TABLE OF CONTENTS
- ABINIT/m_pawxc
- m_pawxc/pawxc
- m_pawxc/pawxc_dfpt
- m_pawxc/pawxc_drivexc_abinit
- m_pawxc/pawxc_drivexc_libxc
- m_pawxc/pawxc_drivexc_wrapper
- m_pawxc/pawxc_get_nkxc
- m_pawxc/pawxc_get_usekden
- m_pawxc/pawxc_get_uselaplacian
- m_pawxc/pawxc_get_xclevel
- m_pawxc/pawxc_is_tb09
- m_pawxc/pawxc_mkdenpos_wrapper
- m_pawxc/pawxc_rotate_back_mag
- m_pawxc/pawxc_rotate_back_mag_dfpt
- m_pawxc/pawxc_rotate_mag
- m_pawxc/pawxc_size_dvxc_wrapper
- m_pawxc/pawxc_xcmult_wrapper
- m_pawxc/pawxc_xcpositron_wrapper
- m_pawxc/pawxcm
- m_pawxc/pawxcm_dfpt
- m_pawxc/pawxcmpositron
- m_pawxc/pawxcpositron
- m_pawxc/pawxcsph
- m_pawxc/pawxcsph_dfpt
- m_pawxc/pawxcsphpositron
- m_pawxc/pawxcsum
- pawxc_mkdenpos_wrapper/pawxc_mkdenpos_local
- pawxc_size_dvxc_wrapper/pawxc_size_dvxc_local
- pawxc_xcmult_wrapper/pawxc_xcmult_local
- pawxc_xcpositron_wrapper/pawxc_xcpositron_abinit
- pawxc_xcpositron_wrapper/pawxc_xcpositron_local
ABINIT/m_pawxc [ Modules ]
NAME
m_pawxc
FUNCTION
XC+PAW related operations
COPYRIGHT
Copyright (C) 2013-2024 ABINIT group (MT, FJ, TR, GJ, TD) This file is distributed under the terms of the GNU General Public License, see ~abinit/COPYING or http://www.gnu.org/copyleft/gpl.txt .
NOTES
FOR DEVELOPERS: in order to preserve the portability of libPAW library, please consult ~abinit/src/??_libpaw/libpaw-coding-rules.txt
SOURCE
20 #include "libpaw.h" 21 22 module m_pawxc 23 24 USE_DEFS 25 USE_MSG_HANDLING 26 USE_MEMORY_PROFILING 27 28 #ifdef LIBPAW_ISO_C_BINDING 29 use, intrinsic :: iso_c_binding, only : c_ptr,c_loc,c_f_pointer 30 #endif 31 32 #ifdef HAVE_LIBPAW_ABINIT 33 use m_xcpositron, only : xcpositron 34 use m_drivexc, only : drivexc,size_dvxc,xcmult,mkdenpos 35 use m_xc_noncoll, only : rotate_mag,rotate_back_mag,rotate_back_mag_dfpt 36 #endif 37 38 use m_libpaw_libxc 39 40 use m_pawang, only : pawang_type 41 use m_pawrad, only : pawrad_type,nderiv_gen,pawrad_deducer0,simp_gen 42 43 implicit none 44 45 private 46 47 public :: pawxc ! Compute xc correlation potential and energies inside a paw sphere. USE (r,theta,phi) 48 public :: pawxcpositron ! Compute electron-positron correlation potential and energies inside a PAW sphere. USE (r,theta,phi) 49 public :: pawxc_dfpt ! Compute first-order change of XC potential and contribution to 50 ! 2nd-order change of XC energy inside a PAW sphere. USE (r,theta,phi) 51 public :: pawxcsum ! Compute useful sums of moments of densities needed to compute on-site contributions to XC energy and potential 52 public :: pawxcm ! Compute xc correlation potential and energies inside a paw sphere. USE (L,M) MOMENTS 53 public :: pawxcmpositron ! Compute electron-positron correlation potential and energies inside a PAW sphere. USE (L,M) MOMENTS 54 public :: pawxcm_dfpt ! Compute 1st-order change of XC potential and contrib 55 ! to 2nd-order change of XC ene inside a PAW sphere. USE (L,M) MOMENTS 56 public :: pawxc_get_nkxc ! Compute size of XC kernel (Kxc) according to spin polarization and XC type 57 public :: pawxc_get_xclevel ! Get XC level (1=LDA, 2=GGA/mGGA, 3=TDDFT) 58 public :: pawxc_get_usekden ! Assess whether kinetic energy density is used in XC functional 59 public :: pawxc_get_uselaplacian ! Assess whether laplacian of density is used in XC functional 60 public :: pawxc_is_tb09 ! Assess whether the XC functional is Tran-Blaha 09 (modified BJ) 61 62 !Private procedures 63 private :: pawxcsph ! Compute XC energy and potential for a spherical density rho(r) given as (up,dn) 64 private :: pawxcsphpositron ! Compute electron-positron XC energy and potential for spherical densities rho_el(r) rho_pos(r) 65 private :: pawxcsph_dfpt ! Compute XC 1st-order potential for a 1st-order spherical density rho1(r) 66 private :: pawxc_rotate_mag ! Rotate a non-collinear density wrt a magnetization 67 private :: pawxc_rotate_back_mag ! Rotate back a collinear XC potential wrt a magnetization 68 private :: pawxc_rotate_back_mag_dfpt ! Rotate back a collinear 1st-order XC potential wrt a magnetization 69 70 !Wrappers 71 private :: pawxc_drivexc_wrapper ! wrapper for drivexc 72 private :: pawxc_mkdenpos_wrapper ! wrapper for mkdenpos 73 private :: pawxc_xcmult_wrapper ! wrapper for xcmult 74 private :: pawxc_size_dvxc_wrapper ! wrapper for size_dvxc 75 private :: pawxc_xcpositron_wrapper ! wrapper for xcpositron 76 77 !Zero of density 78 real(dp),parameter :: rho_min=tol14
m_pawxc/pawxc [ Functions ]
[ Top ] [ m_pawxc ] [ Functions ]
NAME
pawxc
FUNCTION
Start from the density or spin-density, and compute xc correlation potential and energies inside a paw sphere. USE THE DENSITY OVER A WHOLE SPHERICAL GRID (r,theta,phi) Driver of XC functionals.
INPUTS
corexc(nrad)=core density on radial grid ixc= choice of exchange-correlation scheme lm_size=size of density array rhor (see below) lmselect(lm_size)=select the non-zero LM-moments of input density rhor nhat(nrad,lm_size,nspden)=compensation density (total in 1st half and spin-up in 2nd half if nspden=2) nkxc=second dimension of the kxc array. If /=0, the exchange-correlation kernel must be computed non_magnetic_xc= if true, handle density/potential as non-magnetic (even if it is) nrad=size of radial mesh for densities/potentials (might be different from pawrad%mesh_size) nspden=number of spin-density components option=0 compute both XC energies (direct+double-counting) and potential 1 compute only XC potential 2 compute only XC energies (direct+double-counting) 3 compute only XC energy by direct scheme 4 compute only XC energy by direct scheme for spherical part of the density 5 compute only XC potential for spherical part of the density pawang <type(pawang_type)>=paw angular mesh and related data pawrad <type(pawrad_type)>=paw radial mesh and related data rhor(nrad,lm_size,nspden)=electron density in real space in electrons/bohr**3 (total in 1st half and spin-up in 2nd half if nspden=2) usecore= 1 if core density has to be used in Exc/Vxc ; 0 otherwise usexcnhat= 0 if compensation density does not have to be used 1 if compensation density has to be used in double counting energy term only 2 if compensation density (nhat) has to be used in Exc/Vxc and double counting energy term xclevel= XC functional level xc_denpos= lowest allowed density (usually for the computation of the XC functionals) ----- Optional arguments ----- [coretau(nrad*usekden)]= core kinetic energy density (optional) [taur(nrad,lm_size,nspden*usekden)]= kinetic energy density on radial mesh (optional) [xc_taupos]= lowest allowed kinetic energy density (for mGGA XC functionals)
OUTPUT
== if option=0, 2, 3, or 4 ==
enxc=returned exchange and correlation energy (hartree)
== if option=0 or 2 ==
enxcdc=returned exchange-cor. contribution to double-counting energy
== if option=0, 1 or 5 ==
vxc(nrad,pawang%angl_size,nspden)=xc potential
(spin up in 1st half and spin-down in 2nd half if nspden=2)
== if option=0, 1 or 5 and usekden=1 ==
[vxctau(nrad,pawang%angl_size,nspden*usekden)]=xc potential due to kinetic energy density
(spin up in 1st half and spin-down in 2nd half if nspden=2) (optional)
== if nkxc>0 ==
kxc(nrad,pawang%angl_size,nkxc)=xc kernel
(see notes below for nkxc)
== if nk3xc>0 ==
k3xc(nrad,pawang%angl_size,nk3xc)= derivative of xc kernel
(see notes below for nk3xc)
== For the TB09 XC functional (modified Becke-Johnson)
[grho1_over_rho1]=Integral of |Grad(rho^1)|/rho^1 over the augmentation region
Used to compute the c parameter of the TB09 XC functional
NOTES
Content of Kxc array:
===== if LDA
if nspden==1: kxc(:,1)= d2Exc/drho2
(kxc(:,2)= d2Exc/drho_up drho_dn)
if nspden>=2: kxc(:,1)= d2Exc/drho_up drho_up
kxc(:,2)= d2Exc/drho_up drho_dn
kxc(:,3)= d2Exc/drho_dn drho_dn
if nspden==4: kxc(:,4:6)= (m_x, m_y, m_z) (magnetization)
===== if GGA or mGGA
if nspden==1:
kxc(:,1)= d2Exc/drho2
kxc(:,2)= 1/|grad(rho)| dExc/d|grad(rho)|
kxc(:,3)= 1/|grad(rho)| d2Exc/d|grad(rho)| drho
kxc(:,4)= 1/|grad(rho)| * d/d|grad(rho)| ( 1/|grad(rho)| dExc/d|grad(rho)| )
kxc(:,5)= gradx(rho)
kxc(:,6)= grady(rho)
kxc(:,7)= gradz(rho)
if nspden>=2:
kxc(:,1)= d2Exc/drho_up drho_up
kxc(:,2)= d2Exc/drho_up drho_dn
kxc(:,3)= d2Exc/drho_dn drho_dn
kxc(:,4)= 1/|grad(rho_up)| dEx/d|grad(rho_up)|
kxc(:,5)= 1/|grad(rho_dn)| dEx/d|grad(rho_dn)|
kxc(:,6)= 1/|grad(rho_up)| d2Ex/d|grad(rho_up)| drho_up
kxc(:,7)= 1/|grad(rho_dn)| d2Ex/d|grad(rho_dn)| drho_dn
kxc(:,8)= 1/|grad(rho_up)| * d/d|grad(rho_up)| ( 1/|grad(rho_up)| dEx/d|grad(rho_up)| )
kxc(:,9)= 1/|grad(rho_dn)| * d/d|grad(rho_dn)| ( 1/|grad(rho_dn)| dEx/d|grad(rho_dn)| )
kxc(:,10)=1/|grad(rho)| dEc/d|grad(rho)|
kxc(:,11)=1/|grad(rho)| d2Ec/d|grad(rho)| drho_up
kxc(:,12)=1/|grad(rho)| d2Ec/d|grad(rho)| drho_dn
kxc(:,13)=1/|grad(rho)| * d/d|grad(rho)| ( 1/|grad(rho)| dEc/d|grad(rho)| )
kxc(:,14)=gradx(rho_up)
kxc(:,15)=gradx(rho_dn)
kxc(:,16)=grady(rho_up)
kxc(:,17)=grady(rho_dn)
kxc(:,18)=gradz(rho_up)
kxc(:,19)=gradz(rho_dn)
if nspden==4:
kxc(:,20:22)= (m_x, m_y, m_z) (magnetization)
Note about mGGA: 2nd derivatives involving Tau or Laplacian are not output
Content of K3xc array:
===== if LDA (xclevel=1) :
if nspden==1: return k3xc(:,1)=d3Exc/drho3
if nspden>=2, return k3xc(:,1)=d3Exc/drho_up drho_up drho_up
k3xc(:,2)=d3Exc/drho_up drho_up drho_dn
k3xc(:,3)=d3Exc/drho_up drho_dn drho_dn
k3xc(:,4)=d3Exc/drho_dn drho_dn drho_dn
SOURCE
910 subroutine pawxc(corexc,enxc,enxcdc,hyb_mixing,ixc,kxc,k3xc,lm_size,lmselect,nhat,nkxc,nk3xc,non_magnetic_xc,& 911 & nrad,nspden,option,pawang,pawrad,rhor,usecore,usexcnhat,vxc,xclevel,xc_denpos,& 912 & coretau,taur,vxctau,xc_taupos,grho1_over_rho1) ! optional arguments 913 914 !Arguments ------------------------------------ 915 !scalars 916 integer,intent(in) :: ixc,lm_size,nkxc,nk3xc,nrad,nspden,option,usecore,usexcnhat,xclevel 917 logical,intent(in) :: non_magnetic_xc 918 real(dp),intent(in) :: hyb_mixing,xc_denpos 919 real(dp),intent(in),optional :: xc_taupos 920 real(dp),intent(out) :: enxc,enxcdc 921 real(dp),intent(out),optional :: grho1_over_rho1 922 type(pawang_type),intent(in) :: pawang 923 type(pawrad_type),intent(in) :: pawrad 924 !arrays 925 logical,intent(in) :: lmselect(lm_size) 926 real(dp),intent(in) :: corexc(nrad) 927 real(dp),intent(in) :: nhat(nrad,lm_size,nspden*((usexcnhat+1)/2)) 928 real(dp),intent(in),target :: rhor(nrad,lm_size,nspden) 929 real(dp),intent(in),target,optional:: coretau(:),taur(:,:,:) 930 real(dp),intent(out) :: kxc(nrad,pawang%angl_size,nkxc) 931 real(dp),intent(out) :: k3xc(nrad,pawang%angl_size,nk3xc) 932 real(dp),intent(out),target :: vxc(nrad,pawang%angl_size,nspden) 933 real(dp),intent(out),target,optional :: vxctau(:,:,:) 934 935 !Local variables------------------------------- 936 !scalars 937 integer,parameter :: mu(3,3)=reshape([4,9,8,9,5,7,8,7,6],[3,3]) ! Voigt indices 938 integer :: ii,ilm,ipts,ir,ispden,iwarn,jj,lm_size_eff,ndvxc,nd2vxc,ngrad 939 integer :: nkxc_updn,npts,nspden_eff,nspden_updn,nspgrad,nu 940 integer :: nvxcgrho,nvxclrho,nvxctau,order 941 integer :: usecoretau,usegradient,usekden,uselaplacian 942 logical :: need_vxctau,with_taur 943 real(dp) :: enxcr,factor,my_xc_taupos,rhotot,sumg,vxcrho 944 character(len=500) :: msg 945 !arrays 946 real(dp),allocatable :: dgxc(:),dlxc(:),d2lxc(:),dnexcdn(:,:),drho(:),d2rho(:),drhocore(:) 947 real(dp),allocatable :: vxci(:,:),vxci_grho(:,:),vxci_lrho(:,:),vxci_tau(:,:) 948 real(dp),allocatable :: dvxci(:,:),d2vxci(:,:),dylmdr(:,:,:) 949 real(dp),allocatable :: exci(:),ff(:),grho2_updn(:,:),gxc(:,:,:,:),lxc(:,:,:) 950 real(dp),allocatable :: rhoarr(:,:),rho_updn(:,:),lrho_updn(:,:),lrhocore(:) 951 real(dp),allocatable :: tauarr(:,:),tau_updn(:,:),ylmlapl(:,:) 952 real(dp),allocatable,target :: mag(:,:,:),rhohat(:,:,:),rhonow(:,:,:) 953 real(dp),pointer :: mag_(:,:),rho_(:,:,:),tau_(:,:,:),vxctau_(:,:,:) 954 real(dp), LIBPAW_CONTIGUOUS pointer :: vxc_diag(:,:),vxc_nc(:,:),vxc_updn(:,:,:) 955 #ifdef LIBPAW_ISO_C_BINDING 956 type(C_PTR) :: cptr 957 #endif 958 959 ! ************************************************************************* 960 961 !---------------------------------------------------------------------- 962 !----- Check options 963 !---------------------------------------------------------------------- 964 965 !Some dimensions 966 nkxc_updn=merge(nkxc-3,nkxc,nkxc==6.or.nkxc==22) 967 968 !Compatibility tests 969 if(nspden==4.and.nk3xc>0) then 970 msg='K3xc for nspden=4 not implemented!' 971 LIBPAW_ERROR(msg) 972 end if 973 if(nk3xc>0.and.nkxc_updn==0) then 974 msg='nkxc must be non-zero if nk3xc is!' 975 LIBPAW_ERROR(msg) 976 end if 977 if(nspden==4.and.xclevel==2.and..not.non_magnetic_xc) then 978 msg='GGA/mGGA for nspden=4 not fully implemented! (only works if usepawu=4 or pawxcdev/=0)' 979 LIBPAW_ERROR(msg) 980 end if 981 if(pawang%angl_size==0) then 982 msg='pawang%angl_size=0!' 983 LIBPAW_BUG(msg) 984 end if 985 if(.not.allocated(pawang%ylmr)) then 986 msg='pawang%ylmr must be allocated!' 987 LIBPAW_BUG(msg) 988 end if 989 if(xclevel==2.and.(.not.allocated(pawang%ylmrgr))) then 990 msg='pawang%ylmrgr must be allocated!' 991 LIBPAW_BUG(msg) 992 end if 993 if(option==4.or.option==5) then 994 if (pawang%angl_size/=1) then 995 msg='When option=4 or 5, pawang%angl_size must be 1!' 996 LIBPAW_BUG(msg) 997 end if 998 if (pawang%ylm_size/=1) then 999 msg='When option=4 or 5, pawang%ylm_size must be 1!' 1000 LIBPAW_BUG(msg) 1001 end if 1002 if (abs(pawang%anginit(1,1)-one)>tol12.or.abs(pawang%anginit(2,1))>tol12.or. & 1003 & abs(pawang%anginit(3,1))>tol12) then 1004 msg='When option=4 or 5, pawang%anginit must be (1 0 0)!' 1005 LIBPAW_BUG(msg) 1006 end if 1007 end if 1008 if (option/=1.and.option/=5) then 1009 if (nrad<pawrad%int_meshsz) then 1010 msg='When option=0,2,3,4, nrad must be greater than pawrad%int_meshsz!' 1011 LIBPAW_BUG(msg) 1012 end if 1013 end if 1014 1015 1016 !---------------------------------------------------------------------- 1017 !----- Initializations 1018 !---------------------------------------------------------------------- 1019 iwarn=0 1020 nspden_updn=min(nspden,2) 1021 nspden_eff=nspden_updn;if (nspden==4.and.xclevel==2) nspden_eff=4 1022 npts=pawang%angl_size 1023 lm_size_eff=min(lm_size,pawang%ylm_size) 1024 ngrad=1;if(xclevel==2)ngrad=2 1025 nspgrad=0;if (xclevel==2) nspgrad=3*nspden_updn-1 1026 if (option/=1.and.option/=5) enxc=zero 1027 if (option==0.or.option==2) enxcdc=zero 1028 if (option/=3.and.option/=4) vxc(:,:,:)=zero 1029 if (present(vxctau).and.option/=3.and.option/=4) vxctau(:,:,:)=zero 1030 if (nkxc>0) kxc(:,:,:)=zero 1031 if (nk3xc>0) k3xc(:,:,:)=zero 1032 order=1;if (nkxc_updn>0) order=2;if (nk3xc>0) order=3 ! to which der. of the energy the computation must be done 1033 if (present(grho1_over_rho1)) grho1_over_rho1=zero 1034 my_xc_taupos=xc_denpos;if(present(xc_taupos)) my_xc_taupos=xc_taupos 1035 1036 if (xclevel==0.or.ixc==0) then 1037 msg='Note that no xc is applied (ixc=0).' 1038 LIBPAW_WARNING(msg) 1039 1040 else 1041 1042 ! Determine several flags/sizes defining the XCfunctional 1043 call pawxc_size_dvxc_wrapper(ixc,order,nspden_updn,& 1044 & usegradient=usegradient,uselaplacian=uselaplacian,usekden=usekden,& 1045 & nvxcgrho=nvxcgrho,nvxclrho=nvxclrho,nvxctau=nvxctau,ndvxc=ndvxc,nd2vxc=nd2vxc) 1046 1047 ! Allocation of temporary memory space 1048 LIBPAW_ALLOCATE(rhonow,(nrad,nspden,ngrad*ngrad+uselaplacian)) 1049 LIBPAW_ALLOCATE(rhoarr,(nrad,nspden)) 1050 if (usexcnhat>0) then 1051 LIBPAW_ALLOCATE(rhohat,(nrad,lm_size,nspden)) 1052 rhohat(:,:,:)=rhor(:,:,:)+nhat(:,:,:) 1053 end if 1054 if (usexcnhat< 2) rho_=> rhor 1055 if (usexcnhat==2) rho_=> rhohat 1056 if (option/=3.and.option/=4) then 1057 if (nspden/=4) then 1058 vxc_updn => vxc 1059 else 1060 LIBPAW_POINTER_ALLOCATE(vxc_updn,(nrad,npts,nspden_updn)) 1061 LIBPAW_ALLOCATE(mag,(nrad,npts,3)) 1062 end if 1063 end if 1064 1065 ! Meta-GGA: allocation of temporary space 1066 with_taur=.false. ; tau_ => null() 1067 usecoretau=0 ; need_vxctau=.false. 1068 LIBPAW_ALLOCATE(tauarr,(nrad,nspden*usekden)) 1069 if (usekden==1) then 1070 if (present(taur)) then 1071 with_taur=.true. ; tau_=> taur 1072 if (size(taur)/=nrad*lm_size*nspden) then 1073 msg='wrong size for taur!' 1074 LIBPAW_BUG(msg) 1075 end if 1076 end if 1077 if (present(vxctau)) then 1078 need_vxctau=.true. ; vxctau_ => vxctau 1079 if (size(vxctau)/=nrad*pawang%angl_size*nspden) then 1080 msg='wrong size for vxctau!' 1081 LIBPAW_BUG(msg) 1082 end if 1083 else if (option==0.or.option==2) then 1084 !Need to compute vxctau temporarily 1085 need_vxctau=.true. 1086 LIBPAW_ALLOCATE(vxctau_,(nrad,pawang%angl_size,nspden)) 1087 end if 1088 if (present(coretau)) then 1089 usecoretau=usecore 1090 if (size(coretau)/=nrad) then 1091 msg='wrong size for coretau!' 1092 LIBPAW_BUG(msg) 1093 end if 1094 end if 1095 end if 1096 1097 ! Need derivative of core density for GGA/mGGA 1098 if (xclevel==2.and.usecore==1) then 1099 LIBPAW_ALLOCATE(drhocore,(nrad)) 1100 call nderiv_gen(drhocore,corexc,pawrad) 1101 if (uselaplacian==1) then 1102 LIBPAW_ALLOCATE(lrhocore,(nrad)) 1103 LIBPAW_ALLOCATE(d2rho,(nrad)) 1104 call nderiv_gen(d2rho,drhocore,pawrad) 1105 lrhocore(2:nrad)=d2rho(2:nrad)+two*drhocore(2:nrad)/pawrad%rad(2:nrad) 1106 call pawrad_deducer0(lrhocore,nrad,pawrad) 1107 LIBPAW_DEALLOCATE(d2rho) 1108 end if 1109 end if 1110 1111 ! Allocation of mandatory arguments of drivexc 1112 LIBPAW_ALLOCATE(exci,(nrad)) 1113 LIBPAW_ALLOCATE(vxci,(nrad,nspden_updn)) 1114 LIBPAW_ALLOCATE(rho_updn,(nrad,nspden_updn)) 1115 1116 ! Allocation of optional arguments of drivexc 1117 LIBPAW_ALLOCATE(grho2_updn,(nrad,(2*nspden_updn-1)*usegradient)) 1118 LIBPAW_ALLOCATE(lrho_updn,(nrad,nspden_updn*uselaplacian)) 1119 LIBPAW_ALLOCATE(tau_updn,(nrad,nspden_updn*usekden)) 1120 LIBPAW_ALLOCATE(vxci_grho,(nrad,nvxcgrho)) 1121 LIBPAW_ALLOCATE(vxci_lrho,(nrad,nvxclrho)) 1122 LIBPAW_ALLOCATE(vxci_tau,(nrad,nvxctau)) 1123 LIBPAW_ALLOCATE(dvxci,(nrad,ndvxc)) 1124 LIBPAW_ALLOCATE(d2vxci,(nrad,nd2vxc)) 1125 LIBPAW_ALLOCATE(dnexcdn,(nrad,nspgrad)) 1126 1127 ! GGA/mGGA: convert Ylm derivatives from normalized (r_i^hat) 1128 ! to standard cartesian coordinates (r_i) 1129 ! dYlm/dr_i = { dYlm/dr_i^hat - r_i^hat * Sum_j[dYlm/dr_j^hat r_j^hat] } * (1/r) 1130 ! Laplacian: convert Ylm second derivatives from normalized to standard cartesian coordinates 1131 ! Sum_i[d^2Ylm/dr_i^2] = { Sum_j[dYlm/dr_j^hat r_j^hat] 1132 ! - Sum_j>k[d^2Ylm/dr_j^hat.dr_k^hat r_j^hat r_k^hat] } * (-2/r^2) 1133 ! Note that we consider here r=1 (r will be used later)... 1134 if (xclevel==2) then 1135 LIBPAW_ALLOCATE(dylmdr,(3,npts,pawang%ylm_size)) 1136 do ilm=1,pawang%ylm_size 1137 do ipts=1,npts 1138 factor=sum(pawang%ylmrgr(1:3,ilm,ipts)*pawang%anginit(1:3,ipts)) 1139 dylmdr(1:3,ipts,ilm)=pawang%ylmrgr(1:3,ilm,ipts)-factor*pawang%anginit(1:3,ipts) 1140 end do 1141 end do 1142 LIBPAW_ALLOCATE(gxc,(nrad,3,pawang%ylm_size,nspden_updn)) 1143 gxc=zero 1144 if (uselaplacian==1) then 1145 LIBPAW_ALLOCATE(ylmlapl,(npts,pawang%ylm_size)) 1146 ylmlapl(:,:)=zero 1147 do ilm=1,pawang%ylm_size 1148 do ipts=1,npts 1149 do ii=1,3 1150 factor=zero 1151 do jj=1,ii 1152 nu=mu(jj,ii) 1153 factor=factor+pawang%ylmrgr(nu,ilm,ipts)*pawang%anginit(jj,ipts) 1154 end do 1155 ylmlapl(ipts,ilm)=ylmlapl(ipts,ilm) & 1156 & -two*(pawang%ylmrgr(ii,ilm,ipts)+factor)*pawang%anginit(ii,ipts) 1157 end do 1158 end do 1159 end do 1160 LIBPAW_ALLOCATE(lxc,(nrad,pawang%ylm_size,nspden_updn)) 1161 lxc=zero 1162 end if 1163 end if 1164 1165 ! ---------------------------------------------------------------------- 1166 ! ----- Loop on the angular part and inits 1167 ! ---------------------------------------------------------------------- 1168 1169 ! Do loop on the angular part 1170 do ipts=1,npts 1171 1172 ! Copy the input density for this (theta,phi) 1173 rhoarr(:,:)=zero 1174 do ispden=1,nspden 1175 do ilm=1,lm_size_eff 1176 if (lmselect(ilm)) then 1177 rhoarr(1:nrad,ispden)=rhoarr(1:nrad,ispden) & 1178 & +rho_(1:nrad,ilm,ispden)*pawang%ylmr(ilm,ipts) 1179 end if 1180 end do 1181 end do 1182 if (usekden==1) then 1183 tauarr(:,:)=zero 1184 if (with_taur) then 1185 do ispden=1,nspden 1186 do ilm=1,lm_size_eff 1187 tauarr(1:nrad,ispden)=tauarr(1:nrad,ispden) & 1188 & +tau_(1:nrad,ilm,ispden)*pawang%ylmr(ilm,ipts) 1189 end do 1190 end do 1191 end if 1192 end if 1193 if (usecore==1) then 1194 rhoarr(1:nrad,1)=rhoarr(1:nrad,1)+corexc(1:nrad) 1195 if (nspden==2) rhoarr(1:nrad,2)=rhoarr(1:nrad,2)+half*corexc(1:nrad) 1196 end if 1197 if (usecoretau==1) then 1198 tauarr(1:nrad,1)=tauarr(1:nrad,1)+coretau(1:nrad) 1199 if (nspden==2) tauarr(1:nrad,2)=tauarr(1:nrad,2)+half*coretau(1:nrad) 1200 end if 1201 1202 ! Optionally suppress magnetic part 1203 if (non_magnetic_xc) then 1204 if(nspden==2) rhoarr(:,2)=rhoarr(:,1)*half 1205 if(nspden==4) rhoarr(:,2:4)=zero 1206 if (usekden==1) then 1207 if(nspden==2) tauarr(:,2)=tauarr(:,1)*half 1208 if(nspden==4) tauarr(:,2:4)=zero 1209 end if 1210 endif 1211 1212 rhonow(1:nrad,1:nspden,1)=rhoarr(1:nrad,1:nspden) 1213 1214 ! GGA: compute gradient (and possibly laplacian) of density 1215 if (xclevel==2) then 1216 LIBPAW_ALLOCATE(drho,(nrad)) 1217 LIBPAW_ALLOCATE(d2rho,(nrad*uselaplacian)) 1218 LIBPAW_ALLOCATE(ff,(nrad)) 1219 rhonow(:,:,2:4+uselaplacian)=zero 1220 do ispden=1,nspden 1221 do ilm=1,lm_size_eff 1222 if (lmselect(ilm)) then 1223 ff(1:nrad)=rho_(1:nrad,ilm,ispden) 1224 call nderiv_gen(drho,ff,pawrad) 1225 ff(2:nrad)=ff(2:nrad)/pawrad%rad(2:nrad) 1226 call pawrad_deducer0(ff,nrad,pawrad) 1227 do ii=1,3 1228 rhonow(1:nrad,ispden,1+ii)=rhonow(1:nrad,ispden,1+ii) & 1229 & +drho(1:nrad)*pawang%ylmr(ilm,ipts)*pawang%anginit(ii,ipts) & 1230 & +ff(1:nrad)*dylmdr(ii,ipts,ilm) 1231 end do 1232 if (uselaplacian==1) then 1233 call nderiv_gen(d2rho,drho,pawrad) 1234 ff(2:nrad)=ff(2:nrad)/pawrad%rad(2:nrad) 1235 call pawrad_deducer0(ff,nrad,pawrad) 1236 drho(2:nrad)=drho(2:nrad)/pawrad%rad(2:nrad) 1237 call pawrad_deducer0(drho,nrad,pawrad) 1238 rhonow(1:nrad,ispden,5)=rhonow(1:nrad,ispden,5) & 1239 & +ff(1:nrad)*ylmlapl(ipts,ilm) & 1240 & +(d2rho(1:nrad)+two*drho(1:nrad))*pawang%ylmr(ilm,ipts) 1241 end if 1242 end if 1243 end do 1244 end do 1245 LIBPAW_DEALLOCATE(d2rho) 1246 LIBPAW_DEALLOCATE(drho) 1247 LIBPAW_DEALLOCATE(ff) 1248 if (non_magnetic_xc) then 1249 do ii=1,3 1250 if(nspden==2) rhonow(1:nrad,2,1+ii)=rhonow(1:nrad,1,1+ii)*half 1251 if(nspden==4) rhonow(1:nrad,2:4,1+ii)=zero 1252 end do 1253 if (uselaplacian==1) then 1254 if(nspden==2) rhonow(1:nrad,2,5)=rhonow(1:nrad,1,5)*half 1255 if(nspden==4) rhonow(1:nrad,2:4,5)=zero 1256 end if 1257 end if 1258 if (usecore==1) then 1259 do ii=1,3 1260 rhonow(1:nrad,1,1+ii)=rhonow(1:nrad,1,1+ii) & 1261 & +drhocore(1:nrad)*pawang%anginit(ii,ipts) 1262 end do 1263 if (nspden==2) then 1264 do ii=1,3 1265 rhonow(1:nrad,2,1+ii)=rhonow(1:nrad,2,1+ii) & 1266 & +half*drhocore(1:nrad)*pawang%anginit(ii,ipts) 1267 end do 1268 end if 1269 if (uselaplacian==1) then 1270 rhonow(1:nrad,1,5)=rhonow(1:nrad,1,5)+lrhocore(1:nrad) 1271 if (nspden==2) rhonow(1:nrad,2,5)=rhonow(1:nrad,2,5)+half*lrhocore(1:nrad) 1272 end if 1273 end if 1274 end if 1275 1276 ! Storage of density (and gradient) in (up,dn) format 1277 if (nspden==1) then 1278 rho_updn(1:nrad,1)=rhonow(1:nrad,1,1)*half 1279 if (xclevel==2) grho2_updn(1:nrad,1)= & 1280 & quarter*(rhonow(1:nrad,1,2)**2+rhonow(1:nrad,1,3)**2+rhonow(1:nrad,1,4)**2) 1281 if (usekden==1) tau_updn(1:nrad,1)=tauarr(1:nrad,1)*half 1282 if (uselaplacian==1) lrho_updn(1:nrad,1)=rhonow(1:nrad,1,5)*half 1283 else if (nspden==2) then 1284 rho_updn(1:nrad,1)=rhonow(1:nrad,2,1) 1285 rho_updn(1:nrad,2)=rhonow(1:nrad,1,1)-rhonow(1:nrad,2,1) 1286 if (xclevel==2) then 1287 grho2_updn(1:nrad,1)=rhonow(1:nrad,2,2)**2+rhonow(1:nrad,2,3)**2+rhonow(1:nrad,2,4)**2 1288 grho2_updn(1:nrad,2)=(rhonow(1:nrad,1,2)-rhonow(1:nrad,2,2))**2 + & 1289 & (rhonow(1:nrad,1,3)-rhonow(1:nrad,2,3))**2 + & 1290 & (rhonow(1:nrad,1,4)-rhonow(1:nrad,2,4))**2 1291 grho2_updn(1:nrad,3)=rhonow(1:nrad,1,2)**2+rhonow(1:nrad,1,3)**2+rhonow(1:nrad,1,4)**2 1292 end if 1293 if (usekden==1) then 1294 tau_updn(1:nrad,1)=tauarr(1:nrad,2) 1295 tau_updn(1:nrad,2)=tauarr(1:nrad,1)-tauarr(1:nrad,2) 1296 end if 1297 if (uselaplacian==1) then 1298 lrho_updn(1:nrad,1)=rhonow(1:nrad,2,5) 1299 lrho_updn(1:nrad,2)=rhonow(1:nrad,1,5)-rhonow(1:nrad,2,5) 1300 end if 1301 else if (nspden==4) then 1302 mag_ => rhonow(1:nrad,2:4,1) 1303 mag(1:nrad,ipts,1:3)=mag_(1:nrad,1:3) 1304 call pawxc_rotate_mag(rhonow(:,:,1),rho_updn,mag_,nrad) ! Note : gradients are not computed there 1305 if (non_magnetic_xc.and.xclevel==2) then ! In this case grho2_updn is easy to compute 1306 grho2_updn(1:nrad,1)=quarter*(rhonow(1:nrad,1,2)**2+rhonow(1:nrad,1,3)**2+rhonow(1:nrad,1,4)**2) 1307 grho2_updn(1:nrad,2)=grho2_updn(1:nrad,1) 1308 grho2_updn(1:nrad,3)=rhonow(1:nrad,1,2)**2+rhonow(1:nrad,1,3)**2+rhonow(1:nrad,1,4)**2 1309 end if 1310 end if 1311 1312 ! Make the density positive everywhere (but do not care about gradients) 1313 call pawxc_mkdenpos_wrapper(iwarn,nrad,nspden_updn,0,rho_updn,xc_denpos) 1314 if (usekden==1) then 1315 call pawxc_mkdenpos_wrapper(iwarn,nrad,nspden_updn,0,tau_updn,my_xc_taupos) 1316 end if 1317 1318 ! Call to main XC driver 1319 call pawxc_drivexc_wrapper(hyb_mixing,ixc,order,nrad,nspden_updn,& 1320 & usegradient,uselaplacian,usekden,rho_updn,exci,vxci,& 1321 & nvxcgrho,nvxclrho,nvxctau,ndvxc,nd2vxc,& 1322 & grho2=grho2_updn,vxcgrho=vxci_grho,& 1323 & lrho=lrho_updn,vxclrho=vxci_lrho,& 1324 & tau=tau_updn,vxctau=vxci_tau,& 1325 & dvxc=dvxci,d2vxc=d2vxci) 1326 1327 ! If fake meta-GGA, has to remove the core contribution 1328 ! when electronic effective mass has been modified 1329 if (usecoretau==1.and.(ixc==31.or.ixc==35)) then 1330 if (ixc==31.or.ixc==35) then 1331 factor=one-(one/1.01_dp) 1332 if (nspden_updn==1) then 1333 factor=factor*half 1334 do ii=1,nrad 1335 exci(ii)=exci(ii)-factor*coretau(ii)/rho_updn(ii,1) 1336 end do 1337 else 1338 do ii=1,nrad 1339 exci(ii)=exci(ii)-factor*coretau(ii)/(rho_updn(ii,1)+rho_updn(ii,2)) 1340 end do 1341 end if 1342 else 1343 msg='MetaGGA ixc=34 is not yet allowed with a core kinetic energy density!' 1344 LIBPAW_ERROR(msg) 1345 end if 1346 end if 1347 1348 ! ---------------------------------------------------------------------- 1349 ! ----- Store XC kernel and its derivative 1350 ! ---------------------------------------------------------------------- 1351 if (nkxc_updn>0.and.ndvxc>0) then 1352 if (nkxc_updn==1.and.ndvxc==15) then 1353 kxc(1:nrad,ipts,1)=half*(dvxci(1:nrad,1)+dvxci(1:nrad,9)+dvxci(1:nrad,10)) 1354 else if (nkxc_updn==3.and.ndvxc==15) then 1355 kxc(1:nrad,ipts,1)=dvxci(1:nrad,1)+dvxci(1:nrad,9) 1356 kxc(1:nrad,ipts,2)=dvxci(1:nrad,10) 1357 kxc(1:nrad,ipts,3)=dvxci(1:nrad,2)+dvxci(1:nrad,11) 1358 else if (nkxc_updn==7.and.ndvxc==8) then 1359 kxc(1:nrad,ipts,1)=half*dvxci(1:nrad,1) 1360 kxc(1:nrad,ipts,2)=half*dvxci(1:nrad,3) 1361 kxc(1:nrad,ipts,3)=quarter*dvxci(1:nrad,5) 1362 kxc(1:nrad,ipts,4)=eighth*dvxci(1:nrad,7) 1363 else if (nkxc_updn==7.and.ndvxc==15) then 1364 kxc(1:nrad,ipts,1)=half*(dvxci(1:nrad,1)+dvxci(1:nrad,9)+dvxci(1:nrad,10)) 1365 kxc(1:nrad,ipts,2)=half*dvxci(1:nrad,3)+dvxci(1:nrad,12) 1366 kxc(1:nrad,ipts,3)=quarter*dvxci(1:nrad,5)+dvxci(1:nrad,13) 1367 kxc(1:nrad,ipts,4)=eighth*dvxci(1:nrad,7)+dvxci(1:nrad,15) 1368 else if (nkxc_updn==19.and.ndvxc==15) then 1369 kxc(1:nrad,ipts,1)=dvxci(1:nrad,1)+dvxci(1:nrad,9) 1370 kxc(1:nrad,ipts,2)=dvxci(1:nrad,10) 1371 kxc(1:nrad,ipts,3)=dvxci(1:nrad,2)+dvxci(1:nrad,11) 1372 kxc(1:nrad,ipts,4)=dvxci(1:nrad,3) 1373 kxc(1:nrad,ipts,5)=dvxci(1:nrad,4) 1374 kxc(1:nrad,ipts,6)=dvxci(1:nrad,5) 1375 kxc(1:nrad,ipts,7)=dvxci(1:nrad,6) 1376 kxc(1:nrad,ipts,8)=dvxci(1:nrad,7) 1377 kxc(1:nrad,ipts,9)=dvxci(1:nrad,8) 1378 kxc(1:nrad,ipts,10)=dvxci(1:nrad,12) 1379 kxc(1:nrad,ipts,11)=dvxci(1:nrad,13) 1380 kxc(1:nrad,ipts,12)=dvxci(1:nrad,14) 1381 kxc(1:nrad,ipts,13)=dvxci(1:nrad,15) 1382 else ! Other cases 1383 kxc(1:nrad,ipts,1:nkxc)=zero 1384 kxc(1:nrad,ipts,1:min(nkxc,ndvxc))=dvxci(1:nrad,1:min(nkxc,ndvxc)) 1385 end if 1386 if (nkxc_updn==7) then 1387 kxc(1:nrad,ipts,5)=rhonow(1:nrad,1,2) 1388 kxc(1:nrad,ipts,6)=rhonow(1:nrad,1,3) 1389 kxc(1:nrad,ipts,7)=rhonow(1:nrad,1,4) 1390 else if (nkxc_updn==19) then 1391 kxc(1:nrad,ipts,14)=rhonow(1:nrad,1,2) 1392 kxc(1:nrad,ipts,15)=rhonow(1:nrad,2,2) 1393 kxc(1:nrad,ipts,16)=rhonow(1:nrad,1,3) 1394 kxc(1:nrad,ipts,17)=rhonow(1:nrad,2,3) 1395 kxc(1:nrad,ipts,18)=rhonow(1:nrad,1,4) 1396 kxc(1:nrad,ipts,19)=rhonow(1:nrad,2,4) 1397 end if 1398 end if 1399 if (nkxc>=nkxc_updn+3) then 1400 kxc(1:nrad,ipts,nkxc_updn+1)=rhonow(1:nrad,2,1) 1401 kxc(1:nrad,ipts,nkxc_updn+2)=rhonow(1:nrad,3,1) 1402 kxc(1:nrad,ipts,nkxc_updn+3)=rhonow(1:nrad,4,1) 1403 end if 1404 1405 ! kernel derivative : 1406 if (nk3xc>0.and.nd2vxc>0) then 1407 k3xc(1:nrad,ipts,1:min(nk3xc,nd2vxc))=d2vxci(1:nrad,1:min(nk3xc,nd2vxc)) 1408 end if 1409 1410 ! ---------------------------------------------------------------------- 1411 ! ----- Store derivative of Exc wrt kinetic energy density 1412 ! ---------------------------------------------------------------------- 1413 if (need_vxctau) then 1414 do ispden=1,nspden_updn 1415 vxctau_(1:nrad,ipts,ispden)=vxci_tau(1:nrad,ispden) 1416 end do 1417 end if 1418 1419 ! ---------------------------------------------------------------------- 1420 ! ----- Accumulate and store XC potential 1421 ! ---------------------------------------------------------------------- 1422 1423 if (option/=3.and.option/=4) then 1424 1425 do ispden=1,nspden_updn 1426 vxc_updn(1:nrad,ipts,ispden)=vxci(1:nrad,ispden) 1427 end do 1428 1429 ! For GGAs, additional terms appear 1430 if (xclevel==2.and.ixc/=13)then 1431 dnexcdn(1:nrad,1:nspden_updn)=vxci(1:nrad,1:nspden_updn) 1432 ! Treat explicitely spin up, spin down and total spin for spin-polarized 1433 do ii=1,3 1434 if(nspden_updn==1.and.ii>=2)exit !exit when ii=1 is finished if non-spin-polarized 1435 do ir=1,nrad 1436 ! If the norm of the gradient vanishes, then the different terms vanishes 1437 if(grho2_updn(ir,ii)<1.0d-24) then 1438 dnexcdn(ir,ii+nspden_updn)=zero;cycle 1439 end if 1440 ! Compute the derivative of n.e_xc wrt spin up, spin down, or total density 1441 if(nspden_updn==1)then 1442 dnexcdn(ir,ii+nspden_updn)=half*vxci_grho(ir,1) !Definition of vxci_grho changed in v3.3 1443 if (nvxcgrho==3) dnexcdn(ir,ii+nspden_updn)=dnexcdn(ir,ii+nspden_updn)+vxci_grho(ir,3) 1444 else if(nspden_updn==2)then 1445 if (nvxcgrho==3) then 1446 dnexcdn(ir,ii+nspden_updn)=vxci_grho(ir,ii) 1447 else if (ii/=3) then 1448 dnexcdn(ir,ii+nspden_updn)=vxci_grho(ir,ii) 1449 else if (ii==3) then 1450 dnexcdn(ir,ii+nspden_updn)=zero 1451 end if 1452 end if 1453 end do 1454 end do 1455 call pawxc_xcmult_wrapper(dnexcdn,nrad,ngrad,nspden_eff,nspgrad,rhonow) 1456 factor=one;if (nspden_updn==1) factor=half 1457 if (option/=4.and.option/=5) then 1458 factor=factor*four_pi 1459 ! Accumulate moments of gxc=1/grad(rho).dVxc/dgrad(rho) 1460 do ispden=1,nspden_updn 1461 do ilm=1,pawang%ylm_size 1462 do ii=1,3 1463 gxc(1:nrad,ii,ilm,ispden)=gxc(1:nrad,ii,ilm,ispden)+rhonow(1:nrad,ispden,1+ii) & 1464 & *pawang%ylmr(ilm,ipts)*pawang%angwgth(ipts)*factor 1465 end do 1466 end do 1467 end do 1468 else 1469 do ispden=1,nspden_updn 1470 gxc(1:nrad,1,1,ispden)=factor*rhonow(1:nrad,ispden,2) 1471 end do 1472 end if 1473 end if 1474 1475 ! For laplacian-dependent functionals, additional terms appear 1476 if (xclevel==2.and.uselaplacian==1) then 1477 factor=one;if (nspden_updn==1) factor=half 1478 if (option/=4.and.option/=5) then 1479 factor=factor*four_pi 1480 ! Accumulate moments of lxc=dVxc/dlaplacian(rho) 1481 do ispden=1,nspden_updn 1482 do ilm=1,pawang%ylm_size 1483 lxc(1:nrad,ilm,ispden)=lxc(1:nrad,ilm,ispden)+vxci_lrho(1:nrad,ispden) & 1484 & *pawang%ylmr(ilm,ipts)*pawang%angwgth(ipts)*factor 1485 end do 1486 end do 1487 else 1488 do ispden=1,nspden_updn 1489 lxc(1:nrad,1,ispden)=factor*vxci_lrho(1:nrad,ispden) 1490 end do 1491 end if 1492 end if 1493 1494 end if !option 1495 1496 ! ---------------------------------------------------------------------- 1497 ! ----- Accumulate and store XC energy 1498 ! ---------------------------------------------------------------------- 1499 if (option/=1.and.option/=5) then 1500 LIBPAW_ALLOCATE(ff,(nrad)) 1501 ff(1:nrad)=rhoarr(1:nrad,1)*exci(1:nrad)*pawrad%rad(1:nrad)**2 1502 call simp_gen(enxcr,ff,pawrad) 1503 if (option/=4) enxc=enxc+enxcr*pawang%angwgth(ipts) 1504 if (option==4) enxc=enxc+enxcr 1505 LIBPAW_DEALLOCATE(ff) 1506 end if 1507 1508 ! ---------------------------------------------------------------------- 1509 ! ----- Accumulate integral of |Grad_rho|/Rho (to be used for TB09 XC) 1510 ! ---------------------------------------------------------------------- 1511 if (present(grho1_over_rho1).and.pawxc_is_tb09(ixc).and.option<4) then 1512 LIBPAW_ALLOCATE(ff,(nrad)) 1513 if (nspden_updn==1) then 1514 do ir=1,nrad 1515 rhotot=two*rho_updn(ir,1) 1516 if (abs(rhotot)>tol10) ff(ir)=sqrt(four*grho2_updn(ir,1))/rhotot 1517 end do 1518 else ! nspden_updn=2 1519 do ir=1,nrad 1520 rhotot=rho_updn(ir,1)+rho_updn(ir,2) 1521 if (abs(rhotot)>tol10) ff(ir)=sqrt(grho2_updn(ir,3))/rhotot 1522 end do 1523 end if 1524 ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2 1525 call simp_gen(sumg,ff,pawrad) 1526 grho1_over_rho1=grho1_over_rho1+sumg*four_pi*pawang%angwgth(ipts) 1527 LIBPAW_DEALLOCATE(ff) 1528 end if 1529 1530 ! ---------------------------------------------------------------------- 1531 ! ----- End of the loop on npts (angular part) 1532 ! ---------------------------------------------------------------------- 1533 end do 1534 1535 ! Deallocate temporary memory space 1536 LIBPAW_DEALLOCATE(exci) 1537 LIBPAW_DEALLOCATE(vxci) 1538 LIBPAW_DEALLOCATE(rho_updn) 1539 LIBPAW_DEALLOCATE(tau_updn) 1540 LIBPAW_DEALLOCATE(lrho_updn) 1541 LIBPAW_DEALLOCATE(dvxci) 1542 LIBPAW_DEALLOCATE(d2vxci) 1543 LIBPAW_DEALLOCATE(vxci_grho) 1544 LIBPAW_DEALLOCATE(vxci_lrho) 1545 LIBPAW_DEALLOCATE(vxci_tau) 1546 LIBPAW_DEALLOCATE(grho2_updn) 1547 LIBPAW_DEALLOCATE(dnexcdn) 1548 LIBPAW_DEALLOCATE(rhonow) 1549 if (allocated(drhocore)) then 1550 LIBPAW_DEALLOCATE(drhocore) 1551 end if 1552 if (allocated(lrhocore)) then 1553 LIBPAW_DEALLOCATE(lrhocore) 1554 end if 1555 1556 ! ---------------------------------------------------------------------- 1557 ! ----- If GGA, modify potential with term from density gradient 1558 ! ---------------------------------------------------------------------- 1559 if (option/=3.and.option/=4.and.xclevel==2.and.ixc/=13) then 1560 ! Compute divergence of gxc and substract it from Vxc 1561 LIBPAW_ALLOCATE(dgxc,(nrad)) 1562 ! Need to multiply gxc by 2 in the non-polarised case 1563 factor=one;if (nspden_updn==1) factor=two 1564 if (option/=4.and.option/=5) then 1565 LIBPAW_ALLOCATE(ff,(nrad)) 1566 do ispden=1,nspden_updn 1567 do ilm=1,pawang%ylm_size 1568 do ii=1,3 1569 ff(1:nrad)=gxc(1:nrad,ii,ilm,ispden) 1570 call nderiv_gen(dgxc,ff,pawrad) 1571 ff(2:nrad)=ff(2:nrad)/pawrad%rad(2:nrad) 1572 call pawrad_deducer0(ff,nrad,pawrad) 1573 do ipts=1,npts 1574 vxc_updn(1:nrad,ipts,ispden)=vxc_updn(1:nrad,ipts,ispden) & 1575 & -factor*(dgxc(1:nrad)*pawang%anginit(ii,ipts)*pawang%ylmr(ilm,ipts) & 1576 & +ff(1:nrad)*dylmdr(ii,ipts,ilm)) 1577 end do 1578 end do 1579 end do 1580 end do 1581 LIBPAW_DEALLOCATE(ff) 1582 else ! option==4 or option==5 1583 do ispden=1,nspden_updn 1584 call nderiv_gen(dgxc,gxc(:,1,1,ispden),pawrad) 1585 vxc_updn(2:nrad,1,ispden)=vxc_updn(2:nrad,1,ispden) & 1586 & -factor*(dgxc(2:nrad)+two*gxc(2:nrad,1,1,ispden)/pawrad%rad(2:nrad)) 1587 call pawrad_deducer0(vxc(:,1,ispden),nrad,pawrad) 1588 end do 1589 end if 1590 LIBPAW_DEALLOCATE(dgxc) 1591 end if ! GGA 1592 1593 ! ---------------------------------------------------------------------- 1594 ! ----- If mGGA, modify potential with term from density laplacian 1595 ! ---------------------------------------------------------------------- 1596 if (option/=3.and.option/=4.and.xclevel==2.and.uselaplacian==1.and.ixc/=13) then 1597 ! Compute laplacian of lxc and add it to Vxc 1598 LIBPAW_ALLOCATE(dlxc,(nrad)) 1599 LIBPAW_ALLOCATE(d2lxc,(nrad)) 1600 ! Need to multiply lxc by 2 in the non-polarised case 1601 factor=one;if (nspden_updn==1) factor=two 1602 if (option/=4.and.option/=5) then 1603 LIBPAW_ALLOCATE(ff,(nrad)) 1604 do ispden=1,nspden_updn 1605 do ilm=1,pawang%ylm_size 1606 ff(1:nrad)=lxc(1:nrad,ilm,ispden) 1607 call nderiv_gen(dlxc,ff,pawrad) 1608 call nderiv_gen(d2lxc,dlxc,pawrad) 1609 ff(2:nrad)=ff(2:nrad)/(pawrad%rad(2:nrad)**2) 1610 call pawrad_deducer0(ff,nrad,pawrad) 1611 dlxc(2:nrad)=dlxc(2:nrad)/pawrad%rad(2:nrad) 1612 call pawrad_deducer0(dlxc,nrad,pawrad) 1613 do ipts=1,npts 1614 vxc_updn(1:nrad,ipts,ispden)=vxc_updn(1:nrad,ipts,ispden) & 1615 & +factor*(ff(1:nrad)*ylmlapl(ipts,ilm) & 1616 & +(d2lxc(1:nrad)+two*dlxc(1:nrad))*pawang%ylmr(ilm,ipts)) 1617 end do 1618 end do 1619 end do 1620 LIBPAW_DEALLOCATE(ff) 1621 else ! option==4 or option==5 1622 do ispden=1,nspden_updn 1623 call nderiv_gen(dlxc,lxc(:,1,ispden),pawrad) 1624 call nderiv_gen(d2lxc,dlxc,pawrad) 1625 vxc_updn(2:nrad,1,ispden)=vxc_updn(2:nrad,1,ispden) & 1626 & +factor*(d2lxc(2:nrad)+two*dlxc(2:nrad)/pawrad%rad(2:nrad)) 1627 call pawrad_deducer0(vxc(:,1,ispden),nrad,pawrad) 1628 end do 1629 end if 1630 LIBPAW_DEALLOCATE(dlxc) 1631 LIBPAW_DEALLOCATE(d2lxc) 1632 end if ! mGGA 1633 1634 ! ---------------------------------------------------------------------- 1635 ! ----- If non-collinear, rotate back potential according to magnetization 1636 ! ---------------------------------------------------------------------- 1637 if (option/=3.and.option/=4.and.nspden==4) then 1638 ! Use of C pointers to avoid copies (when ISO C bindings are available) 1639 ! %@1$ xlf v15 compiler requires a auxilliary cptr variable 1640 #ifdef LIBPAW_ISO_C_BINDING 1641 cptr=c_loc(vxc_updn(1,1,1)) 1642 call c_f_pointer(cptr,vxc_diag,shape=[nrad*npts,nspden_updn]) 1643 cptr=c_loc(vxc(1,1,1)) 1644 call c_f_pointer(cptr,vxc_nc,shape=[nrad*npts,nspden]) 1645 cptr=c_loc(mag(1,1,1)) 1646 call c_f_pointer(cptr,mag_,shape=[nrad*npts,3]) 1647 #else 1648 LIBPAW_ALLOCATE(vxc_diag,(nrad*npts,nspden_updn)) 1649 LIBPAW_ALLOCATE(vxc_nc,(nrad*npts,nspden)) 1650 LIBPAW_ALLOCATE(mag_,(nrad*npts,3)) 1651 vxc_diag=reshape(vxc_updn,[nrad*npts,nspden_updn]) 1652 mag_=reshape(mag,[nrad*npts,3]) 1653 #endif 1654 call pawxc_rotate_back_mag(vxc_diag,vxc_nc,mag_,nrad*npts) 1655 #ifndef LIBPAW_ISO_C_BINDING 1656 vxc=reshape(vxc_nc,[nrad,npts,nspden]) 1657 LIBPAW_DEALLOCATE(vxc_diag) 1658 LIBPAW_DEALLOCATE(mag_) 1659 LIBPAW_DEALLOCATE(vxc_nc) 1660 #endif 1661 LIBPAW_POINTER_DEALLOCATE(vxc_updn) 1662 LIBPAW_DEALLOCATE(mag) 1663 end if 1664 1665 ! ---------------------------------------------------------------------- 1666 ! ----- Accumulate and store XC double-counting energy 1667 ! ---------------------------------------------------------------------- 1668 if (option==0.or.option==2) then 1669 LIBPAW_ALLOCATE(ff,(nrad)) 1670 do ipts=1,npts ! Do loop on the angular part 1671 ! Compute density for this (theta,phi) 1672 rhoarr(:,:)=zero 1673 if (usexcnhat==0) rho_=>rhor 1674 if (usexcnhat/=0) rho_=>rhohat 1675 do ispden=1,nspden 1676 do ilm=1,lm_size_eff 1677 if (lmselect(ilm)) then 1678 rhoarr(1:nrad,ispden)=rhoarr(1:nrad,ispden)+rho_(1:nrad,ilm,ispden)*pawang%ylmr(ilm,ipts) 1679 end if 1680 end do 1681 end do 1682 ! Compute kinetic energy density for this (theta,phi) 1683 if (with_taur.and.need_vxctau) then 1684 tauarr(:,:)=zero 1685 do ispden=1,nspden 1686 do ilm=1,lm_size_eff 1687 tauarr(1:nrad,ispden)=tauarr(1:nrad,ispden) & 1688 & +tau_(1:nrad,ilm,ispden)*pawang%ylmr(ilm,ipts) 1689 end do 1690 end do 1691 end if 1692 ! Compute integral of Vxc*rho 1693 if (nspden/=4) then 1694 ff(:)=vxc(:,ipts,1)*rhoarr(:,nspden) 1695 if (nspden==2) ff(:)=ff(:)+vxc(:,ipts,2)*(rhoarr(:,1)-rhoarr(:,2)) 1696 else 1697 ff(:)=half*(vxc(:,ipts,1)*(rhoarr(:,1)+rhoarr(:,4)) & 1698 +vxc(:,ipts,2)*(rhoarr(:,1)-rhoarr(:,4))) & 1699 & +vxc(:,ipts,3)*rhoarr(:,2)-vxc(:,ipts,4)*rhoarr(:,3) 1700 end if 1701 ! Possibly add integral of Vxctau*tau 1702 if (with_taur.and.need_vxctau) then 1703 ff(:)=ff(:)+vxctau_(:,ipts,1)*tauarr(:,nspden) 1704 if (nspden==2) ff(:)=ff(:)+vxctau_(:,ipts,2)*(tauarr(:,1)-tauarr(:,2)) 1705 end if 1706 ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2 1707 call simp_gen(vxcrho,ff,pawrad) 1708 enxcdc=enxcdc+vxcrho*pawang%angwgth(ipts) 1709 end do ! End of the loop on npts (angular part) 1710 LIBPAW_DEALLOCATE(ff) 1711 end if ! option 1712 1713 ! ---------------------------------------------------------------------- 1714 ! ----- End 1715 ! ---------------------------------------------------------------------- 1716 ! Add the four*pi factor of the Exc and Excdc angular integration 1717 if (option/=1.and.option/=5) enxc=enxc*four_pi 1718 if (option==0.or.option==2) enxcdc=enxcdc*four_pi 1719 1720 !TESTDEBUG 1721 ! Compute difference between fake mGGA=32 Exc=Int[Grad[rho]**2.dr] 1722 ! and mGGA=33 Exc=-Int[Laplacian[rho]*rho.dr] 1723 ! i.e. contour integral Int_contour[rho.Grad[rho].DS]=rc^2.Sum_L[rho_L(rc)*drho_L(rc)] 1724 ! if (option<4) then 1725 ! enxcr=zero 1726 ! ir=pawrad%int_meshsz 1727 ! LIBPAW_ALLOCATE(drho,(nrad)) 1728 ! LIBPAW_ALLOCATE(ff,(nrad)) 1729 ! enxcr=zero 1730 ! do ilm=1,lm_size_eff 1731 ! ff(1:nrad)=rho_(1:nrad,ilm,1) 1732 ! call nderiv_gen(drho,ff,pawrad) 1733 ! enxcr=enxcr+ff(ir)*drho(ir) 1734 ! end do 1735 ! LIBPAW_DEALLOCATE(drho) 1736 ! LIBPAW_DEALLOCATE(ff) 1737 ! enxcr=enxcr*0.01_dp*pawrad%rad(ir)**2 1738 ! write(100,*) "Contour integral=",enxcr 1739 ! end if 1740 1741 ! Final memory deallocation 1742 LIBPAW_DEALLOCATE(rhoarr) 1743 LIBPAW_DEALLOCATE(tauarr) 1744 if (usexcnhat>0) then 1745 LIBPAW_DEALLOCATE(rhohat) 1746 end if 1747 if (xclevel==2) then 1748 LIBPAW_DEALLOCATE(gxc) 1749 LIBPAW_DEALLOCATE(dylmdr) 1750 if (uselaplacian==1) then 1751 LIBPAW_DEALLOCATE(lxc) 1752 LIBPAW_DEALLOCATE(ylmlapl) 1753 end if 1754 end if 1755 if (usekden==1.and.(.not.present(vxctau)).and.(option==0.or.option==2)) then 1756 LIBPAW_DEALLOCATE(vxctau_) 1757 end if 1758 1759 ! ------------------------------------ 1760 ! End IF a xc part has to be computed 1761 end if 1762 1763 end subroutine pawxc
m_pawxc/pawxc_dfpt [ Functions ]
[ Top ] [ m_pawxc ] [ Functions ]
NAME
pawxc_dfpt
FUNCTION
Compute first-order change of XC potential and contribution to 2nd-order change of XC energy inside a PAW sphere. LDA+GGA - USE THE DENSITY OVER A WHOLE SPHERICAL GRID (r,theta,phi)
INPUTS
corexc1(cplex_den*nrad)=first-order change of core density on radial grid cplex_den= if 1, 1st-order densities are REAL, if 2, COMPLEX cplex_vxc= if 1, 1st-order XC potential is complex, if 2, COMPLEX ixc= choice of exchange-correlation scheme kxc(nrad,pawang%angl_size,nkxc)=GS xc kernel lm_size=size of density array rhor (see below) lmselect(lm_size)=select the non-zero LM-moments of input density rhor1 nhat1(cplex_den*nrad,lm_size,nspden)=first-order change of compensation density (total in 1st half and spin-up in 2nd half if nspden=2) nkxc=second dimension of the kxc array non_magnetic_xc= if true, handle density/potential as non-magnetic (even if it is) nrad=size of radial mesh for densities/potentials (might be different from pawrad%mesh_size) nspden=number of spin-density components option=0 compute both 2nd-order XC energy and 1st-order potential 1 compute only 1st-order XC potential 2 compute only 2nd-order XC energy, XC potential is temporary computed here 3 compute only 2nd-order XC energy, XC potential is input in vxc1(:) pawang <type(pawang_type)>=paw angular mesh and related data pawrad <type(pawrad_type)>=paw radial mesh and related data rhor1(cplex_den*nrad,lm_size,nspden)=first-order change of density usecore= 1 if core density has to be used in Exc/Vxc ; 0 otherwise usexcnhat= 0 if compensation density does not have to be used 1 if compensation density has to be used in d2Exc only 2 if compensation density (nhat) has to be used in d2Exc and Vxc1 vxc(nrad,pawang%angl_size,nspden)=GS xc potential xclevel= XC functional level
OUTPUT
== if option=0 or 2 or 3 ==
d2enxc =returned exchange-cor. contribution to 2nd-order XC energy
d2enxc_im=returned IMAGINARY PART of exchange-cor. contribution to 2nd-order XC energy
(optional argument)
SIDE EFFECTS
vxc1(cplex_vxc*nrad,pawang%angl_size,nspden)=1st-order XC potential
Output if option==0 or 1
Unused if option==2
Input if option==3
NOTES
Content of Kxc array:
===== if LDA
if nspden==1: kxc(:,1)= d2Exc/drho2
(kxc(:,2)= d2Exc/drho_up drho_dn)
if nspden>=2: kxc(:,1)= d2Exc/drho_up drho_up
kxc(:,2)= d2Exc/drho_up drho_dn
kxc(:,3)= d2Exc/drho_dn drho_dn
if nspden==4: kxc(:,4:6)= (m_x, m_y, m_z) (magnetization)
===== if GGA
if nspden==1:
kxc(:,1)= d2Exc/drho2
kxc(:,2)= 1/|grad(rho)| dExc/d|grad(rho)|
kxc(:,3)= 1/|grad(rho)| d2Exc/d|grad(rho)| drho
kxc(:,4)= 1/|grad(rho)| * d/d|grad(rho)| ( 1/|grad(rho)| dExc/d|grad(rho)| )
kxc(:,5)= gradx(rho)
kxc(:,6)= grady(rho)
kxc(:,7)= gradz(rho)
if nspden>=2:
kxc(:,1)= d2Exc/drho_up drho_up
kxc(:,2)= d2Exc/drho_up drho_dn
kxc(:,3)= d2Exc/drho_dn drho_dn
kxc(:,4)= 1/|grad(rho_up)| dEx/d|grad(rho_up)|
kxc(:,5)= 1/|grad(rho_dn)| dEx/d|grad(rho_dn)|
kxc(:,6)= 1/|grad(rho_up)| d2Ex/d|grad(rho_up)| drho_up
kxc(:,7)= 1/|grad(rho_dn)| d2Ex/d|grad(rho_dn)| drho_dn
kxc(:,8)= 1/|grad(rho_up)| * d/d|grad(rho_up)| ( 1/|grad(rho_up)| dEx/d|grad(rho_up)| )
kxc(:,9)= 1/|grad(rho_dn)| * d/d|grad(rho_dn)| ( 1/|grad(rho_dn)| dEx/d|grad(rho_dn)| )
kxc(:,10)=1/|grad(rho)| dEc/d|grad(rho)|
kxc(:,11)=1/|grad(rho)| d2Ec/d|grad(rho)| drho_up
kxc(:,12)=1/|grad(rho)| d2Ec/d|grad(rho)| drho_dn
kxc(:,13)=1/|grad(rho)| * d/d|grad(rho)| ( 1/|grad(rho)| dEc/d|grad(rho)| )
kxc(:,14)=gradx(rho_up)
kxc(:,15)=gradx(rho_dn)
kxc(:,16)=grady(rho_up)
kxc(:,17)=grady(rho_dn)
kxc(:,18)=gradz(rho_up)
kxc(:,19)=gradz(rho_dn)
if nspden==4:
kxc(:,20:22)= (m_x, m_y, m_z) (magnetization)
SOURCE
2132 subroutine pawxc_dfpt(corexc1,cplex_den,cplex_vxc,d2enxc,ixc,kxc,lm_size,lmselect,nhat1,& 2133 & nkxc,non_magnetic_xc,nrad,nspden,option,pawang,pawrad,rhor1,& 2134 & usecore,usexcnhat,vxc,vxc1,xclevel,& 2135 & d2enxc_im) ! optional 2136 2137 !Arguments ------------------------------------ 2138 !scalars 2139 integer,intent(in) :: cplex_den,cplex_vxc,ixc,lm_size,nkxc,nrad,nspden,option 2140 integer,intent(in) :: usecore,usexcnhat,xclevel 2141 logical,intent(in) :: non_magnetic_xc 2142 real(dp),intent(out) :: d2enxc 2143 real(dp),intent(out),optional :: d2enxc_im 2144 type(pawang_type),intent(in) :: pawang 2145 type(pawrad_type),intent(in) :: pawrad 2146 !arrays 2147 logical,intent(in) :: lmselect(lm_size) 2148 real(dp),intent(in) :: corexc1(cplex_den*nrad) 2149 real(dp),intent(in) :: nhat1(cplex_den*nrad,lm_size,nspden*((usexcnhat+1)/2)) 2150 real(dp),intent(in),target :: kxc(nrad,pawang%angl_size,nkxc) 2151 real(dp),intent(in),target :: vxc(nrad,pawang%angl_size,nspden) 2152 real(dp),intent(in),target :: rhor1(cplex_den*nrad,lm_size,nspden) 2153 real(dp),intent(inout),target :: vxc1(cplex_vxc*nrad,pawang%angl_size,nspden) 2154 2155 !Local variables------------------------------- 2156 !scalars 2157 integer :: ii,ilm,ipts,ir,ispden,jr,kr,lm_size_eff,nkxc_cur,npts,nspden_updn 2158 logical :: need_impart 2159 real(dp),parameter :: tol24=tol12*tol12 2160 real(dp) :: coeff_grho,coeff_grho_corr,coeff_grho_dn,coeff_grho_up 2161 real(dp) :: coeff_grhoim,coeff_grhoim_corr,coeff_grhoim_dn,coeff_grhoim_up 2162 real(dp) :: dylmdr_ii,factor,factor_ang_intg,ylm_ii 2163 real(dp) :: grho_grho1,grho_grho1_up,grho_grho1_dn 2164 real(dp) :: grho_grho1im,grho_grho1im_up,grho_grho1im_dn 2165 real(dp) :: rho1_dn,rho1_up,rho1im_dn,rho1im_up 2166 real(dp) :: ro11i,ro11r,ro12i,ro12r,ro21i,ro21r,ro22i,ro22r 2167 real(dp) :: v11i,v11r,v12i,v12r,v21i,v21r,v22i,v22r,vxcrho 2168 character(len=500) :: msg 2169 !arrays 2170 real(dp) :: g0(3),g0_dn(3),g0_up(3),g1(3),g1_dn(3),g1_up(3) 2171 real(dp) :: g1im(3),g1im_dn(3),g1im_up(3) 2172 real(dp) :: gxc1i(3,2),gxc1r(3,2) 2173 real(dp),allocatable :: dgxc1(:),drho1(:,:),drho1core(:,:),dylmdr(:,:,:) 2174 real(dp),allocatable :: ff(:),gg(:),grho1arr(:,:,:),gxc1(:,:,:,:) 2175 real(dp),allocatable,target :: rhohat1(:,:,:),rho1arr(:,:) 2176 real(dp), LIBPAW_CONTIGUOUS pointer :: kxc_(:,:),mag(:,:) 2177 real(dp), LIBPAW_CONTIGUOUS pointer :: rho1_(:,:,:),rho1_nc(:,:),rho1_updn(:,:) 2178 real(dp), LIBPAW_CONTIGUOUS pointer :: vxc_(:,:),vxc1_(:,:,:),vxc1_diag(:,:) 2179 real(dp), LIBPAW_CONTIGUOUS pointer :: vxc1_nc(:,:),vxc1_updn(:,:,:) 2180 #ifdef LIBPAW_ISO_C_BINDING 2181 type(C_PTR) :: cptr 2182 #endif 2183 2184 ! ************************************************************************* 2185 2186 !---------------------------------------------------------------------- 2187 !----- Check options 2188 !---------------------------------------------------------------------- 2189 2190 if(option<0.or.option>3) then 2191 msg='wrong option!' 2192 LIBPAW_BUG(msg) 2193 end if 2194 if(option/=3) then 2195 call pawxc_get_nkxc(nkxc_cur,nspden,xclevel) 2196 if (nkxc/=nkxc_cur) then 2197 msg='Wrong dimension for array kxc!' 2198 LIBPAW_BUG(msg) 2199 end if 2200 if(xclevel==2.and.nspden==4) then 2201 msg='PAW non-collinear magnetism not compatible with GGA!' 2202 LIBPAW_ERROR(msg) 2203 end if 2204 end if 2205 if(pawang%angl_size==0) then 2206 msg='pawang%angl_size=0!' 2207 LIBPAW_BUG(msg) 2208 end if 2209 if(.not.allocated(pawang%ylmr)) then 2210 msg='pawang%ylmr must be allocated!' 2211 LIBPAW_BUG(msg) 2212 end if 2213 if(xclevel==2.and.(.not.allocated(pawang%ylmrgr))) then 2214 msg='pawang%ylmrgr must be allocated!' 2215 LIBPAW_BUG(msg) 2216 end if 2217 if (option/=1) then 2218 if (nrad<pawrad%int_meshsz) then 2219 msg='When option=0,2, nrad must be greater than pawrad%int_meshsz!' 2220 LIBPAW_BUG(msg) 2221 end if 2222 end if 2223 2224 !---------------------------------------------------------------------- 2225 !----- Initializations / allocations 2226 !---------------------------------------------------------------------- 2227 2228 npts=pawang%angl_size 2229 lm_size_eff=min(lm_size,pawang%ylm_size) 2230 nspden_updn=min(nspden,2) 2231 2232 need_impart=present(d2enxc_im) 2233 if (option/=1) then 2234 d2enxc=zero 2235 if (need_impart) d2enxc_im=zero 2236 end if 2237 if (option<=1) vxc1(:,:,:)=zero 2238 2239 !Special case: no XC applied 2240 if (ixc==0.or.(nkxc==0.and.option/=3)) then 2241 msg='Note that no xc is applied (ixc=0). Returning' 2242 LIBPAW_WARNING(msg) 2243 return 2244 end if 2245 2246 LIBPAW_ALLOCATE(rho1arr,(cplex_den*nrad,nspden)) 2247 if (usexcnhat>0) then 2248 LIBPAW_ALLOCATE(rhohat1,(cplex_den*nrad,lm_size,nspden)) 2249 rhohat1(:,:,:)=rhor1(:,:,:)+nhat1(:,:,:) 2250 end if 2251 2252 if (option==2) then 2253 LIBPAW_POINTER_ALLOCATE(vxc1_,(cplex_vxc*nrad,npts,nspden)) 2254 else 2255 vxc1_ => vxc1 2256 end if 2257 2258 !Need gradients and additional allocations in case of GGA 2259 if (xclevel==2.and.option/=3) then 2260 LIBPAW_ALLOCATE(gxc1,(cplex_vxc*nrad,3,pawang%ylm_size,nspden)) 2261 gxc1=zero 2262 if (usecore==1) then 2263 LIBPAW_ALLOCATE(drho1core,(nrad,cplex_den)) 2264 if (cplex_den==1) then 2265 call nderiv_gen(drho1core(:,1),corexc1,pawrad) 2266 else 2267 LIBPAW_ALLOCATE(ff,(nrad)) 2268 LIBPAW_ALLOCATE(gg,(nrad)) 2269 do ir=1,nrad 2270 ff(ir)=corexc1(2*ir-1) 2271 gg(ir)=corexc1(2*ir ) 2272 end do 2273 call nderiv_gen(drho1core(:,1),ff,pawrad) 2274 call nderiv_gen(drho1core(:,2),gg,pawrad) 2275 LIBPAW_DEALLOCATE(ff) 2276 LIBPAW_DEALLOCATE(gg) 2277 end if 2278 end if 2279 ! Convert Ylm derivatives from normalized to standard cartesian coordinates 2280 ! dYlm/dr_i = { dYlm/dr_i^hat - Sum_j[ dYlm/dr_j^hat (r_j/r)] } * (1/r) 2281 LIBPAW_ALLOCATE(dylmdr,(3,npts,pawang%ylm_size)) 2282 do ilm=1,pawang%ylm_size 2283 do ipts=1,npts 2284 factor=sum(pawang%ylmrgr(1:3,ilm,ipts)*pawang%anginit(1:3,ipts)) 2285 dylmdr(1:3,ipts,ilm)=pawang%ylmrgr(1:3,ilm,ipts)-factor*pawang%anginit(1:3,ipts) 2286 end do 2287 end do 2288 end if 2289 2290 !---------------------------------------------------------------------- 2291 !----- Accumulate and store 1st-order change of XC potential 2292 !---------------------------------------------------------------------- 2293 2294 if (option/=3) then 2295 2296 if (nspden/=4) then 2297 rho1_updn => rho1arr 2298 vxc1_updn => vxc1_ 2299 else 2300 LIBPAW_POINTER_ALLOCATE(rho1_updn,(cplex_den*nrad,nspden_updn)) 2301 LIBPAW_POINTER_ALLOCATE(vxc1_updn,(cplex_vxc*nrad,npts,nspden_updn)) 2302 LIBPAW_POINTER_ALLOCATE(rho1_nc,(cplex_den*nrad*npts,nspden)) 2303 LIBPAW_POINTER_ALLOCATE(mag,(nrad,3)) 2304 end if 2305 2306 ! Do loop on the angular part (theta,phi) 2307 do ipts=1,npts 2308 2309 ! Copy the input 1st-order density for this (theta,phi) 2310 rho1arr(:,:)=zero 2311 if (usexcnhat< 2) rho1_=>rhor1 2312 if (usexcnhat==2) rho1_=>rhohat1 2313 do ispden=1,nspden 2314 do ilm=1,lm_size_eff 2315 if (lmselect(ilm)) rho1arr(:,ispden)=rho1arr(:,ispden) & 2316 & +rho1_(:,ilm,ispden)*pawang%ylmr(ilm,ipts) 2317 end do 2318 end do 2319 if (usecore==1) then 2320 rho1arr(:,1)=rho1arr(:,1)+corexc1(:) 2321 if (nspden==2) rho1arr(:,2)=rho1arr(:,2)+half*corexc1(:) 2322 end if 2323 2324 ! Optionally suppress magnetic part 2325 if(non_magnetic_xc) then 2326 if(nspden==2) rho1arr(:,2)=rho1arr(:,1)*half 2327 if(nspden==4) rho1arr(:,2:4)=zero 2328 endif 2329 2330 ! Non-collinear magnetism: rotate magnetization and get a collinear density 2331 if (nspden==4) then 2332 !Store non rotated rho^(1) for future use 2333 ii=(ipts-1)*cplex_den*nrad 2334 do ispden=1,nspden 2335 rho1_nc(ii+1:ii+cplex_den*nrad,ispden)=rho1arr(1:cplex_den*nrad,ispden) 2336 end do 2337 !Extract magnetization from kxc 2338 do ii=1,3 2339 mag(1:nrad,ii)=kxc(:,ipts,ii) 2340 end do 2341 !Rotate rhoarr1 -> rhoarr1_ 2342 !Should use cplex_den 2343 call pawxc_rotate_mag(rho1arr,rho1_updn,mag,nrad,rho_out_format=2) 2344 end if 2345 2346 ! ======================================================================= 2347 ! ======================= LDA =========================================== 2348 ! ======================================================================= 2349 if (xclevel==1.or.ixc==13) then 2350 2351 ! Non-spin-polarized 2352 if (nspden_updn==1) then 2353 if (cplex_vxc==1) then 2354 if (cplex_den==1) then ! cplex_vxc==1 and cplex_den==1 2355 vxc1_updn(1:nrad,ipts,1)=kxc(1:nrad,ipts,1)*rho1_updn(1:nrad,1) 2356 else ! cplex_vxc==1 and cplex_den==2 2357 do ir=1,nrad 2358 vxc1_updn(ir,ipts,1)=kxc(ir,ipts,1)*rho1_updn(2*ir-1,1) 2359 end do 2360 end if 2361 else 2362 if (cplex_den==1) then ! cplex_vxc==2 and cplex_den==1 2363 do ir=1,nrad 2364 vxc1_updn(2*ir-1,ipts,1)=kxc(ir,ipts,1)*rho1_updn(ir,1) 2365 vxc1_updn(2*ir ,ipts,1)=zero 2366 end do 2367 else ! cplex_vxc==2 and cplex_den==2 2368 do ir=1,nrad 2369 vxc1_updn(2*ir-1,ipts,1)=kxc(ir,ipts,1)*rho1_updn(2*ir-1,1) 2370 vxc1_updn(2*ir ,ipts,1)=kxc(ir,ipts,1)*rho1_updn(2*ir ,1) 2371 end do 2372 end if 2373 end if 2374 2375 ! Spin-polarized 2376 else 2377 if (cplex_vxc==1) then 2378 if (cplex_den==1) then ! cplex_vxc==1 and cplex_den==1 2379 do ir=1,nrad 2380 rho1_up=rho1_updn(ir,2);rho1_dn=rho1_updn(ir,1)-rho1_up 2381 vxc1_updn(ir,ipts,1)=kxc(ir,ipts,1)*rho1_up+kxc(ir,ipts,2)*rho1_dn 2382 vxc1_updn(ir,ipts,2)=kxc(ir,ipts,2)*rho1_up+kxc(ir,ipts,3)*rho1_dn 2383 end do 2384 else ! cplex_vxc==1 and cplex_den==2 2385 do ir=1,nrad 2386 jr=2*ir-1 2387 rho1_up=rho1_updn(jr,2);rho1_dn=rho1_updn(jr,1)-rho1_up 2388 vxc1_updn(ir,ipts,1)=kxc(ir,ipts,1)*rho1_up+kxc(ir,ipts,2)*rho1_dn 2389 vxc1_updn(ir,ipts,2)=kxc(ir,ipts,2)*rho1_up+kxc(ir,ipts,3)*rho1_dn 2390 end do 2391 end if 2392 else 2393 if (cplex_den==1) then ! cplex_vxc==2 and cplex_den==1 2394 do ir=1,nrad 2395 jr=2*ir-1 2396 rho1_up=rho1_updn(ir,2);rho1_dn=rho1_updn(ir,1)-rho1_up 2397 vxc1_updn(jr,ipts,1)=kxc(ir,ipts,1)*rho1_up+kxc(ir,ipts,2)*rho1_dn 2398 vxc1_updn(jr,ipts,2)=kxc(ir,ipts,2)*rho1_up+kxc(ir,ipts,3)*rho1_dn 2399 end do 2400 else ! cplex_vxc==2 and cplex_den==2 2401 do ir=1,nrad 2402 jr=2*ir 2403 rho1_up =rho1_updn(jr-1,2);rho1_dn =rho1_updn(jr-1,1)-rho1_up 2404 rho1im_up=rho1_updn(jr ,2);rho1im_dn=rho1_updn(jr ,1)-rho1im_up 2405 vxc1_updn(jr-1,ipts,1)=kxc(ir,ipts,1)*rho1_up +kxc(ir,ipts,2)*rho1_dn 2406 vxc1_updn(jr ,ipts,1)=kxc(ir,ipts,1)*rho1im_up+kxc(ir,ipts,2)*rho1im_dn 2407 vxc1_updn(jr-1,ipts,2)=kxc(ir,ipts,2)*rho1_up +kxc(ir,ipts,3)*rho1_dn 2408 vxc1_updn(jr ,ipts,2)=kxc(ir,ipts,2)*rho1im_up+kxc(ir,ipts,3)*rho1im_dn 2409 end do 2410 end if 2411 end if 2412 end if 2413 2414 else 2415 ! ======================================================================= 2416 ! ======================= GGA =========================================== 2417 ! ======================================================================= 2418 2419 ! Compute the gradient of the first-order density 2420 LIBPAW_ALLOCATE(drho1,(nrad,cplex_den)) 2421 LIBPAW_ALLOCATE(grho1arr,(cplex_den*nrad,nspden,3)) 2422 grho1arr(:,:,1:3)=zero 2423 if (cplex_den==1) then 2424 LIBPAW_ALLOCATE(ff,(nrad)) 2425 do ispden=1,nspden_updn 2426 do ilm=1,lm_size_eff 2427 if (lmselect(ilm)) then 2428 ff(1:nrad)=rho1_(1:nrad,ilm,ispden) 2429 call nderiv_gen(drho1(:,1),ff,pawrad) 2430 ff(2:nrad)=ff(2:nrad)/pawrad%rad(2:nrad) 2431 call pawrad_deducer0(ff,nrad,pawrad) 2432 do ii=1,3 2433 ylm_ii=pawang%ylmr(ilm,ipts)*pawang%anginit(ii,ipts) 2434 dylmdr_ii=dylmdr(ii,ipts,ilm) 2435 grho1arr(1:nrad,ispden,ii)=grho1arr(1:nrad,ispden,ii) & 2436 & +drho1(1:nrad,1)*ylm_ii+ff(1:nrad)*dylmdr_ii 2437 end do 2438 end if 2439 end do 2440 end do 2441 LIBPAW_DEALLOCATE(ff) 2442 else 2443 LIBPAW_ALLOCATE(ff,(nrad)) 2444 LIBPAW_ALLOCATE(gg,(nrad)) 2445 do ispden=1,nspden_updn 2446 do ilm=1,lm_size_eff 2447 if (lmselect(ilm)) then 2448 do ir=1,nrad 2449 ff(ir)=rho1_(2*ir-1,ilm,ispden) 2450 gg(ir)=rho1_(2*ir ,ilm,ispden) 2451 end do 2452 call nderiv_gen(drho1(:,1),ff,pawrad) 2453 call nderiv_gen(drho1(:,2),gg,pawrad) 2454 ff(2:nrad)=ff(2:nrad)/pawrad%rad(2:nrad) 2455 gg(2:nrad)=gg(2:nrad)/pawrad%rad(2:nrad) 2456 call pawrad_deducer0(ff,nrad,pawrad) 2457 call pawrad_deducer0(gg,nrad,pawrad) 2458 do ii=1,3 2459 ylm_ii=pawang%ylmr(ilm,ipts)*pawang%anginit(ii,ipts) 2460 dylmdr_ii=dylmdr(ii,ipts,ilm) 2461 do ir=2,nrad 2462 jr=2*ir 2463 grho1arr(jr-1,ispden,ii)=grho1arr(jr-1,ispden,ii) & 2464 & +drho1(ir,1)*ylm_ii+ff(ir)*dylmdr_ii 2465 grho1arr(jr ,ispden,ii)=grho1arr(jr ,ispden,ii) & 2466 & +drho1(ir,2)*ylm_ii+gg(ir)*dylmdr_ii 2467 end do 2468 end do 2469 end if 2470 end do 2471 end do 2472 LIBPAW_DEALLOCATE(ff) 2473 LIBPAW_DEALLOCATE(gg) 2474 end if 2475 if (usecore==1) then 2476 factor=one;if (nspden_updn==2) factor=half 2477 if (cplex_den==1) then 2478 do ispden=1,nspden_updn 2479 do ii=1,3 2480 grho1arr(1:nrad,ispden,ii)=grho1arr(1:nrad,ispden,ii) & 2481 & +factor*drho1core(1:nrad,1)*pawang%anginit(ii,ipts) 2482 end do 2483 end do 2484 else 2485 do ispden=1,nspden_updn 2486 do ii=1,3 2487 do ir=1,nrad 2488 jr=2*ir 2489 grho1arr(jr-1,ispden,ii)=grho1arr(jr-1,ispden,ii) & 2490 & +factor*drho1core(ir,1)*pawang%anginit(ii,ipts) 2491 grho1arr(jr ,ispden,ii)=grho1arr(jr ,ispden,ii) & 2492 & +factor*drho1core(ir,2)*pawang%anginit(ii,ipts) 2493 end do 2494 end do 2495 end do 2496 end if 2497 end if 2498 LIBPAW_DEALLOCATE(drho1) 2499 2500 ! Optionally suppress magnetic part 2501 if(non_magnetic_xc) then 2502 do ii=1,3 2503 if(nspden==2) grho1arr(:,2,ii)=grho1arr(:,1,ii)*half 2504 if(nspden==4) grho1arr(:,2:4,ii)=zero 2505 end do 2506 endif 2507 2508 ! Apply XC kernel 2509 ! Will compute Vxc^(1) as: vxc1 - Nabla .dot. gxc1 2510 2511 ! Scaling factor for angular integrals: four_pi x spin_factor 2512 factor_ang_intg=four_pi;if (nspden_updn==1) factor_ang_intg=two_pi 2513 2514 ! A- NON POLARIZED SYSTEMS 2515 if (nspden_updn==1) then 2516 2517 do ir=1,nrad 2518 jr=cplex_den*(ir-1)+1 ; kr=cplex_vxc*(ir-1)+1 2519 2520 g0(:)=kxc(ir,ipts,5:7) ; g1(:)=grho1arr(jr,1,1:3) 2521 grho_grho1=dot_product(g0,g1) 2522 coeff_grho=kxc(ir,ipts,3)*rho1_updn(jr,1)+kxc(ir,ipts,4)*grho_grho1 2523 vxc1_updn(kr,ipts,1)=kxc(ir,ipts,1)*rho1_updn(jr,1)+kxc(ir,ipts,3)*grho_grho1 2524 gxc1r(:,1)=g1(:)*kxc(ir,ipts,2)+g0(:)*coeff_grho 2525 !Accumulate gxc1_lm moments as Intg[gxc1(omega).Ylm(omega).d_omega] 2526 do ilm=1,pawang%ylm_size 2527 ylm_ii=pawang%ylmr(ilm,ipts)*pawang%angwgth(ipts)*factor_ang_intg 2528 do ii=1,3 2529 gxc1(kr,ii,ilm,1)=gxc1(ir,ii,ilm,1)+gxc1r(ii,1)*ylm_ii 2530 end do 2531 end do 2532 if (cplex_vxc==2) then 2533 if (cplex_den==2) then 2534 g1im(:)=grho1arr(jr+1,1,1:3) 2535 grho_grho1im=dot_product(g0,g1im) 2536 coeff_grhoim=kxc(ir,ipts,3)*rho1_updn(jr+1,1)+kxc(ir,ipts,4)*grho_grho1im 2537 vxc1_updn(kr+1,ipts,1)=kxc(ir,ipts,1)*rho1_updn(jr+1,1)+kxc(ir,ipts,3)*grho_grho1im 2538 gxc1i(:,1)=g1im(:)*kxc(ir,ipts,2)+g0(:)*coeff_grhoim 2539 !Accumulate gxc1_lm moments as Intg[gxc1(omega).Ylm(omega).d_omega] 2540 do ilm=1,pawang%ylm_size 2541 ylm_ii=pawang%ylmr(ilm,ipts)*pawang%angwgth(ipts)*factor_ang_intg 2542 do ii=1,3 2543 gxc1(kr+1,ii,ilm,1)=gxc1(kr+1,ii,ilm,1)+gxc1i(ii,1)*ylm_ii 2544 end do 2545 end do 2546 else 2547 vxc1_updn(kr+1,ipts,1)=zero ; gxc1i(:,1)=zero 2548 end if 2549 end if 2550 end do ! ir 2551 2552 ! B- POLARIZED SYSTEMS (COLLINEAR) 2553 else ! nspden_updn==2 2554 2555 do ir=1,nrad 2556 jr=cplex_den*(ir-1)+1 ; kr=cplex_vxc*(ir-1)+1 2557 2558 rho1_up=rho1_updn(jr,2);rho1_dn=rho1_updn(jr,1)-rho1_up 2559 g0_up(1)=kxc(ir,ipts,15);g0_dn(1)=kxc(ir,ipts,14)-kxc(ir,ipts,15) 2560 g0_up(2)=kxc(ir,ipts,17);g0_dn(2)=kxc(ir,ipts,16)-kxc(ir,ipts,17) 2561 g0_up(3)=kxc(ir,ipts,19);g0_dn(3)=kxc(ir,ipts,18)-kxc(ir,ipts,19) 2562 g1_up(:)=grho1arr(jr,2,:);g1_dn(:)=grho1arr(jr,1,:)-grho1arr(jr,2,:) 2563 g0(:)=g0_up(:)+g0_dn(:);g1(:)=g1_up(:)+g1_dn(:) 2564 grho_grho1_up=dot_product(g0_up,g1_up) 2565 grho_grho1_dn=dot_product(g0_dn,g1_dn) 2566 grho_grho1 =dot_product(g0,g1) 2567 coeff_grho_corr=kxc(ir,ipts,11)*rho1_up & 2568 & +kxc(ir,ipts,12)*rho1_dn & 2569 & +kxc(ir,ipts,13)*grho_grho1 2570 coeff_grho_up=kxc(ir,ipts,6)*rho1_up & 2571 & +kxc(ir,ipts,8)*grho_grho1_up 2572 coeff_grho_dn=kxc(ir,ipts,7)*rho1_dn & 2573 & +kxc(ir,ipts,9)*grho_grho1_dn 2574 vxc1_updn(kr,ipts,1)=kxc(ir,ipts, 1)*rho1_up & 2575 & +kxc(ir,ipts, 2)*rho1_dn & 2576 & +kxc(ir,ipts, 6)*grho_grho1_up & 2577 & +kxc(ir,ipts,11)*grho_grho1 2578 vxc1_updn(kr,ipts,2)=kxc(ir,ipts, 3)*rho1_dn & 2579 & +kxc(ir,ipts, 2)*rho1_up & 2580 & +kxc(ir,ipts, 7)*grho_grho1_dn & 2581 & +kxc(ir,ipts,12)*grho_grho1 2582 gxc1r(:,1)=(kxc(ir,ipts,4)+kxc(ir,ipts,10))*g1_up(:) & 2583 & +kxc(ir,ipts,10) *g1_dn(:) & 2584 & +coeff_grho_up *g0_up(:) & 2585 & +coeff_grho_corr *g0(:) 2586 gxc1r(:,2)=(kxc(ir,ipts,5)+kxc(ir,ipts,10))*g1_dn(:) & 2587 & +kxc(ir,ipts,10) *g1_up(:) & 2588 & +coeff_grho_dn *g0_dn(:) & 2589 & +coeff_grho_corr *g0(:) 2590 !Accumulate gxc1_lm moments as Intg[gxc1(omega).Ylm(omega).d_omega] 2591 do ispden=1,nspden_updn 2592 do ilm=1,pawang%ylm_size 2593 ylm_ii=pawang%ylmr(ilm,ipts)*pawang%angwgth(ipts)*factor_ang_intg 2594 do ii=1,3 2595 gxc1(kr,ii,ilm,ispden)=gxc1(kr,ii,ilm,ispden)+gxc1r(ii,ispden)*ylm_ii 2596 end do 2597 end do 2598 end do 2599 2600 if (cplex_vxc==2) then 2601 if (cplex_den==2) then 2602 rho1im_up=rho1_updn(jr+1,2);rho1im_dn=rho1_updn(jr+1,1)-rho1im_up 2603 g1im_up(:)=grho1arr(jr+1,2,:);g1im_dn(:)=grho1arr(jr+1,1,:)-grho1arr(jr+1,2,:) 2604 g1im(:)=g1im_up(:)+g1im_dn(:) 2605 grho_grho1im_up=dot_product(g0_up,g1im_up) 2606 grho_grho1im_dn=dot_product(g0_dn,g1im_dn) 2607 grho_grho1im =dot_product(g0,g1im) 2608 coeff_grhoim_corr=kxc(ir,ipts,11)*rho1im_up & 2609 & +kxc(ir,ipts,12)*rho1im_dn & 2610 & +kxc(ir,ipts,13)*grho_grho1im 2611 coeff_grhoim_up=kxc(ir,ipts,6)*rho1im_up & 2612 & +kxc(ir,ipts,8)*grho_grho1im_up 2613 coeff_grhoim_dn=kxc(ir,ipts,7)*rho1im_dn & 2614 & +kxc(ir,ipts,9)*grho_grho1im_dn 2615 vxc1_updn(kr+1,ipts,1)=kxc(ir,ipts, 1)*rho1im_up & 2616 & +kxc(ir,ipts, 2)*rho1im_dn & 2617 & +kxc(ir,ipts, 6)*grho_grho1im_up & 2618 & +kxc(ir,ipts,11)*grho_grho1im 2619 vxc1_updn(kr+1,ipts,2)=kxc(ir,ipts, 3)*rho1im_dn & 2620 & +kxc(ir,ipts, 2)*rho1im_up & 2621 & +kxc(ir,ipts, 7)*grho_grho1im_dn & 2622 & +kxc(ir,ipts,12)*grho_grho1im 2623 gxc1i(:,1)=(kxc(ir,ipts,4)+kxc(ir,ipts,10))*g1im_up(:) & 2624 & +kxc(ir,ipts,10) *g1im_dn(:) & 2625 & +coeff_grhoim_up *g0_up(:) & 2626 & +coeff_grhoim_corr *g0(:) 2627 gxc1i(:,2)=(kxc(ir,ipts,5)+kxc(ir,ipts,10))*g1im_dn(:) & 2628 & +kxc(ir,ipts,10) *g1im_up(:) & 2629 & +coeff_grhoim_dn *g0_dn(:) & 2630 & +coeff_grhoim_corr *g0(:) 2631 !Accumulate gxc1_lm moments as Intg[gxc1(omega).Ylm(omega).d_omega] 2632 do ispden=1,nspden_updn 2633 do ilm=1,pawang%ylm_size 2634 ylm_ii=pawang%ylmr(ilm,ipts)*pawang%angwgth(ipts)*factor_ang_intg 2635 do ii=1,3 2636 gxc1(kr+1,ii,ilm,ispden)=gxc1(kr+1,ii,ilm,ispden)+gxc1i(ii,ispden)*ylm_ii 2637 end do 2638 end do 2639 end do 2640 else 2641 vxc1_updn(kr+1,ipts,1:2)=zero ; gxc1i(:,1:2)=zero 2642 end if 2643 end if 2644 2645 end do ! ir 2646 2647 end if ! nspden_updn 2648 2649 LIBPAW_DEALLOCATE(grho1arr) 2650 2651 end if ! LDA or GGA 2652 2653 ! ----- End of the loop on npts (angular part) 2654 end do 2655 2656 ! Deallocate memory 2657 if (xclevel==2.and.usecore==1) then 2658 LIBPAW_DEALLOCATE(drho1core) 2659 end if 2660 if (nspden==4) then 2661 LIBPAW_POINTER_DEALLOCATE(rho1_updn) 2662 LIBPAW_POINTER_DEALLOCATE(mag) 2663 end if 2664 2665 end if ! option/=3 2666 2667 !---------------------------------------------------------------------- 2668 !----- If GGA, modify 1st-order potential with term from density gradient 2669 !---------------------------------------------------------------------- 2670 if (xclevel==2.and.ixc/=13.and.option/=3) then 2671 ! Compute divergence of gxc1 and substract it from Vxc1 2672 2673 ! Need to multiply gxc1 by 2 in the non-polarised case 2674 factor=one;if (nspden_updn==1) factor=two 2675 2676 LIBPAW_ALLOCATE(dgxc1,(nrad)) 2677 LIBPAW_ALLOCATE(gg,(nrad)) 2678 do ispden=1,nspden_updn 2679 do ilm=1,pawang%ylm_size 2680 do ii=1,3 2681 do ir=1,nrad 2682 jr=cplex_vxc*(ir-1)+1 2683 gg(ir)=gxc1(jr,ii,ilm,ispden) 2684 end do 2685 call nderiv_gen(dgxc1,gg,pawrad) 2686 gg(2:nrad)=gg(2:nrad)/pawrad%rad(2:nrad) 2687 call pawrad_deducer0(gg,nrad,pawrad) 2688 do ipts=1,npts 2689 ylm_ii=pawang%ylmr(ilm,ipts)*pawang%anginit(ii,ipts) 2690 dylmdr_ii=dylmdr(ii,ipts,ilm) 2691 do ir=1,nrad 2692 jr=cplex_vxc*(ir-1)+1 2693 vxc1_(jr,ipts,ispden)=vxc1_(jr,ipts,ispden) & 2694 & -factor*(dgxc1(ir)*ylm_ii+gg(ir)*dylmdr_ii) 2695 end do 2696 end do ! ipts 2697 end do ! ii 2698 end do ! ilm 2699 end do ! ispden 2700 if (cplex_vxc==2) then 2701 do ispden=1,nspden_updn 2702 do ilm=1,pawang%ylm_size 2703 do ii=1,3 2704 do ir=1,nrad 2705 gg(ir)=gxc1(2*ir,ii,ilm,ispden) 2706 end do 2707 call nderiv_gen(dgxc1,gg,pawrad) 2708 gg(2:nrad)=gg(2:nrad)/pawrad%rad(2:nrad) 2709 call pawrad_deducer0(gg,nrad,pawrad) 2710 do ipts=1,npts 2711 ylm_ii=pawang%ylmr(ilm,ipts)*pawang%anginit(ii,ipts) 2712 dylmdr_ii=dylmdr(ii,ipts,ilm) 2713 do ir=1,nrad 2714 vxc1_(2*ir,ipts,ispden)=vxc1_(2*ir,ipts,ispden) & 2715 & -factor*(dgxc1(ir)*ylm_ii+gg(ir)*dylmdr_ii) 2716 end do 2717 end do ! ipts 2718 end do ! ii 2719 end do ! ilm 2720 end do ! ispden 2721 end if ! cplex_vxc 2722 LIBPAW_DEALLOCATE(dgxc1) 2723 LIBPAW_DEALLOCATE(gg) 2724 2725 end if ! GGA 2726 2727 ! ---------------------------------------------------------------------- 2728 ! ----- If non-collinear, rotate back potential according to magnetization 2729 ! ---------------------------------------------------------------------- 2730 if (option/=3.and.nspden==4) then 2731 ! Use of C pointers to avoid copies (when ISO C bindings are available) 2732 ! %@1$ xlf v15 compiler requires a auxilliary cptr variable 2733 #ifdef LIBPAW_ISO_C_BINDING 2734 cptr=c_loc(vxc1_updn(1,1,1)) 2735 call c_f_pointer(cptr,vxc1_diag,shape=[cplex_vxc*nrad*npts,nspden_updn]) 2736 cptr=c_loc(vxc1_(1,1,1)) 2737 call c_f_pointer(cptr,vxc1_nc,shape=[cplex_vxc*nrad*npts,nspden]) 2738 cptr=c_loc(vxc(1,1,1)) 2739 call c_f_pointer(cptr,vxc_,shape=[nrad*npts,nspden]) 2740 cptr=c_loc(kxc(1,1,1)) 2741 call c_f_pointer(cptr,kxc_,shape=[nrad*npts,3]) 2742 cptr=c_loc(kxc(1,1,nkxc-2)) 2743 call c_f_pointer(cptr,mag,shape=[nrad*npts,3]) 2744 #else 2745 LIBPAW_ALLOCATE(vxc1_diag,(cplex_vxc*nrad*npts,nspden_updn)) 2746 LIBPAW_ALLOCATE(vxc1_nc,(cplex_vxc*nrad*npts,nspden)) 2747 LIBPAW_ALLOCATE(vxc_,(nrad*npts,nspden)) 2748 LIBPAW_ALLOCATE(kxc_,(nrad*npts,3)) 2749 LIBPAW_ALLOCATE(mag,(nrad*npts,3)) 2750 vxc1_diag=reshape(vxc1_updn,[cplex_vxc*nrad*npts,nspden_updn]) 2751 vxc_=reshape(vxc(1:cplex_vxc*nrad,1:npts,1:nspden),[cplex_vxc*nrad*npts,nspden]) 2752 kxc_=reshape(kxc(1:nrad,1:npts,1:3),[nrad*npts,3]) 2753 mag=reshape(kxc(1:nrad,1:npts,nkxc-2:nkxc),[nrad*npts,3]) 2754 #endif 2755 !Should use cplex_den and cplex_vxc 2756 call pawxc_rotate_back_mag_dfpt(vxc1_diag,vxc1_nc,vxc_,kxc_,rho1_nc,mag,nrad*npts) 2757 #ifndef LIBPAW_ISO_C_BINDING 2758 vxc1_=reshape(vxc1_nc,[cplex_vxc*nrad,npts,nspden]) 2759 LIBPAW_DEALLOCATE(vxc1_diag) 2760 LIBPAW_DEALLOCATE(vxc1_nc) 2761 LIBPAW_DEALLOCATE(vxc_) 2762 LIBPAW_DEALLOCATE(kxc_) 2763 LIBPAW_DEALLOCATE(mag) 2764 #endif 2765 LIBPAW_POINTER_DEALLOCATE(rho1_nc) 2766 LIBPAW_POINTER_DEALLOCATE(vxc1_updn) 2767 end if 2768 2769 !---------------------------------------------------------------------- 2770 !----- Accumulate and store 2nd-order change of XC energy 2771 !---------------------------------------------------------------------- 2772 if (option/=1) then 2773 2774 ! Do loop on the angular part (theta,phi) 2775 do ipts=1,npts 2776 2777 ! Copy the input 1st-order density for this (theta,phi) 2778 rho1arr(:,:)=zero 2779 if (usexcnhat< 1) rho1_=>rhor1 2780 if (usexcnhat>=1) rho1_=>rhohat1 2781 do ispden=1,nspden 2782 do ilm=1,lm_size_eff 2783 if (lmselect(ilm)) rho1arr(:,ispden)=rho1arr(:,ispden) & 2784 & +rho1_(:,ilm,ispden)*pawang%ylmr(ilm,ipts) 2785 end do 2786 end do 2787 if (usecore==1) then 2788 rho1arr(:,1)=rho1arr(:,1)+corexc1(:) 2789 if (nspden==2) rho1arr(:,2)=rho1arr(:,2)+half*corexc1(:) 2790 end if 2791 2792 ! ----- Calculate d2Exc=Int[Vxc^(1)^*(r).n^(1)(r).dr] 2793 LIBPAW_ALLOCATE(ff,(nrad)) 2794 if (need_impart) then 2795 LIBPAW_ALLOCATE(gg,(nrad)) 2796 end if 2797 2798 ! COLLINEAR MAGNETISM 2799 if (nspden/=4) then 2800 if (cplex_vxc==1.and.cplex_den==1) then ! cplex_vxc==1 and cplex_den==1 2801 ff(:)=vxc1_(:,ipts,1)*rho1arr(:,nspden) 2802 if (nspden==2) ff(:)=ff(:)+vxc1_(:,ipts,2)*(rho1arr(:,1)-rho1arr(:,2)) 2803 if (need_impart) gg(:)=zero 2804 else if (cplex_vxc==2.and.cplex_den==2) then ! cplex_vxc==2 and cplex_den==2 2805 if (.not.need_impart) then ! Real part only 2806 do ir=1,nrad 2807 jr=2*ir;v11r=vxc1_(jr-1,ipts,1);v11i=vxc1_(jr,ipts,1) 2808 ro11r=rho1arr(jr-1,nspden);ro11i=rho1arr(jr,nspden) 2809 ff(ir)=v11r*ro11r+v11i*ro11i 2810 end do 2811 if (nspden==2) then 2812 do ir=1,nrad 2813 jr=2*ir;v22r=vxc1_(jr-1,ipts,2);v22i=vxc1_(jr,ipts,2) 2814 ro22r=rho1arr(jr-1,1)-rho1arr(jr-1,2) 2815 ro22i=rho1arr(jr ,1)-rho1arr(jr ,2) 2816 ff(ir)=ff(ir)+v22r*ro22r+v22i*ro22i 2817 end do 2818 end if 2819 else 2820 do ir=1,nrad ! Real and imaginary parts 2821 jr=2*ir;v11r=vxc1_(jr-1,ipts,1);v11i=vxc1_(jr,ipts,1) 2822 ro11r=rho1arr(jr-1,nspden);ro11i=rho1arr(jr,nspden) 2823 ff(ir)=v11r*ro11r+v11i*ro11i 2824 gg(ir)=v11r*ro11i-v11i*ro11r 2825 end do 2826 if (nspden==2) then 2827 do ir=1,nrad 2828 jr=2*ir;v22r=vxc1_(jr-1,ipts,2);v22i=vxc1_(jr,ipts,2) 2829 ro22r=rho1arr(jr-1,1)-rho1arr(jr-1,2) 2830 ro22i=rho1arr(jr ,1)-rho1arr(jr ,2) 2831 ff(ir)=ff(ir)+v22r*ro22r+v22i*ro22i 2832 gg(ir)=gg(ir)+v22r*ro22i-v22i*ro22r 2833 end do 2834 end if 2835 end if 2836 else ! other cases for cplex_vxc and cplex_den 2837 v11i=zero;ro11i=zero 2838 do ir=1,nrad 2839 jr=cplex_den*(ir-1)+1 ; kr=cplex_vxc*(ir-1)+1 2840 ro11r=rho1arr(jr,nspden);if (cplex_den==2) ro11i=rho1arr(jr+1,nspden) 2841 v11r=vxc1_(kr,ipts,1);if (cplex_vxc==2) v11i=vxc1_(kr+1,ipts,1) 2842 ff(ir)=v11r*ro11r+v11i*ro11i 2843 if (need_impart) gg(ir)=v11r*ro11i-v11i*ro11r 2844 end do 2845 if (nspden==2) then 2846 v22i=zero;ro22i=zero 2847 do ir=1,nrad 2848 jr=cplex_den*(ir-1)+1 ; kr=cplex_vxc*(ir-1)+1 2849 ro22r=rho1arr(jr,1)-rho1arr(jr,2) 2850 if (cplex_den==2) ro22i=rho1arr(jr+1,1)-rho1arr(jr+1,2) 2851 v22r=vxc1_(kr,ipts,2);if (cplex_vxc==2) v22i=vxc1_(kr+1,ipts,2) 2852 ff(ir)=ff(ir)+v22r*ro22r+v22i*ro22i 2853 gg(ir)=gg(ir)+v22r*ro22i-v22i*ro22r 2854 end do 2855 end if 2856 end if ! cplex_vxc and cplex_den 2857 2858 ! NON-COLLINEAR MAGNETISM 2859 else 2860 if (cplex_vxc==1.and.cplex_den==1) then ! cplex_vxc==1 and cplex_den==1 2861 ff(:)=half*(vxc1_(:,ipts,1)*(rho1arr(:,1)+rho1arr(:,4)) & 2862 & +vxc1_(:,ipts,2)*(rho1arr(:,1)-rho1arr(:,4))) & 2863 & +vxc1_(:,ipts,3)*rho1arr(:,2) & 2864 & -vxc1_(:,ipts,4)*rho1arr(:,3) 2865 if (need_impart) gg(:)=zero 2866 else ! other cases for cplex_vxc and cplex_den 2867 2868 ! V is stored as : v^11, v^22, V^12, i.V^21 (each are complex) 2869 ! N is stored as : n, m_x, m_y, mZ (each are complex) 2870 do ir=1,nrad 2871 jr=cplex_den*(ir-1)+1 ; kr=cplex_vxc*(ir-1)+1 2872 ro11r= rho1arr(jr,1)+rho1arr(jr,4) 2873 ro22r= rho1arr(jr,1)-rho1arr(jr,4) 2874 ro12r= rho1arr(jr,2);ro12i=-rho1arr(jr,3) 2875 ro21r= rho1arr(jr,2);ro21i= rho1arr(jr,3) 2876 if (cplex_den==2) then 2877 ro11i=rho1arr(jr+1,1)+rho1arr(jr+1,4) 2878 ro22i=rho1arr(jr+1,1)-rho1arr(jr+1,4) 2879 ro12r=ro12r+rho1arr(jr+1,3);ro12i=ro12i+rho1arr(jr+1,2) 2880 ro21r=ro21r-rho1arr(jr+1,3);ro21i=ro21i+rho1arr(jr+1,2) 2881 else 2882 ro11i=zero;ro22i=zero 2883 end if 2884 v11r= vxc1_(kr,ipts,1);v22r= vxc1_(kr,ipts,2) 2885 v12r= vxc1_(kr,ipts,3);v21i=-vxc1_(kr,ipts,1) 2886 if (cplex_vxc==2) then 2887 v11i= vxc1_(kr+1,ipts,1);v22i= vxc1_(kr+1,ipts,2) 2888 v12i= vxc1_(kr+1,ipts,3);v21r= vxc1_(kr+1,ipts,1) 2889 else 2890 v11i=zero;v22i=zero 2891 v12i=zero;v21i=zero 2892 end if 2893 ! Real part 2894 ff(ir)=half*(v11r*ro11r+v11i*ro11i+v22r*ro22r+v22i*ro22i & 2895 & +v12r*ro12r+v12i*ro12i+v21r*ro21r+v21i*ro21i) 2896 ! Imaginary part 2897 if (need_impart) & 2898 & gg(ir)=half*(v11r*ro11i-v11i*ro11r+v22r*ro22i-v22i*ro22r & 2899 & +v12r*ro12i-v12i*ro12r+v21r*ro21i-v21i*ro21r) 2900 end do 2901 end if ! cplex_vxc and cplex_den 2902 end if ! nspden 2903 2904 ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2 2905 call simp_gen(vxcrho,ff,pawrad) 2906 d2enxc=d2enxc+vxcrho*pawang%angwgth(ipts) 2907 LIBPAW_DEALLOCATE(ff) 2908 2909 if (need_impart) then 2910 gg(1:nrad)=gg(1:nrad)*pawrad%rad(1:nrad)**2 2911 call simp_gen(vxcrho,gg,pawrad) 2912 d2enxc_im=d2enxc_im+vxcrho*pawang%angwgth(ipts) 2913 LIBPAW_DEALLOCATE(gg) 2914 end if 2915 2916 ! ----- End of the loop on npts (angular part) 2917 end do 2918 2919 end if ! option/=1 2920 2921 !Add the four*pi factor of the angular integration 2922 if (option/=1) then 2923 d2enxc=d2enxc*four_pi 2924 if (need_impart) d2enxc_im=d2enxc_im*four_pi 2925 end if 2926 2927 !Free memory 2928 if (usexcnhat>0) then 2929 LIBPAW_DEALLOCATE(rhohat1) 2930 end if 2931 LIBPAW_DEALLOCATE(rho1arr) 2932 if (option==2) then 2933 LIBPAW_POINTER_DEALLOCATE(vxc1_) 2934 end if 2935 if (xclevel==2.and.option/=3) then 2936 LIBPAW_DEALLOCATE(gxc1) 2937 LIBPAW_DEALLOCATE(dylmdr) 2938 end if 2939 2940 end subroutine pawxc_dfpt
m_pawxc/pawxc_drivexc_abinit [ Functions ]
[ Top ] [ m_pawxc ] [ Functions ]
NAME
pawxc_drivexc_abinit
FUNCTION
ABINIT version of XC driving routine
SOURCE
5790 subroutine pawxc_drivexc_abinit() 5791 5792 logical :: test_args 5793 5794 ! ************************************************************************* 5795 5796 test_args=(present(dvxc).and.present(d2vxc)) 5797 if (usegradient==1) test_args=(test_args.and.present(grho2).and.present(vxcgrho)) 5798 if (uselaplacian==1) test_args=(test_args.and.present(lrho).and.present(vxclrho)) 5799 if (usekden==1) test_args=(test_args.and.present(tau).and.present(vxctau)) 5800 if (.not.test_args) then 5801 msg='missing mandatory arguments in pawxc_drivexc_wrapper' 5802 LIBPAW_BUG(msg) 5803 end if 5804 5805 if (uselaplacian==1.or.usekden==1) then 5806 if (uselaplacian==1.and.usekden==1) then 5807 call drivexc(ixc,order,npts,nspden,usegradient,uselaplacian,usekden,& 5808 & rho,exc,vxcrho,nvxcgrho,nvxclrho,nvxctau,ndvxc,nd2vxc, & 5809 & grho2_updn=grho2,vxcgrho=vxcgrho,& 5810 & lrho_updn=lrho,vxclrho=vxclrho,& 5811 & tau_updn=tau,vxctau=vxctau,& 5812 & dvxc=dvxc,d2vxc=d2vxc,hyb_mixing=hyb_mixing) 5813 else if (uselaplacian==1) then 5814 call drivexc(ixc,order,npts,nspden,usegradient,uselaplacian,usekden,& 5815 & rho,exc,vxcrho,nvxcgrho,nvxclrho,nvxctau,ndvxc,nd2vxc, & 5816 & grho2_updn=grho2,vxcgrho=vxcgrho,& 5817 & lrho_updn=lrho,vxclrho=vxclrho,& 5818 & dvxc=dvxc,d2vxc=d2vxc,hyb_mixing=hyb_mixing) 5819 else if (usekden==1) then 5820 call drivexc(ixc,order,npts,nspden,usegradient,uselaplacian,usekden,& 5821 & rho,exc,vxcrho,nvxcgrho,nvxclrho,nvxctau,ndvxc,nd2vxc, & 5822 & grho2_updn=grho2,vxcgrho=vxcgrho,& 5823 & tau_updn=tau,vxctau=vxctau,& 5824 & dvxc=dvxc,d2vxc=d2vxc,hyb_mixing=hyb_mixing) 5825 end if 5826 else if (usegradient==1) then 5827 if (present(exexch)) then 5828 call drivexc(ixc,order,npts,nspden,usegradient,uselaplacian,usekden,& 5829 & rho,exc,vxcrho,nvxcgrho,nvxclrho,nvxctau,ndvxc,nd2vxc, & 5830 & grho2_updn=grho2,vxcgrho=vxcgrho,& 5831 & dvxc=dvxc,d2vxc=d2vxc,& 5832 & exexch=exexch,hyb_mixing=hyb_mixing) 5833 else 5834 call drivexc(ixc,order,npts,nspden,usegradient,uselaplacian,usekden,& 5835 & rho,exc,vxcrho,nvxcgrho,nvxclrho,nvxctau,ndvxc,nd2vxc, & 5836 & grho2_updn=grho2,vxcgrho=vxcgrho,& 5837 & dvxc=dvxc,d2vxc=d2vxc,hyb_mixing=hyb_mixing) 5838 end if 5839 else 5840 call drivexc(ixc,order,npts,nspden,usegradient,uselaplacian,usekden,& 5841 & rho,exc,vxcrho,nvxcgrho,nvxclrho,nvxctau,ndvxc,nd2vxc, & 5842 & dvxc=dvxc,d2vxc=d2vxc,hyb_mixing=hyb_mixing) 5843 end if 5844 5845 end subroutine pawxc_drivexc_abinit
m_pawxc/pawxc_drivexc_libxc [ Functions ]
[ Top ] [ m_pawxc ] [ Functions ]
NAME
pawxc_drivexc_libxc
FUNCTION
LibXC version of XC driving routine
SOURCE
5859 subroutine pawxc_drivexc_libxc() 5860 5861 ! ************************************************************************* 5862 5863 !Check the compatibility of input arguments 5864 if (ixc>=0) then 5865 msg='ixc argument should be negative!' 5866 LIBPAW_BUG(msg) 5867 end if 5868 if (ixc/=libxc_functionals_ixc()) then 5869 msg='The value of ixc differs from the one used to initialize the functional!' 5870 LIBPAW_BUG(msg) 5871 end if 5872 if ((order<1.and.order/=-2).or.order>4) then 5873 msg='The only allowed values for order are 1, 2, -2, or 3!' 5874 LIBPAW_BUG(msg) 5875 end if 5876 if ((order**2>1).and.(.not.present(dvxc))) then 5877 msg='The value of order is not compatible with the presence of the array dvxc!' 5878 LIBPAW_BUG(msg) 5879 end if 5880 if ((order==3).and.(.not.present(d2vxc))) then 5881 msg='The value of order is not compatible with the presence of the array d2vxc!' 5882 LIBPAW_BUG(msg) 5883 end if 5884 if (libxc_functionals_isgga().or.libxc_functionals_ismgga()) then 5885 if ((.not.present(grho2)).or.(.not.present(vxcgrho)).or.& 5886 & (usegradient==0).or.(nvxcgrho==0)) then 5887 write(msg,'(3a)') 'At least one of the functionals is a GGA,',ch10, & 5888 & 'but not all the necessary optional arguments are present.' 5889 LIBPAW_BUG(msg) 5890 end if 5891 if (libxc_functionals_needs_laplacian()) then 5892 if ((.not.present(lrho)).or.(.not.present(vxclrho)).or.& 5893 & (uselaplacian==0).or.(nvxclrho==0)) then 5894 write(msg,'(3a)') 'At least one of the functionals is a mGGA,',ch10, & 5895 & 'but not all the necessary optional arguments are present.' 5896 LIBPAW_BUG(msg) 5897 end if 5898 end if 5899 if (libxc_functionals_ismgga()) then 5900 if ((.not.present(tau)).or.(.not.present(vxctau)).or.& 5901 & (usekden==0).or.(nvxctau==0)) then 5902 write(msg,'(3a)') 'At least one of the functionals is a mGGA,',ch10, & 5903 & 'but not all the necessary optional arguments are present.' 5904 LIBPAW_BUG(msg) 5905 end if 5906 end if 5907 end if 5908 if ((uselaplacian==1.or.usekden==1).and.(usegradient==0)) then 5909 msg='Laplacian or kinetic energy density needs gradient!' 5910 LIBPAW_BUG(msg) 5911 end if 5912 5913 !Call LibXC routines 5914 if (uselaplacian==1.or.usekden==1) then ! meta-GGA 5915 if (uselaplacian==1.and.usekden==1) then 5916 call libxc_functionals_getvxc(ndvxc,nd2vxc,npts,nspden,order,rho,exc,vxcrho,& 5917 & grho2=grho2,vxcgr=vxcgrho,lrho=lrho,vxclrho=vxclrho,tau=tau,vxctau=vxctau) 5918 else if (uselaplacian==1) then 5919 call libxc_functionals_getvxc(ndvxc,nd2vxc,npts,nspden,order,rho,exc,vxcrho,& 5920 & grho2=grho2,vxcgr=vxcgrho,lrho=lrho,vxclrho=vxclrho) 5921 else if (usekden==1) then 5922 call libxc_functionals_getvxc(ndvxc,nd2vxc,npts,nspden,order,rho,exc,vxcrho,& 5923 & grho2=grho2,vxcgr=vxcgrho,tau=tau,vxctau=vxctau) 5924 end if 5925 else if (usegradient==1) then ! GGA 5926 if (abs(order)<=1) then 5927 call libxc_functionals_getvxc(ndvxc,nd2vxc,npts,nspden,order,rho,exc,vxcrho,& 5928 & grho2=grho2,vxcgr=vxcgrho) 5929 else 5930 call libxc_functionals_getvxc(ndvxc,nd2vxc,npts,nspden,order,rho,exc,vxcrho,& 5931 & grho2=grho2,vxcgr=vxcgrho,dvxc=dvxc) 5932 end if 5933 else ! LDA 5934 if (abs(order)<=1) then 5935 call libxc_functionals_getvxc(ndvxc,nd2vxc,npts,nspden,order,rho,exc,vxcrho) 5936 else if (abs(order)<=2) then 5937 call libxc_functionals_getvxc(ndvxc,nd2vxc,npts,nspden,order,rho,exc,vxcrho,& 5938 & dvxc=dvxc) 5939 else 5940 call libxc_functionals_getvxc(ndvxc,nd2vxc,npts,nspden,order,rho,exc,vxcrho,& 5941 & d2vxc=d2vxc) 5942 end if 5943 end if 5944 5945 end subroutine pawxc_drivexc_libxc
m_pawxc/pawxc_drivexc_wrapper [ Functions ]
[ Top ] [ m_pawxc ] [ Functions ]
NAME
pawxc_drivexc_wrapper
FUNCTION
PAW only Wrapper for drivexc routines
NOTES
PENDING. Need to manage properly optional arguments: Check that these are present before calling drivexc Probably use better interfaces of fortran 2003 to avoid numerous if/then sentences.
SOURCE
5736 subroutine pawxc_drivexc_wrapper(hyb_mixing,ixc,order,npts,nspden,usegradient,uselaplacian,usekden,& 5737 & rho,exc,vxcrho,nvxcgrho,nvxclrho,nvxctau,ndvxc,nd2vxc, & ! mandatory arguments 5738 & grho2,vxcgrho,lrho,vxclrho,tau,vxctau,dvxc,d2vxc, & ! optional arguments 5739 & exexch,el_temp,fxcT) ! optional arguments 5740 5741 !Arguments ------------------------------------ 5742 !scalars 5743 integer,intent(in) :: ixc,ndvxc,nd2vxc,npts,nspden,nvxcgrho,nvxclrho,nvxctau,order 5744 integer,intent(in) :: usegradient,uselaplacian,usekden 5745 real(dp),intent(in) :: hyb_mixing 5746 !arrays 5747 real(dp),intent(in) :: rho(npts,nspden) 5748 real(dp),intent(out) :: exc(npts),vxcrho(npts,nspden) 5749 integer,intent(in),optional :: exexch 5750 real(dp),intent(in),optional :: el_temp 5751 real(dp),intent(in),optional :: grho2(npts,(2*nspden-1)*usegradient) 5752 real(dp),intent(in),optional :: lrho(npts,nspden*uselaplacian) 5753 real(dp),intent(in),optional :: tau(npts,nspden*usekden) 5754 real(dp),intent(out),optional:: dvxc(npts,ndvxc),d2vxc(npts,nd2vxc),fxcT(npts) 5755 real(dp),intent(out),optional:: vxcgrho(npts,nvxcgrho),vxclrho(npts,nvxclrho),vxctau(npts,nvxctau) 5756 5757 !Local variables------------------------------- 5758 character(len=100) :: msg 5759 5760 ! ************************************************************************* 5761 5762 5763 !One could add here a section for other codes (i.e. BigDFT, ...) 5764 #if defined HAVE_LIBPAW_ABINIT 5765 call pawxc_drivexc_abinit() 5766 #elif defined LIBPAW_HAVE_LIBXC 5767 call pawxc_drivexc_libxc() 5768 #else 5769 write(msg,'(5a)') 'libPAW XC driving routine only implemented in the following cases:',ch10, & 5770 & ' - ABINIT',ch10,' - libXC' 5771 LIBPAW_BUG(msg) 5772 #endif 5773 5774 if (.false.) write(std_out,*) el_temp
m_pawxc/pawxc_get_nkxc [ Functions ]
[ Top ] [ m_pawxc ] [ Functions ]
NAME
pawxc_get_nkxc
FUNCTION
Get size of XC kernel array (Kxc) according to spin polarization and XC type
INPUTS
nspden= nmber of density spin components xclevel= XC type
OUTPUT
nkxc= size of XC kernel (kxc array)
NOTES
Content of Kxc array:
===== if LDA
if nspden==1: kxc(:,1)= d2Exc/drho2
(kxc(:,2)= d2Exc/drho_up drho_dn)
if nspden>=2: kxc(:,1)= d2Exc/drho_up drho_up
kxc(:,2)= d2Exc/drho_up drho_dn
kxc(:,3)= d2Exc/drho_dn drho_dn
if nspden==4: kxc(:,4:6)= (m_x, m_y, m_z) (magnetization)
===== if GGA
if nspden==1:
kxc(:,1)= d2Exc/drho2
kxc(:,2)= 1/|grad(rho)| dExc/d|grad(rho)|
kxc(:,3)= 1/|grad(rho)| d2Exc/d|grad(rho)| drho
kxc(:,4)= 1/|grad(rho)| * d/d|grad(rho)| ( 1/|grad(rho)| dExc/d|grad(rho)| )
kxc(:,5)= gradx(rho)
kxc(:,6)= grady(rho)
kxc(:,7)= gradz(rho)
if nspden>=2:
kxc(:,1)= d2Exc/drho_up drho_up
kxc(:,2)= d2Exc/drho_up drho_dn
kxc(:,3)= d2Exc/drho_dn drho_dn
kxc(:,4)= 1/|grad(rho_up)| dEx/d|grad(rho_up)|
kxc(:,5)= 1/|grad(rho_dn)| dEx/d|grad(rho_dn)|
kxc(:,6)= 1/|grad(rho_up)| d2Ex/d|grad(rho_up)| drho_up
kxc(:,7)= 1/|grad(rho_dn)| d2Ex/d|grad(rho_dn)| drho_dn
kxc(:,8)= 1/|grad(rho_up)| * d/d|grad(rho_up)| ( 1/|grad(rho_up)| dEx/d|grad(rho_up)| )
kxc(:,9)= 1/|grad(rho_dn)| * d/d|grad(rho_dn)| ( 1/|grad(rho_dn)| dEx/d|grad(rho_dn)| )
kxc(:,10)=1/|grad(rho)| dEc/d|grad(rho)|
kxc(:,11)=1/|grad(rho)| d2Ec/d|grad(rho)| drho_up
kxc(:,12)=1/|grad(rho)| d2Ec/d|grad(rho)| drho_dn
kxc(:,13)=1/|grad(rho)| * d/d|grad(rho)| ( 1/|grad(rho)| dEc/d|grad(rho)| )
kxc(:,14)=gradx(rho_up)
kxc(:,15)=gradx(rho_dn)
kxc(:,16)=grady(rho_up)
kxc(:,17)=grady(rho_dn)
kxc(:,18)=gradz(rho_up)
kxc(:,19)=gradz(rho_dn)
if nspden==4:
kxc(:,20:22)= (m_x, m_y, m_z) (magnetization)
SOURCE
5681 subroutine pawxc_get_nkxc(nkxc,nspden,xclevel) 5682 5683 !Arguments ------------------------------------ 5684 !scalars 5685 integer,intent(in) :: nspden,xclevel 5686 integer,intent(out) :: nkxc 5687 !arrays 5688 5689 !Local variables------------------------------- 5690 !scalars 5691 !arrays 5692 5693 !************************************************************************ 5694 5695 nkxc=0 5696 5697 if (nspden==1) then ! Non polarized 5698 5699 if (xclevel==1) nkxc=1 5700 if (xclevel==2) nkxc=7 5701 5702 else if (nspden==2) then ! Polarized 5703 5704 if (xclevel==1) nkxc=3 5705 if (xclevel==2) nkxc=19 5706 5707 else if (nspden==4) then ! Non-collinear 5708 5709 ! Store magnetization in the 3 last terms of Kxc 5710 if (xclevel==1) nkxc=6 5711 if (xclevel==2) nkxc=22 5712 5713 end if 5714 5715 end subroutine pawxc_get_nkxc
m_pawxc/pawxc_get_usekden [ Functions ]
[ Top ] [ m_pawxc ] [ Functions ]
NAME
pawxc_get_usekden
FUNCTION
Check if kinetic energy density is used in XC functional
INPUTS
ixc= choice of exchange-correlation scheme
SOURCE
718 function pawxc_get_usekden(ixc) 719 !Arguments ------------------------------------ 720 integer,intent(in) :: ixc 721 integer :: pawxc_get_usekden 722 723 ! ************************************************************************* 724 725 pawxc_get_usekden=0 726 if (ixc<0) then 727 if (libxc_functionals_ismgga()) pawxc_get_usekden=1 728 else if (ixc==31.or.ixc==34.or.ixc==35) then 729 pawxc_get_usekden=1 730 end if 731 732 end function pawxc_get_usekden
m_pawxc/pawxc_get_uselaplacian [ Functions ]
[ Top ] [ m_pawxc ] [ Functions ]
NAME
pawxc_get_uselaplacian
FUNCTION
Check if laplacian of density is used in XC functional
INPUTS
ixc= choice of exchange-correlation scheme
SOURCE
749 function pawxc_get_uselaplacian(ixc) 750 !Arguments ------------------------------------ 751 integer,intent(in) :: ixc 752 integer :: pawxc_get_uselaplacian 753 754 ! ************************************************************************* 755 756 pawxc_get_uselaplacian=0 757 if (ixc<0) then 758 if (libxc_functionals_needs_laplacian()) pawxc_get_uselaplacian=1 759 else if (ixc==32.or.ixc==35) then 760 pawxc_get_uselaplacian=1 761 end if 762 763 end function pawxc_get_uselaplacian
m_pawxc/pawxc_get_xclevel [ Functions ]
[ Top ] [ m_pawxc ] [ Functions ]
NAME
pawxc_get_xclevel
FUNCTION
Give the eXchange-Correlation "level" (1=LDA, 2=GGA/mGGA, 3=TDDFT)
INPUTS
ixc= choice of exchange-correlation scheme
SOURCE
677 function pawxc_get_xclevel(ixc) 678 !Arguments ------------------------------------ 679 integer,intent(in) :: ixc 680 integer :: pawxc_get_xclevel 681 682 ! ************************************************************************* 683 684 pawxc_get_xclevel=0 685 686 !ABINIT 687 if ((1<=ixc.and.ixc<=10).or.(30<=ixc.and.ixc<=39).or.(ixc==50)) pawxc_get_xclevel=1 ! ABINIT LDA 688 if ((11<=ixc.and.ixc<=19).or.(23<=ixc.and.ixc<=29).or.ixc==1402000) pawxc_get_xclevel=2 ! ABINIT GGA 689 if (20<=ixc.and.ixc<=22) pawxc_get_xclevel=3 ! ABINIT TDDFT kernel tests 690 if (ixc>=31.and.ixc<=35) pawxc_get_xclevel=2 ! ABINIT internal fake mGGA 691 if (ixc>=41.and.ixc<=42) pawxc_get_xclevel=2 ! ABINIT internal hybrids using GGA 692 693 !LibXC functionals 694 if (ixc<0) then 695 pawxc_get_xclevel=1 696 if (libxc_functionals_isgga()) pawxc_get_xclevel=2 697 if (libxc_functionals_ismgga()) pawxc_get_xclevel=2 698 if (libxc_functionals_is_hybrid()) pawxc_get_xclevel=2 699 end if 700 701 end function pawxc_get_xclevel
m_pawxc/pawxc_is_tb09 [ Functions ]
[ Top ] [ m_pawxc ] [ Functions ]
NAME
pawxc_is_tb09
FUNCTION
Check if the XC functional is Tran-Blaha 09 (modified BJ)
INPUTS
ixc= choice of exchange-correlation scheme
SOURCE
780 function pawxc_is_tb09(ixc) 781 !Arguments ------------------------------------ 782 integer,intent(in) :: ixc 783 logical :: pawxc_is_tb09 784 785 ! ************************************************************************* 786 787 pawxc_is_tb09=.false. 788 if (ixc<0) then 789 pawxc_is_tb09 = libxc_functionals_is_tb09() 790 end if 791 792 end function pawxc_is_tb09
m_pawxc/pawxc_mkdenpos_wrapper [ Functions ]
[ Top ] [ m_pawxc ] [ Functions ]
NAME
pawxc_mkdenpos_wrapper
FUNCTION
Make a density positive everywhere : when the density (or spin-density) is smaller than xc_denpos, set it to the value of xc_denpos
INPUTS
nfft=(effective) number of FFT grid points (for this processor)
nspden=number of spin-density components (max. 2)
option=0 if density rhonow is stored as (up,dn)
1 if density rhonow is stored as (up+dn,up)
Active only when nspden=2
xc_denpos= lowest allowed density (usually for the computation of the XC functionals)
OUTPUT
SIDE EFFECTS
Input/output
iwarn=At input: iwarn=0 a warning will be printed when rho is negative
iwarn>0 no warning will be printed out
At output: iwarn is increased by 1
rhonow(nfft,nspden)=electron (spin)-density in real space,
either on the unshifted grid (if ishift==0,
then equal to rhor),or on the shifted grid
SOURCE
531 subroutine pawxc_mkdenpos_wrapper(iwarn,nfft,nspden,option,rhonow,xc_denpos) 532 533 !Arguments ------------------------------------ 534 !scalars 535 integer,intent(in) :: nfft,nspden,option 536 integer,intent(inout) :: iwarn 537 real(dp),intent(in) :: xc_denpos 538 !arrays 539 real(dp),intent(inout) :: rhonow(nfft,nspden) 540 541 ! ************************************************************************* 542 543 #if defined HAVE_LIBPAW_ABINIT 544 call mkdenpos(iwarn,nfft,nspden,option,rhonow,xc_denpos) 545 #else 546 call pawxc_mkdenpos_local() 547 #endif
m_pawxc/pawxc_rotate_back_mag [ Functions ]
[ Top ] [ m_pawxc ] [ Functions ]
NAME
pawxc_rotate_back_mag
FUNCTION
Rotate back a collinear XC potential (stored as up+dn) with respect to
a magnetization and give a non-collinear XC potential
(stored as up_up, dn_dn, Re{up_dn}, Im{up_dn}).
INPUTS
vxc_in(vectsize,2)=input collinear XC potential mag(vectsize,3)=magnetization used for projection vectsize=size of vector fields
OUTPUT
vxc_out(vectsize,4)=output non-collinear XC potential
SOURCE
6059 subroutine pawxc_rotate_back_mag(vxc_in,vxc_out,mag,vectsize) 6060 6061 !Arguments ------------------------------------ 6062 !scalars 6063 integer,intent(in) :: vectsize 6064 !arrays 6065 real(dp),intent(in) :: vxc_in(vectsize,2),mag(vectsize,3) 6066 real(dp),intent(out) :: vxc_out(vectsize,4) 6067 6068 !Local variables------------------------------- 6069 !scalars 6070 #if ! defined HAVE_LIBPAW_ABINIT 6071 integer :: ipt 6072 real(dp),parameter :: m_norm_min=tol8 6073 real(dp) :: dvdn,dvdz,m_norm 6074 #endif 6075 !arrays 6076 6077 ! ************************************************************************* 6078 6079 !One could add here a section for other codes (i.e. BigDFT, ...) 6080 #if defined HAVE_LIBPAW_ABINIT 6081 call rotate_back_mag(vxc_in,vxc_out,mag,vectsize) 6082 #else 6083 do ipt=1,vectsize 6084 m_norm=sqrt(mag(ipt,1)**2+mag(ipt,2)**2+mag(ipt,3)**2) 6085 dvdn=half*(vxc_in(ipt,1)+vxc_in(ipt,2)) 6086 if (m_norm>m_norm_min) then 6087 dvdz=half*(vxc_in(ipt,1)-vxc_in(ipt,2))/m_norm 6088 vxc_out(ipt,1)=dvdn+mag(ipt,3)*dvdz 6089 vxc_out(ipt,2)=dvdn-mag(ipt,3)*dvdz 6090 vxc_out(ipt,3)= mag(ipt,1)*dvdz 6091 vxc_out(ipt,4)=-mag(ipt,2)*dvdz 6092 else 6093 vxc_out(ipt,1:2)=dvdn 6094 vxc_out(ipt,3:4)=zero 6095 end if 6096 end do 6097 #endif 6098 6099 end subroutine pawxc_rotate_back_mag
m_pawxc/pawxc_rotate_back_mag_dfpt [ Functions ]
[ Top ] [ m_pawxc ] [ Functions ]
NAME
pawxc_rotate_back_mag_dfpt
FUNCTION
Rotate back a 1st-order collinear XC potential (stored as up+dn) with respect to
a magnetization and give a 1st-order non-collinear XC potential
(stored as up_up, dn_dn, Re{up_dn}, Im{up_dn}).
INPUTS
mag(vectsize,3)=0-order magnetization used for projection rho1(vectsize,4)=1st-order non-collinear density and magnetization vxc(vectsize,4)=0-order non-collinear XC potential kxc(vectsize,nkxc)=0-order XC kernel (associated to vxc) vxc1_in(vectsize,2)=input 1st-order collinear XC potential vectsize=size of vector fields
OUTPUT
vxc1_out(vectsize,4)=output 1st-order non-collinear XC potential
SOURCE
6126 subroutine pawxc_rotate_back_mag_dfpt(vxc1_in,vxc1_out,vxc,kxc,rho1,mag,vectsize) 6127 6128 !Arguments ------------------------------------ 6129 !scalars 6130 integer,intent(in) :: vectsize 6131 !arrays 6132 real(dp),intent(in) :: kxc(:,:),mag(vectsize,3),rho1(vectsize,4) 6133 real(dp),intent(in) :: vxc(vectsize,4),vxc1_in(vectsize,2) 6134 real(dp),intent(out) :: vxc1_out(vectsize,4) 6135 6136 !Local variables------------------------------- 6137 !scalars 6138 #if ! defined HAVE_LIBPAW_ABINIT 6139 character(len=100) :: msg 6140 #endif 6141 !arrays 6142 6143 ! ************************************************************************* 6144 6145 !One could add here a section for other codes (i.e. BigDFT, ...) 6146 #if defined HAVE_LIBPAW_ABINIT 6147 call rotate_back_mag_dfpt(1,vxc1_in,vxc1_out,vxc,kxc,rho1,mag,vectsize,1) 6148 #else 6149 msg='[LIBPAW] Non-collinear DFPT not available (only in ABINIT)!' 6150 LIBPAW_ERROR(msg) 6151 #endif 6152 6153 end subroutine pawxc_rotate_back_mag_dfpt
m_pawxc/pawxc_rotate_mag [ Functions ]
[ Top ] [ m_pawxc ] [ Functions ]
NAME
pawxc_rotate_mag
FUNCTION
Project (rotate) a non-collinear density (stored as density+magn.) on a magnetization and give a collinear density (stored as [up,dn] or [up+dn,up]).
INPUTS
rho_in(vectsize,4)=input non-collinear density and magnetization
mag(vectsize,3)=magnetization used for projection
vectsize=size of vector fields
[rho_out_format]= 1=rho_out is stored as [up,dn]
2=rho_out is stored as [up+dn,up]
Default=1
OUTPUT
rho_out(vectsize,2)=output (projected, collinear) density [mag_norm_out(vectsize)]= --optional-- norm of mag(:) at each point of the grid
SOURCE
5975 subroutine pawxc_rotate_mag(rho_in,rho_out,mag,vectsize,mag_norm_out,rho_out_format) 5976 5977 !Arguments ------------------------------------ 5978 !scalars 5979 integer,intent(in) :: vectsize 5980 integer,intent(in),optional :: rho_out_format 5981 !arrays 5982 real(dp),intent(in) :: rho_in(vectsize,4),mag(vectsize,3) 5983 real(dp),intent(out) :: rho_out(vectsize,2) 5984 real(dp),intent(out),optional :: mag_norm_out(vectsize) 5985 5986 !Local variables------------------------------- 5987 !scalars 5988 #if ! defined HAVE_LIBPAW_ABINIT 5989 integer :: ipt 5990 real(dp),parameter :: m_norm_min=tol8 5991 real(dp) :: m_norm,rhoin_dot_mag,rho_up 5992 #endif 5993 !arrays 5994 5995 ! ************************************************************************* 5996 5997 !One could add here a section for other codes (i.e. BigDFT, ...) 5998 #if defined HAVE_LIBPAW_ABINIT 5999 if (present(rho_out_format).and.present(mag_norm_out)) then 6000 call rotate_mag(rho_in,rho_out,mag,vectsize,1, & 6001 & rho_out_format=rho_out_format,mag_norm_out=mag_norm_out) 6002 else if (present(rho_out_format).and..not.present(mag_norm_out)) then 6003 call rotate_mag(rho_in,rho_out,mag,vectsize,1,rho_out_format=rho_out_format) 6004 else if (.not.present(rho_out_format).and.present(mag_norm_out)) then 6005 call rotate_mag(rho_in,rho_out,mag,vectsize,1,mag_norm_out=mag_norm_out) 6006 else 6007 call rotate_mag(rho_in,rho_out,mag,vectsize,1) 6008 end if 6009 #else 6010 do ipt=1,vectsize 6011 m_norm=sqrt(mag(ipt,1)**2+mag(ipt,2)**2+mag(ipt,3)**2) 6012 rhoin_dot_mag=rho_in(ipt,2)*mag(ipt,1)+rho_in(ipt,3)*mag(ipt,2) & 6013 & +rho_in(ipt,4)*mag(ipt,3) 6014 if(m_norm>m_norm_min)then 6015 rho_out(ipt,1)=half*(rho_in(ipt,1)+rhoin_dot_mag/m_norm) 6016 rho_out(ipt,2)=half*(rho_in(ipt,1)-rhoin_dot_mag/m_norm) 6017 else 6018 rho_out(ipt,1)=half*rho_in(ipt,1) 6019 rho_out(ipt,2)=half*rho_in(ipt,1) 6020 end if 6021 if (present(mag_norm_out).and.m_norm> m_norm_min) mag_norm_out(ipt)=m_norm 6022 if (present(mag_norm_out).and.m_norm<=m_norm_min) mag_norm_out(ipt)=zero 6023 end do 6024 if (present(rho_out_format)) then 6025 if (rho_out_format==2) then 6026 do ipt=1,vectsize 6027 rho_up=rho_out(ipt,1) 6028 rho_out(ipt,1)=rho_up+rho_out(ipt,2) 6029 rho_out(ipt,2)=rho_up 6030 end do 6031 end if 6032 end if 6033 #endif 6034 6035 end subroutine pawxc_rotate_mag
m_pawxc/pawxc_size_dvxc_wrapper [ Functions ]
[ Top ] [ m_pawxc ] [ Functions ]
NAME
pawxc_size_dvxc_wrapper
FUNCTION
Give the sizes of the several arrays involved in exchange-correlation calculation needed to allocated them for the drivexc routine
INPUTS
ixc= choice of exchange-correlation scheme order= gives the maximal derivative of Exc computed. 1=usual value (return exc and vxc) 2=also computes the kernel (return exc,vxc,kxc) -2=like 2, except (to be described) 3=also computes the derivative of the kernel (return exc,vxc,kxc,k3xc) nspden= number of spin components [xc_funcs(2)]= <type(libxc_functional_type)> [add_tfw]= optional flag controling the addition of Weiszacker gradient correction to Thomas-Fermi XC energy
OUTPUT
--- All optionals [usegradient]= [flag] 1 if the XC functional needs the gradient of the density (grho2_updn) [uselaplacian]= [flag] 1 if the XC functional needs the laplacian of the density (lrho_updn) [usekden]= [flag] 1 if the XC functional needs the kinetic energy density (lrho_updn) [nvxcgrho]= size of the array dvxcdgr(npts,nvxcgrho) (derivative of Exc wrt to gradient) [nvxclrho]= size of the array dvxclpl(npts,nvxclrho) (derivative of Exc wrt to laplacian) [nvxctau]= size of the array dvxctau(npts,nvxctau) (derivative of Exc wrt to kin. ener. density) [ndvxc]= size of the array dvxc(npts,ndvxc) (second derivatives of Exc wrt to density and gradient) [nd2vxc]= size of the array d2vxc(npts,nd2vxc) (third derivatives of Exc wrt density)
SOURCE
251 subroutine pawxc_size_dvxc_wrapper(ixc,order,nspden,& 252 & usegradient,uselaplacian,usekden,& 253 & nvxcgrho,nvxclrho,nvxctau,ndvxc,nd2vxc) 254 255 !Arguments---------------------- 256 integer,intent(in) :: ixc,nspden,order 257 integer,intent(out),optional :: nvxcgrho,nvxclrho,nvxctau,ndvxc,nd2vxc 258 integer,intent(out),optional :: usegradient,uselaplacian,usekden 259 !Local variables---------------- 260 integer :: nvxcgrho_,nvxclrho_,nvxctau_,ndvxc_,nd2vxc_ 261 integer :: usegradient_,uselaplacian_,usekden_ 262 263 ! ************************************************************************* 264 265 #if defined HAVE_LIBPAW_ABINIT 266 call size_dvxc(ixc,order,nspden,& 267 & usegradient=usegradient_,uselaplacian=uselaplacian_,usekden=usekden_,& 268 nvxcgrho=nvxcgrho_,nvxclrho=nvxclrho_,nvxctau=nvxctau_,& 269 & ndvxc=ndvxc_,nd2vxc=nd2vxc_) 270 #else 271 call pawxc_size_dvxc_local() 272 #endif 273 if (present(usegradient)) usegradient=usegradient_ 274 if (present(uselaplacian)) uselaplacian=uselaplacian_ 275 if (present(usekden)) usekden=usekden_ 276 if (present(nvxcgrho)) nvxcgrho=nvxcgrho_ 277 if (present(nvxclrho)) nvxclrho=nvxclrho_ 278 if (present(nvxctau)) nvxctau=nvxctau_ 279 if (present(ndvxc)) ndvxc=ndvxc_ 280 if (present(nd2vxc)) nd2vxc=nd2vxc_
m_pawxc/pawxc_xcmult_wrapper [ Functions ]
[ Top ] [ m_pawxc ] [ Functions ]
NAME
pawxc_xcmult_wrapper
FUNCTION
In the case of GGA, multiply the different gradient of spin-density by the derivative of the XC functional with respect to the norm of the gradient, then divide it by the norm of the gradient
INPUTS
depsxc(nfft,nspgrad)=derivative of Exc with respect to the (spin-)density,
or to the norm of the gradient of the (spin-)density,
further divided by the norm of the gradient of the (spin-)density
The different components of depsxc will be
for nspden=1, depsxc(:,1)=d(rho.exc)/d(rho)
and if ngrad=2, depsxc(:,2)=1/2*1/|grad rho_up|*d(rho.exc)/d(|grad rho_up|)
+ 1/|grad rho|*d(rho.exc)/d(|grad rho|)
(do not forget : |grad rho| /= |grad rho_up| + |grad rho_down|
for nspden=2, depsxc(:,1)=d(rho.exc)/d(rho_up)
depsxc(:,2)=d(rho.exc)/d(rho_down)
and if ngrad=2, depsxc(:,3)=1/|grad rho_up|*d(rho.exc)/d(|grad rho_up|)
depsxc(:,4)=1/|grad rho_down|*d(rho.exc)/d(|grad rho_down|)
depsxc(:,5)=1/|grad rho|*d(rho.exc)/d(|grad rho|)
nfft=(effective) number of FFT grid points (for this processor)
ngrad = must be 2
nspden=number of spin-density components
nspgrad=number of spin-density and spin-density-gradient components
OUTPUT
(see side effects)
SIDE EFFECTS
rhonow(nfft,nspden,ngrad*ngrad)=
at input :
electron (spin)-density in real space and its gradient,
either on the unshifted grid (if ishift==0,
then equal to rhor), or on the shifted grid
rhonow(:,:,1)=electron density in electrons/bohr**3
rhonow(:,:,2:4)=gradient of electron density in el./bohr**4
at output :
rhonow(:,:,2:4) has been multiplied by the proper factor,
described above.
SOURCE
433 subroutine pawxc_xcmult_wrapper(depsxc,nfft,ngrad,nspden,nspgrad,rhonow) 434 435 !Arguments ------------------------------------ 436 !scalars 437 integer,intent(in) :: nfft,ngrad,nspden,nspgrad 438 !arrays 439 real(dp),intent(in) :: depsxc(nfft,nspgrad) 440 real(dp),intent(inout) :: rhonow(nfft,nspden,ngrad*ngrad) 441 442 ! ************************************************************************* 443 444 #if defined HAVE_LIBPAW_ABINIT 445 call xcmult(depsxc,nfft,ngrad,nspden,nspgrad,rhonow) 446 #else 447 call pawxc_xcmult_local() 448 #endif
m_pawxc/pawxc_xcpositron_wrapper [ Functions ]
[ Top ] [ m_pawxc ] [ Functions ]
NAME
pawxc_xcpositron_wrapper
FUNCTION
Compute electron-positron correlation potentials and energy density. Used electron-positron correlation functional is controlled by ipawxc_xcpositron_wrapper argument. Returns Fxc, Vxc_pos, Vxc_el from input rhor_pos and rhor_el for positron and electrons.
INPUTS
grhoe2(ngr)=square of the gradient of electronic density rhoe (needed for GGA)
ixcpositron=type of electron-positron correlation functional:
1 or -1: LDA zero positron density limit parametrized by Arponen & Pajanne
and provided by Boronski & Nieminen [1,2]
11: LDA zero positron density limit parametrized by Arponen & Pajanne
and fitted by Sterne & Kaiser [1,3]
2: LDA electron-positron correlation
provided by Puska, Seitsonen, and Nieminen [1,4]
3: GGA zero positron density limit parametrized by Arponen & Pajanne
and provided by Boronski & Nieminen [1,2,5]
31: GGA zero positron density limit parametrized by Arponen & Pajanne
and fitted by Sterne & Kaiser [1,3,5]
See references below
ngr=size of grho2 array (0 if LDA, npt if GGA)
npt=number of real space points on which density is provided
posdensity0_limit=True if we are in the zero positron density limit
rhoer(npt)=electron density (bohr^-3)
rhopr(npt)=positron density (bohr^-3)
OUTPUT
fnxc(npt)=correlation energy per unit volume fxc vxce(npt)=correlation potential for electron dfxc/drhoe (hartree) vxcp(npt)=correlation potential for positron dfxc/drhop (hartree) vxcegr(ngr)= 1/|gradRhoe| dfxc/d|gradRhoe| (empty if LDA, i.e. ngr=0) Optional outputs: dvxce(npt)=partial second derivatives of the xc energy wr to the electronic density dvxce(:)=dVxce/dRhoe dvxcp(npt)=partial second derivatives of the xc energy wr to the positronic density dvxcp(:)=dVxcp/drhop
NOTES
References for electron-positron correlation functionals:
[1] J. Arponen and E. Pajanne, Ann. Phys. (N.Y.) 121, 343 (1979) [[cite:Arponen1979a]].
[2] E. Boronski and R.M. Nieminen, Phys. Rev. B 34, 3820 (1986) [[cite:Boronski1986]].
[3] P.A. Sterne and J.H. Kaiser, Phys. Rev. B 43, 13892 (1991) [[cite:Sterne1991]].
[4] M.J. Puska, A.P. Seitsonen and R.M. Nieminen, Phys. Rev. B 52, 10947 (1994) [[cite:Puska1994]].
[5] B. Barbiellini, M.J. Puska, T. Torsti and R.M.Nieminen, Phys. Rev. B 51, 7341 (1995) [[cite:Barbiellini1995]]
SOURCE
134 subroutine pawxc_xcpositron_wrapper(fnxc,grhoe2,ixcpositron,ngr,npt,posdensity0_limit,& 135 & rhoer,rhopr,vxce,vxcegr,vxcp,& 136 & dvxce,dvxcp) ! optional arguments 137 138 !Arguments ------------------------------------ 139 !scalars 140 integer,intent(in) :: ixcpositron,ngr,npt 141 logical,intent(in) :: posdensity0_limit 142 !arrays 143 real(dp),intent(in) :: grhoe2(ngr),rhoer(npt),rhopr(npt) 144 real(dp),intent(out) :: fnxc(npt),vxce(npt),vxcegr(ngr),vxcp(npt) 145 real(dp),intent(out),optional :: dvxce(npt),dvxcp(npt) 146 147 !Local variables------------------------------- 148 149 ! ************************************************************************* 150 151 #if defined HAVE_LIBPAW_ABINIT 152 call pawxc_xcpositron_abinit() 153 #else 154 call pawxc_xcpositron_local() 155 #endif
m_pawxc/pawxcm [ Functions ]
[ Top ] [ m_pawxc ] [ Functions ]
NAME
pawxcm
FUNCTION
Start from the density or spin-density, and compute xc correlation potential and energies inside a paw sphere. LDA+GGA - USE A DEVELOPMENT OF THE DENSITY OVER (L,M) MOMENTS Driver of XC functionals.
INPUTS
corexc(nrad)=core density on radial grid exexch= choice of <<<local>>> exact exchange. Active if exexch=3 (only for PBE) ixc= choice of exchange-correlation scheme lm_size=size of density array rhor (see below) lmselect(lm_size)=select the non-zero LM-moments of input density rhor nhat(nrad,lm_size,nspden)=compensation density (total in 1st half and spin-up in 2nd half if nspden=2) nkxc=second dimension of the kxc array. If /=0, the exchange-correlation kernel must be computed non_magnetic_xc= if true, handle density/potential as non-magnetic (even if it is) nrad=size of radial mesh for densities/potentials (might be different from pawrad%mesh_size) nspden=number of spin-density components option=0 compute both XC energies (direct+double-counting) and potential (and Kernel) 1 compute only XC potential (and Kernel) 2 compute only XC energies (direct+double-counting) 3 compute only XC energy by direct scheme 4 compute only XC energy by direct scheme for spherical part of the density 5 compute only XC potential (and Kernel) for spherical part of the density pawang <type(pawang_type)>=paw angular mesh and related data pawrad <type(pawrad_type)>=paw radial mesh and related data pawxcdev=order of Vxc development rhor(nrad,lm_size,nspden)=electron density in real space in electrons/bohr**3 (total in 1st half and spin-up in 2nd half if nspden=2) usecore= 1 if core density has to be used in Exc/Vxc ; 0 otherwise usexcnhat= 0 if compensation density does not have to be used 1 if compensation density has to be used in double counting energy term only 2 if compensation density (nhat) has to be used in Exc/Vxc and double counting energy term xclevel= XC functional level xc_denpos= lowest allowed density (usually for the computation of the XC functionals)
OUTPUT
== if option==0, 2, 3, or 4 ==
enxc=returned exchange and correlation energy (hartree)
== if option==0 or 2 ==
enxcdc=returned exchange-cor. contribution to double-counting energy
== if option==0 or 1 ==
vxc(nrad,lm_size,nspden)=xc potential
(spin up in 1st half and spin-down in 2nd half if nspden=2)
== if nkxc>0 ==
kxc(nrad,lm_size,nkxc)=xc kernel (see notes below for nkxc)
== For the TB09 XC functional (modified Becke-Johnson)
[grho1_over_rho1]=Integral of |Grad(rho^1)|/rho^1 over the augmentation region
Used to compute the c parameter of the TB09 XC functional
WARNING: NOT YET IMPLEMENTED!
NOTES
Content of Kxc array:
===== if LDA
if nspden==1: kxc(:,1)= d2Exc/drho2
(kxc(:,2)= d2Exc/drho_up drho_dn)
if nspden>=2: kxc(:,1)= d2Exc/drho_up drho_up
kxc(:,2)= d2Exc/drho_up drho_dn
kxc(:,3)= d2Exc/drho_dn drho_dn
if nspden==4: kxc(:,4:6)= (m_x, m_y, m_z) (magnetization)
===== if GGA
if nspden==1:
kxc(:,1)= d2Exc/drho2
kxc(:,2)= 1/|grad(rho)| dExc/d|grad(rho)|
kxc(:,3)= 1/|grad(rho)| d2Exc/d|grad(rho)| drho
kxc(:,4)= 1/|grad(rho)| * d/d|grad(rho)| ( 1/|grad(rho)| dExc/d|grad(rho)| )
kxc(:,5)= gradx(rho)
kxc(:,6)= grady(rho)
kxc(:,7)= gradz(rho)
if nspden>=2:
kxc(:,1)= d2Exc/drho_up drho_up
kxc(:,2)= d2Exc/drho_up drho_dn
kxc(:,3)= d2Exc/drho_dn drho_dn
kxc(:,4)= 1/|grad(rho_up)| dEx/d|grad(rho_up)|
kxc(:,5)= 1/|grad(rho_dn)| dEx/d|grad(rho_dn)|
kxc(:,6)= 1/|grad(rho_up)| d2Ex/d|grad(rho_up)| drho_up
kxc(:,7)= 1/|grad(rho_dn)| d2Ex/d|grad(rho_dn)| drho_dn
kxc(:,8)= 1/|grad(rho_up)| * d/d|grad(rho_up)| ( 1/|grad(rho_up)| dEx/d|grad(rho_up)| )
kxc(:,9)= 1/|grad(rho_dn)| * d/d|grad(rho_dn)| ( 1/|grad(rho_dn)| dEx/d|grad(rho_dn)| )
kxc(:,10)=1/|grad(rho)| dEc/d|grad(rho)|
kxc(:,11)=1/|grad(rho)| d2Ec/d|grad(rho)| drho_up
kxc(:,12)=1/|grad(rho)| d2Ec/d|grad(rho)| drho_dn
kxc(:,13)=1/|grad(rho)| * d/d|grad(rho)| ( 1/|grad(rho)| dEc/d|grad(rho)| )
kxc(:,14)=gradx(rho_up)
kxc(:,15)=gradx(rho_dn)
kxc(:,16)=grady(rho_up)
kxc(:,17)=grady(rho_dn)
kxc(:,18)=gradz(rho_up)
kxc(:,19)=gradz(rho_dn)
if nspden==4:
kxc(:,20:22)= (m_x, m_y, m_z) (magnetization)
SOURCE
4048 subroutine pawxcm(corexc,enxc,enxcdc,exexch,hyb_mixing,ixc,kxc,lm_size,lmselect,nhat,nkxc,& 4049 & non_magnetic_xc,nrad,nspden,option,pawang,pawrad,pawxcdev,rhor,& 4050 & usecore,usexcnhat,vxc,xclevel,xc_denpos,grho1_over_rho1) 4051 4052 !Arguments ------------------------------------ 4053 !scalars 4054 integer,intent(in) :: exexch,ixc,lm_size,nkxc,nrad,nspden,option,pawxcdev,usecore 4055 integer,intent(in) :: usexcnhat,xclevel 4056 logical,intent(in) :: non_magnetic_xc 4057 real(dp),intent(in) :: hyb_mixing,xc_denpos 4058 real(dp),intent(out) :: enxc,enxcdc 4059 real(dp),intent(out),optional :: grho1_over_rho1 4060 type(pawang_type),intent(in) :: pawang 4061 type(pawrad_type),intent(in) :: pawrad 4062 !arrays 4063 logical,intent(in) :: lmselect(lm_size) 4064 real(dp),intent(in) :: corexc(nrad) 4065 real(dp),intent(in) :: nhat(nrad,lm_size,nspden*((usexcnhat+1)/2)) 4066 real(dp),intent(in) :: rhor(nrad,lm_size,nspden) 4067 real(dp),intent(out) :: kxc(nrad,lm_size,nkxc) 4068 real(dp),intent(out) :: vxc(nrad,lm_size,nspden) 4069 4070 !Local variables------------------------------- 4071 !scalars 4072 integer :: ilm,ir,ir1,ir2,ispden,iwarn,jr,nspden_updn,nsums 4073 real(dp),parameter :: delta=1.d-4 4074 real(dp) :: dvxc1,dvxc2,dvxc3,dvxc4,dvxca,dvxcb,dvxcc,dvxcd 4075 real(dp) :: fact,invsqfpi,invsqfpi2,sqfpi,sqfpi2,tol_rho 4076 character(len=500) :: msg 4077 !arrays 4078 real(dp),allocatable :: d1kxc(:,:),d2kxc(:,:),d1vxc(:,:),d2vxc(:,:) 4079 real(dp),allocatable :: exc_(:),exci(:),ff(:),gg(:) 4080 real(dp),allocatable :: kxc1(:,:),kxc2(:,:),kxcdn1(:,:),kxcdn2(:,:),kxci(:,:) 4081 real(dp),allocatable :: m_norm_inv(:),rho_(:,:),rhoinv(:,:),rhosph(:,:) 4082 real(dp),allocatable :: v1sum(:,:),v2sum(:,:,:) 4083 real(dp),allocatable :: vxc1(:,:),vxc2(:,:),vxcdn1(:,:),vxcdn2(:,:),vxci(:,:) 4084 real(dp),allocatable,target :: rho_nc(:,:),rho_updn(:,:,:),vxc_diag(:,:),vxc_nc(:,:) 4085 real(dp), LIBPAW_CONTIGUOUS pointer :: mag_nc(:,:),rho_dn(:,:),rho_up(:,:) 4086 4087 !************************************************************************ 4088 4089 if(nkxc>3) then 4090 msg='Kxc not implemented for GGA! Use pawxcdev 0 ' 4091 LIBPAW_ERROR(msg) 4092 end if 4093 if(nkxc>0.and.nspden==4) then 4094 msg='Kxc not implemented for non-collinear magnetism!' 4095 LIBPAW_ERROR(msg) 4096 end if 4097 if (option/=1.and.option/=5) then 4098 if (nrad<pawrad%int_meshsz) then 4099 msg='When option=0,2,3,4, nrad must be greater than pawrad%int_meshsz!' 4100 LIBPAW_BUG(msg) 4101 end if 4102 end if 4103 #if defined LIBPAW_HAVE_LIBXC 4104 if (present(grho1_over_rho1).and.option<4.and.ixc<0) then 4105 if (libxc_functionals_is_tb09()) then 4106 msg='TB09 (mBJ) XC functional not yet implemented for pawxcdev/=0!' 4107 LIBPAW_ERROR(msg) 4108 end if 4109 end if 4110 #endif 4111 4112 !---------------------------------------------------------------------- 4113 !----- Initializations 4114 !---------------------------------------------------------------------- 4115 4116 !Arrays dimensions and constants 4117 iwarn=0 4118 nspden_updn=min(nspden,2) 4119 sqfpi=sqrt(four_pi);sqfpi2=half*sqfpi 4120 invsqfpi=one/sqfpi;invsqfpi2=half*invsqfpi 4121 nsums=2*nspden_updn-1 4122 4123 !Initializations of output arrays 4124 if (option/=1.and.option/=5) enxc=zero 4125 if (option==0.or.option==2) enxcdc=zero 4126 if (option/=3.and.option/=4) vxc(:,:,:)=zero 4127 if (nkxc/=0) kxc(:,:,:)=zero 4128 4129 if (xclevel==0.or.ixc==0) then ! No xc at all is applied (usually for testing) 4130 msg='Note that no xc is applied (ixc=0). Returning' 4131 LIBPAW_WARNING(msg) 4132 return 4133 end if 4134 4135 !---------------------------------------------------------------------- 4136 !----- Build several densities 4137 !---------------------------------------------------------------------- 4138 4139 !rho_updn contains the effective density used for XC 4140 !with core density and/or compensation density eventually included 4141 !----------------------------------------------------------------- 4142 4143 LIBPAW_ALLOCATE(rho_updn,(nrad,lm_size,nspden)) 4144 rho_updn(:,:,:)=rhor(:,:,:) 4145 if (usexcnhat==2) rho_updn(:,:,:)=rho_updn(:,:,:)+nhat(:,:,:) 4146 4147 !Optionally suppressed magnetic part 4148 if(non_magnetic_xc) then 4149 if(nspden==2) rho_updn(:,:,2)=rho_updn(:,:,1)*half 4150 if(nspden==4) rho_updn(:,:,2:4)=zero 4151 endif 4152 4153 !Add core density 4154 if (usecore==1) then 4155 if (nspden==1.or.nspden==4) then 4156 rho_updn(:,1,1)=rho_updn(:,1,1)+sqfpi*corexc(:) 4157 else if (nspden==2) then 4158 rho_updn(:,1,1)=rho_updn(:,1,1)+sqfpi*corexc(:) 4159 rho_updn(:,1,2)=rho_updn(:,1,2)+sqfpi2*corexc(:) 4160 end if 4161 end if 4162 4163 !In case of collinear magnetism, separate up and down contributions 4164 if (nspden==2) then 4165 LIBPAW_ALLOCATE(ff,(nrad)) 4166 do ilm=1,lm_size 4167 ff(:)=rho_updn(:,ilm,2) 4168 rho_updn(:,ilm,2)=rho_updn(:,ilm,1)-ff(:) 4169 rho_updn(:,ilm,1)=ff(:) 4170 end do 4171 LIBPAW_DEALLOCATE(ff) 4172 end if 4173 4174 !Direct links to rho_up and rho_dn 4175 rho_up => rho_updn(:,:,1) 4176 rho_dn => rho_updn(:,:,nspden_updn) 4177 4178 !rhoSPH contains the spherical part of effective density 4179 !(including Y00 spherical harmonic) 4180 !----------------------------------------------------------------- 4181 LIBPAW_ALLOCATE(rhosph,(nrad,nspden_updn)) 4182 4183 ! Non-magnetic system: rhoSPH(;,1)=(1/2).rhoSPH_total 4184 if (nspden==1) then 4185 rhosph(:,1)=rho_updn(:,1,1)*invsqfpi2 4186 4187 ! Collinear magnetism: rhoSPH = (rhoSPH_up, rhoSPH_dn) 4188 else if (nspden==2) then 4189 rhosph(:,1:2)=rho_updn(:,1,1:2)*invsqfpi 4190 4191 ! Non-collinear magnetism: rhoSPH = (rhoSPH_up, rhoSPH_dn) 4192 ! obtained by rotating rho_updn 4193 else if (nspden==4) then 4194 LIBPAW_ALLOCATE(m_norm_inv,(nrad)) 4195 LIBPAW_ALLOCATE(rho_nc,(nrad,nspden)) 4196 do ispden=1,nspden 4197 rho_nc(1:nrad,ispden)=rho_updn(1:nrad,1,ispden)*invsqfpi 4198 end do 4199 mag_nc => rho_nc(:,2:4) 4200 call pawxc_rotate_mag(rho_nc,rhosph,mag_nc,nrad,mag_norm_out=m_norm_inv) 4201 do ir=1,nrad 4202 m_norm_inv(ir)=merge(invsqfpi/m_norm_inv(ir),zero,m_norm_inv(ir)>rho_min) 4203 end do 4204 end if 4205 4206 !Make spherical density positive 4207 call pawxc_mkdenpos_wrapper(iwarn,nrad,nspden_updn,0,rhosph,xc_denpos) 4208 4209 !---------------------------------------------------------------------- 4210 !----- Compute Exc(rhoSPH) and Vxc(rhoSPH) 4211 !---------------------------------------------------------------------- 4212 4213 LIBPAW_ALLOCATE(exci,(nrad)) 4214 LIBPAW_ALLOCATE(vxci,(nrad,nspden_updn)) 4215 LIBPAW_ALLOCATE(kxci,(nrad,nkxc)) 4216 call pawxcsph(exci,exexch,hyb_mixing,ixc,kxci,nkxc,nrad,nspden_updn,pawrad,rhosph,vxci,xclevel) 4217 4218 !---------------------------------------------------------------------- 4219 !----- Compute numerical derivatives of Vxc,Kxc (by finite diff. scheme) 4220 !---------------------------------------------------------------------- 4221 4222 if (option/=4.and.option/=5) then 4223 LIBPAW_ALLOCATE(exc_,(nrad)) 4224 LIBPAW_ALLOCATE(rho_,(nrad,nspden_updn)) 4225 4226 if (nspden_updn==2) rho_(:,2)=rhosph(:,2) 4227 4228 ! Compute Exc, Vxc for rho+delta_rho 4229 LIBPAW_ALLOCATE(vxc1,(nrad,nspden_updn)) 4230 LIBPAW_ALLOCATE(kxc1,(nrad,nkxc)) 4231 rho_(:,1)=(one+delta)*rhosph(:,1) 4232 call pawxcsph(exc_,exexch,hyb_mixing,ixc,kxc1,nkxc,nrad,nspden_updn,pawrad,rho_,vxc1,xclevel) 4233 4234 ! Compute Exc, Vxc for rho-delta_rho 4235 LIBPAW_ALLOCATE(vxc2,(nrad,nspden_updn)) 4236 LIBPAW_ALLOCATE(kxc2,(nrad,nkxc)) 4237 rho_(:,1)=(one-delta)*rhosph(:,1) 4238 call pawxcsph(exc_,exexch,hyb_mixing,ixc,kxc2,nkxc,nrad,nspden_updn,pawrad,rho_,vxc2,xclevel) 4239 4240 ! Additional terms for spin-polarized systems 4241 if (nspden_updn==2) then 4242 rho_(:,1)=rhosph(:,1) 4243 4244 ! Compute Exc, Vxc for rho+delta_rho_down 4245 LIBPAW_ALLOCATE(vxcdn1,(nrad,nspden_updn)) 4246 LIBPAW_ALLOCATE(kxcdn1,(nrad,nkxc)) 4247 rho_(:,2)=(one+delta)*rhosph(:,2) 4248 call pawxcsph(exc_,exexch,hyb_mixing,ixc,kxcdn1,nkxc,nrad,nspden_updn,pawrad,rho_,vxcdn1,xclevel) 4249 4250 ! Compute Exc, Vxc for rho-delta_rho_down 4251 LIBPAW_ALLOCATE(vxcdn2,(nrad,nspden_updn)) 4252 LIBPAW_ALLOCATE(kxcdn2,(nrad,nkxc)) 4253 rho_(:,2)=(one-delta)*rhosph(:,2) 4254 call pawxcsph(exc_,exexch,hyb_mixing,ixc,kxcdn2,nkxc,nrad,nspden_updn,pawrad,rho_,vxcdn2,xclevel) 4255 4256 end if !nspden_updn==2 4257 LIBPAW_DEALLOCATE(exc_) 4258 LIBPAW_DEALLOCATE(rho_) 4259 4260 ! Store inverse of density finite step 4261 LIBPAW_ALLOCATE(rhoinv,(nrad,nspden_updn)) 4262 fact=one/delta;if (nspden_updn==1) fact=half*fact 4263 do ispden=1,nspden_updn 4264 do ir=1,nrad 4265 if (rhosph(ir,ispden)>rho_min) then 4266 rhoinv(ir,ispden)=fact/rhosph(ir,ispden) 4267 else 4268 rhoinv(ir,ispden)=zero 4269 end if 4270 end do 4271 end do 4272 4273 ! Compute numerical first derivatives of Vxc (by finite difference scheme) 4274 LIBPAW_ALLOCATE(d1vxc,(nrad,2*nspden_updn-1)) 4275 ! Non-magnetic system: compute dVxc/dn 4276 if (nspden==1) then 4277 d1vxc(1:nrad,1)=(vxc1(1:nrad,1)-vxc2(1:nrad,1))*half*rhoinv(1:nrad,1) 4278 ! Collinear magnetism: compute dVxc_up/dn_up,dVxc_dn/dn_up,dVxc_dn/dn_dn 4279 else if (nspden==2) then 4280 d1vxc(1:nrad,1)=(vxc1(1:nrad,1)-vxc2(1:nrad,1))*half*rhoinv(1:nrad,1) 4281 d1vxc(1:nrad,2)=(vxc1(1:nrad,2)-vxc2(1:nrad,2))*half*rhoinv(1:nrad,1) 4282 d1vxc(1:nrad,3)=(vxcdn1(1:nrad,2)-vxcdn2(1:nrad,2))*half*rhoinv(1:nrad,2) 4283 ! Non-collinear magnetism: compute 1/2 d(Vxc_up+Vxc_dn)/dn,1/2 d(Vxc_up-Vxc_dn)/dn 4284 ! 1/2 d(Vxc_up-Vxc_dn)/dm 4285 else if (nspden==4) then 4286 do ir=1,nrad 4287 fact=half*rhoinv(ir,1) 4288 dvxc1=(vxc1 (ir,1)-vxc2 (ir,1))*fact !dVxc_up/dn_up 4289 dvxc2=(vxc1 (ir,2)-vxc2 (ir,2))*fact !dVxc_dn/dn_up 4290 fact=half*rhoinv(ir,2) 4291 dvxc3=(vxcdn1(ir,2)-vxcdn2(ir,2))*fact !dVxc_dn/dn_dn 4292 dvxca=dvxc1+dvxc3;dvxcb=dvxc1-dvxc3;dvxcc=two*dvxc2 !Temporary terms 4293 d1vxc(ir,1)=quarter*(dvxca+dvxcc) ! 1/2 d(Vxc_up+Vxc_dn)/dn 4294 d1vxc(ir,2)=quarter* dvxcb ! 1/2 d(Vxc_up-Vxc_dn)/dn 4295 d1vxc(ir,3)=quarter*(dvxca-dvxcc) ! 1/2 d(Vxc_up-Vxc_dn)/dm 4296 end do 4297 end if 4298 4299 ! Compute numerical second derivatives of Vxc (by finite difference scheme) 4300 if (option/=3.or.pawxcdev>=2) then 4301 LIBPAW_ALLOCATE(d2vxc,(nrad,3*nspden_updn-2)) 4302 ! Non-magnetic system: compute d2Vxc/dn2 4303 if (nspden==1) then 4304 d2vxc(1:nrad,1)=(vxc1(1:nrad,1)+vxc2(1:nrad,1)-two*vxci(1:nrad,1))*rhoinv(1:nrad,1)**2 4305 ! Collinear magnetism: compute d2Vxc_up/dn_up2,d2Vxc_dn/dn_up2,d2Vxc_up/dn_dn2,d2Vxc_dn/dn_dn2 4306 else if (nspden==2) then 4307 d2vxc(1:nrad,1)=(vxc1(1:nrad,1)+vxc2(1:nrad,1)-two*vxci(1:nrad,1))*rhoinv(1:nrad,1)**2 4308 d2vxc(1:nrad,2)=(vxc1(1:nrad,2)+vxc2(1:nrad,2)-two*vxci(1:nrad,2))*rhoinv(1:nrad,1)**2 4309 d2vxc(1:nrad,3)=(vxcdn1(1:nrad,1)+vxcdn2(1:nrad,1)-two*vxci(1:nrad,1))*rhoinv(1:nrad,2)**2 4310 d2vxc(1:nrad,4)=(vxcdn1(1:nrad,2)+vxcdn2(1:nrad,2)-two*vxci(1:nrad,2))*rhoinv(1:nrad,2)**2 4311 ! Non-collinear magnetism: compute 1/2 d2(Vxc_up+Vxc_dn)/dn2,1/2 d2(Vxc_up-Vxc_dn)/dn2 4312 ! 1/2 d2(Vxc_up+Vxc_dn)/dm2,1/2 d2(Vxc_up-Vxc_dn)/dm2 4313 else if (nspden==4) then 4314 do ir=1,nrad 4315 fact=rhoinv(ir,1)**2 4316 dvxc1=(vxc1 (ir,1)+vxc2 (ir,1)-two*vxci(ir,1))*fact !d2Vxc_up/dn_up2 4317 dvxc2=(vxc1 (ir,2)+vxc2 (ir,2)-two*vxci(ir,2))*fact !d2Vxc_dn/dn_up2 4318 fact=rhoinv(ir,2)**2 4319 dvxc3=(vxcdn1(ir,1)+vxcdn2(ir,1)-two*vxci(ir,1))*fact !d2Vxc_up/dn_dn2 4320 dvxc4=(vxcdn1(ir,2)+vxcdn2(ir,2)-two*vxci(ir,2))*fact !d2Vxc_dn/dn_dn2 4321 dvxca=dvxc1+dvxc4;dvxcb=dvxc1-dvxc4 !Temporary terms 4322 dvxcc=dvxc2+dvxc3;dvxcd=dvxc2-dvxc3 !Temporary terms 4323 d2vxc(ir,1)=(dvxca+three*dvxcc)/8._dp ! 1/2 d2(Vxc_up+Vxc_dn)/dn2 4324 d2vxc(ir,2)=(dvxcb+dvxcd)/8._dp ! 1/2 d2(Vxc_up-Vxc_dn)/dn2 4325 d2vxc(ir,3)=(dvxca-dvxcc)/8._dp ! 1/2 d2(Vxc_up+Vxc_dn)/dm2 4326 d2vxc(ir,4)=(dvxcb-three*dvxcd)/8._dp ! 1/2 d2(Vxc_up-Vxc_dn)/dm2 4327 end do 4328 end if 4329 end if 4330 4331 ! Compute numerical first and second derivatives of Kxc (by finite difference scheme) 4332 if (nkxc>0) then 4333 ! Non-magnetic system: compute dKxc/dn, d2Kxc/dn2 4334 if (nspden==1) then 4335 LIBPAW_ALLOCATE(d1kxc,(nrad,1)) 4336 LIBPAW_ALLOCATE(d2kxc,(nrad,1)) 4337 d1kxc(1:nrad,1)=(kxc1(1:nrad,1)-kxc2(1:nrad,1))*half*rhoinv(1:nrad,1) 4338 d2kxc(1:nrad,1)=(kxc1(1:nrad,1)+kxc2(1:nrad,1)-two*kxci(1:nrad,1))*rhoinv(1:nrad,1)**2 4339 ! Collinear magnetism: compute dKxc_upup/dn_up,dKxc_updn/dn_up,dKxc_updn/dn_dn,dKxc_dndn/dn_dn 4340 ! compute d2Kxc_upup/dn_up2,d2Kxc_updn/dn_up2,d2Kxc_upup/dn_dn2,d2Kxc_updn/dn_dn2,d2Kxc_dndn/dn_dn2 4341 else if (nspden==2) then 4342 LIBPAW_ALLOCATE(d1kxc,(nrad,4)) 4343 LIBPAW_ALLOCATE(d2kxc,(nrad,5)) 4344 d1kxc(1:nrad,1)=(kxc1(1:nrad,1)-kxc2(1:nrad,1))*half*rhoinv(1:nrad,1) ! dKxc_upup/dn_up 4345 d1kxc(1:nrad,2)=(kxc1(1:nrad,2)-kxc2(1:nrad,2))*half*rhoinv(1:nrad,1) ! dKxc_updn/dn_up 4346 d1kxc(1:nrad,3)=(kxc1(1:nrad,3)-kxc2(1:nrad,3))*half*rhoinv(1:nrad,1) ! dKxc_dndn/dn_up 4347 d1kxc(1:nrad,4)=(kxcdn1(1:nrad,3)-kxcdn2(1:nrad,3))*half*rhoinv(1:nrad,2) ! dKxc_dndn/dn_dn 4348 d2kxc(1:nrad,1)=(kxc1(1:nrad,1)+kxc2(1:nrad,1)-two*kxci(1:nrad,1))*rhoinv(1:nrad,1)**2 ! d2Kxc_upup/dn_up2 4349 d2kxc(1:nrad,2)=(kxc1(1:nrad,2)+kxc2(1:nrad,2)-two*kxci(1:nrad,2))*rhoinv(1:nrad,1)**2 ! d2Kxc_updn/dn_up2 4350 d2kxc(1:nrad,3)=(kxcdn1(1:nrad,1)+kxcdn2(1:nrad,1)-two*kxci(1:nrad,1))*rhoinv(1:nrad,2)**2 ! d2Kxc_upup/dn_dn2 4351 d2kxc(1:nrad,4)=(kxcdn1(1:nrad,2)+kxcdn2(1:nrad,2)-two*kxci(1:nrad,2))*rhoinv(1:nrad,2)**2 ! d2Kxc_updn/dn_dn2 4352 d2kxc(1:nrad,5)=(kxcdn1(1:nrad,3)+kxcdn2(1:nrad,3)-two*kxci(1:nrad,3))*rhoinv(1:nrad,2)**2 ! d2Kxc_dndn/dn_dn2 4353 end if 4354 end if 4355 4356 LIBPAW_DEALLOCATE(rhoinv) 4357 LIBPAW_DEALLOCATE(vxc1) 4358 LIBPAW_DEALLOCATE(vxc2) 4359 LIBPAW_DEALLOCATE(kxc1) 4360 LIBPAW_DEALLOCATE(kxc2) 4361 if (nspden_updn==2) then 4362 LIBPAW_DEALLOCATE(vxcdn1) 4363 LIBPAW_DEALLOCATE(vxcdn2) 4364 LIBPAW_DEALLOCATE(kxcdn1) 4365 LIBPAW_DEALLOCATE(kxcdn2) 4366 end if 4367 4368 end if ! (option/=4 and option/=5) 4369 4370 LIBPAW_DEALLOCATE(rhosph) 4371 4372 !If non-collinear magnetism, store 1/2(Vxc_up+Vxc_dn) and 1/2(Vxc_up-Vxc_dn) 4373 if (nspden==4) then 4374 vxci(:,1)=half*(vxci(:,1)+vxci(:,2)) 4375 vxci(:,2)=vxci(:,1)-vxci(:,2) 4376 end if 4377 4378 !---------------------------------------------------------------------- 4379 !----- Compute useful sums of densities 4380 !---------------------------------------------------------------------- 4381 4382 if (option/=4.and.option/=5) then 4383 4384 ! Non-collinear magnetism: replace rho_dn by (m_0.dot.m)/|m_0| 4385 if (nspden==4) then 4386 LIBPAW_POINTER_ALLOCATE(rho_dn,(nrad,lm_size)) 4387 rho_dn(:,1)=zero 4388 do ilm=2,lm_size 4389 rho_dn(1:nrad,ilm)=m_norm_inv(1:nrad) & 4390 & *(rho_updn(1:nrad,1,2)*rho_updn(1:nrad,ilm,2) & 4391 & +rho_updn(1:nrad,1,3)*rho_updn(1:nrad,ilm,3) & 4392 & +rho_updn(1:nrad,1,4)*rho_updn(1:nrad,ilm,4)) 4393 end do 4394 end if 4395 4396 ! Non-magnetic system: 4397 ! Compute 4398 ! V1SUM1(r)=Sum_L{n_L(r)^2} 4399 ! V2SUM1(r,L)=Sum_L1_L2{n_L1(r)*n_L2(r)*Gaunt_(L,L1,L2)} 4400 ! Collinear magnetism: 4401 ! Compute 4402 ! V1SUM1(r)=Sum_L{n^up_L(r)^2} 4403 ! V1SUM2(r)=Sum_L{n^up_L(r)*n^dn_L(r)} 4404 ! V1SUM3(r)=Sum_L{n^dn_L(r)^2} 4405 ! V2SUM1(r,L)=Sum_L1_L2{n^up_L1(r)*n^up_L2(r)*Gaunt_(L,L1,L2)} 4406 ! V2SUM2(r,L)=Sum_L1_L2{n^up_L1(r)*n^dn_L2(r)*Gaunt_(L,L1,L2)} 4407 ! V2SUM3(r,L)=Sum_L1_L2{n^dn_L1(r)*n^dn_L2(r)*Gaunt_(L,L1,L2)} 4408 ! Non-collinear magnetism: 4409 ! Compute 4410 ! V1SUM1(r)=Sum_L{n_L(r)^2} 4411 ! V1SUM2(r)=Sum_L{n_L(r) (m_0.m_L)}/|m_0| 4412 ! V1SUM3(r)=Sum_L{(m_0.m_L)^2}/|m_0|^2 4413 ! V2SUM1(r,L)=Sum_L1_L2{n_L1(r)*n_L2(r)*Gaunt_(L,L1,L2)} 4414 ! V2SUM2(r,L)=Sum_L1_L2{n_L1(r) (m_0.m_L2)*Gaunt_(L,L1,L2)}/|m_0| 4415 ! V2SUM3(r,L)=Sum_L1_L2{(m_0.m_L1)*(m_0.m_L2)*Gaunt_(L,L1,L2)}/|m_0|^2 4416 if (pawxcdev>=1) then 4417 LIBPAW_ALLOCATE(v1sum,(nrad,nsums)) 4418 else 4419 LIBPAW_ALLOCATE(v1sum,(0,0)) 4420 end if 4421 if (pawxcdev>=2) then 4422 LIBPAW_ALLOCATE(v2sum,(nrad,lm_size,nsums)) 4423 else 4424 LIBPAW_ALLOCATE(v2sum,(0,0,0)) 4425 end if 4426 call pawxcsum(1,1,1,lmselect,lmselect,lm_size,nrad,nsums,pawxcdev,pawang,& 4427 & rho_up,rho_dn,v1sum,v2sum) 4428 4429 end if !option 4430 4431 !---------------------------------------------------------------------- 4432 !----- Accumulate and store XC potential 4433 !---------------------------------------------------------------------- 4434 4435 if (option/=3.and.option/=4) then 4436 4437 ! === First order development 4438 ! --------------------------- 4439 if (pawxcdev>=1) then 4440 4441 ! Non-magnetic system 4442 if (nspden_updn==1) then 4443 vxc(1:nrad,1,1)=vxci(1:nrad,1)*sqfpi 4444 if (option/=5) then 4445 vxc(1:nrad,1,1)=vxc(1:nrad,1,1)+v1sum(1:nrad,1)*d2vxc(1:nrad,1)*invsqfpi2 4446 do ilm=2,lm_size 4447 if (lmselect(ilm)) then 4448 vxc(1:nrad,ilm,1)=d1vxc(1:nrad,1)*rho_up(1:nrad,ilm) 4449 end if 4450 end do 4451 end if 4452 4453 ! Magnetic system (including non-collinear magn.) 4454 else if (nspden_updn==2) then 4455 vxc(1:nrad,1,1)=vxci(1:nrad,1)*sqfpi 4456 vxc(1:nrad,1,2)=vxci(1:nrad,2)*sqfpi 4457 if (option/=5) then 4458 vxc(1:nrad,1,1)=vxc(1:nrad,1,1)+invsqfpi2*(v1sum(1:nrad,1)*d2vxc(1:nrad,1) & 4459 & +two*v1sum(1:nrad,2)*d2vxc(1:nrad,2)+v1sum(1:nrad,3)*d2vxc(1:nrad,3)) 4460 vxc(1:nrad,1,2)=vxc(1:nrad,1,2)+invsqfpi2*(v1sum(1:nrad,1)*d2vxc(1:nrad,2) & 4461 & +two*v1sum(1:nrad,2)*d2vxc(1:nrad,3)+v1sum(1:nrad,3)*d2vxc(1:nrad,4)) 4462 do ilm=2,lm_size 4463 if (lmselect(ilm)) then 4464 vxc(1:nrad,ilm,1)=vxc(1:nrad,ilm,1) & 4465 & +d1vxc(1:nrad,1)*rho_up(1:nrad,ilm)+d1vxc(1:nrad,2)*rho_dn(1:nrad,ilm) 4466 vxc(1:nrad,ilm,2)=vxc(1:nrad,ilm,2) & 4467 & +d1vxc(1:nrad,2)*rho_up(1:nrad,ilm)+d1vxc(1:nrad,3)*rho_dn(1:nrad,ilm) 4468 end if 4469 end do 4470 end if 4471 end if 4472 end if ! pawxcdev>=1 4473 4474 ! == 2nd order development 4475 ! --------------------------- 4476 if (pawxcdev>=2.and.option/=5) then 4477 4478 ! Non-magnetic system 4479 if (nspden_updn==1) then 4480 do ilm=2,lm_size 4481 vxc(1:nrad,ilm,1)=vxc(1:nrad,ilm,1)+half*d2vxc(1:nrad,1)*v2sum(1:nrad,ilm,1) 4482 end do 4483 4484 ! Magnetic system (including non-collinear magn.) 4485 else if (nspden_updn==2) then 4486 do ilm=2,lm_size 4487 vxc(1:nrad,ilm,1)=vxc(1:nrad,ilm,1)+d2vxc(1:nrad,2)*v2sum(1:nrad,ilm,2) & 4488 & +half*(d2vxc(1:nrad,1)*v2sum(1:nrad,ilm,1)+d2vxc(1:nrad,3)*v2sum(1:nrad,ilm,3)) 4489 vxc(1:nrad,ilm,2)=vxc(1:nrad,ilm,2)+d2vxc(1:nrad,3)*v2sum(1:nrad,ilm,2) & 4490 & +half*(d2vxc(1:nrad,2)*v2sum(1:nrad,ilm,1)+d2vxc(1:nrad,4)*v2sum(1:nrad,ilm,3)) 4491 end do 4492 end if 4493 end if !pawxcdev=2 4494 4495 ! === Pathological case: if rho(r) is negative, interpolate Vxc 4496 ! ------------------------------------------------------------- 4497 if (lmselect(1)) then 4498 tol_rho=xc_denpos*(one+tol6) 4499 do ispden=1,nspden_updn 4500 ir1=0;ir2=0 4501 do ir=1,nrad 4502 if (rho_updn(ir,1,ispden)<tol_rho) then 4503 if (ir1==0) ir1=ir-1 4504 ir2=ir+1 4505 else if (ir1>0) then 4506 if (ir1>1.or.ir2<nrad) then 4507 fact=(vxc(ir2,1,ispden)-vxc(ir1,1,ispden))/(pawrad%rad(ir2)-pawrad%rad(ir1)) 4508 do jr=ir1+1,ir2-1 4509 vxc(jr,1,ispden)=vxc(ir1,1,ispden)+fact*(pawrad%rad(jr)-pawrad%rad(ir1)) 4510 end do 4511 end if 4512 ir1=0;ir2=0 4513 end if 4514 end do 4515 end do 4516 end if 4517 4518 ! === Non-collinear magnetism: "rotate" back the XC potential 4519 ! ------- --------------------------------------------------- 4520 if (nspden==4) then 4521 LIBPAW_ALLOCATE(vxc_diag,(nrad,nspden_updn)) 4522 LIBPAW_ALLOCATE(vxc_nc,(nrad,nspden)) 4523 do ilm=1,lm_size 4524 vxc_diag(:,1)=vxc(:,ilm,1)+vxc(:,ilm,2) ! Get V from (V_up+V_dn)/2 4525 vxc_diag(:,2)=vxc(:,ilm,1)-vxc(:,ilm,2) ! and (V_up-V_dn)/2 4526 call pawxc_rotate_back_mag(vxc_diag,vxc_nc,mag_nc,nrad) 4527 do ispden=1,nspden 4528 vxc(1:nrad,ilm,ispden)=vxc_nc(1:nrad,ispden) 4529 end do 4530 end do 4531 LIBPAW_DEALLOCATE(vxc_diag) 4532 LIBPAW_DEALLOCATE(vxc_nc) 4533 end if 4534 end if !option/=3 and option/=4 4535 4536 !---------------------------------------------------------------------- 4537 !----- Accumulate and store XC kernel 4538 !---------------------------------------------------------------------- 4539 4540 if (nkxc>0) then 4541 4542 ! === First order development 4543 ! --------------------------- 4544 if (pawxcdev>=1) then 4545 ! Non-magnetic system: 4546 if (nspden_updn==1) then 4547 kxc(1:nrad,1,1)=kxci(1:nrad,1)*sqfpi 4548 if (option/=5.and.option/=4) then 4549 kxc(1:nrad,1,1)=kxc(1:nrad,1,1)+invsqfpi2*v1sum(1:nrad,1)*d2kxc(1:nrad,1) 4550 do ilm=2,lm_size 4551 if (lmselect(ilm)) then 4552 kxc(1:nrad,ilm,1)=d1kxc(1:nrad,1)*rho_up(1:nrad,ilm) 4553 end if 4554 end do 4555 end if 4556 ! Magnetic system: 4557 else if (nspden==2) then 4558 kxc(1:nrad,1,1)=kxci(1:nrad,1)*sqfpi 4559 kxc(1:nrad,1,2)=kxci(1:nrad,2)*sqfpi 4560 kxc(1:nrad,1,3)=kxci(1:nrad,3)*sqfpi 4561 if (option/=5.and.option/=4) then 4562 kxc(1:nrad,1,1)=kxc(1:nrad,1,1)+invsqfpi2*(v1sum(1:nrad,1)*d2kxc(1:nrad,1) & 4563 & +two*v1sum(1:nrad,2)*d2kxc(1:nrad,2)+v1sum(1:nrad,3)*d2kxc(1:nrad,3)) 4564 kxc(1:nrad,1,2)=kxc(1:nrad,1,2)+invsqfpi2*(v1sum(1:nrad,1)*d2kxc(1:nrad,2) & 4565 & +two*v1sum(1:nrad,2)*d2kxc(1:nrad,3)+v1sum(1:nrad,3)*d2kxc(1:nrad,4)) 4566 kxc(1:nrad,1,3)=kxc(1:nrad,1,3)+invsqfpi2*(v1sum(1:nrad,1)*d2kxc(1:nrad,3) & 4567 & +two*v1sum(1:nrad,2)*d2kxc(1:nrad,4)+v1sum(1:nrad,3)*d2kxc(1:nrad,5)) 4568 do ilm=2,lm_size 4569 if (lmselect(ilm)) then 4570 kxc(1:nrad,ilm,1)=kxc(1:nrad,ilm,1) & 4571 & +d1kxc(1:nrad,1)*rho_up(1:nrad,ilm)+d1kxc(1:nrad,2)*rho_dn(1:nrad,ilm) 4572 kxc(1:nrad,ilm,2)=kxc(1:nrad,ilm,2) & 4573 & +d1kxc(1:nrad,2)*rho_up(1:nrad,ilm)+d1kxc(1:nrad,3)*rho_dn(1:nrad,ilm) 4574 kxc(1:nrad,ilm,3)=kxc(1:nrad,ilm,3) & 4575 & +d1kxc(1:nrad,3)*rho_up(1:nrad,ilm)+d1kxc(1:nrad,4)*rho_dn(1:nrad,ilm) 4576 end if 4577 end do 4578 end if 4579 end if 4580 end if ! pawxcdev>=1 4581 4582 ! == 2nd order development 4583 ! --------------------------- 4584 if (pawxcdev>=2.and.option/=4.and.option/=5) then 4585 4586 ! Non-magnetic system: 4587 if (nspden_updn==1) then 4588 do ilm=2,lm_size 4589 kxc(1:nrad,ilm,1)=kxc(1:nrad,ilm,1)+half*d2kxc(1:nrad,1)*v2sum(1:nrad,ilm,1) 4590 end do 4591 ! Magnetic system: 4592 else if (nspden==2) then 4593 do ilm=2,lm_size 4594 kxc(1:nrad,ilm,1)=kxc(1:nrad,ilm,1)+d2kxc(1:nrad,2)*v2sum(1:nrad,ilm,2) & 4595 & +half*(d2kxc(1:nrad,1)*v2sum(1:nrad,ilm,1)+d2kxc(1:nrad,3)*v2sum(1:nrad,ilm,3)) 4596 kxc(1:nrad,ilm,2)=kxc(1:nrad,ilm,2)+d2kxc(1:nrad,3)*v2sum(1:nrad,ilm,2) & 4597 & +half*(d2kxc(1:nrad,2)*v2sum(1:nrad,ilm,1)+d2kxc(1:nrad,4)*v2sum(1:nrad,ilm,3)) 4598 kxc(1:nrad,ilm,3)=kxc(1:nrad,ilm,3)+d2kxc(1:nrad,4)*v2sum(1:nrad,ilm,2) & 4599 & +half*(d2kxc(1:nrad,3)*v2sum(1:nrad,ilm,1)+d2kxc(1:nrad,5)*v2sum(1:nrad,ilm,3)) 4600 end do 4601 end if 4602 end if !pawxcdev=2 4603 4604 ! === Pathological case: if rho(r) is negative, interpolate Kxc 4605 ! ------------------------------------------------------------- 4606 4607 ! NOT OK for spin polarized 4608 if (lmselect(1)) then 4609 tol_rho=xc_denpos*(one+tol6) 4610 do ispden=1,nspden_updn 4611 ir1=0;ir2=0 4612 do ir=1,nrad 4613 if (rho_updn(ir,1,ispden)<tol_rho) then 4614 if (ir1==0) ir1=ir-1 4615 ir2=ir+1 4616 else if (ir1>0) then 4617 if (ir1>1.or.ir2<nrad) then 4618 fact=(kxc(ir2,1,ispden)-kxc(ir1,1,ispden))/(pawrad%rad(ir2)-pawrad%rad(ir1)) 4619 do jr=ir1+1,ir2-1 4620 kxc(jr,1,ispden)=kxc(ir1,1,ispden)+fact*(pawrad%rad(jr)-pawrad%rad(ir1)) 4621 end do 4622 end if 4623 ir1=0;ir2=0 4624 end if 4625 end do 4626 end do 4627 end if 4628 4629 ! Non-collinear magnetism: need to store magnetization in kxc 4630 if (nkxc==6.or.nkxc==22) then 4631 do ilm=2,lm_size 4632 kxc(1:nrad,ilm,nkxc-2)=rho_updn(1:nrad,ilm,2) 4633 kxc(1:nrad,ilm,nkxc-1)=rho_updn(1:nrad,ilm,3) 4634 kxc(1:nrad,ilm,nkxc )=rho_updn(1:nrad,ilm,4) 4635 end do 4636 end if 4637 4638 end if ! nkxc>0 4639 4640 if (nspden==4) then 4641 LIBPAW_DEALLOCATE(rho_nc) 4642 LIBPAW_DEALLOCATE(m_norm_inv) 4643 end if 4644 4645 LIBPAW_DEALLOCATE(kxci) 4646 if (nkxc>0.and.option/=4.and.option/=5) then 4647 LIBPAW_DEALLOCATE(d1kxc) 4648 LIBPAW_DEALLOCATE(d2kxc) 4649 end if 4650 4651 !---------------------------------------------------------------------- 4652 !----- Accumulate and store XC energies 4653 !---------------------------------------------------------------------- 4654 4655 !----- Calculate Exc (direct scheme) term 4656 !---------------------------------------- 4657 if (option/=1.and.option/=5) then 4658 LIBPAW_ALLOCATE(ff,(nrad)) 4659 4660 ! Contribution from spherical part of rho 4661 if (nspden==1.or.nspden==4) then 4662 ff(1:nrad)=rho_updn(1:nrad,1,1)*exci(1:nrad)*sqfpi 4663 else if (nspden==2) then 4664 ff(1:nrad)=(rho_updn(1:nrad,1,1)+rho_updn(1:nrad,1,2))*exci(1:nrad)*sqfpi 4665 end if 4666 4667 ! Contribution from aspherical part of rho 4668 if (option/=4) then 4669 4670 ! First order development 4671 if (pawxcdev>=1) then 4672 if (nspden_updn==1) then 4673 ff(1:nrad)=ff(1:nrad)+half*v1sum(1:nrad,1)*d1vxc(1:nrad,1) 4674 else if (nspden_updn==2) then 4675 ff(1:nrad)=ff(1:nrad)+v1sum(1:nrad,2)*d1vxc(1:nrad,2) & 4676 & +half*(v1sum(1:nrad,1)*d1vxc(1:nrad,1)+v1sum(1:nrad,3)*d1vxc(1:nrad,3)) 4677 end if 4678 end if 4679 4680 ! Second order development 4681 if (pawxcdev>=2) then 4682 LIBPAW_ALLOCATE(gg,(nrad)) 4683 4684 gg=zero 4685 do ilm=2,lm_size 4686 if (lmselect(ilm)) then 4687 gg(1:nrad)=gg(1:nrad)+v2sum(1:nrad,ilm,1)*rho_up(1:nrad,ilm) 4688 end if 4689 end do 4690 ff(1:nrad)=ff(1:nrad)+gg(1:nrad)*d2vxc(1:nrad,1)/6._dp 4691 4692 if (nspden_updn==2) then ! Spin polarized (including non-coll. magn.) 4693 gg=zero 4694 do ilm=2,lm_size 4695 if (lmselect(ilm)) then 4696 gg(1:nrad)=gg(1:nrad)+v2sum(1:nrad,ilm,3)*rho_dn(1:nrad,ilm) 4697 end if 4698 end do 4699 ff(1:nrad)=ff(1:nrad)+gg(1:nrad)*d2vxc(1:nrad,4)/6._dp 4700 gg=zero 4701 do ilm=2,lm_size 4702 if (lmselect(ilm)) then 4703 gg(1:nrad)=gg(1:nrad)+v2sum(1:nrad,ilm,2)*rho_up(1:nrad,ilm) 4704 end if 4705 end do 4706 ff(1:nrad)=ff(1:nrad)+half*gg(1:nrad)*d2vxc(1:nrad,2) 4707 gg=zero 4708 do ilm=2,lm_size 4709 if (lmselect(ilm)) then 4710 gg(1:nrad)=gg(1:nrad)+v2sum(1:nrad,ilm,3)*rho_up(1:nrad,ilm) 4711 end if 4712 end do 4713 ff(1:nrad)=ff(1:nrad)+half*gg(1:nrad)*d2vxc(1:nrad,3) 4714 end if 4715 LIBPAW_DEALLOCATE(gg) 4716 end if 4717 4718 end if ! option/=4 4719 4720 ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2 4721 call simp_gen(enxc,ff,pawrad) 4722 LIBPAW_DEALLOCATE(ff) 4723 end if ! option/=1 and option/=5 4724 4725 LIBPAW_DEALLOCATE(exci) 4726 LIBPAW_DEALLOCATE(vxci) 4727 if (nspden==4.and.option/=4.and.option/=5) then 4728 LIBPAW_POINTER_DEALLOCATE(rho_dn) 4729 end if 4730 if (allocated(v1sum)) then 4731 LIBPAW_DEALLOCATE(v1sum) 4732 end if 4733 if (allocated(v2sum)) then 4734 LIBPAW_DEALLOCATE(v2sum) 4735 end if 4736 if (allocated(d1vxc)) then 4737 LIBPAW_DEALLOCATE(d1vxc) 4738 end if 4739 if (allocated(d2vxc)) then 4740 LIBPAW_DEALLOCATE(d2vxc) 4741 end if 4742 4743 !----- Calculate Excdc double counting term 4744 !------------------------------------------ 4745 if (option==0.or.option==2) then 4746 4747 LIBPAW_ALLOCATE(ff,(nrad)) 4748 4749 ! Build appropriate density (without core density) 4750 rho_updn(:,:,:)=rhor(:,:,:) 4751 if (usexcnhat>0) rho_updn(:,:,:)=rho_updn(:,:,:)+nhat(:,:,:) 4752 if (nspden==2) then 4753 do ilm=1,lm_size 4754 ff(:)=rho_updn(:,ilm,2) 4755 rho_updn(:,ilm,2)=rho_updn(:,ilm,1)-ff(:) 4756 rho_updn(:,ilm,1)=ff(:) 4757 end do 4758 end if 4759 4760 ff(1:nrad)=zero 4761 4762 ! Non magnetic or collinear magnetic system: 4763 if (nspden/=4) then 4764 do ispden=1,nspden_updn 4765 do ilm=1,lm_size 4766 if (lmselect(ilm)) ff(1:nrad)=ff(1:nrad)+vxc(1:nrad,ilm,ispden)*rho_updn(1:nrad,ilm,ispden) 4767 end do 4768 end do 4769 else 4770 ! Non-collinear magnetic system: 4771 do ilm=1,lm_size 4772 if (lmselect(ilm)) then 4773 do ir=1,nrad 4774 dvxca=vxc(ir,ilm,1)+vxc(ir,ilm,2);dvxcb=vxc(ir,ilm,1)-vxc(ir,ilm,2) 4775 ff(ir)=ff(ir)+half*(dvxca*rho_updn(ir,ilm,1)+dvxcb*rho_updn(ir,ilm,4)) & 4776 & +vxc(ir,ilm,3)*rho_updn(ir,ilm,2)-vxc(ir,ilm,4)*rho_updn(ir,ilm,3) 4777 end do 4778 end if 4779 end do 4780 end if 4781 4782 ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2 4783 call simp_gen(enxcdc,ff,pawrad) 4784 LIBPAW_DEALLOCATE(ff) 4785 4786 end if ! option 4787 4788 LIBPAW_DEALLOCATE(rho_updn) 4789 4790 end subroutine pawxcm
m_pawxc/pawxcm_dfpt [ Functions ]
[ Top ] [ m_pawxc ] [ Functions ]
NAME
pawxcm_dfpt
FUNCTION
Compute first-order change of XC potential and contribution to 2nd-order change of XC energy inside a PAW sphere. LDA+GGA - USE A DEVELOPMENT OF THE DENSITY OVER (L,M) MOMENTS
INPUTS
corexc1(cplex_den*nrad)=first-order change of core density on radial grid cplex_den= if 1, 1st-order densities are REAL, if 2, COMPLEX cplex_vxc= if 1, 1st-order XC potential is complex, if 2, COMPLEX ixc= choice of exchange-correlation scheme kxc(nrad,lm_size,nkxc)=GS xc kernel lm_size=size of density array rhor (see below) lmselect(lm_size)=select the non-zero LM-moments of input density rhor1 nhat1(cplex_den*nrad,lm_size,nspden)=first-order change of compensation density (total in 1st half and spin-up in 2nd half if nspden=2) nkxc=second dimension of the kxc array non_magnetic_xc= if true, handle density/potential as non-magnetic (even if it is) nrad=size of radial mesh for densities/potentials (might be different from pawrad%mesh_size) nspden=number of spin-density components option=0 compute both 2nd-order XC energy and 1st-order potential 1 compute only 1st-order XC potential 2 compute only 2nd-order XC energy, XC potential is temporary computed here 3 compute only 2nd-order XC energy, XC potential is input in vxc1(:) pawang <type(pawang_type)>=paw angular mesh and related data pawrad <type(pawrad_type)>=paw radial mesh and related data rhor1(cplex_den*nrad,lm_size,nspden)=first-order change of density usecore= 1 if core density has to be used in Exc/Vxc ; 0 otherwise usexcnhat= 0 if compensation density does not have to be used 1 if compensation density has to be used in d2Exc only 2 if compensation density (nhat) has to be used in d2Exc and Vxc1 xclevel= XC functional level
OUTPUT
== if option=0 or 2 or 3 ==rho1_updn
d2enxc=returned exchange-cor. contribution to 2nd-order XC energy
SIDE EFFECTS
vxc1(cplex_vxc*nrad,pawang%angl_size,nspden)=1st-order XC potential
Output if option==0 or 1
Unused if option==2
Input if option==3
SOURCE
4843 subroutine pawxcm_dfpt(corexc1,cplex_den,cplex_vxc,d2enxc,ixc,kxc,lm_size,lmselect,nhat1,& 4844 & nkxc,non_magnetic_xc,nrad,nspden,option,pawang,pawrad,rhor1,usecore,& 4845 & usexcnhat,vxc1,xclevel,& 4846 & d2enxc_im) ! optional 4847 4848 !Arguments ------------------------------------ 4849 !scalars 4850 integer,intent(in) :: cplex_den,cplex_vxc,ixc,lm_size,nkxc,nrad,nspden,option 4851 integer,intent(in) :: usecore,usexcnhat,xclevel 4852 logical,intent(in) :: non_magnetic_xc 4853 real(dp),intent(out) :: d2enxc 4854 real(dp),intent(out),optional :: d2enxc_im 4855 type(pawang_type),intent(in) :: pawang 4856 type(pawrad_type),intent(in) :: pawrad 4857 !arrays 4858 logical,intent(in) :: lmselect(lm_size) 4859 real(dp),intent(in) :: corexc1(cplex_den*nrad) 4860 real(dp),intent(in) :: kxc(nrad,lm_size,nkxc) 4861 real(dp),intent(in) :: nhat1(cplex_den*nrad,lm_size,nspden*((usexcnhat+1)/2)) 4862 real(dp),intent(in) :: rhor1(cplex_den*nrad,lm_size,nspden) 4863 real(dp),intent(inout),target :: vxc1(cplex_vxc*nrad,lm_size,nspden) 4864 4865 !Local variables------------------------------- 4866 !scalars 4867 integer :: ii,ilm,iplex,ir,ivxc,jr,kr,nkxc_cur 4868 logical :: need_impart 4869 real(dp) :: invsqfpi,ro1i,ro1r,sqfpi,sqfpi2,v1i,v1r,vxcrho 4870 character(len=500) :: msg 4871 !arrays 4872 integer,parameter :: ikxc(4)=(/1,2,2,3/),irho(4)=(/1,2,1,2/) 4873 ! real(dp) :: tsec(2) 4874 real(dp),allocatable :: ff(:),gg(:),rho1_updn(:,:,:) 4875 real(dp),allocatable :: v1sum(:),v2sum(:,:) 4876 real(dp),pointer :: vxc1_(:,:,:) 4877 4878 !************************************************************************ 4879 4880 !NOTE (MT) 4881 !lmselect and lm_size are not necessarily the same for densities, kxc and vxc1 4882 !This is not taken into account for the moment, but has to be programmed... 4883 4884 !---------------------------------------------------------------------- 4885 !----- Check options 4886 !---------------------------------------------------------------------- 4887 4888 if(option<0.or.option>3) then 4889 msg='wrong option!' 4890 LIBPAW_BUG(msg) 4891 end if 4892 if(option/=3) then 4893 call pawxc_get_nkxc(nkxc_cur,nspden,xclevel) 4894 if(nkxc/=nkxc_cur) then 4895 msg='Wrong size for kxc array!' 4896 LIBPAW_BUG(msg) 4897 end if 4898 end if 4899 if(nspden==4.and.option/=3) then 4900 msg='nspden=4 not implemented (for vxc)!' 4901 LIBPAW_ERROR(msg) 4902 end if 4903 if (option/=1) then 4904 if (nrad<pawrad%int_meshsz) then 4905 msg='When option=0,2,3, nrad must be greater than pawrad%int_meshsz!' 4906 LIBPAW_BUG(msg) 4907 end if 4908 end if 4909 4910 !---------------------------------------------------------------------- 4911 !----- Initializations 4912 !---------------------------------------------------------------------- 4913 4914 !Arrays dimensions and constants 4915 need_impart=present(d2enxc_im) 4916 sqfpi=sqrt(four_pi);sqfpi2=half*sqfpi;invsqfpi=one/sqfpi 4917 4918 !Initializations of outputs 4919 if (option/=1) then 4920 d2enxc=zero 4921 if (need_impart) d2enxc_im=zero 4922 end if 4923 if (option<=1) vxc1(:,:,:)=zero 4924 4925 !Special case: no XC applied 4926 if (ixc==0.or.(nkxc==0.and.option/=3)) then 4927 msg='Note that no xc is applied (ixc=0). Returning' 4928 LIBPAW_WARNING(msg) 4929 return 4930 end if 4931 4932 !---------------------------------------------------------------------- 4933 !----- Build several densities 4934 !---------------------------------------------------------------------- 4935 4936 !rho1_updn contains the effective 1st-order density used for XC 4937 !with 1st-order core density and/or 1st-order compensation density eventually included 4938 !----------------------------------------------------------------- 4939 LIBPAW_ALLOCATE(rho1_updn,(cplex_den*nrad,lm_size,nspden)) 4940 rho1_updn(:,:,:)=rhor1(:,:,:) 4941 if (usexcnhat==2) rho1_updn(:,:,:)=rho1_updn(:,:,:)+nhat1(:,:,:) 4942 if (usecore==1) then 4943 if (nspden==1.or.nspden==4) then 4944 rho1_updn(:,1,1)=rho1_updn(:,1,1)+sqfpi*corexc1(:) 4945 else if (nspden==2) then 4946 rho1_updn(:,1,1)=rho1_updn(:,1,1)+sqfpi*corexc1(:) 4947 rho1_updn(:,1,2)=rho1_updn(:,1,2)+sqfpi2*corexc1(:) 4948 end if 4949 end if 4950 4951 !Optionally suppressed magnetic part 4952 if(non_magnetic_xc) then 4953 if(nspden==2) rho1_updn(:,:,2)=rho1_updn(:,:,1)*half 4954 if(nspden==4) rho1_updn(:,:,2:4)=zero 4955 endif 4956 4957 !In case of collinear magnetism, separate up and down contributions 4958 if (nspden==2) then 4959 LIBPAW_ALLOCATE(ff,(cplex_den*nrad)) 4960 do ilm=1,lm_size 4961 ff(:)=rho1_updn(:,ilm,2) 4962 rho1_updn(:,ilm,2)=rho1_updn(:,ilm,1)-ff(:) 4963 rho1_updn(:,ilm,1)=ff(:) 4964 end do 4965 LIBPAW_DEALLOCATE(ff) 4966 end if 4967 4968 ! 4969 !---------------------------------------------------------------------- 4970 !----- Accumulate and store 1st-order change of XC potential 4971 !---------------------------------------------------------------------- 4972 4973 if (option==2) then 4974 LIBPAW_POINTER_ALLOCATE(vxc1_,(cplex_vxc*nrad,lm_size,nspden)) 4975 else 4976 vxc1_ => vxc1 4977 end if 4978 4979 if (option/=3) then 4980 4981 vxc1_=zero 4982 LIBPAW_ALLOCATE(v1sum,(cplex_vxc*nrad)) 4983 LIBPAW_ALLOCATE(v2sum,(cplex_vxc*nrad,lm_size)) 4984 4985 do ii=1,3*nspden-2 4986 ivxc=1;if (ii>2) ivxc=2 4987 4988 ! === Vxc1 and Rho1 are REAL 4989 if (cplex_vxc==1.and.cplex_den==1) then ! cplex_vxc==1 and cplex_den==1 4990 call pawxcsum(1,1,1,lmselect,lmselect,lm_size,nrad,1,2,pawang,& 4991 & kxc(:,:,ikxc(ii)),rho1_updn(:,:,irho(ii)),v1sum,v2sum) 4992 vxc1_(:,1,ivxc)=vxc1_(:,1,ivxc)+invsqfpi*(v1sum(:)+kxc(:,1,ikxc(ii))*rho1_updn(:,1,irho(ii))) 4993 do ilm=2,lm_size 4994 vxc1_(:,ilm,ivxc)=vxc1_(:,ilm,ivxc)+v2sum(:,ilm) & 4995 & +invsqfpi*(kxc(:,ilm,ikxc(ii))*rho1_updn(:,1 ,irho(ii)) & 4996 & +kxc(:,1 ,ikxc(ii))*rho1_updn(:,ilm,irho(ii))) 4997 end do 4998 4999 ! === At least one of Vxc1 or Rho1 is COMPLEX 5000 else 5001 call pawxcsum(1,cplex_den,cplex_vxc,lmselect,lmselect,lm_size,nrad,1,2,pawang,& 5002 & kxc(:,:,ikxc(ii)),rho1_updn(:,:,irho(ii)),v1sum,v2sum) 5003 do ir=1,nrad 5004 jr=cplex_den*(ir-1);kr=cplex_vxc*(ir-1) 5005 do iplex=1,1+(cplex_den*cplex_vxc)/4 5006 jr=jr+1;kr=kr+1 5007 vxc1_(kr,1,ivxc)=vxc1_(kr,1,ivxc)+invsqfpi*(v1sum(kr)+kxc(ir,1,ikxc(ii))*rho1_updn(jr,1,irho(ii))) 5008 do ilm=2,lm_size 5009 vxc1_(kr,ilm,ivxc)=vxc1_(kr,ilm,ivxc)+v2sum(kr,ilm) & 5010 & +invsqfpi*(kxc(ir,ilm,ikxc(ii))*rho1_updn(jr,1 ,irho(ii)) & 5011 & +kxc(ir,1 ,ikxc(ii))*rho1_updn(jr,ilm,irho(ii))) 5012 end do 5013 end do 5014 end do 5015 5016 end if ! cplex_den and vxc_den 5017 end do ! ii=1,3*nspden-2 5018 5019 LIBPAW_DEALLOCATE(v1sum) 5020 LIBPAW_DEALLOCATE(v2sum) 5021 5022 end if 5023 5024 !---------------------------------------------------------------------- 5025 !----- Accumulate and store 2nd-order change of XC energy 5026 !---------------------------------------------------------------------- 5027 if (option/=1) then 5028 5029 if (.not.non_magnetic_xc) then 5030 ! For usexnhat=1 particular case, add now compensation density 5031 if (usexcnhat==1) then 5032 rho1_updn(:,:,1)=rho1_updn(:,:,1)+nhat1(:,:,nspden) 5033 if (nspden==2) rho1_updn(:,:,2)=rho1_updn(:,:,2)+nhat1(:,:,1)-nhat1(:,:,2) 5034 end if 5035 else 5036 ! Has to be magnetic here 5037 rho1_updn(:,:,:)=rhor1(:,:,:) 5038 if (usexcnhat>0) rho1_updn(:,:,:)=rho1_updn(:,:,:)+nhat1(:,:,:) 5039 if (usecore==1) then 5040 if (nspden==1.or.nspden==4) then 5041 rho1_updn(:,1,1)=rho1_updn(:,1,1)+sqfpi*corexc1(:) 5042 else if (nspden==2) then 5043 rho1_updn(:,1,1)=rho1_updn(:,1,1)+sqfpi*corexc1(:) 5044 rho1_updn(:,1,2)=rho1_updn(:,1,2)+sqfpi2*corexc1(:) 5045 end if 5046 end if 5047 end if 5048 5049 LIBPAW_ALLOCATE(ff,(nrad)) 5050 ff=zero 5051 if (need_impart) then 5052 LIBPAW_ALLOCATE(gg,(nrad)) 5053 gg=zero 5054 end if 5055 5056 ! ----- Calculate d2Exc=Int[Vxc^(1)^*(r).n^(1)(r).dr] 5057 do ii=1,nspden 5058 ! === Vxc1 and Rho1 are REAL 5059 if (cplex_vxc==1.and.cplex_den==1) then 5060 do ilm=1,lm_size 5061 if (lmselect(ilm)) ff(:)=ff(:)+vxc1_(:,ilm,ii)*rho1_updn(:,ilm,ii) 5062 end do 5063 ! === Vxc1 and Rho1 are COMPLEX 5064 else if (cplex_vxc==2.and.cplex_den==2) then ! cplex_vxc==2 and cplex_den==2 5065 if (.not.need_impart) then ! Real part only 5066 do ilm=1,lm_size 5067 if (lmselect(ilm)) then 5068 do ir=1,nrad 5069 jr=2*ir;v1r=vxc1_(jr-1,ilm,ii);v1i=vxc1_(jr,ilm,ii) 5070 ro1r=rho1_updn(jr-1,ilm,ii);ro1i=rho1_updn(jr,ilm,ii) 5071 ff(ir)=ff(ir)+v1r*ro1r+v1i*ro1i 5072 end do 5073 end if 5074 end do 5075 else ! Real and imaginary parts 5076 do ilm=1,lm_size 5077 if (lmselect(ilm)) then 5078 do ir=1,nrad 5079 jr=2*ir;v1r=vxc1_(jr-1,ilm,ii);v1i=vxc1_(jr,ilm,ii) 5080 ro1r=rho1_updn(jr-1,ilm,ii);ro1i=rho1_updn(jr,ilm,ii) 5081 ff(ir)=ff(ir)+v1r*ro1r+v1i*ro1i 5082 gg(ir)=gg(ir)+v1r*ro1i-v1i*ro1r 5083 end do 5084 end if 5085 end do 5086 end if ! need_impart 5087 ! === Vxc1 and Rho1 are REAL and COMPLEX 5088 else 5089 v1i=zero;ro1i=zero 5090 do ilm=1,lm_size 5091 if (lmselect(ilm)) then 5092 do ir=1,nrad 5093 jr=cplex_vxc*(ir-1)+1;v1r=vxc1_(jr,ilm,ii);;if(cplex_vxc==2)v1i=vxc1_(jr+1,ilm,ii) 5094 jr=cplex_den*(ir-1)+1;ro1r=rho1_updn(jr,ilm,ii);if(cplex_den==2)ro1i=rho1_updn(jr+1,ilm,ii) 5095 ff(ir)=ff(ir)+v1r*ro1r+v1i*ro1i 5096 if (need_impart) gg(ir)=gg(ir)+v1r*ro1i-v1i*ro1r 5097 end do 5098 end if 5099 end do 5100 end if ! cplex_vxc and cplex_den 5101 end do ! ii=1,nspden 5102 5103 ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2 5104 call simp_gen(vxcrho,ff,pawrad) 5105 d2enxc=d2enxc+vxcrho 5106 LIBPAW_DEALLOCATE(ff) 5107 5108 if (need_impart) then 5109 gg(1:nrad)=gg(1:nrad)*pawrad%rad(1:nrad)**2 5110 call simp_gen(vxcrho,gg,pawrad) 5111 d2enxc_im=d2enxc_im+vxcrho 5112 LIBPAW_DEALLOCATE(gg) 5113 end if 5114 5115 end if 5116 5117 LIBPAW_DEALLOCATE(rho1_updn) 5118 if (option==2) then 5119 LIBPAW_POINTER_DEALLOCATE(vxc1_) 5120 end if 5121 5122 end subroutine pawxcm_dfpt
m_pawxc/pawxcmpositron [ Functions ]
[ Top ] [ m_pawxc ] [ Functions ]
NAME
pawxcmpositron
FUNCTION
Compute electron-positron correlation potential and energies inside a PAW sphere LDA+GGA - USE A DEVELOPMENT OF THE DENSITY OVER (L,M) MOMENTS Driver of XC functionals.
INPUTS
calctype=type of electron-positron calculation:
calctype=1 : positron in electronic density
calctype=2 : electrons in positronic density
corexc(nrad)=electron core density on radial grid
ixcpositron=choice of electron-positron XC scheme
lm_size=size of density array rhor (see below)
lmselect (lm_size)=select the non-zero LM-moments of input density rhor (see below)
lmselect_ep(lm_size)=select the non-zero LM-moments of input density rhor_ep (see below)
nhat (nrad,lm_size,nspden)=compensation density corresponding to rhor
nhat_ep(nrad,lm_size,nspden)=compensation density corresponding to rhor_ep
nrad=size of radial mesh for densities/potentials (might be different from pawrad%mesh_size)
nspden=number of spin-density components
option=0 compute both XC energies (direct+double-counting) and potential
1 compute only XC potential
2 compute only XC energies (direct+double-counting)
3 compute only XC energy by direct scheme
4 compute only XC energy by direct scheme for spherical part of the density
pawang <type(pawang_type)>=paw angular mesh and related data
pawrad <type(pawrad_type)>=paw radial mesh and related data
pawxcdev=order of Vxc development
posdensity0_limit=True if we are in the zero positron density limit
rhor(nrad,lm_size,nspden)=electron (or positron) density in real space
(total in 1st half and spin-up in 2nd half if nspden=2)
Contents depends on calctype value:
calctype=1: rhor is the positronic density
calctype=2: rhor is the electronic density
rhor_ep(nrad,lm_size,nspden)=electron (or positron) density in real space
(total in 1st half and spin-up in 2nd half if nspden=2)
Contents depends on calctype value:
calctype=1: rhor_ep is the electronic density
calctype=2: rhor_ep is the positronic density
usecore= 1 if core density has to be used in Exc/Vxc for the electronic density ; 0 otherwise
usexcnhat= 0 if compensation density does not have to be used
1 if compensation density has to be used in double counting energy term only
2 if compensation density (nhat) has to be used in Exc/Vxc and double counting energy term
xc_denpos= lowest allowed density (usually for the computation of the XC functionals)
OUTPUT
== if option==0, 2, 3, or 4 ==
enxc=returned exchange and correlation energy (hartree)
== if option==0 or 2 ==
enxcdc=returned exchange-cor. contribution to double-counting energy
== if option==0 or 1 ==
vxc(nrad,lm_size,nspden)=xc potential
(spin up in 1st half and spin-down in 2nd half if nspden=2)
NOTES
SOURCE
5187 subroutine pawxcmpositron(calctype,corexc,enxc,enxcdc,ixcpositron,lm_size,lmselect,lmselect_ep,& 5188 & nhat,nhat_ep,nrad,nspden,option,pawang,pawrad,pawxcdev,posdensity0_limit,& 5189 & rhor,rhor_ep,usecore,usexcnhat,vxc,xc_denpos) 5190 5191 !Arguments ------------------------------------ 5192 !scalars 5193 integer,intent(in) :: calctype,ixcpositron,lm_size,nrad,nspden,option,pawxcdev,usecore 5194 integer,intent(in) :: usexcnhat 5195 logical,intent(in) :: posdensity0_limit 5196 real(dp),intent(in) :: xc_denpos 5197 real(dp),intent(out) :: enxc,enxcdc 5198 type(pawang_type),intent(in) :: pawang 5199 type(pawrad_type),intent(in) :: pawrad 5200 !arrays 5201 logical,intent(in) :: lmselect(lm_size),lmselect_ep(lm_size) 5202 real(dp),intent(in) :: corexc(nrad) 5203 real(dp),intent(in) :: nhat (nrad,lm_size,nspden*((usexcnhat+1)/2)) 5204 real(dp),intent(in) :: nhat_ep(nrad,lm_size,nspden*((usexcnhat+1)/2)) 5205 real(dp),intent(in) :: rhor (nrad,lm_size,nspden) 5206 real(dp),intent(in) :: rhor_ep(nrad,lm_size,nspden) 5207 real(dp),intent(out) :: vxc(nrad,lm_size,nspden) 5208 5209 !Local variables------------------------------- 5210 !scalars 5211 integer :: ilm,ir,ir1,ir2,iwarn,iwarnp,jr 5212 real(dp),parameter :: delta=1.d-4 5213 real(dp) :: fact,invsqfpi,sqfpi,rhomin 5214 character(len=500) :: msg 5215 !arrays 5216 real(dp),allocatable :: d1vxc(:,:),d2vxc(:,:),fxc_(:),ff(:),fxci(:),gg(:) 5217 real(dp),allocatable :: rho_(:),rhotot(:,:),rhotot_ep(:,:),rhoinv(:),rhoinv_ep(:) 5218 real(dp),allocatable :: rhosph(:),rhosph_ep(:),v1sum(:,:),v2sum(:,:,:) 5219 real(dp),allocatable :: vxce1(:),vxce1_ep(:),vxce2(:),vxce2_ep(:) 5220 real(dp),allocatable :: vxcp1(:),vxcp1_ep(:),vxcp2(:),vxcp2_ep(:) 5221 real(dp),allocatable :: vxcei(:),vxcpi(:) 5222 5223 !************************************************************************ 5224 5225 !----- Check options 5226 if(calctype/=1.and.calctype/=2) then 5227 msg='Invalid value for calctype' 5228 LIBPAW_BUG(msg) 5229 end if 5230 if (option/=1) then 5231 if (nrad<pawrad%int_meshsz) then 5232 msg='When option=0,2,3,4, nrad must be greater than pawrad%int_meshsz!' 5233 LIBPAW_BUG(msg) 5234 end if 5235 end if 5236 5237 !---------------------------------------------------------------------- 5238 !----- Initializations 5239 !---------------------------------------------------------------------- 5240 5241 !Initializations and constants 5242 iwarn=0;iwarnp=1 5243 sqfpi=sqrt(four_pi) 5244 invsqfpi=one/sqfpi 5245 5246 !Initializations of output arrays 5247 if (option/=1) enxc=zero 5248 if (option==0.or.option==2) enxcdc=zero 5249 if (option<3) vxc(:,:,:)=zero 5250 5251 if (ixcpositron==0) then ! No xc at all is applied (usually for testing) 5252 msg='Note that no xc is applied (ixc=0). Returning' 5253 LIBPAW_WARNING(msg) 5254 return 5255 end if 5256 5257 !---------------------------------------------------------------------- 5258 !----- Build several densities 5259 !---------------------------------------------------------------------- 5260 5261 !rhotot/rhotot_ep contain the effective total densities used for XC 5262 !with core density and/or compensation density eventually included 5263 !----------------------------------------------------------------- 5264 !Input density 5265 LIBPAW_ALLOCATE(rhotot,(nrad,lm_size)) 5266 LIBPAW_ALLOCATE(rhotot_ep,(nrad,lm_size)) 5267 rhotot (:,:)=rhor (:,:,1) 5268 rhotot_ep(:,:)=rhor_ep(:,:,1) 5269 !Eventually add compensation density 5270 if (usexcnhat==2) then 5271 rhotot (:,:)=rhotot (:,:)+nhat (:,:,1) 5272 rhotot_ep(:,:)=rhotot_ep(:,:)+nhat_ep(:,:,1) 5273 end if 5274 !Eventually add core density 5275 if (usecore==1) then 5276 if (calctype==1) rhotot_ep(:,1)=rhotot_ep(:,1)+sqfpi*corexc(:) 5277 if (calctype==2) rhotot (:,1)=rhotot (:,1)+sqfpi*corexc(:) 5278 end if 5279 5280 !rhoSPH/rhoSPH_ep contain the spherical part of effective densities 5281 !(including Y00 spherical harmonic) 5282 !----------------------------------------------------------------- 5283 LIBPAW_ALLOCATE(rhosph,(nrad)) 5284 LIBPAW_ALLOCATE(rhosph_ep,(nrad)) 5285 5286 rhosph (:)=rhotot (:,1)*invsqfpi 5287 rhosph_ep(:)=rhotot_ep(:,1)*invsqfpi 5288 5289 !Make spherical densities positive 5290 if (calctype==1) then 5291 if (.not.posdensity0_limit) then 5292 call pawxc_mkdenpos_wrapper(iwarnp,nrad,1,1,rhosph,xc_denpos) 5293 end if 5294 call pawxc_mkdenpos_wrapper(iwarn ,nrad,1,1,rhosph_ep,xc_denpos) 5295 else if (calctype==2) then 5296 call pawxc_mkdenpos_wrapper(iwarn ,nrad,1,1,rhosph,xc_denpos) 5297 if (.not.posdensity0_limit) then 5298 call pawxc_mkdenpos_wrapper(iwarnp,nrad,1,1,rhosph_ep,xc_denpos) 5299 end if 5300 end if 5301 5302 !---------------------------------------------------------------------- 5303 !----- Compute Exc(rhoSPH,rhoSPH_ep) and Vxc(rhoSPH,rhoSPH_ep) 5304 !---------------------------------------------------------------------- 5305 5306 LIBPAW_ALLOCATE(fxci,(nrad)) 5307 LIBPAW_ALLOCATE(vxcei,(nrad)) 5308 LIBPAW_ALLOCATE(vxcpi,(nrad)) 5309 call pawxcsphpositron(calctype,fxci,ixcpositron,nrad,pawrad,posdensity0_limit,rhosph,rhosph_ep,vxcei,vxcpi) 5310 5311 !---------------------------------------------------------------------- 5312 !----- Compute numerical derivatives of Vxc (by finite diff. scheme) 5313 !---------------------------------------------------------------------- 5314 5315 if (option/=4) then 5316 5317 LIBPAW_ALLOCATE(fxc_,(nrad)) 5318 LIBPAW_ALLOCATE(rho_,(nrad)) 5319 5320 ! Compute Vxc for (rho+delta_rho,rho_ep) 5321 LIBPAW_ALLOCATE(vxce1,(nrad)) 5322 LIBPAW_ALLOCATE(vxcp1,(nrad)) 5323 rho_(:)=(one+delta)*rhosph(:) 5324 call pawxcsphpositron(calctype,fxc_,ixcpositron,nrad,pawrad,posdensity0_limit,rho_,rhosph_ep,vxce1,vxcp1) 5325 5326 ! Compute Vxc for(rho-delta_rho,rho_ep) 5327 LIBPAW_ALLOCATE(vxce2,(nrad)) 5328 LIBPAW_ALLOCATE(vxcp2,(nrad)) 5329 rho_(:)=(one-delta)*rhosph(:) 5330 call pawxcsphpositron(calctype,fxc_,ixcpositron,nrad,pawrad,posdensity0_limit,rho_,rhosph_ep,vxce2,vxcp2) 5331 5332 ! Compute Vxc for (rho,rho_ep+delta_rho_ep) 5333 LIBPAW_ALLOCATE(vxce1_ep,(nrad)) 5334 LIBPAW_ALLOCATE(vxcp1_ep,(nrad)) 5335 rho_(:)=(one+delta)*rhosph_ep(:) 5336 call pawxcsphpositron(calctype,fxc_,ixcpositron,nrad,pawrad,posdensity0_limit,rhosph,rho_,vxce1_ep,vxcp1_ep) 5337 5338 ! Compute Vxc for (rho,rho_ep-delta_rho_ep) 5339 LIBPAW_ALLOCATE(vxce2_ep,(nrad)) 5340 LIBPAW_ALLOCATE(vxcp2_ep,(nrad)) 5341 rho_(:)=(one-delta)*rhosph_ep(:) 5342 call pawxcsphpositron(calctype,fxc_,ixcpositron,nrad,pawrad,posdensity0_limit,rhosph,rho_,vxce2_ep,vxcp2_ep) 5343 5344 LIBPAW_DEALLOCATE(fxc_) 5345 LIBPAW_DEALLOCATE(rho_) 5346 5347 ! Store inverse of density finite step 5348 LIBPAW_ALLOCATE(rhoinv,(nrad)) 5349 LIBPAW_ALLOCATE(rhoinv_ep,(nrad)) 5350 fact=one/delta 5351 do ir=1,nrad 5352 if (rhosph(ir)>rho_min) then 5353 rhoinv(ir)=fact/rhosph(ir) 5354 else 5355 rhoinv(ir)=zero 5356 end if 5357 if (rhosph_ep(ir)>rho_min) then 5358 rhoinv_ep(ir)=fact/rhosph_ep(ir) 5359 else 5360 rhoinv_ep(ir)=zero 5361 end if 5362 end do 5363 5364 ! Compute numerical first derivatives of Vxc (by finite difference scheme) 5365 LIBPAW_ALLOCATE(d1vxc,(nrad,3)) 5366 if (calctype==1) then 5367 d1vxc(:,1)=(vxcp1 (:)-vxcp2 (:))*half*rhoinv (:) ! dVxc+/drho+ 5368 d1vxc(:,2)=(vxcp1_ep(:)-vxcp2_ep(:))*half*rhoinv_ep(:) ! dVxc+/drho- 5369 d1vxc(:,3)=(vxce1_ep(:)-vxce2_ep(:))*half*rhoinv_ep(:) ! dVxc-/drho- 5370 else if (calctype==2) then 5371 d1vxc(:,1)=(vxce1 (:)-vxce2 (:))*half*rhoinv (:) ! dVxc-/drho- 5372 d1vxc(:,2)=(vxcp1 (:)-vxcp2 (:))*half*rhoinv (:) ! dVxc+/drho- 5373 ! d1vxc(:,2)=(vxce1_ep(:)-vxce2_ep(:))*half*rhoinv_ep(:) ! dVxc-/drho+ 5374 d1vxc(:,3)=(vxcp1_ep(:)-vxcp2_ep(:))*half*rhoinv_ep(:) ! dVxc+/drho+ 5375 end if 5376 5377 ! Compute numerical second derivatives of Vxc (by finite difference scheme) 5378 if (option<3.or.pawxcdev>1) then 5379 LIBPAW_ALLOCATE(d2vxc,(nrad,4)) 5380 if (calctype==1) then 5381 d2vxc(:,1)=(vxcp1 (:)+vxcp2 (:)-two*vxcpi(:))*rhoinv (:)**2 ! d2Vxc+/drho+_drho+ 5382 d2vxc(:,2)=(vxce1 (:)+vxce2 (:)-two*vxcei(:))*rhoinv (:)**2 ! d2Vxc-/drho+_drho+ 5383 d2vxc(:,3)=(vxcp1_ep(:)+vxcp2_ep(:)-two*vxcpi(:))*rhoinv_ep(:)**2 ! d2Vxc+/drho-_drho- 5384 d2vxc(:,4)=(vxce1_ep(:)+vxce2_ep(:)-two*vxcei(:))*rhoinv_ep(:)**2 ! d2Vxc-/drho-_drho- 5385 else if (calctype==2) then 5386 d2vxc(:,1)=(vxce1 (:)+vxce2 (:)-two*vxcei(:))*rhoinv (:)**2 ! d2Vxc-/drho-_drho- 5387 d2vxc(:,2)=(vxcp1 (:)+vxcp2 (:)-two*vxcpi(:))*rhoinv (:)**2 ! d2Vxc+/drho-_drho- 5388 d2vxc(:,3)=(vxce1_ep(:)+vxce2_ep(:)-two*vxcei(:))*rhoinv_ep(:)**2 ! d2Vxc-/drho+_drho+ 5389 d2vxc(:,4)=(vxcp1_ep(:)+vxcp2_ep(:)-two*vxcpi(:))*rhoinv_ep(:)**2 ! d2Vxc+/drho+_drho+ 5390 end if 5391 end if ! option 5392 5393 LIBPAW_DEALLOCATE(rhoinv) 5394 LIBPAW_DEALLOCATE(rhoinv_ep) 5395 LIBPAW_DEALLOCATE(vxce1) 5396 LIBPAW_DEALLOCATE(vxcp1) 5397 LIBPAW_DEALLOCATE(vxce2) 5398 LIBPAW_DEALLOCATE(vxcp2) 5399 LIBPAW_DEALLOCATE(vxce1_ep) 5400 LIBPAW_DEALLOCATE(vxcp1_ep) 5401 LIBPAW_DEALLOCATE(vxce2_ep) 5402 LIBPAW_DEALLOCATE(vxcp2_ep) 5403 5404 end if ! option/=4 5405 5406 LIBPAW_DEALLOCATE(rhosph) 5407 LIBPAW_DEALLOCATE(rhosph_ep) 5408 5409 !---------------------------------------------------------------------- 5410 !----- Compute useful sums of densities 5411 !---------------------------------------------------------------------- 5412 5413 if (option<3.or.option/=1) then 5414 5415 ! Compute V1SUM1(r)=Sum_L{n^el_L(r)^2} 5416 ! V1SUM2(r)=Sum_L{n^el_L(r)*n^pos_L(r)} 5417 ! V1SUM3(r)=Sum_L{n^pos_L(r)^2} 5418 ! V2SUM1(r,L)=Sum_L1_L2{n^el_L1(r)*n^el_L2(r)*Gaunt_(L,L1,L2)} 5419 ! V2SUM2(r,L)=Sum_L1_L2{n^el_L1(r)*n^pos_L2(r)*Gaunt_(L,L1,L2)} 5420 ! V2SUM3(r,L)=Sum_L1_L2{n^pos_L1(r)*n^pos_L2(r)*Gaunt_(L,L1,L2)} 5421 if (pawxcdev>=1) then 5422 LIBPAW_ALLOCATE(v1sum,(nrad,3)) 5423 else 5424 LIBPAW_ALLOCATE(v1sum,(0,0)) 5425 end if 5426 if (pawxcdev>=2) then 5427 LIBPAW_ALLOCATE(v2sum,(nrad,lm_size,3)) 5428 else 5429 LIBPAW_ALLOCATE(v2sum,(0,0,0)) 5430 end if 5431 call pawxcsum(1,1,1,lmselect,lmselect_ep,lm_size,nrad,3,pawxcdev,pawang,rhotot,rhotot_ep,v1sum,v2sum) 5432 5433 end if !option 5434 5435 !---------------------------------------------------------------------- 5436 !----- Accumulate and store XC potential 5437 !---------------------------------------------------------------------- 5438 5439 if (option<3) then 5440 5441 ! if (option==0.or.option==2) allocate(vxc_ep(nrad,lm_size)) 5442 5443 ! === First order development 5444 ! --------------------------- 5445 if (pawxcdev>=1) then 5446 if (calctype==1) vxc(:,1,1)=vxcpi(:)*sqfpi 5447 if (calctype==2) vxc(:,1,1)=vxcei(:)*sqfpi 5448 vxc(:,1,1)=vxc(:,1,1)+invsqfpi*(d2vxc(:,2)*v1sum(:,2) & 5449 & +half*(d2vxc(:,1)*v1sum(:,1)+d2vxc(:,3)*v1sum(:,3))) 5450 do ilm=2,lm_size 5451 if (lmselect(ilm)) vxc(:,ilm,1)=vxc(:,ilm,1)+d1vxc(:,1)*rhotot (:,ilm) 5452 if (lmselect_ep(ilm)) vxc(:,ilm,1)=vxc(:,ilm,1)+d1vxc(:,2)*rhotot_ep(:,ilm) 5453 end do 5454 ! if (option==0.or.option==2) then 5455 ! if (calctype==1) vxc_ep(:,1)=vxcei(:)*sqfpi 5456 ! if (calctype==2) vxc_ep(:,1)=vxcpi(:)*sqfpi 5457 ! vxc_ep(:,1)=vxc_ep(:,1,1)+invsqfpi*(d2vxc(:,3)*v1sum(:,2) & 5458 ! & +half*(d2vxc(:,2)*v1sum(:,1)+d2vxc(:,4)*v1sum(:,3))) 5459 ! do ilm=2,lm_size 5460 ! if (lmselect(ilm)) vxc_ep(:,ilm)=vxc_ep(:,ilm)+d1vxc(:,2)*rhotot (:,ilm) 5461 ! if (lmselect_ep(ilm)) vxc_ep(:,ilm)=vxc_ep(:,ilm)+d1vxc(:,3)*rhotot_ep(:,ilm) 5462 ! end do 5463 ! end if 5464 end if ! pawxcdev>=1 5465 5466 ! == 2nd order development 5467 ! --------------------------- 5468 if (pawxcdev>=2) then 5469 do ilm=2,lm_size 5470 vxc(:,ilm,1)=vxc(:,ilm,1)+d2vxc(:,2)*v2sum(:,ilm,2) & 5471 & +half*(d2vxc(:,1)*v2sum(:,ilm,1)+d2vxc(:,3)*v2sum(:,ilm,3)) 5472 end do 5473 ! if (option==0.or.option==2) then 5474 ! do ilm=2,lm_size 5475 ! vxc_ep(:,ilm)=vxc_ep(:,ilm)+d2vxc(:,3)*v2sum(:,ilm,2) & 5476 ! & +half*(d2vxc(:,2)*v2sum(:,ilm,1)+d2vxc(:,4)*v2sum(:,ilm,3)) 5477 ! end do 5478 ! end if 5479 end if !pawxcdev=2 5480 5481 ! === Pathological case: if rho(r) is negative, interpolate Vxc 5482 ! ------------------------------------------------------------- 5483 if (lmselect(1)) then 5484 rhomin=xc_denpos*(one+tol6) 5485 ir1=0;ir2=0 5486 do ir=1,nrad 5487 if (rhotot(ir,1)<rhomin) then 5488 if (ir1==0) ir1=ir-1 5489 ir2=ir+1 5490 else if (ir1>0) then 5491 if (ir1>1.or.ir2<nrad) then 5492 fact=(vxc(ir2,1,1)-vxc(ir1,1,1))/(pawrad%rad(ir2)-pawrad%rad(ir1)) 5493 do jr=ir1+1,ir2-1 5494 vxc(jr,1,1)=vxc(ir1,1,1)+fact*(pawrad%rad(jr)-pawrad%rad(ir1)) 5495 end do 5496 end if 5497 ir1=0;ir2=0 5498 end if 5499 end do 5500 end if 5501 ! if (option==0.or.option==2) then 5502 ! if (lmselect_ep(1)) then 5503 ! ir1=0;ir2=0 5504 ! do ir=1,nrad 5505 ! if (rhotot_ep(ir,1)<rho_min) then 5506 ! if (ir1==0) ir1=ir-1 5507 ! ir2=ir+1 5508 ! else if (ir1>0) then 5509 ! if (ir1>1.or.ir2<nrad) then 5510 ! fact=(vxc_ep(ir2,1)-vxc_ep(ir1,1))/(pawrad%rad(ir2)-pawrad%rad(ir1)) 5511 ! do jr=ir1+1,ir2-1 5512 ! vxc_ep(jr,1)=vxc_ep(ir1,1)+fact*(pawrad%rad(jr)-pawrad%rad(ir1)) 5513 ! end do 5514 ! end if 5515 ! ir1=0;ir2=0 5516 ! end if 5517 ! end do 5518 ! end if 5519 ! end if 5520 5521 ! When vxc is dimensionned as polarized... 5522 if (nspden>=2) vxc(:,:,2)=vxc(:,:,1) 5523 if (nspden==4) vxc(:,:,3:4)=zero 5524 5525 end if !option<3 5526 5527 LIBPAW_DEALLOCATE(vxcei) 5528 LIBPAW_DEALLOCATE(vxcpi) 5529 5530 !---------------------------------------------------------------------- 5531 !----- Accumulate and store XC energies 5532 !---------------------------------------------------------------------- 5533 5534 !----- Calculate Exc (direct scheme) term 5535 !---------------------------------------- 5536 5537 if (option/=1) then 5538 LIBPAW_ALLOCATE(ff,(nrad)) 5539 5540 ! Contribution from spherical part of rho 5541 ff(:)=fxci(:)*four_pi 5542 5543 ! Contribution from aspherical part of rho 5544 if (option/=4) then 5545 5546 ! First order development 5547 if (pawxcdev>=1) then 5548 ff(:)=ff(:)+v1sum(:,2)*d1vxc(:,2) & 5549 & +half*(v1sum(:,1)*d1vxc(:,1)+v1sum(:,3)*d1vxc(:,3)) 5550 end if 5551 5552 ! Second order development 5553 if (pawxcdev>=2) then 5554 LIBPAW_ALLOCATE(gg,(nrad)) 5555 gg=zero 5556 do ilm=2,lm_size 5557 if (lmselect(ilm)) gg(:)=gg(:)+v2sum(:,ilm,1)*rhotot(:,ilm) 5558 end do 5559 ff(:)=ff(:)+gg(:)*d2vxc(:,1)/6._dp 5560 gg=zero 5561 do ilm=2,lm_size 5562 if (lmselect(ilm)) gg(:)=gg(:)+v2sum(:,ilm,2)*rhotot(:,ilm) 5563 end do 5564 ff(:)=ff(:) +half*gg(:)*d2vxc(:,2) 5565 gg=zero 5566 do ilm=2,lm_size 5567 if (lmselect(ilm)) gg(:)=gg(:)+v2sum(:,ilm,3)*rhotot(:,ilm) 5568 end do 5569 ff(:)=ff(:) +half*gg(:)*d2vxc(:,3) 5570 gg=zero 5571 do ilm=2,lm_size 5572 if (lmselect_ep(ilm)) gg(:)=gg(:)+v2sum(:,ilm,3)*rhotot_ep(:,ilm) 5573 end do 5574 ff(:)=ff(:)+gg(:)*d2vxc(:,4)/6._dp 5575 LIBPAW_DEALLOCATE(gg) 5576 end if ! pawxcdev>=2 5577 5578 end if ! option/=4 5579 5580 ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2 5581 call simp_gen(enxc,ff,pawrad) 5582 LIBPAW_DEALLOCATE(ff) 5583 end if ! option/=1 5584 5585 LIBPAW_DEALLOCATE(fxci) 5586 if (option<3.or.option/=1) then 5587 LIBPAW_DEALLOCATE(v1sum) 5588 LIBPAW_DEALLOCATE(v2sum) 5589 end if 5590 if (option<3.or.(option/=4.and.pawxcdev>1)) then 5591 LIBPAW_DEALLOCATE(d2vxc) 5592 end if 5593 if (option/=4) then 5594 LIBPAW_DEALLOCATE(d1vxc) 5595 end if 5596 5597 !----- Calculate Excdc double counting term 5598 !------------------------------------------ 5599 if (option==0.or.option==2) then 5600 5601 ! Build appropriate density 5602 if (usexcnhat==1) rhotot(:,:)=rhotot(:,:)+nhat(:,:,1) 5603 if (usecore==1.and.calctype==2) rhotot(:,1)=rhotot(:,1)-sqfpi*corexc(:) 5604 5605 ! Integrate with potential 5606 LIBPAW_ALLOCATE(ff,(nrad)) 5607 ff(:)=zero 5608 do ilm=1,lm_size 5609 if (lmselect(ilm)) ff(:)=ff(:)+vxc(:,ilm,1)*rhotot(:,ilm) 5610 end do 5611 ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2 5612 call simp_gen(enxcdc,ff,pawrad) 5613 LIBPAW_DEALLOCATE(ff) 5614 end if ! option 5615 5616 LIBPAW_DEALLOCATE(rhotot) 5617 LIBPAW_DEALLOCATE(rhotot_ep) 5618 5619 end subroutine pawxcmpositron
m_pawxc/pawxcpositron [ Functions ]
[ Top ] [ m_pawxc ] [ Functions ]
NAME
pawxcpositron
FUNCTION
Compute electron-positron correlation potential and energies inside a PAW sphere LDA ONLY - USE THE DENSITY OVER A WHOLE SPHERICAL GRID (r,theta,phi) Driver of XC functionals.
INPUTS
calctype=type of electronpositron calculation:
calctype=1 : positron in electronic density
calctype=2 : electrons in positronic density
corexc(nrad)=electron core density on radial grid
ixcpositron=choice of electron-positron XC scheme
lm_size=size of density array rhor (see below)
lmselect (lm_size)=select the non-zero LM-moments of input density rhor (see below)
lmselect_ep(lm_size)=select the non-zero LM-moments of input density rhor_ep (see below)
nhat (nrad,lm_size,nspden)=compensation density corresponding to rhor
nhat_ep(nrad,lm_size,nspden)=compensation density corresponding to rhor_ep
nrad=size of radial mesh for densities/potentials (might be different from pawrad%mesh_size)
nspden=number of spin-density components
option=0 compute both XC energies (direct+double-counting) and potential
1 compute only XC potential
2 compute only XC energies (direct+double-counting)
3 compute only XC energy by direct scheme
4 compute only XC energy by direct scheme for spherical part of the density
pawang <type(pawang_type)>=paw angular mesh and related data
pawrad <type(pawrad_type)>=paw radial mesh and related data
posdensity0_limit=True if we are in the zero positron density limit
rhor(nrad,lm_size,nspden)=electron (or positron) density in real space
(total in 1st half and spin-up in 2nd half if nspden=2)
Contents depends on calctype value:
calctype=1: rhor is the positronic density
calctype=2: rhor is the electronic density
rhor_ep(nrad,lm_size,nspden)=electron (or positron) density in real space
(total in 1st half and spin-up in 2nd half if nspden=2)
Contents depends on calctype value:
calctype=1: rhor_ep is the electronic density
calctype=2: rhor_ep is the positronic density
usecore= 1 if core density has to be used in Exc/Vxc for the electronic density ; 0 otherwise
usexcnhat= 0 if compensation density does not have to be used
1 if compensation density has to be used in double counting energy term only
2 if compensation density (nhat) has to be used in Exc/Vxc and double counting energy term
xc_denpos= lowest allowed density (usually for the computation of the XC functionals)
OUTPUT
== if option==0, 2, 3, or 4 ==
enxc=returned exchange and correlation energy (hartree)
== if option==0 or 2 ==
enxcdc=returned exchange-cor. contribution to double-counting energy
== if option==0 or 1 ==
vxc(nrad,pawang%angl_size,nspden)=xc potential
(spin up in 1st half and spin-down in 2nd half if nspden=2)
SIDE EFFECTS
electronpositron <type(electronpositron_type)>=quantities for the electron-positron annihilation
SOURCE
1828 subroutine pawxcpositron(calctype,corexc,enxc,enxcdc,ixcpositron,lm_size,lmselect,lmselect_ep,& 1829 & nhat,nhat_ep,nrad,nspden,option,pawang,pawrad,posdensity0_limit,& 1830 & rhor,rhor_ep,usecore,usexcnhat,vxc,xc_denpos) 1831 1832 !Arguments ------------------------------------ 1833 !scalars 1834 integer,intent(in) :: calctype,ixcpositron,lm_size,nrad,nspden,option,usecore,usexcnhat 1835 logical,intent(in) :: posdensity0_limit 1836 real(dp),intent(in) :: xc_denpos 1837 real(dp),intent(out) :: enxc,enxcdc 1838 type(pawang_type),intent(in) :: pawang 1839 type(pawrad_type),intent(in) :: pawrad 1840 !arrays 1841 logical,intent(in) :: lmselect(lm_size),lmselect_ep(lm_size) 1842 real(dp),intent(in) :: corexc(nrad) 1843 real(dp),intent(in) :: nhat(nrad,lm_size,nspden*((usexcnhat+1)/2)) 1844 real(dp),intent(in) :: nhat_ep(nrad,lm_size,nspden*((usexcnhat+1)/2)) 1845 real(dp),intent(in) :: rhor(nrad,lm_size,nspden) 1846 real(dp),intent(in) :: rhor_ep(nrad,lm_size,nspden) 1847 real(dp),intent(out) :: vxc(nrad,pawang%angl_size,nspden) 1848 1849 !Local variables------------------------------- 1850 !scalars 1851 integer :: ilm,ipts,iwarn,iwarnp,ngr,ngrad,npts,order 1852 real(dp) :: enxcr,vxcrho 1853 character(len=500) :: msg 1854 !arrays 1855 real(dp),allocatable :: ff(:),fxci(:),grho2(:),rhoarr(:),rhoarr_ep(:),rhoarrdc(:),vxci(:),vxci_ep(:),vxcigr(:) 1856 1857 ! ************************************************************************* 1858 1859 !----- Check options 1860 if(ixcpositron==3.or.ixcpositron==31) then 1861 msg='GGA is not implemented (use pawxcdev/=0)!' 1862 LIBPAW_ERROR(msg) 1863 end if 1864 if(calctype/=1.and.calctype/=2) then 1865 msg='Invalid value for calctype!' 1866 LIBPAW_BUG(msg) 1867 end if 1868 if(pawang%angl_size==0) then 1869 msg='pawang%angl_size=0!' 1870 LIBPAW_BUG(msg) 1871 end if 1872 if(.not.allocated(pawang%ylmr)) then 1873 msg='pawang%ylmr must be allocated!' 1874 LIBPAW_BUG(msg) 1875 end if 1876 if (option/=1) then 1877 if (nrad<pawrad%int_meshsz) then 1878 msg='When option=0,2,3,4, nrad must be greater than pawrad%int_meshsz!' 1879 LIBPAW_BUG(msg) 1880 end if 1881 end if 1882 1883 !---------------------------------------------------------------------- 1884 !----- Initializations 1885 !---------------------------------------------------------------------- 1886 1887 !Initialization and constants 1888 iwarn=0;iwarnp=1 1889 npts=pawang%angl_size 1890 order=1;ngr=0;ngrad=1 ! only LDA here ! 1891 1892 !Initializations of output arrays 1893 if (option/=1) enxc=zero 1894 if (option==0.or.option==2) enxcdc=zero 1895 if (option<3) vxc(:,:,:)=zero 1896 1897 if (ixcpositron==0) then ! No xc at all is applied (usually for testing) 1898 msg = 'Note that no xc is applied (ixcpositron=0). Returning' 1899 LIBPAW_WARNING(msg) 1900 return 1901 end if 1902 1903 !Allocations 1904 LIBPAW_ALLOCATE(fxci,(nrad)) 1905 LIBPAW_ALLOCATE(vxci,(nrad)) 1906 LIBPAW_ALLOCATE(rhoarr,(nrad)) 1907 LIBPAW_ALLOCATE(rhoarr_ep,(nrad)) 1908 if (option==0.or.option==2) then 1909 LIBPAW_ALLOCATE(rhoarrdc,(nrad)) 1910 end if 1911 1912 !---------------------------------------------------------------------- 1913 !----- Loop on the angular part 1914 do ipts=1,npts 1915 1916 ! ---------------------------------------------------------------------- 1917 ! ----- Build several densities 1918 ! ---------------------------------------------------------------------- 1919 1920 ! Eventually add compensation density to input density 1921 rhoarr=zero;rhoarr_ep=zero 1922 if (usexcnhat==2) then 1923 do ilm=1,lm_size 1924 if (lmselect(ilm)) & 1925 & rhoarr(:)=rhoarr(:)+(rhor(:,ilm,1)+nhat(:,ilm,1))*pawang%ylmr(ilm,ipts) 1926 end do 1927 do ilm=1,lm_size 1928 if (lmselect_ep(ilm)) & 1929 & rhoarr_ep(:)=rhoarr_ep(:)+(rhor_ep(:,ilm,1)+nhat_ep(:,ilm,1))*pawang%ylmr(ilm,ipts) 1930 end do 1931 else 1932 do ilm=1,lm_size 1933 if (lmselect(ilm)) rhoarr(:)=rhoarr(:)+rhor(:,ilm,1)*pawang%ylmr(ilm,ipts) 1934 end do 1935 do ilm=1,lm_size 1936 if (lmselect_ep(ilm)) rhoarr_ep(:)=rhoarr_ep(:)+rhor_ep(:,ilm,1)*pawang%ylmr(ilm,ipts) 1937 end do 1938 end if 1939 1940 ! Store density for use in double-counting term 1941 if (option==0.or.option==2) rhoarrdc(:)=rhoarr(:) 1942 1943 ! Eventually add core density 1944 if (usecore==1) then 1945 if (calctype==1) rhoarr_ep(:)=rhoarr_ep(:)+corexc(:) 1946 if (calctype==2) rhoarr (:)=rhoarr (:)+corexc(:) 1947 end if 1948 1949 ! Make the densities positive 1950 if (calctype==1) then 1951 if (.not.posdensity0_limit) then 1952 call pawxc_mkdenpos_wrapper(iwarnp,nrad,1,1,rhoarr,xc_denpos) 1953 end if 1954 call pawxc_mkdenpos_wrapper(iwarn ,nrad,1,1,rhoarr_ep,xc_denpos) 1955 else if (calctype==2) then 1956 call pawxc_mkdenpos_wrapper(iwarn ,nrad,1,1,rhoarr,xc_denpos) 1957 if (.not.posdensity0_limit) then 1958 call pawxc_mkdenpos_wrapper(iwarnp,nrad,1,1,rhoarr_ep,xc_denpos) 1959 end if 1960 end if 1961 1962 ! ---------------------------------------------------------------------- 1963 ! ----- Compute XC data 1964 ! ---------------------------------------------------------------------- 1965 1966 ! electron-positron correlation for the positron 1967 LIBPAW_ALLOCATE(vxci_ep,(nrad)) 1968 LIBPAW_ALLOCATE(vxcigr,(ngr)) 1969 LIBPAW_ALLOCATE(grho2,(ngr)) 1970 if (calctype==1) then 1971 call pawxc_xcpositron_wrapper(fxci,grho2,ixcpositron,ngr,nrad,posdensity0_limit,rhoarr_ep,rhoarr,vxci_ep,vxcigr,vxci) 1972 else if (calctype==2) then 1973 call pawxc_xcpositron_wrapper(fxci,grho2,ixcpositron,ngr,nrad,posdensity0_limit,rhoarr,rhoarr_ep,vxci,vxcigr,vxci_ep) 1974 end if 1975 LIBPAW_DEALLOCATE(vxci_ep) 1976 LIBPAW_DEALLOCATE(vxcigr) 1977 LIBPAW_DEALLOCATE(grho2) 1978 1979 ! ---------------------------------------------------------------------- 1980 ! ----- Accumulate and store XC potential 1981 ! ---------------------------------------------------------------------- 1982 if (option<3) then 1983 vxc(:,ipts,1)=vxci(:) 1984 if (nspden>=2) vxc(:,ipts,2)=vxci(:) 1985 if (nspden==4) vxc(:,ipts,3:4)=zero 1986 end if 1987 1988 ! ---------------------------------------------------------------------- 1989 ! ----- Accumulate and store XC energies 1990 ! ---------------------------------------------------------------------- 1991 1992 ! ----- Calculate Exc term 1993 if (option/=1) then 1994 LIBPAW_ALLOCATE(ff,(nrad)) 1995 ff(1:nrad)=fxci(1:nrad)*pawrad%rad(1:nrad)**2 1996 call simp_gen(enxcr,ff,pawrad) 1997 LIBPAW_DEALLOCATE(ff) 1998 if (option/=4) enxc=enxc+enxcr*pawang%angwgth(ipts) 1999 if (option==4) enxc=enxc+enxcr 2000 end if 2001 2002 ! ----- Calculate Excdc double counting term 2003 if (option==0.or.option==2) then 2004 if (usexcnhat==1) then 2005 do ilm=1,lm_size 2006 if (lmselect(ilm)) then 2007 rhoarrdc(:)=rhoarrdc(:)+nhat(:,ilm,1)*pawang%ylmr(ilm,ipts) 2008 end if 2009 end do 2010 end if 2011 LIBPAW_ALLOCATE(ff,(nrad)) 2012 ff(1:nrad)=vxci(1:nrad)*rhoarrdc(1:nrad)*pawrad%rad(1:nrad)**2 2013 call simp_gen(vxcrho,ff,pawrad) 2014 LIBPAW_DEALLOCATE(ff) 2015 enxcdc=enxcdc+vxcrho*pawang%angwgth(ipts) 2016 end if 2017 2018 ! --------------------------------------------------- 2019 ! ----- End of the loop on npts (angular part) 2020 end do 2021 2022 !Add the four*pi factor of the angular integration 2023 if (option/=1) enxc=enxc*four_pi 2024 if (option==0.or.option==2) enxcdc=enxcdc*four_pi 2025 2026 !Deallocations 2027 LIBPAW_DEALLOCATE(fxci) 2028 LIBPAW_DEALLOCATE(vxci) 2029 LIBPAW_DEALLOCATE(rhoarr) 2030 LIBPAW_DEALLOCATE(rhoarr_ep) 2031 if (option==0.or.option==2) then 2032 LIBPAW_DEALLOCATE(rhoarrdc) 2033 end if 2034 2035 end subroutine pawxcpositron
m_pawxc/pawxcsph [ Functions ]
[ Top ] [ m_pawxc ] [ Functions ]
NAME
pawxcsph
FUNCTION
Compute XC energy and potential for a spherical density rho(r) given as (up,dn) Driver of XC functionals. Only treat collinear spins. LDA and GGA
INPUTS
exexch= choice of <<<local>>> exact exchange. Active if exexch>0 (only for GGA) ixc= choice of exchange-correlation scheme (see above and below) nkxc= size of kxc(nrad,nkxc) (XC kernel) nrad= dimension of the radial mesh nspden=number of spin-density components pawrad <type(pawrad_type)>=paw radial mesh and related data rho_updn(nrad,lm_size,nspden)=electron density in real space up (ispden=1) and down (ispden=2) parts If nspden=1, rho_updn(:,:,1) contains (1/2).rho_total xclevel= XC functional level
OUTPUT
exc(nrad)= XC energy density vxc((nrad,nspden)= XC potential === Only if nkxc>0 === kxc(nrad,nkxc)=exchange and correlation kernel (returned only if nkxc/=0) Content of Kxc array: ===== if LDA if nspden==1: kxc(:,1)= d2Exc/drho2 (kxc(:,2)= d2Exc/drho_up drho_dn) if nspden>=2: kxc(:,1)=d2Exc/drho_up drho_up kxc(:,2)=d2Exc/drho_up drho_dn kxc(:,3)=d2Exc/drho_dn drho_dn
SOURCE
2980 subroutine pawxcsph(exc,exexch,hyb_mixing,ixc,kxc,nkxc,nrad,nspden,pawrad,rho_updn,vxc,xclevel) 2981 2982 !Arguments ------------------------------------ 2983 !scalars 2984 integer,intent(in) :: exexch,ixc,nkxc,nrad,nspden,xclevel 2985 real(dp),intent(in) :: hyb_mixing 2986 type(pawrad_type),intent(in) :: pawrad 2987 !arrays 2988 real(dp),intent(in) :: rho_updn(nrad,nspden) 2989 real(dp),intent(out) :: exc(nrad),kxc(nrad,nkxc),vxc(nrad,nspden) 2990 2991 !Local variables------------------------------- 2992 !scalars 2993 integer :: ir,ispden,ndvxc,nspgrad,nvxcdgr,order 2994 integer :: usegradient,uselaplacian,usekden 2995 real(dp),parameter :: tol24=tol12*tol12 2996 real(dp) :: coeff,grho_tot,grho_up,fact 2997 character(len=500) :: msg 2998 !arrays 2999 real(dp) :: d2vxc(1,1) 3000 real(dp),allocatable :: dff(:),dnexcdn(:,:),dvxcdgr(:,:),dvxci(:,:) 3001 real(dp),allocatable :: grho2(:,:),grho_updn(:,:) 3002 3003 ! ************************************************************************* 3004 3005 if(nspden>2)then 3006 write(msg, '(a,a,a,i0)' )& 3007 & 'Only non-spin-polarised or collinear spin-densities are allowed,',ch10,& 3008 & 'while the argument nspden=',nspden 3009 LIBPAW_BUG(msg) 3010 end if 3011 if(nkxc>3)then 3012 msg='nkxc>3 not allowed (GGA)!' 3013 LIBPAW_ERROR(msg) 3014 end if 3015 if(nrad>pawrad%mesh_size)then 3016 msg='nrad > mesh size!' 3017 LIBPAW_BUG(msg) 3018 end if 3019 3020 !Compute sizes of arrays and flags 3021 order=1;if (nkxc>0) order=2 3022 nspgrad=0;if (xclevel==2) nspgrad=3*nspden-1 3023 call pawxc_size_dvxc_wrapper(ixc,order,nspden,& 3024 & usegradient=usegradient,nvxcgrho=nvxcdgr,ndvxc=ndvxc) 3025 uselaplacian=0 ; usekden=0 !metaGGA contributions are not taken into account here 3026 3027 !-------------------------------------------------------------------------- 3028 !-------------- GGA: computation of the gradient of the density 3029 !-------------------------------------------------------------------------- 3030 3031 LIBPAW_ALLOCATE(grho2,(nrad,(2*nspden-1)*usegradient)) 3032 if (xclevel==2) then 3033 3034 ! grho_updn contains the gradient of the radial part 3035 ! grho2(:,1:3) contains the squared norm of this gradient (up, dn and total) 3036 LIBPAW_ALLOCATE(grho_updn,(nrad,nspden)) 3037 3038 ! Gradient of radial part of density 3039 LIBPAW_ALLOCATE(dff,(nrad)) 3040 do ispden=1,nspden 3041 call nderiv_gen(dff,rho_updn(:,ispden),pawrad) 3042 grho_updn(:,ispden)=dff(:) 3043 end do 3044 LIBPAW_DEALLOCATE(dff) 3045 3046 ! Squared norm of the gradient 3047 grho2(:,1)=grho_updn(:,1)**2 3048 if (nspden==2) then 3049 grho2(:,2)=grho_updn(:,2)**2 3050 grho2(:,3)=(grho_updn(:,1)+grho_updn(:,2))**2 3051 end if 3052 3053 end if 3054 3055 !-------------------------------------------------------------------------- 3056 !-------------- Computation of Exc, Vxc (and Kxc) 3057 !-------------------------------------------------------------------------- 3058 3059 !Allocate arrays 3060 LIBPAW_ALLOCATE(dvxci,(nrad,ndvxc)) 3061 LIBPAW_ALLOCATE(dvxcdgr,(nrad,nvxcdgr)) 3062 3063 !Call to main XC driver 3064 call pawxc_drivexc_wrapper(hyb_mixing,ixc,order,nrad,nspden,& 3065 & usegradient,uselaplacian,usekden,rho_updn,exc,vxc,& 3066 & nvxcdgr,0,0,ndvxc,0,grho2=grho2,vxcgrho=dvxcdgr,& 3067 & dvxc=dvxci,d2vxc=d2vxc,exexch=exexch) 3068 3069 !Transfer the XC kernel 3070 if (nkxc>0.and.ndvxc>0) then 3071 if (nkxc==1.and.ndvxc==15) then 3072 kxc(1:nrad,1)=half*(dvxci(1:nrad,1)+dvxci(1:nrad,9)+dvxci(1:nrad,10)) 3073 else if (nkxc==3.and.ndvxc==15) then 3074 kxc(1:nrad,1)=dvxci(1:nrad,1)+dvxci(1:nrad,9) 3075 kxc(1:nrad,2)=dvxci(1:nrad,10) 3076 kxc(1:nrad,3)=dvxci(1:nrad,2)+dvxci(1:nrad,11) 3077 else if (nkxc==7.and.ndvxc==8) then 3078 kxc(1:nrad,1)=half*dvxci(1:nrad,1) 3079 kxc(1:nrad,2)=half*dvxci(1:nrad,3) 3080 kxc(1:nrad,3)=quarter*dvxci(1:nrad,5) 3081 kxc(1:nrad,4)=eighth*dvxci(1:nrad,7) 3082 else if (nkxc==7.and.ndvxc==15) then 3083 kxc(1:nrad,1)=half*(dvxci(1:nrad,1)+dvxci(1:nrad,9)+dvxci(1:nrad,10)) 3084 kxc(1:nrad,2)=half*dvxci(1:nrad,3)+dvxci(1:nrad,12) 3085 kxc(1:nrad,3)=quarter*dvxci(1:nrad,5)+dvxci(1:nrad,13) 3086 kxc(1:nrad,4)=eighth*dvxci(1:nrad,7)+dvxci(1:nrad,15) 3087 else if (nkxc==19.and.ndvxc==15) then 3088 kxc(1:nrad,1)=dvxci(1:nrad,1)+dvxci(1:nrad,9) 3089 kxc(1:nrad,2)=dvxci(1:nrad,10) 3090 kxc(1:nrad,3)=dvxci(1:nrad,2)+dvxci(1:nrad,11) 3091 kxc(1:nrad,4)=dvxci(1:nrad,3) 3092 kxc(1:nrad,5)=dvxci(1:nrad,4) 3093 kxc(1:nrad,6)=dvxci(1:nrad,5) 3094 kxc(1:nrad,7)=dvxci(1:nrad,6) 3095 kxc(1:nrad,8)=dvxci(1:nrad,7) 3096 kxc(1:nrad,9)=dvxci(1:nrad,8) 3097 kxc(1:nrad,10)=dvxci(1:nrad,12) 3098 kxc(1:nrad,11)=dvxci(1:nrad,13) 3099 kxc(1:nrad,12)=dvxci(1:nrad,14) 3100 kxc(1:nrad,13)=dvxci(1:nrad,15) 3101 else ! Other cases 3102 kxc(1:nrad,1:nkxc)=zero 3103 kxc(1:nrad,1:min(nkxc,ndvxc))=dvxci(1:nrad,1:min(nkxc,ndvxc)) 3104 end if 3105 if (nkxc==7) then 3106 kxc(1:nrad,5)=grho_updn(1:nrad,1) ! Not correct 3107 kxc(1:nrad,6)=grho_updn(1:nrad,1) ! Not correct 3108 kxc(1:nrad,7)=grho_updn(1:nrad,1) ! Not correct 3109 else if (nkxc==19) then 3110 kxc(1:nrad,14)=grho_updn(1:nrad,1) ! Not correct 3111 kxc(1:nrad,15)=grho_updn(1:nrad,2) ! Not correct 3112 kxc(1:nrad,16)=grho_updn(1:nrad,1) ! Not correct 3113 kxc(1:nrad,17)=grho_updn(1:nrad,2) ! Not correct 3114 kxc(1:nrad,18)=grho_updn(1:nrad,1) ! Not correct 3115 kxc(1:nrad,19)=grho_updn(1:nrad,2) ! Not correct 3116 end if 3117 end if 3118 LIBPAW_DEALLOCATE(dvxci) 3119 3120 !-------------------------------------------------------------------------- 3121 !-------------- GGA: gardient corrections 3122 !-------------------------------------------------------------------------- 3123 3124 if (xclevel==2.and.ixc/=13) then 3125 3126 ! Compute the derivative of Exc with respect to the (spin-)density, 3127 ! or to the norm of the gradient of the (spin-)density, 3128 ! Further divided by the norm of the gradient of the (spin-)density 3129 ! The different components of dnexcdn will be 3130 ! for nspden=1, dnexcdn(:,1)=d(n.exc)/d(n) 3131 ! and if xclevel=2, dnexcdn(:,2)=1/2*1/|grad n_up|*d(n.exc)/d(|grad n_up|) 3132 ! + 1/|grad n|*d(n.exc)/d(|grad n|) 3133 ! (do not forget : |grad n| /= |grad n_up| + |grad n_down| 3134 ! for nspden=2, dnexcdn(:,1)=d(n.exc)/d(n_up) 3135 ! dnexcdn(:,2)=d(n.exc)/d(n_down) 3136 ! and if xclevel=2, dnexcdn(:,3)=1/|grad n_up|*d(n.exc)/d(|grad n_up|) 3137 ! dnexcdn(:,4)=1/|grad n_down|*d(n.exc)/d(|grad n_down|) 3138 ! dnexcdn(:,5)=1/|grad n|*d(n.exc)/d(|grad n|) 3139 LIBPAW_ALLOCATE(dnexcdn,(nrad,nspgrad)) 3140 ! LDA term 3141 dnexcdn(:,1:nspden)=vxc(:,1:nspden) 3142 ! Additional GGA terms 3143 do ir=1,nrad 3144 do ispden=1,3 ! spin_up, spin_down and total spin density 3145 if (nspden==1.and.ispden>=2) exit 3146 ! If the norm of the gradient vanishes, then the different terms 3147 ! vanishes, but the inverse of the gradient diverges, 3148 ! so skip the update. 3149 if(grho2(ir,ispden)<tol24) then 3150 dnexcdn(ir,ispden+nspden)=zero;cycle 3151 end if 3152 ! Compute the derivative of n.e_xc wrt the spin up, spin down, 3153 ! or total density. In the non-spin-polarized case take the coeff. 3154 ! that will be multiplied by the gradient of the total density. 3155 if (nvxcdgr/=0) then 3156 if (nspden==1) then 3157 ! Definition of dvxcdgr changed in v3.3 3158 if (nvxcdgr==3) then 3159 coeff=half*dvxcdgr(ir,1)+dvxcdgr(ir,3) 3160 else 3161 coeff=half*dvxcdgr(ir,1) 3162 end if 3163 else if (nspden==2)then 3164 if (nvxcdgr==3) then 3165 coeff=dvxcdgr(ir,ispden) 3166 else if (ispden/=3) then 3167 coeff=dvxcdgr(ir,ispden) 3168 else if (ispden==3) then 3169 coeff=zero 3170 end if 3171 end if 3172 end if 3173 dnexcdn(ir,ispden+nspden)=coeff 3174 end do 3175 end do 3176 3177 ! Calculate grad(rho)*dnexcdn and put it in grho_updn(:,:) 3178 if (nvxcdgr/=0) then 3179 if(nspden==1)then 3180 grho_updn(:,1)=grho_updn(:,1)*dnexcdn(:,2) 3181 else 3182 do ir=1,nrad 3183 grho_up=grho_updn(ir,1);grho_tot=grho_up+grho_updn(ir,2) 3184 grho_updn(ir,1)=grho_up*dnexcdn(ir,3)+grho_tot*dnexcdn(ir,5) 3185 grho_updn(ir,2)=(grho_tot-grho_up)*dnexcdn(ir,4)+grho_tot*dnexcdn(ir,5) 3186 end do 3187 end if 3188 end if 3189 LIBPAW_DEALLOCATE(dnexcdn) 3190 3191 ! Compute Vxc 3192 LIBPAW_ALLOCATE(dff,(nrad)) 3193 fact=one;if (nspden==1) fact=two 3194 do ispden=1,nspden 3195 call nderiv_gen(dff,grho_updn(:,ispden),pawrad) 3196 vxc(2:nrad,ispden)=vxc(2:nrad,ispden)-fact*(dff(2:nrad)+two*grho_updn(2:nrad,ispden)/pawrad%rad(2:nrad)) 3197 call pawrad_deducer0(vxc(:,ispden),nrad,pawrad) 3198 end do 3199 LIBPAW_DEALLOCATE(dff) 3200 3201 end if ! xclevel==2 3202 3203 !-------------------------------------------------------------------------- 3204 !-------------- Deallocations 3205 !-------------------------------------------------------------------------- 3206 3207 LIBPAW_DEALLOCATE(grho2) 3208 LIBPAW_DEALLOCATE(dvxcdgr) 3209 if (xclevel==2) then 3210 LIBPAW_DEALLOCATE(grho_updn) 3211 end if 3212 3213 end subroutine pawxcsph
m_pawxc/pawxcsph_dfpt [ Functions ]
[ Top ] [ m_pawxc ] [ Functions ]
NAME
pawxcsph_dfpt
FUNCTION
Compute XC 1st-order potential for a 1st-order spherical density rho1(r) associated to a spherical density, both given as (up,dn) Driver of XC functionals. Only treat collinear spins. LDA and GGA
INPUTS
cplex_den= if 1, 1st-order densities are REAL, if 2, COMPLEX cplex_vxc= if 1, 1st-order XC potential is complex, if 2, COMPLEX ixc= choice of exchange-correlation scheme (see above and below) nrad= dimension of the radial mesh nspden=number of spin-density components pawrad <type(pawrad_type)>=paw radial mesh and related data rho_updn(nrad,lm_size,nspden)=electron density in real space up (ispden=1) and down (ispden=2) parts If nspden=1, rho_updn(:,:,1) contains (1/2).rho_total rho1_updn(nrad,lm_size,nspden)=electron 1st-order density in real space up (ispden=1) and down (ispden=2) parts If nspden=1, rho_updn(:,:,1) contains (1/2).rho1_total xclevel= XC functional level
OUTPUT
vxc1((nrad,nspden)= XC 1st-order potential
SOURCE
3248 subroutine pawxcsph_dfpt(cplex_den,cplex_vxc,ixc,nrad,nspden,pawrad,rho_updn,rho1_updn,vxc1,xclevel) 3249 3250 !Arguments ------------------------------------ 3251 !scalars 3252 integer,intent(in) :: cplex_den,cplex_vxc,ixc,nrad,nspden,xclevel 3253 type(pawrad_type),intent(in) :: pawrad 3254 !arrays 3255 real(dp),intent(in) :: rho_updn(nrad,nspden),rho1_updn(cplex_den*nrad,nspden) 3256 real(dp),intent(out) :: vxc1(cplex_vxc*nrad,nspden) 3257 3258 !Local variables------------------------------- 3259 !scalars 3260 integer :: ii,ir,ispden,ivxc,jr,kr,ndvxc,ngrad,nkxc,nvxcdgr,order,usegradient 3261 real(dp),parameter :: tol24=tol12*tol12 3262 !real(dp) :: coeff_grho_corr,coeff_grho_dn,coeff_grho_up,fact 3263 !real(dp) :: grho_grho1,grho_grho1_dn,grho_grho1_up 3264 character(len=500) :: msg 3265 real(dp),parameter :: hyb_mixing_ = 0.0_dp 3266 !arrays 3267 integer,parameter :: ikxc(4)=(/1,2,2,3/),irho(4)=(/1,2,1,2/) 3268 real(dp),allocatable :: dff(:),dgg(:),dvxcdgr(:,:),dvxc(:,:),exc(:),ff(:),gg(:) 3269 real(dp),allocatable :: grho_updn(:,:),grho1_updn(:,:),grho2(:,:) 3270 real(dp),allocatable :: kxc(:,:),vxc(:,:) 3271 !real(dp),allocatable :: gxc1i(:,:),gxc1r(:,:),vxc1i(:,:),vxc1r(:,:) 3272 3273 ! ************************************************************************* 3274 3275 if(nspden>2)then 3276 write(msg, '(a,a,a,i0)' )& 3277 & 'Only non-spin-polarised or collinear spin-densities are allowed,',ch10,& 3278 & 'while the argument nspden=',nspden 3279 LIBPAW_BUG(msg) 3280 end if 3281 if(nrad>pawrad%mesh_size)then 3282 msg='nrad > mesh size!' 3283 LIBPAW_BUG(msg) 3284 end if 3285 3286 !Compute sizes of arrays and flags 3287 order=2 ! We need Kxc 3288 ngrad=1;if (xclevel==2) ngrad=2 ! ngrad=1 is for LDAs or LSDs; ngrad=2 is for GGAs 3289 nkxc=2*nspden-1;if (xclevel==2) nkxc=15 ! Not correct for nspden=1 3290 call pawxc_size_dvxc_wrapper(ixc,order,nspden,usegradient=usegradient,nvxcgrho=nvxcdgr,ndvxc=ndvxc) 3291 3292 !-------------------------------------------------------------------------- 3293 !-------------- GGA: computation of the gradients of the densities 3294 !-------------------------------------------------------------------------- 3295 3296 LIBPAW_ALLOCATE(grho2,(nrad,(2*nspden-1)*usegradient)) 3297 if (ngrad==2) then 3298 3299 LIBPAW_ALLOCATE(grho_updn,(nrad,nspden)) 3300 LIBPAW_ALLOCATE(grho1_updn,(cplex_den*nrad,nspden)) 3301 3302 ! Gradient of density 3303 LIBPAW_ALLOCATE(dff,(nrad)) 3304 do ispden=1,nspden 3305 call nderiv_gen(dff,rho_updn(:,ispden),pawrad) 3306 grho_updn(:,ispden)=dff(:) 3307 end do 3308 ! Gradient of 1st-order density 3309 if (cplex_den==1) then 3310 do ispden=1,nspden 3311 call nderiv_gen(dff,rho1_updn(:,ispden),pawrad) 3312 grho1_updn(:,ispden)=dff(:) 3313 end do 3314 else 3315 LIBPAW_ALLOCATE(ff,(nrad)) 3316 LIBPAW_ALLOCATE(gg,(nrad)) 3317 LIBPAW_ALLOCATE(dgg,(nrad)) 3318 do ispden=1,nspden 3319 do ir=1,nrad 3320 ff(ir)=rho1_updn(2*ir-1,ispden) 3321 gg(ir)=rho1_updn(2*ir ,ispden) 3322 end do 3323 call nderiv_gen(dff,ff,pawrad) 3324 call nderiv_gen(dgg,gg,pawrad) 3325 do ir=1,nrad 3326 grho1_updn(2*ir-1,ispden)=dff(ir) 3327 grho1_updn(2*ir ,ispden)=dgg(ir) 3328 end do 3329 end do 3330 LIBPAW_DEALLOCATE(ff) 3331 LIBPAW_DEALLOCATE(gg) 3332 LIBPAW_DEALLOCATE(dgg) 3333 end if 3334 LIBPAW_DEALLOCATE(dff) 3335 3336 ! Squared norm of the gradient 3337 grho2(:,1)=grho_updn(:,1)**2 3338 if (nspden==2) then 3339 grho2(:,2)=grho_updn(:,2)**2 3340 grho2(:,3)=(grho_updn(:,1)+grho_updn(:,2))**2 3341 end if 3342 3343 end if 3344 3345 !-------------------------------------------------------------------------- 3346 !-------------- Computation of Kxc (and Exc, Vxc) 3347 !-------------------------------------------------------------------------- 3348 3349 LIBPAW_ALLOCATE(exc,(nrad)) 3350 LIBPAW_ALLOCATE(vxc,(nrad,nspden)) 3351 LIBPAW_ALLOCATE(dvxc,(nrad,ndvxc)) 3352 LIBPAW_ALLOCATE(dvxcdgr,(nrad,nvxcdgr)) 3353 3354 !Call to main XC driver 3355 call pawxc_drivexc_wrapper(hyb_mixing_,ixc,order,nrad,nspden,usegradient,0,0,& 3356 & rho_updn,exc,vxc,nvxcdgr,0,0,ndvxc,0,& 3357 & grho2=grho2,vxcgrho=dvxcdgr,dvxc=dvxc) 3358 3359 !Transfer the XC kernel 3360 LIBPAW_ALLOCATE(kxc,(nrad,nkxc)) 3361 if (nkxc>0.and.ndvxc>0) then 3362 if (nkxc==1.and.ndvxc==15) then 3363 kxc(1:nrad,1)=half*(dvxc(1:nrad,1)+dvxc(1:nrad,9)+dvxc(1:nrad,10)) 3364 else if (nkxc==3.and.ndvxc==15) then 3365 kxc(1:nrad,1)=dvxc(1:nrad,1)+dvxc(1:nrad,9) 3366 kxc(1:nrad,2)=dvxc(1:nrad,10) 3367 kxc(1:nrad,3)=dvxc(1:nrad,2)+dvxc(1:nrad,11) 3368 else if (nkxc==7.and.ndvxc==8) then 3369 kxc(1:nrad,1)=half*dvxc(1:nrad,1) 3370 kxc(1:nrad,2)=half*dvxc(1:nrad,3) 3371 kxc(1:nrad,3)=quarter*dvxc(1:nrad,5) 3372 kxc(1:nrad,4)=eighth*dvxc(1:nrad,7) 3373 else if (nkxc==7.and.ndvxc==15) then 3374 kxc(1:nrad,1)=half*(dvxc(1:nrad,1)+dvxc(1:nrad,9)+dvxc(1:nrad,10)) 3375 kxc(1:nrad,2)=half*dvxc(1:nrad,3)+dvxc(1:nrad,12) 3376 kxc(1:nrad,3)=quarter*dvxc(1:nrad,5)+dvxc(1:nrad,13) 3377 kxc(1:nrad,4)=eighth*dvxc(1:nrad,7)+dvxc(1:nrad,15) 3378 else if (nkxc==19.and.ndvxc==15) then 3379 kxc(1:nrad,1)=dvxc(1:nrad,1)+dvxc(1:nrad,9) 3380 kxc(1:nrad,2)=dvxc(1:nrad,10) 3381 kxc(1:nrad,3)=dvxc(1:nrad,2)+dvxc(1:nrad,11) 3382 kxc(1:nrad,4)=dvxc(1:nrad,3) 3383 kxc(1:nrad,5)=dvxc(1:nrad,4) 3384 kxc(1:nrad,6)=dvxc(1:nrad,5) 3385 kxc(1:nrad,7)=dvxc(1:nrad,6) 3386 kxc(1:nrad,8)=dvxc(1:nrad,7) 3387 kxc(1:nrad,9)=dvxc(1:nrad,8) 3388 kxc(1:nrad,10)=dvxc(1:nrad,12) 3389 kxc(1:nrad,11)=dvxc(1:nrad,13) 3390 kxc(1:nrad,12)=dvxc(1:nrad,14) 3391 kxc(1:nrad,13)=dvxc(1:nrad,15) 3392 else ! Other cases 3393 kxc(1:nrad,1:nkxc)=zero 3394 kxc(1:nrad,1:min(nkxc,ndvxc))=dvxc(1:nrad,1:min(nkxc,ndvxc)) 3395 end if 3396 if (nkxc==7) then 3397 kxc(1:nrad,5)=zero ! Not correct 3398 kxc(1:nrad,6)=zero ! Not correct 3399 kxc(1:nrad,7)=zero ! Not correct 3400 else if (nkxc==19) then 3401 kxc(1:nrad,14)=zero ! Not correct 3402 kxc(1:nrad,15)=zero ! Not correct 3403 kxc(1:nrad,16)=zero ! Not correct 3404 kxc(1:nrad,17)=zero ! Not correct 3405 kxc(1:nrad,18)=zero ! Not correct 3406 kxc(1:nrad,19)=zero ! Not correct 3407 end if 3408 end if 3409 3410 LIBPAW_DEALLOCATE(exc) 3411 LIBPAW_DEALLOCATE(vxc) 3412 LIBPAW_DEALLOCATE(dvxc) 3413 LIBPAW_DEALLOCATE(dvxcdgr) 3414 3415 !-------------------------------------------------------------------------- 3416 !-------------- LDA 3417 !-------------------------------------------------------------------------- 3418 if (ngrad==1.or.ixc==13) then 3419 3420 do ispden=1,3*nspden-2 3421 ivxc=1;if (ispden>2) ivxc=2 3422 if (cplex_vxc==1.and.cplex_den==1) then 3423 vxc1(:,ivxc)=vxc1(:,ivxc)+kxc(:,ikxc(ii))*rho1_updn(:,irho(ii)) 3424 else 3425 do ir=1,nrad 3426 jr=cplex_den*(ir-1);kr=cplex_vxc*(ir-1) 3427 do ii=1,1+(cplex_den*cplex_vxc)/4 3428 jr=jr+1;kr=kr+1 3429 vxc1(kr,ivxc)=vxc1(kr,ivxc)+kxc(ir,ikxc(ii))*rho1_updn(jr,irho(ii)) 3430 end do 3431 end do 3432 end if 3433 end do 3434 3435 ! -------------------------------------------------------------------------- 3436 ! -------------- GGA 3437 ! -------------------------------------------------------------------------- 3438 else 3439 3440 ! FOR NSPDEN=1, should eliminate computation of gxc1i(...), vxc1i(...) 3441 3442 ! LIBPAW_ALLOCATE(vxc1r,(nrad,2)) 3443 ! LIBPAW_ALLOCATE(vxc1i,(nrad,2)) 3444 ! LIBPAW_ALLOCATE(gxc1r,(nrad,2)) 3445 ! LIBPAW_ALLOCATE(gxc1i,(nrad,2)) 3446 ! do ir=1,nrad 3447 ! if (cplex_vxc==1) then ! cplex_vxc==1 and (cplex_den==1 or cplex_den=2) 3448 ! jr=cplex_den*(ir-1)+1 3449 ! grho_grho1_up=grho_updn(ir,1)*grho1_updn(jr,1) 3450 ! grho_grho1_dn=grho_updn(ir,2)*grho1_updn(jr,2) 3451 ! vxc1r(ir,1)=(kxc(ir, 1)+kxc(ir, 9))*rho1_updn(jr,1)+kxc(ir,10)*rho1_updn(jr,2) & 3452 ! & +kxc(ir, 5)*grho_grho1_up+kxc(ir,13)*grho_grho1 3453 ! vxc1r(ir,2)=(kxc(ir, 2)+kxc(ir,11))*rho1_updn(jr,2)+kxc(ir,10)*rho1_updn(jr,1) & 3454 ! & +kxc(ir, 6)*grho_grho1_dn+kxc(ir,14)*grho_grho1 3455 ! coeff_grho_corr=kxc(ir,13)*rho1_updn(jr,1)+kxc(ir,14)*rho1_updn(jr,2)+kxc(ir,15)*grho_grho1 3456 ! coeff_grho_up =kxc(ir, 5)*rho1_updn(jr,1)+kxc(ir, 7)*grho_grho1_up 3457 ! coeff_grho_dn =kxc(ir, 6)*rho1_updn(jr,2)+kxc(ir, 8)*grho_grho1_dn 3458 ! gxc1r(ir,1)=(kxc(ir, 3)+kxc(ir,12))*grho1_updn(jr,1)+kxc(ir,12)*grho1_updn(jr,2) & 3459 ! & +coeff_grho_up*grho_updn(jr,1)+coeff_grho_corr*(grho_updn(jr,1)+grho_updn(jr,2)) 3460 ! gxc1r(ir,2)=(kxc(ir, 4)+kxc(ir,12))*grho1_updn(jr,2)+kxc(ir,12)*grho1_updn(jr,1) & 3461 ! & +coeff_grho_dn*grho_updn(jr,2)+coeff_grho_corr*(grho_updn(jr,1)+grho_updn(jr,2)) 3462 ! end if 3463 ! if (grho2(ir,1)<tol24) gxc1r(ir,:)=zero ! ??? 3464 ! end do 3465 ! 3466 ! ! Apply divergence 3467 ! fact=one;if (nspden==1) fact=two ! Is it true ? we force nspden=2 for gxc... 3468 ! if (cplex_vxc==1) then 3469 ! LIBPAW_ALLOCATE(dff,(nrad)) 3470 ! do ispden=1,nspden 3471 ! call nderiv_gen(dff,gxc1r(:,ispden),pawrad) 3472 ! vxc1(2:nrad,ispden)=vxc1r(2:nrad,ispden)-fact*(dff(2:nrad)+two*gxc1r(2:nrad,ispden)/pawrad%rad(2:nrad)) 3473 ! call pawrad_deducer0(vxc1(:,ispden),nrad,pawrad) 3474 ! end do 3475 ! LIBPAW_DEALLOCATE(dff) 3476 ! else 3477 ! LIBPAW_ALLOCATE(dff,(nrad)) 3478 ! LIBPAW_ALLOCATE(dgg,(nrad)) 3479 ! LIBPAW_ALLOCATE(ff,(nrad)) 3480 ! LIBPAW_ALLOCATE(gg,(nrad)) 3481 ! do ispden=1,nspden 3482 ! call nderiv_gen(dff,gxc1r(:,ispden),pawrad) 3483 ! call nderiv_gen(dgg,gxc1i(:,ispden),pawrad) 3484 ! ff(2:nrad)=vxc1r(2:nrad,ispden)-fact*(dff(2:nrad)+two*gxc1r(2:nrad,ispden)/pawrad%rad(2:nrad)) 3485 ! gg(2:nrad)=vxc1i(2:nrad,ispden)-fact*(dgg(2:nrad)+two*gxc1i(2:nrad,ispden)/pawrad%rad(2:nrad)) 3486 ! call pawrad_deducer0(ff,nrad,pawrad) 3487 ! call pawrad_deducer0(gg,nrad,pawrad) 3488 ! do ir=1,nrad 3489 ! vxc1(2*ir-1,ispden)=ff(ir) 3490 ! vxc1(2*ir ,ispden)=gg(ir) 3491 ! end do 3492 ! end do 3493 ! LIBPAW_DEALLOCATE(dff) 3494 ! LIBPAW_DEALLOCATE(dgg) 3495 ! LIBPAW_DEALLOCATE(ff) 3496 ! LIBPAW_DEALLOCATE(gg) 3497 ! end if 3498 ! 3499 ! LIBPAW_DEALLOCATE(vxc1r) 3500 ! LIBPAW_DEALLOCATE(vxc1i) 3501 ! LIBPAW_DEALLOCATE(gxc1r) 3502 ! LIBPAW_DEALLOCATE(gxc1i) 3503 3504 end if ! ngrad==2 3505 3506 !-------------------------------------------------------------------------- 3507 !-------------- Deallocations 3508 !-------------------------------------------------------------------------- 3509 3510 LIBPAW_DEALLOCATE(grho2) 3511 LIBPAW_DEALLOCATE(kxc) 3512 if (ngrad==2) then 3513 LIBPAW_DEALLOCATE(grho_updn) 3514 LIBPAW_DEALLOCATE(grho1_updn) 3515 end if 3516 3517 end subroutine pawxcsph_dfpt
m_pawxc/pawxcsphpositron [ Functions ]
[ Top ] [ m_pawxc ] [ Functions ]
NAME
pawxcsphpositron
FUNCTION
Compute electron-positron XC energy and potential for spherical densities rho_el(r) rho_pos(r) Driver of XC functionals. LDA and GGA
INPUTS
calctype=type of electron-positron calculation:
calctype=1 : positron in electronic density
calctype=2 : electrons in positronic density
ixcpositron= choice of elctron-positron exchange-correlation scheme
nrad= dimension of the radial mesh
pawrad <type(pawrad_type)>=paw radial mesh and related data
posdensity0_limit=True if we are in the zero positron density limit
rho(nrad,lm_size)=electron (or positron) density in real space
Contents depends on calctype value:
calctype=1: rho is the positronic density
calctype=2: rho is the electronic density
rho_ep(nrad,lm_size)=electron (or positron) density in real space
Contents depends on calctype value:
calctype=1: rho_ep is the electronic density
calctype=2: rho_ep is the positronic density
OUTPUT
fxc(nrad)= electron-positron XC energy per unit volume vxce(nrad)= electron-positron XC potential for the electron vxcp(nrad)= electron-positron XC potential for the positron
SOURCE
3554 subroutine pawxcsphpositron(calctype,fxc,ixcpositron,nrad,pawrad,posdensity0_limit,rho,rho_ep,vxce,vxcp) 3555 3556 !Arguments ------------------------------------ 3557 !scalars 3558 integer,intent(in) :: calctype,ixcpositron,nrad 3559 logical,intent(in) :: posdensity0_limit 3560 type(pawrad_type),intent(in) :: pawrad 3561 !arrays 3562 real(dp),intent(in) :: rho(nrad),rho_ep(nrad) 3563 real(dp),intent(out) :: fxc(nrad),vxce(nrad),vxcp(nrad) 3564 3565 !Local variables------------------------------- 3566 !scalars 3567 integer :: ngr 3568 character(len=500) :: msg 3569 !arrays 3570 real(dp),allocatable :: dff(:),rhograd(:),rhograd2(:),vxcegr(:) 3571 3572 ! ************************************************************************* 3573 3574 if(nrad>pawrad%mesh_size)then 3575 msg='nrad > mesh size!' 3576 LIBPAW_BUG(msg) 3577 end if 3578 3579 !Need gradient of density for GGA 3580 ngr=0;if (ixcpositron==3.or.ixcpositron==31) ngr=nrad 3581 LIBPAW_ALLOCATE(rhograd,(ngr)) 3582 LIBPAW_ALLOCATE(rhograd2,(ngr)) 3583 LIBPAW_ALLOCATE(vxcegr,(ngr)) 3584 if (ngr==nrad) then 3585 if (calctype==1) then 3586 call nderiv_gen(rhograd,rho_ep,pawrad) 3587 else if (calctype==2) then 3588 call nderiv_gen(rhograd,rho,pawrad) 3589 end if 3590 rhograd2(:)=rhograd(:)**2 3591 end if 3592 3593 !---- Computation of Fxc and Vxc for the positron 3594 !rho is the positronic density 3595 !rho_ep is the electronic density 3596 if (calctype==1) then 3597 call pawxc_xcpositron_wrapper(fxc,rhograd2,ixcpositron,ngr,nrad,posdensity0_limit,rho_ep,rho,vxce,vxcegr,vxcp) 3598 3599 ! ---- Computation of Exc and Vxc for the electron 3600 ! rho is the electronic density 3601 ! rho_ep is the positronic density 3602 else if (calctype==2) then 3603 call pawxc_xcpositron_wrapper(fxc,rhograd2,ixcpositron,ngr,nrad,posdensity0_limit,rho,rho_ep,vxce,vxcegr,vxcp) 3604 end if 3605 3606 LIBPAW_DEALLOCATE(rhograd2) 3607 3608 !---- GGA - gradient corrections 3609 if (ngr==nrad) then 3610 LIBPAW_ALLOCATE(dff,(nrad)) 3611 vxcegr(1:nrad)=vxcegr(1:nrad)*rhograd(1:nrad) 3612 call nderiv_gen(dff,vxcegr,pawrad) 3613 vxcp(2:nrad)=vxcp(2:nrad)-(dff(2:nrad)+two*vxcegr(2:nrad)/pawrad%rad(2:nrad)) 3614 call pawrad_deducer0(vxcp,nrad,pawrad) 3615 LIBPAW_DEALLOCATE(dff) 3616 end if 3617 3618 LIBPAW_DEALLOCATE(vxcegr) 3619 LIBPAW_DEALLOCATE(rhograd) 3620 3621 end subroutine pawxcsphpositron
m_pawxc/pawxcsum [ Functions ]
[ Top ] [ m_pawxc ] [ Functions ]
NAME
pawxcsum
FUNCTION
Compute useful sums of moments of densities needed to compute on-site contributions to XC energy and potential First order sums: Sum1(1)=Sum_L{Rho1_L(r)**2} Sum1(2)=Sum_L{Rho1_L(r)*Rho2_L(r)} Sum1(3)=Sum_L{Rho2_L(r)**2} With L>0 Second order sums: Sum2(L,1)=Sum_L1_L2{Rho1_L1(r)*Rho1_L1(r)*Gaunt_(L,L1,L2)} Sum2(L,2)=Sum_L1_L2{Rho1_L1(r)*Rho2_L2(r)*Gaunt_(L,L1,L2)} Sum2(L,3)=Sum_L1_L2{Rho2_L2(r)*Rho2_L2(r)*Gaunt_(L,L1,L2)} With L1>0, L2>0
INPUTS
cplex1=if 1, density Rho1 is REAL, if 2, COMPLEX
cplex2=if 1, density Rho2 is REAL, if 2, COMPLEX
cplexsum=if 1, output sums (Sum1 and Sum2) are REAL, if 2, COMPLEX
lmselect1(lm_size)=select the non-zero LM-moments of input density Rho1
lmselect2(lm_size)=select the non-zero LM-moments of input density Rho2
lm_size=number of moments of the density
nrad=number of radial points
nsums=number of sums to compute:
if nsums=1, computes only
Sum1(1)=Sum_L{Rho1_L(r)*Rho2_L(r)}
Sum2(L,1)=Sum_L1_L2{Rho1_L1(r)*Rho2_L2(r)*Gaunt_(L,L1,L2)}
if nsums=3, computes all sums (Sum1(1:3), Sum2(1:3)
option= 1: compute first order sums
2: compute first and second order sums
pawang <type(pawang_type)>=paw angular mesh and related data
rho1(cplex1*nrad,lm_size)=moments of first density on each radial point
rho2(cplex2*nrad,lm_size)=moments of 2nd density on each radial point
OUTPUT
sum1(cplexsum*nrad,nsums)=first order sums
=== if option>=2
sum2(cplexsum*nrad,lm_size,nsums)=second order sums
SOURCE
3669 subroutine pawxcsum(cplex1,cplex2,cplexsum,lmselect1,lmselect2,lm_size,nrad,nsums,& 3670 & option,pawang,rho1,rho2,sum1,sum2) 3671 3672 !Arguments ------------------------------------ 3673 !scalars 3674 integer,intent(in) :: cplex1,cplex2,cplexsum,lm_size,nrad,nsums,option 3675 !arrays 3676 logical,intent(in) :: lmselect1(lm_size),lmselect2(lm_size) 3677 real(dp),intent(in) :: rho1(cplex1*nrad,lm_size),rho2(cplex2*nrad,lm_size) 3678 real(dp),intent(out) :: sum1(cplexsum*nrad,nsums),sum2(cplexsum*nrad,lm_size,nsums*(option/2)) 3679 type(pawang_type),intent(in) :: pawang 3680 3681 !Local variables------------------------------- 3682 !scalars 3683 integer :: ilm,ilm1,ilm2,ir,i1r,i2r,i3r,isel 3684 real(dp) :: fact,ro1i,ro1r,ro2i,ro2r 3685 character(len=500) :: msg 3686 !arrays 3687 3688 !************************************************************************ 3689 3690 if(nsums/=1.and.nsums/=3) then 3691 msg='nsums must be 1 or 3!' 3692 LIBPAW_BUG(msg) 3693 end if 3694 if(pawang%gnt_option==0) then 3695 msg='pawang%gnt_option=0!' 3696 LIBPAW_BUG(msg) 3697 end if 3698 3699 if (option>=1) then 3700 3701 ! SUM1(r)= Sum_L{Rho1_L(r)*Rho2_L(r)} (L>0) 3702 ! -------------------------------------------------- 3703 sum1=zero 3704 3705 ! ===== All input/output densities are REAL ==== 3706 if (cplex1==1.and.cplex2==1.and.cplexsum==1) then 3707 ! One sum to compute 3708 if (nsums==1) then 3709 do ilm=2,lm_size 3710 if (lmselect1(ilm).and.lmselect2(ilm)) then 3711 sum1(:,1)=sum1(:,1)+rho1(:,ilm)*rho2(:,ilm) 3712 end if 3713 end do 3714 ! Three sums to compute 3715 else 3716 do ilm=2,lm_size 3717 if (lmselect1(ilm)) then 3718 sum1(:,1)=sum1(:,1)+rho1(:,ilm)**2 3719 if (lmselect2(ilm)) sum1(:,2)=sum1(:,2)+rho1(:,ilm)*rho2(:,ilm) 3720 end if 3721 if (lmselect2(ilm)) sum1(:,3)=sum1(:,3)+rho2(:,ilm)**2 3722 end do 3723 end if 3724 3725 ! ===== At least one of Rho1 and Rho2 is COMPLEX ==== 3726 else 3727 ! One sum to compute 3728 if (nsums==1) then 3729 do ilm=2,lm_size 3730 if (lmselect1(ilm).and.lmselect2(ilm)) then 3731 do ir=1,nrad 3732 i1r=cplex1*(ir-1)+1;i2r=cplex2*(ir-1)+1;i3r=cplexsum*(ir-1)+1 3733 ro1r=rho1(i1r,ilm);ro1i=zero;if (cplex1==2) ro1i=rho1(i1r+1,ilm) 3734 ro2r=rho2(i2r,ilm);ro2i=zero;if (cplex2==2) ro2i=rho2(i2r+1,ilm) 3735 sum1(i3r,1)=sum1(i3r,1)+ro1r*ro2r-ro1i*ro2i 3736 if (cplexsum==2) sum1(i3r+1,1)=sum1(i3r+1,1)+ro1r*ro2i+ro1i*ro2r 3737 end do 3738 end if 3739 end do 3740 ! Three sums to compute 3741 else 3742 do ilm=2,lm_size 3743 do ir=1,nrad 3744 i1r=cplex1*(ir-1)+1;i2r=cplex2*(ir-1)+1;i3r=cplexsum*(ir-1)+1 3745 ro1r=rho1(i1r,ilm);ro1i=zero;if (cplex1==2) ro1i=rho1(i1r+1,ilm) 3746 ro2r=rho2(i2r,ilm);ro2i=zero;if (cplex2==2) ro2i=rho2(i2r+1,ilm) 3747 if (lmselect1(ilm)) then 3748 sum1(i3r,1)=sum1(i3r,1)+ro1r**2-ro1i**2 3749 if (lmselect2(ilm)) sum1(i3r,2)=sum1(i3r,2)+ro1r*ro2r-ro1i*ro2i 3750 end if 3751 if (lmselect2(ilm)) sum1(i3r,3)=sum1(i3r,3)+ro2r**2-ro2i**2 3752 if (cplexsum==2) then 3753 if (lmselect1(ilm)) then 3754 sum1(i3r+1,1)=sum1(i3r+1,1)+two*ro1r*ro1i 3755 if (lmselect2(ilm)) sum1(i3r+1,2)=sum1(i3r+1,2)+ro1r*ro2i+ro1i*ro2r 3756 end if 3757 if (lmselect2(ilm)) sum1(i3r+1,3)=sum1(i3r+1,3)+two*ro2r*ro2i 3758 end if 3759 end do 3760 end do 3761 end if ! nsums 3762 end if ! cplex 3763 3764 end if !option 3765 3766 if (option>=2) then 3767 3768 ! SUM2(r,L)= Sum_L1_L2{Rho1_L1(r)*Rho2_L2(r)*Gaunt_(L,L1,L2)} (L1>0, L2>0) 3769 ! -------------------------------------------------- 3770 sum2=zero 3771 ! ===== All input/output densities are REAL ==== 3772 if (cplex1==1.and.cplex2==1.and.cplexsum==1) then 3773 ! One sum to compute 3774 if (nsums==1) then 3775 do ilm=1,lm_size 3776 do ilm1=2,lm_size 3777 if (lmselect1(ilm1)) then 3778 do ilm2=2,ilm1 3779 if (lmselect2(ilm2)) then 3780 isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2) 3781 if (isel>0) then 3782 fact=pawang%realgnt(isel);if (ilm1/=ilm2) fact=two*fact 3783 sum2(:,ilm,1)=sum2(:,ilm,1)+fact*rho1(:,ilm1)*rho2(:,ilm2) 3784 end if 3785 end if 3786 end do 3787 end if 3788 end do 3789 end do 3790 ! Three sums to compute 3791 else 3792 do ilm=1,lm_size 3793 do ilm1=2,lm_size 3794 if (lmselect1(ilm1)) then 3795 do ilm2=2,ilm1 3796 if (lmselect1(ilm2)) then 3797 isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2) 3798 if (isel>0) then 3799 fact=pawang%realgnt(isel);if (ilm1/=ilm2) fact=two*fact 3800 sum2(:,ilm,1)=sum2(:,ilm,1)+fact*rho1(:,ilm1)*rho1(:,ilm2) 3801 end if 3802 end if 3803 end do 3804 end if 3805 end do 3806 do ilm1=2,lm_size 3807 if (lmselect2(ilm1)) then 3808 do ilm2=2,ilm1 3809 if (lmselect2(ilm2)) then 3810 isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2) 3811 if (isel>0) then 3812 fact=pawang%realgnt(isel);if (ilm1/=ilm2) fact=two*fact 3813 sum2(:,ilm,3)=sum2(:,ilm,3)+fact*rho2(:,ilm1)*rho2(:,ilm2) 3814 end if 3815 end if 3816 end do 3817 end if 3818 end do 3819 do ilm1=2,lm_size 3820 if (lmselect1(ilm1)) then 3821 do ilm2=2,ilm1 3822 if (lmselect2(ilm2)) then 3823 isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2) 3824 if (isel>0) then 3825 fact=pawang%realgnt(isel) 3826 sum2(:,ilm,2)=sum2(:,ilm,2)+fact*rho1(:,ilm1)*rho2(:,ilm2) 3827 end if 3828 end if 3829 end do 3830 if (ilm1<lm_size) then 3831 do ilm2=ilm1+1,lm_size 3832 if (lmselect2(ilm2)) then 3833 isel=pawang%gntselect(ilm,ilm1+ilm2*(ilm2-1)/2) 3834 if (isel>0) then 3835 fact=pawang%realgnt(isel) 3836 sum2(:,ilm,2)=sum2(:,ilm,2)+fact*rho1(:,ilm1)*rho2(:,ilm2) 3837 end if 3838 end if 3839 end do 3840 end if 3841 end if 3842 end do 3843 end do 3844 end if ! nsums 3845 3846 ! ===== At least one of Rho1 and Rho2 is COMPLEX ==== 3847 else 3848 ! One sum to compute 3849 if (nsums==1) then 3850 do ilm=1,lm_size 3851 do ilm1=2,lm_size 3852 if (lmselect1(ilm1)) then 3853 do ilm2=2,ilm1 3854 if (lmselect2(ilm2)) then 3855 isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2) 3856 if (isel>0) then 3857 fact=pawang%realgnt(isel);if (ilm1/=ilm2) fact=two*fact 3858 do ir=1,nrad 3859 i1r=cplex1*(ir-1)+1;i2r=cplex2*(ir-1)+1;i3r=cplexsum*(ir-1)+1 3860 ro1r=rho1(i1r,ilm1);ro1i=zero;if (cplex1==2) ro1i=rho1(i1r+1,ilm1) 3861 ro2r=rho2(i2r,ilm2);ro2i=zero;if (cplex2==2) ro2i=rho2(i2r+1,ilm2) 3862 sum2(i3r,ilm,1)=sum2(i3r,ilm,1)+fact*(ro1r*ro2r-ro1i*ro2i) 3863 if (cplexsum==2) sum2(i3r+1,ilm,1)=sum2(i3r+1,ilm,1)+fact*(ro1r*ro2i+ro1i*ro2r) 3864 end do 3865 end if 3866 end if 3867 end do 3868 end if 3869 end do 3870 end do 3871 ! Three sums to compute 3872 else 3873 do ilm=2,lm_size 3874 do ir=1,nrad 3875 i1r=cplex1*(ir-1)+1;i2r=cplex2*(ir-1)+1;i3r=cplexsum*(ir-1)+1 3876 do ilm1=2,lm_size 3877 if (lmselect1(ilm1)) then 3878 ro1r=rho1(i1r,ilm1);ro1i=zero;if (cplex1==2) ro1i=rho1(i1r+1,ilm1) 3879 do ilm2=2,ilm1 3880 if (lmselect1(ilm2)) then 3881 isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2) 3882 if (isel>0) then 3883 fact=pawang%realgnt(isel);if (ilm1/=ilm2) fact=two*fact 3884 ro2r=rho1(i1r,ilm2);ro2i=zero;if (cplex1==2) ro2i=rho1(i1r+1,ilm2) 3885 sum2(i3r,ilm,1)=sum2(i3r,ilm,1)+fact*(ro1r*ro2r-ro1i*ro2i) 3886 if (cplexsum==2) sum2(i3r+1,ilm,1)=sum2(i3r+1,ilm,1)+fact*(ro1r*ro2i+ro1i*ro2r) 3887 end if 3888 end if 3889 end do 3890 end if 3891 end do 3892 do ilm1=2,lm_size 3893 if (lmselect2(ilm1)) then 3894 ro1r=rho2(i2r,ilm1);ro1i=zero;if (cplex2==2) ro1i=rho2(i2r+1,ilm1) 3895 do ilm2=2,ilm1 3896 if (lmselect2(ilm2)) then 3897 isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2) 3898 if (isel>0) then 3899 fact=pawang%realgnt(isel);if (ilm1/=ilm2) fact=two*fact 3900 ro2r=rho2(i2r,ilm2);ro2i=zero;if (cplex2==2) ro2i=rho2(i2r+1,ilm2) 3901 sum2(i3r,ilm,3)=sum2(i3r,ilm,3)+fact*(ro1r*ro2r-ro1i*ro2i) 3902 if (cplexsum==2) sum2(i3r+1,ilm,3)=sum2(i3r+1,ilm,3)+fact*(ro1r*ro2i+ro1i*ro2r) 3903 end if 3904 end if 3905 end do 3906 end if 3907 end do 3908 do ilm1=2,lm_size 3909 if (lmselect1(ilm1)) then 3910 ro1r=rho1(i1r,ilm1);ro1i=zero;if (cplex1==2) ro1i=rho1(i1r+1,ilm1) 3911 do ilm2=2,ilm1 3912 if (lmselect2(ilm2)) then 3913 isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2) 3914 if (isel>0) then 3915 fact=pawang%realgnt(isel) 3916 ro2r=rho2(i2r,ilm2);ro2i=zero;if (cplex2==2) ro2i=rho2(i2r+1,ilm2) 3917 sum2(i3r,ilm,2)=sum2(i3r,ilm,2)+fact*(ro1r*ro2r-ro1i*ro2i) 3918 if (cplexsum==2) sum2(i3r+1,ilm,2)=sum2(i3r+1,ilm,2)+fact*(ro1r*ro2i+ro1i*ro2r) 3919 end if 3920 end if 3921 end do 3922 if (ilm1<lm_size) then 3923 do ilm2=ilm1+1,lm_size 3924 if (lmselect2(ilm2)) then 3925 isel=pawang%gntselect(ilm,ilm1+ilm2*(ilm2-1)/2) 3926 if (isel>0) then 3927 fact=pawang%realgnt(isel) 3928 ro2r=rho2(i2r,ilm2);ro2i=zero;if (cplex2==2) ro2i=rho2(i2r+1,ilm2) 3929 sum2(i3r,ilm,2)=sum2(i3r,ilm,2)+fact*(ro1r*ro2r-ro1i*ro2i) 3930 if (cplexsum==2) sum2(i3r+1,ilm,2)=sum2(i3r+1,ilm,2)+fact*(ro1r*ro2i+ro1i*ro2r) 3931 end if 3932 end if 3933 end do 3934 end if 3935 end if 3936 end do 3937 end do 3938 end do 3939 end if ! nsums 3940 3941 end if ! cplex 3942 3943 end if !option 3944 3945 end subroutine pawxcsum
pawxc_mkdenpos_wrapper/pawxc_mkdenpos_local [ Functions ]
[ Top ] [ pawxc_mkdenpos_wrapper ] [ Functions ]
NAME
pawxc_mkdenpos_local
FUNCTION
Local version of mkdenpos routine (to use outside ABINIT)
SOURCE
563 subroutine pawxc_mkdenpos_local() 564 565 !Local variables------------------------------- 566 !scalars 567 integer :: ifft,ispden,numneg 568 real(dp) :: rhotmp,worst 569 character(len=500) :: msg 570 !arrays 571 real(dp) :: rho(2) 572 573 ! ************************************************************************* 574 575 numneg=0;worst=zero 576 577 if(nspden==1)then 578 ! Non spin-polarized 579 !$OMP PARALLEL DO PRIVATE(ifft,rhotmp) REDUCTION(MIN:worst) REDUCTION(+:numneg) SHARED(nfft,rhonow) 580 !$OMP&SHARED(nfft,rhonow) 581 do ifft=1,nfft 582 rhotmp=rhonow(ifft,1) 583 if(rhotmp<xc_denpos)then 584 if(rhotmp<-xc_denpos)then 585 ! This case is probably beyond machine precision considerations 586 worst=min(worst,rhotmp) 587 numneg=numneg+1 588 end if 589 rhonow(ifft,1)=xc_denpos 590 end if 591 end do 592 593 else if (nspden==2) then 594 ! Spin-polarized 595 596 ! rhonow is stored as (up,dn) 597 if (option==0) then 598 !$OMP PARALLEL DO PRIVATE(ifft,ispden,rho,rhotmp) REDUCTION(MIN:worst) REDUCTION(+:numneg) & 599 !$OMP&SHARED(nfft,nspden,rhonow) 600 do ifft=1,nfft 601 ! For polarized case, rho(1) is spin-up density, rho(2) is spin-down density 602 rho(1)=rhonow(ifft,1) 603 rho(2)=rhonow(ifft,2) 604 do ispden=1,nspden 605 if (rho(ispden)<xc_denpos) then 606 if (rho(ispden)<-xc_denpos) then 607 ! This case is probably beyond machine precision considerations 608 worst=min(worst,rho(ispden)) 609 numneg=numneg+1 610 end if 611 rhonow(ifft,ispden)=xc_denpos 612 end if 613 end do 614 end do 615 616 ! rhonow is stored as (up+dn,up) 617 else if (option==1) then 618 !$OMP PARALLEL DO PRIVATE(ifft,ispden,rho,rhotmp) & 619 !$OMP&REDUCTION(MIN:worst) REDUCTION(+:numneg) & 620 !$OMP&SHARED(nfft,nspden,rhonow) 621 do ifft=1,nfft 622 ! For polarized case, rho(1) is spin-up density, rho(2) is spin-down density 623 rho(1)=rhonow(ifft,2) 624 rho(2)=rhonow(ifft,1)-rho(1) 625 do ispden=1,nspden 626 if (rho(ispden)<xc_denpos) then 627 if (rho(ispden)<-xc_denpos) then 628 ! This case is probably beyond machine precision considerations 629 worst=min(worst,rho(ispden)) 630 numneg=numneg+1 631 end if 632 rho(ispden)=xc_denpos 633 rhonow(ifft,1)=rho(1)+rho(2) 634 rhonow(ifft,2)=rho(1) 635 end if 636 end do 637 end do 638 639 end if ! option 640 else 641 msg='nspden>2 not allowed !' 642 LIBPAW_BUG(msg) 643 end if ! End choice between non-spin polarized and spin-polarized. 644 645 if (numneg>0) then 646 if (iwarn==0) then 647 write(msg,'(a,i10,a,a,a,es10.2,a,e10.2,a,a,a,a)')& 648 & 'Density went too small (lower than xc_denpos) at',numneg,' points',ch10,& 649 & 'and was set to xc_denpos=',xc_denpos,'. Lowest was ',worst,'.',ch10,& 650 & 'Likely due to too low boxcut or too low ecut for','pseudopotential core charge.' 651 LIBPAW_WARNING(msg) 652 end if 653 iwarn=iwarn+1 654 end if 655 656 end subroutine pawxc_mkdenpos_local
pawxc_size_dvxc_wrapper/pawxc_size_dvxc_local [ Functions ]
[ Top ] [ pawxc_size_dvxc_wrapper ] [ Functions ]
NAME
pawxc_size_dvxc_local
FUNCTION
Local version of size_dvxc routine (to use outside ABINIT)
SOURCE
296 subroutine pawxc_size_dvxc_local() 297 298 !Local variables---------------- 299 logical :: need_gradient,need_kden,need_laplacian 300 301 ! ************************************************************************* 302 303 !Do we use the gradient? 304 need_gradient=((ixc>=11.and.ixc<=17).or.(ixc==23.or.ixc==24).or. & 305 & (ixc==26.or.ixc==27).or.(ixc>=31.and.ixc<=35).or. & 306 & (ixc==41.or.ixc==42).or.ixc==1402000) 307 if (ixc<0) then 308 if (libxc_functionals_isgga().or.libxc_functionals_ismgga().or. & 309 & libxc_functionals_is_hybrid()) need_gradient=.true. 310 end if 311 usegradient_=0 ; if (need_gradient) usegradient_=2*min(nspden,2)-1 312 313 !Do we use the laplacian? 314 need_laplacian=(ixc==32.or.ixc==35) 315 if (ixc<0) need_laplacian=libxc_functionals_needs_laplacian() 316 uselaplacian_=0 ; if (need_laplacian) uselaplacian_=min(nspden,2) 317 318 !Do we use the kinetic energy density? 319 need_kden=(ixc==31.or.ixc==34.or.ixc==35) 320 if (ixc<0) need_kden=libxc_functionals_ismgga() 321 usekden_=0 ; if (need_kden) usekden_=min(nspden,2) 322 323 !First derivative(s) of XC functional wrt gradient of density 324 nvxcgrho_=0 325 if (abs(order)>=1) then 326 if (need_gradient) nvxcgrho_=3 327 if (ixc==16.or.ixc==17.or.ixc==26.or.ixc==27) nvxcgrho_=2 328 end if 329 330 !First derivative(s) of XC functional wrt laplacian of density 331 nvxclrho_=0 332 if (abs(order)>=1) then 333 if (need_laplacian) nvxclrho_=min(nspden,2) 334 end if 335 336 !First derivative(s) of XC functional wrt kinetic energy density 337 nvxctau_=0 338 if (abs(order)>=1) then 339 if (need_kden) nvxctau_=min(nspden,2) 340 end if 341 342 !Second derivative(s) of XC functional wrt density 343 ndvxc_=0 344 if (abs(order)>=2) then 345 if (ixc==1.or.ixc==7.or.ixc==8.or.ixc==9.or.ixc==10.or.ixc==13.or. & 346 & ixc==21.or.ixc==22) then 347 ndvxc_=min(nspden,2)+1 348 else if ((ixc>=2.and.ixc<=6).or.(ixc>=31.and.ixc<=35).or.ixc==50) then 349 ndvxc_=1 350 else if (ixc==12.or.ixc==24) then 351 ndvxc_=8 352 else if (ixc==11.or.ixc==12.or.ixc==14.or.ixc==15.or. & 353 & ixc==23.or.ixc==41.or.ixc==42.or.ixc==1402000) then 354 ndvxc_=15 355 else if (ixc<0) then 356 if (libxc_functionals_has_kxc() then 357 ndvxc_=2*min(nspden,2)+1 ; if (order==-2) ndvxc_=2 358 if (need_gradient) ndvxc_=15 359 end if 360 end if 361 end if 362 363 !Third derivative(s) of XC functional wrt density 364 nd2vxc_=0 365 if (abs(order)>=3) then 366 if (ixc==3.or.(ixc>=11.and.ixc<=15.and.ixc/=13).or. & 367 & ixc==23.or.ixc==24.or.ixc==41.or.ixc==42) then 368 nd2vxc_=1 369 else if ((ixc>=7.and.ixc<=10).or.ixc==13.or.ixc==1402000) then 370 nd2vxc_=3*min(nspden,2)-2 371 else if (ixc<0) then 372 if (libxc_functionals_has_k3xc() then 373 if (.not.need_gradient) nd2vxc_=3*min(nspden,2)-2 374 end if 375 end if 376 end if 377 378 end subroutine pawxc_size_dvxc_local
pawxc_xcmult_wrapper/pawxc_xcmult_local [ Functions ]
[ Top ] [ pawxc_xcmult_wrapper ] [ Functions ]
NAME
pawxc_xcmult_local
FUNCTION
Local version of xcmult routine (to use outside ABINIT)
SOURCE
464 subroutine pawxc_xcmult_local() 465 466 !Local variables------------------------------- 467 !scalars 468 integer :: idir,ifft 469 real(dp) :: rho_tot,rho_up 470 471 ! ************************************************************************* 472 473 do idir=1,3 474 475 if(nspden==1)then 476 !$OMP PARALLEL DO PRIVATE(ifft) SHARED(depsxc,idir,nfft,rhonow) 477 do ifft=1,nfft 478 rhonow(ifft,1,1+idir)=rhonow(ifft,1,1+idir)*depsxc(ifft,2) 479 end do 480 else 481 ! In the spin-polarized case, there are more factors to take into account 482 !$OMP PARALLEL DO PRIVATE(ifft,rho_tot,rho_up) SHARED(depsxc,idir,nfft,rhonow) 483 do ifft=1,nfft 484 rho_tot=rhonow(ifft,1,1+idir) 485 rho_up =rhonow(ifft,2,1+idir) 486 rhonow(ifft,1,1+idir)=rho_up *depsxc(ifft,3) + rho_tot*depsxc(ifft,5) 487 rhonow(ifft,2,1+idir)=(rho_tot-rho_up)*depsxc(ifft,4)+ rho_tot*depsxc(ifft,5) 488 end do 489 end if ! nspden==1 490 end do ! End loop on directions 491 492 end subroutine pawxc_xcmult_local
pawxc_xcpositron_wrapper/pawxc_xcpositron_abinit [ Functions ]
[ Top ] [ pawxc_xcpositron_wrapper ] [ Functions ]
NAME
pawxc_xcpositron_abinit
FUNCTION
ABINIT version of electron-positron correlation
SOURCE
171 subroutine pawxc_xcpositron_abinit() 172 173 ! ************************************************************************* 174 175 if(present(dvxce) .and. present(dvxcp)) then 176 call xcpositron(fnxc,grhoe2,ixcpositron,ngr,npt,posdensity0_limit,rhoer,rhopr,vxce,vxcegr,vxcp,& 177 & dvxce=dvxce,dvxcp=dvxcp) ! optional arguments 178 elseif( present(dvxce) .and. .not. present(dvxcp)) then 179 call xcpositron(fnxc,grhoe2,ixcpositron,ngr,npt,posdensity0_limit,rhoer,rhopr,vxce,vxcegr,vxcp,& 180 & dvxce=dvxce) ! optional arguments 181 elseif( .not. present(dvxce) .and. present(dvxcp)) then 182 call xcpositron(fnxc,grhoe2,ixcpositron,ngr,npt,posdensity0_limit,rhoer,rhopr,vxce,vxcegr,vxcp,& 183 & dvxcp=dvxcp) ! optional arguments 184 else 185 call xcpositron(fnxc,grhoe2,ixcpositron,ngr,npt,posdensity0_limit,rhoer,rhopr,vxce,vxcegr,vxcp) 186 end if 187 188 end subroutine pawxc_xcpositron_abinit
pawxc_xcpositron_wrapper/pawxc_xcpositron_local [ Functions ]
[ Top ] [ pawxc_xcpositron_wrapper ] [ Functions ]
NAME
pawxc_xcpositron_local
FUNCTION
Local version of electron-positron correlation (to use outside ABINIT) NOT AVAILABLE
SOURCE
202 subroutine pawxc_xcpositron_local() 203 204 character(len=*), parameter :: msg='xcpositron only available in ABINIT!' 205 206 ! ************************************************************************* 207 208 LIBPAW_BUG(msg) 209 210 end subroutine pawxc_xcpositron_local