Commit ce379ccf authored by Daniel Wortmann's avatar Daniel Wortmann

Added postprocessing code for libxc, major refactoring in x_tofrom_grid routines needed as well

parent b7565d63
......@@ -39,7 +39,9 @@ MODULE m_types_xcpot
REAL,ALLOCATABLE :: gggrd(:),grgru(:),grgrd(:)
!These are the contracted Gradients used in libxc
REAL,ALLOCATABLE :: sigma(:,:)
REAL,ALLOCATABLE :: vsigma(:,:)
REAL,ALLOCATABLE :: gr(:,:,:)
REAL,ALLOCATABLE :: laplace(:,:)
END TYPE t_gradients
CONTAINS
......@@ -64,15 +66,14 @@ CONTAINS
a_ex=-1
END FUNCTION xcpot_get_exchange_weight
SUBROUTINE xcpot_get_vxc(xcpot,jspins,rh,vxc,vx,grad,drdsigma)
SUBROUTINE xcpot_get_vxc(xcpot,jspins,rh,vxc,vx,grad)
CLASS(t_xcpot),INTENT(IN) :: xcpot
INTEGER, INTENT (IN) :: jspins
!--> charge density
REAL,INTENT (IN) :: rh(:,:)
!---> xc potential
REAL, INTENT (OUT) :: vxc (:,:),vx(:,:)
TYPE(t_gradients),OPTIONAL,INTENT(IN)::grad
REAL,ALLOCATABLE,OPTIONAL,INTENT(OUT)::drdsigma(:)
TYPE(t_gradients),OPTIONAL,INTENT(INOUT)::grad
END SUBROUTINE xcpot_get_vxc
......
......@@ -135,7 +135,7 @@ CONTAINS
END FUNCTION xcpot_get_exchange_weight
!***********************************************************************
SUBROUTINE xcpot_get_vxc(xcpot,jspins,rh, vxc,vx, grad,drdsigma)
SUBROUTINE xcpot_get_vxc(xcpot,jspins,rh, vxc,vx, grad)
!***********************************************************************
!
USE m_xcxal, ONLY : vxcxal
......@@ -164,8 +164,7 @@ CONTAINS
REAL, INTENT (OUT) :: vxc(:,:)
! optional arguments for GGA
TYPE(t_gradients),INTENT(IN),OPTIONAL::grad
REAL,ALLOCATABLE,OPTIONAL,INTENT(OUT)::drdsigma(:) !This will not be allocated
TYPE(t_gradients),INTENT(INOUT),OPTIONAL::grad
!c
!c ---> local scalars
INTEGER :: ngrid
......
......@@ -95,7 +95,7 @@ CONTAINS
END FUNCTION xcpot_get_exchange_weight
!***********************************************************************
SUBROUTINE xcpot_get_vxc(xcpot,jspins,rh, vxc,vx, grad,drdsigma)
SUBROUTINE xcpot_get_vxc(xcpot,jspins,rh, vxc,vx, grad)
!***********************************************************************
IMPLICIT NONE
CLASS(t_xcpot_libxc),INTENT(IN) :: xcpot
......@@ -104,22 +104,21 @@ CONTAINS
REAL, INTENT (OUT) :: vx (:,:) !points,spin
REAL, INTENT (OUT ) :: vxc(:,:) !
! optional arguments for GGA
TYPE(t_gradients),OPTIONAL,INTENT(IN)::grad
REAL,ALLOCATABLE,OPTIONAL,INTENT(OUT)::drdsigma(:)
TYPE(t_gradients),OPTIONAL,INTENT(INOUT)::grad
#ifdef CPP_LIBXC
REAL,ALLOCATABLE::vxc_tmp(:,:),vx_tmp(:,:),vsigma(:)
REAL,ALLOCATABLE::vxc_tmp(:,:),vx_tmp(:,:),vsigma(:,:)
!libxc uses the spin as a first index, hence we have to transpose....
ALLOCATE(vxc_tmp(SIZE(vxc,2),SIZE(vxc,1)));vxc_tmp=0.0
ALLOCATE(vx_tmp(SIZE(vx,2),SIZE(vx,1)));vx_tmp=0.0
IF (xcpot%is_gga()) THEN
CALL judft_error("libxc GGA not implemented yet")
IF (.NOT.PRESENT(grad)) CALL judft_error("Bug: You called get_vxc for a GGA potential without providing derivatives")
ALLOCATE(drdsigma(SIZE(grad%sigma)))
CALL xc_f03_gga_vxc(xcpot%xc_func_x, SIZE(rh,1), TRANSPOSE(rh),grad%sigma,vx_tmp,drdsigma)
ALLOCATE(grad%vsigma,mold=grad%sigma)
CALL xc_f03_gga_vxc(xcpot%xc_func_x, SIZE(rh,1), TRANSPOSE(rh),grad%sigma,vx_tmp,grad%vsigma)
IF (xcpot%func_id_c>0) THEN
ALLOCATE(vsigma(SIZE(grad%sigma)))
ALLOCATE(vsigma,mold=grad%sigma)
CALL xc_f03_gga_vxc(xcpot%xc_func_c, SIZE(rh,1), TRANSPOSE(rh),grad%sigma,vxc_tmp,vsigma)
drdsigma=drdsigma+vsigma
grad%vsigma=grad%vsigma+vsigma
vxc_tmp=vxc_tmp+vx_tmp
ENDIF
ELSE !LDA potentials
......
......@@ -2,8 +2,6 @@ set(fleur_F77 ${fleur_F77}
vgen/dylm3.f
vgen/fft3dxc.f
vgen/grdrsvac.f
vgen/mkgxyz3.f
vgen/mkgylm.f
vgen/mkgz.f
vgen/modcyli.f
vgen/modcylk.f
......@@ -17,6 +15,8 @@ vgen/visp5_z.f
)
set(fleur_F90 ${fleur_F90}
vgen/b_field.F90
vgen/mkgylm.f90
vgen/mkgxyz3.f90
vgen/convol.f90
vgen/grdrsis.f90
vgen/mt_tofrom_grid.F90
......
......@@ -3,75 +3,85 @@
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------
MODULE m_mkgxyz3
c.....------------------------------------------------------------------
c by use of cartesian x,y,z components of charge density gradients,
c make the quantities
cc agrt,agru,agrd,g2rt,g2ru,g2rd,gggrt,gggru,gggrd,gzgr
cc used to calculate gradient contribution to xc potential and
cc energy.
c.....------------------------------------------------------------------
CONTAINS
SUBROUTINE mkgxyz3(
> ndm,jsdm,ng3,jspins,vl,
> dvx,dvy,dvz,dvxx,dvyy,dvzz,dvyz,dvzx,dvxy,
< grad)
USE m_types
IMPLICIT NONE
INTEGER, INTENT (IN) :: ndm,ng3,jsdm,jspins
REAL, INTENT (IN) :: vl(ndm,jsdm)
REAL, INTENT (IN) :: dvx(ndm,jsdm),dvy(ndm,jsdm),dvz(ndm,jsdm)
REAL, INTENT (IN) :: dvxx(ndm,jsdm),dvyy(ndm,jsdm),dvzz(ndm,jsdm)
REAL, INTENT (IN) :: dvyz(ndm,jsdm),dvzx(ndm,jsdm),dvxy(ndm,jsdm)
TYPE(t_gradients),INTENT(INOUT)::grad
REAL vlt,dvxt,dvyt,dvzt,dvxxt,dvyyt,dvzzt,dvyzt,dvzxt,dvxyt,
& vlu,dvxu,dvyu,dvzu,dvxxu,dvyyu,dvzzu,dvyzu,dvzxu,dvxyu,
& vld,dvxd,dvyd,dvzd,dvxxd,dvyyd,dvzzd,dvyzd,dvzxd,dvxyd,
& dagrxt,dagrxd,dagrxu,dagryt,dagryd,dagryu,dagrzt,dagrzd,
+ dagrzu,dzdx,dzdy,dzdz,
+ sml
INTEGER i
sml = 1.e-14
IF(ALLOCATED(grad%sigma)) THEN
!Use only contracted gradients for libxc
if (jspins==1) THEN
DO i=1,ng3
grad%sigma(1,i)=
+ dvx(i,1)*dvx(i,1)+dvy(i,1)*dvy(i,1)+dvz(i,1)*dvz(i,1)
ENDDO
ELSE
DO i=1,ng3
grad%sigma(1,i)=
+ dvx(i,1)*dvx(i,1)+dvy(i,1)*dvy(i,1)+dvz(i,1)*dvz(i,1)
grad%sigma(2,i)=
+ dvx(i,1)*dvx(i,2)+dvy(i,1)*dvy(i,2)+dvz(i,1)*dvz(i,2)
grad%sigma(3,i)=
+ dvx(i,2)*dvx(i,2)+dvy(i,2)*dvy(i,2)+dvz(i,2)*dvz(i,2)
ENDDO
ENDIF
RETURN
ENDIF
DO i = 1,ndm
grad%agrt(i) = 0.0
grad%agru(i) = 0.0
grad%agrd(i) = 0.0
grad%gggrt(i) = 0.0
grad%gggru(i) = 0.0
grad%gggrd(i) = 0.0
grad%gzgr(i) = 0.0
grad%g2rt(i) = 0.0
grad%g2ru(i) = 0.0
grad%g2rd(i) = 0.0
ENDDO
IF (jspins.eq.1) THEN
DO 10 i = 1,ng3
MODULE m_mkgxyz3
!.....------------------------------------------------------------------
!c by use of cartesian x,y,z components of charge density gradients,
!c make the quantities
!cc agrt,agru,agrd,g2rt,g2ru,g2rd,gggrt,gggru,gggrd,gzgr
!cc used to calculate gradient contribution to xc potential and
!cc energy.
!c.....------------------------------------------------------------------
CONTAINS
SUBROUTINE mkgxyz3(vl,dvx,dvy,dvz,dvxx,dvyy,dvzz,dvyz,dvzx,dvxy,grad)
USE m_types
IMPLICIT NONE
REAL, INTENT (IN) :: vl(:,:)
REAL, INTENT (IN) :: dvx(:,:),dvy(:,:),dvz(:,:)
REAL, INTENT (IN) :: dvxx(:,:),dvyy(:,:),dvzz(:,:)
REAL, INTENT (IN) :: dvyz(:,:),dvzx(:,:),dvxy(:,:)
TYPE(t_gradients),INTENT(INOUT)::grad
REAL vlt,dvxt,dvyt,dvzt,dvxxt,dvyyt,dvzzt,dvyzt,dvzxt,dvxyt,&
vlu,dvxu,dvyu,dvzu,dvxxu,dvyyu,dvzzu,dvyzu,dvzxu,dvxyu,&
vld,dvxd,dvyd,dvzd,dvxxd,dvyyd,dvzzd,dvyzd,dvzxd,dvxyd,&
dagrxt,dagrxd,dagrxu,dagryt,dagryd,dagryu,dagrzt,dagrzd,&
dagrzu,dzdx,dzdy,dzdz,sml
INTEGER i,js,jspins,nsp
nsp=SIZE(dvx,1)
jspins=SIZE(dvx,2)
sml = 1.e-14
IF (ALLOCATED(grad%gr)) THEN
! Gradients for libxc
DO js=1,jspins
DO i=1,nsp
grad%gr(:,i,js)=(/dvx(i,js),dvy(i,js),dvz(i,js)/)
ENDDO
END DO
IF(ALLOCATED(grad%sigma)) THEN
!Use only contracted gradients for libxc
IF (jspins==1) THEN
DO i=1,nsp
grad%sigma(1,i)= dvx(i,1)*dvx(i,1)+dvy(i,1)*dvy(i,1)+dvz(i,1)*dvz(i,1)
ENDDO
ELSE
DO i=1,nsp
grad%sigma(1,i)= dvx(i,1)*dvx(i,1)+dvy(i,1)*dvy(i,1)+dvz(i,1)*dvz(i,1)
grad%sigma(2,i)= dvx(i,1)*dvx(i,2)+dvy(i,1)*dvy(i,2)+dvz(i,1)*dvz(i,2)
grad%sigma(3,i)= dvx(i,2)*dvx(i,2)+dvy(i,2)*dvy(i,2)+dvz(i,2)*dvz(i,2)
ENDDO
ENDIF
END IF
IF(ALLOCATED(grad%laplace)) THEN
DO js=1,jspins
DO i=1,nsp
grad%laplace(i,js)= dvxx(i,js)+dvyy(i,js)+dvzz(i,js)
ENDDO
ENDDO
ENDIF
RETURN
ENDIF
IF (ANY(SHAPE(vl).NE.SHAPE(dvx))) CALL judft_error("Gradients for internal GGA called with inconsistent sizes",hint="This is a bug")
DO i = 1,size(grad%agrt)
grad%agrt(i) = 0.0
grad%agru(i) = 0.0
grad%agrd(i) = 0.0
grad%gggrt(i) = 0.0
grad%gggru(i) = 0.0
grad%gggrd(i) = 0.0
grad%gzgr(i) = 0.0
grad%g2rt(i) = 0.0
grad%g2ru(i) = 0.0
grad%g2rd(i) = 0.0
ENDDO
IF (jspins.eq.1) THEN
DO 10 i = 1,nsp
vlu=max(vl(i,1)/2,sml)
dvxu=dvx(i,1)/2
......@@ -108,7 +118,7 @@ c.....------------------------------------------------------------------
dvzxt = dvzxu + dvzxd
dvxyt = dvxyu + dvxyd
c agr: abs(grad(ro)), t,u,d for total, up and down.
! agr: abs(grad(ro)), t,u,d for total, up and down.
grad%agrt(i) = max(sqrt(dvxt**2+dvyt**2+dvzt**2),sml)
grad%agru(i) = max(sqrt(dvxu**2+dvyu**2+dvzu**2),sml)
......@@ -130,28 +140,28 @@ c agr: abs(grad(ro)), t,u,d for total, up and down.
grad%gggru(i) = dvxu*dagrxu + dvyu*dagryu + dvzu*dagrzu
grad%gggrd(i) = dvxd*dagrxd + dvyd*dagryd + dvzd*dagrzd
c dzdx=d(zeta)/dx,..
! dzdx=d(zeta)/dx,..
dzdx = (dvxu-dvxd)/vlt - (vlu-vld)*dvxt/vlt**2
dzdy = (dvyu-dvyd)/vlt - (vlu-vld)*dvyt/vlt**2
dzdz = (dvzu-dvzd)/vlt - (vlu-vld)*dvzt/vlt**2
c gzgr=grad(zeta)*grad(ro).
! gzgr=grad(zeta)*grad(ro).
grad%gzgr(i) = dzdx*dvxt + dzdy*dvyt + dzdz*dvzt
c g2r: grad(grad(ro))
! g2r: grad(grad(ro))
grad%g2rt(i) = dvxxt + dvyyt + dvzzt
grad%g2ru(i) = dvxxu + dvyyu + dvzzu
grad%g2rd(i) = dvxxd + dvyyd + dvzzd
10 ENDDO
10 ENDDO
ELSE
ELSE
DO 20 i = 1,ng3
DO 20 i = 1,nsp
vlu = max(vl(i,1),sml)
dvxu=dvx(i,1)
......@@ -187,7 +197,7 @@ c g2r: grad(grad(ro))
dvzxt = dvzxu + dvzxd
dvxyt = dvxyu + dvxyd
c agr: abs(grad(ro)), t,u,d for total, up and down.
!c agr: abs(grad(ro)), t,u,d for total, up and down.
grad%agrt(i) = max(sqrt(dvxt**2+dvyt**2+dvzt**2),sml)
grad%agru(i) = max(sqrt(dvxu**2+dvyu**2+dvzu**2),sml)
......@@ -209,25 +219,25 @@ c agr: abs(grad(ro)), t,u,d for total, up and down.
grad%gggru(i) = dvxu*dagrxu + dvyu*dagryu + dvzu*dagrzu
grad%gggrd(i) = dvxd*dagrxd + dvyd*dagryd + dvzd*dagrzd
c dzdx=d(zeta)/dx,..
!c dzdx=d(zeta)/dx,..
dzdx = (dvxu-dvxd)/vlt - (vlu-vld)*dvxt/vlt**2
dzdy = (dvyu-dvyd)/vlt - (vlu-vld)*dvyt/vlt**2
dzdz = (dvzu-dvzd)/vlt - (vlu-vld)*dvzt/vlt**2
c gzgr=grad(zeta)*grad(ro).
!c gzgr=grad(zeta)*grad(ro).
grad%gzgr(i) = dzdx*dvxt + dzdy*dvyt + dzdz*dvzt
c g2r: grad(grad(ro))
!c g2r: grad(grad(ro))
grad%g2rt(i) = dvxxt + dvyyt + dvzzt
grad%g2ru(i) = dvxxu + dvyyu + dvzzu
grad%g2rd(i) = dvxxd + dvyyd + dvzzd
20 ENDDO
20 ENDDO
ENDIF
END SUBROUTINE mkgxyz3
END MODULE m_mkgxyz3
ENDIF
END SUBROUTINE mkgxyz3
END MODULE m_mkgxyz3
This diff is collapsed.
This diff is collapsed.
......@@ -42,20 +42,20 @@ CONTAINS
END IF
END SUBROUTINE init_mt_grid
SUBROUTINE mt_to_grid(atoms,sphhar,den,nsp,jspins,n,l_grad,ch,grad)
SUBROUTINE mt_to_grid(atoms,sphhar,den_mt,nsp,jspins,n,l_grad,grad,ch)
USE m_grdchlh
USE m_mkgylm
IMPLICIT NONE
TYPE(t_atoms),INTENT(IN) :: atoms
TYPE(t_sphhar),INTENT(IN) :: sphhar
TYPE(t_potden),INTENT(IN) :: den
REAL,INTENT(IN) :: den_mt(:,0:,:)
INTEGER,INTENT(IN) :: n,jspins,nsp
LOGICAL,INTENT(IN) :: l_grad
REAL,INTENT(OUT) :: ch(:,:)
TYPE(t_gradients),INTENT(INOUT)::grad
REAL,INTENT(OUT),OPTIONAL :: ch(:,:)
TYPE(t_gradients),INTENT(INOUT):: grad
REAL, ALLOCATABLE :: chlh(:,:,:),chlhdr(:,:,:),chlhdrr(:,:,:)
REAL, ALLOCATABLE :: chdr(:,:),chdt(:,:),chdf(:,:)
REAL, ALLOCATABLE :: chdr(:,:),chdt(:,:),chdf(:,:),ch_tmp(:,:)
REAL, ALLOCATABLE :: chdrr(:,:),chdtt(:,:),chdff(:,:),chdtf(:,:)
REAL, ALLOCATABLE :: chdrt(:,:),chdrf(:,:)
INTEGER:: nd,lh,js,jr,kt,k
......@@ -63,7 +63,7 @@ CONTAINS
nd = atoms%ntypsy(SUM(atoms%neq(:n-1))+1)
ALLOCATE ( chlh(atoms%jmtd,0:sphhar%nlhd,jspins))
ALLOCATE ( ch_tmp(nsp,jspins) )
IF (l_grad) THEN
ALLOCATE(chdr(nsp,jspins),chdt(nsp,jspins),chdf(nsp,jspins),chdrr(nsp,jspins),&
chdtt(nsp,jspins),chdff(nsp,jspins),chdtf(nsp,jspins),chdrt(nsp,jspins),&
......@@ -81,22 +81,23 @@ CONTAINS
DO js = 1,jspins
DO jr = 1,atoms%jri(n)
chlh(jr,lh,js) = den%mt(jr,lh,n,js)/(atoms%rmsh(jr,n)*atoms%rmsh(jr,n))
chlh(jr,lh,js) = den_mt(jr,lh,js)/(atoms%rmsh(jr,n)*atoms%rmsh(jr,n))
ENDDO
IF (l_grad) CALL grdchlh(1,1,atoms%jri(n),atoms%dx(n),atoms%rmsh(1,n),&
chlh(1,lh,js),ndvgrd, chlhdr(1,lh,js),chlhdrr(1,lh,js))
ENDDO ! js
ENDDO ! lh
ch(:,:) = 0.0 ! charge density (on extended grid for all jr)
kt=0
DO jr = 1,atoms%jri(n)
ch_tmp(:,:) = 0.0 ! charge density (on extended grid for all jr)
! following are at points on jr-th sphere.
! generate the densities on an angular mesh
DO js = 1,jspins
DO lh = 0,sphhar%nlh(nd)
DO k = 1,nsp
ch(kt+k,js) = ch(kt+k,js) + ylh(k,lh,nd)*chlh(jr,lh,js)
ch_tmp(k,js) = ch_tmp(k,js) + ylh(k,lh,nd)*chlh(jr,lh,js)
ENDDO
ENDDO
ENDDO
......@@ -133,12 +134,12 @@ CONTAINS
CALL mkgylm(jspins,atoms%rmsh(jr,n),thet,nsp,&
ch(kt+1:,:),chdr,chdt,chdf,chdrr,chdtt,chdff,chdtf,chdrt,chdrf,grad,kt)
ch_tmp,chdr,chdt,chdf,chdrr,chdtt,chdff,chdtf,chdrt,chdrf,grad,kt)
ENDIF
!Set charge to minimum value
IF (PRESENT(ch)) ch(kt+1:kt+nsp,:)=MAX(ch_tmp(:nsp,:),d_15)
kt=kt+nsp
END DO
!Set charge to minimum value
ch(:,:)=MAX(ch(:,:),d_15)
END SUBROUTINE mt_to_grid
......@@ -149,7 +150,7 @@ CONTAINS
TYPE(t_sphhar),INTENT(IN):: sphhar
INTEGER,INTENT(IN) :: nsp,jspins,n
REAL,INTENT(IN) :: v_in(:,:)
REAL,INTENT(INOUT) :: vr(:,0:,:,:)
REAL,INTENT(INOUT) :: vr(:,0:,:)
REAL :: vpot(nsp),vlh
INTEGER :: js,kt,lh,jr,nd
......@@ -166,7 +167,7 @@ CONTAINS
!c through gauss integration
!
vlh=dot_PRODUCT(vpot(:),ylh(:nsp,lh,nd))
vr(jr,lh,n,js) = vr(jr,lh,n,js) + vlh
vr(jr,lh,js) = vr(jr,lh,js) + vlh
ENDDO ! lh
kt=kt+nsp
ENDDO ! jr
......
......@@ -43,7 +43,7 @@ CONTAINS
END SUBROUTINE init_pw_grid
SUBROUTINE pw_to_grid(xcpot,input,noco,stars,cell,den,rho,grad)
SUBROUTINE pw_to_grid(xcpot,jspins,l_noco,stars,cell,den_pw,grad,rho)
!.....------------------------------------------------------------------
!-------> abbreviations
!
......@@ -79,14 +79,14 @@ CONTAINS
USE m_types
IMPLICIT NONE
CLASS(t_xcpot),INTENT(IN) :: xcpot
TYPE(t_input),INTENT(IN) :: input
TYPE(t_noco),INTENT(IN) :: noco
INTEGER,INTENT(IN) :: jspins
LOGICAL,INTENT(IN) :: l_noco
TYPE(t_stars),INTENT(IN) :: stars
TYPE(t_cell),INTENT(IN) :: cell
TYPE(t_potden),INTENT(IN) :: den
REAL,ALLOCATABLE,INTENT(out) :: rho(:,:)
TYPE(t_gradients),INTENT(OUT) :: grad
COMPLEX,INTENT(IN) :: den_pw(:,:)
TYPE(t_gradients),INTENT(OUT) :: grad
REAL,ALLOCATABLE,INTENT(out),OPTIONAL :: rho(:,:)
INTEGER :: js,i,idm,ig,ndm,jdm
REAL :: rhotot
......@@ -100,42 +100,43 @@ CONTAINS
! Allocate arrays
ALLOCATE( bf3(0:ifftd-1))
IF (xcpot%is_gga()) THEN
ALLOCATE(rho(0:ifftxc3d-1,input%jspins))
ALLOCATE( ph_wrk(0:ifftxc3d-1),rhd1(0:ifftxc3d-1,input%jspins,3))
ALLOCATE( rhd2(0:ifftxc3d-1,input%jspins,6) )
IF (PRESENT(rho)) ALLOCATE(rho(0:ifftxc3d-1,jspins))
ALLOCATE( ph_wrk(0:ifftxc3d-1),rhd1(0:ifftxc3d-1,jspins,3))
ALLOCATE( rhd2(0:ifftxc3d-1,jspins,6) )
ELSE
ALLOCATE(rho(0:ifftd-1,input%jspins))
IF (PRESENT(rho)) ALLOCATE(rho(0:ifftd-1,jspins))
ENDIF
IF (noco%l_noco) THEN
IF (l_noco) THEN
ALLOCATE( mx(0:ifftxc3-1),my(0:ifftxc3-1),magmom(0:ifftxc3-1))
IF (xcpot%is_gga()) ALLOCATE(dmagmom(0:ifftxc3-1,3),ddmagmom(0:ifftxc3-1,3,3) )
END IF
!Put den%pw on grid and store into rho(:,1:2)
DO js=1,input%jspins
IF (xcpot%is_gga()) THEN
CALL fft3dxc(rho(0:,js),bf3, den%pw(:,js), stars%kxc1_fft,stars%kxc2_fft,stars%kxc3_fft,&
stars%nxc3_fft,stars%kmxxc_fft,+1, stars%igfft(0:,1),igxc_fft,stars%pgfft,stars%nstr)
ELSE
CALL fft3d(rho(0,js),bf3, den%pw(1,js), stars,+1)
ENDIF
END DO
IF (PRESENT(rho)) THEN
!Put den_pw on grid and store into rho(:,1:2)
DO js=1,jspins
IF (xcpot%is_gga()) THEN
CALL fft3dxc(rho(0:,js),bf3, den_pw(:,js), stars%kxc1_fft,stars%kxc2_fft,stars%kxc3_fft,&
stars%nxc3_fft,stars%kmxxc_fft,+1, stars%igfft(0:,1),igxc_fft,stars%pgfft,stars%nstr)
ELSE
CALL fft3d(rho(0,js),bf3, den_pw(:,js), stars,+1)
ENDIF
END DO
IF (noco%l_noco) THEN
! Get mx,my on real space grid and recalculate rho and magmom
IF (xcpot%is_gga()) THEN
CALL fft3dxc(mx,my, den%pw(:,3), stars%kxc1_fft,stars%kxc2_fft,stars%kxc3_fft,&
stars%nxc3_fft,stars%kmxxc_fft,+1, stars%igfft(0:,1),igxc_fft,stars%pgfft,stars%nstr)
ELSE
CALL fft3d(mx,my, den%pw(1,3), stars,+1)
IF (l_noco) THEN
! Get mx,my on real space grid and recalculate rho and magmom
IF (xcpot%is_gga()) THEN
CALL fft3dxc(mx,my, den_pw(:,3), stars%kxc1_fft,stars%kxc2_fft,stars%kxc3_fft,&
stars%nxc3_fft,stars%kmxxc_fft,+1, stars%igfft(0:,1),igxc_fft,stars%pgfft,stars%nstr)
ELSE
CALL fft3d(mx,my, den_pw(:,3), stars,+1)
ENDIF
DO i=0,SIZE(rho,1)-1
rhotot= 0.5*( rho(i,1) + rho(i,2) )
magmom(i)= SQRT( (0.5*(rho(i,1)-rho(i,2)))**2 + mx(i)**2 + my(i)**2 )
rho(i,1)= rhotot+magmom(i)
rho(i,2)= rhotot-magmom(i)
END DO
ENDIF
DO i=0,SIZE(rho,1)-1
rhotot= 0.5*( rho(i,1) + rho(i,2) )
magmom(i)= SQRT( (0.5*(rho(i,1)-rho(i,2)))**2 + mx(i)**2 + my(i)**2 )
rho(i,1)= rhotot+magmom(i)
rho(i,2)= rhotot-magmom(i)
END DO
ENDIF
IF (xcpot%is_gga()) THEN
! In collinear calculations all derivatives are calculated in g-spce,
......@@ -145,22 +146,22 @@ CONTAINS
!
! ph_wrk: exp(i*(g_x,g_y,g_z)*tau) * g_(x,y,z).
ALLOCATE(cqpw(stars%ng3,input%jspins))
ALLOCATE(cqpw(stars%ng3,jspins))
cqpw(:,:)= ci*den%pw(:,:)
cqpw(:,:)= ci*den_pw(:,:)
DO idm=1,3
DO ig = 0 , stars%kmxxc_fft - 1
ph_wrk(ig) = stars%pgfft(ig) * gxc_fft(ig,idm)
END DO
DO js=1,input%jspins
DO js=1,jspins
CALL fft3dxc(rhd1(0:,js,idm),bf3, cqpw(:,js), stars%kxc1_fft,stars%kxc2_fft,&
stars%kxc3_fft,stars%nxc3_fft,stars%kmxxc_fft,+1, stars%igfft(0:,1),igxc_fft,ph_wrk,stars%nstr)
END DO
END DO
IF (noco%l_noco) THEN
IF (l_noco) THEN
CALL grdrsis(magmom,cell,stars%kxc1_fft,stars%kxc2_fft,stars%kxc3_fft,dmagmom )
......@@ -177,7 +178,7 @@ CONTAINS
!
! ph_wrk: exp(i*(g_x,g_y,g_z)*tau) * g_(x,y,z) * g_(x,y,z)
cqpw(:,:)= -den%pw(:,:)
cqpw(:,:)= -den_pw(:,:)
ndm = 0
DO idm = 1,3
......@@ -187,7 +188,7 @@ CONTAINS
ph_wrk(ig) = stars%pgfft(ig)*gxc_fft(ig,idm)*gxc_fft(ig,jdm)
ENDDO
DO js=1,input%jspins
DO js=1,jspins
CALL fft3dxc(rhd2(0:,js,ndm),bf3, cqpw(:,js), stars%kxc1_fft,stars%kxc2_fft,&
stars%kxc3_fft,stars%nxc3_fft,stars%kmxxc_fft,+1, stars%igfft(0:,1),igxc_fft,ph_wrk,stars%nstr)
END DO
......@@ -196,7 +197,7 @@ CONTAINS
DEALLOCATE(cqpw)
IF (noco%l_noco) THEN
IF (l_noco) THEN
DO idm = 1,3
CALL grdrsis(dmagmom(0,idm),cell,stars%kxc1_fft,stars%kxc2_fft,stars%kxc3_fft,ddmagmom(0,1,idm) )
END DO
......@@ -212,22 +213,28 @@ CONTAINS
ENDDO !jdm
ENDDO !idm
END IF
CALL xcpot%alloc_gradients(ifftxc3d,input%jspins,grad)
CALL xcpot%alloc_gradients(ifftxc3d,jspins,grad)
!
! calculate the quantities such as abs(grad(rho)),.. used in
! evaluating the gradient contributions to potential and energy.
!
CALL mkgxyz3 (ifftxc3d,input%jspins,ifftxc3,input%jspins,rho, rhd1(0,1,1),rhd1(0,1,2),rhd1(0,1,3),&
rhd2(0,1,1),rhd2(0,1,3),rhd2(0,1,6), rhd2(0,1,5),rhd2(0,1,4),rhd2(0,1,2), grad)
IF (PRESENT(rho)) THEN
CALL mkgxyz3 (rho,rhd1(0:,:,1),rhd1(0:,:,2),rhd1(0:,:,3),&
rhd2(0:,:,1),rhd2(0:,:,3),rhd2(0:,:,6), rhd2(0:,:,5),rhd2(0:,:,4),rhd2(0:,:,2),grad)
ELSE
!Dummy rho (only possible if grad is used for libxc mode)
CALL mkgxyz3 (RESHAPE((/0.0/),(/1,1/)),rhd1(0:,:,1),rhd1(0:,:,2),rhd1(0:,:,3),&
rhd2(0:,:,1),rhd2(0:,:,3),rhd2(0:,:,6), rhd2(0:,:,5),rhd2(0:,:,4),rhd2(0:,:,2),grad)
END IF
ENDIF
rho(:,:)=MAX(rho(:,:),d_15)
IF (PRESENT(rho)) rho(:,:)=MAX(rho(:,:),d_15)
END SUBROUTINE pw_to_grid
SUBROUTINE pw_from_grid(xcpot,stars,l_pw_w,v_in,v_out)
SUBROUTINE pw_from_grid(xcpot,stars,l_pw_w,v_in,v_out_pw,v_out_pw_w)
USE m_fft3d
USE m_fft3dxc
USE m_types
......@@ -236,7 +243,8 @@ CONTAINS
TYPE(t_stars),INTENT(IN) :: stars
REAL,INTENT(INOUT) :: v_in(0:,:)
LOGICAL,INTENT(in) :: l_pw_w
TYPE(t_potden),INTENT(INOUT) :: v_out
COMPLEX,INTENT(INOUT) :: v_out_pw(:,:)
COMPLEX,INTENT(INOUT),OPTIONAL::v_out_pw_w(:,:)
INTEGER :: js,k,i
......@@ -254,7 +262,7 @@ CONTAINS
CALL fft3d(v_in(0:,js),bf3, fg3, stars,-1)
ENDIF
DO k = 1,MERGE(stars%nxc3_fft,stars%ng3,xcpot%is_gga())
v_out%pw(k,js) = v_out%pw(k,js) + fg3(k)
v_out_pw(k,js) = v_out_pw(k,js) + fg3(k)
ENDDO
IF (l_pw_w) THEN
......@@ -277,7 +285,7 @@ CONTAINS
!----> add to warped coulomb potential
!
DO k = 1,stars%ng3
v_out%pw_w(k,js) = v_out%pw_w(k,js) + fg3(k)
v_out_pw_w(k,js) = v_out_pw_w(k,js) + fg3(k)
ENDDO
ENDIF
END DO
......
......@@ -31,6 +31,8 @@ CONTAINS
! ******************************************************************
USE m_pw_tofrom_grid
USE m_types
USE m_types_xcpot_libxc
USE m_libxc_postprocess_gga
IMPLICIT NONE
CLASS(t_xcpot),INTENT(IN) :: xcpot
......@@ -49,20 +51,26 @@ CONTAINS
CALL init_pw_grid(xcpot,stars,sym,cell)
!Put the charge on the grid, in GGA case also calculate gradients
CALL pw_to_grid(xcpot,input,noco,stars,cell,den,rho,grad)