TABLE OF CONTENTS
- ABINIT/m_pawdij
- m_pawdij/pawdij
- m_pawdij/pawdij_gather
- m_pawdij/pawdij_print_ij
- m_pawdij/pawdijexxc
- m_pawdij/pawdijfock
- m_pawdij/pawdijfr
- m_pawdij/pawdijhartree
- m_pawdij/pawdijhat
- m_pawdij/pawdijnd
- m_pawdij/pawdijso
- m_pawdij/pawdiju
- m_pawdij/pawdiju_euijkl
- m_pawdij/pawdijxc
- m_pawdij/pawdijxcm
- m_pawdij/pawpupot
- m_pawdij/pawxpot
- m_pawdij/symdij
- m_pawdij/symdij_all
ABINIT/m_pawdij [ Modules ]
NAME
m_pawdij
FUNCTION
This module contains several routines used to compute the PAW pseudopotential
strengths Dij. The Dijs define the non-local PAW operator:
VNL = Sum_ij [ Dij |pi><pj| ], with pi, pj= projectors
COPYRIGHT
Copyright (C) 2013-2024 ABINIT group (MT, FJ, BA, JWZ) This file is distributed under the terms of the GNU General Public License, see ~abinit/COPYING or http://www.gnu.org/copyleft/gpl.txt . For the initials of contributors, see ~abinit/doc/developers/contributors.txt.
NOTES
FOR DEVELOPPERS: in order to preserve the portability of libPAW library, please consult ~abinit/src/??_libpaw/libpaw-coding-rules.txt
SOURCE
23 #include "libpaw.h" 24 25 MODULE m_pawdij 26 27 USE_DEFS 28 USE_MSG_HANDLING 29 USE_MPI_WRAPPERS 30 USE_MEMORY_PROFILING 31 32 use m_paral_atom, only : get_my_atmtab, free_my_atmtab 33 use m_paw_io, only : pawio_print_ij 34 use m_pawang, only : pawang_type 35 use m_pawrad, only : pawrad_type, pawrad_deducer0, simp_gen, nderiv_gen 36 use m_pawtab, only : pawtab_type 37 use m_paw_an, only : paw_an_type 38 use m_paw_ij, only : paw_ij_type, paw_ij_print 39 use m_pawfgrtab, only : pawfgrtab_type 40 use m_pawrhoij, only : pawrhoij_type 41 use m_paw_finegrid, only : pawgylm, pawexpiqr 42 use m_paw_sphharm, only : slxyzs 43 44 implicit none 45 46 private 47 48 !public procedures. 49 public :: pawdij ! Dij total 50 public :: pawdijhartree ! Dij Hartree 51 public :: pawdijfock ! Dij Fock exact-exchange 52 public :: pawdijxc ! Dij eXchange-Correlation (using (r,theta,phi) grid) 53 public :: pawdijxcm ! Dij eXchange-Correlation (using (l,m) moments) 54 public :: pawdijhat ! Dij^hat (compensation charge contribution) 55 public :: pawdijnd ! Dij nuclear dipole 56 public :: pawdijso ! Dij spin-orbit 57 public :: pawdiju ! Dij DFT+U 58 public :: pawdiju_euijkl ! Dij DFT+U, using pawrhoij instead of occupancies 59 public :: pawdijexxc ! Dij local exact-exchange 60 public :: pawdijfr ! 1st-order frozen Dij 61 public :: pawpupot ! On-site DFT+U potential 62 public :: pawxpot ! On-site local exact-exchange potential 63 public :: symdij ! Symmetrize total Dij or one part of it 64 public :: symdij_all ! Symmetrize all contributions to Dij 65 public :: pawdij_gather ! Perform a allgather operation on Dij 66 public :: pawdij_print_dij ! Print out a Dij matrix
m_pawdij/pawdij [ Functions ]
[ Top ] [ m_pawdij ] [ Functions ]
NAME
pawdij
FUNCTION
Compute the pseudopotential strengths Dij of the PAW non local operator as sum of several contributions. Can compute first-order strenghts Dij for RF calculations. This routine is a driver calling, for each contribution to Dij, a specific routines. Within standard PAW formalism, Dij can be decomposd as follows: Dij = Dij_atomic + Dij_Hartree + Dij_XC + Dij^hat In case of additional approximations, several other terms can appear: Dij_DFT+U, Dij_spin-orbit, Dij_local-exact-exchange, Dij_Fock...
INPUTS
cplex=1 if no phase is applied (GS), 2 if a exp(-iqr) phase is applied (Response Function at q<>0) enunit=choice for units of output Dij gprimd(3,3)=dimensional primitive translations for reciprocal space [hyb_mixing, hyb_mixing_sr]= -- optional-- mixing factors for the global (resp. screened) XC hybrid functional ipert=index of perturbation (used only for RF calculation ; set ipert<=0 for GS calculations. my_natom=number of atoms treated by current processor natom=total number of atoms in cell nfft=number of real space grid points (for current proc) nfftot=total number of real space grid points nspden=number of spin-density components ntypat=number of types of atoms in unit cell. paw_an(my_natom) <type(paw_an_type)>=paw arrays given on angular mesh paw_ij(my_natom) <type(paw_ij_type)>=paw arrays given on (i,j) channels pawang <type(pawang_type)>=paw angular mesh and related data pawfgrtab(my_natom) <type(pawfgrtab_type)>=atomic data given on fine rectangular grid pawprtvol=control print volume and debugging output for PAW pawrad(ntypat) <type(pawrad_type)>=paw radial mesh and related data pawrhoij(my_natom) <type(pawrhoij_type)>= paw rhoij occupancies and related data pawspnorb=flag: 1 if spin-orbit coupling is activated pawtab(ntypat) <type(pawtab_type)>=paw tabulated starting data pawxcdev=Choice of XC development (0=no dev. (use of angular mesh) ; 1 or 2=dev. on moments) qphon(3)=wavevector of the phonon spnorbscl=scaling factor for spin-orbit coupling ucvol=unit cell volume vtrial(cplex*nfft,nspden)=GS potential on real space grid vxc(cplex*nfft,nspden)=XC potential (Hartree) on real space grid xred(3,my_natom)= reduced atomic coordinates ======== Optional arguments ============== Parallelism over atomic sites: mpi_atmtab(:)=indexes of the atoms treated by current proc comm_atom=MPI communicator over atoms mpi_comm_grid=MPI communicator over real space grid points Application of a potential energy shift on atomic sites: natvshift=number of atomic potential energy shifts (per atom) ; default=0 atvshift(natvshift,nsppol,natom)=potential energy shift for lm channel & spin & atom fatvshift=factor that multiplies atvshift Electrons-positron 2-component DFT: electronpositron_calctype=type of calculation for electron-positron 2component-DFT: 0: standard DFT (no positron) ; default value 1: positron in the constant electrons potential 2: electrons in the constant positron potential electronpositron_pawrhoij(my_natom) <type(pawrhoij_type)>= PAW occupation matrix of the "constant" particle(s) (electrons if calctype=1, positron if calctype=2) electronpositron_lmselect(lmmax,my_natom)= Flags selecting the non-zero LM-moments of on-site densities for the "constant" particle(s) (electrons if calctype=1, positron if calctype=2)
OUTPUT
paw_ij(iatom)%dij(cplex_dij*qphase*lmn2_size,ndij)= total Dij terms (GS calculation, ipert=0)
total 1st-order Dij terms (RF ccalc., ipert>0)
May be complex if cplex_dij=2
dij(:,1) contains Dij^up-up
dij(:,2) contains Dij^dn-dn
dij(:,3) contains Dij^up-dn (only if nspinor=2)
dij(:,4) contains Dij^dn-up (only if nspinor=2)
May also compute paw_ij(iatom)%dij0,paw_ij(iatom)%dijhartree,paw_ij(iatom)%dijxc,
paw_ij(iatom)%dijxc_hat,paw_ij(iatom)%dijxc_val,
paw_ij(iatom)%dijhat,paw_ij(iatom)dijso,
paw_ij(iatom)%dijU,paw_ij(iatom)%dijexxc,paw_ij(iatom)%dijfock
NOTES
Response function calculations:
In order to compute first-order Dij, paw_an (resp. paw_ij) datastructures
must contain first-order quantities, namely paw_an1 (resp. paw_ij1).
SOURCE
160 subroutine pawdij(cplex,enunit,gprimd,ipert,my_natom,natom,nfft,nfftot,nspden,ntypat,& 161 & paw_an,paw_ij,pawang,pawfgrtab,pawprtvol,pawrad,pawrhoij,pawspnorb,pawtab,& 162 & pawxcdev,qphon,spnorbscl,ucvol,charge,vtrial,vxc,xred,& 163 & electronpositron_calctype,electronpositron_pawrhoij,electronpositron_lmselect,& 164 & atvshift,fatvshift,natvshift,nucdipmom,& 165 & mpi_atmtab,comm_atom,mpi_comm_grid,hyb_mixing,hyb_mixing_sr) 166 167 !Arguments --------------------------------------------- 168 !scalars 169 integer,intent(in) :: cplex,enunit,ipert,my_natom,natom,nfft,nfftot 170 integer,intent(in) :: nspden,ntypat,pawprtvol,pawspnorb,pawxcdev 171 integer,optional,intent(in) :: electronpositron_calctype 172 integer,optional,intent(in) :: comm_atom,mpi_comm_grid,natvshift 173 real(dp),intent(in) :: spnorbscl,ucvol,charge 174 real(dp),intent(in),optional ::fatvshift,hyb_mixing,hyb_mixing_sr 175 type(pawang_type),intent(in) :: pawang 176 !arrays 177 integer,optional,target,intent(in) :: mpi_atmtab(:) 178 logical,optional,intent(in) :: electronpositron_lmselect(:,:) 179 real(dp),intent(in) :: gprimd(3,3),qphon(3) 180 real(dp),intent(in) :: vxc(:,:),xred(3,natom) 181 real(dp),intent(in),target :: vtrial(cplex*nfft,nspden) 182 real(dp),intent(in),optional :: atvshift(:,:,:) 183 real(dp),intent(in),optional :: nucdipmom(3,natom) 184 type(paw_an_type),intent(in) :: paw_an(my_natom) 185 type(paw_ij_type),target,intent(inout) :: paw_ij(my_natom) 186 type(pawfgrtab_type),intent(inout) :: pawfgrtab(my_natom) 187 type(pawrad_type),intent(in) :: pawrad(ntypat) 188 type(pawrhoij_type),intent(inout) :: pawrhoij(my_natom) 189 type(pawrhoij_type),intent(in),optional :: electronpositron_pawrhoij(:) 190 type(pawtab_type),intent(in) :: pawtab(ntypat) 191 192 !Local variables --------------------------------------- 193 !scalars 194 !Possible algos for PAW+U: 1=using occupation matrix n_i,,2=using PAW matrix rho_ij 195 integer, parameter :: PAWU_ALGO_1=1,PAWU_ALGO_2=2 196 integer, parameter :: PAWU_FLL=1,PAWU_AMF=2 197 integer :: cplex_dij,iatom,iatom_tot,idij,ipositron,itypat,klmn,klmn1,lm_size,lmn2_size 198 integer :: lpawu,my_comm_atom,my_comm_grid,natvshift_,ndij,nsploop,nsppol 199 integer :: pawu_algo,pawu_dblec,qphase,usekden,usepawu,usexcnhat 200 logical :: dij_available,dij_need,dij_prereq 201 logical :: dij0_available,dij0_need,dij0_prereq 202 logical :: dijexxc_available,dijexxc_need,dijexxc_prereq 203 logical :: dijfock_available,dijfock_need,dijfock_prereq 204 logical :: dijhartree_available,dijhartree_need,dijhartree_prereq 205 logical :: dijhat_available,dijhat_need,dijhat_prereq 206 logical :: dijhatfr_available,dijhatfr_need,dijhatfr_prereq 207 logical :: dijnd_available,dijnd_need,dijnd_prereq 208 logical :: dijso_available,dijso_need,dijso_prereq 209 logical :: dijxc_available,dijxc_need,dijxc_prereq 210 logical :: dijxchat_available,dijxchat_need,dijxchat_prereq 211 logical :: dijxcval_available,dijxcval_need,dijxcval_prereq 212 logical :: dijU_available,dijU_need,dijU_prereq 213 logical :: has_nucdipmom,my_atmtab_allocated 214 logical :: need_to_print,paral_atom,v_dijhat_allocated 215 real(dp) :: hyb_mixing_,hyb_mixing_sr_ 216 character(len=500) :: msg 217 !arrays 218 integer,pointer :: my_atmtab(:) 219 logical,allocatable :: lmselect(:) 220 real(dp),allocatable :: dij0(:),dijhartree(:) 221 real(dp),allocatable :: dijhat(:,:),dijexxc(:,:),dijfock_cv(:,:),dijfock_vv(:,:),dijpawu(:,:) 222 real(dp),allocatable :: dijnd(:,:),dijso(:,:) 223 real(dp),allocatable :: dijxc(:,:),dij_ep(:),dijxchat(:,:),dijxcval(:,:) 224 real(dp),pointer :: v_dijhat(:,:),vpawu(:,:,:,:),vpawx(:,:,:) 225 226 ! ************************************************************************* 227 228 !------------------------------------------------------------------------ 229 !----- Check consistency of arguments 230 !------------------------------------------------------------------------ 231 232 ! === Check optional arguments === 233 234 hyb_mixing_ =zero ; if(present(hyb_mixing)) hyb_mixing_ =hyb_mixing 235 hyb_mixing_sr_=zero ; if(present(hyb_mixing_sr)) hyb_mixing_sr_=hyb_mixing_sr 236 237 natvshift_=0;if (present(natvshift)) natvshift_=natvshift 238 if (natvshift_>0) then 239 if ((.not.present(atvshift)).or.(.not.present(fatvshift))) then 240 msg='when natvshift>0, atvshift and fatvshift arguments must be present!' 241 LIBPAW_BUG(msg) 242 end if 243 end if 244 245 ipositron=0;if (present(electronpositron_calctype)) ipositron=electronpositron_calctype 246 if (ipositron/=0) then 247 if ((.not.present(electronpositron_pawrhoij)).or.& 248 & (.not.present(electronpositron_lmselect))) then 249 msg='ep_pawrhoij and ep_lmselect must be present for electron-positron calculations!' 250 LIBPAW_BUG(msg) 251 end if 252 end if 253 254 has_nucdipmom=present(nucdipmom) 255 256 ! === Check complex character of arguments === 257 258 if (nspden==4.and.cplex==2) then 259 msg='nspden=4 probably not compatible with cplex=2!' 260 LIBPAW_BUG(msg) 261 end if 262 if (my_natom>0) then 263 if (paw_ij(1)%ndij==4.and.paw_ij(1)%cplex_dij/=2) then 264 msg='invalid cplex size for Dij (4 Dij components)!' 265 LIBPAW_BUG(msg) 266 end if 267 if (paw_ij(1)%qphase/=paw_an(1)%cplex) then 268 msg='paw_ij()%qphase and paw_an()%cplex must be equal!' 269 LIBPAW_BUG(msg) 270 end if 271 if (ipert<=0.and.paw_ij(1)%qphase/=1) then 272 msg='qphase must be 1 for GS calculations!' 273 LIBPAW_BUG(msg) 274 end if 275 if (ipert>0.and.paw_ij(1)%qphase/=cplex) then 276 msg='paw_ij()%qphase must be equal to cplex!' 277 LIBPAW_BUG(msg) 278 end if 279 if (paw_an(1)%has_vxcval>0.and.paw_an(1)%has_vxctau==2) then 280 msg='kinetic energy density not available for vxc_val!' 281 LIBPAW_BUG(msg) 282 end if 283 end if 284 285 !------------------------------------------------------------------------ 286 !----- Initializations 287 !------------------------------------------------------------------------ 288 289 !Nothing to do for some perturbations (RF case) 290 if (ipert==natom+1.or.ipert==natom+10) then 291 do iatom=1,my_natom 292 if (paw_ij(iatom)%has_dij==1) paw_ij(iatom)%dij=zero 293 if (paw_ij(iatom)%has_dij0==1) paw_ij(iatom)%dij0=zero 294 if (paw_ij(iatom)%has_dijfock==1) paw_ij(iatom)%dijfock=zero 295 if (paw_ij(iatom)%has_dijhartree==1) paw_ij(iatom)%dijhartree=zero 296 if (paw_ij(iatom)%has_dijxc==1) paw_ij(iatom)%dijxc=zero 297 if (paw_ij(iatom)%has_dijhat==1) paw_ij(iatom)%dijhat=zero 298 if (paw_ij(iatom)%has_dijso==1) paw_ij(iatom)%dijso=zero 299 if (paw_ij(iatom)%has_dijU==1) paw_ij(iatom)%dijU=zero 300 if (paw_ij(iatom)%has_dijexxc==1) paw_ij(iatom)%dijexxc=zero 301 if (paw_ij(iatom)%has_dijxc_hat==1) paw_ij(iatom)%dijxc_hat=zero 302 if (paw_ij(iatom)%has_dijxc_val==1) paw_ij(iatom)%dijxc_val=zero 303 end do 304 return 305 end if 306 307 !Set up parallelism over atoms 308 paral_atom=(present(comm_atom).and.(my_natom/=natom)) 309 nullify(my_atmtab);if (present(mpi_atmtab)) my_atmtab => mpi_atmtab 310 my_comm_atom=xmpi_comm_self;if (present(comm_atom)) my_comm_atom=comm_atom 311 call get_my_atmtab(my_comm_atom,my_atmtab,my_atmtab_allocated,paral_atom,natom,my_natom_ref=my_natom) 312 313 !----- Various initializations 314 nsppol=1;nsploop=1 315 if (my_natom>0) then 316 nsppol=paw_ij(1)%nsppol 317 nsploop=nsppol;if (paw_ij(1)%ndij==4) nsploop=4 318 end if 319 usexcnhat=maxval(pawtab(1:ntypat)%usexcnhat) 320 my_comm_grid=xmpi_comm_self;if (present(mpi_comm_grid)) my_comm_grid=mpi_comm_grid 321 322 !------ Select potential for Dij^hat computation 323 v_dijhat_allocated=.false. 324 if (my_natom>0) then 325 if ((paw_ij(1)%has_dij==1).or.(paw_ij(1)%has_dijhat==1).or. & 326 & (paw_ij(1)%has_dijhat==0.and.pawprtvol/=0)) then 327 if (usexcnhat==0) then 328 if (size(vxc,1)/=cplex*nfft.or.size(vxc,2)/=nspden) then 329 msg='invalid size for vxc!' 330 LIBPAW_BUG(msg) 331 end if 332 LIBPAW_POINTER_ALLOCATE(v_dijhat,(cplex*nfft,nspden)) 333 v_dijhat_allocated=.true. 334 !v_dijhat=vtrial-vxc 335 do idij=1,nspden 336 do klmn=1,cplex*nfft 337 v_dijhat(klmn,idij)=vtrial(klmn,idij)-vxc(klmn,idij) 338 end do 339 end do 340 else 341 v_dijhat => vtrial 342 end if 343 end if 344 end if 345 346 !------------------------------------------------------------------------ 347 !----- Loop over atoms 348 !------------------------------------------------------------------------ 349 350 do iatom=1,my_natom 351 iatom_tot=iatom;if (paral_atom) iatom_tot=my_atmtab(iatom) 352 353 ! === Atom-dependent data === 354 355 itypat=paw_ij(iatom)%itypat 356 cplex_dij=paw_ij(iatom)%cplex_dij 357 qphase=paw_ij(iatom)%qphase 358 lm_size=paw_an(iatom)%lm_size 359 lmn2_size=paw_ij(iatom)%lmn2_size 360 ndij=paw_ij(iatom)%ndij 361 usepawu=pawtab(itypat)%usepawu 362 pawu_algo=merge(PAWU_ALGO_1,PAWU_ALGO_2,ipert<=0.and.usepawu>=0) 363 pawu_dblec=merge(PAWU_FLL,PAWU_AMF,abs(usepawu)==1.or.abs(usepawu)==4) 364 usekden=merge(0,1,paw_an(iatom)%has_vxctau/=2) 365 need_to_print=((abs(pawprtvol)>=1).and. & 366 & (iatom_tot==1.or.iatom_tot==natom.or.pawprtvol<0)) 367 368 ! === Determine which conditions and prerequisites are fulfilled for Dij === 369 370 if (my_natom>0) then 371 ! Total Dij: no condition ; no prerequisites 372 dij_available=.true.;dij_prereq=.true. 373 ! Dij0: not available for RF ; need kij for the positron 374 dij0_available=(ipert<=0);dij0_prereq=(ipositron/=1.or.pawtab(itypat)%has_kij==2) 375 ! DijFock:not available for RF, positron; only for Fock exact exch. ; Vxc_ex needed 376 dijfock_available=(paw_ij(iatom)%has_dijfock>0.and.ipert<=0.and.ipositron/=1) 377 dijfock_prereq=(paw_ij(iatom)%has_dijfock==2) 378 ! DijHartree: no condition ; no prerequisites 379 dijhartree_available=.true.;dijhartree_prereq=.true. 380 ! DijXC: no condition ; Vxc needed 381 dijxc_available=.true. 382 dijxc_prereq=(paw_ij(iatom)%has_dijxc==2.or.paw_an(iatom)%has_vxc>0) 383 ! Dij^hat: no condition ; no prerequisites 384 dijhat_available=.true.;dijhat_prereq=.true. 385 ! Dij^hat_FR: only for RF and when it was previously computed 386 dijhatfr_available=(ipert>0.and.paw_ij(iatom)%has_dijfr==2) ; dijhatfr_prereq=.true. 387 ! DijND: requires non-zero nucdipmom 388 dijnd_available=.false. ; dijnd_prereq=(cplex_dij==2) 389 if (has_nucdipmom) dijnd_available=(any(abs(nucdipmom(:,iatom))>tol8)) 390 ! DijSO: not available for RF, positron; only for spin-orbit ; VHartree and Vxc needed 391 dijso_available=(pawspnorb>0.and.ipert<=0.and.ipositron/=1) 392 dijso_prereq=(paw_ij(iatom)%has_dijso==2.or.& 393 & (paw_an(iatom)%has_vhartree>0.and.paw_an(iatom)%has_vxc>0)) 394 ! DijU: not available for positron; only for DFT+U 395 dijU_available=(pawtab(itypat)%usepawu/=0.and.ipositron/=1) 396 dijU_prereq=(paw_ij(iatom)%has_dijU==2.or.paw_ij(iatom)%has_pawu_occ>0.or. & 397 & (paw_ij(iatom)%has_dijU>0)) 398 ! DijExxc: not available for RF, positron; only for local exact exch. ; Vxc_ex needed 399 dijexxc_available=(pawtab(itypat)%useexexch/=0.and.ipert<=0.and.ipositron/=1) 400 dijexxc_prereq=(paw_ij(iatom)%has_dijexxc==2.or.paw_ij(iatom)%has_exexch_pot>0) 401 ! DijXC^hat: not available for RF ; Vxc needed 402 dijxchat_available=(ipert<=0) 403 dijxchat_prereq=(paw_ij(iatom)%has_dijxc_hat==2.or.paw_an(iatom)%has_vxc>0) 404 ! DijXC_val: not available for RF ; Vxc_val needed 405 dijxcval_available=(ipert<=0) 406 dijxcval_prereq=(paw_ij(iatom)%has_dijxc_val==2.or.paw_an(iatom)%has_vxcval>0) 407 end if 408 409 ! === Determine which parts of Dij have to be computed === 410 411 dij_need=.false.;dij0_need=.false.;dijexxc_need=.false.;dijfock_need=.false. 412 dijhartree_need=.false.;dijhat_need=.false.;dijhatfr_need=.false.; 413 dijso_need=.false.;dijU_need=.false.;dijxc_need=.false. 414 dijxchat_need=.false.;dijxcval_need=.false.; dijnd_need=.false. 415 416 if (dij_available) then 417 if (paw_ij(iatom)%has_dij==1) then 418 dij_need=.true.;paw_ij(iatom)%dij(:,:)=zero 419 else if (paw_ij(iatom)%has_dij==0.and.need_to_print) then 420 LIBPAW_ALLOCATE(paw_ij(iatom)%dij,(cplex_dij*qphase*lmn2_size,ndij)) 421 dij_need=.true.;paw_ij(iatom)%dij(:,:)=zero 422 paw_ij(iatom)%has_dij=-1 423 end if 424 else if (paw_ij(iatom)%has_dij==1) then 425 paw_ij(iatom)%dij=zero 426 end if 427 428 if (dij0_available) then 429 if (paw_ij(iatom)%has_dij0==1) then 430 dij0_need=.true.;paw_ij(iatom)%dij0(:)=zero 431 else if (paw_ij(iatom)%has_dij0==0.and.need_to_print) then 432 LIBPAW_ALLOCATE(paw_ij(iatom)%dij0,(lmn2_size)) 433 dij0_need=.true.;paw_ij(iatom)%dij0(:)=zero 434 paw_ij(iatom)%has_dij0=-1 435 end if 436 else if (paw_ij(iatom)%has_dij0==1) then 437 paw_ij(iatom)%dij0=zero 438 end if 439 440 if (dijfock_available) then 441 if (paw_ij(iatom)%has_dijfock==1) then 442 dijfock_need=.true.;paw_ij(iatom)%dijfock(:,:)=zero 443 else if (paw_ij(iatom)%has_dijfock==0.and.need_to_print) then 444 LIBPAW_ALLOCATE(paw_ij(iatom)%dijfock,(cplex_dij*lmn2_size,ndij)) 445 dijfock_need=.true.;paw_ij(iatom)%dijfock(:,:)=zero 446 paw_ij(iatom)%has_dijfock=-1 447 end if 448 else if (paw_ij(iatom)%has_dijfock==1) then 449 paw_ij(iatom)%dijfock=zero 450 end if 451 452 if (dijhartree_available) then 453 if (paw_ij(iatom)%has_dijhartree==1) then 454 dijhartree_need=.true.;paw_ij(iatom)%dijhartree(:)=zero 455 else if (paw_ij(iatom)%has_dijhartree==0) then 456 LIBPAW_ALLOCATE(paw_ij(iatom)%dijhartree,(qphase*lmn2_size)) 457 dijhartree_need=.true.;paw_ij(iatom)%dijhartree(:)=zero 458 paw_ij(iatom)%has_dijhartree=-1 459 end if 460 else if (paw_ij(iatom)%has_dijhartree==1) then 461 paw_ij(iatom)%dijhartree=zero 462 end if 463 464 if (dijxc_available) then 465 if (paw_ij(iatom)%has_dijxc==1) then 466 dijxc_need=.true.;paw_ij(iatom)%dijxc(:,:)=zero 467 else if (paw_ij(iatom)%has_dijxc==0.and.need_to_print) then 468 LIBPAW_ALLOCATE(paw_ij(iatom)%dijxc,(cplex_dij*qphase*lmn2_size,ndij)) 469 dijxc_need=.true.;paw_ij(iatom)%dijxc(:,:)=zero 470 paw_ij(iatom)%has_dijxc=-1 471 end if 472 else if (paw_ij(iatom)%has_dijxc==1) then 473 paw_ij(iatom)%dijxc=zero 474 end if 475 476 if (dijhat_available) then 477 if (paw_ij(iatom)%has_dijhat==1) then 478 dijhat_need=.true.;paw_ij(iatom)%dijhat(:,:)=zero 479 else if (paw_ij(iatom)%has_dijhat==0.and.need_to_print) then 480 LIBPAW_ALLOCATE(paw_ij(iatom)%dijhat,(cplex_dij*qphase*lmn2_size,ndij)) 481 dijhat_need=.true.;paw_ij(iatom)%dijhat(:,:)=zero 482 paw_ij(iatom)%has_dijhat=-1 483 end if 484 else if (paw_ij(iatom)%has_dijhat==1) then 485 paw_ij(iatom)%dijhat=zero 486 end if 487 488 if (dijnd_available) then 489 if (paw_ij(iatom)%has_dijnd==1) then 490 dijnd_need=.true.;paw_ij(iatom)%dijnd(:,:)=zero 491 else if (paw_ij(iatom)%has_dijnd==0.and.need_to_print) then 492 LIBPAW_ALLOCATE(paw_ij(iatom)%dijnd,(cplex_dij*lmn2_size,ndij)) 493 dijnd_need=.true.;paw_ij(iatom)%dijnd(:,:)=zero 494 paw_ij(iatom)%has_dijnd=-1 495 end if 496 else if (paw_ij(iatom)%has_dijnd==1) then 497 paw_ij(iatom)%dijnd=zero 498 end if 499 500 if (dijso_available) then 501 if (paw_ij(iatom)%has_dijso==1) then 502 dijso_need=.true.;paw_ij(iatom)%dijso(:,:)=zero 503 else if (paw_ij(iatom)%has_dijso==0.and.need_to_print) then 504 LIBPAW_ALLOCATE(paw_ij(iatom)%dijso,(cplex_dij*qphase*lmn2_size,ndij)) 505 dijso_need=.true.;paw_ij(iatom)%dijso(:,:)=zero 506 paw_ij(iatom)%has_dijso=-1 507 end if 508 else if (paw_ij(iatom)%has_dijso==1) then 509 paw_ij(iatom)%dijso=zero 510 end if 511 512 if (dijU_available) then 513 if (paw_ij(iatom)%has_dijU==1) then 514 dijU_need=.true.;paw_ij(iatom)%dijU(:,:)=zero 515 else if (paw_ij(iatom)%has_dijU==0.and.need_to_print) then 516 LIBPAW_ALLOCATE(paw_ij(iatom)%dijU,(cplex_dij*qphase*lmn2_size,ndij)) 517 dijU_need=.true.;paw_ij(iatom)%dijU(:,:)=zero 518 paw_ij(iatom)%has_dijU=-1 519 end if 520 else if (paw_ij(iatom)%has_dijU==1) then 521 paw_ij(iatom)%dijU=zero 522 end if 523 524 if (dijexxc_available.and.paw_ij(iatom)%has_dijexxc/=2) then 525 if (paw_ij(iatom)%has_dijexxc==1) then 526 dijexxc_need=.true.;paw_ij(iatom)%dijexxc(:,:)=zero 527 else if (paw_ij(iatom)%has_dijexxc==0.and.need_to_print) then 528 LIBPAW_ALLOCATE(paw_ij(iatom)%dijexxc,(cplex_dij*lmn2_size,ndij)) 529 dijexxc_need=.true.;paw_ij(iatom)%dijexxc(:,:)=zero 530 paw_ij(iatom)%has_dijexxc=-1 531 end if 532 else if (paw_ij(iatom)%has_dijexxc==1) then 533 paw_ij(iatom)%dijexxc=zero 534 end if 535 536 if (dijxchat_available) then 537 if (paw_ij(iatom)%has_dijxc_hat==1) then 538 dijxchat_need=.true.;paw_ij(iatom)%dijxc_hat(:,:)=zero 539 ! else if (paw_ij(iatom)%has_dijxc_hat==0.and.need_to_print) then 540 ! LIBPAW_ALLOCATE(paw_ij(iatom)%dijxc_hat,(cplex_dij*qphase*lmn2_size,ndij)) 541 ! dijxchat_need=.true.;paw_ij(iatom)%dijxc_hat(:,:)=zero 542 ! paw_ij(iatom)%has_dijxc_hat=-1 543 end if 544 else if (paw_ij(iatom)%has_dijxc_hat==1) then 545 paw_ij(iatom)%dijxc_hat=zero 546 end if 547 548 if (dijxcval_available) then 549 if (paw_ij(iatom)%has_dijxc_val==1) then 550 dijxcval_need=.true.;paw_ij(iatom)%dijxc_val(:,:)=zero 551 ! else if (paw_ij(iatom)%has_dijxc_val==0.and.need_to_print) then 552 ! LIBPAW_ALLOCATE(paw_ij(iatom)%dijxc_val,(cplex_dij*qphase*lmn2_size,ndij)) 553 ! dijxcval_need=.true.;paw_ij(iatom)%dijxc_val(:,:)=zero 554 ! paw_ij(iatom)%has_dijxc_val=-1 555 end if 556 else if (paw_ij(iatom)%has_dijxc_val==1) then 557 paw_ij(iatom)%dijxc_val=zero 558 end if 559 560 ! === Print error messages if prerequisites are not fulfilled === 561 562 if (dij_need.and.(.not.dij_prereq)) then 563 msg='Dij prerequisites missing!' 564 LIBPAW_BUG(msg) 565 end if 566 if (dij0_need.and.(.not.dij0_prereq)) then 567 msg='Dij0 prerequisites missing!' 568 LIBPAW_BUG(msg) 569 end if 570 if (dijfock_need.and.(.not.dijfock_prereq)) then 571 msg='DijFock prerequisites missing!' 572 LIBPAW_BUG(msg) 573 end if 574 575 if (dijhartree_need.and.(.not.dijhartree_prereq)) then 576 msg='DijHartree prerequisites missing!' 577 LIBPAW_BUG(msg) 578 end if 579 if (dijxc_need.and.(.not.dijxc_prereq)) then 580 msg='Dij^XC prerequisites missing!' 581 LIBPAW_BUG(msg) 582 end if 583 if (dijhat_need.and.(.not.dijhat_prereq)) then 584 msg='Dij^hat prerequisites missing!' 585 LIBPAW_BUG(msg) 586 end if 587 if (dijhatfr_need.and.(.not.dijhatfr_prereq)) then 588 msg='DijFR^hat prerequisites missing!' 589 LIBPAW_BUG(msg) 590 end if 591 if (dijnd_need.and.(.not.dijnd_prereq)) then 592 msg='DijND prerequisites missing!' 593 LIBPAW_BUG(msg) 594 end if 595 if (dijso_need.and.(.not.dijso_prereq)) then 596 msg='DijSO prerequisites missing!' 597 LIBPAW_BUG(msg) 598 end if 599 if (dijU_need.and.(.not.dijU_prereq)) then 600 msg='DijU prerequisites missing!' 601 LIBPAW_BUG(msg) 602 end if 603 if (dijexxc_need.and.(.not.dijexxc_prereq)) then 604 msg='DijExcc prerequisites missing!' 605 LIBPAW_BUG(msg) 606 end if 607 if (dijxchat_need.and.(.not.dijxchat_prereq)) then 608 msg='DijXC^hat prerequisites missing!' 609 LIBPAW_BUG(msg) 610 end if 611 if (dijxcval_need.and.(.not.dijxcval_prereq)) then 612 msg='DijXC_val prerequisites missing!' 613 LIBPAW_BUG(msg) 614 end if 615 616 ! ------------------------------------------------------------------------ 617 ! ----------- Add atomic Dij0 to Dij 618 ! ------------------------------------------------------------------------ 619 620 if ((dij0_need.or.dij_need).and.dij0_available) then 621 622 LIBPAW_ALLOCATE(dij0,(lmn2_size)) 623 ! ===== Dij0 already computed 624 if (paw_ij(iatom)%has_dij0==2) then 625 dij0(:)=paw_ij(iatom)%dij0(:) 626 else 627 ! ===== Need to compute Dij0 628 dij0(:)=pawtab(itypat)%dij0(:) 629 if (ipositron==1) dij0(:)=two*pawtab(itypat)%kij(:)-dij0(:) 630 if (pawu_algo==PAWU_ALGO_2.and.pawu_dblec==PAWU_FLL) dij0(:)=dij0(:)+pawtab(itypat)%euij_fll(:) 631 if (dij0_need) paw_ij(iatom)%dij0(:)=dij0(:) 632 end if 633 634 if (dij_need) then 635 do idij=1,min(nsploop,2) 636 klmn1=1 637 do klmn=1,lmn2_size 638 paw_ij(iatom)%dij(klmn1,idij)=paw_ij(iatom)%dij(klmn1,idij)+dij0(klmn) 639 klmn1=klmn1+cplex_dij 640 end do 641 end do 642 end if 643 LIBPAW_DEALLOCATE(dij0) 644 end if 645 646 ! ------------------------------------------------------------------------ 647 ! ------------------------------------------------------------------------ 648 ! ----------- Add Dij_{Fock exact-exchange} to Dij 649 ! ------------------------------------------------------------------------ 650 651 if ((dijfock_need.or.dij_need).and.dijfock_available) then 652 653 ! ===== DijFock already computed 654 if (paw_ij(iatom)%has_dijfock==2) then 655 if (dij_need) paw_ij(iatom)%dij(1:cplex_dij*lmn2_size,:)= & 656 & paw_ij(iatom)%dij(1:cplex_dij*lmn2_size,:) & 657 & +paw_ij(iatom)%dijfock(1:cplex_dij*lmn2_size,:) 658 659 else 660 661 ! ===== Need to compute DijFock 662 LIBPAW_ALLOCATE(dijfock_vv,(cplex_dij*lmn2_size,ndij)) 663 LIBPAW_ALLOCATE(dijfock_cv,(cplex_dij*lmn2_size,ndij)) 664 dijfock_vv(:,:)=zero ; dijfock_cv(:,:)=zero 665 ! Exact exchange is evaluated for electrons only 666 if (ipositron/=1) then 667 call pawdijfock(dijfock_vv,dijfock_cv,cplex_dij,qphase,hyb_mixing_,hyb_mixing_sr_, & 668 & ndij,pawrhoij(iatom),pawtab(itypat)) 669 end if 670 if (dijfock_need) paw_ij(iatom)%dijfock(:,:)=dijfock_vv(:,:)+dijfock_cv(:,:) 671 if (dij_need) paw_ij(iatom)%dij(1:cplex_dij*lmn2_size,:)= & 672 & paw_ij(iatom)%dij(1:cplex_dij*lmn2_size,:) & 673 & +dijfock_vv(1:cplex_dij*lmn2_size,:)+dijfock_cv(1:cplex_dij*lmn2_size,:) 674 LIBPAW_DEALLOCATE(dijfock_vv) 675 LIBPAW_DEALLOCATE(dijfock_cv) 676 end if 677 end if 678 679 ! ----------- Add Dij_Hartree to Dij 680 ! ------------------------------------------------------------------------ 681 682 if ((dijhartree_need.or.dij_need).and.dijhartree_available) then 683 684 LIBPAW_ALLOCATE(dijhartree,(qphase*lmn2_size)) 685 ! ===== DijHartree already computed 686 if (paw_ij(iatom)%has_dijhartree==2) then 687 dijhartree(:)=paw_ij(iatom)%dijhartree(:) 688 else 689 ! ===== Need to compute DijHartree 690 if (ipositron/=1) then 691 call pawdijhartree(dijhartree,qphase,nspden,pawrhoij(iatom),pawtab(itypat)) 692 else 693 dijhartree(:)=zero 694 end if 695 if (ipositron/=0) then 696 LIBPAW_ALLOCATE(dij_ep,(qphase*lmn2_size)) 697 call pawdijhartree(dij_ep,qphase,nspden,electronpositron_pawrhoij(iatom),pawtab(itypat)) 698 dijhartree(:)=dijhartree(:)-dij_ep(:) 699 LIBPAW_DEALLOCATE(dij_ep) 700 end if 701 if (dijhartree_need) paw_ij(iatom)%dijhartree(:)=dijhartree(:) 702 end if 703 704 if (dij_need) then 705 do idij=1,min(nsploop,2) 706 klmn1=1 707 do klmn=1,qphase*lmn2_size 708 paw_ij(iatom)%dij(klmn1,idij)=paw_ij(iatom)%dij(klmn1,idij)+dijhartree(klmn) 709 klmn1=klmn1+cplex_dij 710 end do 711 end do 712 end if 713 714 LIBPAW_DEALLOCATE(dijhartree) 715 end if 716 717 ! ------------------------------------------------------------------------ 718 ! ----------- Add Dij_xc to Dij 719 ! ------------------------------------------------------------------------ 720 721 if ((dijxc_need.or.dij_need).and.dijxc_available) then 722 723 ! ===== Dijxc already computed 724 if (paw_ij(iatom)%has_dijxc==2) then 725 if (dij_need) paw_ij(iatom)%dij(:,:)=paw_ij(iatom)%dij(:,:)+paw_ij(iatom)%dijxc(:,:) 726 else 727 728 ! ===== Need to compute DijXC 729 LIBPAW_ALLOCATE(dijxc,(cplex_dij*qphase*lmn2_size,ndij)) 730 if (pawxcdev/=0) then 731 LIBPAW_ALLOCATE(lmselect,(lm_size)) 732 lmselect(:)=paw_an(iatom)%lmselect(:) 733 if (ipositron/=0) lmselect(:)=(lmselect(:).or.electronpositron_lmselect(1:lm_size,iatom)) 734 call pawdijxcm(dijxc,cplex_dij,qphase,lmselect,ndij,nspden,nsppol,pawang,& 735 & pawrad(itypat),pawtab(itypat),paw_an(iatom)%vxc1,& 736 & paw_an(iatom)%vxct1,usexcnhat) 737 LIBPAW_DEALLOCATE(lmselect) 738 else 739 call pawdijxc(dijxc,cplex_dij,qphase,ndij,nspden,nsppol,& 740 & pawang,pawrad(itypat),pawtab(itypat),paw_an(iatom)%vxc1,& 741 & paw_an(iatom)%vxct1,usexcnhat,usekden,& 742 & vxctau1=paw_an(iatom)%vxctau1,vxcttau1=paw_an(iatom)%vxcttau1) 743 end if 744 if (dijxc_need) paw_ij(iatom)%dijxc(:,:)=dijxc(:,:) 745 if (dij_need) paw_ij(iatom)%dij(:,:)=paw_ij(iatom)%dij(:,:)+dijxc(:,:) 746 LIBPAW_DEALLOCATE(dijxc) 747 end if 748 749 end if 750 751 ! ------------------------------------------------------------------------ 752 ! ----------- Add Dij_hat to Dij 753 ! ------------------------------------------------------------------------ 754 755 if ((dijhat_need.or.dij_need).and.dijhat_available) then 756 757 ! ===== Dijhat already computed 758 if (paw_ij(iatom)%has_dijhat==2) then 759 if (dij_need) paw_ij(iatom)%dij(:,:)=paw_ij(iatom)%dij(:,:)+paw_ij(iatom)%dijhat(:,:) 760 else 761 762 ! ===== Need to compute Dijhat 763 LIBPAW_ALLOCATE(dijhat,(cplex_dij*qphase*lmn2_size,ndij)) 764 call pawdijhat(dijhat,cplex_dij,qphase,gprimd,iatom_tot,& 765 & natom,ndij,nfft,nfftot,nspden,nsppol,pawang,pawfgrtab(iatom),& 766 & pawtab(itypat),v_dijhat,qphon,ucvol,xred,mpi_comm_grid=my_comm_grid) 767 if (dijhat_need) paw_ij(iatom)%dijhat(:,:)=dijhat(:,:) 768 if (dij_need) paw_ij(iatom)%dij(:,:)=paw_ij(iatom)%dij(:,:)+dijhat(:,:) 769 LIBPAW_DEALLOCATE(dijhat) 770 end if 771 772 ! ===== RF: add frozen part of 1st-order Dij 773 if (dijhatfr_available) then 774 do idij=1,nsploop 775 if (dij_need) paw_ij(iatom)%dij(:,idij)=paw_ij(iatom)%dij(:,idij) & 776 & +paw_ij(iatom)%dijfr(:,idij) 777 if (dijhat_need) paw_ij(iatom)%dijhat(:,idij)=paw_ij(iatom)%dijhat(:,idij) & 778 & +paw_ij(iatom)%dijfr(:,idij) 779 end do 780 end if 781 782 end if 783 784 ! ------------------------------------------------------------------------ 785 ! ----------- Add Dij nuclear dipole moments to Dij 786 ! ------------------------------------------------------------------------ 787 788 if ((dijnd_need.or.dij_need).and.dijnd_available) then 789 790 ! ===== Dijnd already computed 791 if (paw_ij(iatom)%has_dijnd==2) then 792 if (dij_need) then 793 paw_ij(iatom)%dij(1:cplex_dij*lmn2_size,:)= & 794 & paw_ij(iatom)%dij(1:cplex_dij*lmn2_size,:) + & 795 & paw_ij(iatom)%dijnd(1:cplex_dij*lmn2_size,:) 796 end if 797 798 else 799 800 ! ===== Need to compute Dijnd 801 LIBPAW_ALLOCATE(dijnd,(cplex_dij*lmn2_size,ndij)) 802 call pawdijnd(dijnd,cplex_dij,ndij,nucdipmom(:,iatom),pawrad(itypat),pawtab(itypat)) 803 if (dijnd_need) paw_ij(iatom)%dijnd(:,:)=dijnd(:,:) 804 if (dij_need) then 805 paw_ij(iatom)%dij(1:cplex_dij*lmn2_size,:)= & 806 & paw_ij(iatom)%dij(1:cplex_dij*lmn2_size,:) + & 807 & dijnd(1:cplex_dij*lmn2_size,:) 808 end if 809 LIBPAW_DEALLOCATE(dijnd) 810 end if 811 812 end if 813 814 ! ------------------------------------------------------------------------ 815 ! ----------- Add Dij spin-orbit to Dij 816 ! ------------------------------------------------------------------------ 817 818 if ((dijso_need.or.dij_need).and.dijso_available) then 819 820 ! ===== DijSO already computed 821 if (paw_ij(iatom)%has_dijso==2) then 822 if (dij_need) paw_ij(iatom)%dij(:,:)=paw_ij(iatom)%dij(:,:)+paw_ij(iatom)%dijso(:,:) 823 else 824 825 ! ===== Need to compute DijSO 826 LIBPAW_ALLOCATE(dijso,(cplex_dij*qphase*lmn2_size,ndij)) 827 call pawdijso(dijso,cplex_dij,qphase,ndij,nspden,& 828 & pawang,pawrad(itypat),pawtab(itypat),pawxcdev,spnorbscl,& 829 & paw_an(iatom)%vh1,paw_an(iatom)%vxc1) 830 if (dijso_need) paw_ij(iatom)%dijso(:,:)=dijso(:,:) 831 if (dij_need) paw_ij(iatom)%dij(:,:)=paw_ij(iatom)%dij(:,:)+dijso(:,:) 832 LIBPAW_DEALLOCATE(dijso) 833 end if 834 835 end if 836 837 ! ------------------------------------------------------------------------ 838 ! ----------- Add Dij_{DFT+U} to Dij 839 ! ------------------------------------------------------------------------ 840 841 if ((dijU_need.or.dij_need).and.dijU_available) then 842 843 ! ===== DijU already computed 844 if (paw_ij(iatom)%has_dijU==2) then 845 if (dij_need) paw_ij(iatom)%dij(:,:)=paw_ij(iatom)%dij(:,:)+paw_ij(iatom)%dijU(:,:) 846 else 847 848 ! ===== Need to compute DijU 849 LIBPAW_ALLOCATE(dijpawu,(cplex_dij*qphase*lmn2_size,ndij)) 850 if (pawu_algo==PAWU_ALGO_2) then 851 call pawdiju_euijkl(dijpawu,cplex_dij,qphase,ndij,pawrhoij(iatom),pawtab(itypat)) 852 else 853 lpawu=pawtab(itypat)%lpawu 854 LIBPAW_POINTER_ALLOCATE(vpawu,(cplex_dij,lpawu*2+1,lpawu*2+1,ndij)) 855 if (usepawu>=10) vpawu=zero ! if dmft, do not apply U in DFT+U 856 if (usepawu< 10) then 857 call pawpupot(cplex_dij,ndij,paw_ij(iatom)%noccmmp,paw_ij(iatom)%nocctot,& 858 & pawprtvol,pawtab(itypat),vpawu) 859 end if 860 if (natvshift_==0) then 861 call pawdiju(dijpawu,cplex_dij,qphase,ndij,nsppol,pawtab(itypat),vpawu) 862 else 863 call pawdiju(dijpawu,cplex_dij,qphase,ndij,nsppol,pawtab(itypat),vpawu,& 864 & natvshift=natvshift_,atvshift=atvshift(:,:,iatom_tot),& 865 & fatvshift=fatvshift) 866 end if 867 LIBPAW_POINTER_DEALLOCATE(vpawu) 868 end if 869 if (dijU_need) paw_ij(iatom)%dijU(:,:)=dijpawu(:,:) 870 if (dij_need) paw_ij(iatom)%dij(:,:)=paw_ij(iatom)%dij(:,:)+dijpawu(:,:) 871 LIBPAW_DEALLOCATE(dijpawu) 872 end if 873 874 end if 875 876 ! ------------------------------------------------------------------------ 877 ! ----------- Add Dij_{local exact-exchange} to Dij 878 ! ------------------------------------------------------------------------ 879 880 if ((dijexxc_need.or.dij_need).and.dijexxc_available) then 881 882 ! ===== DijEXXC already computed 883 if (paw_ij(iatom)%has_dijexxc==2) then 884 if (dij_need) paw_ij(iatom)%dij(1:cplex_dij*lmn2_size,:)= & 885 & paw_ij(iatom)%dij(1:cplex_dij*lmn2_size,:) & 886 & +paw_ij(iatom)%dijexxc(1:cplex_dij*lmn2_size,:) 887 else 888 889 ! ===== Need to compute DijEXXC 890 LIBPAW_ALLOCATE(dijexxc,(cplex_dij*lmn2_size,ndij)) 891 if (pawxcdev/=0) then 892 if (paw_ij(iatom)%has_exexch_pot/=2) then 893 LIBPAW_POINTER_ALLOCATE(vpawx,(1,lmn2_size,ndij)) 894 call pawxpot(ndij,pawprtvol,pawrhoij(iatom),pawtab(itypat),vpawx) 895 else 896 vpawx=>paw_ij(iatom)%vpawx 897 end if 898 LIBPAW_ALLOCATE(lmselect,(lm_size)) 899 lmselect(:)=paw_an(iatom)%lmselect(:) 900 if (ipositron/=0) lmselect(:)=(lmselect(:).or.electronpositron_lmselect(1:lm_size,iatom)) 901 call pawdijexxc(dijexxc,cplex_dij,qphase,lmselect,ndij,nspden,nsppol,& 902 & pawang,pawrad(itypat),pawtab(itypat),vpawx,paw_an(iatom)%vxc_ex) 903 LIBPAW_DEALLOCATE(lmselect) 904 if (paw_ij(iatom)%has_exexch_pot/=2) then 905 LIBPAW_POINTER_DEALLOCATE(vpawx) 906 end if 907 if (dijexxc_need) paw_ij(iatom)%dijexxc(:,:)=dijexxc(:,:) 908 if (dij_need) paw_ij(iatom)%dij(1:cplex_dij*lmn2_size,:)= & 909 & paw_ij(iatom)%dij(1:cplex_dij*lmn2_size,:) & 910 & +dijexxc(1:cplex_dij*lmn2_size,:) 911 LIBPAW_DEALLOCATE(dijexxc) 912 end if 913 end if 914 915 end if 916 917 ! ------------------------------------------------------------------------ 918 ! ----------- Add Dij background contribution to the total Dij 919 ! ------------------------------------------------------------------------ 920 921 if (dij_need.and.pawtab(itypat)%usepotzero==1 ) then 922 do idij=1,min(nsploop,2) 923 klmn1=1 924 do klmn=1,lmn2_size 925 paw_ij(iatom)%dij(klmn1,idij)=paw_ij(iatom)%dij(klmn1,idij)+pawtab(itypat)%gammaij(klmn)*charge/ucvol 926 klmn1=klmn1+cplex_dij*qphase 927 end do 928 end do 929 end if 930 931 932 ! ------------------------------------------------------------------------ 933 ! ----------- Compute Dijxc_hat 934 ! ------------------------------------------------------------------------ 935 936 if (dijxchat_need) then 937 938 if (usexcnhat/=0) then 939 LIBPAW_ALLOCATE(dijxchat,(cplex_dij*lmn2_size,ndij)) 940 call pawdijhat(dijxchat,cplex_dij,1,gprimd,iatom_tot,& 941 & natom,ndij,nfft,nfftot,nspden,nsppol,pawang,pawfgrtab(iatom),& 942 & pawtab(itypat),vxc,qphon,ucvol,xred,mpi_comm_grid=my_comm_grid) 943 paw_ij(iatom)%dijxc_hat(1:cplex_dij*lmn2_size,:)=dijxchat(1:cplex_dij*lmn2_size,:) 944 LIBPAW_DEALLOCATE(dijxchat) 945 946 else ! usexcnhat=0 947 paw_ij(iatom)%dijxc_hat=zero 948 end if 949 950 end if 951 952 ! ------------------------------------------------------------------------ 953 ! ----------- Compute Dijxc_val 954 ! ------------------------------------------------------------------------ 955 956 if (dijxcval_need) then 957 958 LIBPAW_ALLOCATE(dijxcval,(cplex_dij*lmn2_size,ndij)) 959 ! Note that usexcnhat=0 for this call (no compensation term) 960 if (pawxcdev/=0) then 961 LIBPAW_ALLOCATE(lmselect,(lm_size)) 962 lmselect(:)=paw_an(iatom)%lmselect(:) 963 if (ipositron/=0) lmselect(:)=(lmselect(:).or.electronpositron_lmselect(1:lm_size,iatom)) 964 call pawdijxcm(dijxcval,cplex_dij,1,lmselect,ndij,nspden,nsppol,& 965 & pawang,pawrad(itypat),pawtab(itypat),paw_an(iatom)%vxc1_val,& 966 & paw_an(iatom)%vxct1_val,0) 967 LIBPAW_DEALLOCATE(lmselect) 968 else 969 call pawdijxc(dijxcval,cplex_dij,1,ndij,nspden,nsppol,& 970 & pawang,pawrad(itypat),pawtab(itypat),paw_an(iatom)%vxc1_val,& 971 & paw_an(iatom)%vxct1_val,0,0) 972 end if 973 paw_ij(iatom)%dijxc_val(1:cplex_dij*lmn2_size,:)=dijxcval(1:cplex_dij*lmn2_size,:) 974 LIBPAW_DEALLOCATE(dijxcval) 975 976 end if 977 978 ! ------------------------------------------------------------------------ 979 980 ! Update some flags 981 if (dij_need.and.paw_ij(iatom)%has_dij>=1) paw_ij(iatom)%has_dij=2 982 if (dij0_need.and.paw_ij(iatom)%has_dij0>=1) paw_ij(iatom)%has_dij0=2 983 if (dijfock_need.and.paw_ij(iatom)%has_dijfock>=1) paw_ij(iatom)%has_dijfock=2 984 985 if (dijhartree_need.and.paw_ij(iatom)%has_dijhartree>=1) paw_ij(iatom)%has_dijhartree=2 986 if (dijxc_need.and.paw_ij(iatom)%has_dijxc>=1) paw_ij(iatom)%has_dijxc=2 987 if (dijhat_need.and.paw_ij(iatom)%has_dijhat>=1) paw_ij(iatom)%has_dijhat=2 988 if (dijnd_need.and.paw_ij(iatom)%has_dijnd>=1) paw_ij(iatom)%has_dijnd=2 989 if (dijso_need.and.paw_ij(iatom)%has_dijso>=1) paw_ij(iatom)%has_dijso=2 990 if (dijU_need.and.paw_ij(iatom)%has_dijU>=1) paw_ij(iatom)%has_dijU=2 991 if (dijexxc_need.and.paw_ij(iatom)%has_dijexxc>=1) paw_ij(iatom)%has_dijexxc=2 992 if (dijxchat_need.and.paw_ij(iatom)%has_dijxc_hat>=1) paw_ij(iatom)%has_dijxc_hat=2 993 if (dijxcval_need.and.paw_ij(iatom)%has_dijxc_val>=1) paw_ij(iatom)%has_dijxc_val=2 994 995 !End loop over atoms 996 end do ! iatom 997 998 !------------------------------------------------------------------------ 999 1000 !Final printing 1001 if (paral_atom) then 1002 call paw_ij_print(paw_ij,unit=std_out,pawprtvol=pawprtvol,pawspnorb=pawspnorb,& 1003 & comm_atom=my_comm_atom,mpi_atmtab=my_atmtab,natom=natom,& 1004 & mode_paral='PERS',enunit=enunit,ipert=ipert) 1005 else 1006 call paw_ij_print(paw_ij,unit=std_out,pawprtvol=pawprtvol,pawspnorb=pawspnorb,& 1007 & mode_paral='COLL',enunit=enunit,ipert=ipert) 1008 end if 1009 1010 !Free temporary storage 1011 if (v_dijhat_allocated) then 1012 LIBPAW_POINTER_DEALLOCATE(v_dijhat) 1013 end if 1014 do iatom=1,my_natom 1015 if (paw_ij(iatom)%has_dij0==-1) then 1016 LIBPAW_DEALLOCATE(paw_ij(iatom)%dij0) 1017 paw_ij(iatom)%has_dij0=0 1018 end if 1019 if (paw_ij(iatom)%has_dijfock==-1) then 1020 LIBPAW_DEALLOCATE(paw_ij(iatom)%dijfock) 1021 paw_ij(iatom)%has_dijfock=0 1022 end if 1023 1024 if (paw_ij(iatom)%has_dijhartree==-1) then 1025 LIBPAW_DEALLOCATE(paw_ij(iatom)%dijhartree) 1026 paw_ij(iatom)%has_dijhartree=0 1027 end if 1028 if (paw_ij(iatom)%has_dijxc==-1) then 1029 LIBPAW_DEALLOCATE(paw_ij(iatom)%dijxc) 1030 paw_ij(iatom)%has_dijxc=0 1031 end if 1032 if (paw_ij(iatom)%has_dijhat==-1) then 1033 LIBPAW_DEALLOCATE(paw_ij(iatom)%dijhat) 1034 paw_ij(iatom)%has_dijhat=0 1035 end if 1036 if (paw_ij(iatom)%has_dijfr==-1) then 1037 LIBPAW_DEALLOCATE(paw_ij(iatom)%dijfr) 1038 paw_ij(iatom)%has_dijfr=0 1039 end if 1040 if (paw_ij(iatom)%has_dijso==-1) then 1041 LIBPAW_DEALLOCATE(paw_ij(iatom)%dijso) 1042 paw_ij(iatom)%has_dijso=0 1043 end if 1044 if (paw_ij(iatom)%has_dijU==-1) then 1045 LIBPAW_DEALLOCATE(paw_ij(iatom)%dijU) 1046 paw_ij(iatom)%has_dijU=0 1047 end if 1048 if (paw_ij(iatom)%has_dijexxc==-1) then 1049 LIBPAW_DEALLOCATE(paw_ij(iatom)%dijexxc) 1050 paw_ij(iatom)%has_dijexxc=0 1051 end if 1052 if (paw_ij(iatom)%has_dijxc_hat==-1) then 1053 LIBPAW_DEALLOCATE(paw_ij(iatom)%dijxc_hat) 1054 paw_ij(iatom)%has_dijxc_hat=0 1055 end if 1056 if (paw_ij(iatom)%has_dijxc_val==-1) then 1057 LIBPAW_DEALLOCATE(paw_ij(iatom)%dijxc_val) 1058 paw_ij(iatom)%has_dijxc_val=0 1059 end if 1060 end do 1061 1062 !Destroy atom table used for parallelism 1063 call free_my_atmtab(my_atmtab,my_atmtab_allocated) 1064 1065 end subroutine pawdij
m_pawdij/pawdij_gather [ Functions ]
[ Top ] [ m_pawdij ] [ Functions ]
NAME
pawdij_gather
FUNCTION
Performs a ALLGATHER operation (over atomic sites) on Dij data stored as a 1D array of Dij arrays.
INPUTS
dij_in = coeff2d_type array containing the input Dij comm_atom= MPI communicator over atoms mpi_atmtab(:)=indexes of the atoms treated by current proc
OUTPUT
dij_out = coeff2d_type array containing the gathered Dij
SOURCE
5473 subroutine pawdij_gather(dij_in,dij_out,comm_atom,mpi_atmtab) 5474 5475 !Arguments ------------------------------------ 5476 !scalars 5477 integer,intent(in) :: comm_atom 5478 !arrays 5479 integer,intent(in) :: mpi_atmtab(:) 5480 type(coeff2_type),intent(in) :: dij_in(:) 5481 type(coeff2_type),intent(out) :: dij_out(:) 5482 5483 !Local variables------------------------------- 5484 !scalars 5485 integer :: buf_dp_size,buf_dp_size_all,buf_int_size,buf_int_size_all 5486 integer :: dij_size,dij_size_out,ierr,ii,i2,indx_dp,indx_int,ival,n1,n2,nproc 5487 !arrays 5488 integer :: bufsz(2) 5489 integer, allocatable :: buf_int(:),buf_int_all(:) 5490 integer, allocatable :: count_dp(:),count_int(:),count_tot(:),displ_dp(:),displ_int(:) 5491 integer, allocatable :: dimdij(:,:) 5492 real(dp),allocatable :: buf_dp(:),buf_dp_all(:) 5493 5494 ! ************************************************************************* 5495 5496 nproc=xmpi_comm_size(comm_atom) 5497 dij_size=size(dij_in,dim=1) 5498 5499 buf_dp_size=0 5500 LIBPAW_ALLOCATE(dimdij,(dij_size,2)) 5501 do ii=1,dij_size 5502 dimdij(ii,1)=size(dij_in(ii)%value,dim=1) 5503 dimdij(ii,2)=size(dij_in(ii)%value,dim=2) 5504 buf_dp_size=buf_dp_size+dimdij(ii,1)*dimdij(ii,2) 5505 end do 5506 5507 !If only one proc, perform a single copy 5508 if (nproc==1) then 5509 do ii=1,dij_size 5510 ival=mpi_atmtab(ii) 5511 if (allocated(dij_out(ival)%value)) then 5512 LIBPAW_DEALLOCATE(dij_out(ival)%value) 5513 end if 5514 LIBPAW_ALLOCATE(dij_out(ival)%value,(n1,n2)) 5515 dij_out(ii)%value=dij_in(ival)%value 5516 end do 5517 LIBPAW_DEALLOCATE(dimdij) 5518 return 5519 end if 5520 5521 !Fill in integer buffer 5522 buf_int_size=3*dij_size 5523 LIBPAW_ALLOCATE(buf_int,(buf_int_size)) 5524 indx_int=1 5525 do ii=1,dij_size 5526 buf_int(indx_int )=dimdij(ii,1) 5527 buf_int(indx_int+1)=dimdij(ii,2) 5528 buf_int(indx_int+2)=mpi_atmtab(ii) 5529 indx_int=indx_int+3 5530 end do 5531 5532 !Fill in real buffer 5533 LIBPAW_ALLOCATE(buf_dp,(buf_dp_size)) 5534 indx_dp=1 5535 do ii=1,dij_size 5536 n1=dimdij(ii,1); n2=dimdij(ii,2) 5537 do i2=1,n2 5538 buf_dp(indx_dp:indx_dp+n1-1)=dij_in(ii)%value(1:n1,i2) 5539 indx_dp=indx_dp+n1 5540 end do 5541 end do 5542 5543 !Communicate (1 gather for integers, 1 gather for reals) 5544 LIBPAW_ALLOCATE(count_int,(nproc)) 5545 LIBPAW_ALLOCATE(displ_int,(nproc)) 5546 LIBPAW_ALLOCATE(count_dp ,(nproc)) 5547 LIBPAW_ALLOCATE(displ_dp ,(nproc)) 5548 LIBPAW_ALLOCATE(count_tot,(2*nproc)) 5549 bufsz(1)=buf_int_size; bufsz(2)=buf_dp_size 5550 call xmpi_allgather(bufsz,2,count_tot,comm_atom,ierr) 5551 do ii=1,nproc 5552 count_int(ii)=count_tot(2*ii-1) 5553 count_dp (ii)=count_tot(2*ii) 5554 end do 5555 displ_int(1)=0;displ_dp(1)=0 5556 do ii=2,nproc 5557 displ_int(ii)=displ_int(ii-1)+count_int(ii-1) 5558 displ_dp (ii)=displ_dp (ii-1)+count_dp (ii-1) 5559 end do 5560 buf_int_size_all=sum(count_int) 5561 buf_dp_size_all =sum(count_dp) 5562 LIBPAW_DEALLOCATE(count_tot) 5563 LIBPAW_ALLOCATE(buf_int_all,(buf_int_size_all)) 5564 LIBPAW_ALLOCATE(buf_dp_all ,(buf_dp_size_all)) 5565 call xmpi_allgatherv(buf_int,buf_int_size,buf_int_all,count_int,displ_int,comm_atom,ierr) 5566 call xmpi_allgatherv(buf_dp ,buf_dp_size ,buf_dp_all ,count_dp ,displ_dp ,comm_atom,ierr) 5567 LIBPAW_DEALLOCATE(count_int) 5568 LIBPAW_DEALLOCATE(displ_int) 5569 LIBPAW_DEALLOCATE(count_dp) 5570 LIBPAW_DEALLOCATE(displ_dp) 5571 5572 !Retrieve gathered data 5573 dij_size_out=buf_int_size_all/3 5574 indx_int=1;indx_dp=1 5575 do ii=1,dij_size_out 5576 n1=buf_int_all(indx_int) 5577 n2=buf_int_all(indx_int+1) 5578 ival=buf_int_all(indx_int+2) 5579 indx_int=indx_int+3 5580 if (allocated(dij_out(ival)%value)) then 5581 LIBPAW_DEALLOCATE(dij_out(ival)%value) 5582 end if 5583 LIBPAW_ALLOCATE(dij_out(ival)%value,(n1,n2)) 5584 do i2=1,n2 5585 dij_out(ival)%value(1:n1,i2)=buf_dp_all(indx_dp:indx_dp+n1-1) 5586 indx_dp=indx_dp+n1 5587 end do 5588 end do 5589 5590 LIBPAW_DEALLOCATE(buf_dp_all) 5591 LIBPAW_DEALLOCATE(buf_int_all) 5592 LIBPAW_DEALLOCATE(buf_int) 5593 LIBPAW_DEALLOCATE(buf_dp) 5594 LIBPAW_DEALLOCATE(dimdij) 5595 5596 end subroutine pawdij_gather
m_pawdij/pawdij_print_ij [ Functions ]
[ Top ] [ m_pawdij ] [ Functions ]
NAME
pawdij_print_dij
FUNCTION
Print out the content of a Dij matrix (total Dij) in a suitable format
INPUTS
dij(cplex_dij*qphase*lmn2_size,ndij)= input matrix to be printed cplex_dij=1 if Dij is real, 2 if Dij is complex qphase=1 if Dij contains no RF phase, 2 if it contains a exp(-iqr) RF phase iatom=current atom natom=total number of atoms in the system nspden=number of spin density components [Ha_or_eV]= 1: output in hartrees, 2: output in eV [opt_prtvol]= >=0 if up to 12 components of _ij matrix have to be printed <0 if all components of ij_ matrix have to be printed (optional) [mode_paral]= parallel printing mode (optional, default='COLL') [test_value]=(real number) if positive, print a warning when the magnitude of Dij is greater (optional) [title_msg]=message to print as title (optional) [unit]=the unit number for output (optional)
OUTPUT
(Only writing)
SOURCE
5628 subroutine pawdij_print_dij(dij,cplex_dij,qphase,iatom,natom,nspden,& 5629 & test_value,title_msg,unit,Ha_or_eV,opt_prtvol,mode_paral) ! Optional arguments 5630 5631 !Arguments ------------------------------------ 5632 !scalars 5633 integer,intent(in) :: cplex_dij,iatom,natom,nspden,qphase 5634 integer,optional,intent(in) :: Ha_or_eV,opt_prtvol,unit 5635 real(dp),intent(in),optional :: test_value 5636 character(len=4),optional,intent(in) :: mode_paral 5637 character(len=100),optional,intent(in) :: title_msg 5638 !arrays 5639 real(dp),intent(in),target :: dij(:,:) 5640 5641 !Local variables------------------------------- 5642 character(len=7),parameter :: dspin(6)=(/"up ","down ","up-up ","dwn-dwn","up-dwn ","dwn-up "/) 5643 integer :: idij,idij_sym,kk,lmn_size,lmn2_size,my_idij,my_idij_sym 5644 integer :: my_prtvol,my_unt,my_Ha_or_eV,ndij,tmp_cplex_dij 5645 real(dp) :: my_test_value,test_value_eff 5646 character(len=4) :: my_mode 5647 character(len=2000) :: msg 5648 !arrays 5649 integer :: idum(0) 5650 real(dp),allocatable,target :: dij1(:),dij2(:) 5651 real(dp),pointer :: dij2p(:),dij2p_(:) 5652 5653 ! ************************************************************************* 5654 5655 !Optional arguments 5656 my_unt =std_out ; if (PRESENT(unit )) my_unt =unit 5657 my_mode ='COLL' ; if (PRESENT(mode_paral)) my_mode =mode_paral 5658 my_prtvol=1 ; if (PRESENT(opt_prtvol)) my_prtvol=opt_prtvol 5659 my_test_value=-one; if (PRESENT(test_value)) my_test_value=test_value 5660 my_Ha_or_eV=1 ; if (PRESENT(Ha_or_eV)) my_Ha_or_eV=Ha_or_eV 5661 5662 !Title 5663 if (present(title_msg)) then 5664 if (trim(title_msg)/='') then 5665 write(msg, '(2a)') ch10,trim(title_msg) 5666 call wrtout(my_unt,msg,my_mode) 5667 end if 5668 end if 5669 5670 !Inits 5671 ndij=size(dij,2) 5672 lmn2_size=size(dij,1)/(cplex_dij*qphase) 5673 lmn_size=int(dsqrt(two*dble(lmn2_size))) 5674 if (qphase==2) then 5675 LIBPAW_ALLOCATE(dij1,(2*lmn2_size)) 5676 LIBPAW_ALLOCATE(dij2,(2*lmn2_size)) 5677 end if 5678 5679 ! === Loop over Dij components === 5680 do idij=1,ndij 5681 5682 idij_sym=idij;if (ndij==4.and.idij>2) idij_sym=7-idij 5683 5684 !Subtitle 5685 if (natom>1.or.nspden>1.or.ndij==4) then 5686 if (nspden==1.and.ndij/=4) write(msg,'(a,i3)') ' Atom #',iatom 5687 if (nspden==2) write(msg,'(a,i3,a,i1)')' Atom #',iatom,' - Spin component ',idij 5688 if (ndij==4) write(msg,'(a,i3,2a)') ' Atom #',iatom,' - Component ',trim(dspin(idij+2*(ndij/4))) 5689 call wrtout(my_unt,msg,my_mode) 5690 end if 5691 5692 !Select upper and lower triangular parts 5693 my_idij=min(size(dij,2),idij) 5694 my_idij_sym=min(size(dij,2),idij_sym) 5695 if (qphase==1) then 5696 tmp_cplex_dij=cplex_dij 5697 dij2p => dij(1:cplex_dij*lmn2_size:1,my_idij) 5698 dij2p_ => dij(1:cplex_dij*lmn2_size:1,my_idij_sym) 5699 else 5700 tmp_cplex_dij=2 5701 if (cplex_dij==1) then 5702 do kk=1,lmn2_size 5703 dij1(2*kk-1)= dij(kk,my_idij) 5704 dij1(2*kk )= dij(kk+lmn2_size,my_idij) 5705 dij2(2*kk-1)= dij(kk,my_idij_sym) 5706 dij2(2*kk )=-dij(kk+lmn2_size,my_idij_sym) 5707 end do 5708 else 5709 do kk=1,lmn2_size 5710 dij1(2*kk-1)= dij(2*kk-1,my_idij)-dij(2*kk +2*lmn2_size,my_idij) 5711 dij1(2*kk )= dij(2*kk ,my_idij)+dij(2*kk-1+2*lmn2_size,my_idij) 5712 dij2(2*kk-1)= dij(2*kk-1,my_idij_sym)+dij(2*kk +2*lmn2_size,my_idij_sym) 5713 dij2(2*kk )= dij(2*kk ,my_idij_sym)-dij(2*kk-1+2*lmn2_size,my_idij_sym) 5714 end do 5715 end if 5716 dij2p => dij1 ; dij2p_ => dij2 5717 end if 5718 5719 !Printing 5720 test_value_eff=-one;if(my_test_value>zero.and.idij==1) test_value_eff=my_test_value 5721 call pawio_print_ij(my_unt,dij2p,lmn2_size,tmp_cplex_dij,lmn_size,-1,idum,0,& 5722 & my_prtvol,idum,test_value_eff,my_Ha_or_eV,& 5723 & opt_sym=2,asym_ij=dij2p_,mode_paral=my_mode) 5724 5725 end do !idij 5726 5727 if (qphase==2) then 5728 LIBPAW_DEALLOCATE(dij1) 5729 LIBPAW_DEALLOCATE(dij2) 5730 end if 5731 5732 end subroutine pawdij_print_dij
m_pawdij/pawdijexxc [ Functions ]
[ Top ] [ m_pawdij ] [ Functions ]
NAME
pawdijexxc
FUNCTION
Compute the local Exact-Exchange contribution to the PAW pseudopotential strength Dij, using a potential expressed as (l,m) spherical moments (for one atom only; only for correlated electrons): D_ij^EXXC= < Phi_i|alpha*(VFock(correlated)-Vxc(n1_correlated)|Phi_j>
INPUTS
cplex_dij=2 if dij is COMPLEX (as in the spin-orbit case), 1 if dij is REAL qphase=2 if dij contains a exp(-i.q.r) phase (as in the q<>0 RF case), 1 if not lmselect(lm_size)=select the non-zero LM-moments of on-site potentials ndij= number of spin components nsppol=number of independent spin WF components pawang <type(pawang_type)>=paw angular mesh and related data pawrad <type(pawrad_type)>=paw radial mesh and related data, for current atom pawtab <type(pawtab_type)>=paw tabulated starting data, for current atom vpawx(1,lmn2_size,ndij)=moments of exact exchange potential for current atom and for correlated electrons vxc_ex(qphase*mesh_size,lm_size,nspden)=all-electron on-site XC potential for current atom taken into account only valence correlated electrons
OUTPUT
dijexxc(cplex_dij*lmn2_size,ndij)= D_ij^Exact-Exchange terms
When Dij is complex (cplex_dij=2):
dij(2*i-1,:) contains the real part, dij(2*i,:) contains the imaginary part
When a exp(-i.q.r) phase is included (qphase=2):
dij(1:cplex_dij*lmn2_size,:)
contains the real part of the phase, i.e. D_ij*cos(q.r)
dij(cplex_dij*lmn2_size+1:2*cplex_dij*lmn2_size,:)
contains the imaginary part of the phase, i.e. D_ij*sin(q.r)
SOURCE
3185 subroutine pawdijexxc(dijexxc,cplex_dij,qphase,lmselect,ndij,nspden,nsppol,& 3186 & pawang,pawrad,pawtab,vpawx,vxc_ex) 3187 3188 !Arguments --------------------------------------------- 3189 !scalars 3190 integer,intent(in) :: cplex_dij,ndij,nspden,nsppol,qphase 3191 type(pawang_type),intent(in) :: pawang 3192 !arrays 3193 logical :: lmselect(:) 3194 real(dp),intent(in) :: vpawx(:,:,:),vxc_ex(:,:,:) 3195 real(dp),intent(out) :: dijexxc(:,:) 3196 type(pawrad_type),intent(in) :: pawrad 3197 type(pawtab_type),intent(in) :: pawtab 3198 3199 !Local variables --------------------------------------- 3200 !scalars 3201 integer :: icount,idij,idijend,ij_size,iln,in1,in2,ir,ir1,isel,ispden,ivxc 3202 integer :: jln,j0ln,klm,klm1,klmn,klmn1,klmn2,kln,lexexch,ln_min,ln_max,lmax,lmin 3203 integer :: lm_size,lmn2_size,mesh_size,nsploop 3204 character(len=500) :: msg 3205 !arrays 3206 real(dp),allocatable :: dijexxc_idij(:),ff(:),gg(:),vxcij1(:) 3207 3208 ! ************************************************************************* 3209 3210 !Useful data 3211 lm_size=pawtab%lcut_size**2 3212 lmn2_size=pawtab%lmn2_size 3213 ij_size=pawtab%ij_size 3214 mesh_size=pawtab%mesh_size 3215 lexexch=pawtab%lexexch 3216 ln_min=pawtab%lnproju(1) 3217 ln_max=pawtab%lnproju(pawtab%nproju) 3218 3219 !Check data consistency 3220 if (qphase==2) then 3221 msg='pawdijexx not available for qphase=2!' 3222 LIBPAW_BUG(msg) 3223 end if 3224 if (size(dijexxc,1)/=cplex_dij*qphase*lmn2_size.or.size(dijexxc,2)/=ndij) then 3225 msg='invalid sizes for dijexxc!' 3226 LIBPAW_BUG(msg) 3227 end if 3228 if (size(lmselect)/=lm_size) then 3229 msg='invalid size for lmselect!' 3230 LIBPAW_BUG(msg) 3231 end if 3232 if (size(vxc_ex,1)/=qphase*mesh_size.or.size(vxc_ex,2)/=lm_size.or.& 3233 & size(vxc_ex,3)/=nspden) then 3234 msg='invalid sizes for vxc_ex!' 3235 LIBPAW_BUG(msg) 3236 end if 3237 if (size(vpawx,1)/=1.or.size(vpawx,2)/=lmn2_size.or.& 3238 & size(vpawx,3)/=ndij) then 3239 msg='invalid sizes for vpawx!' 3240 LIBPAW_BUG(msg) 3241 end if 3242 3243 !Init memory 3244 dijexxc=zero 3245 LIBPAW_ALLOCATE(dijexxc_idij,(qphase*lmn2_size)) 3246 LIBPAW_ALLOCATE(vxcij1,(qphase*ij_size)) 3247 LIBPAW_ALLOCATE(ff,(mesh_size)) 3248 LIBPAW_ALLOCATE(gg,(mesh_size)) 3249 3250 !---------------------------------------------------------- 3251 !Loop over spin components 3252 !---------------------------------------------------------- 3253 nsploop=nsppol;if (ndij==4) nsploop=4 3254 do idij=1,nsploop 3255 3256 if (idij<=nsppol.or.(ndij==4.and.idij<=3)) then 3257 3258 idijend=idij+idij/3 3259 do ispden=idij,idijend 3260 3261 dijexxc_idij=zero 3262 3263 ivxc=ispden 3264 !Take into account nspden=1/nspinor=2 case 3265 if (ndij/=nspden.and.ispden==2) ivxc=1 3266 if (ndij/=nspden.and.ispden> 2) cycle 3267 3268 ! ---------------------------------------------------------- 3269 ! Summing over (l,m) moments 3270 ! ---------------------------------------------------------- 3271 do klm=1,lm_size 3272 if (lmselect(klm)) then 3273 3274 ! ===== Vxc_ij_1 (tmp) ===== 3275 vxcij1=zero 3276 if (qphase==1) then 3277 do jln=ln_min,ln_max 3278 j0ln=jln*(jln-1)/2 3279 do iln=ln_min,jln 3280 kln=j0ln+iln 3281 ff(1:mesh_size)= & 3282 & vxc_ex(1:mesh_size,klm,ivxc)*pawtab%phiphj(1:mesh_size,kln) 3283 call simp_gen(vxcij1(kln),ff,pawrad) 3284 end do 3285 end do 3286 else 3287 do jln=ln_min,ln_max 3288 j0ln=jln*(jln-1)/2 3289 do iln=ln_min,jln 3290 kln=j0ln+iln 3291 do ir=1,mesh_size 3292 ir1=2*ir 3293 ff(ir)= & 3294 & vxc_ex(ir1-1,klm,ivxc)*pawtab%phiphj(ir,kln) 3295 gg(ir)= & 3296 & vxc_ex(ir1,klm,ivxc)*pawtab%phiphj(ir,kln) 3297 end do 3298 call simp_gen(vxcij1(2*kln-1),ff,pawrad) 3299 call simp_gen(vxcij1(2*kln ),gg,pawrad) 3300 end do 3301 end do 3302 end if 3303 3304 ! ===== Accumulate Vxc_ij_1 over klm moments ===== 3305 if (qphase==1) then 3306 do klmn=1,lmn2_size 3307 lmin=pawtab%indklmn(3,klmn) 3308 lmax=pawtab%indklmn(4,klmn) 3309 if (lmin==0.and.lmax==2*lexexch) then 3310 klm1=pawtab%indklmn(1,klmn) 3311 kln=pawtab%indklmn(2,klmn) 3312 isel=pawang%gntselect(klm,klm1) 3313 if (isel>0) dijexxc_idij(klmn)=dijexxc_idij(klmn) & 3314 & +vxcij1(kln)*pawang%realgnt(isel) 3315 end if 3316 end do ! Loop klmn 3317 else ! qphase==2 3318 klmn1=1 3319 do klmn=1,lmn2_size 3320 lmin=pawtab%indklmn(3,klmn) 3321 lmax=pawtab%indklmn(4,klmn) 3322 if (lmin==0.and.lmax==2*lexexch) then 3323 klm1=pawtab%indklmn(1,klmn) 3324 kln=pawtab%indklmn(2,klmn) 3325 isel=pawang%gntselect(klm,klm1) 3326 if (isel>0) then 3327 dijexxc_idij(klmn1 )=dijexxc_idij(klmn1) & 3328 & +vxcij1(2*kln-1)*pawang%realgnt(isel) 3329 dijexxc_idij(klmn1+1)=dijexxc_idij(klmn1+1) & 3330 & +vxcij1(2*kln )*pawang%realgnt(isel) 3331 end if 3332 end if 3333 klmn1=klmn1+qphase 3334 end do ! Loop klmn 3335 end if 3336 3337 end if ! lmselect 3338 end do ! Loop klm 3339 3340 ! Mix Hartree and GGA terms 3341 if (qphase==1) then 3342 do klmn=1,lmn2_size 3343 lmin=pawtab%indklmn(3,klmn) 3344 lmax=pawtab%indklmn(4,klmn) 3345 if (lmin==0.and.lmax==2*lexexch) then 3346 in1=pawtab%klmntomn(3,klmn) 3347 in2=pawtab%klmntomn(4,klmn) 3348 icount=in1+(in2*(in2-1))/2 3349 if(pawtab%ij_proj<icount) then 3350 msg='PAW local exact-exchange: Problem while computing dijexxc !' 3351 LIBPAW_BUG(msg) 3352 end if 3353 dijexxc_idij(klmn)=pawtab%exchmix & 3354 & *(vpawx(1,klmn,idij)-dijexxc_idij(klmn)) 3355 end if 3356 end do 3357 else ! qphase=2 3358 klmn1=1 3359 do klmn=1,lmn2_size 3360 lmin=pawtab%indklmn(3,klmn) 3361 lmax=pawtab%indklmn(4,klmn) 3362 if (lmin==0.and.lmax==2*lexexch) then 3363 in1=pawtab%klmntomn(3,klmn) 3364 in2=pawtab%klmntomn(4,klmn) 3365 icount=in1+(in2*(in2-1))/2 3366 if(pawtab%ij_proj<icount) then 3367 msg='PAW local exact-exchange: Problem while computing dijexxc !' 3368 LIBPAW_BUG(msg) 3369 end if 3370 dijexxc_idij(klmn1) =pawtab%exchmix & 3371 & *(vpawx(1,klmn,idij)-dijexxc_idij(klmn1)) 3372 dijexxc_idij(klmn1+1)=pawtab%exchmix & 3373 & *(vpawx(1,klmn,idij)-dijexxc_idij(klmn1+1)) 3374 end if 3375 klmn1=klmn1+qphase 3376 end do ! Loop klmn 3377 end if 3378 3379 ! ---------------------------------------------------------- 3380 ! Deduce some part of Dij according to symmetries 3381 ! ---------------------------------------------------------- 3382 3383 !if ispden=1 => real part of D^11_ij 3384 !if ispden=2 => real part of D^22_ij 3385 !if ispden=3 => real part of D^12_ij 3386 !if ispden=4 => imaginary part of D^12_ij 3387 klmn1=max(1,ispden-2);klmn2=1 3388 do klmn=1,lmn2_size 3389 dijexxc(klmn1,idij)=dijexxc_idij(klmn2) 3390 klmn1=klmn1+cplex_dij 3391 klmn2=klmn2+qphase 3392 end do 3393 if (qphase==2) then 3394 !Same storage with exp^(-i.q.r) phase 3395 klmn1=max(1,ispden-2)+lmn2_size*cplex_dij;klmn2=2 3396 do klmn=1,lmn2_size 3397 dijexxc(klmn1,idij)=dijexxc_idij(klmn2) 3398 klmn1=klmn1+cplex_dij 3399 klmn2=klmn2+qphase 3400 end do 3401 endif 3402 3403 end do !ispden 3404 3405 !Non-collinear: D_ij(:,4)=D^21_ij=D^12_ij^* 3406 else if (nspden==4.and.idij==4) then 3407 dijexxc(:,idij)=dijexxc(:,idij-1) 3408 if (cplex_dij==2) then 3409 do klmn=2,lmn2_size*cplex_dij,cplex_dij 3410 dijexxc(klmn,idij)=-dijexxc(klmn,idij) 3411 end do 3412 if (qphase==2) then 3413 do klmn=2+lmn2_size*cplex_dij,2*lmn2_size*cplex_dij,cplex_dij 3414 dijexxc(klmn,idij)=-dijexxc(klmn,idij) 3415 end do 3416 end if 3417 end if 3418 3419 !Antiferro: D_ij(:,2)=D^down_ij=D^up_ij 3420 else if (nsppol==1.and.idij==2) then 3421 dijexxc(:,idij)=dijexxc(:,idij-1) 3422 end if 3423 3424 !---------------------------------------------------------- 3425 !End loop on spin density components 3426 end do 3427 3428 !Free temporary memory spaces 3429 LIBPAW_DEALLOCATE(dijexxc_idij) 3430 LIBPAW_DEALLOCATE(vxcij1) 3431 LIBPAW_DEALLOCATE(ff) 3432 LIBPAW_DEALLOCATE(gg) 3433 3434 end subroutine pawdijexxc
m_pawdij/pawdijfock [ Functions ]
[ Top ] [ m_pawdij ] [ Functions ]
NAME
pawdijfock
FUNCTION
Compute Fock exact-exchange contribution(s) to the PAW pseudopotential strength Dij (for one atom only)
INPUTS
hyb_mixing=hybrid mixing coefficient for the Fock contribution hyb_mixing_sr=hybrid mixing coefficient for the short-range Fock contribution qphase=2 if dij contains a exp(-i.q.r) phase (as in the q<>0 RF case), 1 if not ndij= number of spin components dor Fdij pawrhoij <type(pawrhoij_type)>= paw rhoij occupancies (and related data) for current atom pawtab <type(pawtab_type)>=paw tabulated starting data, for current atom
OUTPUT
dijfock_vv(qphase*lmn2_size,ndij)= D_ij^fock terms for valence-valence interactions
dijfock_cv(qphase*lmn2_size,ndij)= D_ij^fock terms for core-valence interactions
When a exp(-i.q.r) phase is included (qphase=2):
dij(1:lmn2_size,:)
contains the real part of the phase, i.e. D_ij*cos(q.r)
dij(lmn2_size+1:2*lmn2_size,:)
contains the imaginary part of the phase, i.e. D_ij*sin(q.r)
NOTES:
WARNING: What follows has been tested only for cases where nsppol=1 and 2, nspden=1 and 2 with nspinor=1.
SOURCE
1202 subroutine pawdijfock(dijfock_vv,dijfock_cv,cplex_dij,qphase,hyb_mixing,hyb_mixing_sr,ndij,pawrhoij,pawtab) 1203 1204 !Arguments --------------------------------------------- 1205 !scalars 1206 integer,intent(in) :: cplex_dij,ndij,qphase 1207 real(dp),intent(in) :: hyb_mixing,hyb_mixing_sr 1208 !arrays 1209 real(dp),intent(out) :: dijfock_vv(:,:),dijfock_cv(:,:) 1210 type(pawrhoij_type),intent(in) :: pawrhoij 1211 type(pawtab_type),intent(in),target :: pawtab 1212 1213 !Local variables --------------------------------------- 1214 !scalars 1215 integer :: cplex_rhoij,iq,iq0_dij,iq0_rhoij,ispden,irhokl,jrhokl,ilmn_i,jlmn_j,ilmn_k,jlmn_l 1216 integer :: klmn_kl,klmn_ij,klmn_il,klmn_kj,klmn1,nsp,lmn2_size 1217 real(dp) :: ro,dij_up,dij_dn,dij_updn_r,dij_updn_i 1218 character(len=500) :: msg 1219 !arrays 1220 real(dp),allocatable :: dijfock_vv_tmp(:,:) 1221 real(dp),pointer :: eijkl(:,:) 1222 1223 ! ************************************************************************* 1224 1225 !Useful data 1226 lmn2_size=pawtab%lmn2_size 1227 cplex_rhoij=pawrhoij%cplex_rhoij 1228 1229 !Check data consistency 1230 if (size(dijfock_vv,1)/=qphase*cplex_dij*lmn2_size.or.size(dijfock_vv,2)/=ndij) then 1231 msg='invalid sizes for Dijfock_vv!' 1232 LIBPAW_BUG(msg) 1233 end if 1234 if (size(dijfock_cv,1)/=qphase*cplex_dij*lmn2_size.or.size(dijfock_cv,2)/=ndij) then 1235 msg='invalid sizes for Dijfock_cv!' 1236 LIBPAW_BUG(msg) 1237 end if 1238 if (pawrhoij%qphase<qphase) then 1239 msg='pawrhoij%qphase must be >=qphase!' 1240 LIBPAW_BUG(msg) 1241 end if 1242 if (ndij==4.and.cplex_dij==1) then 1243 msg='When ndij=4, cplex_dij must be =2!' 1244 LIBPAW_BUG(msg) 1245 end if 1246 1247 if (abs(hyb_mixing)>tol8 .and. abs(hyb_mixing_sr)>tol8) then 1248 msg='invalid hybrid functional' 1249 LIBPAW_BUG(msg) 1250 else 1251 if (abs(hyb_mixing)>tol8) then 1252 eijkl => pawtab%eijkl 1253 else if (abs(hyb_mixing_sr)>tol8) then 1254 eijkl => pawtab%eijkl_sr 1255 end if 1256 end if 1257 1258 !Init memory 1259 dijfock_vv=zero ; dijfock_cv=zero 1260 1261 ! ===== Valence-valence contribution ===== 1262 1263 nsp=pawrhoij%nsppol;if (pawrhoij%nspden==4) nsp=4 1264 LIBPAW_ALLOCATE(dijfock_vv_tmp,(lmn2_size,nsp)) 1265 dijfock_vv_tmp=zero 1266 1267 !Loop over phase exp(iqr) phase real/imaginary part 1268 do iq=1,qphase 1269 !First loop: we store the real part in dij(1 -> lmn2_size) 1270 !2nd loop: we store the imaginary part in dij(lmn2_size+1 -> 2*lmn2_size) 1271 iq0_dij=merge(0,lmn2_size,iq==1) ; iq0_rhoij=cplex_rhoij*iq0_dij 1272 1273 !Loop over spin components 1274 do ispden=1,nsp 1275 1276 !Loop on the non-zero elements rho_kl 1277 jrhokl=iq0_rhoij+1 1278 do irhokl=1,pawrhoij%nrhoijsel 1279 klmn_kl=pawrhoij%rhoijselect(irhokl) 1280 ilmn_k=pawtab%indklmn(7,klmn_kl) 1281 jlmn_l=pawtab%indklmn(8,klmn_kl) 1282 1283 ro=pawrhoij%rhoijp(jrhokl,ispden)*pawtab%dltij(klmn_kl) 1284 1285 !Contribution to the element (k,l) of dijfock 1286 dijfock_vv_tmp(klmn_kl,ispden)=dijfock_vv_tmp(klmn_kl,ispden)-ro*eijkl(klmn_kl,klmn_kl) 1287 1288 !Contribution to the element (i,j) of dijfock with (i,j) < (k,l) 1289 ! We remind that i<j and k<l by construction 1290 do klmn_ij=1,klmn_kl-1 1291 ilmn_i=pawtab%indklmn(7,klmn_ij) 1292 jlmn_j=pawtab%indklmn(8,klmn_ij) 1293 !In this case, i < l 1294 klmn_il=jlmn_l*(jlmn_l-1)/2+ilmn_i 1295 !For (k,j), we compute index of (k,j) or index of (j,k) 1296 if (ilmn_k>jlmn_j) then 1297 klmn_kj=ilmn_k*(ilmn_k-1)/2+jlmn_j 1298 else 1299 klmn_kj=jlmn_j*(jlmn_j-1)/2+ilmn_k 1300 end if 1301 dijfock_vv_tmp(klmn_ij,ispden)=dijfock_vv_tmp(klmn_ij,ispden)-ro*eijkl(klmn_il,klmn_kj) 1302 end do 1303 1304 !Contribution to the element (i,j) of dijfock with (i,j) > (k,l) 1305 ! We remind that i<j and k<l by construction 1306 do klmn_ij=klmn_kl+1,lmn2_size 1307 ilmn_i=pawtab%indklmn(7,klmn_ij) 1308 jlmn_j=pawtab%indklmn(8,klmn_ij) 1309 !In this case, k < j 1310 klmn_kj=jlmn_j*(jlmn_j-1)/2+ilmn_k 1311 !For (i,l), we compute index of (i,l) or index of (l,i) 1312 if (ilmn_i>jlmn_l) then 1313 klmn_il=ilmn_i*(ilmn_i-1)/2+jlmn_l 1314 else 1315 klmn_il=jlmn_l*(jlmn_l-1)/2+ilmn_i 1316 end if 1317 dijfock_vv_tmp(klmn_ij,ispden)=dijfock_vv_tmp(klmn_ij,ispden)-ro*eijkl(klmn_kj,klmn_il) 1318 end do 1319 1320 jrhokl=jrhokl+cplex_rhoij 1321 end do !End loop over rhoij 1322 1323 end do !ispden 1324 1325 ! Regular case: copy spin component into Dij 1326 if (ndij/=4.or.nsp/=4) then 1327 do ispden=1,nsp 1328 klmn1=iq0_dij+1 1329 do klmn_ij=1,lmn2_size 1330 dijfock_vv(klmn1,ispden)=dijfock_vv_tmp(klmn_ij,ispden) 1331 klmn1=klmn1+cplex_dij 1332 end do 1333 end do 1334 ! Antiferro case: copy up component into down one 1335 if (ndij==2.and.nsp==1) then 1336 klmn1=iq0_dij+1 1337 do klmn_ij=1,lmn2_size 1338 dijfock_vv(klmn1,2)=dijfock_vv_tmp(klmn_ij,1) 1339 klmn1=klmn1+cplex_dij 1340 end do 1341 end if 1342 else 1343 !Non-collinear: from (rhoij,m_ij) to rhoij^(alpha,beta) 1344 !rhoij= (rhoij^11+rhoij^22) 1345 !mij_x= (rhoij^12+rhoij^21) 1346 !mij_y=i.(rhoij^12+rhoij^21) 1347 !mij_z= (rhoij^11-rhoij^22) 1348 klmn1=iq0_dij+1 1349 do klmn_ij=1,lmn2_size 1350 dij_up=half*(dijfock_vv_tmp(klmn_ij,1)+dijfock_vv_tmp(klmn_ij,4)) 1351 dij_dn=half*(dijfock_vv_tmp(klmn_ij,1)-dijfock_vv_tmp(klmn_ij,4)) 1352 dij_updn_r= half*dijfock_vv_tmp(klmn_ij,2) 1353 dij_updn_i=-half*dijfock_vv_tmp(klmn_ij,3) 1354 dijfock_vv(klmn1 ,1)= dij_up 1355 dijfock_vv(klmn1 ,2)= dij_dn 1356 dijfock_vv(klmn1 ,3)= dij_updn_r 1357 dijfock_vv(klmn1+1,3)= dij_updn_i 1358 dijfock_vv(klmn1 ,4)= dij_updn_r 1359 dijfock_vv(klmn1+1,4)=-dij_updn_i 1360 klmn1=klmn1+cplex_dij 1361 end do 1362 end if 1363 1364 end do ! qphase 1365 1366 ! ===== Core-valence contribution ===== 1367 1368 do ispden=1,pawrhoij%nsppol 1369 do iq=1,qphase 1370 iq0_dij=merge(0,cplex_dij*lmn2_size,iq==1) 1371 klmn1=iq0_dij+1 1372 do klmn_ij=1,lmn2_size 1373 dijfock_cv(klmn1,ispden)=pawtab%ex_cvij(klmn_ij) 1374 klmn1=klmn1+cplex_dij 1375 end do 1376 end do 1377 end do 1378 1379 !Antiferro case: copy up component into down one 1380 if (ndij==2.and.pawrhoij%nsppol==1) then 1381 dijfock_cv(:,2)=dijfock_cv(:,1) 1382 end if 1383 1384 !Apply mixing factors 1385 if (abs(hyb_mixing)>tol8) then 1386 dijfock_vv(:,:) = hyb_mixing*dijfock_vv(:,:) 1387 else if (abs(hyb_mixing_sr)>tol8) then 1388 dijfock_vv(:,:) = hyb_mixing_sr*dijfock_vv(:,:) 1389 end if 1390 dijfock_cv(:,:) = (hyb_mixing+hyb_mixing_sr)*dijfock_cv(:,:) 1391 1392 !Free temporary memory spaces 1393 LIBPAW_DEALLOCATE(dijfock_vv_tmp) 1394 1395 end subroutine pawdijfock
m_pawdij/pawdijfr [ Functions ]
[ Top ] [ m_pawdij ] [ Functions ]
NAME
pawdijfr
FUNCTION
PAW, Response Function only:
Compute frozen part of psp strength Dij due to 1st-order compensation density
and first order local potential:
Dijfr =Int_R^3{vtrial*Sum_LM[Q_ij_q^LM^(1)] + Vloc^(1)*Sum_LM[Q_ij_q^LM]}
Depends on q wave vector but not on first-order wave-function.
INPUTS
gprimd(3,3)=dimensional primitive translations for reciprocal space idir=direction of atomic displacement (in case of phonons perturb.) ipert=index of perturbation mpi_atmtab(:)=--optional-- indexes of the atoms treated by current proc comm_atom=--optional-- MPI communicator over atoms mpi_comm_grid=--optional-- MPI communicator over real space grid components my_natom=number of atoms treated by current processor natom=total number of atoms in cell nfft=(effective) number of FFT grid points (for this processor) nspden=number of spin-density components nsppol=number of independent spin WF components ntypat=number of types of atoms option=0: computes full frozen part of Dij 1: computes frozen part of Dij without contribution from Vpsp1 pawang <type(pawang_type)>=paw angular mesh and related data pawfgrtab(my_natom) <type(pawfgrtab_type)>=atomic data given on fine rectangular grid pawrad(ntypat*usepaw) <type(pawrad_type)>=paw radial mesh and related data pawtab(ntypat) <type(pawtab_type)>=paw tabulated starting data qphase=2 if dij contains a exp(-i.q.r) phase (as in the q<>0 RF case), 1 if not qphon(3)=wavevector of the phonon rprimd(3,3)=dimensional primitive translations for real space ucvol=unit cell volume (bohr^3) vpsp1(qphase*nfft)= first-order change of local potential vtrial(nfft,nspden)= total GS potential vxc(nfft,nspden)=XC potential xred(3,my_natom)= reduced atomic coordinates
OUTPUT
paw_ij1(iatom)%dijfr(cplex_dij*qphase*lmn2_size,nspden)=
frozen contribution to psp strength Dij
=Int_R^3{vtrial*Sum_LM[Q_ij_q^LM^(1)] + Vloc^(1)*Sum_LM[Q_ij_q^LM]}
When Dij is complex (cplex_dij=2):
dij(2*i-1,:) contains the real part, dij(2*i,:) contains the imaginary part
When a exp(-i.q.r) phase is included (qphase=2):
dij(1:cplex_dij*lmn2_size,:)
contains the real part of the phase, i.e. D_ij*cos(q.r)
dij(cplex_dij*lmn2_size+1:2*cplex_dij*lmn2_size,:)
contains the imaginary part of the phase, i.e. D_ij*sin(q.r)
SOURCE
3493 subroutine pawdijfr(gprimd,idir,ipert,my_natom,natom,nfft,ngfft,nspden,nsppol,ntypat,& 3494 & option,paw_ij1,pawang,pawfgrtab,pawrad,pawtab,qphase,qphon,rprimd,ucvol,& 3495 & vpsp1,vtrial,vxc,xred,& 3496 & mpi_atmtab,comm_atom,mpi_comm_grid) ! optional arguments (parallelism) 3497 3498 !Arguments ------------------------------------ 3499 !scalars 3500 integer,intent(in) :: idir,ipert,my_natom,natom,nfft,nspden,nsppol,ntypat,option,qphase 3501 integer,optional,intent(in) :: comm_atom,mpi_comm_grid 3502 real(dp),intent(in) :: ucvol 3503 type(pawang_type),intent(in) :: pawang 3504 !arrays 3505 integer,intent(in) :: ngfft(18) 3506 integer,optional,target,intent(in) :: mpi_atmtab(:) 3507 real(dp),intent(in) :: gprimd(3,3),qphon(3),rprimd(3,3) 3508 real(dp),intent(in) :: vpsp1(qphase*nfft),vtrial(nfft,nspden),vxc(nfft,nspden) 3509 real(dp),intent(in) :: xred(3,natom) 3510 type(paw_ij_type),intent(inout) :: paw_ij1(my_natom) 3511 type(pawfgrtab_type),intent(inout) :: pawfgrtab(my_natom) 3512 type(pawrad_type),intent(in) :: pawrad(ntypat) 3513 type(pawtab_type),intent(in) :: pawtab(ntypat) 3514 3515 !Local variables------------------------------- 3516 !scalars 3517 integer :: cplex_dij,cplex_nspden,cplex_p1,iatom,iatom_tot,ic,idij,idijend,ier,ils,ilslm,isel 3518 integer :: ispden,istr,itypat,jc,klm,klmn,klmn1,klmn2,kln,lm_size,lmn2_size,lm0,lmax,lmin,mesh_size 3519 integer :: mm,my_comm_atom,my_comm_grid,mu,mua,mub,ndij,nfftot,nfgd,nsploop 3520 integer :: optgr0,optgr1,optgr2,usexcnhat 3521 logical :: has_qphase,my_atmtab_allocated,need_dijfr_1,need_dijfr_2,need_dijfr_3,need_dijfr_4 3522 logical :: paral_atom,qne0,testdij1,testdij2,testdij3 3523 real(dp) :: c1,fact,intg,rg1 3524 character(len=500) :: msg 3525 !arrays 3526 integer,parameter :: m_index(3)=(/1,-1,0/) 3527 integer,pointer :: my_atmtab(:) 3528 integer,parameter :: alpha(9)=(/1,2,3,3,3,2,2,1,1/),beta(9)=(/1,2,3,2,1,1,3,3,2/) 3529 real(dp) :: contrib(2) 3530 real(dp),allocatable :: ff(:),intv(:,:),intv1(:,:),intv2(:,:),intvloc(:,:),intv_tmp(:,:) 3531 real(dp),allocatable :: rg(:),vloc(:,:) 3532 3533 ! ************************************************************************* 3534 3535 !Nothing to be done for DDK 3536 if (ipert==natom+1.or.ipert==natom+10) return 3537 3538 !Set up parallelism over atoms 3539 paral_atom=(present(comm_atom).and.(my_natom/=natom)) 3540 nullify(my_atmtab);if (present(mpi_atmtab)) my_atmtab => mpi_atmtab 3541 my_comm_atom=xmpi_comm_self;if (present(comm_atom)) my_comm_atom=comm_atom 3542 my_comm_grid=xmpi_comm_self;if (present(mpi_comm_grid)) my_comm_grid=mpi_comm_grid 3543 call get_my_atmtab(my_comm_atom,my_atmtab,my_atmtab_allocated,paral_atom,natom,my_natom_ref=my_natom) 3544 3545 !Compatibility tests 3546 qne0=(qphon(1)**2+qphon(2)**2+qphon(3)**2>=1.d-15) 3547 if (my_natom>0) then 3548 if (qne0.and.qphase==1) then 3549 msg='qphase must be 2 when q<>0!' 3550 LIBPAW_BUG(msg) 3551 end if 3552 if (paw_ij1(1)%qphase/=qphase) then 3553 msg='paw_ij1()%qphase and qphase must be equal !' 3554 LIBPAW_BUG(msg) 3555 end if 3556 if (paw_ij1(1)%has_dijfr==0) then 3557 msg='pawdij1()%dijfr must be allocated !' 3558 LIBPAW_BUG(msg) 3559 end if 3560 testdij1=(ipert<=natom.and.option==0.and.pawfgrtab(1)%gylm_allocated==0) 3561 testdij2=(ipert<=natom.and.pawfgrtab(1)%gylmgr_allocated==0) 3562 testdij3=(testdij2.and.qne0.and.pawfgrtab(1)%expiqr_allocated==0) 3563 if ((testdij1.or.testdij2.or.testdij3).and.pawfgrtab(1)%rfgd_allocated==0) then 3564 msg='pawfgrtab()%rfgd array must be allocated !' 3565 LIBPAW_BUG(msg) 3566 end if 3567 end if 3568 3569 !Get correct index of strain pertubation 3570 if (ipert==natom+3) istr = idir 3571 if (ipert==natom+4) istr = idir + 3 3572 3573 !Some inits 3574 usexcnhat=maxval(pawtab(1:ntypat)%usexcnhat) 3575 nfftot=ngfft(1)*ngfft(2)*ngfft(3) 3576 fact=ucvol/dble(nfftot) 3577 cplex_nspden=merge(1,2,nspden/=4) 3578 3579 !Loops over atoms 3580 do iatom=1,my_natom 3581 iatom_tot=iatom;if (paral_atom) iatom_tot=my_atmtab(iatom) 3582 3583 ! Select which part of Dijfr to compute 3584 need_dijfr_1=(ipert==iatom_tot.and.paw_ij1(iatom)%has_dijfr==1) 3585 need_dijfr_2=(ipert<=natom.and.paw_ij1(iatom)%has_dijfr==1.and.(option==0)) 3586 need_dijfr_3=((ipert==natom+2.or.ipert==natom+11).and.paw_ij1(iatom)%has_dijfr==1) 3587 need_dijfr_4=((ipert==natom+3.or.ipert==natom+4).and.paw_ij1(iatom)%has_dijfr==1) 3588 3589 if ((.not.need_dijfr_1).and.(.not.need_dijfr_2).and.(.not.need_dijfr_3).and.(.not.need_dijfr_4)) then 3590 if (paw_ij1(iatom)%has_dijfr>0) then 3591 paw_ij1(iatom)%dijfr=zero ; paw_ij1(iatom)%has_dijfr=2 3592 end if 3593 cycle 3594 end if 3595 3596 ! Some atom-dependent quantities 3597 itypat=pawfgrtab(iatom)%itypat 3598 lm_size=pawtab(itypat)%lcut_size**2 3599 lmn2_size=pawtab(itypat)%lmn2_size 3600 cplex_dij=paw_ij1(iatom)%cplex_dij 3601 ndij=paw_ij1(iatom)%ndij 3602 3603 ! Eventually compute g_l(r).Y_lm(r) factors for the current atom (if not already done) 3604 nfgd=0 3605 if (need_dijfr_1.or.need_dijfr_2.or.need_dijfr_4) then 3606 nfgd=pawfgrtab(iatom)%nfgd 3607 if (((need_dijfr_2.or.need_dijfr_4).and.(pawfgrtab(iatom)%gylm_allocated==0)).or.& 3608 & ((need_dijfr_1).and.(pawfgrtab(iatom)%gylmgr_allocated==0))) then 3609 optgr0=0;optgr1=0;optgr2=0 3610 if ((need_dijfr_2.or. need_dijfr_4).and.(pawfgrtab(iatom)%gylm_allocated==0)) then 3611 if (allocated(pawfgrtab(iatom)%gylm)) then 3612 LIBPAW_DEALLOCATE(pawfgrtab(iatom)%gylm) 3613 end if 3614 LIBPAW_ALLOCATE(pawfgrtab(iatom)%gylm,(nfgd,lm_size)) 3615 pawfgrtab(iatom)%gylm_allocated=2;optgr0=1 3616 end if 3617 if ((need_dijfr_1.or.need_dijfr_4).and.(pawfgrtab(iatom)%gylmgr_allocated==0)) then 3618 if (allocated(pawfgrtab(iatom)%gylmgr)) then 3619 LIBPAW_DEALLOCATE(pawfgrtab(iatom)%gylmgr) 3620 end if 3621 LIBPAW_ALLOCATE(pawfgrtab(iatom)%gylmgr,(3,nfgd,lm_size)) 3622 pawfgrtab(iatom)%gylmgr_allocated=2;optgr1=1 3623 end if 3624 if (optgr0+optgr1+optgr2>0) then 3625 call pawgylm(pawfgrtab(iatom)%gylm,pawfgrtab(iatom)%gylmgr,pawfgrtab(iatom)%gylmgr2,& 3626 & lm_size,nfgd,optgr0,optgr1,optgr2,pawtab(itypat),pawfgrtab(iatom)%rfgd) 3627 end if 3628 end if 3629 end if 3630 3631 ! Eventually compute exp(-i.q.r) factors for the current atom (if not already done) 3632 has_qphase=(qne0.and.qphase==2) 3633 if (need_dijfr_2) then 3634 if (has_qphase.and.(pawfgrtab(iatom)%expiqr_allocated==0)) then 3635 if (allocated(pawfgrtab(iatom)%expiqr)) then 3636 LIBPAW_DEALLOCATE(pawfgrtab(iatom)%expiqr) 3637 end if 3638 LIBPAW_ALLOCATE(pawfgrtab(iatom)%expiqr,(2,nfgd)) 3639 call pawexpiqr(pawfgrtab(iatom)%expiqr,gprimd,nfgd,qphon,& 3640 & pawfgrtab(iatom)%rfgd,xred(:,iatom_tot)) 3641 pawfgrtab(iatom)%expiqr_allocated=2 3642 end if 3643 has_qphase=(pawfgrtab(iatom)%expiqr_allocated/=0) 3644 end if 3645 3646 ! Loop over spin components 3647 nsploop=nsppol;if (ndij==4) nsploop=4 3648 do idij=1,nsploop 3649 if (idij<=nsppol.or.(nspden==4.and.idij<=3)) then 3650 3651 idijend=idij+idij/3 3652 do ispden=idij,idijend 3653 3654 LIBPAW_ALLOCATE(intv,(qphase*cplex_nspden,lm_size)) 3655 intv(:,:) = zero 3656 3657 ! ============ Phonons ==================================== 3658 if (ipert<=natom) then 3659 3660 if (need_dijfr_1.or.need_dijfr_2) then 3661 3662 LIBPAW_ALLOCATE(intv1,(cplex_nspden,lm_size)) 3663 LIBPAW_ALLOCATE(intv2,(qphase,lm_size)) 3664 intv1(:,:)=zero ; intv2(:,:)=zero 3665 3666 ! First part: Int_R^3{vtrial*Sum_LM[Q_ij_q^LM^(1)]} 3667 if (need_dijfr_1) then 3668 3669 ! ----- Retrieve potential Vlocal (subtle if nspden=4 ;-) 3670 LIBPAW_ALLOCATE(vloc,(cplex_nspden,nfgd)) 3671 if (nspden/=4) then 3672 if (usexcnhat==0) then 3673 do ic=1,nfgd 3674 jc=pawfgrtab(iatom)%ifftsph(ic) 3675 vloc(1,ic)=vtrial(jc,ispden)-vxc(jc,ispden) 3676 end do 3677 else 3678 do ic=1,nfgd 3679 vloc(1,ic)=vtrial(pawfgrtab(iatom)%ifftsph(ic),ispden) 3680 end do 3681 end if 3682 else ! nspden==4 3683 if (ispden<=2) then 3684 if (usexcnhat==0) then 3685 do ic=1,nfgd 3686 jc=pawfgrtab(iatom)%ifftsph(ic) 3687 vloc(1,ic)=vtrial(jc,ispden)-vxc(jc,ispden) 3688 vloc(2,ic)=zero 3689 end do 3690 else 3691 do ic=1,nfgd 3692 jc=pawfgrtab(iatom)%ifftsph(ic) 3693 vloc(1,ic)=vtrial(jc,ispden) 3694 vloc(2,ic)=zero 3695 end do 3696 end if 3697 else if (ispden==3) then 3698 if (usexcnhat==0) then 3699 vloc(:,:)=zero 3700 else 3701 do ic=1,nfgd 3702 jc=pawfgrtab(iatom)%ifftsph(ic) 3703 vloc(1,ic)=vtrial(jc,3) 3704 vloc(2,ic)=vtrial(jc,4) 3705 end do 3706 end if 3707 else ! ispden=4 3708 vloc(2,1:nfgd)=-vloc(2,1:nfgd) 3709 end if 3710 end if 3711 3712 ! ----- Compute Integral [ Vtrial(r).(g_l(r).Y_lm(r))^(1) dr ] 3713 LIBPAW_ALLOCATE(intv_tmp,(cplex_nspden,3)) 3714 do ilslm=1,lm_size 3715 intv_tmp=zero 3716 do ic=1,nfgd 3717 do mu=1,3 3718 ! Minus sign because dg(r-R)/dR = -dg(r-R)/dr 3719 contrib(1:cplex_nspden)=-vloc(1:cplex_nspden,ic)*pawfgrtab(iatom)%gylmgr(mu,ic,ilslm) 3720 intv_tmp(1:cplex_nspden,mu)=intv_tmp(1:cplex_nspden,mu)+contrib(1:cplex_nspden) 3721 end do 3722 end do 3723 ! Convert from cartesian to reduced coordinates 3724 intv1(1:cplex_nspden,ilslm)=intv1(1:cplex_nspden,ilslm) & 3725 & +(rprimd(1,idir)*intv_tmp(1:cplex_nspden,1) & 3726 & +rprimd(2,idir)*intv_tmp(1:cplex_nspden,2) & 3727 & +rprimd(3,idir)*intv_tmp(1:cplex_nspden,3)) 3728 end do 3729 LIBPAW_DEALLOCATE(vloc) 3730 LIBPAW_DEALLOCATE(intv_tmp) 3731 end if ! need_dijfr_1 3732 3733 ! 2nd part: Int_R^3{Vloc^(1)*Sum_LM[Q_ij_q^LM]} 3734 if (need_dijfr_2) then 3735 3736 if (ispden==1) then 3737 3738 ! ----- Retrieve potential Vloc^(1) 3739 LIBPAW_ALLOCATE(vloc,(qphase,nfgd)) 3740 if (qphase==1) then 3741 do ic=1,nfgd 3742 jc=qphase*pawfgrtab(iatom)%ifftsph(ic) 3743 vloc(1,ic)=vpsp1(jc) 3744 end do 3745 else 3746 do ic=1,nfgd 3747 jc=2*pawfgrtab(iatom)%ifftsph(ic)-1 3748 vloc(1,ic)=vpsp1(jc ) 3749 vloc(2,ic)=vpsp1(jc+1) 3750 end do 3751 end if 3752 3753 ! ----- Compute Integral [ Vloc^(1)(r).g_l(r).Y_lm(r) ] 3754 LIBPAW_ALLOCATE(intvloc,(qphase,lm_size)) 3755 intvloc=zero 3756 if (has_qphase) then 3757 if (qphase==1) then 3758 do ilslm=1,lm_size 3759 do ic=1,nfgd 3760 contrib(1)=vloc(1,ic)*pawfgrtab(iatom)%gylm(ic,ilslm) 3761 intvloc(1,ilslm)=intvloc(1,ilslm)+contrib(1)*pawfgrtab(iatom)%expiqr(1,ic) 3762 end do 3763 end do 3764 else 3765 do ilslm=1,lm_size 3766 do ic=1,nfgd 3767 contrib(1:2)=vloc(1:2,ic)*pawfgrtab(iatom)%gylm(ic,ilslm) 3768 intvloc(1,ilslm)=intvloc(1,ilslm)+contrib(1)*pawfgrtab(iatom)%expiqr(1,ic) & 3769 & -contrib(2)*pawfgrtab(iatom)%expiqr(2,ic) 3770 intvloc(2,ilslm)=intvloc(2,ilslm)+contrib(1)*pawfgrtab(iatom)%expiqr(2,ic) & 3771 & +contrib(2)*pawfgrtab(iatom)%expiqr(1,ic) 3772 end do 3773 end do 3774 end if 3775 else ! no phase 3776 do ilslm=1,lm_size 3777 do ic=1,nfgd 3778 contrib(1:qphase)=vloc(1:qphase,ic)*pawfgrtab(iatom)%gylm(ic,ilslm) 3779 intvloc(1:qphase,ilslm)=intvloc(1:qphase,ilslm)+contrib(1:qphase) 3780 end do 3781 end do 3782 end if 3783 LIBPAW_DEALLOCATE(vloc) 3784 end if ! ispden=1 3785 3786 !Add to previous contribution 3787 if (ispden<=min(nspden,2)) then 3788 intv2(1:qphase,1:lm_size)=intv2(1:qphase,1:lm_size)+intvloc(1:qphase,1:lm_size) 3789 if (ispden==min(nspden,2)) then 3790 LIBPAW_DEALLOCATE(intvloc) 3791 end if 3792 end if 3793 end if ! need_dijfr_2 3794 3795 ! Sum contributions and apply ucvol/nfft factor on integral 3796 intv(1:cplex_nspden,1:lm_size)=intv1(1:cplex_nspden,1:lm_size) 3797 intv(1,1:lm_size)=intv(1,1:lm_size)+intv2(1,1:lm_size) 3798 if (qphase==2) intv(cplex_nspden+1,1:lm_size)=intv(cplex_nspden+1,1:lm_size)+intv2(2,1:lm_size) 3799 intv(:,:)=fact*intv(:,:) 3800 LIBPAW_DEALLOCATE(intv1) 3801 LIBPAW_DEALLOCATE(intv2) 3802 3803 ! --- Reduction in case of parallelization --- 3804 call xmpi_sum(intv,my_comm_grid,ier) 3805 3806 paw_ij1(iatom)%dijfr(:,ispden)=zero 3807 3808 ! ---- Loop over (i,j) components 3809 klmn1=1;klmn2=1+lmn2_size*cplex_dij ; cplex_p1=cplex_nspden+1 3810 do klmn=1,lmn2_size 3811 klm =pawtab(itypat)%indklmn(1,klmn) 3812 lmin=pawtab(itypat)%indklmn(3,klmn) 3813 lmax=pawtab(itypat)%indklmn(4,klmn) 3814 do ils=lmin,lmax,2 3815 lm0=ils**2+ils+1 3816 do mm=-ils,ils 3817 ilslm=lm0+mm;isel=pawang%gntselect(ilslm,klm) 3818 if (isel>0) then 3819 !The following works only because cplex_nspden<=cplex_dij 3820 paw_ij1(iatom)%dijfr(klmn1,ispden)=paw_ij1(iatom)%dijfr(klmn1,ispden) & 3821 & +pawtab(itypat)%qijl(ilslm,klmn)*intv(1,ilslm) 3822 if (cplex_nspden==2) then 3823 paw_ij1(iatom)%dijfr(klmn1+1,ispden)=paw_ij1(iatom)%dijfr(klmn1+1,ispden) & 3824 & +pawtab(itypat)%qijl(ilslm,klmn)*intv(2,ilslm) 3825 end if 3826 if (qphase==2) then 3827 paw_ij1(iatom)%dijfr(klmn2,ispden)=paw_ij1(iatom)%dijfr(klmn2,ispden) & 3828 & +pawtab(itypat)%qijl(ilslm,klmn)*intv(cplex_p1,ilslm) 3829 if (cplex_nspden==2) then 3830 paw_ij1(iatom)%dijfr(klmn2+1,ispden)=paw_ij1(iatom)%dijfr(klmn2+1,ispden) & 3831 & +pawtab(itypat)%qijl(ilslm,klmn)*intv(4,ilslm) 3832 end if 3833 end if 3834 !Previous version 3835 ! dplex_nsp=cplex_nspden-1 3836 ! paw_ij1(iatom)%dijfr(klmn1:klmn1+dplex_nsp,ispden)= & 3837 ! & paw_ij1(iatom)%dijfr(klmn1:klmn1+dplex_nsp,ispden) & 3838 ! & +pawtab(itypat)%qijl(ilslm,klmn)*intv(1:cplex_nspden,ilslm) 3839 ! if (qphase==2) then 3840 ! paw_ij1(iatom)%dijfr(klmn2:klmn2+dplex_nsp,ispden)= & 3841 ! & paw_ij1(iatom)%dijfr(klmn2:klmn2+dplex_nsp,ispden) & 3842 ! & +pawtab(itypat)%qijl(ilslm,klmn)*intv(1+cplex_nspden:2*cplex_nspden,ilslm) 3843 ! end if 3844 end if 3845 end do 3846 end do 3847 klmn1=klmn1+cplex_dij;klmn2=klmn2+cplex_dij 3848 end do 3849 3850 ! Dijfr is marked as computed 3851 paw_ij1(iatom)%has_dijfr=2 3852 3853 end if 3854 3855 ! ============ Electric field perturbation ======================= 3856 else if (ipert==natom+2.or.ipert==natom+11) then 3857 3858 if (need_dijfr_3) then 3859 3860 ! The following factor arises in expanding the angular dependence of the dipole 3861 ! vector in terms of real spherical harmonics. The real spherical harmonics are as 3862 ! in the routine initylmr.F90; 3863 ! see http://www.unioviedo.es/qcg/art/Theochem419-19-ov-BF97-rotation-matrices.pdf 3864 c1 = sqrt(four_pi/three) 3865 mesh_size=pawtab(itypat)%mesh_size 3866 3867 if (ispden==1) then 3868 3869 LIBPAW_ALLOCATE(ff,(mesh_size)) 3870 LIBPAW_ALLOCATE(rg,(3)) 3871 3872 ! loop over basis state pairs for this atom 3873 klmn1=1 3874 do klmn = 1, paw_ij1(iatom)%lmn2_size 3875 klm =pawtab(itypat)%indklmn(1,klmn) 3876 kln =pawtab(itypat)%indklmn(2,klmn) 3877 lmin=pawtab(itypat)%indklmn(3,klmn) 3878 lmax=pawtab(itypat)%indklmn(4,klmn) 3879 3880 ! Select only l=1, because the dipole is a vector operator 3881 if (lmin==1) then 3882 lm0=3 ! (l^2+l+1) for l=1 3883 3884 ! Computation of <phi_i|r|phi_j>- <tphi_i|r|tphi_j> 3885 ! the dipole vector has radial dependence r 3886 ff(1:mesh_size)=(pawtab(itypat)%phiphj(1:mesh_size,kln)& 3887 & -pawtab(itypat)%tphitphj(1:mesh_size,kln))& 3888 & *pawrad(itypat)%rad(1:mesh_size) 3889 ! call pawrad_deducer0(ff,mesh_size,pawrad(itypat)) 3890 call simp_gen(intg,ff,pawrad(itypat)) 3891 3892 ! Compute <S_li_mi|r-R|S_lj_mj>: use a real Gaunt expression (with selection rule) 3893 rg(1:3)=zero 3894 do ic=1,3 3895 isel=pawang%gntselect(lm0+m_index(ic),klm) 3896 if (isel>0) rg(ic)=pawang%realgnt(isel) 3897 end do 3898 3899 ! Translate from cartesian to reduced coordinates (in idir direction) 3900 rg1=gprimd(1,idir)*rg(1)+gprimd(2,idir)*rg(2)+gprimd(3,idir)*rg(3) 3901 3902 ! Build sqrt(4pi/3).<S_li_mi|r-R|S_lj_mj>.(<phi_i|r-R|phi_j>- <tphi_i|r-R|tphi_j> 3903 paw_ij1(iatom)%dijfr(klmn1,ispden)=c1*rg1*intg 3904 if (cplex_dij==2) paw_ij1(iatom)%dijfr(klmn1+1,ispden)=zero 3905 3906 else 3907 paw_ij1(iatom)%dijfr(klmn1,ispden)=zero 3908 end if ! end gaunt constraint 3909 3910 klmn1=klmn1+cplex_dij 3911 end do ! end loop over lmn2_size pairs of basis states 3912 LIBPAW_DEALLOCATE(ff) 3913 LIBPAW_DEALLOCATE(rg) 3914 3915 ! Dijfr is spin-independent for electric field case 3916 else if (ispden==2) then 3917 paw_ij1(iatom)%dijfr(:,ispden)=paw_ij1(iatom)%dijfr(:,1) 3918 else 3919 paw_ij1(iatom)%dijfr(:,ispden)=zero 3920 end if 3921 3922 ! Dijfr is marked as computed 3923 paw_ij1(iatom)%has_dijfr=2 3924 end if 3925 3926 ! ============ Elastic tensor =============================== 3927 else if (ipert==natom+3.or.ipert==natom+4) then 3928 3929 ! ----- Retrieve potential Vlocal (subtle if nspden=4 ;-) 3930 LIBPAW_ALLOCATE(vloc,(cplex_nspden,nfgd)) 3931 if (nspden/=4) then 3932 if (usexcnhat==0) then 3933 do ic=1,nfgd 3934 jc=pawfgrtab(iatom)%ifftsph(ic) 3935 vloc(1,ic)=vtrial(jc,ispden)-vxc(jc,ispden) 3936 end do 3937 else 3938 do ic=1,nfgd 3939 vloc(1,ic)=vtrial(pawfgrtab(iatom)%ifftsph(ic),ispden) 3940 end do 3941 end if 3942 else ! nspden/=4 3943 if (ispden<=2) then 3944 if (usexcnhat==0) then 3945 do ic=1,nfgd 3946 jc=pawfgrtab(iatom)%ifftsph(ic) 3947 vloc(1,ic)=vtrial(jc,ispden)-vxc(jc,ispden) 3948 vloc(2,ic)=zero 3949 end do 3950 else 3951 do ic=1,nfgd 3952 jc=pawfgrtab(iatom)%ifftsph(ic) 3953 vloc(1,ic)=vtrial(jc,ispden) 3954 vloc(2,ic)=zero 3955 end do 3956 end if 3957 else if (ispden==3) then 3958 if (usexcnhat==0) then 3959 vloc(:,:)=zero 3960 else 3961 do ic=1,nfgd 3962 jc=pawfgrtab(iatom)%ifftsph(ic) 3963 vloc(1,ic)=vtrial(jc,3) 3964 vloc(2,ic)=vtrial(jc,4) 3965 end do 3966 end if 3967 else ! ispden=4 3968 vloc(2,1:nfgd)=-vloc(2,1:nfgd) 3969 end if 3970 end if 3971 3972 ! option = 0 Insulator case 3973 if(option==0)then 3974 do ilslm=1,lm_size 3975 do ic=1,nfgd 3976 jc=pawfgrtab(iatom)%ifftsph(ic) 3977 contrib(1:cplex_nspden) = zero 3978 3979 ! Int_R^3{vtrial*Sum_LM[Q_ij_q^LM^(1)]} 3980 mua=alpha(istr);mub=beta(istr) 3981 contrib(1:cplex_nspden)=contrib(1:cplex_nspden)+half*vloc(1:cplex_nspden,ic)& 3982 & *(pawfgrtab(iatom)%gylmgr(mua,ic,ilslm)*pawfgrtab(iatom)%rfgd(mub,ic)& 3983 & + pawfgrtab(iatom)%gylmgr(mub,ic,ilslm)*pawfgrtab(iatom)%rfgd(mua,ic)) 3984 3985 ! Int_R^3{Vloc^(1)*Sum_LM[Q_ij_q^LM]} 3986 contrib(1)=contrib(1)+vpsp1(jc)*pawfgrtab(iatom)%gylm(ic,ilslm) 3987 3988 ! delta_{alphabeta}Int_R^3{Vloc*Sum_LM[Q_ij_q^LM]} 3989 if(istr<=3)then 3990 contrib(1:cplex_nspden)=contrib(1:cplex_nspden) & 3991 & +vloc(1:cplex_nspden,ic)*pawfgrtab(iatom)%gylm(ic,ilslm) 3992 end if 3993 3994 intv(1:cplex_nspden,ilslm)=intv(1:cplex_nspden,ilslm)+contrib(1:cplex_nspden) 3995 end do 3996 end do 3997 3998 ! option = 1 Metal case (without Vpsp1) 3999 else if (option==1)then 4000 do ilslm=1,lm_size 4001 do ic=1,nfgd 4002 jc=pawfgrtab(iatom)%ifftsph(ic) 4003 contrib(1) = zero 4004 4005 ! Int_R^3{vtrial*Sum_LM[Q_ij_q^LM^(1)]} 4006 mua=alpha(istr);mub=beta(istr) 4007 contrib(1:cplex_nspden)=contrib(1:cplex_nspden)+half*vloc(1:cplex_nspden,ic)& 4008 & *(pawfgrtab(iatom)%gylmgr(mua,ic,ilslm)*pawfgrtab(iatom)%rfgd(mub,ic)& 4009 & + pawfgrtab(iatom)%gylmgr(mub,ic,ilslm)*pawfgrtab(iatom)%rfgd(mua,ic)) 4010 4011 ! delta_{alphabeta}Int_R^3{Vtrial*Sum_LM[Q_ij_q^LM]} 4012 if(istr<=3)then 4013 contrib(1:cplex_nspden)=contrib(1:cplex_nspden) & 4014 & +vloc(1:cplex_nspden,ic)*pawfgrtab(iatom)%gylm(ic,ilslm) 4015 end if 4016 4017 intv(1:cplex_nspden,ilslm)=intv(1:cplex_nspden,ilslm)+contrib(1:cplex_nspden) 4018 end do 4019 end do 4020 end if 4021 LIBPAW_DEALLOCATE(vloc) 4022 4023 ! Apply ucvol/nfft factor on integral 4024 intv(:,:)=fact*intv(:,:) 4025 4026 ! --- Reduction in case of parallelization --- 4027 call xmpi_sum(intv,my_comm_grid,ier) 4028 4029 paw_ij1(iatom)%dijfr(:,ispden)=zero 4030 4031 ! ---- Loop over (i,j) components 4032 klmn1=1 4033 do klmn=1,lmn2_size 4034 klm =pawtab(itypat)%indklmn(1,klmn) 4035 lmin=pawtab(itypat)%indklmn(3,klmn) 4036 lmax=pawtab(itypat)%indklmn(4,klmn) 4037 do ils=lmin,lmax,2 4038 lm0=ils**2+ils+1 4039 do mm=-ils,ils 4040 ilslm=lm0+mm;isel=pawang%gntselect(ilslm,klm) 4041 if (isel>0) then 4042 !The following works only because cplex_nspden<=cplex_dij 4043 paw_ij1(iatom)%dijfr(klmn1,ispden)=paw_ij1(iatom)%dijfr(klmn1,ispden) & 4044 & +pawtab(itypat)%qijl(ilslm,klmn)*intv(1,ilslm) 4045 if (cplex_nspden==2) then 4046 paw_ij1(iatom)%dijfr(klmn1+1,ispden)=paw_ij1(iatom)%dijfr(klmn1+1,ispden) & 4047 & +pawtab(itypat)%qijl(ilslm,klmn)*intv(2,ilslm) 4048 end if 4049 !Previous version 4050 ! dplex_nsp=cplex_nspden-1 4051 ! paw_ij1(iatom)%dijfr(klmn1:klmn1+dplex_nsp,ispden)= & 4052 !& paw_ij1(iatom)%dijfr(klmn1:klmn1+dplex_nsp,ispden) & 4053 !& +pawtab(itypat)%qijl(ilslm,klmn)*intv(1:cplex_nspden,ilslm) 4054 end if 4055 end do 4056 end do 4057 klmn1=klmn1+cplex_dij 4058 end do 4059 4060 ! Dijfr is marked as computed 4061 paw_ij1(iatom)%has_dijfr=2 4062 4063 end if ! ipert 4064 4065 LIBPAW_DEALLOCATE(intv) 4066 4067 !---------------------------------------------------------- 4068 ! End loops over spin components 4069 end do ! ispden 4070 4071 ! ---------------------------------------------------------- 4072 ! Deduce some part of Dij according to symmetries 4073 ! ---------------------------------------------------------- 4074 4075 !Non-collinear: D_ij(:,4)=D^21_ij=D^12_ij^* 4076 else if (nspden==4.and.idij==4) then 4077 paw_ij1(iatom)%dijfr(:,idij)=paw_ij1(iatom)%dijfr(:,idij-1) 4078 if (cplex_dij==2) then 4079 do klmn=2,lmn2_size*cplex_dij,cplex_dij 4080 paw_ij1(iatom)%dijfr(klmn,idij)=-paw_ij1(iatom)%dijfr(klmn,idij) 4081 end do 4082 if (qphase==2) then 4083 do klmn=2+lmn2_size*cplex_dij,2*lmn2_size*cplex_dij,cplex_dij 4084 paw_ij1(iatom)%dijfr(klmn,idij)=-paw_ij1(iatom)%dijfr(klmn,idij) 4085 end do 4086 end if 4087 end if 4088 4089 !Antiferro: D_ij(:,2)=D^down_ij=D^up_ij 4090 else if (nsppol==1.and.idij==2) then 4091 paw_ij1(iatom)%dijfr(:,idij)=paw_ij1(iatom)%dijfr(:,idij-1) 4092 end if 4093 4094 ! End loop on Dij components 4095 end do ! idij 4096 4097 !---------------------------------------------------------- 4098 4099 ! Eventually free temporary space for g_l(r).Y_lm(r) gradients and exp(-i.q.r) 4100 if (need_dijfr_1.or.need_dijfr_2) then 4101 if (pawfgrtab(iatom)%gylm_allocated==2) then 4102 LIBPAW_DEALLOCATE(pawfgrtab(iatom)%gylm) 4103 LIBPAW_ALLOCATE(pawfgrtab(iatom)%gylm,(0,0)) 4104 pawfgrtab(iatom)%gylm_allocated=0 4105 end if 4106 if (pawfgrtab(iatom)%gylmgr_allocated==2) then 4107 LIBPAW_DEALLOCATE(pawfgrtab(iatom)%gylmgr) 4108 LIBPAW_ALLOCATE(pawfgrtab(iatom)%gylmgr,(0,0,0)) 4109 pawfgrtab(iatom)%gylmgr_allocated=0 4110 end if 4111 if (pawfgrtab(iatom)%expiqr_allocated==2) then 4112 LIBPAW_DEALLOCATE(pawfgrtab(iatom)%expiqr) 4113 LIBPAW_ALLOCATE(pawfgrtab(iatom)%expiqr,(0,0)) 4114 pawfgrtab(iatom)%expiqr_allocated=0 4115 end if 4116 end if 4117 4118 ! End loop on atoms 4119 end do 4120 4121 !Destroy atom table used for parallelism 4122 call free_my_atmtab(my_atmtab,my_atmtab_allocated) 4123 4124 end subroutine pawdijfr
m_pawdij/pawdijhartree [ Functions ]
[ Top ] [ m_pawdij ] [ Functions ]
NAME
pawdijhartree
FUNCTION
Compute the Hartree contribution to the PAW pseudopotential strength Dij (for one atom only)
INPUTS
qphase=2 if dij contains a exp(-i.q.r) phase (as in the q<>0 RF case), 1 if not nspden=number of spin density components pawrhoij <type(pawrhoij_type)>= paw rhoij occupancies (and related data) for current atom pawtab <type(pawtab_type)>=paw tabulated starting data, for current atom
OUTPUT
dijhartree(qphase*lmn2_size)= D_ij^Hartree terms
When a exp(-i.q.r) phase is included (qphase=2):
dij(1:lmn2_size,:)
contains the real part of the phase, i.e. D_ij*cos(q.r)
dij(lmn2_size+1:2*lmn2_size,:)
contains the imaginary part of the phase, i.e. D_ij*sin(q.r)
SOURCE
1094 subroutine pawdijhartree(dijhartree,qphase,nspden,pawrhoij,pawtab) 1095 1096 !Arguments --------------------------------------------- 1097 !scalars 1098 integer,intent(in) :: nspden,qphase 1099 !arrays 1100 real(dp),intent(out) :: dijhartree(:) 1101 type(pawrhoij_type),intent(in) :: pawrhoij 1102 type(pawtab_type),intent(in) :: pawtab 1103 1104 !Local variables --------------------------------------- 1105 !scalars 1106 integer :: cplex_rhoij,iq,iq0_dij,iq0_rhoij,irhoij,ispden,jrhoij,klmn,klmn1,lmn2_size,nspdiag 1107 real(dp) :: ro 1108 character(len=500) :: msg 1109 !arrays 1110 1111 ! ************************************************************************* 1112 1113 !Check data consistency 1114 if (size(dijhartree,1)/=qphase*pawtab%lmn2_size) then 1115 msg='invalid size for DijHartree!' 1116 LIBPAW_BUG(msg) 1117 end if 1118 if (pawrhoij%qphase<qphase) then 1119 msg='pawrhoij%qphase must be >=qphase!' 1120 LIBPAW_BUG(msg) 1121 end if 1122 1123 !Initialization 1124 dijhartree=zero 1125 lmn2_size=pawrhoij%lmn2_size 1126 cplex_rhoij=pawrhoij%cplex_rhoij 1127 1128 !Loop over (diagonal) spin-components 1129 nspdiag=1;if (nspden==2) nspdiag=2 1130 do ispden=1,nspdiag 1131 1132 !Loop over phase exp(iqr) phase real/imaginary part 1133 do iq=1,qphase 1134 !First loop: we store the real part in dij(1 -> lmn2_size) 1135 !2nd loop: we store the imaginary part in dij(lmn2_size+1 -> 2*lmn2_size) 1136 iq0_dij=merge(0,lmn2_size,iq==1) 1137 iq0_rhoij=cplex_rhoij*iq0_dij 1138 1139 !Loop over rhoij elements 1140 jrhoij=iq0_rhoij+1 1141 do irhoij=1,pawrhoij%nrhoijsel 1142 klmn=pawrhoij%rhoijselect(irhoij) 1143 1144 ro=pawrhoij%rhoijp(jrhoij,ispden)*pawtab%dltij(klmn) 1145 !print *, "debug: irhoij, ro, pawtab%eijkl(klmn,klmn)", irhoij, ro, pawtab%eijkl(klmn,klmn) 1146 1147 !Diagonal k=l 1148 dijhartree(iq0_dij+klmn)=dijhartree(iq0_dij+klmn)+ro*pawtab%eijkl(klmn,klmn) 1149 1150 !k<=l 1151 do klmn1=1,klmn-1 1152 dijhartree(iq0_dij+klmn1)=dijhartree(iq0_dij+klmn1)+ro*pawtab%eijkl(klmn1,klmn) 1153 end do 1154 1155 !k>l 1156 do klmn1=klmn+1,lmn2_size 1157 dijhartree(iq0_dij+klmn1)=dijhartree(iq0_dij+klmn1)+ro*pawtab%eijkl(klmn,klmn1) 1158 end do 1159 1160 jrhoij=jrhoij+cplex_rhoij 1161 end do !End loop over rhoij 1162 1163 end do !End loop over q phase 1164 1165 end do !End loop over spin 1166 1167 end subroutine pawdijhartree
m_pawdij/pawdijhat [ Functions ]
[ Top ] [ m_pawdij ] [ Functions ]
NAME
pawdijhat
FUNCTION
Compute the "hat" contribution to the PAW pseudopotential strength Dij, i.e. the compensation charge contribution (for one atom only): D_ij^hat=Intg_R [ V(r). Sum_L(Qij^L(r)). dr]
INPUTS
cplex_dij=2 if dij is COMPLEX (as in the spin-orbit case), 1 if dij is REAL qphase=2 if dij contains a exp(-i.q.r) phase (as in the q<>0 RF case), 1 if not gprimd(3,3)=dimensional primitive translations for reciprocal space iatom=absolute index of current atom (between 1 and natom) natom=total number of atoms ndij= number of spin components ngrid=number of points of the real space grid (FFT, WVL, ...) treated by current proc ngridtot=total number of points of the real space grid (FFT, WVL, ...) For the FFT grid, thi should be equal to ngfft1*ngfft2*ngfft3 nspden=number of spin density components nsppol=number of independent spin WF components pawang <type(pawang_type)>=paw angular mesh and related data pawfgrtab<type(pawfgrtab_type)>=atomic data given on fine rectangular grid for current atom pawtab(ntypat) <type(pawtab_type)>=paw tabulated starting data, for current atom Pot(qphase*ngrid,nspden)=potential on real space grid qphon(3)=(RF calculations only) - wavevector of the phonon ucvol=unit cell volume xred(3,my_natom)= reduced atomic coordinates
OUTPUT
dijhat(cplex_dij*qphase*lmn2_size,ndij)= D_ij^hat terms
When Dij is complex (cplex_dij=2):
dij(2*i-1,:) contains the real part, dij(2*i,:) contains the imaginary part
When a exp(-i.q.r) phase is included (qphase=2):
dij(1:cplex_dij*lmn2_size,:)
contains the real part of the phase, i.e. D_ij*cos(q.r)
dij(cplex_dij*lmn2_size+1:2*cplex_dij*lmn2_size,:)
contains the imaginary part of the phase, i.e. D_ij*sin(q.r)
SOURCE
2104 subroutine pawdijhat(dijhat,cplex_dij,qphase,gprimd,iatom,& 2105 & natom,ndij,ngrid,ngridtot,nspden,nsppol,pawang,pawfgrtab,& 2106 & pawtab,Pot,qphon,ucvol,xred,& 2107 & mpi_comm_grid) ! Optional argument 2108 2109 !Arguments --------------------------------------------- 2110 !scalars 2111 integer,intent(in) :: cplex_dij,iatom,natom,ndij 2112 integer,intent(in) :: ngrid,ngridtot,nspden,nsppol,qphase 2113 integer,intent(in),optional :: mpi_comm_grid 2114 real(dp),intent(in) :: ucvol 2115 type(pawang_type),intent(in) :: pawang 2116 type(pawfgrtab_type),intent(inout) :: pawfgrtab 2117 !arrays 2118 real(dp),intent(in) :: gprimd(3,3),Pot(qphase*ngrid,nspden),qphon(3),xred(3,natom) 2119 real(dp),intent(out) :: dijhat(:,:) 2120 type(pawtab_type),intent(in) :: pawtab 2121 2122 !Local variables --------------------------------------- 2123 !scalars 2124 integer :: ic,idij,idijend,ier,ils,ilslm,ilslm1,isel,ispden,jc,klm,klmn,klmn1,klmn2 2125 integer :: lm0,lm_size,lmax,lmin,lmn2_size,mm,my_comm_grid,nfgd,nsploop,optgr0 2126 logical :: has_qphase,qne0 2127 real(dp) :: vi,vr 2128 character(len=500) :: msg 2129 !arrays 2130 real(dp) :: rdum1(1),rdum2(2) 2131 real(dp),allocatable :: dijhat_idij(:),prod(:) 2132 2133 ! ************************************************************************* 2134 2135 !Useful data 2136 lm_size=pawtab%lcut_size**2 2137 lmn2_size=pawtab%lmn2_size 2138 nfgd=pawfgrtab%nfgd 2139 qne0=(qphon(1)**2+qphon(2)**2+qphon(3)**2>=1.d-15) 2140 has_qphase=(qne0.and.qphase==2) 2141 my_comm_grid=xmpi_comm_self;if (present(mpi_comm_grid)) my_comm_grid=mpi_comm_grid 2142 2143 !Check data consistency 2144 if (size(dijhat,1)/=cplex_dij*qphase*lmn2_size.or.size(dijhat,2)/=ndij) then 2145 msg='invalid sizes for Dijhat !' 2146 LIBPAW_BUG(msg) 2147 end if 2148 2149 !Eventually compute g_l(r).Y_lm(r) factors for the current atom (if not already done) 2150 if (pawfgrtab%gylm_allocated==0) then 2151 if (allocated(pawfgrtab%gylm)) then 2152 LIBPAW_DEALLOCATE(pawfgrtab%gylm) 2153 end if 2154 LIBPAW_ALLOCATE(pawfgrtab%gylm,(nfgd,lm_size)) 2155 pawfgrtab%gylm_allocated=2;optgr0=1 2156 call pawgylm(pawfgrtab%gylm,rdum1,rdum2,lm_size,nfgd,optgr0,0,0,pawtab,pawfgrtab%rfgd) 2157 end if 2158 2159 !Eventually compute exp(i.q.r) factors for the current atom (if not already done) 2160 if (has_qphase.and.pawfgrtab%expiqr_allocated==0) then 2161 if (pawfgrtab%rfgd_allocated==0) then 2162 msg='pawfgrtab()%rfgd array must be allocated !' 2163 LIBPAW_BUG(msg) 2164 end if 2165 if (allocated(pawfgrtab%expiqr)) then 2166 LIBPAW_DEALLOCATE(pawfgrtab%expiqr) 2167 end if 2168 LIBPAW_ALLOCATE(pawfgrtab%expiqr,(2,nfgd)) 2169 call pawexpiqr(pawfgrtab%expiqr,gprimd,nfgd,qphon,pawfgrtab%rfgd,xred(:,iatom)) 2170 pawfgrtab%expiqr_allocated=2 2171 end if 2172 2173 !Init memory 2174 dijhat=zero 2175 LIBPAW_ALLOCATE(prod,(qphase*lm_size)) 2176 LIBPAW_ALLOCATE(dijhat_idij,(qphase*lmn2_size)) 2177 2178 !---------------------------------------------------------- 2179 !Loop over spin components 2180 !---------------------------------------------------------- 2181 nsploop=nsppol;if (ndij==4) nsploop=4 2182 do idij=1,nsploop 2183 if (idij<=nsppol.or.(nspden==4.and.idij<=3)) then 2184 2185 idijend=idij+idij/3 2186 do ispden=idij,idijend 2187 2188 ! ------------------------------------------------------ 2189 ! Compute Int[V(r).g_l(r).Y_lm(r)] 2190 ! ------------------------------------------------------ 2191 ! Note for non-collinear magnetism: 2192 ! We compute Int[V^(alpha,beta)(r).g_l(r).Y_lm(r)] 2193 ! Remember: if nspden=4, V is stored as : V^11, V^22, V^12, i.V^21 2194 2195 prod=zero 2196 2197 ! ===== Standard case ============================ 2198 if (.not.has_qphase) then 2199 if (qphase==1) then 2200 do ilslm=1,lm_size 2201 do ic=1,nfgd 2202 vr=Pot(pawfgrtab%ifftsph(ic),ispden) 2203 prod(ilslm)=prod(ilslm)+vr*pawfgrtab%gylm(ic,ilslm) 2204 end do 2205 end do 2206 else 2207 ilslm1=1 2208 do ilslm=1,lm_size 2209 do ic=1,nfgd 2210 jc=2*pawfgrtab%ifftsph(ic) 2211 vr=Pot(jc-1,ispden);vi=Pot(jc,ispden) 2212 prod(ilslm1 )=prod(ilslm1 )+vr*pawfgrtab%gylm(ic,ilslm) 2213 prod(ilslm1+1)=prod(ilslm1+1)+vi*pawfgrtab%gylm(ic,ilslm) 2214 end do 2215 ilslm1=ilslm1+qphase 2216 end do 2217 end if 2218 2219 ! ===== Including Exp(iqr) phase (DFPT only) ===== 2220 else 2221 if (qphase==1) then 2222 do ilslm=1,lm_size 2223 do ic=1,nfgd 2224 vr=Pot(pawfgrtab%ifftsph(ic),ispden) 2225 prod(ilslm)=prod(ilslm)+vr*pawfgrtab%gylm(ic,ilslm)& 2226 & *pawfgrtab%expiqr(1,ic) 2227 end do 2228 end do 2229 else 2230 ilslm1=1 2231 do ilslm=1,lm_size 2232 do ic=1,nfgd 2233 jc=2*pawfgrtab%ifftsph(ic) 2234 vr=Pot(jc-1,ispden);vi=Pot(jc,ispden) 2235 prod(ilslm1 )=prod(ilslm1 )+pawfgrtab%gylm(ic,ilslm)& 2236 & *(vr*pawfgrtab%expiqr(1,ic)-vi*pawfgrtab%expiqr(2,ic)) 2237 prod(ilslm1+1)=prod(ilslm1+1)+pawfgrtab%gylm(ic,ilslm)& 2238 & *(vr*pawfgrtab%expiqr(2,ic)+vi*pawfgrtab%expiqr(1,ic)) 2239 end do 2240 ilslm1=ilslm1+qphase 2241 end do 2242 end if 2243 end if 2244 2245 ! Scaling factor (unit volume) 2246 prod=prod*ucvol/dble(ngridtot) 2247 2248 ! Reduction in case of parallelism 2249 if (xmpi_comm_size(my_comm_grid)>1) then 2250 call xmpi_sum(prod,my_comm_grid,ier) 2251 end if 2252 2253 ! ---------------------------------------------------------- 2254 ! Compute Sum_(i,j)_LM { q_ij^L Int[V(r).g_l(r).Y_lm(r)] } 2255 ! ---------------------------------------------------------- 2256 ! Note for non-collinear magnetism: 2257 ! We compute Sum_(i,j)_LM { q_ij^L Int[V^(alpha,beta)(r).g_l(r).Y_lm(r)] } 2258 2259 dijhat_idij=zero 2260 2261 if (qphase==1) then 2262 do klmn=1,lmn2_size 2263 klm =pawtab%indklmn(1,klmn) 2264 lmin=pawtab%indklmn(3,klmn) 2265 lmax=pawtab%indklmn(4,klmn) 2266 do ils=lmin,lmax,2 2267 lm0=ils**2+ils+1 2268 do mm=-ils,ils 2269 ilslm=lm0+mm;isel=pawang%gntselect(ilslm,klm) 2270 if (isel>0) dijhat_idij(klmn)=dijhat_idij(klmn) & 2271 & +prod(ilslm)*pawtab%qijl(ilslm,klmn) 2272 end do 2273 end do 2274 end do 2275 else 2276 do klmn=1,lmn2_size 2277 klmn1=2*klmn-1 2278 klm =pawtab%indklmn(1,klmn) 2279 lmin=pawtab%indklmn(3,klmn) 2280 lmax=pawtab%indklmn(4,klmn) 2281 do ils=lmin,lmax,2 2282 lm0=ils**2+ils+1 2283 do mm=-ils,ils 2284 ilslm=lm0+mm;ilslm1=2*ilslm;isel=pawang%gntselect(ilslm,klm) 2285 if (isel>0) then 2286 dijhat_idij(klmn1 )=dijhat_idij(klmn1 )+prod(ilslm1-1)*pawtab%qijl(ilslm,klmn) 2287 dijhat_idij(klmn1+1)=dijhat_idij(klmn1+1)+prod(ilslm1 )*pawtab%qijl(ilslm,klmn) 2288 end if 2289 end do 2290 end do 2291 end do 2292 end if 2293 2294 ! ---------------------------------------------------------- 2295 ! Deduce some part of Dij according to symmetries 2296 ! ---------------------------------------------------------- 2297 2298 !if ispden=1 => real part of D^11_ij 2299 !if ispden=2 => real part of D^22_ij 2300 !if ispden=3 => real part of D^12_ij 2301 !if ispden=4 => imaginary part of D^12_ij 2302 klmn1=max(1,ispden-2);klmn2=1 2303 do klmn=1,lmn2_size 2304 dijhat(klmn1,idij)=dijhat_idij(klmn2) 2305 klmn1=klmn1+cplex_dij 2306 klmn2=klmn2+qphase 2307 end do 2308 if (qphase==2) then 2309 !Same storage with exp^(-i.q.r) phase 2310 klmn1=max(1,ispden-2)+lmn2_size*cplex_dij;klmn2=2 2311 do klmn=1,lmn2_size 2312 dijhat(klmn1,idij)=dijhat_idij(klmn2) 2313 klmn1=klmn1+cplex_dij 2314 klmn2=klmn2+qphase 2315 end do 2316 endif 2317 2318 end do !ispden 2319 2320 !Non-collinear: D_ij(:,4)=D^21_ij=D^12_ij^* 2321 else if (nspden==4.and.idij==4) then 2322 dijhat(:,idij)=dijhat(:,idij-1) 2323 if (cplex_dij==2) then 2324 do klmn=2,lmn2_size*cplex_dij,cplex_dij 2325 dijhat(klmn,idij)=-dijhat(klmn,idij) 2326 end do 2327 if (qphase==2) then 2328 do klmn=2+lmn2_size*cplex_dij,2*lmn2_size*cplex_dij,cplex_dij 2329 dijhat(klmn,idij)=-dijhat(klmn,idij) 2330 end do 2331 end if 2332 end if 2333 2334 !Antiferro: D_ij(:,2)=D^down_ij=D^up_ij 2335 else if (nsppol==1.and.idij==2) then 2336 dijhat(:,idij)=dijhat(:,idij-1) 2337 end if 2338 2339 !---------------------------------------------------------- 2340 !End loop on spin density components 2341 end do 2342 2343 !Free temporary memory spaces 2344 LIBPAW_DEALLOCATE(prod) 2345 LIBPAW_DEALLOCATE(dijhat_idij) 2346 if (pawfgrtab%gylm_allocated==2) then 2347 LIBPAW_DEALLOCATE(pawfgrtab%gylm) 2348 LIBPAW_ALLOCATE(pawfgrtab%gylm,(0,0)) 2349 pawfgrtab%gylm_allocated=0 2350 end if 2351 if (pawfgrtab%expiqr_allocated==2) then 2352 LIBPAW_DEALLOCATE(pawfgrtab%expiqr) 2353 LIBPAW_ALLOCATE(pawfgrtab%expiqr,(0,0)) 2354 pawfgrtab%expiqr_allocated=0 2355 end if 2356 2357 end subroutine pawdijhat
m_pawdij/pawdijnd [ Functions ]
[ Top ] [ m_pawdij ] [ Functions ]
NAME
pawdijnd
FUNCTION
Compute the nuclear dipole contribution to the PAW pseudopotential strength Dij (for one atom only)
INPUTS
cplex_dij=2 if dij is COMPLEX (as in the spin-orbit case), 1 if dij is REAL ndij= number of spin components nucdipmom(3) nuclear magnetic dipole moment for current atom pawrad <type(pawrad_type)>=paw radial mesh and related data, for current atom pawtab <type(pawtab_type)>=paw tabulated starting data, for current atom
OUTPUT
dijnd(cplex_dij*lmn2_size,ndij)= nuclear dipole moment Dij terms
cplex_dij=2 must be 2
dij(2*i-1,:) contains the real part,
dij(2*i ,:) contains the imaginary part
NOTES
On-site contribution of a nuclear magnetic dipole moment at $R$. Hamiltonian is $H=(1/2m_e)(p - q_e A)^2 + V$ in SI units, and vector potential $A$ is $A=(\mu_0/4\pi) m\times (r-R)/|r-R|^3 = (\mu_0/4\pi) L_R\cdot m/|r-R|^3$ where $L_R$ is the on-site orbital angular momentum and $m$ is the nuclear magnetic dipole moment. Second order term in A is ignored. In atomic units the on-site term is \alpha^2 L_R\cdot m/|r-R|^3, where \alpha is the fine structure constant.
SOURCE
2395 subroutine pawdijnd(dijnd,cplex_dij,ndij,nucdipmom,pawrad,pawtab) 2396 2397 !Arguments --------------------------------------------- 2398 !scalars 2399 integer,intent(in) :: cplex_dij,ndij 2400 type(pawrad_type),intent(in) :: pawrad 2401 type(pawtab_type),target,intent(in) :: pawtab 2402 !arrays 2403 real(dp),intent(out) :: dijnd(:,:) 2404 real(dp),intent(in) :: nucdipmom(3) 2405 2406 !Local variables --------------------------------------- 2407 !scalars 2408 integer :: idir,ij_size,il,ilmn,im,imesh,jl,jlmn,jm,klmn,kln,lmn2_size,mesh_size 2409 real(dp) :: rr 2410 complex(dpc) :: cmatrixelement,lms 2411 !arrays 2412 integer,pointer :: indlmn(:,:),indklmn(:,:) 2413 real(dp),allocatable :: ff(:),intgr3(:) 2414 character(len=500) :: msg 2415 2416 ! ************************************************************************* 2417 2418 !Useful data 2419 indklmn => pawtab%indklmn 2420 indlmn => pawtab%indlmn 2421 mesh_size=pawtab%mesh_size 2422 ij_size=pawtab%ij_size 2423 lmn2_size=pawtab%lmn2_size 2424 2425 !Check data consistency 2426 if (cplex_dij/=2) then 2427 msg='cplex_dij must be 2 for nuclear dipole moments !' 2428 LIBPAW_BUG(msg) 2429 end if 2430 if (size(dijnd,1)/=cplex_dij*pawtab%lmn2_size.or.size(dijnd,2)/=ndij) then 2431 msg='invalid sizes for Dijnd !' 2432 LIBPAW_BUG(msg) 2433 end if 2434 2435 dijnd = zero 2436 2437 !------------------------------------------------------------------- 2438 ! Computation of (<phi_i|phi_j>-<tphi_i|tphi_j>)/r^3 radial integral 2439 !------------------------------------------------------------------- 2440 2441 LIBPAW_ALLOCATE(intgr3,(ij_size)) 2442 2443 LIBPAW_ALLOCATE(ff,(mesh_size)) 2444 do kln=1,ij_size 2445 do imesh = 2, mesh_size 2446 rr = pawrad%rad(imesh) 2447 ff(imesh)=(pawtab%phiphj(imesh,kln)- pawtab%tphitphj(imesh,kln))/(rr**3) 2448 end do !imesh 2449 call pawrad_deducer0(ff,mesh_size,pawrad) 2450 call simp_gen(intgr3(kln),ff,pawrad) 2451 end do 2452 LIBPAW_DEALLOCATE(ff) 2453 2454 !--------------------------- 2455 ! accumulate matrix elements 2456 !--------------------------- 2457 do klmn=1,lmn2_size 2458 2459 ilmn=indklmn(7,klmn) 2460 jlmn=indklmn(8,klmn) 2461 2462 il=indlmn(1,ilmn) 2463 jl=indlmn(1,jlmn) 2464 2465 im=indlmn(2,ilmn) 2466 jm=indlmn(2,jlmn) 2467 kln=indklmn(2,klmn) 2468 2469 ! Matrix elements of interest are <S_l'm'|L_i|S_lm> 2470 ! these are zero if l' /= l and also if l' == l == 0 2471 if ( il /= jl ) cycle 2472 if ( il == 0 ) cycle 2473 2474 do idir = 1, 3 2475 2476 ! this loop accumulates a dot product so if no dipole moment in direction idir, nothing to do 2477 if( ABS(nucdipmom(idir)) .LT. tol8 ) cycle 2478 2479 call slxyzs(il,im,idir,jl,jm,lms) 2480 2481 cmatrixelement = FineStructureConstant2*lms*nucdipmom(idir)*intgr3(kln) 2482 dijnd(2*klmn-1,1) = dijnd(2*klmn-1,1) + real(cmatrixelement) 2483 dijnd(2*klmn ,1) = dijnd(2*klmn ,1) + aimag(cmatrixelement) 2484 2485 end do ! end loop over idir 2486 2487 end do ! end loop over basis states 2488 2489 LIBPAW_DEALLOCATE(intgr3) 2490 2491 ! in case of ndij > 1, note that there is no spin-flip in this term 2492 ! so therefore down-down = up-up, and up-down and down-up terms are still zero 2493 if(ndij > 1) dijnd(:,2)=dijnd(:,1) 2494 2495 end subroutine pawdijnd
m_pawdij/pawdijso [ Functions ]
[ Top ] [ m_pawdij ] [ Functions ]
NAME
pawdijso
FUNCTION
Compute the spin-orbit contribution to the PAW pseudopotential strength Dij (for one atom only)
INPUTS
cplex_dij=2 if dij is COMPLEX (as in the spin-orbit case), 1 if dij is REAL qphase=2 if dij contains a exp(-i.q.r) phase (as in the q<>0 RF case), 1 if not ndij= number of spin components for Dij^SO nspden=number of spin density components paw_an <type(paw_an_type)>=paw arrays given on angular mesh, for current atom pawang <type(pawang_type)>=paw angular mesh and related data pawrad <type(pawrad_type)>=paw radial mesh and related data, for current atom pawtab <type(pawtab_type)>=paw tabulated starting data, for current atom pawxcdev=Choice of XC development (0=no dev. (use of angular mesh) ; 1 or 2=dev. on moments) spnorbscl=scaling factor for spin-orbit coupling vh1(qphase*mesh_size,v_size,nspden)=all-electron on-site Hartree potential for current atom only spherical moment is used vxc1(qphase*mesh_size,v_size,nspden)=all-electron on-site XC potential for current atom given on a (r,theta,phi) grid (v_size=angl_size) or on (l,m) spherical moments (v_size=lm_size)
OUTPUT
dijso(cplex_dij*qphase*lmn2_size,ndij)= spin-orbit Dij terms
Dij^SO is complex, so cplex_dij=2 must be 2:
dij(2*i-1,:) contains the real part
dij(2*i,:) contains the imaginary part
Dij^SO is represented with 4 components:
dijso(:,:,1) contains Dij_SO^up-up
dijso(:,:,2) contains Dij_SO^dn-dn
dijso(:,:,3) contains Dij_SO^up-dn
dijso(:,:,4) contains Dij_SO^dn-up
When a exp(-i.q.r) phase is included (qphase=2):
dij(1:cplex_dij*lmn2_size,:)
contains the real part of the phase, i.e. D_ij*cos(q.r)
dij(cplex_dij*lmn2_size+1:2*cplex_dij*lmn2_size,:)
contains the imaginary part of the phase, i.e. D_ij*sin(q.r)
SOURCE
2544 subroutine pawdijso(dijso,cplex_dij,qphase,ndij,nspden,& 2545 & pawang,pawrad,pawtab,pawxcdev,spnorbscl,vh1,vxc1) 2546 2547 !Arguments --------------------------------------------- 2548 !scalars 2549 integer,intent(in) :: cplex_dij,ndij,nspden,pawxcdev,qphase 2550 real(dp), intent(in) :: spnorbscl 2551 type(pawang_type),intent(in) :: pawang 2552 !arrays 2553 real(dp),intent(out) :: dijso(:,:) 2554 real(dp),intent(in) :: vh1(:,:,:),vxc1(:,:,:) 2555 type(pawrad_type),intent(in) :: pawrad 2556 type(pawtab_type),target,intent(in) :: pawtab 2557 !Local variables --------------------------------------- 2558 !scalars 2559 integer :: angl_size,idij,ij_size,ilm,ipts,ispden,jlm,klm,klmn,klmn1,kln 2560 integer :: lm_size,lmn2_size,mesh_size,nsploop 2561 real(dp), parameter :: HalfFineStruct2=half/InvFineStruct**2 2562 real(dp) :: fact 2563 character(len=500) :: msg 2564 !arrays 2565 integer, pointer :: indklmn(:,:) 2566 real(dp),allocatable :: dijso_rad(:),dv1dr(:),ff(:) 2567 2568 ! ************************************************************************* 2569 2570 !Useful data 2571 lm_size=pawtab%lcut_size**2 2572 lmn2_size=pawtab%lmn2_size 2573 ij_size=pawtab%ij_size 2574 angl_size=pawang%angl_size 2575 mesh_size=pawtab%mesh_size 2576 indklmn => pawtab%indklmn 2577 nsploop=4 2578 2579 !Check data consistency 2580 if (qphase/=1) then 2581 msg='qphase=2 not yet available in pawdijso!' 2582 LIBPAW_BUG(msg) 2583 end if 2584 if (cplex_dij/=2) then 2585 msg='cplex_dij must be 2 for spin-orbit coupling!' 2586 LIBPAW_BUG(msg) 2587 end if 2588 if (ndij/=4) then 2589 msg='ndij must be 4 for spin-orbit coupling!' 2590 LIBPAW_BUG(msg) 2591 end if 2592 if (pawang%use_ls_ylm==0) then 2593 msg='pawang%use_ls_ylm should be /=0!' 2594 LIBPAW_BUG(msg) 2595 end if 2596 if (size(dijso,1)/=cplex_dij*qphase*lmn2_size.or.size(dijso,2)/=ndij) then 2597 msg='invalid sizes for DijSO!' 2598 LIBPAW_BUG(msg) 2599 end if 2600 if (size(vh1,1)/=qphase*mesh_size.or.size(vh1,2)<1.or.size(vh1,3)<1) then 2601 msg='invalid sizes for vh1!' 2602 LIBPAW_BUG(msg) 2603 end if 2604 if (size(vxc1,1)/=qphase*mesh_size.or.size(vxc1,3)/=nspden.or.& 2605 & (size(vxc1,2)/=angl_size.and.pawxcdev==0).or.& 2606 & (size(vxc1,2)/=lm_size.and.pawxcdev/=0)) then 2607 msg='invalid sizes for vxc1!' 2608 LIBPAW_BUG(msg) 2609 end if 2610 2611 !------------------------------------------------------------------------ 2612 !----------- Allocations and initializations 2613 !------------------------------------------------------------------------ 2614 2615 !Eventually compute <Phi_i|1/r.dV/dr|Phi_j>*alpha2/2*Y_00 (for spin-orbit) 2616 LIBPAW_ALLOCATE(dv1dr,(mesh_size)) 2617 LIBPAW_ALLOCATE(dijso_rad,(ij_size)) 2618 LIBPAW_ALLOCATE(ff,(mesh_size)) 2619 fact=one/sqrt(four_pi) ! Y_00 2620 if (pawxcdev/=0) then 2621 if (nspden==1) then 2622 ff(1:mesh_size)=vxc1(1:mesh_size,1,1) 2623 else 2624 ff(1:mesh_size)=half*(vxc1(1:mesh_size,1,1)+vxc1(1:mesh_size,1,2)) 2625 end if 2626 else 2627 ff(1:mesh_size)=zero 2628 if (nspden==1) then 2629 do ipts=1,angl_size 2630 ff(1:mesh_size)=ff(1:mesh_size) & 2631 & +vxc1(1:mesh_size,ipts,1)*pawang%angwgth(ipts) 2632 end do 2633 else 2634 do ipts=1,angl_size 2635 ff(1:mesh_size)=ff(1:mesh_size) & 2636 & +half*(vxc1(1:mesh_size,ipts,1)+vxc1(1:mesh_size,ipts,2)) & 2637 & *pawang%angwgth(ipts) 2638 end do 2639 end if 2640 ff(1:mesh_size)=sqrt(four_pi)*ff(1:mesh_size) 2641 end if 2642 ff(1:mesh_size)=fact*(ff(1:mesh_size)+vh1(1:mesh_size,1,1)) 2643 call nderiv_gen(dv1dr,ff,pawrad) 2644 dv1dr(2:mesh_size)=HalfFineStruct2*(one/(one-ff(2:mesh_size)*half/InvFineStruct**2)**2) & 2645 & *dv1dr(2:mesh_size)/pawrad%rad(2:mesh_size) 2646 call pawrad_deducer0(dv1dr,mesh_size,pawrad) 2647 do kln=1,ij_size 2648 ff(1:mesh_size)= dv1dr(1:mesh_size)*pawtab%phiphj(1:mesh_size,kln) 2649 call simp_gen(dijso_rad(kln),ff,pawrad) 2650 end do 2651 LIBPAW_DEALLOCATE(dv1dr) 2652 LIBPAW_DEALLOCATE(ff) 2653 dijso_rad(:)=spnorbscl*dijso_rad(:) 2654 2655 !------------------------------------------------------------------------ 2656 !----- Loop over density components 2657 !------------------------------------------------------------------------ 2658 do idij=1,nsploop 2659 2660 ! ------------------------------------------------------------------------ 2661 ! ----- Computation of Dij_so 2662 ! ------------------------------------------------------------------------ 2663 klmn1=1 2664 dijso(:,idij)=zero 2665 if (mod(idij,2)==1) then 2666 ispden=(1+idij)/2 2667 do klmn=1,lmn2_size 2668 if (indklmn(3,klmn)==0) then ! il==jl 2669 klm=indklmn(1,klmn);kln=indklmn(2,klmn) 2670 ilm=indklmn(5,klmn);jlm=indklmn(6,klmn) 2671 fact=dijso_rad(kln);if (ilm>jlm) fact=-fact 2672 dijso(klmn1 ,idij)=fact*pawang%ls_ylm(1,klm,ispden) 2673 dijso(klmn1+1,idij)=fact*pawang%ls_ylm(2,klm,ispden) 2674 end if 2675 klmn1=klmn1+cplex_dij 2676 end do 2677 else if (idij==2) then 2678 do klmn=1,lmn2_size 2679 if (indklmn(3,klmn)==0) then ! il==jl 2680 dijso(klmn1 ,2)=-dijso(klmn1 ,1) 2681 dijso(klmn1+1,2)=-dijso(klmn1+1,1) 2682 end if 2683 klmn1=klmn1+cplex_dij 2684 end do 2685 else if (idij==4) then 2686 do klmn=1,lmn2_size 2687 if (indklmn(3,klmn)==0) then ! il==jl 2688 dijso(klmn1 ,4)=-dijso(klmn1 ,3) 2689 dijso(klmn1+1,4)= dijso(klmn1+1,3) 2690 end if 2691 klmn1=klmn1+cplex_dij 2692 end do 2693 end if 2694 2695 ! ----- End loop over idij 2696 end do 2697 2698 LIBPAW_DEALLOCATE(dijso_rad) 2699 2700 end subroutine pawdijso
m_pawdij/pawdiju [ Functions ]
[ Top ] [ m_pawdij ] [ Functions ]
NAME
pawdiju
FUNCTION
Compute the DFT+U contribution to the PAW pseudopotential strength Dij, (for one atom only): Dijpawu^{\sigma}_{mi,ni,mj,nj}= \sum_{m,m'} [vpawu^{\sigma}_{m,m'}*phiphjint_{ni,nj}^{m,m'}]= [vpawu^{\sigma}_{mi,mj}*phiphjint_{ni,nj}]
INPUTS
cplex_dij=2 if dij is COMPLEX (as in the spin-orbit case), 1 if dij is REAL qphase=2 if dij contains a exp(-i.q.r) phase (as in the q<>0 RF case), 1 if not ndij= number of spin components nsppol=number of independent spin WF components pawtab <type(pawtab_type)>=paw tabulated starting data, for current atom vpawu(cplex_dij,lpawu*2+1,lpawu*2+1,ndij)=moments of DFT+U potential for current atom --- Optional arguments --- atvshift(natvshift,nsppol)=potential energy shift for lm channel & spin (current atom) fatvshift=factor that multiplies atvshift natvshift=number of atomic potential energy shifts (per atom)
OUTPUT
dijpawu(cplex_dij*qphase*lmn2_size,ndij)= D_ij^U terms
When Dij is complex (cplex_dij=2):
dij(2*i-1,:) contains the real part, dij(2*i,:) contains the imaginary part
When a exp(-i.q.r) phase is included (qphase=2):
dij(1:cplex_dij*lmn2_size,:)
contains the real part of the phase, i.e. D_ij*cos(q.r)
dij(cplex_dij*lmn2_size+1:2*cplex_dij*lmn2_size,:)
contains the imaginary part of the phase, i.e. D_ij*sin(q.r)
SOURCE
2741 subroutine pawdiju(dijpawu,cplex_dij,qphase,ndij,nsppol,pawtab,vpawu,& 2742 & natvshift,atvshift,fatvshift) ! optional arguments 2743 2744 !Arguments --------------------------------------------- 2745 !scalars 2746 integer,intent(in) :: cplex_dij,ndij,nsppol,qphase 2747 integer,intent(in),optional :: natvshift 2748 real(dp),intent(in),optional :: fatvshift 2749 !arrays 2750 real(dp),intent(out) :: dijpawu(:,:) 2751 real(dp),intent(in) :: vpawu(:,:,:,:) 2752 real(dp),intent(in),optional :: atvshift(:,:) 2753 type(pawtab_type),intent(in) :: pawtab 2754 2755 !Local variables --------------------------------------- 2756 !scalars 2757 integer :: icount,idij,idijeff,idijend,im1,im2,in1,in2,klmn,klmn1,lmax,lmin,lmn2_size 2758 integer :: lpawu,natvshift_,nsploop 2759 character(len=500) :: msg 2760 !arrays 2761 real(dp),allocatable :: coeffpawu(:),dijpawu_idij(:),dijsymU(:,:) 2762 2763 ! ************************************************************************* 2764 2765 !Useful data 2766 lpawu=pawtab%lpawu 2767 lmn2_size=pawtab%lmn2_size 2768 natvshift_=0;if (present(natvshift)) natvshift_=natvshift 2769 2770 !Check data consistency 2771 if (qphase/=1) then 2772 msg='qphase=2 not available in pawdiju!' 2773 LIBPAW_BUG(msg) 2774 end if 2775 if (size(dijpawu,1)/=cplex_dij*qphase*lmn2_size.or.size(dijpawu,2)/=ndij) then 2776 msg='invalid sizes for dijpawu !' 2777 LIBPAW_BUG(msg) 2778 end if 2779 if (size(vpawu,1)/=cplex_dij.or.size(vpawu,2)/=2*lpawu+1.or.& 2780 & size(vpawu,3)/=2*lpawu+1.or.size(vpawu,4)/=ndij) then 2781 msg='invalid sizes for vpawu !' 2782 LIBPAW_BUG(msg) 2783 end if 2784 if (natvshift_>0) then 2785 if ((.not.present(atvshift)).or.(.not.present(fatvshift))) then 2786 msg='when natvshift>0, atvshift and fatvshift arguments must be present !' 2787 LIBPAW_BUG(msg) 2788 end if 2789 if (size(atvshift,1)/=natvshift.or.size(atvshift,2)/=nsppol) then 2790 msg='invalid sizes for atvshift !' 2791 LIBPAW_BUG(msg) 2792 end if 2793 end if 2794 2795 !Init memory 2796 dijpawu=zero 2797 LIBPAW_ALLOCATE(dijpawu_idij,(cplex_dij*lmn2_size)) 2798 LIBPAW_ALLOCATE(coeffpawu,(cplex_dij)) 2799 if (ndij==4) then 2800 LIBPAW_ALLOCATE(dijsymU,(cplex_dij*lmn2_size,4)) 2801 end if 2802 2803 !Loop over spin components 2804 !---------------------------------------------------------- 2805 nsploop=nsppol;if (ndij==4) nsploop=4 2806 do idij=1,nsploop 2807 if (idij<=nsppol.or.(ndij==4.and.idij<=3)) then 2808 2809 idijend=idij+idij/3 2810 do idijeff=idij,idijend ! if ndij==4, idijeff is used to compute updn and dnup contributions 2811 2812 dijpawu_idij=zero 2813 2814 ! Loop over (l,m,n) moments 2815 ! ---------------------------------------------------------- 2816 klmn1=1 2817 do klmn=1,lmn2_size 2818 im1=pawtab%klmntomn(1,klmn) 2819 im2=pawtab%klmntomn(2,klmn) 2820 lmin=pawtab%indklmn(3,klmn) 2821 lmax=pawtab%indklmn(4,klmn) 2822 2823 ! Select l=lpawu 2824 if (lmin==0.and.lmax==2*lpawu) then 2825 2826 ! Check consistency 2827 in1=pawtab%klmntomn(3,klmn) 2828 in2=pawtab%klmntomn(4,klmn) 2829 icount=in1+(in2*(in2-1))/2 2830 if (pawtab%ij_proj<icount) then 2831 msg='DFT+U: Problem while computing dijexxc !' 2832 LIBPAW_BUG(msg) 2833 end if 2834 2835 ! coeffpawu(:)=vpawu(:,im1,im2,idijeff) ! use real and imaginary part 2836 coeffpawu(:)=vpawu(:,im2,im1,idijeff) ! because of transposition in setnoccmmp (for the cplex_dij==2) 2837 2838 if (natvshift_/=0.and.idij<3.and.im1==im2) then 2839 coeffpawu(1)=coeffpawu(1)+fatvshift*atvshift(im1,idij) 2840 end if 2841 if (cplex_dij==1) then !cplex_dij=nspinor=1 2842 dijpawu_idij(klmn1)=pawtab%phiphjint(icount)*coeffpawu(1) 2843 elseif (cplex_dij==2) then !cplex_dij=nspinor=2 2844 dijpawu_idij(klmn1 )=pawtab%phiphjint(icount)*coeffpawu(1) 2845 dijpawu_idij(klmn1+1)=pawtab%phiphjint(icount)*coeffpawu(2) ! spinor==2 2846 end if 2847 2848 end if ! l selection 2849 klmn1=klmn1+cplex_dij 2850 end do ! klmn 2851 2852 dijpawu(:,idij)=dijpawu_idij(:) 2853 if (ndij==4) dijsymU(:,idijeff)=dijpawu_idij(:) 2854 2855 end do ! idijeff 2856 2857 end if ! idij 2858 2859 if (ndij==4.or.cplex_dij==2) then 2860 if (idij<=2) then 2861 dijpawu(:,idij)=dijpawu(:,idij) 2862 else 2863 dijpawu(:,idij)=dijsymU(:,idij) 2864 end if 2865 end if 2866 2867 !End loop over spin components 2868 !---------------------------------------------------------- 2869 end do 2870 2871 !Free temporary memory spaces 2872 LIBPAW_DEALLOCATE(dijpawu_idij) 2873 LIBPAW_DEALLOCATE(coeffpawu) 2874 if (ndij==4) then 2875 LIBPAW_DEALLOCATE(dijsymU) 2876 end if 2877 2878 end subroutine pawdiju
m_pawdij/pawdiju_euijkl [ Functions ]
[ Top ] [ m_pawdij ] [ Functions ]
NAME
pawdiju_euijkl
FUNCTION
Compute the DFT+U contribution to the PAW pseudopotential strength Dij (for one atom only). Alternative to pawdiju using the following property: D_ij^pawu^{\sigma}_{mi,ni,mj,nj}=\sum_{k,l} [rho^{\sigma}_kl*e^U_ijkl] The routine structure is similar to pawdijhartree.
INPUTS
cplex_dij=2 if dij is COMPLEX (as in the spin-orbit case), 1 if dij is REAL qphase=2 if dij contains a exp(-i.q.r) phase (as in the q<>0 RF case), 1 if not nspden=number of spin density components pawrhoij <type(pawrhoij_type)>= paw rhoij occupancies (and related data) for current atom pawtab <type(pawtab_type)>=paw tabulated starting data, for current atom
OUTPUT
diju(cplex_dij*qphase*lmn2_size,ndij)= D_ij^U terms
diju_im(cplex_dij*qphase*lmn2_size,ndij)= (see below)
When Dij is complex (cplex_dij=2):
dij(2*i-1,:) contains the real part, dij(2*i,:) contains the imaginary part
When a exp(-i.q.r) phase is included (qphase=2):
dij(1:cplex_dij*lmn2_size,:)
contains the real part of the phase, i.e. D_ij*cos(q.r)
dij(cplex_dij*lmn2_size+1:2*cplex_dij*lmn2_size,:)
contains the imaginary part of the phase, i.e. D_ij*sin(q.r)
NOTES
There are some subtleties :
Contrary to eijkl, eu_ijkl is not invariant with respect to the permutation of i <--> j or k <--> l.
Also, we have to deal with spin polarization.
In the non-collinear magnetism case, the correct expression of Dij^st (s and t being spin indexes) is:
D_kl^st = delta_st sum_ij rho_ij^ss eu_ijkl(1)
+ delta_st sum_ij rho_ij^-s-s eu_ijkl(2)
+ (1-delta_st) sum_ij rho_ij^st eu_ijkl(3)
As only the lower triangular part of the Dij matrix is stored (i<=j), in practice we have:
D_kl^st = delta_st sum_i<=j ( rho_ij^ss eu_ijkl(1) + (1-delta_ij) rho_ji^ss eu_jikl(1) )
+ delta_st sum_i<=j ( rho_ij^-s-s eu_ijkl(2) + (1-delta_ij) rho_ji^-s-s eu_jikl(2) )
+ (1-delta_st) sum_i<=j ( rho_ij^st eu_ijkl(3) + (1-delta_ij) rho_ji^st eu_jikl(3) )
In the following, we will use that: (according to the rules in pawpuxinit.F90)
(a) eu_ijkl + eu_jikl = eu_ijlk + eu_jilk (invariant when exchanging k <--> l)
(b) eu_ijkl - eu_jikl = - eu_ijlk + eu_jilk (change of sign when exchanging k <--> l)
and :
(c) eu_iikl = eu_iilk (if i=j, invariant when exchanging k <--> l)
(d) eu_ijkk = eu_jikk (if k=l, invariant when exchanging i <--> j)
qphase=1 (ipert=0 or q=0):
--------------------------
--- Non-collinear case:
We have:
rho_ji^st = (rho_ij^ts)^*
Re(rho_ji^st) = Re(rho_ij^ts)
Im(rho_ji^st) = -Im(rho_ij^ts)
As eu_ijkl is real one gets:
Re(D_kl^st) = delta_st sum_i<=j Re(rho_ij^ss) ( eu_ijkl(1) + (1-delta_ij) eu_jikl(1) )
+ delta_st sum_i<=j Re(rho_ij^-s-s) ( eu_ijkl(2) + (1-delta_ij) eu_jikl(2) )
+ (1-delta_st) sum_i<=j ( Re(rho_ij^st) eu_ijkl(3) + (1-delta_ij) Re(rho_ij^ts) eu_jikl(3) )
Im(D_kl^st) = delta_st sum_i<=j Im(rho_ij^ss) ( eu_ijkl(1) - (1-delta_ij) eu_jikl(1) )
+ delta_st sum_i<=j Im(rho_ij^-s-s) ( eu_ijkl(2) - (1-delta_ij) eu_jikl(2) )
+ (1-delta_st) sum_i<=j ( Im(rho_ij^st) eu_ijkl(3) - (1-delta_ij) Im(rho_ij^ts) eu_jikl(3) )
--- Collinear case:
Re(D_kl^s) = sum_i<=j Re(rho_ij^s) ( eu_ijkl(1) + (1-delta_ij) eu_jikl(1) )
+ sum_i<=j Re(rho_ij^-s) ( eu_ijkl(2) + (1-delta_ij) eu_jikl(2) )
Im(D_kl^s) = sum_i<=j Im(rho_ij^s) ( eu_ijkl(1) - (1-delta_ij) eu_jikl(1) )
+ sum_i<=j Im(rho_ij^-s) ( eu_ijkl(2) - (1-delta_ij) eu_jikl(2) )
Using (a) and (c) one gets:
Re(D_kl^s) = Re(D_lk^s)
Using (b) and (c) one gets:
Im(D_kl^s) = -Im(D_lk^s)
--- Without magnetism (rho_ij^up = rho_ij^down = 1/2 rho_ij^tot):
Re(D_kl) = 1/2 sum_i<=j Re(rho_ij) ( eu_ijkl(1) + eu_ijkl(2) + (1-delta_ij) ( eu_jikl(1) + euijkl(2) ) )
Im(D_kl) = 1/2 sum_i<=j Im(rho_ij) ( eu_ijkl(1) + eu_ijkl(2) - (1-delta_ij) ( eu_jikl(1) + euijkl(2) ) )
qphase=2 (ipert>0 and q/=0) - no magnetism or collinear:
-------------------------------------------------------
We have:
rho_ji = rhoA_ji + rhoB_ji
where:
rhoA_ji = rhoA_ij^*
rhoB_ji = rhoB_ij
So:
D_kl = sum_i<=j ( rho_ij eu_ijkl + (1-delta_ij) (rhoA_ij^* + rhoB_ij) eu_jikl )
As eu_ijkl is real:
Re(D_kl) = sum_i<=j Re(rho_ij) ( eu_ijkl + (1-delta_ij) eu_jikl )
Im(D_kl) = sum_i<=j Im(rhoB_ij) ( eu_ijkl + (1-delta_ij) eu_jikl )
+ sum_i<=j Im(rhoA_ij) ( eu_ijkl - (1-delta_ij) eu_jikl )
We note:
Im(D_kl^A) = sum_i<=j Im(rhoA_ij) ( eu_ijkl - (1-delta_ij) eu_jikl )
Im(D_kl^B) = sum_i<=j Im(rhoB_ij) ( eu_ijkl + (1-delta_ij) eu_jikl )
We still have:
Re(D_kl) = Re(D_lk)
but:
Im(D_kl^A) = -Im(D_lk^A) ( using (b) and (c) )
Im(D_kl^B) = Im(D_lk^B) ( using (a) and (c) )
SOURCE
2997 subroutine pawdiju_euijkl(diju,cplex_dij,qphase,ndij,pawrhoij,pawtab) 2998 2999 !Arguments --------------------------------------------- 3000 !scalars 3001 integer,intent(in) :: cplex_dij,ndij,qphase 3002 !arrays 3003 real(dp),intent(out) :: diju(:,:) 3004 type(pawrhoij_type),intent(in) :: pawrhoij 3005 type(pawtab_type),intent(in) :: pawtab 3006 3007 !Local variables --------------------------------------- 3008 !scalars 3009 integer :: cplex_rhoij,iq,iq0_dij,iq0_rhoij,ilmn,ilmnp,irhoij,j0lmnp,jlmn,jlmnp,jrhoij,select_euijkl 3010 integer :: klmn,klmnp,klmn1,lmn2_size,max_euijkl,min_euijkl,sig1,sig2,sig2p 3011 logical :: compute_im 3012 character(len=500) :: msg 3013 !arrays 3014 real(dp) :: ro(2,ndij),euijkl_temp(3,2) 3015 3016 ! ************************************************************************* 3017 3018 !Check data consistency 3019 lmn2_size=pawrhoij%lmn2_size 3020 if (size(diju,1)/=qphase*cplex_dij*lmn2_size.or.size(diju,2)/=ndij) then 3021 msg='invalid sizes for diju!' 3022 LIBPAW_BUG(msg) 3023 end if 3024 if (pawrhoij%qphase<qphase) then 3025 msg='pawrhoij%qphase must be >=qphase!' 3026 LIBPAW_BUG(msg) 3027 end if 3028 if (ndij/=pawrhoij%nspden) then 3029 msg='pawrhoij%nspden must be equal to ndij!' 3030 LIBPAW_BUG(msg) 3031 end if 3032 3033 !Initialization 3034 diju=zero 3035 cplex_rhoij=pawrhoij%cplex_rhoij 3036 compute_im=(cplex_dij==2) 3037 3038 !Loop over spin-components (Dij) 3039 do sig1=1,ndij 3040 3041 if (sig1<=2) then 3042 min_euijkl = 1 3043 max_euijkl = 2 3044 else 3045 min_euijkl = 3 3046 max_euijkl = 3 3047 end if 3048 3049 !Loop over phase exp(iqr) phase real/imaginary part 3050 do iq=1,qphase 3051 !First loop: we store the real part in dij(1 -> lmn2_size) 3052 !2nd loop: we store the imaginary part in dij(lmn2_size+1 -> 2*lmn2_size) 3053 iq0_dij=merge(0,cplex_dij*lmn2_size,iq==1) 3054 iq0_rhoij=merge(0,cplex_rhoij*lmn2_size,iq==1) 3055 3056 !Loop over rhoij elements 3057 jrhoij=iq0_rhoij+1 3058 do irhoij=1,pawrhoij%nrhoijsel 3059 klmn=pawrhoij%rhoijselect(irhoij) 3060 ilmn=pawtab%indklmn(7,klmn) 3061 jlmn=pawtab%indklmn(8,klmn) 3062 3063 !Storage of rhoij in ro (with a change of representation if nspinor=2) 3064 if (ndij==1) then ! rho_up = rho_down = 1/2 rho_tot 3065 ro(1:cplex_rhoij,1)=half*pawrhoij%rhoijp(jrhoij:jrhoij+cplex_rhoij-1,1) 3066 else if (ndij==2) then 3067 do sig2=1,ndij 3068 ro(1:cplex_rhoij,sig2)=pawrhoij%rhoijp(jrhoij:jrhoij+cplex_rhoij-1,sig2) 3069 end do 3070 else ! ndij=4 3071 !up up = 1/2 ( tot + z ) 3072 ro(1:cplex_rhoij,1)=half*(pawrhoij%rhoijp(jrhoij:jrhoij+cplex_rhoij-1,1)+pawrhoij%rhoijp(jrhoij:jrhoij+cplex_rhoij-1,4)) 3073 !down down = 1/2 ( tot - z ) 3074 ro(1:cplex_rhoij,2)=half*(pawrhoij%rhoijp(jrhoij:jrhoij+cplex_rhoij-1,1)-pawrhoij%rhoijp(jrhoij:jrhoij+cplex_rhoij-1,4)) 3075 if (cplex_rhoij==1) ro(2,1:2) = zero 3076 !up down = 1/2 ( x - i y ) 3077 ro(1,3)= half*pawrhoij%rhoijp(jrhoij,2) 3078 ro(2,3)=-half*pawrhoij%rhoijp(jrhoij,3) 3079 if (cplex_rhoij==2) then 3080 ro(1,3)=ro(1,3)+half*pawrhoij%rhoijp(jrhoij+1,3) 3081 ro(2,3)=ro(2,3)+half*pawrhoij%rhoijp(jrhoij+1,2) 3082 end if 3083 !down up = 1/2 ( x + i y ) 3084 ro(1,4)=half*pawrhoij%rhoijp(jrhoij,2) 3085 ro(2,4)=half*pawrhoij%rhoijp(jrhoij,3) 3086 if (cplex_rhoij==2) then 3087 ro(1,4)=ro(1,4)-half*pawrhoij%rhoijp(jrhoij+1,3) 3088 ro(2,4)=ro(2,4)+half*pawrhoij%rhoijp(jrhoij+1,2) 3089 end if 3090 end if 3091 3092 do jlmnp=1,pawtab%lmn_size 3093 j0lmnp=jlmnp*(jlmnp-1)/2 3094 do ilmnp=1,jlmnp 3095 klmnp=j0lmnp+ilmnp 3096 klmn1=iq0_dij+cplex_dij*(klmnp-1)+1 3097 3098 euijkl_temp(:,1) = pawtab%euijkl(:,ilmn,jlmn,ilmnp,jlmnp) 3099 euijkl_temp(:,2) = pawtab%euijkl(:,jlmn,ilmn,ilmnp,jlmnp) 3100 3101 !Loop over spin-components (rhoij) 3102 do select_euijkl=min_euijkl,max_euijkl 3103 if (sig1<=2) then ! up/up and down/down Dij components 3104 if (ndij==1) then 3105 sig2=1 3106 else 3107 if (select_euijkl==1) then ! Diagonal part of the spin matrix 3108 sig2=sig1 3109 else if (select_euijkl==2) then ! Non-diagonal part 3110 if (sig1==1) sig2=2 3111 if (sig1==2) sig2=1 3112 end if 3113 end if 3114 sig2p = sig2 3115 else ! select_euijkl = 3 3116 sig2 = sig1 3117 if (sig1==3) sig2p=4 3118 if (sig1==4) sig2p=3 3119 end if 3120 !Re(D_kl) = sum_i<=j Re(rho_ij) ( eu_ijlk + (1-delta_ij) eu_jilk ) = Re(D_lk) 3121 diju(klmn1,sig1)=diju(klmn1,sig1)+ro(1,sig2)*euijkl_temp(select_euijkl,1) 3122 if (ilmn/=jlmn) then 3123 diju(klmn1,sig1)=diju(klmn1,sig1)+ro(1,sig2p)*euijkl_temp(select_euijkl,2) 3124 end if 3125 !Im(D_kl) = sum_i<=j Im(rho_ij) ( eu_ijlk - (1-delta_ij) eu_jilk ) = -Im(D_lk) 3126 if (compute_im) then 3127 diju(klmn1+1,sig1)=diju(klmn1+1,sig1)+ro(2,sig2)*euijkl_temp(select_euijkl,1) 3128 if (ilmn/=jlmn) then 3129 diju(klmn1+1,sig1)=diju(klmn1+1,sig1)-ro(2,sig2p)*euijkl_temp(select_euijkl,2) 3130 end if 3131 end if 3132 end do 3133 3134 end do 3135 end do ! k,l 3136 3137 jrhoij=jrhoij+cplex_rhoij 3138 end do ! i,j 3139 3140 end do ! q phase 3141 3142 end do !sig1 3143 3144 end subroutine pawdiju_euijkl
m_pawdij/pawdijxc [ Functions ]
[ Top ] [ m_pawdij ] [ Functions ]
NAME
pawdijxc
FUNCTION
Compute the eXchange-Correlation contribution to the PAW pseudopotential strength Dij, using densities and potential expressed on a (r,theta,phi) grid (for one atom only): D_ij^XC= < Phi_i|Vxc( n1+ nc[+nhat])| Phi_j> -<tPhi_i|Vxc(tn1+tnc[+nhat])|tPhi_j> -Intg_omega [ Vxc(tn1+tnc[+nhat])(r). Sum_L(Qij^L(r)). dr]
INPUTS
cplex_dij=2 if dij is COMPLEX (as in the spin-orbit case), 1 if dij is REAL qphase=2 if dij contains a exp(-i.q.r) phase (as in the q<>0 RF case), 1 if not ndij= number of spin components nspden=number of spin density components nsppol=number of independent spin WF components pawang <type(pawang_type)>=paw angular mesh and related data, for current atom pawrad <type(pawrad_type)>=paw radial mesh and related data, for current atom pawtab <type(pawtab_type)>=paw tabulated starting data usekden=1 if kinetic energy density contribution has to be included (mGGA) usexcnhat= 1 if compensation density is included in Vxc, 0 otherwise vxc1(qphase*mesh_size,angl_size,nspden)=all-electron on-site XC potential for current atom given on a (r,theta,phi) grid vxct1(qphase*mesh_size,angl_size,nspden)=all-electron on-site XC potential for current atom given on a (r,theta,phi) grid [vxctau1(qphase*mesh_size,angl_size,nspden)]=1st deriv. of XC energy wrt to kinetic energy density (all electron) - metaGGA only [vxcttau1(qphase*mesh_size,angl_size,nspden)]=1st deriv. of XC energy wrt to kinetic energy density (pseudo) - metaGGA only
OUTPUT
dijxc(cplex_dij*qphase*lmn2_size,ndij)= D_ij^XC terms
When Dij is complex (cplex_dij=2):
dij(2*i-1,:) contains the real part, dij(2*i,:) contains the imaginary part
When a exp(-i.q.r) phase is included (qphase=2):
dij(1:cplex_dij*lmn2_size,:)
contains the real part of the phase, i.e. D_ij*cos(q.r)
dij(cplex_dij*lmn2_size+1:2*cplex_dij*lmn2_size,:)
contains the imaginary part of the phase, i.e. D_ij*sin(q.r)
SOURCE
1444 subroutine pawdijxc(dijxc,cplex_dij,qphase,ndij,nspden,nsppol,& 1445 & pawang,pawrad,pawtab,vxc1,vxct1,usexcnhat,usekden,& 1446 & vxctau1,vxcttau1) ! optional 1447 1448 !Arguments --------------------------------------------- 1449 !scalars 1450 integer,intent(in) :: cplex_dij,ndij,nspden,nsppol,qphase,usekden,usexcnhat 1451 type(pawang_type),intent(in) :: pawang 1452 !arrays 1453 real(dp),intent(in) :: vxc1(:,:,:),vxct1(:,:,:) 1454 real(dp),intent(in),optional :: vxctau1(:,:,:),vxcttau1(:,:,:) 1455 real(dp),intent(out) :: dijxc(:,:) 1456 type(pawrad_type),intent(in) :: pawrad 1457 type(pawtab_type),intent(in) :: pawtab 1458 1459 !Local variables --------------------------------------- 1460 !scalars 1461 integer :: angl_size,basis_size,idij,idijend 1462 integer :: ii,ij_size,ilm,ils,ils1,ilslm,ipts,ir,ir1,isel,ispden 1463 integer :: jlm,j0lm,klmn1,klmn2,klmn,klm,kln,l_size,lm0,lmax,lmin,lm_size,lmn2_size 1464 integer :: iln,jln,j0ln 1465 integer :: mesh_size,mm,nsploop 1466 real(dp) :: tmp,vi,vr,vxcijhat,vxcijhat_i,vxctauij 1467 character(len=500) :: msg 1468 !arrays 1469 real(dp),allocatable :: dijxc_idij(:),ff(:),gg(:) 1470 real(dp),allocatable :: vxcij1(:),vxcij2(:),vxctauij1(:),yylmr(:,:),yylmgr(:,:) 1471 1472 ! ************************************************************************* 1473 1474 !Useful data 1475 lm_size=pawtab%lcut_size**2 1476 lmn2_size=pawtab%lmn2_size 1477 basis_size=pawtab%basis_size 1478 ij_size=pawtab%ij_size 1479 l_size=pawtab%l_size 1480 mesh_size=pawtab%mesh_size 1481 angl_size=pawang%angl_size 1482 1483 !Check data consistency 1484 if (size(dijxc,1)/=cplex_dij*qphase*lmn2_size.or.size(dijxc,2)/=ndij) then 1485 msg='invalid sizes for Dijxc !' 1486 LIBPAW_BUG(msg) 1487 end if 1488 if (size(vxc1,1)/=qphase*mesh_size.or.size(vxct1,1)/=qphase*mesh_size.or.& 1489 & size(vxc1,2)/=angl_size.or.size(vxct1,2)/=angl_size.or.& 1490 & size(vxc1,3)/=nspden.or.size(vxct1,3)/=nspden) then 1491 msg='invalid sizes for vxc1 or vxct1 !' 1492 LIBPAW_BUG(msg) 1493 end if 1494 1495 !Check if MetaGGA is activated 1496 if (usekden==1) then 1497 if (.not.present(vxctau1)) then 1498 msg="vxctau1 needs to be present!" 1499 LIBPAW_BUG(msg) 1500 else if (size(vxctau1)==0) then 1501 msg="vxctau1 needs to be allocated!" 1502 LIBPAW_BUG(msg) 1503 end if 1504 if (.not.present(vxcttau1)) then 1505 msg="vxcttau1 needs to be present!" 1506 LIBPAW_BUG(msg) 1507 else if (size(vxcttau1)==0) then 1508 msg="vxcttau1 needs to be allocated!" 1509 LIBPAW_BUG(msg) 1510 end if 1511 end if 1512 1513 !Precompute products Ylm*Ylpmp (and Grad(Ylm).Grad(Ylpmp) if mGGA) 1514 lmax=1+maxval(pawtab%indklmn(4,1:lmn2_size)) 1515 LIBPAW_ALLOCATE(yylmr,(lmax**2*(lmax**2+1)/2,angl_size)) 1516 LIBPAW_ALLOCATE(yylmgr,(lmax**2*(lmax**2+1)/2,angl_size*usekden)) 1517 do ipts=1,angl_size 1518 do jlm=1,lmax**2 1519 j0lm=jlm*(jlm-1)/2 1520 do ilm=1,jlm 1521 klm=j0lm+ilm 1522 yylmr(klm,ipts)=pawang%ylmr(ilm,ipts)*pawang%ylmr(jlm,ipts) 1523 end do 1524 end do 1525 end do 1526 if (usekden==1) then 1527 yylmgr(:,:)=zero 1528 do ipts=1,angl_size 1529 do jlm=1,lmax**2 1530 j0lm=jlm*(jlm-1)/2 1531 do ilm=1,jlm 1532 klm=j0lm+ilm 1533 do ii=1,3 1534 yylmgr(klm,ipts)=yylmgr(klm,ipts) & 1535 & +pawang%ylmrgr(ii,ilm,ipts)*pawang%ylmrgr(ii,jlm,ipts) 1536 end do 1537 end do 1538 end do 1539 end do 1540 end if 1541 1542 !Init memory 1543 dijxc=zero 1544 LIBPAW_ALLOCATE(dijxc_idij,(qphase*lmn2_size)) 1545 LIBPAW_ALLOCATE(vxcij1,(qphase*ij_size)) 1546 LIBPAW_ALLOCATE(vxcij2,(qphase*l_size)) 1547 LIBPAW_ALLOCATE(vxctauij1,(qphase*ij_size*usekden)) 1548 LIBPAW_ALLOCATE(ff,(mesh_size)) 1549 LIBPAW_ALLOCATE(gg,(mesh_size)) 1550 vxcij1=zero;vxcij2=zero;vxctauij1=zero 1551 1552 !---------------------------------------------------------- 1553 !Loop over spin components 1554 !---------------------------------------------------------- 1555 nsploop=nsppol;if (ndij==4) nsploop=4 1556 do idij=1,nsploop 1557 if (idij<=nsppol.or.(nspden==4.and.idij<=3)) then 1558 1559 idijend=idij+idij/3 1560 do ispden=idij,idijend 1561 1562 dijxc_idij=zero 1563 1564 ! ---------------------------------------------------------- 1565 ! Loop on angular mesh 1566 ! ---------------------------------------------------------- 1567 do ipts=1,angl_size 1568 1569 ! ===== Vxc_ij_1 (tmp) ===== 1570 vxcij1=zero 1571 if (qphase==1) then 1572 do kln=1,ij_size 1573 ff(1:mesh_size)= & 1574 & vxc1(1:mesh_size,ipts,ispden)*pawtab%phiphj(1:mesh_size,kln) & 1575 & -vxct1(1:mesh_size,ipts,ispden)*pawtab%tphitphj(1:mesh_size,kln) 1576 call simp_gen(vxcij1(kln),ff,pawrad) 1577 end do 1578 !if Meta GGA add 1/2*[<nabla_phi_i|vxctau1|nabla_phi_j> 1579 ! -<nabla_tphi_i|vxcttau1|nabla_tphi_j>] 1580 if (usekden==1) then 1581 do jln=1,basis_size 1582 j0ln=jln*(jln-1)/2 1583 do iln=1,jln 1584 kln=j0ln+iln 1585 ff(2:mesh_size)=(vxctau1(2:mesh_size,ipts,ispden)*pawtab%phiphj(2:mesh_size,kln) & 1586 & -vxcttau1(2:mesh_size,ipts,ispden)*pawtab%tphitphj(2:mesh_size,kln)) & 1587 & /pawrad%rad(2:mesh_size)**2 1588 call pawrad_deducer0(ff,mesh_size,pawrad) 1589 call simp_gen(vxctauij1(kln),ff,pawrad) 1590 ff(1:mesh_size)=vxctau1(1:mesh_size,ipts,ispden) & 1591 & *pawtab%nablaphi(1:mesh_size,iln)*pawtab%nablaphi(1:mesh_size,jln) & 1592 & -vxcttau1(1:mesh_size,ipts,ispden) & 1593 & *pawtab%tnablaphi(1:mesh_size,iln)*pawtab%tnablaphi(1:mesh_size,jln) 1594 call simp_gen(vxctauij,ff,pawrad) 1595 vxcij1(kln)=vxcij1(kln)+half*vxctauij 1596 end do 1597 end do 1598 end if 1599 1600 else 1601 do kln=1,ij_size 1602 do ir=1,mesh_size 1603 ir1=2*ir 1604 ff(ir)= & 1605 & vxc1(ir1-1,ipts,ispden)*pawtab%phiphj(ir,kln) & 1606 & -vxct1(ir1-1,ipts,ispden)*pawtab%tphitphj(ir,kln) 1607 gg(ir)= & 1608 & vxc1(ir1,ipts,ispden)*pawtab%phiphj(ir,kln) & 1609 & -vxct1(ir1,ipts,ispden)*pawtab%tphitphj(ir,kln) 1610 end do 1611 call simp_gen(vxcij1(2*kln-1),ff,pawrad) 1612 call simp_gen(vxcij1(2*kln ),gg,pawrad) 1613 end do 1614 !if Meta GGA add 1/2*[<nabla_phi_i|vxctau1|nabla_phi_j> 1615 ! -<nabla_tphi_i|vxcttau|nabla_tphi_j>] 1616 if (usekden==1) then 1617 do jln=1,basis_size 1618 j0ln=jln*(jln-1)/2 1619 do iln=1,jln 1620 kln=j0ln+iln 1621 do ir=2,mesh_size 1622 ir1=2*ir 1623 ff(ir)=vxctau1(ir1-1,ipts,ispden)*pawtab%phiphj(ir,kln) & 1624 & -vxcttau1(ir1-1,ipts,ispden)*pawtab%tphitphj(ir,kln) 1625 gg(ir)=vxctau1(ir1,ipts,ispden)*pawtab%phiphj(ir,kln) & 1626 & -vxcttau1(ir1,ipts,ispden)*pawtab%tphitphj(ir,kln) 1627 end do 1628 call pawrad_deducer0(ff,mesh_size,pawrad) 1629 call pawrad_deducer0(gg,mesh_size,pawrad) 1630 call simp_gen(vxctauij1(2*kln-1),ff,pawrad) 1631 call simp_gen(vxctauij1(2*kln ),gg,pawrad) 1632 do ir=1,mesh_size 1633 ir1=2*ir 1634 ff(ir)=vxctau1(ir1-1,ipts,ispden) & 1635 & *pawtab%nablaphi(ir,iln)*pawtab%nablaphi(ir,jln) & 1636 & -vxcttau1(ir1-1,ipts,ispden) & 1637 & *pawtab%tnablaphi(ir,iln)*pawtab%tnablaphi(ir,jln) 1638 gg(ir)=vxctau1(ir1,ipts,ispden) & 1639 & *pawtab%nablaphi(ir,iln)*pawtab%nablaphi(ir,jln) & 1640 & -vxcttau1(ir1,ipts,ispden) & 1641 & *pawtab%tnablaphi(ir,iln)*pawtab%tnablaphi(ir,jln) 1642 end do 1643 call simp_gen(vxctauij,ff,pawrad) 1644 vxcij1(2*kln-1)=vxcij1(2*kln-1)+half*vxctauij 1645 call simp_gen(vxctauij,gg,pawrad) 1646 vxcij1(2*kln)=vxcij1(2*kln)+half*vxctauij 1647 end do 1648 end do 1649 end if 1650 1651 end if 1652 1653 ! ===== Vxc_ij_2 (tmp) ===== 1654 vxcij2=zero 1655 if (usexcnhat/=0) then 1656 if (qphase==1) then 1657 do ils=1,l_size 1658 ff(1:mesh_size)=vxct1(1:mesh_size,ipts,ispden) & 1659 & *pawtab%shapefunc(1:mesh_size,ils) & 1660 & *pawrad%rad(1:mesh_size)**2 1661 call simp_gen(vxcij2(ils),ff,pawrad) 1662 end do 1663 else 1664 do ils=1,l_size 1665 do ir=1,mesh_size 1666 ir1=2*ir 1667 tmp=pawtab%shapefunc(ir,ils)*pawrad%rad(ir)**2 1668 ff(ir)=vxct1(ir1-1,ipts,ispden)*tmp 1669 gg(ir)=vxct1(ir1 ,ipts,ispden)*tmp 1670 end do 1671 call simp_gen(vxcij2(2*ils-1),ff,pawrad) 1672 call simp_gen(vxcij2(2*ils ),gg,pawrad) 1673 end do 1674 end if 1675 end if 1676 1677 ! ===== Integrate Vxc_ij_1 and Vxc_ij_2 over the angular mesh ===== 1678 ! ===== and accummulate in total Vxc_ij ===== 1679 if (qphase==1) then 1680 do klmn=1,lmn2_size 1681 klm=pawtab%indklmn(1,klmn);kln=pawtab%indklmn(2,klmn) 1682 lmin=pawtab%indklmn(3,klmn);lmax=pawtab%indklmn(4,klmn) 1683 dijxc_idij(klmn)=dijxc_idij(klmn)+vxcij1(kln) & 1684 & *pawang%angwgth(ipts)*yylmr(klm,ipts)*four_pi 1685 if (usekden==1) then 1686 dijxc_idij(klmn)=dijxc_idij(klmn)+half*vxctauij1(kln) & 1687 & *pawang%angwgth(ipts)*yylmgr(klm,ipts)*four_pi 1688 end if 1689 if (usexcnhat/=0) then 1690 vxcijhat=zero 1691 do ils=lmin,lmax,2 1692 lm0=ils**2+ils+1 1693 vr=four_pi*pawang%angwgth(ipts)*vxcij2(ils+1) 1694 do mm=-ils,ils 1695 ilslm=lm0+mm;isel=pawang%gntselect(ilslm,klm) 1696 if (isel>0) then 1697 tmp=pawang%ylmr(ilslm,ipts)*pawtab%qijl(ilslm,klmn) 1698 vxcijhat=vxcijhat+vr*tmp 1699 end if 1700 end do 1701 end do 1702 dijxc_idij(klmn)=dijxc_idij(klmn)-vxcijhat 1703 end if 1704 end do ! Loop klmn 1705 else 1706 klmn1=1 1707 do klmn=1,lmn2_size 1708 klm=pawtab%indklmn(1,klmn);kln=pawtab%indklmn(2,klmn) 1709 lmin=pawtab%indklmn(3,klmn);lmax=pawtab%indklmn(4,klmn) 1710 tmp=pawang%angwgth(ipts)*yylmr(klm,ipts)*four_pi 1711 dijxc_idij(klmn1 )=dijxc_idij(klmn1 )+vxcij1(2*kln-1)*tmp 1712 dijxc_idij(klmn1+1)=dijxc_idij(klmn1+1)+vxcij1(2*kln )*tmp 1713 if (usekden==1) then 1714 tmp=pawang%angwgth(ipts)*yylmgr(klm,ipts)*four_pi 1715 dijxc_idij(klmn1 )=dijxc_idij(klmn1 )+half*vxctauij1(2*kln-1)*tmp 1716 dijxc_idij(klmn1+1)=dijxc_idij(klmn1+1)+half*vxctauij1(2*kln )*tmp 1717 end if 1718 if (usexcnhat/=0) then 1719 vxcijhat=zero;vxcijhat_i=zero 1720 do ils=lmin,lmax,2 1721 lm0=ils**2+ils+1;ils1=2*(ils+1) 1722 vr=four_pi*pawang%angwgth(ipts)*vxcij2(ils1-1) 1723 vi=four_pi*pawang%angwgth(ipts)*vxcij2(ils1 ) 1724 do mm=-ils,ils 1725 ilslm=lm0+mm;isel=pawang%gntselect(ilslm,klm) 1726 if (isel>0) then 1727 tmp=pawang%ylmr(ilslm,ipts)*pawtab%qijl(ilslm,klmn) 1728 vxcijhat =vxcijhat +vr*tmp 1729 vxcijhat_i=vxcijhat_i+vi*tmp 1730 end if 1731 end do 1732 end do 1733 dijxc_idij(klmn1 )=dijxc_idij(klmn1 )-vxcijhat 1734 dijxc_idij(klmn1+1)=dijxc_idij(klmn1+1)-vxcijhat_i 1735 end if 1736 klmn1=klmn1+qphase 1737 end do ! Loop klmn 1738 end if 1739 1740 ! ---------------------------------------------------------- 1741 ! End loop on angular points 1742 end do 1743 1744 ! ---------------------------------------------------------- 1745 ! Deduce some part of Dij according to symmetries 1746 ! ---------------------------------------------------------- 1747 1748 !if ispden=1 => real part of D^11_ij 1749 !if ispden=2 => real part of D^22_ij 1750 !if ispden=3 => real part of D^12_ij 1751 !if ispden=4 => imaginary part of D^12_ij 1752 klmn1=max(1,ispden-2);klmn2=1 1753 do klmn=1,lmn2_size 1754 dijxc(klmn1,idij)=dijxc_idij(klmn2) 1755 klmn1=klmn1+cplex_dij 1756 klmn2=klmn2+qphase 1757 end do 1758 if (qphase==2) then 1759 !Same storage with exp^(-i.q.r) phase 1760 klmn1=max(1,ispden-2)+lmn2_size*cplex_dij;klmn2=2 1761 do klmn=1,lmn2_size 1762 dijxc(klmn1,idij)=dijxc_idij(klmn2) 1763 klmn1=klmn1+cplex_dij 1764 klmn2=klmn2+qphase 1765 end do 1766 endif 1767 1768 end do !ispden 1769 1770 !Non-collinear: D_ij(:,4)=D^21_ij=D^12_ij^* 1771 else if (nspden==4.and.idij==4) then 1772 dijxc(:,idij)=dijxc(:,idij-1) 1773 if (cplex_dij==2) then 1774 do klmn=2,lmn2_size*cplex_dij,cplex_dij 1775 dijxc(klmn,idij)=-dijxc(klmn,idij) 1776 end do 1777 if (qphase==2) then 1778 do klmn=2+lmn2_size*cplex_dij,2*lmn2_size*cplex_dij,cplex_dij 1779 dijxc(klmn,idij)=-dijxc(klmn,idij) 1780 end do 1781 end if 1782 end if 1783 1784 !Antiferro: D_ij(:,2)=D^down_ij=D^up_ij 1785 else if (nsppol==1.and.idij==2) then 1786 dijxc(:,idij)=dijxc(:,idij-1) 1787 end if 1788 1789 !---------------------------------------------------------- 1790 !End loop on spin density components 1791 end do 1792 1793 !Free temporary memory spaces 1794 LIBPAW_DEALLOCATE(yylmr) 1795 LIBPAW_DEALLOCATE(yylmgr) 1796 LIBPAW_DEALLOCATE(dijxc_idij) 1797 LIBPAW_DEALLOCATE(vxcij1) 1798 LIBPAW_DEALLOCATE(vxcij2) 1799 LIBPAW_DEALLOCATE(vxctauij1) 1800 LIBPAW_DEALLOCATE(ff) 1801 LIBPAW_DEALLOCATE(gg) 1802 1803 end subroutine pawdijxc
m_pawdij/pawdijxcm [ Functions ]
[ Top ] [ m_pawdij ] [ Functions ]
NAME
pawdijxcm
FUNCTION
Compute the eXchange-Correlation contribution to the PAW pseudopotential strength Dij, using densities and potential expressed as (l,m) spherical moments (for one atom only): D_ij^XC= < Phi_i|Vxc( n1+ nc[+nhat])| Phi_j> -<tPhi_i|Vxc(tn1+tnc[+nhat])|tPhi_j> -Intg_omega [ Vxc(tn1+tnc[+nhat])(r). Sum_L(Qij^L(r)). dr]
INPUTS
cplex_dij=2 if dij is COMPLEX (as in the spin-orbit case), 1 if dij is REAL qphase=2 if dij contains a exp(-i.q.r) phase (as in the q<>0 RF case), 1 if not lmselect(lm_size)=select the non-zero LM-moments of on-site potentials ndij= number of spin components nspden=number of spin density components nsppol=number of independent spin WF components pawang <type(pawang_type)>=paw angular mesh and related data, for current atom pawrad <type(pawrad_type)>=paw radial mesh and related data, for current atom pawtab <type(pawtab_type)>=paw tabulated starting data vxc1(qphase*mesh_size,lm_size,nspden)=all-electron on-site XC potential for current atom given on (l,m) spherical moments vxct1(qphase*mesh_size,lm_size,nspden)=all-electron on-site XC potential for current atom given on (l,m) spherical moments usexcnhat= 1 if compensation density is included in Vxc, 0 otherwise
OUTPUT
dijxc(cplex_dij*qphase*lmn2_size,ndij)= D_ij^XC terms
When Dij is complex (cplex_dij=2):
dij(2*i-1,:) contains the real part, dij(2*i,:) contains the imaginary part
When a exp(-i.q.r) phase is included (qphase=2):
dij(1:cplex_dij*lmn2_size,:)
contains the real part of the phase, i.e. D_ij*cos(q.r)
dij(cplex_dij*lmn2_size+1:2*cplex_dij*lmn2_size,:)
contains the imaginary part of the phase, i.e. D_ij*sin(q.r)
SOURCE
1848 subroutine pawdijxcm(dijxc,cplex_dij,qphase,lmselect,ndij,nspden,nsppol,& 1849 & pawang,pawrad,pawtab,vxc1,vxct1,usexcnhat) 1850 1851 !Arguments --------------------------------------------- 1852 !scalars 1853 integer,intent(in) :: cplex_dij,ndij,nspden,nsppol,qphase,usexcnhat 1854 type(pawang_type),intent(in) :: pawang 1855 !arrays 1856 logical :: lmselect(:) 1857 real(dp),intent(in) :: vxc1(:,:,:),vxct1(:,:,:) 1858 real(dp),intent(out) :: dijxc(:,:) 1859 type(pawrad_type),intent(in) :: pawrad 1860 type(pawtab_type),intent(in) :: pawtab 1861 1862 !Local variables --------------------------------------- 1863 !scalars 1864 integer :: idij,idijend,ij_size,ir,ir1,isel,ispden,klm,klm1,klmn,klmn1,klmn2,kln 1865 integer :: lm_size,lmn2_size,ll,mesh_size,nsploop 1866 real(dp) :: tmp,vxcij2,vxcij2_i 1867 character(len=500) :: msg 1868 !arrays 1869 real(dp),allocatable :: dijxc_idij(:),ff(:),gg(:),vxcij1(:) 1870 1871 ! ************************************************************************* 1872 1873 !Useful data 1874 lm_size=pawtab%lcut_size**2 1875 lmn2_size=pawtab%lmn2_size 1876 ij_size=pawtab%ij_size 1877 mesh_size=pawtab%mesh_size 1878 1879 !Check data consistency 1880 if (size(dijxc,1)/=cplex_dij*qphase*lmn2_size.or.size(dijxc,2)/=ndij) then 1881 msg='invalid sizes for Dijxc !' 1882 LIBPAW_BUG(msg) 1883 end if 1884 if (size(lmselect)/=lm_size) then 1885 msg='invalid size for lmselect !' 1886 LIBPAW_BUG(msg) 1887 end if 1888 if (size(vxc1,1)/=qphase*mesh_size.or.size(vxct1,1)/=qphase*mesh_size.or.& 1889 & size(vxc1,2)/=lm_size.or.size(vxct1,2)/=lm_size.or.& 1890 & size(vxc1,3)/=nspden.or.size(vxct1,3)/=nspden) then 1891 msg='invalid sizes for vxc1 or vxct1 !' 1892 LIBPAW_BUG(msg) 1893 end if 1894 1895 !Init memory 1896 dijxc=zero 1897 LIBPAW_ALLOCATE(dijxc_idij,(qphase*lmn2_size)) 1898 LIBPAW_ALLOCATE(vxcij1,(qphase*ij_size)) 1899 LIBPAW_ALLOCATE(ff,(mesh_size)) 1900 LIBPAW_ALLOCATE(gg,(mesh_size)) 1901 1902 !---------------------------------------------------------- 1903 !Loop over spin components 1904 !---------------------------------------------------------- 1905 nsploop=nsppol;if (ndij==4) nsploop=4 1906 do idij=1,nsploop 1907 if (idij<=nsppol.or.(nspden==4.and.idij<=3)) then 1908 1909 idijend=idij+idij/3 1910 do ispden=idij,idijend 1911 1912 dijxc_idij=zero 1913 1914 ! ---------------------------------------------------------- 1915 ! Summing over (l,m) moments 1916 ! ---------------------------------------------------------- 1917 do klm=1,lm_size 1918 if (lmselect(klm)) then 1919 1920 ! ===== Vxc_ij_1 (tmp) ===== 1921 vxcij1=zero 1922 if (qphase==1) then 1923 do kln=1,ij_size 1924 ff(1:mesh_size)= & 1925 & vxc1(1:mesh_size,klm,ispden)*pawtab%phiphj(1:mesh_size,kln) & 1926 & -vxct1(1:mesh_size,klm,ispden)*pawtab%tphitphj(1:mesh_size,kln) 1927 call simp_gen(vxcij1(kln),ff,pawrad) 1928 end do 1929 else ! qphase==2 1930 do kln=1,ij_size 1931 do ir=1,mesh_size 1932 ir1=2*ir 1933 ff(ir)= & 1934 & vxc1(ir1-1,klm,ispden)*pawtab%phiphj(ir,kln) & 1935 & -vxct1(ir1-1,klm,ispden)*pawtab%tphitphj(ir,kln) 1936 gg(ir)= & 1937 & vxc1(ir1,klm,ispden)*pawtab%phiphj(ir,kln) & 1938 & -vxct1(ir1,klm,ispden)*pawtab%tphitphj(ir,kln) 1939 end do 1940 call simp_gen(vxcij1(2*kln-1),ff,pawrad) 1941 call simp_gen(vxcij1(2*kln ),gg,pawrad) 1942 end do 1943 end if 1944 1945 ! ===== Vxc_ij_2 (tmp) ===== 1946 vxcij2=zero;vxcij2_i=zero 1947 if (usexcnhat/=0) then 1948 ll=1+int(sqrt(dble(klm)-0.1_dp)) 1949 if (qphase==1) then 1950 ff(1:mesh_size)=vxct1(1:mesh_size,klm,ispden) & 1951 & *pawtab%shapefunc(1:mesh_size,ll) & 1952 & *pawrad%rad(1:mesh_size)**2 1953 call simp_gen(vxcij2,ff,pawrad) 1954 else ! qphase==2 1955 do ir=1,mesh_size 1956 ir1=2*ir 1957 tmp=pawtab%shapefunc(ir,ll)*pawrad%rad(ir)**2 1958 ff(ir)=vxct1(ir1-1,klm,ispden)*tmp 1959 gg(ir)=vxct1(ir1 ,klm,ispden)*tmp 1960 end do 1961 call simp_gen(vxcij2 ,ff,pawrad) 1962 call simp_gen(vxcij2_i,gg,pawrad) 1963 end if 1964 end if 1965 1966 ! ===== Accumulate over klm moments Vxc_ij_1 and Vxc_ij_2 ===== 1967 ! ===== into total Vxc_ij ===== 1968 if (qphase==1) then 1969 do klmn=1,lmn2_size 1970 klm1=pawtab%indklmn(1,klmn) 1971 kln=pawtab%indklmn(2,klmn) 1972 isel=pawang%gntselect(klm,klm1) 1973 if (isel>0) & 1974 & dijxc_idij(klmn)=dijxc_idij(klmn)+vxcij1(kln)*pawang%realgnt(isel) 1975 if (usexcnhat/=0) & 1976 dijxc_idij(klmn)=dijxc_idij(klmn)-pawtab%qijl(klm,klmn)*vxcij2 1977 end do ! Loop klmn 1978 else ! qphase==2 1979 klmn1=1 1980 do klmn=1,lmn2_size 1981 klm1=pawtab%indklmn(1,klmn) 1982 kln=pawtab%indklmn(2,klmn) 1983 isel=pawang%gntselect(klm,klm1) 1984 if (isel>0) then 1985 dijxc_idij(klmn1 )=dijxc_idij(klmn1) & 1986 & +vxcij1(2*kln-1)*pawang%realgnt(isel) 1987 dijxc_idij(klmn1+1)=dijxc_idij(klmn1+1) & 1988 & +vxcij1(2*kln )*pawang%realgnt(isel) 1989 end if 1990 if (usexcnhat/=0) then 1991 dijxc_idij(klmn1 )=dijxc_idij(klmn1) & 1992 & -pawtab%qijl(klm,klmn)*vxcij2 1993 dijxc_idij(klmn1+1)=dijxc_idij(klmn1+1) & 1994 & -pawtab%qijl(klm,klmn)*vxcij2_i 1995 end if 1996 klmn1=klmn1+qphase 1997 end do ! Loop klmn 1998 end if 1999 2000 end if ! klm selection 2001 end do ! Loop klm 2002 2003 ! ---------------------------------------------------------- 2004 ! Deduce some part of Dij according to symmetries 2005 ! ---------------------------------------------------------- 2006 2007 !if ispden=1 => real part of D^11_ij 2008 !if ispden=2 => real part of D^22_ij 2009 !if ispden=3 => real part of D^12_ij 2010 !if ispden=4 => imaginary part of D^12_ij 2011 klmn1=max(1,ispden-2);klmn2=1 2012 do klmn=1,lmn2_size 2013 dijxc(klmn1,idij)=dijxc_idij(klmn2) 2014 klmn1=klmn1+cplex_dij 2015 klmn2=klmn2+qphase 2016 end do 2017 if (qphase==2) then 2018 !Same storage with exp^(-i.q.r) phase 2019 klmn1=max(1,ispden-2)+lmn2_size*cplex_dij;klmn2=2 2020 do klmn=1,lmn2_size 2021 dijxc(klmn1,idij)=dijxc_idij(klmn2) 2022 klmn1=klmn1+cplex_dij 2023 klmn2=klmn2+qphase 2024 end do 2025 endif 2026 2027 end do !ispden 2028 2029 !Non-collinear: D_ij(:,4)=D^21_ij=D^12_ij^* 2030 else if (nspden==4.and.idij==4) then 2031 dijxc(:,idij)=dijxc(:,idij-1) 2032 if (cplex_dij==2) then 2033 do klmn=2,lmn2_size*cplex_dij,cplex_dij 2034 dijxc(klmn,idij)=-dijxc(klmn,idij) 2035 end do 2036 if (qphase==2) then 2037 do klmn=2+lmn2_size*cplex_dij,2*lmn2_size*cplex_dij,cplex_dij 2038 dijxc(klmn,idij)=-dijxc(klmn,idij) 2039 end do 2040 end if 2041 end if 2042 2043 !Antiferro: D_ij(:,2)=D^down_ij=D^up_ij 2044 else if (nsppol==1.and.idij==2) then 2045 dijxc(:,idij)=dijxc(:,idij-1) 2046 end if 2047 2048 !---------------------------------------------------------- 2049 !End loop on spin density components 2050 end do 2051 2052 !Free temporary memory spaces 2053 LIBPAW_DEALLOCATE(dijxc_idij) 2054 LIBPAW_DEALLOCATE(vxcij1) 2055 LIBPAW_DEALLOCATE(ff) 2056 LIBPAW_DEALLOCATE(gg) 2057 2058 end subroutine pawdijxcm
m_pawdij/pawpupot [ Functions ]
[ Top ] [ m_pawdij ] [ Functions ]
NAME
pawpupot
FUNCTION
Compute the PAW DFT+U on-site potential
INPUTS
cplex_dij=2 if DFT+U pot. is COMPLEX (as in the spin-orbit case), 1 if dij is REAL ndij=number of spin components for Dij pawprtvol=control print volume and debugging output for PAW noccmmp(cplex_dij,2*lpawu+1,2*lpawu+1,ndij)=density matrix in the augm. region nocctot(ndij)=number of electrons in the correlated subspace pawtab(ntypat) <type(pawtab_type)>=paw tabulated starting data: %usepawu, %upawu, %jpau %vee(2*lpawu+1*4)=screened coulomb matrix
OUTPUT
vpawu(cplex_dij,lpawu*2+1,lpawu*2+1,ndij)=lda+u potential
(see eg PRB 52, 5467 (1995) [[cite:Liechenstein1995]])
When vpawu is complex (cplex_dij=2):
vpawu(2*i-1,:) contains the real part
vpawu(2*i,:) contains the imaginary part
SOURCE
4155 subroutine pawpupot(cplex_dij,ndij,noccmmp,nocctot,& 4156 & pawprtvol,pawtab,vpawu) 4157 4158 !Arguments --------------------------------------------- 4159 !scalars 4160 integer,intent(in) :: cplex_dij,ndij,pawprtvol 4161 type(pawtab_type),intent(in) :: pawtab 4162 !arrays 4163 real(dp),intent(in) :: noccmmp(:,:,:,:),nocctot(:) 4164 real(dp),intent(out) :: vpawu(:,:,:,:) 4165 4166 !Local variables --------------------------------------- 4167 !scalars 4168 !Option for interaction energy in case of non-collinear magnetism: 4169 ! 1: E_int=-J/4.N.(N-2) (better) 4170 ! 2: E_int=-J/2.(Nup.(Nup-1)+Ndn.(Ndn-1)) (Nup and Ndn are ill-defined) 4171 ! integer,parameter :: option_interaction=3 4172 4173 integer :: iplex,ispden,jspden,lpawu,m1,m11,m2,m21,m3,m31,m4,m41,nspden_eff 4174 real(dp) :: mnorm,mx,my,mz,n_sig,n_msig,n_tot,VUKStemp,n_sigs,n_msigs 4175 real(dp),save :: VUKS 4176 character(len=500) :: msg 4177 !arrays 4178 real(dp),parameter :: factcg(3:4)=(/one,-one/) 4179 real(dp) :: n34_msig(cplex_dij),n34_sig(cplex_dij) 4180 !real(dp) :: n43_sig(cplex_dij) 4181 4182 ! ***************************************************** 4183 4184 !Useful data 4185 lpawu=pawtab%lpawu 4186 4187 !Check data consistency 4188 if(pawtab%usepawu<0) then 4189 msg = "usepawu<0 not allowed!" 4190 LIBPAW_BUG(msg) 4191 end if 4192 if(ndij==4.and.pawtab%option_interaction_pawu==3.and.pawtab%usepawu>=10) then 4193 msg = "Option_interaction==3 is not compatible with usepawu>=10 in pawpupot" 4194 LIBPAW_ERROR(msg) 4195 end if 4196 if (size(vpawu,1)/=cplex_dij.or.size(vpawu,2)/=2*lpawu+1.or.& 4197 & size(vpawu,3)/=2*lpawu+1.or.size(vpawu,4)/=ndij) then 4198 write (msg,'(a,4I5, a,4I5)') ' invalid sizes for vpawu !',cplex_dij,2*lpawu+1,2*lpawu+1,ndij, & 4199 & ' /= ', size(vpawu,1), size(vpawu,2), size(vpawu,3), size(vpawu,4) 4200 LIBPAW_BUG(msg) 4201 end if 4202 if (size(noccmmp,1)/=cplex_dij.or.size(noccmmp,2)/=2*lpawu+1.or.& 4203 & size(noccmmp,3)/=2*lpawu+1.or.size(noccmmp,4)/=ndij) then 4204 write (msg,'(a,4I5, a,4I5)') ' invalid sizes for noccmmp !',cplex_dij,2*lpawu+1,2*lpawu+1,ndij, & 4205 & ' /= ', size(noccmmp,1), size(noccmmp,2), size(noccmmp,3), size(noccmmp,4) 4206 LIBPAW_BUG(msg) 4207 end if 4208 if (size(nocctot,1)/=ndij) then 4209 msg='invalid size for nocctot !' 4210 LIBPAW_BUG(msg) 4211 end if 4212 4213 !===================================================== 4214 !Compute DFT+U Potential on the basis of projectors 4215 !cf PRB 52 5467 (1995) [[cite:Liechenstein1995]] 4216 !----------------------------------------------------- 4217 4218 vpawu=zero ; nspden_eff=ndij 4219 do ispden=1,nspden_eff 4220 4221 if (ispden<=2) then ! cases ndij=4, ispden=1,2 or ndij<4 4222 jspden=min(nspden_eff,2)-ispden+1 ! (ispden,ndij)=(1,4)=>jspden=2 4223 4224 if (nspden_eff<=2) then 4225 n_sig =nocctot(ispden) 4226 n_msig=nocctot(jspden) 4227 n_tot =n_sig+n_msig 4228 else 4229 n_tot=nocctot(1) 4230 mx=nocctot(2) 4231 my=nocctot(3) 4232 mz=nocctot(4) 4233 mnorm=sqrt(mx*mx+my*my+mz*mz) 4234 if (ispden==1) then 4235 ! n_sig =half*(n_tot+mnorm) 4236 ! n_msig=half*(n_tot-mnorm) 4237 n_sig =half*(n_tot+sign(mnorm,mz)) 4238 n_msig=half*(n_tot-sign(mnorm,mz)) 4239 else 4240 ! n_sig =half*(n_tot-mnorm) 4241 ! n_msig=half*(n_tot+mnorm) 4242 n_sig =half*(n_tot-sign(mnorm,mz)) 4243 n_msig=half*(n_tot+sign(mnorm,mz)) 4244 end if 4245 end if 4246 4247 n_sigs =n_sig/(float(2*lpawu+1)) 4248 n_msigs =n_msig/(float(2*lpawu+1)) 4249 do m1=-lpawu,lpawu 4250 m11=m1+lpawu+1 4251 do m2=-lpawu,lpawu 4252 m21=m2+lpawu+1 4253 do m3=-lpawu,lpawu 4254 m31=m3+lpawu+1 4255 do m4=-lpawu,lpawu 4256 m41=m4+lpawu+1 4257 n34_sig(:) =noccmmp(:,m31,m41,ispden) ! spin sigma 4258 n34_msig(:)=noccmmp(:,m31,m41,jspden) ! opposite spin (-sigma) 4259 if(m31==m41.and.pawtab%usepawu==3) then 4260 n34_sig(1)= n34_sig(1) - n_sigs 4261 n34_msig(1)= n34_msig(1) - n_msigs 4262 end if 4263 do iplex=1,cplex_dij 4264 vpawu(iplex,m11,m21,ispden)=vpawu(iplex,m11,m21,ispden) & 4265 & +n34_msig(iplex)*pawtab%vee(m11,m31,m21,m41) & 4266 & +n34_sig(iplex)*(pawtab%vee(m11,m31,m21,m41)-pawtab%vee(m11,m31,m41,m21)) 4267 end do 4268 ! if(abs(pawprtvol)>=3.and.m11==1.and.m21==1) then 4269 ! write(msg,'(a,i4,i4,2e20.10)') "m31,m41,vu=",m31,m41,& 4270 ! & vpawu(:,m11,m21,ispden) 4271 ! call wrtout(std_out,msg,'COLL') 4272 ! write(msg,'(a,4e20.10)') "vee",pawtab%vee(m11,m31,m21,m41),& 4273 ! & pawtab%vee(m11,m31,m41,m21) 4274 ! call wrtout(std_out,msg,'COLL') 4275 ! write(msg,'(a,4e20.10)') "n34_msig,n34_sig",n34_msig(1),n34_sig(1) 4276 ! call wrtout(std_out,msg,'COLL') 4277 ! end if 4278 end do 4279 end do 4280 ! if(abs(pawprtvol)>=3) then 4281 ! if(m11/=m21) then 4282 ! write(msg,'(a,i4,i4,2e20.10)') "vu=",m11,m21,vpawu(:,m11,m21,ispden) 4283 ! call wrtout(std_out,msg,'COLL') 4284 ! write(msg,'(a,2e20.10)') "vupred=",-pawtab%upawu*noccmmp(:,m21,m11,ispden) 4285 ! call wrtout(std_out,msg,'COLL') 4286 ! end if 4287 ! end if 4288 end do ! m2 4289 if(abs(pawprtvol)>=3) then 4290 write(msg,'(a,i3,14f11.5)') & 4291 & "vpawu ",m11, (vpawu(:,m11,m21,ispden),m21=1,2*lpawu+1) 4292 call wrtout(std_out, msg,'COLL') 4293 write(msg,'(a,i3,14f11.5)') & 4294 & "noccmmp ",m11, (noccmmp(:,m11,m21,ispden),m21=1,2*lpawu+1) 4295 call wrtout(std_out, msg,'COLL') 4296 end if 4297 4298 ! Full localized limit 4299 if(pawtab%usepawu==1.or.pawtab%usepawu==4) then ! not activated if usepawu=10 !! 4300 ! Here we compute vpawu=vpawu-v_dc 4301 vpawu(1,m11,m11,ispden)=vpawu(1,m11,m11,ispden)-pawtab%upawu*(n_tot-half) 4302 if (ndij/=4.or.pawtab%option_interaction_pawu==2) then 4303 if(pawtab%usepawu/=4) then 4304 vpawu(1,m11,m11,ispden)=vpawu(1,m11,m11,ispden)+pawtab%jpawu*(n_sig-half) 4305 else 4306 vpawu(1,m11,m11,ispden)=vpawu(1,m11,m11,ispden)+half*pawtab%jpawu*(n_tot-one) 4307 endif 4308 else if (ndij==4.and.(pawtab%usepawu==4.or.pawtab%option_interaction_pawu==1)) then 4309 vpawu(1,m11,m11,ispden)=vpawu(1,m11,m11,ispden)+half*pawtab%jpawu*(n_tot-one) 4310 else if (ndij==4.and.pawtab%option_interaction_pawu==3) then 4311 ! Here vdc^{alpha,beta}=\vect{m}.\vect{sigma}^{\beta,\alpha} 4312 vpawu(1,m11,m11,ispden)=vpawu(1,m11,m11,ispden)+half*pawtab%jpawu*(n_tot-one) 4313 if (ispden==1) then 4314 vpawu(1,m11,m11,ispden)=vpawu(1,m11,m11,ispden)+half*pawtab%jpawu*mz 4315 else 4316 vpawu(1,m11,m11,ispden)=vpawu(1,m11,m11,ispden)-half*pawtab%jpawu*mz 4317 end if 4318 end if 4319 4320 ! Around mean field 4321 else if(pawtab%usepawu==2) then 4322 vpawu(1,m11,m11,ispden)=vpawu(1,m11,m11,ispden)-n_msig*pawtab%upawu & 4323 & -n_sig*(pawtab%upawu-pawtab%jpawu) & 4324 & *(dble(2*lpawu)/dble(2*lpawu+1)) 4325 end if 4326 4327 ! if (abs(pawprtvol)>=3) then 4328 ! write(msg,'(a,i4,i4,2x,e20.10)') "vudiag= ",m11,m11,vpawu(1,m11,m11,ispden) 4329 ! call wrtout(std_out, msg,'COLL') 4330 ! write(msg,'(a,2e20.10)') "vudiagpred= ",pawtab%upawu*(half-noccmmp(:,m11,m11,ispden)) 4331 ! call wrtout(std_out, msg,'COLL') 4332 ! end if 4333 if(abs(pawprtvol)>=3) then 4334 write(msg,*) "nocctot",nocctot 4335 call wrtout(std_out, msg,'COLL') 4336 write(msg,'(a,i3,14f11.5)') & 4337 & "vpawu 2",m11, (vpawu(:,m11,m21,ispden),m21=1,2*lpawu+1) 4338 call wrtout(std_out, msg,'COLL') 4339 write(msg,'(a,i3,14f11.5)') & 4340 & "noccmmp2",m11, (noccmmp(:,m11,m21,ispden),m21=1,2*lpawu+1) 4341 call wrtout(std_out, msg,'COLL') 4342 end if 4343 end do ! m1 4344 4345 end if ! ispden<=2 4346 4347 ! Non-collinear magnetism: add non-diagonal term; see (Eq 6) in PRB 72, 024458 (2005) [[cite:Shurikov2005]] 4348 ! BA Here, we compute the transpose --- with respect to spin indices --- of 4349 ! BA equation (6) of this reference, because of differences in notations, 4350 ! BA namely Eband=\sum rhoij^{alpha,beta}*Dij(beta,alpha) contrary to PRB 72, 024458 (2005) [[cite:Shurikov2005]] 4351 if (ispden>=3) then 4352 mx=nocctot(2) 4353 my=nocctot(3) 4354 do m1=-lpawu,lpawu 4355 m11=m1+lpawu+1 4356 do m2=-lpawu,lpawu 4357 m21=m2+lpawu+1 4358 do m3=-lpawu,lpawu 4359 m31=m3+lpawu+1 4360 do m4=-lpawu,lpawu 4361 m41=m4+lpawu+1 4362 ! n43_sig(:) =noccmmp(:,m41,m31,ispden) 4363 ! vpawu(1,m11,m21,ispden)=vpawu(1,m11,m21,ispden)-n43_sig(1)*pawtab%vee(m11,m31,m41,m21) 4364 ! vpawu(2,m11,m21,ispden)=vpawu(2,m11,m21,ispden)+n43_sig(2)*pawtab%vee(m11,m31,m41,m21) 4365 n34_sig(:) =noccmmp(:,m31,m41,ispden) 4366 vpawu(1,m11,m21,ispden)=vpawu(1,m11,m21,ispden)-n34_sig(1)*pawtab%vee(m11,m31,m41,m21) 4367 vpawu(2,m11,m21,ispden)=vpawu(2,m11,m21,ispden)-n34_sig(2)*pawtab%vee(m11,m31,m41,m21) 4368 end do 4369 end do 4370 end do 4371 if(pawtab%usepawu==1.and.pawtab%option_interaction_pawu==3) then ! not activated if usepawu=10 !! 4372 vpawu(1,m11,m11,ispden)=vpawu(1,m11,m11,ispden)+half*pawtab%jpawu*mx 4373 if(ispden==3) then 4374 vpawu(2,m11,m11,ispden)=vpawu(2,m11,m11,ispden)-half*pawtab%jpawu*my 4375 else 4376 vpawu(2,m11,m11,ispden)=vpawu(2,m11,m11,ispden)+half*pawtab%jpawu*my 4377 end if 4378 end if 4379 end do 4380 end if 4381 4382 if(abs(pawprtvol)>=3) then 4383 write(std_out,*) "vpawu, ispden",ispden 4384 do m11=1,2*lpawu+1 4385 write(msg,'(12(1x,9(1x,"(",f10.7,",",f10.7,")")))') & 4386 & (vpawu(1:cplex_dij,m11,m21,ispden),m21=1,2*lpawu+1) 4387 call wrtout(std_out,msg,'COLL') 4388 end do 4389 end if 4390 4391 ! Printing for test 4392 if (abs(pawprtvol)>=3) then 4393 if (ispden==1) VUKS=zero 4394 VUKStemp=zero 4395 do m1=-lpawu,lpawu 4396 m11=m1+lpawu+1 4397 do m2=-lpawu,lpawu 4398 m21=m2+lpawu+1 4399 VUKStemp=VUKStemp+vpawu(1,m11,m21,ispden)*noccmmp(1,m11,m21,ispden) 4400 if (cplex_dij == 2) then 4401 VUKStemp=VUKStemp-vpawu(2,m11,m21,ispden)*noccmmp(2,m11,m21,ispden) 4402 end if 4403 write(msg,'(a,2e20.10,2e20.10)') "m1,m2,vpawu,noccmmp= ", & 4404 & vpawu(:,m11,m21,ispden),noccmmp(:,m11,m21,ispden) 4405 call wrtout(std_out, msg,'COLL') 4406 end do 4407 end do 4408 VUKS=VUKS+VUKStemp 4409 write(msg,*) "pawpupot: VUKStemp= ",ispden,VUKStemp 4410 call wrtout(std_out, msg,'COLL') 4411 if (ispden==nspden_eff) then 4412 write(msg,*) "pawpupot: VUKS= ",ispden,VUKS 4413 call wrtout(std_out, msg,'COLL') 4414 end if 4415 end if 4416 4417 end do ! Loop on ispden 4418 4419 end subroutine pawpupot
m_pawdij/pawxpot [ Functions ]
[ Top ] [ m_pawdij ] [ Functions ]
NAME
pawxpot
FUNCTION
Compute the PAW Local Exact-Exchange on-site potential
INPUTS
ndij=number of spin components for Dij pawprtvol=control print volume and debugging output for PAW paw_ij <type(paw_ij_type)>=paw arrays given on (i,j) channels pawtab <type(pawtab_type)>=paw tabulated starting data: pawrhoij <type(pawrhoij_type)>= paw rhoij occupancies and related data
OUTPUT
paw_ij%vpawx(pawtab%lexexch*2+1,pawtab%lexexch*2+1)=local exact-exchange potential
SOURCE
4443 subroutine pawxpot(ndij,pawprtvol,pawrhoij,pawtab,vpawx) 4444 4445 !Arguments --------------------------------------------- 4446 !scalars 4447 integer,intent(in) :: ndij,pawprtvol 4448 type(pawrhoij_type),intent(in) :: pawrhoij 4449 type(pawtab_type),intent(in) :: pawtab 4450 real(dp),intent(out) :: vpawx(:,:,:) 4451 4452 !Local variables --------------------------------------- 4453 !scalars 4454 integer :: cplex_rhoij,irhoij,irhoij1,ispden,jrhoij,jrhoij1,klmn,klmn1,lexexch,ll,lmn2_size 4455 integer :: m11,m21,m31,m41,n1,n2,n3,n4,nk,nn1,nn2,nspden_eff 4456 real(dp) :: tot 4457 character(len=500) :: msg 4458 !arrays 4459 integer :: indn(3,3) 4460 real(dp) :: factnk(6) 4461 4462 ! ***************************************************** 4463 4464 !Useful data 4465 lexexch=pawtab%lexexch 4466 cplex_rhoij=pawrhoij%cplex_rhoij 4467 lmn2_size=pawtab%lmn2_size 4468 if (pawtab%nproju==1) nk=1 4469 if (pawtab%nproju==2) nk=6 4470 factnk(1)=one;factnk(2)=one;factnk(3)=one 4471 factnk(4)=two;factnk(5)=two;factnk(6)=two 4472 indn(1,1)=1;indn(1,2)=4;indn(1,3)=5 4473 indn(2,1)=4;indn(2,2)=2;indn(2,3)=6 4474 indn(3,1)=5;indn(3,2)=6;indn(3,3)=3 4475 4476 !Check data consistency 4477 if (size(vpawx,1)/=1.or.size(vpawx,2)/=lmn2_size.or.& 4478 & size(vpawx,3)/=ndij) then 4479 msg='invalid sizes for vpawx !' 4480 LIBPAW_BUG(msg) 4481 end if 4482 if (pawrhoij%qphase==2) then 4483 msg='pawxpot not compatible with qphase=2 (DFPT)!' 4484 LIBPAW_BUG(msg) 4485 end if 4486 4487 !===================================================== 4488 !Compute local exact exchange Potential 4489 !on the basis of projectors. 4490 !----------------------------------------------------- 4491 4492 vpawx=zero ; nspden_eff=ndij 4493 do ispden=1,nspden_eff 4494 jrhoij=1 4495 do irhoij=1,pawrhoij%nrhoijsel 4496 klmn=pawrhoij%rhoijselect(irhoij) 4497 if(pawtab%indklmn(3,klmn)==0.and.pawtab%indklmn(4,klmn)==2*lexexch) then 4498 m11=pawtab%klmntomn(1,klmn);m21=pawtab%klmntomn(2,klmn) 4499 n1=pawtab%klmntomn(3,klmn);n2=pawtab%klmntomn(4,klmn) 4500 nn1=(n1*n2)/2+1 4501 jrhoij1=1 4502 do irhoij1=1,pawrhoij%nrhoijsel 4503 klmn1=pawrhoij%rhoijselect(irhoij1) 4504 if(pawtab%indklmn(3,klmn1)==0.and.pawtab%indklmn(4,klmn1)==2*lexexch) then 4505 m31=pawtab%klmntomn(1,klmn1);m41=pawtab%klmntomn(2,klmn1) 4506 n3=pawtab%klmntomn(3,klmn1);n4=pawtab%klmntomn(4,klmn1) 4507 nn2=(n3*n4)/2+1 4508 do ll=1,lexexch+1 4509 vpawx(1,klmn,ispden)=vpawx(1,klmn,ispden)& 4510 & -pawtab%vex(m11,m31,m41,m21,ll)*pawtab%dltij(klmn1) & 4511 & *pawtab%fk(indn(nn1,nn2),ll)*pawrhoij%rhoijp(jrhoij1,ispden) 4512 end do 4513 4514 end if 4515 jrhoij1=jrhoij1+cplex_rhoij 4516 end do !irhoij1 4517 end if 4518 jrhoij=jrhoij+cplex_rhoij 4519 end do !irhoij 4520 end do !ispden 4521 4522 !Test 4523 if (abs(pawprtvol)>=2) then 4524 tot=zero 4525 do ispden=1,pawrhoij%nspden 4526 jrhoij=1 4527 do irhoij=1,pawrhoij%nrhoijsel 4528 klmn=pawrhoij%rhoijselect(irhoij) 4529 tot=tot+vpawx(1,klmn,ispden)*pawrhoij%rhoijp(jrhoij,ispden)*pawtab%dltij(klmn) 4530 jrhoij=jrhoij+cplex_rhoij 4531 end do 4532 end do 4533 write(msg, '(a,es22.15)' )" Vpawx: tot=",tot*half 4534 call wrtout(std_out,msg,'COLL') 4535 end if 4536 4537 end subroutine pawxpot
m_pawdij/symdij [ Functions ]
[ Top ] [ m_pawdij ] [ Functions ]
NAME
symdij
FUNCTION
Symmetrize PAW non-local strengths Dij Symmetrize total Dij or one part of it
INPUTS
gprimd(3,3)=dimensional primitive translations for reciprocal space(bohr^-1). indsym(4,nsym,natom)=indirect indexing array for atom labels ipert=index of perturbation if pawrhoij is a pertubed rhoij no meaning for ground-state calculations (should be 0) [mpi_atmtab(:)]=--optional-- indexes of the atoms treated by current proc [comm_atom]=--optional-- MPI communicator over atoms my_natom=number of atoms treated by current processor natom=number of atoms in cell nsym=number of symmetry elements in space group ntypat=number of types of atoms in unit cell. option_dij=choose which part of Dij has to be symmetrized (which paw_ij(:)%dijxxx): 0: total dij (dij) 1: dij due to compensation charge (dijhat) 2: dij due to +U (dijU) 3: dij XC (dijxc) 4: dij XC due to compensation charge (dijxc_hat) 5: dij XC valence only (dijxc_val) 6: dij spin-orbit (dijso) 7: dij exact exchange (dijexxc) 8: dij, RF frozen part (dijfr) 9: dij due to nuclear dipoles 10: dij Hartree 11: dij Fock paw_ij(natom)%cplex_dij=1 if dij are REAL, 2 if they are COMPLEX paw_ij(natom)%qphase=2 if exp^(-i.q.r) phase from RF at q<>0, 1 otherwise paw_ij(natom)%lmn_size=number of (l,m,n) elements for the paw basis paw_ij(natom)%nspden=number of spin-density components paw_ij(natom)%nsppol=number of independant spin-density components paw_ij(natom)%dij(lmn2_size,nspden)=non-symmetrized paw dij quantities pawang <type(pawang_type)>=angular mesh discretization and related data pawprtvol=control print volume and debugging output for PAW pawtab(ntypat) <type(pawtab_type)>=paw tabulated starting data [qphon(3)]=--optional-- (RF calculations only) - wavevector of the phonon rprimd(3,3)=real space primitive translations. symafm(nsym)=(anti)ferromagnetic part of symmetry operations symrec(3,3,nsym)=symmetries of group in terms of operations on reciprocal space primitive translations
SIDE EFFECTS
paw_ij(natom)%dij???(cplex_dij*lmn2_size,nspden)=symmetrized dij quantities as output
SOURCE
4594 subroutine symdij(gprimd,indsym,ipert,my_natom,natom,nsym,ntypat,option_dij,& 4595 & paw_ij,pawang,pawprtvol,pawtab,rprimd,symafm,symrec, & 4596 & mpi_atmtab,comm_atom,qphon) ! optional arguments (parallelism) 4597 4598 !Arguments --------------------------------------------- 4599 !scalars 4600 integer,intent(in) :: ipert,my_natom,natom,nsym,ntypat,option_dij,pawprtvol 4601 integer,optional,intent(in) :: comm_atom 4602 type(pawang_type),intent(in) :: pawang 4603 !arrays 4604 integer,intent(in) :: indsym(4,nsym,natom),symafm(nsym),symrec(3,3,nsym) 4605 integer,optional,target,intent(in) :: mpi_atmtab(:) 4606 real(dp),intent(in) :: gprimd(3,3),rprimd(3,3) 4607 real(dp),intent(in),optional :: qphon(3) 4608 type(paw_ij_type),intent(inout) :: paw_ij(my_natom) 4609 type(pawtab_type),target,intent(in) :: pawtab(ntypat) 4610 4611 !Local variables --------------------------------------- 4612 !scalars 4613 integer :: at_indx,cplex_dij,iafm,iatom,iatom_tot,ii 4614 integer :: il,il0,ilmn,iln,iln0,ilpm,indexi,indexii,indexj,indexjj,indexjj0,indexk,indexkc,indexkc_q 4615 integer :: iplex,iq,irot,ispden,itypat,j0lmn,jl,jl0,jlmn,jln,jln0,jlpm,jspden 4616 integer :: klmn,klmnc,kspden,lmn_size,lmn2_size,mi,mj,my_comm_atom,my_cplex_dij,my_ndij,my_qphase 4617 integer :: mu,natinc,ndij0,ndij1,nu,qphase,sz1,sz2 4618 logical,parameter :: afm_noncoll=.true. ! TRUE if antiferro symmetries are used with non-collinear magnetism 4619 logical :: antiferro,has_qphase,my_atmtab_allocated,noncoll,paral_atom,use_afm 4620 !DEBUG_ALTERNATE_ALGO 4621 !Set to TRUE to choose an alternate algorithm (with another representation) 4622 !to symmetrize Dij within non-collinear magnetism or spin-orbit 4623 logical,parameter :: lsymnew=.false. 4624 !DEBUG_ALTERNATE_ALGO 4625 real(dp) :: arg,factafm,zarot2 4626 character(len=6) :: pertstrg,wrt_mode 4627 character(len=500) :: msg 4628 !arrays 4629 integer :: nsym_used(2) 4630 integer, pointer :: indlmn(:,:) 4631 integer,pointer :: my_atmtab(:) 4632 real(dp) :: dijc(2),fact(2),factsym(2),phase(2) 4633 real(dp) :: rotdij(2,2,2),rotmag(2,3,2),sumdij(2,2,2),summag(2,3,2) 4634 real(dp),allocatable :: dijnew(:,:,:),dijtmp(:,:),symrec_cart(:,:,:) 4635 type(coeff2_type),target, allocatable :: my_tmp_dij(:) 4636 type(coeff2_type),pointer :: tmp_dij(:) 4637 4638 !DEBUG_ALTERNATE_ALGO 4639 !integer :: i1,i2,i3,i4,symrel_conv(3,3) 4640 !real(dp) :: spinrot(4) 4641 !real(dp),allocatable :: dijtemp(:,:),sumrhoso(:,:) 4642 !complex(dpc) :: dijt(2,2),dijt2(2,2),Rspinrot(2,2) 4643 !DEBUG_ALTERNATE_ALGO 4644 4645 ! ********************************************************************* 4646 4647 !Tests consistency of options 4648 if (my_natom>0) then 4649 if ((option_dij==1.and.paw_ij(1)%has_dijhat==0).or.& 4650 & (option_dij==2.and.paw_ij(1)%has_dijU==0).or.& 4651 & (option_dij==3.and.paw_ij(1)%has_dijxc==0).or.& 4652 & (option_dij==4.and.paw_ij(1)%has_dijxc_hat==0).or.& 4653 & (option_dij==5.and.paw_ij(1)%has_dijxc_val==0).or.& 4654 & (option_dij==6.and.paw_ij(1)%has_dijso==0).or.& 4655 & (option_dij==7.and.paw_ij(1)%has_dijexxc==0).or.& 4656 & (option_dij==8.and.paw_ij(1)%has_dijfr==0).or.& 4657 & (option_dij==9.and.paw_ij(1)%has_dijnd==0).or.& 4658 & (option_dij==10.and.paw_ij(1)%has_dijhartree==0).or.& 4659 & (option_dij==11.and.paw_ij(1)%has_dijfock==0)) then 4660 msg='Incompatibilty between option_dij and allocation of Dij!' 4661 LIBPAW_BUG(msg) 4662 end if 4663 end if 4664 4665 !Set up parallelism over atoms 4666 paral_atom=(present(comm_atom).and.(my_natom/=natom)) 4667 nullify(my_atmtab);if (present(mpi_atmtab)) my_atmtab => mpi_atmtab 4668 my_comm_atom=xmpi_comm_self;if (present(comm_atom)) my_comm_atom=comm_atom 4669 call get_my_atmtab(my_comm_atom,my_atmtab,my_atmtab_allocated,paral_atom,natom,my_natom_ref=my_natom) 4670 4671 !Determine sizes of dij array according to options 4672 my_qphase=1;my_cplex_dij=1;my_ndij=1 4673 if (my_natom>0) then 4674 my_qphase=paw_ij(1)%qphase 4675 my_cplex_dij=paw_ij(1)%cplex_dij 4676 my_ndij=paw_ij(1)%ndij 4677 if (option_dij==4.or.option_dij==5.or.option_dij==9) my_qphase=1 4678 if (option_dij==10) my_cplex_dij=1 4679 if (option_dij==10) my_ndij=1 4680 end if 4681 4682 !Antiferro case ? 4683 antiferro=.false.;if (my_natom>0) antiferro=(paw_ij(1)%nspden==2.and.paw_ij(1)%nsppol==1.and.my_ndij/=4) 4684 ! Non-collinear case 4685 noncoll=.false.;if (my_natom>0) noncoll=(my_ndij==4) 4686 if (my_natom>0) then 4687 if (noncoll.and.paw_ij(1)%cplex_dij/=2) then 4688 msg='cplex_dij must be 2 with ndij=4!' 4689 LIBPAW_BUG(msg) 4690 end if 4691 end if 4692 !Do we use antiferro symmetries ? 4693 use_afm=((antiferro).or.(noncoll.and.afm_noncoll)) 4694 4695 !Do we have a phase due to q-vector? 4696 has_qphase=.false. 4697 if (my_natom>0) then 4698 has_qphase=(paw_ij(1)%qphase==2) 4699 if (present(qphon)) then 4700 if (any(abs(qphon(1:3))>tol8).and.(.not.has_qphase)) then 4701 msg='Should have qphase=2 for a non-zero q!' 4702 LIBPAW_BUG(msg) 4703 end if 4704 end if 4705 !DEBUG_ALTERNATE_ALGO 4706 ! if(lsymnew.and.has_qphase) then 4707 ! msg='symdij: alternate algo not available for phonons at q<>0!' 4708 ! LIBPAW_BUG(msg) 4709 ! end if 4710 !DEBUG_ALTERNATE_ALGO 4711 end if 4712 4713 !Printing of unsymetrized Dij 4714 if (abs(pawprtvol)>=1.and.option_dij==0.and.ipert/=natom+1.and.ipert/=natom+10) then 4715 wrt_mode='COLL';if (paral_atom) wrt_mode='PERS' 4716 pertstrg="DIJ";if (ipert>0) pertstrg="DIJ(1)" 4717 natinc=1;if(my_natom>1.and.pawprtvol>=0) natinc=my_natom-1 4718 write(msg, '(7a)') ch10," PAW TEST:",ch10,& 4719 & ' ========= Values of ',trim(pertstrg),' before symetrization =========',ch10 4720 call wrtout(std_out,msg,wrt_mode) 4721 do iatom=1,my_natom,natinc 4722 iatom_tot=iatom; if (paral_atom) iatom_tot=my_atmtab(iatom) 4723 call pawdij_print_dij(paw_ij(iatom)%dij,paw_ij(iatom)%cplex_dij,paw_ij(iatom)%qphase,& 4724 & iatom_tot,natom,paw_ij(iatom)%nspden,opt_prtvol=pawprtvol,mode_paral=wrt_mode) 4725 end do 4726 call wrtout(std_out,"",wrt_mode) 4727 end if 4728 4729 !Symmetrization occurs only when nsym>1 4730 if (nsym>1.and.ipert/=natom+1.and.ipert/=natom+10) then 4731 4732 if (pawang%nsym==0) then 4733 msg='pawang%zarot must be allocated!' 4734 LIBPAW_BUG(msg) 4735 end if 4736 4737 ! Have to make a temporary copy of dij 4738 LIBPAW_DATATYPE_ALLOCATE(my_tmp_dij,(my_natom)) 4739 if (my_natom>0) then 4740 do iatom=1,my_natom 4741 lmn2_size=paw_ij(iatom)%lmn2_size 4742 sz1=my_qphase*my_cplex_dij*lmn2_size;sz2=my_ndij 4743 LIBPAW_ALLOCATE(my_tmp_dij(iatom)%value,(sz1,sz2)) 4744 LIBPAW_ALLOCATE(dijtmp,(sz1,sz2)) 4745 if (option_dij==0) then 4746 dijtmp(:,:)=paw_ij(iatom)%dij(:,:) 4747 else if (option_dij==1) then 4748 dijtmp(:,:)=paw_ij(iatom)%dijhat(:,:) 4749 else if (option_dij==2) then 4750 dijtmp(:,:)=paw_ij(iatom)%dijU(:,:) 4751 else if (option_dij==3) then 4752 dijtmp(:,:)=paw_ij(iatom)%dijxc(:,:) 4753 else if (option_dij==4) then 4754 dijtmp(:,:)=paw_ij(iatom)%dijxc_hat(:,:) 4755 else if (option_dij==5) then 4756 dijtmp(:,:)=paw_ij(iatom)%dijxc_val(:,:) 4757 else if (option_dij==6) then 4758 dijtmp(:,:)=paw_ij(iatom)%dijso(:,:) 4759 else if (option_dij==7) then 4760 dijtmp(:,:)=paw_ij(iatom)%dijexxc(:,:) 4761 else if (option_dij==8) then 4762 dijtmp(:,:)=paw_ij(iatom)%dijfr(:,:) 4763 else if (option_dij==9) then 4764 dijtmp(:,:)=paw_ij(iatom)%dijnd(:,:) 4765 else if (option_dij==10) then 4766 dijtmp(:,1)=paw_ij(iatom)%dijhartree(:) 4767 else if (option_dij==11) then 4768 dijtmp(:,:)=paw_ij(iatom)%dijfock(:,:) 4769 end if 4770 !Has to translate Dij^{alpha,beta} into (Dij, Dij magnetic field) format 4771 if (my_ndij==4) then 4772 my_tmp_dij(iatom)%value(:,1)=dijtmp(:,1)+dijtmp(:,2) 4773 my_tmp_dij(iatom)%value(:,2)=dijtmp(:,3)+dijtmp(:,4) 4774 my_tmp_dij(iatom)%value(:,4)=dijtmp(:,1)-dijtmp(:,2) 4775 do klmn=1,paw_ij(iatom)%lmn2_size 4776 my_tmp_dij(iatom)%value(2*klmn-1,3)=-dijtmp(2*klmn ,3)+dijtmp(2*klmn ,4) 4777 my_tmp_dij(iatom)%value(2*klmn ,3)= dijtmp(2*klmn-1,3)-dijtmp(2*klmn-1,4) 4778 end do 4779 !DEBUG_ALTERNATE_ALGO 4780 ! if(lsymnew) my_tmp_dij(iatom)%value(:,:)=dijtmp(:,:) 4781 !DEBUG_ALTERNATE_ALGO 4782 else 4783 my_tmp_dij(iatom)%value(:,:)=dijtmp(:,:) 4784 end if 4785 LIBPAW_DEALLOCATE(dijtmp) 4786 end do 4787 end if 4788 4789 ! Parallelism: gather all Dij 4790 if (paral_atom) then 4791 LIBPAW_DATATYPE_ALLOCATE(tmp_dij,(natom)) 4792 call pawdij_gather(my_tmp_dij,tmp_dij,my_comm_atom,my_atmtab) 4793 do iatom=1,my_natom 4794 LIBPAW_DEALLOCATE(my_tmp_dij(iatom)%value) 4795 end do 4796 LIBPAW_DATATYPE_DEALLOCATE(my_tmp_dij) 4797 else 4798 tmp_dij=>my_tmp_dij 4799 end if 4800 4801 if (noncoll) then 4802 LIBPAW_ALLOCATE(symrec_cart,(3,3,nsym)) 4803 do irot=1,nsym 4804 symrec_cart(:,:,irot)=symdij_symcart(gprimd,rprimd,symrec(:,:,irot)) 4805 end do 4806 !DEBUG_ALTERNATE_ALGO 4807 ! if(lsymnew) then 4808 ! LIBPAW_ALLOCATE(sumrhoso,(my_cplex_dij,4)) 4809 ! end if 4810 !DEBUG_ALTERNATE_ALGO 4811 end if 4812 4813 ndij1=1 4814 if (antiferro) ndij1=2 4815 if (noncoll) ndij1=4 4816 ndij1=min(ndij1,my_ndij) 4817 ndij0=ndij1-1 4818 LIBPAW_ALLOCATE(dijnew,(my_cplex_dij,ndij1,my_qphase)) 4819 4820 ! Loops over atoms and spin components 4821 do iatom=1,my_natom 4822 iatom_tot=iatom;if (paral_atom) iatom_tot=my_atmtab(iatom) 4823 itypat=paw_ij(iatom)%itypat 4824 lmn_size=paw_ij(iatom)%lmn_size 4825 lmn2_size=paw_ij(iatom)%lmn2_size 4826 cplex_dij=min(paw_ij(iatom)%cplex_dij,my_cplex_dij) 4827 qphase=min(paw_ij(iatom)%qphase,my_qphase) 4828 indlmn => pawtab(itypat)%indlmn 4829 4830 !DEBUG_ALTERNATE_ALGO 4831 ! if (noncoll.and.lsymnew) then 4832 ! LIBPAW_ALLOCATE(dijtemp,(cplex_dij,my_ndij)) 4833 ! end if 4834 !DEBUG_ALTERNATE_ALGO 4835 4836 do ispden=1,paw_ij(iatom)%nsppol 4837 jspden=min(3-ispden,paw_ij(iatom)%nsppol) 4838 4839 ! Loops over (il,im) and (jl,jm) 4840 jl0=-1;jln0=-1;indexj=1 4841 do jlmn=1,lmn_size 4842 jl=indlmn(1,jlmn) 4843 jlpm=1+jl+indlmn(2,jlmn) 4844 jln=indlmn(5,jlmn) 4845 if (jln/=jln0) indexj=indexj+2*jl0+1 4846 j0lmn=jlmn*(jlmn-1)/2 4847 il0=-1;iln0=-1;indexi=1 4848 do ilmn=1,jlmn 4849 il=indlmn(1,ilmn) 4850 ilpm=1+il+indlmn(2,ilmn) 4851 iln=indlmn(5,ilmn) 4852 if (iln/=iln0) indexi=indexi+2*il0+1 4853 klmn=j0lmn+ilmn;klmnc=cplex_dij*(klmn-1) 4854 4855 nsym_used(:)=0 4856 4857 rotdij(:,:,:)=zero 4858 if (noncoll) rotmag(:,:,:)=zero 4859 !DEBUG_ALTERNATE_ALGO 4860 ! if (noncoll.and.lsymnew) sumrhoso(:,:)=zero 4861 !DEBUG_ALTERNATE_ALGO 4862 4863 ! Loop over symmetries 4864 do irot=1,nsym 4865 !DEBUG_ALTERNATE_ALGO 4866 ! if(lsymnew) then 4867 ! call mati3inv(symrec(:,:,irot),symrel_conv) 4868 ! call getspinrot(rprimd,spinrot,symrel_conv) 4869 ! Rspinrot(1,1)=cmplx(spinrot(1),-spinrot(4)) 4870 ! Rspinrot(1,2)=cmplx(-spinrot(3),-spinrot(2)) 4871 ! Rspinrot(2,1)=cmplx(spinrot(3),-spinrot(2)) 4872 ! Rspinrot(2,2)=cmplx(spinrot(1),spinrot(4)) 4873 ! end if 4874 !DEBUG_ALTERNATE_ALGO 4875 if ((symafm(irot)/=1).and.(.not.use_afm)) cycle 4876 kspden=ispden;if (symafm(irot)==-1) kspden=jspden 4877 iafm=1;if ((antiferro).and.(symafm(irot)==-1)) iafm=2 4878 factafm=dble(symafm(irot)) 4879 4880 nsym_used(iafm)=nsym_used(iafm)+1 4881 at_indx=indsym(4,irot,iatom_tot) 4882 4883 if (has_qphase) then 4884 arg=two_pi*(qphon(1)*indsym(1,irot,iatom)+qphon(2)*indsym(2,irot,iatom) & 4885 & +qphon(3)*indsym(3,irot,iatom)) 4886 phase(1)=cos(arg);phase(2)=sin(arg) 4887 end if 4888 4889 sumdij(:,:,:)=zero 4890 if (noncoll) summag(:,:,:)=zero 4891 4892 ! Accumulate values over (mi,mj) and symmetries 4893 do mj=1,2*jl+1 4894 indexjj=indexj+mj;indexjj0=indexjj*(indexjj-1)/2 4895 do mi=1,2*il+1 4896 indexii=indexi+mi 4897 factsym(:)=one 4898 if (indexii<=indexjj) then 4899 indexk=indexjj0+indexii 4900 factsym(2)=one 4901 else 4902 indexk=indexii*(indexii-1)/2+indexjj 4903 factsym(2)=-one 4904 end if 4905 indexkc=cplex_dij*(indexk-1) 4906 indexkc_q=indexkc+cplex_dij*lmn2_size 4907 4908 !DEBUG_ALTERNATE_ALGO 4909 ! if (noncoll.and.lsymnew) then 4910 ! do iplex=1,cplex_dij 4911 ! if(factafm>zero) then 4912 ! dijtemp(iplex,1)=factsym(iplex)*tmp_dij(at_indx)%value(indexkc+iplex,1) 4913 ! dijtemp(iplex,2)=factsym(iplex)*tmp_dij(at_indx)%value(indexkc+iplex,2) 4914 ! else 4915 ! dijtemp(iplex,1)=factsym(iplex)*tmp_dij(at_indx)%value(indexkc+iplex,2) 4916 ! dijtemp(iplex,2)=factsym(iplex)*tmp_dij(at_indx)%value(indexkc+iplex,1) 4917 ! end if 4918 ! if(factsym(2)<zero) then ! to be changed if symafm 4919 ! dijtemp(iplex,3)=factafm*factsym(iplex)*tmp_dij(at_indx)%value(indexkc+iplex,4) 4920 ! dijtemp(iplex,4)=factafm*factsym(iplex)*tmp_dij(at_indx)%value(indexkc+iplex,3) 4921 ! else 4922 ! dijtemp(iplex,3)=factafm*factsym(iplex)*tmp_dij(at_indx)%value(indexkc+iplex,3) 4923 ! dijtemp(iplex,4)=factafm*factsym(iplex)*tmp_dij(at_indx)%value(indexkc+iplex,4) 4924 ! end if 4925 ! end do 4926 ! end if 4927 !DEBUG_ALTERNATE_ALGO 4928 4929 ! Be careful: use here R_rel^-1 in term of spherical harmonics 4930 ! which is tR_rec in term of spherical harmonics 4931 ! so, use transpose[zarot].... however, we use here zarot (??) 4932 zarot2=pawang%zarot(mi,ilpm,il+1,irot)*pawang%zarot(mj,jlpm,jl+1,irot) 4933 ! zarot2=pawang%zarot(ilpm,mi,il+1,irot)*pawang%zarot(jlpm,mj,jl+1,irot) 4934 4935 if((.not.noncoll).or.(.not.lsymnew)) then 4936 fact(1)=factsym(1);fact(2)=factsym(2)*factafm !????? What? MT 4937 sumdij(1:cplex_dij,iafm,1)=sumdij(1:cplex_dij,iafm,1) & 4938 & +fact(1:cplex_dij)*zarot2 & 4939 & *tmp_dij(at_indx)%value(indexkc+1:indexkc+cplex_dij,kspden) 4940 if (qphase==2) & 4941 & sumdij(1:cplex_dij,iafm,2)=sumdij(1:cplex_dij,iafm,2) & 4942 & +fact(1:cplex_dij)*zarot2 & 4943 & *tmp_dij(at_indx)%value(indexkc_q+1:indexkc_q+cplex_dij,kspden) 4944 end if 4945 4946 if (noncoll.and.(.not.lsymnew)) then 4947 fact(1)=factsym(1)*factafm;fact(2)=factsym(2) 4948 do mu=1,3 4949 summag(1:cplex_dij,mu,1)=summag(1:cplex_dij,mu,1) & 4950 & +fact(1:cplex_dij)*zarot2 & 4951 & *tmp_dij(at_indx)%value(indexkc+1:indexkc+cplex_dij,1+mu) 4952 end do 4953 if (qphase==2) then 4954 do mu=1,3 4955 summag(1:cplex_dij,mu,2)=summag(1:cplex_dij,mu,2) & 4956 & +fact(1:cplex_dij)*zarot2 & 4957 & *tmp_dij(at_indx)%value(indexkc_q+1:indexkc_q+cplex_dij,1+mu) 4958 end do 4959 end if 4960 end if 4961 !DEBUG_ALTERNATE_ALGO 4962 ! if (noncoll.and.(lsymnew)) then 4963 ! dijt(1,1)=cmplx(dijtemp(1,1),dijtemp(2,1)) 4964 ! dijt(2,2)=cmplx(dijtemp(1,2),dijtemp(2,2)) 4965 ! dijt(1,2)=cmplx(dijtemp(1,3),dijtemp(2,3)) 4966 ! dijt(2,1)=cmplx(dijtemp(1,4),dijtemp(2,4)) 4967 ! dijt2(:,:)=czero 4968 ! do i1=1,2 4969 ! do i4=1,2 4970 ! do i2=1,2 4971 ! do i3=1,2 4972 ! dijt2(i1,i4)=dijt2(i1,i4)+Rspinrot(i1,i2)*dijt(i2,i3)*conjg(Rspinrot(i4,i3)) 4973 ! end do 4974 ! end do 4975 ! end do 4976 ! end do 4977 ! do mu=1,4 4978 ! if(mu==1) then 4979 ! i1=1;i4=1 4980 ! else if(mu==2) then 4981 ! i1=2;i4=2 4982 ! else if(mu==3) then 4983 ! i1=1;i4=2 4984 ! else if(mu==4) then 4985 ! i1=2;i4=1 4986 ! end if 4987 ! sumrhoso(1,mu)=sumrhoso(1,mu)+zarot2*real(dijt2(i1,i4)) 4988 ! sumrhoso(2,mu)=sumrhoso(2,mu)+zarot2*imag(dijt2(i1,i4)) 4989 ! end do 4990 ! end if 4991 end do ! mi 4992 end do ! mj 4993 !DEBUG_ALTERNATE_ALGO 4994 4995 ! Apply phase for phonons 4996 if (has_qphase) then 4997 !Remember, Dij is stored as follows: 4998 ! Dij= [Dij(2klmn-1)+i.Dij(2klmn)] 4999 ! +i.[Dij(lnm2_size+2klmn-1)+i.Dij(lmn2_size+2klmn)] 5000 if((.not.noncoll).or.(.not.lsymnew)) then 5001 do iplex=1,cplex_dij 5002 dijc(1)=sumdij(iplex,iafm,1) 5003 dijc(2)=sumdij(iplex,iafm,2) 5004 sumdij(iplex,iafm,1)=phase(1)*dijc(1)-phase(2)*dijc(2) 5005 sumdij(iplex,iafm,2)=phase(1)*dijc(2)+phase(2)*dijc(1) 5006 end do 5007 end if 5008 if (noncoll.and.(.not.lsymnew)) then 5009 do iplex=1,cplex_dij 5010 do mu=1,3 5011 dijc(1)=summag(iplex,mu,1) 5012 dijc(2)=summag(iplex,mu,2) 5013 summag(iplex,mu,1)=phase(1)*dijc(1)-phase(2)*dijc(2) 5014 summag(iplex,mu,2)=phase(1)*dijc(2)+phase(2)*dijc(1) 5015 end do 5016 end do 5017 end if 5018 !DEBUG_ALTERNATE_ALGO 5019 ! if (noncoll.and.(lsymnew) then 5020 ! do mu=1,4 5021 ! sumrhoso(1,mu)=phase(1)*sumrhoso(1,mu)-phase(2)*sumrhoso(2,mu) 5022 ! sumrhoso(2,mu)=phase(1)*sumrhoso(2,mu)+phase(2)*sumrhoso(1,mu) 5023 ! end do 5024 ! end do 5025 ! end if 5026 !DEBUG_ALTERNATE_ALGO 5027 end if 5028 5029 ! Add contribution of this rotation 5030 do iq=1,qphase 5031 rotdij(1:cplex_dij,iafm,iq)=rotdij(1:cplex_dij,iafm,iq) & 5032 & +sumdij(1:cplex_dij,iafm,iq) 5033 end do 5034 if (noncoll.and.(.not.lsymnew)) then 5035 ! If non-collinear case, rotate Dij magnetization 5036 ! Should use symrel^1 but use transpose[symrec] instead 5037 do iq=1,qphase 5038 do nu=1,3 5039 do mu=1,3 5040 !We need the transpose ? 5041 rotmag(1:cplex_dij,mu,iq)=rotmag(1:cplex_dij,mu,iq) & 5042 & +symrec_cart(mu,nu,irot)*summag(1:cplex_dij,nu,iq) 5043 end do 5044 end do 5045 end do 5046 end if 5047 5048 end do ! End loop over symmetries 5049 5050 if((.not.noncoll).or.(.not.lsymnew)) then 5051 ! Store new value of dij 5052 do iq=1,qphase 5053 do iplex=1,cplex_dij 5054 dijnew(iplex,1,iq)=rotdij(iplex,1,iq)/nsym_used(1) 5055 if (abs(dijnew(iplex,1,iq))<=tol10) dijnew(iplex,1,iq)=zero 5056 end do 5057 end do 5058 5059 ! Antiferromagnetic case: has to fill up "down" component of dij 5060 if (antiferro.and.nsym_used(2)>0) then 5061 do iq=1,qphase 5062 do iplex=1,cplex_dij 5063 dijnew(iplex,2,iq)=rotdij(iplex,2,iq)/nsym_used(2) 5064 if (abs(dijnew(iplex,2,iq))<=tol10) dijnew(iplex,2,iq)=zero 5065 end do 5066 end do 5067 end if 5068 !DEBUG_ALTERNATE_ALGO 5069 ! else if (noncoll.and.(lsymnew)) then 5070 ! do mu=1,4 5071 ! do iplex=1,cplex_dij 5072 ! dijnew(iplex,mu,1)=sumrhoso(iplex,mu)/nsym_used(1) 5073 ! if (abs(dijnew(iplex,mu,1))<=tol10) dijnew(iplex,mu,1)=zero 5074 ! end do 5075 ! end do 5076 !DEBUG_ALTERNATE_ALGO 5077 end if 5078 5079 ! Non-collinear case: store new values of Dij magnetization 5080 if (noncoll.and.(.not.lsymnew)) then 5081 ! Select on-zero elements 5082 do iq=1,qphase 5083 do mu=1,3 5084 do iplex=1,cplex_dij 5085 rotmag(iplex,mu,iq)=rotmag(iplex,mu,iq)/nsym_used(1) 5086 if (abs(rotmag(iplex,mu,iq))<=tol10) rotmag(iplex,mu,iq)=zero 5087 end do 5088 end do 5089 end do 5090 ! Transfer back to Dij^{alpha,beta} 5091 if(.not.lsymnew) then 5092 !Remember: cplex_dij is 2 in that case 5093 do iq=1,qphase 5094 dijnew(1,1,iq)=half*(dijnew(1,1,iq)+rotmag(1,3,iq)) 5095 dijnew(2,1,iq)=half*(dijnew(2,1,iq)+rotmag(2,3,iq)) 5096 dijnew(1,2,iq)= dijnew(1,1,iq)-rotmag(1,3,iq) 5097 dijnew(2,2,iq)= dijnew(2,1,iq)-rotmag(2,3,iq) 5098 dijnew(1,3,iq)=half*(rotmag(1,1,iq)+rotmag(2,2,iq)) 5099 dijnew(2,3,iq)=half*(rotmag(2,1,iq)-rotmag(1,2,iq)) 5100 dijnew(1,4,iq)=half*(rotmag(1,1,iq)-rotmag(2,2,iq)) 5101 dijnew(2,4,iq)=half*(rotmag(2,1,iq)+rotmag(1,2,iq)) 5102 end do 5103 end if 5104 end if 5105 ! Transfer new value of Dij in suitable pointer 5106 ii=klmnc 5107 do iq=1,qphase 5108 if (option_dij==0) then 5109 paw_ij(iatom)%dij(ii+1:ii+cplex_dij,ispden:ispden+ndij0)=dijnew(1:cplex_dij,1:ndij1,iq) 5110 else if (option_dij==1) then 5111 paw_ij(iatom)%dijhat(ii+1:ii+cplex_dij,ispden:ispden+ndij0)=dijnew(1:cplex_dij,1:ndij1,iq) 5112 else if (option_dij==2) then 5113 paw_ij(iatom)%dijU(ii+1:ii+cplex_dij,ispden:ispden+ndij0)=dijnew(1:cplex_dij,1:ndij1,iq) 5114 else if (option_dij==3) then 5115 paw_ij(iatom)%dijxc(ii+1:ii+cplex_dij,ispden:ispden+ndij0)=dijnew(1:cplex_dij,1:ndij1,iq) 5116 else if (option_dij==4) then 5117 paw_ij(iatom)%dijxc_hat(ii+1:ii+cplex_dij,ispden:ispden+ndij0)=dijnew(1:cplex_dij,1:ndij1,iq) 5118 else if (option_dij==5) then 5119 paw_ij(iatom)%dijxc_val(ii+1:ii+cplex_dij,ispden:ispden+ndij0)=dijnew(1:cplex_dij,1:ndij1,iq) 5120 else if (option_dij==6) then 5121 paw_ij(iatom)%dijso(ii+1:ii+cplex_dij,ispden:ispden+ndij0)=dijnew(1:cplex_dij,1:ndij1,iq) 5122 else if (option_dij==7) then 5123 paw_ij(iatom)%dijexxc(ii+1:ii+cplex_dij,ispden:ispden+ndij0)=dijnew(1:cplex_dij,1:ndij1,iq) 5124 else if (option_dij==8) then 5125 paw_ij(iatom)%dijfr(ii+1:ii+cplex_dij,ispden:ispden+ndij0)=dijnew(1:cplex_dij,1:ndij1,iq) 5126 else if (option_dij==9) then 5127 paw_ij(iatom)%dijnd(ii+1:ii+cplex_dij,ispden:ispden+ndij0)=dijnew(1:cplex_dij,1:ndij1,iq) 5128 else if (option_dij==10) then 5129 paw_ij(iatom)%dijhartree(ii+1:ii+cplex_dij)=dijnew(1:cplex_dij,1,iq) 5130 else if (option_dij==11) then 5131 paw_ij(iatom)%dijfock(ii+1:ii+cplex_dij,ispden:ispden+ndij0)=dijnew(1:cplex_dij,1:ndij1,iq) 5132 end if 5133 ii=ii+lmn2_size*cplex_dij 5134 end do 5135 5136 il0=il;iln0=iln ! End loops over (il,im) and (jl,jm) 5137 end do 5138 jl0=jl;jln0=jln 5139 end do 5140 5141 end do ! ispden 5142 5143 !DEBUG_ALTERNATE_ALGO 5144 ! if (noncoll.and.lsymnew) then 5145 ! LIBPAW_DEALLOCATE(dijtemp) 5146 ! end if 5147 !DEBUG_ALTERNATE_ALGO 5148 5149 end do ! iatom 5150 5151 LIBPAW_DEALLOCATE(dijnew) 5152 if (noncoll) then 5153 LIBPAW_DEALLOCATE(symrec_cart) 5154 !DEBUG_ALTERNATE_ALGO 5155 ! if (lsymnew) then 5156 ! LIBPAW_DEALLOCATE(sumrhoso) 5157 ! end if 5158 !DEBUG_ALTERNATE_ALGO 5159 end if 5160 5161 if (paral_atom) then 5162 do iatom=1,natom 5163 LIBPAW_DEALLOCATE(tmp_dij(iatom)%value) 5164 end do 5165 LIBPAW_DATATYPE_DEALLOCATE(tmp_dij) 5166 else 5167 do iatom=1,my_natom 5168 LIBPAW_DEALLOCATE(my_tmp_dij(iatom)%value) 5169 end do 5170 LIBPAW_DATATYPE_DEALLOCATE(my_tmp_dij) 5171 end if 5172 5173 else if (ipert/=natom+1.and.ipert/=natom+10) then ! nsym>1 5174 5175 ! ********************************************************************* 5176 ! If nsym==1, only cut small components of dij 5177 5178 if (antiferro) then 5179 msg='In the antiferromagnetic case, nsym cannot be 1' 5180 LIBPAW_BUG(msg) 5181 end if 5182 5183 do iatom=1,my_natom 5184 do ispden=1,my_ndij 5185 qphase=paw_ij(iatom)%qphase 5186 cplex_dij=paw_ij(iatom)%cplex_dij 5187 lmn2_size=paw_ij(iatom)%lmn2_size 5188 if (option_dij==0) then 5189 do klmn=1,lmn2_size*cplex_dij*qphase 5190 if (abs(paw_ij(iatom)%dij(klmn,ispden))<=tol10) paw_ij(iatom)%dij(klmn,ispden)=zero 5191 end do 5192 else if (option_dij==1) then 5193 do klmn=1,lmn2_size*cplex_dij*qphase 5194 if (abs(paw_ij(iatom)%dijhat(klmn,ispden))<=tol10) paw_ij(iatom)%dijhat(klmn,ispden)=zero 5195 end do 5196 else if (option_dij==2) then 5197 do klmn=1,lmn2_size*cplex_dij*qphase 5198 if (abs(paw_ij(iatom)%dijU(klmn,ispden))<=tol10) paw_ij(iatom)%dijU(klmn,ispden)=zero 5199 end do 5200 else if (option_dij==3) then 5201 do klmn=1,lmn2_size*cplex_dij*qphase 5202 if (abs(paw_ij(iatom)%dijxc(klmn,ispden))<=tol10) paw_ij(iatom)%dijxc(klmn,ispden)=zero 5203 end do 5204 else if (option_dij==4) then 5205 do klmn=1,lmn2_size*cplex_dij 5206 if (abs(paw_ij(iatom)%dijxc_hat(klmn,ispden))<=tol10) paw_ij(iatom)%dijxc_hat(klmn,ispden)=zero 5207 end do 5208 else if (option_dij==5) then 5209 do klmn=1,lmn2_size*cplex_dij 5210 if (abs(paw_ij(iatom)%dijxc_val(klmn,ispden))<=tol10) paw_ij(iatom)%dijxc_val(klmn,ispden)=zero 5211 end do 5212 else if (option_dij==6) then 5213 do klmn=1,lmn2_size*cplex_dij*qphase 5214 if (abs(paw_ij(iatom)%dijso(klmn,ispden))<=tol10) paw_ij(iatom)%dijso(klmn,ispden)=zero 5215 end do 5216 else if (option_dij==7) then 5217 do klmn=1,lmn2_size*cplex_dij*qphase 5218 if (abs(paw_ij(iatom)%dijexxc(klmn,ispden))<=tol10) paw_ij(iatom)%dijexxc(klmn,ispden)=zero 5219 end do 5220 else if (option_dij==8) then 5221 do klmn=1,lmn2_size*cplex_dij*qphase 5222 if (abs(paw_ij(iatom)%dijfr(klmn,ispden))<=tol10) paw_ij(iatom)%dijfr(klmn,ispden)=zero 5223 end do 5224 else if (option_dij==9) then 5225 do klmn=1,lmn2_size*cplex_dij 5226 if (abs(paw_ij(iatom)%dijnd(klmn,ispden))<=tol10) paw_ij(iatom)%dijnd(klmn,ispden)=zero 5227 end do 5228 else if (option_dij==10.and.ispden==1) then 5229 do klmn=1,lmn2_size*qphase 5230 if (abs(paw_ij(iatom)%dijhartree(klmn))<=tol10) paw_ij(iatom)%dijhartree(klmn)=zero 5231 end do 5232 else if (option_dij==11) then 5233 do klmn=1,lmn2_size*cplex_dij*qphase 5234 if (abs(paw_ij(iatom)%dijfock(klmn,ispden))<=tol10) paw_ij(iatom)%dijfock(klmn,ispden)=zero 5235 end do 5236 end if 5237 end do 5238 end do 5239 5240 end if ! nsym>1 5241 5242 !********************************************************************* 5243 !Printing of Dij 5244 5245 if (abs(pawprtvol)>=1.and.option_dij==0.and.ipert/=natom+1.and.ipert/=natom+10) then 5246 wrt_mode='COLL';if (paral_atom) wrt_mode='PERS' 5247 pertstrg="DIJ";if (ipert>0) pertstrg="DIJ(1)" 5248 natinc=1;if(my_natom>1.and.pawprtvol>=0) natinc=my_natom-1 5249 write(msg, '(7a)') ch10," PAW TEST:",ch10,& 5250 & ' ========= Values of ',trim(pertstrg),' after symetrization =========',ch10 5251 call wrtout(std_out,msg,wrt_mode) 5252 do iatom=1,my_natom,natinc 5253 iatom_tot=iatom; if (paral_atom) iatom_tot=my_atmtab(iatom) 5254 call pawdij_print_dij(paw_ij(iatom)%dij,paw_ij(iatom)%cplex_dij,paw_ij(iatom)%qphase,& 5255 & iatom_tot,natom,paw_ij(iatom)%nspden,opt_prtvol=pawprtvol,mode_paral=wrt_mode) 5256 end do 5257 call wrtout(std_out,"",wrt_mode) 5258 end if 5259 5260 !Destroy atom table used for parallelism 5261 call free_my_atmtab(my_atmtab,my_atmtab_allocated) 5262 5263 !********************************************************************* 5264 !Small function: convert a symmetry operation 5265 !from reduced coordinates (integers) to cartesian coordinates (reals) 5266 contains 5267 function symdij_symcart(aprim,bprim,symred) 5268 5269 real(dp) :: symdij_symcart(3,3) 5270 integer,intent(in) :: symred(3,3) 5271 real(dp),intent(in) :: aprim(3,3),bprim(3,3) 5272 integer :: ii,jj,kk 5273 real(dp) :: tmp(3,3) 5274 symdij_symcart=zero;tmp=zero 5275 do kk=1,3 5276 do jj=1,3 5277 do ii=1,3 5278 tmp(ii,jj)=tmp(ii,jj)+bprim(ii,kk)*dble(symred(jj,kk)) 5279 end do 5280 end do 5281 end do 5282 do kk=1,3 5283 do jj=1,3 5284 do ii=1,3 5285 symdij_symcart(ii,jj)=symdij_symcart(ii,jj)+aprim(ii,kk)*tmp(jj,kk) 5286 end do 5287 end do 5288 end do 5289 end function symdij_symcart 5290 5291 end subroutine symdij
m_pawdij/symdij_all [ Functions ]
[ Top ] [ m_pawdij ] [ Functions ]
NAME
symdij_all
FUNCTION
Symmetrize all contributions to PAW non-local strengths Dij
INPUTS
gprimd(3,3)=dimensional primitive translations for reciprocal space(bohr^-1). indsym(4,nsym,natom)=indirect indexing array for atom labels ipert=index of perturbation if pawrhoij is a pertubed rhoij no meaning for ground-state calculations (should be 0) mpi_atmtab(:)=--optional-- indexes of the atoms treated by current proc comm_atom=--optional-- MPI communicator over atoms my_natom=number of atoms treated by current processor natom=number of atoms in cell nsym=number of symmetry elements in space group ntypat=number of types of atoms in unit cell. paw_ij(natom)%cplex_dij=1 if dij are REAL, 2 if they are COMPLEX paw_ij(natom)%qphase=2 if exp^(-i.q.r) phase from RF at q<>0, 1 otherwise paw_ij(natom)%lmn_size=number of (l,m,n) elements for the paw basis paw_ij(natom)%nspden=number of spin-density components paw_ij(natom)%nsppol=number of independant spin-density components paw_ij(natom)%dij(lmn2_size,nspden)=non-symmetrized paw dij quantities pawang <type(pawang_type)>=angular mesh discretization and related data pawprtvol=control print volume and debugging output for PAW pawtab(ntypat) <type(pawtab_type)>=paw tabulated starting data rprimd(3,3)=real space primitive translations. symafm(nsym)=(anti)ferromagnetic part of symmetry operations symrec(3,3,nsym)=symmetries of group in terms of operations on reciprocal space primitive translations
SIDE EFFECTS
paw_ij(natom)%dij???(cplex_dij*qphase*lmn2_size,nspden)=symmetrized dij quantities as output
SOURCE
5333 subroutine symdij_all(gprimd,indsym,ipert,my_natom,natom,nsym,ntypat,& 5334 & paw_ij,pawang,pawprtvol,pawtab,rprimd,symafm,symrec,& 5335 & mpi_atmtab,comm_atom) ! optional arguments (parallelism) 5336 5337 !Arguments --------------------------------------------- 5338 !scalars 5339 integer,intent(in) :: ipert,my_natom,natom,nsym,ntypat,pawprtvol 5340 integer,optional,intent(in) :: comm_atom 5341 type(pawang_type),intent(in) :: pawang 5342 !arrays 5343 integer,intent(in) :: indsym(4,nsym,natom),symafm(nsym),symrec(3,3,nsym) 5344 integer,optional,target,intent(in) :: mpi_atmtab(:) 5345 real(dp),intent(in) :: gprimd(3,3),rprimd(3,3) 5346 type(paw_ij_type),intent(inout) :: paw_ij(my_natom) 5347 type(pawtab_type),intent(in) :: pawtab(ntypat) 5348 5349 !Local variables --------------------------------------- 5350 !scalars 5351 integer,parameter :: MAX_NOPTS=12 5352 integer :: ii,option_dij,my_comm_atom,nopt 5353 logical :: my_atmtab_allocated,paral_atom 5354 character(len=500) :: msg 5355 !arrays 5356 integer :: options(MAX_NOPTS) 5357 integer,pointer :: my_atmtab(:) 5358 5359 ! ********************************************************************* 5360 5361 nopt = 0 5362 if (ANY(paw_ij(:)%has_dij==2)) then 5363 nopt = nopt + 1 5364 options(nopt) = 0 5365 end if 5366 5367 if (ANY(paw_ij(:)%has_dijhat==2)) then 5368 nopt = nopt + 1 5369 options(nopt) = 1 5370 end if 5371 5372 if (ANY(paw_ij(:)%has_dijU==2)) then 5373 nopt = nopt + 1 5374 options(nopt) = 2 5375 end if 5376 5377 if (ANY(paw_ij(:)%has_dijxc==2)) then 5378 nopt = nopt + 1 5379 options(nopt) = 3 5380 end if 5381 5382 if (ANY(paw_ij(:)%has_dijxc_hat==2)) then 5383 nopt = nopt + 1 5384 options(nopt) = 4 5385 end if 5386 5387 if (ANY(paw_ij(:)%has_dijxc_val==2)) then 5388 nopt = nopt + 1 5389 options(nopt) = 5 5390 end if 5391 5392 if (ANY(paw_ij(:)%has_dijso==2)) then 5393 nopt = nopt + 1 5394 options(nopt) = 6 5395 end if 5396 5397 if (ANY(paw_ij(:)%has_dijexxc==2)) then 5398 nopt = nopt + 1 5399 options(nopt) = 7 5400 end if 5401 5402 if (ANY(paw_ij(:)%has_dijfr==2)) then 5403 nopt = nopt + 1 5404 options(nopt) = 8 5405 end if 5406 5407 if (ANY(paw_ij(:)%has_dijnd==2)) then 5408 nopt = nopt + 1 5409 options(nopt) = 9 5410 end if 5411 5412 if (ANY(paw_ij(:)%has_dijhartree==2)) then 5413 nopt = nopt + 1 5414 options(nopt) = 10 5415 end if 5416 5417 if (ANY(paw_ij(:)%has_dijfock==2)) then 5418 nopt = nopt + 1 5419 options(nopt) = 11 5420 end if 5421 5422 if (ANY(paw_ij(:)%has_exexch_pot==2)) then 5423 nopt = nopt + 1 5424 options(nopt) = 10 5425 msg='symetrization of dij_exexch not coded!' 5426 LIBPAW_ERROR(msg) 5427 end if 5428 5429 !Set up parallelism over atoms 5430 paral_atom=(present(comm_atom)) 5431 nullify(my_atmtab);if (present(mpi_atmtab)) my_atmtab => mpi_atmtab 5432 my_comm_atom=xmpi_comm_self;if (present(comm_atom)) my_comm_atom=comm_atom 5433 call get_my_atmtab(my_comm_atom,my_atmtab,my_atmtab_allocated,paral_atom,natom,my_natom_ref=my_natom) 5434 5435 do ii=1,nopt 5436 option_dij = options(ii) 5437 if (paral_atom) then 5438 call symdij(gprimd,indsym,ipert,my_natom,natom,nsym,ntypat,option_dij,& 5439 & paw_ij,pawang,pawprtvol,pawtab,rprimd,symafm,symrec,& 5440 & comm_atom=my_comm_atom,mpi_atmtab=my_atmtab) 5441 else 5442 call symdij(gprimd,indsym,ipert,my_natom,natom,nsym,ntypat,option_dij,& 5443 & paw_ij,pawang,pawprtvol,pawtab,rprimd,symafm,symrec) 5444 end if 5445 end do 5446 5447 !Destroy atom table used for parallelism 5448 call free_my_atmtab(my_atmtab,my_atmtab_allocated) 5449 5450 end subroutine symdij_all