Skip to content

GitLab

fleur
fleur
Commit cbac3b75 authored by Matthias Redies's avatar Matthias Redies
Browse files
Options

put changes on branch

parent 55719b61
Hide whitespace changes
Inline Side-by-side
Showing with 453 additions and 119 deletions
cdn_mt/cdncore.F90
View file @ cbac3b75
......@@ -9,7 +9,7 @@ MODULE m_cdncore
CONTAINS
SUBROUTINE cdncore(mpi,dimension,oneD,input,vacuum,noco,sym,&
stars,cell,sphhar,atoms,vTot,outDen,moments,results)
stars,cell,sphhar,atoms,vTot,outDen,moments,results, EnergyDen)
USE m_constants
USE m_cdn_io
......@@ -27,21 +27,22 @@ SUBROUTINE cdncore(mpi,dimension,oneD,input,vacuum,noco,sym,&
IMPLICIT NONE
TYPE(t_mpi), INTENT(IN) :: mpi
TYPE(t_dimension), INTENT(IN) :: dimension
TYPE(t_oneD), INTENT(IN) :: oneD
TYPE(t_input), INTENT(IN) :: input
TYPE(t_vacuum), INTENT(IN) :: vacuum
TYPE(t_noco), INTENT(IN) :: noco
TYPE(t_sym), INTENT(IN) :: sym
TYPE(t_stars), INTENT(IN) :: stars
TYPE(t_cell), INTENT(IN) :: cell
TYPE(t_sphhar), INTENT(IN) :: sphhar
TYPE(t_atoms), INTENT(IN) :: atoms
TYPE(t_potden), INTENT(IN) :: vTot
TYPE(t_potden), INTENT(INOUT) :: outDen
TYPE(t_moments), INTENT(INOUT) :: moments
TYPE(t_results), INTENT(INOUT) :: results
TYPE(t_mpi), INTENT(IN) :: mpi
TYPE(t_dimension), INTENT(IN) :: dimension
TYPE(t_oneD), INTENT(IN) :: oneD
TYPE(t_input), INTENT(IN) :: input
TYPE(t_vacuum), INTENT(IN) :: vacuum
TYPE(t_noco), INTENT(IN) :: noco
TYPE(t_sym), INTENT(IN) :: sym
TYPE(t_stars), INTENT(IN) :: stars
TYPE(t_cell), INTENT(IN) :: cell
TYPE(t_sphhar), INTENT(IN) :: sphhar
TYPE(t_atoms), INTENT(IN) :: atoms
TYPE(t_potden), INTENT(IN) :: vTot
TYPE(t_potden), INTENT(INOUT) :: outDen
TYPE(t_moments), INTENT(INOUT) :: moments
TYPE(t_results), INTENT(INOUT) :: results
TYPE(t_potden), INTENT(INOUT), OPTIONAL :: EnergyDen
INTEGER :: jspin, n, iType
REAL :: seig, rhoint, momint
......@@ -53,7 +54,7 @@ SUBROUTINE cdncore(mpi,dimension,oneD,input,vacuum,noco,sym,&
REAL :: rhTemp(dimension%msh,atoms%ntype,dimension%jspd)
results%seigc = 0.0
IF (mpi%irank.EQ.0) THEN
IF (mpi%irank==0) THEN
DO jspin = 1,input%jspins
DO n = 1,atoms%ntype
moments%svdn(n,jspin) = outDen%mt(1,0,n,jspin) / (sfp_const*atoms%rmsh(1,n)*atoms%rmsh(1,n))
......@@ -61,10 +62,10 @@ SUBROUTINE cdncore(mpi,dimension,oneD,input,vacuum,noco,sym,&
END DO
END IF
IF (input%kcrel.EQ.0) THEN
IF (input%kcrel==0) THEN
! Generate input file ecore for subsequent GW calculation
! 11.2.2004 Arno Schindlmayr
IF ((input%gw.eq.1 .or. input%gw.eq.3).AND.(mpi%irank.EQ.0)) THEN
IF ((input%gw==1 .or. input%gw==3).AND.(mpi%irank==0)) THEN
OPEN (15,file='ecore',status='unknown', action='write',form='unformatted')
END IF
......@@ -72,7 +73,7 @@ SUBROUTINE cdncore(mpi,dimension,oneD,input,vacuum,noco,sym,&
tec = 0.0
qint = 0.0
IF (input%frcor) THEN
IF (mpi%irank.EQ.0) THEN
IF (mpi%irank==0) THEN
CALL readCoreDensity(input,atoms,dimension,rh,tec,qint)
END IF
#ifdef CPP_MPI
......@@ -82,51 +83,55 @@ SUBROUTINE cdncore(mpi,dimension,oneD,input,vacuum,noco,sym,&
END IF
!add in core density
IF (mpi%irank.EQ.0) THEN
IF (input%kcrel.EQ.0) THEN
IF (mpi%irank==0) THEN
IF (input%kcrel==0) THEN
DO jspin = 1,input%jspins
CALL cored(input,jspin,atoms,outDen%mt,dimension,sphhar,vTot%mt(:,0,:,jspin), qint,rh,tec,seig)
CALL cored(input,jspin,atoms,outDen%mt,dimension,sphhar,vTot%mt(:,0,:,jspin), qint,rh ,tec,seig, EnergyDen%mt)
rhTemp(:,:,jspin) = rh(:,:,jspin)
results%seigc = results%seigc + seig
END DO
ELSE
IF(PRESENT(EnergyDen)) call juDFT_error("Energyden not implemented for relativistic")
CALL coredr(input,atoms,seig, outDen%mt,dimension,sphhar,vTot%mt(:,0,:,:),qint,rh)
results%seigc = results%seigc + seig
END IF
END IF
DO jspin = 1,input%jspins
IF (mpi%irank.EQ.0) THEN
IF (mpi%irank==0) THEN
DO n = 1,atoms%ntype
moments%stdn(n,jspin) = outDen%mt(1,0,n,jspin) / (sfp_const*atoms%rmsh(1,n)*atoms%rmsh(1,n))
END DO
END IF
IF ((noco%l_noco).AND.(mpi%irank.EQ.0)) THEN
IF (jspin.EQ.2) THEN
IF ((noco%l_noco).AND.(mpi%irank==0)) THEN
IF (jspin==2) THEN
IF(PRESENT(EnergyDen)) call juDFT_error("Energyden not implemented for noco")
!pk non-collinear (start)
!add the coretail-charge to the constant interstitial
!charge (star 0), taking into account the direction of
!magnetisation of this atom
DO iType = 1,atoms%ntype
rhoint = (qint(iType,1) + qint(iType,2)) /cell%volint/input%jspins/2.0
momint = (qint(iType,1) - qint(iType,2)) /cell%volint/input%jspins/2.0
rhoint = (qint(iType,1) + qint(iType,2)) /(cell%volint * input%jspins * 2.0)
momint = (qint(iType,1) - qint(iType,2)) /(cell%volint * input%jspins * 2.0)
!rho_11
outDen%pw(1,1) = outDen%pw(1,1) + rhoint + momint*cos(noco%beta(iType))
!rho_22
outDen%pw(1,2) = outDen%pw(1,2) + rhoint - momint*cos(noco%beta(iType))
!real part rho_21
outDen%pw(1,3) = outDen%pw(1,3) + cmplx(0.5*momint *cos(noco%alph(iType))*sin(noco%beta(iType)),0.0)
outDen%pw(1,3) = outDen%pw(1,3) + cmplx( 0.5*momint *cos(noco%alph(iType))*sin(noco%beta(iType)),&
!imaginary part rho_21
outDen%pw(1,3) = outDen%pw(1,3) + cmplx(0.0,-0.5*momint *sin(noco%alph(iType))*sin(noco%beta(iType)))
-0.5*momint *sin(noco%alph(iType))*sin(noco%beta(iType)))
END DO
!pk non-collinear (end)
END IF
ELSE
IF (input%ctail) THEN
IF(PRESENT(EnergyDen)) call juDFT_error("Energyden not implemented for ctail")
!+gu hope this works as well
CALL cdnovlp(mpi,sphhar,stars,atoms,sym,dimension,vacuum,&
cell,input,oneD,l_st,jspin,rh(:,:,jspin),&
outDen%pw,outDen%vacxy,outDen%mt,outDen%vacz)
ELSE IF (mpi%irank.EQ.0) THEN
ELSE IF (mpi%irank==0) THEN
DO iType = 1,atoms%ntype
outDen%pw(1,jspin) = outDen%pw(1,jspin) + qint(iType,jspin) / (input%jspins * cell%volint)
END DO
......@@ -134,11 +139,11 @@ SUBROUTINE cdncore(mpi,dimension,oneD,input,vacuum,noco,sym,&
END IF
END DO
IF (input%kcrel.EQ.0) THEN
IF (mpi%irank.EQ.0) THEN
IF (input%kcrel==0) THEN
IF (mpi%irank==0) THEN
CALL writeCoreDensity(input,atoms,dimension,rhTemp,tec,qint)
END IF
IF ((input%gw.eq.1 .or. input%gw.eq.3).AND.(mpi%irank.EQ.0)) CLOSE(15)
IF ((input%gw==1 .or. input%gw==3).AND.(mpi%irank==0)) CLOSE(15)
END IF
END SUBROUTINE cdncore
......
core/cored.F90
View file @ cbac3b75
MODULE m_cored
CONTAINS
SUBROUTINE cored(&
& input,jspin,atoms,&
& rho,DIMENSION,&
& sphhar,&
& vr,&
& qint,rhc,tec,seig)
SUBROUTINE cored(input, jspin, atoms, rho, DIMENSION, sphhar, vr, qint, rhc, tec, seig, EnergyDen)
! *******************************************************
! ***** set up the core densities for compounds. *****
! ***** d.d.koelling *****
......@@ -29,20 +23,22 @@ CONTAINS
REAL, INTENT (OUT) :: seig
! ..
! .. Array Arguments ..
REAL, INTENT(IN) :: vr(atoms%jmtd,atoms%ntype)
REAL, INTENT(INOUT) :: rho(atoms%jmtd,0:sphhar%nlhd,atoms%ntype,DIMENSION%jspd)
REAL, INTENT(INOUT) :: rhc(DIMENSION%msh,atoms%ntype,DIMENSION%jspd)
REAL, INTENT(INOUT) :: qint(atoms%ntype,DIMENSION%jspd)
REAL, INTENT(INOUT) :: tec(atoms%ntype,DIMENSION%jspd)
REAL, INTENT(IN) :: vr(atoms%jmtd,atoms%ntype)
REAL, INTENT(INOUT) :: rho(atoms%jmtd,0:sphhar%nlhd,atoms%ntype,DIMENSION%jspd)
REAL, INTENT(INOUT) :: rhc(DIMENSION%msh,atoms%ntype,DIMENSION%jspd)
REAL, INTENT(INOUT) :: qint(atoms%ntype,DIMENSION%jspd)
REAL, INTENT(INOUT) :: tec(atoms%ntype,DIMENSION%jspd)
REAL, INTENT(INOUT), OPTIONAL :: EnergyDen(atoms%jmtd,0:sphhar%nlhd,atoms%ntype,DIMENSION%jspd)
! ..
! .. Local Scalars ..
REAL e,fj,fl,fn,q,rad,rhos,rhs,sea,sume,t2
REAL d,dxx,rn,rnot,z,t1,rr,r,lambd,c,bmu,weight
REAL eig,fj,fl,fn,q,rad,rhos,rhs,sea,sume,t2
REAL d,dxx,rn,rnot,z,t1,rr,r,lambd,c,bmu,weight, aux_weight
INTEGER i,j,jatom,korb,n,ncmsh,nm,nm1,nst ,l,ierr
! ..
! .. Local Arrays ..
REAL rhcs(DIMENSION%msh),rhoc(DIMENSION%msh),rhoss(DIMENSION%msh),vrd(DIMENSION%msh),f(0:3)
REAL rhcs_aux(DIMENSION%msh), rhoss_aux(DIMENSION%msh) !> quantities for energy density calculations
REAL occ(DIMENSION%nstd),a(DIMENSION%msh),b(DIMENSION%msh),ain(DIMENSION%msh),ahelp(DIMENSION%msh)
REAL occ_h(DIMENSION%nstd,2)
INTEGER kappa(DIMENSION%nstd),nprnc(DIMENSION%nstd)
......@@ -99,7 +95,7 @@ CONTAINS
WRITE (6,FMT=8000) z,rnot,dxx,atoms%jri(jatom)
WRITE (16,FMT=8000) z,rnot,dxx,atoms%jri(jatom)
DO j = 1,atoms%jri(jatom)
rhoss(j) = 0.
rhoss(j) = 0.0
vrd(j) = vr(j,jatom)
ENDDO
!
......@@ -137,23 +133,35 @@ CONTAINS
IF (occ(korb) /= 0.0) THEN
fn = nprnc(korb)
fj = iabs(kappa(korb)) - .5e0
weight = 2*fj + 1.e0
IF (bmu > 99.) weight = occ(korb)
fl = fj + (.5e0)*isign(1,kappa(korb))
e = -2* (z/ (fn+fl))**2
CALL differ(fn,fl,fj,c,z,dxx,rnot,rn,d,ncmsh,vrd, e, a,b,ierr)
stateEnergies(korb) = e
WRITE (6,FMT=8010) fn,fl,fj,e,weight
WRITE (16,FMT=8010) fn,fl,fj,e,weight
eig = -2* (z/ (fn+fl))**2
CALL differ(fn,fl,fj,c,z,dxx,rnot,rn,d,ncmsh,vrd, eig, a,b,ierr)
stateEnergies(korb) = eig
WRITE (6,FMT=8010) fn,fl,fj,eig,weight
WRITE (16,FMT=8010) fn,fl,fj,eig,weight
IF (ierr/=0) CALL juDFT_error("error in core-level routine" ,calledby ="cored")
IF (input%gw==1 .OR. input%gw==3) WRITE (15) NINT(fl),weight,e,&
IF (input%gw==1 .OR. input%gw==3) WRITE (15) NINT(fl),weight,eig,&
a(1:atoms%jri(jatom)),b(1:atoms%jri(jatom))
sume = sume + weight*e/input%jspins
sume = sume + weight*eig/input%jspins
DO j = 1,ncmsh
rhcs(j) = weight* (a(j)**2+b(j)**2)
rhcs(j) = weight* (a(j)**2+b(j)**2)
rhoss(j) = rhoss(j) + rhcs(j)
ENDDO
IF(present(EnergyDen)) THEN
rhoss_aux = rhoss
DO j = 1,ncmsh
! for energy density we want to multiply the weights
! with the eigenenergies
rhoss_aux(j) = rhoss_aux(j) + (rhcs(j) * eig)
ENDDO
ENDIF
ENDIF
ENDDO
......@@ -165,6 +173,14 @@ CONTAINS
rho(j,0,jatom,jspin) = rho(j,0,jatom,jspin) + rhoc(j)/sfp_const
ENDDO
IF(present(EnergyDen)) then
DO j = 1,nm
rhoc(j) = rhoss(j)/input%jspins
EnergyDen(j,0,jatom,jspin) = EnergyDen(j,0,jatom,jspin) &
+ rhoss_aux(j) /(input%jspins * sfp_const)
ENDDO
ENDIF
rhc(1:ncmsh,jatom,jspin) = rhoss(1:ncmsh) / input%jspins
rhc(ncmsh+1:DIMENSION%msh,jatom,jspin) = 0.0
......
types/types_xcpot_libxc.F90
View file @ cbac3b75
......@@ -12,41 +12,54 @@ MODULE m_types_xcpot_libxc
USE m_types_xcpot
USE m_judft
IMPLICIT NONE
PRIVATE
PRIVATE :: write_xc_info
TYPE,EXTENDS(t_xcpot):: t_xcpot_libxc
#ifdef CPP_LIBXC
TYPE(xc_f03_func_t) :: xc_func_x,xc_func_c
TYPE(xc_f03_func_info_t) :: xc_info_x,xc_info_c
TYPE(xc_f03_func_t) :: vxc_func_x, vxc_func_c
TYPE(xc_f03_func_t) :: exc_func_x, exc_func_c
#endif
INTEGER :: func_id_c,func_id_x,jspins
INTEGER :: func_vxc_id_c, func_vxc_id_x !> functionals to be used for potential & density convergence
INTEGER :: func_exc_id_c, func_exc_id_x !> functionals to be used in exc- & totale-calculations
INTEGER :: jspins
CONTAINS
PROCEDURE :: is_gga=>xcpot_is_gga
PROCEDURE :: is_MetaGGA=>xcpot_is_MetaGGA
PROCEDURE :: is_hybrid=>xcpot_is_hybrid
PROCEDURE :: get_exchange_weight=>xcpot_get_exchange_weight
PROCEDURE :: get_vxc=>xcpot_get_vxc
PROCEDURE :: get_exc=>xcpot_get_exc
PROCEDURE,NOPASS :: alloc_gradients=>xcpot_alloc_gradients
!Not overloeaded...
PROCEDURE :: init=>xcpot_init
PROCEDURE :: is_gga => xcpot_is_gga
PROCEDURE :: is_MetaGGA => xcpot_is_MetaGGA
PROCEDURE :: is_hybrid => xcpot_is_hybrid
PROCEDURE :: get_exchange_weight => xcpot_get_exchange_weight
PROCEDURE :: get_vxc => xcpot_get_vxc
PROCEDURE :: get_exc => xcpot_get_exc
PROCEDURE,NOPASS :: alloc_gradients => xcpot_alloc_gradients
!Not overloeaded...
PROCEDURE :: init => xcpot_init
END TYPE t_xcpot_libxc
PUBLIC t_xcpot_libxc
CONTAINS
SUBROUTINE xcpot_init(xcpot,jspins,id_x,id_c)
SUBROUTINE xcpot_init(xcpot,jspins,vxc_id_x,vxc_id_c,exc_id_x,exc_id_c)
USE m_judft
IMPLICIT NONE
CLASS(t_xcpot_libxc),INTENT(OUT) :: xcpot
INTEGER,INTENT(IN) :: jspins,id_x,id_c
INTEGER, INTENT(IN) :: jspins
INTEGER, INTENT(IN) :: vxc_id_x, vxc_id_c ! potential functional
INTEGER, INTENT(IN), OPTIONAL :: exc_id_x, exc_id_c ! energy functionals
LOGICAL :: same_functionals ! are vxc and exc equal
#ifdef CPP_LIBXC
INTEGER :: err
xcpot%jspins=jspins
xcpot%func_id_x=id_x
xcpot%func_id_c=id_c
xcpot%jspins = jspins
xcpot%func_vxc_id_x = vxc_id_x
xcpot%func_vxc_id_c = vxc_id_c
xcpot%func_exc_id_x = merge(exc_id_x, vxc_id_x, PRESENT(exc_id_x))
xcpot%func_exc_id_x = merge(exc_id_c, vxc_id_c, PRESENT(exc_id_c))
same_functionals = (xcpot%func_vxc_id_x == xcpot%func_exc_id_x) &
.and. (xcpot%func_vxc_id_c == xcpot%func_exc_id_c)
if(xcpot%func_vxc_id_x == 0 .or. xcpot%func_exc_id_x == 0 ) then
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) //&
......@@ -55,21 +68,39 @@ CONTAINS
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)
! potential functionals
CALL xc_f03_func_init(xcpot%vxc_func_x, xcpot%func_vxc_id_x, XC_UNPOLARIZED)
IF (xcpot%func_vxc_id_c>0) CALL xc_f03_func_init(xcpot%vxc_func_c, xcpot%func_vxc_id_c, XC_UNPOLARIZED)
! energy functionals
CALL xc_f03_func_init(xcpot%exc_func_x, xcpot%func_exc_id_x, XC_UNPOLARIZED)
IF (xcpot%func_exc_id_c>0) CALL xc_f03_func_init(xcpot%exc_func_c, xcpot%func_exc_id_c, XC_UNPOLARIZED)
ELSE
CALL xc_f03_func_init(xcpot%xc_func_x, xcpot%func_id_x, XC_POLARIZED)
IF (xcpot%func_id_c>0) CALL xc_f03_func_init(xcpot%xc_func_c, xcpot%func_id_c, XC_POLARIZED)
! potential functionals
CALL xc_f03_func_init(xcpot%vxc_func_x, xcpot%func_vxc_id_x, XC_POLARIZED)
IF (xcpot%func_vxc_id_c>0) CALL xc_f03_func_init(xcpot%vxc_func_c, xcpot%func_vxc_id_c, XC_POLARIZED)
!energy functionals
CALL xc_f03_func_init(xcpot%exc_func_x, xcpot%func_exc_id_x, XC_POLARIZED)
IF (xcpot%func_exc_id_c>0) CALL xc_f03_func_init(xcpot%exc_func_c, xcpot%func_exc_id_c, XC_POLARIZED)
END IF
xcpot%xc_info_x=xc_f03_func_get_info(xcpot%xc_func_x)
CALL priv_write_info(xcpot%xc_info_x)
IF (xcpot%func_id_c>0) THEN
xcpot%xc_info_c=xc_f03_func_get_info(xcpot%xc_func_c)
CALL priv_write_info(xcpot%xc_info_c)
CALL write_xc_info(xcpot%vxc_func_x)
IF (xcpot%func_vxc_id_c>0) THEN
CALL write_xc_info(xcpot%vxc_func_c)
ELSE
WRITE(*,*) "No Correlation functional"
END IF
IF(.not. same_functionals) THEN
CALL write_xc_info(xcpot%exc_func_x)
IF (xcpot%func_exc_id_c>0) THEN
CALL write_xc_info(xcpot%exc_func_c)
ELSE
WRITE(*,*) "No Correlation functional for TotalE"
ENDIF
END IF
#else
CALL judft_error("You specified a libxc-exchange correlation potential but FLEUR is not linked against libxc", &
hint="Please recompile FLEUR with libxc support")
......@@ -79,9 +110,12 @@ CONTAINS
LOGICAL FUNCTION xcpot_is_gga(xcpot)
IMPLICIT NONE
CLASS(t_xcpot_libxc),INTENT(IN):: xcpot
CLASS(t_xcpot_libxc),INTENT(IN) :: xcpot
#ifdef CPP_LIBXC
xcpot_is_gga=ANY((/XC_FAMILY_GGA, XC_FAMILY_HYB_GGA/)==xc_f03_func_info_get_family(xcpot%xc_info_x))
TYPE(xc_f03_func_info_t) :: xc_info
xc_info = xc_f03_func_get_info(xcpot%vxc_func_x)
xcpot_is_gga=ANY([XC_FAMILY_GGA, XC_FAMILY_HYB_GGA]==xc_f03_func_info_get_family(xc_info))
#endif
END FUNCTION xcpot_is_gga
......@@ -89,7 +123,10 @@ CONTAINS
IMPLICIT NONE
CLASS(t_xcpot_libxc),INTENT(IN):: xcpot
#ifdef CPP_LIBXC
xcpot_is_MetaGGA=ANY((/XC_FAMILY_MGGA, XC_FAMILY_HYB_MGGA/)==xc_f03_func_info_get_family(xcpot%xc_info_x))
TYPE(xc_f03_func_info_t) :: xc_info
xc_info = xc_f03_func_get_info(xcpot%exc_func_x)
xcpot_is_MetaGGA=ANY([XC_FAMILY_MGGA, XC_FAMILY_HYB_MGGA]==xc_f03_func_info_get_family(xc_info))
#endif
END FUNCTION xcpot_is_MetaGGA
......@@ -97,7 +134,10 @@ CONTAINS
IMPLICIT NONE
CLASS(t_xcpot_libxc),INTENT(IN):: xcpot
#ifdef CPP_LIBXC
xcpot_is_hybrid=ANY((/XC_FAMILY_HYB_MGGA, XC_FAMILY_HYB_GGA/)==xc_f03_func_info_get_family(xcpot%xc_info_x))
TYPE(xc_f03_func_info_t) :: xc_info
xc_info = xc_f03_func_get_info(xcpot%vxc_func_x)
xcpot_is_hybrid=ANY([XC_FAMILY_HYB_MGGA, XC_FAMILY_HYB_GGA]==xc_f03_func_info_get_family(xc_info))
#endif
END FUNCTION xcpot_is_hybrid
......@@ -108,7 +148,7 @@ CONTAINS
REAL:: a_ex
#ifdef CPP_LIBXC
a_ex=xc_f03_hyb_exx_coef(xcpot%xc_func_x)
a_ex=xc_f03_hyb_exx_coef(xcpot%vxc_func_x)
#endif
END FUNCTION xcpot_get_exchange_weight
......@@ -132,18 +172,18 @@ CONTAINS
IF (.NOT.PRESENT(grad)) CALL judft_error("Bug: You called get_vxc for a GGA potential without providing derivatives")
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
CALL xc_f03_gga_vxc(xcpot%xc_func_c, SIZE(rh,1), TRANSPOSE(rh),grad%sigma,vxc_tmp,grad%vsigma)
CALL xc_f03_gga_vxc(xcpot%vxc_func_x, SIZE(rh,1), TRANSPOSE(rh),grad%sigma,vx_tmp,vsigma)
IF (xcpot%func_vxc_id_c>0) THEN
CALL xc_f03_gga_vxc(xcpot%vxc_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)
IF (xcpot%func_id_c>0) THEN
CALL xc_f03_lda_vxc(xcpot%xc_func_c, SIZE(rh,1), TRANSPOSE(rh), vxc_tmp)
CALL xc_f03_lda_vxc(xcpot%vxc_func_x, SIZE(rh,1), TRANSPOSE(rh), vx_tmp)
IF (xcpot%func_vxc_id_c>0) THEN
CALL xc_f03_lda_vxc(xcpot%vxc_func_c, SIZE(rh,1), TRANSPOSE(rh), vxc_tmp)
vxc_tmp=vxc_tmp+vx_tmp
ENDIF
ENDIF
......@@ -169,15 +209,15 @@ CONTAINS
#ifdef CPP_LIBXC
IF (xcpot%is_gga()) THEN
IF (.NOT.PRESENT(grad)) CALL judft_error("Bug: You called get_vxc for a GGA potential without providing derivatives")
CALL xc_f03_gga_exc(xcpot%xc_func_x, SIZE(rh,1), TRANSPOSE(rh),grad%sigma,exc)
IF (xcpot%func_id_c>0) THEN
CALL xc_f03_gga_exc(xcpot%xc_func_c, SIZE(rh,1), TRANSPOSE(rh),grad%sigma,excc)
CALL xc_f03_gga_exc(xcpot%exc_func_x, SIZE(rh,1), TRANSPOSE(rh),grad%sigma,exc)
IF (xcpot%func_vxc_id_c>0) THEN
CALL xc_f03_gga_exc(xcpot%exc_func_c, SIZE(rh,1), TRANSPOSE(rh),grad%sigma,excc)
exc=exc+excc
END IF
ELSE !LDA potentials
CALL xc_f03_lda_exc(xcpot%xc_func_x, SIZE(rh,1), TRANSPOSE(rh), exc)
IF (xcpot%func_id_c>0) THEN
CALL xc_f03_lda_exc(xcpot%xc_func_c, SIZE(rh,1), TRANSPOSE(rh), excc)
CALL xc_f03_lda_exc(xcpot%exc_func_x, SIZE(rh,1), TRANSPOSE(rh), exc)
IF (xcpot%func_vxc_id_c>0) THEN
CALL xc_f03_lda_exc(xcpot%exc_func_c, SIZE(rh,1), TRANSPOSE(rh), excc)
exc=exc+excc
END IF
ENDIF
......@@ -198,13 +238,19 @@ CONTAINS
END SUBROUTINE xcpot_alloc_gradients
#ifdef CPP_LIBXC
SUBROUTINE priv_write_info(xc_info)
#ifdef CPP_LIBXC
SUBROUTINE write_xc_info(xc_func, is_E_func)
IMPLICIT NONE
TYPE(xc_f03_func_info_t),INTENT(IN) :: xc_info
INTEGER :: i
CHARACTER(len=120) :: kind, family
TYPE(xc_f03_func_t),INTENT(IN) :: xc_func
LOGICAL,INTENT(IN),OPTIONAL :: is_E_func
TYPE(xc_f03_func_info_t) :: xc_info
INTEGER :: i
CHARACTER(len=120) :: kind, family
LOGICAL :: is_energy_func
xc_info = xc_f03_func_get_info(xc_func)
is_energy_func = merge(is_E_func, .False., PRESENT(is_E_func))
SELECT CASE(xc_f03_func_info_get_kind(xc_info))
CASE (XC_EXCHANGE)
WRITE(kind, '(a)') 'an exchange functional'
......@@ -232,14 +278,19 @@ CONTAINS
WRITE(family,'(a)') "unknown"
END SELECT
WRITE(*,'("The functional ''", a, "'' is ", a, ", it belongs to the ''", a, "'' family and is defined in the reference(s):")') &
TRIM(xc_f03_func_info_get_name(xc_info)), TRIM(kind), TRIM(family)
IF(.not. is_energy_func) THEN
WRITE(*,'("The functional ''", a, "'' is ", a, ", it belongs to the ''", a, "'' family and is defined in the reference(s):")') &
TRIM(xc_f03_func_info_get_name(xc_info)), TRIM(kind), TRIM(family)
ELSE
WRITE(*,'("The functional used for TotalE ''", a, "'' is ", a, ", it belongs to the ''", a, "'' family and is defined in the reference(s):")') &
TRIM(xc_f03_func_info_get_name(xc_info)), TRIM(kind), TRIM(family)
ENDIF
i = 0
DO WHILE(i >= 0)
WRITE(*, '(a,i1,2a)') '[', i+1, '] ', TRIM(xc_f03_func_reference_get_ref(xc_f03_func_info_get_references(xc_info, i)))
END DO
END SUBROUTINE priv_write_info
END SUBROUTINE write_xc_info
#endif
END MODULE m_types_xcpot_libxc
vgen/vgen_xcpot.F90
View file @ cbac3b75
......@@ -158,15 +158,15 @@ CONTAINS
veff = vTot
IF(xcpot%is_hybrid().AND.hybrid%l_subvxc) THEN
DO ispin = 1, input%jspins
DO ispin = 1, input%jspins
CALL convol(stars,vx%pw_w(:,ispin),vx%pw(:,ispin),stars%ufft)
END DO
veff%pw = vTot%pw - xcpot%get_exchange_weight() * vx%pw
veff%pw_w = vTot%pw_w - xcpot%get_exchange_weight() * vx%pw_w
veff%mt = vTot%mt - xcpot%get_exchange_weight() * vx%mt
exc%pw = exc%pw - xcpot%get_exchange_weight() * exc%pw
exc%pw_w = exc%pw_w - xcpot%get_exchange_weight() * exc%pw_w
exc%mt = exc%mt - xcpot%get_exchange_weight() * exc%mt
END DO
veff%pw = vTot%pw - xcpot%get_exchange_weight() * vx%pw
veff%pw_w = vTot%pw_w - xcpot%get_exchange_weight() * vx%pw_w
veff%mt = vTot%mt - xcpot%get_exchange_weight() * vx%mt
exc%pw = exc%pw - xcpot%get_exchange_weight() * exc%pw
exc%pw_w = exc%pw_w - xcpot%get_exchange_weight() * exc%pw_w
exc%mt = exc%mt - xcpot%get_exchange_weight() * exc%mt
END IF
results%te_veff = 0.0
......
xc-pot/CMakeLists.txt
View file @ cbac3b75
set(fleur_F90 ${fleur_F90}
xc-pot/libxc_postprocess_gga.f90
xc-pot/metagga.F90
)
set(fleur_F77 ${fleur_F77}
......
xc-pot/metagga.F90 0 → 100644
View file @ cbac3b75
!--------------------------------------------------------------------------------
! Copyright (c) 2018 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_metagga
type t_realspace_potden
real, allocatable :: is(:,:), mt(:,:)
end type t_realspace_potden
public :: calc_EnergyDen
private :: calc_EnergyDen_auxillary_weights, t_realspace_potden, subtract_RS, multiply_RS
interface operator (-)
procedure subtract_RS
end interface operator (-)