LCPQ/qp2
9
1
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-06-01 10:15:18 +02:00
Code Releases Activity

added many files and did a lot of documentation for bi-ortho scf
Some checks failed
continuous-integration/drone/push Build is failing
Details

Browse Source
This commit is contained in:
eginer 2022-10-05 00:05:22 +02:00
parent b3f425f57e
commit bdce53d8b1
58 changed files with 10781 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
src/ao_many_one_e_ints/NEED Normal file
View File

@ -0,0 +1,5 @@
ao_one_e_ints
ao_two_e_ints
becke_numerical_grid
mo_one_e_ints
dft_utils_in_r

25
src/ao_many_one_e_ints/README.rst Normal file
View File

@ -0,0 +1,25 @@
==================
ao_many_one_e_ints
==================
This module contains A LOT of one-electron integrals of the type
A_ij( r ) = \int dr' phi_i(r') w(r,r') phi_j(r')
where r is a point in real space.
+) ao_gaus_gauss.irp.f: w(r,r') is a exp(-(r-r')^2) , and can be multiplied by x/y/z
+) ao_erf_gauss.irp.f : w(r,r') is a exp(-(r-r')^2) erf(mu * |r-r'|)/|r-r'| , and can be multiplied by x/y/z
+) ao_erf_gauss_grad.irp.f: w(r,r') is a exp(-(r-r')^2) erf(mu * |r-r'|)/|r-r'| , and can be multiplied by x/y/z, but evaluated with also one gradient of an AO function.
Fit of a Slater function and corresponding integrals
----------------------------------------------------
The file fit_slat_gauss.irp.f contains many useful providers/routines to fit a Slater function with 20 gaussian.
+) coef_fit_slat_gauss : coefficients of the gaussians to fit e^(-x)
+) expo_fit_slat_gauss : exponents of the gaussians to fit e^(-x)
Integrals involving Slater functions : stg_gauss_int.irp.f
Taylor expansion of full correlation factor
-------------------------------------------
In taylor_exp.irp.f you might find interesting integrals of the type
\int dr' exp( e^{-alpha |r-r|' - beta |r-r'|^2}) phi_i(r') phi_j(r')
evaluated as a Taylor expansion of the exponential.

269
src/ao_many_one_e_ints/ao_erf_gauss.irp.f Normal file
View File

@ -0,0 +1,269 @@
subroutine phi_j_erf_mu_r_xyz_phi(i,j,mu_in, C_center, xyz_ints)
implicit none
BEGIN_DOC
! xyz_ints(1/2/3) = int dr phi_j(r) [erf(mu |r - C|)/|r-C|] x/y/z phi_i(r)
!
! where phi_i and phi_j are AOs
END_DOC
integer, intent(in) :: i,j
double precision, intent(in) :: mu_in, C_center(3)
double precision, intent(out):: xyz_ints(3)
integer :: num_A,power_A(3), num_b, power_B(3),power_B_tmp(3)
double precision :: alpha, beta, A_center(3), B_center(3),contrib,NAI_pol_mult_erf
integer :: n_pt_in,l,m,mm
xyz_ints = 0.d0
if(ao_overlap_abs(j,i).lt.1.d-12)then
return
endif
n_pt_in = n_pt_max_integrals
! j
num_A = ao_nucl(j)
power_A(1:3)= ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
! i
num_B = ao_nucl(i)
power_B(1:3)= ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l=1,ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
do m=1,ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
do mm = 1, 3
! (x phi_i ) * phi_j
! x * (x - B_x)^b_x = b_x (x - B_x)^b_x + 1 * (x - B_x)^{b_x+1}
!
! first contribution :: B_x (x - B_x)^b_x :: usual integral multiplied by B_x
power_B_tmp = power_B
contrib = NAI_pol_mult_erf(A_center,B_center,power_A,power_B_tmp,alpha,beta,C_center,n_pt_in,mu_in)
xyz_ints(mm) += contrib * B_center(mm) * ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i)
! second contribution :: 1 * (x - B_x)^(b_x+1) :: integral with b_x=>b_x+1
power_B_tmp(mm) += 1
contrib = NAI_pol_mult_erf(A_center,B_center,power_A,power_B_tmp,alpha,beta,C_center,n_pt_in,mu_in)
xyz_ints(mm) += contrib * 1.d0 * ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i)
enddo
enddo
enddo
end
double precision function phi_j_erf_mu_r_phi(i,j,mu_in, C_center)
implicit none
BEGIN_DOC
! phi_j_erf_mu_r_phi = int dr phi_j(r) [erf(mu |r - C|)/|r-C|] phi_i(r)
END_DOC
integer, intent(in) :: i,j
double precision, intent(in) :: mu_in, C_center(3)
integer :: num_A,power_A(3), num_b, power_B(3)
double precision :: alpha, beta, A_center(3), B_center(3),contrib,NAI_pol_mult_erf
integer :: n_pt_in,l,m
phi_j_erf_mu_r_phi = 0.d0
if(ao_overlap_abs(j,i).lt.1.d-12)then
return
endif
n_pt_in = n_pt_max_integrals
! j
num_A = ao_nucl(j)
power_A(1:3)= ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
! i
num_B = ao_nucl(i)
power_B(1:3)= ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l=1,ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
do m=1,ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
contrib = NAI_pol_mult_erf(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in,mu_in)
phi_j_erf_mu_r_phi += contrib * ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i)
enddo
enddo
end
subroutine erfc_mu_gauss_xyz_ij_ao(i,j,mu, C_center, delta,gauss_ints)
implicit none
BEGIN_DOC
! gauss_ints(m) = \int dr exp(-delta (r - C)^2 ) x/y/z * ( 1 - erf(mu |r-r'|))/ |r-r'| * AO_i(r') * AO_j(r')
!
! with m = 1 ==> x, m = 2, m = 3 ==> z
!
! m = 4 ==> no x/y/z
END_DOC
integer, intent(in) :: i,j
double precision, intent(in) :: mu, C_center(3),delta
double precision, intent(out):: gauss_ints(4)
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 :: xyz_ints(4)
integer :: n_pt_in,l,m,mm
gauss_ints = 0.d0
if(ao_overlap_abs(j,i).lt.1.d-12)then
return
endif
n_pt_in = n_pt_max_integrals
! j
num_A = ao_nucl(j)
power_A(1:3)= ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
! i
num_B = ao_nucl(i)
power_B(1:3)= ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
gauss_ints = 0.d0
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)
call erfc_mu_gauss_xyz(C_center,delta,mu,A_center,B_center,power_A,power_B,alpha,beta,n_pt_in,xyz_ints)
do mm = 1, 4
gauss_ints(mm) += xyz_ints(mm) * ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i)
enddo
enddo
enddo
end
subroutine erf_mu_gauss_ij_ao(i,j,mu, C_center, delta,gauss_ints)
implicit none
BEGIN_DOC
! gauss_ints(m) = \int dr exp(-delta (r - C)^2 ) * erf(mu |r-r'|)/ |r-r'| * AO_i(r') * AO_j(r')
!
END_DOC
integer, intent(in) :: i,j
double precision, intent(in) :: mu, C_center(3),delta
double precision, intent(out):: gauss_ints
integer :: num_A,power_A(3), num_b, power_B(3)
double precision :: alpha, beta, A_center(3), B_center(3),contrib,NAI_pol_mult_erf
double precision :: integral , erf_mu_gauss
integer :: n_pt_in,l,m,mm
gauss_ints = 0.d0
if(ao_overlap_abs(j,i).lt.1.d-12)then
return
endif
n_pt_in = n_pt_max_integrals
! j
num_A = ao_nucl(j)
power_A(1:3)= ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
! i
num_B = ao_nucl(i)
power_B(1:3)= ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l=1,ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
do m=1,ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
if(dabs(ao_coef_normalized_ordered_transp(l,j) * ao_coef_normalized_ordered_transp(m,i)).lt.1.d-12)cycle
integral = erf_mu_gauss(C_center,delta,mu,A_center,B_center,power_A,power_B,alpha,beta,n_pt_in)
gauss_ints += integral * ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i)
enddo
enddo
end
subroutine NAI_pol_x_mult_erf_ao(i_ao,j_ao,mu_in,C_center,ints)
implicit none
BEGIN_DOC
! Computes the following integral :
! $\int_{-\infty}^{infty} dr x * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
! $\int_{-\infty}^{infty} dr y * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
! $\int_{-\infty}^{infty} dr z * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
END_DOC
include 'utils/constants.include.F'
integer, intent(in) :: i_ao,j_ao
double precision, intent(in) :: mu_in, C_center(3)
double precision, intent(out):: ints(3)
double precision :: A_center(3), B_center(3),integral, alpha,beta
double precision :: NAI_pol_mult_erf
integer :: i,j,num_A,num_B, power_A(3), power_B(3), n_pt_in, power_xA(3),m
ints = 0.d0
if(ao_overlap_abs(j_ao,i_ao).lt.1.d-12)then
return
endif
num_A = ao_nucl(i_ao)
power_A(1:3)= ao_power(i_ao,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
num_B = ao_nucl(j_ao)
power_B(1:3)= ao_power(j_ao,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
n_pt_in = n_pt_max_integrals
do i = 1, ao_prim_num(i_ao)
alpha = ao_expo_ordered_transp(i,i_ao)
do m = 1, 3
power_xA = power_A
! x * phi_i(r) = x * (x-Ax)**ax = (x-Ax)**(ax+1) + Ax * (x-Ax)**ax
power_xA(m) += 1
do j = 1, ao_prim_num(j_ao)
beta = ao_expo_ordered_transp(j,j_ao)
! First term = (x-Ax)**(ax+1)
integral = NAI_pol_mult_erf(A_center,B_center,power_xA,power_B,alpha,beta,C_center,n_pt_in,mu_in)
ints(m) += integral * ao_coef_normalized_ordered_transp(j,j_ao)*ao_coef_normalized_ordered_transp(i,i_ao)
! Second term = Ax * (x-Ax)**(ax)
integral = NAI_pol_mult_erf(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in,mu_in)
ints(m) += A_center(m) * integral * ao_coef_normalized_ordered_transp(j,j_ao)*ao_coef_normalized_ordered_transp(i,i_ao)
enddo
enddo
enddo
end
subroutine NAI_pol_x_specify_mult_erf_ao(i_ao,j_ao,mu_in,C_center,m,ints)
implicit none
BEGIN_DOC
! Computes the following integral :
! $\int_{-\infty}^{infty} dr X(m) * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
! if m == 1 X(m) = x, m == 1 X(m) = y, m == 1 X(m) = z
END_DOC
include 'utils/constants.include.F'
integer, intent(in) :: i_ao,j_ao,m
double precision, intent(in) :: mu_in, C_center(3)
double precision, intent(out):: ints
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)
ints = 0.d0
if(ao_overlap_abs(j_ao,i_ao).lt.1.d-12)then
return
endif
num_A = ao_nucl(i_ao)
power_A(1:3)= ao_power(i_ao,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
num_B = ao_nucl(j_ao)
power_B(1:3)= ao_power(j_ao,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
n_pt_in = n_pt_max_integrals
do i = 1, ao_prim_num(i_ao)
alpha = ao_expo_ordered_transp(i,i_ao)
power_xA = power_A
! x * phi_i(r) = x * (x-Ax)**ax = (x-Ax)**(ax+1) + Ax * (x-Ax)**ax
power_xA(m) += 1
do j = 1, ao_prim_num(j_ao)
beta = ao_expo_ordered_transp(j,j_ao)
! First term = (x-Ax)**(ax+1)
integral = NAI_pol_mult_erf(A_center,B_center,power_xA,power_B,alpha,beta,C_center,n_pt_in,mu_in)
ints += integral * ao_coef_normalized_ordered_transp(j,j_ao)*ao_coef_normalized_ordered_transp(i,i_ao)
! Second term = Ax * (x-Ax)**(ax)
integral = NAI_pol_mult_erf(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in,mu_in)
ints += A_center(m) * integral * ao_coef_normalized_ordered_transp(j,j_ao)*ao_coef_normalized_ordered_transp(i,i_ao)
enddo
enddo
end

150
src/ao_many_one_e_ints/ao_erf_gauss_grad.irp.f Normal file
View File

@ -0,0 +1,150 @@
subroutine phi_j_erf_mu_r_dxyz_phi(i,j,mu_in, C_center, dxyz_ints)
implicit none
BEGIN_DOC
! dxyz_ints(1/2/3) = int dr phi_i(r) [erf(mu |r - C|)/|r-C|] d/d(x/y/z) phi_i(r)
END_DOC
integer, intent(in) :: i,j
double precision, intent(in) :: mu_in, C_center(3)
double precision, intent(out):: dxyz_ints(3)
integer :: num_A,power_A(3), num_b, power_B(3),power_B_tmp(3)
double precision :: alpha, beta, A_center(3), B_center(3),contrib,NAI_pol_mult_erf,coef,thr
integer :: n_pt_in,l,m,mm
thr = 1.d-12
dxyz_ints = 0.d0
if(ao_overlap_abs(j,i).lt.thr)then
return
endif
n_pt_in = n_pt_max_integrals
! j
num_A = ao_nucl(j)
power_A(1:3)= ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
! i
num_B = ao_nucl(i)
power_B(1:3)= ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l=1,ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
do m=1,ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
coef = ao_coef_normalized_ordered_transp(l,j) * ao_coef_normalized_ordered_transp(m,i)
if(dabs(coef).lt.thr)cycle
do mm = 1, 3
! (d/dx phi_i ) * phi_j
! d/dx * (x - B_x)^b_x exp(-beta * (x -B_x)^2)= [b_x * (x - B_x)^(b_x - 1) - 2 beta * (x - B_x)^(b_x + 1)] exp(-beta * (x -B_x)^2)
!
! first contribution :: b_x (x - B_x)^(b_x-1) :: integral with b_x=>b_x-1 multiplied by b_x
power_B_tmp = power_B
power_B_tmp(mm) += -1
contrib = NAI_pol_mult_erf(A_center,B_center,power_A,power_B_tmp,alpha,beta,C_center,n_pt_in,mu_in)
dxyz_ints(mm) += contrib * dble(power_B(mm)) * coef
! second contribution :: - 2 beta * (x - B_x)^(b_x + 1) :: integral with b_x=> b_x+1 multiplied by -2 * beta
power_B_tmp = power_B
power_B_tmp(mm) += 1
contrib = NAI_pol_mult_erf(A_center,B_center,power_A,power_B_tmp,alpha,beta,C_center,n_pt_in,mu_in)
dxyz_ints(mm) += contrib * (-2.d0 * beta ) * coef
enddo
enddo
enddo
end
subroutine phi_j_erf_mu_r_dxyz_phi_bis(i,j,mu_in, C_center, dxyz_ints)
implicit none
BEGIN_DOC
! dxyz_ints(1/2/3) = int dr phi_j(r) [erf(mu |r - C|)/|r-C|] d/d(x/y/z) phi_i(r)
END_DOC
integer, intent(in) :: i,j
double precision, intent(in) :: mu_in, C_center(3)
double precision, intent(out):: dxyz_ints(3)
integer :: num_A,power_A(3), num_b, power_B(3),power_B_tmp(3)
double precision :: alpha, beta, A_center(3), B_center(3),contrib,NAI_pol_mult_erf
double precision :: thr, coef
integer :: n_pt_in,l,m,mm,kk
thr = 1.d-12
dxyz_ints = 0.d0
if(ao_overlap_abs(j,i).lt.thr)then
return
endif
n_pt_in = n_pt_max_integrals
! j == A
num_A = ao_nucl(j)
power_A(1:3)= ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
! i == B
num_B = ao_nucl(i)
power_B(1:3)= ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
dxyz_ints = 0.d0
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)
do kk = 1, 2 ! loop over the extra terms induced by the d/dx/y/z * AO(i)
do mm = 1, 3
power_B_tmp = power_B
power_B_tmp(mm) = power_ord_grad_transp(kk,mm,i)
coef = ao_coef_normalized_ordered_transp(l,j) * ao_coef_ord_grad_transp(kk,mm,m,i)
if(dabs(coef).lt.thr)cycle
contrib = NAI_pol_mult_erf(A_center,B_center,power_A,power_B_tmp,alpha,beta,C_center,n_pt_in,mu_in)
dxyz_ints(mm) += contrib * coef
enddo
enddo
enddo
enddo
end
subroutine phi_j_erf_mu_r_xyz_dxyz_phi(i,j,mu_in, C_center, dxyz_ints)
implicit none
BEGIN_DOC
! dxyz_ints(1/2/3) = int dr phi_j(r) x/y/z [erf(mu |r - C|)/|r-C|] d/d(x/y/z) phi_i(r)
END_DOC
integer, intent(in) :: i,j
double precision, intent(in) :: mu_in, C_center(3)
double precision, intent(out):: dxyz_ints(3)
integer :: num_A,power_A(3), num_b, power_B(3),power_B_tmp(3)
double precision :: alpha, beta, A_center(3), B_center(3),contrib,NAI_pol_mult_erf
double precision :: thr, coef
integer :: n_pt_in,l,m,mm,kk
thr = 1.d-12
dxyz_ints = 0.d0
if(ao_overlap_abs(j,i).lt.thr)then
return
endif
n_pt_in = n_pt_max_integrals
! j == A
num_A = ao_nucl(j)
power_A(1:3)= ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
! i == B
num_B = ao_nucl(i)
power_B(1:3)= ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
dxyz_ints = 0.d0
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)
do kk = 1, 4 ! loop over the extra terms induced by the x/y/z * d dx/y/z AO(i)
do mm = 1, 3
power_B_tmp = power_B
power_B_tmp(mm) = power_ord_xyz_grad_transp(kk,mm,i)
coef = ao_coef_normalized_ordered_transp(l,j) * ao_coef_ord_xyz_grad_transp(kk,mm,m,i)
if(dabs(coef).lt.thr)cycle
contrib = NAI_pol_mult_erf(A_center,B_center,power_A,power_B_tmp,alpha,beta,C_center,n_pt_in,mu_in)
dxyz_ints(mm) += contrib * coef
enddo
enddo
enddo
enddo
end

136
src/ao_many_one_e_ints/ao_gaus_gauss.irp.f Normal file
View File

@ -0,0 +1,136 @@
subroutine overlap_gauss_xyz_r12_ao(D_center,delta,i,j,gauss_ints)
implicit none
BEGIN_DOC
! gauss_ints(m) = \int dr AO_i(r) AO_j(r) x/y/z e^{-delta |r-D_center|^2}
!
! with m == 1 ==> x, m == 2 ==> y, m == 3 ==> z
END_DOC
integer, intent(in) :: i,j
double precision, intent(in) :: D_center(3), delta
double precision, intent(out) :: gauss_ints(3)
integer :: num_a,num_b,power_A(3), power_B(3),l,k,m
double precision :: A_center(3), B_center(3),overlap_gauss_r12,alpha,beta,gauss_ints_tmp(3)
gauss_ints = 0.d0
if(ao_overlap_abs(j,i).lt.1.d-12)then
return
endif
num_A = ao_nucl(i)
power_A(1:3)= ao_power(i,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
num_B = ao_nucl(j)
power_B(1:3)= ao_power(j,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l=1,ao_prim_num(i)
alpha = ao_expo_ordered_transp(l,i)
do k=1,ao_prim_num(j)
beta = ao_expo_ordered_transp(k,j)
call overlap_gauss_xyz_r12(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta,gauss_ints_tmp)
do m = 1, 3
gauss_ints(m) += gauss_ints_tmp(m) * ao_coef_normalized_ordered_transp(l,i) &
* ao_coef_normalized_ordered_transp(k,j)
enddo
enddo
enddo
end
double precision function overlap_gauss_xyz_r12_ao_specific(D_center,delta,i,j,mx)
implicit none
BEGIN_DOC
! \int dr AO_i(r) AO_j(r) x/y/z e^{-delta |r-D_center|^2}
!
! with mx == 1 ==> x, mx == 2 ==> y, mx == 3 ==> z
END_DOC
integer, intent(in) :: i,j,mx
double precision, intent(in) :: D_center(3), delta
integer :: num_a,num_b,power_A(3), power_B(3),l,k
double precision :: gauss_int
double precision :: A_center(3), B_center(3),overlap_gauss_r12,alpha,beta
double precision :: overlap_gauss_xyz_r12_specific
overlap_gauss_xyz_r12_ao_specific = 0.d0
if(ao_overlap_abs(j,i).lt.1.d-12)then
return
endif
num_A = ao_nucl(i)
power_A(1:3)= ao_power(i,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
num_B = ao_nucl(j)
power_B(1:3)= ao_power(j,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l=1,ao_prim_num(i)
alpha = ao_expo_ordered_transp(l,i)
do k=1,ao_prim_num(j)
beta = ao_expo_ordered_transp(k,j)
gauss_int = overlap_gauss_xyz_r12_specific(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta,mx)
overlap_gauss_xyz_r12_ao_specific = gauss_int * ao_coef_normalized_ordered_transp(l,i) &
* ao_coef_normalized_ordered_transp(k,j)
enddo
enddo
end
subroutine overlap_gauss_r12_all_ao(D_center,delta,aos_ints)
implicit none
double precision, intent(in) :: D_center(3), delta
double precision, intent(out):: aos_ints(ao_num,ao_num)
integer :: num_a,num_b,power_A(3), power_B(3),l,k,i,j
double precision :: A_center(3), B_center(3),overlap_gauss_r12,alpha,beta,analytical_j
aos_ints = 0.d0
do i = 1, ao_num
do j = 1, ao_num
if(ao_overlap_abs(j,i).lt.1.d-12)cycle
num_A = ao_nucl(i)
power_A(1:3)= ao_power(i,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
num_B = ao_nucl(j)
power_B(1:3)= ao_power(j,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l=1,ao_prim_num(i)
alpha = ao_expo_ordered_transp(l,i)
do k=1,ao_prim_num(j)
beta = ao_expo_ordered_transp(k,j)
analytical_j = overlap_gauss_r12(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta)
aos_ints(j,i) += analytical_j * ao_coef_normalized_ordered_transp(l,i) &
* ao_coef_normalized_ordered_transp(k,j)
enddo
enddo
enddo
enddo
end
double precision function overlap_gauss_r12_ao(D_center,delta,i,j)
implicit none
BEGIN_DOC
! \int dr AO_i(r) AO_j(r) e^{-delta |r-D_center|^2}
END_DOC
integer, intent(in) :: i,j
double precision, intent(in) :: D_center(3), delta
integer :: num_a,num_b,power_A(3), power_B(3),l,k
double precision :: A_center(3), B_center(3),overlap_gauss_r12,alpha,beta,analytical_j
overlap_gauss_r12_ao = 0.d0
if(ao_overlap_abs(j,i).lt.1.d-12)then
return
endif
num_A = ao_nucl(i)
power_A(1:3)= ao_power(i,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
num_B = ao_nucl(j)
power_B(1:3)= ao_power(j,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l=1,ao_prim_num(i)
alpha = ao_expo_ordered_transp(l,i)
do k=1,ao_prim_num(j)
beta = ao_expo_ordered_transp(k,j)
analytical_j = overlap_gauss_r12(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta)
overlap_gauss_r12_ao += analytical_j * ao_coef_normalized_ordered_transp(l,i) &
* ao_coef_normalized_ordered_transp(k,j)
enddo
enddo
end

94
src/ao_many_one_e_ints/fit_slat_gauss.irp.f Normal file
View File

@ -0,0 +1,94 @@
BEGIN_PROVIDER [integer, n_max_fit_slat]
implicit none
BEGIN_DOC
! number of gaussian to fit exp(-x)
!
! I took 20 gaussians from the program bassto.f
END_DOC
n_max_fit_slat = 20
END_PROVIDER
BEGIN_PROVIDER [double precision, coef_fit_slat_gauss, (n_max_fit_slat)]
&BEGIN_PROVIDER [double precision, expo_fit_slat_gauss, (n_max_fit_slat)]
implicit none
include 'constants.include.F'
BEGIN_DOC
! fit the exp(-x) as
!
! \sum_{i = 1, n_max_fit_slat} coef_fit_slat_gauss(i) * exp(-expo_fit_slat_gauss(i) * x**2)
!
! The coefficient are taken from the program bassto.f
END_DOC
expo_fit_slat_gauss(01)=30573.77073000000
coef_fit_slat_gauss(01)=0.00338925525
expo_fit_slat_gauss(02)=5608.45238100000
coef_fit_slat_gauss(02)=0.00536433869
expo_fit_slat_gauss(03)=1570.95673400000
coef_fit_slat_gauss(03)=0.00818702846
expo_fit_slat_gauss(04)=541.39785110000
coef_fit_slat_gauss(04)=0.01202047655
expo_fit_slat_gauss(05)=212.43469630000
coef_fit_slat_gauss(05)=0.01711289568
expo_fit_slat_gauss(06)=91.31444574000
coef_fit_slat_gauss(06)=0.02376001022
expo_fit_slat_gauss(07)=42.04087246000
coef_fit_slat_gauss(07)=0.03229121736
expo_fit_slat_gauss(08)=20.43200443000
coef_fit_slat_gauss(08)=0.04303646818
expo_fit_slat_gauss(09)=10.37775161000
coef_fit_slat_gauss(09)=0.05624657578
expo_fit_slat_gauss(10)=5.46880754500
coef_fit_slat_gauss(10)=0.07192311571
expo_fit_slat_gauss(11)=2.97373529200
coef_fit_slat_gauss(11)=0.08949389001
expo_fit_slat_gauss(12)=1.66144190200
coef_fit_slat_gauss(12)=0.10727599240
expo_fit_slat_gauss(13)=0.95052560820
coef_fit_slat_gauss(13)=0.12178961750
expo_fit_slat_gauss(14)=0.55528683970
coef_fit_slat_gauss(14)=0.12740141870
expo_fit_slat_gauss(15)=0.33043360020
coef_fit_slat_gauss(15)=0.11759168160
expo_fit_slat_gauss(16)=0.19982303230
coef_fit_slat_gauss(16)=0.08953504394
expo_fit_slat_gauss(17)=0.12246840760
coef_fit_slat_gauss(17)=0.05066721317
expo_fit_slat_gauss(18)=0.07575825322
coef_fit_slat_gauss(18)=0.01806363869
expo_fit_slat_gauss(19)=0.04690146243
coef_fit_slat_gauss(19)=0.00305632563
expo_fit_slat_gauss(20)=0.02834749861
coef_fit_slat_gauss(20)=0.00013317513
END_PROVIDER
double precision function slater_fit_gam(x,gam)
implicit none
double precision, intent(in) :: x,gam
BEGIN_DOC
! fit of the function exp(-gam * x) with gaussian functions
END_DOC
integer :: i
slater_fit_gam = 0.d0
do i = 1, n_max_fit_slat
slater_fit_gam += coef_fit_slat_gauss(i) * dexp(-expo_fit_slat_gauss(i) * gam * gam * x * x)
enddo
end
subroutine expo_fit_slater_gam(gam,expos)
implicit none
BEGIN_DOC
! returns the array of the exponents of the gaussians to fit exp(-gam*x)
END_DOC
double precision, intent(in) :: gam
double precision, intent(out) :: expos(n_max_fit_slat)
integer :: i
do i = 1, n_max_fit_slat
expos(i) = expo_fit_slat_gauss(i) * gam * gam
enddo
end

342
src/ao_many_one_e_ints/grad_related_ints.irp.f Normal file
View File

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

195
src/ao_many_one_e_ints/prim_int_erf_gauss.irp.f Normal file
View File

@ -0,0 +1,195 @@
double precision function NAI_pol_mult_erf_gauss_r12(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta,C_center,mu)
BEGIN_DOC
! Computes the following integral R^3 :
!
! .. math::
!
! \int dr (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
! \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$ exp(-delta (r - D)^2 ).
!
END_DOC
implicit none
include 'constants.include.F'
double precision, intent(in) :: D_center(3), delta ! pure gaussian "D"
double precision, intent(in) :: C_center(3),mu ! coulomb center "C" and "mu" in the erf(mu*x)/x function
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
integer, intent(in) :: power_A(3),power_B(3)
double precision :: NAI_pol_mult_erf
! First you multiply the usual gaussian "A" with the gaussian exp(-delta (r - D)^2 )
double precision :: A_new(0:max_dim,3)! new polynom
double precision :: A_center_new(3) ! new center
integer :: iorder_a_new(3) ! i_order(i) = order of the new polynom ==> should be equal to power_A
double precision :: alpha_new ! new exponent
double precision :: fact_a_new ! constant factor
double precision :: accu,coefx,coefy,coefz,coefxy,coefxyz,thr
integer :: d(3),i,lx,ly,lz,iorder_tmp(3)
thr = 1.d-10
d = 0 ! order of the polynom for the gaussian exp(-delta (r - D)^2 ) == 0
! New gaussian/polynom defined by :: new pol new center new expo cst fact new order
call give_explicit_poly_and_gaussian(A_new , A_center_new , alpha_new, fact_a_new , iorder_a_new , &
delta,alpha,d,power_A,D_center,A_center,n_pt_max_integrals)
! The new gaussian exp(-delta (r - D)^2 ) (x-A_x)^a \exp(-\alpha (x-A_x)^2
accu = 0.d0
do lx = 0, iorder_a_new(1)
coefx = A_new(lx,1)
if(dabs(coefx).lt.thr)cycle
iorder_tmp(1) = lx
do ly = 0, iorder_a_new(2)
coefy = A_new(ly,2)
coefxy = coefx * coefy
if(dabs(coefxy).lt.thr)cycle
iorder_tmp(2) = ly
do lz = 0, iorder_a_new(3)
coefz = A_new(lz,3)
coefxyz = coefxy * coefz
if(dabs(coefxyz).lt.thr)cycle
iorder_tmp(3) = lz
accu += coefxyz * NAI_pol_mult_erf(A_center_new,B_center,iorder_tmp,power_B,alpha_new,beta,C_center,n_pt_max_integrals,mu)
enddo
enddo
enddo
NAI_pol_mult_erf_gauss_r12 = fact_a_new * accu
end
subroutine erfc_mu_gauss_xyz(D_center,delta,mu,A_center,B_center,power_A,power_B,alpha,beta,n_pt_in,xyz_ints)
BEGIN_DOC
! Computes the following integral :
!
! .. math::
!
! \int dr exp(-delta (r - D)^2 ) x/y/z * (1 - erf(mu |r-r'|))/ |r-r'| * (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
!
! xyz_ints(1) = x , xyz_ints(2) = y, xyz_ints(3) = z, xyz_ints(4) = x^0
END_DOC
implicit none
include 'constants.include.F'
double precision, intent(in) :: D_center(3), delta,mu ! pure gaussian "D" and mu parameter
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
integer, intent(in) :: power_A(3),power_B(3),n_pt_in
double precision, intent(out) :: xyz_ints(4)
double precision :: NAI_pol_mult_erf
! First you multiply the usual gaussian "A" with the gaussian exp(-delta (r - D)^2 )
double precision :: A_new(0:max_dim,3)! new polynom
double precision :: A_center_new(3) ! new center
integer :: iorder_a_new(3) ! i_order(i) = order of the new polynom ==> should be equal to power_A
double precision :: alpha_new ! new exponent
double precision :: fact_a_new ! constant factor
double precision :: accu,coefx,coefy,coefz,coefxy,coefxyz,thr,contrib,contrib_inf,mu_inf
integer :: d(3),i,lx,ly,lz,iorder_tmp(3),dim1,mm
integer :: power_B_tmp(3)
dim1=100
mu_inf = 1.d+10
thr = 1.d-10
d = 0 ! order of the polynom for the gaussian exp(-delta (r - D)^2 ) == 0
! New gaussian/polynom defined by :: new pol new center new expo cst fact new order
call give_explicit_poly_and_gaussian(A_new , A_center_new , alpha_new, fact_a_new , iorder_a_new , &
delta,alpha,d,power_A,D_center,A_center,n_pt_max_integrals)
! The new gaussian exp(-delta (r - D)^2 ) (x-A_x)^a \exp(-\alpha (x-A_x)^2
xyz_ints = 0.d0
do lx = 0, iorder_a_new(1)
coefx = A_new(lx,1)
if(dabs(coefx).lt.thr)cycle
iorder_tmp(1) = lx
do ly = 0, iorder_a_new(2)
coefy = A_new(ly,2)
coefxy = coefx * coefy
if(dabs(coefxy).lt.thr)cycle
iorder_tmp(2) = ly
do lz = 0, iorder_a_new(3)
coefz = A_new(lz,3)
coefxyz = coefxy * coefz
if(dabs(coefxyz).lt.thr)cycle
iorder_tmp(3) = lz
power_B_tmp = power_B
contrib = NAI_pol_mult_erf(A_center_new,B_center,iorder_tmp,power_B_tmp,alpha_new,beta,D_center,n_pt_in,mu)
contrib_inf = NAI_pol_mult_erf(A_center_new,B_center,iorder_tmp,power_B_tmp,alpha_new,beta,D_center,n_pt_in,mu_inf)
xyz_ints(4) += (contrib_inf - contrib) * coefxyz ! usual term with no x/y/z
do mm = 1, 3
! (x phi_i ) * phi_j
! x * (x - B_x)^b_x = B_x (x - B_x)^b_x + 1 * (x - B_x)^{b_x+1}
!
! first contribution :: B_x (x - B_x)^b_x :: usual integral multiplied by B_x
power_B_tmp = power_B
contrib_inf = NAI_pol_mult_erf(A_center_new,B_center,iorder_tmp,power_B_tmp,alpha_new,beta,D_center,n_pt_in,mu_inf)
contrib = NAI_pol_mult_erf(A_center_new,B_center,iorder_tmp,power_B_tmp,alpha_new,beta,D_center,n_pt_in,mu)
xyz_ints(mm) += (contrib_inf - contrib) * B_center(mm) * coefxyz
!
! second contribution :: (x - B_x)^(b_x+1) :: integral with b_x=>b_x+1
power_B_tmp(mm) += 1
contrib = NAI_pol_mult_erf(A_center_new,B_center,iorder_tmp,power_B_tmp,alpha_new,beta,D_center,n_pt_in,mu)
contrib_inf = NAI_pol_mult_erf(A_center_new,B_center,iorder_tmp,power_B_tmp,alpha_new,beta,D_center,n_pt_in,mu_inf)
xyz_ints(mm) += (contrib_inf - contrib) * coefxyz
enddo
enddo
enddo
enddo
xyz_ints *= fact_a_new
end
double precision function erf_mu_gauss(D_center,delta,mu,A_center,B_center,power_A,power_B,alpha,beta,n_pt_in)
BEGIN_DOC
! Computes the following integral :
!
! .. math::
!
! \int dr exp(-delta (r - D)^2 ) erf(mu*|r-r'|)/ |r-r'| * (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
!
END_DOC
implicit none
include 'constants.include.F'
double precision, intent(in) :: D_center(3), delta,mu ! pure gaussian "D" and mu parameter
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
integer, intent(in) :: power_A(3),power_B(3),n_pt_in
double precision :: NAI_pol_mult_erf
! First you multiply the usual gaussian "A" with the gaussian exp(-delta (r - D)^2 )
double precision :: A_new(0:max_dim,3)! new polynom
double precision :: A_center_new(3) ! new center
integer :: iorder_a_new(3) ! i_order(i) = order of the new polynom ==> should be equal to power_A
double precision :: alpha_new ! new exponent
double precision :: fact_a_new ! constant factor
double precision :: accu,coefx,coefy,coefz,coefxy,coefxyz,thr,contrib,contrib_inf,mu_inf
integer :: d(3),i,lx,ly,lz,iorder_tmp(3),dim1,mm
dim1=100
mu_inf = 1.d+10
thr = 1.d-10
d = 0 ! order of the polynom for the gaussian exp(-delta (r - D)^2 ) == 0
! New gaussian/polynom defined by :: new pol new center new expo cst fact new order
call give_explicit_poly_and_gaussian(A_new , A_center_new , alpha_new, fact_a_new , iorder_a_new , &
delta,alpha,d,power_A,D_center,A_center,n_pt_max_integrals)
! The new gaussian exp(-delta (r - D)^2 ) (x-A_x)^a \exp(-\alpha (x-A_x)^2
erf_mu_gauss = 0.d0
do lx = 0, iorder_a_new(1)
coefx = A_new(lx,1)
if(dabs(coefx).lt.thr)cycle
iorder_tmp(1) = lx
do ly = 0, iorder_a_new(2)
coefy = A_new(ly,2)
coefxy = coefx * coefy
if(dabs(coefxy).lt.thr)cycle
iorder_tmp(2) = ly
do lz = 0, iorder_a_new(3)
coefz = A_new(lz,3)
coefxyz = coefxy * coefz
if(dabs(coefxyz).lt.thr)cycle
iorder_tmp(3) = lz
contrib = NAI_pol_mult_erf(A_center_new,B_center,iorder_tmp,power_B,alpha_new,beta,D_center,n_pt_in,mu)
erf_mu_gauss += contrib * coefxyz
enddo
enddo
enddo
erf_mu_gauss *= fact_a_new
end

191
src/ao_many_one_e_ints/prim_int_gauss_gauss.irp.f Normal file
View File

@ -0,0 +1,191 @@
double precision function overlap_gauss_r12(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta)
BEGIN_DOC
! Computes the following integral :
!
! .. math::
!
! \int dr exp(-delta (r - D)^2 ) (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
!
END_DOC
implicit none
include 'constants.include.F'
double precision, intent(in) :: D_center(3), delta ! pure gaussian "D"
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
integer, intent(in) :: power_A(3),power_B(3)
double precision :: overlap_x,overlap_y,overlap_z,overlap
! First you multiply the usual gaussian "A" with the gaussian exp(-delta (r - D)^2 )
double precision :: A_new(0:max_dim,3)! new polynom
double precision :: A_center_new(3) ! new center
integer :: iorder_a_new(3) ! i_order(i) = order of the new polynom ==> should be equal to power_A
double precision :: alpha_new ! new exponent
double precision :: fact_a_new ! constant factor
double precision :: accu,coefx,coefy,coefz,coefxy,coefxyz,thr
integer :: d(3),i,lx,ly,lz,iorder_tmp(3),dim1
dim1=100
thr = 1.d-10
d = 0 ! order of the polynom for the gaussian exp(-delta (r - D)^2 ) == 0
! New gaussian/polynom defined by :: new pol new center new expo cst fact new order
call give_explicit_poly_and_gaussian(A_new , A_center_new , alpha_new, fact_a_new , iorder_a_new , &
delta,alpha,d,power_A,D_center,A_center,n_pt_max_integrals)
! The new gaussian exp(-delta (r - D)^2 ) (x-A_x)^a \exp(-\alpha (x-A_x)^2
accu = 0.d0
do lx = 0, iorder_a_new(1)
coefx = A_new(lx,1)
if(dabs(coefx).lt.thr)cycle
iorder_tmp(1) = lx
do ly = 0, iorder_a_new(2)
coefy = A_new(ly,2)
coefxy = coefx * coefy
if(dabs(coefxy).lt.thr)cycle
iorder_tmp(2) = ly
do lz = 0, iorder_a_new(3)
coefz = A_new(lz,3)
coefxyz = coefxy * coefz
if(dabs(coefxyz).lt.thr)cycle
iorder_tmp(3) = lz
call overlap_gaussian_xyz(A_center_new,B_center,alpha_new,beta,iorder_tmp,power_B,overlap_x,overlap_y,overlap_z,overlap,dim1)
accu += coefxyz * overlap
enddo
enddo
enddo
overlap_gauss_r12 = fact_a_new * accu
end
subroutine overlap_gauss_xyz_r12(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta,gauss_ints)
BEGIN_DOC
! Computes the following integral :
!
! .. math::
!
! gauss_ints(m) = \int dr exp(-delta (r - D)^2 ) * x/y/z (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
!
! with m == 1 ==> x, m == 2 ==> y, m == 3 ==> z
END_DOC
implicit none
include 'constants.include.F'
double precision, intent(in) :: D_center(3), delta ! pure gaussian "D"
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
integer, intent(in) :: power_A(3),power_B(3)
double precision, intent(out) :: gauss_ints(3)
double precision :: overlap_x,overlap_y,overlap_z,overlap
! First you multiply the usual gaussian "A" with the gaussian exp(-delta (r - D)^2 )
double precision :: A_new(0:max_dim,3)! new polynom
double precision :: A_center_new(3) ! new center
integer :: iorder_a_new(3) ! i_order(i) = order of the new polynom ==> should be equal to power_A
integer :: power_B_new(3)
double precision :: alpha_new ! new exponent
double precision :: fact_a_new ! constant factor
double precision :: coefx,coefy,coefz,coefxy,coefxyz,thr
integer :: d(3),i,lx,ly,lz,iorder_tmp(3),dim1,m
dim1=100
thr = 1.d-10
d = 0 ! order of the polynom for the gaussian exp(-delta (r - D)^2 ) == 0
! New gaussian/polynom defined by :: new pol new center new expo cst fact new order
call give_explicit_poly_and_gaussian(A_new , A_center_new , alpha_new, fact_a_new , iorder_a_new , &
delta,alpha,d,power_A,D_center,A_center,n_pt_max_integrals)
! The new gaussian exp(-delta (r - D)^2 ) (x-A_x)^a \exp(-\alpha (x-A_x)^2
gauss_ints = 0.d0
do lx = 0, iorder_a_new(1)
coefx = A_new(lx,1)
if(dabs(coefx).lt.thr)cycle
iorder_tmp(1) = lx
do ly = 0, iorder_a_new(2)
coefy = A_new(ly,2)
coefxy = coefx * coefy
if(dabs(coefxy).lt.thr)cycle
iorder_tmp(2) = ly
do lz = 0, iorder_a_new(3)
coefz = A_new(lz,3)
coefxyz = coefxy * coefz
if(dabs(coefxyz).lt.thr)cycle
iorder_tmp(3) = lz
do m = 1, 3
! change (x-Bx)^bx --> (x-Bx)^(bx+1) + Bx(x-Bx)^bx
power_B_new = power_B
power_B_new(m) += 1 ! (x-Bx)^(bx+1)
call overlap_gaussian_xyz(A_center_new,B_center,alpha_new,beta,iorder_tmp,power_B_new,overlap_x,overlap_y,overlap_z,overlap,dim1)
gauss_ints(m) += coefxyz * overlap
power_B_new = power_B
call overlap_gaussian_xyz(A_center_new,B_center,alpha_new,beta,iorder_tmp,power_B_new,overlap_x,overlap_y,overlap_z,overlap,dim1)
gauss_ints(m) += coefxyz * overlap * B_center(m) ! Bx (x-Bx)^(bx)
enddo
enddo
enddo
enddo
gauss_ints *= fact_a_new
end
double precision function overlap_gauss_xyz_r12_specific(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta,mx)
BEGIN_DOC
! Computes the following integral :
!
! .. math::
!
! \int dr exp(-delta (r - D)^2 ) * x/y/z (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
!
! with mx == 1 ==> x, mx == 2 ==> y, mx == 3 ==> z
END_DOC
implicit none
include 'constants.include.F'
double precision, intent(in) :: D_center(3), delta ! pure gaussian "D"
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
integer, intent(in) :: power_A(3),power_B(3),mx
double precision :: overlap_x,overlap_y,overlap_z,overlap
! First you multiply the usual gaussian "A" with the gaussian exp(-delta (r - D)^2 )
double precision :: A_new(0:max_dim,3)! new polynom
double precision :: A_center_new(3) ! new center
integer :: iorder_a_new(3) ! i_order(i) = order of the new polynom ==> should be equal to power_A
integer :: power_B_new(3)
double precision :: alpha_new ! new exponent
double precision :: fact_a_new ! constant factor
double precision :: coefx,coefy,coefz,coefxy,coefxyz,thr
integer :: d(3),i,lx,ly,lz,iorder_tmp(3),dim1,m
dim1=100
thr = 1.d-10
d = 0 ! order of the polynom for the gaussian exp(-delta (r - D)^2 ) == 0
! New gaussian/polynom defined by :: new pol new center new expo cst fact new order
call give_explicit_poly_and_gaussian(A_new , A_center_new , alpha_new, fact_a_new , iorder_a_new , &
delta,alpha,d,power_A,D_center,A_center,n_pt_max_integrals)
! The new gaussian exp(-delta (r - D)^2 ) (x-A_x)^a \exp(-\alpha (x-A_x)^2
overlap_gauss_xyz_r12_specific = 0.d0
do lx = 0, iorder_a_new(1)
coefx = A_new(lx,1)
if(dabs(coefx).lt.thr)cycle
iorder_tmp(1) = lx
do ly = 0, iorder_a_new(2)
coefy = A_new(ly,2)
coefxy = coefx * coefy
if(dabs(coefxy).lt.thr)cycle
iorder_tmp(2) = ly
do lz = 0, iorder_a_new(3)
coefz = A_new(lz,3)
coefxyz = coefxy * coefz
if(dabs(coefxyz).lt.thr)cycle
iorder_tmp(3) = lz
m = mx
! change (x-Bx)^bx --> (x-Bx)^(bx+1) + Bx(x-Bx)^bx
power_B_new = power_B
power_B_new(m) += 1 ! (x-Bx)^(bx+1)
call overlap_gaussian_xyz(A_center_new,B_center,alpha_new,beta,iorder_tmp,power_B_new,overlap_x,overlap_y,overlap_z,overlap,dim1)
overlap_gauss_xyz_r12_specific += coefxyz * overlap
power_B_new = power_B
call overlap_gaussian_xyz(A_center_new,B_center,alpha_new,beta,iorder_tmp,power_B_new,overlap_x,overlap_y,overlap_z,overlap,dim1)
overlap_gauss_xyz_r12_specific += coefxyz * overlap * B_center(m) ! Bx (x-Bx)^(bx)
enddo
enddo
enddo
overlap_gauss_xyz_r12_specific *= fact_a_new
end

121
src/ao_many_one_e_ints/stg_gauss_int.irp.f Normal file
View File

@ -0,0 +1,121 @@
double precision function ovlp_stg_gauss_int_phi_ij(D_center,gam,delta,A_center,B_center,power_A,power_B,alpha,beta)
BEGIN_DOC
! Computes the following integral :
!
! .. math::
!
! \int dr exp(-gam (r - D)) exp(-delta * (r -D)^2) (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
!
END_DOC
implicit none
double precision, intent(in) :: D_center(3), gam ! pure Slater "D" in r-r_D
double precision, intent(in) :: delta ! gaussian in r-r_D
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
integer, intent(in) :: power_A(3),power_B(3)
integer :: i
double precision :: integral,gama_gauss
double precision, allocatable :: expos_slat(:)
allocate(expos_slat(n_max_fit_slat))
double precision :: overlap_gauss_r12
ovlp_stg_gauss_int_phi_ij = 0.d0
call expo_fit_slater_gam(gam,expos_slat)
do i = 1, n_max_fit_slat
gama_gauss = expos_slat(i)+delta
integral = overlap_gauss_r12(D_center,gama_gauss,A_center,B_center,power_A,power_B,alpha,beta)
ovlp_stg_gauss_int_phi_ij += coef_fit_slat_gauss(i) * integral
enddo
end
double precision function erf_mu_stg_gauss_int_phi_ij(D_center,gam,delta,A_center,B_center,power_A,power_B,alpha,beta,C_center,mu)
BEGIN_DOC
! Computes the following integral :
!
! .. math::
!
! \int dr exp(-gam(r - D)-delta(r - D)^2) (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
! \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
END_DOC
implicit none
include 'constants.include.F'
double precision, intent(in) :: D_center(3), gam ! pure Slater "D" in r-r_D
double precision, intent(in) :: delta ! gaussian in r-r_D
double precision, intent(in) :: C_center(3),mu ! coulomb center "C" and "mu" in the erf(mu*x)/x function
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
integer, intent(in) :: power_A(3),power_B(3)
integer :: i
double precision :: NAI_pol_mult_erf_gauss_r12
double precision :: integral,gama_gauss
double precision, allocatable :: expos_slat(:)
allocate(expos_slat(n_max_fit_slat))
erf_mu_stg_gauss_int_phi_ij = 0.d0
call expo_fit_slater_gam(gam,expos_slat)
do i = 1, n_max_fit_slat
gama_gauss = expos_slat(i) + delta
integral = NAI_pol_mult_erf_gauss_r12(D_center,gama_gauss,A_center,B_center,power_A,power_B,alpha,beta,C_center,mu)
erf_mu_stg_gauss_int_phi_ij += coef_fit_slat_gauss(i) * integral
enddo
end
double precision function overlap_stg_gauss(D_center,gam,A_center,B_center,power_A,power_B,alpha,beta)
BEGIN_DOC
! Computes the following integral :
!
! .. math::
!
! \int dr exp(-gam (r - D)) (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
!
END_DOC
implicit none
double precision, intent(in) :: D_center(3), gam ! pure Slater "D"
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
integer, intent(in) :: power_A(3),power_B(3)
integer :: i
double precision :: expos_slat(n_max_fit_slat),integral,delta
double precision :: overlap_gauss_r12
overlap_stg_gauss = 0.d0
call expo_fit_slater_gam(gam,expos_slat)
do i = 1, n_max_fit_slat
delta = expos_slat(i)
integral = overlap_gauss_r12(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta)
overlap_stg_gauss += coef_fit_slat_gauss(i) * integral
enddo
end
double precision function erf_mu_stg_gauss(D_center,gam,A_center,B_center,power_A,power_B,alpha,beta,C_center,mu)
BEGIN_DOC
! Computes the following integral :
!
! .. math::
!
! \int dr exp(-gam(r - D)) (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
! \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
END_DOC
implicit none
include 'constants.include.F'
double precision, intent(in) :: D_center(3), gam ! pure Slater "D"
double precision, intent(in) :: C_center(3),mu ! coulomb center "C" and "mu" in the erf(mu*x)/x function
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
integer, intent(in) :: power_A(3),power_B(3)
integer :: i
double precision :: expos_slat(n_max_fit_slat),integral,delta
double precision :: NAI_pol_mult_erf_gauss_r12
erf_mu_stg_gauss = 0.d0
call expo_fit_slater_gam(gam,expos_slat)
do i = 1, n_max_fit_slat
delta = expos_slat(i)
integral = NAI_pol_mult_erf_gauss_r12(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta,C_center,mu)
erf_mu_stg_gauss += coef_fit_slat_gauss(i) * integral
enddo
end

101
src/ao_many_one_e_ints/taylor_exp.irp.f Normal file
View File

@ -0,0 +1,101 @@
double precision function exp_dl(x,n)
implicit none
double precision, intent(in) :: x
integer , intent(in) :: n
integer :: i
exp_dl = 1.d0
do i = 1, n
exp_dl += fact_inv(i) * x**dble(i)
enddo
end
subroutine exp_dl_rout(x,n, array)
implicit none
double precision, intent(in) :: x
integer , intent(in) :: n
double precision, intent(out):: array(0:n)
integer :: i
double precision :: accu
accu = 1.d0
array(0) = 1.d0
do i = 1, n
accu += fact_inv(i) * x**dble(i)
array(i) = accu
enddo
end
subroutine exp_dl_ovlp_stg_phi_ij(zeta,D_center,gam,delta,A_center,B_center,power_A,power_B,alpha,beta,n_taylor,array_ints,integral_taylor,exponent_exp)
BEGIN_DOC
! Computes the following integrals :
!
! .. math::
!
! array(i) = \int dr EXP{exponent_exp * [exp(-gam*i (r - D)) exp(-delta*i * (r -D)^2)] (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
!
!
! and gives back the Taylor expansion of the exponential in integral_taylor
END_DOC
implicit none
double precision, intent(in) :: zeta ! prefactor of the argument of the exp(-zeta*x)
integer, intent(in) :: n_taylor ! order of the Taylor expansion of the exponential
double precision, intent(in) :: D_center(3), gam ! pure Slater "D" in r-r_D
double precision, intent(in) :: delta ! gaussian in r-r_D
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
double precision, intent(in) :: exponent_exp
integer, intent(in) :: power_A(3),power_B(3)
double precision, intent(out) :: array_ints(0:n_taylor),integral_taylor
integer :: i,dim1
double precision :: delta_exp,gam_exp,ovlp_stg_gauss_int_phi_ij
double precision :: overlap_x,overlap_y,overlap_z,overlap
dim1=100
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x,overlap_y,overlap_z,overlap,dim1)
array_ints(0) = overlap
integral_taylor = array_ints(0)
do i = 1, n_taylor
delta_exp = dble(i) * delta
gam_exp = dble(i) * gam
array_ints(i) = ovlp_stg_gauss_int_phi_ij(D_center,gam_exp,delta_exp,A_center,B_center,power_A,power_B,alpha,beta)
integral_taylor += (-zeta*exponent_exp)**dble(i) * fact_inv(i) * array_ints(i)
enddo
end
subroutine exp_dl_erf_stg_phi_ij(zeta,D_center,gam,delta,A_center,B_center,power_A,power_B,alpha,beta,C_center,mu,n_taylor,array_ints,integral_taylor)
BEGIN_DOC
! Computes the following integrals :
!
! .. math::
!
! array(i) = \int dr exp(-gam*i (r - D)) exp(-delta*i * (r -D)^2) (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
! \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
!
! and gives back the Taylor expansion of the exponential in integral_taylor
END_DOC
implicit none
integer, intent(in) :: n_taylor ! order of the Taylor expansion of the exponential
double precision, intent(in) :: zeta ! prefactor of the argument of the exp(-zeta*x)
double precision, intent(in) :: D_center(3), gam ! pure Slater "D" in r-r_D
double precision, intent(in) :: delta ! gaussian in r-r_D
double precision, intent(in) :: C_center(3),mu ! coulomb center "C" and "mu" in the erf(mu*x)/x function
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
integer, intent(in) :: power_A(3),power_B(3)
double precision, intent(out) :: array_ints(0:n_taylor),integral_taylor
integer :: i,dim1
double precision :: delta_exp,gam_exp,NAI_pol_mult_erf,erf_mu_stg_gauss_int_phi_ij
dim1=100
array_ints(0) = NAI_pol_mult_erf(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_max_integrals,mu)
integral_taylor = array_ints(0)
do i = 1, n_taylor
delta_exp = dble(i) * delta
gam_exp = dble(i) * gam
array_ints(i) = erf_mu_stg_gauss_int_phi_ij(D_center,gam_exp,delta_exp,A_center,B_center,power_A,power_B,alpha,beta,C_center,mu)
integral_taylor += (-zeta)**dble(i) * fact_inv(i) * array_ints(i)
enddo
end

343
src/ao_many_one_e_ints/xyz_grad_xyz_ao_pol.irp.f Normal file
View File

@ -0,0 +1,343 @@
BEGIN_PROVIDER [double precision, coef_xyz_ao, (2,3,ao_num)]
&BEGIN_PROVIDER [integer, power_xyz_ao, (2,3,ao_num)]
implicit none
BEGIN_DOC
! coefficient for the basis function :: (x * phi_i(r), y * phi_i(r), * z_phi(r))
!
! x * (x - A_x)^a_x = A_x (x - A_x)^a_x + 1 * (x - A_x)^{a_x+1}
END_DOC
integer :: i,j,k,num_ao,power_ao(1:3)
double precision :: center_ao(1:3)
do i = 1, ao_num
power_ao(1:3)= ao_power(i,1:3)
num_ao = ao_nucl(i)
center_ao(1:3) = nucl_coord(num_ao,1:3)
do j = 1, 3
coef_xyz_ao(1,j,i) = center_ao(j) ! A_x (x - A_x)^a_x
power_xyz_ao(1,j,i)= power_ao(j)
coef_xyz_ao(2,j,i) = 1.d0 ! 1 * (x - A_x)^a_{x+1}
power_xyz_ao(2,j,i)= power_ao(j) + 1
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_coef_ord_grad_transp, (2,3,ao_prim_num_max,ao_num) ]
&BEGIN_PROVIDER [ integer, power_ord_grad_transp, (2,3,ao_num) ]
implicit none
BEGIN_DOC
! grad AO in terms of polynoms and coefficients
!
! WARNING !!!! SOME polynoms might be negative !!!!!
!
! WHEN IT IS THE CASE, coefficients are ZERO
END_DOC
integer :: i,j,power_ao(3), m,kk
do j=1, ao_num
power_ao(1:3)= ao_power(j,1:3)
do m = 1, 3
power_ord_grad_transp(1,m,j) = power_ao(m) - 1
power_ord_grad_transp(2,m,j) = power_ao(m) + 1
enddo
do i=1, ao_prim_num_max
do m = 1, 3
ao_coef_ord_grad_transp(1,m,i,j) = ao_coef_normalized_ordered(j,i) * dble(power_ao(m)) ! a_x * c_i
ao_coef_ord_grad_transp(2,m,i,j) = -2.d0 * ao_coef_normalized_ordered(j,i) * ao_expo_ordered_transp(i,j) ! -2 * c_i * alpha_i
do kk = 1, 2
if(power_ord_grad_transp(kk,m,j).lt.0)then
ao_coef_ord_grad_transp(kk,m,i,j) = 0.d0
endif
enddo
enddo
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_coef_ord_xyz_grad_transp, (4,3,ao_prim_num_max,ao_num) ]
&BEGIN_PROVIDER [ integer, power_ord_xyz_grad_transp, (4,3,ao_num) ]
implicit none
BEGIN_DOC
! x * d/dx of an AO in terms of polynoms and coefficients
!
! WARNING !!!! SOME polynoms might be negative !!!!!
!
! WHEN IT IS THE CASE, coefficients are ZERO
END_DOC
integer :: i,j,power_ao(3), m,num_ao,kk
double precision :: center_ao(1:3)
do j=1, ao_num
power_ao(1:3)= ao_power(j,1:3)
num_ao = ao_nucl(j)
center_ao(1:3) = nucl_coord(num_ao,1:3)
do m = 1, 3
power_ord_xyz_grad_transp(1,m,j) = power_ao(m) - 1
power_ord_xyz_grad_transp(2,m,j) = power_ao(m)
power_ord_xyz_grad_transp(3,m,j) = power_ao(m) + 1
power_ord_xyz_grad_transp(4,m,j) = power_ao(m) + 2
do kk = 1, 4
if(power_ord_xyz_grad_transp(kk,m,j).lt.0)then
power_ord_xyz_grad_transp(kk,m,j) = -1
endif
enddo
enddo
do i=1, ao_prim_num_max
do m = 1, 3
ao_coef_ord_xyz_grad_transp(1,m,i,j) = dble(power_ao(m)) * ao_coef_normalized_ordered(j,i) * center_ao(m)
ao_coef_ord_xyz_grad_transp(2,m,i,j) = dble(power_ao(m)) * ao_coef_normalized_ordered(j,i)
ao_coef_ord_xyz_grad_transp(3,m,i,j) = -2.d0 * ao_coef_normalized_ordered(j,i) * ao_expo_ordered_transp(i,j) * center_ao(m)
ao_coef_ord_xyz_grad_transp(4,m,i,j) = -2.d0 * ao_coef_normalized_ordered(j,i) * ao_expo_ordered_transp(i,j)
do kk = 1, 4
if(power_ord_xyz_grad_transp(kk,m,j).lt.0)then
ao_coef_ord_xyz_grad_transp(kk,m,i,j) = 0.d0
endif
enddo
enddo
enddo
enddo
END_PROVIDER
subroutine xyz_grad_phi_ao(r,i_ao,xyz_grad_phi)
implicit none
integer, intent(in) :: i_ao
double precision, intent(in) :: r(3)
double precision, intent(out):: xyz_grad_phi(3) ! x * d/dx phi i, y * d/dy phi_i, z * d/dz phi_
double precision :: center_ao(3),beta
double precision :: accu(3,4),dr(3),r2,pol_usual(3)
integer :: m,power_ao(3),num_ao,j_prim
power_ao(1:3)= ao_power(i_ao,1:3)
num_ao = ao_nucl(i_ao)
center_ao(1:3) = nucl_coord(num_ao,1:3)
dr(1) = (r(1) - center_ao(1))
dr(2) = (r(2) - center_ao(2))
dr(3) = (r(3) - center_ao(3))
r2 = 0.d0
do m = 1, 3
r2 += dr(m)*dr(m)
enddo
! computes the gaussian part
accu = 0.d0
do j_prim =1,ao_prim_num(i_ao)
beta = ao_expo_ordered_transp(j_prim,i_ao)
if(dabs(beta*r2).gt.50.d0)cycle
do m = 1, 3
accu(m,1) += ao_coef_ord_xyz_grad_transp(1,m,j_prim,i_ao) * dexp(-beta*r2)
accu(m,2) += ao_coef_ord_xyz_grad_transp(2,m,j_prim,i_ao) * dexp(-beta*r2)
accu(m,3) += ao_coef_ord_xyz_grad_transp(3,m,j_prim,i_ao) * dexp(-beta*r2)
accu(m,4) += ao_coef_ord_xyz_grad_transp(4,m,j_prim,i_ao) * dexp(-beta*r2)
enddo
enddo
! computes the polynom part
pol_usual = 0.d0
pol_usual(1) = dr(2)**dble(power_ao(2)) * dr(3)**dble(power_ao(3))
pol_usual(2) = dr(1)**dble(power_ao(1)) * dr(3)**dble(power_ao(3))
pol_usual(3) = dr(1)**dble(power_ao(1)) * dr(2)**dble(power_ao(2))
xyz_grad_phi = 0.d0
do m = 1, 3
xyz_grad_phi(m) += accu(m,2) * pol_usual(m) * dr(m)**dble(power_ord_xyz_grad_transp(2,m,i_ao))
xyz_grad_phi(m) += accu(m,3) * pol_usual(m) * dr(m)**dble(power_ord_xyz_grad_transp(3,m,i_ao))
xyz_grad_phi(m) += accu(m,4) * pol_usual(m) * dr(m)**dble(power_ord_xyz_grad_transp(4,m,i_ao))
if(power_ord_xyz_grad_transp(1,m,i_ao).lt.0)cycle
xyz_grad_phi(m) += accu(m,1) * pol_usual(m) * dr(m)**dble(power_ord_xyz_grad_transp(1,m,i_ao))
enddo
end
subroutine grad_phi_ao(r,i_ao,grad_xyz_phi)
implicit none
integer, intent(in) :: i_ao
double precision, intent(in) :: r(3)
double precision, intent(out):: grad_xyz_phi(3) ! x * phi i, y * phi_i, z * phi_
double precision :: center_ao(3),beta
double precision :: accu(3,2),dr(3),r2,pol_usual(3)
integer :: m,power_ao(3),num_ao,j_prim
power_ao(1:3)= ao_power(i_ao,1:3)
num_ao = ao_nucl(i_ao)
center_ao(1:3) = nucl_coord(num_ao,1:3)
dr(1) = (r(1) - center_ao(1))
dr(2) = (r(2) - center_ao(2))
dr(3) = (r(3) - center_ao(3))
r2 = 0.d0
do m = 1, 3
r2 += dr(m)*dr(m)
enddo
! computes the gaussian part
accu = 0.d0
do j_prim =1,ao_prim_num(i_ao)
beta = ao_expo_ordered_transp(j_prim,i_ao)
if(dabs(beta*r2).gt.50.d0)cycle
do m = 1, 3
accu(m,1) += ao_coef_ord_grad_transp(1,m,j_prim,i_ao) * dexp(-beta*r2)
accu(m,2) += ao_coef_ord_grad_transp(2,m,j_prim,i_ao) * dexp(-beta*r2)
enddo
enddo
! computes the polynom part
pol_usual = 0.d0
pol_usual(1) = dr(2)**dble(power_ao(2)) * dr(3)**dble(power_ao(3))
pol_usual(2) = dr(1)**dble(power_ao(1)) * dr(3)**dble(power_ao(3))
pol_usual(3) = dr(1)**dble(power_ao(1)) * dr(2)**dble(power_ao(2))
do m = 1, 3
grad_xyz_phi(m) = accu(m,2) * pol_usual(m) * dr(m)**dble(power_ord_grad_transp(2,m,i_ao))
if(power_ao(m)==0)cycle
grad_xyz_phi(m) += accu(m,1) * pol_usual(m) * dr(m)**dble(power_ord_grad_transp(1,m,i_ao))
enddo
end
subroutine xyz_phi_ao(r,i_ao,xyz_phi)
implicit none
integer, intent(in) :: i_ao
double precision, intent(in) :: r(3)
double precision, intent(out):: xyz_phi(3) ! x * phi i, y * phi_i, z * phi_i
double precision :: center_ao(3),beta
double precision :: accu,dr(3),r2,pol_usual(3)
integer :: m,power_ao(3),num_ao
power_ao(1:3)= ao_power(i_ao,1:3)
num_ao = ao_nucl(i_ao)
center_ao(1:3) = nucl_coord(num_ao,1:3)
dr(1) = (r(1) - center_ao(1))
dr(2) = (r(2) - center_ao(2))
dr(3) = (r(3) - center_ao(3))
r2 = 0.d0
do m = 1, 3
r2 += dr(m)*dr(m)
enddo
! computes the gaussian part
accu = 0.d0
do m=1,ao_prim_num(i_ao)
beta = ao_expo_ordered_transp(m,i_ao)
if(dabs(beta*r2).gt.50.d0)cycle
accu += ao_coef_normalized_ordered_transp(m,i_ao) * dexp(-beta*r2)
enddo
! computes the polynom part
pol_usual = 0.d0
pol_usual(1) = dr(2)**dble(power_ao(2)) * dr(3)**dble(power_ao(3))
pol_usual(2) = dr(1)**dble(power_ao(1)) * dr(3)**dble(power_ao(3))
pol_usual(3) = dr(1)**dble(power_ao(1)) * dr(2)**dble(power_ao(2))
do m = 1, 3
xyz_phi(m) = accu * pol_usual(m) * dr(m)**(dble(power_ao(m))) * ( coef_xyz_ao(1,m,i_ao) + coef_xyz_ao(2,m,i_ao) * dr(m) )
enddo
end
subroutine test_pol_xyz
implicit none
integer :: ipoint,i,j,m,jpoint
double precision :: r1(3),derf_mu_x
double precision :: weight1,r12,xyz_phi(3),grad_phi(3),xyz_grad_phi(3)
double precision, allocatable :: aos_array(:),aos_grad_array(:,:)
double precision :: num_xyz_phi(3),num_grad_phi(3),num_xyz_grad_phi(3)
double precision :: accu_xyz_phi(3),accu_grad_phi(3),accu_xyz_grad_phi(3)
double precision :: meta_accu_xyz_phi(3),meta_accu_grad_phi(3),meta_accu_xyz_grad_phi(3)
allocate(aos_array(ao_num),aos_grad_array(3,ao_num))
meta_accu_xyz_phi = 0.d0
meta_accu_grad_phi = 0.d0
meta_accu_xyz_grad_phi= 0.d0
do i = 1, ao_num
accu_xyz_phi = 0.d0
accu_grad_phi = 0.d0
accu_xyz_grad_phi= 0.d0
do ipoint = 1, n_points_final_grid
r1(:) = final_grid_points(:,ipoint)
weight1 = final_weight_at_r_vector(ipoint)
call give_all_aos_and_grad_at_r(r1,aos_array,aos_grad_array)
do m = 1, 3
num_xyz_phi(m) = r1(m) * aos_array(i)
num_grad_phi(m) = aos_grad_array(m,i)
num_xyz_grad_phi(m) = r1(m) * aos_grad_array(m,i)
enddo
call xyz_phi_ao(r1,i,xyz_phi)
call grad_phi_ao(r1,i,grad_phi)
call xyz_grad_phi_ao(r1,i,xyz_grad_phi)
do m = 1, 3
accu_xyz_phi(m) += weight1 * dabs(num_xyz_phi(m) - xyz_phi(m) )
accu_grad_phi(m) += weight1 * dabs(num_grad_phi(m) - grad_phi(m) )
accu_xyz_grad_phi(m) += weight1 * dabs(num_xyz_grad_phi(m) - xyz_grad_phi(m))
enddo
enddo
print*,''
print*,''
print*,'i,',i
print*,''
do m = 1, 3
! print*, 'm, accu_xyz_phi(m) ' ,m, accu_xyz_phi(m)
! print*, 'm, accu_grad_phi(m) ' ,m, accu_grad_phi(m)
print*, 'm, accu_xyz_grad_phi' ,m, accu_xyz_grad_phi(m)
enddo
do m = 1, 3
meta_accu_xyz_phi(m) += dabs(accu_xyz_phi(m))
meta_accu_grad_phi(m) += dabs(accu_grad_phi(m))
meta_accu_xyz_grad_phi(m) += dabs(accu_xyz_grad_phi(m))
enddo
enddo
do m = 1, 3
! print*, 'm, meta_accu_xyz_phi(m) ' ,m, meta_accu_xyz_phi(m)
! print*, 'm, meta_accu_grad_phi(m) ' ,m, meta_accu_grad_phi(m)
print*, 'm, meta_accu_xyz_grad_phi' ,m, meta_accu_xyz_grad_phi(m)
enddo
end
subroutine test_ints_semi_bis
implicit none
integer :: ipoint,i,j,m
double precision :: r1(3), aos_grad_array_r1(3, ao_num), aos_array_r1(ao_num)
double precision :: C_center(3), weight1,mu_in,r12,derf_mu_x,dxyz_ints(3),NAI_pol_mult_erf_ao
double precision :: ao_mat(ao_num,ao_num),ao_xmat(3,ao_num,ao_num),accu1, accu2(3)
mu_in = 0.5d0
C_center = 0.d0
C_center(1) = 0.25d0
C_center(3) = 1.12d0
C_center(2) = -1.d0
ao_mat = 0.d0
ao_xmat = 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)
call give_all_aos_and_grad_at_r(r1,aos_array_r1,aos_grad_array_r1)
weight1 = final_weight_at_r_vector(ipoint)
r12 = (r1(1) - C_center(1))**2.d0 + (r1(2) - C_center(2))**2.d0 + (r1(3) - C_center(3))**2.d0
r12 = dsqrt(r12)
do i = 1, ao_num
do j = 1, ao_num
ao_mat(j,i) += aos_array_r1(i) * aos_array_r1(j) * weight1 * derf_mu_x(mu_in,r12)
do m = 1, 3
ao_xmat(m,j,i) += r1(m) * aos_array_r1(j) * aos_grad_array_r1(m,i) * weight1 * derf_mu_x(mu_in,r12)
enddo
enddo
enddo
enddo
accu1 = 0.d0
accu2 = 0.d0
accu1relat = 0.d0
accu2relat = 0.d0
double precision :: accu1relat, accu2relat(3)
double precision :: contrib(3)
do i = 1, ao_num
do j = 1, ao_num
call phi_j_erf_mu_r_xyz_dxyz_phi(i,j,mu_in, C_center, dxyz_ints)
print*,''
print*,'i,j',i,j
print*,dxyz_ints(:)
print*,ao_xmat(:,j,i)
do m = 1, 3
contrib(m) = dabs(ao_xmat(m,j,i) - dxyz_ints(m))
accu2(m) += contrib(m)
if(dabs(ao_xmat(m,j,i)).gt.1.d-10)then
accu2relat(m) += dabs(ao_xmat(m,j,i) - dxyz_ints(m))/dabs(ao_xmat(m,j,i))
endif
enddo
print*,contrib
enddo
print*,''
enddo
print*,'accu2relat = '
print*, accu2relat /dble(ao_num * ao_num)
end

12
src/ao_tc_eff_map/EZFIO.cfg Normal file
View File

@ -0,0 +1,12 @@
[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

4
src/ao_tc_eff_map/NEED Normal file
View File

@ -0,0 +1,4 @@
ao_two_e_erf_ints
mo_one_e_ints
ao_many_one_e_ints
dft_utils_in_r

12
src/ao_tc_eff_map/README.rst Normal file
View File

@ -0,0 +1,12 @@
ao_tc_eff_map
=============
This is a module to obtain the integrals on the AO basis of the SCALAR HERMITIAN
effective potential defined in Eq. 32 of JCP 154, 084119 (2021)
It also contains the modification by a one-body Jastrow factor.
The main routine/providers are
+) ao_tc_sym_two_e_pot_map : map of the SCALAR PART of total effective two-electron on the AO basis in PHYSICIST notations. It might contain the two-electron term coming from the one-e correlation factor.
+) get_ao_tc_sym_two_e_pot(i,j,k,l,ao_tc_sym_two_e_pot_map) : routine to get the integrals from ao_tc_sym_two_e_pot_map.
+) ao_tc_sym_two_e_pot(i,j,k,l) : FUNCTION that returns the scalar part of TC-potential EXCLUDING the erf(mu r12)/r12. See two_e_ints_gauss.irp.f for more details.

75
src/ao_tc_eff_map/compute_ints_eff_pot.irp.f Normal file
View File

@ -0,0 +1,75 @@
subroutine compute_ao_tc_sym_two_e_pot_jl(j, l, n_integrals, buffer_i, buffer_value)
use map_module
BEGIN_DOC
! Parallel client for AO integrals of the TC integrals involving purely hermitian operators
END_DOC
implicit none
integer, intent(in) :: j, l
integer,intent(out) :: n_integrals
integer(key_kind),intent(out) :: buffer_i(ao_num*ao_num)
real(integral_kind),intent(out) :: buffer_value(ao_num*ao_num)
integer :: i, k
integer :: kk, m, j1, i1
double precision :: cpu_1, cpu_2, wall_1, wall_2
double precision :: integral, wall_0, integral_pot, integral_erf
double precision :: thr
logical, external :: ao_two_e_integral_zero
double precision :: ao_tc_sym_two_e_pot, ao_two_e_integral_erf
double precision :: j1b_gauss_erf, j1b_gauss_coul
double precision :: j1b_gauss_coul_debug
double precision :: j1b_gauss_coul_modifdebug
double precision :: j1b_gauss_coulerf
PROVIDE j1b_gauss
thr = ao_integrals_threshold
n_integrals = 0
j1 = j+ishft(l*l-l,-1)
do k = 1, ao_num ! r1
i1 = ishft(k*k-k,-1)
if (i1 > j1) then
exit
endif
do i = 1, k
i1 += 1
if (i1 > j1) then
exit
endif
if (ao_two_e_integral_erf_schwartz(i,k)*ao_two_e_integral_erf_schwartz(j,l) < thr ) then
cycle
endif
!DIR$ FORCEINLINE
integral_pot = ao_tc_sym_two_e_pot (i, k, j, l) ! i,k : r1 j,l : r2
integral_erf = ao_two_e_integral_erf(i, k, j, l)
integral = integral_erf + integral_pot
if( j1b_gauss .eq. 1 ) then
integral = integral &
+ j1b_gauss_coulerf(i, k, j, l)
endif
if(abs(integral) < thr) then
cycle
endif
n_integrals += 1
!DIR$ FORCEINLINE
call two_e_integrals_index(i, j, k, l, buffer_i(n_integrals))
buffer_value(n_integrals) = integral
enddo
enddo
end subroutine compute_ao_tc_sym_two_e_pot_jl

194
src/ao_tc_eff_map/integrals_eff_pot_in_map_slave.irp.f Normal file
View File

@ -0,0 +1,194 @@
subroutine ao_tc_sym_two_e_pot_in_map_slave_tcp(i)
implicit none
integer, intent(in) :: i
BEGIN_DOC
! Computes a buffer of integrals. i is the ID of the current thread.
END_DOC
call ao_tc_sym_two_e_pot_in_map_slave(0,i)
end
subroutine ao_tc_sym_two_e_pot_in_map_slave_inproc(i)
implicit none
integer, intent(in) :: i
BEGIN_DOC
! Computes a buffer of integrals. i is the ID of the current thread.
END_DOC
call ao_tc_sym_two_e_pot_in_map_slave(1,i)
end
subroutine ao_tc_sym_two_e_pot_in_map_slave(thread,iproc)
use map_module
use f77_zmq
implicit none
BEGIN_DOC
! Computes a buffer of integrals
END_DOC
integer, intent(in) :: thread, iproc
integer :: j,l,n_integrals
integer :: rc
real(integral_kind), allocatable :: buffer_value(:)
integer(key_kind), allocatable :: buffer_i(:)
integer :: worker_id, task_id
character*(512) :: task
integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
integer(ZMQ_PTR), external :: new_zmq_push_socket
integer(ZMQ_PTR) :: zmq_socket_push
character*(64) :: state
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
integer, external :: connect_to_taskserver
if (connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) == -1) then
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
return
endif
zmq_socket_push = new_zmq_push_socket(thread)
allocate ( buffer_i(ao_num*ao_num), buffer_value(ao_num*ao_num) )
do
integer, external :: get_task_from_taskserver
if (get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task) == -1) then
exit
endif
if (task_id == 0) exit
read(task,*) j, l
integer, external :: task_done_to_taskserver
call compute_ao_tc_sym_two_e_pot_jl(j,l,n_integrals,buffer_i,buffer_value)
if (task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) == -1) then
stop 'Unable to send task_done'
endif
call push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, task_id)
enddo
integer, external :: disconnect_from_taskserver
if (disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id) == -1) then
continue
endif
deallocate( buffer_i, buffer_value )
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
call end_zmq_push_socket(zmq_socket_push,thread)
end
subroutine ao_tc_sym_two_e_pot_in_map_collector(zmq_socket_pull)
use map_module
use f77_zmq
implicit none
BEGIN_DOC
! Collects results from the AO integral calculation
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
integer :: j,l,n_integrals
integer :: rc
real(integral_kind), allocatable :: buffer_value(:)
integer(key_kind), allocatable :: buffer_i(:)
integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
integer(ZMQ_PTR), external :: new_zmq_pull_socket
integer*8 :: control, accu, sze
integer :: task_id, more
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
sze = ao_num*ao_num
allocate ( buffer_i(sze), buffer_value(sze) )
accu = 0_8
more = 1
do while (more == 1)
rc = f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0)
if (rc == -1) then
n_integrals = 0
return
endif
if (rc /= 4) then
print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0)'
stop 'error'
endif
if (n_integrals >= 0) then
if (n_integrals > sze) then
deallocate (buffer_value, buffer_i)
sze = n_integrals
allocate (buffer_value(sze), buffer_i(sze))
endif
rc = f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0)
if (rc /= key_kind*n_integrals) then
print *, rc, key_kind, n_integrals
print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0)'
stop 'error'
endif
rc = f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0)
if (rc /= integral_kind*n_integrals) then
print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0)'
stop 'error'
endif
rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0)
IRP_IF ZMQ_PUSH
IRP_ELSE
rc = f77_zmq_send( zmq_socket_pull, 0, 4, 0)
if (rc /= 4) then
print *, irp_here, ' : f77_zmq_send (zmq_socket_pull,...'
stop 'error'
endif
IRP_ENDIF
call insert_into_ao_tc_sym_two_e_pot_map(n_integrals,buffer_i,buffer_value)
accu += n_integrals
if (task_id /= 0) then
integer, external :: zmq_delete_task
if (zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more) == -1) then
stop 'Unable to delete task'
endif
endif
endif
enddo
deallocate( buffer_i, buffer_value )
integer (map_size_kind) :: get_ao_tc_sym_two_e_pot_map_size
control = get_ao_tc_sym_two_e_pot_map_size(ao_tc_sym_two_e_pot_map)
if (control /= accu) then
print *, ''
print *, irp_here
print *, 'Control : ', control
print *, 'Accu : ', accu
print *, 'Some integrals were lost during the parallel computation.'
print *, 'Try to reduce the number of threads.'
stop
endif
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
end

299
src/ao_tc_eff_map/j1b_1eInteg.py Normal file
View File

@ -0,0 +1,299 @@
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 Normal file
View File

@ -0,0 +1,59 @@
! ---
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
! ---

291
src/ao_tc_eff_map/map_integrals_eff_pot.irp.f Normal file
View File

@ -0,0 +1,291 @@
use map_module
!! AO Map
!! ======
BEGIN_PROVIDER [ type(map_type), ao_tc_sym_two_e_pot_map ]
implicit none
BEGIN_DOC
! |AO| integrals
END_DOC
integer(key_kind) :: key_max
integer(map_size_kind) :: sze
call two_e_integrals_index(ao_num,ao_num,ao_num,ao_num,key_max)
sze = key_max
call map_init(ao_tc_sym_two_e_pot_map,sze)
print*, 'ao_tc_sym_two_e_pot_map map initialized : ', sze
END_PROVIDER
BEGIN_PROVIDER [ integer, ao_tc_sym_two_e_pot_cache_min ]
&BEGIN_PROVIDER [ integer, ao_tc_sym_two_e_pot_cache_max ]
implicit none
BEGIN_DOC
! Min and max values of the AOs for which the integrals are in the cache
END_DOC
ao_tc_sym_two_e_pot_cache_min = max(1,ao_num - 63)
ao_tc_sym_two_e_pot_cache_max = ao_num
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_tc_sym_two_e_pot_cache, (0:64*64*64*64) ]
use map_module
implicit none
BEGIN_DOC
! Cache of |AO| integrals for fast access
END_DOC
PROVIDE ao_tc_sym_two_e_pot_in_map
integer :: i,j,k,l,ii
integer(key_kind) :: idx
real(integral_kind) :: integral
!$OMP PARALLEL DO PRIVATE (i,j,k,l,idx,ii,integral)
do l=ao_tc_sym_two_e_pot_cache_min,ao_tc_sym_two_e_pot_cache_max
do k=ao_tc_sym_two_e_pot_cache_min,ao_tc_sym_two_e_pot_cache_max
do j=ao_tc_sym_two_e_pot_cache_min,ao_tc_sym_two_e_pot_cache_max
do i=ao_tc_sym_two_e_pot_cache_min,ao_tc_sym_two_e_pot_cache_max
!DIR$ FORCEINLINE
call two_e_integrals_index(i,j,k,l,idx)
!DIR$ FORCEINLINE
call map_get(ao_tc_sym_two_e_pot_map,idx,integral)
ii = l-ao_tc_sym_two_e_pot_cache_min
ii = ior( ishft(ii,6), k-ao_tc_sym_two_e_pot_cache_min)
ii = ior( ishft(ii,6), j-ao_tc_sym_two_e_pot_cache_min)
ii = ior( ishft(ii,6), i-ao_tc_sym_two_e_pot_cache_min)
ao_tc_sym_two_e_pot_cache(ii) = integral
enddo
enddo
enddo
enddo
!$OMP END PARALLEL DO
END_PROVIDER
subroutine insert_into_ao_tc_sym_two_e_pot_map(n_integrals,buffer_i, buffer_values)
use map_module
implicit none
BEGIN_DOC
! Create new entry into |AO| map
END_DOC
integer, intent(in) :: n_integrals
integer(key_kind), intent(inout) :: buffer_i(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)
end
double precision function get_ao_tc_sym_two_e_pot(i,j,k,l,map) result(result)
use map_module
implicit none
BEGIN_DOC
! Gets one |AO| two-electron integral from the |AO| map
END_DOC
integer, intent(in) :: i,j,k,l
integer(key_kind) :: idx
type(map_type), intent(inout) :: map
integer :: ii
real(integral_kind) :: tmp
logical, external :: ao_two_e_integral_zero
PROVIDE ao_tc_sym_two_e_pot_in_map ao_tc_sym_two_e_pot_cache ao_tc_sym_two_e_pot_cache_min
!DIR$ FORCEINLINE
! if (ao_two_e_integral_zero(i,j,k,l)) then
if (.False.) then
tmp = 0.d0
!else if (ao_two_e_integral_erf_schwartz(i,k)*ao_two_e_integral_erf_schwartz(j,l) < ao_integrals_threshold) then
! tmp = 0.d0
else
ii = l-ao_tc_sym_two_e_pot_cache_min
ii = ior(ii, k-ao_tc_sym_two_e_pot_cache_min)
ii = ior(ii, j-ao_tc_sym_two_e_pot_cache_min)
ii = ior(ii, i-ao_tc_sym_two_e_pot_cache_min)
if (iand(ii, -64) /= 0) then
!DIR$ FORCEINLINE
call two_e_integrals_index(i,j,k,l,idx)
!DIR$ FORCEINLINE
call map_get(map,idx,tmp)
tmp = tmp
else
ii = l-ao_tc_sym_two_e_pot_cache_min
ii = ior( ishft(ii,6), k-ao_tc_sym_two_e_pot_cache_min)
ii = ior( ishft(ii,6), j-ao_tc_sym_two_e_pot_cache_min)
ii = ior( ishft(ii,6), i-ao_tc_sym_two_e_pot_cache_min)
tmp = ao_tc_sym_two_e_pot_cache(ii)
endif
endif
result = tmp
end
subroutine get_many_ao_tc_sym_two_e_pot(j,k,l,sze,out_val)
use map_module
BEGIN_DOC
! Gets multiple |AO| two-electron integral from the |AO| map .
! All i are retrieved for j,k,l fixed.
END_DOC
implicit none
integer, intent(in) :: j,k,l, sze
real(integral_kind), intent(out) :: out_val(sze)
integer :: i
integer(key_kind) :: hash
double precision :: thresh
! logical, external :: ao_one_e_integral_zero
PROVIDE ao_tc_sym_two_e_pot_in_map ao_tc_sym_two_e_pot_map
thresh = ao_integrals_threshold
! if (ao_one_e_integral_zero(j,l)) then
if (.False.) then
out_val = 0.d0
return
endif
double precision :: get_ao_tc_sym_two_e_pot
do i=1,sze
out_val(i) = get_ao_tc_sym_two_e_pot(i,j,k,l,ao_tc_sym_two_e_pot_map)
enddo
end
subroutine get_many_ao_tc_sym_two_e_pot_non_zero(j,k,l,sze,out_val,out_val_index,non_zero_int)
use map_module
implicit none
BEGIN_DOC
! Gets multiple |AO| two-electron integrals from the |AO| map .
! All non-zero i are retrieved for j,k,l fixed.
END_DOC
integer, intent(in) :: j,k,l, sze
real(integral_kind), intent(out) :: out_val(sze)
integer, intent(out) :: out_val_index(sze),non_zero_int
integer :: i
integer(key_kind) :: hash
double precision :: thresh,tmp
! logical, external :: ao_one_e_integral_zero
PROVIDE ao_tc_sym_two_e_pot_in_map
thresh = ao_integrals_threshold
non_zero_int = 0
! if (ao_one_e_integral_zero(j,l)) then
if (.False.) then
out_val = 0.d0
return
endif
non_zero_int = 0
do i=1,sze
integer, external :: ao_l4
double precision, external :: ao_two_e_integral_eff_pot
!DIR$ FORCEINLINE
!if (ao_two_e_integral_erf_schwartz(i,k)*ao_two_e_integral_erf_schwartz(j,l) < thresh) then
! cycle
!endif
call two_e_integrals_index(i,j,k,l,hash)
call map_get(ao_tc_sym_two_e_pot_map, hash,tmp)
if (dabs(tmp) < thresh ) cycle
non_zero_int = non_zero_int+1
out_val_index(non_zero_int) = i
out_val(non_zero_int) = tmp
enddo
end
function get_ao_tc_sym_two_e_pot_map_size()
implicit none
integer (map_size_kind) :: get_ao_tc_sym_two_e_pot_map_size
BEGIN_DOC
! Returns the number of elements in the |AO| map
END_DOC
get_ao_tc_sym_two_e_pot_map_size = ao_tc_sym_two_e_pot_map % n_elements
end
subroutine clear_ao_tc_sym_two_e_pot_map
implicit none
BEGIN_DOC
! Frees the memory of the |AO| map
END_DOC
call map_deinit(ao_tc_sym_two_e_pot_map)
FREE ao_tc_sym_two_e_pot_map
end
subroutine dump_ao_tc_sym_two_e_pot(filename)
use map_module
implicit none
BEGIN_DOC
! Save to disk the |AO| eff_pot integrals
END_DOC
character*(*), intent(in) :: filename
integer(cache_key_kind), pointer :: key(:)
real(integral_kind), pointer :: val(:)
integer*8 :: i,j, n
call ezfio_set_work_empty(.False.)
open(unit=66,file=filename,FORM='unformatted')
write(66) integral_kind, key_kind
write(66) ao_tc_sym_two_e_pot_map%sorted, ao_tc_sym_two_e_pot_map%map_size, &
ao_tc_sym_two_e_pot_map%n_elements
do i=0_8,ao_tc_sym_two_e_pot_map%map_size
write(66) ao_tc_sym_two_e_pot_map%map(i)%sorted, ao_tc_sym_two_e_pot_map%map(i)%map_size,&
ao_tc_sym_two_e_pot_map%map(i)%n_elements
enddo
do i=0_8,ao_tc_sym_two_e_pot_map%map_size
key => ao_tc_sym_two_e_pot_map%map(i)%key
val => ao_tc_sym_two_e_pot_map%map(i)%value
n = ao_tc_sym_two_e_pot_map%map(i)%n_elements
write(66) (key(j), j=1,n), (val(j), j=1,n)
enddo
close(66)
end
integer function load_ao_tc_sym_two_e_pot(filename)
implicit none
BEGIN_DOC
! Read from disk the |AO| eff_pot integrals
END_DOC
character*(*), intent(in) :: filename
integer*8 :: i
integer(cache_key_kind), pointer :: key(:)
real(integral_kind), pointer :: val(:)
integer :: iknd, kknd
integer*8 :: n, j
load_ao_tc_sym_two_e_pot = 1
open(unit=66,file=filename,FORM='unformatted',STATUS='UNKNOWN')
read(66,err=98,end=98) iknd, kknd
if (iknd /= integral_kind) then
print *, 'Wrong integrals kind in file :', iknd
stop 1
endif
if (kknd /= key_kind) then
print *, 'Wrong key kind in file :', kknd
stop 1
endif
read(66,err=98,end=98) ao_tc_sym_two_e_pot_map%sorted, ao_tc_sym_two_e_pot_map%map_size,&
ao_tc_sym_two_e_pot_map%n_elements
do i=0_8, ao_tc_sym_two_e_pot_map%map_size
read(66,err=99,end=99) ao_tc_sym_two_e_pot_map%map(i)%sorted, &
ao_tc_sym_two_e_pot_map%map(i)%map_size, ao_tc_sym_two_e_pot_map%map(i)%n_elements
call cache_map_reallocate(ao_tc_sym_two_e_pot_map%map(i),ao_tc_sym_two_e_pot_map%map(i)%map_size)
enddo
do i=0_8, ao_tc_sym_two_e_pot_map%map_size
key => ao_tc_sym_two_e_pot_map%map(i)%key
val => ao_tc_sym_two_e_pot_map%map(i)%value
n = ao_tc_sym_two_e_pot_map%map(i)%n_elements
read(66,err=99,end=99) (key(j), j=1,n), (val(j), j=1,n)
enddo
call map_sort(ao_tc_sym_two_e_pot_map)
load_ao_tc_sym_two_e_pot = 0
return
99 continue
call map_deinit(ao_tc_sym_two_e_pot_map)
98 continue
stop 'Problem reading ao_tc_sym_two_e_pot_map file in work/'
end

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

@ -0,0 +1,519 @@
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
!_____________________________________________________________________________________________________________
!_____________________________________________________________________________________________________________

319
src/ao_tc_eff_map/one_e_1bgauss_nonherm.irp.f Normal file
View File

@ -0,0 +1,319 @@
BEGIN_PROVIDER [ double precision, j1b_gauss_nonherm, (ao_num,ao_num)]
BEGIN_DOC
!
! Hermitian part of 1-body Jastrow factow in the |AO| basis set.
!
! \langle \chi_i | - grad \tau_{1b} \cdot grad | \chi_j \rangle =
! 2 \sum_A aA \langle \chi_i | exp[-aA riA^2] (ri-rA) \cdot grad | \chi_j \rangle
!
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, c
integer :: dim1
double precision :: overlap_y, d_a_2, overlap_z, overlap
double precision :: int_gauss_deriv
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_nonherm(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, 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_nonherm)
!$OMP DO SCHEDULE (dynamic)
do j = 1, ao_num
num_A = ao_nucl(j)
power_A(1:3) = ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
do i = 1, ao_num
num_B = ao_nucl(i)
power_B(1:3) = ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l = 1, ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
do m = 1, ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
c = 0.d0
do k = 1, nucl_num
gama = j1b_gauss_pen(k)
C_center(1:3) = nucl_coord(k,1:3)
! \langle \chi_A | exp[-gama r_C^2] r_C \cdot grad | \chi_B \rangle
c1 = int_gauss_deriv( A_center, B_center, C_center &
, power_A, power_B, alpha, beta, gama )
c = c + 2.d0 * gama * c1
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
END_PROVIDER
!_____________________________________________________________________________________________________________
!
! < XA | exp[-gama r_C^2] r_C \cdot grad | XB >
!
double precision function int_gauss_deriv(A_center, B_center, C_center, power_A, power_B, alpha, beta, gama)
! for max_dim
include 'constants.include.F'
implicit none
double precision, intent(in) :: A_center(3), B_center(3), C_center(3)
integer , intent(in) :: power_A(3), power_B(3)
double precision, intent(in) :: alpha, beta, gama
integer :: i, power_C, dim1
integer :: iorder(3), power_D(3)
double precision :: AB_expo
double precision :: fact_AB, center_AB(3), pol_AB(0:max_dim,3)
double precision :: cx, cy, cz
double precision :: overlap_gaussian_x
dim1 = 100
int_gauss_deriv = 0.d0
! ===============
! term I:
! \partial_x
! ===============
if( power_B(1) .ge. 1 ) then
power_D(1) = power_B(1) - 1
power_D(2) = power_B(2)
power_D(3) = power_B(3)
call give_explicit_poly_and_gaussian( pol_AB, center_AB, AB_expo, fact_AB &
, iorder, alpha, beta, power_A, power_D, A_center, B_center, dim1)
power_C = 1
cx = 0.d0
do i = 0, iorder(1)
cx = cx + pol_AB(i,1) * overlap_gaussian_x( center_AB(1), C_center(1), AB_expo, gama, i, power_C, dim1)
enddo
power_C = 0
cy = 0.d0
do i = 0, iorder(2)
cy = cy + pol_AB(i,2) * overlap_gaussian_x( center_AB(2), C_center(2), AB_expo, gama, i, power_C, dim1)
enddo
power_C = 0
cz = 0.d0
do i = 0, iorder(3)
cz = cz + pol_AB(i,3) * overlap_gaussian_x( center_AB(3), C_center(3), AB_expo, gama, i, power_C, dim1)
enddo
int_gauss_deriv = int_gauss_deriv + fact_AB * dble(power_B(1)) * cx * cy * cz
endif
! ===============
power_D(1) = power_B(1) + 1
power_D(2) = power_B(2)
power_D(3) = power_B(3)
call give_explicit_poly_and_gaussian( pol_AB, center_AB, AB_expo, fact_AB &
, iorder, alpha, beta, power_A, power_D, A_center, B_center, dim1)
power_C = 1
cx = 0.d0
do i = 0, iorder(1)
cx = cx + pol_AB(i,1) * overlap_gaussian_x( center_AB(1), C_center(1), AB_expo, gama, i, power_C, dim1)
enddo
power_C = 0
cy = 0.d0
do i = 0, iorder(2)
cy = cy + pol_AB(i,2) * overlap_gaussian_x( center_AB(2), C_center(2), AB_expo, gama, i, power_C, dim1)
enddo
power_C = 0
cz = 0.d0
do i = 0, iorder(3)
cz = cz + pol_AB(i,3) * overlap_gaussian_x( center_AB(3), C_center(3), AB_expo, gama, i, power_C, dim1)
enddo
int_gauss_deriv = int_gauss_deriv - 2.d0 * beta * fact_AB * cx * cy * cz
! ===============
! ===============
! ===============
! term II:
! \partial_y
! ===============
if( power_B(2) .ge. 1 ) then
power_D(1) = power_B(1)
power_D(2) = power_B(2) - 1
power_D(3) = power_B(3)
call give_explicit_poly_and_gaussian( pol_AB, center_AB, AB_expo, fact_AB &
, iorder, alpha, beta, power_A, power_D, A_center, B_center, dim1)
power_C = 0
cx = 0.d0
do i = 0, iorder(1)
cx = cx + pol_AB(i,1) * overlap_gaussian_x( center_AB(1), C_center(1), AB_expo, gama, i, power_C, dim1)
enddo
power_C = 1
cy = 0.d0
do i = 0, iorder(2)
cy = cy + pol_AB(i,2) * overlap_gaussian_x( center_AB(2), C_center(2), AB_expo, gama, i, power_C, dim1)
enddo
power_C = 0
cz = 0.d0
do i = 0, iorder(3)
cz = cz + pol_AB(i,3) * overlap_gaussian_x( center_AB(3), C_center(3), AB_expo, gama, i, power_C, dim1)
enddo
int_gauss_deriv = int_gauss_deriv + fact_AB * dble(power_B(2)) * cx * cy * cz
endif
! ===============
power_D(1) = power_B(1)
power_D(2) = power_B(2) + 1
power_D(3) = power_B(3)
call give_explicit_poly_and_gaussian( pol_AB, center_AB, AB_expo, fact_AB &
, iorder, alpha, beta, power_A, power_D, A_center, B_center, dim1)
power_C = 0
cx = 0.d0
do i = 0, iorder(1)
cx = cx + pol_AB(i,1) * overlap_gaussian_x( center_AB(1), C_center(1), AB_expo, gama, i, power_C, dim1)
enddo
power_C = 1
cy = 0.d0
do i = 0, iorder(2)
cy = cy + pol_AB(i,2) * overlap_gaussian_x( center_AB(2), C_center(2), AB_expo, gama, i, power_C, dim1)
enddo
power_C = 0
cz = 0.d0
do i = 0, iorder(3)
cz = cz + pol_AB(i,3) * overlap_gaussian_x( center_AB(3), C_center(3), AB_expo, gama, i, power_C, dim1)
enddo
int_gauss_deriv = int_gauss_deriv - 2.d0 * beta * fact_AB * cx * cy * cz
! ===============
! ===============
! ===============
! term III:
! \partial_z
! ===============
if( power_B(3) .ge. 1 ) then
power_D(1) = power_B(1)
power_D(2) = power_B(2)
power_D(3) = power_B(3) - 1
call give_explicit_poly_and_gaussian( pol_AB, center_AB, AB_expo, fact_AB &
, iorder, alpha, beta, power_A, power_D, A_center, B_center, dim1)
power_C = 0
cx = 0.d0
do i = 0, iorder(1)
cx = cx + pol_AB(i,1) * overlap_gaussian_x( center_AB(1), C_center(1), AB_expo, gama, i, power_C, dim1)
enddo
power_C = 0
cy = 0.d0
do i = 0, iorder(2)
cy = cy + pol_AB(i,2) * overlap_gaussian_x( center_AB(2), C_center(2), AB_expo, gama, i, power_C, dim1)
enddo
power_C = 1
cz = 0.d0
do i = 0, iorder(3)
cz = cz + pol_AB(i,3) * overlap_gaussian_x( center_AB(3), C_center(3), AB_expo, gama, i, power_C, dim1)
enddo
int_gauss_deriv = int_gauss_deriv + fact_AB * dble(power_B(3)) * cx * cy * cz
endif
! ===============
power_D(1) = power_B(1)
power_D(2) = power_B(2)
power_D(3) = power_B(3) + 1
call give_explicit_poly_and_gaussian( pol_AB, center_AB, AB_expo, fact_AB &
, iorder, alpha, beta, power_A, power_D, A_center, B_center, dim1)
power_C = 0
cx = 0.d0
do i = 0, iorder(1)
cx = cx + pol_AB(i,1) * overlap_gaussian_x( center_AB(1), C_center(1), AB_expo, gama, i, power_C, dim1)
enddo
power_C = 0
cy = 0.d0
do i = 0, iorder(2)
cy = cy + pol_AB(i,2) * overlap_gaussian_x( center_AB(2), C_center(2), AB_expo, gama, i, power_C, dim1)
enddo
power_C = 1
cz = 0.d0
do i = 0, iorder(3)
cz = cz + pol_AB(i,3) * overlap_gaussian_x( center_AB(3), C_center(3), AB_expo, gama, i, power_C, dim1)
enddo
int_gauss_deriv = int_gauss_deriv - 2.d0 * beta * fact_AB * cx * cy * cz
! ===============
! ===============
return
end function int_gauss_deriv
!_____________________________________________________________________________________________________________
!_____________________________________________________________________________________________________________

203
src/ao_tc_eff_map/potential.irp.f Normal file
View File

@ -0,0 +1,203 @@
BEGIN_PROVIDER [integer, n_gauss_eff_pot]
implicit none
BEGIN_DOC
! number of gaussians to represent the effective potential :
!
! V(mu,r12) = -0.25 * (1 - erf(mu*r12))^2 + 1/(\sqrt(pi)mu) * exp(-(mu*r12)^2)
!
! Here (1 - erf(mu*r12))^2 is expanded in Gaussians as Eqs A11-A20 in JCP 154, 084119 (2021)
END_DOC
n_gauss_eff_pot = n_max_fit_slat + 1
END_PROVIDER
BEGIN_PROVIDER [integer, n_gauss_eff_pot_deriv]
implicit none
BEGIN_DOC
! V(r12) = -(1 - erf(mu*r12))^2 is expanded in Gaussians as Eqs A11-A20 in JCP 154, 084119 (2021)
END_DOC
n_gauss_eff_pot_deriv = n_max_fit_slat
END_PROVIDER
BEGIN_PROVIDER [double precision, expo_gauss_eff_pot, (n_gauss_eff_pot)]
&BEGIN_PROVIDER [double precision, coef_gauss_eff_pot, (n_gauss_eff_pot)]
implicit none
BEGIN_DOC
! Coefficients and exponents of the Fit on Gaussians of V(X) = -(1 - erf(mu*X))^2 + 1/(\sqrt(pi)mu) * exp(-(mu*X)^2)
!
! V(X) = \sum_{i=1,n_gauss_eff_pot} coef_gauss_eff_pot(i) * exp(-expo_gauss_eff_pot(i) * X^2)
!
! Relies on the fit proposed in Eqs A11-A20 in JCP 154, 084119 (2021)
END_DOC
include 'constants.include.F'
integer :: i
! fit of the -0.25 * (1 - erf(mu*x))^2 with n_max_fit_slat gaussians
do i = 1, n_max_fit_slat
expo_gauss_eff_pot(i) = expo_gauss_1_erf_x_2(i)
coef_gauss_eff_pot(i) = -0.25d0 * coef_gauss_1_erf_x_2(i) ! -1/4 * (1 - erf(mu*x))^2
enddo
! Analytical Gaussian part of the potential: + 1/(\sqrt(pi)mu) * exp(-(mu*x)^2)
expo_gauss_eff_pot(n_max_fit_slat+1) = mu_erf * mu_erf
coef_gauss_eff_pot(n_max_fit_slat+1) = 1.d0 * mu_erf * inv_sq_pi
END_PROVIDER
double precision function eff_pot_gauss(x,mu)
implicit none
BEGIN_DOC
! V(mu,r12) = -0.25 * (1 - erf(mu*r12))^2 + 1/(\sqrt(pi)mu) * exp(-(mu*r12)^2)
END_DOC
double precision, intent(in) :: x,mu
eff_pot_gauss = mu/dsqrt(dacos(-1.d0)) * dexp(-mu*mu*x*x) - 0.25d0 * (1.d0 - derf(mu*x))**2.d0
end
! -------------------------------------------------------------------------------------------------
! ---
double precision function eff_pot_fit_gauss(x)
implicit none
BEGIN_DOC
! V(mu,r12) = -0.25 * (1 - erf(mu*r12))^2 + 1/(\sqrt(pi)mu) * exp(-(mu*r12)^2)
!
! but fitted with gaussians
END_DOC
double precision, intent(in) :: x
integer :: i
double precision :: alpha
eff_pot_fit_gauss = derf(mu_erf*x)/x
do i = 1, n_gauss_eff_pot
alpha = expo_gauss_eff_pot(i)
eff_pot_fit_gauss += coef_gauss_eff_pot(i) * dexp(-alpha*x*x)
enddo
end
BEGIN_PROVIDER [integer, n_fit_1_erf_x]
implicit none
BEGIN_DOC
!
END_DOC
n_fit_1_erf_x = 2
END_PROVIDER
BEGIN_PROVIDER [double precision, expos_slat_gauss_1_erf_x, (n_fit_1_erf_x)]
implicit none
BEGIN_DOC
! 1 - erf(mu*x) is fitted with a Slater and gaussian as in Eq.A15 of JCP 154, 084119 (2021)
!
! 1 - erf(mu*x) = e^{-expos_slat_gauss_1_erf_x(1) * mu *x} * e^{-expos_slat_gauss_1_erf_x(2) * mu^2 * x^2}
END_DOC
expos_slat_gauss_1_erf_x(1) = 1.09529d0
expos_slat_gauss_1_erf_x(2) = 0.756023d0
END_PROVIDER
BEGIN_PROVIDER [double precision, expo_gauss_1_erf_x, (n_max_fit_slat)]
&BEGIN_PROVIDER [double precision, coef_gauss_1_erf_x, (n_max_fit_slat)]
implicit none
BEGIN_DOC
! (1 - erf(mu*x)) = \sum_i coef_gauss_1_erf_x(i) * exp(-expo_gauss_1_erf_x(i) * x^2)
!
! This is based on a fit of (1 - erf(mu*x)) by exp(-alpha * x) exp(-beta*mu^2x^2)
!
! and the slater function exp(-alpha * x) is fitted with n_max_fit_slat gaussians
!
! See Appendix 2 of JCP 154, 084119 (2021)
END_DOC
integer :: i
double precision :: expos(n_max_fit_slat),alpha,beta
alpha = expos_slat_gauss_1_erf_x(1) * mu_erf
call expo_fit_slater_gam(alpha,expos)
beta = expos_slat_gauss_1_erf_x(2) * mu_erf**2.d0
do i = 1, n_max_fit_slat
expo_gauss_1_erf_x(i) = expos(i) + beta
coef_gauss_1_erf_x(i) = coef_fit_slat_gauss(i)
enddo
END_PROVIDER
double precision function fit_1_erf_x(x)
implicit none
double precision, intent(in) :: x
BEGIN_DOC
! fit_1_erf_x(x) = \sum_i c_i exp (-alpha_i x^2) \approx (1 - erf(mu*x))
END_DOC
integer :: i
fit_1_erf_x = 0.d0
do i = 1, n_max_fit_slat
fit_1_erf_x += dexp(-expo_gauss_1_erf_x(i) *x*x) * coef_gauss_1_erf_x(i)
enddo
end
BEGIN_PROVIDER [double precision, expo_gauss_1_erf_x_2, (n_max_fit_slat)]
&BEGIN_PROVIDER [double precision, coef_gauss_1_erf_x_2, (n_max_fit_slat)]
implicit none
BEGIN_DOC
! (1 - erf(mu*x))^2 = \sum_i coef_gauss_1_erf_x_2(i) * exp(-expo_gauss_1_erf_x_2(i) * x^2)
!
! This is based on a fit of (1 - erf(mu*x)) by exp(-alpha * x) exp(-beta*mu^2x^2)
!
! and the slater function exp(-alpha * x) is fitted with n_max_fit_slat gaussians
END_DOC
integer :: i
double precision :: expos(n_max_fit_slat),alpha,beta
alpha = 2.d0 * expos_slat_gauss_1_erf_x(1) * mu_erf
call expo_fit_slater_gam(alpha,expos)
beta = 2.d0 * expos_slat_gauss_1_erf_x(2) * mu_erf**2.d0
do i = 1, n_max_fit_slat
expo_gauss_1_erf_x_2(i) = expos(i) + beta
coef_gauss_1_erf_x_2(i) = coef_fit_slat_gauss(i)
enddo
END_PROVIDER
double precision function fit_1_erf_x_2(x)
implicit none
double precision, intent(in) :: x
BEGIN_DOC
! fit_1_erf_x_2(x) = \sum_i c_i exp (-alpha_i x^2) \approx (1 - erf(mu*x))^2
END_DOC
integer :: i
fit_1_erf_x_2 = 0.d0
do i = 1, n_max_fit_slat
fit_1_erf_x_2 += dexp(-expo_gauss_1_erf_x_2(i) *x*x) * coef_gauss_1_erf_x_2(i)
enddo
end
subroutine inv_r_times_poly(r, dist_r, dist_vec, poly)
implicit none
BEGIN_DOC
! returns
!
! poly(1) = x / sqrt(x^2+y^2+z^2), poly(2) = y / sqrt(x^2+y^2+z^2), poly(3) = z / sqrt(x^2+y^2+z^2)
!
! with the arguments
!
! r(1) = x, r(2) = y, r(3) = z, dist_r = sqrt(x^2+y^2+z^2)
!
! dist_vec(1) = sqrt(y^2+z^2), dist_vec(2) = sqrt(x^2+z^2), dist_vec(3) = sqrt(x^2+y^2)
END_DOC
double precision, intent(in) :: r(3), dist_r, dist_vec(3)
double precision, intent(out):: poly(3)
double precision :: inv_dist
integer :: i
if (dist_r.gt. 1.d-8)then
inv_dist = 1.d0/dist_r
do i = 1, 3
poly(i) = r(i) * inv_dist
enddo
else
do i = 1, 3
if(dabs(r(i)).lt.dist_vec(i))then
inv_dist = 1.d0/dist_r
poly(i) = r(i) * inv_dist
else !if(dabs(r(i)))then
poly(i) = 1.d0
! poly(i) = 0.d0
endif
enddo
endif
end

86
src/ao_tc_eff_map/providers_ao_eff_pot.irp.f Normal file
View File

@ -0,0 +1,86 @@
BEGIN_PROVIDER [ logical, ao_tc_sym_two_e_pot_in_map ]
implicit none
use f77_zmq
use map_module
BEGIN_DOC
! Map of Atomic integrals
! i(r1) j(r2) 1/r12 k(r1) l(r2)
END_DOC
integer :: i,j,k,l
double precision :: ao_tc_sym_two_e_pot,cpu_1,cpu_2, wall_1, wall_2
double precision :: integral, wall_0
include 'utils/constants.include.F'
! For integrals file
integer(key_kind),allocatable :: buffer_i(:)
integer,parameter :: size_buffer = 1024*64
real(integral_kind),allocatable :: buffer_value(:)
integer :: n_integrals, rc
integer :: kk, m, j1, i1, lmax
character*(64) :: fmt
!double precision :: j1b_gauss_coul_debug
!integral = j1b_gauss_coul_debug(1,1,1,1)
integral = ao_tc_sym_two_e_pot(1,1,1,1)
double precision :: map_mb
print*, 'Providing the ao_tc_sym_two_e_pot_map integrals'
call wall_time(wall_0)
call wall_time(wall_1)
call cpu_time(cpu_1)
integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull
call new_parallel_job(zmq_to_qp_run_socket,zmq_socket_pull,'ao_tc_sym_two_e_pot')
character(len=:), allocatable :: task
allocate(character(len=ao_num*12) :: task)
write(fmt,*) '(', ao_num, '(I5,X,I5,''|''))'
do l=1,ao_num
write(task,fmt) (i,l, i=1,l)
integer, external :: add_task_to_taskserver
if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) == -1) then
stop 'Unable to add task to server'
endif
enddo
deallocate(task)
integer, external :: zmq_set_running
if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
print *, irp_here, ': Failed in zmq_set_running'
endif
PROVIDE nproc
!$OMP PARALLEL DEFAULT(shared) private(i) num_threads(nproc+1)
i = omp_get_thread_num()
if (i==0) then
call ao_tc_sym_two_e_pot_in_map_collector(zmq_socket_pull)
else
call ao_tc_sym_two_e_pot_in_map_slave_inproc(i)
endif
!$OMP END PARALLEL
call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'ao_tc_sym_two_e_pot')
print*, 'Sorting the map'
call map_sort(ao_tc_sym_two_e_pot_map)
call cpu_time(cpu_2)
call wall_time(wall_2)
integer(map_size_kind) :: get_ao_tc_sym_two_e_pot_map_size, ao_eff_pot_map_size
ao_eff_pot_map_size = get_ao_tc_sym_two_e_pot_map_size()
print*, 'AO eff_pot integrals provided:'
print*, ' Size of AO eff_pot map : ', map_mb(ao_tc_sym_two_e_pot_map) ,'MB'
print*, ' Number of AO eff_pot integrals :', ao_eff_pot_map_size
print*, ' cpu time :',cpu_2 - cpu_1, 's'
print*, ' wall time :',wall_2 - wall_1, 's ( x ', (cpu_2-cpu_1)/(wall_2-wall_1+tiny(1.d0)), ' )'
ao_tc_sym_two_e_pot_in_map = .True.
END_PROVIDER

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

@ -0,0 +1,800 @@
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 Normal file
View File

@ -0,0 +1,433 @@
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 Normal file
View File

@ -0,0 +1,397 @@
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 Normal file
View File

@ -0,0 +1,324 @@
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 Normal file
View File

@ -0,0 +1,102 @@
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

624
src/ao_tc_eff_map/two_e_1bgauss_coulerf_schwartz.irp.f Normal file
View File

@ -0,0 +1,624 @@
double precision function j1b_gauss_coulerf_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) [ 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 :: 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(:,:)
PROVIDE j1b_gauss_pen
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( 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_coulerf_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( 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( dim1, cx, cy, cz &
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p &
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q )
j1b_gauss_coulerf_schwartz = j1b_gauss_coulerf_schwartz + coef4 * ( cx + cy + cz )
enddo ! s
enddo ! r
enddo ! q
enddo ! p
deallocate( schwartz_kl )
return
end function j1b_gauss_coulerf_schwartz
subroutine get_cxcycz( dim1, cx, cy, cz &
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p &
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q )
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 :: 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
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-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_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 * 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_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 * 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_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 * 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_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 * 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_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 * 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_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 * 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_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 * 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_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 * 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_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 * 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 [ (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 )
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_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 * 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_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 * 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_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 * 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_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 * 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_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 * 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_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 * 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_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 * 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_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 * 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 [ (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 )
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_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 * 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_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 * 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_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 * 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_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 * 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_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 * 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_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 * 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_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 * 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_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 * 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_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 * 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_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 * 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_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 * 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 [ (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 )
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_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 * 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_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 * 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_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 * 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_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 * 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_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 * 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_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 * 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_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 * 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_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 * 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_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 * 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_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 * 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_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 * 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

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

@ -0,0 +1,854 @@
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 Normal file
View File

@ -0,0 +1,433 @@
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

326
src/ao_tc_eff_map/two_e_ints_gauss.irp.f Normal file
View File

@ -0,0 +1,326 @@
double precision function ao_tc_sym_two_e_pot(i,j,k,l)
implicit none
BEGIN_DOC
! integral of the AO basis <ik|jl> or (ij|kl)
! i(r1) j(r1) (tc_pot(r12,mu)) k(r2) l(r2)
!
! where (tc_pot(r12,mu)) is the scalar part of the potential EXCLUDING the term erf(mu r12)/r12.
!
! See Eq. (32) of JCP 154, 084119 (2021).
END_DOC
integer,intent(in) :: i,j,k,l
integer :: p,q,r,s
double precision :: I_center(3),J_center(3),K_center(3),L_center(3)
integer :: num_i,num_j,num_k,num_l,dim1,I_power(3),J_power(3),K_power(3),L_power(3)
double precision :: integral
include 'utils/constants.include.F'
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
integer :: iorder_p(3), iorder_q(3)
double precision, allocatable :: schwartz_kl(:,:)
double precision :: schwartz_ij
double precision :: scw_gauss_int,general_primitive_integral_gauss
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)
ao_tc_sym_two_e_pot = 0.d0
double precision :: thr
thr = ao_integrals_threshold*ao_integrals_threshold
allocate(schwartz_kl(0:ao_prim_num(l),0:ao_prim_num(k)))
double precision :: coef3
double precision :: coef2
double precision :: p_inv,q_inv
double precision :: coef1
double precision :: coef4
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
schwartz_kl(0,0) = 0.d0
do r = 1, ao_prim_num(k)
coef1 = 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)
coef2 = coef1 * ao_coef_normalized_ordered_transp(s,l) * ao_coef_normalized_ordered_transp(s,l)
call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,&
ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l), &
K_power,L_power,K_center,L_center,dim1)
q_inv = 1.d0/qq
scw_gauss_int = general_primitive_integral_gauss(dim1, &
Q_new,Q_center,fact_q,qq,q_inv,iorder_q, &
Q_new,Q_center,fact_q,qq,q_inv,iorder_q)
schwartz_kl(s,r) = dabs(scw_gauss_int * coef2)
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
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p,i)
do q = 1, ao_prim_num(j)
coef2 = coef1*ao_coef_normalized_ordered_transp(q,j)
call give_explicit_poly_and_gaussian(P_new,P_center,pp,fact_p,iorder_p,&
ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j), &
I_power,J_power,I_center,J_center,dim1)
p_inv = 1.d0/pp
scw_gauss_int = general_primitive_integral_gauss(dim1, &
P_new,P_center,fact_p,pp,p_inv,iorder_p, &
P_new,P_center,fact_p,pp,p_inv,iorder_p)
schwartz_ij = dabs(scw_gauss_int * coef2*coef2)
if (schwartz_kl(0,0)*schwartz_ij < thr) then
cycle
endif
do r = 1, ao_prim_num(k)
if (schwartz_kl(0,r)*schwartz_ij < thr) then
cycle
endif
coef3 = coef2*ao_coef_normalized_ordered_transp(r,k)
do s = 1, ao_prim_num(l)
if (schwartz_kl(s,r)*schwartz_ij < thr) then
cycle
endif
coef4 = coef3*ao_coef_normalized_ordered_transp(s,l)
call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q, &
ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l), &
K_power,L_power,K_center,L_center,dim1)
q_inv = 1.d0/qq
integral = general_primitive_integral_gauss(dim1, &
P_new,P_center,fact_p,pp,p_inv,iorder_p, &
Q_new,Q_center,fact_q,qq,q_inv,iorder_q)
ao_tc_sym_two_e_pot = ao_tc_sym_two_e_pot + coef4 * integral
enddo ! s
enddo ! r
enddo ! q
enddo ! p
deallocate (schwartz_kl)
end
double precision function general_primitive_integral_gauss(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)
double precision :: thr
thr = ao_integrals_threshold
general_primitive_integral_gauss = 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)) < thr) cycle
a = P_new(ix,1)
do jx = 0, iorder_q(1)
d = a*Q_new(jx,1)
if (abs(d) < thr) 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)) > thr) then
b = P_new(iy,2)
do jy = 0, iorder_q(2)
e = b*Q_new(jy,2)
if (abs(e) < thr) 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)) > thr) then
c = P_new(iz,3)
do jz = 0, iorder_q(3)
f = c*Q_new(jz,3)
if (abs(f) < thr) 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 :: aa,c_a,t_a,rho_old,w_a,pi_3,prefactor,inv_pq_3_2
double precision :: gauss_int
integer :: m
gauss_int = 0.d0
pi_3 = pi*pi*pi
inv_pq_3_2 = (p_inv * q_inv)**(1.5d0)
rho_old = (p*q)/(p+q)
prefactor = pi_3 * inv_pq_3_2 * fact_p * fact_q
do i = 1, n_gauss_eff_pot ! browse the gaussians with different expo/coef
aa = expo_gauss_eff_pot(i)
c_a = coef_gauss_eff_pot(i)
t_a = dsqrt( aa /(rho_old + aa) )
w_a = dexp(-t_a*t_a*rho_old*dist)
accu = 0.d0
! evaluation of the polynom Ix(t_a) * Iy(t_a) * Iz(t_a)
do m = 0, n_pt_out,2
accu += d1(m) * (t_a)**(dble(m))
enddo
! equation A8 of PRA-70-062505 (2004) of Toul. Col. Sav.
gauss_int = gauss_int + c_a * prefactor * (1.d0 - t_a*t_a)**(1.5d0) * w_a * accu
enddo
general_primitive_integral_gauss = gauss_int
end
subroutine compute_ao_integrals_gauss_jl(j,l,n_integrals,buffer_i,buffer_value)
implicit none
use map_module
BEGIN_DOC
! Parallel client for AO integrals
END_DOC
integer, intent(in) :: j,l
integer,intent(out) :: n_integrals
integer(key_kind),intent(out) :: buffer_i(ao_num*ao_num)
real(integral_kind),intent(out) :: buffer_value(ao_num*ao_num)
integer :: i,k
double precision :: cpu_1,cpu_2, wall_1, wall_2
double precision :: integral, wall_0
double precision :: thr,ao_tc_sym_two_e_pot
integer :: kk, m, j1, i1
logical, external :: ao_two_e_integral_zero
thr = ao_integrals_threshold
n_integrals = 0
j1 = j+ishft(l*l-l,-1)
do k = 1, ao_num ! r1
i1 = ishft(k*k-k,-1)
if (i1 > j1) then
exit
endif
do i = 1, k
i1 += 1
if (i1 > j1) then
exit
endif
! if (ao_two_e_integral_zero(i,j,k,l)) then
if (.False.) then
cycle
endif
if (ao_two_e_integral_erf_schwartz(i,k)*ao_two_e_integral_erf_schwartz(j,l) < thr ) then
cycle
endif
!DIR$ FORCEINLINE
integral = ao_tc_sym_two_e_pot(i,k,j,l) ! i,k : r1 j,l : r2
if (abs(integral) < thr) then
cycle
endif
n_integrals += 1
!DIR$ FORCEINLINE
call two_e_integrals_index(i,j,k,l,buffer_i(n_integrals))
buffer_value(n_integrals) = integral
enddo
enddo
end

3
src/bi_ort_ints/NEED Normal file
View File

@ -0,0 +1,3 @@
non_h_ints_mu
ao_tc_eff_map
bi_ortho_mos

25
src/bi_ort_ints/README.rst Normal file
View File

@ -0,0 +1,25 @@
===========
bi_ort_ints
===========
This module contains all necessary integrals for the TC Hamiltonian in a bi-orthonormal (BO) MO Basis.
See in bi_ortho_basis for more information.
The main providers are :
One-electron integrals
----------------------
+) ao_one_e_integrals_tc_tot : total one-electron Hamiltonian which might include non hermitian part coming from one-e correlation factor.
+) mo_bi_ortho_tc_one_e : one-electron Hamiltonian (h_core+one-J terms) on the BO-MO basis.
+) mo_bi_orth_bipole_x : x-component of the dipole operator on the BO-MO basis. (Same for y,z)
Two-electron integrals
----------------------
+) ao_two_e_tc_tot : Total two-electron operator (including the non-hermitian term of the TC Hamiltonian) on the AO basis
+) mo_bi_ortho_tc_two_e : Total two-electron operator on the BO-MO basis
Three-electron integrals
------------------------
+) three_body_ints_bi_ort : 6-indices three-electron tensor (-L) on the BO-MO basis. WARNING :: N^6 storage !
+) three_e_3_idx_direct_bi_ort : DIRECT term with 3 different indices of the -L operator. These terms appear in the DIAGONAL matrix element of the -L operator. The 5 other permutations needed to compute matrix elements can be found in three_body_ijm.irp.f
+) three_e_4_idx_direct_bi_ort : DIRECT term with 4 different indices of the -L operator. These terms appear in the OFF-DIAGONAL matrix element of the -L operator including SINGLE EXCITATIONS. The 5 other permutations needed to compute matrix elements can be found in three_body_ijmk.irp.f
+) three_e_5_idx_direct_bi_ort : DIRECT term with 5 different indices of the -L operator. These terms appear in the OFF-DIAGONAL matrix element of the -L operator including DOUBLE EXCITATIONS. The 5 other permutations needed to compute matrix elements can be found in three_body_ijmkl.irp.f

123
src/bi_ort_ints/bi_ort_ints.irp.f Normal file
View File

@ -0,0 +1,123 @@
program bi_ort_ints
implicit none
BEGIN_DOC
! TODO : Put the documentation of the program here
END_DOC
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
! call test_overlap
! call routine_twoe
! call routine_onee
! call test_v_ki_bi_ortho
! call test_x_v_ki_bi_ortho
! call test_3_body_bi_ort
! call test_3_e_diag
! call test_3_e_diag_cycle1
! call test_3_e
call routine_test_one_int
end
subroutine routine_test_one_int
implicit none
integer :: p,q,r,s,ii
integer :: i,j
i = 3
j = 5
double precision :: accu
double precision, allocatable :: vec(:)
integer, allocatable :: iorder(:)
allocate(vec(ao_num**4),iorder(ao_num**4))
accu = 0.d0
ii = 0
do p = 1, ao_num !
do q = 1, ao_num
do r = 1, ao_num
do s = 1, ao_num
!<ji | ji>
!
! j j i i
if(dabs(mo_l_coef(s,j) * mo_l_coef(q,i) * ao_two_e_tc_tot(s,r,q,p) * mo_r_coef(p,i) * mo_r_coef(r,j)).gt.10)then
write(33,'(3(F16.10,X),4(I3,X))')mo_l_coef(s,j) * mo_l_coef(q,i)* mo_r_coef(p,i) * mo_r_coef(r,j) , ao_two_e_tc_tot(s,r,q,p), mo_l_coef(s,j) * mo_l_coef(q,i) * ao_two_e_tc_tot(s,r,q,p) * mo_r_coef(p,i) * mo_r_coef(r,j) , s,q,p,r
endif
ii += 1
iorder(ii) = ii
vec(ii) = mo_l_coef(s,j) * mo_l_coef(q,i) * ao_two_e_tc_tot(s,r,q,p) * mo_r_coef(p,i) * mo_r_coef(r,j)
accu += mo_l_coef(s,j) * mo_l_coef(q,i) * ao_two_e_tc_tot(s,r,q,p) * mo_r_coef(p,i) * mo_r_coef(r,j)
enddo
enddo
enddo
enddo
call dsort(vec,iorder,ao_num**4)
accu = 0.d0
do i = 1, ao_num**4
accu += vec(i)
write(34,*)i,vec(i),accu
enddo
print*,'accu = ',accu
end
subroutine routine_twoe
implicit none
integer :: i,j,k,l
double precision :: old, get_mo_two_e_integral_tc_int
double precision :: ref,new, accu, contrib, bi_ortho_mo_ints
accu = 0.d0
print*,'Testing the bi ortho two e'
do j = 1, mo_num
do i = 1, mo_num
do l = 1, mo_num
do k = 1, mo_num
! mo_non_hermit_term(k,l,i,j) = <k l| V(r_12) |i j>
! ref = bi_ortho_mo_ints(k,l,i,j)
ref = bi_ortho_mo_ints(l,k,j,i)
new = mo_bi_ortho_tc_two_e(l,k,j,i)
! old = get_mo_two_e_integral_tc_int(k,l,i,j,mo_integrals_tc_int_map)
! old += mo_non_hermit_term(l,k,j,i)
contrib = dabs(ref - new)
if(dabs(ref).gt.1.d-10)then
if(contrib.gt.1.d-10)then
print*,k,l,i,j
print*,ref,new,contrib
endif
endif
accu += contrib
enddo
enddo
enddo
enddo
print*,'accu = ',accu/(dble(mo_num)**4)
end
subroutine routine_onee
implicit none
integer :: i,k
double precision :: ref,new,accu,contrib
print*,'Testing the bi ortho one e'
accu = 0.d0
do i = 1, mo_num
do k = 1, mo_num
ref = mo_bi_ortho_tc_one_e_slow(k,i)
new = mo_bi_ortho_tc_one_e(k,i)
contrib = dabs(ref - new)
if(dabs(ref).gt.1.d-10)then
if(contrib .gt. 1.d-10)then
print*,'i,k',i,k
print*,ref,new,contrib
endif
endif
accu += contrib
enddo
enddo
print*,'accu = ',accu/mo_num**2
end

70
src/bi_ort_ints/one_e_bi_ort.irp.f Normal file
View File

@ -0,0 +1,70 @@
! ---
BEGIN_PROVIDER [double precision, ao_one_e_integrals_tc_tot, (ao_num,ao_num)]
implicit none
integer :: i, j
ao_one_e_integrals_tc_tot = ao_one_e_integrals
provide j1b_gauss
if(j1b_gauss .eq. 1) then
do i = 1, ao_num
do j = 1, ao_num
ao_one_e_integrals_tc_tot(j,i) += ( j1b_gauss_hermI (j,i) &
+ j1b_gauss_hermII (j,i) &
+ j1b_gauss_nonherm(j,i) )
enddo
enddo
endif
END_PROVIDER
BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_one_e, (mo_num, mo_num)]
implicit none
BEGIN_DOC
! mo_bi_ortho_tc_one_e(k,i) = <MO^L_k | h_c | MO^R_i>
END_DOC
integer :: i,k,p,q
call ao_to_mo_bi_ortho(ao_one_e_integrals_tc_tot, ao_num, mo_bi_ortho_tc_one_e, mo_num)
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, mo_bi_orth_bipole_x , (mo_num,mo_num)]
&BEGIN_PROVIDER [double precision, mo_bi_orth_bipole_y , (mo_num,mo_num)]
&BEGIN_PROVIDER [double precision, mo_bi_orth_bipole_z , (mo_num,mo_num)]
BEGIN_DOC
! array of the integrals of MO_i * x MO_j
! array of the integrals of MO_i * y MO_j
! array of the integrals of MO_i * z MO_j
END_DOC
implicit none
call ao_to_mo_bi_ortho( &
ao_dipole_x, &
size(ao_dipole_x,1), &
mo_bi_orth_bipole_x, &
size(mo_bi_orth_bipole_x,1) &
)
call ao_to_mo_bi_ortho( &
ao_dipole_y, &
size(ao_dipole_y,1), &
mo_bi_orth_bipole_y, &
size(mo_bi_orth_bipole_y,1) &
)
call ao_to_mo_bi_ortho( &
ao_dipole_z, &
size(ao_dipole_z,1), &
mo_bi_orth_bipole_z, &
size(mo_bi_orth_bipole_z,1) &
)
END_PROVIDER

177
src/bi_ort_ints/semi_num_ints_mo.irp.f Normal file
View File

@ -0,0 +1,177 @@
BEGIN_PROVIDER [ double precision, mo_v_ki_bi_ortho_erf_rk_cst_mu, ( mo_num, mo_num,n_points_final_grid)]
implicit none
BEGIN_DOC
! mo_v_ki_bi_ortho_erf_rk_cst_mu(k,i,ip) = int dr chi_k(r) phi_i(r) (erf(mu |r - R_ip|) - 1 )/(2|r - R_ip|) on the BI-ORTHO MO basis
!
! where phi_k(r) is a LEFT MOs and phi_i(r) is a RIGHT MO
!
! R_ip = the "ip"-th point of the DFT Grid
END_DOC
integer :: ipoint
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint) &
!$OMP SHARED (n_points_final_grid,v_ij_erf_rk_cst_mu,mo_v_ki_bi_ortho_erf_rk_cst_mu)
!$OMP DO SCHEDULE (dynamic)
! TODO :: optimization : transform into a DGEMM
do ipoint = 1, n_points_final_grid
call ao_to_mo_bi_ortho(v_ij_erf_rk_cst_mu(1,1,ipoint),size(v_ij_erf_rk_cst_mu,1),mo_v_ki_bi_ortho_erf_rk_cst_mu(1,1,ipoint),size(mo_v_ki_bi_ortho_erf_rk_cst_mu,1))
enddo
!$OMP END DO
!$OMP END PARALLEL
mo_v_ki_bi_ortho_erf_rk_cst_mu = mo_v_ki_bi_ortho_erf_rk_cst_mu * 0.5d0
END_PROVIDER
BEGIN_PROVIDER [ double precision, mo_v_ki_bi_ortho_erf_rk_cst_mu_transp, ( n_points_final_grid,mo_num, mo_num)]
implicit none
BEGIN_DOC
! int dr phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/(2|r - R|) on the BI-ORTHO MO basis
END_DOC
integer :: ipoint,i,j
do i = 1, mo_num
do j = 1, mo_num
do ipoint = 1, n_points_final_grid
mo_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,j,i) = mo_v_ki_bi_ortho_erf_rk_cst_mu(j,i,ipoint)
enddo
enddo
enddo
! FREE mo_v_ki_bi_ortho_erf_rk_cst_mu
END_PROVIDER
BEGIN_PROVIDER [ double precision, mo_x_v_ki_bi_ortho_erf_rk_cst_mu, ( mo_num, mo_num,3,n_points_final_grid)]
implicit none
BEGIN_DOC
! mo_x_v_ki_bi_ortho_erf_rk_cst_mu(k,i,m,ip) = int dr x(m) * chi_k(r) phi_i(r) (erf(mu |r - R_ip|) - 1)/2|r - R_ip| on the BI-ORTHO MO basis
!
! where chi_k(r)/phi_i(r) are left/right MOs, m=1 => x(m) = x, m=2 => x(m) = y, m=3 => x(m) = z,
!
! R_ip = the "ip"-th point of the DFT Grid
END_DOC
integer :: ipoint,m
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint,m) &
!$OMP SHARED (n_points_final_grid,x_v_ij_erf_rk_cst_mu_transp,mo_x_v_ki_bi_ortho_erf_rk_cst_mu)
!$OMP DO SCHEDULE (dynamic)
! TODO :: optimization : transform into a DGEMM
do ipoint = 1, n_points_final_grid
do m = 1, 3
call ao_to_mo_bi_ortho(x_v_ij_erf_rk_cst_mu_transp(1,1,m,ipoint),size(x_v_ij_erf_rk_cst_mu_transp,1),mo_x_v_ki_bi_ortho_erf_rk_cst_mu(1,1,m,ipoint),size(mo_x_v_ki_bi_ortho_erf_rk_cst_mu,1))
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
mo_x_v_ki_bi_ortho_erf_rk_cst_mu = 0.5d0 * mo_x_v_ki_bi_ortho_erf_rk_cst_mu
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, m, ipoint
do i = 1, mo_num
do j = 1, mo_num
do m = 1, 3
do ipoint = 1, n_points_final_grid
mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,m,j,i) = mo_x_v_ki_bi_ortho_erf_rk_cst_mu(j,i,m,ipoint)
enddo
enddo
enddo
enddo
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, x_W_ki_bi_ortho_erf_rk, (n_points_final_grid, 3, mo_num, mo_num)]
BEGIN_DOC
! x_W_ki_bi_ortho_erf_rk(ip,m,k,i) = \int dr chi_k(r) (1 - erf(mu |r-R_ip|)) (x(m)-X(m)_ip) phi_i(r) ON THE BI-ORTHO MO BASIS
!
! where chi_k(r)/phi_i(r) are left/right MOs, m=1 => X(m) = x, m=2 => X(m) = y, m=3 => X(m) = z,
!
! R_ip = the "ip"-th point of the DFT Grid
END_DOC
implicit none
include 'constants.include.F'
integer :: ipoint, m, i, k
double precision :: xyz
double precision :: wall0, wall1
print*,'providing x_W_ki_bi_ortho_erf_rk ...'
call wall_time(wall0)
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint,m,i,k,xyz) &
!$OMP SHARED (x_W_ki_bi_ortho_erf_rk,n_points_final_grid,mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp,mo_v_ki_bi_ortho_erf_rk_cst_mu_transp,mo_num,final_grid_points)
!$OMP DO SCHEDULE (dynamic)
do i = 1, mo_num
do k = 1, mo_num
do m = 1, 3
do ipoint = 1, n_points_final_grid
xyz = final_grid_points(m,ipoint)
x_W_ki_bi_ortho_erf_rk(ipoint,m,k,i) = mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,m,k,i) - xyz * mo_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,k,i)
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
! FREE mo_v_ki_bi_ortho_erf_rk_cst_mu_transp
! FREE mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp
call wall_time(wall1)
print*,'time to provide x_W_ki_bi_ortho_erf_rk = ',wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, x_W_ki_bi_ortho_erf_rk_diag, (n_points_final_grid, 3, mo_num)]
BEGIN_DOC
! x_W_ki_bi_ortho_erf_rk_diag(ip,m,i) = \int dr chi_i(r) (1 - erf(mu |r-R_ip|)) (x(m)-X(m)_ip) phi_i(r) ON THE BI-ORTHO MO BASIS
!
! where chi_k(r)/phi_i(r) are left/right MOs, m=1 => X(m) = x, m=2 => X(m) = y, m=3 => X(m) = z,
!
! R_ip = the "ip"-th point of the DFT Grid
END_DOC
implicit none
include 'constants.include.F'
integer :: ipoint, m, i
double precision :: xyz
double precision :: wall0, wall1
print*,'providing x_W_ki_bi_ortho_erf_rk_diag ...'
call wall_time(wall0)
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint,m,i,xyz) &
!$OMP SHARED (x_W_ki_bi_ortho_erf_rk_diag,n_points_final_grid,mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp,mo_v_ki_bi_ortho_erf_rk_cst_mu_transp,mo_num,final_grid_points)
!$OMP DO SCHEDULE (dynamic)
do i = 1, mo_num
do m = 1, 3
do ipoint = 1, n_points_final_grid
xyz = final_grid_points(m,ipoint)
x_W_ki_bi_ortho_erf_rk_diag(ipoint,m,i) = mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,m,i,i) - xyz * mo_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,i,i)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print*,'time to provide x_W_ki_bi_ortho_erf_rk_diag = ',wall1 - wall0
END_PROVIDER
! ---

304
src/bi_ort_ints/three_body_ijm.irp.f Normal file
View File

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

228
src/bi_ort_ints/three_body_ijmk.irp.f Normal file
View File

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

240
src/bi_ort_ints/three_body_ijmkl.irp.f Normal file
View File

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

78
src/bi_ort_ints/three_body_ints_bi_ort.irp.f Normal file
View File

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

138
src/bi_ort_ints/total_twoe_pot.irp.f Normal file
View File

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

2
src/bi_ortho_aos/NEED Normal file
View File

@ -0,0 +1,2 @@
basis
ao_basis

5
src/bi_ortho_aos/README.rst Normal file
View File

@ -0,0 +1,5 @@
============
bi_ortho_aos
============
TODO

97
src/bi_ortho_aos/aos_l.irp.f Normal file
View File

@ -0,0 +1,97 @@
BEGIN_PROVIDER [ double precision, ao_coef_l , (ao_num,ao_prim_num_max) ]
implicit none
BEGIN_DOC
! Primitive coefficients and exponents for each atomic orbital. Copied from shell info.
END_DOC
integer :: i, l
do i=1,ao_num
l = ao_shell(i)
ao_coef_l(i,:) = shell_coef(l,:)
end do
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_coef_l_normalized, (ao_num,ao_prim_num_max) ]
&BEGIN_PROVIDER [ double precision, ao_coef_l_normalization_factor, (ao_num) ]
implicit none
BEGIN_DOC
! Coefficients including the |AO| normalization
END_DOC
do i=1,ao_num
l = ao_shell(i)
ao_coef_l_normalized(i,:) = shell_coef(l,:) * shell_normalization_factor(l)
end do
double precision :: norm,overlap_x,overlap_y,overlap_z,C_A(3), c
integer :: l, powA(3), nz
integer :: i,j,k
nz=100
C_A = 0.d0
do i=1,ao_num
powA(1) = ao_power(i,1)
powA(2) = ao_power(i,2)
powA(3) = ao_power(i,3)
! Normalization of the primitives
if (primitives_normalized) then
do j=1,ao_prim_num(i)
call overlap_gaussian_xyz(C_A,C_A,ao_expo(i,j),ao_expo(i,j), &
powA,powA,overlap_x,overlap_y,overlap_z,norm,nz)
ao_coef_l_normalized(i,j) = ao_coef_l_normalized(i,j)/dsqrt(norm)
enddo
endif
! Normalization of the contracted basis functions
if (ao_normalized) then
norm = 0.d0
do j=1,ao_prim_num(i)
do k=1,ao_prim_num(i)
call overlap_gaussian_xyz(C_A,C_A,ao_expo(i,j),ao_expo(i,k),powA,powA,overlap_x,overlap_y,overlap_z,c,nz)
norm = norm+c*ao_coef_l_normalized(i,j)*ao_coef_l_normalized(i,k)
enddo
enddo
ao_coef_l_normalization_factor(i) = 1.d0/dsqrt(norm)
else
ao_coef_l_normalization_factor(i) = 1.d0
endif
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_coef_l_normalized_ordered, (ao_num,ao_prim_num_max) ]
implicit none
BEGIN_DOC
! Sorted primitives to accelerate 4 index |MO| transformation
END_DOC
integer :: iorder(ao_prim_num_max)
double precision :: d(ao_prim_num_max,2)
integer :: i,j
do i=1,ao_num
do j=1,ao_prim_num(i)
iorder(j) = j
d(j,2) = ao_coef_l_normalized(i,j)
enddo
call dsort(d(1,1),iorder,ao_prim_num(i))
call dset_order(d(1,2),iorder,ao_prim_num(i))
do j=1,ao_prim_num(i)
ao_coef_l_normalized_ordered(i,j) = d(j,2)
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_coef_l_normalized_ordered_transp, (ao_prim_num_max,ao_num) ]
implicit none
BEGIN_DOC
! Transposed :c:data:`ao_coef_l_normalized_ordered`
END_DOC
integer :: i,j
do j=1, ao_num
do i=1, ao_prim_num_max
ao_coef_l_normalized_ordered_transp(i,j) = ao_coef_l_normalized_ordered(j,i)
enddo
enddo
END_PROVIDER

97
src/bi_ortho_aos/aos_r.irp.f Normal file
View File

@ -0,0 +1,97 @@
BEGIN_PROVIDER [ double precision, ao_coef_r , (ao_num,ao_prim_num_max) ]
implicit none
BEGIN_DOC
! Primitive coefficients and exponents for each atomic orbital. Copied from shell info.
END_DOC
integer :: i, l
do i=1,ao_num
l = ao_shell(i)
ao_coef_r(i,:) = shell_coef(l,:)
end do
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_coef_r_normalized, (ao_num,ao_prim_num_max) ]
&BEGIN_PROVIDER [ double precision, ao_coef_r_normalization_factor, (ao_num) ]
implicit none
BEGIN_DOC
! Coefficients including the |AO| normalization
END_DOC
do i=1,ao_num
l = ao_shell(i)
ao_coef_r_normalized(i,:) = shell_coef(l,:) * shell_normalization_factor(l)
end do
double precision :: norm,overlap_x,overlap_y,overlap_z,C_A(3), c
integer :: l, powA(3), nz
integer :: i,j,k
nz=100
C_A = 0.d0
do i=1,ao_num
powA(1) = ao_power(i,1)
powA(2) = ao_power(i,2)
powA(3) = ao_power(i,3)
! Normalization of the primitives
if (primitives_normalized) then
do j=1,ao_prim_num(i)
call overlap_gaussian_xyz(C_A,C_A,ao_expo(i,j),ao_expo(i,j), &
powA,powA,overlap_x,overlap_y,overlap_z,norm,nz)
ao_coef_r_normalized(i,j) = ao_coef_r_normalized(i,j)/dsqrt(norm)
enddo
endif
! Normalization of the contracted basis functions
if (ao_normalized) then
norm = 0.d0
do j=1,ao_prim_num(i)
do k=1,ao_prim_num(i)
call overlap_gaussian_xyz(C_A,C_A,ao_expo(i,j),ao_expo(i,k),powA,powA,overlap_x,overlap_y,overlap_z,c,nz)
norm = norm+c*ao_coef_r_normalized(i,j)*ao_coef_r_normalized(i,k)
enddo
enddo
ao_coef_r_normalization_factor(i) = 1.d0/dsqrt(norm)
else
ao_coef_r_normalization_factor(i) = 1.d0
endif
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_coef_r_normalized_ordered, (ao_num,ao_prim_num_max) ]
implicit none
BEGIN_DOC
! Sorted primitives to accelerate 4 index |MO| transformation
END_DOC
integer :: iorder(ao_prim_num_max)
double precision :: d(ao_prim_num_max,2)
integer :: i,j
do i=1,ao_num
do j=1,ao_prim_num(i)
iorder(j) = j
d(j,2) = ao_coef_r_normalized(i,j)
enddo
call dsort(d(1,1),iorder,ao_prim_num(i))
call dset_order(d(1,2),iorder,ao_prim_num(i))
do j=1,ao_prim_num(i)
ao_coef_r_normalized_ordered(i,j) = d(j,2)
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_coef_r_normalized_ordered_transp, (ao_prim_num_max,ao_num) ]
implicit none
BEGIN_DOC
! Transposed :c:data:`ao_coef_r_normalized_ordered`
END_DOC
integer :: i,j
do j=1, ao_num
do i=1, ao_prim_num_max
ao_coef_r_normalized_ordered_transp(i,j) = ao_coef_r_normalized_ordered(j,i)
enddo
enddo
END_PROVIDER

11
src/bi_ortho_mos/EZFIO.cfg Normal file
View File

@ -0,0 +1,11 @@
[mo_r_coef]
type: double precision
doc: right-coefficient of the i-th |AO| on the j-th |MO|
interface: ezfio
size: (ao_basis.ao_num,mo_basis.mo_num)
[mo_l_coef]
type: double precision
doc: right-coefficient of the i-th |AO| on the j-th |MO|
interface: ezfio
size: (ao_basis.ao_num,mo_basis.mo_num)

3
src/bi_ortho_mos/NEED Normal file
View File

@ -0,0 +1,3 @@
mo_basis
becke_numerical_grid
dft_utils_in_r

49
src/bi_ortho_mos/bi_density.irp.f Normal file
View File

@ -0,0 +1,49 @@
! ---
BEGIN_PROVIDER [double precision, TCSCF_bi_ort_dm_ao_alpha, (ao_num, ao_num) ]
implicit none
BEGIN_DOC
! TCSCF_bi_ort_dm_ao_alpha(i,j) = <Chi_0| a^dagger_i,alpha a_j,alpha |Phi_0> where i,j are AO basis.
!
! This is the equivalent of the alpha density of the HF Slater determinant, but with a couple of bi-orthonormal Slater determinant |Chi_0> and |Phi_0>
END_DOC
call dgemm( 'N', 'T', ao_num, ao_num, elec_alpha_num, 1.d0 &
, mo_l_coef, size(mo_l_coef, 1), mo_r_coef, size(mo_r_coef, 1) &
, 0.d0, TCSCF_bi_ort_dm_ao_alpha, size(TCSCF_bi_ort_dm_ao_alpha, 1) )
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, TCSCF_bi_ort_dm_ao_beta, (ao_num, ao_num) ]
implicit none
BEGIN_DOC
! TCSCF_bi_ort_dm_ao_beta(i,j) = <Chi_0| a^dagger_i,beta a_j,beta |Phi_0> where i,j are AO basis.
!
! This is the equivalent of the beta density of the HF Slater determinant, but with a couple of bi-orthonormal Slater determinant |Chi_0> and |Phi_0>
END_DOC
call dgemm( 'N', 'T', ao_num, ao_num, elec_beta_num, 1.d0 &
, mo_l_coef, size(mo_l_coef, 1), mo_r_coef, size(mo_r_coef, 1) &
, 0.d0, TCSCF_bi_ort_dm_ao_beta, size(TCSCF_bi_ort_dm_ao_beta, 1) )
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, TCSCF_bi_ort_dm_ao, (ao_num, ao_num) ]
implicit none
BEGIN_DOC
! TCSCF_bi_ort_dm_ao(i,j) = <Chi_0| a^dagger_i,beta+alpha a_j,beta+alpha |Phi_0> where i,j are AO basis.
!
! This is the equivalent of the total electronic density of the HF Slater determinant, but with a couple of bi-orthonormal Slater determinant |Chi_0> and |Phi_0>
END_DOC
ASSERT ( size(TCSCF_bi_ort_dm_ao, 1) == size(TCSCF_bi_ort_dm_ao_alpha, 1) )
if( elec_alpha_num==elec_beta_num ) then
TCSCF_bi_ort_dm_ao = TCSCF_bi_ort_dm_ao_alpha + TCSCF_bi_ort_dm_ao_alpha
else
ASSERT ( size(TCSCF_bi_ort_dm_ao, 1) == size(TCSCF_bi_ort_dm_ao_beta, 1))
TCSCF_bi_ort_dm_ao = TCSCF_bi_ort_dm_ao_alpha + TCSCF_bi_ort_dm_ao_beta
endif
END_PROVIDER
! ---

137
src/bi_ortho_mos/bi_ort_mos_in_r.irp.f Normal file
View File

@ -0,0 +1,137 @@
! TODO: left & right MO without duplicate AO calculation
! ---
BEGIN_PROVIDER[double precision, mos_r_in_r_array, (mo_num, n_points_final_grid)]
BEGIN_DOC
! mos_in_r_array(i,j) = value of the ith RIGHT mo on the jth grid point
END_DOC
implicit none
integer :: i, j
double precision :: mos_array(mo_num), r(3)
!$OMP PARALLEL DO &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, r, mos_array) &
!$OMP SHARED (mos_r_in_r_array, n_points_final_grid, mo_num, final_grid_points)
do i = 1, n_points_final_grid
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
call give_all_mos_r_at_r(r, mos_array)
do j = 1, mo_num
mos_r_in_r_array(j,i) = mos_array(j)
enddo
enddo
!$OMP END PARALLEL DO
END_PROVIDER
! ---
BEGIN_PROVIDER[double precision, mos_r_in_r_array_transp, (n_points_final_grid, mo_num)]
BEGIN_DOC
! mos_r_in_r_array_transp(i,j) = value of the jth mo on the ith grid point
END_DOC
implicit none
integer :: i,j
do i = 1, n_points_final_grid
do j = 1, mo_num
mos_r_in_r_array_transp(i,j) = mos_r_in_r_array(j,i)
enddo
enddo
END_PROVIDER
! ---
subroutine give_all_mos_r_at_r(r, mos_r_array)
BEGIN_DOC
! mos_r_array(i) = ith RIGHT MO function evaluated at "r"
END_DOC
implicit none
double precision, intent(in) :: r(3)
double precision, intent(out) :: mos_r_array(mo_num)
double precision :: aos_array(ao_num)
call give_all_aos_at_r(r, aos_array)
call dgemv('N', mo_num, ao_num, 1.d0, mo_r_coef_transp, mo_num, aos_array, 1, 0.d0, mos_r_array, 1)
end subroutine give_all_mos_r_at_r
! ---
BEGIN_PROVIDER[double precision, mos_l_in_r_array, (mo_num, n_points_final_grid)]
BEGIN_DOC
! mos_in_r_array(i,j) = value of the ith LEFT mo on the jth grid point
END_DOC
implicit none
integer :: i, j
double precision :: mos_array(mo_num), r(3)
!$OMP PARALLEL DO &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,r,mos_array,j) &
!$OMP SHARED(mos_l_in_r_array,n_points_final_grid,mo_num,final_grid_points)
do i = 1, n_points_final_grid
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
call give_all_mos_l_at_r(r, mos_array)
do j = 1, mo_num
mos_l_in_r_array(j,i) = mos_array(j)
enddo
enddo
!$OMP END PARALLEL DO
END_PROVIDER
! ---
subroutine give_all_mos_l_at_r(r, mos_l_array)
BEGIN_DOC
! mos_l_array(i) = ith LEFT MO function evaluated at "r"
END_DOC
implicit none
double precision, intent(in) :: r(3)
double precision, intent(out) :: mos_l_array(mo_num)
double precision :: aos_array(ao_num)
call give_all_aos_at_r(r, aos_array)
call dgemv('N', mo_num, ao_num, 1.d0, mo_l_coef_transp, mo_num, aos_array, 1, 0.d0, mos_l_array, 1)
end subroutine give_all_mos_l_at_r
! ---
BEGIN_PROVIDER[double precision, mos_l_in_r_array_transp,(n_points_final_grid,mo_num)]
BEGIN_DOC
! mos_l_in_r_array_transp(i,j) = value of the jth mo on the ith grid point
END_DOC
implicit none
integer :: i, j
do i = 1, n_points_final_grid
do j = 1, mo_num
mos_l_in_r_array_transp(i,j) = mos_l_in_r_array(j,i)
enddo
enddo
END_PROVIDER
! ---

100
src/bi_ortho_mos/grad_bi_ort_mos_in_r.irp.f Normal file
View File

@ -0,0 +1,100 @@
BEGIN_PROVIDER[double precision, mos_r_grad_in_r_array,(mo_num,n_points_final_grid,3)]
implicit none
BEGIN_DOC
! mos_r_grad_in_r_array(i,j,k) = value of the kth component of the gradient of ith RIGHT mo on the jth grid point
!
! k = 1 : x, k= 2, y, k 3, z
END_DOC
integer :: m
mos_r_grad_in_r_array = 0.d0
do m=1,3
call dgemm('N','N',mo_num,n_points_final_grid,ao_num,1.d0,mo_r_coef_transp,mo_num,aos_grad_in_r_array(1,1,m),ao_num,0.d0,mos_r_grad_in_r_array(1,1,m),mo_num)
enddo
END_PROVIDER
BEGIN_PROVIDER[double precision, mos_r_grad_in_r_array_transp,(3,mo_num,n_points_final_grid)]
implicit none
BEGIN_DOC
! mos_r_grad_in_r_array_transp(i,j,k) = value of the kth component of the gradient of jth RIGHT mo on the ith grid point
!
! k = 1 : x, k= 2, y, k 3, z
END_DOC
integer :: m
integer :: i,j
mos_r_grad_in_r_array_transp = 0.d0
do i = 1, n_points_final_grid
do j = 1, mo_num
do m = 1, 3
mos_r_grad_in_r_array_transp(m,j,i) = mos_r_grad_in_r_array(j,i,m)
enddo
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER[double precision, mos_r_grad_in_r_array_transp_bis,(3,n_points_final_grid,mo_num)]
implicit none
BEGIN_DOC
! mos_r_grad_in_r_array_transp(i,j,k) = value of the ith component of the gradient on the jth grid point of jth RIGHT MO
END_DOC
integer :: m
integer :: i,j
mos_r_grad_in_r_array_transp_bis = 0.d0
do j = 1, mo_num
do i = 1, n_points_final_grid
do m = 1, 3
mos_r_grad_in_r_array_transp_bis(m,i,j) = mos_r_grad_in_r_array(j,i,m)
enddo
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER[double precision, mos_l_grad_in_r_array,(mo_num,n_points_final_grid,3)]
implicit none
BEGIN_DOC
! mos_l_grad_in_r_array(i,j,k) = value of the kth component of the gradient of ith RIGHT mo on the jth grid point
!
! k = 1 : x, k= 2, y, k 3, z
END_DOC
integer :: m
mos_l_grad_in_r_array = 0.d0
do m=1,3
call dgemm('N','N',mo_num,n_points_final_grid,ao_num,1.d0,mo_r_coef_transp,mo_num,aos_grad_in_r_array(1,1,m),ao_num,0.d0,mos_l_grad_in_r_array(1,1,m),mo_num)
enddo
END_PROVIDER
BEGIN_PROVIDER[double precision, mos_l_grad_in_r_array_transp,(3,mo_num,n_points_final_grid)]
implicit none
BEGIN_DOC
! mos_l_grad_in_r_array_transp(i,j,k) = value of the kth component of the gradient of jth RIGHT mo on the ith grid point
!
! k = 1 : x, k= 2, y, k 3, z
END_DOC
integer :: m
integer :: i,j
mos_l_grad_in_r_array_transp = 0.d0
do i = 1, n_points_final_grid
do j = 1, mo_num
do m = 1, 3
mos_l_grad_in_r_array_transp(m,j,i) = mos_l_grad_in_r_array(j,i,m)
enddo
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER[double precision, mos_l_grad_in_r_array_transp_bis,(3,n_points_final_grid,mo_num)]
implicit none
BEGIN_DOC
! mos_l_grad_in_r_array_transp(i,j,k) = value of the ith component of the gradient on the jth grid point of jth RIGHT MO
END_DOC
integer :: m
integer :: i,j
mos_l_grad_in_r_array_transp_bis = 0.d0
do j = 1, mo_num
do i = 1, n_points_final_grid
do m = 1, 3
mos_l_grad_in_r_array_transp_bis(m,i,j) = mos_l_grad_in_r_array(j,i,m)
enddo
enddo
enddo
END_PROVIDER

173
src/bi_ortho_mos/mos_rl.irp.f Normal file
View File

@ -0,0 +1,173 @@
subroutine ao_to_mo_bi_ortho(A_ao, LDA_ao, A_mo, LDA_mo)
BEGIN_DOC
! Transform A from the |AO| basis to the BI ORTHONORMAL MOS
!
! $C_L^\dagger.A_{ao}.C_R$ where C_L and C_R are the LEFT and RIGHT MO coefs
END_DOC
implicit none
integer, intent(in) :: LDA_ao,LDA_mo
double precision, intent(in) :: A_ao(LDA_ao,ao_num)
double precision, intent(out) :: A_mo(LDA_mo,mo_num)
double precision, allocatable :: T(:,:)
allocate ( T(ao_num,mo_num) )
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T
integer :: i,j,p,q
call dgemm('N', 'N', ao_num, mo_num, ao_num, &
1.d0, A_ao, LDA_ao, &
mo_r_coef, size(mo_r_coef, 1), &
0.d0, T, size(T, 1))
call dgemm('T', 'N', mo_num, mo_num, ao_num, &
1.d0, mo_l_coef, size(mo_l_coef, 1), &
T, ao_num, &
0.d0, A_mo, size(A_mo, 1))
! call restore_symmetry(mo_num,mo_num,A_mo,size(A_mo,1),1.d-12)
deallocate(T)
end subroutine ao_to_mo_bi_ortho
! ---
BEGIN_PROVIDER [ double precision, mo_r_coef, (ao_num, mo_num) ]
BEGIN_DOC
!
! Molecular right-orbital coefficients on |AO| basis set
!
END_DOC
implicit none
integer :: i, j
logical :: exists
PROVIDE ezfio_filename
if (mpi_master) then
call ezfio_has_bi_ortho_mos_mo_r_coef(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(exists, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read mo_r_coef with MPI'
endif
IRP_ENDIF
if (exists) then
if (mpi_master) then
call ezfio_get_bi_ortho_mos_mo_r_coef(mo_r_coef)
write(*,*) 'Read mo_r_coef'
endif
IRP_IF MPI
call MPI_BCAST(mo_r_coef, mo_num*ao_num, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read mo_r_coef with MPI'
endif
IRP_ENDIF
else
print*, 'mo_r_coef are mo_coef'
do i = 1, mo_num
do j = 1, ao_num
mo_r_coef(j,i) = mo_coef(j,i)
enddo
enddo
endif
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, mo_l_coef, (ao_num, mo_num) ]
BEGIN_DOC
!
! Molecular left-orbital coefficients on |AO| basis set
!
END_DOC
implicit none
integer :: i, j
logical :: exists
PROVIDE ezfio_filename
if (mpi_master) then
call ezfio_has_bi_ortho_mos_mo_l_coef(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(exists, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read mo_l_coef with MPI'
endif
IRP_ENDIF
if (exists) then
if (mpi_master) then
call ezfio_get_bi_ortho_mos_mo_l_coef(mo_l_coef)
write(*,*) 'Read mo_l_coef'
endif
IRP_IF MPI
call MPI_BCAST(mo_l_coef, mo_num*ao_num, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read mo_l_coef with MPI'
endif
IRP_ENDIF
else
print*, 'mo_r_coef are mo_coef'
do i = 1, mo_num
do j = 1, ao_num
mo_l_coef(j,i) = mo_coef(j,i)
enddo
enddo
endif
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, mo_r_coef_transp, (mo_num, ao_num)]
implicit none
integer :: j, m
do j = 1, mo_num
do m = 1, ao_num
mo_r_coef_transp(j,m) = mo_r_coef(m,j)
enddo
enddo
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, mo_l_coef_transp, (mo_num, ao_num)]
implicit none
integer :: j, m
do j = 1, mo_num
do m = 1, ao_num
mo_l_coef_transp(j,m) = mo_l_coef(m,j)
enddo
enddo
END_PROVIDER
! ---

120
src/bi_ortho_mos/overlap.irp.f Normal file
View File

@ -0,0 +1,120 @@
BEGIN_PROVIDER [ double precision, overlap_bi_ortho, (mo_num, mo_num)]
&BEGIN_PROVIDER [ double precision, overlap_diag_bi_ortho, (mo_num)]
BEGIN_DOC
! Overlap matrix between the RIGHT and LEFT MOs. Should be the identity matrix
END_DOC
implicit none
integer :: i, k, m, n
double precision :: accu_d, accu_nd
double precision, allocatable :: tmp(:,:)
! TODO : re do the DEGEMM
overlap_bi_ortho = 0.d0
do i = 1, mo_num
do k = 1, mo_num
do m = 1, ao_num
do n = 1, ao_num
overlap_bi_ortho(k,i) += ao_overlap(n,m) * mo_l_coef(n,k) * mo_r_coef(m,i)
enddo
enddo
enddo
enddo
! allocate( tmp(mo_num,ao_num) )
!
! ! tmp <-- L.T x S_ao
! call dgemm( "T", "N", mo_num, ao_num, ao_num, 1.d0 &
! , mo_l_coef, size(mo_l_coef, 1), ao_overlap, size(ao_overlap, 1) &
! , 0.d0, tmp, size(tmp, 1) )
!
! ! S <-- tmp x R
! call dgemm( "N", "N", mo_num, mo_num, ao_num, 1.d0 &
! , tmp, size(tmp, 1), mo_r_coef, size(mo_r_coef, 1) &
! , 0.d0, overlap_bi_ortho, size(overlap_bi_ortho, 1) )
!
! deallocate( tmp )
do i = 1, mo_num
overlap_diag_bi_ortho(i) = overlap_bi_ortho(i,i)
enddo
accu_d = 0.d0
accu_nd = 0.d0
do i = 1, mo_num
do k = 1, mo_num
if(i==k) then
accu_d += dabs(overlap_bi_ortho(k,i))
else
accu_nd += dabs(overlap_bi_ortho(k,i))
endif
enddo
enddo
accu_d = accu_d/dble(mo_num)
accu_nd = accu_nd/dble(mo_num**2-mo_num)
if(dabs(accu_d-1.d0).gt.1.d-10.or.dabs(accu_nd).gt.1.d-10)then
print*,'Warning !!!'
print*,'Average trace of overlap_bi_ortho is different from 1 by ', accu_d
print*,'And bi orthogonality is off by an average of ',accu_nd
print*,'****************'
print*,'Overlap matrix betwee mo_l_coef and mo_r_coef '
do i = 1, mo_num
write(*,'(100(F16.10,X))')overlap_bi_ortho(i,:)
enddo
endif
print*,'Average trace of overlap_bi_ortho (should be 1.)'
print*,'accu_d = ',accu_d
print*,'Sum of off diagonal terms of overlap_bi_ortho (should be zero)'
print*,'accu_nd = ',accu_nd
print*,'****************'
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, overlap_mo_r, (mo_num, mo_num)]
&BEGIN_PROVIDER [ double precision, overlap_mo_l, (mo_num, mo_num)]
implicit none
BEGIN_DOC
! overlap_mo_r_mo(j,i) = <MO_i|MO_R_j>
END_DOC
integer :: i,j,p,q
overlap_mo_r= 0.d0
overlap_mo_l= 0.d0
do i = 1, mo_num
do j = 1, mo_num
do p = 1, ao_num
do q = 1, ao_num
overlap_mo_r(j,i) += mo_r_coef(q,i) * mo_r_coef(p,j) * ao_overlap(q,p)
overlap_mo_l(j,i) += mo_l_coef(q,i) * mo_l_coef(p,j) * ao_overlap(q,p)
enddo
enddo
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, overlap_mo_r_mo, (mo_num, mo_num)]
&BEGIN_PROVIDER [ double precision, overlap_mo_l_mo, (mo_num, mo_num)]
implicit none
BEGIN_DOC
! overlap_mo_r_mo(j,i) = <MO_j|MO_R_i>
END_DOC
integer :: i,j,p,q
overlap_mo_r_mo = 0.d0
overlap_mo_l_mo = 0.d0
do i = 1, mo_num
do j = 1, mo_num
do p = 1, ao_num
do q = 1, ao_num
overlap_mo_r_mo(j,i) += mo_coef(p,j) * mo_r_coef(q,i) * ao_overlap(q,p)
overlap_mo_l_mo(j,i) += mo_coef(p,j) * mo_l_coef(q,i) * ao_overlap(q,p)
enddo
enddo
enddo
enddo
END_PROVIDER

2
src/non_h_ints_mu/NEED Normal file
View File

@ -0,0 +1,2 @@
ao_tc_eff_map
bi_ortho_mos

11
src/non_h_ints_mu/README.rst Normal file
View File

@ -0,0 +1,11 @@
=============
non_h_ints_mu
=============
Computes the non hermitian potential of the mu-TC Hamiltonian on the AO and BI-ORTHO MO basis.
The operator is defined in Eq. 33 of JCP 154, 084119 (2021)
The two providers are :
+) ao_non_hermit_term_chemist which returns the non hermitian part of the two-electron TC Hamiltonian on the MO basis.
+) mo_non_hermit_term_chemist which returns the non hermitian part of the two-electron TC Hamiltonian on the BI-ORTHO MO basis.

177
src/non_h_ints_mu/grad_tc_int.irp.f Normal file
View File

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

73
src/utils/integration.irp.f
View File

@ -412,6 +412,79 @@ subroutine recentered_poly2(P_new,x_A,x_P,a,P_new2,x_B,x_Q,b)
enddo
end
subroutine pol_modif_center(A_center, B_center, iorder, A_pol, B_pol)
BEGIN_DOC
!
! Transform the pol centerd on A:
! [ \sum_i ax_i (x-x_A)^i ] [ \sum_j ay_j (y-y_A)^j ] [ \sum_k az_k (z-z_A)^k ]
! to a pol centered on B
! [ \sum_i bx_i (x-x_B)^i ] [ \sum_j by_j (y-y_B)^j ] [ \sum_k bz_k (z-z_B)^k ]
!
END_DOC
! useful for max_dim
include 'constants.include.F'
implicit none
integer, intent(in) :: iorder(3)
double precision, intent(in) :: A_center(3), B_center(3)
double precision, intent(in) :: A_pol(0:max_dim, 3)
double precision, intent(out) :: B_pol(0:max_dim, 3)
integer :: i, Lmax
do i = 1, 3
Lmax = iorder(i)
call pol_modif_center_x( A_center(i), B_center(i), Lmax, A_pol(0:Lmax, i), B_pol(0:Lmax, i) )
enddo
return
end subroutine pol_modif_center
subroutine pol_modif_center_x(A_center, B_center, iorder, A_pol, B_pol)
BEGIN_DOC
!
! Transform the pol centerd on A:
! [ \sum_i ax_i (x-x_A)^i ]
! to a pol centered on B
! [ \sum_i bx_i (x-x_B)^i ]
!
! bx_i = \sum_{j=i}^{iorder} ax_j (x_B - x_A)^(j-i) j! / [ i! (j-i)! ]
! = \sum_{j=i}^{iorder} ax_j (x_B - x_A)^(j-i) binom_func(j,i)
!
END_DOC
implicit none
integer, intent(in) :: iorder
double precision, intent(in) :: A_center, B_center
double precision, intent(in) :: A_pol(0:iorder)
double precision, intent(out) :: B_pol(0:iorder)
integer :: i, j
double precision :: fact_tmp, dx
double precision :: binom_func
dx = B_center - A_center
do i = 0, iorder
fact_tmp = 0.d0
do j = i, iorder
fact_tmp += A_pol(j) * binom_func(j, i) * dx**dble(j-i)
enddo
B_pol(i) = fact_tmp
enddo
return
end subroutine pol_modif_center_x