PTEROSOR
/
QuantumPackage
mirror of https://github.com/QuantumPackage/qp2.git
10
0
Fork 0
Code Releases Activity

Merge pull request #290 from AbdAmmar/dev-stable-tc-scf 

Dev stable tc scf
This commit is contained in:
AbdAmmar 2023-06-08 18:11:46 +02:00 committed by GitHub
parent bb55553a4e 87f7ec0456
commit 38c01db4cf
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
27 changed files with 3696 additions and 620 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
src/ao_two_e_ints/two_e_Coul_integrals_cosgtos.irp.f
View File

@ -29,14 +29,14 @@ double precision function ao_two_e_integral_cosgtos(i, j, k, l)
complex*16 :: integral5, integral6, integral7, integral8
complex*16 :: integral_tot
double precision :: ao_two_e_integral_cosgtos_schwartz_accel
double precision :: ao_2e_cosgtos_schwartz_accel
complex*16 :: ERI_cosgtos
complex*16 :: general_primitive_integral_cosgtos
if(ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024) then
!print *, ' with shwartz acc '
ao_two_e_integral_cosgtos = ao_two_e_integral_cosgtos_schwartz_accel(i, j, k, l)
ao_two_e_integral_cosgtos = ao_2e_cosgtos_schwartz_accel(i, j, k, l)
else
!print *, ' without shwartz acc '
@ -294,7 +294,7 @@ end function ao_two_e_integral_cosgtos
! ---
double precision function ao_two_e_integral_cosgtos_schwartz_accel(i, j, k, l)
double precision function ao_2e_cosgtos_schwartz_accel(i, j, k, l)
BEGIN_DOC
! integral of the AO basis <ik|jl> or (ij|kl)
@ -329,7 +329,7 @@ double precision function ao_two_e_integral_cosgtos_schwartz_accel(i, j, k, l)
complex*16 :: ERI_cosgtos
complex*16 :: general_primitive_integral_cosgtos
ao_two_e_integral_cosgtos_schwartz_accel = 0.d0
ao_2e_cosgtos_schwartz_accel = 0.d0
dim1 = n_pt_max_integrals
@ -519,8 +519,7 @@ double precision function ao_two_e_integral_cosgtos_schwartz_accel(i, j, k, l)
integral_tot = integral1 + integral2 + integral3 + integral4 + integral5 + integral6 + integral7 + integral8
ao_two_e_integral_cosgtos_schwartz_accel = ao_two_e_integral_cosgtos_schwartz_accel &
+ coef4 * 2.d0 * real(integral_tot)
ao_2e_cosgtos_schwartz_accel = ao_2e_cosgtos_schwartz_accel + coef4 * 2.d0 * real(integral_tot)
enddo ! s
enddo ! r
enddo ! q
@ -698,8 +697,7 @@ double precision function ao_two_e_integral_cosgtos_schwartz_accel(i, j, k, l)
integral_tot = integral1 + integral2 + integral3 + integral4 + integral5 + integral6 + integral7 + integral8
ao_two_e_integral_cosgtos_schwartz_accel = ao_two_e_integral_cosgtos_schwartz_accel &
+ coef4 * 2.d0 * real(integral_tot)
ao_2e_cosgtos_schwartz_accel = ao_2e_cosgtos_schwartz_accel + coef4 * 2.d0 * real(integral_tot)
enddo ! s
enddo ! r
enddo ! q
@ -709,11 +707,11 @@ double precision function ao_two_e_integral_cosgtos_schwartz_accel(i, j, k, l)
deallocate(schwartz_kl)
end function ao_two_e_integral_cosgtos_schwartz_accel
end function ao_2e_cosgtos_schwartz_accel
! ---
BEGIN_PROVIDER [ double precision, ao_two_e_integral_cosgtos_schwartz, (ao_num,ao_num) ]
BEGIN_PROVIDER [ double precision, ao_2e_cosgtos_schwartz, (ao_num,ao_num)]
BEGIN_DOC
! Needed to compute Schwartz inequalities
@ -723,16 +721,16 @@ BEGIN_PROVIDER [ double precision, ao_two_e_integral_cosgtos_schwartz, (ao_num,a
integer :: i, k
double precision :: ao_two_e_integral_cosgtos
ao_two_e_integral_cosgtos_schwartz(1,1) = ao_two_e_integral_cosgtos(1, 1, 1, 1)
ao_2e_cosgtos_schwartz(1,1) = ao_two_e_integral_cosgtos(1, 1, 1, 1)
!$OMP PARALLEL DO PRIVATE(i,k) &
!$OMP DEFAULT(NONE) &
!$OMP SHARED(ao_num, ao_two_e_integral_cosgtos_schwartz) &
!$OMP PARALLEL DO PRIVATE(i,k) &
!$OMP DEFAULT(NONE) &
!$OMP SHARED(ao_num, ao_2e_cosgtos_schwartz) &
!$OMP SCHEDULE(dynamic)
do i = 1, ao_num
do k = 1, i
ao_two_e_integral_cosgtos_schwartz(i,k) = dsqrt(ao_two_e_integral_cosgtos(i, i, k, k))
ao_two_e_integral_cosgtos_schwartz(k,i) = ao_two_e_integral_cosgtos_schwartz(i,k)
ao_2e_cosgtos_schwartz(i,k) = dsqrt(ao_two_e_integral_cosgtos(i, i, k, k))
ao_2e_cosgtos_schwartz(k,i) = ao_2e_cosgtos_schwartz(i,k)
enddo
enddo
!$OMP END PARALLEL DO

39
src/becke_numerical_grid/grid_becke_vector.irp.f
View File

@ -1,10 +1,13 @@
BEGIN_PROVIDER [integer, n_points_final_grid]
implicit none
BEGIN_DOC
! Number of points which are non zero
END_DOC
integer :: i,j,k,l
implicit none
integer :: i, j, k, l
n_points_final_grid = 0
do j = 1, nucl_num
do i = 1, n_points_radial_grid -1
@ -16,9 +19,11 @@ BEGIN_PROVIDER [integer, n_points_final_grid]
enddo
enddo
enddo
print*,'n_points_final_grid = ',n_points_final_grid
print*,'n max point = ',n_points_integration_angular*(n_points_radial_grid*nucl_num - 1)
print*,' n_points_final_grid = ', n_points_final_grid
print*,' n max point = ', n_points_integration_angular*(n_points_radial_grid*nucl_num - 1)
call ezfio_set_becke_numerical_grid_n_points_final_grid(n_points_final_grid)
END_PROVIDER
! ---
@ -41,6 +46,10 @@ END_PROVIDER
implicit none
integer :: i, j, k, l, i_count
double precision :: r(3)
double precision :: wall0, wall1
call wall_time(wall0)
print *, ' Providing final_grid_points ...'
i_count = 0
do j = 1, nucl_num
@ -62,20 +71,34 @@ END_PROVIDER
enddo
enddo
FREE grid_points_per_atom
FREE final_weight_at_r
call wall_time(wall1)
print *, ' wall time for final_grid_points,', wall1 - wall0
call print_memory_usage()
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, final_grid_points_transp, (n_points_final_grid,3)]
implicit none
BEGIN_DOC
! Transposed final_grid_points
! Transposed final_grid_points
END_DOC
implicit none
integer :: i,j
do j=1,3
do i=1,n_points_final_grid
do j = 1, 3
do i = 1, n_points_final_grid
final_grid_points_transp(i,j) = final_grid_points(j,i)
enddo
enddo
END_PROVIDER
! ---

208
src/bi_ort_ints/bi_ort_ints.irp.f
View File

@ -1,13 +1,25 @@
! ---
program bi_ort_ints
implicit none
BEGIN_DOC
! TODO : Put the documentation of the program here
! TODO : Put the documentation of the program here
END_DOC
implicit none
my_grid_becke = .True.
my_n_pt_r_grid = 10
my_n_pt_a_grid = 14
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
!my_n_pt_r_grid = 10
!my_n_pt_a_grid = 14
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
! call test_3e
! call test_5idx
! call test_5idx2
!call test_4idx
call test_4idx2()
call test_5idx2
call test_5idx
end
@ -16,6 +28,11 @@ subroutine test_5idx2
PROVIDE three_e_5_idx_cycle_2_bi_ort
end
subroutine test_4idx2()
!PROVIDE three_e_4_idx_direct_bi_ort
PROVIDE three_e_4_idx_exch23_bi_ort
end
subroutine test_3e
implicit none
integer :: i,k,j,l,m,n,ipoint
@ -147,3 +164,184 @@ subroutine test_5idx
end
! ---
subroutine test_4idx()
implicit none
integer :: i, j, k, l
double precision :: accu, contrib, new, ref, thr
thr = 1d-5
PROVIDE three_e_4_idx_direct_bi_ort_old
PROVIDE three_e_4_idx_direct_bi_ort
accu = 0.d0
do i = 1, mo_num
do j = 1, mo_num
do k = 1, mo_num
do l = 1, mo_num
new = three_e_4_idx_direct_bi_ort (l,k,j,i)
ref = three_e_4_idx_direct_bi_ort_old(l,k,j,i)
contrib = dabs(new - ref)
accu += contrib
if(contrib .gt. thr) then
print*, ' problem in three_e_4_idx_direct_bi_ort'
print*, l, k, j, i
print*, ref, new, contrib
stop
endif
enddo
enddo
enddo
enddo
print*, ' accu on three_e_4_idx_direct_bi_ort = ', accu / dble(mo_num)**4
! ---
PROVIDE three_e_4_idx_exch13_bi_ort_old
PROVIDE three_e_4_idx_exch13_bi_ort
accu = 0.d0
do i = 1, mo_num
do j = 1, mo_num
do k = 1, mo_num
do l = 1, mo_num
new = three_e_4_idx_exch13_bi_ort (l,k,j,i)
ref = three_e_4_idx_exch13_bi_ort_old(l,k,j,i)
contrib = dabs(new - ref)
accu += contrib
if(contrib .gt. thr) then
print*, ' problem in three_e_4_idx_exch13_bi_ort'
print*, l, k, j, i
print*, ref, new, contrib
stop
endif
enddo
enddo
enddo
enddo
print*, ' accu on three_e_4_idx_exch13_bi_ort = ', accu / dble(mo_num)**4
! ---
! PROVIDE three_e_4_idx_exch12_bi_ort_old
! PROVIDE three_e_4_idx_exch12_bi_ort
!
! accu = 0.d0
! do i = 1, mo_num
! do j = 1, mo_num
! do k = 1, mo_num
! do l = 1, mo_num
!
! new = three_e_4_idx_exch12_bi_ort (l,k,j,i)
! ref = three_e_4_idx_exch12_bi_ort_old(l,k,j,i)
! contrib = dabs(new - ref)
! accu += contrib
! if(contrib .gt. thr) then
! print*, ' problem in three_e_4_idx_exch12_bi_ort'
! print*, l, k, j, i
! print*, ref, new, contrib
! stop
! endif
!
! enddo
! enddo
! enddo
! enddo
! print*, ' accu on three_e_4_idx_exch12_bi_ort = ', accu / dble(mo_num)**4
! ---
PROVIDE three_e_4_idx_cycle_1_bi_ort_old
PROVIDE three_e_4_idx_cycle_1_bi_ort
accu = 0.d0
do i = 1, mo_num
do j = 1, mo_num
do k = 1, mo_num
do l = 1, mo_num
new = three_e_4_idx_cycle_1_bi_ort (l,k,j,i)
ref = three_e_4_idx_cycle_1_bi_ort_old(l,k,j,i)
contrib = dabs(new - ref)
accu += contrib
if(contrib .gt. thr) then
print*, ' problem in three_e_4_idx_cycle_1_bi_ort'
print*, l, k, j, i
print*, ref, new, contrib
stop
endif
enddo
enddo
enddo
enddo
print*, ' accu on three_e_4_idx_cycle_1_bi_ort = ', accu / dble(mo_num)**4
! ---
! PROVIDE three_e_4_idx_cycle_2_bi_ort_old
! PROVIDE three_e_4_idx_cycle_2_bi_ort
!
! accu = 0.d0
! do i = 1, mo_num
! do j = 1, mo_num
! do k = 1, mo_num
! do l = 1, mo_num
!
! new = three_e_4_idx_cycle_2_bi_ort (l,k,j,i)
! ref = three_e_4_idx_cycle_2_bi_ort_old(l,k,j,i)
! contrib = dabs(new - ref)
! accu += contrib
! if(contrib .gt. thr) then
! print*, ' problem in three_e_4_idx_cycle_2_bi_ort'
! print*, l, k, j, i
! print*, ref, new, contrib
! stop
! endif
!
! enddo
! enddo
! enddo
! enddo
! print*, ' accu on three_e_4_idx_cycle_2_bi_ort = ', accu / dble(mo_num)**4
! ---
PROVIDE three_e_4_idx_exch23_bi_ort_old
PROVIDE three_e_4_idx_exch23_bi_ort
accu = 0.d0
do i = 1, mo_num
do j = 1, mo_num
do k = 1, mo_num
do l = 1, mo_num
new = three_e_4_idx_exch23_bi_ort (l,k,j,i)
ref = three_e_4_idx_exch23_bi_ort_old(l,k,j,i)
contrib = dabs(new - ref)
accu += contrib
if(contrib .gt. thr) then
print*, ' problem in three_e_4_idx_exch23_bi_ort'
print*, l, k, j, i
print*, ref, new, contrib
stop
endif
enddo
enddo
enddo
enddo
print*, ' accu on three_e_4_idx_exch23_bi_ort = ', accu / dble(mo_num)**4
! ---
return
end

22
src/bi_ort_ints/semi_num_ints_mo.irp.f
View File

@ -54,7 +54,7 @@ BEGIN_PROVIDER [ double precision, mo_v_ki_bi_ortho_erf_rk_cst_mu_transp, (n_poi
enddo
enddo
! FREE mo_v_ki_bi_ortho_erf_rk_cst_mu
!FREE mo_v_ki_bi_ortho_erf_rk_cst_mu
END_PROVIDER
@ -124,6 +124,8 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_transp, (ao_num, ao_num, 3,
enddo
enddo
FREE int2_grad1_u12_ao_test
else
PROVIDE int2_grad1_u12_ao
@ -138,10 +140,13 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_transp, (ao_num, ao_num, 3,
enddo
enddo
FREE int2_grad1_u12_ao
endif
call wall_time(wall1)
print *, ' wall time for int2_grad1_u12_ao_transp ', wall1 - wall0
call print_memory_usage()
END_PROVIDER
@ -150,7 +155,7 @@ END_PROVIDER
BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_transp, (mo_num, mo_num, 3, n_points_final_grid)]
implicit none
integer :: ipoint
integer :: ipoint
double precision :: wall0, wall1
PROVIDE mo_l_coef mo_r_coef
@ -177,6 +182,7 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_transp, (mo_num, mo_num,
!call wall_time(wall1)
!print *, ' Wall time for providing int2_grad1_u12_bimo_transp',wall1 - wall0
!call print_memory_usage()
END_PROVIDER
@ -185,7 +191,11 @@ END_PROVIDER
BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_t, (n_points_final_grid, 3, mo_num, mo_num)]
implicit none
integer :: i, j, ipoint
integer :: i, j, ipoint
double precision :: wall0, wall1
!call wall_time(wall0)
!print *, ' Providing int2_grad1_u12_bimo_t ...'
PROVIDE mo_l_coef mo_r_coef
PROVIDE int2_grad1_u12_bimo_transp
@ -200,6 +210,12 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_t, (n_points_final_grid,
enddo
enddo
FREE int2_grad1_u12_bimo_transp
!call wall_time(wall1)
!print *, ' wall time for int2_grad1_u12_bimo_t,', wall1 - wall0
!call print_memory_usage()
END_PROVIDER
! ---

21
src/bi_ort_ints/three_body_ijm.irp.f
View File

@ -23,11 +23,11 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_direct_bi_ort, (mo_num, mo_num,
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,m,integral) &
!$OMP SHARED (mo_num,three_e_3_idx_direct_bi_ort)
!$OMP DO SCHEDULE (dynamic)
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,m,integral) &
!$OMP SHARED (mo_num,three_e_3_idx_direct_bi_ort)
!$OMP DO SCHEDULE (dynamic)
do i = 1, mo_num
do j = 1, mo_num
do m = j, mo_num
@ -36,8 +36,8 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_direct_bi_ort, (mo_num, mo_num,
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
!$OMP END DO
!$OMP END PARALLEL
do i = 1, mo_num
do j = 1, mo_num
@ -49,6 +49,7 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_direct_bi_ort, (mo_num, mo_num,
call wall_time(wall1)
print *, ' wall time for three_e_3_idx_direct_bi_ort', wall1 - wall0
call print_memory_usage()
END_PROVIDER
@ -102,6 +103,7 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_cycle_1_bi_ort, (mo_num, mo_num
call wall_time(wall1)
print *, ' wall time for three_e_3_idx_cycle_1_bi_ort', wall1 - wall0
call print_memory_usage()
END_PROVIDER
@ -155,6 +157,7 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_cycle_2_bi_ort, (mo_num, mo_num
call wall_time(wall1)
print *, ' wall time for three_e_3_idx_cycle_2_bi_ort', wall1 - wall0
call print_memory_usage()
END_PROVIDER
@ -208,6 +211,7 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_exch23_bi_ort, (mo_num, mo_num,
call wall_time(wall1)
print *, ' wall time for three_e_3_idx_exch23_bi_ort', wall1 - wall0
call print_memory_usage()
END_PROVIDER
@ -261,6 +265,7 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_exch13_bi_ort, (mo_num, mo_num,
call wall_time(wall1)
print *, ' wall time for three_e_3_idx_exch13_bi_ort', wall1 - wall0
call print_memory_usage()
END_PROVIDER
@ -306,6 +311,7 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_exch12_bi_ort, (mo_num, mo_num,
call wall_time(wall1)
print *, ' wall time for three_e_3_idx_exch12_bi_ort', wall1 - wall0
call print_memory_usage()
END_PROVIDER
@ -359,6 +365,7 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_exch12_bi_ort_new, (mo_num, mo_
call wall_time(wall1)
print *, ' wall time for three_e_3_idx_exch12_bi_ort_new', wall1 - wall0
call print_memory_usage()
END_PROVIDER

698
src/bi_ort_ints/three_body_ijmk.irp.f
View File

@ -1,282 +1,482 @@
! ---
BEGIN_PROVIDER [ double precision, three_e_4_idx_direct_bi_ort, (mo_num, mo_num, mo_num, mo_num)]
BEGIN_PROVIDER [ double precision, three_e_4_idx_direct_bi_ort , (mo_num, mo_num, mo_num, mo_num)]
&BEGIN_PROVIDER [ double precision, three_e_4_idx_exch13_bi_ort , (mo_num, mo_num, mo_num, mo_num)]
&BEGIN_PROVIDER [ double precision, three_e_4_idx_cycle_1_bi_ort, (mo_num, mo_num, mo_num, mo_num)]
!&BEGIN_PROVIDER [ double precision, three_e_4_idx_exch12_bi_ort , (mo_num, mo_num, mo_num, mo_num)]
!&BEGIN_PROVIDER [ double precision, three_e_4_idx_cycle_2_bi_ort, (mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
!
! three_e_4_idx_direct_bi_ort(m,j,k,i) = <mjk|-L|mji> ::: notice that i is the RIGHT MO and k is the LEFT MO
! three_e_4_idx_direct_bi_ort (m,j,k,i) = < m j k | -L | m j i > ::: notice that i is the RIGHT MO and k is the LEFT MO
! three_e_4_idx_exch13_bi_ort (m,j,k,i) = < m j k | -L | i j m > ::: notice that i is the RIGHT MO and k is the LEFT MO
! three_e_4_idx_exch12_bi_ort (m,j,k,i) = < m j k | -L | m i j > ::: notice that i is the RIGHT MO and k is the LEFT MO
! = three_e_4_idx_exch13_bi_ort (j,m,k,i)
! three_e_4_idx_cycle_1_bi_ort(m,j,k,i) = < m j k | -L | j i m > ::: notice that i is the RIGHT MO and k is the LEFT MO
! three_e_4_idx_cycle_2_bi_ort(m,j,k,i) = < m j k | -L | i m j > ::: notice that i is the RIGHT MO and k is the LEFT MO
! = three_e_4_idx_cycle_1_bi_ort(j,m,k,i)
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
! notice the -1 sign: in this way three_e_4_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
!
END_DOC
implicit none
integer :: i, j, k, m
double precision :: integral, wall1, wall0
three_e_4_idx_direct_bi_ort = 0.d0
print *, ' Providing the three_e_4_idx_direct_bi_ort ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,integral) &
!$OMP SHARED (mo_num,three_e_4_idx_direct_bi_ort)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m, j, k, m, j, i, integral)
three_e_4_idx_direct_bi_ort(m,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_4_idx_direct_bi_ort', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_4_idx_cycle_1_bi_ort, (mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE FIRST CYCLIC PERMUTATION TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
!
! three_e_4_idx_cycle_1_bi_ort(m,j,k,i) = <mjk|-L|jim> ::: notice that i is the RIGHT MO and k is the LEFT MO
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
! three_e_4_idx_direct_bi_ort (m,j,k,i) : Lk Ri Imm Ijj + Lj Rj Imm Iki + Lm Rm Ijj Iki
! three_e_4_idx_exch13_bi_ort (m,j,k,i) : Lk Rm Imi Ijj + Lj Rj Imi Ikm + Lm Ri Ijj Ikm
! three_e_4_idx_cycle_1_bi_ort(m,j,k,i) : Lk Rm Imj Iji + Lj Ri Imj Ikm + Lm Rj Iji Ikm
!
END_DOC
implicit none
integer :: i, j, k, m
double precision :: integral, wall1, wall0
integer :: ipoint, i, j, k, l, m
double precision :: wall1, wall0
double precision, allocatable :: tmp1(:,:,:,:), tmp2(:,:,:,:), tmp3(:,:,:,:)
double precision, allocatable :: tmp_4d(:,:,:,:)
double precision, allocatable :: tmp4(:,:,:)
double precision, allocatable :: tmp5(:,:)
double precision, allocatable :: tmp_3d(:,:,:)
three_e_4_idx_cycle_1_bi_ort = 0.d0
print *, ' Providing the three_e_4_idx_cycle_1_bi_ort ...'
print *, ' Providing the three_e_4_idx_bi_ort ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,integral) &
!$OMP SHARED (mo_num,three_e_4_idx_cycle_1_bi_ort)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
allocate(tmp_4d(mo_num,mo_num,mo_num,mo_num))
allocate(tmp1(n_points_final_grid,3,mo_num,mo_num))
allocate(tmp2(n_points_final_grid,3,mo_num,mo_num))
allocate(tmp3(n_points_final_grid,3,mo_num,mo_num))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, l, ipoint) &
!$OMP SHARED (mo_num, n_points_final_grid, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, &
!$OMP tmp1, tmp2, tmp3)
!$OMP DO COLLAPSE(2)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m, j, k, j, i, m, integral)
three_e_4_idx_cycle_1_bi_ort(m,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
do l = 1, mo_num
do ipoint = 1, n_points_final_grid
call wall_time(wall1)
print *, ' wall time for three_e_4_idx_cycle_1_bi_ort', wall1 - wall0
tmp1(ipoint,1,l,i) = int2_grad1_u12_bimo_t(ipoint,1,l,l) * mos_l_in_r_array_transp(ipoint,i) * final_weight_at_r_vector(ipoint)
tmp1(ipoint,2,l,i) = int2_grad1_u12_bimo_t(ipoint,2,l,l) * mos_l_in_r_array_transp(ipoint,i) * final_weight_at_r_vector(ipoint)
tmp1(ipoint,3,l,i) = int2_grad1_u12_bimo_t(ipoint,3,l,l) * mos_l_in_r_array_transp(ipoint,i) * final_weight_at_r_vector(ipoint)
END_PROVIDER
tmp2(ipoint,1,l,i) = int2_grad1_u12_bimo_t(ipoint,1,l,l) * mos_r_in_r_array_transp(ipoint,i)
tmp2(ipoint,2,l,i) = int2_grad1_u12_bimo_t(ipoint,2,l,l) * mos_r_in_r_array_transp(ipoint,i)
tmp2(ipoint,3,l,i) = int2_grad1_u12_bimo_t(ipoint,3,l,l) * mos_r_in_r_array_transp(ipoint,i)
! --
BEGIN_PROVIDER [ double precision, three_e_4_idx_cycle_2_bi_ort, (mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE FIRST CYCLIC PERMUTATION TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
!
! three_e_4_idx_cycle_2_bi_ort(m,j,k,i) = <mjk|-L|imj> ::: notice that i is the RIGHT MO and k is the LEFT MO
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
!
END_DOC
implicit none
integer :: i, j, k, m
double precision :: integral, wall1, wall0
three_e_4_idx_cycle_2_bi_ort = 0.d0
print *, ' Providing the three_e_4_idx_cycle_2_bi_ort ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,integral) &
!$OMP SHARED (mo_num,three_e_4_idx_cycle_2_bi_ort)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m, j, k, i, m, j, integral)
three_e_4_idx_cycle_2_bi_ort(m,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_4_idx_cycle_2_bi_ort', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_4_idx_exch23_bi_ort, (mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
!
! three_e_4_idx_exch23_bi_ort(m,j,k,i) = <mjk|-L|jmi> ::: notice that i is the RIGHT MO and k is the LEFT MO
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
!
END_DOC
implicit none
integer :: i, j, k, m
double precision :: integral, wall1, wall0
three_e_4_idx_exch23_bi_ort = 0.d0
print *, ' Providing the three_e_4_idx_exch23_bi_ort ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,integral) &
!$OMP SHARED (mo_num,three_e_4_idx_exch23_bi_ort)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m, j, k, j, m, i, integral)
three_e_4_idx_exch23_bi_ort(m,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_4_idx_exch23_bi_ort', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_4_idx_exch13_bi_ort, (mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
!
! three_e_4_idx_exch13_bi_ort(m,j,k,i) = <mjk|-L|ijm> ::: notice that i is the RIGHT MO and k is the LEFT MO
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
END_DOC
implicit none
integer :: i, j, k, m
double precision :: integral, wall1, wall0
three_e_4_idx_exch13_bi_ort = 0.d0
print *, ' Providing the three_e_4_idx_exch13_bi_ort ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,integral) &
!$OMP SHARED (mo_num,three_e_4_idx_exch13_bi_ort)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m, j, k, i, j, m, integral)
three_e_4_idx_exch13_bi_ort(m,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_4_idx_exch13_bi_ort', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_4_idx_exch12_bi_ort, (mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
!
! three_e_4_idx_exch12_bi_ort(m,j,k,i) = <mjk|-L|mij> ::: notice that i is the RIGHT MO and k is the LEFT MO
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
!
END_DOC
implicit none
integer :: i, j, k, m
double precision :: integral, wall1, wall0
three_e_4_idx_exch12_bi_ort = 0.d0
print *, ' Providing the three_e_4_idx_exch12_bi_ort ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,integral) &
!$OMP SHARED (mo_num,three_e_4_idx_exch12_bi_ort)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m, j, k, m, i, j, integral)
three_e_4_idx_exch12_bi_ort(m,j,k,i) = -1.d0 * integral
enddo
tmp3(ipoint,1,l,i) = int2_grad1_u12_bimo_t(ipoint,1,l,i) * mos_r_in_r_array_transp(ipoint,l)
tmp3(ipoint,2,l,i) = int2_grad1_u12_bimo_t(ipoint,2,l,i) * mos_r_in_r_array_transp(ipoint,l)
tmp3(ipoint,3,l,i) = int2_grad1_u12_bimo_t(ipoint,3,l,i) * mos_r_in_r_array_transp(ipoint,l)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call dgemm( 'T', 'N', mo_num*mo_num, mo_num*mo_num, 3*n_points_final_grid, 1.d0 &
, tmp1, 3*n_points_final_grid, tmp2, 3*n_points_final_grid &
, 0.d0, tmp_4d, mo_num*mo_num)
!$OMP PARALLEL DO PRIVATE(i,j,k,m)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
three_e_4_idx_direct_bi_ort(m,j,k,i) = -tmp_4d(m,k,j,i)
enddo
enddo
enddo
enddo
!$OMP END PARALLEL DO
call dgemm( 'T', 'N', mo_num*mo_num, mo_num*mo_num, 3*n_points_final_grid, 1.d0 &
, tmp3, 3*n_points_final_grid, tmp1, 3*n_points_final_grid &
, 0.d0, tmp_4d, mo_num*mo_num)
deallocate(tmp1)
!$OMP PARALLEL DO PRIVATE(i,j,k,m)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
three_e_4_idx_exch13_bi_ort(m,j,k,i) = -tmp_4d(m,i,j,k)
enddo
enddo
enddo
enddo
!$OMP END PARALLEL DO
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, l, ipoint) &
!$OMP SHARED (mo_num, n_points_final_grid, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, &
!$OMP tmp1)
!$OMP DO COLLAPSE(2)
do i = 1, mo_num
do l = 1, mo_num
do ipoint = 1, n_points_final_grid
tmp1(ipoint,1,l,i) = int2_grad1_u12_bimo_t(ipoint,1,i,l) * mos_l_in_r_array_transp(ipoint,l) * final_weight_at_r_vector(ipoint)
tmp1(ipoint,2,l,i) = int2_grad1_u12_bimo_t(ipoint,2,i,l) * mos_l_in_r_array_transp(ipoint,l) * final_weight_at_r_vector(ipoint)
tmp1(ipoint,3,l,i) = int2_grad1_u12_bimo_t(ipoint,3,i,l) * mos_l_in_r_array_transp(ipoint,l) * final_weight_at_r_vector(ipoint)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call dgemm( 'T', 'N', mo_num*mo_num, mo_num*mo_num, 3*n_points_final_grid, 1.d0 &
, tmp1, 3*n_points_final_grid, tmp2, 3*n_points_final_grid &
, 0.d0, tmp_4d, mo_num*mo_num)
deallocate(tmp2)
!$OMP PARALLEL DO PRIVATE(i,j,k,m)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
three_e_4_idx_exch13_bi_ort(m,j,k,i) = three_e_4_idx_exch13_bi_ort(m,j,k,i) - tmp_4d(m,k,j,i)
enddo
enddo
enddo
enddo
!$OMP END PARALLEL DO
call dgemm( 'T', 'N', mo_num*mo_num, mo_num*mo_num, 3*n_points_final_grid, 1.d0 &
, tmp1, 3*n_points_final_grid, tmp3, 3*n_points_final_grid &
, 0.d0, tmp_4d, mo_num*mo_num)
deallocate(tmp3)
!$OMP PARALLEL DO PRIVATE(i,j,k,m)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
three_e_4_idx_cycle_1_bi_ort(m,j,k,i) = -tmp_4d(m,k,j,i)
enddo
enddo
enddo
enddo
!$OMP END PARALLEL DO
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, l, ipoint) &
!$OMP SHARED (mo_num, n_points_final_grid, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, &
!$OMP tmp1)
!$OMP DO COLLAPSE(2)
do i = 1, mo_num
do l = 1, mo_num
do ipoint = 1, n_points_final_grid
tmp1(ipoint,1,l,i) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,l,l) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
tmp1(ipoint,2,l,i) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,l,l) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
tmp1(ipoint,3,l,i) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,l,l) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call dgemm( 'T', 'N', mo_num*mo_num, mo_num*mo_num, 3*n_points_final_grid, 1.d0 &
, tmp1, 3*n_points_final_grid, int2_grad1_u12_bimo_t, 3*n_points_final_grid &
, 0.d0, tmp_4d, mo_num*mo_num)
deallocate(tmp1)
!$OMP PARALLEL DO PRIVATE(i,j,k,m)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
three_e_4_idx_direct_bi_ort(m,j,k,i) = three_e_4_idx_direct_bi_ort(m,j,k,i) - tmp_4d(m,j,k,i) - tmp_4d(j,m,k,i)
enddo
enddo
enddo
enddo
!$OMP END PARALLEL DO
deallocate(tmp_4d)
allocate(tmp_3d(mo_num,mo_num,mo_num))
allocate(tmp5(n_points_final_grid,mo_num))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, ipoint) &
!$OMP SHARED (mo_num, n_points_final_grid, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP final_weight_at_r_vector, &
!$OMP tmp5)
!$OMP DO
do i = 1, mo_num
do ipoint = 1, n_points_final_grid
tmp5(ipoint,i) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
allocate(tmp4(n_points_final_grid,mo_num,mo_num))
do m = 1, mo_num
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, k, ipoint) &
!$OMP SHARED (mo_num, n_points_final_grid, m, &
!$OMP int2_grad1_u12_bimo_t, &
!$OMP tmp4)
!$OMP DO COLLAPSE(2)
do i = 1, mo_num
do k = 1, mo_num
do ipoint = 1, n_points_final_grid
tmp4(ipoint,k,i) = int2_grad1_u12_bimo_t(ipoint,1,k,m) * int2_grad1_u12_bimo_t(ipoint,1,m,i) &
+ int2_grad1_u12_bimo_t(ipoint,2,k,m) * int2_grad1_u12_bimo_t(ipoint,2,m,i) &
+ int2_grad1_u12_bimo_t(ipoint,3,k,m) * int2_grad1_u12_bimo_t(ipoint,3,m,i)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call dgemm( 'T', 'N', mo_num, mo_num*mo_num, n_points_final_grid, 1.d0 &
, tmp5, n_points_final_grid, tmp4, n_points_final_grid &
, 0.d0, tmp_3d, mo_num)
!$OMP PARALLEL DO PRIVATE(i,j,k)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
three_e_4_idx_exch13_bi_ort(m,j,k,i) = three_e_4_idx_exch13_bi_ort(m,j,k,i) - tmp_3d(j,k,i)
enddo
enddo
enddo
!$OMP END PARALLEL DO
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (j, k, ipoint) &
!$OMP SHARED (mo_num, n_points_final_grid, m, &
!$OMP mos_l_in_r_array_transp, &
!$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, &
!$OMP tmp4)
!$OMP DO COLLAPSE(2)
do k = 1, mo_num
do j = 1, mo_num
do ipoint = 1, n_points_final_grid
tmp4(ipoint,j,k) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,j) &
* ( int2_grad1_u12_bimo_t(ipoint,1,m,j) * int2_grad1_u12_bimo_t(ipoint,1,k,m) &
+ int2_grad1_u12_bimo_t(ipoint,2,m,j) * int2_grad1_u12_bimo_t(ipoint,2,k,m) &
+ int2_grad1_u12_bimo_t(ipoint,3,m,j) * int2_grad1_u12_bimo_t(ipoint,3,k,m) )
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call dgemm( 'T', 'N', mo_num*mo_num, mo_num, n_points_final_grid, 1.d0 &
, tmp4, n_points_final_grid, mos_r_in_r_array_transp, n_points_final_grid &
, 0.d0, tmp_3d, mo_num*mo_num)
!$OMP PARALLEL DO PRIVATE(i,j,k)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
three_e_4_idx_cycle_1_bi_ort(m,j,k,i) = three_e_4_idx_cycle_1_bi_ort(m,j,k,i) - tmp_3d(j,k,i)
enddo
enddo
enddo
!$OMP END PARALLEL DO
enddo
deallocate(tmp5)
deallocate(tmp_3d)
do i = 1, mo_num
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (m, j, ipoint) &
!$OMP SHARED (mo_num, n_points_final_grid, i, &
!$OMP mos_r_in_r_array_transp, &
!$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, &
!$OMP tmp4)
!$OMP DO COLLAPSE(2)
do j = 1, mo_num
do m = 1, mo_num
do ipoint = 1, n_points_final_grid
tmp4(ipoint,m,j) = final_weight_at_r_vector(ipoint) * mos_r_in_r_array_transp(ipoint,m) &
* ( int2_grad1_u12_bimo_t(ipoint,1,m,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
+ int2_grad1_u12_bimo_t(ipoint,2,m,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
+ int2_grad1_u12_bimo_t(ipoint,3,m,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) )
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call dgemm( 'T', 'N', mo_num*mo_num, mo_num, n_points_final_grid, -1.d0 &
, tmp4, n_points_final_grid, mos_l_in_r_array_transp, n_points_final_grid &
, 1.d0, three_e_4_idx_cycle_1_bi_ort(1,1,1,i), mo_num*mo_num)
enddo
deallocate(tmp4)
! !$OMP PARALLEL DO PRIVATE(i,j,k,m)
! do i = 1, mo_num
! do k = 1, mo_num
! do j = 1, mo_num
! do m = 1, mo_num
! three_e_4_idx_exch12_bi_ort (m,j,k,i) = three_e_4_idx_exch13_bi_ort (j,m,k,i)
! three_e_4_idx_cycle_2_bi_ort(m,j,k,i) = three_e_4_idx_cycle_1_bi_ort(j,m,k,i)
! enddo
! enddo
! enddo
! enddo
! !$OMP END PARALLEL DO
call wall_time(wall1)
print *, ' wall time for three_e_4_idx_exch12_bi_ort', wall1 - wall0
print *, ' wall time for three_e_4_idx_bi_ort', wall1 - wall0
call print_memory_usage()
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_4_idx_exch23_bi_ort , (mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
!
! three_e_4_idx_exch23_bi_ort (m,j,k,i) = < m j k | -L | j m i > ::: notice that i is the RIGHT MO and k is the LEFT MO
!
! notice the -1 sign: in this way three_e_4_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
!
! three_e_4_idx_exch23_bi_ort (m,j,k,i) : Lk Ri Imj Ijm + Lj Rm Imj Iki + Lm Rj Ijm Iki
!
END_DOC
implicit none
integer :: i, j, k, l, m, ipoint
double precision :: wall1, wall0
double precision, allocatable :: tmp1(:,:,:,:), tmp_4d(:,:,:,:)
double precision, allocatable :: tmp5(:,:,:), tmp6(:,:,:)
print *, ' Providing the three_e_4_idx_exch23_bi_ort ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
allocate(tmp5(n_points_final_grid,mo_num,mo_num))
allocate(tmp6(n_points_final_grid,mo_num,mo_num))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, l, ipoint) &
!$OMP SHARED (mo_num, n_points_final_grid, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, &
!$OMP tmp5, tmp6)
!$OMP DO COLLAPSE(2)
do i = 1, mo_num
do l = 1, mo_num
do ipoint = 1, n_points_final_grid
tmp5(ipoint,l,i) = int2_grad1_u12_bimo_t(ipoint,1,l,i) * int2_grad1_u12_bimo_t(ipoint,1,i,l) &
+ int2_grad1_u12_bimo_t(ipoint,2,l,i) * int2_grad1_u12_bimo_t(ipoint,2,i,l) &
+ int2_grad1_u12_bimo_t(ipoint,3,l,i) * int2_grad1_u12_bimo_t(ipoint,3,i,l)
tmp6(ipoint,l,i) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,l) * mos_r_in_r_array_transp(ipoint,i)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call dgemm( 'T', 'N', mo_num*mo_num, mo_num*mo_num, n_points_final_grid, -1.d0 &
, tmp5, n_points_final_grid, tmp6, n_points_final_grid &
, 0.d0, three_e_4_idx_exch23_bi_ort, mo_num*mo_num)
deallocate(tmp5)
deallocate(tmp6)
allocate(tmp_4d(mo_num,mo_num,mo_num,mo_num))
allocate(tmp1(n_points_final_grid,3,mo_num,mo_num))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, l, ipoint) &
!$OMP SHARED (mo_num, n_points_final_grid, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, &
!$OMP tmp1)
!$OMP DO COLLAPSE(2)
do i = 1, mo_num
do l = 1, mo_num
do ipoint = 1, n_points_final_grid
tmp1(ipoint,1,l,i) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,l,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,l)
tmp1(ipoint,2,l,i) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,l,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,l)
tmp1(ipoint,3,l,i) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,l,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,l)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call dgemm( 'T', 'N', mo_num*mo_num, mo_num*mo_num, 3*n_points_final_grid, 1.d0 &
, tmp1, 3*n_points_final_grid, int2_grad1_u12_bimo_t, 3*n_points_final_grid &
, 0.d0, tmp_4d, mo_num*mo_num)
deallocate(tmp1)
!$OMP PARALLEL DO PRIVATE(i,j,k,m)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
three_e_4_idx_exch23_bi_ort(m,j,k,i) = three_e_4_idx_exch23_bi_ort(m,j,k,i) - tmp_4d(m,j,k,i) - tmp_4d(j,m,k,i)
enddo
enddo
enddo
enddo
!$OMP END PARALLEL DO
deallocate(tmp_4d)
call wall_time(wall1)
print *, ' wall time for three_e_4_idx_exch23_bi_ort', wall1 - wall0
call print_memory_usage()
END_PROVIDER

290
src/bi_ort_ints/three_body_ijmk_old.irp.f Normal file
View File

@ -0,0 +1,290 @@
! ---
BEGIN_PROVIDER [ double precision, three_e_4_idx_direct_bi_ort_old, (mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
!
! three_e_4_idx_direct_bi_ort_old(m,j,k,i) = <mjk|-L|mji> ::: notice that i is the RIGHT MO and k is the LEFT MO
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
!
END_DOC
implicit none
integer :: i, j, k, m
double precision :: integral, wall1, wall0
three_e_4_idx_direct_bi_ort_old = 0.d0
print *, ' Providing the three_e_4_idx_direct_bi_ort_old ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,integral) &
!$OMP SHARED (mo_num,three_e_4_idx_direct_bi_ort_old)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m, j, k, m, j, i, integral)
three_e_4_idx_direct_bi_ort_old(m,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_4_idx_direct_bi_ort_old', wall1 - wall0
call print_memory_usage()
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_4_idx_cycle_1_bi_ort_old, (mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE FIRST CYCLIC PERMUTATION TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
!
! three_e_4_idx_cycle_1_bi_ort_old(m,j,k,i) = <mjk|-L|jim> ::: notice that i is the RIGHT MO and k is the LEFT MO
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
!
END_DOC
implicit none
integer :: i, j, k, m
double precision :: integral, wall1, wall0
three_e_4_idx_cycle_1_bi_ort_old = 0.d0
print *, ' Providing the three_e_4_idx_cycle_1_bi_ort_old ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,integral) &
!$OMP SHARED (mo_num,three_e_4_idx_cycle_1_bi_ort_old)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m, j, k, j, i, m, integral)
three_e_4_idx_cycle_1_bi_ort_old(m,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_4_idx_cycle_1_bi_ort_old', wall1 - wall0
call print_memory_usage()
END_PROVIDER
! --
BEGIN_PROVIDER [ double precision, three_e_4_idx_cycle_2_bi_ort_old, (mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE FIRST CYCLIC PERMUTATION TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
!
! three_e_4_idx_cycle_2_bi_ort_old(m,j,k,i) = <mjk|-L|imj> ::: notice that i is the RIGHT MO and k is the LEFT MO
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
!
END_DOC
implicit none
integer :: i, j, k, m
double precision :: integral, wall1, wall0
three_e_4_idx_cycle_2_bi_ort_old = 0.d0
print *, ' Providing the three_e_4_idx_cycle_2_bi_ort_old ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,integral) &
!$OMP SHARED (mo_num,three_e_4_idx_cycle_2_bi_ort_old)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m, j, k, i, m, j, integral)
three_e_4_idx_cycle_2_bi_ort_old(m,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_4_idx_cycle_2_bi_ort_old', wall1 - wall0
call print_memory_usage()
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_4_idx_exch23_bi_ort_old, (mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
!
! three_e_4_idx_exch23_bi_ort_old(m,j,k,i) = <mjk|-L|jmi> ::: notice that i is the RIGHT MO and k is the LEFT MO
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
!
END_DOC
implicit none
integer :: i, j, k, m
double precision :: integral, wall1, wall0
three_e_4_idx_exch23_bi_ort_old = 0.d0
print *, ' Providing the three_e_4_idx_exch23_bi_ort_old ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,integral) &
!$OMP SHARED (mo_num,three_e_4_idx_exch23_bi_ort_old)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m, j, k, j, m, i, integral)
three_e_4_idx_exch23_bi_ort_old(m,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_4_idx_exch23_bi_ort_old', wall1 - wall0
call print_memory_usage()
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_4_idx_exch13_bi_ort_old, (mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
!
! three_e_4_idx_exch13_bi_ort_old(m,j,k,i) = <mjk|-L|ijm> ::: notice that i is the RIGHT MO and k is the LEFT MO
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
END_DOC
implicit none
integer :: i, j, k, m
double precision :: integral, wall1, wall0
three_e_4_idx_exch13_bi_ort_old = 0.d0
print *, ' Providing the three_e_4_idx_exch13_bi_ort_old ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,integral) &
!$OMP SHARED (mo_num,three_e_4_idx_exch13_bi_ort_old)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m, j, k, i, j, m, integral)
three_e_4_idx_exch13_bi_ort_old(m,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_4_idx_exch13_bi_ort_old', wall1 - wall0
call print_memory_usage()
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_4_idx_exch12_bi_ort_old, (mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
!
! three_e_4_idx_exch12_bi_ort_old(m,j,k,i) = <mjk|-L|mij> ::: notice that i is the RIGHT MO and k is the LEFT MO
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
!
END_DOC
implicit none
integer :: i, j, k, m
double precision :: integral, wall1, wall0
three_e_4_idx_exch12_bi_ort_old = 0.d0
print *, ' Providing the three_e_4_idx_exch12_bi_ort_old ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,integral) &
!$OMP SHARED (mo_num,three_e_4_idx_exch12_bi_ort_old)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m, j, k, m, i, j, integral)
three_e_4_idx_exch12_bi_ort_old(m,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_4_idx_exch12_bi_ort_old', wall1 - wall0
call print_memory_usage()
END_PROVIDER
! ---

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

@ -19,10 +19,10 @@ end
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
!
END_DOC
implicit none
integer :: i, j, k, m, l
double precision :: wall1, wall0
integer :: ipoint
@ -134,7 +134,6 @@ end
enddo
!$OMP END PARALLEL DO
allocate(rm_grad_ik(n_points_final_grid,3,mo_num))
allocate(rk_grad_im(n_points_final_grid,3,mo_num))
@ -226,6 +225,7 @@ end
!$OMP END PARALLEL DO
enddo
deallocate(rm_grad_ik)
deallocate(rk_grad_im)
deallocate(lk_grad_mi)
@ -233,10 +233,13 @@ end
enddo
deallocate(tmp_mat)
deallocate(orb_mat)
call wall_time(wall1)
print *, ' wall time for three_e_5_idx_bi_ort', wall1 - wall0
call print_memory_usage()
END_PROVIDER

1
src/bi_ort_ints/three_body_ints_bi_ort.irp.f
View File

@ -57,6 +57,7 @@ BEGIN_PROVIDER [ double precision, three_body_ints_bi_ort, (mo_num, mo_num, mo_n
call wall_time(wall1)
print *, ' wall time for three_body_ints_bi_ort', wall1 - wall0
call print_memory_usage()
! if(write_three_body_ints_bi_ort)then
! print*,'Writing three_body_ints_bi_ort on disk ...'
! call write_array_6_index_tensor(mo_num,three_body_ints_bi_ort,name_file)

6
src/bi_ortho_mos/bi_ort_mos_in_r.irp.f
View File

@ -46,7 +46,7 @@ BEGIN_PROVIDER[double precision, mos_r_in_r_array_transp, (n_points_final_grid,
mos_r_in_r_array_transp(i,j) = mos_r_in_r_array(j,i)
enddo
enddo
END_PROVIDER
! ---
@ -116,7 +116,7 @@ end subroutine give_all_mos_l_at_r
! ---
BEGIN_PROVIDER[double precision, mos_l_in_r_array_transp,(n_points_final_grid,mo_num)]
BEGIN_PROVIDER[double precision, mos_l_in_r_array_transp, (n_points_final_grid,mo_num)]
BEGIN_DOC
! mos_l_in_r_array_transp(i,j) = value of the jth mo on the ith grid point
@ -130,7 +130,7 @@ BEGIN_PROVIDER[double precision, mos_l_in_r_array_transp,(n_points_final_grid,mo
mos_l_in_r_array_transp(i,j) = mos_l_in_r_array(j,i)
enddo
enddo
END_PROVIDER
! ---

17
src/fci_tc_bi/fci_tc_bi_ortho.irp.f
View File

@ -54,14 +54,18 @@ subroutine run_cipsi_tc
implicit none
if (.not.is_zmq_slave) then
if (.not. is_zmq_slave) then
PROVIDE psi_det psi_coef mo_bi_ortho_tc_two_e mo_bi_ortho_tc_one_e
if(elec_alpha_num+elec_beta_num.ge.3)then
if(elec_alpha_num+elec_beta_num .ge. 3) then
if(three_body_h_tc)then
call provide_all_three_ints_bi_ortho
call provide_all_three_ints_bi_ortho()
endif
endif
! ---
FREE int2_grad1_u12_bimo_transp int2_grad1_u12_ao_transp
write(json_unit,json_array_open_fmt) 'fci_tc'
if (do_pt2) then
@ -76,13 +80,16 @@ subroutine run_cipsi_tc
call json_close
else
PROVIDE mo_bi_ortho_tc_one_e mo_bi_ortho_tc_two_e pt2_min_parallel_tasks
if(elec_alpha_num+elec_beta_num.ge.3)then
if(three_body_h_tc)then
call provide_all_three_ints_bi_ortho
endif
endif
! ---
FREE int2_grad1_u12_bimo_transp int2_grad1_u12_ao_transp
call run_slave_cipsi

21
src/non_h_ints_mu/grad_squared.irp.f
View File

@ -231,6 +231,7 @@ BEGIN_PROVIDER [ double precision, grad12_j12, (ao_num, ao_num, n_points_final_g
call wall_time(time0)
PROVIDE j1b_type
PROVIDE int2_grad1u2_grad2u2_j1b2
do ipoint = 1, n_points_final_grid
tmp1 = v_1b(ipoint)
@ -242,6 +243,8 @@ BEGIN_PROVIDER [ double precision, grad12_j12, (ao_num, ao_num, n_points_final_g
enddo
enddo
FREE int2_grad1u2_grad2u2_j1b2
!if(j1b_type .eq. 0) then
! grad12_j12 = 0.d0
! do ipoint = 1, n_points_final_grid
@ -262,6 +265,7 @@ BEGIN_PROVIDER [ double precision, grad12_j12, (ao_num, ao_num, n_points_final_g
call wall_time(time1)
print*, ' Wall time for grad12_j12 = ', time1 - time0
call print_memory_usage()
END_PROVIDER
@ -278,6 +282,9 @@ BEGIN_PROVIDER [double precision, u12sq_j1bsq, (ao_num, ao_num, n_points_final_g
print*, ' providing u12sq_j1bsq ...'
call wall_time(time0)
! do not free here
PROVIDE int2_u2_j1b2
do ipoint = 1, n_points_final_grid
tmp_x = v_1b_grad(1,ipoint)
tmp_y = v_1b_grad(2,ipoint)
@ -292,6 +299,7 @@ BEGIN_PROVIDER [double precision, u12sq_j1bsq, (ao_num, ao_num, n_points_final_g
call wall_time(time1)
print*, ' Wall time for u12sq_j1bsq = ', time1 - time0
call print_memory_usage()
END_PROVIDER
@ -310,6 +318,9 @@ BEGIN_PROVIDER [ double precision, u12_grad1_u12_j1b_grad1_j1b, (ao_num, ao_num,
print*, ' providing u12_grad1_u12_j1b_grad1_j1b ...'
call wall_time(time0)
PROVIDE int2_u_grad1u_j1b2
PROVIDE int2_u_grad1u_x_j1b2
do ipoint = 1, n_points_final_grid
x = final_grid_points(1,ipoint)
@ -340,14 +351,17 @@ BEGIN_PROVIDER [ double precision, u12_grad1_u12_j1b_grad1_j1b, (ao_num, ao_num,
enddo
enddo
FREE int2_u_grad1u_j1b2
FREE int2_u_grad1u_x_j1b2
call wall_time(time1)
print*, ' Wall time for u12_grad1_u12_j1b_grad1_j1b = ', time1 - time0
call print_memory_usage()
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, tc_grad_square_ao, (ao_num, ao_num, ao_num, ao_num)]
BEGIN_DOC
@ -401,6 +415,8 @@ BEGIN_PROVIDER [double precision, tc_grad_square_ao, (ao_num, ao_num, ao_num, ao
, int2_grad1_u12_square_ao(1,1,1), ao_num*ao_num, b_mat(1,1,1), n_points_final_grid &
, 0.d0, tc_grad_square_ao, ao_num*ao_num)
FREE int2_grad1_u12_square_ao
! ---
if(((j1b_type .eq. 3) .or. (j1b_type .eq. 4)) .and. use_ipp) then
@ -442,6 +458,8 @@ BEGIN_PROVIDER [double precision, tc_grad_square_ao, (ao_num, ao_num, ao_num, ao
call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
, int2_u2_j1b2(1,1,1), ao_num*ao_num, b_mat(1,1,1), n_points_final_grid &
, 1.d0, tc_grad_square_ao, ao_num*ao_num)
FREE int2_u2_j1b2
endif
! ---
@ -478,6 +496,7 @@ BEGIN_PROVIDER [double precision, tc_grad_square_ao, (ao_num, ao_num, ao_num, ao
call wall_time(time1)
print*, ' Wall time for tc_grad_square_ao = ', time1 - time0
call print_memory_usage()
END_PROVIDER

1
src/non_h_ints_mu/new_grad_tc.irp.f
View File

@ -284,6 +284,7 @@ BEGIN_PROVIDER [double precision, tc_grad_and_lapl_ao, (ao_num, ao_num, ao_num,
call wall_time(time1)
print*, ' Wall time for tc_grad_and_lapl_ao = ', time1 - time0
call print_memory_usage()
END_PROVIDER

8
src/non_h_ints_mu/tc_integ.irp.f
View File

@ -100,6 +100,8 @@ BEGIN_PROVIDER [double precision, int2_grad1_u12_ao, (ao_num, ao_num, n_points_f
!$OMP END DO
!$OMP END PARALLEL
FREE v_ij_erf_rk_cst_mu_j1b v_ij_u_cst_mu_j1b x_v_ij_erf_rk_cst_mu_j1b
elseif(j1b_type .ge. 100) then
PROVIDE final_weight_at_r_vector_extra aos_in_r_array_extra
@ -176,6 +178,7 @@ BEGIN_PROVIDER [double precision, int2_grad1_u12_ao, (ao_num, ao_num, n_points_f
call wall_time(time1)
print*, ' wall time for int2_grad1_u12_ao =', time1-time0
call print_memory_usage()
END_PROVIDER
@ -242,6 +245,8 @@ BEGIN_PROVIDER [double precision, int2_grad1_u12_square_ao, (ao_num, ao_num, n_p
!$OMP END DO
!$OMP END PARALLEL
FREE u12sq_j1bsq grad12_j12
else
PROVIDE u12sq_j1bsq u12_grad1_u12_j1b_grad1_j1b grad12_j12
@ -262,6 +267,8 @@ BEGIN_PROVIDER [double precision, int2_grad1_u12_square_ao, (ao_num, ao_num, n_p
!$OMP END DO
!$OMP END PARALLEL
FREE u12sq_j1bsq u12_grad1_u12_j1b_grad1_j1b grad12_j12
endif
elseif(j1b_type .ge. 100) then
@ -324,6 +331,7 @@ BEGIN_PROVIDER [double precision, int2_grad1_u12_square_ao, (ao_num, ao_num, n_p
call wall_time(time1)
print*, ' wall time for int2_grad1_u12_square_ao =', time1-time0
call print_memory_usage()
END_PROVIDER

3
src/non_h_ints_mu/total_tc_int.irp.f
View File

@ -84,8 +84,11 @@ BEGIN_PROVIDER [double precision, ao_tc_int_chemist, (ao_num, ao_num, ao_num, ao
enddo
endif
FREE tc_grad_square_ao tc_grad_and_lapl_ao ao_two_e_coul
call wall_time(wall1)
print *, ' wall time for ao_tc_int_chemist ', wall1 - wall0
call print_memory_usage()
END_PROVIDER

1285
src/tc_bi_ortho/normal_ordered.irp.f
View File

File diff suppressed because it is too large Load Diff

1062
src/tc_bi_ortho/normal_ordered_contractions.irp.f Normal file
View File

File diff suppressed because it is too large Load Diff

392
src/tc_bi_ortho/normal_ordered_old.irp.f Normal file
View File

@ -0,0 +1,392 @@
! ---
BEGIN_PROVIDER [ double precision, normal_two_body_bi_orth_old, (mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC
! Normal ordering of the three body interaction on the HF density
END_DOC
use bitmasks ! you need to include the bitmasks_module.f90 features
implicit none
integer :: i, h1, p1, h2, p2
integer :: hh1, hh2, pp1, pp2
integer :: Ne(2)
double precision :: hthree_aba, hthree_aaa, hthree_aab
double precision :: wall0, wall1
integer, allocatable :: occ(:,:)
integer(bit_kind), allocatable :: key_i_core(:,:)
print*,' Providing normal_two_body_bi_orth_old ...'
call wall_time(wall0)
PROVIDE N_int
if(read_tc_norm_ord) then
open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/normal_two_body_bi_orth_old', action="read")
read(11) normal_two_body_bi_orth_old
close(11)
else
PROVIDE N_int
allocate( occ(N_int*bit_kind_size,2) )
allocate( key_i_core(N_int,2) )
if(core_tc_op) then
do i = 1, N_int
key_i_core(i,1) = xor(ref_bitmask(i,1),core_bitmask(i,1))
key_i_core(i,2) = xor(ref_bitmask(i,2),core_bitmask(i,2))
enddo
call bitstring_to_list_ab(key_i_core,occ,Ne,N_int)
else
call bitstring_to_list_ab(ref_bitmask,occ,Ne,N_int)
endif
normal_two_body_bi_orth_old = 0.d0
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (hh1, h1, hh2, h2, pp1, p1, pp2, p2, hthree_aba, hthree_aab, hthree_aaa) &
!$OMP SHARED (N_int, n_act_orb, list_act, Ne, occ, normal_two_body_bi_orth_old)
!$OMP DO SCHEDULE (static)
do hh1 = 1, n_act_orb
h1 = list_act(hh1)
do pp1 = 1, n_act_orb
p1 = list_act(pp1)
do hh2 = 1, n_act_orb
h2 = list_act(hh2)
do pp2 = 1, n_act_orb
p2 = list_act(pp2)
! all contributions from the 3-e terms to the double excitations
! s1:(h1-->p1), s2:(h2-->p2) from the HF reference determinant
! opposite spin double excitations : s1 /= s2
call give_aba_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree_aba)
! same spin double excitations : s1 == s2
if(h1<h2.and.p1.gt.p2)then
! with opposite spin contributions
call give_aab_contraction(N_int, h2, h1, p1, p2, Ne, occ, hthree_aab) ! exchange h1<->h2
! same spin double excitations with same spin contributions
if(Ne(2).ge.3)then
call give_aaa_contraction(N_int, h2, h1, p1, p2, Ne, occ, hthree_aaa) ! exchange h1<->h2
else
hthree_aaa = 0.d0
endif
else
! with opposite spin contributions
call give_aab_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree_aab)
if(Ne(2).ge.3)then
! same spin double excitations with same spin contributions
call give_aaa_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree_aaa)
else
hthree_aaa = 0.d0
endif
endif
normal_two_body_bi_orth_old(p2,h2,p1,h1) = 0.5d0*(hthree_aba + hthree_aab + hthree_aaa)
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
deallocate( occ )
deallocate( key_i_core )
endif
if(write_tc_norm_ord.and.mpi_master) then
open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/normal_two_body_bi_orth_old', action="write")
call ezfio_set_work_empty(.False.)
write(11) normal_two_body_bi_orth_old
close(11)
call ezfio_set_tc_keywords_io_tc_integ('Read')
endif
call wall_time(wall1)
print*,' Wall time for normal_two_body_bi_orth_old ', wall1-wall0
END_PROVIDER
! ---
subroutine give_aba_contraction(Nint, h1, h2, p1, p2, Ne, occ, hthree)
use bitmasks ! you need to include the bitmasks_module.f90 features
implicit none
integer, intent(in) :: Nint, h1, h2, p1, p2
integer, intent(in) :: Ne(2), occ(Nint*bit_kind_size,2)
double precision, intent(out) :: hthree
integer :: ii, i
double precision :: int_direct, int_exc_12, int_exc_13, integral
!!!! double alpha/beta
hthree = 0.d0
do ii = 1, Ne(2) ! purely closed shell part
i = occ(ii,2)
call give_integrals_3_body_bi_ort(i, p2, p1, i, h2, h1, integral)
int_direct = -1.d0 * integral
call give_integrals_3_body_bi_ort(p1, p2, i, i, h2, h1, integral)
int_exc_13 = -1.d0 * integral
call give_integrals_3_body_bi_ort(p2, i, p1, i, h2, h1, integral)
int_exc_12 = -1.d0 * integral
hthree += 2.d0 * int_direct - 1.d0 * (int_exc_13 + int_exc_12)
enddo
do ii = Ne(2) + 1, Ne(1) ! purely open-shell part
i = occ(ii,1)
call give_integrals_3_body_bi_ort(i, p2, p1, i, h2, h1, integral)
int_direct = -1.d0 * integral
call give_integrals_3_body_bi_ort(p1, p2, i, i, h2, h1, integral)
int_exc_13 = -1.d0 * integral
call give_integrals_3_body_bi_ort(p2, i, p1, i, h2, h1, integral)
int_exc_12 = -1.d0 * integral
hthree += 1.d0 * int_direct - 0.5d0 * (int_exc_13 + int_exc_12)
enddo
return
end
! ---
BEGIN_PROVIDER [ double precision, normal_two_body_bi_orth_ab, (mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC
! Normal ordered two-body sector of the three-body terms for opposite spin double excitations
END_DOC
use bitmasks ! you need to include the bitmasks_module.f90 features
implicit none
integer :: h1, p1, h2, p2, i
integer :: hh1, hh2, pp1, pp2
integer :: Ne(2)
integer, allocatable :: occ(:,:)
integer(bit_kind), allocatable :: key_i_core(:,:)
double precision :: hthree
PROVIDE N_int
allocate( key_i_core(N_int,2) )
allocate( occ(N_int*bit_kind_size,2) )
if(core_tc_op) then
do i = 1, N_int
key_i_core(i,1) = xor(ref_bitmask(i,1),core_bitmask(i,1))
key_i_core(i,2) = xor(ref_bitmask(i,2),core_bitmask(i,2))
enddo
call bitstring_to_list_ab(key_i_core,occ,Ne,N_int)
else
call bitstring_to_list_ab(ref_bitmask,occ,Ne,N_int)
endif
normal_two_body_bi_orth_ab = 0.d0
do hh1 = 1, n_act_orb
h1 = list_act(hh1)
do pp1 = 1, n_act_orb
p1 = list_act(pp1)
do hh2 = 1, n_act_orb
h2 = list_act(hh2)
do pp2 = 1, n_act_orb
p2 = list_act(pp2)
call give_aba_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree)
normal_two_body_bi_orth_ab(p2,h2,p1,h1) = hthree
enddo
enddo
enddo
enddo
deallocate( key_i_core )
deallocate( occ )
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, normal_two_body_bi_orth_aa_bb, (n_act_orb, n_act_orb, n_act_orb, n_act_orb)]
BEGIN_DOC
! Normal ordered two-body sector of the three-body terms for same spin double excitations
END_DOC
use bitmasks ! you need to include the bitmasks_module.f90 features
implicit none
integer :: i,ii,j,h1,p1,h2,p2
integer :: hh1,hh2,pp1,pp2
integer :: Ne(2)
integer, allocatable :: occ(:,:)
integer(bit_kind), allocatable :: key_i_core(:,:)
double precision :: hthree_aab, hthree_aaa
PROVIDE N_int
allocate( key_i_core(N_int,2) )
allocate( occ(N_int*bit_kind_size,2) )
if(core_tc_op)then
do i = 1, N_int
key_i_core(i,1) = xor(ref_bitmask(i,1),core_bitmask(i,1))
key_i_core(i,2) = xor(ref_bitmask(i,2),core_bitmask(i,2))
enddo
call bitstring_to_list_ab(key_i_core, occ, Ne, N_int)
else
call bitstring_to_list_ab(ref_bitmask, occ, Ne, N_int)
endif
normal_two_body_bi_orth_aa_bb = 0.d0
do hh1 = 1, n_act_orb
h1 = list_act(hh1)
do pp1 = 1 , n_act_orb
p1 = list_act(pp1)
do hh2 = 1, n_act_orb
h2 = list_act(hh2)
do pp2 = 1 , n_act_orb
p2 = list_act(pp2)
if(h1<h2.and.p1.gt.p2)then
call give_aab_contraction(N_int, h2, h1, p1, p2, Ne, occ, hthree_aab) ! exchange h1<->h2
if(Ne(2).ge.3)then
call give_aaa_contraction(N_int, h2, h1, p1, p2, Ne, occ, hthree_aaa) ! exchange h1<->h2
else
hthree_aaa = 0.d0
endif
else
call give_aab_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree_aab)
if(Ne(2).ge.3)then
call give_aaa_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree_aaa)
else
hthree_aaa = 0.d0
endif
endif
normal_two_body_bi_orth_aa_bb(p2,h2,p1,h1) = hthree_aab + hthree_aaa
enddo
enddo
enddo
enddo
deallocate( key_i_core )
deallocate( occ )
END_PROVIDER
! ---
subroutine give_aaa_contraction(Nint, h1, h2, p1, p2, Ne, occ, hthree)
BEGIN_DOC
! pure same spin contribution to same spin double excitation s1=h1,p1, s2=h2,p2, with s1==s2
END_DOC
use bitmasks ! you need to include the bitmasks_module.f90 features
implicit none
integer, intent(in) :: Nint, h1, h2, p1, p2
integer, intent(in) :: Ne(2), occ(Nint*bit_kind_size,2)
double precision, intent(out) :: hthree
integer :: ii,i
double precision :: int_direct,int_exc_12,int_exc_13,int_exc_23
double precision :: integral,int_exc_l,int_exc_ll
hthree = 0.d0
do ii = 1, Ne(2) ! purely closed shell part
i = occ(ii,2)
call give_integrals_3_body_bi_ort(i, p2, p1, i, h2, h1, integral)
int_direct = -1.d0 * integral
call give_integrals_3_body_bi_ort(p2, p1, i, i, h2, h1, integral)
int_exc_l = -1.d0 * integral
call give_integrals_3_body_bi_ort(p1, i, p2, i, h2, h1, integral)
int_exc_ll= -1.d0 * integral
call give_integrals_3_body_bi_ort(p2, i, p1, i, h2, h1, integral)
int_exc_12= -1.d0 * integral
call give_integrals_3_body_bi_ort(p1, p2, i, i, h2, h1, integral)
int_exc_13= -1.d0 * integral
call give_integrals_3_body_bi_ort(i, p1, p2, i, h2, h1, integral)
int_exc_23= -1.d0 * integral
hthree += 1.d0 * int_direct + int_exc_l + int_exc_ll - (int_exc_12 + int_exc_13 + int_exc_23)
enddo
do ii = Ne(2)+1,Ne(1) ! purely open-shell part
i = occ(ii,1)
call give_integrals_3_body_bi_ort(i, p2, p1, i, h2, h1, integral)
int_direct = -1.d0 * integral
call give_integrals_3_body_bi_ort(p2, p1, i , i, h2, h1, integral)
int_exc_l = -1.d0 * integral
call give_integrals_3_body_bi_ort(p1, i, p2, i, h2, h1, integral)
int_exc_ll = -1.d0 * integral
call give_integrals_3_body_bi_ort(p2, i, p1, i, h2, h1, integral)
int_exc_12 = -1.d0 * integral
call give_integrals_3_body_bi_ort(p1, p2, i, i, h2, h1, integral)
int_exc_13 = -1.d0 * integral
call give_integrals_3_body_bi_ort(i, p1, p2, i, h2, h1, integral)
int_exc_23 = -1.d0 * integral
!hthree += 1.d0 * int_direct + 0.5d0 * (int_exc_l + int_exc_ll - (int_exc_12 + int_exc_13 + int_exc_23))
hthree += 0.5d0 * int_direct + 0.5d0 * (int_exc_l + int_exc_ll - (int_exc_12 + int_exc_13 + int_exc_23))
enddo
return
end
! ---
subroutine give_aab_contraction(Nint, h1, h2, p1, p2, Ne, occ, hthree)
use bitmasks ! you need to include the bitmasks_module.f90 features
implicit none
integer, intent(in) :: Nint, h1, h2, p1, p2
integer, intent(in) :: Ne(2), occ(Nint*bit_kind_size,2)
double precision, intent(out) :: hthree
integer :: ii, i
double precision :: int_direct, int_exc_12, int_exc_13, int_exc_23
double precision :: integral, int_exc_l, int_exc_ll
hthree = 0.d0
do ii = 1, Ne(2) ! purely closed shell part
i = occ(ii,2)
call give_integrals_3_body_bi_ort(p2, p1, i, h2, h1, i, integral)
int_direct = -1.d0 * integral
call give_integrals_3_body_bi_ort(p1, p2, i, h2, h1, i, integral)
int_exc_23= -1.d0 * integral
hthree += 1.d0 * int_direct - int_exc_23
enddo
return
end
! ---

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

@ -1,25 +1,38 @@
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
elseif (double_normal_ord .and. (.not. three_e_5_idx_term))then
PROVIDE normal_two_body_bi_orth
endif
! ---
subroutine provide_all_three_ints_bi_ortho()
BEGIN_DOC
! routine that provides all necessary three-electron integrals
END_DOC
implicit none
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_exch23_bi_ort three_e_4_idx_exch13_bi_ort
endif
if(.not. double_normal_ord .and. three_e_5_idx_term) then
PROVIDE three_e_5_idx_direct_bi_ort
elseif(double_normal_ord .and. (.not. three_e_5_idx_term)) then
PROVIDE normal_two_body_bi_orth
endif
endif
return
end
! ---
subroutine htilde_mu_mat_opt_bi_ortho_tot(key_j, key_i, Nint, htot)
implicit none
BEGIN_DOC

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

@ -243,7 +243,9 @@ subroutine fock_ac_tc_operator(iorb,ispin,key, h_fock,p_fock, ispin_fock,hthree,
do j = 1, nb
jj = occ(j,other_spin)
direct_int = three_e_4_idx_direct_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR
exchange_int = three_e_4_idx_exch12_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR
! TODO
! use transpose
exchange_int = three_e_4_idx_exch13_bi_ort(iorb,jj,p_fock,h_fock) ! USES 4-IDX TENSOR
hthree += direct_int - exchange_int
enddo
else !! ispin NE to ispin_fock
@ -322,7 +324,8 @@ subroutine fock_a_tc_operator(iorb,ispin,key, h_fock,p_fock, ispin_fock,hthree,N
do j = 1, nb
jj = occ(j,other_spin)
direct_int = three_e_4_idx_direct_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR
exchange_int = three_e_4_idx_exch12_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR
! TODO use transpose
exchange_int = three_e_4_idx_exch13_bi_ort(iorb,jj,p_fock,h_fock) ! USES 4-IDX TENSOR
hthree -= direct_int - exchange_int
enddo
else !! ispin NE to ispin_fock

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

@ -96,9 +96,11 @@ double precision function three_e_single_parrallel_spin(m,j,k,i)
implicit none
integer, intent(in) :: i,k,j,m
three_e_single_parrallel_spin = three_e_4_idx_direct_bi_ort(m,j,k,i) ! direct
three_e_single_parrallel_spin += three_e_4_idx_cycle_1_bi_ort(m,j,k,i) + three_e_4_idx_cycle_2_bi_ort(m,j,k,i) & ! two cyclic permutations
three_e_single_parrallel_spin += three_e_4_idx_cycle_1_bi_ort(m,j,k,i) + three_e_4_idx_cycle_1_bi_ort(j,m,k,i) & ! two cyclic permutations
- three_e_4_idx_exch23_bi_ort(m,j,k,i) - three_e_4_idx_exch13_bi_ort(m,j,k,i) & ! two first exchange
- three_e_4_idx_exch12_bi_ort(m,j,k,i) ! last exchange
- three_e_4_idx_exch13_bi_ort(j,m,k,i) ! last exchange
! TODO
! use transpose
end
double precision function three_e_double_parrallel_spin(m,l,j,k,i)

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

@ -38,15 +38,16 @@ subroutine write_tc_var()
implicit none
integer :: i, j, k
double precision :: hmono, htwoe, hthree, htot
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)
SIGMA_TC = SIGMA_TC + htot * htot
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

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

@ -11,12 +11,14 @@ program tc_bi_ortho
touch read_wf
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
call test_h_u0
! call test_h_u0
! call test_slater_tc_opt
! call timing_tot
! call timing_diag
! call timing_single
! call timing_double
call test_no()
end
subroutine test_h_u0
@ -252,3 +254,47 @@ subroutine timing_double
end
! ---
subroutine test_no()
implicit none
integer :: i, j, k, l
double precision :: accu, contrib, new, ref, thr
print*, ' testing normal_two_body_bi_orth ...'
thr = 1d-8
PROVIDE normal_two_body_bi_orth_old
PROVIDE normal_two_body_bi_orth
accu = 0.d0
do i = 1, mo_num
do j = 1, mo_num
do k = 1, mo_num
do l = 1, mo_num
new = normal_two_body_bi_orth (l,k,j,i)
ref = normal_two_body_bi_orth_old(l,k,j,i)
contrib = dabs(new - ref)
accu += contrib
if(contrib .gt. thr) then
print*, ' problem on normal_two_body_bi_orth'
print*, l, k, j, i
print*, ref, new, contrib
stop
endif
enddo
enddo
enddo
enddo
print*, ' accu on normal_two_body_bi_orth = ', accu / dble(mo_num)**4
return
end
! ---

6
src/tc_keywords/EZFIO.cfg
View File

@ -226,6 +226,12 @@ doc: Read/Write integrals int2_grad1_u12_ao, tc_grad_square_ao and tc_grad_and_l
interface: ezfio,provider,ocaml
default: None
[io_tc_norm_ord]
type: Disk_access
doc: Read/Write normal_two_body_bi_orth from/to disk [ Write | Read | None ]
interface: ezfio,provider,ocaml
default: None
[debug_tc_pt2]
type: integer
doc: If :: 1 then you compute the TC-PT2 the old way, :: 2 then you check with the new version but without three-body

39
src/tc_scf/rh_tcscf_diis.irp.f
View File

@ -11,6 +11,7 @@ subroutine rh_tcscf_diis()
integer :: i, j, it
integer :: dim_DIIS, index_dim_DIIS
logical :: converged
double precision :: etc_tot, etc_1e, etc_2e, etc_3e, e_save, e_delta
double precision :: tc_grad, g_save, g_delta, g_delta_th
double precision :: level_shift_save, rate_th
@ -92,8 +93,9 @@ subroutine rh_tcscf_diis()
PROVIDE FQS_SQF_ao Fock_matrix_tc_ao_tot
converged = .false.
!do while((tc_grad .gt. dsqrt(thresh_tcscf)) .and. (er_DIIS .gt. dsqrt(thresh_tcscf)))
do while(er_DIIS .gt. dsqrt(thresh_tcscf))
do while(.not. converged)
call wall_time(t0)
@ -218,21 +220,56 @@ subroutine rh_tcscf_diis()
!g_delta_th = dabs(tc_grad) ! g_delta)
er_delta_th = dabs(er_DIIS) !er_delta)
converged = er_DIIS .lt. dsqrt(thresh_tcscf)
call wall_time(t1)
!write(6, '(I4,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, I4,1X, F8.2)') &
! it, etc_tot, etc_1e, etc_2e, etc_3e, e_delta, tc_grad, er_DIIS, level_shift_tcscf, dim_DIIS, (t1-t0)/60.d0
write(6, '(I4,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, I4,1X, F8.2)') &
it, etc_tot, etc_1e, etc_2e, etc_3e, e_delta, er_DIIS, level_shift_tcscf, dim_DIIS, (t1-t0)/60.d0
! Write data in JSON file
call lock_io
if (it == 1) then
write(json_unit, json_dict_uopen_fmt)
else
write(json_unit, json_dict_close_uopen_fmt)
endif
write(json_unit, json_int_fmt) ' iteration ', it
write(json_unit, json_real_fmt) ' SCF TC Energy ', etc_tot
write(json_unit, json_real_fmt) ' E(1e) ', etc_1e
write(json_unit, json_real_fmt) ' E(2e) ', etc_2e
write(json_unit, json_real_fmt) ' E(3e) ', etc_3e
write(json_unit, json_real_fmt) ' delta Energy ', e_delta
write(json_unit, json_real_fmt) ' DIIS error ', er_DIIS
write(json_unit, json_real_fmt) ' level_shift ', level_shift_tcscf
write(json_unit, json_real_fmt) ' DIIS ', dim_DIIS
write(json_unit, json_real_fmt) ' Wall time (min)', (t1-t0)/60.d0
call unlock_io
if(er_delta .lt. 0.d0) then
call ezfio_set_tc_scf_bitc_energy(etc_tot)
call ezfio_set_bi_ortho_mos_mo_l_coef(mo_l_coef)
call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef)
write(json_unit, json_true_fmt) 'saved'
else
write(json_unit, json_false_fmt) 'saved'
endif
call lock_io
if (converged) then
write(json_unit, json_true_fmtx) 'converged'
else
write(json_unit, json_false_fmtx) 'converged'
endif
call unlock_io
if(qp_stop()) exit
enddo
write(json_unit, json_dict_close_fmtx)
! ---
print *, ' TCSCF DIIS converged !'

4
src/tc_scf/tc_scf.irp.f
View File

@ -8,6 +8,8 @@ program tc_scf
implicit none
write(json_unit,json_array_open_fmt) 'tc-scf'
print *, ' starting ...'
my_grid_becke = .True.
@ -57,6 +59,8 @@ program tc_scf
endif
write(json_unit,json_array_close_fmtx)
call json_close
end

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

@ -490,7 +490,7 @@ end subroutine check_sym
subroutine sum_A_At(A, N)
!BEGIN_DOC
! useful for symmetrizing a tensor without a temporary tensor
! add a tensor with its transpose without a temporary tensor
!END_DOC
implicit none
@ -521,3 +521,38 @@ subroutine sum_A_At(A, N)
end
! ---
subroutine sub_A_At(A, N)
!BEGIN_DOC
! substruct a tensor with its transpose without a temporary tensor
!END_DOC
implicit none
integer, intent(in) :: N
double precision, intent(inout) :: A(N,N)
integer :: i, j
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j) &
!$OMP SHARED (A, N)
!$OMP DO
do j = 1, N
do i = j, N
A(i,j) -= A(j,i)
enddo
enddo
!$OMP END DO
!$OMP DO
do j = 2, N
do i = 1, j-1
A(i,j) = -A(j,i)
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
end