9
1
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-11-11 16:03:38 +01:00
qp2/src/cas_based_on_top/on_top_cas_rout.irp.f
2020-04-07 11:42:29 +02:00

119 lines
3.8 KiB
Fortran

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 j = 1, n_act_orb
tmp = act_mos(i) * act_mos(j)
act_density_in_r(1,istate) += tmp * one_e_act_dm_alpha_mo_for_dft(j,i,istate)
act_density_in_r(2,istate) += tmp * one_e_act_dm_beta_mo_for_dft(j,i,istate)
enddo
enddo
total_density(istate) = 2.d0 * (core_density_in_r + inact_density_in_r) + act_density_in_r(1,istate) + act_density_in_r(2,istate)
enddo
end
subroutine give_active_on_top_in_r_one_state(r,istate,mos_array,act_on_top)
implicit none
BEGIN_DOC
! gives the purely active on-top pair density for a given state
END_DOC
integer, intent(in) :: istate
double precision, intent(in) :: r(3),mos_array(mo_num)
double precision, intent(out) :: act_on_top
double precision :: phi_i,phi_j,phi_k,phi_l
integer :: i,j,k,l
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_on_top = 0.d0
do l = 1, n_act_orb
phi_l = act_mos(l)
do k = 1, n_act_orb
phi_k = act_mos(k)
do j = 1, n_act_orb
phi_j = act_mos(j)
tmp = phi_l * phi_k * phi_j
do i = 1, n_act_orb
phi_i = act_mos(i)
! 1 2 1 2
act_on_top += act_2_rdm_ab_mo(i,j,k,l,istate) * tmp * phi_i
enddo
enddo
enddo
enddo
end
subroutine give_on_top_in_r_one_state(r,istate,on_top_in_r)
implicit none
integer, intent(in) :: istate
double precision, intent(in) :: r(3)
double precision, intent(out) :: on_top_in_r
BEGIN_DOC
! on top pair density in r for the state istate a CAS-BASED wf
!
! note that if no_core_density .EQ. .True., all core contributions are excluded
END_DOC
double precision, allocatable :: mos_array(:)
provide act_2_rdm_ab_mo one_e_act_dm_alpha_mo_for_dft one_e_act_dm_beta_mo_for_dft
allocate(mos_array(mo_num))
call give_all_mos_at_r(r,mos_array)
double precision :: core_density_in_r, inact_density_in_r, act_density_in_r(2,N_states), total_density(N_states)
double precision :: act_on_top,core_inact_dm
! getting the different part of the density in r
call give_core_inact_act_density_in_r(r,mos_array,core_density_in_r,inact_density_in_r,act_density_in_r, total_density)
! getting the purely active part of the density in r
call give_active_on_top_in_r_one_state(r,istate,mos_array,act_on_top)
if(no_core_density) then
core_inact_dm = inact_density_in_r
else
core_inact_dm = core_density_in_r + inact_density_in_r
endif
on_top_in_r = act_on_top + core_inact_dm * (act_density_in_r(1,istate) + act_density_in_r(2,istate)) + core_inact_dm*core_inact_dm
end