LCPQ/qp2
9
1
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-12-30 15:15:38 +01:00
Code Releases Activity

renaming the routines in tc slater rules in _slow when they are naively built

Browse Source
This commit is contained in:
eginer 2023-05-22 18:17:17 +02:00
parent 1d5ff0df66
commit daf8b1c3dc
17 changed files with 97 additions and 111 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
src/tc_bi_ortho/dressing_vectors_lr.irp.f
View File

@ -27,7 +27,7 @@ subroutine get_delta_bitc_right(psidet, psicoef, ndet, Nint, delta)
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 htilde_mu_mat_bi_ortho_slow(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
@ -39,7 +39,7 @@ subroutine get_delta_bitc_right(psidet, psicoef, ndet, Nint, delta)
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)
call htilde_mu_mat_bi_ortho_slow(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)
@ -78,7 +78,7 @@ subroutine get_htc_bitc_right(psidet, psicoef, ndet, Nint, delta)
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 htilde_mu_mat_bi_ortho_slow(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
delta = 0.d0
!$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) &
@ -88,7 +88,7 @@ subroutine get_htc_bitc_right(psidet, psicoef, ndet, Nint, delta)
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)
call htilde_mu_mat_bi_ortho_slow(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
delta(i) = delta(i) + psicoef(j) * htc_tot
enddo

18
src/tc_bi_ortho/e_corr_bi_ortho.irp.f
View File

@ -2,7 +2,7 @@
BEGIN_PROVIDER [ double precision, e_tilde_00]
implicit none
double precision :: hmono,htwoe,hthree,htot
call htilde_mu_mat_bi_ortho(HF_bitmask,HF_bitmask,N_int,hmono,htwoe,hthree,htot)
call htilde_mu_mat_bi_ortho_slow(HF_bitmask,HF_bitmask,N_int,hmono,htwoe,hthree,htot)
e_tilde_00 = htot
END_PROVIDER
@ -18,11 +18,11 @@
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(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
call htilde_mu_mat_bi_ortho(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0)
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)
delta_e = e_tilde_00 - e_i0
coef_pt1 = htilde_ij / delta_e
call htilde_mu_mat_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
call htilde_mu_mat_bi_ortho_slow(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
e_pt2_tc_bi_orth += coef_pt1 * htilde_ij
if(degree == 1)then
e_pt2_tc_bi_orth_single += coef_pt1 * htilde_ij
@ -37,7 +37,7 @@
BEGIN_PROVIDER [ double precision, e_tilde_bi_orth_00]
implicit none
double precision :: hmono,htwoe,hthree,htilde_ij
call htilde_mu_mat_bi_ortho(HF_bitmask,HF_bitmask,N_int,hmono,htwoe,hthree,e_tilde_bi_orth_00)
call htilde_mu_mat_bi_ortho_slow(HF_bitmask,HF_bitmask,N_int,hmono,htwoe,hthree,e_tilde_bi_orth_00)
e_tilde_bi_orth_00 += nuclear_repulsion
END_PROVIDER
@ -57,7 +57,7 @@
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(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
call htilde_mu_mat_bi_ortho_slow(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
if(degree == 1)then
e_corr_single_bi_orth += reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1)
e_corr_single_bi_orth_abs += dabs(reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1))
@ -80,7 +80,7 @@
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(psi_det(1,1,j),psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j),psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
e_tc_left_right += htilde_ij * reigvec_tc_bi_orth(i,1) * leigvec_tc_bi_orth(j,1)
enddo
enddo
@ -99,8 +99,8 @@ BEGIN_PROVIDER [ double precision, coef_pt1_bi_ortho, (N_det)]
if(degree==0)then
coef_pt1_bi_ortho(i) = 1.d0
else
call htilde_mu_mat_bi_ortho(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
call htilde_mu_mat_bi_ortho(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0)
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)
delta_e = e_tilde_00 - e_i0
coef_pt1 = htilde_ij / delta_e
coef_pt1_bi_ortho(i)= coef_pt1

12
src/tc_bi_ortho/h_tc_bi_ortho_psi.irp.f
View File

@ -1,4 +1,4 @@
subroutine htc_bi_ortho_calc_tdav(v, u, N_st, sze)
subroutine htc_bi_ortho_calc_tdav_slow(v, u, N_st, sze)
use bitmasks
@ -27,7 +27,7 @@ subroutine htc_bi_ortho_calc_tdav(v, u, N_st, sze)
i = 1
j = 1
call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,j), N_int, htot)
call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,i), psi_det(1,1,j), N_int, htot)
v = 0.d0
!$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) &
@ -36,7 +36,7 @@ subroutine htc_bi_ortho_calc_tdav(v, u, N_st, sze)
do istate = 1, N_st
do i = 1, sze
do j = 1, sze
call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,j), N_int, htot)
call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,i), psi_det(1,1,j), N_int, htot)
v(i,istate) = v(i,istate) + htot * u(j,istate)
enddo
enddo
@ -45,7 +45,7 @@ subroutine htc_bi_ortho_calc_tdav(v, u, N_st, sze)
end
subroutine htcdag_bi_ortho_calc_tdav(v, u, N_st, sze)
subroutine htcdag_bi_ortho_calc_tdav_slow(v, u, N_st, sze)
use bitmasks
@ -71,7 +71,7 @@ subroutine htcdag_bi_ortho_calc_tdav(v, u, N_st, sze)
i = 1
j = 1
call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,j), N_int, htot)
call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,i), psi_det(1,1,j), N_int, htot)
v = 0.d0
@ -81,7 +81,7 @@ subroutine htcdag_bi_ortho_calc_tdav(v, u, N_st, sze)
do istate = 1, N_st
do i = 1, sze
do j = 1, sze
call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,j), psi_det(1,1,i), N_int, htot)
call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, htot)
v(i,istate) = v(i,istate) + htot * u(j,istate)
enddo
enddo

6
src/tc_bi_ortho/print_tc_wf.irp.f
View File

@ -49,12 +49,12 @@ subroutine routine
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(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
call htilde_mu_mat_bi_ortho(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0)
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)
delta_e = e_tilde_00 - e_i0
coef_pt1 = htilde_ij / delta_e
call htilde_mu_mat_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
call htilde_mu_mat_bi_ortho_slow(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
contrib_pt = coef_pt1 * htilde_ij
e_pt2 += contrib_pt

8
src/tc_bi_ortho/pt2_tc_cisd.irp.f
View File

@ -36,11 +36,11 @@ subroutine routine
e_corr_abs = 0.d0
e_corr_pos = 0.d0
e_corr_neg = 0.d0
call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,1), psi_det(1,1,1), N_int, e00)
call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,1), psi_det(1,1,1), N_int, e00)
do i = 2, N_det
call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,1), N_int, hi0)
call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,1), psi_det(1,1,i), N_int, h0i)
call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,i), N_int, ei)
call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,i), psi_det(1,1,1), N_int, hi0)
call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,1), psi_det(1,1,i), N_int, h0i)
call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,i), psi_det(1,1,i), N_int, ei)
call get_excitation_degree(psi_det(1,1,1), psi_det(1,1,i),degree,N_int)
call get_excitation(psi_det(1,1,1), psi_det(1,1,i),exc,degree,phase,N_int)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)

28
src/tc_bi_ortho/slater_tc_3e.irp.f → src/tc_bi_ortho/slater_tc_3e_slow.irp.f
View File

@ -1,27 +1,5 @@
subroutine provide_all_three_ints_bi_ortho
implicit none
BEGIN_DOC
! routine that provides all necessary three-electron integrals
END_DOC
if(three_body_h_tc)then
if(three_e_3_idx_term)then
PROVIDE three_e_3_idx_direct_bi_ort three_e_3_idx_cycle_1_bi_ort three_e_3_idx_cycle_2_bi_ort
PROVIDE three_e_3_idx_exch23_bi_ort three_e_3_idx_exch13_bi_ort three_e_3_idx_exch12_bi_ort
endif
if(three_e_4_idx_term)then
PROVIDE three_e_4_idx_direct_bi_ort three_e_4_idx_cycle_1_bi_ort three_e_4_idx_cycle_2_bi_ort
PROVIDE three_e_4_idx_exch23_bi_ort three_e_4_idx_exch13_bi_ort three_e_4_idx_exch12_bi_ort
endif
if(.not.double_normal_ord.and.three_e_5_idx_term)then
PROVIDE three_e_5_idx_direct_bi_ort three_e_5_idx_cycle_1_bi_ort three_e_5_idx_cycle_2_bi_ort
PROVIDE three_e_5_idx_exch23_bi_ort three_e_5_idx_exch13_bi_ort three_e_5_idx_exch12_bi_ort
elseif (double_normal_ord .and. (.not. three_e_5_idx_term))then
PROVIDE normal_two_body_bi_orth
endif
endif
end
subroutine diag_htilde_three_body_ints_bi_ort(Nint, key_i, hthree)
subroutine diag_htilde_three_body_ints_bi_ort_slow(Nint, key_i, hthree)
BEGIN_DOC
! diagonal element of htilde ONLY FOR THREE-BODY TERMS WITH BI ORTHONORMAL ORBITALS
@ -112,7 +90,7 @@ subroutine diag_htilde_three_body_ints_bi_ort(Nint, key_i, hthree)
end
subroutine single_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree)
subroutine single_htilde_three_body_ints_bi_ort_slow(Nint, key_j, key_i, hthree)
BEGIN_DOC
! <key_j | H_tilde | key_i> for single excitation ONLY FOR THREE-BODY TERMS WITH BI ORTHONORMAL ORBITALS
@ -207,7 +185,7 @@ end
! ---
subroutine double_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree)
subroutine double_htilde_three_body_ints_bi_ort_slow(Nint, key_j, key_i, hthree)
BEGIN_DOC
! <key_j | H_tilde | key_i> for double excitation ONLY FOR THREE-BODY TERMS WITH BI ORTHONORMAL ORBITALS

23
src/tc_bi_ortho/slater_tc_opt.irp.f
View File

@ -1,3 +1,26 @@
subroutine provide_all_three_ints_bi_ortho
implicit none
BEGIN_DOC
! routine that provides all necessary three-electron integrals
END_DOC
if(three_body_h_tc)then
if(three_e_3_idx_term)then
PROVIDE three_e_3_idx_direct_bi_ort three_e_3_idx_cycle_1_bi_ort three_e_3_idx_cycle_2_bi_ort
PROVIDE three_e_3_idx_exch23_bi_ort three_e_3_idx_exch13_bi_ort three_e_3_idx_exch12_bi_ort
endif
if(three_e_4_idx_term)then
PROVIDE three_e_4_idx_direct_bi_ort three_e_4_idx_cycle_1_bi_ort three_e_4_idx_cycle_2_bi_ort
PROVIDE three_e_4_idx_exch23_bi_ort three_e_4_idx_exch13_bi_ort three_e_4_idx_exch12_bi_ort
endif
if(.not.double_normal_ord.and.three_e_5_idx_term)then
PROVIDE three_e_5_idx_direct_bi_ort three_e_5_idx_cycle_1_bi_ort three_e_5_idx_cycle_2_bi_ort
PROVIDE three_e_5_idx_exch23_bi_ort three_e_5_idx_exch13_bi_ort three_e_5_idx_exch12_bi_ort
elseif (double_normal_ord .and. (.not. three_e_5_idx_term))then
PROVIDE normal_two_body_bi_orth
endif
endif
end
subroutine htilde_mu_mat_opt_bi_ortho_tot(key_j, key_i, Nint, htot)
implicit none
BEGIN_DOC

4
src/tc_bi_ortho/slater_tc_opt_diag.irp.f
View File

@ -7,11 +7,11 @@
! Various component of the TC energy for the reference "HF" Slater determinant
END_DOC
double precision :: hmono, htwoe, htot, hthree
call diag_htilde_mu_mat_bi_ortho(N_int,HF_bitmask , hmono, htwoe, htot)
call diag_htilde_mu_mat_bi_ortho_slow(N_int,HF_bitmask , hmono, htwoe, htot)
ref_tc_energy_1e = hmono
ref_tc_energy_2e = htwoe
if(three_body_h_tc)then
call diag_htilde_three_body_ints_bi_ort(N_int, HF_bitmask, hthree)
call diag_htilde_three_body_ints_bi_ort_slow(N_int, HF_bitmask, hthree)
ref_tc_energy_3e = hthree
else
ref_tc_energy_3e = 0.d0

47
src/tc_bi_ortho/slater_tc.irp.f → src/tc_bi_ortho/slater_tc_slow.irp.f
View File

@ -1,7 +1,7 @@
! ---
subroutine htilde_mu_mat_bi_ortho_tot(key_j, key_i, Nint, htot)
subroutine htilde_mu_mat_bi_ortho_tot_slow(key_j, key_i, Nint, htot)
BEGIN_DOC
! <key_j | H_tilde | key_i> where |key_j> is developed on the LEFT basis and |key_i> is developed on the RIGHT basis
@ -24,14 +24,14 @@ subroutine htilde_mu_mat_bi_ortho_tot(key_j, key_i, Nint, htot)
if(degree.gt.2)then
htot = 0.d0
else
call htilde_mu_mat_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree, htot)
call htilde_mu_mat_bi_ortho_slow(key_j, key_i, Nint, hmono, htwoe, hthree, htot)
endif
end subroutine htilde_mu_mat_bi_ortho_tot
end subroutine htilde_mu_mat_bi_ortho_tot_slow
! --
subroutine htilde_mu_mat_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree, htot)
subroutine htilde_mu_mat_bi_ortho_slow(key_j, key_i, Nint, hmono, htwoe, hthree, htot)
BEGIN_DOC
!
@ -61,22 +61,22 @@ subroutine htilde_mu_mat_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree, htot
if(degree.gt.2) return
if(degree == 0)then
call diag_htilde_mu_mat_bi_ortho(Nint, key_i, hmono, htwoe, htot)
call diag_htilde_mu_mat_bi_ortho_slow(Nint, key_i, hmono, htwoe, htot)
else if (degree == 1)then
call single_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot)
call single_htilde_mu_mat_bi_ortho_slow(Nint, key_j, key_i, hmono, htwoe, htot)
else if(degree == 2)then
call double_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot)
call double_htilde_mu_mat_bi_ortho_slow(Nint, key_j, key_i, hmono, htwoe, htot)
endif
if(three_body_h_tc) then
if(degree == 2) then
if(.not.double_normal_ord) then
call double_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree)
if(.not.double_normal_ord.and.elec_num.gt.2.and.three_e_5_idx_term) then
call double_htilde_three_body_ints_bi_ort_slow(Nint, key_j, key_i, hthree)
endif
else if(degree == 1) then
call single_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree)
else if(degree == 0) then
call diag_htilde_three_body_ints_bi_ort(Nint, key_i, hthree)
else if(degree == 1.and.elec_num.gt.2.and.three_e_4_idx_term) then
call single_htilde_three_body_ints_bi_ort_slow(Nint, key_j, key_i, hthree)
else if(degree == 0.and.elec_num.gt.2.and.three_e_3_idx_term) then
call diag_htilde_three_body_ints_bi_ort_slow(Nint, key_i, hthree)
endif
endif
@ -89,7 +89,7 @@ end
! ---
subroutine diag_htilde_mu_mat_bi_ortho(Nint, key_i, hmono, htwoe, htot)
subroutine diag_htilde_mu_mat_bi_ortho_slow(Nint, key_i, hmono, htwoe, htot)
BEGIN_DOC
! diagonal element of htilde ONLY FOR ONE- AND TWO-BODY TERMS
@ -188,7 +188,7 @@ end
subroutine double_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot)
subroutine double_htilde_mu_mat_bi_ortho_slow(Nint, key_j, key_i, hmono, htwoe, htot)
BEGIN_DOC
! <key_j | H_tilde | key_i> for double excitation ONLY FOR ONE- AND TWO-BODY TERMS
@ -227,18 +227,7 @@ subroutine double_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot)
return
endif
! if(core_tc_op)then
! print*,'core_tc_op not already taken into account for bi ortho'
! print*,'stopping ...'
! stop
! do i = 1, Nint
! key_i_core(i,1) = xor(key_i(i,1),core_bitmask(i,1))
! key_i_core(i,2) = xor(key_i(i,2),core_bitmask(i,2))
! enddo
! call bitstring_to_list_ab(key_i_core, occ, Ne, Nint)
! else
call bitstring_to_list_ab(key_i, occ, Ne, Nint)
! endif
call get_double_excitation(key_i, key_j, exc, phase, Nint)
call decode_exc(exc, 2, h1, p1, h2, p2, s1, s2)
@ -246,7 +235,7 @@ subroutine double_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot)
! opposite spin two-body
! key_j, key_i
htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)
if(double_normal_ord.and.+Ne(1).gt.2)then
if(three_body_h_tc.and.double_normal_ord.and.+Ne(1).gt.2)then
htwoe += normal_two_body_bi_orth(p2,h2,p1,h1)!!! WTF ???
endif
else
@ -255,7 +244,7 @@ subroutine double_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot)
htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)
! exchange terms
htwoe -= mo_bi_ortho_tc_two_e(p1,p2,h2,h1)
if(double_normal_ord.and.+Ne(1).gt.2)then
if(three_body_h_tc.and.double_normal_ord.and.+Ne(1).gt.2)then
htwoe -= normal_two_body_bi_orth(h2,p1,h1,p2)!!! WTF ???
htwoe += normal_two_body_bi_orth(h1,p1,h2,p2)!!! WTF ???
endif
@ -266,7 +255,7 @@ subroutine double_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot)
end
subroutine single_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot)
subroutine single_htilde_mu_mat_bi_ortho_slow(Nint, key_j, key_i, hmono, htwoe, htot)
BEGIN_DOC
! <key_j | H_tilde | key_i> for single excitation ONLY FOR ONE- AND TWO-BODY TERMS

12
src/tc_bi_ortho/tc_cisd_sc2_utils.irp.f
View File

@ -11,10 +11,10 @@
allocate(H_jj(N_det),vec_tmp(N_det,n_states_diag),eigval_tmp(N_states))
dressing_dets = 0.d0
do i = 1, N_det
call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,i), N_int, H_jj(i))
call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,i), psi_det(1,1,i), N_int, H_jj(i))
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(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,h0j(i))
call htilde_mu_mat_bi_ortho_slow(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,h0j(i))
endif
enddo
reigvec_tc_bi_orth_tmp = 0.d0
@ -29,7 +29,7 @@
vec_tmp(istate,istate) = 1.d0
enddo
print*,'Diagonalizing the TC CISD '
call davidson_general_diag_dressed_ext_rout_nonsym_b1space(vec_tmp, H_jj, dressing_dets,eigval_tmp, N_det, n_states, n_states_diag, converged, htc_bi_ortho_calc_tdav)
call davidson_general_diag_dressed_ext_rout_nonsym_b1space(vec_tmp, H_jj, dressing_dets,eigval_tmp, N_det, n_states, n_states_diag, converged, htc_bi_ortho_calc_tdav_slow)
do i = 1, N_det
e_corr_dets(i) = reigvec_tc_bi_orth_tmp(i,1) * h0j(i)/reigvec_tc_bi_orth_tmp(1,1)
enddo
@ -41,8 +41,8 @@
it = 0
dressing_dets = 0.d0
double precision, allocatable :: H_jj(:),vec_tmp(:,:),eigval_tmp(:)
external htc_bi_ortho_calc_tdav
external htcdag_bi_ortho_calc_tdav
external htc_bi_ortho_calc_tdav_slow
external htcdag_bi_ortho_calc_tdav_slow
logical :: converged
do while (dabs(E_before-E_current).gt.thr)
it += 1
@ -66,7 +66,7 @@
do istate = N_states+1, n_states_diag
vec_tmp(istate,istate) = 1.d0
enddo
call davidson_general_diag_dressed_ext_rout_nonsym_b1space(vec_tmp, H_jj, dressing_dets,eigval_tmp, N_det, n_states, n_states_diag, converged, htc_bi_ortho_calc_tdav)
call davidson_general_diag_dressed_ext_rout_nonsym_b1space(vec_tmp, H_jj, dressing_dets,eigval_tmp, N_det, n_states, n_states_diag, converged, htc_bi_ortho_calc_tdav_slow)
print*,'outside Davidson'
print*,'eigval_tmp(1) = ',eigval_tmp(1)
do i = 1, N_det

5
src/tc_bi_ortho/tc_h_eigvectors.irp.f
View File

@ -207,8 +207,6 @@ end
else ! n_det > N_det_max_full
double precision, allocatable :: H_jj(:),vec_tmp(:,:)
external htc_bi_ortho_calc_tdav
external htcdag_bi_ortho_calc_tdav
external H_tc_u_0_opt
external H_tc_dagger_u_0_opt
external H_tc_s2_dagger_u_0_opt
@ -217,7 +215,7 @@ end
allocate(H_jj(N_det),vec_tmp(N_det,n_states_diag))
do i = 1, N_det
call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,i), N_int, H_jj(i))
call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,i), psi_det(1,1,i), N_int, H_jj(i))
enddo
print*,'---------------------------------'
@ -259,7 +257,6 @@ end
do istate = N_states+1, n_states_diag
vec_tmp(istate,istate) = 1.d0
enddo
!call davidson_general_ext_rout_nonsym_b1space(vec_tmp, H_jj, eigval_right_tc_bi_orth, N_det, n_states, n_states_diag, converged, htc_bi_ortho_calc_tdav)
!call davidson_general_ext_rout_nonsym_b1space(vec_tmp, H_jj, eigval_right_tc_bi_orth, N_det, n_states, n_states_diag, converged, H_tc_u_0_opt)
converged = .False.
i_it = 0

4
src/tc_bi_ortho/tc_som.irp.f
View File

@ -56,8 +56,8 @@ subroutine main()
U_SOM = 0.d0
do i = 1, N_det
if(i == i_HF) cycle
call htilde_mu_mat_bi_ortho(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(psi_det(1,1,i), psi_det(1,1,i_HF), N_int, hmono_2, htwoe_2, hthree_2, htot_2)
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

4
src/tc_bi_ortho/tc_utils.irp.f
View File

@ -12,7 +12,7 @@ subroutine write_tc_energy()
do i = 1, N_det
do j = 1, N_det
!htot = htilde_matrix_elmt_bi_ortho(i,j)
call htilde_mu_mat_bi_ortho(psi_det(1,1,i), psi_det(1,1,j), N_int, hmono, htwoe, hthree, htot)
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_TC = E_TC + leigvec_tc_bi_orth(i,k) * reigvec_tc_bi_orth(j,k) * htot
enddo
@ -45,7 +45,7 @@ subroutine write_tc_var()
SIGMA_TC = 0.d0
do j = 2, N_det
call htilde_mu_mat_bi_ortho(psi_det(1,1,1), psi_det(1,1,j), N_int, hmono, htwoe, hthree, htot)
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,1), psi_det(1,1,j), N_int, hmono, htwoe, hthree, htot)
SIGMA_TC = SIGMA_TC + htot * htot
enddo

6
src/tc_bi_ortho/test_normal_order.irp.f
View File

@ -35,7 +35,7 @@ subroutine test
det_i = ref_bitmask
call do_single_excitation(det_i,h1,p1,s1,i_ok)
call do_single_excitation(det_i,h2,p2,s2,i_ok)
call htilde_mu_mat_bi_ortho(det_i,HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
call htilde_mu_mat_bi_ortho_slow(det_i,HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
call get_excitation_degree(ref_bitmask,det_i,degree,N_int)
call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int)
hthree *= phase
@ -67,7 +67,7 @@ do h1 = 1, elec_alpha_num
if(i_ok.ne.1)cycle
call do_single_excitation(det_i,h2,p2,s2,i_ok)
if(i_ok.ne.1)cycle
call htilde_mu_mat_bi_ortho(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
call htilde_mu_mat_bi_ortho_slow(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
call get_excitation_degree(ref_bitmask,det_i,degree,N_int)
call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int)
integer :: hh1, pp1, hh2, pp2, ss1, ss2
@ -103,7 +103,7 @@ do h1 = 1, elec_beta_num
if(i_ok.ne.1)cycle
call do_single_excitation(det_i,h2,p2,s2,i_ok)
if(i_ok.ne.1)cycle
call htilde_mu_mat_bi_ortho(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
call htilde_mu_mat_bi_ortho_slow(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
call get_excitation_degree(ref_bitmask,det_i,degree,N_int)
call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int)
call decode_exc(exc, 2, hh1, pp1, hh2, pp2, ss1, ss2)

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

@ -91,7 +91,7 @@ subroutine routine_test_s2_davidson
external H_tc_s2_u_0_opt
allocate(H_jj(N_det),vec_tmp(N_det,n_states_diag),energies(n_states_diag), s2(n_states_diag))
do i = 1, N_det
call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,i), N_int, H_jj(i))
call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,i), psi_det(1,1,i), N_int, H_jj(i))
enddo
! Preparing the left-eigenvector
print*,'Computing the left-eigenvector '

14
src/tc_bi_ortho/test_tc_bi_ortho.irp.f
View File

@ -31,7 +31,7 @@ subroutine test_h_u0
u_0(i) = psi_r_coef_bi_ortho(i,1)
enddo
call H_tc_u_0_nstates_openmp(v_0_new,u_0,N_states,N_det, do_right)
call htc_bi_ortho_calc_tdav (v_0_ref,u_0,N_states,N_det)
call htc_bi_ortho_calc_tdav_slow (v_0_ref,u_0,N_states,N_det)
print*,'difference right '
accu = 0.d0
do i = 1, N_det
@ -42,7 +42,7 @@ subroutine test_h_u0
do_right = .False.
v_0_new = 0.d0
call H_tc_u_0_nstates_openmp(v_0_new,u_0,N_states,N_det, do_right)
call htcdag_bi_ortho_calc_tdav(v_0_ref_dagger,u_0,N_states,N_det, do_right)
call htcdag_bi_ortho_calc_tdav_slow(v_0_ref_dagger,u_0,N_states,N_det, do_right)
print*,'difference left'
accu = 0.d0
do i = 1, N_det
@ -63,7 +63,7 @@ subroutine test_slater_tc_opt
i_count = 0.d0
do i = 1, N_det
do j = 1,N_det
call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hnewmono, hnewtwoe, hnewthree, hnewtot)
if(dabs(htot).gt.1.d-15)then
i_count += 1.D0
@ -99,7 +99,7 @@ subroutine timing_tot
do j = 1, N_det
! call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
i_count += 1.d0
call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
enddo
enddo
call wall_time(wall1)
@ -146,7 +146,7 @@ subroutine timing_diag
do i = 1, N_det
do j = i,i
i_count += 1.d0
call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
enddo
enddo
call wall_time(wall1)
@ -183,7 +183,7 @@ subroutine timing_single
if(degree.ne.1)cycle
i_count += 1.d0
call wall_time(wall0)
call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
call wall_time(wall1)
accu += wall1 - wall0
enddo
@ -225,7 +225,7 @@ subroutine timing_double
if(degree.ne.2)cycle
i_count += 1.d0
call wall_time(wall0)
call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
call wall_time(wall1)
accu += wall1 - wall0
enddo

7
src/tc_bi_ortho/test_tc_fock.irp.f
View File

@ -25,8 +25,7 @@ subroutine test_3e
implicit none
double precision :: integral_aaa,integral_aab,integral_abb,integral_bbb,accu
double precision :: hmono, htwoe, hthree, htot
call htilde_mu_mat_bi_ortho(ref_bitmask, ref_bitmask, N_int, hmono, htwoe, hthree, htot)
! call diag_htilde_three_body_ints_bi_ort(N_int, ref_bitmask, hthree)
call htilde_mu_mat_bi_ortho_slow(ref_bitmask, ref_bitmask, N_int, hmono, htwoe, hthree, htot)
print*,'hmono = ',hmono
print*,'htwoe = ',htwoe
print*,'hthree= ',hthree
@ -88,7 +87,7 @@ subroutine routine_3()
print*, ' excited det'
call debug_det(det_i, N_int)
call htilde_mu_mat_bi_ortho(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij)
call htilde_mu_mat_bi_ortho_slow(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij)
if(dabs(hthree).lt.1.d-10)cycle
ref = hthree
if(s1 == 1)then
@ -156,7 +155,7 @@ subroutine routine_tot()
stop
endif
call htilde_mu_mat_bi_ortho(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij)
call htilde_mu_mat_bi_ortho_slow(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij)
print*,htilde_ij
if(dabs(htilde_ij).lt.1.d-10)cycle
print*, ' excited det'