From 542ccadb18a3af51ac0518b0463059b8a87c0c94 Mon Sep 17 00:00:00 2001 From: Pietro Date: Fri, 22 Feb 2019 11:53:54 +0000 Subject: [PATCH] Protect access to gl and igtongl --- CPV/src/dealloc.f90 | 3 +- CPV/src/init.f90 | 2 +- Modules/recvec.f90 | 70 ++++++++++++++++++++++++++++++++++++-- Modules/recvec_subs.f90 | 55 ------------------------------ PP/src/vasp_xml_module.f90 | 2 +- PW/src/clean_pw.f90 | 18 ++-------- PW/src/exx_band.f90 | 2 +- PW/src/init_run.f90 | 2 +- PW/src/read_file_new.f90 | 2 +- 9 files changed, 77 insertions(+), 79 deletions(-) diff --git a/CPV/src/dealloc.f90 b/CPV/src/dealloc.f90 index 63e80aea2..21565b48e 100644 --- a/CPV/src/dealloc.f90 +++ b/CPV/src/dealloc.f90 @@ -59,7 +59,8 @@ SUBROUTINE deallocate_modules_var() CALL deallocate_cg( ) CALL deallocate_core() CALL deallocate_uspp() - CALL deallocate_gvect() + CALL deallocate_gvect(.TRUE.) ! Value .true. is hard coded in init.f90:195, + ! here it prevents double free of gg variable. CALL deallocate_gvecw() CALL deallocate_smallbox_gvec( ) CALL deallocate_local_pseudo() diff --git a/CPV/src/init.f90 b/CPV/src/init.f90 index ee6a9bb90..c9c9f1284 100644 --- a/CPV/src/init.f90 +++ b/CPV/src/init.f90 @@ -31,7 +31,7 @@ USE recvec_subs, ONLY: ggen, ggens USE gvect, ONLY: mill_g, eigts1,eigts2,eigts3, g, gg, & ecutrho, gcutm, gvect_init, mill, & - ig_l2g, gstart, ngm, ngm_g + ig_l2g, gstart, ngm, ngm_g, gshells use gvecs, only: gcutms, gvecs_init, ngms use gvecw, only: gkcut, gvecw_init, g2kin_init USE smallbox_subs, ONLY: ggenb diff --git a/Modules/recvec.f90 b/Modules/recvec.f90 index 35d059ad5..9a466de2d 100644 --- a/Modules/recvec.f90 +++ b/Modules/recvec.f90 @@ -41,8 +41,8 @@ ! gl(i) = i-th shell of G^2 (in units of tpiba2) ! igtongl(n) = shell index for n-th G-vector ! - REAL(DP), POINTER :: gl(:) - INTEGER, ALLOCATABLE, TARGET :: igtongl(:) + REAL(DP), POINTER, PROTECTED :: gl(:) + INTEGER, ALLOCATABLE, TARGET, PROTECTED :: igtongl(:) ! ! G-vectors cartesian components ( in units tpiba =(2pi/a) ) ! @@ -103,7 +103,18 @@ ! END SUBROUTINE gvect_init - SUBROUTINE deallocate_gvect() + SUBROUTINE deallocate_gvect(vc) + IMPLICIT NONE + ! + LOGICAL, OPTIONAL, INTENT(IN) :: vc + LOGICAL :: vc_ + ! + vc_ = .false. + IF (PRESENT(vc)) vc_ = vc + IF ( .NOT. vc_ ) THEN + IF ( ASSOCIATED( gl ) ) DEALLOCATE ( gl ) + END IF + ! IF( ALLOCATED( gg ) ) DEALLOCATE( gg ) IF( ALLOCATED( g ) ) DEALLOCATE( g ) IF( ALLOCATED( mill_g ) ) DEALLOCATE( mill_g ) @@ -122,6 +133,59 @@ IF( ALLOCATED( igtongl ) ) DEALLOCATE( igtongl ) IF( ALLOCATED( ig_l2g ) ) DEALLOCATE( ig_l2g ) END SUBROUTINE deallocate_gvect_exx + ! + !----------------------------------------------------------------------- + SUBROUTINE gshells ( vc ) + !---------------------------------------------------------------------- + ! + ! calculate number of G shells: ngl, and the index ng = igtongl(ig) + ! that gives the shell index ng for (local) G-vector of index ig + ! + USE kinds, ONLY : DP + USE constants, ONLY : eps8 + ! + IMPLICIT NONE + ! + LOGICAL, INTENT(IN) :: vc + ! + INTEGER :: ng, igl + ! + IF ( vc ) THEN + ! + ! in case of a variable cell run each G vector has its shell + ! + ngl = ngm + gl => gg + DO ng = 1, ngm + igtongl (ng) = ng + ENDDO + ELSE + ! + ! G vectors are grouped in shells with the same norm + ! + ngl = 1 + igtongl (1) = 1 + DO ng = 2, ngm + IF (gg (ng) > gg (ng - 1) + eps8) THEN + ngl = ngl + 1 + ENDIF + igtongl (ng) = ngl + ENDDO + + ALLOCATE (gl( ngl)) + gl (1) = gg (1) + igl = 1 + DO ng = 2, ngm + IF (gg (ng) > gg (ng - 1) + eps8) THEN + igl = igl + 1 + gl (igl) = gg (ng) + ENDIF + ENDDO + + IF (igl /= ngl) CALL errore ('gshells', 'igl <> ngl', ngl) + + ENDIF + END SUBROUTINE gshells !=----------------------------------------------------------------------------=! END MODULE gvect !=----------------------------------------------------------------------------=! diff --git a/Modules/recvec_subs.f90 b/Modules/recvec_subs.f90 index 236c525e3..4ee0638f1 100644 --- a/Modules/recvec_subs.f90 +++ b/Modules/recvec_subs.f90 @@ -318,58 +318,3 @@ CONTAINS !=----------------------------------------------------------------------= END MODULE recvec_subs !=----------------------------------------------------------------------= -! -!----------------------------------------------------------------------- -SUBROUTINE gshells ( vc ) - !---------------------------------------------------------------------- - ! - ! calculate number of G shells: ngl, and the index ng = igtongl(ig) - ! that gives the shell index ng for (local) G-vector of index ig - ! - USE kinds, ONLY : DP - USE gvect, ONLY : gg, ngm, gl, ngl, igtongl - USE constants, ONLY : eps8 - ! - IMPLICIT NONE - ! - LOGICAL, INTENT(IN) :: vc - ! - INTEGER :: ng, igl - ! - IF ( vc ) THEN - ! - ! in case of a variable cell run each G vector has its shell - ! - ngl = ngm - gl => gg - DO ng = 1, ngm - igtongl (ng) = ng - ENDDO - ELSE - ! - ! G vectors are grouped in shells with the same norm - ! - ngl = 1 - igtongl (1) = 1 - DO ng = 2, ngm - IF (gg (ng) > gg (ng - 1) + eps8) THEN - ngl = ngl + 1 - ENDIF - igtongl (ng) = ngl - ENDDO - - ALLOCATE (gl( ngl)) - gl (1) = gg (1) - igl = 1 - DO ng = 2, ngm - IF (gg (ng) > gg (ng - 1) + eps8) THEN - igl = igl + 1 - gl (igl) = gg (ng) - ENDIF - ENDDO - - IF (igl /= ngl) CALL errore ('gshells', 'igl <> ngl', ngl) - - ENDIF - - END SUBROUTINE gshells diff --git a/PP/src/vasp_xml_module.f90 b/PP/src/vasp_xml_module.f90 index de27b4826..d3a7b44df 100644 --- a/PP/src/vasp_xml_module.f90 +++ b/PP/src/vasp_xml_module.f90 @@ -110,7 +110,7 @@ SUBROUTINE readxmlfile_vasp(iexch,icorr,igcx,igcc,inlc,ierr) USE fft_types, ONLY : fft_type_allocate USE recvec_subs, ONLY : ggen, ggens USE gvect, ONLY : gg, ngm, g, gcutm, mill, ngm_g, ig_l2g, & - eigts1, eigts2, eigts3, gstart + eigts1, eigts2, eigts3, gstart, gshells USE fft_base, ONLY : dfftp, dffts USE gvecs, ONLY : ngms, gcutms USE spin_orb, ONLY : lspinorb, domag diff --git a/PW/src/clean_pw.f90 b/PW/src/clean_pw.f90 index 6c3ff7828..c37ed00be 100644 --- a/PW/src/clean_pw.f90 +++ b/PW/src/clean_pw.f90 @@ -24,12 +24,10 @@ SUBROUTINE clean_pw( lflag ) USE basis, ONLY : swfcatom USE cellmd, ONLY : lmovecell USE ions_base, ONLY : deallocate_ions_base - USE gvect, ONLY : g, gg, gl, igtongl, mill, & - eigts1, eigts2, eigts3 USE fixed_occ, ONLY : f_inp USE ktetra, ONLY : deallocate_tetra USE klist, ONLY : deallocate_igk - USE gvect, ONLY : ig_l2g + USE gvect, ONLY : deallocate_gvect USE vlocal, ONLY : strf, vloc USE wvfct, ONLY : g2kin, et, wg, btype USE force_mod, ONLY : force @@ -108,21 +106,14 @@ SUBROUTINE clean_pw( lflag ) ! IF ( ALLOCATED( f_inp ) .and. lflag ) DEALLOCATE( f_inp ) ! - ! ... arrays allocated in ggen.f90 + ! ... arrays in gvect module ! - IF ( ALLOCATED( ig_l2g ) ) DEALLOCATE( ig_l2g ) - IF ( .NOT. lmovecell ) THEN - IF ( ASSOCIATED( gl ) ) DEALLOCATE ( gl ) - END IF + CALL deallocate_gvect(lmovecell) ! CALL sym_rho_deallocate ( ) ! ! ... arrays allocated in allocate_fft.f90 ( and never deallocated ) ! - IF ( ALLOCATED( g ) ) DEALLOCATE( g ) - IF ( ALLOCATED( gg ) ) DEALLOCATE( gg ) - IF ( ALLOCATED( igtongl ) ) DEALLOCATE( igtongl ) - IF ( ALLOCATED( mill ) ) DEALLOCATE( mill ) call destroy_scf_type(rho) call destroy_scf_type(v) call destroy_scf_type(vnew) @@ -143,9 +134,6 @@ SUBROUTINE clean_pw( lflag ) IF ( ALLOCATED( cutoff_2D ) ) DEALLOCATE( cutoff_2D ) IF ( ALLOCATED( lr_Vloc ) ) DEALLOCATE( lr_Vloc ) IF ( ALLOCATED( strf ) ) DEALLOCATE( strf ) - IF ( ALLOCATED( eigts1 ) ) DEALLOCATE( eigts1 ) - IF ( ALLOCATED( eigts2 ) ) DEALLOCATE( eigts2 ) - IF ( ALLOCATED( eigts3 ) ) DEALLOCATE( eigts3 ) ! ! ... arrays allocated in allocate_nlpot.f90 ( and never deallocated ) ! diff --git a/PW/src/exx_band.f90 b/PW/src/exx_band.f90 index 23d735043..d0f7e5ca7 100644 --- a/PW/src/exx_band.f90 +++ b/PW/src/exx_band.f90 @@ -943,7 +943,7 @@ MODULE exx_band USE cellmd, ONLY : lmovecell USE wvfct, ONLY : npwx USE gvect, ONLY : gcutm, ig_l2g, g, gg, ngm, ngm_g, mill, & - gstart, gvect_init, deallocate_gvect_exx + gstart, gvect_init, deallocate_gvect_exx, gshells USE gvecs, ONLY : gcutms, ngms, ngms_g, gvecs_init USE gvecw, ONLY : gkcut, ecutwfc, gcutw USE klist, ONLY : xk, nks, ngk diff --git a/PW/src/init_run.f90 b/PW/src/init_run.f90 index ca7d55681..298881748 100644 --- a/PW/src/init_run.f90 +++ b/PW/src/init_run.f90 @@ -14,7 +14,7 @@ SUBROUTINE init_run() USE wvfct, ONLY : nbnd, et, wg, btype USE control_flags, ONLY : lmd, gamma_only, smallmem, ts_vdw USE gvect, ONLY : g, gg, mill, gcutm, ig_l2g, ngm, ngm_g, & - gstart ! to be comunicated to the Solvers if gamma_only + gshells, gstart ! to be comunicated to the Solvers if gamma_only USE gvecs, ONLY : gcutms, ngms USE cell_base, ONLY : at, bg, set_h_ainv USE cellmd, ONLY : lmovecell diff --git a/PW/src/read_file_new.f90 b/PW/src/read_file_new.f90 index b6bfa9fb4..5f106899a 100644 --- a/PW/src/read_file_new.f90 +++ b/PW/src/read_file_new.f90 @@ -114,7 +114,7 @@ SUBROUTINE read_xml_file ( wfc_is_collected ) USE fft_types, ONLY : fft_type_allocate USE recvec_subs, ONLY : ggen, ggens USE gvect, ONLY : gg, ngm, g, gcutm, mill, ngm_g, ig_l2g, & - eigts1, eigts2, eigts3, gstart + eigts1, eigts2, eigts3, gstart, gshells USE fft_base, ONLY : dfftp, dffts USE gvecs, ONLY : ngms, gcutms USE spin_orb, ONLY : lspinorb, domag