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/eff_spin_dens.irp.f
2020-04-07 11:42:29 +02:00

69 lines
2.9 KiB
Fortran

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