9
1
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-12-25 04:53:32 +01:00
qp2/plugins/local/tc_bi_ortho/tc_utils.irp.f
2024-05-06 18:33:29 +02:00

148 lines
4.0 KiB
Fortran

subroutine write_tc_energy()
implicit none
integer :: i, j, k
double precision :: hmono, htwoe, hthree, htot
double precision :: E_TC, O_TC
double precision :: E_1e, E_2e, E_3e
double precision, allocatable :: E_TC_tmp(:), E_1e_tmp(:), E_2e_tmp(:), E_3e_tmp(:)
! GS
! ---
allocate(E_TC_tmp(N_det), E_1e_tmp(N_det), E_2e_tmp(N_det), E_3e_tmp(N_det))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE(i, j, hmono, htwoe, hthree, htot) &
!$OMP SHARED(N_det, psi_det, N_int, psi_l_coef_bi_ortho, psi_r_coef_bi_ortho, &
!$OMP E_TC_tmp, E_1e_tmp, E_2e_tmp, E_3e_tmp)
!$OMP DO
do i = 1, N_det
E_TC_tmp(i) = 0.d0
E_1e_tmp(i) = 0.d0
E_2e_tmp(i) = 0.d0
E_3e_tmp(i) = 0.d0
do j = 1, N_det
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i), psi_det(1,1,j), N_int, hmono, htwoe, hthree, htot)
E_TC_tmp(i) = E_TC_tmp(i) + psi_l_coef_bi_ortho(i,1) * psi_r_coef_bi_ortho(j,1) * htot
E_1e_tmp(i) = E_1e_tmp(i) + psi_l_coef_bi_ortho(i,1) * psi_r_coef_bi_ortho(j,1) * hmono
E_2e_tmp(i) = E_2e_tmp(i) + psi_l_coef_bi_ortho(i,1) * psi_r_coef_bi_ortho(j,1) * htwoe
E_3e_tmp(i) = E_3e_tmp(i) + psi_l_coef_bi_ortho(i,1) * psi_r_coef_bi_ortho(j,1) * hthree
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
E_1e = 0.d0
E_2e = 0.d0
E_3e = 0.d0
E_TC = 0.d0
O_TC = 0.d0
do i = 1, N_det
E_1e = E_1e + E_1e_tmp(i)
E_2e = E_2e + E_2e_tmp(i)
E_3e = E_3e + E_3e_tmp(i)
E_TC = E_TC + E_TC_tmp(i)
O_TC = O_TC + psi_l_coef_bi_ortho(i,1) * psi_r_coef_bi_ortho(i,1)
enddo
print *, ' state :', 1
print *, " E_TC = ", E_TC / O_TC
print *, " E_1e = ", E_1e / O_TC
print *, " E_2e = ", E_2e / O_TC
print *, " E_3e = ", E_3e / O_TC
print *, " O_TC = ", O_TC
call ezfio_set_tc_bi_ortho_tc_gs_energy(E_TC/O_TC)
! ---
! ES
! ---
do k = 2, n_states
E_TC = 0.d0
E_1e = 0.d0
E_2e = 0.d0
E_3e = 0.d0
do i = 1, N_det
do j = 1, N_det
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i), psi_det(1,1,j), N_int, hmono, htwoe, hthree, htot)
E_TC = E_TC + psi_l_coef_bi_ortho(i,k) * psi_r_coef_bi_ortho(j,k) * htot
E_1e = E_1e + psi_l_coef_bi_ortho(i,k) * psi_r_coef_bi_ortho(j,k) * hmono
E_2e = E_2e + psi_l_coef_bi_ortho(i,k) * psi_r_coef_bi_ortho(j,k) * htwoe
E_3e = E_3e + psi_l_coef_bi_ortho(i,k) * psi_r_coef_bi_ortho(j,k) * hthree
enddo
enddo
O_TC = 0.d0
do i = 1, N_det
O_TC = O_TC + psi_l_coef_bi_ortho(i,k) * psi_r_coef_bi_ortho(i,k)
enddo
print *, ' state :', k
print *, " E_TC = ", E_TC / O_TC
print *, " E_1e = ", E_1e / O_TC
print *, " E_2e = ", E_2e / O_TC
print *, " E_3e = ", E_3e / O_TC
print *, " O_TC = ", O_TC
enddo
deallocate(E_TC_tmp, E_1e_tmp, E_2e_tmp, E_3e_tmp)
end
! ---
subroutine write_tc_var()
implicit none
integer :: i, j, k
double precision :: hmono, htwoe, hthree, htot_1j, htot_j1
double precision :: SIGMA_TC
do k = 1, n_states
SIGMA_TC = 0.d0
do j = 2, N_det
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,1), psi_det(1,1,j), N_int, hmono, htwoe, hthree, htot_1j)
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot_j1)
SIGMA_TC = SIGMA_TC + htot_1j * htot_j1
enddo
print *, " state : ", k
print *, " SIGMA_TC = ", SIGMA_TC
enddo
end
! ---
subroutine write_tc_gs_var_HF()
implicit none
integer :: i, j, k
double precision :: hmono, htwoe, hthree, htot
double precision :: SIGMA_TC
SIGMA_TC = 0.d0
do j = 2, N_det
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot)
SIGMA_TC = SIGMA_TC + htot * htot
enddo
print *, " SIGMA_TC = ", SIGMA_TC
call ezfio_set_tc_bi_ortho_tc_gs_var(SIGMA_TC)
end
! ---