qp2/plugins/local/tc_bi_ortho/tc_utils.irp.f

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_bi_ortho_slow(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_bi_ortho_slow(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_bi_ortho_slow(psi_det(1,1,1), psi_det(1,1,j), N_int, hmono, htwoe, hthree, htot_1j)
      call htilde_mu_mat_bi_ortho_slow(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_bi_ortho_slow(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

! ---