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 .
|
|
|
|
|
!
|
2004-06-26 01:25:37 +08:00
|
|
|
#include "f_defs.h"
|
2003-01-20 05:58:50 +08:00
|
|
|
!
|
|
|
|
|
!----------------------------------------------------------------------
|
2004-11-04 20:09:48 +08:00
|
|
|
SUBROUTINE d0rhod2v (ipert, drhoscf)
|
|
|
|
|
!-----------------------------------------------------------------------
|
|
|
|
|
! calculates the term containing the second variation of the potential
|
|
|
|
|
! and the first variation of the charge density with respect to a
|
|
|
|
|
! perturbation at q=0
|
|
|
|
|
!
|
|
|
|
|
USE ions_base, ONLY : nat, ityp, ntyp => nsp, tau
|
|
|
|
|
USE io_global, ONLY : stdout
|
|
|
|
|
USE io_files, ONLY : iunigk
|
|
|
|
|
USE kinds, ONLY : DP
|
|
|
|
|
USE uspp_param, ONLY : nh
|
|
|
|
|
USE pwcom
|
2003-11-09 18:42:50 +08:00
|
|
|
USE wavefunctions_module, ONLY : evc
|
2004-11-04 20:09:48 +08:00
|
|
|
USE phcom
|
|
|
|
|
USE d3com
|
2008-01-24 01:50:56 +08:00
|
|
|
USE mp_global, ONLY : me_pool, root_image, inter_pool_comm, intra_pool_comm
|
|
|
|
|
USE mp, ONLY : mp_sum
|
2004-11-04 20:09:48 +08:00
|
|
|
!
|
|
|
|
|
IMPLICIT NONE
|
|
|
|
|
!
|
|
|
|
|
INTEGER :: ipert ! index of the perturbation associated with drho
|
2005-08-28 22:09:42 +08:00
|
|
|
COMPLEX (DP) :: drhoscf (nrxx) ! the variation of the charge density
|
2004-11-04 20:09:48 +08:00
|
|
|
!
|
|
|
|
|
INTEGER :: icart, & ! counter on polarizations
|
2003-01-20 05:58:50 +08:00
|
|
|
jcart, & ! counter on polarizations
|
|
|
|
|
na_icart, & ! counter on modes
|
|
|
|
|
na_jcart, & ! counter on modes
|
|
|
|
|
na, & ! counter on atoms
|
|
|
|
|
ng, & ! counter on G vectors
|
|
|
|
|
nt, & ! counter on atomic types
|
|
|
|
|
ik, & ! counter on k points
|
|
|
|
|
ikk, & ! counter on k points
|
|
|
|
|
ig, & ! counter on G vectors
|
|
|
|
|
ibnd, & ! counter on bands
|
|
|
|
|
nu_i, & ! counter on modes
|
|
|
|
|
nu_j, & ! counter on modes
|
|
|
|
|
nu_k, & ! counter on modes
|
|
|
|
|
ikb, jkb, & ! counter on beta functions
|
|
|
|
|
nrec, & ! record position of dwfc
|
|
|
|
|
ios ! integer variable for I/O control
|
|
|
|
|
|
2005-08-28 22:09:42 +08:00
|
|
|
REAL (DP) :: gtau, & ! the product G*\tau_s
|
2003-01-20 05:58:50 +08:00
|
|
|
wgg ! the weight of a K point
|
|
|
|
|
|
2005-08-28 22:09:42 +08:00
|
|
|
COMPLEX (DP) :: ZDOTC, d3dywrk (3*nat,3*nat), fac, alpha(8), work
|
|
|
|
|
COMPLEX (DP), ALLOCATABLE :: work0 (:), work1 (:), work2 (:), &
|
2004-11-04 20:09:48 +08:00
|
|
|
work3 (:), work4 (:), work5 (:), &
|
|
|
|
|
work6 (:)
|
2003-01-20 05:58:50 +08:00
|
|
|
! auxiliary space
|
|
|
|
|
|
2004-11-04 20:09:48 +08:00
|
|
|
ALLOCATE (work0(nrxx))
|
|
|
|
|
ALLOCATE (work1(npwx))
|
|
|
|
|
ALLOCATE (work2(npwx))
|
|
|
|
|
ALLOCATE (work3(npwx))
|
|
|
|
|
ALLOCATE (work4(npwx))
|
|
|
|
|
ALLOCATE (work5(npwx))
|
|
|
|
|
ALLOCATE (work6(npwx))
|
2003-01-20 05:58:50 +08:00
|
|
|
|
2004-03-07 21:47:42 +08:00
|
|
|
d3dywrk (:,:) = (0.d0, 0.d0)
|
2004-11-04 20:09:48 +08:00
|
|
|
!
|
|
|
|
|
! Here the contribution deriving from the local part of the potential
|
|
|
|
|
!
|
|
|
|
|
IF ( me_pool == root_image ) THEN
|
|
|
|
|
!
|
|
|
|
|
! ... computed only by the first pool (no sum over k needed)
|
|
|
|
|
!
|
|
|
|
|
work0 (:) = drhoscf (:)
|
|
|
|
|
CALL cft3 (work0, nr1, nr2, nr3, nrx1, nrx2, nrx3, -1)
|
|
|
|
|
DO na = 1, nat
|
|
|
|
|
DO icart = 1,3
|
|
|
|
|
na_icart = 3*(na-1)+icart
|
|
|
|
|
DO jcart = 1,3
|
|
|
|
|
na_jcart = 3*(na-1)+jcart
|
|
|
|
|
DO ng = 1, ngm
|
|
|
|
|
gtau = tpi * ( g(1,ng)*tau(1,na) + &
|
|
|
|
|
g(2,ng)*tau(2,na) + &
|
|
|
|
|
g(3,ng)*tau(3,na) )
|
2003-01-20 05:58:50 +08:00
|
|
|
|
General cleanup of intrinsic functions:
conversion to real => DBLE
(including real part of a complex number)
conversion to complex => CMPLX
complex conjugate => CONJG
imaginary part => AIMAG
All functions are uppercase.
CMPLX is preprocessed by f_defs.h and performs an explicit cast:
#define CMPLX(a,b) cmplx(a,b,kind=DP)
This implies that 1) f_defs.h must be included whenever a CMPLX is present,
2) CMPLX should stay in a single line, 3) DP must be defined.
All occurrences of real, float, dreal, dfloat, dconjg, dimag, dcmplx
removed - please do not reintroduce any of them.
Tested only with ifc7 and g95 - beware unintended side effects
Maybe not the best solution (explicit casts everywhere would be better)
but it can be easily changed with a script if the need arises.
The following code might be used to test for possible trouble:
program test_intrinsic
implicit none
integer, parameter :: dp = selected_real_kind(14,200)
real (kind=dp) :: a = 0.123456789012345_dp
real (kind=dp) :: b = 0.987654321098765_dp
complex (kind=dp) :: c = ( 0.123456789012345_dp, 0.987654321098765_dp)
print *, ' A = ', a
print *, ' DBLE(A)= ', DBLE(a)
print *, ' C = ', c
print *, 'CONJG(C)= ', CONJG(c)
print *, 'DBLE(c),AIMAG(C) = ', DBLE(c), AIMAG(c)
print *, 'CMPLX(A,B,kind=dp)= ', CMPLX( a, b, kind=dp)
end program test_intrinsic
Note that CMPLX and REAL without a cast yield single precision numbers on
ifc7 and g95 !!!
git-svn-id: http://qeforge.qe-forge.org/svn/q-e/trunk/espresso@2133 c92efa57-630b-4861-b058-cf58834340f0
2005-08-27 01:44:42 +08:00
|
|
|
fac = CMPLX(COS(gtau),SIN(gtau))
|
2003-01-20 05:58:50 +08:00
|
|
|
|
2004-11-04 20:09:48 +08:00
|
|
|
d3dywrk(na_icart,na_jcart) = &
|
2003-01-20 05:58:50 +08:00
|
|
|
d3dywrk(na_icart,na_jcart) - &
|
|
|
|
|
tpiba2 * g(icart,ng) * g(jcart,ng) * &
|
|
|
|
|
omega * vloc(igtongl(ng),ityp(na)) * &
|
|
|
|
|
fac*work0(nl(ng))
|
2004-11-04 20:09:48 +08:00
|
|
|
ENDDO
|
|
|
|
|
ENDDO
|
|
|
|
|
ENDDO
|
|
|
|
|
WRITE( stdout,*) na
|
|
|
|
|
WRITE( stdout,'(3(2f10.6,2x))') &
|
|
|
|
|
((d3dywrk(3*(na-1)+icart,3*(na-1)+jcart), &
|
|
|
|
|
jcart=1,3),icart=1,3)
|
|
|
|
|
ENDDO
|
2003-01-20 05:58:50 +08:00
|
|
|
|
2008-04-14 02:31:27 +08:00
|
|
|
CALL mp_sum( d3dywrk, intra_pool_comm )
|
2004-11-04 20:09:48 +08:00
|
|
|
!
|
|
|
|
|
END IF
|
|
|
|
|
!
|
|
|
|
|
! each pool contributes to next term
|
|
|
|
|
!
|
|
|
|
|
! Here we compute the nonlocal (Kleinman-Bylander) contribution.
|
|
|
|
|
!
|
|
|
|
|
REWIND (unit=iunigk)
|
|
|
|
|
|
|
|
|
|
DO ik = 1, nksq
|
|
|
|
|
READ (iunigk, err = 200, iostat = ios) npw, igk
|
|
|
|
|
200 CALL errore ('d0rhod2v', 'reading igk', ABS (ios) )
|
|
|
|
|
IF (lgamma) THEN
|
2003-02-08 00:04:36 +08:00
|
|
|
ikk = ik
|
|
|
|
|
npwq = npw
|
2004-11-04 20:09:48 +08:00
|
|
|
ELSE
|
2003-02-08 00:04:36 +08:00
|
|
|
ikk = 2 * ik - 1
|
2004-11-04 20:09:48 +08:00
|
|
|
READ (iunigk, err = 300, iostat = ios) npwq, igkq
|
|
|
|
|
300 CALL errore ('d0rhod2v', 'reading igkq', ABS (ios) )
|
2003-02-08 00:04:36 +08:00
|
|
|
npwq = npw
|
2004-11-04 20:09:48 +08:00
|
|
|
ENDIF
|
2003-02-08 00:04:36 +08:00
|
|
|
wgg = wk (ikk)
|
2004-11-04 20:09:48 +08:00
|
|
|
CALL davcio (evc, lrwfc, iuwfc, ikk, - 1)
|
2003-01-20 05:58:50 +08:00
|
|
|
|
2004-11-04 20:09:48 +08:00
|
|
|
CALL init_us_2 (npw, igk, xk (1, ikk), vkb0)
|
2003-01-20 05:58:50 +08:00
|
|
|
!
|
|
|
|
|
! Reads the first variation of the wavefunction projected on conduction
|
|
|
|
|
!
|
2003-02-08 00:04:36 +08:00
|
|
|
nrec = (ipert - 1) * nksq + ik
|
2004-11-04 20:09:48 +08:00
|
|
|
CALL davcio (dpsi, lrdwf, iudwf, nrec, - 1)
|
2003-01-20 05:58:50 +08:00
|
|
|
!
|
|
|
|
|
! In the metallic case corrects dpsi so as that the density matrix
|
|
|
|
|
! will be: Sum_{k,nu} 2 * | dpsi > < psi |
|
|
|
|
|
!
|
2004-11-04 20:09:48 +08:00
|
|
|
IF (degauss /= 0.d0) THEN
|
2003-02-08 00:04:36 +08:00
|
|
|
nrec = ipert + (ik - 1) * 3 * nat
|
2004-11-04 20:09:48 +08:00
|
|
|
CALL davcio (psidqvpsi, lrpdqvp, iupd0vp, nrec, - 1)
|
|
|
|
|
CALL dpsi_corr (evc, psidqvpsi, ikk, ikk, ipert)
|
|
|
|
|
ENDIF
|
|
|
|
|
DO icart = 1, 3
|
|
|
|
|
DO jcart = 1, 3
|
|
|
|
|
DO ibnd = 1, nbnd
|
|
|
|
|
DO ig = 1, npw
|
2003-01-20 05:58:50 +08:00
|
|
|
work1(ig)= evc(ig,ibnd)*tpiba*(xk(icart,ikk)+g(icart,igk(ig)))
|
|
|
|
|
work2(ig)= evc(ig,ibnd)*tpiba*(xk(jcart,ikk)+g(jcart,igk(ig)))
|
|
|
|
|
work3(ig)=dpsi(ig,ibnd)*tpiba*(xk(icart,ikk)+g(icart,igk(ig)))
|
|
|
|
|
work4(ig)=dpsi(ig,ibnd)*tpiba*(xk(jcart,ikk)+g(jcart,igk(ig)))
|
|
|
|
|
work5(ig)= work1(ig)*tpiba*(xk(jcart,ikk)+g(jcart,igk(ig)))
|
|
|
|
|
work6(ig)= work3(ig)*tpiba*(xk(jcart,ikk)+g(jcart,igk(ig)))
|
2004-11-04 20:09:48 +08:00
|
|
|
ENDDO
|
2003-01-20 05:58:50 +08:00
|
|
|
jkb=0
|
2004-11-04 20:09:48 +08:00
|
|
|
DO nt = 1, ntyp
|
|
|
|
|
DO na = 1, nat
|
|
|
|
|
IF (ityp (na) == nt) THEN
|
2003-02-08 00:04:36 +08:00
|
|
|
na_icart = 3 * (na - 1) + icart
|
|
|
|
|
na_jcart = 3 * (na - 1) + jcart
|
2004-11-04 20:09:48 +08:00
|
|
|
DO ikb = 1, nh (nt)
|
2003-01-20 05:58:50 +08:00
|
|
|
jkb=jkb+1
|
2003-02-08 00:04:36 +08:00
|
|
|
alpha (1) = ZDOTC (npw, work1, 1, vkb0(1,jkb), 1)
|
|
|
|
|
alpha (2) = ZDOTC (npw, vkb0(1,jkb), 1, work4, 1)
|
|
|
|
|
alpha (3) = ZDOTC (npw, work2, 1, vkb0(1,jkb), 1)
|
|
|
|
|
alpha (4) = ZDOTC (npw, vkb0(1,jkb), 1, work3, 1)
|
|
|
|
|
alpha (5) = ZDOTC (npw, work5, 1, vkb0(1,jkb), 1)
|
|
|
|
|
alpha (6) = ZDOTC (npw, vkb0(1,jkb), 1, dpsi (1,ibnd), 1)
|
|
|
|
|
alpha (7) = ZDOTC (npw, evc (1,ibnd), 1, vkb0(1,jkb), 1)
|
|
|
|
|
alpha (8) = ZDOTC (npw, vkb0(1,jkb), 1, work6, 1)
|
2003-02-21 22:57:00 +08:00
|
|
|
#ifdef __PARA
|
2008-04-14 02:31:27 +08:00
|
|
|
CALL mp_sum( alpha, intra_pool_comm )
|
2003-01-20 05:58:50 +08:00
|
|
|
#endif
|
|
|
|
|
d3dywrk (na_icart, na_jcart) = d3dywrk (na_icart, na_jcart) &
|
|
|
|
|
+ (alpha(1)*alpha(2) + alpha(3)*alpha(4) &
|
|
|
|
|
- alpha(5)*alpha(6) - alpha(7)*alpha(8)) * &
|
2004-06-22 16:03:59 +08:00
|
|
|
dvan (ikb,ikb,nt) * wgg * 2.0d0
|
2004-11-04 20:09:48 +08:00
|
|
|
ENDDO
|
|
|
|
|
END IF
|
|
|
|
|
ENDDO
|
|
|
|
|
ENDDO
|
|
|
|
|
ENDDO
|
|
|
|
|
ENDDO
|
|
|
|
|
ENDDO
|
|
|
|
|
ENDDO
|
|
|
|
|
!
|
2008-01-24 01:50:56 +08:00
|
|
|
CALL mp_sum ( d3dywrk, inter_pool_comm )
|
2004-11-04 20:09:48 +08:00
|
|
|
!
|
|
|
|
|
! Rotate the dynamical matrix on the basis of patterns
|
|
|
|
|
! first index does not need to be rotated
|
|
|
|
|
!
|
2003-02-08 00:04:36 +08:00
|
|
|
nu_k = ipert
|
2004-11-04 20:09:48 +08:00
|
|
|
DO nu_i = 1, 3 * nat
|
|
|
|
|
DO nu_j = 1, 3 * nat
|
2003-02-08 00:04:36 +08:00
|
|
|
work = (0.0d0, 0.0d0)
|
2004-11-04 20:09:48 +08:00
|
|
|
DO na = 1, nat
|
|
|
|
|
DO icart = 1, 3
|
2003-02-08 00:04:36 +08:00
|
|
|
na_icart = 3 * (na-1) + icart
|
2004-11-04 20:09:48 +08:00
|
|
|
DO jcart = 1, 3
|
2003-02-08 00:04:36 +08:00
|
|
|
na_jcart = 3 * (na-1) + jcart
|
2004-11-04 20:09:48 +08:00
|
|
|
work = work + CONJG(u(na_icart,nu_i)) * &
|
2003-01-20 05:58:50 +08:00
|
|
|
d3dywrk(na_icart,na_jcart) * &
|
|
|
|
|
u(na_jcart,nu_j)
|
2004-11-04 20:09:48 +08:00
|
|
|
ENDDO
|
|
|
|
|
ENDDO
|
|
|
|
|
ENDDO
|
2003-02-08 00:04:36 +08:00
|
|
|
d3dyn(nu_k,nu_i,nu_j) = d3dyn(nu_k,nu_i,nu_j) + work
|
2004-11-04 20:09:48 +08:00
|
|
|
IF (allmodes) THEN
|
2003-02-08 00:04:36 +08:00
|
|
|
d3dyn(nu_j,nu_k,nu_i) = d3dyn(nu_j,nu_k,nu_i) + work
|
|
|
|
|
d3dyn(nu_i,nu_j,nu_k) = d3dyn(nu_i,nu_j,nu_k) + work
|
2004-11-04 20:09:48 +08:00
|
|
|
ENDIF
|
|
|
|
|
ENDDO
|
|
|
|
|
ENDDO
|
2004-03-07 21:47:42 +08:00
|
|
|
|
2004-11-04 20:09:48 +08:00
|
|
|
DEALLOCATE (work6)
|
|
|
|
|
DEALLOCATE (work5)
|
|
|
|
|
DEALLOCATE (work4)
|
|
|
|
|
DEALLOCATE (work3)
|
|
|
|
|
DEALLOCATE (work2)
|
|
|
|
|
DEALLOCATE (work1)
|
|
|
|
|
DEALLOCATE (work0)
|
2003-01-20 05:58:50 +08:00
|
|
|
|
2004-11-04 20:09:48 +08:00
|
|
|
RETURN
|
|
|
|
|
END SUBROUTINE d0rhod2v
|