PTEROSOR/QuantumPackage
10
0
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-12-24 13:23:39 +01:00
Code Releases Activity

merging

Browse Source
This commit is contained in:
eginer 2022-10-22 18:08:56 +02:00
commit fdc5b7a467
57 changed files with 8325 additions and 6128 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,4 +1,6 @@
! ---
subroutine phi_j_erf_mu_r_xyz_phi(i,j,mu_in, C_center, xyz_ints)
implicit none
BEGIN_DOC
@ -49,45 +51,58 @@ subroutine phi_j_erf_mu_r_xyz_phi(i,j,mu_in, C_center, xyz_ints)
enddo
end
! ---
double precision function phi_j_erf_mu_r_phi(i,j,mu_in, C_center)
implicit none
BEGIN_DOC
! phi_j_erf_mu_r_phi = int dr phi_j(r) [erf(mu |r - C|)/|r-C|] phi_i(r)
END_DOC
integer, intent(in) :: i,j
double precision, intent(in) :: mu_in, C_center(3)
integer :: num_A,power_A(3), num_b, power_B(3)
double precision :: alpha, beta, A_center(3), B_center(3),contrib,NAI_pol_mult_erf
integer :: n_pt_in,l,m
phi_j_erf_mu_r_phi = 0.d0
if(ao_overlap_abs(j,i).lt.1.d-12)then
return
endif
n_pt_in = n_pt_max_integrals
! j
num_A = ao_nucl(j)
power_A(1:3)= ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
! i
num_B = ao_nucl(i)
power_B(1:3)= ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
double precision function phi_j_erf_mu_r_phi(i, j, mu_in, C_center)
do l=1,ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
do m=1,ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
contrib = NAI_pol_mult_erf(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in,mu_in)
phi_j_erf_mu_r_phi += contrib * ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i)
BEGIN_DOC
! phi_j_erf_mu_r_phi = int dr phi_j(r) [erf(mu |r - C|)/|r-C|] phi_i(r)
END_DOC
implicit none
integer, intent(in) :: i,j
double precision, intent(in) :: mu_in, C_center(3)
integer :: num_A, power_A(3), num_b, power_B(3)
integer :: n_pt_in, l, m
double precision :: alpha, beta, A_center(3), B_center(3), contrib
double precision :: NAI_pol_mult_erf
phi_j_erf_mu_r_phi = 0.d0
if(ao_overlap_abs(j,i).lt.1.d-12) then
return
endif
n_pt_in = n_pt_max_integrals
! j
num_A = ao_nucl(j)
power_A(1:3) = ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
! i
num_B = ao_nucl(i)
power_B(1:3) = ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l = 1, ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
do m = 1, ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
contrib = NAI_pol_mult_erf(A_center, B_center, power_A, power_B, alpha, beta, C_center, n_pt_in, mu_in)
phi_j_erf_mu_r_phi += contrib * ao_coef_normalized_ordered_transp(l,j) * ao_coef_normalized_ordered_transp(m,i)
enddo
enddo
enddo
end
end function phi_j_erf_mu_r_phi
! ---
subroutine erfc_mu_gauss_xyz_ij_ao(i,j,mu, C_center, delta,gauss_ints)
subroutine erfc_mu_gauss_xyz_ij_ao(i, j, mu, C_center, delta, gauss_ints)
implicit none
BEGIN_DOC
! gauss_ints(m) = \int dr exp(-delta (r - C)^2 ) x/y/z * ( 1 - erf(mu |r-C|))/ |r-C| * AO_i(r) * AO_j(r)
@ -132,95 +147,211 @@ subroutine erfc_mu_gauss_xyz_ij_ao(i,j,mu, C_center, delta,gauss_ints)
enddo
end
subroutine erf_mu_gauss_ij_ao(i,j,mu, C_center, delta,gauss_ints)
implicit none
BEGIN_DOC
! gauss_ints(m) = \int dr exp(-delta (r - C)^2 ) * erf(mu |r-r'|)/ |r-r'| * AO_i(r') * AO_j(r')
!
END_DOC
integer, intent(in) :: i,j
double precision, intent(in) :: mu, C_center(3),delta
double precision, intent(out):: gauss_ints
! ---
integer :: num_A,power_A(3), num_b, power_B(3)
double precision :: alpha, beta, A_center(3), B_center(3),contrib,NAI_pol_mult_erf
double precision :: integral , erf_mu_gauss
integer :: n_pt_in,l,m,mm
gauss_ints = 0.d0
if(ao_overlap_abs(j,i).lt.1.d-12)then
return
endif
n_pt_in = n_pt_max_integrals
! j
num_A = ao_nucl(j)
power_A(1:3)= ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
! i
num_B = ao_nucl(i)
power_B(1:3)= ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
subroutine erf_mu_gauss_ij_ao(i, j, mu, C_center, delta, gauss_ints)
do l=1,ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
do m=1,ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
if(dabs(ao_coef_normalized_ordered_transp(l,j) * ao_coef_normalized_ordered_transp(m,i)).lt.1.d-12)cycle
integral = erf_mu_gauss(C_center,delta,mu,A_center,B_center,power_A,power_B,alpha,beta,n_pt_in)
gauss_ints += integral * ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i)
enddo
enddo
end
subroutine NAI_pol_x_mult_erf_ao(i_ao,j_ao,mu_in,C_center,ints)
implicit none
BEGIN_DOC
!
! gauss_ints = \int dr exp(-delta (r - C)^2) * erf(mu |r-C|) / |r-C| * AO_i(r) * AO_j(r)
!
END_DOC
implicit none
integer, intent(in) :: i, j
double precision, intent(in) :: mu, C_center(3), delta
double precision, intent(out) :: gauss_ints
integer :: n_pt_in, l, m
integer :: num_A, power_A(3), num_b, power_B(3)
double precision :: alpha, beta, A_center(3), B_center(3), coef
double precision :: integral
double precision :: erf_mu_gauss
gauss_ints = 0.d0
if(ao_overlap_abs(j,i).lt.1.d-12) then
return
endif
n_pt_in = n_pt_max_integrals
! j
num_A = ao_nucl(j)
power_A(1:3) = ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
! i
num_B = ao_nucl(i)
power_B(1:3) = ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l = 1, ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
do m = 1, ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
coef = ao_coef_normalized_ordered_transp(l,j) * ao_coef_normalized_ordered_transp(m,i)
if(dabs(coef) .lt. 1.d-12) cycle
integral = erf_mu_gauss(C_center, delta, mu, A_center, B_center, power_A, power_B, alpha, beta, n_pt_in)
gauss_ints += integral * coef
enddo
enddo
end subroutine erf_mu_gauss_ij_ao
! ---
subroutine NAI_pol_x_mult_erf_ao(i_ao, j_ao, mu_in, C_center, ints)
BEGIN_DOC
!
! Computes the following integral :
!
! $\int_{-\infty}^{infty} dr x * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
! $\int_{-\infty}^{infty} dr y * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
! $\int_{-\infty}^{infty} dr z * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
END_DOC
include 'utils/constants.include.F'
integer, intent(in) :: i_ao,j_ao
double precision, intent(in) :: mu_in, C_center(3)
double precision, intent(out):: ints(3)
double precision :: A_center(3), B_center(3),integral, alpha,beta
double precision :: NAI_pol_mult_erf
integer :: i,j,num_A,num_B, power_A(3), power_B(3), n_pt_in, power_xA(3),m
ints = 0.d0
if(ao_overlap_abs(j_ao,i_ao).lt.1.d-12)then
return
endif
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
include 'utils/constants.include.F'
do i = 1, ao_prim_num(i_ao)
alpha = ao_expo_ordered_transp(i,i_ao)
do m = 1, 3
power_xA = power_A
! x * phi_i(r) = x * (x-Ax)**ax = (x-Ax)**(ax+1) + Ax * (x-Ax)**ax
power_xA(m) += 1
do j = 1, ao_prim_num(j_ao)
beta = ao_expo_ordered_transp(j,j_ao)
! First term = (x-Ax)**(ax+1)
integral = NAI_pol_mult_erf(A_center,B_center,power_xA,power_B,alpha,beta,C_center,n_pt_in,mu_in)
ints(m) += integral * ao_coef_normalized_ordered_transp(j,j_ao)*ao_coef_normalized_ordered_transp(i,i_ao)
! Second term = Ax * (x-Ax)**(ax)
integral = NAI_pol_mult_erf(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in,mu_in)
ints(m) += A_center(m) * integral * ao_coef_normalized_ordered_transp(j,j_ao)*ao_coef_normalized_ordered_transp(i,i_ao)
implicit none
integer, intent(in) :: i_ao, j_ao
double precision, intent(in) :: mu_in, C_center(3)
double precision, intent(out) :: ints(3)
integer :: i, j, num_A, num_B, power_A(3), power_B(3), n_pt_in, power_xA(3), m
double precision :: A_center(3), B_center(3), integral, alpha, beta, coef
double precision :: NAI_pol_mult_erf
ints = 0.d0
if(ao_overlap_abs(j_ao,i_ao).lt.1.d-12) then
return
endif
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 m = 1, 3
power_xA = power_A
! x * phi_i(r) = x * (x-Ax)**ax = (x-Ax)**(ax+1) + Ax * (x-Ax)**ax
power_xA(m) += 1
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)
! First term = (x-Ax)**(ax+1)
integral = NAI_pol_mult_erf(A_center, B_center, power_xA, power_B, alpha, beta, C_center, n_pt_in, mu_in)
ints(m) += integral * coef
! Second term = Ax * (x-Ax)**(ax)
integral = NAI_pol_mult_erf(A_center, B_center, power_A, power_B, alpha, beta, C_center, n_pt_in, mu_in)
ints(m) += A_center(m) * integral * coef
enddo
enddo
enddo
enddo
end
end subroutine NAI_pol_x_mult_erf_ao
! ---
subroutine NAI_pol_x_mult_erf_ao_with1s(i_ao, j_ao, beta, B_center, mu_in, C_center, ints)
BEGIN_DOC
!
! Computes the following integral :
!
! $\int_{-\infty}^{infty} dr x * \chi_i(r) \chi_j(r) e^{-\beta (r - B_center)^2} \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
! $\int_{-\infty}^{infty} dr y * \chi_i(r) \chi_j(r) e^{-\beta (r - B_center)^2} \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
! $\int_{-\infty}^{infty} dr z * \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(3)
integer :: i, j, power_Ai(3), power_Aj(3), n_pt_in, power_xA(3), m
double precision :: Ai_center(3), Aj_center(3), integral, alphai, alphaj, coef, coefi
double precision, external :: NAI_pol_mult_erf_with1s
ASSERT(beta .ge. 0.d0)
if(beta .lt. 1d-10) then
call NAI_pol_x_mult_erf_ao(i_ao, j_ao, mu_in, C_center, ints)
return
endif
ints = 0.d0
if(ao_overlap_abs(j_ao,i_ao) .lt. 1.d-12) then
return
endif
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 m = 1, 3
! x * phi_i(r) = x * (x-Ax)**ax = (x-Ax)**(ax+1) + Ax * (x-Ax)**ax
power_xA = power_Ai
power_xA(m) += 1
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)
! First term = (x-Ax)**(ax+1)
integral = NAI_pol_mult_erf_with1s( Ai_center, Aj_center, power_xA, power_Aj, alphai, alphaj &
, beta, B_center, C_center, n_pt_in, mu_in )
ints(m) += integral * coef
! Second term = Ax * (x-Ax)**(ax)
integral = 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(m) += Ai_center(m) * integral * coef
enddo
enddo
enddo
end subroutine NAI_pol_x_mult_erf_ao_with1s
! ---
subroutine NAI_pol_x_specify_mult_erf_ao(i_ao,j_ao,mu_in,C_center,m,ints)
implicit none
@ -249,7 +380,6 @@ subroutine NAI_pol_x_specify_mult_erf_ao(i_ao,j_ao,mu_in,C_center,m,ints)
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)
power_xA = power_A
@ -267,3 +397,5 @@ subroutine NAI_pol_x_specify_mult_erf_ao(i_ao,j_ao,mu_in,C_center,m,ints)
enddo
end
! ---

148
src/ao_many_one_e_ints/ao_gaus_gauss.irp.f
View File

@ -102,36 +102,124 @@ subroutine overlap_gauss_r12_all_ao(D_center,delta,aos_ints)
enddo
end
double precision function overlap_gauss_r12_ao(D_center,delta,i,j)
implicit none
BEGIN_DOC
! \int dr AO_i(r) AO_j(r) e^{-delta |r-D_center|^2}
END_DOC
integer, intent(in) :: i,j
double precision, intent(in) :: D_center(3), delta
! ---
integer :: num_a,num_b,power_A(3), power_B(3),l,k
double precision :: A_center(3), B_center(3),overlap_gauss_r12,alpha,beta,analytical_j
overlap_gauss_r12_ao = 0.d0
if(ao_overlap_abs(j,i).lt.1.d-12)then
return
endif
! TODO :: PUT CYCLES IN LOOPS
num_A = ao_nucl(i)
power_A(1:3)= ao_power(i,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
num_B = ao_nucl(j)
power_B(1:3)= ao_power(j,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l=1,ao_prim_num(i)
alpha = ao_expo_ordered_transp(l,i)
do k=1,ao_prim_num(j)
beta = ao_expo_ordered_transp(k,j)
analytical_j = overlap_gauss_r12(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta)
overlap_gauss_r12_ao += analytical_j * ao_coef_normalized_ordered_transp(l,i) &
* ao_coef_normalized_ordered_transp(k,j)
enddo
enddo
end
! TODO :: PUT CYCLES IN LOOPS
double precision function overlap_gauss_r12_ao(D_center, delta, i, j)
BEGIN_DOC
! \int dr AO_i(r) AO_j(r) e^{-delta |r-D_center|^2}
END_DOC
implicit none
integer, intent(in) :: i, j
double precision, intent(in) :: D_center(3), delta
integer :: power_A(3), power_B(3), l, k
double precision :: A_center(3), B_center(3), alpha, beta, coef, coef1, analytical_j
double precision, external :: overlap_gauss_r12
overlap_gauss_r12_ao = 0.d0
if(ao_overlap_abs(j,i).lt.1.d-12) then
return
endif
power_A(1:3) = ao_power(i,1:3)
power_B(1:3) = ao_power(j,1:3)
A_center(1:3) = nucl_coord(ao_nucl(i),1:3)
B_center(1:3) = nucl_coord(ao_nucl(j),1:3)
do l = 1, ao_prim_num(i)
alpha = ao_expo_ordered_transp (l,i)
coef1 = ao_coef_normalized_ordered_transp(l,i)
do k = 1, ao_prim_num(j)
beta = ao_expo_ordered_transp(k,j)
coef = coef1 * ao_coef_normalized_ordered_transp(k,j)
if(dabs(coef) .lt. 1d-12) cycle
analytical_j = overlap_gauss_r12(D_center, delta, A_center, B_center, power_A, power_B, alpha, beta)
overlap_gauss_r12_ao += coef * analytical_j
enddo
enddo
end function overlap_gauss_r12_ao
! ---
double precision function overlap_gauss_r12_ao_with1s(B_center, beta, D_center, delta, i, j)
BEGIN_DOC
!
! \int dr AO_i(r) AO_j(r) e^{-beta |r-B_center^2|} e^{-delta |r-D_center|^2}
!
END_DOC
implicit none
integer, intent(in) :: i, j
double precision, intent(in) :: B_center(3), beta, D_center(3), delta
integer :: power_A1(3), power_A2(3), l, k
double precision :: A1_center(3), A2_center(3), alpha1, alpha2, coef1, coef12, analytical_j
double precision :: G_center(3), gama, fact_g, gama_inv
double precision, external :: overlap_gauss_r12, overlap_gauss_r12_ao
ASSERT(beta .gt. 0.d0)
if(beta .lt. 1d-10) then
overlap_gauss_r12_ao_with1s = overlap_gauss_r12_ao(D_center, delta, i, j)
return
endif
overlap_gauss_r12_ao_with1s = 0.d0
if(ao_overlap_abs(j,i) .lt. 1.d-12) then
return
endif
! e^{-beta |r-B_center^2|} e^{-delta |r-D_center|^2} = fact_g e^{-gama |r - G|^2}
gama = beta + delta
gama_inv = 1.d0 / gama
G_center(1) = (beta * B_center(1) + delta * D_center(1)) * gama_inv
G_center(2) = (beta * B_center(2) + delta * D_center(2)) * gama_inv
G_center(3) = (beta * B_center(3) + delta * D_center(3)) * gama_inv
fact_g = beta * delta * gama_inv * ( (B_center(1) - D_center(1)) * (B_center(1) - D_center(1)) &
+ (B_center(2) - D_center(2)) * (B_center(2) - D_center(2)) &
+ (B_center(3) - D_center(3)) * (B_center(3) - D_center(3)) )
if(fact_g .gt. 80d0) return
fact_g = dexp(-fact_g)
! ---
power_A1(1:3) = ao_power(i,1:3)
power_A2(1:3) = ao_power(j,1:3)
A1_center(1:3) = nucl_coord(ao_nucl(i),1:3)
A2_center(1:3) = nucl_coord(ao_nucl(j),1:3)
do l = 1, ao_prim_num(i)
alpha1 = ao_expo_ordered_transp (l,i)
coef1 = fact_g * ao_coef_normalized_ordered_transp(l,i)
!if(dabs(coef1) .lt. 1d-12) cycle
do k = 1, ao_prim_num(j)
alpha2 = ao_expo_ordered_transp (k,j)
coef12 = coef1 * ao_coef_normalized_ordered_transp(k,j)
if(dabs(coef12) .lt. 1d-12) cycle
analytical_j = overlap_gauss_r12(G_center, gama, A1_center, A2_center, power_A1, power_A2, alpha1, alpha2)
overlap_gauss_r12_ao_with1s += coef12 * analytical_j
enddo
enddo
end function overlap_gauss_r12_ao_with1s
! ---

571
src/ao_many_one_e_ints/grad_related_ints.irp.f
View File

@ -1,342 +1,417 @@
BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu, ( ao_num, ao_num,n_points_final_grid)]
implicit none
BEGIN_DOC
! int dr phi_i(r) phi_j(r) (erf(mu(R) |r - R| - 1)/|r - R|
END_DOC
integer :: i,j,ipoint
double precision :: mu,r(3),NAI_pol_mult_erf_ao
double precision :: int_mu, int_coulomb
provide mu_erf final_grid_points
double precision :: wall0, wall1
call wall_time(wall0)
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,ipoint,mu,r,int_mu,int_coulomb) &
!$OMP SHARED (ao_num,n_points_final_grid,v_ij_erf_rk_cst_mu,final_grid_points,mu_erf)
! ---
BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu, (ao_num, ao_num, n_points_final_grid)]
BEGIN_DOC
!
! int dr phi_i(r) phi_j(r) (erf(mu(R) |r - R| - 1) / |r - R|
!
END_DOC
implicit none
integer :: i, j, ipoint
double precision :: r(3)
double precision :: int_mu, int_coulomb
double precision :: wall0, wall1
double precision :: NAI_pol_mult_erf_ao
provide mu_erf final_grid_points
call wall_time(wall0)
v_ij_erf_rk_cst_mu = 0.d0
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, ipoint, r, int_mu, int_coulomb) &
!$OMP SHARED (ao_num, n_points_final_grid, v_ij_erf_rk_cst_mu, final_grid_points, mu_erf)
!$OMP DO SCHEDULE (dynamic)
do ipoint = 1, n_points_final_grid
do i = 1, ao_num
do j = i, ao_num
mu = mu_erf
r(1) = final_grid_points(1,ipoint)
r(2) = final_grid_points(2,ipoint)
r(3) = final_grid_points(3,ipoint)
int_mu = NAI_pol_mult_erf_ao(i,j,mu,r)
int_coulomb = NAI_pol_mult_erf_ao(i,j,1.d+9,r)
v_ij_erf_rk_cst_mu(j,i,ipoint)= (int_mu - int_coulomb )
enddo
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)
do i = 1, ao_num
do j = i, ao_num
int_mu = NAI_pol_mult_erf_ao(i, j, mu_erf, r)
int_coulomb = NAI_pol_mult_erf_ao(i, j, 1.d+9, r)
v_ij_erf_rk_cst_mu(j,i,ipoint) = int_mu - int_coulomb
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
do ipoint = 1, n_points_final_grid
do i = 1, ao_num
do j = 1, i-1
v_ij_erf_rk_cst_mu(j,i,ipoint)= v_ij_erf_rk_cst_mu(i,j,ipoint)
do ipoint = 1, n_points_final_grid
do i = 2, ao_num
do j = 1, i-1
v_ij_erf_rk_cst_mu(j,i,ipoint) = v_ij_erf_rk_cst_mu(i,j,ipoint)
enddo
enddo
enddo
enddo
call wall_time(wall1)
print*, ' wall time for v_ij_erf_rk_cst_mu ', wall1 - wall0
call wall_time(wall1)
print*,'wall time for v_ij_erf_rk_cst_mu ',wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_transp, (n_points_final_grid, ao_num, ao_num)]
implicit none
BEGIN_DOC
! int dr phi_i(r) phi_j(r) (erf(mu(R) |r - R| - 1)/|r - R|
END_DOC
integer :: i,j,ipoint
double precision :: mu,r(3),NAI_pol_mult_erf_ao
double precision :: int_mu, int_coulomb
provide mu_erf final_grid_points
double precision :: wall0, wall1
call wall_time(wall0)
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,ipoint,mu,r,int_mu,int_coulomb) &
BEGIN_DOC
! int dr phi_i(r) phi_j(r) (erf(mu(R) |r - R| - 1)/|r - R|
END_DOC
implicit none
integer :: i, j, ipoint
double precision :: r(3)
double precision :: int_mu, int_coulomb
double precision :: wall0, wall1
double precision :: NAI_pol_mult_erf_ao
provide mu_erf final_grid_points
call wall_time(wall0)
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,ipoint,r,int_mu,int_coulomb) &
!$OMP SHARED (ao_num,n_points_final_grid,v_ij_erf_rk_cst_mu_transp,final_grid_points,mu_erf)
!$OMP DO SCHEDULE (dynamic)
do i = 1, ao_num
do j = i, ao_num
do ipoint = 1, n_points_final_grid
mu = mu_erf
r(1) = final_grid_points(1,ipoint)
r(2) = final_grid_points(2,ipoint)
r(3) = final_grid_points(3,ipoint)
int_mu = NAI_pol_mult_erf_ao(i,j,mu,r)
int_coulomb = NAI_pol_mult_erf_ao(i,j,1.d+9,r)
v_ij_erf_rk_cst_mu_transp(ipoint,j,i)= (int_mu - int_coulomb )
enddo
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)
do i = 1, ao_num
do j = i, ao_num
int_mu = NAI_pol_mult_erf_ao(i, j, mu_erf, r)
int_coulomb = NAI_pol_mult_erf_ao(i, j, 1.d+9, r)
v_ij_erf_rk_cst_mu_transp(ipoint,j,i) = int_mu - int_coulomb
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
do i = 1, ao_num
do j = 1, i-1
do ipoint = 1, n_points_final_grid
v_ij_erf_rk_cst_mu_transp(ipoint,j,i)= v_ij_erf_rk_cst_mu_transp(ipoint,i,j)
do i = 2, ao_num
do j = 1, i-1
do ipoint = 1, n_points_final_grid
v_ij_erf_rk_cst_mu_transp(ipoint,j,i) = v_ij_erf_rk_cst_mu_transp(ipoint,i,j)
enddo
enddo
enddo
enddo
call wall_time(wall1)
print*,'wall time for v_ij_erf_rk_cst_mu_transp ',wall1 - wall0
call wall_time(wall1)
print *, ' wall time for v_ij_erf_rk_cst_mu_transp ', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_tmp, (3,ao_num, ao_num,n_points_final_grid)]
implicit none
BEGIN_DOC
! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/|r - R|
END_DOC
integer :: i,j,ipoint,m
double precision :: mu,r(3),ints(3),ints_coulomb(3)
double precision :: wall0, wall1
call wall_time(wall0)
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,ipoint,mu,r,ints,m,ints_coulomb) &
BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_tmp, (3, ao_num, ao_num, n_points_final_grid)]
BEGIN_DOC
! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/|r - R|
END_DOC
implicit none
integer :: i, j, ipoint
double precision :: r(3), ints(3), ints_coulomb(3)
double precision :: wall0, wall1
call wall_time(wall0)
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,ipoint,r,ints,ints_coulomb) &
!$OMP SHARED (ao_num,n_points_final_grid,x_v_ij_erf_rk_cst_mu_tmp,final_grid_points,mu_erf)
!$OMP DO SCHEDULE (dynamic)
do ipoint = 1, n_points_final_grid
do i = 1, ao_num
do j = i, ao_num
mu = mu_erf
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)
call NAI_pol_x_mult_erf_ao(i,j,mu,r,ints)
call NAI_pol_x_mult_erf_ao(i,j,1.d+9,r,ints_coulomb)
do m = 1, 3
x_v_ij_erf_rk_cst_mu_tmp(m,j,i,ipoint) = ( ints(m) - ints_coulomb(m))
do i = 1, ao_num
do j = i, ao_num
call NAI_pol_x_mult_erf_ao(i, j, mu_erf, r, ints )
call NAI_pol_x_mult_erf_ao(i, j, 1.d+9 , r, ints_coulomb)
x_v_ij_erf_rk_cst_mu_tmp(1,j,i,ipoint) = ints(1) - ints_coulomb(1)
x_v_ij_erf_rk_cst_mu_tmp(2,j,i,ipoint) = ints(2) - ints_coulomb(2)
x_v_ij_erf_rk_cst_mu_tmp(3,j,i,ipoint) = ints(3) - ints_coulomb(3)
enddo
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
do ipoint = 1, n_points_final_grid
do i = 1, ao_num
do j = 1, i-1
do m = 1, 3
x_v_ij_erf_rk_cst_mu_tmp(m,j,i,ipoint)= x_v_ij_erf_rk_cst_mu_tmp(m,i,j,ipoint)
do ipoint = 1, n_points_final_grid
do i = 2, ao_num
do j = 1, i-1
x_v_ij_erf_rk_cst_mu_tmp(1,j,i,ipoint) = x_v_ij_erf_rk_cst_mu_tmp(1,i,j,ipoint)
x_v_ij_erf_rk_cst_mu_tmp(2,j,i,ipoint) = x_v_ij_erf_rk_cst_mu_tmp(2,i,j,ipoint)
x_v_ij_erf_rk_cst_mu_tmp(3,j,i,ipoint) = x_v_ij_erf_rk_cst_mu_tmp(3,i,j,ipoint)
enddo
enddo
enddo
enddo
enddo
call wall_time(wall1)
print*,'wall time for x_v_ij_erf_rk_cst_mu_tmp',wall1 - wall0
call wall_time(wall1)
print*, ' wall time for x_v_ij_erf_rk_cst_mu_tmp', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu, (ao_num, ao_num,n_points_final_grid,3)]
implicit none
BEGIN_DOC
! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/|r - R|
END_DOC
integer :: i,j,ipoint,m
double precision :: mu,r(3),ints,ints_coulomb
double precision :: wall0, wall1
call wall_time(wall0)
do ipoint = 1, n_points_final_grid
do i = 1, ao_num
do j = 1, ao_num
do m = 1, 3
x_v_ij_erf_rk_cst_mu(j,i,ipoint,m)= x_v_ij_erf_rk_cst_mu_tmp(m,j,i,ipoint)
enddo
enddo
enddo
enddo
call wall_time(wall1)
print*,'wall time for x_v_ij_erf_rk_cst_mu',wall1 - wall0
BEGIN_DOC
! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/|r - R|
END_DOC
implicit none
integer :: i, j, ipoint
double precision :: wall0, wall1
call wall_time(wall0)
do ipoint = 1, n_points_final_grid
do i = 1, ao_num
do j = 1, ao_num
x_v_ij_erf_rk_cst_mu(j,i,ipoint,1) = x_v_ij_erf_rk_cst_mu_tmp(1,j,i,ipoint)
x_v_ij_erf_rk_cst_mu(j,i,ipoint,2) = x_v_ij_erf_rk_cst_mu_tmp(2,j,i,ipoint)
x_v_ij_erf_rk_cst_mu(j,i,ipoint,3) = x_v_ij_erf_rk_cst_mu_tmp(3,j,i,ipoint)
enddo
enddo
enddo
call wall_time(wall1)
print *, ' wall time for x_v_ij_erf_rk_cst_mu', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_transp, (ao_num, ao_num,3,n_points_final_grid)]
implicit none
BEGIN_DOC
! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/|r - R|
END_DOC
integer :: i,j,ipoint,m
double precision :: mu,r(3),ints,ints_coulomb
double precision :: wall0, wall1
call wall_time(wall0)
do ipoint = 1, n_points_final_grid
do m = 1, 3
do i = 1, ao_num
do j = 1, ao_num
x_v_ij_erf_rk_cst_mu_transp(j,i,m,ipoint)= x_v_ij_erf_rk_cst_mu_tmp(m,j,i,ipoint)
enddo
enddo
enddo
enddo
call wall_time(wall1)
print*,'wall time for x_v_ij_erf_rk_cst_mu_transp',wall1 - wall0
BEGIN_DOC
! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/|r - R|
END_DOC
implicit none
integer :: i, j, ipoint
double precision :: wall0, wall1
call wall_time(wall0)
do ipoint = 1, n_points_final_grid
do i = 1, ao_num
do j = 1, ao_num
x_v_ij_erf_rk_cst_mu_transp(j,i,1,ipoint) = x_v_ij_erf_rk_cst_mu_tmp(1,j,i,ipoint)
x_v_ij_erf_rk_cst_mu_transp(j,i,2,ipoint) = x_v_ij_erf_rk_cst_mu_tmp(2,j,i,ipoint)
x_v_ij_erf_rk_cst_mu_transp(j,i,3,ipoint) = x_v_ij_erf_rk_cst_mu_tmp(3,j,i,ipoint)
enddo
enddo
enddo
call wall_time(wall1)
print *, ' wall time for x_v_ij_erf_rk_cst_mu_transp', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_transp_bis, (n_points_final_grid,ao_num, ao_num,3)]
implicit none
BEGIN_DOC
! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/|r - R|
END_DOC
integer :: i,j,ipoint,m
double precision :: mu,r(3),ints,ints_coulomb
double precision :: wall0, wall1
call wall_time(wall0)
do m = 1, 3
do i = 1, ao_num
do j = 1, ao_num
do ipoint = 1, n_points_final_grid
x_v_ij_erf_rk_cst_mu_transp_bis(ipoint,j,i,m)= x_v_ij_erf_rk_cst_mu_tmp(m,j,i,ipoint)
enddo
enddo
enddo
enddo
call wall_time(wall1)
print*,'wall time for x_v_ij_erf_rk_cst_mu_transp',wall1 - wall0
BEGIN_DOC
! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/|r - R|
END_DOC
implicit none
integer :: i, j, ipoint
double precision :: wall0, wall1
call wall_time(wall0)
do i = 1, ao_num
do j = 1, ao_num
do ipoint = 1, n_points_final_grid
x_v_ij_erf_rk_cst_mu_transp_bis(ipoint,j,i,1) = x_v_ij_erf_rk_cst_mu_tmp(1,j,i,ipoint)
x_v_ij_erf_rk_cst_mu_transp_bis(ipoint,j,i,2) = x_v_ij_erf_rk_cst_mu_tmp(2,j,i,ipoint)
x_v_ij_erf_rk_cst_mu_transp_bis(ipoint,j,i,3) = x_v_ij_erf_rk_cst_mu_tmp(3,j,i,ipoint)
enddo
enddo
enddo
call wall_time(wall1)
print *, ' wall time for x_v_ij_erf_rk_cst_mu_transp_bis', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, d_dx_v_ij_erf_rk_cst_mu_tmp, (3, n_points_final_grid, ao_num, ao_num)]
BEGIN_DOC
! d_dx_v_ij_erf_rk_cst_mu_tmp(m,R,j,i) = int dr phi_j(r)) (erf(mu(R) |r - R|) - 1)/|r - R| d/dx (phi_i(r)
!
! with m == 1 -> d/dx , m == 2 -> d/dy , m == 3 -> d/dz
END_DOC
BEGIN_PROVIDER [ double precision, d_dx_v_ij_erf_rk_cst_mu_tmp, (3,n_points_final_grid,ao_num, ao_num)]
implicit none
BEGIN_DOC
! d_dx_v_ij_erf_rk_cst_mu_tmp(m,R,j,i) = int dr phi_j(r)) (erf(mu(R) |r - R|) - 1)/|r - R| d/dx (phi_i(r)
!
! with m == 1 -> d/dx , m == 2 -> d/dy , m == 3 -> d/dz
END_DOC
integer :: i,j,ipoint,m
double precision :: mu,r(3),ints(3),ints_coulomb(3)
integer :: i, j, ipoint
double precision :: r(3), ints(3), ints_coulomb(3)
double precision :: wall0, wall1
call wall_time(wall0)
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,ipoint,mu,r,ints,m,ints_coulomb) &
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,ipoint,r,ints,ints_coulomb) &
!$OMP SHARED (ao_num,n_points_final_grid,d_dx_v_ij_erf_rk_cst_mu_tmp,final_grid_points,mu_erf)
!$OMP DO SCHEDULE (dynamic)
do i = 1, ao_num
do j = 1, ao_num
do ipoint = 1, n_points_final_grid
mu = mu_erf
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)
call phi_j_erf_mu_r_dxyz_phi(j,i,mu, r, ints)
call phi_j_erf_mu_r_dxyz_phi(j,i,1.d+9, r, ints_coulomb)
do m = 1, 3
d_dx_v_ij_erf_rk_cst_mu_tmp(m,ipoint,j,i) = ( ints(m) - ints_coulomb(m))
do i = 1, ao_num
do j = 1, ao_num
call phi_j_erf_mu_r_dxyz_phi(j, i, mu_erf, r, ints)
call phi_j_erf_mu_r_dxyz_phi(j, i, 1.d+9, r, ints_coulomb)
d_dx_v_ij_erf_rk_cst_mu_tmp(1,ipoint,j,i) = ints(1) - ints_coulomb(1)
d_dx_v_ij_erf_rk_cst_mu_tmp(2,ipoint,j,i) = ints(2) - ints_coulomb(2)
d_dx_v_ij_erf_rk_cst_mu_tmp(3,ipoint,j,i) = ints(3) - ints_coulomb(3)
enddo
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print*,'wall time for d_dx_v_ij_erf_rk_cst_mu_tmp',wall1 - wall0
call wall_time(wall1)
print *, ' wall time for d_dx_v_ij_erf_rk_cst_mu_tmp', wall1 - wall0
END_PROVIDER
BEGIN_PROVIDER [ double precision, d_dx_v_ij_erf_rk_cst_mu, (n_points_final_grid,ao_num, ao_num,3)]
implicit none
BEGIN_DOC
! d_dx_v_ij_erf_rk_cst_mu_tmp(j,i,R,m) = int dr phi_j(r)) (erf(mu(R) |r - R|) - 1)/|r - R| d/dx (phi_i(r)
!
! with m == 1 -> d/dx , m == 2 -> d/dy , m == 3 -> d/dz
END_DOC
integer :: i,j,ipoint,m
double precision :: mu,r(3),ints,ints_coulomb
double precision :: wall0, wall1
call wall_time(wall0)
do i = 1, ao_num
do j = 1, ao_num
do m = 1, 3
do ipoint = 1, n_points_final_grid
d_dx_v_ij_erf_rk_cst_mu(ipoint,j,i,m)= d_dx_v_ij_erf_rk_cst_mu_tmp(m,ipoint,j,i)
! ---
BEGIN_PROVIDER [ double precision, d_dx_v_ij_erf_rk_cst_mu, (n_points_final_grid, ao_num, ao_num, 3)]
BEGIN_DOC
!
! d_dx_v_ij_erf_rk_cst_mu_tmp(j,i,R,m) = int dr phi_j(r)) (erf(mu(R) |r - R|) - 1)/|r - R| d/dx (phi_i(r)
!
! with m == 1 -> d/dx , m == 2 -> d/dy , m == 3 -> d/dz
!
END_DOC
implicit none
integer :: i, j, ipoint
double precision :: wall0, wall1
call wall_time(wall0)
do i = 1, ao_num
do j = 1, ao_num
do ipoint = 1, n_points_final_grid
d_dx_v_ij_erf_rk_cst_mu(ipoint,j,i,1) = d_dx_v_ij_erf_rk_cst_mu_tmp(1,ipoint,j,i)
d_dx_v_ij_erf_rk_cst_mu(ipoint,j,i,2) = d_dx_v_ij_erf_rk_cst_mu_tmp(2,ipoint,j,i)
d_dx_v_ij_erf_rk_cst_mu(ipoint,j,i,3) = d_dx_v_ij_erf_rk_cst_mu_tmp(3,ipoint,j,i)
enddo
enddo
enddo
enddo
enddo
call wall_time(wall1)
print*,'wall time for d_dx_v_ij_erf_rk_cst_mu',wall1 - wall0
call wall_time(wall1)
print *, ' wall time for d_dx_v_ij_erf_rk_cst_mu', wall1 - wall0
END_PROVIDER
BEGIN_PROVIDER [ double precision, x_d_dx_v_ij_erf_rk_cst_mu_tmp, (3,n_points_final_grid,ao_num, ao_num)]
implicit none
BEGIN_DOC
! x_d_dx_v_ij_erf_rk_cst_mu_tmp(m,j,i,R) = int dr x phi_j(r)) (erf(mu(R) |r - R|) - 1)/|r - R| d/dx (phi_i(r)
!
! with m == 1 -> d/dx , m == 2 -> d/dy , m == 3 -> d/dz
END_DOC
integer :: i,j,ipoint,m
double precision :: mu,r(3),ints(3),ints_coulomb(3)
double precision :: wall0, wall1
call wall_time(wall0)
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,ipoint,mu,r,ints,m,ints_coulomb) &
! ---
BEGIN_PROVIDER [ double precision, x_d_dx_v_ij_erf_rk_cst_mu_tmp, (3, n_points_final_grid, ao_num, ao_num)]
BEGIN_DOC
!
! x_d_dx_v_ij_erf_rk_cst_mu_tmp(m,j,i,R) = int dr x phi_j(r)) (erf(mu(R) |r - R|) - 1)/|r - R| d/dx (phi_i(r)
!
! with m == 1 -> d/dx , m == 2 -> d/dy , m == 3 -> d/dz
!
END_DOC
implicit none
integer :: i, j, ipoint
double precision :: r(3), ints(3), ints_coulomb(3)
double precision :: wall0, wall1
call wall_time(wall0)
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,ipoint,r,ints,ints_coulomb) &
!$OMP SHARED (ao_num,n_points_final_grid,x_d_dx_v_ij_erf_rk_cst_mu_tmp,final_grid_points,mu_erf)
!$OMP DO SCHEDULE (dynamic)
do i = 1, ao_num
do j = 1, ao_num
do ipoint = 1, n_points_final_grid
mu = mu_erf
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)
call phi_j_erf_mu_r_xyz_dxyz_phi(j,i,mu, r, ints)
call phi_j_erf_mu_r_xyz_dxyz_phi(j,i,1.d+9, r, ints_coulomb)
do m = 1, 3
x_d_dx_v_ij_erf_rk_cst_mu_tmp(m,ipoint,j,i) = ( ints(m) - ints_coulomb(m))
do i = 1, ao_num
do j = 1, ao_num
call phi_j_erf_mu_r_xyz_dxyz_phi(j, i, mu_erf, r, ints)
call phi_j_erf_mu_r_xyz_dxyz_phi(j, i, 1.d+9, r, ints_coulomb)
x_d_dx_v_ij_erf_rk_cst_mu_tmp(1,ipoint,j,i) = ints(1) - ints_coulomb(1)
x_d_dx_v_ij_erf_rk_cst_mu_tmp(2,ipoint,j,i) = ints(2) - ints_coulomb(2)
x_d_dx_v_ij_erf_rk_cst_mu_tmp(3,ipoint,j,i) = ints(3) - ints_coulomb(3)
enddo
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print*,'wall time for x_d_dx_v_ij_erf_rk_cst_mu_tmp',wall1 - wall0
call wall_time(wall1)
print *, ' wall time for x_d_dx_v_ij_erf_rk_cst_mu_tmp', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, x_d_dx_v_ij_erf_rk_cst_mu, (n_points_final_grid,ao_num, ao_num,3)]
implicit none
BEGIN_DOC
! x_d_dx_v_ij_erf_rk_cst_mu_tmp(j,i,R,m) = int dr x phi_j(r)) (erf(mu(R) |r - R|) - 1)/|r - R| d/dx (phi_i(r)
!
! with m == 1 -> d/dx , m == 2 -> d/dy , m == 3 -> d/dz
END_DOC
integer :: i,j,ipoint,m
double precision :: mu,r(3),ints,ints_coulomb
double precision :: wall0, wall1
call wall_time(wall0)
do i = 1, ao_num
do j = 1, ao_num
do ipoint = 1, n_points_final_grid
do m = 1, 3
x_d_dx_v_ij_erf_rk_cst_mu(ipoint,j,i,m)= x_d_dx_v_ij_erf_rk_cst_mu_tmp(m,ipoint,j,i)
enddo
enddo
enddo
enddo
call wall_time(wall1)
print*,'wall time for x_d_dx_v_ij_erf_rk_cst_mu',wall1 - wall0
BEGIN_DOC
!
! x_d_dx_v_ij_erf_rk_cst_mu_tmp(j,i,R,m) = int dr x phi_j(r)) (erf(mu(R) |r - R|) - 1)/|r - R| d/dx (phi_i(r)
!
! with m == 1 -> d/dx , m == 2 -> d/dy , m == 3 -> d/dz
!
END_DOC
implicit none
integer :: i, j, ipoint
double precision :: wall0, wall1
call wall_time(wall0)
do i = 1, ao_num
do j = 1, ao_num
do ipoint = 1, n_points_final_grid
x_d_dx_v_ij_erf_rk_cst_mu(ipoint,j,i,1) = x_d_dx_v_ij_erf_rk_cst_mu_tmp(1,ipoint,j,i)
x_d_dx_v_ij_erf_rk_cst_mu(ipoint,j,i,2) = x_d_dx_v_ij_erf_rk_cst_mu_tmp(2,ipoint,j,i)
x_d_dx_v_ij_erf_rk_cst_mu(ipoint,j,i,3) = x_d_dx_v_ij_erf_rk_cst_mu_tmp(3,ipoint,j,i)
enddo
enddo
enddo
call wall_time(wall1)
print *, ' wall time for x_d_dx_v_ij_erf_rk_cst_mu', wall1 - wall0
END_PROVIDER
! ---

376
src/ao_one_e_ints/pot_ao_erf_ints.irp.f
View File

@ -1,3 +1,6 @@
! ---
subroutine give_all_erf_kl_ao(integrals_ao,mu_in,C_center)
implicit none
BEGIN_DOC
@ -15,142 +18,331 @@ subroutine give_all_erf_kl_ao(integrals_ao,mu_in,C_center)
enddo
end
! ---
double precision function NAI_pol_mult_erf_ao(i_ao, j_ao, mu_in, C_center)
double precision function NAI_pol_mult_erf_ao(i_ao,j_ao,mu_in,C_center)
implicit none
BEGIN_DOC
!
! Computes the following integral :
! $\int_{-\infty}^{infty} dr \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
! $\int_{-\infty}^{infty} dr \chi_i(r) \chi_j(r) \frac{\erf(\mu |r - R_C|)}{|r - R_C|}$.
!
END_DOC
integer, intent(in) :: i_ao,j_ao
implicit none
integer, intent(in) :: i_ao, j_ao
double precision, intent(in) :: mu_in, C_center(3)
integer :: i,j,num_A,num_B, power_A(3), power_B(3), n_pt_in
double precision :: A_center(3), B_center(3),integral, alpha,beta
integer :: i, j, num_A, num_B, power_A(3), power_B(3), n_pt_in
double precision :: A_center(3), B_center(3), integral, alpha, beta
double precision :: NAI_pol_mult_erf
num_A = ao_nucl(i_ao)
power_A(1:3)= ao_power(i_ao,1:3)
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)
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
NAI_pol_mult_erf_ao = 0.d0
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)
integral = NAI_pol_mult_erf(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in,mu_in)
NAI_pol_mult_erf_ao += integral * ao_coef_normalized_ordered_transp(j,j_ao)*ao_coef_normalized_ordered_transp(i,i_ao)
integral = NAI_pol_mult_erf(A_center, B_center, power_A, power_B, alpha, beta, C_center, n_pt_in,mu_in)
NAI_pol_mult_erf_ao += integral * ao_coef_normalized_ordered_transp(j,j_ao) * ao_coef_normalized_ordered_transp(i,i_ao)
enddo
enddo
end
end function NAI_pol_mult_erf_ao
! ---
double precision function NAI_pol_mult_erf_ao_with1s(i_ao, j_ao, beta, B_center, mu_in, C_center)
double precision function NAI_pol_mult_erf(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in,mu_in)
BEGIN_DOC
!
! Computes the following integral :
! $\int_{-\infty}^{infty} dr \chi_i(r) \chi_j(r) e^{-\beta (r - B_center)^2} \frac{\erf(\mu |r - R_C|)}{|r - R_C|}$.
!
END_DOC
implicit none
integer, intent(in) :: i_ao, j_ao
double precision, intent(in) :: beta, B_center(3)
double precision, intent(in) :: mu_in, C_center(3)
integer :: i, j, power_A1(3), power_A2(3), n_pt_in
double precision :: A1_center(3), A2_center(3), alpha1, alpha2, coef12, coef1, integral
double precision, external :: NAI_pol_mult_erf_with1s, NAI_pol_mult_erf_ao
ASSERT(beta .ge. 0.d0)
if(beta .lt. 1d-10) then
NAI_pol_mult_erf_ao_with1s = NAI_pol_mult_erf_ao(i_ao, j_ao, mu_in, C_center)
return
endif
power_A1(1:3) = ao_power(i_ao,1:3)
power_A2(1:3) = ao_power(j_ao,1:3)
A1_center(1:3) = nucl_coord(ao_nucl(i_ao),1:3)
A2_center(1:3) = nucl_coord(ao_nucl(j_ao),1:3)
n_pt_in = n_pt_max_integrals
NAI_pol_mult_erf_ao_with1s = 0.d0
do i = 1, ao_prim_num(i_ao)
alpha1 = ao_expo_ordered_transp (i,i_ao)
coef1 = ao_coef_normalized_ordered_transp(i,i_ao)
do j = 1, ao_prim_num(j_ao)
alpha2 = ao_expo_ordered_transp(j,j_ao)
coef12 = coef1 * ao_coef_normalized_ordered_transp(j,j_ao)
if(dabs(coef12) .lt. 1d-14) cycle
integral = NAI_pol_mult_erf_with1s( A1_center, A2_center, power_A1, power_A2, alpha1, alpha2 &
, beta, B_center, C_center, n_pt_in, mu_in )
NAI_pol_mult_erf_ao_with1s += integral * coef12
enddo
enddo
end function NAI_pol_mult_erf_ao_with1s
! ---
double precision function NAI_pol_mult_erf(A_center, B_center, power_A, power_B, alpha, beta, C_center, n_pt_in, mu_in)
BEGIN_DOC
!
! Computes the following integral :
!
! .. math::
!
! \int dr (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
! \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
! \frac{\erf(\mu |r - R_C |)}{| r - R_C |}$.
!
END_DOC
implicit none
integer, intent(in) :: n_pt_in
double precision,intent(in) :: C_center(3),A_center(3),B_center(3),alpha,beta,mu_in
integer, intent(in) :: power_A(3),power_B(3)
integer :: i,j,k,l,n_pt
double precision :: P_center(3)
double precision :: d(0:n_pt_in),pouet,coeff,dist,const,pouet_2,factor
double precision :: I_n_special_exact,integrate_bourrin,I_n_bibi
double precision :: V_e_n,const_factor,dist_integral,tmp
double precision :: accu,rint,p_inv,p,rho,p_inv_2
integer :: n_pt_out,lmax
include 'utils/constants.include.F'
p = alpha + beta
p_inv = 1.d0/p
p_inv_2 = 0.5d0 * p_inv
rho = alpha * beta * p_inv
dist = 0.d0
implicit none
integer, intent(in) :: n_pt_in
integer, intent(in) :: power_A(3), power_B(3)
double precision, intent(in) :: C_center(3), A_center(3), B_center(3), alpha, beta, mu_in
integer :: i, n_pt, n_pt_out
double precision :: P_center(3)
double precision :: d(0:n_pt_in), coeff, dist, const, factor
double precision :: const_factor, dist_integral
double precision :: accu, p_inv, p, rho, p_inv_2
double precision :: p_new
double precision :: rint
p = alpha + beta
p_inv = 1.d0 / p
p_inv_2 = 0.5d0 * p_inv
rho = alpha * beta * p_inv
dist = 0.d0
dist_integral = 0.d0
do i = 1, 3
P_center(i) = (alpha * A_center(i) + beta * B_center(i)) * p_inv
dist += (A_center(i) - B_center(i))*(A_center(i) - B_center(i))
dist_integral += (P_center(i) - C_center(i))*(P_center(i) - C_center(i))
P_center(i) = (alpha * A_center(i) + beta * B_center(i)) * p_inv
dist += (A_center(i) - B_center(i)) * (A_center(i) - B_center(i))
dist_integral += (P_center(i) - C_center(i)) * (P_center(i) - C_center(i))
enddo
const_factor = dist*rho
if(const_factor > 80.d0)then
const_factor = dist * rho
if(const_factor > 80.d0) then
NAI_pol_mult_erf = 0.d0
return
endif
double precision :: p_new
p_new = mu_in/dsqrt(p+ mu_in * mu_in)
factor = dexp(-const_factor)
coeff = dtwo_pi * factor * p_inv * p_new
lmax = 20
! print*, "b"
p_new = mu_in / dsqrt(p + mu_in * mu_in)
factor = dexp(-const_factor)
coeff = dtwo_pi * factor * p_inv * p_new
n_pt = 2 * ( (power_A(1) + power_B(1)) + (power_A(2) + power_B(2)) + (power_A(3) + power_B(3)) )
const = p * dist_integral * p_new * p_new
if(n_pt == 0) then
NAI_pol_mult_erf = coeff * rint(0, const)
return
endif
do i = 0, n_pt_in
d(i) = 0.d0
enddo
n_pt = 2 * ( (power_A(1) + power_B(1)) +(power_A(2) + power_B(2)) +(power_A(3) + power_B(3)) )
const = p * dist_integral * p_new * p_new
if (n_pt == 0) then
pouet = rint(0,const)
NAI_pol_mult_erf = coeff * pouet
return
endif
! call give_polynomial_mult_center_one_e_erf(A_center,B_center,alpha,beta,power_A,power_B,C_center,n_pt_in,d,n_pt_out,mu_in)
p_new = p_new * p_new
call give_polynomial_mult_center_one_e_erf_opt(A_center,B_center,alpha,beta,power_A,power_B,C_center,n_pt_in,d,n_pt_out,mu_in,p,p_inv,p_inv_2,p_new,P_center)
call give_polynomial_mult_center_one_e_erf_opt( A_center, B_center, power_A, power_B, C_center &
, n_pt_in, d, n_pt_out, p_inv_2, p_new, P_center)
if(n_pt_out<0)then
if(n_pt_out < 0) then
NAI_pol_mult_erf = 0.d0
return
endif
accu = 0.d0
! sum of integrals of type : int {t,[0,1]} exp-(rho.(P-Q)^2 * t^2) * t^i
do i =0 ,n_pt_out,2
accu += d(i) * rint(i/2,const)
accu = 0.d0
do i = 0, n_pt_out, 2
accu += d(i) * rint(i/2, const)
enddo
NAI_pol_mult_erf = accu * coeff
end
end function NAI_pol_mult_erf
! ---
double precision function NAI_pol_mult_erf_with1s( A1_center, A2_center, power_A1, power_A2, alpha1, alpha2 &
, beta, B_center, C_center, n_pt_in, mu_in )
BEGIN_DOC
!
! Computes the following integral :
!
! .. math::
!
! \int dx (x - A1_x)^a_1 (x - B1_x)^a_2 \exp(-\alpha_1 (x - A1_x)^2 - \alpha_2 (x - A2_x)^2)
! \int dy (y - A1_y)^b_1 (y - B1_y)^b_2 \exp(-\alpha_1 (y - A1_y)^2 - \alpha_2 (y - A2_y)^2)
! \int dz (x - A1_z)^c_1 (z - B1_z)^c_2 \exp(-\alpha_1 (z - A1_z)^2 - \alpha_2 (z - A2_z)^2)
! \exp(-\beta (r - B)^2)
! \frac{\erf(\mu |r - R_C|)}{|r - R_C|}$.
!
END_DOC
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: n_pt_in
integer, intent(in) :: power_A1(3), power_A2(3)
double precision, intent(in) :: C_center(3), A1_center(3), A2_center(3), B_center(3)
double precision, intent(in) :: alpha1, alpha2, beta, mu_in
integer :: i, n_pt, n_pt_out
double precision :: alpha12, alpha12_inv, alpha12_inv_2, rho12, A12_center(3), dist12, const_factor12
double precision :: p, p_inv, p_inv_2, rho, P_center(3), dist, const_factor
double precision :: dist_integral
double precision :: d(0:n_pt_in), coeff, const, factor
double precision :: accu
double precision :: p_new
double precision :: rint
subroutine give_polynomial_mult_center_one_e_erf_opt(A_center,B_center,alpha,beta,&
power_A,power_B,C_center,n_pt_in,d,n_pt_out,mu_in,p,p_inv,p_inv_2,p_new,P_center)
! e^{-alpha1 (r - A1)^2} e^{-alpha2 (r - A2)^2} = e^{-K12} e^{-alpha12 (r - A12)^2}
alpha12 = alpha1 + alpha2
alpha12_inv = 1.d0 / alpha12
alpha12_inv_2 = 0.5d0 * alpha12_inv
rho12 = alpha1 * alpha2 * alpha12_inv
A12_center(1) = (alpha1 * A1_center(1) + alpha2 * A2_center(1)) * alpha12_inv
A12_center(2) = (alpha1 * A1_center(2) + alpha2 * A2_center(2)) * alpha12_inv
A12_center(3) = (alpha1 * A1_center(3) + alpha2 * A2_center(3)) * alpha12_inv
dist12 = (A1_center(1) - A2_center(1)) * (A1_center(1) - A2_center(1)) &
+ (A1_center(2) - A2_center(2)) * (A1_center(2) - A2_center(2)) &
+ (A1_center(3) - A2_center(3)) * (A1_center(3) - A2_center(3))
const_factor12 = dist12 * rho12
if(const_factor12 > 80.d0) then
NAI_pol_mult_erf_with1s = 0.d0
return
endif
! ---
! e^{-K12} e^{-alpha12 (r - A12)^2} e^{-beta (r - B)^2} = e^{-K} e^{-p (r - P)^2}
p = alpha12 + beta
p_inv = 1.d0 / p
p_inv_2 = 0.5d0 * p_inv
rho = alpha12 * beta * p_inv
P_center(1) = (alpha12 * A12_center(1) + beta * B_center(1)) * p_inv
P_center(2) = (alpha12 * A12_center(2) + beta * B_center(2)) * p_inv
P_center(3) = (alpha12 * A12_center(3) + beta * B_center(3)) * p_inv
dist = (A12_center(1) - B_center(1)) * (A12_center(1) - B_center(1)) &
+ (A12_center(2) - B_center(2)) * (A12_center(2) - B_center(2)) &
+ (A12_center(3) - B_center(3)) * (A12_center(3) - B_center(3))
const_factor = const_factor12 + dist * rho
if(const_factor > 80.d0) then
NAI_pol_mult_erf_with1s = 0.d0
return
endif
dist_integral = (P_center(1) - C_center(1)) * (P_center(1) - C_center(1)) &
+ (P_center(2) - C_center(2)) * (P_center(2) - C_center(2)) &
+ (P_center(3) - C_center(3)) * (P_center(3) - C_center(3))
! ---
p_new = mu_in / dsqrt(p + mu_in * mu_in)
factor = dexp(-const_factor)
coeff = dtwo_pi * factor * p_inv * p_new
n_pt = 2 * ( (power_A1(1) + power_A2(1)) + (power_A1(2) + power_A2(2)) + (power_A1(3) + power_A2(3)) )
const = p * dist_integral * p_new * p_new
if(n_pt == 0) then
NAI_pol_mult_erf_with1s = coeff * rint(0, const)
return
endif
do i = 0, n_pt_in
d(i) = 0.d0
enddo
p_new = p_new * p_new
call give_polynomial_mult_center_one_e_erf_opt( A1_center, A2_center, power_A1, power_A2, C_center &
, n_pt_in, d, n_pt_out, p_inv_2, p_new, P_center)
if(n_pt_out < 0) then
NAI_pol_mult_erf_with1s = 0.d0
return
endif
! sum of integrals of type : int {t,[0,1]} exp-(rho.(P-Q)^2 * t^2) * t^i
accu = 0.d0
do i = 0, n_pt_out, 2
accu += d(i) * rint(i/2, const)
enddo
NAI_pol_mult_erf_with1s = accu * coeff
end function NAI_pol_mult_erf_with1s
! ---
subroutine give_polynomial_mult_center_one_e_erf_opt( A_center, B_center, power_A, power_B, C_center &
, n_pt_in, d, n_pt_out, p_inv_2, p_new, P_center)
BEGIN_DOC
! Returns the explicit polynomial in terms of the $t$ variable of the
! following polynomial:
!
! $I_{x1}(a_x, d_x,p,q) \times I_{x1}(a_y, d_y,p,q) \times I_{x1}(a_z, d_z,p,q)$.
END_DOC
implicit none
integer, intent(in) :: n_pt_in
integer,intent(out) :: n_pt_out
double precision, intent(in) :: A_center(3), B_center(3),C_center(3),p,p_inv,p_inv_2,p_new,P_center(3)
double precision, intent(in) :: alpha,beta,mu_in
integer, intent(in) :: power_A(3), power_B(3)
integer :: a_x,b_x,a_y,b_y,a_z,b_z
double precision :: d(0:n_pt_in)
double precision :: d1(0:n_pt_in)
double precision :: d2(0:n_pt_in)
double precision :: d3(0:n_pt_in)
double precision :: accu
integer, intent(in) :: n_pt_in
integer, intent(in) :: power_A(3), power_B(3)
double precision, intent(in) :: A_center(3), B_center(3), C_center(3), p_inv_2, p_new, P_center(3)
integer, intent(out) :: n_pt_out
double precision, intent(out) :: d(0:n_pt_in)
integer :: a_x, b_x, a_y, b_y, a_z, b_z
integer :: n_pt1, n_pt2, n_pt3, dim, i
integer :: n_pt_tmp
double precision :: d1(0:n_pt_in)
double precision :: d2(0:n_pt_in)
double precision :: d3(0:n_pt_in)
double precision :: accu
double precision :: R1x(0:2), B01(0:2), R1xp(0:2), R2x(0:2)
accu = 0.d0
ASSERT (n_pt_in > 1)
double precision :: R1x(0:2), B01(0:2), R1xp(0:2),R2x(0:2)
R1x(0) = (P_center(1) - A_center(1))
R1x(1) = 0.d0
R1x(2) = -(P_center(1) - C_center(1))* p_new
@ -161,27 +353,22 @@ subroutine give_polynomial_mult_center_one_e_erf_opt(A_center,B_center,alpha,bet
!R1xp = (P_x - B_x) - (P_x - C_x) ( t * mu/sqrt(p+mu^2) )^2
R2x(0) = p_inv_2
R2x(1) = 0.d0
R2x(2) = -p_inv_2* p_new
R2x(2) = -p_inv_2 * p_new
!R2x = 0.5 / p - 0.5/p ( t * mu/sqrt(p+mu^2) )^2
do i = 0,n_pt_in
d(i) = 0.d0
enddo
do i = 0,n_pt_in
do i = 0, n_pt_in
d (i) = 0.d0
d1(i) = 0.d0
enddo
do i = 0,n_pt_in
d2(i) = 0.d0
enddo
do i = 0,n_pt_in
d3(i) = 0.d0
enddo
integer :: n_pt1,n_pt2,n_pt3,dim,i
n_pt1 = n_pt_in
n_pt2 = n_pt_in
n_pt3 = n_pt_in
a_x = power_A(1)
b_x = power_B(1)
call I_x1_pol_mult_one_e(a_x,b_x,R1x,R1xp,R2x,d1,n_pt1,n_pt_in)
call I_x1_pol_mult_one_e(a_x, b_x, R1x, R1xp, R2x, d1, n_pt1, n_pt_in)
if(n_pt1<0)then
n_pt_out = -1
do i = 0,n_pt_in
@ -200,7 +387,7 @@ subroutine give_polynomial_mult_center_one_e_erf_opt(A_center,B_center,alpha,bet
!R1xp = (P_x - B_x) - (P_x - C_x) ( t * mu/sqrt(p+mu^2) )^2
a_y = power_A(2)
b_y = power_B(2)
call I_x1_pol_mult_one_e(a_y,b_y,R1x,R1xp,R2x,d2,n_pt2,n_pt_in)
call I_x1_pol_mult_one_e(a_y, b_y, R1x, R1xp, R2x, d2, n_pt2, n_pt_in)
if(n_pt2<0)then
n_pt_out = -1
do i = 0,n_pt_in
@ -209,41 +396,40 @@ subroutine give_polynomial_mult_center_one_e_erf_opt(A_center,B_center,alpha,bet
return
endif
R1x(0) = (P_center(3) - A_center(3))
R1x(1) = 0.d0
R1x(2) = -(P_center(3) - C_center(3))* p_new
R1x(2) = -(P_center(3) - C_center(3)) * p_new
! R1x = (P_x - A_x) - (P_x - C_x) ( t * mu/sqrt(p+mu^2) )^2
R1xp(0) = (P_center(3) - B_center(3))
R1xp(1) = 0.d0
R1xp(2) =-(P_center(3) - C_center(3))* p_new
R1xp(2) =-(P_center(3) - C_center(3)) * p_new
!R2x = 0.5 / p - 0.5/p ( t * mu/sqrt(p+mu^2) )^2
a_z = power_A(3)
b_z = power_B(3)
call I_x1_pol_mult_one_e(a_z,b_z,R1x,R1xp,R2x,d3,n_pt3,n_pt_in)
if(n_pt3<0)then
call I_x1_pol_mult_one_e(a_z, b_z, R1x, R1xp, R2x, d3, n_pt3, n_pt_in)
if(n_pt3 < 0) then
n_pt_out = -1
do i = 0,n_pt_in
d(i) = 0.d0
enddo
return
endif
integer :: n_pt_tmp
n_pt_tmp = 0
call multiply_poly(d1,n_pt1,d2,n_pt2,d,n_pt_tmp)
do i = 0,n_pt_tmp
call multiply_poly(d1, n_pt1, d2, n_pt2, d, n_pt_tmp)
do i = 0, n_pt_tmp
d1(i) = 0.d0
enddo
n_pt_out = 0
call multiply_poly(d ,n_pt_tmp ,d3,n_pt3,d1,n_pt_out)
call multiply_poly(d, n_pt_tmp, d3, n_pt3, d1, n_pt_out)
do i = 0, n_pt_out
d(i) = d1(i)
enddo
end
end subroutine give_polynomial_mult_center_one_e_erf_opt
! ---
subroutine give_polynomial_mult_center_one_e_erf(A_center,B_center,alpha,beta,&

12
src/ao_tc_eff_map/EZFIO.cfg
View File

@ -1,12 +0,0 @@
[j1b_gauss_pen]
type: double precision
doc: exponents of the 1-body Jastrow
interface: ezfio
size: (nuclei.nucl_num)
[j1b_gauss]
type: integer
doc: Use 1-body Gaussian Jastrow
interface: ezfio, provider, ocaml
default: 0

1
src/ao_tc_eff_map/NEED
View File

@ -2,3 +2,4 @@ ao_two_e_erf_ints
mo_one_e_ints
ao_many_one_e_ints
dft_utils_in_r
tc_keywords

23
src/ao_tc_eff_map/compute_ints_eff_pot.irp.f
View File

@ -1,9 +1,11 @@
subroutine compute_ao_tc_sym_two_e_pot_jl(j, l, n_integrals, buffer_i, buffer_value)
use map_module
BEGIN_DOC
! Parallel client for AO integrals of the TC integrals involving purely hermitian operators
! Parallel client for AO integrals
END_DOC
implicit none
@ -21,13 +23,10 @@ subroutine compute_ao_tc_sym_two_e_pot_jl(j, l, n_integrals, buffer_i, buffer_va
logical, external :: ao_two_e_integral_zero
double precision :: ao_tc_sym_two_e_pot, ao_two_e_integral_erf
double precision :: j1b_gauss_erf, j1b_gauss_coul
double precision :: j1b_gauss_coul_debug
double precision :: j1b_gauss_coul_modifdebug
double precision :: j1b_gauss_coulerf
double precision :: j1b_gauss_2e_j1, j1b_gauss_2e_j2
PROVIDE j1b_gauss
PROVIDE j1b_type
thr = ao_integrals_threshold
@ -45,7 +44,7 @@ subroutine compute_ao_tc_sym_two_e_pot_jl(j, l, n_integrals, buffer_i, buffer_va
exit
endif
if (ao_two_e_integral_erf_schwartz(i,k)*ao_two_e_integral_erf_schwartz(j,l) < thr ) then
if (ao_two_e_integral_erf_schwartz(i,k)*ao_two_e_integral_erf_schwartz(j,l) < thr) then
cycle
endif
@ -54,12 +53,14 @@ subroutine compute_ao_tc_sym_two_e_pot_jl(j, l, n_integrals, buffer_i, buffer_va
integral_erf = ao_two_e_integral_erf(i, k, j, l)
integral = integral_erf + integral_pot
if( j1b_gauss .eq. 1 ) then
integral = integral &
+ j1b_gauss_coulerf(i, k, j, l)
if( j1b_type .eq. 1 ) then
!print *, ' j1b type 1 is added'
integral = integral + j1b_gauss_2e_j1(i, k, j, l)
elseif( j1b_type .eq. 2 ) then
!print *, ' j1b type 2 is added'
integral = integral + j1b_gauss_2e_j2(i, k, j, l)
endif
if(abs(integral) < thr) then
cycle
endif

188
src/ao_tc_eff_map/fit_j.irp.f Normal file
View File

@ -0,0 +1,188 @@
BEGIN_PROVIDER [ double precision, expo_j_xmu, (n_fit_1_erf_x) ]
implicit none
BEGIN_DOC
! F(x) = x * (1 - erf(x)) - 1/sqrt(pi) * exp(-x**2) is fitted with a gaussian and a Slater
!
! \approx - 1/sqrt(pi) * exp(-alpha * x ) exp(-beta * x**2)
!
! where alpha = expo_j_xmu(1) and beta = expo_j_xmu(2)
END_DOC
expo_j_xmu(1) = 1.7477d0
expo_j_xmu(2) = 0.668662d0
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, expo_gauss_j_mu_x, (n_max_fit_slat)]
&BEGIN_PROVIDER [double precision, coef_gauss_j_mu_x, (n_max_fit_slat)]
BEGIN_DOC
!
! J(mu,r12) = 1/2 r12 * (1 - erf(mu*r12)) - 1/(2 sqrt(pi)*mu) exp(-(mu*r12)^2) is expressed as
!
! J(mu,r12) = 0.5/mu * F(r12*mu) where F(x) = x * (1 - erf(x)) - 1/sqrt(pi) * exp(-x**2)
!
! F(x) is fitted by - 1/sqrt(pi) * exp(-alpha * x) exp(-beta * x^2) (see expo_j_xmu)
!
! The slater function exp(-alpha * x) is fitted with n_max_fit_slat gaussians
!
! See Appendix 2 of JCP 154, 084119 (2021)
!
END_DOC
implicit none
integer :: i
double precision :: tmp
double precision :: expos(n_max_fit_slat), alpha, beta
tmp = -0.5d0 / (mu_erf * sqrt(dacos(-1.d0)))
alpha = expo_j_xmu(1) * mu_erf
call expo_fit_slater_gam(alpha, expos)
beta = expo_j_xmu(2) * mu_erf * mu_erf
do i = 1, n_max_fit_slat
expo_gauss_j_mu_x(i) = expos(i) + beta
coef_gauss_j_mu_x(i) = tmp * coef_fit_slat_gauss(i)
enddo
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, expo_gauss_j_mu_x_2, (n_max_fit_slat)]
&BEGIN_PROVIDER [double precision, coef_gauss_j_mu_x_2, (n_max_fit_slat)]
BEGIN_DOC
!
! J(mu,r12)^2 = 0.25/mu^2 F(r12*mu)^2
!
! F(x)^2 = 1 /pi * exp(-2 * alpha * x) exp(-2 * beta * x^2)
!
! The slater function exp(-2 * alpha * x) is fitted with n_max_fit_slat gaussians
!
! See Appendix 2 of JCP 154, 084119 (2021)
!
END_DOC
implicit none
integer :: i
double precision :: tmp
double precision :: expos(n_max_fit_slat), alpha, beta
double precision :: alpha_opt, beta_opt
!alpha_opt = 2.d0 * expo_j_xmu(1)
!beta_opt = 2.d0 * expo_j_xmu(2)
! direct opt
alpha_opt = 3.52751759d0
beta_opt = 1.26214809d0
tmp = 0.25d0 / (mu_erf * mu_erf * dacos(-1.d0))
alpha = alpha_opt * mu_erf
call expo_fit_slater_gam(alpha, expos)
beta = beta_opt * mu_erf * mu_erf
do i = 1, n_max_fit_slat
expo_gauss_j_mu_x_2(i) = expos(i) + beta
coef_gauss_j_mu_x_2(i) = tmp * coef_fit_slat_gauss(i)
enddo
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, expo_gauss_j_mu_1_erf, (n_max_fit_slat)]
&BEGIN_PROVIDER [double precision, coef_gauss_j_mu_1_erf, (n_max_fit_slat)]
BEGIN_DOC
!
! J(mu,r12) x \frac{1 - erf(mu * r12)}{2} =
!
! - \frac{1}{4 \sqrt{\pi} \mu} \exp(-(alpha1 + alpha2) * mu * r12 - (beta1 + beta2) * mu^2 * r12^2)
!
END_DOC
implicit none
integer :: i
double precision :: tmp
double precision :: expos(n_max_fit_slat), alpha, beta
double precision :: alpha_opt, beta_opt
!alpha_opt = expo_j_xmu(1) + expo_gauss_1_erf_x(1)
!beta_opt = expo_j_xmu(2) + expo_gauss_1_erf_x(2)
! direct opt
alpha_opt = 2.87875632d0
beta_opt = 1.34801003d0
tmp = -0.25d0 / (mu_erf * dsqrt(dacos(-1.d0)))
alpha = alpha_opt * mu_erf
call expo_fit_slater_gam(alpha, expos)
beta = beta_opt * mu_erf * mu_erf
do i = 1, n_max_fit_slat
expo_gauss_j_mu_1_erf(i) = expos(i) + beta
coef_gauss_j_mu_1_erf(i) = tmp * coef_fit_slat_gauss(i)
enddo
END_PROVIDER
! ---
double precision function F_x_j(x)
implicit none
BEGIN_DOC
! F_x_j(x) = dimension-less correlation factor = x (1 - erf(x)) - 1/sqrt(pi) exp(-x^2)
END_DOC
double precision, intent(in) :: x
F_x_j = x * (1.d0 - derf(x)) - 1/dsqrt(dacos(-1.d0)) * dexp(-x**2)
end
double precision function j_mu_F_x_j(x)
implicit none
BEGIN_DOC
! j_mu_F_x_j(x) = correlation factor = 1/2 r12 * (1 - erf(mu*r12)) - 1/(2 sqrt(pi)*mu) exp(-(mu*r12)^2)
!
! = 1/(2*mu) * F_x_j(mu*x)
END_DOC
double precision :: F_x_j
double precision, intent(in) :: x
j_mu_F_x_j = 0.5d0/mu_erf * F_x_j(x*mu_erf)
end
double precision function j_mu(x)
implicit none
double precision, intent(in) :: x
BEGIN_DOC
! j_mu(x) = correlation factor = 1/2 r12 * (1 - erf(mu*r12)) - 1/(2 sqrt(pi)*mu) exp(-(mu*r12)^2)
END_DOC
j_mu = 0.5d0* x * (1.d0 - derf(mu_erf*x)) - 0.5d0/( dsqrt(dacos(-1.d0))*mu_erf) * dexp(-(mu_erf*x)*(mu_erf*x))
end
double precision function j_mu_fit_gauss(x)
implicit none
BEGIN_DOC
! j_mu_fit_gauss(x) = correlation factor = 1/2 r12 * (1 - erf(mu*r12)) - 1/(2 sqrt(pi)*mu) exp(-(mu*r12)^2)
!
! but fitted with gaussians
END_DOC
double precision, intent(in) :: x
integer :: i
double precision :: alpha,coef
j_mu_fit_gauss = 0.d0
do i = 1, n_max_fit_slat
alpha = expo_gauss_j_mu_x(i)
coef = coef_gauss_j_mu_x(i)
j_mu_fit_gauss += coef * dexp(-alpha*x*x)
enddo
end
! ---

299
src/ao_tc_eff_map/j1b_1eInteg.py
View File

@ -1,299 +0,0 @@
import sys, os
QP_PATH=os.environ["QP_EZFIO"]
sys.path.insert(0,QP_PATH+"/Python/")
from ezfio import ezfio
from datetime import datetime
import time
from math import exp, sqrt, pi
import numpy as np
import subprocess
from scipy.integrate import tplquad
import multiprocessing
from multiprocessing import Pool
# _____________________________________________________________________________
#
def read_ao():
with open('ao_data') as f:
lines = f.readlines()
ao_prim_num = np.zeros((ao_num), dtype=int)
ao_nucl = np.zeros((ao_num), dtype=int)
ao_power = np.zeros((ao_num, 3))
nucl_coord = np.zeros((ao_num, 3))
ao_expo = np.zeros((ao_num, ao_num))
ao_coef = np.zeros((ao_num, ao_num))
iline = 0
for j in range(ao_num):
line = lines[iline]
iline += 1
ao_nucl[j] = int(line) - 1
line = lines[iline].split()
iline += 1
ao_power[j, 0] = float(line[0])
ao_power[j, 1] = float(line[1])
ao_power[j, 2] = float(line[2])
line = lines[iline].split()
iline += 1
nucl_coord[ao_nucl[j], 0] = float(line[0])
nucl_coord[ao_nucl[j], 1] = float(line[1])
nucl_coord[ao_nucl[j], 2] = float(line[2])
line = lines[iline]
iline += 1
ao_prim_num[j] = int(line)
for l in range(ao_prim_num[j]):
line = lines[iline].split()
iline += 1
ao_expo[l, j] = float(line[0])
ao_coef[l, j] = float(line[1])
return( ao_prim_num
, ao_nucl
, ao_power
, nucl_coord
, ao_expo
, ao_coef )
# _____________________________________________________________________________
# _____________________________________________________________________________
#
def Gao(X, i_ao):
ii = ao_nucl[i_ao]
C = np.array([nucl_coord[ii,0], nucl_coord[ii,1], nucl_coord[ii,2]])
Y = X - C
dis = np.dot(Y,Y)
ip = np.array([ao_power[i_ao,0], ao_power[i_ao,1], ao_power[i_ao,2]])
pol = np.prod(Y**ip)
xi = np.sum( ao_coef[:,i_ao] * np.exp(-dis*ao_expo[:,i_ao]) )
return(xi*pol)
# _____________________________________________________________________________
# _____________________________________________________________________________
#
def grad_Gao(X, i_ao):
ii = ao_nucl[i_ao]
C = np.array([nucl_coord[ii,0], nucl_coord[ii,1], nucl_coord[ii,2]])
ix = ao_power[i_ao,0]
iy = ao_power[i_ao,1]
iz = ao_power[i_ao,2]
Y = X - C
dis = np.dot(Y,Y)
xm = np.sum( ao_coef[:,i_ao]*np.exp(-dis*ao_expo[:,i_ao]))
xp = np.sum(ao_expo[:,i_ao]*ao_coef[:,i_ao]*np.exp(-dis*ao_expo[:,i_ao]))
ip = np.array([ix+1, iy, iz])
dx = -2. * np.prod(Y**ip) * xp
if(ix > 0):
ip = np.array([ix-1, iy, iz])
dx += ix * np.prod(Y**ip) * xm
ip = np.array([ix, iy+1, iz])
dy = -2. * np.prod(Y**ip) * xp
if(iy > 0):
ip = np.array([ix, iy-1, iz])
dy += iy * np.prod(Y**ip) * xm
ip = np.array([ix, iy, iz+1])
dz = -2. * np.prod(Y**ip) * xp
if(iz > 0):
ip = np.array([ix, iy, iz-1])
dz += iz * np.prod(Y**ip) * xm
return(np.array([dx, dy, dz]))
# _____________________________________________________________________________
# _____________________________________________________________________________
#
# 3 x < XA | exp[-gama r_C^2] | XB >
# - 2 x < XA | r_A^2 exp[-gama r_C^2] | XB >
#
def integ_lap(z, y, x, i_ao, j_ao):
X = np.array([x, y, z])
Gi = Gao(X, i_ao)
Gj = Gao(X, j_ao)
c = 0.
for k in range(nucl_num):
gama = j1b_gauss_pen[k]
C = nucl_coord[k,:]
Y = X - C
dis = np.dot(Y, Y)
arg = exp(-gama*dis)
arg = exp(-gama*dis)
c += ( 3. - 2. * dis * gama ) * arg * gama * Gi * Gj
return(c)
# _____________________________________________________________________________
# _____________________________________________________________________________
#
#
def integ_grad2(z, y, x, i_ao, j_ao):
X = np.array([x, y, z])
Gi = Gao(X, i_ao)
Gj = Gao(X, j_ao)
c = np.zeros((3))
for k in range(nucl_num):
gama = j1b_gauss_pen[k]
C = nucl_coord[k,:]
Y = X - C
c += gama * exp(-gama*np.dot(Y, Y)) * Y
return(-2*np.dot(c,c)*Gi*Gj)
# _____________________________________________________________________________
# _____________________________________________________________________________
#
#
def integ_nonh(z, y, x, i_ao, j_ao):
X = np.array([x, y, z])
Gi = Gao(X, i_ao)
c = 0.
for k in range(nucl_num):
gama = j1b_gauss_pen[k]
C = nucl_coord[k,:]
Y = X - C
grad = grad_Gao(X, j_ao)
c += gama * exp(-gama*np.dot(Y,Y)) * np.dot(Y,grad)
return(2*c*Gi)
# _____________________________________________________________________________
# _____________________________________________________________________________
#
def perform_integ( ind_ao ):
i_ao = ind_ao[0]
j_ao = ind_ao[1]
a = -15. #-np.Inf
b = +15. #+np.Inf
epsrel = 1e-5
res_lap, err_lap = tplquad( integ_lap
, a, b
, lambda x : a, lambda x : b
, lambda x,y: a, lambda x,y: b
, (i_ao, j_ao)
, epsrel=epsrel )
res_grd, err_grd = tplquad( integ_grad2
, a, b
, lambda x : a, lambda x : b
, lambda x,y: a, lambda x,y: b
, (i_ao, j_ao)
, epsrel=epsrel )
res_nnh, err_nnh = tplquad( integ_nonh
, a, b
, lambda x : a, lambda x : b
, lambda x,y: a, lambda x,y: b
, (i_ao, j_ao)
, epsrel=epsrel )
return( [ res_lap, err_lap
, res_grd, err_grd
, res_nnh, err_nnh ])
# _____________________________________________________________________________
# _____________________________________________________________________________
#
def integ_eval():
list_ind = []
for i_ao in range(ao_num):
for j_ao in range(ao_num):
list_ind.append( [i_ao, j_ao] )
nb_proc = multiprocessing.cpu_count()
print(" --- Excexution with {} processors ---\n".format(nb_proc))
p = Pool(nb_proc)
res = np.array( p.map( perform_integ, list_ind ) )
ii = 0
for i_ao in range(ao_num):
for j_ao in range(ao_num):
print(" {} {} {:+e} {:+e} {:+e} {:+e}".format( i_ao, j_ao
, res[ii][0], res[ii][1], res[ii][2], res[ii][3]) )
ii += 1
p.close()
# _____________________________________________________________________________
# _____________________________________________________________________________
#
if __name__=="__main__":
t0 = time.time()
EZFIO_file = sys.argv[1]
ezfio.set_file(EZFIO_file)
print(" Today's date:", datetime.now() )
print(" EZFIO file = {}".format(EZFIO_file))
nucl_num = ezfio.get_nuclei_nucl_num()
ao_num = ezfio.get_ao_basis_ao_num()
j1b_gauss_pen = ezfio.get_ao_tc_eff_map_j1b_gauss_pen()
ao_prim_num, ao_nucl, ao_power, nucl_coord, ao_expo, ao_coef = read_ao()
#integ_eval()
i_ao = 0
j_ao = 0
a = -5.
b = +5.
epsrel = 1e-1
res_grd, err_grd = tplquad( integ_nonh
, a, b
, lambda x : a, lambda x : b
, lambda x,y: a, lambda x,y: b
, (i_ao, j_ao)
, epsrel=epsrel )
print(res_grd, err_grd)
tf = time.time() - t0
print(' end after {} min'.format(tf/60.))
# _____________________________________________________________________________

59
src/ao_tc_eff_map/j1b_pen.irp.f
View File

@ -1,59 +0,0 @@
! ---
BEGIN_PROVIDER [ double precision, j1b_gauss_pen, (nucl_num) ]
BEGIN_DOC
! exponents of the 1-body Jastrow
END_DOC
implicit none
logical :: exists
PROVIDE ezfio_filename
if (mpi_master) then
call ezfio_has_ao_tc_eff_map_j1b_gauss_pen(exists)
endif
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI
include 'mpif.h'
integer :: ierr
call MPI_BCAST(j1b_gauss_pen, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read j1b_gauss_pen with MPI'
endif
IRP_ENDIF
if (exists) then
if (mpi_master) then
write(6,'(A)') '.. >>>>> [ IO READ: j1b_gauss_pen ] <<<<< ..'
call ezfio_get_ao_tc_eff_map_j1b_gauss_pen(j1b_gauss_pen)
IRP_IF MPI
call MPI_BCAST(j1b_gauss_pen, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read j1b_gauss_pen with MPI'
endif
IRP_ENDIF
endif
else
integer :: i
do i = 1, nucl_num
j1b_gauss_pen(i) = 1d5
enddo
endif
END_PROVIDER
! ---

84
src/ao_tc_eff_map/map_integrals_eff_pot.irp.f
View File

@ -27,42 +27,52 @@ END_PROVIDER
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, ao_tc_sym_two_e_pot_cache, (0:64*64*64*64) ]
use map_module
implicit none
BEGIN_DOC
! Cache of |AO| integrals for fast access
END_DOC
PROVIDE ao_tc_sym_two_e_pot_in_map
integer :: i,j,k,l,ii
integer(key_kind) :: idx
real(integral_kind) :: integral
implicit none
BEGIN_DOC
! Cache of |AO| integrals for fast access
END_DOC
integer :: i,j,k,l,ii
integer(key_kind) :: idx
real(integral_kind) :: integral
PROVIDE ao_tc_sym_two_e_pot_in_map
!$OMP PARALLEL DO PRIVATE (i,j,k,l,idx,ii,integral)
do l=ao_tc_sym_two_e_pot_cache_min,ao_tc_sym_two_e_pot_cache_max
do k=ao_tc_sym_two_e_pot_cache_min,ao_tc_sym_two_e_pot_cache_max
do j=ao_tc_sym_two_e_pot_cache_min,ao_tc_sym_two_e_pot_cache_max
do i=ao_tc_sym_two_e_pot_cache_min,ao_tc_sym_two_e_pot_cache_max
!DIR$ FORCEINLINE
call two_e_integrals_index(i,j,k,l,idx)
!DIR$ FORCEINLINE
call map_get(ao_tc_sym_two_e_pot_map,idx,integral)
ii = l-ao_tc_sym_two_e_pot_cache_min
ii = ior( ishft(ii,6), k-ao_tc_sym_two_e_pot_cache_min)
ii = ior( ishft(ii,6), j-ao_tc_sym_two_e_pot_cache_min)
ii = ior( ishft(ii,6), i-ao_tc_sym_two_e_pot_cache_min)
ao_tc_sym_two_e_pot_cache(ii) = integral
enddo
enddo
enddo
enddo
!$OMP END PARALLEL DO
do l = ao_tc_sym_two_e_pot_cache_min, ao_tc_sym_two_e_pot_cache_max
do k = ao_tc_sym_two_e_pot_cache_min, ao_tc_sym_two_e_pot_cache_max
do j = ao_tc_sym_two_e_pot_cache_min, ao_tc_sym_two_e_pot_cache_max
do i = ao_tc_sym_two_e_pot_cache_min, ao_tc_sym_two_e_pot_cache_max
!DIR$ FORCEINLINE
call two_e_integrals_index(i, j, k, l, idx)
!DIR$ FORCEINLINE
call map_get(ao_tc_sym_two_e_pot_map, idx, integral)
ii = l-ao_tc_sym_two_e_pot_cache_min
ii = ior( ishft(ii,6), k-ao_tc_sym_two_e_pot_cache_min)
ii = ior( ishft(ii,6), j-ao_tc_sym_two_e_pot_cache_min)
ii = ior( ishft(ii,6), i-ao_tc_sym_two_e_pot_cache_min)
ao_tc_sym_two_e_pot_cache(ii) = integral
enddo
enddo
enddo
enddo
!$OMP END PARALLEL DO
END_PROVIDER
! ---
subroutine insert_into_ao_tc_sym_two_e_pot_map(n_integrals, buffer_i, buffer_values)
subroutine insert_into_ao_tc_sym_two_e_pot_map(n_integrals,buffer_i, buffer_values)
use map_module
implicit none
BEGIN_DOC
! Create new entry into |AO| map
END_DOC
@ -72,21 +82,30 @@ subroutine insert_into_ao_tc_sym_two_e_pot_map(n_integrals,buffer_i, buffer_valu
real(integral_kind), intent(inout) :: buffer_values(n_integrals)
call map_append(ao_tc_sym_two_e_pot_map, buffer_i, buffer_values, n_integrals)
end
double precision function get_ao_tc_sym_two_e_pot(i,j,k,l,map) result(result)
! ---
double precision function get_ao_tc_sym_two_e_pot(i, j, k, l, map) result(result)
use map_module
implicit none
BEGIN_DOC
! Gets one |AO| two-electron integral from the |AO| map in PHYSICIST NOTATION
! Gets one |AO| two-electron integral from the |AO| map
END_DOC
integer, intent(in) :: i,j,k,l
integer(key_kind) :: idx
type(map_type), intent(inout) :: map
integer :: ii
real(integral_kind) :: tmp
logical, external :: ao_two_e_integral_zero
PROVIDE ao_tc_sym_two_e_pot_in_map ao_tc_sym_two_e_pot_cache ao_tc_sym_two_e_pot_cache_min
!DIR$ FORCEINLINE
! if (ao_two_e_integral_zero(i,j,k,l)) then
if (.False.) then
@ -100,9 +119,9 @@ double precision function get_ao_tc_sym_two_e_pot(i,j,k,l,map) result(result)
ii = ior(ii, i-ao_tc_sym_two_e_pot_cache_min)
if (iand(ii, -64) /= 0) then
!DIR$ FORCEINLINE
call two_e_integrals_index(i,j,k,l,idx)
call two_e_integrals_index(i, j, k, l, idx)
!DIR$ FORCEINLINE
call map_get(map,idx,tmp)
call map_get(map, idx, tmp)
tmp = tmp
else
ii = l-ao_tc_sym_two_e_pot_cache_min
@ -112,9 +131,12 @@ double precision function get_ao_tc_sym_two_e_pot(i,j,k,l,map) result(result)
tmp = ao_tc_sym_two_e_pot_cache(ii)
endif
endif
result = tmp
end
! ---
subroutine get_many_ao_tc_sym_two_e_pot(j,k,l,sze,out_val)
use map_module

332
src/ao_tc_eff_map/one_e_1bgauss_grad2.irp.f Normal file
View File

@ -0,0 +1,332 @@
! ---
BEGIN_PROVIDER [ double precision, j1b_gauss_hermII, (ao_num,ao_num)]
BEGIN_DOC
!
! :math:`\langle \chi_A | -0.5 \grad \tau_{1b} \cdot \grad \tau_{1b} | \chi_B \rangle`
!
END_DOC
implicit none
integer :: num_A, num_B
integer :: power_A(3), power_B(3)
integer :: i, j, k1, k2, l, m
double precision :: alpha, beta, gama1, gama2, coef1, coef2
double precision :: A_center(3), B_center(3), C_center1(3), C_center2(3)
double precision :: c1, c
integer :: dim1
double precision :: overlap_y, d_a_2, overlap_z, overlap
double precision :: int_gauss_4G
PROVIDE j1b_type j1b_pen j1b_coeff
! --------------------------------------------------------------------------------
! -- Dummy call to provide everything
dim1 = 100
A_center(:) = 0.d0
B_center(:) = 1.d0
alpha = 1.d0
beta = 0.1d0
power_A(:) = 1
power_B(:) = 0
call overlap_gaussian_xyz( A_center, B_center, alpha, beta, power_A, power_B &
, overlap_y, d_a_2, overlap_z, overlap, dim1 )
! --------------------------------------------------------------------------------
j1b_gauss_hermII(1:ao_num,1:ao_num) = 0.d0
if(j1b_type .eq. 1) then
! \tau_1b = \sum_iA -[1 - exp(-alpha_A r_iA^2)]
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, k1, k2, l, m, alpha, beta, gama1, gama2, &
!$OMP A_center, B_center, C_center1, C_center2, &
!$OMP power_A, power_B, num_A, num_B, c1, c) &
!$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, &
!$OMP ao_power, ao_nucl, nucl_coord, &
!$OMP ao_coef_normalized_ordered_transp, &
!$OMP nucl_num, j1b_pen, j1b_gauss_hermII)
!$OMP DO SCHEDULE (dynamic)
do j = 1, ao_num
num_A = ao_nucl(j)
power_A(1:3) = ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
do i = 1, ao_num
num_B = ao_nucl(i)
power_B(1:3) = ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l = 1, ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
do m = 1, ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
c = 0.d0
do k1 = 1, nucl_num
gama1 = j1b_pen(k1)
C_center1(1:3) = nucl_coord(k1,1:3)
do k2 = 1, nucl_num
gama2 = j1b_pen(k2)
C_center2(1:3) = nucl_coord(k2,1:3)
! < XA | exp[-gama1 r_C1^2 -gama2 r_C2^2] r_C1 \cdot r_C2 | XB >
c1 = int_gauss_4G( A_center, B_center, C_center1, C_center2 &
, power_A, power_B, alpha, beta, gama1, gama2 )
c = c - 2.d0 * gama1 * gama2 * c1
enddo
enddo
j1b_gauss_hermII(i,j) = j1b_gauss_hermII(i,j) &
+ ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i) * c
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
elseif(j1b_type .eq. 2) then
! \tau_1b = \sum_iA [c_A exp(-alpha_A r_iA^2)]
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, k1, k2, l, m, alpha, beta, gama1, gama2, &
!$OMP A_center, B_center, C_center1, C_center2, &
!$OMP power_A, power_B, num_A, num_B, c1, c, &
!$OMP coef1, coef2) &
!$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, &
!$OMP ao_power, ao_nucl, nucl_coord, &
!$OMP ao_coef_normalized_ordered_transp, &
!$OMP nucl_num, j1b_pen, j1b_gauss_hermII, &
!$OMP j1b_coeff)
!$OMP DO SCHEDULE (dynamic)
do j = 1, ao_num
num_A = ao_nucl(j)
power_A(1:3) = ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
do i = 1, ao_num
num_B = ao_nucl(i)
power_B(1:3) = ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l = 1, ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
do m = 1, ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
c = 0.d0
do k1 = 1, nucl_num
gama1 = j1b_pen (k1)
coef1 = j1b_coeff(k1)
C_center1(1:3) = nucl_coord(k1,1:3)
do k2 = 1, nucl_num
gama2 = j1b_pen (k2)
coef2 = j1b_coeff(k2)
C_center2(1:3) = nucl_coord(k2,1:3)
! < XA | exp[-gama1 r_C1^2 -gama2 r_C2^2] r_C1 \cdot r_C2 | XB >
c1 = int_gauss_4G( A_center, B_center, C_center1, C_center2 &
, power_A, power_B, alpha, beta, gama1, gama2 )
c = c - 2.d0 * gama1 * gama2 * coef1 * coef2 * c1
enddo
enddo
j1b_gauss_hermII(i,j) = j1b_gauss_hermII(i,j) &
+ ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i) * c
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
endif
END_PROVIDER
!_____________________________________________________________________________________________________________
!
! < XA | exp[-gama1 r_C1^2 -gama2 r_C2^2] r_C1 \cdot r_C2 | XB >
!
double precision function int_gauss_4G( A_center, B_center, C_center1, C_center2, power_A, power_B &
, alpha, beta, gama1, gama2 )
! for max_dim
include 'constants.include.F'
implicit none
integer , intent(in) :: power_A(3), power_B(3)
double precision, intent(in) :: A_center(3), B_center(3), C_center1(3), C_center2(3)
double precision, intent(in) :: alpha, beta, gama1, gama2
integer :: i, dim1, power_C
integer :: iorder(3)
double precision :: AB_expo, fact_AB, AB_center(3), P_AB(0:max_dim,3)
double precision :: gama, fact_C, C_center(3)
double precision :: cx0, cy0, cz0, c_tmp1, c_tmp2, cx, cy, cz
double precision :: int_tmp
double precision :: overlap_gaussian_x
dim1 = 100
! P_AB(0:max_dim,3) polynomial
! AB_center(3) new center
! AB_expo new exponent
! fact_AB constant factor
! iorder(3) i_order(i) = order of the polynomials
call give_explicit_poly_and_gaussian( P_AB, AB_center, AB_expo, fact_AB &
, iorder, alpha, beta, power_A, power_B, A_center, B_center, dim1)
call gaussian_product(gama1, C_center1, gama2, C_center2, fact_C, gama, C_center)
! <<<
! to avoid multi-evaluation
power_C = 0
cx0 = 0.d0
do i = 0, iorder(1)
cx0 = cx0 + P_AB(i,1) * overlap_gaussian_x( AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1)
enddo
cy0 = 0.d0
do i = 0, iorder(2)
cy0 = cy0 + P_AB(i,2) * overlap_gaussian_x( AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1)
enddo
cz0 = 0.d0
do i = 0, iorder(3)
cz0 = cz0 + P_AB(i,3) * overlap_gaussian_x( AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1)
enddo
! >>>
int_tmp = 0.d0
! -----------------------------------------------------------------------------------------------
!
! x term:
! < XA | exp[-gama1 r_C1^2 -gama2 r_C2^2] (x - x_C1) (x - x_C2) | XB >
!
c_tmp1 = 2.d0 * C_center(1) - C_center1(1) - C_center2(1)
c_tmp2 = ( C_center(1) - C_center1(1) ) * ( C_center(1) - C_center2(1) )
cx = 0.d0
do i = 0, iorder(1)
! < XA | exp[-gama r_C^2] (x - x_C)^2 | XB >
power_C = 2
cx = cx + P_AB(i,1) &
* overlap_gaussian_x( AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1)
! < XA | exp[-gama r_C^2] (x - x_C) | XB >
power_C = 1
cx = cx + P_AB(i,1) * c_tmp1 &
* overlap_gaussian_x( AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1)
! < XA | exp[-gama r_C^2] | XB >
power_C = 0
cx = cx + P_AB(i,1) * c_tmp2 &
* overlap_gaussian_x( AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1)
enddo
int_tmp += cx * cy0 * cz0
! -----------------------------------------------------------------------------------------------
! -----------------------------------------------------------------------------------------------
!
! y term:
! < XA | exp[-gama1 r_C1^2 -gama2 r_C2^2] (y - y_C1) (y - y_C2) | XB >
!
c_tmp1 = 2.d0 * C_center(2) - C_center1(2) - C_center2(2)
c_tmp2 = ( C_center(2) - C_center1(2) ) * ( C_center(2) - C_center2(2) )
cy = 0.d0
do i = 0, iorder(2)
! < XA | exp[-gama r_C^2] (y - y_C)^2 | XB >
power_C = 2
cy = cy + P_AB(i,2) &
* overlap_gaussian_x( AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1)
! < XA | exp[-gama r_C^2] (y - y_C) | XB >
power_C = 1
cy = cy + P_AB(i,2) * c_tmp1 &
* overlap_gaussian_x( AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1)
! < XA | exp[-gama r_C^2] | XB >
power_C = 0
cy = cy + P_AB(i,2) * c_tmp2 &
* overlap_gaussian_x( AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1)
enddo
int_tmp += cx0 * cy * cz0
! -----------------------------------------------------------------------------------------------
! -----------------------------------------------------------------------------------------------
!
! z term:
! < XA | exp[-gama1 r_C1^2 -gama2 r_C2^2] (z - z_C1) (z - z_C2) | XB >
!
c_tmp1 = 2.d0 * C_center(3) - C_center1(3) - C_center2(3)
c_tmp2 = ( C_center(3) - C_center1(3) ) * ( C_center(3) - C_center2(3) )
cz = 0.d0
do i = 0, iorder(3)
! < XA | exp[-gama r_C^2] (z - z_C)^2 | XB >
power_C = 2
cz = cz + P_AB(i,3) &
* overlap_gaussian_x( AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1)
! < XA | exp[-gama r_C^2] (z - z_C) | XB >
power_C = 1
cz = cz + P_AB(i,3) * c_tmp1 &
* overlap_gaussian_x( AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1)
! < XA | exp[-gama r_C^2] | XB >
power_C = 0
cz = cz + P_AB(i,3) * c_tmp2 &
* overlap_gaussian_x( AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1)
enddo
int_tmp += cx0 * cy0 * cz
! -----------------------------------------------------------------------------------------------
int_gauss_4G = fact_AB * fact_C * int_tmp
return
end function int_gauss_4G
!_____________________________________________________________________________________________________________
!_____________________________________________________________________________________________________________

519
src/ao_tc_eff_map/one_e_1bgauss_hermit.irp.f
View File

@ -1,519 +0,0 @@
BEGIN_PROVIDER [ double precision, j1b_gauss_hermII, (ao_num,ao_num)]
BEGIN_DOC
!
! Hermitian part of 1-body Jastrow factow in the |AO| basis set.
!
! :math:`\langle \chi_A | -0.5 \grad \tau_{1b} \cdot \grad \tau_{1b} | \chi_B \rangle`
!
END_DOC
implicit none
integer :: num_A, num_B
integer :: power_A(3), power_B(3)
integer :: i, j, k1, k2, l, m
double precision :: alpha, beta, gama1, gama2
double precision :: A_center(3), B_center(3), C_center1(3), C_center2(3)
double precision :: c1, c
integer :: dim1
double precision :: overlap_y, d_a_2, overlap_z, overlap
double precision :: int_gauss_4G
PROVIDE j1b_gauss_pen
! --------------------------------------------------------------------------------
! -- Dummy call to provide everything
dim1 = 100
A_center(:) = 0.d0
B_center(:) = 1.d0
alpha = 1.d0
beta = 0.1d0
power_A(:) = 1
power_B(:) = 0
call overlap_gaussian_xyz( A_center, B_center, alpha, beta, power_A, power_B &
, overlap_y, d_a_2, overlap_z, overlap, dim1 )
! --------------------------------------------------------------------------------
j1b_gauss_hermII(1:ao_num,1:ao_num) = 0.d0
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, k1, k2, l, m, alpha, beta, gama1, gama2, &
!$OMP A_center, B_center, C_center1, C_center2, &
!$OMP power_A, power_B, num_A, num_B, c1, c) &
!$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, &
!$OMP ao_power, ao_nucl, nucl_coord, &
!$OMP ao_coef_normalized_ordered_transp, &
!$OMP nucl_num, j1b_gauss_pen, j1b_gauss_hermII)
!$OMP DO SCHEDULE (dynamic)
do j = 1, ao_num
num_A = ao_nucl(j)
power_A(1:3) = ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
do i = 1, ao_num
num_B = ao_nucl(i)
power_B(1:3) = ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l = 1, ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
do m = 1, ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
c = 0.d0
do k1 = 1, nucl_num
gama1 = j1b_gauss_pen(k1)
C_center1(1:3) = nucl_coord(k1,1:3)
do k2 = 1, nucl_num
gama2 = j1b_gauss_pen(k2)
C_center2(1:3) = nucl_coord(k2,1:3)
! < XA | exp[-gama1 r_C1^2 -gama2 r_C2^2] r_C1 \cdot r_C2 | XB >
c1 = int_gauss_4G( A_center, B_center, C_center1, C_center2 &
, power_A, power_B, alpha, beta, gama1, gama2 )
c = c - 2.d0 * gama1 * gama2 * c1
enddo
enddo
j1b_gauss_hermII(i,j) = j1b_gauss_hermII(i,j) &
+ ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i) * c
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
END_PROVIDER
!_____________________________________________________________________________________________________________
!
! < XA | exp[-gama1 r_C1^2 -gama2 r_C2^2] r_C1 \cdot r_C2 | XB >
!
double precision function int_gauss_4G( A_center, B_center, C_center1, C_center2, power_A, power_B &
, alpha, beta, gama1, gama2 )
! for max_dim
include 'constants.include.F'
implicit none
integer , intent(in) :: power_A(3), power_B(3)
double precision, intent(in) :: A_center(3), B_center(3), C_center1(3), C_center2(3)
double precision, intent(in) :: alpha, beta, gama1, gama2
integer :: i, dim1, power_C
integer :: iorder(3)
double precision :: AB_expo, fact_AB, AB_center(3), P_AB(0:max_dim,3)
double precision :: gama, fact_C, C_center(3)
double precision :: cx0, cy0, cz0, c_tmp1, c_tmp2, cx, cy, cz
double precision :: int_tmp
double precision :: overlap_gaussian_x
dim1 = 100
! P_AB(0:max_dim,3) polynomial
! AB_center(3) new center
! AB_expo new exponent
! fact_AB constant factor
! iorder(3) i_order(i) = order of the polynomials
call give_explicit_poly_and_gaussian( P_AB, AB_center, AB_expo, fact_AB &
, iorder, alpha, beta, power_A, power_B, A_center, B_center, dim1)
call gaussian_product(gama1, C_center1, gama2, C_center2, fact_C, gama, C_center)
! <<<
! to avoid multi-evaluation
power_C = 0
cx0 = 0.d0
do i = 0, iorder(1)
cx0 = cx0 + P_AB(i,1) * overlap_gaussian_x( AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1)
enddo
cy0 = 0.d0
do i = 0, iorder(2)
cy0 = cy0 + P_AB(i,2) * overlap_gaussian_x( AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1)
enddo
cz0 = 0.d0
do i = 0, iorder(3)
cz0 = cz0 + P_AB(i,3) * overlap_gaussian_x( AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1)
enddo
! >>>
int_tmp = 0.d0
! -----------------------------------------------------------------------------------------------
!
! x term:
! < XA | exp[-gama1 r_C1^2 -gama2 r_C2^2] (x - x_C1) (x - x_C2) | XB >
!
c_tmp1 = 2.d0 * C_center(1) - C_center1(1) - C_center2(1)
c_tmp2 = ( C_center(1) - C_center1(1) ) * ( C_center(1) - C_center2(1) )
cx = 0.d0
do i = 0, iorder(1)
! < XA | exp[-gama r_C^2] (x - x_C)^2 | XB >
power_C = 2
cx = cx + P_AB(i,1) &
* overlap_gaussian_x( AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1)
! < XA | exp[-gama r_C^2] (x - x_C) | XB >
power_C = 1
cx = cx + P_AB(i,1) * c_tmp1 &
* overlap_gaussian_x( AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1)
! < XA | exp[-gama r_C^2] | XB >
power_C = 0
cx = cx + P_AB(i,1) * c_tmp2 &
* overlap_gaussian_x( AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1)
enddo
int_tmp += cx * cy0 * cz0
! -----------------------------------------------------------------------------------------------
! -----------------------------------------------------------------------------------------------
!
! y term:
! < XA | exp[-gama1 r_C1^2 -gama2 r_C2^2] (y - y_C1) (y - y_C2) | XB >
!
c_tmp1 = 2.d0 * C_center(2) - C_center1(2) - C_center2(2)
c_tmp2 = ( C_center(2) - C_center1(2) ) * ( C_center(2) - C_center2(2) )
cy = 0.d0
do i = 0, iorder(2)
! < XA | exp[-gama r_C^2] (y - y_C)^2 | XB >
power_C = 2
cy = cy + P_AB(i,2) &
* overlap_gaussian_x( AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1)
! < XA | exp[-gama r_C^2] (y - y_C) | XB >
power_C = 1
cy = cy + P_AB(i,2) * c_tmp1 &
* overlap_gaussian_x( AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1)
! < XA | exp[-gama r_C^2] | XB >
power_C = 0
cy = cy + P_AB(i,2) * c_tmp2 &
* overlap_gaussian_x( AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1)
enddo
int_tmp += cx0 * cy * cz0
! -----------------------------------------------------------------------------------------------
! -----------------------------------------------------------------------------------------------
!
! z term:
! < XA | exp[-gama1 r_C1^2 -gama2 r_C2^2] (z - z_C1) (z - z_C2) | XB >
!
c_tmp1 = 2.d0 * C_center(3) - C_center1(3) - C_center2(3)
c_tmp2 = ( C_center(3) - C_center1(3) ) * ( C_center(3) - C_center2(3) )
cz = 0.d0
do i = 0, iorder(3)
! < XA | exp[-gama r_C^2] (z - z_C)^2 | XB >
power_C = 2
cz = cz + P_AB(i,3) &
* overlap_gaussian_x( AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1)
! < XA | exp[-gama r_C^2] (z - z_C) | XB >
power_C = 1
cz = cz + P_AB(i,3) * c_tmp1 &
* overlap_gaussian_x( AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1)
! < XA | exp[-gama r_C^2] | XB >
power_C = 0
cz = cz + P_AB(i,3) * c_tmp2 &
* overlap_gaussian_x( AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1)
enddo
int_tmp += cx0 * cy0 * cz
! -----------------------------------------------------------------------------------------------
int_gauss_4G = fact_AB * fact_C * int_tmp
return
end function int_gauss_4G
!_____________________________________________________________________________________________________________
!_____________________________________________________________________________________________________________
BEGIN_PROVIDER [ double precision, j1b_gauss_hermI, (ao_num,ao_num)]
BEGIN_DOC
!
! Hermitian part of 1-body Jastrow factow in the |AO| basis set.
!
! :math:`\langle \chi_A | -0.5 \Delta \tau_{1b} | \chi_B \rangle`
!
END_DOC
implicit none
integer :: num_A, num_B
integer :: power_A(3), power_B(3)
integer :: i, j, k, l, m
double precision :: alpha, beta, gama
double precision :: A_center(3), B_center(3), C_center(3)
double precision :: c1, c2, c
integer :: dim1
double precision :: overlap_y, d_a_2, overlap_z, overlap
double precision :: int_gauss_r0, int_gauss_r2
PROVIDE j1b_gauss_pen
! --------------------------------------------------------------------------------
! -- Dummy call to provide everything
dim1 = 100
A_center(:) = 0.d0
B_center(:) = 1.d0
alpha = 1.d0
beta = 0.1d0
power_A(:) = 1
power_B(:) = 0
call overlap_gaussian_xyz( A_center, B_center, alpha, beta, power_A, power_B &
, overlap_y, d_a_2, overlap_z, overlap, dim1 )
! --------------------------------------------------------------------------------
j1b_gauss_hermI(1:ao_num,1:ao_num) = 0.d0
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, k, l, m, alpha, beta, gama, &
!$OMP A_center, B_center, C_center, power_A, power_B, &
!$OMP num_A, num_B, c1, c2, c) &
!$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, &
!$OMP ao_power, ao_nucl, nucl_coord, &
!$OMP ao_coef_normalized_ordered_transp, &
!$OMP nucl_num, j1b_gauss_pen, j1b_gauss_hermI)
!$OMP DO SCHEDULE (dynamic)
do j = 1, ao_num
num_A = ao_nucl(j)
power_A(1:3) = ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
do i = 1, ao_num
num_B = ao_nucl(i)
power_B(1:3) = ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l = 1, ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
do m = 1, ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
c = 0.d0
do k = 1, nucl_num
gama = j1b_gauss_pen(k)
C_center(1:3) = nucl_coord(k,1:3)
! < XA | exp[-gama r_C^2] | XB >
c1 = int_gauss_r0( A_center, B_center, C_center &
, power_A, power_B, alpha, beta, gama )
! < XA | r_A^2 exp[-gama r_C^2] | XB >
c2 = int_gauss_r2( A_center, B_center, C_center &
, power_A, power_B, alpha, beta, gama )
c = c + 3.d0 * gama * c1 - 2.d0 * gama * gama * c2
enddo
j1b_gauss_hermI(i,j) = j1b_gauss_hermI(i,j) &
+ ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i) * c
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
END_PROVIDER
!_____________________________________________________________________________________________________________
!
! < XA | exp[-gama r_C^2] | XB >
!
double precision function int_gauss_r0(A_center, B_center, C_center, power_A, power_B, alpha, beta, gama)
! for max_dim
include 'constants.include.F'
implicit none
integer , intent(in) :: power_A(3), power_B(3)
double precision, intent(in) :: A_center(3), B_center(3), C_center(3)
double precision, intent(in) :: alpha, beta, gama
integer :: i, power_C, dim1
integer :: iorder(3)
integer :: nmax
double precision :: AB_expo, fact_AB, AB_center(3), P_AB(0:max_dim,3)
double precision :: cx, cy, cz
double precision :: overlap_gaussian_x
dim1 = 100
! P_AB(0:max_dim,3) polynomial
! AB_center(3) new center
! AB_expo new exponent
! fact_AB constant factor
! iorder(3) i_order(i) = order of the polynomials
call give_explicit_poly_and_gaussian( P_AB, AB_center, AB_expo, fact_AB &
, iorder, alpha, beta, power_A, power_B, A_center, B_center, dim1)
if( fact_AB .lt. 1d-20 ) then
int_gauss_r0 = 0.d0
return
endif
power_C = 0
cx = 0.d0
do i = 0, iorder(1)
cx = cx + P_AB(i,1) * overlap_gaussian_x(AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1)
enddo
cy = 0.d0
do i = 0, iorder(2)
cy = cy + P_AB(i,2) * overlap_gaussian_x(AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1)
enddo
cz = 0.d0
do i = 0, iorder(3)
cz = cz + P_AB(i,3) * overlap_gaussian_x(AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1)
enddo
int_gauss_r0 = fact_AB * cx * cy * cz
return
end function int_gauss_r0
!_____________________________________________________________________________________________________________
!_____________________________________________________________________________________________________________
!_____________________________________________________________________________________________________________
!
! < XA | r_C^2 exp[-gama r_C^2] | XB >
!
double precision function int_gauss_r2(A_center, B_center, C_center, power_A, power_B, alpha, beta, gama)
! for max_dim
include 'constants.include.F'
implicit none
integer, intent(in) :: power_A(3), power_B(3)
double precision, intent(in) :: A_center(3), B_center(3), C_center(3)
double precision, intent(in) :: alpha, beta, gama
integer :: i, power_C, dim1
integer :: iorder(3)
double precision :: AB_expo, fact_AB, AB_center(3), P_AB(0:max_dim,3)
double precision :: cx0, cy0, cz0, cx, cy, cz
double precision :: int_tmp
double precision :: overlap_gaussian_x
dim1 = 100
! P_AB(0:max_dim,3) polynomial centered on AB_center
! AB_center(3) new center
! AB_expo new exponent
! fact_AB constant factor
! iorder(3) i_order(i) = order of the polynomials
call give_explicit_poly_and_gaussian( P_AB, AB_center, AB_expo, fact_AB &
, iorder, alpha, beta, power_A, power_B, A_center, B_center, dim1)
! <<<
! to avoid multi-evaluation
power_C = 0
cx0 = 0.d0
do i = 0, iorder(1)
cx0 = cx0 + P_AB(i,1) * overlap_gaussian_x(AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1)
enddo
cy0 = 0.d0
do i = 0, iorder(2)
cy0 = cy0 + P_AB(i,2) * overlap_gaussian_x(AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1)
enddo
cz0 = 0.d0
do i = 0, iorder(3)
cz0 = cz0 + P_AB(i,3) * overlap_gaussian_x(AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1)
enddo
! >>>
int_tmp = 0.d0
power_C = 2
! ( x - XC)^2
cx = 0.d0
do i = 0, iorder(1)
cx = cx + P_AB(i,1) * overlap_gaussian_x(AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1)
enddo
int_tmp += cx * cy0 * cz0
! ( y - YC)^2
cy = 0.d0
do i = 0, iorder(2)
cy = cy + P_AB(i,2) * overlap_gaussian_x(AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1)
enddo
int_tmp += cx0 * cy * cz0
! ( z - ZC)^2
cz = 0.d0
do i = 0, iorder(3)
cz = cz + P_AB(i,3) * overlap_gaussian_x(AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1)
enddo
int_tmp += cx0 * cy0 * cz
int_gauss_r2 = fact_AB * int_tmp
return
end function int_gauss_r2
!_____________________________________________________________________________________________________________
!_____________________________________________________________________________________________________________

303
src/ao_tc_eff_map/one_e_1bgauss_lap.irp.f Normal file
View File

@ -0,0 +1,303 @@
! ---
BEGIN_PROVIDER [ double precision, j1b_gauss_hermI, (ao_num,ao_num)]
BEGIN_DOC
!
! :math:`\langle \chi_A | -0.5 \Delta \tau_{1b} | \chi_B \rangle`
!
END_DOC
implicit none
integer :: num_A, num_B
integer :: power_A(3), power_B(3)
integer :: i, j, k, l, m
double precision :: alpha, beta, gama, coef
double precision :: A_center(3), B_center(3), C_center(3)
double precision :: c1, c2, c
integer :: dim1
double precision :: overlap_y, d_a_2, overlap_z, overlap
double precision :: int_gauss_r0, int_gauss_r2
PROVIDE j1b_type j1b_pen j1b_coeff
! --------------------------------------------------------------------------------
! -- Dummy call to provide everything
dim1 = 100
A_center(:) = 0.d0
B_center(:) = 1.d0
alpha = 1.d0
beta = 0.1d0
power_A(:) = 1
power_B(:) = 0
call overlap_gaussian_xyz( A_center, B_center, alpha, beta, power_A, power_B &
, overlap_y, d_a_2, overlap_z, overlap, dim1 )
! --------------------------------------------------------------------------------
j1b_gauss_hermI(1:ao_num,1:ao_num) = 0.d0
if(j1b_type .eq. 1) then
! \tau_1b = \sum_iA -[1 - exp(-alpha_A r_iA^2)]
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, k, l, m, alpha, beta, gama, &
!$OMP A_center, B_center, C_center, power_A, power_B, &
!$OMP num_A, num_B, c1, c2, c) &
!$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, &
!$OMP ao_power, ao_nucl, nucl_coord, &
!$OMP ao_coef_normalized_ordered_transp, &
!$OMP nucl_num, j1b_pen, j1b_gauss_hermI)
!$OMP DO SCHEDULE (dynamic)
do j = 1, ao_num
num_A = ao_nucl(j)
power_A(1:3) = ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
do i = 1, ao_num
num_B = ao_nucl(i)
power_B(1:3) = ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l = 1, ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
do m = 1, ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
c = 0.d0
do k = 1, nucl_num
gama = j1b_pen(k)
C_center(1:3) = nucl_coord(k,1:3)
! < XA | exp[-gama r_C^2] | XB >
c1 = int_gauss_r0( A_center, B_center, C_center &
, power_A, power_B, alpha, beta, gama )
! < XA | r_A^2 exp[-gama r_C^2] | XB >
c2 = int_gauss_r2( A_center, B_center, C_center &
, power_A, power_B, alpha, beta, gama )
c = c + 3.d0 * gama * c1 - 2.d0 * gama * gama * c2
enddo
j1b_gauss_hermI(i,j) = j1b_gauss_hermI(i,j) &
+ ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i) * c
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
elseif(j1b_type .eq. 2) then
! \tau_1b = \sum_iA [c_A exp(-alpha_A r_iA^2)]
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, k, l, m, alpha, beta, gama, coef, &
!$OMP A_center, B_center, C_center, power_A, power_B, &
!$OMP num_A, num_B, c1, c2, c) &
!$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, &
!$OMP ao_power, ao_nucl, nucl_coord, &
!$OMP ao_coef_normalized_ordered_transp, &
!$OMP nucl_num, j1b_pen, j1b_gauss_hermI, &
!$OMP j1b_coeff)
!$OMP DO SCHEDULE (dynamic)
do j = 1, ao_num
num_A = ao_nucl(j)
power_A(1:3) = ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
do i = 1, ao_num
num_B = ao_nucl(i)
power_B(1:3) = ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l = 1, ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
do m = 1, ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
c = 0.d0
do k = 1, nucl_num
gama = j1b_pen (k)
coef = j1b_coeff(k)
C_center(1:3) = nucl_coord(k,1:3)
! < XA | exp[-gama r_C^2] | XB >
c1 = int_gauss_r0( A_center, B_center, C_center &
, power_A, power_B, alpha, beta, gama )
! < XA | r_A^2 exp[-gama r_C^2] | XB >
c2 = int_gauss_r2( A_center, B_center, C_center &
, power_A, power_B, alpha, beta, gama )
c = c + 3.d0 * gama * coef * c1 - 2.d0 * gama * gama * coef * c2
enddo
j1b_gauss_hermI(i,j) = j1b_gauss_hermI(i,j) &
+ ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i) * c
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
endif
END_PROVIDER
!_____________________________________________________________________________________________________________
!
! < XA | exp[-gama r_C^2] | XB >
!
double precision function int_gauss_r0(A_center, B_center, C_center, power_A, power_B, alpha, beta, gama)
! for max_dim
include 'constants.include.F'
implicit none
integer , intent(in) :: power_A(3), power_B(3)
double precision, intent(in) :: A_center(3), B_center(3), C_center(3)
double precision, intent(in) :: alpha, beta, gama
integer :: i, power_C, dim1
integer :: iorder(3)
integer :: nmax
double precision :: AB_expo, fact_AB, AB_center(3), P_AB(0:max_dim,3)
double precision :: cx, cy, cz
double precision :: overlap_gaussian_x
dim1 = 100
! P_AB(0:max_dim,3) polynomial
! AB_center(3) new center
! AB_expo new exponent
! fact_AB constant factor
! iorder(3) i_order(i) = order of the polynomials
call give_explicit_poly_and_gaussian( P_AB, AB_center, AB_expo, fact_AB &
, iorder, alpha, beta, power_A, power_B, A_center, B_center, dim1)
if( fact_AB .lt. 1d-20 ) then
int_gauss_r0 = 0.d0
return
endif
power_C = 0
cx = 0.d0
do i = 0, iorder(1)
cx = cx + P_AB(i,1) * overlap_gaussian_x(AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1)
enddo
cy = 0.d0
do i = 0, iorder(2)
cy = cy + P_AB(i,2) * overlap_gaussian_x(AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1)
enddo
cz = 0.d0
do i = 0, iorder(3)
cz = cz + P_AB(i,3) * overlap_gaussian_x(AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1)
enddo
int_gauss_r0 = fact_AB * cx * cy * cz
return
end function int_gauss_r0
!_____________________________________________________________________________________________________________
!_____________________________________________________________________________________________________________
!_____________________________________________________________________________________________________________
!
! < XA | r_C^2 exp[-gama r_C^2] | XB >
!
double precision function int_gauss_r2(A_center, B_center, C_center, power_A, power_B, alpha, beta, gama)
! for max_dim
include 'constants.include.F'
implicit none
integer, intent(in) :: power_A(3), power_B(3)
double precision, intent(in) :: A_center(3), B_center(3), C_center(3)
double precision, intent(in) :: alpha, beta, gama
integer :: i, power_C, dim1
integer :: iorder(3)
double precision :: AB_expo, fact_AB, AB_center(3), P_AB(0:max_dim,3)
double precision :: cx0, cy0, cz0, cx, cy, cz
double precision :: int_tmp
double precision :: overlap_gaussian_x
dim1 = 100
! P_AB(0:max_dim,3) polynomial centered on AB_center
! AB_center(3) new center
! AB_expo new exponent
! fact_AB constant factor
! iorder(3) i_order(i) = order of the polynomials
call give_explicit_poly_and_gaussian( P_AB, AB_center, AB_expo, fact_AB &
, iorder, alpha, beta, power_A, power_B, A_center, B_center, dim1)
! <<<
! to avoid multi-evaluation
power_C = 0
cx0 = 0.d0
do i = 0, iorder(1)
cx0 = cx0 + P_AB(i,1) * overlap_gaussian_x(AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1)
enddo
cy0 = 0.d0
do i = 0, iorder(2)
cy0 = cy0 + P_AB(i,2) * overlap_gaussian_x(AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1)
enddo
cz0 = 0.d0
do i = 0, iorder(3)
cz0 = cz0 + P_AB(i,3) * overlap_gaussian_x(AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1)
enddo
! >>>
int_tmp = 0.d0
power_C = 2
! ( x - XC)^2
cx = 0.d0
do i = 0, iorder(1)
cx = cx + P_AB(i,1) * overlap_gaussian_x(AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1)
enddo
int_tmp += cx * cy0 * cz0
! ( y - YC)^2
cy = 0.d0
do i = 0, iorder(2)
cy = cy + P_AB(i,2) * overlap_gaussian_x(AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1)
enddo
int_tmp += cx0 * cy * cz0
! ( z - ZC)^2
cz = 0.d0
do i = 0, iorder(3)
cz = cz + P_AB(i,3) * overlap_gaussian_x(AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1)
enddo
int_tmp += cx0 * cy0 * cz
int_gauss_r2 = fact_AB * int_tmp
return
end function int_gauss_r2
!_____________________________________________________________________________________________________________
!_____________________________________________________________________________________________________________

142
src/ao_tc_eff_map/one_e_1bgauss_nonherm.irp.f
View File

@ -1,11 +1,10 @@
! ---
BEGIN_PROVIDER [ double precision, j1b_gauss_nonherm, (ao_num,ao_num)]
BEGIN_DOC
!
! Hermitian part of 1-body Jastrow factow in the |AO| basis set.
!
! \langle \chi_i | - grad \tau_{1b} \cdot grad | \chi_j \rangle =
! 2 \sum_A aA \langle \chi_i | exp[-aA riA^2] (ri-rA) \cdot grad | \chi_j \rangle
! j1b_gauss_nonherm(i,j) = \langle \chi_j | - grad \tau_{1b} \cdot grad | \chi_i \rangle
!
END_DOC
@ -14,7 +13,7 @@ BEGIN_PROVIDER [ double precision, j1b_gauss_nonherm, (ao_num,ao_num)]
integer :: num_A, num_B
integer :: power_A(3), power_B(3)
integer :: i, j, k, l, m
double precision :: alpha, beta, gama
double precision :: alpha, beta, gama, coef
double precision :: A_center(3), B_center(3), C_center(3)
double precision :: c1, c
@ -23,7 +22,7 @@ BEGIN_PROVIDER [ double precision, j1b_gauss_nonherm, (ao_num,ao_num)]
double precision :: int_gauss_deriv
PROVIDE j1b_gauss_pen
PROVIDE j1b_type j1b_pen j1b_coeff
! --------------------------------------------------------------------------------
! -- Dummy call to provide everything
@ -41,6 +40,9 @@ BEGIN_PROVIDER [ double precision, j1b_gauss_nonherm, (ao_num,ao_num)]
j1b_gauss_nonherm(1:ao_num,1:ao_num) = 0.d0
if(j1b_type .eq. 1) then
! \tau_1b = \sum_iA -[1 - exp(-alpha_A r_iA^2)]
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, k, l, m, alpha, beta, gama, &
@ -49,53 +51,101 @@ BEGIN_PROVIDER [ double precision, j1b_gauss_nonherm, (ao_num,ao_num)]
!$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, &
!$OMP ao_power, ao_nucl, nucl_coord, &
!$OMP ao_coef_normalized_ordered_transp, &
!$OMP nucl_num, j1b_gauss_pen, j1b_gauss_nonherm)
!$OMP nucl_num, j1b_pen, j1b_gauss_nonherm)
!$OMP DO SCHEDULE (dynamic)
do j = 1, ao_num
num_A = ao_nucl(j)
power_A(1:3) = ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
do i = 1, ao_num
num_B = ao_nucl(i)
power_B(1:3) = ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l = 1, ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
do m = 1, ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
c = 0.d0
do k = 1, nucl_num
gama = j1b_gauss_pen(k)
C_center(1:3) = nucl_coord(k,1:3)
! \langle \chi_A | exp[-gama r_C^2] r_C \cdot grad | \chi_B \rangle
c1 = int_gauss_deriv( A_center, B_center, C_center &
, power_A, power_B, alpha, beta, gama )
c = c + 2.d0 * gama * c1
do j = 1, ao_num
num_A = ao_nucl(j)
power_A(1:3) = ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
do i = 1, ao_num
num_B = ao_nucl(i)
power_B(1:3) = ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l = 1, ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
do m = 1, ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
c = 0.d0
do k = 1, nucl_num
gama = j1b_pen(k)
C_center(1:3) = nucl_coord(k,1:3)
! \langle \chi_A | exp[-gama r_C^2] r_C \cdot grad | \chi_B \rangle
c1 = int_gauss_deriv( A_center, B_center, C_center &
, power_A, power_B, alpha, beta, gama )
c = c + 2.d0 * gama * c1
enddo
j1b_gauss_nonherm(i,j) = j1b_gauss_nonherm(i,j) &
+ ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i) * c
enddo
j1b_gauss_nonherm(i,j) = j1b_gauss_nonherm(i,j) &
+ ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i) * c
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
elseif(j1b_type .eq. 2) then
! \tau_1b = \sum_iA [c_A exp(-alpha_A r_iA^2)]
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, k, l, m, alpha, beta, gama, coef, &
!$OMP A_center, B_center, C_center, power_A, power_B, &
!$OMP num_A, num_B, c1, c) &
!$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, &
!$OMP ao_power, ao_nucl, nucl_coord, &
!$OMP ao_coef_normalized_ordered_transp, &
!$OMP nucl_num, j1b_pen, j1b_gauss_nonherm, &
!$OMP j1b_coeff)
!$OMP DO SCHEDULE (dynamic)
do j = 1, ao_num
num_A = ao_nucl(j)
power_A(1:3) = ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
do i = 1, ao_num
num_B = ao_nucl(i)
power_B(1:3) = ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l = 1, ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
do m = 1, ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
c = 0.d0
do k = 1, nucl_num
gama = j1b_pen (k)
coef = j1b_coeff(k)
C_center(1:3) = nucl_coord(k,1:3)
! \langle \chi_A | exp[-gama r_C^2] r_C \cdot grad | \chi_B \rangle
c1 = int_gauss_deriv( A_center, B_center, C_center &
, power_A, power_B, alpha, beta, gama )
c = c + 2.d0 * gama * coef * c1
enddo
j1b_gauss_nonherm(i,j) = j1b_gauss_nonherm(i,j) &
+ ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i) * c
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
endif
END_PROVIDER
@ -317,3 +367,5 @@ double precision function int_gauss_deriv(A_center, B_center, C_center, power_A,
end function int_gauss_deriv
!_____________________________________________________________________________________________________________
!_____________________________________________________________________________________________________________

48
src/ao_tc_eff_map/potential.irp.f
View File

@ -94,30 +94,40 @@ BEGIN_PROVIDER [double precision, expos_slat_gauss_1_erf_x, (n_fit_1_erf_x)]
expos_slat_gauss_1_erf_x(2) = 0.756023d0
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, expo_gauss_1_erf_x, (n_max_fit_slat)]
&BEGIN_PROVIDER [double precision, coef_gauss_1_erf_x, (n_max_fit_slat)]
implicit none
BEGIN_DOC
! (1 - erf(mu*x)) = \sum_i coef_gauss_1_erf_x(i) * exp(-expo_gauss_1_erf_x(i) * x^2)
!
! This is based on a fit of (1 - erf(mu*x)) by exp(-alpha * x) exp(-beta*mu^2x^2)
!
! and the slater function exp(-alpha * x) is fitted with n_max_fit_slat gaussians
!
! See Appendix 2 of JCP 154, 084119 (2021)
END_DOC
integer :: i
double precision :: expos(n_max_fit_slat),alpha,beta
alpha = expos_slat_gauss_1_erf_x(1) * mu_erf
call expo_fit_slater_gam(alpha,expos)
beta = expos_slat_gauss_1_erf_x(2) * mu_erf**2.d0
BEGIN_DOC
!
! (1 - erf(mu*x)) = \sum_i coef_gauss_1_erf_x(i) * exp(-expo_gauss_1_erf_x(i) * x^2)
!
! This is based on a fit of (1 - erf(mu*x)) by exp(-alpha * x) exp(-beta*mu^2x^2)
!
! and the slater function exp(-alpha * x) is fitted with n_max_fit_slat gaussians
!
! See Appendix 2 of JCP 154, 084119 (2021)
!
END_DOC
implicit none
integer :: i
double precision :: expos(n_max_fit_slat), alpha, beta
alpha = expos_slat_gauss_1_erf_x(1) * mu_erf
call expo_fit_slater_gam(alpha, expos)
beta = expos_slat_gauss_1_erf_x(2) * mu_erf * mu_erf
do i = 1, n_max_fit_slat
expo_gauss_1_erf_x(i) = expos(i) + beta
coef_gauss_1_erf_x(i) = coef_fit_slat_gauss(i)
enddo
do i = 1, n_max_fit_slat
expo_gauss_1_erf_x(i) = expos(i) + beta
coef_gauss_1_erf_x(i) = coef_fit_slat_gauss(i)
enddo
END_PROVIDER
! ---
double precision function fit_1_erf_x(x)
implicit none
double precision, intent(in) :: x

800
src/ao_tc_eff_map/two_e_1bgauss_coul.irp.f
View File

@ -1,800 +0,0 @@
double precision function j1b_gauss_coul(i, j, k, l)
BEGIN_DOC
!
! integral in the AO basis:
! i(r1) j(r1) f(r12) k(r2) l(r2)
!
! with:
! f(r12) = - [ 0.5 / r12 ] (r1-r2) \cdot \sum_A (-2 a_A) [ r1A exp(-aA r1A^2) - r2A exp(-aA r2A^2) ]
! = [ 1 / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2)
! + (r2-RA)^2 exp(-aA r2A^2)
! - (r1-RA) \cdot (r2-RA) exp(-aA r1A^2)
! - (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ]
!
END_DOC
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: i, j, k, l
integer :: p, q, r, s, ii
integer :: num_i, num_j, num_k, num_l, num_ii
integer :: I_power(3), J_power(3), K_power(3), L_power(3)
integer :: iorder_p(3), iorder_q(3)
integer :: shift_P(3), shift_Q(3)
integer :: dim1
double precision :: coef1, coef2, coef3, coef4
double precision :: expo1, expo2, expo3, expo4
double precision :: p_inv, q_inv
double precision :: P_new_tmp(0:max_dim,3), P_center_tmp(3), fact_p_tmp, pp_tmp
double precision :: Q_new_tmp(0:max_dim,3), Q_center_tmp(3), fact_q_tmp, qq_tmp
double precision :: P_new(0:max_dim,3), P_center(3), fact_p, pp
double precision :: Q_new(0:max_dim,3), Q_center(3), fact_q, qq
double precision :: I_center(3), J_center(3), K_center(3), L_center(3)
double precision :: expoii, factii, Centerii(3)
double precision :: ff, gg, cx, cy, cz
double precision :: general_primitive_integral_coul_shifted
PROVIDE j1b_gauss_pen
dim1 = n_pt_max_integrals
num_i = ao_nucl(i)
num_j = ao_nucl(j)
num_k = ao_nucl(k)
num_l = ao_nucl(l)
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
I_center(p) = nucl_coord(num_i,p)
J_center(p) = nucl_coord(num_j,p)
K_center(p) = nucl_coord(num_k,p)
L_center(p) = nucl_coord(num_l,p)
enddo
j1b_gauss_coul = 0.d0
! -------------------------------------------------------------------------------------------------------------------
!
! [ 1 / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2)
!
! -------------------------------------------------------------------------------------------------------------------
shift_Q = (/ 0, 0, 0 /)
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
expo1 = ao_expo_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
expo2 = ao_expo_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P_new_tmp, P_center_tmp, pp_tmp, fact_p_tmp, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
do r = 1, ao_prim_num(k)
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q_new, Q_center, qq, fact_q, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
q_inv = 1.d0 / qq
cx = 0.d0
cy = 0.d0
cz = 0.d0
do ii = 1, nucl_num
expoii = j1b_gauss_pen(ii)
Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(pp_tmp, P_center_tmp, expoii, Centerii, factii, pp, P_center)
fact_p = fact_p_tmp * factii
p_inv = 1.d0 / pp
! pol centerd on P_center_tmp ==> centerd on P_center
call pol_modif_center( P_center_tmp, P_center, iorder_p, P_new_tmp, P_new)
! ----------------------------------------------------------------------------------------------------
! x term:
ff = P_center(1) - Centerii(1)
shift_P = (/ 2, 0, 0 /)
cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P = (/ 1, 0, 0 /)
cx = cx + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 0 /)
cx = cx + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! y term:
ff = P_center(2) - Centerii(2)
shift_P = (/ 0, 2, 0 /)
cy = cy + expoii * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P = (/ 0, 1, 0 /)
cy = cy + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 0 /)
cy = cy + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! z term:
ff = P_center(3) - Centerii(3)
shift_P = (/ 0, 0, 2 /)
cz = cz + expoii * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 1 /)
cz = cz + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 0 /)
cz = cz + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
enddo
j1b_gauss_coul = j1b_gauss_coul + coef4 * ( cx + cy + cz )
enddo ! s
enddo ! r
enddo ! q
enddo ! p
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
!
! [ 1 / r12 ] \sum_A a_A [ (r2-RA)^2 exp(-aA r2A^2)
!
! -------------------------------------------------------------------------------------------------------------------
shift_P = (/ 0, 0, 0 /)
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
expo1 = ao_expo_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
expo2 = ao_expo_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P_new, P_center, pp, fact_p, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
p_inv = 1.d0 / pp
do r = 1, ao_prim_num(k)
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q_new_tmp, Q_center_tmp, qq_tmp, fact_q_tmp, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
cx = 0.d0
cy = 0.d0
cz = 0.d0
do ii = 1, nucl_num
expoii = j1b_gauss_pen(ii)
Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(qq_tmp, Q_center_tmp, expoii, Centerii, factii, qq, Q_center)
fact_q = fact_q_tmp * factii
q_inv = 1.d0 / qq
! pol centerd on Q_center_tmp ==> centerd on Q_center
call pol_modif_center( Q_center_tmp, Q_center, iorder_q, Q_new_tmp, Q_new)
! ----------------------------------------------------------------------------------------------------
! x term:
ff = Q_center(1) - Centerii(1)
shift_Q = (/ 2, 0, 0 /)
cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_Q = (/ 1, 0, 0 /)
cx = cx + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 0, 0 /)
cx = cx + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! y term:
ff = Q_center(2) - Centerii(2)
shift_Q = (/ 0, 2, 0 /)
cy = cy + expoii * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 1, 0 /)
cy = cy + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 0, 0 /)
cy = cy + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! z term:
ff = Q_center(3) - Centerii(3)
shift_Q = (/ 0, 0, 2 /)
cz = cz + expoii * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 0, 1 /)
cz = cz + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 0, 0 /)
cz = cz + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
enddo
j1b_gauss_coul = j1b_gauss_coul + coef4 * ( cx + cy + cz )
enddo ! s
enddo ! r
enddo ! q
enddo ! p
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
!
! - [ 1 / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r1A^2) ]
!
! -------------------------------------------------------------------------------------------------------------------
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
expo1 = ao_expo_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
expo2 = ao_expo_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P_new_tmp, P_center_tmp, pp_tmp, fact_p_tmp, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
do r = 1, ao_prim_num(k)
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q_new, Q_center, qq, fact_q, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
q_inv = 1.d0 / qq
cx = 0.d0
cy = 0.d0
cz = 0.d0
do ii = 1, nucl_num
expoii = j1b_gauss_pen(ii)
Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(pp_tmp, P_center_tmp, expoii, Centerii, factii, pp, P_center)
fact_p = fact_p_tmp * factii
p_inv = 1.d0 / pp
! pol centerd on P_center_tmp ==> centerd on P_center
call pol_modif_center( P_center_tmp, P_center, iorder_p, P_new_tmp, P_new)
! ----------------------------------------------------------------------------------------------------
! x term:
ff = P_center(1) - Centerii(1)
gg = Q_center(1) - Centerii(1)
shift_p = (/ 1, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 1, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx + expoii * gg * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx + expoii * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx + expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! y term:
ff = P_center(2) - Centerii(2)
gg = Q_center(2) - Centerii(2)
shift_p = (/ 0, 1, 0 /)
shift_Q = (/ 0, 1, 0 /)
cy = cy + expoii * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 0, 1, 0 /)
shift_Q = (/ 0, 0, 0 /)
cy = cy + expoii * gg * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 1, 0 /)
cy = cy + expoii * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cy = cy + expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! z term:
ff = P_center(3) - Centerii(3)
gg = Q_center(3) - Centerii(3)
shift_p = (/ 0, 0, 1 /)
shift_Q = (/ 0, 0, 1 /)
cz = cz + expoii * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 1 /)
shift_Q = (/ 0, 0, 0 /)
cz = cz + expoii * gg * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 1 /)
cz = cz + expoii * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cz = cz + expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
enddo
j1b_gauss_coul = j1b_gauss_coul - coef4 * ( cx + cy + cz )
enddo ! s
enddo ! r
enddo ! q
enddo ! p
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
!
! - [ 1 / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ]
!
! -------------------------------------------------------------------------------------------------------------------
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
expo1 = ao_expo_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
expo2 = ao_expo_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P_new, P_center, pp, fact_p, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
p_inv = 1.d0 / pp
do r = 1, ao_prim_num(k)
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q_new_tmp, Q_center_tmp, qq_tmp, fact_q_tmp, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
cx = 0.d0
cy = 0.d0
cz = 0.d0
do ii = 1, nucl_num
expoii = j1b_gauss_pen(ii)
Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(qq_tmp, Q_center_tmp, expoii, Centerii, factii, qq, Q_center)
fact_q = fact_q_tmp * factii
q_inv = 1.d0 / qq
! pol centerd on Q_center_tmp ==> centerd on Q_center
call pol_modif_center( Q_center_tmp, Q_center, iorder_q, Q_new_tmp, Q_new)
! ----------------------------------------------------------------------------------------------------
! x term:
ff = P_center(1) - Centerii(1)
gg = Q_center(1) - Centerii(1)
shift_p = (/ 1, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 1, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx + expoii * gg * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx + expoii * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx + expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! y term:
ff = P_center(2) - Centerii(2)
gg = Q_center(2) - Centerii(2)
shift_p = (/ 0, 1, 0 /)
shift_Q = (/ 0, 1, 0 /)
cy = cy + expoii * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 0, 1, 0 /)
shift_Q = (/ 0, 0, 0 /)
cy = cy + expoii * gg * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 1, 0 /)
cy = cy + expoii * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cy = cy + expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! z term:
ff = P_center(3) - Centerii(3)
gg = Q_center(3) - Centerii(3)
shift_p = (/ 0, 0, 1 /)
shift_Q = (/ 0, 0, 1 /)
cz = cz + expoii * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 1 /)
shift_Q = (/ 0, 0, 0 /)
cz = cz + expoii * gg * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 1 /)
cz = cz + expoii * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cz = cz + expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
enddo
j1b_gauss_coul = j1b_gauss_coul - coef4 * ( cx + cy + cz )
enddo ! s
enddo ! r
enddo ! q
enddo ! p
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
return
end function j1b_gauss_coul
!______________________________________________________________________________________________________________________
!______________________________________________________________________________________________________________________
double precision function general_primitive_integral_coul_shifted( dim &
, P_new, P_center, fact_p, p, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, q, q_inv, iorder_q, shift_Q )
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: dim
integer, intent(in) :: iorder_p(3), shift_P(3)
integer, intent(in) :: iorder_q(3), shift_Q(3)
double precision, intent(in) :: P_new(0:max_dim,3), P_center(3), fact_p, p, p_inv
double precision, intent(in) :: Q_new(0:max_dim,3), Q_center(3), fact_q, q, q_inv
integer :: n_Ix, n_Iy, n_Iz, nx, ny, nz
integer :: ix, iy, iz, jx, jy, jz, i
integer :: n_pt_tmp, n_pt_out, iorder
integer :: ii, jj
double precision :: rho, dist
double precision :: dx(0:max_dim), Ix_pol(0:max_dim)
double precision :: dy(0:max_dim), Iy_pol(0:max_dim)
double precision :: dz(0:max_dim), Iz_pol(0:max_dim)
double precision :: a, b, c, d, e, f, accu, pq, const
double precision :: pq_inv, p10_1, p10_2, p01_1, p01_2, pq_inv_2
double precision :: d1(0:max_dim), d_poly(0:max_dim)
double precision :: p_plus_q
double precision :: rint_sum
general_primitive_integral_coul_shifted = 0.d0
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: dx, Ix_pol, dy, Iy_pol, dz, Iz_pol
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: d1, d_poly
! Gaussian Product
! ----------------
p_plus_q = (p+q)
pq = p_inv * 0.5d0 * q_inv
pq_inv = 0.5d0 / p_plus_q
p10_1 = q * pq ! 1/(2p)
p01_1 = p * pq ! 1/(2q)
pq_inv_2 = pq_inv + pq_inv
p10_2 = pq_inv_2 * p10_1 * q ! 0.5d0 * q / (pq + p*p)
p01_2 = pq_inv_2 * p01_1 * p ! 0.5d0 * p / (q*q + pq)
accu = 0.d0
iorder = iorder_p(1) + iorder_q(1) + iorder_p(1) + iorder_q(1)
iorder = iorder + shift_P(1) + shift_Q(1)
iorder = iorder + shift_P(1) + shift_Q(1)
!DIR$ VECTOR ALIGNED
do ix = 0, iorder
Ix_pol(ix) = 0.d0
enddo
n_Ix = 0
do ix = 0, iorder_p(1)
ii = ix + shift_P(1)
a = P_new(ix,1)
if(abs(a) < thresh) cycle
do jx = 0, iorder_q(1)
jj = jx + shift_Q(1)
d = a * Q_new(jx,1)
if(abs(d) < thresh) cycle
!DEC$ FORCEINLINE
call give_polynom_mult_center_x( P_center(1), Q_center(1), ii, jj &
, p, q, iorder, pq_inv, pq_inv_2, p10_1, p01_1, p10_2, p01_2, dx, nx )
!DEC$ FORCEINLINE
call add_poly_multiply(dx, nx, d, Ix_pol, n_Ix)
enddo
enddo
if(n_Ix == -1) then
return
endif
iorder = iorder_p(2) + iorder_q(2) + iorder_p(2) + iorder_q(2)
iorder = iorder + shift_P(2) + shift_Q(2)
iorder = iorder + shift_P(2) + shift_Q(2)
!DIR$ VECTOR ALIGNED
do ix = 0, iorder
Iy_pol(ix) = 0.d0
enddo
n_Iy = 0
do iy = 0, iorder_p(2)
if(abs(P_new(iy,2)) > thresh) then
ii = iy + shift_P(2)
b = P_new(iy,2)
do jy = 0, iorder_q(2)
jj = jy + shift_Q(2)
e = b * Q_new(jy,2)
if(abs(e) < thresh) cycle
!DEC$ FORCEINLINE
call give_polynom_mult_center_x( P_center(2), Q_center(2), ii, jj &
, p, q, iorder, pq_inv, pq_inv_2, p10_1, p01_1, p10_2, p01_2, dy, ny )
!DEC$ FORCEINLINE
call add_poly_multiply(dy, ny, e, Iy_pol, n_Iy)
enddo
endif
enddo
if(n_Iy == -1) then
return
endif
iorder = iorder_p(3) + iorder_q(3) + iorder_p(3) + iorder_q(3)
iorder = iorder + shift_P(3) + shift_Q(3)
iorder = iorder + shift_P(3) + shift_Q(3)
do ix = 0, iorder
Iz_pol(ix) = 0.d0
enddo
n_Iz = 0
do iz = 0, iorder_p(3)
if( abs(P_new(iz,3)) > thresh ) then
ii = iz + shift_P(3)
c = P_new(iz,3)
do jz = 0, iorder_q(3)
jj = jz + shift_Q(3)
f = c * Q_new(jz,3)
if(abs(f) < thresh) cycle
!DEC$ FORCEINLINE
call give_polynom_mult_center_x( P_center(3), Q_center(3), ii, jj &
, p, q, iorder, pq_inv, pq_inv_2, p10_1, p01_1, p10_2, p01_2, dz, nz )
!DEC$ FORCEINLINE
call add_poly_multiply(dz, nz, f, Iz_pol, n_Iz)
enddo
endif
enddo
if(n_Iz == -1) then
return
endif
rho = p * q * pq_inv_2
dist = (P_center(1) - Q_center(1)) * (P_center(1) - Q_center(1)) &
+ (P_center(2) - Q_center(2)) * (P_center(2) - Q_center(2)) &
+ (P_center(3) - Q_center(3)) * (P_center(3) - Q_center(3))
const = dist*rho
n_pt_tmp = n_Ix + n_Iy
do i = 0, n_pt_tmp
d_poly(i) = 0.d0
enddo
!DEC$ FORCEINLINE
call multiply_poly(Ix_pol, n_Ix, Iy_pol, n_Iy, d_poly, n_pt_tmp)
if(n_pt_tmp == -1) then
return
endif
n_pt_out = n_pt_tmp + n_Iz
do i = 0, n_pt_out
d1(i) = 0.d0
enddo
!DEC$ FORCEINLINE
call multiply_poly(d_poly, n_pt_tmp, Iz_pol, n_Iz, d1, n_pt_out)
accu = accu + rint_sum(n_pt_out, const, d1)
general_primitive_integral_coul_shifted = fact_p * fact_q * accu * pi_5_2 * p_inv * q_inv / dsqrt(p_plus_q)
return
end function general_primitive_integral_coul_shifted
!______________________________________________________________________________________________________________________
!______________________________________________________________________________________________________________________

433
src/ao_tc_eff_map/two_e_1bgauss_coul_acc.irp.f
View File

@ -1,433 +0,0 @@
double precision function j1b_gauss_coul_acc(i, j, k, l)
BEGIN_DOC
!
! integral in the AO basis:
! i(r1) j(r1) f(r12) k(r2) l(r2)
!
! with:
! f(r12) = - [ 0.5 / r12 ] (r1-r2) \cdot \sum_A (-2 a_A) [ r1A exp(-aA r1A^2) - r2A exp(-aA r2A^2) ]
! = [ 1 / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2)
! + (r2-RA)^2 exp(-aA r2A^2)
! - (r1-RA) \cdot (r2-RA) exp(-aA r1A^2)
! - (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ]
!
END_DOC
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: i, j, k, l
integer :: p, q, r, s, ii
integer :: num_i, num_j, num_k, num_l, num_ii
integer :: I_power(3), J_power(3), K_power(3), L_power(3)
integer :: iorder_p(3), iorder_q(3)
integer :: shift_P(3), shift_Q(3)
integer :: dim1
double precision :: coef1, coef2, coef3, coef4
double precision :: expo1, expo2, expo3, expo4
double precision :: p1_inv, q1_inv, p2_inv, q2_inv
double precision :: P1_new(0:max_dim,3), P1_center(3), fact_p1, pp1
double precision :: P2_new(0:max_dim,3), P2_center(3), fact_p2, pp2
double precision :: Q1_new(0:max_dim,3), Q1_center(3), fact_q1, qq1
double precision :: Q2_new(0:max_dim,3), Q2_center(3), fact_q2, qq2
double precision :: I_center(3), J_center(3), K_center(3), L_center(3)
double precision :: expoii, factii, Centerii(3)
double precision :: ff, gg, cx, cy, cz
double precision :: general_primitive_integral_coul_shifted
!double precision :: j1b_gauss_coul_schwartz_accel
PROVIDE j1b_gauss_pen
dim1 = n_pt_max_integrals
! TODO
!if( ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then
! j1b_gauss_coul_schwartz_accel = j1b_gauss_coul_schwartz_accel(i, j, k, l)
! return
!endif
num_i = ao_nucl(i)
num_j = ao_nucl(j)
num_k = ao_nucl(k)
num_l = ao_nucl(l)
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
I_center(p) = nucl_coord(num_i,p)
J_center(p) = nucl_coord(num_j,p)
K_center(p) = nucl_coord(num_k,p)
L_center(p) = nucl_coord(num_l,p)
enddo
j1b_gauss_coul_acc = 0.d0
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
expo1 = ao_expo_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
expo2 = ao_expo_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P1_new, P1_center, pp1, fact_p1, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
p1_inv = 1.d0 / pp1
do r = 1, ao_prim_num(k)
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q1_new, Q1_center, qq1, fact_q1, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
q1_inv = 1.d0 / qq1
cx = 0.d0
cy = 0.d0
cz = 0.d0
do ii = 1, nucl_num
expoii = j1b_gauss_pen(ii)
Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(pp1, P1_center, expoii, Centerii, factii, pp2, P2_center)
fact_p2 = fact_p1 * factii
p2_inv = 1.d0 / pp2
call pol_modif_center( P1_center, P2_center, iorder_p, P1_new, P2_new)
call gaussian_product(qq1, Q1_center, expoii, Centerii, factii, qq2, Q2_center)
fact_q2 = fact_q1 * factii
q2_inv = 1.d0 / qq2
call pol_modif_center( Q1_center, Q2_center, iorder_q, Q1_new, Q2_new)
! ----------------------------------------------------------------------------------------------------
! [ 1 / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2)
! ----------------------------------------------------------------------------------------------------
shift_Q = (/ 0, 0, 0 /)
! x term:
ff = P2_center(1) - Centerii(1)
shift_P = (/ 2, 0, 0 /)
cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 1, 0, 0 /)
cx = cx + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 0 /)
cx = cx + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! y term:
ff = P2_center(2) - Centerii(2)
shift_P = (/ 0, 2, 0 /)
cy = cy + expoii * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 0, 1, 0 /)
cy = cy + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 0 /)
cy = cy + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! z term:
ff = P2_center(3) - Centerii(3)
shift_P = (/ 0, 0, 2 /)
cz = cz + expoii * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 1 /)
cz = cz + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 0 /)
cz = cz + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! [ 1 / r12 ] \sum_A a_A [ (r2-RA)^2 exp(-aA r2A^2)
! ----------------------------------------------------------------------------------------------------
shift_P = (/ 0, 0, 0 /)
! x term:
ff = Q2_center(1) - Centerii(1)
shift_Q = (/ 2, 0, 0 /)
cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 1, 0, 0 /)
cx = cx + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 0, 0 /)
cx = cx + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! y term:
ff = Q2_center(2) - Centerii(2)
shift_Q = (/ 0, 2, 0 /)
cy = cy + expoii * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 1, 0 /)
cy = cy + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 0, 0 /)
cy = cy + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! z term:
ff = Q2_center(3) - Centerii(3)
shift_Q = (/ 0, 0, 2 /)
cz = cz + expoii * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 0, 1 /)
cz = cz + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 0, 0 /)
cz = cz + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! - [ 1 / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r1A^2) ]
! ----------------------------------------------------------------------------------------------------
! x term:
ff = P2_center(1) - Centerii(1)
gg = Q1_center(1) - Centerii(1)
shift_p = (/ 1, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx - expoii * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 1, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx - expoii * gg * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx - expoii * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx - expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! y term:
ff = P2_center(2) - Centerii(2)
gg = Q1_center(2) - Centerii(2)
shift_p = (/ 0, 1, 0 /)
shift_Q = (/ 0, 1, 0 /)
cy = cy - expoii * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 1, 0 /)
shift_Q = (/ 0, 0, 0 /)
cy = cy - expoii * gg * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 1, 0 /)
cy = cy - expoii * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cy = cy - expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! z term:
ff = P2_center(3) - Centerii(3)
gg = Q1_center(3) - Centerii(3)
shift_p = (/ 0, 0, 1 /)
shift_Q = (/ 0, 0, 1 /)
cz = cz - expoii * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 1 /)
shift_Q = (/ 0, 0, 0 /)
cz = cz - expoii * gg * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 1 /)
cz = cz - expoii * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cz = cz - expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! - [ 1 / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ]
! ----------------------------------------------------------------------------------------------------
! x term:
ff = P1_center(1) - Centerii(1)
gg = Q2_center(1) - Centerii(1)
shift_p = (/ 1, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx - expoii * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 1, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx - expoii * gg * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx - expoii * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx - expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! y term:
ff = P1_center(2) - Centerii(2)
gg = Q2_center(2) - Centerii(2)
shift_p = (/ 0, 1, 0 /)
shift_Q = (/ 0, 1, 0 /)
cy = cy - expoii * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 1, 0 /)
shift_Q = (/ 0, 0, 0 /)
cy = cy - expoii * gg * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 1, 0 /)
cy = cy - expoii * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cy = cy - expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! z term:
ff = P1_center(3) - Centerii(3)
gg = Q2_center(3) - Centerii(3)
shift_p = (/ 0, 0, 1 /)
shift_Q = (/ 0, 0, 1 /)
cz = cz - expoii * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 1 /)
shift_Q = (/ 0, 0, 0 /)
cz = cz - expoii * gg * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 1 /)
cz = cz - expoii * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cz = cz - expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
enddo
j1b_gauss_coul_acc = j1b_gauss_coul_acc + coef4 * ( cx + cy + cz )
enddo ! s
enddo ! r
enddo ! q
enddo ! p
return
end function j1b_gauss_coul_acc

397
src/ao_tc_eff_map/two_e_1bgauss_coul_debug.irp.f
View File

@ -1,397 +0,0 @@
double precision function j1b_gauss_coul_debug(i, j, k, l)
BEGIN_DOC
!
! integral in the AO basis:
! i(r1) j(r1) f(r12) k(r2) l(r2)
!
! with:
! f(r12) = - [ 0.5 / r12 ] (r1-r2) \cdot \sum_A (-2 a_A) [ r1A exp(-aA r1A^2) - r2A exp(-aA r2A^2) ]
! = [ 1 / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2)
! + (r2-RA)^2 exp(-aA r2A^2)
! - (r1-RA) \cdot (r2-RA) exp(-aA r1A^2)
! - (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ]
!
END_DOC
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: i, j, k, l
integer :: p, q, r, s, ii
integer :: num_i, num_j, num_k, num_l, num_ii
integer :: I_power(3), J_power(3), K_power(3), L_power(3)
integer :: iorder_p(3), iorder_q(3)
integer :: shift_P(3), shift_Q(3)
integer :: dim1
double precision :: coef1, coef2, coef3, coef4
double precision :: expo1, expo2, expo3, expo4
double precision :: p_inv, q_inv
double precision :: P_new_tmp(0:max_dim,3), P_center_tmp(3), fact_p_tmp, pp_tmp
double precision :: Q_new_tmp(0:max_dim,3), Q_center_tmp(3), fact_q_tmp, qq_tmp
double precision :: P_new(0:max_dim,3), P_center(3), fact_p, pp
double precision :: Q_new(0:max_dim,3), Q_center(3), fact_q, qq
double precision :: I_center(3), J_center(3), K_center(3), L_center(3)
double precision :: expoii, factii, Centerii(3)
double precision :: ff, gg, cx, cy, cz
double precision :: general_primitive_integral_coul_shifted
PROVIDE j1b_gauss_pen
dim1 = n_pt_max_integrals
num_i = ao_nucl(i)
num_j = ao_nucl(j)
num_k = ao_nucl(k)
num_l = ao_nucl(l)
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
I_center(p) = nucl_coord(num_i,p)
J_center(p) = nucl_coord(num_j,p)
K_center(p) = nucl_coord(num_k,p)
L_center(p) = nucl_coord(num_l,p)
enddo
j1b_gauss_coul_debug = 0.d0
! -------------------------------------------------------------------------------------------------------------------
!
! [ 1 / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2)
!
! -------------------------------------------------------------------------------------------------------------------
shift_Q = (/ 0, 0, 0 /)
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
expo1 = ao_expo_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
expo2 = ao_expo_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P_new_tmp, P_center_tmp, pp_tmp, fact_p_tmp, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
do r = 1, ao_prim_num(k)
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q_new, Q_center, qq, fact_q, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
q_inv = 1.d0 / qq
cx = 0.d0
do ii = 1, nucl_num
expoii = j1b_gauss_pen(ii)
Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(pp_tmp, P_center_tmp, expoii, Centerii, factii, pp, P_center)
fact_p = fact_p_tmp * factii
p_inv = 1.d0 / pp
! pol centerd on P_center_tmp ==> centerd on P_center
call pol_modif_center( P_center_tmp, P_center, iorder_p, P_new_tmp, P_new)
! ----------------------------------------------------------------------------------------------------
! x term:
ff = P_center(1) - Centerii(1)
shift_P = (/ 2, 0, 0 /)
cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P = (/ 1, 0, 0 /)
cx = cx + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 0 /)
cx = cx + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
enddo
j1b_gauss_coul_debug = j1b_gauss_coul_debug + coef4 * cx
enddo ! s
enddo ! r
enddo ! q
enddo ! p
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
! ! -------------------------------------------------------------------------------------------------------------------
! !
! ! [ 1 / r12 ] \sum_A a_A [ (r2-RA)^2 exp(-aA r2A^2)
! !
! ! -------------------------------------------------------------------------------------------------------------------
!
! shift_P = (/ 0, 0, 0 /)
!
! do p = 1, ao_prim_num(i)
! coef1 = ao_coef_normalized_ordered_transp(p, i)
! expo1 = ao_expo_ordered_transp(p, i)
!
! do q = 1, ao_prim_num(j)
! coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
! expo2 = ao_expo_ordered_transp(q, j)
!
! call give_explicit_poly_and_gaussian( P_new, P_center, pp, fact_p, iorder_p, expo1, expo2 &
! , I_power, J_power, I_center, J_center, dim1 )
! p_inv = 1.d0 / pp
!
! do r = 1, ao_prim_num(k)
! coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
! expo3 = ao_expo_ordered_transp(r, k)
!
! do s = 1, ao_prim_num(l)
! coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
! expo4 = ao_expo_ordered_transp(s, l)
!
! call give_explicit_poly_and_gaussian( Q_new_tmp, Q_center_tmp, qq_tmp, fact_q_tmp, iorder_q, expo3, expo4 &
! , K_power, L_power, K_center, L_center, dim1 )
!
! cx = 0.d0
! do ii = 1, nucl_num
! expoii = j1b_gauss_pen(ii)
! Centerii(1:3) = nucl_coord(ii, 1:3)
!
! call gaussian_product(qq_tmp, Q_center_tmp, expoii, Centerii, factii, qq, Q_center)
!
! fact_q = fact_q_tmp * factii
! q_inv = 1.d0 / qq
!
! ! pol centerd on Q_center_tmp ==> centerd on Q_center
! call pol_modif_center( Q_center_tmp, Q_center, iorder_q, Q_new_tmp, Q_new)
!
! ! ----------------------------------------------------------------------------------------------------
! ! x term:
!
! ff = Q_center(1) - Centerii(1)
!
! shift_Q = (/ 2, 0, 0 /)
! cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 &
! , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
! , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
!
! shift_Q = (/ 1, 0, 0 /)
! cx = cx + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
! , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
! , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
!
! shift_Q = (/ 0, 0, 0 /)
! cx = cx + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
! , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
! , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
!
! ! ----------------------------------------------------------------------------------------------------
!
! enddo
!
! j1b_gauss_coul_debug = j1b_gauss_coul_debug + coef4 * cx
! enddo ! s
! enddo ! r
! enddo ! q
! enddo ! p
!
! ! -------------------------------------------------------------------------------------------------------------------
! ! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
!
! - [ 1 / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r1A^2) ]
!
! -------------------------------------------------------------------------------------------------------------------
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
expo1 = ao_expo_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
expo2 = ao_expo_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P_new_tmp, P_center_tmp, pp_tmp, fact_p_tmp, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
do r = 1, ao_prim_num(k)
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q_new, Q_center, qq, fact_q, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
q_inv = 1.d0 / qq
cx = 0.d0
do ii = 1, nucl_num
expoii = j1b_gauss_pen(ii)
Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(pp_tmp, P_center_tmp, expoii, Centerii, factii, pp, P_center)
fact_p = fact_p_tmp * factii
p_inv = 1.d0 / pp
! pol centerd on P_center_tmp ==> centerd on P_center
call pol_modif_center( P_center_tmp, P_center, iorder_p, P_new_tmp, P_new)
! ----------------------------------------------------------------------------------------------------
! x term:
ff = P_center(1) - Centerii(1)
gg = Q_center(1) - Centerii(1)
shift_P = (/ 1, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P = (/ 1, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx + expoii * gg * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx + expoii * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx + expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
enddo
j1b_gauss_coul_debug = j1b_gauss_coul_debug - coef4 * cx
enddo ! s
enddo ! r
enddo ! q
enddo ! p
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
! ! -------------------------------------------------------------------------------------------------------------------
! !
! ! - [ 1 / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ]
! !
! ! -------------------------------------------------------------------------------------------------------------------
!
! do p = 1, ao_prim_num(i)
! coef1 = ao_coef_normalized_ordered_transp(p, i)
! expo1 = ao_expo_ordered_transp(p, i)
!
! do q = 1, ao_prim_num(j)
! coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
! expo2 = ao_expo_ordered_transp(q, j)
!
! call give_explicit_poly_and_gaussian( P_new, P_center, pp, fact_p, iorder_p, expo1, expo2 &
! , I_power, J_power, I_center, J_center, dim1 )
! p_inv = 1.d0 / pp
!
! do r = 1, ao_prim_num(k)
! coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
! expo3 = ao_expo_ordered_transp(r, k)
!
! do s = 1, ao_prim_num(l)
! coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
! expo4 = ao_expo_ordered_transp(s, l)
!
! call give_explicit_poly_and_gaussian( Q_new_tmp, Q_center_tmp, qq_tmp, fact_q_tmp, iorder_q, expo3, expo4 &
! , K_power, L_power, K_center, L_center, dim1 )
!
! cx = 0.d0
! do ii = 1, nucl_num
! expoii = j1b_gauss_pen(ii)
! Centerii(1:3) = nucl_coord(ii, 1:3)
!
! call gaussian_product(qq_tmp, Q_center_tmp, expoii, Centerii, factii, qq, Q_center)
!
! fact_q = fact_q_tmp * factii
! q_inv = 1.d0 / qq
!
! ! pol centerd on Q_center_tmp ==> centerd on Q_center
! call pol_modif_center( Q_center_tmp, Q_center, iorder_q, Q_new_tmp, Q_new)
!
! ! ----------------------------------------------------------------------------------------------------
! ! x term:
!
! ff = P_center(1) - Centerii(1)
! gg = Q_center(1) - Centerii(1)
!
! shift_P = (/ 1, 0, 0 /)
! shift_Q = (/ 1, 0, 0 /)
! cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 &
! , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
! , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
!
! shift_P = (/ 1, 0, 0 /)
! shift_Q = (/ 0, 0, 0 /)
! cx = cx + expoii * gg * general_primitive_integral_coul_shifted( dim1 &
! , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
! , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
!
! shift_P = (/ 0, 0, 0 /)
! shift_Q = (/ 1, 0, 0 /)
! cx = cx + expoii * ff * general_primitive_integral_coul_shifted( dim1 &
! , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
! , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
!
! shift_P = (/ 0, 0, 0 /)
! shift_Q = (/ 0, 0, 0 /)
! cx = cx + expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
! , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
! , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
!
! ! ----------------------------------------------------------------------------------------------------
!
! enddo
!
! j1b_gauss_coul_debug = j1b_gauss_coul_debug - coef4 * cx
!
! enddo ! s
! enddo ! r
! enddo ! q
! enddo ! p
!
! ! -------------------------------------------------------------------------------------------------------------------
! ! -------------------------------------------------------------------------------------------------------------------
return
end function j1b_gauss_coul_debug

324
src/ao_tc_eff_map/two_e_1bgauss_coul_modifdebug.irp.f
View File

@ -1,324 +0,0 @@
double precision function j1b_gauss_coul_modifdebug(i, j, k, l)
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: i, j, k, l
integer :: p, q, r, s, ii
integer :: num_i, num_j, num_k, num_l, num_ii
integer :: I_power(3), J_power(3), K_power(3), L_power(3)
integer :: iorder_p(3), iorder_q(3)
integer :: shift_P(3), shift_Q(3)
integer :: dim1
double precision :: coef1, coef2, coef3, coef4
double precision :: expo1, expo2, expo3, expo4
double precision :: p_inv, q_inv
double precision :: P_new_tmp(0:max_dim,3), P_center_tmp(3), fact_p_tmp, pp_tmp
double precision :: Q_new_tmp(0:max_dim,3), Q_center_tmp(3), fact_q_tmp, qq_tmp
double precision :: P_new(0:max_dim,3), P_center(3), fact_p, pp
double precision :: Q_new(0:max_dim,3), Q_center(3), fact_q, qq
double precision :: I_center(3), J_center(3), K_center(3), L_center(3)
double precision :: expoii, factii, Centerii(3)
double precision :: ff, gg, cx, cy, cz
double precision :: general_primitive_integral_coul
double precision :: general_primitive_integral_coul_shifted
double precision :: ao_two_e_integral
PROVIDE j1b_gauss_pen
dim1 = n_pt_max_integrals
num_i = ao_nucl(i)
num_j = ao_nucl(j)
num_k = ao_nucl(k)
num_l = ao_nucl(l)
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
I_center(p) = nucl_coord(num_i,p)
J_center(p) = nucl_coord(num_j,p)
K_center(p) = nucl_coord(num_k,p)
L_center(p) = nucl_coord(num_l,p)
enddo
j1b_gauss_coul_modifdebug = 0.d0
! do ii = 1, nucl_num
! expoii = j1b_gauss_pen(ii)
! j1b_gauss_coul_modifdebug += expoii * ao_two_e_integral(i, j, k, l)
! enddo
! -------------------------------------------------------------------------------------------------------------------
!
! [ 1 / r12 ] \sum_A a_A exp(-aA r1A^2)
!
! -------------------------------------------------------------------------------------------------------------------
shift_P = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
expo1 = ao_expo_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
expo2 = ao_expo_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P_new_tmp, P_center_tmp, pp_tmp, fact_p_tmp, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
do r = 1, ao_prim_num(k)
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q_new, Q_center, qq, fact_q, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
q_inv = 1.d0 / qq
cx = 0.d0
do ii = 1, nucl_num
expoii = j1b_gauss_pen(ii)
Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(pp_tmp, P_center_tmp, expoii, Centerii, factii, pp, P_center)
fact_p = fact_p_tmp * factii
p_inv = 1.d0 / pp
P_new(:,:) = 0.d0
call pol_modif_center( P_center_tmp, P_center, iorder_p, P_new_tmp, P_new)
! ----------------------------------------------------------------------------------------------------
! x term:
cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
enddo
j1b_gauss_coul_modifdebug = j1b_gauss_coul_modifdebug + coef4 * cx
enddo ! s
enddo ! r
enddo ! q
enddo ! p
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
!
! [ 1 / r12 ] \sum_A a_A exp(-aA r2A^2)
!
! -------------------------------------------------------------------------------------------------------------------
shift_P = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
expo1 = ao_expo_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
expo2 = ao_expo_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P_new, P_center, pp, fact_p, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
p_inv = 1.d0 / pp
do r = 1, ao_prim_num(k)
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q_new_tmp, Q_center_tmp, qq_tmp, fact_q_tmp, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
cx = 0.d0
do ii = 1, nucl_num
expoii = j1b_gauss_pen(ii)
Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(qq_tmp, Q_center_tmp, expoii, Centerii, factii, qq, Q_center)
fact_q = fact_q_tmp * factii
Q_inv = 1.d0 / qq
call pol_modif_center( Q_center_tmp, Q_center, iorder_q, Q_new_tmp, Q_new)
! ----------------------------------------------------------------------------------------------------
! x term:
cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
enddo
j1b_gauss_coul_modifdebug = j1b_gauss_coul_modifdebug + coef4 * cx
enddo ! s
enddo ! r
enddo ! q
enddo ! p
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
return
end function j1b_gauss_coul_modifdebug
double precision function general_primitive_integral_coul(dim, &
P_new,P_center,fact_p,p,p_inv,iorder_p, &
Q_new,Q_center,fact_q,q,q_inv,iorder_q)
implicit none
BEGIN_DOC
! Computes the integral <pq|rs> where p,q,r,s are Gaussian primitives
END_DOC
integer,intent(in) :: dim
include 'utils/constants.include.F'
double precision, intent(in) :: P_new(0:max_dim,3),P_center(3),fact_p,p,p_inv
double precision, intent(in) :: Q_new(0:max_dim,3),Q_center(3),fact_q,q,q_inv
integer, intent(in) :: iorder_p(3)
integer, intent(in) :: iorder_q(3)
double precision :: r_cut,gama_r_cut,rho,dist
double precision :: dx(0:max_dim),Ix_pol(0:max_dim),dy(0:max_dim),Iy_pol(0:max_dim),dz(0:max_dim),Iz_pol(0:max_dim)
integer :: n_Ix,n_Iy,n_Iz,nx,ny,nz
double precision :: bla
integer :: ix,iy,iz,jx,jy,jz,i
double precision :: a,b,c,d,e,f,accu,pq,const
double precision :: pq_inv, p10_1, p10_2, p01_1, p01_2,pq_inv_2
integer :: n_pt_tmp,n_pt_out, iorder
double precision :: d1(0:max_dim),d_poly(0:max_dim),rint,d1_screened(0:max_dim)
general_primitive_integral_coul = 0.d0
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: dx,Ix_pol,dy,Iy_pol,dz,Iz_pol
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: d1, d_poly
! Gaussian Product
! ----------------
pq = p_inv*0.5d0*q_inv
pq_inv = 0.5d0/(p+q)
p10_1 = q*pq ! 1/(2p)
p01_1 = p*pq ! 1/(2q)
pq_inv_2 = pq_inv+pq_inv
p10_2 = pq_inv_2 * p10_1*q !0.5d0*q/(pq + p*p)
p01_2 = pq_inv_2 * p01_1*p !0.5d0*p/(q*q + pq)
accu = 0.d0
iorder = iorder_p(1)+iorder_q(1)+iorder_p(1)+iorder_q(1)
do ix=0,iorder
Ix_pol(ix) = 0.d0
enddo
n_Ix = 0
do ix = 0, iorder_p(1)
if (abs(P_new(ix,1)) < thresh) cycle
a = P_new(ix,1)
do jx = 0, iorder_q(1)
d = a*Q_new(jx,1)
if (abs(d) < thresh) cycle
!DIR$ FORCEINLINE
call give_polynom_mult_center_x(P_center(1),Q_center(1),ix,jx,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dx,nx)
!DIR$ FORCEINLINE
call add_poly_multiply(dx,nx,d,Ix_pol,n_Ix)
enddo
enddo
if (n_Ix == -1) then
return
endif
iorder = iorder_p(2)+iorder_q(2)+iorder_p(2)+iorder_q(2)
do ix=0, iorder
Iy_pol(ix) = 0.d0
enddo
n_Iy = 0
do iy = 0, iorder_p(2)
if (abs(P_new(iy,2)) > thresh) then
b = P_new(iy,2)
do jy = 0, iorder_q(2)
e = b*Q_new(jy,2)
if (abs(e) < thresh) cycle
!DIR$ FORCEINLINE
call give_polynom_mult_center_x(P_center(2),Q_center(2),iy,jy,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dy,ny)
!DIR$ FORCEINLINE
call add_poly_multiply(dy,ny,e,Iy_pol,n_Iy)
enddo
endif
enddo
if (n_Iy == -1) then
return
endif
iorder = iorder_p(3)+iorder_q(3)+iorder_p(3)+iorder_q(3)
do ix=0,iorder
Iz_pol(ix) = 0.d0
enddo
n_Iz = 0
do iz = 0, iorder_p(3)
if (abs(P_new(iz,3)) > thresh) then
c = P_new(iz,3)
do jz = 0, iorder_q(3)
f = c*Q_new(jz,3)
if (abs(f) < thresh) cycle
!DIR$ FORCEINLINE
call give_polynom_mult_center_x(P_center(3),Q_center(3),iz,jz,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dz,nz)
!DIR$ FORCEINLINE
call add_poly_multiply(dz,nz,f,Iz_pol,n_Iz)
enddo
endif
enddo
if (n_Iz == -1) then
return
endif
rho = p*q *pq_inv_2
dist = (P_center(1) - Q_center(1))*(P_center(1) - Q_center(1)) + &
(P_center(2) - Q_center(2))*(P_center(2) - Q_center(2)) + &
(P_center(3) - Q_center(3))*(P_center(3) - Q_center(3))
const = dist*rho
n_pt_tmp = n_Ix+n_Iy
do i=0,n_pt_tmp
d_poly(i)=0.d0
enddo
!DIR$ FORCEINLINE
call multiply_poly(Ix_pol,n_Ix,Iy_pol,n_Iy,d_poly,n_pt_tmp)
if (n_pt_tmp == -1) then
return
endif
n_pt_out = n_pt_tmp+n_Iz
do i=0,n_pt_out
d1(i)=0.d0
enddo
!DIR$ FORCEINLINE
call multiply_poly(d_poly ,n_pt_tmp ,Iz_pol,n_Iz,d1,n_pt_out)
double precision :: rint_sum
accu = accu + rint_sum(n_pt_out,const,d1)
general_primitive_integral_coul = fact_p * fact_q * accu *pi_5_2*p_inv*q_inv/dsqrt(p+q)
end function general_primitive_integral_coul

102
src/ao_tc_eff_map/two_e_1bgauss_coulerf.irp.f
View File

@ -1,102 +0,0 @@
double precision function j1b_gauss_coulerf(i, j, k, l)
BEGIN_DOC
!
! integral in the AO basis:
! i(r1) j(r1) f(r12) k(r2) l(r2)
!
! with:
! f(r12) = - [ (0.5 - 0.5 erf(mu r12)) / r12 ] (r1-r2) \cdot \sum_A (-2 a_A) [ r1A exp(-aA r1A^2) - r2A exp(-aA r2A^2) ]
! = [ (1 - erf(mu r12) / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2)
! + (r2-RA)^2 exp(-aA r2A^2)
! - (r1-RA) \cdot (r2-RA) exp(-aA r1A^2)
! - (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ]
!
END_DOC
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: i, j, k, l
integer :: p, q, r, s
integer :: num_i, num_j, num_k, num_l, num_ii
integer :: I_power(3), J_power(3), K_power(3), L_power(3)
integer :: iorder_p(3), iorder_q(3)
integer :: shift_P(3), shift_Q(3)
integer :: dim1
double precision :: coef1, coef2, coef3, coef4
double precision :: expo1, expo2, expo3, expo4
double precision :: P1_new(0:max_dim,3), P1_center(3), fact_p1, pp1, p1_inv
double precision :: Q1_new(0:max_dim,3), Q1_center(3), fact_q1, qq1, q1_inv
double precision :: I_center(3), J_center(3), K_center(3), L_center(3)
double precision :: ff, gg, cx, cy, cz
double precision :: j1b_gauss_coulerf_schwartz
PROVIDE j1b_gauss_pen
dim1 = n_pt_max_integrals
if( ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then
j1b_gauss_coulerf = j1b_gauss_coulerf_schwartz(i, j, k, l)
return
endif
num_i = ao_nucl(i)
num_j = ao_nucl(j)
num_k = ao_nucl(k)
num_l = ao_nucl(l)
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
I_center(p) = nucl_coord(num_i,p)
J_center(p) = nucl_coord(num_j,p)
K_center(p) = nucl_coord(num_k,p)
L_center(p) = nucl_coord(num_l,p)
enddo
j1b_gauss_coulerf = 0.d0
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
expo1 = ao_expo_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
expo2 = ao_expo_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P1_new, P1_center, pp1, fact_p1, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
p1_inv = 1.d0 / pp1
do r = 1, ao_prim_num(k)
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q1_new, Q1_center, qq1, fact_q1, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
q1_inv = 1.d0 / qq1
call get_cxcycz( dim1, cx, cy, cz &
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p &
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q )
j1b_gauss_coulerf = j1b_gauss_coulerf + coef4 * ( cx + cy + cz )
enddo ! s
enddo ! r
enddo ! q
enddo ! p
return
end function j1b_gauss_coulerf

854
src/ao_tc_eff_map/two_e_1bgauss_erf.irp.f
View File

@ -1,854 +0,0 @@
double precision function j1b_gauss_erf(i, j, k, l)
BEGIN_DOC
!
! integral in the AO basis:
! i(r1) j(r1) f(r12) k(r2) l(r2)
!
! with:
! f(r12) = - [ -0.5 erf(mu r12) / r12 ] (r1-r2) \cdot \sum_A (-2 a_A) [ r1A exp(-aA r1A^2) - r2A exp(-aA r2A^2) ]
! = - [ erf(mu r12) / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2)
! + (r2-RA)^2 exp(-aA r2A^2)
! - (r1-RA) \cdot (r2-RA) exp(-aA r1A^2)
! - (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ]
!
END_DOC
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: i, j, k, l
integer :: p, q, r, s, ii
integer :: num_i, num_j, num_k, num_l, num_ii
integer :: I_power(3), J_power(3), K_power(3), L_power(3)
integer :: iorder_p(3), iorder_q(3)
integer :: shift_P(3), shift_Q(3)
integer :: dim1
double precision :: coef1, coef2, coef3, coef4
double precision :: expo1, expo2, expo3, expo4
double precision :: p_inv, q_inv
double precision :: P_new_tmp(0:max_dim,3), P_center_tmp(3), fact_p_tmp, pp_tmp
double precision :: Q_new_tmp(0:max_dim,3), Q_center_tmp(3), fact_q_tmp, qq_tmp
double precision :: P_new(0:max_dim,3), P_center(3), fact_p, pp
double precision :: Q_new(0:max_dim,3), Q_center(3), fact_q, qq
double precision :: I_center(3), J_center(3), K_center(3), L_center(3)
double precision :: expoii, factii, Centerii(3)
double precision :: ff, gg, cx, cy, cz
double precision :: general_primitive_integral_erf_shifted
PROVIDE mu_erf
PROVIDE j1b_gauss_pen
dim1 = n_pt_max_integrals
num_i = ao_nucl(i)
num_j = ao_nucl(j)
num_k = ao_nucl(k)
num_l = ao_nucl(l)
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
I_center(p) = nucl_coord(num_i,p)
J_center(p) = nucl_coord(num_j,p)
K_center(p) = nucl_coord(num_k,p)
L_center(p) = nucl_coord(num_l,p)
enddo
j1b_gauss_erf = 0.d0
! -------------------------------------------------------------------------------------------------------------------
!
! - [ erf(mu r12) / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2)
!
! -------------------------------------------------------------------------------------------------------------------
shift_Q(1) = 0
shift_Q(2) = 0
shift_Q(3) = 0
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
expo1 = ao_expo_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
expo2 = ao_expo_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P_new_tmp, P_center_tmp, pp_tmp, fact_p_tmp, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
do r = 1, ao_prim_num(k)
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q_new, Q_center, qq, fact_q, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
q_inv = 1.d0 / qq
cx = 0.d0
cy = 0.d0
cz = 0.d0
do ii = 1, nucl_num
expoii = j1b_gauss_pen(ii)
Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(pp_tmp, P_center_tmp, expoii, Centerii, factii, pp, P_center)
fact_p = fact_p_tmp * factii
p_inv = 1.d0 / pp
! pol centerd on P_center_tmp ==> centerd on P_center
call pol_modif_center( P_center_tmp, P_center, iorder_p, P_new_tmp, P_new)
! ----------------------------------------------------------------------------------------------------
! x term:
shift_P(2) = 0
shift_P(3) = 0
ff = P_center(1) - Centerii(1)
shift_P(1) = 2
cx = cx + expoii * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(1) = 1
cx = cx + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(1) = 0
cx = cx + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! y term:
shift_P(1) = 0
shift_P(3) = 0
ff = P_center(2) - Centerii(2)
shift_P(2) = 2
cy = cy + expoii * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(2) = 1
cy = cy + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(2) = 0
cy = cy + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! z term:
shift_P(1) = 0
shift_P(2) = 0
ff = P_center(3) - Centerii(3)
shift_P(3) = 2
cz = cz + expoii * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(3) = 1
cz = cz + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(3) = 0
cz = cz + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
enddo
j1b_gauss_erf = j1b_gauss_erf - coef4 * ( cx + cy + cz )
enddo ! s
enddo ! r
enddo ! q
enddo ! p
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
!
! - [ erf(mu r12) / r12 ] \sum_A a_A [ (r2-RA)^2 exp(-aA r2A^2)
!
! -------------------------------------------------------------------------------------------------------------------
shift_P(1) = 0
shift_P(2) = 0
shift_P(3) = 0
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
expo1 = ao_expo_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
expo2 = ao_expo_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P_new, P_center, pp, fact_p, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
p_inv = 1.d0 / pp
do r = 1, ao_prim_num(k)
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q_new_tmp, Q_center_tmp, qq_tmp, fact_q_tmp, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
cx = 0.d0
cy = 0.d0
cz = 0.d0
do ii = 1, nucl_num
expoii = j1b_gauss_pen(ii)
Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(qq_tmp, Q_center_tmp, expoii, Centerii, factii, qq, Q_center)
fact_q = fact_q_tmp * factii
q_inv = 1.d0 / qq
! pol centerd on Q_center_tmp ==> centerd on Q_center
call pol_modif_center( Q_center_tmp, Q_center, iorder_q, Q_new_tmp, Q_new)
! ----------------------------------------------------------------------------------------------------
! x term:
shift_Q(2) = 0
shift_Q(3) = 0
ff = Q_center(1) - Centerii(1)
shift_Q(1) = 2
cx = cx + expoii * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_Q(1) = 1
cx = cx + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_Q(1) = 0
cx = cx + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! y term:
shift_Q(1) = 0
shift_Q(3) = 0
ff = Q_center(2) - Centerii(2)
shift_Q(2) = 2
cy = cy + expoii * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_Q(2) = 1
cy = cy + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_Q(2) = 0
cy = cy + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! z term:
shift_Q(1) = 0
shift_Q(2) = 0
ff = Q_center(3) - Centerii(3)
shift_Q(3) = 2
cz = cz + expoii * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_Q(3) = 1
cz = cz + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_Q(3) = 0
cz = cz + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
enddo
j1b_gauss_erf = j1b_gauss_erf - coef4 * ( cx + cy + cz )
enddo ! s
enddo ! r
enddo ! q
enddo ! p
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
!
! [ erf(mu r12) / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r1A^2) ]
!
! -------------------------------------------------------------------------------------------------------------------
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
expo1 = ao_expo_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
expo2 = ao_expo_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P_new_tmp, P_center_tmp, pp_tmp, fact_p_tmp, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
do r = 1, ao_prim_num(k)
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q_new, Q_center, qq, fact_q, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
q_inv = 1.d0 / qq
cx = 0.d0
cy = 0.d0
cz = 0.d0
do ii = 1, nucl_num
expoii = j1b_gauss_pen(ii)
Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(pp_tmp, P_center_tmp, expoii, Centerii, factii, pp, P_center)
fact_p = fact_p_tmp * factii
p_inv = 1.d0 / pp
! pol centerd on P_center_tmp ==> centerd on P_center
call pol_modif_center( P_center_tmp, P_center, iorder_p, P_new_tmp, P_new)
! ----------------------------------------------------------------------------------------------------
! x term:
shift_P(2) = 0
shift_P(3) = 0
shift_Q(2) = 0
shift_Q(3) = 0
ff = P_center(1) - Centerii(1)
gg = Q_center(1) - Centerii(1)
shift_P(1) = 1
shift_Q(1) = 1
cx = cx + expoii * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(1) = 1
shift_Q(1) = 0
cx = cx + expoii * gg * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(1) = 0
shift_Q(1) = 1
cx = cx + expoii * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(1) = 0
shift_Q(1) = 0
cx = cx + expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! y term:
shift_P(1) = 0
shift_P(3) = 0
shift_Q(1) = 0
shift_Q(3) = 0
ff = P_center(2) - Centerii(2)
gg = Q_center(2) - Centerii(2)
shift_P(2) = 1
shift_Q(2) = 1
cy = cy + expoii * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(2) = 1
shift_Q(2) = 0
cy = cy + expoii * gg * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(2) = 0
shift_Q(2) = 1
cy = cy + expoii * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(2) = 0
shift_Q(2) = 0
cy = cy + expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! z term:
shift_P(1) = 0
shift_P(2) = 0
shift_Q(1) = 0
shift_Q(2) = 0
ff = P_center(3) - Centerii(3)
gg = Q_center(3) - Centerii(3)
shift_P(3) = 1
shift_Q(3) = 1
cz = cz + expoii * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(3) = 1
shift_Q(3) = 0
cz = cz + expoii * gg * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(3) = 0
shift_Q(3) = 1
cz = cz + expoii * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(3) = 0
shift_Q(3) = 0
cz = cz + expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
enddo
j1b_gauss_erf = j1b_gauss_erf + coef4 * ( cx + cy + cz )
enddo ! s
enddo ! r
enddo ! q
enddo ! p
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
!
! [ erf(mu r12) / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ]
!
! -------------------------------------------------------------------------------------------------------------------
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
expo1 = ao_expo_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
expo2 = ao_expo_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P_new, P_center, pp, fact_p, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
p_inv = 1.d0 / pp
do r = 1, ao_prim_num(k)
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q_new_tmp, Q_center_tmp, qq_tmp, fact_q_tmp, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
cx = 0.d0
cy = 0.d0
cz = 0.d0
do ii = 1, nucl_num
expoii = j1b_gauss_pen(ii)
Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(qq_tmp, Q_center_tmp, expoii, Centerii, factii, qq, Q_center)
fact_q = fact_q_tmp * factii
q_inv = 1.d0 / qq
! pol centerd on Q_center_tmp ==> centerd on Q_center
call pol_modif_center( Q_center_tmp, Q_center, iorder_q, Q_new_tmp, Q_new)
! ----------------------------------------------------------------------------------------------------
! x term:
shift_P(2) = 0
shift_P(3) = 0
shift_Q(2) = 0
shift_Q(3) = 0
ff = P_center(1) - Centerii(1)
gg = Q_center(1) - Centerii(1)
shift_P(1) = 1
shift_Q(1) = 1
cx = cx + expoii * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(1) = 1
shift_Q(1) = 0
cx = cx + expoii * gg * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(1) = 0
shift_Q(1) = 1
cx = cx + expoii * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(1) = 0
shift_Q(1) = 0
cx = cx + expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! y term:
shift_P(1) = 0
shift_P(3) = 0
shift_Q(1) = 0
shift_Q(3) = 0
ff = P_center(2) - Centerii(2)
gg = Q_center(2) - Centerii(2)
shift_P(2) = 1
shift_Q(2) = 1
cy = cy + expoii * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(2) = 1
shift_Q(2) = 0
cy = cy + expoii * gg * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(2) = 0
shift_Q(2) = 1
cy = cy + expoii * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(2) = 0
shift_Q(2) = 0
cy = cy + expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! z term:
shift_P(1) = 0
shift_P(2) = 0
shift_Q(1) = 0
shift_Q(2) = 0
ff = P_center(3) - Centerii(3)
gg = Q_center(3) - Centerii(3)
shift_P(3) = 1
shift_Q(3) = 1
cz = cz + expoii * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(3) = 1
shift_Q(3) = 0
cz = cz + expoii * gg * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(3) = 0
shift_Q(3) = 1
cz = cz + expoii * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(3) = 0
shift_Q(3) = 0
cz = cz + expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
enddo
j1b_gauss_erf = j1b_gauss_erf + coef4 * ( cx + cy + cz )
enddo ! s
enddo ! r
enddo ! q
enddo ! p
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
return
end function j1b_gauss_erf
!______________________________________________________________________________________________________________________
!______________________________________________________________________________________________________________________
double precision function general_primitive_integral_erf_shifted( dim &
, P_new, P_center, fact_p, p, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, q, q_inv, iorder_q, shift_Q )
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: dim
integer, intent(in) :: iorder_p(3), shift_P(3)
integer, intent(in) :: iorder_q(3), shift_Q(3)
double precision, intent(in) :: P_new(0:max_dim,3), P_center(3), fact_p, p, p_inv
double precision, intent(in) :: Q_new(0:max_dim,3), Q_center(3), fact_q, q, q_inv
integer :: n_Ix, n_Iy, n_Iz, nx, ny, nz
integer :: ix, iy, iz, jx, jy, jz, i
integer :: n_pt_tmp, n_pt_out, iorder
integer :: ii, jj
double precision :: rho, dist
double precision :: dx(0:max_dim), Ix_pol(0:max_dim)
double precision :: dy(0:max_dim), Iy_pol(0:max_dim)
double precision :: dz(0:max_dim), Iz_pol(0:max_dim)
double precision :: a, b, c, d, e, f, accu, pq, const
double precision :: pq_inv, p10_1, p10_2, p01_1, p01_2, pq_inv_2
double precision :: d1(0:max_dim), d_poly(0:max_dim)
double precision :: p_plus_q
double precision :: rint_sum
general_primitive_integral_erf_shifted = 0.d0
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: dx, Ix_pol, dy, Iy_pol, dz, Iz_pol
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: d1, d_poly
! Gaussian Product
! ----------------
p_plus_q = (p+q) * ( (p*q)/(p+q) + mu_erf*mu_erf ) / (mu_erf*mu_erf)
pq = p_inv * 0.5d0 * q_inv
pq_inv = 0.5d0 / p_plus_q
p10_1 = q * pq ! 1/(2p)
p01_1 = p * pq ! 1/(2q)
pq_inv_2 = pq_inv + pq_inv
p10_2 = pq_inv_2 * p10_1 * q ! 0.5d0 * q / (pq + p*p)
p01_2 = pq_inv_2 * p01_1 * p ! 0.5d0 * p / (q*q + pq)
accu = 0.d0
iorder = iorder_p(1) + iorder_q(1) + iorder_p(1) + iorder_q(1)
iorder = iorder + shift_P(1) + shift_Q(1)
iorder = iorder + shift_P(1) + shift_Q(1)
!DIR$ VECTOR ALIGNED
do ix = 0, iorder
Ix_pol(ix) = 0.d0
enddo
n_Ix = 0
do ix = 0, iorder_p(1)
ii = ix + shift_P(1)
a = P_new(ix,1)
if(abs(a) < thresh) cycle
do jx = 0, iorder_q(1)
jj = jx + shift_Q(1)
d = a * Q_new(jx,1)
if(abs(d) < thresh) cycle
!DEC$ FORCEINLINE
call give_polynom_mult_center_x( P_center(1), Q_center(1), ii, jj &
, p, q, iorder, pq_inv, pq_inv_2, p10_1, p01_1, p10_2, p01_2, dx, nx )
!DEC$ FORCEINLINE
call add_poly_multiply(dx, nx, d, Ix_pol, n_Ix)
enddo
enddo
if(n_Ix == -1) then
return
endif
iorder = iorder_p(2) + iorder_q(2) + iorder_p(2) + iorder_q(2)
iorder = iorder + shift_P(2) + shift_Q(2)
iorder = iorder + shift_P(2) + shift_Q(2)
!DIR$ VECTOR ALIGNED
do ix = 0, iorder
Iy_pol(ix) = 0.d0
enddo
n_Iy = 0
do iy = 0, iorder_p(2)
if(abs(P_new(iy,2)) > thresh) then
ii = iy + shift_P(2)
b = P_new(iy,2)
do jy = 0, iorder_q(2)
jj = jy + shift_Q(2)
e = b * Q_new(jy,2)
if(abs(e) < thresh) cycle
!DEC$ FORCEINLINE
call give_polynom_mult_center_x( P_center(2), Q_center(2), ii, jj &
, p, q, iorder, pq_inv, pq_inv_2, p10_1, p01_1, p10_2, p01_2, dy, ny )
!DEC$ FORCEINLINE
call add_poly_multiply(dy, ny, e, Iy_pol, n_Iy)
enddo
endif
enddo
if(n_Iy == -1) then
return
endif
iorder = iorder_p(3) + iorder_q(3) + iorder_p(3) + iorder_q(3)
iorder = iorder + shift_P(3) + shift_Q(3)
iorder = iorder + shift_P(3) + shift_Q(3)
do ix = 0, iorder
Iz_pol(ix) = 0.d0
enddo
n_Iz = 0
do iz = 0, iorder_p(3)
if( abs(P_new(iz,3)) > thresh ) then
ii = iz + shift_P(3)
c = P_new(iz,3)
do jz = 0, iorder_q(3)
jj = jz + shift_Q(3)
f = c * Q_new(jz,3)
if(abs(f) < thresh) cycle
!DEC$ FORCEINLINE
call give_polynom_mult_center_x( P_center(3), Q_center(3), ii, jj &
, p, q, iorder, pq_inv, pq_inv_2, p10_1, p01_1, p10_2, p01_2, dz, nz )
!DEC$ FORCEINLINE
call add_poly_multiply(dz, nz, f, Iz_pol, n_Iz)
enddo
endif
enddo
if(n_Iz == -1) then
return
endif
rho = p * q * pq_inv_2
dist = (P_center(1) - Q_center(1)) * (P_center(1) - Q_center(1)) &
+ (P_center(2) - Q_center(2)) * (P_center(2) - Q_center(2)) &
+ (P_center(3) - Q_center(3)) * (P_center(3) - Q_center(3))
const = dist*rho
n_pt_tmp = n_Ix + n_Iy
do i = 0, n_pt_tmp
d_poly(i) = 0.d0
enddo
!DEC$ FORCEINLINE
call multiply_poly(Ix_pol, n_Ix, Iy_pol, n_Iy, d_poly, n_pt_tmp)
if(n_pt_tmp == -1) then
return
endif
n_pt_out = n_pt_tmp + n_Iz
do i = 0, n_pt_out
d1(i) = 0.d0
enddo
!DEC$ FORCEINLINE
call multiply_poly(d_poly, n_pt_tmp, Iz_pol, n_Iz, d1, n_pt_out)
accu = accu + rint_sum(n_pt_out, const, d1)
general_primitive_integral_erf_shifted = fact_p * fact_q * accu * pi_5_2 * p_inv * q_inv / dsqrt(p_plus_q)
return
end function general_primitive_integral_erf_shifted
!______________________________________________________________________________________________________________________
!______________________________________________________________________________________________________________________

433
src/ao_tc_eff_map/two_e_1bgauss_erf_acc.irp.f
View File

@ -1,433 +0,0 @@
double precision function j1b_gauss_erf_acc(i, j, k, l)
BEGIN_DOC
!
! integral in the AO basis:
! i(r1) j(r1) f(r12) k(r2) l(r2)
!
! with:
! f(r12) = - [ -0.5 erf(mu r12) / r12 ] (r1-r2) \cdot \sum_A (-2 a_A) [ r1A exp(-aA r1A^2) - r2A exp(-aA r2A^2) ]
! = - [ erf(mu r12) / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2)
! + (r2-RA)^2 exp(-aA r2A^2)
! - (r1-RA) \cdot (r2-RA) exp(-aA r1A^2)
! - (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ]
!
END_DOC
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: i, j, k, l
integer :: p, q, r, s, ii
integer :: num_i, num_j, num_k, num_l, num_ii
integer :: I_power(3), J_power(3), K_power(3), L_power(3)
integer :: iorder_p(3), iorder_q(3)
integer :: shift_P(3), shift_Q(3)
integer :: dim1
double precision :: coef1, coef2, coef3, coef4
double precision :: expo1, expo2, expo3, expo4
double precision :: p1_inv, q1_inv, p2_inv, q2_inv
double precision :: P1_new(0:max_dim,3), P1_center(3), fact_p1, pp1
double precision :: P2_new(0:max_dim,3), P2_center(3), fact_p2, pp2
double precision :: Q1_new(0:max_dim,3), Q1_center(3), fact_q1, qq1
double precision :: Q2_new(0:max_dim,3), Q2_center(3), fact_q2, qq2
double precision :: I_center(3), J_center(3), K_center(3), L_center(3)
double precision :: expoii, factii, Centerii(3)
double precision :: ff, gg, cx, cy, cz
double precision :: general_primitive_integral_erf_shifted
!double precision :: j1b_gauss_erf_schwartz_accel
PROVIDE j1b_gauss_pen
dim1 = n_pt_max_integrals
! TODO
!if( ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then
! j1b_gauss_erf_schwartz_accel = j1b_gauss_erf_schwartz_accel(i, j, k, l)
! return
!endif
num_i = ao_nucl(i)
num_j = ao_nucl(j)
num_k = ao_nucl(k)
num_l = ao_nucl(l)
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
I_center(p) = nucl_coord(num_i,p)
J_center(p) = nucl_coord(num_j,p)
K_center(p) = nucl_coord(num_k,p)
L_center(p) = nucl_coord(num_l,p)
enddo
j1b_gauss_erf_acc = 0.d0
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
expo1 = ao_expo_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
expo2 = ao_expo_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P1_new, P1_center, pp1, fact_p1, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
p1_inv = 1.d0 / pp1
do r = 1, ao_prim_num(k)
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q1_new, Q1_center, qq1, fact_q1, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
q1_inv = 1.d0 / qq1
cx = 0.d0
cy = 0.d0
cz = 0.d0
do ii = 1, nucl_num
expoii = j1b_gauss_pen(ii)
Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(pp1, P1_center, expoii, Centerii, factii, pp2, P2_center)
fact_p2 = fact_p1 * factii
p2_inv = 1.d0 / pp2
call pol_modif_center( P1_center, P2_center, iorder_p, P1_new, P2_new)
call gaussian_product(qq1, Q1_center, expoii, Centerii, factii, qq2, Q2_center)
fact_q2 = fact_q1 * factii
q2_inv = 1.d0 / qq2
call pol_modif_center( Q1_center, Q2_center, iorder_q, Q1_new, Q2_new)
! ----------------------------------------------------------------------------------------------------
! [ erf(mu r12) / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2)
! ----------------------------------------------------------------------------------------------------
shift_Q = (/ 0, 0, 0 /)
! x term:
ff = P2_center(1) - Centerii(1)
shift_P = (/ 2, 0, 0 /)
cx = cx + expoii * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 1, 0, 0 /)
cx = cx + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 0 /)
cx = cx + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! y term:
ff = P2_center(2) - Centerii(2)
shift_P = (/ 0, 2, 0 /)
cy = cy + expoii * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 0, 1, 0 /)
cy = cy + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 0 /)
cy = cy + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! z term:
ff = P2_center(3) - Centerii(3)
shift_P = (/ 0, 0, 2 /)
cz = cz + expoii * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 1 /)
cz = cz + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 0 /)
cz = cz + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! [ erf(mu r12) / r12 ] \sum_A a_A [ (r2-RA)^2 exp(-aA r2A^2)
! ----------------------------------------------------------------------------------------------------
shift_P = (/ 0, 0, 0 /)
! x term:
ff = Q2_center(1) - Centerii(1)
shift_Q = (/ 2, 0, 0 /)
cx = cx + expoii * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 1, 0, 0 /)
cx = cx + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 0, 0 /)
cx = cx + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! y term:
ff = Q2_center(2) - Centerii(2)
shift_Q = (/ 0, 2, 0 /)
cy = cy + expoii * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 1, 0 /)
cy = cy + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 0, 0 /)
cy = cy + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! z term:
ff = Q2_center(3) - Centerii(3)
shift_Q = (/ 0, 0, 2 /)
cz = cz + expoii * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 0, 1 /)
cz = cz + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 0, 0 /)
cz = cz + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! - [ erf(mu r12) / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r1A^2) ]
! ----------------------------------------------------------------------------------------------------
! x term:
ff = P2_center(1) - Centerii(1)
gg = Q1_center(1) - Centerii(1)
shift_p = (/ 1, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx - expoii * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 1, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx - expoii * gg * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx - expoii * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx - expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! y term:
ff = P2_center(2) - Centerii(2)
gg = Q1_center(2) - Centerii(2)
shift_p = (/ 0, 1, 0 /)
shift_Q = (/ 0, 1, 0 /)
cy = cy - expoii * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 1, 0 /)
shift_Q = (/ 0, 0, 0 /)
cy = cy - expoii * gg * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 1, 0 /)
cy = cy - expoii * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cy = cy - expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! z term:
ff = P2_center(3) - Centerii(3)
gg = Q1_center(3) - Centerii(3)
shift_p = (/ 0, 0, 1 /)
shift_Q = (/ 0, 0, 1 /)
cz = cz - expoii * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 1 /)
shift_Q = (/ 0, 0, 0 /)
cz = cz - expoii * gg * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 1 /)
cz = cz - expoii * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cz = cz - expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! - [ erf(mu r12) / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ]
! ----------------------------------------------------------------------------------------------------
! x term:
ff = P1_center(1) - Centerii(1)
gg = Q2_center(1) - Centerii(1)
shift_p = (/ 1, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx - expoii * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 1, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx - expoii * gg * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx - expoii * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx - expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! y term:
ff = P1_center(2) - Centerii(2)
gg = Q2_center(2) - Centerii(2)
shift_p = (/ 0, 1, 0 /)
shift_Q = (/ 0, 1, 0 /)
cy = cy - expoii * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 1, 0 /)
shift_Q = (/ 0, 0, 0 /)
cy = cy - expoii * gg * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 1, 0 /)
cy = cy - expoii * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cy = cy - expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! z term:
ff = P1_center(3) - Centerii(3)
gg = Q2_center(3) - Centerii(3)
shift_p = (/ 0, 0, 1 /)
shift_Q = (/ 0, 0, 1 /)
cz = cz - expoii * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 1 /)
shift_Q = (/ 0, 0, 0 /)
cz = cz - expoii * gg * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 1 /)
cz = cz - expoii * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cz = cz - expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
enddo
j1b_gauss_erf_acc = j1b_gauss_erf_acc - coef4 * ( cx + cy + cz )
enddo ! s
enddo ! r
enddo ! q
enddo ! p
return
end function j1b_gauss_erf_acc

148
src/ao_tc_eff_map/two_e_1bgauss_coulerf_schwartz.irp.f → src/ao_tc_eff_map/two_e_1bgauss_j1.irp.f
View File

@ -1,4 +1,106 @@
double precision function j1b_gauss_coulerf_schwartz(i, j, k, l)
! ---
double precision function j1b_gauss_2e_j1(i, j, k, l)
BEGIN_DOC
!
! integral in the AO basis:
! i(r1) j(r1) f(r12) k(r2) l(r2)
!
! with:
! f(r12) = - [ (0.5 - 0.5 erf(mu r12)) / r12 ] (r1-r2) \cdot \sum_A (-2 a_A) [ r1A exp(-aA r1A^2) - r2A exp(-aA r2A^2) ]
! = [ (1 - erf(mu r12) / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2)
! + (r2-RA)^2 exp(-aA r2A^2)
! - (r1-RA) \cdot (r2-RA) exp(-aA r1A^2)
! - (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ]
!
END_DOC
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: i, j, k, l
integer :: p, q, r, s
integer :: num_i, num_j, num_k, num_l, num_ii
integer :: I_power(3), J_power(3), K_power(3), L_power(3)
integer :: iorder_p(3), iorder_q(3)
integer :: shift_P(3), shift_Q(3)
integer :: dim1
double precision :: coef1, coef2, coef3, coef4
double precision :: expo1, expo2, expo3, expo4
double precision :: P1_new(0:max_dim,3), P1_center(3), fact_p1, pp1, p1_inv
double precision :: Q1_new(0:max_dim,3), Q1_center(3), fact_q1, qq1, q1_inv
double precision :: I_center(3), J_center(3), K_center(3), L_center(3)
double precision :: ff, gg, cx, cy, cz
double precision :: j1b_gauss_2e_j1_schwartz
if( ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then
j1b_gauss_2e_j1 = j1b_gauss_2e_j1_schwartz(i, j, k, l)
return
endif
num_i = ao_nucl(i)
num_j = ao_nucl(j)
num_k = ao_nucl(k)
num_l = ao_nucl(l)
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
I_center(p) = nucl_coord(num_i,p)
J_center(p) = nucl_coord(num_j,p)
K_center(p) = nucl_coord(num_k,p)
L_center(p) = nucl_coord(num_l,p)
enddo
j1b_gauss_2e_j1 = 0.d0
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
expo1 = ao_expo_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
expo2 = ao_expo_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P1_new, P1_center, pp1, fact_p1, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
p1_inv = 1.d0 / pp1
do r = 1, ao_prim_num(k)
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q1_new, Q1_center, qq1, fact_q1, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
q1_inv = 1.d0 / qq1
call get_cxcycz_j1( dim1, cx, cy, cz &
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p &
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q )
j1b_gauss_2e_j1 = j1b_gauss_2e_j1 + coef4 * ( cx + cy + cz )
enddo ! s
enddo ! r
enddo ! q
enddo ! p
return
end function j1b_gauss_2e_j1
! ---
double precision function j1b_gauss_2e_j1_schwartz(i, j, k, l)
BEGIN_DOC
!
@ -35,7 +137,7 @@ double precision function j1b_gauss_coulerf_schwartz(i, j, k, l)
double precision :: schwartz_ij, thr
double precision, allocatable :: schwartz_kl(:,:)
PROVIDE j1b_gauss_pen
PROVIDE j1b_pen
dim1 = n_pt_max_integrals
thr = ao_integrals_threshold * ao_integrals_threshold
@ -73,9 +175,9 @@ double precision function j1b_gauss_coulerf_schwartz(i, j, k, l)
, K_power, L_power, K_center, L_center, dim1 )
q1_inv = 1.d0 / qq1
call get_cxcycz( dim1, cx, cy, cz &
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q &
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q )
call get_cxcycz_j1( dim1, cx, cy, cz &
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q &
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q )
schwartz_kl(s,r) = coef4 * dabs( cx + cy + cz )
schwartz_kl(0,r) = max( schwartz_kl(0,r) , schwartz_kl(s,r) )
@ -85,7 +187,7 @@ double precision function j1b_gauss_coulerf_schwartz(i, j, k, l)
enddo
j1b_gauss_coulerf_schwartz = 0.d0
j1b_gauss_2e_j1_schwartz = 0.d0
do p = 1, ao_prim_num(i)
expo1 = ao_expo_ordered_transp(p, i)
@ -99,9 +201,9 @@ double precision function j1b_gauss_coulerf_schwartz(i, j, k, l)
, I_power, J_power, I_center, J_center, dim1 )
p1_inv = 1.d0 / pp1
call get_cxcycz( dim1, cx, cy, cz &
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p &
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p )
call get_cxcycz_j1( dim1, cx, cy, cz &
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p &
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p )
schwartz_ij = coef2 * coef2 * dabs( cx + cy + cz )
if( schwartz_kl(0,0) * schwartz_ij < thr ) cycle
@ -120,11 +222,11 @@ double precision function j1b_gauss_coulerf_schwartz(i, j, k, l)
, K_power, L_power, K_center, L_center, dim1 )
q1_inv = 1.d0 / qq1
call get_cxcycz( dim1, cx, cy, cz &
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p &
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q )
call get_cxcycz_j1( dim1, cx, cy, cz &
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p &
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q )
j1b_gauss_coulerf_schwartz = j1b_gauss_coulerf_schwartz + coef4 * ( cx + cy + cz )
j1b_gauss_2e_j1_schwartz = j1b_gauss_2e_j1_schwartz + coef4 * ( cx + cy + cz )
enddo ! s
enddo ! r
enddo ! q
@ -133,15 +235,13 @@ double precision function j1b_gauss_coulerf_schwartz(i, j, k, l)
deallocate( schwartz_kl )
return
end function j1b_gauss_coulerf_schwartz
end function j1b_gauss_2e_j1_schwartz
! ---
subroutine get_cxcycz( dim1, cx, cy, cz &
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p &
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q )
subroutine get_cxcycz_j1( dim1, cx, cy, cz &
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p &
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q )
include 'utils/constants.include.F'
@ -163,12 +263,14 @@ subroutine get_cxcycz( dim1, cx, cy, cz &
double precision :: general_primitive_integral_erf_shifted
double precision :: general_primitive_integral_coul_shifted
PROVIDE j1b_pen
cx = 0.d0
cy = 0.d0
cz = 0.d0
do ii = 1, nucl_num
expoii = j1b_gauss_pen(ii)
expoii = j1b_pen(ii)
Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(pp1, P1_center, expoii, Centerii, factii, pp2, P2_center)
@ -620,5 +722,7 @@ subroutine get_cxcycz( dim1, cx, cy, cz &
enddo
return
end subroutine get_cxcycz
end subroutine get_cxcycz_j1
! ---

729
src/ao_tc_eff_map/two_e_1bgauss_j2.irp.f Normal file
View File

@ -0,0 +1,729 @@
! ---
double precision function j1b_gauss_2e_j2(i, j, k, l)
BEGIN_DOC
!
! integral in the AO basis:
! i(r1) j(r1) f(r12) k(r2) l(r2)
!
! with:
! f(r12) = - [ (0.5 - 0.5 erf(mu r12)) / r12 ] (r1-r2) \cdot \sum_A (-2 a_A c_A) [ r1A exp(-aA r1A^2) - r2A exp(-aA r2A^2) ]
! = [ (1 - erf(mu r12) / r12 ] \sum_A a_A c_A [ (r1-RA)^2 exp(-aA r1A^2)
! + (r2-RA)^2 exp(-aA r2A^2)
! - (r1-RA) \cdot (r2-RA) exp(-aA r1A^2)
! - (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ]
!
END_DOC
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: i, j, k, l
integer :: p, q, r, s
integer :: num_i, num_j, num_k, num_l, num_ii
integer :: I_power(3), J_power(3), K_power(3), L_power(3)
integer :: iorder_p(3), iorder_q(3)
integer :: shift_P(3), shift_Q(3)
integer :: dim1
double precision :: coef1, coef2, coef3, coef4
double precision :: expo1, expo2, expo3, expo4
double precision :: P1_new(0:max_dim,3), P1_center(3), fact_p1, pp1, p1_inv
double precision :: Q1_new(0:max_dim,3), Q1_center(3), fact_q1, qq1, q1_inv
double precision :: I_center(3), J_center(3), K_center(3), L_center(3)
double precision :: ff, gg, cx, cy, cz
double precision :: j1b_gauss_2e_j2_schwartz
dim1 = n_pt_max_integrals
if( ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then
j1b_gauss_2e_j2 = j1b_gauss_2e_j2_schwartz(i, j, k, l)
return
endif
num_i = ao_nucl(i)
num_j = ao_nucl(j)
num_k = ao_nucl(k)
num_l = ao_nucl(l)
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
I_center(p) = nucl_coord(num_i,p)
J_center(p) = nucl_coord(num_j,p)
K_center(p) = nucl_coord(num_k,p)
L_center(p) = nucl_coord(num_l,p)
enddo
j1b_gauss_2e_j2 = 0.d0
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
expo1 = ao_expo_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
expo2 = ao_expo_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P1_new, P1_center, pp1, fact_p1, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
p1_inv = 1.d0 / pp1
do r = 1, ao_prim_num(k)
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q1_new, Q1_center, qq1, fact_q1, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
q1_inv = 1.d0 / qq1
call get_cxcycz_j2( dim1, cx, cy, cz &
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p &
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q )
j1b_gauss_2e_j2 = j1b_gauss_2e_j2 + coef4 * ( cx + cy + cz )
enddo ! s
enddo ! r
enddo ! q
enddo ! p
return
end function j1b_gauss_2e_j2
! ---
double precision function j1b_gauss_2e_j2_schwartz(i, j, k, l)
BEGIN_DOC
!
! integral in the AO basis:
! i(r1) j(r1) f(r12) k(r2) l(r2)
!
! with:
! f(r12) = - [ (0.5 - 0.5 erf(mu r12)) / r12 ] (r1-r2) \cdot \sum_A (-2 a_A c_A) [ r1A exp(-aA r1A^2) - r2A exp(-aA r2A^2) ]
! = [ (1 - erf(mu r12) / r12 ] \sum_A a_A c_A [ (r1-RA)^2 exp(-aA r1A^2)
! + (r2-RA)^2 exp(-aA r2A^2)
! - (r1-RA) \cdot (r2-RA) exp(-aA r1A^2)
! - (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ]
!
END_DOC
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: i, j, k, l
integer :: p, q, r, s
integer :: num_i, num_j, num_k, num_l, num_ii
integer :: I_power(3), J_power(3), K_power(3), L_power(3)
integer :: iorder_p(3), iorder_q(3)
integer :: dim1
double precision :: coef1, coef2, coef3, coef4
double precision :: expo1, expo2, expo3, expo4
double precision :: P1_new(0:max_dim,3), P1_center(3), fact_p1, pp1, p1_inv
double precision :: Q1_new(0:max_dim,3), Q1_center(3), fact_q1, qq1, q1_inv
double precision :: I_center(3), J_center(3), K_center(3), L_center(3)
double precision :: cx, cy, cz
double precision :: schwartz_ij, thr
double precision, allocatable :: schwartz_kl(:,:)
dim1 = n_pt_max_integrals
thr = ao_integrals_threshold * ao_integrals_threshold
num_i = ao_nucl(i)
num_j = ao_nucl(j)
num_k = ao_nucl(k)
num_l = ao_nucl(l)
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
I_center(p) = nucl_coord(num_i,p)
J_center(p) = nucl_coord(num_j,p)
K_center(p) = nucl_coord(num_k,p)
L_center(p) = nucl_coord(num_l,p)
enddo
allocate( schwartz_kl(0:ao_prim_num(l) , 0:ao_prim_num(k)) )
schwartz_kl(0,0) = 0.d0
do r = 1, ao_prim_num(k)
expo3 = ao_expo_ordered_transp(r,k)
coef3 = ao_coef_normalized_ordered_transp(r,k) * ao_coef_normalized_ordered_transp(r,k)
schwartz_kl(0,r) = 0.d0
do s = 1, ao_prim_num(l)
expo4 = ao_expo_ordered_transp(s,l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s,l) * ao_coef_normalized_ordered_transp(s,l)
call give_explicit_poly_and_gaussian( Q1_new, Q1_center, qq1, fact_q1, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
q1_inv = 1.d0 / qq1
call get_cxcycz_j2( dim1, cx, cy, cz &
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q &
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q )
schwartz_kl(s,r) = coef4 * dabs( cx + cy + cz )
schwartz_kl(0,r) = max( schwartz_kl(0,r) , schwartz_kl(s,r) )
enddo
schwartz_kl(0,0) = max( schwartz_kl(0,r) , schwartz_kl(0,0) )
enddo
j1b_gauss_2e_j2_schwartz = 0.d0
do p = 1, ao_prim_num(i)
expo1 = ao_expo_ordered_transp(p, i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
expo2 = ao_expo_ordered_transp(q, j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P1_new, P1_center, pp1, fact_p1, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
p1_inv = 1.d0 / pp1
call get_cxcycz_j2( dim1, cx, cy, cz &
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p &
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p )
schwartz_ij = coef2 * coef2 * dabs( cx + cy + cz )
if( schwartz_kl(0,0) * schwartz_ij < thr ) cycle
do r = 1, ao_prim_num(k)
if( schwartz_kl(0,r) * schwartz_ij < thr ) cycle
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
if( schwartz_kl(s,r) * schwartz_ij < thr ) cycle
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q1_new, Q1_center, qq1, fact_q1, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
q1_inv = 1.d0 / qq1
call get_cxcycz_j2( dim1, cx, cy, cz &
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p &
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q )
j1b_gauss_2e_j2_schwartz = j1b_gauss_2e_j2_schwartz + coef4 * ( cx + cy + cz )
enddo ! s
enddo ! r
enddo ! q
enddo ! p
deallocate( schwartz_kl )
return
end function j1b_gauss_2e_j2_schwartz
! ---
subroutine get_cxcycz_j2( dim1, cx, cy, cz &
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p &
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q )
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: dim1
integer, intent(in) :: iorder_p(3), iorder_q(3)
double precision, intent(in) :: P1_new(0:max_dim,3), P1_center(3), fact_p1, pp1, p1_inv
double precision, intent(in) :: Q1_new(0:max_dim,3), Q1_center(3), fact_q1, qq1, q1_inv
double precision, intent(out) :: cx, cy, cz
integer :: ii
integer :: shift_P(3), shift_Q(3)
double precision :: coefii, expoii, factii, Centerii(3)
double precision :: P2_new(0:max_dim,3), P2_center(3), fact_p2, pp2, p2_inv
double precision :: Q2_new(0:max_dim,3), Q2_center(3), fact_q2, qq2, q2_inv
double precision :: ff, gg
double precision :: general_primitive_integral_erf_shifted
double precision :: general_primitive_integral_coul_shifted
PROVIDE j1b_pen j1b_coeff
cx = 0.d0
cy = 0.d0
cz = 0.d0
do ii = 1, nucl_num
expoii = j1b_pen (ii)
coefii = j1b_coeff(ii)
Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(pp1, P1_center, expoii, Centerii, factii, pp2, P2_center)
fact_p2 = fact_p1 * factii
p2_inv = 1.d0 / pp2
call pol_modif_center( P1_center, P2_center, iorder_p, P1_new, P2_new )
call gaussian_product(qq1, Q1_center, expoii, Centerii, factii, qq2, Q2_center)
fact_q2 = fact_q1 * factii
q2_inv = 1.d0 / qq2
call pol_modif_center( Q1_center, Q2_center, iorder_q, Q1_new, Q2_new )
! ----------------------------------------------------------------------------------------------------
! [ (1-erf(mu r12)) / r12 ] \sum_A a_A c_A [ (r1-RA)^2 exp(-aA r1A^2)
! ----------------------------------------------------------------------------------------------------
shift_Q = (/ 0, 0, 0 /)
! x term:
ff = P2_center(1) - Centerii(1)
shift_P = (/ 2, 0, 0 /)
cx = cx + expoii * coefii * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cx = cx - expoii * coefii * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 1, 0, 0 /)
cx = cx + expoii * coefii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cx = cx - expoii * coefii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 0 /)
cx = cx + expoii * coefii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cx = cx - expoii * coefii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! y term:
ff = P2_center(2) - Centerii(2)
shift_P = (/ 0, 2, 0 /)
cy = cy + expoii * coefii * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cy = cy - expoii * coefii * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 0, 1, 0 /)
cy = cy + expoii * coefii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cy = cy - expoii * coefii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 0 /)
cy = cy + expoii * coefii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cy = cy - expoii * coefii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! z term:
ff = P2_center(3) - Centerii(3)
shift_P = (/ 0, 0, 2 /)
cz = cz + expoii * coefii * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cz = cz - expoii * coefii * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 1 /)
cz = cz + expoii * coefii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cz = cz - expoii * coefii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 0 /)
cz = cz + expoii * coefii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cz = cz - expoii * coefii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! [ (1-erf(mu r12)) / r12 ] \sum_A a_A c_A [ (r2-RA)^2 exp(-aA r2A^2)
! ----------------------------------------------------------------------------------------------------
shift_P = (/ 0, 0, 0 /)
! x term:
ff = Q2_center(1) - Centerii(1)
shift_Q = (/ 2, 0, 0 /)
cx = cx + expoii * coefii * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cx = cx - expoii * coefii * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 1, 0, 0 /)
cx = cx + expoii * coefii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cx = cx - expoii * coefii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 0, 0 /)
cx = cx + expoii * coefii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cx = cx - expoii * coefii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! y term:
ff = Q2_center(2) - Centerii(2)
shift_Q = (/ 0, 2, 0 /)
cy = cy + expoii * coefii * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cy = cy - expoii * coefii * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 1, 0 /)
cy = cy + expoii * coefii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cy = cy - expoii * coefii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 0, 0 /)
cy = cy + expoii * coefii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cy = cy - expoii * coefii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! z term:
ff = Q2_center(3) - Centerii(3)
shift_Q = (/ 0, 0, 2 /)
cz = cz + expoii * coefii * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cz = cz - expoii * coefii * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 0, 1 /)
cz = cz + expoii * coefii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cz = cz - expoii * coefii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 0, 0 /)
cz = cz + expoii * coefii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cz = cz - expoii * coefii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! - [ (1-erf(mu r12)) / r12 ] \sum_A a_A c_A [ (r1-RA) \cdot (r2-RA) exp(-aA r1A^2) ]
! ----------------------------------------------------------------------------------------------------
! x term:
ff = P2_center(1) - Centerii(1)
gg = Q1_center(1) - Centerii(1)
shift_p = (/ 1, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx - expoii * coefii * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cx = cx + expoii * coefii * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 1, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx - expoii * coefii * gg * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cx = cx + expoii * coefii * gg * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx - expoii * coefii * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cx = cx + expoii * coefii * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx - expoii * coefii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cx = cx + expoii * coefii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! y term:
ff = P2_center(2) - Centerii(2)
gg = Q1_center(2) - Centerii(2)
shift_p = (/ 0, 1, 0 /)
shift_Q = (/ 0, 1, 0 /)
cy = cy - expoii * coefii * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cy = cy + expoii * coefii * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 1, 0 /)
shift_Q = (/ 0, 0, 0 /)
cy = cy - expoii * coefii * gg * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cy = cy + expoii * coefii * gg * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 1, 0 /)
cy = cy - expoii * coefii * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cy = cy + expoii * coefii * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cy = cy - expoii * coefii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cy = cy + expoii * coefii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! z term:
ff = P2_center(3) - Centerii(3)
gg = Q1_center(3) - Centerii(3)
shift_p = (/ 0, 0, 1 /)
shift_Q = (/ 0, 0, 1 /)
cz = cz - expoii * coefii * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cz = cz + expoii * coefii * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 1 /)
shift_Q = (/ 0, 0, 0 /)
cz = cz - expoii * coefii * gg * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cz = cz + expoii * coefii * gg * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 1 /)
cz = cz - expoii * coefii * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cz = cz + expoii * coefii * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cz = cz - expoii * coefii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cz = cz + expoii * coefii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! - [ (1-erf(mu r12)) / r12 ] \sum_A a_A c_A [ (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ]
! ----------------------------------------------------------------------------------------------------
! x term:
ff = P1_center(1) - Centerii(1)
gg = Q2_center(1) - Centerii(1)
shift_p = (/ 1, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx - expoii * coefii * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cx = cx + expoii * coefii * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 1, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx - expoii * coefii * gg * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cx = cx + expoii * coefii * gg * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx - expoii * coefii * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cx = cx + expoii * coefii * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx - expoii * coefii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cx = cx + expoii * coefii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! y term:
ff = P1_center(2) - Centerii(2)
gg = Q2_center(2) - Centerii(2)
shift_p = (/ 0, 1, 0 /)
shift_Q = (/ 0, 1, 0 /)
cy = cy - expoii * coefii * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cy = cy + expoii * coefii * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 1, 0 /)
shift_Q = (/ 0, 0, 0 /)
cy = cy - expoii * coefii * gg * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cy = cy + expoii * coefii * gg * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 1, 0 /)
cy = cy - expoii * coefii * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cy = cy + expoii * coefii * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cy = cy - expoii * coefii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cy = cy + expoii * coefii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! z term:
ff = P1_center(3) - Centerii(3)
gg = Q2_center(3) - Centerii(3)
shift_p = (/ 0, 0, 1 /)
shift_Q = (/ 0, 0, 1 /)
cz = cz - expoii * coefii * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cz = cz + expoii * coefii * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 1 /)
shift_Q = (/ 0, 0, 0 /)
cz = cz - expoii * coefii * gg * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cz = cz + expoii * coefii * gg * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 1 /)
cz = cz - expoii * coefii * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cz = cz + expoii * coefii * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cz = cz - expoii * coefii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cz = cz + expoii * coefii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
enddo
return
end subroutine get_cxcycz_j2
! ---

1
src/ao_tc_eff_map/two_e_ints_gauss.irp.f
View File

@ -254,6 +254,7 @@ double precision function general_primitive_integral_gauss(dim, &
rho_old = (p*q)/(p+q)
prefactor = pi_3 * inv_pq_3_2 * fact_p * fact_q
do i = 1, n_gauss_eff_pot ! browse the gaussians with different expo/coef
!do i = 1, n_gauss_eff_pot-1
aa = expo_gauss_eff_pot(i)
c_a = coef_gauss_eff_pot(i)
t_a = dsqrt( aa /(rho_old + aa) )

364
src/ao_tc_eff_map/useful_sub.irp.f Normal file
View File

@ -0,0 +1,364 @@
! ---
!______________________________________________________________________________________________________________________
!______________________________________________________________________________________________________________________
double precision function general_primitive_integral_coul_shifted( dim &
, P_new, P_center, fact_p, p, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, q, q_inv, iorder_q, shift_Q )
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: dim
integer, intent(in) :: iorder_p(3), shift_P(3)
integer, intent(in) :: iorder_q(3), shift_Q(3)
double precision, intent(in) :: P_new(0:max_dim,3), P_center(3), fact_p, p, p_inv
double precision, intent(in) :: Q_new(0:max_dim,3), Q_center(3), fact_q, q, q_inv
integer :: n_Ix, n_Iy, n_Iz, nx, ny, nz
integer :: ix, iy, iz, jx, jy, jz, i
integer :: n_pt_tmp, n_pt_out, iorder
integer :: ii, jj
double precision :: rho, dist
double precision :: dx(0:max_dim), Ix_pol(0:max_dim)
double precision :: dy(0:max_dim), Iy_pol(0:max_dim)
double precision :: dz(0:max_dim), Iz_pol(0:max_dim)
double precision :: a, b, c, d, e, f, accu, pq, const
double precision :: pq_inv, p10_1, p10_2, p01_1, p01_2, pq_inv_2
double precision :: d1(0:max_dim), d_poly(0:max_dim)
double precision :: p_plus_q
double precision :: rint_sum
general_primitive_integral_coul_shifted = 0.d0
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: dx, Ix_pol, dy, Iy_pol, dz, Iz_pol
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: d1, d_poly
! Gaussian Product
! ----------------
p_plus_q = (p+q)
pq = p_inv * 0.5d0 * q_inv
pq_inv = 0.5d0 / p_plus_q
p10_1 = q * pq ! 1/(2p)
p01_1 = p * pq ! 1/(2q)
pq_inv_2 = pq_inv + pq_inv
p10_2 = pq_inv_2 * p10_1 * q ! 0.5d0 * q / (pq + p*p)
p01_2 = pq_inv_2 * p01_1 * p ! 0.5d0 * p / (q*q + pq)
accu = 0.d0
iorder = iorder_p(1) + iorder_q(1) + iorder_p(1) + iorder_q(1)
iorder = iorder + shift_P(1) + shift_Q(1)
iorder = iorder + shift_P(1) + shift_Q(1)
!DIR$ VECTOR ALIGNED
do ix = 0, iorder
Ix_pol(ix) = 0.d0
enddo
n_Ix = 0
do ix = 0, iorder_p(1)
ii = ix + shift_P(1)
a = P_new(ix,1)
if(abs(a) < thresh) cycle
do jx = 0, iorder_q(1)
jj = jx + shift_Q(1)
d = a * Q_new(jx,1)
if(abs(d) < thresh) cycle
!DEC$ FORCEINLINE
call give_polynom_mult_center_x( P_center(1), Q_center(1), ii, jj &
, p, q, iorder, pq_inv, pq_inv_2, p10_1, p01_1, p10_2, p01_2, dx, nx )
!DEC$ FORCEINLINE
call add_poly_multiply(dx, nx, d, Ix_pol, n_Ix)
enddo
enddo
if(n_Ix == -1) then
return
endif
iorder = iorder_p(2) + iorder_q(2) + iorder_p(2) + iorder_q(2)
iorder = iorder + shift_P(2) + shift_Q(2)
iorder = iorder + shift_P(2) + shift_Q(2)
!DIR$ VECTOR ALIGNED
do ix = 0, iorder
Iy_pol(ix) = 0.d0
enddo
n_Iy = 0
do iy = 0, iorder_p(2)
if(abs(P_new(iy,2)) > thresh) then
ii = iy + shift_P(2)
b = P_new(iy,2)
do jy = 0, iorder_q(2)
jj = jy + shift_Q(2)
e = b * Q_new(jy,2)
if(abs(e) < thresh) cycle
!DEC$ FORCEINLINE
call give_polynom_mult_center_x( P_center(2), Q_center(2), ii, jj &
, p, q, iorder, pq_inv, pq_inv_2, p10_1, p01_1, p10_2, p01_2, dy, ny )
!DEC$ FORCEINLINE
call add_poly_multiply(dy, ny, e, Iy_pol, n_Iy)
enddo
endif
enddo
if(n_Iy == -1) then
return
endif
iorder = iorder_p(3) + iorder_q(3) + iorder_p(3) + iorder_q(3)
iorder = iorder + shift_P(3) + shift_Q(3)
iorder = iorder + shift_P(3) + shift_Q(3)
do ix = 0, iorder
Iz_pol(ix) = 0.d0
enddo
n_Iz = 0
do iz = 0, iorder_p(3)
if( abs(P_new(iz,3)) > thresh ) then
ii = iz + shift_P(3)
c = P_new(iz,3)
do jz = 0, iorder_q(3)
jj = jz + shift_Q(3)
f = c * Q_new(jz,3)
if(abs(f) < thresh) cycle
!DEC$ FORCEINLINE
call give_polynom_mult_center_x( P_center(3), Q_center(3), ii, jj &
, p, q, iorder, pq_inv, pq_inv_2, p10_1, p01_1, p10_2, p01_2, dz, nz )
!DEC$ FORCEINLINE
call add_poly_multiply(dz, nz, f, Iz_pol, n_Iz)
enddo
endif
enddo
if(n_Iz == -1) then
return
endif
rho = p * q * pq_inv_2
dist = (P_center(1) - Q_center(1)) * (P_center(1) - Q_center(1)) &
+ (P_center(2) - Q_center(2)) * (P_center(2) - Q_center(2)) &
+ (P_center(3) - Q_center(3)) * (P_center(3) - Q_center(3))
const = dist*rho
n_pt_tmp = n_Ix + n_Iy
do i = 0, n_pt_tmp
d_poly(i) = 0.d0
enddo
!DEC$ FORCEINLINE
call multiply_poly(Ix_pol, n_Ix, Iy_pol, n_Iy, d_poly, n_pt_tmp)
if(n_pt_tmp == -1) then
return
endif
n_pt_out = n_pt_tmp + n_Iz
do i = 0, n_pt_out
d1(i) = 0.d0
enddo
!DEC$ FORCEINLINE
call multiply_poly(d_poly, n_pt_tmp, Iz_pol, n_Iz, d1, n_pt_out)
accu = accu + rint_sum(n_pt_out, const, d1)
general_primitive_integral_coul_shifted = fact_p * fact_q * accu * pi_5_2 * p_inv * q_inv / dsqrt(p_plus_q)
return
end function general_primitive_integral_coul_shifted
!______________________________________________________________________________________________________________________
!______________________________________________________________________________________________________________________
!______________________________________________________________________________________________________________________
!______________________________________________________________________________________________________________________
double precision function general_primitive_integral_erf_shifted( dim &
, P_new, P_center, fact_p, p, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, q, q_inv, iorder_q, shift_Q )
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: dim
integer, intent(in) :: iorder_p(3), shift_P(3)
integer, intent(in) :: iorder_q(3), shift_Q(3)
double precision, intent(in) :: P_new(0:max_dim,3), P_center(3), fact_p, p, p_inv
double precision, intent(in) :: Q_new(0:max_dim,3), Q_center(3), fact_q, q, q_inv
integer :: n_Ix, n_Iy, n_Iz, nx, ny, nz
integer :: ix, iy, iz, jx, jy, jz, i
integer :: n_pt_tmp, n_pt_out, iorder
integer :: ii, jj
double precision :: rho, dist
double precision :: dx(0:max_dim), Ix_pol(0:max_dim)
double precision :: dy(0:max_dim), Iy_pol(0:max_dim)
double precision :: dz(0:max_dim), Iz_pol(0:max_dim)
double precision :: a, b, c, d, e, f, accu, pq, const
double precision :: pq_inv, p10_1, p10_2, p01_1, p01_2, pq_inv_2
double precision :: d1(0:max_dim), d_poly(0:max_dim)
double precision :: p_plus_q
double precision :: rint_sum
general_primitive_integral_erf_shifted = 0.d0
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: dx, Ix_pol, dy, Iy_pol, dz, Iz_pol
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: d1, d_poly
! Gaussian Product
! ----------------
p_plus_q = (p+q) * ( (p*q)/(p+q) + mu_erf*mu_erf ) / (mu_erf*mu_erf)
pq = p_inv * 0.5d0 * q_inv
pq_inv = 0.5d0 / p_plus_q
p10_1 = q * pq ! 1/(2p)
p01_1 = p * pq ! 1/(2q)
pq_inv_2 = pq_inv + pq_inv
p10_2 = pq_inv_2 * p10_1 * q ! 0.5d0 * q / (pq + p*p)
p01_2 = pq_inv_2 * p01_1 * p ! 0.5d0 * p / (q*q + pq)
accu = 0.d0
iorder = iorder_p(1) + iorder_q(1) + iorder_p(1) + iorder_q(1)
iorder = iorder + shift_P(1) + shift_Q(1)
iorder = iorder + shift_P(1) + shift_Q(1)
!DIR$ VECTOR ALIGNED
do ix = 0, iorder
Ix_pol(ix) = 0.d0
enddo
n_Ix = 0
do ix = 0, iorder_p(1)
ii = ix + shift_P(1)
a = P_new(ix,1)
if(abs(a) < thresh) cycle
do jx = 0, iorder_q(1)
jj = jx + shift_Q(1)
d = a * Q_new(jx,1)
if(abs(d) < thresh) cycle
!DEC$ FORCEINLINE
call give_polynom_mult_center_x( P_center(1), Q_center(1), ii, jj &
, p, q, iorder, pq_inv, pq_inv_2, p10_1, p01_1, p10_2, p01_2, dx, nx )
!DEC$ FORCEINLINE
call add_poly_multiply(dx, nx, d, Ix_pol, n_Ix)
enddo
enddo
if(n_Ix == -1) then
return
endif
iorder = iorder_p(2) + iorder_q(2) + iorder_p(2) + iorder_q(2)
iorder = iorder + shift_P(2) + shift_Q(2)
iorder = iorder + shift_P(2) + shift_Q(2)
!DIR$ VECTOR ALIGNED
do ix = 0, iorder
Iy_pol(ix) = 0.d0
enddo
n_Iy = 0
do iy = 0, iorder_p(2)
if(abs(P_new(iy,2)) > thresh) then
ii = iy + shift_P(2)
b = P_new(iy,2)
do jy = 0, iorder_q(2)
jj = jy + shift_Q(2)
e = b * Q_new(jy,2)
if(abs(e) < thresh) cycle
!DEC$ FORCEINLINE
call give_polynom_mult_center_x( P_center(2), Q_center(2), ii, jj &
, p, q, iorder, pq_inv, pq_inv_2, p10_1, p01_1, p10_2, p01_2, dy, ny )
!DEC$ FORCEINLINE
call add_poly_multiply(dy, ny, e, Iy_pol, n_Iy)
enddo
endif
enddo
if(n_Iy == -1) then
return
endif
iorder = iorder_p(3) + iorder_q(3) + iorder_p(3) + iorder_q(3)
iorder = iorder + shift_P(3) + shift_Q(3)
iorder = iorder + shift_P(3) + shift_Q(3)
do ix = 0, iorder
Iz_pol(ix) = 0.d0
enddo
n_Iz = 0
do iz = 0, iorder_p(3)
if( abs(P_new(iz,3)) > thresh ) then
ii = iz + shift_P(3)
c = P_new(iz,3)
do jz = 0, iorder_q(3)
jj = jz + shift_Q(3)
f = c * Q_new(jz,3)
if(abs(f) < thresh) cycle
!DEC$ FORCEINLINE
call give_polynom_mult_center_x( P_center(3), Q_center(3), ii, jj &
, p, q, iorder, pq_inv, pq_inv_2, p10_1, p01_1, p10_2, p01_2, dz, nz )
!DEC$ FORCEINLINE
call add_poly_multiply(dz, nz, f, Iz_pol, n_Iz)
enddo
endif
enddo
if(n_Iz == -1) then
return
endif
rho = p * q * pq_inv_2
dist = (P_center(1) - Q_center(1)) * (P_center(1) - Q_center(1)) &
+ (P_center(2) - Q_center(2)) * (P_center(2) - Q_center(2)) &
+ (P_center(3) - Q_center(3)) * (P_center(3) - Q_center(3))
const = dist*rho
n_pt_tmp = n_Ix + n_Iy
do i = 0, n_pt_tmp
d_poly(i) = 0.d0
enddo
!DEC$ FORCEINLINE
call multiply_poly(Ix_pol, n_Ix, Iy_pol, n_Iy, d_poly, n_pt_tmp)
if(n_pt_tmp == -1) then
return
endif
n_pt_out = n_pt_tmp + n_Iz
do i = 0, n_pt_out
d1(i) = 0.d0
enddo
!DEC$ FORCEINLINE
call multiply_poly(d_poly, n_pt_tmp, Iz_pol, n_Iz, d1, n_pt_out)
accu = accu + rint_sum(n_pt_out, const, d1)
general_primitive_integral_erf_shifted = fact_p * fact_q * accu * pi_5_2 * p_inv * q_inv / dsqrt(p_plus_q)
return
end function general_primitive_integral_erf_shifted
!______________________________________________________________________________________________________________________
!______________________________________________________________________________________________________________________

3
src/ao_two_e_ints/map_integrals.irp.f
View File

@ -321,8 +321,9 @@ BEGIN_PROVIDER [ double precision, ao_integrals_cache, (0:64*64*64*64) ]
!$OMP END PARALLEL DO
END_PROVIDER
! ---
double precision function get_ao_two_e_integral(i,j,k,l,map) result(result)
double precision function get_ao_two_e_integral(i, j, k, l, map) result(result)
use map_module
implicit none
BEGIN_DOC

4
src/ao_two_e_ints/two_e_integrals.irp.f
View File

@ -1,7 +1,7 @@
! ---
double precision function ao_two_e_integral(i,j,k,l)
double precision function ao_two_e_integral(i, j, k, l)
BEGIN_DOC
! integral of the AO basis <ik|jl> or (ij|kl)
@ -29,7 +29,7 @@ double precision function ao_two_e_integral(i,j,k,l)
if(use_cosgtos) then
!print *, ' use_cosgtos for ao_two_e_integral ?', use_cosgtos
ao_two_e_integral = ao_two_e_integral_cosgtos(i,j,k,l)
ao_two_e_integral = ao_two_e_integral_cosgtos(i, j, k, l)
else

153
src/bi_ort_ints/biorthog_mo_for_h.irp.f Normal file
View File

@ -0,0 +1,153 @@
! ---
double precision function bi_ortho_mo_coul_ints(l, k, j, i)
BEGIN_DOC
!
! < mo^L_k mo^L_l | 1/r12 | mo^R_i mo^R_j >
!
END_DOC
implicit none
integer, intent(in) :: i, j, k, l
integer :: m, n, p, q
bi_ortho_mo_coul_ints = 0.d0
do m = 1, ao_num
do p = 1, ao_num
do n = 1, ao_num
do q = 1, ao_num
! p1h1p2h2 l1 l2 r1 r2
bi_ortho_mo_coul_ints += ao_two_e_coul(n,q,m,p) * mo_l_coef(m,l) * mo_l_coef(n,k) * mo_r_coef(p,j) * mo_r_coef(q,i)
enddo
enddo
enddo
enddo
end function bi_ortho_mo_coul_ints
! ---
! TODO :: transform into DEGEMM
BEGIN_PROVIDER [double precision, mo_bi_ortho_coul_e_chemist, (mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC
!
! mo_bi_ortho_coul_e_chemist(k,i,l,j) = < k l | 1/r12 | i j > where i,j are right MOs and k,l are left MOs
!
END_DOC
implicit none
integer :: i, j, k, l, m, n, p, q
double precision, allocatable :: mo_tmp_1(:,:,:,:), mo_tmp_2(:,:,:,:)
allocate(mo_tmp_1(mo_num,ao_num,ao_num,ao_num))
mo_tmp_1 = 0.d0
do m = 1, ao_num
do p = 1, ao_num
do n = 1, ao_num
do q = 1, ao_num
do k = 1, mo_num
! (k n|p m) = sum_q c_qk * (q n|p m)
mo_tmp_1(k,n,p,m) += mo_l_coef_transp(k,q) * ao_two_e_coul(q,n,p,m)
enddo
enddo
enddo
enddo
enddo
allocate(mo_tmp_2(mo_num,mo_num,ao_num,ao_num))
mo_tmp_2 = 0.d0
do m = 1, ao_num
do p = 1, ao_num
do n = 1, ao_num
do i = 1, mo_num
do k = 1, mo_num
! (k i|p m) = sum_n c_ni * (k n|p m)
mo_tmp_2(k,i,p,m) += mo_r_coef_transp(i,n) * mo_tmp_1(k,n,p,m)
enddo
enddo
enddo
enddo
enddo
deallocate(mo_tmp_1)
allocate(mo_tmp_1(mo_num,mo_num,mo_num,ao_num))
mo_tmp_1 = 0.d0
do m = 1, ao_num
do p = 1, ao_num
do l = 1, mo_num
do i = 1, mo_num
do k = 1, mo_num
mo_tmp_1(k,i,l,m) += mo_l_coef_transp(l,p) * mo_tmp_2(k,i,p,m)
enddo
enddo
enddo
enddo
enddo
deallocate(mo_tmp_2)
mo_bi_ortho_coul_e_chemist = 0.d0
do m = 1, ao_num
do j = 1, mo_num
do l = 1, mo_num
do i = 1, mo_num
do k = 1, mo_num
mo_bi_ortho_coul_e_chemist(k,i,l,j) += mo_r_coef_transp(j,m) * mo_tmp_1(k,i,l,m)
enddo
enddo
enddo
enddo
enddo
deallocate(mo_tmp_1)
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, mo_bi_ortho_coul_e, (mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC
!
! mo_bi_ortho_coul_e(k,l,i,j) = < k l | 1/r12 | i j > where i,j are right MOs and k,l are left MOs
!
END_DOC
implicit none
integer :: i, j, k, l
do j = 1, mo_num
do i = 1, mo_num
do l = 1, mo_num
do k = 1, mo_num
! < k l | V12 | i j > (k i|l j)
mo_bi_ortho_coul_e(k,l,i,j) = mo_bi_ortho_coul_e_chemist(k,i,l,j)
enddo
enddo
enddo
enddo
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, mo_bi_ortho_one_e, (mo_num, mo_num)]
BEGIN_DOC
!
! mo_bi_ortho_one_e(k,i) = < MO^L_k | h_c | MO^R_i >
!
END_DOC
implicit none
call ao_to_mo_bi_ortho(ao_one_e_integrals, ao_num, mo_bi_ortho_one_e , mo_num)
END_PROVIDER
! ---

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

@ -8,9 +8,9 @@ BEGIN_PROVIDER [double precision, ao_one_e_integrals_tc_tot, (ao_num,ao_num)]
ao_one_e_integrals_tc_tot = ao_one_e_integrals
provide j1b_gauss
provide j1b_type
if(j1b_gauss .eq. 1) then
if( (j1b_type .eq. 1) .or. (j1b_type .eq. 2) ) then
do i = 1, ao_num
do j = 1, ao_num
@ -24,12 +24,17 @@ BEGIN_PROVIDER [double precision, ao_one_e_integrals_tc_tot, (ao_num,ao_num)]
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_one_e, (mo_num, mo_num)]
implicit none
BEGIN_DOC
! mo_bi_ortho_tc_one_e(k,i) = <MO^L_k | h_c | MO^R_i>
END_DOC
integer :: i,k,p,q
BEGIN_DOC
!
! mo_bi_ortho_tc_one_e(k,i) = <MO^L_k | h_c | MO^R_i>
!
END_DOC
implicit none
call ao_to_mo_bi_ortho(ao_one_e_integrals_tc_tot, ao_num, mo_bi_ortho_tc_one_e, mo_num)

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

@ -1,81 +1,198 @@
BEGIN_PROVIDER [ double precision, mo_v_ki_bi_ortho_erf_rk_cst_mu, ( mo_num, mo_num,n_points_final_grid)]
implicit none
BEGIN_DOC
! mo_v_ki_bi_ortho_erf_rk_cst_mu(k,i,ip) = int dr chi_k(r) phi_i(r) (erf(mu |r - R_ip|) - 1 )/(2|r - R_ip|) on the BI-ORTHO MO basis
!
! where phi_k(r) is a LEFT MOs and phi_i(r) is a RIGHT MO
!
! R_ip = the "ip"-th point of the DFT Grid
END_DOC
integer :: ipoint
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
! ---
! TODO :: optimization : transform into a DGEMM
BEGIN_PROVIDER [ double precision, mo_v_ki_bi_ortho_erf_rk_cst_mu, (mo_num, mo_num, n_points_final_grid)]
BEGIN_DOC
!
! mo_v_ki_bi_ortho_erf_rk_cst_mu(k,i,ip) = int dr chi_k(r) phi_i(r) (erf(mu |r - R_ip|) - 1 )/(2|r - R_ip|) on the BI-ORTHO MO basis
!
! where phi_k(r) is a LEFT MOs and phi_i(r) is a RIGHT MO
!
! R_ip = the "ip"-th point of the DFT Grid
!
END_DOC
implicit none
integer :: ipoint
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint) &
!$OMP SHARED (n_points_final_grid,v_ij_erf_rk_cst_mu,mo_v_ki_bi_ortho_erf_rk_cst_mu)
!$OMP DO SCHEDULE (dynamic)
! TODO :: optimization : transform into a DGEMM
do ipoint = 1, n_points_final_grid
call ao_to_mo_bi_ortho(v_ij_erf_rk_cst_mu(1,1,ipoint),size(v_ij_erf_rk_cst_mu,1),mo_v_ki_bi_ortho_erf_rk_cst_mu(1,1,ipoint),size(mo_v_ki_bi_ortho_erf_rk_cst_mu,1))
enddo
do ipoint = 1, n_points_final_grid
call ao_to_mo_bi_ortho( v_ij_erf_rk_cst_mu (1,1,ipoint), size(v_ij_erf_rk_cst_mu, 1) &
, mo_v_ki_bi_ortho_erf_rk_cst_mu(1,1,ipoint), size(mo_v_ki_bi_ortho_erf_rk_cst_mu, 1) )
enddo
!$OMP END DO
!$OMP END PARALLEL
mo_v_ki_bi_ortho_erf_rk_cst_mu = mo_v_ki_bi_ortho_erf_rk_cst_mu * 0.5d0
END_PROVIDER
BEGIN_PROVIDER [ double precision, mo_v_ki_bi_ortho_erf_rk_cst_mu_transp, ( n_points_final_grid,mo_num, mo_num)]
implicit none
BEGIN_DOC
! int dr phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/(2|r - R|) on the BI-ORTHO MO basis
END_DOC
integer :: ipoint,i,j
do i = 1, mo_num
do j = 1, mo_num
do ipoint = 1, n_points_final_grid
mo_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,j,i) = mo_v_ki_bi_ortho_erf_rk_cst_mu(j,i,ipoint)
enddo
enddo
enddo
! FREE mo_v_ki_bi_ortho_erf_rk_cst_mu
END_PROVIDER
BEGIN_PROVIDER [ double precision, mo_x_v_ki_bi_ortho_erf_rk_cst_mu, ( mo_num, mo_num,3,n_points_final_grid)]
implicit none
BEGIN_DOC
! mo_x_v_ki_bi_ortho_erf_rk_cst_mu(k,i,m,ip) = int dr x(m) * chi_k(r) phi_i(r) (erf(mu |r - R_ip|) - 1)/2|r - R_ip| on the BI-ORTHO MO basis
!
! where chi_k(r)/phi_i(r) are left/right MOs, m=1 => x(m) = x, m=2 => x(m) = y, m=3 => x(m) = z,
!
! R_ip = the "ip"-th point of the DFT Grid
END_DOC
integer :: ipoint,m
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint,m) &
!$OMP SHARED (n_points_final_grid,x_v_ij_erf_rk_cst_mu_transp,mo_x_v_ki_bi_ortho_erf_rk_cst_mu)
!$OMP DO SCHEDULE (dynamic)
! TODO :: optimization : transform into a DGEMM
do ipoint = 1, n_points_final_grid
do m = 1, 3
call ao_to_mo_bi_ortho(x_v_ij_erf_rk_cst_mu_transp(1,1,m,ipoint),size(x_v_ij_erf_rk_cst_mu_transp,1),mo_x_v_ki_bi_ortho_erf_rk_cst_mu(1,1,m,ipoint),size(mo_x_v_ki_bi_ortho_erf_rk_cst_mu,1))
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
mo_x_v_ki_bi_ortho_erf_rk_cst_mu = 0.5d0 * mo_x_v_ki_bi_ortho_erf_rk_cst_mu
mo_v_ki_bi_ortho_erf_rk_cst_mu = mo_v_ki_bi_ortho_erf_rk_cst_mu * 0.5d0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp, (n_points_final_grid, 3, mo_num, mo_num)]
BEGIN_PROVIDER [ double precision, mo_v_ki_bi_ortho_erf_rk_cst_mu_transp, (n_points_final_grid, mo_num, mo_num)]
BEGIN_DOC
!
! int dr phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/(2|r - R|) on the BI-ORTHO MO basis
!
END_DOC
implicit none
integer :: i, j, m, ipoint
integer :: ipoint, i, j
do i = 1, mo_num
do j = 1, mo_num
do m = 1, 3
do ipoint = 1, n_points_final_grid
mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,m,j,i) = mo_x_v_ki_bi_ortho_erf_rk_cst_mu(j,i,m,ipoint)
enddo
do ipoint = 1, n_points_final_grid
mo_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,j,i) = mo_v_ki_bi_ortho_erf_rk_cst_mu(j,i,ipoint)
enddo
enddo
enddo
! FREE mo_v_ki_bi_ortho_erf_rk_cst_mu
END_PROVIDER
! ---
! TODO :: optimization : transform into a DGEMM
BEGIN_PROVIDER [ double precision, mo_x_v_ki_bi_ortho_erf_rk_cst_mu, (mo_num, mo_num, 3, n_points_final_grid)]
BEGIN_DOC
!
! mo_x_v_ki_bi_ortho_erf_rk_cst_mu(k,i,m,ip) = int dr x(m) * chi_k(r) phi_i(r) (erf(mu |r - R_ip|) - 1)/2|r - R_ip| on the BI-ORTHO MO basis
!
! where chi_k(r)/phi_i(r) are left/right MOs, m=1 => x(m) = x, m=2 => x(m) = y, m=3 => x(m) = z,
!
! R_ip = the "ip"-th point of the DFT Grid
!
END_DOC
implicit none
integer :: ipoint
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint) &
!$OMP SHARED (n_points_final_grid,x_v_ij_erf_rk_cst_mu_transp,mo_x_v_ki_bi_ortho_erf_rk_cst_mu)
!$OMP DO SCHEDULE (dynamic)
do ipoint = 1, n_points_final_grid
call ao_to_mo_bi_ortho( x_v_ij_erf_rk_cst_mu_transp (1,1,1,ipoint), size(x_v_ij_erf_rk_cst_mu_transp, 1) &
, mo_x_v_ki_bi_ortho_erf_rk_cst_mu(1,1,1,ipoint), size(mo_x_v_ki_bi_ortho_erf_rk_cst_mu, 1) )
call ao_to_mo_bi_ortho( x_v_ij_erf_rk_cst_mu_transp (1,1,2,ipoint), size(x_v_ij_erf_rk_cst_mu_transp, 1) &
, mo_x_v_ki_bi_ortho_erf_rk_cst_mu(1,1,2,ipoint), size(mo_x_v_ki_bi_ortho_erf_rk_cst_mu, 1) )
call ao_to_mo_bi_ortho( x_v_ij_erf_rk_cst_mu_transp (1,1,3,ipoint), size(x_v_ij_erf_rk_cst_mu_transp, 1) &
, mo_x_v_ki_bi_ortho_erf_rk_cst_mu(1,1,3,ipoint), size(mo_x_v_ki_bi_ortho_erf_rk_cst_mu, 1) )
enddo
!$OMP END DO
!$OMP END PARALLEL
mo_x_v_ki_bi_ortho_erf_rk_cst_mu = 0.5d0 * mo_x_v_ki_bi_ortho_erf_rk_cst_mu
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_transp, (ao_num, ao_num, 3, n_points_final_grid)]
implicit none
integer :: i, j, ipoint
double precision :: wall0, wall1
call wall_time(wall0)
do ipoint = 1, n_points_final_grid
do i = 1, ao_num
do j = 1, ao_num
int2_grad1_u12_ao_transp(j,i,1,ipoint) = int2_grad1_u12_ao(1,j,i,ipoint)
int2_grad1_u12_ao_transp(j,i,2,ipoint) = int2_grad1_u12_ao(2,j,i,ipoint)
int2_grad1_u12_ao_transp(j,i,3,ipoint) = int2_grad1_u12_ao(3,j,i,ipoint)
enddo
enddo
enddo
call wall_time(wall1)
print *, ' wall time for int2_grad1_u12_ao_transp ', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_transp, (mo_num, mo_num, 3, n_points_final_grid)]
implicit none
integer :: ipoint
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint) &
!$OMP SHARED (n_points_final_grid,int2_grad1_u12_ao_transp,int2_grad1_u12_bimo_transp)
!$OMP DO SCHEDULE (dynamic)
do ipoint = 1, n_points_final_grid
call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp (1,1,1,ipoint), size(int2_grad1_u12_ao_transp , 1) &
, int2_grad1_u12_bimo_transp(1,1,1,ipoint), size(int2_grad1_u12_bimo_transp, 1) )
call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp (1,1,2,ipoint), size(int2_grad1_u12_ao_transp , 1) &
, int2_grad1_u12_bimo_transp(1,1,2,ipoint), size(int2_grad1_u12_bimo_transp, 1) )
call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp (1,1,3,ipoint), size(int2_grad1_u12_ao_transp , 1) &
, int2_grad1_u12_bimo_transp(1,1,3,ipoint), size(int2_grad1_u12_bimo_transp, 1) )
enddo
!$OMP END DO
!$OMP END PARALLEL
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo, (3, mo_num, mo_num, n_points_final_grid)]
BEGIN_DOC
!
! int2_grad1_u12_bimo(:,k,i,ipoint) = \int dr2 [-1 * \grad_r1 J(r1,r2)] \chi_k(r2) \phi_i(r2)
!
END_DOC
implicit none
integer :: ipoint
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint) &
!$OMP SHARED (n_points_final_grid,int2_grad1_u12_ao,int2_grad1_u12_bimo)
!$OMP DO SCHEDULE (dynamic)
do ipoint = 1, n_points_final_grid
call ao_to_mo_bi_ortho( int2_grad1_u12_ao (1,1,1,ipoint), size(int2_grad1_u12_ao , 2) &
, int2_grad1_u12_bimo(1,1,1,ipoint), size(int2_grad1_u12_bimo, 2) )
call ao_to_mo_bi_ortho( int2_grad1_u12_ao (2,1,1,ipoint), size(int2_grad1_u12_ao , 2) &
, int2_grad1_u12_bimo(2,1,1,ipoint), size(int2_grad1_u12_bimo, 2) )
call ao_to_mo_bi_ortho( int2_grad1_u12_ao (3,1,1,ipoint), size(int2_grad1_u12_ao , 2) &
, int2_grad1_u12_bimo(3,1,1,ipoint), size(int2_grad1_u12_bimo, 2) )
enddo
!$OMP END DO
!$OMP END PARALLEL
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp, (n_points_final_grid, 3, mo_num, mo_num)]
implicit none
integer :: i, j, ipoint
do i = 1, mo_num
do j = 1, mo_num
do ipoint = 1, n_points_final_grid
mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,1,j,i) = mo_x_v_ki_bi_ortho_erf_rk_cst_mu(j,i,1,ipoint)
mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,2,j,i) = mo_x_v_ki_bi_ortho_erf_rk_cst_mu(j,i,2,ipoint)
mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,3,j,i) = mo_x_v_ki_bi_ortho_erf_rk_cst_mu(j,i,3,ipoint)
enddo
enddo
enddo
@ -83,14 +200,15 @@ END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, x_W_ki_bi_ortho_erf_rk, (n_points_final_grid, 3, mo_num, mo_num)]
BEGIN_DOC
! x_W_ki_bi_ortho_erf_rk(ip,m,k,i) = \int dr chi_k(r) (1 - erf(mu |r-R_ip|)) (x(m)-X(m)_ip) phi_i(r) ON THE BI-ORTHO MO BASIS
!
! where chi_k(r)/phi_i(r) are left/right MOs, m=1 => X(m) = x, m=2 => X(m) = y, m=3 => X(m) = z,
!
! R_ip = the "ip"-th point of the DFT Grid
!
! x_W_ki_bi_ortho_erf_rk(ip,m,k,i) = \int dr chi_k(r) \frac{(1 - erf(mu |r-R_ip|))}{2|r-R_ip|} (x(m)-R_ip(m)) phi_i(r) ON THE BI-ORTHO MO BASIS
!
! where chi_k(r)/phi_i(r) are left/right MOs, m=1 => X(m) = x, m=2 => X(m) = y, m=3 => X(m) = z,
!
! R_ip = the "ip"-th point of the DFT Grid
END_DOC
implicit none
@ -100,7 +218,7 @@ BEGIN_PROVIDER [ double precision, x_W_ki_bi_ortho_erf_rk, (n_points_final_grid,
double precision :: xyz
double precision :: wall0, wall1
print*,'providing x_W_ki_bi_ortho_erf_rk ...'
print*, ' providing x_W_ki_bi_ortho_erf_rk ...'
call wall_time(wall0)
!$OMP PARALLEL &
@ -126,7 +244,7 @@ BEGIN_PROVIDER [ double precision, x_W_ki_bi_ortho_erf_rk, (n_points_final_grid,
! FREE mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp
call wall_time(wall1)
print*,'time to provide x_W_ki_bi_ortho_erf_rk = ',wall1 - wall0
print *, ' time to provide x_W_ki_bi_ortho_erf_rk = ', wall1 - wall0
END_PROVIDER

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

@ -1,304 +1,366 @@
! ---
BEGIN_PROVIDER [ double precision, three_e_3_idx_direct_bi_ort, (mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the direct terms
!
! three_e_3_idx_direct_bi_ort(m,j,i) = <mji|-L|mji>
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
END_DOC
integer :: i,j,m
double precision :: integral, wall1, wall0
character*(128) :: name_file
three_e_3_idx_direct_bi_ort = 0.d0
print*,'Providing the three_e_3_idx_direct_bi_ort ...'
call wall_time(wall0)
name_file = 'six_index_tensor'
provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
BEGIN_DOC
!
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the direct terms
!
! three_e_3_idx_direct_bi_ort(m,j,i) = <mji|-L|mji>
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
!
END_DOC
implicit none
integer :: i, j, m
double precision :: integral, wall1, wall0
three_e_3_idx_direct_bi_ort = 0.d0
print *, ' Providing the three_e_3_idx_direct_bi_ort ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,m,integral) &
!$OMP SHARED (mo_num,three_e_3_idx_direct_bi_ort)
!$OMP DO SCHEDULE (dynamic)
do i = 1, mo_num
do j = 1, mo_num
do m = j, mo_num
call give_integrals_3_body_bi_ort(m,j,i,m,j,i,integral)
three_e_3_idx_direct_bi_ort(m,j,i) = -1.d0 * integral
do j = 1, mo_num
do m = j, mo_num
call give_integrals_3_body_bi_ort(m, j, i, m, j, i, integral)
three_e_3_idx_direct_bi_ort(m,j,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print*,'wall time for three_e_3_idx_direct_bi_ort',wall1 - wall0
do i = 1, mo_num
do j = 1, mo_num
do m = 1, j
three_e_3_idx_direct_bi_ort(m,j,i) = three_e_3_idx_direct_bi_ort(j,m,i)
do j = 1, mo_num
do m = 1, j
three_e_3_idx_direct_bi_ort(m,j,i) = three_e_3_idx_direct_bi_ort(j,m,i)
enddo
enddo
enddo
enddo
call wall_time(wall1)
print *, ' wall time for three_e_3_idx_direct_bi_ort', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_3_idx_cycle_1_bi_ort, (mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the first cyclic permutation
!
! three_e_3_idx_direct_bi_ort(m,j,i) = <mji|-L|jim>
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
END_DOC
integer :: i,j,m
double precision :: integral, wall1, wall0
character*(128) :: name_file
three_e_3_idx_cycle_1_bi_ort = 0.d0
print*,'Providing the three_e_3_idx_cycle_1_bi_ort ...'
call wall_time(wall0)
name_file = 'six_index_tensor'
provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
BEGIN_DOC
!
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the first cyclic permutation
!
! three_e_3_idx_direct_bi_ort(m,j,i) = <mji|-L|jim>
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
!
END_DOC
implicit none
integer :: i, j, m
double precision :: integral, wall1, wall0
three_e_3_idx_cycle_1_bi_ort = 0.d0
print *, ' Providing the three_e_3_idx_cycle_1_bi_ort ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,m,integral) &
!$OMP SHARED (mo_num,three_e_3_idx_cycle_1_bi_ort)
!$OMP DO SCHEDULE (dynamic)
do i = 1, mo_num
do j = 1, mo_num
do m = j, mo_num
call give_integrals_3_body_bi_ort(m,j,i,j,i,m,integral)
three_e_3_idx_cycle_1_bi_ort(m,j,i) = -1.d0 * integral
do j = 1, mo_num
do m = j, mo_num
call give_integrals_3_body_bi_ort(m, j, i, j, i, m, integral)
three_e_3_idx_cycle_1_bi_ort(m,j,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
do i = 1, mo_num
do j = 1, mo_num
do m = 1, j
three_e_3_idx_cycle_1_bi_ort(m,j,i) = three_e_3_idx_cycle_1_bi_ort(j,m,i)
do j = 1, mo_num
do m = 1, j
three_e_3_idx_cycle_1_bi_ort(m,j,i) = three_e_3_idx_cycle_1_bi_ort(j,m,i)
enddo
enddo
enddo
enddo
print*,'wall time for three_e_3_idx_cycle_1_bi_ort',wall1 - wall0
call wall_time(wall1)
print *, ' wall time for three_e_3_idx_cycle_1_bi_ort', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_3_idx_cycle_2_bi_ort, (mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the second cyclic permutation
!
! three_e_3_idx_direct_bi_ort(m,j,i) = <mji|-L|imj>
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
END_DOC
integer :: i,j,m
double precision :: integral, wall1, wall0
character*(128) :: name_file
three_e_3_idx_cycle_2_bi_ort = 0.d0
print*,'Providing the three_e_3_idx_cycle_2_bi_ort ...'
call wall_time(wall0)
name_file = 'six_index_tensor'
provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
BEGIN_DOC
!
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the second cyclic permutation
!
! three_e_3_idx_direct_bi_ort(m,j,i) = <mji|-L|imj>
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
!
END_DOC
implicit none
integer :: i, j, m
double precision :: integral, wall1, wall0
three_e_3_idx_cycle_2_bi_ort = 0.d0
print *, ' Providing the three_e_3_idx_cycle_2_bi_ort ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,m,integral) &
!$OMP SHARED (mo_num,three_e_3_idx_cycle_2_bi_ort)
!$OMP DO SCHEDULE (dynamic)
do i = 1, mo_num
do j = 1, mo_num
do m = j, mo_num
call give_integrals_3_body_bi_ort(m,j,i,i,m,j,integral)
three_e_3_idx_cycle_2_bi_ort(m,j,i) = -1.d0 * integral
do j = 1, mo_num
do m = j, mo_num
call give_integrals_3_body_bi_ort(m, j, i, i, m, j, integral)
three_e_3_idx_cycle_2_bi_ort(m,j,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
do i = 1, mo_num
do j = 1, mo_num
do m = 1, j
three_e_3_idx_cycle_2_bi_ort(m,j,i) = three_e_3_idx_cycle_2_bi_ort(j,m,i)
do j = 1, mo_num
do m = 1, j
three_e_3_idx_cycle_2_bi_ort(m,j,i) = three_e_3_idx_cycle_2_bi_ort(j,m,i)
enddo
enddo
enddo
enddo
print*,'wall time for three_e_3_idx_cycle_2_bi_ort',wall1 - wall0
call wall_time(wall1)
print *, ' wall time for three_e_3_idx_cycle_2_bi_ort', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_3_idx_exch23_bi_ort, (mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the permutations of particle 2 and 3
!
! three_e_3_idx_exch23_bi_ort(m,j,i) = <mji|-L|jmi>
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
END_DOC
integer :: i,j,m
double precision :: integral, wall1, wall0
character*(128) :: name_file
three_e_3_idx_exch23_bi_ort = 0.d0
print*,'Providing the three_e_3_idx_exch23_bi_ort ...'
call wall_time(wall0)
name_file = 'six_index_tensor'
provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
BEGIN_DOC
!
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the permutations of particle 2 and 3
!
! three_e_3_idx_exch23_bi_ort(m,j,i) = <mji|-L|jmi>
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
!
END_DOC
implicit none
integer :: i, j, m
double precision :: integral, wall1, wall0
three_e_3_idx_exch23_bi_ort = 0.d0
print*,'Providing the three_e_3_idx_exch23_bi_ort ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,m,integral) &
!$OMP SHARED (mo_num,three_e_3_idx_exch23_bi_ort)
!$OMP DO SCHEDULE (dynamic)
do i = 1, mo_num
do j = 1, mo_num
do m = j, mo_num
call give_integrals_3_body_bi_ort(m,j,i,j,m,i,integral)
three_e_3_idx_exch23_bi_ort(m,j,i) = -1.d0 * integral
do j = 1, mo_num
do m = j, mo_num
call give_integrals_3_body_bi_ort(m, j, i, j, m, i, integral)
three_e_3_idx_exch23_bi_ort(m,j,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
do i = 1, mo_num
do j = 1, mo_num
do m = 1, j
three_e_3_idx_exch23_bi_ort(m,j,i) = three_e_3_idx_exch23_bi_ort(j,m,i)
do j = 1, mo_num
do m = 1, j
three_e_3_idx_exch23_bi_ort(m,j,i) = three_e_3_idx_exch23_bi_ort(j,m,i)
enddo
enddo
enddo
enddo
call wall_time(wall1)
print*,'wall time for three_e_3_idx_exch23_bi_ort',wall1 - wall0
call wall_time(wall1)
print *, ' wall time for three_e_3_idx_exch23_bi_ort', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_3_idx_exch13_bi_ort, (mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the permutations of particle 1 and 3
!
! three_e_3_idx_exch13_bi_ort(m,j,i) = <mji|-L|ijm>
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
END_DOC
integer :: i,j,m
double precision :: integral, wall1, wall0
character*(128) :: name_file
three_e_3_idx_exch13_bi_ort = 0.d0
print*,'Providing the three_e_3_idx_exch13_bi_ort ...'
call wall_time(wall0)
name_file = 'six_index_tensor'
provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
BEGIN_DOC
!
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the permutations of particle 1 and 3
!
! three_e_3_idx_exch13_bi_ort(m,j,i) = <mji|-L|ijm>
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
!
END_DOC
implicit none
integer :: i,j,m
double precision :: integral, wall1, wall0
three_e_3_idx_exch13_bi_ort = 0.d0
print *, ' Providing the three_e_3_idx_exch13_bi_ort ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,m,integral) &
!$OMP SHARED (mo_num,three_e_3_idx_exch13_bi_ort)
!$OMP DO SCHEDULE (dynamic)
do i = 1, mo_num
do j = 1, mo_num
do m = j, mo_num
call give_integrals_3_body_bi_ort(m,j,i,i,j,m,integral)
three_e_3_idx_exch13_bi_ort(m,j,i) = -1.d0 * integral
do j = 1, mo_num
do m = j, mo_num
call give_integrals_3_body_bi_ort(m, j, i, i, j, m,integral)
three_e_3_idx_exch13_bi_ort(m,j,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
do i = 1, mo_num
do j = 1, mo_num
do m = 1, j
three_e_3_idx_exch13_bi_ort(m,j,i) = three_e_3_idx_exch13_bi_ort(j,m,i)
do j = 1, mo_num
do m = 1, j
three_e_3_idx_exch13_bi_ort(m,j,i) = three_e_3_idx_exch13_bi_ort(j,m,i)
enddo
enddo
enddo
enddo
call wall_time(wall1)
print*,'wall time for three_e_3_idx_exch13_bi_ort',wall1 - wall0
call wall_time(wall1)
print *, ' wall time for three_e_3_idx_exch13_bi_ort', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_3_idx_exch12_bi_ort, (mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the permutations of particle 1 and 2
!
! three_e_3_idx_exch12_bi_ort(m,j,i) = <mji|-L|mij>
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
END_DOC
integer :: i,j,m
double precision :: integral, wall1, wall0
character*(128) :: name_file
three_e_3_idx_exch12_bi_ort = 0.d0
print*,'Providing the three_e_3_idx_exch12_bi_ort ...'
call wall_time(wall0)
name_file = 'six_index_tensor'
provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
BEGIN_DOC
!
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the permutations of particle 1 and 2
!
! three_e_3_idx_exch12_bi_ort(m,j,i) = <mji|-L|mij>
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
!
END_DOC
implicit none
integer :: i, j, m
double precision :: integral, wall1, wall0
three_e_3_idx_exch12_bi_ort = 0.d0
print *, ' Providing the three_e_3_idx_exch12_bi_ort ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,m,integral) &
!$OMP SHARED (mo_num,three_e_3_idx_exch12_bi_ort)
!$OMP DO SCHEDULE (dynamic)
do i = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m,j,i,m,i,j,integral)
three_e_3_idx_exch12_bi_ort(m,j,i) = -1.d0 * integral
do j = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m, j, i, m, i, j, integral)
three_e_3_idx_exch12_bi_ort(m,j,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print*,'wall time for three_e_3_idx_exch12_bi_ort',wall1 - wall0
call wall_time(wall1)
print *, ' wall time for three_e_3_idx_exch12_bi_ort', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_3_idx_exch12_bi_ort_new, (mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the permutations of particle 1 and 2
!
! three_e_3_idx_exch12_bi_ort_new(m,j,i) = <mji|-L|mij>
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
END_DOC
integer :: i,j,m
double precision :: integral, wall1, wall0
character*(128) :: name_file
three_e_3_idx_exch12_bi_ort_new = 0.d0
print*,'Providing the three_e_3_idx_exch12_bi_ort_new ...'
call wall_time(wall0)
name_file = 'six_index_tensor'
provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
BEGIN_DOC
!
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the permutations of particle 1 and 2
!
! three_e_3_idx_exch12_bi_ort_new(m,j,i) = <mji|-L|mij>
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
!
END_DOC
implicit none
integer :: i, j, m
double precision :: integral, wall1, wall0
three_e_3_idx_exch12_bi_ort_new = 0.d0
print *, ' Providing the three_e_3_idx_exch12_bi_ort_new ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,m,integral) &
!$OMP SHARED (mo_num,three_e_3_idx_exch12_bi_ort_new)
!$OMP DO SCHEDULE (dynamic)
do i = 1, mo_num
do j = 1, mo_num
do m = j, mo_num
call give_integrals_3_body_bi_ort(m,j,i,m,i,j,integral)
three_e_3_idx_exch12_bi_ort_new(m,j,i) = -1.d0 * integral
do j = 1, mo_num
do m = j, mo_num
call give_integrals_3_body_bi_ort(m, j, i, m, i, j, integral)
three_e_3_idx_exch12_bi_ort_new(m,j,i) = -1.d0 * integral
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
do i = 1, mo_num
do j = 1, mo_num
do m = 1, j
three_e_3_idx_exch12_bi_ort_new(m,j,i) = three_e_3_idx_exch12_bi_ort_new(j,m,i)
do j = 1, mo_num
do m = 1, j
three_e_3_idx_exch12_bi_ort_new(m,j,i) = three_e_3_idx_exch12_bi_ort_new(j,m,i)
enddo
enddo
enddo
enddo
call wall_time(wall1)
print*,'wall time for three_e_3_idx_exch12_bi_ort_new',wall1 - wall0
call wall_time(wall1)
print *, ' wall time for three_e_3_idx_exch12_bi_ort_new', wall1 - wall0
END_PROVIDER
! ---

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

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

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

@ -1,240 +1,296 @@
! ---
BEGIN_PROVIDER [ double precision, three_e_5_idx_direct_bi_ort, (mo_num, mo_num, mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
!
!three_e_5_idx_direct_bi_ort(m,l,j,k,i) = <mjk|-L|mji> ::: notice that i is the RIGHT MO and k is the LEFT MO
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
END_DOC
integer :: i,j,k,m,l
double precision :: integral, wall1, wall0
character*(128) :: name_file
three_e_5_idx_direct_bi_ort = 0.d0
print*,'Providing the three_e_5_idx_direct_bi_ort ...'
call wall_time(wall0)
provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,l,integral) &
!$OMP SHARED (mo_num,three_e_5_idx_direct_bi_ort)
!$OMP DO SCHEDULE (dynamic)
do i = 1, mo_num
BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
!
! three_e_5_idx_direct_bi_ort(m,l,j,k,i) = <mjk|-L|mji> ::: notice that i is the RIGHT MO and k is the LEFT MO
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
END_DOC
implicit none
integer :: i, j, k, m, l
double precision :: integral, wall1, wall0
three_e_5_idx_direct_bi_ort = 0.d0
print *, ' Providing the three_e_5_idx_direct_bi_ort ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,l,integral) &
!$OMP SHARED (mo_num,three_e_5_idx_direct_bi_ort)
!$OMP DO SCHEDULE (dynamic)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do l = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m,l,k,m,j,i,integral)
three_e_5_idx_direct_bi_ort(m,l,j,k,i) = -1.d0 * integral
enddo
do j = 1, mo_num
do l = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m, l, k, m, j, i, integral)
three_e_5_idx_direct_bi_ort(m,l,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print*,'wall time for three_e_5_idx_direct_bi_ort',wall1 - wall0
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_5_idx_direct_bi_ort', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_5_idx_cycle_1_bi_ort, (mo_num, mo_num, mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC
! matrix element of the -L three-body operator FOR THE FIRST CYCLIC PERMUTATION TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
!
!three_e_5_idx_cycle_1_bi_ort(m,l,j,k,i) = <mlk|-L|jim> ::: notice that i is the RIGHT MO and k is the LEFT MO
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
END_DOC
integer :: i,j,k,m,l
double precision :: integral, wall1, wall0
character*(128) :: name_file
three_e_5_idx_cycle_1_bi_ort = 0.d0
print*,'Providing the three_e_5_idx_cycle_1_bi_ort ...'
call wall_time(wall0)
provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,l,integral) &
!$OMP SHARED (mo_num,three_e_5_idx_cycle_1_bi_ort)
!$OMP DO SCHEDULE (dynamic)
do i = 1, mo_num
BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE FIRST CYCLIC PERMUTATION TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
!
! three_e_5_idx_cycle_1_bi_ort(m,l,j,k,i) = <mlk|-L|jim> ::: notice that i is the RIGHT MO and k is the LEFT MO
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
!
END_DOC
implicit none
integer :: i, j, k, m, l
double precision :: integral, wall1, wall0
three_e_5_idx_cycle_1_bi_ort = 0.d0
print *, ' Providing the three_e_5_idx_cycle_1_bi_ort ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,l,integral) &
!$OMP SHARED (mo_num,three_e_5_idx_cycle_1_bi_ort)
!$OMP DO SCHEDULE (dynamic)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do l = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m,l,k,j,i,m,integral)
three_e_5_idx_cycle_1_bi_ort(m,l,j,k,i) = -1.d0 * integral
enddo
do j = 1, mo_num
do l = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m, l, k, j, i, m, integral)
three_e_5_idx_cycle_1_bi_ort(m,l,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print*,'wall time for three_e_5_idx_cycle_1_bi_ort',wall1 - wall0
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_5_idx_cycle_1_bi_ort', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_5_idx_cycle_2_bi_ort, (mo_num, mo_num, mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC
! matrix element of the -L three-body operator FOR THE FIRST CYCLIC PERMUTATION TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
!
!three_e_5_idx_cycle_2_bi_ort(m,l,j,k,i) = <mlk|-L|imj> ::: notice that i is the RIGHT MO and k is the LEFT MO
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
END_DOC
integer :: i,j,k,m,l
double precision :: integral, wall1, wall0
character*(128) :: name_file
three_e_5_idx_cycle_2_bi_ort = 0.d0
print*,'Providing the three_e_5_idx_cycle_2_bi_ort ...'
call wall_time(wall0)
provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,l,integral) &
!$OMP SHARED (mo_num,three_e_5_idx_cycle_2_bi_ort)
!$OMP DO SCHEDULE (dynamic)
do i = 1, mo_num
BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE FIRST CYCLIC PERMUTATION TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
!
! three_e_5_idx_cycle_2_bi_ort(m,l,j,k,i) = <mlk|-L|imj> ::: notice that i is the RIGHT MO and k is the LEFT MO
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
!
END_DOC
implicit none
integer :: i, j, k, m, l
double precision :: integral, wall1, wall0
three_e_5_idx_cycle_2_bi_ort = 0.d0
print *, ' Providing the three_e_5_idx_cycle_2_bi_ort ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,l,integral) &
!$OMP SHARED (mo_num,three_e_5_idx_cycle_2_bi_ort)
!$OMP DO SCHEDULE (dynamic)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
do l = 1, mo_num
call give_integrals_3_body_bi_ort(m,l,k,i,m,j,integral)
three_e_5_idx_cycle_2_bi_ort(m,l,j,k,i) = -1.d0 * integral
enddo
do j = 1, mo_num
do m = 1, mo_num
do l = 1, mo_num
call give_integrals_3_body_bi_ort(m, l, k, i, m, j, integral)
three_e_5_idx_cycle_2_bi_ort(m,l,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print*,'wall time for three_e_5_idx_cycle_2_bi_ort',wall1 - wall0
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_5_idx_cycle_2_bi_ort', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_5_idx_exch23_bi_ort, (mo_num, mo_num, mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
!
!three_e_5_idx_exch23_bi_ort(m,l,j,k,i) = <mlk|-L|jmi> ::: notice that i is the RIGHT MO and k is the LEFT MO
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
END_DOC
integer :: i,j,k,m,l
double precision :: integral, wall1, wall0
character*(128) :: name_file
three_e_5_idx_exch23_bi_ort = 0.d0
print*,'Providing the three_e_5_idx_exch23_bi_ort ...'
call wall_time(wall0)
provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,l,integral) &
!$OMP SHARED (mo_num,three_e_5_idx_exch23_bi_ort)
!$OMP DO SCHEDULE (dynamic)
do i = 1, mo_num
BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
!
! three_e_5_idx_exch23_bi_ort(m,l,j,k,i) = <mlk|-L|jmi> ::: notice that i is the RIGHT MO and k is the LEFT MO
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
!
END_DOC
implicit none
integer :: i, j, k, m, l
double precision :: integral, wall1, wall0
three_e_5_idx_exch23_bi_ort = 0.d0
print *, ' Providing the three_e_5_idx_exch23_bi_ort ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,l,integral) &
!$OMP SHARED (mo_num,three_e_5_idx_exch23_bi_ort)
!$OMP DO SCHEDULE (dynamic)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do l = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m,l,k,j,m,i,integral)
three_e_5_idx_exch23_bi_ort(m,l,j,k,i) = -1.d0 * integral
enddo
do j = 1, mo_num
do l = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m, l, k, j, m, i, integral)
three_e_5_idx_exch23_bi_ort(m,l,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print*,'wall time for three_e_5_idx_exch23_bi_ort',wall1 - wall0
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_5_idx_exch23_bi_ort', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_5_idx_exch13_bi_ort, (mo_num, mo_num, mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
!
!three_e_5_idx_exch13_bi_ort(m,l,j,k,i) = <mlk|-L|jmi> ::: notice that i is the RIGHT MO and k is the LEFT MO
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
END_DOC
integer :: i,j,k,m,l
double precision :: integral, wall1, wall0
character*(128) :: name_file
three_e_5_idx_exch13_bi_ort = 0.d0
print*,'Providing the three_e_5_idx_exch13_bi_ort ...'
call wall_time(wall0)
provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,l,integral) &
!$OMP SHARED (mo_num,three_e_5_idx_exch13_bi_ort)
!$OMP DO SCHEDULE (dynamic)
do i = 1, mo_num
BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
!
! three_e_5_idx_exch13_bi_ort(m,l,j,k,i) = <mlk|-L|jmi> ::: notice that i is the RIGHT MO and k is the LEFT MO
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
!
END_DOC
implicit none
integer :: i, j, k, m, l
double precision :: integral, wall1, wall0
three_e_5_idx_exch13_bi_ort = 0.d0
print *, ' Providing the three_e_5_idx_exch13_bi_ort ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,l,integral) &
!$OMP SHARED (mo_num,three_e_5_idx_exch13_bi_ort)
!$OMP DO SCHEDULE (dynamic)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do l = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m,l,k,i,j,m,integral)
three_e_5_idx_exch13_bi_ort(m,l,j,k,i) = -1.d0 * integral
enddo
do j = 1, mo_num
do l = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m, l, k, i, j, m, integral)
three_e_5_idx_exch13_bi_ort(m,l,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print*,'wall time for three_e_5_idx_exch13_bi_ort',wall1 - wall0
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_5_idx_exch13_bi_ort', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_5_idx_exch12_bi_ort, (mo_num, mo_num, mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
!
!three_e_5_idx_exch12_bi_ort(m,l,j,k,i) = <mlk|-L|jmi> ::: notice that i is the RIGHT MO and k is the LEFT MO
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
END_DOC
integer :: i,j,k,m,l
double precision :: integral, wall1, wall0
character*(128) :: name_file
three_e_5_idx_exch12_bi_ort = 0.d0
print*,'Providing the three_e_5_idx_exch12_bi_ort ...'
call wall_time(wall0)
provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,l,integral) &
!$OMP SHARED (mo_num,three_e_5_idx_exch12_bi_ort)
!$OMP DO SCHEDULE (dynamic)
do i = 1, mo_num
BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
!
! three_e_5_idx_exch12_bi_ort(m,l,j,k,i) = <mlk|-L|jmi> ::: notice that i is the RIGHT MO and k is the LEFT MO
!
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
!
END_DOC
implicit none
integer :: i, j, k, m, l
double precision :: integral, wall1, wall0
three_e_5_idx_exch12_bi_ort = 0.d0
print *, ' Providing the three_e_5_idx_exch12_bi_ort ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,l,integral) &
!$OMP SHARED (mo_num,three_e_5_idx_exch12_bi_ort)
!$OMP DO SCHEDULE (dynamic)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do l = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m,l,k,m,i,j,integral)
three_e_5_idx_exch12_bi_ort(m,l,j,k,i) = -1.d0 * integral
enddo
do j = 1, mo_num
do l = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m, l, k, m, i, j, integral)
three_e_5_idx_exch12_bi_ort(m,l,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print*,'wall time for three_e_5_idx_exch12_bi_ort',wall1 - wall0
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_5_idx_exch12_bi_ort', wall1 - wall0
END_PROVIDER
! ---

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

@ -1,17 +1,24 @@
! ---
BEGIN_PROVIDER [ double precision, three_body_ints_bi_ort, (mo_num, mo_num, mo_num, mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC
! matrix element of the -L three-body operator
!
! notice the -1 sign: in this way three_body_ints_bi_ort can be directly used to compute Slater rules :)
END_DOC
integer :: i,j,k,l,m,n
implicit none
integer :: i, j, k, l, m, n
double precision :: integral, wall1, wall0
character*(128) :: name_file
three_body_ints_bi_ort = 0.d0
print*,'Providing the three_body_ints_bi_ort ...'
call wall_time(wall0)
name_file = 'six_index_tensor'
character*(128) :: name_file
three_body_ints_bi_ort = 0.d0
print*,'Providing the three_body_ints_bi_ort ...'
call wall_time(wall0)
name_file = 'six_index_tensor'
! if(read_three_body_ints_bi_ort)then
! call read_fcidump_3_tc(three_body_ints_bi_ort)
! else
@ -19,32 +26,37 @@ BEGIN_PROVIDER [ double precision, three_body_ints_bi_ort, (mo_num, mo_num, mo_n
! print*,'Reading three_body_ints_bi_ort from disk ...'
! call read_array_6_index_tensor(mo_num,three_body_ints_bi_ort,name_file)
! else
provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,l,m,n,integral) &
!$OMP SHARED (mo_num,three_body_ints_bi_ort)
!$OMP DO SCHEDULE (dynamic)
do i = 1, mo_num
!provide x_W_ki_bi_ortho_erf_rk
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,l,m,n,integral) &
!$OMP SHARED (mo_num,three_body_ints_bi_ort)
!$OMP DO SCHEDULE (dynamic)
do i = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
do k = 1, mo_num
do l = 1, mo_num
do n = 1, mo_num
call give_integrals_3_body_bi_ort(n,l,k,m,j,i,integral)
three_body_ints_bi_ort(n,l,k,m,j,i) = -1.d0 * integral
do m = 1, mo_num
do k = 1, mo_num
do l = 1, mo_num
do n = 1, mo_num
call give_integrals_3_body_bi_ort(n, l, k, m, j, i, integral)
three_body_ints_bi_ort(n,l,k,m,j,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
enddo
!$OMP END DO
!$OMP END PARALLEL
! endif
! endif
call wall_time(wall1)
print*,'wall time for three_body_ints_bi_ort',wall1 - wall0
call wall_time(wall1)
print *, ' wall time for three_body_ints_bi_ort', wall1 - wall0
! if(write_three_body_ints_bi_ort)then
! print*,'Writing three_body_ints_bi_ort on disk ...'
! call write_array_6_index_tensor(mo_num,three_body_ints_bi_ort,name_file)
@ -53,26 +65,68 @@ BEGIN_PROVIDER [ double precision, three_body_ints_bi_ort, (mo_num, mo_num, mo_n
END_PROVIDER
subroutine give_integrals_3_body_bi_ort(n,l,k,m,j,i,integral)
implicit none
double precision, intent(out) :: integral
integer, intent(in) :: n,l,k,m,j,i
double precision :: weight
BEGIN_DOC
! <n l k|-L|m j i> with a BI ORTHONORMAL ORBITALS
END_DOC
integer :: ipoint,mm
integral = 0.d0
do mm = 1, 3
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,mm,n,m) * x_W_ki_bi_ortho_erf_rk(ipoint,mm,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,mm,n,m) * x_W_ki_bi_ortho_erf_rk(ipoint,mm,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,mm,l,j) * x_W_ki_bi_ortho_erf_rk(ipoint,mm,k,i)
enddo
enddo
end
! ---
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 ORBITALS
!
END_DOC
implicit none
integer, intent(in) :: n, l, k, m, j, i
double precision, intent(out) :: integral
integer :: ipoint
double precision :: weight
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) &
+ int2_grad1_u12_bimo_transp(n,m,3,ipoint) * int2_grad1_u12_bimo_transp(l,j,3,ipoint) )
integral += weight * mos_l_in_r_array_transp(ipoint,l) * mos_r_in_r_array_transp(ipoint,j) &
* ( int2_grad1_u12_bimo_transp(n,m,1,ipoint) * int2_grad1_u12_bimo_transp(k,i,1,ipoint) &
+ int2_grad1_u12_bimo_transp(n,m,2,ipoint) * int2_grad1_u12_bimo_transp(k,i,2,ipoint) &
+ int2_grad1_u12_bimo_transp(n,m,3,ipoint) * int2_grad1_u12_bimo_transp(k,i,3,ipoint) )
integral += weight * mos_l_in_r_array_transp(ipoint,n) * mos_r_in_r_array_transp(ipoint,m) &
* ( int2_grad1_u12_bimo_transp(l,j,1,ipoint) * int2_grad1_u12_bimo_transp(k,i,1,ipoint) &
+ int2_grad1_u12_bimo_transp(l,j,2,ipoint) * int2_grad1_u12_bimo_transp(k,i,2,ipoint) &
+ int2_grad1_u12_bimo_transp(l,j,3,ipoint) * int2_grad1_u12_bimo_transp(k,i,3,ipoint) )
enddo
end subroutine give_integrals_3_body_bi_ort
! ---

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

@ -1,138 +1,198 @@
BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_num) ]
integer :: i,j,k,l
BEGIN_DOC
! ao_two_e_tc_tot(k,i,l,j) = (ki|V^TC(r_12)|lj) = <lk| V^TC(r_12) |ji> where V^TC(r_12) is the total TC operator
!
! including both hermitian and non hermitian parts. THIS IS IN CHEMIST NOTATION.
!
! WARNING :: non hermitian ! acts on "the right functions" (i,j)
END_DOC
double precision :: integral_sym, integral_nsym, get_ao_tc_sym_two_e_pot
PROVIDE ao_tc_sym_two_e_pot_in_map
do j = 1, ao_num
do l = 1, ao_num
do i = 1, ao_num
do k = 1, ao_num
integral_sym = get_ao_tc_sym_two_e_pot(i,j,k,l,ao_tc_sym_two_e_pot_map)
! ao_non_hermit_term_chemist(k,i,l,j) = < k l | [erf( mu r12) - 1] d/d_r12 | i j > on the AO basis
integral_nsym = ao_non_hermit_term_chemist(k,i,l,j)
ao_two_e_tc_tot(k,i,l,j) = integral_sym + integral_nsym
enddo
enddo
enddo
enddo
END_PROVIDER
double precision function bi_ortho_mo_ints(l,k,j,i)
implicit none
BEGIN_DOC
! <mo^L_k mo^L_l | V^TC(r_12) | mo^R_i mo^R_j>
!
! WARNING :: very naive, super slow, only used to DEBUG.
END_DOC
integer, intent(in) :: i,j,k,l
integer :: m,n,p,q
bi_ortho_mo_ints = 0.d0
do m = 1, ao_num
do p = 1, ao_num
do n = 1, ao_num
do q = 1, ao_num
! p1h1p2h2 l1 l2 r1 r2
bi_ortho_mo_ints += ao_two_e_tc_tot(n,q,m,p) * mo_l_coef(m,l) * mo_l_coef(n,k) * mo_r_coef(p,j) * mo_r_coef(q,i)
enddo
enddo
enddo
enddo
end
! ---
BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC
! mo_bi_ortho_tc_two_e_chemist(k,i,l,j) = <k l|V(r_12)|i j> where i,j are right MOs and k,l are left MOs
END_DOC
integer :: i,j,k,l,m,n,p,q
double precision, allocatable :: mo_tmp_1(:,:,:,:),mo_tmp_2(:,:,:,:),mo_tmp_3(:,:,:,:)
BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_num) ]
!! TODO :: transform into DEGEMM
allocate(mo_tmp_1(mo_num,ao_num,ao_num,ao_num))
mo_tmp_1 = 0.d0
do m = 1, ao_num
do p = 1, ao_num
do n = 1, ao_num
do q = 1, ao_num
do k = 1, mo_num
! (k n|p m) = sum_q c_qk * (q n|p m)
mo_tmp_1(k,n,p,m) += mo_l_coef_transp(k,q) * ao_two_e_tc_tot(q,n,p,m)
enddo
BEGIN_DOC
!
! ao_two_e_tc_tot(k,i,l,j) = (ki|V^TC(r_12)|lj) = <lk| V^TC(r_12) |ji> where V^TC(r_12) is the total TC operator
!
! including both hermitian and non hermitian parts. THIS IS IN CHEMIST NOTATION.
!
! WARNING :: non hermitian ! acts on "the right functions" (i,j)
!
END_DOC
integer :: i, j, k, l
double precision :: integral_sym, integral_nsym
double precision, external :: get_ao_tc_sym_two_e_pot
provide j1b_type
if(j1b_type .eq. 3) then
do j = 1, ao_num
do l = 1, ao_num
do i = 1, ao_num
do k = 1, ao_num
ao_two_e_tc_tot(k,i,l,j) = ao_tc_int_chemist(k,i,l,j)
!write(222,*) ao_two_e_tc_tot(k,i,l,j)
enddo
enddo
enddo
enddo
enddo
enddo
enddo
allocate(mo_tmp_2(mo_num,mo_num,ao_num,ao_num))
mo_tmp_2 = 0.d0
do m = 1, ao_num
do p = 1, ao_num
do n = 1, ao_num
do i = 1, mo_num
do k = 1, mo_num
! (k i|p m) = sum_n c_ni * (k n|p m)
mo_tmp_2(k,i,p,m) += mo_r_coef_transp(i,n) * mo_tmp_1(k,n,p,m)
enddo
else
PROVIDE ao_tc_sym_two_e_pot_in_map
do j = 1, ao_num
do l = 1, ao_num
do i = 1, ao_num
do k = 1, ao_num
integral_sym = get_ao_tc_sym_two_e_pot(i, j, k, l, ao_tc_sym_two_e_pot_map)
! ao_non_hermit_term_chemist(k,i,l,j) = < k l | [erf( mu r12) - 1] d/d_r12 | i j > on the AO basis
integral_nsym = ao_non_hermit_term_chemist(k,i,l,j)
ao_two_e_tc_tot(k,i,l,j) = integral_sym + integral_nsym
!write(111,*) ao_two_e_tc_tot(k,i,l,j)
enddo
enddo
enddo
enddo
enddo
enddo
enddo
deallocate(mo_tmp_1)
allocate(mo_tmp_1(mo_num,mo_num,mo_num,ao_num))
mo_tmp_1 = 0.d0
do m = 1, ao_num
do p = 1, ao_num
do l = 1, mo_num
do i = 1, mo_num
do k = 1, mo_num
mo_tmp_1(k,i,l,m) += mo_l_coef_transp(l,p) * mo_tmp_2(k,i,p,m)
enddo
enddo
enddo
enddo
enddo
deallocate(mo_tmp_2)
mo_bi_ortho_tc_two_e_chemist = 0.d0
do m = 1, ao_num
do j = 1, mo_num
do l = 1, mo_num
do i = 1, mo_num
do k = 1, mo_num
mo_bi_ortho_tc_two_e_chemist(k,i,l,j) += mo_r_coef_transp(j,m) * mo_tmp_1(k,i,l,m)
enddo
enddo
enddo
enddo
enddo
endif
END_PROVIDER
! ---
double precision function bi_ortho_mo_ints(l, k, j, i)
BEGIN_DOC
!
! <mo^L_k mo^L_l | V^TC(r_12) | mo^R_i mo^R_j>
!
! WARNING :: very naive, super slow, only used to DEBUG.
!
END_DOC
implicit none
integer, intent(in) :: i, j, k, l
integer :: m, n, p, q
bi_ortho_mo_ints = 0.d0
do m = 1, ao_num
do p = 1, ao_num
do n = 1, ao_num
do q = 1, ao_num
! p1h1p2h2 l1 l2 r1 r2
bi_ortho_mo_ints += ao_two_e_tc_tot(n,q,m,p) * mo_l_coef(m,l) * mo_l_coef(n,k) * mo_r_coef(p,j) * mo_r_coef(q,i)
enddo
enddo
enddo
enddo
end function bi_ortho_mo_ints
! ---
! TODO :: transform into DEGEMM
BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC
!
! mo_bi_ortho_tc_two_e_chemist(k,i,l,j) = <k l|V(r_12)|i j> where i,j are right MOs and k,l are left MOs
!
END_DOC
implicit none
integer :: i, j, k, l, m, n, p, q
double precision, allocatable :: mo_tmp_1(:,:,:,:), mo_tmp_2(:,:,:,:)
allocate(mo_tmp_1(mo_num,ao_num,ao_num,ao_num))
mo_tmp_1 = 0.d0
do m = 1, ao_num
do p = 1, ao_num
do n = 1, ao_num
do q = 1, ao_num
do k = 1, mo_num
! (k n|p m) = sum_q c_qk * (q n|p m)
mo_tmp_1(k,n,p,m) += mo_l_coef_transp(k,q) * ao_two_e_tc_tot(q,n,p,m)
enddo
enddo
enddo
enddo
enddo
allocate(mo_tmp_2(mo_num,mo_num,ao_num,ao_num))
mo_tmp_2 = 0.d0
do m = 1, ao_num
do p = 1, ao_num
do n = 1, ao_num
do i = 1, mo_num
do k = 1, mo_num
! (k i|p m) = sum_n c_ni * (k n|p m)
mo_tmp_2(k,i,p,m) += mo_r_coef_transp(i,n) * mo_tmp_1(k,n,p,m)
enddo
enddo
enddo
enddo
enddo
deallocate(mo_tmp_1)
allocate(mo_tmp_1(mo_num,mo_num,mo_num,ao_num))
mo_tmp_1 = 0.d0
do m = 1, ao_num
do p = 1, ao_num
do l = 1, mo_num
do i = 1, mo_num
do k = 1, mo_num
mo_tmp_1(k,i,l,m) += mo_l_coef_transp(l,p) * mo_tmp_2(k,i,p,m)
enddo
enddo
enddo
enddo
enddo
deallocate(mo_tmp_2)
mo_bi_ortho_tc_two_e_chemist = 0.d0
do m = 1, ao_num
do j = 1, mo_num
do l = 1, mo_num
do i = 1, mo_num
do k = 1, mo_num
mo_bi_ortho_tc_two_e_chemist(k,i,l,j) += mo_r_coef_transp(j,m) * mo_tmp_1(k,i,l,m)
enddo
enddo
enddo
enddo
enddo
deallocate(mo_tmp_1)
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e, (mo_num, mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC
! mo_bi_ortho_tc_two_e(k,l,i,j) = <k l| V(r_12) |i j> where i,j are right MOs and k,l are left MOs
!
! the potential V(r_12) contains ALL TWO-E CONTRIBUTION OF THE TC-HAMILTONIAN
END_DOC
integer :: i,j,k,l
do j = 1, mo_num
do i = 1, mo_num
do l = 1, mo_num
do k = 1, mo_num
! (k i|l j) = <k l|V(r_12)|i j>
mo_bi_ortho_tc_two_e(k,l,i,j) = mo_bi_ortho_tc_two_e_chemist(k,i,l,j)
BEGIN_DOC
!
! mo_bi_ortho_tc_two_e(k,l,i,j) = <k l| V(r_12) |i j> where i,j are right MOs and k,l are left MOs
!
! the potential V(r_12) contains ALL TWO-E CONTRIBUTION OF THE TC-HAMILTONIAN
!
END_DOC
implicit none
integer :: i, j, k, l
do j = 1, mo_num
do i = 1, mo_num
do l = 1, mo_num
do k = 1, mo_num
! < k l | V12 | i j > (k i|l j)
mo_bi_ortho_tc_two_e(k,l,i,j) = mo_bi_ortho_tc_two_e_chemist(k,i,l,j)
enddo
enddo
enddo
enddo
enddo
enddo
END_PROVIDER
! ---

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

@ -1,33 +1,37 @@
! ---
subroutine ao_to_mo_bi_ortho(A_ao, LDA_ao, A_mo, LDA_mo)
BEGIN_DOC
!
! Transform A from the |AO| basis to the BI ORTHONORMAL MOS
!
! $C_L^\dagger.A_{ao}.C_R$ where C_L and C_R are the LEFT and RIGHT MO coefs
!
END_DOC
implicit none
integer, intent(in) :: LDA_ao,LDA_mo
integer, intent(in) :: LDA_ao, LDA_mo
double precision, intent(in) :: A_ao(LDA_ao,ao_num)
double precision, intent(out) :: A_mo(LDA_mo,mo_num)
double precision, allocatable :: T(:,:)
allocate ( T(ao_num,mo_num) )
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T
integer :: i,j,p,q
call dgemm('N', 'N', ao_num, mo_num, ao_num, &
1.d0, A_ao, LDA_ao, &
mo_r_coef, size(mo_r_coef, 1), &
0.d0, T, size(T, 1))
! T = A_ao x mo_r_coef
call dgemm( 'N', 'N', ao_num, mo_num, ao_num, 1.d0 &
, A_ao, LDA_ao, mo_r_coef, size(mo_r_coef, 1) &
, 0.d0, T, size(T, 1) )
call dgemm('T', 'N', mo_num, mo_num, ao_num, &
1.d0, mo_l_coef, size(mo_l_coef, 1), &
T, ao_num, &
0.d0, A_mo, size(A_mo, 1))
! A_mo = mo_l_coef.T x T
call dgemm( 'T', 'N', mo_num, mo_num, ao_num, 1.d0 &
, 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)
deallocate(T)
end subroutine ao_to_mo_bi_ortho
@ -131,7 +135,7 @@ BEGIN_PROVIDER [ double precision, mo_l_coef, (ao_num, mo_num) ]
IRP_ENDIF
else
print*, 'mo_r_coef are mo_coef'
print*, 'mo_l_coef are mo_coef'
do i = 1, mo_num
do j = 1, ao_num
mo_l_coef(j,i) = mo_coef(j,i)

512
src/non_h_ints_mu/debug_fit.irp.f Normal file
View File

@ -0,0 +1,512 @@
! --
program debug_fit
implicit none
my_grid_becke = .True.
my_n_pt_r_grid = 30
my_n_pt_a_grid = 50
!my_n_pt_r_grid = 100
!my_n_pt_a_grid = 170
!my_n_pt_r_grid = 150
!my_n_pt_a_grid = 194
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
PROVIDE mu_erf j1b_pen
!call test_j1b_nucl()
call test_grad_j1b_nucl()
!call test_lapl_j1b_nucl()
!call test_list_b2()
!call test_list_b3()
call test_fit_u()
!call test_fit_u2()
!call test_fit_ugradu()
end
! ---
subroutine test_j1b_nucl()
implicit none
integer :: ipoint
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
double precision :: r(3)
double precision, external :: j1b_nucl
print*, ' test_j1b_nucl ...'
PROVIDE v_1b
eps_ij = 1d-7
acc_tot = 0.d0
normalz = 0.d0
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)
i_exc = v_1b(ipoint)
i_num = j1b_nucl(r)
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in v_1b on', ipoint
print *, ' analyt = ', i_exc
print *, ' numeri = ', i_num
print *, ' diff = ', acc_ij
endif
acc_tot += acc_ij
normalz += dabs(i_num)
enddo
print*, ' acc_tot = ', acc_tot
print*, ' normalz = ', normalz
return
end subroutine test_j1b_nucl
! ---
subroutine test_grad_j1b_nucl()
implicit none
integer :: ipoint
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
double precision :: r(3)
double precision, external :: grad_x_j1b_nucl
double precision, external :: grad_y_j1b_nucl
double precision, external :: grad_z_j1b_nucl
print*, ' test_grad_j1b_nucl ...'
PROVIDE v_1b_grad
eps_ij = 1d-7
acc_tot = 0.d0
normalz = 0.d0
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)
i_exc = v_1b_grad(1,ipoint)
i_num = grad_x_j1b_nucl(r)
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in x of v_1b_grad on', ipoint
print *, ' analyt = ', i_exc
print *, ' numeri = ', i_num
print *, ' diff = ', acc_ij
endif
i_exc = v_1b_grad(2,ipoint)
i_num = grad_y_j1b_nucl(r)
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in y of v_1b_grad on', ipoint
print *, ' analyt = ', i_exc
print *, ' numeri = ', i_num
print *, ' diff = ', acc_ij
endif
i_exc = v_1b_grad(3,ipoint)
i_num = grad_z_j1b_nucl(r)
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in z of v_1b_grad on', ipoint
print *, ' analyt = ', i_exc
print *, ' numeri = ', i_num
print *, ' diff = ', acc_ij
endif
acc_tot += acc_ij
normalz += dabs(i_num)
enddo
print*, ' acc_tot = ', acc_tot
print*, ' normalz = ', normalz
return
end subroutine test_grad_j1b_nucl
! ---
subroutine test_lapl_j1b_nucl()
implicit none
integer :: ipoint
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
double precision :: r(3)
double precision, external :: lapl_j1b_nucl
print*, ' test_lapl_j1b_nucl ...'
PROVIDE v_1b_lapl
eps_ij = 1d-5
acc_tot = 0.d0
normalz = 0.d0
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)
i_exc = v_1b_lapl(ipoint)
i_num = lapl_j1b_nucl(r)
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in v_1b_lapl on', ipoint
print *, ' analyt = ', i_exc
print *, ' numeri = ', i_num
print *, ' diff = ', acc_ij
endif
acc_tot += acc_ij
normalz += dabs(i_num)
enddo
print*, ' acc_tot = ', acc_tot
print*, ' normalz = ', normalz
return
end subroutine test_lapl_j1b_nucl
! ---
subroutine test_list_b2()
implicit none
integer :: ipoint
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
double precision :: r(3)
double precision, external :: j1b_nucl
print*, ' test_list_b2 ...'
PROVIDE v_1b_list_b2
eps_ij = 1d-7
acc_tot = 0.d0
normalz = 0.d0
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)
i_exc = v_1b_list_b2(ipoint)
i_num = j1b_nucl(r)
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in list_b2 on', ipoint
print *, ' analyt = ', i_exc
print *, ' numeri = ', i_num
print *, ' diff = ', acc_ij
endif
acc_tot += acc_ij
normalz += dabs(i_num)
enddo
print*, ' acc_tot = ', acc_tot
print*, ' normalz = ', normalz
return
end subroutine test_list_b2
! ---
subroutine test_list_b3()
implicit none
integer :: ipoint
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_tmp, i_num, normalz
double precision :: r(3)
double precision, external :: j1b_nucl
print*, ' test_list_b3 ...'
PROVIDE v_1b_list_b3
eps_ij = 1d-7
acc_tot = 0.d0
normalz = 0.d0
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)
i_exc = v_1b_list_b3(ipoint)
i_tmp = j1b_nucl(r)
i_num = i_tmp * i_tmp
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in list_b3 on', ipoint
print *, ' analyt = ', i_exc
print *, ' numeri = ', i_num
print *, ' diff = ', acc_ij
endif
acc_tot += acc_ij
normalz += dabs(i_num)
enddo
print*, ' acc_tot = ', acc_tot
print*, ' normalz = ', normalz
return
end subroutine test_list_b3
! ---
subroutine test_fit_ugradu()
implicit none
integer :: jpoint, ipoint, i
double precision :: i_exc, i_fit, i_num, x2, tmp, dx, dy, dz
double precision :: r1(3), r2(3), grad(3)
double precision :: eps_ij, acc_tot, acc_ij, normalz, coef, expo
double precision, external :: j12_mu
print*, ' test_fit_ugradu ...'
eps_ij = 1d-3
do jpoint = 1, n_points_final_grid
r2(1) = final_grid_points(1,jpoint)
r2(2) = final_grid_points(2,jpoint)
r2(3) = final_grid_points(3,jpoint)
acc_tot = 0.d0
normalz = 0.d0
do ipoint = 1, n_points_final_grid
r1(1) = final_grid_points(1,ipoint)
r1(2) = final_grid_points(2,ipoint)
r1(3) = final_grid_points(3,ipoint)
dx = r1(1) - r2(1)
dy = r1(2) - r2(2)
dz = r1(3) - r2(3)
x2 = dx * dx + dy * dy + dz * dz
if(x2 .lt. 1d-10) cycle
i_fit = 0.d0
do i = 1, n_max_fit_slat
expo = expo_gauss_j_mu_1_erf(i)
coef = coef_gauss_j_mu_1_erf(i)
i_fit += coef * dexp(-expo*x2)
enddo
i_fit = i_fit / dsqrt(x2)
tmp = j12_mu(r1, r2)
call grad1_j12_mu_exc(r1, r2, grad)
! ---
i_exc = tmp * grad(1)
i_num = i_fit * dx
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem on x in test_fit_ugradu on', ipoint
print *, ' analyt = ', i_exc
print *, ' numeri = ', i_num
print *, ' diff = ', acc_ij
endif
acc_tot += acc_ij
normalz += dabs(i_exc)
! ---
i_exc = tmp * grad(2)
i_num = i_fit * dy
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem on y in test_fit_ugradu on', ipoint
print *, ' analyt = ', i_exc
print *, ' numeri = ', i_num
print *, ' diff = ', acc_ij
endif
acc_tot += acc_ij
normalz += dabs(i_exc)
! ---
i_exc = tmp * grad(3)
i_num = i_fit * dz
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem on z in test_fit_ugradu on', ipoint
print *, ' analyt = ', i_exc
print *, ' numeri = ', i_num
print *, ' diff = ', acc_ij
endif
acc_tot += acc_ij
normalz += dabs(i_exc)
! ---
enddo
if( (acc_tot/normalz) .gt. 1d-3 ) then
print*, ' acc_tot = ', acc_tot
print*, ' normalz = ', normalz
endif
enddo
return
end subroutine test_fit_ugradu
! ---
subroutine test_fit_u()
implicit none
integer :: jpoint, ipoint, i
double precision :: i_exc, i_fit, i_num, x2
double precision :: r1(3), r2(3), dx, dy, dz
double precision :: eps_ij, acc_tot, acc_ij, normalz, coef, expo
double precision, external :: j12_mu
print*, ' test_fit_u ...'
eps_ij = 1d-3
do jpoint = 1, n_points_final_grid
r2(1) = final_grid_points(1,jpoint)
r2(2) = final_grid_points(2,jpoint)
r2(3) = final_grid_points(3,jpoint)
acc_tot = 0.d0
normalz = 0.d0
do ipoint = 1, n_points_final_grid
r1(1) = final_grid_points(1,ipoint)
r1(2) = final_grid_points(2,ipoint)
r1(3) = final_grid_points(3,ipoint)
dx = r1(1) - r2(1)
dy = r1(2) - r2(2)
dz = r1(3) - r2(3)
x2 = dx * dx + dy * dy + dz * dz
if(x2 .lt. 1d-10) cycle
i_fit = 0.d0
do i = 1, n_max_fit_slat
expo = expo_gauss_j_mu_x(i)
coef = coef_gauss_j_mu_x(i)
i_fit += coef * dexp(-expo*x2)
enddo
i_exc = j12_mu(r1, r2)
i_num = i_fit
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in test_fit_u on', ipoint
print *, ' analyt = ', i_exc
print *, ' numeri = ', i_num
print *, ' diff = ', acc_ij
endif
acc_tot += acc_ij
normalz += dabs(i_exc)
enddo
if( (acc_tot/normalz) .gt. 1d-3 ) then
print*, ' acc_tot = ', acc_tot
print*, ' normalz = ', normalz
endif
enddo
return
end subroutine test_fit_u
! ---
subroutine test_fit_u2()
implicit none
integer :: jpoint, ipoint, i
double precision :: i_exc, i_fit, i_num, x2
double precision :: r1(3), r2(3), dx, dy, dz, tmp
double precision :: eps_ij, acc_tot, acc_ij, normalz, coef, expo
double precision, external :: j12_mu
print*, ' test_fit_u2 ...'
eps_ij = 1d-3
do jpoint = 1, n_points_final_grid
r2(1) = final_grid_points(1,jpoint)
r2(2) = final_grid_points(2,jpoint)
r2(3) = final_grid_points(3,jpoint)
acc_tot = 0.d0
normalz = 0.d0
do ipoint = 1, n_points_final_grid
r1(1) = final_grid_points(1,ipoint)
r1(2) = final_grid_points(2,ipoint)
r1(3) = final_grid_points(3,ipoint)
dx = r1(1) - r2(1)
dy = r1(2) - r2(2)
dz = r1(3) - r2(3)
x2 = dx * dx + dy * dy + dz * dz
if(x2 .lt. 1d-10) cycle
i_fit = 0.d0
do i = 1, n_max_fit_slat
expo = expo_gauss_j_mu_x_2(i)
coef = coef_gauss_j_mu_x_2(i)
i_fit += coef * dexp(-expo*x2)
enddo
tmp = j12_mu(r1, r2)
i_exc = tmp * tmp
i_num = i_fit
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in test_fit_u2 on', ipoint
print *, ' analyt = ', i_exc
print *, ' numeri = ', i_num
print *, ' diff = ', acc_ij
endif
acc_tot += acc_ij
normalz += dabs(i_exc)
enddo
if( (acc_tot/normalz) .gt. 1d-3 ) then
print*, ' acc_tot = ', acc_tot
print*, ' normalz = ', normalz
endif
enddo
return
end subroutine test_fit_u2
! ---

601
src/non_h_ints_mu/debug_integ_jmu_modif.irp.f Normal file
View File

@ -0,0 +1,601 @@
! --
program debug_integ_jmu_modif
implicit none
my_grid_becke = .True.
!my_n_pt_r_grid = 30
!my_n_pt_a_grid = 50
!my_n_pt_r_grid = 100
!my_n_pt_a_grid = 170
my_n_pt_r_grid = 150
my_n_pt_a_grid = 194
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
PROVIDE mu_erf j1b_pen
call test_v_ij_u_cst_mu_j1b()
! call test_v_ij_erf_rk_cst_mu_j1b()
! call test_x_v_ij_erf_rk_cst_mu_j1b()
! call test_int2_u2_j1b2()
! call test_int2_grad1u2_grad2u2_j1b2()
! call test_int2_u_grad1u_total_j1b2()
!
! call test_int2_grad1_u12_ao()
!
! call test_grad12_j12()
! call test_u12sq_j1bsq()
! call test_u12_grad1_u12_j1b_grad1_j1b()
! !call test_gradu_squared_u_ij_mu()
end
! ---
subroutine test_v_ij_u_cst_mu_j1b()
implicit none
integer :: i, j, ipoint
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
double precision, external :: num_v_ij_u_cst_mu_j1b
print*, ' test_v_ij_u_cst_mu_j1b ...'
PROVIDE v_ij_u_cst_mu_j1b
eps_ij = 1d-3
acc_tot = 0.d0
normalz = 0.d0
!do ipoint = 1, 10
do ipoint = 1, n_points_final_grid
do j = 1, ao_num
do i = 1, ao_num
i_exc = v_ij_u_cst_mu_j1b(i,j,ipoint)
i_num = num_v_ij_u_cst_mu_j1b(i,j,ipoint)
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in v_ij_u_cst_mu_j1b on', i, j, ipoint
print *, ' analyt integ = ', i_exc
print *, ' numeri integ = ', i_num
print *, ' diff = ', acc_ij
endif
acc_tot += acc_ij
normalz += dabs(i_num)
enddo
enddo
enddo
print*, ' acc_tot = ', acc_tot
print*, ' normalz = ', normalz
return
end subroutine test_v_ij_u_cst_mu_j1b
! ---
subroutine test_v_ij_erf_rk_cst_mu_j1b()
implicit none
integer :: i, j, ipoint
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
double precision, external :: num_v_ij_erf_rk_cst_mu_j1b
print*, ' test_v_ij_erf_rk_cst_mu_j1b ...'
PROVIDE v_ij_erf_rk_cst_mu_j1b
eps_ij = 1d-3
acc_tot = 0.d0
normalz = 0.d0
!do ipoint = 1, 10
do ipoint = 1, n_points_final_grid
do j = 1, ao_num
do i = 1, ao_num
i_exc = v_ij_erf_rk_cst_mu_j1b(i,j,ipoint)
i_num = num_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint)
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in v_ij_erf_rk_cst_mu_j1b on', i, j, ipoint
print *, ' analyt integ = ', i_exc
print *, ' numeri integ = ', i_num
print *, ' diff = ', acc_ij
endif
acc_tot += acc_ij
normalz += dabs(i_num)
enddo
enddo
enddo
print*, ' acc_tot = ', acc_tot
print*, ' normalz = ', normalz
return
end subroutine test_v_ij_erf_rk_cst_mu_j1b
! ---
subroutine test_x_v_ij_erf_rk_cst_mu_j1b()
implicit none
integer :: i, j, ipoint
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
double precision :: integ(3)
print*, ' test_x_v_ij_erf_rk_cst_mu_j1b ...'
PROVIDE x_v_ij_erf_rk_cst_mu_j1b
eps_ij = 1d-3
acc_tot = 0.d0
normalz = 0.d0
!do ipoint = 1, 10
do ipoint = 1, n_points_final_grid
do j = 1, ao_num
do i = 1, ao_num
call num_x_v_ij_erf_rk_cst_mu_j1b(i, j, ipoint, integ)
i_exc = x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,1)
i_num = integ(1)
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in x part of x_v_ij_erf_rk_cst_mu_j1b on', i, j, ipoint
print *, ' analyt integ = ', i_exc
print *, ' numeri integ = ', i_num
print *, ' diff = ', acc_ij
endif
acc_tot += acc_ij
normalz += dabs(i_num)
i_exc = x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,2)
i_num = integ(2)
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in y part of x_v_ij_erf_rk_cst_mu_j1b on', i, j, ipoint
print *, ' analyt integ = ', i_exc
print *, ' numeri integ = ', i_num
print *, ' diff = ', acc_ij
endif
acc_tot += acc_ij
normalz += dabs(i_num)
i_exc = x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,3)
i_num = integ(3)
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in z part of x_v_ij_erf_rk_cst_mu_j1b on', i, j, ipoint
print *, ' analyt integ = ', i_exc
print *, ' numeri integ = ', i_num
print *, ' diff = ', acc_ij
endif
acc_tot += acc_ij
normalz += dabs(i_num)
enddo
enddo
enddo
print*, ' acc_tot = ', acc_tot
print*, ' normalz = ', normalz
return
end subroutine test_x_v_ij_erf_rk_cst_mu_j1b
! ---
subroutine test_int2_u2_j1b2()
implicit none
integer :: i, j, ipoint
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
double precision, external :: num_int2_u2_j1b2
print*, ' test_int2_u2_j1b2 ...'
PROVIDE int2_u2_j1b2
eps_ij = 1d-3
acc_tot = 0.d0
normalz = 0.d0
!do ipoint = 1, 10
do ipoint = 1, n_points_final_grid
do j = 1, ao_num
do i = 1, ao_num
i_exc = int2_u2_j1b2(i,j,ipoint)
i_num = num_int2_u2_j1b2(i,j,ipoint)
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in int2_u2_j1b2 on', i, j, ipoint
print *, ' analyt integ = ', i_exc
print *, ' numeri integ = ', i_num
print *, ' diff = ', acc_ij
endif
acc_tot += acc_ij
normalz += dabs(i_num)
enddo
enddo
enddo
acc_tot = acc_tot / normalz
print*, ' acc_tot = ', acc_tot
print*, ' normalz = ', normalz
return
end subroutine test_int2_u2_j1b2
! ---
subroutine test_int2_grad1u2_grad2u2_j1b2()
implicit none
integer :: i, j, ipoint
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
double precision, external :: num_int2_grad1u2_grad2u2_j1b2
print*, ' test_int2_grad1u2_grad2u2_j1b2 ...'
PROVIDE int2_grad1u2_grad2u2_j1b2
eps_ij = 1d-3
acc_tot = 0.d0
normalz = 0.d0
!do ipoint = 1, 10
do ipoint = 1, n_points_final_grid
do j = 1, ao_num
do i = 1, ao_num
i_exc = int2_grad1u2_grad2u2_j1b2(i,j,ipoint)
i_num = num_int2_grad1u2_grad2u2_j1b2(i,j,ipoint)
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in int2_grad1u2_grad2u2_j1b2 on', i, j, ipoint
print *, ' analyt integ = ', i_exc
print *, ' numeri integ = ', i_num
print *, ' diff = ', acc_ij
endif
acc_tot += acc_ij
normalz += dabs(i_num)
enddo
enddo
enddo
print*, ' acc_tot = ', acc_tot
print*, ' normalz = ', normalz
return
end subroutine test_int2_grad1u2_grad2u2_j1b2
! ---
subroutine test_int2_grad1_u12_ao()
implicit none
integer :: i, j, ipoint
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
double precision :: integ(3)
print*, ' test_int2_grad1_u12_ao ...'
PROVIDE int2_grad1_u12_ao
eps_ij = 1d-3
acc_tot = 0.d0
normalz = 0.d0
do ipoint = 1, n_points_final_grid
do j = 1, ao_num
do i = 1, ao_num
call num_int2_grad1_u12_ao(i, j, ipoint, integ)
i_exc = int2_grad1_u12_ao(1,i,j,ipoint)
i_num = integ(1)
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in x part of int2_grad1_u12_ao on', i, j, ipoint
print *, ' analyt integ = ', i_exc
print *, ' numeri integ = ', i_num
print *, ' diff = ', acc_ij
endif
acc_tot += acc_ij
normalz += dabs(i_num)
i_exc = int2_grad1_u12_ao(2,i,j,ipoint)
i_num = integ(2)
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in y part of int2_grad1_u12_ao on', i, j, ipoint
print *, ' analyt integ = ', i_exc
print *, ' numeri integ = ', i_num
print *, ' diff = ', acc_ij
endif
acc_tot += acc_ij
normalz += dabs(i_num)
i_exc = int2_grad1_u12_ao(3,i,j,ipoint)
i_num = integ(3)
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in z part of int2_grad1_u12_ao on', i, j, ipoint
print *, ' analyt integ = ', i_exc
print *, ' numeri integ = ', i_num
print *, ' diff = ', acc_ij
endif
acc_tot += acc_ij
normalz += dabs(i_num)
enddo
enddo
enddo
print*, ' acc_tot = ', acc_tot
print*, ' normalz = ', normalz
return
end subroutine test_int2_grad1_u12_ao
! ---
subroutine test_int2_u_grad1u_total_j1b2()
implicit none
integer :: i, j, ipoint
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
double precision :: x, y, z
double precision :: integ(3)
print*, ' test_int2_u_grad1u_total_j1b2 ...'
PROVIDE int2_u_grad1u_j1b2
PROVIDE int2_u_grad1u_x_j1b2
eps_ij = 1d-3
acc_tot = 0.d0
normalz = 0.d0
!do ipoint = 1, 10
do ipoint = 1, n_points_final_grid
x = final_grid_points(1,ipoint)
y = final_grid_points(2,ipoint)
z = final_grid_points(3,ipoint)
do j = 1, ao_num
do i = 1, ao_num
call num_int2_u_grad1u_total_j1b2(i, j, ipoint, integ)
i_exc = x * int2_u_grad1u_j1b2(i,j,ipoint) - int2_u_grad1u_x_j1b2(1,i,j,ipoint)
i_num = integ(1)
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in x part of int2_u_grad1u_total_j1b2 on', i, j, ipoint
print *, ' analyt integ = ', i_exc
print *, ' numeri integ = ', i_num
print *, ' diff = ', acc_ij
endif
acc_tot += acc_ij
normalz += dabs(i_num)
i_exc = y * int2_u_grad1u_j1b2(i,j,ipoint) - int2_u_grad1u_x_j1b2(2,i,j,ipoint)
i_num = integ(2)
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in y part of int2_u_grad1u_total_j1b2 on', i, j, ipoint
print *, ' analyt integ = ', i_exc
print *, ' numeri integ = ', i_num
print *, ' diff = ', acc_ij
endif
acc_tot += acc_ij
normalz += dabs(i_num)
i_exc = z * int2_u_grad1u_j1b2(i,j,ipoint) - int2_u_grad1u_x_j1b2(3,i,j,ipoint)
i_num = integ(3)
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in z part of int2_u_grad1u_total_j1b2 on', i, j, ipoint
print *, ' analyt integ = ', i_exc
print *, ' numeri integ = ', i_num
print *, ' diff = ', acc_ij
endif
acc_tot += acc_ij
normalz += dabs(i_num)
enddo
enddo
enddo
print*, ' acc_tot = ', acc_tot
print*, ' normalz = ', normalz
return
end subroutine test_int2_u_grad1u_total_j1b2
! ---
subroutine test_gradu_squared_u_ij_mu()
implicit none
integer :: i, j, ipoint
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
double precision, external :: num_gradu_squared_u_ij_mu
print*, ' test_gradu_squared_u_ij_mu ...'
PROVIDE gradu_squared_u_ij_mu
eps_ij = 1d-3
acc_tot = 0.d0
normalz = 0.d0
do ipoint = 1, n_points_final_grid
do j = 1, ao_num
do i = 1, ao_num
i_exc = gradu_squared_u_ij_mu(i,j,ipoint)
i_num = num_gradu_squared_u_ij_mu(i, j, ipoint)
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in gradu_squared_u_ij_mu on', i, j, ipoint
print *, ' analyt integ = ', i_exc
print *, ' numeri integ = ', i_num
print *, ' diff = ', acc_ij
endif
acc_tot += acc_ij
normalz += dabs(i_num)
enddo
enddo
enddo
print*, ' acc_tot = ', acc_tot
print*, ' normalz = ', normalz
return
end subroutine test_gradu_squared_u_ij_mu
! ---
subroutine test_grad12_j12()
implicit none
integer :: i, j, ipoint
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
double precision, external :: num_grad12_j12
print*, ' test_grad12_j12 ...'
PROVIDE grad12_j12
eps_ij = 1d-3
acc_tot = 0.d0
normalz = 0.d0
do ipoint = 1, n_points_final_grid
do j = 1, ao_num
do i = 1, ao_num
i_exc = grad12_j12(i,j,ipoint)
i_num = num_grad12_j12(i, j, ipoint)
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in grad12_j12 on', i, j, ipoint
print *, ' analyt integ = ', i_exc
print *, ' numeri integ = ', i_num
print *, ' diff = ', acc_ij
endif
acc_tot += acc_ij
normalz += dabs(i_num)
enddo
enddo
enddo
print*, ' acc_tot = ', acc_tot
print*, ' normalz = ', normalz
return
end subroutine test_grad12_j12
! ---
subroutine test_u12sq_j1bsq()
implicit none
integer :: i, j, ipoint
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
double precision, external :: num_u12sq_j1bsq
print*, ' test_u12sq_j1bsq ...'
PROVIDE u12sq_j1bsq
eps_ij = 1d-3
acc_tot = 0.d0
normalz = 0.d0
do ipoint = 1, n_points_final_grid
do j = 1, ao_num
do i = 1, ao_num
i_exc = u12sq_j1bsq(i,j,ipoint)
i_num = num_u12sq_j1bsq(i, j, ipoint)
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in u12sq_j1bsq on', i, j, ipoint
print *, ' analyt integ = ', i_exc
print *, ' numeri integ = ', i_num
print *, ' diff = ', acc_ij
endif
acc_tot += acc_ij
normalz += dabs(i_num)
enddo
enddo
enddo
print*, ' acc_tot = ', acc_tot
print*, ' normalz = ', normalz
return
end subroutine test_u12sq_j1bsq
! ---
subroutine test_u12_grad1_u12_j1b_grad1_j1b()
implicit none
integer :: i, j, ipoint
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
double precision, external :: num_u12_grad1_u12_j1b_grad1_j1b
print*, ' test_u12_grad1_u12_j1b_grad1_j1b ...'
PROVIDE u12_grad1_u12_j1b_grad1_j1b
eps_ij = 1d-3
acc_tot = 0.d0
normalz = 0.d0
do ipoint = 1, n_points_final_grid
do j = 1, ao_num
do i = 1, ao_num
i_exc = u12_grad1_u12_j1b_grad1_j1b(i,j,ipoint)
i_num = num_u12_grad1_u12_j1b_grad1_j1b(i, j, ipoint)
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in u12_grad1_u12_j1b_grad1_j1b on', i, j, ipoint
print *, ' analyt integ = ', i_exc
print *, ' numeri integ = ', i_num
print *, ' diff = ', acc_ij
endif
acc_tot += acc_ij
normalz += dabs(i_num)
enddo
enddo
enddo
print*, ' acc_tot = ', acc_tot
print*, ' normalz = ', normalz
return
end subroutine test_u12_grad1_u12_j1b_grad1_j1b,
! ---

91
src/non_h_ints_mu/fit_j.irp.f
View File

@ -1,91 +0,0 @@
BEGIN_PROVIDER [ double precision, expo_j_xmu, (n_fit_1_erf_x) ]
implicit none
BEGIN_DOC
! F(x) = x * (1 - erf(x)) - 1/sqrt(pi) * exp(-x**2) is fitted with a gaussian and a Slater
!
! \approx - 1/sqrt(pi) * exp(-alpha * x ) exp(-beta * x**2)
!
! where alpha = expo_j_xmu(1) and beta = expo_j_xmu(2)
END_DOC
expo_j_xmu(1) = 1.7477d0
expo_j_xmu(2) = 0.668662d0
END_PROVIDER
BEGIN_PROVIDER [double precision, expo_gauss_j_mu_x, (n_max_fit_slat)]
&BEGIN_PROVIDER [double precision, coef_gauss_j_mu_x, (n_max_fit_slat)]
implicit none
BEGIN_DOC
! J(mu,r12) = 1/2 r12 * (1 - erf(mu*r12)) - 1/(2 sqrt(pi)*mu) exp(-(mu*r12)^2) is expressed as
!
! J(mu,r12) = 0.5/mu * F(r12*mu) where F(x) = x * (1 - erf(x)) - 1/sqrt(pi) * exp(-x**2)
!
! F(x) is fitted by - 1/sqrt(pi) * exp(-alpha * x) exp(-beta * x^2) (see expo_j_xmu)
!
! The slater function exp(-alpha * x) is fitted with n_max_fit_slat gaussians
!
! See Appendix 2 of JCP 154, 084119 (2021)
!
END_DOC
integer :: i
double precision :: expos(n_max_fit_slat),alpha,beta
alpha = expo_j_xmu(1) * mu_erf
call expo_fit_slater_gam(alpha,expos)
beta = expo_j_xmu(2) * mu_erf**2.d0
do i = 1, n_max_fit_slat
expo_gauss_j_mu_x(i) = expos(i) + beta
coef_gauss_j_mu_x(i) = coef_fit_slat_gauss(i) / (2.d0 * mu_erf) * (- 1/dsqrt(dacos(-1.d0)))
enddo
END_PROVIDER
double precision function F_x_j(x)
implicit none
BEGIN_DOC
! F_x_j(x) = dimension-less correlation factor = x (1 - erf(x)) - 1/sqrt(pi) exp(-x^2)
END_DOC
double precision, intent(in) :: x
F_x_j = x * (1.d0 - derf(x)) - 1/dsqrt(dacos(-1.d0)) * dexp(-x**2)
end
double precision function j_mu_F_x_j(x)
implicit none
BEGIN_DOC
! j_mu_F_x_j(x) = correlation factor = 1/2 r12 * (1 - erf(mu*r12)) - 1/(2 sqrt(pi)*mu) exp(-(mu*r12)^2)
!
! = 1/(2*mu) * F_x_j(mu*x)
END_DOC
double precision :: F_x_j
double precision, intent(in) :: x
j_mu_F_x_j = 0.5d0/mu_erf * F_x_j(x*mu_erf)
end
double precision function j_mu(x)
implicit none
double precision, intent(in) :: x
BEGIN_DOC
! j_mu(x) = correlation factor = 1/2 r12 * (1 - erf(mu*r12)) - 1/(2 sqrt(pi)*mu) exp(-(mu*r12)^2)
END_DOC
j_mu = 0.5d0* x * (1.d0 - derf(mu_erf*x)) - 0.5d0/( dsqrt(dacos(-1.d0))*mu_erf) * dexp(-(mu_erf*x)*(mu_erf*x))
end
double precision function j_mu_fit_gauss(x)
implicit none
BEGIN_DOC
! j_mu_fit_gauss(x) = correlation factor = 1/2 r12 * (1 - erf(mu*r12)) - 1/(2 sqrt(pi)*mu) exp(-(mu*r12)^2)
!
! but fitted with gaussians
END_DOC
double precision, intent(in) :: x
integer :: i
double precision :: alpha,coef
j_mu_fit_gauss = 0.d0
do i = 1, n_max_fit_slat
alpha = expo_gauss_j_mu_x(i)
coef = coef_gauss_j_mu_x(i)
j_mu_fit_gauss += coef_gauss_j_mu_x(i) * dexp(-expo_gauss_j_mu_x(i)*x*x)
enddo
end

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

@ -1,36 +1,159 @@
BEGIN_PROVIDER [ double precision, grad_1_squared_u_ij_mu, ( ao_num, ao_num,n_points_final_grid)]
implicit none
integer :: ipoint,i,j,m,igauss
BEGIN_DOC
! grad_1_squared_u_ij_mu(j,i,ipoint) = -1/2 \int dr2 phi_j(r2) phi_i(r2) |\grad_r1 u(r1,r2,\mu)|^2
! |\grad_r1 u(r1,r2,\mu)|^2 = 1/4 * (1 - erf(mu*r12))^2
! ! (1 - erf(mu*r12))^2 = \sum_i coef_gauss_1_erf_x_2(i) * exp(-expo_gauss_1_erf_x_2(i) * r12^2)
END_DOC
double precision :: r(3),delta,coef
double precision :: overlap_gauss_r12_ao,time0,time1
print*,'providing grad_1_squared_u_ij_mu ...'
call wall_time(time0)
!TODO : strong optmization : write the loops in a different way
! : for each couple of AO, the gaussian product are done once for all
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)
do j = 1, ao_num
do i = 1, ao_num
! \int dr2 phi_j(r2) phi_i(r2) (1 - erf(mu*r12))^2
! = \sum_i coef_gauss_1_erf_x_2(i) \int dr2 phi_j(r2) phi_i(r2) exp(-expo_gauss_1_erf_x_2(i) * (r_1 - r_2)^2)
do igauss = 1, n_max_fit_slat
delta = expo_gauss_1_erf_x_2(igauss)
coef = coef_gauss_1_erf_x_2(igauss)
grad_1_squared_u_ij_mu(j,i,ipoint) += -0.25 * coef * overlap_gauss_r12_ao(r,delta,i,j)
! ---
! TODO : strong optmization : write the loops in a different way
! : for each couple of AO, the gaussian product are done once for all
BEGIN_PROVIDER [ double precision, gradu_squared_u_ij_mu, (ao_num, ao_num, n_points_final_grid) ]
BEGIN_DOC
!
! if J(r1,r2) = u12:
!
! gradu_squared_u_ij_mu = -0.50 x \int r2 [ (grad_1 u12)^2 + (grad_2 u12^2)] \phi_i(2) \phi_j(2)
! = -0.25 x \int r2 (1 - erf(mu*r12))^2 \phi_i(2) \phi_j(2)
! and
! (1 - erf(mu*r12))^2 = \sum_i coef_gauss_1_erf_x_2(i) * exp(-expo_gauss_1_erf_x_2(i) * r12^2)
!
! if J(r1,r2) = u12 x v1 x v2
!
! gradu_squared_u_ij_mu = -0.50 x \int r2 \phi_i(2) \phi_j(2) [ v1^2 v2^2 ((grad_1 u12)^2 + (grad_2 u12^2)]) + u12^2 v2^2 (grad_1 v1)^2 + 2 u12 v1 v2^2 (grad_1 u12) . (grad_1 v1) ]
! = -0.25 x v1^2 \int r2 \phi_i(2) \phi_j(2) [1 - erf(mu r12)]^2 v2^2
! + -0.50 x (grad_1 v1)^2 \int r2 \phi_i(2) \phi_j(2) u12^2 v2^2
! + -1.00 x v1 (grad_1 v1) \int r2 \phi_i(2) \phi_j(2) (grad_1 u12) v2^2
! = v1^2 x int2_grad1u2_grad2u2_j1b2
! + -0.5 x (grad_1 v1)^2 x int2_u2_j1b2
! + -1.0 X V1 x (grad_1 v1) \cdot [ int2_u_grad1u_j1b2 x r - int2_u_grad1u_x_j1b ]
!
!
END_DOC
implicit none
integer :: ipoint, i, j, m, igauss
double precision :: x, y, z, r(3), delta, coef
double precision :: tmp_v, tmp_x, tmp_y, tmp_z
double precision :: tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7, tmp8, tmp9
double precision :: time0, time1
double precision, external :: overlap_gauss_r12_ao
print*, ' providing gradu_squared_u_ij_mu ...'
call wall_time(time0)
PROVIDE j1b_type
if(j1b_type .eq. 3) then
do ipoint = 1, n_points_final_grid
x = final_grid_points(1,ipoint)
y = final_grid_points(2,ipoint)
z = final_grid_points(3,ipoint)
tmp_v = v_1b (ipoint)
tmp_x = v_1b_grad(1,ipoint)
tmp_y = v_1b_grad(2,ipoint)
tmp_z = v_1b_grad(3,ipoint)
tmp1 = tmp_v * tmp_v
tmp2 = -0.5d0 * (tmp_x * tmp_x + tmp_y * tmp_y + tmp_z * tmp_z)
tmp3 = tmp_v * tmp_x
tmp4 = tmp_v * tmp_y
tmp5 = tmp_v * tmp_z
tmp6 = -x * tmp3
tmp7 = -y * tmp4
tmp8 = -z * tmp5
do j = 1, ao_num
do i = 1, ao_num
tmp9 = int2_u_grad1u_j1b2(i,j,ipoint)
gradu_squared_u_ij_mu(i,j,ipoint) = tmp1 * int2_grad1u2_grad2u2_j1b2(i,j,ipoint) &
+ tmp2 * int2_u2_j1b2 (i,j,ipoint) &
+ tmp6 * tmp9 + tmp3 * int2_u_grad1u_x_j1b2(1,i,j,ipoint) &
+ tmp7 * tmp9 + tmp4 * int2_u_grad1u_x_j1b2(2,i,j,ipoint) &
+ tmp8 * tmp9 + tmp5 * int2_u_grad1u_x_j1b2(3,i,j,ipoint)
enddo
enddo
enddo
enddo
enddo
enddo
call wall_time(time1)
print*,'Wall time for grad_1_squared_u_ij_mu = ',time1 - time0
END_PROVIDER
else
gradu_squared_u_ij_mu = 0.d0
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)
do j = 1, ao_num
do i = 1, ao_num
do igauss = 1, n_max_fit_slat
delta = expo_gauss_1_erf_x_2(igauss)
coef = coef_gauss_1_erf_x_2(igauss)
gradu_squared_u_ij_mu(i,j,ipoint) += -0.25d0 * coef * overlap_gauss_r12_ao(r, delta, i, j)
enddo
enddo
enddo
enddo
endif
call wall_time(time1)
print*, ' Wall time for gradu_squared_u_ij_mu = ', time1 - time0
END_PROVIDER
! ---
!BEGIN_PROVIDER [double precision, tc_grad_square_ao, (ao_num, ao_num, ao_num, ao_num)]
!
! BEGIN_DOC
! !
! ! tc_grad_square_ao(k,i,l,j) = -1/2 <kl | |\grad_1 u(r1,r2)|^2 + |\grad_1 u(r1,r2)|^2 | ij>
! !
! END_DOC
!
! implicit none
! integer :: ipoint, i, j, k, l
! double precision :: weight1, ao_ik_r, ao_i_r
! double precision, allocatable :: ac_mat(:,:,:,:)
!
! allocate(ac_mat(ao_num,ao_num,ao_num,ao_num))
! ac_mat = 0.d0
!
! do ipoint = 1, n_points_final_grid
! weight1 = final_weight_at_r_vector(ipoint)
!
! do i = 1, ao_num
! ao_i_r = weight1 * aos_in_r_array_transp(ipoint,i)
!
! do k = 1, ao_num
! ao_ik_r = ao_i_r * aos_in_r_array_transp(ipoint,k)
!
! do j = 1, ao_num
! do l = 1, ao_num
! ac_mat(k,i,l,j) += ao_ik_r * gradu_squared_u_ij_mu(l,j,ipoint)
! enddo
! enddo
! enddo
! enddo
! enddo
!
! 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)
! !write(11,*) tc_grad_square_ao(k,i,l,j)
! enddo
! enddo
! enddo
! enddo
!
! deallocate(ac_mat)
!
!END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, grad_1_squared_u_ij_mu_new, (n_points_final_grid, ao_num, ao_num)]
implicit none
@ -130,40 +253,189 @@
BEGIN_PROVIDER [double precision, tc_grad_square_ao, (ao_num, ao_num, ao_num, ao_num)]
implicit none
BEGIN_DOC
! tc_grad_square_ao(k,i,l,j) = -1/2 <kl | |\grad_1 u(r1,r2)|^2 + |\grad_1 u(r1,r2)|^2 | ij>
!
END_DOC
integer :: ipoint,i,j,k,l
double precision :: contrib,weight1
double precision, allocatable :: ac_mat(:,:,:,:)
allocate(ac_mat(ao_num, ao_num, ao_num, ao_num))
ac_mat = 0.d0
BEGIN_DOC
!
! tc_grad_square_ao(k,i,l,j) = -1/2 <kl | |\grad_1 u(r1,r2)|^2 + |\grad_1 u(r1,r2)|^2 | ij>
!
END_DOC
implicit none
integer :: ipoint, i, j, k, l
double precision :: weight1, ao_ik_r, ao_i_r
double precision, allocatable :: ac_mat(:,:,:,:), bc_mat(:,:,:,:)
allocate(ac_mat(ao_num,ao_num,ao_num,ao_num))
ac_mat = 0.d0
allocate(bc_mat(ao_num,ao_num,ao_num,ao_num))
bc_mat = 0.d0
do ipoint = 1, n_points_final_grid
weight1 = final_weight_at_r_vector(ipoint)
do j = 1, ao_num
do l = 1, ao_num
do i = 1, ao_num
weight1 = final_weight_at_r_vector(ipoint)
do i = 1, ao_num
ao_i_r = weight1 * aos_in_r_array_transp(ipoint,i)
do k = 1, ao_num
contrib = weight1 *0.5D0* (aos_in_r_array_transp(ipoint,k) * aos_in_r_array_transp(ipoint,i))
! \int dr1 phi_k(r1) phi_i(r1) . \int dr2 |\grad_1 u(r1,r2)|^2 \phi_l(r2) \phi_j(r2)
ac_mat(k,i,l,j) += grad_1_squared_u_ij_mu(l,j,ipoint) * contrib
ao_ik_r = ao_i_r * aos_in_r_array_transp(ipoint,k)
do j = 1, ao_num
do l = 1, ao_num
ac_mat(k,i,l,j) += ao_ik_r * ( u12sq_j1bsq(l,j,ipoint) + u12_grad1_u12_j1b_grad1_j1b(l,j,ipoint) )
bc_mat(k,i,l,j) += ao_ik_r * grad12_j12(l,j,ipoint)
enddo
enddo
enddo
enddo
enddo
enddo
enddo
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)
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) + bc_mat(k,i,l,j)
enddo
enddo
enddo
enddo
enddo
enddo
deallocate(ac_mat)
deallocate(bc_mat)
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, grad12_j12, (ao_num, ao_num, n_points_final_grid) ]
implicit none
integer :: ipoint, i, j, m, igauss
double precision :: r(3), delta, coef
double precision :: tmp1
double precision :: time0, time1
double precision, external :: overlap_gauss_r12_ao
print*, ' providing grad12_j12 ...'
call wall_time(time0)
PROVIDE j1b_type
if(j1b_type .eq. 3) then
do ipoint = 1, n_points_final_grid
tmp1 = v_1b(ipoint)
tmp1 = tmp1 * tmp1
do j = 1, ao_num
do i = 1, ao_num
grad12_j12(i,j,ipoint) = tmp1 * int2_grad1u2_grad2u2_j1b2(i,j,ipoint)
enddo
enddo
enddo
else
grad12_j12 = 0.d0
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)
do j = 1, ao_num
do i = 1, ao_num
do igauss = 1, n_max_fit_slat
delta = expo_gauss_1_erf_x_2(igauss)
coef = coef_gauss_1_erf_x_2(igauss)
grad12_j12(i,j,ipoint) += -0.25d0 * coef * overlap_gauss_r12_ao(r, delta, i, j)
enddo
enddo
enddo
enddo
endif
call wall_time(time1)
print*, ' Wall time for grad12_j12 = ', time1 - time0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, u12sq_j1bsq, (ao_num, ao_num, n_points_final_grid) ]
implicit none
integer :: ipoint, i, j
double precision :: tmp_x, tmp_y, tmp_z
double precision :: tmp1
double precision :: time0, time1
print*, ' providing u12sq_j1bsq ...'
call wall_time(time0)
do ipoint = 1, n_points_final_grid
tmp_x = v_1b_grad(1,ipoint)
tmp_y = v_1b_grad(2,ipoint)
tmp_z = v_1b_grad(3,ipoint)
tmp1 = -0.5d0 * (tmp_x * tmp_x + tmp_y * tmp_y + tmp_z * tmp_z)
do j = 1, ao_num
do i = 1, ao_num
u12sq_j1bsq(i,j,ipoint) = tmp1 * int2_u2_j1b2(i,j,ipoint)
enddo
enddo
enddo
call wall_time(time1)
print*, ' Wall time for u12sq_j1bsq = ', time1 - time0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, u12_grad1_u12_j1b_grad1_j1b, (ao_num, ao_num, n_points_final_grid) ]
implicit none
integer :: ipoint, i, j, m, igauss
double precision :: x, y, z
double precision :: tmp_v, tmp_x, tmp_y, tmp_z
double precision :: tmp3, tmp4, tmp5, tmp6, tmp7, tmp8, tmp9
double precision :: time0, time1
double precision, external :: overlap_gauss_r12_ao
print*, ' providing u12_grad1_u12_j1b_grad1_j1b ...'
call wall_time(time0)
do ipoint = 1, n_points_final_grid
x = final_grid_points(1,ipoint)
y = final_grid_points(2,ipoint)
z = final_grid_points(3,ipoint)
tmp_v = v_1b (ipoint)
tmp_x = v_1b_grad(1,ipoint)
tmp_y = v_1b_grad(2,ipoint)
tmp_z = v_1b_grad(3,ipoint)
tmp3 = tmp_v * tmp_x
tmp4 = tmp_v * tmp_y
tmp5 = tmp_v * tmp_z
tmp6 = -x * tmp3
tmp7 = -y * tmp4
tmp8 = -z * tmp5
do j = 1, ao_num
do i = 1, ao_num
tmp9 = int2_u_grad1u_j1b2(i,j,ipoint)
u12_grad1_u12_j1b_grad1_j1b(i,j,ipoint) = tmp6 * tmp9 + tmp3 * int2_u_grad1u_x_j1b2(1,i,j,ipoint) &
+ tmp7 * tmp9 + tmp4 * int2_u_grad1u_x_j1b2(2,i,j,ipoint) &
+ tmp8 * tmp9 + tmp5 * int2_u_grad1u_x_j1b2(3,i,j,ipoint)
enddo
enddo
enddo
call wall_time(time1)
print*, ' Wall time for u12_grad1_u12_j1b_grad1_j1b = ', time1 - time0
END_PROVIDER
! ---

290
src/non_h_ints_mu/grad_tc_int.irp.f
View File

@ -1,67 +1,75 @@
! ---
BEGIN_PROVIDER [double precision, ao_non_hermit_term_chemist, (ao_num, ao_num, ao_num, ao_num)]
implicit none
BEGIN_DOC
! 1 1 2 2 1 2 1 2
!
! ao_non_hermit_term_chemist(k,i,l,j) = < k l | [erf( mu r12) - 1] d/d_r12 | i j > on the AO basis
END_DOC
integer :: i,j,k,l,ipoint,m
double precision :: weight1,thr,r(3)
thr = 1.d-8
double precision, allocatable :: b_mat(:,:,:,:),ac_mat(:,:,:,:)
! provide v_ij_erf_rk_cst_mu
provide v_ij_erf_rk_cst_mu x_v_ij_erf_rk_cst_mu
! ao_non_hermit_term_chemist = non_h_ints
! return
BEGIN_DOC
! 1 1 2 2 1 2 1 2
!
! ao_non_hermit_term_chemist(k,i,l,j) = < k l | [erf( mu r12) - 1] d/d_r12 | i j > on the AO basis
!
END_DOC
implicit none
integer :: i, j, k, l, ipoint, m
double precision :: weight1, r(3)
double precision :: wall1, wall0
double precision, allocatable :: b_mat(:,:,:,:), ac_mat(:,:,:,:)
provide v_ij_erf_rk_cst_mu x_v_ij_erf_rk_cst_mu
call wall_time(wall0)
allocate(b_mat(n_points_final_grid,ao_num,ao_num,3),ac_mat(ao_num, ao_num, ao_num, ao_num))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
allocate(b_mat(n_points_final_grid,ao_num,ao_num,3), ac_mat(ao_num,ao_num,ao_num,ao_num))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,k,m,ipoint,r,weight1) &
!$OMP SHARED (aos_in_r_array_transp,aos_grad_in_r_array_transp_bis,b_mat)&
!$OMP SHARED (ao_num,n_points_final_grid,final_grid_points,final_weight_at_r_vector)
!$OMP DO SCHEDULE (static)
do m = 1, 3
do i = 1, ao_num
do k = 1, ao_num
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)
weight1 = final_weight_at_r_vector(ipoint)
b_mat(ipoint,k,i,m) = 0.5d0 * aos_in_r_array_transp(ipoint,k) * r(m) * weight1 * aos_grad_in_r_array_transp_bis(ipoint,i,m)
do m = 1, 3
do i = 1, ao_num
do k = 1, ao_num
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)
weight1 = final_weight_at_r_vector(ipoint)
b_mat(ipoint,k,i,m) = 0.5d0 * aos_in_r_array_transp(ipoint,k) * r(m) * weight1 * aos_grad_in_r_array_transp_bis(ipoint,i,m)
enddo
enddo
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
! (A) b_mat(ipoint,k,i,m) X v_ij_erf_rk_cst_mu(j,l,r1)
! 1/2 \int dr1 x1 phi_k(1) d/dx1 phi_i(1) \int dr2 (1 - erf(mu_r12))/r12 phi_j(2) phi_l(2)
! (A) b_mat(ipoint,k,i,m) X v_ij_erf_rk_cst_mu(j,l,r1)
! 1/2 \int dr1 x1 phi_k(1) d/dx1 phi_i(1) \int dr2 (1 - erf(mu_r12))/r12 phi_j(2) phi_l(2)
ac_mat = 0.d0
do m = 1, 3
! A B^T dim(A,1) dim(B,2) dim(A,2) alpha * A LDA
call dgemm("N","N",ao_num*ao_num,ao_num*ao_num,n_points_final_grid,1.d0,v_ij_erf_rk_cst_mu(1,1,1),ao_num*ao_num &
,b_mat(1,1,1,m),n_points_final_grid,1.d0,ac_mat,ao_num*ao_num)
! A B^T dim(A,1) dim(B,2) dim(A,2) alpha * A LDA
call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
, v_ij_erf_rk_cst_mu(1,1,1), ao_num*ao_num, b_mat(1,1,1,m), n_points_final_grid &
, 1.d0, ac_mat, ao_num*ao_num)
enddo
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,k,m,ipoint,weight1) &
!$OMP SHARED (aos_in_r_array_transp,aos_grad_in_r_array_transp_bis,b_mat,ao_num,n_points_final_grid,final_weight_at_r_vector)
!$OMP DO SCHEDULE (static)
do m = 1, 3
do i = 1, ao_num
do k = 1, ao_num
do ipoint = 1, n_points_final_grid
weight1 = final_weight_at_r_vector(ipoint)
b_mat(ipoint,k,i,m) = 0.5d0 * aos_in_r_array_transp(ipoint,k) * weight1 * aos_grad_in_r_array_transp_bis(ipoint,i,m)
do m = 1, 3
do i = 1, ao_num
do k = 1, ao_num
do ipoint = 1, n_points_final_grid
weight1 = final_weight_at_r_vector(ipoint)
b_mat(ipoint,k,i,m) = 0.5d0 * aos_in_r_array_transp(ipoint,k) * weight1 * aos_grad_in_r_array_transp_bis(ipoint,i,m)
enddo
enddo
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
@ -69,117 +77,141 @@ END_DOC
! 1/2 \int dr1 phi_k(1) d/dx1 phi_i(1) \int dr2 x2(1 - erf(mu_r12))/r12 phi_j(2) phi_l(2)
do m = 1, 3
! A B^T dim(A,1) dim(B,2) dim(A,2) alpha * A LDA
call dgemm("N","N",ao_num*ao_num,ao_num*ao_num,n_points_final_grid,-1.d0,x_v_ij_erf_rk_cst_mu(1,1,1,m),ao_num*ao_num &
,b_mat(1,1,1,m),n_points_final_grid,1.d0,ac_mat,ao_num*ao_num)
call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, -1.d0 &
, x_v_ij_erf_rk_cst_mu(1,1,1,m), ao_num*ao_num, b_mat(1,1,1,m), n_points_final_grid &
, 1.d0, ac_mat, ao_num*ao_num)
enddo
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,k,j,l) &
!$OMP SHARED (ac_mat,ao_non_hermit_term_chemist,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
! (ki|lj) (ki|lj) (lj|ki)
ao_non_hermit_term_chemist(k,i,l,j) = ac_mat(k,i,l,j) + ac_mat(l,j,k,i)
do j = 1, ao_num
do l = 1, ao_num
do i = 1, ao_num
do k = 1, ao_num
! (ki|lj) (ki|lj) (lj|ki)
ao_non_hermit_term_chemist(k,i,l,j) = ac_mat(k,i,l,j) + ac_mat(l,j,k,i)
enddo
enddo
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
double precision :: wall1, wall0
call wall_time(wall1)
print*,'wall time dgemm ',wall1 - wall0
print *, ' wall time dgemm ', wall1 - wall0
END_PROVIDER
! ---
! TODO :: optimization :: transform into DGEM
BEGIN_PROVIDER [double precision, mo_non_hermit_term_chemist, (mo_num, mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC
! 1 1 2 2 1 2 1 2
!
! mo_non_hermit_term_chemist(k,i,l,j) = < k l | [erf( mu r12) - 1] d/d_r12 | i j > on the MO basis
END_DOC
integer :: i,j,k,l,m,n,p,q
double precision, allocatable :: mo_tmp_1(:,:,:,:),mo_tmp_2(:,:,:,:),mo_tmp_3(:,:,:,:)
BEGIN_DOC
! 1 1 2 2 1 2 1 2
!
! mo_non_hermit_term_chemist(k,i,l,j) = < k l | [erf( mu r12) - 1] d/d_r12 | i j > on the MO basis
END_DOC
implicit none
integer :: i, j, k, l, m, n, p, q
double precision, allocatable :: mo_tmp_1(:,:,:,:), mo_tmp_2(:,:,:,:)
allocate(mo_tmp_1(mo_num,ao_num,ao_num,ao_num))
! TODO :: optimization :: transform into DGEM
mo_tmp_1 = 0.d0
do m = 1, ao_num
do p = 1, ao_num
do n = 1, ao_num
do q = 1, ao_num
do k = 1, mo_num
! (k n|p m) = sum_q c_qk * (q n|p m)
mo_tmp_1(k,n,p,m) += mo_coef_transp(k,q) * ao_non_hermit_term_chemist(q,n,p,m)
enddo
allocate(mo_tmp_1(mo_num,ao_num,ao_num,ao_num))
mo_tmp_1 = 0.d0
do m = 1, ao_num
do p = 1, ao_num
do n = 1, ao_num
do q = 1, ao_num
do k = 1, mo_num
! (k n|p m) = sum_q c_qk * (q n|p m)
mo_tmp_1(k,n,p,m) += mo_coef_transp(k,q) * ao_non_hermit_term_chemist(q,n,p,m)
enddo
enddo
enddo
enddo
enddo
enddo
enddo
free ao_non_hermit_term_chemist
allocate(mo_tmp_2(mo_num,mo_num,ao_num,ao_num))
mo_tmp_2 = 0.d0
do m = 1, ao_num
do p = 1, ao_num
do n = 1, ao_num
do i = 1, mo_num
do k = 1, mo_num
! (k i|p m) = sum_n c_ni * (k n|p m)
mo_tmp_2(k,i,p,m) += mo_coef_transp(i,n) * mo_tmp_1(k,n,p,m)
enddo
free ao_non_hermit_term_chemist
allocate(mo_tmp_2(mo_num,mo_num,ao_num,ao_num))
mo_tmp_2 = 0.d0
do m = 1, ao_num
do p = 1, ao_num
do n = 1, ao_num
do i = 1, mo_num
do k = 1, mo_num
! (k i|p m) = sum_n c_ni * (k n|p m)
mo_tmp_2(k,i,p,m) += mo_coef_transp(i,n) * mo_tmp_1(k,n,p,m)
enddo
enddo
enddo
enddo
enddo
enddo
enddo
deallocate(mo_tmp_1)
allocate(mo_tmp_1(mo_num,mo_num,mo_num,ao_num))
mo_tmp_1 = 0.d0
do m = 1, ao_num
do p = 1, ao_num
do l = 1, mo_num
do i = 1, mo_num
do k = 1, mo_num
mo_tmp_1(k,i,l,m) += mo_coef_transp(l,p) * mo_tmp_2(k,i,p,m)
enddo
deallocate(mo_tmp_1)
allocate(mo_tmp_1(mo_num,mo_num,mo_num,ao_num))
mo_tmp_1 = 0.d0
do m = 1, ao_num
do p = 1, ao_num
do l = 1, mo_num
do i = 1, mo_num
do k = 1, mo_num
mo_tmp_1(k,i,l,m) += mo_coef_transp(l,p) * mo_tmp_2(k,i,p,m)
enddo
enddo
enddo
enddo
enddo
enddo
enddo
deallocate(mo_tmp_2)
mo_non_hermit_term_chemist = 0.d0
do m = 1, ao_num
do j = 1, mo_num
do l = 1, mo_num
do i = 1, mo_num
do k = 1, mo_num
mo_non_hermit_term_chemist(k,i,l,j) += mo_coef_transp(j,m) * mo_tmp_1(k,i,l,m)
enddo
deallocate(mo_tmp_2)
mo_non_hermit_term_chemist = 0.d0
do m = 1, ao_num
do j = 1, mo_num
do l = 1, mo_num
do i = 1, mo_num
do k = 1, mo_num
mo_non_hermit_term_chemist(k,i,l,j) += mo_coef_transp(j,m) * mo_tmp_1(k,i,l,m)
enddo
enddo
enddo
enddo
enddo
enddo
enddo
deallocate(mo_tmp_1)
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, mo_non_hermit_term, (mo_num, mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC
! 1 2 1 2 1 2 1 2
!
! mo_non_hermit_term(k,l,i,j) = < k l | [erf( mu r12) - 1] d/d_r12 | i j > on the MO basis
END_DOC
integer :: i,j,k,l
do j = 1, mo_num
do i = 1, mo_num
do l = 1, mo_num
do k = 1, mo_num
mo_non_hermit_term(k,l,i,j) = mo_non_hermit_term_chemist(k,i,l,j)
BEGIN_DOC
! 1 2 1 2 1 2 1 2
!
! mo_non_hermit_term(k,l,i,j) = < k l | [erf( mu r12) - 1] d/d_r12 | i j > on the MO basis
END_DOC
implicit none
integer :: i, j, k, l
do j = 1, mo_num
do i = 1, mo_num
do l = 1, mo_num
do k = 1, mo_num
mo_non_hermit_term(k,l,i,j) = mo_non_hermit_term_chemist(k,i,l,j)
enddo
enddo
enddo
enddo
enddo
enddo
END_PROVIDER
! ---

623
src/non_h_ints_mu/j12_nucl_utils.irp.f Normal file
View File

@ -0,0 +1,623 @@
! ---
BEGIN_PROVIDER [ double precision, v_1b, (n_points_final_grid)]
implicit none
integer :: ipoint, i, j, phase
double precision :: x, y, z, dx, dy, dz
double precision :: a, d, e, fact_r
do ipoint = 1, n_points_final_grid
x = final_grid_points(1,ipoint)
y = final_grid_points(2,ipoint)
z = final_grid_points(3,ipoint)
fact_r = 1.d0
do j = 1, nucl_num
a = j1b_pen(j)
dx = x - nucl_coord(j,1)
dy = y - nucl_coord(j,2)
dz = z - nucl_coord(j,3)
d = dx*dx + dy*dy + dz*dz
e = 1.d0 - dexp(-a*d)
fact_r = fact_r * e
enddo
v_1b(ipoint) = fact_r
enddo
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, v_1b_grad, (3, n_points_final_grid)]
implicit none
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
do ipoint = 1, n_points_final_grid
x = final_grid_points(1,ipoint)
y = final_grid_points(2,ipoint)
z = final_grid_points(3,ipoint)
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
v_1b_grad(1,ipoint) = fact_x
v_1b_grad(2,ipoint) = fact_y
v_1b_grad(3,ipoint) = fact_z
enddo
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, v_1b_lapl, (n_points_final_grid)]
implicit none
integer :: ipoint, i, j, phase
double precision :: x, y, z, dx, dy, dz
double precision :: a, d, e, b
double precision :: fact_r
double precision :: ax_der, ay_der, az_der, a_expo
do ipoint = 1, n_points_final_grid
x = final_grid_points(1,ipoint)
y = final_grid_points(2,ipoint)
z = final_grid_points(3,ipoint)
fact_r = 0.d0
do i = 1, List_all_comb_b2_size
phase = 0
b = 0.d0
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)
b += a
a_expo += a * (dx*dx + dy*dy + dz*dz)
ax_der += a * dx
ay_der += a * dy
az_der += a * dz
enddo
fact_r += (-1.d0)**dble(phase) * (-6.d0*b + 4.d0*(ax_der*ax_der + ay_der*ay_der + az_der*az_der) ) * dexp(-a_expo)
enddo
v_1b_lapl(ipoint) = fact_r
enddo
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, v_1b_list_b2, (n_points_final_grid)]
implicit none
integer :: i, ipoint
double precision :: x, y, z, coef, expo, dx, dy, dz
double precision :: fact_r
PROVIDE List_all_comb_b2_coef List_all_comb_b2_expo List_all_comb_b2_cent
do ipoint = 1, n_points_final_grid
x = final_grid_points(1,ipoint)
y = final_grid_points(2,ipoint)
z = final_grid_points(3,ipoint)
fact_r = 0.d0
do i = 1, List_all_comb_b2_size
coef = List_all_comb_b2_coef(i)
expo = List_all_comb_b2_expo(i)
dx = x - List_all_comb_b2_cent(1,i)
dy = y - List_all_comb_b2_cent(2,i)
dz = z - List_all_comb_b2_cent(3,i)
fact_r += coef * dexp(-expo * (dx*dx + dy*dy + dz*dz))
enddo
v_1b_list_b2(ipoint) = fact_r
enddo
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, v_1b_list_b3, (n_points_final_grid)]
implicit none
integer :: i, ipoint
double precision :: x, y, z, coef, expo, dx, dy, dz
double precision :: fact_r
PROVIDE List_all_comb_b3_coef List_all_comb_b3_expo List_all_comb_b3_cent
do ipoint = 1, n_points_final_grid
x = final_grid_points(1,ipoint)
y = final_grid_points(2,ipoint)
z = final_grid_points(3,ipoint)
fact_r = 0.d0
do i = 1, List_all_comb_b3_size
coef = List_all_comb_b3_coef(i)
expo = List_all_comb_b3_expo(i)
dx = x - List_all_comb_b3_cent(1,i)
dy = y - List_all_comb_b3_cent(2,i)
dz = z - List_all_comb_b3_cent(3,i)
fact_r += coef * dexp(-expo * (dx*dx + dy*dy + dz*dz))
enddo
v_1b_list_b3(ipoint) = fact_r
enddo
END_PROVIDER
! ---
double precision function jmu_modif(r1, r2)
implicit none
double precision, intent(in) :: r1(3), r2(3)
double precision, external :: j12_mu, j12_nucl
jmu_modif = j12_mu(r1, r2) * j12_nucl(r1, r2)
return
end function jmu_modif
! ---
double precision function j12_mu(r1, r2)
include 'constants.include.F'
implicit none
double precision, intent(in) :: r1(3), r2(3)
double precision :: mu_r12, r12
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_r12 = mu_erf * r12
j12_mu = 0.5d0 * r12 * (1.d0 - derf(mu_r12)) - inv_sq_pi_2 * dexp(-mu_r12*mu_r12) / mu_erf
return
end function j12_mu
! ---
double precision function j12_mu_gauss(r1, r2)
implicit none
double precision, intent(in) :: r1(3), r2(3)
integer :: i
double precision :: r12, coef, expo
r12 = (r1(1) - r2(1)) * (r1(1) - r2(1)) &
+ (r1(2) - r2(2)) * (r1(2) - r2(2)) &
+ (r1(3) - r2(3)) * (r1(3) - r2(3))
j12_mu_gauss = 0.d0
do i = 1, n_max_fit_slat
expo = expo_gauss_j_mu_x(i)
coef = coef_gauss_j_mu_x(i)
j12_mu_gauss += coef * dexp(-expo*r12)
enddo
return
end function j12_mu_gauss
! ---
double precision function j1b_nucl(r)
implicit none
double precision, intent(in) :: r(3)
integer :: i
double precision :: a, d, e
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 - exp(-a*d)
j1b_nucl = j1b_nucl * e
enddo
return
end function j1b_nucl
! ---
double precision function j12_nucl(r1, r2)
implicit none
double precision, intent(in) :: r1(3), r2(3)
double precision, external :: j1b_nucl
j12_nucl = j1b_nucl(r1) * j1b_nucl(r2)
return
end function j12_nucl
! ---
! ---------------------------------------------------------------------------------------
double precision function grad_x_j1b_nucl(r)
implicit none
double precision, intent(in) :: r(3)
double precision :: r_eps(3), eps, fp, fm, delta
double precision, external :: j1b_nucl
eps = 1d-6
r_eps = r
delta = max(eps, dabs(eps*r(1)))
r_eps(1) = r_eps(1) + delta
fp = j1b_nucl(r_eps)
r_eps(1) = r_eps(1) - 2.d0 * delta
fm = j1b_nucl(r_eps)
grad_x_j1b_nucl = 0.5d0 * (fp - fm) / delta
return
end function grad_x_j1b_nucl
double precision function grad_y_j1b_nucl(r)
implicit none
double precision, intent(in) :: r(3)
double precision :: r_eps(3), eps, fp, fm, delta
double precision, external :: j1b_nucl
eps = 1d-6
r_eps = r
delta = max(eps, dabs(eps*r(2)))
r_eps(2) = r_eps(2) + delta
fp = j1b_nucl(r_eps)
r_eps(2) = r_eps(2) - 2.d0 * delta
fm = j1b_nucl(r_eps)
grad_y_j1b_nucl = 0.5d0 * (fp - fm) / delta
return
end function grad_y_j1b_nucl
double precision function grad_z_j1b_nucl(r)
implicit none
double precision, intent(in) :: r(3)
double precision :: r_eps(3), eps, fp, fm, delta
double precision, external :: j1b_nucl
eps = 1d-6
r_eps = r
delta = max(eps, dabs(eps*r(3)))
r_eps(3) = r_eps(3) + delta
fp = j1b_nucl(r_eps)
r_eps(3) = r_eps(3) - 2.d0 * delta
fm = j1b_nucl(r_eps)
grad_z_j1b_nucl = 0.5d0 * (fp - fm) / delta
return
end function grad_z_j1b_nucl
! ---------------------------------------------------------------------------------------
! ---
double precision function lapl_j1b_nucl(r)
implicit none
double precision, intent(in) :: r(3)
double precision :: r_eps(3), eps, fp, fm, delta
double precision, external :: grad_x_j1b_nucl
double precision, external :: grad_y_j1b_nucl
double precision, external :: grad_z_j1b_nucl
eps = 1d-5
r_eps = r
lapl_j1b_nucl = 0.d0
! ---
delta = max(eps, dabs(eps*r(1)))
r_eps(1) = r_eps(1) + delta
fp = grad_x_j1b_nucl(r_eps)
r_eps(1) = r_eps(1) - 2.d0 * delta
fm = grad_x_j1b_nucl(r_eps)
r_eps(1) = r_eps(1) + delta
lapl_j1b_nucl += 0.5d0 * (fp - fm) / delta
! ---
delta = max(eps, dabs(eps*r(2)))
r_eps(2) = r_eps(2) + delta
fp = grad_y_j1b_nucl(r_eps)
r_eps(2) = r_eps(2) - 2.d0 * delta
fm = grad_y_j1b_nucl(r_eps)
r_eps(2) = r_eps(2) + delta
lapl_j1b_nucl += 0.5d0 * (fp - fm) / delta
! ---
delta = max(eps, dabs(eps*r(3)))
r_eps(3) = r_eps(3) + delta
fp = grad_z_j1b_nucl(r_eps)
r_eps(3) = r_eps(3) - 2.d0 * delta
fm = grad_z_j1b_nucl(r_eps)
r_eps(3) = r_eps(3) + delta
lapl_j1b_nucl += 0.5d0 * (fp - fm) / delta
! ---
return
end function lapl_j1b_nucl
! ---
! ---------------------------------------------------------------------------------------
double precision function grad1_x_jmu_modif(r1, r2)
implicit none
double precision, intent(in) :: r1(3), r2(3)
double precision :: r1_eps(3), eps, fp, fm, delta
double precision, external :: jmu_modif
eps = 1d-7
r1_eps = r1
delta = max(eps, dabs(eps*r1(1)))
r1_eps(1) = r1_eps(1) + delta
fp = jmu_modif(r1_eps, r2)
r1_eps(1) = r1_eps(1) - 2.d0 * delta
fm = jmu_modif(r1_eps, r2)
grad1_x_jmu_modif = 0.5d0 * (fp - fm) / delta
return
end function grad1_x_jmu_modif
double precision function grad1_y_jmu_modif(r1, r2)
implicit none
double precision, intent(in) :: r1(3), r2(3)
double precision :: r1_eps(3), eps, fp, fm, delta
double precision, external :: jmu_modif
eps = 1d-7
r1_eps = r1
delta = max(eps, dabs(eps*r1(2)))
r1_eps(2) = r1_eps(2) + delta
fp = jmu_modif(r1_eps, r2)
r1_eps(2) = r1_eps(2) - 2.d0 * delta
fm = jmu_modif(r1_eps, r2)
grad1_y_jmu_modif = 0.5d0 * (fp - fm) / delta
return
end function grad1_y_jmu_modif
double precision function grad1_z_jmu_modif(r1, r2)
implicit none
double precision, intent(in) :: r1(3), r2(3)
double precision :: r1_eps(3), eps, fp, fm, delta
double precision, external :: jmu_modif
eps = 1d-7
r1_eps = r1
delta = max(eps, dabs(eps*r1(3)))
r1_eps(3) = r1_eps(3) + delta
fp = jmu_modif(r1_eps, r2)
r1_eps(3) = r1_eps(3) - 2.d0 * delta
fm = jmu_modif(r1_eps, r2)
grad1_z_jmu_modif = 0.5d0 * (fp - fm) / delta
return
end function grad1_z_jmu_modif
! ---------------------------------------------------------------------------------------
! ---
! ---------------------------------------------------------------------------------------
double precision function grad1_x_j12_mu_num(r1, r2)
implicit none
double precision, intent(in) :: r1(3), r2(3)
double precision :: r1_eps(3), eps, fp, fm, delta
double precision, external :: j12_mu
eps = 1d-7
r1_eps = r1
delta = max(eps, dabs(eps*r1(1)))
r1_eps(1) = r1_eps(1) + delta
fp = j12_mu(r1_eps, r2)
r1_eps(1) = r1_eps(1) - 2.d0 * delta
fm = j12_mu(r1_eps, r2)
grad1_x_j12_mu_num = 0.5d0 * (fp - fm) / delta
return
end function grad1_x_j12_mu_num
double precision function grad1_y_j12_mu_num(r1, r2)
implicit none
double precision, intent(in) :: r1(3), r2(3)
double precision :: r1_eps(3), eps, fp, fm, delta
double precision, external :: j12_mu
eps = 1d-7
r1_eps = r1
delta = max(eps, dabs(eps*r1(2)))
r1_eps(2) = r1_eps(2) + delta
fp = j12_mu(r1_eps, r2)
r1_eps(2) = r1_eps(2) - 2.d0 * delta
fm = j12_mu(r1_eps, r2)
grad1_y_j12_mu_num = 0.5d0 * (fp - fm) / delta
return
end function grad1_y_j12_mu_num
double precision function grad1_z_j12_mu_num(r1, r2)
implicit none
double precision, intent(in) :: r1(3), r2(3)
double precision :: r1_eps(3), eps, fp, fm, delta
double precision, external :: j12_mu
eps = 1d-7
r1_eps = r1
delta = max(eps, dabs(eps*r1(3)))
r1_eps(3) = r1_eps(3) + delta
fp = j12_mu(r1_eps, r2)
r1_eps(3) = r1_eps(3) - 2.d0 * delta
fm = j12_mu(r1_eps, r2)
grad1_z_j12_mu_num = 0.5d0 * (fp - fm) / delta
return
end function grad1_z_j12_mu_num
! ---------------------------------------------------------------------------------------
! ---
subroutine grad1_j12_mu_exc(r1, r2, grad)
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
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
return
end subroutine grad1_j12_mu_exc
! ---
subroutine grad1_jmu_modif_num(r1, r2, grad)
implicit none
double precision, intent(in) :: r1(3), r2(3)
double precision, intent(out) :: grad(3)
double precision :: tmp0, tmp1, tmp2, tmp3, tmp4, grad_u12(3)
double precision, external :: j12_mu
double precision, external :: j1b_nucl
double precision, external :: grad_x_j1b_nucl
double precision, external :: grad_y_j1b_nucl
double precision, external :: grad_z_j1b_nucl
call grad1_j12_mu_exc(r1, r2, grad_u12)
tmp0 = j1b_nucl(r1)
tmp1 = j1b_nucl(r2)
tmp2 = j12_mu(r1, r2)
tmp3 = tmp0 * tmp1
tmp4 = tmp2 * tmp1
grad(1) = tmp3 * grad_u12(1) + tmp4 * grad_x_j1b_nucl(r1)
grad(2) = tmp3 * grad_u12(2) + tmp4 * grad_y_j1b_nucl(r1)
grad(3) = tmp3 * grad_u12(3) + tmp4 * grad_z_j1b_nucl(r1)
return
end subroutine grad1_jmu_modif_num
! ---

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

@ -1,70 +1,151 @@
BEGIN_PROVIDER [ double precision, grad_1_u_ij_mu, ( ao_num, ao_num,n_points_final_grid,3)]
implicit none
BEGIN_DOC
! grad_1_u_ij_mu(i,j,ipoint) = -1 * \int dr2 \grad_r1 u(r1,r2) \phi_i(r2) \phi_j(r2)
!
! where r1 = r(ipoint)
!
! grad_1_u_ij_mu(i,j,ipoint) = \int dr2 (r1 - r2) (erf(mu * r12)-1)/2 r_12 \phi_i(r2) \phi_j(r2)
END_DOC
integer :: ipoint,i,j,m
double precision :: r(3)
do m = 1, 3
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)
do j = 1, ao_num
do i = 1, ao_num
grad_1_u_ij_mu(i,j,ipoint,m) = v_ij_erf_rk_cst_mu(i,j,ipoint) * r(m) - x_v_ij_erf_rk_cst_mu(i,j,ipoint,m)
! ---
BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao, (3, ao_num, ao_num, n_points_final_grid)]
BEGIN_DOC
!
! 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)
!
! if J(r1,r2) = u12:
!
! int2_grad1_u12_ao(:,i,j,ipoint) = 0.5 x \int dr2 [(r1 - r2) (erf(mu * r12)-1)r_12] \phi_i(r2) \phi_j(r2)
! = 0.5 * [ v_ij_erf_rk_cst_mu(i,j,ipoint) * r(:) - x_v_ij_erf_rk_cst_mu(i,j,ipoint,:) ]
!
! if J(r1,r2) = u12 x v1 x v2
!
! int2_grad1_u12_ao(:,i,j,ipoint) = v1 x [ 0.5 x \int dr2 [(r1 - r2) (erf(mu * r12)-1)r_12] v2 \phi_i(r2) \phi_j(r2) ]
! - \grad_1 v1 x [ \int dr2 u12 v2 \phi_i(r2) \phi_j(r2) ]
! = 0.5 v_1b(ipoint) * v_ij_erf_rk_cst_mu_j1b(i,j,ipoint) * r(:)
! - 0.5 v_1b(ipoint) * x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,:)
! - v_1b_grad[:,ipoint] * v_ij_u_cst_mu_j1b(i,j,ipoint)
!
!
END_DOC
implicit none
integer :: ipoint, i, j
double precision :: x, y, z, tmp_x, tmp_y, tmp_z, tmp0, tmp1, tmp2
PROVIDE j1b_type
if(j1b_type .eq. 3) then
do ipoint = 1, n_points_final_grid
x = final_grid_points(1,ipoint)
y = final_grid_points(2,ipoint)
z = final_grid_points(3,ipoint)
tmp0 = 0.5d0 * v_1b(ipoint)
tmp_x = v_1b_grad(1,ipoint)
tmp_y = v_1b_grad(2,ipoint)
tmp_z = v_1b_grad(3,ipoint)
do j = 1, ao_num
do i = 1, ao_num
tmp1 = tmp0 * v_ij_erf_rk_cst_mu_j1b(i,j,ipoint)
tmp2 = v_ij_u_cst_mu_j1b(i,j,ipoint)
int2_grad1_u12_ao(1,i,j,ipoint) = tmp1 * x - tmp0 * x_v_ij_erf_rk_cst_mu_tmp_j1b(1,i,j,ipoint) - tmp2 * tmp_x
int2_grad1_u12_ao(2,i,j,ipoint) = tmp1 * y - tmp0 * x_v_ij_erf_rk_cst_mu_tmp_j1b(2,i,j,ipoint) - tmp2 * tmp_y
int2_grad1_u12_ao(3,i,j,ipoint) = tmp1 * z - tmp0 * x_v_ij_erf_rk_cst_mu_tmp_j1b(3,i,j,ipoint) - tmp2 * tmp_z
enddo
enddo
enddo
enddo
enddo
enddo
grad_1_u_ij_mu *= 0.5d0
else
do ipoint = 1, n_points_final_grid
x = final_grid_points(1,ipoint)
y = final_grid_points(2,ipoint)
z = final_grid_points(3,ipoint)
do j = 1, ao_num
do i = 1, ao_num
tmp1 = v_ij_erf_rk_cst_mu(i,j,ipoint)
int2_grad1_u12_ao(1,i,j,ipoint) = tmp1 * x - x_v_ij_erf_rk_cst_mu_tmp(1,i,j,ipoint)
int2_grad1_u12_ao(2,i,j,ipoint) = tmp1 * y - x_v_ij_erf_rk_cst_mu_tmp(2,i,j,ipoint)
int2_grad1_u12_ao(3,i,j,ipoint) = tmp1 * z - x_v_ij_erf_rk_cst_mu_tmp(3,i,j,ipoint)
enddo
enddo
enddo
int2_grad1_u12_ao *= 0.5d0
endif
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, tc_grad_and_lapl_ao, (ao_num, ao_num, ao_num, ao_num)]
implicit none
BEGIN_DOC
! tc_grad_and_lapl_ao(k,i,l,j) = <kl | -1/2 \Delta_1 u(r1,r2) - \grad_1 u(r1,r2) .\grad_1| ij>
!
! = 1/2 \int dr1 (phi_k(r1) \grad_r1 phi_i(r1) - phi_i(r1) \grad_r1 phi_k(r1)) . \int dr2 \grad_r1 u(r1,r2) \phi_l(r2) \phi_j(r2)
!
! This is obtained by integration by parts.
END_DOC
integer :: ipoint,i,j,k,l,m
double precision :: contrib,weight1
double precision, allocatable :: ac_mat(:,:,:,:)
allocate(ac_mat(ao_num, ao_num, ao_num, ao_num))
ac_mat = 0.d0
do m = 1, 3
do ipoint = 1, n_points_final_grid
weight1 = final_weight_at_r_vector(ipoint)
do j = 1, ao_num
do l = 1, ao_num
do i = 1, ao_num
do k = 1, ao_num
contrib = weight1 *0.5D0* (aos_in_r_array_transp(ipoint,k) * aos_grad_in_r_array_transp_bis(ipoint,i,m) &
-aos_in_r_array_transp(ipoint,i) * aos_grad_in_r_array_transp_bis(ipoint,k,m) )
! \int dr1 phi_k(r1) \grad_r1 phi_i(r1) . \int dr2 \grad_r1 u(r1,r2) \phi_l(r2) \phi_j(r2)
ac_mat(k,i,l,j) += grad_1_u_ij_mu(l,j,ipoint,m) * contrib
enddo
enddo
enddo
enddo
enddo
enddo
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)
BEGIN_DOC
!
! tc_grad_and_lapl_ao(k,i,l,j) = < k l | -1/2 \Delta_1 u(r1,r2) - \grad_1 u(r1,r2) | ij >
!
! = 1/2 \int dr1 (phi_k(r1) \grad_r1 phi_i(r1) - phi_i(r1) \grad_r1 phi_k(r1)) . \int dr2 \grad_r1 u(r1,r2) \phi_l(r2) \phi_j(r2)
!
! This is obtained by integration by parts.
!
END_DOC
implicit none
integer :: ipoint, i, j, k, l
double precision :: weight1, contrib_x, contrib_y, contrib_z, tmp_x, tmp_y, tmp_z
double precision :: ao_k_r, ao_i_r, ao_i_dx, ao_i_dy, ao_i_dz
double precision, allocatable :: ac_mat(:,:,:,:)
allocate(ac_mat(ao_num,ao_num,ao_num,ao_num))
ac_mat = 0.d0
do ipoint = 1, n_points_final_grid
weight1 = 0.5d0 * final_weight_at_r_vector(ipoint)
do i = 1, ao_num
ao_i_r = weight1 * aos_in_r_array_transp (ipoint,i)
ao_i_dx = weight1 * aos_grad_in_r_array_transp_bis(ipoint,i,1)
ao_i_dy = weight1 * aos_grad_in_r_array_transp_bis(ipoint,i,2)
ao_i_dz = weight1 * aos_grad_in_r_array_transp_bis(ipoint,i,3)
do k = 1, ao_num
ao_k_r = aos_in_r_array_transp(ipoint,k)
tmp_x = ao_k_r * ao_i_dx - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,1)
tmp_y = ao_k_r * ao_i_dy - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,2)
tmp_z = ao_k_r * ao_i_dz - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,3)
do j = 1, ao_num
do l = 1, ao_num
contrib_x = int2_grad1_u12_ao(1,l,j,ipoint) * tmp_x
contrib_y = int2_grad1_u12_ao(2,l,j,ipoint) * tmp_y
contrib_z = int2_grad1_u12_ao(3,l,j,ipoint) * tmp_z
ac_mat(k,i,l,j) += contrib_x + contrib_y + contrib_z
enddo
enddo
enddo
enddo
enddo
enddo
enddo
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
deallocate(ac_mat)
END_PROVIDER
! ---

623
src/non_h_ints_mu/numerical_integ.irp.f Normal file
View File

@ -0,0 +1,623 @@
! ---
double precision function num_v_ij_u_cst_mu_j1b(i, j, ipoint)
BEGIN_DOC
!
! \int dr2 u12 \phi_i(r2) \phi_j(r2) x v_1b(r2)
!
END_DOC
implicit none
integer, intent(in) :: i, j, ipoint
integer :: jpoint
double precision :: r1(3), r2(3)
double precision, external :: ao_value
double precision, external :: j12_mu, j1b_nucl, j12_mu_gauss
r1(1) = final_grid_points(1,ipoint)
r1(2) = final_grid_points(2,ipoint)
r1(3) = final_grid_points(3,ipoint)
num_v_ij_u_cst_mu_j1b = 0.d0
do jpoint = 1, n_points_final_grid
r2(1) = final_grid_points(1,jpoint)
r2(2) = final_grid_points(2,jpoint)
r2(3) = final_grid_points(3,jpoint)
num_v_ij_u_cst_mu_j1b += ao_value(i, r2) * ao_value(j, r2) * j12_mu_gauss(r1, r2) * j1b_nucl(r2) * final_weight_at_r_vector(jpoint)
enddo
return
end function num_v_ij_u_cst_mu_j1b
! ---
double precision function num_int2_u2_j1b2(i, j, ipoint)
BEGIN_DOC
!
! \int dr2 u12^2 \phi_i(r2) \phi_j(r2) x v_1b(r2)^2
!
END_DOC
implicit none
integer, intent(in) :: i, j, ipoint
integer :: jpoint, i_fit
double precision :: r1(3), r2(3)
double precision :: dx, dy, dz, r12, x2, tmp1, tmp2, tmp3, coef, expo
double precision, external :: ao_value
double precision, external :: j1b_nucl
double precision, external :: j12_mu
r1(1) = final_grid_points(1,ipoint)
r1(2) = final_grid_points(2,ipoint)
r1(3) = final_grid_points(3,ipoint)
num_int2_u2_j1b2 = 0.d0
do jpoint = 1, n_points_final_grid
r2(1) = final_grid_points(1,jpoint)
r2(2) = final_grid_points(2,jpoint)
r2(3) = final_grid_points(3,jpoint)
dx = r1(1) - r2(1)
dy = r1(2) - r2(2)
dz = r1(3) - r2(3)
x2 = dx * dx + dy * dy + dz * dz
r12 = dsqrt(x2)
tmp1 = j1b_nucl(r2)
tmp2 = tmp1 * tmp1 * ao_value(i, r2) * ao_value(j, r2) * final_weight_at_r_vector(jpoint)
!tmp3 = 0.d0
!do i_fit = 1, n_max_fit_slat
! expo = expo_gauss_j_mu_x_2(i_fit)
! coef = coef_gauss_j_mu_x_2(i_fit)
! tmp3 += coef * dexp(-expo*x2)
!enddo
tmp3 = j12_mu(r1, r2)
tmp3 = tmp3 * tmp3
num_int2_u2_j1b2 += tmp2 * tmp3
enddo
return
end function num_int2_u2_j1b2
! ---
double precision function num_int2_grad1u2_grad2u2_j1b2(i, j, ipoint)
BEGIN_DOC
!
! \int dr2 \frac{-[erf(mu r12) -1]^2}{4} \phi_i(r2) \phi_j(r2) x v_1b(r2)^2
!
END_DOC
implicit none
integer, intent(in) :: i, j, ipoint
integer :: jpoint, i_fit
double precision :: r1(3), r2(3)
double precision :: dx, dy, dz, r12, x2, tmp1, tmp2, tmp3, coef, expo
double precision, external :: ao_value
double precision, external :: j1b_nucl
r1(1) = final_grid_points(1,ipoint)
r1(2) = final_grid_points(2,ipoint)
r1(3) = final_grid_points(3,ipoint)
num_int2_grad1u2_grad2u2_j1b2 = 0.d0
do jpoint = 1, n_points_final_grid
r2(1) = final_grid_points(1,jpoint)
r2(2) = final_grid_points(2,jpoint)
r2(3) = final_grid_points(3,jpoint)
dx = r1(1) - r2(1)
dy = r1(2) - r2(2)
dz = r1(3) - r2(3)
x2 = dx * dx + dy * dy + dz * dz
r12 = dsqrt(x2)
tmp1 = j1b_nucl(r2)
tmp2 = tmp1 * tmp1 * ao_value(i, r2) * ao_value(j, r2) * final_weight_at_r_vector(jpoint)
!tmp3 = 0.d0
!do i_fit = 1, n_max_fit_slat
! expo = expo_gauss_1_erf_x_2(i_fit)
! coef = coef_gauss_1_erf_x_2(i_fit)
! tmp3 += coef * dexp(-expo*x2)
!enddo
tmp3 = derf(mu_erf*r12) - 1.d0
tmp3 = tmp3 * tmp3
tmp3 = -0.25d0 * tmp3
num_int2_grad1u2_grad2u2_j1b2 += tmp2 * tmp3
enddo
return
end function num_int2_grad1u2_grad2u2_j1b2
! ---
double precision function num_v_ij_erf_rk_cst_mu_j1b(i, j, ipoint)
BEGIN_DOC
!
! \int dr2 [erf(mu r12) -1]/r12 \phi_i(r2) \phi_j(r2) x v_1b(r2)
!
END_DOC
implicit none
integer, intent(in) :: i, j, ipoint
integer :: jpoint
double precision :: r1(3), r2(3)
double precision :: dx, dy, dz, r12, tmp1, tmp2
double precision, external :: ao_value
double precision, external :: j1b_nucl
r1(1) = final_grid_points(1,ipoint)
r1(2) = final_grid_points(2,ipoint)
r1(3) = final_grid_points(3,ipoint)
num_v_ij_erf_rk_cst_mu_j1b = 0.d0
do jpoint = 1, n_points_final_grid
r2(1) = final_grid_points(1,jpoint)
r2(2) = final_grid_points(2,jpoint)
r2(3) = final_grid_points(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) cycle
tmp1 = (derf(mu_erf * r12) - 1.d0) / r12
tmp2 = tmp1 * ao_value(i, r2) * ao_value(j, r2) * j1b_nucl(r2) * final_weight_at_r_vector(jpoint)
num_v_ij_erf_rk_cst_mu_j1b += tmp2
enddo
return
end function num_v_ij_erf_rk_cst_mu_j1b
! ---
subroutine num_x_v_ij_erf_rk_cst_mu_j1b(i, j, ipoint, integ)
BEGIN_DOC
!
! \int dr2 [erf(mu r12) -1]/r12 \phi_i(r2) \phi_j(r2) x v_1b(r2) x r2
!
END_DOC
implicit none
integer, intent(in) :: i, j, ipoint
double precision, intent(out) :: integ(3)
integer :: jpoint
double precision :: r1(3), r2(3), grad(3)
double precision :: dx, dy, dz, r12, tmp1, tmp2
double precision :: tmp_x, tmp_y, tmp_z
double precision, external :: ao_value
double precision, external :: j1b_nucl
r1(1) = final_grid_points(1,ipoint)
r1(2) = final_grid_points(2,ipoint)
r1(3) = final_grid_points(3,ipoint)
tmp_x = 0.d0
tmp_y = 0.d0
tmp_z = 0.d0
do jpoint = 1, n_points_final_grid
r2(1) = final_grid_points(1,jpoint)
r2(2) = final_grid_points(2,jpoint)
r2(3) = final_grid_points(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) cycle
tmp1 = (derf(mu_erf * r12) - 1.d0) / r12
tmp2 = tmp1 * ao_value(i, r2) * ao_value(j, r2) * j1b_nucl(r2) * final_weight_at_r_vector(jpoint)
tmp_x += tmp2 * r2(1)
tmp_y += tmp2 * r2(2)
tmp_z += tmp2 * r2(3)
enddo
integ(1) = tmp_x
integ(2) = tmp_y
integ(3) = tmp_z
return
end subroutine num_x_v_ij_erf_rk_cst_mu_j1b
! ---
subroutine num_int2_grad1_u12_ao(i, j, ipoint, integ)
BEGIN_DOC
!
! \int dr2 [-grad_1 u12] \phi_i(r2) \phi_j(r2) x v12_1b(r1, r2)
!
END_DOC
implicit none
integer, intent(in) :: i, j, ipoint
double precision, intent(out) :: integ(3)
integer :: jpoint
double precision :: tmp, r1(3), r2(3), grad(3)
double precision :: tmp_x, tmp_y, tmp_z
double precision, external :: ao_value
r1(1) = final_grid_points(1,ipoint)
r1(2) = final_grid_points(2,ipoint)
r1(3) = final_grid_points(3,ipoint)
tmp_x = 0.d0
tmp_y = 0.d0
tmp_z = 0.d0
do jpoint = 1, n_points_final_grid
r2(1) = final_grid_points(1,jpoint)
r2(2) = final_grid_points(2,jpoint)
r2(3) = final_grid_points(3,jpoint)
tmp = ao_value(i, r2) * ao_value(j, r2) * final_weight_at_r_vector(jpoint)
call grad1_jmu_modif_num(r1, r2, grad)
tmp_x += tmp * (-1.d0 * grad(1))
tmp_y += tmp * (-1.d0 * grad(2))
tmp_z += tmp * (-1.d0 * grad(3))
enddo
integ(1) = tmp_x
integ(2) = tmp_y
integ(3) = tmp_z
return
end subroutine num_int2_grad1_u12_ao
! ---
double precision function num_gradu_squared_u_ij_mu(i, j, ipoint)
BEGIN_DOC
!
! -0.50 x \int r2 \phi_i(2) \phi_j(2) x v2^2
! [ v1^2 ((grad_1 u12)^2 + (grad_2 u12^2)])
! + u12^2 (grad_1 v1)^2
! + 2 u12 v1 (grad_1 u12) . (grad_1 v1)
!
END_DOC
implicit none
integer, intent(in) :: i, j, ipoint
integer :: jpoint
double precision :: r1(3), r2(3)
double precision :: tmp_x, tmp_y, tmp_z, r12
double precision :: dx1_v1, dy1_v1, dz1_v1, grad_u12(3)
double precision :: tmp1, v1_tmp, v2_tmp, u12_tmp
double precision :: fst_term, scd_term, thd_term, tmp
double precision, external :: ao_value
double precision, external :: j1b_nucl
double precision, external :: j12_mu
double precision, external :: grad_x_j1b_nucl
double precision, external :: grad_y_j1b_nucl
double precision, external :: grad_z_j1b_nucl
r1(1) = final_grid_points(1,ipoint)
r1(2) = final_grid_points(2,ipoint)
r1(3) = final_grid_points(3,ipoint)
num_gradu_squared_u_ij_mu = 0.d0
do jpoint = 1, n_points_final_grid
r2(1) = final_grid_points(1,jpoint)
r2(2) = final_grid_points(2,jpoint)
r2(3) = final_grid_points(3,jpoint)
tmp_x = r1(1) - r2(1)
tmp_y = r1(2) - r2(2)
tmp_z = r1(3) - r2(3)
r12 = dsqrt(tmp_x*tmp_x + tmp_y*tmp_y + tmp_z*tmp_z)
dx1_v1 = grad_x_j1b_nucl(r1)
dy1_v1 = grad_y_j1b_nucl(r1)
dz1_v1 = grad_z_j1b_nucl(r1)
call grad1_j12_mu_exc(r1, r2, grad_u12)
tmp1 = 1.d0 - derf(mu_erf * r12)
v1_tmp = j1b_nucl(r1)
v2_tmp = j1b_nucl(r2)
u12_tmp = j12_mu(r1, r2)
fst_term = 0.5d0 * tmp1 * tmp1 * v1_tmp * v1_tmp
scd_term = u12_tmp * u12_tmp * (dx1_v1*dx1_v1 + dy1_v1*dy1_v1 + dz1_v1*dz1_v1)
thd_term = 2.d0 * v1_tmp * u12_tmp * (dx1_v1*grad_u12(1) + dy1_v1*grad_u12(2) + dz1_v1*grad_u12(3))
tmp = -0.5d0 * ao_value(i, r2) * ao_value(j, r2) * final_weight_at_r_vector(jpoint) * (fst_term + scd_term + thd_term) * v2_tmp * v2_tmp
num_gradu_squared_u_ij_mu += tmp
enddo
return
end function num_gradu_squared_u_ij_mu
! ---
double precision function num_grad12_j12(i, j, ipoint)
BEGIN_DOC
!
! -0.50 x \int r2 \phi_i(2) \phi_j(2) x v2^2 [v1^2 ((grad_1 u12)^2 + (grad_2 u12^2)]) ]
!
END_DOC
implicit none
integer, intent(in) :: i, j, ipoint
integer :: jpoint
double precision :: r1(3), r2(3)
double precision :: tmp_x, tmp_y, tmp_z, r12
double precision :: dx1_v1, dy1_v1, dz1_v1, grad_u12(3)
double precision :: tmp1, v1_tmp, v2_tmp, u12_tmp
double precision :: fst_term, scd_term, thd_term, tmp
double precision, external :: ao_value
double precision, external :: j1b_nucl
double precision, external :: j12_mu
double precision, external :: grad_x_j1b_nucl
double precision, external :: grad_y_j1b_nucl
double precision, external :: grad_z_j1b_nucl
r1(1) = final_grid_points(1,ipoint)
r1(2) = final_grid_points(2,ipoint)
r1(3) = final_grid_points(3,ipoint)
num_grad12_j12 = 0.d0
do jpoint = 1, n_points_final_grid
r2(1) = final_grid_points(1,jpoint)
r2(2) = final_grid_points(2,jpoint)
r2(3) = final_grid_points(3,jpoint)
tmp_x = r1(1) - r2(1)
tmp_y = r1(2) - r2(2)
tmp_z = r1(3) - r2(3)
r12 = dsqrt(tmp_x*tmp_x + tmp_y*tmp_y + tmp_z*tmp_z)
dx1_v1 = grad_x_j1b_nucl(r1)
dy1_v1 = grad_y_j1b_nucl(r1)
dz1_v1 = grad_z_j1b_nucl(r1)
call grad1_j12_mu_exc(r1, r2, grad_u12)
tmp1 = 1.d0 - derf(mu_erf * r12)
v1_tmp = j1b_nucl(r1)
v2_tmp = j1b_nucl(r2)
u12_tmp = j12_mu(r1, r2)
fst_term = 0.5d0 * tmp1 * tmp1 * v1_tmp * v1_tmp
tmp = -0.5d0 * ao_value(i, r2) * ao_value(j, r2) * final_weight_at_r_vector(jpoint) * fst_term * v2_tmp * v2_tmp
num_grad12_j12 += tmp
enddo
return
end function num_grad12_j12
! ---
double precision function num_u12sq_j1bsq(i, j, ipoint)
BEGIN_DOC
!
! -0.50 x \int r2 \phi_i(2) \phi_j(2) x v2^2 [ u12^2 (grad_1 v1)^2 ]
!
END_DOC
implicit none
integer, intent(in) :: i, j, ipoint
integer :: jpoint
double precision :: r1(3), r2(3)
double precision :: tmp_x, tmp_y, tmp_z, r12
double precision :: dx1_v1, dy1_v1, dz1_v1, grad_u12(3)
double precision :: tmp1, v1_tmp, v2_tmp, u12_tmp
double precision :: fst_term, scd_term, thd_term, tmp
double precision, external :: ao_value
double precision, external :: j1b_nucl
double precision, external :: j12_mu
double precision, external :: grad_x_j1b_nucl
double precision, external :: grad_y_j1b_nucl
double precision, external :: grad_z_j1b_nucl
r1(1) = final_grid_points(1,ipoint)
r1(2) = final_grid_points(2,ipoint)
r1(3) = final_grid_points(3,ipoint)
num_u12sq_j1bsq = 0.d0
do jpoint = 1, n_points_final_grid
r2(1) = final_grid_points(1,jpoint)
r2(2) = final_grid_points(2,jpoint)
r2(3) = final_grid_points(3,jpoint)
tmp_x = r1(1) - r2(1)
tmp_y = r1(2) - r2(2)
tmp_z = r1(3) - r2(3)
r12 = dsqrt(tmp_x*tmp_x + tmp_y*tmp_y + tmp_z*tmp_z)
dx1_v1 = grad_x_j1b_nucl(r1)
dy1_v1 = grad_y_j1b_nucl(r1)
dz1_v1 = grad_z_j1b_nucl(r1)
call grad1_j12_mu_exc(r1, r2, grad_u12)
tmp1 = 1.d0 - derf(mu_erf * r12)
v1_tmp = j1b_nucl(r1)
v2_tmp = j1b_nucl(r2)
u12_tmp = j12_mu(r1, r2)
scd_term = u12_tmp * u12_tmp * (dx1_v1*dx1_v1 + dy1_v1*dy1_v1 + dz1_v1*dz1_v1)
tmp = -0.5d0 * ao_value(i, r2) * ao_value(j, r2) * final_weight_at_r_vector(jpoint) * scd_term * v2_tmp * v2_tmp
num_u12sq_j1bsq += tmp
enddo
return
end function num_u12sq_j1bsq
! ---
double precision function num_u12_grad1_u12_j1b_grad1_j1b(i, j, ipoint)
BEGIN_DOC
!
! -0.50 x \int r2 \phi_i(2) \phi_j(2) x v2^2 [ 2 u12 v1 (grad_1 u12) . (grad_1 v1) ]
!
END_DOC
implicit none
integer, intent(in) :: i, j, ipoint
integer :: jpoint
double precision :: r1(3), r2(3)
double precision :: tmp_x, tmp_y, tmp_z, r12
double precision :: dx1_v1, dy1_v1, dz1_v1, grad_u12(3)
double precision :: tmp1, v1_tmp, v2_tmp, u12_tmp
double precision :: fst_term, scd_term, thd_term, tmp
double precision, external :: ao_value
double precision, external :: j1b_nucl
double precision, external :: j12_mu
double precision, external :: grad_x_j1b_nucl
double precision, external :: grad_y_j1b_nucl
double precision, external :: grad_z_j1b_nucl
r1(1) = final_grid_points(1,ipoint)
r1(2) = final_grid_points(2,ipoint)
r1(3) = final_grid_points(3,ipoint)
num_u12_grad1_u12_j1b_grad1_j1b = 0.d0
do jpoint = 1, n_points_final_grid
r2(1) = final_grid_points(1,jpoint)
r2(2) = final_grid_points(2,jpoint)
r2(3) = final_grid_points(3,jpoint)
tmp_x = r1(1) - r2(1)
tmp_y = r1(2) - r2(2)
tmp_z = r1(3) - r2(3)
r12 = dsqrt(tmp_x*tmp_x + tmp_y*tmp_y + tmp_z*tmp_z)
dx1_v1 = grad_x_j1b_nucl(r1)
dy1_v1 = grad_y_j1b_nucl(r1)
dz1_v1 = grad_z_j1b_nucl(r1)
call grad1_j12_mu_exc(r1, r2, grad_u12)
tmp1 = 1.d0 - derf(mu_erf * r12)
v1_tmp = j1b_nucl(r1)
v2_tmp = j1b_nucl(r2)
u12_tmp = j12_mu(r1, r2)
thd_term = 2.d0 * v1_tmp * u12_tmp * (dx1_v1*grad_u12(1) + dy1_v1*grad_u12(2) + dz1_v1*grad_u12(3))
tmp = -0.5d0 * ao_value(i, r2) * ao_value(j, r2) * final_weight_at_r_vector(jpoint) * thd_term * v2_tmp * v2_tmp
num_u12_grad1_u12_j1b_grad1_j1b += tmp
enddo
return
end function num_u12_grad1_u12_j1b_grad1_j1b
! ---
subroutine num_int2_u_grad1u_total_j1b2(i, j, ipoint, integ)
BEGIN_DOC
!
! \int dr2 u12 (grad_1 u12) \phi_i(r2) \phi_j(r2) x v_1b(r2)^2
!
END_DOC
implicit none
integer, intent(in) :: i, j, ipoint
double precision, intent(out) :: integ(3)
integer :: jpoint
double precision :: r1(3), r2(3), grad(3)
double precision :: dx, dy, dz, r12, tmp0, tmp1, tmp2
double precision :: tmp_x, tmp_y, tmp_z
double precision, external :: ao_value
double precision, external :: j1b_nucl
double precision, external :: j12_mu
r1(1) = final_grid_points(1,ipoint)
r1(2) = final_grid_points(2,ipoint)
r1(3) = final_grid_points(3,ipoint)
tmp_x = 0.d0
tmp_y = 0.d0
tmp_z = 0.d0
do jpoint = 1, n_points_final_grid
r2(1) = final_grid_points(1,jpoint)
r2(2) = final_grid_points(2,jpoint)
r2(3) = final_grid_points(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) cycle
tmp0 = j1b_nucl(r2)
tmp1 = 0.5d0 * j12_mu(r1, r2) * (1.d0 - derf(mu_erf * r12)) / r12
tmp2 = tmp0 * tmp0 * tmp1 * ao_value(i, r2) * ao_value(j, r2) * final_weight_at_r_vector(jpoint)
tmp_x += tmp2 * dx
tmp_y += tmp2 * dy
tmp_z += tmp2 * dz
enddo
integ(1) = tmp_x
integ(2) = tmp_y
integ(3) = tmp_z
return
end subroutine num_int2_u_grad1u_total_j1b2
! ---

60
src/non_h_ints_mu/total_tc_int.irp.f Normal file
View File

@ -0,0 +1,60 @@
! ---
BEGIN_PROVIDER [double precision, ao_tc_int_chemist, (ao_num, ao_num, ao_num, ao_num)]
implicit none
integer :: i, j, k, l
double precision :: wall1, wall0
call wall_time(wall0)
do j = 1, ao_num
do l = 1, ao_num
do i = 1, ao_num
do k = 1, ao_num
ao_tc_int_chemist(k,i,l,j) = tc_grad_square_ao(k,i,l,j) + tc_grad_and_lapl_ao(k,i,l,j) + ao_two_e_coul(k,i,l,j)
enddo
enddo
enddo
enddo
call wall_time(wall1)
print *, ' wall time for ao_tc_int_chemist ', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, ao_two_e_coul, (ao_num, ao_num, ao_num, ao_num) ]
BEGIN_DOC
!
! ao_two_e_coul(k,i,l,j) = ( k i | 1/r12 | l j ) = < l k | 1/r12 | j i >
!
END_DOC
integer :: i, j, k, l
double precision :: integral
double precision, external :: get_ao_two_e_integral
PROVIDE ao_integrals_map
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
enddo
enddo
enddo
enddo
END_PROVIDER
! ---

53
src/tc_bi_ortho/compute_deltamu_right.irp.f Normal file
View File

@ -0,0 +1,53 @@
program compute_deltamu_right
implicit none
my_grid_becke = .True.
my_n_pt_r_grid = 30
my_n_pt_a_grid = 50
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
read_wf = .True.
touch read_wf
PROVIDE N_int
call delta_right()
end
! ---
subroutine delta_right()
implicit none
integer :: k
double precision, allocatable :: delta(:,:)
print *, j1b_type
print *, j1b_pen
print *, mu_erf
allocate( delta(N_det,N_states) )
delta = 0.d0
do k = 1, N_states
!do k = 1, 1
! get < I_left | H_mu - H | psi_right >
!call get_h_bitc_right(psi_det, psi_r_coef_bi_ortho(:,k), N_det, N_int, delta(:,k))
call get_delta_bitc_right(psi_det, psi_r_coef_bi_ortho(:,k), N_det, N_int, delta(:,k))
! order as QMCCHEM
call dset_order(delta(:,k), psi_bilinear_matrix_order, N_det)
enddo
! call ezfio_set_dmc_dress_dmc_delta_h(delta)
deallocate(delta)
return
end subroutine delta_right
! ---

155
src/tc_bi_ortho/dressing_vectors_lr.irp.f Normal file
View File

@ -0,0 +1,155 @@
! ---
subroutine get_delta_bitc_right(psidet, psicoef, ndet, Nint, delta)
BEGIN_DOC
!
! delta(I) = < I_left | H_TC - H | Psi_right >
!
END_DOC
use bitmasks
implicit none
integer, intent(in) :: ndet, Nint
double precision, intent(in) :: psicoef(ndet)
integer(bit_kind), intent(in) :: psidet(Nint,2,ndet)
double precision, intent(out) :: delta(ndet)
integer :: i, j
double precision :: h_mono, h_twoe, h_tot
double precision :: htc_mono, htc_twoe, htc_three, htc_tot
double precision :: delta_mat
print *, ' get_delta_bitc_right ...'
i = 1
j = 1
call htilde_mu_mat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
call hmat_bi_ortho (psidet(1,1,i), psidet(1,1,j), Nint, h_mono, h_twoe, h_tot)
delta = 0.d0
!$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) &
!$OMP SHARED(delta, ndet, psidet, psicoef, Nint) &
!$OMP PRIVATE(i, j, delta_mat, h_mono, h_twoe, h_tot, &
!$OMP htc_mono, htc_twoe, htc_three, htc_tot)
do i = 1, ndet
do j = 1, ndet
! < I | Htilde | J >
call htilde_mu_mat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
! < I | H | J >
call hmat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, h_mono, h_twoe, h_tot)
delta_mat = htc_tot - h_tot
delta(i) = delta(i) + psicoef(j) * delta_mat
enddo
enddo
!$OMP END PARALLEL DO
end subroutine get_delta_bitc_right
! ---
subroutine get_htc_bitc_right(psidet, psicoef, ndet, Nint, delta)
BEGIN_DOC
!
! delta(I) = < I_left | H_TC | Psi_right >
!
END_DOC
use bitmasks
implicit none
integer, intent(in) :: ndet, Nint
double precision, intent(in) :: psicoef(ndet)
integer(bit_kind), intent(in) :: psidet(Nint,2,ndet)
double precision, intent(out) :: delta(ndet)
integer :: i, j
double precision :: htc_mono, htc_twoe, htc_three, htc_tot
print *, ' get_htc_bitc_right ...'
i = 1
j = 1
call htilde_mu_mat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
delta = 0.d0
!$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) &
!$OMP SHARED(delta, ndet, psidet, psicoef, Nint) &
!$OMP PRIVATE(i, j, htc_mono, htc_twoe, htc_three, htc_tot)
do i = 1, ndet
do j = 1, ndet
! < I | Htilde | J >
call htilde_mu_mat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
delta(i) = delta(i) + psicoef(j) * htc_tot
enddo
enddo
!$OMP END PARALLEL DO
end subroutine get_htc_bitc_right
! ---
subroutine get_h_bitc_right(psidet, psicoef, ndet, Nint, delta)
BEGIN_DOC
!
! delta(I) = < I_left | H | Psi_right >
!
END_DOC
use bitmasks
implicit none
integer, intent(in) :: ndet, Nint
double precision, intent(in) :: psicoef(ndet)
integer(bit_kind), intent(in) :: psidet(Nint,2,ndet)
double precision, intent(out) :: delta(ndet)
integer :: i, j
double precision :: h_mono, h_twoe, h_tot
print *, ' get_h_bitc_right ...'
i = 1
j = 1
call hmat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, h_mono, h_twoe, h_tot)
!double precision :: norm
!norm = 0.d0
!do i = 1, ndet
! norm += psicoef(i) * psicoef(i)
!enddo
!print*, ' norm = ', norm
call hmat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, h_mono, h_twoe, h_tot)
delta = 0.d0
! !$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) &
! !$OMP SHARED(delta, ndet, psidet, psicoef, Nint) &
! !$OMP PRIVATE(i, j, h_mono, h_twoe, h_tot)
do i = 1, ndet
do j = 1, ndet
! < I | H | J >
call hmat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, h_mono, h_twoe, h_tot)
delta(i) = delta(i) + psicoef(j) * h_tot
enddo
enddo
! !$OMP END PARALLEL DO
end subroutine get_h_bitc_right
! ---

243
src/tc_bi_ortho/h_biortho.irp.f Normal file
View File

@ -0,0 +1,243 @@
! --
subroutine hmat_bi_ortho(key_j, key_i, Nint, hmono, htwoe, htot)
BEGIN_DOC
!
! < key_j | H | key_i > where | key_j > is developed on the LEFT basis and | key_i > is developed on the RIGHT basis
!
END_DOC
use bitmasks
implicit none
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
double precision, intent(out) :: hmono, htwoe, htot
integer :: degree
hmono = 0.d0
htwoe = 0.d0
htot = 0.d0
call get_excitation_degree(key_i, key_j, degree, Nint)
if(degree .gt. 2) return
if(degree == 0) then
call diag_hmat_bi_ortho(Nint, key_i, hmono, htwoe)
htot = htot + nuclear_repulsion
else if (degree == 1) then
call single_hmat_bi_ortho(Nint, key_j, key_i, hmono, htwoe)
else if(degree == 2) then
call double_hmat_bi_ortho(Nint, key_j, key_i, hmono, htwoe)
endif
htot += hmono + htwoe
return
end subroutine hmat_bi_ortho
! ---
subroutine diag_hmat_bi_ortho(Nint, key_i, hmono, htwoe)
use bitmasks
implicit none
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key_i(Nint,2)
double precision, intent(out) :: hmono, htwoe
integer :: occ(Nint*bit_kind_size,2)
integer :: Ne(2), i, j, ii, jj, ispin, jspin
hmono = 0.d0
htwoe = 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_one_e(ii,ii)
enddo
enddo
! alpha/beta two-body
ispin = 1
jspin = 2
do i = 1, Ne(ispin) ! electron 1
ii = occ(i,ispin)
do j = 1, Ne(jspin) ! electron 2
jj = occ(j,jspin)
htwoe += mo_bi_ortho_coul_e(jj,ii,jj,ii)
enddo
enddo
! 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_coul_e(ii,jj,ii,jj) - mo_bi_ortho_coul_e(ii,jj,jj,ii)
enddo
enddo
! 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_coul_e(ii,jj,ii,jj) - mo_bi_ortho_coul_e(ii,jj,jj,ii)
enddo
enddo
return
end subroutine diag_hmat_bi_ortho
! ---
subroutine single_hmat_bi_ortho(Nint, key_j, key_i, hmono, htwoe)
BEGIN_DOC
!
! < key_j | H | key_i > for single excitation
!
END_DOC
use bitmasks
implicit none
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2)
double precision, intent(out) :: hmono, htwoe
integer :: occ(Nint*bit_kind_size,2)
integer :: Ne(2), i, j, ii, ispin, jspin
integer :: degree,exc(0:2,2,2)
integer :: h1, p1, h2, p2, s1, s2
integer :: other_spin(2)
double precision :: phase
other_spin(1) = 2
other_spin(2) = 1
hmono = 0.d0
htwoe = 0.d0
call get_excitation_degree(key_i, key_j, degree, Nint)
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)
hmono = mo_bi_ortho_one_e(p1,h1) * phase
! alpha/beta two-body
ispin = other_spin(s1)
if(s1 == 1) then
! single alpha
do i = 1, Ne(ispin) ! electron 2
ii = occ(i,ispin)
htwoe += mo_bi_ortho_coul_e(ii,p1,ii,h1)
enddo
else
! single beta
do i = 1, Ne(ispin) ! electron 1
ii = occ(i,ispin)
htwoe += mo_bi_ortho_coul_e(p1,ii,h1,ii)
enddo
endif
! same spin two-body
do i = 1, Ne(s1)
ii = occ(i,s1)
! ( h1 p1 |ii ii ) - ( h1 ii | p1 ii )
htwoe += mo_bi_ortho_coul_e(ii,p1,ii,h1) - mo_bi_ortho_coul_e(p1,ii,ii,h1)
enddo
htwoe *= phase
end subroutine single_hmat_bi_ortho
! ---
subroutine double_hmat_bi_ortho(Nint, key_j, key_i, hmono, htwoe)
BEGIN_DOC
!
! < key_j | H | key_i> for double excitation
!
END_DOC
use bitmasks
implicit none
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2)
double precision, intent(out) :: hmono, htwoe
integer :: occ(Nint*bit_kind_size,2)
integer :: Ne(2), i, j, ii, ispin, jspin
integer :: degree,exc(0:2,2,2)
integer :: h1, p1, h2, p2, s1, s2
integer :: other_spin(2)
double precision :: phase
other_spin(1) = 2
other_spin(2) = 1
call get_excitation_degree(key_i, key_j, degree, Nint)
hmono = 0.d0
htwoe = 0.d0
if(degree .ne. 2) then
return
endif
call bitstring_to_list_ab(key_i, occ, Ne, Nint)
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
htwoe = mo_bi_ortho_coul_e(p2,p1,h2,h1)
else
! same spin two-body
! direct terms exchange terms
htwoe = mo_bi_ortho_coul_e(p2,p1,h2,h1) - mo_bi_ortho_coul_e(p1,p2,h2,h1)
endif
htwoe *= phase
end subroutine double_hmat_bi_ortho
! ---

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

@ -41,6 +41,15 @@ BEGIN_PROVIDER [ double precision, psi_l_coef_bi_ortho, (psi_det_size,N_states)
enddo
deallocate(psi_l_coef_bi_ortho_read)
else
print*, 'psi_l_coef_bi_ortho are psi_coef'
do k=1,N_states
do i=1,N_det
psi_l_coef_bi_ortho(i,k) = psi_coef(i,k)
enddo
enddo
endif
endif
endif
@ -100,6 +109,15 @@ BEGIN_PROVIDER [ double precision, psi_r_coef_bi_ortho, (psi_det_size,N_states)
enddo
deallocate(psi_r_coef_bi_ortho_read)
else
print*, 'psi_r_coef_bi_ortho are psi_coef'
do k=1,N_states
do i=1,N_det
psi_r_coef_bi_ortho(i,k) = psi_coef(i,k)
enddo
enddo
endif
endif
endif

61
src/tc_bi_ortho/select_dets_bi_ortho.irp.f
View File

@ -1,61 +0,0 @@
program tc_bi_ortho
implicit none
BEGIN_DOC
! TODO : Put the documentation of the program here
END_DOC
print *, 'Hello world'
my_grid_becke = .True.
my_n_pt_r_grid = 30
my_n_pt_a_grid = 50
read_wf = .True.
touch read_wf
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
!!!!!!!!!!!!!!! WARNING NO 3-BODY
!!!!!!!!!!!!!!! WARNING NO 3-BODY
three_body_h_tc = .False.
touch three_body_h_tc
!!!!!!!!!!!!!!! WARNING NO 3-BODY
!!!!!!!!!!!!!!! WARNING NO 3-BODY
call routine_test
! call test
end
subroutine routine_test
implicit none
use bitmasks ! you need to include the bitmasks_module.f90 features
integer :: i,n_good,degree
integer(bit_kind), allocatable :: dets(:,:,:)
integer, allocatable :: iorder(:)
double precision, allocatable :: coef(:),coef_new(:,:)
double precision :: thr
allocate(coef(N_det), iorder(N_det))
do i = 1, N_det
iorder(i) = i
call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
if(degree==1)then
coef(i) = -0.5d0
else
coef(i) = -dabs(coef_pt1_bi_ortho(i))
endif
enddo
call dsort(coef,iorder,N_det)
!thr = save_threshold
thr = 1d-15
n_good = 0
do i = 1, N_det
if(dabs(coef(i)).gt.thr)then
n_good += 1
endif
enddo
print*,'n_good = ',n_good
allocate(dets(N_int,2,n_good),coef_new(n_good,n_states))
do i = 1, n_good
dets(:,:,i) = psi_det(:,:,iorder(i))
coef_new(i,:) = psi_coef(iorder(i),:)
enddo
call save_wavefunction_general(n_good,n_states,dets,n_good,coef_new)
end

82
src/tc_bi_ortho/slater_tc.irp.f
View File

@ -1,4 +1,6 @@
!!!!!!
! ---
subroutine htilde_mu_mat_bi_ortho_tot(key_j, key_i, Nint, htot)
BEGIN_DOC
@ -15,66 +17,78 @@ subroutine htilde_mu_mat_bi_ortho_tot(key_j, key_i, Nint, htot)
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2)
double precision, intent(out) :: htot
double precision :: hmono,htwoe,hthree
double precision :: hmono, htwoe, hthree
integer :: degree
call get_excitation_degree(key_j, key_i, degree, Nint)
if(degree.gt.2)then
htot = 0.d0
htot = 0.d0
else
call htilde_mu_mat_bi_ortho(key_j,key_i, Nint, hmono,htwoe,hthree,htot)
call htilde_mu_mat_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree, htot)
endif
end subroutine htilde_mu_mat_tot
end subroutine htilde_mu_mat_bi_ortho_tot
! --
subroutine htilde_mu_mat_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree, htot)
implicit none
use bitmasks
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
!!
! Returns the detail of the matrix element in terms of single, two and three electron contribution.
!! WARNING !!
!
! Non hermitian !!
!
END_DOC
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key_i(Nint,2),key_j(Nint,2)
double precision, intent(out) :: hmono,htwoe,hthree,htot
integer :: degree
hmono = 0.d0
htwoe= 0.d0
htot = 0.d0
use bitmasks
implicit none
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
double precision, intent(out) :: hmono, htwoe, hthree, htot
integer :: degree
hmono = 0.d0
htwoe = 0.d0
htot = 0.d0
hthree = 0.D0
call get_excitation_degree(key_i, key_j, degree, Nint)
if(degree.gt.2)return
if(degree.gt.2) return
if(degree == 0)then
call diag_htilde_mu_mat_bi_ortho(Nint, key_i, hmono, htwoe, htot)
call diag_htilde_mu_mat_bi_ortho(Nint, key_i, hmono, htwoe, htot)
else if (degree == 1)then
call single_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot)
call single_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot)
else if(degree == 2)then
call double_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot)
endif
if(three_body_h_tc) then
if(degree == 2) then
if(.not.double_normal_ord) then
call double_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree)
endif
else if(degree == 1)then
call single_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree)
else if(degree == 0)then
call diag_htilde_three_body_ints_bi_ort(Nint, key_i, hthree)
endif
endif
htot = hmono + htwoe + hthree
if(degree==0)then
htot += nuclear_repulsion
endif
call double_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot)
endif
if(three_body_h_tc) then
if(degree == 2) then
if(.not.double_normal_ord) then
call double_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree)
endif
else if(degree == 1) then
call single_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree)
else if(degree == 0) then
call diag_htilde_three_body_ints_bi_ort(Nint, key_i, hthree)
endif
endif
htot = hmono + htwoe + hthree
if(degree==0) then
htot += nuclear_repulsion
endif
end
! ---
subroutine diag_htilde_mu_mat_bi_ortho(Nint, key_i, hmono, htwoe, htot)
BEGIN_DOC

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

@ -207,6 +207,8 @@ subroutine single_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree)
end
! ---
subroutine double_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree)
BEGIN_DOC
@ -244,7 +246,7 @@ subroutine double_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree)
return
endif
if(core_tc_op)then
if(core_tc_op) then
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))
@ -291,3 +293,6 @@ subroutine double_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree)
endif
hthree *= phase
end
! ---

18
src/tc_keywords/EZFIO.cfg
View File

@ -105,3 +105,21 @@ type: integer
doc: if +1: only positive is selected, -1: only negative is selected, :0 both positive and negative
interface: ezfio,provider,ocaml
default: 0
[j1b_pen]
type: double precision
doc: exponents of the 1-body Jastrow
interface: ezfio
size: (nuclei.nucl_num)
[j1b_coeff]
type: double precision
doc: coeff of the 1-body Jastrow
interface: ezfio
size: (nuclei.nucl_num)
[j1b_type]
type: integer
doc: type of 1-body Jastrow
interface: ezfio, provider, ocaml
default: 0

1
src/tc_keywords/NEED
View File

@ -1 +1,2 @@
ezfio_files
nuclei

113
src/tc_keywords/j1b_pen.irp.f Normal file
View File

@ -0,0 +1,113 @@
! ---
BEGIN_PROVIDER [ double precision, j1b_pen, (nucl_num) ]
BEGIN_DOC
! exponents of the 1-body Jastrow
END_DOC
implicit none
logical :: exists
PROVIDE ezfio_filename
if (mpi_master) then
call ezfio_has_tc_keywords_j1b_pen(exists)
endif
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI
include 'mpif.h'
integer :: ierr
call MPI_BCAST(j1b_pen, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read j1b_pen with MPI'
endif
IRP_ENDIF
if (exists) then
if (mpi_master) then
write(6,'(A)') '.. >>>>> [ IO READ: j1b_pen ] <<<<< ..'
call ezfio_get_tc_keywords_j1b_pen(j1b_pen)
IRP_IF MPI
call MPI_BCAST(j1b_pen, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read j1b_pen with MPI'
endif
IRP_ENDIF
endif
else
integer :: i
do i = 1, nucl_num
j1b_pen(i) = 1d5
enddo
endif
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, j1b_coeff, (nucl_num) ]
BEGIN_DOC
! coefficients of the 1-body Jastrow
END_DOC
implicit none
logical :: exists
PROVIDE ezfio_filename
if (mpi_master) then
call ezfio_has_tc_keywords_j1b_coeff(exists)
endif
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI
include 'mpif.h'
integer :: ierr
call MPI_BCAST(j1b_coeff, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read j1b_coeff with MPI'
endif
IRP_ENDIF
if (exists) then
if (mpi_master) then
write(6,'(A)') '.. >>>>> [ IO READ: j1b_coeff ] <<<<< ..'
call ezfio_get_tc_keywords_j1b_coeff(j1b_coeff)
IRP_IF MPI
call MPI_BCAST(j1b_coeff, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read j1b_coeff with MPI'
endif
IRP_ENDIF
endif
else
integer :: i
do i = 1, nucl_num
j1b_coeff(i) = 0d5
enddo
endif
END_PROVIDER
! ---