9
1
mirror of https://github.com/QuantumPackage/qp2.git synced 2025-02-11 03:04:30 +01:00

Merge pull request #99 from QuantumPackage/cleaning_dft

Cleaning dft
This commit is contained in:
Anthony Scemama 2020-04-21 15:07:36 +02:00 committed by GitHub
commit 1362042e23
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
69 changed files with 5818 additions and 164 deletions

View File

@ -22,8 +22,8 @@ The core modules of the QP
Ex : if "exchange_functional" == "sr_pbe", then energy_x will contain the exchange correlation functional defined in "functiona/sr_pbe.irp.f", which corresponds to the short-range PBE functional (at the value mu_erf for the range separation parameter)
*** How are handled the DFT functionals in QP2 ?
================================================
*** How to add a new functional in QP2
======================================
Creating a new functional and propagating it through the whole QP2 programs is easy as all dependencies are handled by a script.

View File

@ -0,0 +1,63 @@
#!/usr/bin/env bats
source $QP_ROOT/tests/bats/common.bats.sh
source $QP_ROOT/quantum_package.rc
function run() {
thresh=$2
test_exe fci || skip
qp edit --check
qp set perturbation do_pt2 False
qp set determinants n_det_max 8000
qp set determinants n_states 1
qp set davidson threshold_davidson 1.e-10
qp set davidson n_states_diag 8
qp run fci
energy1="$(ezfio get fci energy | tr '[]' ' ' | cut -d ',' -f 1)"
eq $energy1 $1 $thresh
}
function run_md() {
thresh=$2
qp set mu_of_r mu_of_r_potential cas_ful
file_out=${EZFIO_FILE}.basis_corr.out
qp run basis_correction | tee $file_out
energy1="$(grep 'ECMD SU-PBE-OT , state 1 =' ${file_out} | cut -d '=' -f 2)"
eq $energy1 $1 $thresh
}
function run_sd() {
thresh=$2
qp set mu_of_r mu_of_r_potential hf
qp set_frozen_core
file_out=${EZFIO_FILE}.basis_corr.out
qp run basis_correction | tee $file_out
energy1="$(grep 'ECMD PBE-UEG , state 1 =' ${file_out} | cut -d '=' -f 2)"
eq $energy1 $1 $thresh
}
@test "O2 CAS" {
qp set_file o2_cas.gms.ezfio
qp set_mo_class -c "[1-2]" -a "[3-10]" -d "[11-46]"
run -149.72435425 3.e-4 10000
qp set_mo_class -c "[1-2]" -a "[3-10]" -v "[11-46]"
run_md -0.1160222327 1.e-6
}
@test "LiF RHF" {
qp set_file lif.ezfio
run_sd -0.0649431665 1.e-6
}
@test "F ROHF" {
qp set_file f.ezfio
run_sd -0.0355395041 1.e-6
}
@test "Be RHF" {
qp set_file be.ezfio
run_sd -0.0325139011 1.e-6
}

View File

@ -0,0 +1,3 @@
mu_of_r
dft_utils_func
dft_one_e

View File

@ -0,0 +1,27 @@
================
basis_correction
================
This module proposes the various flavours of the DFT-based basis set correction originally proposed in J. Chem. Phys. 149, 194301 (2018); https://doi.org/10.1063/1.5052714.
This basis set correction relies mainy on :
+) The definition of a range-separation function \mu(r) varying in space to mimic the incompleteness of the basis set used to represent the coulomb interaction. This procedure needs a two-body rdm representing qualitatively the spacial distribution of the opposite spin electron pairs.
Two types of \mu(r) are proposed, according to the strength of correlation, through the keyword "mu_of_r_potential" in the module "mu_of_r":
a) "mu_of_r_potential = hf" uses the two-body rdm of a HF-like wave function (i.e. a single Slater determinant developped with the MOs stored in the EZFIO folder).
When HF is a qualitative representation of the electron pairs (i.e. weakly correlated systems), such an approach for \mu(r) is OK.
See for instance JPCL, 10, 2931-2937 (2019) for typical flavours of the results.
Thanks to the trivial nature of such a two-body rdm, the equation (22) of J. Chem. Phys. 149, 194301 (2018) can be rewritten in a very efficient way, and therefore the limiting factor of such an approach is the AO->MO four-index transformation of the two-electron integrals.
b) "mu_of_r_potential = cas_ful" uses the two-body rdm of CAS-like wave function (i.e. linear combination of Slater determinants developped in an active space with the MOs stored in the EZFIO folder).
If the CAS is properly chosen (i.e. the CAS-like wave function qualitatively represents the wave function of the systems), then such an approach is OK for \mu(r) even in the case of strong correlation.
+) The use of DFT correlation functionals with multi-determinant reference (Ecmd). These functionals are originally defined in the RS-DFT framework (see for instance Theor. Chem. Acc.114, 305(2005)) and design to capture short-range correlation effects. A important quantity arising in the Ecmd is the exact on-top pair density of the system, and the main differences of approximated Ecmd relies on different approximations for the exact on-top pair density.
The two main flavours of Ecmd depends on the strength of correlation in the system:
a) for weakly correlated systems, the ECMD PBE-UEG functional based on the seminal work of in RSDFT (see JCP, 150, 084103 1-10 (2019)) and adapted for the basis set correction in JPCL, 10, 2931-2937 (2019) uses the exact on-top pair density of the UEG at large mu and the PBE correlation functional at mu = 0. As shown in JPCL, 10, 2931-2937 (2019), such a functional is more accurate than the ECMD LDA for weakly correlated systems.
b) for strongly correlated systems, the ECMD PBE-OT, which uses the extrapolated on-top pair density of the CAS wave function thanks to the large \mu behaviour of the on-top pair density, is accurate, but suffers from S_z dependence (i.e. is not invariant with respect to S_z) because of the spin-polarization dependence of the PBE correlation functional entering at mu=0.
An alternative is ECMD SU-PBE-OT which uses the same on-top pair density that ECMD PBE-OT but a ZERO spin-polarization to remove the S_z dependence. As shown in ???????????, this strategy is one of the more accurate and respects S_z invariance and size consistency if the CAS wave function is correctly chosen.

View File

@ -0,0 +1 @@
change all correlation functionals with the pbe_on_top general

View File

@ -0,0 +1,27 @@
program basis_correction
implicit none
BEGIN_DOC
! TODO : Put the documentation of the program here
END_DOC
read_wf = .True.
touch read_wf
no_core_density = .True.
touch no_core_density
provide mo_two_e_integrals_in_map
call print_basis_correction
! call print_e_b
end
subroutine print_e_b
implicit none
print *, 'Hello world'
print*,'ecmd_lda_mu_of_r = ',ecmd_lda_mu_of_r
print*,'ecmd_pbe_ueg_mu_of_r = ',ecmd_pbe_ueg_mu_of_r
print*,'ecmd_pbe_ueg_eff_xi_mu_of_r = ',ecmd_pbe_ueg_eff_xi_mu_of_r
print*,''
print*,'psi_energy + E^B_LDA = ',psi_energy + ecmd_lda_mu_of_r
print*,'psi_energy + E^B_PBE_UEG = ',psi_energy + ecmd_pbe_ueg_mu_of_r
print*,'psi_energy + E^B_PBE_UEG_Xi = ',psi_energy + ecmd_pbe_ueg_eff_xi_mu_of_r
print*,''
print*,'mu_average_prov = ',mu_average_prov
end

View File

@ -0,0 +1,92 @@
BEGIN_PROVIDER [double precision, ecmd_pbe_ueg_eff_xi_mu_of_r, (N_states)]
BEGIN_DOC
! ecmd_pbe_ueg_eff_xi_mu_of_r = multi-determinantal Ecmd within the PBE-UEG and effective spin polarization approximation with mu(r),
!
! see Eqs. 30 in ???????????
!
! Based on the PBE-on-top functional (see Eqs. 26, 27 of J. Chem. Phys.150, 084103 (2019); doi: 10.1063/1.5082638)
!
! and replaces the approximation of the exact on-top pair density by the exact on-top of the UEG
!
! !!!! BUT !!!! with an EFFECTIVE SPIN POLARIZATION DEPENDING ON THE ON-TOP PAIR DENSITY
!
! See P. Perdew, A. Savin, and K. Burke, Phys. Rev. A 51, 4531 (1995). for original Ref., and Eq. 29 in ???????????
END_DOC
implicit none
double precision :: weight,density
integer :: ipoint,istate
double precision :: eps_c_md_PBE,mu,rho_a,rho_b,grad_rho_a(3),grad_rho_b(3),g0_UEG_mu_inf,on_top
ecmd_pbe_ueg_eff_xi_mu_of_r = 0.d0
print*,'Providing ecmd_pbe_ueg_eff_xi_mu_of_r ...'
call wall_time(wall0)
do istate = 1, N_states
do ipoint = 1, n_points_final_grid
weight=final_weight_at_r_vector(ipoint)
mu = mu_of_r_prov(ipoint,istate)
density = one_e_dm_and_grad_alpha_in_r(4,ipoint,istate) + one_e_dm_and_grad_beta_in_r(4,ipoint,istate)
! We use the effective spin density to define rho_a/rho_b
rho_a = 0.5d0 * (density + effective_spin_dm(ipoint,istate))
rho_b = 0.5d0 * (density - effective_spin_dm(ipoint,istate))
grad_rho_a(1:3) = one_e_dm_and_grad_alpha_in_r(1:3,ipoint,istate)
grad_rho_b(1:3) = one_e_dm_and_grad_beta_in_r(1:3,ipoint,istate)
! We take the on-top pair density of the UEG which is (1-zeta^2) rhoc^2 g0 = 4 rhoa * rhob * g0
! with the effective rho_a and rho_b
on_top = 4.d0 * rho_a * rho_b * g0_UEG_mu_inf(rho_a,rho_b)
call ec_md_pbe_on_top_general(mu,rho_a,rho_b,grad_rho_a,grad_rho_b,on_top,eps_c_md_PBE)
ecmd_pbe_ueg_eff_xi_mu_of_r(istate) += eps_c_md_PBE * weight
enddo
enddo
double precision :: wall1, wall0
call wall_time(wall1)
print*,'Time for the ecmd_pbe_ueg_eff_xi_mu_of_r:',wall1-wall0
END_PROVIDER
BEGIN_PROVIDER [double precision, ecmd_lda_eff_xi_mu_of_r, (N_states)]
BEGIN_DOC
! ecmd_lda_eff_xi_mu_of_r = multi-determinantal Ecmd within the LDA and effective spin polarization approximation with mu(r),
!
! corresponds to equation 40 in J. Chem. Phys. 149, 194301 (2018); https://doi.org/10.1063/1.5052714
!
! !!!! BUT !!!! with an EFFECTIVE SPIN POLARIZATION DEPENDING ON THE ON-TOP PAIR DENSITY
!
! See P. Perdew, A. Savin, and K. Burke, Phys. Rev. A 51, 4531 (1995). for original Ref., and Eq. 29 in ???????????
END_DOC
implicit none
integer :: ipoint,istate
double precision :: rho_a, rho_b, ec
logical :: dospin
double precision :: wall0,wall1,weight,mu,density
dospin = .true. ! JT dospin have to be set to true for open shell
print*,'Providing ecmd_lda_eff_xi_mu_of_r ...'
ecmd_lda_eff_xi_mu_of_r = 0.d0
call wall_time(wall0)
do istate = 1, N_states
do ipoint = 1, n_points_final_grid
mu = mu_of_r_prov(ipoint,istate)
weight = final_weight_at_r_vector(ipoint)
density = one_e_dm_and_grad_alpha_in_r(4,ipoint,istate) + one_e_dm_and_grad_beta_in_r(4,ipoint,istate)
rho_a = 0.5d0 * (density + effective_spin_dm(ipoint,istate))
rho_b = 0.5d0 * (density - effective_spin_dm(ipoint,istate))
call ESRC_MD_LDAERF (mu,rho_a,rho_b,dospin,ec)
if(isnan(ec))then
print*,'ec is nan'
stop
endif
ecmd_lda_eff_xi_mu_of_r(istate) += weight * ec
enddo
enddo
call wall_time(wall1)
print*,'Time for ecmd_lda_eff_xi_mu_of_r :',wall1-wall0
END_PROVIDER

View File

@ -0,0 +1,183 @@
BEGIN_PROVIDER [double precision, ecmd_pbe_on_top_mu_of_r, (N_states)]
BEGIN_DOC
!
! Ecmd functional evaluated with mu(r) and depending on
! +) the on-top pair density
!
! +) the total density, density gradients
!
! +) the spin density
!
! Defined originally in Eq. (25) of JCP, 150, 084103 1-10 (2019) for RS-DFT calculations, but evaluated with mu(r).
!
! Such a functional is built by interpolating between two regimes :
!
! +) the large mu behaviour in cst/(\mu^3) \int dr on-top(r) where on-top(r) is supposed to be the exact on-top of the system
!
! +) mu= 0 with the usal ec_pbe(rho_a,rho_b,grad_rho_a,grad_rho_b)
!
! Here the approximation to the exact on-top is done through the assymptotic expansion (in \mu) of the exact on-top pair density (see Eq. 29) but with a mu(r) instead of a constant mu
!
! Such an asymptotic expansion was introduced in P. Gori-Giorgi and A. Savin, Phys. Rev. A73, 032506 (2006)
!
END_DOC
implicit none
double precision :: weight
double precision :: eps_c_md_on_top_PBE,on_top_extrap,mu_correction_of_on_top
integer :: ipoint,istate
double precision :: eps_c_md_PBE,mu,rho_a,rho_b,grad_rho_a(3),grad_rho_b(3),on_top
ecmd_pbe_on_top_mu_of_r = 0.d0
do istate = 1, N_states
do ipoint = 1, n_points_final_grid
weight = final_weight_at_r_vector(ipoint)
mu = mu_of_r_prov(ipoint,istate)
! depends on (rho_a, rho_b) <==> (rho_tot,spin_pol)
rho_a = one_e_dm_and_grad_alpha_in_r(4,ipoint,istate)
rho_b = one_e_dm_and_grad_beta_in_r(4,ipoint,istate)
grad_rho_a(1:3) = one_e_dm_and_grad_alpha_in_r(1:3,ipoint,istate)
grad_rho_b(1:3) = one_e_dm_and_grad_beta_in_r(1:3,ipoint,istate)
if(mu_of_r_potential == "cas_ful")then
! You take the on-top of the CAS wave function which is computed with mu(r)
on_top = on_top_cas_mu_r(ipoint,istate)
else
! You take the on-top of the CAS wave function computed separately
on_top = total_cas_on_top_density(ipoint,istate)
endif
! We take the extrapolated on-top pair density * 2 because of normalization
on_top_extrap = 2.d0 * mu_correction_of_on_top(mu,on_top)
call ec_md_pbe_on_top_general(mu,rho_a,rho_b,grad_rho_a,grad_rho_b,on_top_extrap,eps_c_md_on_top_PBE)
ecmd_pbe_on_top_mu_of_r(istate) += eps_c_md_on_top_PBE * weight
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, ecmd_pbe_on_top_su_mu_of_r, (N_states)]
BEGIN_DOC
!
! Ecmd functional evaluated with mu(r) and depending on
! +) the on-top pair density
!
! +) the total density, density gradients
!
! +) !!!!! NO SPIN POLAIRIZATION !!!!!
!
! Defined originally in Eq. (25) of JCP, 150, 084103 1-10 (2019) for RS-DFT calculations, but evaluated with mu(r).
!
! Such a functional is built by interpolating between two regimes :
!
! +) the large mu behaviour in cst/(\mu^3) \int dr on-top(r) where on-top(r) is supposed to be the exact on-top of the system
!
! +) mu= 0 with the usal ec_pbe(rho_a,rho_b,grad_rho_a,grad_rho_b)
!
! Here the approximation to the exact on-top is done through the assymptotic expansion (in \mu) of the exact on-top pair density (see Eq. 29) but with a mu(r) instead of a constant mu
!
! Such an asymptotic expansion was introduced in P. Gori-Giorgi and A. Savin, Phys. Rev. A73, 032506 (2006)
!
END_DOC
implicit none
double precision :: weight
double precision :: eps_c_md_on_top_PBE,on_top_extrap,mu_correction_of_on_top
integer :: ipoint,istate
double precision :: eps_c_md_PBE,mu,rho_a,rho_b,grad_rho_a(3),grad_rho_b(3),on_top,density
ecmd_pbe_on_top_su_mu_of_r = 0.d0
do istate = 1, N_states
do ipoint = 1, n_points_final_grid
weight = final_weight_at_r_vector(ipoint)
mu = mu_of_r_prov(ipoint,istate)
density = one_e_dm_and_grad_alpha_in_r(4,ipoint,istate) + one_e_dm_and_grad_beta_in_r(4,ipoint,istate)
! rho_a = rho_b = rho_tot/2 ==> NO SPIN POLARIZATION
rho_a = 0.5d0 * density
rho_b = 0.5d0 * density
grad_rho_a(1:3) = one_e_dm_and_grad_alpha_in_r(1:3,ipoint,istate)
grad_rho_b(1:3) = one_e_dm_and_grad_beta_in_r(1:3,ipoint,istate)
if(mu_of_r_potential == "cas_ful")then
! You take the on-top of the CAS wave function which is computed with mu(r)
on_top = on_top_cas_mu_r(ipoint,istate)
else
! You take the on-top of the CAS wave function computed separately
on_top = total_cas_on_top_density(ipoint,istate)
endif
! We take the extrapolated on-top pair density * 2 because of normalization
on_top_extrap = 2.d0 * mu_correction_of_on_top(mu,on_top)
call ec_md_pbe_on_top_general(mu,rho_a,rho_b,grad_rho_a,grad_rho_b,on_top_extrap,eps_c_md_on_top_PBE)
ecmd_pbe_on_top_su_mu_of_r(istate) += eps_c_md_on_top_PBE * weight
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, ecmd_pbe_on_top_no_extrap_su_mu_of_r, (N_states)]
BEGIN_DOC
!
! Ecmd functional evaluated with mu(r) and depending on
! +) the on-top pair density
!
! +) the total density, density gradients
!
! +) !!!!! NO SPIN POLAIRIZATION !!!!!
!
! Defined originally in Eq. (25) of JCP, 150, 084103 1-10 (2019) for RS-DFT calculations, but evaluated with mu(r).
!
! Such a functional is built by interpolating between two regimes :
!
! +) the large mu behaviour in cst/(\mu^3) \int dr on-top(r) where on-top(r) is supposed to be the exact on-top of the system
!
! +) mu= 0 with the usal ec_pbe(rho_a,rho_b,grad_rho_a,grad_rho_b)
!
! Here the approximation to the exact on-top is done through the assymptotic expansion (in \mu) of the exact on-top pair density (see Eq. 29) but with a mu(r) instead of a constant mu
!
! Such an asymptotic expansion was introduced in P. Gori-Giorgi and A. Savin, Phys. Rev. A73, 032506 (2006)
!
END_DOC
implicit none
double precision :: weight
double precision :: eps_c_md_on_top_PBE,on_top_extrap,mu_correction_of_on_top
integer :: ipoint,istate
double precision :: eps_c_md_PBE,mu,rho_a,rho_b,grad_rho_a(3),grad_rho_b(3),on_top,density
ecmd_pbe_on_top_no_extrap_su_mu_of_r = 0.d0
do istate = 1, N_states
do ipoint = 1, n_points_final_grid
weight = final_weight_at_r_vector(ipoint)
mu = mu_of_r_prov(ipoint,istate)
density = one_e_dm_and_grad_alpha_in_r(4,ipoint,istate) + one_e_dm_and_grad_beta_in_r(4,ipoint,istate)
! rho_a = rho_b = rho_tot/2 ==> NO SPIN POLARIZATION
rho_a = 0.5d0 * density
rho_b = 0.5d0 * density
grad_rho_a(1:3) = one_e_dm_and_grad_alpha_in_r(1:3,ipoint,istate)
grad_rho_b(1:3) = one_e_dm_and_grad_beta_in_r(1:3,ipoint,istate)
if(mu_of_r_potential == "cas_ful")then
! You take the on-top of the CAS wave function which is computed with mu(r)
on_top = on_top_cas_mu_r(ipoint,istate)
else
! You take the on-top of the CAS wave function computed separately
on_top = total_cas_on_top_density(ipoint,istate)
endif
! We DO NOT take the extrapolated on-top pair density, but there is * 2 because of normalization
on_top_extrap = 2.d0 * on_top
call ec_md_pbe_on_top_general(mu,rho_a,rho_b,grad_rho_a,grad_rho_b,on_top_extrap,eps_c_md_on_top_PBE)
ecmd_pbe_on_top_no_extrap_su_mu_of_r(istate) += eps_c_md_on_top_PBE * weight
enddo
enddo
END_PROVIDER

View File

@ -0,0 +1,82 @@
subroutine print_basis_correction
implicit none
integer :: istate
provide mu_average_prov
if(mu_of_r_potential.EQ."hf")then
provide ecmd_lda_mu_of_r ecmd_pbe_ueg_mu_of_r
else if(mu_of_r_potential.EQ."cas_ful".or.mu_of_r_potential.EQ."cas_truncated")then
provide ecmd_lda_mu_of_r ecmd_pbe_ueg_mu_of_r
provide ecmd_pbe_on_top_mu_of_r ecmd_pbe_on_top_su_mu_of_r
endif
print*, ''
print*, ''
print*, '****************************************'
print*, '****************************************'
print*, 'Basis set correction for WFT using DFT Ecmd functionals'
print*, 'These functionals are accurate for short-range correlation'
print*, ''
print*, 'For more details look at Journal of Chemical Physics 149, 194301 1-15 (2018) '
print*, ' Journal of Physical Chemistry Letters 10, 2931-2937 (2019) '
print*, ' ???REF SC?'
print*, '****************************************'
print*, '****************************************'
print*, 'mu_of_r_potential = ',mu_of_r_potential
if(mu_of_r_potential.EQ."hf")then
print*, ''
print*,'Using a HF-like two-body density to define mu(r)'
print*,'This assumes that HF is a qualitative representation of the wave function '
print*,'********************************************'
print*,'Functionals more suited for weak correlation'
print*,'********************************************'
print*,'+) LDA Ecmd functional : purely based on the UEG (JCP,149,194301,1-15 (2018)) '
do istate = 1, N_states
write(*, '(A29,X,I3,X,A3,X,F16.10)') ' ECMD LDA , state ',istate,' = ',ecmd_lda_mu_of_r(istate)
enddo
print*,'+) PBE-UEG Ecmd functional : PBE at mu=0, UEG ontop pair density at large mu (JPCL, 10, 2931-2937 (2019))'
do istate = 1, N_states
write(*, '(A29,X,I3,X,A3,X,F16.10)') ' ECMD PBE-UEG , state ',istate,' = ',ecmd_pbe_ueg_mu_of_r(istate)
enddo
else if(mu_of_r_potential.EQ."cas_ful")then
print*, ''
print*,'Using a CAS-like two-body density to define mu(r)'
print*,'This assumes that the CAS is a qualitative representation of the wave function '
print*,'********************************************'
print*,'Functionals more suited for weak correlation'
print*,'********************************************'
print*,'+) LDA Ecmd functional : purely based on the UEG (JCP,149,194301,1-15 (2018)) '
do istate = 1, N_states
write(*, '(A29,X,I3,X,A3,X,F16.10)') ' ECMD LDA , state ',istate,' = ',ecmd_lda_mu_of_r(istate)
enddo
print*,'+) PBE-UEG Ecmd functional : PBE at mu=0, UEG ontop pair density at large mu (JPCL, 10, 2931-2937 (2019))'
do istate = 1, N_states
write(*, '(A29,X,I3,X,A3,X,F16.10)') ' ECMD PBE-UEG , state ',istate,' = ',ecmd_pbe_ueg_mu_of_r(istate)
enddo
print*,''
print*,'********************************************'
print*,'********************************************'
print*,'+) PBE-on-top Ecmd functional : (??????? REF-SCF ??????????)'
print*,'PBE at mu=0, extrapolated ontop pair density at large mu, usual spin-polarization'
do istate = 1, N_states
write(*, '(A29,X,I3,X,A3,X,F16.10)') ' ECMD PBE-OT , state ',istate,' = ',ecmd_pbe_on_top_mu_of_r(istate)
enddo
print*,''
print*,'********************************************'
print*,'+) PBE-on-top no spin polarization Ecmd functional : (??????? REF-SCF ??????????)'
print*,'PBE at mu=0, extrapolated ontop pair density at large mu, and ZERO SPIN POLARIZATION'
do istate = 1, N_states
write(*, '(A29,X,I3,X,A3,X,F16.10)') ' ECMD SU-PBE-OT , state ',istate,' = ',ecmd_pbe_on_top_su_mu_of_r(istate)
enddo
print*,''
endif
print*,''
print*,'**************'
do istate = 1, N_states
write(*, '(A29,X,I3,X,A3,X,F16.10)') ' Average mu(r) , state ',istate,' = ',mu_average_prov(istate)
enddo
end

View File

@ -0,0 +1,83 @@
BEGIN_PROVIDER [double precision, ecmd_lda_mu_of_r, (N_states)]
BEGIN_DOC
! ecmd_lda_mu_of_r = multi-determinantal Ecmd within the LDA approximation with mu(r) ,
!
! see equation 40 in J. Chem. Phys. 149, 194301 (2018); https://doi.org/10.1063/1.5052714
END_DOC
implicit none
integer :: ipoint,istate
double precision :: rho_a, rho_b, ec
double precision :: wall0,wall1,weight,mu
logical :: dospin
dospin = .true. ! JT dospin have to be set to true for open shell
print*,'Providing ecmd_lda_mu_of_r ...'
ecmd_lda_mu_of_r = 0.d0
call wall_time(wall0)
do istate = 1, N_states
do ipoint = 1, n_points_final_grid
! mu(r) defined by Eq. (37) of J. Chem. Phys. 149, 194301 (2018)
mu = mu_of_r_prov(ipoint,istate)
weight = final_weight_at_r_vector(ipoint)
rho_a = one_e_dm_and_grad_alpha_in_r(4,ipoint,istate)
rho_b = one_e_dm_and_grad_beta_in_r(4,ipoint,istate)
! Ecmd within the LDA approximation of PRB 73, 155111 (2006)
call ESRC_MD_LDAERF (mu,rho_a,rho_b,dospin,ec)
if(isnan(ec))then
print*,'ec is nan'
stop
endif
ecmd_lda_mu_of_r(istate) += weight * ec
enddo
enddo
call wall_time(wall1)
print*,'Time for ecmd_lda_mu_of_r :',wall1-wall0
END_PROVIDER
BEGIN_PROVIDER [double precision, ecmd_pbe_ueg_mu_of_r, (N_states)]
BEGIN_DOC
! ecmd_pbe_ueg_mu_of_r = multi-determinantal Ecmd within the PBE-UEG approximation with mu(r) ,
!
! see Eqs. 13-14b in Phys.Chem.Lett.2019, 10, 2931 2937; https://pubs.acs.org/doi/10.1021/acs.jpclett.9b01176
!
! Based on the PBE-on-top functional (see Eqs. 26, 27 of J. Chem. Phys.150, 084103 (2019); doi: 10.1063/1.5082638)
!
! but it the on-top pair density of the UEG as an approximation of the exact on-top pair density
END_DOC
implicit none
double precision :: weight
integer :: ipoint,istate
double precision :: eps_c_md_PBE,mu,rho_a,rho_b,grad_rho_a(3),grad_rho_b(3),on_top
double precision :: g0_UEG_mu_inf
ecmd_pbe_ueg_mu_of_r = 0.d0
print*,'Providing ecmd_pbe_ueg_mu_of_r ...'
call wall_time(wall0)
do istate = 1, N_states
do ipoint = 1, n_points_final_grid
weight=final_weight_at_r_vector(ipoint)
! mu(r) defined by Eq. (37) of J. Chem. Phys. 149, 194301 (2018)
mu = mu_of_r_prov(ipoint,istate)
rho_a = one_e_dm_and_grad_alpha_in_r(4,ipoint,istate)
rho_b = one_e_dm_and_grad_beta_in_r(4,ipoint,istate)
grad_rho_a(1:3) = one_e_dm_and_grad_alpha_in_r(1:3,ipoint,istate)
grad_rho_b(1:3) = one_e_dm_and_grad_beta_in_r(1:3,ipoint,istate)
! We take the on-top pair density of the UEG which is (1-zeta^2) rhoc^2 g0 = 4 rhoa * rhob * g0
on_top = 4.d0 * rho_a * rho_b * g0_UEG_mu_inf(rho_a,rho_b)
! The form of interpolated (mu=0 ---> mu=infinity) functional originally introduced in JCP, 150, 084103 1-10 (2019)
call ec_md_pbe_on_top_general(mu,rho_a,rho_b,grad_rho_a,grad_rho_b,on_top,eps_c_md_PBE)
ecmd_pbe_ueg_mu_of_r(istate) += eps_c_md_PBE * weight
enddo
enddo
double precision :: wall1, wall0
call wall_time(wall1)
print*,'Time for the ecmd_pbe_ueg_mu_of_r:',wall1-wall0
END_PROVIDER

View File

@ -18,6 +18,7 @@ BEGIN_PROVIDER [integer, n_points_final_grid]
enddo
print*,'n_points_final_grid = ',n_points_final_grid
print*,'n max point = ',n_points_integration_angular*(n_points_radial_grid*nucl_num - 1)
call ezfio_set_becke_numerical_grid_n_points_final_grid(n_points_final_grid)
END_PROVIDER
BEGIN_PROVIDER [double precision, final_grid_points, (3,n_points_final_grid)]

View File

@ -0,0 +1,2 @@
two_body_rdm
dft_utils_in_r

View File

@ -0,0 +1,9 @@
==============
on_top_density
==============
This plugin proposes different routines/providers to compute the on-top pair density of a CAS-based wave function.
This means that all determinants in psi_det must belong to an active-space.
As usual, see the file "example.irp.f" to get introduced to the main providers/routines.

View File

@ -0,0 +1,125 @@
BEGIN_PROVIDER[double precision, core_mos_in_r_array, (n_core_orb,n_points_final_grid)]
&BEGIN_PROVIDER[double precision, core_mos_in_r_array_transp,(n_points_final_grid,n_core_orb)]
implicit none
BEGIN_DOC
! all COREE MOs on the grid points, arranged in two different ways
END_DOC
integer :: i,j,k
do i = 1, n_core_orb
j = list_core(i)
do k = 1, n_points_final_grid
core_mos_in_r_array_transp(k,i) = mos_in_r_array_transp(k,j)
enddo
enddo
do k = 1, n_points_final_grid
do i = 1, n_core_orb
core_mos_in_r_array(i,k) = core_mos_in_r_array_transp(k,i)
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER[double precision, inact_mos_in_r_array, (n_inact_orb,n_points_final_grid)]
&BEGIN_PROVIDER[double precision, inact_mos_in_r_array_transp,(n_points_final_grid,n_inact_orb)]
implicit none
BEGIN_DOC
! all INACTIVE MOs on the grid points, arranged in two different ways
END_DOC
integer :: i,j,k
do i = 1, n_inact_orb
j = list_inact(i)
do k = 1, n_points_final_grid
inact_mos_in_r_array_transp(k,i) = mos_in_r_array_transp(k,j)
enddo
enddo
do k = 1, n_points_final_grid
do i = 1, n_inact_orb
inact_mos_in_r_array(i,k) = inact_mos_in_r_array_transp(k,i)
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER[double precision, act_mos_in_r_array, (n_act_orb,n_points_final_grid)]
&BEGIN_PROVIDER[double precision, act_mos_in_r_array_transp,(n_points_final_grid,n_act_orb)]
implicit none
BEGIN_DOC
! all ACTIVE MOs on the grid points, arranged in two different ways
END_DOC
integer :: i,j,k
do i = 1, n_act_orb
j = list_act(i)
do k = 1, n_points_final_grid
act_mos_in_r_array_transp(k,i) = mos_in_r_array_transp(k,j)
enddo
enddo
do k = 1, n_points_final_grid
do i = 1, n_act_orb
act_mos_in_r_array(i,k) = act_mos_in_r_array_transp(k,i)
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER[double precision, virt_mos_in_r_array, (n_virt_orb,n_points_final_grid)]
&BEGIN_PROVIDER[double precision, virt_mos_in_r_array_transp,(n_points_final_grid,n_virt_orb)]
implicit none
BEGIN_DOC
! all VIRTUAL MOs on the grid points, arranged in two different ways
END_DOC
integer :: i,j,k
do i = 1, n_virt_orb
j = list_virt(i)
do k = 1, n_points_final_grid
virt_mos_in_r_array_transp(k,i) = mos_in_r_array_transp(k,j)
enddo
enddo
do k = 1, n_points_final_grid
do i = 1, n_virt_orb
virt_mos_in_r_array(i,k) = virt_mos_in_r_array_transp(k,i)
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER[double precision, core_inact_act_mos_in_r_array, (n_core_inact_act_orb,n_points_final_grid)]
&BEGIN_PROVIDER[double precision, core_inact_act_mos_in_r_array_transp,(n_points_final_grid,n_core_inact_act_orb)]
implicit none
integer :: i,j,k
do i = 1, n_core_inact_act_orb
j = list_core_inact_act(i)
do k = 1, n_points_final_grid
core_inact_act_mos_in_r_array_transp(k,i) = mos_in_r_array_transp(k,j)
enddo
enddo
do k = 1, n_points_final_grid
do i = 1, n_core_inact_act_orb
core_inact_act_mos_in_r_array(i,k) = core_inact_act_mos_in_r_array_transp(k,i)
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER[double precision, core_inact_act_mos_grad_in_r_array, (3,n_core_inact_act_orb,n_points_final_grid)]
implicit none
integer :: i,j,k,l
do i = 1, n_core_inact_act_orb
j = list_core_inact_act(i)
do k = 1, n_points_final_grid
do l = 1, 3
core_inact_act_mos_grad_in_r_array(l,i,k) = mos_grad_in_r_array(j,k,l)
enddo
enddo
enddo
END_PROVIDER

View File

@ -0,0 +1,47 @@
program cas_based_density
implicit none
BEGIN_DOC
! TODO : Small example to use the different quantities in this plugin
END_DOC
!! You force QP2 to read the wave function in the EZFIO folder
!! It is assumed that all Slater determinants in the wave function
!! belongs to an active space defined by core, inactive and active list of orbitals
read_wf = .True.
touch read_wf
call routine_test_cas_based_density
end
subroutine routine_test_cas_based_density
implicit none
integer :: ipoint, istate
double precision :: accu_n_elec(N_states),accu_n_elec_2(N_states)
! PROVIDERS
accu_n_elec = 0.d0
do istate = 1, N_states
do ipoint = 1, n_points_final_grid
accu_n_elec(istate) += one_e_cas_total_density(ipoint,istate) * final_weight_at_r_vector(ipoint)
enddo
print*,'istate = ',istate
print*,'accu_n_elec = ',accu_n_elec(istate)
enddo
! ROUTINES
double precision :: r(3),core_dens,inact_dens,act_dens(2,N_states),total_cas_dens(N_states)
accu_n_elec_2 = 0.d0
do ipoint = 1, n_points_final_grid
r(:) = final_grid_points(:,ipoint)
call give_cas_density_in_r(core_dens,inact_dens,act_dens,total_cas_dens,r)
do istate = 1, N_states
accu_n_elec_2(istate) += total_cas_dens(istate) * final_weight_at_r_vector(ipoint)
enddo
enddo
do istate = 1, N_states
print*,'istate = ',istate
print*,'accu_n_elec = ',accu_n_elec_2(istate)
enddo
end

View File

@ -0,0 +1,19 @@
program cas_based_on_top_density
implicit none
BEGIN_DOC
! TODO : Small example to use the different quantities in this plugin
END_DOC
!! You force QP2 to read the wave function in the EZFIO folder
!! It is assumed that all Slater determinants in the wave function
!! belongs to an active space defined by core, inactive and active list of orbitals
read_wf = .True.
touch read_wf
! call routine_test_cas_based_on_top_density
call routine
end
subroutine routine
implicit none
provide total_cas_on_top_density
end

View File

@ -0,0 +1,99 @@
BEGIN_PROVIDER [double precision, one_e_cas_total_density ,(n_points_final_grid,N_states) ]
implicit none
BEGIN_DOC
! one_e_cas_total_density = TOTAL DENSITY FOR a CAS wave function
!
! WARNING : if "no_core_density" == .True. then the core part of density is ignored
END_DOC
integer :: ipoint,i,j,istate
do istate = 1, N_states
do ipoint = 1, n_points_final_grid
one_e_cas_total_density(ipoint,istate) = one_e_act_density_alpha(ipoint,istate) + one_e_act_density_beta(ipoint,istate) &
+ 2.d0 * inact_density(ipoint)
if(.not.no_core_density)then !!! YOU ADD THE CORE DENSITY
one_e_cas_total_density(ipoint,istate) += 2.d0 * core_density(ipoint)
endif
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, one_e_act_density_alpha,(n_points_final_grid,N_states) ]
implicit none
BEGIN_DOC
! one_e_act_density_alpha = pure ACTIVE part of the DENSITY for ALPHA ELECTRONS
END_DOC
one_e_act_density_alpha = 0.d0
integer :: ipoint,i,j,istate
do istate = 1, N_states
do ipoint = 1, n_points_final_grid
do i = 1, n_act_orb
do j = 1, n_act_orb
one_e_act_density_alpha(ipoint,istate) += one_e_act_dm_alpha_mo_for_dft(j,i,istate) * act_mos_in_r_array(j,ipoint) * act_mos_in_r_array(i,ipoint)
enddo
enddo
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, one_e_act_density_beta,(n_points_final_grid,N_states) ]
implicit none
BEGIN_DOC
! one_e_act_density_beta = pure ACTIVE part of the DENSITY for BETA ELECTRONS
END_DOC
one_e_act_density_beta = 0.d0
integer :: ipoint,i,j,istate
do istate = 1, N_states
do ipoint = 1, n_points_final_grid
do i = 1, n_act_orb
do j = 1, n_act_orb
one_e_act_density_beta(ipoint,istate) += one_e_act_dm_beta_mo_for_dft(j,i,istate) * act_mos_in_r_array(j,ipoint) * act_mos_in_r_array(i,ipoint)
enddo
enddo
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, inact_density, (n_points_final_grid) ]
implicit none
BEGIN_DOC
! INACTIVE part of the density for alpha/beta.
!
! WARNING :: IF YOU NEED THE TOTAL DENSITY COMING FROM THE INACTIVE,
!
! YOU MUST MULTIPLY BY TWO
END_DOC
integer :: i,j
inact_density = 0.d0
do i = 1, n_points_final_grid
do j = 1, n_inact_orb
inact_density(i) += inact_mos_in_r_array(j,i) **2
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, core_density, (n_points_final_grid) ]
implicit none
BEGIN_DOC
! CORE part of the density for alpha/beta.
!
! WARNING :: IF YOU NEED THE TOTAL DENSITY COMING FROM THE CORE,
!
! YOU MUST MULTIPLY BY TWO
END_DOC
integer :: i,j
core_density = 0.d0
do i = 1, n_points_final_grid
do j = 1, n_core_orb
core_density(i) += core_mos_in_r_array(j,i) **2
enddo
enddo
END_PROVIDER

View File

@ -0,0 +1,65 @@
subroutine give_cas_density_in_r(core_dens,inact_dens,act_dens,total_cas_dens,r)
implicit none
BEGIN_DOC
! returns the different component of the density at grid point r(3) for a CAS wave function
!
! core_dens : density coming from the CORE orbitals
!
! inact_dens : density coming from the INACT orbitals
!
! act_dens(1/2,1:N_states) : active part of the alpha/beta electrons for all states
!
! total_cas_dens : total density of the cas wave function
!
! WARNING : if "no_core_density" == .True. then the core part of density is ignored in total_cas_dens
END_DOC
double precision, intent(in) :: r(3)
double precision, intent(out) :: core_dens, inact_dens, act_dens(2,N_states), total_cas_dens(N_states)
double precision, allocatable :: mos_array(:),act_mos(:)
allocate(mos_array(mo_num))
call give_all_mos_at_r(r,mos_array)
integer :: i,iorb,j,jorb,istate
! core part of the density
core_dens = 0.d0
do i = 1, n_core_orb
iorb = list_core(i)
core_dens += mos_array(iorb)*mos_array(iorb)
enddo
core_dens = core_dens * 2.d0
! inactive part of the density
inact_dens = 0.d0
do i = 1, n_inact_orb
iorb = list_inact(i)
inact_dens += mos_array(iorb)*mos_array(iorb)
enddo
inact_dens = inact_dens * 2.d0
allocate(act_mos(n_act_orb))
do i = 1, n_act_orb
iorb = list_act(i)
act_mos(i) = mos_array(iorb)
enddo
! active part of the density for alpha/beta and all states
act_dens = 0.d0
do istate = 1, N_states
do i = 1, n_act_orb
do j = 1, n_act_orb
act_dens(1,istate) += one_e_act_dm_alpha_mo_for_dft(j,i,istate) * act_mos(j) * act_mos(i)
act_dens(2,istate) += one_e_act_dm_beta_mo_for_dft(j,i,istate) * act_mos(j) * act_mos(i)
enddo
enddo
enddo
! TOTAL density for all states
do istate = 1, N_states
total_cas_dens(istate) = inact_dens + act_dens(1,istate) + act_dens(2,istate)
if(.not.no_core_density)then !!! YOU ADD THE CORE DENSITY
total_cas_dens(istate) += core_dens
endif
enddo
end

View File

@ -0,0 +1,37 @@
BEGIN_PROVIDER [double precision, one_e_act_dm_beta_mo_for_dft, (n_act_orb,n_act_orb,N_states)]
implicit none
BEGIN_DOC
! one_e_act_dm_beta_mo_for_dft = pure ACTIVE part of the ONE ELECTRON REDUCED DENSITY MATRIX for the BETA ELECTRONS
END_DOC
integer :: i,j,ii,jj,istate
do istate = 1, N_states
do ii = 1, n_act_orb
i = list_act(ii)
do jj = 1, n_act_orb
j = list_act(jj)
one_e_act_dm_beta_mo_for_dft(jj,ii,istate) = one_e_dm_mo_beta_for_dft(j,i,istate)
enddo
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, one_e_act_dm_alpha_mo_for_dft, (n_act_orb,n_act_orb,N_states)]
implicit none
BEGIN_DOC
! one_e_act_dm_alpha_mo_for_dft = pure ACTIVE part of the ONE ELECTRON REDUCED DENSITY MATRIX for the ALPHA ELECTRONS
END_DOC
integer :: i,j,ii,jj,istate
do istate = 1, N_states
do ii = 1, n_act_orb
i = list_act(ii)
do jj = 1, n_act_orb
j = list_act(jj)
one_e_act_dm_alpha_mo_for_dft(jj,ii,istate) = one_e_dm_mo_alpha_for_dft(j,i,istate)
enddo
enddo
enddo
END_PROVIDER

View File

@ -0,0 +1,68 @@
BEGIN_PROVIDER [double precision, effective_spin_dm, (n_points_final_grid,N_states) ]
&BEGIN_PROVIDER [double precision, grad_effective_spin_dm, (3,n_points_final_grid,N_states) ]
implicit none
BEGIN_DOC
! effective_spin_dm(r_i) = \sqrt( n(r)^2 - 4 * ontop(r) )
! effective spin density obtained from the total density and on-top pair density
! see equation (6) of Phys. Chem. Chem. Phys., 2015, 17, 22412--22422 | 22413
END_DOC
provide total_cas_on_top_density
integer :: i_point,i_state,i
double precision :: n2,m2,thr
thr = 1.d-14
effective_spin_dm = 0.d0
grad_effective_spin_dm = 0.d0
do i_state = 1, N_states
do i_point = 1, n_points_final_grid
n2 = (one_e_dm_and_grad_alpha_in_r(4,i_point,i_state) + one_e_dm_and_grad_beta_in_r(4,i_point,i_state))
! density squared
n2 = n2 * n2
if(n2 - 4.D0 * total_cas_on_top_density(i_point,i_state).gt.thr)then
effective_spin_dm(i_point,i_state) = dsqrt(n2 - 4.D0 * total_cas_on_top_density(i_point,i_state))
if(isnan(effective_spin_dm(i_point,i_state)))then
print*,'isnan(effective_spin_dm(i_point,i_state)'
stop
endif
m2 = effective_spin_dm(i_point,i_state)
m2 = 0.5d0 / m2 ! 1/(2 * sqrt(n(r)^2 - 4 * ontop(r)) )
do i = 1, 3
grad_effective_spin_dm(i,i_point,i_state) = m2 * ( one_e_stuff_for_pbe(i,i_point,i_state) - 4.d0 * grad_total_cas_on_top_density(i,i_point,i_state) )
enddo
else
effective_spin_dm(i_point,i_state) = 0.d0
grad_effective_spin_dm(:,i_point,i_state) = 0.d0
endif
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, effective_alpha_dm, (n_points_final_grid,N_states) ]
&BEGIN_PROVIDER [double precision, effective_beta_dm, (n_points_final_grid,N_states) ]
&BEGIN_PROVIDER [double precision, grad_effective_alpha_dm, (3,n_points_final_grid,N_states) ]
&BEGIN_PROVIDER [double precision, grad_effective_beta_dm, (3,n_points_final_grid,N_states) ]
implicit none
BEGIN_DOC
! effective_alpha_dm(r_i) = 1/2 * (effective_spin_dm(r_i) + n(r_i))
! effective_beta_dm(r_i) = 1/2 * (-effective_spin_dm(r_i) + n(r_i))
END_DOC
provide total_cas_on_top_density
integer :: i_point,i_state,i
double precision :: n,grad_n
do i_state = 1, N_states
do i_point = 1, n_points_final_grid
n = (one_e_dm_and_grad_alpha_in_r(4,i_point,i_state) + one_e_dm_and_grad_beta_in_r(4,i_point,i_state))
effective_alpha_dm(i_point,i_state) = 0.5d0 * (n + effective_spin_dm(i_point,i_state))
effective_beta_dm(i_point,i_state) = 0.5d0 * (n - effective_spin_dm(i_point,i_state))
do i = 1, 3
grad_n = (one_e_dm_and_grad_alpha_in_r(i,i_point,i_state) + one_e_dm_and_grad_beta_in_r(i,i_point,i_state))
grad_effective_alpha_dm(i,i_point,i_state) = 0.5d0 * (grad_n + grad_effective_spin_dm(i,i_point,i_state) )
grad_effective_beta_dm(i,i_point,i_state) = 0.5d0 * (grad_n - grad_effective_spin_dm(i,i_point,i_state) )
enddo
enddo
enddo
END_PROVIDER

View File

@ -0,0 +1,41 @@
subroutine write_on_top_in_real_space
implicit none
BEGIN_DOC
! This routines is a simple example of how to plot the on-top pair density on a simple 1D grid
END_DOC
double precision :: zmax,dz,r(3),on_top_in_r,total_density,zcenter,dist
integer :: nz,i,istate
character*(128) :: output
integer :: i_unit_output,getUnitAndOpen
PROVIDE ezfio_filename
output=trim(ezfio_filename)//'.on_top'
print*,'output = ',trim(output)
i_unit_output = getUnitAndOpen(output,'w')
zmax = 2.0d0
print*,'nucl_coord(1,3) = ',nucl_coord(1,3)
print*,'nucl_coord(2,3) = ',nucl_coord(2,3)
dist = dabs(nucl_coord(1,3) - nucl_coord(2,3))
zmax += dist
zcenter = (nucl_coord(1,3) + nucl_coord(2,3))*0.5d0
print*,'zcenter = ',zcenter
print*,'zmax = ',zmax
nz = 1000
dz = zmax / dble(nz)
r(:) = 0.d0
r(3) = zcenter -zmax * 0.5d0
print*,'r(3) = ',r(3)
istate = 1
do i = 1, nz
call give_on_top_in_r_one_state(r,istate,on_top_in_r)
call give_cas_density_in_r(r,total_density)
write(i_unit_output,*)r(3),on_top_in_r,total_density
r(3) += dz
enddo
end

View File

@ -0,0 +1,76 @@
subroutine act_on_top_on_grid_pt(ipoint,istate,pure_act_on_top_of_r)
implicit none
BEGIN_DOC
! act_on_top_on_grid_pt returns the purely ACTIVE part of the on top pair density
!
! at the grid point ipoint, for the state istate
END_DOC
integer, intent(in) :: ipoint,istate
double precision, intent(out) :: pure_act_on_top_of_r
double precision :: phi_i,phi_j,phi_k,phi_l
integer :: i,j,k,l
ASSERT (istate <= N_states)
pure_act_on_top_of_r = 0.d0
do l = 1, n_act_orb
phi_l = act_mos_in_r_array(l,ipoint)
do k = 1, n_act_orb
phi_k = act_mos_in_r_array(k,ipoint)
do j = 1, n_act_orb
phi_j = act_mos_in_r_array(j,ipoint)
do i = 1, n_act_orb
phi_i = act_mos_in_r_array(i,ipoint)
! 1 2 1 2
pure_act_on_top_of_r += act_2_rdm_ab_mo(i,j,k,l,istate) * phi_i * phi_j * phi_k * phi_l
enddo
enddo
enddo
enddo
end
BEGIN_PROVIDER [double precision, total_cas_on_top_density,(n_points_final_grid,N_states) ]
implicit none
BEGIN_DOC
! on top pair density :: n2(r,r) at each of the Becke's grid point of a CAS-BASED wf
!
! Contains all core/inact/act contribution.
!
! !!!!! WARNING !!!!! If no_core_density then you REMOVE ALL CONTRIBUTIONS COMING FROM THE CORE ORBITALS
END_DOC
integer :: i_point,istate
double precision :: wall_0,wall_1,core_inact_dm,pure_act_on_top_of_r
logical :: no_core
print*,'providing the total_cas_on_top_density'
! for parallelization
provide inact_density core_density one_e_act_density_beta one_e_act_density_alpha act_mos_in_r_array
i_point = 1
istate = 1
call act_on_top_on_grid_pt(i_point,istate,pure_act_on_top_of_r)
call wall_time(wall_0)
if(no_core_density)then
print*,'USING THE VALENCE ONLY TWO BODY DENSITY'
endif
do istate = 1, N_states
!$OMP PARALLEL DO &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i_point,core_inact_dm,pure_act_on_top_of_r) &
!$OMP SHARED(total_cas_on_top_density,n_points_final_grid,inact_density,core_density,one_e_act_density_beta,one_e_act_density_alpha,no_core_density,istate)
do i_point = 1, n_points_final_grid
call act_on_top_on_grid_pt(i_point,istate,pure_act_on_top_of_r)
if(no_core_density) then
core_inact_dm = inact_density(i_point)
else
core_inact_dm = (inact_density(i_point) + core_density(i_point))
endif
total_cas_on_top_density(i_point,istate) = pure_act_on_top_of_r + core_inact_dm * (one_e_act_density_beta(i_point,istate) + one_e_act_density_alpha(i_point,istate)) + core_inact_dm*core_inact_dm
enddo
!$OMP END PARALLEL DO
enddo
call wall_time(wall_1)
print*,'provided the total_cas_on_top_density'
print*,'Time to provide :',wall_1 - wall_0
END_PROVIDER

View File

@ -0,0 +1,118 @@
subroutine give_core_inact_act_density_in_r(r,mos_array,core_density_in_r,inact_density_in_r,act_density_in_r, total_density)
implicit none
double precision, intent(in) :: r(3),mos_array(mo_num)
double precision, intent(out):: core_density_in_r,inact_density_in_r,act_density_in_r(2,N_states),total_density(N_states)
BEGIN_DOC
! core, inactive and active part of the density for alpha/beta electrons
!
! the density coming from the core and inactive are the same for alpha/beta electrons
!
! act_density(1/2, i) = alpha/beta density for the ith state
!
! total_density(i) = 2 * (core_density_in_r+inact_density_in_r) + act_density_in_r(1,i) + act_density_in_r(2,i)
END_DOC
integer :: i,j,istate
core_density_in_r = 0.d0
do i = 1, n_core_orb
j = list_core(i)
core_density_in_r += mos_array(j) * mos_array(j)
enddo
inact_density_in_r = 0.d0
do i = 1, n_inact_orb
j = list_inact(i)
inact_density_in_r += mos_array(j) * mos_array(j)
enddo
double precision, allocatable :: act_mos(:)
double precision :: tmp
allocate(act_mos(n_act_orb))
do i = 1, n_act_orb
j = list_act(i)
act_mos(i) = mos_array(j)
enddo
act_density_in_r = 0.d0
do istate = 1, N_states
do i = 1, n_act_orb
do