Commit 1018338f authored by Daniel Wortmann's avatar Daniel Wortmann

Merge branch 'xc-pot-refactor' into 'develop'

Merge libxc branch as GGA seems to be approximately working...

See merge request fleur/fleur!9
parents 295f78fc c941f55d
......@@ -82,6 +82,7 @@
! arltv(i) : length of reciprical lattice vector along
! direction (i)
!
IF (.NOT.xcpot%is_gga()) xcpot%gmaxxc=stars%gmax
WRITE (6,'('' gmaxxc should be: 2*kmax <= gmaxxc <= gmax '')')
IF ( abs( xcpot%gmaxxc - stars%gmax ) .le. 10.0**(-6) ) THEN
WRITE (6,'('' concerning memory, you may want to choose'',&
......
......@@ -20,7 +20,7 @@ CONTAINS
!! TE_EXC : charge density-ex-corr.energy density integral
SUBROUTINE vgen(hybrid,field,input,xcpot,DIMENSION,atoms,sphhar,stars,vacuum,sym,&
obsolete,cell,oneD,sliceplot,mpi,results,noco,den,vTot,vXC,vCoul)
obsolete,cell,oneD,sliceplot,mpi,results,noco,den,vTot,vx,vCoul)
USE m_rotate_int_den_to_local
USE m_bfield
......@@ -33,6 +33,7 @@ CONTAINS
#endif
IMPLICIT NONE
TYPE(t_results), INTENT(INOUT) :: results
CLASS(t_xcpot), INTENT(IN) :: xcpot
TYPE(t_hybrid), INTENT(IN) :: hybrid
......@@ -51,26 +52,29 @@ CONTAINS
TYPE(t_sphhar), INTENT(IN) :: sphhar
TYPE(t_atoms), INTENT(IN) :: atoms
TYPE(t_potden), INTENT(INOUT) :: den
TYPE(t_potden), INTENT(INOUT) :: vTot,vXC,vCoul
TYPE(t_potden), INTENT(INOUT) :: vTot,vx,vCoul
TYPE(t_potden) :: workden,denRot
if (mpi%irank==0) WRITE (6,FMT=8000)
8000 FORMAT (/,/,t10,' p o t e n t i a l g e n e r a t o r',/)
CALL vTot%resetPotDen()
CALL vCoul%resetPotDen()
CALL vXC%resetPotDen()
ALLOCATE(vXC%pw_w,vTot%pw_w,mold=vTot%pw)
CALL vx%resetPotDen()
ALLOCATE(vx%pw_w,vTot%pw_w,mold=vTot%pw)
ALLOCATE(vCoul%pw_w(SIZE(den%pw,1),1))
CALL workDen%init(stars,atoms,sphhar,vacuum,input%jspins,noco%l_noco,0)
!sum up both spins in den into workden
CALL den%sum_both_spin(workden)
CALL vgen_coulomb(1,mpi,dimension,oneD,input,field,vacuum,sym,stars,cell,sphhar,atoms,workden,vCoul,results)
CALL vCoul%copy_both_spin(vTot)
IF (noco%l_noco) THEN
......@@ -79,19 +83,21 @@ CONTAINS
CALL rotate_int_den_to_local(dimension,sym,stars,atoms,sphhar,vacuum,cell,input,noco,oneD,denRot)
ENDIF
CALL vgen_xcpot(hybrid,input,xcpot,dimension,atoms,sphhar,stars,vacuum,sym,&
obsolete,cell,oneD,sliceplot,mpi,noco,den,denRot,vTot,vXC,results)
obsolete,cell,oneD,sliceplot,mpi,noco,den,denRot,vTot,vx,results)
!ToDo, check if this is needed for more potentials as well...
CALL vgen_finalize(atoms,stars,vacuum,sym,noco,input,vTot,denRot)
DEALLOCATE(vcoul%pw_w,vXC%pw_w)
DEALLOCATE(vcoul%pw_w,vx%pw_w)
CALL bfield(input,noco,atoms,field,vTot)
#ifdef CPP_MPI
CALL mpi_bc_potden(mpi,stars,sphhar,atoms,input,vacuum,oneD,noco,vTot)
CALL mpi_bc_potden(mpi,stars,sphhar,atoms,input,vacuum,oneD,noco,vCoul)
CALL mpi_bc_potden(mpi,stars,sphhar,atoms,input,vacuum,oneD,noco,vXC)
CALL mpi_bc_potden(mpi,stars,sphhar,atoms,input,vacuum,oneD,noco,vx)
#endif
END SUBROUTINE vgen
......
......@@ -39,6 +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
......@@ -63,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
......@@ -87,8 +89,14 @@ CONTAINS
SUBROUTINE xcpot_alloc_gradients(ngrid,jspins,grad)
INTEGER, INTENT (IN) :: jspins,ngrid
TYPE(t_gradients),INTENT(OUT):: grad
TYPE(t_gradients),INTENT(INOUT):: grad
IF (allocated(grad%agrt)) THEN
DEALLOCATE(grad%agrt,grad%agru,grad%agrd)
DEALLOCATE(grad%g2ru,grad%g2rd,grad%gggrt)
DEALLOCATE(grad%gggru,grad%gzgr,grad%g2rt)
DEALLOCATE(grad%gggrd,grad%grgru,grad%grgrd)
ENDIF
!For the in-build xc-pots
ALLOCATE(grad%agrt(ngrid),grad%agru(ngrid),grad%agrd(ngrid))
ALLOCATE(grad%g2ru(ngrid),grad%g2rd(ngrid),grad%gggrt(ngrid))
......
......@@ -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
......
......@@ -44,7 +44,15 @@ CONTAINS
xcpot%jspins=jspins
xcpot%func_id_x=id_x
xcpot%func_id_c=id_c
if(xcpot%func_id_x == 0 .or. xcpot%func_id_c == 0) then
CALL judft_error("LibXC exchange- and correlation-function indicies need to be set"&
,hint='Try this: ' // ACHAR(10) //&
'<xcFunctional name="libxc" relativisticCorrections="F">' // ACHAR(10) //&
' <libXC exchange="1" correlation="1" /> ' // ACHAR(10) //&
'</xcFunctional> ')
endif
IF (jspins==1) THEN
CALL xc_f03_func_init(xcpot%xc_func_x, xcpot%func_id_x, XC_UNPOLARIZED)
IF (xcpot%func_id_c>0) CALL xc_f03_func_init(xcpot%xc_func_c, xcpot%func_id_c, XC_UNPOLARIZED)
......@@ -95,7 +103,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,23 +112,23 @@ 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(vsigma,mold=grad%vsigma)
!where(abs(grad%sigma)<1E-9) grad%sigma=1E-9
CALL xc_f03_gga_vxc(xcpot%xc_func_x, SIZE(rh,1), TRANSPOSE(rh),grad%sigma,vx_tmp,vsigma)
IF (xcpot%func_id_c>0) THEN
ALLOCATE(vsigma(SIZE(grad%sigma)))
CALL xc_f03_gga_vxc(xcpot%xc_func_c, SIZE(rh,1), TRANSPOSE(rh),grad%sigma,vxc_tmp,vsigma)
drdsigma=drdsigma+vsigma
CALL xc_f03_gga_vxc(xcpot%xc_func_c, SIZE(rh,1), TRANSPOSE(rh),grad%sigma,vxc_tmp,grad%vsigma)
grad%vsigma=grad%vsigma+vsigma
vxc_tmp=vxc_tmp+vx_tmp
ELSE
vxc_tmp=vx_tmp
ENDIF
ELSE !LDA potentials
CALL xc_f03_lda_vxc(xcpot%xc_func_x, SIZE(rh,1), TRANSPOSE(rh), vx_tmp)
......@@ -169,9 +177,14 @@ CONTAINS
SUBROUTINE xcpot_alloc_gradients(ngrid,jspins,grad)
INTEGER, INTENT (IN) :: jspins,ngrid
TYPE(t_gradients),INTENT(OUT):: grad
TYPE(t_gradients),INTENT(INOUT):: grad
!For libxc we only need the sigma array...
IF (ALLOCATED(grad%sigma)) DEALLOCATE(grad%sigma,grad%gr,grad%laplace,grad%vsigma)
ALLOCATE(grad%sigma(MERGE(1,3,jspins==1),ngrid))
ALLOCATE(grad%gr(3,ngrid,jspins))
ALLOCATE(grad%laplace(ngrid,jspins))
ALLOCATE(grad%vsigma,mold=grad%sigma)
END SUBROUTINE xcpot_alloc_gradients
......
......@@ -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,8 +15,11 @@ 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
vgen/int_nv.F90
vgen/lhglptg.f90
vgen/lhglpts.f90
......@@ -32,12 +33,11 @@ vgen/prp_xcfft_map.f90
vgen/psqpw.F90
vgen/rotate_int_den_to_local.F90
vgen/vintcz.f90
vgen/visxc.f90
vgen/visxcg.f90
vgen/vis_xc.F90
vgen/pw_tofrom_grid.F90
vgen/vmatgen.f90
vgen/vmts.F90
vgen/vmtxc.f90
vgen/vmtxcg.F90
vgen/vmt_xc.F90
vgen/vvac.f90
vgen/vvacis.f90
vgen/vvacxc.f90
......
This diff is collapsed.
......@@ -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.
!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! 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_mt_tofrom_grid
USE m_types
PRIVATE
REAL,PARAMETER :: d_15 = 1.e-15
INTEGER,PARAMETER :: ndvgrd=6 ! this should be consistent across GGA derivative routines
REAL, ALLOCATABLE :: ylh(:,:,:),ylht(:,:,:),ylhtt(:,:,:)
REAL, ALLOCATABLE :: ylhf(:,:,:),ylhff(:,:,:),ylhtf(:,:,:)
REAL, ALLOCATABLE :: wt(:),rx(:,:),thet(:)
PUBLIC :: init_mt_grid,mt_to_grid,mt_from_grid,finish_mt_grid
CONTAINS
SUBROUTINE init_mt_grid(nsp,jspins,atoms,sphhar,xcpot,sym,l_grad)
USE m_gaussp
USE m_lhglptg
USE m_lhglpts
IMPLICIT NONE
INTEGER,INTENT(IN) :: nsp,jspins
TYPE(t_atoms),INTENT(IN) :: atoms
TYPE(t_sphhar),INTENT(IN) :: sphhar
CLASS(t_xcpot),INTENT(IN) :: xcpot
TYPE(t_sym),INTENT(IN) :: sym
LOGICAL,INTENT(IN) :: l_grad
! generate nspd points on a sherical shell with radius 1.0
! angular mesh equidistant in phi,
! theta are zeros of the legendre polynomials
ALLOCATE(wt(nsp),rx(3,nsp),thet(nsp))
CALL gaussp(atoms%lmaxd, rx,wt)
! generate the lattice harmonics on the angular mesh
ALLOCATE ( ylh(nsp,0:sphhar%nlhd,sphhar%ntypsd))
IF (l_grad) ALLOCATE(ylht,ylhtt,ylhf,ylhff,ylhtf,MOLD=ylh )
IF (l_grad) THEN
CALL lhglptg(sphhar,atoms,rx,nsp,xcpot,sym,&
ylh,thet,ylht,ylhtt,ylhf,ylhff,ylhtf)
ELSE
CALL lhglpts( sphhar,atoms, rx,nsp, sym, ylh)
END IF
END SUBROUTINE init_mt_grid
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
REAL,INTENT(IN) :: den_mt(:,0:,:)
INTEGER,INTENT(IN) :: n,jspins,nsp
LOGICAL,INTENT(IN) :: l_grad
REAL,INTENT(OUT),OPTIONAL :: ch(:,:)
TYPE(t_gradients),INTENT(INOUT):: grad
REAL, ALLOCATABLE :: chlh(:,:,:),chlhdr(:,:,:),chlhdrr(:,:,:)
REAL, ALLOCATABLE :: chdr(:,:),chdt(:,:),chdf(:,:),ch_tmp(:,:)
REAL, ALLOCATABLE :: chdrr(:,:),chdtt(:,:),chdff(:,:),chdtf(:,:)
REAL, ALLOCATABLE :: chdrt(:,:),chdrf(:,:)
INTEGER:: nd,lh,js,jr,kt,k
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),&
chdrf(nsp,jspins) )
ALLOCATE (chlhdr(atoms%jmtd,0:sphhar%nlhd,jspins))
ALLOCATE (chlhdrr(atoms%jmtd,0:sphhar%nlhd,jspins))
ENDIF
DO lh = 0,sphhar%nlh(nd)
! calculates gradients of radial charge densities of l=> 0.
! rho*ylh/r**2 is charge density. chlh=rho/r**2.
! charge density=sum(chlh*ylh).
! chlhdr=d(chlh)/dr, chlhdrr=dd(chlh)/drr.
DO js = 1,jspins
DO jr = 1,atoms%jri(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
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_tmp(k,js) = ch_tmp(k,js) + ylh(k,lh,nd)*chlh(jr,lh,js)
ENDDO
ENDDO
ENDDO
IF (l_grad) THEN
chdr(:,:) = 0.0 ! d(ch)/dr