TABLE OF CONTENTS


ABINIT/m_pawxc [ Modules ]

[ Top ] [ 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