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

Update to EPW USPP to support time-reversal symm. 

Courtesy of R. Margine.
This commit is contained in:
Samuel Ponce 2019-02-04 18:02:45 +00:00
parent 92d7ce5df2
commit c2ef20a5e7
12 changed files with 435 additions and 396 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
EPW/src/adddvscf2.f90
View File

@ -67,9 +67,9 @@
INTEGER :: ijs INTEGER :: ijs
!! Counter on combined is and js polarization !! Counter on combined is and js polarization
! !
COMPLEX(DP) :: sumA COMPLEX(kind=DP) :: sum_k
!! auxiliary sum variable !! auxiliary sum variable
COMPLEX(DP) :: sum_nc(npol) COMPLEX(kind=DP) :: sum_nc(npol)
!! auxiliary sum variable non-collinear case !! auxiliary sum variable non-collinear case
! !
IF (.not.okvan) RETURN IF (.not.okvan) RETURN
@ -87,12 +87,12 @@
! we multiply the integral for the becp term and the beta_n ! we multiply the integral for the becp term and the beta_n
! !
DO ibnd = lower_band, upper_band DO ibnd = lower_band, upper_band
do ih = 1, nh(nt) DO ih = 1, nh(nt)
ikb = ijkb0 + ih ikb = ijkb0 + ih
IF (noncolin) THEN IF (noncolin) THEN
sum_nc = czero sum_nc = czero
ELSE ELSE
sumA = czero sum_k = czero
ENDIF ENDIF
DO jh = 1, nh(nt) DO jh = 1, nh(nt)
jkb = ijkb0 + jh jkb = ijkb0 + jh
@ -106,7 +106,7 @@
ENDDO ENDDO
ENDDO ENDDO
ELSE ELSE
sumA = sumA + int3(ih,jh,na,current_spin,ipert) * & sum_k = sum_k + int3(ih,jh,na,current_spin,ipert) * &
becp1(ik)%k(jkb,ibnd) becp1(ik)%k(jkb,ibnd)
ENDIF ENDIF
ENDDO ENDDO
@ -114,7 +114,7 @@
CALL zaxpy( npwq, sum_nc(1), vkb(1,ikb), 1, dvpsi(1,ibnd), 1 ) CALL zaxpy( npwq, sum_nc(1), vkb(1,ikb), 1, dvpsi(1,ibnd), 1 )
CALL zaxpy( npwq, sum_nc(2), vkb(1,ikb), 1, dvpsi(1+npwx,ibnd), 1 ) CALL zaxpy( npwq, sum_nc(2), vkb(1,ikb), 1, dvpsi(1+npwx,ibnd), 1 )
ELSE ELSE
CALL zaxpy( npwq, sumA, vkb(1,ikb), 1, dvpsi(1,ibnd), 1 ) CALL zaxpy( npwq, sum_k, vkb(1,ikb), 1, dvpsi(1,ibnd), 1 )
ENDIF ENDIF
ENDDO ENDDO
ENDDO ENDDO

10
EPW/src/allocate_epwq.f90
View File

@ -25,10 +25,10 @@
USE gvect, ONLY : ngm USE gvect, ONLY : ngm
USE noncollin_module, ONLY : noncolin, npol, nspin_mag USE noncollin_module, ONLY : noncolin, npol, nspin_mag
USE spin_orb, ONLY : lspinorb USE spin_orb, ONLY : lspinorb
USE phcom, ONLY : evq, dpsi, vlocq, dmuxc USE phcom, ONLY : evq, vlocq, dmuxc
USE phus, ONLY : int1, int1_nc, int2, int2_so, & USE phus, ONLY : int1, int1_nc, int2, int2_so, &
int4, int4_nc, int5, int5_so, becsum_nc, & int4, int4_nc, int5, int5_so, &
alphasum, alphasum_nc, alphap alphap
USE lr_symm_base, ONLY : rtau USE lr_symm_base, ONLY : rtau
USE qpoint, ONLY : eigqts USE qpoint, ONLY : eigqts
USE lrus, ONLY : becp1 USE lrus, ONLY : becp1
@ -52,7 +52,6 @@
! ALLOCATE space for the quantities needed in EPW ! ALLOCATE space for the quantities needed in EPW
! !
ALLOCATE (evq(npwx*npol, nbnd)) ALLOCATE (evq(npwx*npol, nbnd))
ALLOCATE (dpsi ( npwx*npol, nbnd))
ALLOCATE (transp_temp(nstemp)) ALLOCATE (transp_temp(nstemp))
! !
ALLOCATE (vlocq(ngm, ntyp)) ALLOCATE (vlocq(ngm, ntyp))
@ -82,14 +81,11 @@
IF (noncolin) THEN IF (noncolin) THEN
ALLOCATE (int1_nc(nhm, nhm, 3, nat, nspin)) ALLOCATE (int1_nc(nhm, nhm, 3, nat, nspin))
ALLOCATE (int4_nc(nhm, nhm, 3, 3, nat, nspin)) ALLOCATE (int4_nc(nhm, nhm, 3, 3, nat, nspin))
ALLOCATE (becsum_nc(nhm*(nhm+1)/2, nat, npol, npol))
ALLOCATE (alphasum_nc(nhm*(nhm+1)/2, 3, nat, npol, npol))
IF (lspinorb) THEN IF (lspinorb) THEN
ALLOCATE (int2_so(nhm, nhm, 3, nat, nat, nspin)) ALLOCATE (int2_so(nhm, nhm, 3, nat, nat, nspin))
ALLOCATE (int5_so(nhm, nhm, 3, 3, nat, nat, nspin)) ALLOCATE (int5_so(nhm, nhm, 3, 3, nat, nat, nspin))
ENDIF ENDIF
ENDIF ! noncolin ENDIF ! noncolin
ALLOCATE (alphasum(nhm * (nhm + 1)/2, 3, nat, nspin_mag))
ENDIF ENDIF
! !
ALLOCATE (becp1(nks)) ALLOCATE (becp1(nks))

40
EPW/src/close_epw.f90
View File

@ -104,9 +104,7 @@
!! Imported the noncolinear case implemented by xlzhang !! Imported the noncolinear case implemented by xlzhang
!! !!
!---------------------------------------------------------------------- !----------------------------------------------------------------------
USE phcom, ONLY : alphap, alphasum, alphasum_nc, & USE phcom, ONLY : alphap, dmuxc, drc, dyn, evq, dvpsi, &
becsum_nc, dmuxc, dpsi,&
drc, dpsi, dyn, evq, dvpsi,&
int5, vlocq, int2_so, int5_so int5, vlocq, int2_so, int5_so
USE lrus, ONLY : becp1, int3, int3_nc USE lrus, ONLY : becp1, int3, int3_nc
USE phus, ONLY : int1, int1_nc, int2, int4, int4_nc USE phus, ONLY : int1, int1_nc, int2, int4, int4_nc
@ -154,7 +152,6 @@
IF(ASSOCIATED(igkq)) DEALLOCATE(igkq) IF(ASSOCIATED(igkq)) DEALLOCATE(igkq)
! !
IF(ALLOCATED(dvpsi)) DEALLOCATE (dvpsi) IF(ALLOCATED(dvpsi)) DEALLOCATE (dvpsi)
IF(ALLOCATED(dpsi)) DEALLOCATE ( dpsi)
! !
IF(ALLOCATED(vlocq)) DEALLOCATE (vlocq) IF(ALLOCATED(vlocq)) DEALLOCATE (vlocq)
IF(ALLOCATED(dmuxc)) DEALLOCATE (dmuxc) IF(ALLOCATED(dmuxc)) DEALLOCATE (dmuxc)
@ -178,28 +175,25 @@
IF(ALLOCATED(int1_nc)) DEALLOCATE(int1_nc) IF(ALLOCATED(int1_nc)) DEALLOCATE(int1_nc)
IF(ALLOCATED(int3_nc)) DEALLOCATE(int3_nc) IF(ALLOCATED(int3_nc)) DEALLOCATE(int3_nc)
IF(ALLOCATED(int4_nc)) DEALLOCATE(int4_nc) IF(ALLOCATED(int4_nc)) DEALLOCATE(int4_nc)
IF(ALLOCATED(becsum_nc)) DEALLOCATE(becsum_nc)
IF(ALLOCATED(alphasum_nc)) DEALLOCATE(alphasum_nc)
IF(ALLOCATED(int2_so)) DEALLOCATE(int2_so) IF(ALLOCATED(int2_so)) DEALLOCATE(int2_so)
IF(ALLOCATED(int5_so)) DEALLOCATE(int5_so) IF(ALLOCATED(int5_so)) DEALLOCATE(int5_so)
IF(ALLOCATED(alphasum)) DEALLOCATE (alphasum)
! !
if(allocated(alphap)) then IF (allocated(alphap)) THEN
do ik=1,nks DO ik = 1, nks
do ipol=1,3 DO ipol = 1, 3
call deallocate_bec_type ( alphap(ipol,ik) ) CALL deallocate_bec_type( alphap(ipol,ik) )
enddo ENDDO
end do ENDDO
deallocate (alphap) DEALLOCATE(alphap)
endif ENDIF
if(allocated(becp1)) then IF (allocated(becp1)) THEN
do ik=1,size(becp1) DO ik = 1, size(becp1)
call deallocate_bec_type ( becp1(ik) ) CALL deallocate_bec_type( becp1(ik) )
end do ENDDO
deallocate(becp1) DEALLOCATE(becp1)
end if ENDIF
call deallocate_bec_type ( becp ) CALL deallocate_bec_type ( becp )
!
IF(ALLOCATED(nbnd_occ)) DEALLOCATE(nbnd_occ) IF(ALLOCATED(nbnd_occ)) DEALLOCATE(nbnd_occ)
IF(ALLOCATED(m_loc)) DEALLOCATE(m_loc) IF(ALLOCATED(m_loc)) DEALLOCATE(m_loc)
! !

154
EPW/src/dvanqq2.f90
View File

@ -15,10 +15,16 @@
!! !!
!! New !! New
!! This routine calculates two integrals of the Q functions and !! This routine calculates two integrals of the Q functions and
!! its derivatives with c V_loc and V_eff which are used !! its derivatives with V_loc and V_eff which are used
!! to compute term dV_bare/dtau * psi in addusdvqpsi. !! to compute term dV_bare/dtau * psi in addusdvqpsi.
!! The result is stored in int1, int2, int4, int5. The routine is called !! The result is stored in int1, int2, int4, int5. The routine is called
!! for each q in nqc. !! for each q in nqc.
!! int1 -> Eq. B20 of Ref.[1]
!! int2 -> Eq. B21 of Ref.[1]
!! int4 -> Eq. B23 of Ref.[1]
!! int5 -> Eq. B24 of Ref.[1]
!!
!! [1] PRB 64, 235118 (2001).
!! !!
!! RM - Nov/Dec 2014 !! RM - Nov/Dec 2014
!! Imported the noncolinear case implemented by xlzhang !! Imported the noncolinear case implemented by xlzhang
@ -73,19 +79,27 @@
INTEGER :: is INTEGER :: is
!! counter on spin !! counter on spin
! !
REAL(DP), ALLOCATABLE :: qmod(:) REAL(kind=DP), ALLOCATABLE :: qmod(:)
!! the modulus of q+G !! the modulus of q+G
REAL(DP), ALLOCATABLE :: qmodg(:) REAL(kind=DP), ALLOCATABLE :: qmodg(:)
!! the modulus of G !! the modulus of G
REAL(DP), ALLOCATABLE :: qpg(:,:) REAL(DP), ALLOCATABLE :: qpg(:,:)
!! the q+G vectors !! the q+G vectors
REAL(DP), ALLOCATABLE :: ylmkq(:,:), ylmk0(:,:) REAL(kind=DP), ALLOCATABLE :: ylmkq(:,:)
!! the spherical harmonics !! the spherical harmonics at q+G
REAL(kind=DP), ALLOCATABLE :: ylmk0(:,:)
!! the spherical harmonics at G
! !
COMPLEX(kind=DP) :: fact, fact1, ZDOTC COMPLEX(kind=DP) :: fact
COMPLEX(kind=DP), ALLOCATABLE :: aux1(:), aux2(:),& !! e^{-i q * \tau} * conjg(e^{-i q * \tau})
aux3(:), aux5(:), veff(:,:), sk(:) COMPLEX(kind=DP) :: fact1
! work space !! -i * omega
COMPLEX(kind=DP), EXTERNAL :: zdotc
!! the scalar product function
COMPLEX(kind=DP), ALLOCATABLE :: aux1(:), aux2(:), &
aux3(:), aux5(:), sk(:)
COMPLEX(kind=DP), ALLOCATABLE :: veff(:,:)
!! effective potential
COMPLEX(kind=DP), ALLOCATABLE, TARGET :: qgm(:) COMPLEX(kind=DP), ALLOCATABLE, TARGET :: qgm(:)
!! the augmentation function at G !! the augmentation function at G
COMPLEX(kind=DP), POINTER :: qgmq(:) COMPLEX(kind=DP), POINTER :: qgmq(:)
@ -93,35 +107,35 @@
! !
IF (.not.okvan) RETURN IF (.not.okvan) RETURN
! !
CALL start_clock ('dvanqq2') CALL start_clock('dvanqq2')
! !
int1(:,:,:,:,:) = czero int1(:,:,:,:,:) = czero
int2(:,:,:,:,:) = czero int2(:,:,:,:,:) = czero
int4(:,:,:,:,:) = czero int4(:,:,:,:,:) = czero
int5(:,:,:,:,:) = czero int5(:,:,:,:,:) = czero
ALLOCATE (sk ( ngm)) ALLOCATE( sk(ngm) )
ALLOCATE (aux1( ngm)) ALLOCATE( aux1(ngm) )
ALLOCATE (aux2( ngm)) ALLOCATE( aux2(ngm) )
ALLOCATE (aux3( ngm)) ALLOCATE( aux3(ngm) )
ALLOCATE (aux5( ngm)) ALLOCATE( aux5(ngm) )
ALLOCATE (qmodg( ngm)) ALLOCATE( qmodg(ngm) )
ALLOCATE (ylmk0( ngm, lmaxq * lmaxq)) ALLOCATE( qmod(ngm) )
ALLOCATE (qgm ( ngm)) ALLOCATE( qgmq(ngm) )
ALLOCATE (ylmkq( ngm, lmaxq * lmaxq)) ALLOCATE( qgm(ngm))
ALLOCATE (qmod( ngm)) ALLOCATE( ylmk0(ngm, lmaxq * lmaxq) )
ALLOCATE (qgmq( ngm)) ALLOCATE( ylmkq(ngm, lmaxq * lmaxq) )
! !
! compute spherical harmonics ! compute spherical harmonics
! !
CALL ylmr2 (lmaxq * lmaxq, ngm, g, gg, ylmk0) CALL ylmr2( lmaxq * lmaxq, ngm, g, gg, ylmk0 )
DO ig = 1, ngm DO ig = 1, ngm
qmodg(ig) = sqrt( gg(ig) ) qmodg(ig) = sqrt( gg(ig) )
ENDDO ENDDO
! !
ALLOCATE (qpg(3, ngm)) ALLOCATE( qpg(3, ngm) )
CALL setqmod(ngm, xq, g, qmod, qpg) CALL setqmod( ngm, xq, g, qmod, qpg )
CALL ylmr2(lmaxq * lmaxq, ngm, qpg, qmod, ylmkq) CALL ylmr2(lmaxq * lmaxq, ngm, qpg, qmod, ylmkq)
DEALLOCATE (qpg) DEALLOCATE(qpg)
DO ig = 1, ngm DO ig = 1, ngm
qmod(ig) = sqrt( qmod(ig) ) qmod(ig) = sqrt( qmod(ig) )
ENDDO ENDDO
@ -148,14 +162,15 @@
! !
DO ntb = 1, ntyp DO ntb = 1, ntyp
IF (upf(ntb)%tvanp ) THEN IF (upf(ntb)%tvanp ) THEN
!
DO ih = 1, nh(ntb) DO ih = 1, nh(ntb)
DO jh = ih, nh(ntb) DO jh = ih, nh(ntb)
ijh = ijtoh(ih,jh,ntb) ijh = ijtoh(ih,jh,ntb)
! !
! compute the augmentation function ! compute the augmentation function
! !
CALL qvan2(ngm, ih, jh, ntb, qmodg, qgm, ylmk0) CALL qvan2( ngm, ih, jh, ntb, qmodg, qgm, ylmk0 )
CALL qvan2(ngm, ih, jh, ntb, qmod, qgmq, ylmkq) CALL qvan2( ngm, ih, jh, ntb, qmod, qgmq, ylmkq )
! !
! NB: for this integral the moving atom and the atom of Q ! NB: for this integral the moving atom and the atom of Q
! do not necessarily coincide ! do not necessarily coincide
@ -167,8 +182,9 @@
* eigts2(mill(2,ig),nb) & * eigts2(mill(2,ig),nb) &
* eigts3(mill(3,ig),nb) * eigts3(mill(3,ig),nb)
ENDDO ENDDO
!
DO na = 1, nat DO na = 1, nat
fact = eigqts(na) * CONJG( eigqts(nb) ) fact = eigqts(na) * conjg( eigqts(nb) )
! !
! nb is the atom of the augmentation function ! nb is the atom of the augmentation function
! !
@ -178,12 +194,14 @@
* eigts2(mill(2,ig),na) & * eigts2(mill(2,ig),na) &
* eigts3(mill(3,ig),na) * eigts3(mill(3,ig),na)
ENDDO ENDDO
!
DO ipol = 1, 3 DO ipol = 1, 3
DO ig = 1, ngm DO ig = 1, ngm
aux5(ig) = sk(ig) * ( g(ipol,ig) + xq(ipol) ) aux5(ig) = sk(ig) * ( g(ipol,ig) + xq(ipol) )
ENDDO ENDDO
int2(ih,jh,ipol,na,nb) = fact * fact1 * & int2(ih,jh,ipol,na,nb) = fact * fact1 * &
ZDOTC(ngm, aux1, 1, aux5, 1) zdotc(ngm, aux1, 1, aux5, 1)
!
DO jpol = 1, 3 DO jpol = 1, 3
IF (jpol >= ipol) THEN IF (jpol >= ipol) THEN
DO ig = 1, ngm DO ig = 1, ngm
@ -191,45 +209,51 @@
( g(jpol,ig) + xq(jpol) ) ( g(jpol,ig) + xq(jpol) )
ENDDO ENDDO
int5(ijh,ipol,jpol,na,nb) = & int5(ijh,ipol,jpol,na,nb) = &
CONJG(fact) * tpiba2 * omega * & conjg(fact) * tpiba2 * omega * &
ZDOTC(ngm, aux3, 1, aux1, 1) zdotc(ngm, aux3, 1, aux1, 1)
ELSE ELSE
int5(ijh,ipol,jpol,na,nb) = & int5(ijh,ipol,jpol,na,nb) = &
int5(ijh,jpol,ipol,na,nb) int5(ijh,jpol,ipol,na,nb)
ENDIF ENDIF
ENDDO ENDDO
ENDDO ENDDO !ipol
ENDDO !
ENDDO !na
!
DO ig = 1, ngm DO ig = 1, ngm
aux1(ig) = qgm(ig) * eigts1(mill(1,ig),nb) & aux1(ig) = qgm(ig) * eigts1(mill(1,ig),nb) &
* eigts2(mill(2,ig),nb) & * eigts2(mill(2,ig),nb) &
* eigts3(mill(3,ig),nb) * eigts3(mill(3,ig),nb)
ENDDO ENDDO
!
DO is = 1, nspin_mag DO is = 1, nspin_mag
DO ipol = 1, 3 DO ipol = 1, 3
DO ig = 1, ngm DO ig = 1, ngm
aux2(ig) = veff(dfftp%nl(ig),is) * g(ipol,ig) aux2(ig) = veff(dfftp%nl(ig),is) * g(ipol,ig)
ENDDO ENDDO
int1(ih,jh,ipol,nb,is) = - fact1 * & int1(ih,jh,ipol,nb,is) = - fact1 * &
ZDOTC(ngm, aux1, 1, aux2, 1) zdotc(ngm, aux1, 1, aux2, 1)
DO jpol = 1, 3 DO jpol = 1, 3
IF (jpol >= ipol) THEN IF (jpol >= ipol) THEN
DO ig = 1, ngm DO ig = 1, ngm
aux3(ig) = aux2(ig) * g(jpol,ig) aux3(ig) = aux2(ig) * g(jpol,ig)
ENDDO ENDDO
int4(ijh,ipol,jpol,nb,is) = - tpiba2 * & int4(ijh,ipol,jpol,nb,is) = - tpiba2 * &
omega * ZDOTC(ngm, aux3, 1, aux1, 1) omega * zdotc(ngm, aux3, 1, aux1, 1)
ELSE ELSE
int4(ijh,ipol,jpol,nb,is) = & int4(ijh,ipol,jpol,nb,is) = &
int4(ijh,jpol,ipol,nb,is) int4(ijh,jpol,ipol,nb,is)
ENDIF ENDIF
ENDDO ENDDO ! jpol
ENDDO ENDDO ! ipol
ENDDO ENDDO ! is
ENDIF !
ENDDO ENDIF ! ityp
ENDDO ENDDO ! nb
ENDDO !
ENDDO ! jh
ENDDO ! ih
!
DO ih = 1, nh(ntb) DO ih = 1, nh(ntb)
DO jh = ih + 1, nh(ntb) DO jh = ih + 1, nh(ntb)
! !
@ -247,14 +271,17 @@
ENDDO ENDDO
ENDIF ENDIF
ENDDO ENDDO
ENDDO !
ENDDO ENDDO ! jh
ENDIF ENDDO ! ih
ENDDO !
ENDIF ! upf
ENDDO ! ntb
CALL mp_sum(int1, intra_pool_comm) CALL mp_sum(int1, intra_pool_comm)
CALL mp_sum(int2, intra_pool_comm) CALL mp_sum(int2, intra_pool_comm)
CALL mp_sum(int4, intra_pool_comm) CALL mp_sum(int4, intra_pool_comm)
CALL mp_sum(int5, intra_pool_comm) CALL mp_sum(int5, intra_pool_comm)
!
IF (noncolin) THEN IF (noncolin) THEN
CALL set_int12_nc(0) CALL set_int12_nc(0)
int4_nc = czero int4_nc = czero
@ -276,18 +303,29 @@
ENDDO ENDDO
ENDIF ENDIF
! !
DEALLOCATE (veff) !DBRM
DEALLOCATE (qgmq) !write(*,'(a,e20.12)') 'int1 = ', &
DEALLOCATE (qmod) !SUM((REAL(REAL(int1(:,:,:,:,:))))**2)+SUM((REAL(AIMAG(int1(:,:,:,:,:))))**2)
DEALLOCATE (ylmkq) !write(*,'(a,e20.12)') 'int2 = ', &
DEALLOCATE (qgm) !SUM((REAL(REAL(int2(:,:,:,:,:))))**2)+SUM((REAL(AIMAG(int2(:,:,:,:,:))))**2)
DEALLOCATE (ylmk0) !write(*,'(a,e20.12)') 'int4 = ', &
DEALLOCATE (qmodg) !SUM((REAL(REAL(int4(:,:,:,:,:))))**2)+SUM((REAL(AIMAG(int4(:,:,:,:,:))))**2)
DEALLOCATE (aux5) !write(*,'(a,e20.12)') 'int5 = ', &
DEALLOCATE (aux3) !SUM((REAL(REAL(int5(:,:,:,:,:))))**2)+SUM((REAL(AIMAG(int5(:,:,:,:,:))))**2)
DEALLOCATE (aux2) !END
DEALLOCATE (aux1) !
DEALLOCATE (sk) DEALLOCATE(sk)
DEALLOCATE(aux1)
DEALLOCATE(aux2)
DEALLOCATE(aux3)
DEALLOCATE(aux5)
DEALLOCATE(qmodg)
DEALLOCATE(qmod)
DEALLOCATE(qgmq)
DEALLOCATE(qgm)
DEALLOCATE(ylmk0)
DEALLOCATE(ylmkq)
DEALLOCATE(veff)
! !
CALL stop_clock ('dvanqq2') CALL stop_clock ('dvanqq2')
RETURN RETURN

252
EPW/src/dvqpsi_us3.f90
View File

@ -10,7 +10,7 @@
! adapted from PH/dvqpsi_us (QE) ! adapted from PH/dvqpsi_us (QE)
! !
!---------------------------------------------------------------------- !----------------------------------------------------------------------
SUBROUTINE dvqpsi_us3( ik, uact, addnlcc, xxk, xq0 ) SUBROUTINE dvqpsi_us3( ik, uact, addnlcc, xxkq, xq0 )
!---------------------------------------------------------------------- !----------------------------------------------------------------------
!! !!
!! This routine calculates dV_bare/dtau * psi for one perturbation !! This routine calculates dV_bare/dtau * psi for one perturbation
@ -59,10 +59,10 @@
! !
REAL(kind=DP), INTENT (in) :: xq0(3) REAL(kind=DP), INTENT (in) :: xq0(3)
!! Current coarse q-point coordinate !! Current coarse q-point coordinate
REAL(kind=DP), INTENT (in) :: xxk(3) REAL(kind=DP), INTENT (in) :: xxkq(3)
!! k-point coordinate !! k+q point coordinate
! !
COMPLEX(kind=DP), INTENT(in) :: uact (3 * nat) COMPLEX(kind=DP), INTENT(in) :: uact(3 * nat)
!! the pattern of displacements !! the pattern of displacements
! !
! Local variables ! Local variables
@ -86,14 +86,24 @@
INTEGER :: npw INTEGER :: npw
!! Number of k+G-vectors inside 'ecut sphere' !! Number of k+G-vectors inside 'ecut sphere'
! !
REAL(DP) :: fac REAL(kind=DP) :: fac
!! spin degeneracy factor !! spin degeneracy factor
! !
COMPLEX(DP) :: gtau, gu, fact, u1, u2, u3, gu0 COMPLEX(kind=DP) :: gtau
COMPLEX(DP), ALLOCATABLE, TARGET :: aux(:) !! e^{-i G * \tau}
COMPLEX(DP), ALLOCATABLE :: aux1(:), aux2(:) COMPLEX(kind=DP) :: u1, u2, u3
COMPLEX(DP), POINTER :: auxs(:) !! components of displacement pattern u
COMPLEX(DP), ALLOCATABLE :: drhoc(:) COMPLEX(kind=DP) :: gu0
!! scalar product q * u
COMPLEX(kind=DP) :: gu
!! q * u + G * u
COMPLEX(kind=DP) :: fact
!! e^{-i q * \tau}
COMPLEX(kind=DP), ALLOCATABLE, TARGET :: aux(:)
COMPLEX(kind=DP), ALLOCATABLE :: aux1(:), aux2(:)
COMPLEX(kind=DP), POINTER :: auxs(:)
COMPLEX(kind=DP), ALLOCATABLE :: drhoc(:)
!! response core charge density
! !
CALL start_clock('dvqpsi_us3') CALL start_clock('dvqpsi_us3')
! !
@ -115,131 +125,133 @@
dvpsi(:,:) = czero dvpsi(:,:) = czero
aux1(:) = czero aux1(:) = czero
DO na = 1, nat DO na = 1, nat
fact = tpiba * (0.d0, -1.d0) * eigqts(na) fact = tpiba * (0.d0, -1.d0) * eigqts(na)
mu = 3 * (na - 1) mu = 3 * (na - 1)
IF (abs(uact(mu+1)) + abs(uact(mu+2)) + abs(uact(mu+3)) .gt. eps12) THEN u1 = uact(mu+1)
nt = ityp(na) u2 = uact(mu+2)
u1 = uact(mu + 1) u3 = uact(mu+3)
u2 = uact(mu + 2) IF (abs(u1) + abs(u2) + abs(u3) .gt. eps12) THEN
u3 = uact(mu + 3) nt = ityp(na)
gu0 = xq0(1) * u1 + xq0(2) * u2 + xq0(3) * u3 gu0 = xq0(1) * u1 + xq0(2) * u2 + xq0(3) * u3
DO ig = 1, ngms DO ig = 1, ngms
gtau = eigts1(mill(1,ig),na) * eigts2(mill(2,ig),na) * eigts3(mill(3,ig),na) gtau = eigts1(mill(1,ig),na) * &
gu = gu0 + g(1,ig) * u1 + g(2,ig) * u2 + g(3,ig) * u3 eigts2(mill(2,ig),na) * &
aux1( dffts%nl(ig) ) = aux1( dffts%nl(ig) ) + vlocq(ig,nt) * gu * fact * gtau eigts3(mill(3,ig),na)
ENDDO gu = gu0 + g(1,ig) * u1 + g(2,ig) * u2 + g(3,ig) * u3
ENDIF aux1(dffts%nl(ig)) = aux1(dffts%nl(ig)) + vlocq(ig,nt) * gu * fact * gtau
ENDDO
ENDIF
ENDDO ENDDO
! !
! add NLCC when present ! add NLCC when present
! !
IF (nlcc_any .AND. addnlcc) THEN IF (nlcc_any .AND. addnlcc) THEN
drhoc(:) = czero drhoc(:) = czero
DO na = 1, nat DO na = 1, nat
fact = tpiba * (0.d0, -1.d0) * eigqts(na) fact = tpiba * (0.d0, -1.d0) * eigqts(na)
mu = 3 * (na - 1) mu = 3 * (na - 1)
IF (abs(uact(mu+1)) + abs(uact(mu+2)) + abs(uact(mu+3)) .gt. eps12) THEN u1 = uact(mu+1)
nt = ityp(na) u2 = uact(mu+2)
u1 = uact(mu+1) u3 = uact(mu+3)
u2 = uact(mu+2) IF (abs(u1) + abs(u2) + abs(u3) .gt. eps12) THEN
u3 = uact(mu+3) nt = ityp(na)
gu0 = xq0(1) * u1 + xq0(2) * u2 + xq0(3) * u3 gu0 = xq0(1) * u1 + xq0(2) * u2 + xq0(3) * u3
IF (upf(nt)%nlcc) THEN IF (upf(nt)%nlcc) THEN
DO ig = 1,ngm DO ig = 1,ngm
gtau = eigts1(mill(1,ig),na) * & gtau = eigts1(mill(1,ig),na) * &
eigts2(mill(2,ig),na) * & eigts2(mill(2,ig),na) * &
eigts3(mill(3,ig),na) eigts3(mill(3,ig),na)
gu = gu0 + g(1,ig) * u1 + g(2,ig) * u2 + g(3,ig) * u3 gu = gu0 + g(1,ig) * u1 + g(2,ig) * u2 + g(3,ig) * u3
drhoc(dfftp%nl(ig)) = drhoc(dfftp%nl(ig)) + drc(ig,nt) * gu * fact * gtau drhoc(dfftp%nl(ig)) = drhoc(dfftp%nl(ig)) + drc(ig,nt) * gu * fact * gtau
ENDDO ENDDO
ENDIF ENDIF
ENDIF
ENDDO
!
CALL invfft('Rho', drhoc, dfftp)
!
IF (.not.lsda) THEN
DO ir = 1, dfftp%nnr
aux(ir) = drhoc(ir) * dmuxc(ir,1,1)
ENDDO
ELSE
is = isk(ik)
DO ir = 1, dfftp%nnr
aux(ir) = drhoc(ir) * 0.5d0 * ( dmuxc(ir,is,1) + dmuxc(ir,is,2) )
ENDDO
ENDIF ENDIF
! ENDDO
fac = 1.d0 / dble(nspin_lsda) !
DO is = 1, nspin_lsda CALL invfft('Rho', drhoc, dfftp)
rho%of_r(:,is) = rho%of_r(:,is) + fac * rho_core !
IF (.not.lsda) THEN
DO ir = 1, dfftp%nnr
aux(ir) = drhoc(ir) * dmuxc(ir,1,1)
ENDDO ENDDO
! ELSE
IF ( dft_is_gradient() ) & is = isk(ik)
CALL dgradcorr( dfftp, rho%of_r, grho, & DO ir = 1, dfftp%nnr
dvxc_rr, dvxc_sr, dvxc_ss, dvxc_s, xq0, drhoc, & aux(ir) = drhoc(ir) * 0.5d0 * ( dmuxc(ir,is,1) + dmuxc(ir,is,2) )
1, nspin_gga, g, aux )
!
IF ( dft_is_nonlocc() ) &
CALL dnonloccorr( rho%of_r, drhoc, xq0, aux )
!
DO is = 1, nspin_lsda
rho%of_r(:,is) = rho%of_r(:,is) - fac * rho_core
END DO
!
CALL fwfft('Rho', aux, dfftp)
!
! This is needed also when the smooth and the thick grids coincide to
! cut the potential at the cut-off
!
auxs(:) = czero
DO ig = 1, ngms
auxs(dffts%nl(ig)) = aux(dfftp%nl(ig))
ENDDO ENDDO
aux1(:) = aux1(:) + auxs(:) ENDIF
ENDIF !
fac = 1.d0 / dble(nspin_lsda)
DO is = 1, nspin_lsda
rho%of_r(:,is) = rho%of_r(:,is) + fac * rho_core
ENDDO
!
IF ( dft_is_gradient() ) &
CALL dgradcorr( dfftp, rho%of_r, grho, &
dvxc_rr, dvxc_sr, dvxc_ss, dvxc_s, xq0, drhoc, &
1, nspin_gga, g, aux )
!
IF ( dft_is_nonlocc() ) &
CALL dnonloccorr( rho%of_r, drhoc, xq0, aux )
!
DO is = 1, nspin_lsda
rho%of_r(:,is) = rho%of_r(:,is) - fac * rho_core
ENDDO
!
CALL fwfft('Rho', aux, dfftp)
!
! This is needed also when the smooth and the thick grids coincide to
! cut the potential at the cut-off
!
auxs(:) = czero
DO ig = 1, ngms
auxs(dffts%nl(ig)) = aux(dfftp%nl(ig))
ENDDO
aux1(:) = aux1(:) + auxs(:)
ENDIF
! !
! Now we compute dV_loc/dtau in real space ! Now we compute dV_loc/dtau in real space
! !
CALL invfft('Rho', aux1, dffts) CALL invfft('Rho', aux1, dffts)
DO ibnd = lower_band, upper_band DO ibnd = lower_band, upper_band
DO ip = 1, npol DO ip = 1, npol
aux2(:) = czero aux2(:) = czero
IF ( ip == 1 ) THEN IF ( ip == 1 ) THEN
DO ig = 1, npw DO ig = 1, npw
aux2( dffts%nl( igk(ig) ) ) = evc(ig,ibnd) aux2( dffts%nl( igk(ig) ) ) = evc(ig,ibnd)
ENDDO
ELSE
DO ig = 1, npw
aux2( dffts%nl( igk(ig) ) ) = evc(ig+npwx,ibnd)
ENDDO
ENDIF
!
! This wavefunction is computed in real space
!
CALL invfft('Wave', aux2, dffts)
DO ir = 1, dffts%nnr
aux2(ir) = aux2(ir) * aux1(ir)
ENDDO ENDDO
! ELSE
! and finally dV_loc/dtau * psi is transformed in reciprocal space DO ig = 1, npw
! aux2( dffts%nl( igk(ig) ) ) = evc(ig+npwx,ibnd)
CALL fwfft('Wave', aux2, dffts) ENDDO
IF ( ip == 1 ) THEN ENDIF
DO ig = 1, npwq !
dvpsi(ig,ibnd) = aux2( dffts%nl( igkq(ig) ) ) ! This wavefunction is computed in real space
ENDDO !
ELSE CALL invfft('Wave', aux2, dffts)
DO ig = 1, npwq DO ir = 1, dffts%nnr
dvpsi(ig+npwx,ibnd) = aux2( dffts%nl( igkq(ig) ) ) aux2(ir) = aux2(ir) * aux1(ir)
ENDDO ENDDO
ENDIF !
ENDDO ! and finally dV_loc/dtau * psi is transformed in reciprocal space
!
CALL fwfft('Wave', aux2, dffts)
IF ( ip == 1 ) THEN
DO ig = 1, npwq
dvpsi(ig,ibnd) = aux2( dffts%nl( igkq(ig) ) )
ENDDO
ELSE
DO ig = 1, npwq
dvpsi(ig+npwx,ibnd) = aux2( dffts%nl( igkq(ig) ) )
ENDDO
ENDIF
ENDDO
ENDDO ENDDO
! !
IF (nlcc_any .AND. addnlcc) THEN IF (nlcc_any .AND. addnlcc) THEN
DEALLOCATE(drhoc) DEALLOCATE(drhoc)
DEALLOCATE(aux) DEALLOCATE(aux)
DEALLOCATE(auxs) DEALLOCATE(auxs)
ENDIF ENDIF
DEALLOCATE(aux1) DEALLOCATE(aux1)
DEALLOCATE(aux2) DEALLOCATE(aux2)
@ -248,7 +260,7 @@
! First a term similar to the KB case. ! First a term similar to the KB case.
! Then a term due to the change of the D coefficients in the perturbat ! Then a term due to the change of the D coefficients in the perturbat
! !
CALL dvqpsi_us_only3( ik, uact, xxk ) CALL dvqpsi_us_only3( ik, uact, xxkq )
! !
CALL stop_clock('dvqpsi_us3') CALL stop_clock('dvqpsi_us3')
! !

116
EPW/src/dvqpsi_us_only3.f90
View File

@ -10,7 +10,7 @@
! adapted from PH/dvqpsi_us_only (QE) ! adapted from PH/dvqpsi_us_only (QE)
! !
!---------------------------------------------------------------------- !----------------------------------------------------------------------
subroutine dvqpsi_us_only3( ik, uact, xxk ) subroutine dvqpsi_us_only3( ik, uact, xxkq )
!---------------------------------------------------------------------- !----------------------------------------------------------------------
!! !!
!! This routine calculates dV_bare/dtau * psi for one perturbation !! This routine calculates dV_bare/dtau * psi for one perturbation
@ -41,11 +41,11 @@
IMPLICIT NONE IMPLICIT NONE
! !
INTEGER, INTENT(in) :: ik INTEGER, INTENT(in) :: ik
!! Input: the k point !! the k point
REAL(kind=DP), INTENT(in) :: xxk(3) REAL(kind=DP), INTENT(in) :: xxkq(3)
!! input: the k point (cartesian coordinates) !! the k+q point (cartesian coordinates)
COMPLEX(kind=DP), INTENT(in) :: uact (3 * nat) COMPLEX(kind=DP), INTENT(in) :: uact(3 * nat)
!! input: the pattern of displacements !! the pattern of displacements
! !
! Local variables ! Local variables
! !
@ -84,10 +84,10 @@
INTEGER :: ijs INTEGER :: ijs
!! Counter on combined is and js polarization !! Counter on combined is and js polarization
! !
REAL(DP), ALLOCATABLE :: deff(:,:,:) REAL(kind=DP), ALLOCATABLE :: deff(:,:,:)
! !
COMPLEX(DP), ALLOCATABLE :: ps1(:,:), ps2(:,:,:), aux(:), deff_nc(:,:,:,:) COMPLEX(kind=DP), ALLOCATABLE :: ps1(:,:), ps2(:,:,:), aux(:), deff_nc(:,:,:,:)
COMPLEX(DP), ALLOCATABLE :: ps1_nc(:,:,:), ps2_nc(:,:,:,:) COMPLEX(kind=DP), ALLOCATABLE :: ps1_nc(:,:,:), ps2_nc(:,:,:,:)
! !
LOGICAL :: ok LOGICAL :: ok
! !
@ -124,16 +124,14 @@
ijkb0 = 0 ijkb0 = 0
DO nt = 1, ntyp DO nt = 1, ntyp
DO na = 1, nat DO na = 1, nat
IF (ityp (na) .eq. nt) THEN IF (ityp(na) .eq. nt) THEN
mu = 3 * (na - 1) mu = 3 * (na - 1)
DO ih = 1, nh(nt) DO ih = 1, nh(nt)
ikb = ijkb0 + ih ikb = ijkb0 + ih
DO jh = 1, nh(nt) DO jh = 1, nh(nt)
jkb = ijkb0 + jh jkb = ijkb0 + jh
DO ipol = 1, 3 DO ipol = 1, 3
IF ( abs( uact(mu + 1) ) + & IF ( abs( uact(mu+1) ) + abs( uact(mu+2) ) + abs( uact(mu+3) ) > eps12 ) THEN
abs( uact(mu + 2) ) + &
abs( uact(mu + 3) ) > eps12 ) THEN
IF (noncolin) THEN IF (noncolin) THEN
ijs = 0 ijs = 0
DO is = 1, npol DO is = 1, npol
@ -155,52 +153,52 @@
deff(ih,jh,na) * becp1(ik)%k(jkb,ibnd) * & deff(ih,jh,na) * becp1(ik)%k(jkb,ibnd) * &
(0.d0,-1.d0) * uact(mu+ipol) * tpiba (0.d0,-1.d0) * uact(mu+ipol) * tpiba
ENDIF ENDIF
IF (okvan) THEN ! IF (okvan) THEN
IF (noncolin) THEN ! IF (noncolin) THEN
ijs = 0 ! ijs = 0
DO is = 1, npol ! DO is = 1, npol
DO js = 1, npol ! DO js = 1, npol
ijs = ijs + 1 ! ijs = ijs + 1
ps1_nc(ikb,is,ibnd) = ps1_nc(ikb,is,ibnd) + & ! ps1_nc(ikb,is,ibnd) = ps1_nc(ikb,is,ibnd) + &
int1_nc(ih,jh,ipol,na,ijs) * & ! int1_nc(ih,jh,ipol,na,ijs) * &
becp1(ik)%nc(jkb,js,ibnd) * uact(mu+ipol) ! becp1(ik)%nc(jkb,js,ibnd) * uact(mu+ipol)
ENDDO ! ENDDO
ENDDO ! ENDDO
ELSE ! ELSE
ps1(ikb,ibnd) = ps1(ikb, ibnd) + & ! ps1(ikb,ibnd) = ps1(ikb, ibnd) + &
int1(ih,jh,ipol,na,current_spin) * & ! int1(ih,jh,ipol,na,current_spin) * &
becp1(ik)%k(jkb,ibnd) * uact(mu +ipol) ! becp1(ik)%k(jkb,ibnd) * uact(mu+ipol)
ENDIF ! ENDIF
ENDIF ! ENDIF ! okvan
ENDIF ! uact>0 ENDIF ! uact>0
IF (okvan) THEN ! IF (okvan) THEN
DO nb = 1, nat ! DO nb = 1, nat
nu = 3 * (nb - 1) ! nu = 3 * (nb - 1)
IF (noncolin) THEN ! IF (noncolin) THEN
IF (lspinorb) THEN ! IF (lspinorb) THEN
ijs = 0 ! ijs = 0
DO is = 1, npol ! DO is = 1, npol
DO js = 1, npol ! DO js = 1, npol
ijs = ijs + 1 ! ijs = ijs + 1
ps1_nc(ikb,is,ibnd) = ps1_nc(ikb,is,ibnd) + & ! ps1_nc(ikb,is,ibnd) = ps1_nc(ikb,is,ibnd) + &
int2_so(ih,jh,ipol,nb,na,ijs) * & ! int2_so(ih,jh,ipol,nb,na,ijs) * &
becp1(ik)%nc(jkb,js,ibnd) * uact(nu+ipol) ! becp1(ik)%nc(jkb,js,ibnd) * uact(nu+ipol)
ENDDO ! ENDDO
ENDDO ! ENDDO
ELSE ! ELSE
DO is = 1, npol ! DO is = 1, npol
ps1_nc(ikb,is,ibnd) = ps1_nc(ikb,is,ibnd) + & ! ps1_nc(ikb,is,ibnd) = ps1_nc(ikb,is,ibnd) + &
int2(ih,jh,ipol,nb,na) * & ! int2(ih,jh,ipol,nb,na) * &
becp1(ik)%nc(jkb,is,ibnd) * uact(nu+ipol) ! becp1(ik)%nc(jkb,is,ibnd) * uact(nu+ipol)
ENDDO ! ENDDO
ENDIF ! ENDIF
ELSE ! ELSE
ps1(ikb,ibnd) = ps1(ikb,ibnd) + & ! ps1(ikb,ibnd) = ps1(ikb,ibnd) + &
int2(ih,jh,ipol,nb,na) * & ! int2(ih,jh,ipol,nb,na) * &
becp1(ik)%k(jkb,ibnd) * uact(nu+ipol) ! becp1(ik)%k(jkb,ibnd) * uact(nu+ipol)
ENDIF ! ENDIF
ENDDO ! ENDDO
ENDIF ! okvan ! ENDIF ! okvan
ENDDO ! ipol ENDDO ! ipol
ENDDO ! jh ENDDO ! jh
ENDDO ! ih ENDDO ! ih
@ -241,7 +239,7 @@
DO ig = 1, npwq DO ig = 1, npwq
igg = igkq(ig) igg = igkq(ig)
!aux(ig) = vkb(ig,ikb) * ( xk(ipol,ikq) + g(ipol,igg) ) !aux(ig) = vkb(ig,ikb) * ( xk(ipol,ikq) + g(ipol,igg) )
aux(ig) = vkb(ig,ikb) * ( xxk(ipol) + g(ipol,igg) ) aux(ig) = vkb(ig,ikb) * ( xxkq(ipol) + g(ipol,igg) )
ENDDO ENDDO
DO ibnd = lower_band, upper_band DO ibnd = lower_band, upper_band
IF (noncolin) THEN IF (noncolin) THEN

67
EPW/src/elphel2_shuffle.f90
View File

@ -154,23 +154,23 @@
!! Absolute index of k+q-point !! Absolute index of k+q-point
! !
! Local variables for rotating the wavefunctions (in order to use q in the irr wedge) ! Local variables for rotating the wavefunctions (in order to use q in the irr wedge)
REAL(DP) :: xktmp(3) REAL(kind=DP) :: xkqtmp(3)
!! Temporary k+q vector for KB projectors !! Temporary k+q vector for KB projectors
REAL(DP) :: sxk(3) REAL(kind=DP) :: sxk(3)
!! !! Rotated k-point xk
REAL(DP) :: g0vec_all_r(3,125) REAL(kind=DP) :: g0vec_all_r(3,125)
!! G_0 vectors needed to fold the k+q grid into the k grid, cartesian coord. !! G_0 vectors needed to fold the k+q grid into the k grid, cartesian coord.
REAL(DP) :: zero_vect(3) REAL(kind=DP) :: zero_vect(3)
!! Temporary zero vector !! Temporary zero vector
! !
COMPLEX(DP), ALLOCATABLE :: aux1(:,:), aux2(:,:), aux3(:,:) COMPLEX(kind=DP), ALLOCATABLE :: aux1(:,:), aux2(:,:), aux3(:,:)
COMPLEX(DP), ALLOCATABLE :: eptmp(:,:), elphmat(:,:,:) COMPLEX(kind=DP), ALLOCATABLE :: eptmp(:,:), elphmat(:,:,:)
!! arrays for e-ph matrix elements !! arrays for e-ph matrix elements
! !
!DBSP - NAG complains ... !DBSP - NAG complains ...
COMPLEX(DP), EXTERNAL :: ZDOTC COMPLEX(kind=DP), EXTERNAL :: zdotc
!DBSP !DBSP
! REAL(kind=DP) :: b,c ! REAL(kind=DP) :: b, c, d
!END !END
! !
IF ( .not. ALLOCATED(elphmat) ) ALLOCATE( elphmat(nbnd, nbnd, npe) ) IF ( .not. ALLOCATED(elphmat) ) ALLOCATE( elphmat(nbnd, nbnd, npe) )
@ -221,8 +221,9 @@
IF (lsda) current_spin = isk(ik) IF (lsda) current_spin = isk(ik)
elphmat(:,:,:) = czero elphmat(:,:,:) = czero
!DBSP !DBSP
! c = 0 ! b = zero
! b = 0 ! c = zero
! d = zero
!END !END
! !
! find index, and possibly pool, of k+q ! find index, and possibly pool, of k+q
@ -285,7 +286,7 @@
umatq(:,:,ik) = umat_all(:,:,nkq_abs) umatq(:,:,ik) = umat_all(:,:,nkq_abs)
! !
! the k-vector needed for the KB projectors ! the k-vector needed for the KB projectors
xktmp = xkq(:,ik) xkqtmp = xkq(:,ik)
! !
! -------------------------------------------------- ! --------------------------------------------------
! Fourier translation of the G-sphere igkq ! Fourier translation of the G-sphere igkq
@ -306,7 +307,7 @@
! (this is needed in the calculation of the KB terms ! (this is needed in the calculation of the KB terms
! for nonlocal pseudos) ! for nonlocal pseudos)
! !
xktmp = xkq(:,ik) - g0vec_all_r(:,shift(ik+ik0)) xkqtmp = xkq(:,ik) - g0vec_all_r(:,shift(ik+ik0))
! !
! --------------------------------------------------------------------- ! ---------------------------------------------------------------------
! phase factor arising from fractional traslations ! phase factor arising from fractional traslations
@ -371,8 +372,8 @@
! now we generate vkb on the igkq() set because dvpsi is needed on that set ! now we generate vkb on the igkq() set because dvpsi is needed on that set
! we need S(k)+q_0 in the KB projector: total momentum transfer must be q_0 ! we need S(k)+q_0 in the KB projector: total momentum transfer must be q_0
! !
xktmp = sxk + xq0 xkqtmp = sxk + xq0
CALL init_us_2( npwq, igkq, xktmp, vkb ) CALL init_us_2( npwq, igkq, xkqtmp, vkb )
! !
! -------------------------------------------------- ! --------------------------------------------------
! Calculation of the matrix element ! Calculation of the matrix element
@ -382,15 +383,15 @@
! !
! recalculate dvbare_q*psi_k ! recalculate dvbare_q*psi_k
! the call to dvqpsi_us3 differs from the old one to dvqpsi_us ! the call to dvqpsi_us3 differs from the old one to dvqpsi_us
! only the xktmp passed. ! only the xkqtmp passed.
! !
! we have to use the first q in the star in the dvqpsi_us3 call below (xq0) ! we have to use the first q in the star in the dvqpsi_us3 call below (xq0)
! !
mode = imode0 + ipert mode = imode0 + ipert
IF (timerev) THEN IF (timerev) THEN
CALL dvqpsi_us3( ik, CONJG(u(:,mode)), .false., xktmp, xq0 ) CALL dvqpsi_us3( ik, conjg(u(:,mode)), .false., xkqtmp, xq0 )
ELSE ELSE
CALL dvqpsi_us3( ik, u(:,mode), .false., xktmp, xq0 ) CALL dvqpsi_us3( ik, u(:,mode), .false., xkqtmp, xq0 )
ENDIF ENDIF
!DBSP !DBSP
! b = b+SUM((REAL(REAL(dvpsi(:,:))))**2)+SUM((REAL(AIMAG(dvpsi(:,:))))**2) ! b = b+SUM((REAL(REAL(dvpsi(:,:))))**2)+SUM((REAL(AIMAG(dvpsi(:,:))))**2)
@ -404,7 +405,7 @@
DO ibnd = lower_band, upper_band DO ibnd = lower_band, upper_band
CALL invfft_wave(npw, igk, evc(:,ibnd), aux1) CALL invfft_wave(npw, igk, evc(:,ibnd), aux1)
IF (timerev) THEN IF (timerev) THEN
CALL apply_dpot(dffts%nnr, aux1, CONJG(dvscfins(:,:,ipert)), current_spin) CALL apply_dpot(dffts%nnr, aux1, conjg(dvscfins(:,:,ipert)), current_spin)
ELSE ELSE
CALL apply_dpot(dffts%nnr, aux1, dvscfins(:,:,ipert), current_spin) CALL apply_dpot(dffts%nnr, aux1, dvscfins(:,:,ipert), current_spin)
ENDIF ENDIF
@ -412,10 +413,13 @@
ENDDO ENDDO
dvpsi = dvpsi + aux3 dvpsi = dvpsi + aux3
! !
CALL adddvscf2( ipert, ik )
!
!DBSP !DBSP
!c = c+SUM((REAL(REAL(dvpsi(:,:))))**2)+SUM((REAL(AIMAG(dvpsi(:,:))))**2) ! c = c+SUM((REAL(REAL(dvpsi(:,:))))**2)+SUM((REAL(AIMAG(dvpsi(:,:))))**2)
!END
!
CALL adddvscf2( ipert, ik )
!DBRM
! d = c+SUM((REAL(REAL(dvpsi(:,:))))**2)+SUM((REAL(AIMAG(dvpsi(:,:))))**2)
!END !END
! !
! calculate elphmat(j,i)=<psi_{k+q,j}|dvscf_q*psi_{k,i}> for this pertur ! calculate elphmat(j,i)=<psi_{k+q,j}|dvscf_q*psi_{k,i}> for this pertur
@ -424,10 +428,10 @@
DO ibnd =lower_band, upper_band DO ibnd =lower_band, upper_band
DO jbnd = 1, nbnd DO jbnd = 1, nbnd
elphmat(jbnd,ibnd,ipert) = & elphmat(jbnd,ibnd,ipert) = &
ZDOTC( npwq, evq(1,jbnd), 1, dvpsi(1,ibnd), 1 ) zdotc( npwq, evq(1,jbnd), 1, dvpsi(1,ibnd), 1 )
IF (noncolin) & IF (noncolin) &
elphmat(jbnd,ibnd,ipert) = elphmat(jbnd,ibnd,ipert) + & elphmat(jbnd,ibnd,ipert) = elphmat(jbnd,ibnd,ipert) + &
ZDOTC( npwq, evq(npwx+1,jbnd), 1, dvpsi(npwx+1,ibnd), 1 ) zdotc( npwq, evq(npwx+1,jbnd), 1, dvpsi(npwx+1,ibnd), 1 )
ENDDO ENDDO
ENDDO ENDDO
ENDDO ENDDO
@ -439,7 +443,8 @@
! IF (ik==2) THEN ! IF (ik==2) THEN
! write(*,*)'SUM dvpsi b ', b ! write(*,*)'SUM dvpsi b ', b
! write(*,*)'SUM dvpsi c ', c ! write(*,*)'SUM dvpsi c ', c
! write(*,*)'elphmat(:,:,:)**2',SUM((REAL(REAL(elphmat(:,:,:))))**2)+SUM((REAL(AIMAG(elphmat(:,:,:))))**2) ! write(*,*)'SUM dvpsi d ', d
! write(*,*)'elphmat(:,:,:)**2', SUM((REAL(REAL(elphmat(:,:,:))))**2)+SUM((REAL(AIMAG(elphmat(:,:,:))))**2)
! ENDIF ! ENDIF
!END !END
! !
@ -498,8 +503,8 @@
IMPLICIT NONE IMPLICIT NONE
! !
INTEGER, INTENT(in) :: npw, igk(npwx) INTEGER, INTENT(in) :: npw, igk(npwx)
COMPLEX(DP), INTENT(inout) :: evc(npwx*npol, nbnd) COMPLEX(kind=DP), INTENT(inout) :: evc(npwx*npol, nbnd)
COMPLEX(DP), INTENT(in) :: eigv1(ngm), eig0v COMPLEX(kind=DP), INTENT(in) :: eigv1(ngm), eig0v
! !
INTEGER :: ig INTEGER :: ig
!! Counter on G-vectors !! Counter on G-vectors
@ -529,11 +534,15 @@
! !
IMPLICIT NONE IMPLICIT NONE
! !
REAL(kind=DP), INTENT(in) :: x(3)
!! Input x
INTEGER, INTENT(in) :: s(3,3) INTEGER, INTENT(in) :: s(3,3)
REAL(DP), INTENT(in) :: x(3) !! Symmetry matrix
REAL(DP), INTENT(out) :: sx(3) REAL(kind=DP), INTENT(out) :: sx(3)
!! Output rotated x
! !
REAL(DP) :: xcrys(3) REAL(DP) :: xcrys(3)
!! x in cartesian coords
INTEGER :: i INTEGER :: i
! !
xcrys = x xcrys = x

49
EPW/src/elphon_shuffle.f90
View File

@ -13,8 +13,6 @@
!! Electron-phonon calculation from data saved in fildvscf !! Electron-phonon calculation from data saved in fildvscf
!! Shuffle2 mode (shuffle on electrons + load all phonon q's) !! Shuffle2 mode (shuffle on electrons + load all phonon q's)
!! !!
!! No ultrasoft yet
!!
!! RM - Nov/Dec 2014 !! RM - Nov/Dec 2014
!! Imported the noncolinear case implemented by xlzhang !! Imported the noncolinear case implemented by xlzhang
!! !!
@ -24,9 +22,7 @@
! !
USE kinds, ONLY : DP USE kinds, ONLY : DP
USE mp, ONLY : mp_barrier, mp_sum USE mp, ONLY : mp_barrier, mp_sum
USE mp_global, ONLY : my_pool_id, nproc_pool, npool, kunit, & USE mp_global, ONLY : my_pool_id, npool, inter_pool_comm
inter_pool_comm
USE mp_images, ONLY : nproc_image
USE ions_base, ONLY : nat USE ions_base, ONLY : nat
USE pwcom, ONLY : nbnd, nks, nkstot USE pwcom, ONLY : nbnd, nks, nkstot
USE gvect, ONLY : ngm USE gvect, ONLY : ngm
@ -79,47 +75,14 @@
!! Counter on bands !! Counter on bands
INTEGER :: jbnd INTEGER :: jbnd
!! Counter on bands !! Counter on bands
INTEGER :: tmp_pool_id
!! temporary pool id
INTEGER :: iks
!! Index of the first k-point block in this pool
INTEGER :: ik0
!! Index of iks - 1
INTEGER :: nkl
!!
INTEGER :: nkr
!!
! !
COMPLEX(DP), POINTER :: dvscfin(:,:,:) COMPLEX(kind=DP), POINTER :: dvscfin(:,:,:)
!! Change of the scf potential !! Change of the scf potential
COMPLEX(DP), POINTER :: dvscfins(:,:,:) COMPLEX(kind=DP), POINTER :: dvscfins(:,:,:)
!! Change of the scf potential (smooth) !! Change of the scf potential (smooth)
! !
CALL start_clock('elphon_shuffle') CALL start_clock('elphon_shuffle')
! !
ik0 = 0
tmp_pool_id = 0
!
npool = nproc_image / nproc_pool
IF (npool.gt.1) THEN
!
! number of kpoint blocks, kpoints per pool and reminder
kunit = 1
nkl = kunit * ( nkstot / npool )
nkr = ( nkstot - nkl * npool ) / kunit
! the reminder goes to the first nkr pools
IF ( my_pool_id < nkr ) nkl = nkl + kunit
!
iks = nkl * my_pool_id + 1
IF ( my_pool_id >= nkr ) iks = iks + nkr * kunit
!
! the index of the first k point block in this pool - 1
! (I will need the index of ik, not ikk)
!
ik0 = ( iks - 1 ) / kunit
!
ENDIF
!
! read Delta Vscf and calculate electron-phonon coefficients ! read Delta Vscf and calculate electron-phonon coefficients
! !
imode0 = 0 imode0 = 0
@ -152,7 +115,7 @@
dvscfins => dvscfin dvscfins => dvscfin
ENDIF ENDIF
! !
CALL newdq2( dvscfin, npe ) CALL newdq2( dvscfin, npe, xq0, timerev )
CALL elphel2_shuffle( npe, imode0, dvscfins, gmapsym, eigv, isym, xq0, timerev ) CALL elphel2_shuffle( npe, imode0, dvscfins, gmapsym, eigv, isym, xq0, timerev )
! !
imode0 = imode0 + npe imode0 = imode0 + npe
@ -170,8 +133,8 @@
! must be transformed in the cartesian basis ! must be transformed in the cartesian basis
! epmat_{CART} = conjg ( U ) * epmat_{PATTERN} ! epmat_{CART} = conjg ( U ) * epmat_{PATTERN}
! !
! note it is not U^\dagger ! Have a look to symdyn_munu.f90 ! note it is not U^\dagger but u_pattern!
! for comparison ! Have a look to symdyn_munu.f90 for comparison
! !
DO ibnd = 1, nbnd DO ibnd = 1, nbnd
DO jbnd = 1, nbnd DO jbnd = 1, nbnd

47
EPW/src/elphon_shuffle_wrap.f90
View File

@ -455,15 +455,12 @@
! !
minus_q = (iswitch .gt. -3) minus_q = (iswitch .gt. -3)
! !
! ! Initialize vlocq for the current irreducible q-point
! CALL epw_init(.false.)
!
! loop over the q points of the star ! loop over the q points of the star
! !
DO iq = 1, nq DO iq = 1, nq
! SP: First the vlocq needs to be initialized properly with the first ! SP: First the vlocq needs to be initialized properly with the first
! q in the star ! q in the star
xq = xq0 xq = xq0
CALL epw_init(.false.) CALL epw_init(.false.)
! !
! retrieve the q in the star ! retrieve the q in the star
@ -655,15 +652,14 @@
! !
CALL createkmap( xq ) CALL createkmap( xq )
! !
xq0 = -xq0
!
CALL loadumat( nbnd, nbndsub, nks, nkstot, xq, cu, cuq, lwin, lwinq, exband, w_centers ) CALL loadumat( nbnd, nbndsub, nks, nkstot, xq, cu, cuq, lwin, lwinq, exband, w_centers )
! !
! Calculate overlap U_k+q U_k^\dagger ! Calculate overlap U_k+q U_k^\dagger
IF (lpolar) CALL compute_umn_c( nbnd, nbndsub, nks, cu, cuq, bmat(:,:,:,nqc) ) IF (lpolar) CALL compute_umn_c( nbnd, nbndsub, nks, cu, cuq, bmat(:,:,:,nqc) )
! !
CALL elphon_shuffle( iq_irr, nqc_irr, nqc, gmapsym, eigv, isym, xq0, .true. ) xq0 = -xq0
! !
CALL elphon_shuffle( iq_irr, nqc_irr, nqc, gmapsym, eigv, isym, xq0, .true. )
! bring epmatq in the mode representation of iq_first, ! bring epmatq in the mode representation of iq_first,
! and then in the cartesian representation of iq ! and then in the cartesian representation of iq
! !
@ -795,20 +791,20 @@
! !
IMPLICIT NONE IMPLICIT NONE
! !
REAL(DP), INTENT(in):: x(3) REAL(kind=DP), INTENT(in) :: x(3)
!! Input x !! Input x
INTEGER, INTENT(in) :: s(3,3) INTEGER, INTENT(in) :: s(3,3)
!! Symmetry matrix !! Symmetry matrix
REAL(DP), INTENT(out):: sx(3) REAL(kind=DP), INTENT(out) :: sx(3)
!! Output rotated one. !! Output rotated x
! !
! Local Variable ! Local Variable
INTEGER :: i INTEGER :: i
! !
DO i = 1, 3 DO i = 1, 3
sx (i) = dble( s(i,1) ) * x(1) & sx(i) = dble( s(i,1) ) * x(1) &
+ dble( s(i,2) ) * x(2) & + dble( s(i,2) ) * x(2) &
+ dble( s(i,3) ) * x(3) + dble( s(i,3) ) * x(3)
ENDDO ENDDO
! !
RETURN RETURN
@ -824,12 +820,12 @@
! !
IMPLICIT NONE IMPLICIT NONE
! !
REAL(DP), INTENT(in) :: x(3) REAL(kind=DP), INTENT(in) :: x(3)
!! input: input vector !! input: input vector
REAL(DP), INTENT(in) :: y(3) REAL(kind=DP), INTENT(in) :: y(3)
!! input: second input vector !! input: second input vector
REAL(DP) :: accep REAL(kind=DP) :: accep
!! acceptance PARAMETER !! acceptance parameter
PARAMETER (accep = 1.0d-5) PARAMETER (accep = 1.0d-5)
! !
eqvect_strict = abs( x(1)-y(1) ) .lt. accep .AND. & eqvect_strict = abs( x(1)-y(1) ) .lt. accep .AND. &
@ -853,13 +849,22 @@
! !
IMPLICIT NONE IMPLICIT NONE
! !
INTEGER, INTENT(IN) :: current_iq INTEGER, INTENT(in) :: current_iq
!! Current q-point !! Current q-point
INTEGER, INTENT(IN) :: iunpun INTEGER, INTENT(in) :: iunpun
!! Current q-point !! Current q-point
INTEGER, INTENT(OUT) :: ierr INTEGER, INTENT(out) :: ierr
!! Error !! Error
INTEGER :: imode0, imode, irr, ipert, iq !
! Local variables
INTEGER :: imode0, imode
!! Counter on modes
INTEGER :: irr
!! Counter on irreducible representations
INTEGER :: ipert
!! Counter on perturbations at each irr
INTEGER :: iq
!! Current q-point
! !
ierr = 0 ierr = 0
IF (meta_ionode) THEN IF (meta_ionode) THEN

78
EPW/src/newdq2.f90
View File

@ -11,7 +11,7 @@
! Adapted from LR_Modules/newdq.f90 (QE) ! Adapted from LR_Modules/newdq.f90 (QE)
! !
!---------------------------------------------------------------------- !----------------------------------------------------------------------
SUBROUTINE newdq2( dvscf, npe ) SUBROUTINE newdq2( dvscf, npe, xq0, timerev )
!---------------------------------------------------------------------- !----------------------------------------------------------------------
!! !!
!! This routine computes the contribution of the selfconsistent !! This routine computes the contribution of the selfconsistent
@ -32,15 +32,19 @@
USE mp_global, ONLY : intra_pool_comm USE mp_global, ONLY : intra_pool_comm
USE mp, ONLY : mp_sum USE mp, ONLY : mp_sum
USE lrus, ONLY : int3 USE lrus, ONLY : int3
USE qpoint, ONLY : xq, eigqts USE qpoint, ONLY : eigqts
USE constants_epw, ONLY : czero USE constants_epw, ONLY : czero
! !
IMPLICIT NONE IMPLICIT NONE
! !
INTEGER, INTENT(in) :: npe INTEGER, INTENT(in) :: npe
!! Number of perturbations for this irr representation !! Number of perturbations for this irr representation
COMPLEX(DP), INTENT(in) :: dvscf(dfftp%nnr, nspin_mag, npe) REAL(kind=DP), INTENT(in) :: xq0(3)
!! The first q-point in the star (cartesian coords.)
COMPLEX(kind=DP), INTENT(in) :: dvscf(dfftp%nnr, nspin_mag, npe)
!! Change of the selfconsistent potential !! Change of the selfconsistent potential
LOGICAL, INTENT(in) :: timerev
!! true if we are using time reversal
! !
! Local variables ! Local variables
! !
@ -61,16 +65,20 @@
INTEGER :: jh INTEGER :: jh
!! Counter on beta functions !! Counter on beta functions
! !
REAL(DP), ALLOCATABLE :: qmod(:) REAL(kind=DP), ALLOCATABLE :: qmod(:)
!! the modulus of q+G !! the modulus of q+G
REAL(DP), ALLOCATABLE :: qg(:,:) REAL(kind=DP), ALLOCATABLE :: qg(:,:)
!! the values of q+G !! the values of q+G
REAL(DP), ALLOCATABLE :: ylmk0(:,:) REAL(kind=DP), ALLOCATABLE :: ylmk0(:,:)
!! the spherical harmonics !! the spherical harmonics at q+G
! !
COMPLEX(DP), EXTERNAL :: zdotc COMPLEX(kind=DP), EXTERNAL :: zdotc
!! the scalar product function !! the scalar product function
COMPLEX(DP), ALLOCATABLE :: aux1(:), aux2(:,:), veff(:), qgm(:) COMPLEX(kind=DP), ALLOCATABLE :: aux1(:), aux2(:,:)
COMPLEX(kind=DP), ALLOCATABLE :: qgm(:)
!! the augmentation function at G
COMPLEX(kind=DP), ALLOCATABLE :: veff(:)
!! effective potential
! !
IF (.not.okvan) RETURN IF (.not.okvan) RETURN
! !
@ -88,7 +96,7 @@
! !
! first compute the spherical harmonics ! first compute the spherical harmonics
! !
CALL setqmod( ngm, xq, g, qmod, qg ) CALL setqmod( ngm, xq0, g, qmod, qg )
CALL ylmr2( lmaxq * lmaxq, ngm, qg, qmod, ylmk0 ) CALL ylmr2( lmaxq * lmaxq, ngm, qg, qmod, ylmk0 )
DO ig = 1, ngm DO ig = 1, ngm
qmod(ig) = sqrt( qmod(ig) ) qmod(ig) = sqrt( qmod(ig) )
@ -102,19 +110,25 @@
! !
DO is = 1, nspin_mag DO is = 1, nspin_mag
DO ir = 1, dfftp%nnr DO ir = 1, dfftp%nnr
veff(ir) = dvscf(ir,is,ipert) IF (timerev) THEN
veff(ir) = conjg(dvscf(ir,is,ipert))
ELSE
veff(ir) = dvscf(ir,is,ipert)
ENDIF
ENDDO ENDDO
CALL fwfft('Rho', veff, dfftp) CALL fwfft('Rho', veff, dfftp)
DO ig = 1, ngm DO ig = 1, ngm
aux2(ig,is) = veff( dfftp%nl(ig) ) aux2(ig,is) = veff( dfftp%nl(ig) )
ENDDO ENDDO
ENDDO ENDDO
! !
DO nt = 1, ntyp DO nt = 1, ntyp
IF (upf(nt)%tvanp ) THEN IF (upf(nt)%tvanp ) THEN
!
DO ih = 1, nh(nt) DO ih = 1, nh(nt)
DO jh = ih, nh(nt) DO jh = ih, nh(nt)
CALL qvan2( ngm, ih, jh, nt, qmod, qgm, ylmk0 ) CALL qvan2( ngm, ih, jh, nt, qmod, qgm, ylmk0 )
!
DO na = 1, nat DO na = 1, nat
IF (ityp(na) == nt) THEN IF (ityp(na) == nt) THEN
DO ig = 1, ngm DO ig = 1, ngm
@ -125,12 +139,14 @@
ENDDO ENDDO
DO is = 1, nspin_mag DO is = 1, nspin_mag
int3(ih,jh,na,is,ipert) = omega * & int3(ih,jh,na,is,ipert) = omega * &
zdotc(ngm,aux1,1,aux2(1,is),1) zdotc(ngm,aux1,1,aux2(1,is),1)
ENDDO ENDDO
ENDIF ENDIF
ENDDO ENDDO
ENDDO !
ENDDO ENDDO ! jh
ENDDO ! ih
!
DO na = 1, nat DO na = 1, nat
IF (ityp(na) == nt) THEN IF (ityp(na) == nt) THEN
! !
@ -143,23 +159,31 @@
ENDDO ENDDO
ENDDO ENDDO
ENDDO ENDDO
ENDIF !
ENDDO ENDIF ! ityp
ENDIF ENDDO ! na
ENDDO !
ENDDO ENDIF ! upf
ENDDO ! nt
!
ENDDO ! ipert
! !
CALL mp_sum(int3, intra_pool_comm) CALL mp_sum(int3, intra_pool_comm)
! !
IF (noncolin) CALL set_int3_nc( npe ) IF (noncolin) CALL set_int3_nc( npe )
! !
DEALLOCATE (aux1) !DMRM
DEALLOCATE (aux2) !write(*,'(a,e20.12)') 'int3 = ', &
DEALLOCATE (veff) !SUM((REAL(REAL(int3(:,:,:,:,:))))**2)+SUM((REAL(AIMAG(int3(:,:,:,:,:))))**2)
DEALLOCATE (ylmk0) !END
DEALLOCATE (qgm) !
DEALLOCATE (qmod) DEALLOCATE(aux1)
DEALLOCATE (qg) DEALLOCATE(aux2)
DEALLOCATE(veff)
DEALLOCATE(ylmk0)
DEALLOCATE(qgm)
DEALLOCATE(qmod)
DEALLOCATE(qg)
! !
CALL stop_clock('newdq2') CALL stop_clock('newdq2')
! !

4
EPW/src/printing.f90
View File

@ -1520,11 +1520,11 @@
CALL print_clock ('epq_init') CALL print_clock ('epq_init')
WRITE( stdout, * ) WRITE( stdout, * )
CALL print_clock ('epq_init') CALL print_clock ('epq_init')
IF (nlcc_any) call print_clock ('set_drhoc') IF (nlcc_any) CALL print_clock ('set_drhoc')
CALL print_clock ('init_vloc') CALL print_clock ('init_vloc')
CALL print_clock ('init_us_1') CALL print_clock ('init_us_1')
CALL print_clock ('newd') CALL print_clock ('newd')
CALL print_clock ('dvanqq') CALL print_clock ('dvanqq2')
CALL print_clock ('drho') CALL print_clock ('drho')
WRITE( stdout, * ) WRITE( stdout, * )
! !

2
test-suite/extract-epw.x
View File

@ -65,7 +65,7 @@ pi=`grep "Re[Pi]=" $fname | awk '{print $4; print $7; print $10}'`
mobvb=`grep "Mobility VB Fermi level" $fname | awk '{print $5}'` mobvb=`grep "Mobility VB Fermi level" $fname | awk '{print $5}'`
mobcb=`grep "Mobility CB Fermi level" $fname | awk '{print $5}'` mobcb=`grep "Mobility CB Fermi level" $fname | awk '{print $5}'`
density=`grep " x-axis" $fname | awk '{print $1; print $2; print $3}'` density=`grep " x-axis" $fname | awk '{print $1; print $2; print $3}'`
mobx=`grep " x-axis" $fname | awk '{print $4}'` mobx=`grep " x-axis" $fname | awk '{print $5}'`
mobav=`grep " avg" $fname | awk '{print $1}'` mobav=`grep " avg" $fname | awk '{print $1}'`
mobxZ=`grep " x-axis [Z]" $fname | awk '{print $1; print $2; print $3; print $4}'` mobxZ=`grep " x-axis [Z]" $fname | awk '{print $1; print $2; print $3; print $4}'`
indabs=`grep " (cm-1)" $fname | awk '{print $1; print $2; print $3; print $4}'` indabs=`grep " (cm-1)" $fname | awk '{print $1; print $2; print $3; print $4}'`