mirror of https://gitlab.com/QEF/q-e.git
216 lines
7.4 KiB
Fortran
216 lines
7.4 KiB
Fortran
!
|
|
! 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 .
|
|
!
|
|
#include "f_defs.h"
|
|
!
|
|
!----------------------------------------------------------------------
|
|
SUBROUTINE dqrhod2v (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 a generic q
|
|
!
|
|
USE ions_base, ONLY : nat, ityp, ntyp => nsp, tau
|
|
USE kinds, ONLY : DP
|
|
USE pwcom
|
|
USE uspp_param, ONLY : nh
|
|
USE wavefunctions_module, ONLY : evc
|
|
USE io_files, ONLY : iunigk
|
|
USE phcom
|
|
USE d3com
|
|
USE mp_global, ONLY : me_pool, root_pool
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
INTEGER :: ipert
|
|
! index of the perturbation associated with drho
|
|
COMPLEX (DP) :: drhoscf (nrxx)
|
|
! the variation of the charge density
|
|
!
|
|
! local variables
|
|
!
|
|
INTEGER :: icart, jcart, na_icart, na_jcart, na, ng, nt, &
|
|
ik, ikk, ikq, ig, ibnd, nu_i, nu_j, nu_k, ikb, jkb, nrec, ios
|
|
! counters
|
|
|
|
REAL (DP) :: gtau, wgg
|
|
! the product G*\tau_s
|
|
! the weight of a K point
|
|
|
|
COMPLEX (DP) :: ZDOTC, fac, alpha (8), work
|
|
COMPLEX (DP), ALLOCATABLE :: d3dywrk (:,:), work0 (:), &
|
|
work1 (:), work2 (:), work3 (:), work4 (:), work5 (:), work6 (:)
|
|
! work space
|
|
|
|
ALLOCATE (d3dywrk( 3 * nat, 3 * nat))
|
|
ALLOCATE (work0( nrxx))
|
|
ALLOCATE (work1( npwx))
|
|
ALLOCATE (work2( npwx))
|
|
ALLOCATE (work3( npwx))
|
|
ALLOCATE (work4( npwx))
|
|
ALLOCATE (work5( npwx))
|
|
ALLOCATE (work6( npwx))
|
|
|
|
d3dywrk (:,:) = (0.d0, 0.d0)
|
|
!
|
|
! Here the contribution deriving from the local part of the potential
|
|
!
|
|
! ... computed only by the first pool (no sum over k needed)
|
|
!
|
|
IF ( me_pool == root_pool ) THEN
|
|
!
|
|
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 * ( (xq (1) + g (1, ng) ) * tau (1, na) + &
|
|
(xq (2) + g (2, ng) ) * tau (2, na) + &
|
|
(xq (3) + g (3, ng) ) * tau (3, na) )
|
|
fac = CMPLX (COS (gtau), - SIN (gtau) )
|
|
d3dywrk (na_icart, na_jcart) = d3dywrk (na_icart, na_jcart) &
|
|
- tpiba2 * omega * (xq (icart) + g (icart, ng) ) * &
|
|
(xq (jcart) + g (jcart, ng) ) * &
|
|
vlocq (ng, ityp (na) ) * fac * CONJG (work0 (nl (ng) ) )
|
|
ENDDO
|
|
ENDDO
|
|
ENDDO
|
|
ENDDO
|
|
!
|
|
CALL reduce (2 * 9 * nat * nat, d3dywrk)
|
|
!
|
|
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 ('dqrhod2v', 'reading igk', ABS (ios) )
|
|
IF (lgamma) THEN
|
|
ikk = ik
|
|
ikq = ik
|
|
npwq = npw
|
|
ELSE
|
|
ikk = 2 * ik - 1
|
|
ikq = 2 * ik
|
|
READ (iunigk, err = 300, iostat = ios) npwq, igkq
|
|
300 CALL errore ('dqrhod2v', 'reading igkq', ABS (ios) )
|
|
ENDIF
|
|
wgg = wk (ikk)
|
|
CALL davcio (evc, lrwfc, iuwfc, ikk, - 1)
|
|
!
|
|
! In metallic case it necessary to know the wave function at k+q point
|
|
! so as to correct dpsi. dvpsi is used as working array
|
|
!
|
|
IF (degauss /= 0.d0) CALL davcio (dvpsi, lrwfc, iuwfc, ikq, -1)
|
|
CALL init_us_2 (npwq, igkq, xk (1, ikq), vkb)
|
|
CALL init_us_2 (npw, igk, xk (1, ikk), vkb0)
|
|
!
|
|
! Reads the first variation of the wavefunction projected on conduction
|
|
!
|
|
nrec = (ipert - 1) * nksq + ik
|
|
CALL davcio (dpsi, lrdwf, iudqwf, nrec, - 1)
|
|
!
|
|
! In the metallic case corrects dpsi so as that the density matrix
|
|
! will be: Sum_{k,nu} 2 * | dpsi > < psi |
|
|
!
|
|
IF (degauss /= 0.d0) THEN
|
|
nrec = ipert + (ik - 1) * 3 * nat
|
|
CALL davcio (psidqvpsi, lrpdqvp, iupdqvp, nrec, - 1)
|
|
CALL dpsi_corr (dvpsi, psidqvpsi, ikk, ikq, ipert)
|
|
ENDIF
|
|
!
|
|
DO icart = 1, 3
|
|
DO jcart = 1, 3
|
|
DO ibnd = 1, nbnd
|
|
DO ig = 1, npw
|
|
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)))
|
|
work5(ig)= work1(ig)*tpiba*(xk(jcart,ikk)+g(jcart,igk(ig)))
|
|
ENDDO
|
|
DO ig = 1, npwq
|
|
work3(ig)=dpsi(ig,ibnd)*tpiba*(xk(icart,ikq)+g(icart,igkq(ig)))
|
|
work4(ig)=dpsi(ig,ibnd)*tpiba*(xk(jcart,ikq)+g(jcart,igkq(ig)))
|
|
work6(ig)= work3(ig)*tpiba*(xk(jcart,ikq)+g(jcart,igkq(ig)))
|
|
ENDDO
|
|
jkb=0
|
|
DO nt = 1, ntyp
|
|
DO na = 1, nat
|
|
IF (ityp (na).EQ.nt) THEN
|
|
na_icart = 3 * (na - 1) + icart
|
|
na_jcart = 3 * (na - 1) + jcart
|
|
DO ikb = 1, nh (nt)
|
|
jkb = jkb+1
|
|
alpha(1) = ZDOTC(npw, work1, 1,vkb0(1,jkb), 1)
|
|
alpha(2) = ZDOTC(npwq,vkb(1,jkb), 1, work4, 1)
|
|
alpha(3) = ZDOTC(npw, work2, 1,vkb0(1,jkb), 1)
|
|
alpha(4) = ZDOTC(npwq,vkb(1,jkb), 1, work3, 1)
|
|
alpha(5) = ZDOTC(npw, work5, 1,vkb0(1,jkb), 1)
|
|
alpha(6) = ZDOTC(npwq,vkb(1,jkb),1,dpsi(1,ibnd),1)
|
|
alpha(7) = ZDOTC(npw, evc(1,ibnd),1,vkb0(1,jkb),1)
|
|
alpha(8) = ZDOTC(npwq,vkb(1,jkb),1,work6, 1)
|
|
!
|
|
CALL reduce(16, alpha)
|
|
!
|
|
d3dywrk(na_icart,na_jcart) = d3dywrk(na_icart,na_jcart) &
|
|
+ CONJG(alpha(1) * alpha(2) + alpha(3) * alpha(4) - &
|
|
alpha(5) * alpha(6) - alpha(7) * alpha(8) ) &
|
|
* dvan (ikb, ikb, nt) * wgg * 2.0d0
|
|
ENDDO
|
|
ENDIF
|
|
ENDDO
|
|
END DO
|
|
END DO
|
|
ENDDO
|
|
ENDDO
|
|
ENDDO
|
|
!
|
|
CALL poolreduce (2 * 9 * nat * nat, d3dywrk)
|
|
!
|
|
! Rotate the dynamical matrix on the basis of patterns
|
|
! some indices do not need to be rotated
|
|
!
|
|
nu_k = ipert
|
|
DO nu_i = 1, 3 * nat
|
|
IF (q0mode (nu_i) ) THEN
|
|
DO nu_j = 1, 3 * nat
|
|
work = (0.0d0, 0.0d0)
|
|
DO na = 1, nat
|
|
DO icart = 1, 3
|
|
na_icart = 3 * (na - 1) + icart
|
|
DO jcart = 1, 3
|
|
na_jcart = 3 * (na - 1) + jcart
|
|
work = work + ug0 (na_icart, nu_i) * &
|
|
d3dywrk (na_icart,na_jcart) * u (na_jcart, nu_j)
|
|
ENDDO
|
|
ENDDO
|
|
ENDDO
|
|
d3dyn (nu_i, nu_k, nu_j) = d3dyn (nu_i, nu_k, nu_j) + work
|
|
d3dyn (nu_i, nu_j, nu_k) = d3dyn (nu_i, nu_j, nu_k) + CONJG(work)
|
|
ENDDO
|
|
ENDIF
|
|
ENDDO
|
|
|
|
DEALLOCATE (work6)
|
|
DEALLOCATE (work5)
|
|
DEALLOCATE (work4)
|
|
DEALLOCATE (work3)
|
|
DEALLOCATE (work2)
|
|
DEALLOCATE (work1)
|
|
DEALLOCATE (work0)
|
|
DEALLOCATE (d3dywrk)
|
|
|
|
RETURN
|
|
END SUBROUTINE dqrhod2v
|