2003-01-20 05:58:50 +08:00
|
|
|
!
|
|
|
|
|
! Copyright (C) 2001 PWSCF group
|
|
|
|
|
! This file is distributed under the terms of the
|
|
|
|
|
! GNU General Public License. See the file `License'
|
|
|
|
|
! in the root directory of the present distribution,
|
|
|
|
|
! or http://www.gnu.org/copyleft/gpl.txt .
|
|
|
|
|
!
|
|
|
|
|
!----------------------------------------------------------------------
|
2003-02-08 00:04:36 +08:00
|
|
|
subroutine dvanqq
|
2003-01-20 05:58:50 +08:00
|
|
|
!----------------------------------------------------------------------
|
|
|
|
|
!
|
|
|
|
|
! This routine calculates four integrals of the Q functions and
|
|
|
|
|
! its derivatives with c V_loc and V_eff which are used
|
|
|
|
|
! to compute term dV_bare/dtau * psi in addusdvqpsi and in addusdynmat.
|
|
|
|
|
! The result is stored in int1,int2,int4,int5. The routine is called
|
|
|
|
|
! only once. int4 and int5 are deallocated after use in
|
|
|
|
|
! addusdynmat, and int1 and int2 saved on disk by that routine.
|
|
|
|
|
!
|
|
|
|
|
#include "machine.h"
|
|
|
|
|
|
2003-02-08 00:04:36 +08:00
|
|
|
use pwcom
|
|
|
|
|
use parameters, only : DP
|
|
|
|
|
use phcom
|
|
|
|
|
implicit none
|
2003-01-20 05:58:50 +08:00
|
|
|
!
|
|
|
|
|
! And the local variables
|
|
|
|
|
!
|
|
|
|
|
|
2003-02-08 00:04:36 +08:00
|
|
|
integer :: na, nb, ig, nta, ntb, ir, ih, jh, ijh, ipol, jpol, is
|
2003-01-20 05:58:50 +08:00
|
|
|
! counter on atoms
|
|
|
|
|
! counter on G vectors
|
|
|
|
|
! counter on atomic types
|
|
|
|
|
! counter on real mesh
|
|
|
|
|
! counter on beta functions
|
|
|
|
|
! counter on polarizations
|
|
|
|
|
! counter on spin
|
|
|
|
|
|
|
|
|
|
|
2003-02-08 00:04:36 +08:00
|
|
|
real(kind=DP), allocatable :: qmod (:), qmodg (:), qpg (:,:), &
|
2003-01-20 05:58:50 +08:00
|
|
|
ylmkq (:,:), ylmk0 (:,:)
|
|
|
|
|
! the modulus of q+G
|
|
|
|
|
! the modulus of G
|
|
|
|
|
! the q+G vectors
|
|
|
|
|
! the spherical harmonics
|
|
|
|
|
! the spherical harmonics
|
|
|
|
|
|
|
|
|
|
complex(kind=DP) :: fact, fact1, ZDOTC
|
2003-02-08 00:04:36 +08:00
|
|
|
complex(kind=DP), allocatable :: sk (:), aux1 (:), aux2 (:),&
|
|
|
|
|
aux3 (:), aux5 (:,:,:), veff (:,:)
|
|
|
|
|
complex(kind=DP), pointer :: qgmq (:)
|
2003-01-20 05:58:50 +08:00
|
|
|
! auxiliary variables
|
|
|
|
|
! the scalar product function
|
|
|
|
|
! auxiliary variable
|
|
|
|
|
! a mesh space for d V_loc /dtau
|
|
|
|
|
! a mesh space
|
|
|
|
|
! a mesh space
|
|
|
|
|
! a mesh space
|
|
|
|
|
! a mesh space for the FFT of the V_eff
|
|
|
|
|
! the augmentation function at q+G
|
|
|
|
|
|
2003-02-08 00:04:36 +08:00
|
|
|
if (recover) return
|
2003-01-20 05:58:50 +08:00
|
|
|
|
2003-02-08 00:04:36 +08:00
|
|
|
if (.not.okvan) return
|
2003-01-20 05:58:50 +08:00
|
|
|
|
2003-02-08 00:04:36 +08:00
|
|
|
call start_clock ('dvanqq')
|
|
|
|
|
call setv (2 * nhm * nhm * 3 * nat * nspin, 0.d0, int1, 1)
|
|
|
|
|
call setv (2 * nhm * nhm * 3 * nat * nat, 0.d0, int2, 1)
|
|
|
|
|
call setv (nhm * (nhm + 1) * 3 * 3 * nat * nspin, 0.d0, int4, 1)
|
2003-01-20 05:58:50 +08:00
|
|
|
|
2003-02-08 00:04:36 +08:00
|
|
|
call setv (nhm * (nhm + 1) * 3 * 3 * nat * nat, 0.d0, int5, 1)
|
|
|
|
|
allocate (sk ( ngm))
|
|
|
|
|
allocate (aux1( ngm))
|
|
|
|
|
allocate (aux2( ngm))
|
|
|
|
|
allocate (aux3( ngm))
|
|
|
|
|
allocate (aux5( ngm ,nat, 3 ))
|
|
|
|
|
allocate (qmodg( ngm))
|
|
|
|
|
allocate (veff ( nrxx , nspin))
|
|
|
|
|
allocate (ylmk0( ngm , lqx * lqx))
|
|
|
|
|
if (.not.lgamma) then
|
|
|
|
|
allocate (ylmkq(ngm , lqx * lqx))
|
|
|
|
|
allocate (qpg (3, ngm))
|
|
|
|
|
allocate (qmod( ngm))
|
|
|
|
|
allocate (qgmq( ngm))
|
|
|
|
|
else
|
|
|
|
|
qgmq =>qgm
|
2003-01-20 05:58:50 +08:00
|
|
|
endif
|
|
|
|
|
!
|
|
|
|
|
! compute spherical harmonics
|
|
|
|
|
!
|
2003-02-08 00:04:36 +08:00
|
|
|
call ylmr2 (lqx * lqx, ngm, g, gg, ylmk0)
|
|
|
|
|
do ig = 1, ngm
|
|
|
|
|
qmodg (ig) = sqrt (gg (ig) )
|
2003-01-20 05:58:50 +08:00
|
|
|
|
|
|
|
|
enddo
|
2003-02-08 00:04:36 +08:00
|
|
|
if (.not.lgamma) then
|
|
|
|
|
call setqmod (ngm, xq, g, qmod, qpg)
|
|
|
|
|
call ylmr2 (lqx * lqx, ngm, qpg, qmod, ylmkq)
|
|
|
|
|
do ig = 1, ngm
|
|
|
|
|
qmod (ig) = sqrt (qmod (ig) )
|
2003-01-20 05:58:50 +08:00
|
|
|
enddo
|
|
|
|
|
endif
|
|
|
|
|
!
|
|
|
|
|
! we start by computing the FT of the effective potential
|
|
|
|
|
!
|
2003-02-08 00:04:36 +08:00
|
|
|
do is = 1, nspin
|
|
|
|
|
do ir = 1, nrxx
|
|
|
|
|
veff (ir, is) = DCMPLX (vltot (ir) + vr (ir, is), 0.d0)
|
2003-01-20 05:58:50 +08:00
|
|
|
enddo
|
2003-02-08 00:04:36 +08:00
|
|
|
call cft3 (veff (1, is), nr1, nr2, nr3, nrx1, nrx2, nrx3, - 1)
|
2003-01-20 05:58:50 +08:00
|
|
|
enddo
|
|
|
|
|
!
|
|
|
|
|
!
|
|
|
|
|
! We compute here four of the five integrals needed in the phonon
|
|
|
|
|
!
|
2003-02-08 00:04:36 +08:00
|
|
|
fact1 = DCMPLX (0.d0, - tpiba * omega)
|
|
|
|
|
do na = 1, nat
|
|
|
|
|
nta = ityp (na)
|
|
|
|
|
do ig = 1, ngm
|
2003-01-20 05:58:50 +08:00
|
|
|
sk (ig) = vlocq (ig, nta) * eigts1 (ig1 (ig), na) * eigts2 (ig2 ( &
|
|
|
|
|
ig), na) * eigts3 (ig3 (ig), na)
|
|
|
|
|
enddo
|
2003-02-08 00:04:36 +08:00
|
|
|
do ipol = 1, 3
|
|
|
|
|
do ig = 1, ngm
|
|
|
|
|
aux5 (ig, na, ipol) = sk (ig) * (g (ipol, ig) + xq (ipol) )
|
2003-01-20 05:58:50 +08:00
|
|
|
enddo
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
enddo
|
2003-02-08 00:04:36 +08:00
|
|
|
do ntb = 1, ntyp
|
|
|
|
|
if (tvanp (ntb) ) then
|
|
|
|
|
ijh = 0
|
|
|
|
|
do ih = 1, nh (ntb)
|
|
|
|
|
do jh = ih, nh (ntb)
|
|
|
|
|
ijh = ijh + 1
|
2003-01-20 05:58:50 +08:00
|
|
|
!
|
|
|
|
|
! compute the augmentation function
|
|
|
|
|
!
|
|
|
|
|
|
2003-02-08 00:04:36 +08:00
|
|
|
call qvan2 (ngm, ih, jh, ntb, qmodg, qgm, ylmk0)
|
2003-01-20 05:58:50 +08:00
|
|
|
|
|
|
|
|
if (.not.lgamma) call qvan2 (ngm, ih, jh, ntb, qmod, qgmq, &
|
|
|
|
|
ylmkq)
|
|
|
|
|
!
|
|
|
|
|
! NB: for this integral the moving atom and the atom of Q
|
|
|
|
|
! do not necessarily coincide
|
|
|
|
|
!
|
|
|
|
|
!
|
2003-02-08 00:04:36 +08:00
|
|
|
do nb = 1, nat
|
|
|
|
|
if (ityp (nb) .eq.ntb) then
|
|
|
|
|
do ig = 1, ngm
|
2003-01-20 05:58:50 +08:00
|
|
|
aux1 (ig) = qgmq (ig) * eigts1 (ig1 (ig), nb) * eigts2 (ig2 &
|
|
|
|
|
(ig), nb) * eigts3 (ig3 (ig), nb)
|
|
|
|
|
|
|
|
|
|
enddo
|
2003-02-08 00:04:36 +08:00
|
|
|
do na = 1, nat
|
2003-01-20 05:58:50 +08:00
|
|
|
|
2003-02-08 00:04:36 +08:00
|
|
|
fact = eigqts (na) * conjg (eigqts (nb) )
|
2003-01-20 05:58:50 +08:00
|
|
|
!
|
|
|
|
|
! nb is the atom of the augmentation function
|
|
|
|
|
!
|
2003-02-08 00:04:36 +08:00
|
|
|
do ipol = 1, 3
|
2003-01-20 05:58:50 +08:00
|
|
|
|
|
|
|
|
int2 (ih, jh, ipol, na, nb) = fact * fact1 * ZDOTC (ngm, &
|
|
|
|
|
aux1, 1, aux5 (1, na, ipol), 1)
|
2003-02-08 00:04:36 +08:00
|
|
|
do jpol = 1, 3
|
|
|
|
|
if (jpol.ge.ipol) then
|
|
|
|
|
do ig = 1, ngm
|
2003-01-20 05:58:50 +08:00
|
|
|
aux3 (ig) = aux5 (ig, na, ipol) * (g (jpol, ig) + xq ( &
|
|
|
|
|
jpol) )
|
|
|
|
|
enddo
|
|
|
|
|
int5 (ijh, ipol, jpol, na, nb) = conjg (fact) * tpiba2 * &
|
|
|
|
|
omega * ZDOTC (ngm, aux3, 1, aux1, 1)
|
2003-02-08 00:04:36 +08:00
|
|
|
else
|
2003-01-20 05:58:50 +08:00
|
|
|
int5 (ijh, ipol, jpol, na, nb) = int5 (ijh, jpol, ipol, &
|
|
|
|
|
na, nb)
|
|
|
|
|
endif
|
|
|
|
|
enddo
|
|
|
|
|
enddo
|
|
|
|
|
enddo
|
2003-02-08 00:04:36 +08:00
|
|
|
if (.not.lgamma) then
|
|
|
|
|
do ig = 1, ngm
|
2003-01-20 05:58:50 +08:00
|
|
|
aux1 (ig) = qgm (ig) * eigts1 (ig1 (ig), nb) * eigts2 ( &
|
|
|
|
|
ig2 (ig), nb) * eigts3 (ig3 (ig), nb)
|
|
|
|
|
enddo
|
|
|
|
|
endif
|
2003-02-08 00:04:36 +08:00
|
|
|
do is = 1, nspin
|
|
|
|
|
do ipol = 1, 3
|
|
|
|
|
do ig = 1, ngm
|
|
|
|
|
aux2 (ig) = veff (nl (ig), is) * g (ipol, ig)
|
2003-01-20 05:58:50 +08:00
|
|
|
enddo
|
|
|
|
|
int1 (ih, jh, ipol, nb, is) = - fact1 * ZDOTC (ngm, aux1, 1, &
|
|
|
|
|
aux2, 1)
|
2003-02-08 00:04:36 +08:00
|
|
|
do jpol = 1, 3
|
|
|
|
|
if (jpol.ge.ipol) then
|
|
|
|
|
do ig = 1, ngm
|
|
|
|
|
aux3 (ig) = aux2 (ig) * g (jpol, ig)
|
2003-01-20 05:58:50 +08:00
|
|
|
enddo
|
|
|
|
|
int4 (ijh, ipol, jpol, nb, is) = - tpiba2 * omega * &
|
|
|
|
|
ZDOTC (ngm, aux3, 1, aux1, 1)
|
2003-02-08 00:04:36 +08:00
|
|
|
else
|
2003-01-20 05:58:50 +08:00
|
|
|
int4 (ijh, ipol, jpol, nb, is) = int4 (ijh, jpol, ipol, &
|
|
|
|
|
nb, is)
|
|
|
|
|
endif
|
|
|
|
|
enddo
|
|
|
|
|
enddo
|
|
|
|
|
enddo
|
|
|
|
|
endif
|
|
|
|
|
enddo
|
|
|
|
|
enddo
|
|
|
|
|
enddo
|
2003-02-08 00:04:36 +08:00
|
|
|
do ih = 1, nh (ntb)
|
|
|
|
|
do jh = ih + 1, nh (ntb)
|
2003-01-20 05:58:50 +08:00
|
|
|
!
|
|
|
|
|
! We use the symmetry properties of the integral factor
|
|
|
|
|
!
|
2003-02-08 00:04:36 +08:00
|
|
|
do nb = 1, nat
|
|
|
|
|
if (ityp (nb) .eq.ntb) then
|
|
|
|
|
do ipol = 1, 3
|
|
|
|
|
do is = 1, nspin
|
|
|
|
|
int1 (jh, ih, ipol, nb, is) = int1 (ih, jh, ipol, nb, is)
|
2003-01-20 05:58:50 +08:00
|
|
|
enddo
|
2003-02-08 00:04:36 +08:00
|
|
|
do na = 1, nat
|
|
|
|
|
int2 (jh, ih, ipol, na, nb) = int2 (ih, jh, ipol, na, nb)
|
2003-01-20 05:58:50 +08:00
|
|
|
enddo
|
|
|
|
|
enddo
|
|
|
|
|
endif
|
|
|
|
|
enddo
|
|
|
|
|
enddo
|
|
|
|
|
enddo
|
|
|
|
|
endif
|
|
|
|
|
enddo
|
|
|
|
|
#ifdef PARA
|
2003-02-08 00:04:36 +08:00
|
|
|
call reduce (2 * nhm * nhm * 3 * nat * nspin, int1)
|
|
|
|
|
call reduce (2 * nhm * nhm * 3 * nat * nat, int2)
|
|
|
|
|
call reduce (nhm * (nhm + 1) * 3 * 3 * nat * nspin, int4)
|
|
|
|
|
call reduce (nhm * (nhm + 1) * 3 * 3 * nat * nat, int5)
|
2003-01-20 05:58:50 +08:00
|
|
|
#endif
|
|
|
|
|
! do ih=1,nh(1)
|
|
|
|
|
! do jh=1,nh(1)
|
|
|
|
|
! do ipol=1,3
|
|
|
|
|
! write(6,'(3i5,2f20.10)') ipol,ih,jh,int2(ih,jh,ipol,1,1)
|
|
|
|
|
! enddo
|
|
|
|
|
! enddo
|
|
|
|
|
! enddo
|
|
|
|
|
! call stop_ph(.true.)
|
2003-02-08 00:04:36 +08:00
|
|
|
if (.not.lgamma) then
|
|
|
|
|
deallocate(qgmq)
|
|
|
|
|
deallocate (qmod)
|
|
|
|
|
deallocate (qpg)
|
|
|
|
|
deallocate (ylmkq)
|
2003-01-20 05:58:50 +08:00
|
|
|
endif
|
2003-02-08 00:04:36 +08:00
|
|
|
deallocate (ylmk0)
|
|
|
|
|
deallocate (veff)
|
|
|
|
|
deallocate (qmodg)
|
|
|
|
|
deallocate (aux5)
|
|
|
|
|
deallocate (aux3)
|
|
|
|
|
deallocate (aux2)
|
|
|
|
|
deallocate (aux1)
|
|
|
|
|
deallocate (sk)
|
2003-01-20 05:58:50 +08:00
|
|
|
|
2003-02-08 00:04:36 +08:00
|
|
|
call stop_clock ('dvanqq')
|
|
|
|
|
return
|
2003-01-20 05:58:50 +08:00
|
|
|
end subroutine dvanqq
|
