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

Merge branch 'master' of gitlab.com:QEF/q-e

This commit is contained in:
Pietro Delugas 2018-01-26 09:13:22 +01:00
parent a4c1065c66 e0580362d7
commit 17ba1bab52
12 changed files with 179 additions and 258 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored
View File

@ -14,5 +14,7 @@ install/config.log
install/config.status install/config.status
install/configure.msg install/configure.msg
Modules/version.f90 Modules/version.f90
test-suite/*/test.err.*
test-suite/*/test.out.*
S3DE S3DE

93
FFTXlib/fft_ggen.f90
View File

@ -18,7 +18,7 @@ MODULE fft_ggen
PRIVATE PRIVATE
SAVE SAVE
PUBLIC :: fft_set_nl, fft_set_nlm PUBLIC :: fft_set_nl
!=----------------------------------------------------------------------= !=----------------------------------------------------------------------=
CONTAINS CONTAINS
@ -30,6 +30,7 @@ CONTAINS
! !
! Input: FFT descriptor dfft, lattice vectors at, list of G-vectors g ! Input: FFT descriptor dfft, lattice vectors at, list of G-vectors g
! Output: indices nl such that G_fft(nl(i)) = G(i) ! Output: indices nl such that G_fft(nl(i)) = G(i)
! indices nlm such that G_fft(nlm(i)) = -G(i) only if lgamma=.true.
! optionally, Miller indices: if bg = reciprocal lattice vectors, ! optionally, Miller indices: if bg = reciprocal lattice vectors,
! G(:,i) = mill(1,i)*bg(:,1) + mill(2,i)*bg(:,2) + mill(3,i)*bg(:,3) ! G(:,i) = mill(1,i)*bg(:,1) + mill(2,i)*bg(:,2) + mill(3,i)*bg(:,3)
! !
@ -45,80 +46,52 @@ CONTAINS
! !
IF( ALLOCATED( dfft%nl ) ) DEALLOCATE( dfft%nl ) IF( ALLOCATED( dfft%nl ) ) DEALLOCATE( dfft%nl )
ALLOCATE( dfft%nl( dfft%ngm ) ) ALLOCATE( dfft%nl( dfft%ngm ) )
if (dfft%lgamma) THEN
IF( ALLOCATED( dfft%nlm ) ) DEALLOCATE( dfft%nlm )
ALLOCATE( dfft%nlm( dfft%ngm ) )
END IF
! !
DO ng = 1, dfft%ngm DO ng = 1, dfft%ngm
n1 = nint (sum(g (:, ng) * at (:, 1))) + 1 n1 = nint (sum(g (:, ng) * at (:, 1)))
IF(PRESENT(mill)) mill (1,ng) = n1 - 1 IF(PRESENT(mill)) mill (1,ng) = n1
IF (n1<1) n1 = n1 + dfft%nr1 IF (n1<0) n1 = n1 + dfft%nr1
n2 = nint (sum(g (:, ng) * at (:, 2))) + 1 n2 = nint (sum(g (:, ng) * at (:, 2)))
IF(PRESENT(mill)) mill (2,ng) = n2 - 1 IF(PRESENT(mill)) mill (2,ng) = n2
IF (n2<1) n2 = n2 + dfft%nr2 IF (n2<0) n2 = n2 + dfft%nr2
n3 = nint (sum(g (:, ng) * at (:, 3))) + 1 n3 = nint (sum(g (:, ng) * at (:, 3)))
IF(PRESENT(mill)) mill (3,ng) = n3 - 1 IF(PRESENT(mill)) mill (3,ng) = n3
IF (n3<1) n3 = n3 + dfft%nr3 IF (n3<0) n3 = n3 + dfft%nr3
IF (n1>dfft%nr1 .or. n2>dfft%nr2 .or. n3>dfft%nr3) & IF (n1>=dfft%nr1 .or. n2>=dfft%nr2 .or. n3>=dfft%nr3) &
CALL fftx_error__('ggen','Mesh too small?',ng) CALL fftx_error__('ggen','Mesh too small?',ng)
IF ( dfft%lpara) THEN IF ( dfft%lpara) THEN
dfft%nl (ng) = n3 + ( dfft%isind ( n1+(n2-1)*dfft%nr1x) - 1) * dfft%nr3x dfft%nl (ng) = 1 + n3 + ( dfft%isind ( 1 + n1 + n2*dfft%nr1x) - 1) * dfft%nr3x
ELSE ELSE
dfft%nl (ng) = n1 + (n2-1) * dfft%nr1x + (n3-1) * dfft%nr1x * dfft%nr2x dfft%nl (ng) = 1 + n1 + n2 * dfft%nr1x + n3 * dfft%nr1x * dfft%nr2x
ENDIF ENDIF
If (dfft%lgamma) THEN
n1 = - n1 ; IF (n1<0) n1 = n1 + dfft%nr1
n2 = - n2 ; IF (n2<0) n2 = n2 + dfft%nr2
n3 = - n3 ; IF (n3<0) n3 = n3 + dfft%nr3
IF ( dfft%lpara ) THEN
dfft%nlm(ng) = 1 + n3 + ( dfft%isind ( 1 + n1 + n2*dfft%nr1x) - 1) * dfft%nr3x
ELSE
dfft%nlm(ng) = 1 + n1 + n2 * dfft%nr1x + n3 * dfft%nr1x * dfft%nr2x
ENDIF
END IF
ENDDO ENDDO
! !
END SUBROUTINE fft_set_nl END SUBROUTINE fft_set_nl
! !
!
!-----------------------------------------------------------------------
SUBROUTINE fft_set_nlm( dfft, mill )
!----------------------------------------------------------------------
!
! Input: FFT descriptor dfft, miller indices
! Output: indices nlm such that G_fft(nlm(i)) = -G(i)
!
USE fft_types, ONLY : fft_type_descriptor
!
IMPLICIT NONE
!
TYPE (fft_type_descriptor), INTENT(inout) :: dfft
INTEGER, INTENT(IN) :: mill(:,:)
!
INTEGER :: n1, n2, n3, ng
!
IF( ALLOCATED( dfft%nlm ) ) DEALLOCATE( dfft%nlm )
ALLOCATE( dfft%nlm( dfft%ngm ) )
!
DO ng = 1, dfft%ngm
n1 = -mill (1,ng) + 1
IF (n1 < 1) THEN
n1 = n1 + dfft%nr1
END IF
n2 = -mill (2,ng) + 1
IF (n2 < 1) THEN
n2 = n2 + dfft%nr2
END IF
n3 = -mill (3,ng) + 1
IF (n3 < 1) THEN
n3 = n3 + dfft%nr3
END IF
IF (n1>dfft%nr1 .or. n2>dfft%nr2 .or. n3>dfft%nr3) THEN
CALL fftx_error__('index_minusg','Mesh too small?',ng)
ENDIF
IF ( dfft%lpara ) THEN
dfft%nlm(ng) = n3 + (dfft%isind (n1 + (n2-1)*dfft%nr1x) - 1) * dfft%nr3x
ELSE
dfft%nlm(ng) = n1 + (n2-1) * dfft%nr1x + (n3-1) * dfft%nr1x * dfft%nr2x
ENDIF
ENDDO
END SUBROUTINE fft_set_nlm
!
!=----------------------------------------------------------------------= !=----------------------------------------------------------------------=
END MODULE fft_ggen END MODULE fft_ggen
!=----------------------------------------------------------------------= !=----------------------------------------------------------------------=

163
Modules/gradutils.f90
View File

@ -6,9 +6,10 @@
! or http://www.gnu.org/copyleft/gpl.txt . ! or http://www.gnu.org/copyleft/gpl.txt .
! !
!-------------------------------------------------------------------- !--------------------------------------------------------------------
! Routines computing gradient via FFT ! Various routines computing gradient and similar quantities via FFT
!-------------------------------------------------------------------- !--------------------------------------------------------------------
! ! FIXME: there is a dependency upon "cell_base" via variable tpiba
! (2\pi/a) that maybe should be taken out from here?
!-------------------------------------------------------------------- !--------------------------------------------------------------------
SUBROUTINE external_gradient( a, grada ) SUBROUTINE external_gradient( a, grada )
!-------------------------------------------------------------------- !--------------------------------------------------------------------
@ -43,7 +44,6 @@ SUBROUTINE fft_gradient_r2r( dfft, a, g, ga )
! !
USE kinds, ONLY : DP USE kinds, ONLY : DP
USE cell_base, ONLY : tpiba USE cell_base, ONLY : tpiba
USE control_flags, ONLY : gamma_only
USE fft_interfaces,ONLY : fwfft, invfft USE fft_interfaces,ONLY : fwfft, invfft
USE fft_types, ONLY : fft_type_descriptor USE fft_types, ONLY : fft_type_descriptor
! !
@ -74,7 +74,7 @@ SUBROUTINE fft_gradient_r2r( dfft, a, g, ga )
gaux(dfft%nl(:)) = g(ipol,:) * CMPLX( -AIMAG( aux(dfft%nl(:)) ), & gaux(dfft%nl(:)) = g(ipol,:) * CMPLX( -AIMAG( aux(dfft%nl(:)) ), &
REAL( aux(dfft%nl(:)) ), kind=DP) REAL( aux(dfft%nl(:)) ), kind=DP)
! !
IF ( gamma_only ) THEN IF ( dfft%lgamma ) THEN
! !
gaux(dfft%nlm(:)) = CMPLX( REAL( gaux(dfft%nl(:)) ), & gaux(dfft%nlm(:)) = CMPLX( REAL( gaux(dfft%nl(:)) ), &
-AIMAG( gaux(dfft%nl(:)) ), kind=DP) -AIMAG( gaux(dfft%nl(:)) ), kind=DP)
@ -125,6 +125,8 @@ SUBROUTINE fft_qgradient (dfft, a, xq, g, ga)
INTEGER :: n, ipol INTEGER :: n, ipol
COMPLEX(DP), ALLOCATABLE :: aux(:), gaux(:) COMPLEX(DP), ALLOCATABLE :: aux(:), gaux(:)
IF ( dfft%lgamma ) CALL errore( 'fft_qgradient', &
'not to be called with Gamma tricks', 1 )
ALLOCATE (gaux(dfft%nnr)) ALLOCATE (gaux(dfft%nnr))
ALLOCATE (aux (dfft%nnr)) ALLOCATE (aux (dfft%nnr))
@ -167,7 +169,6 @@ SUBROUTINE fft_gradient_g2r( dfft, a, g, ga )
! !
USE cell_base, ONLY : tpiba USE cell_base, ONLY : tpiba
USE kinds, ONLY : DP USE kinds, ONLY : DP
USE control_flags, ONLY : gamma_only
USE fft_interfaces,ONLY : invfft USE fft_interfaces,ONLY : invfft
USE fft_types, ONLY : fft_type_descriptor USE fft_types, ONLY : fft_type_descriptor
! !
@ -178,28 +179,48 @@ SUBROUTINE fft_gradient_g2r( dfft, a, g, ga )
REAL(DP), INTENT(IN) :: g(3,dfft%ngm) REAL(DP), INTENT(IN) :: g(3,dfft%ngm)
REAL(DP), INTENT(OUT) :: ga(3,dfft%nnr) REAL(DP), INTENT(OUT) :: ga(3,dfft%nnr)
! !
INTEGER :: ipol INTEGER :: ipol, n
COMPLEX(DP), ALLOCATABLE :: gaux(:) COMPLEX(DP), ALLOCATABLE :: gaux(:)
! !
! !
ALLOCATE( gaux( dfft%nnr ) ) ALLOCATE( gaux( dfft%nnr ) )
!
! ... multiply by (iG) to get (\grad_ipol a)(G) ...
!
ga(:,:) = 0.D0 ga(:,:) = 0.D0
! !
DO ipol = 1, 3 IF ( dfft%lgamma) THEN
! !
! ... Gamma tricks: perform 2 FFT's in a single shot
! x and y
ipol = 1
gaux(:) = (0.0_dp,0.0_dp) gaux(:) = (0.0_dp,0.0_dp)
! !
gaux(dfft%nl(:)) = g(ipol,:) * CMPLX( -AIMAG(a(:)), REAL(a(:)), kind=DP) ! ... multiply a(G) by iG to get the gradient in real space
! !
IF ( gamma_only ) THEN DO n = 1, dfft%ngm
! gaux(dfft%nl (n)) = CMPLX( 0.0_dp, g(ipol, n), kind=DP )* a(n) - &
gaux(dfft%nlm(:)) = CMPLX( REAL( gaux(dfft%nl(:)) ), & g(ipol+1,n) * a(n)
-AIMAG( gaux(dfft%nl(:)) ), kind=DP) gaux(dfft%nlm(n)) = CMPLX( 0.0_dp,-g(ipol, n), kind=DP )*CONJG(a(n)) +&
! g(ipol+1,n) * CONJG(a(n))
END IF ENDDO
!
! ... bring back to R-space, (\grad_ipol a)(r) ...
!
CALL invfft ('Rho', gaux, dfft)
!
! ... bring back to R-space, (\grad_ipol a)(r)
! ... add the factor 2\pi/a missing in the definition of q+G
!
DO n = 1, dfft%nnr
ga (ipol , n) = REAL( gaux(n) ) * tpiba
ga (ipol+1, n) = AIMAG( gaux(n) ) * tpiba
ENDDO
! z
ipol = 3
gaux(:) = (0.0_dp,0.0_dp)
!
! ... multiply a(G) by iG to get the gradient in real space
!
gaux(dfft%nl (:)) = g(ipol,:) * CMPLX( -AIMAG(a(:)), REAL(a(:)), kind=DP)
gaux(dfft%nlm(:)) = CONJG( gaux(dfft%nl(:)) )
! !
! ... bring back to R-space, (\grad_ipol a)(r) ... ! ... bring back to R-space, (\grad_ipol a)(r) ...
! !
@ -207,9 +228,29 @@ SUBROUTINE fft_gradient_g2r( dfft, a, g, ga )
! !
! ...and add the factor 2\pi/a missing in the definition of G ! ...and add the factor 2\pi/a missing in the definition of G
! !
ga(ipol,:) = ga(ipol,:) + tpiba * REAL( gaux(:) ) ga(ipol,:) = tpiba * REAL( gaux(:) )
! !
END DO ELSE
!
DO ipol = 1, 3
!
gaux(:) = (0.0_dp,0.0_dp)
!
! ... multiply a(G) by iG to get the gradient in real space
!
gaux(dfft%nl(:)) = g(ipol,:) * CMPLX( -AIMAG(a(:)), REAL(a(:)), kind=DP)
!
! ... bring back to R-space, (\grad_ipol a)(r) ...
!
CALL invfft ('Rho', gaux, dfft)
!
! ...and add the factor 2\pi/a missing in the definition of G
!
ga(ipol,:) = tpiba * REAL( gaux(:) )
!
END DO
!
END IF
! !
DEALLOCATE( gaux ) DEALLOCATE( gaux )
! !
@ -229,7 +270,6 @@ SUBROUTINE fft_graddot( dfft, a, g, da )
! !
USE cell_base, ONLY : tpiba USE cell_base, ONLY : tpiba
USE kinds, ONLY : DP USE kinds, ONLY : DP
USE control_flags, ONLY : gamma_only
USE fft_interfaces,ONLY : fwfft, invfft USE fft_interfaces,ONLY : fwfft, invfft
USE fft_types, ONLY : fft_type_descriptor USE fft_types, ONLY : fft_type_descriptor
! !
@ -241,35 +281,71 @@ SUBROUTINE fft_graddot( dfft, a, g, da )
! !
INTEGER :: n, ipol INTEGER :: n, ipol
COMPLEX(DP), ALLOCATABLE :: aux(:), gaux(:) COMPLEX(DP), ALLOCATABLE :: aux(:), gaux(:)
COMPLEX(DP) :: fp, fm, aux1, aux2
! !
! ALLOCATE( aux(dfft%nnr) )
ALLOCATE( aux(dfft%nnr), gaux(dfft%nnr) ) ALLOCATE( gaux(dfft%nnr) )
! !
gaux(:) = (0.0_dp,0.0_dp) gaux(:) = (0.0_dp,0.0_dp)
! !
DO ipol = 1, 3 IF ( dfft%lgamma ) THEN
! !
aux = CMPLX( a(ipol,:), 0.0_dp, kind=DP) ! Gamma tricks: perform 2 FFT's in a single shot
! x and y
ipol = 1
aux(:) = CMPLX( a(ipol,:), a(ipol+1,:), kind=DP)
! !
! ... bring a(ipol,r) to G-space, a(G) ... ! ... bring a(ipol,r) to G-space, a(G) ...
! !
CALL fwfft ('Rho', aux, dfft) CALL fwfft ('Rho', aux, dfft)
! !
DO n = 1, dfft%ngm ! ... multiply by iG to get the gradient in G-space
!
gaux(dfft%nl(n)) = gaux(dfft%nl(n)) + g(ipol,n) * &
CMPLX( -AIMAG( aux(dfft%nl(n)) ), &
REAL( aux(dfft%nl(n)) ), kind=DP)
!
END DO
!
END DO
!
IF ( gamma_only ) THEN
! !
DO n = 1, dfft%ngm DO n = 1, dfft%ngm
! !
fp = (aux(dfft%nl(n)) + aux (dfft%nlm(n)))*0.5_dp
fm = (aux(dfft%nl(n)) - aux (dfft%nlm(n)))*0.5_dp
aux1 = CMPLX( REAL(fp), AIMAG(fm), kind=DP)
aux2 = CMPLX(AIMAG(fp), -REAL(fm), kind=DP)
gaux (dfft%nl(n)) = &
CMPLX(0.0_dp, g(ipol ,n),kind=DP) * aux1 + &
CMPLX(0.0_dp, g(ipol+1,n),kind=DP) * aux2
ENDDO
! z
ipol = 3
aux(:) = CMPLX( a(ipol,:), 0.0_dp, kind=DP)
!
! ... bring a(ipol,r) to G-space, a(G) ...
!
CALL fwfft ('Rho', aux, dfft)
!
! ... multiply by iG to get the gradient in G-space
! ... fill both gaux(G) and gaux(-G) = gaux*(G)
!
DO n = 1, dfft%ngm
gaux(dfft%nl(n)) = gaux(dfft%nl(n)) + g(ipol,n) * &
CMPLX( -AIMAG( aux(dfft%nl(n)) ), &
REAL( aux(dfft%nl(n)) ), kind=DP)
gaux(dfft%nlm(n)) = CONJG( gaux(dfft%nl(n)) ) gaux(dfft%nlm(n)) = CONJG( gaux(dfft%nl(n)) )
END DO
!
ELSE
!
DO ipol = 1, 3
!
aux = CMPLX( a(ipol,:), 0.0_dp, kind=DP)
!
! ... bring a(ipol,r) to G-space, a(G) ...
!
CALL fwfft ('Rho', aux, dfft)
!
! ... multiply by iG to get the gradient in G-space
!
DO n = 1, dfft%ngm
gaux(dfft%nl(n)) = gaux(dfft%nl(n)) + g(ipol,n) * &
CMPLX( -AIMAG( aux(dfft%nl(n)) ), &
REAL( aux(dfft%nl(n)) ), kind=DP)
END DO
! !
END DO END DO
! !
@ -301,7 +377,6 @@ SUBROUTINE fft_qgraddot ( dfft, a, xq, g, da)
! ... output: ga(:) \sum_i \grad_i a_i, complex, on the real-space FFT grid ! ... output: ga(:) \sum_i \grad_i a_i, complex, on the real-space FFT grid
! !
USE kinds, ONLY : DP USE kinds, ONLY : DP
USE control_flags, ONLY : gamma_only
USE cell_base, ONLY : tpiba USE cell_base, ONLY : tpiba
USE fft_interfaces, ONLY : fwfft, invfft USE fft_interfaces, ONLY : fwfft, invfft
USE fft_types, ONLY : fft_type_descriptor USE fft_types, ONLY : fft_type_descriptor
@ -316,6 +391,8 @@ SUBROUTINE fft_qgraddot ( dfft, a, xq, g, da)
INTEGER :: n, ipol INTEGER :: n, ipol
COMPLEX(DP), allocatable :: aux (:) COMPLEX(DP), allocatable :: aux (:)
IF ( dfft%lgamma ) CALL errore( 'fft_qgraddot', &
'not to be called with Gamma tricks', 1 )
ALLOCATE (aux (dfft%nnr)) ALLOCATE (aux (dfft%nnr))
da(:) = (0.0_dp, 0.0_dp) da(:) = (0.0_dp, 0.0_dp)
DO ipol = 1, 3 DO ipol = 1, 3
@ -381,7 +458,6 @@ SUBROUTINE fft_laplacian( dfft, a, gg, lapla )
! !
USE kinds, ONLY : DP USE kinds, ONLY : DP
USE cell_base, ONLY : tpiba2 USE cell_base, ONLY : tpiba2
USE control_flags, ONLY : gamma_only
USE fft_types, ONLY : fft_type_descriptor USE fft_types, ONLY : fft_type_descriptor
USE fft_interfaces,ONLY : fwfft, invfft USE fft_interfaces,ONLY : fwfft, invfft
! !
@ -414,7 +490,7 @@ SUBROUTINE fft_laplacian( dfft, a, gg, lapla )
! !
END DO END DO
! !
IF ( gamma_only ) THEN IF ( dfft%lgamma ) THEN
! !
laux(dfft%nlm(:)) = CMPLX( REAL(laux(dfft%nl(:)) ), & laux(dfft%nlm(:)) = CMPLX( REAL(laux(dfft%nl(:)) ), &
-AIMAG(laux(dfft%nl(:)) ), kind=DP) -AIMAG(laux(dfft%nl(:)) ), kind=DP)
@ -427,7 +503,7 @@ SUBROUTINE fft_laplacian( dfft, a, gg, lapla )
! !
! ... add the missing factor (2\pi/a)^2 in G ! ... add the missing factor (2\pi/a)^2 in G
! !
lapla = tpiba2 * DBLE( laux ) lapla = tpiba2 * REAL( laux )
! !
DEALLOCATE( laux ) DEALLOCATE( laux )
DEALLOCATE( aux ) DEALLOCATE( aux )
@ -453,7 +529,6 @@ SUBROUTINE fft_hessian( dfft, a, g, ga, ha )
! !
USE kinds, ONLY : DP USE kinds, ONLY : DP
USE cell_base, ONLY : tpiba USE cell_base, ONLY : tpiba
USE control_flags, ONLY : gamma_only
USE fft_types, ONLY : fft_type_descriptor USE fft_types, ONLY : fft_type_descriptor
USE fft_interfaces,ONLY : fwfft, invfft USE fft_interfaces,ONLY : fwfft, invfft
! !
@ -487,7 +562,7 @@ SUBROUTINE fft_hessian( dfft, a, g, ga, ha )
gaux(dfft%nl(:)) = g(ipol,:) * CMPLX( -AIMAG( aux(dfft%nl(:)) ), & gaux(dfft%nl(:)) = g(ipol,:) * CMPLX( -AIMAG( aux(dfft%nl(:)) ), &
REAL( aux(dfft%nl(:)) ), kind=DP ) REAL( aux(dfft%nl(:)) ), kind=DP )
! !
IF ( gamma_only ) THEN IF ( dfft%lgamma ) THEN
! !
gaux(dfft%nlm(:)) = CMPLX( REAL( gaux(dfft%nl(:)) ), & gaux(dfft%nlm(:)) = CMPLX( REAL( gaux(dfft%nl(:)) ), &
-AIMAG( gaux(dfft%nl(:)) ), kind=DP) -AIMAG( gaux(dfft%nl(:)) ), kind=DP)
@ -500,7 +575,7 @@ SUBROUTINE fft_hessian( dfft, a, g, ga, ha )
! !
! ...and add the factor 2\pi/a missing in the definition of G ! ...and add the factor 2\pi/a missing in the definition of G
! !
ga(ipol,:) = tpiba * DBLE( gaux(:) ) ga(ipol,:) = tpiba * REAL( gaux(:) )
! !
! ... compute the second derivatives ! ... compute the second derivatives
! !
@ -512,7 +587,7 @@ SUBROUTINE fft_hessian( dfft, a, g, ga, ha )
CMPLX( REAL( aux(dfft%nl(:)) ), & CMPLX( REAL( aux(dfft%nl(:)) ), &
AIMAG( aux(dfft%nl(:)) ), kind=DP) AIMAG( aux(dfft%nl(:)) ), kind=DP)
! !
IF ( gamma_only ) THEN IF ( dfft%lgamma ) THEN
! !
haux(dfft%nlm(:)) = CMPLX( REAL( haux(dfft%nl(:)) ), & haux(dfft%nlm(:)) = CMPLX( REAL( haux(dfft%nl(:)) ), &
-AIMAG( haux(dfft%nl(:)) ), kind=DP) -AIMAG( haux(dfft%nl(:)) ), kind=DP)
@ -525,7 +600,7 @@ SUBROUTINE fft_hessian( dfft, a, g, ga, ha )
! !
! ...and add the factor 2\pi/a missing in the definition of G ! ...and add the factor 2\pi/a missing in the definition of G
! !
ha(ipol, jpol, :) = tpiba * tpiba * DBLE( haux(:) ) ha(ipol, jpol, :) = tpiba * tpiba * REAL( haux(:) )
! !
ha(jpol, ipol, :) = ha(ipol, jpol, :) ha(jpol, ipol, :) = ha(ipol, jpol, :)
! !

1
Modules/make.depend
View File

@ -109,7 +109,6 @@ generate_k_along_lines.o : kind.o
gradutils.o : ../FFTXlib/fft_interfaces.o gradutils.o : ../FFTXlib/fft_interfaces.o
gradutils.o : ../FFTXlib/fft_types.o gradutils.o : ../FFTXlib/fft_types.o
gradutils.o : cell_base.o gradutils.o : cell_base.o
gradutils.o : control_flags.o
gradutils.o : fft_base.o gradutils.o : fft_base.o
gradutils.o : kind.o gradutils.o : kind.o
gradutils.o : recvec.o gradutils.o : recvec.o

4
Modules/recvec_subs.f90
View File

@ -15,7 +15,7 @@ MODULE recvec_subs
! !
USE kinds, ONLY : dp USE kinds, ONLY : dp
USE fft_types, ONLY: fft_stick_index, fft_type_descriptor USE fft_types, ONLY: fft_stick_index, fft_type_descriptor
USE fft_ggen, ONLY : fft_set_nl, fft_set_nlm USE fft_ggen, ONLY : fft_set_nl
! !
PRIVATE PRIVATE
SAVE SAVE
@ -224,7 +224,6 @@ CONTAINS
! Now set nl and nls with the correct fft correspondence ! Now set nl and nls with the correct fft correspondence
! !
CALL fft_set_nl( dfftp, at, g, mill ) CALL fft_set_nl( dfftp, at, g, mill )
IF( gamma_only ) CALL fft_set_nlm( dfftp, mill )
! !
END SUBROUTINE ggen END SUBROUTINE ggen
! !
@ -273,7 +272,6 @@ CONTAINS
IF ( ng /= ngms ) CALL errore ('ggens','mismatch in number of G-vectors',2) IF ( ng /= ngms ) CALL errore ('ggens','mismatch in number of G-vectors',2)
! !
CALL fft_set_nl ( dffts, at, g ) CALL fft_set_nl ( dffts, at, g )
IF ( gamma_only) CALL fft_set_nlm ( dffts, mill )
! !
END SUBROUTINE ggens END SUBROUTINE ggens
! !

133
PHonon/Gamma/dgradcorr.f90
View File

@ -44,7 +44,6 @@ SUBROUTINE dgradcor1 (dfft, rho, grho, dvxc_rr, dvxc_sr, dvxc_ss, dvxc_s, &
h (:,:,:) = 0.d0 h (:,:,:) = 0.d0
DO is = 1, nspin DO is = 1, nspin
CALL fft_gradient_g2r (dfft, drhoc(1, is), g, gdrho (1,1,is) ) CALL fft_gradient_g2r (dfft, drhoc(1, is), g, gdrho (1,1,is) )
!CALL gradient1 (dfft, drhoc(1, is), g, gdrho (1,1,is) )
ENDDO ENDDO
DO k = 1, dfft%nnr DO k = 1, dfft%nnr
grho2 = grho(1, k, 1)**2 + grho(2, k, 1)**2 + grho(3, k, 1)**2 grho2 = grho(1, k, 1)**2 + grho(2, k, 1)**2 + grho(3, k, 1)**2
@ -142,7 +141,6 @@ SUBROUTINE dgradcor1 (dfft, rho, grho, dvxc_rr, dvxc_sr, dvxc_ss, dvxc_s, &
ENDDO ENDDO
! linear variation of the second term ! linear variation of the second term
DO is = 1, nspin DO is = 1, nspin
!CALL grad_dot1 (dfft, h (1, 1, is), g, dh)
CALL fft_graddot (dfft, h (1, 1, is), g, dh) CALL fft_graddot (dfft, h (1, 1, is), g, dh)
DO k = 1, dfft%nnr DO k = 1, dfft%nnr
dvxc (k, is) = dvxc (k, is) - dh (k) dvxc (k, is) = dvxc (k, is) - dh (k)
@ -153,134 +151,3 @@ SUBROUTINE dgradcor1 (dfft, rho, grho, dvxc_rr, dvxc_sr, dvxc_ss, dvxc_s, &
DEALLOCATE (gdrho) DEALLOCATE (gdrho)
RETURN RETURN
END SUBROUTINE dgradcor1 END SUBROUTINE dgradcor1
!
!--------------------------------------------------------------------
SUBROUTINE gradient1( dfft, a, g, ga)
!--------------------------------------------------------------------
! Calculates ga = \grad a in R-space (a is G-space)
USE kinds, ONLY : DP
USE cell_base, ONLY : tpiba
USE fft_interfaces, ONLY : fwfft, invfft
USE fft_types, ONLY : fft_type_descriptor
!
IMPLICIT NONE
TYPE(fft_type_descriptor),INTENT(IN) :: dfft
COMPLEX(DP) :: a (dfft%nnr)
real(DP) :: ga (3, dfft%nnr), g (3, dfft%ngm)
!
INTEGER :: n, ipol
COMPLEX(DP), ALLOCATABLE :: gaux (:)
ALLOCATE (gaux(dfft%nnr))
! a(G) multiply by i(q+G) to get (\grad_ipol a)(q+G) ...
! do ipol = 1, 3
! x, y
ipol=1
DO n = 1, dfft%nnr
gaux (n) = (0.d0, 0.d0)
ENDDO
DO n = 1, dfft%ngm
gaux(dfft%nl (n)) = cmplx(0.d0, g(ipol, n),kind=DP)* a (dfft%nl(n)) - &
g(ipol+1, n) * a (dfft%nl(n))
gaux(dfft%nlm(n)) = cmplx(0.d0,-g(ipol,n),kind=DP)* conjg(a (dfft%nl(n))) + &
g(ipol+1, n) * conjg(a (dfft%nl(n)))
ENDDO
! bring back to R-space, (\grad_ipol a)(r) ...
CALL invfft ('Rho', gaux, dfft )
! ...and add the factor 2\pi/a missing in the definition of q+G
DO n = 1, dfft%nnr
ga (ipol , n) = dble(gaux (n)) * tpiba
ga (ipol+1, n) = aimag(gaux (n)) * tpiba
ENDDO
! z
ipol=3
DO n = 1, dfft%nnr
gaux (n) = (0.d0, 0.d0)
ENDDO
DO n = 1, dfft%ngm
gaux(dfft%nl (n)) = cmplx(0.d0, g(ipol, n),kind=DP) * a (dfft%nl(n))
gaux(dfft%nlm(n)) = conjg(gaux(dfft%nl(n)))
ENDDO
! bring back to R-space, (\grad_ipol a)(r) ...
CALL invfft ('Rho', gaux, dfft )
! ...and add the factor 2\pi/a missing in the definition of q+G
DO n = 1, dfft%nnr
ga (ipol, n) = dble(gaux (n)) * tpiba
ENDDO
! enddo
DEALLOCATE (gaux)
RETURN
END SUBROUTINE gradient1
!--------------------------------------------------------------------
SUBROUTINE grad_dot1 (dfft, a, g, da)
!--------------------------------------------------------------------
! Calculates da = \sum_i \grad_i a_i in R-space
USE kinds, ONLY : DP
USE cell_base, ONLY : tpiba
USE fft_interfaces, ONLY : fwfft, invfft
USE fft_types, ONLY : fft_type_descriptor
!
IMPLICIT NONE
TYPE(fft_type_descriptor),INTENT(IN) :: dfft
REAL(DP) :: a (3,dfft%nnr), da(dfft%nnr)
real(DP) :: g (3, dfft%ngm)
!
INTEGER :: n, ipol
COMPLEX(DP), ALLOCATABLE :: aux (:), daux(:)
COMPLEX(DP) :: fp, fm, aux1, aux2
ALLOCATE (aux (dfft%nnr))
ALLOCATE (daux (dfft%nnr))
DO n = 1, dfft%nnr
daux(n) = (0.d0, 0.d0)
ENDDO
!!! do ipol = 1, 3
! x, y
ipol=1
! copy a(ipol,r) to a complex array...
DO n = 1, dfft%nnr
aux (n) = cmplx( dble(a(ipol, n)), dble(a(ipol+1, n)),kind=DP)
ENDDO
! bring a(ipol,r) to G-space, a(G) ...
CALL fwfft ('Rho', aux, dfft)
! multiply by i(q+G) to get (\grad_ipol a)(q+G) ...
DO n = 1, dfft%ngm
fp = (aux(dfft%nl (n)) + aux (dfft%nlm(n)))*0.5d0
fm = (aux(dfft%nl (n)) - aux (dfft%nlm(n)))*0.5d0
aux1 = cmplx( dble(fp), aimag(fm),kind=DP)
aux2 = cmplx(aimag(fp),- dble(fm),kind=DP)
daux (dfft%nl(n)) = daux (dfft%nl(n)) + cmplx(0.d0,g(ipol,n),kind=DP)*aux1 + &
cmplx(0.d0, g(ipol+1, n),kind=DP) * aux2
ENDDO
! z
ipol=3
! copy a(ipol,r) to a complex array...
DO n = 1, dfft%nnr
aux (n) = a(ipol, n)
ENDDO
! bring a(ipol,r) to G-space, a(G) ...
CALL fwfft ('Rho', aux, dfft)
! multiply by i(q+G) to get (\grad_ipol a)(q+G) ...
DO n = 1, dfft%ngm
daux (dfft%nl(n)) = daux (dfft%nl(n)) + cmplx(0.d0, g(ipol,n),kind=DP) * &
aux(dfft%nl(n))
ENDDO
!!! enddo
DO n = 1, dfft%ngm
daux(dfft%nlm(n)) = conjg(daux(dfft%nl(n)))
ENDDO
! bring back to R-space, (\grad_ipol a)(r) ...
CALL invfft ('Rho', daux, dfft )
! ...add the factor 2\pi/a missing in the definition of q+G and sum
DO n = 1, dfft%nnr
da (n) = DBLE(daux(n)) * tpiba
ENDDO
DEALLOCATE (daux)
DEALLOCATE (aux)
RETURN
END SUBROUTINE grad_dot1

2
PHonon/Gamma/make.depend
View File

@ -59,9 +59,7 @@ d2ion.o : ../../Modules/io_global.o
d2ion.o : ../../Modules/kind.o d2ion.o : ../../Modules/kind.o
d2ion.o : ../../Modules/mp_global.o d2ion.o : ../../Modules/mp_global.o
d2ion.o : ../../UtilXlib/mp.o d2ion.o : ../../UtilXlib/mp.o
dgradcorr.o : ../../FFTXlib/fft_interfaces.o
dgradcorr.o : ../../FFTXlib/fft_types.o dgradcorr.o : ../../FFTXlib/fft_types.o
dgradcorr.o : ../../Modules/cell_base.o
dgradcorr.o : ../../Modules/kind.o dgradcorr.o : ../../Modules/kind.o
dielec.o : ../../Modules/cell_base.o dielec.o : ../../Modules/cell_base.o
dielec.o : ../../Modules/constants.o dielec.o : ../../Modules/constants.o

8
PHonon/examples/example12/run_example
View File

@ -142,7 +142,7 @@ normal modes for sih4
/ /
0.0 0.0 0.0 0.0 0.0 0.0
EOF EOF
$ECHO " running normal mode calculation for SiH4...\c" $ECHO " running normal mode calculation for SiH4 (LDA) ...\c"
$PHCG_COMMAND < sih4.nm.in > sih4.nm.out $PHCG_COMMAND < sih4.nm.in > sih4.nm.out
check_failure $? check_failure $?
$ECHO " done" $ECHO " done"
@ -152,7 +152,7 @@ cat > sih4.dyn.in << EOF
&input fildyn='sih4.dyn', asr='zero-dim' / &input fildyn='sih4.dyn', asr='zero-dim' /
EOF EOF
$ECHO " running IR cross section calculation for SiH4...\c" $ECHO " running IR cross section calculation for SiH4 (LDA) ...\c"
$DYNMAT_COMMAND < sih4.dyn.in > sih4.dyn.out $DYNMAT_COMMAND < sih4.dyn.in > sih4.dyn.out
check_failure $? check_failure $?
$ECHO " done" $ECHO " done"
@ -208,7 +208,7 @@ vibrations of SiH4
/ /
0.0 0.0 0.0 0.0 0.0 0.0
EOF EOF
$ECHO " running normal mode calculation for CH4...\c" $ECHO " running normal mode calculation for SiH4 (GGA) ...\c"
$PHCG_COMMAND < sih4.nm.in > sih4-gga.nm.out $PHCG_COMMAND < sih4.nm.in > sih4-gga.nm.out
check_failure $? check_failure $?
$ECHO " done" $ECHO " done"
@ -218,7 +218,7 @@ cat > sih4.dyn.in << EOF
&input fildyn='sih4.dyn', asr='zero-dim' / &input fildyn='sih4.dyn', asr='zero-dim' /
EOF EOF
$ECHO " running IR cross section calculation for CH4...\c" $ECHO " running IR cross section calculation for SiH4 (GGA) ...\c"
$DYNMAT_COMMAND < sih4.dyn.in > sih4-gga.dyn.out $DYNMAT_COMMAND < sih4.dyn.in > sih4-gga.dyn.out
check_failure $? check_failure $?
$ECHO " done" $ECHO " done"

22
PW/Doc/INPUT_PW.def
View File

@ -552,13 +552,22 @@ input_description -distribution {Quantum Espresso} -package PWscf -program pw.x
where beta is the angle between axis a and c where beta is the angle between axis a and c
13 Monoclinic base-centered celldm(2)=b/a 13 Monoclinic base-centered celldm(2)=b/a
celldm(3)=c/a, (unique axis c) celldm(3)=c/a,
celldm(4)=cos(ab) celldm(4)=cos(ab)
v1 = ( a/2, 0, -c/2), v1 = ( a/2, 0, -c/2),
v2 = (b*cos(gamma), b*sin(gamma), 0), v2 = (b*cos(gamma), b*sin(gamma), 0 ),
v3 = ( a/2, 0, c/2), v3 = ( a/2, 0, c/2),
where gamma is the angle between axis a and b where gamma is the angle between axis a and b
-13 Monoclinic base-centered celldm(2)=b/a
(unique axis b) celldm(3)=c/a,
celldm(5)=cos(ac)
v1 = ( a/2, 0, -c/2),
v2 = ( a/2, 0, c/2),
v3 = (b*cos(beta), 0, b*sin(beta)),
where beta is the angle between axis a and c
14 Triclinic celldm(2)= b/a, 14 Triclinic celldm(2)= b/a,
celldm(3)= c/a, celldm(3)= c/a,
celldm(4)= cos(bc), celldm(4)= cos(bc),
@ -1669,7 +1678,8 @@ input_description -distribution {Quantum Espresso} -package PWscf -program pw.x
This allows to give in input only the inequivalent atomic This allows to give in input only the inequivalent atomic
positions. The positions of all the symmetry equivalent atoms positions. The positions of all the symmetry equivalent atoms
are calculated by the code. Used only when the atomic positions are calculated by the code. Used only when the atomic positions
are of type crystal_sg. are of type crystal_sg. See also @ref uniqueb,
@ref origin_choice, @ref rhombohedral
} }
} }
@ -2583,7 +2593,7 @@ input_description -distribution {Quantum Espresso} -package PWscf -program pw.x
in relative coordinates of the primitive lattice. in relative coordinates of the primitive lattice.
This option differs from the previous one because This option differs from the previous one because
in this case only the symmetry inequivalent atoms in this case only the symmetry inequivalent atoms
are given. The variable space_group must indicate are given. The variable @ref space_group must indicate
the space group number used to find the symmetry the space group number used to find the symmetry
equivalent atoms. The other variables that control equivalent atoms. The other variables that control
this option are uniqueb, origin_choice, and this option are uniqueb, origin_choice, and

3
install/configure.ac
View File

@ -8,7 +8,6 @@
AC_INIT(ESPRESSO, 6.1, , espresso) AC_INIT(ESPRESSO, 6.1, , espresso)
# Do not use Autoconf 2.69
AC_PREREQ(2.60) AC_PREREQ(2.60)
AC_CONFIG_MACRO_DIR([m4/]) AC_CONFIG_MACRO_DIR([m4/])
@ -28,7 +27,7 @@ X_AC_QE_ARCH()
try_dflags="" try_dflags=""
# "-I../include" is required by IOTK ... # "-I../include" is required by IOTK ...
try_iflags="-I\$(TOPDIR)/include -I\$(TOPDIR)/FoX/finclude -I\$(TOPDIR)/S3 try_iflags="-I\$(TOPDIR)/include -I\$(TOPDIR)/FoX/finclude -I\$(TOPDIR)/S3DE/iotk/include/"
# Checking archiver... # Checking archiver...
X_AC_QE_AR() X_AC_QE_AR()

2
install/m4/x_ac_qe_mpif90.m4
View File

@ -1,7 +1,7 @@
# Copyright (C) 2001-2016 Quantum ESPRESSO Foundation # Copyright (C) 2001-2016 Quantum ESPRESSO Foundation
AC_DEFUN([X_AC_QE_MPIF90], [ AC_DEFUN([X_AC_QE_MPIF90], [
AC_REQUIRE([AC_PROG_FC])
AC_ARG_ENABLE(parallel, AC_ARG_ENABLE(parallel,
[AS_HELP_STRING([--enable-parallel], [AS_HELP_STRING([--enable-parallel],
[compile for parallel execution if possible (default: yes)])], [compile for parallel execution if possible (default: yes)])],

4
test-suite/Makefile
View File

@ -39,9 +39,9 @@ pseudo :
run-tests : run-tests-serial run-tests : run-tests-serial
run-tests-serial : run-tests-cp-serial run-tests-pw-serial run-tests-serial : run-tests-pw-serial run-tests-cp-serial
run-tests-parallel : run-tests-cp-parallel run-tests-pw-parallel run-tests-parallel : run-tests-pw-parallel run-tests-cp-parallel run-tests-ph-parallel run-tests-epw-parallel
run-tests-cp-serial : prolog pseudo run-tests-cp-serial : prolog pseudo