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/configure.msg
Modules/version.f90
test-suite/*/test.err.*
test-suite/*/test.out.*
S3DE

93
FFTXlib/fft_ggen.f90
View File

@ -18,7 +18,7 @@ MODULE fft_ggen
PRIVATE
SAVE
PUBLIC :: fft_set_nl, fft_set_nlm
PUBLIC :: fft_set_nl
!=----------------------------------------------------------------------=
CONTAINS
@ -30,6 +30,7 @@ CONTAINS
!
! Input: FFT descriptor dfft, lattice vectors at, list of G-vectors g
! 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,
! 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 )
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
n1 = nint (sum(g (:, ng) * at (:, 1))) + 1
IF(PRESENT(mill)) mill (1,ng) = n1 - 1
IF (n1<1) n1 = n1 + dfft%nr1
n1 = nint (sum(g (:, ng) * at (:, 1)))
IF(PRESENT(mill)) mill (1,ng) = n1
IF (n1<0) n1 = n1 + dfft%nr1
n2 = nint (sum(g (:, ng) * at (:, 2))) + 1
IF(PRESENT(mill)) mill (2,ng) = n2 - 1
IF (n2<1) n2 = n2 + dfft%nr2
n2 = nint (sum(g (:, ng) * at (:, 2)))
IF(PRESENT(mill)) mill (2,ng) = n2
IF (n2<0) n2 = n2 + dfft%nr2
n3 = nint (sum(g (:, ng) * at (:, 3))) + 1
IF(PRESENT(mill)) mill (3,ng) = n3 - 1
IF (n3<1) n3 = n3 + dfft%nr3
n3 = nint (sum(g (:, ng) * at (:, 3)))
IF(PRESENT(mill)) mill (3,ng) = n3
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)
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
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
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
!
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
!=----------------------------------------------------------------------=

163
Modules/gradutils.f90
View File

@ -6,9 +6,10 @@
! 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 )
!--------------------------------------------------------------------
@ -43,7 +44,6 @@ SUBROUTINE fft_gradient_r2r( dfft, a, g, ga )
!
USE kinds, ONLY : DP
USE cell_base, ONLY : tpiba
USE control_flags, ONLY : gamma_only
USE fft_interfaces,ONLY : fwfft, invfft
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(:)) ), &
REAL( aux(dfft%nl(:)) ), kind=DP)
!
IF ( gamma_only ) THEN
IF ( dfft%lgamma ) THEN
!
gaux(dfft%nlm(:)) = CMPLX( REAL( gaux(dfft%nl(:)) ), &
-AIMAG( gaux(dfft%nl(:)) ), kind=DP)
@ -125,6 +125,8 @@ SUBROUTINE fft_qgradient (dfft, a, xq, g, ga)
INTEGER :: n, ipol
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 (aux (dfft%nnr))
@ -167,7 +169,6 @@ SUBROUTINE fft_gradient_g2r( dfft, a, g, ga )
!
USE cell_base, ONLY : tpiba
USE kinds, ONLY : DP
USE control_flags, ONLY : gamma_only
USE fft_interfaces,ONLY : invfft
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(OUT) :: ga(3,dfft%nnr)
!
INTEGER :: ipol
INTEGER :: ipol, n
COMPLEX(DP), ALLOCATABLE :: gaux(:)
!
!
ALLOCATE( gaux( dfft%nnr ) )
!
! ... multiply by (iG) to get (\grad_ipol a)(G) ...
!
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(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
!
gaux(dfft%nlm(:)) = CMPLX( REAL( gaux(dfft%nl(:)) ), &
-AIMAG( gaux(dfft%nl(:)) ), kind=DP)
!
END IF
DO n = 1, dfft%ngm
gaux(dfft%nl (n)) = CMPLX( 0.0_dp, g(ipol, n), kind=DP )* a(n) - &
g(ipol+1,n) * a(n)
gaux(dfft%nlm(n)) = CMPLX( 0.0_dp,-g(ipol, n), kind=DP )*CONJG(a(n)) +&
g(ipol+1,n) * CONJG(a(n))
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) ...
!
@ -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
!
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 )
!
@ -229,7 +270,6 @@ SUBROUTINE fft_graddot( dfft, a, g, da )
!
USE cell_base, ONLY : tpiba
USE kinds, ONLY : DP
USE control_flags, ONLY : gamma_only
USE fft_interfaces,ONLY : fwfft, invfft
USE fft_types, ONLY : fft_type_descriptor
!
@ -241,35 +281,71 @@ SUBROUTINE fft_graddot( dfft, a, g, da )
!
INTEGER :: n, ipol
COMPLEX(DP), ALLOCATABLE :: aux(:), gaux(:)
COMPLEX(DP) :: fp, fm, aux1, aux2
!
!
ALLOCATE( aux(dfft%nnr), gaux(dfft%nnr) )
ALLOCATE( aux(dfft%nnr) )
ALLOCATE( gaux(dfft%nnr) )
!
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) ...
!
CALL fwfft ('Rho', aux, dfft)
!
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
!
IF ( gamma_only ) THEN
! ... multiply by iG to get the gradient in G-space
!
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)) )
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
!
@ -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
!
USE kinds, ONLY : DP
USE control_flags, ONLY : gamma_only
USE cell_base, ONLY : tpiba
USE fft_interfaces, ONLY : fwfft, invfft
USE fft_types, ONLY : fft_type_descriptor
@ -316,6 +391,8 @@ SUBROUTINE fft_qgraddot ( dfft, a, xq, g, da)
INTEGER :: n, ipol
COMPLEX(DP), allocatable :: aux (:)
IF ( dfft%lgamma ) CALL errore( 'fft_qgraddot', &
'not to be called with Gamma tricks', 1 )
ALLOCATE (aux (dfft%nnr))
da(:) = (0.0_dp, 0.0_dp)
DO ipol = 1, 3
@ -381,7 +458,6 @@ SUBROUTINE fft_laplacian( dfft, a, gg, lapla )
!
USE kinds, ONLY : DP
USE cell_base, ONLY : tpiba2
USE control_flags, ONLY : gamma_only
USE fft_types, ONLY : fft_type_descriptor
USE fft_interfaces,ONLY : fwfft, invfft
!
@ -414,7 +490,7 @@ SUBROUTINE fft_laplacian( dfft, a, gg, lapla )
!
END DO
!
IF ( gamma_only ) THEN
IF ( dfft%lgamma ) THEN
!
laux(dfft%nlm(:)) = CMPLX( REAL(laux(dfft%nl(:)) ), &
-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
!
lapla = tpiba2 * DBLE( laux )
lapla = tpiba2 * REAL( laux )
!
DEALLOCATE( laux )
DEALLOCATE( aux )
@ -453,7 +529,6 @@ SUBROUTINE fft_hessian( dfft, a, g, ga, ha )
!
USE kinds, ONLY : DP
USE cell_base, ONLY : tpiba
USE control_flags, ONLY : gamma_only
USE fft_types, ONLY : fft_type_descriptor
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(:)) ), &
REAL( aux(dfft%nl(:)) ), kind=DP )
!
IF ( gamma_only ) THEN
IF ( dfft%lgamma ) THEN
!
gaux(dfft%nlm(:)) = CMPLX( REAL( gaux(dfft%nl(:)) ), &
-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
!
ga(ipol,:) = tpiba * DBLE( gaux(:) )
ga(ipol,:) = tpiba * REAL( gaux(:) )
!
! ... compute the second derivatives
!
@ -512,7 +587,7 @@ SUBROUTINE fft_hessian( dfft, a, g, ga, ha )
CMPLX( REAL( aux(dfft%nl(:)) ), &
AIMAG( aux(dfft%nl(:)) ), kind=DP)
!
IF ( gamma_only ) THEN
IF ( dfft%lgamma ) THEN
!
haux(dfft%nlm(:)) = CMPLX( REAL( haux(dfft%nl(:)) ), &
-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
!
ha(ipol, jpol, :) = tpiba * tpiba * DBLE( haux(:) )
ha(ipol, jpol, :) = tpiba * tpiba * REAL( haux(:) )
!
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_types.o
gradutils.o : cell_base.o
gradutils.o : control_flags.o
gradutils.o : fft_base.o
gradutils.o : kind.o
gradutils.o : recvec.o

4
Modules/recvec_subs.f90
View File

@ -15,7 +15,7 @@ MODULE recvec_subs
!
USE kinds, ONLY : dp
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
SAVE
@ -224,7 +224,6 @@ CONTAINS
! Now set nl and nls with the correct fft correspondence
!
CALL fft_set_nl( dfftp, at, g, mill )
IF( gamma_only ) CALL fft_set_nlm( dfftp, mill )
!
END SUBROUTINE ggen
!
@ -273,7 +272,6 @@ CONTAINS
IF ( ng /= ngms ) CALL errore ('ggens','mismatch in number of G-vectors',2)
!
CALL fft_set_nl ( dffts, at, g )
IF ( gamma_only) CALL fft_set_nlm ( dffts, mill )
!
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
DO is = 1, nspin
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
DO k = 1, dfft%nnr
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
! linear variation of the second term
DO is = 1, nspin
!CALL grad_dot1 (dfft, h (1, 1, is), g, dh)
CALL fft_graddot (dfft, h (1, 1, is), g, dh)
DO k = 1, dfft%nnr
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)
RETURN
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/mp_global.o
d2ion.o : ../../UtilXlib/mp.o
dgradcorr.o : ../../FFTXlib/fft_interfaces.o
dgradcorr.o : ../../FFTXlib/fft_types.o
dgradcorr.o : ../../Modules/cell_base.o
dgradcorr.o : ../../Modules/kind.o
dielec.o : ../../Modules/cell_base.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
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
check_failure $?
$ECHO " done"
@ -152,7 +152,7 @@ cat > sih4.dyn.in << EOF
&input fildyn='sih4.dyn', asr='zero-dim' /
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
check_failure $?
$ECHO " done"
@ -208,7 +208,7 @@ vibrations of SiH4
/
0.0 0.0 0.0
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
check_failure $?
$ECHO " done"
@ -218,7 +218,7 @@ cat > sih4.dyn.in << EOF
&input fildyn='sih4.dyn', asr='zero-dim' /
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
check_failure $?
$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
13 Monoclinic base-centered celldm(2)=b/a
celldm(3)=c/a,
(unique axis c) celldm(3)=c/a,
celldm(4)=cos(ab)
v1 = ( a/2, 0, -c/2),
v2 = (b*cos(gamma), b*sin(gamma), 0),
v3 = ( a/2, 0, c/2),
v1 = ( a/2, 0, -c/2),
v2 = (b*cos(gamma), b*sin(gamma), 0 ),
v3 = ( a/2, 0, c/2),
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,
celldm(3)= c/a,
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
positions. The positions of all the symmetry equivalent atoms
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.
This option differs from the previous one because
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
equivalent atoms. The other variables that control
this option are uniqueb, origin_choice, and

3
install/configure.ac
View File

@ -8,7 +8,6 @@
AC_INIT(ESPRESSO, 6.1, , espresso)
# Do not use Autoconf 2.69
AC_PREREQ(2.60)
AC_CONFIG_MACRO_DIR([m4/])
@ -28,7 +27,7 @@ X_AC_QE_ARCH()
try_dflags=""
# "-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...
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
AC_DEFUN([X_AC_QE_MPIF90], [
AC_REQUIRE([AC_PROG_FC])
AC_ARG_ENABLE(parallel,
[AS_HELP_STRING([--enable-parallel],
[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-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