mirror of
https://github.com/QuantumPackage/qp2.git
synced 2024-09-27 20:11:13 +02:00
Merge pull request #242 from QuantumPackage/dev-stable-tc-scf
Dev stable tc scf
This commit is contained in:
Emmanuel Giner
GitHub
commit
dd7f6ad0d3
2
external/qp2-dependencies
vendored
2
external/qp2-dependencies
vendored
@ -1 +1 @@
|
||||
Subproject commit 242151e03d1d6bf042387226431d82d35845686a
|
||||
Subproject commit f40bde0925808bbec0424b57bfcef1b26473a1c8
|
||||
5
src/ao_many_one_e_ints/NEED
Normal file
5
src/ao_many_one_e_ints/NEED
Normal file
@ -0,0 +1,5 @@
|
||||
ao_one_e_ints
|
||||
ao_two_e_ints
|
||||
becke_numerical_grid
|
||||
mo_one_e_ints
|
||||
dft_utils_in_r
|
||||
25
src/ao_many_one_e_ints/README.rst
Normal file
25
src/ao_many_one_e_ints/README.rst
Normal file
@ -0,0 +1,25 @@
|
||||
==================
|
||||
ao_many_one_e_ints
|
||||
==================
|
||||
|
||||
This module contains A LOT of one-electron integrals of the type
|
||||
A_ij( r ) = \int dr' phi_i(r') w(r,r') phi_j(r')
|
||||
where r is a point in real space.
|
||||
|
||||
+) ao_gaus_gauss.irp.f: w(r,r') is a exp(-(r-r')^2) , and can be multiplied by x/y/z
|
||||
+) ao_erf_gauss.irp.f : w(r,r') is a exp(-(r-r')^2) erf(mu * |r-r'|)/|r-r'| , and can be multiplied by x/y/z
|
||||
+) ao_erf_gauss_grad.irp.f: w(r,r') is a exp(-(r-r')^2) erf(mu * |r-r'|)/|r-r'| , and can be multiplied by x/y/z, but evaluated with also one gradient of an AO function.
|
||||
|
||||
Fit of a Slater function and corresponding integrals
|
||||
----------------------------------------------------
|
||||
The file fit_slat_gauss.irp.f contains many useful providers/routines to fit a Slater function with 20 gaussian.
|
||||
+) coef_fit_slat_gauss : coefficients of the gaussians to fit e^(-x)
|
||||
+) expo_fit_slat_gauss : exponents of the gaussians to fit e^(-x)
|
||||
|
||||
Integrals involving Slater functions : stg_gauss_int.irp.f
|
||||
|
||||
Taylor expansion of full correlation factor
|
||||
-------------------------------------------
|
||||
In taylor_exp.irp.f you might find interesting integrals of the type
|
||||
\int dr' exp( e^{-alpha |r-r|' - beta |r-r'|^2}) phi_i(r') phi_j(r')
|
||||
evaluated as a Taylor expansion of the exponential.
|
||||
1113
src/ao_many_one_e_ints/ao_erf_gauss.irp.f
Normal file
1113
src/ao_many_one_e_ints/ao_erf_gauss.irp.f
Normal file
File diff suppressed because it is too large
Load Diff
150
src/ao_many_one_e_ints/ao_erf_gauss_grad.irp.f
Normal file
150
src/ao_many_one_e_ints/ao_erf_gauss_grad.irp.f
Normal file
@ -0,0 +1,150 @@
|
||||
subroutine phi_j_erf_mu_r_dxyz_phi(i,j,mu_in, C_center, dxyz_ints)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! dxyz_ints(1/2/3) = int dr phi_i(r) [erf(mu |r - C|)/|r-C|] d/d(x/y/z) phi_i(r)
|
||||
END_DOC
|
||||
integer, intent(in) :: i,j
|
||||
double precision, intent(in) :: mu_in, C_center(3)
|
||||
double precision, intent(out):: dxyz_ints(3)
|
||||
integer :: num_A,power_A(3), num_b, power_B(3),power_B_tmp(3)
|
||||
double precision :: alpha, beta, A_center(3), B_center(3),contrib,NAI_pol_mult_erf,coef,thr
|
||||
integer :: n_pt_in,l,m,mm
|
||||
thr = 1.d-12
|
||||
dxyz_ints = 0.d0
|
||||
if(ao_overlap_abs(j,i).lt.thr)then
|
||||
return
|
||||
endif
|
||||
|
||||
n_pt_in = n_pt_max_integrals
|
||||
! j
|
||||
num_A = ao_nucl(j)
|
||||
power_A(1:3)= ao_power(j,1:3)
|
||||
A_center(1:3) = nucl_coord(num_A,1:3)
|
||||
! i
|
||||
num_B = ao_nucl(i)
|
||||
power_B(1:3)= ao_power(i,1:3)
|
||||
B_center(1:3) = nucl_coord(num_B,1:3)
|
||||
|
||||
do l=1,ao_prim_num(j)
|
||||
alpha = ao_expo_ordered_transp(l,j)
|
||||
do m=1,ao_prim_num(i)
|
||||
beta = ao_expo_ordered_transp(m,i)
|
||||
coef = ao_coef_normalized_ordered_transp(l,j) * ao_coef_normalized_ordered_transp(m,i)
|
||||
if(dabs(coef).lt.thr)cycle
|
||||
do mm = 1, 3
|
||||
! (d/dx phi_i ) * phi_j
|
||||
! d/dx * (x - B_x)^b_x exp(-beta * (x -B_x)^2)= [b_x * (x - B_x)^(b_x - 1) - 2 beta * (x - B_x)^(b_x + 1)] exp(-beta * (x -B_x)^2)
|
||||
!
|
||||
! first contribution :: b_x (x - B_x)^(b_x-1) :: integral with b_x=>b_x-1 multiplied by b_x
|
||||
power_B_tmp = power_B
|
||||
power_B_tmp(mm) += -1
|
||||
contrib = NAI_pol_mult_erf(A_center,B_center,power_A,power_B_tmp,alpha,beta,C_center,n_pt_in,mu_in)
|
||||
dxyz_ints(mm) += contrib * dble(power_B(mm)) * coef
|
||||
|
||||
! second contribution :: - 2 beta * (x - B_x)^(b_x + 1) :: integral with b_x=> b_x+1 multiplied by -2 * beta
|
||||
power_B_tmp = power_B
|
||||
power_B_tmp(mm) += 1
|
||||
contrib = NAI_pol_mult_erf(A_center,B_center,power_A,power_B_tmp,alpha,beta,C_center,n_pt_in,mu_in)
|
||||
dxyz_ints(mm) += contrib * (-2.d0 * beta ) * coef
|
||||
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
end
|
||||
|
||||
|
||||
|
||||
|
||||
subroutine phi_j_erf_mu_r_dxyz_phi_bis(i,j,mu_in, C_center, dxyz_ints)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! dxyz_ints(1/2/3) = int dr phi_j(r) [erf(mu |r - C|)/|r-C|] d/d(x/y/z) phi_i(r)
|
||||
END_DOC
|
||||
integer, intent(in) :: i,j
|
||||
double precision, intent(in) :: mu_in, C_center(3)
|
||||
double precision, intent(out):: dxyz_ints(3)
|
||||
integer :: num_A,power_A(3), num_b, power_B(3),power_B_tmp(3)
|
||||
double precision :: alpha, beta, A_center(3), B_center(3),contrib,NAI_pol_mult_erf
|
||||
double precision :: thr, coef
|
||||
integer :: n_pt_in,l,m,mm,kk
|
||||
thr = 1.d-12
|
||||
dxyz_ints = 0.d0
|
||||
if(ao_overlap_abs(j,i).lt.thr)then
|
||||
return
|
||||
endif
|
||||
|
||||
n_pt_in = n_pt_max_integrals
|
||||
! j == A
|
||||
num_A = ao_nucl(j)
|
||||
power_A(1:3)= ao_power(j,1:3)
|
||||
A_center(1:3) = nucl_coord(num_A,1:3)
|
||||
! i == B
|
||||
num_B = ao_nucl(i)
|
||||
power_B(1:3)= ao_power(i,1:3)
|
||||
B_center(1:3) = nucl_coord(num_B,1:3)
|
||||
|
||||
dxyz_ints = 0.d0
|
||||
do l=1,ao_prim_num(j)
|
||||
alpha = ao_expo_ordered_transp(l,j)
|
||||
do m=1,ao_prim_num(i)
|
||||
beta = ao_expo_ordered_transp(m,i)
|
||||
do kk = 1, 2 ! loop over the extra terms induced by the d/dx/y/z * AO(i)
|
||||
do mm = 1, 3
|
||||
power_B_tmp = power_B
|
||||
power_B_tmp(mm) = power_ord_grad_transp(kk,mm,i)
|
||||
coef = ao_coef_normalized_ordered_transp(l,j) * ao_coef_ord_grad_transp(kk,mm,m,i)
|
||||
if(dabs(coef).lt.thr)cycle
|
||||
contrib = NAI_pol_mult_erf(A_center,B_center,power_A,power_B_tmp,alpha,beta,C_center,n_pt_in,mu_in)
|
||||
dxyz_ints(mm) += contrib * coef
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
end
|
||||
|
||||
subroutine phi_j_erf_mu_r_xyz_dxyz_phi(i,j,mu_in, C_center, dxyz_ints)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! dxyz_ints(1/2/3) = int dr phi_j(r) x/y/z [erf(mu |r - C|)/|r-C|] d/d(x/y/z) phi_i(r)
|
||||
END_DOC
|
||||
integer, intent(in) :: i,j
|
||||
double precision, intent(in) :: mu_in, C_center(3)
|
||||
double precision, intent(out):: dxyz_ints(3)
|
||||
integer :: num_A,power_A(3), num_b, power_B(3),power_B_tmp(3)
|
||||
double precision :: alpha, beta, A_center(3), B_center(3),contrib,NAI_pol_mult_erf
|
||||
double precision :: thr, coef
|
||||
integer :: n_pt_in,l,m,mm,kk
|
||||
thr = 1.d-12
|
||||
dxyz_ints = 0.d0
|
||||
if(ao_overlap_abs(j,i).lt.thr)then
|
||||
return
|
||||
endif
|
||||
|
||||
n_pt_in = n_pt_max_integrals
|
||||
! j == A
|
||||
num_A = ao_nucl(j)
|
||||
power_A(1:3)= ao_power(j,1:3)
|
||||
A_center(1:3) = nucl_coord(num_A,1:3)
|
||||
! i == B
|
||||
num_B = ao_nucl(i)
|
||||
power_B(1:3)= ao_power(i,1:3)
|
||||
B_center(1:3) = nucl_coord(num_B,1:3)
|
||||
|
||||
dxyz_ints = 0.d0
|
||||
do l=1,ao_prim_num(j)
|
||||
alpha = ao_expo_ordered_transp(l,j)
|
||||
do m=1,ao_prim_num(i)
|
||||
beta = ao_expo_ordered_transp(m,i)
|
||||
do kk = 1, 4 ! loop over the extra terms induced by the x/y/z * d dx/y/z AO(i)
|
||||
do mm = 1, 3
|
||||
power_B_tmp = power_B
|
||||
power_B_tmp(mm) = power_ord_xyz_grad_transp(kk,mm,i)
|
||||
coef = ao_coef_normalized_ordered_transp(l,j) * ao_coef_ord_xyz_grad_transp(kk,mm,m,i)
|
||||
if(dabs(coef).lt.thr)cycle
|
||||
contrib = NAI_pol_mult_erf(A_center,B_center,power_A,power_B_tmp,alpha,beta,C_center,n_pt_in,mu_in)
|
||||
dxyz_ints(mm) += contrib * coef
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
end
|
||||
426
src/ao_many_one_e_ints/ao_gaus_gauss.irp.f
Normal file
426
src/ao_many_one_e_ints/ao_gaus_gauss.irp.f
Normal file
@ -0,0 +1,426 @@
|
||||
! ---
|
||||
|
||||
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
|
||||
|
||||
! ---
|
||||
|
||||
! TODO :: PUT CYCLES IN LOOPS
|
||||
double precision function overlap_gauss_r12_ao(D_center, delta, i, j)
|
||||
|
||||
BEGIN_DOC
|
||||
! \int dr AO_i(r) AO_j(r) e^{-delta |r-D_center|^2}
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: i, j
|
||||
double precision, intent(in) :: D_center(3), delta
|
||||
|
||||
integer :: power_A(3), power_B(3), l, k
|
||||
double precision :: A_center(3), B_center(3), alpha, beta, coef, coef1, analytical_j
|
||||
|
||||
double precision, external :: overlap_gauss_r12
|
||||
|
||||
overlap_gauss_r12_ao = 0.d0
|
||||
|
||||
if(ao_overlap_abs(j,i).lt.1.d-12) then
|
||||
return
|
||||
endif
|
||||
|
||||
power_A(1:3) = ao_power(i,1:3)
|
||||
power_B(1:3) = ao_power(j,1:3)
|
||||
|
||||
A_center(1:3) = nucl_coord(ao_nucl(i),1:3)
|
||||
B_center(1:3) = nucl_coord(ao_nucl(j),1:3)
|
||||
|
||||
do l = 1, ao_prim_num(i)
|
||||
alpha = ao_expo_ordered_transp (l,i)
|
||||
coef1 = ao_coef_normalized_ordered_transp(l,i)
|
||||
|
||||
do k = 1, ao_prim_num(j)
|
||||
beta = ao_expo_ordered_transp(k,j)
|
||||
coef = coef1 * ao_coef_normalized_ordered_transp(k,j)
|
||||
|
||||
if(dabs(coef) .lt. 1d-12) cycle
|
||||
|
||||
analytical_j = overlap_gauss_r12(D_center, delta, A_center, B_center, power_A, power_B, alpha, beta)
|
||||
|
||||
overlap_gauss_r12_ao += coef * analytical_j
|
||||
enddo
|
||||
enddo
|
||||
|
||||
end function overlap_gauss_r12_ao
|
||||
|
||||
! --
|
||||
|
||||
double precision function overlap_abs_gauss_r12_ao(D_center, delta, i, j)
|
||||
|
||||
BEGIN_DOC
|
||||
! \int dr AO_i(r) AO_j(r) e^{-delta |r-D_center|^2}
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: i, j
|
||||
double precision, intent(in) :: D_center(3), delta
|
||||
|
||||
integer :: power_A(3), power_B(3), l, k
|
||||
double precision :: A_center(3), B_center(3), alpha, beta, coef, coef1, analytical_j
|
||||
|
||||
double precision, external :: overlap_abs_gauss_r12
|
||||
|
||||
overlap_abs_gauss_r12_ao = 0.d0
|
||||
|
||||
if(ao_overlap_abs(j,i).lt.1.d-12) then
|
||||
return
|
||||
endif
|
||||
|
||||
power_A(1:3) = ao_power(i,1:3)
|
||||
power_B(1:3) = ao_power(j,1:3)
|
||||
|
||||
A_center(1:3) = nucl_coord(ao_nucl(i),1:3)
|
||||
B_center(1:3) = nucl_coord(ao_nucl(j),1:3)
|
||||
|
||||
do l = 1, ao_prim_num(i)
|
||||
alpha = ao_expo_ordered_transp (l,i)
|
||||
coef1 = ao_coef_normalized_ordered_transp(l,i)
|
||||
|
||||
do k = 1, ao_prim_num(j)
|
||||
beta = ao_expo_ordered_transp(k,j)
|
||||
coef = coef1 * ao_coef_normalized_ordered_transp(k,j)
|
||||
|
||||
if(dabs(coef) .lt. 1d-12) cycle
|
||||
|
||||
analytical_j = overlap_abs_gauss_r12(D_center, delta, A_center, B_center, power_A, power_B, alpha, beta)
|
||||
|
||||
overlap_abs_gauss_r12_ao += dabs(coef * analytical_j)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
end function overlap_gauss_r12_ao
|
||||
|
||||
! --
|
||||
|
||||
subroutine overlap_gauss_r12_ao_v(D_center, LD_D, delta, i, j, resv, LD_resv, n_points)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! \int dr AO_i(r) AO_j(r) e^{-delta |r-D_center|^2}
|
||||
!
|
||||
! n_points: nb of integrals <= min(LD_D, LD_resv)
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: i, j, LD_D, LD_resv, n_points
|
||||
double precision, intent(in) :: D_center(LD_D,3), delta
|
||||
double precision, intent(out) :: resv(LD_resv)
|
||||
|
||||
integer :: ipoint
|
||||
integer :: power_A(3), power_B(3), l, k
|
||||
double precision :: A_center(3), B_center(3), alpha, beta, coef, coef1
|
||||
double precision, allocatable :: analytical_j(:)
|
||||
|
||||
resv(:) = 0.d0
|
||||
if(ao_overlap_abs(j,i) .lt. 1.d-12) then
|
||||
return
|
||||
endif
|
||||
|
||||
power_A(1:3) = ao_power(i,1:3)
|
||||
power_B(1:3) = ao_power(j,1:3)
|
||||
|
||||
A_center(1:3) = nucl_coord(ao_nucl(i),1:3)
|
||||
B_center(1:3) = nucl_coord(ao_nucl(j),1:3)
|
||||
|
||||
allocate(analytical_j(n_points))
|
||||
|
||||
do l = 1, ao_prim_num(i)
|
||||
alpha = ao_expo_ordered_transp (l,i)
|
||||
coef1 = ao_coef_normalized_ordered_transp(l,i)
|
||||
|
||||
do k = 1, ao_prim_num(j)
|
||||
beta = ao_expo_ordered_transp(k,j)
|
||||
coef = coef1 * ao_coef_normalized_ordered_transp(k,j)
|
||||
|
||||
if(dabs(coef) .lt. 1d-12) cycle
|
||||
|
||||
call overlap_gauss_r12_v(D_center, LD_D, delta, A_center, B_center, power_A, power_B, alpha, beta, analytical_j, n_points, n_points)
|
||||
|
||||
do ipoint = 1, n_points
|
||||
resv(ipoint) = resv(ipoint) + coef * analytical_j(ipoint)
|
||||
enddo
|
||||
|
||||
enddo
|
||||
enddo
|
||||
|
||||
deallocate(analytical_j)
|
||||
|
||||
end subroutine overlap_gauss_r12_ao_v
|
||||
|
||||
! ---
|
||||
|
||||
double precision function overlap_gauss_r12_ao_with1s(B_center, beta, D_center, delta, i, j)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! \int dr AO_i(r) AO_j(r) e^{-beta |r-B_center^2|} e^{-delta |r-D_center|^2}
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: i, j
|
||||
double precision, intent(in) :: B_center(3), beta, D_center(3), delta
|
||||
|
||||
integer :: power_A1(3), power_A2(3), l, k
|
||||
double precision :: A1_center(3), A2_center(3), alpha1, alpha2, coef1, coef12, analytical_j
|
||||
double precision :: G_center(3), gama, fact_g, gama_inv
|
||||
|
||||
double precision, external :: overlap_gauss_r12, overlap_gauss_r12_ao
|
||||
|
||||
if(beta .lt. 1d-10) then
|
||||
overlap_gauss_r12_ao_with1s = overlap_gauss_r12_ao(D_center, delta, i, j)
|
||||
return
|
||||
endif
|
||||
|
||||
overlap_gauss_r12_ao_with1s = 0.d0
|
||||
|
||||
if(ao_overlap_abs(j,i) .lt. 1.d-12) then
|
||||
return
|
||||
endif
|
||||
|
||||
! e^{-beta |r-B_center^2|} e^{-delta |r-D_center|^2} = fact_g e^{-gama |r - G|^2}
|
||||
|
||||
gama = beta + delta
|
||||
gama_inv = 1.d0 / gama
|
||||
G_center(1) = (beta * B_center(1) + delta * D_center(1)) * gama_inv
|
||||
G_center(2) = (beta * B_center(2) + delta * D_center(2)) * gama_inv
|
||||
G_center(3) = (beta * B_center(3) + delta * D_center(3)) * gama_inv
|
||||
fact_g = beta * delta * gama_inv * ( (B_center(1) - D_center(1)) * (B_center(1) - D_center(1)) &
|
||||
+ (B_center(2) - D_center(2)) * (B_center(2) - D_center(2)) &
|
||||
+ (B_center(3) - D_center(3)) * (B_center(3) - D_center(3)) )
|
||||
if(fact_g .gt. 10d0) return
|
||||
fact_g = dexp(-fact_g)
|
||||
|
||||
! ---
|
||||
|
||||
power_A1(1:3) = ao_power(i,1:3)
|
||||
power_A2(1:3) = ao_power(j,1:3)
|
||||
|
||||
A1_center(1:3) = nucl_coord(ao_nucl(i),1:3)
|
||||
A2_center(1:3) = nucl_coord(ao_nucl(j),1:3)
|
||||
|
||||
do l = 1, ao_prim_num(i)
|
||||
alpha1 = ao_expo_ordered_transp (l,i)
|
||||
coef1 = fact_g * ao_coef_normalized_ordered_transp(l,i)
|
||||
if(dabs(coef1) .lt. 1d-12) cycle
|
||||
|
||||
do k = 1, ao_prim_num(j)
|
||||
alpha2 = ao_expo_ordered_transp (k,j)
|
||||
coef12 = coef1 * ao_coef_normalized_ordered_transp(k,j)
|
||||
if(dabs(coef12) .lt. 1d-12) cycle
|
||||
|
||||
analytical_j = overlap_gauss_r12(G_center, gama, A1_center, A2_center, power_A1, power_A2, alpha1, alpha2)
|
||||
|
||||
overlap_gauss_r12_ao_with1s += coef12 * analytical_j
|
||||
enddo
|
||||
enddo
|
||||
|
||||
end function overlap_gauss_r12_ao_with1s
|
||||
|
||||
! ---
|
||||
|
||||
subroutine overlap_gauss_r12_ao_with1s_v(B_center, beta, D_center, LD_D, delta, i, j, resv, LD_resv, n_points)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! \int dr AO_i(r) AO_j(r) e^{-beta |r-B_center^2|} e^{-delta |r-D_center|^2}
|
||||
! using an array of D_centers.
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: i, j, n_points, LD_D, LD_resv
|
||||
double precision, intent(in) :: B_center(3), beta, D_center(LD_D,3), delta
|
||||
double precision, intent(out) :: resv(LD_resv)
|
||||
|
||||
integer :: ipoint
|
||||
integer :: power_A1(3), power_A2(3), l, k
|
||||
double precision :: A1_center(3), A2_center(3), alpha1, alpha2, coef1
|
||||
double precision :: coef12, coef12f
|
||||
double precision :: gama, gama_inv
|
||||
double precision :: bg, dg, bdg
|
||||
double precision, allocatable :: fact_g(:), G_center(:,:), analytical_j(:)
|
||||
|
||||
if(ao_overlap_abs(j,i) .lt. 1.d-12) then
|
||||
return
|
||||
endif
|
||||
|
||||
ASSERT(beta .gt. 0.d0)
|
||||
|
||||
if(beta .lt. 1d-10) then
|
||||
call overlap_gauss_r12_ao_v(D_center, LD_D, delta, i, j, resv, LD_resv, n_points)
|
||||
return
|
||||
endif
|
||||
|
||||
resv(:) = 0.d0
|
||||
|
||||
! e^{-beta |r-B_center^2|} e^{-delta |r-D_center|^2} = fact_g e^{-gama |r - G|^2}
|
||||
|
||||
gama = beta + delta
|
||||
gama_inv = 1.d0 / gama
|
||||
|
||||
power_A1(1:3) = ao_power(i,1:3)
|
||||
power_A2(1:3) = ao_power(j,1:3)
|
||||
|
||||
A1_center(1:3) = nucl_coord(ao_nucl(i),1:3)
|
||||
A2_center(1:3) = nucl_coord(ao_nucl(j),1:3)
|
||||
|
||||
allocate(fact_g(n_points), G_center(n_points,3), analytical_j(n_points))
|
||||
|
||||
bg = beta * gama_inv
|
||||
dg = delta * gama_inv
|
||||
bdg = bg * delta
|
||||
|
||||
do ipoint = 1, n_points
|
||||
|
||||
G_center(ipoint,1) = bg * B_center(1) + dg * D_center(ipoint,1)
|
||||
G_center(ipoint,2) = bg * B_center(2) + dg * D_center(ipoint,2)
|
||||
G_center(ipoint,3) = bg * B_center(3) + dg * D_center(ipoint,3)
|
||||
fact_g(ipoint) = bdg * ( (B_center(1) - D_center(ipoint,1)) * (B_center(1) - D_center(ipoint,1)) &
|
||||
+ (B_center(2) - D_center(ipoint,2)) * (B_center(2) - D_center(ipoint,2)) &
|
||||
+ (B_center(3) - D_center(ipoint,3)) * (B_center(3) - D_center(ipoint,3)) )
|
||||
|
||||
if(fact_g(ipoint) < 10d0) then
|
||||
fact_g(ipoint) = dexp(-fact_g(ipoint))
|
||||
else
|
||||
fact_g(ipoint) = 0.d0
|
||||
endif
|
||||
|
||||
enddo
|
||||
|
||||
do l = 1, ao_prim_num(i)
|
||||
alpha1 = ao_expo_ordered_transp (l,i)
|
||||
coef1 = ao_coef_normalized_ordered_transp(l,i)
|
||||
|
||||
do k = 1, ao_prim_num(j)
|
||||
alpha2 = ao_expo_ordered_transp (k,j)
|
||||
coef12 = coef1 * ao_coef_normalized_ordered_transp(k,j)
|
||||
if(dabs(coef12) .lt. 1d-12) cycle
|
||||
|
||||
call overlap_gauss_r12_v(G_center, n_points, gama, A1_center, A2_center, power_A1, power_A2, alpha1, alpha2, analytical_j, n_points, n_points)
|
||||
|
||||
do ipoint = 1, n_points
|
||||
coef12f = coef12 * fact_g(ipoint)
|
||||
resv(ipoint) += coef12f * analytical_j(ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
deallocate(fact_g, G_center, analytical_j)
|
||||
|
||||
end subroutine overlap_gauss_r12_ao_with1s_v
|
||||
|
||||
! ---
|
||||
|
||||
94
src/ao_many_one_e_ints/fit_slat_gauss.irp.f
Normal file
94
src/ao_many_one_e_ints/fit_slat_gauss.irp.f
Normal file
@ -0,0 +1,94 @@
|
||||
BEGIN_PROVIDER [integer, n_max_fit_slat]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! number of gaussian to fit exp(-x)
|
||||
!
|
||||
! I took 20 gaussians from the program bassto.f
|
||||
END_DOC
|
||||
n_max_fit_slat = 20
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [double precision, coef_fit_slat_gauss, (n_max_fit_slat)]
|
||||
&BEGIN_PROVIDER [double precision, expo_fit_slat_gauss, (n_max_fit_slat)]
|
||||
implicit none
|
||||
include 'constants.include.F'
|
||||
BEGIN_DOC
|
||||
! fit the exp(-x) as
|
||||
!
|
||||
! \sum_{i = 1, n_max_fit_slat} coef_fit_slat_gauss(i) * exp(-expo_fit_slat_gauss(i) * x**2)
|
||||
!
|
||||
! The coefficient are taken from the program bassto.f
|
||||
END_DOC
|
||||
|
||||
|
||||
expo_fit_slat_gauss(01)=30573.77073000000
|
||||
coef_fit_slat_gauss(01)=0.00338925525
|
||||
expo_fit_slat_gauss(02)=5608.45238100000
|
||||
coef_fit_slat_gauss(02)=0.00536433869
|
||||
expo_fit_slat_gauss(03)=1570.95673400000
|
||||
coef_fit_slat_gauss(03)=0.00818702846
|
||||
expo_fit_slat_gauss(04)=541.39785110000
|
||||
coef_fit_slat_gauss(04)=0.01202047655
|
||||
expo_fit_slat_gauss(05)=212.43469630000
|
||||
coef_fit_slat_gauss(05)=0.01711289568
|
||||
expo_fit_slat_gauss(06)=91.31444574000
|
||||
coef_fit_slat_gauss(06)=0.02376001022
|
||||
expo_fit_slat_gauss(07)=42.04087246000
|
||||
coef_fit_slat_gauss(07)=0.03229121736
|
||||
expo_fit_slat_gauss(08)=20.43200443000
|
||||
coef_fit_slat_gauss(08)=0.04303646818
|
||||
expo_fit_slat_gauss(09)=10.37775161000
|
||||
coef_fit_slat_gauss(09)=0.05624657578
|
||||
expo_fit_slat_gauss(10)=5.46880754500
|
||||
coef_fit_slat_gauss(10)=0.07192311571
|
||||
expo_fit_slat_gauss(11)=2.97373529200
|
||||
coef_fit_slat_gauss(11)=0.08949389001
|
||||
expo_fit_slat_gauss(12)=1.66144190200
|
||||
coef_fit_slat_gauss(12)=0.10727599240
|
||||
expo_fit_slat_gauss(13)=0.95052560820
|
||||
coef_fit_slat_gauss(13)=0.12178961750
|
||||
expo_fit_slat_gauss(14)=0.55528683970
|
||||
coef_fit_slat_gauss(14)=0.12740141870
|
||||
expo_fit_slat_gauss(15)=0.33043360020
|
||||
coef_fit_slat_gauss(15)=0.11759168160
|
||||
expo_fit_slat_gauss(16)=0.19982303230
|
||||
coef_fit_slat_gauss(16)=0.08953504394
|
||||
expo_fit_slat_gauss(17)=0.12246840760
|
||||
coef_fit_slat_gauss(17)=0.05066721317
|
||||
expo_fit_slat_gauss(18)=0.07575825322
|
||||
coef_fit_slat_gauss(18)=0.01806363869
|
||||
expo_fit_slat_gauss(19)=0.04690146243
|
||||
coef_fit_slat_gauss(19)=0.00305632563
|
||||
expo_fit_slat_gauss(20)=0.02834749861
|
||||
coef_fit_slat_gauss(20)=0.00013317513
|
||||
|
||||
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
double precision function slater_fit_gam(x,gam)
|
||||
implicit none
|
||||
double precision, intent(in) :: x,gam
|
||||
BEGIN_DOC
|
||||
! fit of the function exp(-gam * x) with gaussian functions
|
||||
END_DOC
|
||||
integer :: i
|
||||
slater_fit_gam = 0.d0
|
||||
do i = 1, n_max_fit_slat
|
||||
slater_fit_gam += coef_fit_slat_gauss(i) * dexp(-expo_fit_slat_gauss(i) * gam * gam * x * x)
|
||||
enddo
|
||||
end
|
||||
|
||||
subroutine expo_fit_slater_gam(gam,expos)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! returns the array of the exponents of the gaussians to fit exp(-gam*x)
|
||||
END_DOC
|
||||
double precision, intent(in) :: gam
|
||||
double precision, intent(out) :: expos(n_max_fit_slat)
|
||||
integer :: i
|
||||
do i = 1, n_max_fit_slat
|
||||
expos(i) = expo_fit_slat_gauss(i) * gam * gam
|
||||
enddo
|
||||
end
|
||||
|
||||
517
src/ao_many_one_e_ints/grad2_jmu_manu.irp.f
Normal file
517
src/ao_many_one_e_ints/grad2_jmu_manu.irp.f
Normal file
@ -0,0 +1,517 @@
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2_test, (ao_num, ao_num, n_points_final_grid)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! -\frac{1}{4} x int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 [1 - erf(mu r12)]^2
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint, i_1s, i_fit
|
||||
double precision :: r(3), expo_fit, coef_fit
|
||||
double precision :: coef, beta, B_center(3)
|
||||
double precision :: tmp
|
||||
double precision :: wall0, wall1
|
||||
double precision :: int_gauss, dsqpi_3_2, int_j1b
|
||||
double precision :: factor_ij_1s, beta_ij, center_ij_1s(3), sq_pi_3_2
|
||||
double precision, allocatable :: int_fit_v(:)
|
||||
double precision, external :: overlap_gauss_r12_ao_with1s
|
||||
|
||||
print*, ' providing int2_grad1u2_grad2u2_j1b2_test ...'
|
||||
|
||||
sq_pi_3_2 = (dacos(-1.d0))**(1.5d0)
|
||||
|
||||
provide mu_erf final_grid_points_transp j1b_pen List_comb_thr_b3_coef
|
||||
call wall_time(wall0)
|
||||
|
||||
int2_grad1u2_grad2u2_j1b2_test(:,:,:) = 0.d0
|
||||
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, &
|
||||
!$OMP coef_fit, expo_fit, int_fit_v, tmp,int_gauss,int_j1b,factor_ij_1s,beta_ij,center_ij_1s) &
|
||||
!$OMP SHARED (n_points_final_grid, ao_num, final_grid_points,List_comb_thr_b3_size, &
|
||||
!$OMP final_grid_points_transp, ng_fit_jast, &
|
||||
!$OMP expo_gauss_1_erf_x_2, coef_gauss_1_erf_x_2, &
|
||||
!$OMP List_comb_thr_b3_coef, List_comb_thr_b3_expo, &
|
||||
!$OMP List_comb_thr_b3_cent, int2_grad1u2_grad2u2_j1b2_test, ao_abs_comb_b3_j1b, &
|
||||
!$OMP ao_overlap_abs,sq_pi_3_2)
|
||||
!$OMP DO SCHEDULE(dynamic)
|
||||
do ipoint = 1, n_points_final_grid
|
||||
r(1) = final_grid_points(1,ipoint)
|
||||
r(2) = final_grid_points(2,ipoint)
|
||||
r(3) = final_grid_points(3,ipoint)
|
||||
do i = 1, ao_num
|
||||
do j = i, ao_num
|
||||
if(ao_overlap_abs(j,i) .lt. 1.d-12) then
|
||||
cycle
|
||||
endif
|
||||
|
||||
do i_1s = 1, List_comb_thr_b3_size(j,i)
|
||||
|
||||
coef = List_comb_thr_b3_coef (i_1s,j,i)
|
||||
beta = List_comb_thr_b3_expo (i_1s,j,i)
|
||||
int_j1b = ao_abs_comb_b3_j1b(i_1s,j,i)
|
||||
B_center(1) = List_comb_thr_b3_cent(1,i_1s,j,i)
|
||||
B_center(2) = List_comb_thr_b3_cent(2,i_1s,j,i)
|
||||
B_center(3) = List_comb_thr_b3_cent(3,i_1s,j,i)
|
||||
|
||||
do i_fit = 1, ng_fit_jast
|
||||
|
||||
expo_fit = expo_gauss_1_erf_x_2(i_fit)
|
||||
!DIR$ FORCEINLINE
|
||||
call gaussian_product(expo_fit,r,beta,B_center,factor_ij_1s,beta_ij,center_ij_1s)
|
||||
coef_fit = -0.25d0 * coef_gauss_1_erf_x_2(i_fit) * coef
|
||||
! if(dabs(coef_fit*factor_ij_1s*int_j1b).lt.1.d-10)cycle ! old version
|
||||
if(dabs(coef_fit*factor_ij_1s*int_j1b*sq_pi_3_2*(beta_ij)**(-1.5d0)).lt.1.d-10)cycle
|
||||
|
||||
! call overlap_gauss_r12_ao_with1s_v(B_center, beta, final_grid_points_transp, &
|
||||
! expo_fit, i, j, int_fit_v, n_points_final_grid)
|
||||
int_gauss = overlap_gauss_r12_ao_with1s(B_center, beta, r, expo_fit, i, j)
|
||||
|
||||
int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint) += coef_fit * int_gauss
|
||||
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 1, ao_num
|
||||
do j = 1, i-1
|
||||
int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint) = int2_grad1u2_grad2u2_j1b2_test(i,j,ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print*, ' wall time for int2_grad1u2_grad2u2_j1b2_test', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2_test_v, (ao_num, ao_num, n_points_final_grid)]
|
||||
!
|
||||
! BEGIN_DOC
|
||||
! !
|
||||
! ! -\frac{1}{4} x int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 [1 - erf(mu r12)]^2
|
||||
! !
|
||||
! END_DOC
|
||||
!
|
||||
implicit none
|
||||
integer :: i, j, ipoint, i_1s, i_fit
|
||||
double precision :: r(3), expo_fit, coef_fit
|
||||
double precision :: coef, beta, B_center(3)
|
||||
double precision :: tmp
|
||||
double precision :: wall0, wall1
|
||||
|
||||
double precision, allocatable :: int_fit_v(:),big_array(:,:,:)
|
||||
double precision, external :: overlap_gauss_r12_ao_with1s
|
||||
|
||||
print*, ' providing int2_grad1u2_grad2u2_j1b2_test_v ...'
|
||||
|
||||
provide mu_erf final_grid_points_transp j1b_pen
|
||||
call wall_time(wall0)
|
||||
|
||||
double precision :: int_j1b
|
||||
big_array(:,:,:) = 0.d0
|
||||
allocate(big_array(n_points_final_grid,ao_num, ao_num))
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center,&
|
||||
!$OMP coef_fit, expo_fit, int_fit_v, tmp,int_j1b) &
|
||||
!$OMP SHARED (n_points_final_grid, ao_num, List_comb_thr_b3_size,&
|
||||
!$OMP final_grid_points_transp, ng_fit_jast, &
|
||||
!$OMP expo_gauss_1_erf_x_2, coef_gauss_1_erf_x_2, &
|
||||
!$OMP List_comb_thr_b3_coef, List_comb_thr_b3_expo, &
|
||||
!$OMP List_comb_thr_b3_cent, big_array,&
|
||||
!$OMP ao_abs_comb_b3_j1b,ao_overlap_abs)
|
||||
!
|
||||
allocate(int_fit_v(n_points_final_grid))
|
||||
!$OMP DO SCHEDULE(dynamic)
|
||||
do i = 1, ao_num
|
||||
do j = i, ao_num
|
||||
|
||||
if(ao_overlap_abs(j,i) .lt. 1.d-12) then
|
||||
cycle
|
||||
endif
|
||||
|
||||
do i_1s = 1, List_comb_thr_b3_size(j,i)
|
||||
|
||||
coef = List_comb_thr_b3_coef (i_1s,j,i)
|
||||
beta = List_comb_thr_b3_expo (i_1s,j,i)
|
||||
int_j1b = ao_abs_comb_b3_j1b(i_1s,j,i)
|
||||
! if(dabs(coef)*dabs(int_j1b).lt.1.d-15)cycle
|
||||
B_center(1) = List_comb_thr_b3_cent(1,i_1s,j,i)
|
||||
B_center(2) = List_comb_thr_b3_cent(2,i_1s,j,i)
|
||||
B_center(3) = List_comb_thr_b3_cent(3,i_1s,j,i)
|
||||
|
||||
do i_fit = 1, ng_fit_jast
|
||||
|
||||
expo_fit = expo_gauss_1_erf_x_2(i_fit)
|
||||
coef_fit = -0.25d0 * coef_gauss_1_erf_x_2(i_fit) * coef
|
||||
|
||||
call overlap_gauss_r12_ao_with1s_v(B_center, beta, final_grid_points_transp, size(final_grid_points_transp,1),&
|
||||
expo_fit, i, j, int_fit_v, size(int_fit_v,1),n_points_final_grid)
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
big_array(ipoint,j,i) += coef_fit * int_fit_v(ipoint)
|
||||
enddo
|
||||
|
||||
enddo
|
||||
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
deallocate(int_fit_v)
|
||||
!$OMP END PARALLEL
|
||||
do i = 1, ao_num
|
||||
do j = i, ao_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
int2_grad1u2_grad2u2_j1b2_test_v(j,i,ipoint) = big_array(ipoint,j,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 2, ao_num
|
||||
do j = 1, i-1
|
||||
int2_grad1u2_grad2u2_j1b2_test_v(j,i,ipoint) = big_array(ipoint,i,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print*, ' wall time for int2_grad1u2_grad2u2_j1b2_test_v', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, int2_u2_j1b2_test, (ao_num, ao_num, n_points_final_grid)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 [u_12^mu]^2
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint, i_1s, i_fit
|
||||
double precision :: r(3), int_fit, expo_fit, coef_fit
|
||||
double precision :: coef, beta, B_center(3), tmp
|
||||
double precision :: wall0, wall1,int_j1b
|
||||
|
||||
double precision, external :: overlap_gauss_r12_ao
|
||||
double precision, external :: overlap_gauss_r12_ao_with1s
|
||||
double precision :: factor_ij_1s,beta_ij,center_ij_1s(3),sq_pi_3_2
|
||||
|
||||
print*, ' providing int2_u2_j1b2_test ...'
|
||||
|
||||
sq_pi_3_2 = (dacos(-1.d0))**(1.5d0)
|
||||
|
||||
provide mu_erf final_grid_points j1b_pen
|
||||
call wall_time(wall0)
|
||||
|
||||
int2_u2_j1b2_test = 0.d0
|
||||
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, &
|
||||
!$OMP coef_fit, expo_fit, int_fit, tmp, int_j1b,factor_ij_1s,beta_ij,center_ij_1s) &
|
||||
!$OMP SHARED (n_points_final_grid, ao_num, List_comb_thr_b3_size, &
|
||||
!$OMP final_grid_points, ng_fit_jast, &
|
||||
!$OMP expo_gauss_j_mu_x_2, coef_gauss_j_mu_x_2, &
|
||||
!$OMP List_comb_thr_b3_coef, List_comb_thr_b3_expo,sq_pi_3_2, &
|
||||
!$OMP List_comb_thr_b3_cent, int2_u2_j1b2_test,ao_abs_comb_b3_j1b)
|
||||
!$OMP DO
|
||||
do ipoint = 1, n_points_final_grid
|
||||
r(1) = final_grid_points(1,ipoint)
|
||||
r(2) = final_grid_points(2,ipoint)
|
||||
r(3) = final_grid_points(3,ipoint)
|
||||
|
||||
do i = 1, ao_num
|
||||
do j = i, ao_num
|
||||
|
||||
|
||||
tmp = 0.d0
|
||||
do i_1s = 1, List_comb_thr_b3_size(j,i)
|
||||
|
||||
coef = List_comb_thr_b3_coef (i_1s,j,i)
|
||||
beta = List_comb_thr_b3_expo (i_1s,j,i)
|
||||
int_j1b = ao_abs_comb_b3_j1b(i_1s,j,i)
|
||||
if(dabs(coef)*dabs(int_j1b).lt.1.d-10)cycle
|
||||
B_center(1) = List_comb_thr_b3_cent(1,i_1s,j,i)
|
||||
B_center(2) = List_comb_thr_b3_cent(2,i_1s,j,i)
|
||||
B_center(3) = List_comb_thr_b3_cent(3,i_1s,j,i)
|
||||
|
||||
do i_fit = 1, ng_fit_jast
|
||||
|
||||
expo_fit = expo_gauss_j_mu_x_2(i_fit)
|
||||
coef_fit = coef_gauss_j_mu_x_2(i_fit)
|
||||
!DIR$ FORCEINLINE
|
||||
call gaussian_product(expo_fit,r,beta,B_center,factor_ij_1s,beta_ij,center_ij_1s)
|
||||
! if(dabs(coef_fit*coef*factor_ij_1s*int_j1b).lt.1.d-10)cycle ! old version
|
||||
if(dabs(coef_fit*coef*factor_ij_1s*int_j1b*sq_pi_3_2*(beta_ij)**(-1.5d0)).lt.1.d-10)cycle
|
||||
|
||||
! ---
|
||||
|
||||
int_fit = overlap_gauss_r12_ao_with1s(B_center, beta, r, expo_fit, i, j)
|
||||
|
||||
tmp += coef * coef_fit * int_fit
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
enddo
|
||||
|
||||
int2_u2_j1b2_test(j,i,ipoint) = tmp
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 2, ao_num
|
||||
do j = 1, i-1
|
||||
int2_u2_j1b2_test(j,i,ipoint) = int2_u2_j1b2_test(i,j,ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print*, ' wall time for int2_u2_j1b2_test', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2_test, (ao_num, ao_num, n_points_final_grid, 3)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 u_12^mu [\grad_1 u_12^mu] r2
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint, i_1s, i_fit
|
||||
double precision :: r(3), int_fit(3), expo_fit, coef_fit
|
||||
double precision :: coef, beta, B_center(3), dist
|
||||
double precision :: alpha_1s, alpha_1s_inv, centr_1s(3), expo_coef_1s, coef_tmp
|
||||
double precision :: tmp_x, tmp_y, tmp_z, int_j1b
|
||||
double precision :: wall0, wall1, sq_pi_3_2,sq_alpha
|
||||
|
||||
print*, ' providing int2_u_grad1u_x_j1b2_test ...'
|
||||
|
||||
sq_pi_3_2 = dacos(-1.D0)**(1.d0)
|
||||
provide mu_erf final_grid_points j1b_pen
|
||||
call wall_time(wall0)
|
||||
|
||||
int2_u_grad1u_x_j1b2_test = 0.d0
|
||||
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, &
|
||||
!$OMP coef_fit, expo_fit, int_fit, alpha_1s, dist, &
|
||||
!$OMP alpha_1s_inv, centr_1s, expo_coef_1s, coef_tmp, &
|
||||
!$OMP tmp_x, tmp_y, tmp_z,int_j1b,sq_alpha) &
|
||||
!$OMP SHARED (n_points_final_grid, ao_num, List_comb_thr_b3_size, &
|
||||
!$OMP final_grid_points, ng_fit_jast, &
|
||||
!$OMP expo_gauss_j_mu_1_erf, coef_gauss_j_mu_1_erf, &
|
||||
!$OMP List_comb_thr_b3_coef, List_comb_thr_b3_expo, &
|
||||
!$OMP List_comb_thr_b3_cent, int2_u_grad1u_x_j1b2_test,ao_abs_comb_b3_j1b,sq_pi_3_2)
|
||||
!$OMP DO
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
r(1) = final_grid_points(1,ipoint)
|
||||
r(2) = final_grid_points(2,ipoint)
|
||||
r(3) = final_grid_points(3,ipoint)
|
||||
|
||||
do i = 1, ao_num
|
||||
do j = i, ao_num
|
||||
|
||||
tmp_x = 0.d0
|
||||
tmp_y = 0.d0
|
||||
tmp_z = 0.d0
|
||||
do i_1s = 1, List_comb_thr_b3_size(j,i)
|
||||
|
||||
coef = List_comb_thr_b3_coef (i_1s,j,i)
|
||||
beta = List_comb_thr_b3_expo (i_1s,j,i)
|
||||
int_j1b = ao_abs_comb_b3_j1b(i_1s,j,i)
|
||||
if(dabs(coef)*dabs(int_j1b).lt.1.d-10)cycle
|
||||
B_center(1) = List_comb_thr_b3_cent(1,i_1s,j,i)
|
||||
B_center(2) = List_comb_thr_b3_cent(2,i_1s,j,i)
|
||||
B_center(3) = List_comb_thr_b3_cent(3,i_1s,j,i)
|
||||
do i_fit = 1, ng_fit_jast
|
||||
|
||||
expo_fit = expo_gauss_j_mu_1_erf(i_fit)
|
||||
coef_fit = coef_gauss_j_mu_1_erf(i_fit)
|
||||
|
||||
dist = (B_center(1) - r(1)) * (B_center(1) - r(1)) &
|
||||
+ (B_center(2) - r(2)) * (B_center(2) - r(2)) &
|
||||
+ (B_center(3) - r(3)) * (B_center(3) - r(3))
|
||||
|
||||
alpha_1s = beta + expo_fit
|
||||
alpha_1s_inv = 1.d0 / alpha_1s
|
||||
|
||||
centr_1s(1) = alpha_1s_inv * (beta * B_center(1) + expo_fit * r(1))
|
||||
centr_1s(2) = alpha_1s_inv * (beta * B_center(2) + expo_fit * r(2))
|
||||
centr_1s(3) = alpha_1s_inv * (beta * B_center(3) + expo_fit * r(3))
|
||||
|
||||
expo_coef_1s = beta * expo_fit * alpha_1s_inv * dist
|
||||
coef_tmp = coef * coef_fit * dexp(-expo_coef_1s)
|
||||
sq_alpha = alpha_1s_inv * dsqrt(alpha_1s_inv)
|
||||
! if(dabs(coef_tmp*int_j1b) .lt. 1d-10) cycle ! old version
|
||||
if(dabs(coef_tmp*int_j1b*sq_pi_3_2*sq_alpha) .lt. 1d-10) cycle
|
||||
|
||||
call NAI_pol_x_mult_erf_ao_with1s(i, j, alpha_1s, centr_1s, 1.d+9, r, int_fit)
|
||||
|
||||
tmp_x += coef_tmp * int_fit(1)
|
||||
tmp_y += coef_tmp * int_fit(2)
|
||||
tmp_z += coef_tmp * int_fit(3)
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
enddo
|
||||
|
||||
int2_u_grad1u_x_j1b2_test(j,i,ipoint,1) = tmp_x
|
||||
int2_u_grad1u_x_j1b2_test(j,i,ipoint,2) = tmp_y
|
||||
int2_u_grad1u_x_j1b2_test(j,i,ipoint,3) = tmp_z
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 2, ao_num
|
||||
do j = 1, i-1
|
||||
int2_u_grad1u_x_j1b2_test(j,i,ipoint,1) = int2_u_grad1u_x_j1b2_test(i,j,ipoint,1)
|
||||
int2_u_grad1u_x_j1b2_test(j,i,ipoint,2) = int2_u_grad1u_x_j1b2_test(i,j,ipoint,2)
|
||||
int2_u_grad1u_x_j1b2_test(j,i,ipoint,3) = int2_u_grad1u_x_j1b2_test(i,j,ipoint,3)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print*, ' wall time for int2_u_grad1u_x_j1b2_test', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ double precision, int2_u_grad1u_j1b2_test, (ao_num, ao_num, n_points_final_grid)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 u_12^mu [\grad_1 u_12^mu]
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint, i_1s, i_fit
|
||||
double precision :: r(3), int_fit, expo_fit, coef_fit, coef_tmp
|
||||
double precision :: coef, beta, B_center(3), dist
|
||||
double precision :: alpha_1s, alpha_1s_inv, centr_1s(3), expo_coef_1s, tmp
|
||||
double precision :: wall0, wall1
|
||||
double precision, external :: NAI_pol_mult_erf_ao_with1s
|
||||
double precision :: j12_mu_r12,int_j1b
|
||||
double precision :: sigma_ij,dist_ij_ipoint,dsqpi_3_2
|
||||
double precision :: beta_ij,center_ij_1s(3),factor_ij_1s
|
||||
|
||||
print*, ' providing int2_u_grad1u_j1b2_test ...'
|
||||
|
||||
dsqpi_3_2 = (dacos(-1.d0))**(1.5d0)
|
||||
|
||||
provide mu_erf final_grid_points j1b_pen ao_overlap_abs List_comb_thr_b3_cent
|
||||
call wall_time(wall0)
|
||||
|
||||
|
||||
int2_u_grad1u_j1b2_test = 0.d0
|
||||
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, &
|
||||
!$OMP coef_fit, expo_fit, int_fit, tmp, alpha_1s, dist, &
|
||||
!$OMP beta_ij,center_ij_1s,factor_ij_1s, &
|
||||
!$OMP int_j1b,alpha_1s_inv, centr_1s, expo_coef_1s, coef_tmp) &
|
||||
!$OMP SHARED (n_points_final_grid, ao_num, List_comb_thr_b3_size, &
|
||||
!$OMP final_grid_points, ng_fit_jast, &
|
||||
!$OMP expo_gauss_j_mu_1_erf, coef_gauss_j_mu_1_erf, &
|
||||
!$OMP ao_prod_dist_grid, ao_prod_sigma, ao_overlap_abs_grid,ao_prod_center,dsqpi_3_2, &
|
||||
!$OMP List_comb_thr_b3_coef, List_comb_thr_b3_expo, ao_abs_comb_b3_j1b, &
|
||||
!$OMP List_comb_thr_b3_cent, int2_u_grad1u_j1b2_test)
|
||||
!$OMP DO
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 1, ao_num
|
||||
do j = i, ao_num
|
||||
if(dabs(ao_overlap_abs_grid(j,i)).lt.1.d-10)cycle
|
||||
r(1) = final_grid_points(1,ipoint)
|
||||
r(2) = final_grid_points(2,ipoint)
|
||||
r(3) = final_grid_points(3,ipoint)
|
||||
|
||||
tmp = 0.d0
|
||||
do i_1s = 1, List_comb_thr_b3_size(j,i)
|
||||
|
||||
coef = List_comb_thr_b3_coef (i_1s,j,i)
|
||||
beta = List_comb_thr_b3_expo (i_1s,j,i)
|
||||
int_j1b = ao_abs_comb_b3_j1b(i_1s,j,i)
|
||||
if(dabs(coef)*dabs(int_j1b).lt.1.d-10)cycle
|
||||
B_center(1) = List_comb_thr_b3_cent(1,i_1s,j,i)
|
||||
B_center(2) = List_comb_thr_b3_cent(2,i_1s,j,i)
|
||||
B_center(3) = List_comb_thr_b3_cent(3,i_1s,j,i)
|
||||
dist = (B_center(1) - r(1)) * (B_center(1) - r(1)) &
|
||||
+ (B_center(2) - r(2)) * (B_center(2) - r(2)) &
|
||||
+ (B_center(3) - r(3)) * (B_center(3) - r(3))
|
||||
|
||||
do i_fit = 1, ng_fit_jast
|
||||
|
||||
expo_fit = expo_gauss_j_mu_1_erf(i_fit)
|
||||
call gaussian_product(expo_fit,r,beta,B_center,factor_ij_1s,beta_ij,center_ij_1s)
|
||||
if(factor_ij_1s*dabs(coef*int_j1b)*dsqpi_3_2*beta_ij**(-1.5d0).lt.1.d-15)cycle
|
||||
coef_fit = coef_gauss_j_mu_1_erf(i_fit)
|
||||
|
||||
alpha_1s = beta + expo_fit
|
||||
alpha_1s_inv = 1.d0 / alpha_1s
|
||||
centr_1s(1) = alpha_1s_inv * (beta * B_center(1) + expo_fit * r(1))
|
||||
centr_1s(2) = alpha_1s_inv * (beta * B_center(2) + expo_fit * r(2))
|
||||
centr_1s(3) = alpha_1s_inv * (beta * B_center(3) + expo_fit * r(3))
|
||||
|
||||
expo_coef_1s = beta * expo_fit * alpha_1s_inv * dist
|
||||
if(expo_coef_1s .gt. 20.d0) cycle
|
||||
coef_tmp = coef * coef_fit * dexp(-expo_coef_1s)
|
||||
if(dabs(coef_tmp) .lt. 1d-08) cycle
|
||||
|
||||
int_fit = NAI_pol_mult_erf_ao_with1s(i, j, alpha_1s, centr_1s, 1.d+9, r)
|
||||
|
||||
tmp += coef_tmp * int_fit
|
||||
enddo
|
||||
enddo
|
||||
|
||||
int2_u_grad1u_j1b2_test(j,i,ipoint) = tmp
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 2, ao_num
|
||||
do j = 1, i-1
|
||||
int2_u_grad1u_j1b2_test(j,i,ipoint) = int2_u_grad1u_j1b2_test(i,j,ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print*, ' wall time for int2_u_grad1u_j1b2_test', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
420
src/ao_many_one_e_ints/grad2_jmu_modif.irp.f
Normal file
420
src/ao_many_one_e_ints/grad2_jmu_modif.irp.f
Normal file
@ -0,0 +1,420 @@
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2, (ao_num, ao_num, n_points_final_grid)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! -\frac{1}{4} x int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 [1 - erf(mu r12)]^2
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint, i_1s, i_fit
|
||||
double precision :: r(3), int_fit, expo_fit, coef_fit
|
||||
double precision :: coef, beta, B_center(3)
|
||||
double precision :: tmp
|
||||
double precision :: wall0, wall1
|
||||
|
||||
double precision, external :: overlap_gauss_r12_ao
|
||||
double precision, external :: overlap_gauss_r12_ao_with1s
|
||||
|
||||
print*, ' providing int2_grad1u2_grad2u2_j1b2 ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
provide mu_erf final_grid_points j1b_pen
|
||||
|
||||
int2_grad1u2_grad2u2_j1b2 = 0.d0
|
||||
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, &
|
||||
!$OMP coef_fit, expo_fit, int_fit, tmp) &
|
||||
!$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b3_size, &
|
||||
!$OMP final_grid_points, ng_fit_jast, &
|
||||
!$OMP expo_gauss_1_erf_x_2, coef_gauss_1_erf_x_2, &
|
||||
!$OMP List_all_comb_b3_coef, List_all_comb_b3_expo, &
|
||||
!$OMP List_all_comb_b3_cent, int2_grad1u2_grad2u2_j1b2)
|
||||
!$OMP DO
|
||||
do ipoint = 1, n_points_final_grid
|
||||
r(1) = final_grid_points(1,ipoint)
|
||||
r(2) = final_grid_points(2,ipoint)
|
||||
r(3) = final_grid_points(3,ipoint)
|
||||
|
||||
do i = 1, ao_num
|
||||
do j = i, ao_num
|
||||
|
||||
tmp = 0.d0
|
||||
do i_fit = 1, ng_fit_jast
|
||||
|
||||
expo_fit = expo_gauss_1_erf_x_2(i_fit)
|
||||
coef_fit = coef_gauss_1_erf_x_2(i_fit)
|
||||
|
||||
! ---
|
||||
|
||||
int_fit = overlap_gauss_r12_ao(r, expo_fit, i, j)
|
||||
tmp += -0.25d0 * coef_fit * int_fit
|
||||
! if(dabs(coef_fit*int_fit) .lt. 1d-12) cycle
|
||||
|
||||
! ---
|
||||
|
||||
do i_1s = 2, List_all_comb_b3_size
|
||||
|
||||
coef = List_all_comb_b3_coef (i_1s)
|
||||
beta = List_all_comb_b3_expo (i_1s)
|
||||
B_center(1) = List_all_comb_b3_cent(1,i_1s)
|
||||
B_center(2) = List_all_comb_b3_cent(2,i_1s)
|
||||
B_center(3) = List_all_comb_b3_cent(3,i_1s)
|
||||
|
||||
int_fit = overlap_gauss_r12_ao_with1s(B_center, beta, r, expo_fit, i, j)
|
||||
|
||||
tmp += -0.25d0 * coef * coef_fit * int_fit
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
enddo
|
||||
|
||||
int2_grad1u2_grad2u2_j1b2(j,i,ipoint) = tmp
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 2, ao_num
|
||||
do j = 1, i-1
|
||||
int2_grad1u2_grad2u2_j1b2(j,i,ipoint) = int2_grad1u2_grad2u2_j1b2(i,j,ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print*, ' wall time for int2_grad1u2_grad2u2_j1b2 =', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, int2_u2_j1b2, (ao_num, ao_num, n_points_final_grid)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 [u_12^mu]^2
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint, i_1s, i_fit
|
||||
double precision :: r(3), int_fit, expo_fit, coef_fit
|
||||
double precision :: coef, beta, B_center(3), tmp
|
||||
double precision :: wall0, wall1
|
||||
|
||||
double precision, external :: overlap_gauss_r12_ao
|
||||
double precision, external :: overlap_gauss_r12_ao_with1s
|
||||
|
||||
print*, ' providing int2_u2_j1b2 ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
provide mu_erf final_grid_points j1b_pen
|
||||
|
||||
int2_u2_j1b2 = 0.d0
|
||||
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, &
|
||||
!$OMP coef_fit, expo_fit, int_fit, tmp) &
|
||||
!$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b3_size, &
|
||||
!$OMP final_grid_points, ng_fit_jast, &
|
||||
!$OMP expo_gauss_j_mu_x_2, coef_gauss_j_mu_x_2, &
|
||||
!$OMP List_all_comb_b3_coef, List_all_comb_b3_expo, &
|
||||
!$OMP List_all_comb_b3_cent, int2_u2_j1b2)
|
||||
!$OMP DO
|
||||
do ipoint = 1, n_points_final_grid
|
||||
r(1) = final_grid_points(1,ipoint)
|
||||
r(2) = final_grid_points(2,ipoint)
|
||||
r(3) = final_grid_points(3,ipoint)
|
||||
|
||||
do i = 1, ao_num
|
||||
do j = i, ao_num
|
||||
|
||||
tmp = 0.d0
|
||||
do i_fit = 1, ng_fit_jast
|
||||
|
||||
expo_fit = expo_gauss_j_mu_x_2(i_fit)
|
||||
coef_fit = coef_gauss_j_mu_x_2(i_fit)
|
||||
|
||||
! ---
|
||||
|
||||
int_fit = overlap_gauss_r12_ao(r, expo_fit, i, j)
|
||||
tmp += coef_fit * int_fit
|
||||
! if(dabs(coef_fit*int_fit) .lt. 1d-12) cycle
|
||||
|
||||
! ---
|
||||
|
||||
do i_1s = 2, List_all_comb_b3_size
|
||||
|
||||
coef = List_all_comb_b3_coef (i_1s)
|
||||
beta = List_all_comb_b3_expo (i_1s)
|
||||
B_center(1) = List_all_comb_b3_cent(1,i_1s)
|
||||
B_center(2) = List_all_comb_b3_cent(2,i_1s)
|
||||
B_center(3) = List_all_comb_b3_cent(3,i_1s)
|
||||
|
||||
int_fit = overlap_gauss_r12_ao_with1s(B_center, beta, r, expo_fit, i, j)
|
||||
|
||||
tmp += coef * coef_fit * int_fit
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
enddo
|
||||
|
||||
int2_u2_j1b2(j,i,ipoint) = tmp
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 2, ao_num
|
||||
do j = 1, i-1
|
||||
int2_u2_j1b2(j,i,ipoint) = int2_u2_j1b2(i,j,ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print*, ' wall time for int2_u2_j1b2', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2, (ao_num, ao_num, n_points_final_grid, 3)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 u_12^mu [\grad_1 u_12^mu] r2
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint, i_1s, i_fit
|
||||
double precision :: r(3), int_fit(3), expo_fit, coef_fit
|
||||
double precision :: coef, beta, B_center(3), dist
|
||||
double precision :: alpha_1s, alpha_1s_inv, centr_1s(3), expo_coef_1s, coef_tmp
|
||||
double precision :: tmp_x, tmp_y, tmp_z
|
||||
double precision :: wall0, wall1
|
||||
|
||||
print*, ' providing int2_u_grad1u_x_j1b2 ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
provide mu_erf final_grid_points j1b_pen
|
||||
|
||||
int2_u_grad1u_x_j1b2 = 0.d0
|
||||
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, &
|
||||
!$OMP coef_fit, expo_fit, int_fit, alpha_1s, dist, &
|
||||
!$OMP alpha_1s_inv, centr_1s, expo_coef_1s, coef_tmp, &
|
||||
!$OMP tmp_x, tmp_y, tmp_z) &
|
||||
!$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b3_size, &
|
||||
!$OMP final_grid_points, ng_fit_jast, &
|
||||
!$OMP expo_gauss_j_mu_1_erf, coef_gauss_j_mu_1_erf, &
|
||||
!$OMP List_all_comb_b3_coef, List_all_comb_b3_expo, &
|
||||
!$OMP List_all_comb_b3_cent, int2_u_grad1u_x_j1b2)
|
||||
!$OMP DO
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
r(1) = final_grid_points(1,ipoint)
|
||||
r(2) = final_grid_points(2,ipoint)
|
||||
r(3) = final_grid_points(3,ipoint)
|
||||
|
||||
do i = 1, ao_num
|
||||
do j = i, ao_num
|
||||
|
||||
tmp_x = 0.d0
|
||||
tmp_y = 0.d0
|
||||
tmp_z = 0.d0
|
||||
do i_fit = 1, ng_fit_jast
|
||||
|
||||
expo_fit = expo_gauss_j_mu_1_erf(i_fit)
|
||||
coef_fit = coef_gauss_j_mu_1_erf(i_fit)
|
||||
|
||||
! ---
|
||||
|
||||
call NAI_pol_x_mult_erf_ao_with1s(i, j, expo_fit, r, 1.d+9, r, int_fit)
|
||||
tmp_x += coef_fit * int_fit(1)
|
||||
tmp_y += coef_fit * int_fit(2)
|
||||
tmp_z += coef_fit * int_fit(3)
|
||||
! if( dabs(coef_fit)*(dabs(int_fit(1)) + dabs(int_fit(2)) + dabs(int_fit(3))) .lt. 3d-10 ) cycle
|
||||
|
||||
! ---
|
||||
|
||||
do i_1s = 2, List_all_comb_b3_size
|
||||
|
||||
coef = List_all_comb_b3_coef (i_1s)
|
||||
beta = List_all_comb_b3_expo (i_1s)
|
||||
B_center(1) = List_all_comb_b3_cent(1,i_1s)
|
||||
B_center(2) = List_all_comb_b3_cent(2,i_1s)
|
||||
B_center(3) = List_all_comb_b3_cent(3,i_1s)
|
||||
dist = (B_center(1) - r(1)) * (B_center(1) - r(1)) &
|
||||
+ (B_center(2) - r(2)) * (B_center(2) - r(2)) &
|
||||
+ (B_center(3) - r(3)) * (B_center(3) - r(3))
|
||||
|
||||
alpha_1s = beta + expo_fit
|
||||
alpha_1s_inv = 1.d0 / alpha_1s
|
||||
|
||||
centr_1s(1) = alpha_1s_inv * (beta * B_center(1) + expo_fit * r(1))
|
||||
centr_1s(2) = alpha_1s_inv * (beta * B_center(2) + expo_fit * r(2))
|
||||
centr_1s(3) = alpha_1s_inv * (beta * B_center(3) + expo_fit * r(3))
|
||||
|
||||
expo_coef_1s = beta * expo_fit * alpha_1s_inv * dist
|
||||
coef_tmp = coef * coef_fit * dexp(-expo_coef_1s)
|
||||
! if(dabs(coef_tmp) .lt. 1d-12) cycle
|
||||
|
||||
call NAI_pol_x_mult_erf_ao_with1s(i, j, alpha_1s, centr_1s, 1.d+9, r, int_fit)
|
||||
|
||||
tmp_x += coef_tmp * int_fit(1)
|
||||
tmp_y += coef_tmp * int_fit(2)
|
||||
tmp_z += coef_tmp * int_fit(3)
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
enddo
|
||||
|
||||
int2_u_grad1u_x_j1b2(j,i,ipoint,1) = tmp_x
|
||||
int2_u_grad1u_x_j1b2(j,i,ipoint,2) = tmp_y
|
||||
int2_u_grad1u_x_j1b2(j,i,ipoint,3) = tmp_z
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 2, ao_num
|
||||
do j = 1, i-1
|
||||
int2_u_grad1u_x_j1b2(j,i,ipoint,1) = int2_u_grad1u_x_j1b2(i,j,ipoint,1)
|
||||
int2_u_grad1u_x_j1b2(j,i,ipoint,2) = int2_u_grad1u_x_j1b2(i,j,ipoint,2)
|
||||
int2_u_grad1u_x_j1b2(j,i,ipoint,3) = int2_u_grad1u_x_j1b2(i,j,ipoint,3)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print*, ' wall time for int2_u_grad1u_x_j1b2 = ', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, int2_u_grad1u_j1b2, (ao_num, ao_num, n_points_final_grid)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 u_12^mu [\grad_1 u_12^mu]
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint, i_1s, i_fit
|
||||
double precision :: r(3), int_fit, expo_fit, coef_fit, coef_tmp
|
||||
double precision :: coef, beta, B_center(3), dist
|
||||
double precision :: alpha_1s, alpha_1s_inv, centr_1s(3), expo_coef_1s, tmp
|
||||
double precision :: wall0, wall1
|
||||
double precision, external :: NAI_pol_mult_erf_ao_with1s
|
||||
|
||||
print*, ' providing int2_u_grad1u_j1b2 ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
provide mu_erf final_grid_points j1b_pen
|
||||
|
||||
int2_u_grad1u_j1b2 = 0.d0
|
||||
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, &
|
||||
!$OMP coef_fit, expo_fit, int_fit, tmp, alpha_1s, dist, &
|
||||
!$OMP alpha_1s_inv, centr_1s, expo_coef_1s, coef_tmp) &
|
||||
!$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b3_size, &
|
||||
!$OMP final_grid_points, ng_fit_jast, &
|
||||
!$OMP expo_gauss_j_mu_1_erf, coef_gauss_j_mu_1_erf, &
|
||||
!$OMP List_all_comb_b3_coef, List_all_comb_b3_expo, &
|
||||
!$OMP List_all_comb_b3_cent, int2_u_grad1u_j1b2)
|
||||
!$OMP DO
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 1, ao_num
|
||||
do j = i, ao_num
|
||||
r(1) = final_grid_points(1,ipoint)
|
||||
r(2) = final_grid_points(2,ipoint)
|
||||
r(3) = final_grid_points(3,ipoint)
|
||||
|
||||
tmp = 0.d0
|
||||
do i_fit = 1, ng_fit_jast
|
||||
|
||||
expo_fit = expo_gauss_j_mu_1_erf(i_fit)
|
||||
coef_fit = coef_gauss_j_mu_1_erf(i_fit)
|
||||
|
||||
! ---
|
||||
|
||||
int_fit = NAI_pol_mult_erf_ao_with1s(i, j, expo_fit, r, 1.d+9, r)
|
||||
! if(dabs(coef_fit)*dabs(int_fit) .lt. 1d-12) cycle
|
||||
|
||||
tmp += coef_fit * int_fit
|
||||
|
||||
! ---
|
||||
|
||||
do i_1s = 2, List_all_comb_b3_size
|
||||
|
||||
coef = List_all_comb_b3_coef (i_1s)
|
||||
beta = List_all_comb_b3_expo (i_1s)
|
||||
B_center(1) = List_all_comb_b3_cent(1,i_1s)
|
||||
B_center(2) = List_all_comb_b3_cent(2,i_1s)
|
||||
B_center(3) = List_all_comb_b3_cent(3,i_1s)
|
||||
dist = (B_center(1) - r(1)) * (B_center(1) - r(1)) &
|
||||
+ (B_center(2) - r(2)) * (B_center(2) - r(2)) &
|
||||
+ (B_center(3) - r(3)) * (B_center(3) - r(3))
|
||||
|
||||
alpha_1s = beta + expo_fit
|
||||
alpha_1s_inv = 1.d0 / alpha_1s
|
||||
centr_1s(1) = alpha_1s_inv * (beta * B_center(1) + expo_fit * r(1))
|
||||
centr_1s(2) = alpha_1s_inv * (beta * B_center(2) + expo_fit * r(2))
|
||||
centr_1s(3) = alpha_1s_inv * (beta * B_center(3) + expo_fit * r(3))
|
||||
|
||||
expo_coef_1s = beta * expo_fit * alpha_1s_inv * dist
|
||||
if(expo_coef_1s .gt. 80.d0) cycle
|
||||
coef_tmp = coef * coef_fit * dexp(-expo_coef_1s)
|
||||
if(dabs(coef_tmp) .lt. 1d-12) cycle
|
||||
|
||||
int_fit = NAI_pol_mult_erf_ao_with1s(i, j, alpha_1s, centr_1s, 1.d+9, r)
|
||||
|
||||
tmp += coef_tmp * int_fit
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
enddo
|
||||
|
||||
int2_u_grad1u_j1b2(j,i,ipoint) = tmp
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 2, ao_num
|
||||
do j = 1, i-1
|
||||
int2_u_grad1u_j1b2(j,i,ipoint) = int2_u_grad1u_j1b2(i,j,ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print*, ' wall time for int2_u_grad1u_j1b2', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
453
src/ao_many_one_e_ints/grad2_jmu_modif_vect.irp.f
Normal file
453
src/ao_many_one_e_ints/grad2_jmu_modif_vect.irp.f
Normal file
@ -0,0 +1,453 @@
|
||||
!
|
||||
!! ---
|
||||
!
|
||||
!BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2, (ao_num, ao_num, n_points_final_grid)]
|
||||
!
|
||||
! BEGIN_DOC
|
||||
! !
|
||||
! ! -\frac{1}{4} int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 [1 - erf(mu r12)]^2
|
||||
! !
|
||||
! END_DOC
|
||||
!
|
||||
! implicit none
|
||||
! integer :: i, j, ipoint, i_1s, i_fit
|
||||
! integer :: i_mask_grid
|
||||
! double precision :: r(3), expo_fit, coef_fit
|
||||
! double precision :: coef, beta, B_center(3)
|
||||
! double precision :: wall0, wall1
|
||||
!
|
||||
! integer, allocatable :: n_mask_grid(:)
|
||||
! double precision, allocatable :: r_mask_grid(:,:)
|
||||
! double precision, allocatable :: int_fit_v(:)
|
||||
!
|
||||
! print*, ' providing int2_grad1u2_grad2u2_j1b2'
|
||||
!
|
||||
! provide mu_erf final_grid_points_transp j1b_pen
|
||||
! call wall_time(wall0)
|
||||
!
|
||||
! int2_grad1u2_grad2u2_j1b2(:,:,:) = 0.d0
|
||||
!
|
||||
! !$OMP PARALLEL DEFAULT (NONE) &
|
||||
! !$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center,&
|
||||
! !$OMP coef_fit, expo_fit, int_fit_v, n_mask_grid, &
|
||||
! !$OMP i_mask_grid, r_mask_grid) &
|
||||
! !$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b3_size,&
|
||||
! !$OMP final_grid_points_transp, n_max_fit_slat, &
|
||||
! !$OMP expo_gauss_1_erf_x_2, coef_gauss_1_erf_x_2, &
|
||||
! !$OMP List_all_comb_b3_coef, List_all_comb_b3_expo, &
|
||||
! !$OMP List_all_comb_b3_cent, int2_grad1u2_grad2u2_j1b2, &
|
||||
! !$OMP ao_overlap_abs)
|
||||
!
|
||||
! allocate(int_fit_v(n_points_final_grid))
|
||||
! allocate(n_mask_grid(n_points_final_grid))
|
||||
! allocate(r_mask_grid(n_points_final_grid,3))
|
||||
!
|
||||
! !$OMP DO SCHEDULE(dynamic)
|
||||
! do i = 1, ao_num
|
||||
! do j = i, ao_num
|
||||
!
|
||||
! if(ao_overlap_abs(j,i) .lt. 1.d-12) then
|
||||
! cycle
|
||||
! endif
|
||||
!
|
||||
! do i_fit = 1, n_max_fit_slat
|
||||
!
|
||||
! expo_fit = expo_gauss_1_erf_x_2(i_fit)
|
||||
! coef_fit = coef_gauss_1_erf_x_2(i_fit) * (-0.25d0)
|
||||
!
|
||||
! ! ---
|
||||
!
|
||||
! call overlap_gauss_r12_ao_v(final_grid_points_transp, n_points_final_grid, expo_fit, i, j, int_fit_v, n_points_final_grid, n_points_final_grid)
|
||||
!
|
||||
! i_mask_grid = 0 ! dim
|
||||
! n_mask_grid = 0 ! ind
|
||||
! r_mask_grid = 0.d0 ! val
|
||||
! do ipoint = 1, n_points_final_grid
|
||||
!
|
||||
! int2_grad1u2_grad2u2_j1b2(j,i,ipoint) += coef_fit * int_fit_v(ipoint)
|
||||
!
|
||||
! if(dabs(int_fit_v(ipoint)) .gt. 1d-10) then
|
||||
! i_mask_grid += 1
|
||||
! n_mask_grid(i_mask_grid ) = ipoint
|
||||
! r_mask_grid(i_mask_grid,1) = final_grid_points_transp(ipoint,1)
|
||||
! r_mask_grid(i_mask_grid,2) = final_grid_points_transp(ipoint,2)
|
||||
! r_mask_grid(i_mask_grid,3) = final_grid_points_transp(ipoint,3)
|
||||
! endif
|
||||
!
|
||||
! enddo
|
||||
!
|
||||
! if(i_mask_grid .eq. 0) cycle
|
||||
!
|
||||
! ! ---
|
||||
!
|
||||
! do i_1s = 2, List_all_comb_b3_size
|
||||
!
|
||||
! coef = List_all_comb_b3_coef (i_1s) * coef_fit
|
||||
! beta = List_all_comb_b3_expo (i_1s)
|
||||
! B_center(1) = List_all_comb_b3_cent(1,i_1s)
|
||||
! B_center(2) = List_all_comb_b3_cent(2,i_1s)
|
||||
! B_center(3) = List_all_comb_b3_cent(3,i_1s)
|
||||
!
|
||||
! call overlap_gauss_r12_ao_with1s_v(B_center, beta, r_mask_grid, n_points_final_grid, expo_fit, i, j, int_fit_v, n_points_final_grid, i_mask_grid)
|
||||
!
|
||||
! do ipoint = 1, i_mask_grid
|
||||
! int2_grad1u2_grad2u2_j1b2(j,i,n_mask_grid(ipoint)) += coef * int_fit_v(ipoint)
|
||||
! enddo
|
||||
!
|
||||
! enddo
|
||||
!
|
||||
! ! ---
|
||||
!
|
||||
! enddo
|
||||
! enddo
|
||||
! enddo
|
||||
! !$OMP END DO
|
||||
!
|
||||
! deallocate(n_mask_grid)
|
||||
! deallocate(r_mask_grid)
|
||||
! deallocate(int_fit_v)
|
||||
!
|
||||
! !$OMP END PARALLEL
|
||||
!
|
||||
! do ipoint = 1, n_points_final_grid
|
||||
! do i = 2, ao_num
|
||||
! do j = 1, i-1
|
||||
! int2_grad1u2_grad2u2_j1b2(j,i,ipoint) = int2_grad1u2_grad2u2_j1b2(i,j,ipoint)
|
||||
! enddo
|
||||
! enddo
|
||||
! enddo
|
||||
!
|
||||
! call wall_time(wall1)
|
||||
! print*, ' wall time for int2_grad1u2_grad2u2_j1b2', wall1 - wall0
|
||||
!
|
||||
!END_PROVIDER
|
||||
!
|
||||
!! ---
|
||||
!
|
||||
!BEGIN_PROVIDER [ double precision, int2_u2_j1b2, (ao_num, ao_num, n_points_final_grid)]
|
||||
!
|
||||
! BEGIN_DOC
|
||||
! !
|
||||
! ! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 [u_12^mu]^2
|
||||
! !
|
||||
! END_DOC
|
||||
!
|
||||
! implicit none
|
||||
! integer :: i, j, ipoint, i_1s, i_fit
|
||||
! integer :: i_mask_grid
|
||||
! double precision :: r(3), expo_fit, coef_fit
|
||||
! double precision :: coef, beta, B_center(3), tmp
|
||||
! double precision :: wall0, wall1
|
||||
!
|
||||
! integer, allocatable :: n_mask_grid(:)
|
||||
! double precision, allocatable :: r_mask_grid(:,:)
|
||||
! double precision, allocatable :: int_fit_v(:)
|
||||
!
|
||||
! print*, ' providing int2_u2_j1b2'
|
||||
!
|
||||
! provide mu_erf final_grid_points_transp j1b_pen
|
||||
! call wall_time(wall0)
|
||||
!
|
||||
! int2_u2_j1b2(:,:,:) = 0.d0
|
||||
!
|
||||
! !$OMP PARALLEL DEFAULT (NONE) &
|
||||
! !$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, &
|
||||
! !$OMP coef_fit, expo_fit, int_fit_v, &
|
||||
! !$OMP i_mask_grid, n_mask_grid, r_mask_grid ) &
|
||||
! !$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b3_size, &
|
||||
! !$OMP final_grid_points_transp, n_max_fit_slat, &
|
||||
! !$OMP expo_gauss_j_mu_x_2, coef_gauss_j_mu_x_2, &
|
||||
! !$OMP List_all_comb_b3_coef, List_all_comb_b3_expo, &
|
||||
! !$OMP List_all_comb_b3_cent, int2_u2_j1b2)
|
||||
!
|
||||
! allocate(n_mask_grid(n_points_final_grid))
|
||||
! allocate(r_mask_grid(n_points_final_grid,3))
|
||||
! allocate(int_fit_v(n_points_final_grid))
|
||||
!
|
||||
! !$OMP DO SCHEDULE(dynamic)
|
||||
! do i = 1, ao_num
|
||||
! do j = i, ao_num
|
||||
!
|
||||
! do i_fit = 1, n_max_fit_slat
|
||||
!
|
||||
! expo_fit = expo_gauss_j_mu_x_2(i_fit)
|
||||
! coef_fit = coef_gauss_j_mu_x_2(i_fit)
|
||||
!
|
||||
! ! ---
|
||||
!
|
||||
! call overlap_gauss_r12_ao_v(final_grid_points_transp, n_points_final_grid, expo_fit, i, j, int_fit_v, n_points_final_grid, n_points_final_grid)
|
||||
!
|
||||
! i_mask_grid = 0 ! dim
|
||||
! n_mask_grid = 0 ! ind
|
||||
! r_mask_grid = 0.d0 ! val
|
||||
!
|
||||
! do ipoint = 1, n_points_final_grid
|
||||
! int2_u2_j1b2(j,i,ipoint) += coef_fit * int_fit_v(ipoint)
|
||||
!
|
||||
! if(dabs(int_fit_v(ipoint)) .gt. 1d-10) then
|
||||
! i_mask_grid += 1
|
||||
! n_mask_grid(i_mask_grid ) = ipoint
|
||||
! r_mask_grid(i_mask_grid,1) = final_grid_points_transp(ipoint,1)
|
||||
! r_mask_grid(i_mask_grid,2) = final_grid_points_transp(ipoint,2)
|
||||
! r_mask_grid(i_mask_grid,3) = final_grid_points_transp(ipoint,3)
|
||||
! endif
|
||||
! enddo
|
||||
!
|
||||
! if(i_mask_grid .eq. 0) cycle
|
||||
!
|
||||
! ! ---
|
||||
!
|
||||
! do i_1s = 2, List_all_comb_b3_size
|
||||
!
|
||||
! coef = List_all_comb_b3_coef (i_1s) * coef_fit
|
||||
! beta = List_all_comb_b3_expo (i_1s)
|
||||
! B_center(1) = List_all_comb_b3_cent(1,i_1s)
|
||||
! B_center(2) = List_all_comb_b3_cent(2,i_1s)
|
||||
! B_center(3) = List_all_comb_b3_cent(3,i_1s)
|
||||
!
|
||||
! call overlap_gauss_r12_ao_with1s_v(B_center, beta, r_mask_grid, n_points_final_grid, expo_fit, i, j, int_fit_v, n_points_final_grid, i_mask_grid)
|
||||
!
|
||||
! do ipoint = 1, i_mask_grid
|
||||
! int2_u2_j1b2(j,i,n_mask_grid(ipoint)) += coef * int_fit_v(ipoint)
|
||||
! enddo
|
||||
!
|
||||
! enddo
|
||||
!
|
||||
! ! ---
|
||||
!
|
||||
! enddo
|
||||
! enddo
|
||||
! enddo
|
||||
! !$OMP END DO
|
||||
!
|
||||
! deallocate(n_mask_grid)
|
||||
! deallocate(r_mask_grid)
|
||||
! deallocate(int_fit_v)
|
||||
!
|
||||
! !$OMP END PARALLEL
|
||||
!
|
||||
! do ipoint = 1, n_points_final_grid
|
||||
! do i = 2, ao_num
|
||||
! do j = 1, i-1
|
||||
! int2_u2_j1b2(j,i,ipoint) = int2_u2_j1b2(i,j,ipoint)
|
||||
! enddo
|
||||
! enddo
|
||||
! enddo
|
||||
!
|
||||
! call wall_time(wall1)
|
||||
! print*, ' wall time for int2_u2_j1b2', wall1 - wall0
|
||||
!
|
||||
!END_PROVIDER
|
||||
!
|
||||
!! ---
|
||||
!
|
||||
!BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2, (ao_num, ao_num, n_points_final_grid, 3)]
|
||||
!
|
||||
! BEGIN_DOC
|
||||
! !
|
||||
! ! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 u_12^mu [\grad_1 u_12^mu] r2
|
||||
! !
|
||||
! END_DOC
|
||||
!
|
||||
! implicit none
|
||||
!
|
||||
! integer :: i, j, ipoint, i_1s, i_fit
|
||||
! integer :: i_mask_grid1, i_mask_grid2, i_mask_grid3, i_mask_grid(3)
|
||||
! double precision :: x, y, z, expo_fit, coef_fit
|
||||
! double precision :: coef, beta, B_center(3)
|
||||
! double precision :: alpha_1s, alpha_1s_inv, expo_coef_1s
|
||||
! double precision :: wall0, wall1
|
||||
!
|
||||
! integer, allocatable :: n_mask_grid(:,:)
|
||||
! double precision, allocatable :: r_mask_grid(:,:,:)
|
||||
! double precision, allocatable :: int_fit_v(:,:), dist(:,:), centr_1s(:,:,:)
|
||||
!
|
||||
! print*, ' providing int2_u_grad1u_x_j1b2'
|
||||
!
|
||||
! provide mu_erf final_grid_points_transp j1b_pen
|
||||
! call wall_time(wall0)
|
||||
!
|
||||
! int2_u_grad1u_x_j1b2(:,:,:,:) = 0.d0
|
||||
!
|
||||
! !$OMP PARALLEL DEFAULT (NONE) &
|
||||
! !$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, x, y, z, coef, beta, &
|
||||
! !$OMP coef_fit, expo_fit, int_fit_v, alpha_1s, dist, B_center,&
|
||||
! !$OMP alpha_1s_inv, centr_1s, expo_coef_1s, &
|
||||
! !$OMP i_mask_grid1, i_mask_grid2, i_mask_grid3, i_mask_grid, &
|
||||
! !$OMP n_mask_grid, r_mask_grid) &
|
||||
! !$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b3_size, &
|
||||
! !$OMP final_grid_points_transp, n_max_fit_slat, &
|
||||
! !$OMP expo_gauss_j_mu_1_erf, coef_gauss_j_mu_1_erf, &
|
||||
! !$OMP List_all_comb_b3_coef, List_all_comb_b3_expo, &
|
||||
! !$OMP List_all_comb_b3_cent, int2_u_grad1u_x_j1b2)
|
||||
!
|
||||
! allocate(dist(n_points_final_grid,3))
|
||||
! allocate(centr_1s(n_points_final_grid,3,3))
|
||||
! allocate(n_mask_grid(n_points_final_grid,3))
|
||||
! allocate(r_mask_grid(n_points_final_grid,3,3))
|
||||
! allocate(int_fit_v(n_points_final_grid,3))
|
||||
!
|
||||
! !$OMP DO SCHEDULE(dynamic)
|
||||
! do i = 1, ao_num
|
||||
! do j = i, ao_num
|
||||
! do i_fit = 1, n_max_fit_slat
|
||||
!
|
||||
! expo_fit = expo_gauss_j_mu_1_erf(i_fit)
|
||||
! coef_fit = coef_gauss_j_mu_1_erf(i_fit)
|
||||
!
|
||||
! ! ---
|
||||
!
|
||||
! call NAI_pol_x_mult_erf_ao_with1s_v0(i, j, expo_fit, final_grid_points_transp, n_points_final_grid, 1.d+9, final_grid_points_transp, n_points_final_grid, int_fit_v, n_points_final_grid, n_points_final_grid)
|
||||
!
|
||||
! i_mask_grid1 = 0 ! dim
|
||||
! i_mask_grid2 = 0 ! dim
|
||||
! i_mask_grid3 = 0 ! dim
|
||||
! n_mask_grid = 0 ! ind
|
||||
! r_mask_grid = 0.d0 ! val
|
||||
! do ipoint = 1, n_points_final_grid
|
||||
!
|
||||
! ! ---
|
||||
!
|
||||
! int2_u_grad1u_x_j1b2(j,i,ipoint,1) += coef_fit * int_fit_v(ipoint,1)
|
||||
!
|
||||
! if(dabs(int_fit_v(ipoint,1)) .gt. 1d-10) then
|
||||
! i_mask_grid1 += 1
|
||||
! n_mask_grid(i_mask_grid1, 1) = ipoint
|
||||
! r_mask_grid(i_mask_grid1,1,1) = final_grid_points_transp(ipoint,1)
|
||||
! r_mask_grid(i_mask_grid1,2,1) = final_grid_points_transp(ipoint,2)
|
||||
! r_mask_grid(i_mask_grid1,3,1) = final_grid_points_transp(ipoint,3)
|
||||
! endif
|
||||
!
|
||||
! ! ---
|
||||
!
|
||||
! int2_u_grad1u_x_j1b2(j,i,ipoint,2) += coef_fit * int_fit_v(ipoint,2)
|
||||
!
|
||||
! if(dabs(int_fit_v(ipoint,2)) .gt. 1d-10) then
|
||||
! i_mask_grid2 += 1
|
||||
! n_mask_grid(i_mask_grid2, 2) = ipoint
|
||||
! r_mask_grid(i_mask_grid2,1,2) = final_grid_points_transp(ipoint,1)
|
||||
! r_mask_grid(i_mask_grid2,2,2) = final_grid_points_transp(ipoint,2)
|
||||
! r_mask_grid(i_mask_grid2,3,2) = final_grid_points_transp(ipoint,3)
|
||||
! endif
|
||||
!
|
||||
! ! ---
|
||||
!
|
||||
! int2_u_grad1u_x_j1b2(j,i,ipoint,3) += coef_fit * int_fit_v(ipoint,3)
|
||||
!
|
||||
! if(dabs(int_fit_v(ipoint,3)) .gt. 1d-10) then
|
||||
! i_mask_grid3 += 1
|
||||
! n_mask_grid(i_mask_grid3, 3) = ipoint
|
||||
! r_mask_grid(i_mask_grid3,1,3) = final_grid_points_transp(ipoint,1)
|
||||
! r_mask_grid(i_mask_grid3,2,3) = final_grid_points_transp(ipoint,2)
|
||||
! r_mask_grid(i_mask_grid3,3,3) = final_grid_points_transp(ipoint,3)
|
||||
! endif
|
||||
!
|
||||
! ! ---
|
||||
!
|
||||
! enddo
|
||||
!
|
||||
! if((i_mask_grid1+i_mask_grid2+i_mask_grid3) .eq. 0) cycle
|
||||
!
|
||||
! i_mask_grid(1) = i_mask_grid1
|
||||
! i_mask_grid(2) = i_mask_grid2
|
||||
! i_mask_grid(3) = i_mask_grid3
|
||||
!
|
||||
! ! ---
|
||||
!
|
||||
! do i_1s = 2, List_all_comb_b3_size
|
||||
!
|
||||
! coef = List_all_comb_b3_coef (i_1s) * coef_fit
|
||||
! beta = List_all_comb_b3_expo (i_1s)
|
||||
! B_center(1) = List_all_comb_b3_cent(1,i_1s)
|
||||
! B_center(2) = List_all_comb_b3_cent(2,i_1s)
|
||||
! B_center(3) = List_all_comb_b3_cent(3,i_1s)
|
||||
!
|
||||
! alpha_1s = beta + expo_fit
|
||||
! alpha_1s_inv = 1.d0 / alpha_1s
|
||||
! expo_coef_1s = beta * expo_fit * alpha_1s_inv
|
||||
!
|
||||
! do ipoint = 1, i_mask_grid1
|
||||
!
|
||||
! x = r_mask_grid(ipoint,1,1)
|
||||
! y = r_mask_grid(ipoint,2,1)
|
||||
! z = r_mask_grid(ipoint,3,1)
|
||||
!
|
||||
! centr_1s(ipoint,1,1) = alpha_1s_inv * (beta * B_center(1) + expo_fit * x)
|
||||
! centr_1s(ipoint,2,1) = alpha_1s_inv * (beta * B_center(2) + expo_fit * y)
|
||||
! centr_1s(ipoint,3,1) = alpha_1s_inv * (beta * B_center(3) + expo_fit * z)
|
||||
!
|
||||
! dist(ipoint,1) = (B_center(1) - x) * (B_center(1) - x) + (B_center(2) - y) * (B_center(2) - y) + (B_center(3) - z) * (B_center(3) - z)
|
||||
! enddo
|
||||
!
|
||||
! do ipoint = 1, i_mask_grid2
|
||||
!
|
||||
! x = r_mask_grid(ipoint,1,2)
|
||||
! y = r_mask_grid(ipoint,2,2)
|
||||
! z = r_mask_grid(ipoint,3,2)
|
||||
!
|
||||
! centr_1s(ipoint,1,2) = alpha_1s_inv * (beta * B_center(1) + expo_fit * x)
|
||||
! centr_1s(ipoint,2,2) = alpha_1s_inv * (beta * B_center(2) + expo_fit * y)
|
||||
! centr_1s(ipoint,3,2) = alpha_1s_inv * (beta * B_center(3) + expo_fit * z)
|
||||
!
|
||||
! dist(ipoint,2) = (B_center(1) - x) * (B_center(1) - x) + (B_center(2) - y) * (B_center(2) - y) + (B_center(3) - z) * (B_center(3) - z)
|
||||
! enddo
|
||||
!
|
||||
! do ipoint = 1, i_mask_grid3
|
||||
!
|
||||
! x = r_mask_grid(ipoint,1,3)
|
||||
! y = r_mask_grid(ipoint,2,3)
|
||||
! z = r_mask_grid(ipoint,3,3)
|
||||
!
|
||||
! centr_1s(ipoint,1,3) = alpha_1s_inv * (beta * B_center(1) + expo_fit * x)
|
||||
! centr_1s(ipoint,2,3) = alpha_1s_inv * (beta * B_center(2) + expo_fit * y)
|
||||
! centr_1s(ipoint,3,3) = alpha_1s_inv * (beta * B_center(3) + expo_fit * z)
|
||||
!
|
||||
! dist(ipoint,3) = (B_center(1) - x) * (B_center(1) - x) + (B_center(2) - y) * (B_center(2) - y) + (B_center(3) - z) * (B_center(3) - z)
|
||||
! enddo
|
||||
!
|
||||
! call NAI_pol_x_mult_erf_ao_with1s_v(i, j, alpha_1s, centr_1s, n_points_final_grid, 1.d+9, r_mask_grid, n_points_final_grid, int_fit_v, n_points_final_grid, i_mask_grid)
|
||||
!
|
||||
! do ipoint = 1, i_mask_grid1
|
||||
! int2_u_grad1u_x_j1b2(j,i,n_mask_grid(ipoint,1),1) += coef * dexp(-expo_coef_1s * dist(ipoint,1)) * int_fit_v(ipoint,1)
|
||||
! enddo
|
||||
!
|
||||
! do ipoint = 1, i_mask_grid2
|
||||
! int2_u_grad1u_x_j1b2(j,i,n_mask_grid(ipoint,2),2) += coef * dexp(-expo_coef_1s * dist(ipoint,2)) * int_fit_v(ipoint,2)
|
||||
! enddo
|
||||
!
|
||||
! do ipoint = 1, i_mask_grid3
|
||||
! int2_u_grad1u_x_j1b2(j,i,n_mask_grid(ipoint,3),3) += coef * dexp(-expo_coef_1s * dist(ipoint,3)) * int_fit_v(ipoint,3)
|
||||
! enddo
|
||||
!
|
||||
! enddo
|
||||
!
|
||||
! ! ---
|
||||
!
|
||||
! enddo
|
||||
! enddo
|
||||
! enddo
|
||||
! !$OMP END DO
|
||||
!
|
||||
! deallocate(dist)
|
||||
! deallocate(centr_1s)
|
||||
! deallocate(n_mask_grid)
|
||||
! deallocate(r_mask_grid)
|
||||
! deallocate(int_fit_v)
|
||||
!
|
||||
! !$OMP END PARALLEL
|
||||
!
|
||||
! do ipoint = 1, n_points_final_grid
|
||||
! do i = 2, ao_num
|
||||
! do j = 1, i-1
|
||||
! int2_u_grad1u_x_j1b2(j,i,ipoint,1) = int2_u_grad1u_x_j1b2(i,j,ipoint,1)
|
||||
! int2_u_grad1u_x_j1b2(j,i,ipoint,2) = int2_u_grad1u_x_j1b2(i,j,ipoint,2)
|
||||
! int2_u_grad1u_x_j1b2(j,i,ipoint,3) = int2_u_grad1u_x_j1b2(i,j,ipoint,3)
|
||||
! enddo
|
||||
! enddo
|
||||
! enddo
|
||||
!
|
||||
! call wall_time(wall1)
|
||||
! print*, ' wall time for int2_u_grad1u_x_j1b2 =', wall1 - wall0
|
||||
!
|
||||
!END_PROVIDER
|
||||
!
|
||||
369
src/ao_many_one_e_ints/grad_lapl_jmu_manu.irp.f
Normal file
369
src/ao_many_one_e_ints/grad_lapl_jmu_manu.irp.f
Normal file
@ -0,0 +1,369 @@
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_j1b_test, (ao_num, ao_num, n_points_final_grid)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! int dr phi_i(r) phi_j(r) 1s_j1b(r) (erf(mu(R) |r - R| - 1) / |r - R|
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint, i_1s
|
||||
double precision :: r(3), int_mu, int_coulomb
|
||||
double precision :: coef, beta, B_center(3)
|
||||
double precision :: tmp,int_j1b
|
||||
double precision :: wall0, wall1
|
||||
double precision, external :: NAI_pol_mult_erf_ao_with1s
|
||||
double precision :: sigma_ij,dist_ij_ipoint,dsqpi_3_2
|
||||
|
||||
print*, ' providing v_ij_erf_rk_cst_mu_j1b_test ...'
|
||||
|
||||
dsqpi_3_2 = (dacos(-1.d0))**(1.5d0)
|
||||
provide mu_erf final_grid_points j1b_pen
|
||||
call wall_time(wall0)
|
||||
|
||||
v_ij_erf_rk_cst_mu_j1b_test = 0.d0
|
||||
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, int_mu, int_coulomb, tmp, int_j1b)&
|
||||
!$OMP SHARED (n_points_final_grid, ao_num, List_comb_thr_b2_size, final_grid_points, &
|
||||
!$OMP List_comb_thr_b2_coef, List_comb_thr_b2_expo, List_comb_thr_b2_cent,ao_abs_comb_b2_j1b, &
|
||||
!$OMP v_ij_erf_rk_cst_mu_j1b_test, mu_erf, &
|
||||
!$OMP ao_overlap_abs_grid,ao_prod_center,ao_prod_sigma,dsqpi_3_2)
|
||||
!$OMP DO
|
||||
!do ipoint = 1, 10
|
||||
do ipoint = 1, n_points_final_grid
|
||||
r(1) = final_grid_points(1,ipoint)
|
||||
r(2) = final_grid_points(2,ipoint)
|
||||
r(3) = final_grid_points(3,ipoint)
|
||||
|
||||
do i = 1, ao_num
|
||||
do j = i, ao_num
|
||||
if(dabs(ao_overlap_abs_grid(j,i)).lt.1.d-20)cycle
|
||||
|
||||
tmp = 0.d0
|
||||
do i_1s = 1, List_comb_thr_b2_size(j,i)
|
||||
|
||||
coef = List_comb_thr_b2_coef (i_1s,j,i)
|
||||
beta = List_comb_thr_b2_expo (i_1s,j,i)
|
||||
int_j1b = ao_abs_comb_b2_j1b(i_1s,j,i)
|
||||
if(dabs(coef)*dabs(int_j1b).lt.1.d-10)cycle
|
||||
B_center(1) = List_comb_thr_b2_cent(1,i_1s,j,i)
|
||||
B_center(2) = List_comb_thr_b2_cent(2,i_1s,j,i)
|
||||
B_center(3) = List_comb_thr_b2_cent(3,i_1s,j,i)
|
||||
! TODO :: cycle on the 1 - erf(mur12)
|
||||
int_mu = NAI_pol_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r)
|
||||
int_coulomb = NAI_pol_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r)
|
||||
|
||||
tmp += coef * (int_mu - int_coulomb)
|
||||
enddo
|
||||
|
||||
v_ij_erf_rk_cst_mu_j1b_test(j,i,ipoint) = tmp
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 2, ao_num
|
||||
do j = 1, i-1
|
||||
v_ij_erf_rk_cst_mu_j1b_test(j,i,ipoint) = v_ij_erf_rk_cst_mu_j1b_test(i,j,ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print*, ' wall time for v_ij_erf_rk_cst_mu_j1b_test', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_j1b_test, (ao_num, ao_num, n_points_final_grid, 3)]
|
||||
|
||||
BEGIN_DOC
|
||||
! int dr x phi_i(r) phi_j(r) 1s_j1b(r) (erf(mu(R) |r - R|) - 1)/|r - R|
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint, i_1s
|
||||
double precision :: coef, beta, B_center(3), r(3), ints(3), ints_coulomb(3)
|
||||
double precision :: tmp_x, tmp_y, tmp_z
|
||||
double precision :: wall0, wall1
|
||||
double precision :: sigma_ij,dist_ij_ipoint,dsqpi_3_2,int_j1b,factor_ij_1s,beta_ij,center_ij_1s
|
||||
|
||||
print*, ' providing x_v_ij_erf_rk_cst_mu_j1b_test ...'
|
||||
|
||||
dsqpi_3_2 = (dacos(-1.d0))**(1.5d0)
|
||||
|
||||
provide expo_erfc_mu_gauss ao_prod_sigma ao_prod_center
|
||||
call wall_time(wall0)
|
||||
|
||||
x_v_ij_erf_rk_cst_mu_j1b_test = 0.d0
|
||||
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, ints, ints_coulomb, &
|
||||
!$OMP int_j1b, tmp_x, tmp_y, tmp_z,factor_ij_1s,beta_ij,center_ij_1s) &
|
||||
!$OMP SHARED (n_points_final_grid, ao_num, List_comb_thr_b2_size, final_grid_points,&
|
||||
!$OMP List_comb_thr_b2_coef, List_comb_thr_b2_expo, List_comb_thr_b2_cent, &
|
||||
!$OMP x_v_ij_erf_rk_cst_mu_j1b_test, mu_erf,ao_abs_comb_b2_j1b, &
|
||||
!$OMP ao_overlap_abs_grid,ao_prod_center,ao_prod_sigma)
|
||||
! !$OMP ao_overlap_abs_grid,ao_prod_center,ao_prod_sigma,dsqpi_3_2,expo_erfc_mu_gauss)
|
||||
!$OMP DO
|
||||
do ipoint = 1, n_points_final_grid
|
||||
r(1) = final_grid_points(1,ipoint)
|
||||
r(2) = final_grid_points(2,ipoint)
|
||||
r(3) = final_grid_points(3,ipoint)
|
||||
|
||||
do i = 1, ao_num
|
||||
do j = i, ao_num
|
||||
if(dabs(ao_overlap_abs_grid(j,i)).lt.1.d-10)cycle
|
||||
|
||||
tmp_x = 0.d0
|
||||
tmp_y = 0.d0
|
||||
tmp_z = 0.d0
|
||||
do i_1s = 1, List_comb_thr_b2_size(j,i)
|
||||
|
||||
coef = List_comb_thr_b2_coef (i_1s,j,i)
|
||||
beta = List_comb_thr_b2_expo (i_1s,j,i)
|
||||
int_j1b = ao_abs_comb_b2_j1b(i_1s,j,i)
|
||||
if(dabs(coef)*dabs(int_j1b).lt.1.d-10)cycle
|
||||
B_center(1) = List_comb_thr_b2_cent(1,i_1s,j,i)
|
||||
B_center(2) = List_comb_thr_b2_cent(2,i_1s,j,i)
|
||||
B_center(3) = List_comb_thr_b2_cent(3,i_1s,j,i)
|
||||
|
||||
! if(ao_prod_center(1,j,i).ne.10000.d0)then
|
||||
! ! approximate 1 - erf(mu r12) by a gaussian * 10
|
||||
! !DIR$ FORCEINLINE
|
||||
! call gaussian_product(expo_erfc_mu_gauss,r, &
|
||||
! ao_prod_sigma(j,i),ao_prod_center(1,j,i), &
|
||||
! factor_ij_1s,beta_ij,center_ij_1s)
|
||||
! if(dabs(coef * factor_ij_1s*int_j1b*10.d0 * dsqpi_3_2 * beta_ij**(-1.5d0)).lt.1.d-10)cycle
|
||||
! endif
|
||||
call NAI_pol_x_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r, ints )
|
||||
call NAI_pol_x_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r, ints_coulomb)
|
||||
|
||||
tmp_x += coef * (ints(1) - ints_coulomb(1))
|
||||
tmp_y += coef * (ints(2) - ints_coulomb(2))
|
||||
tmp_z += coef * (ints(3) - ints_coulomb(3))
|
||||
enddo
|
||||
|
||||
x_v_ij_erf_rk_cst_mu_j1b_test(j,i,ipoint,1) = tmp_x
|
||||
x_v_ij_erf_rk_cst_mu_j1b_test(j,i,ipoint,2) = tmp_y
|
||||
x_v_ij_erf_rk_cst_mu_j1b_test(j,i,ipoint,3) = tmp_z
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 2, ao_num
|
||||
do j = 1, i-1
|
||||
x_v_ij_erf_rk_cst_mu_j1b_test(j,i,ipoint,1) = x_v_ij_erf_rk_cst_mu_j1b_test(i,j,ipoint,1)
|
||||
x_v_ij_erf_rk_cst_mu_j1b_test(j,i,ipoint,2) = x_v_ij_erf_rk_cst_mu_j1b_test(i,j,ipoint,2)
|
||||
x_v_ij_erf_rk_cst_mu_j1b_test(j,i,ipoint,3) = x_v_ij_erf_rk_cst_mu_j1b_test(i,j,ipoint,3)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print*, ' wall time for x_v_ij_erf_rk_cst_mu_j1b_test', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
! TODO analytically
|
||||
BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_test, (ao_num, ao_num, n_points_final_grid)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2) u(mu, r12)
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint, i_1s, i_fit
|
||||
double precision :: r(3), int_fit, expo_fit, coef_fit
|
||||
double precision :: coef, beta, B_center(3)
|
||||
double precision :: tmp
|
||||
double precision :: wall0, wall1
|
||||
|
||||
double precision, external :: overlap_gauss_r12_ao_with1s
|
||||
double precision :: sigma_ij,dist_ij_ipoint,dsqpi_3_2,int_j1b
|
||||
|
||||
print*, ' providing v_ij_u_cst_mu_j1b_test ...'
|
||||
|
||||
dsqpi_3_2 = (dacos(-1.d0))**(1.5d0)
|
||||
|
||||
provide mu_erf final_grid_points j1b_pen
|
||||
call wall_time(wall0)
|
||||
|
||||
v_ij_u_cst_mu_j1b_test = 0.d0
|
||||
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, &
|
||||
!$OMP beta_ij_u, factor_ij_1s_u, center_ij_1s_u, &
|
||||
!$OMP coef_fit, expo_fit, int_fit, tmp,coeftot,int_j1b) &
|
||||
!$OMP SHARED (n_points_final_grid, ao_num, &
|
||||
!$OMP final_grid_points, ng_fit_jast, &
|
||||
!$OMP expo_gauss_j_mu_x, coef_gauss_j_mu_x, &
|
||||
!$OMP List_comb_thr_b2_coef, List_comb_thr_b2_expo,List_comb_thr_b2_size, &
|
||||
!$OMP List_comb_thr_b2_cent, v_ij_u_cst_mu_j1b_test,ao_abs_comb_b2_j1b, &
|
||||
!$OMP ao_overlap_abs_grid,ao_prod_center,ao_prod_sigma,dsqpi_3_2)
|
||||
!$OMP DO
|
||||
!do ipoint = 1, 10
|
||||
do ipoint = 1, n_points_final_grid
|
||||
r(1) = final_grid_points(1,ipoint)
|
||||
r(2) = final_grid_points(2,ipoint)
|
||||
r(3) = final_grid_points(3,ipoint)
|
||||
|
||||
do i = 1, ao_num
|
||||
do j = i, ao_num
|
||||
if(dabs(ao_overlap_abs_grid(j,i)).lt.1.d-20)cycle
|
||||
|
||||
tmp = 0.d0
|
||||
do i_1s = 1, List_comb_thr_b2_size(j,i)
|
||||
|
||||
coef = List_comb_thr_b2_coef (i_1s,j,i)
|
||||
beta = List_comb_thr_b2_expo (i_1s,j,i)
|
||||
int_j1b = ao_abs_comb_b2_j1b(i_1s,j,i)
|
||||
if(dabs(coef)*dabs(int_j1b).lt.1.d-10)cycle
|
||||
B_center(1) = List_comb_thr_b2_cent(1,i_1s,j,i)
|
||||
B_center(2) = List_comb_thr_b2_cent(2,i_1s,j,i)
|
||||
B_center(3) = List_comb_thr_b2_cent(3,i_1s,j,i)
|
||||
|
||||
do i_fit = 1, ng_fit_jast
|
||||
|
||||
expo_fit = expo_gauss_j_mu_x(i_fit)
|
||||
coef_fit = coef_gauss_j_mu_x(i_fit)
|
||||
coeftot = coef * coef_fit
|
||||
if(dabs(coeftot).lt.1.d-15)cycle
|
||||
double precision :: beta_ij_u, factor_ij_1s_u, center_ij_1s_u(3),coeftot
|
||||
call gaussian_product(beta,B_center,expo_fit,r,factor_ij_1s_u,beta_ij_u,center_ij_1s_u)
|
||||
if(factor_ij_1s_u*ao_overlap_abs_grid(j,i).lt.1.d-15)cycle
|
||||
int_fit = overlap_gauss_r12_ao_with1s(B_center, beta, r, expo_fit, i, j)
|
||||
|
||||
tmp += coef * coef_fit * int_fit
|
||||
enddo
|
||||
enddo
|
||||
|
||||
v_ij_u_cst_mu_j1b_test(j,i,ipoint) = tmp
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 2, ao_num
|
||||
do j = 1, i-1
|
||||
v_ij_u_cst_mu_j1b_test(j,i,ipoint) = v_ij_u_cst_mu_j1b_test(i,j,ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print*, ' wall time for v_ij_u_cst_mu_j1b_test', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_ng_1_test, (ao_num, ao_num, n_points_final_grid)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2) u(mu, r12) with u(mu,r12) \approx 1/2 mu e^{-2.5 * mu (r12)^2}
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint, i_1s
|
||||
double precision :: r(3), int_fit, expo_fit, coef_fit
|
||||
double precision :: coef, beta, B_center(3)
|
||||
double precision :: tmp
|
||||
double precision :: wall0, wall1
|
||||
|
||||
double precision, external :: overlap_gauss_r12_ao_with1s
|
||||
double precision :: sigma_ij,dist_ij_ipoint,dsqpi_3_2,int_j1b
|
||||
dsqpi_3_2 = (dacos(-1.d0))**(1.5d0)
|
||||
|
||||
provide mu_erf final_grid_points j1b_pen
|
||||
call wall_time(wall0)
|
||||
|
||||
v_ij_u_cst_mu_j1b_ng_1_test = 0.d0
|
||||
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, &
|
||||
!$OMP beta_ij_u, factor_ij_1s_u, center_ij_1s_u, &
|
||||
!$OMP coef_fit, expo_fit, int_fit, tmp,coeftot,int_j1b) &
|
||||
!$OMP SHARED (n_points_final_grid, ao_num, &
|
||||
!$OMP final_grid_points, expo_good_j_mu_1gauss,coef_good_j_mu_1gauss, &
|
||||
!$OMP expo_gauss_j_mu_x, coef_gauss_j_mu_x, &
|
||||
!$OMP List_comb_thr_b2_coef, List_comb_thr_b2_expo,List_comb_thr_b2_size, &
|
||||
!$OMP List_comb_thr_b2_cent, v_ij_u_cst_mu_j1b_ng_1_test,ao_abs_comb_b2_j1b, &
|
||||
!$OMP ao_overlap_abs_grid,ao_prod_center,ao_prod_sigma,dsqpi_3_2)
|
||||
!$OMP DO
|
||||
!do ipoint = 1, 10
|
||||
do ipoint = 1, n_points_final_grid
|
||||
r(1) = final_grid_points(1,ipoint)
|
||||
r(2) = final_grid_points(2,ipoint)
|
||||
r(3) = final_grid_points(3,ipoint)
|
||||
|
||||
do i = 1, ao_num
|
||||
do j = i, ao_num
|
||||
if(dabs(ao_overlap_abs_grid(j,i)).lt.1.d-20)cycle
|
||||
|
||||
tmp = 0.d0
|
||||
do i_1s = 1, List_comb_thr_b2_size(j,i)
|
||||
|
||||
coef = List_comb_thr_b2_coef (i_1s,j,i)
|
||||
beta = List_comb_thr_b2_expo (i_1s,j,i)
|
||||
int_j1b = ao_abs_comb_b2_j1b(i_1s,j,i)
|
||||
if(dabs(coef)*dabs(int_j1b).lt.1.d-10)cycle
|
||||
B_center(1) = List_comb_thr_b2_cent(1,i_1s,j,i)
|
||||
B_center(2) = List_comb_thr_b2_cent(2,i_1s,j,i)
|
||||
B_center(3) = List_comb_thr_b2_cent(3,i_1s,j,i)
|
||||
|
||||
! do i_fit = 1, ng_fit_jast
|
||||
|
||||
expo_fit = expo_good_j_mu_1gauss
|
||||
coef_fit = 1.d0
|
||||
coeftot = coef * coef_fit
|
||||
if(dabs(coeftot).lt.1.d-15)cycle
|
||||
double precision :: beta_ij_u, factor_ij_1s_u, center_ij_1s_u(3),coeftot
|
||||
call gaussian_product(beta,B_center,expo_fit,r,factor_ij_1s_u,beta_ij_u,center_ij_1s_u)
|
||||
if(factor_ij_1s_u*ao_overlap_abs_grid(j,i).lt.1.d-15)cycle
|
||||
int_fit = overlap_gauss_r12_ao_with1s(B_center, beta, r, expo_fit, i, j)
|
||||
|
||||
tmp += coef * coef_fit * int_fit
|
||||
! enddo
|
||||
enddo
|
||||
|
||||
v_ij_u_cst_mu_j1b_ng_1_test(j,i,ipoint) = tmp
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 2, ao_num
|
||||
do j = 1, i-1
|
||||
v_ij_u_cst_mu_j1b_ng_1_test(j,i,ipoint) = v_ij_u_cst_mu_j1b_ng_1_test(i,j,ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print*, ' wall time for v_ij_u_cst_mu_j1b_ng_1_test', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
300
src/ao_many_one_e_ints/grad_lapl_jmu_modif.irp.f
Normal file
300
src/ao_many_one_e_ints/grad_lapl_jmu_modif.irp.f
Normal file
@ -0,0 +1,300 @@
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_points_final_grid)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! int dr phi_i(r) phi_j(r) 1s_j1b(r) (erf(mu(R) |r - R| - 1) / |r - R|
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint, i_1s
|
||||
double precision :: r(3), int_mu, int_coulomb
|
||||
double precision :: coef, beta, B_center(3)
|
||||
double precision :: tmp
|
||||
double precision :: wall0, wall1
|
||||
double precision, external :: NAI_pol_mult_erf_ao_with1s
|
||||
|
||||
print *, ' providing v_ij_erf_rk_cst_mu_j1b ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
provide mu_erf final_grid_points j1b_pen
|
||||
|
||||
v_ij_erf_rk_cst_mu_j1b = 0.d0
|
||||
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, int_mu, int_coulomb, tmp) &
|
||||
!$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b2_size, final_grid_points, &
|
||||
!$OMP List_all_comb_b2_coef, List_all_comb_b2_expo, List_all_comb_b2_cent, &
|
||||
!$OMP v_ij_erf_rk_cst_mu_j1b, mu_erf)
|
||||
!$OMP DO
|
||||
!do ipoint = 1, 10
|
||||
do ipoint = 1, n_points_final_grid
|
||||
r(1) = final_grid_points(1,ipoint)
|
||||
r(2) = final_grid_points(2,ipoint)
|
||||
r(3) = final_grid_points(3,ipoint)
|
||||
|
||||
do i = 1, ao_num
|
||||
do j = i, ao_num
|
||||
|
||||
tmp = 0.d0
|
||||
|
||||
! ---
|
||||
|
||||
coef = List_all_comb_b2_coef (1)
|
||||
beta = List_all_comb_b2_expo (1)
|
||||
B_center(1) = List_all_comb_b2_cent(1,1)
|
||||
B_center(2) = List_all_comb_b2_cent(2,1)
|
||||
B_center(3) = List_all_comb_b2_cent(3,1)
|
||||
|
||||
int_mu = NAI_pol_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r)
|
||||
int_coulomb = NAI_pol_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r)
|
||||
! if(dabs(coef)*dabs(int_mu - int_coulomb) .lt. 1d-12) cycle
|
||||
|
||||
tmp += coef * (int_mu - int_coulomb)
|
||||
|
||||
! ---
|
||||
|
||||
do i_1s = 2, List_all_comb_b2_size
|
||||
|
||||
coef = List_all_comb_b2_coef (i_1s)
|
||||
beta = List_all_comb_b2_expo (i_1s)
|
||||
B_center(1) = List_all_comb_b2_cent(1,i_1s)
|
||||
B_center(2) = List_all_comb_b2_cent(2,i_1s)
|
||||
B_center(3) = List_all_comb_b2_cent(3,i_1s)
|
||||
|
||||
int_mu = NAI_pol_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r)
|
||||
int_coulomb = NAI_pol_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r)
|
||||
|
||||
tmp += coef * (int_mu - int_coulomb)
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
v_ij_erf_rk_cst_mu_j1b(j,i,ipoint) = tmp
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 2, ao_num
|
||||
do j = 1, i-1
|
||||
v_ij_erf_rk_cst_mu_j1b(j,i,ipoint) = v_ij_erf_rk_cst_mu_j1b(i,j,ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print*, ' wall time for v_ij_erf_rk_cst_mu_j1b', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_points_final_grid, 3)]
|
||||
|
||||
BEGIN_DOC
|
||||
! int dr x phi_i(r) phi_j(r) 1s_j1b(r) (erf(mu(R) |r - R|) - 1)/|r - R|
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint, i_1s
|
||||
double precision :: coef, beta, B_center(3), r(3), ints(3), ints_coulomb(3)
|
||||
double precision :: tmp_x, tmp_y, tmp_z
|
||||
double precision :: wall0, wall1
|
||||
|
||||
print*, ' providing x_v_ij_erf_rk_cst_mu_j1b ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
x_v_ij_erf_rk_cst_mu_j1b = 0.d0
|
||||
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, ints, ints_coulomb, &
|
||||
!$OMP tmp_x, tmp_y, tmp_z) &
|
||||
!$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b2_size, final_grid_points,&
|
||||
!$OMP List_all_comb_b2_coef, List_all_comb_b2_expo, List_all_comb_b2_cent, &
|
||||
!$OMP x_v_ij_erf_rk_cst_mu_j1b, mu_erf)
|
||||
!$OMP DO
|
||||
!do ipoint = 1, 10
|
||||
do ipoint = 1, n_points_final_grid
|
||||
r(1) = final_grid_points(1,ipoint)
|
||||
r(2) = final_grid_points(2,ipoint)
|
||||
r(3) = final_grid_points(3,ipoint)
|
||||
|
||||
do i = 1, ao_num
|
||||
do j = i, ao_num
|
||||
|
||||
tmp_x = 0.d0
|
||||
tmp_y = 0.d0
|
||||
tmp_z = 0.d0
|
||||
|
||||
! ---
|
||||
|
||||
coef = List_all_comb_b2_coef (1)
|
||||
beta = List_all_comb_b2_expo (1)
|
||||
B_center(1) = List_all_comb_b2_cent(1,1)
|
||||
B_center(2) = List_all_comb_b2_cent(2,1)
|
||||
B_center(3) = List_all_comb_b2_cent(3,1)
|
||||
|
||||
call NAI_pol_x_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r, ints )
|
||||
call NAI_pol_x_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r, ints_coulomb)
|
||||
|
||||
! if( dabs(coef)*(dabs(ints(1)-ints_coulomb(1)) + dabs(ints(2)-ints_coulomb(2)) + dabs(ints(3)-ints_coulomb(3))) .lt. 3d-10) cycle
|
||||
|
||||
tmp_x += coef * (ints(1) - ints_coulomb(1))
|
||||
tmp_y += coef * (ints(2) - ints_coulomb(2))
|
||||
tmp_z += coef * (ints(3) - ints_coulomb(3))
|
||||
|
||||
! ---
|
||||
|
||||
do i_1s = 2, List_all_comb_b2_size
|
||||
|
||||
coef = List_all_comb_b2_coef (i_1s)
|
||||
beta = List_all_comb_b2_expo (i_1s)
|
||||
B_center(1) = List_all_comb_b2_cent(1,i_1s)
|
||||
B_center(2) = List_all_comb_b2_cent(2,i_1s)
|
||||
B_center(3) = List_all_comb_b2_cent(3,i_1s)
|
||||
|
||||
call NAI_pol_x_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r, ints )
|
||||
call NAI_pol_x_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r, ints_coulomb)
|
||||
|
||||
tmp_x += coef * (ints(1) - ints_coulomb(1))
|
||||
tmp_y += coef * (ints(2) - ints_coulomb(2))
|
||||
tmp_z += coef * (ints(3) - ints_coulomb(3))
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
x_v_ij_erf_rk_cst_mu_j1b(j,i,ipoint,1) = tmp_x
|
||||
x_v_ij_erf_rk_cst_mu_j1b(j,i,ipoint,2) = tmp_y
|
||||
x_v_ij_erf_rk_cst_mu_j1b(j,i,ipoint,3) = tmp_z
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 2, ao_num
|
||||
do j = 1, i-1
|
||||
x_v_ij_erf_rk_cst_mu_j1b(j,i,ipoint,1) = x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,1)
|
||||
x_v_ij_erf_rk_cst_mu_j1b(j,i,ipoint,2) = x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,2)
|
||||
x_v_ij_erf_rk_cst_mu_j1b(j,i,ipoint,3) = x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,3)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print*, ' wall time for x_v_ij_erf_rk_cst_mu_j1b =', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
! TODO analytically
|
||||
BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b, (ao_num, ao_num, n_points_final_grid)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2) u(mu, r12)
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint, i_1s, i_fit
|
||||
double precision :: r(3), int_fit, expo_fit, coef_fit
|
||||
double precision :: coef, beta, B_center(3)
|
||||
double precision :: tmp
|
||||
double precision :: wall0, wall1
|
||||
|
||||
double precision, external :: overlap_gauss_r12_ao_with1s
|
||||
|
||||
print*, ' providing v_ij_u_cst_mu_j1b ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
provide mu_erf final_grid_points j1b_pen
|
||||
|
||||
v_ij_u_cst_mu_j1b = 0.d0
|
||||
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, &
|
||||
!$OMP coef_fit, expo_fit, int_fit, tmp) &
|
||||
!$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b2_size, &
|
||||
!$OMP final_grid_points, ng_fit_jast, &
|
||||
!$OMP expo_gauss_j_mu_x, coef_gauss_j_mu_x, &
|
||||
!$OMP List_all_comb_b2_coef, List_all_comb_b2_expo, &
|
||||
!$OMP List_all_comb_b2_cent, v_ij_u_cst_mu_j1b)
|
||||
!$OMP DO
|
||||
!do ipoint = 1, 10
|
||||
do ipoint = 1, n_points_final_grid
|
||||
r(1) = final_grid_points(1,ipoint)
|
||||
r(2) = final_grid_points(2,ipoint)
|
||||
r(3) = final_grid_points(3,ipoint)
|
||||
|
||||
do i = 1, ao_num
|
||||
do j = i, ao_num
|
||||
|
||||
tmp = 0.d0
|
||||
do i_fit = 1, ng_fit_jast
|
||||
|
||||
expo_fit = expo_gauss_j_mu_x(i_fit)
|
||||
coef_fit = coef_gauss_j_mu_x(i_fit)
|
||||
|
||||
! ---
|
||||
|
||||
coef = List_all_comb_b2_coef (1)
|
||||
beta = List_all_comb_b2_expo (1)
|
||||
B_center(1) = List_all_comb_b2_cent(1,1)
|
||||
B_center(2) = List_all_comb_b2_cent(2,1)
|
||||
B_center(3) = List_all_comb_b2_cent(3,1)
|
||||
|
||||
int_fit = overlap_gauss_r12_ao_with1s(B_center, beta, r, expo_fit, i, j)
|
||||
! if(dabs(int_fit*coef) .lt. 1d-12) cycle
|
||||
|
||||
tmp += coef * coef_fit * int_fit
|
||||
|
||||
! ---
|
||||
|
||||
do i_1s = 2, List_all_comb_b2_size
|
||||
|
||||
coef = List_all_comb_b2_coef (i_1s)
|
||||
beta = List_all_comb_b2_expo (i_1s)
|
||||
B_center(1) = List_all_comb_b2_cent(1,i_1s)
|
||||
B_center(2) = List_all_comb_b2_cent(2,i_1s)
|
||||
B_center(3) = List_all_comb_b2_cent(3,i_1s)
|
||||
|
||||
int_fit = overlap_gauss_r12_ao_with1s(B_center, beta, r, expo_fit, i, j)
|
||||
|
||||
tmp += coef * coef_fit * int_fit
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
enddo
|
||||
|
||||
v_ij_u_cst_mu_j1b(j,i,ipoint) = tmp
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 2, ao_num
|
||||
do j = 1, i-1
|
||||
v_ij_u_cst_mu_j1b(j,i,ipoint) = v_ij_u_cst_mu_j1b(i,j,ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print*, ' wall time for v_ij_u_cst_mu_j1b', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
437
src/ao_many_one_e_ints/grad_related_ints.irp.f
Normal file
437
src/ao_many_one_e_ints/grad_related_ints.irp.f
Normal file
@ -0,0 +1,437 @@
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu, (ao_num, ao_num, n_points_final_grid)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! int dr phi_i(r) phi_j(r) (erf(mu(R) |r - R| - 1) / |r - R|
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint
|
||||
double precision :: r(3)
|
||||
double precision :: int_mu, int_coulomb
|
||||
double precision :: wall0, wall1
|
||||
|
||||
double precision :: NAI_pol_mult_erf_ao
|
||||
|
||||
print*, ' providing v_ij_erf_rk_cst_mu ...'
|
||||
|
||||
provide mu_erf final_grid_points
|
||||
call wall_time(wall0)
|
||||
|
||||
v_ij_erf_rk_cst_mu = 0.d0
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i, j, ipoint, r, int_mu, int_coulomb) &
|
||||
!$OMP SHARED (ao_num, n_points_final_grid, v_ij_erf_rk_cst_mu, final_grid_points, mu_erf)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do ipoint = 1, n_points_final_grid
|
||||
r(1) = final_grid_points(1,ipoint)
|
||||
r(2) = final_grid_points(2,ipoint)
|
||||
r(3) = final_grid_points(3,ipoint)
|
||||
|
||||
do i = 1, ao_num
|
||||
do j = i, ao_num
|
||||
|
||||
int_mu = NAI_pol_mult_erf_ao(i, j, mu_erf, r)
|
||||
int_coulomb = NAI_pol_mult_erf_ao(i, j, 1.d+9, r)
|
||||
|
||||
v_ij_erf_rk_cst_mu(j,i,ipoint) = int_mu - int_coulomb
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 2, ao_num
|
||||
do j = 1, i-1
|
||||
v_ij_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)]
|
||||
|
||||
BEGIN_DOC
|
||||
! int dr phi_i(r) phi_j(r) (erf(mu(R) |r - R| - 1)/|r - R|
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint
|
||||
double precision :: r(3)
|
||||
double precision :: int_mu, int_coulomb
|
||||
double precision :: wall0, wall1
|
||||
double precision :: NAI_pol_mult_erf_ao
|
||||
|
||||
print *, ' providing v_ij_erf_rk_cst_mu_transp ...'
|
||||
|
||||
provide mu_erf final_grid_points
|
||||
call wall_time(wall0)
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,ipoint,r,int_mu,int_coulomb) &
|
||||
!$OMP SHARED (ao_num,n_points_final_grid,v_ij_erf_rk_cst_mu_transp,final_grid_points,mu_erf)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do ipoint = 1, n_points_final_grid
|
||||
r(1) = final_grid_points(1,ipoint)
|
||||
r(2) = final_grid_points(2,ipoint)
|
||||
r(3) = final_grid_points(3,ipoint)
|
||||
|
||||
do i = 1, ao_num
|
||||
do j = i, ao_num
|
||||
int_mu = NAI_pol_mult_erf_ao(i, j, mu_erf, r)
|
||||
int_coulomb = NAI_pol_mult_erf_ao(i, j, 1.d+9, r)
|
||||
|
||||
v_ij_erf_rk_cst_mu_transp(ipoint,j,i) = int_mu - int_coulomb
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
do i = 2, ao_num
|
||||
do j = 1, i-1
|
||||
do ipoint = 1, n_points_final_grid
|
||||
v_ij_erf_rk_cst_mu_transp(ipoint,j,i) = v_ij_erf_rk_cst_mu_transp(ipoint,i,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
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)]
|
||||
|
||||
BEGIN_DOC
|
||||
! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/|r - R|
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint
|
||||
double precision :: r(3), ints(3), ints_coulomb(3)
|
||||
double precision :: wall0, wall1
|
||||
|
||||
print*, ' providing x_v_ij_erf_rk_cst_mu_tmp ...'
|
||||
|
||||
call wall_time(wall0)
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,ipoint,r,ints,ints_coulomb) &
|
||||
!$OMP SHARED (ao_num,n_points_final_grid,x_v_ij_erf_rk_cst_mu_tmp,final_grid_points,mu_erf)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do ipoint = 1, n_points_final_grid
|
||||
r(1) = final_grid_points(1,ipoint)
|
||||
r(2) = final_grid_points(2,ipoint)
|
||||
r(3) = final_grid_points(3,ipoint)
|
||||
|
||||
do i = 1, ao_num
|
||||
do j = i, ao_num
|
||||
|
||||
call NAI_pol_x_mult_erf_ao(i, j, mu_erf, r, ints )
|
||||
call NAI_pol_x_mult_erf_ao(i, j, 1.d+9 , r, ints_coulomb)
|
||||
|
||||
x_v_ij_erf_rk_cst_mu_tmp(1,j,i,ipoint) = ints(1) - ints_coulomb(1)
|
||||
x_v_ij_erf_rk_cst_mu_tmp(2,j,i,ipoint) = ints(2) - ints_coulomb(2)
|
||||
x_v_ij_erf_rk_cst_mu_tmp(3,j,i,ipoint) = ints(3) - ints_coulomb(3)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 2, ao_num
|
||||
do j = 1, i-1
|
||||
x_v_ij_erf_rk_cst_mu_tmp(1,j,i,ipoint) = x_v_ij_erf_rk_cst_mu_tmp(1,i,j,ipoint)
|
||||
x_v_ij_erf_rk_cst_mu_tmp(2,j,i,ipoint) = x_v_ij_erf_rk_cst_mu_tmp(2,i,j,ipoint)
|
||||
x_v_ij_erf_rk_cst_mu_tmp(3,j,i,ipoint) = x_v_ij_erf_rk_cst_mu_tmp(3,i,j,ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
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)]
|
||||
|
||||
BEGIN_DOC
|
||||
! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/|r - R|
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint
|
||||
double precision :: wall0, wall1
|
||||
|
||||
print *, ' providing x_v_ij_erf_rk_cst_mu ...'
|
||||
|
||||
call wall_time(wall0)
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
x_v_ij_erf_rk_cst_mu(j,i,ipoint,1) = x_v_ij_erf_rk_cst_mu_tmp(1,j,i,ipoint)
|
||||
x_v_ij_erf_rk_cst_mu(j,i,ipoint,2) = x_v_ij_erf_rk_cst_mu_tmp(2,j,i,ipoint)
|
||||
x_v_ij_erf_rk_cst_mu(j,i,ipoint,3) = x_v_ij_erf_rk_cst_mu_tmp(3,j,i,ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for x_v_ij_erf_rk_cst_mu = ', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_transp, (ao_num, ao_num,3,n_points_final_grid)]
|
||||
|
||||
BEGIN_DOC
|
||||
! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/|r - R|
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint
|
||||
double precision :: wall0, wall1
|
||||
|
||||
print *, ' providing x_v_ij_erf_rk_cst_mu_transp ...'
|
||||
|
||||
call wall_time(wall0)
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
x_v_ij_erf_rk_cst_mu_transp(j,i,1,ipoint) = x_v_ij_erf_rk_cst_mu_tmp(1,j,i,ipoint)
|
||||
x_v_ij_erf_rk_cst_mu_transp(j,i,2,ipoint) = x_v_ij_erf_rk_cst_mu_tmp(2,j,i,ipoint)
|
||||
x_v_ij_erf_rk_cst_mu_transp(j,i,3,ipoint) = x_v_ij_erf_rk_cst_mu_tmp(3,j,i,ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for x_v_ij_erf_rk_cst_mu_transp = ', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_transp_bis, (n_points_final_grid, ao_num, ao_num, 3)]
|
||||
|
||||
BEGIN_DOC
|
||||
! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/|r - R|
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint
|
||||
double precision :: wall0, wall1
|
||||
|
||||
print *, ' providing x_v_ij_erf_rk_cst_mu_transp_bis ...'
|
||||
|
||||
call wall_time(wall0)
|
||||
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
x_v_ij_erf_rk_cst_mu_transp_bis(ipoint,j,i,1) = x_v_ij_erf_rk_cst_mu_tmp(1,j,i,ipoint)
|
||||
x_v_ij_erf_rk_cst_mu_transp_bis(ipoint,j,i,2) = x_v_ij_erf_rk_cst_mu_tmp(2,j,i,ipoint)
|
||||
x_v_ij_erf_rk_cst_mu_transp_bis(ipoint,j,i,3) = x_v_ij_erf_rk_cst_mu_tmp(3,j,i,ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for x_v_ij_erf_rk_cst_mu_transp_bis = ', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, d_dx_v_ij_erf_rk_cst_mu_tmp, (3, n_points_final_grid, ao_num, ao_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
! d_dx_v_ij_erf_rk_cst_mu_tmp(m,R,j,i) = int dr phi_j(r)) (erf(mu(R) |r - R|) - 1)/|r - R| d/dx (phi_i(r)
|
||||
!
|
||||
! with m == 1 -> d/dx , m == 2 -> d/dy , m == 3 -> d/dz
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint
|
||||
double precision :: r(3), ints(3), ints_coulomb(3)
|
||||
double precision :: wall0, wall1
|
||||
|
||||
print *, ' providing d_dx_v_ij_erf_rk_cst_mu_tmp ...'
|
||||
|
||||
call wall_time(wall0)
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,ipoint,r,ints,ints_coulomb) &
|
||||
!$OMP SHARED (ao_num,n_points_final_grid,d_dx_v_ij_erf_rk_cst_mu_tmp,final_grid_points,mu_erf)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do ipoint = 1, n_points_final_grid
|
||||
r(1) = final_grid_points(1,ipoint)
|
||||
r(2) = final_grid_points(2,ipoint)
|
||||
r(3) = final_grid_points(3,ipoint)
|
||||
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
call phi_j_erf_mu_r_dxyz_phi(j, i, mu_erf, r, ints)
|
||||
call phi_j_erf_mu_r_dxyz_phi(j, i, 1.d+9, r, ints_coulomb)
|
||||
|
||||
d_dx_v_ij_erf_rk_cst_mu_tmp(1,ipoint,j,i) = ints(1) - ints_coulomb(1)
|
||||
d_dx_v_ij_erf_rk_cst_mu_tmp(2,ipoint,j,i) = ints(2) - ints_coulomb(2)
|
||||
d_dx_v_ij_erf_rk_cst_mu_tmp(3,ipoint,j,i) = ints(3) - ints_coulomb(3)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$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)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! d_dx_v_ij_erf_rk_cst_mu_tmp(j,i,R,m) = int dr phi_j(r)) (erf(mu(R) |r - R|) - 1)/|r - R| d/dx (phi_i(r)
|
||||
!
|
||||
! with m == 1 -> d/dx , m == 2 -> d/dy , m == 3 -> d/dz
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint
|
||||
double precision :: wall0, wall1
|
||||
|
||||
print *, ' providing d_dx_v_ij_erf_rk_cst_mu ...'
|
||||
|
||||
call wall_time(wall0)
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
d_dx_v_ij_erf_rk_cst_mu(ipoint,j,i,1) = d_dx_v_ij_erf_rk_cst_mu_tmp(1,ipoint,j,i)
|
||||
d_dx_v_ij_erf_rk_cst_mu(ipoint,j,i,2) = d_dx_v_ij_erf_rk_cst_mu_tmp(2,ipoint,j,i)
|
||||
d_dx_v_ij_erf_rk_cst_mu(ipoint,j,i,3) = d_dx_v_ij_erf_rk_cst_mu_tmp(3,ipoint,j,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
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)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! x_d_dx_v_ij_erf_rk_cst_mu_tmp(m,j,i,R) = int dr x phi_j(r)) (erf(mu(R) |r - R|) - 1)/|r - R| d/dx (phi_i(r)
|
||||
!
|
||||
! with m == 1 -> d/dx , m == 2 -> d/dy , m == 3 -> d/dz
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint
|
||||
double precision :: r(3), ints(3), ints_coulomb(3)
|
||||
double precision :: wall0, wall1
|
||||
|
||||
print *, ' providing x_d_dx_v_ij_erf_rk_cst_mu_tmp ...'
|
||||
|
||||
call wall_time(wall0)
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,ipoint,r,ints,ints_coulomb) &
|
||||
!$OMP SHARED (ao_num,n_points_final_grid,x_d_dx_v_ij_erf_rk_cst_mu_tmp,final_grid_points,mu_erf)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do ipoint = 1, n_points_final_grid
|
||||
r(1) = final_grid_points(1,ipoint)
|
||||
r(2) = final_grid_points(2,ipoint)
|
||||
r(3) = final_grid_points(3,ipoint)
|
||||
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
call phi_j_erf_mu_r_xyz_dxyz_phi(j, i, mu_erf, r, ints)
|
||||
call phi_j_erf_mu_r_xyz_dxyz_phi(j, i, 1.d+9, r, ints_coulomb)
|
||||
|
||||
x_d_dx_v_ij_erf_rk_cst_mu_tmp(1,ipoint,j,i) = ints(1) - ints_coulomb(1)
|
||||
x_d_dx_v_ij_erf_rk_cst_mu_tmp(2,ipoint,j,i) = ints(2) - ints_coulomb(2)
|
||||
x_d_dx_v_ij_erf_rk_cst_mu_tmp(3,ipoint,j,i) = ints(3) - ints_coulomb(3)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$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)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! x_d_dx_v_ij_erf_rk_cst_mu_tmp(j,i,R,m) = int dr x phi_j(r)) (erf(mu(R) |r - R|) - 1)/|r - R| d/dx (phi_i(r)
|
||||
!
|
||||
! with m == 1 -> d/dx , m == 2 -> d/dy , m == 3 -> d/dz
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint
|
||||
double precision :: wall0, wall1
|
||||
|
||||
print *, ' providing x_d_dx_v_ij_erf_rk_cst_mu ...'
|
||||
|
||||
call wall_time(wall0)
|
||||
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
x_d_dx_v_ij_erf_rk_cst_mu(ipoint,j,i,1) = x_d_dx_v_ij_erf_rk_cst_mu_tmp(1,ipoint,j,i)
|
||||
x_d_dx_v_ij_erf_rk_cst_mu(ipoint,j,i,2) = x_d_dx_v_ij_erf_rk_cst_mu_tmp(2,ipoint,j,i)
|
||||
x_d_dx_v_ij_erf_rk_cst_mu(ipoint,j,i,3) = x_d_dx_v_ij_erf_rk_cst_mu_tmp(3,ipoint,j,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for x_d_dx_v_ij_erf_rk_cst_mu = ', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
|
||||
59
src/ao_many_one_e_ints/list_grid.irp.f
Normal file
59
src/ao_many_one_e_ints/list_grid.irp.f
Normal file
@ -0,0 +1,59 @@
|
||||
BEGIN_PROVIDER [ integer, n_pts_grid_ao_prod, (ao_num, ao_num)]
|
||||
&BEGIN_PROVIDER [ integer, max_n_pts_grid_ao_prod]
|
||||
implicit none
|
||||
integer :: i,j,ipoint
|
||||
double precision :: overlap, r(3),thr, overlap_abs_gauss_r12_ao,overlap_gauss_r12_ao
|
||||
double precision :: sigma,dist,center_ij(3),fact_gauss, alpha, center(3)
|
||||
n_pts_grid_ao_prod = 0
|
||||
thr = 1.d-11
|
||||
print*,' expo_good_j_mu_1gauss = ',expo_good_j_mu_1gauss
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, i, j, r, overlap, fact_gauss, alpha, center,dist,sigma,center_ij) &
|
||||
!$OMP SHARED (n_points_final_grid, ao_num, thr, ao_overlap_abs_grid,n_pts_grid_ao_prod,expo_good_j_mu_1gauss,&
|
||||
!$OMP final_grid_points,ao_prod_center,ao_prod_sigma,ao_nucl)
|
||||
!$OMP DO
|
||||
do i = 1, ao_num
|
||||
! do i = 3,3
|
||||
do j = 1, ao_num
|
||||
! do i = 22,22
|
||||
! do j = 9,9
|
||||
center_ij(1:3) = ao_prod_center(1:3,j,i)
|
||||
sigma = ao_prod_sigma(j,i)
|
||||
sigma *= sigma
|
||||
sigma = 0.5d0 /sigma
|
||||
! if(dabs(ao_overlap_abs_grid(j,i)).lt.1.d-10)cycle
|
||||
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)
|
||||
dist = (center_ij(1) - r(1))*(center_ij(1) - r(1))
|
||||
dist += (center_ij(2) - r(2))*(center_ij(2) - r(2))
|
||||
dist += (center_ij(3) - r(3))*(center_ij(3) - r(3))
|
||||
dist = dsqrt(dist)
|
||||
call gaussian_product(sigma, center_ij, expo_good_j_mu_1gauss, r, fact_gauss, alpha, center)
|
||||
! print*,''
|
||||
! print*,j,i,ao_overlap_abs_grid(j,i),ao_overlap_abs(j,i)
|
||||
! print*,r
|
||||
! print*,dist,sigma
|
||||
! print*,fact_gauss
|
||||
if( fact_gauss*ao_overlap_abs_grid(j,i).lt.1.d-11)cycle
|
||||
if(ao_nucl(i) == ao_nucl(j))then
|
||||
overlap = overlap_abs_gauss_r12_ao(r, expo_good_j_mu_1gauss, i, j)
|
||||
else
|
||||
overlap = overlap_gauss_r12_ao(r, expo_good_j_mu_1gauss, i, j)
|
||||
endif
|
||||
! print*,overlap
|
||||
if(dabs(overlap).lt.thr)cycle
|
||||
n_pts_grid_ao_prod(j,i) += 1
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
integer :: list(ao_num)
|
||||
do i = 1, ao_num
|
||||
list(i) = maxval(n_pts_grid_ao_prod(:,i))
|
||||
enddo
|
||||
max_n_pts_grid_ao_prod = maxval(list)
|
||||
END_PROVIDER
|
||||
237
src/ao_many_one_e_ints/listj1b.irp.f
Normal file
237
src/ao_many_one_e_ints/listj1b.irp.f
Normal file
@ -0,0 +1,237 @@
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ integer, List_all_comb_b2_size]
|
||||
|
||||
implicit none
|
||||
|
||||
List_all_comb_b2_size = 2**nucl_num
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ integer, List_all_comb_b2, (nucl_num, List_all_comb_b2_size)]
|
||||
|
||||
implicit none
|
||||
integer :: i, j
|
||||
|
||||
if(nucl_num .gt. 32) then
|
||||
print *, ' nucl_num = ', nucl_num, '> 32'
|
||||
stop
|
||||
endif
|
||||
|
||||
List_all_comb_b2 = 0
|
||||
|
||||
do i = 0, List_all_comb_b2_size-1
|
||||
do j = 0, nucl_num-1
|
||||
if (btest(i,j)) then
|
||||
List_all_comb_b2(j+1,i+1) = 1
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, List_all_comb_b2_coef, ( List_all_comb_b2_size)]
|
||||
&BEGIN_PROVIDER [ double precision, List_all_comb_b2_expo, ( List_all_comb_b2_size)]
|
||||
&BEGIN_PROVIDER [ double precision, List_all_comb_b2_cent, (3, List_all_comb_b2_size)]
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, phase
|
||||
double precision :: tmp_alphaj, tmp_alphak
|
||||
double precision :: tmp_cent_x, tmp_cent_y, tmp_cent_z
|
||||
|
||||
provide j1b_pen
|
||||
|
||||
List_all_comb_b2_coef = 0.d0
|
||||
List_all_comb_b2_expo = 0.d0
|
||||
List_all_comb_b2_cent = 0.d0
|
||||
|
||||
do i = 1, List_all_comb_b2_size
|
||||
|
||||
tmp_cent_x = 0.d0
|
||||
tmp_cent_y = 0.d0
|
||||
tmp_cent_z = 0.d0
|
||||
do j = 1, nucl_num
|
||||
tmp_alphaj = dble(List_all_comb_b2(j,i)) * j1b_pen(j)
|
||||
List_all_comb_b2_expo(i) += tmp_alphaj
|
||||
tmp_cent_x += tmp_alphaj * nucl_coord(j,1)
|
||||
tmp_cent_y += tmp_alphaj * nucl_coord(j,2)
|
||||
tmp_cent_z += tmp_alphaj * nucl_coord(j,3)
|
||||
enddo
|
||||
|
||||
if(List_all_comb_b2_expo(i) .lt. 1d-10) cycle
|
||||
|
||||
List_all_comb_b2_cent(1,i) = tmp_cent_x / List_all_comb_b2_expo(i)
|
||||
List_all_comb_b2_cent(2,i) = tmp_cent_y / List_all_comb_b2_expo(i)
|
||||
List_all_comb_b2_cent(3,i) = tmp_cent_z / List_all_comb_b2_expo(i)
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
do i = 1, List_all_comb_b2_size
|
||||
|
||||
do j = 2, nucl_num, 1
|
||||
tmp_alphaj = dble(List_all_comb_b2(j,i)) * j1b_pen(j)
|
||||
do k = 1, j-1, 1
|
||||
tmp_alphak = dble(List_all_comb_b2(k,i)) * j1b_pen(k)
|
||||
|
||||
List_all_comb_b2_coef(i) += tmp_alphaj * tmp_alphak * ( (nucl_coord(j,1) - nucl_coord(k,1)) * (nucl_coord(j,1) - nucl_coord(k,1)) &
|
||||
+ (nucl_coord(j,2) - nucl_coord(k,2)) * (nucl_coord(j,2) - nucl_coord(k,2)) &
|
||||
+ (nucl_coord(j,3) - nucl_coord(k,3)) * (nucl_coord(j,3) - nucl_coord(k,3)) )
|
||||
enddo
|
||||
enddo
|
||||
|
||||
if(List_all_comb_b2_expo(i) .lt. 1d-10) cycle
|
||||
|
||||
List_all_comb_b2_coef(i) = List_all_comb_b2_coef(i) / List_all_comb_b2_expo(i)
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
do i = 1, List_all_comb_b2_size
|
||||
|
||||
phase = 0
|
||||
do j = 1, nucl_num
|
||||
phase += List_all_comb_b2(j,i)
|
||||
enddo
|
||||
|
||||
List_all_comb_b2_coef(i) = (-1.d0)**dble(phase) * dexp(-List_all_comb_b2_coef(i))
|
||||
enddo
|
||||
|
||||
print *, ' coeff, expo & cent of list b2'
|
||||
do i = 1, List_all_comb_b2_size
|
||||
print*, i, List_all_comb_b2_coef(i), List_all_comb_b2_expo(i)
|
||||
print*, List_all_comb_b2_cent(1,i), List_all_comb_b2_cent(2,i), List_all_comb_b2_cent(3,i)
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ integer, List_all_comb_b3_size]
|
||||
|
||||
implicit none
|
||||
|
||||
List_all_comb_b3_size = 3**nucl_num
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ integer, List_all_comb_b3, (nucl_num, List_all_comb_b3_size)]
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ii, jj
|
||||
integer, allocatable :: M(:,:), p(:)
|
||||
|
||||
if(nucl_num .gt. 32) then
|
||||
print *, ' nucl_num = ', nucl_num, '> 32'
|
||||
stop
|
||||
endif
|
||||
|
||||
List_all_comb_b3(:,:) = 0
|
||||
List_all_comb_b3(:,List_all_comb_b3_size) = 2
|
||||
|
||||
allocate(p(nucl_num))
|
||||
p = 0
|
||||
|
||||
do i = 2, List_all_comb_b3_size-1
|
||||
do j = 1, nucl_num
|
||||
|
||||
ii = 0
|
||||
do jj = 1, j-1, 1
|
||||
ii = ii + p(jj) * 3**(jj-1)
|
||||
enddo
|
||||
p(j) = modulo(i-1-ii, 3**j) / 3**(j-1)
|
||||
|
||||
List_all_comb_b3(j,i) = p(j)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, List_all_comb_b3_coef, ( List_all_comb_b3_size)]
|
||||
&BEGIN_PROVIDER [ double precision, List_all_comb_b3_expo, ( List_all_comb_b3_size)]
|
||||
&BEGIN_PROVIDER [ double precision, List_all_comb_b3_cent, (3, List_all_comb_b3_size)]
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, phase
|
||||
double precision :: tmp_alphaj, tmp_alphak, facto
|
||||
|
||||
provide j1b_pen
|
||||
|
||||
List_all_comb_b3_coef = 0.d0
|
||||
List_all_comb_b3_expo = 0.d0
|
||||
List_all_comb_b3_cent = 0.d0
|
||||
|
||||
do i = 1, List_all_comb_b3_size
|
||||
|
||||
do j = 1, nucl_num
|
||||
tmp_alphaj = dble(List_all_comb_b3(j,i)) * j1b_pen(j)
|
||||
List_all_comb_b3_expo(i) += tmp_alphaj
|
||||
List_all_comb_b3_cent(1,i) += tmp_alphaj * nucl_coord(j,1)
|
||||
List_all_comb_b3_cent(2,i) += tmp_alphaj * nucl_coord(j,2)
|
||||
List_all_comb_b3_cent(3,i) += tmp_alphaj * nucl_coord(j,3)
|
||||
|
||||
enddo
|
||||
|
||||
if(List_all_comb_b3_expo(i) .lt. 1d-10) cycle
|
||||
ASSERT(List_all_comb_b3_expo(i) .gt. 0d0)
|
||||
|
||||
List_all_comb_b3_cent(1,i) = List_all_comb_b3_cent(1,i) / List_all_comb_b3_expo(i)
|
||||
List_all_comb_b3_cent(2,i) = List_all_comb_b3_cent(2,i) / List_all_comb_b3_expo(i)
|
||||
List_all_comb_b3_cent(3,i) = List_all_comb_b3_cent(3,i) / List_all_comb_b3_expo(i)
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
do i = 1, List_all_comb_b3_size
|
||||
|
||||
do j = 2, nucl_num, 1
|
||||
tmp_alphaj = dble(List_all_comb_b3(j,i)) * j1b_pen(j)
|
||||
do k = 1, j-1, 1
|
||||
tmp_alphak = dble(List_all_comb_b3(k,i)) * j1b_pen(k)
|
||||
|
||||
List_all_comb_b3_coef(i) += tmp_alphaj * tmp_alphak * ( (nucl_coord(j,1) - nucl_coord(k,1)) * (nucl_coord(j,1) - nucl_coord(k,1)) &
|
||||
+ (nucl_coord(j,2) - nucl_coord(k,2)) * (nucl_coord(j,2) - nucl_coord(k,2)) &
|
||||
+ (nucl_coord(j,3) - nucl_coord(k,3)) * (nucl_coord(j,3) - nucl_coord(k,3)) )
|
||||
enddo
|
||||
enddo
|
||||
|
||||
if(List_all_comb_b3_expo(i) .lt. 1d-10) cycle
|
||||
|
||||
List_all_comb_b3_coef(i) = List_all_comb_b3_coef(i) / List_all_comb_b3_expo(i)
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
do i = 1, List_all_comb_b3_size
|
||||
|
||||
facto = 1.d0
|
||||
phase = 0
|
||||
do j = 1, nucl_num
|
||||
tmp_alphaj = dble(List_all_comb_b3(j,i))
|
||||
|
||||
facto *= 2.d0 / (gamma(tmp_alphaj+1.d0) * gamma(3.d0-tmp_alphaj))
|
||||
phase += List_all_comb_b3(j,i)
|
||||
enddo
|
||||
|
||||
List_all_comb_b3_coef(i) = (-1.d0)**dble(phase) * facto * dexp(-List_all_comb_b3_coef(i))
|
||||
enddo
|
||||
|
||||
print *, ' coeff, expo & cent of list b3'
|
||||
do i = 1, List_all_comb_b3_size
|
||||
print*, i, List_all_comb_b3_coef(i), List_all_comb_b3_expo(i)
|
||||
print*, List_all_comb_b3_cent(1,i), List_all_comb_b3_cent(2,i), List_all_comb_b3_cent(3,i)
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
191
src/ao_many_one_e_ints/listj1b_sorted.irp.f
Normal file
191
src/ao_many_one_e_ints/listj1b_sorted.irp.f
Normal file
@ -0,0 +1,191 @@
|
||||
|
||||
BEGIN_PROVIDER [ integer, List_comb_thr_b2_size, (ao_num, ao_num)]
|
||||
&BEGIN_PROVIDER [ integer, max_List_comb_thr_b2_size]
|
||||
implicit none
|
||||
integer :: i_1s,i,j,ipoint
|
||||
double precision :: coef,beta,center(3),int_j1b,thr
|
||||
double precision :: r(3),weight,dist
|
||||
thr = 1.d-15
|
||||
List_comb_thr_b2_size = 0
|
||||
do i = 1, ao_num
|
||||
do j = i, ao_num
|
||||
do i_1s = 1, List_all_comb_b2_size
|
||||
coef = List_all_comb_b2_coef (i_1s)
|
||||
if(dabs(coef).lt.1.d-15)cycle
|
||||
beta = List_all_comb_b2_expo (i_1s)
|
||||
beta = max(beta,1.d-12)
|
||||
center(1:3) = List_all_comb_b2_cent(1:3,i_1s)
|
||||
int_j1b = 0.d0
|
||||
do ipoint = 1, n_points_extra_final_grid
|
||||
r(1:3) = final_grid_points_extra(1:3,ipoint)
|
||||
weight = final_weight_at_r_vector_extra(ipoint)
|
||||
dist = ( center(1) - r(1) )*( center(1) - r(1) )
|
||||
dist += ( center(2) - r(2) )*( center(2) - r(2) )
|
||||
dist += ( center(3) - r(3) )*( center(3) - r(3) )
|
||||
int_j1b += dabs(aos_in_r_array_extra_transp(ipoint,i) * aos_in_r_array_extra_transp(ipoint,j))*dexp(-beta*dist) * weight
|
||||
enddo
|
||||
if(dabs(coef)*dabs(int_j1b).gt.thr)then
|
||||
List_comb_thr_b2_size(j,i) += 1
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
do i = 1, ao_num
|
||||
do j = 1, i-1
|
||||
List_comb_thr_b2_size(j,i) = List_comb_thr_b2_size(i,j)
|
||||
enddo
|
||||
enddo
|
||||
integer :: list(ao_num)
|
||||
do i = 1, ao_num
|
||||
list(i) = maxval(List_comb_thr_b2_size(:,i))
|
||||
enddo
|
||||
max_List_comb_thr_b2_size = maxval(list)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, List_comb_thr_b2_coef, ( max_List_comb_thr_b2_size,ao_num, ao_num )]
|
||||
&BEGIN_PROVIDER [ double precision, List_comb_thr_b2_expo, ( max_List_comb_thr_b2_size,ao_num, ao_num )]
|
||||
&BEGIN_PROVIDER [ double precision, List_comb_thr_b2_cent, (3, max_List_comb_thr_b2_size,ao_num, ao_num )]
|
||||
&BEGIN_PROVIDER [ double precision, ao_abs_comb_b2_j1b, ( max_List_comb_thr_b2_size ,ao_num, ao_num)]
|
||||
implicit none
|
||||
integer :: i_1s,i,j,ipoint,icount
|
||||
double precision :: coef,beta,center(3),int_j1b,thr
|
||||
double precision :: r(3),weight,dist
|
||||
thr = 1.d-15
|
||||
ao_abs_comb_b2_j1b = 10000000.d0
|
||||
do i = 1, ao_num
|
||||
do j = i, ao_num
|
||||
icount = 0
|
||||
do i_1s = 1, List_all_comb_b2_size
|
||||
coef = List_all_comb_b2_coef (i_1s)
|
||||
if(dabs(coef).lt.1.d-12)cycle
|
||||
beta = List_all_comb_b2_expo (i_1s)
|
||||
center(1:3) = List_all_comb_b2_cent(1:3,i_1s)
|
||||
int_j1b = 0.d0
|
||||
do ipoint = 1, n_points_extra_final_grid
|
||||
r(1:3) = final_grid_points_extra(1:3,ipoint)
|
||||
weight = final_weight_at_r_vector_extra(ipoint)
|
||||
dist = ( center(1) - r(1) )*( center(1) - r(1) )
|
||||
dist += ( center(2) - r(2) )*( center(2) - r(2) )
|
||||
dist += ( center(3) - r(3) )*( center(3) - r(3) )
|
||||
int_j1b += dabs(aos_in_r_array_extra_transp(ipoint,i) * aos_in_r_array_extra_transp(ipoint,j))*dexp(-beta*dist) * weight
|
||||
enddo
|
||||
if(dabs(coef)*dabs(int_j1b).gt.thr)then
|
||||
icount += 1
|
||||
List_comb_thr_b2_coef(icount,j,i) = coef
|
||||
List_comb_thr_b2_expo(icount,j,i) = beta
|
||||
List_comb_thr_b2_cent(1:3,icount,j,i) = center(1:3)
|
||||
ao_abs_comb_b2_j1b(icount,j,i) = int_j1b
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do i = 1, ao_num
|
||||
do j = 1, i-1
|
||||
do icount = 1, List_comb_thr_b2_size(j,i)
|
||||
List_comb_thr_b2_coef(icount,j,i) = List_comb_thr_b2_coef(icount,i,j)
|
||||
List_comb_thr_b2_expo(icount,j,i) = List_comb_thr_b2_expo(icount,i,j)
|
||||
List_comb_thr_b2_cent(1:3,icount,j,i) = List_comb_thr_b2_cent(1:3,icount,i,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ integer, List_comb_thr_b3_size, (ao_num, ao_num)]
|
||||
&BEGIN_PROVIDER [ integer, max_List_comb_thr_b3_size]
|
||||
implicit none
|
||||
integer :: i_1s,i,j,ipoint
|
||||
double precision :: coef,beta,center(3),int_j1b,thr
|
||||
double precision :: r(3),weight,dist
|
||||
thr = 1.d-15
|
||||
List_comb_thr_b3_size = 0
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
do i_1s = 1, List_all_comb_b3_size
|
||||
coef = List_all_comb_b3_coef (i_1s)
|
||||
beta = List_all_comb_b3_expo (i_1s)
|
||||
center(1:3) = List_all_comb_b3_cent(1:3,i_1s)
|
||||
if(dabs(coef).lt.thr)cycle
|
||||
int_j1b = 0.d0
|
||||
do ipoint = 1, n_points_extra_final_grid
|
||||
r(1:3) = final_grid_points_extra(1:3,ipoint)
|
||||
weight = final_weight_at_r_vector_extra(ipoint)
|
||||
dist = ( center(1) - r(1) )*( center(1) - r(1) )
|
||||
dist += ( center(2) - r(2) )*( center(2) - r(2) )
|
||||
dist += ( center(3) - r(3) )*( center(3) - r(3) )
|
||||
int_j1b += dabs(aos_in_r_array_extra_transp(ipoint,i) * aos_in_r_array_extra_transp(ipoint,j))*dexp(-beta*dist) * weight
|
||||
enddo
|
||||
if(dabs(coef)*dabs(int_j1b).gt.thr)then
|
||||
List_comb_thr_b3_size(j,i) += 1
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
! do i = 1, ao_num
|
||||
! do j = 1, i-1
|
||||
! List_comb_thr_b3_size(j,i) = List_comb_thr_b3_size(i,j)
|
||||
! enddo
|
||||
! enddo
|
||||
integer :: list(ao_num)
|
||||
do i = 1, ao_num
|
||||
list(i) = maxval(List_comb_thr_b3_size(:,i))
|
||||
enddo
|
||||
max_List_comb_thr_b3_size = maxval(list)
|
||||
print*,'max_List_comb_thr_b3_size = ',max_List_comb_thr_b3_size
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, List_comb_thr_b3_coef, ( max_List_comb_thr_b3_size,ao_num, ao_num )]
|
||||
&BEGIN_PROVIDER [ double precision, List_comb_thr_b3_expo, ( max_List_comb_thr_b3_size,ao_num, ao_num )]
|
||||
&BEGIN_PROVIDER [ double precision, List_comb_thr_b3_cent, (3, max_List_comb_thr_b3_size,ao_num, ao_num )]
|
||||
&BEGIN_PROVIDER [ double precision, ao_abs_comb_b3_j1b, ( max_List_comb_thr_b3_size ,ao_num, ao_num)]
|
||||
implicit none
|
||||
integer :: i_1s,i,j,ipoint,icount
|
||||
double precision :: coef,beta,center(3),int_j1b,thr
|
||||
double precision :: r(3),weight,dist
|
||||
thr = 1.d-15
|
||||
ao_abs_comb_b3_j1b = 10000000.d0
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
icount = 0
|
||||
do i_1s = 1, List_all_comb_b3_size
|
||||
coef = List_all_comb_b3_coef (i_1s)
|
||||
beta = List_all_comb_b3_expo (i_1s)
|
||||
beta = max(beta,1.d-12)
|
||||
center(1:3) = List_all_comb_b3_cent(1:3,i_1s)
|
||||
if(dabs(coef).lt.thr)cycle
|
||||
int_j1b = 0.d0
|
||||
do ipoint = 1, n_points_extra_final_grid
|
||||
r(1:3) = final_grid_points_extra(1:3,ipoint)
|
||||
weight = final_weight_at_r_vector_extra(ipoint)
|
||||
dist = ( center(1) - r(1) )*( center(1) - r(1) )
|
||||
dist += ( center(2) - r(2) )*( center(2) - r(2) )
|
||||
dist += ( center(3) - r(3) )*( center(3) - r(3) )
|
||||
int_j1b += dabs(aos_in_r_array_extra_transp(ipoint,i) * aos_in_r_array_extra_transp(ipoint,j))*dexp(-beta*dist) * weight
|
||||
enddo
|
||||
if(dabs(coef)*dabs(int_j1b).gt.thr)then
|
||||
icount += 1
|
||||
List_comb_thr_b3_coef(icount,j,i) = coef
|
||||
List_comb_thr_b3_expo(icount,j,i) = beta
|
||||
List_comb_thr_b3_cent(1:3,icount,j,i) = center(1:3)
|
||||
ao_abs_comb_b3_j1b(icount,j,i) = int_j1b
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! do i = 1, ao_num
|
||||
! do j = 1, i-1
|
||||
! do icount = 1, List_comb_thr_b3_size(j,i)
|
||||
! List_comb_thr_b3_coef(icount,j,i) = List_comb_thr_b3_coef(icount,i,j)
|
||||
! List_comb_thr_b3_expo(icount,j,i) = List_comb_thr_b3_expo(icount,i,j)
|
||||
! List_comb_thr_b3_cent(1:3,icount,j,i) = List_comb_thr_b3_cent(1:3,icount,i,j)
|
||||
! enddo
|
||||
! enddo
|
||||
! enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
195
src/ao_many_one_e_ints/prim_int_erf_gauss.irp.f
Normal file
195
src/ao_many_one_e_ints/prim_int_erf_gauss.irp.f
Normal file
@ -0,0 +1,195 @@
|
||||
double precision function NAI_pol_mult_erf_gauss_r12(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta,C_center,mu)
|
||||
BEGIN_DOC
|
||||
! Computes the following integral R^3 :
|
||||
!
|
||||
! .. math::
|
||||
!
|
||||
! \int dr (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
|
||||
! \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$ exp(-delta (r - D)^2 ).
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
include 'constants.include.F'
|
||||
double precision, intent(in) :: D_center(3), delta ! pure gaussian "D"
|
||||
double precision, intent(in) :: C_center(3),mu ! coulomb center "C" and "mu" in the erf(mu*x)/x function
|
||||
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
|
||||
integer, intent(in) :: power_A(3),power_B(3)
|
||||
|
||||
double precision :: NAI_pol_mult_erf
|
||||
! First you multiply the usual gaussian "A" with the gaussian exp(-delta (r - D)^2 )
|
||||
double precision :: A_new(0:max_dim,3)! new polynom
|
||||
double precision :: A_center_new(3) ! new center
|
||||
integer :: iorder_a_new(3) ! i_order(i) = order of the new polynom ==> should be equal to power_A
|
||||
double precision :: alpha_new ! new exponent
|
||||
double precision :: fact_a_new ! constant factor
|
||||
double precision :: accu,coefx,coefy,coefz,coefxy,coefxyz,thr
|
||||
integer :: d(3),i,lx,ly,lz,iorder_tmp(3)
|
||||
thr = 1.d-10
|
||||
d = 0 ! order of the polynom for the gaussian exp(-delta (r - D)^2 ) == 0
|
||||
|
||||
! New gaussian/polynom defined by :: new pol new center new expo cst fact new order
|
||||
call give_explicit_poly_and_gaussian(A_new , A_center_new , alpha_new, fact_a_new , iorder_a_new , &
|
||||
delta,alpha,d,power_A,D_center,A_center,n_pt_max_integrals)
|
||||
! The new gaussian exp(-delta (r - D)^2 ) (x-A_x)^a \exp(-\alpha (x-A_x)^2
|
||||
accu = 0.d0
|
||||
do lx = 0, iorder_a_new(1)
|
||||
coefx = A_new(lx,1)
|
||||
if(dabs(coefx).lt.thr)cycle
|
||||
iorder_tmp(1) = lx
|
||||
do ly = 0, iorder_a_new(2)
|
||||
coefy = A_new(ly,2)
|
||||
coefxy = coefx * coefy
|
||||
if(dabs(coefxy).lt.thr)cycle
|
||||
iorder_tmp(2) = ly
|
||||
do lz = 0, iorder_a_new(3)
|
||||
coefz = A_new(lz,3)
|
||||
coefxyz = coefxy * coefz
|
||||
if(dabs(coefxyz).lt.thr)cycle
|
||||
iorder_tmp(3) = lz
|
||||
accu += coefxyz * NAI_pol_mult_erf(A_center_new,B_center,iorder_tmp,power_B,alpha_new,beta,C_center,n_pt_max_integrals,mu)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
NAI_pol_mult_erf_gauss_r12 = fact_a_new * accu
|
||||
end
|
||||
|
||||
subroutine erfc_mu_gauss_xyz(D_center,delta,mu,A_center,B_center,power_A,power_B,alpha,beta,n_pt_in,xyz_ints)
|
||||
BEGIN_DOC
|
||||
! Computes the following integral :
|
||||
!
|
||||
! .. math::
|
||||
!
|
||||
! \int dr exp(-delta (r - D)^2 ) x/y/z * (1 - erf(mu |r-r'|))/ |r-r'| * (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
|
||||
!
|
||||
! xyz_ints(1) = x , xyz_ints(2) = y, xyz_ints(3) = z, xyz_ints(4) = x^0
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
include 'constants.include.F'
|
||||
double precision, intent(in) :: D_center(3), delta,mu ! pure gaussian "D" and mu parameter
|
||||
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
|
||||
integer, intent(in) :: power_A(3),power_B(3),n_pt_in
|
||||
double precision, intent(out) :: xyz_ints(4)
|
||||
|
||||
double precision :: NAI_pol_mult_erf
|
||||
! First you multiply the usual gaussian "A" with the gaussian exp(-delta (r - D)^2 )
|
||||
double precision :: A_new(0:max_dim,3)! new polynom
|
||||
double precision :: A_center_new(3) ! new center
|
||||
integer :: iorder_a_new(3) ! i_order(i) = order of the new polynom ==> should be equal to power_A
|
||||
double precision :: alpha_new ! new exponent
|
||||
double precision :: fact_a_new ! constant factor
|
||||
double precision :: accu,coefx,coefy,coefz,coefxy,coefxyz,thr,contrib,contrib_inf,mu_inf
|
||||
integer :: d(3),i,lx,ly,lz,iorder_tmp(3),dim1,mm
|
||||
integer :: power_B_tmp(3)
|
||||
dim1=100
|
||||
mu_inf = 1.d+10
|
||||
thr = 1.d-10
|
||||
d = 0 ! order of the polynom for the gaussian exp(-delta (r - D)^2 ) == 0
|
||||
|
||||
! New gaussian/polynom defined by :: new pol new center new expo cst fact new order
|
||||
call give_explicit_poly_and_gaussian(A_new , A_center_new , alpha_new, fact_a_new , iorder_a_new , &
|
||||
delta,alpha,d,power_A,D_center,A_center,n_pt_max_integrals)
|
||||
! The new gaussian exp(-delta (r - D)^2 ) (x-A_x)^a \exp(-\alpha (x-A_x)^2
|
||||
xyz_ints = 0.d0
|
||||
do lx = 0, iorder_a_new(1)
|
||||
coefx = A_new(lx,1)
|
||||
if(dabs(coefx).lt.thr)cycle
|
||||
iorder_tmp(1) = lx
|
||||
do ly = 0, iorder_a_new(2)
|
||||
coefy = A_new(ly,2)
|
||||
coefxy = coefx * coefy
|
||||
if(dabs(coefxy).lt.thr)cycle
|
||||
iorder_tmp(2) = ly
|
||||
do lz = 0, iorder_a_new(3)
|
||||
coefz = A_new(lz,3)
|
||||
coefxyz = coefxy * coefz
|
||||
if(dabs(coefxyz).lt.thr)cycle
|
||||
iorder_tmp(3) = lz
|
||||
power_B_tmp = power_B
|
||||
contrib = NAI_pol_mult_erf(A_center_new,B_center,iorder_tmp,power_B_tmp,alpha_new,beta,D_center,n_pt_in,mu)
|
||||
contrib_inf = NAI_pol_mult_erf(A_center_new,B_center,iorder_tmp,power_B_tmp,alpha_new,beta,D_center,n_pt_in,mu_inf)
|
||||
xyz_ints(4) += (contrib_inf - contrib) * coefxyz ! usual term with no x/y/z
|
||||
|
||||
do mm = 1, 3
|
||||
! (x phi_i ) * phi_j
|
||||
! x * (x - B_x)^b_x = B_x (x - B_x)^b_x + 1 * (x - B_x)^{b_x+1}
|
||||
|
||||
!
|
||||
! first contribution :: B_x (x - B_x)^b_x :: usual integral multiplied by B_x
|
||||
power_B_tmp = power_B
|
||||
contrib_inf = NAI_pol_mult_erf(A_center_new,B_center,iorder_tmp,power_B_tmp,alpha_new,beta,D_center,n_pt_in,mu_inf)
|
||||
contrib = NAI_pol_mult_erf(A_center_new,B_center,iorder_tmp,power_B_tmp,alpha_new,beta,D_center,n_pt_in,mu)
|
||||
xyz_ints(mm) += (contrib_inf - contrib) * B_center(mm) * coefxyz
|
||||
|
||||
!
|
||||
! second contribution :: (x - B_x)^(b_x+1) :: integral with b_x=>b_x+1
|
||||
power_B_tmp(mm) += 1
|
||||
contrib = NAI_pol_mult_erf(A_center_new,B_center,iorder_tmp,power_B_tmp,alpha_new,beta,D_center,n_pt_in,mu)
|
||||
contrib_inf = NAI_pol_mult_erf(A_center_new,B_center,iorder_tmp,power_B_tmp,alpha_new,beta,D_center,n_pt_in,mu_inf)
|
||||
xyz_ints(mm) += (contrib_inf - contrib) * coefxyz
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
xyz_ints *= fact_a_new
|
||||
end
|
||||
|
||||
|
||||
double precision function erf_mu_gauss(D_center,delta,mu,A_center,B_center,power_A,power_B,alpha,beta,n_pt_in)
|
||||
BEGIN_DOC
|
||||
! Computes the following integral :
|
||||
!
|
||||
! .. math::
|
||||
!
|
||||
! \int dr exp(-delta (r - D)^2 ) erf(mu*|r-r'|)/ |r-r'| * (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
include 'constants.include.F'
|
||||
double precision, intent(in) :: D_center(3), delta,mu ! pure gaussian "D" and mu parameter
|
||||
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
|
||||
integer, intent(in) :: power_A(3),power_B(3),n_pt_in
|
||||
|
||||
double precision :: NAI_pol_mult_erf
|
||||
! First you multiply the usual gaussian "A" with the gaussian exp(-delta (r - D)^2 )
|
||||
double precision :: A_new(0:max_dim,3)! new polynom
|
||||
double precision :: A_center_new(3) ! new center
|
||||
integer :: iorder_a_new(3) ! i_order(i) = order of the new polynom ==> should be equal to power_A
|
||||
double precision :: alpha_new ! new exponent
|
||||
double precision :: fact_a_new ! constant factor
|
||||
double precision :: accu,coefx,coefy,coefz,coefxy,coefxyz,thr,contrib,contrib_inf,mu_inf
|
||||
integer :: d(3),i,lx,ly,lz,iorder_tmp(3),dim1,mm
|
||||
dim1=100
|
||||
mu_inf = 1.d+10
|
||||
thr = 1.d-10
|
||||
d = 0 ! order of the polynom for the gaussian exp(-delta (r - D)^2 ) == 0
|
||||
|
||||
! New gaussian/polynom defined by :: new pol new center new expo cst fact new order
|
||||
call give_explicit_poly_and_gaussian(A_new , A_center_new , alpha_new, fact_a_new , iorder_a_new , &
|
||||
delta,alpha,d,power_A,D_center,A_center,n_pt_max_integrals)
|
||||
! The new gaussian exp(-delta (r - D)^2 ) (x-A_x)^a \exp(-\alpha (x-A_x)^2
|
||||
erf_mu_gauss = 0.d0
|
||||
do lx = 0, iorder_a_new(1)
|
||||
coefx = A_new(lx,1)
|
||||
if(dabs(coefx).lt.thr)cycle
|
||||
iorder_tmp(1) = lx
|
||||
do ly = 0, iorder_a_new(2)
|
||||
coefy = A_new(ly,2)
|
||||
coefxy = coefx * coefy
|
||||
if(dabs(coefxy).lt.thr)cycle
|
||||
iorder_tmp(2) = ly
|
||||
do lz = 0, iorder_a_new(3)
|
||||
coefz = A_new(lz,3)
|
||||
coefxyz = coefxy * coefz
|
||||
if(dabs(coefxyz).lt.thr)cycle
|
||||
iorder_tmp(3) = lz
|
||||
contrib = NAI_pol_mult_erf(A_center_new,B_center,iorder_tmp,power_B,alpha_new,beta,D_center,n_pt_in,mu)
|
||||
erf_mu_gauss += contrib * coefxyz
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
erf_mu_gauss *= fact_a_new
|
||||
end
|
||||
|
||||
340
src/ao_many_one_e_ints/prim_int_gauss_gauss.irp.f
Normal file
340
src/ao_many_one_e_ints/prim_int_gauss_gauss.irp.f
Normal file
@ -0,0 +1,340 @@
|
||||
! ---
|
||||
|
||||
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
|
||||
|
||||
include 'constants.include.F'
|
||||
|
||||
implicit none
|
||||
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
|
||||
overlap_gauss_r12 = 0.d0
|
||||
|
||||
! 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)
|
||||
if(fact_a_new.lt.thr)return
|
||||
! 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)*fact_a_new
|
||||
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 = accu
|
||||
end
|
||||
|
||||
!---
|
||||
double precision function overlap_abs_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,dx,lower_exp_val
|
||||
integer :: d(3),i,lx,ly,lz,iorder_tmp(3),dim1
|
||||
dim1=50
|
||||
lower_exp_val = 40.d0
|
||||
thr = 1.d-12
|
||||
d(:) = 0 ! order of the polynom for the gaussian exp(-delta (r - D)^2 ) == 0
|
||||
overlap_abs_gauss_r12 = 0.d0
|
||||
|
||||
! 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)
|
||||
if(fact_a_new.lt.thr)return
|
||||
! 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)*fact_a_new
|
||||
! 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_x_abs(A_center_new(1),B_center(1),alpha_new,beta,iorder_tmp(1),power_B(1),overlap_x,lower_exp_val,dx,dim1)
|
||||
call overlap_x_abs(A_center_new(2),B_center(2),alpha_new,beta,iorder_tmp(2),power_B(2),overlap_y,lower_exp_val,dx,dim1)
|
||||
call overlap_x_abs(A_center_new(3),B_center(3),alpha_new,beta,iorder_tmp(3),power_B(3),overlap_z,lower_exp_val,dx,dim1)
|
||||
accu += dabs(coefxyz * overlap_x * overlap_y * overlap_z)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
overlap_abs_gauss_r12= accu
|
||||
end
|
||||
|
||||
!---
|
||||
|
||||
! TODO apply Gaussian product three times first
|
||||
subroutine overlap_gauss_r12_v(D_center, LD_D, delta, A_center, B_center, power_A, power_B, alpha, beta, rvec, LD_rvec, n_points)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! Computes the following integral :
|
||||
!
|
||||
! \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)
|
||||
! using an array of D_centers
|
||||
!
|
||||
! n_points: nb of integrals
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
include 'constants.include.F'
|
||||
|
||||
integer, intent(in) :: LD_D, LD_rvec, n_points
|
||||
integer, intent(in) :: power_A(3), power_B(3)
|
||||
double precision, intent(in) :: D_center(LD_D,3), delta
|
||||
double precision, intent(in) :: A_center(3), B_center(3), alpha, beta
|
||||
double precision, intent(out) :: rvec(LD_rvec)
|
||||
|
||||
integer :: maxab
|
||||
integer :: d(3), i, lx, ly, lz, iorder_tmp(3), ipoint
|
||||
double precision :: overlap_x, overlap_y, overlap_z
|
||||
double precision :: alpha_new
|
||||
double precision :: accu, thr, coefxy
|
||||
integer, allocatable :: iorder_a_new(:)
|
||||
double precision, allocatable :: overlap(:)
|
||||
double precision, allocatable :: A_new(:,:,:), A_center_new(:,:)
|
||||
double precision, allocatable :: fact_a_new(:)
|
||||
|
||||
thr = 1.d-10
|
||||
d(:) = 0
|
||||
|
||||
maxab = maxval(power_A(1:3))
|
||||
|
||||
allocate(A_new(n_points,0:maxab,3), A_center_new(n_points,3), fact_a_new(n_points), iorder_a_new(3), overlap(n_points))
|
||||
|
||||
call give_explicit_poly_and_gaussian_v(A_new, maxab, A_center_new, alpha_new, fact_a_new, iorder_a_new, delta, alpha, d, power_A, D_center, LD_D, A_center, n_points)
|
||||
|
||||
rvec(:) = 0.d0
|
||||
|
||||
do lx = 0, iorder_a_new(1)
|
||||
iorder_tmp(1) = lx
|
||||
|
||||
do ly = 0, iorder_a_new(2)
|
||||
iorder_tmp(2) = ly
|
||||
|
||||
do lz = 0, iorder_a_new(3)
|
||||
iorder_tmp(3) = lz
|
||||
|
||||
call overlap_gaussian_xyz_v(A_center_new, B_center, alpha_new, beta, iorder_tmp, power_B, overlap, n_points)
|
||||
|
||||
do ipoint = 1, n_points
|
||||
rvec(ipoint) = rvec(ipoint) + A_new(ipoint,lx,1) * A_new(ipoint,ly,2) * A_new(ipoint,lz,3) * overlap(ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do ipoint = 1, n_points
|
||||
rvec(ipoint) = rvec(ipoint) * fact_a_new(ipoint)
|
||||
enddo
|
||||
|
||||
deallocate(A_new, A_center_new, fact_a_new, iorder_a_new, overlap)
|
||||
|
||||
end subroutine overlap_gauss_r12_v
|
||||
|
||||
!---
|
||||
|
||||
subroutine overlap_gauss_xyz_r12(D_center, delta, A_center, B_center, power_A, power_B, alpha, beta, gauss_ints)
|
||||
|
||||
BEGIN_DOC
|
||||
! Computes the following integral :
|
||||
!
|
||||
! .. math::
|
||||
!
|
||||
! gauss_ints(m) = \int dr exp(-delta (r - D)^2 ) * x/y/z (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
|
||||
!
|
||||
! with m == 1 ==> x, m == 2 ==> y, m == 3 ==> z
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
include 'constants.include.F'
|
||||
double precision, intent(in) :: D_center(3), delta ! pure gaussian "D"
|
||||
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
|
||||
integer, intent(in) :: power_A(3),power_B(3)
|
||||
double precision, intent(out) :: gauss_ints(3)
|
||||
|
||||
double precision :: overlap_x,overlap_y,overlap_z,overlap
|
||||
! First you multiply the usual gaussian "A" with the gaussian exp(-delta (r - D)^2 )
|
||||
double precision :: A_new(0:max_dim,3)! new polynom
|
||||
double precision :: A_center_new(3) ! new center
|
||||
integer :: iorder_a_new(3) ! i_order(i) = order of the new polynom ==> should be equal to power_A
|
||||
integer :: power_B_new(3)
|
||||
double precision :: alpha_new ! new exponent
|
||||
double precision :: fact_a_new ! constant factor
|
||||
double precision :: coefx,coefy,coefz,coefxy,coefxyz,thr
|
||||
integer :: d(3),i,lx,ly,lz,iorder_tmp(3),dim1,m
|
||||
dim1=100
|
||||
thr = 1.d-10
|
||||
d = 0 ! order of the polynom for the gaussian exp(-delta (r - D)^2 ) == 0
|
||||
|
||||
! New gaussian/polynom defined by :: new pol new center new expo cst fact new order
|
||||
call give_explicit_poly_and_gaussian(A_new , A_center_new , alpha_new, fact_a_new , iorder_a_new , &
|
||||
delta,alpha,d,power_A,D_center,A_center,n_pt_max_integrals)
|
||||
! The new gaussian exp(-delta (r - D)^2 ) (x-A_x)^a \exp(-\alpha (x-A_x)^2
|
||||
gauss_ints = 0.d0
|
||||
do lx = 0, iorder_a_new(1)
|
||||
coefx = A_new(lx,1)
|
||||
if(dabs(coefx).lt.thr)cycle
|
||||
iorder_tmp(1) = lx
|
||||
do ly = 0, iorder_a_new(2)
|
||||
coefy = A_new(ly,2)
|
||||
coefxy = coefx * coefy
|
||||
if(dabs(coefxy).lt.thr)cycle
|
||||
iorder_tmp(2) = ly
|
||||
do lz = 0, iorder_a_new(3)
|
||||
coefz = A_new(lz,3)
|
||||
coefxyz = coefxy * coefz
|
||||
if(dabs(coefxyz).lt.thr)cycle
|
||||
iorder_tmp(3) = lz
|
||||
do m = 1, 3
|
||||
! change (x-Bx)^bx --> (x-Bx)^(bx+1) + Bx(x-Bx)^bx
|
||||
power_B_new = power_B
|
||||
power_B_new(m) += 1 ! (x-Bx)^(bx+1)
|
||||
call overlap_gaussian_xyz(A_center_new,B_center,alpha_new,beta,iorder_tmp,power_B_new,overlap_x,overlap_y,overlap_z,overlap,dim1)
|
||||
gauss_ints(m) += coefxyz * overlap
|
||||
|
||||
power_B_new = power_B
|
||||
call overlap_gaussian_xyz(A_center_new,B_center,alpha_new,beta,iorder_tmp,power_B_new,overlap_x,overlap_y,overlap_z,overlap,dim1)
|
||||
gauss_ints(m) += coefxyz * overlap * B_center(m) ! Bx (x-Bx)^(bx)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
gauss_ints *= fact_a_new
|
||||
end
|
||||
|
||||
double precision function overlap_gauss_xyz_r12_specific(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta,mx)
|
||||
BEGIN_DOC
|
||||
! Computes the following integral :
|
||||
!
|
||||
! .. math::
|
||||
!
|
||||
! \int dr exp(-delta (r - D)^2 ) * x/y/z (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
|
||||
!
|
||||
! with mx == 1 ==> x, mx == 2 ==> y, mx == 3 ==> z
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
include 'constants.include.F'
|
||||
double precision, intent(in) :: D_center(3), delta ! pure gaussian "D"
|
||||
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
|
||||
integer, intent(in) :: power_A(3),power_B(3),mx
|
||||
|
||||
double precision :: overlap_x,overlap_y,overlap_z,overlap
|
||||
! First you multiply the usual gaussian "A" with the gaussian exp(-delta (r - D)^2 )
|
||||
double precision :: A_new(0:max_dim,3)! new polynom
|
||||
double precision :: A_center_new(3) ! new center
|
||||
integer :: iorder_a_new(3) ! i_order(i) = order of the new polynom ==> should be equal to power_A
|
||||
integer :: power_B_new(3)
|
||||
double precision :: alpha_new ! new exponent
|
||||
double precision :: fact_a_new ! constant factor
|
||||
double precision :: coefx,coefy,coefz,coefxy,coefxyz,thr
|
||||
integer :: d(3),i,lx,ly,lz,iorder_tmp(3),dim1,m
|
||||
dim1=100
|
||||
thr = 1.d-10
|
||||
d = 0 ! order of the polynom for the gaussian exp(-delta (r - D)^2 ) == 0
|
||||
|
||||
! New gaussian/polynom defined by :: new pol new center new expo cst fact new order
|
||||
call give_explicit_poly_and_gaussian(A_new , A_center_new , alpha_new, fact_a_new , iorder_a_new , &
|
||||
delta,alpha,d,power_A,D_center,A_center,n_pt_max_integrals)
|
||||
! The new gaussian exp(-delta (r - D)^2 ) (x-A_x)^a \exp(-\alpha (x-A_x)^2
|
||||
overlap_gauss_xyz_r12_specific = 0.d0
|
||||
do lx = 0, iorder_a_new(1)
|
||||
coefx = A_new(lx,1)
|
||||
if(dabs(coefx).lt.thr)cycle
|
||||
iorder_tmp(1) = lx
|
||||
do ly = 0, iorder_a_new(2)
|
||||
coefy = A_new(ly,2)
|
||||
coefxy = coefx * coefy
|
||||
if(dabs(coefxy).lt.thr)cycle
|
||||
iorder_tmp(2) = ly
|
||||
do lz = 0, iorder_a_new(3)
|
||||
coefz = A_new(lz,3)
|
||||
coefxyz = coefxy * coefz
|
||||
if(dabs(coefxyz).lt.thr)cycle
|
||||
iorder_tmp(3) = lz
|
||||
m = mx
|
||||
! change (x-Bx)^bx --> (x-Bx)^(bx+1) + Bx(x-Bx)^bx
|
||||
power_B_new = power_B
|
||||
power_B_new(m) += 1 ! (x-Bx)^(bx+1)
|
||||
call overlap_gaussian_xyz(A_center_new,B_center,alpha_new,beta,iorder_tmp,power_B_new,overlap_x,overlap_y,overlap_z,overlap,dim1)
|
||||
overlap_gauss_xyz_r12_specific += coefxyz * overlap
|
||||
|
||||
power_B_new = power_B
|
||||
call overlap_gaussian_xyz(A_center_new,B_center,alpha_new,beta,iorder_tmp,power_B_new,overlap_x,overlap_y,overlap_z,overlap,dim1)
|
||||
overlap_gauss_xyz_r12_specific += coefxyz * overlap * B_center(m) ! Bx (x-Bx)^(bx)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
overlap_gauss_xyz_r12_specific *= fact_a_new
|
||||
end
|
||||
121
src/ao_many_one_e_ints/stg_gauss_int.irp.f
Normal file
121
src/ao_many_one_e_ints/stg_gauss_int.irp.f
Normal file
@ -0,0 +1,121 @@
|
||||
double precision function ovlp_stg_gauss_int_phi_ij(D_center,gam,delta,A_center,B_center,power_A,power_B,alpha,beta)
|
||||
BEGIN_DOC
|
||||
! Computes the following integral :
|
||||
!
|
||||
! .. math::
|
||||
!
|
||||
! \int dr exp(-gam (r - D)) exp(-delta * (r -D)^2) (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
double precision, intent(in) :: D_center(3), gam ! pure Slater "D" in r-r_D
|
||||
double precision, intent(in) :: delta ! gaussian in r-r_D
|
||||
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
|
||||
integer, intent(in) :: power_A(3),power_B(3)
|
||||
|
||||
integer :: i
|
||||
double precision :: integral,gama_gauss
|
||||
double precision, allocatable :: expos_slat(:)
|
||||
allocate(expos_slat(n_max_fit_slat))
|
||||
double precision :: overlap_gauss_r12
|
||||
ovlp_stg_gauss_int_phi_ij = 0.d0
|
||||
call expo_fit_slater_gam(gam,expos_slat)
|
||||
do i = 1, n_max_fit_slat
|
||||
gama_gauss = expos_slat(i)+delta
|
||||
integral = overlap_gauss_r12(D_center,gama_gauss,A_center,B_center,power_A,power_B,alpha,beta)
|
||||
ovlp_stg_gauss_int_phi_ij += coef_fit_slat_gauss(i) * integral
|
||||
enddo
|
||||
end
|
||||
|
||||
|
||||
double precision function erf_mu_stg_gauss_int_phi_ij(D_center,gam,delta,A_center,B_center,power_A,power_B,alpha,beta,C_center,mu)
|
||||
BEGIN_DOC
|
||||
! Computes the following integral :
|
||||
!
|
||||
! .. math::
|
||||
!
|
||||
! \int dr exp(-gam(r - D)-delta(r - D)^2) (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
|
||||
! \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
include 'constants.include.F'
|
||||
double precision, intent(in) :: D_center(3), gam ! pure Slater "D" in r-r_D
|
||||
double precision, intent(in) :: delta ! gaussian in r-r_D
|
||||
double precision, intent(in) :: C_center(3),mu ! coulomb center "C" and "mu" in the erf(mu*x)/x function
|
||||
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
|
||||
integer, intent(in) :: power_A(3),power_B(3)
|
||||
|
||||
integer :: i
|
||||
double precision :: NAI_pol_mult_erf_gauss_r12
|
||||
double precision :: integral,gama_gauss
|
||||
double precision, allocatable :: expos_slat(:)
|
||||
allocate(expos_slat(n_max_fit_slat))
|
||||
erf_mu_stg_gauss_int_phi_ij = 0.d0
|
||||
call expo_fit_slater_gam(gam,expos_slat)
|
||||
do i = 1, n_max_fit_slat
|
||||
gama_gauss = expos_slat(i) + delta
|
||||
integral = NAI_pol_mult_erf_gauss_r12(D_center,gama_gauss,A_center,B_center,power_A,power_B,alpha,beta,C_center,mu)
|
||||
erf_mu_stg_gauss_int_phi_ij += coef_fit_slat_gauss(i) * integral
|
||||
enddo
|
||||
end
|
||||
|
||||
double precision function overlap_stg_gauss(D_center,gam,A_center,B_center,power_A,power_B,alpha,beta)
|
||||
BEGIN_DOC
|
||||
! Computes the following integral :
|
||||
!
|
||||
! .. math::
|
||||
!
|
||||
! \int dr exp(-gam (r - D)) (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
double precision, intent(in) :: D_center(3), gam ! pure Slater "D"
|
||||
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
|
||||
integer, intent(in) :: power_A(3),power_B(3)
|
||||
|
||||
integer :: i
|
||||
double precision :: expos_slat(n_max_fit_slat),integral,delta
|
||||
double precision :: overlap_gauss_r12
|
||||
overlap_stg_gauss = 0.d0
|
||||
call expo_fit_slater_gam(gam,expos_slat)
|
||||
do i = 1, n_max_fit_slat
|
||||
delta = expos_slat(i)
|
||||
integral = overlap_gauss_r12(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta)
|
||||
overlap_stg_gauss += coef_fit_slat_gauss(i) * integral
|
||||
enddo
|
||||
end
|
||||
|
||||
double precision function erf_mu_stg_gauss(D_center,gam,A_center,B_center,power_A,power_B,alpha,beta,C_center,mu)
|
||||
BEGIN_DOC
|
||||
! Computes the following integral :
|
||||
!
|
||||
! .. math::
|
||||
!
|
||||
! \int dr exp(-gam(r - D)) (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
|
||||
! \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
include 'constants.include.F'
|
||||
double precision, intent(in) :: D_center(3), gam ! pure Slater "D"
|
||||
double precision, intent(in) :: C_center(3),mu ! coulomb center "C" and "mu" in the erf(mu*x)/x function
|
||||
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
|
||||
integer, intent(in) :: power_A(3),power_B(3)
|
||||
|
||||
|
||||
integer :: i
|
||||
double precision :: expos_slat(n_max_fit_slat),integral,delta
|
||||
double precision :: NAI_pol_mult_erf_gauss_r12
|
||||
erf_mu_stg_gauss = 0.d0
|
||||
call expo_fit_slater_gam(gam,expos_slat)
|
||||
do i = 1, n_max_fit_slat
|
||||
delta = expos_slat(i)
|
||||
integral = NAI_pol_mult_erf_gauss_r12(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta,C_center,mu)
|
||||
erf_mu_stg_gauss += coef_fit_slat_gauss(i) * integral
|
||||
enddo
|
||||
end
|
||||
101
src/ao_many_one_e_ints/taylor_exp.irp.f
Normal file
101
src/ao_many_one_e_ints/taylor_exp.irp.f
Normal file
@ -0,0 +1,101 @@
|
||||
double precision function exp_dl(x,n)
|
||||
implicit none
|
||||
double precision, intent(in) :: x
|
||||
integer , intent(in) :: n
|
||||
integer :: i
|
||||
exp_dl = 1.d0
|
||||
do i = 1, n
|
||||
exp_dl += fact_inv(i) * x**dble(i)
|
||||
enddo
|
||||
end
|
||||
|
||||
subroutine exp_dl_rout(x,n, array)
|
||||
implicit none
|
||||
double precision, intent(in) :: x
|
||||
integer , intent(in) :: n
|
||||
double precision, intent(out):: array(0:n)
|
||||
integer :: i
|
||||
double precision :: accu
|
||||
accu = 1.d0
|
||||
array(0) = 1.d0
|
||||
do i = 1, n
|
||||
accu += fact_inv(i) * x**dble(i)
|
||||
array(i) = accu
|
||||
enddo
|
||||
end
|
||||
|
||||
subroutine exp_dl_ovlp_stg_phi_ij(zeta,D_center,gam,delta,A_center,B_center,power_A,power_B,alpha,beta,n_taylor,array_ints,integral_taylor,exponent_exp)
|
||||
BEGIN_DOC
|
||||
! Computes the following integrals :
|
||||
!
|
||||
! .. math::
|
||||
!
|
||||
! array(i) = \int dr EXP{exponent_exp * [exp(-gam*i (r - D)) exp(-delta*i * (r -D)^2)] (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
|
||||
!
|
||||
!
|
||||
! and gives back the Taylor expansion of the exponential in integral_taylor
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
double precision, intent(in) :: zeta ! prefactor of the argument of the exp(-zeta*x)
|
||||
integer, intent(in) :: n_taylor ! order of the Taylor expansion of the exponential
|
||||
double precision, intent(in) :: D_center(3), gam ! pure Slater "D" in r-r_D
|
||||
double precision, intent(in) :: delta ! gaussian in r-r_D
|
||||
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
|
||||
double precision, intent(in) :: exponent_exp
|
||||
integer, intent(in) :: power_A(3),power_B(3)
|
||||
double precision, intent(out) :: array_ints(0:n_taylor),integral_taylor
|
||||
|
||||
integer :: i,dim1
|
||||
double precision :: delta_exp,gam_exp,ovlp_stg_gauss_int_phi_ij
|
||||
double precision :: overlap_x,overlap_y,overlap_z,overlap
|
||||
dim1=100
|
||||
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x,overlap_y,overlap_z,overlap,dim1)
|
||||
array_ints(0) = overlap
|
||||
integral_taylor = array_ints(0)
|
||||
do i = 1, n_taylor
|
||||
delta_exp = dble(i) * delta
|
||||
gam_exp = dble(i) * gam
|
||||
array_ints(i) = ovlp_stg_gauss_int_phi_ij(D_center,gam_exp,delta_exp,A_center,B_center,power_A,power_B,alpha,beta)
|
||||
integral_taylor += (-zeta*exponent_exp)**dble(i) * fact_inv(i) * array_ints(i)
|
||||
enddo
|
||||
|
||||
end
|
||||
|
||||
subroutine exp_dl_erf_stg_phi_ij(zeta,D_center,gam,delta,A_center,B_center,power_A,power_B,alpha,beta,C_center,mu,n_taylor,array_ints,integral_taylor)
|
||||
BEGIN_DOC
|
||||
! Computes the following integrals :
|
||||
!
|
||||
! .. math::
|
||||
!
|
||||
! array(i) = \int dr exp(-gam*i (r - D)) exp(-delta*i * (r -D)^2) (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
|
||||
! \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
|
||||
!
|
||||
!
|
||||
! and gives back the Taylor expansion of the exponential in integral_taylor
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: n_taylor ! order of the Taylor expansion of the exponential
|
||||
double precision, intent(in) :: zeta ! prefactor of the argument of the exp(-zeta*x)
|
||||
double precision, intent(in) :: D_center(3), gam ! pure Slater "D" in r-r_D
|
||||
double precision, intent(in) :: delta ! gaussian in r-r_D
|
||||
double precision, intent(in) :: C_center(3),mu ! coulomb center "C" and "mu" in the erf(mu*x)/x function
|
||||
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
|
||||
integer, intent(in) :: power_A(3),power_B(3)
|
||||
double precision, intent(out) :: array_ints(0:n_taylor),integral_taylor
|
||||
|
||||
integer :: i,dim1
|
||||
double precision :: delta_exp,gam_exp,NAI_pol_mult_erf,erf_mu_stg_gauss_int_phi_ij
|
||||
dim1=100
|
||||
|
||||
array_ints(0) = NAI_pol_mult_erf(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_max_integrals,mu)
|
||||
integral_taylor = array_ints(0)
|
||||
do i = 1, n_taylor
|
||||
delta_exp = dble(i) * delta
|
||||
gam_exp = dble(i) * gam
|
||||
array_ints(i) = erf_mu_stg_gauss_int_phi_ij(D_center,gam_exp,delta_exp,A_center,B_center,power_A,power_B,alpha,beta,C_center,mu)
|
||||
integral_taylor += (-zeta)**dble(i) * fact_inv(i) * array_ints(i)
|
||||
enddo
|
||||
|
||||
end
|
||||
343
src/ao_many_one_e_ints/xyz_grad_xyz_ao_pol.irp.f
Normal file
343
src/ao_many_one_e_ints/xyz_grad_xyz_ao_pol.irp.f
Normal file
@ -0,0 +1,343 @@
|
||||
BEGIN_PROVIDER [double precision, coef_xyz_ao, (2,3,ao_num)]
|
||||
&BEGIN_PROVIDER [integer, power_xyz_ao, (2,3,ao_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! coefficient for the basis function :: (x * phi_i(r), y * phi_i(r), * z_phi(r))
|
||||
!
|
||||
! x * (x - A_x)^a_x = A_x (x - A_x)^a_x + 1 * (x - A_x)^{a_x+1}
|
||||
END_DOC
|
||||
integer :: i,j,k,num_ao,power_ao(1:3)
|
||||
double precision :: center_ao(1:3)
|
||||
do i = 1, ao_num
|
||||
power_ao(1:3)= ao_power(i,1:3)
|
||||
num_ao = ao_nucl(i)
|
||||
center_ao(1:3) = nucl_coord(num_ao,1:3)
|
||||
do j = 1, 3
|
||||
coef_xyz_ao(1,j,i) = center_ao(j) ! A_x (x - A_x)^a_x
|
||||
power_xyz_ao(1,j,i)= power_ao(j)
|
||||
coef_xyz_ao(2,j,i) = 1.d0 ! 1 * (x - A_x)^a_{x+1}
|
||||
power_xyz_ao(2,j,i)= power_ao(j) + 1
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, ao_coef_ord_grad_transp, (2,3,ao_prim_num_max,ao_num) ]
|
||||
&BEGIN_PROVIDER [ integer, power_ord_grad_transp, (2,3,ao_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! grad AO in terms of polynoms and coefficients
|
||||
!
|
||||
! WARNING !!!! SOME polynoms might be negative !!!!!
|
||||
!
|
||||
! WHEN IT IS THE CASE, coefficients are ZERO
|
||||
END_DOC
|
||||
integer :: i,j,power_ao(3), m,kk
|
||||
do j=1, ao_num
|
||||
power_ao(1:3)= ao_power(j,1:3)
|
||||
do m = 1, 3
|
||||
power_ord_grad_transp(1,m,j) = power_ao(m) - 1
|
||||
power_ord_grad_transp(2,m,j) = power_ao(m) + 1
|
||||
enddo
|
||||
do i=1, ao_prim_num_max
|
||||
do m = 1, 3
|
||||
ao_coef_ord_grad_transp(1,m,i,j) = ao_coef_normalized_ordered(j,i) * dble(power_ao(m)) ! a_x * c_i
|
||||
ao_coef_ord_grad_transp(2,m,i,j) = -2.d0 * ao_coef_normalized_ordered(j,i) * ao_expo_ordered_transp(i,j) ! -2 * c_i * alpha_i
|
||||
do kk = 1, 2
|
||||
if(power_ord_grad_transp(kk,m,j).lt.0)then
|
||||
ao_coef_ord_grad_transp(kk,m,i,j) = 0.d0
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, ao_coef_ord_xyz_grad_transp, (4,3,ao_prim_num_max,ao_num) ]
|
||||
&BEGIN_PROVIDER [ integer, power_ord_xyz_grad_transp, (4,3,ao_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! x * d/dx of an AO in terms of polynoms and coefficients
|
||||
!
|
||||
! WARNING !!!! SOME polynoms might be negative !!!!!
|
||||
!
|
||||
! WHEN IT IS THE CASE, coefficients are ZERO
|
||||
END_DOC
|
||||
integer :: i,j,power_ao(3), m,num_ao,kk
|
||||
double precision :: center_ao(1:3)
|
||||
do j=1, ao_num
|
||||
power_ao(1:3)= ao_power(j,1:3)
|
||||
num_ao = ao_nucl(j)
|
||||
center_ao(1:3) = nucl_coord(num_ao,1:3)
|
||||
do m = 1, 3
|
||||
power_ord_xyz_grad_transp(1,m,j) = power_ao(m) - 1
|
||||
power_ord_xyz_grad_transp(2,m,j) = power_ao(m)
|
||||
power_ord_xyz_grad_transp(3,m,j) = power_ao(m) + 1
|
||||
power_ord_xyz_grad_transp(4,m,j) = power_ao(m) + 2
|
||||
do kk = 1, 4
|
||||
if(power_ord_xyz_grad_transp(kk,m,j).lt.0)then
|
||||
power_ord_xyz_grad_transp(kk,m,j) = -1
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
do i=1, ao_prim_num_max
|
||||
do m = 1, 3
|
||||
ao_coef_ord_xyz_grad_transp(1,m,i,j) = dble(power_ao(m)) * ao_coef_normalized_ordered(j,i) * center_ao(m)
|
||||
ao_coef_ord_xyz_grad_transp(2,m,i,j) = dble(power_ao(m)) * ao_coef_normalized_ordered(j,i)
|
||||
ao_coef_ord_xyz_grad_transp(3,m,i,j) = -2.d0 * ao_coef_normalized_ordered(j,i) * ao_expo_ordered_transp(i,j) * center_ao(m)
|
||||
ao_coef_ord_xyz_grad_transp(4,m,i,j) = -2.d0 * ao_coef_normalized_ordered(j,i) * ao_expo_ordered_transp(i,j)
|
||||
do kk = 1, 4
|
||||
if(power_ord_xyz_grad_transp(kk,m,j).lt.0)then
|
||||
ao_coef_ord_xyz_grad_transp(kk,m,i,j) = 0.d0
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
subroutine xyz_grad_phi_ao(r,i_ao,xyz_grad_phi)
|
||||
implicit none
|
||||
integer, intent(in) :: i_ao
|
||||
double precision, intent(in) :: r(3)
|
||||
double precision, intent(out):: xyz_grad_phi(3) ! x * d/dx phi i, y * d/dy phi_i, z * d/dz phi_
|
||||
double precision :: center_ao(3),beta
|
||||
double precision :: accu(3,4),dr(3),r2,pol_usual(3)
|
||||
integer :: m,power_ao(3),num_ao,j_prim
|
||||
power_ao(1:3)= ao_power(i_ao,1:3)
|
||||
num_ao = ao_nucl(i_ao)
|
||||
center_ao(1:3) = nucl_coord(num_ao,1:3)
|
||||
dr(1) = (r(1) - center_ao(1))
|
||||
dr(2) = (r(2) - center_ao(2))
|
||||
dr(3) = (r(3) - center_ao(3))
|
||||
r2 = 0.d0
|
||||
do m = 1, 3
|
||||
r2 += dr(m)*dr(m)
|
||||
enddo
|
||||
! computes the gaussian part
|
||||
accu = 0.d0
|
||||
do j_prim =1,ao_prim_num(i_ao)
|
||||
beta = ao_expo_ordered_transp(j_prim,i_ao)
|
||||
if(dabs(beta*r2).gt.50.d0)cycle
|
||||
do m = 1, 3
|
||||
accu(m,1) += ao_coef_ord_xyz_grad_transp(1,m,j_prim,i_ao) * dexp(-beta*r2)
|
||||
accu(m,2) += ao_coef_ord_xyz_grad_transp(2,m,j_prim,i_ao) * dexp(-beta*r2)
|
||||
accu(m,3) += ao_coef_ord_xyz_grad_transp(3,m,j_prim,i_ao) * dexp(-beta*r2)
|
||||
accu(m,4) += ao_coef_ord_xyz_grad_transp(4,m,j_prim,i_ao) * dexp(-beta*r2)
|
||||
enddo
|
||||
enddo
|
||||
! computes the polynom part
|
||||
pol_usual = 0.d0
|
||||
pol_usual(1) = dr(2)**dble(power_ao(2)) * dr(3)**dble(power_ao(3))
|
||||
pol_usual(2) = dr(1)**dble(power_ao(1)) * dr(3)**dble(power_ao(3))
|
||||
pol_usual(3) = dr(1)**dble(power_ao(1)) * dr(2)**dble(power_ao(2))
|
||||
|
||||
xyz_grad_phi = 0.d0
|
||||
do m = 1, 3
|
||||
xyz_grad_phi(m) += accu(m,2) * pol_usual(m) * dr(m)**dble(power_ord_xyz_grad_transp(2,m,i_ao))
|
||||
xyz_grad_phi(m) += accu(m,3) * pol_usual(m) * dr(m)**dble(power_ord_xyz_grad_transp(3,m,i_ao))
|
||||
xyz_grad_phi(m) += accu(m,4) * pol_usual(m) * dr(m)**dble(power_ord_xyz_grad_transp(4,m,i_ao))
|
||||
if(power_ord_xyz_grad_transp(1,m,i_ao).lt.0)cycle
|
||||
xyz_grad_phi(m) += accu(m,1) * pol_usual(m) * dr(m)**dble(power_ord_xyz_grad_transp(1,m,i_ao))
|
||||
enddo
|
||||
end
|
||||
|
||||
subroutine grad_phi_ao(r,i_ao,grad_xyz_phi)
|
||||
implicit none
|
||||
integer, intent(in) :: i_ao
|
||||
double precision, intent(in) :: r(3)
|
||||
double precision, intent(out):: grad_xyz_phi(3) ! x * phi i, y * phi_i, z * phi_
|
||||
double precision :: center_ao(3),beta
|
||||
double precision :: accu(3,2),dr(3),r2,pol_usual(3)
|
||||
integer :: m,power_ao(3),num_ao,j_prim
|
||||
power_ao(1:3)= ao_power(i_ao,1:3)
|
||||
num_ao = ao_nucl(i_ao)
|
||||
center_ao(1:3) = nucl_coord(num_ao,1:3)
|
||||
dr(1) = (r(1) - center_ao(1))
|
||||
dr(2) = (r(2) - center_ao(2))
|
||||
dr(3) = (r(3) - center_ao(3))
|
||||
r2 = 0.d0
|
||||
do m = 1, 3
|
||||
r2 += dr(m)*dr(m)
|
||||
enddo
|
||||
! computes the gaussian part
|
||||
accu = 0.d0
|
||||
do j_prim =1,ao_prim_num(i_ao)
|
||||
beta = ao_expo_ordered_transp(j_prim,i_ao)
|
||||
if(dabs(beta*r2).gt.50.d0)cycle
|
||||
do m = 1, 3
|
||||
accu(m,1) += ao_coef_ord_grad_transp(1,m,j_prim,i_ao) * dexp(-beta*r2)
|
||||
accu(m,2) += ao_coef_ord_grad_transp(2,m,j_prim,i_ao) * dexp(-beta*r2)
|
||||
enddo
|
||||
enddo
|
||||
! computes the polynom part
|
||||
pol_usual = 0.d0
|
||||
pol_usual(1) = dr(2)**dble(power_ao(2)) * dr(3)**dble(power_ao(3))
|
||||
pol_usual(2) = dr(1)**dble(power_ao(1)) * dr(3)**dble(power_ao(3))
|
||||
pol_usual(3) = dr(1)**dble(power_ao(1)) * dr(2)**dble(power_ao(2))
|
||||
do m = 1, 3
|
||||
grad_xyz_phi(m) = accu(m,2) * pol_usual(m) * dr(m)**dble(power_ord_grad_transp(2,m,i_ao))
|
||||
if(power_ao(m)==0)cycle
|
||||
grad_xyz_phi(m) += accu(m,1) * pol_usual(m) * dr(m)**dble(power_ord_grad_transp(1,m,i_ao))
|
||||
enddo
|
||||
end
|
||||
|
||||
subroutine xyz_phi_ao(r,i_ao,xyz_phi)
|
||||
implicit none
|
||||
integer, intent(in) :: i_ao
|
||||
double precision, intent(in) :: r(3)
|
||||
double precision, intent(out):: xyz_phi(3) ! x * phi i, y * phi_i, z * phi_i
|
||||
double precision :: center_ao(3),beta
|
||||
double precision :: accu,dr(3),r2,pol_usual(3)
|
||||
integer :: m,power_ao(3),num_ao
|
||||
power_ao(1:3)= ao_power(i_ao,1:3)
|
||||
num_ao = ao_nucl(i_ao)
|
||||
center_ao(1:3) = nucl_coord(num_ao,1:3)
|
||||
dr(1) = (r(1) - center_ao(1))
|
||||
dr(2) = (r(2) - center_ao(2))
|
||||
dr(3) = (r(3) - center_ao(3))
|
||||
r2 = 0.d0
|
||||
do m = 1, 3
|
||||
r2 += dr(m)*dr(m)
|
||||
enddo
|
||||
! computes the gaussian part
|
||||
accu = 0.d0
|
||||
do m=1,ao_prim_num(i_ao)
|
||||
beta = ao_expo_ordered_transp(m,i_ao)
|
||||
if(dabs(beta*r2).gt.50.d0)cycle
|
||||
accu += ao_coef_normalized_ordered_transp(m,i_ao) * dexp(-beta*r2)
|
||||
enddo
|
||||
! computes the polynom part
|
||||
pol_usual = 0.d0
|
||||
pol_usual(1) = dr(2)**dble(power_ao(2)) * dr(3)**dble(power_ao(3))
|
||||
pol_usual(2) = dr(1)**dble(power_ao(1)) * dr(3)**dble(power_ao(3))
|
||||
pol_usual(3) = dr(1)**dble(power_ao(1)) * dr(2)**dble(power_ao(2))
|
||||
do m = 1, 3
|
||||
xyz_phi(m) = accu * pol_usual(m) * dr(m)**(dble(power_ao(m))) * ( coef_xyz_ao(1,m,i_ao) + coef_xyz_ao(2,m,i_ao) * dr(m) )
|
||||
enddo
|
||||
end
|
||||
|
||||
|
||||
subroutine test_pol_xyz
|
||||
implicit none
|
||||
integer :: ipoint,i,j,m,jpoint
|
||||
double precision :: r1(3),derf_mu_x
|
||||
double precision :: weight1,r12,xyz_phi(3),grad_phi(3),xyz_grad_phi(3)
|
||||
double precision, allocatable :: aos_array(:),aos_grad_array(:,:)
|
||||
double precision :: num_xyz_phi(3),num_grad_phi(3),num_xyz_grad_phi(3)
|
||||
double precision :: accu_xyz_phi(3),accu_grad_phi(3),accu_xyz_grad_phi(3)
|
||||
double precision :: meta_accu_xyz_phi(3),meta_accu_grad_phi(3),meta_accu_xyz_grad_phi(3)
|
||||
allocate(aos_array(ao_num),aos_grad_array(3,ao_num))
|
||||
meta_accu_xyz_phi = 0.d0
|
||||
meta_accu_grad_phi = 0.d0
|
||||
meta_accu_xyz_grad_phi= 0.d0
|
||||
do i = 1, ao_num
|
||||
accu_xyz_phi = 0.d0
|
||||
accu_grad_phi = 0.d0
|
||||
accu_xyz_grad_phi= 0.d0
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
r1(:) = final_grid_points(:,ipoint)
|
||||
weight1 = final_weight_at_r_vector(ipoint)
|
||||
call give_all_aos_and_grad_at_r(r1,aos_array,aos_grad_array)
|
||||
do m = 1, 3
|
||||
num_xyz_phi(m) = r1(m) * aos_array(i)
|
||||
num_grad_phi(m) = aos_grad_array(m,i)
|
||||
num_xyz_grad_phi(m) = r1(m) * aos_grad_array(m,i)
|
||||
enddo
|
||||
call xyz_phi_ao(r1,i,xyz_phi)
|
||||
call grad_phi_ao(r1,i,grad_phi)
|
||||
call xyz_grad_phi_ao(r1,i,xyz_grad_phi)
|
||||
do m = 1, 3
|
||||
accu_xyz_phi(m) += weight1 * dabs(num_xyz_phi(m) - xyz_phi(m) )
|
||||
accu_grad_phi(m) += weight1 * dabs(num_grad_phi(m) - grad_phi(m) )
|
||||
accu_xyz_grad_phi(m) += weight1 * dabs(num_xyz_grad_phi(m) - xyz_grad_phi(m))
|
||||
enddo
|
||||
enddo
|
||||
print*,''
|
||||
print*,''
|
||||
print*,'i,',i
|
||||
print*,''
|
||||
do m = 1, 3
|
||||
! print*, 'm, accu_xyz_phi(m) ' ,m, accu_xyz_phi(m)
|
||||
! print*, 'm, accu_grad_phi(m) ' ,m, accu_grad_phi(m)
|
||||
print*, 'm, accu_xyz_grad_phi' ,m, accu_xyz_grad_phi(m)
|
||||
enddo
|
||||
do m = 1, 3
|
||||
meta_accu_xyz_phi(m) += dabs(accu_xyz_phi(m))
|
||||
meta_accu_grad_phi(m) += dabs(accu_grad_phi(m))
|
||||
meta_accu_xyz_grad_phi(m) += dabs(accu_xyz_grad_phi(m))
|
||||
enddo
|
||||
enddo
|
||||
do m = 1, 3
|
||||
! print*, 'm, meta_accu_xyz_phi(m) ' ,m, meta_accu_xyz_phi(m)
|
||||
! print*, 'm, meta_accu_grad_phi(m) ' ,m, meta_accu_grad_phi(m)
|
||||
print*, 'm, meta_accu_xyz_grad_phi' ,m, meta_accu_xyz_grad_phi(m)
|
||||
enddo
|
||||
|
||||
|
||||
|
||||
end
|
||||
|
||||
subroutine test_ints_semi_bis
|
||||
implicit none
|
||||
integer :: ipoint,i,j,m
|
||||
double precision :: r1(3), aos_grad_array_r1(3, ao_num), aos_array_r1(ao_num)
|
||||
double precision :: C_center(3), weight1,mu_in,r12,derf_mu_x,dxyz_ints(3),NAI_pol_mult_erf_ao
|
||||
double precision :: ao_mat(ao_num,ao_num),ao_xmat(3,ao_num,ao_num),accu1, accu2(3)
|
||||
mu_in = 0.5d0
|
||||
C_center = 0.d0
|
||||
C_center(1) = 0.25d0
|
||||
C_center(3) = 1.12d0
|
||||
C_center(2) = -1.d0
|
||||
ao_mat = 0.d0
|
||||
ao_xmat = 0.d0
|
||||
do ipoint = 1, n_points_final_grid
|
||||
r1(1) = final_grid_points(1,ipoint)
|
||||
r1(2) = final_grid_points(2,ipoint)
|
||||
r1(3) = final_grid_points(3,ipoint)
|
||||
call give_all_aos_and_grad_at_r(r1,aos_array_r1,aos_grad_array_r1)
|
||||
weight1 = final_weight_at_r_vector(ipoint)
|
||||
r12 = (r1(1) - C_center(1))**2.d0 + (r1(2) - C_center(2))**2.d0 + (r1(3) - C_center(3))**2.d0
|
||||
r12 = dsqrt(r12)
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
ao_mat(j,i) += aos_array_r1(i) * aos_array_r1(j) * weight1 * derf_mu_x(mu_in,r12)
|
||||
do m = 1, 3
|
||||
ao_xmat(m,j,i) += r1(m) * aos_array_r1(j) * aos_grad_array_r1(m,i) * weight1 * derf_mu_x(mu_in,r12)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
accu1 = 0.d0
|
||||
accu2 = 0.d0
|
||||
accu1relat = 0.d0
|
||||
accu2relat = 0.d0
|
||||
double precision :: accu1relat, accu2relat(3)
|
||||
double precision :: contrib(3)
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
call phi_j_erf_mu_r_xyz_dxyz_phi(i,j,mu_in, C_center, dxyz_ints)
|
||||
print*,''
|
||||
print*,'i,j',i,j
|
||||
print*,dxyz_ints(:)
|
||||
print*,ao_xmat(:,j,i)
|
||||
do m = 1, 3
|
||||
contrib(m) = dabs(ao_xmat(m,j,i) - dxyz_ints(m))
|
||||
accu2(m) += contrib(m)
|
||||
if(dabs(ao_xmat(m,j,i)).gt.1.d-10)then
|
||||
accu2relat(m) += dabs(ao_xmat(m,j,i) - dxyz_ints(m))/dabs(ao_xmat(m,j,i))
|
||||
endif
|
||||
enddo
|
||||
print*,contrib
|
||||
enddo
|
||||
print*,''
|
||||
enddo
|
||||
print*,'accu2relat = '
|
||||
print*, accu2relat /dble(ao_num * ao_num)
|
||||
|
||||
end
|
||||
|
||||
|
||||
@ -46,142 +46,327 @@ double precision function NAI_pol_mult_erf_ao(i_ao,j_ao,mu_in,C_center)
|
||||
|
||||
end
|
||||
|
||||
double precision function NAI_pol_mult_erf(A_center, B_center, power_A, power_B, alpha, beta, C_center, n_pt_in, mu_in)
|
||||
|
||||
|
||||
double precision function NAI_pol_mult_erf(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in,mu_in)
|
||||
BEGIN_DOC
|
||||
!
|
||||
! Computes the following integral :
|
||||
!
|
||||
! .. math::
|
||||
!
|
||||
! \int dr (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
|
||||
! \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
|
||||
! \frac{\erf(\mu |r - R_C |)}{| r - R_C |}$.
|
||||
!
|
||||
END_DOC
|
||||
|
||||
include 'utils/constants.include.F'
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: n_pt_in
|
||||
integer, intent(in) :: power_A(3), power_B(3)
|
||||
double precision, intent(in) :: C_center(3), A_center(3), B_center(3), alpha, beta, mu_in
|
||||
|
||||
integer :: i, n_pt, n_pt_out
|
||||
double precision :: P_center(3)
|
||||
double precision :: d(0:n_pt_in), coeff, dist, const, factor
|
||||
double precision :: const_factor, dist_integral
|
||||
double precision :: accu, p_inv, p, rho, p_inv_2
|
||||
double precision :: p_new
|
||||
|
||||
double precision :: rint
|
||||
|
||||
p = alpha + beta
|
||||
p_inv = 1.d0 / p
|
||||
p_inv_2 = 0.5d0 * p_inv
|
||||
rho = alpha * beta * p_inv
|
||||
|
||||
dist = 0.d0
|
||||
dist_integral = 0.d0
|
||||
do i = 1, 3
|
||||
P_center(i) = (alpha * A_center(i) + beta * B_center(i)) * p_inv
|
||||
dist += (A_center(i) - B_center(i)) * (A_center(i) - B_center(i))
|
||||
dist_integral += (P_center(i) - C_center(i)) * (P_center(i) - C_center(i))
|
||||
enddo
|
||||
const_factor = dist * rho
|
||||
if(const_factor > 80.d0) then
|
||||
NAI_pol_mult_erf = 0.d0
|
||||
return
|
||||
endif
|
||||
|
||||
p_new = mu_in / dsqrt(p + mu_in * mu_in)
|
||||
factor = dexp(-const_factor)
|
||||
coeff = dtwo_pi * factor * p_inv * p_new
|
||||
|
||||
n_pt = 2 * ( (power_A(1) + power_B(1)) + (power_A(2) + power_B(2)) + (power_A(3) + power_B(3)) )
|
||||
const = p * dist_integral * p_new * p_new
|
||||
if(n_pt == 0) then
|
||||
NAI_pol_mult_erf = coeff * rint(0, const)
|
||||
return
|
||||
endif
|
||||
|
||||
do i = 0, n_pt_in
|
||||
d(i) = 0.d0
|
||||
enddo
|
||||
! call give_polynomial_mult_center_one_e_erf(A_center,B_center,alpha,beta,power_A,power_B,C_center,n_pt_in,d,n_pt_out,mu_in)
|
||||
p_new = p_new * p_new
|
||||
call give_polynomial_mult_center_one_e_erf_opt(A_center, B_center, power_A, power_B, C_center, n_pt_in, d, n_pt_out, p_inv_2, p_new, P_center)
|
||||
|
||||
if(n_pt_out < 0) then
|
||||
NAI_pol_mult_erf = 0.d0
|
||||
return
|
||||
endif
|
||||
|
||||
! sum of integrals of type : int {t,[0,1]} exp-(rho.(P-Q)^2 * t^2) * t^i
|
||||
accu = 0.d0
|
||||
do i = 0, n_pt_out, 2
|
||||
accu += d(i) * rint(i/2, const)
|
||||
enddo
|
||||
NAI_pol_mult_erf = accu * coeff
|
||||
|
||||
end function NAI_pol_mult_erf
|
||||
|
||||
! ---
|
||||
|
||||
|
||||
double precision function NAI_pol_mult_erf_ao_with1s(i_ao, j_ao, beta, B_center, mu_in, C_center)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! Computes the following integral :
|
||||
! $\int_{-\infty}^{infty} dr \chi_i(r) \chi_j(r) e^{-\beta (r - B_center)^2} \frac{\erf(\mu |r - R_C|)}{|r - R_C|}$.
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: n_pt_in
|
||||
double precision,intent(in) :: C_center(3),A_center(3),B_center(3),alpha,beta,mu_in
|
||||
integer, intent(in) :: power_A(3),power_B(3)
|
||||
integer :: i,j,k,l,n_pt
|
||||
double precision :: P_center(3)
|
||||
integer, intent(in) :: i_ao, j_ao
|
||||
double precision, intent(in) :: beta, B_center(3)
|
||||
double precision, intent(in) :: mu_in, C_center(3)
|
||||
|
||||
integer :: i, j, power_A1(3), power_A2(3), n_pt_in
|
||||
double precision :: A1_center(3), A2_center(3), alpha1, alpha2, coef12, coef1, integral
|
||||
|
||||
double precision, external :: NAI_pol_mult_erf_with1s, NAI_pol_mult_erf_ao
|
||||
|
||||
ASSERT(beta .ge. 0.d0)
|
||||
if(beta .lt. 1d-10) then
|
||||
NAI_pol_mult_erf_ao_with1s = NAI_pol_mult_erf_ao(i_ao, j_ao, mu_in, C_center)
|
||||
return
|
||||
endif
|
||||
|
||||
power_A1(1:3) = ao_power(i_ao,1:3)
|
||||
power_A2(1:3) = ao_power(j_ao,1:3)
|
||||
|
||||
A1_center(1:3) = nucl_coord(ao_nucl(i_ao),1:3)
|
||||
A2_center(1:3) = nucl_coord(ao_nucl(j_ao),1:3)
|
||||
|
||||
n_pt_in = n_pt_max_integrals
|
||||
|
||||
NAI_pol_mult_erf_ao_with1s = 0.d0
|
||||
do i = 1, ao_prim_num(i_ao)
|
||||
alpha1 = ao_expo_ordered_transp (i,i_ao)
|
||||
coef1 = ao_coef_normalized_ordered_transp(i,i_ao)
|
||||
|
||||
do j = 1, ao_prim_num(j_ao)
|
||||
alpha2 = ao_expo_ordered_transp(j,j_ao)
|
||||
coef12 = coef1 * ao_coef_normalized_ordered_transp(j,j_ao)
|
||||
if(dabs(coef12) .lt. 1d-14) cycle
|
||||
|
||||
integral = NAI_pol_mult_erf_with1s( A1_center, A2_center, power_A1, power_A2, alpha1, alpha2 &
|
||||
, beta, B_center, C_center, n_pt_in, mu_in )
|
||||
|
||||
NAI_pol_mult_erf_ao_with1s += integral * coef12
|
||||
enddo
|
||||
enddo
|
||||
|
||||
end function NAI_pol_mult_erf_ao_with1s
|
||||
|
||||
subroutine NAI_pol_mult_erf_with1s_v(A1_center, A2_center, power_A1, power_A2, alpha1, alpha2, beta, B_center, LD_B, C_center, LD_C, n_pt_in, mu_in, res_v, LD_resv, n_points)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! Computes the following integral :
|
||||
!
|
||||
! .. math ::
|
||||
!
|
||||
! \int dx (x - A1_x)^a_1 (x - B1_x)^a_2 \exp(-\alpha_1 (x - A1_x)^2 - \alpha_2 (x - A2_x)^2)
|
||||
! \int dy (y - A1_y)^b_1 (y - B1_y)^b_2 \exp(-\alpha_1 (y - A1_y)^2 - \alpha_2 (y - A2_y)^2)
|
||||
! \int dz (x - A1_z)^c_1 (z - B1_z)^c_2 \exp(-\alpha_1 (z - A1_z)^2 - \alpha_2 (z - A2_z)^2)
|
||||
! \exp(-\beta (r - B)^2)
|
||||
! \frac{\erf(\mu |r - R_C|)}{|r - R_C|}$.
|
||||
!
|
||||
END_DOC
|
||||
|
||||
double precision :: d(0:n_pt_in),pouet,coeff,dist,const,pouet_2,factor
|
||||
double precision :: I_n_special_exact,integrate_bourrin,I_n_bibi
|
||||
double precision :: V_e_n,const_factor,dist_integral,tmp
|
||||
double precision :: accu,rint,p_inv,p,rho,p_inv_2
|
||||
integer :: n_pt_out,lmax
|
||||
include 'utils/constants.include.F'
|
||||
p = alpha + beta
|
||||
p_inv = 1.d0/p
|
||||
p_inv_2 = 0.5d0 * p_inv
|
||||
rho = alpha * beta * p_inv
|
||||
|
||||
dist = 0.d0
|
||||
dist_integral = 0.d0
|
||||
do i = 1, 3
|
||||
P_center(i) = (alpha * A_center(i) + beta * B_center(i)) * p_inv
|
||||
dist += (A_center(i) - B_center(i))*(A_center(i) - B_center(i))
|
||||
dist_integral += (P_center(i) - C_center(i))*(P_center(i) - C_center(i))
|
||||
enddo
|
||||
const_factor = dist*rho
|
||||
if(const_factor > 80.d0)then
|
||||
NAI_pol_mult_erf = 0.d0
|
||||
return
|
||||
endif
|
||||
double precision :: p_new
|
||||
p_new = mu_in/dsqrt(p+ mu_in * mu_in)
|
||||
factor = dexp(-const_factor)
|
||||
coeff = dtwo_pi * factor * p_inv * p_new
|
||||
lmax = 20
|
||||
implicit none
|
||||
integer, intent(in) :: n_pt_in, LD_B, LD_C, LD_resv, n_points
|
||||
integer, intent(in) :: power_A1(3), power_A2(3)
|
||||
double precision, intent(in) :: A1_center(3), A2_center(3)
|
||||
double precision, intent(in) :: C_center(LD_C,3), B_center(LD_B,3)
|
||||
double precision, intent(in) :: alpha1, alpha2, beta, mu_in
|
||||
double precision, intent(out) :: res_v(LD_resv)
|
||||
|
||||
! print*, "b"
|
||||
do i = 0, n_pt_in
|
||||
d(i) = 0.d0
|
||||
enddo
|
||||
n_pt = 2 * ( (power_A(1) + power_B(1)) +(power_A(2) + power_B(2)) +(power_A(3) + power_B(3)) )
|
||||
const = p * dist_integral * p_new * p_new
|
||||
if (n_pt == 0) then
|
||||
pouet = rint(0,const)
|
||||
NAI_pol_mult_erf = coeff * pouet
|
||||
integer :: i, n_pt, n_pt_out, ipoint
|
||||
double precision :: alpha12, alpha12_inv, alpha12_inv_2, rho12, A12_center(3), dist12, const_factor12
|
||||
double precision :: p, p_inv, p_inv_2, rho, P_center(3), dist, const_factor
|
||||
double precision :: dist_integral
|
||||
double precision :: d(0:n_pt_in), coeff, const, factor
|
||||
double precision :: accu
|
||||
double precision :: p_new, p_new2, coef_tmp, cons_tmp
|
||||
|
||||
double precision :: rint
|
||||
|
||||
|
||||
res_V(1:LD_resv) = 0.d0
|
||||
|
||||
! e^{-alpha1 (r - A1)^2} e^{-alpha2 (r - A2)^2} = e^{-K12} e^{-alpha12 (r - A12)^2}
|
||||
alpha12 = alpha1 + alpha2
|
||||
alpha12_inv = 1.d0 / alpha12
|
||||
alpha12_inv_2 = 0.5d0 * alpha12_inv
|
||||
rho12 = alpha1 * alpha2 * alpha12_inv
|
||||
A12_center(1) = (alpha1 * A1_center(1) + alpha2 * A2_center(1)) * alpha12_inv
|
||||
A12_center(2) = (alpha1 * A1_center(2) + alpha2 * A2_center(2)) * alpha12_inv
|
||||
A12_center(3) = (alpha1 * A1_center(3) + alpha2 * A2_center(3)) * alpha12_inv
|
||||
dist12 = (A1_center(1) - A2_center(1)) * (A1_center(1) - A2_center(1))&
|
||||
+ (A1_center(2) - A2_center(2)) * (A1_center(2) - A2_center(2))&
|
||||
+ (A1_center(3) - A2_center(3)) * (A1_center(3) - A2_center(3))
|
||||
|
||||
const_factor12 = dist12 * rho12
|
||||
if(const_factor12 > 80.d0) then
|
||||
return
|
||||
endif
|
||||
|
||||
! call give_polynomial_mult_center_one_e_erf(A_center,B_center,alpha,beta,power_A,power_B,C_center,n_pt_in,d,n_pt_out,mu_in)
|
||||
p_new = p_new * p_new
|
||||
call give_polynomial_mult_center_one_e_erf_opt(A_center,B_center,alpha,beta,power_A,power_B,C_center,n_pt_in,d,n_pt_out,mu_in,p,p_inv,p_inv_2,p_new,P_center)
|
||||
! e^{-K12} e^{-alpha12 (r - A12)^2} e^{-beta (r - B)^2} = e^{-K} e^{-p (r - P)^2}
|
||||
p = alpha12 + beta
|
||||
p_inv = 1.d0 / p
|
||||
p_inv_2 = 0.5d0 * p_inv
|
||||
rho = alpha12 * beta * p_inv
|
||||
p_new = mu_in / dsqrt(p + mu_in * mu_in)
|
||||
p_new2 = p_new * p_new
|
||||
coef_tmp = dtwo_pi * p_inv * p_new
|
||||
cons_tmp = p * p_new2
|
||||
n_pt = 2 * (power_A1(1) + power_A2(1) + power_A1(2) + power_A2(2) + power_A1(3) + power_A2(3) )
|
||||
|
||||
if(n_pt == 0) then
|
||||
|
||||
do ipoint = 1, n_points
|
||||
|
||||
dist = (A12_center(1) - B_center(ipoint,1)) * (A12_center(1) - B_center(ipoint,1))&
|
||||
+ (A12_center(2) - B_center(ipoint,2)) * (A12_center(2) - B_center(ipoint,2))&
|
||||
+ (A12_center(3) - B_center(ipoint,3)) * (A12_center(3) - B_center(ipoint,3))
|
||||
const_factor = const_factor12 + dist * rho
|
||||
if(const_factor > 80.d0) cycle
|
||||
coeff = coef_tmp * dexp(-const_factor)
|
||||
|
||||
P_center(1) = (alpha12 * A12_center(1) + beta * B_center(ipoint,1)) * p_inv
|
||||
P_center(2) = (alpha12 * A12_center(2) + beta * B_center(ipoint,2)) * p_inv
|
||||
P_center(3) = (alpha12 * A12_center(3) + beta * B_center(ipoint,3)) * p_inv
|
||||
dist_integral = (P_center(1) - C_center(ipoint,1)) * (P_center(1) - C_center(ipoint,1))&
|
||||
+ (P_center(2) - C_center(ipoint,2)) * (P_center(2) - C_center(ipoint,2))&
|
||||
+ (P_center(3) - C_center(ipoint,3)) * (P_center(3) - C_center(ipoint,3))
|
||||
const = cons_tmp * dist_integral
|
||||
|
||||
res_v(ipoint) = coeff * rint(0, const)
|
||||
enddo
|
||||
|
||||
else
|
||||
|
||||
do ipoint = 1, n_points
|
||||
|
||||
dist = (A12_center(1) - B_center(ipoint,1)) * (A12_center(1) - B_center(ipoint,1))&
|
||||
+ (A12_center(2) - B_center(ipoint,2)) * (A12_center(2) - B_center(ipoint,2))&
|
||||
+ (A12_center(3) - B_center(ipoint,3)) * (A12_center(3) - B_center(ipoint,3))
|
||||
const_factor = const_factor12 + dist * rho
|
||||
if(const_factor > 80.d0) cycle
|
||||
coeff = coef_tmp * dexp(-const_factor)
|
||||
|
||||
P_center(1) = (alpha12 * A12_center(1) + beta * B_center(ipoint,1)) * p_inv
|
||||
P_center(2) = (alpha12 * A12_center(2) + beta * B_center(ipoint,2)) * p_inv
|
||||
P_center(3) = (alpha12 * A12_center(3) + beta * B_center(ipoint,3)) * p_inv
|
||||
dist_integral = (P_center(1) - C_center(ipoint,1)) * (P_center(1) - C_center(ipoint,1))&
|
||||
+ (P_center(2) - C_center(ipoint,2)) * (P_center(2) - C_center(ipoint,2))&
|
||||
+ (P_center(3) - C_center(ipoint,3)) * (P_center(3) - C_center(ipoint,3))
|
||||
const = cons_tmp * dist_integral
|
||||
|
||||
do i = 0, n_pt_in
|
||||
d(i) = 0.d0
|
||||
enddo
|
||||
!TODO: VECTORIZE HERE
|
||||
call give_polynomial_mult_center_one_e_erf_opt(A1_center, A2_center, power_A1, power_A2, C_center(ipoint,1:3), n_pt_in, d, n_pt_out, p_inv_2, p_new2, P_center)
|
||||
|
||||
if(n_pt_out < 0) then
|
||||
cycle
|
||||
endif
|
||||
|
||||
! sum of integrals of type : int {t,[0,1]} exp-(rho.(P-Q)^2 * t^2) * t^i
|
||||
accu = 0.d0
|
||||
do i = 0, n_pt_out, 2
|
||||
accu += d(i) * rint(i/2, const)
|
||||
enddo
|
||||
|
||||
res_v(ipoint) = accu * coeff
|
||||
enddo
|
||||
|
||||
if(n_pt_out<0)then
|
||||
NAI_pol_mult_erf = 0.d0
|
||||
return
|
||||
endif
|
||||
accu = 0.d0
|
||||
|
||||
! sum of integrals of type : int {t,[0,1]} exp-(rho.(P-Q)^2 * t^2) * t^i
|
||||
do i =0 ,n_pt_out,2
|
||||
accu += d(i) * rint(i/2,const)
|
||||
enddo
|
||||
NAI_pol_mult_erf = accu * coeff
|
||||
end subroutine NAI_pol_mult_erf_with1s_v
|
||||
|
||||
end
|
||||
! ---
|
||||
|
||||
subroutine give_polynomial_mult_center_one_e_erf_opt(A_center, B_center, power_A, power_B, C_center, n_pt_in, d, n_pt_out, p_inv_2, p_new, P_center)
|
||||
|
||||
subroutine give_polynomial_mult_center_one_e_erf_opt(A_center,B_center,alpha,beta,&
|
||||
power_A,power_B,C_center,n_pt_in,d,n_pt_out,mu_in,p,p_inv,p_inv_2,p_new,P_center)
|
||||
BEGIN_DOC
|
||||
! Returns the explicit polynomial in terms of the $t$ variable of the
|
||||
! following polynomial:
|
||||
!
|
||||
! $I_{x1}(a_x, d_x,p,q) \times I_{x1}(a_y, d_y,p,q) \times I_{x1}(a_z, d_z,p,q)$.
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: n_pt_in
|
||||
integer,intent(out) :: n_pt_out
|
||||
double precision, intent(in) :: A_center(3), B_center(3),C_center(3),p,p_inv,p_inv_2,p_new,P_center(3)
|
||||
double precision, intent(in) :: alpha,beta,mu_in
|
||||
integer, intent(in) :: power_A(3), power_B(3)
|
||||
integer :: a_x,b_x,a_y,b_y,a_z,b_z
|
||||
double precision :: d(0:n_pt_in)
|
||||
double precision :: d1(0:n_pt_in)
|
||||
double precision :: d2(0:n_pt_in)
|
||||
double precision :: d3(0:n_pt_in)
|
||||
double precision :: accu
|
||||
integer, intent(in) :: n_pt_in
|
||||
integer, intent(in) :: power_A(3), power_B(3)
|
||||
double precision, intent(in) :: A_center(3), B_center(3), C_center(3), p_inv_2, p_new, P_center(3)
|
||||
integer, intent(out) :: n_pt_out
|
||||
double precision, intent(out) :: d(0:n_pt_in)
|
||||
|
||||
integer :: a_x, b_x, a_y, b_y, a_z, b_z
|
||||
integer :: n_pt1, n_pt2, n_pt3, dim, i
|
||||
integer :: n_pt_tmp
|
||||
double precision :: d1(0:n_pt_in)
|
||||
double precision :: d2(0:n_pt_in)
|
||||
double precision :: d3(0:n_pt_in)
|
||||
double precision :: accu
|
||||
double precision :: R1x(0:2), B01(0:2), R1xp(0:2), R2x(0:2)
|
||||
|
||||
accu = 0.d0
|
||||
ASSERT (n_pt_in > 1)
|
||||
|
||||
double precision :: R1x(0:2), B01(0:2), R1xp(0:2),R2x(0:2)
|
||||
R1x(0) = (P_center(1) - A_center(1))
|
||||
R1x(1) = 0.d0
|
||||
R1x(2) = -(P_center(1) - C_center(1))* p_new
|
||||
R1x(0) = (P_center(1) - A_center(1))
|
||||
R1x(1) = 0.d0
|
||||
R1x(2) = -(P_center(1) - C_center(1))* p_new
|
||||
! R1x = (P_x - A_x) - (P_x - C_x) ( t * mu/sqrt(p+mu^2) )^2
|
||||
R1xp(0) = (P_center(1) - B_center(1))
|
||||
R1xp(1) = 0.d0
|
||||
R1xp(2) =-(P_center(1) - C_center(1))* p_new
|
||||
R1xp(0) = (P_center(1) - B_center(1))
|
||||
R1xp(1) = 0.d0
|
||||
R1xp(2) =-(P_center(1) - C_center(1))* p_new
|
||||
!R1xp = (P_x - B_x) - (P_x - C_x) ( t * mu/sqrt(p+mu^2) )^2
|
||||
R2x(0) = p_inv_2
|
||||
R2x(1) = 0.d0
|
||||
R2x(2) = -p_inv_2* p_new
|
||||
R2x(0) = p_inv_2
|
||||
R2x(1) = 0.d0
|
||||
R2x(2) = -p_inv_2 * p_new
|
||||
!R2x = 0.5 / p - 0.5/p ( t * mu/sqrt(p+mu^2) )^2
|
||||
do i = 0,n_pt_in
|
||||
d(i) = 0.d0
|
||||
enddo
|
||||
do i = 0,n_pt_in
|
||||
|
||||
do i = 0, n_pt_in
|
||||
d (i) = 0.d0
|
||||
d1(i) = 0.d0
|
||||
enddo
|
||||
do i = 0,n_pt_in
|
||||
d2(i) = 0.d0
|
||||
enddo
|
||||
do i = 0,n_pt_in
|
||||
d3(i) = 0.d0
|
||||
enddo
|
||||
integer :: n_pt1,n_pt2,n_pt3,dim,i
|
||||
|
||||
n_pt1 = n_pt_in
|
||||
n_pt2 = n_pt_in
|
||||
n_pt3 = n_pt_in
|
||||
a_x = power_A(1)
|
||||
b_x = power_B(1)
|
||||
call I_x1_pol_mult_one_e(a_x,b_x,R1x,R1xp,R2x,d1,n_pt1,n_pt_in)
|
||||
call I_x1_pol_mult_one_e(a_x, b_x, R1x, R1xp, R2x, d1, n_pt1, n_pt_in)
|
||||
if(n_pt1<0)then
|
||||
n_pt_out = -1
|
||||
do i = 0,n_pt_in
|
||||
@ -190,17 +375,17 @@ subroutine give_polynomial_mult_center_one_e_erf_opt(A_center,B_center,alpha,bet
|
||||
return
|
||||
endif
|
||||
|
||||
R1x(0) = (P_center(2) - A_center(2))
|
||||
R1x(1) = 0.d0
|
||||
R1x(2) = -(P_center(2) - C_center(2))* p_new
|
||||
R1x(0) = (P_center(2) - A_center(2))
|
||||
R1x(1) = 0.d0
|
||||
R1x(2) = -(P_center(2) - C_center(2))* p_new
|
||||
! R1x = (P_x - A_x) - (P_x - C_x) ( t * mu/sqrt(p+mu^2) )^2
|
||||
R1xp(0) = (P_center(2) - B_center(2))
|
||||
R1xp(1) = 0.d0
|
||||
R1xp(2) =-(P_center(2) - C_center(2))* p_new
|
||||
R1xp(0) = (P_center(2) - B_center(2))
|
||||
R1xp(1) = 0.d0
|
||||
R1xp(2) =-(P_center(2) - C_center(2))* p_new
|
||||
!R1xp = (P_x - B_x) - (P_x - C_x) ( t * mu/sqrt(p+mu^2) )^2
|
||||
a_y = power_A(2)
|
||||
b_y = power_B(2)
|
||||
call I_x1_pol_mult_one_e(a_y,b_y,R1x,R1xp,R2x,d2,n_pt2,n_pt_in)
|
||||
call I_x1_pol_mult_one_e(a_y, b_y, R1x, R1xp, R2x, d2, n_pt2, n_pt_in)
|
||||
if(n_pt2<0)then
|
||||
n_pt_out = -1
|
||||
do i = 0,n_pt_in
|
||||
@ -209,51 +394,151 @@ subroutine give_polynomial_mult_center_one_e_erf_opt(A_center,B_center,alpha,bet
|
||||
return
|
||||
endif
|
||||
|
||||
|
||||
R1x(0) = (P_center(3) - A_center(3))
|
||||
R1x(1) = 0.d0
|
||||
R1x(2) = -(P_center(3) - C_center(3))* p_new
|
||||
R1x(0) = (P_center(3) - A_center(3))
|
||||
R1x(1) = 0.d0
|
||||
R1x(2) = -(P_center(3) - C_center(3)) * p_new
|
||||
! R1x = (P_x - A_x) - (P_x - C_x) ( t * mu/sqrt(p+mu^2) )^2
|
||||
R1xp(0) = (P_center(3) - B_center(3))
|
||||
R1xp(1) = 0.d0
|
||||
R1xp(2) =-(P_center(3) - C_center(3))* p_new
|
||||
R1xp(0) = (P_center(3) - B_center(3))
|
||||
R1xp(1) = 0.d0
|
||||
R1xp(2) =-(P_center(3) - C_center(3)) * p_new
|
||||
!R2x = 0.5 / p - 0.5/p ( t * mu/sqrt(p+mu^2) )^2
|
||||
a_z = power_A(3)
|
||||
b_z = power_B(3)
|
||||
|
||||
call I_x1_pol_mult_one_e(a_z,b_z,R1x,R1xp,R2x,d3,n_pt3,n_pt_in)
|
||||
if(n_pt3<0)then
|
||||
call I_x1_pol_mult_one_e(a_z, b_z, R1x, R1xp, R2x, d3, n_pt3, n_pt_in)
|
||||
if(n_pt3 < 0) then
|
||||
n_pt_out = -1
|
||||
do i = 0,n_pt_in
|
||||
d(i) = 0.d0
|
||||
enddo
|
||||
return
|
||||
endif
|
||||
integer :: n_pt_tmp
|
||||
|
||||
n_pt_tmp = 0
|
||||
call multiply_poly(d1,n_pt1,d2,n_pt2,d,n_pt_tmp)
|
||||
do i = 0,n_pt_tmp
|
||||
call multiply_poly(d1, n_pt1, d2, n_pt2, d, n_pt_tmp)
|
||||
do i = 0, n_pt_tmp
|
||||
d1(i) = 0.d0
|
||||
enddo
|
||||
n_pt_out = 0
|
||||
call multiply_poly(d ,n_pt_tmp ,d3,n_pt3,d1,n_pt_out)
|
||||
call multiply_poly(d, n_pt_tmp, d3, n_pt3, d1, n_pt_out)
|
||||
do i = 0, n_pt_out
|
||||
d(i) = d1(i)
|
||||
enddo
|
||||
|
||||
end
|
||||
end subroutine give_polynomial_mult_center_one_e_erf_opt
|
||||
|
||||
! ---
|
||||
subroutine NAI_pol_mult_erf_v(A_center, B_center, power_A, power_B, alpha, beta, C_center, LD_C, n_pt_in, mu_in, res_v, LD_resv, n_points)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! Computes the following integral :
|
||||
!
|
||||
! .. math::
|
||||
!
|
||||
! \int dr (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
|
||||
! \frac{\erf(\mu |r - R_C |)}{| r - R_C |}$.
|
||||
!
|
||||
END_DOC
|
||||
|
||||
include 'utils/constants.include.F'
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: n_pt_in, n_points, LD_C, LD_resv
|
||||
integer, intent(in) :: power_A(3), power_B(3)
|
||||
double precision, intent(in) :: A_center(3), B_center(3), alpha, beta, mu_in
|
||||
double precision, intent(in) :: C_center(LD_C,3)
|
||||
double precision, intent(out) :: res_v(LD_resv)
|
||||
|
||||
integer :: i, n_pt, n_pt_out, ipoint
|
||||
double precision :: P_center(3)
|
||||
double precision :: d(0:n_pt_in), coeff, dist, const, factor
|
||||
double precision :: const_factor, dist_integral
|
||||
double precision :: accu, p_inv, p, rho, p_inv_2
|
||||
double precision :: p_new, p_new2, coef_tmp
|
||||
|
||||
double precision :: rint
|
||||
|
||||
res_V(1:LD_resv) = 0.d0
|
||||
|
||||
p = alpha + beta
|
||||
p_inv = 1.d0 / p
|
||||
p_inv_2 = 0.5d0 * p_inv
|
||||
rho = alpha * beta * p_inv
|
||||
p_new = mu_in / dsqrt(p + mu_in * mu_in)
|
||||
p_new2 = p_new * p_new
|
||||
coef_tmp = p * p_new2
|
||||
|
||||
dist = 0.d0
|
||||
do i = 1, 3
|
||||
P_center(i) = (alpha * A_center(i) + beta * B_center(i)) * p_inv
|
||||
dist += (A_center(i) - B_center(i)) * (A_center(i) - B_center(i))
|
||||
enddo
|
||||
|
||||
const_factor = dist * rho
|
||||
if(const_factor > 80.d0) then
|
||||
return
|
||||
endif
|
||||
factor = dexp(-const_factor)
|
||||
coeff = dtwo_pi * factor * p_inv * p_new
|
||||
|
||||
n_pt = 2 * ( power_A(1) + power_B(1) + power_A(2) + power_B(2) + power_A(3) + power_B(3) )
|
||||
|
||||
if(n_pt == 0) then
|
||||
|
||||
do ipoint = 1, n_points
|
||||
dist_integral = 0.d0
|
||||
do i = 1, 3
|
||||
dist_integral += (P_center(i) - C_center(ipoint,i)) * (P_center(i) - C_center(ipoint,i))
|
||||
enddo
|
||||
const = coef_tmp * dist_integral
|
||||
|
||||
res_v(ipoint) = coeff * rint(0, const)
|
||||
enddo
|
||||
|
||||
else
|
||||
|
||||
do ipoint = 1, n_points
|
||||
dist_integral = 0.d0
|
||||
do i = 1, 3
|
||||
dist_integral += (P_center(i) - C_center(ipoint,i)) * (P_center(i) - C_center(ipoint,i))
|
||||
enddo
|
||||
const = coef_tmp * dist_integral
|
||||
|
||||
do i = 0, n_pt_in
|
||||
d(i) = 0.d0
|
||||
enddo
|
||||
call give_polynomial_mult_center_one_e_erf_opt(A_center, B_center, power_A, power_B, C_center(ipoint,1:3), n_pt_in, d, n_pt_out, p_inv_2, p_new2, P_center)
|
||||
|
||||
if(n_pt_out < 0) then
|
||||
res_v(ipoint) = 0.d0
|
||||
cycle
|
||||
endif
|
||||
|
||||
! sum of integrals of type : int {t,[0,1]} exp-(rho.(P-Q)^2 * t^2) * t^i
|
||||
accu = 0.d0
|
||||
do i = 0, n_pt_out, 2
|
||||
accu += d(i) * rint(i/2, const)
|
||||
enddo
|
||||
|
||||
res_v(ipoint) = accu * coeff
|
||||
enddo
|
||||
|
||||
endif
|
||||
|
||||
end subroutine NAI_pol_mult_erf_v
|
||||
|
||||
|
||||
subroutine give_polynomial_mult_center_one_e_erf(A_center,B_center,alpha,beta,power_A,power_B,C_center,n_pt_in,d,n_pt_out,mu_in)
|
||||
|
||||
|
||||
subroutine give_polynomial_mult_center_one_e_erf(A_center,B_center,alpha,beta,&
|
||||
power_A,power_B,C_center,n_pt_in,d,n_pt_out,mu_in)
|
||||
BEGIN_DOC
|
||||
! Returns the explicit polynomial in terms of the $t$ variable of the
|
||||
! following polynomial:
|
||||
!
|
||||
! $I_{x1}(a_x, d_x,p,q) \times I_{x1}(a_y, d_y,p,q) \times I_{x1}(a_z, d_z,p,q)$.
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: n_pt_in
|
||||
integer,intent(out) :: n_pt_out
|
||||
@ -374,3 +659,113 @@ subroutine give_polynomial_mult_center_one_e_erf(A_center,B_center,alpha,beta,&
|
||||
|
||||
end
|
||||
|
||||
double precision function NAI_pol_mult_erf_with1s( A1_center, A2_center, power_A1, power_A2, alpha1, alpha2 &
|
||||
, beta, B_center, C_center, n_pt_in, mu_in )
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! Computes the following integral :
|
||||
!
|
||||
! .. math::
|
||||
!
|
||||
! \int dx (x - A1_x)^a_1 (x - B1_x)^a_2 \exp(-\alpha_1 (x - A1_x)^2 - \alpha_2 (x - A2_x)^2)
|
||||
! \int dy (y - A1_y)^b_1 (y - B1_y)^b_2 \exp(-\alpha_1 (y - A1_y)^2 - \alpha_2 (y - A2_y)^2)
|
||||
! \int dz (x - A1_z)^c_1 (z - B1_z)^c_2 \exp(-\alpha_1 (z - A1_z)^2 - \alpha_2 (z - A2_z)^2)
|
||||
! \exp(-\beta (r - B)^2)
|
||||
! \frac{\erf(\mu |r - R_C|)}{|r - R_C|}$.
|
||||
!
|
||||
END_DOC
|
||||
|
||||
include 'utils/constants.include.F'
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: n_pt_in
|
||||
integer, intent(in) :: power_A1(3), power_A2(3)
|
||||
double precision, intent(in) :: C_center(3), A1_center(3), A2_center(3), B_center(3)
|
||||
double precision, intent(in) :: alpha1, alpha2, beta, mu_in
|
||||
|
||||
integer :: i, n_pt, n_pt_out
|
||||
double precision :: alpha12, alpha12_inv, alpha12_inv_2, rho12, A12_center(3), dist12, const_factor12
|
||||
double precision :: p, p_inv, p_inv_2, rho, P_center(3), dist, const_factor
|
||||
double precision :: dist_integral
|
||||
double precision :: d(0:n_pt_in), coeff, const, factor
|
||||
double precision :: accu
|
||||
double precision :: p_new
|
||||
|
||||
double precision :: rint
|
||||
|
||||
|
||||
! e^{-alpha1 (r - A1)^2} e^{-alpha2 (r - A2)^2} = e^{-K12} e^{-alpha12 (r - A12)^2}
|
||||
alpha12 = alpha1 + alpha2
|
||||
alpha12_inv = 1.d0 / alpha12
|
||||
alpha12_inv_2 = 0.5d0 * alpha12_inv
|
||||
rho12 = alpha1 * alpha2 * alpha12_inv
|
||||
A12_center(1) = (alpha1 * A1_center(1) + alpha2 * A2_center(1)) * alpha12_inv
|
||||
A12_center(2) = (alpha1 * A1_center(2) + alpha2 * A2_center(2)) * alpha12_inv
|
||||
A12_center(3) = (alpha1 * A1_center(3) + alpha2 * A2_center(3)) * alpha12_inv
|
||||
dist12 = (A1_center(1) - A2_center(1)) * (A1_center(1) - A2_center(1)) &
|
||||
+ (A1_center(2) - A2_center(2)) * (A1_center(2) - A2_center(2)) &
|
||||
+ (A1_center(3) - A2_center(3)) * (A1_center(3) - A2_center(3))
|
||||
|
||||
const_factor12 = dist12 * rho12
|
||||
if(const_factor12 > 80.d0) then
|
||||
NAI_pol_mult_erf_with1s = 0.d0
|
||||
return
|
||||
endif
|
||||
|
||||
! ---
|
||||
|
||||
! e^{-K12} e^{-alpha12 (r - A12)^2} e^{-beta (r - B)^2} = e^{-K} e^{-p (r - P)^2}
|
||||
p = alpha12 + beta
|
||||
p_inv = 1.d0 / p
|
||||
p_inv_2 = 0.5d0 * p_inv
|
||||
rho = alpha12 * beta * p_inv
|
||||
P_center(1) = (alpha12 * A12_center(1) + beta * B_center(1)) * p_inv
|
||||
P_center(2) = (alpha12 * A12_center(2) + beta * B_center(2)) * p_inv
|
||||
P_center(3) = (alpha12 * A12_center(3) + beta * B_center(3)) * p_inv
|
||||
dist = (A12_center(1) - B_center(1)) * (A12_center(1) - B_center(1)) &
|
||||
+ (A12_center(2) - B_center(2)) * (A12_center(2) - B_center(2)) &
|
||||
+ (A12_center(3) - B_center(3)) * (A12_center(3) - B_center(3))
|
||||
|
||||
const_factor = const_factor12 + dist * rho
|
||||
if(const_factor > 80.d0) then
|
||||
NAI_pol_mult_erf_with1s = 0.d0
|
||||
return
|
||||
endif
|
||||
|
||||
dist_integral = (P_center(1) - C_center(1)) * (P_center(1) - C_center(1)) &
|
||||
+ (P_center(2) - C_center(2)) * (P_center(2) - C_center(2)) &
|
||||
+ (P_center(3) - C_center(3)) * (P_center(3) - C_center(3))
|
||||
|
||||
! ---
|
||||
|
||||
p_new = mu_in / dsqrt(p + mu_in * mu_in)
|
||||
factor = dexp(-const_factor)
|
||||
coeff = dtwo_pi * factor * p_inv * p_new
|
||||
|
||||
n_pt = 2 * ( (power_A1(1) + power_A2(1)) + (power_A1(2) + power_A2(2)) + (power_A1(3) + power_A2(3)) )
|
||||
const = p * dist_integral * p_new * p_new
|
||||
if(n_pt == 0) then
|
||||
NAI_pol_mult_erf_with1s = coeff * rint(0, const)
|
||||
return
|
||||
endif
|
||||
|
||||
do i = 0, n_pt_in
|
||||
d(i) = 0.d0
|
||||
enddo
|
||||
p_new = p_new * p_new
|
||||
call give_polynomial_mult_center_one_e_erf_opt( A1_center, A2_center, power_A1, power_A2, C_center, n_pt_in, d, n_pt_out, p_inv_2, p_new, P_center)
|
||||
|
||||
if(n_pt_out < 0) then
|
||||
NAI_pol_mult_erf_with1s = 0.d0
|
||||
return
|
||||
endif
|
||||
|
||||
! sum of integrals of type : int {t,[0,1]} exp-(rho.(P-Q)^2 * t^2) * t^i
|
||||
accu = 0.d0
|
||||
do i = 0, n_pt_out, 2
|
||||
accu += d(i) * rint(i/2, const)
|
||||
enddo
|
||||
NAI_pol_mult_erf_with1s = accu * coeff
|
||||
|
||||
end function NAI_pol_mult_erf_with1s
|
||||
|
||||
5
src/ao_tc_eff_map/NEED
Normal file
5
src/ao_tc_eff_map/NEED
Normal file
@ -0,0 +1,5 @@
|
||||
ao_two_e_erf_ints
|
||||
mo_one_e_ints
|
||||
ao_many_one_e_ints
|
||||
dft_utils_in_r
|
||||
tc_keywords
|
||||
12
src/ao_tc_eff_map/README.rst
Normal file
12
src/ao_tc_eff_map/README.rst
Normal file
@ -0,0 +1,12 @@
|
||||
ao_tc_eff_map
|
||||
=============
|
||||
|
||||
This is a module to obtain the integrals on the AO basis of the SCALAR HERMITIAN
|
||||
effective potential defined in Eq. 32 of JCP 154, 084119 (2021)
|
||||
It also contains the modification by a one-body Jastrow factor.
|
||||
|
||||
The main routine/providers are
|
||||
|
||||
+) ao_tc_sym_two_e_pot_map : map of the SCALAR PART of total effective two-electron on the AO basis in PHYSICIST notations. It might contain the two-electron term coming from the one-e correlation factor.
|
||||
+) get_ao_tc_sym_two_e_pot(i,j,k,l,ao_tc_sym_two_e_pot_map) : routine to get the integrals from ao_tc_sym_two_e_pot_map.
|
||||
+) ao_tc_sym_two_e_pot(i,j,k,l) : FUNCTION that returns the scalar part of TC-potential EXCLUDING the erf(mu r12)/r12. See two_e_ints_gauss.irp.f for more details.
|
||||
76
src/ao_tc_eff_map/compute_ints_eff_pot.irp.f
Normal file
76
src/ao_tc_eff_map/compute_ints_eff_pot.irp.f
Normal file
@ -0,0 +1,76 @@
|
||||
|
||||
|
||||
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
|
||||
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_2e_j1, j1b_gauss_2e_j2
|
||||
|
||||
|
||||
PROVIDE j1b_type
|
||||
|
||||
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_type .eq. 1 ) then
|
||||
!print *, ' j1b type 1 is added'
|
||||
integral = integral + j1b_gauss_2e_j1(i, k, j, l)
|
||||
elseif( j1b_type .eq. 2 ) then
|
||||
!print *, ' j1b type 2 is added'
|
||||
integral = integral + j1b_gauss_2e_j2(i, k, j, l)
|
||||
endif
|
||||
|
||||
if(abs(integral) < thr) then
|
||||
cycle
|
||||
endif
|
||||
|
||||
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
|
||||
|
||||
510
src/ao_tc_eff_map/fit_j.irp.f
Normal file
510
src/ao_tc_eff_map/fit_j.irp.f
Normal file
@ -0,0 +1,510 @@
|
||||
BEGIN_PROVIDER [ double precision, expo_j_xmu_1gauss ]
|
||||
&BEGIN_PROVIDER [ double precision, coef_j_xmu_1gauss ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Upper bound long range fit of F(x) = x * (1 - erf(x)) - 1/sqrt(pi) * exp(-x**2)
|
||||
!
|
||||
! with a single gaussian.
|
||||
!
|
||||
! Such a function can be used to screen integrals with F(x).
|
||||
END_DOC
|
||||
expo_j_xmu_1gauss = 0.5d0
|
||||
coef_j_xmu_1gauss = 1.d0
|
||||
END_PROVIDER
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, expo_erfc_gauss ]
|
||||
implicit none
|
||||
expo_erfc_gauss = 1.41211d0
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, expo_erfc_mu_gauss ]
|
||||
implicit none
|
||||
expo_erfc_mu_gauss = expo_erfc_gauss * mu_erf * mu_erf
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, expo_good_j_mu_1gauss ]
|
||||
&BEGIN_PROVIDER [ double precision, coef_good_j_mu_1gauss ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! exponent of Gaussian in order to obtain an upper bound of J(r12,mu)
|
||||
!
|
||||
! Can be used to scree integrals with J(r12,mu)
|
||||
END_DOC
|
||||
expo_good_j_mu_1gauss = 2.D0 * mu_erf * expo_j_xmu_1gauss
|
||||
coef_good_j_mu_1gauss = 0.5d0/mu_erf * coef_j_xmu_1gauss
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, expo_j_xmu, (n_fit_1_erf_x) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! F(x) = x * (1 - erf(x)) - 1/sqrt(pi) * exp(-x**2) is fitted with a gaussian and a Slater
|
||||
!
|
||||
! \approx - 1/sqrt(pi) * exp(-alpha * x ) exp(-beta * x**2)
|
||||
!
|
||||
! where alpha = expo_j_xmu(1) and beta = expo_j_xmu(2)
|
||||
END_DOC
|
||||
expo_j_xmu(1) = 1.7477d0
|
||||
expo_j_xmu(2) = 0.668662d0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, expo_gauss_j_mu_x, (ng_fit_jast)]
|
||||
&BEGIN_PROVIDER [double precision, coef_gauss_j_mu_x, (ng_fit_jast)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! J(mu,r12) = 1/2 r12 * (1 - erf(mu*r12)) - 1/(2 sqrt(pi)*mu) exp(-(mu*r12)^2) is expressed as
|
||||
!
|
||||
! J(mu,r12) = 0.5/mu * F(r12*mu) where F(x) = x * (1 - erf(x)) - 1/sqrt(pi) * exp(-x**2)
|
||||
!
|
||||
! F(x) is fitted by - 1/sqrt(pi) * exp(-alpha * x) exp(-beta * x^2) (see expo_j_xmu)
|
||||
!
|
||||
! The slater function exp(-alpha * x) is fitted with n_max_fit_slat gaussians
|
||||
!
|
||||
! See Appendix 2 of JCP 154, 084119 (2021)
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i
|
||||
double precision :: tmp
|
||||
double precision :: expos(ng_fit_jast), alpha, beta
|
||||
|
||||
if(ng_fit_jast .eq. 1) then
|
||||
|
||||
coef_gauss_j_mu_x = (/ -0.47947881d0 /)
|
||||
expo_gauss_j_mu_x = (/ 3.4987848d0 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_j_mu_x(i) = tmp * expo_gauss_j_mu_x(i)
|
||||
enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 2) then
|
||||
|
||||
coef_gauss_j_mu_x = (/ -0.18390742d0, -0.35512656d0 /)
|
||||
expo_gauss_j_mu_x = (/ 31.9279947d0 , 2.11428789d0 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_j_mu_x(i) = tmp * expo_gauss_j_mu_x(i)
|
||||
enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 3) then
|
||||
|
||||
coef_gauss_j_mu_x = (/ -0.07501725d0, -0.28499012d0, -0.1953932d0 /)
|
||||
expo_gauss_j_mu_x = (/ 206.74058566d0, 1.72974157d0, 11.18735164d0 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_j_mu_x(i) = tmp * expo_gauss_j_mu_x(i)
|
||||
enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 5) then
|
||||
|
||||
coef_gauss_j_mu_x = (/ -0.01832955d0 , -0.10188952d0 , -0.20710858d0 , -0.18975032d0 , -0.04641657d0 /)
|
||||
expo_gauss_j_mu_x = (/ 4.33116687d+03, 2.61292842d+01, 1.43447161d+00, 4.92767426d+00, 2.10654699d+02 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_j_mu_x(i) = tmp * expo_gauss_j_mu_x(i)
|
||||
enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 6) then
|
||||
|
||||
coef_gauss_j_mu_x = (/ -0.08783664d0 , -0.16088711d0 , -0.18464486d0 , -0.0368509d0 , -0.08130028d0 , -0.0126972d0 /)
|
||||
expo_gauss_j_mu_x = (/ 4.09729729d+01, 7.11620618d+00, 2.03692338d+00, 4.10831731d+02, 1.12480198d+00, 1.00000000d+04 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_j_mu_x(i) = tmp * expo_gauss_j_mu_x(i)
|
||||
enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 7) then
|
||||
|
||||
coef_gauss_j_mu_x = (/ -0.01756495d0 , -0.01023623d0 , -0.06548959d0 , -0.03539446d0 , -0.17150646d0 , -0.15071096d0 , -0.11326834d0 /)
|
||||
expo_gauss_j_mu_x = (/ 9.88572565d+02, 1.21363371d+04, 3.69794870d+01, 1.67364529d+02, 3.03962934d+00, 1.27854005d+00, 9.76383343d+00 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_j_mu_x(i) = tmp * expo_gauss_j_mu_x(i)
|
||||
enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 8) then
|
||||
|
||||
coef_gauss_j_mu_x = (/ -0.11489205d0 , -0.16008968d0 , -0.12892456d0 , -0.04250838d0 , -0.0718451d0 , -0.02394051d0 , -0.00913353d0 , -0.01285182d0 /)
|
||||
expo_gauss_j_mu_x = (/ 6.97632442d+00, 2.56010878d+00, 1.22760977d+00, 7.47697124d+01, 2.16104215d+01, 2.96549728d+02, 1.40773328d+04, 1.43335159d+03 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_j_mu_x(i) = tmp * expo_gauss_j_mu_x(i)
|
||||
enddo
|
||||
|
||||
!elseif(ng_fit_jast .eq. 9) then
|
||||
|
||||
! coef_gauss_j_mu_x = (/ /)
|
||||
! expo_gauss_j_mu_x = (/ /)
|
||||
|
||||
! tmp = mu_erf * mu_erf
|
||||
! do i = 1, ng_fit_jast
|
||||
! expo_gauss_j_mu_x(i) = tmp * expo_gauss_j_mu_x(i)
|
||||
! enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 20) then
|
||||
|
||||
ASSERT(n_max_fit_slat == 20)
|
||||
|
||||
alpha = expo_j_xmu(1) * mu_erf
|
||||
call expo_fit_slater_gam(alpha, expos)
|
||||
beta = expo_j_xmu(2) * mu_erf * mu_erf
|
||||
|
||||
tmp = -1.0d0 / sqrt(dacos(-1.d0))
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_j_mu_x(i) = expos(i) + beta
|
||||
coef_gauss_j_mu_x(i) = tmp * coef_fit_slat_gauss(i)
|
||||
enddo
|
||||
|
||||
else
|
||||
|
||||
print *, ' not implemented yet'
|
||||
stop
|
||||
|
||||
endif
|
||||
|
||||
tmp = 0.5d0 / mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
coef_gauss_j_mu_x(i) = tmp * coef_gauss_j_mu_x(i)
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, expo_gauss_j_mu_x_2, (ng_fit_jast)]
|
||||
&BEGIN_PROVIDER [double precision, coef_gauss_j_mu_x_2, (ng_fit_jast)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! J(mu,r12)^2 = 0.25/mu^2 F(r12*mu)^2
|
||||
!
|
||||
! F(x)^2 = 1/pi * exp(-2 * alpha * x) exp(-2 * beta * x^2)
|
||||
!
|
||||
! The slater function exp(-2 * alpha * x) is fitted with n_max_fit_slat gaussians
|
||||
!
|
||||
! See Appendix 2 of JCP 154, 084119 (2021)
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i
|
||||
double precision :: tmp
|
||||
double precision :: expos(ng_fit_jast), alpha, beta
|
||||
double precision :: alpha_opt, beta_opt
|
||||
|
||||
if(ng_fit_jast .eq. 1) then
|
||||
|
||||
coef_gauss_j_mu_x_2 = (/ 0.26699573d0 /)
|
||||
expo_gauss_j_mu_x_2 = (/ 11.71029824d0 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_j_mu_x_2(i) = tmp * expo_gauss_j_mu_x_2(i)
|
||||
enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 2) then
|
||||
|
||||
coef_gauss_j_mu_x_2 = (/ 0.11627934d0 , 0.18708824d0 /)
|
||||
expo_gauss_j_mu_x_2 = (/ 102.41386863d0, 6.36239771d0 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_j_mu_x_2(i) = tmp * expo_gauss_j_mu_x_2(i)
|
||||
enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 3) then
|
||||
|
||||
coef_gauss_j_mu_x_2 = (/ 0.04947216d0 , 0.14116238d0, 0.12276501d0 /)
|
||||
expo_gauss_j_mu_x_2 = (/ 635.29701766d0, 4.87696954d0, 33.36745891d0 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_j_mu_x_2(i) = tmp * expo_gauss_j_mu_x_2(i)
|
||||
enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 5) then
|
||||
|
||||
coef_gauss_j_mu_x_2 = (/ 0.01461527d0 , 0.03257147d0 , 0.08831354d0 , 0.11411794d0 , 0.06858783d0 /)
|
||||
expo_gauss_j_mu_x_2 = (/ 8.76554470d+03, 4.90224577d+02, 3.68267125d+00, 1.29663940d+01, 6.58240931d+01 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_j_mu_x_2(i) = tmp * expo_gauss_j_mu_x_2(i)
|
||||
enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 6) then
|
||||
|
||||
coef_gauss_j_mu_x_2 = (/ 0.01347632d0 , 0.03929124d0 , 0.06289468d0 , 0.10702493d0 , 0.06999865d0 , 0.02558191d0 /)
|
||||
expo_gauss_j_mu_x_2 = (/ 1.00000000d+04, 1.20900717d+02, 3.20346191d+00, 8.92157196d+00, 3.28119120d+01, 6.49045808d+02 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_j_mu_x_2(i) = tmp * expo_gauss_j_mu_x_2(i)
|
||||
enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 7) then
|
||||
|
||||
coef_gauss_j_mu_x_2 = (/ 0.05202849d0 , 0.01031081d0 , 0.04699157d0 , 0.01451002d0 , 0.07442576d0 , 0.02692033d0 , 0.09311842d0 /)
|
||||
expo_gauss_j_mu_x_2 = (/ 3.04469415d+00, 1.40682034d+04, 7.45960945d+01, 1.43067466d+03, 2.16815661d+01, 2.95750306d+02, 7.23471236d+00 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_j_mu_x_2(i) = tmp * expo_gauss_j_mu_x_2(i)
|
||||
enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 8) then
|
||||
|
||||
coef_gauss_j_mu_x_2 = (/ 0.00942115d0 , 0.07332421d0 , 0.0508308d0 , 0.08204949d0 , 0.0404099d0 , 0.03201288d0 , 0.01911313d0 , 0.01114732d0 /)
|
||||
expo_gauss_j_mu_x_2 = (/ 1.56957321d+04, 1.52867810d+01, 4.36016903d+01, 5.96818956d+00, 2.85535269d+00, 1.36064008d+02, 4.71968910d+02, 1.92022350d+03 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_j_mu_x_2(i) = tmp * expo_gauss_j_mu_x_2(i)
|
||||
enddo
|
||||
|
||||
!elseif(ng_fit_jast .eq. 9) then
|
||||
|
||||
! coef_gauss_j_mu_x_2 = (/ /)
|
||||
! expo_gauss_j_mu_x_2 = (/ /)
|
||||
!
|
||||
! tmp = mu_erf * mu_erf
|
||||
! do i = 1, ng_fit_jast
|
||||
! expo_gauss_j_mu_x_2(i) = tmp * expo_gauss_j_mu_x_2(i)
|
||||
! enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 20) then
|
||||
|
||||
ASSERT(n_max_fit_slat == 20)
|
||||
|
||||
!alpha_opt = 2.d0 * expo_j_xmu(1)
|
||||
!beta_opt = 2.d0 * expo_j_xmu(2)
|
||||
|
||||
! direct opt
|
||||
alpha_opt = 3.52751759d0
|
||||
beta_opt = 1.26214809d0
|
||||
|
||||
alpha = alpha_opt * mu_erf
|
||||
call expo_fit_slater_gam(alpha, expos)
|
||||
beta = beta_opt * mu_erf * mu_erf
|
||||
|
||||
tmp = 1.d0 / dacos(-1.d0)
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_j_mu_x_2(i) = expos(i) + beta
|
||||
coef_gauss_j_mu_x_2(i) = tmp * coef_fit_slat_gauss(i)
|
||||
enddo
|
||||
|
||||
else
|
||||
|
||||
print *, ' not implemented yet'
|
||||
stop
|
||||
|
||||
endif
|
||||
|
||||
tmp = 0.25d0 / (mu_erf * mu_erf)
|
||||
do i = 1, ng_fit_jast
|
||||
coef_gauss_j_mu_x_2(i) = tmp * coef_gauss_j_mu_x_2(i)
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, expo_gauss_j_mu_1_erf, (ng_fit_jast)]
|
||||
&BEGIN_PROVIDER [double precision, coef_gauss_j_mu_1_erf, (ng_fit_jast)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! J(mu,r12) x \frac{1 - erf(mu * r12)}{2} =
|
||||
!
|
||||
! - \frac{1}{4 \sqrt{\pi} \mu} \exp(-(alpha1 + alpha2) * mu * r12 - (beta1 + beta2) * mu^2 * r12^2)
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i
|
||||
double precision :: tmp
|
||||
double precision :: expos(ng_fit_jast), alpha, beta
|
||||
double precision :: alpha_opt, beta_opt
|
||||
|
||||
if(ng_fit_jast .eq. 1) then
|
||||
|
||||
coef_gauss_j_mu_1_erf = (/ -0.47742461d0 /)
|
||||
expo_gauss_j_mu_1_erf = (/ 8.72255696d0 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_j_mu_1_erf(i) = tmp * expo_gauss_j_mu_1_erf(i)
|
||||
enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 2) then
|
||||
|
||||
coef_gauss_j_mu_1_erf = (/ -0.19342649d0, -0.34563835d0 /)
|
||||
expo_gauss_j_mu_1_erf = (/ 78.66099999d0, 5.04324363d0 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_j_mu_1_erf(i) = tmp * expo_gauss_j_mu_1_erf(i)
|
||||
enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 3) then
|
||||
|
||||
coef_gauss_j_mu_1_erf = (/ -0.0802541d0 , -0.27019258d0, -0.20546681d0 /)
|
||||
expo_gauss_j_mu_1_erf = (/ 504.53350764d0, 4.01408169d0, 26.5758329d0 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_j_mu_1_erf(i) = tmp * expo_gauss_j_mu_1_erf(i)
|
||||
enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 5) then
|
||||
|
||||
coef_gauss_j_mu_1_erf = (/ -0.02330531d0 , -0.11888176d0 , -0.16476192d0 , -0.19874713d0 , -0.05889174d0 /)
|
||||
expo_gauss_j_mu_1_erf = (/ 1.00000000d+04, 4.66067922d+01, 3.04359857d+00, 9.54726649d+00, 3.59796835d+02 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_j_mu_1_erf(i) = tmp * expo_gauss_j_mu_1_erf(i)
|
||||
enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 6) then
|
||||
|
||||
coef_gauss_j_mu_1_erf = (/ -0.01865654d0 , -0.18319251d0 , -0.06543196d0 , -0.11522778d0 , -0.14825793d0 , -0.03327101d0 /)
|
||||
expo_gauss_j_mu_1_erf = (/ 1.00000000d+04, 8.05593848d+00, 1.27986190d+02, 2.92674319d+01, 2.93583623d+00, 7.65609148d+02 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_j_mu_1_erf(i) = tmp * expo_gauss_j_mu_1_erf(i)
|
||||
enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 7) then
|
||||
|
||||
coef_gauss_j_mu_1_erf = (/ -0.11853067d0 , -0.01522824d0 , -0.07419098d0 , -0.022202d0 , -0.12242283d0 , -0.04177571d0 , -0.16983107d0 /)
|
||||
expo_gauss_j_mu_1_erf = (/ 2.74057056d+00, 1.37626591d+04, 6.65578663d+01, 1.34693031d+03, 1.90547699d+01, 2.69445390d+02, 6.31845879d+00/)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_j_mu_1_erf(i) = tmp * expo_gauss_j_mu_1_erf(i)
|
||||
enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 8) then
|
||||
|
||||
coef_gauss_j_mu_1_erf = (/ -0.12263328d0 , -0.04965255d0 , -0.15463564d0 , -0.09675781d0 , -0.0807023d0 , -0.02923298d0 , -0.01381381d0 , -0.01675923d0 /)
|
||||
expo_gauss_j_mu_1_erf = (/ 1.36101994d+01, 1.24908367d+02, 5.29061388d+00, 2.60692516d+00, 3.93396935d+01, 4.43071610d+02, 1.54902240d+04, 1.85170446d+03 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_j_mu_1_erf(i) = tmp * expo_gauss_j_mu_1_erf(i)
|
||||
enddo
|
||||
|
||||
!elseif(ng_fit_jast .eq. 9) then
|
||||
|
||||
! coef_gauss_j_mu_1_erf = (/ /)
|
||||
! expo_gauss_j_mu_1_erf = (/ /)
|
||||
|
||||
! tmp = mu_erf * mu_erf
|
||||
! do i = 1, ng_fit_jast
|
||||
! expo_gauss_j_mu_1_erf(i) = tmp * expo_gauss_j_mu_1_erf(i)
|
||||
! enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 20) then
|
||||
|
||||
ASSERT(n_max_fit_slat == 20)
|
||||
|
||||
!alpha_opt = expo_j_xmu(1) + expo_gauss_1_erf_x(1)
|
||||
!beta_opt = expo_j_xmu(2) + expo_gauss_1_erf_x(2)
|
||||
|
||||
! direct opt
|
||||
alpha_opt = 2.87875632d0
|
||||
beta_opt = 1.34801003d0
|
||||
|
||||
alpha = alpha_opt * mu_erf
|
||||
call expo_fit_slater_gam(alpha, expos)
|
||||
beta = beta_opt * mu_erf * mu_erf
|
||||
|
||||
tmp = -1.d0 / dsqrt(dacos(-1.d0))
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_j_mu_1_erf(i) = expos(i) + beta
|
||||
coef_gauss_j_mu_1_erf(i) = tmp * coef_fit_slat_gauss(i)
|
||||
enddo
|
||||
|
||||
else
|
||||
|
||||
print *, ' not implemented yet'
|
||||
stop
|
||||
|
||||
endif
|
||||
|
||||
tmp = 0.25d0 / mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
coef_gauss_j_mu_1_erf(i) = tmp * coef_gauss_j_mu_1_erf(i)
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
double precision function F_x_j(x)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! F_x_j(x) = dimension-less correlation factor = x (1 - erf(x)) - 1/sqrt(pi) exp(-x^2)
|
||||
END_DOC
|
||||
double precision, intent(in) :: x
|
||||
F_x_j = x * (1.d0 - derf(x)) - 1/dsqrt(dacos(-1.d0)) * dexp(-x**2)
|
||||
|
||||
end
|
||||
|
||||
double precision function j_mu_F_x_j(x)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! j_mu_F_x_j(x) = correlation factor = 1/2 r12 * (1 - erf(mu*r12)) - 1/(2 sqrt(pi)*mu) exp(-(mu*r12)^2)
|
||||
!
|
||||
! = 1/(2*mu) * F_x_j(mu*x)
|
||||
END_DOC
|
||||
double precision :: F_x_j
|
||||
double precision, intent(in) :: x
|
||||
j_mu_F_x_j = 0.5d0/mu_erf * F_x_j(x*mu_erf)
|
||||
end
|
||||
|
||||
double precision function j_mu(x)
|
||||
implicit none
|
||||
double precision, intent(in) :: x
|
||||
BEGIN_DOC
|
||||
! j_mu(x) = correlation factor = 1/2 r12 * (1 - erf(mu*r12)) - 1/(2 sqrt(pi)*mu) exp(-(mu*r12)^2)
|
||||
END_DOC
|
||||
j_mu = 0.5d0* x * (1.d0 - derf(mu_erf*x)) - 0.5d0/( dsqrt(dacos(-1.d0))*mu_erf) * dexp(-(mu_erf*x)*(mu_erf*x))
|
||||
|
||||
end
|
||||
|
||||
double precision function j_mu_fit_gauss(x)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! j_mu_fit_gauss(x) = correlation factor = 1/2 r12 * (1 - erf(mu*r12)) - 1/(2 sqrt(pi)*mu) exp(-(mu*r12)^2)
|
||||
!
|
||||
! but fitted with gaussians
|
||||
END_DOC
|
||||
double precision, intent(in) :: x
|
||||
integer :: i
|
||||
double precision :: alpha,coef
|
||||
j_mu_fit_gauss = 0.d0
|
||||
do i = 1, n_max_fit_slat
|
||||
alpha = expo_gauss_j_mu_x(i)
|
||||
coef = coef_gauss_j_mu_x(i)
|
||||
j_mu_fit_gauss += coef * dexp(-alpha*x*x)
|
||||
enddo
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
194
src/ao_tc_eff_map/integrals_eff_pot_in_map_slave.irp.f
Normal file
194
src/ao_tc_eff_map/integrals_eff_pot_in_map_slave.irp.f
Normal file
@ -0,0 +1,194 @@
|
||||
subroutine ao_tc_sym_two_e_pot_in_map_slave_tcp(i)
|
||||
implicit none
|
||||
integer, intent(in) :: i
|
||||
BEGIN_DOC
|
||||
! Computes a buffer of integrals. i is the ID of the current thread.
|
||||
END_DOC
|
||||
call ao_tc_sym_two_e_pot_in_map_slave(0,i)
|
||||
end
|
||||
|
||||
|
||||
subroutine ao_tc_sym_two_e_pot_in_map_slave_inproc(i)
|
||||
implicit none
|
||||
integer, intent(in) :: i
|
||||
BEGIN_DOC
|
||||
! Computes a buffer of integrals. i is the ID of the current thread.
|
||||
END_DOC
|
||||
call ao_tc_sym_two_e_pot_in_map_slave(1,i)
|
||||
end
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
subroutine ao_tc_sym_two_e_pot_in_map_slave(thread,iproc)
|
||||
use map_module
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Computes a buffer of integrals
|
||||
END_DOC
|
||||
|
||||
integer, intent(in) :: thread, iproc
|
||||
|
||||
integer :: j,l,n_integrals
|
||||
integer :: rc
|
||||
real(integral_kind), allocatable :: buffer_value(:)
|
||||
integer(key_kind), allocatable :: buffer_i(:)
|
||||
|
||||
integer :: worker_id, task_id
|
||||
character*(512) :: task
|
||||
|
||||
integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
|
||||
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
|
||||
|
||||
integer(ZMQ_PTR), external :: new_zmq_push_socket
|
||||
integer(ZMQ_PTR) :: zmq_socket_push
|
||||
|
||||
character*(64) :: state
|
||||
|
||||
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
|
||||
|
||||
integer, external :: connect_to_taskserver
|
||||
if (connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) == -1) then
|
||||
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
|
||||
return
|
||||
endif
|
||||
|
||||
zmq_socket_push = new_zmq_push_socket(thread)
|
||||
|
||||
allocate ( buffer_i(ao_num*ao_num), buffer_value(ao_num*ao_num) )
|
||||
|
||||
|
||||
do
|
||||
integer, external :: get_task_from_taskserver
|
||||
if (get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task) == -1) then
|
||||
exit
|
||||
endif
|
||||
if (task_id == 0) exit
|
||||
read(task,*) j, l
|
||||
integer, external :: task_done_to_taskserver
|
||||
call compute_ao_tc_sym_two_e_pot_jl(j,l,n_integrals,buffer_i,buffer_value)
|
||||
if (task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) == -1) then
|
||||
stop 'Unable to send task_done'
|
||||
endif
|
||||
call push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, task_id)
|
||||
enddo
|
||||
|
||||
integer, external :: disconnect_from_taskserver
|
||||
if (disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id) == -1) then
|
||||
continue
|
||||
endif
|
||||
deallocate( buffer_i, buffer_value )
|
||||
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
|
||||
call end_zmq_push_socket(zmq_socket_push,thread)
|
||||
|
||||
end
|
||||
|
||||
|
||||
subroutine ao_tc_sym_two_e_pot_in_map_collector(zmq_socket_pull)
|
||||
use map_module
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Collects results from the AO integral calculation
|
||||
END_DOC
|
||||
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
|
||||
integer :: j,l,n_integrals
|
||||
integer :: rc
|
||||
|
||||
real(integral_kind), allocatable :: buffer_value(:)
|
||||
integer(key_kind), allocatable :: buffer_i(:)
|
||||
|
||||
integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
|
||||
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
|
||||
|
||||
integer(ZMQ_PTR), external :: new_zmq_pull_socket
|
||||
|
||||
integer*8 :: control, accu, sze
|
||||
integer :: task_id, more
|
||||
|
||||
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
|
||||
|
||||
sze = ao_num*ao_num
|
||||
allocate ( buffer_i(sze), buffer_value(sze) )
|
||||
|
||||
accu = 0_8
|
||||
more = 1
|
||||
do while (more == 1)
|
||||
|
||||
rc = f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0)
|
||||
if (rc == -1) then
|
||||
n_integrals = 0
|
||||
return
|
||||
endif
|
||||
if (rc /= 4) then
|
||||
print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0)'
|
||||
stop 'error'
|
||||
endif
|
||||
|
||||
if (n_integrals >= 0) then
|
||||
|
||||
if (n_integrals > sze) then
|
||||
deallocate (buffer_value, buffer_i)
|
||||
sze = n_integrals
|
||||
allocate (buffer_value(sze), buffer_i(sze))
|
||||
endif
|
||||
|
||||
rc = f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0)
|
||||
if (rc /= key_kind*n_integrals) then
|
||||
print *, rc, key_kind, n_integrals
|
||||
print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0)'
|
||||
stop 'error'
|
||||
endif
|
||||
|
||||
rc = f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0)
|
||||
if (rc /= integral_kind*n_integrals) then
|
||||
print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0)'
|
||||
stop 'error'
|
||||
endif
|
||||
|
||||
rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0)
|
||||
|
||||
IRP_IF ZMQ_PUSH
|
||||
IRP_ELSE
|
||||
rc = f77_zmq_send( zmq_socket_pull, 0, 4, 0)
|
||||
if (rc /= 4) then
|
||||
print *, irp_here, ' : f77_zmq_send (zmq_socket_pull,...'
|
||||
stop 'error'
|
||||
endif
|
||||
IRP_ENDIF
|
||||
|
||||
|
||||
call insert_into_ao_tc_sym_two_e_pot_map(n_integrals,buffer_i,buffer_value)
|
||||
accu += n_integrals
|
||||
if (task_id /= 0) then
|
||||
integer, external :: zmq_delete_task
|
||||
if (zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more) == -1) then
|
||||
stop 'Unable to delete task'
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
|
||||
enddo
|
||||
|
||||
deallocate( buffer_i, buffer_value )
|
||||
|
||||
integer (map_size_kind) :: get_ao_tc_sym_two_e_pot_map_size
|
||||
control = get_ao_tc_sym_two_e_pot_map_size(ao_tc_sym_two_e_pot_map)
|
||||
|
||||
if (control /= accu) then
|
||||
print *, ''
|
||||
print *, irp_here
|
||||
print *, 'Control : ', control
|
||||
print *, 'Accu : ', accu
|
||||
print *, 'Some integrals were lost during the parallel computation.'
|
||||
print *, 'Try to reduce the number of threads.'
|
||||
stop
|
||||
endif
|
||||
|
||||
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
|
||||
|
||||
end
|
||||
|
||||
313
src/ao_tc_eff_map/map_integrals_eff_pot.irp.f
Normal file
313
src/ao_tc_eff_map/map_integrals_eff_pot.irp.f
Normal file
@ -0,0 +1,313 @@
|
||||
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
|
||||
|
||||
integer :: i,j,k,l,ii
|
||||
integer(key_kind) :: idx
|
||||
real(integral_kind) :: integral
|
||||
|
||||
PROVIDE ao_tc_sym_two_e_pot_in_map
|
||||
|
||||
!$OMP PARALLEL DO PRIVATE (i,j,k,l,idx,ii,integral)
|
||||
do l = ao_tc_sym_two_e_pot_cache_min, ao_tc_sym_two_e_pot_cache_max
|
||||
do k = ao_tc_sym_two_e_pot_cache_min, ao_tc_sym_two_e_pot_cache_max
|
||||
do j = ao_tc_sym_two_e_pot_cache_min, ao_tc_sym_two_e_pot_cache_max
|
||||
do i = ao_tc_sym_two_e_pot_cache_min, ao_tc_sym_two_e_pot_cache_max
|
||||
!DIR$ FORCEINLINE
|
||||
call two_e_integrals_index(i, j, k, l, idx)
|
||||
!DIR$ FORCEINLINE
|
||||
call map_get(ao_tc_sym_two_e_pot_map, idx, integral)
|
||||
ii = l-ao_tc_sym_two_e_pot_cache_min
|
||||
ii = ior( ishft(ii,6), k-ao_tc_sym_two_e_pot_cache_min)
|
||||
ii = ior( ishft(ii,6), j-ao_tc_sym_two_e_pot_cache_min)
|
||||
ii = ior( ishft(ii,6), i-ao_tc_sym_two_e_pot_cache_min)
|
||||
ao_tc_sym_two_e_pot_cache(ii) = integral
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
|
||||
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
|
||||
|
||||
|
||||
|
||||
|
||||
332
src/ao_tc_eff_map/one_e_1bgauss_grad2.irp.f
Normal file
332
src/ao_tc_eff_map/one_e_1bgauss_grad2.irp.f
Normal file
@ -0,0 +1,332 @@
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, j1b_gauss_hermII, (ao_num,ao_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! :math:`\langle \chi_A | -0.5 \grad \tau_{1b} \cdot \grad \tau_{1b} | \chi_B \rangle`
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
integer :: num_A, num_B
|
||||
integer :: power_A(3), power_B(3)
|
||||
integer :: i, j, k1, k2, l, m
|
||||
double precision :: alpha, beta, gama1, gama2, coef1, coef2
|
||||
double precision :: A_center(3), B_center(3), C_center1(3), C_center2(3)
|
||||
double precision :: c1, c
|
||||
|
||||
integer :: dim1
|
||||
double precision :: overlap_y, d_a_2, overlap_z, overlap
|
||||
|
||||
double precision :: int_gauss_4G
|
||||
|
||||
PROVIDE j1b_type j1b_pen j1b_coeff
|
||||
|
||||
! --------------------------------------------------------------------------------
|
||||
! -- Dummy call to provide everything
|
||||
dim1 = 100
|
||||
A_center(:) = 0.d0
|
||||
B_center(:) = 1.d0
|
||||
alpha = 1.d0
|
||||
beta = 0.1d0
|
||||
power_A(:) = 1
|
||||
power_B(:) = 0
|
||||
call overlap_gaussian_xyz( A_center, B_center, alpha, beta, power_A, power_B &
|
||||
, overlap_y, d_a_2, overlap_z, overlap, dim1 )
|
||||
! --------------------------------------------------------------------------------
|
||||
|
||||
|
||||
j1b_gauss_hermII(1:ao_num,1:ao_num) = 0.d0
|
||||
|
||||
if(j1b_type .eq. 1) then
|
||||
! \tau_1b = \sum_iA -[1 - exp(-alpha_A r_iA^2)]
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i, j, k1, k2, l, m, alpha, beta, gama1, gama2, &
|
||||
!$OMP A_center, B_center, C_center1, C_center2, &
|
||||
!$OMP power_A, power_B, num_A, num_B, c1, c) &
|
||||
!$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, &
|
||||
!$OMP ao_power, ao_nucl, nucl_coord, &
|
||||
!$OMP ao_coef_normalized_ordered_transp, &
|
||||
!$OMP nucl_num, j1b_pen, j1b_gauss_hermII)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do j = 1, ao_num
|
||||
num_A = ao_nucl(j)
|
||||
power_A(1:3) = ao_power(j,1:3)
|
||||
A_center(1:3) = nucl_coord(num_A,1:3)
|
||||
|
||||
do i = 1, ao_num
|
||||
num_B = ao_nucl(i)
|
||||
power_B(1:3) = ao_power(i,1:3)
|
||||
B_center(1:3) = nucl_coord(num_B,1:3)
|
||||
|
||||
do l = 1, ao_prim_num(j)
|
||||
alpha = ao_expo_ordered_transp(l,j)
|
||||
|
||||
do m = 1, ao_prim_num(i)
|
||||
beta = ao_expo_ordered_transp(m,i)
|
||||
|
||||
c = 0.d0
|
||||
do k1 = 1, nucl_num
|
||||
gama1 = j1b_pen(k1)
|
||||
C_center1(1:3) = nucl_coord(k1,1:3)
|
||||
|
||||
do k2 = 1, nucl_num
|
||||
gama2 = j1b_pen(k2)
|
||||
C_center2(1:3) = nucl_coord(k2,1:3)
|
||||
|
||||
! < XA | exp[-gama1 r_C1^2 -gama2 r_C2^2] r_C1 \cdot r_C2 | XB >
|
||||
c1 = int_gauss_4G( A_center, B_center, C_center1, C_center2 &
|
||||
, power_A, power_B, alpha, beta, gama1, gama2 )
|
||||
|
||||
c = c - 2.d0 * gama1 * gama2 * c1
|
||||
enddo
|
||||
enddo
|
||||
|
||||
j1b_gauss_hermII(i,j) = j1b_gauss_hermII(i,j) &
|
||||
+ ao_coef_normalized_ordered_transp(l,j) &
|
||||
* ao_coef_normalized_ordered_transp(m,i) * c
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
elseif(j1b_type .eq. 2) then
|
||||
! \tau_1b = \sum_iA [c_A exp(-alpha_A r_iA^2)]
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i, j, k1, k2, l, m, alpha, beta, gama1, gama2, &
|
||||
!$OMP A_center, B_center, C_center1, C_center2, &
|
||||
!$OMP power_A, power_B, num_A, num_B, c1, c, &
|
||||
!$OMP coef1, coef2) &
|
||||
!$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, &
|
||||
!$OMP ao_power, ao_nucl, nucl_coord, &
|
||||
!$OMP ao_coef_normalized_ordered_transp, &
|
||||
!$OMP nucl_num, j1b_pen, j1b_gauss_hermII, &
|
||||
!$OMP j1b_coeff)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do j = 1, ao_num
|
||||
num_A = ao_nucl(j)
|
||||
power_A(1:3) = ao_power(j,1:3)
|
||||
A_center(1:3) = nucl_coord(num_A,1:3)
|
||||
|
||||
do i = 1, ao_num
|
||||
num_B = ao_nucl(i)
|
||||
power_B(1:3) = ao_power(i,1:3)
|
||||
B_center(1:3) = nucl_coord(num_B,1:3)
|
||||
|
||||
do l = 1, ao_prim_num(j)
|
||||
alpha = ao_expo_ordered_transp(l,j)
|
||||
|
||||
do m = 1, ao_prim_num(i)
|
||||
beta = ao_expo_ordered_transp(m,i)
|
||||
|
||||
c = 0.d0
|
||||
do k1 = 1, nucl_num
|
||||
gama1 = j1b_pen (k1)
|
||||
coef1 = j1b_coeff(k1)
|
||||
C_center1(1:3) = nucl_coord(k1,1:3)
|
||||
|
||||
do k2 = 1, nucl_num
|
||||
gama2 = j1b_pen (k2)
|
||||
coef2 = j1b_coeff(k2)
|
||||
C_center2(1:3) = nucl_coord(k2,1:3)
|
||||
|
||||
! < XA | exp[-gama1 r_C1^2 -gama2 r_C2^2] r_C1 \cdot r_C2 | XB >
|
||||
c1 = int_gauss_4G( A_center, B_center, C_center1, C_center2 &
|
||||
, power_A, power_B, alpha, beta, gama1, gama2 )
|
||||
|
||||
c = c - 2.d0 * gama1 * gama2 * coef1 * coef2 * c1
|
||||
enddo
|
||||
enddo
|
||||
|
||||
j1b_gauss_hermII(i,j) = j1b_gauss_hermII(i,j) &
|
||||
+ ao_coef_normalized_ordered_transp(l,j) &
|
||||
* ao_coef_normalized_ordered_transp(m,i) * c
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
!_____________________________________________________________________________________________________________
|
||||
!
|
||||
! < XA | exp[-gama1 r_C1^2 -gama2 r_C2^2] r_C1 \cdot r_C2 | XB >
|
||||
!
|
||||
double precision function int_gauss_4G( A_center, B_center, C_center1, C_center2, power_A, power_B &
|
||||
, alpha, beta, gama1, gama2 )
|
||||
|
||||
! for max_dim
|
||||
include 'constants.include.F'
|
||||
|
||||
implicit none
|
||||
|
||||
integer , intent(in) :: power_A(3), power_B(3)
|
||||
double precision, intent(in) :: A_center(3), B_center(3), C_center1(3), C_center2(3)
|
||||
double precision, intent(in) :: alpha, beta, gama1, gama2
|
||||
|
||||
integer :: i, dim1, power_C
|
||||
integer :: iorder(3)
|
||||
double precision :: AB_expo, fact_AB, AB_center(3), P_AB(0:max_dim,3)
|
||||
double precision :: gama, fact_C, C_center(3)
|
||||
double precision :: cx0, cy0, cz0, c_tmp1, c_tmp2, cx, cy, cz
|
||||
double precision :: int_tmp
|
||||
|
||||
double precision :: overlap_gaussian_x
|
||||
|
||||
dim1 = 100
|
||||
|
||||
! P_AB(0:max_dim,3) polynomial
|
||||
! AB_center(3) new center
|
||||
! AB_expo new exponent
|
||||
! fact_AB constant factor
|
||||
! iorder(3) i_order(i) = order of the polynomials
|
||||
call give_explicit_poly_and_gaussian( P_AB, AB_center, AB_expo, fact_AB &
|
||||
, iorder, alpha, beta, power_A, power_B, A_center, B_center, dim1)
|
||||
|
||||
call gaussian_product(gama1, C_center1, gama2, C_center2, fact_C, gama, C_center)
|
||||
|
||||
! <<<
|
||||
! to avoid multi-evaluation
|
||||
power_C = 0
|
||||
|
||||
cx0 = 0.d0
|
||||
do i = 0, iorder(1)
|
||||
cx0 = cx0 + P_AB(i,1) * overlap_gaussian_x( AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1)
|
||||
enddo
|
||||
cy0 = 0.d0
|
||||
do i = 0, iorder(2)
|
||||
cy0 = cy0 + P_AB(i,2) * overlap_gaussian_x( AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1)
|
||||
enddo
|
||||
cz0 = 0.d0
|
||||
do i = 0, iorder(3)
|
||||
cz0 = cz0 + P_AB(i,3) * overlap_gaussian_x( AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1)
|
||||
enddo
|
||||
! >>>
|
||||
|
||||
int_tmp = 0.d0
|
||||
|
||||
! -----------------------------------------------------------------------------------------------
|
||||
!
|
||||
! x term:
|
||||
! < XA | exp[-gama1 r_C1^2 -gama2 r_C2^2] (x - x_C1) (x - x_C2) | XB >
|
||||
!
|
||||
|
||||
c_tmp1 = 2.d0 * C_center(1) - C_center1(1) - C_center2(1)
|
||||
c_tmp2 = ( C_center(1) - C_center1(1) ) * ( C_center(1) - C_center2(1) )
|
||||
|
||||
cx = 0.d0
|
||||
do i = 0, iorder(1)
|
||||
|
||||
! < XA | exp[-gama r_C^2] (x - x_C)^2 | XB >
|
||||
power_C = 2
|
||||
cx = cx + P_AB(i,1) &
|
||||
* overlap_gaussian_x( AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1)
|
||||
|
||||
! < XA | exp[-gama r_C^2] (x - x_C) | XB >
|
||||
power_C = 1
|
||||
cx = cx + P_AB(i,1) * c_tmp1 &
|
||||
* overlap_gaussian_x( AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1)
|
||||
|
||||
! < XA | exp[-gama r_C^2] | XB >
|
||||
power_C = 0
|
||||
cx = cx + P_AB(i,1) * c_tmp2 &
|
||||
* overlap_gaussian_x( AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1)
|
||||
|
||||
enddo
|
||||
|
||||
int_tmp += cx * cy0 * cz0
|
||||
|
||||
! -----------------------------------------------------------------------------------------------
|
||||
|
||||
|
||||
! -----------------------------------------------------------------------------------------------
|
||||
!
|
||||
! y term:
|
||||
! < XA | exp[-gama1 r_C1^2 -gama2 r_C2^2] (y - y_C1) (y - y_C2) | XB >
|
||||
!
|
||||
|
||||
c_tmp1 = 2.d0 * C_center(2) - C_center1(2) - C_center2(2)
|
||||
c_tmp2 = ( C_center(2) - C_center1(2) ) * ( C_center(2) - C_center2(2) )
|
||||
|
||||
cy = 0.d0
|
||||
do i = 0, iorder(2)
|
||||
|
||||
! < XA | exp[-gama r_C^2] (y - y_C)^2 | XB >
|
||||
power_C = 2
|
||||
cy = cy + P_AB(i,2) &
|
||||
* overlap_gaussian_x( AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1)
|
||||
|
||||
! < XA | exp[-gama r_C^2] (y - y_C) | XB >
|
||||
power_C = 1
|
||||
cy = cy + P_AB(i,2) * c_tmp1 &
|
||||
* overlap_gaussian_x( AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1)
|
||||
|
||||
! < XA | exp[-gama r_C^2] | XB >
|
||||
power_C = 0
|
||||
cy = cy + P_AB(i,2) * c_tmp2 &
|
||||
* overlap_gaussian_x( AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1)
|
||||
|
||||
enddo
|
||||
|
||||
int_tmp += cx0 * cy * cz0
|
||||
|
||||
! -----------------------------------------------------------------------------------------------
|
||||
|
||||
|
||||
! -----------------------------------------------------------------------------------------------
|
||||
!
|
||||
! z term:
|
||||
! < XA | exp[-gama1 r_C1^2 -gama2 r_C2^2] (z - z_C1) (z - z_C2) | XB >
|
||||
!
|
||||
|
||||
c_tmp1 = 2.d0 * C_center(3) - C_center1(3) - C_center2(3)
|
||||
c_tmp2 = ( C_center(3) - C_center1(3) ) * ( C_center(3) - C_center2(3) )
|
||||
|
||||
cz = 0.d0
|
||||
do i = 0, iorder(3)
|
||||
|
||||
! < XA | exp[-gama r_C^2] (z - z_C)^2 | XB >
|
||||
power_C = 2
|
||||
cz = cz + P_AB(i,3) &
|
||||
* overlap_gaussian_x( AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1)
|
||||
|
||||
! < XA | exp[-gama r_C^2] (z - z_C) | XB >
|
||||
power_C = 1
|
||||
cz = cz + P_AB(i,3) * c_tmp1 &
|
||||
* overlap_gaussian_x( AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1)
|
||||
|
||||
! < XA | exp[-gama r_C^2] | XB >
|
||||
power_C = 0
|
||||
cz = cz + P_AB(i,3) * c_tmp2 &
|
||||
* overlap_gaussian_x( AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1)
|
||||
|
||||
enddo
|
||||
|
||||
int_tmp += cx0 * cy0 * cz
|
||||
|
||||
! -----------------------------------------------------------------------------------------------
|
||||
|
||||
int_gauss_4G = fact_AB * fact_C * int_tmp
|
||||
|
||||
return
|
||||
end function int_gauss_4G
|
||||
!_____________________________________________________________________________________________________________
|
||||
!_____________________________________________________________________________________________________________
|
||||
|
||||
|
||||
303
src/ao_tc_eff_map/one_e_1bgauss_lap.irp.f
Normal file
303
src/ao_tc_eff_map/one_e_1bgauss_lap.irp.f
Normal file
@ -0,0 +1,303 @@
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, j1b_gauss_hermI, (ao_num,ao_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! :math:`\langle \chi_A | -0.5 \Delta \tau_{1b} | \chi_B \rangle`
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
integer :: num_A, num_B
|
||||
integer :: power_A(3), power_B(3)
|
||||
integer :: i, j, k, l, m
|
||||
double precision :: alpha, beta, gama, coef
|
||||
double precision :: A_center(3), B_center(3), C_center(3)
|
||||
double precision :: c1, c2, c
|
||||
|
||||
integer :: dim1
|
||||
double precision :: overlap_y, d_a_2, overlap_z, overlap
|
||||
|
||||
double precision :: int_gauss_r0, int_gauss_r2
|
||||
|
||||
PROVIDE j1b_type j1b_pen j1b_coeff
|
||||
|
||||
! --------------------------------------------------------------------------------
|
||||
! -- Dummy call to provide everything
|
||||
dim1 = 100
|
||||
A_center(:) = 0.d0
|
||||
B_center(:) = 1.d0
|
||||
alpha = 1.d0
|
||||
beta = 0.1d0
|
||||
power_A(:) = 1
|
||||
power_B(:) = 0
|
||||
call overlap_gaussian_xyz( A_center, B_center, alpha, beta, power_A, power_B &
|
||||
, overlap_y, d_a_2, overlap_z, overlap, dim1 )
|
||||
! --------------------------------------------------------------------------------
|
||||
|
||||
j1b_gauss_hermI(1:ao_num,1:ao_num) = 0.d0
|
||||
|
||||
if(j1b_type .eq. 1) then
|
||||
! \tau_1b = \sum_iA -[1 - exp(-alpha_A r_iA^2)]
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i, j, k, l, m, alpha, beta, gama, &
|
||||
!$OMP A_center, B_center, C_center, power_A, power_B, &
|
||||
!$OMP num_A, num_B, c1, c2, c) &
|
||||
!$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, &
|
||||
!$OMP ao_power, ao_nucl, nucl_coord, &
|
||||
!$OMP ao_coef_normalized_ordered_transp, &
|
||||
!$OMP nucl_num, j1b_pen, j1b_gauss_hermI)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do j = 1, ao_num
|
||||
num_A = ao_nucl(j)
|
||||
power_A(1:3) = ao_power(j,1:3)
|
||||
A_center(1:3) = nucl_coord(num_A,1:3)
|
||||
|
||||
do i = 1, ao_num
|
||||
num_B = ao_nucl(i)
|
||||
power_B(1:3) = ao_power(i,1:3)
|
||||
B_center(1:3) = nucl_coord(num_B,1:3)
|
||||
|
||||
do l = 1, ao_prim_num(j)
|
||||
alpha = ao_expo_ordered_transp(l,j)
|
||||
|
||||
do m = 1, ao_prim_num(i)
|
||||
beta = ao_expo_ordered_transp(m,i)
|
||||
|
||||
c = 0.d0
|
||||
do k = 1, nucl_num
|
||||
gama = j1b_pen(k)
|
||||
C_center(1:3) = nucl_coord(k,1:3)
|
||||
|
||||
! < XA | exp[-gama r_C^2] | XB >
|
||||
c1 = int_gauss_r0( A_center, B_center, C_center &
|
||||
, power_A, power_B, alpha, beta, gama )
|
||||
|
||||
! < XA | r_A^2 exp[-gama r_C^2] | XB >
|
||||
c2 = int_gauss_r2( A_center, B_center, C_center &
|
||||
, power_A, power_B, alpha, beta, gama )
|
||||
|
||||
c = c + 3.d0 * gama * c1 - 2.d0 * gama * gama * c2
|
||||
enddo
|
||||
|
||||
j1b_gauss_hermI(i,j) = j1b_gauss_hermI(i,j) &
|
||||
+ ao_coef_normalized_ordered_transp(l,j) &
|
||||
* ao_coef_normalized_ordered_transp(m,i) * c
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
elseif(j1b_type .eq. 2) then
|
||||
! \tau_1b = \sum_iA [c_A exp(-alpha_A r_iA^2)]
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i, j, k, l, m, alpha, beta, gama, coef, &
|
||||
!$OMP A_center, B_center, C_center, power_A, power_B, &
|
||||
!$OMP num_A, num_B, c1, c2, c) &
|
||||
!$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, &
|
||||
!$OMP ao_power, ao_nucl, nucl_coord, &
|
||||
!$OMP ao_coef_normalized_ordered_transp, &
|
||||
!$OMP nucl_num, j1b_pen, j1b_gauss_hermI, &
|
||||
!$OMP j1b_coeff)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do j = 1, ao_num
|
||||
num_A = ao_nucl(j)
|
||||
power_A(1:3) = ao_power(j,1:3)
|
||||
A_center(1:3) = nucl_coord(num_A,1:3)
|
||||
|
||||
do i = 1, ao_num
|
||||
num_B = ao_nucl(i)
|
||||
power_B(1:3) = ao_power(i,1:3)
|
||||
B_center(1:3) = nucl_coord(num_B,1:3)
|
||||
|
||||
do l = 1, ao_prim_num(j)
|
||||
alpha = ao_expo_ordered_transp(l,j)
|
||||
|
||||
do m = 1, ao_prim_num(i)
|
||||
beta = ao_expo_ordered_transp(m,i)
|
||||
|
||||
c = 0.d0
|
||||
do k = 1, nucl_num
|
||||
gama = j1b_pen (k)
|
||||
coef = j1b_coeff(k)
|
||||
C_center(1:3) = nucl_coord(k,1:3)
|
||||
|
||||
! < XA | exp[-gama r_C^2] | XB >
|
||||
c1 = int_gauss_r0( A_center, B_center, C_center &
|
||||
, power_A, power_B, alpha, beta, gama )
|
||||
|
||||
! < XA | r_A^2 exp[-gama r_C^2] | XB >
|
||||
c2 = int_gauss_r2( A_center, B_center, C_center &
|
||||
, power_A, power_B, alpha, beta, gama )
|
||||
|
||||
c = c + 3.d0 * gama * coef * c1 - 2.d0 * gama * gama * coef * c2
|
||||
enddo
|
||||
|
||||
j1b_gauss_hermI(i,j) = j1b_gauss_hermI(i,j) &
|
||||
+ ao_coef_normalized_ordered_transp(l,j) &
|
||||
* ao_coef_normalized_ordered_transp(m,i) * c
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
!_____________________________________________________________________________________________________________
|
||||
!
|
||||
! < XA | exp[-gama r_C^2] | XB >
|
||||
!
|
||||
double precision function int_gauss_r0(A_center, B_center, C_center, power_A, power_B, alpha, beta, gama)
|
||||
|
||||
! for max_dim
|
||||
include 'constants.include.F'
|
||||
|
||||
implicit none
|
||||
|
||||
integer , intent(in) :: power_A(3), power_B(3)
|
||||
double precision, intent(in) :: A_center(3), B_center(3), C_center(3)
|
||||
double precision, intent(in) :: alpha, beta, gama
|
||||
|
||||
integer :: i, power_C, dim1
|
||||
integer :: iorder(3)
|
||||
integer :: nmax
|
||||
double precision :: AB_expo, fact_AB, AB_center(3), P_AB(0:max_dim,3)
|
||||
double precision :: cx, cy, cz
|
||||
|
||||
double precision :: overlap_gaussian_x
|
||||
|
||||
dim1 = 100
|
||||
|
||||
! P_AB(0:max_dim,3) polynomial
|
||||
! AB_center(3) new center
|
||||
! AB_expo new exponent
|
||||
! fact_AB constant factor
|
||||
! iorder(3) i_order(i) = order of the polynomials
|
||||
call give_explicit_poly_and_gaussian( P_AB, AB_center, AB_expo, fact_AB &
|
||||
, iorder, alpha, beta, power_A, power_B, A_center, B_center, dim1)
|
||||
|
||||
if( fact_AB .lt. 1d-20 ) then
|
||||
int_gauss_r0 = 0.d0
|
||||
return
|
||||
endif
|
||||
|
||||
power_C = 0
|
||||
cx = 0.d0
|
||||
do i = 0, iorder(1)
|
||||
cx = cx + P_AB(i,1) * overlap_gaussian_x(AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1)
|
||||
enddo
|
||||
cy = 0.d0
|
||||
do i = 0, iorder(2)
|
||||
cy = cy + P_AB(i,2) * overlap_gaussian_x(AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1)
|
||||
enddo
|
||||
cz = 0.d0
|
||||
do i = 0, iorder(3)
|
||||
cz = cz + P_AB(i,3) * overlap_gaussian_x(AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1)
|
||||
enddo
|
||||
|
||||
int_gauss_r0 = fact_AB * cx * cy * cz
|
||||
|
||||
return
|
||||
end function int_gauss_r0
|
||||
!_____________________________________________________________________________________________________________
|
||||
!_____________________________________________________________________________________________________________
|
||||
|
||||
|
||||
|
||||
!_____________________________________________________________________________________________________________
|
||||
!
|
||||
! < XA | r_C^2 exp[-gama r_C^2] | XB >
|
||||
!
|
||||
double precision function int_gauss_r2(A_center, B_center, C_center, power_A, power_B, alpha, beta, gama)
|
||||
|
||||
! for max_dim
|
||||
include 'constants.include.F'
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: power_A(3), power_B(3)
|
||||
double precision, intent(in) :: A_center(3), B_center(3), C_center(3)
|
||||
double precision, intent(in) :: alpha, beta, gama
|
||||
|
||||
integer :: i, power_C, dim1
|
||||
integer :: iorder(3)
|
||||
double precision :: AB_expo, fact_AB, AB_center(3), P_AB(0:max_dim,3)
|
||||
double precision :: cx0, cy0, cz0, cx, cy, cz
|
||||
double precision :: int_tmp
|
||||
|
||||
double precision :: overlap_gaussian_x
|
||||
|
||||
dim1 = 100
|
||||
|
||||
! P_AB(0:max_dim,3) polynomial centered on AB_center
|
||||
! AB_center(3) new center
|
||||
! AB_expo new exponent
|
||||
! fact_AB constant factor
|
||||
! iorder(3) i_order(i) = order of the polynomials
|
||||
call give_explicit_poly_and_gaussian( P_AB, AB_center, AB_expo, fact_AB &
|
||||
, iorder, alpha, beta, power_A, power_B, A_center, B_center, dim1)
|
||||
|
||||
! <<<
|
||||
! to avoid multi-evaluation
|
||||
power_C = 0
|
||||
|
||||
cx0 = 0.d0
|
||||
do i = 0, iorder(1)
|
||||
cx0 = cx0 + P_AB(i,1) * overlap_gaussian_x(AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1)
|
||||
enddo
|
||||
cy0 = 0.d0
|
||||
do i = 0, iorder(2)
|
||||
cy0 = cy0 + P_AB(i,2) * overlap_gaussian_x(AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1)
|
||||
enddo
|
||||
cz0 = 0.d0
|
||||
do i = 0, iorder(3)
|
||||
cz0 = cz0 + P_AB(i,3) * overlap_gaussian_x(AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1)
|
||||
enddo
|
||||
! >>>
|
||||
|
||||
int_tmp = 0.d0
|
||||
|
||||
power_C = 2
|
||||
|
||||
! ( x - XC)^2
|
||||
cx = 0.d0
|
||||
do i = 0, iorder(1)
|
||||
cx = cx + P_AB(i,1) * overlap_gaussian_x(AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1)
|
||||
enddo
|
||||
int_tmp += cx * cy0 * cz0
|
||||
|
||||
! ( y - YC)^2
|
||||
cy = 0.d0
|
||||
do i = 0, iorder(2)
|
||||
cy = cy + P_AB(i,2) * overlap_gaussian_x(AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1)
|
||||
enddo
|
||||
int_tmp += cx0 * cy * cz0
|
||||
|
||||
! ( z - ZC)^2
|
||||
cz = 0.d0
|
||||
do i = 0, iorder(3)
|
||||
cz = cz + P_AB(i,3) * overlap_gaussian_x(AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1)
|
||||
enddo
|
||||
int_tmp += cx0 * cy0 * cz
|
||||
|
||||
int_gauss_r2 = fact_AB * int_tmp
|
||||
|
||||
return
|
||||
end function int_gauss_r2
|
||||
!_____________________________________________________________________________________________________________
|
||||
!_____________________________________________________________________________________________________________
|
||||
|
||||
|
||||
371
src/ao_tc_eff_map/one_e_1bgauss_nonherm.irp.f
Normal file
371
src/ao_tc_eff_map/one_e_1bgauss_nonherm.irp.f
Normal file
@ -0,0 +1,371 @@
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, j1b_gauss_nonherm, (ao_num,ao_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! j1b_gauss_nonherm(i,j) = \langle \chi_j | - grad \tau_{1b} \cdot grad | \chi_i \rangle
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
integer :: num_A, num_B
|
||||
integer :: power_A(3), power_B(3)
|
||||
integer :: i, j, k, l, m
|
||||
double precision :: alpha, beta, gama, coef
|
||||
double precision :: A_center(3), B_center(3), C_center(3)
|
||||
double precision :: c1, c
|
||||
|
||||
integer :: dim1
|
||||
double precision :: overlap_y, d_a_2, overlap_z, overlap
|
||||
|
||||
double precision :: int_gauss_deriv
|
||||
|
||||
PROVIDE j1b_type j1b_pen j1b_coeff
|
||||
|
||||
! --------------------------------------------------------------------------------
|
||||
! -- Dummy call to provide everything
|
||||
dim1 = 100
|
||||
A_center(:) = 0.d0
|
||||
B_center(:) = 1.d0
|
||||
alpha = 1.d0
|
||||
beta = 0.1d0
|
||||
power_A(:) = 1
|
||||
power_B(:) = 0
|
||||
call overlap_gaussian_xyz( A_center, B_center, alpha, beta, power_A, power_B &
|
||||
, overlap_y, d_a_2, overlap_z, overlap, dim1 )
|
||||
! --------------------------------------------------------------------------------
|
||||
|
||||
|
||||
j1b_gauss_nonherm(1:ao_num,1:ao_num) = 0.d0
|
||||
|
||||
if(j1b_type .eq. 1) then
|
||||
! \tau_1b = \sum_iA -[1 - exp(-alpha_A r_iA^2)]
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i, j, k, l, m, alpha, beta, gama, &
|
||||
!$OMP A_center, B_center, C_center, power_A, power_B, &
|
||||
!$OMP num_A, num_B, c1, c) &
|
||||
!$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, &
|
||||
!$OMP ao_power, ao_nucl, nucl_coord, &
|
||||
!$OMP ao_coef_normalized_ordered_transp, &
|
||||
!$OMP nucl_num, j1b_pen, j1b_gauss_nonherm)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do j = 1, ao_num
|
||||
num_A = ao_nucl(j)
|
||||
power_A(1:3) = ao_power(j,1:3)
|
||||
A_center(1:3) = nucl_coord(num_A,1:3)
|
||||
|
||||
do i = 1, ao_num
|
||||
num_B = ao_nucl(i)
|
||||
power_B(1:3) = ao_power(i,1:3)
|
||||
B_center(1:3) = nucl_coord(num_B,1:3)
|
||||
|
||||
do l = 1, ao_prim_num(j)
|
||||
alpha = ao_expo_ordered_transp(l,j)
|
||||
|
||||
do m = 1, ao_prim_num(i)
|
||||
beta = ao_expo_ordered_transp(m,i)
|
||||
|
||||
c = 0.d0
|
||||
do k = 1, nucl_num
|
||||
gama = j1b_pen(k)
|
||||
C_center(1:3) = nucl_coord(k,1:3)
|
||||
|
||||
! \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
|
||||
|
||||
elseif(j1b_type .eq. 2) then
|
||||
! \tau_1b = \sum_iA [c_A exp(-alpha_A r_iA^2)]
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i, j, k, l, m, alpha, beta, gama, coef, &
|
||||
!$OMP A_center, B_center, C_center, power_A, power_B, &
|
||||
!$OMP num_A, num_B, c1, c) &
|
||||
!$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, &
|
||||
!$OMP ao_power, ao_nucl, nucl_coord, &
|
||||
!$OMP ao_coef_normalized_ordered_transp, &
|
||||
!$OMP nucl_num, j1b_pen, j1b_gauss_nonherm, &
|
||||
!$OMP j1b_coeff)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do j = 1, ao_num
|
||||
num_A = ao_nucl(j)
|
||||
power_A(1:3) = ao_power(j,1:3)
|
||||
A_center(1:3) = nucl_coord(num_A,1:3)
|
||||
|
||||
do i = 1, ao_num
|
||||
num_B = ao_nucl(i)
|
||||
power_B(1:3) = ao_power(i,1:3)
|
||||
B_center(1:3) = nucl_coord(num_B,1:3)
|
||||
|
||||
do l = 1, ao_prim_num(j)
|
||||
alpha = ao_expo_ordered_transp(l,j)
|
||||
|
||||
do m = 1, ao_prim_num(i)
|
||||
beta = ao_expo_ordered_transp(m,i)
|
||||
|
||||
c = 0.d0
|
||||
do k = 1, nucl_num
|
||||
gama = j1b_pen (k)
|
||||
coef = j1b_coeff(k)
|
||||
C_center(1:3) = nucl_coord(k,1:3)
|
||||
|
||||
! \langle \chi_A | exp[-gama r_C^2] r_C \cdot grad | \chi_B \rangle
|
||||
c1 = int_gauss_deriv( A_center, B_center, C_center &
|
||||
, power_A, power_B, alpha, beta, gama )
|
||||
|
||||
c = c + 2.d0 * gama * coef * c1
|
||||
enddo
|
||||
|
||||
j1b_gauss_nonherm(i,j) = j1b_gauss_nonherm(i,j) &
|
||||
+ ao_coef_normalized_ordered_transp(l,j) &
|
||||
* ao_coef_normalized_ordered_transp(m,i) * c
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
!_____________________________________________________________________________________________________________
|
||||
!
|
||||
! < 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
|
||||
!_____________________________________________________________________________________________________________
|
||||
!_____________________________________________________________________________________________________________
|
||||
|
||||
|
||||
335
src/ao_tc_eff_map/potential.irp.f
Normal file
335
src/ao_tc_eff_map/potential.irp.f
Normal file
@ -0,0 +1,335 @@
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [integer, n_gauss_eff_pot]
|
||||
|
||||
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
|
||||
|
||||
implicit none
|
||||
|
||||
n_gauss_eff_pot = ng_fit_jast + 1
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [integer, n_gauss_eff_pot_deriv]
|
||||
|
||||
BEGIN_DOC
|
||||
! V(r12) = -(1 - erf(mu*r12))^2 is expanded in Gaussians as Eqs A11-A20 in JCP 154, 084119 (2021)
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
n_gauss_eff_pot_deriv = ng_fit_jast
|
||||
|
||||
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)]
|
||||
|
||||
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'
|
||||
|
||||
implicit none
|
||||
integer :: i
|
||||
|
||||
! fit of the -0.25 * (1 - erf(mu*x))^2 with n_max_fit_slat gaussians
|
||||
do i = 1, ng_fit_jast
|
||||
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(ng_fit_jast+1) = mu_erf * mu_erf
|
||||
coef_gauss_eff_pot(ng_fit_jast+1) = 1.d0 * mu_erf * inv_sq_pi
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
double precision function eff_pot_gauss(x, mu)
|
||||
|
||||
BEGIN_DOC
|
||||
! V(mu,r12) = -0.25 * (1 - erf(mu*r12))^2 + 1/(\sqrt(pi)mu) * exp(-(mu*r12)^2)
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
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)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! (1 - erf(mu*x)) = \sum_i coef_gauss_1_erf_x(i) * exp(-expo_gauss_1_erf_x(i) * x^2)
|
||||
!
|
||||
! This is based on a fit of (1 - erf(mu*x)) by exp(-alpha * x) exp(-beta*mu^2x^2)
|
||||
!
|
||||
! and the slater function exp(-alpha * x) is fitted with n_max_fit_slat gaussians
|
||||
!
|
||||
! See Appendix 2 of JCP 154, 084119 (2021)
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i
|
||||
double precision :: expos(n_max_fit_slat), alpha, beta
|
||||
|
||||
alpha = expos_slat_gauss_1_erf_x(1) * mu_erf
|
||||
call expo_fit_slater_gam(alpha, expos)
|
||||
beta = expos_slat_gauss_1_erf_x(2) * mu_erf * mu_erf
|
||||
|
||||
do i = 1, n_max_fit_slat
|
||||
expo_gauss_1_erf_x(i) = expos(i) + beta
|
||||
coef_gauss_1_erf_x(i) = coef_fit_slat_gauss(i)
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
double precision function fit_1_erf_x(x)
|
||||
|
||||
BEGIN_DOC
|
||||
! fit_1_erf_x(x) = \sum_i c_i exp (-alpha_i x^2) \approx (1 - erf(mu*x))
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i
|
||||
double precision, intent(in) :: x
|
||||
|
||||
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, (ng_fit_jast)]
|
||||
&BEGIN_PROVIDER [double precision, coef_gauss_1_erf_x_2, (ng_fit_jast)]
|
||||
|
||||
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
|
||||
|
||||
implicit none
|
||||
integer :: i
|
||||
double precision :: expos(ng_fit_jast), alpha, beta, tmp
|
||||
|
||||
if(ng_fit_jast .eq. 1) then
|
||||
|
||||
coef_gauss_1_erf_x_2 = (/ 0.85345277d0 /)
|
||||
expo_gauss_1_erf_x_2 = (/ 6.23519457d0 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_1_erf_x_2(i) = tmp * expo_gauss_1_erf_x_2(i)
|
||||
enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 2) then
|
||||
|
||||
coef_gauss_1_erf_x_2 = (/ 0.31030624d0 , 0.64364964d0 /)
|
||||
expo_gauss_1_erf_x_2 = (/ 55.39184787d0, 3.92151407d0 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_1_erf_x_2(i) = tmp * expo_gauss_1_erf_x_2(i)
|
||||
enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 3) then
|
||||
|
||||
coef_gauss_1_erf_x_2 = (/ 0.33206082d0 , 0.52347449d0, 0.12605012d0 /)
|
||||
expo_gauss_1_erf_x_2 = (/ 19.90272209d0, 3.2671671d0 , 336.47320445d0 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_1_erf_x_2(i) = tmp * expo_gauss_1_erf_x_2(i)
|
||||
enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 5) then
|
||||
|
||||
coef_gauss_1_erf_x_2 = (/ 0.02956716d0, 0.17025555d0, 0.32774114d0, 0.39034764d0, 0.07822781d0 /)
|
||||
expo_gauss_1_erf_x_2 = (/ 6467.28126d0, 46.9071990d0, 9.09617721d0, 2.76883328d0, 360.367093d0 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_1_erf_x_2(i) = tmp * expo_gauss_1_erf_x_2(i)
|
||||
enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 6) then
|
||||
|
||||
coef_gauss_1_erf_x_2 = (/ 0.18331042d0 , 0.10971118d0 , 0.29949169d0 , 0.34853132d0 , 0.0394275d0 , 0.01874444d0 /)
|
||||
expo_gauss_1_erf_x_2 = (/ 2.54293498d+01, 1.40317872d+02, 7.14630801d+00, 2.65517675d+00, 1.45142619d+03, 1.00000000d+04 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_1_erf_x_2(i) = tmp * expo_gauss_1_erf_x_2(i)
|
||||
enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 7) then
|
||||
|
||||
coef_gauss_1_erf_x_2 = (/ 0.0213619d0 , 0.03221511d0 , 0.29966689d0 , 0.19178934d0 , 0.06154732d0 , 0.28214555d0 , 0.11125985d0 /)
|
||||
expo_gauss_1_erf_x_2 = (/ 1.34727067d+04, 1.27166613d+03, 5.52584567d+00, 1.67753218d+01, 2.46145691d+02, 2.47971820d+00, 5.95141293d+01 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_1_erf_x_2(i) = tmp * expo_gauss_1_erf_x_2(i)
|
||||
enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 8) then
|
||||
|
||||
coef_gauss_1_erf_x_2 = (/ 0.28189124d0 , 0.19518669d0 , 0.12161735d0 , 0.24257438d0 , 0.07309656d0 , 0.042435d0 , 0.01926109d0 , 0.02393415d0 /)
|
||||
expo_gauss_1_erf_x_2 = (/ 4.69795903d+00, 1.21379451d+01, 3.55527053d+01, 2.39227172d+00, 1.14827721d+02, 4.16320213d+02, 1.52813587d+04, 1.78516557d+03 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_1_erf_x_2(i) = tmp * expo_gauss_1_erf_x_2(i)
|
||||
enddo
|
||||
|
||||
!elseif(ng_fit_jast .eq. 9) then
|
||||
|
||||
! coef_gauss_1_erf_x_2 = (/ /)
|
||||
! expo_gauss_1_erf_x_2 = (/ /)
|
||||
|
||||
! tmp = mu_erf * mu_erf
|
||||
! do i = 1, ng_fit_jast
|
||||
! expo_gauss_1_erf_x_2(i) = tmp * expo_gauss_1_erf_x_2(i)
|
||||
! enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 20) then
|
||||
|
||||
ASSERT(n_max_fit_slat == 20)
|
||||
|
||||
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 * mu_erf
|
||||
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
|
||||
|
||||
else
|
||||
|
||||
print *, ' not implemented yet'
|
||||
stop
|
||||
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
double precision function fit_1_erf_x_2(x)
|
||||
implicit none
|
||||
double precision, intent(in) :: x
|
||||
BEGIN_DOC
|
||||
! fit_1_erf_x_2(x) = \sum_i c_i exp (-alpha_i x^2) \approx (1 - erf(mu*x))^2
|
||||
END_DOC
|
||||
integer :: i
|
||||
fit_1_erf_x_2 = 0.d0
|
||||
do i = 1, n_max_fit_slat
|
||||
fit_1_erf_x_2 += dexp(-expo_gauss_1_erf_x_2(i) *x*x) * coef_gauss_1_erf_x_2(i)
|
||||
enddo
|
||||
|
||||
end
|
||||
|
||||
subroutine inv_r_times_poly(r, dist_r, dist_vec, poly)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! returns
|
||||
!
|
||||
! poly(1) = x / sqrt(x^2+y^2+z^2), poly(2) = y / sqrt(x^2+y^2+z^2), poly(3) = z / sqrt(x^2+y^2+z^2)
|
||||
!
|
||||
! with the arguments
|
||||
!
|
||||
! r(1) = x, r(2) = y, r(3) = z, dist_r = sqrt(x^2+y^2+z^2)
|
||||
!
|
||||
! dist_vec(1) = sqrt(y^2+z^2), dist_vec(2) = sqrt(x^2+z^2), dist_vec(3) = sqrt(x^2+y^2)
|
||||
END_DOC
|
||||
double precision, intent(in) :: r(3), dist_r, dist_vec(3)
|
||||
double precision, intent(out):: poly(3)
|
||||
double precision :: inv_dist
|
||||
integer :: i
|
||||
if (dist_r.gt. 1.d-8)then
|
||||
inv_dist = 1.d0/dist_r
|
||||
do i = 1, 3
|
||||
poly(i) = r(i) * inv_dist
|
||||
enddo
|
||||
else
|
||||
do i = 1, 3
|
||||
if(dabs(r(i)).lt.dist_vec(i))then
|
||||
inv_dist = 1.d0/dist_r
|
||||
poly(i) = r(i) * inv_dist
|
||||
else !if(dabs(r(i)))then
|
||||
poly(i) = 1.d0
|
||||
! poly(i) = 0.d0
|
||||
endif
|
||||
enddo
|
||||
endif
|
||||
end
|
||||
86
src/ao_tc_eff_map/providers_ao_eff_pot.irp.f
Normal file
86
src/ao_tc_eff_map/providers_ao_eff_pot.irp.f
Normal file
@ -0,0 +1,86 @@
|
||||
|
||||
BEGIN_PROVIDER [ logical, ao_tc_sym_two_e_pot_in_map ]
|
||||
implicit none
|
||||
use f77_zmq
|
||||
use map_module
|
||||
BEGIN_DOC
|
||||
! Map of Atomic integrals
|
||||
! i(r1) j(r2) 1/r12 k(r1) l(r2)
|
||||
END_DOC
|
||||
|
||||
integer :: i,j,k,l
|
||||
double precision :: ao_tc_sym_two_e_pot,cpu_1,cpu_2, wall_1, wall_2
|
||||
double precision :: integral, wall_0
|
||||
include 'utils/constants.include.F'
|
||||
|
||||
! For integrals file
|
||||
integer(key_kind),allocatable :: buffer_i(:)
|
||||
integer,parameter :: size_buffer = 1024*64
|
||||
real(integral_kind),allocatable :: buffer_value(:)
|
||||
|
||||
integer :: n_integrals, rc
|
||||
integer :: kk, m, j1, i1, lmax
|
||||
character*(64) :: fmt
|
||||
|
||||
!double precision :: j1b_gauss_coul_debug
|
||||
!integral = j1b_gauss_coul_debug(1,1,1,1)
|
||||
|
||||
integral = ao_tc_sym_two_e_pot(1,1,1,1)
|
||||
|
||||
double precision :: map_mb
|
||||
|
||||
print*, 'Providing the ao_tc_sym_two_e_pot_map integrals'
|
||||
call wall_time(wall_0)
|
||||
call wall_time(wall_1)
|
||||
call cpu_time(cpu_1)
|
||||
|
||||
integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull
|
||||
call new_parallel_job(zmq_to_qp_run_socket,zmq_socket_pull,'ao_tc_sym_two_e_pot')
|
||||
|
||||
character(len=:), allocatable :: task
|
||||
allocate(character(len=ao_num*12) :: task)
|
||||
write(fmt,*) '(', ao_num, '(I5,X,I5,''|''))'
|
||||
do l=1,ao_num
|
||||
write(task,fmt) (i,l, i=1,l)
|
||||
integer, external :: add_task_to_taskserver
|
||||
if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) == -1) then
|
||||
stop 'Unable to add task to server'
|
||||
endif
|
||||
enddo
|
||||
deallocate(task)
|
||||
|
||||
integer, external :: zmq_set_running
|
||||
if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
|
||||
print *, irp_here, ': Failed in zmq_set_running'
|
||||
endif
|
||||
|
||||
PROVIDE nproc
|
||||
!$OMP PARALLEL DEFAULT(shared) private(i) num_threads(nproc+1)
|
||||
i = omp_get_thread_num()
|
||||
if (i==0) then
|
||||
call ao_tc_sym_two_e_pot_in_map_collector(zmq_socket_pull)
|
||||
else
|
||||
call ao_tc_sym_two_e_pot_in_map_slave_inproc(i)
|
||||
endif
|
||||
!$OMP END PARALLEL
|
||||
|
||||
call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'ao_tc_sym_two_e_pot')
|
||||
|
||||
|
||||
print*, 'Sorting the map'
|
||||
call map_sort(ao_tc_sym_two_e_pot_map)
|
||||
call cpu_time(cpu_2)
|
||||
call wall_time(wall_2)
|
||||
integer(map_size_kind) :: get_ao_tc_sym_two_e_pot_map_size, ao_eff_pot_map_size
|
||||
ao_eff_pot_map_size = get_ao_tc_sym_two_e_pot_map_size()
|
||||
|
||||
print*, 'AO eff_pot integrals provided:'
|
||||
print*, ' Size of AO eff_pot map : ', map_mb(ao_tc_sym_two_e_pot_map) ,'MB'
|
||||
print*, ' Number of AO eff_pot integrals :', ao_eff_pot_map_size
|
||||
print*, ' cpu time :',cpu_2 - cpu_1, 's'
|
||||
print*, ' wall time :',wall_2 - wall_1, 's ( x ', (cpu_2-cpu_1)/(wall_2-wall_1+tiny(1.d0)), ' )'
|
||||
|
||||
ao_tc_sym_two_e_pot_in_map = .True.
|
||||
|
||||
|
||||
END_PROVIDER
|
||||
728
src/ao_tc_eff_map/two_e_1bgauss_j1.irp.f
Normal file
728
src/ao_tc_eff_map/two_e_1bgauss_j1.irp.f
Normal file
@ -0,0 +1,728 @@
|
||||
! ---
|
||||
|
||||
double precision function j1b_gauss_2e_j1(i, j, k, l)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! integral in the AO basis:
|
||||
! i(r1) j(r1) f(r12) k(r2) l(r2)
|
||||
!
|
||||
! with:
|
||||
! f(r12) = - [ (0.5 - 0.5 erf(mu r12)) / r12 ] (r1-r2) \cdot \sum_A (-2 a_A) [ r1A exp(-aA r1A^2) - r2A exp(-aA r2A^2) ]
|
||||
! = [ (1 - erf(mu r12) / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2)
|
||||
! + (r2-RA)^2 exp(-aA r2A^2)
|
||||
! - (r1-RA) \cdot (r2-RA) exp(-aA r1A^2)
|
||||
! - (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ]
|
||||
!
|
||||
END_DOC
|
||||
|
||||
include 'utils/constants.include.F'
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: i, j, k, l
|
||||
|
||||
integer :: p, q, r, s
|
||||
integer :: num_i, num_j, num_k, num_l, num_ii
|
||||
integer :: I_power(3), J_power(3), K_power(3), L_power(3)
|
||||
integer :: iorder_p(3), iorder_q(3)
|
||||
integer :: shift_P(3), shift_Q(3)
|
||||
integer :: dim1
|
||||
|
||||
double precision :: coef1, coef2, coef3, coef4
|
||||
double precision :: expo1, expo2, expo3, expo4
|
||||
double precision :: P1_new(0:max_dim,3), P1_center(3), fact_p1, pp1, p1_inv
|
||||
double precision :: Q1_new(0:max_dim,3), Q1_center(3), fact_q1, qq1, q1_inv
|
||||
double precision :: I_center(3), J_center(3), K_center(3), L_center(3)
|
||||
double precision :: ff, gg, cx, cy, cz
|
||||
|
||||
double precision :: j1b_gauss_2e_j1_schwartz
|
||||
|
||||
if( ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then
|
||||
j1b_gauss_2e_j1 = j1b_gauss_2e_j1_schwartz(i, j, k, l)
|
||||
return
|
||||
endif
|
||||
|
||||
num_i = ao_nucl(i)
|
||||
num_j = ao_nucl(j)
|
||||
num_k = ao_nucl(k)
|
||||
num_l = ao_nucl(l)
|
||||
|
||||
do p = 1, 3
|
||||
I_power(p) = ao_power(i,p)
|
||||
J_power(p) = ao_power(j,p)
|
||||
K_power(p) = ao_power(k,p)
|
||||
L_power(p) = ao_power(l,p)
|
||||
I_center(p) = nucl_coord(num_i,p)
|
||||
J_center(p) = nucl_coord(num_j,p)
|
||||
K_center(p) = nucl_coord(num_k,p)
|
||||
L_center(p) = nucl_coord(num_l,p)
|
||||
enddo
|
||||
|
||||
j1b_gauss_2e_j1 = 0.d0
|
||||
|
||||
do p = 1, ao_prim_num(i)
|
||||
coef1 = ao_coef_normalized_ordered_transp(p, i)
|
||||
expo1 = ao_expo_ordered_transp(p, i)
|
||||
|
||||
do q = 1, ao_prim_num(j)
|
||||
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
|
||||
expo2 = ao_expo_ordered_transp(q, j)
|
||||
|
||||
call give_explicit_poly_and_gaussian( P1_new, P1_center, pp1, fact_p1, iorder_p, expo1, expo2 &
|
||||
, I_power, J_power, I_center, J_center, dim1 )
|
||||
p1_inv = 1.d0 / pp1
|
||||
|
||||
do r = 1, ao_prim_num(k)
|
||||
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
|
||||
expo3 = ao_expo_ordered_transp(r, k)
|
||||
|
||||
do s = 1, ao_prim_num(l)
|
||||
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
|
||||
expo4 = ao_expo_ordered_transp(s, l)
|
||||
|
||||
call give_explicit_poly_and_gaussian( Q1_new, Q1_center, qq1, fact_q1, iorder_q, expo3, expo4 &
|
||||
, K_power, L_power, K_center, L_center, dim1 )
|
||||
q1_inv = 1.d0 / qq1
|
||||
|
||||
call get_cxcycz_j1( dim1, cx, cy, cz &
|
||||
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p &
|
||||
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q )
|
||||
|
||||
j1b_gauss_2e_j1 = j1b_gauss_2e_j1 + coef4 * ( cx + cy + cz )
|
||||
enddo ! s
|
||||
enddo ! r
|
||||
enddo ! q
|
||||
enddo ! p
|
||||
|
||||
return
|
||||
end function j1b_gauss_2e_j1
|
||||
|
||||
! ---
|
||||
|
||||
double precision function j1b_gauss_2e_j1_schwartz(i, j, k, l)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! 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_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_j1( dim1, cx, cy, cz &
|
||||
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q &
|
||||
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q )
|
||||
|
||||
schwartz_kl(s,r) = coef4 * dabs( cx + cy + cz )
|
||||
schwartz_kl(0,r) = max( schwartz_kl(0,r) , schwartz_kl(s,r) )
|
||||
enddo
|
||||
|
||||
schwartz_kl(0,0) = max( schwartz_kl(0,r) , schwartz_kl(0,0) )
|
||||
enddo
|
||||
|
||||
|
||||
j1b_gauss_2e_j1_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_j1( dim1, cx, cy, cz &
|
||||
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p &
|
||||
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p )
|
||||
|
||||
schwartz_ij = coef2 * coef2 * dabs( cx + cy + cz )
|
||||
if( schwartz_kl(0,0) * schwartz_ij < thr ) cycle
|
||||
|
||||
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_j1( dim1, cx, cy, cz &
|
||||
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p &
|
||||
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q )
|
||||
|
||||
j1b_gauss_2e_j1_schwartz = j1b_gauss_2e_j1_schwartz + coef4 * ( cx + cy + cz )
|
||||
enddo ! s
|
||||
enddo ! r
|
||||
enddo ! q
|
||||
enddo ! p
|
||||
|
||||
deallocate( schwartz_kl )
|
||||
|
||||
return
|
||||
end function j1b_gauss_2e_j1_schwartz
|
||||
|
||||
! ---
|
||||
|
||||
subroutine get_cxcycz_j1( dim1, cx, cy, cz &
|
||||
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p &
|
||||
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q )
|
||||
|
||||
include 'utils/constants.include.F'
|
||||
|
||||
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
|
||||
|
||||
PROVIDE j1b_pen
|
||||
|
||||
cx = 0.d0
|
||||
cy = 0.d0
|
||||
cz = 0.d0
|
||||
do ii = 1, nucl_num
|
||||
|
||||
expoii = j1b_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_j1
|
||||
|
||||
! ---
|
||||
|
||||
729
src/ao_tc_eff_map/two_e_1bgauss_j2.irp.f
Normal file
729
src/ao_tc_eff_map/two_e_1bgauss_j2.irp.f
Normal file
@ -0,0 +1,729 @@
|
||||
! ---
|
||||
|
||||
double precision function j1b_gauss_2e_j2(i, j, k, l)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! integral in the AO basis:
|
||||
! i(r1) j(r1) f(r12) k(r2) l(r2)
|
||||
!
|
||||
! with:
|
||||
! f(r12) = - [ (0.5 - 0.5 erf(mu r12)) / r12 ] (r1-r2) \cdot \sum_A (-2 a_A c_A) [ r1A exp(-aA r1A^2) - r2A exp(-aA r2A^2) ]
|
||||
! = [ (1 - erf(mu r12) / r12 ] \sum_A a_A c_A [ (r1-RA)^2 exp(-aA r1A^2)
|
||||
! + (r2-RA)^2 exp(-aA r2A^2)
|
||||
! - (r1-RA) \cdot (r2-RA) exp(-aA r1A^2)
|
||||
! - (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ]
|
||||
!
|
||||
END_DOC
|
||||
|
||||
include 'utils/constants.include.F'
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: i, j, k, l
|
||||
|
||||
integer :: p, q, r, s
|
||||
integer :: num_i, num_j, num_k, num_l, num_ii
|
||||
integer :: I_power(3), J_power(3), K_power(3), L_power(3)
|
||||
integer :: iorder_p(3), iorder_q(3)
|
||||
integer :: shift_P(3), shift_Q(3)
|
||||
integer :: dim1
|
||||
|
||||
double precision :: coef1, coef2, coef3, coef4
|
||||
double precision :: expo1, expo2, expo3, expo4
|
||||
double precision :: P1_new(0:max_dim,3), P1_center(3), fact_p1, pp1, p1_inv
|
||||
double precision :: Q1_new(0:max_dim,3), Q1_center(3), fact_q1, qq1, q1_inv
|
||||
double precision :: I_center(3), J_center(3), K_center(3), L_center(3)
|
||||
double precision :: ff, gg, cx, cy, cz
|
||||
|
||||
double precision :: j1b_gauss_2e_j2_schwartz
|
||||
|
||||
dim1 = n_pt_max_integrals
|
||||
|
||||
if( ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then
|
||||
j1b_gauss_2e_j2 = j1b_gauss_2e_j2_schwartz(i, j, k, l)
|
||||
return
|
||||
endif
|
||||
|
||||
num_i = ao_nucl(i)
|
||||
num_j = ao_nucl(j)
|
||||
num_k = ao_nucl(k)
|
||||
num_l = ao_nucl(l)
|
||||
|
||||
do p = 1, 3
|
||||
I_power(p) = ao_power(i,p)
|
||||
J_power(p) = ao_power(j,p)
|
||||
K_power(p) = ao_power(k,p)
|
||||
L_power(p) = ao_power(l,p)
|
||||
I_center(p) = nucl_coord(num_i,p)
|
||||
J_center(p) = nucl_coord(num_j,p)
|
||||
K_center(p) = nucl_coord(num_k,p)
|
||||
L_center(p) = nucl_coord(num_l,p)
|
||||
enddo
|
||||
|
||||
j1b_gauss_2e_j2 = 0.d0
|
||||
|
||||
do p = 1, ao_prim_num(i)
|
||||
coef1 = ao_coef_normalized_ordered_transp(p, i)
|
||||
expo1 = ao_expo_ordered_transp(p, i)
|
||||
|
||||
do q = 1, ao_prim_num(j)
|
||||
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
|
||||
expo2 = ao_expo_ordered_transp(q, j)
|
||||
|
||||
call give_explicit_poly_and_gaussian( P1_new, P1_center, pp1, fact_p1, iorder_p, expo1, expo2 &
|
||||
, I_power, J_power, I_center, J_center, dim1 )
|
||||
p1_inv = 1.d0 / pp1
|
||||
|
||||
do r = 1, ao_prim_num(k)
|
||||
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
|
||||
expo3 = ao_expo_ordered_transp(r, k)
|
||||
|
||||
do s = 1, ao_prim_num(l)
|
||||
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
|
||||
expo4 = ao_expo_ordered_transp(s, l)
|
||||
|
||||
call give_explicit_poly_and_gaussian( Q1_new, Q1_center, qq1, fact_q1, iorder_q, expo3, expo4 &
|
||||
, K_power, L_power, K_center, L_center, dim1 )
|
||||
q1_inv = 1.d0 / qq1
|
||||
|
||||
call get_cxcycz_j2( dim1, cx, cy, cz &
|
||||
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p &
|
||||
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q )
|
||||
|
||||
j1b_gauss_2e_j2 = j1b_gauss_2e_j2 + coef4 * ( cx + cy + cz )
|
||||
enddo ! s
|
||||
enddo ! r
|
||||
enddo ! q
|
||||
enddo ! p
|
||||
|
||||
return
|
||||
end function j1b_gauss_2e_j2
|
||||
|
||||
! ---
|
||||
|
||||
double precision function j1b_gauss_2e_j2_schwartz(i, j, k, l)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! integral in the AO basis:
|
||||
! i(r1) j(r1) f(r12) k(r2) l(r2)
|
||||
!
|
||||
! with:
|
||||
! f(r12) = - [ (0.5 - 0.5 erf(mu r12)) / r12 ] (r1-r2) \cdot \sum_A (-2 a_A c_A) [ r1A exp(-aA r1A^2) - r2A exp(-aA r2A^2) ]
|
||||
! = [ (1 - erf(mu r12) / r12 ] \sum_A a_A c_A [ (r1-RA)^2 exp(-aA r1A^2)
|
||||
! + (r2-RA)^2 exp(-aA r2A^2)
|
||||
! - (r1-RA) \cdot (r2-RA) exp(-aA r1A^2)
|
||||
! - (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ]
|
||||
!
|
||||
END_DOC
|
||||
|
||||
include 'utils/constants.include.F'
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: i, j, k, l
|
||||
|
||||
integer :: p, q, r, s
|
||||
integer :: num_i, num_j, num_k, num_l, num_ii
|
||||
integer :: I_power(3), J_power(3), K_power(3), L_power(3)
|
||||
integer :: iorder_p(3), iorder_q(3)
|
||||
integer :: dim1
|
||||
|
||||
double precision :: coef1, coef2, coef3, coef4
|
||||
double precision :: expo1, expo2, expo3, expo4
|
||||
double precision :: P1_new(0:max_dim,3), P1_center(3), fact_p1, pp1, p1_inv
|
||||
double precision :: Q1_new(0:max_dim,3), Q1_center(3), fact_q1, qq1, q1_inv
|
||||
double precision :: I_center(3), J_center(3), K_center(3), L_center(3)
|
||||
double precision :: cx, cy, cz
|
||||
double precision :: schwartz_ij, thr
|
||||
double precision, allocatable :: schwartz_kl(:,:)
|
||||
|
||||
dim1 = n_pt_max_integrals
|
||||
thr = ao_integrals_threshold * ao_integrals_threshold
|
||||
|
||||
num_i = ao_nucl(i)
|
||||
num_j = ao_nucl(j)
|
||||
num_k = ao_nucl(k)
|
||||
num_l = ao_nucl(l)
|
||||
|
||||
do p = 1, 3
|
||||
I_power(p) = ao_power(i,p)
|
||||
J_power(p) = ao_power(j,p)
|
||||
K_power(p) = ao_power(k,p)
|
||||
L_power(p) = ao_power(l,p)
|
||||
I_center(p) = nucl_coord(num_i,p)
|
||||
J_center(p) = nucl_coord(num_j,p)
|
||||
K_center(p) = nucl_coord(num_k,p)
|
||||
L_center(p) = nucl_coord(num_l,p)
|
||||
enddo
|
||||
|
||||
|
||||
allocate( schwartz_kl(0:ao_prim_num(l) , 0:ao_prim_num(k)) )
|
||||
|
||||
schwartz_kl(0,0) = 0.d0
|
||||
do r = 1, ao_prim_num(k)
|
||||
expo3 = ao_expo_ordered_transp(r,k)
|
||||
coef3 = ao_coef_normalized_ordered_transp(r,k) * ao_coef_normalized_ordered_transp(r,k)
|
||||
|
||||
schwartz_kl(0,r) = 0.d0
|
||||
do s = 1, ao_prim_num(l)
|
||||
expo4 = ao_expo_ordered_transp(s,l)
|
||||
coef4 = coef3 * ao_coef_normalized_ordered_transp(s,l) * ao_coef_normalized_ordered_transp(s,l)
|
||||
|
||||
call give_explicit_poly_and_gaussian( Q1_new, Q1_center, qq1, fact_q1, iorder_q, expo3, expo4 &
|
||||
, K_power, L_power, K_center, L_center, dim1 )
|
||||
q1_inv = 1.d0 / qq1
|
||||
|
||||
call get_cxcycz_j2( dim1, cx, cy, cz &
|
||||
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q &
|
||||
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q )
|
||||
|
||||
schwartz_kl(s,r) = coef4 * dabs( cx + cy + cz )
|
||||
schwartz_kl(0,r) = max( schwartz_kl(0,r) , schwartz_kl(s,r) )
|
||||
enddo
|
||||
|
||||
schwartz_kl(0,0) = max( schwartz_kl(0,r) , schwartz_kl(0,0) )
|
||||
enddo
|
||||
|
||||
|
||||
j1b_gauss_2e_j2_schwartz = 0.d0
|
||||
|
||||
do p = 1, ao_prim_num(i)
|
||||
expo1 = ao_expo_ordered_transp(p, i)
|
||||
coef1 = ao_coef_normalized_ordered_transp(p, i)
|
||||
|
||||
do q = 1, ao_prim_num(j)
|
||||
expo2 = ao_expo_ordered_transp(q, j)
|
||||
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
|
||||
|
||||
call give_explicit_poly_and_gaussian( P1_new, P1_center, pp1, fact_p1, iorder_p, expo1, expo2 &
|
||||
, I_power, J_power, I_center, J_center, dim1 )
|
||||
p1_inv = 1.d0 / pp1
|
||||
|
||||
call get_cxcycz_j2( dim1, cx, cy, cz &
|
||||
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p &
|
||||
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p )
|
||||
|
||||
schwartz_ij = coef2 * coef2 * dabs( cx + cy + cz )
|
||||
if( schwartz_kl(0,0) * schwartz_ij < thr ) cycle
|
||||
|
||||
do r = 1, ao_prim_num(k)
|
||||
if( schwartz_kl(0,r) * schwartz_ij < thr ) cycle
|
||||
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
|
||||
expo3 = ao_expo_ordered_transp(r, k)
|
||||
|
||||
do s = 1, ao_prim_num(l)
|
||||
if( schwartz_kl(s,r) * schwartz_ij < thr ) cycle
|
||||
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
|
||||
expo4 = ao_expo_ordered_transp(s, l)
|
||||
|
||||
call give_explicit_poly_and_gaussian( Q1_new, Q1_center, qq1, fact_q1, iorder_q, expo3, expo4 &
|
||||
, K_power, L_power, K_center, L_center, dim1 )
|
||||
q1_inv = 1.d0 / qq1
|
||||
|
||||
call get_cxcycz_j2( dim1, cx, cy, cz &
|
||||
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p &
|
||||
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q )
|
||||
|
||||
j1b_gauss_2e_j2_schwartz = j1b_gauss_2e_j2_schwartz + coef4 * ( cx + cy + cz )
|
||||
enddo ! s
|
||||
enddo ! r
|
||||
enddo ! q
|
||||
enddo ! p
|
||||
|
||||
deallocate( schwartz_kl )
|
||||
|
||||
return
|
||||
end function j1b_gauss_2e_j2_schwartz
|
||||
|
||||
! ---
|
||||
|
||||
subroutine get_cxcycz_j2( dim1, cx, cy, cz &
|
||||
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p &
|
||||
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q )
|
||||
|
||||
include 'utils/constants.include.F'
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: dim1
|
||||
integer, intent(in) :: iorder_p(3), iorder_q(3)
|
||||
double precision, intent(in) :: P1_new(0:max_dim,3), P1_center(3), fact_p1, pp1, p1_inv
|
||||
double precision, intent(in) :: Q1_new(0:max_dim,3), Q1_center(3), fact_q1, qq1, q1_inv
|
||||
double precision, intent(out) :: cx, cy, cz
|
||||
|
||||
integer :: ii
|
||||
integer :: shift_P(3), shift_Q(3)
|
||||
double precision :: coefii, expoii, factii, Centerii(3)
|
||||
double precision :: P2_new(0:max_dim,3), P2_center(3), fact_p2, pp2, p2_inv
|
||||
double precision :: Q2_new(0:max_dim,3), Q2_center(3), fact_q2, qq2, q2_inv
|
||||
double precision :: ff, gg
|
||||
|
||||
double precision :: general_primitive_integral_erf_shifted
|
||||
double precision :: general_primitive_integral_coul_shifted
|
||||
|
||||
PROVIDE j1b_pen j1b_coeff
|
||||
|
||||
cx = 0.d0
|
||||
cy = 0.d0
|
||||
cz = 0.d0
|
||||
do ii = 1, nucl_num
|
||||
|
||||
expoii = j1b_pen (ii)
|
||||
coefii = j1b_coeff(ii)
|
||||
Centerii(1:3) = nucl_coord(ii, 1:3)
|
||||
|
||||
call gaussian_product(pp1, P1_center, expoii, Centerii, factii, pp2, P2_center)
|
||||
fact_p2 = fact_p1 * factii
|
||||
p2_inv = 1.d0 / pp2
|
||||
call pol_modif_center( P1_center, P2_center, iorder_p, P1_new, P2_new )
|
||||
|
||||
call gaussian_product(qq1, Q1_center, expoii, Centerii, factii, qq2, Q2_center)
|
||||
fact_q2 = fact_q1 * factii
|
||||
q2_inv = 1.d0 / qq2
|
||||
call pol_modif_center( Q1_center, Q2_center, iorder_q, Q1_new, Q2_new )
|
||||
|
||||
|
||||
! ----------------------------------------------------------------------------------------------------
|
||||
! [ (1-erf(mu r12)) / r12 ] \sum_A a_A c_A [ (r1-RA)^2 exp(-aA r1A^2)
|
||||
! ----------------------------------------------------------------------------------------------------
|
||||
|
||||
shift_Q = (/ 0, 0, 0 /)
|
||||
|
||||
! x term:
|
||||
ff = P2_center(1) - Centerii(1)
|
||||
|
||||
shift_P = (/ 2, 0, 0 /)
|
||||
cx = cx + expoii * coefii * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
cx = cx - expoii * coefii * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
|
||||
shift_P = (/ 1, 0, 0 /)
|
||||
cx = cx + expoii * coefii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
cx = cx - expoii * coefii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
|
||||
shift_P = (/ 0, 0, 0 /)
|
||||
cx = cx + expoii * coefii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
cx = cx - expoii * coefii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
|
||||
! y term:
|
||||
ff = P2_center(2) - Centerii(2)
|
||||
|
||||
shift_P = (/ 0, 2, 0 /)
|
||||
cy = cy + expoii * coefii * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
cy = cy - expoii * coefii * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
|
||||
shift_P = (/ 0, 1, 0 /)
|
||||
cy = cy + expoii * coefii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
cy = cy - expoii * coefii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
|
||||
shift_P = (/ 0, 0, 0 /)
|
||||
cy = cy + expoii * coefii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
cy = cy - expoii * coefii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
|
||||
! z term:
|
||||
ff = P2_center(3) - Centerii(3)
|
||||
|
||||
shift_P = (/ 0, 0, 2 /)
|
||||
cz = cz + expoii * coefii * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
cz = cz - expoii * coefii * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
|
||||
shift_P = (/ 0, 0, 1 /)
|
||||
cz = cz + expoii * coefii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
cz = cz - expoii * coefii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
|
||||
shift_P = (/ 0, 0, 0 /)
|
||||
cz = cz + expoii * coefii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
cz = cz - expoii * coefii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
! ----------------------------------------------------------------------------------------------------
|
||||
|
||||
|
||||
|
||||
! ----------------------------------------------------------------------------------------------------
|
||||
! [ (1-erf(mu r12)) / r12 ] \sum_A a_A c_A [ (r2-RA)^2 exp(-aA r2A^2)
|
||||
! ----------------------------------------------------------------------------------------------------
|
||||
|
||||
shift_P = (/ 0, 0, 0 /)
|
||||
|
||||
! x term:
|
||||
ff = Q2_center(1) - Centerii(1)
|
||||
|
||||
shift_Q = (/ 2, 0, 0 /)
|
||||
cx = cx + expoii * coefii * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
cx = cx - expoii * coefii * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
|
||||
shift_Q = (/ 1, 0, 0 /)
|
||||
cx = cx + expoii * coefii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
cx = cx - expoii * coefii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
|
||||
shift_Q = (/ 0, 0, 0 /)
|
||||
cx = cx + expoii * coefii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
cx = cx - expoii * coefii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
|
||||
! y term:
|
||||
ff = Q2_center(2) - Centerii(2)
|
||||
|
||||
shift_Q = (/ 0, 2, 0 /)
|
||||
cy = cy + expoii * coefii * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
cy = cy - expoii * coefii * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
|
||||
shift_Q = (/ 0, 1, 0 /)
|
||||
cy = cy + expoii * coefii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
cy = cy - expoii * coefii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
|
||||
shift_Q = (/ 0, 0, 0 /)
|
||||
cy = cy + expoii * coefii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
cy = cy - expoii * coefii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
|
||||
! z term:
|
||||
ff = Q2_center(3) - Centerii(3)
|
||||
|
||||
shift_Q = (/ 0, 0, 2 /)
|
||||
cz = cz + expoii * coefii * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
cz = cz - expoii * coefii * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
|
||||
shift_Q = (/ 0, 0, 1 /)
|
||||
cz = cz + expoii * coefii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
cz = cz - expoii * coefii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
|
||||
shift_Q = (/ 0, 0, 0 /)
|
||||
cz = cz + expoii * coefii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
cz = cz - expoii * coefii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
|
||||
! ----------------------------------------------------------------------------------------------------
|
||||
|
||||
|
||||
|
||||
! ----------------------------------------------------------------------------------------------------
|
||||
! - [ (1-erf(mu r12)) / r12 ] \sum_A a_A c_A [ (r1-RA) \cdot (r2-RA) exp(-aA r1A^2) ]
|
||||
! ----------------------------------------------------------------------------------------------------
|
||||
|
||||
! x term:
|
||||
ff = P2_center(1) - Centerii(1)
|
||||
gg = Q1_center(1) - Centerii(1)
|
||||
|
||||
shift_p = (/ 1, 0, 0 /)
|
||||
shift_Q = (/ 1, 0, 0 /)
|
||||
cx = cx - expoii * coefii * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
cx = cx + expoii * coefii * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
|
||||
shift_p = (/ 1, 0, 0 /)
|
||||
shift_Q = (/ 0, 0, 0 /)
|
||||
cx = cx - expoii * coefii * gg * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
cx = cx + expoii * coefii * gg * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
|
||||
shift_p = (/ 0, 0, 0 /)
|
||||
shift_Q = (/ 1, 0, 0 /)
|
||||
cx = cx - expoii * coefii * ff * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
cx = cx + expoii * coefii * ff * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
|
||||
shift_p = (/ 0, 0, 0 /)
|
||||
shift_Q = (/ 0, 0, 0 /)
|
||||
cx = cx - expoii * coefii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
cx = cx + expoii * coefii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
|
||||
! y term:
|
||||
ff = P2_center(2) - Centerii(2)
|
||||
gg = Q1_center(2) - Centerii(2)
|
||||
|
||||
shift_p = (/ 0, 1, 0 /)
|
||||
shift_Q = (/ 0, 1, 0 /)
|
||||
cy = cy - expoii * coefii * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
cy = cy + expoii * coefii * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
|
||||
shift_p = (/ 0, 1, 0 /)
|
||||
shift_Q = (/ 0, 0, 0 /)
|
||||
cy = cy - expoii * coefii * gg * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
cy = cy + expoii * coefii * gg * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
|
||||
shift_p = (/ 0, 0, 0 /)
|
||||
shift_Q = (/ 0, 1, 0 /)
|
||||
cy = cy - expoii * coefii * ff * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
cy = cy + expoii * coefii * ff * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
|
||||
shift_p = (/ 0, 0, 0 /)
|
||||
shift_Q = (/ 0, 0, 0 /)
|
||||
cy = cy - expoii * coefii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
cy = cy + expoii * coefii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
|
||||
! z term:
|
||||
ff = P2_center(3) - Centerii(3)
|
||||
gg = Q1_center(3) - Centerii(3)
|
||||
|
||||
shift_p = (/ 0, 0, 1 /)
|
||||
shift_Q = (/ 0, 0, 1 /)
|
||||
cz = cz - expoii * coefii * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
cz = cz + expoii * coefii * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
|
||||
shift_p = (/ 0, 0, 1 /)
|
||||
shift_Q = (/ 0, 0, 0 /)
|
||||
cz = cz - expoii * coefii * gg * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
cz = cz + expoii * coefii * gg * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
|
||||
shift_p = (/ 0, 0, 0 /)
|
||||
shift_Q = (/ 0, 0, 1 /)
|
||||
cz = cz - expoii * coefii * ff * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
cz = cz + expoii * coefii * ff * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
|
||||
shift_p = (/ 0, 0, 0 /)
|
||||
shift_Q = (/ 0, 0, 0 /)
|
||||
cz = cz - expoii * coefii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
cz = cz + expoii * coefii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
|
||||
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
|
||||
|
||||
! ----------------------------------------------------------------------------------------------------
|
||||
|
||||
|
||||
|
||||
! ----------------------------------------------------------------------------------------------------
|
||||
! - [ (1-erf(mu r12)) / r12 ] \sum_A a_A c_A [ (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ]
|
||||
! ----------------------------------------------------------------------------------------------------
|
||||
|
||||
! x term:
|
||||
ff = P1_center(1) - Centerii(1)
|
||||
gg = Q2_center(1) - Centerii(1)
|
||||
|
||||
shift_p = (/ 1, 0, 0 /)
|
||||
shift_Q = (/ 1, 0, 0 /)
|
||||
cx = cx - expoii * coefii * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
cx = cx + expoii * coefii * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
|
||||
shift_p = (/ 1, 0, 0 /)
|
||||
shift_Q = (/ 0, 0, 0 /)
|
||||
cx = cx - expoii * coefii * gg * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
cx = cx + expoii * coefii * gg * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
|
||||
shift_p = (/ 0, 0, 0 /)
|
||||
shift_Q = (/ 1, 0, 0 /)
|
||||
cx = cx - expoii * coefii * ff * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
cx = cx + expoii * coefii * ff * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
|
||||
shift_p = (/ 0, 0, 0 /)
|
||||
shift_Q = (/ 0, 0, 0 /)
|
||||
cx = cx - expoii * coefii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
cx = cx + expoii * coefii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
|
||||
! y term:
|
||||
ff = P1_center(2) - Centerii(2)
|
||||
gg = Q2_center(2) - Centerii(2)
|
||||
|
||||
shift_p = (/ 0, 1, 0 /)
|
||||
shift_Q = (/ 0, 1, 0 /)
|
||||
cy = cy - expoii * coefii * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
cy = cy + expoii * coefii * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
|
||||
shift_p = (/ 0, 1, 0 /)
|
||||
shift_Q = (/ 0, 0, 0 /)
|
||||
cy = cy - expoii * coefii * gg * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
cy = cy + expoii * coefii * gg * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
|
||||
shift_p = (/ 0, 0, 0 /)
|
||||
shift_Q = (/ 0, 1, 0 /)
|
||||
cy = cy - expoii * coefii * ff * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
cy = cy + expoii * coefii * ff * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
|
||||
shift_p = (/ 0, 0, 0 /)
|
||||
shift_Q = (/ 0, 0, 0 /)
|
||||
cy = cy - expoii * coefii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
cy = cy + expoii * coefii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
|
||||
! z term:
|
||||
ff = P1_center(3) - Centerii(3)
|
||||
gg = Q2_center(3) - Centerii(3)
|
||||
|
||||
shift_p = (/ 0, 0, 1 /)
|
||||
shift_Q = (/ 0, 0, 1 /)
|
||||
cz = cz - expoii * coefii * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
cz = cz + expoii * coefii * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
|
||||
shift_p = (/ 0, 0, 1 /)
|
||||
shift_Q = (/ 0, 0, 0 /)
|
||||
cz = cz - expoii * coefii * gg * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
cz = cz + expoii * coefii * gg * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
|
||||
shift_p = (/ 0, 0, 0 /)
|
||||
shift_Q = (/ 0, 0, 1 /)
|
||||
cz = cz - expoii * coefii * ff * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
cz = cz + expoii * coefii * ff * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
|
||||
shift_p = (/ 0, 0, 0 /)
|
||||
shift_Q = (/ 0, 0, 0 /)
|
||||
cz = cz - expoii * coefii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
cz = cz + expoii * coefii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
|
||||
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
|
||||
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
|
||||
|
||||
! ----------------------------------------------------------------------------------------------------
|
||||
|
||||
enddo
|
||||
|
||||
return
|
||||
end subroutine get_cxcycz_j2
|
||||
|
||||
! ---
|
||||
|
||||
327
src/ao_tc_eff_map/two_e_ints_gauss.irp.f
Normal file
327
src/ao_tc_eff_map/two_e_ints_gauss.irp.f
Normal file
@ -0,0 +1,327 @@
|
||||
double precision function ao_tc_sym_two_e_pot(i,j,k,l)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! integral of the AO basis <ik|jl> or (ij|kl)
|
||||
! i(r1) j(r1) (tc_pot(r12,mu)) k(r2) l(r2)
|
||||
!
|
||||
! where (tc_pot(r12,mu)) is the scalar part of the potential EXCLUDING the term erf(mu r12)/r12.
|
||||
!
|
||||
! See Eq. (32) of JCP 154, 084119 (2021).
|
||||
END_DOC
|
||||
integer,intent(in) :: i,j,k,l
|
||||
integer :: p,q,r,s
|
||||
double precision :: I_center(3),J_center(3),K_center(3),L_center(3)
|
||||
integer :: num_i,num_j,num_k,num_l,dim1,I_power(3),J_power(3),K_power(3),L_power(3)
|
||||
double precision :: integral
|
||||
include 'utils/constants.include.F'
|
||||
double precision :: P_new(0:max_dim,3),P_center(3),fact_p,pp
|
||||
double precision :: Q_new(0:max_dim,3),Q_center(3),fact_q,qq
|
||||
integer :: iorder_p(3), iorder_q(3)
|
||||
double precision, allocatable :: schwartz_kl(:,:)
|
||||
double precision :: schwartz_ij
|
||||
double precision :: scw_gauss_int,general_primitive_integral_gauss
|
||||
|
||||
dim1 = n_pt_max_integrals
|
||||
|
||||
num_i = ao_nucl(i)
|
||||
num_j = ao_nucl(j)
|
||||
num_k = ao_nucl(k)
|
||||
num_l = ao_nucl(l)
|
||||
ao_tc_sym_two_e_pot = 0.d0
|
||||
double precision :: thr
|
||||
thr = ao_integrals_threshold*ao_integrals_threshold
|
||||
|
||||
allocate(schwartz_kl(0:ao_prim_num(l),0:ao_prim_num(k)))
|
||||
|
||||
double precision :: coef3
|
||||
double precision :: coef2
|
||||
double precision :: p_inv,q_inv
|
||||
double precision :: coef1
|
||||
double precision :: coef4
|
||||
|
||||
do p = 1, 3
|
||||
I_power(p) = ao_power(i,p)
|
||||
J_power(p) = ao_power(j,p)
|
||||
K_power(p) = ao_power(k,p)
|
||||
L_power(p) = ao_power(l,p)
|
||||
I_center(p) = nucl_coord(num_i,p)
|
||||
J_center(p) = nucl_coord(num_j,p)
|
||||
K_center(p) = nucl_coord(num_k,p)
|
||||
L_center(p) = nucl_coord(num_l,p)
|
||||
enddo
|
||||
|
||||
schwartz_kl(0,0) = 0.d0
|
||||
do r = 1, ao_prim_num(k)
|
||||
coef1 = ao_coef_normalized_ordered_transp(r,k)*ao_coef_normalized_ordered_transp(r,k)
|
||||
schwartz_kl(0,r) = 0.d0
|
||||
do s = 1, ao_prim_num(l)
|
||||
coef2 = coef1 * ao_coef_normalized_ordered_transp(s,l) * ao_coef_normalized_ordered_transp(s,l)
|
||||
call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,&
|
||||
ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l), &
|
||||
K_power,L_power,K_center,L_center,dim1)
|
||||
q_inv = 1.d0/qq
|
||||
scw_gauss_int = general_primitive_integral_gauss(dim1, &
|
||||
Q_new,Q_center,fact_q,qq,q_inv,iorder_q, &
|
||||
Q_new,Q_center,fact_q,qq,q_inv,iorder_q)
|
||||
|
||||
schwartz_kl(s,r) = dabs(scw_gauss_int * coef2)
|
||||
schwartz_kl(0,r) = max(schwartz_kl(0,r),schwartz_kl(s,r))
|
||||
enddo
|
||||
schwartz_kl(0,0) = max(schwartz_kl(0,r),schwartz_kl(0,0))
|
||||
enddo
|
||||
do p = 1, ao_prim_num(i)
|
||||
coef1 = ao_coef_normalized_ordered_transp(p,i)
|
||||
do q = 1, ao_prim_num(j)
|
||||
coef2 = coef1*ao_coef_normalized_ordered_transp(q,j)
|
||||
call give_explicit_poly_and_gaussian(P_new,P_center,pp,fact_p,iorder_p,&
|
||||
ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j), &
|
||||
I_power,J_power,I_center,J_center,dim1)
|
||||
p_inv = 1.d0/pp
|
||||
scw_gauss_int = general_primitive_integral_gauss(dim1, &
|
||||
P_new,P_center,fact_p,pp,p_inv,iorder_p, &
|
||||
P_new,P_center,fact_p,pp,p_inv,iorder_p)
|
||||
schwartz_ij = dabs(scw_gauss_int * coef2*coef2)
|
||||
if (schwartz_kl(0,0)*schwartz_ij < thr) then
|
||||
cycle
|
||||
endif
|
||||
do r = 1, ao_prim_num(k)
|
||||
if (schwartz_kl(0,r)*schwartz_ij < thr) then
|
||||
cycle
|
||||
endif
|
||||
coef3 = coef2*ao_coef_normalized_ordered_transp(r,k)
|
||||
do s = 1, ao_prim_num(l)
|
||||
if (schwartz_kl(s,r)*schwartz_ij < thr) then
|
||||
cycle
|
||||
endif
|
||||
coef4 = coef3*ao_coef_normalized_ordered_transp(s,l)
|
||||
call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q, &
|
||||
ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l), &
|
||||
K_power,L_power,K_center,L_center,dim1)
|
||||
q_inv = 1.d0/qq
|
||||
integral = general_primitive_integral_gauss(dim1, &
|
||||
P_new,P_center,fact_p,pp,p_inv,iorder_p, &
|
||||
Q_new,Q_center,fact_q,qq,q_inv,iorder_q)
|
||||
ao_tc_sym_two_e_pot = ao_tc_sym_two_e_pot + coef4 * integral
|
||||
enddo ! s
|
||||
enddo ! r
|
||||
enddo ! q
|
||||
enddo ! p
|
||||
|
||||
deallocate (schwartz_kl)
|
||||
|
||||
end
|
||||
|
||||
|
||||
double precision function general_primitive_integral_gauss(dim, &
|
||||
P_new,P_center,fact_p,p,p_inv,iorder_p, &
|
||||
Q_new,Q_center,fact_q,q,q_inv,iorder_q)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Computes the integral <pq|rs> where p,q,r,s are Gaussian primitives
|
||||
END_DOC
|
||||
integer,intent(in) :: dim
|
||||
include 'utils/constants.include.F'
|
||||
double precision, intent(in) :: P_new(0:max_dim,3),P_center(3),fact_p,p,p_inv
|
||||
double precision, intent(in) :: Q_new(0:max_dim,3),Q_center(3),fact_q,q,q_inv
|
||||
integer, intent(in) :: iorder_p(3)
|
||||
integer, intent(in) :: iorder_q(3)
|
||||
|
||||
double precision :: r_cut,gama_r_cut,rho,dist
|
||||
double precision :: dx(0:max_dim),Ix_pol(0:max_dim),dy(0:max_dim),Iy_pol(0:max_dim),dz(0:max_dim),Iz_pol(0:max_dim)
|
||||
integer :: n_Ix,n_Iy,n_Iz,nx,ny,nz
|
||||
double precision :: bla
|
||||
integer :: ix,iy,iz,jx,jy,jz,i
|
||||
double precision :: a,b,c,d,e,f,accu,pq,const
|
||||
double precision :: pq_inv, p10_1, p10_2, p01_1, p01_2,pq_inv_2
|
||||
integer :: n_pt_tmp,n_pt_out, iorder
|
||||
double precision :: d1(0:max_dim),d_poly(0:max_dim),rint,d1_screened(0:max_dim)
|
||||
double precision :: thr
|
||||
|
||||
thr = ao_integrals_threshold
|
||||
|
||||
general_primitive_integral_gauss = 0.d0
|
||||
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: dx,Ix_pol,dy,Iy_pol,dz,Iz_pol
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: d1, d_poly
|
||||
|
||||
! Gaussian Product
|
||||
! ----------------
|
||||
|
||||
pq = p_inv*0.5d0*q_inv
|
||||
pq_inv = 0.5d0/(p+q)
|
||||
p10_1 = q*pq ! 1/(2p)
|
||||
p01_1 = p*pq ! 1/(2q)
|
||||
pq_inv_2 = pq_inv+pq_inv
|
||||
p10_2 = pq_inv_2 * p10_1*q !0.5d0*q/(pq + p*p)
|
||||
p01_2 = pq_inv_2 * p01_1*p !0.5d0*p/(q*q + pq)
|
||||
|
||||
|
||||
accu = 0.d0
|
||||
iorder = iorder_p(1)+iorder_q(1)+iorder_p(1)+iorder_q(1)
|
||||
do ix=0,iorder
|
||||
Ix_pol(ix) = 0.d0
|
||||
enddo
|
||||
n_Ix = 0
|
||||
do ix = 0, iorder_p(1)
|
||||
if (abs(P_new(ix,1)) < thr) cycle
|
||||
a = P_new(ix,1)
|
||||
do jx = 0, iorder_q(1)
|
||||
d = a*Q_new(jx,1)
|
||||
if (abs(d) < thr) cycle
|
||||
!DIR$ FORCEINLINE
|
||||
call give_polynom_mult_center_x(P_center(1),Q_center(1),ix,jx,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dx,nx)
|
||||
!DIR$ FORCEINLINE
|
||||
call add_poly_multiply(dx,nx,d,Ix_pol,n_Ix)
|
||||
enddo
|
||||
enddo
|
||||
if (n_Ix == -1) then
|
||||
return
|
||||
endif
|
||||
iorder = iorder_p(2)+iorder_q(2)+iorder_p(2)+iorder_q(2)
|
||||
do ix=0, iorder
|
||||
Iy_pol(ix) = 0.d0
|
||||
enddo
|
||||
n_Iy = 0
|
||||
do iy = 0, iorder_p(2)
|
||||
if (abs(P_new(iy,2)) > thr) then
|
||||
b = P_new(iy,2)
|
||||
do jy = 0, iorder_q(2)
|
||||
e = b*Q_new(jy,2)
|
||||
if (abs(e) < thr) cycle
|
||||
!DIR$ FORCEINLINE
|
||||
call give_polynom_mult_center_x(P_center(2),Q_center(2),iy,jy,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dy,ny)
|
||||
!DIR$ FORCEINLINE
|
||||
call add_poly_multiply(dy,ny,e,Iy_pol,n_Iy)
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
if (n_Iy == -1) then
|
||||
return
|
||||
endif
|
||||
|
||||
iorder = iorder_p(3)+iorder_q(3)+iorder_p(3)+iorder_q(3)
|
||||
do ix=0,iorder
|
||||
Iz_pol(ix) = 0.d0
|
||||
enddo
|
||||
n_Iz = 0
|
||||
do iz = 0, iorder_p(3)
|
||||
if (abs(P_new(iz,3)) > thr) then
|
||||
c = P_new(iz,3)
|
||||
do jz = 0, iorder_q(3)
|
||||
f = c*Q_new(jz,3)
|
||||
if (abs(f) < thr) cycle
|
||||
!DIR$ FORCEINLINE
|
||||
call give_polynom_mult_center_x(P_center(3),Q_center(3),iz,jz,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dz,nz)
|
||||
!DIR$ FORCEINLINE
|
||||
call add_poly_multiply(dz,nz,f,Iz_pol,n_Iz)
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
if (n_Iz == -1) then
|
||||
return
|
||||
endif
|
||||
|
||||
rho = p*q *pq_inv_2
|
||||
dist = (P_center(1) - Q_center(1))*(P_center(1) - Q_center(1)) + &
|
||||
(P_center(2) - Q_center(2))*(P_center(2) - Q_center(2)) + &
|
||||
(P_center(3) - Q_center(3))*(P_center(3) - Q_center(3))
|
||||
const = dist*rho
|
||||
|
||||
n_pt_tmp = n_Ix+n_Iy
|
||||
do i=0,n_pt_tmp
|
||||
d_poly(i)=0.d0
|
||||
enddo
|
||||
|
||||
!DIR$ FORCEINLINE
|
||||
call multiply_poly(Ix_pol,n_Ix,Iy_pol,n_Iy,d_poly,n_pt_tmp)
|
||||
if (n_pt_tmp == -1) then
|
||||
return
|
||||
endif
|
||||
n_pt_out = n_pt_tmp+n_Iz
|
||||
do i=0,n_pt_out
|
||||
d1(i)=0.d0
|
||||
enddo
|
||||
|
||||
!DIR$ FORCEINLINE
|
||||
call multiply_poly(d_poly ,n_pt_tmp ,Iz_pol,n_Iz,d1,n_pt_out)
|
||||
|
||||
double precision :: aa,c_a,t_a,rho_old,w_a,pi_3,prefactor,inv_pq_3_2
|
||||
double precision :: gauss_int
|
||||
integer :: m
|
||||
gauss_int = 0.d0
|
||||
pi_3 = pi*pi*pi
|
||||
inv_pq_3_2 = (p_inv * q_inv)**(1.5d0)
|
||||
rho_old = (p*q)/(p+q)
|
||||
prefactor = pi_3 * inv_pq_3_2 * fact_p * fact_q
|
||||
do i = 1, n_gauss_eff_pot ! browse the gaussians with different expo/coef
|
||||
!do i = 1, n_gauss_eff_pot-1
|
||||
aa = expo_gauss_eff_pot(i)
|
||||
c_a = coef_gauss_eff_pot(i)
|
||||
t_a = dsqrt( aa /(rho_old + aa) )
|
||||
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
|
||||
364
src/ao_tc_eff_map/useful_sub.irp.f
Normal file
364
src/ao_tc_eff_map/useful_sub.irp.f
Normal file
@ -0,0 +1,364 @@
|
||||
! ---
|
||||
|
||||
!______________________________________________________________________________________________________________________
|
||||
!______________________________________________________________________________________________________________________
|
||||
|
||||
double precision function general_primitive_integral_coul_shifted( dim &
|
||||
, P_new, P_center, fact_p, p, p_inv, iorder_p, shift_P &
|
||||
, Q_new, Q_center, fact_q, q, q_inv, iorder_q, shift_Q )
|
||||
|
||||
include 'utils/constants.include.F'
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: dim
|
||||
integer, intent(in) :: iorder_p(3), shift_P(3)
|
||||
integer, intent(in) :: iorder_q(3), shift_Q(3)
|
||||
double precision, intent(in) :: P_new(0:max_dim,3), P_center(3), fact_p, p, p_inv
|
||||
double precision, intent(in) :: Q_new(0:max_dim,3), Q_center(3), fact_q, q, q_inv
|
||||
|
||||
integer :: n_Ix, n_Iy, n_Iz, nx, ny, nz
|
||||
integer :: ix, iy, iz, jx, jy, jz, i
|
||||
integer :: n_pt_tmp, n_pt_out, iorder
|
||||
integer :: ii, jj
|
||||
double precision :: rho, dist
|
||||
double precision :: dx(0:max_dim), Ix_pol(0:max_dim)
|
||||
double precision :: dy(0:max_dim), Iy_pol(0:max_dim)
|
||||
double precision :: dz(0:max_dim), Iz_pol(0:max_dim)
|
||||
double precision :: a, b, c, d, e, f, accu, pq, const
|
||||
double precision :: pq_inv, p10_1, p10_2, p01_1, p01_2, pq_inv_2
|
||||
double precision :: d1(0:max_dim), d_poly(0:max_dim)
|
||||
double precision :: p_plus_q
|
||||
|
||||
double precision :: rint_sum
|
||||
|
||||
general_primitive_integral_coul_shifted = 0.d0
|
||||
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: dx, Ix_pol, dy, Iy_pol, dz, Iz_pol
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: d1, d_poly
|
||||
|
||||
! Gaussian Product
|
||||
! ----------------
|
||||
p_plus_q = (p+q)
|
||||
pq = p_inv * 0.5d0 * q_inv
|
||||
pq_inv = 0.5d0 / p_plus_q
|
||||
p10_1 = q * pq ! 1/(2p)
|
||||
p01_1 = p * pq ! 1/(2q)
|
||||
pq_inv_2 = pq_inv + pq_inv
|
||||
p10_2 = pq_inv_2 * p10_1 * q ! 0.5d0 * q / (pq + p*p)
|
||||
p01_2 = pq_inv_2 * p01_1 * p ! 0.5d0 * p / (q*q + pq)
|
||||
|
||||
accu = 0.d0
|
||||
|
||||
iorder = iorder_p(1) + iorder_q(1) + iorder_p(1) + iorder_q(1)
|
||||
iorder = iorder + shift_P(1) + shift_Q(1)
|
||||
iorder = iorder + shift_P(1) + shift_Q(1)
|
||||
!DIR$ VECTOR ALIGNED
|
||||
do ix = 0, iorder
|
||||
Ix_pol(ix) = 0.d0
|
||||
enddo
|
||||
n_Ix = 0
|
||||
do ix = 0, iorder_p(1)
|
||||
|
||||
ii = ix + shift_P(1)
|
||||
a = P_new(ix,1)
|
||||
if(abs(a) < thresh) cycle
|
||||
|
||||
do jx = 0, iorder_q(1)
|
||||
|
||||
jj = jx + shift_Q(1)
|
||||
d = a * Q_new(jx,1)
|
||||
if(abs(d) < thresh) cycle
|
||||
|
||||
!DEC$ FORCEINLINE
|
||||
call give_polynom_mult_center_x( P_center(1), Q_center(1), ii, jj &
|
||||
, p, q, iorder, pq_inv, pq_inv_2, p10_1, p01_1, p10_2, p01_2, dx, nx )
|
||||
!DEC$ FORCEINLINE
|
||||
call add_poly_multiply(dx, nx, d, Ix_pol, n_Ix)
|
||||
enddo
|
||||
enddo
|
||||
if(n_Ix == -1) then
|
||||
return
|
||||
endif
|
||||
|
||||
iorder = iorder_p(2) + iorder_q(2) + iorder_p(2) + iorder_q(2)
|
||||
iorder = iorder + shift_P(2) + shift_Q(2)
|
||||
iorder = iorder + shift_P(2) + shift_Q(2)
|
||||
!DIR$ VECTOR ALIGNED
|
||||
do ix = 0, iorder
|
||||
Iy_pol(ix) = 0.d0
|
||||
enddo
|
||||
n_Iy = 0
|
||||
do iy = 0, iorder_p(2)
|
||||
|
||||
if(abs(P_new(iy,2)) > thresh) then
|
||||
|
||||
ii = iy + shift_P(2)
|
||||
b = P_new(iy,2)
|
||||
|
||||
do jy = 0, iorder_q(2)
|
||||
|
||||
jj = jy + shift_Q(2)
|
||||
e = b * Q_new(jy,2)
|
||||
if(abs(e) < thresh) cycle
|
||||
|
||||
!DEC$ FORCEINLINE
|
||||
call give_polynom_mult_center_x( P_center(2), Q_center(2), ii, jj &
|
||||
, p, q, iorder, pq_inv, pq_inv_2, p10_1, p01_1, p10_2, p01_2, dy, ny )
|
||||
!DEC$ FORCEINLINE
|
||||
call add_poly_multiply(dy, ny, e, Iy_pol, n_Iy)
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
if(n_Iy == -1) then
|
||||
return
|
||||
endif
|
||||
|
||||
iorder = iorder_p(3) + iorder_q(3) + iorder_p(3) + iorder_q(3)
|
||||
iorder = iorder + shift_P(3) + shift_Q(3)
|
||||
iorder = iorder + shift_P(3) + shift_Q(3)
|
||||
do ix = 0, iorder
|
||||
Iz_pol(ix) = 0.d0
|
||||
enddo
|
||||
n_Iz = 0
|
||||
do iz = 0, iorder_p(3)
|
||||
|
||||
if( abs(P_new(iz,3)) > thresh ) then
|
||||
|
||||
ii = iz + shift_P(3)
|
||||
c = P_new(iz,3)
|
||||
|
||||
do jz = 0, iorder_q(3)
|
||||
|
||||
jj = jz + shift_Q(3)
|
||||
f = c * Q_new(jz,3)
|
||||
if(abs(f) < thresh) cycle
|
||||
|
||||
!DEC$ FORCEINLINE
|
||||
call give_polynom_mult_center_x( P_center(3), Q_center(3), ii, jj &
|
||||
, p, q, iorder, pq_inv, pq_inv_2, p10_1, p01_1, p10_2, p01_2, dz, nz )
|
||||
!DEC$ FORCEINLINE
|
||||
call add_poly_multiply(dz, nz, f, Iz_pol, n_Iz)
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
if(n_Iz == -1) then
|
||||
return
|
||||
endif
|
||||
|
||||
rho = p * q * pq_inv_2
|
||||
dist = (P_center(1) - Q_center(1)) * (P_center(1) - Q_center(1)) &
|
||||
+ (P_center(2) - Q_center(2)) * (P_center(2) - Q_center(2)) &
|
||||
+ (P_center(3) - Q_center(3)) * (P_center(3) - Q_center(3))
|
||||
const = dist*rho
|
||||
|
||||
n_pt_tmp = n_Ix + n_Iy
|
||||
do i = 0, n_pt_tmp
|
||||
d_poly(i) = 0.d0
|
||||
enddo
|
||||
|
||||
!DEC$ FORCEINLINE
|
||||
call multiply_poly(Ix_pol, n_Ix, Iy_pol, n_Iy, d_poly, n_pt_tmp)
|
||||
if(n_pt_tmp == -1) then
|
||||
return
|
||||
endif
|
||||
n_pt_out = n_pt_tmp + n_Iz
|
||||
do i = 0, n_pt_out
|
||||
d1(i) = 0.d0
|
||||
enddo
|
||||
|
||||
!DEC$ FORCEINLINE
|
||||
call multiply_poly(d_poly, n_pt_tmp, Iz_pol, n_Iz, d1, n_pt_out)
|
||||
accu = accu + rint_sum(n_pt_out, const, d1)
|
||||
|
||||
general_primitive_integral_coul_shifted = fact_p * fact_q * accu * pi_5_2 * p_inv * q_inv / dsqrt(p_plus_q)
|
||||
|
||||
return
|
||||
end function general_primitive_integral_coul_shifted
|
||||
!______________________________________________________________________________________________________________________
|
||||
!______________________________________________________________________________________________________________________
|
||||
|
||||
|
||||
|
||||
!______________________________________________________________________________________________________________________
|
||||
!______________________________________________________________________________________________________________________
|
||||
|
||||
double precision function general_primitive_integral_erf_shifted( dim &
|
||||
, P_new, P_center, fact_p, p, p_inv, iorder_p, shift_P &
|
||||
, Q_new, Q_center, fact_q, q, q_inv, iorder_q, shift_Q )
|
||||
|
||||
include 'utils/constants.include.F'
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: dim
|
||||
integer, intent(in) :: iorder_p(3), shift_P(3)
|
||||
integer, intent(in) :: iorder_q(3), shift_Q(3)
|
||||
double precision, intent(in) :: P_new(0:max_dim,3), P_center(3), fact_p, p, p_inv
|
||||
double precision, intent(in) :: Q_new(0:max_dim,3), Q_center(3), fact_q, q, q_inv
|
||||
|
||||
integer :: n_Ix, n_Iy, n_Iz, nx, ny, nz
|
||||
integer :: ix, iy, iz, jx, jy, jz, i
|
||||
integer :: n_pt_tmp, n_pt_out, iorder
|
||||
integer :: ii, jj
|
||||
double precision :: rho, dist
|
||||
double precision :: dx(0:max_dim), Ix_pol(0:max_dim)
|
||||
double precision :: dy(0:max_dim), Iy_pol(0:max_dim)
|
||||
double precision :: dz(0:max_dim), Iz_pol(0:max_dim)
|
||||
double precision :: a, b, c, d, e, f, accu, pq, const
|
||||
double precision :: pq_inv, p10_1, p10_2, p01_1, p01_2, pq_inv_2
|
||||
double precision :: d1(0:max_dim), d_poly(0:max_dim)
|
||||
double precision :: p_plus_q
|
||||
|
||||
double precision :: rint_sum
|
||||
|
||||
general_primitive_integral_erf_shifted = 0.d0
|
||||
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: dx, Ix_pol, dy, Iy_pol, dz, Iz_pol
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: d1, d_poly
|
||||
|
||||
! Gaussian Product
|
||||
! ----------------
|
||||
p_plus_q = (p+q) * ( (p*q)/(p+q) + mu_erf*mu_erf ) / (mu_erf*mu_erf)
|
||||
pq = p_inv * 0.5d0 * q_inv
|
||||
pq_inv = 0.5d0 / p_plus_q
|
||||
p10_1 = q * pq ! 1/(2p)
|
||||
p01_1 = p * pq ! 1/(2q)
|
||||
pq_inv_2 = pq_inv + pq_inv
|
||||
p10_2 = pq_inv_2 * p10_1 * q ! 0.5d0 * q / (pq + p*p)
|
||||
p01_2 = pq_inv_2 * p01_1 * p ! 0.5d0 * p / (q*q + pq)
|
||||
|
||||
accu = 0.d0
|
||||
|
||||
iorder = iorder_p(1) + iorder_q(1) + iorder_p(1) + iorder_q(1)
|
||||
iorder = iorder + shift_P(1) + shift_Q(1)
|
||||
iorder = iorder + shift_P(1) + shift_Q(1)
|
||||
!DIR$ VECTOR ALIGNED
|
||||
do ix = 0, iorder
|
||||
Ix_pol(ix) = 0.d0
|
||||
enddo
|
||||
n_Ix = 0
|
||||
do ix = 0, iorder_p(1)
|
||||
|
||||
ii = ix + shift_P(1)
|
||||
a = P_new(ix,1)
|
||||
if(abs(a) < thresh) cycle
|
||||
|
||||
do jx = 0, iorder_q(1)
|
||||
|
||||
jj = jx + shift_Q(1)
|
||||
d = a * Q_new(jx,1)
|
||||
if(abs(d) < thresh) cycle
|
||||
|
||||
!DEC$ FORCEINLINE
|
||||
call give_polynom_mult_center_x( P_center(1), Q_center(1), ii, jj &
|
||||
, p, q, iorder, pq_inv, pq_inv_2, p10_1, p01_1, p10_2, p01_2, dx, nx )
|
||||
!DEC$ FORCEINLINE
|
||||
call add_poly_multiply(dx, nx, d, Ix_pol, n_Ix)
|
||||
enddo
|
||||
enddo
|
||||
if(n_Ix == -1) then
|
||||
return
|
||||
endif
|
||||
|
||||
iorder = iorder_p(2) + iorder_q(2) + iorder_p(2) + iorder_q(2)
|
||||
iorder = iorder + shift_P(2) + shift_Q(2)
|
||||
iorder = iorder + shift_P(2) + shift_Q(2)
|
||||
!DIR$ VECTOR ALIGNED
|
||||
do ix = 0, iorder
|
||||
Iy_pol(ix) = 0.d0
|
||||
enddo
|
||||
n_Iy = 0
|
||||
do iy = 0, iorder_p(2)
|
||||
|
||||
if(abs(P_new(iy,2)) > thresh) then
|
||||
|
||||
ii = iy + shift_P(2)
|
||||
b = P_new(iy,2)
|
||||
|
||||
do jy = 0, iorder_q(2)
|
||||
|
||||
jj = jy + shift_Q(2)
|
||||
e = b * Q_new(jy,2)
|
||||
if(abs(e) < thresh) cycle
|
||||
|
||||
!DEC$ FORCEINLINE
|
||||
call give_polynom_mult_center_x( P_center(2), Q_center(2), ii, jj &
|
||||
, p, q, iorder, pq_inv, pq_inv_2, p10_1, p01_1, p10_2, p01_2, dy, ny )
|
||||
!DEC$ FORCEINLINE
|
||||
call add_poly_multiply(dy, ny, e, Iy_pol, n_Iy)
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
if(n_Iy == -1) then
|
||||
return
|
||||
endif
|
||||
|
||||
iorder = iorder_p(3) + iorder_q(3) + iorder_p(3) + iorder_q(3)
|
||||
iorder = iorder + shift_P(3) + shift_Q(3)
|
||||
iorder = iorder + shift_P(3) + shift_Q(3)
|
||||
do ix = 0, iorder
|
||||
Iz_pol(ix) = 0.d0
|
||||
enddo
|
||||
n_Iz = 0
|
||||
do iz = 0, iorder_p(3)
|
||||
|
||||
if( abs(P_new(iz,3)) > thresh ) then
|
||||
|
||||
ii = iz + shift_P(3)
|
||||
c = P_new(iz,3)
|
||||
|
||||
do jz = 0, iorder_q(3)
|
||||
|
||||
jj = jz + shift_Q(3)
|
||||
f = c * Q_new(jz,3)
|
||||
if(abs(f) < thresh) cycle
|
||||
|
||||
!DEC$ FORCEINLINE
|
||||
call give_polynom_mult_center_x( P_center(3), Q_center(3), ii, jj &
|
||||
, p, q, iorder, pq_inv, pq_inv_2, p10_1, p01_1, p10_2, p01_2, dz, nz )
|
||||
!DEC$ FORCEINLINE
|
||||
call add_poly_multiply(dz, nz, f, Iz_pol, n_Iz)
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
if(n_Iz == -1) then
|
||||
return
|
||||
endif
|
||||
|
||||
rho = p * q * pq_inv_2
|
||||
dist = (P_center(1) - Q_center(1)) * (P_center(1) - Q_center(1)) &
|
||||
+ (P_center(2) - Q_center(2)) * (P_center(2) - Q_center(2)) &
|
||||
+ (P_center(3) - Q_center(3)) * (P_center(3) - Q_center(3))
|
||||
const = dist*rho
|
||||
|
||||
n_pt_tmp = n_Ix + n_Iy
|
||||
do i = 0, n_pt_tmp
|
||||
d_poly(i) = 0.d0
|
||||
enddo
|
||||
|
||||
!DEC$ FORCEINLINE
|
||||
call multiply_poly(Ix_pol, n_Ix, Iy_pol, n_Iy, d_poly, n_pt_tmp)
|
||||
if(n_pt_tmp == -1) then
|
||||
return
|
||||
endif
|
||||
n_pt_out = n_pt_tmp + n_Iz
|
||||
do i = 0, n_pt_out
|
||||
d1(i) = 0.d0
|
||||
enddo
|
||||
|
||||
!DEC$ FORCEINLINE
|
||||
call multiply_poly(d_poly, n_pt_tmp, Iz_pol, n_Iz, d1, n_pt_out)
|
||||
accu = accu + rint_sum(n_pt_out, const, d1)
|
||||
|
||||
general_primitive_integral_erf_shifted = fact_p * fact_q * accu * pi_5_2 * p_inv * q_inv / dsqrt(p_plus_q)
|
||||
|
||||
return
|
||||
end function general_primitive_integral_erf_shifted
|
||||
!______________________________________________________________________________________________________________________
|
||||
!______________________________________________________________________________________________________________________
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
4
src/bi_ort_ints/NEED
Normal file
4
src/bi_ort_ints/NEED
Normal file
@ -0,0 +1,4 @@
|
||||
non_h_ints_mu
|
||||
ao_tc_eff_map
|
||||
bi_ortho_mos
|
||||
tc_keywords
|
||||
25
src/bi_ort_ints/README.rst
Normal file
25
src/bi_ort_ints/README.rst
Normal file
@ -0,0 +1,25 @@
|
||||
===========
|
||||
bi_ort_ints
|
||||
===========
|
||||
|
||||
This module contains all necessary integrals for the TC Hamiltonian in a bi-orthonormal (BO) MO Basis.
|
||||
See in bi_ortho_basis for more information.
|
||||
The main providers are :
|
||||
|
||||
One-electron integrals
|
||||
----------------------
|
||||
+) ao_one_e_integrals_tc_tot : total one-electron Hamiltonian which might include non hermitian part coming from one-e correlation factor.
|
||||
+) mo_bi_ortho_tc_one_e : one-electron Hamiltonian (h_core+one-J terms) on the BO-MO basis.
|
||||
+) mo_bi_orth_bipole_x : x-component of the dipole operator on the BO-MO basis. (Same for y,z)
|
||||
|
||||
Two-electron integrals
|
||||
----------------------
|
||||
+) ao_two_e_tc_tot : Total two-electron operator (including the non-hermitian term of the TC Hamiltonian) on the AO basis
|
||||
+) mo_bi_ortho_tc_two_e : Total two-electron operator on the BO-MO basis
|
||||
|
||||
Three-electron integrals
|
||||
------------------------
|
||||
+) three_body_ints_bi_ort : 6-indices three-electron tensor (-L) on the BO-MO basis. WARNING :: N^6 storage !
|
||||
+) three_e_3_idx_direct_bi_ort : DIRECT term with 3 different indices of the -L operator. These terms appear in the DIAGONAL matrix element of the -L operator. The 5 other permutations needed to compute matrix elements can be found in three_body_ijm.irp.f
|
||||
+) three_e_4_idx_direct_bi_ort : DIRECT term with 4 different indices of the -L operator. These terms appear in the OFF-DIAGONAL matrix element of the -L operator including SINGLE EXCITATIONS. The 5 other permutations needed to compute matrix elements can be found in three_body_ijmk.irp.f
|
||||
+) three_e_5_idx_direct_bi_ort : DIRECT term with 5 different indices of the -L operator. These terms appear in the OFF-DIAGONAL matrix element of the -L operator including DOUBLE EXCITATIONS. The 5 other permutations needed to compute matrix elements can be found in three_body_ijmkl.irp.f
|
||||
44
src/bi_ort_ints/bi_ort_ints.irp.f
Normal file
44
src/bi_ort_ints/bi_ort_ints.irp.f
Normal file
@ -0,0 +1,44 @@
|
||||
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 = 10
|
||||
my_n_pt_a_grid = 14
|
||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||
call test_3e
|
||||
end
|
||||
|
||||
subroutine test_3e
|
||||
implicit none
|
||||
integer :: i,k,j,l,m,n,ipoint
|
||||
double precision :: accu, contrib,new,ref
|
||||
i = 1
|
||||
k = 1
|
||||
accu = 0.d0
|
||||
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
|
||||
do n = 1, mo_num
|
||||
call give_integrals_3_body_bi_ort(n, l, k, m, j, i, new)
|
||||
call give_integrals_3_body_bi_ort_old(n, l, k, m, j, i, ref)
|
||||
contrib = dabs(new - ref)
|
||||
accu += contrib
|
||||
if(contrib .gt. 1.d-10)then
|
||||
print*,'pb !!'
|
||||
print*,i,k,j,l,m,n
|
||||
print*,ref,new,contrib
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
print*,'accu = ',accu/dble(mo_num)**6
|
||||
|
||||
|
||||
end
|
||||
153
src/bi_ort_ints/biorthog_mo_for_h.irp.f
Normal file
153
src/bi_ort_ints/biorthog_mo_for_h.irp.f
Normal file
@ -0,0 +1,153 @@
|
||||
|
||||
! ---
|
||||
|
||||
double precision function bi_ortho_mo_coul_ints(l, k, j, i)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! < mo^L_k mo^L_l | 1/r12 | mo^R_i mo^R_j >
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: i, j, k, l
|
||||
integer :: m, n, p, q
|
||||
|
||||
bi_ortho_mo_coul_ints = 0.d0
|
||||
do m = 1, ao_num
|
||||
do p = 1, ao_num
|
||||
do n = 1, ao_num
|
||||
do q = 1, ao_num
|
||||
! p1h1p2h2 l1 l2 r1 r2
|
||||
bi_ortho_mo_coul_ints += ao_two_e_coul(n,q,m,p) * mo_l_coef(m,l) * mo_l_coef(n,k) * mo_r_coef(p,j) * mo_r_coef(q,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
end function bi_ortho_mo_coul_ints
|
||||
|
||||
! ---
|
||||
|
||||
! TODO :: transform into DEGEMM
|
||||
|
||||
BEGIN_PROVIDER [double precision, mo_bi_ortho_coul_e_chemist, (mo_num, mo_num, mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! mo_bi_ortho_coul_e_chemist(k,i,l,j) = < k l | 1/r12 | i j > where i,j are right MOs and k,l are left MOs
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, l, m, n, p, q
|
||||
double precision, allocatable :: mo_tmp_1(:,:,:,:), mo_tmp_2(:,:,:,:)
|
||||
|
||||
allocate(mo_tmp_1(mo_num,ao_num,ao_num,ao_num))
|
||||
mo_tmp_1 = 0.d0
|
||||
|
||||
do m = 1, ao_num
|
||||
do p = 1, ao_num
|
||||
do n = 1, ao_num
|
||||
do q = 1, ao_num
|
||||
do k = 1, mo_num
|
||||
! (k n|p m) = sum_q c_qk * (q n|p m)
|
||||
mo_tmp_1(k,n,p,m) += mo_l_coef_transp(k,q) * ao_two_e_coul(q,n,p,m)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
allocate(mo_tmp_2(mo_num,mo_num,ao_num,ao_num))
|
||||
mo_tmp_2 = 0.d0
|
||||
|
||||
do m = 1, ao_num
|
||||
do p = 1, ao_num
|
||||
do n = 1, ao_num
|
||||
do i = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
! (k i|p m) = sum_n c_ni * (k n|p m)
|
||||
mo_tmp_2(k,i,p,m) += mo_r_coef_transp(i,n) * mo_tmp_1(k,n,p,m)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
deallocate(mo_tmp_1)
|
||||
|
||||
allocate(mo_tmp_1(mo_num,mo_num,mo_num,ao_num))
|
||||
mo_tmp_1 = 0.d0
|
||||
do m = 1, ao_num
|
||||
do p = 1, ao_num
|
||||
do l = 1, mo_num
|
||||
do i = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
mo_tmp_1(k,i,l,m) += mo_l_coef_transp(l,p) * mo_tmp_2(k,i,p,m)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
deallocate(mo_tmp_2)
|
||||
|
||||
mo_bi_ortho_coul_e_chemist = 0.d0
|
||||
do m = 1, ao_num
|
||||
do j = 1, mo_num
|
||||
do l = 1, mo_num
|
||||
do i = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
mo_bi_ortho_coul_e_chemist(k,i,l,j) += mo_r_coef_transp(j,m) * mo_tmp_1(k,i,l,m)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
deallocate(mo_tmp_1)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, mo_bi_ortho_coul_e, (mo_num, mo_num, mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! mo_bi_ortho_coul_e(k,l,i,j) = < k l | 1/r12 | i j > where i,j are right MOs and k,l are left MOs
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, l
|
||||
|
||||
do j = 1, mo_num
|
||||
do i = 1, mo_num
|
||||
do l = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
! < k l | V12 | i j > (k i|l j)
|
||||
mo_bi_ortho_coul_e(k,l,i,j) = mo_bi_ortho_coul_e_chemist(k,i,l,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, mo_bi_ortho_one_e, (mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! mo_bi_ortho_one_e(k,i) = < MO^L_k | h_c | MO^R_i >
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
call ao_to_mo_bi_ortho(ao_one_e_integrals, ao_num, mo_bi_ortho_one_e , mo_num)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
75
src/bi_ort_ints/one_e_bi_ort.irp.f
Normal file
75
src/bi_ort_ints/one_e_bi_ort.irp.f
Normal file
@ -0,0 +1,75 @@
|
||||
|
||||
! ---
|
||||
|
||||
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_type
|
||||
|
||||
if( (j1b_type .eq. 1) .or. (j1b_type .eq. 2) ) 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)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! mo_bi_ortho_tc_one_e(k,i) = <MO^L_k | h_c | MO^R_i>
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
call ao_to_mo_bi_ortho(ao_one_e_integrals_tc_tot, ao_num, mo_bi_ortho_tc_one_e, mo_num)
|
||||
|
||||
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
|
||||
|
||||
318
src/bi_ort_ints/semi_num_ints_mo.irp.f
Normal file
318
src/bi_ort_ints/semi_num_ints_mo.irp.f
Normal file
@ -0,0 +1,318 @@
|
||||
|
||||
! ---
|
||||
|
||||
! TODO :: optimization : transform into a DGEMM
|
||||
|
||||
BEGIN_PROVIDER [ double precision, mo_v_ki_bi_ortho_erf_rk_cst_mu, (mo_num, mo_num, n_points_final_grid)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! mo_v_ki_bi_ortho_erf_rk_cst_mu(k,i,ip) = int dr chi_k(r) phi_i(r) (erf(mu |r - R_ip|) - 1 )/(2|r - R_ip|) on the BI-ORTHO MO basis
|
||||
!
|
||||
! where phi_k(r) is a LEFT MOs and phi_i(r) is a RIGHT MO
|
||||
!
|
||||
! R_ip = the "ip"-th point of the DFT Grid
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: ipoint
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint) &
|
||||
!$OMP SHARED (n_points_final_grid,v_ij_erf_rk_cst_mu,mo_v_ki_bi_ortho_erf_rk_cst_mu)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
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)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! int dr phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/(2|r - R|) on the BI-ORTHO MO basis
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: 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
|
||||
|
||||
! ---
|
||||
|
||||
! TODO :: optimization : transform into a DGEMM
|
||||
|
||||
BEGIN_PROVIDER [ double precision, mo_x_v_ki_bi_ortho_erf_rk_cst_mu, (mo_num, mo_num, 3, n_points_final_grid)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! mo_x_v_ki_bi_ortho_erf_rk_cst_mu(k,i,m,ip) = int dr x(m) * chi_k(r) phi_i(r) (erf(mu |r - R_ip|) - 1)/2|r - R_ip| on the BI-ORTHO MO basis
|
||||
!
|
||||
! where chi_k(r)/phi_i(r) are left/right MOs, m=1 => x(m) = x, m=2 => x(m) = y, m=3 => x(m) = z,
|
||||
!
|
||||
! R_ip = the "ip"-th point of the DFT Grid
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: ipoint
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint) &
|
||||
!$OMP SHARED (n_points_final_grid,x_v_ij_erf_rk_cst_mu_transp,mo_x_v_ki_bi_ortho_erf_rk_cst_mu)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
call ao_to_mo_bi_ortho( x_v_ij_erf_rk_cst_mu_transp (1,1,1,ipoint), size(x_v_ij_erf_rk_cst_mu_transp, 1) &
|
||||
, mo_x_v_ki_bi_ortho_erf_rk_cst_mu(1,1,1,ipoint), size(mo_x_v_ki_bi_ortho_erf_rk_cst_mu, 1) )
|
||||
call ao_to_mo_bi_ortho( x_v_ij_erf_rk_cst_mu_transp (1,1,2,ipoint), size(x_v_ij_erf_rk_cst_mu_transp, 1) &
|
||||
, mo_x_v_ki_bi_ortho_erf_rk_cst_mu(1,1,2,ipoint), size(mo_x_v_ki_bi_ortho_erf_rk_cst_mu, 1) )
|
||||
call ao_to_mo_bi_ortho( x_v_ij_erf_rk_cst_mu_transp (1,1,3,ipoint), size(x_v_ij_erf_rk_cst_mu_transp, 1) &
|
||||
, mo_x_v_ki_bi_ortho_erf_rk_cst_mu(1,1,3,ipoint), size(mo_x_v_ki_bi_ortho_erf_rk_cst_mu, 1) )
|
||||
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
mo_x_v_ki_bi_ortho_erf_rk_cst_mu = 0.5d0 * mo_x_v_ki_bi_ortho_erf_rk_cst_mu
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_transp, (ao_num, ao_num, 3, n_points_final_grid)]
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint
|
||||
double precision :: wall0, wall1
|
||||
|
||||
print *, ' providing int2_grad1_u12_ao_transp ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
if(test_cycle_tc)then
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
int2_grad1_u12_ao_transp(j,i,1,ipoint) = int2_grad1_u12_ao_test(j,i,ipoint,1)
|
||||
int2_grad1_u12_ao_transp(j,i,2,ipoint) = int2_grad1_u12_ao_test(j,i,ipoint,2)
|
||||
int2_grad1_u12_ao_transp(j,i,3,ipoint) = int2_grad1_u12_ao_test(j,i,ipoint,3)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
else
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
int2_grad1_u12_ao_transp(j,i,1,ipoint) = int2_grad1_u12_ao(j,i,ipoint,1)
|
||||
int2_grad1_u12_ao_transp(j,i,2,ipoint) = int2_grad1_u12_ao(j,i,ipoint,2)
|
||||
int2_grad1_u12_ao_transp(j,i,3,ipoint) = int2_grad1_u12_ao(j,i,ipoint,3)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for int2_grad1_u12_ao_transp ', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_transp, (mo_num, mo_num, 3, n_points_final_grid)]
|
||||
|
||||
implicit none
|
||||
integer :: ipoint
|
||||
double precision :: wall0, wall1
|
||||
|
||||
!print *, ' providing int2_grad1_u12_bimo_transp'
|
||||
|
||||
call wall_time(wall0)
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint) &
|
||||
!$OMP SHARED (n_points_final_grid,int2_grad1_u12_ao_transp,int2_grad1_u12_bimo_transp)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do ipoint = 1, n_points_final_grid
|
||||
call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp (1,1,1,ipoint), size(int2_grad1_u12_ao_transp , 1) &
|
||||
, int2_grad1_u12_bimo_transp(1,1,1,ipoint), size(int2_grad1_u12_bimo_transp, 1) )
|
||||
call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp (1,1,2,ipoint), size(int2_grad1_u12_ao_transp , 1) &
|
||||
, int2_grad1_u12_bimo_transp(1,1,2,ipoint), size(int2_grad1_u12_bimo_transp, 1) )
|
||||
call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp (1,1,3,ipoint), size(int2_grad1_u12_ao_transp , 1) &
|
||||
, int2_grad1_u12_bimo_transp(1,1,3,ipoint), size(int2_grad1_u12_bimo_transp, 1) )
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
call wall_time(wall1)
|
||||
!print *, ' Wall time for providing int2_grad1_u12_bimo_transp',wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_t, (n_points_final_grid,3, mo_num, mo_num )]
|
||||
implicit none
|
||||
integer :: i, j, ipoint
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
int2_grad1_u12_bimo_t(ipoint,1,j,i) = int2_grad1_u12_bimo_transp(j,i,1,ipoint)
|
||||
int2_grad1_u12_bimo_t(ipoint,2,j,i) = int2_grad1_u12_bimo_transp(j,i,2,ipoint)
|
||||
int2_grad1_u12_bimo_t(ipoint,3,j,i) = int2_grad1_u12_bimo_transp(j,i,3,ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_t, (n_points_final_grid, 3, ao_num, ao_num)]
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
int2_grad1_u12_ao_t(ipoint,1,j,i) = int2_grad1_u12_ao(j,i,ipoint,1)
|
||||
int2_grad1_u12_ao_t(ipoint,2,j,i) = int2_grad1_u12_ao(j,i,ipoint,2)
|
||||
int2_grad1_u12_ao_t(ipoint,3,j,i) = int2_grad1_u12_ao(j,i,ipoint,3)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp, (n_points_final_grid, 3, mo_num, mo_num)]
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint
|
||||
|
||||
do i = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,1,j,i) = mo_x_v_ki_bi_ortho_erf_rk_cst_mu(j,i,1,ipoint)
|
||||
mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,2,j,i) = mo_x_v_ki_bi_ortho_erf_rk_cst_mu(j,i,2,ipoint)
|
||||
mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,3,j,i) = mo_x_v_ki_bi_ortho_erf_rk_cst_mu(j,i,3,ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
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) \frac{(1 - erf(mu |r-R_ip|))}{2|r-R_ip|} (x(m)-R_ip(m)) phi_i(r) ON THE BI-ORTHO MO BASIS
|
||||
!
|
||||
! where chi_k(r)/phi_i(r) are left/right MOs, m=1 => X(m) = x, m=2 => X(m) = y, m=3 => X(m) = z,
|
||||
!
|
||||
! R_ip = the "ip"-th point of the DFT Grid
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
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
|
||||
|
||||
! ---
|
||||
|
||||
366
src/bi_ort_ints/three_body_ijm.irp.f
Normal file
366
src/bi_ort_ints/three_body_ijm.irp.f
Normal file
@ -0,0 +1,366 @@
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, three_e_3_idx_direct_bi_ort, (mo_num, mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the direct terms
|
||||
!
|
||||
! three_e_3_idx_direct_bi_ort(m,j,i) = <mji|-L|mji>
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, m
|
||||
double precision :: integral, wall1, wall0
|
||||
|
||||
three_e_3_idx_direct_bi_ort = 0.d0
|
||||
print *, ' Providing the three_e_3_idx_direct_bi_ort ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,m,integral) &
|
||||
!$OMP SHARED (mo_num,three_e_3_idx_direct_bi_ort)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do i = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do m = j, mo_num
|
||||
call give_integrals_3_body_bi_ort(m, j, i, m, j, i, integral)
|
||||
three_e_3_idx_direct_bi_ort(m,j,i) = -1.d0 * integral
|
||||
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_direct_bi_ort(m,j,i) = three_e_3_idx_direct_bi_ort(j,m,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for three_e_3_idx_direct_bi_ort', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, three_e_3_idx_cycle_1_bi_ort, (mo_num, mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the first cyclic permutation
|
||||
!
|
||||
! three_e_3_idx_cycle_1_bi_ort(m,j,i) = <mji|-L|jim>
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, m
|
||||
double precision :: integral, wall1, wall0
|
||||
|
||||
three_e_3_idx_cycle_1_bi_ort = 0.d0
|
||||
print *, ' Providing the three_e_3_idx_cycle_1_bi_ort ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,m,integral) &
|
||||
!$OMP SHARED (mo_num,three_e_3_idx_cycle_1_bi_ort)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do i = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do m = j, mo_num
|
||||
call give_integrals_3_body_bi_ort(m, j, i, j, i, m, integral)
|
||||
three_e_3_idx_cycle_1_bi_ort(m,j,i) = -1.d0 * integral
|
||||
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_cycle_1_bi_ort(m,j,i) = three_e_3_idx_cycle_1_bi_ort(j,m,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for three_e_3_idx_cycle_1_bi_ort', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, three_e_3_idx_cycle_2_bi_ort, (mo_num, mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the second cyclic permutation
|
||||
!
|
||||
! three_e_3_idx_direct_bi_ort(m,j,i) = <mji|-L|imj>
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, m
|
||||
double precision :: integral, wall1, wall0
|
||||
|
||||
three_e_3_idx_cycle_2_bi_ort = 0.d0
|
||||
print *, ' Providing the three_e_3_idx_cycle_2_bi_ort ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,m,integral) &
|
||||
!$OMP SHARED (mo_num,three_e_3_idx_cycle_2_bi_ort)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do i = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do m = j, mo_num
|
||||
call give_integrals_3_body_bi_ort(m, j, i, i, m, j, integral)
|
||||
three_e_3_idx_cycle_2_bi_ort(m,j,i) = -1.d0 * integral
|
||||
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_cycle_2_bi_ort(m,j,i) = three_e_3_idx_cycle_2_bi_ort(j,m,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for three_e_3_idx_cycle_2_bi_ort', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, three_e_3_idx_exch23_bi_ort, (mo_num, mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the permutations of particle 2 and 3
|
||||
!
|
||||
! three_e_3_idx_exch23_bi_ort(m,j,i) = <mji|-L|jmi>
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, m
|
||||
double precision :: integral, wall1, wall0
|
||||
|
||||
three_e_3_idx_exch23_bi_ort = 0.d0
|
||||
print*,'Providing the three_e_3_idx_exch23_bi_ort ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,m,integral) &
|
||||
!$OMP SHARED (mo_num,three_e_3_idx_exch23_bi_ort)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do i = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do m = j, mo_num
|
||||
call give_integrals_3_body_bi_ort(m, j, i, j, m, i, integral)
|
||||
three_e_3_idx_exch23_bi_ort(m,j,i) = -1.d0 * integral
|
||||
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)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the permutations of particle 1 and 3
|
||||
!
|
||||
! three_e_3_idx_exch13_bi_ort(m,j,i) = <mji|-L|ijm>
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i,j,m
|
||||
double precision :: integral, wall1, wall0
|
||||
|
||||
three_e_3_idx_exch13_bi_ort = 0.d0
|
||||
print *, ' Providing the three_e_3_idx_exch13_bi_ort ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,m,integral) &
|
||||
!$OMP SHARED (mo_num,three_e_3_idx_exch13_bi_ort)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do i = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do m = j, mo_num
|
||||
call give_integrals_3_body_bi_ort(m, j, i, i, j, m,integral)
|
||||
three_e_3_idx_exch13_bi_ort(m,j,i) = -1.d0 * integral
|
||||
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)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the permutations of particle 1 and 2
|
||||
!
|
||||
! three_e_3_idx_exch12_bi_ort(m,j,i) = <mji|-L|mij>
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, m
|
||||
double precision :: integral, wall1, wall0
|
||||
|
||||
three_e_3_idx_exch12_bi_ort = 0.d0
|
||||
print *, ' Providing the three_e_3_idx_exch12_bi_ort ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,m,integral) &
|
||||
!$OMP SHARED (mo_num,three_e_3_idx_exch12_bi_ort)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do i = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do m = 1, mo_num
|
||||
call give_integrals_3_body_bi_ort(m, j, i, m, i, j, integral)
|
||||
three_e_3_idx_exch12_bi_ort(m,j,i) = -1.d0 * integral
|
||||
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)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the permutations of particle 1 and 2
|
||||
!
|
||||
! three_e_3_idx_exch12_bi_ort_new(m,j,i) = <mji|-L|mij>
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, m
|
||||
double precision :: integral, wall1, wall0
|
||||
|
||||
three_e_3_idx_exch12_bi_ort_new = 0.d0
|
||||
print *, ' Providing the three_e_3_idx_exch12_bi_ort_new ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,m,integral) &
|
||||
!$OMP SHARED (mo_num,three_e_3_idx_exch12_bi_ort_new)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do i = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do m = j, mo_num
|
||||
call give_integrals_3_body_bi_ort(m, j, i, m, i, j, integral)
|
||||
three_e_3_idx_exch12_bi_ort_new(m,j,i) = -1.d0 * integral
|
||||
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
|
||||
|
||||
! ---
|
||||
|
||||
284
src/bi_ort_ints/three_body_ijmk.irp.f
Normal file
284
src/bi_ort_ints/three_body_ijmk.irp.f
Normal file
@ -0,0 +1,284 @@
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, three_e_4_idx_direct_bi_ort, (mo_num, mo_num, mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
|
||||
!
|
||||
! three_e_4_idx_direct_bi_ort(m,j,k,i) = <mjk|-L|mji> ::: notice that i is the RIGHT MO and k is the LEFT MO
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, m
|
||||
double precision :: integral, wall1, wall0
|
||||
|
||||
three_e_4_idx_direct_bi_ort = 0.d0
|
||||
print *, ' Providing the three_e_4_idx_direct_bi_ort ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,k,m,integral) &
|
||||
!$OMP SHARED (mo_num,three_e_4_idx_direct_bi_ort)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do i = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do m = 1, mo_num
|
||||
call give_integrals_3_body_bi_ort(m, j, k, m, j, i, integral)
|
||||
three_e_4_idx_direct_bi_ort(m,j,k,i) = -1.d0 * integral
|
||||
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)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! matrix element of the -L three-body operator FOR THE FIRST CYCLIC PERMUTATION TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
|
||||
!
|
||||
! three_e_4_idx_cycle_1_bi_ort(m,j,k,i) = <mjk|-L|jim> ::: notice that i is the RIGHT MO and k is the LEFT MO
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, m
|
||||
double precision :: integral, wall1, wall0
|
||||
|
||||
three_e_4_idx_cycle_1_bi_ort = 0.d0
|
||||
print *, ' Providing the three_e_4_idx_cycle_1_bi_ort ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,k,m,integral) &
|
||||
!$OMP SHARED (mo_num,three_e_4_idx_cycle_1_bi_ort)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do i = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do m = 1, mo_num
|
||||
call give_integrals_3_body_bi_ort(m, j, k, j, i, m, integral)
|
||||
three_e_4_idx_cycle_1_bi_ort(m,j,k,i) = -1.d0 * integral
|
||||
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)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! matrix element of the -L three-body operator FOR THE FIRST CYCLIC PERMUTATION TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
|
||||
!
|
||||
! three_e_4_idx_cycle_2_bi_ort(m,j,k,i) = <mjk|-L|imj> ::: notice that i is the RIGHT MO and k is the LEFT MO
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, m
|
||||
double precision :: integral, wall1, wall0
|
||||
|
||||
three_e_4_idx_cycle_2_bi_ort = 0.d0
|
||||
print *, ' Providing the three_e_4_idx_cycle_2_bi_ort ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,k,m,integral) &
|
||||
!$OMP SHARED (mo_num,three_e_4_idx_cycle_2_bi_ort)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do i = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do m = 1, mo_num
|
||||
call give_integrals_3_body_bi_ort(m, j, k, i, m, j, integral)
|
||||
three_e_4_idx_cycle_2_bi_ort(m,j,k,i) = -1.d0 * integral
|
||||
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)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
|
||||
!
|
||||
! three_e_4_idx_exch23_bi_ort(m,j,k,i) = <mjk|-L|jmi> ::: notice that i is the RIGHT MO and k is the LEFT MO
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, m
|
||||
double precision :: integral, wall1, wall0
|
||||
|
||||
three_e_4_idx_exch23_bi_ort = 0.d0
|
||||
print *, ' Providing the three_e_4_idx_exch23_bi_ort ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,k,m,integral) &
|
||||
!$OMP SHARED (mo_num,three_e_4_idx_exch23_bi_ort)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do i = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do m = 1, mo_num
|
||||
call give_integrals_3_body_bi_ort(m, j, k, j, m, i, integral)
|
||||
three_e_4_idx_exch23_bi_ort(m,j,k,i) = -1.d0 * integral
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for three_e_4_idx_exch23_bi_ort', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, three_e_4_idx_exch13_bi_ort, (mo_num, mo_num, mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
|
||||
!
|
||||
! three_e_4_idx_exch13_bi_ort(m,j,k,i) = <mjk|-L|ijm> ::: notice that i is the RIGHT MO and k is the LEFT MO
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, m
|
||||
double precision :: integral, wall1, wall0
|
||||
|
||||
three_e_4_idx_exch13_bi_ort = 0.d0
|
||||
print *, ' Providing the three_e_4_idx_exch13_bi_ort ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,k,m,integral) &
|
||||
!$OMP SHARED (mo_num,three_e_4_idx_exch13_bi_ort)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do i = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do m = 1, mo_num
|
||||
call give_integrals_3_body_bi_ort(m, j, k, i, j, m, integral)
|
||||
three_e_4_idx_exch13_bi_ort(m,j,k,i) = -1.d0 * integral
|
||||
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)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
|
||||
!
|
||||
! three_e_4_idx_exch12_bi_ort(m,j,k,i) = <mjk|-L|mij> ::: notice that i is the RIGHT MO and k is the LEFT MO
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, m
|
||||
double precision :: integral, wall1, wall0
|
||||
|
||||
three_e_4_idx_exch12_bi_ort = 0.d0
|
||||
print *, ' Providing the three_e_4_idx_exch12_bi_ort ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,k,m,integral) &
|
||||
!$OMP SHARED (mo_num,three_e_4_idx_exch12_bi_ort)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do i = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do m = 1, mo_num
|
||||
call give_integrals_3_body_bi_ort(m, j, k, m, i, j, integral)
|
||||
three_e_4_idx_exch12_bi_ort(m,j,k,i) = -1.d0 * integral
|
||||
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
|
||||
|
||||
! ---
|
||||
|
||||
296
src/bi_ort_ints/three_body_ijmkl.irp.f
Normal file
296
src/bi_ort_ints/three_body_ijmkl.irp.f
Normal file
@ -0,0 +1,296 @@
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, three_e_5_idx_direct_bi_ort, (mo_num, mo_num, mo_num, mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
|
||||
!
|
||||
! three_e_5_idx_direct_bi_ort(m,l,j,k,i) = <mlk|-L|mji> ::: notice that i is the RIGHT MO and k is the LEFT MO
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, m, l
|
||||
double precision :: integral, wall1, wall0
|
||||
|
||||
three_e_5_idx_direct_bi_ort = 0.d0
|
||||
print *, ' Providing the three_e_5_idx_direct_bi_ort ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,k,m,l,integral) &
|
||||
!$OMP SHARED (mo_num,three_e_5_idx_direct_bi_ort)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do i = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do l = 1, mo_num
|
||||
do m = 1, mo_num
|
||||
call give_integrals_3_body_bi_ort(m, l, k, m, j, i, integral)
|
||||
three_e_5_idx_direct_bi_ort(m,l,j,k,i) = -1.d0 * integral
|
||||
enddo
|
||||
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)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! matrix element of the -L three-body operator FOR THE FIRST CYCLIC PERMUTATION TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
|
||||
!
|
||||
! three_e_5_idx_cycle_1_bi_ort(m,l,j,k,i) = <mlk|-L|jim> ::: notice that i is the RIGHT MO and k is the LEFT MO
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, m, l
|
||||
double precision :: integral, wall1, wall0
|
||||
|
||||
three_e_5_idx_cycle_1_bi_ort = 0.d0
|
||||
print *, ' Providing the three_e_5_idx_cycle_1_bi_ort ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,k,m,l,integral) &
|
||||
!$OMP SHARED (mo_num,three_e_5_idx_cycle_1_bi_ort)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do i = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do l = 1, mo_num
|
||||
do m = 1, mo_num
|
||||
call give_integrals_3_body_bi_ort(m, l, k, j, i, m, integral)
|
||||
three_e_5_idx_cycle_1_bi_ort(m,l,j,k,i) = -1.d0 * integral
|
||||
enddo
|
||||
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)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! matrix element of the -L three-body operator FOR THE FIRST CYCLIC PERMUTATION TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
|
||||
!
|
||||
! three_e_5_idx_cycle_2_bi_ort(m,l,j,k,i) = <mlk|-L|imj> ::: notice that i is the RIGHT MO and k is the LEFT MO
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, m, l
|
||||
double precision :: integral, wall1, wall0
|
||||
|
||||
three_e_5_idx_cycle_2_bi_ort = 0.d0
|
||||
print *, ' Providing the three_e_5_idx_cycle_2_bi_ort ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,k,m,l,integral) &
|
||||
!$OMP SHARED (mo_num,three_e_5_idx_cycle_2_bi_ort)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do i = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do m = 1, mo_num
|
||||
do l = 1, mo_num
|
||||
call give_integrals_3_body_bi_ort(m, l, k, i, m, j, integral)
|
||||
three_e_5_idx_cycle_2_bi_ort(m,l,j,k,i) = -1.d0 * integral
|
||||
enddo
|
||||
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)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
|
||||
!
|
||||
! three_e_5_idx_exch23_bi_ort(m,l,j,k,i) = <mlk|-L|jmi> ::: notice that i is the RIGHT MO and k is the LEFT MO
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, m, l
|
||||
double precision :: integral, wall1, wall0
|
||||
|
||||
three_e_5_idx_exch23_bi_ort = 0.d0
|
||||
print *, ' Providing the three_e_5_idx_exch23_bi_ort ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,k,m,l,integral) &
|
||||
!$OMP SHARED (mo_num,three_e_5_idx_exch23_bi_ort)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do i = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do l = 1, mo_num
|
||||
do m = 1, mo_num
|
||||
call give_integrals_3_body_bi_ort(m, l, k, j, m, i, integral)
|
||||
three_e_5_idx_exch23_bi_ort(m,l,j,k,i) = -1.d0 * integral
|
||||
enddo
|
||||
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)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
|
||||
!
|
||||
! three_e_5_idx_exch13_bi_ort(m,l,j,k,i) = <mlk|-L|ijm> ::: notice that i is the RIGHT MO and k is the LEFT MO
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, m, l
|
||||
double precision :: integral, wall1, wall0
|
||||
|
||||
three_e_5_idx_exch13_bi_ort = 0.d0
|
||||
print *, ' Providing the three_e_5_idx_exch13_bi_ort ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,k,m,l,integral) &
|
||||
!$OMP SHARED (mo_num,three_e_5_idx_exch13_bi_ort)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do i = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do l = 1, mo_num
|
||||
do m = 1, mo_num
|
||||
call give_integrals_3_body_bi_ort(m, l, k, i, j, m, integral)
|
||||
three_e_5_idx_exch13_bi_ort(m,l,j,k,i) = -1.d0 * integral
|
||||
enddo
|
||||
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)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
|
||||
!
|
||||
! three_e_5_idx_exch12_bi_ort(m,l,j,k,i) = <mlk|-L|mij> ::: notice that i is the RIGHT MO and k is the LEFT MO
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, m, l
|
||||
double precision :: integral, wall1, wall0
|
||||
|
||||
three_e_5_idx_exch12_bi_ort = 0.d0
|
||||
print *, ' Providing the three_e_5_idx_exch12_bi_ort ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,k,m,l,integral) &
|
||||
!$OMP SHARED (mo_num,three_e_5_idx_exch12_bi_ort)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do i = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do l = 1, mo_num
|
||||
do m = 1, mo_num
|
||||
call give_integrals_3_body_bi_ort(m, l, k, m, i, j, integral)
|
||||
three_e_5_idx_exch12_bi_ort(m,l,j,k,i) = -1.d0 * integral
|
||||
enddo
|
||||
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
|
||||
|
||||
! ---
|
||||
|
||||
207
src/bi_ort_ints/three_body_ints_bi_ort.irp.f
Normal file
207
src/bi_ort_ints/three_body_ints_bi_ort.irp.f
Normal file
@ -0,0 +1,207 @@
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, three_body_ints_bi_ort, (mo_num, mo_num, mo_num, mo_num, mo_num, mo_num)]
|
||||
|
||||
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
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, l, m, n
|
||||
double precision :: integral, wall1, wall0
|
||||
character*(128) :: name_file
|
||||
|
||||
three_body_ints_bi_ort = 0.d0
|
||||
print *, ' Providing the three_body_ints_bi_ort ...'
|
||||
call wall_time(wall0)
|
||||
name_file = 'six_index_tensor'
|
||||
|
||||
! 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
|
||||
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,k,l,m,n,integral) &
|
||||
!$OMP SHARED (mo_num,three_body_ints_bi_ort)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do i = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do m = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
do l = 1, mo_num
|
||||
do n = 1, mo_num
|
||||
call give_integrals_3_body_bi_ort(n, l, k, m, j, i, integral)
|
||||
|
||||
three_body_ints_bi_ort(n,l,k,m,j,i) = -1.d0 * integral
|
||||
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)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! < n l k | -L | m j i > with a BI-ORTHONORMAL MOLECULAR ORBITALS
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: n, l, k, m, j, i
|
||||
double precision, intent(out) :: integral
|
||||
integer :: ipoint
|
||||
double precision :: weight
|
||||
|
||||
integral = 0.d0
|
||||
do ipoint = 1, n_points_final_grid
|
||||
weight = final_weight_at_r_vector(ipoint)
|
||||
|
||||
integral += weight * mos_l_in_r_array_transp(ipoint,k) * mos_r_in_r_array_transp(ipoint,i) &
|
||||
* ( int2_grad1_u12_bimo_t(ipoint,1,n,m) * int2_grad1_u12_bimo_t(ipoint,1,l,j) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,2,n,m) * int2_grad1_u12_bimo_t(ipoint,2,l,j) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,3,n,m) * int2_grad1_u12_bimo_t(ipoint,3,l,j) )
|
||||
integral += weight * mos_l_in_r_array_transp(ipoint,l) * mos_r_in_r_array_transp(ipoint,j) &
|
||||
* ( int2_grad1_u12_bimo_t(ipoint,1,n,m) * int2_grad1_u12_bimo_t(ipoint,1,k,i) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,2,n,m) * int2_grad1_u12_bimo_t(ipoint,2,k,i) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,3,n,m) * int2_grad1_u12_bimo_t(ipoint,3,k,i) )
|
||||
integral += weight * mos_l_in_r_array_transp(ipoint,n) * mos_r_in_r_array_transp(ipoint,m) &
|
||||
* ( int2_grad1_u12_bimo_t(ipoint,1,l,j) * int2_grad1_u12_bimo_t(ipoint,1,k,i) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,2,l,j) * int2_grad1_u12_bimo_t(ipoint,2,k,i) &
|
||||
+ int2_grad1_u12_bimo_t(ipoint,3,l,j) * int2_grad1_u12_bimo_t(ipoint,3,k,i) )
|
||||
|
||||
enddo
|
||||
|
||||
end subroutine give_integrals_3_body_bi_ort
|
||||
|
||||
! ---
|
||||
|
||||
subroutine give_integrals_3_body_bi_ort_old(n, l, k, m, j, i, integral)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! < n l k | -L | m j i > with a BI-ORTHONORMAL MOLECULAR ORBITALS
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: n, l, k, m, j, i
|
||||
double precision, intent(out) :: integral
|
||||
integer :: ipoint
|
||||
double precision :: weight
|
||||
|
||||
integral = 0.d0
|
||||
do ipoint = 1, n_points_final_grid
|
||||
weight = final_weight_at_r_vector(ipoint)
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! integral += weight * mos_l_in_r_array_transp(ipoint,k) * mos_r_in_r_array_transp(ipoint,i) &
|
||||
! * ( x_W_ki_bi_ortho_erf_rk(ipoint,1,n,m) * x_W_ki_bi_ortho_erf_rk(ipoint,1,l,j) &
|
||||
! + x_W_ki_bi_ortho_erf_rk(ipoint,2,n,m) * x_W_ki_bi_ortho_erf_rk(ipoint,2,l,j) &
|
||||
! + x_W_ki_bi_ortho_erf_rk(ipoint,3,n,m) * x_W_ki_bi_ortho_erf_rk(ipoint,3,l,j) )
|
||||
! integral += weight * mos_l_in_r_array_transp(ipoint,l) * mos_r_in_r_array_transp(ipoint,j) &
|
||||
! * ( x_W_ki_bi_ortho_erf_rk(ipoint,1,n,m) * x_W_ki_bi_ortho_erf_rk(ipoint,1,k,i) &
|
||||
! + x_W_ki_bi_ortho_erf_rk(ipoint,2,n,m) * x_W_ki_bi_ortho_erf_rk(ipoint,2,k,i) &
|
||||
! + x_W_ki_bi_ortho_erf_rk(ipoint,3,n,m) * x_W_ki_bi_ortho_erf_rk(ipoint,3,k,i) )
|
||||
! integral += weight * mos_l_in_r_array_transp(ipoint,n) * mos_r_in_r_array_transp(ipoint,m) &
|
||||
! * ( x_W_ki_bi_ortho_erf_rk(ipoint,1,l,j) * x_W_ki_bi_ortho_erf_rk(ipoint,1,k,i) &
|
||||
! + x_W_ki_bi_ortho_erf_rk(ipoint,2,l,j) * x_W_ki_bi_ortho_erf_rk(ipoint,2,k,i) &
|
||||
! + x_W_ki_bi_ortho_erf_rk(ipoint,3,l,j) * x_W_ki_bi_ortho_erf_rk(ipoint,3,k,i) )
|
||||
|
||||
! integral += weight * mos_l_in_r_array_transp(ipoint,k) * mos_r_in_r_array_transp(ipoint,i) &
|
||||
! * ( int2_grad1_u12_bimo(1,n,m,ipoint) * int2_grad1_u12_bimo(1,l,j,ipoint) &
|
||||
! + int2_grad1_u12_bimo(2,n,m,ipoint) * int2_grad1_u12_bimo(2,l,j,ipoint) &
|
||||
! + int2_grad1_u12_bimo(3,n,m,ipoint) * int2_grad1_u12_bimo(3,l,j,ipoint) )
|
||||
! integral += weight * mos_l_in_r_array_transp(ipoint,l) * mos_r_in_r_array_transp(ipoint,j) &
|
||||
! * ( int2_grad1_u12_bimo(1,n,m,ipoint) * int2_grad1_u12_bimo(1,k,i,ipoint) &
|
||||
! + int2_grad1_u12_bimo(2,n,m,ipoint) * int2_grad1_u12_bimo(2,k,i,ipoint) &
|
||||
! + int2_grad1_u12_bimo(3,n,m,ipoint) * int2_grad1_u12_bimo(3,k,i,ipoint) )
|
||||
! integral += weight * mos_l_in_r_array_transp(ipoint,n) * mos_r_in_r_array_transp(ipoint,m) &
|
||||
! * ( int2_grad1_u12_bimo(1,l,j,ipoint) * int2_grad1_u12_bimo(1,k,i,ipoint) &
|
||||
! + int2_grad1_u12_bimo(2,l,j,ipoint) * int2_grad1_u12_bimo(2,k,i,ipoint) &
|
||||
! + int2_grad1_u12_bimo(3,l,j,ipoint) * int2_grad1_u12_bimo(3,k,i,ipoint) )
|
||||
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
integral += weight * mos_l_in_r_array_transp(ipoint,k) * mos_r_in_r_array_transp(ipoint,i) &
|
||||
* ( int2_grad1_u12_bimo_transp(n,m,1,ipoint) * int2_grad1_u12_bimo_transp(l,j,1,ipoint) &
|
||||
+ int2_grad1_u12_bimo_transp(n,m,2,ipoint) * int2_grad1_u12_bimo_transp(l,j,2,ipoint) &
|
||||
+ int2_grad1_u12_bimo_transp(n,m,3,ipoint) * int2_grad1_u12_bimo_transp(l,j,3,ipoint) )
|
||||
integral += weight * mos_l_in_r_array_transp(ipoint,l) * mos_r_in_r_array_transp(ipoint,j) &
|
||||
* ( int2_grad1_u12_bimo_transp(n,m,1,ipoint) * int2_grad1_u12_bimo_transp(k,i,1,ipoint) &
|
||||
+ int2_grad1_u12_bimo_transp(n,m,2,ipoint) * int2_grad1_u12_bimo_transp(k,i,2,ipoint) &
|
||||
+ int2_grad1_u12_bimo_transp(n,m,3,ipoint) * int2_grad1_u12_bimo_transp(k,i,3,ipoint) )
|
||||
integral += weight * mos_l_in_r_array_transp(ipoint,n) * mos_r_in_r_array_transp(ipoint,m) &
|
||||
* ( int2_grad1_u12_bimo_transp(l,j,1,ipoint) * int2_grad1_u12_bimo_transp(k,i,1,ipoint) &
|
||||
+ int2_grad1_u12_bimo_transp(l,j,2,ipoint) * int2_grad1_u12_bimo_transp(k,i,2,ipoint) &
|
||||
+ int2_grad1_u12_bimo_transp(l,j,3,ipoint) * int2_grad1_u12_bimo_transp(k,i,3,ipoint) )
|
||||
|
||||
enddo
|
||||
|
||||
end subroutine give_integrals_3_body_bi_ort_old
|
||||
|
||||
! ---
|
||||
|
||||
subroutine give_integrals_3_body_bi_ort_ao(n, l, k, m, j, i, integral)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! < n l k | -L | m j i > with a BI-ORTHONORMAL ATOMIC ORBITALS
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: n, l, k, m, j, i
|
||||
double precision, intent(out) :: integral
|
||||
integer :: ipoint
|
||||
double precision :: weight
|
||||
|
||||
integral = 0.d0
|
||||
do ipoint = 1, n_points_final_grid
|
||||
weight = final_weight_at_r_vector(ipoint)
|
||||
|
||||
integral += weight * aos_in_r_array_transp(ipoint,k) * aos_in_r_array_transp(ipoint,i) &
|
||||
* ( int2_grad1_u12_ao_t(ipoint,1,n,m) * int2_grad1_u12_ao_t(ipoint,1,l,j) &
|
||||
+ int2_grad1_u12_ao_t(ipoint,2,n,m) * int2_grad1_u12_ao_t(ipoint,2,l,j) &
|
||||
+ int2_grad1_u12_ao_t(ipoint,3,n,m) * int2_grad1_u12_ao_t(ipoint,3,l,j) )
|
||||
integral += weight * aos_in_r_array_transp(ipoint,l) * aos_in_r_array_transp(ipoint,j) &
|
||||
* ( int2_grad1_u12_ao_t(ipoint,1,n,m) * int2_grad1_u12_ao_t(ipoint,1,k,i) &
|
||||
+ int2_grad1_u12_ao_t(ipoint,2,n,m) * int2_grad1_u12_ao_t(ipoint,2,k,i) &
|
||||
+ int2_grad1_u12_ao_t(ipoint,3,n,m) * int2_grad1_u12_ao_t(ipoint,3,k,i) )
|
||||
integral += weight * aos_in_r_array_transp(ipoint,n) * aos_in_r_array_transp(ipoint,m) &
|
||||
* ( int2_grad1_u12_ao_t(ipoint,1,l,j) * int2_grad1_u12_ao_t(ipoint,1,k,i) &
|
||||
+ int2_grad1_u12_ao_t(ipoint,2,l,j) * int2_grad1_u12_ao_t(ipoint,2,k,i) &
|
||||
+ int2_grad1_u12_ao_t(ipoint,3,l,j) * int2_grad1_u12_ao_t(ipoint,3,k,i) )
|
||||
|
||||
enddo
|
||||
|
||||
end subroutine give_integrals_3_body_bi_ort_ao
|
||||
|
||||
! ---
|
||||
250
src/bi_ort_ints/total_twoe_pot.irp.f
Normal file
250
src/bi_ort_ints/total_twoe_pot.irp.f
Normal file
@ -0,0 +1,250 @@
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_num) ]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! ao_two_e_tc_tot(k,i,l,j) = (ki|V^TC(r_12)|lj) = <lk| V^TC(r_12) |ji> where V^TC(r_12) is the total TC operator
|
||||
!
|
||||
! including both hermitian and non hermitian parts. THIS IS IN CHEMIST NOTATION.
|
||||
!
|
||||
! WARNING :: non hermitian ! acts on "the right functions" (i,j)
|
||||
!
|
||||
END_DOC
|
||||
|
||||
integer :: i, j, k, l
|
||||
double precision :: integral_sym, integral_nsym
|
||||
double precision, external :: get_ao_tc_sym_two_e_pot
|
||||
|
||||
provide j1b_type
|
||||
|
||||
if(j1b_type .eq. 3) then
|
||||
|
||||
do j = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
ao_two_e_tc_tot(k,i,l,j) = ao_tc_int_chemist(k,i,l,j)
|
||||
!write(222,*) ao_two_e_tc_tot(k,i,l,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
else
|
||||
|
||||
PROVIDE ao_tc_sym_two_e_pot_in_map
|
||||
|
||||
do j = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
|
||||
integral_sym = get_ao_tc_sym_two_e_pot(i, j, k, l, ao_tc_sym_two_e_pot_map)
|
||||
! ao_non_hermit_term_chemist(k,i,l,j) = < k l | [erf( mu r12) - 1] d/d_r12 | i j > on the AO basis
|
||||
integral_nsym = ao_non_hermit_term_chemist(k,i,l,j)
|
||||
|
||||
!print *, ' sym integ = ', integral_sym
|
||||
!print *, ' non-sym integ = ', integral_nsym
|
||||
|
||||
ao_two_e_tc_tot(k,i,l,j) = integral_sym + integral_nsym
|
||||
!write(111,*) ao_two_e_tc_tot(k,i,l,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
double precision function bi_ortho_mo_ints(l, k, j, i)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! <mo^L_k mo^L_l | V^TC(r_12) | mo^R_i mo^R_j>
|
||||
!
|
||||
! WARNING :: very naive, super slow, only used to DEBUG.
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: i, j, k, l
|
||||
integer :: m, n, p, q
|
||||
|
||||
bi_ortho_mo_ints = 0.d0
|
||||
do m = 1, ao_num
|
||||
do p = 1, ao_num
|
||||
do n = 1, ao_num
|
||||
do q = 1, ao_num
|
||||
! p1h1p2h2 l1 l2 r1 r2
|
||||
bi_ortho_mo_ints += ao_two_e_tc_tot(n,q,m,p) * mo_l_coef(m,l) * mo_l_coef(n,k) * mo_r_coef(p,j) * mo_r_coef(q,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
end function bi_ortho_mo_ints
|
||||
|
||||
! ---
|
||||
|
||||
! TODO :: transform into DEGEMM
|
||||
|
||||
BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num, mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! mo_bi_ortho_tc_two_e_chemist(k,i,l,j) = <k l|V(r_12)|i j> where i,j are right MOs and k,l are left MOs
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, l, m, n, p, q
|
||||
double precision, allocatable :: mo_tmp_1(:,:,:,:), mo_tmp_2(:,:,:,:)
|
||||
|
||||
allocate(mo_tmp_1(mo_num,ao_num,ao_num,ao_num))
|
||||
mo_tmp_1 = 0.d0
|
||||
|
||||
do m = 1, ao_num
|
||||
do p = 1, ao_num
|
||||
do n = 1, ao_num
|
||||
do q = 1, ao_num
|
||||
do k = 1, mo_num
|
||||
! (k n|p m) = sum_q c_qk * (q n|p m)
|
||||
mo_tmp_1(k,n,p,m) += mo_l_coef_transp(k,q) * ao_two_e_tc_tot(q,n,p,m)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
allocate(mo_tmp_2(mo_num,mo_num,ao_num,ao_num))
|
||||
mo_tmp_2 = 0.d0
|
||||
|
||||
do m = 1, ao_num
|
||||
do p = 1, ao_num
|
||||
do n = 1, ao_num
|
||||
do i = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
! (k i|p m) = sum_n c_ni * (k n|p m)
|
||||
mo_tmp_2(k,i,p,m) += mo_r_coef_transp(i,n) * mo_tmp_1(k,n,p,m)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
deallocate(mo_tmp_1)
|
||||
|
||||
allocate(mo_tmp_1(mo_num,mo_num,mo_num,ao_num))
|
||||
mo_tmp_1 = 0.d0
|
||||
do m = 1, ao_num
|
||||
do p = 1, ao_num
|
||||
do l = 1, mo_num
|
||||
do i = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
mo_tmp_1(k,i,l,m) += mo_l_coef_transp(l,p) * mo_tmp_2(k,i,p,m)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
deallocate(mo_tmp_2)
|
||||
|
||||
mo_bi_ortho_tc_two_e_chemist = 0.d0
|
||||
do m = 1, ao_num
|
||||
do j = 1, mo_num
|
||||
do l = 1, mo_num
|
||||
do i = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
mo_bi_ortho_tc_two_e_chemist(k,i,l,j) += mo_r_coef_transp(j,m) * mo_tmp_1(k,i,l,m)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
deallocate(mo_tmp_1)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e, (mo_num, mo_num, mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! mo_bi_ortho_tc_two_e(k,l,i,j) = <k l| V(r_12) |i j> where i,j are right MOs and k,l are left MOs
|
||||
!
|
||||
! the potential V(r_12) contains ALL TWO-E CONTRIBUTION OF THE TC-HAMILTONIAN
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, l
|
||||
|
||||
do j = 1, mo_num
|
||||
do i = 1, mo_num
|
||||
do l = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
! < k l | V12 | i j > (k i|l j)
|
||||
mo_bi_ortho_tc_two_e(k,l,i,j) = mo_bi_ortho_tc_two_e_chemist(k,i,l,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_two_e_jj, (mo_num,mo_num) ]
|
||||
&BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_two_e_jj_exchange, (mo_num,mo_num) ]
|
||||
&BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_two_e_jj_anti, (mo_num,mo_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! mo_bi_ortho_tc_two_e_jj(i,j) = J_ij = <ji|W-K|ji>
|
||||
! mo_bi_ortho_tc_two_e_jj_exchange(i,j) = K_ij = <ij|W-K|ji>
|
||||
! mo_bi_ortho_tc_two_e_jj_anti(i,j) = J_ij - K_ij
|
||||
END_DOC
|
||||
|
||||
integer :: i,j
|
||||
double precision :: get_two_e_integral
|
||||
|
||||
mo_bi_ortho_tc_two_e_jj = 0.d0
|
||||
mo_bi_ortho_tc_two_e_jj_exchange = 0.d0
|
||||
|
||||
do i=1,mo_num
|
||||
do j=1,mo_num
|
||||
mo_bi_ortho_tc_two_e_jj(i,j) = mo_bi_ortho_tc_two_e(j,i,j,i)
|
||||
mo_bi_ortho_tc_two_e_jj_exchange(i,j) = mo_bi_ortho_tc_two_e(i,j,j,i)
|
||||
mo_bi_ortho_tc_two_e_jj_anti(i,j) = mo_bi_ortho_tc_two_e_jj(i,j) - mo_bi_ortho_tc_two_e_jj_exchange(i,j)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [double precision, tc_2e_3idx_coulomb_integrals, (mo_num,mo_num, mo_num)]
|
||||
&BEGIN_PROVIDER [double precision, tc_2e_3idx_exchange_integrals,(mo_num,mo_num, mo_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! tc_2e_3idx_coulomb_integrals(j,k,i) = <jk|ji>
|
||||
!
|
||||
! tc_2e_3idx_exchange_integrals(j,k,i) = <kj|ji>
|
||||
END_DOC
|
||||
integer :: i,j,k,l
|
||||
double precision :: get_two_e_integral
|
||||
double precision :: integral
|
||||
|
||||
do i = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
tc_2e_3idx_coulomb_integrals(j, k,i) = mo_bi_ortho_tc_two_e(j ,k ,j ,i )
|
||||
tc_2e_3idx_exchange_integrals(j,k,i) = mo_bi_ortho_tc_two_e(k ,j ,j ,i )
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
11
src/bi_ortho_mos/EZFIO.cfg
Normal file
11
src/bi_ortho_mos/EZFIO.cfg
Normal file
@ -0,0 +1,11 @@
|
||||
[mo_r_coef]
|
||||
type: double precision
|
||||
doc: right-coefficient of the i-th |AO| on the j-th |MO|
|
||||
interface: ezfio
|
||||
size: (ao_basis.ao_num,mo_basis.mo_num)
|
||||
|
||||
[mo_l_coef]
|
||||
type: double precision
|
||||
doc: right-coefficient of the i-th |AO| on the j-th |MO|
|
||||
interface: ezfio
|
||||
size: (ao_basis.ao_num,mo_basis.mo_num)
|
||||
3
src/bi_ortho_mos/NEED
Normal file
3
src/bi_ortho_mos/NEED
Normal file
@ -0,0 +1,3 @@
|
||||
mo_basis
|
||||
becke_numerical_grid
|
||||
dft_utils_in_r
|
||||
70
src/bi_ortho_mos/bi_density.irp.f
Normal file
70
src/bi_ortho_mos/bi_density.irp.f
Normal file
@ -0,0 +1,70 @@
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, TCSCF_bi_ort_dm_ao_alpha, (ao_num, ao_num) ]
|
||||
|
||||
BEGIN_DOC
|
||||
! TCSCF_bi_ort_dm_ao_alpha(i,j) = <Chi_0| a^dagger_i,alpha a_j,alpha |Phi_0> where i,j are AO basis.
|
||||
!
|
||||
! This is the equivalent of the alpha density of the HF Slater determinant, but with a couple of bi-orthonormal Slater determinant |Chi_0> and |Phi_0>
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
call dgemm( 'N', 'T', ao_num, ao_num, elec_alpha_num, 1.d0 &
|
||||
, mo_l_coef, size(mo_l_coef, 1), mo_r_coef, size(mo_r_coef, 1) &
|
||||
!, mo_r_coef, size(mo_r_coef, 1), mo_l_coef, size(mo_l_coef, 1) &
|
||||
, 0.d0, TCSCF_bi_ort_dm_ao_alpha, size(TCSCF_bi_ort_dm_ao_alpha, 1) )
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, TCSCF_bi_ort_dm_ao_beta, (ao_num, ao_num) ]
|
||||
|
||||
BEGIN_DOC
|
||||
! TCSCF_bi_ort_dm_ao_beta(i,j) = <Chi_0| a^dagger_i,beta a_j,beta |Phi_0> where i,j are AO basis.
|
||||
!
|
||||
! This is the equivalent of the beta density of the HF Slater determinant, but with a couple of bi-orthonormal Slater determinant |Chi_0> and |Phi_0>
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
call dgemm( 'N', 'T', ao_num, ao_num, elec_beta_num, 1.d0 &
|
||||
, mo_l_coef, size(mo_l_coef, 1), mo_r_coef, size(mo_r_coef, 1) &
|
||||
!, mo_r_coef, size(mo_r_coef, 1), mo_l_coef, size(mo_l_coef, 1) &
|
||||
, 0.d0, TCSCF_bi_ort_dm_ao_beta, size(TCSCF_bi_ort_dm_ao_beta, 1) )
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, TCSCF_bi_ort_dm_ao, (ao_num, ao_num) ]
|
||||
|
||||
BEGIN_DOC
|
||||
! TCSCF_bi_ort_dm_ao(i,j) = <Chi_0| a^dagger_i,beta+alpha a_j,beta+alpha |Phi_0> where i,j are AO basis.
|
||||
!
|
||||
! This is the equivalent of the total electronic density of the HF Slater determinant, but with a couple of bi-orthonormal Slater determinant |Chi_0> and |Phi_0>
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
ASSERT(size(TCSCF_bi_ort_dm_ao, 1) == size(TCSCF_bi_ort_dm_ao_alpha, 1))
|
||||
|
||||
if(elec_alpha_num==elec_beta_num) then
|
||||
TCSCF_bi_ort_dm_ao = TCSCF_bi_ort_dm_ao_alpha + TCSCF_bi_ort_dm_ao_alpha
|
||||
else
|
||||
ASSERT(size(TCSCF_bi_ort_dm_ao, 1) == size(TCSCF_bi_ort_dm_ao_beta, 1))
|
||||
TCSCF_bi_ort_dm_ao = TCSCF_bi_ort_dm_ao_alpha + TCSCF_bi_ort_dm_ao_beta
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
137
src/bi_ortho_mos/bi_ort_mos_in_r.irp.f
Normal file
137
src/bi_ortho_mos/bi_ort_mos_in_r.irp.f
Normal file
@ -0,0 +1,137 @@
|
||||
|
||||
! TODO: left & right MO without duplicate AO calculation
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER[double precision, mos_r_in_r_array, (mo_num, n_points_final_grid)]
|
||||
|
||||
BEGIN_DOC
|
||||
! mos_in_r_array(i,j) = value of the ith RIGHT mo on the jth grid point
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j
|
||||
double precision :: mos_array(mo_num), r(3)
|
||||
|
||||
!$OMP PARALLEL DO &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i, j, r, mos_array) &
|
||||
!$OMP SHARED (mos_r_in_r_array, n_points_final_grid, mo_num, final_grid_points)
|
||||
do i = 1, n_points_final_grid
|
||||
r(1) = final_grid_points(1,i)
|
||||
r(2) = final_grid_points(2,i)
|
||||
r(3) = final_grid_points(3,i)
|
||||
call give_all_mos_r_at_r(r, mos_array)
|
||||
do j = 1, mo_num
|
||||
mos_r_in_r_array(j,i) = mos_array(j)
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER[double precision, mos_r_in_r_array_transp, (n_points_final_grid, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
! mos_r_in_r_array_transp(i,j) = value of the jth mo on the ith grid point
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i,j
|
||||
|
||||
do i = 1, n_points_final_grid
|
||||
do j = 1, mo_num
|
||||
mos_r_in_r_array_transp(i,j) = mos_r_in_r_array(j,i)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
subroutine give_all_mos_r_at_r(r, mos_r_array)
|
||||
|
||||
BEGIN_DOC
|
||||
! mos_r_array(i) = ith RIGHT MO function evaluated at "r"
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
double precision, intent(in) :: r(3)
|
||||
double precision, intent(out) :: mos_r_array(mo_num)
|
||||
double precision :: aos_array(ao_num)
|
||||
|
||||
call give_all_aos_at_r(r, aos_array)
|
||||
call dgemv('N', mo_num, ao_num, 1.d0, mo_r_coef_transp, mo_num, aos_array, 1, 0.d0, mos_r_array, 1)
|
||||
|
||||
end subroutine give_all_mos_r_at_r
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER[double precision, mos_l_in_r_array, (mo_num, n_points_final_grid)]
|
||||
|
||||
BEGIN_DOC
|
||||
! mos_in_r_array(i,j) = value of the ith LEFT mo on the jth grid point
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j
|
||||
double precision :: mos_array(mo_num), r(3)
|
||||
|
||||
!$OMP PARALLEL DO &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,r,mos_array,j) &
|
||||
!$OMP SHARED(mos_l_in_r_array,n_points_final_grid,mo_num,final_grid_points)
|
||||
do i = 1, n_points_final_grid
|
||||
r(1) = final_grid_points(1,i)
|
||||
r(2) = final_grid_points(2,i)
|
||||
r(3) = final_grid_points(3,i)
|
||||
call give_all_mos_l_at_r(r, mos_array)
|
||||
do j = 1, mo_num
|
||||
mos_l_in_r_array(j,i) = mos_array(j)
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
subroutine give_all_mos_l_at_r(r, mos_l_array)
|
||||
|
||||
BEGIN_DOC
|
||||
! mos_l_array(i) = ith LEFT MO function evaluated at "r"
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
double precision, intent(in) :: r(3)
|
||||
double precision, intent(out) :: mos_l_array(mo_num)
|
||||
double precision :: aos_array(ao_num)
|
||||
|
||||
call give_all_aos_at_r(r, aos_array)
|
||||
call dgemv('N', mo_num, ao_num, 1.d0, mo_l_coef_transp, mo_num, aos_array, 1, 0.d0, mos_l_array, 1)
|
||||
|
||||
end subroutine give_all_mos_l_at_r
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER[double precision, mos_l_in_r_array_transp,(n_points_final_grid,mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
! mos_l_in_r_array_transp(i,j) = value of the jth mo on the ith grid point
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j
|
||||
|
||||
do i = 1, n_points_final_grid
|
||||
do j = 1, mo_num
|
||||
mos_l_in_r_array_transp(i,j) = mos_l_in_r_array(j,i)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
100
src/bi_ortho_mos/grad_bi_ort_mos_in_r.irp.f
Normal file
100
src/bi_ortho_mos/grad_bi_ort_mos_in_r.irp.f
Normal file
@ -0,0 +1,100 @@
|
||||
BEGIN_PROVIDER[double precision, mos_r_grad_in_r_array,(mo_num,n_points_final_grid,3)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! mos_r_grad_in_r_array(i,j,k) = value of the kth component of the gradient of ith RIGHT mo on the jth grid point
|
||||
!
|
||||
! k = 1 : x, k= 2, y, k 3, z
|
||||
END_DOC
|
||||
integer :: m
|
||||
mos_r_grad_in_r_array = 0.d0
|
||||
do m=1,3
|
||||
call dgemm('N','N',mo_num,n_points_final_grid,ao_num,1.d0,mo_r_coef_transp,mo_num,aos_grad_in_r_array(1,1,m),ao_num,0.d0,mos_r_grad_in_r_array(1,1,m),mo_num)
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER[double precision, mos_r_grad_in_r_array_transp,(3,mo_num,n_points_final_grid)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! mos_r_grad_in_r_array_transp(i,j,k) = value of the kth component of the gradient of jth RIGHT mo on the ith grid point
|
||||
!
|
||||
! k = 1 : x, k= 2, y, k 3, z
|
||||
END_DOC
|
||||
integer :: m
|
||||
integer :: i,j
|
||||
mos_r_grad_in_r_array_transp = 0.d0
|
||||
do i = 1, n_points_final_grid
|
||||
do j = 1, mo_num
|
||||
do m = 1, 3
|
||||
mos_r_grad_in_r_array_transp(m,j,i) = mos_r_grad_in_r_array(j,i,m)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER[double precision, mos_r_grad_in_r_array_transp_bis,(3,n_points_final_grid,mo_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! mos_r_grad_in_r_array_transp(i,j,k) = value of the ith component of the gradient on the jth grid point of jth RIGHT MO
|
||||
END_DOC
|
||||
integer :: m
|
||||
integer :: i,j
|
||||
mos_r_grad_in_r_array_transp_bis = 0.d0
|
||||
do j = 1, mo_num
|
||||
do i = 1, n_points_final_grid
|
||||
do m = 1, 3
|
||||
mos_r_grad_in_r_array_transp_bis(m,i,j) = mos_r_grad_in_r_array(j,i,m)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER[double precision, mos_l_grad_in_r_array,(mo_num,n_points_final_grid,3)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! mos_l_grad_in_r_array(i,j,k) = value of the kth component of the gradient of ith RIGHT mo on the jth grid point
|
||||
!
|
||||
! k = 1 : x, k= 2, y, k 3, z
|
||||
END_DOC
|
||||
integer :: m
|
||||
mos_l_grad_in_r_array = 0.d0
|
||||
do m=1,3
|
||||
call dgemm('N','N',mo_num,n_points_final_grid,ao_num,1.d0,mo_r_coef_transp,mo_num,aos_grad_in_r_array(1,1,m),ao_num,0.d0,mos_l_grad_in_r_array(1,1,m),mo_num)
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER[double precision, mos_l_grad_in_r_array_transp,(3,mo_num,n_points_final_grid)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! mos_l_grad_in_r_array_transp(i,j,k) = value of the kth component of the gradient of jth RIGHT mo on the ith grid point
|
||||
!
|
||||
! k = 1 : x, k= 2, y, k 3, z
|
||||
END_DOC
|
||||
integer :: m
|
||||
integer :: i,j
|
||||
mos_l_grad_in_r_array_transp = 0.d0
|
||||
do i = 1, n_points_final_grid
|
||||
do j = 1, mo_num
|
||||
do m = 1, 3
|
||||
mos_l_grad_in_r_array_transp(m,j,i) = mos_l_grad_in_r_array(j,i,m)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER[double precision, mos_l_grad_in_r_array_transp_bis,(3,n_points_final_grid,mo_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! mos_l_grad_in_r_array_transp(i,j,k) = value of the ith component of the gradient on the jth grid point of jth RIGHT MO
|
||||
END_DOC
|
||||
integer :: m
|
||||
integer :: i,j
|
||||
mos_l_grad_in_r_array_transp_bis = 0.d0
|
||||
do j = 1, mo_num
|
||||
do i = 1, n_points_final_grid
|
||||
do m = 1, 3
|
||||
mos_l_grad_in_r_array_transp_bis(m,i,j) = mos_l_grad_in_r_array(j,i,m)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
224
src/bi_ortho_mos/mos_rl.irp.f
Normal file
224
src/bi_ortho_mos/mos_rl.irp.f
Normal file
@ -0,0 +1,224 @@
|
||||
|
||||
! ---
|
||||
|
||||
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
|
||||
|
||||
! T = A_ao x mo_r_coef
|
||||
call dgemm( 'N', 'N', ao_num, mo_num, ao_num, 1.d0 &
|
||||
, A_ao, LDA_ao, mo_r_coef, size(mo_r_coef, 1) &
|
||||
, 0.d0, T, size(T, 1) )
|
||||
|
||||
! A_mo = mo_l_coef.T x T
|
||||
call dgemm( 'T', 'N', mo_num, mo_num, ao_num, 1.d0 &
|
||||
, mo_l_coef, size(mo_l_coef, 1), T, size(T, 1) &
|
||||
, 0.d0, A_mo, LDA_mo )
|
||||
|
||||
! call restore_symmetry(mo_num,mo_num,A_mo,size(A_mo,1),1.d-12)
|
||||
deallocate(T)
|
||||
|
||||
end subroutine ao_to_mo_bi_ortho
|
||||
|
||||
! ---
|
||||
|
||||
subroutine mo_to_ao_bi_ortho(A_mo, LDA_mo, A_ao, LDA_ao)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! mo_l_coef.T x A_ao x mo_r_coef = A_mo
|
||||
! mo_l_coef.T x ao_overlap x mo_r_coef = I
|
||||
!
|
||||
! ==> A_ao = (ao_overlap x mo_r_coef) x A_mo x (ao_overlap x mo_l_coef).T
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: LDA_ao, LDA_mo
|
||||
double precision, intent(in) :: A_mo(LDA_mo,mo_num)
|
||||
double precision, intent(out) :: A_ao(LDA_ao,ao_num)
|
||||
double precision, allocatable :: tmp_1(:,:), tmp_2(:,:)
|
||||
|
||||
! ao_overlap x mo_r_coef
|
||||
allocate( tmp_1(ao_num,mo_num) )
|
||||
call dgemm( 'N', 'N', ao_num, mo_num, ao_num, 1.d0 &
|
||||
, ao_overlap, size(ao_overlap, 1), mo_r_coef, size(mo_r_coef, 1) &
|
||||
, 0.d0, tmp_1, size(tmp_1, 1) )
|
||||
|
||||
! (ao_overlap x mo_r_coef) x A_mo
|
||||
allocate( tmp_2(ao_num,mo_num) )
|
||||
call dgemm( 'N', 'N', ao_num, mo_num, mo_num, 1.d0 &
|
||||
, tmp_1, size(tmp_1, 1), A_mo, LDA_mo &
|
||||
, 0.d0, tmp_2, size(tmp_2, 1) )
|
||||
|
||||
! ao_overlap x mo_l_coef
|
||||
tmp_1 = 0.d0
|
||||
call dgemm( 'N', 'N', ao_num, mo_num, ao_num, 1.d0 &
|
||||
, ao_overlap, size(ao_overlap, 1), mo_l_coef, size(mo_l_coef, 1) &
|
||||
, 0.d0, tmp_1, size(tmp_1, 1) )
|
||||
|
||||
! (ao_overlap x mo_r_coef) x A_mo x (ao_overlap x mo_l_coef).T
|
||||
call dgemm( 'N', 'T', ao_num, ao_num, mo_num, 1.d0 &
|
||||
, tmp_2, size(tmp_2, 1), tmp_1, size(tmp_1, 1) &
|
||||
, 0.d0, A_ao, LDA_ao )
|
||||
|
||||
deallocate(tmp_1, tmp_2)
|
||||
|
||||
end subroutine mo_to_ao_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_l_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
|
||||
|
||||
! ---
|
||||
|
||||
|
||||
160
src/bi_ortho_mos/overlap.irp.f
Normal file
160
src/bi_ortho_mos/overlap.irp.f
Normal file
@ -0,0 +1,160 @@
|
||||
|
||||
|
||||
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 ', dabs(accu_d-1.d0)
|
||||
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)]
|
||||
|
||||
BEGIN_DOC
|
||||
! overlap_mo_r_mo(j,i) = <MO_i|MO_R_j>
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
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)]
|
||||
|
||||
BEGIN_DOC
|
||||
! overlap_mo_r_mo(j,i) = <MO_j|MO_R_i>
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
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
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, angle_left_right, (mo_num)]
|
||||
&BEGIN_PROVIDER [ double precision, max_angle_left_right]
|
||||
|
||||
BEGIN_DOC
|
||||
! angle_left_right(i) = angle between the left-eigenvector chi_i and the right-eigenvector phi_i
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j
|
||||
double precision :: left, right, arg
|
||||
double precision :: angle(mo_num)
|
||||
|
||||
do i = 1, mo_num
|
||||
left = overlap_mo_l(i,i)
|
||||
right = overlap_mo_r(i,i)
|
||||
arg = min(overlap_bi_ortho(i,i)/(left*right),1.d0)
|
||||
arg = max(arg, -1.d0)
|
||||
angle_left_right(i) = dacos(arg) * 180.d0/dacos(-1.d0)
|
||||
enddo
|
||||
|
||||
angle(1:mo_num) = dabs(angle_left_right(1:mo_num))
|
||||
max_angle_left_right = maxval(angle)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
|
||||
@ -169,4 +169,43 @@
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER[double precision, aos_in_r_array_extra, (ao_num,n_points_extra_final_grid)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! aos_in_r_array_extra(i,j) = value of the ith ao on the jth grid point
|
||||
END_DOC
|
||||
integer :: i,j
|
||||
double precision :: aos_array(ao_num), r(3)
|
||||
!$OMP PARALLEL DO &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,r,aos_array,j) &
|
||||
!$OMP SHARED(aos_in_r_array_extra,n_points_extra_final_grid,ao_num,final_grid_points_extra)
|
||||
do i = 1, n_points_extra_final_grid
|
||||
r(1) = final_grid_points_extra(1,i)
|
||||
r(2) = final_grid_points_extra(2,i)
|
||||
r(3) = final_grid_points_extra(3,i)
|
||||
call give_all_aos_at_r(r,aos_array)
|
||||
do j = 1, ao_num
|
||||
aos_in_r_array_extra(j,i) = aos_array(j)
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER[double precision, aos_in_r_array_extra_transp, (n_points_extra_final_grid,ao_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! aos_in_r_array_extra_transp(i,j) = value of the jth ao on the ith grid point
|
||||
END_DOC
|
||||
integer :: i,j
|
||||
double precision :: aos_array(ao_num), r(3)
|
||||
do i = 1, n_points_extra_final_grid
|
||||
do j = 1, ao_num
|
||||
aos_in_r_array_extra_transp(i,j) = aos_in_r_array_extra(j,i)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
155
src/dft_utils_in_r/ao_prod_mlti_pl.irp.f
Normal file
155
src/dft_utils_in_r/ao_prod_mlti_pl.irp.f
Normal file
@ -0,0 +1,155 @@
|
||||
|
||||
BEGIN_PROVIDER [ double precision, ao_abs_int_grid, (ao_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! ao_abs_int_grid(i) = \int dr |phi_i(r) |
|
||||
END_DOC
|
||||
integer :: i,j,ipoint
|
||||
double precision :: contrib, weight,r(3)
|
||||
ao_abs_int_grid = 0.D0
|
||||
do ipoint = 1,n_points_final_grid
|
||||
r(:) = final_grid_points(:,ipoint)
|
||||
weight = final_weight_at_r_vector(ipoint)
|
||||
do i = 1, ao_num
|
||||
contrib = dabs(aos_in_r_array(i,ipoint)) * weight
|
||||
ao_abs_int_grid(i) += contrib
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, ao_overlap_abs_grid, (ao_num, ao_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! ao_overlap_abs_grid(j,i) = \int dr |phi_i(r) phi_j(r)|
|
||||
END_DOC
|
||||
integer :: i,j,ipoint
|
||||
double precision :: contrib, weight,r(3)
|
||||
ao_overlap_abs_grid = 0.D0
|
||||
do ipoint = 1,n_points_final_grid
|
||||
r(:) = final_grid_points(:,ipoint)
|
||||
weight = final_weight_at_r_vector(ipoint)
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
contrib = dabs(aos_in_r_array(j,ipoint) * aos_in_r_array(i,ipoint)) * weight
|
||||
ao_overlap_abs_grid(j,i) += contrib
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, ao_prod_center, (3, ao_num, ao_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! ao_prod_center(1:3,j,i) = \int dr |phi_i(r) phi_j(r)| x/y/z / \int |phi_i(r) phi_j(r)|
|
||||
!
|
||||
! if \int |phi_i(r) phi_j(r)| < 1.d-10 then ao_prod_center = 10000.
|
||||
END_DOC
|
||||
integer :: i,j,m,ipoint
|
||||
double precision :: contrib, weight,r(3)
|
||||
ao_prod_center = 0.D0
|
||||
do ipoint = 1,n_points_final_grid
|
||||
r(:) = final_grid_points(:,ipoint)
|
||||
weight = final_weight_at_r_vector(ipoint)
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
contrib = dabs(aos_in_r_array(j,ipoint) * aos_in_r_array(i,ipoint)) * weight
|
||||
do m = 1, 3
|
||||
ao_prod_center(m,j,i) += contrib * r(m)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
if(dabs(ao_overlap_abs_grid(j,i)).gt.1.d-10)then
|
||||
do m = 1, 3
|
||||
ao_prod_center(m,j,i) *= 1.d0/ao_overlap_abs_grid(j,i)
|
||||
enddo
|
||||
else
|
||||
do m = 1, 3
|
||||
ao_prod_center(m,j,i) = 10000.d0
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, ao_prod_abs_r, (ao_num, ao_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! ao_prod_abs_r(i,j) = \int |phi_i(r) phi_j(r)| dsqrt((x - <|i|x|j|>)^2 + (y - <|i|y|j|>)^2 +(z - <|i|z|j|>)^2) / \int |phi_i(r) phi_j(r)|
|
||||
!
|
||||
END_DOC
|
||||
ao_prod_abs_r = 0.d0
|
||||
integer :: i,j,m,ipoint
|
||||
double precision :: contrib, weight,r(3),contrib_x2
|
||||
do ipoint = 1,n_points_final_grid
|
||||
r(:) = final_grid_points(:,ipoint)
|
||||
weight = final_weight_at_r_vector(ipoint)
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
contrib = dabs(aos_in_r_array(j,ipoint) * aos_in_r_array(i,ipoint)) * weight
|
||||
contrib_x2 = 0.d0
|
||||
do m = 1, 3
|
||||
contrib_x2 += (r(m) - ao_prod_center(m,j,i)) * (r(m) - ao_prod_center(m,j,i))
|
||||
enddo
|
||||
contrib_x2 = dsqrt(contrib_x2)
|
||||
ao_prod_abs_r(j,i) += contrib * contrib_x2
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [double precision, ao_prod_sigma, (ao_num, ao_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Gaussian exponent reproducing the product |chi_i(r) chi_j(r)|
|
||||
!
|
||||
! Therefore |chi_i(r) chi_j(r)| \approx e^{-ao_prod_sigma(j,i) (r - ao_prod_center(1:3,j,i))**2}
|
||||
END_DOC
|
||||
integer :: i,j
|
||||
double precision :: pi,alpha
|
||||
pi = dacos(-1.d0)
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
! if(dabs(ao_overlap_abs_grid(j,i)).gt.1.d-5)then
|
||||
alpha = 1.d0/pi * (2.d0*ao_overlap_abs_grid(j,i)/ao_prod_abs_r(j,i))**2
|
||||
ao_prod_sigma(j,i) = alpha
|
||||
! endif
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, ao_prod_dist_grid, (ao_num, ao_num, n_points_final_grid)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! ao_prod_dist_grid(j,i,ipoint) = distance between the center of |phi_i(r) phi_j(r)| and the grid point r(ipoint)
|
||||
END_DOC
|
||||
integer :: i,j,m,ipoint
|
||||
double precision :: distance,r(3)
|
||||
do ipoint = 1, n_points_final_grid
|
||||
r(:) = final_grid_points(:,ipoint)
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
distance = 0.d0
|
||||
do m = 1, 3
|
||||
distance += (ao_prod_center(m,j,i) - r(m))*(ao_prod_center(m,j,i) - r(m))
|
||||
enddo
|
||||
distance = dsqrt(distance)
|
||||
ao_prod_dist_grid(j,i,ipoint) = distance
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
!BEGIN_PROVIDER [ double precision, ao_abs_prod_j1b, (ao_num, ao_num)]
|
||||
! implicit none
|
||||
!
|
||||
!END_PROVIDER
|
||||
2
src/non_h_ints_mu/NEED
Normal file
2
src/non_h_ints_mu/NEED
Normal file
@ -0,0 +1,2 @@
|
||||
ao_tc_eff_map
|
||||
bi_ortho_mos
|
||||
11
src/non_h_ints_mu/README.rst
Normal file
11
src/non_h_ints_mu/README.rst
Normal file
@ -0,0 +1,11 @@
|
||||
=============
|
||||
non_h_ints_mu
|
||||
=============
|
||||
|
||||
Computes the non hermitian potential of the mu-TC Hamiltonian on the AO and BI-ORTHO MO basis.
|
||||
The operator is defined in Eq. 33 of JCP 154, 084119 (2021)
|
||||
|
||||
The two providers are :
|
||||
+) ao_non_hermit_term_chemist which returns the non hermitian part of the two-electron TC Hamiltonian on the MO basis.
|
||||
+) mo_non_hermit_term_chemist which returns the non hermitian part of the two-electron TC Hamiltonian on the BI-ORTHO MO basis.
|
||||
|
||||
512
src/non_h_ints_mu/debug_fit.irp.f
Normal file
512
src/non_h_ints_mu/debug_fit.irp.f
Normal file
@ -0,0 +1,512 @@
|
||||
|
||||
! --
|
||||
|
||||
program debug_fit
|
||||
|
||||
implicit none
|
||||
|
||||
my_grid_becke = .True.
|
||||
|
||||
my_n_pt_r_grid = 30
|
||||
my_n_pt_a_grid = 50
|
||||
!my_n_pt_r_grid = 100
|
||||
!my_n_pt_a_grid = 170
|
||||
!my_n_pt_r_grid = 150
|
||||
!my_n_pt_a_grid = 194
|
||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||
|
||||
PROVIDE mu_erf j1b_pen
|
||||
|
||||
!call test_j1b_nucl()
|
||||
call test_grad_j1b_nucl()
|
||||
!call test_lapl_j1b_nucl()
|
||||
|
||||
!call test_list_b2()
|
||||
!call test_list_b3()
|
||||
|
||||
call test_fit_u()
|
||||
!call test_fit_u2()
|
||||
!call test_fit_ugradu()
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine test_j1b_nucl()
|
||||
|
||||
implicit none
|
||||
integer :: ipoint
|
||||
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
|
||||
double precision :: r(3)
|
||||
double precision, external :: j1b_nucl
|
||||
|
||||
print*, ' test_j1b_nucl ...'
|
||||
|
||||
PROVIDE v_1b
|
||||
|
||||
eps_ij = 1d-7
|
||||
acc_tot = 0.d0
|
||||
normalz = 0.d0
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
r(1) = final_grid_points(1,ipoint)
|
||||
r(2) = final_grid_points(2,ipoint)
|
||||
r(3) = final_grid_points(3,ipoint)
|
||||
|
||||
i_exc = v_1b(ipoint)
|
||||
i_num = j1b_nucl(r)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem in v_1b on', ipoint
|
||||
print *, ' analyt = ', i_exc
|
||||
print *, ' numeri = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
endif
|
||||
|
||||
acc_tot += acc_ij
|
||||
normalz += dabs(i_num)
|
||||
enddo
|
||||
|
||||
print*, ' acc_tot = ', acc_tot
|
||||
print*, ' normalz = ', normalz
|
||||
|
||||
return
|
||||
end subroutine test_j1b_nucl
|
||||
|
||||
! ---
|
||||
|
||||
subroutine test_grad_j1b_nucl()
|
||||
|
||||
implicit none
|
||||
integer :: ipoint
|
||||
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
|
||||
double precision :: r(3)
|
||||
double precision, external :: grad_x_j1b_nucl
|
||||
double precision, external :: grad_y_j1b_nucl
|
||||
double precision, external :: grad_z_j1b_nucl
|
||||
|
||||
print*, ' test_grad_j1b_nucl ...'
|
||||
|
||||
PROVIDE v_1b_grad
|
||||
|
||||
eps_ij = 1d-7
|
||||
acc_tot = 0.d0
|
||||
normalz = 0.d0
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
r(1) = final_grid_points(1,ipoint)
|
||||
r(2) = final_grid_points(2,ipoint)
|
||||
r(3) = final_grid_points(3,ipoint)
|
||||
|
||||
i_exc = v_1b_grad(1,ipoint)
|
||||
i_num = grad_x_j1b_nucl(r)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem in x of v_1b_grad on', ipoint
|
||||
print *, ' analyt = ', i_exc
|
||||
print *, ' numeri = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
endif
|
||||
|
||||
i_exc = v_1b_grad(2,ipoint)
|
||||
i_num = grad_y_j1b_nucl(r)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem in y of v_1b_grad on', ipoint
|
||||
print *, ' analyt = ', i_exc
|
||||
print *, ' numeri = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
endif
|
||||
|
||||
i_exc = v_1b_grad(3,ipoint)
|
||||
i_num = grad_z_j1b_nucl(r)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem in z of v_1b_grad on', ipoint
|
||||
print *, ' analyt = ', i_exc
|
||||
print *, ' numeri = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
endif
|
||||
|
||||
acc_tot += acc_ij
|
||||
normalz += dabs(i_num)
|
||||
enddo
|
||||
|
||||
print*, ' acc_tot = ', acc_tot
|
||||
print*, ' normalz = ', normalz
|
||||
|
||||
return
|
||||
end subroutine test_grad_j1b_nucl
|
||||
|
||||
! ---
|
||||
|
||||
subroutine test_lapl_j1b_nucl()
|
||||
|
||||
implicit none
|
||||
integer :: ipoint
|
||||
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
|
||||
double precision :: r(3)
|
||||
double precision, external :: lapl_j1b_nucl
|
||||
|
||||
print*, ' test_lapl_j1b_nucl ...'
|
||||
|
||||
PROVIDE v_1b_lapl
|
||||
|
||||
eps_ij = 1d-5
|
||||
acc_tot = 0.d0
|
||||
normalz = 0.d0
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
r(1) = final_grid_points(1,ipoint)
|
||||
r(2) = final_grid_points(2,ipoint)
|
||||
r(3) = final_grid_points(3,ipoint)
|
||||
|
||||
i_exc = v_1b_lapl(ipoint)
|
||||
i_num = lapl_j1b_nucl(r)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem in v_1b_lapl on', ipoint
|
||||
print *, ' analyt = ', i_exc
|
||||
print *, ' numeri = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
endif
|
||||
|
||||
acc_tot += acc_ij
|
||||
normalz += dabs(i_num)
|
||||
enddo
|
||||
|
||||
print*, ' acc_tot = ', acc_tot
|
||||
print*, ' normalz = ', normalz
|
||||
|
||||
return
|
||||
end subroutine test_lapl_j1b_nucl
|
||||
|
||||
! ---
|
||||
|
||||
subroutine test_list_b2()
|
||||
|
||||
implicit none
|
||||
integer :: ipoint
|
||||
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
|
||||
double precision :: r(3)
|
||||
double precision, external :: j1b_nucl
|
||||
|
||||
print*, ' test_list_b2 ...'
|
||||
|
||||
PROVIDE v_1b_list_b2
|
||||
|
||||
eps_ij = 1d-7
|
||||
acc_tot = 0.d0
|
||||
normalz = 0.d0
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
r(1) = final_grid_points(1,ipoint)
|
||||
r(2) = final_grid_points(2,ipoint)
|
||||
r(3) = final_grid_points(3,ipoint)
|
||||
|
||||
i_exc = v_1b_list_b2(ipoint)
|
||||
i_num = j1b_nucl(r)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem in list_b2 on', ipoint
|
||||
print *, ' analyt = ', i_exc
|
||||
print *, ' numeri = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
endif
|
||||
|
||||
acc_tot += acc_ij
|
||||
normalz += dabs(i_num)
|
||||
enddo
|
||||
|
||||
print*, ' acc_tot = ', acc_tot
|
||||
print*, ' normalz = ', normalz
|
||||
|
||||
return
|
||||
end subroutine test_list_b2
|
||||
|
||||
! ---
|
||||
|
||||
subroutine test_list_b3()
|
||||
|
||||
implicit none
|
||||
integer :: ipoint
|
||||
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_tmp, i_num, normalz
|
||||
double precision :: r(3)
|
||||
double precision, external :: j1b_nucl
|
||||
|
||||
print*, ' test_list_b3 ...'
|
||||
|
||||
PROVIDE v_1b_list_b3
|
||||
|
||||
eps_ij = 1d-7
|
||||
acc_tot = 0.d0
|
||||
normalz = 0.d0
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
r(1) = final_grid_points(1,ipoint)
|
||||
r(2) = final_grid_points(2,ipoint)
|
||||
r(3) = final_grid_points(3,ipoint)
|
||||
|
||||
i_exc = v_1b_list_b3(ipoint)
|
||||
i_tmp = j1b_nucl(r)
|
||||
i_num = i_tmp * i_tmp
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem in list_b3 on', ipoint
|
||||
print *, ' analyt = ', i_exc
|
||||
print *, ' numeri = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
endif
|
||||
|
||||
acc_tot += acc_ij
|
||||
normalz += dabs(i_num)
|
||||
enddo
|
||||
|
||||
print*, ' acc_tot = ', acc_tot
|
||||
print*, ' normalz = ', normalz
|
||||
|
||||
return
|
||||
end subroutine test_list_b3
|
||||
|
||||
! ---
|
||||
|
||||
subroutine test_fit_ugradu()
|
||||
|
||||
implicit none
|
||||
|
||||
integer :: jpoint, ipoint, i
|
||||
double precision :: i_exc, i_fit, i_num, x2, tmp, dx, dy, dz
|
||||
double precision :: r1(3), r2(3), grad(3)
|
||||
double precision :: eps_ij, acc_tot, acc_ij, normalz, coef, expo
|
||||
|
||||
double precision, external :: j12_mu
|
||||
|
||||
print*, ' test_fit_ugradu ...'
|
||||
|
||||
eps_ij = 1d-3
|
||||
|
||||
do jpoint = 1, n_points_final_grid
|
||||
r2(1) = final_grid_points(1,jpoint)
|
||||
r2(2) = final_grid_points(2,jpoint)
|
||||
r2(3) = final_grid_points(3,jpoint)
|
||||
|
||||
acc_tot = 0.d0
|
||||
normalz = 0.d0
|
||||
do ipoint = 1, n_points_final_grid
|
||||
r1(1) = final_grid_points(1,ipoint)
|
||||
r1(2) = final_grid_points(2,ipoint)
|
||||
r1(3) = final_grid_points(3,ipoint)
|
||||
|
||||
dx = r1(1) - r2(1)
|
||||
dy = r1(2) - r2(2)
|
||||
dz = r1(3) - r2(3)
|
||||
x2 = dx * dx + dy * dy + dz * dz
|
||||
if(x2 .lt. 1d-10) cycle
|
||||
|
||||
i_fit = 0.d0
|
||||
do i = 1, n_max_fit_slat
|
||||
expo = expo_gauss_j_mu_1_erf(i)
|
||||
coef = coef_gauss_j_mu_1_erf(i)
|
||||
i_fit += coef * dexp(-expo*x2)
|
||||
enddo
|
||||
i_fit = i_fit / dsqrt(x2)
|
||||
|
||||
tmp = j12_mu(r1, r2)
|
||||
call grad1_j12_mu_exc(r1, r2, grad)
|
||||
|
||||
! ---
|
||||
|
||||
i_exc = tmp * grad(1)
|
||||
i_num = i_fit * dx
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem on x in test_fit_ugradu on', ipoint
|
||||
print *, ' analyt = ', i_exc
|
||||
print *, ' numeri = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
endif
|
||||
acc_tot += acc_ij
|
||||
normalz += dabs(i_exc)
|
||||
|
||||
! ---
|
||||
|
||||
i_exc = tmp * grad(2)
|
||||
i_num = i_fit * dy
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem on y in test_fit_ugradu on', ipoint
|
||||
print *, ' analyt = ', i_exc
|
||||
print *, ' numeri = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
endif
|
||||
acc_tot += acc_ij
|
||||
normalz += dabs(i_exc)
|
||||
|
||||
! ---
|
||||
|
||||
i_exc = tmp * grad(3)
|
||||
i_num = i_fit * dz
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem on z in test_fit_ugradu on', ipoint
|
||||
print *, ' analyt = ', i_exc
|
||||
print *, ' numeri = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
endif
|
||||
acc_tot += acc_ij
|
||||
normalz += dabs(i_exc)
|
||||
|
||||
! ---
|
||||
|
||||
enddo
|
||||
|
||||
if( (acc_tot/normalz) .gt. 1d-3 ) then
|
||||
print*, ' acc_tot = ', acc_tot
|
||||
print*, ' normalz = ', normalz
|
||||
endif
|
||||
enddo
|
||||
|
||||
return
|
||||
end subroutine test_fit_ugradu
|
||||
|
||||
! ---
|
||||
|
||||
subroutine test_fit_u()
|
||||
|
||||
implicit none
|
||||
|
||||
integer :: jpoint, ipoint, i
|
||||
double precision :: i_exc, i_fit, i_num, x2
|
||||
double precision :: r1(3), r2(3), dx, dy, dz
|
||||
double precision :: eps_ij, acc_tot, acc_ij, normalz, coef, expo
|
||||
|
||||
double precision, external :: j12_mu
|
||||
|
||||
print*, ' test_fit_u ...'
|
||||
|
||||
eps_ij = 1d-3
|
||||
|
||||
do jpoint = 1, n_points_final_grid
|
||||
r2(1) = final_grid_points(1,jpoint)
|
||||
r2(2) = final_grid_points(2,jpoint)
|
||||
r2(3) = final_grid_points(3,jpoint)
|
||||
|
||||
acc_tot = 0.d0
|
||||
normalz = 0.d0
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
r1(1) = final_grid_points(1,ipoint)
|
||||
r1(2) = final_grid_points(2,ipoint)
|
||||
r1(3) = final_grid_points(3,ipoint)
|
||||
|
||||
dx = r1(1) - r2(1)
|
||||
dy = r1(2) - r2(2)
|
||||
dz = r1(3) - r2(3)
|
||||
x2 = dx * dx + dy * dy + dz * dz
|
||||
if(x2 .lt. 1d-10) cycle
|
||||
|
||||
i_fit = 0.d0
|
||||
do i = 1, n_max_fit_slat
|
||||
expo = expo_gauss_j_mu_x(i)
|
||||
coef = coef_gauss_j_mu_x(i)
|
||||
i_fit += coef * dexp(-expo*x2)
|
||||
enddo
|
||||
|
||||
i_exc = j12_mu(r1, r2)
|
||||
i_num = i_fit
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem in test_fit_u on', ipoint
|
||||
print *, ' analyt = ', i_exc
|
||||
print *, ' numeri = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
endif
|
||||
|
||||
acc_tot += acc_ij
|
||||
normalz += dabs(i_exc)
|
||||
enddo
|
||||
|
||||
if( (acc_tot/normalz) .gt. 1d-3 ) then
|
||||
print*, ' acc_tot = ', acc_tot
|
||||
print*, ' normalz = ', normalz
|
||||
endif
|
||||
enddo
|
||||
|
||||
return
|
||||
end subroutine test_fit_u
|
||||
|
||||
! ---
|
||||
|
||||
subroutine test_fit_u2()
|
||||
|
||||
implicit none
|
||||
|
||||
integer :: jpoint, ipoint, i
|
||||
double precision :: i_exc, i_fit, i_num, x2
|
||||
double precision :: r1(3), r2(3), dx, dy, dz, tmp
|
||||
double precision :: eps_ij, acc_tot, acc_ij, normalz, coef, expo
|
||||
|
||||
double precision, external :: j12_mu
|
||||
|
||||
print*, ' test_fit_u2 ...'
|
||||
|
||||
eps_ij = 1d-3
|
||||
|
||||
do jpoint = 1, n_points_final_grid
|
||||
r2(1) = final_grid_points(1,jpoint)
|
||||
r2(2) = final_grid_points(2,jpoint)
|
||||
r2(3) = final_grid_points(3,jpoint)
|
||||
|
||||
acc_tot = 0.d0
|
||||
normalz = 0.d0
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
r1(1) = final_grid_points(1,ipoint)
|
||||
r1(2) = final_grid_points(2,ipoint)
|
||||
r1(3) = final_grid_points(3,ipoint)
|
||||
|
||||
dx = r1(1) - r2(1)
|
||||
dy = r1(2) - r2(2)
|
||||
dz = r1(3) - r2(3)
|
||||
x2 = dx * dx + dy * dy + dz * dz
|
||||
if(x2 .lt. 1d-10) cycle
|
||||
|
||||
i_fit = 0.d0
|
||||
do i = 1, n_max_fit_slat
|
||||
expo = expo_gauss_j_mu_x_2(i)
|
||||
coef = coef_gauss_j_mu_x_2(i)
|
||||
i_fit += coef * dexp(-expo*x2)
|
||||
enddo
|
||||
|
||||
tmp = j12_mu(r1, r2)
|
||||
i_exc = tmp * tmp
|
||||
i_num = i_fit
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem in test_fit_u2 on', ipoint
|
||||
print *, ' analyt = ', i_exc
|
||||
print *, ' numeri = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
endif
|
||||
|
||||
acc_tot += acc_ij
|
||||
normalz += dabs(i_exc)
|
||||
enddo
|
||||
|
||||
if( (acc_tot/normalz) .gt. 1d-3 ) then
|
||||
print*, ' acc_tot = ', acc_tot
|
||||
print*, ' normalz = ', normalz
|
||||
endif
|
||||
enddo
|
||||
|
||||
return
|
||||
end subroutine test_fit_u2
|
||||
|
||||
! ---
|
||||
|
||||
|
||||
780
src/non_h_ints_mu/debug_integ_jmu_modif.irp.f
Normal file
780
src/non_h_ints_mu/debug_integ_jmu_modif.irp.f
Normal file
@ -0,0 +1,780 @@
|
||||
|
||||
! --
|
||||
|
||||
program debug_integ_jmu_modif
|
||||
|
||||
implicit none
|
||||
|
||||
my_grid_becke = .True.
|
||||
|
||||
!my_n_pt_r_grid = 30
|
||||
!my_n_pt_a_grid = 50
|
||||
!my_n_pt_r_grid = 100
|
||||
!my_n_pt_a_grid = 170
|
||||
my_n_pt_r_grid = 150
|
||||
my_n_pt_a_grid = 194
|
||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||
|
||||
PROVIDE mu_erf j1b_pen
|
||||
|
||||
! call test_v_ij_u_cst_mu_j1b()
|
||||
! call test_v_ij_erf_rk_cst_mu_j1b()
|
||||
! call test_x_v_ij_erf_rk_cst_mu_j1b()
|
||||
! call test_int2_u2_j1b2()
|
||||
! call test_int2_grad1u2_grad2u2_j1b2()
|
||||
! call test_int2_u_grad1u_total_j1b2()
|
||||
!
|
||||
! call test_int2_grad1_u12_ao()
|
||||
!
|
||||
! call test_grad12_j12()
|
||||
! call test_u12sq_j1bsq()
|
||||
! call test_u12_grad1_u12_j1b_grad1_j1b()
|
||||
! !call test_gradu_squared_u_ij_mu()
|
||||
|
||||
!call test_vect_overlap_gauss_r12_ao()
|
||||
call test_vect_overlap_gauss_r12_ao_with1s()
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine test_v_ij_u_cst_mu_j1b()
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint
|
||||
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
|
||||
double precision, external :: num_v_ij_u_cst_mu_j1b
|
||||
|
||||
print*, ' test_v_ij_u_cst_mu_j1b ...'
|
||||
|
||||
PROVIDE v_ij_u_cst_mu_j1b
|
||||
|
||||
eps_ij = 1d-3
|
||||
acc_tot = 0.d0
|
||||
normalz = 0.d0
|
||||
|
||||
!do ipoint = 1, 10
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
|
||||
i_exc = v_ij_u_cst_mu_j1b(i,j,ipoint)
|
||||
i_num = num_v_ij_u_cst_mu_j1b(i,j,ipoint)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem in v_ij_u_cst_mu_j1b on', i, j, ipoint
|
||||
print *, ' analyt integ = ', i_exc
|
||||
print *, ' numeri integ = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
endif
|
||||
|
||||
acc_tot += acc_ij
|
||||
normalz += dabs(i_num)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
print*, ' acc_tot = ', acc_tot
|
||||
print*, ' normalz = ', normalz
|
||||
|
||||
return
|
||||
end subroutine test_v_ij_u_cst_mu_j1b
|
||||
|
||||
! ---
|
||||
|
||||
subroutine test_v_ij_erf_rk_cst_mu_j1b()
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint
|
||||
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
|
||||
double precision, external :: num_v_ij_erf_rk_cst_mu_j1b
|
||||
|
||||
print*, ' test_v_ij_erf_rk_cst_mu_j1b ...'
|
||||
|
||||
PROVIDE v_ij_erf_rk_cst_mu_j1b
|
||||
|
||||
eps_ij = 1d-3
|
||||
acc_tot = 0.d0
|
||||
normalz = 0.d0
|
||||
|
||||
!do ipoint = 1, 10
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
|
||||
i_exc = v_ij_erf_rk_cst_mu_j1b(i,j,ipoint)
|
||||
i_num = num_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem in v_ij_erf_rk_cst_mu_j1b on', i, j, ipoint
|
||||
print *, ' analyt integ = ', i_exc
|
||||
print *, ' numeri integ = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
endif
|
||||
|
||||
acc_tot += acc_ij
|
||||
normalz += dabs(i_num)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
print*, ' acc_tot = ', acc_tot
|
||||
print*, ' normalz = ', normalz
|
||||
|
||||
return
|
||||
end subroutine test_v_ij_erf_rk_cst_mu_j1b
|
||||
|
||||
! ---
|
||||
|
||||
subroutine test_x_v_ij_erf_rk_cst_mu_j1b()
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint
|
||||
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
|
||||
double precision :: integ(3)
|
||||
|
||||
print*, ' test_x_v_ij_erf_rk_cst_mu_j1b ...'
|
||||
|
||||
PROVIDE x_v_ij_erf_rk_cst_mu_j1b
|
||||
|
||||
eps_ij = 1d-3
|
||||
acc_tot = 0.d0
|
||||
normalz = 0.d0
|
||||
|
||||
!do ipoint = 1, 10
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
|
||||
call num_x_v_ij_erf_rk_cst_mu_j1b(i, j, ipoint, integ)
|
||||
|
||||
i_exc = x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,1)
|
||||
i_num = integ(1)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem in x part of x_v_ij_erf_rk_cst_mu_j1b on', i, j, ipoint
|
||||
print *, ' analyt integ = ', i_exc
|
||||
print *, ' numeri integ = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
endif
|
||||
acc_tot += acc_ij
|
||||
normalz += dabs(i_num)
|
||||
|
||||
i_exc = x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,2)
|
||||
i_num = integ(2)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem in y part of x_v_ij_erf_rk_cst_mu_j1b on', i, j, ipoint
|
||||
print *, ' analyt integ = ', i_exc
|
||||
print *, ' numeri integ = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
endif
|
||||
acc_tot += acc_ij
|
||||
normalz += dabs(i_num)
|
||||
|
||||
i_exc = x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,3)
|
||||
i_num = integ(3)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem in z part of x_v_ij_erf_rk_cst_mu_j1b on', i, j, ipoint
|
||||
print *, ' analyt integ = ', i_exc
|
||||
print *, ' numeri integ = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
endif
|
||||
acc_tot += acc_ij
|
||||
normalz += dabs(i_num)
|
||||
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
print*, ' acc_tot = ', acc_tot
|
||||
print*, ' normalz = ', normalz
|
||||
|
||||
return
|
||||
end subroutine test_x_v_ij_erf_rk_cst_mu_j1b
|
||||
|
||||
! ---
|
||||
|
||||
subroutine test_int2_u2_j1b2()
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint
|
||||
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
|
||||
double precision, external :: num_int2_u2_j1b2
|
||||
|
||||
print*, ' test_int2_u2_j1b2 ...'
|
||||
|
||||
PROVIDE int2_u2_j1b2
|
||||
|
||||
eps_ij = 1d-3
|
||||
acc_tot = 0.d0
|
||||
normalz = 0.d0
|
||||
|
||||
!do ipoint = 1, 10
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
|
||||
i_exc = int2_u2_j1b2(i,j,ipoint)
|
||||
i_num = num_int2_u2_j1b2(i,j,ipoint)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem in int2_u2_j1b2 on', i, j, ipoint
|
||||
print *, ' analyt integ = ', i_exc
|
||||
print *, ' numeri integ = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
endif
|
||||
|
||||
acc_tot += acc_ij
|
||||
normalz += dabs(i_num)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
acc_tot = acc_tot / normalz
|
||||
print*, ' acc_tot = ', acc_tot
|
||||
print*, ' normalz = ', normalz
|
||||
|
||||
return
|
||||
end subroutine test_int2_u2_j1b2
|
||||
|
||||
! ---
|
||||
|
||||
subroutine test_int2_grad1u2_grad2u2_j1b2()
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint
|
||||
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
|
||||
double precision, external :: num_int2_grad1u2_grad2u2_j1b2
|
||||
|
||||
print*, ' test_int2_grad1u2_grad2u2_j1b2 ...'
|
||||
|
||||
PROVIDE int2_grad1u2_grad2u2_j1b2
|
||||
|
||||
eps_ij = 1d-3
|
||||
acc_tot = 0.d0
|
||||
normalz = 0.d0
|
||||
|
||||
!do ipoint = 1, 10
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
|
||||
i_exc = int2_grad1u2_grad2u2_j1b2(i,j,ipoint)
|
||||
i_num = num_int2_grad1u2_grad2u2_j1b2(i,j,ipoint)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem in int2_grad1u2_grad2u2_j1b2 on', i, j, ipoint
|
||||
print *, ' analyt integ = ', i_exc
|
||||
print *, ' numeri integ = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
endif
|
||||
|
||||
acc_tot += acc_ij
|
||||
normalz += dabs(i_num)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
print*, ' acc_tot = ', acc_tot
|
||||
print*, ' normalz = ', normalz
|
||||
|
||||
return
|
||||
end subroutine test_int2_grad1u2_grad2u2_j1b2
|
||||
|
||||
! ---
|
||||
|
||||
subroutine test_int2_grad1_u12_ao()
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint
|
||||
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
|
||||
double precision :: integ(3)
|
||||
|
||||
print*, ' test_int2_grad1_u12_ao ...'
|
||||
|
||||
PROVIDE int2_grad1_u12_ao
|
||||
|
||||
eps_ij = 1d-3
|
||||
acc_tot = 0.d0
|
||||
normalz = 0.d0
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
|
||||
call num_int2_grad1_u12_ao(i, j, ipoint, integ)
|
||||
|
||||
i_exc = int2_grad1_u12_ao(i,j,ipoint,1)
|
||||
i_num = integ(1)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem in x part of int2_grad1_u12_ao on', i, j, ipoint
|
||||
print *, ' analyt integ = ', i_exc
|
||||
print *, ' numeri integ = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
endif
|
||||
acc_tot += acc_ij
|
||||
normalz += dabs(i_num)
|
||||
|
||||
i_exc = int2_grad1_u12_ao(i,j,ipoint,2)
|
||||
i_num = integ(2)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem in y part of int2_grad1_u12_ao on', i, j, ipoint
|
||||
print *, ' analyt integ = ', i_exc
|
||||
print *, ' numeri integ = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
endif
|
||||
acc_tot += acc_ij
|
||||
normalz += dabs(i_num)
|
||||
|
||||
i_exc = int2_grad1_u12_ao(i,j,ipoint,3)
|
||||
i_num = integ(3)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem in z part of int2_grad1_u12_ao on', i, j, ipoint
|
||||
print *, ' analyt integ = ', i_exc
|
||||
print *, ' numeri integ = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
endif
|
||||
acc_tot += acc_ij
|
||||
normalz += dabs(i_num)
|
||||
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
print*, ' acc_tot = ', acc_tot
|
||||
print*, ' normalz = ', normalz
|
||||
|
||||
return
|
||||
end subroutine test_int2_grad1_u12_ao
|
||||
|
||||
! ---
|
||||
|
||||
subroutine test_int2_u_grad1u_total_j1b2()
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint
|
||||
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
|
||||
double precision :: x, y, z
|
||||
double precision :: integ(3)
|
||||
|
||||
print*, ' test_int2_u_grad1u_total_j1b2 ...'
|
||||
|
||||
PROVIDE int2_u_grad1u_j1b2
|
||||
PROVIDE int2_u_grad1u_x_j1b2
|
||||
|
||||
eps_ij = 1d-3
|
||||
acc_tot = 0.d0
|
||||
normalz = 0.d0
|
||||
|
||||
!do ipoint = 1, 10
|
||||
do ipoint = 1, n_points_final_grid
|
||||
x = final_grid_points(1,ipoint)
|
||||
y = final_grid_points(2,ipoint)
|
||||
z = final_grid_points(3,ipoint)
|
||||
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
|
||||
call num_int2_u_grad1u_total_j1b2(i, j, ipoint, integ)
|
||||
|
||||
i_exc = x * int2_u_grad1u_j1b2(i,j,ipoint) - int2_u_grad1u_x_j1b2(i,j,ipoint,1)
|
||||
i_num = integ(1)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem in x part of int2_u_grad1u_total_j1b2 on', i, j, ipoint
|
||||
print *, ' analyt integ = ', i_exc
|
||||
print *, ' numeri integ = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
endif
|
||||
acc_tot += acc_ij
|
||||
normalz += dabs(i_num)
|
||||
|
||||
i_exc = y * int2_u_grad1u_j1b2(i,j,ipoint) - int2_u_grad1u_x_j1b2(i,j,ipoint,2)
|
||||
i_num = integ(2)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem in y part of int2_u_grad1u_total_j1b2 on', i, j, ipoint
|
||||
print *, ' analyt integ = ', i_exc
|
||||
print *, ' numeri integ = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
endif
|
||||
acc_tot += acc_ij
|
||||
normalz += dabs(i_num)
|
||||
|
||||
i_exc = z * int2_u_grad1u_j1b2(i,j,ipoint) - int2_u_grad1u_x_j1b2(i,j,ipoint,3)
|
||||
i_num = integ(3)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem in z part of int2_u_grad1u_total_j1b2 on', i, j, ipoint
|
||||
print *, ' analyt integ = ', i_exc
|
||||
print *, ' numeri integ = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
endif
|
||||
acc_tot += acc_ij
|
||||
normalz += dabs(i_num)
|
||||
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
print*, ' acc_tot = ', acc_tot
|
||||
print*, ' normalz = ', normalz
|
||||
|
||||
return
|
||||
end subroutine test_int2_u_grad1u_total_j1b2
|
||||
|
||||
! ---
|
||||
|
||||
subroutine test_gradu_squared_u_ij_mu()
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint
|
||||
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
|
||||
double precision, external :: num_gradu_squared_u_ij_mu
|
||||
|
||||
print*, ' test_gradu_squared_u_ij_mu ...'
|
||||
|
||||
PROVIDE gradu_squared_u_ij_mu
|
||||
|
||||
eps_ij = 1d-3
|
||||
acc_tot = 0.d0
|
||||
normalz = 0.d0
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
|
||||
i_exc = gradu_squared_u_ij_mu(i,j,ipoint)
|
||||
i_num = num_gradu_squared_u_ij_mu(i, j, ipoint)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem in gradu_squared_u_ij_mu on', i, j, ipoint
|
||||
print *, ' analyt integ = ', i_exc
|
||||
print *, ' numeri integ = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
endif
|
||||
acc_tot += acc_ij
|
||||
normalz += dabs(i_num)
|
||||
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
print*, ' acc_tot = ', acc_tot
|
||||
print*, ' normalz = ', normalz
|
||||
|
||||
return
|
||||
end subroutine test_gradu_squared_u_ij_mu
|
||||
|
||||
! ---
|
||||
|
||||
subroutine test_grad12_j12()
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint
|
||||
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
|
||||
double precision, external :: num_grad12_j12
|
||||
|
||||
print*, ' test_grad12_j12 ...'
|
||||
|
||||
PROVIDE grad12_j12
|
||||
|
||||
eps_ij = 1d-3
|
||||
acc_tot = 0.d0
|
||||
normalz = 0.d0
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
|
||||
i_exc = grad12_j12(i,j,ipoint)
|
||||
i_num = num_grad12_j12(i, j, ipoint)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem in grad12_j12 on', i, j, ipoint
|
||||
print *, ' analyt integ = ', i_exc
|
||||
print *, ' numeri integ = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
endif
|
||||
|
||||
acc_tot += acc_ij
|
||||
normalz += dabs(i_num)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
print*, ' acc_tot = ', acc_tot
|
||||
print*, ' normalz = ', normalz
|
||||
|
||||
return
|
||||
end subroutine test_grad12_j12
|
||||
|
||||
! ---
|
||||
|
||||
subroutine test_u12sq_j1bsq()
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint
|
||||
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
|
||||
double precision, external :: num_u12sq_j1bsq
|
||||
|
||||
print*, ' test_u12sq_j1bsq ...'
|
||||
|
||||
PROVIDE u12sq_j1bsq
|
||||
|
||||
eps_ij = 1d-3
|
||||
acc_tot = 0.d0
|
||||
normalz = 0.d0
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
|
||||
i_exc = u12sq_j1bsq(i,j,ipoint)
|
||||
i_num = num_u12sq_j1bsq(i, j, ipoint)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem in u12sq_j1bsq on', i, j, ipoint
|
||||
print *, ' analyt integ = ', i_exc
|
||||
print *, ' numeri integ = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
endif
|
||||
|
||||
acc_tot += acc_ij
|
||||
normalz += dabs(i_num)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
print*, ' acc_tot = ', acc_tot
|
||||
print*, ' normalz = ', normalz
|
||||
|
||||
return
|
||||
end subroutine test_u12sq_j1bsq
|
||||
|
||||
! ---
|
||||
|
||||
subroutine test_u12_grad1_u12_j1b_grad1_j1b()
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint
|
||||
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
|
||||
double precision, external :: num_u12_grad1_u12_j1b_grad1_j1b
|
||||
|
||||
print*, ' test_u12_grad1_u12_j1b_grad1_j1b ...'
|
||||
|
||||
PROVIDE u12_grad1_u12_j1b_grad1_j1b
|
||||
|
||||
eps_ij = 1d-3
|
||||
acc_tot = 0.d0
|
||||
normalz = 0.d0
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
|
||||
i_exc = u12_grad1_u12_j1b_grad1_j1b(i,j,ipoint)
|
||||
i_num = num_u12_grad1_u12_j1b_grad1_j1b(i, j, ipoint)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem in u12_grad1_u12_j1b_grad1_j1b on', i, j, ipoint
|
||||
print *, ' analyt integ = ', i_exc
|
||||
print *, ' numeri integ = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
endif
|
||||
|
||||
acc_tot += acc_ij
|
||||
normalz += dabs(i_num)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
print*, ' acc_tot = ', acc_tot
|
||||
print*, ' normalz = ', normalz
|
||||
|
||||
return
|
||||
end subroutine test_u12_grad1_u12_j1b_grad1_j1b
|
||||
|
||||
! ---
|
||||
|
||||
subroutine test_vect_overlap_gauss_r12_ao()
|
||||
|
||||
implicit none
|
||||
|
||||
integer :: i, j, ipoint
|
||||
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
|
||||
double precision :: expo_fit, r(3)
|
||||
double precision, allocatable :: I_vec(:,:,:), I_ref(:,:,:), int_fit_v(:)
|
||||
|
||||
double precision, external :: overlap_gauss_r12_ao
|
||||
|
||||
print *, ' test_vect_overlap_gauss_r12_ao ...'
|
||||
|
||||
provide mu_erf final_grid_points_transp j1b_pen
|
||||
|
||||
expo_fit = expo_gauss_j_mu_x_2(1)
|
||||
|
||||
! ---
|
||||
|
||||
allocate(int_fit_v(n_points_final_grid))
|
||||
allocate(I_vec(ao_num,ao_num,n_points_final_grid))
|
||||
|
||||
I_vec = 0.d0
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
|
||||
call overlap_gauss_r12_ao_v(final_grid_points_transp, n_points_final_grid, expo_fit, i, j, int_fit_v, n_points_final_grid, n_points_final_grid)
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
I_vec(j,i,ipoint) = int_fit_v(ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
allocate(I_ref(ao_num,ao_num,n_points_final_grid))
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
r(1) = final_grid_points(1,ipoint)
|
||||
r(2) = final_grid_points(2,ipoint)
|
||||
r(3) = final_grid_points(3,ipoint)
|
||||
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
|
||||
I_ref(j,i,ipoint) = overlap_gauss_r12_ao(r, expo_fit, i, j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
eps_ij = 1d-3
|
||||
acc_tot = 0.d0
|
||||
normalz = 0.d0
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
|
||||
i_exc = I_ref(i,j,ipoint)
|
||||
i_num = I_vec(i,j,ipoint)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
!acc_ij = dabs(i_exc - i_num) / dabs(i_exc)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem in overlap_gauss_r12_ao_v on', i, j, ipoint
|
||||
print *, ' analyt integ = ', i_exc
|
||||
print *, ' numeri integ = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
stop
|
||||
endif
|
||||
|
||||
acc_tot += acc_ij
|
||||
normalz += dabs(i_num)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
print*, ' acc_tot = ', acc_tot
|
||||
print*, ' normalz = ', normalz
|
||||
|
||||
return
|
||||
end subroutine test_vect_overlap_gauss_r12_ao
|
||||
|
||||
! ---
|
||||
|
||||
subroutine test_vect_overlap_gauss_r12_ao_with1s()
|
||||
|
||||
implicit none
|
||||
|
||||
integer :: i, j, ipoint
|
||||
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
|
||||
double precision :: expo_fit, r(3), beta, B_center(3)
|
||||
double precision, allocatable :: I_vec(:,:,:), I_ref(:,:,:), int_fit_v(:)
|
||||
|
||||
double precision, external :: overlap_gauss_r12_ao_with1s
|
||||
|
||||
print *, ' test_vect_overlap_gauss_r12_ao_with1s ...'
|
||||
|
||||
provide mu_erf final_grid_points_transp j1b_pen
|
||||
|
||||
expo_fit = expo_gauss_j_mu_x_2(1)
|
||||
beta = List_all_comb_b3_expo (2)
|
||||
B_center(1) = List_all_comb_b3_cent(1,2)
|
||||
B_center(2) = List_all_comb_b3_cent(2,2)
|
||||
B_center(3) = List_all_comb_b3_cent(3,2)
|
||||
|
||||
! ---
|
||||
|
||||
allocate(int_fit_v(n_points_final_grid))
|
||||
allocate(I_vec(ao_num,ao_num,n_points_final_grid))
|
||||
|
||||
I_vec = 0.d0
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
|
||||
call overlap_gauss_r12_ao_with1s_v(B_center, beta, final_grid_points_transp, n_points_final_grid, expo_fit, i, j, int_fit_v, n_points_final_grid, n_points_final_grid)
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
I_vec(j,i,ipoint) = int_fit_v(ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
allocate(I_ref(ao_num,ao_num,n_points_final_grid))
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
r(1) = final_grid_points(1,ipoint)
|
||||
r(2) = final_grid_points(2,ipoint)
|
||||
r(3) = final_grid_points(3,ipoint)
|
||||
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
|
||||
I_ref(j,i,ipoint) = overlap_gauss_r12_ao_with1s(B_center, beta, r, expo_fit, i, j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
eps_ij = 1d-3
|
||||
acc_tot = 0.d0
|
||||
normalz = 0.d0
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
|
||||
i_exc = I_ref(i,j,ipoint)
|
||||
i_num = I_vec(i,j,ipoint)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
!acc_ij = dabs(i_exc - i_num) / dabs(i_exc)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem in overlap_gauss_r12_ao_v on', i, j, ipoint
|
||||
print *, ' analyt integ = ', i_exc
|
||||
print *, ' numeri integ = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
stop
|
||||
endif
|
||||
|
||||
acc_tot += acc_ij
|
||||
normalz += dabs(i_num)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
print*, ' acc_tot = ', acc_tot
|
||||
print*, ' normalz = ', normalz
|
||||
|
||||
return
|
||||
end subroutine test_vect_overlap_gauss_r12_ao
|
||||
|
||||
437
src/non_h_ints_mu/grad_squared.irp.f
Normal file
437
src/non_h_ints_mu/grad_squared.irp.f
Normal file
@ -0,0 +1,437 @@
|
||||
|
||||
! ---
|
||||
|
||||
! TODO : strong optmization : write the loops in a different way
|
||||
! : for each couple of AO, the gaussian product are done once for all
|
||||
|
||||
BEGIN_PROVIDER [ double precision, gradu_squared_u_ij_mu, (ao_num, ao_num, n_points_final_grid) ]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! if J(r1,r2) = u12:
|
||||
!
|
||||
! gradu_squared_u_ij_mu = -0.50 x \int r2 [ (grad_1 u12)^2 + (grad_2 u12^2)] \phi_i(2) \phi_j(2)
|
||||
! = -0.25 x \int r2 (1 - erf(mu*r12))^2 \phi_i(2) \phi_j(2)
|
||||
! and
|
||||
! (1 - erf(mu*r12))^2 = \sum_i coef_gauss_1_erf_x_2(i) * exp(-expo_gauss_1_erf_x_2(i) * r12^2)
|
||||
!
|
||||
! if J(r1,r2) = u12 x v1 x v2
|
||||
!
|
||||
! gradu_squared_u_ij_mu = -0.50 x \int r2 \phi_i(2) \phi_j(2) [ v1^2 v2^2 ((grad_1 u12)^2 + (grad_2 u12^2)]) + u12^2 v2^2 (grad_1 v1)^2 + 2 u12 v1 v2^2 (grad_1 u12) . (grad_1 v1) ]
|
||||
! = -0.25 x v1^2 \int r2 \phi_i(2) \phi_j(2) [1 - erf(mu r12)]^2 v2^2
|
||||
! + -0.50 x (grad_1 v1)^2 \int r2 \phi_i(2) \phi_j(2) u12^2 v2^2
|
||||
! + -1.00 x v1 (grad_1 v1) \int r2 \phi_i(2) \phi_j(2) (grad_1 u12) v2^2
|
||||
! = v1^2 x int2_grad1u2_grad2u2_j1b2
|
||||
! + -0.5 x (grad_1 v1)^2 x int2_u2_j1b2
|
||||
! + -1.0 X V1 x (grad_1 v1) \cdot [ int2_u_grad1u_j1b2 x r - int2_u_grad1u_x_j1b ]
|
||||
!
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: ipoint, i, j, m, igauss
|
||||
double precision :: x, y, z, r(3), delta, coef
|
||||
double precision :: tmp_v, tmp_x, tmp_y, tmp_z
|
||||
double precision :: tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7, tmp8, tmp9
|
||||
double precision :: time0, time1
|
||||
double precision, external :: overlap_gauss_r12_ao
|
||||
|
||||
print*, ' providing gradu_squared_u_ij_mu ...'
|
||||
call wall_time(time0)
|
||||
|
||||
PROVIDE j1b_type
|
||||
|
||||
if(j1b_type .eq. 3) then
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
x = final_grid_points(1,ipoint)
|
||||
y = final_grid_points(2,ipoint)
|
||||
z = final_grid_points(3,ipoint)
|
||||
tmp_v = v_1b (ipoint)
|
||||
tmp_x = v_1b_grad(1,ipoint)
|
||||
tmp_y = v_1b_grad(2,ipoint)
|
||||
tmp_z = v_1b_grad(3,ipoint)
|
||||
|
||||
tmp1 = tmp_v * tmp_v
|
||||
tmp2 = -0.5d0 * (tmp_x * tmp_x + tmp_y * tmp_y + tmp_z * tmp_z)
|
||||
tmp3 = tmp_v * tmp_x
|
||||
tmp4 = tmp_v * tmp_y
|
||||
tmp5 = tmp_v * tmp_z
|
||||
|
||||
tmp6 = -x * tmp3
|
||||
tmp7 = -y * tmp4
|
||||
tmp8 = -z * tmp5
|
||||
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
|
||||
tmp9 = int2_u_grad1u_j1b2(i,j,ipoint)
|
||||
|
||||
gradu_squared_u_ij_mu(i,j,ipoint) = tmp1 * int2_grad1u2_grad2u2_j1b2(i,j,ipoint) &
|
||||
+ tmp2 * int2_u2_j1b2 (i,j,ipoint) &
|
||||
+ tmp6 * tmp9 + tmp3 * int2_u_grad1u_x_j1b2(i,j,ipoint,1) &
|
||||
+ tmp7 * tmp9 + tmp4 * int2_u_grad1u_x_j1b2(i,j,ipoint,2) &
|
||||
+ tmp8 * tmp9 + tmp5 * int2_u_grad1u_x_j1b2(i,j,ipoint,3)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
else
|
||||
|
||||
gradu_squared_u_ij_mu = 0.d0
|
||||
do ipoint = 1, n_points_final_grid
|
||||
r(1) = final_grid_points(1,ipoint)
|
||||
r(2) = final_grid_points(2,ipoint)
|
||||
r(3) = final_grid_points(3,ipoint)
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
do igauss = 1, n_max_fit_slat
|
||||
delta = expo_gauss_1_erf_x_2(igauss)
|
||||
coef = coef_gauss_1_erf_x_2(igauss)
|
||||
gradu_squared_u_ij_mu(i,j,ipoint) += -0.25d0 * coef * overlap_gauss_r12_ao(r, delta, i, j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
endif
|
||||
|
||||
call wall_time(time1)
|
||||
print*, ' Wall time for gradu_squared_u_ij_mu = ', time1 - time0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
!BEGIN_PROVIDER [double precision, tc_grad_square_ao_loop, (ao_num, ao_num, ao_num, ao_num)]
|
||||
!
|
||||
! BEGIN_DOC
|
||||
! !
|
||||
! ! tc_grad_square_ao_loop(k,i,l,j) = -1/2 <kl | |\grad_1 u(r1,r2)|^2 + |\grad_1 u(r1,r2)|^2 | ij>
|
||||
! !
|
||||
! END_DOC
|
||||
!
|
||||
! implicit none
|
||||
! integer :: ipoint, i, j, k, l
|
||||
! double precision :: weight1, ao_ik_r, ao_i_r
|
||||
! double precision, allocatable :: ac_mat(:,:,:,:)
|
||||
!
|
||||
! allocate(ac_mat(ao_num,ao_num,ao_num,ao_num))
|
||||
! ac_mat = 0.d0
|
||||
!
|
||||
! do ipoint = 1, n_points_final_grid
|
||||
! weight1 = final_weight_at_r_vector(ipoint)
|
||||
!
|
||||
! do i = 1, ao_num
|
||||
! ao_i_r = weight1 * aos_in_r_array_transp(ipoint,i)
|
||||
!
|
||||
! do k = 1, ao_num
|
||||
! ao_ik_r = ao_i_r * aos_in_r_array_transp(ipoint,k)
|
||||
!
|
||||
! do j = 1, ao_num
|
||||
! do l = 1, ao_num
|
||||
! ac_mat(k,i,l,j) += ao_ik_r * gradu_squared_u_ij_mu(l,j,ipoint)
|
||||
! enddo
|
||||
! enddo
|
||||
! enddo
|
||||
! enddo
|
||||
! enddo
|
||||
!
|
||||
! do j = 1, ao_num
|
||||
! do l = 1, ao_num
|
||||
! do i = 1, ao_num
|
||||
! do k = 1, ao_num
|
||||
! tc_grad_square_ao_loop(k,i,l,j) = ac_mat(k,i,l,j) + ac_mat(l,j,k,i)
|
||||
! !write(11,*) tc_grad_square_ao_loop(k,i,l,j)
|
||||
! enddo
|
||||
! enddo
|
||||
! enddo
|
||||
! enddo
|
||||
!
|
||||
! deallocate(ac_mat)
|
||||
!
|
||||
!END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, tc_grad_square_ao_loop, (ao_num, ao_num, ao_num, ao_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! tc_grad_square_ao_loop(k,i,l,j) = 1/2 <kl | |\grad_1 u(r1,r2)|^2 + |\grad_2 u(r1,r2)|^2 | ij>
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: ipoint, i, j, k, l
|
||||
double precision :: weight1, ao_ik_r, ao_i_r
|
||||
double precision :: time0, time1
|
||||
double precision, allocatable :: ac_mat(:,:,:,:), bc_mat(:,:,:,:)
|
||||
|
||||
print*, ' providing tc_grad_square_ao_loop ...'
|
||||
call wall_time(time0)
|
||||
|
||||
allocate(ac_mat(ao_num,ao_num,ao_num,ao_num))
|
||||
ac_mat = 0.d0
|
||||
allocate(bc_mat(ao_num,ao_num,ao_num,ao_num))
|
||||
bc_mat = 0.d0
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
weight1 = final_weight_at_r_vector(ipoint)
|
||||
|
||||
do i = 1, ao_num
|
||||
!ao_i_r = weight1 * aos_in_r_array_transp(ipoint,i)
|
||||
ao_i_r = weight1 * aos_in_r_array(i,ipoint)
|
||||
|
||||
do k = 1, ao_num
|
||||
!ao_ik_r = ao_i_r * aos_in_r_array_transp(ipoint,k)
|
||||
ao_ik_r = ao_i_r * aos_in_r_array(k,ipoint)
|
||||
|
||||
do j = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
ac_mat(k,i,l,j) += ao_ik_r * ( u12sq_j1bsq(l,j,ipoint) + u12_grad1_u12_j1b_grad1_j1b(l,j,ipoint) )
|
||||
bc_mat(k,i,l,j) += ao_ik_r * grad12_j12(l,j,ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do j = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
tc_grad_square_ao_loop(k,i,l,j) = ac_mat(k,i,l,j) + ac_mat(l,j,k,i) + bc_mat(k,i,l,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
deallocate(ac_mat)
|
||||
deallocate(bc_mat)
|
||||
|
||||
call wall_time(time1)
|
||||
print*, ' Wall time for tc_grad_square_ao_loop = ', time1 - time0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, grad12_j12, (ao_num, ao_num, n_points_final_grid) ]
|
||||
|
||||
implicit none
|
||||
integer :: ipoint, i, j, m, igauss
|
||||
double precision :: r(3), delta, coef
|
||||
double precision :: tmp1
|
||||
double precision :: time0, time1
|
||||
double precision, external :: overlap_gauss_r12_ao
|
||||
|
||||
print*, ' providing grad12_j12 ...'
|
||||
call wall_time(time0)
|
||||
|
||||
PROVIDE j1b_type
|
||||
|
||||
if(j1b_type .eq. 3) then
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
tmp1 = v_1b(ipoint)
|
||||
tmp1 = tmp1 * tmp1
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
grad12_j12(i,j,ipoint) = tmp1 * int2_grad1u2_grad2u2_j1b2(i,j,ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
else
|
||||
|
||||
grad12_j12 = 0.d0
|
||||
do ipoint = 1, n_points_final_grid
|
||||
r(1) = final_grid_points(1,ipoint)
|
||||
r(2) = final_grid_points(2,ipoint)
|
||||
r(3) = final_grid_points(3,ipoint)
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
do igauss = 1, n_max_fit_slat
|
||||
delta = expo_gauss_1_erf_x_2(igauss)
|
||||
coef = coef_gauss_1_erf_x_2(igauss)
|
||||
grad12_j12(i,j,ipoint) += -0.25d0 * coef * overlap_gauss_r12_ao(r, delta, i, j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
endif
|
||||
|
||||
call wall_time(time1)
|
||||
print*, ' Wall time for grad12_j12 = ', time1 - time0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, u12sq_j1bsq, (ao_num, ao_num, n_points_final_grid) ]
|
||||
|
||||
implicit none
|
||||
integer :: ipoint, i, j
|
||||
double precision :: tmp_x, tmp_y, tmp_z
|
||||
double precision :: tmp1
|
||||
double precision :: time0, time1
|
||||
|
||||
print*, ' providing u12sq_j1bsq ...'
|
||||
call wall_time(time0)
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
tmp_x = v_1b_grad(1,ipoint)
|
||||
tmp_y = v_1b_grad(2,ipoint)
|
||||
tmp_z = v_1b_grad(3,ipoint)
|
||||
tmp1 = -0.5d0 * (tmp_x * tmp_x + tmp_y * tmp_y + tmp_z * tmp_z)
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
u12sq_j1bsq(i,j,ipoint) = tmp1 * int2_u2_j1b2(i,j,ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(time1)
|
||||
print*, ' Wall time for u12sq_j1bsq = ', time1 - time0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, u12_grad1_u12_j1b_grad1_j1b, (ao_num, ao_num, n_points_final_grid) ]
|
||||
|
||||
implicit none
|
||||
integer :: ipoint, i, j, m, igauss
|
||||
double precision :: x, y, z
|
||||
double precision :: tmp_v, tmp_x, tmp_y, tmp_z
|
||||
double precision :: tmp3, tmp4, tmp5, tmp6, tmp7, tmp8, tmp9
|
||||
double precision :: time0, time1
|
||||
double precision, external :: overlap_gauss_r12_ao
|
||||
|
||||
print*, ' providing u12_grad1_u12_j1b_grad1_j1b ...'
|
||||
call wall_time(time0)
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
x = final_grid_points(1,ipoint)
|
||||
y = final_grid_points(2,ipoint)
|
||||
z = final_grid_points(3,ipoint)
|
||||
tmp_v = v_1b (ipoint)
|
||||
tmp_x = v_1b_grad(1,ipoint)
|
||||
tmp_y = v_1b_grad(2,ipoint)
|
||||
tmp_z = v_1b_grad(3,ipoint)
|
||||
|
||||
tmp3 = tmp_v * tmp_x
|
||||
tmp4 = tmp_v * tmp_y
|
||||
tmp5 = tmp_v * tmp_z
|
||||
|
||||
tmp6 = -x * tmp3
|
||||
tmp7 = -y * tmp4
|
||||
tmp8 = -z * tmp5
|
||||
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
|
||||
tmp9 = int2_u_grad1u_j1b2(i,j,ipoint)
|
||||
|
||||
u12_grad1_u12_j1b_grad1_j1b(i,j,ipoint) = tmp6 * tmp9 + tmp3 * int2_u_grad1u_x_j1b2(i,j,ipoint,1) &
|
||||
+ tmp7 * tmp9 + tmp4 * int2_u_grad1u_x_j1b2(i,j,ipoint,2) &
|
||||
+ tmp8 * tmp9 + tmp5 * int2_u_grad1u_x_j1b2(i,j,ipoint,3)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(time1)
|
||||
print*, ' Wall time for u12_grad1_u12_j1b_grad1_j1b = ', time1 - time0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, tc_grad_square_ao, (ao_num, ao_num, ao_num, ao_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! tc_grad_square_ao(k,i,l,j) = 1/2 <kl | |\grad_1 u(r1,r2)|^2 + |\grad_2 u(r1,r2)|^2 | ij>
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: ipoint, i, j, k, l
|
||||
double precision :: weight1, ao_ik_r, ao_i_r
|
||||
double precision :: time0, time1
|
||||
double precision, allocatable :: ac_mat(:,:,:,:), b_mat(:,:,:), tmp(:,:,:)
|
||||
|
||||
print*, ' providing tc_grad_square_ao ...'
|
||||
call wall_time(time0)
|
||||
|
||||
allocate(ac_mat(ao_num,ao_num,ao_num,ao_num), b_mat(n_points_final_grid,ao_num,ao_num), tmp(ao_num,ao_num,n_points_final_grid))
|
||||
|
||||
b_mat = 0.d0
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i, k, ipoint) &
|
||||
!$OMP SHARED (aos_in_r_array_transp, b_mat, ao_num, n_points_final_grid, final_weight_at_r_vector)
|
||||
!$OMP DO SCHEDULE (static)
|
||||
do i = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
b_mat(ipoint,k,i) = final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,k)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
tmp = 0.d0
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (j, l, ipoint) &
|
||||
!$OMP SHARED (tmp, ao_num, n_points_final_grid, u12sq_j1bsq, u12_grad1_u12_j1b_grad1_j1b, grad12_j12)
|
||||
!$OMP DO SCHEDULE (static)
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do j = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
tmp(l,j,ipoint) = u12sq_j1bsq(l,j,ipoint) + u12_grad1_u12_j1b_grad1_j1b(l,j,ipoint) + 0.5d0 * grad12_j12(l,j,ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
|
||||
ac_mat = 0.d0
|
||||
call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
|
||||
, tmp(1,1,1), ao_num*ao_num, b_mat(1,1,1), n_points_final_grid &
|
||||
, 1.d0, ac_mat, ao_num*ao_num)
|
||||
deallocate(tmp, b_mat)
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i, j, k, l) &
|
||||
!$OMP SHARED (ac_mat, tc_grad_square_ao, ao_num)
|
||||
!$OMP DO SCHEDULE (static)
|
||||
do j = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
tc_grad_square_ao(k,i,l,j) = ac_mat(k,i,l,j) + ac_mat(l,j,k,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
deallocate(ac_mat)
|
||||
|
||||
call wall_time(time1)
|
||||
print*, ' Wall time for tc_grad_square_ao = ', time1 - time0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
221
src/non_h_ints_mu/grad_squared_manu.irp.f
Normal file
221
src/non_h_ints_mu/grad_squared_manu.irp.f
Normal file
@ -0,0 +1,221 @@
|
||||
|
||||
BEGIN_PROVIDER [double precision, tc_grad_square_ao_test, (ao_num, ao_num, ao_num, ao_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! tc_grad_square_ao_test(k,i,l,j) = -1/2 <kl | |\grad_1 u(r1,r2)|^2 + |\grad_1 u(r1,r2)|^2 | ij>
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: ipoint, i, j, k, l
|
||||
double precision :: weight1, ao_ik_r, ao_i_r,contrib,contrib2
|
||||
double precision :: time0, time1
|
||||
double precision, allocatable :: ac_mat(:,:,:,:), b_mat(:,:,:), tmp(:,:,:)
|
||||
|
||||
print*, ' providing tc_grad_square_ao_test ...'
|
||||
call wall_time(time0)
|
||||
|
||||
provide u12sq_j1bsq_test u12_grad1_u12_j1b_grad1_j1b_test grad12_j12_test
|
||||
|
||||
allocate(ac_mat(ao_num,ao_num,ao_num,ao_num), b_mat(n_points_final_grid,ao_num,ao_num), tmp(ao_num,ao_num,n_points_final_grid))
|
||||
|
||||
b_mat = 0.d0
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i, k, ipoint) &
|
||||
!$OMP SHARED (aos_in_r_array_transp, b_mat, ao_num, n_points_final_grid, final_weight_at_r_vector)
|
||||
!$OMP DO SCHEDULE (static)
|
||||
do i = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
b_mat(ipoint,k,i) = final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,k)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
tmp = 0.d0
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (j, l, ipoint) &
|
||||
!$OMP SHARED (tmp, ao_num, n_points_final_grid, u12sq_j1bsq_test, u12_grad1_u12_j1b_grad1_j1b_test, grad12_j12_test)
|
||||
!$OMP DO SCHEDULE (static)
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do j = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
tmp(l,j,ipoint) = u12sq_j1bsq_test(l,j,ipoint) + u12_grad1_u12_j1b_grad1_j1b_test(l,j,ipoint) + 0.5d0 * grad12_j12_test(l,j,ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
ac_mat = 0.d0
|
||||
call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
|
||||
, tmp(1,1,1), ao_num*ao_num, b_mat(1,1,1), n_points_final_grid &
|
||||
, 1.d0, ac_mat, ao_num*ao_num)
|
||||
deallocate(tmp, b_mat)
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i, j, k, l) &
|
||||
!$OMP SHARED (ac_mat, tc_grad_square_ao_test, ao_num)
|
||||
!$OMP DO SCHEDULE (static)
|
||||
do j = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
tc_grad_square_ao_test(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
|
||||
|
||||
deallocate(ac_mat)
|
||||
|
||||
call wall_time(time1)
|
||||
print*, ' Wall time for tc_grad_square_ao_test = ', time1 - time0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, u12sq_j1bsq_test, (ao_num, ao_num, n_points_final_grid) ]
|
||||
|
||||
implicit none
|
||||
integer :: ipoint, i, j
|
||||
double precision :: tmp_x, tmp_y, tmp_z
|
||||
double precision :: tmp1
|
||||
double precision :: time0, time1
|
||||
|
||||
print*, ' providing u12sq_j1bsq_test ...'
|
||||
call wall_time(time0)
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
tmp_x = v_1b_grad(1,ipoint)
|
||||
tmp_y = v_1b_grad(2,ipoint)
|
||||
tmp_z = v_1b_grad(3,ipoint)
|
||||
tmp1 = -0.5d0 * (tmp_x * tmp_x + tmp_y * tmp_y + tmp_z * tmp_z)
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
u12sq_j1bsq_test(i,j,ipoint) = tmp1 * int2_u2_j1b2_test(i,j,ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(time1)
|
||||
print*, ' Wall time for u12sq_j1bsq_test = ', time1 - time0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, u12_grad1_u12_j1b_grad1_j1b_test, (ao_num, ao_num, n_points_final_grid) ]
|
||||
|
||||
implicit none
|
||||
integer :: ipoint, i, j, m, igauss
|
||||
double precision :: x, y, z
|
||||
double precision :: tmp_v, tmp_x, tmp_y, tmp_z
|
||||
double precision :: tmp3, tmp4, tmp5, tmp6, tmp7, tmp8, tmp9
|
||||
double precision :: time0, time1
|
||||
double precision, external :: overlap_gauss_r12_ao
|
||||
|
||||
print*, ' providing u12_grad1_u12_j1b_grad1_j1b_test ...'
|
||||
|
||||
provide int2_u_grad1u_x_j1b2_test
|
||||
call wall_time(time0)
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
x = final_grid_points(1,ipoint)
|
||||
y = final_grid_points(2,ipoint)
|
||||
z = final_grid_points(3,ipoint)
|
||||
tmp_v = v_1b (ipoint)
|
||||
tmp_x = v_1b_grad(1,ipoint)
|
||||
tmp_y = v_1b_grad(2,ipoint)
|
||||
tmp_z = v_1b_grad(3,ipoint)
|
||||
|
||||
tmp3 = tmp_v * tmp_x
|
||||
tmp4 = tmp_v * tmp_y
|
||||
tmp5 = tmp_v * tmp_z
|
||||
|
||||
tmp6 = -x * tmp3
|
||||
tmp7 = -y * tmp4
|
||||
tmp8 = -z * tmp5
|
||||
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
|
||||
tmp9 = int2_u_grad1u_j1b2_test(i,j,ipoint)
|
||||
|
||||
u12_grad1_u12_j1b_grad1_j1b_test(i,j,ipoint) = tmp6 * tmp9 + tmp3 * int2_u_grad1u_x_j1b2_test(i,j,ipoint,1) &
|
||||
+ tmp7 * tmp9 + tmp4 * int2_u_grad1u_x_j1b2_test(i,j,ipoint,2) &
|
||||
+ tmp8 * tmp9 + tmp5 * int2_u_grad1u_x_j1b2_test(i,j,ipoint,3)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(time1)
|
||||
print*, ' Wall time for u12_grad1_u12_j1b_grad1_j1b_test = ', time1 - time0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, grad12_j12_test, (ao_num, ao_num, n_points_final_grid) ]
|
||||
|
||||
implicit none
|
||||
integer :: ipoint, i, j, m, igauss
|
||||
double precision :: r(3), delta, coef
|
||||
double precision :: tmp1
|
||||
double precision :: time0, time1
|
||||
double precision, external :: overlap_gauss_r12_ao
|
||||
provide int2_grad1u2_grad2u2_j1b2_test
|
||||
print*, ' providing grad12_j12_test ...'
|
||||
call wall_time(time0)
|
||||
|
||||
PROVIDE j1b_type
|
||||
|
||||
if(j1b_type .eq. 3) then
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
tmp1 = v_1b(ipoint)
|
||||
tmp1 = tmp1 * tmp1
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
grad12_j12_test(i,j,ipoint) = tmp1 * int2_grad1u2_grad2u2_j1b2_test(i,j,ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
else
|
||||
|
||||
grad12_j12_test = 0.d0
|
||||
do ipoint = 1, n_points_final_grid
|
||||
r(1) = final_grid_points(1,ipoint)
|
||||
r(2) = final_grid_points(2,ipoint)
|
||||
r(3) = final_grid_points(3,ipoint)
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
do igauss = 1, n_max_fit_slat
|
||||
delta = expo_gauss_1_erf_x_2(igauss)
|
||||
coef = coef_gauss_1_erf_x_2(igauss)
|
||||
grad12_j12_test(i,j,ipoint) += -0.25d0 * coef * overlap_gauss_r12_ao(r, delta, i, j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
endif
|
||||
|
||||
call wall_time(time1)
|
||||
print*, ' Wall time for grad12_j12_test = ', time1 - time0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
217
src/non_h_ints_mu/grad_tc_int.irp.f
Normal file
217
src/non_h_ints_mu/grad_tc_int.irp.f
Normal file
@ -0,0 +1,217 @@
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, ao_non_hermit_term_chemist, (ao_num, ao_num, ao_num, ao_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
! 1 1 2 2 1 2 1 2
|
||||
!
|
||||
! ao_non_hermit_term_chemist(k,i,l,j) = < k l | [erf( mu r12) - 1] d/d_r12 | i j > on the AO basis
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, l, ipoint, m
|
||||
double precision :: weight1, r(3)
|
||||
double precision :: wall1, wall0
|
||||
double precision, allocatable :: b_mat(:,:,:,:), ac_mat(:,:,:,:)
|
||||
|
||||
provide v_ij_erf_rk_cst_mu x_v_ij_erf_rk_cst_mu
|
||||
|
||||
call wall_time(wall0)
|
||||
allocate(b_mat(n_points_final_grid,ao_num,ao_num,3), ac_mat(ao_num,ao_num,ao_num,ao_num))
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$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
|
||||
|
||||
! (A) b_mat(ipoint,k,i,m) X v_ij_erf_rk_cst_mu(j,l,r1)
|
||||
! 1/2 \int dr1 x1 phi_k(1) d/dx1 phi_i(1) \int dr2 (1 - erf(mu_r12))/r12 phi_j(2) phi_l(2)
|
||||
ac_mat = 0.d0
|
||||
do m = 1, 3
|
||||
! A B^T dim(A,1) dim(B,2) dim(A,2) alpha * A LDA
|
||||
|
||||
call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
|
||||
, v_ij_erf_rk_cst_mu(1,1,1), ao_num*ao_num, b_mat(1,1,1,m), n_points_final_grid &
|
||||
, 1.d0, ac_mat, ao_num*ao_num)
|
||||
|
||||
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
|
||||
|
||||
! (B) b_mat(ipoint,k,i,m) X x_v_ij_erf_rk_cst_mu(j,l,r1,m)
|
||||
! 1/2 \int dr1 phi_k(1) d/dx1 phi_i(1) \int dr2 x2(1 - erf(mu_r12))/r12 phi_j(2) phi_l(2)
|
||||
do m = 1, 3
|
||||
! A B^T dim(A,1) dim(B,2) dim(A,2) alpha * A LDA
|
||||
|
||||
call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, -1.d0 &
|
||||
, x_v_ij_erf_rk_cst_mu(1,1,1,m), ao_num*ao_num, b_mat(1,1,1,m), n_points_final_grid &
|
||||
, 1.d0, ac_mat, ao_num*ao_num)
|
||||
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
|
||||
! (ki|lj) (ki|lj) (lj|ki)
|
||||
ao_non_hermit_term_chemist(k,i,l,j) = ac_mat(k,i,l,j) + ac_mat(l,j,k,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time dgemm ', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
! TODO :: optimization :: transform into DGEM
|
||||
|
||||
BEGIN_PROVIDER [double precision, mo_non_hermit_term_chemist, (mo_num, mo_num, mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
! 1 1 2 2 1 2 1 2
|
||||
!
|
||||
! mo_non_hermit_term_chemist(k,i,l,j) = < k l | [erf( mu r12) - 1] d/d_r12 | i j > on the MO basis
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, l, m, n, p, q
|
||||
double precision, allocatable :: mo_tmp_1(:,:,:,:), mo_tmp_2(:,:,:,:)
|
||||
|
||||
allocate(mo_tmp_1(mo_num,ao_num,ao_num,ao_num))
|
||||
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
|
||||
deallocate(mo_tmp_1)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, mo_non_hermit_term, (mo_num, mo_num, mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
! 1 2 1 2 1 2 1 2
|
||||
!
|
||||
! mo_non_hermit_term(k,l,i,j) = < k l | [erf( mu r12) - 1] d/d_r12 | i j > on the MO basis
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, l
|
||||
|
||||
do j = 1, mo_num
|
||||
do i = 1, mo_num
|
||||
do l = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
mo_non_hermit_term(k,l,i,j) = mo_non_hermit_term_chemist(k,i,l,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
640
src/non_h_ints_mu/j12_nucl_utils.irp.f
Normal file
640
src/non_h_ints_mu/j12_nucl_utils.irp.f
Normal file
@ -0,0 +1,640 @@
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, v_1b, (n_points_final_grid)]
|
||||
|
||||
implicit none
|
||||
integer :: ipoint, i, j, phase
|
||||
double precision :: x, y, z, dx, dy, dz
|
||||
double precision :: a, d, e, fact_r
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
x = final_grid_points(1,ipoint)
|
||||
y = final_grid_points(2,ipoint)
|
||||
z = final_grid_points(3,ipoint)
|
||||
|
||||
fact_r = 1.d0
|
||||
do j = 1, nucl_num
|
||||
a = j1b_pen(j)
|
||||
dx = x - nucl_coord(j,1)
|
||||
dy = y - nucl_coord(j,2)
|
||||
dz = z - nucl_coord(j,3)
|
||||
d = dx*dx + dy*dy + dz*dz
|
||||
e = 1.d0 - dexp(-a*d)
|
||||
|
||||
fact_r = fact_r * e
|
||||
enddo
|
||||
|
||||
v_1b(ipoint) = fact_r
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, v_1b_grad, (3, n_points_final_grid)]
|
||||
|
||||
implicit none
|
||||
integer :: ipoint, i, j, phase
|
||||
double precision :: x, y, z, dx, dy, dz
|
||||
double precision :: a, d, e
|
||||
double precision :: fact_x, fact_y, fact_z
|
||||
double precision :: ax_der, ay_der, az_der, a_expo
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
x = final_grid_points(1,ipoint)
|
||||
y = final_grid_points(2,ipoint)
|
||||
z = final_grid_points(3,ipoint)
|
||||
|
||||
fact_x = 0.d0
|
||||
fact_y = 0.d0
|
||||
fact_z = 0.d0
|
||||
do i = 1, List_all_comb_b2_size
|
||||
|
||||
phase = 0
|
||||
a_expo = 0.d0
|
||||
ax_der = 0.d0
|
||||
ay_der = 0.d0
|
||||
az_der = 0.d0
|
||||
do j = 1, nucl_num
|
||||
a = dble(List_all_comb_b2(j,i)) * j1b_pen(j)
|
||||
dx = x - nucl_coord(j,1)
|
||||
dy = y - nucl_coord(j,2)
|
||||
dz = z - nucl_coord(j,3)
|
||||
|
||||
phase += List_all_comb_b2(j,i)
|
||||
a_expo += a * (dx*dx + dy*dy + dz*dz)
|
||||
ax_der += a * dx
|
||||
ay_der += a * dy
|
||||
az_der += a * dz
|
||||
enddo
|
||||
e = -2.d0 * (-1.d0)**dble(phase) * dexp(-a_expo)
|
||||
|
||||
fact_x += e * ax_der
|
||||
fact_y += e * ay_der
|
||||
fact_z += e * az_der
|
||||
enddo
|
||||
|
||||
v_1b_grad(1,ipoint) = fact_x
|
||||
v_1b_grad(2,ipoint) = fact_y
|
||||
v_1b_grad(3,ipoint) = fact_z
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, v_1b_lapl, (n_points_final_grid)]
|
||||
|
||||
implicit none
|
||||
integer :: ipoint, i, j, phase
|
||||
double precision :: x, y, z, dx, dy, dz
|
||||
double precision :: a, d, e, b
|
||||
double precision :: fact_r
|
||||
double precision :: ax_der, ay_der, az_der, a_expo
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
x = final_grid_points(1,ipoint)
|
||||
y = final_grid_points(2,ipoint)
|
||||
z = final_grid_points(3,ipoint)
|
||||
|
||||
fact_r = 0.d0
|
||||
do i = 1, List_all_comb_b2_size
|
||||
|
||||
phase = 0
|
||||
b = 0.d0
|
||||
a_expo = 0.d0
|
||||
ax_der = 0.d0
|
||||
ay_der = 0.d0
|
||||
az_der = 0.d0
|
||||
do j = 1, nucl_num
|
||||
a = dble(List_all_comb_b2(j,i)) * j1b_pen(j)
|
||||
dx = x - nucl_coord(j,1)
|
||||
dy = y - nucl_coord(j,2)
|
||||
dz = z - nucl_coord(j,3)
|
||||
|
||||
phase += List_all_comb_b2(j,i)
|
||||
b += a
|
||||
a_expo += a * (dx*dx + dy*dy + dz*dz)
|
||||
ax_der += a * dx
|
||||
ay_der += a * dy
|
||||
az_der += a * dz
|
||||
enddo
|
||||
|
||||
fact_r += (-1.d0)**dble(phase) * (-6.d0*b + 4.d0*(ax_der*ax_der + ay_der*ay_der + az_der*az_der) ) * dexp(-a_expo)
|
||||
enddo
|
||||
|
||||
v_1b_lapl(ipoint) = fact_r
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, v_1b_list_b2, (n_points_final_grid)]
|
||||
|
||||
implicit none
|
||||
integer :: i, ipoint
|
||||
double precision :: x, y, z, coef, expo, dx, dy, dz
|
||||
double precision :: fact_r
|
||||
|
||||
PROVIDE List_all_comb_b2_coef List_all_comb_b2_expo List_all_comb_b2_cent
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
x = final_grid_points(1,ipoint)
|
||||
y = final_grid_points(2,ipoint)
|
||||
z = final_grid_points(3,ipoint)
|
||||
|
||||
fact_r = 0.d0
|
||||
do i = 1, List_all_comb_b2_size
|
||||
|
||||
coef = List_all_comb_b2_coef(i)
|
||||
expo = List_all_comb_b2_expo(i)
|
||||
|
||||
dx = x - List_all_comb_b2_cent(1,i)
|
||||
dy = y - List_all_comb_b2_cent(2,i)
|
||||
dz = z - List_all_comb_b2_cent(3,i)
|
||||
|
||||
fact_r += coef * dexp(-expo * (dx*dx + dy*dy + dz*dz))
|
||||
enddo
|
||||
|
||||
v_1b_list_b2(ipoint) = fact_r
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, v_1b_list_b3, (n_points_final_grid)]
|
||||
|
||||
implicit none
|
||||
integer :: i, ipoint
|
||||
double precision :: x, y, z, coef, expo, dx, dy, dz
|
||||
double precision :: fact_r
|
||||
|
||||
PROVIDE List_all_comb_b3_coef List_all_comb_b3_expo List_all_comb_b3_cent
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
x = final_grid_points(1,ipoint)
|
||||
y = final_grid_points(2,ipoint)
|
||||
z = final_grid_points(3,ipoint)
|
||||
|
||||
fact_r = 0.d0
|
||||
do i = 1, List_all_comb_b3_size
|
||||
|
||||
coef = List_all_comb_b3_coef(i)
|
||||
expo = List_all_comb_b3_expo(i)
|
||||
|
||||
dx = x - List_all_comb_b3_cent(1,i)
|
||||
dy = y - List_all_comb_b3_cent(2,i)
|
||||
dz = z - List_all_comb_b3_cent(3,i)
|
||||
|
||||
fact_r += coef * dexp(-expo * (dx*dx + dy*dy + dz*dz))
|
||||
enddo
|
||||
|
||||
v_1b_list_b3(ipoint) = fact_r
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
double precision function jmu_modif(r1, r2)
|
||||
|
||||
implicit none
|
||||
double precision, intent(in) :: r1(3), r2(3)
|
||||
double precision, external :: j12_mu, j12_nucl
|
||||
|
||||
jmu_modif = j12_mu(r1, r2) * j12_nucl(r1, r2)
|
||||
|
||||
return
|
||||
end function jmu_modif
|
||||
|
||||
! ---
|
||||
|
||||
double precision function j12_mu(r1, r2)
|
||||
|
||||
include 'constants.include.F'
|
||||
|
||||
implicit none
|
||||
double precision, intent(in) :: r1(3), r2(3)
|
||||
double precision :: mu_r12, r12
|
||||
|
||||
r12 = dsqrt( (r1(1) - r2(1)) * (r1(1) - r2(1)) &
|
||||
+ (r1(2) - r2(2)) * (r1(2) - r2(2)) &
|
||||
+ (r1(3) - r2(3)) * (r1(3) - r2(3)) )
|
||||
mu_r12 = mu_erf * r12
|
||||
|
||||
j12_mu = 0.5d0 * r12 * (1.d0 - derf(mu_r12)) - inv_sq_pi_2 * dexp(-mu_r12*mu_r12) / mu_erf
|
||||
|
||||
return
|
||||
end function j12_mu
|
||||
|
||||
! ---
|
||||
|
||||
double precision function j12_mu_r12(r12)
|
||||
|
||||
include 'constants.include.F'
|
||||
|
||||
implicit none
|
||||
double precision, intent(in) :: r12
|
||||
double precision :: mu_r12
|
||||
|
||||
mu_r12 = mu_erf * r12
|
||||
|
||||
j12_mu_r12 = 0.5d0 * r12 * (1.d0 - derf(mu_r12)) - inv_sq_pi_2 * dexp(-mu_r12*mu_r12) / mu_erf
|
||||
|
||||
return
|
||||
end function j12_mu_r12
|
||||
|
||||
! ---
|
||||
|
||||
double precision function j12_mu_gauss(r1, r2)
|
||||
|
||||
implicit none
|
||||
double precision, intent(in) :: r1(3), r2(3)
|
||||
integer :: i
|
||||
double precision :: r12, coef, expo
|
||||
|
||||
r12 = (r1(1) - r2(1)) * (r1(1) - r2(1)) &
|
||||
+ (r1(2) - r2(2)) * (r1(2) - r2(2)) &
|
||||
+ (r1(3) - r2(3)) * (r1(3) - r2(3))
|
||||
|
||||
j12_mu_gauss = 0.d0
|
||||
do i = 1, n_max_fit_slat
|
||||
expo = expo_gauss_j_mu_x(i)
|
||||
coef = coef_gauss_j_mu_x(i)
|
||||
|
||||
j12_mu_gauss += coef * dexp(-expo*r12)
|
||||
enddo
|
||||
|
||||
return
|
||||
end function j12_mu_gauss
|
||||
|
||||
! ---
|
||||
|
||||
double precision function j1b_nucl(r)
|
||||
|
||||
implicit none
|
||||
double precision, intent(in) :: r(3)
|
||||
integer :: i
|
||||
double precision :: a, d, e
|
||||
|
||||
j1b_nucl = 1.d0
|
||||
|
||||
do i = 1, nucl_num
|
||||
a = j1b_pen(i)
|
||||
d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
|
||||
+ (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
|
||||
+ (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
|
||||
e = 1.d0 - exp(-a*d)
|
||||
|
||||
j1b_nucl = j1b_nucl * e
|
||||
enddo
|
||||
|
||||
return
|
||||
end function j1b_nucl
|
||||
|
||||
! ---
|
||||
|
||||
double precision function j12_nucl(r1, r2)
|
||||
|
||||
implicit none
|
||||
double precision, intent(in) :: r1(3), r2(3)
|
||||
double precision, external :: j1b_nucl
|
||||
|
||||
j12_nucl = j1b_nucl(r1) * j1b_nucl(r2)
|
||||
|
||||
return
|
||||
end function j12_nucl
|
||||
|
||||
! ---
|
||||
|
||||
! ---------------------------------------------------------------------------------------
|
||||
|
||||
double precision function grad_x_j1b_nucl(r)
|
||||
|
||||
implicit none
|
||||
double precision, intent(in) :: r(3)
|
||||
double precision :: r_eps(3), eps, fp, fm, delta
|
||||
double precision, external :: j1b_nucl
|
||||
|
||||
eps = 1d-6
|
||||
r_eps = r
|
||||
delta = max(eps, dabs(eps*r(1)))
|
||||
|
||||
r_eps(1) = r_eps(1) + delta
|
||||
fp = j1b_nucl(r_eps)
|
||||
r_eps(1) = r_eps(1) - 2.d0 * delta
|
||||
fm = j1b_nucl(r_eps)
|
||||
|
||||
grad_x_j1b_nucl = 0.5d0 * (fp - fm) / delta
|
||||
|
||||
return
|
||||
end function grad_x_j1b_nucl
|
||||
|
||||
double precision function grad_y_j1b_nucl(r)
|
||||
|
||||
implicit none
|
||||
double precision, intent(in) :: r(3)
|
||||
double precision :: r_eps(3), eps, fp, fm, delta
|
||||
double precision, external :: j1b_nucl
|
||||
|
||||
eps = 1d-6
|
||||
r_eps = r
|
||||
delta = max(eps, dabs(eps*r(2)))
|
||||
|
||||
r_eps(2) = r_eps(2) + delta
|
||||
fp = j1b_nucl(r_eps)
|
||||
r_eps(2) = r_eps(2) - 2.d0 * delta
|
||||
fm = j1b_nucl(r_eps)
|
||||
|
||||
grad_y_j1b_nucl = 0.5d0 * (fp - fm) / delta
|
||||
|
||||
return
|
||||
end function grad_y_j1b_nucl
|
||||
|
||||
double precision function grad_z_j1b_nucl(r)
|
||||
|
||||
implicit none
|
||||
double precision, intent(in) :: r(3)
|
||||
double precision :: r_eps(3), eps, fp, fm, delta
|
||||
double precision, external :: j1b_nucl
|
||||
|
||||
eps = 1d-6
|
||||
r_eps = r
|
||||
delta = max(eps, dabs(eps*r(3)))
|
||||
|
||||
r_eps(3) = r_eps(3) + delta
|
||||
fp = j1b_nucl(r_eps)
|
||||
r_eps(3) = r_eps(3) - 2.d0 * delta
|
||||
fm = j1b_nucl(r_eps)
|
||||
|
||||
grad_z_j1b_nucl = 0.5d0 * (fp - fm) / delta
|
||||
|
||||
return
|
||||
end function grad_z_j1b_nucl
|
||||
|
||||
! ---------------------------------------------------------------------------------------
|
||||
|
||||
! ---
|
||||
|
||||
double precision function lapl_j1b_nucl(r)
|
||||
|
||||
implicit none
|
||||
double precision, intent(in) :: r(3)
|
||||
double precision :: r_eps(3), eps, fp, fm, delta
|
||||
double precision, external :: grad_x_j1b_nucl
|
||||
double precision, external :: grad_y_j1b_nucl
|
||||
double precision, external :: grad_z_j1b_nucl
|
||||
|
||||
eps = 1d-5
|
||||
r_eps = r
|
||||
|
||||
lapl_j1b_nucl = 0.d0
|
||||
|
||||
! ---
|
||||
|
||||
delta = max(eps, dabs(eps*r(1)))
|
||||
r_eps(1) = r_eps(1) + delta
|
||||
fp = grad_x_j1b_nucl(r_eps)
|
||||
r_eps(1) = r_eps(1) - 2.d0 * delta
|
||||
fm = grad_x_j1b_nucl(r_eps)
|
||||
r_eps(1) = r_eps(1) + delta
|
||||
|
||||
lapl_j1b_nucl += 0.5d0 * (fp - fm) / delta
|
||||
|
||||
! ---
|
||||
|
||||
delta = max(eps, dabs(eps*r(2)))
|
||||
r_eps(2) = r_eps(2) + delta
|
||||
fp = grad_y_j1b_nucl(r_eps)
|
||||
r_eps(2) = r_eps(2) - 2.d0 * delta
|
||||
fm = grad_y_j1b_nucl(r_eps)
|
||||
r_eps(2) = r_eps(2) + delta
|
||||
|
||||
lapl_j1b_nucl += 0.5d0 * (fp - fm) / delta
|
||||
|
||||
! ---
|
||||
|
||||
delta = max(eps, dabs(eps*r(3)))
|
||||
r_eps(3) = r_eps(3) + delta
|
||||
fp = grad_z_j1b_nucl(r_eps)
|
||||
r_eps(3) = r_eps(3) - 2.d0 * delta
|
||||
fm = grad_z_j1b_nucl(r_eps)
|
||||
r_eps(3) = r_eps(3) + delta
|
||||
|
||||
lapl_j1b_nucl += 0.5d0 * (fp - fm) / delta
|
||||
|
||||
! ---
|
||||
|
||||
return
|
||||
end function lapl_j1b_nucl
|
||||
|
||||
! ---
|
||||
|
||||
! ---------------------------------------------------------------------------------------
|
||||
|
||||
double precision function grad1_x_jmu_modif(r1, r2)
|
||||
|
||||
implicit none
|
||||
double precision, intent(in) :: r1(3), r2(3)
|
||||
double precision :: r1_eps(3), eps, fp, fm, delta
|
||||
double precision, external :: jmu_modif
|
||||
|
||||
eps = 1d-7
|
||||
r1_eps = r1
|
||||
delta = max(eps, dabs(eps*r1(1)))
|
||||
|
||||
r1_eps(1) = r1_eps(1) + delta
|
||||
fp = jmu_modif(r1_eps, r2)
|
||||
r1_eps(1) = r1_eps(1) - 2.d0 * delta
|
||||
fm = jmu_modif(r1_eps, r2)
|
||||
|
||||
grad1_x_jmu_modif = 0.5d0 * (fp - fm) / delta
|
||||
|
||||
return
|
||||
end function grad1_x_jmu_modif
|
||||
|
||||
double precision function grad1_y_jmu_modif(r1, r2)
|
||||
|
||||
implicit none
|
||||
double precision, intent(in) :: r1(3), r2(3)
|
||||
double precision :: r1_eps(3), eps, fp, fm, delta
|
||||
double precision, external :: jmu_modif
|
||||
|
||||
eps = 1d-7
|
||||
r1_eps = r1
|
||||
delta = max(eps, dabs(eps*r1(2)))
|
||||
|
||||
r1_eps(2) = r1_eps(2) + delta
|
||||
fp = jmu_modif(r1_eps, r2)
|
||||
r1_eps(2) = r1_eps(2) - 2.d0 * delta
|
||||
fm = jmu_modif(r1_eps, r2)
|
||||
|
||||
grad1_y_jmu_modif = 0.5d0 * (fp - fm) / delta
|
||||
|
||||
return
|
||||
end function grad1_y_jmu_modif
|
||||
|
||||
double precision function grad1_z_jmu_modif(r1, r2)
|
||||
|
||||
implicit none
|
||||
double precision, intent(in) :: r1(3), r2(3)
|
||||
double precision :: r1_eps(3), eps, fp, fm, delta
|
||||
double precision, external :: jmu_modif
|
||||
|
||||
eps = 1d-7
|
||||
r1_eps = r1
|
||||
delta = max(eps, dabs(eps*r1(3)))
|
||||
|
||||
r1_eps(3) = r1_eps(3) + delta
|
||||
fp = jmu_modif(r1_eps, r2)
|
||||
r1_eps(3) = r1_eps(3) - 2.d0 * delta
|
||||
fm = jmu_modif(r1_eps, r2)
|
||||
|
||||
grad1_z_jmu_modif = 0.5d0 * (fp - fm) / delta
|
||||
|
||||
return
|
||||
end function grad1_z_jmu_modif
|
||||
|
||||
! ---------------------------------------------------------------------------------------
|
||||
|
||||
! ---
|
||||
|
||||
! ---------------------------------------------------------------------------------------
|
||||
|
||||
double precision function grad1_x_j12_mu_num(r1, r2)
|
||||
|
||||
implicit none
|
||||
double precision, intent(in) :: r1(3), r2(3)
|
||||
double precision :: r1_eps(3), eps, fp, fm, delta
|
||||
double precision, external :: j12_mu
|
||||
|
||||
eps = 1d-7
|
||||
r1_eps = r1
|
||||
delta = max(eps, dabs(eps*r1(1)))
|
||||
|
||||
r1_eps(1) = r1_eps(1) + delta
|
||||
fp = j12_mu(r1_eps, r2)
|
||||
r1_eps(1) = r1_eps(1) - 2.d0 * delta
|
||||
fm = j12_mu(r1_eps, r2)
|
||||
|
||||
grad1_x_j12_mu_num = 0.5d0 * (fp - fm) / delta
|
||||
|
||||
return
|
||||
end function grad1_x_j12_mu_num
|
||||
|
||||
double precision function grad1_y_j12_mu_num(r1, r2)
|
||||
|
||||
implicit none
|
||||
double precision, intent(in) :: r1(3), r2(3)
|
||||
double precision :: r1_eps(3), eps, fp, fm, delta
|
||||
double precision, external :: j12_mu
|
||||
|
||||
eps = 1d-7
|
||||
r1_eps = r1
|
||||
delta = max(eps, dabs(eps*r1(2)))
|
||||
|
||||
r1_eps(2) = r1_eps(2) + delta
|
||||
fp = j12_mu(r1_eps, r2)
|
||||
r1_eps(2) = r1_eps(2) - 2.d0 * delta
|
||||
fm = j12_mu(r1_eps, r2)
|
||||
|
||||
grad1_y_j12_mu_num = 0.5d0 * (fp - fm) / delta
|
||||
|
||||
return
|
||||
end function grad1_y_j12_mu_num
|
||||
|
||||
double precision function grad1_z_j12_mu_num(r1, r2)
|
||||
|
||||
implicit none
|
||||
double precision, intent(in) :: r1(3), r2(3)
|
||||
double precision :: r1_eps(3), eps, fp, fm, delta
|
||||
double precision, external :: j12_mu
|
||||
|
||||
eps = 1d-7
|
||||
r1_eps = r1
|
||||
delta = max(eps, dabs(eps*r1(3)))
|
||||
|
||||
r1_eps(3) = r1_eps(3) + delta
|
||||
fp = j12_mu(r1_eps, r2)
|
||||
r1_eps(3) = r1_eps(3) - 2.d0 * delta
|
||||
fm = j12_mu(r1_eps, r2)
|
||||
|
||||
grad1_z_j12_mu_num = 0.5d0 * (fp - fm) / delta
|
||||
|
||||
return
|
||||
end function grad1_z_j12_mu_num
|
||||
|
||||
! ---------------------------------------------------------------------------------------
|
||||
|
||||
! ---
|
||||
|
||||
subroutine grad1_j12_mu_exc(r1, r2, grad)
|
||||
|
||||
implicit none
|
||||
double precision, intent(in) :: r1(3), r2(3)
|
||||
double precision, intent(out) :: grad(3)
|
||||
double precision :: dx, dy, dz, r12, tmp
|
||||
|
||||
grad = 0.d0
|
||||
|
||||
dx = r1(1) - r2(1)
|
||||
dy = r1(2) - r2(2)
|
||||
dz = r1(3) - r2(3)
|
||||
|
||||
r12 = dsqrt( dx * dx + dy * dy + dz * dz )
|
||||
if(r12 .lt. 1d-10) return
|
||||
|
||||
tmp = 0.5d0 * (1.d0 - derf(mu_erf * r12)) / r12
|
||||
|
||||
grad(1) = tmp * dx
|
||||
grad(2) = tmp * dy
|
||||
grad(3) = tmp * dz
|
||||
|
||||
return
|
||||
end subroutine grad1_j12_mu_exc
|
||||
|
||||
! ---
|
||||
|
||||
subroutine grad1_jmu_modif_num(r1, r2, grad)
|
||||
|
||||
implicit none
|
||||
|
||||
double precision, intent(in) :: r1(3), r2(3)
|
||||
double precision, intent(out) :: grad(3)
|
||||
|
||||
double precision :: tmp0, tmp1, tmp2, tmp3, tmp4, grad_u12(3)
|
||||
|
||||
double precision, external :: j12_mu
|
||||
double precision, external :: j1b_nucl
|
||||
double precision, external :: grad_x_j1b_nucl
|
||||
double precision, external :: grad_y_j1b_nucl
|
||||
double precision, external :: grad_z_j1b_nucl
|
||||
|
||||
call grad1_j12_mu_exc(r1, r2, grad_u12)
|
||||
|
||||
tmp0 = j1b_nucl(r1)
|
||||
tmp1 = j1b_nucl(r2)
|
||||
tmp2 = j12_mu(r1, r2)
|
||||
tmp3 = tmp0 * tmp1
|
||||
tmp4 = tmp2 * tmp1
|
||||
|
||||
grad(1) = tmp3 * grad_u12(1) + tmp4 * grad_x_j1b_nucl(r1)
|
||||
grad(2) = tmp3 * grad_u12(2) + tmp4 * grad_y_j1b_nucl(r1)
|
||||
grad(3) = tmp3 * grad_u12(3) + tmp4 * grad_z_j1b_nucl(r1)
|
||||
|
||||
return
|
||||
end subroutine grad1_jmu_modif_num
|
||||
|
||||
! ---
|
||||
|
||||
|
||||
|
||||
|
||||
360
src/non_h_ints_mu/new_grad_tc.irp.f
Normal file
360
src/non_h_ints_mu/new_grad_tc.irp.f
Normal file
@ -0,0 +1,360 @@
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao, (ao_num, ao_num, n_points_final_grid, 3)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! int2_grad1_u12_ao(i,j,ipoint,:) = \int dr2 [-1 * \grad_r1 J(r1,r2)] \phi_i(r2) \phi_j(r2)
|
||||
!
|
||||
! where r1 = r(ipoint)
|
||||
!
|
||||
! if J(r1,r2) = u12:
|
||||
!
|
||||
! int2_grad1_u12_ao(i,j,ipoint,:) = 0.5 x \int dr2 [(r1 - r2) (erf(mu * r12)-1)r_12] \phi_i(r2) \phi_j(r2)
|
||||
! = 0.5 * [ v_ij_erf_rk_cst_mu(i,j,ipoint) * r(:) - x_v_ij_erf_rk_cst_mu(i,j,ipoint,:) ]
|
||||
!
|
||||
! if J(r1,r2) = u12 x v1 x v2
|
||||
!
|
||||
! int2_grad1_u12_ao(i,j,ipoint,:) = v1 x [ 0.5 x \int dr2 [(r1 - r2) (erf(mu * r12)-1)r_12] v2 \phi_i(r2) \phi_j(r2) ]
|
||||
! - \grad_1 v1 x [ \int dr2 u12 v2 \phi_i(r2) \phi_j(r2) ]
|
||||
! = 0.5 v_1b(ipoint) * v_ij_erf_rk_cst_mu_j1b(i,j,ipoint) * r(:)
|
||||
! - 0.5 v_1b(ipoint) * x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,:)
|
||||
! - v_1b_grad[:,ipoint] * v_ij_u_cst_mu_j1b(i,j,ipoint)
|
||||
!
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: ipoint, i, j
|
||||
double precision :: time0, time1
|
||||
double precision :: x, y, z, tmp_x, tmp_y, tmp_z, tmp0, tmp1, tmp2
|
||||
|
||||
print*, ' providing int2_grad1_u12_ao ...'
|
||||
call wall_time(time0)
|
||||
|
||||
PROVIDE j1b_type
|
||||
|
||||
if(j1b_type .eq. 3) then
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
x = final_grid_points(1,ipoint)
|
||||
y = final_grid_points(2,ipoint)
|
||||
z = final_grid_points(3,ipoint)
|
||||
|
||||
tmp0 = 0.5d0 * v_1b(ipoint)
|
||||
tmp_x = v_1b_grad(1,ipoint)
|
||||
tmp_y = v_1b_grad(2,ipoint)
|
||||
tmp_z = v_1b_grad(3,ipoint)
|
||||
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
|
||||
tmp1 = tmp0 * v_ij_erf_rk_cst_mu_j1b(i,j,ipoint)
|
||||
tmp2 = v_ij_u_cst_mu_j1b(i,j,ipoint)
|
||||
|
||||
int2_grad1_u12_ao(i,j,ipoint,1) = tmp1 * x - tmp0 * x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,1) - tmp2 * tmp_x
|
||||
int2_grad1_u12_ao(i,j,ipoint,2) = tmp1 * y - tmp0 * x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,2) - tmp2 * tmp_y
|
||||
int2_grad1_u12_ao(i,j,ipoint,3) = tmp1 * z - tmp0 * x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,3) - tmp2 * tmp_z
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
else
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
x = final_grid_points(1,ipoint)
|
||||
y = final_grid_points(2,ipoint)
|
||||
z = final_grid_points(3,ipoint)
|
||||
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
tmp1 = v_ij_erf_rk_cst_mu(i,j,ipoint)
|
||||
|
||||
int2_grad1_u12_ao(i,j,ipoint,1) = tmp1 * x - x_v_ij_erf_rk_cst_mu_transp_bis(ipoint,i,j,1)
|
||||
int2_grad1_u12_ao(i,j,ipoint,2) = tmp1 * y - x_v_ij_erf_rk_cst_mu_transp_bis(ipoint,i,j,2)
|
||||
int2_grad1_u12_ao(i,j,ipoint,3) = tmp1 * z - x_v_ij_erf_rk_cst_mu_transp_bis(ipoint,i,j,3)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
int2_grad1_u12_ao *= 0.5d0
|
||||
|
||||
endif
|
||||
|
||||
call wall_time(time1)
|
||||
print*, ' Wall time for int2_grad1_u12_ao = ', time1 - time0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, int1_grad2_u12_ao, (3, ao_num, ao_num, n_points_final_grid)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! int1_grad2_u12_ao(:,i,j,ipoint) = \int dr1 [-1 * \grad_r2 J(r1,r2)] \phi_i(r1) \phi_j(r1)
|
||||
!
|
||||
! where r1 = r(ipoint)
|
||||
!
|
||||
! if J(r1,r2) = u12:
|
||||
!
|
||||
! int1_grad2_u12_ao(:,i,j,ipoint) = +0.5 x \int dr1 [-(r1 - r2) (erf(mu * r12)-1)r_12] \phi_i(r1) \phi_j(r1)
|
||||
! = -0.5 * [ v_ij_erf_rk_cst_mu(i,j,ipoint) * r(:) - x_v_ij_erf_rk_cst_mu(i,j,ipoint,:) ]
|
||||
! = -int2_grad1_u12_ao(i,j,ipoint,:)
|
||||
!
|
||||
! if J(r1,r2) = u12 x v1 x v2
|
||||
!
|
||||
! int1_grad2_u12_ao(:,i,j,ipoint) = v2 x [ 0.5 x \int dr1 [-(r1 - r2) (erf(mu * r12)-1)r_12] v1 \phi_i(r1) \phi_j(r1) ]
|
||||
! - \grad_2 v2 x [ \int dr1 u12 v1 \phi_i(r1) \phi_j(r1) ]
|
||||
! = -0.5 v_1b(ipoint) * v_ij_erf_rk_cst_mu_j1b(i,j,ipoint) * r(:)
|
||||
! + 0.5 v_1b(ipoint) * x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,:)
|
||||
! - v_1b_grad[:,ipoint] * v_ij_u_cst_mu_j1b(i,j,ipoint)
|
||||
!
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: ipoint, i, j
|
||||
double precision :: x, y, z, tmp_x, tmp_y, tmp_z, tmp0, tmp1, tmp2
|
||||
|
||||
PROVIDE j1b_type
|
||||
|
||||
if(j1b_type .eq. 3) then
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
x = final_grid_points(1,ipoint)
|
||||
y = final_grid_points(2,ipoint)
|
||||
z = final_grid_points(3,ipoint)
|
||||
|
||||
tmp0 = 0.5d0 * v_1b(ipoint)
|
||||
tmp_x = v_1b_grad(1,ipoint)
|
||||
tmp_y = v_1b_grad(2,ipoint)
|
||||
tmp_z = v_1b_grad(3,ipoint)
|
||||
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
|
||||
tmp1 = tmp0 * v_ij_erf_rk_cst_mu_j1b(i,j,ipoint)
|
||||
tmp2 = v_ij_u_cst_mu_j1b(i,j,ipoint)
|
||||
|
||||
int1_grad2_u12_ao(1,i,j,ipoint) = -tmp1 * x + tmp0 * x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,1) - tmp2 * tmp_x
|
||||
int1_grad2_u12_ao(2,i,j,ipoint) = -tmp1 * y + tmp0 * x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,2) - tmp2 * tmp_y
|
||||
int1_grad2_u12_ao(3,i,j,ipoint) = -tmp1 * z + tmp0 * x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,3) - tmp2 * tmp_z
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
else
|
||||
|
||||
int1_grad2_u12_ao = -1.d0 * int2_grad1_u12_ao
|
||||
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, tc_grad_and_lapl_ao_loop, (ao_num, ao_num, ao_num, ao_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! tc_grad_and_lapl_ao_loop(k,i,l,j) = < k l | -1/2 \Delta_1 u(r1,r2) - \grad_1 u(r1,r2) . \grad_1 | ij >
|
||||
!
|
||||
! = 1/2 \int dr1 (phi_k(r1) \grad_r1 phi_i(r1) - phi_i(r1) \grad_r1 phi_k(r1)) . \int dr2 \grad_r1 u(r1,r2) \phi_l(r2) \phi_j(r2)
|
||||
!
|
||||
! This is obtained by integration by parts.
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: ipoint, i, j, k, l
|
||||
double precision :: weight1, contrib_x, contrib_y, contrib_z, tmp_x, tmp_y, tmp_z
|
||||
double precision :: ao_k_r, ao_i_r, ao_i_dx, ao_i_dy, ao_i_dz
|
||||
double precision :: ao_j_r, ao_l_r, ao_l_dx, ao_l_dy, ao_l_dz
|
||||
double precision :: time0, time1
|
||||
double precision, allocatable :: ac_mat(:,:,:,:)
|
||||
|
||||
print*, ' providing tc_grad_and_lapl_ao_loop ...'
|
||||
call wall_time(time0)
|
||||
|
||||
allocate(ac_mat(ao_num,ao_num,ao_num,ao_num))
|
||||
ac_mat = 0.d0
|
||||
|
||||
! ---
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
weight1 = 0.5d0 * final_weight_at_r_vector(ipoint)
|
||||
|
||||
do i = 1, ao_num
|
||||
!ao_i_r = weight1 * aos_in_r_array_transp (ipoint,i)
|
||||
!ao_i_dx = weight1 * aos_grad_in_r_array_transp_bis(ipoint,i,1)
|
||||
!ao_i_dy = weight1 * aos_grad_in_r_array_transp_bis(ipoint,i,2)
|
||||
!ao_i_dz = weight1 * aos_grad_in_r_array_transp_bis(ipoint,i,3)
|
||||
ao_i_r = weight1 * aos_in_r_array (i,ipoint)
|
||||
ao_i_dx = weight1 * aos_grad_in_r_array(i,ipoint,1)
|
||||
ao_i_dy = weight1 * aos_grad_in_r_array(i,ipoint,2)
|
||||
ao_i_dz = weight1 * aos_grad_in_r_array(i,ipoint,3)
|
||||
|
||||
do k = 1, ao_num
|
||||
!ao_k_r = aos_in_r_array_transp(ipoint,k)
|
||||
ao_k_r = aos_in_r_array(k,ipoint)
|
||||
|
||||
!tmp_x = ao_k_r * ao_i_dx - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,1)
|
||||
!tmp_y = ao_k_r * ao_i_dy - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,2)
|
||||
!tmp_z = ao_k_r * ao_i_dz - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,3)
|
||||
tmp_x = ao_k_r * ao_i_dx - ao_i_r * aos_grad_in_r_array(k,ipoint,1)
|
||||
tmp_y = ao_k_r * ao_i_dy - ao_i_r * aos_grad_in_r_array(k,ipoint,2)
|
||||
tmp_z = ao_k_r * ao_i_dz - ao_i_r * aos_grad_in_r_array(k,ipoint,3)
|
||||
|
||||
do j = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
|
||||
contrib_x = int2_grad1_u12_ao(l,j,ipoint,1) * tmp_x
|
||||
contrib_y = int2_grad1_u12_ao(l,j,ipoint,2) * tmp_y
|
||||
contrib_z = int2_grad1_u12_ao(l,j,ipoint,3) * tmp_z
|
||||
|
||||
ac_mat(k,i,l,j) += contrib_x + contrib_y + contrib_z
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
!do ipoint = 1, n_points_final_grid
|
||||
! weight1 = 0.5d0 * final_weight_at_r_vector(ipoint)
|
||||
|
||||
! do l = 1, ao_num
|
||||
! ao_l_r = weight1 * aos_in_r_array_transp (ipoint,l)
|
||||
! ao_l_dx = weight1 * aos_grad_in_r_array_transp_bis(ipoint,l,1)
|
||||
! ao_l_dy = weight1 * aos_grad_in_r_array_transp_bis(ipoint,l,2)
|
||||
! ao_l_dz = weight1 * aos_grad_in_r_array_transp_bis(ipoint,l,3)
|
||||
|
||||
! do j = 1, ao_num
|
||||
! ao_j_r = aos_in_r_array_transp(ipoint,j)
|
||||
|
||||
! tmp_x = ao_j_r * ao_l_dx - ao_l_r * aos_grad_in_r_array_transp_bis(ipoint,j,1)
|
||||
! tmp_y = ao_j_r * ao_l_dy - ao_l_r * aos_grad_in_r_array_transp_bis(ipoint,j,2)
|
||||
! tmp_z = ao_j_r * ao_l_dz - ao_l_r * aos_grad_in_r_array_transp_bis(ipoint,j,3)
|
||||
|
||||
! do i = 1, ao_num
|
||||
! do k = 1, ao_num
|
||||
|
||||
! contrib_x = int2_grad1_u12_ao(k,i,ipoint,1) * tmp_x
|
||||
! contrib_y = int2_grad1_u12_ao(k,i,ipoint,2) * tmp_y
|
||||
! contrib_z = int2_grad1_u12_ao(k,i,ipoint,3) * tmp_z
|
||||
|
||||
! ac_mat(k,i,l,j) += contrib_x + contrib_y + contrib_z
|
||||
! enddo
|
||||
! enddo
|
||||
! enddo
|
||||
! enddo
|
||||
!enddo
|
||||
|
||||
! ---
|
||||
|
||||
do j = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
tc_grad_and_lapl_ao_loop(k,i,l,j) = ac_mat(k,i,l,j) + ac_mat(l,j,k,i)
|
||||
!tc_grad_and_lapl_ao_loop(k,i,l,j) = ac_mat(k,i,l,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
deallocate(ac_mat)
|
||||
|
||||
call wall_time(time1)
|
||||
print*, ' Wall time for tc_grad_and_lapl_ao_loop = ', time1 - time0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, tc_grad_and_lapl_ao, (ao_num, ao_num, ao_num, ao_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! tc_grad_and_lapl_ao(k,i,l,j) = < k l | -1/2 \Delta_1 u(r1,r2) - \grad_1 u(r1,r2) . \grad_1 | ij >
|
||||
!
|
||||
! = 1/2 \int dr1 (phi_k(r1) \grad_r1 phi_i(r1) - phi_i(r1) \grad_r1 phi_k(r1)) . \int dr2 \grad_r1 u(r1,r2) \phi_l(r2) \phi_j(r2)
|
||||
!
|
||||
! This is obtained by integration by parts.
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: ipoint, i, j, k, l, m
|
||||
double precision :: weight1, ao_k_r, ao_i_r
|
||||
double precision :: time0, time1
|
||||
double precision, allocatable :: ac_mat(:,:,:,:), b_mat(:,:,:,:)
|
||||
|
||||
print*, ' providing tc_grad_and_lapl_ao ...'
|
||||
call wall_time(time0)
|
||||
|
||||
allocate(b_mat(n_points_final_grid,ao_num,ao_num,3), ac_mat(ao_num,ao_num,ao_num,ao_num))
|
||||
|
||||
b_mat = 0.d0
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i, k, ipoint, weight1, ao_i_r, ao_k_r) &
|
||||
!$OMP SHARED (aos_in_r_array_transp, aos_grad_in_r_array_transp_bis, b_mat, &
|
||||
!$OMP ao_num, n_points_final_grid, final_weight_at_r_vector)
|
||||
!$OMP DO SCHEDULE (static)
|
||||
do i = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
weight1 = 0.5d0 * final_weight_at_r_vector(ipoint)
|
||||
ao_i_r = aos_in_r_array_transp(ipoint,i)
|
||||
ao_k_r = aos_in_r_array_transp(ipoint,k)
|
||||
|
||||
b_mat(ipoint,k,i,1) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,1) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,1))
|
||||
b_mat(ipoint,k,i,2) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,2) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,2))
|
||||
b_mat(ipoint,k,i,3) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,3) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,3))
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
ac_mat = 0.d0
|
||||
do m = 1, 3
|
||||
call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
|
||||
, int2_grad1_u12_ao(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
|
||||
deallocate(b_mat)
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i, j, k, l) &
|
||||
!$OMP SHARED (ac_mat, tc_grad_and_lapl_ao, ao_num)
|
||||
!$OMP DO SCHEDULE (static)
|
||||
do j = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
tc_grad_and_lapl_ao(k,i,l,j) = ac_mat(k,i,l,j) + ac_mat(l,j,k,i)
|
||||
!tc_grad_and_lapl_ao(k,i,l,j) = ac_mat(k,i,l,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
deallocate(ac_mat)
|
||||
|
||||
call wall_time(time1)
|
||||
print*, ' Wall time for tc_grad_and_lapl_ao = ', time1 - time0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
|
||||
174
src/non_h_ints_mu/new_grad_tc_manu.irp.f
Normal file
174
src/non_h_ints_mu/new_grad_tc_manu.irp.f
Normal file
@ -0,0 +1,174 @@
|
||||
|
||||
BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_test, (ao_num, ao_num, n_points_final_grid, 3)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! int2_grad1_u12_ao_test(i,j,ipoint,:) = \int dr2 [-1 * \grad_r1 J(r1,r2)] \phi_i(r2) \phi_j(r2)
|
||||
!
|
||||
! where r1 = r(ipoint)
|
||||
!
|
||||
! if J(r1,r2) = u12:
|
||||
!
|
||||
! int2_grad1_u12_ao_test(i,j,ipoint,:) = 0.5 x \int dr2 [(r1 - r2) (erf(mu * r12)-1)r_12] \phi_i(r2) \phi_j(r2)
|
||||
! = 0.5 * [ v_ij_erf_rk_cst_mu(i,j,ipoint) * r(:) - x_v_ij_erf_rk_cst_mu(i,j,ipoint,:) ]
|
||||
!
|
||||
! if J(r1,r2) = u12 x v1 x v2
|
||||
!
|
||||
! int2_grad1_u12_ao_test(i,j,ipoint,:) = v1 x [ 0.5 x \int dr2 [(r1 - r2) (erf(mu * r12)-1)r_12] v2 \phi_i(r2) \phi_j(r2) ]
|
||||
! - \grad_1 v1 x [ \int dr2 u12 v2 \phi_i(r2) \phi_j(r2) ]
|
||||
! = 0.5 v_1b(ipoint) * v_ij_erf_rk_cst_mu_j1b(i,j,ipoint) * r(:)
|
||||
! - 0.5 v_1b(ipoint) * x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,:)
|
||||
! - v_1b_grad[:,ipoint] * v_ij_u_cst_mu_j1b(i,j,ipoint)
|
||||
!
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: ipoint, i, j
|
||||
double precision :: time0, time1
|
||||
double precision :: x, y, z, tmp_x, tmp_y, tmp_z, tmp0, tmp1, tmp2
|
||||
|
||||
print*, ' providing int2_grad1_u12_ao_test ...'
|
||||
call wall_time(time0)
|
||||
|
||||
PROVIDE j1b_type
|
||||
|
||||
if(j1b_type .eq. 3) then
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
x = final_grid_points(1,ipoint)
|
||||
y = final_grid_points(2,ipoint)
|
||||
z = final_grid_points(3,ipoint)
|
||||
|
||||
tmp0 = 0.5d0 * v_1b(ipoint)
|
||||
tmp_x = v_1b_grad(1,ipoint)
|
||||
tmp_y = v_1b_grad(2,ipoint)
|
||||
tmp_z = v_1b_grad(3,ipoint)
|
||||
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
|
||||
tmp1 = tmp0 * v_ij_erf_rk_cst_mu_j1b_test(i,j,ipoint)
|
||||
tmp2 = v_ij_u_cst_mu_j1b_test(i,j,ipoint)
|
||||
|
||||
int2_grad1_u12_ao_test(i,j,ipoint,1) = tmp1 * x - tmp0 * x_v_ij_erf_rk_cst_mu_j1b_test(i,j,ipoint,1) - tmp2 * tmp_x
|
||||
int2_grad1_u12_ao_test(i,j,ipoint,2) = tmp1 * y - tmp0 * x_v_ij_erf_rk_cst_mu_j1b_test(i,j,ipoint,2) - tmp2 * tmp_y
|
||||
int2_grad1_u12_ao_test(i,j,ipoint,3) = tmp1 * z - tmp0 * x_v_ij_erf_rk_cst_mu_j1b_test(i,j,ipoint,3) - tmp2 * tmp_z
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
else
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
x = final_grid_points(1,ipoint)
|
||||
y = final_grid_points(2,ipoint)
|
||||
z = final_grid_points(3,ipoint)
|
||||
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
tmp1 = v_ij_erf_rk_cst_mu(i,j,ipoint)
|
||||
|
||||
int2_grad1_u12_ao_test(i,j,ipoint,1) = tmp1 * x - x_v_ij_erf_rk_cst_mu_tmp(i,j,ipoint,1)
|
||||
int2_grad1_u12_ao_test(i,j,ipoint,2) = tmp1 * y - x_v_ij_erf_rk_cst_mu_tmp(i,j,ipoint,2)
|
||||
int2_grad1_u12_ao_test(i,j,ipoint,3) = tmp1 * z - x_v_ij_erf_rk_cst_mu_tmp(i,j,ipoint,3)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
int2_grad1_u12_ao_test *= 0.5d0
|
||||
|
||||
endif
|
||||
|
||||
call wall_time(time1)
|
||||
print*, ' Wall time for int2_grad1_u12_ao_test = ', time1 - time0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, tc_grad_and_lapl_ao_test, (ao_num, ao_num, ao_num, ao_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! tc_grad_and_lapl_ao_test(k,i,l,j) = < k l | -1/2 \Delta_1 u(r1,r2) - \grad_1 u(r1,r2) | ij >
|
||||
!
|
||||
! = 1/2 \int dr1 (phi_k(r1) \grad_r1 phi_i(r1) - phi_i(r1) \grad_r1 phi_k(r1)) . \int dr2 \grad_r1 u(r1,r2) \phi_l(r2) \phi_j(r2)
|
||||
!
|
||||
! This is obtained by integration by parts.
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: ipoint, i, j, k, l, m
|
||||
double precision :: weight1, contrib_x, contrib_y, contrib_z, tmp_x, tmp_y, tmp_z
|
||||
double precision :: ao_k_r, ao_i_r, ao_i_dx, ao_i_dy, ao_i_dz
|
||||
double precision :: time0, time1
|
||||
double precision, allocatable :: ac_mat(:,:,:,:), b_mat(:,:,:,:)
|
||||
|
||||
print*, ' providing tc_grad_and_lapl_ao_test ...'
|
||||
call wall_time(time0)
|
||||
|
||||
provide int2_grad1_u12_ao_test
|
||||
|
||||
allocate(b_mat(n_points_final_grid,ao_num,ao_num,3), ac_mat(ao_num,ao_num,ao_num,ao_num))
|
||||
|
||||
b_mat = 0.d0
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i, k, ipoint, weight1, ao_i_r, ao_k_r) &
|
||||
!$OMP SHARED (aos_in_r_array_transp, aos_grad_in_r_array_transp_bis, b_mat, &
|
||||
!$OMP ao_num, n_points_final_grid, final_weight_at_r_vector)
|
||||
!$OMP DO SCHEDULE (static)
|
||||
do i = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
weight1 = 0.5d0 * final_weight_at_r_vector(ipoint)
|
||||
ao_i_r = aos_in_r_array_transp(ipoint,i)
|
||||
ao_k_r = aos_in_r_array_transp(ipoint,k)
|
||||
|
||||
b_mat(ipoint,k,i,1) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,1) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,1))
|
||||
b_mat(ipoint,k,i,2) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,2) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,2))
|
||||
b_mat(ipoint,k,i,3) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,3) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,3))
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
ac_mat = 0.d0
|
||||
do m = 1, 3
|
||||
call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
|
||||
, int2_grad1_u12_ao_test(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
|
||||
deallocate(b_mat)
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i, j, k, l) &
|
||||
!$OMP SHARED (ac_mat, tc_grad_and_lapl_ao_test, ao_num)
|
||||
!$OMP DO SCHEDULE (static)
|
||||
do j = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
tc_grad_and_lapl_ao_test(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
|
||||
|
||||
deallocate(ac_mat)
|
||||
|
||||
call wall_time(time1)
|
||||
print*, ' Wall time for tc_grad_and_lapl_ao_test = ', time1 - time0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
623
src/non_h_ints_mu/numerical_integ.irp.f
Normal file
623
src/non_h_ints_mu/numerical_integ.irp.f
Normal file
@ -0,0 +1,623 @@
|
||||
|
||||
! ---
|
||||
|
||||
double precision function num_v_ij_u_cst_mu_j1b(i, j, ipoint)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! \int dr2 u12 \phi_i(r2) \phi_j(r2) x v_1b(r2)
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: i, j, ipoint
|
||||
|
||||
integer :: jpoint
|
||||
double precision :: r1(3), r2(3)
|
||||
|
||||
double precision, external :: ao_value
|
||||
double precision, external :: j12_mu, j1b_nucl, j12_mu_gauss
|
||||
|
||||
r1(1) = final_grid_points(1,ipoint)
|
||||
r1(2) = final_grid_points(2,ipoint)
|
||||
r1(3) = final_grid_points(3,ipoint)
|
||||
|
||||
num_v_ij_u_cst_mu_j1b = 0.d0
|
||||
do jpoint = 1, n_points_final_grid
|
||||
r2(1) = final_grid_points(1,jpoint)
|
||||
r2(2) = final_grid_points(2,jpoint)
|
||||
r2(3) = final_grid_points(3,jpoint)
|
||||
|
||||
num_v_ij_u_cst_mu_j1b += ao_value(i, r2) * ao_value(j, r2) * j12_mu_gauss(r1, r2) * j1b_nucl(r2) * final_weight_at_r_vector(jpoint)
|
||||
enddo
|
||||
|
||||
return
|
||||
end function num_v_ij_u_cst_mu_j1b
|
||||
|
||||
! ---
|
||||
|
||||
double precision function num_int2_u2_j1b2(i, j, ipoint)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! \int dr2 u12^2 \phi_i(r2) \phi_j(r2) x v_1b(r2)^2
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: i, j, ipoint
|
||||
|
||||
integer :: jpoint, i_fit
|
||||
double precision :: r1(3), r2(3)
|
||||
double precision :: dx, dy, dz, r12, x2, tmp1, tmp2, tmp3, coef, expo
|
||||
|
||||
double precision, external :: ao_value
|
||||
double precision, external :: j1b_nucl
|
||||
double precision, external :: j12_mu
|
||||
|
||||
r1(1) = final_grid_points(1,ipoint)
|
||||
r1(2) = final_grid_points(2,ipoint)
|
||||
r1(3) = final_grid_points(3,ipoint)
|
||||
|
||||
num_int2_u2_j1b2 = 0.d0
|
||||
do jpoint = 1, n_points_final_grid
|
||||
r2(1) = final_grid_points(1,jpoint)
|
||||
r2(2) = final_grid_points(2,jpoint)
|
||||
r2(3) = final_grid_points(3,jpoint)
|
||||
dx = r1(1) - r2(1)
|
||||
dy = r1(2) - r2(2)
|
||||
dz = r1(3) - r2(3)
|
||||
x2 = dx * dx + dy * dy + dz * dz
|
||||
r12 = dsqrt(x2)
|
||||
|
||||
tmp1 = j1b_nucl(r2)
|
||||
tmp2 = tmp1 * tmp1 * ao_value(i, r2) * ao_value(j, r2) * final_weight_at_r_vector(jpoint)
|
||||
|
||||
!tmp3 = 0.d0
|
||||
!do i_fit = 1, n_max_fit_slat
|
||||
! expo = expo_gauss_j_mu_x_2(i_fit)
|
||||
! coef = coef_gauss_j_mu_x_2(i_fit)
|
||||
! tmp3 += coef * dexp(-expo*x2)
|
||||
!enddo
|
||||
tmp3 = j12_mu(r1, r2)
|
||||
tmp3 = tmp3 * tmp3
|
||||
|
||||
num_int2_u2_j1b2 += tmp2 * tmp3
|
||||
enddo
|
||||
|
||||
return
|
||||
end function num_int2_u2_j1b2
|
||||
|
||||
! ---
|
||||
|
||||
double precision function num_int2_grad1u2_grad2u2_j1b2(i, j, ipoint)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! \int dr2 \frac{-[erf(mu r12) -1]^2}{4} \phi_i(r2) \phi_j(r2) x v_1b(r2)^2
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: i, j, ipoint
|
||||
|
||||
integer :: jpoint, i_fit
|
||||
double precision :: r1(3), r2(3)
|
||||
double precision :: dx, dy, dz, r12, x2, tmp1, tmp2, tmp3, coef, expo
|
||||
|
||||
double precision, external :: ao_value
|
||||
double precision, external :: j1b_nucl
|
||||
|
||||
r1(1) = final_grid_points(1,ipoint)
|
||||
r1(2) = final_grid_points(2,ipoint)
|
||||
r1(3) = final_grid_points(3,ipoint)
|
||||
|
||||
num_int2_grad1u2_grad2u2_j1b2 = 0.d0
|
||||
do jpoint = 1, n_points_final_grid
|
||||
r2(1) = final_grid_points(1,jpoint)
|
||||
r2(2) = final_grid_points(2,jpoint)
|
||||
r2(3) = final_grid_points(3,jpoint)
|
||||
dx = r1(1) - r2(1)
|
||||
dy = r1(2) - r2(2)
|
||||
dz = r1(3) - r2(3)
|
||||
x2 = dx * dx + dy * dy + dz * dz
|
||||
r12 = dsqrt(x2)
|
||||
|
||||
tmp1 = j1b_nucl(r2)
|
||||
tmp2 = tmp1 * tmp1 * ao_value(i, r2) * ao_value(j, r2) * final_weight_at_r_vector(jpoint)
|
||||
|
||||
!tmp3 = 0.d0
|
||||
!do i_fit = 1, n_max_fit_slat
|
||||
! expo = expo_gauss_1_erf_x_2(i_fit)
|
||||
! coef = coef_gauss_1_erf_x_2(i_fit)
|
||||
! tmp3 += coef * dexp(-expo*x2)
|
||||
!enddo
|
||||
tmp3 = derf(mu_erf*r12) - 1.d0
|
||||
tmp3 = tmp3 * tmp3
|
||||
|
||||
tmp3 = -0.25d0 * tmp3
|
||||
|
||||
num_int2_grad1u2_grad2u2_j1b2 += tmp2 * tmp3
|
||||
enddo
|
||||
|
||||
return
|
||||
end function num_int2_grad1u2_grad2u2_j1b2
|
||||
|
||||
! ---
|
||||
|
||||
double precision function num_v_ij_erf_rk_cst_mu_j1b(i, j, ipoint)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! \int dr2 [erf(mu r12) -1]/r12 \phi_i(r2) \phi_j(r2) x v_1b(r2)
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: i, j, ipoint
|
||||
|
||||
integer :: jpoint
|
||||
double precision :: r1(3), r2(3)
|
||||
double precision :: dx, dy, dz, r12, tmp1, tmp2
|
||||
|
||||
double precision, external :: ao_value
|
||||
double precision, external :: j1b_nucl
|
||||
|
||||
r1(1) = final_grid_points(1,ipoint)
|
||||
r1(2) = final_grid_points(2,ipoint)
|
||||
r1(3) = final_grid_points(3,ipoint)
|
||||
|
||||
num_v_ij_erf_rk_cst_mu_j1b = 0.d0
|
||||
do jpoint = 1, n_points_final_grid
|
||||
r2(1) = final_grid_points(1,jpoint)
|
||||
r2(2) = final_grid_points(2,jpoint)
|
||||
r2(3) = final_grid_points(3,jpoint)
|
||||
dx = r1(1) - r2(1)
|
||||
dy = r1(2) - r2(2)
|
||||
dz = r1(3) - r2(3)
|
||||
r12 = dsqrt( dx * dx + dy * dy + dz * dz )
|
||||
if(r12 .lt. 1d-10) cycle
|
||||
|
||||
tmp1 = (derf(mu_erf * r12) - 1.d0) / r12
|
||||
tmp2 = tmp1 * ao_value(i, r2) * ao_value(j, r2) * j1b_nucl(r2) * final_weight_at_r_vector(jpoint)
|
||||
|
||||
num_v_ij_erf_rk_cst_mu_j1b += tmp2
|
||||
enddo
|
||||
|
||||
return
|
||||
end function num_v_ij_erf_rk_cst_mu_j1b
|
||||
|
||||
! ---
|
||||
|
||||
subroutine num_x_v_ij_erf_rk_cst_mu_j1b(i, j, ipoint, integ)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! \int dr2 [erf(mu r12) -1]/r12 \phi_i(r2) \phi_j(r2) x v_1b(r2) x r2
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: i, j, ipoint
|
||||
double precision, intent(out) :: integ(3)
|
||||
|
||||
integer :: jpoint
|
||||
double precision :: r1(3), r2(3), grad(3)
|
||||
double precision :: dx, dy, dz, r12, tmp1, tmp2
|
||||
double precision :: tmp_x, tmp_y, tmp_z
|
||||
|
||||
double precision, external :: ao_value
|
||||
double precision, external :: j1b_nucl
|
||||
|
||||
r1(1) = final_grid_points(1,ipoint)
|
||||
r1(2) = final_grid_points(2,ipoint)
|
||||
r1(3) = final_grid_points(3,ipoint)
|
||||
|
||||
tmp_x = 0.d0
|
||||
tmp_y = 0.d0
|
||||
tmp_z = 0.d0
|
||||
do jpoint = 1, n_points_final_grid
|
||||
r2(1) = final_grid_points(1,jpoint)
|
||||
r2(2) = final_grid_points(2,jpoint)
|
||||
r2(3) = final_grid_points(3,jpoint)
|
||||
dx = r1(1) - r2(1)
|
||||
dy = r1(2) - r2(2)
|
||||
dz = r1(3) - r2(3)
|
||||
r12 = dsqrt( dx * dx + dy * dy + dz * dz )
|
||||
if(r12 .lt. 1d-10) cycle
|
||||
|
||||
tmp1 = (derf(mu_erf * r12) - 1.d0) / r12
|
||||
tmp2 = tmp1 * ao_value(i, r2) * ao_value(j, r2) * j1b_nucl(r2) * final_weight_at_r_vector(jpoint)
|
||||
|
||||
tmp_x += tmp2 * r2(1)
|
||||
tmp_y += tmp2 * r2(2)
|
||||
tmp_z += tmp2 * r2(3)
|
||||
enddo
|
||||
|
||||
integ(1) = tmp_x
|
||||
integ(2) = tmp_y
|
||||
integ(3) = tmp_z
|
||||
|
||||
return
|
||||
end subroutine num_x_v_ij_erf_rk_cst_mu_j1b
|
||||
|
||||
! ---
|
||||
|
||||
subroutine num_int2_grad1_u12_ao(i, j, ipoint, integ)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! \int dr2 [-grad_1 u12] \phi_i(r2) \phi_j(r2) x v12_1b(r1, r2)
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: i, j, ipoint
|
||||
double precision, intent(out) :: integ(3)
|
||||
|
||||
integer :: jpoint
|
||||
double precision :: tmp, r1(3), r2(3), grad(3)
|
||||
double precision :: tmp_x, tmp_y, tmp_z
|
||||
|
||||
double precision, external :: ao_value
|
||||
|
||||
r1(1) = final_grid_points(1,ipoint)
|
||||
r1(2) = final_grid_points(2,ipoint)
|
||||
r1(3) = final_grid_points(3,ipoint)
|
||||
|
||||
tmp_x = 0.d0
|
||||
tmp_y = 0.d0
|
||||
tmp_z = 0.d0
|
||||
do jpoint = 1, n_points_final_grid
|
||||
r2(1) = final_grid_points(1,jpoint)
|
||||
r2(2) = final_grid_points(2,jpoint)
|
||||
r2(3) = final_grid_points(3,jpoint)
|
||||
tmp = ao_value(i, r2) * ao_value(j, r2) * final_weight_at_r_vector(jpoint)
|
||||
|
||||
call grad1_jmu_modif_num(r1, r2, grad)
|
||||
|
||||
tmp_x += tmp * (-1.d0 * grad(1))
|
||||
tmp_y += tmp * (-1.d0 * grad(2))
|
||||
tmp_z += tmp * (-1.d0 * grad(3))
|
||||
enddo
|
||||
|
||||
integ(1) = tmp_x
|
||||
integ(2) = tmp_y
|
||||
integ(3) = tmp_z
|
||||
|
||||
return
|
||||
end subroutine num_int2_grad1_u12_ao
|
||||
|
||||
! ---
|
||||
|
||||
double precision function num_gradu_squared_u_ij_mu(i, j, ipoint)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! -0.50 x \int r2 \phi_i(2) \phi_j(2) x v2^2
|
||||
! [ v1^2 ((grad_1 u12)^2 + (grad_2 u12^2)])
|
||||
! + u12^2 (grad_1 v1)^2
|
||||
! + 2 u12 v1 (grad_1 u12) . (grad_1 v1)
|
||||
!
|
||||
END_DOC
|
||||
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: i, j, ipoint
|
||||
|
||||
integer :: jpoint
|
||||
double precision :: r1(3), r2(3)
|
||||
double precision :: tmp_x, tmp_y, tmp_z, r12
|
||||
double precision :: dx1_v1, dy1_v1, dz1_v1, grad_u12(3)
|
||||
double precision :: tmp1, v1_tmp, v2_tmp, u12_tmp
|
||||
double precision :: fst_term, scd_term, thd_term, tmp
|
||||
|
||||
double precision, external :: ao_value
|
||||
double precision, external :: j1b_nucl
|
||||
double precision, external :: j12_mu
|
||||
double precision, external :: grad_x_j1b_nucl
|
||||
double precision, external :: grad_y_j1b_nucl
|
||||
double precision, external :: grad_z_j1b_nucl
|
||||
|
||||
r1(1) = final_grid_points(1,ipoint)
|
||||
r1(2) = final_grid_points(2,ipoint)
|
||||
r1(3) = final_grid_points(3,ipoint)
|
||||
|
||||
num_gradu_squared_u_ij_mu = 0.d0
|
||||
do jpoint = 1, n_points_final_grid
|
||||
|
||||
r2(1) = final_grid_points(1,jpoint)
|
||||
r2(2) = final_grid_points(2,jpoint)
|
||||
r2(3) = final_grid_points(3,jpoint)
|
||||
|
||||
tmp_x = r1(1) - r2(1)
|
||||
tmp_y = r1(2) - r2(2)
|
||||
tmp_z = r1(3) - r2(3)
|
||||
r12 = dsqrt(tmp_x*tmp_x + tmp_y*tmp_y + tmp_z*tmp_z)
|
||||
|
||||
dx1_v1 = grad_x_j1b_nucl(r1)
|
||||
dy1_v1 = grad_y_j1b_nucl(r1)
|
||||
dz1_v1 = grad_z_j1b_nucl(r1)
|
||||
|
||||
call grad1_j12_mu_exc(r1, r2, grad_u12)
|
||||
|
||||
tmp1 = 1.d0 - derf(mu_erf * r12)
|
||||
v1_tmp = j1b_nucl(r1)
|
||||
v2_tmp = j1b_nucl(r2)
|
||||
u12_tmp = j12_mu(r1, r2)
|
||||
|
||||
fst_term = 0.5d0 * tmp1 * tmp1 * v1_tmp * v1_tmp
|
||||
scd_term = u12_tmp * u12_tmp * (dx1_v1*dx1_v1 + dy1_v1*dy1_v1 + dz1_v1*dz1_v1)
|
||||
thd_term = 2.d0 * v1_tmp * u12_tmp * (dx1_v1*grad_u12(1) + dy1_v1*grad_u12(2) + dz1_v1*grad_u12(3))
|
||||
|
||||
tmp = -0.5d0 * ao_value(i, r2) * ao_value(j, r2) * final_weight_at_r_vector(jpoint) * (fst_term + scd_term + thd_term) * v2_tmp * v2_tmp
|
||||
|
||||
num_gradu_squared_u_ij_mu += tmp
|
||||
enddo
|
||||
|
||||
return
|
||||
end function num_gradu_squared_u_ij_mu
|
||||
|
||||
! ---
|
||||
|
||||
double precision function num_grad12_j12(i, j, ipoint)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! -0.50 x \int r2 \phi_i(2) \phi_j(2) x v2^2 [v1^2 ((grad_1 u12)^2 + (grad_2 u12^2)]) ]
|
||||
!
|
||||
END_DOC
|
||||
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: i, j, ipoint
|
||||
|
||||
integer :: jpoint
|
||||
double precision :: r1(3), r2(3)
|
||||
double precision :: tmp_x, tmp_y, tmp_z, r12
|
||||
double precision :: dx1_v1, dy1_v1, dz1_v1, grad_u12(3)
|
||||
double precision :: tmp1, v1_tmp, v2_tmp, u12_tmp
|
||||
double precision :: fst_term, scd_term, thd_term, tmp
|
||||
|
||||
double precision, external :: ao_value
|
||||
double precision, external :: j1b_nucl
|
||||
double precision, external :: j12_mu
|
||||
double precision, external :: grad_x_j1b_nucl
|
||||
double precision, external :: grad_y_j1b_nucl
|
||||
double precision, external :: grad_z_j1b_nucl
|
||||
|
||||
r1(1) = final_grid_points(1,ipoint)
|
||||
r1(2) = final_grid_points(2,ipoint)
|
||||
r1(3) = final_grid_points(3,ipoint)
|
||||
|
||||
num_grad12_j12 = 0.d0
|
||||
do jpoint = 1, n_points_final_grid
|
||||
|
||||
r2(1) = final_grid_points(1,jpoint)
|
||||
r2(2) = final_grid_points(2,jpoint)
|
||||
r2(3) = final_grid_points(3,jpoint)
|
||||
|
||||
tmp_x = r1(1) - r2(1)
|
||||
tmp_y = r1(2) - r2(2)
|
||||
tmp_z = r1(3) - r2(3)
|
||||
r12 = dsqrt(tmp_x*tmp_x + tmp_y*tmp_y + tmp_z*tmp_z)
|
||||
|
||||
dx1_v1 = grad_x_j1b_nucl(r1)
|
||||
dy1_v1 = grad_y_j1b_nucl(r1)
|
||||
dz1_v1 = grad_z_j1b_nucl(r1)
|
||||
|
||||
call grad1_j12_mu_exc(r1, r2, grad_u12)
|
||||
|
||||
tmp1 = 1.d0 - derf(mu_erf * r12)
|
||||
v1_tmp = j1b_nucl(r1)
|
||||
v2_tmp = j1b_nucl(r2)
|
||||
u12_tmp = j12_mu(r1, r2)
|
||||
|
||||
fst_term = 0.5d0 * tmp1 * tmp1 * v1_tmp * v1_tmp
|
||||
|
||||
tmp = -0.5d0 * ao_value(i, r2) * ao_value(j, r2) * final_weight_at_r_vector(jpoint) * fst_term * v2_tmp * v2_tmp
|
||||
|
||||
num_grad12_j12 += tmp
|
||||
enddo
|
||||
|
||||
return
|
||||
end function num_grad12_j12
|
||||
|
||||
! ---
|
||||
|
||||
double precision function num_u12sq_j1bsq(i, j, ipoint)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! -0.50 x \int r2 \phi_i(2) \phi_j(2) x v2^2 [ u12^2 (grad_1 v1)^2 ]
|
||||
!
|
||||
END_DOC
|
||||
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: i, j, ipoint
|
||||
|
||||
integer :: jpoint
|
||||
double precision :: r1(3), r2(3)
|
||||
double precision :: tmp_x, tmp_y, tmp_z, r12
|
||||
double precision :: dx1_v1, dy1_v1, dz1_v1, grad_u12(3)
|
||||
double precision :: tmp1, v1_tmp, v2_tmp, u12_tmp
|
||||
double precision :: fst_term, scd_term, thd_term, tmp
|
||||
|
||||
double precision, external :: ao_value
|
||||
double precision, external :: j1b_nucl
|
||||
double precision, external :: j12_mu
|
||||
double precision, external :: grad_x_j1b_nucl
|
||||
double precision, external :: grad_y_j1b_nucl
|
||||
double precision, external :: grad_z_j1b_nucl
|
||||
|
||||
r1(1) = final_grid_points(1,ipoint)
|
||||
r1(2) = final_grid_points(2,ipoint)
|
||||
r1(3) = final_grid_points(3,ipoint)
|
||||
|
||||
num_u12sq_j1bsq = 0.d0
|
||||
do jpoint = 1, n_points_final_grid
|
||||
|
||||
r2(1) = final_grid_points(1,jpoint)
|
||||
r2(2) = final_grid_points(2,jpoint)
|
||||
r2(3) = final_grid_points(3,jpoint)
|
||||
|
||||
tmp_x = r1(1) - r2(1)
|
||||
tmp_y = r1(2) - r2(2)
|
||||
tmp_z = r1(3) - r2(3)
|
||||
r12 = dsqrt(tmp_x*tmp_x + tmp_y*tmp_y + tmp_z*tmp_z)
|
||||
|
||||
dx1_v1 = grad_x_j1b_nucl(r1)
|
||||
dy1_v1 = grad_y_j1b_nucl(r1)
|
||||
dz1_v1 = grad_z_j1b_nucl(r1)
|
||||
|
||||
call grad1_j12_mu_exc(r1, r2, grad_u12)
|
||||
|
||||
tmp1 = 1.d0 - derf(mu_erf * r12)
|
||||
v1_tmp = j1b_nucl(r1)
|
||||
v2_tmp = j1b_nucl(r2)
|
||||
u12_tmp = j12_mu(r1, r2)
|
||||
|
||||
scd_term = u12_tmp * u12_tmp * (dx1_v1*dx1_v1 + dy1_v1*dy1_v1 + dz1_v1*dz1_v1)
|
||||
|
||||
tmp = -0.5d0 * ao_value(i, r2) * ao_value(j, r2) * final_weight_at_r_vector(jpoint) * scd_term * v2_tmp * v2_tmp
|
||||
|
||||
num_u12sq_j1bsq += tmp
|
||||
enddo
|
||||
|
||||
return
|
||||
end function num_u12sq_j1bsq
|
||||
|
||||
! ---
|
||||
|
||||
double precision function num_u12_grad1_u12_j1b_grad1_j1b(i, j, ipoint)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! -0.50 x \int r2 \phi_i(2) \phi_j(2) x v2^2 [ 2 u12 v1 (grad_1 u12) . (grad_1 v1) ]
|
||||
!
|
||||
END_DOC
|
||||
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: i, j, ipoint
|
||||
|
||||
integer :: jpoint
|
||||
double precision :: r1(3), r2(3)
|
||||
double precision :: tmp_x, tmp_y, tmp_z, r12
|
||||
double precision :: dx1_v1, dy1_v1, dz1_v1, grad_u12(3)
|
||||
double precision :: tmp1, v1_tmp, v2_tmp, u12_tmp
|
||||
double precision :: fst_term, scd_term, thd_term, tmp
|
||||
|
||||
double precision, external :: ao_value
|
||||
double precision, external :: j1b_nucl
|
||||
double precision, external :: j12_mu
|
||||
double precision, external :: grad_x_j1b_nucl
|
||||
double precision, external :: grad_y_j1b_nucl
|
||||
double precision, external :: grad_z_j1b_nucl
|
||||
|
||||
r1(1) = final_grid_points(1,ipoint)
|
||||
r1(2) = final_grid_points(2,ipoint)
|
||||
r1(3) = final_grid_points(3,ipoint)
|
||||
|
||||
num_u12_grad1_u12_j1b_grad1_j1b = 0.d0
|
||||
do jpoint = 1, n_points_final_grid
|
||||
|
||||
r2(1) = final_grid_points(1,jpoint)
|
||||
r2(2) = final_grid_points(2,jpoint)
|
||||
r2(3) = final_grid_points(3,jpoint)
|
||||
|
||||
tmp_x = r1(1) - r2(1)
|
||||
tmp_y = r1(2) - r2(2)
|
||||
tmp_z = r1(3) - r2(3)
|
||||
r12 = dsqrt(tmp_x*tmp_x + tmp_y*tmp_y + tmp_z*tmp_z)
|
||||
|
||||
dx1_v1 = grad_x_j1b_nucl(r1)
|
||||
dy1_v1 = grad_y_j1b_nucl(r1)
|
||||
dz1_v1 = grad_z_j1b_nucl(r1)
|
||||
|
||||
call grad1_j12_mu_exc(r1, r2, grad_u12)
|
||||
|
||||
tmp1 = 1.d0 - derf(mu_erf * r12)
|
||||
v1_tmp = j1b_nucl(r1)
|
||||
v2_tmp = j1b_nucl(r2)
|
||||
u12_tmp = j12_mu(r1, r2)
|
||||
|
||||
thd_term = 2.d0 * v1_tmp * u12_tmp * (dx1_v1*grad_u12(1) + dy1_v1*grad_u12(2) + dz1_v1*grad_u12(3))
|
||||
|
||||
tmp = -0.5d0 * ao_value(i, r2) * ao_value(j, r2) * final_weight_at_r_vector(jpoint) * thd_term * v2_tmp * v2_tmp
|
||||
|
||||
num_u12_grad1_u12_j1b_grad1_j1b += tmp
|
||||
enddo
|
||||
|
||||
return
|
||||
end function num_u12_grad1_u12_j1b_grad1_j1b
|
||||
|
||||
! ---
|
||||
|
||||
subroutine num_int2_u_grad1u_total_j1b2(i, j, ipoint, integ)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! \int dr2 u12 (grad_1 u12) \phi_i(r2) \phi_j(r2) x v_1b(r2)^2
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: i, j, ipoint
|
||||
double precision, intent(out) :: integ(3)
|
||||
|
||||
integer :: jpoint
|
||||
double precision :: r1(3), r2(3), grad(3)
|
||||
double precision :: dx, dy, dz, r12, tmp0, tmp1, tmp2
|
||||
double precision :: tmp_x, tmp_y, tmp_z
|
||||
|
||||
double precision, external :: ao_value
|
||||
double precision, external :: j1b_nucl
|
||||
double precision, external :: j12_mu
|
||||
|
||||
r1(1) = final_grid_points(1,ipoint)
|
||||
r1(2) = final_grid_points(2,ipoint)
|
||||
r1(3) = final_grid_points(3,ipoint)
|
||||
|
||||
tmp_x = 0.d0
|
||||
tmp_y = 0.d0
|
||||
tmp_z = 0.d0
|
||||
do jpoint = 1, n_points_final_grid
|
||||
r2(1) = final_grid_points(1,jpoint)
|
||||
r2(2) = final_grid_points(2,jpoint)
|
||||
r2(3) = final_grid_points(3,jpoint)
|
||||
dx = r1(1) - r2(1)
|
||||
dy = r1(2) - r2(2)
|
||||
dz = r1(3) - r2(3)
|
||||
r12 = dsqrt( dx * dx + dy * dy + dz * dz )
|
||||
if(r12 .lt. 1d-10) cycle
|
||||
|
||||
tmp0 = j1b_nucl(r2)
|
||||
tmp1 = 0.5d0 * j12_mu(r1, r2) * (1.d0 - derf(mu_erf * r12)) / r12
|
||||
tmp2 = tmp0 * tmp0 * tmp1 * ao_value(i, r2) * ao_value(j, r2) * final_weight_at_r_vector(jpoint)
|
||||
|
||||
tmp_x += tmp2 * dx
|
||||
tmp_y += tmp2 * dy
|
||||
tmp_z += tmp2 * dz
|
||||
enddo
|
||||
|
||||
integ(1) = tmp_x
|
||||
integ(2) = tmp_y
|
||||
integ(3) = tmp_z
|
||||
|
||||
return
|
||||
end subroutine num_int2_u_grad1u_total_j1b2
|
||||
|
||||
! ---
|
||||
102
src/non_h_ints_mu/test_non_h_ints.irp.f
Normal file
102
src/non_h_ints_mu/test_non_h_ints.irp.f
Normal file
@ -0,0 +1,102 @@
|
||||
program test_non_h
|
||||
implicit none
|
||||
my_grid_becke = .True.
|
||||
my_n_pt_r_grid = 50
|
||||
my_n_pt_a_grid = 74
|
||||
! my_n_pt_r_grid = 10 ! small grid for quick debug
|
||||
! my_n_pt_a_grid = 26 ! small grid for quick debug
|
||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||
!call routine_grad_squared
|
||||
call routine_fit
|
||||
end
|
||||
|
||||
subroutine routine_lapl_grad
|
||||
implicit none
|
||||
integer :: i,j,k,l
|
||||
double precision :: grad_lapl, get_ao_tc_sym_two_e_pot,new,accu,contrib
|
||||
double precision :: ao_two_e_integral_erf,get_ao_two_e_integral,count_n,accu_relat
|
||||
! !!!!!!!!!!!!!!!!!!!!! WARNING
|
||||
! THIS ROUTINE MAKES SENSE ONLY IF HAND MODIFIED coef_gauss_eff_pot(1:n_max_fit_slat) = 0. to cancel (1-erf(mu*r12))^2
|
||||
accu = 0.d0
|
||||
accu_relat = 0.d0
|
||||
count_n = 0.d0
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
grad_lapl = get_ao_tc_sym_two_e_pot(i,j,k,l,ao_tc_sym_two_e_pot_map) ! pure gaussian part : comes from Lapl
|
||||
grad_lapl += ao_two_e_integral_erf(i, k, j, l) ! erf(mu r12)/r12 : comes from Lapl
|
||||
grad_lapl += ao_non_hermit_term_chemist(k,i,l,j) ! \grad u(r12) . grad
|
||||
new = tc_grad_and_lapl_ao(k,i,l,j)
|
||||
new += get_ao_two_e_integral(i,j,k,l,ao_integrals_map)
|
||||
contrib = dabs(new - grad_lapl)
|
||||
if(dabs(grad_lapl).gt.1.d-12)then
|
||||
count_n += 1.d0
|
||||
accu_relat += 2.0d0 * contrib/dabs(grad_lapl+new)
|
||||
endif
|
||||
if(contrib.gt.1.d-10)then
|
||||
print*,i,j,k,l
|
||||
print*,grad_lapl,new,contrib
|
||||
print*,2.0d0*contrib/dabs(grad_lapl+new+1.d-12)
|
||||
endif
|
||||
accu += contrib
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
print*,'accu = ',accu/count_n
|
||||
print*,'accu/rel = ',accu_relat/count_n
|
||||
|
||||
end
|
||||
|
||||
subroutine routine_grad_squared
|
||||
implicit none
|
||||
integer :: i,j,k,l
|
||||
double precision :: grad_squared, get_ao_tc_sym_two_e_pot,new,accu,contrib
|
||||
double precision :: count_n,accu_relat
|
||||
! !!!!!!!!!!!!!!!!!!!!! WARNING
|
||||
! THIS ROUTINE MAKES SENSE ONLY IF HAND MODIFIED coef_gauss_eff_pot(n_max_fit_slat:n_max_fit_slat+1) = 0. to cancel exp(-'mu*r12)^2)
|
||||
accu = 0.d0
|
||||
accu_relat = 0.d0
|
||||
count_n = 0.d0
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
grad_squared = get_ao_tc_sym_two_e_pot(i,j,k,l,ao_tc_sym_two_e_pot_map) ! pure gaussian part : comes from Lapl
|
||||
new = tc_grad_square_ao(k,i,l,j)
|
||||
contrib = dabs(new - grad_squared)
|
||||
if(dabs(grad_squared).gt.1.d-12)then
|
||||
count_n += 1.d0
|
||||
accu_relat += 2.0d0 * contrib/dabs(grad_squared+new)
|
||||
endif
|
||||
if(contrib.gt.1.d-10)then
|
||||
print*,i,j,k,l
|
||||
print*,grad_squared,new,contrib
|
||||
print*,2.0d0*contrib/dabs(grad_squared+new+1.d-12)
|
||||
endif
|
||||
accu += contrib
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
print*,'accu = ',accu/count_n
|
||||
print*,'accu/rel = ',accu_relat/count_n
|
||||
|
||||
end
|
||||
|
||||
subroutine routine_fit
|
||||
implicit none
|
||||
integer :: i,nx
|
||||
double precision :: dx,xmax,x,j_mu,j_mu_F_x_j,j_mu_fit_gauss
|
||||
nx = 500
|
||||
xmax = 5.d0
|
||||
dx = xmax/dble(nx)
|
||||
x = 0.d0
|
||||
print*,'coucou',mu_erf
|
||||
do i = 1, nx
|
||||
write(33,'(100(F16.10,X))') x,j_mu(x),j_mu_F_x_j(x),j_mu_fit_gauss(x)
|
||||
x += dx
|
||||
enddo
|
||||
|
||||
end
|
||||
91
src/non_h_ints_mu/total_tc_int.irp.f
Normal file
91
src/non_h_ints_mu/total_tc_int.irp.f
Normal file
@ -0,0 +1,91 @@
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, ao_tc_int_chemist, (ao_num, ao_num, ao_num, ao_num)]
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, l
|
||||
double precision :: wall1, wall0
|
||||
|
||||
print *, ' providing ao_tc_int_chemist ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
if(test_cycle_tc)then
|
||||
ao_tc_int_chemist = ao_tc_int_chemist_test
|
||||
else
|
||||
do j = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
ao_tc_int_chemist(k,i,l,j) = tc_grad_square_ao(k,i,l,j) + tc_grad_and_lapl_ao(k,i,l,j) + ao_two_e_coul(k,i,l,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for ao_tc_int_chemist ', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, ao_tc_int_chemist_test, (ao_num, ao_num, ao_num, ao_num)]
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, l
|
||||
double precision :: wall1, wall0
|
||||
|
||||
print *, ' providing ao_tc_int_chemist_test ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
do j = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
ao_tc_int_chemist_test(k,i,l,j) = tc_grad_square_ao_test(k,i,l,j) + tc_grad_and_lapl_ao_test(k,i,l,j) + ao_two_e_coul(k,i,l,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for ao_tc_int_chemist_test ', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, ao_two_e_coul, (ao_num, ao_num, ao_num, ao_num) ]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! ao_two_e_coul(k,i,l,j) = ( k i | 1/r12 | l j ) = < l k | 1/r12 | j i >
|
||||
!
|
||||
END_DOC
|
||||
|
||||
integer :: i, j, k, l
|
||||
double precision :: integral
|
||||
double precision, external :: get_ao_two_e_integral
|
||||
|
||||
PROVIDE ao_integrals_map
|
||||
|
||||
do j = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
|
||||
! < 1:k, 2:l | 1:i, 2:j >
|
||||
integral = get_ao_two_e_integral(i, j, k, l, ao_integrals_map)
|
||||
|
||||
ao_two_e_coul(k,i,l,j) = integral
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
1
src/non_hermit_dav/NEED
Normal file
1
src/non_hermit_dav/NEED
Normal file
@ -0,0 +1 @@
|
||||
utils
|
||||
1156
src/non_hermit_dav/biorthog.irp.f
Normal file
1156
src/non_hermit_dav/biorthog.irp.f
Normal file
File diff suppressed because it is too large
Load Diff
56
src/non_hermit_dav/gram_schmit.irp.f
Normal file
56
src/non_hermit_dav/gram_schmit.irp.f
Normal file
@ -0,0 +1,56 @@
|
||||
subroutine bi_ortho_gram_schmidt(wi,vi,n,ni,wk,wk_schmidt)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! you enter with a set of "ni" BI-ORTHONORMAL vectors of length "n"
|
||||
!
|
||||
! vi(j,i) = <j|vi>, wi(j,i) = <j|wi>, <vi|wj> = delta_{ij} S_ii, S_ii =<vi|wi>
|
||||
!
|
||||
! and a vector vk(j) = <j|vk>
|
||||
!
|
||||
! you go out with a vector vk_schmidt(j) = <j|vk_schmidt>
|
||||
!
|
||||
! which is Gram-Schmidt orthonormalized with respect to the "vi"
|
||||
!
|
||||
! <vi|wk_schmidt> = 0
|
||||
!
|
||||
! |wk_schmidt> = |wk> - \sum_{i=1}^ni (<vi|wk>/<vi|wi>) |wi>
|
||||
!
|
||||
! according to Eq. (5), (6) of Computers Structures, Vol 56, No. 4, pp 605-613, 1995
|
||||
!
|
||||
! https://doi.org/10.1016/0045-7949(94)00565-K
|
||||
END_DOC
|
||||
integer, intent(in) :: n,ni
|
||||
double precision, intent(in) :: wi(n,ni),vi(n,ni),wk(n)
|
||||
double precision, intent(out):: wk_schmidt(n)
|
||||
double precision :: vi_wk,u_dot_v,tmp,u_dot_u
|
||||
double precision, allocatable :: sii(:)
|
||||
integer :: i,j
|
||||
allocate( sii(ni) )
|
||||
wk_schmidt = wk
|
||||
do i = 1, ni
|
||||
sii(i) = u_dot_v(vi(1,i),wi(1,i),n)
|
||||
enddo
|
||||
! do i = 1, n
|
||||
! print*,i,'wk',wk(i)
|
||||
! enddo
|
||||
! print*,''
|
||||
! print*,''
|
||||
do i = 1, ni
|
||||
! print*,'i',i
|
||||
! Gram-Schmidt
|
||||
vi_wk = u_dot_v(vi(1,i),wk,n)
|
||||
vi_wk = vi_wk / sii(i)
|
||||
! print*,''
|
||||
do j = 1, n
|
||||
! print*,j,vi_wk,wi(j,i)
|
||||
wk_schmidt(j) -= vi_wk * wi(j,i)
|
||||
enddo
|
||||
enddo
|
||||
tmp = u_dot_u(wk_schmidt,n)
|
||||
tmp = 1.d0/dsqrt(tmp)
|
||||
wk_schmidt = tmp * wk_schmidt
|
||||
! do j = 1, n
|
||||
! print*,j,'wk_scc',wk_schmidt(j)
|
||||
! enddo
|
||||
! pause
|
||||
end
|
||||
93
src/non_hermit_dav/htilde_mat.irp.f
Normal file
93
src/non_hermit_dav/htilde_mat.irp.f
Normal file
@ -0,0 +1,93 @@
|
||||
BEGIN_PROVIDER [ integer, n_mat]
|
||||
implicit none
|
||||
n_mat = 2
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, h_non_hermit, (n_mat, n_mat)]
|
||||
&BEGIN_PROVIDER [ double precision, h_non_hermit_transp, (n_mat, n_mat)]
|
||||
&BEGIN_PROVIDER [ double precision, reigvec_ht, (n_mat, n_mat)]
|
||||
&BEGIN_PROVIDER [ double precision, leigvec_ht, (n_mat, n_mat)]
|
||||
&BEGIN_PROVIDER [ double precision, eigval_ht, (n_mat)]
|
||||
&BEGIN_PROVIDER [ integer, n_real_ht, (n_mat)]
|
||||
implicit none
|
||||
integer :: i,j
|
||||
do i = 1, n_mat
|
||||
read(33,*)h_non_hermit(i,1:n_mat)
|
||||
enddo
|
||||
print*,''
|
||||
print*,'H_mat '
|
||||
print*,''
|
||||
do i = 1, n_mat
|
||||
write(*,'(1000(F16.10,X))')h_non_hermit(i,:)
|
||||
enddo
|
||||
do i = 1, n_mat
|
||||
do j = 1, n_mat
|
||||
h_non_hermit_transp(j,i) = h_non_hermit(i,j)
|
||||
enddo
|
||||
enddo
|
||||
call non_hrmt_real_diag(n_mat,h_non_hermit,reigvec_ht,leigvec_ht,n_real_ht,eigval_ht)
|
||||
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
subroutine hcalc_r_tmp(v,u,N_st,sze) ! v = H u
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Template of routine for the application of H
|
||||
!
|
||||
! Here, it is done with the Hamiltonian matrix
|
||||
!
|
||||
! on the set of determinants of psi_det
|
||||
!
|
||||
! Computes $v = H | u \rangle$
|
||||
!
|
||||
END_DOC
|
||||
integer, intent(in) :: N_st,sze
|
||||
double precision, intent(in) :: u(sze,N_st)
|
||||
double precision, intent(inout) :: v(sze,N_st)
|
||||
integer :: i,j,istate
|
||||
v = 0.d0
|
||||
do istate = 1, N_st
|
||||
do j = 1, sze
|
||||
do i = 1, sze
|
||||
v(i,istate) += h_non_hermit(i,j) * u(j,istate)
|
||||
! print*,i,j,h_non_hermit(i,j),u(j,istate)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
print*,'HU'
|
||||
do i = 1, sze
|
||||
print*,v(i,1)
|
||||
enddo
|
||||
end
|
||||
|
||||
subroutine hcalc_l_tmp(v,u,N_st,sze) ! v = H^\dagger u
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Template of routine for the application of H
|
||||
!
|
||||
! Here, it is done with the Hamiltonian matrix
|
||||
!
|
||||
! on the set of determinants of psi_det
|
||||
!
|
||||
! Computes $v = H | u \rangle$
|
||||
!
|
||||
END_DOC
|
||||
integer, intent(in) :: N_st,sze
|
||||
double precision, intent(in) :: u(sze,N_st)
|
||||
double precision, intent(inout) :: v(sze,N_st)
|
||||
integer :: i,j,istate
|
||||
v = 0.d0
|
||||
do istate = 1, N_st
|
||||
do j = 1, sze
|
||||
do i = 1, sze
|
||||
v(i,istate) += h_non_hermit_transp(i,j) * u(j,istate)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
print*,'HU'
|
||||
do i = 1, sze
|
||||
print*,v(i,1)
|
||||
enddo
|
||||
end
|
||||
2907
src/non_hermit_dav/lapack_diag_non_hermit.irp.f
Normal file
2907
src/non_hermit_dav/lapack_diag_non_hermit.irp.f
Normal file
File diff suppressed because it is too large
Load Diff
670
src/non_hermit_dav/new_routines.irp.f
Normal file
670
src/non_hermit_dav/new_routines.irp.f
Normal file
@ -0,0 +1,670 @@
|
||||
subroutine non_hrmt_diag_split_degen_bi_orthog(n, A, leigvec, reigvec, n_real_eigv, eigval)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! routine which returns the sorted REAL EIGENVALUES ONLY and corresponding LEFT/RIGHT eigenvetors
|
||||
!
|
||||
! of a non hermitian matrix A(n,n)
|
||||
!
|
||||
! n_real_eigv is the number of real eigenvalues, which might be smaller than the dimension "n"
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: n
|
||||
double precision, intent(in) :: A(n,n)
|
||||
integer, intent(out) :: n_real_eigv
|
||||
double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n)
|
||||
double precision, allocatable :: reigvec_tmp(:,:), leigvec_tmp(:,:)
|
||||
|
||||
integer :: i, j, n_degen,k , iteration
|
||||
double precision :: shift_current
|
||||
double precision :: r,thr,accu_d, accu_nd
|
||||
integer, allocatable :: iorder_origin(:),iorder(:)
|
||||
double precision, allocatable :: WR(:), WI(:), Vl(:,:), VR(:,:),S(:,:)
|
||||
double precision, allocatable :: Aw(:,:),diag_elem(:),A_save(:,:)
|
||||
double precision, allocatable :: im_part(:),re_part(:)
|
||||
double precision :: accu,thr_cut, thr_norm=1d0
|
||||
|
||||
|
||||
thr_cut = 1.d-15
|
||||
print*,'Computing the left/right eigenvectors ...'
|
||||
print*,'Using the degeneracy splitting algorithm'
|
||||
! initialization
|
||||
shift_current = 1.d-15
|
||||
iteration = 0
|
||||
print*,'***** iteration = ',iteration
|
||||
|
||||
|
||||
! pre-processing the matrix :: sorting by diagonal elements
|
||||
allocate(reigvec_tmp(n,n), leigvec_tmp(n,n))
|
||||
allocate(diag_elem(n),iorder_origin(n),A_save(n,n))
|
||||
! print*,'Aw'
|
||||
do i = 1, n
|
||||
iorder_origin(i) = i
|
||||
diag_elem(i) = A(i,i)
|
||||
! write(*,'(100(F16.10,X))')A(:,i)
|
||||
enddo
|
||||
call dsort(diag_elem, iorder_origin, n)
|
||||
do i = 1, n
|
||||
do j = 1, n
|
||||
A_save(j,i) = A(iorder_origin(j),iorder_origin(i))
|
||||
enddo
|
||||
enddo
|
||||
|
||||
allocate(WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n))
|
||||
allocate(im_part(n),iorder(n))
|
||||
allocate( S(n,n) )
|
||||
|
||||
|
||||
Aw = A_save
|
||||
call cancel_small_elmts(aw,n,thr_cut)
|
||||
call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
|
||||
do i = 1, n
|
||||
im_part(i) = -dabs(WI(i))
|
||||
iorder(i) = i
|
||||
enddo
|
||||
call dsort(im_part, iorder, n)
|
||||
n_real_eigv = 0
|
||||
do i = 1, n
|
||||
if(dabs(WI(i)).lt.1.d-20)then
|
||||
n_real_eigv += 1
|
||||
else
|
||||
! print*,'Found an imaginary component to eigenvalue'
|
||||
! print*,'Re(i) + Im(i)',WR(i),WI(i)
|
||||
endif
|
||||
enddo
|
||||
if(n_real_eigv.ne.n)then
|
||||
shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
|
||||
print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
|
||||
print*,'Splitting the degeneracies by ',shift_current
|
||||
else
|
||||
print*,'All eigenvalues are real !'
|
||||
endif
|
||||
|
||||
|
||||
do while(n_real_eigv.ne.n)
|
||||
iteration += 1
|
||||
print*,'***** iteration = ',iteration
|
||||
if(shift_current.gt.1.d-3)then
|
||||
print*,'shift_current > 1.d-3 !!'
|
||||
print*,'Your matrix intrinsically contains complex eigenvalues'
|
||||
stop
|
||||
endif
|
||||
Aw = A_save
|
||||
call cancel_small_elmts(Aw,n,thr_cut)
|
||||
call split_matrix_degen(Aw,n,shift_current)
|
||||
call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
|
||||
n_real_eigv = 0
|
||||
do i = 1, n
|
||||
if(dabs(WI(i)).lt.1.d-20)then
|
||||
n_real_eigv+= 1
|
||||
else
|
||||
! print*,'Found an imaginary component to eigenvalue'
|
||||
! print*,'Re(i) + Im(i)',WR(i),WI(i)
|
||||
endif
|
||||
enddo
|
||||
if(n_real_eigv.ne.n)then
|
||||
do i = 1, n
|
||||
im_part(i) = -dabs(WI(i))
|
||||
iorder(i) = i
|
||||
enddo
|
||||
call dsort(im_part, iorder, n)
|
||||
shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
|
||||
print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
|
||||
print*,'Splitting the degeneracies by ',shift_current
|
||||
else
|
||||
print*,'All eigenvalues are real !'
|
||||
endif
|
||||
enddo
|
||||
!!!!!!!!!!!!!!!! SORTING THE EIGENVALUES
|
||||
do i = 1, n
|
||||
eigval(i) = WR(i)
|
||||
iorder(i) = i
|
||||
enddo
|
||||
call dsort(eigval,iorder,n)
|
||||
do i = 1, n
|
||||
! print*,'eigval(i) = ',eigval(i)
|
||||
reigvec_tmp(:,i) = VR(:,iorder(i))
|
||||
leigvec_tmp(:,i) = Vl(:,iorder(i))
|
||||
enddo
|
||||
|
||||
!!! ONCE ALL EIGENVALUES ARE REAL ::: CHECK BI-ORTHONORMALITY
|
||||
! check bi-orthogonality
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
print *, ' accu_nd bi-orthog = ', accu_nd
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print *, ' '
|
||||
print *, ' bi-orthogonality: not imposed yet'
|
||||
print *, ' '
|
||||
print *, ' '
|
||||
print *, ' orthog between degen eigenvect'
|
||||
print *, ' '
|
||||
double precision, allocatable :: S_nh_inv_half(:,:)
|
||||
allocate(S_nh_inv_half(n,n))
|
||||
logical :: complex_root
|
||||
deallocate(S_nh_inv_half)
|
||||
call impose_orthog_degen_eigvec(n, eigval, reigvec_tmp)
|
||||
call impose_orthog_degen_eigvec(n, eigval, leigvec_tmp)
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print*,'New vectors not bi-orthonormals at ',accu_nd
|
||||
call impose_biorthog_qr(n, n, leigvec_tmp, reigvec_tmp, S)
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print*,'New vectors not bi-orthonormals at ',accu_nd
|
||||
print*,'Must be a deep problem ...'
|
||||
stop
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
|
||||
!! EIGENVECTORS SORTED AND BI-ORTHONORMAL
|
||||
do i = 1, n
|
||||
do j = 1, n
|
||||
VR(iorder_origin(j),i) = reigvec_tmp(j,i)
|
||||
VL(iorder_origin(j),i) = leigvec_tmp(j,i)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
!! RECOMPUTING THE EIGENVALUES
|
||||
eigval = 0.d0
|
||||
do i = 1, n
|
||||
iorder(i) = i
|
||||
accu = 0.d0
|
||||
do j = 1, n
|
||||
accu += VL(j,i) * VR(j,i)
|
||||
do k = 1, n
|
||||
eigval(i) += VL(j,i) * A(j,k) * VR(k,i)
|
||||
enddo
|
||||
enddo
|
||||
eigval(i) *= 1.d0/accu
|
||||
! print*,'eigval(i) = ',eigval(i)
|
||||
enddo
|
||||
!! RESORT JUST TO BE SURE
|
||||
call dsort(eigval, iorder, n)
|
||||
do i = 1, n
|
||||
do j = 1, n
|
||||
reigvec(j,i) = VR(j,iorder(i))
|
||||
leigvec(j,i) = VL(j,iorder(i))
|
||||
enddo
|
||||
enddo
|
||||
print*,'Checking for final reigvec/leigvec'
|
||||
shift_current = max(1.d-10,shift_current)
|
||||
print*,'Thr for eigenvectors = ',shift_current
|
||||
call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, shift_current, thr_norm, .false.)
|
||||
call check_biorthog(n, n, leigvec, reigvec, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
print *, ' accu_nd bi-orthog = ', accu_nd
|
||||
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print*,'Something went wrong in non_hrmt_diag_split_degen_bi_orthog'
|
||||
print*,'Eigenvectors are not bi orthonormal ..'
|
||||
print*,'accu_nd = ',accu_nd
|
||||
stop
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
|
||||
|
||||
subroutine non_hrmt_diag_split_degen_s_inv_half(n, A, leigvec, reigvec, n_real_eigv, eigval)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! routine which returns the sorted REAL EIGENVALUES ONLY and corresponding LEFT/RIGHT eigenvetors
|
||||
!
|
||||
! of a non hermitian matrix A(n,n)
|
||||
!
|
||||
! n_real_eigv is the number of real eigenvalues, which might be smaller than the dimension "n"
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: n
|
||||
double precision, intent(in) :: A(n,n)
|
||||
integer, intent(out) :: n_real_eigv
|
||||
double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n)
|
||||
double precision, allocatable :: reigvec_tmp(:,:), leigvec_tmp(:,:)
|
||||
|
||||
integer :: i, j, n_degen,k , iteration
|
||||
double precision :: shift_current
|
||||
double precision :: r,thr,accu_d, accu_nd
|
||||
integer, allocatable :: iorder_origin(:),iorder(:)
|
||||
double precision, allocatable :: WR(:), WI(:), Vl(:,:), VR(:,:),S(:,:)
|
||||
double precision, allocatable :: Aw(:,:),diag_elem(:),A_save(:,:)
|
||||
double precision, allocatable :: im_part(:),re_part(:)
|
||||
double precision :: accu,thr_cut, thr_norm=1.d0
|
||||
double precision, allocatable :: S_nh_inv_half(:,:)
|
||||
logical :: complex_root
|
||||
|
||||
|
||||
thr_cut = 1.d-15
|
||||
print*,'Computing the left/right eigenvectors ...'
|
||||
print*,'Using the degeneracy splitting algorithm'
|
||||
! initialization
|
||||
shift_current = 1.d-15
|
||||
iteration = 0
|
||||
print*,'***** iteration = ',iteration
|
||||
|
||||
|
||||
! pre-processing the matrix :: sorting by diagonal elements
|
||||
allocate(reigvec_tmp(n,n), leigvec_tmp(n,n))
|
||||
allocate(diag_elem(n),iorder_origin(n),A_save(n,n))
|
||||
! print*,'Aw'
|
||||
do i = 1, n
|
||||
iorder_origin(i) = i
|
||||
diag_elem(i) = A(i,i)
|
||||
! write(*,'(100(F16.10,X))')A(:,i)
|
||||
enddo
|
||||
call dsort(diag_elem, iorder_origin, n)
|
||||
do i = 1, n
|
||||
do j = 1, n
|
||||
A_save(j,i) = A(iorder_origin(j),iorder_origin(i))
|
||||
enddo
|
||||
enddo
|
||||
|
||||
allocate(WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n))
|
||||
allocate(im_part(n),iorder(n))
|
||||
allocate( S(n,n) )
|
||||
allocate(S_nh_inv_half(n,n))
|
||||
|
||||
|
||||
Aw = A_save
|
||||
call cancel_small_elmts(aw,n,thr_cut)
|
||||
call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
|
||||
do i = 1, n
|
||||
im_part(i) = -dabs(WI(i))
|
||||
iorder(i) = i
|
||||
enddo
|
||||
call dsort(im_part, iorder, n)
|
||||
n_real_eigv = 0
|
||||
do i = 1, n
|
||||
if(dabs(WI(i)).lt.1.d-20)then
|
||||
n_real_eigv += 1
|
||||
else
|
||||
! print*,'Found an imaginary component to eigenvalue'
|
||||
! print*,'Re(i) + Im(i)',WR(i),WI(i)
|
||||
endif
|
||||
enddo
|
||||
if(n_real_eigv.ne.n)then
|
||||
shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
|
||||
print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
|
||||
print*,'Splitting the degeneracies by ',shift_current
|
||||
else
|
||||
print*,'All eigenvalues are real !'
|
||||
endif
|
||||
|
||||
|
||||
do while(n_real_eigv.ne.n)
|
||||
iteration += 1
|
||||
print*,'***** iteration = ',iteration
|
||||
if(shift_current.gt.1.d-3)then
|
||||
print*,'shift_current > 1.d-3 !!'
|
||||
print*,'Your matrix intrinsically contains complex eigenvalues'
|
||||
stop
|
||||
endif
|
||||
Aw = A_save
|
||||
! thr_cut = shift_current
|
||||
call cancel_small_elmts(Aw,n,thr_cut)
|
||||
call split_matrix_degen(Aw,n,shift_current)
|
||||
call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
|
||||
n_real_eigv = 0
|
||||
do i = 1, n
|
||||
if(dabs(WI(i)).lt.1.d-20)then
|
||||
n_real_eigv+= 1
|
||||
else
|
||||
! print*,'Found an imaginary component to eigenvalue'
|
||||
! print*,'Re(i) + Im(i)',WR(i),WI(i)
|
||||
endif
|
||||
enddo
|
||||
if(n_real_eigv.ne.n)then
|
||||
do i = 1, n
|
||||
im_part(i) = -dabs(WI(i))
|
||||
iorder(i) = i
|
||||
enddo
|
||||
call dsort(im_part, iorder, n)
|
||||
shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
|
||||
print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
|
||||
print*,'Splitting the degeneracies by ',shift_current
|
||||
else
|
||||
print*,'All eigenvalues are real !'
|
||||
endif
|
||||
enddo
|
||||
!!!!!!!!!!!!!!!! SORTING THE EIGENVALUES
|
||||
do i = 1, n
|
||||
eigval(i) = WR(i)
|
||||
iorder(i) = i
|
||||
enddo
|
||||
call dsort(eigval,iorder,n)
|
||||
do i = 1, n
|
||||
! print*,'eigval(i) = ',eigval(i)
|
||||
reigvec_tmp(:,i) = VR(:,iorder(i))
|
||||
leigvec_tmp(:,i) = Vl(:,iorder(i))
|
||||
enddo
|
||||
|
||||
!!! ONCE ALL EIGENVALUES ARE REAL ::: CHECK BI-ORTHONORMALITY
|
||||
! check bi-orthogonality
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
print *, ' accu_nd bi-orthog = ', accu_nd
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print *, ' '
|
||||
print *, ' bi-orthogonality: not imposed yet'
|
||||
if(complex_root) then
|
||||
print *, ' '
|
||||
print *, ' '
|
||||
print *, ' orthog between degen eigenvect'
|
||||
print *, ' '
|
||||
! bi-orthonormalization using orthogonalization of left, right and then QR between left and right
|
||||
call impose_orthog_degen_eigvec(n, eigval, reigvec_tmp) ! orthogonalization of reigvec
|
||||
call impose_orthog_degen_eigvec(n, eigval, leigvec_tmp) ! orthogonalization of leigvec
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print*,'New vectors not bi-orthonormals at ', accu_nd
|
||||
call get_inv_half_nonsymmat_diago(S, n, S_nh_inv_half, complex_root)
|
||||
if(complex_root)then
|
||||
call impose_biorthog_qr(n, n, leigvec_tmp, reigvec_tmp, S) ! bi-orthonormalization using QR
|
||||
else
|
||||
print*,'S^{-1/2} exists !!'
|
||||
call bi_ortho_s_inv_half(n,leigvec_tmp,reigvec_tmp,S_nh_inv_half) ! use of S^{-1/2} bi-orthonormalization
|
||||
endif
|
||||
endif
|
||||
else ! the matrix S^{-1/2} exists
|
||||
print*,'S^{-1/2} exists !!'
|
||||
call bi_ortho_s_inv_half(n,leigvec_tmp,reigvec_tmp,S_nh_inv_half) ! use of S^{-1/2} bi-orthonormalization
|
||||
endif
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print*,'New vectors not bi-orthonormals at ',accu_nd
|
||||
print*,'Must be a deep problem ...'
|
||||
stop
|
||||
endif
|
||||
endif
|
||||
|
||||
!! EIGENVECTORS SORTED AND BI-ORTHONORMAL
|
||||
do i = 1, n
|
||||
do j = 1, n
|
||||
VR(iorder_origin(j),i) = reigvec_tmp(j,i)
|
||||
VL(iorder_origin(j),i) = leigvec_tmp(j,i)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
!! RECOMPUTING THE EIGENVALUES
|
||||
eigval = 0.d0
|
||||
do i = 1, n
|
||||
iorder(i) = i
|
||||
accu = 0.d0
|
||||
do j = 1, n
|
||||
accu += VL(j,i) * VR(j,i)
|
||||
do k = 1, n
|
||||
eigval(i) += VL(j,i) * A(j,k) * VR(k,i)
|
||||
enddo
|
||||
enddo
|
||||
eigval(i) *= 1.d0/accu
|
||||
! print*,'eigval(i) = ',eigval(i)
|
||||
enddo
|
||||
!! RESORT JUST TO BE SURE
|
||||
call dsort(eigval, iorder, n)
|
||||
do i = 1, n
|
||||
do j = 1, n
|
||||
reigvec(j,i) = VR(j,iorder(i))
|
||||
leigvec(j,i) = VL(j,iorder(i))
|
||||
enddo
|
||||
enddo
|
||||
print*,'Checking for final reigvec/leigvec'
|
||||
shift_current = max(1.d-10,shift_current)
|
||||
print*,'Thr for eigenvectors = ',shift_current
|
||||
call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, shift_current, thr_norm, .false.)
|
||||
call check_biorthog(n, n, leigvec, reigvec, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
print *, ' accu_nd bi-orthog = ', accu_nd
|
||||
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print*,'Something went wrong in non_hrmt_diag_split_degen_bi_orthog'
|
||||
print*,'Eigenvectors are not bi orthonormal ..'
|
||||
print*,'accu_nd = ',accu_nd
|
||||
stop
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
|
||||
subroutine non_hrmt_fock_mat(n, A, leigvec, reigvec, n_real_eigv, eigval)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! routine returning the eigenvalues and left/right eigenvectors of the TC fock matrix
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: n
|
||||
double precision, intent(in) :: A(n,n)
|
||||
integer, intent(out) :: n_real_eigv
|
||||
double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n)
|
||||
double precision, allocatable :: reigvec_tmp(:,:), leigvec_tmp(:,:)
|
||||
|
||||
integer :: i, j, n_degen,k , iteration
|
||||
double precision :: shift_current
|
||||
double precision :: r,thr,accu_d, accu_nd
|
||||
integer, allocatable :: iorder_origin(:),iorder(:)
|
||||
double precision, allocatable :: WR(:), WI(:), Vl(:,:), VR(:,:),S(:,:)
|
||||
double precision, allocatable :: Aw(:,:),diag_elem(:),A_save(:,:)
|
||||
double precision, allocatable :: im_part(:),re_part(:)
|
||||
double precision :: accu,thr_cut
|
||||
double precision, allocatable :: S_nh_inv_half(:,:)
|
||||
logical :: complex_root
|
||||
double precision :: thr_norm=1d0
|
||||
|
||||
|
||||
thr_cut = 1.d-15
|
||||
print*,'Computing the left/right eigenvectors ...'
|
||||
print*,'Using the degeneracy splitting algorithm'
|
||||
! initialization
|
||||
shift_current = 1.d-15
|
||||
iteration = 0
|
||||
print*,'***** iteration = ',iteration
|
||||
|
||||
|
||||
! pre-processing the matrix :: sorting by diagonal elements
|
||||
allocate(reigvec_tmp(n,n), leigvec_tmp(n,n))
|
||||
allocate(diag_elem(n),iorder_origin(n),A_save(n,n))
|
||||
! print*,'Aw'
|
||||
do i = 1, n
|
||||
iorder_origin(i) = i
|
||||
diag_elem(i) = A(i,i)
|
||||
! write(*,'(100(F16.10,X))')A(:,i)
|
||||
enddo
|
||||
call dsort(diag_elem, iorder_origin, n)
|
||||
do i = 1, n
|
||||
do j = 1, n
|
||||
A_save(j,i) = A(iorder_origin(j),iorder_origin(i))
|
||||
enddo
|
||||
enddo
|
||||
|
||||
allocate(WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n))
|
||||
allocate(im_part(n),iorder(n))
|
||||
allocate( S(n,n) )
|
||||
allocate(S_nh_inv_half(n,n))
|
||||
|
||||
|
||||
Aw = A_save
|
||||
call cancel_small_elmts(aw,n,thr_cut)
|
||||
call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
|
||||
do i = 1, n
|
||||
im_part(i) = -dabs(WI(i))
|
||||
iorder(i) = i
|
||||
enddo
|
||||
call dsort(im_part, iorder, n)
|
||||
n_real_eigv = 0
|
||||
do i = 1, n
|
||||
if(dabs(WI(i)).lt.1.d-20)then
|
||||
n_real_eigv += 1
|
||||
else
|
||||
! print*,'Found an imaginary component to eigenvalue'
|
||||
! print*,'Re(i) + Im(i)',WR(i),WI(i)
|
||||
endif
|
||||
enddo
|
||||
if(n_real_eigv.ne.n)then
|
||||
shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
|
||||
print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
|
||||
print*,'Splitting the degeneracies by ',shift_current
|
||||
else
|
||||
print*,'All eigenvalues are real !'
|
||||
endif
|
||||
|
||||
|
||||
do while(n_real_eigv.ne.n)
|
||||
iteration += 1
|
||||
print*,'***** iteration = ',iteration
|
||||
if(shift_current.gt.1.d-3)then
|
||||
print*,'shift_current > 1.d-3 !!'
|
||||
print*,'Your matrix intrinsically contains complex eigenvalues'
|
||||
stop
|
||||
endif
|
||||
Aw = A_save
|
||||
! thr_cut = shift_current
|
||||
call cancel_small_elmts(Aw,n,thr_cut)
|
||||
call split_matrix_degen(Aw,n,shift_current)
|
||||
call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
|
||||
n_real_eigv = 0
|
||||
do i = 1, n
|
||||
if(dabs(WI(i)).lt.1.d-20)then
|
||||
n_real_eigv+= 1
|
||||
else
|
||||
! print*,'Found an imaginary component to eigenvalue'
|
||||
! print*,'Re(i) + Im(i)',WR(i),WI(i)
|
||||
endif
|
||||
enddo
|
||||
if(n_real_eigv.ne.n)then
|
||||
do i = 1, n
|
||||
im_part(i) = -dabs(WI(i))
|
||||
iorder(i) = i
|
||||
enddo
|
||||
call dsort(im_part, iorder, n)
|
||||
shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
|
||||
print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
|
||||
print*,'Splitting the degeneracies by ',shift_current
|
||||
else
|
||||
print*,'All eigenvalues are real !'
|
||||
endif
|
||||
enddo
|
||||
!!!!!!!!!!!!!!!! SORTING THE EIGENVALUES
|
||||
do i = 1, n
|
||||
eigval(i) = WR(i)
|
||||
iorder(i) = i
|
||||
enddo
|
||||
call dsort(eigval,iorder,n)
|
||||
do i = 1, n
|
||||
! print*,'eigval(i) = ',eigval(i)
|
||||
reigvec_tmp(:,i) = VR(:,iorder(i))
|
||||
leigvec_tmp(:,i) = Vl(:,iorder(i))
|
||||
enddo
|
||||
|
||||
!!! ONCE ALL EIGENVALUES ARE REAL ::: CHECK BI-ORTHONORMALITY
|
||||
! check bi-orthogonality
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
print *, ' accu_nd bi-orthog = ', accu_nd
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print *, ' '
|
||||
print *, ' bi-orthogonality: not imposed yet'
|
||||
print *, ' '
|
||||
print *, ' '
|
||||
print *, ' Using impose_unique_biorthog_degen_eigvec'
|
||||
print *, ' '
|
||||
! bi-orthonormalization using orthogonalization of left, right and then QR between left and right
|
||||
call impose_unique_biorthog_degen_eigvec(n, eigval, mo_coef, leigvec_tmp, reigvec_tmp)
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
print*,'accu_nd = ',accu_nd
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print*,'New vectors not bi-orthonormals at ',accu_nd
|
||||
call get_inv_half_nonsymmat_diago(S, n, S_nh_inv_half,complex_root)
|
||||
if(complex_root)then
|
||||
print*,'S^{-1/2} does not exits, using QR bi-orthogonalization'
|
||||
call impose_biorthog_qr(n, n, leigvec_tmp, reigvec_tmp, S) ! bi-orthonormalization using QR
|
||||
else
|
||||
print*,'S^{-1/2} exists !!'
|
||||
call bi_ortho_s_inv_half(n,leigvec_tmp,reigvec_tmp,S_nh_inv_half) ! use of S^{-1/2} bi-orthonormalization
|
||||
endif
|
||||
endif
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print*,'New vectors not bi-orthonormals at ',accu_nd
|
||||
print*,'Must be a deep problem ...'
|
||||
stop
|
||||
endif
|
||||
endif
|
||||
|
||||
!! EIGENVECTORS SORTED AND BI-ORTHONORMAL
|
||||
do i = 1, n
|
||||
do j = 1, n
|
||||
VR(iorder_origin(j),i) = reigvec_tmp(j,i)
|
||||
VL(iorder_origin(j),i) = leigvec_tmp(j,i)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
!! RECOMPUTING THE EIGENVALUES
|
||||
eigval = 0.d0
|
||||
do i = 1, n
|
||||
iorder(i) = i
|
||||
accu = 0.d0
|
||||
do j = 1, n
|
||||
accu += VL(j,i) * VR(j,i)
|
||||
do k = 1, n
|
||||
eigval(i) += VL(j,i) * A(j,k) * VR(k,i)
|
||||
enddo
|
||||
enddo
|
||||
eigval(i) *= 1.d0/accu
|
||||
! print*,'eigval(i) = ',eigval(i)
|
||||
enddo
|
||||
!! RESORT JUST TO BE SURE
|
||||
call dsort(eigval, iorder, n)
|
||||
do i = 1, n
|
||||
do j = 1, n
|
||||
reigvec(j,i) = VR(j,iorder(i))
|
||||
leigvec(j,i) = VL(j,iorder(i))
|
||||
enddo
|
||||
enddo
|
||||
print*,'Checking for final reigvec/leigvec'
|
||||
shift_current = max(1.d-10,shift_current)
|
||||
print*,'Thr for eigenvectors = ',shift_current
|
||||
call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, shift_current, thr_norm, .false.)
|
||||
call check_biorthog(n, n, leigvec, reigvec, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
print *, ' accu_nd bi-orthog = ', accu_nd
|
||||
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print*,'Something went wrong in non_hrmt_diag_split_degen_bi_orthog'
|
||||
print*,'Eigenvectors are not bi orthonormal ..'
|
||||
print*,'accu_nd = ',accu_nd
|
||||
stop
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
|
||||
53
src/non_hermit_dav/project.irp.f
Normal file
53
src/non_hermit_dav/project.irp.f
Normal file
@ -0,0 +1,53 @@
|
||||
subroutine h_non_hermite(v,u,Hmat,a,N_st,sze)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Template of routine for the application of H
|
||||
!
|
||||
! Here, it is done with the Hamiltonian matrix
|
||||
!
|
||||
! on the set of determinants of psi_det
|
||||
!
|
||||
! Computes $v = a * H | u \rangle$
|
||||
!
|
||||
END_DOC
|
||||
integer, intent(in) :: N_st,sze
|
||||
double precision, intent(in) :: u(sze,N_st), Hmat(sze,sze), a
|
||||
double precision, intent(inout) :: v(sze,N_st)
|
||||
integer :: i,j,k
|
||||
do k = 1, N_st
|
||||
do j = 1, sze
|
||||
do i = 1, sze
|
||||
v(i,k) += a * u(j,k) * Hmat(i,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
end
|
||||
|
||||
|
||||
subroutine exp_tau_H(u,v,hmat,tau,et,N_st,sze)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! realises v = (1 - tau (H - et)) u
|
||||
END_DOC
|
||||
integer, intent(in) :: N_st,sze
|
||||
double precision, intent(in) :: hmat(sze,sze), u(sze,N_st), tau, et
|
||||
double precision, intent(out):: v(sze,N_st)
|
||||
double precision :: a
|
||||
integer :: i,j
|
||||
v = (1.d0 + tau * et) * u
|
||||
a = -1.d0 * tau
|
||||
call h_non_hermite(v,u,Hmat,a,N_st,sze)
|
||||
end
|
||||
|
||||
double precision function project_phi0(u,Hmat0,N_st,sze)
|
||||
implicit none
|
||||
integer, intent(in) :: N_st,sze
|
||||
double precision, intent(in) :: u(sze,N_st), Hmat0(sze)
|
||||
integer :: j
|
||||
project_phi0 = 0.d0
|
||||
do j = 1, sze
|
||||
project_phi0 += u(j,1) * Hmat0(j)
|
||||
enddo
|
||||
project_phi0 *= 1.d0 / u(1,1)
|
||||
end
|
||||
|
||||
325
src/non_hermit_dav/utils.irp.f
Normal file
325
src/non_hermit_dav/utils.irp.f
Normal file
@ -0,0 +1,325 @@
|
||||
|
||||
subroutine get_inv_half_svd(matrix, n, matrix_inv_half)
|
||||
|
||||
BEGIN_DOC
|
||||
! :math:`X = S^{-1/2}` obtained by SVD
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: n
|
||||
double precision, intent(in) :: matrix(n,n)
|
||||
double precision, intent(out) :: matrix_inv_half(n,n)
|
||||
|
||||
integer :: num_linear_dependencies
|
||||
integer :: LDA, LDC
|
||||
integer :: info, i, j, k
|
||||
double precision, parameter :: threshold = 1.d-6
|
||||
double precision, allocatable :: U(:,:),Vt(:,:), D(:),matrix_half(:,:),D_half(:)
|
||||
|
||||
double precision :: accu_d,accu_nd
|
||||
|
||||
LDA = size(matrix, 1)
|
||||
LDC = size(matrix_inv_half, 1)
|
||||
if(LDA .ne. LDC) then
|
||||
print*, ' LDA != LDC'
|
||||
stop
|
||||
endif
|
||||
|
||||
print*, ' n = ', n
|
||||
print*, ' LDA = ', LDA
|
||||
print*, ' LDC = ', LDC
|
||||
|
||||
double precision,allocatable :: WR(:),WI(:),VL(:,:),VR(:,:)
|
||||
allocate(WR(n),WI(n),VL(n,n),VR(n,n))
|
||||
call lapack_diag_non_sym(n,matrix,WR,WI,VL,VR)
|
||||
do i = 1, n
|
||||
print*,'WR,WI',WR(i),WI(i)
|
||||
enddo
|
||||
|
||||
|
||||
allocate(U(LDC,n), Vt(LDA,n), D(n))
|
||||
|
||||
call svd(matrix, LDA, U, LDC, D, Vt, LDA, n, n)
|
||||
double precision, allocatable :: tmp1(:,:),tmp2(:,:),D_mat(:,:)
|
||||
allocate(tmp1(n,n),tmp2(n,n),D_mat(n,n),matrix_half(n,n),D_half(n))
|
||||
D_mat = 0.d0
|
||||
do i = 1,n
|
||||
D_mat(i,i) = D(i)
|
||||
enddo
|
||||
! matrix = U D Vt
|
||||
! tmp1 = U D
|
||||
tmp1 = 0.d0
|
||||
call dgemm( 'N', 'N', n, n, n, 1.d0 &
|
||||
, U, size(U, 1), D_mat, size(D_mat, 1) &
|
||||
, 0.d0, tmp1, size(tmp1, 1) )
|
||||
! tmp2 = tmp1 X Vt = matrix
|
||||
tmp2 = 0.d0
|
||||
call dgemm( 'N', 'N', n, n, n, 1.d0 &
|
||||
, tmp1, size(tmp1, 1), Vt, size(Vt, 1) &
|
||||
, 0.d0, tmp2, size(tmp2, 1) )
|
||||
print*,'Checking the recomposition of the matrix'
|
||||
accu_nd = 0.d0
|
||||
accu_d = 0.d0
|
||||
do i = 1, n
|
||||
accu_d += dabs(tmp2(i,i) - matrix(i,i))
|
||||
do j = 1, n
|
||||
if(i==j)cycle
|
||||
accu_nd += dabs(tmp2(j,i) - matrix(j,i))
|
||||
enddo
|
||||
enddo
|
||||
print*,'accu_d =',accu_d
|
||||
print*,'accu_nd =',accu_nd
|
||||
print*,'passed the recomposition'
|
||||
|
||||
num_linear_dependencies = 0
|
||||
do i = 1, n
|
||||
if(abs(D(i)) <= threshold) then
|
||||
D(i) = 0.d0
|
||||
num_linear_dependencies += 1
|
||||
else
|
||||
ASSERT (D(i) > 0.d0)
|
||||
D_half(i) = dsqrt(D(i))
|
||||
D(i) = 1.d0 / dsqrt(D(i))
|
||||
endif
|
||||
enddo
|
||||
write(*,*) ' linear dependencies', num_linear_dependencies
|
||||
|
||||
matrix_inv_half = 0.d0
|
||||
matrix_half = 0.d0
|
||||
do k = 1, n
|
||||
if(D(k) /= 0.d0) then
|
||||
do j = 1, n
|
||||
do i = 1, n
|
||||
! matrix_inv_half(i,j) = matrix_inv_half(i,j) + U(i,k) * D(k) * Vt(k,j)
|
||||
matrix_inv_half(i,j) = matrix_inv_half(i,j) + U(i,k) * D(k) * Vt(j,k)
|
||||
matrix_half(i,j) = matrix_half(i,j) + U(i,k) * D_half(k) * Vt(j,k)
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
print*,'testing S^1/2 * S^1/2= S'
|
||||
! tmp1 = S^1/2 X S^1/2
|
||||
tmp1 = 0.d0
|
||||
call dgemm( 'N', 'N', n, n, n, 1.d0 &
|
||||
, matrix_half, size(matrix_half, 1), matrix_half, size(matrix_half, 1) &
|
||||
, 0.d0, tmp1, size(tmp1, 1) )
|
||||
accu_nd = 0.d0
|
||||
accu_d = 0.d0
|
||||
do i = 1, n
|
||||
accu_d += dabs(tmp1(i,i) - matrix(i,i))
|
||||
do j = 1, n
|
||||
if(i==j)cycle
|
||||
accu_nd += dabs(tmp1(j,i) - matrix(j,i))
|
||||
enddo
|
||||
enddo
|
||||
print*,'accu_d =',accu_d
|
||||
print*,'accu_nd =',accu_nd
|
||||
|
||||
! print*,'S inv half'
|
||||
! do i = 1, n
|
||||
! write(*, '(1000(F16.10,X))') matrix_inv_half(i,:)
|
||||
! enddo
|
||||
|
||||
double precision, allocatable :: pseudo_inverse(:,:),identity(:,:)
|
||||
allocate( pseudo_inverse(n,n),identity(n,n))
|
||||
call get_pseudo_inverse(matrix,n,n,n,pseudo_inverse,n,threshold)
|
||||
|
||||
! S^-1 X S = 1
|
||||
! identity = 0.d0
|
||||
! call dgemm( 'N', 'N', n, n, n, 1.d0 &
|
||||
! , matrix, size(matrix, 1), pseudo_inverse, size(pseudo_inverse, 1) &
|
||||
! , 0.d0, identity, size(identity, 1) )
|
||||
print*,'Checking S^-1/2 X S^-1/2 = S^-1 ?'
|
||||
! S^-1/2 X S^-1/2 = S^-1 ?
|
||||
tmp1 = 0.d0
|
||||
call dgemm( 'N', 'N', n, n, n, 1.d0 &
|
||||
,matrix_inv_half, size(matrix_inv_half, 1), matrix_inv_half, size(matrix_inv_half, 1) &
|
||||
, 0.d0, tmp1, size(tmp1, 1) )
|
||||
accu_nd = 0.d0
|
||||
accu_d = 0.d0
|
||||
do i = 1, n
|
||||
accu_d += dabs(1.d0 - pseudo_inverse(i,i))
|
||||
do j = 1, n
|
||||
if(i==j)cycle
|
||||
accu_nd += dabs(tmp1(j,i) - pseudo_inverse(j,i))
|
||||
enddo
|
||||
enddo
|
||||
print*,'accu_d =',accu_d
|
||||
print*,'accu_nd =',accu_nd
|
||||
|
||||
stop
|
||||
!
|
||||
! ! ( S^-1/2 x S ) x S^-1/2
|
||||
! Stmp2 = 0.d0
|
||||
! call dgemm( 'N', 'N', n, n, n, 1.d0 &
|
||||
! , Stmp, size(Stmp, 1), matrix_inv_half, size(matrix_inv_half, 1) &
|
||||
! , 0.d0, Stmp2, size(Stmp2, 1) )
|
||||
|
||||
! S^-1/2 x ( S^-1/2 x S )
|
||||
! Stmp2 = 0.d0
|
||||
! call dgemm( 'N', 'N', n, n, n, 1.d0 &
|
||||
! , matrix_inv_half, size(matrix_inv_half, 1), Stmp, size(Stmp, 1) &
|
||||
! , 0.d0, Stmp2, size(Stmp2, 1) )
|
||||
|
||||
! do i = 1, n
|
||||
! do j = 1, n
|
||||
! if(i==j) then
|
||||
! accu_d += Stmp2(j,i)
|
||||
! else
|
||||
! accu_nd = accu_nd + Stmp2(j,i) * Stmp2(j,i)
|
||||
! endif
|
||||
! enddo
|
||||
! enddo
|
||||
! accu_nd = dsqrt(accu_nd)
|
||||
! print*, ' after S^-1/2: sum of off-diag S elements = ', accu_nd
|
||||
! print*, ' after S^-1/2: sum of diag S elements = ', accu_d
|
||||
! do i = 1, n
|
||||
! write(*,'(1000(F16.10,X))') Stmp2(i,:)
|
||||
! enddo
|
||||
|
||||
!double precision :: thresh
|
||||
!thresh = 1.d-10
|
||||
!if( accu_nd.gt.thresh .or. dabs(accu_d-dble(n)).gt.thresh) then
|
||||
! stop
|
||||
!endif
|
||||
|
||||
end subroutine get_inv_half_svd
|
||||
|
||||
! ---
|
||||
|
||||
subroutine get_inv_half_nonsymmat_diago(matrix, n, matrix_inv_half, complex_root)
|
||||
|
||||
BEGIN_DOC
|
||||
! input: S = matrix
|
||||
! output: S^{-1/2} = matrix_inv_half obtained by diagonalization
|
||||
!
|
||||
! S = VR D VL^T
|
||||
! = VR D^{1/2} D^{1/2} VL^T
|
||||
! = VR D^{1/2} VL^T VR D^{1/2} VL^T
|
||||
! = S^{1/2} S^{1/2} with S = VR D^{1/2} VL^T
|
||||
!
|
||||
! == > S^{-1/2} = VR D^{-1/2} VL^T
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: n
|
||||
double precision, intent(in) :: matrix(n,n)
|
||||
logical, intent(out) :: complex_root
|
||||
double precision, intent(out) :: matrix_inv_half(n,n)
|
||||
|
||||
integer :: i, j
|
||||
double precision :: accu_d, accu_nd
|
||||
double precision, allocatable :: WR(:), WI(:), VL(:,:), VR(:,:), S(:,:), S_diag(:)
|
||||
double precision, allocatable :: tmp1(:,:), D_mat(:,:)
|
||||
|
||||
complex_root = .False.
|
||||
|
||||
matrix_inv_half = 0.D0
|
||||
print*,'Computing S^{-1/2}'
|
||||
|
||||
allocate(WR(n), WI(n), VL(n,n), VR(n,n))
|
||||
call lapack_diag_non_sym(n, matrix, WR, WI, VL, VR)
|
||||
|
||||
allocate(S(n,n))
|
||||
call check_biorthog(n, n, VL, VR, accu_d, accu_nd, S)
|
||||
print*,'accu_nd S^{-1/2}',accu_nd
|
||||
if(accu_nd.gt.1.d-10) then
|
||||
complex_root = .True. ! if vectors are not bi-orthogonal return
|
||||
print*,'Eigenvectors of S are not bi-orthonormal, skipping S^{-1/2}'
|
||||
return
|
||||
endif
|
||||
|
||||
allocate(S_diag(n))
|
||||
do i = 1, n
|
||||
S_diag(i) = 1.d0/dsqrt(S(i,i))
|
||||
if(dabs(WI(i)).gt.1.d-20.or.WR(i).lt.0.d0)then ! check that eigenvalues are real and positive
|
||||
complex_root = .True.
|
||||
print*,'Eigenvalues of S have imaginary part '
|
||||
print*,'WR(i),WI(i)',WR(i), WR(i)
|
||||
print*,'Skipping S^{-1/2}'
|
||||
return
|
||||
endif
|
||||
enddo
|
||||
deallocate(S)
|
||||
|
||||
if(complex_root) return
|
||||
|
||||
! normalization of vectors
|
||||
do i = 1, n
|
||||
if(S_diag(i).eq.1.d0) cycle
|
||||
do j = 1,n
|
||||
VL(j,i) *= S_diag(i)
|
||||
VR(j,i) *= S_diag(i)
|
||||
enddo
|
||||
enddo
|
||||
deallocate(S_diag)
|
||||
|
||||
allocate(tmp1(n,n), D_mat(n,n))
|
||||
|
||||
D_mat = 0.d0
|
||||
do i = 1, n
|
||||
D_mat(i,i) = 1.d0/dsqrt(WR(i))
|
||||
enddo
|
||||
deallocate(WR, WI)
|
||||
|
||||
! tmp1 = VR D^{-1/2}
|
||||
tmp1 = 0.d0
|
||||
call dgemm( 'N', 'N', n, n, n, 1.d0 &
|
||||
, VR, size(VR, 1), D_mat, size(D_mat, 1) &
|
||||
, 0.d0, tmp1, size(tmp1, 1) )
|
||||
deallocate(VR, D_mat)
|
||||
|
||||
! S^{-1/2} = tmp1 X VL^T
|
||||
matrix_inv_half = 0.d0
|
||||
call dgemm( 'N', 'T', n, n, n, 1.d0 &
|
||||
, tmp1, size(tmp1, 1), VL, size(VL, 1) &
|
||||
, 0.d0, matrix_inv_half, size(matrix_inv_half, 1) )
|
||||
deallocate(tmp1, VL)
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine bi_ortho_s_inv_half(n,leigvec,reigvec,S_nh_inv_half)
|
||||
implicit none
|
||||
integer, intent(in) :: n
|
||||
double precision, intent(in) :: S_nh_inv_half(n,n)
|
||||
double precision, intent(inout) :: leigvec(n,n),reigvec(n,n)
|
||||
BEGIN_DOC
|
||||
! bi-orthonormalization of left and right vectors
|
||||
!
|
||||
! S = VL^T VR
|
||||
!
|
||||
! S^{-1/2} S S^{-1/2} = 1 = S^{-1/2} VL^T VR S^{-1/2} = VL_new^T VR_new
|
||||
!
|
||||
! VL_new = VL (S^{-1/2})^T
|
||||
!
|
||||
! VR_new = VR S^{^{-1/2}}
|
||||
END_DOC
|
||||
double precision,allocatable :: vl_tmp(:,:),vr_tmp(:,:)
|
||||
print*,'Bi-orthonormalization using S^{-1/2}'
|
||||
allocate(vl_tmp(n,n),vr_tmp(n,n))
|
||||
vl_tmp = leigvec
|
||||
vr_tmp = reigvec
|
||||
! VL_new = VL (S^{-1/2})^T
|
||||
call dgemm( 'N', 'T', n, n, n, 1.d0 &
|
||||
, vl_tmp, size(vl_tmp, 1), S_nh_inv_half, size(S_nh_inv_half, 1) &
|
||||
, 0.d0, leigvec, size(leigvec, 1) )
|
||||
! VR_new = VR S^{^{-1/2}}
|
||||
call dgemm( 'N', 'N', n, n, n, 1.d0 &
|
||||
, vr_tmp, size(vr_tmp, 1), S_nh_inv_half, size(S_nh_inv_half, 1) &
|
||||
, 0.d0, reigvec, size(reigvec, 1) )
|
||||
double precision :: accu_d, accu_nd
|
||||
double precision,allocatable :: S(:,:)
|
||||
allocate(S(n,n))
|
||||
call check_biorthog(n, n, leigvec, reigvec, accu_d, accu_nd, S)
|
||||
if(dabs(accu_d - n).gt.1.d-10 .or. accu_nd .gt.1.d-8 )then
|
||||
print*,'Pb in bi_ortho_s_inv_half !!'
|
||||
print*,'accu_d =',accu_d
|
||||
print*,'accu_nd =',accu_nd
|
||||
stop
|
||||
endif
|
||||
end
|
||||
185
src/tc_keywords/EZFIO.cfg
Normal file
185
src/tc_keywords/EZFIO.cfg
Normal file
@ -0,0 +1,185 @@
|
||||
[read_rl_eigv]
|
||||
type: logical
|
||||
doc: If |true|, read the right/left eigenvectors from ezfio
|
||||
interface: ezfio,provider,ocaml
|
||||
default: False
|
||||
|
||||
[comp_left_eigv]
|
||||
type: logical
|
||||
doc: If |true|, computes also the left-eigenvector
|
||||
interface: ezfio,provider,ocaml
|
||||
default: False
|
||||
|
||||
[three_body_h_tc]
|
||||
type: logical
|
||||
doc: If |true|, three-body terms are included
|
||||
interface: ezfio,provider,ocaml
|
||||
default: True
|
||||
|
||||
[pure_three_body_h_tc]
|
||||
type: logical
|
||||
doc: If |true|, pure triple excitation three-body terms are included
|
||||
interface: ezfio,provider,ocaml
|
||||
default: False
|
||||
|
||||
[double_normal_ord]
|
||||
type: logical
|
||||
doc: If |true|, contracted double excitation three-body terms are included
|
||||
interface: ezfio,provider,ocaml
|
||||
default: False
|
||||
|
||||
[core_tc_op]
|
||||
type: logical
|
||||
doc: If |true|, takes the usual Hamiltonian for core orbitals (assumed to be doubly occupied)
|
||||
interface: ezfio,provider,ocaml
|
||||
default: False
|
||||
|
||||
[full_tc_h_solver]
|
||||
type: logical
|
||||
doc: If |true|, you diagonalize the full TC H matrix
|
||||
interface: ezfio,provider,ocaml
|
||||
default: False
|
||||
|
||||
[thresh_it_dav]
|
||||
type: Threshold
|
||||
doc: Thresholds on the energy for iterative Davidson used in TC
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 1.e-5
|
||||
|
||||
[max_it_dav]
|
||||
type: integer
|
||||
doc: nb max of iteration in Davidson used in TC
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 1000
|
||||
|
||||
[thresh_psi_r]
|
||||
type: Threshold
|
||||
doc: Thresholds on the coefficients of the right-eigenvector. Used for PT2 computation.
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 0.000005
|
||||
|
||||
[thresh_psi_r_norm]
|
||||
type: logical
|
||||
doc: If |true|, you prune the WF to compute the PT1 coef based on the norm. If False, the pruning is done through the amplitude on the right-coefficient.
|
||||
interface: ezfio,provider,ocaml
|
||||
default: False
|
||||
|
||||
[state_following_tc]
|
||||
type: logical
|
||||
doc: If |true|, the states are re-ordered to match the input states
|
||||
default: False
|
||||
interface: ezfio,provider,ocaml
|
||||
|
||||
[bi_ortho]
|
||||
type: logical
|
||||
doc: If |true|, the MO basis is assumed to be bi-orthonormal
|
||||
interface: ezfio,provider,ocaml
|
||||
default: True
|
||||
|
||||
[symetric_fock_tc]
|
||||
type: logical
|
||||
doc: If |true|, using F+F^t as Fock TC
|
||||
interface: ezfio,provider,ocaml
|
||||
default: False
|
||||
|
||||
[thresh_tcscf]
|
||||
type: Threshold
|
||||
doc: Threshold on the convergence of the Hartree Fock energy.
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 1.e-12
|
||||
|
||||
[n_it_tcscf_max]
|
||||
type: Strictly_positive_int
|
||||
doc: Maximum number of SCF iterations
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 100
|
||||
|
||||
[j1b_pen]
|
||||
type: double precision
|
||||
doc: exponents of the 1-body Jastrow
|
||||
interface: ezfio
|
||||
size: (nuclei.nucl_num)
|
||||
|
||||
[j1b_coeff]
|
||||
type: double precision
|
||||
doc: coeff of the 1-body Jastrow
|
||||
interface: ezfio
|
||||
size: (nuclei.nucl_num)
|
||||
|
||||
[j1b_type]
|
||||
type: integer
|
||||
doc: type of 1-body Jastrow
|
||||
interface: ezfio, provider, ocaml
|
||||
default: 0
|
||||
|
||||
[thr_degen_tc]
|
||||
type: Threshold
|
||||
doc: Threshold to determine if two orbitals are degenerate in TCSCF in order to avoid random quasi orthogonality between the right- and left-eigenvector for the same eigenvalue
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 1.e-6
|
||||
|
||||
[maxovl_tc]
|
||||
type: logical
|
||||
doc: If |true|, maximize the overlap between orthogonalized left- and right eigenvectors
|
||||
interface: ezfio,provider,ocaml
|
||||
default: False
|
||||
|
||||
[ng_fit_jast]
|
||||
type: integer
|
||||
doc: nb of Gaussians used to fit Jastrow fcts
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 20
|
||||
|
||||
[tcscf_algorithm]
|
||||
type: character*(32)
|
||||
doc: Type of TCSCF algorithm used. Possible choices are [Simple | DIIS]
|
||||
interface: ezfio,provider,ocaml
|
||||
default: Simple
|
||||
|
||||
[test_cycle_tc]
|
||||
type: logical
|
||||
doc: If |true|, the integrals of the three-body jastrow are computed with cycles
|
||||
interface: ezfio,provider,ocaml
|
||||
default: True
|
||||
|
||||
[thresh_biorthog_diag]
|
||||
type: Threshold
|
||||
doc: Threshold to determine if diagonal elements of the bi-orthogonal condition L.T x R are close enouph to 1
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 1.e-6
|
||||
|
||||
[thresh_biorthog_nondiag]
|
||||
type: Threshold
|
||||
doc: Threshold to determine if non-diagonal elements of L.T x R are close enouph to 0
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 1.e-6
|
||||
|
||||
[max_dim_diis_tcscf]
|
||||
type: integer
|
||||
doc: Maximum size of the DIIS extrapolation procedure
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 15
|
||||
|
||||
[threshold_diis_tcscf]
|
||||
type: Threshold
|
||||
doc: Threshold on the convergence of the DIIS error vector during a TCSCF calculation. If 0. is chosen, the square root of thresh_tcscf will be used.
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 0.
|
||||
|
||||
[level_shift_tcscf]
|
||||
type: Positive_float
|
||||
doc: Energy shift on the virtual MOs to improve TCSCF convergence
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 0.
|
||||
|
||||
[im_thresh_tcscf]
|
||||
type: Threshold
|
||||
doc: Thresholds on the Imag part of energy
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 1.e-7
|
||||
|
||||
[debug_tc_pt2]
|
||||
type: integer
|
||||
doc: If :: 1 then you compute the TC-PT2 the old way, :: 2 then you check with the new version but without three-body
|
||||
interface: ezfio,provider,ocaml
|
||||
default: -1
|
||||
2
src/tc_keywords/NEED
Normal file
2
src/tc_keywords/NEED
Normal file
@ -0,0 +1,2 @@
|
||||
ezfio_files
|
||||
nuclei
|
||||
116
src/tc_keywords/j1b_pen.irp.f
Normal file
116
src/tc_keywords/j1b_pen.irp.f
Normal file
@ -0,0 +1,116 @@
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, j1b_pen, (nucl_num) ]
|
||||
|
||||
BEGIN_DOC
|
||||
! exponents of the 1-body Jastrow
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
logical :: exists
|
||||
|
||||
PROVIDE ezfio_filename
|
||||
|
||||
if (mpi_master) then
|
||||
call ezfio_has_tc_keywords_j1b_pen(exists)
|
||||
endif
|
||||
|
||||
IRP_IF MPI_DEBUG
|
||||
print *, irp_here, mpi_rank
|
||||
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
|
||||
IRP_ENDIF
|
||||
|
||||
IRP_IF MPI
|
||||
include 'mpif.h'
|
||||
integer :: ierr
|
||||
call MPI_BCAST(j1b_pen, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
|
||||
if (ierr /= MPI_SUCCESS) then
|
||||
stop 'Unable to read j1b_pen with MPI'
|
||||
endif
|
||||
IRP_ENDIF
|
||||
|
||||
if (exists) then
|
||||
|
||||
if (mpi_master) then
|
||||
write(6,'(A)') '.. >>>>> [ IO READ: j1b_pen ] <<<<< ..'
|
||||
call ezfio_get_tc_keywords_j1b_pen(j1b_pen)
|
||||
IRP_IF MPI
|
||||
call MPI_BCAST(j1b_pen, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
|
||||
if (ierr /= MPI_SUCCESS) then
|
||||
stop 'Unable to read j1b_pen with MPI'
|
||||
endif
|
||||
IRP_ENDIF
|
||||
endif
|
||||
|
||||
else
|
||||
|
||||
integer :: i
|
||||
do i = 1, nucl_num
|
||||
j1b_pen(i) = 1d5
|
||||
enddo
|
||||
|
||||
endif
|
||||
print*,'parameters for nuclei jastrow'
|
||||
do i = 1, nucl_num
|
||||
print*,'i,Z,j1b_pen(i)',i,nucl_charge(i),j1b_pen(i)
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, j1b_coeff, (nucl_num) ]
|
||||
|
||||
BEGIN_DOC
|
||||
! coefficients of the 1-body Jastrow
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
logical :: exists
|
||||
|
||||
PROVIDE ezfio_filename
|
||||
|
||||
if (mpi_master) then
|
||||
call ezfio_has_tc_keywords_j1b_coeff(exists)
|
||||
endif
|
||||
|
||||
IRP_IF MPI_DEBUG
|
||||
print *, irp_here, mpi_rank
|
||||
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
|
||||
IRP_ENDIF
|
||||
|
||||
IRP_IF MPI
|
||||
include 'mpif.h'
|
||||
integer :: ierr
|
||||
call MPI_BCAST(j1b_coeff, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
|
||||
if (ierr /= MPI_SUCCESS) then
|
||||
stop 'Unable to read j1b_coeff with MPI'
|
||||
endif
|
||||
IRP_ENDIF
|
||||
|
||||
if (exists) then
|
||||
|
||||
if (mpi_master) then
|
||||
write(6,'(A)') '.. >>>>> [ IO READ: j1b_coeff ] <<<<< ..'
|
||||
call ezfio_get_tc_keywords_j1b_coeff(j1b_coeff)
|
||||
IRP_IF MPI
|
||||
call MPI_BCAST(j1b_coeff, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
|
||||
if (ierr /= MPI_SUCCESS) then
|
||||
stop 'Unable to read j1b_coeff with MPI'
|
||||
endif
|
||||
IRP_ENDIF
|
||||
endif
|
||||
|
||||
else
|
||||
|
||||
integer :: i
|
||||
do i = 1, nucl_num
|
||||
j1b_coeff(i) = 0d5
|
||||
enddo
|
||||
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
7
src/tc_keywords/tc_keywords.irp.f
Normal file
7
src/tc_keywords/tc_keywords.irp.f
Normal file
@ -0,0 +1,7 @@
|
||||
program tc_keywords
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! TODO : Put the documentation of the program here
|
||||
END_DOC
|
||||
print *, 'Hello world'
|
||||
end
|
||||
27
src/tc_scf/11.tc_scf.bats
Normal file
27
src/tc_scf/11.tc_scf.bats
Normal file
@ -0,0 +1,27 @@
|
||||
#!/usr/bin/env bats
|
||||
|
||||
source $QP_ROOT/tests/bats/common.bats.sh
|
||||
source $QP_ROOT/quantum_package.rc
|
||||
|
||||
|
||||
function run_Ne() {
|
||||
rm -rf Ne_tc_scf
|
||||
echo Ne > Ne.xyz
|
||||
qp create_ezfio -b cc-pcvdz Ne.xyz -o Ne_tc_scf
|
||||
qp run scf
|
||||
qp set tc_keywords bi_ortho True
|
||||
qp set tc_keywords test_cycle_tc True
|
||||
qp set ao_two_e_erf_ints mu_erf 0.87
|
||||
qp set tc_keywords j1b_pen [1.5]
|
||||
qp set tc_keywords j1b_type 3
|
||||
qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out
|
||||
eref=-128.552134
|
||||
energy="$(qp get tc_scf bitc_energy)"
|
||||
eq $energy $eref 1e-6
|
||||
}
|
||||
|
||||
|
||||
@test "Ne" {
|
||||
run_Ne
|
||||
}
|
||||
|
||||
4
src/tc_scf/EZFIO.cfg
Normal file
4
src/tc_scf/EZFIO.cfg
Normal file
@ -0,0 +1,4 @@
|
||||
[bitc_energy]
|
||||
type: Threshold
|
||||
doc: Energy bi-tc HF
|
||||
interface: ezfio
|
||||
6
src/tc_scf/NEED
Normal file
6
src/tc_scf/NEED
Normal file
@ -0,0 +1,6 @@
|
||||
hartree_fock
|
||||
bi_ortho_mos
|
||||
three_body_ints
|
||||
bi_ort_ints
|
||||
tc_keywords
|
||||
non_hermit_dav
|
||||
74
src/tc_scf/combine_lr_tcscf.irp.f
Normal file
74
src/tc_scf/combine_lr_tcscf.irp.f
Normal file
@ -0,0 +1,74 @@
|
||||
|
||||
! ---
|
||||
|
||||
program combine_lr_tcscf
|
||||
|
||||
BEGIN_DOC
|
||||
! TODO : Put the documentation of the program here
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
my_grid_becke = .True.
|
||||
my_n_pt_r_grid = 30
|
||||
my_n_pt_a_grid = 50
|
||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||
|
||||
bi_ortho = .True.
|
||||
touch bi_ortho
|
||||
|
||||
call comb_orbitals()
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine comb_orbitals()
|
||||
|
||||
implicit none
|
||||
integer :: i, m, n, nn, mm
|
||||
double precision :: accu_d, accu_nd
|
||||
double precision, allocatable :: R(:,:), L(:,:), Rnew(:,:), tmp(:,:), S(:,:)
|
||||
|
||||
n = ao_num
|
||||
m = mo_num
|
||||
nn = elec_alpha_num
|
||||
mm = m - nn
|
||||
|
||||
allocate(L(n,m), R(n,m), Rnew(n,m), S(m,m))
|
||||
L = mo_l_coef
|
||||
R = mo_r_coef
|
||||
|
||||
call check_weighted_biorthog(n, m, ao_overlap, L, R, accu_d, accu_nd, S, .true.)
|
||||
|
||||
allocate(tmp(n,nn))
|
||||
do i = 1, nn
|
||||
tmp(1:n,i) = R(1:n,i)
|
||||
enddo
|
||||
call impose_weighted_orthog_svd(n, nn, ao_overlap, tmp)
|
||||
do i = 1, nn
|
||||
Rnew(1:n,i) = tmp(1:n,i)
|
||||
enddo
|
||||
deallocate(tmp)
|
||||
|
||||
allocate(tmp(n,mm))
|
||||
do i = 1, mm
|
||||
tmp(1:n,i) = L(1:n,i+nn)
|
||||
enddo
|
||||
call impose_weighted_orthog_svd(n, mm, ao_overlap, tmp)
|
||||
do i = 1, mm
|
||||
Rnew(1:n,i+nn) = tmp(1:n,i)
|
||||
enddo
|
||||
deallocate(tmp)
|
||||
|
||||
call check_weighted_biorthog(n, m, ao_overlap, Rnew, Rnew, accu_d, accu_nd, S, .true.)
|
||||
|
||||
mo_r_coef = Rnew
|
||||
call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef)
|
||||
|
||||
deallocate(L, R, Rnew, S)
|
||||
|
||||
end subroutine comb_orbitals
|
||||
|
||||
! ---
|
||||
|
||||
229
src/tc_scf/diago_bi_ort_tcfock.irp.f
Normal file
229
src/tc_scf/diago_bi_ort_tcfock.irp.f
Normal file
@ -0,0 +1,229 @@
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, fock_tc_reigvec_mo, (mo_num, mo_num)]
|
||||
&BEGIN_PROVIDER [ double precision, fock_tc_leigvec_mo, (mo_num, mo_num)]
|
||||
&BEGIN_PROVIDER [ double precision, eigval_fock_tc_mo, (mo_num)]
|
||||
&BEGIN_PROVIDER [ double precision, overlap_fock_tc_eigvec_mo, (mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
! EIGENVECTORS OF FOCK MATRIX ON THE MO BASIS and their OVERLAP
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: n_real_tc
|
||||
integer :: i, j, k, l
|
||||
double precision :: accu_d, accu_nd, accu_tmp
|
||||
double precision :: norm
|
||||
double precision, allocatable :: eigval_right_tmp(:)
|
||||
double precision, allocatable :: F_tmp(:,:)
|
||||
|
||||
allocate( eigval_right_tmp(mo_num), F_tmp(mo_num,mo_num) )
|
||||
|
||||
PROVIDE Fock_matrix_tc_mo_tot
|
||||
|
||||
do i = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
F_tmp(j,i) = Fock_matrix_tc_mo_tot(j,i)
|
||||
enddo
|
||||
enddo
|
||||
! insert level shift here
|
||||
do i = elec_beta_num+1, elec_alpha_num
|
||||
F_tmp(i,i) += 0.5d0 * level_shift_tcscf
|
||||
enddo
|
||||
do i = elec_alpha_num+1, mo_num
|
||||
F_tmp(i,i) += level_shift_tcscf
|
||||
enddo
|
||||
|
||||
call non_hrmt_bieig( mo_num, F_tmp, thresh_biorthog_diag, thresh_biorthog_nondiag &
|
||||
, fock_tc_leigvec_mo, fock_tc_reigvec_mo &
|
||||
, n_real_tc, eigval_right_tmp )
|
||||
|
||||
!if(max_ov_tc_scf)then
|
||||
! call non_hrmt_fock_mat( mo_num, F_tmp, thresh_biorthog_diag, thresh_biorthog_nondiag &
|
||||
! , fock_tc_leigvec_mo, fock_tc_reigvec_mo &
|
||||
! , n_real_tc, eigval_right_tmp )
|
||||
!else
|
||||
! call non_hrmt_diag_split_degen_bi_orthog( mo_num, F_tmp &
|
||||
! , fock_tc_leigvec_mo, fock_tc_reigvec_mo &
|
||||
! , n_real_tc, eigval_right_tmp )
|
||||
!endif
|
||||
|
||||
deallocate(F_tmp)
|
||||
|
||||
|
||||
! if(n_real_tc .ne. mo_num)then
|
||||
! print*,'n_real_tc ne mo_num ! ',n_real_tc
|
||||
! stop
|
||||
! endif
|
||||
|
||||
eigval_fock_tc_mo = eigval_right_tmp
|
||||
! print*,'Eigenvalues of Fock_matrix_tc_mo_tot'
|
||||
! do i = 1, elec_alpha_num
|
||||
! print*, i, eigval_fock_tc_mo(i)
|
||||
! enddo
|
||||
! do i = elec_alpha_num+1, mo_num
|
||||
! print*, i, eigval_fock_tc_mo(i) - level_shift_tcscf
|
||||
! enddo
|
||||
! deallocate( eigval_right_tmp )
|
||||
|
||||
! L.T x R
|
||||
call dgemm( "T", "N", mo_num, mo_num, mo_num, 1.d0 &
|
||||
, fock_tc_leigvec_mo, size(fock_tc_leigvec_mo, 1) &
|
||||
, fock_tc_reigvec_mo, size(fock_tc_reigvec_mo, 1) &
|
||||
, 0.d0, overlap_fock_tc_eigvec_mo, size(overlap_fock_tc_eigvec_mo, 1) )
|
||||
|
||||
! ---
|
||||
|
||||
accu_d = 0.d0
|
||||
accu_nd = 0.d0
|
||||
do i = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
if(i==k) then
|
||||
accu_tmp = overlap_fock_tc_eigvec_mo(k,i)
|
||||
accu_d += dabs(accu_tmp )
|
||||
else
|
||||
accu_tmp = overlap_fock_tc_eigvec_mo(k,i)
|
||||
accu_nd += accu_tmp * accu_tmp
|
||||
if(dabs(overlap_fock_tc_eigvec_mo(k,i)) .gt. thresh_biorthog_nondiag)then
|
||||
print *, 'k,i', k, i, overlap_fock_tc_eigvec_mo(k,i)
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
accu_nd = dsqrt(accu_nd) / accu_d
|
||||
if(accu_nd .gt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthog failed'
|
||||
print *, ' accu_nd MO = ', accu_nd, thresh_biorthog_nondiag
|
||||
print *, ' overlap_fock_tc_eigvec_mo = '
|
||||
do i = 1, mo_num
|
||||
write(*,'(100(F16.10,X))') overlap_fock_tc_eigvec_mo(i,:)
|
||||
enddo
|
||||
stop
|
||||
endif
|
||||
|
||||
! ---
|
||||
|
||||
if(dabs(accu_d - dble(mo_num))/dble(mo_num) .gt. thresh_biorthog_diag) then
|
||||
|
||||
print *, ' mo_num = ', mo_num
|
||||
print *, ' accu_d MO = ', accu_d, thresh_biorthog_diag
|
||||
print *, ' normalizing vectors ...'
|
||||
do i = 1, mo_num
|
||||
norm = dsqrt(dabs(overlap_fock_tc_eigvec_mo(i,i)))
|
||||
if(norm .gt. thresh_biorthog_diag) then
|
||||
do k = 1, mo_num
|
||||
fock_tc_reigvec_mo(k,i) *= 1.d0/norm
|
||||
fock_tc_leigvec_mo(k,i) *= 1.d0/norm
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
|
||||
call dgemm( "T", "N", mo_num, mo_num, mo_num, 1.d0 &
|
||||
, fock_tc_leigvec_mo, size(fock_tc_leigvec_mo, 1) &
|
||||
, fock_tc_reigvec_mo, size(fock_tc_reigvec_mo, 1) &
|
||||
, 0.d0, overlap_fock_tc_eigvec_mo, size(overlap_fock_tc_eigvec_mo, 1) )
|
||||
|
||||
accu_d = 0.d0
|
||||
accu_nd = 0.d0
|
||||
do i = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
if(i==k) then
|
||||
accu_tmp = overlap_fock_tc_eigvec_mo(k,i)
|
||||
accu_d += dabs(accu_tmp)
|
||||
else
|
||||
accu_tmp = overlap_fock_tc_eigvec_mo(k,i)
|
||||
accu_nd += accu_tmp * accu_tmp
|
||||
if(dabs(overlap_fock_tc_eigvec_mo(k,i)) .gt. thresh_biorthog_nondiag)then
|
||||
print *, 'k,i', k, i, overlap_fock_tc_eigvec_mo(k,i)
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
accu_nd = dsqrt(accu_nd) / accu_d
|
||||
if(accu_nd .gt. thresh_biorthog_diag) then
|
||||
print *, ' bi-orthog failed'
|
||||
print *, ' accu_nd MO = ', accu_nd, thresh_biorthog_nondiag
|
||||
print *, ' overlap_fock_tc_eigvec_mo = '
|
||||
do i = 1, mo_num
|
||||
write(*,'(100(F16.10,X))') overlap_fock_tc_eigvec_mo(i,:)
|
||||
enddo
|
||||
stop
|
||||
endif
|
||||
|
||||
endif
|
||||
|
||||
! ---
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, fock_tc_reigvec_ao, (ao_num, mo_num)]
|
||||
&BEGIN_PROVIDER [ double precision, fock_tc_leigvec_ao, (ao_num, mo_num)]
|
||||
&BEGIN_PROVIDER [ double precision, overlap_fock_tc_eigvec_ao, (mo_num, mo_num) ]
|
||||
|
||||
BEGIN_DOC
|
||||
! EIGENVECTORS OF FOCK MATRIX ON THE AO BASIS and their OVERLAP
|
||||
!
|
||||
! THE OVERLAP SHOULD BE THE SAME AS overlap_fock_tc_eigvec_mo
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, q, p
|
||||
double precision :: accu, accu_d
|
||||
double precision, allocatable :: tmp(:,:)
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
! ! MO_R x R
|
||||
call dgemm( 'N', 'N', ao_num, mo_num, mo_num, 1.d0 &
|
||||
, mo_r_coef, size(mo_r_coef, 1) &
|
||||
, fock_tc_reigvec_mo, size(fock_tc_reigvec_mo, 1) &
|
||||
, 0.d0, fock_tc_reigvec_ao, size(fock_tc_reigvec_ao, 1) )
|
||||
|
||||
! MO_L x L
|
||||
call dgemm( 'N', 'N', ao_num, mo_num, mo_num, 1.d0 &
|
||||
, mo_l_coef, size(mo_l_coef, 1) &
|
||||
, fock_tc_leigvec_mo, size(fock_tc_leigvec_mo, 1) &
|
||||
, 0.d0, fock_tc_leigvec_ao, size(fock_tc_leigvec_ao, 1) )
|
||||
|
||||
allocate( tmp(mo_num,ao_num) )
|
||||
|
||||
! tmp <-- L.T x S_ao
|
||||
call dgemm( "T", "N", mo_num, ao_num, ao_num, 1.d0 &
|
||||
, fock_tc_leigvec_ao, size(fock_tc_leigvec_ao, 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), fock_tc_reigvec_ao, size(fock_tc_reigvec_ao, 1) &
|
||||
, 0.d0, overlap_fock_tc_eigvec_ao, size(overlap_fock_tc_eigvec_ao, 1) )
|
||||
|
||||
deallocate( tmp )
|
||||
|
||||
! ---
|
||||
double precision :: norm
|
||||
do i = 1, mo_num
|
||||
norm = 1.d0/dsqrt(dabs(overlap_fock_tc_eigvec_ao(i,i)))
|
||||
do j = 1, mo_num
|
||||
fock_tc_reigvec_ao(j,i) *= norm
|
||||
fock_tc_leigvec_ao(j,i) *= norm
|
||||
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 &
|
||||
, fock_tc_leigvec_ao, size(fock_tc_leigvec_ao, 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), fock_tc_reigvec_ao, size(fock_tc_reigvec_ao, 1) &
|
||||
, 0.d0, overlap_fock_tc_eigvec_ao, size(overlap_fock_tc_eigvec_ao, 1) )
|
||||
|
||||
deallocate( tmp )
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
186
src/tc_scf/diis_tcscf.irp.f
Normal file
186
src/tc_scf/diis_tcscf.irp.f
Normal file
@ -0,0 +1,186 @@
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, threshold_DIIS_nonzero_TCSCF ]
|
||||
|
||||
implicit none
|
||||
|
||||
if(threshold_DIIS_TCSCF == 0.d0) then
|
||||
threshold_DIIS_nonzero_TCSCF = dsqrt(thresh_tcscf)
|
||||
else
|
||||
threshold_DIIS_nonzero_TCSCF = threshold_DIIS_TCSCF
|
||||
endif
|
||||
ASSERT(threshold_DIIS_nonzero_TCSCF >= 0.d0)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, Q_alpha, (ao_num, ao_num) ]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! Q_alpha = mo_r_coef x eta_occ_alpha x mo_l_coef.T
|
||||
!
|
||||
! [Q_alpha]_ij = \sum_{k=1}^{elec_alpha_num} [mo_r_coef]_ik [mo_l_coef]_jk
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
Q_alpha = 0.d0
|
||||
call dgemm( 'N', 'T', ao_num, ao_num, elec_alpha_num, 1.d0 &
|
||||
, mo_r_coef, size(mo_r_coef, 1), mo_l_coef, size(mo_l_coef, 1) &
|
||||
, 0.d0, Q_alpha, size(Q_alpha, 1) )
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, Q_beta, (ao_num, ao_num) ]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! Q_beta = mo_r_coef x eta_occ_beta x mo_l_coef.T
|
||||
!
|
||||
! [Q_beta]_ij = \sum_{k=1}^{elec_beta_num} [mo_r_coef]_ik [mo_l_coef]_jk
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
Q_beta = 0.d0
|
||||
call dgemm( 'N', 'T', ao_num, ao_num, elec_beta_num, 1.d0 &
|
||||
, mo_r_coef, size(mo_r_coef, 1), mo_l_coef, size(mo_l_coef, 1) &
|
||||
, 0.d0, Q_beta, size(Q_beta, 1) )
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, Q_matrix, (ao_num, ao_num) ]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! Q_matrix = 2 mo_r_coef x eta_occ x mo_l_coef.T
|
||||
!
|
||||
! with:
|
||||
! | 1 if i = j = 1, ..., nb of occ orbitals
|
||||
! [eta_occ]_ij = |
|
||||
! | 0 otherwise
|
||||
!
|
||||
! the diis error is defines as:
|
||||
! e = F_ao x Q x ao_overlap - ao_overlap x Q x F_ao
|
||||
! with:
|
||||
! mo_l_coef.T x ao_overlap x mo_r_coef = I
|
||||
! F_mo = mo_l_coef.T x F_ao x mo_r_coef
|
||||
! F_ao = (ao_overlap x mo_r_coef) x F_mo x (ao_overlap x mo_l_coef).T
|
||||
!
|
||||
! ==> e = 2 ao_overlap x mo_r_coef x [ F_mo x eta_occ - eta_occ x F_mo ] x (ao_overlap x mo_l_coef).T
|
||||
!
|
||||
! at convergence:
|
||||
! F_mo x eta_occ - eta_occ x F_mo = 0
|
||||
! ==> [F_mo]_ij ([eta_occ]_ii - [eta_occ]_jj) = 0
|
||||
! ==> [F_mo]_ia = [F_mo]_ai = 0 where: i = occ and a = vir
|
||||
! ==> Brillouin conditions
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
if(elec_alpha_num == elec_beta_num) then
|
||||
Q_matrix = Q_alpha + Q_alpha
|
||||
else
|
||||
Q_matrix = Q_alpha + Q_beta
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, FQS_SQF_ao, (ao_num, ao_num)]
|
||||
|
||||
implicit none
|
||||
double precision, allocatable :: tmp(:,:)
|
||||
|
||||
allocate(tmp(ao_num,ao_num))
|
||||
|
||||
! F x Q
|
||||
call dgemm( 'N', 'N', ao_num, ao_num, ao_num, 1.d0 &
|
||||
, Fock_matrix_tc_ao_tot, size(Fock_matrix_tc_ao_tot, 1), Q_matrix, size(Q_matrix, 1) &
|
||||
, 0.d0, tmp, size(tmp, 1) )
|
||||
|
||||
! F x Q x S
|
||||
call dgemm( 'N', 'N', ao_num, ao_num, ao_num, 1.d0 &
|
||||
, tmp, size(tmp, 1), ao_overlap, size(ao_overlap, 1) &
|
||||
, 0.d0, FQS_SQF_ao, size(FQS_SQF_ao, 1) )
|
||||
|
||||
! S x Q
|
||||
tmp = 0.d0
|
||||
call dgemm( 'N', 'N', ao_num, ao_num, ao_num, 1.d0 &
|
||||
, ao_overlap, size(ao_overlap, 1), Q_matrix, size(Q_matrix, 1) &
|
||||
, 0.d0, tmp, size(tmp, 1) )
|
||||
|
||||
! F x Q x S - S x Q x F
|
||||
call dgemm( 'N', 'N', ao_num, ao_num, ao_num, -1.d0 &
|
||||
, tmp, size(tmp, 1), Fock_matrix_tc_ao_tot, size(Fock_matrix_tc_ao_tot, 1) &
|
||||
, 1.d0, FQS_SQF_ao, size(FQS_SQF_ao, 1) )
|
||||
|
||||
deallocate(tmp)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, FQS_SQF_mo, (mo_num, mo_num)]
|
||||
|
||||
implicit none
|
||||
|
||||
call ao_to_mo_bi_ortho( FQS_SQF_ao, size(FQS_SQF_ao, 1) &
|
||||
, FQS_SQF_mo, size(FQS_SQF_mo, 1) )
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
! BEGIN_PROVIDER [ double precision, eigenval_Fock_tc_ao, (ao_num) ]
|
||||
!&BEGIN_PROVIDER [ double precision, eigenvec_Fock_tc_ao, (ao_num,ao_num) ]
|
||||
!
|
||||
! BEGIN_DOC
|
||||
! !
|
||||
! ! Eigenvalues and eigenvectors of the Fock matrix over the ao basis
|
||||
! !
|
||||
! ! F' = X.T x F x X where X = ao_overlap^(-1/2)
|
||||
! !
|
||||
! ! F' x Cr' = Cr' x E ==> F Cr = Cr x E with Cr = X x Cr'
|
||||
! ! F'.T x Cl' = Cl' x E ==> F.T Cl = Cl x E with Cl = X x Cl'
|
||||
! !
|
||||
! END_DOC
|
||||
!
|
||||
! implicit none
|
||||
! double precision, allocatable :: tmp1(:,:), tmp2(:,:)
|
||||
!
|
||||
! ! ---
|
||||
! ! Fock matrix in orthogonal basis: F' = X.T x F x X
|
||||
!
|
||||
! allocate(tmp1(ao_num,ao_num))
|
||||
! call dgemm( 'N', 'N', ao_num, ao_num, ao_num, 1.d0 &
|
||||
! , Fock_matrix_tc_ao_tot, size(Fock_matrix_tc_ao_tot, 1), S_half_inv, size(S_half_inv, 1) &
|
||||
! , 0.d0, tmp1, size(tmp1, 1) )
|
||||
!
|
||||
! allocate(tmp2(ao_num,ao_num))
|
||||
! call dgemm( 'T', 'N', ao_num, ao_num, ao_num, 1.d0 &
|
||||
! , S_half_inv, size(S_half_inv, 1), tmp1, size(tmp1, 1) &
|
||||
! , 0.d0, tmp2, size(tmp2, 1) )
|
||||
!
|
||||
! ! ---
|
||||
!
|
||||
! ! Diagonalize F' to obtain eigenvectors in orthogonal basis C' and eigenvalues
|
||||
! ! TODO
|
||||
!
|
||||
! ! Back-transform eigenvectors: C =X.C'
|
||||
!
|
||||
!END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
~
|
||||
405
src/tc_scf/fock_3e_bi_ortho_uhf.irp.f
Normal file
405
src/tc_scf/fock_3e_bi_ortho_uhf.irp.f
Normal file
@ -0,0 +1,405 @@
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_cs, (mo_num, mo_num)]
|
||||
|
||||
implicit none
|
||||
integer :: a, b, i, j
|
||||
double precision :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
|
||||
double precision :: ti, tf
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
!print *, ' PROVIDING fock_3e_uhf_mo_cs ...'
|
||||
call wall_time(ti)
|
||||
|
||||
fock_3e_uhf_mo_cs = 0.d0
|
||||
|
||||
do a = 1, mo_num
|
||||
do b = 1, mo_num
|
||||
|
||||
do j = 1, elec_beta_num
|
||||
do i = 1, elec_beta_num
|
||||
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
||||
|
||||
fock_3e_uhf_mo_cs(b,a) -= 0.5d0 * ( 4.d0 * I_bij_aij &
|
||||
+ I_bij_ija &
|
||||
+ I_bij_jai &
|
||||
- 2.d0 * I_bij_aji &
|
||||
- 2.d0 * I_bij_iaj &
|
||||
- 2.d0 * I_bij_jia )
|
||||
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(tf)
|
||||
!print *, ' total Wall time for fock_3e_uhf_mo_cs =', tf - ti
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a, (mo_num, mo_num)]
|
||||
|
||||
implicit none
|
||||
integer :: a, b, i, j, o
|
||||
double precision :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
|
||||
double precision :: ti, tf
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
!print *, ' PROVIDING fock_3e_uhf_mo_a ...'
|
||||
call wall_time(ti)
|
||||
|
||||
o = elec_beta_num + 1
|
||||
|
||||
fock_3e_uhf_mo_a = fock_3e_uhf_mo_cs
|
||||
|
||||
do a = 1, mo_num
|
||||
do b = 1, mo_num
|
||||
|
||||
! ---
|
||||
|
||||
do j = o, elec_alpha_num
|
||||
do i = 1, elec_beta_num
|
||||
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
||||
|
||||
fock_3e_uhf_mo_a(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
|
||||
+ I_bij_ija &
|
||||
+ I_bij_jai &
|
||||
- I_bij_aji &
|
||||
- I_bij_iaj &
|
||||
- 2.d0 * I_bij_jia )
|
||||
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
do j = 1, elec_beta_num
|
||||
do i = o, elec_alpha_num
|
||||
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
||||
|
||||
fock_3e_uhf_mo_a(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
|
||||
+ I_bij_ija &
|
||||
+ I_bij_jai &
|
||||
- I_bij_aji &
|
||||
- 2.d0 * I_bij_iaj &
|
||||
- I_bij_jia )
|
||||
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
do j = o, elec_alpha_num
|
||||
do i = o, elec_alpha_num
|
||||
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
||||
|
||||
fock_3e_uhf_mo_a(b,a) -= 0.5d0 * ( I_bij_aij &
|
||||
+ I_bij_ija &
|
||||
+ I_bij_jai &
|
||||
- I_bij_aji &
|
||||
- I_bij_iaj &
|
||||
- I_bij_jia )
|
||||
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(tf)
|
||||
!print *, ' total Wall time for fock_3e_uhf_mo_a =', tf - ti
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b, (mo_num, mo_num)]
|
||||
|
||||
implicit none
|
||||
integer :: a, b, i, j, o
|
||||
double precision :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
|
||||
double precision :: ti, tf
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
!print *, ' PROVIDING fock_3e_uhf_mo_b ...'
|
||||
call wall_time(ti)
|
||||
|
||||
o = elec_beta_num + 1
|
||||
|
||||
fock_3e_uhf_mo_b = fock_3e_uhf_mo_cs
|
||||
|
||||
do a = 1, mo_num
|
||||
do b = 1, mo_num
|
||||
|
||||
! ---
|
||||
|
||||
do j = o, elec_alpha_num
|
||||
do i = 1, elec_beta_num
|
||||
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
||||
|
||||
fock_3e_uhf_mo_b(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
|
||||
- I_bij_aji &
|
||||
- I_bij_iaj )
|
||||
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
do j = 1, elec_beta_num
|
||||
do i = o, elec_alpha_num
|
||||
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
||||
|
||||
fock_3e_uhf_mo_b(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
|
||||
- I_bij_aji &
|
||||
- I_bij_jia )
|
||||
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
do j = o, elec_alpha_num
|
||||
do i = o, elec_alpha_num
|
||||
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
||||
|
||||
fock_3e_uhf_mo_b(b,a) -= 0.5d0 * ( I_bij_aij &
|
||||
- I_bij_aji )
|
||||
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(tf)
|
||||
!print *, ' total Wall time for fock_3e_uhf_mo_b =', tf - ti
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_3e_uhf_ao_a, (ao_num, ao_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! Equations (B6) and (B7)
|
||||
!
|
||||
! g <--> gamma
|
||||
! d <--> delta
|
||||
! e <--> eta
|
||||
! k <--> kappa
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: g, d, e, k, mu, nu
|
||||
double precision :: dm_ge_a, dm_ge_b, dm_ge
|
||||
double precision :: dm_dk_a, dm_dk_b, dm_dk
|
||||
double precision :: i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu
|
||||
double precision :: ti, tf
|
||||
double precision, allocatable :: f_tmp(:,:)
|
||||
|
||||
print *, ' PROVIDING fock_3e_uhf_ao_a ...'
|
||||
call wall_time(ti)
|
||||
|
||||
fock_3e_uhf_ao_a = 0.d0
|
||||
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (g, e, d, k, mu, nu, dm_ge_a, dm_ge_b, dm_ge, dm_dk_a, dm_dk_b, dm_dk, f_tmp, &
|
||||
!$OMP i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu) &
|
||||
!$OMP SHARED (ao_num, TCSCF_bi_ort_dm_ao_alpha, TCSCF_bi_ort_dm_ao_beta, fock_3e_uhf_ao_a)
|
||||
|
||||
allocate(f_tmp(ao_num,ao_num))
|
||||
f_tmp = 0.d0
|
||||
|
||||
!$OMP DO
|
||||
do g = 1, ao_num
|
||||
do e = 1, ao_num
|
||||
dm_ge_a = TCSCF_bi_ort_dm_ao_alpha(g,e)
|
||||
dm_ge_b = TCSCF_bi_ort_dm_ao_beta (g,e)
|
||||
dm_ge = dm_ge_a + dm_ge_b
|
||||
do d = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
dm_dk_a = TCSCF_bi_ort_dm_ao_alpha(d,k)
|
||||
dm_dk_b = TCSCF_bi_ort_dm_ao_beta (d,k)
|
||||
dm_dk = dm_dk_a + dm_dk_b
|
||||
do mu = 1, ao_num
|
||||
do nu = 1, ao_num
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, e, k, i_mugd_nuek)
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, e, k, nu, i_mugd_eknu)
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, k, nu, e, i_mugd_knue)
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, k, e, i_mugd_nuke)
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, e, nu, k, i_mugd_enuk)
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, k, e, nu, i_mugd_kenu)
|
||||
f_tmp(mu,nu) -= 0.5d0 * ( dm_ge * dm_dk * i_mugd_nuek &
|
||||
+ dm_ge_a * dm_dk_a * i_mugd_eknu &
|
||||
+ dm_ge_a * dm_dk_a * i_mugd_knue &
|
||||
- dm_ge_a * dm_dk * i_mugd_enuk &
|
||||
- dm_ge * dm_dk_a * i_mugd_kenu &
|
||||
- dm_ge_a * dm_dk_a * i_mugd_nuke &
|
||||
- dm_ge_b * dm_dk_b * i_mugd_nuke )
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO NOWAIT
|
||||
|
||||
!$OMP CRITICAL
|
||||
do mu = 1, ao_num
|
||||
do nu = 1, ao_num
|
||||
fock_3e_uhf_ao_a(mu,nu) += f_tmp(mu,nu)
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END CRITICAL
|
||||
|
||||
deallocate(f_tmp)
|
||||
!$OMP END PARALLEL
|
||||
|
||||
call wall_time(tf)
|
||||
print *, ' total Wall time for fock_3e_uhf_ao_a =', tf - ti
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_3e_uhf_ao_b, (ao_num, ao_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! Equations (B6) and (B7)
|
||||
!
|
||||
! g <--> gamma
|
||||
! d <--> delta
|
||||
! e <--> eta
|
||||
! k <--> kappa
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: g, d, e, k, mu, nu
|
||||
double precision :: dm_ge_a, dm_ge_b, dm_ge
|
||||
double precision :: dm_dk_a, dm_dk_b, dm_dk
|
||||
double precision :: i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu
|
||||
double precision :: ti, tf
|
||||
double precision, allocatable :: f_tmp(:,:)
|
||||
|
||||
print *, ' PROVIDING fock_3e_uhf_ao_b ...'
|
||||
call wall_time(ti)
|
||||
|
||||
fock_3e_uhf_ao_b = 0.d0
|
||||
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (g, e, d, k, mu, nu, dm_ge_a, dm_ge_b, dm_ge, dm_dk_a, dm_dk_b, dm_dk, f_tmp, &
|
||||
!$OMP i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu) &
|
||||
!$OMP SHARED (ao_num, TCSCF_bi_ort_dm_ao_alpha, TCSCF_bi_ort_dm_ao_beta, fock_3e_uhf_ao_b)
|
||||
|
||||
allocate(f_tmp(ao_num,ao_num))
|
||||
f_tmp = 0.d0
|
||||
|
||||
!$OMP DO
|
||||
do g = 1, ao_num
|
||||
do e = 1, ao_num
|
||||
dm_ge_a = TCSCF_bi_ort_dm_ao_alpha(g,e)
|
||||
dm_ge_b = TCSCF_bi_ort_dm_ao_beta (g,e)
|
||||
dm_ge = dm_ge_a + dm_ge_b
|
||||
do d = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
dm_dk_a = TCSCF_bi_ort_dm_ao_alpha(d,k)
|
||||
dm_dk_b = TCSCF_bi_ort_dm_ao_beta (d,k)
|
||||
dm_dk = dm_dk_a + dm_dk_b
|
||||
do mu = 1, ao_num
|
||||
do nu = 1, ao_num
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, e, k, i_mugd_nuek)
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, e, k, nu, i_mugd_eknu)
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, k, nu, e, i_mugd_knue)
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, k, e, i_mugd_nuke)
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, e, nu, k, i_mugd_enuk)
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, k, e, nu, i_mugd_kenu)
|
||||
f_tmp(mu,nu) -= 0.5d0 * ( dm_ge * dm_dk * i_mugd_nuek &
|
||||
+ dm_ge_b * dm_dk_b * i_mugd_eknu &
|
||||
+ dm_ge_b * dm_dk_b * i_mugd_knue &
|
||||
- dm_ge_b * dm_dk * i_mugd_enuk &
|
||||
- dm_ge * dm_dk_b * i_mugd_kenu &
|
||||
- dm_ge_b * dm_dk_b * i_mugd_nuke &
|
||||
- dm_ge_a * dm_dk_a * i_mugd_nuke )
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO NOWAIT
|
||||
|
||||
!$OMP CRITICAL
|
||||
do mu = 1, ao_num
|
||||
do nu = 1, ao_num
|
||||
fock_3e_uhf_ao_b(mu,nu) += f_tmp(mu,nu)
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END CRITICAL
|
||||
|
||||
deallocate(f_tmp)
|
||||
!$OMP END PARALLEL
|
||||
|
||||
call wall_time(tf)
|
||||
print *, ' total Wall time for fock_3e_uhf_ao_b =', tf - ti
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
107
src/tc_scf/fock_for_right.irp.f
Normal file
107
src/tc_scf/fock_for_right.irp.f
Normal file
@ -0,0 +1,107 @@
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, good_hermit_tc_fock_mat, (mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
! good_hermit_tc_fock_mat = Hermitian Upper triangular Fock matrix
|
||||
!
|
||||
! The converged eigenvectors of such matrix yield to orthonormal vectors satisfying the left Brillouin theorem
|
||||
END_DOC
|
||||
implicit none
|
||||
integer :: i, j
|
||||
|
||||
good_hermit_tc_fock_mat = Fock_matrix_tc_mo_tot
|
||||
do j = 1, mo_num
|
||||
do i = 1, j-1
|
||||
good_hermit_tc_fock_mat(i,j) = Fock_matrix_tc_mo_tot(j,i)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, hermit_average_tc_fock_mat, (mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
! hermit_average_tc_fock_mat = (F + F^\dagger)/2
|
||||
END_DOC
|
||||
implicit none
|
||||
integer :: i, j
|
||||
|
||||
hermit_average_tc_fock_mat = Fock_matrix_tc_mo_tot
|
||||
do j = 1, mo_num
|
||||
do i = 1, mo_num
|
||||
hermit_average_tc_fock_mat(i,j) = 0.5d0 * (Fock_matrix_tc_mo_tot(j,i) + Fock_matrix_tc_mo_tot(i,j))
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
! ---
|
||||
BEGIN_PROVIDER [ double precision, grad_hermit]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! square of gradient of the energy
|
||||
END_DOC
|
||||
if(symetric_fock_tc)then
|
||||
grad_hermit = grad_hermit_average_tc_fock_mat
|
||||
else
|
||||
grad_hermit = grad_good_hermit_tc_fock_mat
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, grad_good_hermit_tc_fock_mat]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! grad_good_hermit_tc_fock_mat = norm of gradients of the upper triangular TC fock
|
||||
END_DOC
|
||||
integer :: i, j
|
||||
grad_good_hermit_tc_fock_mat = 0.d0
|
||||
do i = 1, elec_alpha_num
|
||||
do j = elec_alpha_num+1, mo_num
|
||||
grad_good_hermit_tc_fock_mat += dabs(good_hermit_tc_fock_mat(i,j))
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, grad_hermit_average_tc_fock_mat]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! grad_hermit_average_tc_fock_mat = norm of gradients of the upper triangular TC fock
|
||||
END_DOC
|
||||
integer :: i, j
|
||||
grad_hermit_average_tc_fock_mat = 0.d0
|
||||
do i = 1, elec_alpha_num
|
||||
do j = elec_alpha_num+1, mo_num
|
||||
grad_hermit_average_tc_fock_mat += dabs(hermit_average_tc_fock_mat(i,j))
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
! ---
|
||||
|
||||
subroutine save_good_hermit_tc_eigvectors()
|
||||
|
||||
implicit none
|
||||
integer :: sign
|
||||
character*(64) :: label
|
||||
logical :: output
|
||||
|
||||
sign = 1
|
||||
label = "Canonical"
|
||||
output = .False.
|
||||
|
||||
if(symetric_fock_tc)then
|
||||
call mo_as_eigvectors_of_mo_matrix(hermit_average_tc_fock_mat, mo_num, mo_num, label, sign, output)
|
||||
else
|
||||
call mo_as_eigvectors_of_mo_matrix(good_hermit_tc_fock_mat, mo_num, mo_num, label, sign, output)
|
||||
endif
|
||||
end subroutine save_good_hermit_tc_eigvectors
|
||||
|
||||
! ---
|
||||
|
||||
307
src/tc_scf/fock_tc.irp.f
Normal file
307
src/tc_scf/fock_tc.irp.f
Normal file
@ -0,0 +1,307 @@
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, two_e_tc_non_hermit_integral_seq_alpha, (ao_num, ao_num)]
|
||||
&BEGIN_PROVIDER [ double precision, two_e_tc_non_hermit_integral_seq_beta , (ao_num, ao_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! two_e_tc_non_hermit_integral_seq_alpha(k,i) = <k| F^tc_alpha |i>
|
||||
!
|
||||
! where F^tc is the two-body part of the TC Fock matrix and k,i are AO basis functions
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, l
|
||||
double precision :: density, density_a, density_b
|
||||
double precision :: t0, t1
|
||||
|
||||
!print*, ' providing two_e_tc_non_hermit_integral_seq ...'
|
||||
!call wall_time(t0)
|
||||
|
||||
two_e_tc_non_hermit_integral_seq_alpha = 0.d0
|
||||
two_e_tc_non_hermit_integral_seq_beta = 0.d0
|
||||
|
||||
do i = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
|
||||
density_a = TCSCF_density_matrix_ao_alpha(l,j)
|
||||
density_b = TCSCF_density_matrix_ao_beta (l,j)
|
||||
density = density_a + density_b
|
||||
|
||||
!! rho(l,j) * < k l| T | i j>
|
||||
!two_e_tc_non_hermit_integral_seq_alpha(k,i) += density * ao_two_e_tc_tot(l,j,k,i)
|
||||
!! rho(l,j) * < k l| T | i j>
|
||||
!two_e_tc_non_hermit_integral_seq_beta (k,i) += density * ao_two_e_tc_tot(l,j,k,i)
|
||||
!! rho_a(l,j) * < l k| T | i j>
|
||||
!two_e_tc_non_hermit_integral_seq_alpha(k,i) -= density_a * ao_two_e_tc_tot(k,j,l,i)
|
||||
!! rho_b(l,j) * < l k| T | i j>
|
||||
!two_e_tc_non_hermit_integral_seq_beta (k,i) -= density_b * ao_two_e_tc_tot(k,j,l,i)
|
||||
|
||||
!! rho(l,j) * < k l| T | i j>
|
||||
!two_e_tc_non_hermit_integral_alpha(k,i) += density * ao_two_e_tc_tot(l,j,k,i)
|
||||
!! rho(l,j) * < k l| T | i j>
|
||||
!two_e_tc_non_hermit_integral_beta (k,i) += density * ao_two_e_tc_tot(l,j,k,i)
|
||||
!! rho_a(l,j) * < l k| T | i j>
|
||||
!two_e_tc_non_hermit_integral_alpha(k,i) -= density_a * ao_two_e_tc_tot(k,j,l,i)
|
||||
!! rho_b(l,j) * < l k| T | i j>
|
||||
!two_e_tc_non_hermit_integral_beta (k,i) -= density_b * ao_two_e_tc_tot(k,j,l,i)
|
||||
|
||||
! rho(l,j) * < k l| T | i j>
|
||||
two_e_tc_non_hermit_integral_seq_alpha(k,i) += density * ao_two_e_tc_tot(k,i,l,j)
|
||||
! rho(l,j) * < k l| T | i j>
|
||||
two_e_tc_non_hermit_integral_seq_beta (k,i) += density * ao_two_e_tc_tot(k,i,l,j)
|
||||
! rho_a(l,j) * < k l| T | j i>
|
||||
two_e_tc_non_hermit_integral_seq_alpha(k,i) -= density_a * ao_two_e_tc_tot(k,j,l,i)
|
||||
! rho_b(l,j) * < k l| T | j i>
|
||||
two_e_tc_non_hermit_integral_seq_beta (k,i) -= density_b * ao_two_e_tc_tot(k,j,l,i)
|
||||
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
!call wall_time(t1)
|
||||
!print*, ' wall time for two_e_tc_non_hermit_integral_seq after = ', t1 - t0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, two_e_tc_non_hermit_integral_alpha, (ao_num, ao_num)]
|
||||
&BEGIN_PROVIDER [ double precision, two_e_tc_non_hermit_integral_beta , (ao_num, ao_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! two_e_tc_non_hermit_integral_alpha(k,i) = <k| F^tc_alpha |i>
|
||||
!
|
||||
! where F^tc is the two-body part of the TC Fock matrix and k,i are AO basis functions
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, l
|
||||
double precision :: density, density_a, density_b, I_coul, I_kjli
|
||||
double precision :: t0, t1
|
||||
double precision, allocatable :: tmp_a(:,:), tmp_b(:,:)
|
||||
|
||||
!print*, ' providing two_e_tc_non_hermit_integral ...'
|
||||
!call wall_time(t0)
|
||||
|
||||
two_e_tc_non_hermit_integral_alpha = 0.d0
|
||||
two_e_tc_non_hermit_integral_beta = 0.d0
|
||||
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i, j, k, l, density_a, density_b, density, tmp_a, tmp_b, I_coul, I_kjli) &
|
||||
!$OMP SHARED (ao_num, TCSCF_density_matrix_ao_alpha, TCSCF_density_matrix_ao_beta, ao_two_e_tc_tot, &
|
||||
!$OMP two_e_tc_non_hermit_integral_alpha, two_e_tc_non_hermit_integral_beta)
|
||||
|
||||
allocate(tmp_a(ao_num,ao_num), tmp_b(ao_num,ao_num))
|
||||
tmp_a = 0.d0
|
||||
tmp_b = 0.d0
|
||||
|
||||
!$OMP DO
|
||||
do j = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
density_a = TCSCF_density_matrix_ao_alpha(l,j)
|
||||
density_b = TCSCF_density_matrix_ao_beta (l,j)
|
||||
density = density_a + density_b
|
||||
do i = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
|
||||
I_coul = density * ao_two_e_tc_tot(k,i,l,j)
|
||||
I_kjli = ao_two_e_tc_tot(k,j,l,i)
|
||||
|
||||
tmp_a(k,i) += I_coul - density_a * I_kjli
|
||||
tmp_b(k,i) += I_coul - density_b * I_kjli
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO NOWAIT
|
||||
|
||||
!$OMP CRITICAL
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
two_e_tc_non_hermit_integral_alpha(j,i) += tmp_a(j,i)
|
||||
two_e_tc_non_hermit_integral_beta (j,i) += tmp_b(j,i)
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END CRITICAL
|
||||
|
||||
deallocate(tmp_a, tmp_b)
|
||||
!$OMP END PARALLEL
|
||||
|
||||
!call wall_time(t1)
|
||||
!print*, ' wall time for two_e_tc_non_hermit_integral after = ', t1 - t0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, Fock_matrix_tc_ao_alpha, (ao_num, ao_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
! Total alpha TC Fock matrix : h_c + Two-e^TC terms on the AO basis
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
Fock_matrix_tc_ao_alpha = ao_one_e_integrals_tc_tot + two_e_tc_non_hermit_integral_alpha
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, Fock_matrix_tc_ao_beta, (ao_num, ao_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
! Total beta TC Fock matrix : h_c + Two-e^TC terms on the AO basis
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
Fock_matrix_tc_ao_beta = ao_one_e_integrals_tc_tot + two_e_tc_non_hermit_integral_beta
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_alpha, (mo_num, mo_num) ]
|
||||
|
||||
BEGIN_DOC
|
||||
! Total alpha TC Fock matrix : h_c + Two-e^TC terms on the MO basis
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
double precision, allocatable :: tmp(:,:)
|
||||
|
||||
if(bi_ortho) then
|
||||
|
||||
!allocate(tmp(ao_num,ao_num))
|
||||
!tmp = Fock_matrix_tc_ao_alpha
|
||||
!if(three_body_h_tc) then
|
||||
! tmp += fock_3e_uhf_ao_a
|
||||
!endif
|
||||
!call ao_to_mo_bi_ortho(tmp, size(tmp, 1), Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1))
|
||||
!deallocate(tmp)
|
||||
|
||||
call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_alpha, size(Fock_matrix_tc_ao_alpha, 1) &
|
||||
, Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1) )
|
||||
if(three_body_h_tc) then
|
||||
!Fock_matrix_tc_mo_alpha += fock_a_tot_3e_bi_orth
|
||||
Fock_matrix_tc_mo_alpha += fock_3e_uhf_mo_a
|
||||
endif
|
||||
|
||||
else
|
||||
call ao_to_mo( Fock_matrix_tc_ao_alpha, size(Fock_matrix_tc_ao_alpha, 1) &
|
||||
, Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1) )
|
||||
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_beta, (mo_num,mo_num) ]
|
||||
|
||||
BEGIN_DOC
|
||||
! Total beta TC Fock matrix : h_c + Two-e^TC terms on the MO basis
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
double precision, allocatable :: tmp(:,:)
|
||||
|
||||
if(bi_ortho) then
|
||||
|
||||
!allocate(tmp(ao_num,ao_num))
|
||||
!tmp = Fock_matrix_tc_ao_beta
|
||||
!if(three_body_h_tc) then
|
||||
! tmp += fock_3e_uhf_ao_b
|
||||
!endif
|
||||
!call ao_to_mo_bi_ortho(tmp, size(tmp, 1), Fock_matrix_tc_mo_beta, size(Fock_matrix_tc_mo_beta, 1))
|
||||
!deallocate(tmp)
|
||||
|
||||
call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_beta, size(Fock_matrix_tc_ao_beta, 1) &
|
||||
, Fock_matrix_tc_mo_beta, size(Fock_matrix_tc_mo_beta, 1) )
|
||||
if(three_body_h_tc) then
|
||||
!Fock_matrix_tc_mo_beta += fock_b_tot_3e_bi_orth
|
||||
Fock_matrix_tc_mo_beta += fock_3e_uhf_mo_b
|
||||
endif
|
||||
|
||||
else
|
||||
|
||||
call ao_to_mo( Fock_matrix_tc_ao_beta, size(Fock_matrix_tc_ao_beta, 1) &
|
||||
, Fock_matrix_tc_mo_beta, size(Fock_matrix_tc_mo_beta, 1) )
|
||||
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, grad_non_hermit_left]
|
||||
&BEGIN_PROVIDER [ double precision, grad_non_hermit_right]
|
||||
&BEGIN_PROVIDER [ double precision, grad_non_hermit]
|
||||
|
||||
implicit none
|
||||
integer :: i, k
|
||||
|
||||
grad_non_hermit_left = 0.d0
|
||||
grad_non_hermit_right = 0.d0
|
||||
|
||||
do i = 1, elec_beta_num ! doc --> SOMO
|
||||
do k = elec_beta_num+1, elec_alpha_num
|
||||
grad_non_hermit_left = max(grad_non_hermit_left , dabs(Fock_matrix_tc_mo_tot(k,i)))
|
||||
grad_non_hermit_right = max(grad_non_hermit_right, dabs(Fock_matrix_tc_mo_tot(i,k)))
|
||||
!grad_non_hermit_left += dabs(Fock_matrix_tc_mo_tot(k,i))
|
||||
!grad_non_hermit_right += dabs(Fock_matrix_tc_mo_tot(i,k))
|
||||
!grad_non_hermit_left += Fock_matrix_tc_mo_tot(k,i) * Fock_matrix_tc_mo_tot(k,i)
|
||||
!grad_non_hermit_right += Fock_matrix_tc_mo_tot(i,k) * Fock_matrix_tc_mo_tot(i,k)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do i = 1, elec_beta_num ! doc --> virt
|
||||
do k = elec_alpha_num+1, mo_num
|
||||
grad_non_hermit_left = max(grad_non_hermit_left , dabs(Fock_matrix_tc_mo_tot(k,i)))
|
||||
grad_non_hermit_right = max(grad_non_hermit_right, dabs(Fock_matrix_tc_mo_tot(i,k)))
|
||||
!grad_non_hermit_left += dabs(Fock_matrix_tc_mo_tot(k,i))
|
||||
!grad_non_hermit_right += dabs(Fock_matrix_tc_mo_tot(i,k))
|
||||
grad_non_hermit_left += Fock_matrix_tc_mo_tot(k,i) * Fock_matrix_tc_mo_tot(k,i)
|
||||
grad_non_hermit_right += Fock_matrix_tc_mo_tot(i,k) * Fock_matrix_tc_mo_tot(i,k)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do i = elec_beta_num+1, elec_alpha_num ! SOMO --> virt
|
||||
do k = elec_alpha_num+1, mo_num
|
||||
grad_non_hermit_left = max(grad_non_hermit_left , dabs(Fock_matrix_tc_mo_tot(k,i)))
|
||||
grad_non_hermit_right = max(grad_non_hermit_right, dabs(Fock_matrix_tc_mo_tot(i,k)))
|
||||
!grad_non_hermit_left += dabs(Fock_matrix_tc_mo_tot(k,i))
|
||||
!grad_non_hermit_right += dabs(Fock_matrix_tc_mo_tot(i,k))
|
||||
grad_non_hermit_left += Fock_matrix_tc_mo_tot(k,i) * Fock_matrix_tc_mo_tot(k,i)
|
||||
grad_non_hermit_right += Fock_matrix_tc_mo_tot(i,k) * Fock_matrix_tc_mo_tot(i,k)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
!grad_non_hermit = dsqrt(grad_non_hermit_left) + dsqrt(grad_non_hermit_right)
|
||||
grad_non_hermit = grad_non_hermit_left + grad_non_hermit_right
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, Fock_matrix_tc_ao_tot, (ao_num, ao_num) ]
|
||||
|
||||
implicit none
|
||||
|
||||
call mo_to_ao_bi_ortho( Fock_matrix_tc_mo_tot, size(Fock_matrix_tc_mo_tot, 1) &
|
||||
, Fock_matrix_tc_ao_tot, size(Fock_matrix_tc_ao_tot, 1) )
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
|
||||
144
src/tc_scf/fock_tc_mo_tot.irp.f
Normal file
144
src/tc_scf/fock_tc_mo_tot.irp.f
Normal file
@ -0,0 +1,144 @@
|
||||
|
||||
BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_tot, (mo_num,mo_num) ]
|
||||
&BEGIN_PROVIDER [ double precision, Fock_matrix_tc_diag_mo_tot, (mo_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Fock matrix on the MO basis.
|
||||
! For open shells, the ROHF Fock Matrix is ::
|
||||
!
|
||||
! | F-K | F + K/2 | F |
|
||||
! |---------------------------------|
|
||||
! | F + K/2 | F | F - K/2 |
|
||||
! |---------------------------------|
|
||||
! | F | F - K/2 | F + K |
|
||||
!
|
||||
!
|
||||
! F = 1/2 (Fa + Fb)
|
||||
!
|
||||
! K = Fb - Fa
|
||||
!
|
||||
END_DOC
|
||||
integer :: i,j,n
|
||||
if (elec_alpha_num == elec_beta_num) then
|
||||
Fock_matrix_tc_mo_tot = Fock_matrix_tc_mo_alpha
|
||||
else
|
||||
|
||||
do j=1,elec_beta_num
|
||||
! F-K
|
||||
do i=1,elec_beta_num !CC
|
||||
Fock_matrix_tc_mo_tot(i,j) = 0.5d0*(Fock_matrix_tc_mo_alpha(i,j)+Fock_matrix_tc_mo_beta(i,j))&
|
||||
- (Fock_matrix_tc_mo_beta(i,j) - Fock_matrix_tc_mo_alpha(i,j))
|
||||
enddo
|
||||
! F+K/2
|
||||
do i=elec_beta_num+1,elec_alpha_num !CA
|
||||
Fock_matrix_tc_mo_tot(i,j) = 0.5d0*(Fock_matrix_tc_mo_alpha(i,j)+Fock_matrix_tc_mo_beta(i,j))&
|
||||
+ 0.5d0*(Fock_matrix_tc_mo_beta(i,j) - Fock_matrix_tc_mo_alpha(i,j))
|
||||
enddo
|
||||
! F
|
||||
do i=elec_alpha_num+1, mo_num !CV
|
||||
Fock_matrix_tc_mo_tot(i,j) = 0.5d0*(Fock_matrix_tc_mo_alpha(i,j)+Fock_matrix_tc_mo_beta(i,j))
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do j=elec_beta_num+1,elec_alpha_num
|
||||
! F+K/2
|
||||
do i=1,elec_beta_num !AC
|
||||
Fock_matrix_tc_mo_tot(i,j) = 0.5d0*(Fock_matrix_tc_mo_alpha(i,j)+Fock_matrix_tc_mo_beta(i,j))&
|
||||
+ 0.5d0*(Fock_matrix_tc_mo_beta(i,j) - Fock_matrix_tc_mo_alpha(i,j))
|
||||
enddo
|
||||
! F
|
||||
do i=elec_beta_num+1,elec_alpha_num !AA
|
||||
Fock_matrix_tc_mo_tot(i,j) = 0.5d0*(Fock_matrix_tc_mo_alpha(i,j)+Fock_matrix_tc_mo_beta(i,j))
|
||||
enddo
|
||||
! F-K/2
|
||||
do i=elec_alpha_num+1, mo_num !AV
|
||||
Fock_matrix_tc_mo_tot(i,j) = 0.5d0*(Fock_matrix_tc_mo_alpha(i,j)+Fock_matrix_tc_mo_beta(i,j))&
|
||||
- 0.5d0*(Fock_matrix_tc_mo_beta(i,j) - Fock_matrix_tc_mo_alpha(i,j))
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do j=elec_alpha_num+1, mo_num
|
||||
! F
|
||||
do i=1,elec_beta_num !VC
|
||||
Fock_matrix_tc_mo_tot(i,j) = 0.5d0*(Fock_matrix_tc_mo_alpha(i,j)+Fock_matrix_tc_mo_beta(i,j))
|
||||
enddo
|
||||
! F-K/2
|
||||
do i=elec_beta_num+1,elec_alpha_num !VA
|
||||
Fock_matrix_tc_mo_tot(i,j) = 0.5d0*(Fock_matrix_tc_mo_alpha(i,j)+Fock_matrix_tc_mo_beta(i,j))&
|
||||
- 0.5d0*(Fock_matrix_tc_mo_beta(i,j) - Fock_matrix_tc_mo_alpha(i,j))
|
||||
enddo
|
||||
! F+K
|
||||
do i=elec_alpha_num+1,mo_num !VV
|
||||
Fock_matrix_tc_mo_tot(i,j) = 0.5d0*(Fock_matrix_tc_mo_alpha(i,j)+Fock_matrix_tc_mo_beta(i,j)) &
|
||||
+ (Fock_matrix_tc_mo_beta(i,j) - Fock_matrix_tc_mo_alpha(i,j))
|
||||
enddo
|
||||
enddo
|
||||
if(three_body_h_tc)then
|
||||
! C-O
|
||||
do j = 1, elec_beta_num
|
||||
do i = elec_beta_num+1, elec_alpha_num
|
||||
Fock_matrix_tc_mo_tot(i,j) += 0.5d0*(fock_a_tot_3e_bi_orth(i,j) + fock_b_tot_3e_bi_orth(i,j))
|
||||
Fock_matrix_tc_mo_tot(j,i) += 0.5d0*(fock_a_tot_3e_bi_orth(j,i) + fock_b_tot_3e_bi_orth(j,i))
|
||||
enddo
|
||||
enddo
|
||||
! C-V
|
||||
do j = 1, elec_beta_num
|
||||
do i = elec_alpha_num+1, mo_num
|
||||
Fock_matrix_tc_mo_tot(i,j) += 0.5d0*(fock_a_tot_3e_bi_orth(i,j) + fock_b_tot_3e_bi_orth(i,j))
|
||||
Fock_matrix_tc_mo_tot(j,i) += 0.5d0*(fock_a_tot_3e_bi_orth(j,i) + fock_b_tot_3e_bi_orth(j,i))
|
||||
enddo
|
||||
enddo
|
||||
! O-V
|
||||
do j = elec_beta_num+1, elec_alpha_num
|
||||
do i = elec_alpha_num+1, mo_num
|
||||
Fock_matrix_tc_mo_tot(i,j) += 0.5d0*(fock_a_tot_3e_bi_orth(i,j) + fock_b_tot_3e_bi_orth(i,j))
|
||||
Fock_matrix_tc_mo_tot(j,i) += 0.5d0*(fock_a_tot_3e_bi_orth(j,i) + fock_b_tot_3e_bi_orth(j,i))
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
|
||||
endif
|
||||
|
||||
do i = 1, mo_num
|
||||
Fock_matrix_tc_diag_mo_tot(i) = Fock_matrix_tc_mo_tot(i,i)
|
||||
enddo
|
||||
|
||||
|
||||
if(frozen_orb_scf)then
|
||||
integer :: iorb,jorb
|
||||
do i = 1, n_core_orb
|
||||
iorb = list_core(i)
|
||||
do j = 1, n_act_orb
|
||||
jorb = list_act(j)
|
||||
Fock_matrix_tc_mo_tot(iorb,jorb) = 0.d0
|
||||
Fock_matrix_tc_mo_tot(jorb,iorb) = 0.d0
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
|
||||
if(no_oa_or_av_opt)then
|
||||
do i = 1, n_act_orb
|
||||
iorb = list_act(i)
|
||||
do j = 1, n_inact_orb
|
||||
jorb = list_inact(j)
|
||||
Fock_matrix_tc_mo_tot(iorb,jorb) = 0.d0
|
||||
Fock_matrix_tc_mo_tot(jorb,iorb) = 0.d0
|
||||
enddo
|
||||
do j = 1, n_virt_orb
|
||||
jorb = list_virt(j)
|
||||
Fock_matrix_tc_mo_tot(iorb,jorb) = 0.d0
|
||||
Fock_matrix_tc_mo_tot(jorb,iorb) = 0.d0
|
||||
enddo
|
||||
do j = 1, n_core_orb
|
||||
jorb = list_core(j)
|
||||
Fock_matrix_tc_mo_tot(iorb,jorb) = 0.d0
|
||||
Fock_matrix_tc_mo_tot(jorb,iorb) = 0.d0
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
if(.not.bi_ortho .and. three_body_h_tc)then
|
||||
Fock_matrix_tc_mo_tot += fock_3_mat
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
229
src/tc_scf/fock_three.irp.f
Normal file
229
src/tc_scf/fock_three.irp.f
Normal file
@ -0,0 +1,229 @@
|
||||
BEGIN_PROVIDER [ double precision, fock_3_mat, (mo_num, mo_num)]
|
||||
implicit none
|
||||
integer :: i,j
|
||||
double precision :: contrib
|
||||
fock_3_mat = 0.d0
|
||||
if(.not.bi_ortho.and.three_body_h_tc)then
|
||||
call give_fock_ia_three_e_total(1,1,contrib)
|
||||
!! !$OMP PARALLEL &
|
||||
!! !$OMP DEFAULT (NONE) &
|
||||
!! !$OMP PRIVATE (i,j,m,integral) &
|
||||
!! !$OMP SHARED (mo_num,three_body_3_index)
|
||||
!! !$OMP DO SCHEDULE (guided) COLLAPSE(3)
|
||||
do i = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
call give_fock_ia_three_e_total(j,i,contrib)
|
||||
fock_3_mat(j,i) = -contrib
|
||||
enddo
|
||||
enddo
|
||||
else if(bi_ortho.and.three_body_h_tc)then
|
||||
!! !$OMP END DO
|
||||
!! !$OMP END PARALLEL
|
||||
!! do i = 1, mo_num
|
||||
!! do j = 1, i-1
|
||||
!! mat_three(j,i) = mat_three(i,j)
|
||||
!! enddo
|
||||
!! enddo
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
subroutine give_fock_ia_three_e_total(i,a,contrib)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! contrib is the TOTAL (same spins / opposite spins) contribution from the three body term to the Fock operator
|
||||
!
|
||||
END_DOC
|
||||
integer, intent(in) :: i,a
|
||||
double precision, intent(out) :: contrib
|
||||
double precision :: int_1, int_2, int_3
|
||||
double precision :: mos_i, mos_a, w_ia
|
||||
double precision :: mos_ia, weight
|
||||
|
||||
integer :: mm, ipoint,k,l
|
||||
|
||||
int_1 = 0.d0
|
||||
int_2 = 0.d0
|
||||
int_3 = 0.d0
|
||||
do mm = 1, 3
|
||||
do ipoint = 1, n_points_final_grid
|
||||
weight = final_weight_at_r_vector(ipoint)
|
||||
mos_i = mos_in_r_array_transp(ipoint,i)
|
||||
mos_a = mos_in_r_array_transp(ipoint,a)
|
||||
mos_ia = mos_a * mos_i
|
||||
w_ia = x_W_ij_erf_rk(ipoint,mm,i,a)
|
||||
|
||||
int_1 += weight * fock_3_w_kk_sum(ipoint,mm) * (4.d0 * fock_3_rho_beta(ipoint) * w_ia &
|
||||
+ 2.0d0 * mos_ia * fock_3_w_kk_sum(ipoint,mm) &
|
||||
- 2.0d0 * fock_3_w_ki_mos_k(ipoint,mm,i) * mos_a &
|
||||
- 2.0d0 * fock_3_w_ki_mos_k(ipoint,mm,a) * mos_i )
|
||||
int_2 += weight * (-1.d0) * ( 2.0d0 * fock_3_w_kl_mo_k_mo_l(ipoint,mm) * w_ia &
|
||||
+ 2.0d0 * fock_3_rho_beta(ipoint) * fock_3_w_ki_wk_a(ipoint,mm,i,a) &
|
||||
+ 1.0d0 * mos_ia * fock_3_trace_w_tilde(ipoint,mm) )
|
||||
|
||||
int_3 += weight * 1.d0 * (fock_3_w_kl_wla_phi_k(ipoint,mm,i) * mos_a + fock_3_w_kl_wla_phi_k(ipoint,mm,a) * mos_i &
|
||||
+fock_3_w_ki_mos_k(ipoint,mm,i) * fock_3_w_ki_mos_k(ipoint,mm,a) )
|
||||
enddo
|
||||
enddo
|
||||
contrib = int_1 + int_2 + int_3
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, diag_three_elem_hf]
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, ipoint, mm
|
||||
double precision :: contrib, weight, four_third, one_third, two_third, exchange_int_231
|
||||
double precision :: integral_aaa, hthree, integral_aab, integral_abb, integral_bbb
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
!print *, ' providing diag_three_elem_hf'
|
||||
|
||||
if(.not. three_body_h_tc) then
|
||||
|
||||
diag_three_elem_hf = 0.d0
|
||||
|
||||
else
|
||||
|
||||
if(.not. bi_ortho) then
|
||||
|
||||
! ---
|
||||
|
||||
one_third = 1.d0/3.d0
|
||||
two_third = 2.d0/3.d0
|
||||
four_third = 4.d0/3.d0
|
||||
diag_three_elem_hf = 0.d0
|
||||
do i = 1, elec_beta_num
|
||||
do j = 1, elec_beta_num
|
||||
do k = 1, elec_beta_num
|
||||
call give_integrals_3_body(k, j, i, j, i, k,exchange_int_231)
|
||||
diag_three_elem_hf += two_third * exchange_int_231
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
do mm = 1, 3
|
||||
do ipoint = 1, n_points_final_grid
|
||||
weight = final_weight_at_r_vector(ipoint)
|
||||
contrib = 3.d0 * fock_3_w_kk_sum(ipoint,mm) * fock_3_rho_beta(ipoint) * fock_3_w_kk_sum(ipoint,mm) &
|
||||
- 2.d0 * fock_3_w_kl_mo_k_mo_l(ipoint,mm) * fock_3_w_kk_sum(ipoint,mm) &
|
||||
- 1.d0 * fock_3_rho_beta(ipoint) * fock_3_w_kl_w_kl(ipoint,mm)
|
||||
contrib *= four_third
|
||||
contrib += -two_third * fock_3_rho_beta(ipoint) * fock_3_w_kl_w_kl(ipoint,mm) &
|
||||
-four_third * fock_3_w_kk_sum(ipoint,mm) * fock_3_w_kl_mo_k_mo_l(ipoint,mm)
|
||||
diag_three_elem_hf += weight * contrib
|
||||
enddo
|
||||
enddo
|
||||
|
||||
diag_three_elem_hf = - diag_three_elem_hf
|
||||
|
||||
! ---
|
||||
|
||||
else
|
||||
|
||||
provide mo_l_coef mo_r_coef
|
||||
call give_aaa_contrib(integral_aaa)
|
||||
call give_aab_contrib(integral_aab)
|
||||
call give_abb_contrib(integral_abb)
|
||||
call give_bbb_contrib(integral_bbb)
|
||||
diag_three_elem_hf = integral_aaa + integral_aab + integral_abb + integral_bbb
|
||||
! print*,'integral_aaa + integral_aab + integral_abb + integral_bbb'
|
||||
! print*,integral_aaa , integral_aab , integral_abb , integral_bbb
|
||||
|
||||
endif
|
||||
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, fock_3_mat_a_op_sh, (mo_num, mo_num)]
|
||||
implicit none
|
||||
integer :: h,p,i,j
|
||||
double precision :: direct_int, exch_int, exchange_int_231, exchange_int_312
|
||||
double precision :: exchange_int_23, exchange_int_12, exchange_int_13
|
||||
|
||||
fock_3_mat_a_op_sh = 0.d0
|
||||
do h = 1, mo_num
|
||||
do p = 1, mo_num
|
||||
!F_a^{ab}(h,p)
|
||||
do i = 1, elec_beta_num ! beta
|
||||
do j = elec_beta_num+1, elec_alpha_num ! alpha
|
||||
call give_integrals_3_body(h,j,i,p,j,i,direct_int) ! <hji|pji>
|
||||
call give_integrals_3_body(h,j,i,j,p,i,exch_int)
|
||||
fock_3_mat_a_op_sh(h,p) -= direct_int - exch_int
|
||||
enddo
|
||||
enddo
|
||||
!F_a^{aa}(h,p)
|
||||
do i = 1, elec_beta_num ! alpha
|
||||
do j = elec_beta_num+1, elec_alpha_num ! alpha
|
||||
direct_int = three_body_4_index(j,i,h,p)
|
||||
call give_integrals_3_body(h,j,i,p,j,i,direct_int)
|
||||
call give_integrals_3_body(h,j,i,i,p,j,exchange_int_231)
|
||||
call give_integrals_3_body(h,j,i,j,i,p,exchange_int_312)
|
||||
call give_integrals_3_body(h,j,i,p,i,j,exchange_int_23)
|
||||
call give_integrals_3_body(h,j,i,i,j,p,exchange_int_12)
|
||||
call give_integrals_3_body(h,j,i,j,p,i,exchange_int_13)
|
||||
fock_3_mat_a_op_sh(h,p) -= ( direct_int + exchange_int_231 + exchange_int_312 &
|
||||
- exchange_int_23 & ! i <-> j
|
||||
- exchange_int_12 & ! p <-> j
|
||||
- exchange_int_13 )! p <-> i
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
! symmetrized
|
||||
! do p = 1, elec_beta_num
|
||||
! do h = elec_alpha_num +1, mo_num
|
||||
! fock_3_mat_a_op_sh(h,p) = fock_3_mat_a_op_sh(p,h)
|
||||
! enddo
|
||||
! enddo
|
||||
|
||||
! do h = elec_beta_num+1, elec_alpha_num
|
||||
! do p = elec_alpha_num +1, mo_num
|
||||
! !F_a^{bb}(h,p)
|
||||
! do i = 1, elec_beta_num
|
||||
! do j = i+1, elec_beta_num
|
||||
! call give_integrals_3_body(h,j,i,p,j,i,direct_int)
|
||||
! call give_integrals_3_body(h,j,i,p,i,j,exch_int)
|
||||
! fock_3_mat_a_op_sh(h,p) -= direct_int - exch_int
|
||||
! enddo
|
||||
! enddo
|
||||
! enddo
|
||||
! enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, fock_3_mat_b_op_sh, (mo_num, mo_num)]
|
||||
implicit none
|
||||
integer :: h,p,i,j
|
||||
double precision :: direct_int, exch_int
|
||||
fock_3_mat_b_op_sh = 0.d0
|
||||
do h = 1, elec_beta_num
|
||||
do p = elec_alpha_num +1, mo_num
|
||||
!F_b^{aa}(h,p)
|
||||
do i = 1, elec_beta_num
|
||||
do j = elec_beta_num+1, elec_alpha_num
|
||||
call give_integrals_3_body(h,j,i,p,j,i,direct_int)
|
||||
call give_integrals_3_body(h,j,i,p,i,j,exch_int)
|
||||
fock_3_mat_b_op_sh(h,p) += direct_int - exch_int
|
||||
enddo
|
||||
enddo
|
||||
|
||||
!F_b^{ab}(h,p)
|
||||
do i = elec_beta_num+1, elec_beta_num
|
||||
do j = 1, elec_beta_num
|
||||
call give_integrals_3_body(h,j,i,p,j,i,direct_int)
|
||||
call give_integrals_3_body(h,j,i,j,p,i,exch_int)
|
||||
fock_3_mat_b_op_sh(h,p) += direct_int - exch_int
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
178
src/tc_scf/fock_three_bi_ortho.irp.f
Normal file
178
src/tc_scf/fock_three_bi_ortho.irp.f
Normal file
@ -0,0 +1,178 @@
|
||||
BEGIN_PROVIDER [ double precision, fock_a_abb_3e_bi_orth_old, (mo_num, mo_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! fock_a_abb_3e_bi_orth_old(a,i) = bi-ortho 3-e Fock matrix for alpha electrons from alpha,beta,beta contribution
|
||||
END_DOC
|
||||
fock_a_abb_3e_bi_orth_old = 0.d0
|
||||
integer :: i,a,j,k
|
||||
double precision :: direct_int, exch_23_int
|
||||
do i = 1, mo_num
|
||||
do a = 1, mo_num
|
||||
|
||||
do j = 1, elec_beta_num
|
||||
do k = j+1, elec_beta_num
|
||||
! see contrib_3e_soo
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int) ! < a k j | i k j >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)! < a k j | i j k > : E_23
|
||||
fock_a_abb_3e_bi_orth_old(a,i) += direct_int - exch_23_int
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
enddo
|
||||
fock_a_abb_3e_bi_orth_old = - fock_a_abb_3e_bi_orth_old
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, fock_a_aba_3e_bi_orth_old, (mo_num, mo_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! fock_a_aba_3e_bi_orth_old(a,i) = bi-ortho 3-e Fock matrix for alpha electrons from alpha,alpha,beta contribution
|
||||
END_DOC
|
||||
fock_a_aba_3e_bi_orth_old = 0.d0
|
||||
integer :: i,a,j,k
|
||||
double precision :: direct_int, exch_13_int
|
||||
do i = 1, mo_num
|
||||
do a = 1, mo_num
|
||||
|
||||
do j = 1, elec_alpha_num ! a
|
||||
do k = 1, elec_beta_num ! b
|
||||
! a b a a b a
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )! < a k j | i k j >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)! < a k j | j k i > : E_13
|
||||
fock_a_aba_3e_bi_orth_old(a,i) += direct_int - exch_13_int
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
enddo
|
||||
fock_a_aba_3e_bi_orth_old = - fock_a_aba_3e_bi_orth_old
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, fock_a_aaa_3e_bi_orth_old, (mo_num, mo_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! fock_a_aaa_3e_bi_orth_old(a,i) = bi-ortho 3-e Fock matrix for alpha electrons from alpha,alpha,alpha contribution
|
||||
END_DOC
|
||||
fock_a_aaa_3e_bi_orth_old = 0.d0
|
||||
integer :: i,a,j,k
|
||||
double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int, c_3_int, c_minus_3_int
|
||||
do i = 1, mo_num
|
||||
do a = 1, mo_num
|
||||
|
||||
do j = 1, elec_alpha_num
|
||||
do k = j+1, elec_alpha_num
|
||||
! positive terms :: cycle contrib
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, j, i, k, c_3_int) ! < a k j | j i k >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, k, j, i, c_minus_3_int)! < a k j | k j i >
|
||||
fock_a_aaa_3e_bi_orth_old(a,i) += direct_int + c_3_int + c_minus_3_int
|
||||
! negative terms :: exchange contrib
|
||||
call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23
|
||||
call give_integrals_3_body_bi_ort(a, k, j, k, i, j, exch_12_int)!!! < a k j | k i j > : E_12
|
||||
fock_a_aaa_3e_bi_orth_old(a,i) += - exch_13_int - exch_23_int - exch_12_int
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
enddo
|
||||
fock_a_aaa_3e_bi_orth_old = - fock_a_aaa_3e_bi_orth_old
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_a_tot_3e_bi_orth_old, (mo_num, mo_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! fock_a_tot_3e_bi_orth_old = bi-ortho 3-e Fock matrix for alpha electrons from all possible spin contributions
|
||||
END_DOC
|
||||
fock_a_tot_3e_bi_orth_old = fock_a_abb_3e_bi_orth_old + fock_a_aba_3e_bi_orth_old + fock_a_aaa_3e_bi_orth_old
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, fock_b_baa_3e_bi_orth_old, (mo_num, mo_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! fock_b_baa_3e_bi_orth_old(a,i) = bi-ortho 3-e Fock matrix for beta electrons from beta,alpha,alpha contribution
|
||||
END_DOC
|
||||
fock_b_baa_3e_bi_orth_old = 0.d0
|
||||
integer :: i,a,j,k
|
||||
double precision :: direct_int, exch_23_int
|
||||
do i = 1, mo_num
|
||||
do a = 1, mo_num
|
||||
|
||||
do j = 1, elec_alpha_num
|
||||
do k = j+1, elec_alpha_num
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int) ! < a k j | i k j >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)! < a k j | i j k > : E_23
|
||||
fock_b_baa_3e_bi_orth_old(a,i) += direct_int - exch_23_int
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
enddo
|
||||
fock_b_baa_3e_bi_orth_old = - fock_b_baa_3e_bi_orth_old
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, fock_b_bab_3e_bi_orth_old, (mo_num, mo_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! fock_b_bab_3e_bi_orth_old(a,i) = bi-ortho 3-e Fock matrix for beta electrons from beta,alpha,beta contribution
|
||||
END_DOC
|
||||
fock_b_bab_3e_bi_orth_old = 0.d0
|
||||
integer :: i,a,j,k
|
||||
double precision :: direct_int, exch_13_int
|
||||
do i = 1, mo_num
|
||||
do a = 1, mo_num
|
||||
|
||||
do j = 1, elec_beta_num
|
||||
do k = 1, elec_alpha_num
|
||||
! b a b b a b
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int) ! < a k j | i k j >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)! < a k j | j k i > : E_13
|
||||
fock_b_bab_3e_bi_orth_old(a,i) += direct_int - exch_13_int
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
enddo
|
||||
fock_b_bab_3e_bi_orth_old = - fock_b_bab_3e_bi_orth_old
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, fock_b_bbb_3e_bi_orth_old, (mo_num, mo_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! fock_b_bbb_3e_bi_orth_old(a,i) = bi-ortho 3-e Fock matrix for alpha electrons from alpha,alpha,alpha contribution
|
||||
END_DOC
|
||||
fock_b_bbb_3e_bi_orth_old = 0.d0
|
||||
integer :: i,a,j,k
|
||||
double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int, c_3_int, c_minus_3_int
|
||||
do i = 1, mo_num
|
||||
do a = 1, mo_num
|
||||
|
||||
do j = 1, elec_beta_num
|
||||
do k = j+1, elec_beta_num
|
||||
! positive terms :: cycle contrib
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, j, i, k, c_3_int) ! < a k j | j i k >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, k, j, i, c_minus_3_int)! < a k j | k j i >
|
||||
fock_b_bbb_3e_bi_orth_old(a,i) += direct_int + c_3_int + c_minus_3_int
|
||||
! negative terms :: exchange contrib
|
||||
call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23
|
||||
call give_integrals_3_body_bi_ort(a, k, j, k, i, j, exch_12_int)!!! < a k j | k i j > : E_12
|
||||
fock_b_bbb_3e_bi_orth_old(a,i) += - exch_13_int - exch_23_int - exch_12_int
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
enddo
|
||||
fock_b_bbb_3e_bi_orth_old = - fock_b_bbb_3e_bi_orth_old
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, fock_b_tot_3e_bi_orth_old, (mo_num, mo_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! fock_b_tot_3e_bi_orth_old = bi-ortho 3-e Fock matrix for alpha electrons from all possible spin contributions
|
||||
END_DOC
|
||||
fock_b_tot_3e_bi_orth_old = fock_b_bbb_3e_bi_orth_old + fock_b_bab_3e_bi_orth_old + fock_b_baa_3e_bi_orth_old
|
||||
|
||||
END_PROVIDER
|
||||
286
src/tc_scf/fock_three_bi_ortho_new_new.irp.f
Normal file
286
src/tc_scf/fock_three_bi_ortho_new_new.irp.f
Normal file
@ -0,0 +1,286 @@
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_a_tot_3e_bi_orth, (mo_num, mo_num)]
|
||||
|
||||
implicit none
|
||||
integer :: i, a
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
fock_a_tot_3e_bi_orth = 0.d0
|
||||
|
||||
do i = 1, mo_num
|
||||
do a = 1, mo_num
|
||||
fock_a_tot_3e_bi_orth(a,i) += fock_cs_3e_bi_orth (a,i)
|
||||
fock_a_tot_3e_bi_orth(a,i) += fock_a_tmp1_bi_ortho(a,i)
|
||||
fock_a_tot_3e_bi_orth(a,i) += fock_a_tmp2_bi_ortho(a,i)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_b_tot_3e_bi_orth, (mo_num, mo_num)]
|
||||
|
||||
implicit none
|
||||
integer :: i, a
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
fock_b_tot_3e_bi_orth = 0.d0
|
||||
|
||||
do i = 1, mo_num
|
||||
do a = 1, mo_num
|
||||
fock_b_tot_3e_bi_orth(a,i) += fock_cs_3e_bi_orth (a,i)
|
||||
fock_b_tot_3e_bi_orth(a,i) += fock_b_tmp2_bi_ortho(a,i)
|
||||
fock_b_tot_3e_bi_orth(a,i) += fock_b_tmp1_bi_ortho(a,i)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_cs_3e_bi_orth, (mo_num, mo_num)]
|
||||
|
||||
implicit none
|
||||
integer :: i, a, j, k
|
||||
double precision :: contrib_sss, contrib_sos, contrib_soo, contrib
|
||||
double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int, c_3_int, c_minus_3_int
|
||||
double precision :: new
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
fock_cs_3e_bi_orth = 0.d0
|
||||
|
||||
do i = 1, mo_num
|
||||
do a = 1, mo_num
|
||||
|
||||
do j = 1, elec_beta_num
|
||||
do k = 1, elec_beta_num
|
||||
|
||||
!!call contrib_3e_sss(a,i,j,k,contrib_sss)
|
||||
!!call contrib_3e_soo(a,i,j,k,contrib_soo)
|
||||
!!call contrib_3e_sos(a,i,j,k,contrib_sos)
|
||||
!!contrib = 0.5d0 * (contrib_sss + contrib_soo) + contrib_sos
|
||||
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, j, i, k, c_3_int) ! < a k j | j i k >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, k, j, i, c_minus_3_int)! < a k j | k j i >
|
||||
|
||||
! negative terms :: exchange contrib
|
||||
call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23
|
||||
call give_integrals_3_body_bi_ort(a, k, j, k, i, j, exch_12_int)!!! < a k j | k i j > : E_12
|
||||
|
||||
new = 2.d0 * direct_int + 0.5d0 * (c_3_int + c_minus_3_int - exch_12_int) -1.5d0 * exch_13_int - exch_23_int
|
||||
|
||||
fock_cs_3e_bi_orth(a,i) += new
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
fock_cs_3e_bi_orth = - fock_cs_3e_bi_orth
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_a_tmp1_bi_ortho, (mo_num, mo_num)]
|
||||
|
||||
implicit none
|
||||
integer :: i, a, j, k
|
||||
double precision :: contrib_sss, contrib_sos, contrib_soo, contrib
|
||||
double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int, c_3_int, c_minus_3_int
|
||||
double precision :: new
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
fock_a_tmp1_bi_ortho = 0.d0
|
||||
|
||||
do i = 1, mo_num
|
||||
do a = 1, mo_num
|
||||
|
||||
do j = elec_beta_num + 1, elec_alpha_num
|
||||
do k = 1, elec_beta_num
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, j, i, k, c_3_int) ! < a k j | j i k >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, k, j, i, c_minus_3_int)! < a k j | k j i >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23
|
||||
call give_integrals_3_body_bi_ort(a, k, j, k, i, j, exch_12_int)!!! < a k j | k i j > : E_12
|
||||
|
||||
fock_a_tmp1_bi_ortho(a,i) += 1.5d0 * (direct_int - exch_13_int) + 0.5d0 * (c_3_int + c_minus_3_int - exch_23_int - exch_12_int)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
fock_a_tmp1_bi_ortho = - fock_a_tmp1_bi_ortho
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_a_tmp2_bi_ortho, (mo_num, mo_num)]
|
||||
|
||||
implicit none
|
||||
integer :: i, a, j, k
|
||||
double precision :: contrib_sss
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
fock_a_tmp2_bi_ortho = 0.d0
|
||||
|
||||
do i = 1, mo_num
|
||||
do a = 1, mo_num
|
||||
do j = 1, elec_alpha_num
|
||||
do k = elec_beta_num+1, elec_alpha_num
|
||||
call contrib_3e_sss(a, i, j, k, contrib_sss)
|
||||
|
||||
fock_a_tmp2_bi_ortho(a,i) += 0.5d0 * contrib_sss
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_b_tmp1_bi_ortho, (mo_num, mo_num)]
|
||||
|
||||
implicit none
|
||||
integer :: i, a, j, k
|
||||
double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int
|
||||
double precision :: new
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
fock_b_tmp1_bi_ortho = 0.d0
|
||||
|
||||
do i = 1, mo_num
|
||||
do a = 1, mo_num
|
||||
do j = 1, elec_beta_num
|
||||
do k = elec_beta_num+1, elec_alpha_num
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23
|
||||
|
||||
fock_b_tmp1_bi_ortho(a,i) += 1.5d0 * direct_int - 0.5d0 * exch_23_int - exch_13_int
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
fock_b_tmp1_bi_ortho = - fock_b_tmp1_bi_ortho
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_b_tmp2_bi_ortho, (mo_num, mo_num)]
|
||||
|
||||
implicit none
|
||||
integer :: i, a, j, k
|
||||
double precision :: contrib_soo
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
fock_b_tmp2_bi_ortho = 0.d0
|
||||
|
||||
do i = 1, mo_num
|
||||
do a = 1, mo_num
|
||||
do j = elec_beta_num + 1, elec_alpha_num
|
||||
do k = 1, elec_alpha_num
|
||||
call contrib_3e_soo(a, i, j, k, contrib_soo)
|
||||
|
||||
fock_b_tmp2_bi_ortho(a,i) += 0.5d0 * contrib_soo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
subroutine contrib_3e_sss(a, i, j, k, integral)
|
||||
|
||||
BEGIN_DOC
|
||||
! returns the pure same spin contribution to F(a,i) from two orbitals j,k
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: a, i, j, k
|
||||
double precision, intent(out) :: integral
|
||||
double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int, c_3_int, c_minus_3_int
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, j, i, k, c_3_int) ! < a k j | j i k >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, k, j, i, c_minus_3_int)! < a k j | k j i >
|
||||
integral = direct_int + c_3_int + c_minus_3_int
|
||||
|
||||
! negative terms :: exchange contrib
|
||||
call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23
|
||||
call give_integrals_3_body_bi_ort(a, k, j, k, i, j, exch_12_int)!!! < a k j | k i j > : E_12
|
||||
integral += - exch_13_int - exch_23_int - exch_12_int
|
||||
|
||||
integral = -integral
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine contrib_3e_soo(a,i,j,k,integral)
|
||||
|
||||
BEGIN_DOC
|
||||
! returns the same spin / opposite spin / opposite spin contribution to F(a,i) from two orbitals j,k
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: a, i, j, k
|
||||
double precision, intent(out) :: integral
|
||||
double precision :: direct_int, exch_23_int
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int) ! < a k j | i k j >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)! < a k j | i j k > : E_23
|
||||
integral = direct_int - exch_23_int
|
||||
|
||||
integral = -integral
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine contrib_3e_sos(a, i, j, k, integral)
|
||||
|
||||
BEGIN_DOC
|
||||
! returns the same spin / opposite spin / same spin contribution to F(a,i) from two orbitals j,k
|
||||
END_DOC
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: a, i, j, k
|
||||
double precision, intent(out) :: integral
|
||||
double precision :: direct_int, exch_13_int
|
||||
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )! < a k j | i k j >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)! < a k j | j k i > : E_13
|
||||
integral = direct_int - exch_13_int
|
||||
|
||||
integral = -integral
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
140
src/tc_scf/fock_three_utils.irp.f
Normal file
140
src/tc_scf/fock_three_utils.irp.f
Normal file
@ -0,0 +1,140 @@
|
||||
|
||||
BEGIN_PROVIDER [ double precision, fock_3_w_kk_sum, (n_points_final_grid,3)]
|
||||
implicit none
|
||||
integer :: mm, ipoint,k
|
||||
double precision :: w_kk
|
||||
fock_3_w_kk_sum = 0.d0
|
||||
do k = 1, elec_beta_num
|
||||
do mm = 1, 3
|
||||
do ipoint = 1, n_points_final_grid
|
||||
w_kk = x_W_ij_erf_rk(ipoint,mm,k,k)
|
||||
fock_3_w_kk_sum(ipoint,mm) += w_kk
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, fock_3_w_ki_mos_k, (n_points_final_grid,3,mo_num)]
|
||||
implicit none
|
||||
integer :: mm, ipoint,k,i
|
||||
double precision :: w_ki, mo_k
|
||||
fock_3_w_ki_mos_k = 0.d0
|
||||
do i = 1, mo_num
|
||||
do k = 1, elec_beta_num
|
||||
do mm = 1, 3
|
||||
do ipoint = 1, n_points_final_grid
|
||||
w_ki = x_W_ij_erf_rk(ipoint,mm,k,i)
|
||||
mo_k = mos_in_r_array(k,ipoint)
|
||||
fock_3_w_ki_mos_k(ipoint,mm,i) += w_ki * mo_k
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, fock_3_w_kl_w_kl, (n_points_final_grid,3)]
|
||||
implicit none
|
||||
integer :: k,j,ipoint,mm
|
||||
double precision :: w_kj
|
||||
fock_3_w_kl_w_kl = 0.d0
|
||||
do j = 1, elec_beta_num
|
||||
do k = 1, elec_beta_num
|
||||
do mm = 1, 3
|
||||
do ipoint = 1, n_points_final_grid
|
||||
w_kj = x_W_ij_erf_rk(ipoint,mm,k,j)
|
||||
fock_3_w_kl_w_kl(ipoint,mm) += w_kj * w_kj
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, fock_3_rho_beta, (n_points_final_grid)]
|
||||
implicit none
|
||||
integer :: ipoint,k
|
||||
fock_3_rho_beta = 0.d0
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do k = 1, elec_beta_num
|
||||
fock_3_rho_beta(ipoint) += mos_in_r_array(k,ipoint) * mos_in_r_array(k,ipoint)
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, fock_3_w_kl_mo_k_mo_l, (n_points_final_grid,3)]
|
||||
implicit none
|
||||
integer :: ipoint,k,l,mm
|
||||
double precision :: mos_k, mos_l, w_kl
|
||||
fock_3_w_kl_mo_k_mo_l = 0.d0
|
||||
do k = 1, elec_beta_num
|
||||
do l = 1, elec_beta_num
|
||||
do mm = 1, 3
|
||||
do ipoint = 1, n_points_final_grid
|
||||
mos_k = mos_in_r_array_transp(ipoint,k)
|
||||
mos_l = mos_in_r_array_transp(ipoint,l)
|
||||
w_kl = x_W_ij_erf_rk(ipoint,mm,l,k)
|
||||
fock_3_w_kl_mo_k_mo_l(ipoint,mm) += w_kl * mos_k * mos_l
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, fock_3_w_ki_wk_a, (n_points_final_grid,3,mo_num, mo_num)]
|
||||
implicit none
|
||||
integer :: ipoint,i,a,k,mm
|
||||
double precision :: w_ki,w_ka
|
||||
fock_3_w_ki_wk_a = 0.d0
|
||||
do i = 1, mo_num
|
||||
do a = 1, mo_num
|
||||
do mm = 1, 3
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do k = 1, elec_beta_num
|
||||
w_ki = x_W_ij_erf_rk(ipoint,mm,k,i)
|
||||
w_ka = x_W_ij_erf_rk(ipoint,mm,k,a)
|
||||
fock_3_w_ki_wk_a(ipoint,mm,a,i) += w_ki * w_ka
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, fock_3_trace_w_tilde, (n_points_final_grid,3)]
|
||||
implicit none
|
||||
integer :: ipoint,k,mm
|
||||
fock_3_trace_w_tilde = 0.d0
|
||||
do k = 1, elec_beta_num
|
||||
do mm = 1, 3
|
||||
do ipoint = 1, n_points_final_grid
|
||||
fock_3_trace_w_tilde(ipoint,mm) += fock_3_w_ki_wk_a(ipoint,mm,k,k)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, fock_3_w_kl_wla_phi_k, (n_points_final_grid,3,mo_num)]
|
||||
implicit none
|
||||
integer :: ipoint,a,k,mm,l
|
||||
double precision :: w_kl,w_la, mo_k
|
||||
fock_3_w_kl_wla_phi_k = 0.d0
|
||||
do a = 1, mo_num
|
||||
do k = 1, elec_beta_num
|
||||
do l = 1, elec_beta_num
|
||||
do mm = 1, 3
|
||||
do ipoint = 1, n_points_final_grid
|
||||
w_kl = x_W_ij_erf_rk(ipoint,mm,l,k)
|
||||
w_la = x_W_ij_erf_rk(ipoint,mm,l,a)
|
||||
mo_k = mos_in_r_array_transp(ipoint,k)
|
||||
fock_3_w_kl_wla_phi_k(ipoint,mm,a) += w_kl * w_la * mo_k
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
391
src/tc_scf/integrals_in_r_stuff.irp.f
Normal file
391
src/tc_scf/integrals_in_r_stuff.irp.f
Normal file
@ -0,0 +1,391 @@
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, tc_scf_dm_in_r, (n_points_final_grid) ]
|
||||
|
||||
implicit none
|
||||
integer :: i, j
|
||||
|
||||
tc_scf_dm_in_r = 0.d0
|
||||
do i = 1, n_points_final_grid
|
||||
do j = 1, elec_beta_num
|
||||
tc_scf_dm_in_r(i) += mos_r_in_r_array(j,i) * mos_l_in_r_array(j,i)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, w_sum_in_r, (n_points_final_grid, 3)]
|
||||
|
||||
implicit none
|
||||
integer :: ipoint, j, xi
|
||||
|
||||
w_sum_in_r = 0.d0
|
||||
do j = 1, elec_beta_num
|
||||
do xi = 1, 3
|
||||
do ipoint = 1, n_points_final_grid
|
||||
!w_sum_in_r(ipoint,xi) += x_W_ki_bi_ortho_erf_rk(ipoint,xi,j,j)
|
||||
w_sum_in_r(ipoint,xi) += x_W_ki_bi_ortho_erf_rk_diag(ipoint,xi,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, ww_sum_in_r, (n_points_final_grid, 3)]
|
||||
|
||||
implicit none
|
||||
integer :: ipoint, j, xi
|
||||
double precision :: tmp
|
||||
|
||||
ww_sum_in_r = 0.d0
|
||||
do j = 1, elec_beta_num
|
||||
do xi = 1, 3
|
||||
do ipoint = 1, n_points_final_grid
|
||||
tmp = x_W_ki_bi_ortho_erf_rk_diag(ipoint,xi,j)
|
||||
ww_sum_in_r(ipoint,xi) += tmp * tmp
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, W1_r_in_r, (n_points_final_grid, 3, mo_num)]
|
||||
|
||||
implicit none
|
||||
integer :: i, j, xi, ipoint
|
||||
|
||||
! TODO: call lapack
|
||||
|
||||
W1_r_in_r = 0.d0
|
||||
do i = 1, mo_num
|
||||
do j = 1, elec_beta_num
|
||||
do xi = 1, 3
|
||||
do ipoint = 1, n_points_final_grid
|
||||
W1_r_in_r(ipoint,xi,i) += mos_r_in_r_array_transp(ipoint,j) * x_W_ki_bi_ortho_erf_rk(ipoint,xi,j,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, W1_l_in_r, (n_points_final_grid, 3, mo_num)]
|
||||
|
||||
implicit none
|
||||
integer :: i, j, xi, ipoint
|
||||
|
||||
! TODO: call lapack
|
||||
|
||||
W1_l_in_r = 0.d0
|
||||
do i = 1, mo_num
|
||||
do j = 1, elec_beta_num
|
||||
do xi = 1, 3
|
||||
do ipoint = 1, n_points_final_grid
|
||||
W1_l_in_r(ipoint,xi,i) += mos_l_in_r_array_transp(ipoint,j) * x_W_ki_bi_ortho_erf_rk(ipoint,xi,i,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, W1_in_r, (n_points_final_grid, 3)]
|
||||
|
||||
implicit none
|
||||
integer :: j, xi, ipoint
|
||||
|
||||
! TODO: call lapack
|
||||
|
||||
W1_in_r = 0.d0
|
||||
do j = 1, elec_beta_num
|
||||
do xi = 1, 3
|
||||
do ipoint = 1, n_points_final_grid
|
||||
W1_in_r(ipoint,xi) += W1_l_in_r(ipoint,xi,j) * mos_r_in_r_array_transp(ipoint,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, W1_diag_in_r, (n_points_final_grid, 3)]
|
||||
|
||||
implicit none
|
||||
integer :: j, xi, ipoint
|
||||
|
||||
! TODO: call lapack
|
||||
|
||||
W1_diag_in_r = 0.d0
|
||||
do j = 1, elec_beta_num
|
||||
do xi = 1, 3
|
||||
do ipoint = 1, n_points_final_grid
|
||||
W1_diag_in_r(ipoint,xi) += mos_r_in_r_array_transp(ipoint,j) * mos_l_in_r_array_transp(ipoint,j) * x_W_ki_bi_ortho_erf_rk_diag(ipoint,xi,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, v_sum_in_r, (n_points_final_grid, 3)]
|
||||
|
||||
implicit none
|
||||
integer :: i, j, xi, ipoint
|
||||
|
||||
! TODO: call lapack
|
||||
v_sum_in_r = 0.d0
|
||||
do i = 1, elec_beta_num
|
||||
do j = 1, elec_beta_num
|
||||
do xi = 1, 3
|
||||
do ipoint = 1, n_points_final_grid
|
||||
v_sum_in_r(ipoint,xi) += x_W_ki_bi_ortho_erf_rk(ipoint,xi,i,j) * x_W_ki_bi_ortho_erf_rk(ipoint,xi,j,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, W1_W1_r_in_r, (n_points_final_grid, 3, mo_num)]
|
||||
|
||||
implicit none
|
||||
integer :: i, m, xi, ipoint
|
||||
|
||||
! TODO: call lapack
|
||||
|
||||
W1_W1_r_in_r = 0.d0
|
||||
do i = 1, mo_num
|
||||
do m = 1, elec_beta_num
|
||||
do xi = 1, 3
|
||||
do ipoint = 1, n_points_final_grid
|
||||
W1_W1_r_in_r(ipoint,xi,i) += x_W_ki_bi_ortho_erf_rk(ipoint,xi,m,i) * W1_r_in_r(ipoint,xi,m)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, W1_W1_l_in_r, (n_points_final_grid, 3, mo_num)]
|
||||
|
||||
implicit none
|
||||
integer :: i, j, xi, ipoint
|
||||
|
||||
! TODO: call lapack
|
||||
|
||||
W1_W1_l_in_r = 0.d0
|
||||
do i = 1, mo_num
|
||||
do j = 1, elec_beta_num
|
||||
do xi = 1, 3
|
||||
do ipoint = 1, n_points_final_grid
|
||||
W1_W1_l_in_r(ipoint,xi,i) += x_W_ki_bi_ortho_erf_rk(ipoint,xi,i,j) * W1_l_in_r(ipoint,xi,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
subroutine direct_term_imj_bi_ortho(a, i, integral)
|
||||
|
||||
BEGIN_DOC
|
||||
! computes sum_(j,m = 1, elec_beta_num) < a m j | i m j > with bi ortho mos
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: i, a
|
||||
double precision, intent(out) :: integral
|
||||
|
||||
integer :: ipoint, xi
|
||||
double precision :: weight, tmp
|
||||
|
||||
integral = 0.d0
|
||||
do xi = 1, 3
|
||||
do ipoint = 1, n_points_final_grid
|
||||
weight = final_weight_at_r_vector(ipoint)
|
||||
!integral += ( mos_l_in_r_array(a,ipoint) * mos_r_in_r_array(i,ipoint) * w_sum_in_r(ipoint,xi) * w_sum_in_r(ipoint,xi) &
|
||||
! + 2.d0 * tc_scf_dm_in_r(ipoint) * w_sum_in_r(ipoint,xi) * x_W_ki_bi_ortho_erf_rk(ipoint,xi,a,i) ) * weight
|
||||
|
||||
tmp = w_sum_in_r(ipoint,xi)
|
||||
|
||||
integral += ( mos_l_in_r_array_transp(ipoint,a) * mos_r_in_r_array_transp(ipoint,i) * tmp * tmp &
|
||||
+ 2.d0 * tc_scf_dm_in_r(ipoint) * tmp * x_W_ki_bi_ortho_erf_rk(ipoint,xi,a,i) &
|
||||
) * weight
|
||||
enddo
|
||||
enddo
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine exch_term_jmi_bi_ortho(a, i, integral)
|
||||
|
||||
BEGIN_DOC
|
||||
! computes sum_(j,m = 1, elec_beta_num) < a m j | j m i > with bi ortho mos
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: i, a
|
||||
double precision, intent(out) :: integral
|
||||
|
||||
integer :: ipoint, xi, j
|
||||
double precision :: weight, tmp
|
||||
|
||||
integral = 0.d0
|
||||
do xi = 1, 3
|
||||
do ipoint = 1, n_points_final_grid
|
||||
weight = final_weight_at_r_vector(ipoint)
|
||||
|
||||
tmp = 0.d0
|
||||
do j = 1, elec_beta_num
|
||||
tmp = tmp + x_W_ki_bi_ortho_erf_rk(ipoint,xi,a,j) * x_W_ki_bi_ortho_erf_rk(ipoint,xi,j,i)
|
||||
enddo
|
||||
|
||||
integral += ( mos_l_in_r_array_transp(ipoint,a) * W1_r_in_r(ipoint,xi,i) * w_sum_in_r(ipoint,xi) &
|
||||
+ tc_scf_dm_in_r(ipoint) * tmp &
|
||||
+ mos_r_in_r_array_transp(ipoint,i) * W1_l_in_r(ipoint,xi,a) * w_sum_in_r(ipoint,xi) &
|
||||
) * weight
|
||||
|
||||
enddo
|
||||
enddo
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine exch_term_ijm_bi_ortho(a, i, integral)
|
||||
|
||||
BEGIN_DOC
|
||||
! computes sum_(j,m = 1, elec_beta_num) < a m j | i j m > with bi ortho mos
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: i, a
|
||||
double precision, intent(out) :: integral
|
||||
|
||||
integer :: ipoint, xi
|
||||
double precision :: weight
|
||||
|
||||
integral = 0.d0
|
||||
do xi = 1, 3
|
||||
do ipoint = 1, n_points_final_grid
|
||||
weight = final_weight_at_r_vector(ipoint)
|
||||
|
||||
integral += ( mos_l_in_r_array_transp(ipoint,a) * mos_r_in_r_array_transp(ipoint,i) * v_sum_in_r(ipoint,xi) &
|
||||
+ 2.d0 * x_W_ki_bi_ortho_erf_rk(ipoint,xi,a,i) * W1_in_r(ipoint,xi) &
|
||||
) * weight
|
||||
|
||||
enddo
|
||||
enddo
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine direct_term_ijj_bi_ortho(a, i, integral)
|
||||
|
||||
BEGIN_DOC
|
||||
! computes sum_(j = 1, elec_beta_num) < a j j | i j j > with bi ortho mos
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: i, a
|
||||
double precision, intent(out) :: integral
|
||||
|
||||
integer :: ipoint, xi
|
||||
double precision :: weight
|
||||
|
||||
integral = 0.d0
|
||||
do xi = 1, 3
|
||||
do ipoint = 1, n_points_final_grid
|
||||
weight = final_weight_at_r_vector(ipoint)
|
||||
|
||||
integral += ( mos_l_in_r_array_transp(ipoint,a) * mos_r_in_r_array_transp(ipoint,i) * ww_sum_in_r(ipoint,xi) &
|
||||
+ 2.d0 * W1_diag_in_r(ipoint, xi) * x_W_ki_bi_ortho_erf_rk(ipoint,xi,a,i) &
|
||||
) * weight
|
||||
enddo
|
||||
enddo
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine cyclic_term_jim_bi_ortho(a, i, integral)
|
||||
|
||||
BEGIN_DOC
|
||||
! computes sum_(j,m = 1, elec_beta_num) < a m j | j i m > with bi ortho mos
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: i, a
|
||||
double precision, intent(out) :: integral
|
||||
|
||||
integer :: ipoint, xi
|
||||
double precision :: weight
|
||||
|
||||
integral = 0.d0
|
||||
do xi = 1, 3
|
||||
do ipoint = 1, n_points_final_grid
|
||||
weight = final_weight_at_r_vector(ipoint)
|
||||
|
||||
integral += ( mos_l_in_r_array_transp(ipoint,a) * W1_W1_r_in_r(ipoint,xi,i) &
|
||||
+ W1_W1_l_in_r(ipoint,xi,a) * mos_r_in_r_array_transp(ipoint,i) &
|
||||
+ W1_l_in_r(ipoint,xi,a) * W1_r_in_r(ipoint,xi,i) &
|
||||
) * weight
|
||||
|
||||
enddo
|
||||
enddo
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine cyclic_term_mji_bi_ortho(a, i, integral)
|
||||
|
||||
BEGIN_DOC
|
||||
! computes sum_(j,m = 1, elec_beta_num) < a m j | m j i > with bi ortho mos
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: i, a
|
||||
double precision, intent(out) :: integral
|
||||
|
||||
integer :: ipoint, xi
|
||||
double precision :: weight
|
||||
|
||||
integral = 0.d0
|
||||
do xi = 1, 3
|
||||
do ipoint = 1, n_points_final_grid
|
||||
weight = final_weight_at_r_vector(ipoint)
|
||||
|
||||
integral += ( mos_l_in_r_array_transp(ipoint,a) * W1_W1_r_in_r(ipoint,xi,i) &
|
||||
+ W1_l_in_r(ipoint,xi,a) * W1_r_in_r(ipoint,xi,i) &
|
||||
+ W1_W1_l_in_r(ipoint,xi,a) * mos_r_in_r_array_transp(ipoint,i) &
|
||||
) * weight
|
||||
|
||||
enddo
|
||||
enddo
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
12
src/tc_scf/minimize_tc_angles.irp.f
Normal file
12
src/tc_scf/minimize_tc_angles.irp.f
Normal file
@ -0,0 +1,12 @@
|
||||
program print_angles
|
||||
implicit none
|
||||
my_grid_becke = .True.
|
||||
my_n_pt_r_grid = 30
|
||||
my_n_pt_a_grid = 50
|
||||
! my_n_pt_r_grid = 10 ! small grid for quick debug
|
||||
! my_n_pt_a_grid = 14 ! small grid for quick debug
|
||||
touch my_n_pt_r_grid my_n_pt_a_grid
|
||||
! call sort_by_tc_fock
|
||||
call minimize_tc_orb_angles
|
||||
end
|
||||
|
||||
176
src/tc_scf/molden_lr_mos.irp.f
Normal file
176
src/tc_scf/molden_lr_mos.irp.f
Normal file
@ -0,0 +1,176 @@
|
||||
program molden
|
||||
BEGIN_DOC
|
||||
! TODO : Put the documentation of the program here
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
print *, 'starting ...'
|
||||
|
||||
my_grid_becke = .True.
|
||||
my_n_pt_r_grid = 30
|
||||
my_n_pt_a_grid = 50
|
||||
! my_n_pt_r_grid = 10 ! small grid for quick debug
|
||||
! my_n_pt_a_grid = 26 ! small grid for quick debug
|
||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||
|
||||
call molden_lr
|
||||
end
|
||||
subroutine molden_lr
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Produces a Molden file
|
||||
END_DOC
|
||||
character*(128) :: output
|
||||
integer :: i_unit_output,getUnitAndOpen
|
||||
integer :: i,j,k,l
|
||||
double precision, parameter :: a0 = 0.529177249d0
|
||||
|
||||
PROVIDE ezfio_filename
|
||||
|
||||
output=trim(ezfio_filename)//'.mol'
|
||||
print*,'output = ',trim(output)
|
||||
|
||||
i_unit_output = getUnitAndOpen(output,'w')
|
||||
|
||||
write(i_unit_output,'(A)') '[Molden Format]'
|
||||
|
||||
write(i_unit_output,'(A)') '[Atoms] Angs'
|
||||
do i = 1, nucl_num
|
||||
write(i_unit_output,'(A2,2X,I4,2X,I4,3(2X,F15.10))') &
|
||||
trim(element_name(int(nucl_charge(i)))), &
|
||||
i, &
|
||||
int(nucl_charge(i)), &
|
||||
nucl_coord(i,1)*a0, nucl_coord(i,2)*a0, nucl_coord(i,3)*a0
|
||||
enddo
|
||||
|
||||
write(i_unit_output,'(A)') '[GTO]'
|
||||
|
||||
character*(1) :: character_shell
|
||||
integer :: i_shell,i_prim,i_ao
|
||||
integer :: iorder(ao_num)
|
||||
integer :: nsort(ao_num)
|
||||
|
||||
i_shell = 0
|
||||
i_prim = 0
|
||||
do i=1,nucl_num
|
||||
write(i_unit_output,*) i, 0
|
||||
do j=1,nucl_num_shell_aos(i)
|
||||
i_shell +=1
|
||||
i_ao = nucl_list_shell_aos(i,j)
|
||||
character_shell = trim(ao_l_char(i_ao))
|
||||
write(i_unit_output,*) character_shell, ao_prim_num(i_ao), '1.00'
|
||||
do k = 1, ao_prim_num(i_ao)
|
||||
i_prim +=1
|
||||
write(i_unit_output,'(E20.10,2X,E20.10)') ao_expo(i_ao,k), ao_coef(i_ao,k)
|
||||
enddo
|
||||
l = i_ao
|
||||
do while ( ao_l(l) == ao_l(i_ao) )
|
||||
nsort(l) = i*10000 + j*100
|
||||
l += 1
|
||||
if (l > ao_num) exit
|
||||
enddo
|
||||
enddo
|
||||
write(i_unit_output,*)''
|
||||
enddo
|
||||
|
||||
|
||||
do i=1,ao_num
|
||||
iorder(i) = i
|
||||
! p
|
||||
if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 0 )) then
|
||||
nsort(i) += 1
|
||||
else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 0 )) then
|
||||
nsort(i) += 2
|
||||
else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 1 )) then
|
||||
nsort(i) += 3
|
||||
! d
|
||||
else if ((ao_power(i,1) == 2 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 0 )) then
|
||||
nsort(i) += 1
|
||||
else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 2 ).and.(ao_power(i,3) == 0 )) then
|
||||
nsort(i) += 2
|
||||
else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 2 )) then
|
||||
nsort(i) += 3
|
||||
else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 0 )) then
|
||||
nsort(i) += 4
|
||||
else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 1 )) then
|
||||
nsort(i) += 5
|
||||
else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 1 )) then
|
||||
nsort(i) += 6
|
||||
! f
|
||||
else if ((ao_power(i,1) == 3 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 0 )) then
|
||||
nsort(i) += 1
|
||||
else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 3 ).and.(ao_power(i,3) == 0 )) then
|
||||
nsort(i) += 2
|
||||
else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 3 )) then
|
||||
nsort(i) += 3
|
||||
else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 2 ).and.(ao_power(i,3) == 0 )) then
|
||||
nsort(i) += 4
|
||||
else if ((ao_power(i,1) == 2 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 0 )) then
|
||||
nsort(i) += 5
|
||||
else if ((ao_power(i,1) == 2 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 1 )) then
|
||||
nsort(i) += 6
|
||||
else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 2 )) then
|
||||
nsort(i) += 7
|
||||
else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 2 )) then
|
||||
nsort(i) += 8
|
||||
else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 2 ).and.(ao_power(i,3) == 1 )) then
|
||||
nsort(i) += 9
|
||||
else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 1 )) then
|
||||
nsort(i) += 10
|
||||
! g
|
||||
else if ((ao_power(i,1) == 4 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 0 )) then
|
||||
nsort(i) += 1
|
||||
else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 4 ).and.(ao_power(i,3) == 0 )) then
|
||||
nsort(i) += 2
|
||||
else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 4 )) then
|
||||
nsort(i) += 3
|
||||
else if ((ao_power(i,1) == 3 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 0 )) then
|
||||
nsort(i) += 4
|
||||
else if ((ao_power(i,1) == 3 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 1 )) then
|
||||
nsort(i) += 5
|
||||
else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 3 ).and.(ao_power(i,3) == 0 )) then
|
||||
nsort(i) += 6
|
||||
else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 3 ).and.(ao_power(i,3) == 1 )) then
|
||||
nsort(i) += 7
|
||||
else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 3 )) then
|
||||
nsort(i) += 8
|
||||
else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 3 )) then
|
||||
nsort(i) += 9
|
||||
else if ((ao_power(i,1) == 2 ).and.(ao_power(i,2) == 2 ).and.(ao_power(i,3) == 0 )) then
|
||||
nsort(i) += 10
|
||||
else if ((ao_power(i,1) == 2 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 2 )) then
|
||||
nsort(i) += 11
|
||||
else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 2 ).and.(ao_power(i,3) == 2 )) then
|
||||
nsort(i) += 12
|
||||
else if ((ao_power(i,1) == 2 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 1 )) then
|
||||
nsort(i) += 13
|
||||
else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 2 ).and.(ao_power(i,3) == 1 )) then
|
||||
nsort(i) += 14
|
||||
else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 2 )) then
|
||||
nsort(i) += 15
|
||||
endif
|
||||
enddo
|
||||
|
||||
call isort(nsort,iorder,ao_num)
|
||||
write(i_unit_output,'(A)') '[MO]'
|
||||
do i=1,mo_num
|
||||
write (i_unit_output,*) 'Sym= 1'
|
||||
write (i_unit_output,*) 'Ene=', Fock_matrix_tc_mo_tot(i,i)
|
||||
write (i_unit_output,*) 'Spin= Alpha'
|
||||
write (i_unit_output,*) 'Occup=', mo_occ(i)
|
||||
do j=1,ao_num
|
||||
write(i_unit_output, '(I6,2X,E20.10)') j, mo_r_coef(iorder(j),i)
|
||||
enddo
|
||||
|
||||
write (i_unit_output,*) 'Sym= 1'
|
||||
write (i_unit_output,*) 'Ene=', Fock_matrix_tc_mo_tot(i,i)
|
||||
write (i_unit_output,*) 'Spin= Alpha'
|
||||
write (i_unit_output,*) 'Occup=', mo_occ(i)
|
||||
do j=1,ao_num
|
||||
write(i_unit_output, '(I6,2X,E20.10)') j, mo_l_coef(iorder(j),i)
|
||||
enddo
|
||||
enddo
|
||||
close(i_unit_output)
|
||||
end
|
||||
|
||||
9
src/tc_scf/print_angle_tc_orb.irp.f
Normal file
9
src/tc_scf/print_angle_tc_orb.irp.f
Normal file
@ -0,0 +1,9 @@
|
||||
program print_angles
|
||||
implicit none
|
||||
my_grid_becke = .True.
|
||||
! my_n_pt_r_grid = 30
|
||||
! my_n_pt_a_grid = 50
|
||||
my_n_pt_r_grid = 10 ! small grid for quick debug
|
||||
my_n_pt_a_grid = 14 ! small grid for quick debug
|
||||
call print_angles_tc
|
||||
end
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user