PTEROSOR/QuantumPackage
10
0
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-06-26 15:12:19 +02:00
Code Releases Activity

NO-L0 V0

Browse Source
This commit is contained in:
AbdAmmar 2023-09-12 11:57:38 +02:00
parent 3270602419
commit a88730f10f
4 changed files with 243 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

92
src/tc_bi_ortho/no_dressing_naive.irp.f Normal file
View File

@ -0,0 +1,92 @@
! ---
BEGIN_PROVIDER [double precision, no_0_naive]
implicit none
integer :: ii, jj, kk
integer :: i, j, k
double precision :: sigma_i, sigma_j, sigma_k
double precision :: tmp
double precision :: I_ijk_ijk, I_ijk_kij, I_ijk_jki, I_ijk_jik, I_ijk_kji, I_ijk_ikj
double precision :: t0, t1
logical, external :: is_same_spin
print*, " Providing no_0_naive ..."
call wall_time(t0)
tmp = 0.d0
do ii = 1, elec_num
if(ii .le. elec_beta_num) then
i = ii
sigma_i = -1.d0
else
i = ii - elec_beta_num
sigma_i = +1.d0
endif
do jj = 1, elec_num
if(jj .le. elec_beta_num) then
j = jj
sigma_j = -1.d0
else
j = jj - elec_beta_num
sigma_j = +1.d0
endif
do kk = 1, elec_num
if(kk .le. elec_beta_num) then
k = kk
sigma_k = -1.d0
else
k = kk - elec_beta_num
sigma_k = +1.d0
endif
call give_integrals_3_body_bi_ort_spin( i, sigma_i, j, sigma_j, k, sigma_k &
, i, sigma_i, j, sigma_j, k, sigma_k &
, I_ijk_ijk)
call give_integrals_3_body_bi_ort_spin( i, sigma_i, j, sigma_j, k, sigma_k &
, k, sigma_k, i, sigma_i, j, sigma_j &
, I_ijk_kij)
call give_integrals_3_body_bi_ort_spin( i, sigma_i, j, sigma_j, k, sigma_k &
, j, sigma_j, k, sigma_k, i, sigma_i &
, I_ijk_jki)
call give_integrals_3_body_bi_ort_spin( i, sigma_i, j, sigma_j, k, sigma_k &
, j, sigma_j, i, sigma_i, k, sigma_k &
, I_ijk_jik)
call give_integrals_3_body_bi_ort_spin( i, sigma_i, j, sigma_j, k, sigma_k &
, k, sigma_k, j, sigma_j, i, sigma_i &
, I_ijk_kji)
call give_integrals_3_body_bi_ort_spin( i, sigma_i, j, sigma_j, k, sigma_k &
, i, sigma_i, k, sigma_k, j, sigma_j &
, I_ijk_ikj)
tmp = tmp + I_ijk_ijk + I_ijk_kij + I_ijk_jki - I_ijk_jik - I_ijk_kji - I_ijk_ikj
!tmp = tmp + I_ijk_ijk + 2.d0 * I_ijk_kij - 3.d0 * I_ijk_jik
enddo
enddo
enddo
no_0_naive = -1.d0 * (-tmp) / 6.d0
call wall_time(t1)
print*, " Wall time for no_0_naive (sec) = ", (t1 - t0)/60.d0
print*, " no_0_naive = ", no_0_naive
END_PROVIDER
! ---

105
src/tc_bi_ortho/no_dressing_v0.irp.f Normal file
View File

@ -0,0 +1,105 @@
! ---
BEGIN_PROVIDER [double precision, no_0_v0]
implicit none
integer :: i, j, k
double precision :: tmp
double precision :: I_ijk_ijk, I_ijk_kij, I_ijk_jik, I_ijk_jki, I_ijk_ikj, I_ijk_kji
double precision :: t0, t1
call wall_time(t0)
print*, " Providing no_0_v0 ..."
if(elec_alpha_num .eq. elec_beta_num) then
tmp = 0.d0
do i = 1, elec_beta_num
do j = 1, elec_beta_num
do k = 1, elec_beta_num
call give_integrals_3_body_bi_ort(i, j, k, i, j, k, I_ijk_ijk)
call give_integrals_3_body_bi_ort(i, j, k, k, i, j, I_ijk_kij)
call give_integrals_3_body_bi_ort(i, j, k, j, i, k, I_ijk_jik)
tmp = tmp + 4.d0 * (2.d0 * I_ijk_ijk + I_ijk_kij - 3.d0 * I_ijk_jik)
enddo
enddo
enddo
no_0_v0 = -1.d0 * (-tmp) / 6.d0
else
tmp = 0.d0
do i = 1, elec_beta_num
do j = 1, elec_beta_num
do k = 1, elec_beta_num
call give_integrals_3_body_bi_ort(i, j, k, i, j, k, I_ijk_ijk)
call give_integrals_3_body_bi_ort(i, j, k, k, i, j, I_ijk_kij)
call give_integrals_3_body_bi_ort(i, j, k, j, i, k, I_ijk_jik)
tmp = tmp + 4.d0 * (2.d0 * I_ijk_ijk + I_ijk_kij - 3.d0 * I_ijk_jik)
enddo
enddo
enddo
do i = elec_beta_num+1, elec_alpha_num
do j = elec_beta_num+1, elec_alpha_num
do k = elec_beta_num+1, elec_alpha_num
call give_integrals_3_body_bi_ort(i, j, k, i, j, k, I_ijk_ijk)
call give_integrals_3_body_bi_ort(i, j, k, k, i, j, I_ijk_kij)
call give_integrals_3_body_bi_ort(i, j, k, j, i, k, I_ijk_jik)
tmp = tmp + I_ijk_ijk + 2.d0 * I_ijk_kij - 3.d0 * I_ijk_jik
enddo
enddo
enddo
do i = elec_beta_num+1, elec_alpha_num
do j = 1, elec_beta_num
do k = 1, elec_beta_num
call give_integrals_3_body_bi_ort(i, j, k, i, j, k, I_ijk_ijk)
call give_integrals_3_body_bi_ort(i, j, k, j, k, i, I_ijk_jki)
call give_integrals_3_body_bi_ort(i, j, k, i, k, j, I_ijk_ikj)
call give_integrals_3_body_bi_ort(i, j, k, j, i, k, I_ijk_jik)
call give_integrals_3_body_bi_ort(i, j, k, k, j, i, I_ijk_kji)
tmp = tmp + 6.d0 * (2.d0 * I_ijk_ijk + I_ijk_jki - I_ijk_ikj - I_ijk_jik - I_ijk_kji)
enddo
do k = elec_beta_num+1, elec_alpha_num
call give_integrals_3_body_bi_ort(i, j, k, i, j, k, I_ijk_ijk)
call give_integrals_3_body_bi_ort(i, j, k, j, k, i, I_ijk_jki)
call give_integrals_3_body_bi_ort(i, j, k, i, k, j, I_ijk_ikj)
call give_integrals_3_body_bi_ort(i, j, k, j, i, k, I_ijk_jik)
call give_integrals_3_body_bi_ort(i, j, k, k, j, i, I_ijk_kji)
tmp = tmp + 3.d0 * (2.d0 * I_ijk_ijk + 2.d0 * I_ijk_jki - I_ijk_ikj - I_ijk_jik - 2.d0 * I_ijk_kji)
enddo
enddo
enddo
no_0_v0 = -1.d0 * (-tmp) / 6.d0
endif
call wall_time(t1)
print*, " Wall time for no_0_v0 (sec) = ", (t1 - t0)/60.d0
print*, " no_0_v0 = ", no_0_v0
END_PROVIDER
! ---

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

@ -66,3 +66,25 @@ 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
! ---

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

@ -35,7 +35,9 @@ program tc_bi_ortho
!call test_no_aaa()
!call test_no()
call test_no_v0()
!call test_no_v0()
call test_no_0()
end
@ -315,7 +317,7 @@ subroutine test_no_v0()
print*, ' accu (%) = ', 100.d0*accu/norm
return
end subroutine test_no
end subroutine test_no_0
! ---
@ -498,3 +500,23 @@ end
! ---
subroutine test_no_0()
implicit none
double precision :: accu, norm
print*, ' testing test_no_0 ...'
PROVIDE no_0_naive
PROVIDE no_0_v0
accu = dabs(no_0_naive - no_0_v0)
norm = dabs(no_0_naive)
print*, ' accu (%) = ', 100.d0*accu/norm
return
end
! ---