9
1
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-11-12 08:23:39 +01:00
qp2/plugins/local/tc_bi_ortho/e_corr_bi_ortho.irp.f

110 lines
4.3 KiB
Fortran
Raw Normal View History

2023-02-07 17:07:49 +01:00
use bitmasks ! you need to include the bitmasks_module.f90 features
BEGIN_PROVIDER [ double precision, e_tilde_00]
implicit none
double precision :: hmono,htwoe,hthree,htot
call htilde_mu_mat_bi_ortho_slow(HF_bitmask,HF_bitmask,N_int,hmono,htwoe,hthree,htot)
2023-02-07 17:07:49 +01:00
e_tilde_00 = htot
END_PROVIDER
BEGIN_PROVIDER [ double precision, e_pt2_tc_bi_orth]
&BEGIN_PROVIDER [ double precision, e_pt2_tc_bi_orth_single]
&BEGIN_PROVIDER [ double precision, e_pt2_tc_bi_orth_double]
implicit none
integer :: i,degree
double precision :: hmono,htwoe,hthree,htilde_ij,coef_pt1,e_i0,delta_e
e_pt2_tc_bi_orth = 0.d0
e_pt2_tc_bi_orth_single = 0.d0
e_pt2_tc_bi_orth_double = 0.d0
do i = 1, N_det
call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
if(degree == 1 .or. degree == 2)then
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0)
2023-02-07 17:07:49 +01:00
delta_e = e_tilde_00 - e_i0
coef_pt1 = htilde_ij / delta_e
call htilde_mu_mat_bi_ortho_slow(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
2023-02-07 17:07:49 +01:00
e_pt2_tc_bi_orth += coef_pt1 * htilde_ij
if(degree == 1)then
e_pt2_tc_bi_orth_single += coef_pt1 * htilde_ij
else
! print*,'coef_pt1, e_pt2',coef_pt1,coef_pt1 * htilde_ij
e_pt2_tc_bi_orth_double += coef_pt1 * htilde_ij
endif
endif
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, e_tilde_bi_orth_00]
implicit none
double precision :: hmono,htwoe,hthree,htilde_ij
call htilde_mu_mat_bi_ortho_slow(HF_bitmask,HF_bitmask,N_int,hmono,htwoe,hthree,e_tilde_bi_orth_00)
2023-02-07 17:07:49 +01:00
e_tilde_bi_orth_00 += nuclear_repulsion
END_PROVIDER
BEGIN_PROVIDER [ double precision, e_corr_bi_orth ]
&BEGIN_PROVIDER [ double precision, e_corr_bi_orth_proj ]
&BEGIN_PROVIDER [ double precision, e_corr_single_bi_orth ]
&BEGIN_PROVIDER [ double precision, e_corr_double_bi_orth ]
2023-05-01 14:00:04 +02:00
&BEGIN_PROVIDER [ double precision, e_corr_bi_orth_proj_abs ]
&BEGIN_PROVIDER [ double precision, e_corr_single_bi_orth_abs ]
&BEGIN_PROVIDER [ double precision, e_corr_double_bi_orth_abs ]
2023-02-07 17:07:49 +01:00
implicit none
integer :: i,degree
double precision :: hmono,htwoe,hthree,htilde_ij
e_corr_bi_orth = 0.d0
e_corr_single_bi_orth = 0.d0
e_corr_double_bi_orth = 0.d0
do i = 1, N_det
call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
call htilde_mu_mat_bi_ortho_slow(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
2023-02-07 17:07:49 +01:00
if(degree == 1)then
e_corr_single_bi_orth += reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1)
2023-05-01 14:00:04 +02:00
e_corr_single_bi_orth_abs += dabs(reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1))
2023-02-07 17:07:49 +01:00
else if(degree == 2)then
e_corr_double_bi_orth += reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1)
2023-05-01 14:00:04 +02:00
e_corr_double_bi_orth_abs += dabs(reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1))
2023-02-07 17:07:49 +01:00
endif
enddo
e_corr_bi_orth_proj = e_corr_single_bi_orth + e_corr_double_bi_orth
e_corr_bi_orth = eigval_right_tc_bi_orth(1) - e_tilde_bi_orth_00
2023-05-01 14:00:04 +02:00
e_corr_bi_orth_proj_abs = e_corr_single_bi_orth_abs + e_corr_double_bi_orth_abs
2023-02-07 17:07:49 +01:00
END_PROVIDER
BEGIN_PROVIDER [ double precision, e_tc_left_right ]
implicit none
integer :: i,j
double precision :: hmono,htwoe,hthree,htilde_ij,accu
e_tc_left_right = 0.d0
accu = 0.d0
do i = 1, N_det
accu += reigvec_tc_bi_orth(i,1) * leigvec_tc_bi_orth(i,1)
do j = 1, N_det
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j),psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
2023-02-07 17:07:49 +01:00
e_tc_left_right += htilde_ij * reigvec_tc_bi_orth(i,1) * leigvec_tc_bi_orth(j,1)
enddo
enddo
e_tc_left_right *= 1.d0/accu
e_tc_left_right += nuclear_repulsion
END_PROVIDER
BEGIN_PROVIDER [ double precision, coef_pt1_bi_ortho, (N_det)]
implicit none
integer :: i,degree
double precision :: hmono,htwoe,hthree,htilde_ij,coef_pt1,e_i0,delta_e
do i = 1, N_det
call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
if(degree==0)then
coef_pt1_bi_ortho(i) = 1.d0
else
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0)
2023-02-07 17:07:49 +01:00
delta_e = e_tilde_00 - e_i0
coef_pt1 = htilde_ij / delta_e
coef_pt1_bi_ortho(i)= coef_pt1
endif
enddo
END_PROVIDER