diff --git a/src/ao_many_one_e_ints/NEED b/src/ao_many_one_e_ints/NEED new file mode 100644 index 00000000..0d08442c --- /dev/null +++ b/src/ao_many_one_e_ints/NEED @@ -0,0 +1,5 @@ +ao_one_e_ints +ao_two_e_ints +becke_numerical_grid +mo_one_e_ints +dft_utils_in_r diff --git a/src/ao_many_one_e_ints/README.rst b/src/ao_many_one_e_ints/README.rst new file mode 100644 index 00000000..6d2c083f --- /dev/null +++ b/src/ao_many_one_e_ints/README.rst @@ -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. diff --git a/src/ao_many_one_e_ints/ao_erf_gauss.irp.f b/src/ao_many_one_e_ints/ao_erf_gauss.irp.f new file mode 100644 index 00000000..39be352f --- /dev/null +++ b/src/ao_many_one_e_ints/ao_erf_gauss.irp.f @@ -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 + diff --git a/src/ao_many_one_e_ints/ao_erf_gauss_grad.irp.f b/src/ao_many_one_e_ints/ao_erf_gauss_grad.irp.f new file mode 100644 index 00000000..8a32c38a --- /dev/null +++ b/src/ao_many_one_e_ints/ao_erf_gauss_grad.irp.f @@ -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 diff --git a/src/ao_many_one_e_ints/ao_gaus_gauss.irp.f b/src/ao_many_one_e_ints/ao_gaus_gauss.irp.f new file mode 100644 index 00000000..cd9a486d --- /dev/null +++ b/src/ao_many_one_e_ints/ao_gaus_gauss.irp.f @@ -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 + + diff --git a/src/ao_many_one_e_ints/fit_slat_gauss.irp.f b/src/ao_many_one_e_ints/fit_slat_gauss.irp.f new file mode 100644 index 00000000..052ad072 --- /dev/null +++ b/src/ao_many_one_e_ints/fit_slat_gauss.irp.f @@ -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 + diff --git a/src/ao_many_one_e_ints/grad_related_ints.irp.f b/src/ao_many_one_e_ints/grad_related_ints.irp.f new file mode 100644 index 00000000..c3c886f8 --- /dev/null +++ b/src/ao_many_one_e_ints/grad_related_ints.irp.f @@ -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 + diff --git a/src/ao_many_one_e_ints/prim_int_erf_gauss.irp.f b/src/ao_many_one_e_ints/prim_int_erf_gauss.irp.f new file mode 100644 index 00000000..641d25fe --- /dev/null +++ b/src/ao_many_one_e_ints/prim_int_erf_gauss.irp.f @@ -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 + diff --git a/src/ao_many_one_e_ints/prim_int_gauss_gauss.irp.f b/src/ao_many_one_e_ints/prim_int_gauss_gauss.irp.f new file mode 100644 index 00000000..749227ea --- /dev/null +++ b/src/ao_many_one_e_ints/prim_int_gauss_gauss.irp.f @@ -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 diff --git a/src/ao_many_one_e_ints/stg_gauss_int.irp.f b/src/ao_many_one_e_ints/stg_gauss_int.irp.f new file mode 100644 index 00000000..384f744b --- /dev/null +++ b/src/ao_many_one_e_ints/stg_gauss_int.irp.f @@ -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 diff --git a/src/ao_many_one_e_ints/taylor_exp.irp.f b/src/ao_many_one_e_ints/taylor_exp.irp.f new file mode 100644 index 00000000..9857875a --- /dev/null +++ b/src/ao_many_one_e_ints/taylor_exp.irp.f @@ -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 diff --git a/src/ao_many_one_e_ints/xyz_grad_xyz_ao_pol.irp.f b/src/ao_many_one_e_ints/xyz_grad_xyz_ao_pol.irp.f new file mode 100644 index 00000000..eed1c348 --- /dev/null +++ b/src/ao_many_one_e_ints/xyz_grad_xyz_ao_pol.irp.f @@ -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 + + diff --git a/src/ao_tc_eff_map/EZFIO.cfg b/src/ao_tc_eff_map/EZFIO.cfg new file mode 100644 index 00000000..1c72e2f5 --- /dev/null +++ b/src/ao_tc_eff_map/EZFIO.cfg @@ -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 diff --git a/src/ao_tc_eff_map/NEED b/src/ao_tc_eff_map/NEED new file mode 100644 index 00000000..38638c7c --- /dev/null +++ b/src/ao_tc_eff_map/NEED @@ -0,0 +1,4 @@ +ao_two_e_erf_ints +mo_one_e_ints +ao_many_one_e_ints +dft_utils_in_r diff --git a/src/ao_tc_eff_map/README.rst b/src/ao_tc_eff_map/README.rst new file mode 100644 index 00000000..d45df18f --- /dev/null +++ b/src/ao_tc_eff_map/README.rst @@ -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. diff --git a/src/ao_tc_eff_map/compute_ints_eff_pot.irp.f b/src/ao_tc_eff_map/compute_ints_eff_pot.irp.f new file mode 100644 index 00000000..6196f56e --- /dev/null +++ b/src/ao_tc_eff_map/compute_ints_eff_pot.irp.f @@ -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 + diff --git a/src/ao_tc_eff_map/integrals_eff_pot_in_map_slave.irp.f b/src/ao_tc_eff_map/integrals_eff_pot_in_map_slave.irp.f new file mode 100644 index 00000000..28401cc4 --- /dev/null +++ b/src/ao_tc_eff_map/integrals_eff_pot_in_map_slave.irp.f @@ -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 + diff --git a/src/ao_tc_eff_map/j1b_1eInteg.py b/src/ao_tc_eff_map/j1b_1eInteg.py new file mode 100644 index 00000000..53fb1a41 --- /dev/null +++ b/src/ao_tc_eff_map/j1b_1eInteg.py @@ -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.)) +# _____________________________________________________________________________ + + + diff --git a/src/ao_tc_eff_map/j1b_pen.irp.f b/src/ao_tc_eff_map/j1b_pen.irp.f new file mode 100644 index 00000000..9587cfe2 --- /dev/null +++ b/src/ao_tc_eff_map/j1b_pen.irp.f @@ -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 + +! --- + + diff --git a/src/ao_tc_eff_map/map_integrals_eff_pot.irp.f b/src/ao_tc_eff_map/map_integrals_eff_pot.irp.f new file mode 100644 index 00000000..aea4644f --- /dev/null +++ b/src/ao_tc_eff_map/map_integrals_eff_pot.irp.f @@ -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 + + + + diff --git a/src/ao_tc_eff_map/one_e_1bgauss_hermit.irp.f b/src/ao_tc_eff_map/one_e_1bgauss_hermit.irp.f new file mode 100644 index 00000000..21b6ed83 --- /dev/null +++ b/src/ao_tc_eff_map/one_e_1bgauss_hermit.irp.f @@ -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 +!_____________________________________________________________________________________________________________ +!_____________________________________________________________________________________________________________ diff --git a/src/ao_tc_eff_map/one_e_1bgauss_nonherm.irp.f b/src/ao_tc_eff_map/one_e_1bgauss_nonherm.irp.f new file mode 100644 index 00000000..3ae3e019 --- /dev/null +++ b/src/ao_tc_eff_map/one_e_1bgauss_nonherm.irp.f @@ -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 +!_____________________________________________________________________________________________________________ +!_____________________________________________________________________________________________________________ diff --git a/src/ao_tc_eff_map/potential.irp.f b/src/ao_tc_eff_map/potential.irp.f new file mode 100644 index 00000000..2f7ea4d6 --- /dev/null +++ b/src/ao_tc_eff_map/potential.irp.f @@ -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 diff --git a/src/ao_tc_eff_map/providers_ao_eff_pot.irp.f b/src/ao_tc_eff_map/providers_ao_eff_pot.irp.f new file mode 100644 index 00000000..055bf323 --- /dev/null +++ b/src/ao_tc_eff_map/providers_ao_eff_pot.irp.f @@ -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 diff --git a/src/ao_tc_eff_map/two_e_1bgauss_coul.irp.f b/src/ao_tc_eff_map/two_e_1bgauss_coul.irp.f new file mode 100644 index 00000000..8d819711 --- /dev/null +++ b/src/ao_tc_eff_map/two_e_1bgauss_coul.irp.f @@ -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 +!______________________________________________________________________________________________________________________ +!______________________________________________________________________________________________________________________ diff --git a/src/ao_tc_eff_map/two_e_1bgauss_coul_acc.irp.f b/src/ao_tc_eff_map/two_e_1bgauss_coul_acc.irp.f new file mode 100644 index 00000000..cee9183c --- /dev/null +++ b/src/ao_tc_eff_map/two_e_1bgauss_coul_acc.irp.f @@ -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 diff --git a/src/ao_tc_eff_map/two_e_1bgauss_coul_debug.irp.f b/src/ao_tc_eff_map/two_e_1bgauss_coul_debug.irp.f new file mode 100644 index 00000000..8ced59e4 --- /dev/null +++ b/src/ao_tc_eff_map/two_e_1bgauss_coul_debug.irp.f @@ -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 + diff --git a/src/ao_tc_eff_map/two_e_1bgauss_coul_modifdebug.irp.f b/src/ao_tc_eff_map/two_e_1bgauss_coul_modifdebug.irp.f new file mode 100644 index 00000000..753fff8f --- /dev/null +++ b/src/ao_tc_eff_map/two_e_1bgauss_coul_modifdebug.irp.f @@ -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 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 diff --git a/src/ao_tc_eff_map/two_e_1bgauss_coulerf.irp.f b/src/ao_tc_eff_map/two_e_1bgauss_coulerf.irp.f new file mode 100644 index 00000000..92512bd7 --- /dev/null +++ b/src/ao_tc_eff_map/two_e_1bgauss_coulerf.irp.f @@ -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 + diff --git a/src/ao_tc_eff_map/two_e_1bgauss_coulerf_schwartz.irp.f b/src/ao_tc_eff_map/two_e_1bgauss_coulerf_schwartz.irp.f new file mode 100644 index 00000000..f2ba8276 --- /dev/null +++ b/src/ao_tc_eff_map/two_e_1bgauss_coulerf_schwartz.irp.f @@ -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 + diff --git a/src/ao_tc_eff_map/two_e_1bgauss_erf.irp.f b/src/ao_tc_eff_map/two_e_1bgauss_erf.irp.f new file mode 100644 index 00000000..f5ff5499 --- /dev/null +++ b/src/ao_tc_eff_map/two_e_1bgauss_erf.irp.f @@ -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 +!______________________________________________________________________________________________________________________ +!______________________________________________________________________________________________________________________ diff --git a/src/ao_tc_eff_map/two_e_1bgauss_erf_acc.irp.f b/src/ao_tc_eff_map/two_e_1bgauss_erf_acc.irp.f new file mode 100644 index 00000000..54210c44 --- /dev/null +++ b/src/ao_tc_eff_map/two_e_1bgauss_erf_acc.irp.f @@ -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 diff --git a/src/ao_tc_eff_map/two_e_ints_gauss.irp.f b/src/ao_tc_eff_map/two_e_ints_gauss.irp.f new file mode 100644 index 00000000..988b0b58 --- /dev/null +++ b/src/ao_tc_eff_map/two_e_ints_gauss.irp.f @@ -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 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 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 diff --git a/src/bi_ort_ints/NEED b/src/bi_ort_ints/NEED new file mode 100644 index 00000000..4142e19f --- /dev/null +++ b/src/bi_ort_ints/NEED @@ -0,0 +1,3 @@ +non_h_ints_mu +ao_tc_eff_map +bi_ortho_mos diff --git a/src/bi_ort_ints/README.rst b/src/bi_ort_ints/README.rst new file mode 100644 index 00000000..d496c4f7 --- /dev/null +++ b/src/bi_ort_ints/README.rst @@ -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 diff --git a/src/bi_ort_ints/bi_ort_ints.irp.f b/src/bi_ort_ints/bi_ort_ints.irp.f new file mode 100644 index 00000000..6884ff38 --- /dev/null +++ b/src/bi_ort_ints/bi_ort_ints.irp.f @@ -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 + ! + ! + ! 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) = +! 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 + + + + diff --git a/src/bi_ort_ints/one_e_bi_ort.irp.f b/src/bi_ort_ints/one_e_bi_ort.irp.f new file mode 100644 index 00000000..b7b87463 --- /dev/null +++ b/src/bi_ort_ints/one_e_bi_ort.irp.f @@ -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) = + 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 + diff --git a/src/bi_ort_ints/semi_num_ints_mo.irp.f b/src/bi_ort_ints/semi_num_ints_mo.irp.f new file mode 100644 index 00000000..6c4b44c0 --- /dev/null +++ b/src/bi_ort_ints/semi_num_ints_mo.irp.f @@ -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 + +! --- + diff --git a/src/bi_ort_ints/three_body_ijm.irp.f b/src/bi_ort_ints/three_body_ijm.irp.f new file mode 100644 index 00000000..4fd85756 --- /dev/null +++ b/src/bi_ort_ints/three_body_ijm.irp.f @@ -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) = +! +! 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) = +! +! 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) = +! +! 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) = +! +! 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) = +! +! 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) = +! +! 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) = +! +! 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 + diff --git a/src/bi_ort_ints/three_body_ijmk.irp.f b/src/bi_ort_ints/three_body_ijmk.irp.f new file mode 100644 index 00000000..40c34ddf --- /dev/null +++ b/src/bi_ort_ints/three_body_ijmk.irp.f @@ -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) = ::: 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) = ::: 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) = ::: 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) = ::: 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) = ::: 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) = ::: 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 diff --git a/src/bi_ort_ints/three_body_ijmkl.irp.f b/src/bi_ort_ints/three_body_ijmkl.irp.f new file mode 100644 index 00000000..72e93955 --- /dev/null +++ b/src/bi_ort_ints/three_body_ijmkl.irp.f @@ -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) = ::: 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) = ::: 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) = ::: 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) = ::: 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) = ::: 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) = ::: 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 diff --git a/src/bi_ort_ints/three_body_ints_bi_ort.irp.f b/src/bi_ort_ints/three_body_ints_bi_ort.irp.f new file mode 100644 index 00000000..1fe27ab1 --- /dev/null +++ b/src/bi_ort_ints/three_body_ints_bi_ort.irp.f @@ -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 +! 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 + diff --git a/src/bi_ort_ints/total_twoe_pot.irp.f b/src/bi_ort_ints/total_twoe_pot.irp.f new file mode 100644 index 00000000..b71a85d2 --- /dev/null +++ b/src/bi_ort_ints/total_twoe_pot.irp.f @@ -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) = 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 +! +! +! 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) = 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) = 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) = + 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 diff --git a/src/bi_ortho_aos/NEED b/src/bi_ortho_aos/NEED new file mode 100644 index 00000000..26404a02 --- /dev/null +++ b/src/bi_ortho_aos/NEED @@ -0,0 +1,2 @@ +basis +ao_basis diff --git a/src/bi_ortho_aos/README.rst b/src/bi_ortho_aos/README.rst new file mode 100644 index 00000000..f35bfc4f --- /dev/null +++ b/src/bi_ortho_aos/README.rst @@ -0,0 +1,5 @@ +============ +bi_ortho_aos +============ + +TODO diff --git a/src/bi_ortho_aos/aos_l.irp.f b/src/bi_ortho_aos/aos_l.irp.f new file mode 100644 index 00000000..7c89c82b --- /dev/null +++ b/src/bi_ortho_aos/aos_l.irp.f @@ -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 + diff --git a/src/bi_ortho_aos/aos_r.irp.f b/src/bi_ortho_aos/aos_r.irp.f new file mode 100644 index 00000000..8ca6d94e --- /dev/null +++ b/src/bi_ortho_aos/aos_r.irp.f @@ -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 + diff --git a/src/bi_ortho_mos/EZFIO.cfg b/src/bi_ortho_mos/EZFIO.cfg new file mode 100644 index 00000000..9b06a655 --- /dev/null +++ b/src/bi_ortho_mos/EZFIO.cfg @@ -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) diff --git a/src/bi_ortho_mos/NEED b/src/bi_ortho_mos/NEED new file mode 100644 index 00000000..2a2196e5 --- /dev/null +++ b/src/bi_ortho_mos/NEED @@ -0,0 +1,3 @@ +mo_basis +becke_numerical_grid +dft_utils_in_r diff --git a/src/bi_ortho_mos/bi_density.irp.f b/src/bi_ortho_mos/bi_density.irp.f new file mode 100644 index 00000000..947be870 --- /dev/null +++ b/src/bi_ortho_mos/bi_density.irp.f @@ -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) = 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) = 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) = 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 + +! --- + diff --git a/src/bi_ortho_mos/bi_ort_mos_in_r.irp.f b/src/bi_ortho_mos/bi_ort_mos_in_r.irp.f new file mode 100644 index 00000000..42130575 --- /dev/null +++ b/src/bi_ortho_mos/bi_ort_mos_in_r.irp.f @@ -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 + +! --- + diff --git a/src/bi_ortho_mos/grad_bi_ort_mos_in_r.irp.f b/src/bi_ortho_mos/grad_bi_ort_mos_in_r.irp.f new file mode 100644 index 00000000..5478fa5c --- /dev/null +++ b/src/bi_ortho_mos/grad_bi_ort_mos_in_r.irp.f @@ -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 diff --git a/src/bi_ortho_mos/mos_rl.irp.f b/src/bi_ortho_mos/mos_rl.irp.f new file mode 100644 index 00000000..b6e93c17 --- /dev/null +++ b/src/bi_ortho_mos/mos_rl.irp.f @@ -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 + +! --- + diff --git a/src/bi_ortho_mos/overlap.irp.f b/src/bi_ortho_mos/overlap.irp.f new file mode 100644 index 00000000..b974492f --- /dev/null +++ b/src/bi_ortho_mos/overlap.irp.f @@ -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) = + 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) = + 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 diff --git a/src/non_h_ints_mu/NEED b/src/non_h_ints_mu/NEED new file mode 100644 index 00000000..d09ab4a5 --- /dev/null +++ b/src/non_h_ints_mu/NEED @@ -0,0 +1,2 @@ +ao_tc_eff_map +bi_ortho_mos diff --git a/src/non_h_ints_mu/README.rst b/src/non_h_ints_mu/README.rst new file mode 100644 index 00000000..6a36bb98 --- /dev/null +++ b/src/non_h_ints_mu/README.rst @@ -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. + diff --git a/src/non_h_ints_mu/grad_tc_int.irp.f b/src/non_h_ints_mu/grad_tc_int.irp.f new file mode 100644 index 00000000..dd60e724 --- /dev/null +++ b/src/non_h_ints_mu/grad_tc_int.irp.f @@ -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 diff --git a/src/utils/integration.irp.f b/src/utils/integration.irp.f index fe4418ac..c2bff2e8 100644 --- a/src/utils/integration.irp.f +++ b/src/utils/integration.irp.f @@ -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 + +