mirror of https://gitlab.com/QEF/q-e.git
333 lines
10 KiB
Fortran
333 lines
10 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 .
|
|
!
|
|
!-----------------------------------------------------------------------
|
|
subroutine raman_mat
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
! Reads on the disk all the necessary wavefunctions and computes
|
|
! the raman tensor
|
|
!
|
|
#include "f_defs.h"
|
|
|
|
use kinds, only : DP
|
|
use pwcom
|
|
USE io_files, ONLY: iunigk
|
|
USE ions_base, ONLY: nat
|
|
USE wavefunctions_module, ONLY: evc
|
|
use phcom
|
|
USE ramanm
|
|
implicit none
|
|
|
|
logical :: wr_all
|
|
integer :: ik, ig, ipa, ipb, icr, jcr, iat, ibnd, jbnd, imod, nrec, &
|
|
il, ntm
|
|
! counter on k-points
|
|
! counter on electric field polarizations
|
|
! counter on electric field polarizations
|
|
! counter on cartesian coordinates
|
|
! counter on cartesian coordinates
|
|
! counter on atoms
|
|
! counter on bands
|
|
! counter on atomic displacement mode
|
|
! record number
|
|
|
|
real(DP) , allocatable :: wrk (:,:,:), matram(:,:,:,:), matw(:,:,:,:,:)
|
|
! working array
|
|
! the Raman-tensor: the first two indexes referes to the electric fields,
|
|
! the last two to the atomic displacemts
|
|
! components of the Raman-tensor: used only for testing purposes
|
|
real(DP) :: weight, tmp
|
|
! weight in the summation over k-points
|
|
! working space
|
|
|
|
complex(DP) , allocatable :: uact(:,:), chif(:,:,:), &
|
|
depsi (:,:,:), auxg(:), evc_sw (:,:), aux1 (:,:), &
|
|
ps (:,:,:,:), becp1_sw (:,:), alphap_sw (:,:,:)
|
|
! pattern of atomic displacements
|
|
! array of wavefunctions
|
|
! swap space
|
|
complex(DP) :: tmpc, ZDOTC
|
|
! the scalar product function
|
|
|
|
allocate (wrk (6,3*nat,2) )
|
|
allocate (matram (3,3,3,nat) )
|
|
allocate (matw (3,3,3,nat,4) )
|
|
allocate (uact (3*nat,3*nat) )
|
|
allocate (chif (npwx,nbnd,6) )
|
|
allocate (depsi (npwx,nbnd,3) )
|
|
allocate (auxg (npwx) )
|
|
allocate (evc_sw (npwx,nbnd) )
|
|
allocate (aux1 (npwx,nbnd) )
|
|
allocate (ps (nbnd,nbnd,3,3))
|
|
allocate (becp1_sw (nkb,nbnd) )
|
|
allocate (alphap_sw (nkb,nbnd,3) )
|
|
|
|
!
|
|
! Set the atomic displacement pattern ( crystal coordinates )
|
|
!
|
|
uact (:,:) = (0.d0, 0.d0)
|
|
do iat = 0, nat - 1
|
|
do icr = 1, 3
|
|
do jcr = 1, 3
|
|
uact (3*iat + jcr, 3*iat + icr) = CMPLX (at (jcr, icr), 0.d0)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
wrk (:,:,:) = 0.d0
|
|
if (nksq.gt.1) rewind (unit = iunigk)
|
|
|
|
!
|
|
! The raman tensor is computed as the sum of three different contribution
|
|
! These contributions are calculated in the following loop and stored
|
|
! in the two different arrays wrk(:,:,i),i=1,2 ( this may be usefull while
|
|
! testing ).
|
|
!
|
|
do ik = 1, nksq
|
|
!
|
|
! Using weight = 2.d0*wk(ik)*e2, calculates the third derivative of the
|
|
! energy with respect to atomic displacemements and with respect to two
|
|
! electric fields (units are Bohr^2).
|
|
! Using weight = -2.d0*wk(ik)*e2*fpi/omega, calculates the derivative
|
|
! of the dielectric constants with respect to atomic-displacem
|
|
! (units are Bohr^-1 ).
|
|
! weight = -2.d0*wk(ik)*e2
|
|
weight = - 2.d0 * wk (ik) * e2 * fpi / omega
|
|
|
|
if (nksq.gt.1) read (iunigk) npw, igk
|
|
npwq = npw
|
|
if (nksq.gt.1) call davcio (evc, lrwfc, iuwfc, ik, -1)
|
|
call init_us_2 (npw, igk, xk (1,ik), vkb)
|
|
|
|
do ipa = 1, 3
|
|
nrec = (ipa - 1) * nksq + ik
|
|
call davcio (depsi (1, 1, ipa), lrdwf, iudwf, nrec, -1)
|
|
enddo
|
|
do ipa = 1, 3
|
|
do ipb = 1, 3
|
|
do ibnd = 1, nbnd_occ (ik)
|
|
do jbnd = 1, nbnd_occ (ik)
|
|
ps (ibnd, jbnd, ipa, ipb) = &
|
|
ZDOTC (npwq, depsi (1, ibnd, ipa), 1, &
|
|
depsi (1, jbnd, ipb), 1)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
#ifdef __PARA
|
|
call reduce (2 * nbnd * nbnd * 9, ps)
|
|
#endif
|
|
do ipa = 1, 6
|
|
nrec = (ipa - 1) * nksq + ik
|
|
call davcio (chif (1, 1, ipa), lrd2w, iud2w, nrec, -1)
|
|
enddo
|
|
|
|
do ipa = 1, 6
|
|
do ibnd = 1, nbnd_occ (ik)
|
|
auxg (:) = (0.d0, 0.d0)
|
|
do jbnd = 1, nbnd_occ (ik)
|
|
tmpc = ps (jbnd, ibnd, a1j (ipa), a2j (ipa))
|
|
call ZAXPY (npwq, tmpc, evc (1, jbnd), 1, auxg, 1)
|
|
enddo
|
|
call DAXPY (2 * npwq, -1.d0, auxg, 1, chif (1, ibnd, ipa), 1)
|
|
enddo
|
|
enddo
|
|
|
|
do imod = 1, 3 * nat
|
|
call dvqpsi_us (ik, imod, uact (1, imod),.false. )
|
|
do ipa = 1, 6
|
|
tmp = 0.d0
|
|
do ibnd = 1, nbnd_occ (ik)
|
|
tmp = tmp + weight * DBLE( ZDOTC(npwq, &
|
|
chif (1, ibnd, ipa), 1, dvpsi (1, ibnd), 1) )
|
|
enddo
|
|
wrk (ipa, imod, 1) = wrk (ipa, imod, 1) + tmp
|
|
enddo
|
|
enddo
|
|
|
|
!
|
|
! evc, becp1, alphap are written into a swap space
|
|
!
|
|
if (nksq.eq.1) call ZCOPY (npwx * nbnd, evc, 1, evc_sw, 1)
|
|
call ZCOPY (nkb * nbnd, becp1 (1, 1, ik), 1, becp1_sw, 1)
|
|
call ZCOPY (nkb * nbnd * 3, alphap (1, 1, 1, ik), 1, alphap_sw, 1)
|
|
|
|
do ipa = 1, 3
|
|
nrec = (ipa - 1) * nksq + ik
|
|
call davcio (chif (1, 1, ipa), lrdwf, iudwf, nrec, -1)
|
|
enddo
|
|
|
|
do imod = 1, 3 * nat
|
|
do ipa = 1, 3
|
|
!
|
|
! initializes some variables used by dvqpsi_us
|
|
!
|
|
call ZCOPY (npwx * nbnd, chif (1, 1, ipa), 1, evc, 1)
|
|
call ccalbec (nkb, npwx, npw, nbnd, becp1 (1, 1, ik), vkb, evc)
|
|
do ipb = 1, 3
|
|
do ibnd = 1, nbnd
|
|
do ig = 1, npw
|
|
aux1 (ig, ibnd) = evc(ig,ibnd) * &
|
|
tpiba * (0.d0,1.d0) * &
|
|
( xk(ipb,ik) + g(ipb,igk(ig)) )
|
|
enddo
|
|
enddo
|
|
call ccalbec (nkb, npwx, npw, nbnd, alphap(1,1,ipb,ik), vkb, aux1)
|
|
enddo
|
|
|
|
call dvqpsi_us (ik, imod, uact (1, imod),.false. )
|
|
do ipb = 1, ipa
|
|
tmp = 0.d0
|
|
do ibnd = 1, nbnd_occ (ik)
|
|
tmp = tmp + weight * DBLE(ZDOTC (npwq, &
|
|
chif (1, ibnd, ipb), 1, dvpsi (1, ibnd), 1) )
|
|
enddo
|
|
wrk (jab (ipa, ipb), imod, 2) = &
|
|
wrk (jab (ipa, ipb), imod, 2) + tmp
|
|
enddo
|
|
enddo
|
|
enddo
|
|
!
|
|
! evc, becp1, alphap are restored to their original value
|
|
!
|
|
if (nksq.eq.1) call ZCOPY (npwx * nbnd, evc_sw, 1, evc, 1)
|
|
call ZCOPY (nkb * nbnd, becp1_sw, 1, becp1 (1, 1, ik), 1)
|
|
call ZCOPY (nkb * nbnd * 3, alphap_sw, 1, alphap (1, 1, 1, ik), 1)
|
|
|
|
enddo
|
|
|
|
#ifdef __PARA
|
|
call reduce(6 * 3 * nat * 2, wrk )
|
|
call poolreduce(6 * 3 * nat * 2, wrk )
|
|
#endif
|
|
|
|
do iat = 1, nat
|
|
do icr = 1, 3
|
|
imod = icr + (iat - 1) * 3
|
|
do ipa = 1, 3
|
|
do ipb = 1, ipa
|
|
tmp = wrk (jab (ipa, ipb), imod, 1) + &
|
|
wrk (jab (ipa, ipb), imod, 2)
|
|
matw (ipa, ipb, icr, iat, 1) = tmp
|
|
matw (ipb, ipa, icr, iat, 1) = tmp
|
|
do il = 1, 2
|
|
matw (ipa, ipb, icr, iat, il + 1) = &
|
|
wrk (jab (ipa, ipb), imod, il)
|
|
matw (ipb, ipa, icr, iat, il + 1) = &
|
|
wrk (jab (ipa, ipb), imod, il)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
!
|
|
! wr_all =.true. ==> writes the two contributions before and after
|
|
! symmetrization (used for testing purposes only )
|
|
!
|
|
wr_all = .false.
|
|
|
|
ntm = 1
|
|
if (wr_all ) ntm = 3
|
|
|
|
do il = 1, ntm
|
|
call DCOPY(27*nat,matw(1,1,1,1,il),1,matram,1)
|
|
if (wr_all ) then
|
|
if (il.eq.1) then
|
|
write(6,'(/,10x,''Raman tensor: Total '',/)')
|
|
else
|
|
write(6,'(/,10x,''Raman tensor: contribution # '',i3,/)') &
|
|
il - 1
|
|
endif
|
|
write(6,'(/,10x,''Unsymmetrized in crystal axis '',/)')
|
|
call write_raman(matram)
|
|
endif
|
|
!
|
|
! Symmetrizes the Raman tensor
|
|
!
|
|
call symram(matram,nsym,s,nat,irt)
|
|
if (wr_all ) then
|
|
write(6,'(/,10x,''Symmetrized in crystal axis '',/)')
|
|
call write_raman(matram)
|
|
endif
|
|
!
|
|
! Transforms from crystal to cartesian axis
|
|
!
|
|
do iat = 1, nat
|
|
call trntnsr_3 (matram (1, 1, 1, iat), at, bg, 1)
|
|
enddo
|
|
write(6,'(/,10x,''Raman tensor (au^-1) in cartesian axis '',/)')
|
|
|
|
if (il == 1) ramtns(:,:,:,:) = matram(:,:,:,:)
|
|
if (wr_all ) call write_raman(matram)
|
|
|
|
do iat = 1, nat
|
|
write(6,'(10x,'' atom '',i6)') iat
|
|
do icr = 1, 3
|
|
do ipb = 1, 3
|
|
write(6,'(10x,''('',3f18.9,'' )'')') &
|
|
(matram(ipa,ipb,icr,iat),ipa=1,3)
|
|
enddo
|
|
write(6,'(10x)')
|
|
enddo
|
|
enddo
|
|
enddo
|
|
!
|
|
! write Raman tensor dchi/du = (omega/4pi)*deps/du in A^2
|
|
! it may not be written to file fildyn if trans=.false.
|
|
!
|
|
call write_ramtns (6, ramtns)
|
|
!
|
|
deallocate (wrk )
|
|
deallocate (matram )
|
|
deallocate (matw )
|
|
deallocate (uact )
|
|
deallocate (chif )
|
|
deallocate (depsi )
|
|
deallocate (auxg )
|
|
deallocate (evc_sw )
|
|
deallocate (aux1 )
|
|
deallocate (ps )
|
|
deallocate (becp1_sw )
|
|
deallocate (alphap_sw )
|
|
|
|
return
|
|
end subroutine raman_mat
|
|
!
|
|
!-----------------------------------------------------------------------
|
|
subroutine write_raman (matram)
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
#include "f_defs.h"
|
|
|
|
use kinds, only : DP
|
|
USE ions_base, ONLY: nat
|
|
USE ramanm
|
|
implicit none
|
|
|
|
real(DP) :: matram(3,3,3,nat)
|
|
|
|
integer :: icr, iat, ipa
|
|
character (len=2) :: ch(3), ch2(6)
|
|
|
|
data ch /'X','Y','Z'/
|
|
data ch2 /'XX','YY','ZZ','XY','YZ','ZX'/
|
|
|
|
write(6,'('' at'',7x,3(a2,10x),3x,3(a2,10x) )') &
|
|
( ch2 (icr), icr = 1, 6)
|
|
do iat = 1, nat
|
|
write(6,'(1x)')
|
|
do icr = 1, 3
|
|
write(6,'(1x,i3,1x,a1,'':'',3f12.6,3x,3f12.6)') &
|
|
iat, ch (icr), &
|
|
(matram (a1j (ipa), a2j (ipa), icr, iat), ipa=1,6)
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end subroutine write_raman
|