! ! 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