LCPQ/qp2
9
1
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-12-21 11:03:29 +01:00
Code Releases Activity

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

Browse Source 
Dev stable tc scf
This commit is contained in:
AbdAmmar 2023-09-19 14:15:38 +02:00 committed by GitHub
commit a3e8b4732a
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
55 changed files with 8346 additions and 3344 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

154
src/ao_many_one_e_ints/ao_erf_gauss.irp.f
View File

@ -1245,3 +1245,157 @@ end subroutine NAI_pol_x2_mult_erf_ao
! ---
subroutine NAI_pol_012_mult_erf_ao_with1s(i_ao, j_ao, beta, B_center, mu_in, C_center, ints)
BEGIN_DOC
!
! Computes the following integral :
!
! ints(1) = $\int_{-\infty}^{infty} dr x^0 * \chi_i(r) \chi_j(r) e^{-\beta (r - B_center)^2} \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
! ints(2) = $\int_{-\infty}^{infty} dr x^1 * \chi_i(r) \chi_j(r) e^{-\beta (r - B_center)^2} \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
! ints(3) = $\int_{-\infty}^{infty} dr y^1 * \chi_i(r) \chi_j(r) e^{-\beta (r - B_center)^2} \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
! ints(4) = $\int_{-\infty}^{infty} dr z^1 * \chi_i(r) \chi_j(r) e^{-\beta (r - B_center)^2} \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
! ints(5) = $\int_{-\infty}^{infty} dr x^2 * \chi_i(r) \chi_j(r) e^{-\beta (r - B_center)^2} \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
! ints(6) = $\int_{-\infty}^{infty} dr y^2 * \chi_i(r) \chi_j(r) e^{-\beta (r - B_center)^2} \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
! ints(7) = $\int_{-\infty}^{infty} dr z^2 * \chi_i(r) \chi_j(r) e^{-\beta (r - B_center)^2} \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
END_DOC
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: i_ao, j_ao
double precision, intent(in) :: beta, B_center(3), mu_in, C_center(3)
double precision, intent(out) :: ints(7)
integer :: i, j, power_Ai(3), power_Aj(3), n_pt_in, m
integer :: power_A1(3), power_A2(3)
double precision :: Ai_center(3), Aj_center(3), alphai, alphaj, coef, coefi
double precision :: integral0, integral1, integral2
double precision, external :: NAI_pol_mult_erf_with1s
ASSERT(beta .ge. 0.d0)
if(beta .lt. 1d-10) then
call NAI_pol_012_mult_erf_ao(i_ao, j_ao, mu_in, C_center, ints)
return
endif
ints = 0.d0
power_Ai(1:3) = ao_power(i_ao,1:3)
power_Aj(1:3) = ao_power(j_ao,1:3)
Ai_center(1:3) = nucl_coord(ao_nucl(i_ao),1:3)
Aj_center(1:3) = nucl_coord(ao_nucl(j_ao),1:3)
n_pt_in = n_pt_max_integrals
do i = 1, ao_prim_num(i_ao)
alphai = ao_expo_ordered_transp (i,i_ao)
coefi = ao_coef_normalized_ordered_transp(i,i_ao)
do j = 1, ao_prim_num(j_ao)
alphaj = ao_expo_ordered_transp (j,j_ao)
coef = coefi * ao_coef_normalized_ordered_transp(j,j_ao)
integral0 = NAI_pol_mult_erf_with1s(Ai_center, Aj_center, power_Ai, power_Aj, alphai, alphaj, beta, B_center, C_center, n_pt_in, mu_in)
ints(1) += coef * integral0
do m = 1, 3
power_A1 = power_Ai
power_A1(m) += 1
integral1 = NAI_pol_mult_erf_with1s(Ai_center, Aj_center, power_A1, power_Aj, alphai, alphaj, beta, B_center, C_center, n_pt_in, mu_in)
ints(1+m) += coef * (integral1 + Ai_center(m)*integral0)
power_A2 = power_Ai
power_A2(m) += 2
integral2 = NAI_pol_mult_erf_with1s(Ai_center, Aj_center, power_A2, power_Aj, alphai, alphaj, beta, B_center, C_center, n_pt_in, mu_in)
ints(4+m) += coef * (integral2 + Ai_center(m) * (2.d0*integral1 + Ai_center(m)*integral0))
enddo
enddo
enddo
end subroutine NAI_pol_012_mult_erf_ao_with1s
! ---
subroutine NAI_pol_012_mult_erf_ao(i_ao, j_ao, mu_in, C_center, ints)
BEGIN_DOC
!
! Computes the following integral :
!
! int(1) = $\int_{-\infty}^{infty} dr x^0 * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
! int(2) = $\int_{-\infty}^{infty} dr x^1 * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
! int(3) = $\int_{-\infty}^{infty} dr y^1 * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
! int(4) = $\int_{-\infty}^{infty} dr z^1 * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
! int(5) = $\int_{-\infty}^{infty} dr x^2 * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
! int(6) = $\int_{-\infty}^{infty} dr y^2 * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
! int(7) = $\int_{-\infty}^{infty} dr z^2 * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
END_DOC
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: i_ao, j_ao
double precision, intent(in) :: mu_in, C_center(3)
double precision, intent(out) :: ints(7)
integer :: i, j, num_A, num_B, power_A(3), power_B(3), n_pt_in, m
integer :: power_A1(3), power_A2(3)
double precision :: A_center(3), B_center(3), alpha, beta, coef
double precision :: integral0, integral1, integral2
double precision :: NAI_pol_mult_erf
ints = 0.d0
num_A = ao_nucl(i_ao)
power_A(1:3) = ao_power(i_ao,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
num_B = ao_nucl(j_ao)
power_B(1:3) = ao_power(j_ao,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
n_pt_in = n_pt_max_integrals
do i = 1, ao_prim_num(i_ao)
alpha = ao_expo_ordered_transp(i,i_ao)
do j = 1, ao_prim_num(j_ao)
beta = ao_expo_ordered_transp(j,j_ao)
coef = ao_coef_normalized_ordered_transp(j,j_ao) * ao_coef_normalized_ordered_transp(i,i_ao)
integral0 = NAI_pol_mult_erf(A_center, B_center, power_A, power_B, alpha, beta, C_center, n_pt_in, mu_in)
ints(1) += coef * integral0
do m = 1, 3
power_A1 = power_A
power_A1(m) += 1
integral1 = NAI_pol_mult_erf(A_center, B_center, power_A1, power_B, alpha, beta, C_center, n_pt_in, mu_in)
ints(1+m) += coef * (integral1 + A_center(m)*integral0)
power_A2 = power_A
power_A2(m) += 2
integral2 = NAI_pol_mult_erf(A_center, B_center, power_A2, power_B, alpha, beta, C_center, n_pt_in, mu_in)
ints(4+m) += coef * (integral2 + A_center(m) * (2.d0*integral1 + A_center(m)*integral0))
enddo
enddo
enddo
end subroutine NAI_pol_012_mult_erf_ao
! ---

131
src/ao_many_one_e_ints/grad_lapl_jmu_modif.irp.f
View File

@ -299,15 +299,12 @@ END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_points_final_grid)]
BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_j1b_an_old, (ao_num, ao_num, n_points_final_grid)]
BEGIN_DOC
!
! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2) u(mu, r12)
!
! TODO
! one subroutine for all integrals
!
END_DOC
include 'constants.include.F'
@ -325,7 +322,7 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_poin
double precision, external :: overlap_gauss_r12_ao_with1s
double precision, external :: NAI_pol_mult_erf_ao_with1s
print*, ' providing v_ij_u_cst_mu_j1b_an ...'
print*, ' providing v_ij_u_cst_mu_j1b_an_old ...'
call wall_time(wall0)
provide mu_erf final_grid_points j1b_pen
@ -333,7 +330,7 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_poin
ct = inv_sq_pi_2 / mu_erf
v_ij_u_cst_mu_j1b_an = 0.d0
v_ij_u_cst_mu_j1b_an_old = 0.d0
!$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, &
@ -342,7 +339,7 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_poin
!$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b2_size, &
!$OMP final_grid_points, mu_erf, ct, &
!$OMP List_all_comb_b2_coef, List_all_comb_b2_expo, &
!$OMP List_all_comb_b2_cent, v_ij_u_cst_mu_j1b_an)
!$OMP List_all_comb_b2_cent, v_ij_u_cst_mu_j1b_an_old)
!$OMP DO
do ipoint = 1, n_points_final_grid
@ -413,6 +410,125 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_poin
! ---
v_ij_u_cst_mu_j1b_an_old(j,i,ipoint) = tmp
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
do ipoint = 1, n_points_final_grid
do i = 2, ao_num
do j = 1, i-1
v_ij_u_cst_mu_j1b_an_old(j,i,ipoint) = v_ij_u_cst_mu_j1b_an_old(i,j,ipoint)
enddo
enddo
enddo
call wall_time(wall1)
print*, ' wall time for v_ij_u_cst_mu_j1b_an_old', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_points_final_grid)]
BEGIN_DOC
!
! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2) u(mu, r12)
!
END_DOC
include 'constants.include.F'
implicit none
integer :: i, j, ipoint, i_1s
double precision :: r(3), r1_2
double precision :: int_o
double precision :: int_c(7), int_e(7)
double precision :: coef, beta, B_center(3)
double precision :: tmp, ct
double precision :: wall0, wall1
double precision, external :: overlap_gauss_r12_ao_with1s
double precision, external :: NAI_pol_mult_erf_ao_with1s
print*, ' providing v_ij_u_cst_mu_j1b_an ...'
call wall_time(wall0)
provide mu_erf final_grid_points j1b_pen
PROVIDE List_all_comb_b2_size List_all_comb_b2_coef List_all_comb_b2_expo List_all_comb_b2_cent
ct = inv_sq_pi_2 / mu_erf
v_ij_u_cst_mu_j1b_an = 0.d0
!$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, &
!$OMP r1_2, tmp, int_c, int_e, int_o) &
!$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b2_size, &
!$OMP final_grid_points, mu_erf, ct, &
!$OMP List_all_comb_b2_coef, List_all_comb_b2_expo, &
!$OMP List_all_comb_b2_cent, v_ij_u_cst_mu_j1b_an)
!$OMP DO
do ipoint = 1, n_points_final_grid
r(1) = final_grid_points(1,ipoint)
r(2) = final_grid_points(2,ipoint)
r(3) = final_grid_points(3,ipoint)
r1_2 = 0.5d0 * (r(1)*r(1) + r(2)*r(2) + r(3)*r(3))
do i = 1, ao_num
do j = i, ao_num
! ---
coef = List_all_comb_b2_coef (1)
beta = List_all_comb_b2_expo (1)
B_center(1) = List_all_comb_b2_cent(1,1)
B_center(2) = List_all_comb_b2_cent(2,1)
B_center(3) = List_all_comb_b2_cent(3,1)
call NAI_pol_012_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r, int_c)
call NAI_pol_012_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r, int_e)
int_o = overlap_gauss_r12_ao_with1s(B_center, beta, r, mu_erf*mu_erf, i, j)
tmp = coef &
* ( r1_2 * (int_c(1) - int_e(1)) &
- r(1) * (int_c(2) - int_e(2)) - r(2) * (int_c(3) - int_e(3)) - r(3) * (int_c(4) - int_e(4)) &
+ 0.5d0 * (int_c(5) + int_c(6) + int_c(7) - int_e(5) - int_e(6) - int_e(7)) &
- ct * int_o &
)
! ---
do i_1s = 2, List_all_comb_b2_size
coef = List_all_comb_b2_coef (i_1s)
if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0
beta = List_all_comb_b2_expo (i_1s)
B_center(1) = List_all_comb_b2_cent(1,i_1s)
B_center(2) = List_all_comb_b2_cent(2,i_1s)
B_center(3) = List_all_comb_b2_cent(3,i_1s)
call NAI_pol_012_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r, int_c)
call NAI_pol_012_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r, int_e)
int_o = overlap_gauss_r12_ao_with1s(B_center, beta, r, mu_erf*mu_erf, i, j)
tmp = tmp + coef &
* ( r1_2 * (int_c(1) - int_e(1)) &
- r(1) * (int_c(2) - int_e(2)) - r(2) * (int_c(3) - int_e(3)) - r(3) * (int_c(4) - int_e(4)) &
+ 0.5d0 * (int_c(5) + int_c(6) + int_c(7) - int_e(5) - int_e(6) - int_e(7)) &
- ct * int_o &
)
enddo
! ---
v_ij_u_cst_mu_j1b_an(j,i,ipoint) = tmp
enddo
enddo
@ -434,4 +550,3 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_poin
END_PROVIDER
! ---

4
src/becke_numerical_grid/EZFIO.cfg
View File

@ -33,6 +33,10 @@ doc: Number of angular grid points given from input. Warning, this number cannot
interface: ezfio,provider,ocaml
default: 1202
[n_points_extra_final_grid]
type: integer
doc: Total number of extra_grid points
interface: ezfio
[extra_grid_type_sgn]
type: integer

4
src/becke_numerical_grid/extra_grid.irp.f
View File

@ -14,7 +14,7 @@
implicit none
if(.not.my_extra_grid_becke)then
if(.not. my_extra_grid_becke) then
select case (extra_grid_type_sgn)
case(0)
n_points_extra_radial_grid = 23
@ -33,7 +33,7 @@
stop
end select
else
n_points_extra_radial_grid = my_n_pt_r_extra_grid
n_points_extra_radial_grid = my_n_pt_r_extra_grid
n_points_extra_integration_angular = my_n_pt_a_extra_grid
endif

34
src/becke_numerical_grid/extra_grid_vector.irp.f
View File

@ -23,29 +23,33 @@ BEGIN_PROVIDER [integer, n_points_extra_final_grid]
enddo
enddo
print*,'n_points_extra_final_grid = ',n_points_extra_final_grid
print*,'n max point = ',n_points_extra_integration_angular*(n_points_extra_radial_grid*nucl_num - 1)
! call ezfio_set_becke_numerical_grid_n_points_extra_final_grid(n_points_extra_final_grid)
print*, ' n_points_extra_final_grid = ', n_points_extra_final_grid
print*, ' n max point = ', n_points_extra_integration_angular*(n_points_extra_radial_grid*nucl_num - 1)
call ezfio_set_becke_numerical_grid_n_points_extra_final_grid(n_points_extra_final_grid)
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, final_grid_points_extra, (3,n_points_extra_final_grid)]
&BEGIN_PROVIDER [double precision, final_weight_at_r_vector_extra, (n_points_extra_final_grid) ]
&BEGIN_PROVIDER [integer, index_final_points_extra, (3,n_points_extra_final_grid) ]
&BEGIN_PROVIDER [integer, index_final_points_extra_reverse, (n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num) ]
implicit none
&BEGIN_PROVIDER [double precision, final_weight_at_r_vector_extra, (n_points_extra_final_grid)]
&BEGIN_PROVIDER [integer, index_final_points_extra, (3,n_points_extra_final_grid)]
&BEGIN_PROVIDER [integer, index_final_points_extra_reverse, (n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num)]
BEGIN_DOC
! final_grid_points_extra(1:3,j) = (/ x, y, z /) of the jth grid point
!
! final_weight_at_r_vector_extra(i) = Total weight function of the ith grid point which contains the Lebedev, Voronoi and radial weights contributions
!
! index_final_points_extra(1:3,i) = gives the angular, radial and atomic indices associated to the ith grid point
!
! index_final_points_extra_reverse(i,j,k) = index of the grid point having i as angular, j as radial and l as atomic indices
! final_grid_points_extra(1:3,j) = (/ x, y, z /) of the jth grid point
!
! final_weight_at_r_vector_extra(i) = Total weight function of the ith grid point which contains the Lebedev, Voronoi and radial weights contributions
!
! index_final_points_extra(1:3,i) = gives the angular, radial and atomic indices associated to the ith grid point
!
! index_final_points_extra_reverse(i,j,k) = index of the grid point having i as angular, j as radial and l as atomic indices
END_DOC
implicit none
integer :: i,j,k,l,i_count
double precision :: r(3)
i_count = 0
do j = 1, nucl_num
do i = 1, n_points_extra_radial_grid -1
@ -67,3 +71,5 @@ END_PROVIDER
enddo
END_PROVIDER

5
src/becke_numerical_grid/grid_becke.irp.f
View File

@ -14,7 +14,7 @@
implicit none
if(.not.my_grid_becke)then
if(.not. my_grid_becke) then
select case (grid_type_sgn)
case(0)
n_points_radial_grid = 23
@ -37,6 +37,9 @@
n_points_integration_angular = my_n_pt_a_grid
endif
print*, " n_points_radial_grid = ", n_points_radial_grid
print*, " n_points_integration_angular = ", n_points_integration_angular
END_PROVIDER
! ---

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

@ -18,10 +18,11 @@ program bi_ort_ints
! call test_5idx
! call test_5idx2
call test_4idx()
call test_4idx_n4()
!call test_4idx_n4()
!call test_4idx2()
!call test_5idx2
!call test_5idx
end
subroutine test_5idx2
@ -340,7 +341,7 @@ subroutine test_4idx()
implicit none
integer :: i, j, k, l
double precision :: accu, contrib, new, ref, thr
double precision :: accu, contrib, new, ref, thr, norm
thr = 1d-10
@ -348,6 +349,7 @@ subroutine test_4idx()
PROVIDE three_e_4_idx_direct_bi_ort
accu = 0.d0
norm = 0.d0
do i = 1, mo_num
do j = 1, mo_num
do k = 1, mo_num
@ -356,7 +358,6 @@ subroutine test_4idx()
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
@ -364,11 +365,14 @@ subroutine test_4idx()
stop
endif
accu += contrib
norm += dabs(ref)
enddo
enddo
enddo
enddo
print*, ' accu on three_e_4_idx_direct_bi_ort = ', accu / dble(mo_num)**4
print*, ' accu on three_e_4_idx_direct_bi_ort (%) = ', 100.d0 * accu / norm
! ---
@ -376,6 +380,7 @@ subroutine test_4idx()
PROVIDE three_e_4_idx_exch13_bi_ort
accu = 0.d0
norm = 0.d0
do i = 1, mo_num
do j = 1, mo_num
do k = 1, mo_num
@ -384,7 +389,6 @@ subroutine test_4idx()
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
@ -392,11 +396,14 @@ subroutine test_4idx()
stop
endif
accu += contrib
norm += dabs(ref)
enddo
enddo
enddo
enddo
print*, ' accu on three_e_4_idx_exch13_bi_ort = ', accu / dble(mo_num)**4
print*, ' accu on three_e_4_idx_exch13_bi_ort (%) = ', 100.d0 * accu / norm
! ---
@ -404,6 +411,7 @@ subroutine test_4idx()
PROVIDE three_e_4_idx_cycle_1_bi_ort
accu = 0.d0
norm = 0.d0
do i = 1, mo_num
do j = 1, mo_num
do k = 1, mo_num
@ -412,7 +420,6 @@ subroutine test_4idx()
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
@ -420,11 +427,14 @@ subroutine test_4idx()
stop
endif
accu += contrib
norm += dabs(ref)
enddo
enddo
enddo
enddo
print*, ' accu on three_e_4_idx_cycle_1_bi_ort = ', accu / dble(mo_num)**4
print*, ' accu on three_e_4_idx_cycle_1_bi_ort (%) = ', 100.d0 * accu / norm
! ---
@ -432,6 +442,7 @@ subroutine test_4idx()
PROVIDE three_e_4_idx_exch23_bi_ort
accu = 0.d0
norm = 0.d0
do i = 1, mo_num
do j = 1, mo_num
do k = 1, mo_num
@ -440,7 +451,6 @@ subroutine test_4idx()
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
@ -448,13 +458,18 @@ subroutine test_4idx()
stop
endif
accu += contrib
norm += dabs(ref)
enddo
enddo
enddo
enddo
print*, ' accu on three_e_4_idx_exch23_bi_ort = ', accu / dble(mo_num)**4
print*, ' accu on three_e_4_idx_exch23_bi_ort (%) = ', 100.d0 * accu / norm
! ---
return
end

1610
src/bi_ort_ints/no_dressing.irp.f Normal file
View File

File diff suppressed because it is too large Load Diff

66
src/bi_ort_ints/no_dressing_energy.irp.f Normal file
View File

@ -0,0 +1,66 @@
! ---
BEGIN_PROVIDER [double precision, energy_1e_noL_HF]
implicit none
integer :: i
PROVIDE mo_bi_ortho_tc_one_e
energy_1e_noL_HF = 0.d0
do i = 1, elec_beta_num
energy_1e_noL_HF += mo_bi_ortho_tc_one_e(i,i)
enddo
do i = 1, elec_alpha_num
energy_1e_noL_HF += mo_bi_ortho_tc_one_e(i,i)
enddo
print*, "energy_1e_noL_HF = ", energy_1e_noL_HF
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, energy_2e_noL_HF]
implicit none
integer :: i, j
PROVIDE mo_bi_ortho_tc_two_e
energy_2e_noL_HF = 0.d0
! down-down & down-down
do i = 1, elec_beta_num
do j = 1, elec_beta_num
energy_2e_noL_HF += (mo_bi_ortho_tc_two_e(i,j,i,j) - mo_bi_ortho_tc_two_e(j,i,i,j))
enddo
enddo
! down-down & up-up
do i = 1, elec_beta_num
do j = 1, elec_alpha_num
energy_2e_noL_HF += mo_bi_ortho_tc_two_e(i,j,i,j)
enddo
enddo
! up-up & down-down
do i = 1, elec_alpha_num
do j = 1, elec_beta_num
energy_2e_noL_HF += mo_bi_ortho_tc_two_e(i,j,i,j)
enddo
enddo
! up-up & up-up
do i = 1, elec_alpha_num
do j = 1, elec_alpha_num
energy_2e_noL_HF += (mo_bi_ortho_tc_two_e(i,j,i,j) - mo_bi_ortho_tc_two_e(j,i,i,j))
enddo
enddo
! 0.5 x is in the Slater-Condon rules and not in the integrals
energy_2e_noL_HF = 0.5d0 * energy_2e_noL_HF
print*, "energy_2e_noL_HF = ", energy_2e_noL_HF
END_PROVIDER
! ---

512
src/bi_ort_ints/no_dressing_naive.irp.f Normal file
View File

@ -0,0 +1,512 @@
! ---
BEGIN_PROVIDER [double precision, noL_0e_naive]
implicit none
integer :: ii, jj, kk
integer :: i, j, k
double precision :: sigma_i, sigma_j, sigma_k
double precision :: I_ijk_ijk, I_ijk_kij, I_ijk_jki, I_ijk_jik, I_ijk_kji, I_ijk_ikj
double precision :: t0, t1
double precision, allocatable :: tmp(:)
print*, " Providing noL_0e_naive ..."
call wall_time(t0)
allocate(tmp(elec_num))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ii, i, sigma_i, jj, j, sigma_j, kk, k, sigma_k, &
!$OMP I_ijk_ijk, I_ijk_kij, I_ijk_jki, I_ijk_jik, &
!$OMP I_ijk_kji, I_ijk_ikj) &
!$OMP SHARED (elec_beta_num, elec_num, tmp)
!$OMP DO
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
tmp(ii) = 0.d0
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(ii) = tmp(ii) + I_ijk_ijk + I_ijk_kij + I_ijk_jki - I_ijk_jik - I_ijk_kji - I_ijk_ikj
! = tmp(ii) + I_ijk_ijk + 2.d0 * I_ijk_kij - 3.d0 * I_ijk_jik
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
noL_0e_naive = -1.d0 * (sum(tmp)) / 6.d0
deallocate(tmp)
call wall_time(t1)
print*, " Wall time for noL_0e_naive (min) = ", (t1 - t0)/60.d0
print*, " noL_0e_naive = ", noL_0e_naive
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, noL_1e_naive, (mo_num, mo_num)]
BEGIN_DOC
!
! < p | H(1) | s > is dressed with noL_1e_naive(p,s)
!
END_DOC
implicit none
integer :: ii, jj
integer :: i, j, p, s
double precision :: sigma_i, sigma_j, sigma_p, sigma_s
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 noL_1e_naive ..."
call wall_time(t0)
! ----
! up-up part
sigma_p = +1.d0
sigma_s = +1.d0
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ii, i, sigma_i, jj, j, sigma_j, &
!$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, noL_1e_naive)
!$OMP DO COLLAPSE (2)
do s = 1, mo_num
do p = 1, mo_num
noL_1e_naive(p,s) = 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 = +1d0
endif
call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
, s, sigma_s, j, sigma_j, i, sigma_i &
, I_pij_sji)
call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
, s, sigma_s, i, sigma_i, j, sigma_j &
, I_pij_sij)
call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
, j, sigma_j, i, sigma_i, s, sigma_s &
, I_pij_jis)
call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
, i, sigma_i, j, sigma_j, s, sigma_s &
, I_pij_ijs)
call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
, i, sigma_i, s, sigma_s, j, sigma_j &
, I_pij_isj)
call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
, j, sigma_j, s, sigma_s, i, sigma_i &
, I_pij_jsi)
! x 0.5 because we consider 0.5 (up + down)
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
enddo ! p
!$OMP END DO
!$OMP END PARALLEL
! ----
! down-down part
sigma_p = -1.d0
sigma_s = -1.d0
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ii, i, sigma_i, jj, j, sigma_j, &
!$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, noL_1e_naive)
!$OMP DO COLLAPSE (2)
do s = 1, mo_num
do p = 1, mo_num
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 = +1d0
endif
call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
, s, sigma_s, j, sigma_j, i, sigma_i &
, I_pij_sji)
call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
, s, sigma_s, i, sigma_i, j, sigma_j &
, I_pij_sij)
call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
, j, sigma_j, i, sigma_i, s, sigma_s &
, I_pij_jis)
call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
, i, sigma_i, j, sigma_j, s, sigma_s &
, I_pij_ijs)
call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
, i, sigma_i, s, sigma_s, j, sigma_j &
, I_pij_isj)
call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
, j, sigma_j, s, sigma_s, i, sigma_i &
, I_pij_jsi)
! x 0.5 because we consider 0.5 (up + down)
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
enddo ! p
!$OMP END DO
!$OMP END PARALLEL
! ---
call wall_time(t1)
print*, " Wall time for noL_1e_naive (min) = ", (t1 - t0)/60.d0
END_PROVIDER
! ---
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 noL_2e_naive(p,q,s,t)
!
END_DOC
implicit none
integer :: ii
integer :: i, p, q, s, t
double precision :: sigma_i, sigma_p, sigma_q, sigma_s, sigma_t
double precision :: I_ipq_ist, I_ipq_sit, I_ipq_tsi
double precision :: t0, t1
print*, " Providing noL_2e_naive ..."
call wall_time(t0)
! ----
! up-up & up-up part
sigma_p = +1.d0
sigma_s = +1.d0
sigma_q = +1.d0
sigma_t = +1.d0
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ii, i, sigma_i, p, q, s, t, &
!$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 noL_2e_naive)
!$OMP DO COLLAPSE (4)
do t = 1, mo_num
do s = 1, mo_num
do q = 1, mo_num
do p = 1, mo_num
noL_2e_naive(p,q,s,t) = 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
call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
, i, sigma_i, s, sigma_s, t, sigma_t &
, I_ipq_ist)
call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
, s, sigma_s, i, sigma_i, t, sigma_t &
, I_ipq_sit)
call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
, t, sigma_t, s, sigma_s, i, sigma_i &
, I_ipq_tsi)
! x 0.25 because we consider 0.25 (up-up + up-down + down-up + down-down)
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
enddo ! s
enddo ! t
!$OMP END DO
!$OMP END PARALLEL
! ----
! up-up & down-down part
sigma_p = +1.d0
sigma_s = +1.d0
sigma_q = -1.d0
sigma_t = -1.d0
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ii, i, sigma_i, p, q, s, t, &
!$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 noL_2e_naive)
!$OMP DO COLLAPSE (4)
do t = 1, mo_num
do s = 1, mo_num
do q = 1, mo_num
do p = 1, mo_num
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
call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
, i, sigma_i, s, sigma_s, t, sigma_t &
, I_ipq_ist)
call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
, s, sigma_s, i, sigma_i, t, sigma_t &
, I_ipq_sit)
call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
, t, sigma_t, s, sigma_s, i, sigma_i &
, I_ipq_tsi)
! x 0.25 because we consider 0.25 (up-up + up-down + down-up + down-down)
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
enddo ! s
enddo ! t
!$OMP END DO
!$OMP END PARALLEL
! ----
! down-down & up-up part
sigma_p = -1.d0
sigma_s = -1.d0
sigma_q = +1.d0
sigma_t = +1.d0
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ii, i, sigma_i, p, q, s, t, &
!$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 noL_2e_naive)
!$OMP DO COLLAPSE (4)
do t = 1, mo_num
do s = 1, mo_num
do q = 1, mo_num
do p = 1, mo_num
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
call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
, i, sigma_i, s, sigma_s, t, sigma_t &
, I_ipq_ist)
call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
, s, sigma_s, i, sigma_i, t, sigma_t &
, I_ipq_sit)
call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
, t, sigma_t, s, sigma_s, i, sigma_i &
, I_ipq_tsi)
! x 0.25 because we consider 0.25 (up-up + up-down + down-up + down-down)
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
enddo ! s
enddo ! t
!$OMP END DO
!$OMP END PARALLEL
! ----
! down-down & down-down part
sigma_p = -1.d0
sigma_s = -1.d0
sigma_q = -1.d0
sigma_t = -1.d0
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ii, i, sigma_i, p, q, s, t, &
!$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 noL_2e_naive)
!$OMP DO COLLAPSE (4)
do t = 1, mo_num
do s = 1, mo_num
do q = 1, mo_num
do p = 1, mo_num
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
call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
, i, sigma_i, s, sigma_s, t, sigma_t &
, I_ipq_ist)
call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
, s, sigma_s, i, sigma_i, t, sigma_t &
, I_ipq_sit)
call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
, t, sigma_t, s, sigma_s, i, sigma_i &
, I_ipq_tsi)
! x 0.25 because we consider 0.25 (up-up + up-down + down-up + down-down)
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
enddo ! s
enddo ! t
!$OMP END DO
!$OMP END PARALLEL
call wall_time(t1)
print*, " Wall time for noL_2e_naive (min) = ", (t1 - t0)/60.d0
END_PROVIDER
! ---

21
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
! ---
@ -48,12 +53,14 @@ END_PROVIDER
BEGIN_PROVIDER [double precision, mo_bi_orth_bipole_x , (mo_num,mo_num)]
&BEGIN_PROVIDER [double precision, mo_bi_orth_bipole_y , (mo_num,mo_num)]
&BEGIN_PROVIDER [double precision, mo_bi_orth_bipole_z , (mo_num,mo_num)]
BEGIN_DOC
! array of the integrals of Left MO_i * x Right MO_j
! array of the integrals of Left MO_i * y Right MO_j
! array of the integrals of Left MO_i * z Right MO_j
END_DOC
implicit none
BEGIN_DOC
! array of the integrals of Left MO_i * x Right MO_j
! array of the integrals of Left MO_i * y Right MO_j
! array of the integrals of Left MO_i * z Right MO_j
END_DOC
implicit none
call ao_to_mo_bi_ortho( &
ao_dipole_x, &

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

@ -64,120 +64,117 @@
!$OMP END DO
!$OMP END PARALLEL
! loops approach to break the O(N^4) scaling in memory
call set_multiple_levels_omp(.false.)
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (n, ipoint, tmp_loc_1, tmp_loc_2, tmp_2d, tmp1, tmp2) &
!$OMP SHARED (mo_num, n_points_final_grid, i, k, &
!$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 tmp_aux_1, tmp_aux_2, &
!$OMP three_e_4_idx_direct_bi_ort, three_e_4_idx_exch13_bi_ort, &
!$OMP three_e_4_idx_exch23_bi_ort, three_e_4_idx_cycle_1_bi_ort)
allocate(tmp_2d(mo_num,mo_num))
allocate(tmp1(n_points_final_grid,4,mo_num))
allocate(tmp2(n_points_final_grid,4,mo_num))
! loops approach to break the O(N^4) scaling in memory
!$OMP DO
do k = 1, mo_num
! ---
do i = 1, mo_num
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (n, ipoint, tmp_loc_1, tmp_loc_2) &
!$OMP SHARED (mo_num, n_points_final_grid, i, k, &
!$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 tmp_aux_2, tmp1)
!$OMP DO
do n = 1, mo_num
do ipoint = 1, n_points_final_grid
! ---
tmp_loc_1 = mos_l_in_r_array_transp(ipoint,k) * mos_r_in_r_array_transp(ipoint,i)
tmp_loc_2 = tmp_aux_2(ipoint,n)
do n = 1, mo_num
do ipoint = 1, n_points_final_grid
tmp1(ipoint,1,n) = int2_grad1_u12_bimo_t(ipoint,1,n,n) * tmp_loc_1 + int2_grad1_u12_bimo_t(ipoint,1,k,i) * tmp_loc_2
tmp1(ipoint,2,n) = int2_grad1_u12_bimo_t(ipoint,2,n,n) * tmp_loc_1 + int2_grad1_u12_bimo_t(ipoint,2,k,i) * tmp_loc_2
tmp1(ipoint,3,n) = int2_grad1_u12_bimo_t(ipoint,3,n,n) * tmp_loc_1 + int2_grad1_u12_bimo_t(ipoint,3,k,i) * tmp_loc_2
tmp1(ipoint,4,n) = int2_grad1_u12_bimo_t(ipoint,1,n,n) * int2_grad1_u12_bimo_t(ipoint,1,k,i) &
+ int2_grad1_u12_bimo_t(ipoint,2,n,n) * int2_grad1_u12_bimo_t(ipoint,2,k,i) &
+ int2_grad1_u12_bimo_t(ipoint,3,n,n) * int2_grad1_u12_bimo_t(ipoint,3,k,i)
tmp_loc_1 = mos_l_in_r_array_transp(ipoint,k) * mos_r_in_r_array_transp(ipoint,i)
tmp_loc_2 = tmp_aux_2(ipoint,n)
tmp1(ipoint,1,n) = int2_grad1_u12_bimo_t(ipoint,1,n,n) * tmp_loc_1 + int2_grad1_u12_bimo_t(ipoint,1,k,i) * tmp_loc_2
tmp1(ipoint,2,n) = int2_grad1_u12_bimo_t(ipoint,2,n,n) * tmp_loc_1 + int2_grad1_u12_bimo_t(ipoint,2,k,i) * tmp_loc_2
tmp1(ipoint,3,n) = int2_grad1_u12_bimo_t(ipoint,3,n,n) * tmp_loc_1 + int2_grad1_u12_bimo_t(ipoint,3,k,i) * tmp_loc_2
tmp1(ipoint,4,n) = int2_grad1_u12_bimo_t(ipoint,1,n,n) * int2_grad1_u12_bimo_t(ipoint,1,k,i) &
+ int2_grad1_u12_bimo_t(ipoint,2,n,n) * int2_grad1_u12_bimo_t(ipoint,2,k,i) &
+ int2_grad1_u12_bimo_t(ipoint,3,n,n) * int2_grad1_u12_bimo_t(ipoint,3,k,i)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call dgemm( 'T', 'N', mo_num, mo_num, 4*n_points_final_grid, 1.d0 &
, tmp_aux_1(1,1,1), 4*n_points_final_grid, tmp1(1,1,1), 4*n_points_final_grid &
, 0.d0, tmp_2d(1,1), mo_num)
call dgemm( 'T', 'N', mo_num, mo_num, 4*n_points_final_grid, 1.d0 &
, tmp_aux_1(1,1,1), 4*n_points_final_grid, tmp1(1,1,1), 4*n_points_final_grid &
, 0.d0, tmp_2d(1,1), mo_num)
!$OMP PARALLEL DO PRIVATE(j,m)
do j = 1, mo_num
do m = 1, mo_num
three_e_4_idx_direct_bi_ort(m,j,k,i) = -tmp_2d(m,j)
do j = 1, mo_num
do m = 1, mo_num
three_e_4_idx_direct_bi_ort(m,j,k,i) = -tmp_2d(m,j)
enddo
enddo
enddo
!$OMP END PARALLEL DO
! ---
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (n, ipoint, tmp_loc_1, tmp_loc_2) &
!$OMP SHARED (mo_num, n_points_final_grid, i, k, &
!$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)
!$OMP DO
do n = 1, mo_num
do ipoint = 1, n_points_final_grid
tmp_loc_1 = mos_l_in_r_array_transp(ipoint,k) * mos_r_in_r_array_transp(ipoint,n)
tmp_loc_2 = mos_l_in_r_array_transp(ipoint,n) * mos_r_in_r_array_transp(ipoint,i)
tmp1(ipoint,1,n) = int2_grad1_u12_bimo_t(ipoint,1,n,i) * tmp_loc_1 + int2_grad1_u12_bimo_t(ipoint,1,k,n) * tmp_loc_2
tmp1(ipoint,2,n) = int2_grad1_u12_bimo_t(ipoint,2,n,i) * tmp_loc_1 + int2_grad1_u12_bimo_t(ipoint,2,k,n) * tmp_loc_2
tmp1(ipoint,3,n) = int2_grad1_u12_bimo_t(ipoint,3,n,i) * tmp_loc_1 + int2_grad1_u12_bimo_t(ipoint,3,k,n) * tmp_loc_2
tmp1(ipoint,4,n) = int2_grad1_u12_bimo_t(ipoint,1,n,i) * int2_grad1_u12_bimo_t(ipoint,1,k,n) &
+ int2_grad1_u12_bimo_t(ipoint,2,n,i) * int2_grad1_u12_bimo_t(ipoint,2,k,n) &
+ int2_grad1_u12_bimo_t(ipoint,3,n,i) * int2_grad1_u12_bimo_t(ipoint,3,k,n)
tmp2(ipoint,1,n) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,n)
tmp2(ipoint,2,n) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,n)
tmp2(ipoint,3,n) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,n)
tmp2(ipoint,4,n) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,n)
do n = 1, mo_num
do ipoint = 1, n_points_final_grid
tmp_loc_1 = mos_l_in_r_array_transp(ipoint,k) * mos_r_in_r_array_transp(ipoint,n)
tmp_loc_2 = mos_l_in_r_array_transp(ipoint,n) * mos_r_in_r_array_transp(ipoint,i)
tmp1(ipoint,1,n) = int2_grad1_u12_bimo_t(ipoint,1,n,i) * tmp_loc_1 + int2_grad1_u12_bimo_t(ipoint,1,k,n) * tmp_loc_2
tmp1(ipoint,2,n) = int2_grad1_u12_bimo_t(ipoint,2,n,i) * tmp_loc_1 + int2_grad1_u12_bimo_t(ipoint,2,k,n) * tmp_loc_2
tmp1(ipoint,3,n) = int2_grad1_u12_bimo_t(ipoint,3,n,i) * tmp_loc_1 + int2_grad1_u12_bimo_t(ipoint,3,k,n) * tmp_loc_2
tmp1(ipoint,4,n) = int2_grad1_u12_bimo_t(ipoint,1,n,i) * int2_grad1_u12_bimo_t(ipoint,1,k,n) &
+ int2_grad1_u12_bimo_t(ipoint,2,n,i) * int2_grad1_u12_bimo_t(ipoint,2,k,n) &
+ int2_grad1_u12_bimo_t(ipoint,3,n,i) * int2_grad1_u12_bimo_t(ipoint,3,k,n)
tmp2(ipoint,1,n) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,n)
tmp2(ipoint,2,n) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,n)
tmp2(ipoint,3,n) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,n)
tmp2(ipoint,4,n) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,n)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call dgemm( 'T', 'N', mo_num, mo_num, 4*n_points_final_grid, 1.d0 &
, tmp1(1,1,1), 4*n_points_final_grid, tmp_aux_1(1,1,1), 4*n_points_final_grid &
, 0.d0, tmp_2d(1,1), mo_num)
! ---
!$OMP PARALLEL DO PRIVATE(j,m)
do j = 1, mo_num
do m = 1, mo_num
three_e_4_idx_exch13_bi_ort(m,j,k,i) = -tmp_2d(m,j)
call dgemm( 'T', 'N', mo_num, mo_num, 4*n_points_final_grid, 1.d0 &
, tmp1(1,1,1), 4*n_points_final_grid, tmp_aux_1(1,1,1), 4*n_points_final_grid &
, 0.d0, tmp_2d(1,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_2d(m,j)
enddo
enddo
enddo
!$OMP END PARALLEL DO
call dgemm( 'T', 'N', mo_num, mo_num, 4*n_points_final_grid, 1.d0 &
, tmp1(1,1,1), 4*n_points_final_grid, tmp2(1,1,1), 4*n_points_final_grid &
, 0.d0, tmp_2d(1,1), mo_num)
! ---
!$OMP PARALLEL DO PRIVATE(j,m)
do j = 1, mo_num
do m = 1, mo_num
three_e_4_idx_cycle_1_bi_ort(m,i,k,j) = -tmp_2d(m,j)
call dgemm( 'T', 'N', mo_num, mo_num, 4*n_points_final_grid, 1.d0 &
, tmp1(1,1,1), 4*n_points_final_grid, tmp2(1,1,1), 4*n_points_final_grid &
, 0.d0, tmp_2d(1,1), mo_num)
do j = 1, mo_num
do m = 1, mo_num
three_e_4_idx_cycle_1_bi_ort(m,i,k,j) = -tmp_2d(m,j)
enddo
enddo
enddo
!$OMP END PARALLEL DO
enddo ! i
! ---
enddo ! i
! ---
do j = 1, mo_num
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (n, ipoint, tmp_loc_1, tmp_loc_2) &
!$OMP SHARED (mo_num, n_points_final_grid, j, k, &
!$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)
!$OMP DO
do n = 1, mo_num
do ipoint = 1, n_points_final_grid
@ -197,31 +194,33 @@
tmp2(ipoint,4,n) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,k) * mos_r_in_r_array_transp(ipoint,n)
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call dgemm( 'T', 'N', mo_num, mo_num, 4*n_points_final_grid, 1.d0 &
, tmp1(1,1,1), 4*n_points_final_grid, tmp2(1,1,1), 4*n_points_final_grid &
, 0.d0, tmp_2d(1,1), mo_num)
!$OMP PARALLEL DO PRIVATE(i,m)
do i = 1, mo_num
do m = 1, mo_num
three_e_4_idx_exch23_bi_ort(m,j,k,i) = -tmp_2d(m,i)
enddo
enddo
!$OMP END PARALLEL DO
enddo ! j
! ---
enddo !k
!$OMP END DO
deallocate(tmp_2d)
deallocate(tmp1)
deallocate(tmp2)
!$OMP END PARALLEL
deallocate(tmp_aux_1)
deallocate(tmp_aux_2)
call wall_time(wall1)
print *, ' wall time for three_e_4_idx_bi_ort', wall1 - wall0
call print_memory_usage()

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

@ -68,11 +68,69 @@ END_PROVIDER
! ---
subroutine give_integrals_3_body_bi_ort_spin( n, sigma_n, l, sigma_l, k, sigma_k &
, m, sigma_m, j, sigma_j, i, sigma_i &
, integral)
BEGIN_DOC
!
! < n l k | L | m j i > with a BI-ORTHONORMAL SPIN-ORBITALS
!
! /!\ L is defined without the 1/6 factor
!
END_DOC
implicit none
integer, intent(in) :: n, l, k, m, j, i
double precision, intent(in) :: sigma_n, sigma_l, sigma_k, sigma_m, sigma_j, sigma_i
double precision, intent(out) :: integral
integer :: ipoint
double precision :: weight, tmp
logical, external :: is_same_spin
integral = 0.d0
if( is_same_spin(sigma_n, sigma_m) .and. &
is_same_spin(sigma_l, sigma_j) .and. &
is_same_spin(sigma_k, sigma_i) ) then
PROVIDE mo_l_coef mo_r_coef
PROVIDE int2_grad1_u12_bimo_t
do ipoint = 1, n_points_final_grid
tmp = mos_l_in_r_array_transp(ipoint,k) * mos_r_in_r_array_transp(ipoint,i) &
* ( int2_grad1_u12_bimo_t(ipoint,1,n,m) * int2_grad1_u12_bimo_t(ipoint,1,l,j) &
+ int2_grad1_u12_bimo_t(ipoint,2,n,m) * int2_grad1_u12_bimo_t(ipoint,2,l,j) &
+ int2_grad1_u12_bimo_t(ipoint,3,n,m) * int2_grad1_u12_bimo_t(ipoint,3,l,j) )
tmp = tmp + mos_l_in_r_array_transp(ipoint,l) * mos_r_in_r_array_transp(ipoint,j) &
* ( int2_grad1_u12_bimo_t(ipoint,1,n,m) * int2_grad1_u12_bimo_t(ipoint,1,k,i) &
+ int2_grad1_u12_bimo_t(ipoint,2,n,m) * int2_grad1_u12_bimo_t(ipoint,2,k,i) &
+ int2_grad1_u12_bimo_t(ipoint,3,n,m) * int2_grad1_u12_bimo_t(ipoint,3,k,i) )
tmp = tmp + mos_l_in_r_array_transp(ipoint,n) * mos_r_in_r_array_transp(ipoint,m) &
* ( int2_grad1_u12_bimo_t(ipoint,1,l,j) * int2_grad1_u12_bimo_t(ipoint,1,k,i) &
+ int2_grad1_u12_bimo_t(ipoint,2,l,j) * int2_grad1_u12_bimo_t(ipoint,2,k,i) &
+ int2_grad1_u12_bimo_t(ipoint,3,l,j) * int2_grad1_u12_bimo_t(ipoint,3,k,i) )
integral = integral + tmp * final_weight_at_r_vector(ipoint)
enddo
endif
return
end subroutine give_integrals_3_body_bi_ort_spin
! ---
subroutine give_integrals_3_body_bi_ort(n, l, k, m, j, i, integral)
BEGIN_DOC
!
! < n l k | -L | m j i > with a BI-ORTHONORMAL MOLECULAR ORBITALS
! < n l k | L | m j i > with a BI-ORTHONORMAL MOLECULAR ORBITALS
!
! /!\ L is defined without the 1/6 factor
!
END_DOC
@ -115,7 +173,9 @@ subroutine give_integrals_3_body_bi_ort_old(n, l, k, m, j, i, integral)
BEGIN_DOC
!
! < n l k | -L | m j i > with a BI-ORTHONORMAL MOLECULAR ORBITALS
! < n l k | L | m j i > with a BI-ORTHONORMAL MOLECULAR ORBITALS
!
! /!\ L is defined without the 1/6 factor
!
END_DOC
@ -128,35 +188,6 @@ subroutine give_integrals_3_body_bi_ort_old(n, l, k, m, j, i, integral)
integral = 0.d0
do ipoint = 1, n_points_final_grid
weight = final_weight_at_r_vector(ipoint)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! integral += weight * mos_l_in_r_array_transp(ipoint,k) * mos_r_in_r_array_transp(ipoint,i) &
! * ( x_W_ki_bi_ortho_erf_rk(ipoint,1,n,m) * x_W_ki_bi_ortho_erf_rk(ipoint,1,l,j) &
! + x_W_ki_bi_ortho_erf_rk(ipoint,2,n,m) * x_W_ki_bi_ortho_erf_rk(ipoint,2,l,j) &
! + x_W_ki_bi_ortho_erf_rk(ipoint,3,n,m) * x_W_ki_bi_ortho_erf_rk(ipoint,3,l,j) )
! integral += weight * mos_l_in_r_array_transp(ipoint,l) * mos_r_in_r_array_transp(ipoint,j) &
! * ( x_W_ki_bi_ortho_erf_rk(ipoint,1,n,m) * x_W_ki_bi_ortho_erf_rk(ipoint,1,k,i) &
! + x_W_ki_bi_ortho_erf_rk(ipoint,2,n,m) * x_W_ki_bi_ortho_erf_rk(ipoint,2,k,i) &
! + x_W_ki_bi_ortho_erf_rk(ipoint,3,n,m) * x_W_ki_bi_ortho_erf_rk(ipoint,3,k,i) )
! integral += weight * mos_l_in_r_array_transp(ipoint,n) * mos_r_in_r_array_transp(ipoint,m) &
! * ( x_W_ki_bi_ortho_erf_rk(ipoint,1,l,j) * x_W_ki_bi_ortho_erf_rk(ipoint,1,k,i) &
! + x_W_ki_bi_ortho_erf_rk(ipoint,2,l,j) * x_W_ki_bi_ortho_erf_rk(ipoint,2,k,i) &
! + x_W_ki_bi_ortho_erf_rk(ipoint,3,l,j) * x_W_ki_bi_ortho_erf_rk(ipoint,3,k,i) )
! integral += weight * mos_l_in_r_array_transp(ipoint,k) * mos_r_in_r_array_transp(ipoint,i) &
! * ( int2_grad1_u12_bimo(1,n,m,ipoint) * int2_grad1_u12_bimo(1,l,j,ipoint) &
! + int2_grad1_u12_bimo(2,n,m,ipoint) * int2_grad1_u12_bimo(2,l,j,ipoint) &
! + int2_grad1_u12_bimo(3,n,m,ipoint) * int2_grad1_u12_bimo(3,l,j,ipoint) )
! integral += weight * mos_l_in_r_array_transp(ipoint,l) * mos_r_in_r_array_transp(ipoint,j) &
! * ( int2_grad1_u12_bimo(1,n,m,ipoint) * int2_grad1_u12_bimo(1,k,i,ipoint) &
! + int2_grad1_u12_bimo(2,n,m,ipoint) * int2_grad1_u12_bimo(2,k,i,ipoint) &
! + int2_grad1_u12_bimo(3,n,m,ipoint) * int2_grad1_u12_bimo(3,k,i,ipoint) )
! integral += weight * mos_l_in_r_array_transp(ipoint,n) * mos_r_in_r_array_transp(ipoint,m) &
! * ( int2_grad1_u12_bimo(1,l,j,ipoint) * int2_grad1_u12_bimo(1,k,i,ipoint) &
! + int2_grad1_u12_bimo(2,l,j,ipoint) * int2_grad1_u12_bimo(2,k,i,ipoint) &
! + int2_grad1_u12_bimo(3,l,j,ipoint) * int2_grad1_u12_bimo(3,k,i,ipoint) )
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
integral += weight * mos_l_in_r_array_transp(ipoint,k) * mos_r_in_r_array_transp(ipoint,i) &
* ( int2_grad1_u12_bimo_transp(n,m,1,ipoint) * int2_grad1_u12_bimo_transp(l,j,1,ipoint) &
+ int2_grad1_u12_bimo_transp(n,m,2,ipoint) * int2_grad1_u12_bimo_transp(l,j,2,ipoint) &
@ -180,7 +211,9 @@ subroutine give_integrals_3_body_bi_ort_ao(n, l, k, m, j, i, integral)
BEGIN_DOC
!
! < n l k | -L | m j i > with a BI-ORTHONORMAL ATOMIC ORBITALS
! < n l k | L | m j i > with a BI-ORTHONORMAL ATOMIC ORBITALS
!
! /!\ L is defined without the 1/6 factor
!
END_DOC

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

@ -256,6 +256,13 @@ 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
! x 2 because of the Slater-Condon rules convention
mo_bi_ortho_tc_two_e = mo_bi_ortho_tc_two_e + 2.d0 * noL_2e
FREE noL_2e
endif
END_PROVIDER
! ---
@ -266,9 +273,11 @@ END_PROVIDER
&BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_two_e_jj_anti, (mo_num,mo_num)]
BEGIN_DOC
! mo_bi_ortho_tc_two_e_jj(i,j) = J_ij = <ji|W-K|ji>
!
! mo_bi_ortho_tc_two_e_jj (i,j) = J_ij = <ji|W-K|ji>
! mo_bi_ortho_tc_two_e_jj_exchange(i,j) = K_ij = <ij|W-K|ji>
! mo_bi_ortho_tc_two_e_jj_anti(i,j) = J_ij - K_ij
! mo_bi_ortho_tc_two_e_jj_anti (i,j) = J_ij - K_ij
!
END_DOC
implicit none
@ -279,9 +288,9 @@ END_PROVIDER
do i = 1, mo_num
do j = 1, mo_num
mo_bi_ortho_tc_two_e_jj(i,j) = mo_bi_ortho_tc_two_e(j,i,j,i)
mo_bi_ortho_tc_two_e_jj (i,j) = mo_bi_ortho_tc_two_e(j,i,j,i)
mo_bi_ortho_tc_two_e_jj_exchange(i,j) = mo_bi_ortho_tc_two_e(i,j,j,i)
mo_bi_ortho_tc_two_e_jj_anti(i,j) = mo_bi_ortho_tc_two_e_jj(i,j) - mo_bi_ortho_tc_two_e_jj_exchange(i,j)
mo_bi_ortho_tc_two_e_jj_anti (i,j) = mo_bi_ortho_tc_two_e_jj(i,j) - mo_bi_ortho_tc_two_e_jj_exchange(i,j)
enddo
enddo

2
src/bi_ortho_mos/bi_density.irp.f
View File

@ -15,7 +15,6 @@ BEGIN_PROVIDER [double precision, TCSCF_bi_ort_dm_ao_alpha, (ao_num, ao_num) ]
call dgemm( 'N', 'T', ao_num, ao_num, elec_alpha_num, 1.d0 &
, mo_l_coef, size(mo_l_coef, 1), mo_r_coef, size(mo_r_coef, 1) &
!, mo_r_coef, size(mo_r_coef, 1), mo_l_coef, size(mo_l_coef, 1) &
, 0.d0, TCSCF_bi_ort_dm_ao_alpha, size(TCSCF_bi_ort_dm_ao_alpha, 1) )
END_PROVIDER
@ -36,7 +35,6 @@ BEGIN_PROVIDER [ double precision, TCSCF_bi_ort_dm_ao_beta, (ao_num, ao_num) ]
call dgemm( 'N', 'T', ao_num, ao_num, elec_beta_num, 1.d0 &
, mo_l_coef, size(mo_l_coef, 1), mo_r_coef, size(mo_r_coef, 1) &
!, mo_r_coef, size(mo_r_coef, 1), mo_l_coef, size(mo_l_coef, 1) &
, 0.d0, TCSCF_bi_ort_dm_ao_beta, size(TCSCF_bi_ort_dm_ao_beta, 1) )
END_PROVIDER

1
src/bi_ortho_mos/mos_rl.irp.f
View File

@ -32,7 +32,6 @@ subroutine ao_to_mo_bi_ortho(A_ao, LDA_ao, A_mo, LDA_mo)
, mo_l_coef, size(mo_l_coef, 1), T, size(T, 1) &
, 0.d0, A_mo, LDA_mo )
! call restore_symmetry(mo_num,mo_num,A_mo,size(A_mo,1),1.d-12)
deallocate(T)
end subroutine ao_to_mo_bi_ortho

1
src/non_h_ints_mu/NEED
View File

@ -1,2 +1,3 @@
qmckl
ao_tc_eff_map
bi_ortho_mos

77
src/non_h_ints_mu/debug_fit.irp.f
View File

@ -13,17 +13,27 @@ program debug_fit
PROVIDE mu_erf j1b_pen
if(j1b_type .ge. 100) then
my_extra_grid_becke = .True.
PROVIDE tc_grid2_a tc_grid2_r
my_n_pt_r_extra_grid = tc_grid2_r
my_n_pt_a_extra_grid = tc_grid2_a
touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid
endif
!call test_j1b_nucl()
!call test_grad_j1b_nucl()
!call test_lapl_j1b_nucl()
!call test_list_b2()
call test_list_b3()
!call test_list_b3()
!call test_fit_u()
!call test_fit_u2()
!call test_fit_ugradu()
call test_grad1_u12_withsq_num()
end
! ---
@ -643,4 +653,69 @@ end subroutine test_fit_u2
! ---
subroutine test_grad1_u12_withsq_num()
implicit none
integer :: ipoint, jpoint, m
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
double precision, allocatable :: tmp_grad1_u12_squared(:,:), tmp_grad1_u12(:,:,:)
print*, ' test_grad1_u12_withsq_num ...'
PROVIDE grad1_u12_num grad1_u12_squared_num
allocate(tmp_grad1_u12_squared(n_points_extra_final_grid,n_points_final_grid))
allocate(tmp_grad1_u12(n_points_extra_final_grid,n_points_final_grid,3))
eps_ij = 1d-7
acc_tot = 0.d0
normalz = 0.d0
do ipoint = 1, n_points_final_grid
call get_grad1_u12_withsq_r1_seq(final_grid_points(1,ipoint), n_points_extra_final_grid, tmp_grad1_u12(1,ipoint,1) &
, tmp_grad1_u12(1,ipoint,2) &
, tmp_grad1_u12(1,ipoint,3) &
, tmp_grad1_u12_squared(1,ipoint))
do jpoint = 1, n_points_extra_final_grid
i_exc = grad1_u12_squared_num(jpoint,ipoint)
i_num = tmp_grad1_u12_squared(jpoint,ipoint)
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in grad1_u12_squared_num on', ipoint, jpoint
print *, ' analyt = ', i_exc
print *, ' numeri = ', i_num
print *, ' diff = ', acc_ij
stop
endif
acc_tot += acc_ij
normalz += dabs(i_num)
do m = 1, 3
i_exc = grad1_u12_num(jpoint,ipoint,m)
i_num = tmp_grad1_u12(jpoint,ipoint,m)
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in grad1_u12_num on', ipoint, jpoint, m
print *, ' analyt = ', i_exc
print *, ' numeri = ', i_num
print *, ' diff = ', acc_ij
stop
endif
acc_tot += acc_ij
normalz += dabs(i_num)
enddo
enddo
enddo
!print*, ' acc_tot = ', acc_tot
!print*, ' normalz = ', normalz
print*, ' accuracy (%) = ', 100.d0 * acc_tot / normalz
return
end subroutine test_grad1_u12_withsq_num
! ---

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

@ -425,7 +425,6 @@ BEGIN_PROVIDER [double precision, tc_grad_square_ao, (ao_num, ao_num, ao_num, ao
! an additional term is added here directly instead of
! being added in int2_grad1_u12_square_ao for performance
! note that the factor
PROVIDE int2_u2_j1b2
@ -465,25 +464,8 @@ BEGIN_PROVIDER [double precision, tc_grad_square_ao, (ao_num, ao_num, ao_num, ao
! ---
deallocate(b_mat)
call sum_A_At(tc_grad_square_ao(1,1,1,1), ao_num*ao_num)
!!$OMP PARALLEL &
!!$OMP DEFAULT (NONE) &
!!$OMP PRIVATE (i, j, k, l) &
!!$OMP SHARED (ac_mat, tc_grad_square_ao, ao_num)
!!$OMP DO SCHEDULE (static)
! do j = 1, ao_num
! do l = 1, ao_num
! do i = 1, ao_num
! do k = 1, ao_num
! tc_grad_square_ao(k,i,l,j) = ac_mat(k,i,l,j) + ac_mat(l,j,k,i)
! enddo
! enddo
! enddo
! enddo
!!$OMP END DO
!!$OMP END PARALLEL
endif
if(write_tc_integ.and.mpi_master) then

66
src/non_h_ints_mu/grad_squared_manu.irp.f
View File

@ -67,72 +67,6 @@ BEGIN_PROVIDER [double precision, tc_grad_square_ao_test, (ao_num, ao_num, ao_nu
deallocate(tmp, b_mat)
call sum_A_At(tc_grad_square_ao_test(1,1,1,1), ao_num*ao_num)
!do i = 1, ao_num
! do j = 1, ao_num
! do k = i, ao_num
! do l = max(j,k), ao_num
! tc_grad_square_ao_test(i,j,k,l) = 0.5d0 * (tc_grad_square_ao_test(i,j,k,l) + tc_grad_square_ao_test(k,l,i,j))
! tc_grad_square_ao_test(k,l,i,j) = tc_grad_square_ao_test(i,j,k,l)
! end do
! !if (j.eq.k) then
! ! do l = j+1, ao_num
! ! tc_grad_square_ao_test(i,j,k,l) = 0.5d0 * (tc_grad_square_ao_test(i,j,k,l) + tc_grad_square_ao_test(k,l,i,j))
! ! tc_grad_square_ao_test(k,l,i,j) = tc_grad_square_ao_test(i,j,k,l)
! ! end do
! !else
! ! do l = j, ao_num
! ! tc_grad_square_ao_test(i,j,k,l) = 0.5d0 * (tc_grad_square_ao_test(i,j,k,l) + tc_grad_square_ao_test(k,l,i,j))
! ! tc_grad_square_ao_test(k,l,i,j) = tc_grad_square_ao_test(i,j,k,l)
! ! enddo
! !endif
! enddo
! enddo
!enddo
!tc_grad_square_ao_test = 2.d0 * tc_grad_square_ao_test
! !$OMP PARALLEL &
! !$OMP DEFAULT (NONE) &
! !$OMP PRIVATE (i, j, k, l) &
! !$OMP SHARED (tc_grad_square_ao_test, ao_num)
! !$OMP DO SCHEDULE (static)
! integer :: ii
! ii = 0
! do j = 1, ao_num
! do l = 1, ao_num
! do i = 1, ao_num
! do k = 1, ao_num
! if((i.lt.j) .and. (k.lt.l)) cycle
! ii = ii + 1
! tc_grad_square_ao_test(k,i,l,j) = tc_grad_square_ao_test(k,i,l,j) + tc_grad_square_ao_test(l,j,k,i)
! enddo
! enddo
! enddo
! enddo
! print *, ' ii =', ii
! !$OMP END DO
! !$OMP END PARALLEL
! !$OMP PARALLEL &
! !$OMP DEFAULT (NONE) &
! !$OMP PRIVATE (i, j, k, l) &
! !$OMP SHARED (tc_grad_square_ao_test, ao_num)
! !$OMP DO SCHEDULE (static)
! do j = 1, ao_num
! do l = 1, ao_num
! do i = 1, j-1
! do k = 1, l-1
! ii = ii + 1
! tc_grad_square_ao_test(k,i,l,j) = tc_grad_square_ao_test(l,j,k,i)
! enddo
! enddo
! enddo
! enddo
! print *, ' ii =', ii
! print *, ao_num * ao_num * ao_num * ao_num
! !$OMP END DO
! !$OMP END PARALLEL
endif

799
src/non_h_ints_mu/jast_deriv.irp.f
View File

@ -24,15 +24,20 @@
double precision :: v1b_r1, v1b_r2, u2b_r12
double precision :: grad1_v1b(3), grad1_u2b(3)
double precision :: dx, dy, dz
double precision :: time0, time1
double precision, external :: j12_mu, j1b_nucl
PROVIDE j1b_type
PROVIDE final_grid_points_extra
print*, ' providing grad1_u12_num & grad1_u12_squared_num ...'
call wall_time(time0)
grad1_u12_num = 0.d0
grad1_u12_squared_num = 0.d0
if(j1b_type .eq. 100) then
if( (j1b_type .eq. 100) .or. &
(j1b_type .ge. 200) .and. (j1b_type .lt. 300) ) then
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
@ -111,41 +116,93 @@
!$OMP END DO
!$OMP END PARALLEL
elseif((j1b_type .ge. 200) .and. (j1b_type .lt. 300)) then
elseif (j1b_type .eq. 1000) then
double precision :: f
f = 1.d0 / dble(elec_num - 1)
double precision, allocatable :: rij(:,:,:)
allocate( rij(3, 2, n_points_extra_final_grid) )
use qmckl
integer(qmckl_exit_code) :: rc
integer*8 :: npoints
npoints = n_points_extra_final_grid
double precision, allocatable :: gl(:,:,:)
allocate( gl(2,4,n_points_extra_final_grid) )
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, jpoint, r1, r2, grad1_u2b, dx, dy, dz) &
!$OMP SHARED (n_points_final_grid, n_points_extra_final_grid, final_grid_points, &
!$OMP final_grid_points_extra, grad1_u12_num, grad1_u12_squared_num)
!$OMP DO SCHEDULE (static)
do ipoint = 1, n_points_final_grid ! r1
r1(1) = final_grid_points(1,ipoint)
r1(2) = final_grid_points(2,ipoint)
r1(3) = final_grid_points(3,ipoint)
do jpoint = 1, n_points_extra_final_grid ! r2
rij(1:3, 1, jpoint) = final_grid_points (1:3, ipoint)
rij(1:3, 2, jpoint) = final_grid_points_extra(1:3, jpoint)
enddo
rc = qmckl_set_electron_coord(qmckl_ctx_jastrow, 'N', npoints, rij, npoints*6_8)
if (rc /= QMCKL_SUCCESS) then
print *, irp_here, 'qmckl error in set_electron_coord'
stop -1
endif
! ---
! e-e term
rc = qmckl_get_jastrow_champ_factor_ee_gl(qmckl_ctx_jastrow, gl, 8_8*npoints)
if (rc /= QMCKL_SUCCESS) then
print *, irp_here, 'qmckl error in fact_ee_gl'
stop -1
endif
do jpoint = 1, n_points_extra_final_grid ! r2
grad1_u12_num(jpoint,ipoint,1) = gl(1,1,jpoint)
grad1_u12_num(jpoint,ipoint,2) = gl(1,2,jpoint)
grad1_u12_num(jpoint,ipoint,3) = gl(1,3,jpoint)
enddo
r2(1) = final_grid_points_extra(1,jpoint)
r2(2) = final_grid_points_extra(2,jpoint)
r2(3) = final_grid_points_extra(3,jpoint)
! ---
! e-e-n term
call grad1_j12_mu(r1, r2, grad1_u2b)
! rc = qmckl_get_jastrow_champ_factor_een_gl(qmckl_ctx_jastrow, gl, 8_8*npoints)
! if (rc /= QMCKL_SUCCESS) then
! print *, irp_here, 'qmckl error in fact_een_gl'
! stop -1
! endif
!
! do jpoint = 1, n_points_extra_final_grid ! r2
! grad1_u12_num(jpoint,ipoint,1) = grad1_u12_num(jpoint,ipoint,1) + gl(1,1,jpoint)
! grad1_u12_num(jpoint,ipoint,2) = grad1_u12_num(jpoint,ipoint,2) + gl(1,2,jpoint)
! grad1_u12_num(jpoint,ipoint,3) = grad1_u12_num(jpoint,ipoint,3) + gl(1,3,jpoint)
! enddo
dx = grad1_u2b(1)
dy = grad1_u2b(2)
dz = grad1_u2b(3)
! ---
! e-n term
grad1_u12_num(jpoint,ipoint,1) = dx
grad1_u12_num(jpoint,ipoint,2) = dy
grad1_u12_num(jpoint,ipoint,3) = dz
rc = qmckl_get_jastrow_champ_factor_en_gl(qmckl_ctx_jastrow, gl, 8_8*npoints)
if (rc /= QMCKL_SUCCESS) then
print *, irp_here, 'qmckl error in fact_en_gl'
stop -1
endif
do jpoint = 1, n_points_extra_final_grid ! r2
grad1_u12_num(jpoint,ipoint,1) = grad1_u12_num(jpoint,ipoint,1) + f * gl(1,1,jpoint)
grad1_u12_num(jpoint,ipoint,2) = grad1_u12_num(jpoint,ipoint,2) + f * gl(1,2,jpoint)
grad1_u12_num(jpoint,ipoint,3) = grad1_u12_num(jpoint,ipoint,3) + f * gl(1,3,jpoint)
enddo
do jpoint = 1, n_points_extra_final_grid ! r2
dx = grad1_u12_num(jpoint,ipoint,1)
dy = grad1_u12_num(jpoint,ipoint,2)
dz = grad1_u12_num(jpoint,ipoint,3)
grad1_u12_squared_num(jpoint,ipoint) = dx*dx + dy*dy + dz*dz
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
deallocate(gl, rij)
else
@ -154,700 +211,10 @@
endif
call wall_time(time1)
print*, ' Wall time for grad1_u12_num & grad1_u12_squared_num (min) =', (time1-time0)/60.d0
END_PROVIDER
! ---
double precision function j12_mu(r1, r2)
include 'constants.include.F'
implicit none
double precision, intent(in) :: r1(3), r2(3)
double precision :: mu_tmp, r12
if((j1b_type .ge. 0) .and. (j1b_type .lt. 200)) then
r12 = dsqrt( (r1(1) - r2(1)) * (r1(1) - r2(1)) &
+ (r1(2) - r2(2)) * (r1(2) - r2(2)) &
+ (r1(3) - r2(3)) * (r1(3) - r2(3)) )
mu_tmp = mu_erf * r12
j12_mu = 0.5d0 * r12 * (1.d0 - derf(mu_tmp)) - inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / mu_erf
else
print *, ' j1b_type = ', j1b_type, 'not implemented for j12_mu'
stop
endif
return
end function j12_mu
! ---
subroutine grad1_j12_mu(r1, r2, grad)
BEGIN_DOC
! gradient of j(mu(r1,r2),r12) form of jastrow.
!
! if mu(r1,r2) = cst ---> j1b_type < 200 and
!
! d/dx1 j(mu,r12) = 0.5 * (1 - erf(mu *r12))/r12 * (x1 - x2)
!
! if mu(r1,r2) /= cst ---> 200 < j1b_type < 300 and
!
! d/dx1 j(mu(r1,r2),r12) = exp(-(mu(r1,r2)*r12)**2) /(2 *sqrt(pi) * mu(r1,r2)**2 ) d/dx1 mu(r1,r2)
!
! + 0.5 * (1 - erf(mu(r1,r2) *r12))/r12 * (x1 - x2)
END_DOC
include 'constants.include.F'
implicit none
double precision, intent(in) :: r1(3), r2(3)
double precision, intent(out) :: grad(3)
double precision :: dx, dy, dz, r12, tmp
grad = 0.d0
if((j1b_type .ge. 0) .and. (j1b_type .lt. 200)) then
dx = r1(1) - r2(1)
dy = r1(2) - r2(2)
dz = r1(3) - r2(3)
r12 = dsqrt(dx * dx + dy * dy + dz * dz)
if(r12 .lt. 1d-10) return
tmp = 0.5d0 * (1.d0 - derf(mu_erf * r12)) / r12
grad(1) = tmp * dx
grad(2) = tmp * dy
grad(3) = tmp * dz
elseif((j1b_type .ge. 200) .and. (j1b_type .lt. 300)) then
double precision :: mu_val, mu_tmp, mu_der(3)
dx = r1(1) - r2(1)
dy = r1(2) - r2(2)
dz = r1(3) - r2(3)
r12 = dsqrt(dx * dx + dy * dy + dz * dz)
call mu_r_val_and_grad(r1, r2, mu_val, mu_der)
mu_tmp = mu_val * r12
tmp = inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / (mu_val * mu_val)
grad(1) = tmp * mu_der(1)
grad(2) = tmp * mu_der(2)
grad(3) = tmp * mu_der(3)
if(r12 .lt. 1d-10) return
tmp = 0.5d0 * (1.d0 - derf(mu_tmp)) / r12
grad(1) = grad(1) + tmp * dx
grad(2) = grad(2) + tmp * dy
grad(3) = grad(3) + tmp * dz
else
print *, ' j1b_type = ', j1b_type, 'not implemented yet'
stop
endif
return
end subroutine grad1_j12_mu
! ---
double precision function j1b_nucl(r)
implicit none
double precision, intent(in) :: r(3)
integer :: i
double precision :: a, d, e, x, y, z
if((j1b_type .eq. 2) .or. (j1b_type .eq. 102)) then
j1b_nucl = 1.d0
do i = 1, nucl_num
a = j1b_pen(i)
d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
+ (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+ (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
j1b_nucl = j1b_nucl - dexp(-a*dsqrt(d))
enddo
elseif((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then
j1b_nucl = 1.d0
do i = 1, nucl_num
a = j1b_pen(i)
d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
+ (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+ (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
e = 1.d0 - dexp(-a*d)
j1b_nucl = j1b_nucl * e
enddo
elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then
j1b_nucl = 1.d0
do i = 1, nucl_num
a = j1b_pen(i)
d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
+ (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+ (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
j1b_nucl = j1b_nucl - j1b_pen_coef(i) * dexp(-a*d)
enddo
elseif((j1b_type .eq. 5) .or. (j1b_type .eq. 105)) then
j1b_nucl = 1.d0
do i = 1, nucl_num
a = j1b_pen(i)
x = r(1) - nucl_coord(i,1)
y = r(2) - nucl_coord(i,2)
z = r(3) - nucl_coord(i,3)
d = x*x + y*y + z*z
j1b_nucl = j1b_nucl - dexp(-a*d*d)
enddo
else
print *, ' j1b_type = ', j1b_type, 'not implemented for j1b_nucl'
stop
endif
return
end function j1b_nucl
! ---
double precision function j1b_nucl_square(r)
implicit none
double precision, intent(in) :: r(3)
integer :: i
double precision :: a, d, e, x, y, z
if((j1b_type .eq. 2) .or. (j1b_type .eq. 102)) then
j1b_nucl_square = 1.d0
do i = 1, nucl_num
a = j1b_pen(i)
d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
+ (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+ (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
j1b_nucl_square = j1b_nucl_square - dexp(-a*dsqrt(d))
enddo
j1b_nucl_square = j1b_nucl_square * j1b_nucl_square
elseif((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then
j1b_nucl_square = 1.d0
do i = 1, nucl_num
a = j1b_pen(i)
d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
+ (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+ (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
e = 1.d0 - dexp(-a*d)
j1b_nucl_square = j1b_nucl_square * e
enddo
j1b_nucl_square = j1b_nucl_square * j1b_nucl_square
elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then
j1b_nucl_square = 1.d0
do i = 1, nucl_num
a = j1b_pen(i)
d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
+ (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+ (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
j1b_nucl_square = j1b_nucl_square - j1b_pen_coef(i) * dexp(-a*d)
enddo
j1b_nucl_square = j1b_nucl_square * j1b_nucl_square
elseif((j1b_type .eq. 5) .or. (j1b_type .eq. 105)) then
j1b_nucl_square = 1.d0
do i = 1, nucl_num
a = j1b_pen(i)
x = r(1) - nucl_coord(i,1)
y = r(2) - nucl_coord(i,2)
z = r(3) - nucl_coord(i,3)
d = x*x + y*y + z*z
j1b_nucl_square = j1b_nucl_square - dexp(-a*d*d)
enddo
j1b_nucl_square = j1b_nucl_square * j1b_nucl_square
else
print *, ' j1b_type = ', j1b_type, 'not implemented for j1b_nucl_square'
stop
endif
return
end function j1b_nucl_square
! ---
subroutine grad1_j1b_nucl(r, grad)
implicit none
double precision, intent(in) :: r(3)
double precision, intent(out) :: grad(3)
integer :: ipoint, i, j, phase
double precision :: x, y, z, dx, dy, dz
double precision :: a, d, e
double precision :: fact_x, fact_y, fact_z
double precision :: ax_der, ay_der, az_der, a_expo
if((j1b_type .eq. 2) .or. (j1b_type .eq. 102)) then
fact_x = 0.d0
fact_y = 0.d0
fact_z = 0.d0
do i = 1, nucl_num
a = j1b_pen(i)
x = r(1) - nucl_coord(i,1)
y = r(2) - nucl_coord(i,2)
z = r(3) - nucl_coord(i,3)
d = dsqrt(x*x + y*y + z*z)
e = a * dexp(-a*d) / d
fact_x += e * x
fact_y += e * y
fact_z += e * z
enddo
grad(1) = fact_x
grad(2) = fact_y
grad(3) = fact_z
elseif((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then
x = r(1)
y = r(2)
z = r(3)
fact_x = 0.d0
fact_y = 0.d0
fact_z = 0.d0
do i = 1, List_all_comb_b2_size
phase = 0
a_expo = 0.d0
ax_der = 0.d0
ay_der = 0.d0
az_der = 0.d0
do j = 1, nucl_num
a = dble(List_all_comb_b2(j,i)) * j1b_pen(j)
dx = x - nucl_coord(j,1)
dy = y - nucl_coord(j,2)
dz = z - nucl_coord(j,3)
phase += List_all_comb_b2(j,i)
a_expo += a * (dx*dx + dy*dy + dz*dz)
ax_der += a * dx
ay_der += a * dy
az_der += a * dz
enddo
e = -2.d0 * (-1.d0)**dble(phase) * dexp(-a_expo)
fact_x += e * ax_der
fact_y += e * ay_der
fact_z += e * az_der
enddo
grad(1) = fact_x
grad(2) = fact_y
grad(3) = fact_z
elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then
fact_x = 0.d0
fact_y = 0.d0
fact_z = 0.d0
do i = 1, nucl_num
a = j1b_pen(i)
x = r(1) - nucl_coord(i,1)
y = r(2) - nucl_coord(i,2)
z = r(3) - nucl_coord(i,3)
d = x*x + y*y + z*z
e = a * j1b_pen_coef(i) * dexp(-a*d)
fact_x += e * x
fact_y += e * y
fact_z += e * z
enddo
grad(1) = 2.d0 * fact_x
grad(2) = 2.d0 * fact_y
grad(3) = 2.d0 * fact_z
elseif((j1b_type .eq. 5) .or. (j1b_type .eq. 105)) then
fact_x = 0.d0
fact_y = 0.d0
fact_z = 0.d0
do i = 1, nucl_num
a = j1b_pen(i)
x = r(1) - nucl_coord(i,1)
y = r(2) - nucl_coord(i,2)
z = r(3) - nucl_coord(i,3)
d = x*x + y*y + z*z
e = a * d * dexp(-a*d*d)
fact_x += e * x
fact_y += e * y
fact_z += e * z
enddo
grad(1) = 4.d0 * fact_x
grad(2) = 4.d0 * fact_y
grad(3) = 4.d0 * fact_z
else
print *, ' j1b_type = ', j1b_type, 'not implemented for grad1_j1b_nucl'
stop
endif
return
end subroutine grad1_j1b_nucl
! ---
subroutine mu_r_val_and_grad(r1, r2, mu_val, mu_der)
implicit none
double precision, intent(in) :: r1(3), r2(3)
double precision, intent(out) :: mu_val, mu_der(3)
double precision :: r(3)
double precision :: dm_a(1), dm_b(1), grad_dm_a(3,1), grad_dm_b(3,1)
double precision :: dm_tot, tmp1, tmp2, tmp3
double precision :: rho1, grad_rho1(3),rho2,rho_tot,inv_rho_tot
double precision :: f_rho1, f_rho2, d_drho_f_rho1
double precision :: d_dx1_f_rho1(3),d_dx_rho_f_rho(3),nume
if(j1b_type .eq. 200) then
!
! r = 0.5 (r1 + r2)
!
! mu[rho(r)] = alpha sqrt(rho) + mu0 exp(-rho)
!
! d mu[rho(r)] / dx1 = 0.5 d mu[rho(r)] / dx
! d mu[rho(r)] / dx = [0.5 alpha / sqrt(rho) - mu0 exp(-rho)] (d rho(r) / dx)
!
PROVIDE mu_r_ct mu_erf
r(1) = 0.5d0 * (r1(1) + r2(1))
r(2) = 0.5d0 * (r1(2) + r2(2))
r(3) = 0.5d0 * (r1(3) + r2(3))
call density_and_grad_alpha_beta(r, dm_a, dm_b, grad_dm_a, grad_dm_b)
dm_tot = dm_a(1) + dm_b(1)
tmp1 = dsqrt(dm_tot)
tmp2 = mu_erf * dexp(-dm_tot)
mu_val = mu_r_ct * tmp1 + tmp2
mu_der = 0.d0
if(dm_tot .lt. 1d-7) return
tmp3 = 0.25d0 * mu_r_ct / tmp1 - 0.5d0 * tmp2
mu_der(1) = tmp3 * (grad_dm_a(1,1) + grad_dm_b(1,1))
mu_der(2) = tmp3 * (grad_dm_a(2,1) + grad_dm_b(2,1))
mu_der(3) = tmp3 * (grad_dm_a(3,1) + grad_dm_b(3,1))
elseif(j1b_type .eq. 201) then
!
! r = 0.5 (r1 + r2)
!
! mu[rho(r)] = alpha rho + mu0 exp(-rho)
!
! d mu[rho(r)] / dx1 = 0.5 d mu[rho(r)] / dx
! d mu[rho(r)] / dx = [0.5 alpha / sqrt(rho) - mu0 exp(-rho)] (d rho(r) / dx)
!
PROVIDE mu_r_ct mu_erf
r(1) = 0.5d0 * (r1(1) + r2(1))
r(2) = 0.5d0 * (r1(2) + r2(2))
r(3) = 0.5d0 * (r1(3) + r2(3))
call density_and_grad_alpha_beta(r, dm_a, dm_b, grad_dm_a, grad_dm_b)
dm_tot = dm_a(1) + dm_b(1)
tmp2 = mu_erf * dexp(-dm_tot)
mu_val = mu_r_ct * dm_tot + tmp2
tmp3 = 0.5d0 * (mu_r_ct - tmp2)
mu_der(1) = tmp3 * (grad_dm_a(1,1) + grad_dm_b(1,1))
mu_der(2) = tmp3 * (grad_dm_a(2,1) + grad_dm_b(2,1))
mu_der(3) = tmp3 * (grad_dm_a(3,1) + grad_dm_b(3,1))
elseif(j1b_type .eq. 202) then
! mu(r1,r2) = {rho(r1) f[rho(r1)] + rho(r2) f[rho(r2)]} / RHO
!
! RHO = rho(r1) + rho(r2)
!
! f[rho] = alpha rho^beta + mu0 exp(-rho)
!
! d/dx1 mu(r1,r2) = 1/RHO^2 * {RHO * d/dx1 (rho(r1) f[rho(r1)])
! - d/dx1 rho(r1) * [rho(r1) f[rho(r1)] + rho(r2) f[rho(r2)]] }
!
! d/dx1 f[rho(r1)] = [0.5 alpha / sqrt(rho(r1)) - mu0 exp(-rho(r1))] (d rho(r1) / dx1)
!
! d/dx1 (rho(r1) f[rho(r1)] = rho(r1) * d/dx1 f[rho(r1)] + f[rho(r1)] * d/dx1 rho(r1)
!!!!!!!!! rho1,rho2,rho1+rho2
call get_all_rho_grad_rho(r1,r2,rho1,rho2,grad_rho1)
rho_tot = rho1 + rho2
if(rho_tot.lt.1.d-10)rho_tot = 1.d-10
inv_rho_tot = 1.d0/rho_tot
! f(rho) = mu_r_ct * rho**beta_rho_power + mu_erf * exp(-rho)
call get_all_f_rho(rho1,rho2,mu_r_ct,mu_erf,beta_rho_power,f_rho1,d_drho_f_rho1,f_rho2)
d_dx1_f_rho1(1:3) = d_drho_f_rho1 * grad_rho1(1:3)
d_dx_rho_f_rho(1:3) = rho1 * d_dx1_f_rho1(1:3) + f_rho1 * grad_rho1(1:3)
nume = rho1 * f_rho1 + rho2 * f_rho2
mu_val = nume * inv_rho_tot
mu_der(1:3) = inv_rho_tot*inv_rho_tot * (rho_tot * d_dx_rho_f_rho(1:3) - grad_rho1(1:3) * nume)
elseif(j1b_type .eq. 203) then
! mu(r1,r2) = {rho(r1) f[rho(r1)] + rho(r2) f[rho(r2)]} / RHO
!
! RHO = rho(r1) + rho(r2)
!
! f[rho] = alpha rho^beta + mu0
!
! d/dx1 mu(r1,r2) = 1/RHO^2 * {RHO * d/dx1 (rho(r1) f[rho(r1)])
! - d/dx1 rho(r1) * [rho(r1) f[rho(r1)] + rho(r2) f[rho(r2)]] }
!
! d/dx1 f[rho(r1)] = [0.5 alpha / sqrt(rho(r1)) ] (d rho(r1) / dx1)
!
! d/dx1 (rho(r1) f[rho(r1)] = rho(r1) * d/dx1 f[rho(r1)] + f[rho(r1)] * d/dx1 rho(r1)
!!!!!!!!! rho1,rho2,rho1+rho2
call get_all_rho_grad_rho(r1,r2,rho1,rho2,grad_rho1)
rho_tot = rho1 + rho2
if(rho_tot.lt.1.d-10)rho_tot = 1.d-10
inv_rho_tot = 1.d0/rho_tot
! f(rho) = mu_r_ct * rho**beta_rho_power + mu_erf
call get_all_f_rho_simple(rho1,rho2,mu_r_ct,mu_erf,beta_rho_power,f_rho1,d_drho_f_rho1,f_rho2)
d_dx1_f_rho1(1:3) = d_drho_f_rho1 * grad_rho1(1:3)
d_dx_rho_f_rho(1:3) = rho1 * d_dx1_f_rho1(1:3) + f_rho1 * grad_rho1(1:3)
nume = rho1 * f_rho1 + rho2 * f_rho2
mu_val = nume * inv_rho_tot
mu_der(1:3) = inv_rho_tot*inv_rho_tot * (rho_tot * d_dx_rho_f_rho(1:3) - grad_rho1(1:3) * nume)
elseif(j1b_type .eq. 204) then
! mu(r1,r2) = 1/2 * (f[rho(r1)] + f[rho(r2)]}
!
! f[rho] = alpha rho^beta + mu0
!
! d/dx1 mu(r1,r2) = 1/2 * d/dx1 (rho(r1) f[rho(r1)])
!
! d/dx1 f[rho(r1)] = [0.5 alpha / sqrt(rho(r1)) ] (d rho(r1) / dx1)
!
! d/dx1 (rho(r1) f[rho(r1)] = rho(r1) * d/dx1 f[rho(r1)] + f[rho(r1)] * d/dx1 rho(r1)
!!!!!!!!! rho1,rho2,rho1+rho2
call get_all_rho_grad_rho(r1,r2,rho1,rho2,grad_rho1)
rho_tot = rho1 + rho2
if(rho_tot.lt.1.d-10)rho_tot = 1.d-10
inv_rho_tot = 1.d0/rho_tot
! f(rho) = mu_r_ct * rho**beta_rho_power + mu_erf
call get_all_f_rho_simple(rho1,rho2,mu_r_ct,mu_erf,beta_rho_power,f_rho1,d_drho_f_rho1,f_rho2)
d_dx1_f_rho1(1:3) = d_drho_f_rho1 * grad_rho1(1:3)
d_dx_rho_f_rho(1:3) = rho1 * d_dx1_f_rho1(1:3) + f_rho1 * grad_rho1(1:3)
mu_val = 0.5d0 * ( f_rho1 + f_rho2)
mu_der(1:3) = d_dx_rho_f_rho(1:3)
else
print *, ' j1b_type = ', j1b_type, 'not implemented yet'
stop
endif
return
end subroutine mu_r_val_and_grad
! ---
subroutine grad1_j1b_nucl_square_num(r1, grad)
implicit none
double precision, intent(in) :: r1(3)
double precision, intent(out) :: grad(3)
double precision :: r(3), eps, tmp_eps, vp, vm
double precision, external :: j1b_nucl_square
eps = 1d-5
tmp_eps = 0.5d0 / eps
r(1:3) = r1(1:3)
r(1) = r(1) + eps
vp = j1b_nucl_square(r)
r(1) = r(1) - 2.d0 * eps
vm = j1b_nucl_square(r)
r(1) = r(1) + eps
grad(1) = tmp_eps * (vp - vm)
r(2) = r(2) + eps
vp = j1b_nucl_square(r)
r(2) = r(2) - 2.d0 * eps
vm = j1b_nucl_square(r)
r(2) = r(2) + eps
grad(2) = tmp_eps * (vp - vm)
r(3) = r(3) + eps
vp = j1b_nucl_square(r)
r(3) = r(3) - 2.d0 * eps
vm = j1b_nucl_square(r)
r(3) = r(3) + eps
grad(3) = tmp_eps * (vp - vm)
return
end subroutine grad1_j1b_nucl_square_num
! ---
subroutine grad1_j12_mu_square_num(r1, r2, grad)
include 'constants.include.F'
implicit none
double precision, intent(in) :: r1(3), r2(3)
double precision, intent(out) :: grad(3)
double precision :: r(3)
double precision :: eps, tmp_eps, vp, vm
double precision, external :: j12_mu_square
eps = 1d-5
tmp_eps = 0.5d0 / eps
r(1:3) = r1(1:3)
r(1) = r(1) + eps
vp = j12_mu_square(r, r2)
r(1) = r(1) - 2.d0 * eps
vm = j12_mu_square(r, r2)
r(1) = r(1) + eps
grad(1) = tmp_eps * (vp - vm)
r(2) = r(2) + eps
vp = j12_mu_square(r, r2)
r(2) = r(2) - 2.d0 * eps
vm = j12_mu_square(r, r2)
r(2) = r(2) + eps
grad(2) = tmp_eps * (vp - vm)
r(3) = r(3) + eps
vp = j12_mu_square(r, r2)
r(3) = r(3) - 2.d0 * eps
vm = j12_mu_square(r, r2)
r(3) = r(3) + eps
grad(3) = tmp_eps * (vp - vm)
return
end subroutine grad1_j12_mu_square_num
! ---
double precision function j12_mu_square(r1, r2)
implicit none
double precision, intent(in) :: r1(3), r2(3)
double precision, external :: j12_mu
j12_mu_square = j12_mu(r1, r2) * j12_mu(r1, r2)
return
end function j12_mu_square
! ---
subroutine f_mu_and_deriv_mu(rho,alpha,mu0,beta,f_mu,d_drho_f_mu)
implicit none
BEGIN_DOC
! function giving mu as a function of rho
!
! f_mu = alpha * rho**beta + mu0 * exp(-rho)
!
! and its derivative with respect to rho d_drho_f_mu
END_DOC
double precision, intent(in) :: rho,alpha,mu0,beta
double precision, intent(out) :: f_mu,d_drho_f_mu
f_mu = alpha * (rho)**beta + mu0 * dexp(-rho)
d_drho_f_mu = alpha * beta * rho**(beta-1.d0) - mu0 * dexp(-rho)
end
subroutine get_all_rho_grad_rho(r1,r2,rho1,rho2,grad_rho1)
implicit none
BEGIN_DOC
! returns the density in r1,r2 and grad_rho at r1
END_DOC
double precision, intent(in) :: r1(3),r2(3)
double precision, intent(out):: grad_rho1(3),rho1,rho2
double precision :: dm_a(1), dm_b(1), grad_dm_a(3,1), grad_dm_b(3,1)
call density_and_grad_alpha_beta(r1, dm_a, dm_b, grad_dm_a, grad_dm_b)
rho1 = dm_a(1) + dm_b(1)
grad_rho1(1:3) = grad_dm_a(1:3,1) + grad_dm_b(1:3,1)
call density_and_grad_alpha_beta(r2, dm_a, dm_b, grad_dm_a, grad_dm_b)
rho2 = dm_a(1) + dm_b(1)
end
subroutine get_all_f_rho(rho1,rho2,alpha,mu0,beta,f_rho1,d_drho_f_rho1,f_rho2)
implicit none
BEGIN_DOC
! returns the values f(mu(r1)), f(mu(r2)) and d/drho(1) f(mu(r1))
END_DOC
double precision, intent(in) :: rho1,rho2,alpha,mu0,beta
double precision, intent(out):: f_rho1,d_drho_f_rho1,f_rho2
double precision :: tmp
call f_mu_and_deriv_mu(rho1,alpha,mu0,beta,f_rho1,d_drho_f_rho1)
call f_mu_and_deriv_mu(rho2,alpha,mu0,beta,f_rho2,tmp)
end
subroutine get_all_f_rho_simple(rho1,rho2,alpha,mu0,beta,f_rho1,d_drho_f_rho1,f_rho2)
implicit none
BEGIN_DOC
! returns the values f(mu(r1)), f(mu(r2)) and d/drho(1) f(mu(r1))
END_DOC
double precision, intent(in) :: rho1,rho2,alpha,mu0,beta
double precision, intent(out):: f_rho1,d_drho_f_rho1,f_rho2
double precision :: tmp
call f_mu_and_deriv_mu_simple(rho1,alpha,mu0,beta,f_rho1,d_drho_f_rho1)
call f_mu_and_deriv_mu_simple(rho2,alpha,mu0,beta,f_rho2,tmp)
end
subroutine f_mu_and_deriv_mu_simple(rho,alpha,mu0,beta,f_mu,d_drho_f_mu)
implicit none
BEGIN_DOC
! function giving mu as a function of rho
!
! f_mu = alpha * rho**beta + mu0
!
! and its derivative with respect to rho d_drho_f_mu
END_DOC
double precision, intent(in) :: rho,alpha,mu0,beta
double precision, intent(out) :: f_mu,d_drho_f_mu
f_mu = alpha * (rho)**beta + mu0
d_drho_f_mu = alpha * beta * rho**(beta-1.d0)
end

700
src/non_h_ints_mu/jast_deriv_utils.irp.f Normal file
View File

@ -0,0 +1,700 @@
! ---
double precision function j12_mu(r1, r2)
include 'constants.include.F'
implicit none
double precision, intent(in) :: r1(3), r2(3)
double precision :: mu_tmp, r12
if((j1b_type .ge. 0) .and. (j1b_type .lt. 200)) then
r12 = dsqrt( (r1(1) - r2(1)) * (r1(1) - r2(1)) &
+ (r1(2) - r2(2)) * (r1(2) - r2(2)) &
+ (r1(3) - r2(3)) * (r1(3) - r2(3)) )
mu_tmp = mu_erf * r12
j12_mu = 0.5d0 * r12 * (1.d0 - derf(mu_tmp)) - inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / mu_erf
else
print *, ' j1b_type = ', j1b_type, 'not implemented for j12_mu'
stop
endif
return
end function j12_mu
! ---
subroutine grad1_j12_mu(r1, r2, grad)
BEGIN_DOC
!
! gradient of j(mu(r1,r2),r12) form of jastrow.
!
! if mu(r1,r2) = cst ---> j1b_type < 200 and
!
! d/dx1 j(mu,r12) = 0.5 * (1 - erf(mu *r12))/r12 * (x1 - x2)
!
! if mu(r1,r2) /= cst ---> 200 < j1b_type < 300 and
!
! d/dx1 j(mu(r1,r2),r12) = exp(-(mu(r1,r2)*r12)**2) /(2 *sqrt(pi) * mu(r1,r2)**2 ) d/dx1 mu(r1,r2)
! + 0.5 * (1 - erf(mu(r1,r2) *r12))/r12 * (x1 - x2)
!
END_DOC
include 'constants.include.F'
implicit none
double precision, intent(in) :: r1(3), r2(3)
double precision, intent(out) :: grad(3)
double precision :: dx, dy, dz, r12, tmp
grad = 0.d0
if((j1b_type .ge. 0) .and. (j1b_type .lt. 200)) then
dx = r1(1) - r2(1)
dy = r1(2) - r2(2)
dz = r1(3) - r2(3)
r12 = dsqrt(dx * dx + dy * dy + dz * dz)
if(r12 .lt. 1d-10) return
tmp = 0.5d0 * (1.d0 - derf(mu_erf * r12)) / r12
grad(1) = tmp * dx
grad(2) = tmp * dy
grad(3) = tmp * dz
elseif((j1b_type .ge. 200) .and. (j1b_type .lt. 300)) then
double precision :: mu_val, mu_tmp, mu_der(3)
dx = r1(1) - r2(1)
dy = r1(2) - r2(2)
dz = r1(3) - r2(3)
r12 = dsqrt(dx * dx + dy * dy + dz * dz)
call mu_r_val_and_grad(r1, r2, mu_val, mu_der)
mu_tmp = mu_val * r12
tmp = inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / (mu_val * mu_val)
grad(1) = tmp * mu_der(1)
grad(2) = tmp * mu_der(2)
grad(3) = tmp * mu_der(3)
if(r12 .lt. 1d-10) return
tmp = 0.5d0 * (1.d0 - derf(mu_tmp)) / r12
grad(1) = grad(1) + tmp * dx
grad(2) = grad(2) + tmp * dy
grad(3) = grad(3) + tmp * dz
else
print *, ' j1b_type = ', j1b_type, 'not implemented yet'
stop
endif
return
end subroutine grad1_j12_mu
! ---
double precision function j1b_nucl(r)
implicit none
double precision, intent(in) :: r(3)
integer :: i
double precision :: a, d, e, x, y, z
if((j1b_type .eq. 2) .or. (j1b_type .eq. 102)) then
j1b_nucl = 1.d0
do i = 1, nucl_num
a = j1b_pen(i)
d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
+ (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+ (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
j1b_nucl = j1b_nucl - dexp(-a*dsqrt(d))
enddo
elseif((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then
j1b_nucl = 1.d0
do i = 1, nucl_num
a = j1b_pen(i)
d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
+ (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+ (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
e = 1.d0 - dexp(-a*d)
j1b_nucl = j1b_nucl * e
enddo
elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then
j1b_nucl = 1.d0
do i = 1, nucl_num
a = j1b_pen(i)
d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
+ (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+ (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
j1b_nucl = j1b_nucl - j1b_pen_coef(i) * dexp(-a*d)
enddo
elseif((j1b_type .eq. 5) .or. (j1b_type .eq. 105)) then
j1b_nucl = 1.d0
do i = 1, nucl_num
a = j1b_pen(i)
x = r(1) - nucl_coord(i,1)
y = r(2) - nucl_coord(i,2)
z = r(3) - nucl_coord(i,3)
d = x*x + y*y + z*z
j1b_nucl = j1b_nucl - dexp(-a*d*d)
enddo
else
print *, ' j1b_type = ', j1b_type, 'not implemented for j1b_nucl'
stop
endif
return
end function j1b_nucl
! ---
double precision function j1b_nucl_square(r)
implicit none
double precision, intent(in) :: r(3)
integer :: i
double precision :: a, d, e, x, y, z
if((j1b_type .eq. 2) .or. (j1b_type .eq. 102)) then
j1b_nucl_square = 1.d0
do i = 1, nucl_num
a = j1b_pen(i)
d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
+ (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+ (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
j1b_nucl_square = j1b_nucl_square - dexp(-a*dsqrt(d))
enddo
j1b_nucl_square = j1b_nucl_square * j1b_nucl_square
elseif((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then
j1b_nucl_square = 1.d0
do i = 1, nucl_num
a = j1b_pen(i)
d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
+ (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+ (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
e = 1.d0 - dexp(-a*d)
j1b_nucl_square = j1b_nucl_square * e
enddo
j1b_nucl_square = j1b_nucl_square * j1b_nucl_square
elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then
j1b_nucl_square = 1.d0
do i = 1, nucl_num
a = j1b_pen(i)
d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
+ (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+ (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
j1b_nucl_square = j1b_nucl_square - j1b_pen_coef(i) * dexp(-a*d)
enddo
j1b_nucl_square = j1b_nucl_square * j1b_nucl_square
elseif((j1b_type .eq. 5) .or. (j1b_type .eq. 105)) then
j1b_nucl_square = 1.d0
do i = 1, nucl_num
a = j1b_pen(i)
x = r(1) - nucl_coord(i,1)
y = r(2) - nucl_coord(i,2)
z = r(3) - nucl_coord(i,3)
d = x*x + y*y + z*z
j1b_nucl_square = j1b_nucl_square - dexp(-a*d*d)
enddo
j1b_nucl_square = j1b_nucl_square * j1b_nucl_square
else
print *, ' j1b_type = ', j1b_type, 'not implemented for j1b_nucl_square'
stop
endif
return
end function j1b_nucl_square
! ---
subroutine grad1_j1b_nucl(r, grad)
implicit none
double precision, intent(in) :: r(3)
double precision, intent(out) :: grad(3)
integer :: ipoint, i, j, phase
double precision :: x, y, z, dx, dy, dz
double precision :: a, d, e
double precision :: fact_x, fact_y, fact_z
double precision :: ax_der, ay_der, az_der, a_expo
if((j1b_type .eq. 2) .or. (j1b_type .eq. 102)) then
fact_x = 0.d0
fact_y = 0.d0
fact_z = 0.d0
do i = 1, nucl_num
a = j1b_pen(i)
x = r(1) - nucl_coord(i,1)
y = r(2) - nucl_coord(i,2)
z = r(3) - nucl_coord(i,3)
d = dsqrt(x*x + y*y + z*z)
e = a * dexp(-a*d) / d
fact_x += e * x
fact_y += e * y
fact_z += e * z
enddo
grad(1) = fact_x
grad(2) = fact_y
grad(3) = fact_z
elseif((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then
x = r(1)
y = r(2)
z = r(3)
fact_x = 0.d0
fact_y = 0.d0
fact_z = 0.d0
do i = 1, List_all_comb_b2_size
phase = 0
a_expo = 0.d0
ax_der = 0.d0
ay_der = 0.d0
az_der = 0.d0
do j = 1, nucl_num
a = dble(List_all_comb_b2(j,i)) * j1b_pen(j)
dx = x - nucl_coord(j,1)
dy = y - nucl_coord(j,2)
dz = z - nucl_coord(j,3)
phase += List_all_comb_b2(j,i)
a_expo += a * (dx*dx + dy*dy + dz*dz)
ax_der += a * dx
ay_der += a * dy
az_der += a * dz
enddo
e = -2.d0 * (-1.d0)**dble(phase) * dexp(-a_expo)
fact_x += e * ax_der
fact_y += e * ay_der
fact_z += e * az_der
enddo
grad(1) = fact_x
grad(2) = fact_y
grad(3) = fact_z
elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then
fact_x = 0.d0
fact_y = 0.d0
fact_z = 0.d0
do i = 1, nucl_num
a = j1b_pen(i)
x = r(1) - nucl_coord(i,1)
y = r(2) - nucl_coord(i,2)
z = r(3) - nucl_coord(i,3)
d = x*x + y*y + z*z
e = a * j1b_pen_coef(i) * dexp(-a*d)
fact_x += e * x
fact_y += e * y
fact_z += e * z
enddo
grad(1) = 2.d0 * fact_x
grad(2) = 2.d0 * fact_y
grad(3) = 2.d0 * fact_z
elseif((j1b_type .eq. 5) .or. (j1b_type .eq. 105)) then
fact_x = 0.d0
fact_y = 0.d0
fact_z = 0.d0
do i = 1, nucl_num
a = j1b_pen(i)
x = r(1) - nucl_coord(i,1)
y = r(2) - nucl_coord(i,2)
z = r(3) - nucl_coord(i,3)
d = x*x + y*y + z*z
e = a * d * dexp(-a*d*d)
fact_x += e * x
fact_y += e * y
fact_z += e * z
enddo
grad(1) = 4.d0 * fact_x
grad(2) = 4.d0 * fact_y
grad(3) = 4.d0 * fact_z
else
print *, ' j1b_type = ', j1b_type, 'not implemented for grad1_j1b_nucl'
stop
endif
return
end subroutine grad1_j1b_nucl
! ---
subroutine mu_r_val_and_grad(r1, r2, mu_val, mu_der)
implicit none
double precision, intent(in) :: r1(3), r2(3)
double precision, intent(out) :: mu_val, mu_der(3)
double precision :: r(3)
double precision :: dm_a(1), dm_b(1), grad_dm_a(3,1), grad_dm_b(3,1)
double precision :: dm_tot, tmp1, tmp2, tmp3
double precision :: rho1, grad_rho1(3),rho2,rho_tot,inv_rho_tot
double precision :: f_rho1, f_rho2, d_drho_f_rho1
double precision :: d_dx1_f_rho1(3),d_dx_rho_f_rho(3),nume
if(j1b_type .eq. 200) then
!
! r = 0.5 (r1 + r2)
!
! mu[rho(r)] = alpha sqrt(rho) + mu0 exp(-rho)
!
! d mu[rho(r)] / dx1 = 0.5 d mu[rho(r)] / dx
! d mu[rho(r)] / dx = [0.5 alpha / sqrt(rho) - mu0 exp(-rho)] (d rho(r) / dx)
!
PROVIDE mu_r_ct mu_erf
r(1) = 0.5d0 * (r1(1) + r2(1))
r(2) = 0.5d0 * (r1(2) + r2(2))
r(3) = 0.5d0 * (r1(3) + r2(3))
call density_and_grad_alpha_beta(r, dm_a, dm_b, grad_dm_a, grad_dm_b)
dm_tot = dm_a(1) + dm_b(1)
tmp1 = dsqrt(dm_tot)
tmp2 = mu_erf * dexp(-dm_tot)
mu_val = mu_r_ct * tmp1 + tmp2
mu_der = 0.d0
if(dm_tot .lt. 1d-7) return
tmp3 = 0.25d0 * mu_r_ct / tmp1 - 0.5d0 * tmp2
mu_der(1) = tmp3 * (grad_dm_a(1,1) + grad_dm_b(1,1))
mu_der(2) = tmp3 * (grad_dm_a(2,1) + grad_dm_b(2,1))
mu_der(3) = tmp3 * (grad_dm_a(3,1) + grad_dm_b(3,1))
elseif(j1b_type .eq. 201) then
!
! r = 0.5 (r1 + r2)
!
! mu[rho(r)] = alpha rho + mu0 exp(-rho)
!
! d mu[rho(r)] / dx1 = 0.5 d mu[rho(r)] / dx
! d mu[rho(r)] / dx = [0.5 alpha / sqrt(rho) - mu0 exp(-rho)] (d rho(r) / dx)
!
PROVIDE mu_r_ct mu_erf
r(1) = 0.5d0 * (r1(1) + r2(1))
r(2) = 0.5d0 * (r1(2) + r2(2))
r(3) = 0.5d0 * (r1(3) + r2(3))
call density_and_grad_alpha_beta(r, dm_a, dm_b, grad_dm_a, grad_dm_b)
dm_tot = dm_a(1) + dm_b(1)
tmp2 = mu_erf * dexp(-dm_tot)
mu_val = mu_r_ct * dm_tot + tmp2
tmp3 = 0.5d0 * (mu_r_ct - tmp2)
mu_der(1) = tmp3 * (grad_dm_a(1,1) + grad_dm_b(1,1))
mu_der(2) = tmp3 * (grad_dm_a(2,1) + grad_dm_b(2,1))
mu_der(3) = tmp3 * (grad_dm_a(3,1) + grad_dm_b(3,1))
elseif(j1b_type .eq. 202) then
! mu(r1,r2) = {rho(r1) f[rho(r1)] + rho(r2) f[rho(r2)]} / RHO
!
! RHO = rho(r1) + rho(r2)
!
! f[rho] = alpha rho^beta + mu0 exp(-rho)
!
! d/dx1 mu(r1,r2) = 1/RHO^2 * {RHO * d/dx1 (rho(r1) f[rho(r1)])
! - d/dx1 rho(r1) * [rho(r1) f[rho(r1)] + rho(r2) f[rho(r2)]] }
!
! d/dx1 f[rho(r1)] = [0.5 alpha / sqrt(rho(r1)) - mu0 exp(-rho(r1))] (d rho(r1) / dx1)
!
! d/dx1 (rho(r1) f[rho(r1)] = rho(r1) * d/dx1 f[rho(r1)] + f[rho(r1)] * d/dx1 rho(r1)
!!!!!!!!! rho1,rho2,rho1+rho2
call get_all_rho_grad_rho(r1,r2,rho1,rho2,grad_rho1)
rho_tot = rho1 + rho2
if(rho_tot.lt.1.d-10)rho_tot = 1.d-10
inv_rho_tot = 1.d0/rho_tot
! f(rho) = mu_r_ct * rho**beta_rho_power + mu_erf * exp(-rho)
call get_all_f_rho(rho1,rho2,mu_r_ct,mu_erf,beta_rho_power,f_rho1,d_drho_f_rho1,f_rho2)
d_dx1_f_rho1(1:3) = d_drho_f_rho1 * grad_rho1(1:3)
d_dx_rho_f_rho(1:3) = rho1 * d_dx1_f_rho1(1:3) + f_rho1 * grad_rho1(1:3)
nume = rho1 * f_rho1 + rho2 * f_rho2
mu_val = nume * inv_rho_tot
mu_der(1:3) = inv_rho_tot*inv_rho_tot * (rho_tot * d_dx_rho_f_rho(1:3) - grad_rho1(1:3) * nume)
elseif(j1b_type .eq. 203) then
! mu(r1,r2) = {rho(r1) f[rho(r1)] + rho(r2) f[rho(r2)]} / RHO
!
! RHO = rho(r1) + rho(r2)
!
! f[rho] = alpha rho^beta + mu0
!
! d/dx1 mu(r1,r2) = 1/RHO^2 * {RHO * d/dx1 (rho(r1) f[rho(r1)])
! - d/dx1 rho(r1) * [rho(r1) f[rho(r1)] + rho(r2) f[rho(r2)]] }
!
! d/dx1 f[rho(r1)] = [0.5 alpha / sqrt(rho(r1)) ] (d rho(r1) / dx1)
!
! d/dx1 (rho(r1) f[rho(r1)] = rho(r1) * d/dx1 f[rho(r1)] + f[rho(r1)] * d/dx1 rho(r1)
!!!!!!!!! rho1,rho2,rho1+rho2
call get_all_rho_grad_rho(r1,r2,rho1,rho2,grad_rho1)
rho_tot = rho1 + rho2
if(rho_tot.lt.1.d-10)rho_tot = 1.d-10
inv_rho_tot = 1.d0/rho_tot
! f(rho) = mu_r_ct * rho**beta_rho_power + mu_erf
call get_all_f_rho_simple(rho1,rho2,mu_r_ct,mu_erf,beta_rho_power,f_rho1,d_drho_f_rho1,f_rho2)
d_dx1_f_rho1(1:3) = d_drho_f_rho1 * grad_rho1(1:3)
d_dx_rho_f_rho(1:3) = rho1 * d_dx1_f_rho1(1:3) + f_rho1 * grad_rho1(1:3)
nume = rho1 * f_rho1 + rho2 * f_rho2
mu_val = nume * inv_rho_tot
mu_der(1:3) = inv_rho_tot*inv_rho_tot * (rho_tot * d_dx_rho_f_rho(1:3) - grad_rho1(1:3) * nume)
elseif(j1b_type .eq. 204) then
! mu(r1,r2) = 1/2 * (f[rho(r1)] + f[rho(r2)]}
!
! f[rho] = alpha rho^beta + mu0
!
! d/dx1 mu(r1,r2) = 1/2 * d/dx1 (rho(r1) f[rho(r1)])
!
! d/dx1 f[rho(r1)] = [0.5 alpha / sqrt(rho(r1)) ] (d rho(r1) / dx1)
!
! d/dx1 (rho(r1) f[rho(r1)] = rho(r1) * d/dx1 f[rho(r1)] + f[rho(r1)] * d/dx1 rho(r1)
!!!!!!!!! rho1,rho2,rho1+rho2
call get_all_rho_grad_rho(r1,r2,rho1,rho2,grad_rho1)
rho_tot = rho1 + rho2
if(rho_tot.lt.1.d-10)rho_tot = 1.d-10
inv_rho_tot = 1.d0/rho_tot
! f(rho) = mu_r_ct * rho**beta_rho_power + mu_erf
call get_all_f_rho_simple(rho1,rho2,mu_r_ct,mu_erf,beta_rho_power,f_rho1,d_drho_f_rho1,f_rho2)
d_dx1_f_rho1(1:3) = d_drho_f_rho1 * grad_rho1(1:3)
d_dx_rho_f_rho(1:3) = rho1 * d_dx1_f_rho1(1:3) + f_rho1 * grad_rho1(1:3)
mu_val = 0.5d0 * ( f_rho1 + f_rho2)
mu_der(1:3) = d_dx_rho_f_rho(1:3)
else
print *, ' j1b_type = ', j1b_type, 'not implemented yet'
stop
endif
return
end subroutine mu_r_val_and_grad
! ---
subroutine grad1_j1b_nucl_square_num(r1, grad)
implicit none
double precision, intent(in) :: r1(3)
double precision, intent(out) :: grad(3)
double precision :: r(3), eps, tmp_eps, vp, vm
double precision, external :: j1b_nucl_square
eps = 1d-5
tmp_eps = 0.5d0 / eps
r(1:3) = r1(1:3)
r(1) = r(1) + eps
vp = j1b_nucl_square(r)
r(1) = r(1) - 2.d0 * eps
vm = j1b_nucl_square(r)
r(1) = r(1) + eps
grad(1) = tmp_eps * (vp - vm)
r(2) = r(2) + eps
vp = j1b_nucl_square(r)
r(2) = r(2) - 2.d0 * eps
vm = j1b_nucl_square(r)
r(2) = r(2) + eps
grad(2) = tmp_eps * (vp - vm)
r(3) = r(3) + eps
vp = j1b_nucl_square(r)
r(3) = r(3) - 2.d0 * eps
vm = j1b_nucl_square(r)
r(3) = r(3) + eps
grad(3) = tmp_eps * (vp - vm)
return
end subroutine grad1_j1b_nucl_square_num
! ---
subroutine grad1_j12_mu_square_num(r1, r2, grad)
include 'constants.include.F'
implicit none
double precision, intent(in) :: r1(3), r2(3)
double precision, intent(out) :: grad(3)
double precision :: r(3)
double precision :: eps, tmp_eps, vp, vm
double precision, external :: j12_mu_square
eps = 1d-5
tmp_eps = 0.5d0 / eps
r(1:3) = r1(1:3)
r(1) = r(1) + eps
vp = j12_mu_square(r, r2)
r(1) = r(1) - 2.d0 * eps
vm = j12_mu_square(r, r2)
r(1) = r(1) + eps
grad(1) = tmp_eps * (vp - vm)
r(2) = r(2) + eps
vp = j12_mu_square(r, r2)
r(2) = r(2) - 2.d0 * eps
vm = j12_mu_square(r, r2)
r(2) = r(2) + eps
grad(2) = tmp_eps * (vp - vm)
r(3) = r(3) + eps
vp = j12_mu_square(r, r2)
r(3) = r(3) - 2.d0 * eps
vm = j12_mu_square(r, r2)
r(3) = r(3) + eps
grad(3) = tmp_eps * (vp - vm)
return
end subroutine grad1_j12_mu_square_num
! ---
double precision function j12_mu_square(r1, r2)
implicit none
double precision, intent(in) :: r1(3), r2(3)
double precision, external :: j12_mu
j12_mu_square = j12_mu(r1, r2) * j12_mu(r1, r2)
return
end function j12_mu_square
! ---
subroutine f_mu_and_deriv_mu(rho,alpha,mu0,beta,f_mu,d_drho_f_mu)
implicit none
BEGIN_DOC
! function giving mu as a function of rho
!
! f_mu = alpha * rho**beta + mu0 * exp(-rho)
!
! and its derivative with respect to rho d_drho_f_mu
END_DOC
double precision, intent(in) :: rho,alpha,mu0,beta
double precision, intent(out) :: f_mu,d_drho_f_mu
f_mu = alpha * (rho)**beta + mu0 * dexp(-rho)
d_drho_f_mu = alpha * beta * rho**(beta-1.d0) - mu0 * dexp(-rho)
end
subroutine get_all_rho_grad_rho(r1,r2,rho1,rho2,grad_rho1)
implicit none
BEGIN_DOC
! returns the density in r1,r2 and grad_rho at r1
END_DOC
double precision, intent(in) :: r1(3),r2(3)
double precision, intent(out):: grad_rho1(3),rho1,rho2
double precision :: dm_a(1), dm_b(1), grad_dm_a(3,1), grad_dm_b(3,1)
call density_and_grad_alpha_beta(r1, dm_a, dm_b, grad_dm_a, grad_dm_b)
rho1 = dm_a(1) + dm_b(1)
grad_rho1(1:3) = grad_dm_a(1:3,1) + grad_dm_b(1:3,1)
call density_and_grad_alpha_beta(r2, dm_a, dm_b, grad_dm_a, grad_dm_b)
rho2 = dm_a(1) + dm_b(1)
end
subroutine get_all_f_rho(rho1,rho2,alpha,mu0,beta,f_rho1,d_drho_f_rho1,f_rho2)
implicit none
BEGIN_DOC
! returns the values f(mu(r1)), f(mu(r2)) and d/drho(1) f(mu(r1))
END_DOC
double precision, intent(in) :: rho1,rho2,alpha,mu0,beta
double precision, intent(out):: f_rho1,d_drho_f_rho1,f_rho2
double precision :: tmp
call f_mu_and_deriv_mu(rho1,alpha,mu0,beta,f_rho1,d_drho_f_rho1)
call f_mu_and_deriv_mu(rho2,alpha,mu0,beta,f_rho2,tmp)
end
subroutine get_all_f_rho_simple(rho1,rho2,alpha,mu0,beta,f_rho1,d_drho_f_rho1,f_rho2)
implicit none
BEGIN_DOC
! returns the values f(mu(r1)), f(mu(r2)) and d/drho(1) f(mu(r1))
END_DOC
double precision, intent(in) :: rho1,rho2,alpha,mu0,beta
double precision, intent(out):: f_rho1,d_drho_f_rho1,f_rho2
double precision :: tmp
call f_mu_and_deriv_mu_simple(rho1,alpha,mu0,beta,f_rho1,d_drho_f_rho1)
call f_mu_and_deriv_mu_simple(rho2,alpha,mu0,beta,f_rho2,tmp)
end
subroutine f_mu_and_deriv_mu_simple(rho,alpha,mu0,beta,f_mu,d_drho_f_mu)
implicit none
BEGIN_DOC
! function giving mu as a function of rho
!
! f_mu = alpha * rho**beta + mu0
!
! and its derivative with respect to rho d_drho_f_mu
END_DOC
double precision, intent(in) :: rho,alpha,mu0,beta
double precision, intent(out) :: f_mu,d_drho_f_mu
f_mu = alpha * (rho)**beta + mu0
d_drho_f_mu = alpha * beta * rho**(beta-1.d0)
end
! ---

332
src/non_h_ints_mu/jast_deriv_utils_vect.irp.f Normal file
View File

@ -0,0 +1,332 @@
! ---
subroutine get_grad1_u12_withsq_r1_seq(r1, n_grid2, resx, resy, resz, res)
BEGIN_DOC
!
! grad_1 u(r1,r2)
!
! this will be integrated numerically over r2:
! we use grid for r1 and extra_grid for r2
!
! for 99 < j1b_type < 199
!
! u(r1,r2) = j12_mu(r12) x v(r1) x v(r2)
! grad1 u(r1, r2) = [(grad1 j12_mu) v(r1) + j12_mu grad1 v(r1)] v(r2)
!
END_DOC
implicit none
integer, intent(in) :: n_grid2
double precision, intent(in) :: r1(3)
double precision, intent(out) :: resx(n_grid2), resy(n_grid2), resz(n_grid2), res(n_grid2)
integer :: jpoint
double precision :: v1b_r1
double precision :: grad1_v1b(3)
double precision, allocatable :: v1b_r2(:)
double precision, allocatable :: u2b_r12(:)
double precision, allocatable :: gradx1_u2b(:), grady1_u2b(:), gradz1_u2b(:)
double precision, external :: j1b_nucl
PROVIDE j1b_type
PROVIDE final_grid_points_extra
if( (j1b_type .eq. 100) .or. &
(j1b_type .ge. 200) .and. (j1b_type .lt. 300) ) then
call grad1_j12_mu_r1_seq(r1, n_grid2, resx, resy, resz)
do jpoint = 1, n_points_extra_final_grid
res(jpoint) = resx(jpoint) * resx(jpoint) &
+ resy(jpoint) * resy(jpoint) &
+ resz(jpoint) * resz(jpoint)
enddo
elseif((j1b_type .gt. 100) .and. (j1b_type .lt. 200)) then
allocate(v1b_r2(n_grid2))
allocate(u2b_r12(n_grid2))
allocate(gradx1_u2b(n_grid2))
allocate(grady1_u2b(n_grid2))
allocate(gradz1_u2b(n_grid2))
v1b_r1 = j1b_nucl(r1)
call grad1_j1b_nucl(r1, grad1_v1b)
call j1b_nucl_r1_seq(n_grid2, v1b_r2)
call j12_mu_r1_seq(r1, n_grid2, u2b_r12)
call grad1_j12_mu_r1_seq(r1, n_grid2, gradx1_u2b, grady1_u2b, gradz1_u2b)
do jpoint = 1, n_points_extra_final_grid
resx(jpoint) = (gradx1_u2b(jpoint) * v1b_r1 + u2b_r12(jpoint) * grad1_v1b(1)) * v1b_r2(jpoint)
resy(jpoint) = (grady1_u2b(jpoint) * v1b_r1 + u2b_r12(jpoint) * grad1_v1b(2)) * v1b_r2(jpoint)
resz(jpoint) = (gradz1_u2b(jpoint) * v1b_r1 + u2b_r12(jpoint) * grad1_v1b(3)) * v1b_r2(jpoint)
res (jpoint) = resx(jpoint) * resx(jpoint) &
+ resy(jpoint) * resy(jpoint) &
+ resz(jpoint) * resz(jpoint)
enddo
deallocate(v1b_r2, u2b_r12, gradx1_u2b, grady1_u2b, gradz1_u2b)
else
print *, ' j1b_type = ', j1b_type, 'not implemented yet'
stop
endif
return
end subroutine get_grad1_u12_withsq_r1_seq
! ---
subroutine grad1_j12_mu_r1_seq(r1, n_grid2, gradx, grady, gradz)
BEGIN_DOC
!
! gradient of j(mu(r1,r2),r12) form of jastrow.
!
! if mu(r1,r2) = cst ---> j1b_type < 200 and
!
! d/dx1 j(mu,r12) = 0.5 * (1 - erf(mu *r12))/r12 * (x1 - x2)
!
! if mu(r1,r2) /= cst ---> 200 < j1b_type < 300 and
!
! d/dx1 j(mu(r1,r2),r12) = exp(-(mu(r1,r2)*r12)**2) /(2 *sqrt(pi) * mu(r1,r2)**2 ) d/dx1 mu(r1,r2)
! + 0.5 * (1 - erf(mu(r1,r2) *r12))/r12 * (x1 - x2)
!
END_DOC
include 'constants.include.F'
implicit none
integer , intent(in) :: n_grid2
double precision, intent(in) :: r1(3)
double precision, intent(out) :: gradx(n_grid2)
double precision, intent(out) :: grady(n_grid2)
double precision, intent(out) :: gradz(n_grid2)
integer :: jpoint
double precision :: r2(3)
double precision :: dx, dy, dz, r12, tmp
if((j1b_type .ge. 0) .and. (j1b_type .lt. 200)) then
do jpoint = 1, n_points_extra_final_grid ! r2
r2(1) = final_grid_points_extra(1,jpoint)
r2(2) = final_grid_points_extra(2,jpoint)
r2(3) = final_grid_points_extra(3,jpoint)
dx = r1(1) - r2(1)
dy = r1(2) - r2(2)
dz = r1(3) - r2(3)
r12 = dsqrt(dx * dx + dy * dy + dz * dz)
if(r12 .lt. 1d-10) then
gradx(jpoint) = 0.d0
grady(jpoint) = 0.d0
gradz(jpoint) = 0.d0
cycle
endif
tmp = 0.5d0 * (1.d0 - derf(mu_erf * r12)) / r12
gradx(jpoint) = tmp * dx
grady(jpoint) = tmp * dy
gradz(jpoint) = tmp * dz
enddo
elseif((j1b_type .ge. 200) .and. (j1b_type .lt. 300)) then
double precision :: mu_val, mu_tmp, mu_der(3)
do jpoint = 1, n_points_extra_final_grid ! r2
r2(1) = final_grid_points_extra(1,jpoint)
r2(2) = final_grid_points_extra(2,jpoint)
r2(3) = final_grid_points_extra(3,jpoint)
dx = r1(1) - r2(1)
dy = r1(2) - r2(2)
dz = r1(3) - r2(3)
r12 = dsqrt(dx * dx + dy * dy + dz * dz)
call mu_r_val_and_grad(r1, r2, mu_val, mu_der)
mu_tmp = mu_val * r12
tmp = inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / (mu_val * mu_val)
gradx(jpoint) = tmp * mu_der(1)
grady(jpoint) = tmp * mu_der(2)
gradz(jpoint) = tmp * mu_der(3)
if(r12 .lt. 1d-10) then
gradx(jpoint) = 0.d0
grady(jpoint) = 0.d0
gradz(jpoint) = 0.d0
cycle
endif
tmp = 0.5d0 * (1.d0 - derf(mu_tmp)) / r12
gradx(jpoint) = gradx(jpoint) + tmp * dx
grady(jpoint) = grady(jpoint) + tmp * dy
gradz(jpoint) = gradz(jpoint) + tmp * dz
enddo
else
print *, ' j1b_type = ', j1b_type, 'not implemented yet'
stop
endif
return
end subroutine grad1_j12_mu_r1_seq
! ---
subroutine j12_mu_r1_seq(r1, n_grid2, res)
include 'constants.include.F'
implicit none
integer, intent(in) :: n_grid2
double precision, intent(in) :: r1(3)
double precision, intent(out) :: res(n_grid2)
integer :: jpoint
double precision :: r2(3)
double precision :: mu_tmp, r12
PROVIDE final_grid_points_extra
if((j1b_type .ge. 0) .and. (j1b_type .lt. 200)) then
do jpoint = 1, n_points_extra_final_grid ! r2
r2(1) = final_grid_points_extra(1,jpoint)
r2(2) = final_grid_points_extra(2,jpoint)
r2(3) = final_grid_points_extra(3,jpoint)
r12 = dsqrt( (r1(1) - r2(1)) * (r1(1) - r2(1)) &
+ (r1(2) - r2(2)) * (r1(2) - r2(2)) &
+ (r1(3) - r2(3)) * (r1(3) - r2(3)) )
mu_tmp = mu_erf * r12
res(jpoint) = 0.5d0 * r12 * (1.d0 - derf(mu_tmp)) - inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / mu_erf
enddo
else
print *, ' j1b_type = ', j1b_type, 'not implemented for j12_mu_r1_seq'
stop
endif
return
end subroutine j12_mu_r1_seq
! ---
subroutine j1b_nucl_r1_seq(n_grid2, res)
! TODO
! change loops order
implicit none
integer, intent(in) :: n_grid2
double precision, intent(out) :: res(n_grid2)
double precision :: r(3)
integer :: i, jpoint
double precision :: a, d, e, x, y, z
if((j1b_type .eq. 2) .or. (j1b_type .eq. 102)) then
res = 1.d0
do jpoint = 1, n_points_extra_final_grid ! r2
r(1) = final_grid_points_extra(1,jpoint)
r(2) = final_grid_points_extra(2,jpoint)
r(3) = final_grid_points_extra(3,jpoint)
do i = 1, nucl_num
a = j1b_pen(i)
d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
+ (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+ (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
res(jpoint) -= dexp(-a*dsqrt(d))
enddo
enddo
elseif((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then
res = 1.d0
do jpoint = 1, n_points_extra_final_grid ! r2
r(1) = final_grid_points_extra(1,jpoint)
r(2) = final_grid_points_extra(2,jpoint)
r(3) = final_grid_points_extra(3,jpoint)
do i = 1, nucl_num
a = j1b_pen(i)
d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
+ (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+ (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
e = 1.d0 - dexp(-a*d)
res(jpoint) *= e
enddo
enddo
elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then
res = 1.d0
do jpoint = 1, n_points_extra_final_grid ! r2
r(1) = final_grid_points_extra(1,jpoint)
r(2) = final_grid_points_extra(2,jpoint)
r(3) = final_grid_points_extra(3,jpoint)
do i = 1, nucl_num
a = j1b_pen(i)
d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
+ (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+ (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
res(jpoint) -= j1b_pen_coef(i) * dexp(-a*d)
enddo
enddo
elseif((j1b_type .eq. 5) .or. (j1b_type .eq. 105)) then
res = 1.d0
do jpoint = 1, n_points_extra_final_grid ! r2
r(1) = final_grid_points_extra(1,jpoint)
r(2) = final_grid_points_extra(2,jpoint)
r(3) = final_grid_points_extra(3,jpoint)
do i = 1, nucl_num
a = j1b_pen(i)
x = r(1) - nucl_coord(i,1)
y = r(2) - nucl_coord(i,2)
z = r(3) - nucl_coord(i,3)
d = x*x + y*y + z*z
res(jpoint) -= dexp(-a*d*d)
enddo
enddo
else
print *, ' j1b_type = ', j1b_type, 'not implemented for j1b_nucl_r1_seq'
stop
endif
return
end subroutine j1b_nucl_r1_seq
! ---

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

@ -149,22 +149,6 @@ BEGIN_PROVIDER [double precision, tc_grad_and_lapl_ao, (ao_num, ao_num, ao_num,
deallocate(b_mat)
call sum_A_At(tc_grad_and_lapl_ao(1,1,1,1), ao_num*ao_num)
! !$OMP PARALLEL &
! !$OMP DEFAULT (NONE) &
! !$OMP PRIVATE (i, j, k, l) &
! !$OMP SHARED (ac_mat, tc_grad_and_lapl_ao, ao_num)
! !$OMP DO SCHEDULE (static)
! do j = 1, ao_num
! do l = 1, ao_num
! do i = 1, ao_num
! do k = 1, ao_num
! tc_grad_and_lapl_ao(k,i,l,j) = ac_mat(k,i,l,j) + ac_mat(l,j,k,i)
! enddo
! enddo
! enddo
! enddo
! !$OMP END DO
! !$OMP END PARALLEL
endif

102
src/non_h_ints_mu/qmckl.irp.f Normal file
View File

@ -0,0 +1,102 @@
BEGIN_PROVIDER [ integer*8, qmckl_ctx_jastrow ]
use qmckl
implicit none
BEGIN_DOC
! Context for the QMCKL library
END_DOC
integer(qmckl_exit_code) :: rc
qmckl_ctx_jastrow = qmckl_context_create()
rc = qmckl_set_nucleus_num(qmckl_ctx_jastrow, nucl_num*1_8)
rc = qmckl_check(qmckl_ctx_jastrow, rc)
if (rc /= QMCKL_SUCCESS) stop -1
rc = qmckl_set_nucleus_charge(qmckl_ctx_jastrow, nucl_charge, nucl_num*1_8)
rc = qmckl_check(qmckl_ctx_jastrow, rc)
if (rc /= QMCKL_SUCCESS) stop -1
rc = qmckl_set_nucleus_coord(qmckl_ctx_jastrow, 'T', nucl_coord, nucl_num*3_8)
rc = qmckl_check(qmckl_ctx_jastrow, rc)
if (rc /= QMCKL_SUCCESS) stop -1
rc = qmckl_set_electron_num(qmckl_ctx_jastrow, 1_8, 1_8)
rc = qmckl_check(qmckl_ctx_jastrow, rc)
if (rc /= QMCKL_SUCCESS) stop -1
! Jastrow parameters
rc = qmckl_set_jastrow_champ_type_nucl_num (qmckl_ctx_jastrow, 2_8)
rc = qmckl_check(qmckl_ctx_jastrow, rc)
if (rc /= QMCKL_SUCCESS) stop -1
rc = qmckl_set_jastrow_champ_type_nucl_vector (qmckl_ctx_jastrow, (/0_8,1_8,1_8/), 1_8*nucl_num)
rc = qmckl_check(qmckl_ctx_jastrow, rc)
if (rc /= QMCKL_SUCCESS) stop -1
rc = qmckl_set_jastrow_champ_rescale_factor_ee (qmckl_ctx_jastrow, 0.6d0)
rc = qmckl_check(qmckl_ctx_jastrow, rc)
if (rc /= QMCKL_SUCCESS) stop -1
rc = qmckl_set_jastrow_champ_rescale_factor_en (qmckl_ctx_jastrow, (/0.6d0, 0.6d0 /), 2_8 )
rc = qmckl_check(qmckl_ctx_jastrow, rc)
if (rc /= QMCKL_SUCCESS) stop -1
rc = qmckl_set_jastrow_champ_aord_num (qmckl_ctx_jastrow, 5_8)
rc = qmckl_check(qmckl_ctx_jastrow, rc)
if (rc /= QMCKL_SUCCESS) stop -1
rc = qmckl_set_jastrow_champ_bord_num (qmckl_ctx_jastrow, 5_8)
rc = qmckl_check(qmckl_ctx_jastrow, rc)
if (rc /= QMCKL_SUCCESS) stop -1
rc = qmckl_set_jastrow_champ_cord_num (qmckl_ctx_jastrow, 0_8)
rc = qmckl_check(qmckl_ctx_jastrow, rc)
if (rc /= QMCKL_SUCCESS) stop -1
! double precision :: a_vector(12) = dble(&
! (/ 0.00000000, 0.00000000, -0.71168405, -0.44415699, -0.13865109, 0.07002267 , &
! 0.00000000, 0.00000000, -0.11379992, 0.04542846, 0.01696997, -0.01809299 /) )
! double precision :: b_vector(6) = dble(&
! (/ 0.00000000, 0.65603311, 0.14581988, 0.03138163, 0.00153156, -0.00447302 /) )
! double precision :: c_vector(46) = &
! (/ 1.06384279d0, -1.44303973d0, -0.92409833d0, 0.11845356d0, -0.02980776d0, &
! 1.07048863d0, 0.06009623d0, -0.01854872d0, -0.00915398d0, 0.01324198d0, &
! -0.00504959d0, -0.01202497d0, -0.00531644d0, 0.15101629d0, -0.00723831d0, &
! -0.00384182d0, -0.00295036d0, -0.00114583d0, 0.00158107d0, -0.00078107d0, &
! -0.00080000d0, -0.14140576d0, -0.00237271d0, -0.03006706d0, 0.01537009d0, &
! -0.02327226d0, 0.16502789d0, -0.01458259d0, -0.09946065d0, 0.00850029d0, &
! -0.02969361d0, -0.01159547d0, 0.00516313d0, 0.00405247d0, -0.02200886d0, &
! 0.03376709d0, 0.01277767d0, -0.01523013d0, -0.00739224d0, -0.00463953d0, &
! 0.00003174d0, -0.01421128d0, 0.00808140d0, 0.00612988d0, -0.00610632d0, &
! 0.01926215d0 /)
! a_vector = 0.d0
! b_vector = 0.d0
! c_vector = 0.d0
double precision :: a_vector(12) = dble(&
(/ 0.00000000 , 0.00000000, -0.45105821, -0.23519218, -0.03825391, 0.10072866, &
0.00000000 , 0.00000000, -0.06930592, -0.02909224, -0.00134650, 0.01477242 /) )
double precision :: b_vector(6) = dble(&
(/ 0.00000000, 0.00000000, 0.29217862, -0.00450671, -0.02925982, -0.01381532 /) )
double precision :: c_vector(46)
c_vector = 0.d0
rc = qmckl_set_jastrow_champ_a_vector(qmckl_ctx_jastrow, a_vector, 12_8)
rc = qmckl_check(qmckl_ctx_jastrow, rc)
if (rc /= QMCKL_SUCCESS) stop -1
rc = qmckl_set_jastrow_champ_b_vector(qmckl_ctx_jastrow, b_vector, 6_8)
rc = qmckl_check(qmckl_ctx_jastrow, rc)
if (rc /= QMCKL_SUCCESS) stop -1
! rc = qmckl_set_jastrow_champ_c_vector(qmckl_ctx_jastrow, c_vector, 46_8)
! rc = qmckl_check(qmckl_ctx_jastrow, rc)
! if (rc /= QMCKL_SUCCESS) stop -1
END_PROVIDER

116
src/non_h_ints_mu/tc_integ.irp.f → src/non_h_ints_mu/tc_integ_an.irp.f
View File

@ -1,10 +1,11 @@
! ---
BEGIN_PROVIDER [double precision, int2_grad1_u12_ao, (ao_num, ao_num, n_points_final_grid, 3)]
BEGIN_DOC
!
! TODO
! combine with int2_grad1_u12_square_ao to avoid repeated calculation ?
!
! int2_grad1_u12_ao(i,j,ipoint,:) = \int dr2 [-1 * \grad_r1 J(r1,r2)] \phi_i(r2) \phi_j(r2)
!
! where r1 = r(ipoint)
@ -104,63 +105,13 @@ BEGIN_PROVIDER [double precision, int2_grad1_u12_ao, (ao_num, ao_num, n_points_f
FREE v_ij_erf_rk_cst_mu_j1b v_ij_u_cst_mu_j1b_an x_v_ij_erf_rk_cst_mu_j1b
elseif(j1b_type .ge. 100) then
! PROVIDE int2_grad1_u12_ao_num
! int2_grad1_u12_ao = int2_grad1_u12_ao_num
PROVIDE final_weight_at_r_vector_extra aos_in_r_array_extra
PROVIDE grad1_u12_num
PROVIDE int2_grad1_u12_ao_num_1shot
int2_grad1_u12_ao = int2_grad1_u12_ao_num_1shot
double precision, allocatable :: tmp(:,:,:)
allocate(tmp(n_points_extra_final_grid,ao_num,ao_num))
tmp = 0.d0
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (j, i, jpoint) &
!$OMP SHARED (tmp, ao_num, n_points_extra_final_grid, final_weight_at_r_vector_extra, aos_in_r_array_extra_transp)
!$OMP DO SCHEDULE (static)
do j = 1, ao_num
do i = 1, ao_num
do jpoint = 1, n_points_extra_final_grid
tmp(jpoint,i,j) = final_weight_at_r_vector_extra(jpoint) * aos_in_r_array_extra_transp(jpoint,i) * aos_in_r_array_extra_transp(jpoint,j)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
int2_grad1_u12_ao = 0.d0
do m = 1, 3
!call dgemm( "T", "N", ao_num*ao_num, n_points_final_grid, n_points_extra_final_grid, +1.d0 &
! this work also because of the symmetry in K(1,2) and sign compensation in L(1,2,3)
call dgemm( "T", "N", ao_num*ao_num, n_points_final_grid, n_points_extra_final_grid, -1.d0 &
, tmp(1,1,1), n_points_extra_final_grid, grad1_u12_num(1,1,m), n_points_extra_final_grid &
, 0.d0, int2_grad1_u12_ao(1,1,1,m), ao_num*ao_num)
enddo
!! these dgemm are equivalent to
!!$OMP PARALLEL &
!!$OMP DEFAULT (NONE) &
!!$OMP PRIVATE (j, i, ipoint, jpoint, w) &
!!$OMP SHARED (int2_grad1_u12_ao, ao_num, n_points_final_grid, &
!!$OMP n_points_extra_final_grid, final_weight_at_r_vector_extra, &
!!$OMP aos_in_r_array_extra_transp, grad1_u12_num, tmp)
!!$OMP DO SCHEDULE (static)
!do ipoint = 1, n_points_final_grid
! do j = 1, ao_num
! do i = 1, ao_num
! do jpoint = 1, n_points_extra_final_grid
! w = -tmp(jpoint,i,j)
! !w = tmp(jpoint,i,j) this work also because of the symmetry in K(1,2)
! ! and sign compensation in L(1,2,3)
! int2_grad1_u12_ao(i,j,ipoint,1) += w * grad1_u12_num(jpoint,ipoint,1)
! int2_grad1_u12_ao(i,j,ipoint,2) += w * grad1_u12_num(jpoint,ipoint,2)
! int2_grad1_u12_ao(i,j,ipoint,3) += w * grad1_u12_num(jpoint,ipoint,3)
! enddo
! enddo
! enddo
!enddo
!!$OMP END DO
!!$OMP END PARALLEL
deallocate(tmp)
else
print *, ' j1b_type = ', j1b_type, 'not implemented yet'
@ -274,55 +225,12 @@ BEGIN_PROVIDER [double precision, int2_grad1_u12_square_ao, (ao_num, ao_num, n_p
elseif(j1b_type .ge. 100) then
PROVIDE final_weight_at_r_vector_extra aos_in_r_array_extra
PROVIDE grad1_u12_squared_num
! PROVIDE int2_grad1_u12_square_ao_num
! int2_grad1_u12_square_ao = int2_grad1_u12_square_ao_num
double precision, allocatable :: tmp(:,:,:)
allocate(tmp(n_points_extra_final_grid,ao_num,ao_num))
tmp = 0.d0
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (j, i, jpoint) &
!$OMP SHARED (tmp, ao_num, n_points_extra_final_grid, final_weight_at_r_vector_extra, aos_in_r_array_extra_transp)
!$OMP DO SCHEDULE (static)
do j = 1, ao_num
do i = 1, ao_num
do jpoint = 1, n_points_extra_final_grid
tmp(jpoint,i,j) = final_weight_at_r_vector_extra(jpoint) * aos_in_r_array_extra_transp(jpoint,i) * aos_in_r_array_extra_transp(jpoint,j)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
PROVIDE int2_grad1_u12_square_ao_num_1shot
int2_grad1_u12_square_ao = int2_grad1_u12_square_ao_num_1shot
int2_grad1_u12_square_ao = 0.d0
call dgemm( "T", "N", ao_num*ao_num, n_points_final_grid, n_points_extra_final_grid, -0.5d0 &
, tmp(1,1,1), n_points_extra_final_grid, grad1_u12_squared_num(1,1), n_points_extra_final_grid &
, 0.d0, int2_grad1_u12_square_ao(1,1,1), ao_num*ao_num)
!! this dgemm is equivalen to
!!$OMP PARALLEL &
!!$OMP DEFAULT (NONE) &
!!$OMP PRIVATE (i, j, ipoint, jpoint, w) &
!!$OMP SHARED (int2_grad1_u12_square_ao, ao_num, n_points_final_grid, &
!!$OMP n_points_extra_final_grid, final_weight_at_r_vector_extra, &
!!$OMP aos_in_r_array_extra_transp, grad1_u12_squared_num, tmp)
!!$OMP DO SCHEDULE (static)
!do ipoint = 1, n_points_final_grid
! do j = 1, ao_num
! do i = 1, ao_num
! do jpoint = 1, n_points_extra_final_grid
! w = -0.5d0 * tmp(jpoint,i,j)
! int2_grad1_u12_square_ao(i,j,ipoint) += w * grad1_u12_squared_num(jpoint,ipoint)
! enddo
! enddo
! enddo
!enddo
!!$OMP END DO
!!$OMP END PARALLEL
deallocate(tmp)
else
print *, ' j1b_type = ', j1b_type, 'not implemented yet'

201
src/non_h_ints_mu/tc_integ_num.irp.f Normal file
View File

@ -0,0 +1,201 @@
BEGIN_PROVIDER [double precision, int2_grad1_u12_ao_num , (ao_num,ao_num,n_points_final_grid,3)]
&BEGIN_PROVIDER [double precision, int2_grad1_u12_square_ao_num, (ao_num,ao_num,n_points_final_grid) ]
BEGIN_DOC
!
! int2_grad1_u12_ao_num(i,j,ipoint,:) = \int dr2 [-1 * \grad_r1 J(r1,r2)] \phi_i(r2) \phi_j(r2)
!
! int2_grad1_u12_square_ao_num = -(1/2) x int dr2 chi_l(r2) chi_j(r2) [grad_1 u(r1,r2)]^2
!
END_DOC
implicit none
integer :: ipoint, i, j, m, jpoint
integer :: n_blocks, n_rest, n_pass
integer :: i_blocks, i_rest, i_pass, ii
double precision :: time0, time1
double precision :: mem, n_double
double precision, allocatable :: tmp(:,:,:)
double precision, allocatable :: tmp_grad1_u12(:,:,:), tmp_grad1_u12_squared(:,:)
! TODO
! tmp_grad1_u12_squared get be obtained from tmp_grad1_u12
print*, ' providing int2_grad1_u12_ao_num & int2_grad1_u12_square_ao_num ...'
call wall_time(time0)
PROVIDE final_weight_at_r_vector_extra aos_in_r_array_extra
allocate(tmp(n_points_extra_final_grid,ao_num,ao_num))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (j, i, jpoint) &
!$OMP SHARED (tmp, ao_num, n_points_extra_final_grid, final_weight_at_r_vector_extra, aos_in_r_array_extra_transp)
!$OMP DO SCHEDULE (static)
do j = 1, ao_num
do i = 1, ao_num
do jpoint = 1, n_points_extra_final_grid
tmp(jpoint,i,j) = final_weight_at_r_vector_extra(jpoint) * aos_in_r_array_extra_transp(jpoint,i) * aos_in_r_array_extra_transp(jpoint,j)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
! n_points_final_grid = n_blocks * n_pass + n_rest
call total_memory(mem)
mem = max(1.d0, qp_max_mem - mem)
n_double = mem * 1.d8
n_blocks = min(n_double / (n_points_extra_final_grid * 4), 1.d0*n_points_final_grid)
n_rest = int(mod(n_points_final_grid, n_blocks))
n_pass = int((n_points_final_grid - n_rest) / n_blocks)
call write_int(6, n_pass, 'Number of passes')
call write_int(6, n_blocks, 'Size of the blocks')
call write_int(6, n_rest, 'Size of the last block')
allocate(tmp_grad1_u12_squared(n_points_extra_final_grid,n_blocks))
allocate(tmp_grad1_u12(n_points_extra_final_grid,n_blocks,3))
do i_pass = 1, n_pass
ii = (i_pass-1)*n_blocks + 1
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i_blocks, ipoint) &
!$OMP SHARED (n_blocks, n_points_extra_final_grid, ii, &
!$OMP final_grid_points, tmp_grad1_u12, &
!$OMP tmp_grad1_u12_squared)
!$OMP DO
do i_blocks = 1, n_blocks
ipoint = ii - 1 + i_blocks ! r1
call get_grad1_u12_withsq_r1_seq(final_grid_points(1,ipoint), n_points_extra_final_grid, tmp_grad1_u12(1,i_blocks,1) &
, tmp_grad1_u12(1,i_blocks,2) &
, tmp_grad1_u12(1,i_blocks,3) &
, tmp_grad1_u12_squared(1,i_blocks))
enddo
!$OMP END DO
!$OMP END PARALLEL
do m = 1, 3
call dgemm( "T", "N", ao_num*ao_num, n_blocks, n_points_extra_final_grid, 1.d0 &
, tmp(1,1,1), n_points_extra_final_grid, tmp_grad1_u12(1,1,m), n_points_extra_final_grid &
, 0.d0, int2_grad1_u12_ao_num(1,1,ii,m), ao_num*ao_num)
enddo
call dgemm( "T", "N", ao_num*ao_num, n_blocks, n_points_extra_final_grid, -0.5d0 &
, tmp(1,1,1), n_points_extra_final_grid, tmp_grad1_u12_squared(1,1), n_points_extra_final_grid &
, 0.d0, int2_grad1_u12_square_ao_num(1,1,ii), ao_num*ao_num)
enddo
deallocate(tmp_grad1_u12, tmp_grad1_u12_squared)
if(n_rest .gt. 0) then
allocate(tmp_grad1_u12_squared(n_points_extra_final_grid,n_rest))
allocate(tmp_grad1_u12(n_points_extra_final_grid,n_rest,3))
ii = n_pass*n_blocks + 1
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i_rest, ipoint) &
!$OMP SHARED (n_rest, n_points_extra_final_grid, ii, &
!$OMP final_grid_points, tmp_grad1_u12, &
!$OMP tmp_grad1_u12_squared)
!$OMP DO
do i_rest = 1, n_rest
ipoint = ii - 1 + i_rest ! r1
call get_grad1_u12_withsq_r1_seq(final_grid_points(1,ipoint), n_points_extra_final_grid, tmp_grad1_u12(1,i_rest,1) &
, tmp_grad1_u12(1,i_rest,2) &
, tmp_grad1_u12(1,i_rest,3) &
, tmp_grad1_u12_squared(1,i_rest))
enddo
!$OMP END DO
!$OMP END PARALLEL
do m = 1, 3
call dgemm( "T", "N", ao_num*ao_num, n_rest, n_points_extra_final_grid, 1.d0 &
, tmp(1,1,1), n_points_extra_final_grid, tmp_grad1_u12(1,1,m), n_points_extra_final_grid &
, 0.d0, int2_grad1_u12_ao_num(1,1,ii,m), ao_num*ao_num)
enddo
call dgemm( "T", "N", ao_num*ao_num, n_rest, n_points_extra_final_grid, -0.5d0 &
, tmp(1,1,1), n_points_extra_final_grid, tmp_grad1_u12_squared(1,1), n_points_extra_final_grid &
, 0.d0, int2_grad1_u12_square_ao_num(1,1,ii), ao_num*ao_num)
deallocate(tmp_grad1_u12, tmp_grad1_u12_squared)
endif
deallocate(tmp)
call wall_time(time1)
print*, ' wall time for int2_grad1_u12_ao_num & int2_grad1_u12_square_ao_num =', time1-time0
call print_memory_usage()
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, int2_grad1_u12_ao_num_1shot , (ao_num,ao_num,n_points_final_grid,3)]
&BEGIN_PROVIDER [double precision, int2_grad1_u12_square_ao_num_1shot, (ao_num,ao_num,n_points_final_grid) ]
BEGIN_DOC
!
! int2_grad1_u12_ao_num_1shot(i,j,ipoint,:) = \int dr2 [-1 * \grad_r1 J(r1,r2)] \phi_i(r2) \phi_j(r2)
!
! int2_grad1_u12_square_ao_num_1shot = -(1/2) x int dr2 chi_l(r2) chi_j(r2) [grad_1 u(r1,r2)]^2
!
END_DOC
implicit none
integer :: ipoint, i, j, m, jpoint
double precision :: time0, time1
double precision, allocatable :: tmp(:,:,:)
print*, ' providing int2_grad1_u12_ao_num_1shot & int2_grad1_u12_square_ao_num_1shot ...'
call wall_time(time0)
PROVIDE final_weight_at_r_vector_extra aos_in_r_array_extra
PROVIDE grad1_u12_num grad1_u12_squared_num
allocate(tmp(n_points_extra_final_grid,ao_num,ao_num))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (j, i, jpoint) &
!$OMP SHARED (tmp, ao_num, n_points_extra_final_grid, final_weight_at_r_vector_extra, aos_in_r_array_extra_transp)
!$OMP DO SCHEDULE (static)
do j = 1, ao_num
do i = 1, ao_num
do jpoint = 1, n_points_extra_final_grid
tmp(jpoint,i,j) = final_weight_at_r_vector_extra(jpoint) * aos_in_r_array_extra_transp(jpoint,i) * aos_in_r_array_extra_transp(jpoint,j)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
do m = 1, 3
!call dgemm( "T", "N", ao_num*ao_num, n_points_final_grid, n_points_extra_final_grid, -1.d0 &
! this work also because of the symmetry in K(1,2) and sign compensation in L(1,2,3)
call dgemm( "T", "N", ao_num*ao_num, n_points_final_grid, n_points_extra_final_grid, +1.d0 &
, tmp(1,1,1), n_points_extra_final_grid, grad1_u12_num(1,1,m), n_points_extra_final_grid &
, 0.d0, int2_grad1_u12_ao_num_1shot(1,1,1,m), ao_num*ao_num)
enddo
FREE grad1_u12_num
call dgemm( "T", "N", ao_num*ao_num, n_points_final_grid, n_points_extra_final_grid, -0.5d0 &
, tmp(1,1,1), n_points_extra_final_grid, grad1_u12_squared_num(1,1), n_points_extra_final_grid &
, 0.d0, int2_grad1_u12_square_ao_num_1shot(1,1,1), ao_num*ao_num)
FREE grad1_u12_squared_num
deallocate(tmp)
call wall_time(time1)
print*, ' wall time for int2_grad1_u12_ao_num_1shot & int2_grad1_u12_square_ao_num_1shot =', time1-time0
call print_memory_usage()
END_PROVIDER
! ---

136
src/non_h_ints_mu/test_non_h_ints.irp.f
View File

@ -11,10 +11,24 @@ program test_non_h
my_n_pt_a_grid = tc_grid1_a
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
if(j1b_type .ge. 100) then
my_extra_grid_becke = .True.
PROVIDE tc_grid2_a tc_grid2_r
my_n_pt_r_extra_grid = tc_grid2_r
my_n_pt_a_extra_grid = tc_grid2_a
touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid
endif
!call routine_grad_squared()
!call routine_fit()
call test_ipp()
!call test_ipp()
!call test_v_ij_u_cst_mu_j1b_an()
call test_int2_grad1_u12_square_ao()
call test_int2_grad1_u12_ao()
end
! ---
@ -545,9 +559,129 @@ end subroutine grad1_aos_ik_grad1_esquare
! ---
subroutine test_v_ij_u_cst_mu_j1b_an()
implicit none
integer :: i, j, ipoint
double precision :: I_old, I_new
double precision :: norm, accu, thr, diff
PROVIDE v_ij_u_cst_mu_j1b_an_old v_ij_u_cst_mu_j1b_an
thr = 1d-12
norm = 0.d0
accu = 0.d0
do ipoint = 1, n_points_final_grid
do i = 1, ao_num
do j = 1, ao_num
I_old = v_ij_u_cst_mu_j1b_an_old(j,i,ipoint)
I_new = v_ij_u_cst_mu_j1b_an (j,i,ipoint)
diff = dabs(I_new-I_old)
if(diff .gt. thr) then
print *, ' problem on:', j, i, ipoint
print *, ' old value :', I_old
print *, ' new value :', I_new
stop
endif
accu += diff
norm += dabs(I_old)
enddo
enddo
enddo
print*, ' accuracy(%) = ', 100.d0 * accu / norm
return
end subroutine test_v_ij_u_cst_mu_j1b_an
! ---
subroutine test_int2_grad1_u12_square_ao()
implicit none
integer :: i, j, ipoint
double precision :: I_old, I_new
double precision :: norm, accu, thr, diff
PROVIDE int2_grad1_u12_square_ao
PROVIDE int2_grad1_u12_square_ao_num_1shot
thr = 1d-8
norm = 0.d0
accu = 0.d0
do ipoint = 1, n_points_final_grid
do i = 1, ao_num
do j = 1, ao_num
I_old = int2_grad1_u12_square_ao_num_1shot(j,i,ipoint)
I_new = int2_grad1_u12_square_ao (j,i,ipoint)
!I_new = int2_grad1_u12_square_ao_num (j,i,ipoint)
diff = dabs(I_new-I_old)
if(diff .gt. thr) then
print *, ' problem on:', j, i, ipoint
print *, ' old value :', I_old
print *, ' new value :', I_new
!stop
endif
accu += diff
norm += dabs(I_old)
enddo
enddo
enddo
print*, ' accuracy(%) = ', 100.d0 * accu / norm
return
end subroutine test_int2_grad1_u12_square_ao
! ---
subroutine test_int2_grad1_u12_ao()
implicit none
integer :: i, j, ipoint, m
double precision :: I_old, I_new
double precision :: norm, accu, thr, diff
PROVIDE int2_grad1_u12_ao
PROVIDE int2_grad1_u12_ao_num_1shot
thr = 1d-8
norm = 0.d0
accu = 0.d0
do ipoint = 1, n_points_final_grid
do i = 1, ao_num
do j = 1, ao_num
do m = 1, 3
I_old = int2_grad1_u12_ao_num_1shot(j,i,ipoint,m)
I_new = int2_grad1_u12_ao (j,i,ipoint,m)
!I_new = int2_grad1_u12_ao_num (j,i,ipoint,m)
diff = dabs(I_new-I_old)
if(diff .gt. thr) then
print *, ' problem on:', j, i, ipoint, m
print *, ' old value :', I_old
print *, ' new value :', I_new
!stop
endif
accu += diff
norm += dabs(I_old)
enddo
enddo
enddo
enddo
print*, ' accuracy(%) = ', 100.d0 * accu / norm
return
end subroutine test_int2_grad1_u12_ao
! ---

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

@ -1,7 +1,4 @@
! TODO
! remove ao_two_e_coul and use map directly
! ---
BEGIN_PROVIDER [double precision, ao_vartc_int_chemist, (ao_num, ao_num, ao_num, ao_num)]
@ -58,12 +55,13 @@ BEGIN_PROVIDER [double precision, ao_tc_int_chemist, (ao_num, ao_num, ao_num, ao
integer :: i, j, k, l
double precision :: wall1, wall0
PROVIDE j1b_type
print *, ' providing ao_tc_int_chemist ...'
call wall_time(wall0)
if(test_cycle_tc) then
PROVIDE j1b_type
if(j1b_type .ne. 3) then
print*, ' TC integrals with cycle can not be used for j1b_type =', j1b_type
stop
@ -89,6 +87,11 @@ BEGIN_PROVIDER [double precision, ao_tc_int_chemist, (ao_num, ao_num, ao_num, ao
FREE tc_grad_square_ao tc_grad_and_lapl_ao ao_two_e_coul
if(j1b_type .ge. 100) then
FREE int2_grad1_u12_ao_num int2_grad1_u12_square_ao_num
endif
call wall_time(wall1)
print *, ' wall time for ao_tc_int_chemist ', wall1 - wall0
call print_memory_usage()
@ -160,24 +163,26 @@ BEGIN_PROVIDER [double precision, ao_two_e_coul, (ao_num, ao_num, ao_num, ao_num
END_DOC
integer :: i, j, k, l
double precision :: integral
double precision, external :: get_ao_two_e_integral
PROVIDE ao_integrals_map
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP SHARED(ao_num, ao_two_e_coul, ao_integrals_map) &
!$OMP PRIVATE(i, j, k, l)
!$OMP DO
do j = 1, ao_num
do l = 1, ao_num
do i = 1, ao_num
do k = 1, ao_num
! < 1:k, 2:l | 1:i, 2:j >
integral = get_ao_two_e_integral(i, j, k, l, ao_integrals_map)
ao_two_e_coul(k,i,l,j) = integral
ao_two_e_coul(k,i,l,j) = get_ao_two_e_integral(i, j, k, l, ao_integrals_map)
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
END_PROVIDER

1
src/qmckl/LIB Normal file
View File

@ -0,0 +1 @@
-lqmckl

1
src/qmckl/NEED Normal file
View File

@ -0,0 +1 @@
nuclei

4
src/qmckl/README.md Normal file
View File

@ -0,0 +1,4 @@
#QMCkl
Info related to the QMCkl library.

1
src/qmckl/qmckl.F90 Normal file
View File

@ -0,0 +1 @@
#include <qmckl_f.F90>

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

File diff suppressed because it is too large Load Diff

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

@ -26,7 +26,7 @@ BEGIN_PROVIDER [ double precision, normal_two_body_bi_orth_old, (mo_num, mo_num,
if(read_tc_norm_ord) then
open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/normal_two_body_bi_orth_old', action="read")
open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/normal_two_body_bi_orth', action="read")
read(11) normal_two_body_bi_orth_old
close(11)
@ -103,7 +103,7 @@ BEGIN_PROVIDER [ double precision, normal_two_body_bi_orth_old, (mo_num, mo_num,
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")
open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/normal_two_body_bi_orth', action="write")
call ezfio_set_work_empty(.False.)
write(11) normal_two_body_bi_orth_old
close(11)

1022
src/tc_bi_ortho/normal_ordered_v0.irp.f Normal file
View File

File diff suppressed because it is too large Load Diff

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

@ -37,7 +37,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
@ -53,7 +55,7 @@ subroutine htilde_mu_mat_opt_bi_ortho_tot(key_j, key_i, Nint, htot)
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
double precision, intent(out) :: htot
double precision :: hmono, htwoe, hthree
double precision :: hmono, htwoe, hthree
call htilde_mu_mat_opt_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree, htot)
@ -85,29 +87,36 @@ 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(.not.pure_three_body_h_tc)then
if(degree.gt.2) return
if(degree == 0) then
call diag_htilde_mu_mat_fock_bi_ortho (Nint, key_i, hmono, htwoe, hthree, htot)
else if (degree == 1) then
call single_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i , hmono, htwoe, hthree, htot)
else if(degree == 2) then
call double_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot)
endif
if(.not.pure_three_body_h_tc) then
if(degree .gt. 2) return
if(degree == 0) then
call diag_htilde_mu_mat_fock_bi_ortho (Nint, key_i, hmono, htwoe, hthree, htot)
else if (degree == 1) then
call single_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i , hmono, htwoe, hthree, htot)
else if(degree == 2) then
call double_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot)
endif
else
if(degree.gt.3) return
if(degree == 0) then
call diag_htilde_mu_mat_fock_bi_ortho (Nint, key_i, hmono, htwoe, hthree, htot)
else if (degree == 1) then
call single_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i , hmono, htwoe, hthree, htot)
else if(degree == 2) then
call double_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot)
else
call triple_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot)
endif
if(degree .gt. 3) return
if(degree == 0) then
call diag_htilde_mu_mat_fock_bi_ortho (Nint, key_i, hmono, htwoe, hthree, htot)
else if (degree == 1) then
call single_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i , hmono, htwoe, hthree, htot)
else if(degree == 2) then
call double_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot)
else
call triple_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot)
endif
endif
if(degree==0) then
@ -159,3 +168,4 @@ subroutine htilde_mu_mat_opt_bi_ortho_no_3e(key_j, key_i, Nint, htot)
end
! ---

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

@ -7,7 +7,9 @@
&BEGIN_PROVIDER [ double precision, ref_tc_energy_3e]
BEGIN_DOC
!
! Various component of the TC energy for the reference "HF" Slater determinant
!
END_DOC
implicit none
@ -29,6 +31,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
! ---
@ -36,7 +43,9 @@ END_PROVIDER
subroutine diag_htilde_mu_mat_fock_bi_ortho(Nint, det_in, hmono, htwoe, hthree, htot)
BEGIN_DOC
!
! Computes $\langle i|H|i \rangle$.
!
END_DOC
implicit none
@ -58,7 +67,7 @@ subroutine diag_htilde_mu_mat_fock_bi_ortho(Nint, det_in, hmono, htwoe, hthree,
nexc(1) = 0
nexc(2) = 0
do i=1,Nint
do i = 1, Nint
hole(i,1) = xor(det_in(i,1),ref_bitmask(i,1))
hole(i,2) = xor(det_in(i,2),ref_bitmask(i,2))
particle(i,1) = iand(hole(i,1),det_in(i,1))
@ -107,6 +116,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
! ---
@ -114,6 +128,7 @@ end
subroutine ac_tc_operator(iorb, ispin, key, hmono, htwoe, hthree, Nint, na, nb)
BEGIN_DOC
!
! Routine that computes one- and two-body energy corresponding
!
! to the ADDITION of an electron in an orbital 'iorb' of spin 'ispin'
@ -123,6 +138,7 @@ subroutine ac_tc_operator(iorb, ispin, key, hmono, htwoe, hthree, Nint, na, nb)
! in output, the determinant key is changed by the ADDITION of that electron
!
! and the quantities hmono,htwoe,hthree are INCREMENTED
!
END_DOC
use bitmasks
@ -178,8 +194,8 @@ subroutine ac_tc_operator(iorb, ispin, key, hmono, htwoe, hthree, Nint, na, nb)
enddo
if(three_body_h_tc .and. (elec_num.gt.2) .and. three_e_3_idx_term) then
!!!!! 3-e part
!! same-spin/same-spin
do j = 1, na
jj = occ(j,ispin)
@ -210,16 +226,19 @@ subroutine ac_tc_operator(iorb, ispin, key, hmono, htwoe, hthree, Nint, na, nb)
enddo
endif
na = na+1
na = na + 1
end
! ---
subroutine a_tc_operator(iorb,ispin,key,hmono,htwoe,hthree,Nint,na,nb)
subroutine a_tc_operator(iorb, ispin, key, hmono, htwoe, hthree, Nint, na, nb)
use bitmasks
implicit none
BEGIN_DOC
!
! Routine that computes one- and two-body energy corresponding
!
! to the REMOVAL of an electron in an orbital 'iorb' of spin 'ispin'
@ -229,17 +248,19 @@ subroutine a_tc_operator(iorb,ispin,key,hmono,htwoe,hthree,Nint,na,nb)
! in output, the determinant key is changed by the REMOVAL of that electron
!
! and the quantities hmono,htwoe,hthree are INCREMENTED
!
END_DOC
integer, intent(in) :: iorb, ispin, Nint
integer, intent(inout) :: na, nb
integer, intent(in) :: iorb, ispin, Nint
integer, intent(inout) :: na, nb
integer(bit_kind), intent(inout) :: key(Nint,2)
double precision, intent(inout) :: hmono,htwoe,hthree
double precision, intent(inout) :: hmono,htwoe,hthree
double precision :: direct_int, exchange_int
integer :: occ(Nint*bit_kind_size,2)
integer :: other_spin
integer :: k,l,i,jj,mm,j,m
integer :: tmp(2)
double precision :: direct_int, exchange_int
integer :: occ(Nint*bit_kind_size,2)
integer :: other_spin
integer :: k, l, i, jj, mm, j, m
integer :: tmp(2)
ASSERT (iorb > 0)
ASSERT (ispin > 0)
@ -259,60 +280,63 @@ subroutine a_tc_operator(iorb,ispin,key,hmono,htwoe,hthree,Nint,na,nb)
hmono = hmono - mo_bi_ortho_tc_one_e(iorb,iorb)
! Same spin
do i=1,na
htwoe= htwoe- mo_bi_ortho_tc_two_e_jj_anti(occ(i,ispin),iorb)
do i = 1, na
htwoe = htwoe - mo_bi_ortho_tc_two_e_jj_anti(occ(i,ispin),iorb)
enddo
! Opposite spin
do i=1,nb
htwoe= htwoe- mo_bi_ortho_tc_two_e_jj(occ(i,other_spin),iorb)
do i = 1, nb
htwoe = htwoe - mo_bi_ortho_tc_two_e_jj(occ(i,other_spin),iorb)
enddo
if(three_body_h_tc.and.elec_num.gt.2.and.three_e_3_idx_term)then
!!!!! 3-e part
!! same-spin/same-spin
do j = 1, na
jj = occ(j,ispin)
do m = j+1, na
mm = occ(m,ispin)
hthree -= three_e_diag_parrallel_spin_prov(mm,jj,iorb)
if(three_body_h_tc .and. elec_num.gt.2 .and. three_e_3_idx_term) then
!!!!! 3-e part
!! same-spin/same-spin
do j = 1, na
jj = occ(j,ispin)
do m = j+1, na
mm = occ(m,ispin)
hthree -= three_e_diag_parrallel_spin_prov(mm,jj,iorb)
enddo
enddo
enddo
!! same-spin/oposite-spin
do j = 1, na
jj = occ(j,ispin)
do m = 1, nb
mm = occ(m,other_spin)
direct_int = three_e_3_idx_direct_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR
exchange_int = three_e_3_idx_exch12_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR
hthree -= (direct_int - exchange_int)
enddo
enddo
!! oposite-spin/opposite-spin
!! same-spin/oposite-spin
do j = 1, na
jj = occ(j,ispin)
do m = 1, nb
mm = occ(m,other_spin)
direct_int = three_e_3_idx_direct_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR
exchange_int = three_e_3_idx_exch12_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR
hthree -= (direct_int - exchange_int)
enddo
enddo
!! oposite-spin/opposite-spin
do j = 1, nb
jj = occ(j,other_spin)
do m = j+1, nb
mm = occ(m,other_spin)
direct_int = three_e_3_idx_direct_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR
exchange_int = three_e_3_idx_exch23_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR
hthree -= (direct_int - exchange_int)
enddo
jj = occ(j,other_spin)
do m = j+1, nb
mm = occ(m,other_spin)
direct_int = three_e_3_idx_direct_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR
exchange_int = three_e_3_idx_exch23_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR
hthree -= (direct_int - exchange_int)
enddo
enddo
endif
end
! ---
subroutine diag_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, det_in,htot)
implicit none
BEGIN_DOC
! Computes $\langle i|H|i \rangle$. WITHOUT ANY CONTRIBUTIONS FROM 3E TERMS
END_DOC
integer,intent(in) :: Nint
integer(bit_kind),intent(in) :: det_in(Nint,2)
double precision, intent(out) :: htot
double precision :: hmono,htwoe
implicit none
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: det_in(Nint,2)
double precision, intent(out) :: htot
double precision :: hmono, htwoe
integer(bit_kind) :: hole(Nint,2)
integer(bit_kind) :: particle(Nint,2)
integer :: i, nexc(2), ispin
@ -339,15 +363,15 @@ subroutine diag_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, det_in,htot)
nexc(2) = nexc(2) + popcnt(hole(i,2))
enddo
if (nexc(1)+nexc(2) == 0) then
if(nexc(1)+nexc(2) == 0) then
hmono = ref_tc_energy_1e
htwoe = ref_tc_energy_2e
htot = ref_tc_energy_tot
htot = ref_tc_energy_tot
return
endif
!call debug_det(det_in,Nint)
integer :: tmp(2)
integer :: tmp(2)
!DIR$ FORCEINLINE
call bitstring_to_list_ab(particle, occ_particle, tmp, Nint)
ASSERT (tmp(1) == nexc(1)) ! Number of particles alpha
@ -357,8 +381,8 @@ subroutine diag_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, det_in,htot)
ASSERT (tmp(1) == nexc(1)) ! Number of holes alpha
ASSERT (tmp(2) == nexc(2)) ! Number of holes beta
det_tmp = ref_bitmask
hmono = ref_tc_energy_1e
htwoe = ref_tc_energy_2e
do ispin=1,2

94
src/tc_bi_ortho/slater_tc_opt_double.irp.f
View File

@ -1,4 +1,6 @@
! ---
subroutine double_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot)
BEGIN_DOC
@ -29,55 +31,77 @@ subroutine double_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe,
hthree = 0.d0
htot = 0.d0
if(degree.ne.2)then
return
if(degree .ne. 2) then
return
endif
integer :: degree_i,degree_j
call get_excitation_degree(ref_bitmask,key_i,degree_i,N_int)
call get_excitation_degree(ref_bitmask,key_j,degree_j,N_int)
integer :: degree_i, degree_j
call get_excitation_degree(ref_bitmask, key_i, degree_i, N_int)
call get_excitation_degree(ref_bitmask, key_j, degree_j, N_int)
call get_double_excitation(key_i, key_j, exc, phase, Nint)
call decode_exc(exc, 2, h1, p1, h2, p2, s1, s2)
if(s1.ne.s2)then
! opposite spin two-body
htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)
if(three_body_h_tc.and.elec_num.gt.2)then
if(.not.double_normal_ord.and.three_e_5_idx_term)then
if(degree_i>degree_j)then
call three_comp_two_e_elem(key_j,h1,h2,p1,p2,s1,s2,hthree)
else
call three_comp_two_e_elem(key_i,h1,h2,p1,p2,s1,s2,hthree)
if(s1 .ne. s2) then
! opposite spin two-body
htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)
if(three_body_h_tc .and. (elec_num .gt. 2)) then
! add 3-e term
if(.not.double_normal_ord .and. three_e_5_idx_term) then
! 5-idx approx
if(degree_i > degree_j) then
call three_comp_two_e_elem(key_j,h1,h2,p1,p2,s1,s2,hthree)
else
call three_comp_two_e_elem(key_i,h1,h2,p1,p2,s1,s2,hthree)
endif
elseif(double_normal_ord) then
! noL a la Manu
htwoe += normal_two_body_bi_orth(p2,h2,p1,h1)
endif
elseif(double_normal_ord)then
htwoe += normal_two_body_bi_orth(p2,h2,p1,h1)
endif
endif
else
! same spin two-body
! direct terms
htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)
! exchange terms
htwoe -= mo_bi_ortho_tc_two_e(p1,p2,h2,h1)
if(three_body_h_tc.and.elec_num.gt.2)then
if(.not.double_normal_ord.and.three_e_5_idx_term)then
if(degree_i>degree_j)then
call three_comp_two_e_elem(key_j,h1,h2,p1,p2,s1,s2,hthree)
else
call three_comp_two_e_elem(key_i,h1,h2,p1,p2,s1,s2,hthree)
endif
elseif(double_normal_ord)then
htwoe -= normal_two_body_bi_orth(h2,p1,h1,p2)
htwoe += normal_two_body_bi_orth(h1,p1,h2,p2)
! same spin two-body
! direct terms
htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)
! exchange terms
htwoe -= mo_bi_ortho_tc_two_e(p1,p2,h2,h1)
if(three_body_h_tc .and. (elec_num .gt. 2)) then
! add 3-e term
if(.not.double_normal_ord.and.three_e_5_idx_term)then
! 5-idx approx
if(degree_i > degree_j) then
call three_comp_two_e_elem(key_j,h1,h2,p1,p2,s1,s2,hthree)
else
call three_comp_two_e_elem(key_i,h1,h2,p1,p2,s1,s2,hthree)
endif
elseif(double_normal_ord) then
! noL a la Manu
htwoe -= normal_two_body_bi_orth(h2,p1,h1,p2)
htwoe += normal_two_body_bi_orth(h1,p1,h2,p2)
endif
endif
endif
endif
hthree *= phase
htwoe *= phase
htot = htwoe + hthree
htot = htwoe + hthree
end
! ---
subroutine three_comp_two_e_elem(key_i,h1,h2,p1,p2,s1,s2,hthree)
implicit none

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

@ -1,12 +1,16 @@
! ---
subroutine single_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot)
subroutine single_htilde_mu_mat_fock_bi_ortho (Nint, key_j, key_i, hmono, htwoe, hthree, htot)
BEGIN_DOC
!
! <key_j |H_tilde | key_i> for single excitation ONLY FOR ONE- AND TWO-BODY TERMS
!!
!! WARNING !!
!
! Non hermitian !!
!
END_DOC
use bitmasks
@ -31,93 +35,105 @@ subroutine single_htilde_mu_mat_fock_bi_ortho (Nint, key_j, key_i, hmono, htwoe
htwoe = 0.d0
hthree = 0.d0
htot = 0.d0
call get_excitation_degree(key_i, key_j, degree, Nint)
if(degree.ne.1)then
return
if(degree .ne. 1) then
return
endif
call bitstring_to_list_ab(key_i, occ, Ne, Nint)
call get_single_excitation(key_i, key_j, exc, phase, Nint)
call decode_exc(exc,1,h1,p1,h2,p2,s1,s2)
call get_single_excitation_from_fock_tc(key_i,key_j,h1,p1,s1,phase,hmono,htwoe,hthree,htot)
end
subroutine get_single_excitation_from_fock_tc(key_i,key_j,h,p,spin,phase,hmono,htwoe,hthree,htot)
use bitmasks
implicit none
integer,intent(in) :: h,p,spin
double precision, intent(in) :: phase
integer(bit_kind), intent(in) :: key_i(N_int,2), key_j(N_int,2)
double precision, intent(out) :: hmono,htwoe,hthree,htot
integer(bit_kind) :: differences(N_int,2)
integer(bit_kind) :: hole(N_int,2)
integer(bit_kind) :: partcl(N_int,2)
integer :: occ_hole(N_int*bit_kind_size,2)
integer :: occ_partcl(N_int*bit_kind_size,2)
integer :: n_occ_ab_hole(2),n_occ_ab_partcl(2)
integer :: i0,i
double precision :: buffer_c(mo_num),buffer_x(mo_num)
do i=1, mo_num
buffer_c(i) = tc_2e_3idx_coulomb_integrals(i,p,h)
buffer_x(i) = tc_2e_3idx_exchange_integrals(i,p,h)
enddo
do i = 1, N_int
differences(i,1) = xor(key_i(i,1),ref_closed_shell_bitmask(i,1))
differences(i,2) = xor(key_i(i,2),ref_closed_shell_bitmask(i,2))
hole(i,1) = iand(differences(i,1),ref_closed_shell_bitmask(i,1))
hole(i,2) = iand(differences(i,2),ref_closed_shell_bitmask(i,2))
partcl(i,1) = iand(differences(i,1),key_i(i,1))
partcl(i,2) = iand(differences(i,2),key_i(i,2))
enddo
call bitstring_to_list_ab(hole, occ_hole, n_occ_ab_hole, N_int)
call bitstring_to_list_ab(partcl, occ_partcl, n_occ_ab_partcl, N_int)
hmono = mo_bi_ortho_tc_one_e(p,h)
htwoe = fock_op_2_e_tc_closed_shell(p,h)
! holes :: direct terms
do i0 = 1, n_occ_ab_hole(1)
i = occ_hole(i0,1)
htwoe -= buffer_c(i)
enddo
do i0 = 1, n_occ_ab_hole(2)
i = occ_hole(i0,2)
htwoe -= buffer_c(i)
enddo
! holes :: exchange terms
do i0 = 1, n_occ_ab_hole(spin)
i = occ_hole(i0,spin)
htwoe += buffer_x(i)
enddo
! particles :: direct terms
do i0 = 1, n_occ_ab_partcl(1)
i = occ_partcl(i0,1)
htwoe += buffer_c(i)
enddo
do i0 = 1, n_occ_ab_partcl(2)
i = occ_partcl(i0,2)
htwoe += buffer_c(i)
enddo
! particles :: exchange terms
do i0 = 1, n_occ_ab_partcl(spin)
i = occ_partcl(i0,spin)
htwoe -= buffer_x(i)
enddo
hthree = 0.d0
if (three_body_h_tc.and.elec_num.gt.2.and.three_e_4_idx_term)then
call three_comp_fock_elem(key_i,h,p,spin,hthree)
endif
htwoe = htwoe * phase
hmono = hmono * phase
hthree = hthree * phase
htot = htwoe + hmono + hthree
call decode_exc(exc, 1, h1, p1, h2, p2, s1, s2)
call get_single_excitation_from_fock_tc(key_i, key_j, h1, p1, s1, phase, hmono, htwoe, hthree, htot)
end
! ---
subroutine get_single_excitation_from_fock_tc(key_i, key_j, h, p, spin, phase, hmono, htwoe, hthree, htot)
use bitmasks
implicit none
integer, intent(in) :: h, p, spin
double precision, intent(in) :: phase
integer(bit_kind), intent(in) :: key_i(N_int,2), key_j(N_int,2)
double precision, intent(out) :: hmono, htwoe, hthree, htot
integer(bit_kind) :: differences(N_int,2)
integer(bit_kind) :: hole(N_int,2)
integer(bit_kind) :: partcl(N_int,2)
integer :: occ_hole(N_int*bit_kind_size,2)
integer :: occ_partcl(N_int*bit_kind_size,2)
integer :: n_occ_ab_hole(2),n_occ_ab_partcl(2)
integer :: i0,i
double precision :: buffer_c(mo_num),buffer_x(mo_num)
do i = 1, mo_num
buffer_c(i) = tc_2e_3idx_coulomb_integrals (i,p,h)
buffer_x(i) = tc_2e_3idx_exchange_integrals(i,p,h)
enddo
do i = 1, N_int
differences(i,1) = xor(key_i(i,1), ref_closed_shell_bitmask(i,1))
differences(i,2) = xor(key_i(i,2), ref_closed_shell_bitmask(i,2))
hole (i,1) = iand(differences(i,1), ref_closed_shell_bitmask(i,1))
hole (i,2) = iand(differences(i,2), ref_closed_shell_bitmask(i,2))
partcl (i,1) = iand(differences(i,1), key_i(i,1))
partcl (i,2) = iand(differences(i,2), key_i(i,2))
enddo
call bitstring_to_list_ab(hole, occ_hole, n_occ_ab_hole, N_int)
call bitstring_to_list_ab(partcl, occ_partcl, n_occ_ab_partcl, N_int)
hmono = mo_bi_ortho_tc_one_e(p,h)
htwoe = fock_op_2_e_tc_closed_shell(p,h)
! holes :: direct terms
do i0 = 1, n_occ_ab_hole(1)
i = occ_hole(i0,1)
htwoe -= buffer_c(i)
enddo
do i0 = 1, n_occ_ab_hole(2)
i = occ_hole(i0,2)
htwoe -= buffer_c(i)
enddo
! holes :: exchange terms
do i0 = 1, n_occ_ab_hole(spin)
i = occ_hole(i0,spin)
htwoe += buffer_x(i)
enddo
! particles :: direct terms
do i0 = 1, n_occ_ab_partcl(1)
i = occ_partcl(i0,1)
htwoe += buffer_c(i)
enddo
do i0 = 1, n_occ_ab_partcl(2)
i = occ_partcl(i0,2)
htwoe += buffer_c(i)
enddo
! particles :: exchange terms
do i0 = 1, n_occ_ab_partcl(spin)
i = occ_partcl(i0,spin)
htwoe -= buffer_x(i)
enddo
hthree = 0.d0
if (three_body_h_tc .and. elec_num.gt.2 .and. three_e_4_idx_term) then
call three_comp_fock_elem(key_i, h, p, spin, hthree)
endif
htwoe = htwoe * phase
hmono = hmono * phase
hthree = hthree * phase
htot = htwoe + hmono + hthree
end
! ---
subroutine three_comp_fock_elem(key_i,h_fock,p_fock,ispin_fock,hthree)
implicit none
integer,intent(in) :: h_fock,p_fock,ispin_fock

89
src/tc_bi_ortho/slater_tc_slow.irp.f
View File

@ -81,8 +81,14 @@ subroutine htilde_mu_mat_bi_ortho_slow(key_j, key_i, Nint, hmono, htwoe, hthree,
endif
htot = hmono + htwoe + hthree
if(degree==0) then
htot += nuclear_repulsion
if(noL_standard) then
PROVIDE noL_0e
htot += noL_0e
endif
endif
end
@ -92,7 +98,9 @@ end
subroutine diag_htilde_mu_mat_bi_ortho_slow(Nint, key_i, hmono, htwoe, htot)
BEGIN_DOC
! diagonal element of htilde ONLY FOR ONE- AND TWO-BODY TERMS
!
! diagonal element of htilde ONLY FOR ONE- AND TWO-BODY TERMS
!
END_DOC
use bitmasks
@ -108,78 +116,53 @@ subroutine diag_htilde_mu_mat_bi_ortho_slow(Nint, key_i, hmono, htwoe, htot)
PROVIDE mo_bi_ortho_tc_two_e
! PROVIDE mo_two_e_integrals_tc_int_in_map mo_bi_ortho_tc_two_e
!
! PROVIDE mo_integrals_erf_map core_energy nuclear_repulsion core_bitmask
! PROVIDE core_fock_operator
!
! PROVIDE j1b_gauss
hmono = 0.d0
htwoe = 0.d0
htot = 0.d0
! if(core_tc_op)then
! print*,'core_tc_op not already taken into account for bi ortho'
! print*,'stopping ...'
! stop
! do i = 1, Nint
! key_i_core(i,1) = xor(key_i(i,1),core_bitmask(i,1))
! key_i_core(i,2) = xor(key_i(i,2),core_bitmask(i,2))
! enddo
! call bitstring_to_list_ab(key_i_core, occ, Ne, Nint)
! hmono = core_energy - nuclear_repulsion
! else
call bitstring_to_list_ab(key_i, occ, Ne, Nint)
hmono = 0.d0
! endif
htwoe= 0.d0
htot = 0.d0
call bitstring_to_list_ab(key_i, occ, Ne, Nint)
do ispin = 1, 2
do i = 1, Ne(ispin) !
ii = occ(i,ispin)
hmono += mo_bi_ortho_tc_one_e(ii,ii)
! if(core_tc_op)then
! print*,'core_tc_op not already taken into account for bi ortho'
! print*,'stopping ...'
! stop
! hmono += core_fock_operator(ii,ii) ! add the usual Coulomb - Exchange from the core
! endif
enddo
do i = 1, Ne(ispin)
ii = occ(i,ispin)
hmono += mo_bi_ortho_tc_one_e(ii,ii)
enddo
enddo
! alpha/beta two-body
ispin = 1
jspin = 2
do i = 1, Ne(ispin) ! electron 1 (so it can be associated to mu(r1))
! alpha/beta two-body
ispin = 1
jspin = 2
do i = 1, Ne(ispin) ! electron 1 (so it can be associated to mu(r1))
ii = occ(i,ispin)
do j = 1, Ne(jspin) ! electron 2
jj = occ(j,jspin)
htwoe += mo_bi_ortho_tc_two_e(jj,ii,jj,ii)
jj = occ(j,jspin)
htwoe += mo_bi_ortho_tc_two_e(jj,ii,jj,ii)
enddo
enddo
enddo
! alpha/alpha two-body
do i = 1, Ne(ispin)
! alpha/alpha two-body
do i = 1, Ne(ispin)
ii = occ(i,ispin)
do j = i+1, Ne(ispin)
jj = occ(j,ispin)
htwoe += mo_bi_ortho_tc_two_e(ii,jj,ii,jj) - mo_bi_ortho_tc_two_e(ii,jj,jj,ii)
jj = occ(j,ispin)
htwoe += mo_bi_ortho_tc_two_e(ii,jj,ii,jj) - mo_bi_ortho_tc_two_e(ii,jj,jj,ii)
enddo
enddo
enddo
! beta/beta two-body
do i = 1, Ne(jspin)
! beta/beta two-body
do i = 1, Ne(jspin)
ii = occ(i,jspin)
do j = i+1, Ne(jspin)
jj = occ(j,jspin)
htwoe += mo_bi_ortho_tc_two_e(ii,jj,ii,jj) - mo_bi_ortho_tc_two_e(ii,jj,jj,ii)
jj = occ(j,jspin)
htwoe += mo_bi_ortho_tc_two_e(ii,jj,ii,jj) - mo_bi_ortho_tc_two_e(ii,jj,jj,ii)
enddo
enddo
enddo
htot = hmono + htwoe
end
! ---
subroutine double_htilde_mu_mat_bi_ortho_slow(Nint, key_j, key_i, hmono, htwoe, htot)

33
src/tc_bi_ortho/tc_hmat.irp.f
View File

@ -1,10 +1,14 @@
BEGIN_PROVIDER [double precision, htilde_matrix_elmt_bi_ortho, (N_det,N_det)]
! ---
BEGIN_PROVIDER [double precision, htilde_matrix_elmt_bi_ortho, (N_det,N_det)]
BEGIN_DOC
!
! htilde_matrix_elmt_bi_ortho(j,i) = <J| H^tilde |I>
!
! WARNING !!!!!!!!! IT IS NOT HERMITIAN !!!!!!!!!
!
END_DOC
implicit none
@ -17,28 +21,33 @@
j = 1
call htilde_mu_mat_opt_bi_ortho_tot(psi_det(1,1,j), psi_det(1,1,i), N_int, htot)
!$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,j, htot) &
!$OMP SHARED (N_det, psi_det, N_int,htilde_matrix_elmt_bi_ortho)
do i = 1, N_det
do j = 1, N_det
! < J |Htilde | I >
call htilde_mu_mat_opt_bi_ortho_tot(psi_det(1,1,j), psi_det(1,1,i), N_int, htot)
!$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,j, htot) &
!$OMP SHARED (N_det, psi_det, N_int, htilde_matrix_elmt_bi_ortho)
do i = 1, N_det
do j = 1, N_det
! < J |Htilde | I >
call htilde_mu_mat_opt_bi_ortho_tot(psi_det(1,1,j), psi_det(1,1,i), N_int, htot)
htilde_matrix_elmt_bi_ortho(j,i) = htot
enddo
htilde_matrix_elmt_bi_ortho(j,i) = htot
enddo
!$OMP END PARALLEL DO
enddo
!$OMP END PARALLEL DO
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, htilde_matrix_elmt_bi_ortho_tranp, (N_det,N_det)]
implicit none
integer ::i,j
implicit none
integer ::i,j
do i = 1, N_det
do j = 1, N_det
htilde_matrix_elmt_bi_ortho_tranp(j,i) = htilde_matrix_elmt_bi_ortho(i,j)
enddo
enddo
END_PROVIDER
! ---

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

@ -11,14 +11,17 @@ program tc_bi_ortho
print *, 'Hello world'
my_grid_becke = .True.
my_grid_becke = .True.
PROVIDE tc_grid1_a tc_grid1_r
my_n_pt_r_grid = tc_grid1_r
my_n_pt_a_grid = tc_grid1_a
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
read_wf = .True.
touch read_wf
call write_int(6, my_n_pt_r_grid, 'radial external grid over')
call write_int(6, my_n_pt_a_grid, 'angular external grid over')
! read_wf = .True.
! touch read_wf
! call test_h_u0
! call test_slater_tc_opt
@ -27,10 +30,18 @@ program tc_bi_ortho
! call timing_single
! call timing_double
call test_no()
!call test_no_aba()
!call test_no_aab()
!call test_no_aaa()
!call test_no()
!call test_no_v0()
call test_noL_0e()
call test_noL_1e()
!call test_noL_2e_v0()
call test_noL_2e()
end
subroutine test_h_u0
@ -268,29 +279,30 @@ end
! ---
subroutine test_no()
subroutine test_no_v0()
implicit none
integer :: i, j, k, l
double precision :: accu, contrib, new, ref, thr
double precision :: accu, contrib, new, ref, thr, norm
print*, ' testing normal_two_body_bi_orth ...'
print*, ' test_no_v0 ...'
thr = 1d-8
PROVIDE normal_two_body_bi_orth_old
PROVIDE normal_two_body_bi_orth_v0
PROVIDE normal_two_body_bi_orth
accu = 0.d0
norm = 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)
new = normal_two_body_bi_orth (l,k,j,i)
ref = normal_two_body_bi_orth_v0(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
@ -298,13 +310,62 @@ subroutine test_no()
stop
endif
accu += contrib
norm += dabs(ref)
enddo
enddo
enddo
enddo
print*, ' accu on normal_two_body_bi_orth = ', accu / dble(mo_num)**4
return
print*, ' accu (%) = ', 100.d0*accu/norm
return
end
! ---
subroutine test_no()
implicit none
integer :: i, j, k, l
double precision :: accu, contrib, new, ref, thr, norm
print*, ' test_no ...'
thr = 1d-8
PROVIDE normal_two_body_bi_orth_old
PROVIDE normal_two_body_bi_orth
accu = 0.d0
norm = 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)
if(contrib .gt. thr) then
print*, ' problem on normal_two_body_bi_orth'
print*, l, k, j, i
print*, ref, new, contrib
stop
endif
accu += contrib
norm += dabs(ref)
enddo
enddo
enddo
enddo
print*, ' accu (%) = ', 100.d0*accu/norm
return
end
! ---
@ -313,7 +374,7 @@ subroutine test_no_aba()
implicit none
integer :: i, j, k, l
double precision :: accu, contrib, new, ref, thr
double precision :: accu, contrib, new, ref, thr, norm
print*, ' testing no_aba_contraction ...'
@ -323,6 +384,7 @@ subroutine test_no_aba()
PROVIDE no_aba_contraction
accu = 0.d0
norm = 0.d0
do i = 1, mo_num
do j = 1, mo_num
do k = 1, mo_num
@ -331,7 +393,6 @@ subroutine test_no_aba()
new = no_aba_contraction (l,k,j,i)
ref = no_aba_contraction_v0(l,k,j,i)
contrib = dabs(new - ref)
accu += contrib
if(contrib .gt. thr) then
print*, ' problem on no_aba_contraction'
print*, l, k, j, i
@ -339,13 +400,16 @@ subroutine test_no_aba()
stop
endif
accu += contrib
norm += dabs(ref)
enddo
enddo
enddo
enddo
print*, ' accu on no_aba_contraction = ', accu / dble(mo_num)**4
return
print*, ' accu (%) = ', 100.d0*accu/norm
return
end
! ---
@ -355,7 +419,7 @@ subroutine test_no_aab()
implicit none
integer :: i, j, k, l
double precision :: accu, contrib, new, ref, thr
double precision :: accu, contrib, new, ref, thr, norm
print*, ' testing no_aab_contraction ...'
@ -365,6 +429,7 @@ subroutine test_no_aab()
PROVIDE no_aab_contraction
accu = 0.d0
norm = 0.d0
do i = 1, mo_num
do j = 1, mo_num
do k = 1, mo_num
@ -373,7 +438,6 @@ subroutine test_no_aab()
new = no_aab_contraction (l,k,j,i)
ref = no_aab_contraction_v0(l,k,j,i)
contrib = dabs(new - ref)
accu += contrib
if(contrib .gt. thr) then
print*, ' problem on no_aab_contraction'
print*, l, k, j, i
@ -381,13 +445,16 @@ subroutine test_no_aab()
stop
endif
accu += contrib
norm += dabs(ref)
enddo
enddo
enddo
enddo
print*, ' accu on no_aab_contraction = ', accu / dble(mo_num)**4
return
print*, ' accu (%) = ', 100.d0*accu/norm
return
end
! ---
@ -396,7 +463,7 @@ subroutine test_no_aaa()
implicit none
integer :: i, j, k, l
double precision :: accu, contrib, new, ref, thr
double precision :: accu, contrib, new, ref, thr, norm
print*, ' testing no_aaa_contraction ...'
@ -406,6 +473,7 @@ subroutine test_no_aaa()
PROVIDE no_aaa_contraction
accu = 0.d0
norm = 0.d0
do i = 1, mo_num
do j = 1, mo_num
do k = 1, mo_num
@ -414,7 +482,6 @@ subroutine test_no_aaa()
new = no_aaa_contraction (l,k,j,i)
ref = no_aaa_contraction_v0(l,k,j,i)
contrib = dabs(new - ref)
accu += contrib
if(contrib .gt. thr) then
print*, ' problem on no_aaa_contraction'
print*, l, k, j, i
@ -422,13 +489,179 @@ subroutine test_no_aaa()
stop
endif
accu += contrib
norm += dabs(ref)
enddo
enddo
enddo
enddo
print*, ' accu on no_aaa_contraction = ', accu / dble(mo_num)**4
return
print*, ' accu (%) = ', 100.d0*accu/norm
return
end
! ---
subroutine test_noL_0e()
implicit none
double precision :: accu, norm, thr
thr = 1d-8
print*, ' testing noL_0e ...'
PROVIDE noL_0e_naive
PROVIDE noL_0e_v0
PROVIDE noL_0e
accu = dabs(noL_0e_naive - noL_0e)
norm = dabs(noL_0e_naive)
if(accu .gt. thr) then
print*, ' problem on noL_0e'
print*, noL_0e_naive, noL_0e
stop
endif
print*, ' accu (%) = ', 100.d0*accu/norm
return
end
! ---
subroutine test_noL_1e()
implicit none
integer :: i, j
double precision :: accu, contrib, new, ref, thr, norm
print*, ' testing noL_1e ...'
PROVIDE noL_1e_naive
PROVIDE noL_1e
PROVIDE energy_1e_noL_HF
thr = 1d-8
accu = 0.d0
norm = 0.d0
do i = 1, mo_num
do j = 1, mo_num
new = noL_1e (j,i)
ref = noL_1e_naive(j,i)
contrib = dabs(new - ref)
if(contrib .gt. thr) then
print*, ' problem on noL_1e'
print*, j, i
print*, ref, new, contrib
stop
endif
accu += contrib
norm += dabs(ref)
enddo
enddo
print*, ' accu (%) = ', 100.d0*accu/norm
return
end
! ---
subroutine test_noL_2e_v0()
implicit none
integer :: i, j, k, l
double precision :: accu, contrib, new, ref, thr, norm
print*, ' testing noL_2e_v0 ...'
PROVIDE noL_2e_naive
PROVIDE noL_2e_v0
PROVIDE energy_2e_noL_HF
thr = 1d-8
accu = 0.d0
norm = 0.d0
do i = 1, mo_num
do j = 1, mo_num
do k = 1, mo_num
do l = 1, mo_num
new = noL_2e_v0 (l,k,j,i)
ref = noL_2e_naive(l,k,j,i)
contrib = dabs(new - ref)
if(contrib .gt. thr) then
print*, ' problem on noL_2e_v0'
print*, l, k, j, i
print*, ref, new, contrib
stop
endif
accu += contrib
norm += dabs(ref)
enddo
enddo
enddo
enddo
print*, ' accu (%) = ', 100.d0*accu/norm
return
end
! ---
subroutine test_noL_2e()
implicit none
integer :: i, j, k, l
double precision :: accu, contrib, new, ref, thr, norm
print*, ' testing noL_2e ...'
PROVIDE noL_2e_naive
PROVIDE noL_2e
PROVIDE energy_2e_noL_HF
thr = 1d-8
accu = 0.d0
norm = 0.d0
do i = 1, mo_num
do j = 1, mo_num
do k = 1, mo_num
do l = 1, mo_num
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 noL_2e'
print*, l, k, j, i
print*, ref, new, contrib
stop
endif
accu += contrib
norm += dabs(ref)
enddo
enddo
enddo
enddo
print*, ' accu (%) = ', 100.d0*accu/norm
return
end
! ---

21
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 (to be used with three_body_h_tc |false|)
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)
@ -110,13 +116,13 @@ default: False
type: Threshold
doc: Threshold on the convergence of the Hartree Fock energy.
interface: ezfio,provider,ocaml
default: 1.e-10
default: 1.e-8
[n_it_tcscf_max]
type: Strictly_positive_int
doc: Maximum number of SCF iterations
interface: ezfio,provider,ocaml
default: 100
default: 50
[selection_tc]
type: integer
@ -280,4 +286,15 @@ doc: size of radial grid over r1
interface: ezfio,provider,ocaml
default: 30
[tc_grid2_a]
type: integer
doc: size of angular grid over r2
interface: ezfio,provider,ocaml
default: 194
[tc_grid2_r]
type: integer
doc: size of radial grid over r2
interface: ezfio,provider,ocaml
default: 50

280
src/tc_scf/fock_3e_bi_ortho_cs.irp.f Normal file
View File

@ -0,0 +1,280 @@
! ---
BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_cs, (mo_num, mo_num)]
implicit none
integer :: a, b, i, j, ipoint
double precision :: ti, tf
double precision :: loc_1, loc_2, loc_3
double precision, allocatable :: Okappa(:), Jkappa(:,:)
double precision, allocatable :: tmp_omp_d1(:), tmp_omp_d2(:,:)
double precision, allocatable :: tmp_1(:,:), tmp_2(:,:,:,:)
double precision, allocatable :: tmp_3(:,:,:), tmp_4(:,:,:)
PROVIDE mo_l_coef mo_r_coef
!print *, ' PROVIDING fock_3e_uhf_mo_cs ...'
!call wall_time(ti)
! ---
allocate(Jkappa(n_points_final_grid,3), Okappa(n_points_final_grid))
Jkappa = 0.d0
Okappa = 0.d0
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, tmp_omp_d1, tmp_omp_d2) &
!$OMP SHARED (n_points_final_grid, elec_beta_num, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP int2_grad1_u12_bimo_t, Okappa, Jkappa)
allocate(tmp_omp_d2(n_points_final_grid,3), tmp_omp_d1(n_points_final_grid))
tmp_omp_d2 = 0.d0
tmp_omp_d1 = 0.d0
!$OMP DO
do i = 1, elec_beta_num
do ipoint = 1, n_points_final_grid
tmp_omp_d2(ipoint,1) += int2_grad1_u12_bimo_t(ipoint,1,i,i)
tmp_omp_d2(ipoint,2) += int2_grad1_u12_bimo_t(ipoint,2,i,i)
tmp_omp_d2(ipoint,3) += int2_grad1_u12_bimo_t(ipoint,3,i,i)
tmp_omp_d1(ipoint) += mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
enddo
enddo
!$OMP END DO NOWAIT
!$OMP CRITICAL
do ipoint = 1, n_points_final_grid
Jkappa(ipoint,1) += tmp_omp_d2(ipoint,1)
Jkappa(ipoint,2) += tmp_omp_d2(ipoint,2)
Jkappa(ipoint,3) += tmp_omp_d2(ipoint,3)
Okappa(ipoint) += tmp_omp_d1(ipoint)
enddo
!$OMP END CRITICAL
deallocate(tmp_omp_d2, tmp_omp_d1)
!$OMP END PARALLEL
! ---
allocate(tmp_1(n_points_final_grid,4))
do ipoint = 1, n_points_final_grid
loc_1 = 2.d0 * Okappa(ipoint)
tmp_1(ipoint,1) = loc_1 * Jkappa(ipoint,1)
tmp_1(ipoint,2) = loc_1 * Jkappa(ipoint,2)
tmp_1(ipoint,3) = loc_1 * Jkappa(ipoint,3)
tmp_1(ipoint,4) = Okappa(ipoint)
enddo
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, loc_1, tmp_omp_d2) &
!$OMP SHARED (n_points_final_grid, elec_beta_num, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP int2_grad1_u12_bimo_t, tmp_1)
allocate(tmp_omp_d2(n_points_final_grid,3))
tmp_omp_d2 = 0.d0
!$OMP DO COLLAPSE(2)
do i = 1, elec_beta_num
do j = 1, elec_beta_num
do ipoint = 1, n_points_final_grid
loc_1 = mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
tmp_omp_d2(ipoint,1) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,1,i,j)
tmp_omp_d2(ipoint,2) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,2,i,j)
tmp_omp_d2(ipoint,3) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,3,i,j)
enddo
enddo
enddo
!$OMP END DO NOWAIT
!$OMP CRITICAL
do ipoint = 1, n_points_final_grid
tmp_1(ipoint,1) += tmp_omp_d2(ipoint,1)
tmp_1(ipoint,2) += tmp_omp_d2(ipoint,2)
tmp_1(ipoint,3) += tmp_omp_d2(ipoint,3)
enddo
!$OMP END CRITICAL
deallocate(tmp_omp_d2)
!$OMP END PARALLEL
! ---
allocate(tmp_2(n_points_final_grid,4,mo_num,mo_num))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, a, b) &
!$OMP SHARED (n_points_final_grid, mo_num, &
!$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 tmp_2)
!$OMP DO COLLAPSE(2)
do a = 1, mo_num
do b = 1, mo_num
do ipoint = 1, n_points_final_grid
tmp_2(ipoint,1,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,b,a)
tmp_2(ipoint,2,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,b,a)
tmp_2(ipoint,3,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,b,a)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, a, b, i) &
!$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, &
!$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
!$OMP tmp_2)
!$OMP DO COLLAPSE(2)
do a = 1, mo_num
do b = 1, mo_num
tmp_2(:,4,b,a) = 0.d0
do i = 1, elec_beta_num
do ipoint = 1, n_points_final_grid
tmp_2(ipoint,4,b,a) -= final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,a) &
+ int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,a) &
+ int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,a) )
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
! ---
call dgemv( 'T', 4*n_points_final_grid, mo_num*mo_num, -2.d0 &
, tmp_2(1,1,1,1), size(tmp_2, 1) * size(tmp_2, 2) &
, tmp_1(1,1), 1 &
, 0.d0, fock_3e_uhf_mo_cs(1,1), 1)
deallocate(tmp_1, tmp_2)
! ---
allocate(tmp_3(n_points_final_grid,5,mo_num), tmp_4(n_points_final_grid,5,mo_num))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, b, loc_1, loc_2) &
!$OMP SHARED (n_points_final_grid, mo_num, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP final_weight_at_r_vector, Jkappa, tmp_3, tmp_4)
!$OMP DO
do b = 1, mo_num
tmp_3(:,:,b) = 0.d0
tmp_4(:,:,b) = 0.d0
do ipoint = 1, n_points_final_grid
tmp_3(ipoint,1,b) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,b)
tmp_4(ipoint,1,b) = -2.d0 * mos_r_in_r_array_transp(ipoint,b) * ( Jkappa(ipoint,1) * Jkappa(ipoint,1) &
+ Jkappa(ipoint,2) * Jkappa(ipoint,2) &
+ Jkappa(ipoint,3) * Jkappa(ipoint,3) )
tmp_4(ipoint,5,b) = mos_r_in_r_array_transp(ipoint,b)
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, b, i, loc_1, loc_2) &
!$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, &
!$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP Jkappa, tmp_3, tmp_4)
!$OMP DO
do b = 1, mo_num
do i = 1, elec_beta_num
do ipoint = 1, n_points_final_grid
loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
loc_2 = mos_r_in_r_array_transp(ipoint,i)
tmp_3(ipoint,2,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,1,b,i)
tmp_3(ipoint,3,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,2,b,i)
tmp_3(ipoint,4,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,3,b,i)
tmp_3(ipoint,5,b) += 2.d0 * loc_1 * ( Jkappa(ipoint,1) * int2_grad1_u12_bimo_t(ipoint,1,b,i) &
+ Jkappa(ipoint,2) * int2_grad1_u12_bimo_t(ipoint,2,b,i) &
+ Jkappa(ipoint,3) * int2_grad1_u12_bimo_t(ipoint,3,b,i) )
tmp_4(ipoint,2,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,1,i,b)
tmp_4(ipoint,3,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,2,i,b)
tmp_4(ipoint,4,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,3,i,b)
tmp_4(ipoint,1,b) += 2.d0 * loc_2 * ( Jkappa(ipoint,1) * int2_grad1_u12_bimo_t(ipoint,1,i,b) &
+ Jkappa(ipoint,2) * int2_grad1_u12_bimo_t(ipoint,2,i,b) &
+ Jkappa(ipoint,3) * int2_grad1_u12_bimo_t(ipoint,3,i,b) )
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, b, i, j, loc_1, loc_2, loc_3) &
!$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, &
!$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP tmp_3, tmp_4)
!$OMP DO
do b = 1, mo_num
do i = 1, elec_beta_num
do j = 1, elec_beta_num
do ipoint = 1, n_points_final_grid
loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,j)
loc_2 = mos_r_in_r_array_transp(ipoint,b)
loc_3 = mos_r_in_r_array_transp(ipoint,i)
tmp_3(ipoint,5,b) -= loc_1 * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,j) &
+ int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,j) &
+ int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,j) )
tmp_4(ipoint,1,b) += ( loc_2 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
+ int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
+ int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) ) &
- loc_3 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,b) &
+ int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,b) &
+ int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,b) ) )
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
! ---
call dgemm( 'T', 'N', mo_num, mo_num, 5*n_points_final_grid, 1.d0 &
, tmp_3(1,1,1), 5*n_points_final_grid &
, tmp_4(1,1,1), 5*n_points_final_grid &
, 1.d0, fock_3e_uhf_mo_cs(1,1), mo_num)
deallocate(tmp_3, tmp_4)
deallocate(Jkappa, Okappa)
! ---
!call wall_time(tf)
!print *, ' total Wall time for fock_3e_uhf_mo_cs =', tf - ti
END_PROVIDER
! ---

536
src/tc_scf/fock_3e_bi_ortho_os.irp.f Normal file
View File

@ -0,0 +1,536 @@
! ---
BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a_os, (mo_num, mo_num)]
&BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b_os, (mo_num, mo_num)]
BEGIN_DOC
!
! Open Shell part of the Fock matrix from three-electron terms
!
! WARNING :: non hermitian if bi-ortho MOS used
!
END_DOC
implicit none
integer :: a, b, i, j, ipoint
double precision :: loc_1, loc_2, loc_3, loc_4
double precision :: ti, tf
double precision, allocatable :: Okappa(:), Jkappa(:,:), Obarkappa(:), Jbarkappa(:,:)
double precision, allocatable :: tmp_omp_d1(:), tmp_omp_d2(:,:)
double precision, allocatable :: tmp_1(:,:), tmp_2(:,:,:,:)
double precision, allocatable :: tmp_3(:,:,:), tmp_4(:,:,:)
PROVIDE mo_l_coef mo_r_coef
!print *, ' Providing fock_3e_uhf_mo_a_os and fock_3e_uhf_mo_b_os ...'
!call wall_time(ti)
! ---
allocate(Jkappa(n_points_final_grid,3), Okappa(n_points_final_grid))
allocate(Jbarkappa(n_points_final_grid,3), Obarkappa(n_points_final_grid))
Jkappa = 0.d0
Okappa = 0.d0
Jbarkappa = 0.d0
Obarkappa = 0.d0
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, tmp_omp_d1, tmp_omp_d2) &
!$OMP SHARED (n_points_final_grid, elec_beta_num, elec_alpha_num, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP int2_grad1_u12_bimo_t, Okappa, Jkappa, Obarkappa, Jbarkappa)
allocate(tmp_omp_d2(n_points_final_grid,3), tmp_omp_d1(n_points_final_grid))
tmp_omp_d2 = 0.d0
tmp_omp_d1 = 0.d0
!$OMP DO
do i = 1, elec_beta_num
do ipoint = 1, n_points_final_grid
tmp_omp_d2(ipoint,1) += int2_grad1_u12_bimo_t(ipoint,1,i,i)
tmp_omp_d2(ipoint,2) += int2_grad1_u12_bimo_t(ipoint,2,i,i)
tmp_omp_d2(ipoint,3) += int2_grad1_u12_bimo_t(ipoint,3,i,i)
tmp_omp_d1(ipoint) += mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
enddo
enddo
!$OMP END DO NOWAIT
!$OMP CRITICAL
do ipoint = 1, n_points_final_grid
Jkappa(ipoint,1) += tmp_omp_d2(ipoint,1)
Jkappa(ipoint,2) += tmp_omp_d2(ipoint,2)
Jkappa(ipoint,3) += tmp_omp_d2(ipoint,3)
Okappa(ipoint) += tmp_omp_d1(ipoint)
enddo
!$OMP END CRITICAL
tmp_omp_d2 = 0.d0
tmp_omp_d1 = 0.d0
!$OMP DO
do i = elec_beta_num+1, elec_alpha_num
do ipoint = 1, n_points_final_grid
tmp_omp_d2(ipoint,1) += int2_grad1_u12_bimo_t(ipoint,1,i,i)
tmp_omp_d2(ipoint,2) += int2_grad1_u12_bimo_t(ipoint,2,i,i)
tmp_omp_d2(ipoint,3) += int2_grad1_u12_bimo_t(ipoint,3,i,i)
tmp_omp_d1(ipoint) += mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
enddo
enddo
!$OMP END DO NOWAIT
!$OMP CRITICAL
do ipoint = 1, n_points_final_grid
Jbarkappa(ipoint,1) += tmp_omp_d2(ipoint,1)
Jbarkappa(ipoint,2) += tmp_omp_d2(ipoint,2)
Jbarkappa(ipoint,3) += tmp_omp_d2(ipoint,3)
Obarkappa(ipoint) += tmp_omp_d1(ipoint)
enddo
!$OMP END CRITICAL
deallocate(tmp_omp_d2, tmp_omp_d1)
!$OMP END PARALLEL
! ---
allocate(tmp_1(n_points_final_grid,4))
do ipoint = 1, n_points_final_grid
loc_1 = -2.d0 * Okappa (ipoint)
loc_2 = -2.d0 * Obarkappa(ipoint)
loc_3 = Obarkappa(ipoint)
tmp_1(ipoint,1) = (loc_1 - loc_3) * Jbarkappa(ipoint,1) + loc_2 * Jkappa(ipoint,1)
tmp_1(ipoint,2) = (loc_1 - loc_3) * Jbarkappa(ipoint,2) + loc_2 * Jkappa(ipoint,2)
tmp_1(ipoint,3) = (loc_1 - loc_3) * Jbarkappa(ipoint,3) + loc_2 * Jkappa(ipoint,3)
tmp_1(ipoint,4) = Obarkappa(ipoint)
enddo
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, loc_1, loc_2, tmp_omp_d2) &
!$OMP SHARED (n_points_final_grid, elec_beta_num, elec_alpha_num, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP int2_grad1_u12_bimo_t, tmp_1)
allocate(tmp_omp_d2(n_points_final_grid,3))
tmp_omp_d2 = 0.d0
!$OMP DO COLLAPSE(2)
do i = 1, elec_beta_num
do j = elec_beta_num+1, elec_alpha_num
do ipoint = 1, n_points_final_grid
loc_1 = mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
loc_2 = mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
tmp_omp_d2(ipoint,1) += loc_1 * int2_grad1_u12_bimo_t(ipoint,1,i,j) + loc_2 * int2_grad1_u12_bimo_t(ipoint,1,j,i)
tmp_omp_d2(ipoint,2) += loc_1 * int2_grad1_u12_bimo_t(ipoint,2,i,j) + loc_2 * int2_grad1_u12_bimo_t(ipoint,2,j,i)
tmp_omp_d2(ipoint,3) += loc_1 * int2_grad1_u12_bimo_t(ipoint,3,i,j) + loc_2 * int2_grad1_u12_bimo_t(ipoint,3,j,i)
enddo
enddo
enddo
!$OMP END DO NOWAIT
!$OMP CRITICAL
do ipoint = 1, n_points_final_grid
tmp_1(ipoint,1) += tmp_omp_d2(ipoint,1)
tmp_1(ipoint,2) += tmp_omp_d2(ipoint,2)
tmp_1(ipoint,3) += tmp_omp_d2(ipoint,3)
enddo
!$OMP END CRITICAL
tmp_omp_d2 = 0.d0
!$OMP DO COLLAPSE(2)
do i = elec_beta_num+1, elec_alpha_num
do j = elec_beta_num+1, elec_alpha_num
do ipoint = 1, n_points_final_grid
loc_1 = mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
tmp_omp_d2(ipoint,1) += loc_1 * int2_grad1_u12_bimo_t(ipoint,1,i,j)
tmp_omp_d2(ipoint,2) += loc_1 * int2_grad1_u12_bimo_t(ipoint,2,i,j)
tmp_omp_d2(ipoint,3) += loc_1 * int2_grad1_u12_bimo_t(ipoint,3,i,j)
enddo
enddo
enddo
!$OMP END DO NOWAIT
!$OMP CRITICAL
do ipoint = 1, n_points_final_grid
tmp_1(ipoint,1) += tmp_omp_d2(ipoint,1)
tmp_1(ipoint,2) += tmp_omp_d2(ipoint,2)
tmp_1(ipoint,3) += tmp_omp_d2(ipoint,3)
enddo
!$OMP END CRITICAL
deallocate(tmp_omp_d2)
!$OMP END PARALLEL
! ---
allocate(tmp_2(n_points_final_grid,4,mo_num,mo_num))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, a, b) &
!$OMP SHARED (n_points_final_grid, mo_num, &
!$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 tmp_2)
!$OMP DO COLLAPSE(2)
do a = 1, mo_num
do b = 1, mo_num
do ipoint = 1, n_points_final_grid
tmp_2(ipoint,1,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,b,a)
tmp_2(ipoint,2,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,b,a)
tmp_2(ipoint,3,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,b,a)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, a, b, i) &
!$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
!$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
!$OMP tmp_2)
!$OMP DO COLLAPSE(2)
do a = 1, mo_num
do b = 1, mo_num
tmp_2(:,4,b,a) = 0.d0
do i = 1, elec_beta_num
do ipoint = 1, n_points_final_grid
tmp_2(ipoint,4,b,a) += final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,a) &
+ int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,a) &
+ int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,a) )
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
! ---
call dgemv( 'T', 4*n_points_final_grid, mo_num*mo_num, 1.d0 &
, tmp_2(1,1,1,1), size(tmp_2, 1) * size(tmp_2, 2) &
, tmp_1(1,1), 1 &
, 0.d0, fock_3e_uhf_mo_b_os(1,1), 1)
deallocate(tmp_1, tmp_2)
! ---
allocate(tmp_3(n_points_final_grid,2,mo_num), tmp_4(n_points_final_grid,2,mo_num))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, b, loc_1, loc_2) &
!$OMP SHARED (n_points_final_grid, mo_num, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP final_weight_at_r_vector, Jkappa, Jbarkappa, tmp_3, tmp_4)
!$OMP DO
do b = 1, mo_num
tmp_3(:,:,b) = 0.d0
tmp_4(:,:,b) = 0.d0
do ipoint = 1, n_points_final_grid
tmp_3(ipoint,1,b) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,b)
loc_1 = -2.0d0 * mos_r_in_r_array_transp(ipoint,b)
tmp_4(ipoint,1,b) = loc_1 * ( Jbarkappa(ipoint,1) * (Jkappa(ipoint,1) + 0.25d0 * Jbarkappa(ipoint,1)) &
+ Jbarkappa(ipoint,2) * (Jkappa(ipoint,2) + 0.25d0 * Jbarkappa(ipoint,2)) &
+ Jbarkappa(ipoint,3) * (Jkappa(ipoint,3) + 0.25d0 * Jbarkappa(ipoint,3)) )
tmp_4(ipoint,2,b) = mos_r_in_r_array_transp(ipoint,b)
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, b, i, loc_1, loc_2, loc_3, loc_4) &
!$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
!$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP Jkappa, Jbarkappa, tmp_3, tmp_4)
!$OMP DO
do b = 1, mo_num
do i = 1, elec_beta_num
do ipoint = 1, n_points_final_grid
loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
loc_2 = mos_r_in_r_array_transp(ipoint,i)
tmp_3(ipoint,2,b) += loc_1 * ( Jbarkappa(ipoint,1) * int2_grad1_u12_bimo_t(ipoint,1,b,i) &
+ Jbarkappa(ipoint,2) * int2_grad1_u12_bimo_t(ipoint,2,b,i) &
+ Jbarkappa(ipoint,3) * int2_grad1_u12_bimo_t(ipoint,3,b,i) )
tmp_4(ipoint,1,b) += loc_2 * ( Jbarkappa(ipoint,1) * int2_grad1_u12_bimo_t(ipoint,1,i,b) &
+ Jbarkappa(ipoint,2) * int2_grad1_u12_bimo_t(ipoint,2,i,b) &
+ Jbarkappa(ipoint,3) * int2_grad1_u12_bimo_t(ipoint,3,i,b) )
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, b, i, j, loc_1, loc_2, loc_3) &
!$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
!$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP tmp_3, tmp_4)
!$OMP DO
do b = 1, mo_num
do i = 1, elec_beta_num
do j = elec_beta_num+1, elec_alpha_num
do ipoint = 1, n_points_final_grid
loc_2 = mos_r_in_r_array_transp(ipoint,b)
tmp_4(ipoint,1,b) += loc_2 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
+ int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
+ int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) )
enddo
enddo
enddo
do i = elec_beta_num+1, elec_alpha_num
do j = elec_beta_num+1, elec_alpha_num
do ipoint = 1, n_points_final_grid
loc_2 = 0.5d0 * mos_r_in_r_array_transp(ipoint,b)
tmp_4(ipoint,1,b) += loc_2 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
+ int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
+ int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) )
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
! ---
call dgemm( 'T', 'N', mo_num, mo_num, 2*n_points_final_grid, 1.d0 &
, tmp_3(1,1,1), 2*n_points_final_grid &
, tmp_4(1,1,1), 2*n_points_final_grid &
, 1.d0, fock_3e_uhf_mo_b_os(1,1), mo_num)
deallocate(tmp_3, tmp_4)
! ---
fock_3e_uhf_mo_a_os = fock_3e_uhf_mo_b_os
allocate(tmp_1(n_points_final_grid,1))
do ipoint = 1, n_points_final_grid
tmp_1(ipoint,1) = Obarkappa(ipoint) + 2.d0 * Okappa(ipoint)
enddo
allocate(tmp_2(n_points_final_grid,1,mo_num,mo_num))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, a, b, i) &
!$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
!$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
!$OMP tmp_2)
!$OMP DO COLLAPSE(2)
do a = 1, mo_num
do b = 1, mo_num
tmp_2(:,1,b,a) = 0.d0
do i = elec_beta_num+1, elec_alpha_num
do ipoint = 1, n_points_final_grid
tmp_2(ipoint,1,b,a) += final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,a) &
+ int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,a) &
+ int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,a) )
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call dgemv( 'T', n_points_final_grid, mo_num*mo_num, 1.d0 &
, tmp_2(1,1,1,1), size(tmp_2, 1) * size(tmp_2, 2) &
, tmp_1(1,1), 1 &
, 1.d0, fock_3e_uhf_mo_a_os(1,1), 1)
deallocate(tmp_1, tmp_2)
! ---
allocate(tmp_3(n_points_final_grid,8,mo_num), tmp_4(n_points_final_grid,8,mo_num))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, b) &
!$OMP SHARED (n_points_final_grid, mo_num, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP final_weight_at_r_vector, Jkappa, Jbarkappa, tmp_3, tmp_4)
!$OMP DO
do b = 1, mo_num
tmp_3(:,:,b) = 0.d0
tmp_4(:,:,b) = 0.d0
do ipoint = 1, n_points_final_grid
tmp_3(ipoint,1,b) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,b)
tmp_4(ipoint,8,b) = mos_r_in_r_array_transp(ipoint,b)
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, b, i, loc_1, loc_2, loc_3, loc_4) &
!$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
!$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP Jkappa, Jbarkappa, tmp_3, tmp_4)
!$OMP DO
do b = 1, mo_num
do i = 1, elec_beta_num
do ipoint = 1, n_points_final_grid
loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
loc_2 = mos_r_in_r_array_transp(ipoint,i)
tmp_3(ipoint,2,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,1,b,i)
tmp_3(ipoint,3,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,2,b,i)
tmp_3(ipoint,4,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,3,b,i)
tmp_4(ipoint,5,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,1,i,b)
tmp_4(ipoint,6,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,2,i,b)
tmp_4(ipoint,7,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,3,i,b)
enddo
enddo
do i = elec_beta_num+1, elec_alpha_num
do ipoint = 1, n_points_final_grid
loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
loc_3 = 2.d0 * loc_1
loc_2 = mos_r_in_r_array_transp(ipoint,i)
loc_4 = 2.d0 * loc_2
tmp_3(ipoint,5,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,1,b,i)
tmp_3(ipoint,6,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,2,b,i)
tmp_3(ipoint,7,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,3,b,i)
tmp_3(ipoint,8,b) += loc_3 * ( (Jkappa(ipoint,1) + 0.5d0 * Jbarkappa(ipoint,1)) * int2_grad1_u12_bimo_t(ipoint,1,b,i) &
+ (Jkappa(ipoint,2) + 0.5d0 * Jbarkappa(ipoint,2)) * int2_grad1_u12_bimo_t(ipoint,2,b,i) &
+ (Jkappa(ipoint,3) + 0.5d0 * Jbarkappa(ipoint,3)) * int2_grad1_u12_bimo_t(ipoint,3,b,i) )
tmp_4(ipoint,1,b) += loc_4 * ( (Jkappa(ipoint,1) + 0.5d0 * Jbarkappa(ipoint,1)) * int2_grad1_u12_bimo_t(ipoint,1,i,b) &
+ (Jkappa(ipoint,2) + 0.5d0 * Jbarkappa(ipoint,2)) * int2_grad1_u12_bimo_t(ipoint,2,i,b) &
+ (Jkappa(ipoint,3) + 0.5d0 * Jbarkappa(ipoint,3)) * int2_grad1_u12_bimo_t(ipoint,3,i,b) )
tmp_4(ipoint,2,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,1,i,b)
tmp_4(ipoint,3,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,2,i,b)
tmp_4(ipoint,4,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,3,i,b)
tmp_4(ipoint,5,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,1,i,b)
tmp_4(ipoint,6,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,2,i,b)
tmp_4(ipoint,7,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,3,i,b)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, b, i, j, loc_1, loc_2, loc_3) &
!$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
!$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP tmp_3, tmp_4)
!$OMP DO
do b = 1, mo_num
do i = 1, elec_beta_num
do j = elec_beta_num+1, elec_alpha_num
do ipoint = 1, n_points_final_grid
loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,j)
loc_2 = mos_r_in_r_array_transp(ipoint,b)
loc_3 = mos_r_in_r_array_transp(ipoint,i)
tmp_3(ipoint,8,b) -= loc_1 * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,j) &
+ int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,j) &
+ int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,j) )
tmp_4(ipoint,1,b) -= loc_3 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,b) &
+ int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,b) &
+ int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,b) )
loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
loc_3 = mos_r_in_r_array_transp(ipoint,j)
tmp_3(ipoint,8,b) -= loc_1 * ( int2_grad1_u12_bimo_t(ipoint,1,b,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
+ int2_grad1_u12_bimo_t(ipoint,2,b,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
+ int2_grad1_u12_bimo_t(ipoint,3,b,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) )
tmp_4(ipoint,1,b) -= loc_3 * ( int2_grad1_u12_bimo_t(ipoint,1,j,i) * int2_grad1_u12_bimo_t(ipoint,1,i,b) &
+ int2_grad1_u12_bimo_t(ipoint,2,j,i) * int2_grad1_u12_bimo_t(ipoint,2,i,b) &
+ int2_grad1_u12_bimo_t(ipoint,3,j,i) * int2_grad1_u12_bimo_t(ipoint,3,i,b) )
enddo
enddo
enddo
do i = elec_beta_num+1, elec_alpha_num
do j = elec_beta_num+1, elec_alpha_num
do ipoint = 1, n_points_final_grid
loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,j)
loc_2 = 0.5d0 * mos_r_in_r_array_transp(ipoint,b)
loc_3 = mos_r_in_r_array_transp(ipoint,i)
tmp_3(ipoint,8,b) -= loc_1 * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,j) &
+ int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,j) &
+ int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,j) )
tmp_4(ipoint,1,b) -= loc_3 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,b) &
+ int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,b) &
+ int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,b) )
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
! ---
call dgemm( 'T', 'N', mo_num, mo_num, 8*n_points_final_grid, 1.d0 &
, tmp_3(1,1,1), 8*n_points_final_grid &
, tmp_4(1,1,1), 8*n_points_final_grid &
, 1.d0, fock_3e_uhf_mo_a_os(1,1), mo_num)
deallocate(tmp_3, tmp_4)
deallocate(Jkappa, Okappa)
!call wall_time(tf)
!print *, ' Wall time for fock_3e_uhf_mo_a_os and fock_3e_uhf_mo_b_os =', tf - ti
END_PROVIDER
! ---

453
src/tc_scf/fock_3e_bi_ortho_uhf.irp.f
View File

@ -1,194 +1,35 @@
! ---
BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_cs, (mo_num, mo_num)]
implicit none
integer :: a, b, i, j
double precision :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
double precision :: ti, tf
double precision, allocatable :: tmp(:,:)
PROVIDE mo_l_coef mo_r_coef
call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, I_bij_aij)
!print *, ' PROVIDING fock_3e_uhf_mo_cs ...'
!call wall_time(ti)
fock_3e_uhf_mo_cs = 0.d0
!$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (a, b, i, j, I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia, tmp) &
!$OMP SHARED (mo_num, elec_beta_num, fock_3e_uhf_mo_cs)
allocate(tmp(mo_num,mo_num))
tmp = 0.d0
!$OMP DO
do a = 1, mo_num
do b = 1, mo_num
do j = 1, elec_beta_num
do i = 1, elec_beta_num
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
tmp(b,a) -= 0.5d0 * ( 4.d0 * I_bij_aij &
+ I_bij_ija &
+ I_bij_jai &
- 2.d0 * I_bij_aji &
- 2.d0 * I_bij_iaj &
- 2.d0 * I_bij_jia )
enddo
enddo
enddo
enddo
!$OMP END DO NOWAIT
!$OMP CRITICAL
do a = 1, mo_num
do b = 1, mo_num
fock_3e_uhf_mo_cs(b,a) += tmp(b,a)
enddo
enddo
!$OMP END CRITICAL
deallocate(tmp)
!$OMP END PARALLEL
!call wall_time(tf)
!print *, ' total Wall time for fock_3e_uhf_mo_cs =', tf - ti
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a, (mo_num, mo_num)]
BEGIN_DOC
!
! ALPHA part of the Fock matrix from three-electron terms
! Fock matrix alpha from three-electron terms
!
! WARNING :: non hermitian if bi-ortho MOS used
!
END_DOC
implicit none
integer :: a, b, i, j, o
double precision :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
double precision :: ti, tf
double precision, allocatable :: tmp(:,:)
double precision :: ti, tf
PROVIDE mo_l_coef mo_r_coef
PROVIDE fock_3e_uhf_mo_cs
!print *, ' Providing fock_3e_uhf_mo_a ...'
!call wall_time(ti)
o = elec_beta_num + 1
call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, I_bij_aij)
! CLOSED-SHELL PART
PROVIDE fock_3e_uhf_mo_cs
fock_3e_uhf_mo_a = fock_3e_uhf_mo_cs
!$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (a, b, i, j, I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia, tmp) &
!$OMP SHARED (mo_num, o, elec_alpha_num, elec_beta_num, fock_3e_uhf_mo_a)
if(elec_alpha_num .ne. elec_beta_num) then
allocate(tmp(mo_num,mo_num))
tmp = 0.d0
! OPEN-SHELL PART
PROVIDE fock_3e_uhf_mo_a_os
!$OMP DO
do a = 1, mo_num
do b = 1, mo_num
! ---
do j = o, elec_alpha_num
do i = 1, elec_beta_num
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
tmp(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
+ I_bij_ija &
+ I_bij_jai &
- I_bij_aji &
- I_bij_iaj &
- 2.d0 * I_bij_jia )
enddo
enddo
! ---
do j = 1, elec_beta_num
do i = o, elec_alpha_num
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
tmp(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
+ I_bij_ija &
+ I_bij_jai &
- I_bij_aji &
- 2.d0 * I_bij_iaj &
- I_bij_jia )
enddo
enddo
! ---
do j = o, elec_alpha_num
do i = o, elec_alpha_num
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
tmp(b,a) -= 0.5d0 * ( I_bij_aij &
+ I_bij_ija &
+ I_bij_jai &
- I_bij_aji &
- I_bij_iaj &
- I_bij_jia )
enddo
enddo
! ---
enddo
enddo
!$OMP END DO NOWAIT
!$OMP CRITICAL
do a = 1, mo_num
do b = 1, mo_num
fock_3e_uhf_mo_a(b,a) += tmp(b,a)
enddo
enddo
!$OMP END CRITICAL
deallocate(tmp)
!$OMP END PARALLEL
fock_3e_uhf_mo_a += fock_3e_uhf_mo_a_os
endif
!call wall_time(tf)
!print *, ' Wall time for fock_3e_uhf_mo_a =', tf - ti
@ -200,285 +41,35 @@ END_PROVIDER
BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b, (mo_num, mo_num)]
BEGIN_DOC
! BETA part of the Fock matrix from three-electron terms
!
! Fock matrix beta from three-electron terms
!
! WARNING :: non hermitian if bi-ortho MOS used
!
END_DOC
implicit none
integer :: a, b, i, j, o
double precision :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
double precision :: ti, tf
double precision, allocatable :: tmp(:,:)
double precision :: ti, tf
PROVIDE mo_l_coef mo_r_coef
!print *, ' PROVIDING fock_3e_uhf_mo_b ...'
!print *, ' Providing and fock_3e_uhf_mo_b ...'
!call wall_time(ti)
o = elec_beta_num + 1
call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, I_bij_aij)
! CLOSED-SHELL PART
PROVIDE fock_3e_uhf_mo_cs
fock_3e_uhf_mo_b = fock_3e_uhf_mo_cs
!$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (a, b, i, j, I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia, tmp) &
!$OMP SHARED (mo_num, o, elec_alpha_num, elec_beta_num, fock_3e_uhf_mo_b)
if(elec_alpha_num .ne. elec_beta_num) then
allocate(tmp(mo_num,mo_num))
tmp = 0.d0
! OPEN-SHELL PART
PROVIDE fock_3e_uhf_mo_b_os
!$OMP DO
do a = 1, mo_num
do b = 1, mo_num
! ---
do j = o, elec_alpha_num
do i = 1, elec_beta_num
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
tmp(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
- I_bij_aji &
- I_bij_iaj )
enddo
enddo
! ---
do j = 1, elec_beta_num
do i = o, elec_alpha_num
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
tmp(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
- I_bij_aji &
- I_bij_jia )
enddo
enddo
! ---
do j = o, elec_alpha_num
do i = o, elec_alpha_num
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
tmp(b,a) -= 0.5d0 * ( I_bij_aij &
- I_bij_aji )
enddo
enddo
! ---
enddo
enddo
!$OMP END DO NOWAIT
!$OMP CRITICAL
do a = 1, mo_num
do b = 1, mo_num
fock_3e_uhf_mo_b(b,a) += tmp(b,a)
enddo
enddo
!$OMP END CRITICAL
deallocate(tmp)
!$OMP END PARALLEL
fock_3e_uhf_mo_b += fock_3e_uhf_mo_b_os
endif
!call wall_time(tf)
!print *, ' total Wall time for fock_3e_uhf_mo_b =', tf - ti
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, fock_3e_uhf_ao_a, (ao_num, ao_num)]
BEGIN_DOC
!
! Equations (B6) and (B7)
!
! g <--> gamma
! d <--> delta
! e <--> eta
! k <--> kappa
!
END_DOC
implicit none
integer :: g, d, e, k, mu, nu
double precision :: dm_ge_a, dm_ge_b, dm_ge
double precision :: dm_dk_a, dm_dk_b, dm_dk
double precision :: i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu
double precision :: ti, tf
double precision, allocatable :: f_tmp(:,:)
print *, ' PROVIDING fock_3e_uhf_ao_a ...'
call wall_time(ti)
fock_3e_uhf_ao_a = 0.d0
!$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (g, e, d, k, mu, nu, dm_ge_a, dm_ge_b, dm_ge, dm_dk_a, dm_dk_b, dm_dk, f_tmp, &
!$OMP i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu) &
!$OMP SHARED (ao_num, TCSCF_bi_ort_dm_ao_alpha, TCSCF_bi_ort_dm_ao_beta, fock_3e_uhf_ao_a)
allocate(f_tmp(ao_num,ao_num))
f_tmp = 0.d0
!$OMP DO
do g = 1, ao_num
do e = 1, ao_num
dm_ge_a = TCSCF_bi_ort_dm_ao_alpha(g,e)
dm_ge_b = TCSCF_bi_ort_dm_ao_beta (g,e)
dm_ge = dm_ge_a + dm_ge_b
do d = 1, ao_num
do k = 1, ao_num
dm_dk_a = TCSCF_bi_ort_dm_ao_alpha(d,k)
dm_dk_b = TCSCF_bi_ort_dm_ao_beta (d,k)
dm_dk = dm_dk_a + dm_dk_b
do mu = 1, ao_num
do nu = 1, ao_num
call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, e, k, i_mugd_nuek)
call give_integrals_3_body_bi_ort_ao(mu, g, d, e, k, nu, i_mugd_eknu)
call give_integrals_3_body_bi_ort_ao(mu, g, d, k, nu, e, i_mugd_knue)
call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, k, e, i_mugd_nuke)
call give_integrals_3_body_bi_ort_ao(mu, g, d, e, nu, k, i_mugd_enuk)
call give_integrals_3_body_bi_ort_ao(mu, g, d, k, e, nu, i_mugd_kenu)
f_tmp(mu,nu) -= 0.5d0 * ( dm_ge * dm_dk * i_mugd_nuek &
+ dm_ge_a * dm_dk_a * i_mugd_eknu &
+ dm_ge_a * dm_dk_a * i_mugd_knue &
- dm_ge_a * dm_dk * i_mugd_enuk &
- dm_ge * dm_dk_a * i_mugd_kenu &
- dm_ge_a * dm_dk_a * i_mugd_nuke &
- dm_ge_b * dm_dk_b * i_mugd_nuke )
enddo
enddo
enddo
enddo
enddo
enddo
!$OMP END DO NOWAIT
!$OMP CRITICAL
do mu = 1, ao_num
do nu = 1, ao_num
fock_3e_uhf_ao_a(mu,nu) += f_tmp(mu,nu)
enddo
enddo
!$OMP END CRITICAL
deallocate(f_tmp)
!$OMP END PARALLEL
call wall_time(tf)
print *, ' total Wall time for fock_3e_uhf_ao_a =', tf - ti
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, fock_3e_uhf_ao_b, (ao_num, ao_num)]
BEGIN_DOC
!
! Equations (B6) and (B7)
!
! g <--> gamma
! d <--> delta
! e <--> eta
! k <--> kappa
!
END_DOC
implicit none
integer :: g, d, e, k, mu, nu
double precision :: dm_ge_a, dm_ge_b, dm_ge
double precision :: dm_dk_a, dm_dk_b, dm_dk
double precision :: i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu
double precision :: ti, tf
double precision, allocatable :: f_tmp(:,:)
print *, ' PROVIDING fock_3e_uhf_ao_b ...'
call wall_time(ti)
fock_3e_uhf_ao_b = 0.d0
!$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (g, e, d, k, mu, nu, dm_ge_a, dm_ge_b, dm_ge, dm_dk_a, dm_dk_b, dm_dk, f_tmp, &
!$OMP i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu) &
!$OMP SHARED (ao_num, TCSCF_bi_ort_dm_ao_alpha, TCSCF_bi_ort_dm_ao_beta, fock_3e_uhf_ao_b)
allocate(f_tmp(ao_num,ao_num))
f_tmp = 0.d0
!$OMP DO
do g = 1, ao_num
do e = 1, ao_num
dm_ge_a = TCSCF_bi_ort_dm_ao_alpha(g,e)
dm_ge_b = TCSCF_bi_ort_dm_ao_beta (g,e)
dm_ge = dm_ge_a + dm_ge_b
do d = 1, ao_num
do k = 1, ao_num
dm_dk_a = TCSCF_bi_ort_dm_ao_alpha(d,k)
dm_dk_b = TCSCF_bi_ort_dm_ao_beta (d,k)
dm_dk = dm_dk_a + dm_dk_b
do mu = 1, ao_num
do nu = 1, ao_num
call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, e, k, i_mugd_nuek)
call give_integrals_3_body_bi_ort_ao(mu, g, d, e, k, nu, i_mugd_eknu)
call give_integrals_3_body_bi_ort_ao(mu, g, d, k, nu, e, i_mugd_knue)
call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, k, e, i_mugd_nuke)
call give_integrals_3_body_bi_ort_ao(mu, g, d, e, nu, k, i_mugd_enuk)
call give_integrals_3_body_bi_ort_ao(mu, g, d, k, e, nu, i_mugd_kenu)
f_tmp(mu,nu) -= 0.5d0 * ( dm_ge * dm_dk * i_mugd_nuek &
+ dm_ge_b * dm_dk_b * i_mugd_eknu &
+ dm_ge_b * dm_dk_b * i_mugd_knue &
- dm_ge_b * dm_dk * i_mugd_enuk &
- dm_ge * dm_dk_b * i_mugd_kenu &
- dm_ge_b * dm_dk_b * i_mugd_nuke &
- dm_ge_a * dm_dk_a * i_mugd_nuke )
enddo
enddo
enddo
enddo
enddo
enddo
!$OMP END DO NOWAIT
!$OMP CRITICAL
do mu = 1, ao_num
do nu = 1, ao_num
fock_3e_uhf_ao_b(mu,nu) += f_tmp(mu,nu)
enddo
enddo
!$OMP END CRITICAL
deallocate(f_tmp)
!$OMP END PARALLEL
call wall_time(tf)
print *, ' total Wall time for fock_3e_uhf_ao_b =', tf - ti
!print *, ' Wall time for fock_3e_uhf_mo_b =', tf - ti
END_PROVIDER

490
src/tc_scf/fock_3e_bi_ortho_uhf_old.irp.f Normal file
View File

@ -0,0 +1,490 @@
! ---
BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_cs_old, (mo_num, mo_num)]
implicit none
integer :: a, b, i, j
double precision :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
double precision :: ti, tf
double precision, allocatable :: tmp(:,:)
PROVIDE mo_l_coef mo_r_coef
call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, I_bij_aij)
!print *, ' PROVIDING fock_3e_uhf_mo_cs_old ...'
!call wall_time(ti)
fock_3e_uhf_mo_cs_old = 0.d0
!$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (a, b, i, j, I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia, tmp) &
!$OMP SHARED (mo_num, elec_beta_num, fock_3e_uhf_mo_cs_old)
allocate(tmp(mo_num,mo_num))
tmp = 0.d0
!$OMP DO
do a = 1, mo_num
do b = 1, mo_num
do j = 1, elec_beta_num
do i = 1, elec_beta_num
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
tmp(b,a) -= 0.5d0 * ( 4.d0 * I_bij_aij &
+ I_bij_ija &
+ I_bij_jai &
- 2.d0 * I_bij_aji &
- 2.d0 * I_bij_iaj &
- 2.d0 * I_bij_jia )
enddo
enddo
enddo
enddo
!$OMP END DO NOWAIT
!$OMP CRITICAL
do a = 1, mo_num
do b = 1, mo_num
fock_3e_uhf_mo_cs_old(b,a) += tmp(b,a)
enddo
enddo
!$OMP END CRITICAL
deallocate(tmp)
!$OMP END PARALLEL
!call wall_time(tf)
!print *, ' total Wall time for fock_3e_uhf_mo_cs_old =', tf - ti
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a_old, (mo_num, mo_num)]
BEGIN_DOC
!
! ALPHA part of the Fock matrix from three-electron terms
!
! WARNING :: non hermitian if bi-ortho MOS used
!
END_DOC
implicit none
integer :: a, b, i, j, o
double precision :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
double precision :: ti, tf
double precision, allocatable :: tmp(:,:)
PROVIDE mo_l_coef mo_r_coef
PROVIDE fock_3e_uhf_mo_cs
!print *, ' Providing fock_3e_uhf_mo_a_old ...'
!call wall_time(ti)
o = elec_beta_num + 1
call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, I_bij_aij)
PROVIDE fock_3e_uhf_mo_cs_old
fock_3e_uhf_mo_a_old = fock_3e_uhf_mo_cs_old
!$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (a, b, i, j, I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia, tmp) &
!$OMP SHARED (mo_num, o, elec_alpha_num, elec_beta_num, fock_3e_uhf_mo_a_old)
allocate(tmp(mo_num,mo_num))
tmp = 0.d0
!$OMP DO
do a = 1, mo_num
do b = 1, mo_num
! ---
do j = o, elec_alpha_num
do i = 1, elec_beta_num
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
tmp(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
+ I_bij_ija &
+ I_bij_jai &
- I_bij_aji &
- I_bij_iaj &
- 2.d0 * I_bij_jia )
enddo
enddo
! ---
do j = 1, elec_beta_num
do i = o, elec_alpha_num
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
tmp(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
+ I_bij_ija &
+ I_bij_jai &
- I_bij_aji &
- 2.d0 * I_bij_iaj &
- I_bij_jia )
enddo
enddo
! ---
do j = o, elec_alpha_num
do i = o, elec_alpha_num
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
tmp(b,a) -= 0.5d0 * ( I_bij_aij &
+ I_bij_ija &
+ I_bij_jai &
- I_bij_aji &
- I_bij_iaj &
- I_bij_jia )
enddo
enddo
! ---
enddo
enddo
!$OMP END DO NOWAIT
!$OMP CRITICAL
do a = 1, mo_num
do b = 1, mo_num
fock_3e_uhf_mo_a_old(b,a) += tmp(b,a)
enddo
enddo
!$OMP END CRITICAL
deallocate(tmp)
!$OMP END PARALLEL
!call wall_time(tf)
!print *, ' Wall time for fock_3e_uhf_mo_a_old =', tf - ti
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b_old, (mo_num, mo_num)]
BEGIN_DOC
!
! BETA part of the Fock matrix from three-electron terms
!
! WARNING :: non hermitian if bi-ortho MOS used
!
END_DOC
implicit none
integer :: a, b, i, j, o
double precision :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
double precision :: ti, tf
double precision, allocatable :: tmp(:,:)
PROVIDE mo_l_coef mo_r_coef
!print *, ' PROVIDING fock_3e_uhf_mo_b_old ...'
!call wall_time(ti)
o = elec_beta_num + 1
call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, I_bij_aij)
PROVIDE fock_3e_uhf_mo_cs_old
fock_3e_uhf_mo_b_old = fock_3e_uhf_mo_cs_old
!$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (a, b, i, j, I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia, tmp) &
!$OMP SHARED (mo_num, o, elec_alpha_num, elec_beta_num, fock_3e_uhf_mo_b_old)
allocate(tmp(mo_num,mo_num))
tmp = 0.d0
!$OMP DO
do a = 1, mo_num
do b = 1, mo_num
! ---
do j = o, elec_alpha_num
do i = 1, elec_beta_num
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
tmp(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
- I_bij_aji &
- I_bij_iaj )
enddo
enddo
! ---
do j = 1, elec_beta_num
do i = o, elec_alpha_num
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
tmp(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
- I_bij_aji &
- I_bij_jia )
enddo
enddo
! ---
do j = o, elec_alpha_num
do i = o, elec_alpha_num
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
tmp(b,a) -= 0.5d0 * ( I_bij_aij &
- I_bij_aji )
enddo
enddo
! ---
enddo
enddo
!$OMP END DO NOWAIT
!$OMP CRITICAL
do a = 1, mo_num
do b = 1, mo_num
fock_3e_uhf_mo_b_old(b,a) += tmp(b,a)
enddo
enddo
!$OMP END CRITICAL
deallocate(tmp)
!$OMP END PARALLEL
!call wall_time(tf)
!print *, ' total Wall time for fock_3e_uhf_mo_b_old =', tf - ti
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, fock_3e_uhf_ao_a, (ao_num, ao_num)]
BEGIN_DOC
!
! Equations (B6) and (B7)
!
! g <--> gamma
! d <--> delta
! e <--> eta
! k <--> kappa
!
END_DOC
implicit none
integer :: g, d, e, k, mu, nu
double precision :: dm_ge_a, dm_ge_b, dm_ge
double precision :: dm_dk_a, dm_dk_b, dm_dk
double precision :: i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu
double precision :: ti, tf
double precision, allocatable :: f_tmp(:,:)
!print *, ' PROVIDING fock_3e_uhf_ao_a ...'
!call wall_time(ti)
fock_3e_uhf_ao_a = 0.d0
!$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (g, e, d, k, mu, nu, dm_ge_a, dm_ge_b, dm_ge, dm_dk_a, dm_dk_b, dm_dk, f_tmp, &
!$OMP i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu) &
!$OMP SHARED (ao_num, TCSCF_bi_ort_dm_ao_alpha, TCSCF_bi_ort_dm_ao_beta, fock_3e_uhf_ao_a)
allocate(f_tmp(ao_num,ao_num))
f_tmp = 0.d0
!$OMP DO
do g = 1, ao_num
do e = 1, ao_num
dm_ge_a = TCSCF_bi_ort_dm_ao_alpha(g,e)
dm_ge_b = TCSCF_bi_ort_dm_ao_beta (g,e)
dm_ge = dm_ge_a + dm_ge_b
do d = 1, ao_num
do k = 1, ao_num
dm_dk_a = TCSCF_bi_ort_dm_ao_alpha(d,k)
dm_dk_b = TCSCF_bi_ort_dm_ao_beta (d,k)
dm_dk = dm_dk_a + dm_dk_b
do mu = 1, ao_num
do nu = 1, ao_num
call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, e, k, i_mugd_nuek)
call give_integrals_3_body_bi_ort_ao(mu, g, d, e, k, nu, i_mugd_eknu)
call give_integrals_3_body_bi_ort_ao(mu, g, d, k, nu, e, i_mugd_knue)
call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, k, e, i_mugd_nuke)
call give_integrals_3_body_bi_ort_ao(mu, g, d, e, nu, k, i_mugd_enuk)
call give_integrals_3_body_bi_ort_ao(mu, g, d, k, e, nu, i_mugd_kenu)
f_tmp(mu,nu) -= 0.5d0 * ( dm_ge * dm_dk * i_mugd_nuek &
+ dm_ge_a * dm_dk_a * i_mugd_eknu &
+ dm_ge_a * dm_dk_a * i_mugd_knue &
- dm_ge_a * dm_dk * i_mugd_enuk &
- dm_ge * dm_dk_a * i_mugd_kenu &
- dm_ge_a * dm_dk_a * i_mugd_nuke &
- dm_ge_b * dm_dk_b * i_mugd_nuke )
enddo
enddo
enddo
enddo
enddo
enddo
!$OMP END DO NOWAIT
!$OMP CRITICAL
do mu = 1, ao_num
do nu = 1, ao_num
fock_3e_uhf_ao_a(mu,nu) += f_tmp(mu,nu)
enddo
enddo
!$OMP END CRITICAL
deallocate(f_tmp)
!$OMP END PARALLEL
!call wall_time(tf)
!print *, ' total Wall time for fock_3e_uhf_ao_a =', tf - ti
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, fock_3e_uhf_ao_b, (ao_num, ao_num)]
BEGIN_DOC
!
! Equations (B6) and (B7)
!
! g <--> gamma
! d <--> delta
! e <--> eta
! k <--> kappa
!
END_DOC
implicit none
integer :: g, d, e, k, mu, nu
double precision :: dm_ge_a, dm_ge_b, dm_ge
double precision :: dm_dk_a, dm_dk_b, dm_dk
double precision :: i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu
double precision :: ti, tf
double precision, allocatable :: f_tmp(:,:)
!print *, ' PROVIDING fock_3e_uhf_ao_b ...'
!call wall_time(ti)
fock_3e_uhf_ao_b = 0.d0
!$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (g, e, d, k, mu, nu, dm_ge_a, dm_ge_b, dm_ge, dm_dk_a, dm_dk_b, dm_dk, f_tmp, &
!$OMP i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu) &
!$OMP SHARED (ao_num, TCSCF_bi_ort_dm_ao_alpha, TCSCF_bi_ort_dm_ao_beta, fock_3e_uhf_ao_b)
allocate(f_tmp(ao_num,ao_num))
f_tmp = 0.d0
!$OMP DO
do g = 1, ao_num
do e = 1, ao_num
dm_ge_a = TCSCF_bi_ort_dm_ao_alpha(g,e)
dm_ge_b = TCSCF_bi_ort_dm_ao_beta (g,e)
dm_ge = dm_ge_a + dm_ge_b
do d = 1, ao_num
do k = 1, ao_num
dm_dk_a = TCSCF_bi_ort_dm_ao_alpha(d,k)
dm_dk_b = TCSCF_bi_ort_dm_ao_beta (d,k)
dm_dk = dm_dk_a + dm_dk_b
do mu = 1, ao_num
do nu = 1, ao_num
call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, e, k, i_mugd_nuek)
call give_integrals_3_body_bi_ort_ao(mu, g, d, e, k, nu, i_mugd_eknu)
call give_integrals_3_body_bi_ort_ao(mu, g, d, k, nu, e, i_mugd_knue)
call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, k, e, i_mugd_nuke)
call give_integrals_3_body_bi_ort_ao(mu, g, d, e, nu, k, i_mugd_enuk)
call give_integrals_3_body_bi_ort_ao(mu, g, d, k, e, nu, i_mugd_kenu)
f_tmp(mu,nu) -= 0.5d0 * ( dm_ge * dm_dk * i_mugd_nuek &
+ dm_ge_b * dm_dk_b * i_mugd_eknu &
+ dm_ge_b * dm_dk_b * i_mugd_knue &
- dm_ge_b * dm_dk * i_mugd_enuk &
- dm_ge * dm_dk_b * i_mugd_kenu &
- dm_ge_b * dm_dk_b * i_mugd_nuke &
- dm_ge_a * dm_dk_a * i_mugd_nuke )
enddo
enddo
enddo
enddo
enddo
enddo
!$OMP END DO NOWAIT
!$OMP CRITICAL
do mu = 1, ao_num
do nu = 1, ao_num
fock_3e_uhf_ao_b(mu,nu) += f_tmp(mu,nu)
enddo
enddo
!$OMP END CRITICAL
deallocate(f_tmp)
!$OMP END PARALLEL
!call wall_time(tf)
!print *, ' total Wall time for fock_3e_uhf_ao_b =', tf - ti
END_PROVIDER
! ---

27
src/tc_scf/fock_tc.irp.f
View File

@ -190,30 +190,14 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_alpha, (mo_num, mo_num) ]
if(bi_ortho) then
!allocate(tmp(ao_num,ao_num))
!tmp = Fock_matrix_tc_ao_alpha
!if(three_body_h_tc) then
! tmp += fock_3e_uhf_ao_a
!endif
!call ao_to_mo_bi_ortho(tmp, size(tmp, 1), Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1))
!deallocate(tmp)
PROVIDE mo_l_coef mo_r_coef
!call wall_time(tt0)
call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_alpha, size(Fock_matrix_tc_ao_alpha, 1) &
, Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1) )
!call wall_time(tt1)
!print*, ' 2-e term:', tt1-tt0
if(three_body_h_tc) then
!call wall_time(tt0)
PROVIDE fock_a_tot_3e_bi_orth
Fock_matrix_tc_mo_alpha += fock_a_tot_3e_bi_orth
! PROVIDE fock_3e_uhf_mo_a
! Fock_matrix_tc_mo_alpha += fock_3e_uhf_mo_a
!call wall_time(tt1)
!print*, ' 3-e term:', tt1-tt0
PROVIDE fock_3e_uhf_mo_a
Fock_matrix_tc_mo_alpha += fock_3e_uhf_mo_a
endif
else
@ -243,11 +227,10 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_beta, (mo_num,mo_num) ]
call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_beta, size(Fock_matrix_tc_ao_beta, 1) &
, Fock_matrix_tc_mo_beta, size(Fock_matrix_tc_mo_beta, 1) )
if(three_body_h_tc) then
PROVIDE fock_b_tot_3e_bi_orth
Fock_matrix_tc_mo_beta += fock_b_tot_3e_bi_orth
! PROVIDE fock_3e_uhf_mo_b
! Fock_matrix_tc_mo_beta += fock_3e_uhf_mo_b
PROVIDE fock_3e_uhf_mo_b
Fock_matrix_tc_mo_beta += fock_3e_uhf_mo_b
endif
else

2
src/tc_scf/fock_three_bi_ortho.irp.f
View File

@ -34,7 +34,7 @@ BEGIN_PROVIDER [double precision, fock_a_tot_3e_bi_orth, (mo_num, mo_num)]
enddo
!call wall_time(t1)
!print*, ' Wall time for fock_a_tot_3e_bi_orth =', t1-t0
!print*, ' Wall time for fock_a_tot_3e_bi_orth =', t1 - t0
END_PROVIDER

414
src/tc_scf/fock_three_hermit.irp.f
View File

@ -78,13 +78,16 @@ end
! ---
! TODO DGEMM
BEGIN_PROVIDER [double precision, diag_three_elem_hf]
implicit none
integer :: i, j, k, ipoint, mm
double precision :: contrib, weight, four_third, one_third, two_third, exchange_int_231
double precision :: integral_aaa, hthree, integral_aab, integral_abb, integral_bbb
integer :: i, j, k, ipoint, mm
double precision :: contrib, weight, four_third, one_third, two_third, exchange_int_231
double precision :: integral_aaa, hthree, integral_aab, integral_abb, integral_bbb
double precision, allocatable :: tmp(:)
double precision, allocatable :: tmp_L(:,:), tmp_R(:,:)
double precision, allocatable :: tmp_M(:,:), tmp_S(:), tmp_O(:), tmp_J(:,:)
double precision, allocatable :: tmp_M_priv(:,:), tmp_S_priv(:), tmp_O_priv(:), tmp_J_priv(:,:)
PROVIDE mo_l_coef mo_r_coef
@ -131,14 +134,397 @@ BEGIN_PROVIDER [double precision, diag_three_elem_hf]
else
provide mo_l_coef mo_r_coef
call give_aaa_contrib(integral_aaa)
call give_aab_contrib(integral_aab)
call give_abb_contrib(integral_abb)
call give_bbb_contrib(integral_bbb)
diag_three_elem_hf = integral_aaa + integral_aab + integral_abb + integral_bbb
! print*,'integral_aaa + integral_aab + integral_abb + integral_bbb'
! print*,integral_aaa , integral_aab , integral_abb , integral_bbb
! ------------
! SLOW VERSION
! ------------
!call give_aaa_contrib(integral_aaa)
!call give_aab_contrib(integral_aab)
!call give_abb_contrib(integral_abb)
!call give_bbb_contrib(integral_bbb)
!diag_three_elem_hf = integral_aaa + integral_aab + integral_abb + integral_bbb
! ------------
! ------------
PROVIDE int2_grad1_u12_bimo_t
PROVIDE mos_l_in_r_array_transp
PROVIDE mos_r_in_r_array_transp
if(elec_alpha_num .eq. elec_beta_num) then
allocate(tmp(elec_beta_num))
allocate(tmp_L(n_points_final_grid,3), tmp_R(n_points_final_grid,3))
!$OMP PARALLEL &
!$OMP DEFAULT(NONE) &
!$OMP PRIVATE(j, i, ipoint, tmp_L, tmp_R) &
!$OMP SHARED(elec_beta_num, n_points_final_grid, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP int2_grad1_u12_bimo_t, tmp, final_weight_at_r_vector)
!$OMP DO
do j = 1, elec_beta_num
tmp_L = 0.d0
tmp_R = 0.d0
do i = 1, elec_beta_num
do ipoint = 1, n_points_final_grid
tmp_L(ipoint,1) = tmp_L(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i)
tmp_L(ipoint,2) = tmp_L(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i)
tmp_L(ipoint,3) = tmp_L(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i)
tmp_R(ipoint,1) = tmp_R(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i)
tmp_R(ipoint,2) = tmp_R(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i)
tmp_R(ipoint,3) = tmp_R(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i)
enddo
enddo
tmp(j) = 0.d0
do ipoint = 1, n_points_final_grid
tmp(j) = tmp(j) + final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3))
enddo
enddo ! j
!$OMP END DO
!$OMP END PARALLEL
diag_three_elem_hf = -2.d0 * sum(tmp)
deallocate(tmp)
deallocate(tmp_L, tmp_R)
! ---
allocate(tmp_O(n_points_final_grid), tmp_J(n_points_final_grid,3))
tmp_O = 0.d0
tmp_J = 0.d0
!$OMP PARALLEL &
!$OMP DEFAULT(NONE) &
!$OMP PRIVATE(i, ipoint, tmp_O_priv, tmp_J_priv) &
!$OMP SHARED(elec_beta_num, n_points_final_grid, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP int2_grad1_u12_bimo_t, tmp_O, tmp_J)
allocate(tmp_O_priv(n_points_final_grid), tmp_J_priv(n_points_final_grid,3))
tmp_O_priv = 0.d0
tmp_J_priv = 0.d0
!$OMP DO
do i = 1, elec_beta_num
do ipoint = 1, n_points_final_grid
tmp_O_priv(ipoint) = tmp_O_priv(ipoint) + mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
tmp_J_priv(ipoint,1) = tmp_J_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,i)
tmp_J_priv(ipoint,2) = tmp_J_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,i)
tmp_J_priv(ipoint,3) = tmp_J_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,i)
enddo
enddo
!$OMP END DO NOWAIT
!$OMP CRITICAL
tmp_O = tmp_O + tmp_O_priv
tmp_J = tmp_J + tmp_J_priv
!$OMP END CRITICAL
deallocate(tmp_O_priv, tmp_J_priv)
!$OMP END PARALLEL
allocate(tmp_M(n_points_final_grid,3), tmp_S(n_points_final_grid))
tmp_M = 0.d0
tmp_S = 0.d0
!$OMP PARALLEL &
!$OMP DEFAULT(NONE) &
!$OMP PRIVATE(i, j, ipoint, tmp_M_priv, tmp_S_priv) &
!$OMP SHARED(elec_beta_num, n_points_final_grid, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP int2_grad1_u12_bimo_t, tmp_M, tmp_S)
allocate(tmp_M_priv(n_points_final_grid,3), tmp_S_priv(n_points_final_grid))
tmp_M_priv = 0.d0
tmp_S_priv = 0.d0
!$OMP DO COLLAPSE(2)
do i = 1, elec_beta_num
do j = 1, elec_beta_num
do ipoint = 1, n_points_final_grid
tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
+ int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
+ int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i)
enddo
enddo
enddo
!$OMP END DO NOWAIT
!$OMP CRITICAL
tmp_M = tmp_M + tmp_M_priv
tmp_S = tmp_S + tmp_S_priv
!$OMP END CRITICAL
deallocate(tmp_M_priv, tmp_S_priv)
!$OMP END PARALLEL
allocate(tmp(n_points_final_grid))
do ipoint = 1, n_points_final_grid
tmp_S(ipoint) = 2.d0 * (tmp_J(ipoint,1)*tmp_J(ipoint,1) + tmp_J(ipoint,2)*tmp_J(ipoint,2) + tmp_J(ipoint,3)*tmp_J(ipoint,3)) - tmp_S(ipoint)
tmp(ipoint) = final_weight_at_r_vector(ipoint) * ( tmp_O(ipoint) * tmp_S(ipoint) &
- 2.d0 * ( tmp_J(ipoint,1) * tmp_M(ipoint,1) &
+ tmp_J(ipoint,2) * tmp_M(ipoint,2) &
+ tmp_J(ipoint,3) * tmp_M(ipoint,3)))
enddo
diag_three_elem_hf = diag_three_elem_hf -2.d0 * (sum(tmp))
deallocate(tmp)
else
allocate(tmp(elec_alpha_num))
allocate(tmp_L(n_points_final_grid,3), tmp_R(n_points_final_grid,3))
!$OMP PARALLEL &
!$OMP DEFAULT(NONE) &
!$OMP PRIVATE(j, i, ipoint, tmp_L, tmp_R) &
!$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP int2_grad1_u12_bimo_t, tmp, final_weight_at_r_vector)
!$OMP DO
do j = 1, elec_beta_num
tmp_L = 0.d0
tmp_R = 0.d0
do i = elec_beta_num+1, elec_alpha_num
do ipoint = 1, n_points_final_grid
tmp_L(ipoint,1) = tmp_L(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i)
tmp_L(ipoint,2) = tmp_L(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i)
tmp_L(ipoint,3) = tmp_L(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i)
tmp_R(ipoint,1) = tmp_R(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i)
tmp_R(ipoint,2) = tmp_R(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i)
tmp_R(ipoint,3) = tmp_R(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i)
enddo
enddo
tmp(j) = 0.d0
do ipoint = 1, n_points_final_grid
tmp(j) = tmp(j) + final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3))
enddo
do i = 1, elec_beta_num
do ipoint = 1, n_points_final_grid
tmp_L(ipoint,1) = tmp_L(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i)
tmp_L(ipoint,2) = tmp_L(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i)
tmp_L(ipoint,3) = tmp_L(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i)
tmp_R(ipoint,1) = tmp_R(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i)
tmp_R(ipoint,2) = tmp_R(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i)
tmp_R(ipoint,3) = tmp_R(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i)
enddo
enddo
do ipoint = 1, n_points_final_grid
tmp(j) = tmp(j) + final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3))
enddo
enddo ! j
!$OMP END DO
!$OMP END PARALLEL
! ---
!$OMP PARALLEL &
!$OMP DEFAULT(NONE) &
!$OMP PRIVATE(j, i, ipoint, tmp_L, tmp_R) &
!$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP int2_grad1_u12_bimo_t, tmp, final_weight_at_r_vector)
!$OMP DO
do j = elec_beta_num+1, elec_alpha_num
tmp_L = 0.d0
tmp_R = 0.d0
do i = 1, elec_alpha_num
do ipoint = 1, n_points_final_grid
tmp_L(ipoint,1) = tmp_L(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i)
tmp_L(ipoint,2) = tmp_L(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i)
tmp_L(ipoint,3) = tmp_L(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i)
tmp_R(ipoint,1) = tmp_R(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i)
tmp_R(ipoint,2) = tmp_R(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i)
tmp_R(ipoint,3) = tmp_R(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i)
enddo
enddo
tmp(j) = 0.d0
do ipoint = 1, n_points_final_grid
tmp(j) = tmp(j) + 0.5d0 * final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3))
enddo
enddo ! j
!$OMP END DO
!$OMP END PARALLEL
diag_three_elem_hf = -2.d0 * sum(tmp)
deallocate(tmp)
deallocate(tmp_L, tmp_R)
! ---
allocate(tmp_O(n_points_final_grid), tmp_J(n_points_final_grid,3))
tmp_O = 0.d0
tmp_J = 0.d0
!$OMP PARALLEL &
!$OMP DEFAULT(NONE) &
!$OMP PRIVATE(i, ipoint, tmp_O_priv, tmp_J_priv) &
!$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP int2_grad1_u12_bimo_t, tmp_O, tmp_J)
allocate(tmp_O_priv(n_points_final_grid), tmp_J_priv(n_points_final_grid,3))
tmp_O_priv = 0.d0
tmp_J_priv = 0.d0
!$OMP DO
do i = 1, elec_beta_num
do ipoint = 1, n_points_final_grid
tmp_O_priv(ipoint) = tmp_O_priv(ipoint) + mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
tmp_J_priv(ipoint,1) = tmp_J_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,i)
tmp_J_priv(ipoint,2) = tmp_J_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,i)
tmp_J_priv(ipoint,3) = tmp_J_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,i)
enddo
enddo
!$OMP END DO NOWAIT
!$OMP DO
do i = elec_beta_num+1, elec_alpha_num
do ipoint = 1, n_points_final_grid
tmp_O_priv(ipoint) = tmp_O_priv(ipoint) + 0.5d0 * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
tmp_J_priv(ipoint,1) = tmp_J_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,i)
tmp_J_priv(ipoint,2) = tmp_J_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,i)
tmp_J_priv(ipoint,3) = tmp_J_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,i)
enddo
enddo
!$OMP END DO NOWAIT
!$OMP CRITICAL
tmp_O = tmp_O + tmp_O_priv
tmp_J = tmp_J + tmp_J_priv
!$OMP END CRITICAL
deallocate(tmp_O_priv, tmp_J_priv)
!$OMP END PARALLEL
! ---
allocate(tmp_M(n_points_final_grid,3), tmp_S(n_points_final_grid))
tmp_M = 0.d0
tmp_S = 0.d0
!$OMP PARALLEL &
!$OMP DEFAULT(NONE) &
!$OMP PRIVATE(i, j, ipoint, tmp_M_priv, tmp_S_priv) &
!$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP int2_grad1_u12_bimo_t, tmp_M, tmp_S)
allocate(tmp_M_priv(n_points_final_grid,3), tmp_S_priv(n_points_final_grid))
tmp_M_priv = 0.d0
tmp_S_priv = 0.d0
!$OMP DO COLLAPSE(2)
do i = 1, elec_beta_num
do j = 1, elec_beta_num
do ipoint = 1, n_points_final_grid
tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
+ int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
+ int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i)
enddo
enddo
enddo
!$OMP END DO NOWAIT
!$OMP DO COLLAPSE(2)
do i = elec_beta_num+1, elec_alpha_num
do j = 1, elec_beta_num
do ipoint = 1, n_points_final_grid
tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
+ int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
+ int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i)
enddo
enddo
enddo
!$OMP END DO NOWAIT
!$OMP DO COLLAPSE(2)
do i = elec_beta_num+1, elec_alpha_num
do j = elec_beta_num+1, elec_alpha_num
do ipoint = 1, n_points_final_grid
tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
+ 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
+ 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i)
enddo
enddo
enddo
!$OMP END DO NOWAIT
!$OMP CRITICAL
tmp_M = tmp_M + tmp_M_priv
tmp_S = tmp_S + tmp_S_priv
!$OMP END CRITICAL
deallocate(tmp_M_priv, tmp_S_priv)
!$OMP END PARALLEL
allocate(tmp(n_points_final_grid))
do ipoint = 1, n_points_final_grid
tmp_S(ipoint) = 2.d0 * (tmp_J(ipoint,1)*tmp_J(ipoint,1) + tmp_J(ipoint,2)*tmp_J(ipoint,2) + tmp_J(ipoint,3)*tmp_J(ipoint,3)) - tmp_S(ipoint)
tmp(ipoint) = final_weight_at_r_vector(ipoint) * ( tmp_O(ipoint) * tmp_S(ipoint) &
- 2.d0 * ( tmp_J(ipoint,1) * tmp_M(ipoint,1) &
+ tmp_J(ipoint,2) * tmp_M(ipoint,2) &
+ tmp_J(ipoint,3) * tmp_M(ipoint,3)))
enddo
diag_three_elem_hf = diag_three_elem_hf - 2.d0 * (sum(tmp))
deallocate(tmp)
endif
endif
@ -374,3 +760,7 @@ BEGIN_PROVIDER [ double precision, fock_3_w_kl_wla_phi_k, (n_points_final_grid,3
enddo
END_PROVIDER

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

@ -13,19 +13,32 @@ program tc_scf
print *, ' starting ...'
my_grid_becke = .True.
PROVIDE tc_grid1_a tc_grid1_r
my_n_pt_r_grid = tc_grid1_r
my_n_pt_a_grid = tc_grid1_a
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
call write_int(6, my_n_pt_r_grid, 'radial external grid over')
call write_int(6, my_n_pt_a_grid, 'angular external grid over')
PROVIDE mu_erf
print *, ' mu = ', mu_erf
PROVIDE j1b_type
print *, ' j1b_type = ', j1b_type
print *, j1b_pen
if(j1b_type .ge. 100) then
my_extra_grid_becke = .True.
PROVIDE tc_grid2_a tc_grid2_r
my_n_pt_r_extra_grid = tc_grid2_r
my_n_pt_a_extra_grid = tc_grid2_a
touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid
call write_int(6, my_n_pt_r_extra_grid, 'radial internal grid over')
call write_int(6, my_n_pt_a_extra_grid, 'angular internal grid over')
endif
!call create_guess()
!call orthonormalize_mos()

30
src/tc_scf/tc_scf_dm.irp.f
View File

@ -1,46 +1,68 @@
! ---
BEGIN_PROVIDER [ double precision, TCSCF_density_matrix_ao_beta, (ao_num, ao_num) ]
BEGIN_PROVIDER [double precision, TCSCF_density_matrix_ao_beta, (ao_num, ao_num)]
BEGIN_DOC
!
! TC-SCF transition density matrix on the AO basis for BETA electrons
!
END_DOC
implicit none
if(bi_ortho) then
PROVIDE mo_l_coef mo_r_coef
TCSCF_density_matrix_ao_beta = TCSCF_bi_ort_dm_ao_beta
else
TCSCF_density_matrix_ao_beta = SCF_density_matrix_ao_beta
endif
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, TCSCF_density_matrix_ao_alpha, (ao_num, ao_num) ]
BEGIN_PROVIDER [double precision, TCSCF_density_matrix_ao_alpha, (ao_num, ao_num)]
BEGIN_DOC
!
! TC-SCF transition density matrix on the AO basis for ALPHA electrons
!
END_DOC
implicit none
if(bi_ortho) then
PROVIDE mo_l_coef mo_r_coef
TCSCF_density_matrix_ao_alpha = TCSCF_bi_ort_dm_ao_alpha
else
TCSCF_density_matrix_ao_alpha = SCF_density_matrix_ao_alpha
endif
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, TCSCF_density_matrix_ao_tot, (ao_num, ao_num) ]
implicit none
BEGIN_PROVIDER [double precision, TCSCF_density_matrix_ao_tot, (ao_num, ao_num)]
BEGIN_DOC
!
! TC-SCF transition density matrix on the AO basis for ALPHA+BETA electrons
!
END_DOC
implicit none
TCSCF_density_matrix_ao_tot = TCSCF_density_matrix_ao_beta + TCSCF_density_matrix_ao_alpha
END_PROVIDER

134
src/tc_scf/test_int.irp.f
View File

@ -54,7 +54,12 @@ program test_ints
!!PROVIDE TC_HF_energy VARTC_HF_energy
!!print *, ' TC_HF_energy = ', TC_HF_energy
!!print *, ' VARTC_HF_energy = ', VARTC_HF_energy
call test_old_ints
! call test_old_ints
call test_fock_3e_uhf_mo_cs()
call test_fock_3e_uhf_mo_a()
call test_fock_3e_uhf_mo_b()
end
! ---
@ -1096,3 +1101,130 @@ subroutine test_int2_grad1_u12_ao_test
print*,'accu_abs = ',accu_abs/dble(ao_num)**4
print*,'accu_relat = ',accu_relat/dble(ao_num)**4
end
! ---
subroutine test_fock_3e_uhf_mo_cs()
implicit none
integer :: i, j
double precision :: I_old, I_new
double precision :: diff_tot, diff, thr_ih, norm
! double precision :: t0, t1
! print*, ' Providing fock_a_tot_3e_bi_orth ...'
! call wall_time(t0)
! PROVIDE fock_a_tot_3e_bi_orth
! call wall_time(t1)
! print*, ' Wall time for fock_a_tot_3e_bi_orth =', t1 - t0
PROVIDE fock_3e_uhf_mo_cs fock_3e_uhf_mo_cs_old
thr_ih = 1d-8
norm = 0.d0
diff_tot = 0.d0
do i = 1, mo_num
do j = 1, mo_num
I_old = fock_3e_uhf_mo_cs_old(j,i)
I_new = fock_3e_uhf_mo_cs (j,i)
diff = dabs(I_old - I_new)
if(diff .gt. thr_ih) then
print *, ' problem in fock_3e_uhf_mo_cs on ', j, i
print *, ' old value = ', I_old
print *, ' new value = ', I_new
!stop
endif
norm += dabs(I_old)
diff_tot += diff
enddo
enddo
print *, ' diff tot (%) = ', 100.d0 * diff_tot / norm
return
end subroutine test_fock_3e_uhf_mo_cs
! ---
subroutine test_fock_3e_uhf_mo_a()
implicit none
integer :: i, j
double precision :: I_old, I_new
double precision :: diff_tot, diff, thr_ih, norm
PROVIDE fock_3e_uhf_mo_a fock_3e_uhf_mo_a_old
thr_ih = 1d-8
norm = 0.d0
diff_tot = 0.d0
do i = 1, mo_num
do j = 1, mo_num
I_old = fock_3e_uhf_mo_a_old(j,i)
I_new = fock_3e_uhf_mo_a (j,i)
diff = dabs(I_old - I_new)
if(diff .gt. thr_ih) then
print *, ' problem in fock_3e_uhf_mo_a on ', j, i
print *, ' old value = ', I_old
print *, ' new value = ', I_new
!stop
endif
norm += dabs(I_old)
diff_tot += diff
enddo
enddo
print *, ' diff tot (%) = ', 100.d0 * diff_tot / norm
return
end subroutine test_fock_3e_uhf_mo_a
! ---
subroutine test_fock_3e_uhf_mo_b()
implicit none
integer :: i, j
double precision :: I_old, I_new
double precision :: diff_tot, diff, thr_ih, norm
PROVIDE fock_3e_uhf_mo_b fock_3e_uhf_mo_b_old
thr_ih = 1d-8
norm = 0.d0
diff_tot = 0.d0
do i = 1, mo_num
do j = 1, mo_num
I_old = fock_3e_uhf_mo_b_old(j,i)
I_new = fock_3e_uhf_mo_b (j,i)
diff = dabs(I_old - I_new)
if(diff .gt. thr_ih) then
print *, ' problem in fock_3e_uhf_mo_b on ', j, i
print *, ' old value = ', I_old
print *, ' new value = ', I_new
!stop
endif
norm += dabs(I_old)
diff_tot += diff
enddo
enddo
print *, ' diff tot (%) = ', 100.d0 * diff_tot / norm
return
end subroutine test_fock_3e_uhf_mo_b
! ---

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
! ---