LCPQ/qp2
9
1
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-06-01 02:05:18 +02:00
Code Releases Activity

Hij in bimo added

Browse Source
This commit is contained in:
AbdAmmar 2022-10-20 15:48:34 +02:00
parent ad01d2b2e4
commit 813f2c3601
9 changed files with 744 additions and 152 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
src/ao_tc_eff_map/potential.irp.f
View File

@ -94,30 +94,40 @@ BEGIN_PROVIDER [double precision, expos_slat_gauss_1_erf_x, (n_fit_1_erf_x)]
expos_slat_gauss_1_erf_x(2) = 0.756023d0
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, expo_gauss_1_erf_x, (n_max_fit_slat)]
&BEGIN_PROVIDER [double precision, coef_gauss_1_erf_x, (n_max_fit_slat)]
implicit none
BEGIN_DOC
! (1 - erf(mu*x)) = \sum_i coef_gauss_1_erf_x(i) * exp(-expo_gauss_1_erf_x(i) * x^2)
!
! This is based on a fit of (1 - erf(mu*x)) by exp(-alpha * x) exp(-beta*mu^2x^2)
!
! and the slater function exp(-alpha * x) is fitted with n_max_fit_slat gaussians
!
! See Appendix 2 of JCP 154, 084119 (2021)
END_DOC
integer :: i
double precision :: expos(n_max_fit_slat),alpha,beta
alpha = expos_slat_gauss_1_erf_x(1) * mu_erf
call expo_fit_slater_gam(alpha,expos)
beta = expos_slat_gauss_1_erf_x(2) * mu_erf**2.d0
BEGIN_DOC
!
! (1 - erf(mu*x)) = \sum_i coef_gauss_1_erf_x(i) * exp(-expo_gauss_1_erf_x(i) * x^2)
!
! This is based on a fit of (1 - erf(mu*x)) by exp(-alpha * x) exp(-beta*mu^2x^2)
!
! and the slater function exp(-alpha * x) is fitted with n_max_fit_slat gaussians
!
! See Appendix 2 of JCP 154, 084119 (2021)
!
END_DOC
implicit none
integer :: i
double precision :: expos(n_max_fit_slat), alpha, beta
alpha = expos_slat_gauss_1_erf_x(1) * mu_erf
call expo_fit_slater_gam(alpha, expos)
beta = expos_slat_gauss_1_erf_x(2) * mu_erf * mu_erf
do i = 1, n_max_fit_slat
expo_gauss_1_erf_x(i) = expos(i) + beta
coef_gauss_1_erf_x(i) = coef_fit_slat_gauss(i)
enddo
do i = 1, n_max_fit_slat
expo_gauss_1_erf_x(i) = expos(i) + beta
coef_gauss_1_erf_x(i) = coef_fit_slat_gauss(i)
enddo
END_PROVIDER
! ---
double precision function fit_1_erf_x(x)
implicit none
double precision, intent(in) :: x

4
src/ao_two_e_ints/two_e_integrals.irp.f
View File

@ -1,7 +1,7 @@
! ---
double precision function ao_two_e_integral(i,j,k,l)
double precision function ao_two_e_integral(i, j, k, l)
BEGIN_DOC
! integral of the AO basis <ik|jl> or (ij|kl)
@ -29,7 +29,7 @@ double precision function ao_two_e_integral(i,j,k,l)
if(use_cosgtos) then
!print *, ' use_cosgtos for ao_two_e_integral ?', use_cosgtos
ao_two_e_integral = ao_two_e_integral_cosgtos(i,j,k,l)
ao_two_e_integral = ao_two_e_integral_cosgtos(i, j, k, l)
else

183
src/bi_ort_ints/biorthog_mo_for_h.irp.f Normal file
View File

@ -0,0 +1,183 @@
! ---
BEGIN_PROVIDER [double precision, ao_two_e_coul, (ao_num, ao_num, ao_num, ao_num) ]
BEGIN_DOC
!
! ao_two_e_coul(k,i,l,j) = ( k i | 1/r12 | l j ) = < l k | 1/r12 | j i >
!
END_DOC
integer :: i, j, k, l
double precision :: integral
double precision, external :: get_ao_two_e_integral
PROVIDE ao_integrals_map
do j = 1, ao_num
do l = 1, ao_num
do i = 1, ao_num
do k = 1, ao_num
integral = get_ao_two_e_integral(i, j, k, l, ao_integrals_map)
ao_two_e_coul(k,i,l,j) = integral
enddo
enddo
enddo
enddo
END_PROVIDER
! ---
double precision function bi_ortho_mo_coul_ints(l, k, j, i)
BEGIN_DOC
!
! < mo^L_k mo^L_l | 1/r12 | mo^R_i mo^R_j >
!
END_DOC
implicit none
integer, intent(in) :: i, j, k, l
integer :: m, n, p, q
bi_ortho_mo_coul_ints = 0.d0
do m = 1, ao_num
do p = 1, ao_num
do n = 1, ao_num
do q = 1, ao_num
! p1h1p2h2 l1 l2 r1 r2
bi_ortho_mo_coul_ints += ao_two_e_coul(n,q,m,p) * mo_l_coef(m,l) * mo_l_coef(n,k) * mo_r_coef(p,j) * mo_r_coef(q,i)
enddo
enddo
enddo
enddo
end function bi_ortho_mo_coul_ints
! ---
! TODO :: transform into DEGEMM
BEGIN_PROVIDER [double precision, mo_bi_ortho_coul_e_chemist, (mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC
!
! mo_bi_ortho_coul_e_chemist(k,i,l,j) = < k l | 1/r12 | i j > where i,j are right MOs and k,l are left MOs
!
END_DOC
implicit none
integer :: i, j, k, l, m, n, p, q
double precision, allocatable :: mo_tmp_1(:,:,:,:), mo_tmp_2(:,:,:,:)
allocate(mo_tmp_1(mo_num,ao_num,ao_num,ao_num))
mo_tmp_1 = 0.d0
do m = 1, ao_num
do p = 1, ao_num
do n = 1, ao_num
do q = 1, ao_num
do k = 1, mo_num
! (k n|p m) = sum_q c_qk * (q n|p m)
mo_tmp_1(k,n,p,m) += mo_l_coef_transp(k,q) * ao_two_e_coul(q,n,p,m)
enddo
enddo
enddo
enddo
enddo
allocate(mo_tmp_2(mo_num,mo_num,ao_num,ao_num))
mo_tmp_2 = 0.d0
do m = 1, ao_num
do p = 1, ao_num
do n = 1, ao_num
do i = 1, mo_num
do k = 1, mo_num
! (k i|p m) = sum_n c_ni * (k n|p m)
mo_tmp_2(k,i,p,m) += mo_r_coef_transp(i,n) * mo_tmp_1(k,n,p,m)
enddo
enddo
enddo
enddo
enddo
deallocate(mo_tmp_1)
allocate(mo_tmp_1(mo_num,mo_num,mo_num,ao_num))
mo_tmp_1 = 0.d0
do m = 1, ao_num
do p = 1, ao_num
do l = 1, mo_num
do i = 1, mo_num
do k = 1, mo_num
mo_tmp_1(k,i,l,m) += mo_l_coef_transp(l,p) * mo_tmp_2(k,i,p,m)
enddo
enddo
enddo
enddo
enddo
deallocate(mo_tmp_2)
mo_bi_ortho_coul_e_chemist = 0.d0
do m = 1, ao_num
do j = 1, mo_num
do l = 1, mo_num
do i = 1, mo_num
do k = 1, mo_num
mo_bi_ortho_coul_e_chemist(k,i,l,j) += mo_r_coef_transp(j,m) * mo_tmp_1(k,i,l,m)
enddo
enddo
enddo
enddo
enddo
deallocate(mo_tmp_1)
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, mo_bi_ortho_coul_e, (mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC
!
! mo_bi_ortho_coul_e(k,l,i,j) = < k l | 1/r12 | i j > where i,j are right MOs and k,l are left MOs
!
END_DOC
implicit none
integer :: i, j, k, l
do j = 1, mo_num
do i = 1, mo_num
do l = 1, mo_num
do k = 1, mo_num
! < k l | V12 | i j > (k i|l j)
mo_bi_ortho_coul_e(k,l,i,j) = mo_bi_ortho_coul_e_chemist(k,i,l,j)
enddo
enddo
enddo
enddo
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, mo_bi_ortho_one_e, (mo_num, mo_num)]
BEGIN_DOC
! mo_bi_ortho_one_e(k,i) = <MO^L_k | h_c | MO^R_i>
END_DOC
implicit none
call ao_to_mo_bi_ortho( ao_one_e_integrals, ao_num &
, mo_bi_ortho_one_e , mo_num )
END_PROVIDER
! ---

15
src/bi_ort_ints/one_e_bi_ort.irp.f
View File

@ -24,12 +24,17 @@ BEGIN_PROVIDER [double precision, ao_one_e_integrals_tc_tot, (ao_num,ao_num)]
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_one_e, (mo_num, mo_num)]
implicit none
BEGIN_DOC
! mo_bi_ortho_tc_one_e(k,i) = <MO^L_k | h_c | MO^R_i>
END_DOC
integer :: i,k,p,q
BEGIN_DOC
!
! mo_bi_ortho_tc_one_e(k,i) = <MO^L_k | h_c | MO^R_i>
!
END_DOC
implicit none
call ao_to_mo_bi_ortho(ao_one_e_integrals_tc_tot, ao_num, mo_bi_ortho_tc_one_e, mo_num)

289
src/bi_ort_ints/total_twoe_pot.irp.f
View File

@ -1,138 +1,177 @@
BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_num) ]
integer :: i,j,k,l
BEGIN_DOC
! ao_two_e_tc_tot(k,i,l,j) = (ki|V^TC(r_12)|lj) = <lk| V^TC(r_12) |ji> where V^TC(r_12) is the total TC operator
!
! including both hermitian and non hermitian parts. THIS IS IN CHEMIST NOTATION.
!
! WARNING :: non hermitian ! acts on "the right functions" (i,j)
END_DOC
double precision :: integral_sym, integral_nsym, get_ao_tc_sym_two_e_pot
PROVIDE ao_tc_sym_two_e_pot_in_map
do j = 1, ao_num
do l = 1, ao_num
do i = 1, ao_num
do k = 1, ao_num
integral_sym = get_ao_tc_sym_two_e_pot(i,j,k,l,ao_tc_sym_two_e_pot_map)
! ao_non_hermit_term_chemist(k,i,l,j) = < k l | [erf( mu r12) - 1] d/d_r12 | i j > on the AO basis
integral_nsym = ao_non_hermit_term_chemist(k,i,l,j)
ao_two_e_tc_tot(k,i,l,j) = integral_sym + integral_nsym
enddo
enddo
enddo
enddo
END_PROVIDER
double precision function bi_ortho_mo_ints(l,k,j,i)
implicit none
BEGIN_DOC
! <mo^L_k mo^L_l | V^TC(r_12) | mo^R_i mo^R_j>
!
! WARNING :: very naive, super slow, only used to DEBUG.
END_DOC
integer, intent(in) :: i,j,k,l
integer :: m,n,p,q
bi_ortho_mo_ints = 0.d0
do m = 1, ao_num
do p = 1, ao_num
do n = 1, ao_num
do q = 1, ao_num
! p1h1p2h2 l1 l2 r1 r2
bi_ortho_mo_ints += ao_two_e_tc_tot(n,q,m,p) * mo_l_coef(m,l) * mo_l_coef(n,k) * mo_r_coef(p,j) * mo_r_coef(q,i)
enddo
enddo
enddo
enddo
end
! ---
BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC
! mo_bi_ortho_tc_two_e_chemist(k,i,l,j) = <k l|V(r_12)|i j> where i,j are right MOs and k,l are left MOs
END_DOC
integer :: i,j,k,l,m,n,p,q
double precision, allocatable :: mo_tmp_1(:,:,:,:),mo_tmp_2(:,:,:,:),mo_tmp_3(:,:,:,:)
BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_num) ]
!! TODO :: transform into DEGEMM
allocate(mo_tmp_1(mo_num,ao_num,ao_num,ao_num))
mo_tmp_1 = 0.d0
do m = 1, ao_num
do p = 1, ao_num
do n = 1, ao_num
do q = 1, ao_num
do k = 1, mo_num
! (k n|p m) = sum_q c_qk * (q n|p m)
mo_tmp_1(k,n,p,m) += mo_l_coef_transp(k,q) * ao_two_e_tc_tot(q,n,p,m)
enddo
BEGIN_DOC
!
! ao_two_e_tc_tot(k,i,l,j) = (ki|V^TC(r_12)|lj) = <lk| V^TC(r_12) |ji> where V^TC(r_12) is the total TC operator
!
! including both hermitian and non hermitian parts. THIS IS IN CHEMIST NOTATION.
!
! WARNING :: non hermitian ! acts on "the right functions" (i,j)
!
END_DOC
integer :: i, j, k, l
double precision :: integral_sym, integral_nsym
double precision, external :: get_ao_tc_sym_two_e_pot
PROVIDE ao_tc_sym_two_e_pot_in_map
do j = 1, ao_num
do l = 1, ao_num
do i = 1, ao_num
do k = 1, ao_num
integral_sym = get_ao_tc_sym_two_e_pot(i,j,k,l,ao_tc_sym_two_e_pot_map)
! ao_non_hermit_term_chemist(k,i,l,j) = < k l | [erf( mu r12) - 1] d/d_r12 | i j > on the AO basis
integral_nsym = ao_non_hermit_term_chemist(k,i,l,j)
ao_two_e_tc_tot(k,i,l,j) = integral_sym + integral_nsym
enddo
enddo
enddo
enddo
enddo
enddo
allocate(mo_tmp_2(mo_num,mo_num,ao_num,ao_num))
mo_tmp_2 = 0.d0
do m = 1, ao_num
do p = 1, ao_num
do n = 1, ao_num
do i = 1, mo_num
do k = 1, mo_num
! (k i|p m) = sum_n c_ni * (k n|p m)
mo_tmp_2(k,i,p,m) += mo_r_coef_transp(i,n) * mo_tmp_1(k,n,p,m)
enddo
enddo
enddo
enddo
enddo
deallocate(mo_tmp_1)
allocate(mo_tmp_1(mo_num,mo_num,mo_num,ao_num))
mo_tmp_1 = 0.d0
do m = 1, ao_num
do p = 1, ao_num
do l = 1, mo_num
do i = 1, mo_num
do k = 1, mo_num
mo_tmp_1(k,i,l,m) += mo_l_coef_transp(l,p) * mo_tmp_2(k,i,p,m)
enddo
enddo
enddo
enddo
enddo
deallocate(mo_tmp_2)
mo_bi_ortho_tc_two_e_chemist = 0.d0
do m = 1, ao_num
do j = 1, mo_num
do l = 1, mo_num
do i = 1, mo_num
do k = 1, mo_num
mo_bi_ortho_tc_two_e_chemist(k,i,l,j) += mo_r_coef_transp(j,m) * mo_tmp_1(k,i,l,m)
enddo
enddo
enddo
enddo
enddo
END_PROVIDER
! ---
double precision function bi_ortho_mo_ints(l, k, j, i)
BEGIN_DOC
! <mo^L_k mo^L_l | V^TC(r_12) | mo^R_i mo^R_j>
!
! WARNING :: very naive, super slow, only used to DEBUG.
END_DOC
implicit none
integer, intent(in) :: i, j, k, l
integer :: m, n, p, q
bi_ortho_mo_ints = 0.d0
do m = 1, ao_num
do p = 1, ao_num
do n = 1, ao_num
do q = 1, ao_num
! p1h1p2h2 l1 l2 r1 r2
bi_ortho_mo_ints += ao_two_e_tc_tot(n,q,m,p) * mo_l_coef(m,l) * mo_l_coef(n,k) * mo_r_coef(p,j) * mo_r_coef(q,i)
enddo
enddo
enddo
enddo
end function bi_ortho_mo_ints
! ---
! TODO :: transform into DEGEMM
BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC
!
! mo_bi_ortho_tc_two_e_chemist(k,i,l,j) = <k l|V(r_12)|i j> where i,j are right MOs and k,l are left MOs
!
END_DOC
implicit none
integer :: i, j, k, l, m, n, p, q
double precision, allocatable :: mo_tmp_1(:,:,:,:), mo_tmp_2(:,:,:,:)
allocate(mo_tmp_1(mo_num,ao_num,ao_num,ao_num))
mo_tmp_1 = 0.d0
do m = 1, ao_num
do p = 1, ao_num
do n = 1, ao_num
do q = 1, ao_num
do k = 1, mo_num
! (k n|p m) = sum_q c_qk * (q n|p m)
mo_tmp_1(k,n,p,m) += mo_l_coef_transp(k,q) * ao_two_e_tc_tot(q,n,p,m)
enddo
enddo
enddo
enddo
enddo
allocate(mo_tmp_2(mo_num,mo_num,ao_num,ao_num))
mo_tmp_2 = 0.d0
do m = 1, ao_num
do p = 1, ao_num
do n = 1, ao_num
do i = 1, mo_num
do k = 1, mo_num
! (k i|p m) = sum_n c_ni * (k n|p m)
mo_tmp_2(k,i,p,m) += mo_r_coef_transp(i,n) * mo_tmp_1(k,n,p,m)
enddo
enddo
enddo
enddo
enddo
deallocate(mo_tmp_1)
allocate(mo_tmp_1(mo_num,mo_num,mo_num,ao_num))
mo_tmp_1 = 0.d0
do m = 1, ao_num
do p = 1, ao_num
do l = 1, mo_num
do i = 1, mo_num
do k = 1, mo_num
mo_tmp_1(k,i,l,m) += mo_l_coef_transp(l,p) * mo_tmp_2(k,i,p,m)
enddo
enddo
enddo
enddo
enddo
deallocate(mo_tmp_2)
mo_bi_ortho_tc_two_e_chemist = 0.d0
do m = 1, ao_num
do j = 1, mo_num
do l = 1, mo_num
do i = 1, mo_num
do k = 1, mo_num
mo_bi_ortho_tc_two_e_chemist(k,i,l,j) += mo_r_coef_transp(j,m) * mo_tmp_1(k,i,l,m)
enddo
enddo
enddo
enddo
enddo
deallocate(mo_tmp_1)
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e, (mo_num, mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC
! mo_bi_ortho_tc_two_e(k,l,i,j) = <k l| V(r_12) |i j> where i,j are right MOs and k,l are left MOs
!
! the potential V(r_12) contains ALL TWO-E CONTRIBUTION OF THE TC-HAMILTONIAN
END_DOC
integer :: i,j,k,l
do j = 1, mo_num
do i = 1, mo_num
do l = 1, mo_num
do k = 1, mo_num
! (k i|l j) = <k l|V(r_12)|i j>
mo_bi_ortho_tc_two_e(k,l,i,j) = mo_bi_ortho_tc_two_e_chemist(k,i,l,j)
BEGIN_DOC
!
! mo_bi_ortho_tc_two_e(k,l,i,j) = <k l| V(r_12) |i j> where i,j are right MOs and k,l are left MOs
!
! the potential V(r_12) contains ALL TWO-E CONTRIBUTION OF THE TC-HAMILTONIAN
!
END_DOC
implicit none
integer :: i, j, k, l
do j = 1, mo_num
do i = 1, mo_num
do l = 1, mo_num
do k = 1, mo_num
! < k l | V12 | i j > (k i|l j)
mo_bi_ortho_tc_two_e(k,l,i,j) = mo_bi_ortho_tc_two_e_chemist(k,i,l,j)
enddo
enddo
enddo
enddo
enddo
enddo
END_PROVIDER
! ---

52
src/tc_bi_ortho/compute_deltamu_right.irp.f Normal file
View File

@ -0,0 +1,52 @@
program compute_deltamu_right
implicit none
my_grid_becke = .True.
my_n_pt_r_grid = 30
my_n_pt_a_grid = 50
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
read_wf = .True.
touch read_wf
PROVIDE N_int
call delta_right()
end
! ---
subroutine delta_right()
implicit none
integer :: k
double precision, allocatable :: delta(:,:)
print *, j1b_type
print *, j1b_pen
print *, mu_erf
allocate( delta(N_det,N_states) )
delta = 0.d0
do k = 1, N_states
!do k = 1, 1
! get < I_left | H_mu - H | psi_right >
call get_delta_bitc_right(psi_det, psi_r_coef_bi_ortho(:,k), N_det, N_int, delta(:,k))
! order as QMCCHEM
call dset_order(delta(:,k), psi_bilinear_matrix_order, N_det)
enddo
call ezfio_set_dmc_dress_dmc_delta_h(delta)
deallocate(delta)
return
end subroutine delta_right
! ---

54
src/tc_bi_ortho/dressing_vectors_lr.irp.f Normal file
View File

@ -0,0 +1,54 @@
! ---
subroutine get_delta_bitc_right(psidet, psicoef, ndet, Nint, delta)
BEGIN_DOC
!
! delta(I) = < I_left | H_TC - H | Psi_right >
!
END_DOC
use bitmasks
implicit none
integer, intent(in) :: ndet, Nint
double precision, intent(in) :: psicoef(ndet)
integer(bit_kind), intent(in) :: psidet(Nint,2,ndet)
double precision, intent(out) :: delta(ndet)
integer :: i, j
double precision :: h_mono, h_twoe, h_tot
double precision :: htc_mono, htc_twoe, htc_three, htc_tot
double precision :: delta_mat
i = 1
j = 1
call htilde_mu_mat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
call hmat_bi_ortho (psidet(1,1,i), psidet(1,1,j), Nint, h_mono , h_twoe , h_tot)
delta = 0.d0
!$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) &
!$OMP SHARED(delta, ndet, psidet, psicoef, Nint) &
!$OMP PRIVATE(i, j, delta_mat, h_mono, h_twoe, h_tot, &
!$OMP htc_mono, htc_twoe, htc_three, htc_tot)
do i = 1, ndet
do j = 1, ndet
! < I | Htilde | J >
call htilde_mu_mat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
! < I | H | J >
call hmat_bi_ortho (psidet(1,1,i), psidet(1,1,j), Nint, h_mono , h_twoe , h_tot)
delta_mat = htc_tot - h_tot
delta(i) = delta(i) + psicoef(j) * delta_mat
enddo
enddo
!$OMP END PARALLEL DO
end subroutine get_delta_bitc_right
! ---

249
src/tc_bi_ortho/h_biortho.irp.f Normal file
View File

@ -0,0 +1,249 @@
! --
subroutine hmat_bi_ortho(key_j, key_i, Nint, hmono, htwoe, htot)
BEGIN_DOC
!
! <key_j | H | key_i > where | key_j > is developed on the LEFT basis and | key_i > is developed on the RIGHT basis
!
END_DOC
use bitmasks
implicit none
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
double precision, intent(out) :: hmono, htwoe, htot
integer :: degree
hmono = 0.d0
htwoe = 0.d0
htot = 0.d0
call get_excitation_degree(key_i, key_j, degree, Nint)
if(degree .gt. 2) return
if(degree == 0) then
call diag_hmat_bi_ortho(Nint, key_i, hmono, htwoe)
htot = htot + nuclear_repulsion
else if (degree == 1)then
call single_hmat_bi_ortho(Nint, key_j, key_i, hmono, htwoe)
else if(degree == 2)then
call double_hmat_bi_ortho(Nint, key_j, key_i, hmono, htwoe)
endif
htot += hmono + htwoe
return
end subroutine hmat_bi_ortho
! ---
subroutine diag_hmat_bi_ortho(Nint, key_i, hmono, htwoe)
use bitmasks
implicit none
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key_i(Nint,2)
double precision, intent(out) :: hmono, htwoe
integer :: occ(Nint*bit_kind_size,2)
integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk
integer(bit_kind) :: key_i_core(Nint,2)
hmono = 0.d0
htwoe = 0.d0
call bitstring_to_list_ab(key_i, occ, Ne, Nint)
do ispin = 1, 2
do i = 1, Ne(ispin)
ii = occ(i,ispin)
hmono += mo_bi_ortho_one_e(ii,ii)
enddo
enddo
! alpha/beta two-body
ispin = 1
jspin = 2
do i = 1, Ne(ispin) ! electron 1
ii = occ(i,ispin)
do j = 1, Ne(jspin) ! electron 2
jj = occ(j,jspin)
htwoe += mo_bi_ortho_coul_e(jj,ii,jj,ii)
enddo
enddo
! alpha/alpha two-body
do i = 1, Ne(ispin)
ii = occ(i,ispin)
do j = i+1, Ne(ispin)
jj = occ(j,ispin)
htwoe += mo_bi_ortho_coul_e(ii,jj,ii,jj) - mo_bi_ortho_coul_e(ii,jj,jj,ii)
enddo
enddo
! beta/beta two-body
do i = 1, Ne(jspin)
ii = occ(i,jspin)
do j = i+1, Ne(jspin)
jj = occ(j,jspin)
htwoe += mo_bi_ortho_coul_e(ii,jj,ii,jj) - mo_bi_ortho_coul_e(ii,jj,jj,ii)
enddo
enddo
return
end subroutine diag_hmat_bi_ortho
! ---
subroutine single_hmat_bi_ortho(Nint, key_j, key_i, hmono, htwoe)
BEGIN_DOC
!
! < key_j | H | key_i > for single excitation
!
END_DOC
use bitmasks
implicit none
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2)
double precision, intent(out) :: hmono, htwoe
integer :: occ(Nint*bit_kind_size,2)
integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk
integer :: degree,exc(0:2,2,2)
integer :: h1, p1, h2, p2, s1, s2
integer :: other_spin(2)
integer(bit_kind) :: key_j_core(Nint,2), key_i_core(Nint,2)
double precision :: phase
double precision :: direct_int, exchange_int_12, exchange_int_23, exchange_int_13
other_spin(1) = 2
other_spin(2) = 1
hmono = 0.d0
htwoe = 0.d0
call get_excitation_degree(key_i, key_j, degree, Nint)
if(degree .ne. 1) then
return
endif
call bitstring_to_list_ab(key_i, occ, Ne, Nint)
call get_single_excitation(key_i, key_j, exc, phase, Nint)
call decode_exc(exc, 1, h1, p1, h2, p2, s1, s2)
hmono = mo_bi_ortho_one_e(p1,h1) * phase
! alpha/beta two-body
ispin = other_spin(s1)
if(s1 == 1) then
! single alpha
do i = 1, Ne(ispin) ! electron 2
ii = occ(i,ispin)
htwoe += mo_bi_ortho_coul_e(ii,p1,ii,h1)
enddo
else
! single beta
do i = 1, Ne(ispin) ! electron 1
ii = occ(i,ispin)
htwoe += mo_bi_ortho_coul_e(p1,ii,h1,ii)
enddo
endif
! same spin two-body
do i = 1, Ne(s1)
ii = occ(i,s1)
! ( h1 p1 |ii ii ) - ( h1 ii | p1 ii )
htwoe += mo_bi_ortho_coul_e(ii,p1,ii,h1) - mo_bi_ortho_coul_e(p1,ii,ii,h1)
enddo
htwoe *= phase
end subroutine single_hmat_bi_ortho
! ---
subroutine double_hmat_bi_ortho(Nint, key_j, key_i, hmono, htwoe)
BEGIN_DOC
!
! < key_j | H | key_i> for double excitation
!
END_DOC
use bitmasks
implicit none
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2)
double precision, intent(out) :: hmono, htwoe
integer :: occ(Nint*bit_kind_size,2)
integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk
integer :: degree,exc(0:2,2,2)
integer :: h1, p1, h2, p2, s1, s2
integer :: other_spin(2)
integer(bit_kind) :: key_i_core(Nint,2)
double precision :: phase
other_spin(1) = 2
other_spin(2) = 1
call get_excitation_degree(key_i, key_j, degree, Nint)
hmono = 0.d0
htwoe = 0.d0
if(degree .ne. 2) then
return
endif
call bitstring_to_list_ab(key_i, occ, Ne, Nint)
call get_double_excitation(key_i, key_j, exc, phase, Nint)
call decode_exc(exc, 2, h1, p1, h2, p2, s1, s2)
if(s1.ne.s2) then
htwoe = mo_bi_ortho_coul_e(p2,p1,h2,h1)
else
! same spin two-body
! direct terms
htwoe = mo_bi_ortho_coul_e(p2,p1,h2,h1)
! exchange terms
htwoe -= mo_bi_ortho_coul_e(p1,p2,h2,h1)
endif
htwoe *= phase
end subroutine double_hmat_bi_ortho
! ---

2
src/tc_bi_ortho/slater_tc.irp.f
View File

@ -24,7 +24,7 @@ subroutine htilde_mu_mat_bi_ortho_tot(key_j, key_i, Nint, htot)
call htilde_mu_mat_bi_ortho(key_j,key_i, Nint, hmono,htwoe,hthree,htot)
endif
end subroutine htilde_mu_mat_tot
end subroutine htilde_mu_mat_bi_ortho_tot
! --