9
1
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-10-05 23:55:57 +02:00
qp2/plugins/local/tc_bi_ortho/tc_som.irp.f
2024-01-15 12:02:38 +01:00

64 lines
1.3 KiB
Fortran

! ---
program tc_som
BEGIN_DOC
! TODO : Put the documentation of the program here
END_DOC
implicit none
print *, ' starting ...'
print *, ' do not forget to do tc-scf first'
my_grid_becke = .True.
PROVIDE tc_grid1_a tc_grid1_r
my_n_pt_r_grid = tc_grid1_r
my_n_pt_a_grid = tc_grid1_a
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
read_wf = .true.
touch read_wf
call main()
end
! ---
subroutine main()
implicit none
integer :: i, i_HF, degree
double precision :: hmono_1, htwoe_1, hthree_1, htot_1
double precision :: hmono_2, htwoe_2, hthree_2, htot_2
double precision :: U_SOM
PROVIDE N_int N_det
do i = 1, N_det
call get_excitation_degree(HF_bitmask, psi_det(1,1,i), degree, N_int)
if(degree == 0) then
i_HF = i
exit
endif
enddo
print *, ' HF determinants:', i_HF
print *, ' N_det :', N_det
U_SOM = 0.d0
do i = 1, N_det
if(i == i_HF) cycle
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i_HF), psi_det(1,1,i), N_int, hmono_1, htwoe_1, hthree_1, htot_1)
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i), psi_det(1,1,i_HF), N_int, hmono_2, htwoe_2, hthree_2, htot_2)
U_SOM += htot_1 * htot_2
enddo
U_SOM = 0.5d0 * U_SOM
print *, ' U_SOM = ', U_SOM
return
end subroutine main
! ---