scnc
/
quantum-espresso
mirror of https://gitlab.com/QEF/q-e.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Fix indentation (N. Nemec) 

git-svn-id: http://qeforge.qe-forge.org/svn/q-e/trunk/espresso@6444 c92efa57-630b-4861-b058-cf58834340f0
This commit is contained in:
nn245 2010-02-22 08:14:43 +00:00
parent e8b49314d3
commit c63ef96da5
3 changed files with 496 additions and 500 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

656
PW/ggen.f90
View File

@ -8,373 +8,371 @@
! !
!----------------------------------------------------------------------- !-----------------------------------------------------------------------
SUBROUTINE ggen() SUBROUTINE ggen()
!---------------------------------------------------------------------- !----------------------------------------------------------------------
! !
! This routine generates all the reciprocal lattice vectors ! This routine generates all the reciprocal lattice vectors
! contained in the sphere of radius gcutm. Furthermore it ! contained in the sphere of radius gcutm. Furthermore it
! computes the indices nl which give the correspondence ! computes the indices nl which give the correspondence
! between the fft mesh points and the array of g vectors. ! between the fft mesh points and the array of g vectors.
! !
USE kinds, ONLY : DP USE kinds, ONLY : DP
USE cell_base, ONLY : at, bg USE cell_base, ONLY : at, bg
USE reciprocal_vectors, ONLY : ig_l2g USE reciprocal_vectors, ONLY : ig_l2g
USE gvect, ONLY : g, gg, ngm, ngm_g, ngm_l, nr1, nr2, nr3, & USE gvect, ONLY : g, gg, ngm, ngm_g, ngm_l, nr1, nr2, nr3, &
gcutm, nrx1, nrx2, nrx3, ig1, ig2, ig3, & gcutm, nrx1, nrx2, nrx3, ig1, ig2, ig3, &
nl, gstart, gl, ngl, igtongl nl, gstart, gl, ngl, igtongl
USE gsmooth, ONLY : ngms, gcutms, ngms_g, nr1s, nr2s, nr3s, & USE gsmooth, ONLY : ngms, gcutms, ngms_g, nr1s, nr2s, nr3s, &
nrx1s, nrx3s, nls nrx1s, nrx3s, nls
USE control_flags, ONLY : gamma_only USE control_flags, ONLY : gamma_only
USE cellmd, ONLY : lmovecell USE cellmd, ONLY : lmovecell
USE constants, ONLY : eps8 USE constants, ONLY : eps8
USE fft_base, ONLY : dfftp, dffts USE fft_base, ONLY : dfftp, dffts
IMPLICIT NONE IMPLICIT NONE
! !
! here a few local variables ! here a few local variables
! !
REAL(DP) :: t (3), tt, swap REAL(DP) :: t (3), tt, swap
REAL(DP), ALLOCATABLE :: esort (:) REAL(DP), ALLOCATABLE :: esort (:)
! !
INTEGER :: ngmx, n1, n2, n3, n1s, n2s, n3s INTEGER :: ngmx, n1, n2, n3, n1s, n2s, n3s
! !
REAL(DP), ALLOCATABLE :: g2sort_g(:) REAL(DP), ALLOCATABLE :: g2sort_g(:)
! array containing all g vectors, on all processors: replicated data ! array containing all g vectors, on all processors: replicated data
INTEGER, ALLOCATABLE :: mill_g(:,:) INTEGER, ALLOCATABLE :: mill_g(:,:)
! array containing all g vectors generators, on all processors: ! array containing all g vectors generators, on all processors:
! replicated data ! replicated data
INTEGER, ALLOCATABLE :: igsrt(:) INTEGER, ALLOCATABLE :: igsrt(:)
! !
#ifdef __PARA #ifdef __PARA
INTEGER :: m1, m2, mc INTEGER :: m1, m2, mc
! !
#endif #endif
INTEGER :: i, j, k, ipol, ng, igl, iswap, indsw INTEGER :: i, j, k, ipol, ng, igl, iswap, indsw
! !
! counters ! counters
! !
! set the total number of fft mesh points and and initial value of gg ! set the total number of fft mesh points and and initial value of gg
! The choice of gcutm is due to the fact that we have to order the ! The choice of gcutm is due to the fact that we have to order the
! vectors after computing them. ! vectors after computing them.
! !
gg(:) = gcutm + 1.d0 gg(:) = gcutm + 1.d0
! !
! set d vector for unique ordering ! set d vector for unique ordering
! !
! and computes all the g vectors inside a sphere ! and computes all the g vectors inside a sphere
! !
ALLOCATE( ig_l2g( ngm_l ) ) ALLOCATE( ig_l2g( ngm_l ) )
ALLOCATE( mill_g( 3, ngm_g ) ) ALLOCATE( mill_g( 3, ngm_g ) )
ALLOCATE( igsrt( ngm_g ) ) ALLOCATE( igsrt( ngm_g ) )
ALLOCATE( g2sort_g( ngm_g ) ) ALLOCATE( g2sort_g( ngm_g ) )
g2sort_g(:) = 1.0d20 g2sort_g(:) = 1.0d20
! !
n1 = nr1 + 1 n1 = nr1 + 1
n2 = nr2 + 1 n2 = nr2 + 1
n3 = nr3 + 1 n3 = nr3 + 1
! !
! save present value of ngm in ngmx variable ! save present value of ngm in ngmx variable
! !
ngmx = ngm ngmx = ngm
! !
ngm = 0 ngm = 0
ngms = 0 ngms = 0
DO i = - n1, n1 DO i = - n1, n1
! !
! Gamma-only: exclude space with x < 0 ! Gamma-only: exclude space with x < 0
! !
IF ( gamma_only .and. i < 0) GOTO 10 IF ( gamma_only .and. i < 0) GOTO 10
DO j = - n2, n2 DO j = - n2, n2
! !
! exclude plane with x = 0, y < 0 ! exclude plane with x = 0, y < 0
! !
IF ( gamma_only .and. i == 0 .and. j < 0) GOTO 11 IF ( gamma_only .and. i == 0 .and. j < 0) GOTO 11
DO k = - n3, n3 DO k = - n3, n3
! !
! exclude line with x = 0, y = 0, z < 0 ! exclude line with x = 0, y = 0, z < 0
! !
IF ( gamma_only .and. i == 0 .and. j == 0 .and. k < 0) GOTO 12 IF ( gamma_only .and. i == 0 .and. j == 0 .and. k < 0) GOTO 12
tt = 0.d0 tt = 0.d0
DO ipol = 1, 3 DO ipol = 1, 3
t (ipol) = i * bg (ipol, 1) + j * bg (ipol, 2) + k * bg (ipol, 3) t (ipol) = i * bg (ipol, 1) + j * bg (ipol, 2) + k * bg (ipol, 3)
tt = tt + t (ipol) * t (ipol) tt = tt + t (ipol) * t (ipol)
ENDDO ENDDO
IF (tt <= gcutm) THEN IF (tt <= gcutm) THEN
ngm = ngm + 1 ngm = ngm + 1
IF (tt <= gcutms) ngms = ngms + 1 IF (tt <= gcutms) ngms = ngms + 1
IF (ngm > ngm_g) CALL errore ('ggen', 'too many g-vectors', ngm) IF (ngm > ngm_g) CALL errore ('ggen', 'too many g-vectors', ngm)
mill_g( 1, ngm ) = i mill_g( 1, ngm ) = i
mill_g( 2, ngm ) = j mill_g( 2, ngm ) = j
mill_g( 3, ngm ) = k mill_g( 3, ngm ) = k
IF ( tt > eps8 ) THEN IF ( tt > eps8 ) THEN
g2sort_g(ngm) = tt g2sort_g(ngm) = tt
ELSE ELSE
g2sort_g(ngm) = 0.d0 g2sort_g(ngm) = 0.d0
ENDIF ENDIF
ENDIF ENDIF
12 CONTINUE 12 CONTINUE
ENDDO ENDDO
11 CONTINUE 11 CONTINUE
ENDDO
10 CONTINUE
ENDDO
IF (ngm /= ngm_g ) &
CALL errore ('ggen', 'g-vectors missing !', abs(ngm - ngm_g))
IF (ngms /= ngms_g) &
CALL errore ('ggen', 'smooth g-vectors missing !', abs(ngms - ngms_g))
igsrt(1) = 0
CALL hpsort_eps( ngm_g, g2sort_g, igsrt, eps8 )
DEALLOCATE( g2sort_g )
DO ng = 1, ngm_g-1
indsw = ng
7 IF(igsrt(indsw) /= ng) THEN
! .. swap indices
DO i = 1, 3
iswap = mill_g(i,indsw)
mill_g(i,indsw) = mill_g(i,igsrt(indsw))
mill_g(i,igsrt(indsw)) = iswap
ENDDO ENDDO
10 CONTINUE
ENDDO
IF (ngm /= ngm_g ) &
CALL errore ('ggen', 'g-vectors missing !', abs(ngm - ngm_g))
IF (ngms /= ngms_g) &
CALL errore ('ggen', 'smooth g-vectors missing !', abs(ngms - ngms_g))
igsrt(1) = 0
CALL hpsort_eps( ngm_g, g2sort_g, igsrt, eps8 )
DEALLOCATE( g2sort_g )
DO ng = 1, ngm_g-1
indsw = ng
7 IF(igsrt(indsw) /= ng) THEN
! .. swap indices ! .. swap indices
iswap = indsw; indsw = igsrt(indsw); igsrt(iswap) = iswap DO i = 1, 3
IF(igsrt(indsw) == ng) THEN iswap = mill_g(i,indsw)
igsrt(indsw)=indsw mill_g(i,indsw) = mill_g(i,igsrt(indsw))
ELSE mill_g(i,igsrt(indsw)) = iswap
GOTO 7 ENDDO
! .. swap indices
iswap = indsw; indsw = igsrt(indsw); igsrt(iswap) = iswap
IF(igsrt(indsw) == ng) THEN
igsrt(indsw)=indsw
ELSE
GOTO 7
ENDIF
ENDIF ENDIF
ENDIF ENDDO
ENDDO
DEALLOCATE( igsrt ) DEALLOCATE( igsrt )
! WRITE( stdout, fmt="(//,' --- Executing new GGEN Loop ---',//)" ) ! WRITE( stdout, fmt="(//,' --- Executing new GGEN Loop ---',//)" )
ALLOCATE(esort(ngm) ) ALLOCATE(esort(ngm) )
esort(:) = 1.0d20 esort(:) = 1.0d20
ngm = 0 ngm = 0
ngms = 0 ngms = 0
DO ng = 1, ngm_g DO ng = 1, ngm_g
i = mill_g(1, ng) i = mill_g(1, ng)
j = mill_g(2, ng) j = mill_g(2, ng)
k = mill_g(3, ng) k = mill_g(3, ng)
#ifdef __PARA #ifdef __PARA
m1 = mod (i, nr1) + 1 m1 = mod (i, nr1) + 1
IF (m1.lt.1) m1 = m1 + nr1 IF (m1.lt.1) m1 = m1 + nr1
m2 = mod (j, nr2) + 1 m2 = mod (j, nr2) + 1
IF (m2.lt.1) m2 = m2 + nr2 IF (m2.lt.1) m2 = m2 + nr2
mc = m1 + (m2 - 1) * nrx1 mc = m1 + (m2 - 1) * nrx1
IF ( dfftp%isind ( mc ) .eq.0) GOTO 1 IF ( dfftp%isind ( mc ) .eq.0) GOTO 1
#endif #endif
tt = 0.d0 tt = 0.d0
DO ipol = 1, 3 DO ipol = 1, 3
t (ipol) = i * bg (ipol, 1) + j * bg (ipol, 2) + k * bg (ipol, 3) t (ipol) = i * bg (ipol, 1) + j * bg (ipol, 2) + k * bg (ipol, 3)
tt = tt + t (ipol) * t (ipol) tt = tt + t (ipol) * t (ipol)
ENDDO ENDDO
ngm = ngm + 1 ngm = ngm + 1
IF (tt <= gcutms) ngms = ngms + 1 IF (tt <= gcutms) ngms = ngms + 1
IF (ngm > ngmx) CALL errore ('ggen', 'too many g-vectors', ngm) IF (ngm > ngmx) CALL errore ('ggen', 'too many g-vectors', ngm)
! !
! Here map local and global g index !!! ! Here map local and global g index !!!
! !
ig_l2g( ngm ) = ng ig_l2g( ngm ) = ng
! !
g (1:3, ngm) = t (1:3) g (1:3, ngm) = t (1:3)
gg (ngm) = tt gg (ngm) = tt
IF (tt > eps8) THEN IF (tt > eps8) THEN
esort (ngm) = tt esort (ngm) = tt
ELSE ELSE
esort (ngm) = 0.d0 esort (ngm) = 0.d0
ENDIF ENDIF
1 CONTINUE 1 CONTINUE
ENDDO ENDDO
IF (ngm.ne.ngmx) & IF (ngm.ne.ngmx) &
CALL errore ('ggen', 'g-vectors missing !', abs(ngm - ngmx)) CALL errore ('ggen', 'g-vectors missing !', abs(ngm - ngmx))
! !
! reorder the g's in order of increasing magnitude. On exit ! reorder the g's in order of increasing magnitude. On exit
! from hpsort esort is ordered, and nl contains the new order. ! from hpsort esort is ordered, and nl contains the new order.
! !
! initialize the index inside sorting routine ! initialize the index inside sorting routine
nl (1) = 0 nl (1) = 0
CALL hpsort_eps ( ngm, esort, nl, eps8 ) CALL hpsort_eps ( ngm, esort, nl, eps8 )
! !
DEALLOCATE( esort ) DEALLOCATE( esort )
! !
! reorder also the g vectors, and nl ! reorder also the g vectors, and nl
! !
DO ng = 1, ngm - 1 DO ng = 1, ngm - 1
20 indsw = nl (ng) 20 indsw = nl (ng)
IF (indsw.ne.ng) THEN IF (indsw.ne.ng) THEN
DO ipol = 1, 3 DO ipol = 1, 3
swap = g (ipol, indsw) swap = g (ipol, indsw)
g (ipol, indsw) = g (ipol, nl (indsw) ) g (ipol, indsw) = g (ipol, nl (indsw) )
g (ipol, nl (indsw) ) = swap g (ipol, nl (indsw) ) = swap
ENDDO ENDDO
swap = gg (indsw) swap = gg (indsw)
gg (indsw) = gg (nl (indsw) ) gg (indsw) = gg (nl (indsw) )
gg (nl (indsw) ) = swap gg (nl (indsw) ) = swap
! !
! Remember: ig_l2g is the index of a given G vectors in the ! Remember: ig_l2g is the index of a given G vectors in the
! sorted global array containing all G vectors, it is used to ! sorted global array containing all G vectors, it is used to
! collect all wave function components ! collect all wave function components
! !
iswap = ig_l2g( indsw ) iswap = ig_l2g( indsw )
ig_l2g( indsw ) = ig_l2g( nl(indsw) ) ig_l2g( indsw ) = ig_l2g( nl(indsw) )
ig_l2g( nl(indsw) ) = iswap ig_l2g( nl(indsw) ) = iswap
iswap = nl (ng) iswap = nl (ng)
nl (ng) = nl (indsw) nl (ng) = nl (indsw)
nl (indsw) = iswap nl (indsw) = iswap
GOTO 20 GOTO 20
ENDIF ENDIF
ENDDO ENDDO
! !
! here to initialize berry_phase ! here to initialize berry_phase
! CALL berry_setup(ngm, ngm_g, nr1, nr2, nr3, mill_g) ! CALL berry_setup(ngm, ngm_g, nr1, nr2, nr3, mill_g)
! !
! determine first nonzero g vector ! determine first nonzero g vector
! !
IF (gg(1).le.eps8) THEN IF (gg(1).le.eps8) THEN
gstart=2 gstart=2
ELSE ELSE
gstart=1 gstart=1
ENDIF ENDIF
! !
! Now set nl and nls with the correct fft correspondence ! Now set nl and nls with the correct fft correspondence
! !
DO ng = 1, ngm DO ng = 1, ngm
n1 = nint (g (1, ng) * at (1, 1) + g (2, ng) * at (2, 1) + g (3, & n1 = nint (g (1, ng) * at (1, 1) + g (2, ng) * at (2, 1) + g (3, &
ng) * at (3, 1) ) + 1 ng) * at (3, 1) ) + 1
ig1 (ng) = n1 - 1 ig1 (ng) = n1 - 1
n1s = n1 n1s = n1
IF (n1.lt.1) n1 = n1 + nr1 IF (n1.lt.1) n1 = n1 + nr1
IF (n1s.lt.1) n1s = n1s + nr1s IF (n1s.lt.1) n1s = n1s + nr1s
n2 = nint (g (1, ng) * at (1, 2) + g (2, ng) * at (2, 2) + g (3, & n2 = nint (g (1, ng) * at (1, 2) + g (2, ng) * at (2, 2) + g (3, &
ng) * at (3, 2) ) + 1 ng) * at (3, 2) ) + 1
ig2 (ng) = n2 - 1 ig2 (ng) = n2 - 1
n2s = n2 n2s = n2
IF (n2.lt.1) n2 = n2 + nr2 IF (n2.lt.1) n2 = n2 + nr2
IF (n2s.lt.1) n2s = n2s + nr2s IF (n2s.lt.1) n2s = n2s + nr2s
n3 = nint (g (1, ng) * at (1, 3) + g (2, ng) * at (2, 3) + g (3, & n3 = nint (g (1, ng) * at (1, 3) + g (2, ng) * at (2, 3) + g (3, &
ng) * at (3, 3) ) + 1 ng) * at (3, 3) ) + 1
ig3 (ng) = n3 - 1 ig3 (ng) = n3 - 1
n3s = n3 n3s = n3
IF (n3.lt.1) n3 = n3 + nr3 IF (n3.lt.1) n3 = n3 + nr3
IF (n3s.lt.1) n3s = n3s + nr3s IF (n3s.lt.1) n3s = n3s + nr3s
IF (n1.le.nr1.and.n2.le.nr2.and.n3.le.nr3) THEN IF (n1.le.nr1.and.n2.le.nr2.and.n3.le.nr3) THEN
#if defined (__PARA) && !defined (__USE_3D_FFT) #if defined (__PARA) && !defined (__USE_3D_FFT)
nl (ng) = n3 + ( dfftp%isind (n1 + (n2 - 1) * nrx1) - 1) * nrx3 nl (ng) = n3 + ( dfftp%isind (n1 + (n2 - 1) * nrx1) - 1) * nrx3
IF (ng.le.ngms) nls (ng) = n3s + ( dffts%isind (n1s + (n2s - 1) & IF (ng.le.ngms) nls (ng) = n3s + ( dffts%isind (n1s + (n2s - 1) &
* nrx1s) - 1) * nrx3s * nrx1s) - 1) * nrx3s
#else #else
nl (ng) = n1 + (n2 - 1) * nrx1 + (n3 - 1) * nrx1 * nrx2 nl (ng) = n1 + (n2 - 1) * nrx1 + (n3 - 1) * nrx1 * nrx2
IF (ng.le.ngms) nls (ng) = n1s + (n2s - 1) * nrx1s + (n3s - 1) & IF (ng.le.ngms) nls (ng) = n1s + (n2s - 1) * nrx1s + (n3s - 1) &
* nrx1s * nr2s * nrx1s * nr2s
#endif #endif
ELSE ELSE
CALL errore('ggen','Mesh too small?',ng) CALL errore('ggen','Mesh too small?',ng)
ENDIF ENDIF
ENDDO ENDDO
! !
DEALLOCATE( mill_g ) DEALLOCATE( mill_g )
! !
! calculate number of G shells: ngl ! calculate number of G shells: ngl
! !
IF (lmovecell) THEN IF (lmovecell) THEN
! !
! in case of a variable cell run each G vector has its shell ! in case of a variable cell run each G vector has its shell
! !
ngl = ngm ngl = ngm
gl => gg gl => gg
DO ng = 1, ngm DO ng = 1, ngm
igtongl (ng) = ng igtongl (ng) = ng
ENDDO ENDDO
ELSE ELSE
! !
! G vectors are grouped in shells with the same norm ! G vectors are grouped in shells with the same norm
! !
ngl = 1 ngl = 1
igtongl (1) = 1 igtongl (1) = 1
DO ng = 2, ngm DO ng = 2, ngm
IF (gg (ng) > gg (ng - 1) + eps8) THEN IF (gg (ng) > gg (ng - 1) + eps8) THEN
ngl = ngl + 1 ngl = ngl + 1
ENDIF ENDIF
igtongl (ng) = ngl igtongl (ng) = ngl
ENDDO ENDDO
ALLOCATE (gl( ngl)) ALLOCATE (gl( ngl))
gl (1) = gg (1) gl (1) = gg (1)
igl = 1 igl = 1
DO ng = 2, ngm DO ng = 2, ngm
IF (gg (ng) > gg (ng - 1) + eps8) THEN IF (gg (ng) > gg (ng - 1) + eps8) THEN
igl = igl + 1 igl = igl + 1
gl (igl) = gg (ng) gl (igl) = gg (ng)
ENDIF ENDIF
ENDDO ENDDO
IF (igl.ne.ngl) CALL errore ('setup', 'igl <> ngl', ngl) IF (igl.ne.ngl) CALL errore ('setup', 'igl <> ngl', ngl)
ENDIF ENDIF
IF ( gamma_only) CALL index_minusg() IF ( gamma_only) CALL index_minusg()
RETURN END SUBROUTINE ggen
END SUBROUTINE ggen
! !
!----------------------------------------------------------------------- !-----------------------------------------------------------------------
SUBROUTINE index_minusg() SUBROUTINE index_minusg()
!---------------------------------------------------------------------- !----------------------------------------------------------------------
! !
! compute indices nlm and nlms giving the correspondence ! compute indices nlm and nlms giving the correspondence
! between the fft mesh points and -G (for gamma-only calculations) ! between the fft mesh points and -G (for gamma-only calculations)
! !
USE gvect, ONLY : ngm, nr1, nr2, nr3, & USE gvect, ONLY : ngm, nr1, nr2, nr3, &
nrx1, nrx2, nrx3, nlM, ig1, ig2, ig3 nrx1, nrx2, nrx3, nlM, ig1, ig2, ig3
USE gsmooth, ONLY : nr1s, nr2s, nr3s, nrx1s, nrx3s, nlsm, ngms USE gsmooth, ONLY : nr1s, nr2s, nr3s, nrx1s, nrx3s, nlsm, ngms
USE fft_base, ONLY : dfftp, dffts USE fft_base, ONLY : dfftp, dffts
IMPLICIT NONE IMPLICIT NONE
! !
INTEGER :: n1, n2, n3, n1s, n2s, n3s, ng INTEGER :: n1, n2, n3, n1s, n2s, n3s, ng
! !
! !
DO ng = 1, ngm DO ng = 1, ngm
n1 = -ig1 (ng) + 1 n1 = -ig1 (ng) + 1
n1s = n1 n1s = n1
IF (n1 < 1) n1 = n1 + nr1 IF (n1 < 1) n1 = n1 + nr1
IF (n1s < 1) n1s = n1s + nr1s IF (n1s < 1) n1s = n1s + nr1s
n2 = -ig2 (ng) + 1 n2 = -ig2 (ng) + 1
n2s = n2 n2s = n2
IF (n2 < 1) n2 = n2 + nr2 IF (n2 < 1) n2 = n2 + nr2
IF (n2s < 1) n2s = n2s + nr2s IF (n2s < 1) n2s = n2s + nr2s
n3 = -ig3 (ng) + 1 n3 = -ig3 (ng) + 1
n3s = n3 n3s = n3
IF (n3 < 1) n3 = n3 + nr3 IF (n3 < 1) n3 = n3 + nr3
IF (n3s < 1) n3s = n3s + nr3s IF (n3s < 1) n3s = n3s + nr3s
IF (n1.le.nr1 .and. n2.le.nr2 .and. n3.le.nr3) THEN IF (n1.le.nr1 .and. n2.le.nr2 .and. n3.le.nr3) THEN
#if defined (__PARA) && !defined (__USE_3D_FFT) #if defined (__PARA) && !defined (__USE_3D_FFT)
nlm(ng) = n3 + (dfftp%isind (n1 + (n2 - 1) * nrx1) - 1) * nrx3 nlm(ng) = n3 + (dfftp%isind (n1 + (n2 - 1) * nrx1) - 1) * nrx3
IF (ng.le.ngms) nlsm(ng) = n3s + (dffts%isind (n1s + (n2s - 1) & IF (ng.le.ngms) nlsm(ng) = n3s + (dffts%isind (n1s + (n2s - 1) &
* nrx1s) - 1) * nrx3s * nrx1s) - 1) * nrx3s
#else #else
nlm(ng) = n1 + (n2 - 1) * nrx1 + (n3 - 1) * nrx1 * nrx2 nlm(ng) = n1 + (n2 - 1) * nrx1 + (n3 - 1) * nrx1 * nrx2
IF (ng.le.ngms) nlsm(ng) = n1s + (n2s - 1) * nrx1s + (n3s - 1) & IF (ng.le.ngms) nlsm(ng) = n1s + (n2s - 1) * nrx1s + (n3s - 1) &
* nrx1s * nr2s * nrx1s * nr2s
#endif #endif
ELSE ELSE
CALL errore('index_minusg','Mesh too small?',ng) CALL errore('index_minusg','Mesh too small?',ng)
ENDIF ENDIF
ENDDO ENDDO
RETURN
END SUBROUTINE index_minusg END SUBROUTINE index_minusg

196
PW/gk_sort.f90
View File

@ -7,104 +7,102 @@
! !
!---------------------------------------------------------------------------- !----------------------------------------------------------------------------
SUBROUTINE gk_sort( k, ngm, g, ecut, ngk, igk, gk ) SUBROUTINE gk_sort( k, ngm, g, ecut, ngk, igk, gk )
!---------------------------------------------------------------------------- !----------------------------------------------------------------------------
! !
! ... sorts k+g in order of increasing magnitude, up to ecut ! ... sorts k+g in order of increasing magnitude, up to ecut
! ... NB: this version will yield the same ordering for different ecut ! ... NB: this version will yield the same ordering for different ecut
! ... and the same ordering in all machines ! ... and the same ordering in all machines
! !
USE kinds, ONLY : DP USE kinds, ONLY : DP
USE constants, ONLY : eps8 USE constants, ONLY : eps8
USE wvfct, ONLY : npwx USE wvfct, ONLY : npwx
! !
IMPLICIT NONE IMPLICIT NONE
! !
! ... Here the dummy variables ! ... Here the dummy variables
! !
INTEGER, INTENT(in) :: ngm INTEGER, INTENT(in) :: ngm
! input : the number of g vectors ! input : the number of g vectors
INTEGER, INTENT(inout) :: ngk INTEGER, INTENT(inout) :: ngk
! input/output : the number of k+G vectors inside the "ecut sphere" ! input/output : the number of k+G vectors inside the "ecut sphere"
INTEGER, INTENT(out) :: igk(npwx) INTEGER, INTENT(out) :: igk(npwx)
! output : the correspondence k+G <-> G ! output : the correspondence k+G <-> G
REAL(DP), INTENT(in) :: k(3), g(3,ngm), ecut REAL(DP), INTENT(in) :: k(3), g(3,ngm), ecut
! input : the k point ! input : the k point
! input : the coordinates of G vectors ! input : the coordinates of G vectors
! input : the cut-off energy ! input : the cut-off energy
REAL(DP), INTENT(out) :: gk(npwx) REAL(DP), INTENT(out) :: gk(npwx)
! output : the moduli of k+G ! output : the moduli of k+G
! !
INTEGER :: ng, nk INTEGER :: ng, nk
! counter on G vectors ! counter on G vectors
! counter on k+G vectors ! counter on k+G vectors
REAL(DP) :: q, q2x REAL(DP) :: q, q2x
! |k+G|^2 ! |k+G|^2
! upper bound for |G| ! upper bound for |G|
! !
! !
! ... first we count the number of k+G vectors inside the cut-off sphere ! ... first we count the number of k+G vectors inside the cut-off sphere
! !
q2x = ( sqrt( k(1)**2 + k(2)**2 + k(3)**2 ) + sqrt( ecut ) )**2 q2x = ( sqrt( k(1)**2 + k(2)**2 + k(3)**2 ) + sqrt( ecut ) )**2
! !
ngk = 0 ngk = 0
! !
DO ng = 1, ngm DO ng = 1, ngm
! !
q = ( k(1) + g(1,ng) )**2 + ( k(2) + g(2,ng) )**2 + ( k(3) + g(3,ng) )**2 q = ( k(1) + g(1,ng) )**2 + ( k(2) + g(2,ng) )**2 + ( k(3) + g(3,ng) )**2
! !
! ... here if |k+G|^2 <= Ecut ! ... here if |k+G|^2 <= Ecut
! !
IF ( q <= ecut ) THEN IF ( q <= ecut ) THEN
! !
ngk = ngk + 1 ngk = ngk + 1
! !
! ... gk is a fake quantity giving the same ordering on all machines ! ... gk is a fake quantity giving the same ordering on all machines
! !
IF ( ngk > npwx ) & IF ( ngk > npwx ) &
CALL errore( 'gk_sort', 'array gk out-of-bounds', 1 ) CALL errore( 'gk_sort', 'array gk out-of-bounds', 1 )
! !
IF ( q > eps8 ) THEN IF ( q > eps8 ) THEN
! !
gk(ngk) = q gk(ngk) = q
! !
ELSE ELSE
! !
gk(ngk) = 0.D0 gk(ngk) = 0.D0
! !
ENDIF ENDIF
! !
! ... set the initial value of index array ! ... set the initial value of index array
! !
igk(ngk) = ng igk(ngk) = ng
! !
ELSE ELSE
! !
! ... if |G| > |k| + SQRT( Ecut ) stop search and order vectors ! ... if |G| > |k| + SQRT( Ecut ) stop search and order vectors
! !
IF ( ( g(1,ng)**2 + g(2,ng)**2 + g(3,ng)**2 ) > ( q2x + eps8 ) ) exit IF ( ( g(1,ng)**2 + g(2,ng)**2 + g(3,ng)**2 ) > ( q2x + eps8 ) ) exit
! !
ENDIF ENDIF
! !
ENDDO ENDDO
! !
IF ( ng > ngm ) & IF ( ng > ngm ) &
CALL infomsg( 'gk_sort', 'unexpected exit from do-loop') CALL infomsg( 'gk_sort', 'unexpected exit from do-loop')
! !
! ... order vector gk keeping initial position in index ! ... order vector gk keeping initial position in index
! !
CALL hpsort_eps( ngk, gk, igk, eps8 ) CALL hpsort_eps( ngk, gk, igk, eps8 )
! !
! ... now order true |k+G| ! ... now order true |k+G|
! !
DO nk = 1, ngk DO nk = 1, ngk
! !
gk(nk) = ( k(1) + g(1,igk(nk) ) )**2 + & gk(nk) = ( k(1) + g(1,igk(nk) ) )**2 + &
( k(2) + g(2,igk(nk) ) )**2 + & ( k(2) + g(2,igk(nk) ) )**2 + &
( k(3) + g(3,igk(nk) ) )**2 ( k(3) + g(3,igk(nk) ) )**2
! !
ENDDO ENDDO
! !
RETURN
!
END SUBROUTINE gk_sort END SUBROUTINE gk_sort

144
PW/realus.f90
View File

@ -51,13 +51,13 @@ MODULE realus
! !
CONTAINS CONTAINS
! !
!------------------------------------------------------------------------ !------------------------------------------------------------------------
SUBROUTINE read_rs_status( dirname, ierr ) SUBROUTINE read_rs_status( dirname, ierr )
!------------------------------------------------------------------------ !------------------------------------------------------------------------
! !
! This subroutine reads the real space control flags from a pwscf punch card ! This subroutine reads the real space control flags from a pwscf punch card
! OBM 2009 ! OBM 2009
! !
USE iotk_module USE iotk_module
USE io_global, ONLY : ionode,ionode_id USE io_global, ONLY : ionode,ionode_id
USE io_files, ONLY : iunpun, xmlpun USE io_files, ONLY : iunpun, xmlpun
@ -106,9 +106,9 @@ MODULE realus
END SUBROUTINE read_rs_status END SUBROUTINE read_rs_status
!---------------------------------------------------------------------------- !----------------------------------------------------------------------------
SUBROUTINE init_realspace_vars() SUBROUTINE init_realspace_vars()
!--------------------------------------------------------------------------- !---------------------------------------------------------------------------
!This subroutine should be called to allocate/reset real space related variables. !This subroutine should be called to allocate/reset real space related variables.
!--------------------------------------------------------------------------- !---------------------------------------------------------------------------
USE wvfct, ONLY : npwx,npw, igk, g2kin USE wvfct, ONLY : npwx,npw, igk, g2kin
USE klist, ONLY : nks,xk USE klist, ONLY : nks,xk
USE gvect, ONLY : ngm, g, ecutwfc USE gvect, ONLY : ngm, g, ecutwfc
@ -1712,10 +1712,10 @@ MODULE realus
END SUBROUTINE calbec_rs_gamma END SUBROUTINE calbec_rs_gamma
! !
SUBROUTINE calbec_rs_k ( ibnd, m ) SUBROUTINE calbec_rs_k ( ibnd, m )
!-------------------------------------------------------------------------- !--------------------------------------------------------------------------
! The k_point generalised version of calbec_rs_gamma. Basically same as above, but becp is used instead ! The k_point generalised version of calbec_rs_gamma. Basically same as above, but becp is used instead
! of becp_r, skipping the gamma point reduction ! of becp_r, skipping the gamma point reduction
! derived from above by OBM 051108 ! derived from above by OBM 051108
USE kinds, ONLY : DP USE kinds, ONLY : DP
USE cell_base, ONLY : omega USE cell_base, ONLY : omega
USE wavefunctions_module, ONLY : psic USE wavefunctions_module, ONLY : psic
@ -1793,13 +1793,13 @@ MODULE realus
END SUBROUTINE calbec_rs_k END SUBROUTINE calbec_rs_k
!-------------------------------------------------------------------------- !--------------------------------------------------------------------------
SUBROUTINE s_psir_gamma ( ibnd, m ) SUBROUTINE s_psir_gamma ( ibnd, m )
!-------------------------------------------------------------------------- !--------------------------------------------------------------------------
! !
! ... This routine applies the S matrix to m wavefunctions psi in real space (in psic), ! ... This routine applies the S matrix to m wavefunctions psi in real space (in psic),
! ... and puts the results again in psic for backtransforming. ! ... and puts the results again in psic for backtransforming.
! ... Requires becp%r (calbecr in REAL SPACE) and betasave (from betapointlist in realus) ! ... Requires becp%r (calbecr in REAL SPACE) and betasave (from betapointlist in realus)
! Subroutine written by Dario Rocca, modified by O. Baris Malcioglu ! Subroutine written by Dario Rocca, modified by O. Baris Malcioglu
! WARNING ! for the sake of speed, no checks performed in this subroutine ! WARNING ! for the sake of speed, no checks performed in this subroutine
USE kinds, ONLY : DP USE kinds, ONLY : DP
USE cell_base, ONLY : omega USE cell_base, ONLY : omega
@ -1821,7 +1821,7 @@ MODULE realus
REAL(DP) :: fac REAL(DP) :: fac
REAL(DP), ALLOCATABLE, DIMENSION(:) :: w1, w2, bcr, bci REAL(DP), ALLOCATABLE, DIMENSION(:) :: w1, w2, bcr, bci
! !
real(DP), EXTERNAL :: ddot REAL(DP), EXTERNAL :: ddot
! !
@ -1923,7 +1923,7 @@ MODULE realus
REAL(DP), ALLOCATABLE, DIMENSION(:) :: bcr, bci REAL(DP), ALLOCATABLE, DIMENSION(:) :: bcr, bci
COMPLEX(DP) , ALLOCATABLE, DIMENSION(:) :: w1 COMPLEX(DP) , ALLOCATABLE, DIMENSION(:) :: w1
! !
real(DP), EXTERNAL :: ddot REAL(DP), EXTERNAL :: ddot
! !
@ -2025,7 +2025,7 @@ MODULE realus
REAL(DP) :: fac REAL(DP) :: fac
REAL(DP), ALLOCATABLE, DIMENSION(:) :: w1, w2, bcr, bci REAL(DP), ALLOCATABLE, DIMENSION(:) :: w1, w2, bcr, bci
! !
real(DP), EXTERNAL :: ddot REAL(DP), EXTERNAL :: ddot
! !
CALL start_clock( 'add_vuspsir' ) CALL start_clock( 'add_vuspsir' )
@ -2131,7 +2131,7 @@ MODULE realus
! !
COMPLEX(DP), ALLOCATABLE, DIMENSION(:) :: w1 COMPLEX(DP), ALLOCATABLE, DIMENSION(:) :: w1
! !
real(DP), EXTERNAL :: ddot REAL(DP), EXTERNAL :: ddot
! !
CALL start_clock( 'add_vuspsir' ) CALL start_clock( 'add_vuspsir' )
@ -2193,22 +2193,22 @@ MODULE realus
ENDDO ENDDO
! !
ENDDO ENDDO
ENDIF ENDIF
CALL stop_clock( 'add_vuspsir' ) CALL stop_clock( 'add_vuspsir' )
RETURN RETURN
! !
END SUBROUTINE add_vuspsir_k END SUBROUTINE add_vuspsir_k
!-------------------------------------------------------------------------- !--------------------------------------------------------------------------
SUBROUTINE fft_orbital_gamma (orbital, ibnd, nbnd, conserved) SUBROUTINE fft_orbital_gamma (orbital, ibnd, nbnd, conserved)
!-------------------------------------------------------------------------- !--------------------------------------------------------------------------
! !
! OBM 241008 ! OBM 241008
! This driver subroutine transforms the given orbital using fft and puts the result in psic ! This driver subroutine transforms the given orbital using fft and puts the result in psic
! Warning! In order to be fast, no checks on the supplied data are performed! ! Warning! In order to be fast, no checks on the supplied data are performed!
! orbital: the orbital to be transformed ! orbital: the orbital to be transformed
! ibnd: band index ! ibnd: band index
! nbnd: total number of bands ! nbnd: total number of bands
USE wavefunctions_module, ONLY : psic USE wavefunctions_module, ONLY : psic
USE gsmooth, ONLY : nr1s,nr2s,nr3s,nrx1s,nrx2s,& USE gsmooth, ONLY : nr1s,nr2s,nr3s,nrx1s,nrx2s,&
nrx3s,nrxxs,nls,nlsm,doublegrid nrx3s,nrxxs,nls,nlsm,doublegrid
@ -2243,12 +2243,12 @@ MODULE realus
INTEGER :: v_siz INTEGER :: v_siz
!The new task group version based on vloc_psi !The new task group version based on vloc_psi
!print *, "->Real space" !print *, "->Real space"
CALL start_clock( 'fft_orbital' ) CALL start_clock( 'fft_orbital' )
use_tg = ( use_task_groups ) .and. ( nbnd >= nogrp ) use_tg = ( use_task_groups ) .and. ( nbnd >= nogrp )
IF( use_tg ) THEN IF( use_tg ) THEN
! !
tg_psic = (0.d0, 0.d0) tg_psic = (0.d0, 0.d0)
@ -2283,7 +2283,7 @@ MODULE realus
ENDIF ENDIF
ENDIF ENDIF
ELSE !Task groups not used ELSE !Task groups not used
! !
psic(:) = (0.d0, 0.d0) psic(:) = (0.d0, 0.d0)
@ -2326,7 +2326,7 @@ MODULE realus
ENDIF ENDIF
ENDIF ENDIF
ENDIF ENDIF
!if (.not. allocated(psic)) CALL errore( 'fft_orbital_gamma', 'psic not allocated', 2 ) !if (.not. allocated(psic)) CALL errore( 'fft_orbital_gamma', 'psic not allocated', 2 )
! OLD VERSION ! Based on an algorithm found somewhere in the TDDFT codes, generalised to k points ! OLD VERSION ! Based on an algorithm found somewhere in the TDDFT codes, generalised to k points
@ -2353,21 +2353,21 @@ MODULE realus
! call cft3s(psic,nr1s,nr2s,nr3s,nrx1s,nrx2s,nrx3s,2) ! call cft3s(psic,nr1s,nr2s,nr3s,nrx1s,nrx2s,nrx3s,2)
CALL stop_clock( 'fft_orbital' ) CALL stop_clock( 'fft_orbital' )
END SUBROUTINE fft_orbital_gamma END SUBROUTINE fft_orbital_gamma
! !
! !
!-------------------------------------------------------------------------- !--------------------------------------------------------------------------
SUBROUTINE bfft_orbital_gamma (orbital, ibnd, nbnd,conserved) SUBROUTINE bfft_orbital_gamma (orbital, ibnd, nbnd,conserved)
!-------------------------------------------------------------------------- !--------------------------------------------------------------------------
! !
! OBM 241008 ! OBM 241008
! This driver subroutine -back- transforms the given orbital using fft using the already existent data ! This driver subroutine -back- transforms the given orbital using fft using the already existent data
! in psic. Warning! This subroutine does not reset the orbital, use carefully! ! in psic. Warning! This subroutine does not reset the orbital, use carefully!
! Warning 2! In order to be fast, no checks on the supplied data are performed! ! Warning 2! In order to be fast, no checks on the supplied data are performed!
! Variables: ! Variables:
! orbital: the orbital to be transformed ! orbital: the orbital to be transformed
! ibnd: band index ! ibnd: band index
! nbnd: total number of bands ! nbnd: total number of bands
USE wavefunctions_module, ONLY : psic USE wavefunctions_module, ONLY : psic
USE gsmooth, ONLY : nr1s,nr2s,nr3s,nrx1s,nrx2s,& USE gsmooth, ONLY : nr1s,nr2s,nr3s,nrx1s,nrx2s,&
nrx3s,nrxxs,nls,nlsm,doublegrid nrx3s,nrxxs,nls,nlsm,doublegrid
@ -2402,7 +2402,7 @@ MODULE realus
!New task_groups versions !New task_groups versions
use_tg = ( use_task_groups ) .and. ( nbnd >= nogrp ) use_tg = ( use_task_groups ) .and. ( nbnd >= nogrp )
IF( use_tg ) THEN IF( use_tg ) THEN
CALL tg_cft3s ( tg_psic, dffts, -2, use_tg ) CALL tg_cft3s ( tg_psic, dffts, -2, use_tg )
! !
ioff = 0 ioff = 0
! !
@ -2432,11 +2432,11 @@ MODULE realus
ENDIF ENDIF
ELSE !Non task_groups version ELSE !Non task_groups version
!larger memory slightly faster !larger memory slightly faster
CALL cft3s(psic,nr1s,nr2s,nr3s,nrx1s,nrx2s,nrx3s,-2) CALL cft3s(psic,nr1s,nr2s,nr3s,nrx1s,nrx2s,nrx3s,-2)
IF (ibnd < nbnd) THEN IF (ibnd < nbnd) THEN
! two ffts at the same time ! two ffts at the same time
DO j = 1, npw_k(1) DO j = 1, npw_k(1)
@ -2491,18 +2491,18 @@ MODULE realus
! !
CALL stop_clock( 'bfft_orbital' ) CALL stop_clock( 'bfft_orbital' )
END SUBROUTINE bfft_orbital_gamma END SUBROUTINE bfft_orbital_gamma
! !
!-------------------------------------------------------------------------- !--------------------------------------------------------------------------
SUBROUTINE fft_orbital_k (orbital, ibnd, nbnd,conserved) SUBROUTINE fft_orbital_k (orbital, ibnd, nbnd,conserved)
!-------------------------------------------------------------------------- !--------------------------------------------------------------------------
! !
! OBM 110908 ! OBM 110908
! This subroutine transforms the given orbital using fft and puts the result in psic ! This subroutine transforms the given orbital using fft and puts the result in psic
! Warning! In order to be fast, no checks on the supplied data are performed! ! Warning! In order to be fast, no checks on the supplied data are performed!
! orbital: the orbital to be transformed ! orbital: the orbital to be transformed
! ibnd: band index ! ibnd: band index
! nbnd: total number of bands ! nbnd: total number of bands
USE wavefunctions_module, ONLY : psic USE wavefunctions_module, ONLY : psic
USE gsmooth, ONLY : nr1s,nr2s,nr3s,nrx1s,nrx2s,& USE gsmooth, ONLY : nr1s,nr2s,nr3s,nrx1s,nrx2s,&
nrx3s,nrxxs,nls,nlsm,doublegrid nrx3s,nrxxs,nls,nlsm,doublegrid
@ -2753,7 +2753,7 @@ MODULE realus
IF (.not.okvan) RETURN IF (.not.okvan) RETURN
IF( .not.gamma_only) THEN IF( .not.gamma_only) THEN
WRITE(stdout,*) ' adduspos_gamma_r is a gamma only routine' WRITE(stdout,*) ' adduspos_gamma_r is a gamma ONLY routine'
STOP STOP
ENDIF ENDIF