PTEROSOR/QuantumPackage
10
0
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-06-30 00:44:37 +02: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

182
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) subroutine phi_j_erf_mu_r_xyz_phi(i,j,mu_in, C_center, xyz_ints)
implicit none implicit none
BEGIN_DOC BEGIN_DOC
@ -49,26 +51,37 @@ subroutine phi_j_erf_mu_r_xyz_phi(i,j,mu_in, C_center, xyz_ints)
enddo enddo
end end
! ---
double precision function phi_j_erf_mu_r_phi(i, j, mu_in, C_center) double precision function phi_j_erf_mu_r_phi(i, j, mu_in, C_center)
implicit none
BEGIN_DOC BEGIN_DOC
! phi_j_erf_mu_r_phi = int dr phi_j(r) [erf(mu |r - C|)/|r-C|] phi_i(r) ! phi_j_erf_mu_r_phi = int dr phi_j(r) [erf(mu |r - C|)/|r-C|] phi_i(r)
END_DOC END_DOC
implicit none
integer, intent(in) :: i,j integer, intent(in) :: i,j
double precision, intent(in) :: mu_in, C_center(3) double precision, intent(in) :: mu_in, C_center(3)
integer :: num_A, power_A(3), num_b, power_B(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 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 phi_j_erf_mu_r_phi = 0.d0
if(ao_overlap_abs(j,i).lt.1.d-12) then if(ao_overlap_abs(j,i).lt.1.d-12) then
return return
endif endif
n_pt_in = n_pt_max_integrals n_pt_in = n_pt_max_integrals
! j ! j
num_A = ao_nucl(j) num_A = ao_nucl(j)
power_A(1:3) = ao_power(j,1:3) power_A(1:3) = ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3) A_center(1:3) = nucl_coord(num_A,1:3)
! i ! i
num_B = ao_nucl(i) num_B = ao_nucl(i)
power_B(1:3) = ao_power(i,1:3) power_B(1:3) = ao_power(i,1:3)
@ -78,14 +91,16 @@ double precision function phi_j_erf_mu_r_phi(i,j,mu_in, C_center)
alpha = ao_expo_ordered_transp(l,j) alpha = ao_expo_ordered_transp(l,j)
do m = 1, ao_prim_num(i) do m = 1, ao_prim_num(i)
beta = ao_expo_ordered_transp(m,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) 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) phi_j_erf_mu_r_phi += contrib * ao_coef_normalized_ordered_transp(l,j) * ao_coef_normalized_ordered_transp(m,i)
enddo 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 implicit none
@ -132,29 +147,41 @@ subroutine erfc_mu_gauss_xyz_ij_ao(i,j,mu, C_center, delta,gauss_ints)
enddo enddo
end end
! ---
subroutine erf_mu_gauss_ij_ao(i, j, mu, C_center, delta, gauss_ints) subroutine erf_mu_gauss_ij_ao(i, j, mu, C_center, delta, gauss_ints)
implicit none
BEGIN_DOC BEGIN_DOC
! gauss_ints(m) = \int dr exp(-delta (r - C)^2 ) * erf(mu |r-r'|)/ |r-r'| * AO_i(r') * AO_j(r') !
! gauss_ints = \int dr exp(-delta (r - C)^2) * erf(mu |r-C|) / |r-C| * AO_i(r) * AO_j(r)
! !
END_DOC END_DOC
implicit none
integer, intent(in) :: i, j integer, intent(in) :: i, j
double precision, intent(in) :: mu, C_center(3), delta double precision, intent(in) :: mu, C_center(3), delta
double precision, intent(out) :: gauss_ints double precision, intent(out) :: gauss_ints
integer :: n_pt_in, l, m
integer :: num_A, power_A(3), num_b, power_B(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 double precision :: alpha, beta, A_center(3), B_center(3), coef
double precision :: integral , erf_mu_gauss double precision :: integral
integer :: n_pt_in,l,m,mm
double precision :: erf_mu_gauss
gauss_ints = 0.d0 gauss_ints = 0.d0
if(ao_overlap_abs(j,i).lt.1.d-12) then if(ao_overlap_abs(j,i).lt.1.d-12) then
return return
endif endif
n_pt_in = n_pt_max_integrals n_pt_in = n_pt_max_integrals
! j ! j
num_A = ao_nucl(j) num_A = ao_nucl(j)
power_A(1:3) = ao_power(j,1:3) power_A(1:3) = ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3) A_center(1:3) = nucl_coord(num_A,1:3)
! i ! i
num_B = ao_nucl(i) num_B = ao_nucl(i)
power_B(1:3) = ao_power(i,1:3) power_B(1:3) = ao_power(i,1:3)
@ -164,63 +191,167 @@ subroutine erf_mu_gauss_ij_ao(i,j,mu, C_center, delta,gauss_ints)
alpha = ao_expo_ordered_transp(l,j) alpha = ao_expo_ordered_transp(l,j)
do m = 1, ao_prim_num(i) do m = 1, ao_prim_num(i)
beta = ao_expo_ordered_transp(m,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 coef = ao_coef_normalized_ordered_transp(l,j) * ao_coef_normalized_ordered_transp(m,i)
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
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) subroutine NAI_pol_x_mult_erf_ao(i_ao, j_ao, mu_in, C_center, ints)
implicit none
BEGIN_DOC BEGIN_DOC
!
! Computes the following integral : ! 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 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 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 | }$. ! $\int_{-\infty}^{infty} dr z * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
END_DOC END_DOC
include 'utils/constants.include.F' include 'utils/constants.include.F'
implicit none
integer, intent(in) :: i_ao, j_ao integer, intent(in) :: i_ao, j_ao
double precision, intent(in) :: mu_in, C_center(3) double precision, intent(in) :: mu_in, C_center(3)
double precision, intent(out) :: ints(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 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 ints = 0.d0
if(ao_overlap_abs(j_ao,i_ao).lt.1.d-12) then if(ao_overlap_abs(j_ao,i_ao).lt.1.d-12) then
return return
endif endif
num_A = ao_nucl(i_ao) num_A = ao_nucl(i_ao)
power_A(1:3) = ao_power(i_ao,1:3) power_A(1:3) = ao_power(i_ao,1:3)
A_center(1:3) = nucl_coord(num_A,1:3) A_center(1:3) = nucl_coord(num_A,1:3)
num_B = ao_nucl(j_ao) num_B = ao_nucl(j_ao)
power_B(1:3) = ao_power(j_ao,1:3) power_B(1:3) = ao_power(j_ao,1:3)
B_center(1:3) = nucl_coord(num_B,1:3) B_center(1:3) = nucl_coord(num_B,1:3)
n_pt_in = n_pt_max_integrals
n_pt_in = n_pt_max_integrals
do i = 1, ao_prim_num(i_ao) do i = 1, ao_prim_num(i_ao)
alpha = ao_expo_ordered_transp(i,i_ao) alpha = ao_expo_ordered_transp(i,i_ao)
do m = 1, 3 do m = 1, 3
power_xA = power_A power_xA = power_A
! x * phi_i(r) = x * (x-Ax)**ax = (x-Ax)**(ax+1) + Ax * (x-Ax)**ax ! x * phi_i(r) = x * (x-Ax)**ax = (x-Ax)**(ax+1) + Ax * (x-Ax)**ax
power_xA(m) += 1 power_xA(m) += 1
do j = 1, ao_prim_num(j_ao) do j = 1, ao_prim_num(j_ao)
beta = ao_expo_ordered_transp(j,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) ! 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) 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) ints(m) += integral * coef
! Second term = Ax * (x-Ax)**(ax) ! 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) 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) ints(m) += A_center(m) * integral * coef
enddo enddo
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) subroutine NAI_pol_x_specify_mult_erf_ao(i_ao,j_ao,mu_in,C_center,m,ints)
implicit none 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) B_center(1:3) = nucl_coord(num_B,1:3)
n_pt_in = n_pt_max_integrals n_pt_in = n_pt_max_integrals
do i = 1, ao_prim_num(i_ao) do i = 1, ao_prim_num(i_ao)
alpha = ao_expo_ordered_transp(i,i_ao) alpha = ao_expo_ordered_transp(i,i_ao)
power_xA = power_A 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 enddo
end end
! ---

110
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 enddo
end end
! ---
! TODO :: PUT CYCLES IN LOOPS
double precision function overlap_gauss_r12_ao(D_center, delta, i, j) double precision function overlap_gauss_r12_ao(D_center, delta, i, j)
implicit none
BEGIN_DOC BEGIN_DOC
! \int dr AO_i(r) AO_j(r) e^{-delta |r-D_center|^2} ! \int dr AO_i(r) AO_j(r) e^{-delta |r-D_center|^2}
END_DOC END_DOC
implicit none
integer, intent(in) :: i, j integer, intent(in) :: i, j
double precision, intent(in) :: D_center(3), delta double precision, intent(in) :: D_center(3), delta
integer :: num_a,num_b,power_A(3), power_B(3),l,k integer :: power_A(3), power_B(3), l, k
double precision :: A_center(3), B_center(3),overlap_gauss_r12,alpha,beta,analytical_j 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 overlap_gauss_r12_ao = 0.d0
if(ao_overlap_abs(j,i).lt.1.d-12) then if(ao_overlap_abs(j,i).lt.1.d-12) then
return return
endif endif
! TODO :: PUT CYCLES IN LOOPS
num_A = ao_nucl(i)
power_A(1:3) = ao_power(i,1:3) 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) power_B(1:3) = ao_power(j,1:3)
B_center(1:3) = nucl_coord(num_B,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) do l = 1, ao_prim_num(i)
alpha = ao_expo_ordered_transp (l,i) alpha = ao_expo_ordered_transp (l,i)
coef1 = ao_coef_normalized_ordered_transp(l,i)
do k = 1, ao_prim_num(j) do k = 1, ao_prim_num(j)
beta = ao_expo_ordered_transp(k,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) 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) overlap_gauss_r12_ao += coef * analytical_j
enddo enddo
enddo enddo
end
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
! ---

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

@ -1,29 +1,44 @@
! ---
BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu, (ao_num, ao_num, n_points_final_grid)] BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu, (ao_num, ao_num, n_points_final_grid)]
implicit none
BEGIN_DOC BEGIN_DOC
!
! int dr phi_i(r) phi_j(r) (erf(mu(R) |r - R| - 1) / |r - R| ! int dr phi_i(r) phi_j(r) (erf(mu(R) |r - R| - 1) / |r - R|
!
END_DOC END_DOC
implicit none
integer :: i, j, ipoint integer :: i, j, ipoint
double precision :: mu,r(3),NAI_pol_mult_erf_ao double precision :: r(3)
double precision :: int_mu, int_coulomb double precision :: int_mu, int_coulomb
provide mu_erf final_grid_points
double precision :: wall0, wall1 double precision :: wall0, wall1
double precision :: NAI_pol_mult_erf_ao
provide mu_erf final_grid_points
call wall_time(wall0) call wall_time(wall0)
v_ij_erf_rk_cst_mu = 0.d0
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,ipoint,mu,r,int_mu,int_coulomb) & !$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 SHARED (ao_num, n_points_final_grid, v_ij_erf_rk_cst_mu, final_grid_points, mu_erf)
!$OMP DO SCHEDULE (dynamic) !$OMP DO SCHEDULE (dynamic)
do ipoint = 1, n_points_final_grid 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(1) = final_grid_points(1,ipoint)
r(2) = final_grid_points(2,ipoint) r(2) = final_grid_points(2,ipoint)
r(3) = final_grid_points(3,ipoint) r(3) = final_grid_points(3,ipoint)
int_mu = NAI_pol_mult_erf_ao(i,j,mu,r)
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) 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 )
v_ij_erf_rk_cst_mu(j,i,ipoint) = int_mu - int_coulomb
enddo enddo
enddo enddo
enddo enddo
@ -31,7 +46,7 @@ BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu, ( ao_num, ao_num,n_points
!$OMP END PARALLEL !$OMP END PARALLEL
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do i = 1, ao_num do i = 2, ao_num
do j = 1, i-1 do j = 1, i-1
v_ij_erf_rk_cst_mu(j,i,ipoint) = v_ij_erf_rk_cst_mu(i,j,ipoint) v_ij_erf_rk_cst_mu(j,i,ipoint) = v_ij_erf_rk_cst_mu(i,j,ipoint)
enddo enddo
@ -40,41 +55,50 @@ BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu, ( ao_num, ao_num,n_points
call wall_time(wall1) call wall_time(wall1)
print*, ' wall time for v_ij_erf_rk_cst_mu ', wall1 - wall0 print*, ' wall time for v_ij_erf_rk_cst_mu ', wall1 - wall0
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_transp, (n_points_final_grid, ao_num, ao_num)] BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_transp, (n_points_final_grid, ao_num, ao_num)]
implicit none
BEGIN_DOC BEGIN_DOC
! int dr phi_i(r) phi_j(r) (erf(mu(R) |r - R| - 1)/|r - R| ! int dr phi_i(r) phi_j(r) (erf(mu(R) |r - R| - 1)/|r - R|
END_DOC END_DOC
implicit none
integer :: i, j, ipoint integer :: i, j, ipoint
double precision :: mu,r(3),NAI_pol_mult_erf_ao double precision :: r(3)
double precision :: int_mu, int_coulomb double precision :: int_mu, int_coulomb
provide mu_erf final_grid_points
double precision :: wall0, wall1 double precision :: wall0, wall1
double precision :: NAI_pol_mult_erf_ao
provide mu_erf final_grid_points
call wall_time(wall0) call wall_time(wall0)
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,ipoint,mu,r,int_mu,int_coulomb) & !$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 SHARED (ao_num,n_points_final_grid,v_ij_erf_rk_cst_mu_transp,final_grid_points,mu_erf)
!$OMP DO SCHEDULE (dynamic) !$OMP DO SCHEDULE (dynamic)
do i = 1, ao_num
do j = i, ao_num
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
mu = mu_erf
r(1) = final_grid_points(1,ipoint) r(1) = final_grid_points(1,ipoint)
r(2) = final_grid_points(2,ipoint) r(2) = final_grid_points(2,ipoint)
r(3) = final_grid_points(3,ipoint) r(3) = final_grid_points(3,ipoint)
int_mu = NAI_pol_mult_erf_ao(i,j,mu,r)
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) 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 )
v_ij_erf_rk_cst_mu_transp(ipoint,j,i) = int_mu - int_coulomb
enddo enddo
enddo enddo
enddo enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
do i = 1, ao_num do i = 2, ao_num
do j = 1, i-1 do j = 1, i-1
do ipoint = 1, n_points_final_grid 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) v_ij_erf_rk_cst_mu_transp(ipoint,j,i) = v_ij_erf_rk_cst_mu_transp(ipoint,i,j)
@ -84,35 +108,43 @@ BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_transp, (n_points_final_gr
call wall_time(wall1) call wall_time(wall1)
print *, ' wall time for v_ij_erf_rk_cst_mu_transp ', wall1 - wall0 print *, ' wall time for v_ij_erf_rk_cst_mu_transp ', wall1 - wall0
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_tmp, (3, ao_num, ao_num, n_points_final_grid)] 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 BEGIN_DOC
! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/|r - R| ! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/|r - R|
END_DOC END_DOC
integer :: i,j,ipoint,m
double precision :: mu,r(3),ints(3),ints_coulomb(3) implicit none
integer :: i, j, ipoint
double precision :: r(3), ints(3), ints_coulomb(3)
double precision :: wall0, wall1 double precision :: wall0, wall1
call wall_time(wall0) call wall_time(wall0)
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,ipoint,mu,r,ints,m,ints_coulomb) & !$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 SHARED (ao_num,n_points_final_grid,x_v_ij_erf_rk_cst_mu_tmp,final_grid_points,mu_erf)
!$OMP DO SCHEDULE (dynamic) !$OMP DO SCHEDULE (dynamic)
do ipoint = 1, n_points_final_grid 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(1) = final_grid_points(1,ipoint)
r(2) = final_grid_points(2,ipoint) r(2) = final_grid_points(2,ipoint)
r(3) = final_grid_points(3,ipoint) r(3) = final_grid_points(3,ipoint)
call NAI_pol_x_mult_erf_ao(i,j,mu,r,ints)
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) 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)) x_v_ij_erf_rk_cst_mu_tmp(1,j,i,ipoint) = ints(1) - ints_coulomb(1)
enddo 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 enddo
@ -120,35 +152,40 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_tmp, (3,ao_num, ao_num,n
!$OMP END PARALLEL !$OMP END PARALLEL
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do i = 1, ao_num do i = 2, ao_num
do j = 1, i-1 do j = 1, i-1
do m = 1, 3 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(m,j,i,ipoint)= x_v_ij_erf_rk_cst_mu_tmp(m,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)
enddo 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 enddo
call wall_time(wall1) call wall_time(wall1)
print*, ' wall time for x_v_ij_erf_rk_cst_mu_tmp', wall1 - wall0 print*, ' wall time for x_v_ij_erf_rk_cst_mu_tmp', wall1 - wall0
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu, (ao_num, ao_num,n_points_final_grid,3)] BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu, (ao_num, ao_num,n_points_final_grid,3)]
implicit none
BEGIN_DOC BEGIN_DOC
! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/|r - R| ! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/|r - R|
END_DOC END_DOC
integer :: i,j,ipoint,m
double precision :: mu,r(3),ints,ints_coulomb implicit none
integer :: i, j, ipoint
double precision :: wall0, wall1 double precision :: wall0, wall1
call wall_time(wall0) call wall_time(wall0)
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do i = 1, ao_num do i = 1, ao_num
do j = 1, ao_num do j = 1, ao_num
do m = 1, 3 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,m)= x_v_ij_erf_rk_cst_mu_tmp(m,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)
enddo 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 enddo
enddo enddo
@ -158,84 +195,99 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu, (ao_num, ao_num,n_point
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_transp, (ao_num, ao_num,3,n_points_final_grid)] 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 BEGIN_DOC
! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/|r - R| ! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/|r - R|
END_DOC END_DOC
integer :: i,j,ipoint,m
double precision :: mu,r(3),ints,ints_coulomb implicit none
integer :: i, j, ipoint
double precision :: wall0, wall1 double precision :: wall0, wall1
call wall_time(wall0) call wall_time(wall0)
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do m = 1, 3
do i = 1, ao_num do i = 1, ao_num
do j = 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) x_v_ij_erf_rk_cst_mu_transp(j,i,1,ipoint) = x_v_ij_erf_rk_cst_mu_tmp(1,j,i,ipoint)
enddo 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 enddo
enddo enddo
call wall_time(wall1) call wall_time(wall1)
print *, ' wall time for x_v_ij_erf_rk_cst_mu_transp', wall1 - wall0 print *, ' wall time for x_v_ij_erf_rk_cst_mu_transp', wall1 - wall0
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_transp_bis, (n_points_final_grid,ao_num, ao_num,3)] 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 BEGIN_DOC
! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/|r - R| ! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/|r - R|
END_DOC END_DOC
integer :: i,j,ipoint,m
double precision :: mu,r(3),ints,ints_coulomb implicit none
integer :: i, j, ipoint
double precision :: wall0, wall1 double precision :: wall0, wall1
call wall_time(wall0) call wall_time(wall0)
do m = 1, 3
do i = 1, ao_num do i = 1, ao_num
do j = 1, ao_num do j = 1, ao_num
do ipoint = 1, n_points_final_grid 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) 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 enddo
enddo enddo
enddo
call wall_time(wall1)
print*,'wall time for x_v_ij_erf_rk_cst_mu_transp',wall1 - wall0
call wall_time(wall1)
print *, ' wall time for x_v_ij_erf_rk_cst_mu_transp_bis', wall1 - wall0
END_PROVIDER 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_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 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) ! 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 ! with m == 1 -> d/dx , m == 2 -> d/dy , m == 3 -> d/dz
END_DOC END_DOC
integer :: i,j,ipoint,m
double precision :: mu,r(3),ints(3),ints_coulomb(3) implicit none
integer :: i, j, ipoint
double precision :: r(3), ints(3), ints_coulomb(3)
double precision :: wall0, wall1 double precision :: wall0, wall1
call wall_time(wall0) call wall_time(wall0)
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,ipoint,mu,r,ints,m,ints_coulomb) & !$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 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) !$OMP DO SCHEDULE (dynamic)
do i = 1, ao_num
do j = 1, ao_num
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
mu = mu_erf
r(1) = final_grid_points(1,ipoint) r(1) = final_grid_points(1,ipoint)
r(2) = final_grid_points(2,ipoint) r(2) = final_grid_points(2,ipoint)
r(3) = final_grid_points(3,ipoint) r(3) = final_grid_points(3,ipoint)
call phi_j_erf_mu_r_dxyz_phi(j,i,mu, r, ints)
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) 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)) d_dx_v_ij_erf_rk_cst_mu_tmp(1,ipoint,j,i) = ints(1) - ints_coulomb(1)
enddo 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 enddo
@ -245,26 +297,31 @@ BEGIN_PROVIDER [ double precision, d_dx_v_ij_erf_rk_cst_mu_tmp, (3,n_points_fina
call wall_time(wall1) call wall_time(wall1)
print *, ' wall time for d_dx_v_ij_erf_rk_cst_mu_tmp', wall1 - wall0 print *, ' wall time for d_dx_v_ij_erf_rk_cst_mu_tmp', wall1 - wall0
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, d_dx_v_ij_erf_rk_cst_mu, (n_points_final_grid, ao_num, ao_num, 3)] 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 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) ! 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 ! with m == 1 -> d/dx , m == 2 -> d/dy , m == 3 -> d/dz
!
END_DOC END_DOC
integer :: i,j,ipoint,m
double precision :: mu,r(3),ints,ints_coulomb implicit none
integer :: i, j, ipoint
double precision :: wall0, wall1 double precision :: wall0, wall1
call wall_time(wall0) call wall_time(wall0)
do i = 1, ao_num do i = 1, ao_num
do j = 1, ao_num do j = 1, ao_num
do m = 1, 3
do ipoint = 1, n_points_final_grid 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) 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)
enddo 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 enddo
@ -274,34 +331,43 @@ BEGIN_PROVIDER [ double precision, d_dx_v_ij_erf_rk_cst_mu, (n_points_final_grid
END_PROVIDER 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)] 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 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) ! 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 ! with m == 1 -> d/dx , m == 2 -> d/dy , m == 3 -> d/dz
!
END_DOC END_DOC
integer :: i,j,ipoint,m
double precision :: mu,r(3),ints(3),ints_coulomb(3) implicit none
integer :: i, j, ipoint
double precision :: r(3), ints(3), ints_coulomb(3)
double precision :: wall0, wall1 double precision :: wall0, wall1
call wall_time(wall0) call wall_time(wall0)
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,ipoint,mu,r,ints,m,ints_coulomb) & !$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 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) !$OMP DO SCHEDULE (dynamic)
do i = 1, ao_num
do j = 1, ao_num
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
mu = mu_erf
r(1) = final_grid_points(1,ipoint) r(1) = final_grid_points(1,ipoint)
r(2) = final_grid_points(2,ipoint) r(2) = final_grid_points(2,ipoint)
r(3) = final_grid_points(3,ipoint) r(3) = final_grid_points(3,ipoint)
call phi_j_erf_mu_r_xyz_dxyz_phi(j,i,mu, r, ints)
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) 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)) x_d_dx_v_ij_erf_rk_cst_mu_tmp(1,ipoint,j,i) = ints(1) - ints_coulomb(1)
enddo 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 enddo
@ -311,26 +377,32 @@ BEGIN_PROVIDER [ double precision, x_d_dx_v_ij_erf_rk_cst_mu_tmp, (3,n_points_fi
call wall_time(wall1) call wall_time(wall1)
print *, ' wall time for x_d_dx_v_ij_erf_rk_cst_mu_tmp', wall1 - wall0 print *, ' wall time for x_d_dx_v_ij_erf_rk_cst_mu_tmp', wall1 - wall0
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, x_d_dx_v_ij_erf_rk_cst_mu, (n_points_final_grid,ao_num, ao_num,3)] 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 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) ! 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 ! with m == 1 -> d/dx , m == 2 -> d/dy , m == 3 -> d/dz
!
END_DOC END_DOC
integer :: i,j,ipoint,m
double precision :: mu,r(3),ints,ints_coulomb implicit none
integer :: i, j, ipoint
double precision :: wall0, wall1 double precision :: wall0, wall1
call wall_time(wall0) call wall_time(wall0)
do i = 1, ao_num do i = 1, ao_num
do j = 1, ao_num do j = 1, ao_num
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do m = 1, 3 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,m)= x_d_dx_v_ij_erf_rk_cst_mu_tmp(m,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)
enddo 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 enddo
enddo enddo
@ -340,3 +412,6 @@ BEGIN_PROVIDER [ double precision, x_d_dx_v_ij_erf_rk_cst_mu, (n_points_final_gr
END_PROVIDER END_PROVIDER
! ---

268
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) subroutine give_all_erf_kl_ao(integrals_ao,mu_in,C_center)
implicit none implicit none
BEGIN_DOC BEGIN_DOC
@ -15,41 +18,109 @@ subroutine give_all_erf_kl_ao(integrals_ao,mu_in,C_center)
enddo enddo
end 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 BEGIN_DOC
!
! Computes the following integral : ! 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 END_DOC
implicit none
integer, intent(in) :: i_ao, j_ao integer, intent(in) :: i_ao, j_ao
double precision, intent(in) :: mu_in, C_center(3) 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 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 :: A_center(3), B_center(3), integral, alpha, beta
double precision :: NAI_pol_mult_erf double precision :: NAI_pol_mult_erf
num_A = ao_nucl(i_ao) num_A = ao_nucl(i_ao)
power_A(1:3) = ao_power(i_ao,1:3) power_A(1:3) = ao_power(i_ao,1:3)
A_center(1:3) = nucl_coord(num_A,1:3) A_center(1:3) = nucl_coord(num_A,1:3)
num_B = ao_nucl(j_ao) num_B = ao_nucl(j_ao)
power_B(1:3) = ao_power(j_ao,1:3) power_B(1:3) = ao_power(j_ao,1:3)
B_center(1:3) = nucl_coord(num_B,1:3) B_center(1:3) = nucl_coord(num_B,1:3)
n_pt_in = n_pt_max_integrals n_pt_in = n_pt_max_integrals
NAI_pol_mult_erf_ao = 0.d0 NAI_pol_mult_erf_ao = 0.d0
do i = 1, ao_prim_num(i_ao) do i = 1, ao_prim_num(i_ao)
alpha = ao_expo_ordered_transp(i,i_ao) alpha = ao_expo_ordered_transp(i,i_ao)
do j = 1, ao_prim_num(j_ao) do j = 1, ao_prim_num(j_ao)
beta = ao_expo_ordered_transp(j,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) 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) NAI_pol_mult_erf_ao += integral * ao_coef_normalized_ordered_transp(j,j_ao) * ao_coef_normalized_ordered_transp(i,i_ao)
enddo enddo
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)
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) 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 BEGIN_DOC
!
! Computes the following integral : ! Computes the following integral :
! !
! .. math:: ! .. math::
@ -59,19 +130,22 @@ double precision function NAI_pol_mult_erf(A_center,B_center,power_A,power_B,alp
! !
END_DOC END_DOC
include 'utils/constants.include.F'
implicit none implicit none
integer, intent(in) :: n_pt_in 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, intent(in) :: power_A(3), power_B(3)
integer :: i,j,k,l,n_pt double precision, intent(in) :: C_center(3), A_center(3), B_center(3), alpha, beta, mu_in
double precision :: P_center(3)
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
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 = alpha + beta
p_inv = 1.d0 / p p_inv = 1.d0 / p
p_inv_2 = 0.5d0 * p_inv p_inv_2 = 0.5d0 * p_inv
@ -89,68 +163,186 @@ double precision function NAI_pol_mult_erf(A_center,B_center,power_A,power_B,alp
NAI_pol_mult_erf = 0.d0 NAI_pol_mult_erf = 0.d0
return return
endif endif
double precision :: p_new
p_new = mu_in / dsqrt(p + mu_in * mu_in) p_new = mu_in / dsqrt(p + mu_in * mu_in)
factor = dexp(-const_factor) factor = dexp(-const_factor)
coeff = dtwo_pi * factor * p_inv * p_new coeff = dtwo_pi * factor * p_inv * p_new
lmax = 20
! print*, "b"
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)) ) 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 const = p * dist_integral * p_new * p_new
if(n_pt == 0) then if(n_pt == 0) then
pouet = rint(0,const) NAI_pol_mult_erf = coeff * rint(0, const)
NAI_pol_mult_erf = coeff * pouet
return return
endif endif
do i = 0, n_pt_in
d(i) = 0.d0
enddo
! 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) ! 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 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 NAI_pol_mult_erf = 0.d0
return return
endif endif
accu = 0.d0
! sum of integrals of type : int {t,[0,1]} exp-(rho.(P-Q)^2 * t^2) * t^i ! 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 do i = 0, n_pt_out, 2
accu += d(i) * rint(i/2, const) accu += d(i) * rint(i/2, const)
enddo enddo
NAI_pol_mult_erf = accu * coeff 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,& ! e^{-alpha1 (r - A1)^2} e^{-alpha2 (r - A2)^2} = e^{-K12} e^{-alpha12 (r - A12)^2}
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) 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 BEGIN_DOC
! Returns the explicit polynomial in terms of the $t$ variable of the ! Returns the explicit polynomial in terms of the $t$ variable of the
! following polynomial: ! 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)$. ! $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 END_DOC
implicit none implicit none
integer, intent(in) :: n_pt_in 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, 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 :: a_x, b_x, a_y, b_y, a_z, b_z
double precision :: d(0:n_pt_in) integer :: n_pt1, n_pt2, n_pt3, dim, i
integer :: n_pt_tmp
double precision :: d1(0:n_pt_in) double precision :: d1(0:n_pt_in)
double precision :: d2(0:n_pt_in) double precision :: d2(0:n_pt_in)
double precision :: d3(0:n_pt_in) double precision :: d3(0:n_pt_in)
double precision :: accu double precision :: accu
double precision :: R1x(0:2), B01(0:2), R1xp(0:2), R2x(0:2)
accu = 0.d0 accu = 0.d0
ASSERT (n_pt_in > 1) 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(0) = (P_center(1) - A_center(1))
R1x(1) = 0.d0 R1x(1) = 0.d0
R1x(2) = -(P_center(1) - C_center(1))* p_new R1x(2) = -(P_center(1) - C_center(1))* p_new
@ -163,19 +355,14 @@ subroutine give_polynomial_mult_center_one_e_erf_opt(A_center,B_center,alpha,bet
R2x(1) = 0.d0 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 !R2x = 0.5 / p - 0.5/p ( t * mu/sqrt(p+mu^2) )^2
do i = 0, n_pt_in do i = 0, n_pt_in
d (i) = 0.d0 d (i) = 0.d0
enddo
do i = 0,n_pt_in
d1(i) = 0.d0 d1(i) = 0.d0
enddo
do i = 0,n_pt_in
d2(i) = 0.d0 d2(i) = 0.d0
enddo
do i = 0,n_pt_in
d3(i) = 0.d0 d3(i) = 0.d0
enddo enddo
integer :: n_pt1,n_pt2,n_pt3,dim,i
n_pt1 = n_pt_in n_pt1 = n_pt_in
n_pt2 = n_pt_in n_pt2 = n_pt_in
n_pt3 = n_pt_in n_pt3 = n_pt_in
@ -209,7 +396,6 @@ subroutine give_polynomial_mult_center_one_e_erf_opt(A_center,B_center,alpha,bet
return return
endif endif
R1x(0) = (P_center(3) - A_center(3)) R1x(0) = (P_center(3) - A_center(3))
R1x(1) = 0.d0 R1x(1) = 0.d0
R1x(2) = -(P_center(3) - C_center(3)) * p_new R1x(2) = -(P_center(3) - C_center(3)) * p_new
@ -229,7 +415,7 @@ subroutine give_polynomial_mult_center_one_e_erf_opt(A_center,B_center,alpha,bet
enddo enddo
return return
endif endif
integer :: n_pt_tmp
n_pt_tmp = 0 n_pt_tmp = 0
call multiply_poly(d1, n_pt1, d2, n_pt2, d, n_pt_tmp) call multiply_poly(d1, n_pt1, d2, n_pt2, d, n_pt_tmp)
do i = 0, n_pt_tmp do i = 0, n_pt_tmp
@ -241,9 +427,9 @@ subroutine give_polynomial_mult_center_one_e_erf_opt(A_center,B_center,alpha,bet
d(i) = d1(i) d(i) = d1(i)
enddo 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,& 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 mo_one_e_ints
ao_many_one_e_ints ao_many_one_e_ints
dft_utils_in_r dft_utils_in_r
tc_keywords

21
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) subroutine compute_ao_tc_sym_two_e_pot_jl(j, l, n_integrals, buffer_i, buffer_value)
use map_module use map_module
BEGIN_DOC BEGIN_DOC
! Parallel client for AO integrals of the TC integrals involving purely hermitian operators ! Parallel client for AO integrals
END_DOC END_DOC
implicit none 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 logical, external :: ao_two_e_integral_zero
double precision :: ao_tc_sym_two_e_pot, ao_two_e_integral_erf 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_2e_j1, j1b_gauss_2e_j2
double precision :: j1b_gauss_coul_debug
double precision :: j1b_gauss_coul_modifdebug
double precision :: j1b_gauss_coulerf
PROVIDE j1b_gauss PROVIDE j1b_type
thr = ao_integrals_threshold thr = ao_integrals_threshold
@ -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_erf = ao_two_e_integral_erf(i, k, j, l)
integral = integral_erf + integral_pot integral = integral_erf + integral_pot
if( j1b_gauss .eq. 1 ) then if( j1b_type .eq. 1 ) then
integral = integral & !print *, ' j1b type 1 is added'
+ j1b_gauss_coulerf(i, k, j, l) 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 endif
if(abs(integral) < thr) then if(abs(integral) < thr) then
cycle cycle
endif 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
! ---

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

@ -27,16 +27,23 @@ END_PROVIDER
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, ao_tc_sym_two_e_pot_cache, (0:64*64*64*64) ] BEGIN_PROVIDER [ double precision, ao_tc_sym_two_e_pot_cache, (0:64*64*64*64) ]
use map_module use map_module
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Cache of |AO| integrals for fast access ! Cache of |AO| integrals for fast access
END_DOC END_DOC
PROVIDE ao_tc_sym_two_e_pot_in_map
integer :: i,j,k,l,ii integer :: i,j,k,l,ii
integer(key_kind) :: idx integer(key_kind) :: idx
real(integral_kind) :: integral real(integral_kind) :: integral
PROVIDE ao_tc_sym_two_e_pot_in_map
!$OMP PARALLEL DO PRIVATE (i,j,k,l,idx,ii,integral) !$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 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 k = ao_tc_sym_two_e_pot_cache_min, ao_tc_sym_two_e_pot_cache_max
@ -59,10 +66,13 @@ BEGIN_PROVIDER [ double precision, ao_tc_sym_two_e_pot_cache, (0:64*64*64*64) ]
END_PROVIDER 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 use map_module
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Create new entry into |AO| map ! Create new entry into |AO| map
END_DOC 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) 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) call map_append(ao_tc_sym_two_e_pot_map, buffer_i, buffer_values, n_integrals)
end 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 use map_module
implicit none implicit none
BEGIN_DOC 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 END_DOC
integer, intent(in) :: i,j,k,l integer, intent(in) :: i,j,k,l
integer(key_kind) :: idx integer(key_kind) :: idx
type(map_type), intent(inout) :: map type(map_type), intent(inout) :: map
integer :: ii integer :: ii
real(integral_kind) :: tmp real(integral_kind) :: tmp
logical, external :: ao_two_e_integral_zero 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 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 !DIR$ FORCEINLINE
! if (ao_two_e_integral_zero(i,j,k,l)) then ! if (ao_two_e_integral_zero(i,j,k,l)) then
if (.False.) then if (.False.) then
@ -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) tmp = ao_tc_sym_two_e_pot_cache(ii)
endif endif
endif endif
result = tmp result = tmp
end end
! ---
subroutine get_many_ao_tc_sym_two_e_pot(j,k,l,sze,out_val) subroutine get_many_ao_tc_sym_two_e_pot(j,k,l,sze,out_val)
use map_module 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
!_____________________________________________________________________________________________________________
!_____________________________________________________________________________________________________________

82
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_PROVIDER [ double precision, j1b_gauss_nonherm, (ao_num,ao_num)]
BEGIN_DOC BEGIN_DOC
! !
! Hermitian part of 1-body Jastrow factow in the |AO| basis set. ! j1b_gauss_nonherm(i,j) = \langle \chi_j | - grad \tau_{1b} \cdot grad | \chi_i \rangle
!
! \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
! !
END_DOC END_DOC
@ -14,7 +13,7 @@ BEGIN_PROVIDER [ double precision, j1b_gauss_nonherm, (ao_num,ao_num)]
integer :: num_A, num_B integer :: num_A, num_B
integer :: power_A(3), power_B(3) integer :: power_A(3), power_B(3)
integer :: i, j, k, l, m 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 :: A_center(3), B_center(3), C_center(3)
double precision :: c1, c double precision :: c1, c
@ -23,7 +22,7 @@ BEGIN_PROVIDER [ double precision, j1b_gauss_nonherm, (ao_num,ao_num)]
double precision :: int_gauss_deriv double precision :: int_gauss_deriv
PROVIDE j1b_gauss_pen PROVIDE j1b_type j1b_pen j1b_coeff
! -------------------------------------------------------------------------------- ! --------------------------------------------------------------------------------
! -- Dummy call to provide everything ! -- 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 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 PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, k, l, m, alpha, beta, gama, & !$OMP PRIVATE (i, j, k, l, m, alpha, beta, gama, &
@ -49,18 +51,14 @@ BEGIN_PROVIDER [ double precision, j1b_gauss_nonherm, (ao_num,ao_num)]
!$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, & !$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, &
!$OMP ao_power, ao_nucl, nucl_coord, & !$OMP ao_power, ao_nucl, nucl_coord, &
!$OMP ao_coef_normalized_ordered_transp, & !$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) !$OMP DO SCHEDULE (dynamic)
do j = 1, ao_num do j = 1, ao_num
num_A = ao_nucl(j) num_A = ao_nucl(j)
power_A(1:3) = ao_power(j,1:3) power_A(1:3) = ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3) A_center(1:3) = nucl_coord(num_A,1:3)
do i = 1, ao_num do i = 1, ao_num
num_B = ao_nucl(i) num_B = ao_nucl(i)
power_B(1:3) = ao_power(i,1:3) power_B(1:3) = ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3) B_center(1:3) = nucl_coord(num_B,1:3)
@ -73,8 +71,7 @@ BEGIN_PROVIDER [ double precision, j1b_gauss_nonherm, (ao_num,ao_num)]
c = 0.d0 c = 0.d0
do k = 1, nucl_num do k = 1, nucl_num
gama = j1b_pen(k)
gama = j1b_gauss_pen(k)
C_center(1:3) = nucl_coord(k,1:3) C_center(1:3) = nucl_coord(k,1:3)
! \langle \chi_A | exp[-gama r_C^2] r_C \cdot grad | \chi_B \rangle ! \langle \chi_A | exp[-gama r_C^2] r_C \cdot grad | \chi_B \rangle
@ -87,15 +84,68 @@ BEGIN_PROVIDER [ double precision, j1b_gauss_nonherm, (ao_num,ao_num)]
j1b_gauss_nonherm(i,j) = j1b_gauss_nonherm(i,j) & j1b_gauss_nonherm(i,j) = j1b_gauss_nonherm(i,j) &
+ ao_coef_normalized_ordered_transp(l,j) & + ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i) * c * ao_coef_normalized_ordered_transp(m,i) * c
enddo enddo
enddo enddo
enddo enddo
enddo enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$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 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 end function int_gauss_deriv
!_____________________________________________________________________________________________________________ !_____________________________________________________________________________________________________________
!_____________________________________________________________________________________________________________ !_____________________________________________________________________________________________________________

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

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

132
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 BEGIN_DOC
! !
@ -35,7 +137,7 @@ double precision function j1b_gauss_coulerf_schwartz(i, j, k, l)
double precision :: schwartz_ij, thr double precision :: schwartz_ij, thr
double precision, allocatable :: schwartz_kl(:,:) double precision, allocatable :: schwartz_kl(:,:)
PROVIDE j1b_gauss_pen PROVIDE j1b_pen
dim1 = n_pt_max_integrals dim1 = n_pt_max_integrals
thr = ao_integrals_threshold * ao_integrals_threshold thr = ao_integrals_threshold * ao_integrals_threshold
@ -73,7 +175,7 @@ double precision function j1b_gauss_coulerf_schwartz(i, j, k, l)
, K_power, L_power, K_center, L_center, dim1 ) , K_power, L_power, K_center, L_center, dim1 )
q1_inv = 1.d0 / qq1 q1_inv = 1.d0 / qq1
call get_cxcycz( dim1, cx, cy, cz & 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 &
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q ) , Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q )
@ -85,7 +187,7 @@ double precision function j1b_gauss_coulerf_schwartz(i, j, k, l)
enddo enddo
j1b_gauss_coulerf_schwartz = 0.d0 j1b_gauss_2e_j1_schwartz = 0.d0
do p = 1, ao_prim_num(i) do p = 1, ao_prim_num(i)
expo1 = ao_expo_ordered_transp(p, i) expo1 = ao_expo_ordered_transp(p, i)
@ -99,7 +201,7 @@ double precision function j1b_gauss_coulerf_schwartz(i, j, k, l)
, I_power, J_power, I_center, J_center, dim1 ) , I_power, J_power, I_center, J_center, dim1 )
p1_inv = 1.d0 / pp1 p1_inv = 1.d0 / pp1
call get_cxcycz( dim1, cx, cy, cz & 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 &
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p ) , P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p )
@ -120,11 +222,11 @@ double precision function j1b_gauss_coulerf_schwartz(i, j, k, l)
, K_power, L_power, K_center, L_center, dim1 ) , K_power, L_power, K_center, L_center, dim1 )
q1_inv = 1.d0 / qq1 q1_inv = 1.d0 / qq1
call get_cxcycz( dim1, cx, cy, cz & 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 &
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q ) , 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 ! s
enddo ! r enddo ! r
enddo ! q enddo ! q
@ -133,13 +235,11 @@ double precision function j1b_gauss_coulerf_schwartz(i, j, k, l)
deallocate( schwartz_kl ) deallocate( schwartz_kl )
return return
end function j1b_gauss_coulerf_schwartz end function j1b_gauss_2e_j1_schwartz
! ---
subroutine get_cxcycz_j1( dim1, cx, cy, cz &
subroutine 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 &
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q ) , Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q )
@ -163,12 +263,14 @@ subroutine get_cxcycz( dim1, cx, cy, cz &
double precision :: general_primitive_integral_erf_shifted double precision :: general_primitive_integral_erf_shifted
double precision :: general_primitive_integral_coul_shifted double precision :: general_primitive_integral_coul_shifted
PROVIDE j1b_pen
cx = 0.d0 cx = 0.d0
cy = 0.d0 cy = 0.d0
cz = 0.d0 cz = 0.d0
do ii = 1, nucl_num do ii = 1, nucl_num
expoii = j1b_gauss_pen(ii) expoii = j1b_pen(ii)
Centerii(1:3) = nucl_coord(ii, 1:3) Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(pp1, P1_center, expoii, Centerii, factii, pp2, P2_center) call gaussian_product(pp1, P1_center, expoii, Centerii, factii, pp2, P2_center)
@ -620,5 +722,7 @@ subroutine get_cxcycz( dim1, cx, cy, cz &
enddo enddo
return 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) rho_old = (p*q)/(p+q)
prefactor = pi_3 * inv_pq_3_2 * fact_p * fact_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 ! browse the gaussians with different expo/coef
!do i = 1, n_gauss_eff_pot-1
aa = expo_gauss_eff_pot(i) aa = expo_gauss_eff_pot(i)
c_a = coef_gauss_eff_pot(i) c_a = coef_gauss_eff_pot(i)
t_a = dsqrt( aa /(rho_old + aa) ) 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
!______________________________________________________________________________________________________________________
!______________________________________________________________________________________________________________________

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

@ -321,6 +321,7 @@ BEGIN_PROVIDER [ double precision, ao_integrals_cache, (0:64*64*64*64) ]
!$OMP END PARALLEL DO !$OMP END PARALLEL DO
END_PROVIDER 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 use map_module

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

13
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 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 i = 1, ao_num
do j = 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 END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_one_e, (mo_num, mo_num)] BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_one_e, (mo_num, mo_num)]
implicit none
BEGIN_DOC BEGIN_DOC
!
! mo_bi_ortho_tc_one_e(k,i) = <MO^L_k | h_c | MO^R_i> ! mo_bi_ortho_tc_one_e(k,i) = <MO^L_k | h_c | MO^R_i>
!
END_DOC END_DOC
integer :: i,k,p,q
implicit none
call ao_to_mo_bi_ortho(ao_one_e_integrals_tc_tot, ao_num, mo_bi_ortho_tc_one_e, mo_num) call ao_to_mo_bi_ortho(ao_one_e_integrals_tc_tot, ao_num, mo_bi_ortho_tc_one_e, mo_num)

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

@ -1,34 +1,51 @@
! ---
! 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_PROVIDER [ double precision, mo_v_ki_bi_ortho_erf_rk_cst_mu, (mo_num, mo_num, n_points_final_grid)]
implicit none
BEGIN_DOC 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 ! 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 ! 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 ! R_ip = the "ip"-th point of the DFT Grid
!
END_DOC END_DOC
implicit none
integer :: ipoint integer :: ipoint
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint) & !$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 SHARED (n_points_final_grid,v_ij_erf_rk_cst_mu,mo_v_ki_bi_ortho_erf_rk_cst_mu)
!$OMP DO SCHEDULE (dynamic) !$OMP DO SCHEDULE (dynamic)
! TODO :: optimization : transform into a DGEMM
do ipoint = 1, n_points_final_grid 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)) 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 enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
mo_v_ki_bi_ortho_erf_rk_cst_mu = mo_v_ki_bi_ortho_erf_rk_cst_mu * 0.5d0 mo_v_ki_bi_ortho_erf_rk_cst_mu = mo_v_ki_bi_ortho_erf_rk_cst_mu * 0.5d0
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, mo_v_ki_bi_ortho_erf_rk_cst_mu_transp, (n_points_final_grid, 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)]
implicit none
BEGIN_DOC 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 ! 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 END_DOC
implicit none
integer :: ipoint, i, j integer :: ipoint, i, j
do i = 1, mo_num do i = 1, mo_num
do j = 1, mo_num do j = 1, mo_num
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
@ -36,46 +53,146 @@ BEGIN_PROVIDER [ double precision, mo_v_ki_bi_ortho_erf_rk_cst_mu_transp, ( n_po
enddo enddo
enddo enddo
enddo enddo
! FREE mo_v_ki_bi_ortho_erf_rk_cst_mu ! FREE mo_v_ki_bi_ortho_erf_rk_cst_mu
END_PROVIDER 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_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 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 ! 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, ! 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 ! R_ip = the "ip"-th point of the DFT Grid
!
END_DOC END_DOC
integer :: ipoint,m
implicit none
integer :: ipoint
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint,m) & !$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 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) !$OMP DO SCHEDULE (dynamic)
! TODO :: optimization : transform into a DGEMM
do ipoint = 1, n_points_final_grid 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)) 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) &
enddo , 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 enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$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_x_v_ki_bi_ortho_erf_rk_cst_mu = 0.5d0 * mo_x_v_ki_bi_ortho_erf_rk_cst_mu
END_PROVIDER 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, int2_grad1_u12_ao_transp, (ao_num, ao_num, 3, n_points_final_grid)]
implicit none implicit none
integer :: i, j, m, ipoint 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 i = 1, mo_num
do j = 1, mo_num do j = 1, mo_num
do m = 1, 3
do ipoint = 1, n_points_final_grid 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) 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)
enddo 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 enddo
enddo enddo
@ -83,10 +200,11 @@ END_PROVIDER
! --- ! ---
BEGIN_PROVIDER [ double precision, x_W_ki_bi_ortho_erf_rk, (n_points_final_grid, 3, mo_num, mo_num)] BEGIN_PROVIDER [ double precision, x_W_ki_bi_ortho_erf_rk, (n_points_final_grid, 3, mo_num, mo_num)]
BEGIN_DOC 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 !
! 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, ! 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,
! !

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

@ -1,20 +1,28 @@
! ---
BEGIN_PROVIDER [ double precision, three_e_3_idx_direct_bi_ort, (mo_num, mo_num, mo_num)] BEGIN_PROVIDER [ double precision, three_e_3_idx_direct_bi_ort, (mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC BEGIN_DOC
!
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the direct terms ! 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> ! 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 ! 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 END_DOC
implicit none
integer :: i, j, m integer :: i, j, m
double precision :: integral, wall1, wall0 double precision :: integral, wall1, wall0
character*(128) :: name_file
three_e_3_idx_direct_bi_ort = 0.d0 three_e_3_idx_direct_bi_ort = 0.d0
print *, ' Providing the three_e_3_idx_direct_bi_ort ...' print *, ' Providing the three_e_3_idx_direct_bi_ort ...'
call wall_time(wall0) 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 provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,m,integral) & !$OMP PRIVATE (i,j,m,integral) &
@ -30,8 +38,6 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_direct_bi_ort, (mo_num, mo_num,
enddo enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$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 i = 1, mo_num
do j = 1, mo_num do j = 1, mo_num
@ -41,25 +47,35 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_direct_bi_ort, (mo_num, mo_num,
enddo enddo
enddo enddo
call wall_time(wall1)
print *, ' wall time for three_e_3_idx_direct_bi_ort', wall1 - wall0
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_3_idx_cycle_1_bi_ort, (mo_num, mo_num, mo_num)] BEGIN_PROVIDER [ double precision, three_e_3_idx_cycle_1_bi_ort, (mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC BEGIN_DOC
!
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the first cyclic permutation ! 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> ! 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 ! 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 END_DOC
implicit none
integer :: i, j, m integer :: i, j, m
double precision :: integral, wall1, wall0 double precision :: integral, wall1, wall0
character*(128) :: name_file
three_e_3_idx_cycle_1_bi_ort = 0.d0 three_e_3_idx_cycle_1_bi_ort = 0.d0
print *, ' Providing the three_e_3_idx_cycle_1_bi_ort ...' print *, ' Providing the three_e_3_idx_cycle_1_bi_ort ...'
call wall_time(wall0) 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 provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,m,integral) & !$OMP PRIVATE (i,j,m,integral) &
@ -75,7 +91,6 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_cycle_1_bi_ort, (mo_num, mo_num
enddo enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
call wall_time(wall1)
do i = 1, mo_num do i = 1, mo_num
do j = 1, mo_num do j = 1, mo_num
@ -84,27 +99,36 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_cycle_1_bi_ort, (mo_num, mo_num
enddo enddo
enddo enddo
enddo enddo
call wall_time(wall1)
print *, ' wall time for three_e_3_idx_cycle_1_bi_ort', wall1 - wall0 print *, ' wall time for three_e_3_idx_cycle_1_bi_ort', wall1 - wall0
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_3_idx_cycle_2_bi_ort, (mo_num, mo_num, mo_num)] BEGIN_PROVIDER [ double precision, three_e_3_idx_cycle_2_bi_ort, (mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC BEGIN_DOC
!
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the second cyclic permutation ! 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> ! 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 ! 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 END_DOC
implicit none
integer :: i, j, m integer :: i, j, m
double precision :: integral, wall1, wall0 double precision :: integral, wall1, wall0
character*(128) :: name_file
three_e_3_idx_cycle_2_bi_ort = 0.d0 three_e_3_idx_cycle_2_bi_ort = 0.d0
print *, ' Providing the three_e_3_idx_cycle_2_bi_ort ...' print *, ' Providing the three_e_3_idx_cycle_2_bi_ort ...'
call wall_time(wall0) 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 provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,m,integral) & !$OMP PRIVATE (i,j,m,integral) &
@ -120,7 +144,7 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_cycle_2_bi_ort, (mo_num, mo_num
enddo enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
call wall_time(wall1)
do i = 1, mo_num do i = 1, mo_num
do j = 1, mo_num do j = 1, mo_num
do m = 1, j do m = 1, j
@ -128,27 +152,36 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_cycle_2_bi_ort, (mo_num, mo_num
enddo enddo
enddo enddo
enddo enddo
call wall_time(wall1)
print *, ' wall time for three_e_3_idx_cycle_2_bi_ort', wall1 - wall0 print *, ' wall time for three_e_3_idx_cycle_2_bi_ort', wall1 - wall0
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_3_idx_exch23_bi_ort, (mo_num, mo_num, mo_num)] BEGIN_PROVIDER [ double precision, three_e_3_idx_exch23_bi_ort, (mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC BEGIN_DOC
!
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the permutations of particle 2 and 3 ! 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> ! 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 ! 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 END_DOC
implicit none
integer :: i, j, m integer :: i, j, m
double precision :: integral, wall1, wall0 double precision :: integral, wall1, wall0
character*(128) :: name_file
three_e_3_idx_exch23_bi_ort = 0.d0 three_e_3_idx_exch23_bi_ort = 0.d0
print*,'Providing the three_e_3_idx_exch23_bi_ort ...' print*,'Providing the three_e_3_idx_exch23_bi_ort ...'
call wall_time(wall0) 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 provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,m,integral) & !$OMP PRIVATE (i,j,m,integral) &
@ -164,6 +197,7 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_exch23_bi_ort, (mo_num, mo_num,
enddo enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
do i = 1, mo_num do i = 1, mo_num
do j = 1, mo_num do j = 1, mo_num
do m = 1, j do m = 1, j
@ -171,28 +205,36 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_exch23_bi_ort, (mo_num, mo_num,
enddo enddo
enddo enddo
enddo enddo
call wall_time(wall1) call wall_time(wall1)
print *, ' wall time for three_e_3_idx_exch23_bi_ort', wall1 - wall0 print *, ' wall time for three_e_3_idx_exch23_bi_ort', wall1 - wall0
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_3_idx_exch13_bi_ort, (mo_num, mo_num, mo_num)] BEGIN_PROVIDER [ double precision, three_e_3_idx_exch13_bi_ort, (mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC BEGIN_DOC
!
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the permutations of particle 1 and 3 ! 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> ! 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 ! 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 END_DOC
implicit none
integer :: i,j,m integer :: i,j,m
double precision :: integral, wall1, wall0 double precision :: integral, wall1, wall0
character*(128) :: name_file
three_e_3_idx_exch13_bi_ort = 0.d0 three_e_3_idx_exch13_bi_ort = 0.d0
print *, ' Providing the three_e_3_idx_exch13_bi_ort ...' print *, ' Providing the three_e_3_idx_exch13_bi_ort ...'
call wall_time(wall0) 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 provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,m,integral) & !$OMP PRIVATE (i,j,m,integral) &
@ -208,6 +250,7 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_exch13_bi_ort, (mo_num, mo_num,
enddo enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
do i = 1, mo_num do i = 1, mo_num
do j = 1, mo_num do j = 1, mo_num
do m = 1, j do m = 1, j
@ -215,28 +258,36 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_exch13_bi_ort, (mo_num, mo_num,
enddo enddo
enddo enddo
enddo enddo
call wall_time(wall1) call wall_time(wall1)
print *, ' wall time for three_e_3_idx_exch13_bi_ort', wall1 - wall0 print *, ' wall time for three_e_3_idx_exch13_bi_ort', wall1 - wall0
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_3_idx_exch12_bi_ort, (mo_num, mo_num, mo_num)] BEGIN_PROVIDER [ double precision, three_e_3_idx_exch12_bi_ort, (mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC BEGIN_DOC
!
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the permutations of particle 1 and 2 ! 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> ! 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 ! 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 END_DOC
implicit none
integer :: i, j, m integer :: i, j, m
double precision :: integral, wall1, wall0 double precision :: integral, wall1, wall0
character*(128) :: name_file
three_e_3_idx_exch12_bi_ort = 0.d0 three_e_3_idx_exch12_bi_ort = 0.d0
print *, ' Providing the three_e_3_idx_exch12_bi_ort ...' print *, ' Providing the three_e_3_idx_exch12_bi_ort ...'
call wall_time(wall0) 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 provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,m,integral) & !$OMP PRIVATE (i,j,m,integral) &
@ -252,29 +303,36 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_exch12_bi_ort, (mo_num, mo_num,
enddo enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
call wall_time(wall1) call wall_time(wall1)
print *, ' wall time for three_e_3_idx_exch12_bi_ort', wall1 - wall0 print *, ' wall time for three_e_3_idx_exch12_bi_ort', wall1 - wall0
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_3_idx_exch12_bi_ort_new, (mo_num, mo_num, mo_num)] BEGIN_PROVIDER [ double precision, three_e_3_idx_exch12_bi_ort_new, (mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC BEGIN_DOC
!
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the permutations of particle 1 and 2 ! 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> ! 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 ! 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 END_DOC
implicit none
integer :: i, j, m integer :: i, j, m
double precision :: integral, wall1, wall0 double precision :: integral, wall1, wall0
character*(128) :: name_file
three_e_3_idx_exch12_bi_ort_new = 0.d0 three_e_3_idx_exch12_bi_ort_new = 0.d0
print *, ' Providing the three_e_3_idx_exch12_bi_ort_new ...' print *, ' Providing the three_e_3_idx_exch12_bi_ort_new ...'
call wall_time(wall0) 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 provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,m,integral) & !$OMP PRIVATE (i,j,m,integral) &
@ -290,6 +348,7 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_exch12_bi_ort_new, (mo_num, mo_
enddo enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
do i = 1, mo_num do i = 1, mo_num
do j = 1, mo_num do j = 1, mo_num
do m = 1, j do m = 1, j
@ -297,8 +356,11 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_exch12_bi_ort_new, (mo_num, mo_
enddo enddo
enddo enddo
enddo enddo
call wall_time(wall1) call wall_time(wall1)
print *, ' wall time for three_e_3_idx_exch12_bi_ort_new', wall1 - wall0 print *, ' wall time for three_e_3_idx_exch12_bi_ort_new', wall1 - wall0
END_PROVIDER END_PROVIDER
! ---

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

@ -1,19 +1,28 @@
! ---
BEGIN_PROVIDER [ double precision, three_e_4_idx_direct_bi_ort, (mo_num, mo_num, mo_num, mo_num)] BEGIN_PROVIDER [ double precision, three_e_4_idx_direct_bi_ort, (mo_num, mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs ! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
! !
! three_e_4_idx_direct_bi_ort(m,j,k,i) = <mjk|-L|mji> ::: notice that i is the RIGHT MO and k is the LEFT MO ! three_e_4_idx_direct_bi_ort(m,j,k,i) = <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 ! 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 END_DOC
implicit none
integer :: i, j, k, m integer :: i, j, k, m
double precision :: integral, wall1, wall0 double precision :: integral, wall1, wall0
character*(128) :: name_file
three_e_4_idx_direct_bi_ort = 0.d0 three_e_4_idx_direct_bi_ort = 0.d0
print *, ' Providing the three_e_4_idx_direct_bi_ort ...' print *, ' Providing the three_e_4_idx_direct_bi_ort ...'
call wall_time(wall0) call wall_time(wall0)
provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,integral) & !$OMP PRIVATE (i,j,k,m,integral) &
@ -31,27 +40,36 @@ BEGIN_PROVIDER [ double precision, three_e_4_idx_direct_bi_ort, (mo_num, mo_num,
enddo enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
call wall_time(wall1) call wall_time(wall1)
print *, ' wall time for three_e_4_idx_direct_bi_ort', wall1 - wall0 print *, ' wall time for three_e_4_idx_direct_bi_ort', wall1 - wall0
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_4_idx_cycle_1_bi_ort, (mo_num, mo_num, mo_num, mo_num)] BEGIN_PROVIDER [ double precision, three_e_4_idx_cycle_1_bi_ort, (mo_num, mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE FIRST CYCLIC PERMUTATION TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs ! 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 ! 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 ! 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 END_DOC
implicit none
integer :: i, j, k, m integer :: i, j, k, m
double precision :: integral, wall1, wall0 double precision :: integral, wall1, wall0
character*(128) :: name_file
three_e_4_idx_cycle_1_bi_ort = 0.d0 three_e_4_idx_cycle_1_bi_ort = 0.d0
print *, ' Providing the three_e_4_idx_cycle_1_bi_ort ...' print *, ' Providing the three_e_4_idx_cycle_1_bi_ort ...'
call wall_time(wall0) call wall_time(wall0)
provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,integral) & !$OMP PRIVATE (i,j,k,m,integral) &
@ -69,28 +87,36 @@ BEGIN_PROVIDER [ double precision, three_e_4_idx_cycle_1_bi_ort, (mo_num, mo_num
enddo enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
call wall_time(wall1) call wall_time(wall1)
print *, ' wall time for three_e_4_idx_cycle_1_bi_ort', wall1 - wall0 print *, ' wall time for three_e_4_idx_cycle_1_bi_ort', wall1 - wall0
END_PROVIDER END_PROVIDER
! --
BEGIN_PROVIDER [ double precision, three_e_4_idx_cycle_2_bi_ort, (mo_num, mo_num, mo_num, mo_num)] BEGIN_PROVIDER [ double precision, three_e_4_idx_cycle_2_bi_ort, (mo_num, mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE FIRST CYCLIC PERMUTATION TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs ! 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 ! 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 ! 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 END_DOC
implicit none
integer :: i, j, k, m integer :: i, j, k, m
double precision :: integral, wall1, wall0 double precision :: integral, wall1, wall0
character*(128) :: name_file
three_e_4_idx_cycle_2_bi_ort = 0.d0 three_e_4_idx_cycle_2_bi_ort = 0.d0
print *, ' Providing the three_e_4_idx_cycle_2_bi_ort ...' print *, ' Providing the three_e_4_idx_cycle_2_bi_ort ...'
call wall_time(wall0) call wall_time(wall0)
provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,integral) & !$OMP PRIVATE (i,j,k,m,integral) &
@ -108,27 +134,36 @@ BEGIN_PROVIDER [ double precision, three_e_4_idx_cycle_2_bi_ort, (mo_num, mo_num
enddo enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
call wall_time(wall1) call wall_time(wall1)
print *, ' wall time for three_e_4_idx_cycle_2_bi_ort', wall1 - wall0 print *, ' wall time for three_e_4_idx_cycle_2_bi_ort', wall1 - wall0
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_4_idx_exch23_bi_ort, (mo_num, mo_num, mo_num, mo_num)] BEGIN_PROVIDER [ double precision, three_e_4_idx_exch23_bi_ort, (mo_num, mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs ! 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 ! 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 ! 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 END_DOC
implicit none
integer :: i, j, k, m integer :: i, j, k, m
double precision :: integral, wall1, wall0 double precision :: integral, wall1, wall0
character*(128) :: name_file
three_e_4_idx_exch23_bi_ort = 0.d0 three_e_4_idx_exch23_bi_ort = 0.d0
print *, ' Providing the three_e_4_idx_exch23_bi_ort ...' print *, ' Providing the three_e_4_idx_exch23_bi_ort ...'
call wall_time(wall0) call wall_time(wall0)
provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,integral) & !$OMP PRIVATE (i,j,k,m,integral) &
@ -146,27 +181,35 @@ BEGIN_PROVIDER [ double precision, three_e_4_idx_exch23_bi_ort, (mo_num, mo_num,
enddo enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
call wall_time(wall1) call wall_time(wall1)
print *, ' wall time for three_e_4_idx_exch23_bi_ort', wall1 - wall0 print *, ' wall time for three_e_4_idx_exch23_bi_ort', wall1 - wall0
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_4_idx_exch13_bi_ort, (mo_num, mo_num, mo_num, mo_num)] BEGIN_PROVIDER [ double precision, three_e_4_idx_exch13_bi_ort, (mo_num, mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs ! 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 ! 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 ! 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 END_DOC
implicit none
integer :: i, j, k, m integer :: i, j, k, m
double precision :: integral, wall1, wall0 double precision :: integral, wall1, wall0
character*(128) :: name_file
three_e_4_idx_exch13_bi_ort = 0.d0 three_e_4_idx_exch13_bi_ort = 0.d0
print *, ' Providing the three_e_4_idx_exch13_bi_ort ...' print *, ' Providing the three_e_4_idx_exch13_bi_ort ...'
call wall_time(wall0) call wall_time(wall0)
provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,integral) & !$OMP PRIVATE (i,j,k,m,integral) &
@ -184,27 +227,36 @@ BEGIN_PROVIDER [ double precision, three_e_4_idx_exch13_bi_ort, (mo_num, mo_num,
enddo enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
call wall_time(wall1) call wall_time(wall1)
print *, ' wall time for three_e_4_idx_exch13_bi_ort', wall1 - wall0 print *, ' wall time for three_e_4_idx_exch13_bi_ort', wall1 - wall0
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_4_idx_exch12_bi_ort, (mo_num, mo_num, mo_num, mo_num)] BEGIN_PROVIDER [ double precision, three_e_4_idx_exch12_bi_ort, (mo_num, mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs ! 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 ! 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 ! 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 END_DOC
implicit none
integer :: i, j, k, m integer :: i, j, k, m
double precision :: integral, wall1, wall0 double precision :: integral, wall1, wall0
character*(128) :: name_file
three_e_4_idx_exch12_bi_ort = 0.d0 three_e_4_idx_exch12_bi_ort = 0.d0
print *, ' Providing the three_e_4_idx_exch12_bi_ort ...' print *, ' Providing the three_e_4_idx_exch12_bi_ort ...'
call wall_time(wall0) call wall_time(wall0)
provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,integral) & !$OMP PRIVATE (i,j,k,m,integral) &
@ -222,7 +274,11 @@ BEGIN_PROVIDER [ double precision, three_e_4_idx_exch12_bi_ort, (mo_num, mo_num,
enddo enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
call wall_time(wall1) call wall_time(wall1)
print *, ' wall time for three_e_4_idx_exch12_bi_ort', wall1 - wall0 print *, ' wall time for three_e_4_idx_exch12_bi_ort', wall1 - wall0
END_PROVIDER END_PROVIDER
! ---

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

@ -1,19 +1,27 @@
! ---
BEGIN_PROVIDER [ double precision, three_e_5_idx_direct_bi_ort, (mo_num, mo_num, mo_num, mo_num, mo_num)] 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 BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs ! 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 ! 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 ! 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 END_DOC
implicit none
integer :: i, j, k, m, l integer :: i, j, k, m, l
double precision :: integral, wall1, wall0 double precision :: integral, wall1, wall0
character*(128) :: name_file
three_e_5_idx_direct_bi_ort = 0.d0 three_e_5_idx_direct_bi_ort = 0.d0
print *, ' Providing the three_e_5_idx_direct_bi_ort ...' print *, ' Providing the three_e_5_idx_direct_bi_ort ...'
call wall_time(wall0) call wall_time(wall0)
provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,l,integral) & !$OMP PRIVATE (i,j,k,m,l,integral) &
@ -33,27 +41,36 @@ BEGIN_PROVIDER [ double precision, three_e_5_idx_direct_bi_ort, (mo_num, mo_num,
enddo enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
call wall_time(wall1) call wall_time(wall1)
print *, ' wall time for three_e_5_idx_direct_bi_ort', wall1 - wall0 print *, ' wall time for three_e_5_idx_direct_bi_ort', wall1 - wall0
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_5_idx_cycle_1_bi_ort, (mo_num, mo_num, mo_num, mo_num, mo_num)] 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 BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE FIRST CYCLIC PERMUTATION TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs ! 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 ! 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 ! 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 END_DOC
implicit none
integer :: i, j, k, m, l integer :: i, j, k, m, l
double precision :: integral, wall1, wall0 double precision :: integral, wall1, wall0
character*(128) :: name_file
three_e_5_idx_cycle_1_bi_ort = 0.d0 three_e_5_idx_cycle_1_bi_ort = 0.d0
print *, ' Providing the three_e_5_idx_cycle_1_bi_ort ...' print *, ' Providing the three_e_5_idx_cycle_1_bi_ort ...'
call wall_time(wall0) call wall_time(wall0)
provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,l,integral) & !$OMP PRIVATE (i,j,k,m,l,integral) &
@ -73,28 +90,36 @@ BEGIN_PROVIDER [ double precision, three_e_5_idx_cycle_1_bi_ort, (mo_num, mo_num
enddo enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
call wall_time(wall1) call wall_time(wall1)
print *, ' wall time for three_e_5_idx_cycle_1_bi_ort', wall1 - wall0 print *, ' wall time for three_e_5_idx_cycle_1_bi_ort', wall1 - wall0
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_5_idx_cycle_2_bi_ort, (mo_num, mo_num, mo_num, mo_num, mo_num)] 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 BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE FIRST CYCLIC PERMUTATION TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs ! 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 ! 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 ! 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 END_DOC
implicit none
integer :: i, j, k, m, l integer :: i, j, k, m, l
double precision :: integral, wall1, wall0 double precision :: integral, wall1, wall0
character*(128) :: name_file
three_e_5_idx_cycle_2_bi_ort = 0.d0 three_e_5_idx_cycle_2_bi_ort = 0.d0
print *, ' Providing the three_e_5_idx_cycle_2_bi_ort ...' print *, ' Providing the three_e_5_idx_cycle_2_bi_ort ...'
call wall_time(wall0) call wall_time(wall0)
provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,l,integral) & !$OMP PRIVATE (i,j,k,m,l,integral) &
@ -114,27 +139,36 @@ BEGIN_PROVIDER [ double precision, three_e_5_idx_cycle_2_bi_ort, (mo_num, mo_num
enddo enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
call wall_time(wall1) call wall_time(wall1)
print *, ' wall time for three_e_5_idx_cycle_2_bi_ort', wall1 - wall0 print *, ' wall time for three_e_5_idx_cycle_2_bi_ort', wall1 - wall0
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_5_idx_exch23_bi_ort, (mo_num, mo_num, mo_num, mo_num, mo_num)] 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 BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs ! 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 ! 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 ! 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 END_DOC
implicit none
integer :: i, j, k, m, l integer :: i, j, k, m, l
double precision :: integral, wall1, wall0 double precision :: integral, wall1, wall0
character*(128) :: name_file
three_e_5_idx_exch23_bi_ort = 0.d0 three_e_5_idx_exch23_bi_ort = 0.d0
print *, ' Providing the three_e_5_idx_exch23_bi_ort ...' print *, ' Providing the three_e_5_idx_exch23_bi_ort ...'
call wall_time(wall0) call wall_time(wall0)
provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,l,integral) & !$OMP PRIVATE (i,j,k,m,l,integral) &
@ -154,27 +188,36 @@ BEGIN_PROVIDER [ double precision, three_e_5_idx_exch23_bi_ort, (mo_num, mo_num,
enddo enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
call wall_time(wall1) call wall_time(wall1)
print *, ' wall time for three_e_5_idx_exch23_bi_ort', wall1 - wall0 print *, ' wall time for three_e_5_idx_exch23_bi_ort', wall1 - wall0
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_5_idx_exch13_bi_ort, (mo_num, mo_num, mo_num, mo_num, mo_num)] 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 BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs ! 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 ! 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 ! 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 END_DOC
implicit none
integer :: i, j, k, m, l integer :: i, j, k, m, l
double precision :: integral, wall1, wall0 double precision :: integral, wall1, wall0
character*(128) :: name_file
three_e_5_idx_exch13_bi_ort = 0.d0 three_e_5_idx_exch13_bi_ort = 0.d0
print *, ' Providing the three_e_5_idx_exch13_bi_ort ...' print *, ' Providing the three_e_5_idx_exch13_bi_ort ...'
call wall_time(wall0) call wall_time(wall0)
provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,l,integral) & !$OMP PRIVATE (i,j,k,m,l,integral) &
@ -194,27 +237,36 @@ BEGIN_PROVIDER [ double precision, three_e_5_idx_exch13_bi_ort, (mo_num, mo_num,
enddo enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
call wall_time(wall1) call wall_time(wall1)
print *, ' wall time for three_e_5_idx_exch13_bi_ort', wall1 - wall0 print *, ' wall time for three_e_5_idx_exch13_bi_ort', wall1 - wall0
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_5_idx_exch12_bi_ort, (mo_num, mo_num, mo_num, mo_num, mo_num)] 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 BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs ! 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 ! 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 ! 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 END_DOC
implicit none
integer :: i, j, k, m, l integer :: i, j, k, m, l
double precision :: integral, wall1, wall0 double precision :: integral, wall1, wall0
character*(128) :: name_file
three_e_5_idx_exch12_bi_ort = 0.d0 three_e_5_idx_exch12_bi_ort = 0.d0
print *, ' Providing the three_e_5_idx_exch12_bi_ort ...' print *, ' Providing the three_e_5_idx_exch12_bi_ort ...'
call wall_time(wall0) call wall_time(wall0)
provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,l,integral) & !$OMP PRIVATE (i,j,k,m,l,integral) &
@ -234,7 +286,11 @@ BEGIN_PROVIDER [ double precision, three_e_5_idx_exch12_bi_ort, (mo_num, mo_num,
enddo enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
call wall_time(wall1) call wall_time(wall1)
print *, ' wall time for three_e_5_idx_exch12_bi_ort', wall1 - wall0 print *, ' wall time for three_e_5_idx_exch12_bi_ort', wall1 - wall0
END_PROVIDER END_PROVIDER
! ---

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

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

@ -1,38 +1,77 @@
! ---
BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_num) ] BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_num) ]
integer :: i,j,k,l
BEGIN_DOC 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 ! 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. ! including both hermitian and non hermitian parts. THIS IS IN CHEMIST NOTATION.
! !
! WARNING :: non hermitian ! acts on "the right functions" (i,j) ! WARNING :: non hermitian ! acts on "the right functions" (i,j)
!
END_DOC END_DOC
double precision :: integral_sym, integral_nsym, get_ao_tc_sym_two_e_pot
PROVIDE ao_tc_sym_two_e_pot_in_map 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 j = 1, ao_num
do l = 1, ao_num do l = 1, ao_num
do i = 1, ao_num do i = 1, ao_num
do k = 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
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) 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 ! 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) integral_nsym = ao_non_hermit_term_chemist(k,i,l,j)
ao_two_e_tc_tot(k,i,l,j) = integral_sym + integral_nsym 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 enddo
endif
END_PROVIDER END_PROVIDER
! ---
double precision function bi_ortho_mo_ints(l, k, j, i) double precision function bi_ortho_mo_ints(l, k, j, i)
implicit none
BEGIN_DOC BEGIN_DOC
!
! <mo^L_k mo^L_l | V^TC(r_12) | mo^R_i mo^R_j> ! <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. ! WARNING :: very naive, super slow, only used to DEBUG.
!
END_DOC END_DOC
implicit none
integer, intent(in) :: i, j, k, l integer, intent(in) :: i, j, k, l
integer :: m, n, p, q integer :: m, n, p, q
bi_ortho_mo_ints = 0.d0 bi_ortho_mo_ints = 0.d0
do m = 1, ao_num do m = 1, ao_num
do p = 1, ao_num do p = 1, ao_num
@ -45,22 +84,27 @@ double precision function bi_ortho_mo_ints(l,k,j,i)
enddo enddo
enddo enddo
end end function bi_ortho_mo_ints
! --- ! ---
BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num, mo_num, mo_num)] ! TODO :: transform into DEGEMM
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(:,:,:,:)
!! 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)) allocate(mo_tmp_1(mo_num,ao_num,ao_num,ao_num))
mo_tmp_1 = 0.d0 mo_tmp_1 = 0.d0
do m = 1, ao_num do m = 1, ao_num
do p = 1, ao_num do p = 1, ao_num
do n = 1, ao_num do n = 1, ao_num
@ -73,8 +117,10 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num,
enddo enddo
enddo enddo
enddo enddo
allocate(mo_tmp_2(mo_num,mo_num,ao_num,ao_num)) allocate(mo_tmp_2(mo_num,mo_num,ao_num,ao_num))
mo_tmp_2 = 0.d0 mo_tmp_2 = 0.d0
do m = 1, ao_num do m = 1, ao_num
do p = 1, ao_num do p = 1, ao_num
do n = 1, ao_num do n = 1, ao_num
@ -88,6 +134,7 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num,
enddo enddo
enddo enddo
deallocate(mo_tmp_1) deallocate(mo_tmp_1)
allocate(mo_tmp_1(mo_num,mo_num,mo_num,ao_num)) allocate(mo_tmp_1(mo_num,mo_num,mo_num,ao_num))
mo_tmp_1 = 0.d0 mo_tmp_1 = 0.d0
do m = 1, ao_num do m = 1, ao_num
@ -102,6 +149,7 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num,
enddo enddo
enddo enddo
deallocate(mo_tmp_2) deallocate(mo_tmp_2)
mo_bi_ortho_tc_two_e_chemist = 0.d0 mo_bi_ortho_tc_two_e_chemist = 0.d0
do m = 1, ao_num do m = 1, ao_num
do j = 1, mo_num do j = 1, mo_num
@ -114,25 +162,37 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num,
enddo enddo
enddo enddo
enddo enddo
deallocate(mo_tmp_1)
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e, (mo_num, mo_num, mo_num, mo_num)] BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e, (mo_num, mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC 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 ! 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 ! the potential V(r_12) contains ALL TWO-E CONTRIBUTION OF THE TC-HAMILTONIAN
!
END_DOC END_DOC
implicit none
integer :: i, j, k, l integer :: i, j, k, l
do j = 1, mo_num do j = 1, mo_num
do i = 1, mo_num do i = 1, mo_num
do l = 1, mo_num do l = 1, mo_num
do k = 1, mo_num do k = 1, mo_num
! (k i|l j) = <k l|V(r_12)|i j> ! < 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) 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
enddo enddo
END_PROVIDER END_PROVIDER
! ---

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

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

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

@ -1,37 +1,160 @@
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 ! TODO : strong optmization : write the loops in a different way
! : for each couple of AO, the gaussian product are done once for all ! : 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
else
gradu_squared_u_ij_mu = 0.d0
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
r(1) = final_grid_points(1,ipoint) r(1) = final_grid_points(1,ipoint)
r(2) = final_grid_points(2,ipoint) r(2) = final_grid_points(2,ipoint)
r(3) = final_grid_points(3,ipoint) r(3) = final_grid_points(3,ipoint)
do j = 1, ao_num do j = 1, ao_num
do i = 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 do igauss = 1, n_max_fit_slat
delta = expo_gauss_1_erf_x_2(igauss) delta = expo_gauss_1_erf_x_2(igauss)
coef = coef_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) gradu_squared_u_ij_mu(i,j,ipoint) += -0.25d0 * coef * overlap_gauss_r12_ao(r, delta, i, j)
enddo enddo
enddo enddo
enddo enddo
enddo enddo
endif
call wall_time(time1) call wall_time(time1)
print*,'Wall time for grad_1_squared_u_ij_mu = ',time1 - time0 print*, ' Wall time for gradu_squared_u_ij_mu = ', time1 - time0
END_PROVIDER 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)] BEGIN_PROVIDER [ double precision, grad_1_squared_u_ij_mu_new, (n_points_final_grid, ao_num, ao_num)]
implicit none implicit none
integer :: ipoint,i,j,m,igauss integer :: ipoint,i,j,m,igauss
@ -130,25 +253,36 @@
BEGIN_PROVIDER [double precision, tc_grad_square_ao, (ao_num, ao_num, ao_num, ao_num)] BEGIN_PROVIDER [double precision, tc_grad_square_ao, (ao_num, ao_num, ao_num, ao_num)]
implicit none
BEGIN_DOC 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> ! 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 END_DOC
implicit none
integer :: ipoint, i, j, k, l integer :: ipoint, i, j, k, l
double precision :: contrib,weight1 double precision :: weight1, ao_ik_r, ao_i_r
double precision, allocatable :: ac_mat(:,:,:,:) double precision, allocatable :: ac_mat(:,:,:,:), bc_mat(:,:,:,:)
allocate(ac_mat(ao_num,ao_num,ao_num,ao_num)) allocate(ac_mat(ao_num,ao_num,ao_num,ao_num))
ac_mat = 0.d0 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 do ipoint = 1, n_points_final_grid
weight1 = final_weight_at_r_vector(ipoint) 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 j = 1, ao_num
do l = 1, ao_num do l = 1, ao_num
do i = 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) )
do k = 1, ao_num bc_mat(k,i,l,j) += ao_ik_r * grad12_j12(l,j,ipoint)
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
enddo enddo
enddo enddo
enddo enddo
@ -159,11 +293,149 @@ BEGIN_PROVIDER [double precision, tc_grad_square_ao, (ao_num, ao_num, ao_num, ao
do l = 1, ao_num do l = 1, ao_num
do i = 1, ao_num do i = 1, ao_num
do k = 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) 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
enddo enddo
deallocate(ac_mat)
deallocate(bc_mat)
END_PROVIDER 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
! ---

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

@ -1,20 +1,26 @@
! ---
BEGIN_PROVIDER [double precision, ao_non_hermit_term_chemist, (ao_num, ao_num, ao_num, ao_num)] BEGIN_PROVIDER [double precision, ao_non_hermit_term_chemist, (ao_num, ao_num, ao_num, ao_num)]
implicit none
BEGIN_DOC BEGIN_DOC
! 1 1 2 2 1 2 1 2 ! 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 ! 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 END_DOC
implicit none
integer :: i, j, k, l, ipoint, m integer :: i, j, k, l, ipoint, m
double precision :: weight1,thr,r(3) double precision :: weight1, r(3)
thr = 1.d-8 double precision :: wall1, wall0
double precision, allocatable :: b_mat(:,:,:,:), ac_mat(:,:,:,:) 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 provide v_ij_erf_rk_cst_mu x_v_ij_erf_rk_cst_mu
! ao_non_hermit_term_chemist = non_h_ints
! return
call wall_time(wall0) 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)) 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 PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,k,m,ipoint,r,weight1) & !$OMP PRIVATE (i,k,m,ipoint,r,weight1) &
@ -37,14 +43,16 @@ END_DOC
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
! (A) b_mat(ipoint,k,i,m) X v_ij_erf_rk_cst_mu(j,l,r1) ! (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) ! 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 ac_mat = 0.d0
do m = 1, 3 do m = 1, 3
! A B^T dim(A,1) dim(B,2) dim(A,2) alpha * A LDA ! 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) 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 enddo
!$OMP PARALLEL & !$OMP PARALLEL &
@ -69,8 +77,10 @@ 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) ! 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 do m = 1, 3
! A B^T dim(A,1) dim(B,2) dim(A,2) alpha * A LDA ! 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 enddo
!$OMP PARALLEL & !$OMP PARALLEL &
@ -90,24 +100,31 @@ END_DOC
enddo enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
double precision :: wall1, wall0
call wall_time(wall1) call wall_time(wall1)
print *, ' wall time dgemm ', wall1 - wall0 print *, ' wall time dgemm ', wall1 - wall0
END_PROVIDER END_PROVIDER
! ---
! TODO :: optimization :: transform into DGEM
BEGIN_PROVIDER [double precision, mo_non_hermit_term_chemist, (mo_num, mo_num, mo_num, mo_num)] BEGIN_PROVIDER [double precision, mo_non_hermit_term_chemist, (mo_num, mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC BEGIN_DOC
! 1 1 2 2 1 2 1 2 ! 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 ! 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 END_DOC
implicit none
integer :: i, j, k, l, m, n, p, q integer :: i, j, k, l, m, n, p, q
double precision, allocatable :: mo_tmp_1(:,:,:,:),mo_tmp_2(:,:,:,:),mo_tmp_3(:,:,:,:) double precision, allocatable :: mo_tmp_1(:,:,:,:), mo_tmp_2(:,:,:,:)
allocate(mo_tmp_1(mo_num,ao_num,ao_num,ao_num)) allocate(mo_tmp_1(mo_num,ao_num,ao_num,ao_num))
! TODO :: optimization :: transform into DGEM
mo_tmp_1 = 0.d0 mo_tmp_1 = 0.d0
do m = 1, ao_num do m = 1, ao_num
do p = 1, ao_num do p = 1, ao_num
do n = 1, ao_num do n = 1, ao_num
@ -121,8 +138,10 @@ END_DOC
enddo enddo
enddo enddo
free ao_non_hermit_term_chemist free ao_non_hermit_term_chemist
allocate(mo_tmp_2(mo_num,mo_num,ao_num,ao_num)) allocate(mo_tmp_2(mo_num,mo_num,ao_num,ao_num))
mo_tmp_2 = 0.d0 mo_tmp_2 = 0.d0
do m = 1, ao_num do m = 1, ao_num
do p = 1, ao_num do p = 1, ao_num
do n = 1, ao_num do n = 1, ao_num
@ -136,8 +155,10 @@ END_DOC
enddo enddo
enddo enddo
deallocate(mo_tmp_1) deallocate(mo_tmp_1)
allocate(mo_tmp_1(mo_num,mo_num,mo_num,ao_num)) allocate(mo_tmp_1(mo_num,mo_num,mo_num,ao_num))
mo_tmp_1 = 0.d0 mo_tmp_1 = 0.d0
do m = 1, ao_num do m = 1, ao_num
do p = 1, ao_num do p = 1, ao_num
do l = 1, mo_num do l = 1, mo_num
@ -150,6 +171,7 @@ END_DOC
enddo enddo
enddo enddo
deallocate(mo_tmp_2) deallocate(mo_tmp_2)
mo_non_hermit_term_chemist = 0.d0 mo_non_hermit_term_chemist = 0.d0
do m = 1, ao_num do m = 1, ao_num
do j = 1, mo_num do j = 1, mo_num
@ -162,17 +184,23 @@ END_DOC
enddo enddo
enddo enddo
enddo enddo
deallocate(mo_tmp_1)
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, mo_non_hermit_term, (mo_num, mo_num, mo_num, mo_num)] BEGIN_PROVIDER [double precision, mo_non_hermit_term, (mo_num, mo_num, mo_num, mo_num)]
implicit none
BEGIN_DOC BEGIN_DOC
! 1 2 1 2 1 2 1 2 ! 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 ! 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 END_DOC
implicit none
integer :: i, j, k, l integer :: i, j, k, l
do j = 1, mo_num do j = 1, mo_num
do i = 1, mo_num do i = 1, mo_num
do l = 1, mo_num do l = 1, mo_num
@ -182,4 +210,8 @@ END_DOC
enddo enddo
enddo enddo
enddo enddo
END_PROVIDER 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
! ---

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

@ -1,56 +1,132 @@
BEGIN_PROVIDER [ double precision, grad_1_u_ij_mu, ( ao_num, ao_num,n_points_final_grid,3)]
implicit none ! ---
BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao, (3, ao_num, ao_num, n_points_final_grid)]
BEGIN_DOC BEGIN_DOC
! grad_1_u_ij_mu(i,j,ipoint) = -1 * \int dr2 \grad_r1 u(r1,r2) \phi_i(r2) \phi_j(r2) !
! 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) ! 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) ! 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 END_DOC
integer :: ipoint,i,j,m
double precision :: r(3) implicit none
do m = 1, 3 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 do ipoint = 1, n_points_final_grid
r(1) = final_grid_points(1,ipoint) x = final_grid_points(1,ipoint)
r(2) = final_grid_points(2,ipoint) y = final_grid_points(2,ipoint)
r(3) = final_grid_points(3,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 j = 1, ao_num
do i = 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)
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
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
grad_1_u_ij_mu *= 0.5d0 enddo
enddo
int2_grad1_u12_ao *= 0.5d0
endif
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, tc_grad_and_lapl_ao, (ao_num, ao_num, ao_num, ao_num)] BEGIN_PROVIDER [double precision, tc_grad_and_lapl_ao, (ao_num, ao_num, ao_num, ao_num)]
implicit none
BEGIN_DOC 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> !
! 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) ! = 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. ! This is obtained by integration by parts.
!
END_DOC END_DOC
integer :: ipoint,i,j,k,l,m
double precision :: contrib,weight1 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(:,:,:,:) double precision, allocatable :: ac_mat(:,:,:,:)
allocate(ac_mat(ao_num,ao_num,ao_num,ao_num)) allocate(ac_mat(ao_num,ao_num,ao_num,ao_num))
ac_mat = 0.d0 ac_mat = 0.d0
do m = 1, 3
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
weight1 = final_weight_at_r_vector(ipoint) 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 j = 1, ao_num
do l = 1, ao_num do l = 1, ao_num
do i = 1, ao_num
do k = 1, ao_num contrib_x = int2_grad1_u12_ao(1,l,j,ipoint) * tmp_x
contrib = weight1 *0.5D0* (aos_in_r_array_transp(ipoint,k) * aos_grad_in_r_array_transp_bis(ipoint,i,m) & contrib_y = int2_grad1_u12_ao(2,l,j,ipoint) * tmp_y
-aos_in_r_array_transp(ipoint,i) * aos_grad_in_r_array_transp_bis(ipoint,k,m) ) contrib_z = int2_grad1_u12_ao(3,l,j,ipoint) * tmp_z
! \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 ac_mat(k,i,l,j) += contrib_x + contrib_y + contrib_z
enddo
enddo enddo
enddo enddo
enddo enddo
@ -67,4 +143,9 @@ BEGIN_PROVIDER [double precision, tc_grad_and_lapl_ao, (ao_num, ao_num, ao_num,
enddo enddo
enddo enddo
deallocate(ac_mat)
END_PROVIDER 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 enddo
deallocate(psi_l_coef_bi_ortho_read) 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 endif
endif endif
@ -100,6 +109,15 @@ BEGIN_PROVIDER [ double precision, psi_r_coef_bi_ortho, (psi_det_size,N_states)
enddo enddo
deallocate(psi_r_coef_bi_ortho_read) 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 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

22
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) subroutine htilde_mu_mat_bi_ortho_tot(key_j, key_i, Nint, htot)
BEGIN_DOC BEGIN_DOC
@ -17,6 +19,7 @@ subroutine htilde_mu_mat_bi_ortho_tot(key_j, key_i, Nint, htot)
double precision, intent(out) :: htot double precision, intent(out) :: htot
double precision :: hmono, htwoe, hthree double precision :: hmono, htwoe, hthree
integer :: degree integer :: degree
call get_excitation_degree(key_j, key_i, degree, Nint) call get_excitation_degree(key_j, key_i, degree, Nint)
if(degree.gt.2)then if(degree.gt.2)then
htot = 0.d0 htot = 0.d0
@ -24,21 +27,26 @@ subroutine htilde_mu_mat_bi_ortho_tot(key_j, key_i, Nint, htot)
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 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) subroutine htilde_mu_mat_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree, htot)
implicit none
use bitmasks
BEGIN_DOC 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 ! <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. ! Returns the detail of the matrix element in terms of single, two and three electron contribution.
!! WARNING !! !! WARNING !!
! !
! Non hermitian !! ! Non hermitian !!
!
END_DOC END_DOC
use bitmasks
implicit none
integer, intent(in) :: Nint integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
double precision, intent(out) :: hmono, htwoe, hthree, htot double precision, intent(out) :: hmono, htwoe, hthree, htot
@ -48,8 +56,10 @@ subroutine htilde_mu_mat_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree, htot
htwoe = 0.d0 htwoe = 0.d0
htot = 0.d0 htot = 0.d0
hthree = 0.D0 hthree = 0.D0
call get_excitation_degree(key_i, key_j, degree, Nint) call get_excitation_degree(key_i, key_j, degree, Nint)
if(degree.gt.2) return if(degree.gt.2) return
if(degree == 0)then 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 else if (degree == 1)then
@ -57,6 +67,7 @@ subroutine htilde_mu_mat_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree, htot
else if(degree == 2)then else if(degree == 2)then
call double_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot) call double_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot)
endif endif
if(three_body_h_tc) then if(three_body_h_tc) then
if(degree == 2) then if(degree == 2) then
if(.not.double_normal_ord) then if(.not.double_normal_ord) then
@ -68,6 +79,7 @@ subroutine htilde_mu_mat_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree, htot
call diag_htilde_three_body_ints_bi_ort(Nint, key_i, hthree) call diag_htilde_three_body_ints_bi_ort(Nint, key_i, hthree)
endif endif
endif endif
htot = hmono + htwoe + hthree htot = hmono + htwoe + hthree
if(degree==0) then if(degree==0) then
htot += nuclear_repulsion htot += nuclear_repulsion
@ -75,6 +87,8 @@ subroutine htilde_mu_mat_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree, htot
end end
! ---
subroutine diag_htilde_mu_mat_bi_ortho(Nint, key_i, hmono, htwoe, htot) subroutine diag_htilde_mu_mat_bi_ortho(Nint, key_i, hmono, htwoe, htot)
BEGIN_DOC BEGIN_DOC

5
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 end
! ---
subroutine double_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree) subroutine double_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree)
BEGIN_DOC BEGIN_DOC
@ -291,3 +293,6 @@ subroutine double_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree)
endif endif
hthree *= phase hthree *= phase
end 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 doc: if +1: only positive is selected, -1: only negative is selected, :0 both positive and negative
interface: ezfio,provider,ocaml interface: ezfio,provider,ocaml
default: 0 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 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
! ---