PTEROSOR/QuantumPackage
10
0
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-11-15 02:23:51 +01:00
Code Releases Activity

noL dredding

Browse Source
This commit is contained in:
AbdAmmar 2023-09-12 20:43:54 +02:00
parent e288c40d8b
commit 677b58ae61
10 changed files with 123 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
src/tc_bi_ortho/no_dressing_naive.irp.f → src/bi_ort_ints/no_dressing_naive.irp.f
View File

@ -1,7 +1,7 @@
! ---
BEGIN_PROVIDER [double precision, no_0_naive]
BEGIN_PROVIDER [double precision, noL_0e_naive]
implicit none
integer :: ii, jj, kk
@ -11,7 +11,7 @@ BEGIN_PROVIDER [double precision, no_0_naive]
double precision :: t0, t1
double precision, allocatable :: tmp(:)
print*, " Providing no_0_naive ..."
print*, " Providing noL_0e_naive ..."
call wall_time(t0)
allocate(tmp(elec_num))
@ -89,24 +89,24 @@ BEGIN_PROVIDER [double precision, no_0_naive]
!$OMP END DO
!$OMP END PARALLEL
no_0_naive = -1.d0 * (-sum(tmp)) / 6.d0
noL_0e_naive = -1.d0 * (-sum(tmp)) / 6.d0
deallocate(tmp)
call wall_time(t1)
print*, " Wall time for no_0_naive (min) = ", (t1 - t0)/60.d0
print*, " Wall time for noL_0e_naive (min) = ", (t1 - t0)/60.d0
print*, " no_0_naive = ", no_0_naive
print*, " noL_0e_naive = ", noL_0e_naive
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, no_1_naive, (mo_num, mo_num)]
BEGIN_PROVIDER [double precision, noL_1e_naive, (mo_num, mo_num)]
BEGIN_DOC
!
! < p | H(1) | s > is dressed with no_1_naive(p,s)
! < p | H(1) | s > is dressed with noL_1e_naive(p,s)
!
END_DOC
@ -117,7 +117,7 @@ BEGIN_PROVIDER [double precision, no_1_naive, (mo_num, mo_num)]
double precision :: I_pij_sji, I_pij_sij, I_pij_jis, I_pij_ijs, I_pij_isj, I_pij_jsi
double precision :: t0, t1
print*, " Providing no_1_naive ..."
print*, " Providing noL_1e_naive ..."
call wall_time(t0)
! ----
@ -132,14 +132,14 @@ BEGIN_PROVIDER [double precision, no_1_naive, (mo_num, mo_num)]
!$OMP I_pij_sji, I_pij_sij, I_pij_jis, &
!$OMP I_pij_ijs, I_pij_isj, I_pij_jsi ) &
!$OMP SHARED (mo_num, elec_beta_num, elec_num, &
!$OMP sigma_p, sigma_s, no_1_naive)
!$OMP sigma_p, sigma_s, noL_1e_naive)
!$OMP DO COLLAPSE (2)
do s = 1, mo_num
do p = 1, mo_num
no_1_naive(p,s) = 0.d0
noL_1e_naive(p,s) = 0.d0
do ii = 1, elec_num
if(ii .le. elec_beta_num) then
i = ii
@ -184,7 +184,7 @@ BEGIN_PROVIDER [double precision, no_1_naive, (mo_num, mo_num)]
! x (-1) because integrals are over -L
! x 0.5 because we consider 0.5 (up + down)
no_1_naive(p,s) = no_1_naive(p,s) + 0.25d0 * (I_pij_sji - I_pij_sij + I_pij_jis - I_pij_ijs + I_pij_isj - I_pij_jsi)
noL_1e_naive(p,s) = noL_1e_naive(p,s) + 0.25d0 * (I_pij_sji - I_pij_sij + I_pij_jis - I_pij_ijs + I_pij_isj - I_pij_jsi)
enddo ! j
enddo ! i
enddo ! s
@ -205,7 +205,7 @@ BEGIN_PROVIDER [double precision, no_1_naive, (mo_num, mo_num)]
!$OMP I_pij_sji, I_pij_sij, I_pij_jis, &
!$OMP I_pij_ijs, I_pij_isj, I_pij_jsi ) &
!$OMP SHARED (mo_num, elec_beta_num, elec_num, &
!$OMP sigma_p, sigma_s, no_1_naive)
!$OMP sigma_p, sigma_s, noL_1e_naive)
!$OMP DO COLLAPSE (2)
@ -256,7 +256,7 @@ BEGIN_PROVIDER [double precision, no_1_naive, (mo_num, mo_num)]
! x (-1) because integrals are over -L
! x 0.5 because we consider 0.5 (up + down)
no_1_naive(p,s) = no_1_naive(p,s) + 0.25d0 * (I_pij_sji - I_pij_sij + I_pij_jis - I_pij_ijs + I_pij_isj - I_pij_jsi)
noL_1e_naive(p,s) = noL_1e_naive(p,s) + 0.25d0 * (I_pij_sji - I_pij_sij + I_pij_jis - I_pij_ijs + I_pij_isj - I_pij_jsi)
enddo ! j
enddo ! i
enddo ! s
@ -267,17 +267,17 @@ BEGIN_PROVIDER [double precision, no_1_naive, (mo_num, mo_num)]
! ---
call wall_time(t1)
print*, " Wall time for no_1_naive (min) = ", (t1 - t0)/60.d0
print*, " Wall time for noL_1e_naive (min) = ", (t1 - t0)/60.d0
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, no_2_naive, (mo_num, mo_num, mo_num, mo_num)]
BEGIN_PROVIDER [double precision, noL_2e_naive, (mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC
!
! < p q | H(2) | s t > is dressed with no_2_naive(p,q,s,t)
! < p q | H(2) | s t > is dressed with noL_2e_naive(p,q,s,t)
!
END_DOC
@ -288,7 +288,7 @@ BEGIN_PROVIDER [double precision, no_2_naive, (mo_num, mo_num, mo_num, mo_num)]
double precision :: I_ipq_ist, I_ipq_sit, I_ipq_tsi
double precision :: t0, t1
print*, " Providing no_2_naive ..."
print*, " Providing noL_2e_naive ..."
call wall_time(t0)
! ----
@ -305,7 +305,7 @@ BEGIN_PROVIDER [double precision, no_2_naive, (mo_num, mo_num, mo_num, mo_num)]
!$OMP I_ipq_ist, I_ipq_sit, I_ipq_tsi) &
!$OMP SHARED (mo_num, elec_beta_num, elec_num, &
!$OMP sigma_p, sigma_q, sigma_s, sigma_t, &
!$OMP no_2_naive)
!$OMP noL_2e_naive)
!$OMP DO COLLAPSE (4)
do t = 1, mo_num
@ -313,7 +313,7 @@ BEGIN_PROVIDER [double precision, no_2_naive, (mo_num, mo_num, mo_num, mo_num)]
do q = 1, mo_num
do p = 1, mo_num
no_2_naive(p,q,s,t) = 0.d0
noL_2e_naive(p,q,s,t) = 0.d0
do ii = 1, elec_num
if(ii .le. elec_beta_num) then
i = ii
@ -337,7 +337,7 @@ BEGIN_PROVIDER [double precision, no_2_naive, (mo_num, mo_num, mo_num, mo_num)]
! x (-1) because integrals are over -L
! x 0.25 because we consider 0.25 (up-up + up-down + down-up + down-down)
no_2_naive(p,q,s,t) = no_2_naive(p,q,s,t) + 0.125d0 * (I_ipq_ist - I_ipq_sit - I_ipq_tsi)
noL_2e_naive(p,q,s,t) = noL_2e_naive(p,q,s,t) + 0.125d0 * (I_ipq_ist - I_ipq_sit - I_ipq_tsi)
enddo ! i
enddo ! p
enddo ! q
@ -360,7 +360,7 @@ BEGIN_PROVIDER [double precision, no_2_naive, (mo_num, mo_num, mo_num, mo_num)]
!$OMP I_ipq_ist, I_ipq_sit, I_ipq_tsi) &
!$OMP SHARED (mo_num, elec_beta_num, elec_num, &
!$OMP sigma_p, sigma_q, sigma_s, sigma_t, &
!$OMP no_2_naive)
!$OMP noL_2e_naive)
!$OMP DO COLLAPSE (4)
do t = 1, mo_num
@ -391,7 +391,7 @@ BEGIN_PROVIDER [double precision, no_2_naive, (mo_num, mo_num, mo_num, mo_num)]
! x (-1) because integrals are over -L
! x 0.25 because we consider 0.25 (up-up + up-down + down-up + down-down)
no_2_naive(p,q,s,t) = no_2_naive(p,q,s,t) + 0.125d0 * (I_ipq_ist - I_ipq_sit - I_ipq_tsi)
noL_2e_naive(p,q,s,t) = noL_2e_naive(p,q,s,t) + 0.125d0 * (I_ipq_ist - I_ipq_sit - I_ipq_tsi)
enddo ! i
enddo ! p
enddo ! q
@ -414,7 +414,7 @@ BEGIN_PROVIDER [double precision, no_2_naive, (mo_num, mo_num, mo_num, mo_num)]
!$OMP I_ipq_ist, I_ipq_sit, I_ipq_tsi) &
!$OMP SHARED (mo_num, elec_beta_num, elec_num, &
!$OMP sigma_p, sigma_q, sigma_s, sigma_t, &
!$OMP no_2_naive)
!$OMP noL_2e_naive)
!$OMP DO COLLAPSE (4)
do t = 1, mo_num
@ -445,7 +445,7 @@ BEGIN_PROVIDER [double precision, no_2_naive, (mo_num, mo_num, mo_num, mo_num)]
! x (-1) because integrals are over -L
! x 0.25 because we consider 0.25 (up-up + up-down + down-up + down-down)
no_2_naive(p,q,s,t) = no_2_naive(p,q,s,t) + 0.125d0 * (I_ipq_ist - I_ipq_sit - I_ipq_tsi)
noL_2e_naive(p,q,s,t) = noL_2e_naive(p,q,s,t) + 0.125d0 * (I_ipq_ist - I_ipq_sit - I_ipq_tsi)
enddo ! i
enddo ! p
enddo ! q
@ -468,7 +468,7 @@ BEGIN_PROVIDER [double precision, no_2_naive, (mo_num, mo_num, mo_num, mo_num)]
!$OMP I_ipq_ist, I_ipq_sit, I_ipq_tsi) &
!$OMP SHARED (mo_num, elec_beta_num, elec_num, &
!$OMP sigma_p, sigma_q, sigma_s, sigma_t, &
!$OMP no_2_naive)
!$OMP noL_2e_naive)
!$OMP DO COLLAPSE (4)
do t = 1, mo_num
@ -499,7 +499,7 @@ BEGIN_PROVIDER [double precision, no_2_naive, (mo_num, mo_num, mo_num, mo_num)]
! x (-1) because integrals are over -L
! x 0.25 because we consider 0.25 (up-up + up-down + down-up + down-down)
no_2_naive(p,q,s,t) = no_2_naive(p,q,s,t) + 0.125d0 * (I_ipq_ist - I_ipq_sit - I_ipq_tsi)
noL_2e_naive(p,q,s,t) = noL_2e_naive(p,q,s,t) + 0.125d0 * (I_ipq_ist - I_ipq_sit - I_ipq_tsi)
enddo ! i
enddo ! p
enddo ! q
@ -509,7 +509,7 @@ BEGIN_PROVIDER [double precision, no_2_naive, (mo_num, mo_num, mo_num, mo_num)]
!$OMP END PARALLEL
call wall_time(t1)
print*, " Wall time for no_2_naive (min) = ", (t1 - t0)/60.d0
print*, " Wall time for noL_2e_naive (min) = ", (t1 - t0)/60.d0
END_PROVIDER

54
src/tc_bi_ortho/no_dressing_v0.irp.f → src/bi_ort_ints/no_dressing_v0.irp.f
View File

@ -1,7 +1,7 @@
! ---
BEGIN_PROVIDER [double precision, no_0_v0]
BEGIN_PROVIDER [double precision, noL_0e]
implicit none
integer :: i, j, k
@ -10,7 +10,7 @@ BEGIN_PROVIDER [double precision, no_0_v0]
double precision, allocatable :: tmp(:)
call wall_time(t0)
print*, " Providing no_0_v0 ..."
print*, " Providing noL_0e ..."
if(elec_alpha_num .eq. elec_beta_num) then
@ -40,7 +40,7 @@ BEGIN_PROVIDER [double precision, no_0_v0]
!$OMP END DO
!$OMP END PARALLEL
no_0_v0 = -1.d0 * (-sum(tmp)) / 6.d0
noL_0e = -1.d0 * (-sum(tmp)) / 6.d0
deallocate(tmp)
@ -114,22 +114,22 @@ BEGIN_PROVIDER [double precision, no_0_v0]
!$OMP END DO
!$OMP END PARALLEL
no_0_v0 = -1.d0 * (-sum(tmp)) / 6.d0
noL_0e = -1.d0 * (-sum(tmp)) / 6.d0
deallocate(tmp)
endif
call wall_time(t1)
print*, " Wall time for no_0_v0 (min) = ", (t1 - t0)/60.d0
print*, " Wall time for noL_0e (min) = ", (t1 - t0)/60.d0
print*, " no_0_v0 = ", no_0_v0
print*, " noL_0e = ", noL_0e
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, no_1_v0, (mo_num, mo_num)]
BEGIN_PROVIDER [double precision, noL_1e, (mo_num, mo_num)]
BEGIN_DOC
!
@ -143,7 +143,7 @@ BEGIN_PROVIDER [double precision, no_1_v0, (mo_num, mo_num)]
double precision :: t0, t1
call wall_time(t0)
print*, " Providing no_1_v0 ..."
print*, " Providing noL_1e ..."
if(elec_alpha_num .eq. elec_beta_num) then
@ -152,13 +152,13 @@ BEGIN_PROVIDER [double precision, no_1_v0, (mo_num, mo_num)]
!$OMP PRIVATE (p, s, i, j, &
!$OMP I_pij_sij, I_pij_isj, I_pij_ijs, &
!$OMP I_pij_sji) &
!$OMP SHARED (mo_num, elec_beta_num, no_1_v0)
!$OMP SHARED (mo_num, elec_beta_num, noL_1e)
!$OMP DO COLLAPSE(2)
do s = 1, mo_num
do p = 1, mo_num
no_1_v0(p,s) = 0.d0
noL_1e(p,s) = 0.d0
do i = 1, elec_beta_num
do j = 1, elec_beta_num
@ -167,7 +167,7 @@ BEGIN_PROVIDER [double precision, no_1_v0, (mo_num, mo_num)]
call give_integrals_3_body_bi_ort(p, i, j, i, j, s, I_pij_ijs)
call give_integrals_3_body_bi_ort(p, i, j, s, j, i, I_pij_sji)
no_1_v0(p,s) = no_1_v0(p,s) - (2.d0*I_pij_sij - 2.d0*I_pij_isj + I_pij_ijs - I_pij_sji)
noL_1e(p,s) = noL_1e(p,s) - (2.d0*I_pij_sij - 2.d0*I_pij_isj + I_pij_ijs - I_pij_sji)
enddo
enddo
enddo
@ -182,13 +182,13 @@ BEGIN_PROVIDER [double precision, no_1_v0, (mo_num, mo_num)]
!$OMP PRIVATE (p, s, i, j, &
!$OMP I_pij_sij, I_pij_isj, I_pij_ijs, &
!$OMP I_pij_sji, I_pij_jsi, I_pij_jis) &
!$OMP SHARED (mo_num, elec_beta_num, elec_alpha_num, no_1_v0)
!$OMP SHARED (mo_num, elec_beta_num, elec_alpha_num, noL_1e)
!$OMP DO COLLAPSE(2)
do s = 1, mo_num
do p = 1, mo_num
no_1_v0(p,s) = 0.d0
noL_1e(p,s) = 0.d0
do i = 1, elec_beta_num
do j = 1, elec_beta_num
@ -197,7 +197,7 @@ BEGIN_PROVIDER [double precision, no_1_v0, (mo_num, mo_num)]
call give_integrals_3_body_bi_ort(p, i, j, i, j, s, I_pij_ijs)
call give_integrals_3_body_bi_ort(p, i, j, s, j, i, I_pij_sji)
no_1_v0(p,s) = no_1_v0(p,s) - (2.d0*I_pij_sij - 2.d0*I_pij_isj + I_pij_ijs - I_pij_sji)
noL_1e(p,s) = noL_1e(p,s) - (2.d0*I_pij_sij - 2.d0*I_pij_isj + I_pij_ijs - I_pij_sji)
enddo ! j
enddo ! i
@ -211,7 +211,7 @@ BEGIN_PROVIDER [double precision, no_1_v0, (mo_num, mo_num)]
call give_integrals_3_body_bi_ort(p, i, j, i, s, j, I_pij_isj)
call give_integrals_3_body_bi_ort(p, i, j, i, j, s, I_pij_ijs)
no_1_v0(p,s) = no_1_v0(p,s) + 0.5d0 * (2.d0*I_pij_sji - I_pij_jsi + 2.d0*I_pij_jis - 4.d0*I_pij_sij + 2.d0*I_pij_isj - I_pij_ijs)
noL_1e(p,s) = noL_1e(p,s) + 0.5d0 * (2.d0*I_pij_sji - I_pij_jsi + 2.d0*I_pij_jis - 4.d0*I_pij_sij + 2.d0*I_pij_isj - I_pij_ijs)
enddo ! j
do j = elec_beta_num+1, elec_alpha_num
@ -221,7 +221,7 @@ BEGIN_PROVIDER [double precision, no_1_v0, (mo_num, mo_num)]
call give_integrals_3_body_bi_ort(p, i, j, i, j, s, I_pij_ijs)
call give_integrals_3_body_bi_ort(p, i, j, s, j, i, I_pij_sji)
no_1_v0(p,s) = no_1_v0(p,s) - 0.5d0 * (I_pij_sij - I_pij_isj + I_pij_ijs - I_pij_sji)
noL_1e(p,s) = noL_1e(p,s) - 0.5d0 * (I_pij_sij - I_pij_isj + I_pij_ijs - I_pij_sji)
enddo ! j
enddo ! i
@ -233,13 +233,13 @@ BEGIN_PROVIDER [double precision, no_1_v0, (mo_num, mo_num)]
endif
call wall_time(t1)
print*, " Wall time for no_1_v0 (min) = ", (t1 - t0)/60.d0
print*, " Wall time for noL_1e (min) = ", (t1 - t0)/60.d0
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, no_2_v0, (mo_num, mo_num, mo_num, mo_num)]
BEGIN_PROVIDER [double precision, noL_2e, (mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC
!
@ -253,7 +253,7 @@ BEGIN_PROVIDER [double precision, no_2_v0, (mo_num, mo_num, mo_num, mo_num)]
double precision :: t0, t1
call wall_time(t0)
print*, " Providing no_2_v0 ..."
print*, " Providing noL_2e ..."
if(elec_alpha_num .eq. elec_beta_num) then
@ -261,7 +261,7 @@ BEGIN_PROVIDER [double precision, no_2_v0, (mo_num, mo_num, mo_num, mo_num)]
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (p, q, s, t, i, &
!$OMP I_ipq_sit, I_ipq_tsi, I_ipq_ist) &
!$OMP SHARED (mo_num, elec_beta_num, no_2_v0)
!$OMP SHARED (mo_num, elec_beta_num, noL_2e)
!$OMP DO COLLAPSE(4)
do t = 1, mo_num
@ -269,14 +269,14 @@ BEGIN_PROVIDER [double precision, no_2_v0, (mo_num, mo_num, mo_num, mo_num)]
do q = 1, mo_num
do p = 1, mo_num
no_2_v0(p,q,s,t) = 0.d0
noL_2e(p,q,s,t) = 0.d0
do i = 1, elec_beta_num
call give_integrals_3_body_bi_ort(i, p, q, s, i, t, I_ipq_sit)
call give_integrals_3_body_bi_ort(i, p, q, t, s, i, I_ipq_tsi)
call give_integrals_3_body_bi_ort(i, p, q, i, s, t, I_ipq_ist)
no_2_v0(p,q,s,t) = no_2_v0(p,q,s,t) - 0.5d0 * (I_ipq_sit + I_ipq_tsi - 2.d0*I_ipq_ist)
noL_2e(p,q,s,t) = noL_2e(p,q,s,t) - 0.5d0 * (I_ipq_sit + I_ipq_tsi - 2.d0*I_ipq_ist)
enddo
enddo
enddo
@ -291,7 +291,7 @@ BEGIN_PROVIDER [double precision, no_2_v0, (mo_num, mo_num, mo_num, mo_num)]
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (p, q, s, t, i, &
!$OMP I_ipq_sit, I_ipq_tsi, I_ipq_ist) &
!$OMP SHARED (mo_num, elec_beta_num, elec_alpha_num, no_2_v0)
!$OMP SHARED (mo_num, elec_beta_num, elec_alpha_num, noL_2e)
!$OMP DO COLLAPSE(4)
do t = 1, mo_num
@ -299,14 +299,14 @@ BEGIN_PROVIDER [double precision, no_2_v0, (mo_num, mo_num, mo_num, mo_num)]
do q = 1, mo_num
do p = 1, mo_num
no_2_v0(p,q,s,t) = 0.d0
noL_2e(p,q,s,t) = 0.d0
do i = 1, elec_beta_num
call give_integrals_3_body_bi_ort(i, p, q, s, i, t, I_ipq_sit)
call give_integrals_3_body_bi_ort(i, p, q, t, s, i, I_ipq_tsi)
call give_integrals_3_body_bi_ort(i, p, q, i, s, t, I_ipq_ist)
no_2_v0(p,q,s,t) = no_2_v0(p,q,s,t) - 0.5d0 * (I_ipq_sit + I_ipq_tsi - 2.d0*I_ipq_ist)
noL_2e(p,q,s,t) = noL_2e(p,q,s,t) - 0.5d0 * (I_ipq_sit + I_ipq_tsi - 2.d0*I_ipq_ist)
enddo ! i
do i = elec_beta_num+1, elec_alpha_num
@ -315,7 +315,7 @@ BEGIN_PROVIDER [double precision, no_2_v0, (mo_num, mo_num, mo_num, mo_num)]
call give_integrals_3_body_bi_ort(i, p, q, t, s, i, I_ipq_tsi)
call give_integrals_3_body_bi_ort(i, p, q, i, s, t, I_ipq_ist)
no_2_v0(p,q,s,t) = no_2_v0(p,q,s,t) - 0.25d0 * (I_ipq_sit + I_ipq_tsi - 2.d0*I_ipq_ist)
noL_2e(p,q,s,t) = noL_2e(p,q,s,t) - 0.25d0 * (I_ipq_sit + I_ipq_tsi - 2.d0*I_ipq_ist)
enddo ! i
enddo ! p
@ -328,7 +328,7 @@ BEGIN_PROVIDER [double precision, no_2_v0, (mo_num, mo_num, mo_num, mo_num)]
endif
call wall_time(t1)
print*, " Wall time for no_2_v0 (min) = ", (t1 - t0)/60.d0
print*, " Wall time for noL_2e (min) = ", (t1 - t0)/60.d0
END_PROVIDER

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

@ -29,7 +29,7 @@ END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_one_e, (mo_num, mo_num)]
BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_one_e, (mo_num, mo_num)]
BEGIN_DOC
!
@ -41,6 +41,11 @@ BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_one_e, (mo_num, mo_num)]
call ao_to_mo_bi_ortho(ao_one_e_integrals_tc_tot, ao_num, mo_bi_ortho_tc_one_e, mo_num)
if(noL_standard) then
PROVIDE noL_1e
mo_bi_ortho_tc_one_e = mo_bi_ortho_tc_one_e + noL_1e
endif
END_PROVIDER
! ---

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

@ -256,6 +256,12 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e, (mo_num, mo_num, mo_num,
FREE mo_bi_ortho_tc_two_e_chemist
if(noL_standard) then
PROVIDE noL_2e
mo_bi_ortho_tc_two_e = mo_bi_ortho_tc_two_e + noL_2e
FREE noL_2e
endif
END_PROVIDER
! ---

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

@ -34,7 +34,9 @@ end
! ---
subroutine htilde_mu_mat_opt_bi_ortho_tot(key_j, key_i, Nint, htot)
implicit none
implicit none
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
@ -82,7 +84,7 @@ subroutine htilde_mu_mat_opt_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree,
hmono = 0.d0
htwoe = 0.d0
htot = 0.d0
hthree = 0.D0
hthree = 0.d0
call get_excitation_degree(key_i, key_j, degree, Nint)
if(degree.gt.2) return

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

@ -29,6 +29,11 @@
ref_tc_energy_tot = ref_tc_energy_1e + ref_tc_energy_2e + ref_tc_energy_3e + nuclear_repulsion
if(noL_standard) then
PROVIDE noL_0e
ref_tc_energy_tot += noL_0e
endif
END_PROVIDER
! ---
@ -107,6 +112,11 @@ subroutine diag_htilde_mu_mat_fock_bi_ortho(Nint, det_in, hmono, htwoe, hthree,
htot = hmono + htwoe + hthree + nuclear_repulsion
if(noL_standard) then
PROVIDE noL_0e
htot += noL_0e
endif
end
! ---

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

@ -66,25 +66,3 @@ end
! ---
logical function is_same_spin(sigma_1, sigma_2)
BEGIN_DOC
!
! true if sgn(sigma_1) = sgn(sigma_2)
!
END_DOC
implicit none
double precision, intent(in) :: sigma_1, sigma_2
if((sigma_1 * sigma_2) .gt. 0.d0) then
is_same_spin = .true.
else
is_same_spin = .false.
endif
end function is_same_spin
! ---

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

@ -509,11 +509,11 @@ subroutine test_no_0()
print*, ' testing no_0 ...'
PROVIDE no_0_naive
PROVIDE no_0_v0
PROVIDE noL_0e_naive
PROVIDE noL_0e
accu = dabs(no_0_naive - no_0_v0)
norm = dabs(no_0_naive)
accu = dabs(noL_0e_naive - noL_0e)
norm = dabs(noL_0e_naive)
print*, ' accu (%) = ', 100.d0*accu/norm
@ -530,8 +530,8 @@ subroutine test_no_1()
print*, ' testing no_1 ...'
PROVIDE no_1_naive
PROVIDE no_1_v0
PROVIDE noL_1e_naive
PROVIDE noL_1e
thr = 1d-8
@ -540,8 +540,8 @@ subroutine test_no_1()
do i = 1, mo_num
do j = 1, mo_num
new = no_1_v0 (j,i)
ref = no_1_naive(j,i)
new = noL_1e (j,i)
ref = noL_1e_naive(j,i)
contrib = dabs(new - ref)
if(contrib .gt. thr) then
print*, ' problem on no_aaa_contraction'
@ -570,8 +570,8 @@ subroutine test_no_2()
print*, ' testing no_2 ...'
PROVIDE no_2_naive
PROVIDE no_2_v0
PROVIDE noL_2e_naive
PROVIDE noL_2e
thr = 1d-8
@ -582,8 +582,8 @@ subroutine test_no_2()
do k = 1, mo_num
do l = 1, mo_num
new = no_2_v0 (l,k,j,i)
ref = no_2_naive(l,k,j,i)
new = noL_2e (l,k,j,i)
ref = noL_2e_naive(l,k,j,i)
contrib = dabs(new - ref)
if(contrib .gt. thr) then
print*, ' problem on no_aaa_contraction'

6
src/tc_keywords/EZFIO.cfg
View File

@ -46,6 +46,12 @@ doc: If |true|, contracted double excitation three-body terms are included
interface: ezfio,provider,ocaml
default: False
[noL_standard]
type: logical
doc: If |true|, standard normal-ordering for L
interface: ezfio,provider,ocaml
default: False
[core_tc_op]
type: logical
doc: If |true|, takes the usual Hamiltonian for core orbitals (assumed to be doubly occupied)

25
src/utils/util.irp.f
View File

@ -556,3 +556,28 @@ subroutine sub_A_At(A, N)
!$OMP END PARALLEL
end
! ---
logical function is_same_spin(sigma_1, sigma_2)
BEGIN_DOC
!
! true if sgn(sigma_1) = sgn(sigma_2)
!
END_DOC
implicit none
double precision, intent(in) :: sigma_1, sigma_2
if((sigma_1 * sigma_2) .gt. 0.d0) then
is_same_spin = .true.
else
is_same_spin = .false.
endif
end function is_same_spin
! ---