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_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-2018 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 DEVELOPPERS: in order to preserve the portability of libPAW library, please consult ~abinit/src/??_libpaw/libpaw-coding-rules.txt
SOURCE
21 #include "libpaw.h" 22 23 module m_pawxc 24 25 USE_DEFS 26 USE_MSG_HANDLING 27 USE_MEMORY_PROFILING 28 29 #ifdef LIBPAW_ISO_C_BINDING 30 use iso_c_binding, only : c_ptr,c_loc,c_f_pointer 31 #endif 32 33 #ifdef HAVE_LIBPAW_ABINIT 34 use m_xcpositron, only : xcpositron 35 use m_drivexc, only : drivexc_main, size_dvxc, xcmult, mkdenpos 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 private 45 46 public :: pawxc ! Compute xc correlation potential and energies inside a paw sphere. USE (r,theta,phi) 47 public :: pawxcpositron ! Compute electron-positron correlation potential and energies inside a PAW sphere. USE (r,theta,phi) 48 public :: pawxc_dfpt ! Compute first-order change of XC potential and contribution to 49 ! 2nd-order change of XC energy inside a PAW sphere. USE (r,theta,phi) 50 public :: pawxcsum ! Compute useful sums of moments of densities needed to compute on-site contributions to XC energy and potential 51 public :: pawxcm ! Compute xc correlation potential and energies inside a paw sphere. USE (L,M) MOMENTS 52 public :: pawxcmpositron ! Compute electron-positron correlation potential and energies inside a PAW sphere. USE (L,M) MOMENTS 53 public :: pawxcm_dfpt ! Compute 1st-order change of XC potential and contrib 54 ! to 2nd-order change of XC ene inside a PAW sphere. USE (L,M) MOMENTS 55 public :: pawxc_get_nkxc ! Compute sze of XC kernel (Kxc) according to spin polarization and XC type 56 57 !Private procedures 58 private :: pawxcsph ! Compute XC energy and potential for a spherical density rho(r) given as (up,dn) 59 private :: pawxcsphpositron ! Compute electron-positron XC energy and potential for spherical densities rho_el(r) rho_pos(r) 60 private :: pawxcsph_dfpt ! Compute XC 1st-order potential for a 1st-order spherical density rho1(r) 61 private :: pawxc_rotate_mag ! Rotate a non-collinear density wrt a magnetization 62 private :: pawxc_rotate_back_mag ! Rotate back a collinear XC potential wrt a magnetization 63 private :: pawxc_rotate_back_mag_dfpt ! Rotate back a collinear 1st-order XC potential wrt a magnetization 64 65 !Wrappers 66 private :: pawxc_drivexc_wrapper ! wrapper for drivexc_main 67 private :: pawxc_mkdenpos_wrapper ! wrapper for mkdenpos 68 private :: pawxc_xcmult_wrapper ! wrapper for xcmult 69 private :: pawxc_size_dvxc_wrapper ! wrapper for size_dvxc 70 private :: pawxc_xcpositron_wrapper ! wrapper for xcpositron 71 72 !Zero of density 73 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= true if usepawu==4 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)
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 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)
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) Dimension of K3xc: ===== 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
PARENTS
m_pawpsp,pawdenpot
CHILDREN
rotate_back_mag_dfpt
SOURCE
861 subroutine pawxc(corexc,enxc,enxcdc,ixc,kxc,k3xc,lm_size,lmselect,nhat,nkxc,nk3xc,non_magnetic_xc,nrad,nspden,option,& 862 & pawang,pawrad,rhor,usecore,usexcnhat,vxc,xclevel,xc_denpos) 863 864 865 !This section has been created automatically by the script Abilint (TD). 866 !Do not modify the following lines by hand. 867 #undef ABI_FUNC 868 #define ABI_FUNC 'pawxc' 869 !End of the abilint section 870 871 implicit none 872 873 !Arguments ------------------------------------ 874 !scalars 875 integer,intent(in) :: ixc,lm_size,nkxc,nk3xc,nrad,nspden,option,usecore,usexcnhat,xclevel 876 logical,intent(in) :: non_magnetic_xc 877 real(dp),intent(in) :: xc_denpos 878 real(dp),intent(out) :: enxc,enxcdc 879 type(pawang_type),intent(in) :: pawang 880 type(pawrad_type),intent(in) :: pawrad 881 !arrays 882 logical,intent(in) :: lmselect(lm_size) 883 real(dp),intent(in) :: corexc(nrad) 884 real(dp),intent(in) :: nhat(nrad,lm_size,nspden*((usexcnhat+1)/2)) 885 real(dp),intent(in),target :: rhor(nrad,lm_size,nspden) 886 real(dp),intent(out) :: kxc(nrad,pawang%angl_size,nkxc) 887 real(dp),intent(out) :: k3xc(nrad,pawang%angl_size,nk3xc) 888 real(dp),intent(out),target :: vxc(nrad,pawang%angl_size,nspden) 889 890 !Local variables------------------------------- 891 !scalars 892 integer :: ii,ilm,ipts,ir,ispden,iwarn,lm_size_eff,mgga,ndvxc,nd2vxc,ngr2,ngrad 893 integer :: nkxc_updn,npts,nspden_eff,nspden_updn,nspgrad,nvxcdgr,order 894 real(dp) :: dvdn,dvdz,enxcr,factor,vxcrho 895 character(len=500) :: msg 896 !arrays 897 real(dp),allocatable :: dgxc(:),dnexcdn(:,:),drho(:),drhocore(:),dvxcdgr(:,:),dvxci(:,:),d2vxci(:,:) 898 real(dp),allocatable :: dylmdr(:,:,:),exci(:),ff(:),grho2_updn(:,:),gxc(:,:,:,:) 899 real(dp),allocatable :: rhoarr(:,:),rho_updn(:,:),vxci(:,:) 900 real(dp),allocatable,target :: mag(:,:,:),rhohat(:,:,:),rhonow(:,:,:) 901 real(dp), pointer :: mag_(:,:),rho_(:,:,:) 902 real(dp), LIBPAW_CONTIGUOUS pointer :: vxc_diag(:,:),vxc_nc(:,:),vxc_updn(:,:,:) 903 #ifdef LIBPAW_ISO_C_BINDING 904 type(C_PTR) :: cptr 905 #endif 906 907 ! ************************************************************************* 908 909 !---------------------------------------------------------------------- 910 !----- Check options 911 !---------------------------------------------------------------------- 912 913 nkxc_updn=merge(nkxc-3,nkxc,nkxc==6.or.nkxc==22) 914 if(nspden==4.and.nk3xc>0) then 915 msg='K3xc for nspden=4 not implemented!' 916 MSG_ERROR(msg) 917 end if 918 if(nk3xc>0.and.nkxc_updn==0) then 919 msg='nkxc must be non-zero if nk3xc is' 920 MSG_ERROR(msg) 921 end if 922 if(nspden==4.and.xclevel==2) then 923 msg='GGA for nspden=4 not implemented!' 924 MSG_ERROR(msg) 925 end if 926 if(pawang%angl_size==0) then 927 msg='pawang%angl_size=0!' 928 MSG_BUG(msg) 929 end if 930 if(.not.allocated(pawang%ylmr)) then 931 msg='pawang%ylmr must be allocated!' 932 MSG_BUG(msg) 933 end if 934 if(xclevel==2.and.(.not.allocated(pawang%ylmrgr))) then 935 msg='pawang%ylmrgr must be allocated!' 936 MSG_BUG(msg) 937 end if 938 if(option==4.or.option==5) then 939 if (pawang%angl_size/=1) then 940 msg='When option=4 or 5, pawang%angl_size must be 1!' 941 MSG_BUG(msg) 942 end if 943 if (pawang%ylm_size/=1) then 944 msg='When option=4 or 5, pawang%ylm_size must be 1!' 945 MSG_BUG(msg) 946 end if 947 if (abs(pawang%anginit(1,1)-one)>tol12.or.abs(pawang%anginit(2,1))>tol12.or. & 948 & abs(pawang%anginit(3,1))>tol12) then 949 msg='When option=4 or 5, pawang%anginit must be (1 0 0)!' 950 MSG_BUG(msg) 951 end if 952 end if 953 if (option/=1.and.option/=5) then 954 if (nrad<pawrad%int_meshsz) then 955 msg='When option=0,2,3,4, nrad must be greater than pawrad%int_meshsz!' 956 MSG_BUG(msg) 957 end if 958 end if 959 960 !---------------------------------------------------------------------- 961 !----- Initializations 962 !---------------------------------------------------------------------- 963 iwarn=0 964 nspden_updn=min(nspden,2) 965 nspden_eff=nspden_updn;if (nspden==4.and.xclevel==2) nspden_eff=4 966 npts=pawang%angl_size 967 lm_size_eff=min(lm_size,pawang%ylm_size) 968 ngrad=1;if(xclevel==2)ngrad=2 969 nspgrad=0;if (xclevel==2) nspgrad=3*nspden_updn-1 970 if (option/=1.and.option/=5) enxc=zero 971 if (option==0.or.option==2) enxcdc=zero 972 if (option/=3.and.option/=4) vxc(:,:,:)=zero 973 if (nkxc>0) kxc(:,:,:)=zero 974 if (nk3xc>0) k3xc(:,:,:)=zero 975 mgga=0 !metaGGA contributions are not taken into account here 976 order=1;if (nkxc_updn>0) order=2;if (nk3xc>0) order=3 ! to which der. of the energy the computation must be done 977 978 if (xclevel==0.or.ixc==0) then 979 msg='Note that no xc is applied (ixc=0).' 980 MSG_WARNING(msg) 981 982 else 983 984 ! Allocation of temporary memory space 985 LIBPAW_ALLOCATE(rhonow,(nrad,nspden,ngrad*ngrad)) 986 LIBPAW_ALLOCATE(rhoarr,(nrad,nspden)) 987 if (usexcnhat>0) then 988 LIBPAW_ALLOCATE(rhohat,(nrad,lm_size,nspden)) 989 rhohat(:,:,:)=rhor(:,:,:)+nhat(:,:,:) 990 end if 991 if (xclevel==2.and.usecore==1) then 992 LIBPAW_ALLOCATE(drhocore,(nrad)) 993 call nderiv_gen(drhocore,corexc,pawrad) 994 end if 995 if (option/=3.and.option/=4) then 996 if (nspden/=4) then 997 vxc_updn => vxc 998 else 999 LIBPAW_ALLOCATE(vxc_updn,(nrad,npts,nspden_updn)) 1000 LIBPAW_ALLOCATE(mag,(nrad,npts,3)) 1001 end if 1002 end if 1003 1004 ! Allocation of mandatory arguments of drivexc 1005 LIBPAW_ALLOCATE(exci,(nrad)) 1006 LIBPAW_ALLOCATE(vxci,(nrad,nspden_updn)) 1007 LIBPAW_ALLOCATE(rho_updn,(nrad,nspden_updn)) 1008 ! Allocation of optional arguments of drivexc 1009 call pawxc_size_dvxc_wrapper(ixc,ndvxc,ngr2,nd2vxc,nspden_updn,nvxcdgr,order) 1010 LIBPAW_ALLOCATE(dvxci,(nrad,ndvxc)) 1011 LIBPAW_ALLOCATE(d2vxci,(nrad,nd2vxc)) 1012 LIBPAW_ALLOCATE(dvxcdgr,(nrad,nvxcdgr)) 1013 LIBPAW_ALLOCATE(grho2_updn,(nrad,ngr2)) 1014 LIBPAW_ALLOCATE(dnexcdn,(nrad,nspgrad)) 1015 1016 ! GGA: convert Ylm derivatives from normalized to standard cartesian coordinates 1017 ! dYlm/dr_i = { dYlm/dr_i^hat - Sum_j[ dYlm/dr_j^hat (r_j/r)] } * (1/r) 1018 if (xclevel==2) then 1019 LIBPAW_ALLOCATE(dylmdr,(3,npts,pawang%ylm_size)) 1020 do ilm=1,pawang%ylm_size 1021 do ipts=1,npts 1022 factor=sum(pawang%ylmrgr(1:3,ilm,ipts)*pawang%anginit(1:3,ipts)) 1023 dylmdr(1:3,ipts,ilm)=pawang%ylmrgr(1:3,ilm,ipts)-factor*pawang%anginit(1:3,ipts) 1024 end do 1025 end do 1026 LIBPAW_ALLOCATE(gxc,(nrad,3,pawang%ylm_size,nspden_updn)) 1027 gxc=zero 1028 end if 1029 1030 ! ---------------------------------------------------------------------- 1031 ! ----- Loop on the angular part and inits 1032 ! ---------------------------------------------------------------------- 1033 1034 ! Do loop on the angular part 1035 do ipts=1,npts 1036 1037 ! Copy the input density for this (theta,phi) 1038 rhoarr(:,:)=zero 1039 if (usexcnhat< 2) rho_=>rhor 1040 if (usexcnhat==2) rho_=>rhohat 1041 do ispden=1,nspden 1042 do ilm=1,lm_size_eff 1043 if (lmselect(ilm)) then 1044 rhoarr(1:nrad,ispden)=rhoarr(1:nrad,ispden) & 1045 & +rho_(1:nrad,ilm,ispden)*pawang%ylmr(ilm,ipts) 1046 end if 1047 end do 1048 end do 1049 if (usecore==1) then 1050 rhoarr(1:nrad,1)=rhoarr(1:nrad,1)+corexc(1:nrad) 1051 if (nspden==2) rhoarr(1:nrad,2)=rhoarr(1:nrad,2)+half*corexc(1:nrad) 1052 end if 1053 1054 ! Optionally suppressed magnetic part. 1055 if(non_magnetic_xc) then 1056 if(nspden==2) then 1057 rhoarr(:,2)=rhoarr(:,1)/two 1058 endif 1059 if(nspden==4) then 1060 rhoarr(:,2)=zero 1061 rhoarr(:,3)=zero 1062 rhoarr(:,4)=zero 1063 endif 1064 endif 1065 1066 rhonow(1:nrad,1:nspden,1)=rhoarr(1:nrad,1:nspden) 1067 1068 ! GGA: compute gradient of density 1069 if (xclevel==2) then 1070 rhonow(:,:,2:4)=zero 1071 LIBPAW_ALLOCATE(drho,(nrad)) 1072 LIBPAW_ALLOCATE(ff,(nrad)) 1073 do ispden=1,nspden 1074 do ilm=1,lm_size_eff 1075 if (lmselect(ilm)) then 1076 ff(1:nrad)=rho_(1:nrad,ilm,ispden) 1077 call nderiv_gen(drho,ff,pawrad) 1078 ff(2:nrad)=ff(2:nrad)/pawrad%rad(2:nrad) 1079 call pawrad_deducer0(ff,nrad,pawrad) 1080 do ii=1,3 1081 rhonow(1:nrad,ispden,1+ii)=rhonow(1:nrad,ispden,1+ii) & 1082 & +drho(1:nrad)*pawang%ylmr(ilm,ipts)*pawang%anginit(ii,ipts) & 1083 & +ff(1:nrad)*dylmdr(ii,ipts,ilm) 1084 end do 1085 end if 1086 end do 1087 end do 1088 LIBPAW_DEALLOCATE(drho) 1089 LIBPAW_DEALLOCATE(ff) 1090 if (usecore==1) then 1091 do ii=1,3 1092 rhonow(1:nrad,1,1+ii)=rhonow(1:nrad,1,1+ii) & 1093 & +drhocore(1:nrad)*pawang%anginit(ii,ipts) 1094 end do 1095 if (nspden==2) then 1096 do ii=1,3 1097 rhonow(1:nrad,2,1+ii)=rhonow(1:nrad,2,1+ii) & 1098 & +half*drhocore(1:nrad)*pawang%anginit(ii,ipts) 1099 end do 1100 end if 1101 end if 1102 end if 1103 1104 ! Storage of density (and gradient) in (up,dn) format 1105 if (nspden==1) then 1106 rho_updn(1:nrad,1)=rhonow(1:nrad,1,1)*half 1107 if (xclevel==2) then 1108 grho2_updn(1:nrad,1)=quarter*(rhonow(1:nrad,1,2)**2+rhonow(1:nrad,1,3)**2+rhonow(1:nrad,1,4)**2) 1109 end if 1110 else if (nspden==2) then 1111 rho_updn(1:nrad,1)=rhonow(1:nrad,2,1) 1112 rho_updn(1:nrad,2)=rhonow(1:nrad,1,1)-rhonow(1:nrad,2,1) 1113 if (xclevel==2) then 1114 grho2_updn(1:nrad,1)=rhonow(1:nrad,2,2)**2+rhonow(1:nrad,2,3)**2+rhonow(1:nrad,2,4)**2 1115 grho2_updn(1:nrad,2)=(rhonow(1:nrad,1,2)-rhonow(1:nrad,2,2))**2 + & 1116 & (rhonow(1:nrad,1,3)-rhonow(1:nrad,2,3))**2 + & 1117 & (rhonow(1:nrad,1,4)-rhonow(1:nrad,2,4))**2 1118 grho2_updn(1:nrad,3)=rhonow(1:nrad,1,2)**2+rhonow(1:nrad,1,3)**2+rhonow(1:nrad,1,4)**2 1119 end if 1120 else if (nspden==4) then 1121 mag_ => rhonow(1:nrad,2:4,1) 1122 mag(1:nrad,ipts,1:3)=mag_(1:nrad,1:3) 1123 call pawxc_rotate_mag(rhonow(:,:,1),rho_updn,mag_,nrad) 1124 end if 1125 1126 ! Make the density positive everywhere (but do not care about gradients) 1127 call pawxc_mkdenpos_wrapper(iwarn,nrad,nspden_updn,0,rho_updn,xc_denpos) 1128 1129 ! Call to main XC driver 1130 call pawxc_drivexc_wrapper(exci,ixc,mgga,ndvxc,nd2vxc,ngr2,nrad,nspden_updn,nvxcdgr,order,rho_updn,vxci,xclevel, & 1131 & dvxc=dvxci,d2vxc=d2vxci,grho2=grho2_updn,vxcgrho=dvxcdgr) 1132 1133 1134 ! ---------------------------------------------------------------------- 1135 ! ----- Accumulate and store XC kernel and its derivative 1136 ! ---------------------------------------------------------------------- 1137 if (nkxc_updn>0.and.ndvxc>0) then 1138 if (nkxc_updn==1.and.ndvxc==15) then 1139 kxc(1:nrad,ipts,1)=half*(dvxci(1:nrad,1)+dvxci(1:nrad,9)+dvxci(1:nrad,10)) 1140 else if (nkxc_updn==3.and.ndvxc==15) then 1141 kxc(1:nrad,ipts,1)=dvxci(1:nrad,1)+dvxci(1:nrad,9) 1142 kxc(1:nrad,ipts,2)=dvxci(1:nrad,10) 1143 kxc(1:nrad,ipts,3)=dvxci(1:nrad,2)+dvxci(1:nrad,11) 1144 else if (nkxc_updn==7.and.ndvxc==8) then 1145 kxc(1:nrad,ipts,1)=half*dvxci(1:nrad,1) 1146 kxc(1:nrad,ipts,2)=half*dvxci(1:nrad,3) 1147 kxc(1:nrad,ipts,3)=quarter*dvxci(1:nrad,5) 1148 kxc(1:nrad,ipts,4)=eighth*dvxci(1:nrad,7) 1149 else if (nkxc_updn==7.and.ndvxc==15) then 1150 kxc(1:nrad,ipts,1)=half*(dvxci(1:nrad,1)+dvxci(1:nrad,9)+dvxci(1:nrad,10)) 1151 kxc(1:nrad,ipts,2)=half*dvxci(1:nrad,3)+dvxci(1:nrad,12) 1152 kxc(1:nrad,ipts,3)=quarter*dvxci(1:nrad,5)+dvxci(1:nrad,13) 1153 kxc(1:nrad,ipts,4)=eighth*dvxci(1:nrad,7)+dvxci(1:nrad,15) 1154 else if (nkxc_updn==19.and.ndvxc==15) then 1155 kxc(1:nrad,ipts,1)=dvxci(1:nrad,1)+dvxci(1:nrad,9) 1156 kxc(1:nrad,ipts,2)=dvxci(1:nrad,10) 1157 kxc(1:nrad,ipts,3)=dvxci(1:nrad,2)+dvxci(1:nrad,11) 1158 kxc(1:nrad,ipts,4)=dvxci(1:nrad,3) 1159 kxc(1:nrad,ipts,5)=dvxci(1:nrad,4) 1160 kxc(1:nrad,ipts,6)=dvxci(1:nrad,5) 1161 kxc(1:nrad,ipts,7)=dvxci(1:nrad,6) 1162 kxc(1:nrad,ipts,8)=dvxci(1:nrad,7) 1163 kxc(1:nrad,ipts,9)=dvxci(1:nrad,8) 1164 kxc(1:nrad,ipts,10)=dvxci(1:nrad,12) 1165 kxc(1:nrad,ipts,11)=dvxci(1:nrad,13) 1166 kxc(1:nrad,ipts,12)=dvxci(1:nrad,14) 1167 kxc(1:nrad,ipts,13)=dvxci(1:nrad,15) 1168 else ! Other cases 1169 kxc(1:nrad,ipts,1:nkxc)=zero 1170 kxc(1:nrad,ipts,1:min(nkxc,ndvxc))=dvxci(1:nrad,1:min(nkxc,ndvxc)) 1171 end if 1172 if (nkxc_updn==7) then 1173 kxc(1:nrad,ipts,5)=rhonow(1:nrad,1,2) 1174 kxc(1:nrad,ipts,6)=rhonow(1:nrad,1,3) 1175 kxc(1:nrad,ipts,7)=rhonow(1:nrad,1,4) 1176 else if (nkxc_updn==19) then 1177 kxc(1:nrad,ipts,14)=rhonow(1:nrad,1,2) 1178 kxc(1:nrad,ipts,15)=rhonow(1:nrad,2,2) 1179 kxc(1:nrad,ipts,16)=rhonow(1:nrad,1,3) 1180 kxc(1:nrad,ipts,17)=rhonow(1:nrad,2,3) 1181 kxc(1:nrad,ipts,18)=rhonow(1:nrad,1,4) 1182 kxc(1:nrad,ipts,19)=rhonow(1:nrad,2,4) 1183 end if 1184 end if 1185 if (nkxc>=nkxc_updn+3) then 1186 kxc(1:nrad,ipts,nkxc_updn+1)=rhonow(1:nrad,2,1) 1187 kxc(1:nrad,ipts,nkxc_updn+2)=rhonow(1:nrad,3,1) 1188 kxc(1:nrad,ipts,nkxc_updn+3)=rhonow(1:nrad,4,1) 1189 end if 1190 1191 ! kernel derivative : 1192 if (nk3xc>0.and.nd2vxc>0) then 1193 k3xc(1:nrad,ipts,1:min(nk3xc,nd2vxc))=d2vxci(1:nrad,1:min(nk3xc,nd2vxc)) 1194 end if 1195 1196 ! ---------------------------------------------------------------------- 1197 ! ----- Accumulate and store XC potential 1198 ! ---------------------------------------------------------------------- 1199 1200 if (option/=3.and.option/=4) then 1201 1202 do ispden=1,nspden_updn 1203 vxc_updn(1:nrad,ipts,ispden)=vxci(1:nrad,ispden) 1204 end do 1205 1206 ! For GGAs, additional terms appear 1207 if(xclevel==2.and.ixc/=13)then 1208 dnexcdn(1:nrad,1:nspden_updn)=vxci(1:nrad,1:nspden_updn) 1209 ! Treat explicitely spin up, spin down and total spin for spin-polarized 1210 do ii=1,3 1211 if(nspden_updn==1.and.ii>=2)exit !exit when ii=1 is finished if non-spin-polarized 1212 do ir=1,nrad 1213 ! If the norm of the gradient vanishes, then the different terms vanishes 1214 if(grho2_updn(ir,ii)<1.0d-24) then 1215 dnexcdn(ir,ii+nspden_updn)=zero;cycle 1216 end if 1217 ! Compute the derivative of n.e_xc wrt spin up, spin down, or total density 1218 if(nspden_updn==1)then 1219 dnexcdn(ir,ii+nspden_updn)=half*dvxcdgr(ir,1) !Definition of dvxcdgr changed in v3.3 1220 if (nvxcdgr==3) dnexcdn(ir,ii+nspden_updn)=dnexcdn(ir,ii+nspden_updn)+dvxcdgr(ir,3) 1221 else if(nspden_updn==2)then 1222 if (nvxcdgr==3) then 1223 dnexcdn(ir,ii+nspden_updn)=dvxcdgr(ir,ii) 1224 else if (ii/=3) then 1225 dnexcdn(ir,ii+nspden_updn)=dvxcdgr(ir,ii) 1226 else if (ii==3) then 1227 dnexcdn(ir,ii+nspden_updn)=zero 1228 end if 1229 end if 1230 end do 1231 end do 1232 call pawxc_xcmult_wrapper(dnexcdn,nrad,ngrad,nspden_eff,nspgrad,rhonow) 1233 factor=one;if (nspden_updn==1) factor=half 1234 if (option/=4.and.option/=5) then 1235 factor=factor*four_pi 1236 ! Accumulate moments of gxc 1237 do ispden=1,nspden_updn 1238 do ilm=1,pawang%ylm_size 1239 do ii=1,3 1240 gxc(1:nrad,ii,ilm,ispden)=gxc(1:nrad,ii,ilm,ispden)+rhonow(1:nrad,ispden,1+ii) & 1241 & *pawang%ylmr(ilm,ipts)*pawang%angwgth(ipts)*factor 1242 end do 1243 end do 1244 end do 1245 else 1246 do ispden=1,nspden_updn 1247 gxc(1:nrad,1,1,ispden)=factor*rhonow(1:nrad,ispden,2) 1248 end do 1249 end if 1250 end if 1251 1252 end if !option 1253 1254 ! ---------------------------------------------------------------------- 1255 ! ----- Accumulate and store XC energy 1256 ! ---------------------------------------------------------------------- 1257 if (option/=1.and.option/=5) then 1258 LIBPAW_ALLOCATE(ff,(nrad)) 1259 ff(1:nrad)=rhoarr(1:nrad,1)*exci(1:nrad)*pawrad%rad(1:nrad)**2 1260 call simp_gen(enxcr,ff,pawrad) 1261 if (option/=4) enxc=enxc+enxcr*pawang%angwgth(ipts) 1262 if (option==4) enxc=enxc+enxcr 1263 LIBPAW_DEALLOCATE(ff) 1264 end if 1265 1266 ! ---------------------------------------------------------------------- 1267 ! ----- End of the loop on npts (angular part) 1268 ! ---------------------------------------------------------------------- 1269 end do 1270 1271 ! Deallocate temporary memory space 1272 LIBPAW_DEALLOCATE(exci) 1273 LIBPAW_DEALLOCATE(vxci) 1274 LIBPAW_DEALLOCATE(rho_updn) 1275 LIBPAW_DEALLOCATE(dvxci) 1276 LIBPAW_DEALLOCATE(d2vxci) 1277 LIBPAW_DEALLOCATE(dvxcdgr) 1278 LIBPAW_DEALLOCATE(grho2_updn) 1279 LIBPAW_DEALLOCATE(dnexcdn) 1280 if (xclevel==2.and.usecore==1) then 1281 LIBPAW_DEALLOCATE(drhocore) 1282 end if 1283 LIBPAW_DEALLOCATE(rhonow) 1284 1285 ! ---------------------------------------------------------------------- 1286 ! ----- If GGA, modify potential with term from density gradient 1287 ! ---------------------------------------------------------------------- 1288 if (option/=3.and.option/=4.and.xclevel==2.and.ixc/=13) then 1289 ! Compute divergence of gxc and substract it from Vxc 1290 LIBPAW_ALLOCATE(dgxc,(nrad)) 1291 ! Need to multiply gxc by 2 in the non-polarised case 1292 factor=one;if (nspden_updn==1) factor=two 1293 if (option/=4.and.option/=5) then 1294 LIBPAW_ALLOCATE(ff,(nrad)) 1295 do ispden=1,nspden_updn 1296 do ilm=1,pawang%ylm_size 1297 do ii=1,3 1298 ff(1:nrad)=gxc(1:nrad,ii,ilm,ispden) 1299 call nderiv_gen(dgxc,ff,pawrad) 1300 ff(2:nrad)=ff(2:nrad)/pawrad%rad(2:nrad) 1301 call pawrad_deducer0(ff,nrad,pawrad) 1302 do ipts=1,npts 1303 vxc_updn(1:nrad,ipts,ispden)=vxc_updn(1:nrad,ipts,ispden) & 1304 & -factor*(dgxc(1:nrad)*pawang%anginit(ii,ipts)*pawang%ylmr(ilm,ipts) & 1305 & +ff(1:nrad)*dylmdr(ii,ipts,ilm)) 1306 end do 1307 end do 1308 end do 1309 end do 1310 LIBPAW_DEALLOCATE(ff) 1311 else ! option==4 or option==5 1312 do ispden=1,nspden_updn 1313 call nderiv_gen(dgxc,gxc(:,1,1,ispden),pawrad) 1314 vxc_updn(2:nrad,1,ispden)=vxc_updn(2:nrad,1,ispden) & 1315 & -factor*(dgxc(2:nrad)+two*gxc(2:nrad,1,1,ispden)/pawrad%rad(2:nrad)) 1316 call pawrad_deducer0(vxc(:,1,ispden),nrad,pawrad) 1317 end do 1318 end if 1319 LIBPAW_DEALLOCATE(dgxc) 1320 end if ! GGA 1321 1322 ! ---------------------------------------------------------------------- 1323 ! ----- If non-collinear, rotate back potential according to magnetization 1324 ! ---------------------------------------------------------------------- 1325 if (option/=3.and.option/=4.and.nspden==4) then 1326 ! Use of C pointers to avoid copies (when ISO C bindings are available) 1327 ! %@1$ xlf v15 compiler requires a auxilliary cptr variable 1328 #ifdef LIBPAW_ISO_C_BINDING 1329 cptr=c_loc(vxc_updn(1,1,1)) 1330 call c_f_pointer(cptr,vxc_diag,shape=[nrad*npts,nspden_updn]) 1331 cptr=c_loc(vxc(1,1,1)) 1332 call c_f_pointer(cptr,vxc_nc,shape=[nrad*npts,nspden]) 1333 cptr=c_loc(mag(1,1,1)) 1334 call c_f_pointer(cptr,mag_,shape=[nrad*npts,3]) 1335 #else 1336 LIBPAW_ALLOCATE(vxc_diag,(nrad*npts,nspden_updn)) 1337 LIBPAW_ALLOCATE(vxc_nc,(nrad*npts,nspden)) 1338 LIBPAW_ALLOCATE(mag_,(nrad*npts,3)) 1339 vxc_diag=reshape(vxc_updn,[nrad*npts,nspden_updn]) 1340 mag_=reshape(mag,[nrad*npts,3]) 1341 #endif 1342 call pawxc_rotate_back_mag(vxc_diag,vxc_nc,mag_,nrad*npts) 1343 #ifndef LIBPAW_ISO_C_BINDING 1344 vxc=reshape(vxc_nc,[nrad,npts,nspden]) 1345 LIBPAW_DEALLOCATE(vxc_diag) 1346 LIBPAW_DEALLOCATE(mag_) 1347 LIBPAW_DEALLOCATE(vxc_nc) 1348 #endif 1349 LIBPAW_DEALLOCATE(vxc_updn) 1350 LIBPAW_DEALLOCATE(mag) 1351 end if 1352 1353 ! ---------------------------------------------------------------------- 1354 ! ----- Accumulate and store XC double-counting energy 1355 ! ---------------------------------------------------------------------- 1356 if (option==0.or.option==2) then 1357 LIBPAW_ALLOCATE(ff,(nrad)) 1358 do ipts=1,npts ! Do loop on the angular part 1359 ! Compute density for this (theta,phi) 1360 rhoarr(:,:)=zero 1361 if (usexcnhat==0) rho_=>rhor 1362 if (usexcnhat/=0) rho_=>rhohat 1363 do ispden=1,nspden 1364 do ilm=1,lm_size_eff 1365 if (lmselect(ilm)) then 1366 rhoarr(1:nrad,ispden)=rhoarr(1:nrad,ispden)+rho_(1:nrad,ilm,ispden)*pawang%ylmr(ilm,ipts) 1367 end if 1368 end do 1369 end do 1370 ! Compute integral of Vxc*rho 1371 if (nspden/=4) then 1372 ff(:)=vxc(:,ipts,1)*rhoarr(:,nspden) 1373 if (nspden==2) ff(:)=ff(:)+vxc(:,ipts,2)*(rhoarr(:,1)-rhoarr(:,2)) 1374 else 1375 ff(:)=half*(vxc(:,ipts,1)*(rhoarr(:,1)+rhoarr(:,4)) & 1376 +vxc(:,ipts,2)*(rhoarr(:,1)-rhoarr(:,4))) & 1377 & +vxc(:,ipts,3)*rhoarr(:,2)-vxc(:,ipts,4)*rhoarr(:,3) 1378 end if 1379 ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2 1380 call simp_gen(vxcrho,ff,pawrad) 1381 enxcdc=enxcdc+vxcrho*pawang%angwgth(ipts) 1382 end do ! End of the loop on npts (angular part) 1383 LIBPAW_DEALLOCATE(ff) 1384 end if ! option 1385 1386 ! ---------------------------------------------------------------------- 1387 ! ----- End 1388 ! ---------------------------------------------------------------------- 1389 ! Add the four*pi factor of the Exc and Excdc angular integration 1390 if (option/=1.and.option/=5) enxc=enxc*four_pi 1391 if (option==0.or.option==2) enxcdc=enxcdc*four_pi 1392 1393 ! Final memory deallocation 1394 nullify(rho_) 1395 LIBPAW_DEALLOCATE(rhoarr) 1396 if (usexcnhat>0) then 1397 LIBPAW_DEALLOCATE(rhohat) 1398 end if 1399 if (xclevel==2) then 1400 LIBPAW_DEALLOCATE(gxc) 1401 LIBPAW_DEALLOCATE(dylmdr) 1402 end if 1403 1404 ! ------------------------------------ 1405 ! End IF a xc part has to be computed 1406 end if 1407 1408 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 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)
PARENTS
pawdenpot,pawdfptenergy
CHILDREN
rotate_back_mag_dfpt
SOURCE
1797 subroutine pawxc_dfpt(corexc1,cplex_den,cplex_vxc,d2enxc,ixc,kxc,lm_size,lmselect,nhat1,nkxc,nrad,nspden,& 1798 & option,pawang,pawrad,rhor1,usecore,usexcnhat,vxc,vxc1,xclevel,& 1799 & d2enxc_im) ! optional 1800 1801 1802 !This section has been created automatically by the script Abilint (TD). 1803 !Do not modify the following lines by hand. 1804 #undef ABI_FUNC 1805 #define ABI_FUNC 'pawxc_dfpt' 1806 !End of the abilint section 1807 1808 implicit none 1809 1810 !Arguments ------------------------------------ 1811 !scalars 1812 integer,intent(in) :: cplex_den,cplex_vxc,ixc,lm_size,nkxc,nrad,nspden,option 1813 integer,intent(in) :: usecore,usexcnhat,xclevel 1814 real(dp),intent(out) :: d2enxc 1815 real(dp),intent(out),optional :: d2enxc_im 1816 type(pawang_type),intent(in) :: pawang 1817 type(pawrad_type),intent(in) :: pawrad 1818 !arrays 1819 logical,intent(in) :: lmselect(lm_size) 1820 real(dp),intent(in) :: corexc1(cplex_den*nrad) 1821 real(dp),intent(in) :: nhat1(cplex_den*nrad,lm_size,nspden*((usexcnhat+1)/2)) 1822 real(dp),intent(in),target :: kxc(nrad,pawang%angl_size,nkxc) 1823 real(dp),intent(in),target :: vxc(nrad,pawang%angl_size,nspden) 1824 real(dp),intent(in),target :: rhor1(cplex_den*nrad,lm_size,nspden) 1825 real(dp),intent(inout),target :: vxc1(cplex_vxc*nrad,pawang%angl_size,nspden) 1826 1827 !Local variables------------------------------- 1828 !scalars 1829 integer :: ii,ilm,ipts,ir,ispden,jr,kr,lm_size_eff,nkxc_cur,npts,nspden_updn 1830 logical :: need_impart 1831 real(dp),parameter :: tol24=tol12*tol12 1832 real(dp) :: coeff_grho,coeff_grho_corr,coeff_grho_dn,coeff_grho_up 1833 real(dp) :: coeff_grhoim,coeff_grhoim_corr,coeff_grhoim_dn,coeff_grhoim_up 1834 real(dp) :: dylmdr_ii,factor,factor_ang_intg,ylm_ii 1835 real(dp) :: grho_grho1,grho_grho1_up,grho_grho1_dn 1836 real(dp) :: grho_grho1im,grho_grho1im_up,grho_grho1im_dn 1837 real(dp) :: rho1_dn,rho1_up,rho1im_dn,rho1im_up 1838 real(dp) :: ro11i,ro11r,ro12i,ro12r,ro21i,ro21r,ro22i,ro22r 1839 real(dp) :: v11i,v11r,v12i,v12r,v21i,v21r,v22i,v22r,vxcrho 1840 character(len=500) :: msg 1841 !arrays 1842 real(dp) :: g0(3),g0_dn(3),g0_up(3),g1(3),g1_dn(3),g1_up(3) 1843 real(dp) :: g1im(3),g1im_dn(3),g1im_up(3) 1844 real(dp) :: gxc1i(3,2),gxc1r(3,2) 1845 real(dp),allocatable :: dgxc1(:),drho1(:,:),drho1core(:,:),dylmdr(:,:,:) 1846 real(dp),allocatable :: ff(:),gg(:),grho1arr(:,:,:),gxc1(:,:,:,:) 1847 real(dp),allocatable,target :: rhohat1(:,:,:),rho1arr(:,:) 1848 real(dp), LIBPAW_CONTIGUOUS pointer :: kxc_(:,:),mag(:,:) 1849 real(dp), LIBPAW_CONTIGUOUS pointer :: rho1_(:,:,:),rho1_nc(:,:),rho1_updn(:,:) 1850 real(dp), LIBPAW_CONTIGUOUS pointer :: vxc_(:,:),vxc1_(:,:,:),vxc1_diag(:,:) 1851 real(dp), LIBPAW_CONTIGUOUS pointer :: vxc1_nc(:,:),vxc1_updn(:,:,:) 1852 #ifdef LIBPAW_ISO_C_BINDING 1853 type(C_PTR) :: cptr 1854 #endif 1855 1856 ! ************************************************************************* 1857 1858 !---------------------------------------------------------------------- 1859 !----- Check options 1860 !---------------------------------------------------------------------- 1861 1862 if(option<0.or.option>3) then 1863 msg='wrong option!' 1864 MSG_BUG(msg) 1865 end if 1866 if(option/=3) then 1867 call pawxc_get_nkxc(nkxc_cur,nspden,xclevel) 1868 if (nkxc/=nkxc_cur) then 1869 msg='Wrong dimension for array kxc!' 1870 MSG_BUG(msg) 1871 end if 1872 if(xclevel==2.and.nspden==4) then 1873 msg='PAW non-collinear magnetism not compatible with GGA!' 1874 MSG_ERROR(msg) 1875 end if 1876 end if 1877 if(pawang%angl_size==0) then 1878 msg='pawang%angl_size=0!' 1879 MSG_BUG(msg) 1880 end if 1881 if(.not.allocated(pawang%ylmr)) then 1882 msg='pawang%ylmr must be allocated!' 1883 MSG_BUG(msg) 1884 end if 1885 if(xclevel==2.and.(.not.allocated(pawang%ylmrgr))) then 1886 msg='pawang%ylmrgr must be allocated!' 1887 MSG_BUG(msg) 1888 end if 1889 if (option/=1) then 1890 if (nrad<pawrad%int_meshsz) then 1891 msg='When option=0,2, nrad must be greater than pawrad%int_meshsz!' 1892 MSG_BUG(msg) 1893 end if 1894 end if 1895 1896 !---------------------------------------------------------------------- 1897 !----- Initializations / allocations 1898 !---------------------------------------------------------------------- 1899 1900 npts=pawang%angl_size 1901 lm_size_eff=min(lm_size,pawang%ylm_size) 1902 nspden_updn=min(nspden,2) 1903 1904 need_impart=present(d2enxc_im) 1905 if (option/=1) then 1906 d2enxc=zero 1907 if (need_impart) d2enxc_im=zero 1908 end if 1909 if (option<=1) vxc1(:,:,:)=zero 1910 1911 !Special case: no XC applied 1912 if (ixc==0.or.(nkxc==0.and.option/=3)) then 1913 msg='Note that no xc is applied (ixc=0). Returning' 1914 MSG_WARNING(msg) 1915 return 1916 end if 1917 1918 LIBPAW_ALLOCATE(rho1arr,(cplex_den*nrad,nspden)) 1919 if (usexcnhat>0) then 1920 LIBPAW_ALLOCATE(rhohat1,(cplex_den*nrad,lm_size,nspden)) 1921 rhohat1(:,:,:)=rhor1(:,:,:)+nhat1(:,:,:) 1922 end if 1923 1924 if (option==2) then 1925 LIBPAW_POINTER_ALLOCATE(vxc1_,(cplex_vxc*nrad,npts,nspden)) 1926 else 1927 vxc1_ => vxc1 1928 end if 1929 1930 !Need gradients and additional allocations in case of GGA 1931 if (xclevel==2.and.option/=3) then 1932 LIBPAW_ALLOCATE(gxc1,(cplex_vxc*nrad,3,pawang%ylm_size,nspden)) 1933 gxc1=zero 1934 if (usecore==1) then 1935 LIBPAW_ALLOCATE(drho1core,(nrad,cplex_den)) 1936 if (cplex_den==1) then 1937 call nderiv_gen(drho1core(:,1),corexc1,pawrad) 1938 else 1939 LIBPAW_ALLOCATE(ff,(nrad)) 1940 LIBPAW_ALLOCATE(gg,(nrad)) 1941 do ir=1,nrad 1942 ff(ir)=corexc1(2*ir-1) 1943 gg(ir)=corexc1(2*ir ) 1944 end do 1945 call nderiv_gen(drho1core(:,1),ff,pawrad) 1946 call nderiv_gen(drho1core(:,2),gg,pawrad) 1947 LIBPAW_DEALLOCATE(ff) 1948 LIBPAW_DEALLOCATE(gg) 1949 end if 1950 end if 1951 ! Convert Ylm derivatives from normalized to standard cartesian coordinates 1952 ! dYlm/dr_i = { dYlm/dr_i^hat - Sum_j[ dYlm/dr_j^hat (r_j/r)] } * (1/r) 1953 LIBPAW_ALLOCATE(dylmdr,(3,npts,pawang%ylm_size)) 1954 do ilm=1,pawang%ylm_size 1955 do ipts=1,npts 1956 factor=sum(pawang%ylmrgr(1:3,ilm,ipts)*pawang%anginit(1:3,ipts)) 1957 dylmdr(1:3,ipts,ilm)=pawang%ylmrgr(1:3,ilm,ipts)-factor*pawang%anginit(1:3,ipts) 1958 end do 1959 end do 1960 end if 1961 1962 !---------------------------------------------------------------------- 1963 !----- Accumulate and store 1st-order change of XC potential 1964 !---------------------------------------------------------------------- 1965 1966 if (option/=3) then 1967 1968 if (nspden/=4) then 1969 rho1_updn => rho1arr 1970 vxc1_updn => vxc1_ 1971 else 1972 LIBPAW_ALLOCATE(rho1_updn,(cplex_den*nrad,nspden_updn)) 1973 LIBPAW_ALLOCATE(vxc1_updn,(cplex_vxc*nrad,npts,nspden_updn)) 1974 LIBPAW_ALLOCATE(rho1_nc,(cplex_den*nrad*npts,nspden)) 1975 LIBPAW_ALLOCATE(mag,(nrad,3)) 1976 end if 1977 1978 ! Do loop on the angular part (theta,phi) 1979 do ipts=1,npts 1980 1981 ! Copy the input 1st-order density for this (theta,phi) 1982 rho1arr(:,:)=zero 1983 if (usexcnhat< 2) rho1_=>rhor1 1984 if (usexcnhat==2) rho1_=>rhohat1 1985 do ispden=1,nspden 1986 do ilm=1,lm_size_eff 1987 if (lmselect(ilm)) rho1arr(:,ispden)=rho1arr(:,ispden) & 1988 & +rho1_(:,ilm,ispden)*pawang%ylmr(ilm,ipts) 1989 end do 1990 end do 1991 if (usecore==1) then 1992 rho1arr(:,1)=rho1arr(:,1)+corexc1(:) 1993 if (nspden==2) rho1arr(:,2)=rho1arr(:,2)+half*corexc1(:) 1994 end if 1995 1996 ! Non-collinear magnetism: rotate magnetization and get a collinear density 1997 if (nspden==4) then 1998 !Store non rotated rho^(1) for future use 1999 ii=(ipts-1)*cplex_den*nrad 2000 do ispden=1,nspden 2001 rho1_nc(ii+1:ii+cplex_den*nrad,ispden)=rho1arr(1:cplex_den*nrad,ispden) 2002 end do 2003 !Extract magnetization from kxc 2004 do ii=1,3 2005 mag(1:nrad,ii)=kxc(:,ipts,ii) 2006 end do 2007 !Rotate rhoarr1 -> rhoarr1_ 2008 !Should use cplex_den 2009 call pawxc_rotate_mag(rho1arr,rho1_updn,mag,nrad,rho_out_format=2) 2010 end if 2011 2012 ! ======================================================================= 2013 ! ======================= LDA =========================================== 2014 ! ======================================================================= 2015 if (xclevel==1.or.ixc==13) then 2016 2017 ! Non-spin-polarized 2018 if (nspden_updn==1) then 2019 if (cplex_vxc==1) then 2020 if (cplex_den==1) then ! cplex_vxc==1 and cplex_den==1 2021 vxc1_updn(1:nrad,ipts,1)=kxc(1:nrad,ipts,1)*rho1_updn(1:nrad,1) 2022 else ! cplex_vxc==1 and cplex_den==2 2023 do ir=1,nrad 2024 vxc1_updn(ir,ipts,1)=kxc(ir,ipts,1)*rho1_updn(2*ir-1,1) 2025 end do 2026 end if 2027 else 2028 if (cplex_den==1) then ! cplex_vxc==2 and cplex_den==1 2029 do ir=1,nrad 2030 vxc1_updn(2*ir-1,ipts,1)=kxc(ir,ipts,1)*rho1_updn(ir,1) 2031 vxc1_updn(2*ir ,ipts,1)=zero 2032 end do 2033 else ! cplex_vxc==2 and cplex_den==2 2034 do ir=1,nrad 2035 vxc1_updn(2*ir-1,ipts,1)=kxc(ir,ipts,1)*rho1_updn(2*ir-1,1) 2036 vxc1_updn(2*ir ,ipts,1)=kxc(ir,ipts,1)*rho1_updn(2*ir ,1) 2037 end do 2038 end if 2039 end if 2040 2041 ! Spin-polarized 2042 else 2043 if (cplex_vxc==1) then 2044 if (cplex_den==1) then ! cplex_vxc==1 and cplex_den==1 2045 do ir=1,nrad 2046 rho1_up=rho1_updn(ir,2);rho1_dn=rho1_updn(ir,1)-rho1_up 2047 vxc1_updn(ir,ipts,1)=kxc(ir,ipts,1)*rho1_up+kxc(ir,ipts,2)*rho1_dn 2048 vxc1_updn(ir,ipts,2)=kxc(ir,ipts,2)*rho1_up+kxc(ir,ipts,3)*rho1_dn 2049 end do 2050 else ! cplex_vxc==1 and cplex_den==2 2051 do ir=1,nrad 2052 jr=2*ir-1 2053 rho1_up=rho1_updn(jr,2);rho1_dn=rho1_updn(jr,1)-rho1_up 2054 vxc1_updn(ir,ipts,1)=kxc(ir,ipts,1)*rho1_up+kxc(ir,ipts,2)*rho1_dn 2055 vxc1_updn(ir,ipts,2)=kxc(ir,ipts,2)*rho1_up+kxc(ir,ipts,3)*rho1_dn 2056 end do 2057 end if 2058 else 2059 if (cplex_den==1) then ! cplex_vxc==2 and cplex_den==1 2060 do ir=1,nrad 2061 jr=2*ir-1 2062 rho1_up=rho1_updn(ir,2);rho1_dn=rho1_updn(ir,1)-rho1_up 2063 vxc1_updn(jr,ipts,1)=kxc(ir,ipts,1)*rho1_up+kxc(ir,ipts,2)*rho1_dn 2064 vxc1_updn(jr,ipts,2)=kxc(ir,ipts,2)*rho1_up+kxc(ir,ipts,3)*rho1_dn 2065 end do 2066 else ! cplex_vxc==2 and cplex_den==2 2067 do ir=1,nrad 2068 jr=2*ir 2069 rho1_up =rho1_updn(jr-1,2);rho1_dn =rho1_updn(jr-1,1)-rho1_up 2070 rho1im_up=rho1_updn(jr ,2);rho1im_dn=rho1_updn(jr ,1)-rho1im_up 2071 vxc1_updn(jr-1,ipts,1)=kxc(ir,ipts,1)*rho1_up +kxc(ir,ipts,2)*rho1_dn 2072 vxc1_updn(jr ,ipts,1)=kxc(ir,ipts,1)*rho1im_up+kxc(ir,ipts,2)*rho1im_dn 2073 vxc1_updn(jr-1,ipts,2)=kxc(ir,ipts,2)*rho1_up +kxc(ir,ipts,3)*rho1_dn 2074 vxc1_updn(jr ,ipts,2)=kxc(ir,ipts,2)*rho1im_up+kxc(ir,ipts,3)*rho1im_dn 2075 end do 2076 end if 2077 end if 2078 end if 2079 2080 else 2081 ! ======================================================================= 2082 ! ======================= GGA =========================================== 2083 ! ======================================================================= 2084 2085 ! Compute the gradient of the first-order density 2086 LIBPAW_ALLOCATE(drho1,(nrad,cplex_den)) 2087 LIBPAW_ALLOCATE(grho1arr,(cplex_den*nrad,nspden,3)) 2088 grho1arr(:,:,1:3)=zero 2089 if (cplex_den==1) then 2090 LIBPAW_ALLOCATE(ff,(nrad)) 2091 do ispden=1,nspden_updn 2092 do ilm=1,lm_size_eff 2093 if (lmselect(ilm)) then 2094 ff(1:nrad)=rho1_(1:nrad,ilm,ispden) 2095 call nderiv_gen(drho1(:,1),ff,pawrad) 2096 ff(2:nrad)=ff(2:nrad)/pawrad%rad(2:nrad) 2097 call pawrad_deducer0(ff,nrad,pawrad) 2098 do ii=1,3 2099 ylm_ii=pawang%ylmr(ilm,ipts)*pawang%anginit(ii,ipts) 2100 dylmdr_ii=dylmdr(ii,ipts,ilm) 2101 grho1arr(1:nrad,ispden,ii)=grho1arr(1:nrad,ispden,ii) & 2102 & +drho1(1:nrad,1)*ylm_ii+ff(1:nrad)*dylmdr_ii 2103 end do 2104 end if 2105 end do 2106 end do 2107 LIBPAW_DEALLOCATE(ff) 2108 else 2109 LIBPAW_ALLOCATE(ff,(nrad)) 2110 LIBPAW_ALLOCATE(gg,(nrad)) 2111 do ispden=1,nspden_updn 2112 do ilm=1,lm_size_eff 2113 if (lmselect(ilm)) then 2114 do ir=1,nrad 2115 ff(ir)=rho1_(2*ir-1,ilm,ispden) 2116 gg(ir)=rho1_(2*ir ,ilm,ispden) 2117 end do 2118 call nderiv_gen(drho1(:,1),ff,pawrad) 2119 call nderiv_gen(drho1(:,2),gg,pawrad) 2120 ff(2:nrad)=ff(2:nrad)/pawrad%rad(2:nrad) 2121 gg(2:nrad)=gg(2:nrad)/pawrad%rad(2:nrad) 2122 call pawrad_deducer0(ff,nrad,pawrad) 2123 call pawrad_deducer0(gg,nrad,pawrad) 2124 do ii=1,3 2125 ylm_ii=pawang%ylmr(ilm,ipts)*pawang%anginit(ii,ipts) 2126 dylmdr_ii=dylmdr(ii,ipts,ilm) 2127 do ir=2,nrad 2128 jr=2*ir 2129 grho1arr(jr-1,ispden,ii)=grho1arr(jr-1,ispden,ii) & 2130 & +drho1(ir,1)*ylm_ii+ff(ir)*dylmdr_ii 2131 grho1arr(jr ,ispden,ii)=grho1arr(jr ,ispden,ii) & 2132 & +drho1(ir,2)*ylm_ii+gg(ir)*dylmdr_ii 2133 end do 2134 end do 2135 end if 2136 end do 2137 end do 2138 LIBPAW_DEALLOCATE(ff) 2139 LIBPAW_DEALLOCATE(gg) 2140 end if 2141 if (usecore==1) then 2142 factor=one;if (nspden_updn==2) factor=half 2143 if (cplex_den==1) then 2144 do ispden=1,nspden_updn 2145 do ii=1,3 2146 grho1arr(1:nrad,ispden,ii)=grho1arr(1:nrad,ispden,ii) & 2147 & +factor*drho1core(1:nrad,1)*pawang%anginit(ii,ipts) 2148 end do 2149 end do 2150 else 2151 do ispden=1,nspden_updn 2152 do ii=1,3 2153 do ir=1,nrad 2154 jr=2*ir 2155 grho1arr(jr-1,ispden,ii)=grho1arr(jr-1,ispden,ii) & 2156 & +factor*drho1core(ir,1)*pawang%anginit(ii,ipts) 2157 grho1arr(jr ,ispden,ii)=grho1arr(jr ,ispden,ii) & 2158 & +factor*drho1core(ir,2)*pawang%anginit(ii,ipts) 2159 end do 2160 end do 2161 end do 2162 end if 2163 end if 2164 LIBPAW_DEALLOCATE(drho1) 2165 2166 ! Apply XC kernel 2167 ! Will compute Vxc^(1) as: vxc1 - Nabla .dot. gxc1 2168 2169 ! Scaling factor for angular integrals: four_pi x spin_factor 2170 factor_ang_intg=four_pi;if (nspden_updn==1) factor_ang_intg=two_pi 2171 2172 ! A- NON POLARIZED SYSTEMS 2173 if (nspden_updn==1) then 2174 2175 do ir=1,nrad 2176 jr=cplex_den*(ir-1)+1 ; kr=cplex_vxc*(ir-1)+1 2177 2178 g0(:)=kxc(ir,ipts,5:7) ; g1(:)=grho1arr(jr,1,1:3) 2179 grho_grho1=dot_product(g0,g1) 2180 coeff_grho=kxc(ir,ipts,3)*rho1_updn(jr,1)+kxc(ir,ipts,4)*grho_grho1 2181 vxc1_updn(kr,ipts,1)=kxc(ir,ipts,1)*rho1_updn(jr,1)+kxc(ir,ipts,3)*grho_grho1 2182 gxc1r(:,1)=g1(:)*kxc(ir,ipts,2)+g0(:)*coeff_grho 2183 !Accumulate gxc1_lm moments as Intg[gxc1(omega).Ylm(omega).d_omega] 2184 do ilm=1,pawang%ylm_size 2185 ylm_ii=pawang%ylmr(ilm,ipts)*pawang%angwgth(ipts)*factor_ang_intg 2186 do ii=1,3 2187 gxc1(kr,ii,ilm,1)=gxc1(ir,ii,ilm,1)+gxc1r(ii,1)*ylm_ii 2188 end do 2189 end do 2190 if (cplex_vxc==2) then 2191 if (cplex_den==2) then 2192 g1im(:)=grho1arr(jr+1,1,1:3) 2193 grho_grho1im=dot_product(g0,g1im) 2194 coeff_grhoim=kxc(ir,ipts,3)*rho1_updn(jr+1,1)+kxc(ir,ipts,4)*grho_grho1im 2195 vxc1_updn(kr+1,ipts,1)=kxc(ir,ipts,1)*rho1_updn(jr+1,1)+kxc(ir,ipts,3)*grho_grho1im 2196 gxc1i(:,1)=g1im(:)*kxc(ir,ipts,2)+g0(:)*coeff_grhoim 2197 !Accumulate gxc1_lm moments as Intg[gxc1(omega).Ylm(omega).d_omega] 2198 do ilm=1,pawang%ylm_size 2199 ylm_ii=pawang%ylmr(ilm,ipts)*pawang%angwgth(ipts)*factor_ang_intg 2200 do ii=1,3 2201 gxc1(kr+1,ii,ilm,1)=gxc1(kr+1,ii,ilm,1)+gxc1i(ii,1)*ylm_ii 2202 end do 2203 end do 2204 else 2205 vxc1_updn(kr+1,ipts,1)=zero ; gxc1i(:,1)=zero 2206 end if 2207 end if 2208 end do ! ir 2209 2210 ! B- POLARIZED SYSTEMS (COLLINEAR) 2211 else ! nspden_updn==2 2212 2213 do ir=1,nrad 2214 jr=cplex_den*(ir-1)+1 ; kr=cplex_vxc*(ir-1)+1 2215 2216 rho1_up=rho1_updn(jr,2);rho1_dn=rho1_updn(jr,1)-rho1_up 2217 g0_up(1)=kxc(ir,ipts,15);g0_dn(1)=kxc(ir,ipts,14)-kxc(ir,ipts,15) 2218 g0_up(2)=kxc(ir,ipts,17);g0_dn(2)=kxc(ir,ipts,16)-kxc(ir,ipts,17) 2219 g0_up(3)=kxc(ir,ipts,19);g0_dn(3)=kxc(ir,ipts,18)-kxc(ir,ipts,19) 2220 g1_up(:)=grho1arr(jr,2,:);g1_dn(:)=grho1arr(jr,1,:)-grho1arr(jr,2,:) 2221 g0(:)=g0_up(:)+g0_dn(:);g1(:)=g1_up(:)+g1_dn(:) 2222 grho_grho1_up=dot_product(g0_up,g1_up) 2223 grho_grho1_dn=dot_product(g0_dn,g1_dn) 2224 grho_grho1 =dot_product(g0,g1) 2225 coeff_grho_corr=kxc(ir,ipts,11)*rho1_up & 2226 & +kxc(ir,ipts,12)*rho1_dn & 2227 & +kxc(ir,ipts,13)*grho_grho1 2228 coeff_grho_up=kxc(ir,ipts,6)*rho1_up & 2229 & +kxc(ir,ipts,8)*grho_grho1_up 2230 coeff_grho_dn=kxc(ir,ipts,7)*rho1_dn & 2231 & +kxc(ir,ipts,9)*grho_grho1_dn 2232 vxc1_updn(kr,ipts,1)=kxc(ir,ipts, 1)*rho1_up & 2233 & +kxc(ir,ipts, 2)*rho1_dn & 2234 & +kxc(ir,ipts, 6)*grho_grho1_up & 2235 & +kxc(ir,ipts,11)*grho_grho1 2236 vxc1_updn(kr,ipts,2)=kxc(ir,ipts, 3)*rho1_dn & 2237 & +kxc(ir,ipts, 2)*rho1_up & 2238 & +kxc(ir,ipts, 7)*grho_grho1_dn & 2239 & +kxc(ir,ipts,12)*grho_grho1 2240 gxc1r(:,1)=(kxc(ir,ipts,4)+kxc(ir,ipts,10))*g1_up(:) & 2241 & +kxc(ir,ipts,10) *g1_dn(:) & 2242 & +coeff_grho_up *g0_up(:) & 2243 & +coeff_grho_corr *g0(:) 2244 gxc1r(:,2)=(kxc(ir,ipts,5)+kxc(ir,ipts,10))*g1_dn(:) & 2245 & +kxc(ir,ipts,10) *g1_up(:) & 2246 & +coeff_grho_dn *g0_dn(:) & 2247 & +coeff_grho_corr *g0(:) 2248 !Accumulate gxc1_lm moments as Intg[gxc1(omega).Ylm(omega).d_omega] 2249 do ispden=1,nspden_updn 2250 do ilm=1,pawang%ylm_size 2251 ylm_ii=pawang%ylmr(ilm,ipts)*pawang%angwgth(ipts)*factor_ang_intg 2252 do ii=1,3 2253 gxc1(kr,ii,ilm,ispden)=gxc1(kr,ii,ilm,ispden)+gxc1r(ii,ispden)*ylm_ii 2254 end do 2255 end do 2256 end do 2257 2258 if (cplex_vxc==2) then 2259 if (cplex_den==2) then 2260 rho1im_up=rho1_updn(jr+1,2);rho1im_dn=rho1_updn(jr+1,1)-rho1im_up 2261 g1im_up(:)=grho1arr(jr+1,2,:);g1im_dn(:)=grho1arr(jr+1,1,:)-grho1arr(jr+1,2,:) 2262 g1im(:)=g1im_up(:)+g1im_dn(:) 2263 grho_grho1im_up=dot_product(g0_up,g1im_up) 2264 grho_grho1im_dn=dot_product(g0_dn,g1im_dn) 2265 grho_grho1im =dot_product(g0,g1im) 2266 coeff_grhoim_corr=kxc(ir,ipts,11)*rho1im_up & 2267 & +kxc(ir,ipts,12)*rho1im_dn & 2268 & +kxc(ir,ipts,13)*grho_grho1im 2269 coeff_grhoim_up=kxc(ir,ipts,6)*rho1im_up & 2270 & +kxc(ir,ipts,8)*grho_grho1im_up 2271 coeff_grhoim_dn=kxc(ir,ipts,7)*rho1im_dn & 2272 & +kxc(ir,ipts,9)*grho_grho1im_dn 2273 vxc1_updn(kr+1,ipts,1)=kxc(ir,ipts, 1)*rho1im_up & 2274 & +kxc(ir,ipts, 2)*rho1im_dn & 2275 & +kxc(ir,ipts, 6)*grho_grho1im_up & 2276 & +kxc(ir,ipts,11)*grho_grho1im 2277 vxc1_updn(kr+1,ipts,2)=kxc(ir,ipts, 3)*rho1im_dn & 2278 & +kxc(ir,ipts, 2)*rho1im_up & 2279 & +kxc(ir,ipts, 7)*grho_grho1im_dn & 2280 & +kxc(ir,ipts,12)*grho_grho1im 2281 gxc1i(:,1)=(kxc(ir,ipts,4)+kxc(ir,ipts,10))*g1im_up(:) & 2282 & +kxc(ir,ipts,10) *g1im_dn(:) & 2283 & +coeff_grhoim_up *g0_up(:) & 2284 & +coeff_grhoim_corr *g0(:) 2285 gxc1i(:,2)=(kxc(ir,ipts,5)+kxc(ir,ipts,10))*g1im_dn(:) & 2286 & +kxc(ir,ipts,10) *g1im_up(:) & 2287 & +coeff_grhoim_dn *g0_dn(:) & 2288 & +coeff_grhoim_corr *g0(:) 2289 !Accumulate gxc1_lm moments as Intg[gxc1(omega).Ylm(omega).d_omega] 2290 do ispden=1,nspden_updn 2291 do ilm=1,pawang%ylm_size 2292 ylm_ii=pawang%ylmr(ilm,ipts)*pawang%angwgth(ipts)*factor_ang_intg 2293 do ii=1,3 2294 gxc1(kr+1,ii,ilm,ispden)=gxc1(kr+1,ii,ilm,ispden)+gxc1i(ii,ispden)*ylm_ii 2295 end do 2296 end do 2297 end do 2298 else 2299 vxc1_updn(kr+1,ipts,1:2)=zero ; gxc1i(:,1:2)=zero 2300 end if 2301 end if 2302 2303 end do ! ir 2304 2305 end if ! nspden_updn 2306 2307 LIBPAW_DEALLOCATE(grho1arr) 2308 2309 end if ! LDA or GGA 2310 2311 ! ----- End of the loop on npts (angular part) 2312 end do 2313 2314 ! Deallocate memory 2315 if (xclevel==2.and.usecore==1) then 2316 LIBPAW_DEALLOCATE(drho1core) 2317 end if 2318 if (nspden==4) then 2319 LIBPAW_DEALLOCATE(rho1_updn) 2320 LIBPAW_DEALLOCATE(mag) 2321 end if 2322 2323 end if ! option/=3 2324 2325 !---------------------------------------------------------------------- 2326 !----- If GGA, modify 1st-order potential with term from density gradient 2327 !---------------------------------------------------------------------- 2328 if (xclevel==2.and.ixc/=13.and.option/=3) then 2329 ! Compute divergence of gxc1 and substract it from Vxc1 2330 2331 ! Need to multiply gxc1 by 2 in the non-polarised case 2332 factor=one;if (nspden_updn==1) factor=two 2333 2334 LIBPAW_ALLOCATE(dgxc1,(nrad)) 2335 LIBPAW_ALLOCATE(gg,(nrad)) 2336 do ispden=1,nspden_updn 2337 do ilm=1,pawang%ylm_size 2338 do ii=1,3 2339 do ir=1,nrad 2340 jr=cplex_vxc*(ir-1)+1 2341 gg(ir)=gxc1(jr,ii,ilm,ispden) 2342 end do 2343 call nderiv_gen(dgxc1,gg,pawrad) 2344 gg(2:nrad)=gg(2:nrad)/pawrad%rad(2:nrad) 2345 call pawrad_deducer0(gg,nrad,pawrad) 2346 do ipts=1,npts 2347 ylm_ii=pawang%ylmr(ilm,ipts)*pawang%anginit(ii,ipts) 2348 dylmdr_ii=dylmdr(ii,ipts,ilm) 2349 do ir=1,nrad 2350 jr=cplex_vxc*(ir-1)+1 2351 vxc1_(jr,ipts,ispden)=vxc1_(jr,ipts,ispden) & 2352 & -factor*(dgxc1(ir)*ylm_ii+gg(ir)*dylmdr_ii) 2353 end do 2354 end do ! ipts 2355 end do ! ii 2356 end do ! ilm 2357 end do ! ispden 2358 if (cplex_vxc==2) then 2359 do ispden=1,nspden_updn 2360 do ilm=1,pawang%ylm_size 2361 do ii=1,3 2362 do ir=1,nrad 2363 gg(ir)=gxc1(2*ir,ii,ilm,ispden) 2364 end do 2365 call nderiv_gen(dgxc1,gg,pawrad) 2366 gg(2:nrad)=gg(2:nrad)/pawrad%rad(2:nrad) 2367 call pawrad_deducer0(gg,nrad,pawrad) 2368 do ipts=1,npts 2369 ylm_ii=pawang%ylmr(ilm,ipts)*pawang%anginit(ii,ipts) 2370 dylmdr_ii=dylmdr(ii,ipts,ilm) 2371 do ir=1,nrad 2372 vxc1_(2*ir,ipts,ispden)=vxc1_(2*ir,ipts,ispden) & 2373 & -factor*(dgxc1(ir)*ylm_ii+gg(ir)*dylmdr_ii) 2374 end do 2375 end do ! ipts 2376 end do ! ii 2377 end do ! ilm 2378 end do ! ispden 2379 end if ! cplex_vxc 2380 LIBPAW_DEALLOCATE(dgxc1) 2381 LIBPAW_DEALLOCATE(gg) 2382 2383 end if ! GGA 2384 2385 ! ---------------------------------------------------------------------- 2386 ! ----- If non-collinear, rotate back potential according to magnetization 2387 ! ---------------------------------------------------------------------- 2388 if (option/=3.and.nspden==4) then 2389 ! Use of C pointers to avoid copies (when ISO C bindings are available) 2390 ! %@1$ xlf v15 compiler requires a auxilliary cptr variable 2391 #ifdef LIBPAW_ISO_C_BINDING 2392 cptr=c_loc(vxc1_updn(1,1,1)) 2393 call c_f_pointer(cptr,vxc1_diag,shape=[cplex_vxc*nrad*npts,nspden_updn]) 2394 cptr=c_loc(vxc1_(1,1,1)) 2395 call c_f_pointer(cptr,vxc1_nc,shape=[cplex_vxc*nrad*npts,nspden]) 2396 cptr=c_loc(vxc(1,1,1)) 2397 call c_f_pointer(cptr,vxc_,shape=[nrad*npts,nspden]) 2398 cptr=c_loc(kxc(1,1,1)) 2399 call c_f_pointer(cptr,kxc_,shape=[nrad*npts,3]) 2400 cptr=c_loc(kxc(1,1,nkxc-2)) 2401 call c_f_pointer(cptr,mag,shape=[nrad*npts,3]) 2402 #else 2403 LIBPAW_ALLOCATE(vxc1_diag,(cplex_vxc*nrad*npts,nspden_updn)) 2404 LIBPAW_ALLOCATE(vxc1_nc,(cplex_vxc*nrad*npts,nspden)) 2405 LIBPAW_ALLOCATE(vxc_,(nrad*npts,nspden)) 2406 LIBPAW_ALLOCATE(kxc_,(nrad*npts,3)) 2407 LIBPAW_ALLOCATE(mag,(nrad*npts,3)) 2408 vxc1_diag=reshape(vxc1_updn,[cplex_vxc*nrad*npts,nspden_updn]) 2409 vxc_=reshape(vxc(1:cplex_vxc*nrad,1:npts,1:nspden),[cplex_vxc*nrad*npts,nspden]) 2410 kxc_=reshape(kxc(1:nrad,1:npts,1:3),[nrad*npts,3]) 2411 mag=reshape(kxc(1:nrad,1:npts,nkxc-2:nkxc),[nrad*npts,3]) 2412 #endif 2413 !Should use cplex_den and cplex_vxc 2414 call pawxc_rotate_back_mag_dfpt(vxc1_diag,vxc1_nc,vxc_,kxc_,rho1_nc,mag,nrad*npts) 2415 #ifndef LIBPAW_ISO_C_BINDING 2416 vxc1_=reshape(vxc1_nc,[cplex_vxc*nrad,npts,nspden]) 2417 LIBPAW_DEALLOCATE(vxc1_diag) 2418 LIBPAW_DEALLOCATE(vxc1_nc) 2419 LIBPAW_DEALLOCATE(vxc_) 2420 LIBPAW_DEALLOCATE(kxc_) 2421 LIBPAW_DEALLOCATE(mag) 2422 #endif 2423 LIBPAW_DEALLOCATE(rho1_nc) 2424 LIBPAW_DEALLOCATE(vxc1_updn) 2425 end if 2426 2427 !---------------------------------------------------------------------- 2428 !----- Accumulate and store 2nd-order change of XC energy 2429 !---------------------------------------------------------------------- 2430 if (option/=1) then 2431 2432 ! Do loop on the angular part (theta,phi) 2433 do ipts=1,npts 2434 2435 ! Copy the input 1st-order density for this (theta,phi) 2436 rho1arr(:,:)=zero 2437 if (usexcnhat< 1) rho1_=>rhor1 2438 if (usexcnhat>=1) rho1_=>rhohat1 2439 do ispden=1,nspden 2440 do ilm=1,lm_size_eff 2441 if (lmselect(ilm)) rho1arr(:,ispden)=rho1arr(:,ispden) & 2442 & +rho1_(:,ilm,ispden)*pawang%ylmr(ilm,ipts) 2443 end do 2444 end do 2445 if (usecore==1) then 2446 rho1arr(:,1)=rho1arr(:,1)+corexc1(:) 2447 if (nspden==2) rho1arr(:,2)=rho1arr(:,2)+half*corexc1(:) 2448 end if 2449 2450 ! ----- Calculate d2Exc=Int[Vxc^(1)^*(r).n^(1)(r).dr] 2451 LIBPAW_ALLOCATE(ff,(nrad)) 2452 if (need_impart) then 2453 LIBPAW_ALLOCATE(gg,(nrad)) 2454 end if 2455 2456 ! COLLINEAR MAGNETISM 2457 if (nspden/=4) then 2458 if (cplex_vxc==1.and.cplex_den==1) then ! cplex_vxc==1 and cplex_den==1 2459 ff(:)=vxc1_(:,ipts,1)*rho1arr(:,nspden) 2460 if (nspden==2) ff(:)=ff(:)+vxc1_(:,ipts,2)*(rho1arr(:,1)-rho1arr(:,2)) 2461 if (need_impart) gg(:)=zero 2462 else if (cplex_vxc==2.and.cplex_den==2) then ! cplex_vxc==2 and cplex_den==2 2463 if (.not.need_impart) then ! Real part only 2464 do ir=1,nrad 2465 jr=2*ir;v11r=vxc1_(jr-1,ipts,1);v11i=vxc1_(jr,ipts,1) 2466 ro11r=rho1arr(jr-1,nspden);ro11i=rho1arr(jr,nspden) 2467 ff(ir)=v11r*ro11r+v11i*ro11i 2468 end do 2469 if (nspden==2) then 2470 do ir=1,nrad 2471 jr=2*ir;v22r=vxc1_(jr-1,ipts,2);v22i=vxc1_(jr,ipts,2) 2472 ro22r=rho1arr(jr-1,1)-rho1arr(jr-1,2) 2473 ro22i=rho1arr(jr ,1)-rho1arr(jr ,2) 2474 ff(ir)=ff(ir)+v22r*ro22r+v22i*ro22i 2475 end do 2476 end if 2477 else 2478 do ir=1,nrad ! Real and imaginary parts 2479 jr=2*ir;v11r=vxc1_(jr-1,ipts,1);v11i=vxc1_(jr,ipts,1) 2480 ro11r=rho1arr(jr-1,nspden);ro11i=rho1arr(jr,nspden) 2481 ff(ir)=v11r*ro11r+v11i*ro11i 2482 gg(ir)=v11r*ro11i-v11i*ro11r 2483 end do 2484 if (nspden==2) then 2485 do ir=1,nrad 2486 jr=2*ir;v22r=vxc1_(jr-1,ipts,2);v22i=vxc1_(jr,ipts,2) 2487 ro22r=rho1arr(jr-1,1)-rho1arr(jr-1,2) 2488 ro22i=rho1arr(jr ,1)-rho1arr(jr ,2) 2489 ff(ir)=ff(ir)+v22r*ro22r+v22i*ro22i 2490 gg(ir)=gg(ir)+v22r*ro22i-v22i*ro22r 2491 end do 2492 end if 2493 end if 2494 else ! other cases for cplex_vxc and cplex_den 2495 v11i=zero;ro11i=zero 2496 do ir=1,nrad 2497 jr=cplex_den*(ir-1)+1 ; kr=cplex_vxc*(ir-1)+1 2498 ro11r=rho1arr(jr,nspden);if (cplex_den==2) ro11i=rho1arr(jr+1,nspden) 2499 v11r=vxc1_(kr,ipts,1);if (cplex_vxc==2) v11i=vxc1_(kr+1,ipts,1) 2500 ff(ir)=v11r*ro11r+v11i*ro11i 2501 if (need_impart) gg(ir)=v11r*ro11i-v11i*ro11r 2502 end do 2503 if (nspden==2) then 2504 v22i=zero;ro22i=zero 2505 do ir=1,nrad 2506 jr=cplex_den*(ir-1)+1 ; kr=cplex_vxc*(ir-1)+1 2507 ro22r=rho1arr(jr,1)-rho1arr(jr,2) 2508 if (cplex_den==2) ro22i=rho1arr(jr+1,1)-rho1arr(jr+1,2) 2509 v22r=vxc1_(kr,ipts,2);if (cplex_vxc==2) v22i=vxc1_(kr+1,ipts,2) 2510 ff(ir)=ff(ir)+v22r*ro22r+v22i*ro22i 2511 gg(ir)=gg(ir)+v22r*ro22i-v22i*ro22r 2512 end do 2513 end if 2514 end if ! cplex_vxc and cplex_den 2515 2516 ! NON-COLLINEAR MAGNETISM 2517 else 2518 if (cplex_vxc==1.and.cplex_den==1) then ! cplex_vxc==1 and cplex_den==1 2519 ff(:)=half*(vxc1_(:,ipts,1)*(rho1arr(:,1)+rho1arr(:,4)) & 2520 & +vxc1_(:,ipts,2)*(rho1arr(:,1)-rho1arr(:,4))) & 2521 & +vxc1_(:,ipts,3)*rho1arr(:,2) & 2522 & -vxc1_(:,ipts,4)*rho1arr(:,3) 2523 if (need_impart) gg(:)=zero 2524 else ! other cases for cplex_vxc and cplex_den 2525 2526 ! V is stored as : v^11, v^22, V^12, i.V^21 (each are complex) 2527 ! N is stored as : n, m_x, m_y, mZ (each are complex) 2528 do ir=1,nrad 2529 jr=cplex_den*(ir-1)+1 ; kr=cplex_vxc*(ir-1)+1 2530 ro11r= rho1arr(jr,1)+rho1arr(jr,4) 2531 ro22r= rho1arr(jr,1)-rho1arr(jr,4) 2532 ro12r= rho1arr(jr,2);ro12i=-rho1arr(jr,3) 2533 ro21r= rho1arr(jr,2);ro21i= rho1arr(jr,3) 2534 if (cplex_den==2) then 2535 ro11i=rho1arr(jr+1,1)+rho1arr(jr+1,4) 2536 ro22i=rho1arr(jr+1,1)-rho1arr(jr+1,4) 2537 ro12r=ro12r+rho1arr(jr+1,3);ro12i=ro12i+rho1arr(jr+1,2) 2538 ro21r=ro21r-rho1arr(jr+1,3);ro21i=ro21i+rho1arr(jr+1,2) 2539 else 2540 ro11i=zero;ro22i=zero 2541 end if 2542 v11r= vxc1_(kr,ipts,1);v22r= vxc1_(kr,ipts,2) 2543 v12r= vxc1_(kr,ipts,3);v21i=-vxc1_(kr,ipts,1) 2544 if (cplex_vxc==2) then 2545 v11i= vxc1_(kr+1,ipts,1);v22i= vxc1_(kr+1,ipts,2) 2546 v12i= vxc1_(kr+1,ipts,3);v21r= vxc1_(kr+1,ipts,1) 2547 else 2548 v11i=zero;v22i=zero 2549 v12i=zero;v21i=zero 2550 end if 2551 ! Real part 2552 ff(ir)=half*(v11r*ro11r+v11i*ro11i+v22r*ro22r+v22i*ro22i & 2553 & +v12r*ro12r+v12i*ro12i+v21r*ro21r+v21i*ro21i) 2554 ! Imaginary part 2555 if (need_impart) & 2556 & gg(ir)=half*(v11r*ro11i-v11i*ro11r+v22r*ro22i-v22i*ro22r & 2557 & +v12r*ro12i-v12i*ro12r+v21r*ro21i-v21i*ro21r) 2558 end do 2559 end if ! cplex_vxc and cplex_den 2560 end if ! nspden 2561 2562 ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2 2563 call simp_gen(vxcrho,ff,pawrad) 2564 d2enxc=d2enxc+vxcrho*pawang%angwgth(ipts) 2565 LIBPAW_DEALLOCATE(ff) 2566 2567 if (need_impart) then 2568 gg(1:nrad)=gg(1:nrad)*pawrad%rad(1:nrad)**2 2569 call simp_gen(vxcrho,gg,pawrad) 2570 d2enxc_im=d2enxc_im+vxcrho*pawang%angwgth(ipts) 2571 LIBPAW_DEALLOCATE(gg) 2572 end if 2573 2574 ! ----- End of the loop on npts (angular part) 2575 end do 2576 2577 end if ! option/=1 2578 2579 !Add the four*pi factor of the angular integration 2580 if (option/=1) then 2581 d2enxc=d2enxc*four_pi 2582 if (need_impart) d2enxc_im=d2enxc_im*four_pi 2583 end if 2584 2585 !Free memory 2586 if (usexcnhat>0) then 2587 LIBPAW_DEALLOCATE(rhohat1) 2588 end if 2589 LIBPAW_DEALLOCATE(rho1arr) 2590 if (option==2) then 2591 LIBPAW_POINTER_DEALLOCATE(vxc1_) 2592 end if 2593 if (xclevel==2.and.option/=3) then 2594 LIBPAW_DEALLOCATE(gxc1) 2595 LIBPAW_DEALLOCATE(dylmdr) 2596 end if 2597 2598 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
PARENTS
m_pawxc
CHILDREN
rotate_back_mag_dfpt
SOURCE
5547 subroutine pawxc_drivexc_abinit() 5548 5549 5550 !This section has been created automatically by the script Abilint (TD). 5551 !Do not modify the following lines by hand. 5552 #undef ABI_FUNC 5553 #define ABI_FUNC 'pawxc_drivexc_abinit' 5554 !End of the abilint section 5555 5556 implicit none 5557 5558 ! ************************************************************************* 5559 5560 if ((.not.present(dvxc)).or.(.not.present(grho2)).or.(.not.present(vxcgrho))) then 5561 msg='dvxc, grho2 and vxcgrho should be present in pawxc_drivexc_wrapper' 5562 MSG_BUG(msg) 5563 end if 5564 if(mgga==1) then 5565 msg='MGGA is not yet coded in pawxc_drivexc_wrapper/ABINIT' 5566 MSG_ERROR(msg) 5567 end if 5568 5569 !Call to main XC driver 5570 !PENDING: we cannot handle all optional-variable combinations. 5571 !Hence, only two posibilities are considered here: 5572 !1) Pass dvxc, exexch, grho2 and vxcgrho 5573 if (present(exexch)) then 5574 call drivexc_main(exc,ixc,mgga,ndvxc,nd2vxc,ngr2,npts,nspden,nvxcgrho,order,rho,vxcrho,xclevel,& 5575 & dvxc=dvxc,d2vxc=d2vxc,exexch=exexch,grho2=grho2,vxcgrho=vxcgrho) 5576 else 5577 !2) Pass only dvxc, grho2 and vxcgrho 5578 call drivexc_main(exc,ixc,mgga,ndvxc,nd2vxc,ngr2,npts,nspden,nvxcgrho,order,rho,vxcrho,xclevel,& 5579 & dvxc=dvxc,d2vxc=d2vxc,grho2=grho2,vxcgrho=vxcgrho) 5580 end if 5581 5582 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
PARENTS
m_pawxc
CHILDREN
rotate_back_mag_dfpt
SOURCE
5602 subroutine pawxc_drivexc_libxc() 5603 5604 5605 !This section has been created automatically by the script Abilint (TD). 5606 !Do not modify the following lines by hand. 5607 #undef ABI_FUNC 5608 #define ABI_FUNC 'pawxc_drivexc_libxc' 5609 !End of the abilint section 5610 5611 implicit none 5612 5613 ! ************************************************************************* 5614 5615 !Check the compatibility of input arguments 5616 if (libxc_functionals_ismgga()) then 5617 msg='MGGA is not yet coded in pawxc_drivexc_wrapper/LIBXC' 5618 MSG_ERROR(msg) 5619 end if 5620 if (ixc>=0) then 5621 msg='ixc argument should be negative!' 5622 MSG_BUG(msg) 5623 end if 5624 if (ixc/=libxc_functionals_ixc()) then 5625 msg='The value of ixc differs from the one used to initialize the functional!' 5626 MSG_BUG(msg) 5627 end if 5628 if ((order<1.and.order/=-2).or.order>4) then 5629 msg='The only allowed values for order are 1, 2, -2, or 3!' 5630 MSG_BUG(msg) 5631 end if 5632 if ((order**2>1).and.(.not.present(dvxc))) then 5633 msg='The value of order is not compatible with the presence of the array dvxc!' 5634 MSG_BUG(msg) 5635 end if 5636 if ((order==3).and.(.not.present(d2vxc))) then 5637 msg='The value of order is not compatible with the presence of the array d2vxc!' 5638 MSG_BUG(msg) 5639 end if 5640 if (libxc_functionals_isgga()) then 5641 if ((.not.present(grho2)).or.(.not.present(vxcgrho)).or.(nvxcgrho==0)) then 5642 write(msg,'(3a)') 'At least one of the functionals is a GGA,',ch10, & 5643 & 'but not all the necessary optional arguments are present.' 5644 MSG_BUG(msg) 5645 end if 5646 if (ngr2==0.or.nvxcgrho/=3) then 5647 msg='The values of nvxcgrho or ngr2 are not compatible with GGA!' 5648 MSG_BUG(msg) 5649 end if 5650 end if 5651 5652 !Call LibXC routines 5653 if (libxc_functionals_isgga()) then 5654 if (order**2<=1) then 5655 call libxc_functionals_getvxc(ndvxc,nd2vxc,npts,nspden,order,rho,exc,vxcrho,& 5656 & grho2=grho2,vxcgr=vxcgrho) 5657 else 5658 call libxc_functionals_getvxc(ndvxc,nd2vxc,npts,nspden,order,rho,exc,vxcrho,& 5659 & grho2=grho2,vxcgr=vxcgrho,dvxc=dvxc) 5660 end if 5661 else 5662 if (order**2<=1) then 5663 call libxc_functionals_getvxc(ndvxc,nd2vxc,npts,nspden,order,rho,exc,vxcrho) 5664 else if (order**2<=4) then 5665 call libxc_functionals_getvxc(ndvxc,nd2vxc,npts,nspden,order,rho,exc,vxcrho,& 5666 & dvxc=dvxc) 5667 else 5668 call libxc_functionals_getvxc(ndvxc,nd2vxc,npts,nspden,order,rho,exc,vxcrho,& 5669 & dvxc=dvxc,d2vxc=d2vxc) 5670 end if 5671 end if 5672 5673 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.
PARENTS
m_pawxc
CHILDREN
rotate_back_mag_dfpt
SOURCE
5484 subroutine pawxc_drivexc_wrapper(exc,ixc,mgga,ndvxc,nd2vxc,ngr2,npts,nspden,nvxcgrho,& 5485 & order,rho,vxcrho,xclevel, & 5486 & dvxc,d2vxc,el_temp,exexch,fxcT,grho2,lrho,tau,vxcgrho,vxclrho,vxctau,xc_tb09_c) ! Optional arguments 5487 5488 5489 !This section has been created automatically by the script Abilint (TD). 5490 !Do not modify the following lines by hand. 5491 #undef ABI_FUNC 5492 #define ABI_FUNC 'pawxc_drivexc_wrapper' 5493 !End of the abilint section 5494 5495 implicit none 5496 5497 !Arguments ------------------------------------ 5498 !scalars 5499 integer,intent(in) :: ixc,mgga,ndvxc,nd2vxc,ngr2,npts,nspden,nvxcgrho,order,xclevel 5500 !arrays 5501 real(dp),intent(in) :: rho(npts,nspden) 5502 real(dp),intent(out) :: exc(npts),vxcrho(npts,nspden) 5503 integer,intent(in),optional :: exexch 5504 real(dp),intent(in),optional :: el_temp,xc_tb09_c 5505 real(dp),intent(in),optional:: grho2(npts,ngr2),lrho(npts,nspden*mgga),tau(npts,nspden*mgga) 5506 real(dp),intent(out),optional:: dvxc(npts,ndvxc),d2vxc(npts,nd2vxc),fxcT(npts),vxcgrho(npts,nvxcgrho) 5507 real(dp),intent(out),optional:: vxclrho(npts,nspden*mgga),vxctau(npts,nspden*mgga) 5508 5509 !Local variables------------------------------- 5510 character(len=100) :: msg 5511 5512 ! ************************************************************************* 5513 5514 !One could add here a section for other codes (i.e. BigDFT, ...) 5515 #if defined HAVE_LIBPAW_ABINIT 5516 call pawxc_drivexc_abinit() 5517 #elif defined HAVE_LIBXC 5518 call pawxc_drivexc_libxc() 5519 #else 5520 write(msg,'(5a)') 'libPAW XC driving routine only implemented in the following cases:',ch10, & 5521 & ' - ABINIT',ch10,' - libXC' 5522 MSG_BUG(msg) 5523 #endif 5524 5525 if (.false.) write(std_out,*) el_temp,xc_tb09_c,lrho(1,1),tau(1,1)
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)
PARENTS
m_pawxc,respfn,nonlinear
CHILDREN
SOURCE
5414 subroutine pawxc_get_nkxc(nkxc,nspden,xclevel) 5415 5416 5417 !This section has been created automatically by the script Abilint (TD). 5418 !Do not modify the following lines by hand. 5419 #undef ABI_FUNC 5420 #define ABI_FUNC 'pawxc_get_nkxc' 5421 !End of the abilint section 5422 5423 implicit none 5424 5425 !Arguments ------------------------------------ 5426 !scalars 5427 integer,intent(in) :: nspden,xclevel 5428 integer,intent(out) :: nkxc 5429 !arrays 5430 5431 !Local variables------------------------------- 5432 !scalars 5433 !arrays 5434 5435 !************************************************************************ 5436 5437 nkxc=0 5438 5439 if (nspden==1) then ! Non polarized 5440 5441 if (xclevel==1) nkxc=1 5442 if (xclevel==2) nkxc=7 5443 5444 else if (nspden==2) then ! Polarized 5445 5446 if (xclevel==1) nkxc=3 5447 if (xclevel==2) nkxc=19 5448 5449 else if (nspden==4) then ! Non-collinear 5450 5451 ! Store magnetization in the 3 last terms of Kxc 5452 if (xclevel==1) nkxc=6 5453 if (xclevel==2) nkxc=22 5454 5455 end if 5456 5457 end subroutine pawxc_get_nkxc
m_pawxc/pawxc_mkdenpos_wrapper [ Functions ]
[ Top ] [ m_pawxc ] [ Functions ]
NAME
pawxc_mkdenpos_wrapper
FUNCTION
Make a ground-state 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
PARENTS
m_pawxc
CHILDREN
rotate_back_mag_dfpt
SOURCE
595 subroutine pawxc_mkdenpos_wrapper(iwarn,nfft,nspden,option,rhonow,xc_denpos) 596 597 598 !This section has been created automatically by the script Abilint (TD). 599 !Do not modify the following lines by hand. 600 #undef ABI_FUNC 601 #define ABI_FUNC 'pawxc_mkdenpos_wrapper' 602 !End of the abilint section 603 604 implicit none 605 606 !Arguments ------------------------------------ 607 !scalars 608 integer,intent(in) :: nfft,nspden,option 609 integer,intent(inout) :: iwarn 610 real(dp),intent(in) :: xc_denpos 611 !arrays 612 real(dp),intent(inout) :: rhonow(nfft,nspden) 613 614 ! ************************************************************************* 615 616 #if defined HAVE_LIBPAW_ABINIT 617 call mkdenpos(iwarn,nfft,nspden,option,rhonow,xc_denpos) 618 #else 619 call pawxc_mkdenpos_local() 620 #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
PARENTS
m_pawxc
CHILDREN
rotate_back_mag_dfpt
SOURCE
5811 subroutine pawxc_rotate_back_mag(vxc_in,vxc_out,mag,vectsize) 5812 5813 #if defined HAVE_LIBPAW_ABINIT 5814 use m_xc_noncoll, only : rotate_back_mag 5815 #endif 5816 5817 !This section has been created automatically by the script Abilint (TD). 5818 !Do not modify the following lines by hand. 5819 #undef ABI_FUNC 5820 #define ABI_FUNC 'pawxc_rotate_back_mag' 5821 !End of the abilint section 5822 5823 implicit none 5824 5825 !Arguments ------------------------------------ 5826 !scalars 5827 integer,intent(in) :: vectsize 5828 !arrays 5829 real(dp),intent(in) :: vxc_in(vectsize,2),mag(vectsize,3) 5830 real(dp),intent(out) :: vxc_out(vectsize,4) 5831 5832 !Local variables------------------------------- 5833 !scalars 5834 #if ! defined HAVE_LIBPAW_ABINIT 5835 integer :: ipt 5836 real(dp),parameter :: m_norm_min=tol8 5837 real(dp) :: dvdn,dvdz,m_norm 5838 #endif 5839 !arrays 5840 5841 ! ************************************************************************* 5842 5843 !One could add here a section for other codes (i.e. BigDFT, ...) 5844 #if defined HAVE_LIBPAW_ABINIT 5845 call rotate_back_mag(vxc_in,vxc_out,mag,vectsize) 5846 #else 5847 do ipt=1,vectsize 5848 m_norm=sqrt(mag(ipt,1)**2+mag(ipt,2)**2+mag(ipt,3)**2) 5849 dvdn=half*(vxc_in(ipt,1)+vxc_in(ipt,2)) 5850 if (m_norm>m_norm_min) then 5851 dvdz=half*(vxc_in(ipt,1)-vxc_in(ipt,2))/m_norm 5852 vxc_out(ipt,1)=dvdn+mag(ipt,3)*dvdz 5853 vxc_out(ipt,2)=dvdn-mag(ipt,3)*dvdz 5854 vxc_out(ipt,3)= mag(ipt,1)*dvdz 5855 vxc_out(ipt,4)=-mag(ipt,2)*dvdz 5856 else 5857 vxc_out(ipt,1:2)=dvdn 5858 vxc_out(ipt,3:4)=zero 5859 end if 5860 end do 5861 #endif 5862 5863 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
PARENTS
m_pawxc
CHILDREN
rotate_back_mag_dfpt
SOURCE
5896 subroutine pawxc_rotate_back_mag_dfpt(vxc1_in,vxc1_out,vxc,kxc,rho1,mag,vectsize) 5897 5898 #if defined HAVE_LIBPAW_ABINIT 5899 use m_xc_noncoll, only : rotate_back_mag_dfpt 5900 #endif 5901 5902 !This section has been created automatically by the script Abilint (TD). 5903 !Do not modify the following lines by hand. 5904 #undef ABI_FUNC 5905 #define ABI_FUNC 'pawxc_rotate_back_mag_dfpt' 5906 !End of the abilint section 5907 5908 implicit none 5909 5910 !Arguments ------------------------------------ 5911 !scalars 5912 integer,intent(in) :: vectsize 5913 !arrays 5914 real(dp),intent(in) :: kxc(:,:),mag(vectsize,3),rho1(vectsize,4) 5915 real(dp),intent(in) :: vxc(vectsize,4),vxc1_in(vectsize,2) 5916 real(dp),intent(out) :: vxc1_out(vectsize,4) 5917 5918 !Local variables------------------------------- 5919 !scalars 5920 #if ! defined HAVE_LIBPAW_ABINIT 5921 character(len=100) :: msg 5922 #endif 5923 !arrays 5924 5925 ! ************************************************************************* 5926 5927 !One could add here a section for other codes (i.e. BigDFT, ...) 5928 #if defined HAVE_LIBPAW_ABINIT 5929 call rotate_back_mag_dfpt(1,vxc1_in,vxc1_out,vxc,kxc,rho1,mag,vectsize,1) 5930 #else 5931 msg='[LIBPAW] Non-collinear DFPT not available (only in ABINIT)!' 5932 MSG_ERROR(msg) 5933 #endif 5934 5935 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
PARENTS
m_pawxc
CHILDREN
rotate_back_mag_dfpt
SOURCE
5709 subroutine pawxc_rotate_mag(rho_in,rho_out,mag,vectsize,mag_norm_out,rho_out_format) 5710 5711 #if defined HAVE_LIBPAW_ABINIT 5712 use m_xc_noncoll, only : rotate_mag 5713 #endif 5714 5715 !This section has been created automatically by the script Abilint (TD). 5716 !Do not modify the following lines by hand. 5717 #undef ABI_FUNC 5718 #define ABI_FUNC 'pawxc_rotate_mag' 5719 !End of the abilint section 5720 5721 implicit none 5722 5723 !Arguments ------------------------------------ 5724 !scalars 5725 integer,intent(in) :: vectsize 5726 integer,intent(in),optional :: rho_out_format 5727 !arrays 5728 real(dp),intent(in) :: rho_in(vectsize,4),mag(vectsize,3) 5729 real(dp),intent(out) :: rho_out(vectsize,2) 5730 real(dp),intent(out),optional :: mag_norm_out(vectsize) 5731 5732 !Local variables------------------------------- 5733 !scalars 5734 #if ! defined HAVE_LIBPAW_ABINIT 5735 integer :: ipt 5736 real(dp),parameter :: m_norm_min=tol8 5737 real(dp) :: m_norm,rhoin_dot_mag,rho_up 5738 #endif 5739 !arrays 5740 5741 ! ************************************************************************* 5742 5743 !One could add here a section for other codes (i.e. BigDFT, ...) 5744 #if defined HAVE_LIBPAW_ABINIT 5745 if (present(rho_out_format).and.present(mag_norm_out)) then 5746 call rotate_mag(rho_in,rho_out,mag,vectsize,1, & 5747 & rho_out_format=rho_out_format,mag_norm_out=mag_norm_out) 5748 else if (present(rho_out_format).and..not.present(mag_norm_out)) then 5749 call rotate_mag(rho_in,rho_out,mag,vectsize,1,rho_out_format=rho_out_format) 5750 else if (.not.present(rho_out_format).and.present(mag_norm_out)) then 5751 call rotate_mag(rho_in,rho_out,mag,vectsize,1,mag_norm_out=mag_norm_out) 5752 else 5753 call rotate_mag(rho_in,rho_out,mag,vectsize,1) 5754 end if 5755 #else 5756 do ipt=1,vectsize 5757 m_norm=sqrt(mag(ipt,1)**2+mag(ipt,2)**2+mag(ipt,3)**2) 5758 rhoin_dot_mag=rho_in(ipt,2)*mag(ipt,1)+rho_in(ipt,3)*mag(ipt,2) & 5759 & +rho_in(ipt,4)*mag(ipt,3) 5760 if(m_norm>m_norm_min)then 5761 rho_out(ipt,1)=half*(rho_in(ipt,1)+rhoin_dot_mag/m_norm) 5762 rho_out(ipt,2)=half*(rho_in(ipt,1)-rhoin_dot_mag/m_norm) 5763 else 5764 rho_out(ipt,1)=half*rho_in(ipt,1) 5765 rho_out(ipt,2)=half*rho_in(ipt,1) 5766 end if 5767 if (present(mag_norm_out).and.m_norm> m_norm_min) mag_norm_out(ipt)=m_norm 5768 if (present(mag_norm_out).and.m_norm<=m_norm_min) mag_norm_out(ipt)=zero 5769 end do 5770 if (present(rho_out_format)) then 5771 if (rho_out_format==2) then 5772 do ipt=1,vectsize 5773 rho_up=rho_out(ipt,1) 5774 rho_out(ipt,1)=rho_up+rho_out(ipt,2) 5775 rho_out(ipt,2)=rho_up 5776 end do 5777 end if 5778 end if 5779 #endif 5780 5781 end subroutine pawxc_rotate_mag
m_pawxc/pawxc_size_dvxc_wrapper [ Functions ]
[ Top ] [ m_pawxc ] [ Functions ]
NAME
pawxc_size_dvxc_wrapper
FUNCTION
Give the size of the array dvxc(npts,ndvxc) and the second dimension of the d2vxc(npts,nd2vxc) needed for the allocations depending on the routine which is called from 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)
OUTPUT
ndvxc size of the array dvxc(npts,ndvxc) for allocation ngr2 size of the array grho2_updn(npts,ngr2) for allocation nd2vxc size of the array d2vxc(npts,nd2vxc) for allocation nvxcdgr size of the array dvxcdgr(npts,nvxcdgr) for allocation
PARENTS
m_pawxc
CHILDREN
rotate_back_mag_dfpt
SOURCE
289 subroutine pawxc_size_dvxc_wrapper(ixc,ndvxc,ngr2,nd2vxc,nspden,nvxcdgr,order) 290 291 292 !This section has been created automatically by the script Abilint (TD). 293 !Do not modify the following lines by hand. 294 #undef ABI_FUNC 295 #define ABI_FUNC 'pawxc_size_dvxc_wrapper' 296 !End of the abilint section 297 298 implicit none 299 300 !Arguments---------------------- 301 integer, intent(in) :: ixc,nspden,order 302 integer, intent(out) :: ndvxc,nd2vxc,ngr2,nvxcdgr 303 304 ! ************************************************************************* 305 306 #if defined HAVE_LIBPAW_ABINIT 307 call size_dvxc(ixc,ndvxc,ngr2,nd2vxc,nspden,nvxcdgr,order) 308 #else 309 call pawxc_size_dvxc_local() 310 #endif
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.
PARENTS
m_pawxc
CHILDREN
rotate_back_mag_dfpt
SOURCE
467 subroutine pawxc_xcmult_wrapper(depsxc,nfft,ngrad,nspden,nspgrad,rhonow) 468 469 470 !This section has been created automatically by the script Abilint (TD). 471 !Do not modify the following lines by hand. 472 #undef ABI_FUNC 473 #define ABI_FUNC 'pawxc_xcmult_wrapper' 474 !End of the abilint section 475 476 implicit none 477 478 !Arguments ------------------------------------ 479 !scalars 480 integer,intent(in) :: nfft,ngrad,nspden,nspgrad 481 !arrays 482 real(dp),intent(in) :: depsxc(nfft,nspgrad) 483 real(dp),intent(inout) :: rhonow(nfft,nspden,ngrad*ngrad) 484 485 ! ************************************************************************* 486 487 #if defined HAVE_LIBPAW_ABINIT 488 call xcmult(depsxc,nfft,ngrad,nspden,nspgrad,rhonow) 489 #else 490 call pawxc_xcmult_local() 491 #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]]
PARENTS
m_pawxc
CHILDREN
rotate_back_mag_dfpt
SOURCE
135 subroutine pawxc_xcpositron_wrapper(fnxc,grhoe2,ixcpositron,ngr,npt,posdensity0_limit,& 136 & rhoer,rhopr,vxce,vxcegr,vxcp,& 137 & dvxce,dvxcp) ! optional arguments 138 139 140 !This section has been created automatically by the script Abilint (TD). 141 !Do not modify the following lines by hand. 142 #undef ABI_FUNC 143 #define ABI_FUNC 'pawxc_xcpositron_wrapper' 144 !End of the abilint section 145 146 implicit none 147 148 !Arguments ------------------------------------ 149 !scalars 150 integer,intent(in) :: ixcpositron,ngr,npt 151 logical,intent(in) :: posdensity0_limit 152 !arrays 153 real(dp),intent(in) :: grhoe2(ngr),rhoer(npt),rhopr(npt) 154 real(dp),intent(out) :: fnxc(npt),vxce(npt),vxcegr(ngr),vxcp(npt) 155 real(dp),intent(out),optional :: dvxce(npt),dvxcp(npt) 156 157 !Local variables------------------------------- 158 159 ! ************************************************************************* 160 161 #if defined HAVE_LIBPAW_ABINIT 162 call pawxc_xcpositron_abinit() 163 #else 164 call pawxc_xcpositron_local() 165 #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= true if usepawu==4 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)
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)
PARENTS
m_pawpsp,pawdenpot
CHILDREN
rotate_back_mag_dfpt
SOURCE
3761 subroutine pawxcm(corexc,enxc,enxcdc,exexch,ixc,kxc,lm_size,lmselect,nhat,nkxc,non_magnetic_xc,nrad,nspden,option,& 3762 & pawang,pawrad,pawxcdev,rhor,usecore,usexcnhat,vxc,xclevel,xc_denpos) 3763 3764 3765 !This section has been created automatically by the script Abilint (TD). 3766 !Do not modify the following lines by hand. 3767 #undef ABI_FUNC 3768 #define ABI_FUNC 'pawxcm' 3769 !End of the abilint section 3770 3771 implicit none 3772 3773 !Arguments ------------------------------------ 3774 !scalars 3775 integer,intent(in) :: exexch,ixc,lm_size,nkxc,nrad,nspden,option,pawxcdev,usecore 3776 integer,intent(in) :: usexcnhat,xclevel 3777 logical,intent(in) :: non_magnetic_xc 3778 real(dp),intent(in) :: xc_denpos 3779 real(dp),intent(out) :: enxc,enxcdc 3780 type(pawang_type),intent(in) :: pawang 3781 type(pawrad_type),intent(in) :: pawrad 3782 !arrays 3783 logical,intent(in) :: lmselect(lm_size) 3784 real(dp),intent(in) :: corexc(nrad) 3785 real(dp),intent(in) :: nhat(nrad,lm_size,nspden*((usexcnhat+1)/2)) 3786 real(dp),intent(in) :: rhor(nrad,lm_size,nspden) 3787 real(dp),intent(out) :: kxc(nrad,lm_size,nkxc) 3788 real(dp),intent(out) :: vxc(nrad,lm_size,nspden) 3789 3790 !Local variables------------------------------- 3791 !scalars 3792 integer :: ilm,ir,ir1,ir2,ispden,iwarn,jr,nspden_updn,nsums 3793 real(dp),parameter :: delta=1.d-4 3794 real(dp) :: dvxc1,dvxc2,dvxc3,dvxc4,dvxca,dvxcb,dvxcc,dvxcd 3795 real(dp) :: fact,invsqfpi,invsqfpi2,sqfpi,sqfpi2,tol_rho 3796 character(len=500) :: msg 3797 !arrays 3798 real(dp),allocatable :: d1kxc(:,:),d2kxc(:,:),d1vxc(:,:),d2vxc(:,:) 3799 real(dp),allocatable :: exc_(:),exci(:),ff(:),gg(:) 3800 real(dp),allocatable :: kxc1(:,:),kxc2(:,:),kxcdn1(:,:),kxcdn2(:,:),kxci(:,:) 3801 real(dp),allocatable :: m_norm_inv(:),rho_(:,:),rhoinv(:,:),rhosph(:,:) 3802 real(dp),allocatable :: v1sum(:,:),v2sum(:,:,:) 3803 real(dp),allocatable :: vxc1(:,:),vxc2(:,:),vxcdn1(:,:),vxcdn2(:,:),vxci(:,:) 3804 real(dp),allocatable,target :: rho_nc(:,:),rho_updn(:,:,:),vxc_diag(:,:),vxc_nc(:,:) 3805 real(dp), LIBPAW_CONTIGUOUS pointer :: mag_nc(:,:),rho_dn(:,:),rho_up(:,:) 3806 3807 !************************************************************************ 3808 3809 if(nkxc>3) then 3810 msg='Kxc not implemented for GGA!' 3811 MSG_ERROR(msg) 3812 end if 3813 if(nkxc>0.and.nspden==4) then 3814 msg='Kxc not implemented for non-collinear magnetism!' 3815 MSG_ERROR(msg) 3816 end if 3817 if (option/=1.and.option/=5) then 3818 if (nrad<pawrad%int_meshsz) then 3819 msg='When option=0,2,3,4, nrad must be greater than pawrad%int_meshsz!' 3820 MSG_BUG(msg) 3821 end if 3822 end if 3823 3824 !---------------------------------------------------------------------- 3825 !----- Initializations 3826 !---------------------------------------------------------------------- 3827 3828 !Arrays dimensions and constants 3829 iwarn=0 3830 nspden_updn=min(nspden,2) 3831 sqfpi=sqrt(four_pi);sqfpi2=half*sqfpi 3832 invsqfpi=one/sqfpi;invsqfpi2=half*invsqfpi 3833 nsums=2*nspden_updn-1 3834 3835 !Initializations of output arrays 3836 if (option/=1.and.option/=5) enxc=zero 3837 if (option==0.or.option==2) enxcdc=zero 3838 if (option/=3.and.option/=4) vxc(:,:,:)=zero 3839 if (nkxc/=0) kxc(:,:,:)=zero 3840 3841 if (xclevel==0.or.ixc==0) then ! No xc at all is applied (usually for testing) 3842 msg='Note that no xc is applied (ixc=0). Returning' 3843 MSG_WARNING(msg) 3844 return 3845 end if 3846 3847 !---------------------------------------------------------------------- 3848 !----- Build several densities 3849 !---------------------------------------------------------------------- 3850 3851 !rho_updn contains the effective density used for XC 3852 !with core density and/or compensation density eventually included 3853 !----------------------------------------------------------------- 3854 LIBPAW_ALLOCATE(rho_updn,(nrad,lm_size,nspden)) 3855 rho_updn(:,:,:)=rhor(:,:,:) 3856 if (usexcnhat==2) rho_updn(:,:,:)=rho_updn(:,:,:)+nhat(:,:,:) 3857 if (usecore==1) then 3858 if (nspden==1.or.nspden==4) then 3859 rho_updn(:,1,1)=rho_updn(:,1,1)+sqfpi*corexc(:) 3860 else if (nspden==2) then 3861 rho_updn(:,1,1)=rho_updn(:,1,1)+sqfpi*corexc(:) 3862 rho_updn(:,1,2)=rho_updn(:,1,2)+sqfpi2*corexc(:) 3863 end if 3864 end if 3865 3866 3867 if(non_magnetic_xc) then 3868 if(nspden==2) then 3869 rho_updn(:,:,2)=rho_updn(:,:,1)/two 3870 endif 3871 if(nspden==4) then 3872 rho_updn(:,:,2)=zero 3873 rho_updn(:,:,3)=zero 3874 rho_updn(:,:,4)=zero 3875 endif 3876 endif 3877 3878 !In case of collinear magnetism, separate up and down contributions 3879 if (nspden==2) then 3880 LIBPAW_ALLOCATE(ff,(nrad)) 3881 do ilm=1,lm_size 3882 ff(:)=rho_updn(:,ilm,2) 3883 rho_updn(:,ilm,2)=rho_updn(:,ilm,1)-ff(:) 3884 rho_updn(:,ilm,1)=ff(:) 3885 end do 3886 LIBPAW_DEALLOCATE(ff) 3887 end if 3888 3889 !Direct links to rho_up and rho_dn 3890 rho_up => rho_updn(:,:,1) 3891 rho_dn => rho_updn(:,:,nspden_updn) 3892 3893 !rhoSPH contains the spherical part of effective density 3894 !(including Y00 spherical harmonic) 3895 !----------------------------------------------------------------- 3896 LIBPAW_ALLOCATE(rhosph,(nrad,nspden_updn)) 3897 3898 ! Non-magnetic system: rhoSPH(;,1)=(1/2).rhoSPH_total 3899 if (nspden==1) then 3900 rhosph(:,1)=rho_updn(:,1,1)*invsqfpi2 3901 3902 ! Collinear magnetism: rhoSPH = (rhoSPH_up, rhoSPH_dn) 3903 else if (nspden==2) then 3904 rhosph(:,1:2)=rho_updn(:,1,1:2)*invsqfpi 3905 3906 ! Non-collinear magnetism: rhoSPH = (rhoSPH_up, rhoSPH_dn) 3907 ! obtained by rotating rho_updn 3908 else if (nspden==4) then 3909 LIBPAW_ALLOCATE(m_norm_inv,(nrad)) 3910 LIBPAW_ALLOCATE(rho_nc,(nrad,nspden)) 3911 do ispden=1,nspden 3912 rho_nc(1:nrad,ispden)=rho_updn(1:nrad,1,ispden)*invsqfpi 3913 end do 3914 mag_nc => rho_nc(:,2:4) 3915 call pawxc_rotate_mag(rho_nc,rhosph,mag_nc,nrad,mag_norm_out=m_norm_inv) 3916 do ir=1,nrad 3917 m_norm_inv(ir)=merge(invsqfpi/m_norm_inv(ir),zero,m_norm_inv(ir)>rho_min) 3918 end do 3919 end if 3920 3921 !Make spherical density positive 3922 call pawxc_mkdenpos_wrapper(iwarn,nrad,nspden_updn,0,rhosph,xc_denpos) 3923 3924 !---------------------------------------------------------------------- 3925 !----- Compute Exc(rhoSPH) and Vxc(rhoSPH) 3926 !---------------------------------------------------------------------- 3927 3928 LIBPAW_ALLOCATE(exci,(nrad)) 3929 LIBPAW_ALLOCATE(vxci,(nrad,nspden_updn)) 3930 LIBPAW_ALLOCATE(kxci,(nrad,nkxc)) 3931 call pawxcsph(exci,exexch,ixc,kxci,nkxc,nrad,nspden_updn,pawrad,rhosph,vxci,xclevel) 3932 3933 !---------------------------------------------------------------------- 3934 !----- Compute numerical derivatives of Vxc,Kxc (by finite diff. scheme) 3935 !---------------------------------------------------------------------- 3936 3937 if (option/=4.and.option/=5) then 3938 LIBPAW_ALLOCATE(exc_,(nrad)) 3939 LIBPAW_ALLOCATE(rho_,(nrad,nspden_updn)) 3940 3941 if (nspden_updn==2) rho_(:,2)=rhosph(:,2) 3942 3943 ! Compute Exc, Vxc for rho+delta_rho 3944 LIBPAW_ALLOCATE(vxc1,(nrad,nspden_updn)) 3945 LIBPAW_ALLOCATE(kxc1,(nrad,nkxc)) 3946 rho_(:,1)=(one+delta)*rhosph(:,1) 3947 call pawxcsph(exc_,exexch,ixc,kxc1,nkxc,nrad,nspden_updn,pawrad,rho_,vxc1,xclevel) 3948 3949 ! Compute Exc, Vxc for rho-delta_rho 3950 LIBPAW_ALLOCATE(vxc2,(nrad,nspden_updn)) 3951 LIBPAW_ALLOCATE(kxc2,(nrad,nkxc)) 3952 rho_(:,1)=(one-delta)*rhosph(:,1) 3953 call pawxcsph(exc_,exexch,ixc,kxc2,nkxc,nrad,nspden_updn,pawrad,rho_,vxc2,xclevel) 3954 3955 ! Additional terms for spin-polarized systems 3956 if (nspden_updn==2) then 3957 rho_(:,1)=rhosph(:,1) 3958 3959 ! Compute Exc, Vxc for rho+delta_rho_down 3960 LIBPAW_ALLOCATE(vxcdn1,(nrad,nspden_updn)) 3961 LIBPAW_ALLOCATE(kxcdn1,(nrad,nkxc)) 3962 rho_(:,2)=(one+delta)*rhosph(:,2) 3963 call pawxcsph(exc_,exexch,ixc,kxcdn1,nkxc,nrad,nspden_updn,pawrad,rho_,vxcdn1,xclevel) 3964 3965 ! Compute Exc, Vxc for rho-delta_rho_down 3966 LIBPAW_ALLOCATE(vxcdn2,(nrad,nspden_updn)) 3967 LIBPAW_ALLOCATE(kxcdn2,(nrad,nkxc)) 3968 rho_(:,2)=(one-delta)*rhosph(:,2) 3969 call pawxcsph(exc_,exexch,ixc,kxcdn2,nkxc,nrad,nspden_updn,pawrad,rho_,vxcdn2,xclevel) 3970 3971 end if !nspden_updn==2 3972 LIBPAW_DEALLOCATE(exc_) 3973 LIBPAW_DEALLOCATE(rho_) 3974 3975 ! Store inverse of density finite step 3976 LIBPAW_ALLOCATE(rhoinv,(nrad,nspden_updn)) 3977 fact=one/delta;if (nspden_updn==1) fact=half*fact 3978 do ispden=1,nspden_updn 3979 do ir=1,nrad 3980 if (rhosph(ir,ispden)>rho_min) then 3981 rhoinv(ir,ispden)=fact/rhosph(ir,ispden) 3982 else 3983 rhoinv(ir,ispden)=zero 3984 end if 3985 end do 3986 end do 3987 3988 ! Compute numerical first derivatives of Vxc (by finite difference scheme) 3989 LIBPAW_ALLOCATE(d1vxc,(nrad,2*nspden_updn-1)) 3990 ! Non-magnetic system: compute dVxc/dn 3991 if (nspden==1) then 3992 d1vxc(1:nrad,1)=(vxc1(1:nrad,1)-vxc2(1:nrad,1))*half*rhoinv(1:nrad,1) 3993 ! Collinear magnetism: compute dVxc_up/dn_up,dVxc_dn/dn_up,dVxc_dn/dn_dn 3994 else if (nspden==2) then 3995 d1vxc(1:nrad,1)=(vxc1(1:nrad,1)-vxc2(1:nrad,1))*half*rhoinv(1:nrad,1) 3996 d1vxc(1:nrad,2)=(vxc1(1:nrad,2)-vxc2(1:nrad,2))*half*rhoinv(1:nrad,1) 3997 d1vxc(1:nrad,3)=(vxcdn1(1:nrad,2)-vxcdn2(1:nrad,2))*half*rhoinv(1:nrad,2) 3998 ! Non-collinear magnetism: compute 1/2 d(Vxc_up+Vxc_dn)/dn,1/2 d(Vxc_up-Vxc_dn)/dn 3999 ! 1/2 d(Vxc_up-Vxc_dn)/dm 4000 else if (nspden==4) then 4001 do ir=1,nrad 4002 fact=half*rhoinv(ir,1) 4003 dvxc1=(vxc1 (ir,1)-vxc2 (ir,1))*fact !dVxc_up/dn_up 4004 dvxc2=(vxc1 (ir,2)-vxc2 (ir,2))*fact !dVxc_dn/dn_up 4005 fact=half*rhoinv(ir,2) 4006 dvxc3=(vxcdn1(ir,2)-vxcdn2(ir,2))*fact !dVxc_dn/dn_dn 4007 dvxca=dvxc1+dvxc3;dvxcb=dvxc1-dvxc3;dvxcc=two*dvxc2 !Temporary terms 4008 d1vxc(ir,1)=quarter*(dvxca+dvxcc) ! 1/2 d(Vxc_up+Vxc_dn)/dn 4009 d1vxc(ir,2)=quarter* dvxcb ! 1/2 d(Vxc_up-Vxc_dn)/dn 4010 d1vxc(ir,3)=quarter*(dvxca-dvxcc) ! 1/2 d(Vxc_up-Vxc_dn)/dm 4011 end do 4012 end if 4013 4014 ! Compute numerical second derivatives of Vxc (by finite difference scheme) 4015 if (option/=3.or.pawxcdev>=2) then 4016 LIBPAW_ALLOCATE(d2vxc,(nrad,3*nspden_updn-2)) 4017 ! Non-magnetic system: compute d2Vxc/dn2 4018 if (nspden==1) then 4019 d2vxc(1:nrad,1)=(vxc1(1:nrad,1)+vxc2(1:nrad,1)-two*vxci(1:nrad,1))*rhoinv(1:nrad,1)**2 4020 ! Collinear magnetism: compute d2Vxc_up/dn_up2,d2Vxc_dn/dn_up2,d2Vxc_up/dn_dn2,d2Vxc_dn/dn_dn2 4021 else if (nspden==2) then 4022 d2vxc(1:nrad,1)=(vxc1(1:nrad,1)+vxc2(1:nrad,1)-two*vxci(1:nrad,1))*rhoinv(1:nrad,1)**2 4023 d2vxc(1:nrad,2)=(vxc1(1:nrad,2)+vxc2(1:nrad,2)-two*vxci(1:nrad,2))*rhoinv(1:nrad,1)**2 4024 d2vxc(1:nrad,3)=(vxcdn1(1:nrad,1)+vxcdn2(1:nrad,1)-two*vxci(1:nrad,1))*rhoinv(1:nrad,2)**2 4025 d2vxc(1:nrad,4)=(vxcdn1(1:nrad,2)+vxcdn2(1:nrad,2)-two*vxci(1:nrad,2))*rhoinv(1:nrad,2)**2 4026 ! Non-collinear magnetism: compute 1/2 d2(Vxc_up+Vxc_dn)/dn2,1/2 d2(Vxc_up-Vxc_dn)/dn2 4027 ! 1/2 d2(Vxc_up+Vxc_dn)/dm2,1/2 d2(Vxc_up-Vxc_dn)/dm2 4028 else if (nspden==4) then 4029 do ir=1,nrad 4030 fact=rhoinv(ir,1)**2 4031 dvxc1=(vxc1 (ir,1)+vxc2 (ir,1)-two*vxci(ir,1))*fact !d2Vxc_up/dn_up2 4032 dvxc2=(vxc1 (ir,2)+vxc2 (ir,2)-two*vxci(ir,2))*fact !d2Vxc_dn/dn_up2 4033 fact=rhoinv(ir,2)**2 4034 dvxc3=(vxcdn1(ir,1)+vxcdn2(ir,1)-two*vxci(ir,1))*fact !d2Vxc_up/dn_dn2 4035 dvxc4=(vxcdn1(ir,2)+vxcdn2(ir,2)-two*vxci(ir,2))*fact !d2Vxc_dn/dn_dn2 4036 dvxca=dvxc1+dvxc4;dvxcb=dvxc1-dvxc4 !Temporary terms 4037 dvxcc=dvxc2+dvxc3;dvxcd=dvxc2-dvxc3 !Temporary terms 4038 d2vxc(ir,1)=(dvxca+three*dvxcc)/8._dp ! 1/2 d2(Vxc_up+Vxc_dn)/dn2 4039 d2vxc(ir,2)=(dvxcb+dvxcd)/8._dp ! 1/2 d2(Vxc_up-Vxc_dn)/dn2 4040 d2vxc(ir,3)=(dvxca-dvxcc)/8._dp ! 1/2 d2(Vxc_up+Vxc_dn)/dm2 4041 d2vxc(ir,4)=(dvxcb-three*dvxcd)/8._dp ! 1/2 d2(Vxc_up-Vxc_dn)/dm2 4042 end do 4043 end if 4044 end if 4045 4046 ! Compute numerical first and second derivatives of Kxc (by finite difference scheme) 4047 if (nkxc>0) then 4048 ! Non-magnetic system: compute dKxc/dn, d2Kxc/dn2 4049 if (nspden==1) then 4050 LIBPAW_ALLOCATE(d1kxc,(nrad,1)) 4051 LIBPAW_ALLOCATE(d2kxc,(nrad,1)) 4052 d1kxc(1:nrad,1)=(kxc1(1:nrad,1)-kxc2(1:nrad,1))*half*rhoinv(1:nrad,1) 4053 d2kxc(1:nrad,1)=(kxc1(1:nrad,1)+kxc2(1:nrad,1)-two*kxci(1:nrad,1))*rhoinv(1:nrad,1)**2 4054 ! Collinear magnetism: compute dKxc_upup/dn_up,dKxc_updn/dn_up,dKxc_updn/dn_dn,dKxc_dndn/dn_dn 4055 ! compute d2Kxc_upup/dn_up2,d2Kxc_updn/dn_up2,d2Kxc_upup/dn_dn2,d2Kxc_updn/dn_dn2,d2Kxc_dndn/dn_dn2 4056 else if (nspden==2) then 4057 LIBPAW_ALLOCATE(d1kxc,(nrad,4)) 4058 LIBPAW_ALLOCATE(d2kxc,(nrad,5)) 4059 d1kxc(1:nrad,1)=(kxc1(1:nrad,1)-kxc2(1:nrad,1))*half*rhoinv(1:nrad,1) ! dKxc_upup/dn_up 4060 d1kxc(1:nrad,2)=(kxc1(1:nrad,2)-kxc2(1:nrad,2))*half*rhoinv(1:nrad,1) ! dKxc_updn/dn_up 4061 d1kxc(1:nrad,3)=(kxc1(1:nrad,3)-kxc2(1:nrad,3))*half*rhoinv(1:nrad,1) ! dKxc_dndn/dn_up 4062 d1kxc(1:nrad,4)=(kxcdn1(1:nrad,3)-kxcdn2(1:nrad,3))*half*rhoinv(1:nrad,2) ! dKxc_dndn/dn_dn 4063 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 4064 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 4065 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 4066 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 4067 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 4068 end if 4069 end if 4070 4071 LIBPAW_DEALLOCATE(rhoinv) 4072 LIBPAW_DEALLOCATE(vxc1) 4073 LIBPAW_DEALLOCATE(vxc2) 4074 LIBPAW_DEALLOCATE(kxc1) 4075 LIBPAW_DEALLOCATE(kxc2) 4076 if (nspden_updn==2) then 4077 LIBPAW_DEALLOCATE(vxcdn1) 4078 LIBPAW_DEALLOCATE(vxcdn2) 4079 LIBPAW_DEALLOCATE(kxcdn1) 4080 LIBPAW_DEALLOCATE(kxcdn2) 4081 end if 4082 4083 end if ! (option/=4 and option/=5) 4084 4085 LIBPAW_DEALLOCATE(rhosph) 4086 4087 !If non-collinear magnetism, store 1/2(Vxc_up+Vxc_dn) and 1/2(Vxc_up-Vxc_dn) 4088 if (nspden==4) then 4089 vxci(:,1)=half*(vxci(:,1)+vxci(:,2)) 4090 vxci(:,2)=vxci(:,1)-vxci(:,2) 4091 end if 4092 4093 !---------------------------------------------------------------------- 4094 !----- Compute useful sums of densities 4095 !---------------------------------------------------------------------- 4096 4097 if (option/=4.and.option/=5) then 4098 4099 ! Non-collinear magnetism: replace rho_dn by (m_0.dot.m)/|m_0| 4100 if (nspden==4) then 4101 LIBPAW_ALLOCATE(rho_dn,(nrad,lm_size)) 4102 rho_dn(:,1)=zero 4103 do ilm=2,lm_size 4104 rho_dn(1:nrad,ilm)=m_norm_inv(1:nrad) & 4105 & *(rho_updn(1:nrad,1,2)*rho_updn(1:nrad,ilm,2) & 4106 & +rho_updn(1:nrad,1,3)*rho_updn(1:nrad,ilm,3) & 4107 & +rho_updn(1:nrad,1,4)*rho_updn(1:nrad,ilm,4)) 4108 end do 4109 end if 4110 4111 ! Non-magnetic system: 4112 ! Compute 4113 ! V1SUM1(r)=Sum_L{n_L(r)^2} 4114 ! V2SUM1(r,L)=Sum_L1_L2{n_L1(r)*n_L2(r)*Gaunt_(L,L1,L2)} 4115 ! Collinear magnetism: 4116 ! Compute 4117 ! V1SUM1(r)=Sum_L{n^up_L(r)^2} 4118 ! V1SUM2(r)=Sum_L{n^up_L(r)*n^dn_L(r)} 4119 ! V1SUM3(r)=Sum_L{n^dn_L(r)^2} 4120 ! V2SUM1(r,L)=Sum_L1_L2{n^up_L1(r)*n^up_L2(r)*Gaunt_(L,L1,L2)} 4121 ! V2SUM2(r,L)=Sum_L1_L2{n^up_L1(r)*n^dn_L2(r)*Gaunt_(L,L1,L2)} 4122 ! V2SUM3(r,L)=Sum_L1_L2{n^dn_L1(r)*n^dn_L2(r)*Gaunt_(L,L1,L2)} 4123 ! Non-collinear magnetism: 4124 ! Compute 4125 ! V1SUM1(r)=Sum_L{n_L(r)^2} 4126 ! V1SUM2(r)=Sum_L{n_L(r) (m_0.m_L)}/|m_0| 4127 ! V1SUM3(r)=Sum_L{(m_0.m_L)^2}/|m_0|^2 4128 ! V2SUM1(r,L)=Sum_L1_L2{n_L1(r)*n_L2(r)*Gaunt_(L,L1,L2)} 4129 ! V2SUM2(r,L)=Sum_L1_L2{n_L1(r) (m_0.m_L2)*Gaunt_(L,L1,L2)}/|m_0| 4130 ! V2SUM3(r,L)=Sum_L1_L2{(m_0.m_L1)*(m_0.m_L2)*Gaunt_(L,L1,L2)}/|m_0|^2 4131 if (pawxcdev>=1) then 4132 LIBPAW_ALLOCATE(v1sum,(nrad,nsums)) 4133 else 4134 LIBPAW_ALLOCATE(v1sum,(0,0)) 4135 end if 4136 if (pawxcdev>=2) then 4137 LIBPAW_ALLOCATE(v2sum,(nrad,lm_size,nsums)) 4138 else 4139 LIBPAW_ALLOCATE(v2sum,(0,0,0)) 4140 end if 4141 call pawxcsum(1,1,1,lmselect,lmselect,lm_size,nrad,nsums,pawxcdev,pawang,& 4142 & rho_up,rho_dn,v1sum,v2sum) 4143 4144 end if !option 4145 4146 !---------------------------------------------------------------------- 4147 !----- Accumulate and store XC potential 4148 !---------------------------------------------------------------------- 4149 4150 if (option/=3.and.option/=4) then 4151 4152 ! === First order development 4153 ! --------------------------- 4154 if (pawxcdev>=1) then 4155 4156 ! Non-magnetic system 4157 if (nspden_updn==1) then 4158 vxc(1:nrad,1,1)=vxci(1:nrad,1)*sqfpi 4159 if (option/=5) then 4160 vxc(1:nrad,1,1)=vxc(1:nrad,1,1)+v1sum(1:nrad,1)*d2vxc(1:nrad,1)*invsqfpi2 4161 do ilm=2,lm_size 4162 if (lmselect(ilm)) then 4163 vxc(1:nrad,ilm,1)=d1vxc(1:nrad,1)*rho_up(1:nrad,ilm) 4164 end if 4165 end do 4166 end if 4167 4168 ! Magnetic system (including non-collinear magn.) 4169 else if (nspden_updn==2) then 4170 vxc(1:nrad,1,1)=vxci(1:nrad,1)*sqfpi 4171 vxc(1:nrad,1,2)=vxci(1:nrad,2)*sqfpi 4172 if (option/=5) then 4173 vxc(1:nrad,1,1)=vxc(1:nrad,1,1)+invsqfpi2*(v1sum(1:nrad,1)*d2vxc(1:nrad,1) & 4174 & +two*v1sum(1:nrad,2)*d2vxc(1:nrad,2)+v1sum(1:nrad,3)*d2vxc(1:nrad,3)) 4175 vxc(1:nrad,1,2)=vxc(1:nrad,1,2)+invsqfpi2*(v1sum(1:nrad,1)*d2vxc(1:nrad,2) & 4176 & +two*v1sum(1:nrad,2)*d2vxc(1:nrad,3)+v1sum(1:nrad,3)*d2vxc(1:nrad,4)) 4177 do ilm=2,lm_size 4178 if (lmselect(ilm)) then 4179 vxc(1:nrad,ilm,1)=vxc(1:nrad,ilm,1) & 4180 & +d1vxc(1:nrad,1)*rho_up(1:nrad,ilm)+d1vxc(1:nrad,2)*rho_dn(1:nrad,ilm) 4181 vxc(1:nrad,ilm,2)=vxc(1:nrad,ilm,2) & 4182 & +d1vxc(1:nrad,2)*rho_up(1:nrad,ilm)+d1vxc(1:nrad,3)*rho_dn(1:nrad,ilm) 4183 end if 4184 end do 4185 end if 4186 end if 4187 end if ! pawxcdev>=1 4188 4189 ! == 2nd order development 4190 ! --------------------------- 4191 if (pawxcdev>=2.and.option/=5) then 4192 4193 ! Non-magnetic system 4194 if (nspden_updn==1) then 4195 do ilm=2,lm_size 4196 vxc(1:nrad,ilm,1)=vxc(1:nrad,ilm,1)+half*d2vxc(1:nrad,1)*v2sum(1:nrad,ilm,1) 4197 end do 4198 4199 ! Magnetic system (including non-collinear magn.) 4200 else if (nspden_updn==2) then 4201 do ilm=2,lm_size 4202 vxc(1:nrad,ilm,1)=vxc(1:nrad,ilm,1)+d2vxc(1:nrad,2)*v2sum(1:nrad,ilm,2) & 4203 & +half*(d2vxc(1:nrad,1)*v2sum(1:nrad,ilm,1)+d2vxc(1:nrad,3)*v2sum(1:nrad,ilm,3)) 4204 vxc(1:nrad,ilm,2)=vxc(1:nrad,ilm,2)+d2vxc(1:nrad,3)*v2sum(1:nrad,ilm,2) & 4205 & +half*(d2vxc(1:nrad,2)*v2sum(1:nrad,ilm,1)+d2vxc(1:nrad,4)*v2sum(1:nrad,ilm,3)) 4206 end do 4207 end if 4208 end if !pawxcdev=2 4209 4210 ! === Pathological case: if rho(r) is negative, interpolate Vxc 4211 ! ------------------------------------------------------------- 4212 if (lmselect(1)) then 4213 tol_rho=xc_denpos*(one+tol6) 4214 do ispden=1,nspden_updn 4215 ir1=0;ir2=0 4216 do ir=1,nrad 4217 if (rho_updn(ir,1,ispden)<tol_rho) then 4218 if (ir1==0) ir1=ir-1 4219 ir2=ir+1 4220 else if (ir1>0) then 4221 if (ir1>1.or.ir2<nrad) then 4222 fact=(vxc(ir2,1,ispden)-vxc(ir1,1,ispden))/(pawrad%rad(ir2)-pawrad%rad(ir1)) 4223 do jr=ir1+1,ir2-1 4224 vxc(jr,1,ispden)=vxc(ir1,1,ispden)+fact*(pawrad%rad(jr)-pawrad%rad(ir1)) 4225 end do 4226 end if 4227 ir1=0;ir2=0 4228 end if 4229 end do 4230 end do 4231 end if 4232 4233 ! === Non-collinear magnetism: "rotate" back the XC potential 4234 ! ------- --------------------------------------------------- 4235 if (nspden==4) then 4236 LIBPAW_ALLOCATE(vxc_diag,(nrad,nspden_updn)) 4237 LIBPAW_ALLOCATE(vxc_nc,(nrad,nspden)) 4238 do ilm=1,lm_size 4239 vxc_diag(:,1)=vxc(:,ilm,1)+vxc(:,ilm,2) ! Get V from (V_up+V_dn)/2 4240 vxc_diag(:,2)=vxc(:,ilm,1)-vxc(:,ilm,2) ! and (V_up-V_dn)/2 4241 call pawxc_rotate_back_mag(vxc_diag,vxc_nc,mag_nc,nrad) 4242 do ispden=1,nspden 4243 vxc(1:nrad,ilm,ispden)=vxc_nc(1:nrad,ispden) 4244 end do 4245 end do 4246 LIBPAW_DEALLOCATE(vxc_diag) 4247 LIBPAW_DEALLOCATE(vxc_nc) 4248 end if 4249 end if !option/=3 and option/=4 4250 4251 !---------------------------------------------------------------------- 4252 !----- Accumulate and store XC kernel 4253 !---------------------------------------------------------------------- 4254 4255 if (nkxc>0) then 4256 4257 ! === First order development 4258 ! --------------------------- 4259 if (pawxcdev>=1) then 4260 ! Non-magnetic system: 4261 if (nspden_updn==1) then 4262 kxc(1:nrad,1,1)=kxci(1:nrad,1)*sqfpi 4263 if (option/=5.and.option/=4) then 4264 kxc(1:nrad,1,1)=kxc(1:nrad,1,1)+invsqfpi2*v1sum(1:nrad,1)*d2kxc(1:nrad,1) 4265 do ilm=2,lm_size 4266 if (lmselect(ilm)) then 4267 kxc(1:nrad,ilm,1)=d1kxc(1:nrad,1)*rho_up(1:nrad,ilm) 4268 end if 4269 end do 4270 end if 4271 ! Magnetic system: 4272 else if (nspden==2) then 4273 kxc(1:nrad,1,1)=kxci(1:nrad,1)*sqfpi 4274 kxc(1:nrad,1,2)=kxci(1:nrad,2)*sqfpi 4275 kxc(1:nrad,1,3)=kxci(1:nrad,3)*sqfpi 4276 if (option/=5.and.option/=4) then 4277 kxc(1:nrad,1,1)=kxc(1:nrad,1,1)+invsqfpi2*(v1sum(1:nrad,1)*d2kxc(1:nrad,1) & 4278 & +two*v1sum(1:nrad,2)*d2kxc(1:nrad,2)+v1sum(1:nrad,3)*d2kxc(1:nrad,3)) 4279 kxc(1:nrad,1,2)=kxc(1:nrad,1,2)+invsqfpi2*(v1sum(1:nrad,1)*d2kxc(1:nrad,2) & 4280 & +two*v1sum(1:nrad,2)*d2kxc(1:nrad,3)+v1sum(1:nrad,3)*d2kxc(1:nrad,4)) 4281 kxc(1:nrad,1,3)=kxc(1:nrad,1,3)+invsqfpi2*(v1sum(1:nrad,1)*d2kxc(1:nrad,3) & 4282 & +two*v1sum(1:nrad,2)*d2kxc(1:nrad,4)+v1sum(1:nrad,3)*d2kxc(1:nrad,5)) 4283 do ilm=2,lm_size 4284 if (lmselect(ilm)) then 4285 kxc(1:nrad,ilm,1)=kxc(1:nrad,ilm,1) & 4286 & +d1kxc(1:nrad,1)*rho_up(1:nrad,ilm)+d1kxc(1:nrad,2)*rho_dn(1:nrad,ilm) 4287 kxc(1:nrad,ilm,2)=kxc(1:nrad,ilm,2) & 4288 & +d1kxc(1:nrad,2)*rho_up(1:nrad,ilm)+d1kxc(1:nrad,3)*rho_dn(1:nrad,ilm) 4289 kxc(1:nrad,ilm,3)=kxc(1:nrad,ilm,3) & 4290 & +d1kxc(1:nrad,3)*rho_up(1:nrad,ilm)+d1kxc(1:nrad,4)*rho_dn(1:nrad,ilm) 4291 end if 4292 end do 4293 end if 4294 end if 4295 end if ! pawxcdev>=1 4296 4297 ! == 2nd order development 4298 ! --------------------------- 4299 if (pawxcdev>=2.and.option/=4.and.option/=5) then 4300 4301 ! Non-magnetic system: 4302 if (nspden_updn==1) then 4303 do ilm=2,lm_size 4304 kxc(1:nrad,ilm,1)=kxc(1:nrad,ilm,1)+half*d2kxc(1:nrad,1)*v2sum(1:nrad,ilm,1) 4305 end do 4306 ! Magnetic system: 4307 else if (nspden==2) then 4308 do ilm=2,lm_size 4309 kxc(1:nrad,ilm,1)=kxc(1:nrad,ilm,1)+d2kxc(1:nrad,2)*v2sum(1:nrad,ilm,2) & 4310 & +half*(d2kxc(1:nrad,1)*v2sum(1:nrad,ilm,1)+d2kxc(1:nrad,3)*v2sum(1:nrad,ilm,3)) 4311 kxc(1:nrad,ilm,2)=kxc(1:nrad,ilm,2)+d2kxc(1:nrad,3)*v2sum(1:nrad,ilm,2) & 4312 & +half*(d2kxc(1:nrad,2)*v2sum(1:nrad,ilm,1)+d2kxc(1:nrad,4)*v2sum(1:nrad,ilm,3)) 4313 kxc(1:nrad,ilm,3)=kxc(1:nrad,ilm,3)+d2kxc(1:nrad,4)*v2sum(1:nrad,ilm,2) & 4314 & +half*(d2kxc(1:nrad,3)*v2sum(1:nrad,ilm,1)+d2kxc(1:nrad,5)*v2sum(1:nrad,ilm,3)) 4315 end do 4316 end if 4317 end if !pawxcdev=2 4318 4319 ! === Pathological case: if rho(r) is negative, interpolate Kxc 4320 ! ------------------------------------------------------------- 4321 4322 ! NOT OK for spin polarized 4323 if (lmselect(1)) then 4324 tol_rho=xc_denpos*(one+tol6) 4325 do ispden=1,nspden_updn 4326 ir1=0;ir2=0 4327 do ir=1,nrad 4328 if (rho_updn(ir,1,ispden)<tol_rho) then 4329 if (ir1==0) ir1=ir-1 4330 ir2=ir+1 4331 else if (ir1>0) then 4332 if (ir1>1.or.ir2<nrad) then 4333 fact=(kxc(ir2,1,ispden)-kxc(ir1,1,ispden))/(pawrad%rad(ir2)-pawrad%rad(ir1)) 4334 do jr=ir1+1,ir2-1 4335 kxc(jr,1,ispden)=kxc(ir1,1,ispden)+fact*(pawrad%rad(jr)-pawrad%rad(ir1)) 4336 end do 4337 end if 4338 ir1=0;ir2=0 4339 end if 4340 end do 4341 end do 4342 end if 4343 4344 ! Non-collinear magnetism: need to store magnetization in kxc 4345 if (nkxc==6.or.nkxc==22) then 4346 do ilm=2,lm_size 4347 kxc(1:nrad,ilm,nkxc-2)=rho_updn(1:nrad,ilm,2) 4348 kxc(1:nrad,ilm,nkxc-1)=rho_updn(1:nrad,ilm,3) 4349 kxc(1:nrad,ilm,nkxc )=rho_updn(1:nrad,ilm,4) 4350 end do 4351 end if 4352 4353 end if ! nkxc>0 4354 4355 if (nspden==4) then 4356 LIBPAW_DEALLOCATE(rho_nc) 4357 LIBPAW_DEALLOCATE(m_norm_inv) 4358 end if 4359 4360 LIBPAW_DEALLOCATE(kxci) 4361 if (nkxc>0.and.option/=4.and.option/=5) then 4362 LIBPAW_DEALLOCATE(d1kxc) 4363 LIBPAW_DEALLOCATE(d2kxc) 4364 end if 4365 4366 !---------------------------------------------------------------------- 4367 !----- Accumulate and store XC energies 4368 !---------------------------------------------------------------------- 4369 4370 !----- Calculate Exc (direct scheme) term 4371 !---------------------------------------- 4372 if (option/=1.and.option/=5) then 4373 LIBPAW_ALLOCATE(ff,(nrad)) 4374 4375 ! Contribution from spherical part of rho 4376 if (nspden==1.or.nspden==4) then 4377 ff(1:nrad)=rho_updn(1:nrad,1,1)*exci(1:nrad)*sqfpi 4378 else if (nspden==2) then 4379 ff(1:nrad)=(rho_updn(1:nrad,1,1)+rho_updn(1:nrad,1,2))*exci(1:nrad)*sqfpi 4380 end if 4381 4382 ! Contribution from aspherical part of rho 4383 if (option/=4) then 4384 4385 ! First order development 4386 if (pawxcdev>=1) then 4387 if (nspden_updn==1) then 4388 ff(1:nrad)=ff(1:nrad)+half*v1sum(1:nrad,1)*d1vxc(1:nrad,1) 4389 else if (nspden_updn==2) then 4390 ff(1:nrad)=ff(1:nrad)+v1sum(1:nrad,2)*d1vxc(1:nrad,2) & 4391 & +half*(v1sum(1:nrad,1)*d1vxc(1:nrad,1)+v1sum(1:nrad,3)*d1vxc(1:nrad,3)) 4392 end if 4393 end if 4394 4395 ! Second order development 4396 if (pawxcdev>=2) then 4397 LIBPAW_ALLOCATE(gg,(nrad)) 4398 4399 gg=zero 4400 do ilm=2,lm_size 4401 if (lmselect(ilm)) then 4402 gg(1:nrad)=gg(1:nrad)+v2sum(1:nrad,ilm,1)*rho_up(1:nrad,ilm) 4403 end if 4404 end do 4405 ff(1:nrad)=ff(1:nrad)+gg(1:nrad)*d2vxc(1:nrad,1)/6._dp 4406 4407 if (nspden_updn==2) then ! Spin polarized (including non-coll. magn.) 4408 gg=zero 4409 do ilm=2,lm_size 4410 if (lmselect(ilm)) then 4411 gg(1:nrad)=gg(1:nrad)+v2sum(1:nrad,ilm,3)*rho_dn(1:nrad,ilm) 4412 end if 4413 end do 4414 ff(1:nrad)=ff(1:nrad)+gg(1:nrad)*d2vxc(1:nrad,4)/6._dp 4415 gg=zero 4416 do ilm=2,lm_size 4417 if (lmselect(ilm)) then 4418 gg(1:nrad)=gg(1:nrad)+v2sum(1:nrad,ilm,2)*rho_up(1:nrad,ilm) 4419 end if 4420 end do 4421 ff(1:nrad)=ff(1:nrad)+half*gg(1:nrad)*d2vxc(1:nrad,2) 4422 gg=zero 4423 do ilm=2,lm_size 4424 if (lmselect(ilm)) then 4425 gg(1:nrad)=gg(1:nrad)+v2sum(1:nrad,ilm,3)*rho_up(1:nrad,ilm) 4426 end if 4427 end do 4428 ff(1:nrad)=ff(1:nrad)+half*gg(1:nrad)*d2vxc(1:nrad,3) 4429 end if 4430 LIBPAW_DEALLOCATE(gg) 4431 end if 4432 4433 end if ! option/=4 4434 4435 ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2 4436 call simp_gen(enxc,ff,pawrad) 4437 LIBPAW_DEALLOCATE(ff) 4438 end if ! option/=1 and option/=5 4439 4440 LIBPAW_DEALLOCATE(exci) 4441 LIBPAW_DEALLOCATE(vxci) 4442 if (nspden==4.and.option/=4.and.option/=5) then 4443 LIBPAW_DEALLOCATE(rho_dn) 4444 end if 4445 if (allocated(v1sum)) then 4446 LIBPAW_DEALLOCATE(v1sum) 4447 end if 4448 if (allocated(v2sum)) then 4449 LIBPAW_DEALLOCATE(v2sum) 4450 end if 4451 if (allocated(d1vxc)) then 4452 LIBPAW_DEALLOCATE(d1vxc) 4453 end if 4454 if (allocated(d2vxc)) then 4455 LIBPAW_DEALLOCATE(d2vxc) 4456 end if 4457 4458 !----- Calculate Excdc double counting term 4459 !------------------------------------------ 4460 if (option==0.or.option==2) then 4461 4462 ! Build appropriate density 4463 if (usexcnhat==1) then 4464 if (nspden==1.or.nspden==4) then 4465 rho_updn(:,:,:)=rho_updn(:,:,:)+nhat(:,:,:) 4466 else if (nspden==2) then 4467 rho_updn(:,:,1)=rho_updn(:,:,1)+nhat(:,:,2) 4468 rho_updn(:,:,2)=rho_updn(:,:,2)+nhat(:,:,1)-nhat(:,:,2) 4469 end if 4470 end if 4471 if (usecore==1) then 4472 if (nspden==1.or.nspden==4) then 4473 rho_updn(:,1,1)=rho_updn(:,1,1)-sqfpi*corexc(:) 4474 else if (nspden==2) then 4475 rho_updn(:,1,1)=rho_updn(:,1,1)-sqfpi2*corexc(:) 4476 rho_updn(:,1,2)=rho_updn(:,1,2)-sqfpi2*corexc(:) 4477 end if 4478 end if 4479 4480 LIBPAW_ALLOCATE(ff,(nrad)) 4481 ff(1:nrad)=zero 4482 4483 ! Non magnetic or collinear magnetic system: 4484 if (nspden/=4) then 4485 do ispden=1,nspden_updn 4486 do ilm=1,lm_size 4487 if (lmselect(ilm)) ff(1:nrad)=ff(1:nrad)+vxc(1:nrad,ilm,ispden)*rho_updn(1:nrad,ilm,ispden) 4488 end do 4489 end do 4490 else 4491 ! Non-collinear magnetic system: 4492 do ilm=1,lm_size 4493 if (lmselect(ilm)) then 4494 do ir=1,nrad 4495 dvxca=vxc(ir,ilm,1)+vxc(ir,ilm,2);dvxcb=vxc(ir,ilm,1)-vxc(ir,ilm,2) 4496 ff(ir)=ff(ir)+half*(dvxca*rho_updn(ir,ilm,1)+dvxcb*rho_updn(ir,ilm,4)) & 4497 & +vxc(ir,ilm,3)*rho_updn(ir,ilm,2)-vxc(ir,ilm,4)*rho_updn(ir,ilm,3) 4498 end do 4499 end if 4500 end do 4501 end if 4502 4503 ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2 4504 call simp_gen(enxcdc,ff,pawrad) 4505 LIBPAW_DEALLOCATE(ff) 4506 4507 end if ! option 4508 4509 LIBPAW_DEALLOCATE(rho_updn) 4510 4511 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 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
PARENTS
pawdenpot,pawdfptenergy
CHILDREN
rotate_back_mag_dfpt
SOURCE
4569 subroutine pawxcm_dfpt(corexc1,cplex_den,cplex_vxc,d2enxc,ixc,kxc,lm_size,lmselect,nhat1,nkxc,nrad,nspden,& 4570 & option,pawang,pawrad,rhor1,usecore,usexcnhat,vxc1,xclevel,& 4571 & d2enxc_im) ! optional 4572 4573 4574 !This section has been created automatically by the script Abilint (TD). 4575 !Do not modify the following lines by hand. 4576 #undef ABI_FUNC 4577 #define ABI_FUNC 'pawxcm_dfpt' 4578 !End of the abilint section 4579 4580 implicit none 4581 4582 !Arguments ------------------------------------ 4583 !scalars 4584 integer,intent(in) :: cplex_den,cplex_vxc,ixc,lm_size,nkxc,nrad,nspden,option 4585 integer,intent(in) :: usecore,usexcnhat,xclevel 4586 real(dp),intent(out) :: d2enxc 4587 real(dp),intent(out),optional :: d2enxc_im 4588 type(pawang_type),intent(in) :: pawang 4589 type(pawrad_type),intent(in) :: pawrad 4590 !arrays 4591 logical,intent(in) :: lmselect(lm_size) 4592 real(dp),intent(in) :: corexc1(cplex_den*nrad) 4593 real(dp),intent(in) :: kxc(nrad,lm_size,nkxc) 4594 real(dp),intent(in) :: nhat1(cplex_den*nrad,lm_size,nspden*((usexcnhat+1)/2)) 4595 real(dp),intent(in) :: rhor1(cplex_den*nrad,lm_size,nspden) 4596 real(dp),intent(inout),target :: vxc1(cplex_vxc*nrad,lm_size,nspden) 4597 4598 !Local variables------------------------------- 4599 !scalars 4600 integer :: ii,ilm,iplex,ir,ivxc,jr,kr,nkxc_cur 4601 logical :: need_impart 4602 real(dp) :: invsqfpi,ro1i,ro1r,sqfpi,sqfpi2,v1i,v1r,vxcrho 4603 character(len=500) :: msg 4604 !arrays 4605 integer,parameter :: ikxc(4)=(/1,2,2,3/),irho(4)=(/1,2,1,2/) 4606 ! real(dp) :: tsec(2) 4607 real(dp),allocatable :: ff(:),gg(:),rho1_updn(:,:,:) 4608 real(dp),allocatable :: v1sum(:),v2sum(:,:) 4609 real(dp),pointer :: vxc1_(:,:,:) 4610 4611 !************************************************************************ 4612 4613 !NOTE (MT) 4614 !lmselect and lm_size are not necessarily the same for densities, kxc and vxc1 4615 !This is not taken into account for the moment, but has to be programmed... 4616 4617 !---------------------------------------------------------------------- 4618 !----- Check options 4619 !---------------------------------------------------------------------- 4620 4621 if(option<0.or.option>3) then 4622 msg='wrong option!' 4623 MSG_BUG(msg) 4624 end if 4625 if(option/=3) then 4626 call pawxc_get_nkxc(nkxc_cur,nspden,xclevel) 4627 if(nkxc/=nkxc_cur) then 4628 msg='Wrong size for kxc array!' 4629 MSG_BUG(msg) 4630 end if 4631 end if 4632 if(nspden==4.and.option/=3) then 4633 msg='nspden=4 not implemented (for vxc)!' 4634 MSG_ERROR(msg) 4635 end if 4636 if (option/=1) then 4637 if (nrad<pawrad%int_meshsz) then 4638 msg='When option=0,2,3, nrad must be greater than pawrad%int_meshsz!' 4639 MSG_BUG(msg) 4640 end if 4641 end if 4642 4643 !---------------------------------------------------------------------- 4644 !----- Initializations 4645 !---------------------------------------------------------------------- 4646 4647 !Arrays dimensions and constants 4648 need_impart=present(d2enxc_im) 4649 sqfpi=sqrt(four_pi);sqfpi2=half*sqfpi;invsqfpi=one/sqfpi 4650 4651 !Initializations of outputs 4652 if (option/=1) then 4653 d2enxc=zero 4654 if (need_impart) d2enxc_im=zero 4655 end if 4656 if (option<=1) vxc1(:,:,:)=zero 4657 4658 !Special case: no XC applied 4659 if (ixc==0.or.(nkxc==0.and.option/=3)) then 4660 msg='Note that no xc is applied (ixc=0). Returning' 4661 MSG_WARNING(msg) 4662 return 4663 end if 4664 4665 !---------------------------------------------------------------------- 4666 !----- Build several densities 4667 !---------------------------------------------------------------------- 4668 4669 !rho1_updn contains the effective 1st-order density used for XC 4670 !with 1st-order core density and/or 1st-order compensation density eventually included 4671 !----------------------------------------------------------------- 4672 LIBPAW_ALLOCATE(rho1_updn,(cplex_den*nrad,lm_size,nspden)) 4673 rho1_updn(:,:,:)=rhor1(:,:,:) 4674 if (usexcnhat==2) rho1_updn(:,:,:)=rho1_updn(:,:,:)+nhat1(:,:,:) 4675 if (usecore==1) then 4676 if (nspden==1.or.nspden==4) then 4677 rho1_updn(:,1,1)=rho1_updn(:,1,1)+sqfpi*corexc1(:) 4678 else if (nspden==2) then 4679 rho1_updn(:,1,1)=rho1_updn(:,1,1)+sqfpi*corexc1(:) 4680 rho1_updn(:,1,2)=rho1_updn(:,1,2)+sqfpi2*corexc1(:) 4681 end if 4682 end if 4683 4684 !In case of collinear magnetism, separate up and down contributions 4685 if (nspden==2) then 4686 LIBPAW_ALLOCATE(ff,(cplex_den*nrad)) 4687 do ilm=1,lm_size 4688 ff(:)=rho1_updn(:,ilm,2) 4689 rho1_updn(:,ilm,2)=rho1_updn(:,ilm,1)-ff(:) 4690 rho1_updn(:,ilm,1)=ff(:) 4691 end do 4692 LIBPAW_DEALLOCATE(ff) 4693 end if 4694 4695 ! 4696 !---------------------------------------------------------------------- 4697 !----- Accumulate and store 1st-order change of XC potential 4698 !---------------------------------------------------------------------- 4699 4700 if (option==2) then 4701 LIBPAW_POINTER_ALLOCATE(vxc1_,(cplex_vxc*nrad,lm_size,nspden)) 4702 else 4703 vxc1_ => vxc1 4704 end if 4705 4706 if (option/=3) then 4707 4708 vxc1_=zero 4709 LIBPAW_ALLOCATE(v1sum,(cplex_vxc*nrad)) 4710 LIBPAW_ALLOCATE(v2sum,(cplex_vxc*nrad,lm_size)) 4711 4712 do ii=1,3*nspden-2 4713 ivxc=1;if (ii>2) ivxc=2 4714 4715 ! === Vxc1 and Rho1 are REAL 4716 if (cplex_vxc==1.and.cplex_den==1) then ! cplex_vxc==1 and cplex_den==1 4717 call pawxcsum(1,1,1,lmselect,lmselect,lm_size,nrad,1,2,pawang,& 4718 & kxc(:,:,ikxc(ii)),rho1_updn(:,:,irho(ii)),v1sum,v2sum) 4719 vxc1_(:,1,ivxc)=vxc1_(:,1,ivxc)+invsqfpi*(v1sum(:)+kxc(:,1,ikxc(ii))*rho1_updn(:,1,irho(ii))) 4720 do ilm=2,lm_size 4721 vxc1_(:,ilm,ivxc)=vxc1_(:,ilm,ivxc)+v2sum(:,ilm) & 4722 & +invsqfpi*(kxc(:,ilm,ikxc(ii))*rho1_updn(:,1 ,irho(ii)) & 4723 & +kxc(:,1 ,ikxc(ii))*rho1_updn(:,ilm,irho(ii))) 4724 end do 4725 4726 ! === At least one of Vxc1 or Rho1 is COMPLEX 4727 else 4728 call pawxcsum(1,cplex_den,cplex_vxc,lmselect,lmselect,lm_size,nrad,1,2,pawang,& 4729 & kxc(:,:,ikxc(ii)),rho1_updn(:,:,irho(ii)),v1sum,v2sum) 4730 do ir=1,nrad 4731 jr=cplex_den*(ir-1);kr=cplex_vxc*(ir-1) 4732 do iplex=1,1+(cplex_den*cplex_vxc)/4 4733 jr=jr+1;kr=kr+1 4734 vxc1_(kr,1,ivxc)=vxc1_(kr,1,ivxc)+invsqfpi*(v1sum(kr)+kxc(ir,1,ikxc(ii))*rho1_updn(jr,1,irho(ii))) 4735 do ilm=2,lm_size 4736 vxc1_(kr,ilm,ivxc)=vxc1_(kr,ilm,ivxc)+v2sum(kr,ilm) & 4737 & +invsqfpi*(kxc(ir,ilm,ikxc(ii))*rho1_updn(jr,1 ,irho(ii)) & 4738 & +kxc(ir,1 ,ikxc(ii))*rho1_updn(jr,ilm,irho(ii))) 4739 end do 4740 end do 4741 end do 4742 4743 end if ! cplex_den and vxc_den 4744 end do ! ii=1,3*nspden-2 4745 4746 LIBPAW_DEALLOCATE(v1sum) 4747 LIBPAW_DEALLOCATE(v2sum) 4748 4749 end if 4750 4751 !---------------------------------------------------------------------- 4752 !----- Accumulate and store 2nd-order change of XC energy 4753 !---------------------------------------------------------------------- 4754 if (option/=1) then 4755 4756 ! For usexnhat=1 particular case, add now compensation density 4757 if (usexcnhat==1) then 4758 rho1_updn(:,:,1)=rho1_updn(:,:,1)+nhat1(:,:,nspden) 4759 if (nspden==2) rho1_updn(:,:,2)=rho1_updn(:,:,2)+nhat1(:,:,1)-nhat1(:,:,2) 4760 end if 4761 4762 LIBPAW_ALLOCATE(ff,(nrad)) 4763 ff=zero 4764 if (need_impart) then 4765 LIBPAW_ALLOCATE(gg,(nrad)) 4766 gg=zero 4767 end if 4768 4769 ! ----- Calculate d2Exc=Int[Vxc^(1)^*(r).n^(1)(r).dr] 4770 do ii=1,nspden 4771 ! === Vxc1 and Rho1 are REAL 4772 if (cplex_vxc==1.and.cplex_den==1) then 4773 do ilm=1,lm_size 4774 if (lmselect(ilm)) ff(:)=ff(:)+vxc1_(:,ilm,ii)*rho1_updn(:,ilm,ii) 4775 end do 4776 ! === Vxc1 and Rho1 are COMPLEX 4777 else if (cplex_vxc==2.and.cplex_den==2) then ! cplex_vxc==2 and cplex_den==2 4778 if (.not.need_impart) then ! Real part only 4779 do ilm=1,lm_size 4780 if (lmselect(ilm)) then 4781 do ir=1,nrad 4782 jr=2*ir;v1r=vxc1_(jr-1,ilm,ii);v1i=vxc1_(jr,ilm,ii) 4783 ro1r=rho1_updn(jr-1,ilm,ii);ro1i=rho1_updn(jr,ilm,ii) 4784 ff(ir)=ff(ir)+v1r*ro1r+v1i*ro1i 4785 end do 4786 end if 4787 end do 4788 else ! Real and imaginary parts 4789 do ilm=1,lm_size 4790 if (lmselect(ilm)) then 4791 do ir=1,nrad 4792 jr=2*ir;v1r=vxc1_(jr-1,ilm,ii);v1i=vxc1_(jr,ilm,ii) 4793 ro1r=rho1_updn(jr-1,ilm,ii);ro1i=rho1_updn(jr,ilm,ii) 4794 ff(ir)=ff(ir)+v1r*ro1r+v1i*ro1i 4795 gg(ir)=gg(ir)+v1r*ro1i-v1i*ro1r 4796 end do 4797 end if 4798 end do 4799 end if ! need_impart 4800 ! === Vxc1 and Rho1 are REAL and COMPLEX 4801 else 4802 v1i=zero;ro1i=zero 4803 do ilm=1,lm_size 4804 if (lmselect(ilm)) then 4805 do ir=1,nrad 4806 jr=cplex_vxc*(ir-1)+1;v1r=vxc1_(jr,ilm,ii);;if(cplex_vxc==2)v1i=vxc1_(jr+1,ilm,ii) 4807 jr=cplex_den*(ir-1)+1;ro1r=rho1_updn(jr,ilm,ii);if(cplex_den==2)ro1i=rho1_updn(jr+1,ilm,ii) 4808 ff(ir)=ff(ir)+v1r*ro1r+v1i*ro1i 4809 if (need_impart) gg(ir)=gg(ir)+v1r*ro1i-v1i*ro1r 4810 end do 4811 end if 4812 end do 4813 end if ! cplex_vxc and cplex_den 4814 end do ! ii=1,nspden 4815 4816 ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2 4817 call simp_gen(vxcrho,ff,pawrad) 4818 d2enxc=d2enxc+vxcrho 4819 LIBPAW_DEALLOCATE(ff) 4820 4821 if (need_impart) then 4822 gg(1:nrad)=gg(1:nrad)*pawrad%rad(1:nrad)**2 4823 call simp_gen(vxcrho,gg,pawrad) 4824 d2enxc_im=d2enxc_im+vxcrho 4825 LIBPAW_DEALLOCATE(gg) 4826 end if 4827 4828 end if 4829 4830 LIBPAW_DEALLOCATE(rho1_updn) 4831 if (option==2) then 4832 LIBPAW_POINTER_DEALLOCATE(vxc1_) 4833 end if 4834 4835 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
PARENTS
pawdenpot
CHILDREN
rotate_back_mag_dfpt
SOURCE
4906 subroutine pawxcmpositron(calctype,corexc,enxc,enxcdc,ixcpositron,lm_size,lmselect,lmselect_ep,& 4907 & nhat,nhat_ep,nrad,nspden,option,pawang,pawrad,pawxcdev,posdensity0_limit,& 4908 & rhor,rhor_ep,usecore,usexcnhat,vxc,xc_denpos) 4909 4910 4911 !This section has been created automatically by the script Abilint (TD). 4912 !Do not modify the following lines by hand. 4913 #undef ABI_FUNC 4914 #define ABI_FUNC 'pawxcmpositron' 4915 !End of the abilint section 4916 4917 implicit none 4918 4919 !Arguments ------------------------------------ 4920 !scalars 4921 integer,intent(in) :: calctype,ixcpositron,lm_size,nrad,nspden,option,pawxcdev,usecore 4922 integer,intent(in) :: usexcnhat 4923 logical,intent(in) :: posdensity0_limit 4924 real(dp),intent(in) :: xc_denpos 4925 real(dp),intent(out) :: enxc,enxcdc 4926 type(pawang_type),intent(in) :: pawang 4927 type(pawrad_type),intent(in) :: pawrad 4928 !arrays 4929 logical,intent(in) :: lmselect(lm_size),lmselect_ep(lm_size) 4930 real(dp),intent(in) :: corexc(nrad) 4931 real(dp),intent(in) :: nhat (nrad,lm_size,nspden*((usexcnhat+1)/2)) 4932 real(dp),intent(in) :: nhat_ep(nrad,lm_size,nspden*((usexcnhat+1)/2)) 4933 real(dp),intent(in) :: rhor (nrad,lm_size,nspden) 4934 real(dp),intent(in) :: rhor_ep(nrad,lm_size,nspden) 4935 real(dp),intent(out) :: vxc(nrad,lm_size,nspden) 4936 4937 !Local variables------------------------------- 4938 !scalars 4939 integer :: ilm,ir,ir1,ir2,iwarn,iwarnp,jr 4940 real(dp),parameter :: delta=1.d-4 4941 real(dp) :: fact,invsqfpi,sqfpi,rhomin 4942 character(len=500) :: msg 4943 !arrays 4944 real(dp),allocatable :: d1vxc(:,:),d2vxc(:,:),fxc_(:),ff(:),fxci(:),gg(:) 4945 real(dp),allocatable :: rho_(:),rhotot(:,:),rhotot_ep(:,:),rhoinv(:),rhoinv_ep(:) 4946 real(dp),allocatable :: rhosph(:),rhosph_ep(:),v1sum(:,:),v2sum(:,:,:) 4947 real(dp),allocatable :: vxce1(:),vxce1_ep(:),vxce2(:),vxce2_ep(:) 4948 real(dp),allocatable :: vxcp1(:),vxcp1_ep(:),vxcp2(:),vxcp2_ep(:) 4949 real(dp),allocatable :: vxcei(:),vxcpi(:) 4950 4951 !************************************************************************ 4952 4953 !----- Check options 4954 if(calctype/=1.and.calctype/=2) then 4955 msg='Invalid value for calctype' 4956 MSG_BUG(msg) 4957 end if 4958 if (option/=1) then 4959 if (nrad<pawrad%int_meshsz) then 4960 msg='When option=0,2,3,4, nrad must be greater than pawrad%int_meshsz!' 4961 MSG_BUG(msg) 4962 end if 4963 end if 4964 4965 !---------------------------------------------------------------------- 4966 !----- Initializations 4967 !---------------------------------------------------------------------- 4968 4969 !Initializations and constants 4970 iwarn=0;iwarnp=1 4971 sqfpi=sqrt(four_pi) 4972 invsqfpi=one/sqfpi 4973 4974 !Initializations of output arrays 4975 if (option/=1) enxc=zero 4976 if (option==0.or.option==2) enxcdc=zero 4977 if (option<3) vxc(:,:,:)=zero 4978 4979 if (ixcpositron==0) then ! No xc at all is applied (usually for testing) 4980 msg='Note that no xc is applied (ixc=0). Returning' 4981 MSG_WARNING(msg) 4982 return 4983 end if 4984 4985 !---------------------------------------------------------------------- 4986 !----- Build several densities 4987 !---------------------------------------------------------------------- 4988 4989 !rhotot/rhotot_ep contain the effective total densities used for XC 4990 !with core density and/or compensation density eventually included 4991 !----------------------------------------------------------------- 4992 !Input density 4993 LIBPAW_ALLOCATE(rhotot,(nrad,lm_size)) 4994 LIBPAW_ALLOCATE(rhotot_ep,(nrad,lm_size)) 4995 rhotot (:,:)=rhor (:,:,1) 4996 rhotot_ep(:,:)=rhor_ep(:,:,1) 4997 !Eventually add compensation density 4998 if (usexcnhat==2) then 4999 rhotot (:,:)=rhotot (:,:)+nhat (:,:,1) 5000 rhotot_ep(:,:)=rhotot_ep(:,:)+nhat_ep(:,:,1) 5001 end if 5002 !Eventually add core density 5003 if (usecore==1) then 5004 if (calctype==1) rhotot_ep(:,1)=rhotot_ep(:,1)+sqfpi*corexc(:) 5005 if (calctype==2) rhotot (:,1)=rhotot (:,1)+sqfpi*corexc(:) 5006 end if 5007 5008 !rhoSPH/rhoSPH_ep contain the spherical part of effective densities 5009 !(including Y00 spherical harmonic) 5010 !----------------------------------------------------------------- 5011 LIBPAW_ALLOCATE(rhosph,(nrad)) 5012 LIBPAW_ALLOCATE(rhosph_ep,(nrad)) 5013 5014 rhosph (:)=rhotot (:,1)*invsqfpi 5015 rhosph_ep(:)=rhotot_ep(:,1)*invsqfpi 5016 5017 !Make spherical densities positive 5018 if (calctype==1) then 5019 if (.not.posdensity0_limit) then 5020 call pawxc_mkdenpos_wrapper(iwarnp,nrad,1,1,rhosph,xc_denpos) 5021 end if 5022 call pawxc_mkdenpos_wrapper(iwarn ,nrad,1,1,rhosph_ep,xc_denpos) 5023 else if (calctype==2) then 5024 call pawxc_mkdenpos_wrapper(iwarn ,nrad,1,1,rhosph,xc_denpos) 5025 if (.not.posdensity0_limit) then 5026 call pawxc_mkdenpos_wrapper(iwarnp,nrad,1,1,rhosph_ep,xc_denpos) 5027 end if 5028 end if 5029 5030 !---------------------------------------------------------------------- 5031 !----- Compute Exc(rhoSPH,rhoSPH_ep) and Vxc(rhoSPH,rhoSPH_ep) 5032 !---------------------------------------------------------------------- 5033 5034 LIBPAW_ALLOCATE(fxci,(nrad)) 5035 LIBPAW_ALLOCATE(vxcei,(nrad)) 5036 LIBPAW_ALLOCATE(vxcpi,(nrad)) 5037 call pawxcsphpositron(calctype,fxci,ixcpositron,nrad,pawrad,posdensity0_limit,rhosph,rhosph_ep,vxcei,vxcpi) 5038 5039 !---------------------------------------------------------------------- 5040 !----- Compute numerical derivatives of Vxc (by finite diff. scheme) 5041 !---------------------------------------------------------------------- 5042 5043 if (option/=4) then 5044 5045 LIBPAW_ALLOCATE(fxc_,(nrad)) 5046 LIBPAW_ALLOCATE(rho_,(nrad)) 5047 5048 ! Compute Vxc for (rho+delta_rho,rho_ep) 5049 LIBPAW_ALLOCATE(vxce1,(nrad)) 5050 LIBPAW_ALLOCATE(vxcp1,(nrad)) 5051 rho_(:)=(one+delta)*rhosph(:) 5052 call pawxcsphpositron(calctype,fxc_,ixcpositron,nrad,pawrad,posdensity0_limit,rho_,rhosph_ep,vxce1,vxcp1) 5053 5054 ! Compute Vxc for(rho-delta_rho,rho_ep) 5055 LIBPAW_ALLOCATE(vxce2,(nrad)) 5056 LIBPAW_ALLOCATE(vxcp2,(nrad)) 5057 rho_(:)=(one-delta)*rhosph(:) 5058 call pawxcsphpositron(calctype,fxc_,ixcpositron,nrad,pawrad,posdensity0_limit,rho_,rhosph_ep,vxce2,vxcp2) 5059 5060 ! Compute Vxc for (rho,rho_ep+delta_rho_ep) 5061 LIBPAW_ALLOCATE(vxce1_ep,(nrad)) 5062 LIBPAW_ALLOCATE(vxcp1_ep,(nrad)) 5063 rho_(:)=(one+delta)*rhosph_ep(:) 5064 call pawxcsphpositron(calctype,fxc_,ixcpositron,nrad,pawrad,posdensity0_limit,rhosph,rho_,vxce1_ep,vxcp1_ep) 5065 5066 ! Compute Vxc for (rho,rho_ep-delta_rho_ep) 5067 LIBPAW_ALLOCATE(vxce2_ep,(nrad)) 5068 LIBPAW_ALLOCATE(vxcp2_ep,(nrad)) 5069 rho_(:)=(one-delta)*rhosph_ep(:) 5070 call pawxcsphpositron(calctype,fxc_,ixcpositron,nrad,pawrad,posdensity0_limit,rhosph,rho_,vxce2_ep,vxcp2_ep) 5071 5072 LIBPAW_DEALLOCATE(fxc_) 5073 LIBPAW_DEALLOCATE(rho_) 5074 5075 ! Store inverse of density finite step 5076 LIBPAW_ALLOCATE(rhoinv,(nrad)) 5077 LIBPAW_ALLOCATE(rhoinv_ep,(nrad)) 5078 fact=one/delta 5079 do ir=1,nrad 5080 if (rhosph(ir)>rho_min) then 5081 rhoinv(ir)=fact/rhosph(ir) 5082 else 5083 rhoinv(ir)=zero 5084 end if 5085 if (rhosph_ep(ir)>rho_min) then 5086 rhoinv_ep(ir)=fact/rhosph_ep(ir) 5087 else 5088 rhoinv_ep(ir)=zero 5089 end if 5090 end do 5091 5092 ! Compute numerical first derivatives of Vxc (by finite difference scheme) 5093 LIBPAW_ALLOCATE(d1vxc,(nrad,3)) 5094 if (calctype==1) then 5095 d1vxc(:,1)=(vxcp1 (:)-vxcp2 (:))*half*rhoinv (:) ! dVxc+/drho+ 5096 d1vxc(:,2)=(vxcp1_ep(:)-vxcp2_ep(:))*half*rhoinv_ep(:) ! dVxc+/drho- 5097 d1vxc(:,3)=(vxce1_ep(:)-vxce2_ep(:))*half*rhoinv_ep(:) ! dVxc-/drho- 5098 else if (calctype==2) then 5099 d1vxc(:,1)=(vxce1 (:)-vxce2 (:))*half*rhoinv (:) ! dVxc-/drho- 5100 d1vxc(:,2)=(vxcp1 (:)-vxcp2 (:))*half*rhoinv (:) ! dVxc+/drho- 5101 ! d1vxc(:,2)=(vxce1_ep(:)-vxce2_ep(:))*half*rhoinv_ep(:) ! dVxc-/drho+ 5102 d1vxc(:,3)=(vxcp1_ep(:)-vxcp2_ep(:))*half*rhoinv_ep(:) ! dVxc+/drho+ 5103 end if 5104 5105 ! Compute numerical second derivatives of Vxc (by finite difference scheme) 5106 if (option<3.or.pawxcdev>1) then 5107 LIBPAW_ALLOCATE(d2vxc,(nrad,4)) 5108 if (calctype==1) then 5109 d2vxc(:,1)=(vxcp1 (:)+vxcp2 (:)-two*vxcpi(:))*rhoinv (:)**2 ! d2Vxc+/drho+_drho+ 5110 d2vxc(:,2)=(vxce1 (:)+vxce2 (:)-two*vxcei(:))*rhoinv (:)**2 ! d2Vxc-/drho+_drho+ 5111 d2vxc(:,3)=(vxcp1_ep(:)+vxcp2_ep(:)-two*vxcpi(:))*rhoinv_ep(:)**2 ! d2Vxc+/drho-_drho- 5112 d2vxc(:,4)=(vxce1_ep(:)+vxce2_ep(:)-two*vxcei(:))*rhoinv_ep(:)**2 ! d2Vxc-/drho-_drho- 5113 else if (calctype==2) then 5114 d2vxc(:,1)=(vxce1 (:)+vxce2 (:)-two*vxcei(:))*rhoinv (:)**2 ! d2Vxc-/drho-_drho- 5115 d2vxc(:,2)=(vxcp1 (:)+vxcp2 (:)-two*vxcpi(:))*rhoinv (:)**2 ! d2Vxc+/drho-_drho- 5116 d2vxc(:,3)=(vxce1_ep(:)+vxce2_ep(:)-two*vxcei(:))*rhoinv_ep(:)**2 ! d2Vxc-/drho+_drho+ 5117 d2vxc(:,4)=(vxcp1_ep(:)+vxcp2_ep(:)-two*vxcpi(:))*rhoinv_ep(:)**2 ! d2Vxc+/drho+_drho+ 5118 end if 5119 end if ! option 5120 5121 LIBPAW_DEALLOCATE(rhoinv) 5122 LIBPAW_DEALLOCATE(rhoinv_ep) 5123 LIBPAW_DEALLOCATE(vxce1) 5124 LIBPAW_DEALLOCATE(vxcp1) 5125 LIBPAW_DEALLOCATE(vxce2) 5126 LIBPAW_DEALLOCATE(vxcp2) 5127 LIBPAW_DEALLOCATE(vxce1_ep) 5128 LIBPAW_DEALLOCATE(vxcp1_ep) 5129 LIBPAW_DEALLOCATE(vxce2_ep) 5130 LIBPAW_DEALLOCATE(vxcp2_ep) 5131 5132 end if ! option/=4 5133 5134 LIBPAW_DEALLOCATE(rhosph) 5135 LIBPAW_DEALLOCATE(rhosph_ep) 5136 5137 !---------------------------------------------------------------------- 5138 !----- Compute useful sums of densities 5139 !---------------------------------------------------------------------- 5140 5141 if (option<3.or.option/=1) then 5142 5143 ! Compute V1SUM1(r)=Sum_L{n^el_L(r)^2} 5144 ! V1SUM2(r)=Sum_L{n^el_L(r)*n^pos_L(r)} 5145 ! V1SUM3(r)=Sum_L{n^pos_L(r)^2} 5146 ! V2SUM1(r,L)=Sum_L1_L2{n^el_L1(r)*n^el_L2(r)*Gaunt_(L,L1,L2)} 5147 ! V2SUM2(r,L)=Sum_L1_L2{n^el_L1(r)*n^pos_L2(r)*Gaunt_(L,L1,L2)} 5148 ! V2SUM3(r,L)=Sum_L1_L2{n^pos_L1(r)*n^pos_L2(r)*Gaunt_(L,L1,L2)} 5149 if (pawxcdev>=1) then 5150 LIBPAW_ALLOCATE(v1sum,(nrad,3)) 5151 else 5152 LIBPAW_ALLOCATE(v1sum,(0,0)) 5153 end if 5154 if (pawxcdev>=2) then 5155 LIBPAW_ALLOCATE(v2sum,(nrad,lm_size,3)) 5156 else 5157 LIBPAW_ALLOCATE(v2sum,(0,0,0)) 5158 end if 5159 call pawxcsum(1,1,1,lmselect,lmselect_ep,lm_size,nrad,3,pawxcdev,pawang,rhotot,rhotot_ep,v1sum,v2sum) 5160 5161 end if !option 5162 5163 !---------------------------------------------------------------------- 5164 !----- Accumulate and store XC potential 5165 !---------------------------------------------------------------------- 5166 5167 if (option<3) then 5168 5169 ! if (option==0.or.option==2) allocate(vxc_ep(nrad,lm_size)) 5170 5171 ! === First order development 5172 ! --------------------------- 5173 if (pawxcdev>=1) then 5174 if (calctype==1) vxc(:,1,1)=vxcpi(:)*sqfpi 5175 if (calctype==2) vxc(:,1,1)=vxcei(:)*sqfpi 5176 vxc(:,1,1)=vxc(:,1,1)+invsqfpi*(d2vxc(:,2)*v1sum(:,2) & 5177 & +half*(d2vxc(:,1)*v1sum(:,1)+d2vxc(:,3)*v1sum(:,3))) 5178 do ilm=2,lm_size 5179 if (lmselect(ilm)) vxc(:,ilm,1)=vxc(:,ilm,1)+d1vxc(:,1)*rhotot (:,ilm) 5180 if (lmselect_ep(ilm)) vxc(:,ilm,1)=vxc(:,ilm,1)+d1vxc(:,2)*rhotot_ep(:,ilm) 5181 end do 5182 ! if (option==0.or.option==2) then 5183 ! if (calctype==1) vxc_ep(:,1)=vxcei(:)*sqfpi 5184 ! if (calctype==2) vxc_ep(:,1)=vxcpi(:)*sqfpi 5185 ! vxc_ep(:,1)=vxc_ep(:,1,1)+invsqfpi*(d2vxc(:,3)*v1sum(:,2) & 5186 ! & +half*(d2vxc(:,2)*v1sum(:,1)+d2vxc(:,4)*v1sum(:,3))) 5187 ! do ilm=2,lm_size 5188 ! if (lmselect(ilm)) vxc_ep(:,ilm)=vxc_ep(:,ilm)+d1vxc(:,2)*rhotot (:,ilm) 5189 ! if (lmselect_ep(ilm)) vxc_ep(:,ilm)=vxc_ep(:,ilm)+d1vxc(:,3)*rhotot_ep(:,ilm) 5190 ! end do 5191 ! end if 5192 end if ! pawxcdev>=1 5193 5194 ! == 2nd order development 5195 ! --------------------------- 5196 if (pawxcdev>=2) then 5197 do ilm=2,lm_size 5198 vxc(:,ilm,1)=vxc(:,ilm,1)+d2vxc(:,2)*v2sum(:,ilm,2) & 5199 & +half*(d2vxc(:,1)*v2sum(:,ilm,1)+d2vxc(:,3)*v2sum(:,ilm,3)) 5200 end do 5201 ! if (option==0.or.option==2) then 5202 ! do ilm=2,lm_size 5203 ! vxc_ep(:,ilm)=vxc_ep(:,ilm)+d2vxc(:,3)*v2sum(:,ilm,2) & 5204 ! & +half*(d2vxc(:,2)*v2sum(:,ilm,1)+d2vxc(:,4)*v2sum(:,ilm,3)) 5205 ! end do 5206 ! end if 5207 end if !pawxcdev=2 5208 5209 ! === Pathological case: if rho(r) is negative, interpolate Vxc 5210 ! ------------------------------------------------------------- 5211 if (lmselect(1)) then 5212 rhomin=xc_denpos*(one+tol6) 5213 ir1=0;ir2=0 5214 do ir=1,nrad 5215 if (rhotot(ir,1)<rhomin) then 5216 if (ir1==0) ir1=ir-1 5217 ir2=ir+1 5218 else if (ir1>0) then 5219 if (ir1>1.or.ir2<nrad) then 5220 fact=(vxc(ir2,1,1)-vxc(ir1,1,1))/(pawrad%rad(ir2)-pawrad%rad(ir1)) 5221 do jr=ir1+1,ir2-1 5222 vxc(jr,1,1)=vxc(ir1,1,1)+fact*(pawrad%rad(jr)-pawrad%rad(ir1)) 5223 end do 5224 end if 5225 ir1=0;ir2=0 5226 end if 5227 end do 5228 end if 5229 ! if (option==0.or.option==2) then 5230 ! if (lmselect_ep(1)) then 5231 ! ir1=0;ir2=0 5232 ! do ir=1,nrad 5233 ! if (rhotot_ep(ir,1)<rho_min) then 5234 ! if (ir1==0) ir1=ir-1 5235 ! ir2=ir+1 5236 ! else if (ir1>0) then 5237 ! if (ir1>1.or.ir2<nrad) then 5238 ! fact=(vxc_ep(ir2,1)-vxc_ep(ir1,1))/(pawrad%rad(ir2)-pawrad%rad(ir1)) 5239 ! do jr=ir1+1,ir2-1 5240 ! vxc_ep(jr,1)=vxc_ep(ir1,1)+fact*(pawrad%rad(jr)-pawrad%rad(ir1)) 5241 ! end do 5242 ! end if 5243 ! ir1=0;ir2=0 5244 ! end if 5245 ! end do 5246 ! end if 5247 ! end if 5248 5249 ! When vxc is dimensionned as polarized... 5250 if (nspden>=2) vxc(:,:,2)=vxc(:,:,1) 5251 if (nspden==4) vxc(:,:,3:4)=zero 5252 5253 end if !option<3 5254 5255 LIBPAW_DEALLOCATE(vxcei) 5256 LIBPAW_DEALLOCATE(vxcpi) 5257 5258 !---------------------------------------------------------------------- 5259 !----- Accumulate and store XC energies 5260 !---------------------------------------------------------------------- 5261 5262 !----- Calculate Exc (direct scheme) term 5263 !---------------------------------------- 5264 5265 if (option/=1) then 5266 LIBPAW_ALLOCATE(ff,(nrad)) 5267 5268 ! Contribution from spherical part of rho 5269 ff(:)=fxci(:)*four_pi 5270 5271 ! Contribution from aspherical part of rho 5272 if (option/=4) then 5273 5274 ! First order development 5275 if (pawxcdev>=1) then 5276 ff(:)=ff(:)+v1sum(:,2)*d1vxc(:,2) & 5277 & +half*(v1sum(:,1)*d1vxc(:,1)+v1sum(:,3)*d1vxc(:,3)) 5278 end if 5279 5280 ! Second order development 5281 if (pawxcdev>=2) then 5282 LIBPAW_ALLOCATE(gg,(nrad)) 5283 gg=zero 5284 do ilm=2,lm_size 5285 if (lmselect(ilm)) gg(:)=gg(:)+v2sum(:,ilm,1)*rhotot(:,ilm) 5286 end do 5287 ff(:)=ff(:)+gg(:)*d2vxc(:,1)/6._dp 5288 gg=zero 5289 do ilm=2,lm_size 5290 if (lmselect(ilm)) gg(:)=gg(:)+v2sum(:,ilm,2)*rhotot(:,ilm) 5291 end do 5292 ff(:)=ff(:) +half*gg(:)*d2vxc(:,2) 5293 gg=zero 5294 do ilm=2,lm_size 5295 if (lmselect(ilm)) gg(:)=gg(:)+v2sum(:,ilm,3)*rhotot(:,ilm) 5296 end do 5297 ff(:)=ff(:) +half*gg(:)*d2vxc(:,3) 5298 gg=zero 5299 do ilm=2,lm_size 5300 if (lmselect_ep(ilm)) gg(:)=gg(:)+v2sum(:,ilm,3)*rhotot_ep(:,ilm) 5301 end do 5302 ff(:)=ff(:)+gg(:)*d2vxc(:,4)/6._dp 5303 LIBPAW_DEALLOCATE(gg) 5304 end if ! pawxcdev>=2 5305 5306 end if ! option/=4 5307 5308 ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2 5309 call simp_gen(enxc,ff,pawrad) 5310 LIBPAW_DEALLOCATE(ff) 5311 end if ! option/=1 5312 5313 LIBPAW_DEALLOCATE(fxci) 5314 if (option<3.or.option/=1) then 5315 LIBPAW_DEALLOCATE(v1sum) 5316 LIBPAW_DEALLOCATE(v2sum) 5317 end if 5318 if (option<3.or.(option/=4.and.pawxcdev>1)) then 5319 LIBPAW_DEALLOCATE(d2vxc) 5320 end if 5321 if (option/=4) then 5322 LIBPAW_DEALLOCATE(d1vxc) 5323 end if 5324 5325 !----- Calculate Excdc double counting term 5326 !------------------------------------------ 5327 if (option==0.or.option==2) then 5328 5329 ! Build appropriate density 5330 if (usexcnhat==1) rhotot(:,:)=rhotot(:,:)+nhat(:,:,1) 5331 if (usecore==1.and.calctype==2) rhotot(:,1)=rhotot(:,1)-sqfpi*corexc(:) 5332 5333 ! Integrate with potential 5334 LIBPAW_ALLOCATE(ff,(nrad)) 5335 ff(:)=zero 5336 do ilm=1,lm_size 5337 if (lmselect(ilm)) ff(:)=ff(:)+vxc(:,ilm,1)*rhotot(:,ilm) 5338 end do 5339 ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2 5340 call simp_gen(enxcdc,ff,pawrad) 5341 LIBPAW_DEALLOCATE(ff) 5342 end if ! option 5343 5344 LIBPAW_DEALLOCATE(rhotot) 5345 LIBPAW_DEALLOCATE(rhotot_ep) 5346 5347 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
PARENTS
pawdenpot
CHILDREN
rotate_back_mag_dfpt
SOURCE
1479 subroutine pawxcpositron(calctype,corexc,enxc,enxcdc,ixcpositron,lm_size,lmselect,lmselect_ep,& 1480 & nhat,nhat_ep,nrad,nspden,option,pawang,pawrad,posdensity0_limit,& 1481 & rhor,rhor_ep,usecore,usexcnhat,vxc,xc_denpos) 1482 1483 1484 !This section has been created automatically by the script Abilint (TD). 1485 !Do not modify the following lines by hand. 1486 #undef ABI_FUNC 1487 #define ABI_FUNC 'pawxcpositron' 1488 !End of the abilint section 1489 1490 implicit none 1491 1492 !Arguments ------------------------------------ 1493 !scalars 1494 integer,intent(in) :: calctype,ixcpositron,lm_size,nrad,nspden,option,usecore,usexcnhat 1495 logical,intent(in) :: posdensity0_limit 1496 real(dp),intent(in) :: xc_denpos 1497 real(dp),intent(out) :: enxc,enxcdc 1498 type(pawang_type),intent(in) :: pawang 1499 type(pawrad_type),intent(in) :: pawrad 1500 !arrays 1501 logical,intent(in) :: lmselect(lm_size),lmselect_ep(lm_size) 1502 real(dp),intent(in) :: corexc(nrad) 1503 real(dp),intent(in) :: nhat(nrad,lm_size,nspden*((usexcnhat+1)/2)) 1504 real(dp),intent(in) :: nhat_ep(nrad,lm_size,nspden*((usexcnhat+1)/2)) 1505 real(dp),intent(in) :: rhor(nrad,lm_size,nspden) 1506 real(dp),intent(in) :: rhor_ep(nrad,lm_size,nspden) 1507 real(dp),intent(out) :: vxc(nrad,pawang%angl_size,nspden) 1508 1509 !Local variables------------------------------- 1510 !scalars 1511 integer :: ilm,ipts,iwarn,iwarnp,ngr,ngrad,npts,order 1512 real(dp) :: enxcr,vxcrho 1513 character(len=500) :: msg 1514 !arrays 1515 real(dp),allocatable :: ff(:),fxci(:),grho2(:),rhoarr(:),rhoarr_ep(:),rhoarrdc(:),vxci(:),vxci_ep(:),vxcigr(:) 1516 1517 ! ************************************************************************* 1518 1519 !----- Check options 1520 if(ixcpositron==3.or.ixcpositron==31) then 1521 msg='GGA is not implemented (use pawxcdev/=0)!' 1522 MSG_ERROR(msg) 1523 end if 1524 if(calctype/=1.and.calctype/=2) then 1525 msg='Invalid value for calctype!' 1526 MSG_BUG(msg) 1527 end if 1528 if(pawang%angl_size==0) then 1529 msg='pawang%angl_size=0!' 1530 MSG_BUG(msg) 1531 end if 1532 if(.not.allocated(pawang%ylmr)) then 1533 msg='pawang%ylmr must be allocated!' 1534 MSG_BUG(msg) 1535 end if 1536 if (option/=1) then 1537 if (nrad<pawrad%int_meshsz) then 1538 msg='When option=0,2,3,4, nrad must be greater than pawrad%int_meshsz!' 1539 MSG_BUG(msg) 1540 end if 1541 end if 1542 1543 !---------------------------------------------------------------------- 1544 !----- Initializations 1545 !---------------------------------------------------------------------- 1546 1547 !Initialization and constants 1548 iwarn=0;iwarnp=1 1549 npts=pawang%angl_size 1550 order=1;ngr=0;ngrad=1 ! only LDA here ! 1551 1552 !Initializations of output arrays 1553 if (option/=1) enxc=zero 1554 if (option==0.or.option==2) enxcdc=zero 1555 if (option<3) vxc(:,:,:)=zero 1556 1557 if (ixcpositron==0) then ! No xc at all is applied (usually for testing) 1558 msg = 'Note that no xc is applied (ixcpositron=0). Returning' 1559 MSG_WARNING(msg) 1560 return 1561 end if 1562 1563 !Allocations 1564 LIBPAW_ALLOCATE(fxci,(nrad)) 1565 LIBPAW_ALLOCATE(vxci,(nrad)) 1566 LIBPAW_ALLOCATE(rhoarr,(nrad)) 1567 LIBPAW_ALLOCATE(rhoarr_ep,(nrad)) 1568 if (option==0.or.option==2) then 1569 LIBPAW_ALLOCATE(rhoarrdc,(nrad)) 1570 end if 1571 1572 !---------------------------------------------------------------------- 1573 !----- Loop on the angular part 1574 do ipts=1,npts 1575 1576 ! ---------------------------------------------------------------------- 1577 ! ----- Build several densities 1578 ! ---------------------------------------------------------------------- 1579 1580 ! Eventually add compensation density to input density 1581 rhoarr=zero;rhoarr_ep=zero 1582 if (usexcnhat==2) then 1583 do ilm=1,lm_size 1584 if (lmselect(ilm)) & 1585 & rhoarr(:)=rhoarr(:)+(rhor(:,ilm,1)+nhat(:,ilm,1))*pawang%ylmr(ilm,ipts) 1586 end do 1587 do ilm=1,lm_size 1588 if (lmselect_ep(ilm)) & 1589 & rhoarr_ep(:)=rhoarr_ep(:)+(rhor_ep(:,ilm,1)+nhat_ep(:,ilm,1))*pawang%ylmr(ilm,ipts) 1590 end do 1591 else 1592 do ilm=1,lm_size 1593 if (lmselect(ilm)) rhoarr(:)=rhoarr(:)+rhor(:,ilm,1)*pawang%ylmr(ilm,ipts) 1594 end do 1595 do ilm=1,lm_size 1596 if (lmselect_ep(ilm)) rhoarr_ep(:)=rhoarr_ep(:)+rhor_ep(:,ilm,1)*pawang%ylmr(ilm,ipts) 1597 end do 1598 end if 1599 1600 ! Store density for use in double-counting term 1601 if (option==0.or.option==2) rhoarrdc(:)=rhoarr(:) 1602 1603 ! Eventually add core density 1604 if (usecore==1) then 1605 if (calctype==1) rhoarr_ep(:)=rhoarr_ep(:)+corexc(:) 1606 if (calctype==2) rhoarr (:)=rhoarr (:)+corexc(:) 1607 end if 1608 1609 ! Make the densities positive 1610 if (calctype==1) then 1611 if (.not.posdensity0_limit) then 1612 call pawxc_mkdenpos_wrapper(iwarnp,nrad,1,1,rhoarr,xc_denpos) 1613 end if 1614 call pawxc_mkdenpos_wrapper(iwarn ,nrad,1,1,rhoarr_ep,xc_denpos) 1615 else if (calctype==2) then 1616 call pawxc_mkdenpos_wrapper(iwarn ,nrad,1,1,rhoarr,xc_denpos) 1617 if (.not.posdensity0_limit) then 1618 call pawxc_mkdenpos_wrapper(iwarnp,nrad,1,1,rhoarr_ep,xc_denpos) 1619 end if 1620 end if 1621 1622 ! ---------------------------------------------------------------------- 1623 ! ----- Compute XC data 1624 ! ---------------------------------------------------------------------- 1625 1626 ! electron-positron correlation for the positron 1627 LIBPAW_ALLOCATE(vxci_ep,(nrad)) 1628 LIBPAW_ALLOCATE(vxcigr,(ngr)) 1629 LIBPAW_ALLOCATE(grho2,(ngr)) 1630 if (calctype==1) then 1631 call pawxc_xcpositron_wrapper(fxci,grho2,ixcpositron,ngr,nrad,posdensity0_limit,rhoarr_ep,rhoarr,vxci_ep,vxcigr,vxci) 1632 else if (calctype==2) then 1633 call pawxc_xcpositron_wrapper(fxci,grho2,ixcpositron,ngr,nrad,posdensity0_limit,rhoarr,rhoarr_ep,vxci,vxcigr,vxci_ep) 1634 end if 1635 LIBPAW_DEALLOCATE(vxci_ep) 1636 LIBPAW_DEALLOCATE(vxcigr) 1637 LIBPAW_DEALLOCATE(grho2) 1638 1639 ! ---------------------------------------------------------------------- 1640 ! ----- Accumulate and store XC potential 1641 ! ---------------------------------------------------------------------- 1642 if (option<3) then 1643 vxc(:,ipts,1)=vxci(:) 1644 if (nspden>=2) vxc(:,ipts,2)=vxci(:) 1645 if (nspden==4) vxc(:,ipts,3:4)=zero 1646 end if 1647 1648 ! ---------------------------------------------------------------------- 1649 ! ----- Accumulate and store XC energies 1650 ! ---------------------------------------------------------------------- 1651 1652 ! ----- Calculate Exc term 1653 if (option/=1) then 1654 LIBPAW_ALLOCATE(ff,(nrad)) 1655 ff(1:nrad)=fxci(1:nrad)*pawrad%rad(1:nrad)**2 1656 call simp_gen(enxcr,ff,pawrad) 1657 LIBPAW_DEALLOCATE(ff) 1658 if (option/=4) enxc=enxc+enxcr*pawang%angwgth(ipts) 1659 if (option==4) enxc=enxc+enxcr 1660 end if 1661 1662 ! ----- Calculate Excdc double counting term 1663 if (option==0.or.option==2) then 1664 if (usexcnhat==1) then 1665 do ilm=1,lm_size 1666 if (lmselect(ilm)) then 1667 rhoarrdc(:)=rhoarrdc(:)+nhat(:,ilm,1)*pawang%ylmr(ilm,ipts) 1668 end if 1669 end do 1670 end if 1671 LIBPAW_ALLOCATE(ff,(nrad)) 1672 ff(1:nrad)=vxci(1:nrad)*rhoarrdc(1:nrad)*pawrad%rad(1:nrad)**2 1673 call simp_gen(vxcrho,ff,pawrad) 1674 LIBPAW_DEALLOCATE(ff) 1675 enxcdc=enxcdc+vxcrho*pawang%angwgth(ipts) 1676 end if 1677 1678 ! --------------------------------------------------- 1679 ! ----- End of the loop on npts (angular part) 1680 end do 1681 1682 !Add the four*pi factor of the angular integration 1683 if (option/=1) enxc=enxc*four_pi 1684 if (option==0.or.option==2) enxcdc=enxcdc*four_pi 1685 1686 !Deallocations 1687 LIBPAW_DEALLOCATE(fxci) 1688 LIBPAW_DEALLOCATE(vxci) 1689 LIBPAW_DEALLOCATE(rhoarr) 1690 LIBPAW_DEALLOCATE(rhoarr_ep) 1691 if (option==0.or.option==2) then 1692 LIBPAW_DEALLOCATE(rhoarrdc) 1693 end if 1694 1695 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
PARENTS
m_pawxc
CHILDREN
rotate_back_mag_dfpt
SOURCE
2644 subroutine pawxcsph(exc,exexch,ixc,kxc,nkxc,nrad,nspden,pawrad,rho_updn,vxc,xclevel) 2645 2646 2647 !This section has been created automatically by the script Abilint (TD). 2648 !Do not modify the following lines by hand. 2649 #undef ABI_FUNC 2650 #define ABI_FUNC 'pawxcsph' 2651 !End of the abilint section 2652 2653 implicit none 2654 2655 !Arguments ------------------------------------ 2656 !scalars 2657 integer,intent(in) :: exexch,ixc,nkxc,nrad,nspden,xclevel 2658 type(pawrad_type),intent(in) :: pawrad 2659 !arrays 2660 real(dp),intent(in) :: rho_updn(nrad,nspden) 2661 real(dp),intent(out) :: exc(nrad),kxc(nrad,nkxc),vxc(nrad,nspden) 2662 2663 !Local variables------------------------------- 2664 !scalars 2665 integer :: ir,ispden,mgga,ndvxc,nd2vxc,ngr2,nspgrad,nvxcdgr,order 2666 real(dp),parameter :: tol24=tol12*tol12 2667 real(dp) :: coeff,grho_tot,grho_up,fact 2668 character(len=500) :: msg 2669 !arrays 2670 real(dp),allocatable :: dff(:),dnexcdn(:,:),dvxcdgr(:,:),dvxci(:,:) 2671 real(dp),allocatable :: grho2(:,:),grho_updn(:,:) 2672 2673 ! ************************************************************************* 2674 2675 if(nspden>2)then 2676 write(msg, '(a,a,a,i0)' )& 2677 & 'Only non-spin-polarised or collinear spin-densities are allowed,',ch10,& 2678 & 'while the argument nspden=',nspden 2679 MSG_BUG(msg) 2680 end if 2681 if(nkxc>3)then 2682 msg='nkxc>3 not allowed (GGA)!' 2683 MSG_ERROR(msg) 2684 end if 2685 if(nrad>pawrad%mesh_size)then 2686 msg='nrad > mesh size!' 2687 MSG_BUG(msg) 2688 end if 2689 2690 !Compute sizes of arrays and flags 2691 order=1;if (nkxc>0) order=2 2692 nspgrad=0;if (xclevel==2) nspgrad=3*nspden-1 2693 call pawxc_size_dvxc_wrapper(ixc,ndvxc,ngr2,nd2vxc,nspden,nvxcdgr,order) 2694 mgga=0 !metaGGA contributions are not taken into account here 2695 2696 2697 !-------------------------------------------------------------------------- 2698 !-------------- GGA: computation of the gradient of the density 2699 !-------------------------------------------------------------------------- 2700 2701 LIBPAW_ALLOCATE(grho2,(nrad,ngr2)) 2702 if (xclevel==2) then 2703 2704 ! grho_updn contains the gradient of the radial part 2705 ! grho2(:,1:3) contains the squared norm of this gradient (up, dn and total) 2706 LIBPAW_ALLOCATE(grho_updn,(nrad,nspden)) 2707 2708 ! Gradient of radial part of density 2709 LIBPAW_ALLOCATE(dff,(nrad)) 2710 do ispden=1,nspden 2711 call nderiv_gen(dff,rho_updn(:,ispden),pawrad) 2712 grho_updn(:,ispden)=dff(:) 2713 end do 2714 LIBPAW_DEALLOCATE(dff) 2715 2716 ! Squared norm of the gradient 2717 grho2(:,1)=grho_updn(:,1)**2 2718 if (nspden==2) then 2719 grho2(:,2)=grho_updn(:,2)**2 2720 grho2(:,3)=(grho_updn(:,1)+grho_updn(:,2))**2 2721 end if 2722 2723 end if 2724 2725 !-------------------------------------------------------------------------- 2726 !-------------- Computation of Exc, Vxc (and Kxc) 2727 !-------------------------------------------------------------------------- 2728 2729 !Allocate arrays 2730 LIBPAW_ALLOCATE(dvxci,(nrad,ndvxc)) 2731 LIBPAW_ALLOCATE(dvxcdgr,(nrad,nvxcdgr)) 2732 2733 !Call to main XC driver 2734 call pawxc_drivexc_wrapper(exc,ixc,mgga,ndvxc,nd2vxc,ngr2,nrad,nspden,nvxcdgr,order,rho_updn,vxc,xclevel, & 2735 & dvxc=dvxci,exexch=exexch,grho2=grho2,vxcgrho=dvxcdgr) 2736 2737 !Transfer the XC kernel 2738 if (nkxc>0.and.ndvxc>0) then 2739 if (nkxc==1.and.ndvxc==15) then 2740 kxc(1:nrad,1)=half*(dvxci(1:nrad,1)+dvxci(1:nrad,9)+dvxci(1:nrad,10)) 2741 else if (nkxc==3.and.ndvxc==15) then 2742 kxc(1:nrad,1)=dvxci(1:nrad,1)+dvxci(1:nrad,9) 2743 kxc(1:nrad,2)=dvxci(1:nrad,10) 2744 kxc(1:nrad,3)=dvxci(1:nrad,2)+dvxci(1:nrad,11) 2745 else if (nkxc==7.and.ndvxc==8) then 2746 kxc(1:nrad,1)=half*dvxci(1:nrad,1) 2747 kxc(1:nrad,2)=half*dvxci(1:nrad,3) 2748 kxc(1:nrad,3)=quarter*dvxci(1:nrad,5) 2749 kxc(1:nrad,4)=eighth*dvxci(1:nrad,7) 2750 else if (nkxc==7.and.ndvxc==15) then 2751 kxc(1:nrad,1)=half*(dvxci(1:nrad,1)+dvxci(1:nrad,9)+dvxci(1:nrad,10)) 2752 kxc(1:nrad,2)=half*dvxci(1:nrad,3)+dvxci(1:nrad,12) 2753 kxc(1:nrad,3)=quarter*dvxci(1:nrad,5)+dvxci(1:nrad,13) 2754 kxc(1:nrad,4)=eighth*dvxci(1:nrad,7)+dvxci(1:nrad,15) 2755 else if (nkxc==19.and.ndvxc==15) then 2756 kxc(1:nrad,1)=dvxci(1:nrad,1)+dvxci(1:nrad,9) 2757 kxc(1:nrad,2)=dvxci(1:nrad,10) 2758 kxc(1:nrad,3)=dvxci(1:nrad,2)+dvxci(1:nrad,11) 2759 kxc(1:nrad,4)=dvxci(1:nrad,3) 2760 kxc(1:nrad,5)=dvxci(1:nrad,4) 2761 kxc(1:nrad,6)=dvxci(1:nrad,5) 2762 kxc(1:nrad,7)=dvxci(1:nrad,6) 2763 kxc(1:nrad,8)=dvxci(1:nrad,7) 2764 kxc(1:nrad,9)=dvxci(1:nrad,8) 2765 kxc(1:nrad,10)=dvxci(1:nrad,12) 2766 kxc(1:nrad,11)=dvxci(1:nrad,13) 2767 kxc(1:nrad,12)=dvxci(1:nrad,14) 2768 kxc(1:nrad,13)=dvxci(1:nrad,15) 2769 else ! Other cases 2770 kxc(1:nrad,1:nkxc)=zero 2771 kxc(1:nrad,1:min(nkxc,ndvxc))=dvxci(1:nrad,1:min(nkxc,ndvxc)) 2772 end if 2773 if (nkxc==7) then 2774 kxc(1:nrad,5)=grho_updn(1:nrad,1) ! Not correct 2775 kxc(1:nrad,6)=grho_updn(1:nrad,1) ! Not correct 2776 kxc(1:nrad,7)=grho_updn(1:nrad,1) ! Not correct 2777 else if (nkxc==19) then 2778 kxc(1:nrad,14)=grho_updn(1:nrad,1) ! Not correct 2779 kxc(1:nrad,15)=grho_updn(1:nrad,2) ! Not correct 2780 kxc(1:nrad,16)=grho_updn(1:nrad,1) ! Not correct 2781 kxc(1:nrad,17)=grho_updn(1:nrad,2) ! Not correct 2782 kxc(1:nrad,18)=grho_updn(1:nrad,1) ! Not correct 2783 kxc(1:nrad,19)=grho_updn(1:nrad,2) ! Not correct 2784 end if 2785 end if 2786 LIBPAW_DEALLOCATE(dvxci) 2787 2788 !-------------------------------------------------------------------------- 2789 !-------------- GGA: gardient corrections 2790 !-------------------------------------------------------------------------- 2791 2792 if (xclevel==2.and.ixc/=13) then 2793 2794 ! Compute the derivative of Exc with respect to the (spin-)density, 2795 ! or to the norm of the gradient of the (spin-)density, 2796 ! Further divided by the norm of the gradient of the (spin-)density 2797 ! The different components of dnexcdn will be 2798 ! for nspden=1, dnexcdn(:,1)=d(n.exc)/d(n) 2799 ! and if xclevel=2, dnexcdn(:,2)=1/2*1/|grad n_up|*d(n.exc)/d(|grad n_up|) 2800 ! + 1/|grad n|*d(n.exc)/d(|grad n|) 2801 ! (do not forget : |grad n| /= |grad n_up| + |grad n_down| 2802 ! for nspden=2, dnexcdn(:,1)=d(n.exc)/d(n_up) 2803 ! dnexcdn(:,2)=d(n.exc)/d(n_down) 2804 ! and if xclevel=2, dnexcdn(:,3)=1/|grad n_up|*d(n.exc)/d(|grad n_up|) 2805 ! dnexcdn(:,4)=1/|grad n_down|*d(n.exc)/d(|grad n_down|) 2806 ! dnexcdn(:,5)=1/|grad n|*d(n.exc)/d(|grad n|) 2807 LIBPAW_ALLOCATE(dnexcdn,(nrad,nspgrad)) 2808 ! LDA term 2809 dnexcdn(:,1:nspden)=vxc(:,1:nspden) 2810 ! Additional GGA terms 2811 do ir=1,nrad 2812 do ispden=1,3 ! spin_up, spin_down and total spin density 2813 if (nspden==1.and.ispden>=2) exit 2814 ! If the norm of the gradient vanishes, then the different terms 2815 ! vanishes, but the inverse of the gradient diverges, 2816 ! so skip the update. 2817 if(grho2(ir,ispden)<tol24) then 2818 dnexcdn(ir,ispden+nspden)=zero;cycle 2819 end if 2820 ! Compute the derivative of n.e_xc wrt the spin up, spin down, 2821 ! or total density. In the non-spin-polarized case take the coeff. 2822 ! that will be multiplied by the gradient of the total density. 2823 if (nvxcdgr/=0) then 2824 if (nspden==1) then 2825 ! Definition of dvxcdgr changed in v3.3 2826 if (nvxcdgr==3) then 2827 coeff=half*dvxcdgr(ir,1)+dvxcdgr(ir,3) 2828 else 2829 coeff=half*dvxcdgr(ir,1) 2830 end if 2831 else if (nspden==2)then 2832 if (nvxcdgr==3) then 2833 coeff=dvxcdgr(ir,ispden) 2834 else if (ispden/=3) then 2835 coeff=dvxcdgr(ir,ispden) 2836 else if (ispden==3) then 2837 coeff=zero 2838 end if 2839 end if 2840 end if 2841 dnexcdn(ir,ispden+nspden)=coeff 2842 end do 2843 end do 2844 2845 ! Calculate grad(rho)*dnexcdn and put it in grho_updn(:,:) 2846 if (nvxcdgr/=0) then 2847 if(nspden==1)then 2848 grho_updn(:,1)=grho_updn(:,1)*dnexcdn(:,2) 2849 else 2850 do ir=1,nrad 2851 grho_up=grho_updn(ir,1);grho_tot=grho_up+grho_updn(ir,2) 2852 grho_updn(ir,1)=grho_up*dnexcdn(ir,3)+grho_tot*dnexcdn(ir,5) 2853 grho_updn(ir,2)=(grho_tot-grho_up)*dnexcdn(ir,4)+grho_tot*dnexcdn(ir,5) 2854 end do 2855 end if 2856 end if 2857 LIBPAW_DEALLOCATE(dnexcdn) 2858 2859 ! Compute Vxc 2860 LIBPAW_ALLOCATE(dff,(nrad)) 2861 fact=one;if (nspden==1) fact=two 2862 do ispden=1,nspden 2863 call nderiv_gen(dff,grho_updn(:,ispden),pawrad) 2864 vxc(2:nrad,ispden)=vxc(2:nrad,ispden)-fact*(dff(2:nrad)+two*grho_updn(2:nrad,ispden)/pawrad%rad(2:nrad)) 2865 call pawrad_deducer0(vxc(:,ispden),nrad,pawrad) 2866 end do 2867 LIBPAW_DEALLOCATE(dff) 2868 2869 end if ! xclevel==2 2870 2871 !-------------------------------------------------------------------------- 2872 !-------------- Deallocations 2873 !-------------------------------------------------------------------------- 2874 2875 LIBPAW_DEALLOCATE(grho2) 2876 LIBPAW_DEALLOCATE(dvxcdgr) 2877 if (xclevel==2) then 2878 LIBPAW_DEALLOCATE(grho_updn) 2879 end if 2880 2881 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
PARENTS
CHILDREN
rotate_back_mag_dfpt
SOURCE
2921 subroutine pawxcsph_dfpt(cplex_den,cplex_vxc,ixc,nrad,nspden,pawrad,rho_updn,rho1_updn,vxc1,xclevel) 2922 2923 2924 !This section has been created automatically by the script Abilint (TD). 2925 !Do not modify the following lines by hand. 2926 #undef ABI_FUNC 2927 #define ABI_FUNC 'pawxcsph_dfpt' 2928 !End of the abilint section 2929 2930 implicit none 2931 2932 !Arguments ------------------------------------ 2933 !scalars 2934 integer,intent(in) :: cplex_den,cplex_vxc,ixc,nrad,nspden,xclevel 2935 type(pawrad_type),intent(in) :: pawrad 2936 !arrays 2937 real(dp),intent(in) :: rho_updn(nrad,nspden),rho1_updn(cplex_den*nrad,nspden) 2938 real(dp),intent(out) :: vxc1(cplex_vxc*nrad,nspden) 2939 2940 !Local variables------------------------------- 2941 !scalars 2942 integer :: ii,ir,ispden,ivxc,jr,kr,mgga,ndvxc,nd2vxc,ngr2,ngrad,nkxc,nvxcdgr,order 2943 real(dp),parameter :: tol24=tol12*tol12 2944 !real(dp) :: coeff_grho_corr,coeff_grho_dn,coeff_grho_up,fact 2945 !real(dp) :: grho_grho1,grho_grho1_dn,grho_grho1_up 2946 character(len=500) :: msg 2947 !arrays 2948 integer,parameter :: ikxc(4)=(/1,2,2,3/),irho(4)=(/1,2,1,2/) 2949 real(dp),allocatable :: dff(:),dgg(:),dvxcdgr(:,:),dvxc(:,:),exc(:),ff(:),gg(:) 2950 real(dp),allocatable :: grho_updn(:,:),grho1_updn(:,:),grho2(:,:) 2951 real(dp),allocatable :: kxc(:,:),vxc(:,:) 2952 !real(dp),allocatable :: gxc1i(:,:),gxc1r(:,:),vxc1i(:,:),vxc1r(:,:) 2953 2954 ! ************************************************************************* 2955 2956 if(nspden>2)then 2957 write(msg, '(a,a,a,i0)' )& 2958 & 'Only non-spin-polarised or collinear spin-densities are allowed,',ch10,& 2959 & 'while the argument nspden=',nspden 2960 MSG_BUG(msg) 2961 end if 2962 if(nrad>pawrad%mesh_size)then 2963 msg='nrad > mesh size!' 2964 MSG_BUG(msg) 2965 end if 2966 2967 !Compute sizes of arrays and flags 2968 order=2 ! We need Kxc 2969 ngrad=1;if (xclevel==2) ngrad=2 ! ngrad=1 is for LDAs or LSDs; ngrad=2 is for GGAs 2970 call pawxc_size_dvxc_wrapper(ixc,ndvxc,ngr2,nd2vxc,nspden,nvxcdgr,order) 2971 nkxc=2*nspden-1;if (xclevel==2) nkxc=15 ! Not correct for nspden=1 2972 mgga=0 !metaGGA contributions are not taken into account here 2973 2974 !-------------------------------------------------------------------------- 2975 !-------------- GGA: computation of the gradients of the densities 2976 !-------------------------------------------------------------------------- 2977 2978 LIBPAW_ALLOCATE(grho2,(nrad,ngr2)) 2979 if (ngrad==2) then 2980 2981 LIBPAW_ALLOCATE(grho_updn,(nrad,nspden)) 2982 LIBPAW_ALLOCATE(grho1_updn,(cplex_den*nrad,nspden)) 2983 2984 ! Gradient of density 2985 LIBPAW_ALLOCATE(dff,(nrad)) 2986 do ispden=1,nspden 2987 call nderiv_gen(dff,rho_updn(:,ispden),pawrad) 2988 grho_updn(:,ispden)=dff(:) 2989 end do 2990 ! Gradient of 1st-order density 2991 if (cplex_den==1) then 2992 do ispden=1,nspden 2993 call nderiv_gen(dff,rho1_updn(:,ispden),pawrad) 2994 grho1_updn(:,ispden)=dff(:) 2995 end do 2996 else 2997 LIBPAW_ALLOCATE(ff,(nrad)) 2998 LIBPAW_ALLOCATE(gg,(nrad)) 2999 LIBPAW_ALLOCATE(dgg,(nrad)) 3000 do ispden=1,nspden 3001 do ir=1,nrad 3002 ff(ir)=rho1_updn(2*ir-1,ispden) 3003 gg(ir)=rho1_updn(2*ir ,ispden) 3004 end do 3005 call nderiv_gen(dff,ff,pawrad) 3006 call nderiv_gen(dgg,gg,pawrad) 3007 do ir=1,nrad 3008 grho1_updn(2*ir-1,ispden)=dff(ir) 3009 grho1_updn(2*ir ,ispden)=dgg(ir) 3010 end do 3011 end do 3012 LIBPAW_DEALLOCATE(ff) 3013 LIBPAW_DEALLOCATE(gg) 3014 LIBPAW_DEALLOCATE(dgg) 3015 end if 3016 LIBPAW_DEALLOCATE(dff) 3017 3018 ! Squared norm of the gradient 3019 grho2(:,1)=grho_updn(:,1)**2 3020 if (nspden==2) then 3021 grho2(:,2)=grho_updn(:,2)**2 3022 grho2(:,3)=(grho_updn(:,1)+grho_updn(:,2))**2 3023 end if 3024 3025 end if 3026 3027 !-------------------------------------------------------------------------- 3028 !-------------- Computation of Kxc (and Exc, Vxc) 3029 !-------------------------------------------------------------------------- 3030 3031 LIBPAW_ALLOCATE(exc,(nrad)) 3032 LIBPAW_ALLOCATE(vxc,(nrad,nspden)) 3033 LIBPAW_ALLOCATE(dvxc,(nrad,ndvxc)) 3034 LIBPAW_ALLOCATE(dvxcdgr,(nrad,nvxcdgr)) 3035 3036 !Call to main XC driver 3037 call pawxc_drivexc_wrapper(exc,ixc,mgga,ndvxc,nd2vxc,ngr2,nrad,nspden,nvxcdgr,order,rho_updn,vxc,xclevel, & 3038 & dvxc=dvxc,grho2=grho2,vxcgrho=dvxcdgr) 3039 3040 !Transfer the XC kernel 3041 LIBPAW_ALLOCATE(kxc,(nrad,nkxc)) 3042 if (nkxc>0.and.ndvxc>0) then 3043 if (nkxc==1.and.ndvxc==15) then 3044 kxc(1:nrad,1)=half*(dvxc(1:nrad,1)+dvxc(1:nrad,9)+dvxc(1:nrad,10)) 3045 else if (nkxc==3.and.ndvxc==15) then 3046 kxc(1:nrad,1)=dvxc(1:nrad,1)+dvxc(1:nrad,9) 3047 kxc(1:nrad,2)=dvxc(1:nrad,10) 3048 kxc(1:nrad,3)=dvxc(1:nrad,2)+dvxc(1:nrad,11) 3049 else if (nkxc==7.and.ndvxc==8) then 3050 kxc(1:nrad,1)=half*dvxc(1:nrad,1) 3051 kxc(1:nrad,2)=half*dvxc(1:nrad,3) 3052 kxc(1:nrad,3)=quarter*dvxc(1:nrad,5) 3053 kxc(1:nrad,4)=eighth*dvxc(1:nrad,7) 3054 else if (nkxc==7.and.ndvxc==15) then 3055 kxc(1:nrad,1)=half*(dvxc(1:nrad,1)+dvxc(1:nrad,9)+dvxc(1:nrad,10)) 3056 kxc(1:nrad,2)=half*dvxc(1:nrad,3)+dvxc(1:nrad,12) 3057 kxc(1:nrad,3)=quarter*dvxc(1:nrad,5)+dvxc(1:nrad,13) 3058 kxc(1:nrad,4)=eighth*dvxc(1:nrad,7)+dvxc(1:nrad,15) 3059 else if (nkxc==19.and.ndvxc==15) then 3060 kxc(1:nrad,1)=dvxc(1:nrad,1)+dvxc(1:nrad,9) 3061 kxc(1:nrad,2)=dvxc(1:nrad,10) 3062 kxc(1:nrad,3)=dvxc(1:nrad,2)+dvxc(1:nrad,11) 3063 kxc(1:nrad,4)=dvxc(1:nrad,3) 3064 kxc(1:nrad,5)=dvxc(1:nrad,4) 3065 kxc(1:nrad,6)=dvxc(1:nrad,5) 3066 kxc(1:nrad,7)=dvxc(1:nrad,6) 3067 kxc(1:nrad,8)=dvxc(1:nrad,7) 3068 kxc(1:nrad,9)=dvxc(1:nrad,8) 3069 kxc(1:nrad,10)=dvxc(1:nrad,12) 3070 kxc(1:nrad,11)=dvxc(1:nrad,13) 3071 kxc(1:nrad,12)=dvxc(1:nrad,14) 3072 kxc(1:nrad,13)=dvxc(1:nrad,15) 3073 else ! Other cases 3074 kxc(1:nrad,1:nkxc)=zero 3075 kxc(1:nrad,1:min(nkxc,ndvxc))=dvxc(1:nrad,1:min(nkxc,ndvxc)) 3076 end if 3077 if (nkxc==7) then 3078 kxc(1:nrad,5)=zero ! Not correct 3079 kxc(1:nrad,6)=zero ! Not correct 3080 kxc(1:nrad,7)=zero ! Not correct 3081 else if (nkxc==19) then 3082 kxc(1:nrad,14)=zero ! Not correct 3083 kxc(1:nrad,15)=zero ! Not correct 3084 kxc(1:nrad,16)=zero ! Not correct 3085 kxc(1:nrad,17)=zero ! Not correct 3086 kxc(1:nrad,18)=zero ! Not correct 3087 kxc(1:nrad,19)=zero ! Not correct 3088 end if 3089 end if 3090 3091 LIBPAW_DEALLOCATE(exc) 3092 LIBPAW_DEALLOCATE(vxc) 3093 LIBPAW_DEALLOCATE(dvxc) 3094 LIBPAW_DEALLOCATE(dvxcdgr) 3095 3096 !-------------------------------------------------------------------------- 3097 !-------------- LDA 3098 !-------------------------------------------------------------------------- 3099 if (ngrad==1.or.ixc==13) then 3100 3101 do ispden=1,3*nspden-2 3102 ivxc=1;if (ispden>2) ivxc=2 3103 if (cplex_vxc==1.and.cplex_den==1) then 3104 vxc1(:,ivxc)=vxc1(:,ivxc)+kxc(:,ikxc(ii))*rho1_updn(:,irho(ii)) 3105 else 3106 do ir=1,nrad 3107 jr=cplex_den*(ir-1);kr=cplex_vxc*(ir-1) 3108 do ii=1,1+(cplex_den*cplex_vxc)/4 3109 jr=jr+1;kr=kr+1 3110 vxc1(kr,ivxc)=vxc1(kr,ivxc)+kxc(ir,ikxc(ii))*rho1_updn(jr,irho(ii)) 3111 end do 3112 end do 3113 end if 3114 end do 3115 3116 ! -------------------------------------------------------------------------- 3117 ! -------------- GGA 3118 ! -------------------------------------------------------------------------- 3119 else 3120 3121 ! FOR NSPDEN=1, should eliminate computation of gxc1i(...), vxc1i(...) 3122 3123 ! LIBPAW_ALLOCATE(vxc1r,(nrad,2)) 3124 ! LIBPAW_ALLOCATE(vxc1i,(nrad,2)) 3125 ! LIBPAW_ALLOCATE(gxc1r,(nrad,2)) 3126 ! LIBPAW_ALLOCATE(gxc1i,(nrad,2)) 3127 ! do ir=1,nrad 3128 ! if (cplex_vxc==1) then ! cplex_vxc==1 and (cplex_den==1 or cplex_den=2) 3129 ! jr=cplex_den*(ir-1)+1 3130 ! grho_grho1_up=grho_updn(ir,1)*grho1_updn(jr,1) 3131 ! grho_grho1_dn=grho_updn(ir,2)*grho1_updn(jr,2) 3132 ! vxc1r(ir,1)=(kxc(ir, 1)+kxc(ir, 9))*rho1_updn(jr,1)+kxc(ir,10)*rho1_updn(jr,2) & 3133 ! & +kxc(ir, 5)*grho_grho1_up+kxc(ir,13)*grho_grho1 3134 ! vxc1r(ir,2)=(kxc(ir, 2)+kxc(ir,11))*rho1_updn(jr,2)+kxc(ir,10)*rho1_updn(jr,1) & 3135 ! & +kxc(ir, 6)*grho_grho1_dn+kxc(ir,14)*grho_grho1 3136 ! coeff_grho_corr=kxc(ir,13)*rho1_updn(jr,1)+kxc(ir,14)*rho1_updn(jr,2)+kxc(ir,15)*grho_grho1 3137 ! coeff_grho_up =kxc(ir, 5)*rho1_updn(jr,1)+kxc(ir, 7)*grho_grho1_up 3138 ! coeff_grho_dn =kxc(ir, 6)*rho1_updn(jr,2)+kxc(ir, 8)*grho_grho1_dn 3139 ! gxc1r(ir,1)=(kxc(ir, 3)+kxc(ir,12))*grho1_updn(jr,1)+kxc(ir,12)*grho1_updn(jr,2) & 3140 ! & +coeff_grho_up*grho_updn(jr,1)+coeff_grho_corr*(grho_updn(jr,1)+grho_updn(jr,2)) 3141 ! gxc1r(ir,2)=(kxc(ir, 4)+kxc(ir,12))*grho1_updn(jr,2)+kxc(ir,12)*grho1_updn(jr,1) & 3142 ! & +coeff_grho_dn*grho_updn(jr,2)+coeff_grho_corr*(grho_updn(jr,1)+grho_updn(jr,2)) 3143 ! end if 3144 ! if (grho2(ir,1)<tol24) gxc1r(ir,:)=zero ! ??? 3145 ! end do 3146 ! 3147 ! ! Apply divergence 3148 ! fact=one;if (nspden==1) fact=two ! Is it true ? we force nspden=2 for gxc... 3149 ! if (cplex_vxc==1) then 3150 ! LIBPAW_ALLOCATE(dff,(nrad)) 3151 ! do ispden=1,nspden 3152 ! call nderiv_gen(dff,gxc1r(:,ispden),pawrad) 3153 ! vxc1(2:nrad,ispden)=vxc1r(2:nrad,ispden)-fact*(dff(2:nrad)+two*gxc1r(2:nrad,ispden)/pawrad%rad(2:nrad)) 3154 ! call pawrad_deducer0(vxc1(:,ispden),nrad,pawrad) 3155 ! end do 3156 ! LIBPAW_DEALLOCATE(dff) 3157 ! else 3158 ! LIBPAW_ALLOCATE(dff,(nrad)) 3159 ! LIBPAW_ALLOCATE(dgg,(nrad)) 3160 ! LIBPAW_ALLOCATE(ff,(nrad)) 3161 ! LIBPAW_ALLOCATE(gg,(nrad)) 3162 ! do ispden=1,nspden 3163 ! call nderiv_gen(dff,gxc1r(:,ispden),pawrad) 3164 ! call nderiv_gen(dgg,gxc1i(:,ispden),pawrad) 3165 ! ff(2:nrad)=vxc1r(2:nrad,ispden)-fact*(dff(2:nrad)+two*gxc1r(2:nrad,ispden)/pawrad%rad(2:nrad)) 3166 ! gg(2:nrad)=vxc1i(2:nrad,ispden)-fact*(dgg(2:nrad)+two*gxc1i(2:nrad,ispden)/pawrad%rad(2:nrad)) 3167 ! call pawrad_deducer0(ff,nrad,pawrad) 3168 ! call pawrad_deducer0(gg,nrad,pawrad) 3169 ! do ir=1,nrad 3170 ! vxc1(2*ir-1,ispden)=ff(ir) 3171 ! vxc1(2*ir ,ispden)=gg(ir) 3172 ! end do 3173 ! end do 3174 ! LIBPAW_DEALLOCATE(dff) 3175 ! LIBPAW_DEALLOCATE(dgg) 3176 ! LIBPAW_DEALLOCATE(ff) 3177 ! LIBPAW_DEALLOCATE(gg) 3178 ! end if 3179 ! 3180 ! LIBPAW_DEALLOCATE(vxc1r) 3181 ! LIBPAW_DEALLOCATE(vxc1i) 3182 ! LIBPAW_DEALLOCATE(gxc1r) 3183 ! LIBPAW_DEALLOCATE(gxc1i) 3184 3185 end if ! ngrad==2 3186 3187 !-------------------------------------------------------------------------- 3188 !-------------- Deallocations 3189 !-------------------------------------------------------------------------- 3190 3191 LIBPAW_DEALLOCATE(grho2) 3192 LIBPAW_DEALLOCATE(kxc) 3193 if (ngrad==2) then 3194 LIBPAW_DEALLOCATE(grho_updn) 3195 LIBPAW_DEALLOCATE(grho1_updn) 3196 end if 3197 3198 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
PARENTS
m_pawxc
CHILDREN
rotate_back_mag_dfpt
SOURCE
3241 subroutine pawxcsphpositron(calctype,fxc,ixcpositron,nrad,pawrad,posdensity0_limit,rho,rho_ep,vxce,vxcp) 3242 3243 3244 !This section has been created automatically by the script Abilint (TD). 3245 !Do not modify the following lines by hand. 3246 #undef ABI_FUNC 3247 #define ABI_FUNC 'pawxcsphpositron' 3248 !End of the abilint section 3249 3250 implicit none 3251 3252 !Arguments ------------------------------------ 3253 !scalars 3254 integer,intent(in) :: calctype,ixcpositron,nrad 3255 logical,intent(in) :: posdensity0_limit 3256 type(pawrad_type),intent(in) :: pawrad 3257 !arrays 3258 real(dp),intent(in) :: rho(nrad),rho_ep(nrad) 3259 real(dp),intent(out) :: fxc(nrad),vxce(nrad),vxcp(nrad) 3260 3261 !Local variables------------------------------- 3262 !scalars 3263 integer :: ngr 3264 character(len=500) :: msg 3265 !arrays 3266 real(dp),allocatable :: dff(:),rhograd(:),rhograd2(:),vxcegr(:) 3267 3268 ! ************************************************************************* 3269 3270 if(nrad>pawrad%mesh_size)then 3271 msg='nrad > mesh size!' 3272 MSG_BUG(msg) 3273 end if 3274 3275 !Need gradient of density for GGA 3276 ngr=0;if (ixcpositron==3.or.ixcpositron==31) ngr=nrad 3277 LIBPAW_ALLOCATE(rhograd,(ngr)) 3278 LIBPAW_ALLOCATE(rhograd2,(ngr)) 3279 LIBPAW_ALLOCATE(vxcegr,(ngr)) 3280 if (ngr==nrad) then 3281 if (calctype==1) then 3282 call nderiv_gen(rhograd,rho_ep,pawrad) 3283 else if (calctype==2) then 3284 call nderiv_gen(rhograd,rho,pawrad) 3285 end if 3286 rhograd2(:)=rhograd(:)**2 3287 end if 3288 3289 !---- Computation of Fxc and Vxc for the positron 3290 !rho is the positronic density 3291 !rho_ep is the electronic density 3292 if (calctype==1) then 3293 call pawxc_xcpositron_wrapper(fxc,rhograd2,ixcpositron,ngr,nrad,posdensity0_limit,rho_ep,rho,vxce,vxcegr,vxcp) 3294 3295 ! ---- Computation of Exc and Vxc for the electron 3296 ! rho is the electronic density 3297 ! rho_ep is the positronic density 3298 else if (calctype==2) then 3299 call pawxc_xcpositron_wrapper(fxc,rhograd2,ixcpositron,ngr,nrad,posdensity0_limit,rho,rho_ep,vxce,vxcegr,vxcp) 3300 end if 3301 3302 LIBPAW_DEALLOCATE(rhograd2) 3303 3304 !---- GGA - gradient corrections 3305 if (ngr==nrad) then 3306 LIBPAW_ALLOCATE(dff,(nrad)) 3307 vxcegr(1:nrad)=vxcegr(1:nrad)*rhograd(1:nrad) 3308 call nderiv_gen(dff,vxcegr,pawrad) 3309 vxcp(2:nrad)=vxcp(2:nrad)-(dff(2:nrad)+two*vxcegr(2:nrad)/pawrad%rad(2:nrad)) 3310 call pawrad_deducer0(vxcp,nrad,pawrad) 3311 LIBPAW_DEALLOCATE(dff) 3312 end if 3313 3314 LIBPAW_DEALLOCATE(vxcegr) 3315 LIBPAW_DEALLOCATE(rhograd) 3316 3317 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
PARENTS
m_pawxc,poslifetime,posratecore
CHILDREN
rotate_back_mag_dfpt
SOURCE
3371 subroutine pawxcsum(cplex1,cplex2,cplexsum,lmselect1,lmselect2,lm_size,nrad,nsums,& 3372 & option,pawang,rho1,rho2,sum1,sum2) 3373 3374 3375 !This section has been created automatically by the script Abilint (TD). 3376 !Do not modify the following lines by hand. 3377 #undef ABI_FUNC 3378 #define ABI_FUNC 'pawxcsum' 3379 !End of the abilint section 3380 3381 implicit none 3382 3383 !Arguments ------------------------------------ 3384 !scalars 3385 integer,intent(in) :: cplex1,cplex2,cplexsum,lm_size,nrad,nsums,option 3386 !arrays 3387 logical,intent(in) :: lmselect1(lm_size),lmselect2(lm_size) 3388 real(dp),intent(in) :: rho1(cplex1*nrad,lm_size),rho2(cplex2*nrad,lm_size) 3389 real(dp),intent(out) :: sum1(cplexsum*nrad,nsums),sum2(cplexsum*nrad,lm_size,nsums*(option/2)) 3390 type(pawang_type),intent(in) :: pawang 3391 3392 !Local variables------------------------------- 3393 !scalars 3394 integer :: ilm,ilm1,ilm2,ir,i1r,i2r,i3r,isel 3395 real(dp) :: fact,ro1i,ro1r,ro2i,ro2r 3396 character(len=500) :: msg 3397 !arrays 3398 3399 !************************************************************************ 3400 3401 if(nsums/=1.and.nsums/=3) then 3402 msg='nsums must be 1 or 3!' 3403 MSG_BUG(msg) 3404 end if 3405 if(pawang%gnt_option==0) then 3406 msg='pawang%gnt_option=0!' 3407 MSG_BUG(msg) 3408 end if 3409 3410 if (option>=1) then 3411 3412 ! SUM1(r)= Sum_L{Rho1_L(r)*Rho2_L(r)} (L>0) 3413 ! -------------------------------------------------- 3414 sum1=zero 3415 3416 ! ===== All input/output densities are REAL ==== 3417 if (cplex1==1.and.cplex2==1.and.cplexsum==1) then 3418 ! One sum to compute 3419 if (nsums==1) then 3420 do ilm=2,lm_size 3421 if (lmselect1(ilm).and.lmselect2(ilm)) then 3422 sum1(:,1)=sum1(:,1)+rho1(:,ilm)*rho2(:,ilm) 3423 end if 3424 end do 3425 ! Three sums to compute 3426 else 3427 do ilm=2,lm_size 3428 if (lmselect1(ilm)) then 3429 sum1(:,1)=sum1(:,1)+rho1(:,ilm)**2 3430 if (lmselect2(ilm)) sum1(:,2)=sum1(:,2)+rho1(:,ilm)*rho2(:,ilm) 3431 end if 3432 if (lmselect2(ilm)) sum1(:,3)=sum1(:,3)+rho2(:,ilm)**2 3433 end do 3434 end if 3435 3436 ! ===== At least one of Rho1 and Rho2 is COMPLEX ==== 3437 else 3438 ! One sum to compute 3439 if (nsums==1) then 3440 do ilm=2,lm_size 3441 if (lmselect1(ilm).and.lmselect2(ilm)) then 3442 do ir=1,nrad 3443 i1r=cplex1*(ir-1)+1;i2r=cplex2*(ir-1)+1;i3r=cplexsum*(ir-1)+1 3444 ro1r=rho1(i1r,ilm);ro1i=zero;if (cplex1==2) ro1i=rho1(i1r+1,ilm) 3445 ro2r=rho2(i2r,ilm);ro2i=zero;if (cplex2==2) ro2i=rho2(i2r+1,ilm) 3446 sum1(i3r,1)=sum1(i3r,1)+ro1r*ro2r-ro1i*ro2i 3447 if (cplexsum==2) sum1(i3r+1,1)=sum1(i3r+1,1)+ro1r*ro2i+ro1i*ro2r 3448 end do 3449 end if 3450 end do 3451 ! Three sums to compute 3452 else 3453 do ilm=2,lm_size 3454 do ir=1,nrad 3455 i1r=cplex1*(ir-1)+1;i2r=cplex2*(ir-1)+1;i3r=cplexsum*(ir-1)+1 3456 ro1r=rho1(i1r,ilm);ro1i=zero;if (cplex1==2) ro1i=rho1(i1r+1,ilm) 3457 ro2r=rho2(i2r,ilm);ro2i=zero;if (cplex2==2) ro2i=rho2(i2r+1,ilm) 3458 if (lmselect1(ilm)) then 3459 sum1(i3r,1)=sum1(i3r,1)+ro1r**2-ro1i**2 3460 if (lmselect2(ilm)) sum1(i3r,2)=sum1(i3r,2)+ro1r*ro2r-ro1i*ro2i 3461 end if 3462 if (lmselect2(ilm)) sum1(i3r,3)=sum1(i3r,3)+ro2r**2-ro2i**2 3463 if (cplexsum==2) then 3464 if (lmselect1(ilm)) then 3465 sum1(i3r+1,1)=sum1(i3r+1,1)+two*ro1r*ro1i 3466 if (lmselect2(ilm)) sum1(i3r+1,2)=sum1(i3r+1,2)+ro1r*ro2i+ro1i*ro2r 3467 end if 3468 if (lmselect2(ilm)) sum1(i3r+1,3)=sum1(i3r+1,3)+two*ro2r*ro2i 3469 end if 3470 end do 3471 end do 3472 end if ! nsums 3473 end if ! cplex 3474 3475 end if !option 3476 3477 if (option>=2) then 3478 3479 ! SUM2(r,L)= Sum_L1_L2{Rho1_L1(r)*Rho2_L2(r)*Gaunt_(L,L1,L2)} (L1>0, L2>0) 3480 ! -------------------------------------------------- 3481 sum2=zero 3482 ! ===== All input/output densities are REAL ==== 3483 if (cplex1==1.and.cplex2==1.and.cplexsum==1) then 3484 ! One sum to compute 3485 if (nsums==1) then 3486 do ilm=1,lm_size 3487 do ilm1=2,lm_size 3488 if (lmselect1(ilm1)) then 3489 do ilm2=2,ilm1 3490 if (lmselect2(ilm2)) then 3491 isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2) 3492 if (isel>0) then 3493 fact=pawang%realgnt(isel);if (ilm1/=ilm2) fact=two*fact 3494 sum2(:,ilm,1)=sum2(:,ilm,1)+fact*rho1(:,ilm1)*rho2(:,ilm2) 3495 end if 3496 end if 3497 end do 3498 end if 3499 end do 3500 end do 3501 ! Three sums to compute 3502 else 3503 do ilm=1,lm_size 3504 do ilm1=2,lm_size 3505 if (lmselect1(ilm1)) then 3506 do ilm2=2,ilm1 3507 if (lmselect1(ilm2)) then 3508 isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2) 3509 if (isel>0) then 3510 fact=pawang%realgnt(isel);if (ilm1/=ilm2) fact=two*fact 3511 sum2(:,ilm,1)=sum2(:,ilm,1)+fact*rho1(:,ilm1)*rho1(:,ilm2) 3512 end if 3513 end if 3514 end do 3515 end if 3516 end do 3517 do ilm1=2,lm_size 3518 if (lmselect2(ilm1)) then 3519 do ilm2=2,ilm1 3520 if (lmselect2(ilm2)) then 3521 isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2) 3522 if (isel>0) then 3523 fact=pawang%realgnt(isel);if (ilm1/=ilm2) fact=two*fact 3524 sum2(:,ilm,3)=sum2(:,ilm,3)+fact*rho2(:,ilm1)*rho2(:,ilm2) 3525 end if 3526 end if 3527 end do 3528 end if 3529 end do 3530 do ilm1=2,lm_size 3531 if (lmselect1(ilm1)) then 3532 do ilm2=2,ilm1 3533 if (lmselect2(ilm2)) then 3534 isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2) 3535 if (isel>0) then 3536 fact=pawang%realgnt(isel) 3537 sum2(:,ilm,2)=sum2(:,ilm,2)+fact*rho1(:,ilm1)*rho2(:,ilm2) 3538 end if 3539 end if 3540 end do 3541 if (ilm1<lm_size) then 3542 do ilm2=ilm1+1,lm_size 3543 if (lmselect2(ilm2)) then 3544 isel=pawang%gntselect(ilm,ilm1+ilm2*(ilm2-1)/2) 3545 if (isel>0) then 3546 fact=pawang%realgnt(isel) 3547 sum2(:,ilm,2)=sum2(:,ilm,2)+fact*rho1(:,ilm1)*rho2(:,ilm2) 3548 end if 3549 end if 3550 end do 3551 end if 3552 end if 3553 end do 3554 end do 3555 end if ! nsums 3556 3557 ! ===== At least one of Rho1 and Rho2 is COMPLEX ==== 3558 else 3559 ! One sum to compute 3560 if (nsums==1) then 3561 do ilm=1,lm_size 3562 do ilm1=2,lm_size 3563 if (lmselect1(ilm1)) then 3564 do ilm2=2,ilm1 3565 if (lmselect2(ilm2)) then 3566 isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2) 3567 if (isel>0) then 3568 fact=pawang%realgnt(isel);if (ilm1/=ilm2) fact=two*fact 3569 do ir=1,nrad 3570 i1r=cplex1*(ir-1)+1;i2r=cplex2*(ir-1)+1;i3r=cplexsum*(ir-1)+1 3571 ro1r=rho1(i1r,ilm1);ro1i=zero;if (cplex1==2) ro1i=rho1(i1r+1,ilm1) 3572 ro2r=rho2(i2r,ilm2);ro2i=zero;if (cplex2==2) ro2i=rho2(i2r+1,ilm2) 3573 sum2(i3r,ilm,1)=sum2(i3r,ilm,1)+fact*(ro1r*ro2r-ro1i*ro2i) 3574 if (cplexsum==2) sum2(i3r+1,ilm,1)=sum2(i3r+1,ilm,1)+fact*(ro1r*ro2i+ro1i*ro2r) 3575 end do 3576 end if 3577 end if 3578 end do 3579 end if 3580 end do 3581 end do 3582 ! Three sums to compute 3583 else 3584 do ilm=2,lm_size 3585 do ir=1,nrad 3586 i1r=cplex1*(ir-1)+1;i2r=cplex2*(ir-1)+1;i3r=cplexsum*(ir-1)+1 3587 do ilm1=2,lm_size 3588 if (lmselect1(ilm1)) then 3589 ro1r=rho1(i1r,ilm1);ro1i=zero;if (cplex1==2) ro1i=rho1(i1r+1,ilm1) 3590 do ilm2=2,ilm1 3591 if (lmselect1(ilm2)) then 3592 isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2) 3593 if (isel>0) then 3594 fact=pawang%realgnt(isel);if (ilm1/=ilm2) fact=two*fact 3595 ro2r=rho1(i1r,ilm2);ro2i=zero;if (cplex1==2) ro2i=rho1(i1r+1,ilm2) 3596 sum2(i3r,ilm,1)=sum2(i3r,ilm,1)+fact*(ro1r*ro2r-ro1i*ro2i) 3597 if (cplexsum==2) sum2(i3r+1,ilm,1)=sum2(i3r+1,ilm,1)+fact*(ro1r*ro2i+ro1i*ro2r) 3598 end if 3599 end if 3600 end do 3601 end if 3602 end do 3603 do ilm1=2,lm_size 3604 if (lmselect2(ilm1)) then 3605 ro1r=rho2(i2r,ilm1);ro1i=zero;if (cplex2==2) ro1i=rho2(i2r+1,ilm1) 3606 do ilm2=2,ilm1 3607 if (lmselect2(ilm2)) then 3608 isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2) 3609 if (isel>0) then 3610 fact=pawang%realgnt(isel);if (ilm1/=ilm2) fact=two*fact 3611 ro2r=rho2(i2r,ilm2);ro2i=zero;if (cplex2==2) ro2i=rho2(i2r+1,ilm2) 3612 sum2(i3r,ilm,3)=sum2(i3r,ilm,3)+fact*(ro1r*ro2r-ro1i*ro2i) 3613 if (cplexsum==2) sum2(i3r+1,ilm,3)=sum2(i3r+1,ilm,3)+fact*(ro1r*ro2i+ro1i*ro2r) 3614 end if 3615 end if 3616 end do 3617 end if 3618 end do 3619 do ilm1=2,lm_size 3620 if (lmselect1(ilm1)) then 3621 ro1r=rho1(i1r,ilm1);ro1i=zero;if (cplex1==2) ro1i=rho1(i1r+1,ilm1) 3622 do ilm2=2,ilm1 3623 if (lmselect2(ilm2)) then 3624 isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2) 3625 if (isel>0) then 3626 fact=pawang%realgnt(isel) 3627 ro2r=rho2(i2r,ilm2);ro2i=zero;if (cplex2==2) ro2i=rho2(i2r+1,ilm2) 3628 sum2(i3r,ilm,2)=sum2(i3r,ilm,2)+fact*(ro1r*ro2r-ro1i*ro2i) 3629 if (cplexsum==2) sum2(i3r+1,ilm,2)=sum2(i3r+1,ilm,2)+fact*(ro1r*ro2i+ro1i*ro2r) 3630 end if 3631 end if 3632 end do 3633 if (ilm1<lm_size) then 3634 do ilm2=ilm1+1,lm_size 3635 if (lmselect2(ilm2)) then 3636 isel=pawang%gntselect(ilm,ilm1+ilm2*(ilm2-1)/2) 3637 if (isel>0) then 3638 fact=pawang%realgnt(isel) 3639 ro2r=rho2(i2r,ilm2);ro2i=zero;if (cplex2==2) ro2i=rho2(i2r+1,ilm2) 3640 sum2(i3r,ilm,2)=sum2(i3r,ilm,2)+fact*(ro1r*ro2r-ro1i*ro2i) 3641 if (cplexsum==2) sum2(i3r+1,ilm,2)=sum2(i3r+1,ilm,2)+fact*(ro1r*ro2i+ro1i*ro2r) 3642 end if 3643 end if 3644 end do 3645 end if 3646 end if 3647 end do 3648 end do 3649 end do 3650 end if ! nsums 3651 3652 end if ! cplex 3653 3654 end if !option 3655 3656 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)
PARENTS
m_pawxc
CHILDREN
rotate_back_mag_dfpt
SOURCE
642 subroutine pawxc_mkdenpos_local() 643 644 645 !This section has been created automatically by the script Abilint (TD). 646 !Do not modify the following lines by hand. 647 #undef ABI_FUNC 648 #define ABI_FUNC 'pawxc_mkdenpos_local' 649 !End of the abilint section 650 651 implicit none 652 653 !Local variables------------------------------- 654 !scalars 655 integer :: ifft,ispden,numneg 656 real(dp) :: rhotmp,worst 657 character(len=500) :: msg 658 !arrays 659 real(dp) :: rho(2) 660 661 ! ************************************************************************* 662 663 numneg=0;worst=zero 664 665 if(nspden==1)then 666 ! Non spin-polarized 667 !$OMP PARALLEL DO PRIVATE(ifft,rhotmp) REDUCTION(MIN:worst) REDUCTION(+:numneg) SHARED(nfft,rhonow) 668 do ifft=1,nfft 669 rhotmp=rhonow(ifft,1) 670 if(rhotmp<xc_denpos)then 671 if(rhotmp<-xc_denpos)then 672 ! This case is probably beyond machine precision considerations 673 worst=min(worst,rhotmp) 674 numneg=numneg+1 675 end if 676 rhonow(ifft,1)=xc_denpos 677 end if 678 end do 679 680 else if (nspden==2) then 681 ! Spin-polarized 682 683 ! rhonow is stored as (up,dn) 684 if (option==0) then 685 !$OMP PARALLEL DO PRIVATE(ifft,ispden,rho,rhotmp) REDUCTION(MIN:worst) REDUCTION(+:numneg) & 686 !$OMP&SHARED(nfft,nspden,rhonow) 687 do ifft=1,nfft 688 ! For polarized case, rho(1) is spin-up density, rho(2) is spin-down density 689 rho(1)=rhonow(ifft,1) 690 rho(2)=rhonow(ifft,2) 691 do ispden=1,nspden 692 if (rho(ispden)<xc_denpos) then 693 if (rho(ispden)<-xc_denpos) then 694 ! This case is probably beyond machine precision considerations 695 worst=min(worst,rho(ispden)) 696 numneg=numneg+1 697 end if 698 rhonow(ifft,ispden)=xc_denpos 699 end if 700 end do 701 end do 702 703 ! rhonow is stored as (up+dn,up) 704 else if (option==1) then 705 !$OMP PARALLEL DO PRIVATE(ifft,ispden,rho,rhotmp) & 706 !$OMP&REDUCTION(MIN:worst) REDUCTION(+:numneg) & 707 !$OMP&SHARED(nfft,nspden,rhonow) 708 do ifft=1,nfft 709 ! For polarized case, rho(1) is spin-up density, rho(2) is spin-down density 710 rho(1)=rhonow(ifft,2) 711 rho(2)=rhonow(ifft,1)-rho(1) 712 do ispden=1,nspden 713 if (rho(ispden)<xc_denpos) then 714 if (rho(ispden)<-xc_denpos) then 715 ! This case is probably beyond machine precision considerations 716 worst=min(worst,rho(ispden)) 717 numneg=numneg+1 718 end if 719 rho(ispden)=xc_denpos 720 rhonow(ifft,1)=rho(1)+rho(2) 721 rhonow(ifft,2)=rho(1) 722 end if 723 end do 724 end do 725 726 end if ! option 727 else 728 msg='nspden>2 not allowed !' 729 MSG_BUG(msg) 730 end if ! End choice between non-spin polarized and spin-polarized. 731 732 if (numneg>0) then 733 if (iwarn==0) then 734 write(msg,'(a,i10,a,a,a,es10.2,a,e10.2,a,a,a,a)')& 735 & 'Density went too small (lower than xc_denpos) at',numneg,' points',ch10,& 736 & 'and was set to xc_denpos=',xc_denpos,'. Lowest was ',worst,'.',ch10,& 737 & 'Likely due to too low boxcut or too low ecut for','pseudopotential core charge.' 738 MSG_WARNING(msg) 739 end if 740 iwarn=iwarn+1 741 end if 742 743 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)
PARENTS
m_pawxc
CHILDREN
rotate_back_mag_dfpt
SOURCE
332 subroutine pawxc_size_dvxc_local() 333 334 335 !This section has been created automatically by the script Abilint (TD). 336 !Do not modify the following lines by hand. 337 #undef ABI_FUNC 338 #define ABI_FUNC 'pawxc_size_dvxc_local' 339 !End of the abilint section 340 341 implicit none 342 343 ! ************************************************************************* 344 345 ngr2=0;nvxcdgr=0;ndvxc=0;nd2vxc=0 346 347 !Dimension for the gradient of the density (only allocated for GGA or mGGA) 348 if ((ixc>=11.and.ixc<=17).or.(ixc>=23.and.ixc<=24).or.ixc==26.or.ixc==27.or. & 349 & (ixc>=31.and.ixc<=34)) ngr2=2*min(nspden,2)-1 350 if (ixc<0.and.(libxc_functionals_isgga().or.libxc_functionals_ismgga())) & 351 & ngr2=2*min(nspden,2)-1 352 353 !A-Only Exc and Vxc 354 if (order**2 <= 1) then 355 if (((ixc>=11 .and. ixc<=15) .or. (ixc>=23 .and. ixc<=24)) .and. ixc/=13) nvxcdgr=3 356 if (ixc==16.or.ixc==17.or.ixc==26.or.ixc==27) nvxcdgr=2 357 if (ixc<0) nvxcdgr=3 358 if (ixc>=31 .and. ixc<=34) nvxcdgr=3 !Native fake metaGGA functionals (for testing purpose only) 359 else 360 361 !B- Exc+Vxc and other derivatives 362 ! Definition of ndvxc and nvxcdgr, 2nd dimension of the arrays of 2nd-order derivatives 363 if (ixc==1 .or. ixc==21 .or. ixc==22 .or. (ixc>=7 .and. ixc<=10) .or. ixc==13) then 364 ! Routine xcspol: new Teter fit (4/93) to Ceperley-Alder data, with spin-pol option routine xcspol 365 ! Routine xcpbe, with different options (optpbe) and orders (order) 366 ndvxc=min(nspden,2)+1 367 else if (ixc>=2 .and. ixc<=6) then 368 ! Perdew-Zunger fit to Ceperly-Alder data (no spin-pol) !routine xcpzca 369 ! Teter fit (4/91) to Ceperley-Alder values (no spin-pol) !routine xctetr 370 ! Wigner xc (no spin-pol) !routine xcwign 371 ! Hedin-Lundqvist xc (no spin-pol) !routine xchelu 372 ! X-alpha (no spin-pol) !routine xcxalp 373 ndvxc=1 374 else if (ixc==12 .or. ixc==24) then 375 ! Routine xcpbe, with optpbe=-2 and different orders (order) 376 ndvxc=8 377 nvxcdgr=3 378 else if ((ixc>=11 .and. ixc<=15 .and. ixc/=13) .or. (ixc==23)) then 379 ! Routine xcpbe, with different options (optpbe) and orders (order) 380 ndvxc=15 381 nvxcdgr=3 382 else if(ixc==16 .or. ixc==17 .or. ixc==26 .or. ixc==27 ) then 383 ndvxc=0 384 nvxcdgr=2 385 else if (ixc<0) then 386 if(libxc_functionals_isgga().or.libxc_functionals_ismgga()) then 387 ndvxc=15 388 else 389 ndvxc=3 390 end if 391 nvxcdgr=3 392 end if 393 394 ! Definition of nd2vxc, 2nd dimension of the array of 3rd-order derivatives 395 if (order==3) then 396 if (ixc==3) nd2vxc=1 ! Non spin polarized LDA case 397 if ((ixc>=7 .and. ixc<=10) .or. (ixc==13)) nd2vxc=3*min(nspden,2)-2 398 ! Following line to be corrected when the calculation of d2vxcar is implemented for these functionals 399 if ((ixc>=11 .and. ixc<=15 .and. ixc/=13) .or. (ixc==23.and.ixc<=24)) nd2vxc=1 400 if ((ixc<0.and.(.not.(libxc_functionals_isgga().or. & 401 & libxc_functionals_ismgga())))) nd2vxc=3*min(nspden,2)-2 402 end if 403 404 end if 405 406 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)
PARENTS
m_pawxc
CHILDREN
rotate_back_mag_dfpt
SOURCE
513 subroutine pawxc_xcmult_local() 514 515 516 !This section has been created automatically by the script Abilint (TD). 517 !Do not modify the following lines by hand. 518 #undef ABI_FUNC 519 #define ABI_FUNC 'pawxc_xcmult_local' 520 !End of the abilint section 521 522 implicit none 523 524 !Local variables------------------------------- 525 !scalars 526 integer :: idir,ifft 527 real(dp) :: rho_tot,rho_up 528 529 ! ************************************************************************* 530 531 do idir=1,3 532 533 if(nspden==1)then 534 !$OMP PARALLEL DO PRIVATE(ifft) SHARED(depsxc,idir,nfft,rhonow) 535 do ifft=1,nfft 536 rhonow(ifft,1,1+idir)=rhonow(ifft,1,1+idir)*depsxc(ifft,2) 537 end do 538 else 539 ! In the spin-polarized case, there are more factors to take into account 540 !$OMP PARALLEL DO PRIVATE(ifft,rho_tot,rho_up) SHARED(depsxc,idir,nfft,rhonow) 541 do ifft=1,nfft 542 rho_tot=rhonow(ifft,1,1+idir) 543 rho_up =rhonow(ifft,2,1+idir) 544 rhonow(ifft,1,1+idir)=rho_up *depsxc(ifft,3) + rho_tot*depsxc(ifft,5) 545 rhonow(ifft,2,1+idir)=(rho_tot-rho_up)*depsxc(ifft,4)+ rho_tot*depsxc(ifft,5) 546 end do 547 end if ! nspden==1 548 end do ! End loop on directions 549 550 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
PARENTS
m_pawxc
CHILDREN
rotate_back_mag_dfpt
SOURCE
187 subroutine pawxc_xcpositron_abinit() 188 189 190 !This section has been created automatically by the script Abilint (TD). 191 !Do not modify the following lines by hand. 192 #undef ABI_FUNC 193 #define ABI_FUNC 'pawxc_xcpositron_abinit' 194 !End of the abilint section 195 196 implicit none 197 198 ! ************************************************************************* 199 200 if(present(dvxce) .and. present(dvxcp)) then 201 call xcpositron(fnxc,grhoe2,ixcpositron,ngr,npt,posdensity0_limit,rhoer,rhopr,vxce,vxcegr,vxcp,& 202 & dvxce=dvxce,dvxcp=dvxcp) ! optional arguments 203 elseif( present(dvxce) .and. .not. present(dvxcp)) then 204 call xcpositron(fnxc,grhoe2,ixcpositron,ngr,npt,posdensity0_limit,rhoer,rhopr,vxce,vxcegr,vxcp,& 205 & dvxce=dvxce) ! optional arguments 206 elseif( .not. present(dvxce) .and. present(dvxcp)) then 207 call xcpositron(fnxc,grhoe2,ixcpositron,ngr,npt,posdensity0_limit,rhoer,rhopr,vxce,vxcegr,vxcp,& 208 & dvxcp=dvxcp) ! optional arguments 209 else 210 call xcpositron(fnxc,grhoe2,ixcpositron,ngr,npt,posdensity0_limit,rhoer,rhopr,vxce,vxcegr,vxcp) 211 end if 212 213 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
PARENTS
m_pawxc
CHILDREN
rotate_back_mag_dfpt
SOURCE
233 subroutine pawxc_xcpositron_local() 234 235 236 !This section has been created automatically by the script Abilint (TD). 237 !Do not modify the following lines by hand. 238 #undef ABI_FUNC 239 #define ABI_FUNC 'pawxc_xcpositron_local' 240 !End of the abilint section 241 242 implicit none 243 244 character(len=*), parameter :: msg='xcpositron only available in ABINIT!' 245 246 ! ************************************************************************* 247 248 MSG_BUG(msg) 249 250 end subroutine pawxc_xcpositron_local