LCPQ/qp2
9
1
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-12-22 03:23:29 +01:00
Code Releases Activity

Merge pull request #313 from AbdAmmar/dev-stable
Some checks failed
continuous-integration/drone/push Build is failing
Details

Browse Source 
Dev stable
This commit is contained in:
Anthony Scemama 2024-01-23 13:41:58 +01:00 committed by GitHub
commit ec5b391731
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
74 changed files with 6074 additions and 5250 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
plugins/local/ao_many_one_e_ints/NEED
View File

@ -4,3 +4,4 @@ becke_numerical_grid
mo_one_e_ints mo_one_e_ints
dft_utils_in_r dft_utils_in_r
tc_keywords tc_keywords
hamiltonian

38
plugins/local/ao_many_one_e_ints/ao_erf_gauss.irp.f
View File

@ -98,7 +98,7 @@ double precision function phi_j_erf_mu_r_phi(i, j, mu_in, C_center)
enddo enddo
enddo enddo
end function phi_j_erf_mu_r_phi end
! --- ! ---
@ -201,7 +201,7 @@ subroutine erf_mu_gauss_ij_ao(i, j, mu, C_center, delta, gauss_ints)
enddo enddo
enddo enddo
end subroutine erf_mu_gauss_ij_ao end
! --- ! ---
@ -266,7 +266,7 @@ subroutine NAI_pol_x_mult_erf_ao(i_ao, j_ao, mu_in, C_center, ints)
enddo enddo
enddo enddo
end subroutine NAI_pol_x_mult_erf_ao end
! --- ! ---
@ -340,7 +340,7 @@ subroutine NAI_pol_x_mult_erf_ao_v0(i_ao, j_ao, mu_in, C_center, LD_C, ints, LD_
deallocate(integral) deallocate(integral)
end subroutine NAI_pol_x_mult_erf_ao_v0 end
! --- ! ---
@ -420,7 +420,7 @@ subroutine NAI_pol_x_mult_erf_ao_v(i_ao, j_ao, mu_in, C_center, LD_C, ints, LD_i
deallocate(integral) deallocate(integral)
end subroutine NAI_pol_x_mult_erf_ao_v end
! --- ! ---
@ -479,7 +479,7 @@ double precision function NAI_pol_x_mult_erf_ao_x(i_ao, j_ao, mu_in, C_center)
enddo enddo
enddo enddo
end function NAI_pol_x_mult_erf_ao_x end
! --- ! ---
@ -538,7 +538,7 @@ double precision function NAI_pol_x_mult_erf_ao_y(i_ao, j_ao, mu_in, C_center)
enddo enddo
enddo enddo
end function NAI_pol_x_mult_erf_ao_y end
! --- ! ---
@ -597,7 +597,7 @@ double precision function NAI_pol_x_mult_erf_ao_z(i_ao, j_ao, mu_in, C_center)
enddo enddo
enddo enddo
end function NAI_pol_x_mult_erf_ao_z end
! --- ! ---
@ -667,7 +667,7 @@ double precision function NAI_pol_x_mult_erf_ao_with1s_x(i_ao, j_ao, beta, B_cen
enddo enddo
enddo enddo
end function NAI_pol_x_mult_erf_ao_with1s_x end
! --- ! ---
@ -737,7 +737,7 @@ double precision function NAI_pol_x_mult_erf_ao_with1s_y(i_ao, j_ao, beta, B_cen
enddo enddo
enddo enddo
end function NAI_pol_x_mult_erf_ao_with1s_y end
! --- ! ---
@ -807,7 +807,7 @@ double precision function NAI_pol_x_mult_erf_ao_with1s_z(i_ao, j_ao, beta, B_cen
enddo enddo
enddo enddo
end function NAI_pol_x_mult_erf_ao_with1s_z end
! --- ! ---
@ -880,7 +880,7 @@ subroutine NAI_pol_x_mult_erf_ao_with1s(i_ao, j_ao, beta, B_center, mu_in, C_cen
enddo enddo
enddo enddo
end subroutine NAI_pol_x_mult_erf_ao_with1s end
! --- ! ---
@ -967,7 +967,7 @@ subroutine NAI_pol_x_mult_erf_ao_with1s_v0(i_ao, j_ao, beta, B_center, LD_B, mu_
deallocate(integral) deallocate(integral)
end subroutine NAI_pol_x_mult_erf_ao_with1s_v0 end
! --- ! ---
@ -1057,7 +1057,7 @@ subroutine NAI_pol_x_mult_erf_ao_with1s_v(i_ao, j_ao, beta, B_center, LD_B, mu_i
deallocate(integral) deallocate(integral)
end subroutine NAI_pol_x_mult_erf_ao_with1s_v end
! --- ! ---
@ -1175,7 +1175,7 @@ subroutine NAI_pol_x2_mult_erf_ao_with1s(i_ao, j_ao, beta, B_center, mu_in, C_ce
enddo enddo
enddo enddo
end subroutine NAI_pol_x2_mult_erf_ao_with1s end
! --- ! ---
@ -1241,7 +1241,7 @@ subroutine NAI_pol_x2_mult_erf_ao(i_ao, j_ao, mu_in, C_center, ints)
enddo enddo
enddo enddo
end subroutine NAI_pol_x2_mult_erf_ao end
! --- ! ---
@ -1320,7 +1320,7 @@ subroutine NAI_pol_012_mult_erf_ao_with1s(i_ao, j_ao, beta, B_center, mu_in, C_c
enddo enddo
enddo enddo
end subroutine NAI_pol_012_mult_erf_ao_with1s end
! --- ! ---
@ -1328,7 +1328,7 @@ subroutine NAI_pol_012_mult_erf_ao(i_ao, j_ao, mu_in, C_center, ints)
BEGIN_DOC BEGIN_DOC
! !
! Computes the following integral : ! Computes the following integrals :
! !
! int(1) = $\int_{-\infty}^{infty} dr x^0 * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$. ! int(1) = $\int_{-\infty}^{infty} dr x^0 * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
! !
@ -1395,7 +1395,7 @@ subroutine NAI_pol_012_mult_erf_ao(i_ao, j_ao, mu_in, C_center, ints)
enddo enddo
enddo enddo
end subroutine NAI_pol_012_mult_erf_ao end
! --- ! ---

89
plugins/local/ao_many_one_e_ints/ao_gaus_gauss.irp.f
View File

@ -152,7 +152,7 @@ double precision function overlap_gauss_r12_ao(D_center, delta, i, j)
enddo enddo
enddo enddo
end function overlap_gauss_r12_ao end
! -- ! --
@ -199,7 +199,7 @@ double precision function overlap_abs_gauss_r12_ao(D_center, delta, i, j)
enddo enddo
enddo enddo
end function overlap_gauss_r12_ao end
! -- ! --
@ -257,7 +257,7 @@ subroutine overlap_gauss_r12_ao_v(D_center, LD_D, delta, i, j, resv, LD_resv, n_
deallocate(analytical_j) deallocate(analytical_j)
end subroutine overlap_gauss_r12_ao_v end
! --- ! ---
@ -327,7 +327,7 @@ double precision function overlap_gauss_r12_ao_with1s(B_center, beta, D_center,
enddo enddo
enddo enddo
end function overlap_gauss_r12_ao_with1s end
! --- ! ---
@ -420,7 +420,86 @@ subroutine overlap_gauss_r12_ao_with1s_v(B_center, beta, D_center, LD_D, delta,
deallocate(fact_g, G_center, analytical_j) deallocate(fact_g, G_center, analytical_j)
end subroutine overlap_gauss_r12_ao_with1s_v end
! ---
subroutine overlap_gauss_r12_ao_012(D_center, delta, i, j, ints)
BEGIN_DOC
!
! Computes the following integrals :
!
! ints(1) = $\int_{-\infty}^{infty} dr x^0 * \chi_i(r) \chi_j(r) e^{-\delta (r - D_center)^2}
!
! ints(2) = $\int_{-\infty}^{infty} dr x^1 * \chi_i(r) \chi_j(r) e^{-\delta (r - D_center)^2}
! ints(3) = $\int_{-\infty}^{infty} dr y^1 * \chi_i(r) \chi_j(r) e^{-\delta (r - D_center)^2}
! ints(4) = $\int_{-\infty}^{infty} dr z^1 * \chi_i(r) \chi_j(r) e^{-\delta (r - D_center)^2}
!
! ints(5) = $\int_{-\infty}^{infty} dr x^2 * \chi_i(r) \chi_j(r) e^{-\delta (r - D_center)^2}
! ints(6) = $\int_{-\infty}^{infty} dr y^2 * \chi_i(r) \chi_j(r) e^{-\delta (r - D_center)^2}
! ints(7) = $\int_{-\infty}^{infty} dr z^2 * \chi_i(r) \chi_j(r) e^{-\delta (r - D_center)^2}
!
END_DOC
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: i, j
double precision, intent(in) :: delta, D_center(3)
double precision, intent(out) :: ints(7)
integer :: k, l, m
integer :: power_A(3), power_B(3), power_A1(3), power_A2(3)
double precision :: A_center(3), B_center(3), alpha, beta, coef1, coef
double precision :: integral0, integral1, integral2
double precision, external :: overlap_gauss_r12
ints = 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
integral0 = overlap_gauss_r12(D_center, delta, A_center, B_center, power_A, power_B, alpha, beta)
ints(1) += coef * integral0
do m = 1, 3
power_A1 = power_A
power_A1(m) += 1
integral1 = overlap_gauss_r12(D_center, delta, A_center, B_center, power_A1, power_B, alpha, beta)
ints(1+m) += coef * (integral1 + A_center(m)*integral0)
power_A2 = power_A
power_A2(m) += 2
integral2 = overlap_gauss_r12(D_center, delta, A_center, B_center, power_A2, power_B, alpha, beta)
ints(4+m) += coef * (integral2 + A_center(m) * (2.d0*integral1 + A_center(m)*integral0))
enddo
enddo ! k
enddo ! l
return
end
! --- ! ---

198
plugins/local/ao_many_one_e_ints/grad2_jmu_manu.irp.f
View File

@ -1,11 +1,11 @@
! --- ! ---
BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2_test, (ao_num, ao_num, n_points_final_grid)] BEGIN_PROVIDER [double precision, int2_grad1u2_grad2u2_env2_test, (ao_num, ao_num, n_points_final_grid)]
BEGIN_DOC BEGIN_DOC
! !
! -\frac{1}{4} x int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 [1 - erf(mu r12)]^2 ! -\frac{1}{4} x int dr2 phi_i(r2) phi_j(r2) 1s_env(r2)^2 [1 - erf(mu r12)]^2
! !
END_DOC END_DOC
@ -15,30 +15,30 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2_test, (ao_num, ao_n
double precision :: coef, beta, B_center(3) double precision :: coef, beta, B_center(3)
double precision :: tmp double precision :: tmp
double precision :: wall0, wall1 double precision :: wall0, wall1
double precision :: int_gauss, dsqpi_3_2, int_j1b double precision :: int_gauss, dsqpi_3_2, int_env
double precision :: factor_ij_1s, beta_ij, center_ij_1s(3), sq_pi_3_2 double precision :: factor_ij_1s, beta_ij, center_ij_1s(3), sq_pi_3_2
double precision, allocatable :: int_fit_v(:) double precision, allocatable :: int_fit_v(:)
double precision, external :: overlap_gauss_r12_ao double precision, external :: overlap_gauss_r12_ao
double precision, external :: overlap_gauss_r12_ao_with1s double precision, external :: overlap_gauss_r12_ao_with1s
print*, ' providing int2_grad1u2_grad2u2_j1b2_test ...' print*, ' providing int2_grad1u2_grad2u2_env2_test ...'
sq_pi_3_2 = (dacos(-1.d0))**(1.5d0) sq_pi_3_2 = (dacos(-1.d0))**(1.5d0)
provide mu_erf final_grid_points_transp j1b_pen List_comb_thr_b3_coef provide mu_erf final_grid_points_transp List_comb_thr_b3_coef
call wall_time(wall0) call wall_time(wall0)
int2_grad1u2_grad2u2_j1b2_test(:,:,:) = 0.d0 int2_grad1u2_grad2u2_env2_test(:,:,:) = 0.d0
!$OMP PARALLEL DEFAULT (NONE) & !$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, & !$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 coef_fit, expo_fit, int_fit_v, tmp,int_gauss,int_env,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 SHARED (n_points_final_grid, ao_num, final_grid_points,List_comb_thr_b3_size, &
!$OMP final_grid_points_transp, ng_fit_jast, & !$OMP final_grid_points_transp, ng_fit_jast, &
!$OMP expo_gauss_1_erf_x_2, coef_gauss_1_erf_x_2, & !$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_coef, List_comb_thr_b3_expo, &
!$OMP List_comb_thr_b3_cent, int2_grad1u2_grad2u2_j1b2_test, ao_abs_comb_b3_j1b, & !$OMP List_comb_thr_b3_cent, int2_grad1u2_grad2u2_env2_test, ao_abs_comb_b3_env, &
!$OMP ao_overlap_abs,sq_pi_3_2,thrsh_cycle_tc) !$OMP ao_overlap_abs,sq_pi_3_2,thrsh_cycle_tc)
!$OMP DO SCHEDULE(dynamic) !$OMP DO SCHEDULE(dynamic)
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
r(1) = final_grid_points(1,ipoint) r(1) = final_grid_points(1,ipoint)
@ -54,13 +54,13 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2_test, (ao_num, ao_n
! i_1s = 1 ! i_1s = 1
! --- --- --- ! --- --- ---
int_j1b = ao_abs_comb_b3_j1b(1,j,i) int_env = ao_abs_comb_b3_env(1,j,i)
do i_fit = 1, ng_fit_jast do i_fit = 1, ng_fit_jast
expo_fit = expo_gauss_1_erf_x_2(i_fit) expo_fit = expo_gauss_1_erf_x_2(i_fit)
coef_fit = -0.25d0 * coef_gauss_1_erf_x_2(i_fit) coef_fit = -0.25d0 * coef_gauss_1_erf_x_2(i_fit)
! if(dabs(coef_fit*int_j1b*sq_pi_3_2*(expo_fit)**(-1.5d0)).lt.thrsh_cycle_tc)cycle ! if(dabs(coef_fit*int_env*sq_pi_3_2*(expo_fit)**(-1.5d0)).lt.thrsh_cycle_tc)cycle
int_gauss = overlap_gauss_r12_ao(r, expo_fit, i, j) int_gauss = overlap_gauss_r12_ao(r, expo_fit, i, j)
int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint) += coef_fit * int_gauss int2_grad1u2_grad2u2_env2_test(j,i,ipoint) += coef_fit * int_gauss
enddo enddo
! --- --- --- ! --- --- ---
@ -71,7 +71,7 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2_test, (ao_num, ao_n
coef = List_comb_thr_b3_coef (i_1s,j,i) coef = List_comb_thr_b3_coef (i_1s,j,i)
beta = List_comb_thr_b3_expo (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) int_env = ao_abs_comb_b3_env(i_1s,j,i)
B_center(1) = List_comb_thr_b3_cent(1,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(2) = List_comb_thr_b3_cent(2,i_1s,j,i)
B_center(3) = List_comb_thr_b3_cent(3,i_1s,j,i) B_center(3) = List_comb_thr_b3_cent(3,i_1s,j,i)
@ -81,11 +81,11 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2_test, (ao_num, ao_n
!DIR$ FORCEINLINE !DIR$ FORCEINLINE
call gaussian_product(expo_fit,r,beta,B_center,factor_ij_1s,beta_ij,center_ij_1s) 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 coef_fit = -0.25d0 * coef_gauss_1_erf_x_2(i_fit) * coef
! if(dabs(coef_fit*factor_ij_1s*int_j1b*sq_pi_3_2*(beta_ij)**(-1.5d0)).lt.thrsh_cycle_tc)cycle ! if(dabs(coef_fit*factor_ij_1s*int_env*sq_pi_3_2*(beta_ij)**(-1.5d0)).lt.thrsh_cycle_tc)cycle
! call overlap_gauss_r12_ao_with1s_v(B_center, beta, final_grid_points_transp, & ! 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) ! 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) 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 int2_grad1u2_grad2u2_env2_test(j,i,ipoint) += coef_fit * int_gauss
enddo enddo
enddo enddo
@ -98,26 +98,26 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2_test, (ao_num, ao_n
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do i = 1, ao_num do i = 1, ao_num
do j = 1, i-1 do j = 1, i-1
int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint) = int2_grad1u2_grad2u2_j1b2_test(i,j,ipoint) int2_grad1u2_grad2u2_env2_test(j,i,ipoint) = int2_grad1u2_grad2u2_env2_test(i,j,ipoint)
enddo enddo
enddo enddo
enddo enddo
call wall_time(wall1) call wall_time(wall1)
print*, ' wall time for int2_grad1u2_grad2u2_j1b2_test', wall1 - wall0 print*, ' wall time for int2_grad1u2_grad2u2_env2_test (min) = ', (wall1 - wall0) / 60.d0
END_PROVIDER END_PROVIDER
! --- ! ---
BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2_test_v, (ao_num, ao_num, n_points_final_grid)] BEGIN_PROVIDER [double precision, int2_grad1u2_grad2u2_env2_test_v, (ao_num, ao_num, n_points_final_grid)]
!
! BEGIN_DOC BEGIN_DOC
! ! !
! ! -\frac{1}{4} x int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 [1 - erf(mu r12)]^2 ! -\frac{1}{4} x int dr2 phi_i(r2) phi_j(r2) 1s_env(r2)^2 [1 - erf(mu r12)]^2
! ! !
! END_DOC END_DOC
!
implicit none implicit none
integer :: i, j, ipoint, i_1s, i_fit integer :: i, j, ipoint, i_1s, i_fit
double precision :: r(3), expo_fit, coef_fit double precision :: r(3), expo_fit, coef_fit
@ -128,24 +128,24 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2_test_v, (ao_num, ao
double precision, allocatable :: int_fit_v(:),big_array(:,:,:) double precision, allocatable :: int_fit_v(:),big_array(:,:,:)
double precision, external :: overlap_gauss_r12_ao_with1s double precision, external :: overlap_gauss_r12_ao_with1s
print*, ' providing int2_grad1u2_grad2u2_j1b2_test_v ...' print*, ' providing int2_grad1u2_grad2u2_env2_test_v ...'
provide mu_erf final_grid_points_transp j1b_pen provide mu_erf final_grid_points_transp
call wall_time(wall0) call wall_time(wall0)
double precision :: int_j1b double precision :: int_env
big_array(:,:,:) = 0.d0 big_array(:,:,:) = 0.d0
allocate(big_array(n_points_final_grid,ao_num, ao_num)) allocate(big_array(n_points_final_grid,ao_num, ao_num))
!$OMP PARALLEL DEFAULT (NONE) & !$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center,& !$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 coef_fit, expo_fit, int_fit_v, tmp,int_env) &
!$OMP SHARED (n_points_final_grid, ao_num, List_comb_thr_b3_size,& !$OMP SHARED (n_points_final_grid, ao_num, List_comb_thr_b3_size,&
!$OMP final_grid_points_transp, ng_fit_jast, & !$OMP final_grid_points_transp, ng_fit_jast, &
!$OMP expo_gauss_1_erf_x_2, coef_gauss_1_erf_x_2, & !$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_coef, List_comb_thr_b3_expo, &
!$OMP List_comb_thr_b3_cent, big_array,& !$OMP List_comb_thr_b3_cent, big_array,&
!$OMP ao_abs_comb_b3_j1b,ao_overlap_abs,thrsh_cycle_tc) !$OMP ao_abs_comb_b3_env,ao_overlap_abs,thrsh_cycle_tc)
! !
allocate(int_fit_v(n_points_final_grid)) allocate(int_fit_v(n_points_final_grid))
!$OMP DO SCHEDULE(dynamic) !$OMP DO SCHEDULE(dynamic)
do i = 1, ao_num do i = 1, ao_num
@ -159,7 +159,7 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2_test_v, (ao_num, ao
coef = List_comb_thr_b3_coef (i_1s,j,i) coef = List_comb_thr_b3_coef (i_1s,j,i)
beta = List_comb_thr_b3_expo (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) int_env = ao_abs_comb_b3_env(i_1s,j,i)
B_center(1) = List_comb_thr_b3_cent(1,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(2) = List_comb_thr_b3_cent(2,i_1s,j,i)
B_center(3) = List_comb_thr_b3_cent(3,i_1s,j,i) B_center(3) = List_comb_thr_b3_cent(3,i_1s,j,i)
@ -187,7 +187,7 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2_test_v, (ao_num, ao
do i = 1, ao_num do i = 1, ao_num
do j = i, ao_num do j = i, ao_num
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
int2_grad1u2_grad2u2_j1b2_test_v(j,i,ipoint) = big_array(ipoint,j,i) int2_grad1u2_grad2u2_env2_test_v(j,i,ipoint) = big_array(ipoint,j,i)
enddo enddo
enddo enddo
enddo enddo
@ -195,23 +195,23 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2_test_v, (ao_num, ao
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do i = 2, ao_num do i = 2, ao_num
do j = 1, i-1 do j = 1, i-1
int2_grad1u2_grad2u2_j1b2_test_v(j,i,ipoint) = big_array(ipoint,i,j) int2_grad1u2_grad2u2_env2_test_v(j,i,ipoint) = big_array(ipoint,i,j)
enddo enddo
enddo enddo
enddo enddo
call wall_time(wall1) call wall_time(wall1)
print*, ' wall time for int2_grad1u2_grad2u2_j1b2_test_v', wall1 - wall0 print*, ' wall time for int2_grad1u2_grad2u2_env2_test_v (min) = ', (wall1 - wall0) / 60.d0
END_PROVIDER END_PROVIDER
! --- ! ---
BEGIN_PROVIDER [ double precision, int2_u2_j1b2_test, (ao_num, ao_num, n_points_final_grid)] BEGIN_PROVIDER [double precision, int2_u2_env2_test, (ao_num, ao_num, n_points_final_grid)]
BEGIN_DOC BEGIN_DOC
! !
! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 [u_12^mu]^2 ! int dr2 phi_i(r2) phi_j(r2) 1s_env(r2)^2 [u_12^mu]^2
! !
END_DOC END_DOC
@ -219,29 +219,29 @@ BEGIN_PROVIDER [ double precision, int2_u2_j1b2_test, (ao_num, ao_num, n_points_
integer :: i, j, ipoint, i_1s, i_fit integer :: i, j, ipoint, i_1s, i_fit
double precision :: r(3), int_fit, expo_fit, coef_fit double precision :: r(3), int_fit, expo_fit, coef_fit
double precision :: coef, beta, B_center(3), tmp double precision :: coef, beta, B_center(3), tmp
double precision :: wall0, wall1,int_j1b double precision :: wall0, wall1,int_env
double precision, external :: overlap_gauss_r12_ao double precision, external :: overlap_gauss_r12_ao
double precision, external :: overlap_gauss_r12_ao_with1s double precision, external :: overlap_gauss_r12_ao_with1s
double precision :: factor_ij_1s,beta_ij,center_ij_1s(3),sq_pi_3_2 double precision :: factor_ij_1s,beta_ij,center_ij_1s(3),sq_pi_3_2
print*, ' providing int2_u2_j1b2_test ...' print*, ' providing int2_u2_env2_test ...'
sq_pi_3_2 = (dacos(-1.d0))**(1.5d0) sq_pi_3_2 = (dacos(-1.d0))**(1.5d0)
provide mu_erf final_grid_points j1b_pen provide mu_erf final_grid_points
call wall_time(wall0) call wall_time(wall0)
int2_u2_j1b2_test = 0.d0 int2_u2_env2_test = 0.d0
!$OMP PARALLEL DEFAULT (NONE) & !$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, & !$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 coef_fit, expo_fit, int_fit, tmp, int_env,factor_ij_1s,beta_ij,center_ij_1s) &
!$OMP SHARED (n_points_final_grid, ao_num, List_comb_thr_b3_size, & !$OMP SHARED (n_points_final_grid, ao_num, List_comb_thr_b3_size, &
!$OMP final_grid_points, ng_fit_jast, & !$OMP final_grid_points, ng_fit_jast, &
!$OMP expo_gauss_j_mu_x_2, coef_gauss_j_mu_x_2, & !$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_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,thrsh_cycle_tc) !$OMP List_comb_thr_b3_cent, int2_u2_env2_test,ao_abs_comb_b3_env,thrsh_cycle_tc)
!$OMP DO !$OMP DO
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
r(1) = final_grid_points(1,ipoint) r(1) = final_grid_points(1,ipoint)
@ -257,12 +257,12 @@ BEGIN_PROVIDER [ double precision, int2_u2_j1b2_test, (ao_num, ao_num, n_points_
! i_1s = 1 ! i_1s = 1
! --- --- --- ! --- --- ---
int_j1b = ao_abs_comb_b3_j1b(1,j,i) int_env = ao_abs_comb_b3_env(1,j,i)
if(dabs(int_j1b).lt.thrsh_cycle_tc) cycle if(dabs(int_env).lt.thrsh_cycle_tc) cycle
do i_fit = 1, ng_fit_jast do i_fit = 1, ng_fit_jast
expo_fit = expo_gauss_j_mu_x_2(i_fit) expo_fit = expo_gauss_j_mu_x_2(i_fit)
coef_fit = coef_gauss_j_mu_x_2(i_fit) coef_fit = coef_gauss_j_mu_x_2(i_fit)
! if(dabs(coef_fit*int_j1b*sq_pi_3_2*(expo_fit)**(-1.5d0)).lt.thrsh_cycle_tc)cycle ! if(dabs(coef_fit*int_env*sq_pi_3_2*(expo_fit)**(-1.5d0)).lt.thrsh_cycle_tc)cycle
int_fit = overlap_gauss_r12_ao(r, expo_fit, i, j) int_fit = overlap_gauss_r12_ao(r, expo_fit, i, j)
tmp += coef_fit * int_fit tmp += coef_fit * int_fit
enddo enddo
@ -275,8 +275,8 @@ BEGIN_PROVIDER [ double precision, int2_u2_j1b2_test, (ao_num, ao_num, n_points_
coef = List_comb_thr_b3_coef (i_1s,j,i) coef = List_comb_thr_b3_coef (i_1s,j,i)
beta = List_comb_thr_b3_expo (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) int_env = ao_abs_comb_b3_env(i_1s,j,i)
! if(dabs(coef)*dabs(int_j1b).lt.thrsh_cycle_tc)cycle ! if(dabs(coef)*dabs(int_env).lt.thrsh_cycle_tc)cycle
B_center(1) = List_comb_thr_b3_cent(1,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(2) = List_comb_thr_b3_cent(2,i_1s,j,i)
B_center(3) = List_comb_thr_b3_cent(3,i_1s,j,i) B_center(3) = List_comb_thr_b3_cent(3,i_1s,j,i)
@ -286,13 +286,13 @@ BEGIN_PROVIDER [ double precision, int2_u2_j1b2_test, (ao_num, ao_num, n_points_
coef_fit = coef_gauss_j_mu_x_2(i_fit) coef_fit = coef_gauss_j_mu_x_2(i_fit)
!DIR$ FORCEINLINE !DIR$ FORCEINLINE
call gaussian_product(expo_fit,r,beta,B_center,factor_ij_1s,beta_ij,center_ij_1s) 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*sq_pi_3_2*(beta_ij)**(-1.5d0)).lt.thrsh_cycle_tc)cycle ! if(dabs(coef_fit*coef*factor_ij_1s*int_env*sq_pi_3_2*(beta_ij)**(-1.5d0)).lt.thrsh_cycle_tc)cycle
int_fit = overlap_gauss_r12_ao_with1s(B_center, beta, r, expo_fit, i, j) int_fit = overlap_gauss_r12_ao_with1s(B_center, beta, r, expo_fit, i, j)
tmp += coef * coef_fit * int_fit tmp += coef * coef_fit * int_fit
enddo enddo
enddo enddo
int2_u2_j1b2_test(j,i,ipoint) = tmp int2_u2_env2_test(j,i,ipoint) = tmp
enddo enddo
enddo enddo
enddo enddo
@ -302,23 +302,23 @@ BEGIN_PROVIDER [ double precision, int2_u2_j1b2_test, (ao_num, ao_num, n_points_
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do i = 2, ao_num do i = 2, ao_num
do j = 1, i-1 do j = 1, i-1
int2_u2_j1b2_test(j,i,ipoint) = int2_u2_j1b2_test(i,j,ipoint) int2_u2_env2_test(j,i,ipoint) = int2_u2_env2_test(i,j,ipoint)
enddo enddo
enddo enddo
enddo enddo
call wall_time(wall1) call wall_time(wall1)
print*, ' wall time for int2_u2_j1b2_test', wall1 - wall0 print*, ' wall time for int2_u2_env2_test (min) = ', (wall1 - wall0) / 60.d0
END_PROVIDER END_PROVIDER
! --- ! ---
BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2_test, (ao_num, ao_num, n_points_final_grid, 3)] BEGIN_PROVIDER [double precision, int2_u_grad1u_x_env2_test, (ao_num,ao_num,n_points_final_grid,3)]
BEGIN_DOC BEGIN_DOC
! !
! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 u_12^mu [\grad_1 u_12^mu] r2 ! int dr2 phi_i(r2) phi_j(r2) 1s_env(r2)^2 u_12^mu [\grad_1 u_12^mu] r2
! !
END_DOC END_DOC
@ -327,27 +327,27 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2_test, (ao_num, ao_num, n
double precision :: r(3), int_fit(3), expo_fit, coef_fit double precision :: r(3), int_fit(3), expo_fit, coef_fit
double precision :: coef, beta, B_center(3), dist 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 :: 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 :: tmp_x, tmp_y, tmp_z, int_env
double precision :: wall0, wall1, sq_pi_3_2,sq_alpha double precision :: wall0, wall1, sq_pi_3_2,sq_alpha
print*, ' providing int2_u_grad1u_x_j1b2_test ...' print*, ' providing int2_u_grad1u_x_env2_test ...'
sq_pi_3_2 = dacos(-1.D0)**(1.d0) sq_pi_3_2 = dacos(-1.D0)**(1.d0)
provide mu_erf final_grid_points j1b_pen provide mu_erf final_grid_points
call wall_time(wall0) call wall_time(wall0)
int2_u_grad1u_x_j1b2_test = 0.d0 int2_u_grad1u_x_env2_test = 0.d0
!$OMP PARALLEL DEFAULT (NONE) & !$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, & !$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 coef_fit, expo_fit, int_fit, alpha_1s, dist, &
!$OMP alpha_1s_inv, centr_1s, expo_coef_1s, coef_tmp, & !$OMP alpha_1s_inv, centr_1s, expo_coef_1s, coef_tmp, &
!$OMP tmp_x, tmp_y, tmp_z,int_j1b,sq_alpha) & !$OMP tmp_x, tmp_y, tmp_z,int_env,sq_alpha) &
!$OMP SHARED (n_points_final_grid, ao_num, List_comb_thr_b3_size, & !$OMP SHARED (n_points_final_grid, ao_num, List_comb_thr_b3_size, &
!$OMP final_grid_points, ng_fit_jast, & !$OMP final_grid_points, ng_fit_jast, &
!$OMP expo_gauss_j_mu_1_erf, coef_gauss_j_mu_1_erf, & !$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_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,thrsh_cycle_tc) !$OMP List_comb_thr_b3_cent, int2_u_grad1u_x_env2_test,ao_abs_comb_b3_env,sq_pi_3_2,thrsh_cycle_tc)
!$OMP DO !$OMP DO
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
@ -365,8 +365,8 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2_test, (ao_num, ao_num, n
coef = List_comb_thr_b3_coef (i_1s,j,i) coef = List_comb_thr_b3_coef (i_1s,j,i)
beta = List_comb_thr_b3_expo (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) int_env = ao_abs_comb_b3_env(i_1s,j,i)
if(dabs(coef)*dabs(int_j1b).lt.thrsh_cycle_tc)cycle if(dabs(coef)*dabs(int_env).lt.thrsh_cycle_tc)cycle
B_center(1) = List_comb_thr_b3_cent(1,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(2) = List_comb_thr_b3_cent(2,i_1s,j,i)
B_center(3) = List_comb_thr_b3_cent(3,i_1s,j,i) B_center(3) = List_comb_thr_b3_cent(3,i_1s,j,i)
@ -389,7 +389,7 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2_test, (ao_num, ao_num, n
expo_coef_1s = beta * expo_fit * alpha_1s_inv * dist expo_coef_1s = beta * expo_fit * alpha_1s_inv * dist
coef_tmp = coef * coef_fit * dexp(-expo_coef_1s) coef_tmp = coef * coef_fit * dexp(-expo_coef_1s)
sq_alpha = alpha_1s_inv * dsqrt(alpha_1s_inv) sq_alpha = alpha_1s_inv * dsqrt(alpha_1s_inv)
! if(dabs(coef_tmp*int_j1b*sq_pi_3_2*sq_alpha) .lt. thrsh_cycle_tc) cycle ! if(dabs(coef_tmp*int_env*sq_pi_3_2*sq_alpha) .lt. thrsh_cycle_tc) cycle
call NAI_pol_x_mult_erf_ao_with1s(i, j, alpha_1s, centr_1s, 1.d+9, r, int_fit) call NAI_pol_x_mult_erf_ao_with1s(i, j, alpha_1s, centr_1s, 1.d+9, r, int_fit)
@ -402,9 +402,9 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2_test, (ao_num, ao_num, n
enddo enddo
int2_u_grad1u_x_j1b2_test(j,i,ipoint,1) = tmp_x int2_u_grad1u_x_env2_test(j,i,ipoint,1) = tmp_x
int2_u_grad1u_x_j1b2_test(j,i,ipoint,2) = tmp_y int2_u_grad1u_x_env2_test(j,i,ipoint,2) = tmp_y
int2_u_grad1u_x_j1b2_test(j,i,ipoint,3) = tmp_z int2_u_grad1u_x_env2_test(j,i,ipoint,3) = tmp_z
enddo enddo
enddo enddo
enddo enddo
@ -414,24 +414,25 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2_test, (ao_num, ao_num, n
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do i = 2, ao_num do i = 2, ao_num
do j = 1, i-1 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_env2_test(j,i,ipoint,1) = int2_u_grad1u_x_env2_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_env2_test(j,i,ipoint,2) = int2_u_grad1u_x_env2_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) int2_u_grad1u_x_env2_test(j,i,ipoint,3) = int2_u_grad1u_x_env2_test(i,j,ipoint,3)
enddo enddo
enddo enddo
enddo enddo
call wall_time(wall1) call wall_time(wall1)
print*, ' wall time for int2_u_grad1u_x_j1b2_test', wall1 - wall0 print*, ' wall time for int2_u_grad1u_x_env2_test (min) = ', (wall1 - wall0) / 60.d0
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, int2_u_grad1u_j1b2_test, (ao_num, ao_num, n_points_final_grid)] BEGIN_PROVIDER [double precision, int2_u_grad1u_env2_test, (ao_num, ao_num, n_points_final_grid)]
BEGIN_DOC BEGIN_DOC
! !
! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 u_12^mu [\grad_1 u_12^mu] ! int dr2 phi_i(r2) phi_j(r2) 1s_env(r2)^2 u_12^mu [\grad_1 u_12^mu]
! !
END_DOC END_DOC
@ -442,31 +443,31 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_j1b2_test, (ao_num, ao_num, n_p
double precision :: alpha_1s, alpha_1s_inv, centr_1s(3), expo_coef_1s, tmp double precision :: alpha_1s, alpha_1s_inv, centr_1s(3), expo_coef_1s, tmp
double precision :: wall0, wall1 double precision :: wall0, wall1
double precision, external :: NAI_pol_mult_erf_ao_with1s double precision, external :: NAI_pol_mult_erf_ao_with1s
double precision :: j12_mu_r12,int_j1b double precision :: j12_mu_r12,int_env
double precision :: sigma_ij,dist_ij_ipoint,dsqpi_3_2 double precision :: sigma_ij,dist_ij_ipoint,dsqpi_3_2
double precision :: beta_ij,center_ij_1s(3),factor_ij_1s double precision :: beta_ij,center_ij_1s(3),factor_ij_1s
print*, ' providing int2_u_grad1u_j1b2_test ...' print*, ' providing int2_u_grad1u_env2_test ...'
dsqpi_3_2 = (dacos(-1.d0))**(1.5d0) dsqpi_3_2 = (dacos(-1.d0))**(1.5d0)
provide mu_erf final_grid_points j1b_pen ao_overlap_abs List_comb_thr_b3_cent provide mu_erf final_grid_points ao_overlap_abs List_comb_thr_b3_cent
call wall_time(wall0) call wall_time(wall0)
int2_u_grad1u_j1b2_test = 0.d0 int2_u_grad1u_env2_test = 0.d0
!$OMP PARALLEL DEFAULT (NONE) & !$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, & !$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 coef_fit, expo_fit, int_fit, tmp, alpha_1s, dist, &
!$OMP beta_ij,center_ij_1s,factor_ij_1s, & !$OMP beta_ij,center_ij_1s,factor_ij_1s, &
!$OMP int_j1b,alpha_1s_inv, centr_1s, expo_coef_1s, coef_tmp) & !$OMP int_env,alpha_1s_inv, centr_1s, expo_coef_1s, coef_tmp) &
!$OMP SHARED (n_points_final_grid, ao_num, List_comb_thr_b3_size, & !$OMP SHARED (n_points_final_grid, ao_num, List_comb_thr_b3_size, &
!$OMP final_grid_points, ng_fit_jast, & !$OMP final_grid_points, ng_fit_jast, &
!$OMP expo_gauss_j_mu_1_erf, coef_gauss_j_mu_1_erf, & !$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 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_coef, List_comb_thr_b3_expo, ao_abs_comb_b3_env, &
!$OMP List_comb_thr_b3_cent, int2_u_grad1u_j1b2_test,thrsh_cycle_tc) !$OMP List_comb_thr_b3_cent, int2_u_grad1u_env2_test,thrsh_cycle_tc)
!$OMP DO !$OMP DO
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do i = 1, ao_num do i = 1, ao_num
@ -484,11 +485,9 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_j1b2_test, (ao_num, ao_num, n_p
! i_1s = 1 ! i_1s = 1
! --- --- --- ! --- --- ---
int_j1b = ao_abs_comb_b3_j1b(1,j,i) int_env = ao_abs_comb_b3_env(1,j,i)
! if(dabs(int_j1b).lt.thrsh_cycle_tc) cycle
do i_fit = 1, ng_fit_jast do i_fit = 1, ng_fit_jast
expo_fit = expo_gauss_j_mu_1_erf(i_fit) expo_fit = expo_gauss_j_mu_1_erf(i_fit)
! if(dabs(int_j1b)*dsqpi_3_2*expo_fit**(-1.5d0).lt.thrsh_cycle_tc) cycle
coef_fit = coef_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) int_fit = NAI_pol_mult_erf_ao_with1s(i, j, expo_fit, r, 1.d+9, r)
tmp += coef_fit * int_fit tmp += coef_fit * int_fit
@ -502,8 +501,7 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_j1b2_test, (ao_num, ao_num, n_p
coef = List_comb_thr_b3_coef (i_1s,j,i) coef = List_comb_thr_b3_coef (i_1s,j,i)
beta = List_comb_thr_b3_expo (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) int_env = ao_abs_comb_b3_env(i_1s,j,i)
! if(dabs(coef)*dabs(int_j1b).lt.thrsh_cycle_tc)cycle
B_center(1) = List_comb_thr_b3_cent(1,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(2) = List_comb_thr_b3_cent(2,i_1s,j,i)
B_center(3) = List_comb_thr_b3_cent(3,i_1s,j,i) B_center(3) = List_comb_thr_b3_cent(3,i_1s,j,i)
@ -513,7 +511,6 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_j1b2_test, (ao_num, ao_num, n_p
do i_fit = 1, ng_fit_jast do i_fit = 1, ng_fit_jast
expo_fit = expo_gauss_j_mu_1_erf(i_fit) 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) 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.thrsh_cycle_tc)cycle
coef_fit = coef_gauss_j_mu_1_erf(i_fit) coef_fit = coef_gauss_j_mu_1_erf(i_fit)
alpha_1s = beta + expo_fit alpha_1s = beta + expo_fit
@ -533,7 +530,7 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_j1b2_test, (ao_num, ao_num, n_p
enddo enddo
enddo enddo
int2_u_grad1u_j1b2_test(j,i,ipoint) = tmp int2_u_grad1u_env2_test(j,i,ipoint) = tmp
enddo enddo
enddo enddo
enddo enddo
@ -543,14 +540,15 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_j1b2_test, (ao_num, ao_num, n_p
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do i = 2, ao_num do i = 2, ao_num
do j = 1, i-1 do j = 1, i-1
int2_u_grad1u_j1b2_test(j,i,ipoint) = int2_u_grad1u_j1b2_test(i,j,ipoint) int2_u_grad1u_env2_test(j,i,ipoint) = int2_u_grad1u_env2_test(i,j,ipoint)
enddo enddo
enddo enddo
enddo enddo
call wall_time(wall1) call wall_time(wall1)
print*, ' wall time for int2_u_grad1u_j1b2_test', wall1 - wall0 print*, ' wall time for int2_u_grad1u_env2_test (min) = ', (wall1 - wall0) / 60.d0
END_PROVIDER END_PROVIDER
! --- ! ---

203
plugins/local/ao_many_one_e_ints/grad2_jmu_modif.irp.f
View File

@ -6,7 +6,7 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2, (ao_num, ao_num, n_poin
BEGIN_DOC BEGIN_DOC
! !
! -\frac{1}{4} x int dr2 phi_i(r2) phi_j(r2) [1 - erf(mu r12)]^2 ! \frac{1}{4} x int dr2 phi_i(r2) phi_j(r2) [1 - erf(mu r12)]^2
! !
END_DOC END_DOC
@ -21,7 +21,8 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2, (ao_num, ao_num, n_poin
print*, ' providing int2_grad1u2_grad2u2 ...' print*, ' providing int2_grad1u2_grad2u2 ...'
call wall_time(wall0) call wall_time(wall0)
provide mu_erf final_grid_points j1b_pen provide mu_erf
provide final_grid_points
int2_grad1u2_grad2u2 = 0.d0 int2_grad1u2_grad2u2 = 0.d0
@ -44,7 +45,7 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2, (ao_num, ao_num, n_poin
expo_fit = expo_gauss_1_erf_x_2(i_fit) expo_fit = expo_gauss_1_erf_x_2(i_fit)
coef_fit = coef_gauss_1_erf_x_2(i_fit) coef_fit = coef_gauss_1_erf_x_2(i_fit)
tmp += -0.25d0 * coef_fit * overlap_gauss_r12_ao(r, expo_fit, i, j) tmp += 0.25d0 * coef_fit * overlap_gauss_r12_ao(r, expo_fit, i, j)
enddo enddo
int2_grad1u2_grad2u2(j,i,ipoint) = tmp int2_grad1u2_grad2u2(j,i,ipoint) = tmp
@ -63,17 +64,17 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2, (ao_num, ao_num, n_poin
enddo enddo
call wall_time(wall1) call wall_time(wall1)
print*, ' wall time for int2_grad1u2_grad2u2 =', wall1 - wall0 print*, ' wall time for int2_grad1u2_grad2u2 (min) = ', (wall1 - wall0) / 60.d0
END_PROVIDER END_PROVIDER
! --- ! ---
BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2, (ao_num, ao_num, n_points_final_grid)] BEGIN_PROVIDER [double precision, int2_grad1u2_grad2u2_env2, (ao_num, ao_num, n_points_final_grid)]
BEGIN_DOC BEGIN_DOC
! !
! -\frac{1}{4} x int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 [1 - erf(mu r12)]^2 ! -\frac{1}{4} x int dr2 phi_i(r2) phi_j(r2) 1s_env(r2)^2 [1 - erf(mu r12)]^2
! !
END_DOC END_DOC
@ -87,21 +88,22 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2, (ao_num, ao_num, n
double precision, external :: overlap_gauss_r12_ao double precision, external :: overlap_gauss_r12_ao
double precision, external :: overlap_gauss_r12_ao_with1s double precision, external :: overlap_gauss_r12_ao_with1s
print*, ' providing int2_grad1u2_grad2u2_j1b2 ...' print*, ' providing int2_grad1u2_grad2u2_env2 ...'
call wall_time(wall0) call wall_time(wall0)
provide mu_erf final_grid_points j1b_pen provide mu_erf
provide final_grid_points
int2_grad1u2_grad2u2_j1b2 = 0.d0 int2_grad1u2_grad2u2_env2 = 0.d0
!$OMP PARALLEL DEFAULT (NONE) & !$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, & !$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, &
!$OMP coef_fit, expo_fit, int_fit, tmp) & !$OMP coef_fit, expo_fit, int_fit, tmp) &
!$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b3_size, & !$OMP SHARED (n_points_final_grid, ao_num, List_env1s_square_size, &
!$OMP final_grid_points, ng_fit_jast, & !$OMP final_grid_points, ng_fit_jast, &
!$OMP expo_gauss_1_erf_x_2, coef_gauss_1_erf_x_2, & !$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_env1s_square_coef, List_env1s_square_expo, &
!$OMP List_all_comb_b3_cent, int2_grad1u2_grad2u2_j1b2) !$OMP List_env1s_square_cent, int2_grad1u2_grad2u2_env2)
!$OMP DO !$OMP DO
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
r(1) = final_grid_points(1,ipoint) r(1) = final_grid_points(1,ipoint)
@ -125,14 +127,14 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2, (ao_num, ao_num, n
! --- ! ---
do i_1s = 2, List_all_comb_b3_size do i_1s = 2, List_env1s_square_size
coef = List_all_comb_b3_coef (i_1s) coef = List_env1s_square_coef (i_1s)
if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0 if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0
beta = List_all_comb_b3_expo (i_1s) beta = List_env1s_square_expo (i_1s)
B_center(1) = List_all_comb_b3_cent(1,i_1s) B_center(1) = List_env1s_square_cent(1,i_1s)
B_center(2) = List_all_comb_b3_cent(2,i_1s) B_center(2) = List_env1s_square_cent(2,i_1s)
B_center(3) = List_all_comb_b3_cent(3,i_1s) B_center(3) = List_env1s_square_cent(3,i_1s)
int_fit = overlap_gauss_r12_ao_with1s(B_center, beta, r, expo_fit, i, j) int_fit = overlap_gauss_r12_ao_with1s(B_center, beta, r, expo_fit, i, j)
@ -143,7 +145,7 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2, (ao_num, ao_num, n
enddo enddo
int2_grad1u2_grad2u2_j1b2(j,i,ipoint) = tmp int2_grad1u2_grad2u2_env2(j,i,ipoint) = tmp
enddo enddo
enddo enddo
enddo enddo
@ -153,23 +155,23 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2, (ao_num, ao_num, n
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do i = 2, ao_num do i = 2, ao_num
do j = 1, i-1 do j = 1, i-1
int2_grad1u2_grad2u2_j1b2(j,i,ipoint) = int2_grad1u2_grad2u2_j1b2(i,j,ipoint) int2_grad1u2_grad2u2_env2(j,i,ipoint) = int2_grad1u2_grad2u2_env2(i,j,ipoint)
enddo enddo
enddo enddo
enddo enddo
call wall_time(wall1) call wall_time(wall1)
print*, ' wall time for int2_grad1u2_grad2u2_j1b2 =', wall1 - wall0 print*, ' wall time for int2_grad1u2_grad2u2_env2 (min) =', (wall1 - wall0) / 60.d0
END_PROVIDER END_PROVIDER
! --- ! ---
BEGIN_PROVIDER [double precision, int2_u2_j1b2, (ao_num, ao_num, n_points_final_grid)] BEGIN_PROVIDER [double precision, int2_u2_env2, (ao_num, ao_num, n_points_final_grid)]
BEGIN_DOC BEGIN_DOC
! !
! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 [u_12^mu]^2 ! int dr2 phi_i(r2) phi_j(r2) 1s_env(r2)^2 [u_12^mu]^2
! !
END_DOC END_DOC
@ -182,21 +184,22 @@ BEGIN_PROVIDER [double precision, int2_u2_j1b2, (ao_num, ao_num, n_points_final_
double precision, external :: overlap_gauss_r12_ao double precision, external :: overlap_gauss_r12_ao
double precision, external :: overlap_gauss_r12_ao_with1s double precision, external :: overlap_gauss_r12_ao_with1s
print*, ' providing int2_u2_j1b2 ...' print*, ' providing int2_u2_env2 ...'
call wall_time(wall0) call wall_time(wall0)
provide mu_erf final_grid_points j1b_pen provide mu_erf
provide final_grid_points
int2_u2_j1b2 = 0.d0 int2_u2_env2 = 0.d0
!$OMP PARALLEL DEFAULT (NONE) & !$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, & !$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, &
!$OMP coef_fit, expo_fit, int_fit, tmp) & !$OMP coef_fit, expo_fit, int_fit, tmp) &
!$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b3_size, & !$OMP SHARED (n_points_final_grid, ao_num, List_env1s_square_size, &
!$OMP final_grid_points, ng_fit_jast, & !$OMP final_grid_points, ng_fit_jast, &
!$OMP expo_gauss_j_mu_x_2, coef_gauss_j_mu_x_2, & !$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_env1s_square_coef, List_env1s_square_expo, &
!$OMP List_all_comb_b3_cent, int2_u2_j1b2) !$OMP List_env1s_square_cent, int2_u2_env2)
!$OMP DO !$OMP DO
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
r(1) = final_grid_points(1,ipoint) r(1) = final_grid_points(1,ipoint)
@ -220,14 +223,14 @@ BEGIN_PROVIDER [double precision, int2_u2_j1b2, (ao_num, ao_num, n_points_final_
! --- ! ---
do i_1s = 2, List_all_comb_b3_size do i_1s = 2, List_env1s_square_size
coef = List_all_comb_b3_coef (i_1s) coef = List_env1s_square_coef (i_1s)
if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0 if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0
beta = List_all_comb_b3_expo (i_1s) beta = List_env1s_square_expo (i_1s)
B_center(1) = List_all_comb_b3_cent(1,i_1s) B_center(1) = List_env1s_square_cent(1,i_1s)
B_center(2) = List_all_comb_b3_cent(2,i_1s) B_center(2) = List_env1s_square_cent(2,i_1s)
B_center(3) = List_all_comb_b3_cent(3,i_1s) B_center(3) = List_env1s_square_cent(3,i_1s)
int_fit = overlap_gauss_r12_ao_with1s(B_center, beta, r, expo_fit, i, j) int_fit = overlap_gauss_r12_ao_with1s(B_center, beta, r, expo_fit, i, j)
@ -238,7 +241,7 @@ BEGIN_PROVIDER [double precision, int2_u2_j1b2, (ao_num, ao_num, n_points_final_
enddo enddo
int2_u2_j1b2(j,i,ipoint) = tmp int2_u2_env2(j,i,ipoint) = tmp
enddo enddo
enddo enddo
enddo enddo
@ -248,23 +251,23 @@ BEGIN_PROVIDER [double precision, int2_u2_j1b2, (ao_num, ao_num, n_points_final_
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do i = 2, ao_num do i = 2, ao_num
do j = 1, i-1 do j = 1, i-1
int2_u2_j1b2(j,i,ipoint) = int2_u2_j1b2(i,j,ipoint) int2_u2_env2(j,i,ipoint) = int2_u2_env2(i,j,ipoint)
enddo enddo
enddo enddo
enddo enddo
call wall_time(wall1) call wall_time(wall1)
print*, ' wall time for int2_u2_j1b2', wall1 - wall0 print*, ' wall time for int2_u2_env2 (min) = ', (wall1 - wall0) / 60.d0
END_PROVIDER END_PROVIDER
! --- ! ---
BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2, (ao_num, ao_num, n_points_final_grid, 3)] BEGIN_PROVIDER [double precision, int2_u_grad1u_x_env2, (ao_num, ao_num, n_points_final_grid, 3)]
BEGIN_DOC BEGIN_DOC
! !
! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 u_12^mu [\grad_1 u_12^mu] r2 ! int dr2 phi_i(r2) phi_j(r2) 1s_env(r2)^2 u_12^mu [\grad_1 u_12^mu] r2
! !
END_DOC END_DOC
@ -276,23 +279,24 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2, (ao_num, ao_num, n_poin
double precision :: tmp_x, tmp_y, tmp_z double precision :: tmp_x, tmp_y, tmp_z
double precision :: wall0, wall1 double precision :: wall0, wall1
print*, ' providing int2_u_grad1u_x_j1b2 ...' print*, ' providing int2_u_grad1u_x_env2 ...'
call wall_time(wall0) call wall_time(wall0)
provide mu_erf final_grid_points j1b_pen provide mu_erf
provide final_grid_points
int2_u_grad1u_x_j1b2 = 0.d0 int2_u_grad1u_x_env2 = 0.d0
!$OMP PARALLEL DEFAULT (NONE) & !$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, & !$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 coef_fit, expo_fit, int_fit, alpha_1s, dist, &
!$OMP alpha_1s_inv, centr_1s, expo_coef_1s, coef_tmp, & !$OMP alpha_1s_inv, centr_1s, expo_coef_1s, coef_tmp, &
!$OMP tmp_x, tmp_y, tmp_z) & !$OMP tmp_x, tmp_y, tmp_z) &
!$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b3_size, & !$OMP SHARED (n_points_final_grid, ao_num, List_env1s_square_size, &
!$OMP final_grid_points, ng_fit_jast, & !$OMP final_grid_points, ng_fit_jast, &
!$OMP expo_gauss_j_mu_1_erf, coef_gauss_j_mu_1_erf, & !$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_env1s_square_coef, List_env1s_square_expo, &
!$OMP List_all_comb_b3_cent, int2_u_grad1u_x_j1b2) !$OMP List_env1s_square_cent, int2_u_grad1u_x_env2)
!$OMP DO !$OMP DO
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
@ -321,14 +325,14 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2, (ao_num, ao_num, n_poin
! --- ! ---
do i_1s = 2, List_all_comb_b3_size do i_1s = 2, List_env1s_square_size
coef = List_all_comb_b3_coef (i_1s) coef = List_env1s_square_coef (i_1s)
if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0 if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0
beta = List_all_comb_b3_expo (i_1s) beta = List_env1s_square_expo (i_1s)
B_center(1) = List_all_comb_b3_cent(1,i_1s) B_center(1) = List_env1s_square_cent(1,i_1s)
B_center(2) = List_all_comb_b3_cent(2,i_1s) B_center(2) = List_env1s_square_cent(2,i_1s)
B_center(3) = List_all_comb_b3_cent(3,i_1s) B_center(3) = List_env1s_square_cent(3,i_1s)
dist = (B_center(1) - r(1)) * (B_center(1) - r(1)) & dist = (B_center(1) - r(1)) * (B_center(1) - r(1)) &
+ (B_center(2) - r(2)) * (B_center(2) - r(2)) & + (B_center(2) - r(2)) * (B_center(2) - r(2)) &
+ (B_center(3) - r(3)) * (B_center(3) - r(3)) + (B_center(3) - r(3)) * (B_center(3) - r(3))
@ -355,9 +359,9 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2, (ao_num, ao_num, n_poin
enddo enddo
int2_u_grad1u_x_j1b2(j,i,ipoint,1) = tmp_x int2_u_grad1u_x_env2(j,i,ipoint,1) = tmp_x
int2_u_grad1u_x_j1b2(j,i,ipoint,2) = tmp_y int2_u_grad1u_x_env2(j,i,ipoint,2) = tmp_y
int2_u_grad1u_x_j1b2(j,i,ipoint,3) = tmp_z int2_u_grad1u_x_env2(j,i,ipoint,3) = tmp_z
enddo enddo
enddo enddo
enddo enddo
@ -367,25 +371,25 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2, (ao_num, ao_num, n_poin
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do i = 2, ao_num do i = 2, ao_num
do j = 1, i-1 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_env2(j,i,ipoint,1) = int2_u_grad1u_x_env2(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_env2(j,i,ipoint,2) = int2_u_grad1u_x_env2(i,j,ipoint,2)
int2_u_grad1u_x_j1b2(j,i,ipoint,3) = int2_u_grad1u_x_j1b2(i,j,ipoint,3) int2_u_grad1u_x_env2(j,i,ipoint,3) = int2_u_grad1u_x_env2(i,j,ipoint,3)
enddo enddo
enddo enddo
enddo enddo
call wall_time(wall1) call wall_time(wall1)
print*, ' wall time for int2_u_grad1u_x_j1b2 = ', wall1 - wall0 print*, ' wall time for int2_u_grad1u_x_env2 (min) = ', (wall1 - wall0) / 60.d0
END_PROVIDER END_PROVIDER
! --- ! ---
BEGIN_PROVIDER [ double precision, int2_u_grad1u_j1b2, (ao_num, ao_num, n_points_final_grid)] BEGIN_PROVIDER [ double precision, int2_u_grad1u_env2, (ao_num, ao_num, n_points_final_grid)]
BEGIN_DOC BEGIN_DOC
! !
! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 u_12^mu [\grad_1 u_12^mu] ! int dr2 phi_i(r2) phi_j(r2) 1s_env(r2)^2 u_12^mu [\grad_1 u_12^mu]
! !
END_DOC END_DOC
@ -397,22 +401,23 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_j1b2, (ao_num, ao_num, n_points
double precision :: wall0, wall1 double precision :: wall0, wall1
double precision, external :: NAI_pol_mult_erf_ao_with1s double precision, external :: NAI_pol_mult_erf_ao_with1s
print*, ' providing int2_u_grad1u_j1b2 ...' print*, ' providing int2_u_grad1u_env2 ...'
call wall_time(wall0) call wall_time(wall0)
provide mu_erf final_grid_points j1b_pen provide mu_erf
provide final_grid_points
int2_u_grad1u_j1b2 = 0.d0 int2_u_grad1u_env2 = 0.d0
!$OMP PARALLEL DEFAULT (NONE) & !$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, & !$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 coef_fit, expo_fit, int_fit, tmp, alpha_1s, dist, &
!$OMP alpha_1s_inv, centr_1s, expo_coef_1s, coef_tmp) & !$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 SHARED (n_points_final_grid, ao_num, List_env1s_square_size, &
!$OMP final_grid_points, ng_fit_jast, & !$OMP final_grid_points, ng_fit_jast, &
!$OMP expo_gauss_j_mu_1_erf, coef_gauss_j_mu_1_erf, & !$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_env1s_square_coef, List_env1s_square_expo, &
!$OMP List_all_comb_b3_cent, int2_u_grad1u_j1b2) !$OMP List_env1s_square_cent, int2_u_grad1u_env2)
!$OMP DO !$OMP DO
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do i = 1, ao_num do i = 1, ao_num
@ -436,14 +441,14 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_j1b2, (ao_num, ao_num, n_points
! --- ! ---
do i_1s = 2, List_all_comb_b3_size do i_1s = 2, List_env1s_square_size
coef = List_all_comb_b3_coef (i_1s) coef = List_env1s_square_coef (i_1s)
if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0 if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0
beta = List_all_comb_b3_expo (i_1s) beta = List_env1s_square_expo (i_1s)
B_center(1) = List_all_comb_b3_cent(1,i_1s) B_center(1) = List_env1s_square_cent(1,i_1s)
B_center(2) = List_all_comb_b3_cent(2,i_1s) B_center(2) = List_env1s_square_cent(2,i_1s)
B_center(3) = List_all_comb_b3_cent(3,i_1s) B_center(3) = List_env1s_square_cent(3,i_1s)
dist = (B_center(1) - r(1)) * (B_center(1) - r(1)) & dist = (B_center(1) - r(1)) * (B_center(1) - r(1)) &
+ (B_center(2) - r(2)) * (B_center(2) - r(2)) & + (B_center(2) - r(2)) * (B_center(2) - r(2)) &
+ (B_center(3) - r(3)) * (B_center(3) - r(3)) + (B_center(3) - r(3)) * (B_center(3) - r(3))
@ -468,7 +473,7 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_j1b2, (ao_num, ao_num, n_points
enddo enddo
int2_u_grad1u_j1b2(j,i,ipoint) = tmp int2_u_grad1u_env2(j,i,ipoint) = tmp
enddo enddo
enddo enddo
enddo enddo
@ -478,13 +483,13 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_j1b2, (ao_num, ao_num, n_points
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do i = 2, ao_num do i = 2, ao_num
do j = 1, i-1 do j = 1, i-1
int2_u_grad1u_j1b2(j,i,ipoint) = int2_u_grad1u_j1b2(i,j,ipoint) int2_u_grad1u_env2(j,i,ipoint) = int2_u_grad1u_env2(i,j,ipoint)
enddo enddo
enddo enddo
enddo enddo
call wall_time(wall1) call wall_time(wall1)
print*, ' wall time for int2_u_grad1u_j1b2', wall1 - wall0 print*, ' wall time for int2_u_grad1u_env2 (min) = ', (wall1 - wall0) / 60.d0
END_PROVIDER END_PROVIDER

453
plugins/local/ao_many_one_e_ints/grad2_jmu_modif_vect.irp.f
View File

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

115
plugins/local/ao_many_one_e_ints/grad_lapl_jmu_manu.irp.f
View File

@ -1,11 +1,11 @@
! --- ! ---
BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_j1b_test, (ao_num, ao_num, n_points_final_grid)] BEGIN_PROVIDER [double precision, v_ij_erf_rk_cst_mu_env_test, (ao_num, ao_num, n_points_final_grid)]
BEGIN_DOC BEGIN_DOC
! !
! int dr phi_i(r) phi_j(r) 1s_j1b(r) (erf(mu(R) |r - R| - 1) / |r - R| ! int dr phi_i(r) phi_j(r) 1s_env(r) (erf(mu(R) |r - R| - 1) / |r - R|
! !
END_DOC END_DOC
@ -13,24 +13,23 @@ BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_j1b_test, (ao_num, ao_num,
integer :: i, j, ipoint, i_1s integer :: i, j, ipoint, i_1s
double precision :: r(3), int_mu, int_coulomb double precision :: r(3), int_mu, int_coulomb
double precision :: coef, beta, B_center(3) double precision :: coef, beta, B_center(3)
double precision :: tmp,int_j1b double precision :: tmp,int_env
double precision :: wall0, wall1 double precision :: wall0, wall1
double precision, external :: NAI_pol_mult_erf_ao_with1s double precision, external :: NAI_pol_mult_erf_ao_with1s
double precision :: sigma_ij,dist_ij_ipoint,dsqpi_3_2 double precision :: sigma_ij,dist_ij_ipoint,dsqpi_3_2
print*, ' providing v_ij_erf_rk_cst_mu_j1b_test ...' print*, ' providing v_ij_erf_rk_cst_mu_env_test ...'
dsqpi_3_2 = (dacos(-1.d0))**(1.5d0) dsqpi_3_2 = (dacos(-1.d0))**(1.5d0)
provide mu_erf final_grid_points j1b_pen
call wall_time(wall0) call wall_time(wall0)
v_ij_erf_rk_cst_mu_j1b_test = 0.d0 v_ij_erf_rk_cst_mu_env_test = 0.d0
!$OMP PARALLEL DEFAULT (NONE) & !$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, int_mu, int_coulomb, tmp, int_j1b)& !$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, int_mu, int_coulomb, tmp, int_env)&
!$OMP SHARED (n_points_final_grid, ao_num, List_comb_thr_b2_size, final_grid_points, & !$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 List_comb_thr_b2_coef, List_comb_thr_b2_expo, List_comb_thr_b2_cent,ao_abs_comb_b2_env, &
!$OMP v_ij_erf_rk_cst_mu_j1b_test, mu_erf, & !$OMP v_ij_erf_rk_cst_mu_env_test, mu_erf, &
!$OMP ao_overlap_abs_grid,ao_prod_center,ao_prod_sigma,dsqpi_3_2,thrsh_cycle_tc) !$OMP ao_overlap_abs_grid,ao_prod_center,ao_prod_sigma,dsqpi_3_2,thrsh_cycle_tc)
!$OMP DO !$OMP DO
!do ipoint = 1, 10 !do ipoint = 1, 10
@ -48,8 +47,8 @@ BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_j1b_test, (ao_num, ao_num,
coef = List_comb_thr_b2_coef (i_1s,j,i) coef = List_comb_thr_b2_coef (i_1s,j,i)
beta = List_comb_thr_b2_expo (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) int_env = ao_abs_comb_b2_env(i_1s,j,i)
! if(dabs(coef)*dabs(int_j1b).lt.thrsh_cycle_tc)cycle ! if(dabs(coef)*dabs(int_env).lt.thrsh_cycle_tc)cycle
B_center(1) = List_comb_thr_b2_cent(1,i_1s,j,i) 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(2) = List_comb_thr_b2_cent(2,i_1s,j,i)
B_center(3) = List_comb_thr_b2_cent(3,i_1s,j,i) B_center(3) = List_comb_thr_b2_cent(3,i_1s,j,i)
@ -60,7 +59,7 @@ BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_j1b_test, (ao_num, ao_num,
tmp += coef * (int_mu - int_coulomb) tmp += coef * (int_mu - int_coulomb)
enddo enddo
v_ij_erf_rk_cst_mu_j1b_test(j,i,ipoint) = tmp v_ij_erf_rk_cst_mu_env_test(j,i,ipoint) = tmp
enddo enddo
enddo enddo
enddo enddo
@ -70,22 +69,22 @@ BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_j1b_test, (ao_num, ao_num,
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do i = 2, ao_num do i = 2, ao_num
do j = 1, i-1 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) v_ij_erf_rk_cst_mu_env_test(j,i,ipoint) = v_ij_erf_rk_cst_mu_env_test(i,j,ipoint)
enddo enddo
enddo enddo
enddo enddo
call wall_time(wall1) call wall_time(wall1)
print*, ' wall time for v_ij_erf_rk_cst_mu_j1b_test', wall1 - wall0 print*, ' wall time for v_ij_erf_rk_cst_mu_env_test (min) = ', (wall1 - wall0) / 60.d0
END_PROVIDER 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_PROVIDER [double precision, x_v_ij_erf_rk_cst_mu_env_test, (ao_num, ao_num, n_points_final_grid, 3)]
BEGIN_DOC BEGIN_DOC
! int dr x phi_i(r) phi_j(r) 1s_j1b(r) (erf(mu(R) |r - R|) - 1)/|r - R| ! int dr x phi_i(r) phi_j(r) 1s_env(r) (erf(mu(R) |r - R|) - 1)/|r - R|
END_DOC END_DOC
implicit none implicit none
@ -93,23 +92,23 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_j1b_test, (ao_num, ao_nu
double precision :: coef, beta, B_center(3), r(3), ints(3), ints_coulomb(3) double precision :: coef, beta, B_center(3), r(3), ints(3), ints_coulomb(3)
double precision :: tmp_x, tmp_y, tmp_z double precision :: tmp_x, tmp_y, tmp_z
double precision :: wall0, wall1 double precision :: wall0, wall1
double precision :: sigma_ij,dist_ij_ipoint,dsqpi_3_2,int_j1b,factor_ij_1s,beta_ij,center_ij_1s double precision :: sigma_ij,dist_ij_ipoint,dsqpi_3_2,int_env,factor_ij_1s,beta_ij,center_ij_1s
print*, ' providing x_v_ij_erf_rk_cst_mu_j1b_test ...' print*, ' providing x_v_ij_erf_rk_cst_mu_env_test ...'
dsqpi_3_2 = (dacos(-1.d0))**(1.5d0) dsqpi_3_2 = (dacos(-1.d0))**(1.5d0)
provide expo_erfc_mu_gauss ao_prod_sigma ao_prod_center provide expo_erfc_mu_gauss ao_prod_sigma ao_prod_center
call wall_time(wall0) call wall_time(wall0)
x_v_ij_erf_rk_cst_mu_j1b_test = 0.d0 x_v_ij_erf_rk_cst_mu_env_test = 0.d0
!$OMP PARALLEL DEFAULT (NONE) & !$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, ints, ints_coulomb, & !$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 int_env, 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 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 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 x_v_ij_erf_rk_cst_mu_env_test, mu_erf,ao_abs_comb_b2_env, &
!$OMP ao_overlap_abs_grid,ao_prod_center,ao_prod_sigma,thrsh_cycle_tc) !$OMP ao_overlap_abs_grid,ao_prod_center,ao_prod_sigma,thrsh_cycle_tc)
! !$OMP ao_overlap_abs_grid,ao_prod_center,ao_prod_sigma,dsqpi_3_2,expo_erfc_mu_gauss) ! !$OMP ao_overlap_abs_grid,ao_prod_center,ao_prod_sigma,dsqpi_3_2,expo_erfc_mu_gauss)
!$OMP DO !$OMP DO
@ -129,8 +128,8 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_j1b_test, (ao_num, ao_nu
coef = List_comb_thr_b2_coef (i_1s,j,i) coef = List_comb_thr_b2_coef (i_1s,j,i)
beta = List_comb_thr_b2_expo (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) int_env = ao_abs_comb_b2_env(i_1s,j,i)
! if(dabs(coef)*dabs(int_j1b).lt.thrsh_cycle_tc)cycle ! if(dabs(coef)*dabs(int_env).lt.thrsh_cycle_tc)cycle
B_center(1) = List_comb_thr_b2_cent(1,i_1s,j,i) 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(2) = List_comb_thr_b2_cent(2,i_1s,j,i)
B_center(3) = List_comb_thr_b2_cent(3,i_1s,j,i) B_center(3) = List_comb_thr_b2_cent(3,i_1s,j,i)
@ -143,9 +142,9 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_j1b_test, (ao_num, ao_nu
tmp_z += coef * (ints(3) - ints_coulomb(3)) tmp_z += coef * (ints(3) - ints_coulomb(3))
enddo enddo
x_v_ij_erf_rk_cst_mu_j1b_test(j,i,ipoint,1) = tmp_x x_v_ij_erf_rk_cst_mu_env_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_env_test(j,i,ipoint,2) = tmp_y
x_v_ij_erf_rk_cst_mu_j1b_test(j,i,ipoint,3) = tmp_z x_v_ij_erf_rk_cst_mu_env_test(j,i,ipoint,3) = tmp_z
enddo enddo
enddo enddo
enddo enddo
@ -155,26 +154,26 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_j1b_test, (ao_num, ao_nu
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do i = 2, ao_num do i = 2, ao_num
do j = 1, i-1 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_env_test(j,i,ipoint,1) = x_v_ij_erf_rk_cst_mu_env_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_env_test(j,i,ipoint,2) = x_v_ij_erf_rk_cst_mu_env_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) x_v_ij_erf_rk_cst_mu_env_test(j,i,ipoint,3) = x_v_ij_erf_rk_cst_mu_env_test(i,j,ipoint,3)
enddo enddo
enddo enddo
enddo enddo
call wall_time(wall1) call wall_time(wall1)
print*, ' wall time for x_v_ij_erf_rk_cst_mu_j1b_test', wall1 - wall0 print*, ' wall time for x_v_ij_erf_rk_cst_mu_env_test (min) = ', (wall1 - wall0) / 60.d0
END_PROVIDER END_PROVIDER
! --- ! ---
! TODO analytically ! TODO analytically
BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_test, (ao_num, ao_num, n_points_final_grid)] BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_env_test, (ao_num, ao_num, n_points_final_grid)]
BEGIN_DOC BEGIN_DOC
! !
! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2) u(mu, r12) ! int dr2 phi_i(r2) phi_j(r2) 1s_env(r2) u(mu, r12)
! !
END_DOC END_DOC
@ -185,29 +184,28 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_test, (ao_num, ao_num, n_po
double precision :: tmp double precision :: tmp
double precision :: wall0, wall1 double precision :: wall0, wall1
double precision :: beta_ij_u, factor_ij_1s_u, center_ij_1s_u(3), coeftot double precision :: beta_ij_u, factor_ij_1s_u, center_ij_1s_u(3), coeftot
double precision :: sigma_ij, dist_ij_ipoint, dsqpi_3_2, int_j1b double precision :: sigma_ij, dist_ij_ipoint, dsqpi_3_2, int_env
double precision, external :: overlap_gauss_r12_ao double precision, external :: overlap_gauss_r12_ao
double precision, external :: overlap_gauss_r12_ao_with1s double precision, external :: overlap_gauss_r12_ao_with1s
print*, ' providing v_ij_u_cst_mu_j1b_test ...' print*, ' providing v_ij_u_cst_mu_env_test ...'
dsqpi_3_2 = (dacos(-1.d0))**(1.5d0) dsqpi_3_2 = (dacos(-1.d0))**(1.5d0)
provide mu_erf final_grid_points j1b_pen
call wall_time(wall0) call wall_time(wall0)
v_ij_u_cst_mu_j1b_test = 0.d0 v_ij_u_cst_mu_env_test = 0.d0
!$OMP PARALLEL DEFAULT (NONE) & !$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, & !$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 beta_ij_u, factor_ij_1s_u, center_ij_1s_u, &
!$OMP coef_fit, expo_fit, int_fit, tmp,coeftot,int_j1b) & !$OMP coef_fit, expo_fit, int_fit, tmp,coeftot,int_env) &
!$OMP SHARED (n_points_final_grid, ao_num, & !$OMP SHARED (n_points_final_grid, ao_num, &
!$OMP final_grid_points, ng_fit_jast, & !$OMP final_grid_points, ng_fit_jast, &
!$OMP expo_gauss_j_mu_x, coef_gauss_j_mu_x, & !$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_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 List_comb_thr_b2_cent, v_ij_u_cst_mu_env_test,ao_abs_comb_b2_env, &
!$OMP ao_overlap_abs_grid,ao_prod_center,ao_prod_sigma,dsqpi_3_2,thrsh_cycle_tc) !$OMP ao_overlap_abs_grid,ao_prod_center,ao_prod_sigma,dsqpi_3_2,thrsh_cycle_tc)
!$OMP DO !$OMP DO
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
@ -225,8 +223,8 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_test, (ao_num, ao_num, n_po
! i_1s = 1 ! i_1s = 1
! --- --- --- ! --- --- ---
int_j1b = ao_abs_comb_b2_j1b(1,j,i) int_env = ao_abs_comb_b2_env(1,j,i)
! if(dabs(int_j1b).lt.thrsh_cycle_tc) cycle ! if(dabs(int_env).lt.thrsh_cycle_tc) cycle
do i_fit = 1, ng_fit_jast do i_fit = 1, ng_fit_jast
expo_fit = expo_gauss_j_mu_x(i_fit) expo_fit = expo_gauss_j_mu_x(i_fit)
coef_fit = coef_gauss_j_mu_x(i_fit) coef_fit = coef_gauss_j_mu_x(i_fit)
@ -242,8 +240,8 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_test, (ao_num, ao_num, n_po
do i_1s = 2, List_comb_thr_b2_size(j,i) do i_1s = 2, List_comb_thr_b2_size(j,i)
coef = List_comb_thr_b2_coef (i_1s,j,i) coef = List_comb_thr_b2_coef (i_1s,j,i)
beta = List_comb_thr_b2_expo (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) int_env = ao_abs_comb_b2_env(i_1s,j,i)
! if(dabs(coef)*dabs(int_j1b).lt.thrsh_cycle_tc)cycle ! if(dabs(coef)*dabs(int_env).lt.thrsh_cycle_tc)cycle
B_center(1) = List_comb_thr_b2_cent(1,i_1s,j,i) 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(2) = List_comb_thr_b2_cent(2,i_1s,j,i)
B_center(3) = List_comb_thr_b2_cent(3,i_1s,j,i) B_center(3) = List_comb_thr_b2_cent(3,i_1s,j,i)
@ -259,7 +257,7 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_test, (ao_num, ao_num, n_po
enddo enddo
enddo enddo
v_ij_u_cst_mu_j1b_test(j,i,ipoint) = tmp v_ij_u_cst_mu_env_test(j,i,ipoint) = tmp
enddo enddo
enddo enddo
enddo enddo
@ -269,23 +267,23 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_test, (ao_num, ao_num, n_po
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do i = 2, ao_num do i = 2, ao_num
do j = 1, i-1 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) v_ij_u_cst_mu_env_test(j,i,ipoint) = v_ij_u_cst_mu_env_test(i,j,ipoint)
enddo enddo
enddo enddo
enddo enddo
call wall_time(wall1) call wall_time(wall1)
print*, ' wall time for v_ij_u_cst_mu_j1b_test', wall1 - wall0 print*, ' wall time for v_ij_u_cst_mu_env_test (min) = ', (wall1 - wall0) / 60.d0
END_PROVIDER END_PROVIDER
! --- ! ---
BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_ng_1_test, (ao_num, ao_num, n_points_final_grid)] BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_env_ng_1_test, (ao_num, ao_num, n_points_final_grid)]
BEGIN_DOC 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} ! int dr2 phi_i(r2) phi_j(r2) 1s_env(r2) u(mu, r12) with u(mu,r12) \approx 1/2 mu e^{-2.5 * mu (r12)^2}
! !
END_DOC END_DOC
@ -296,27 +294,26 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_ng_1_test, (ao_num, ao_num,
double precision :: tmp double precision :: tmp
double precision :: wall0, wall1 double precision :: wall0, wall1
double precision :: beta_ij_u, factor_ij_1s_u, center_ij_1s_u(3), coeftot double precision :: beta_ij_u, factor_ij_1s_u, center_ij_1s_u(3), coeftot
double precision :: sigma_ij, dist_ij_ipoint, dsqpi_3_2, int_j1b double precision :: sigma_ij, dist_ij_ipoint, dsqpi_3_2, int_env
double precision, external :: overlap_gauss_r12_ao double precision, external :: overlap_gauss_r12_ao
double precision, external :: overlap_gauss_r12_ao_with1s double precision, external :: overlap_gauss_r12_ao_with1s
dsqpi_3_2 = (dacos(-1.d0))**(1.5d0) dsqpi_3_2 = (dacos(-1.d0))**(1.5d0)
provide mu_erf final_grid_points j1b_pen
call wall_time(wall0) call wall_time(wall0)
v_ij_u_cst_mu_j1b_ng_1_test = 0.d0 v_ij_u_cst_mu_env_ng_1_test = 0.d0
!$OMP PARALLEL DEFAULT (NONE) & !$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, & !$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 beta_ij_u, factor_ij_1s_u, center_ij_1s_u, &
!$OMP coef_fit, expo_fit, int_fit, tmp,coeftot,int_j1b) & !$OMP coef_fit, expo_fit, int_fit, tmp,coeftot,int_env) &
!$OMP SHARED (n_points_final_grid, ao_num, & !$OMP SHARED (n_points_final_grid, ao_num, &
!$OMP final_grid_points, expo_good_j_mu_1gauss,coef_good_j_mu_1gauss, & !$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 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_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 List_comb_thr_b2_cent, v_ij_u_cst_mu_env_ng_1_test,ao_abs_comb_b2_env, &
!$OMP ao_overlap_abs_grid,ao_prod_center,ao_prod_sigma,dsqpi_3_2,thrsh_cycle_tc) !$OMP ao_overlap_abs_grid,ao_prod_center,ao_prod_sigma,dsqpi_3_2,thrsh_cycle_tc)
!$OMP DO !$OMP DO
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
@ -334,8 +331,8 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_ng_1_test, (ao_num, ao_num,
! i_1s = 1 ! i_1s = 1
! --- --- --- ! --- --- ---
int_j1b = ao_abs_comb_b2_j1b(1,j,i) int_env = ao_abs_comb_b2_env(1,j,i)
! if(dabs(int_j1b).lt.thrsh_cycle_tc) cycle ! if(dabs(int_env).lt.thrsh_cycle_tc) cycle
expo_fit = expo_good_j_mu_1gauss expo_fit = expo_good_j_mu_1gauss
int_fit = overlap_gauss_r12_ao(r, expo_fit, i, j) int_fit = overlap_gauss_r12_ao(r, expo_fit, i, j)
tmp += int_fit tmp += int_fit
@ -347,8 +344,8 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_ng_1_test, (ao_num, ao_num,
do i_1s = 2, List_comb_thr_b2_size(j,i) do i_1s = 2, List_comb_thr_b2_size(j,i)
coef = List_comb_thr_b2_coef (i_1s,j,i) coef = List_comb_thr_b2_coef (i_1s,j,i)
beta = List_comb_thr_b2_expo (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) int_env = ao_abs_comb_b2_env(i_1s,j,i)
! if(dabs(coef)*dabs(int_j1b).lt.thrsh_cycle_tc)cycle ! if(dabs(coef)*dabs(int_env).lt.thrsh_cycle_tc)cycle
B_center(1) = List_comb_thr_b2_cent(1,i_1s,j,i) 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(2) = List_comb_thr_b2_cent(2,i_1s,j,i)
B_center(3) = List_comb_thr_b2_cent(3,i_1s,j,i) B_center(3) = List_comb_thr_b2_cent(3,i_1s,j,i)
@ -364,7 +361,7 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_ng_1_test, (ao_num, ao_num,
! enddo ! enddo
enddo enddo
v_ij_u_cst_mu_j1b_ng_1_test(j,i,ipoint) = tmp v_ij_u_cst_mu_env_ng_1_test(j,i,ipoint) = tmp
enddo enddo
enddo enddo
enddo enddo
@ -374,13 +371,13 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_ng_1_test, (ao_num, ao_num,
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do i = 2, ao_num do i = 2, ao_num
do j = 1, i-1 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) v_ij_u_cst_mu_env_ng_1_test(j,i,ipoint) = v_ij_u_cst_mu_env_ng_1_test(i,j,ipoint)
enddo enddo
enddo enddo
enddo enddo
call wall_time(wall1) call wall_time(wall1)
print*, ' wall time for v_ij_u_cst_mu_j1b_ng_1_test', wall1 - wall0 print*, ' wall time for v_ij_u_cst_mu_env_ng_1_test (min) = ', (wall1 - wall0) / 60.d0
END_PROVIDER END_PROVIDER

237
plugins/local/ao_many_one_e_ints/grad_lapl_jmu_modif.irp.f
View File

@ -1,11 +1,11 @@
! --- ! ---
BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_points_final_grid)] BEGIN_PROVIDER [double precision, v_ij_erf_rk_cst_mu_env, (ao_num, ao_num, n_points_final_grid)]
BEGIN_DOC BEGIN_DOC
! !
! int dr phi_i(r) phi_j(r) 1s_j1b(r) (erf(mu(R) |r - R| - 1) / |r - R| ! int dr phi_i(r) phi_j(r) 1s_env(r) (erf(mu(R) |r - R| - 1) / |r - R|
! !
END_DOC END_DOC
@ -17,18 +17,20 @@ BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_po
double precision :: wall0, wall1 double precision :: wall0, wall1
double precision, external :: NAI_pol_mult_erf_ao_with1s double precision, external :: NAI_pol_mult_erf_ao_with1s
print *, ' providing v_ij_erf_rk_cst_mu_j1b ...' PROVIDE mu_erf
PROVIDE final_grid_points
PROVIDE env_expo
print *, ' providing v_ij_erf_rk_cst_mu_env ...'
call wall_time(wall0) call wall_time(wall0)
provide mu_erf final_grid_points j1b_pen v_ij_erf_rk_cst_mu_env = 0.d0
v_ij_erf_rk_cst_mu_j1b = 0.d0
!$OMP PARALLEL DEFAULT (NONE) & !$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, int_mu, int_coulomb, tmp) & !$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 SHARED (n_points_final_grid, ao_num, List_env1s_size, final_grid_points, &
!$OMP List_all_comb_b2_coef, List_all_comb_b2_expo, List_all_comb_b2_cent, & !$OMP List_env1s_coef, List_env1s_expo, List_env1s_cent, &
!$OMP v_ij_erf_rk_cst_mu_j1b, mu_erf) !$OMP v_ij_erf_rk_cst_mu_env, mu_erf)
!$OMP DO !$OMP DO
!do ipoint = 1, 10 !do ipoint = 1, 10
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
@ -43,28 +45,27 @@ BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_po
! --- ! ---
coef = List_all_comb_b2_coef (1) coef = List_env1s_coef (1)
beta = List_all_comb_b2_expo (1) beta = List_env1s_expo (1)
B_center(1) = List_all_comb_b2_cent(1,1) B_center(1) = List_env1s_cent(1,1)
B_center(2) = List_all_comb_b2_cent(2,1) B_center(2) = List_env1s_cent(2,1)
B_center(3) = List_all_comb_b2_cent(3,1) B_center(3) = List_env1s_cent(3,1)
int_mu = NAI_pol_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r) 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) 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) tmp += coef * (int_mu - int_coulomb)
! --- ! ---
do i_1s = 2, List_all_comb_b2_size do i_1s = 2, List_env1s_size
coef = List_all_comb_b2_coef (i_1s) coef = List_env1s_coef (i_1s)
if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0 if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0
beta = List_all_comb_b2_expo (i_1s) beta = List_env1s_expo (i_1s)
B_center(1) = List_all_comb_b2_cent(1,i_1s) B_center(1) = List_env1s_cent(1,i_1s)
B_center(2) = List_all_comb_b2_cent(2,i_1s) B_center(2) = List_env1s_cent(2,i_1s)
B_center(3) = List_all_comb_b2_cent(3,i_1s) B_center(3) = List_env1s_cent(3,i_1s)
int_mu = NAI_pol_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r) 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) int_coulomb = NAI_pol_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r)
@ -74,7 +75,7 @@ BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_po
! --- ! ---
v_ij_erf_rk_cst_mu_j1b(j,i,ipoint) = tmp v_ij_erf_rk_cst_mu_env(j,i,ipoint) = tmp
enddo enddo
enddo enddo
enddo enddo
@ -84,22 +85,22 @@ BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_po
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do i = 2, ao_num do i = 2, ao_num
do j = 1, i-1 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) v_ij_erf_rk_cst_mu_env(j,i,ipoint) = v_ij_erf_rk_cst_mu_env(i,j,ipoint)
enddo enddo
enddo enddo
enddo enddo
call wall_time(wall1) call wall_time(wall1)
print*, ' wall time for v_ij_erf_rk_cst_mu_j1b', wall1 - wall0 print*, ' wall time for v_ij_erf_rk_cst_mu_env (min) = ', (wall1 - wall0) / 60.d0
END_PROVIDER END_PROVIDER
! --- ! ---
BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_points_final_grid, 3)] BEGIN_PROVIDER [double precision, x_v_ij_erf_rk_cst_mu_env, (ao_num, ao_num, n_points_final_grid, 3)]
BEGIN_DOC BEGIN_DOC
! int dr x phi_i(r) phi_j(r) 1s_j1b(r) (erf(mu(R) |r - R|) - 1)/|r - R| ! int dr x phi_i(r) phi_j(r) 1s_env(r) (erf(mu(R) |r - R|) - 1)/|r - R|
END_DOC END_DOC
implicit none implicit none
@ -108,17 +109,17 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_
double precision :: tmp_x, tmp_y, tmp_z double precision :: tmp_x, tmp_y, tmp_z
double precision :: wall0, wall1 double precision :: wall0, wall1
print*, ' providing x_v_ij_erf_rk_cst_mu_j1b ...' print*, ' providing x_v_ij_erf_rk_cst_mu_env ...'
call wall_time(wall0) call wall_time(wall0)
x_v_ij_erf_rk_cst_mu_j1b = 0.d0 x_v_ij_erf_rk_cst_mu_env = 0.d0
!$OMP PARALLEL DEFAULT (NONE) & !$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, ints, ints_coulomb, & !$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, ints, ints_coulomb, &
!$OMP tmp_x, tmp_y, tmp_z) & !$OMP tmp_x, tmp_y, tmp_z) &
!$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b2_size, final_grid_points,& !$OMP SHARED (n_points_final_grid, ao_num, List_env1s_size, final_grid_points,&
!$OMP List_all_comb_b2_coef, List_all_comb_b2_expo, List_all_comb_b2_cent, & !$OMP List_env1s_coef, List_env1s_expo, List_env1s_cent, &
!$OMP x_v_ij_erf_rk_cst_mu_j1b, mu_erf) !$OMP x_v_ij_erf_rk_cst_mu_env, mu_erf)
!$OMP DO !$OMP DO
!do ipoint = 1, 10 !do ipoint = 1, 10
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
@ -135,11 +136,11 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_
! --- ! ---
coef = List_all_comb_b2_coef (1) coef = List_env1s_coef (1)
beta = List_all_comb_b2_expo (1) beta = List_env1s_expo (1)
B_center(1) = List_all_comb_b2_cent(1,1) B_center(1) = List_env1s_cent(1,1)
B_center(2) = List_all_comb_b2_cent(2,1) B_center(2) = List_env1s_cent(2,1)
B_center(3) = List_all_comb_b2_cent(3,1) B_center(3) = List_env1s_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, mu_erf, r, ints )
call NAI_pol_x_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r, ints_coulomb) call NAI_pol_x_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r, ints_coulomb)
@ -152,14 +153,14 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_
! --- ! ---
do i_1s = 2, List_all_comb_b2_size do i_1s = 2, List_env1s_size
coef = List_all_comb_b2_coef (i_1s) coef = List_env1s_coef (i_1s)
if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0 if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0
beta = List_all_comb_b2_expo (i_1s) beta = List_env1s_expo (i_1s)
B_center(1) = List_all_comb_b2_cent(1,i_1s) B_center(1) = List_env1s_cent(1,i_1s)
B_center(2) = List_all_comb_b2_cent(2,i_1s) B_center(2) = List_env1s_cent(2,i_1s)
B_center(3) = List_all_comb_b2_cent(3,i_1s) B_center(3) = List_env1s_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, mu_erf, r, ints )
call NAI_pol_x_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r, ints_coulomb) call NAI_pol_x_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r, ints_coulomb)
@ -171,9 +172,9 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_
! --- ! ---
x_v_ij_erf_rk_cst_mu_j1b(j,i,ipoint,1) = tmp_x x_v_ij_erf_rk_cst_mu_env(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_env(j,i,ipoint,2) = tmp_y
x_v_ij_erf_rk_cst_mu_j1b(j,i,ipoint,3) = tmp_z x_v_ij_erf_rk_cst_mu_env(j,i,ipoint,3) = tmp_z
enddo enddo
enddo enddo
enddo enddo
@ -183,25 +184,25 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do i = 2, ao_num do i = 2, ao_num
do j = 1, i-1 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_env(j,i,ipoint,1) = x_v_ij_erf_rk_cst_mu_env(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_env(j,i,ipoint,2) = x_v_ij_erf_rk_cst_mu_env(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) x_v_ij_erf_rk_cst_mu_env(j,i,ipoint,3) = x_v_ij_erf_rk_cst_mu_env(i,j,ipoint,3)
enddo enddo
enddo enddo
enddo enddo
call wall_time(wall1) call wall_time(wall1)
print*, ' wall time for x_v_ij_erf_rk_cst_mu_j1b =', wall1 - wall0 print*, ' wall time for x_v_ij_erf_rk_cst_mu_env (min) =', (wall1 - wall0) / 60.d0
END_PROVIDER END_PROVIDER
! --- ! ---
BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_fit, (ao_num, ao_num, n_points_final_grid)] BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_env_fit, (ao_num, ao_num, n_points_final_grid)]
BEGIN_DOC BEGIN_DOC
! !
! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2) u(mu, r12) ! int dr2 phi_i(r2) phi_j(r2) 1s_env(r2) u(mu, r12)
! !
END_DOC END_DOC
@ -214,23 +215,23 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_fit, (ao_num, ao_num, n_poi
double precision, external :: overlap_gauss_r12_ao_with1s double precision, external :: overlap_gauss_r12_ao_with1s
print*, ' providing v_ij_u_cst_mu_j1b_fit ...' print*, ' providing v_ij_u_cst_mu_env_fit ...'
call wall_time(wall0) call wall_time(wall0)
provide mu_erf final_grid_points j1b_pen provide mu_erf final_grid_points env_expo
PROVIDE ng_fit_jast expo_gauss_j_mu_x coef_gauss_j_mu_x PROVIDE ng_fit_jast expo_gauss_j_mu_x coef_gauss_j_mu_x
PROVIDE List_all_comb_b2_size List_all_comb_b2_coef List_all_comb_b2_expo List_all_comb_b2_cent PROVIDE List_env1s_size List_env1s_coef List_env1s_expo List_env1s_cent
v_ij_u_cst_mu_j1b_fit = 0.d0 v_ij_u_cst_mu_env_fit = 0.d0
!$OMP PARALLEL DEFAULT (NONE) & !$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, & !$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, &
!$OMP coef_fit, expo_fit, int_fit, tmp) & !$OMP coef_fit, expo_fit, int_fit, tmp) &
!$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b2_size, & !$OMP SHARED (n_points_final_grid, ao_num, List_env1s_size, &
!$OMP final_grid_points, ng_fit_jast, & !$OMP final_grid_points, ng_fit_jast, &
!$OMP expo_gauss_j_mu_x, coef_gauss_j_mu_x, & !$OMP expo_gauss_j_mu_x, coef_gauss_j_mu_x, &
!$OMP List_all_comb_b2_coef, List_all_comb_b2_expo, & !$OMP List_env1s_coef, List_env1s_expo, &
!$OMP List_all_comb_b2_cent, v_ij_u_cst_mu_j1b_fit) !$OMP List_env1s_cent, v_ij_u_cst_mu_env_fit)
!$OMP DO !$OMP DO
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
r(1) = final_grid_points(1,ipoint) r(1) = final_grid_points(1,ipoint)
@ -247,11 +248,11 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_fit, (ao_num, ao_num, n_poi
! --- ! ---
coef = List_all_comb_b2_coef (1) coef = List_env1s_coef (1)
beta = List_all_comb_b2_expo (1) beta = List_env1s_expo (1)
B_center(1) = List_all_comb_b2_cent(1,1) B_center(1) = List_env1s_cent(1,1)
B_center(2) = List_all_comb_b2_cent(2,1) B_center(2) = List_env1s_cent(2,1)
B_center(3) = List_all_comb_b2_cent(3,1) B_center(3) = List_env1s_cent(3,1)
int_fit = overlap_gauss_r12_ao_with1s(B_center, beta, r, expo_fit, i, j) int_fit = overlap_gauss_r12_ao_with1s(B_center, beta, r, expo_fit, i, j)
@ -259,14 +260,14 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_fit, (ao_num, ao_num, n_poi
! --- ! ---
do i_1s = 2, List_all_comb_b2_size do i_1s = 2, List_env1s_size
coef = List_all_comb_b2_coef (i_1s) coef = List_env1s_coef (i_1s)
if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0 if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0
beta = List_all_comb_b2_expo (i_1s) beta = List_env1s_expo (i_1s)
B_center(1) = List_all_comb_b2_cent(1,i_1s) B_center(1) = List_env1s_cent(1,i_1s)
B_center(2) = List_all_comb_b2_cent(2,i_1s) B_center(2) = List_env1s_cent(2,i_1s)
B_center(3) = List_all_comb_b2_cent(3,i_1s) B_center(3) = List_env1s_cent(3,i_1s)
int_fit = overlap_gauss_r12_ao_with1s(B_center, beta, r, expo_fit, i, j) int_fit = overlap_gauss_r12_ao_with1s(B_center, beta, r, expo_fit, i, j)
@ -277,7 +278,7 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_fit, (ao_num, ao_num, n_poi
enddo enddo
v_ij_u_cst_mu_j1b_fit(j,i,ipoint) = tmp v_ij_u_cst_mu_env_fit(j,i,ipoint) = tmp
enddo enddo
enddo enddo
enddo enddo
@ -287,23 +288,23 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_fit, (ao_num, ao_num, n_poi
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do i = 2, ao_num do i = 2, ao_num
do j = 1, i-1 do j = 1, i-1
v_ij_u_cst_mu_j1b_fit(j,i,ipoint) = v_ij_u_cst_mu_j1b_fit(i,j,ipoint) v_ij_u_cst_mu_env_fit(j,i,ipoint) = v_ij_u_cst_mu_env_fit(i,j,ipoint)
enddo enddo
enddo enddo
enddo enddo
call wall_time(wall1) call wall_time(wall1)
print*, ' wall time for v_ij_u_cst_mu_j1b_fit', wall1 - wall0 print*, ' wall time for v_ij_u_cst_mu_env_fit (min) = ', (wall1 - wall0) / 60.d0
END_PROVIDER END_PROVIDER
! --- ! ---
BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_j1b_an_old, (ao_num, ao_num, n_points_final_grid)] BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_env_an_old, (ao_num, ao_num, n_points_final_grid)]
BEGIN_DOC BEGIN_DOC
! !
! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2) u(mu, r12) ! int dr2 phi_i(r2) phi_j(r2) 1s_env(r2) u(mu, r12)
! !
END_DOC END_DOC
@ -322,24 +323,24 @@ BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_j1b_an_old, (ao_num, ao_num, n_p
double precision, external :: overlap_gauss_r12_ao_with1s double precision, external :: overlap_gauss_r12_ao_with1s
double precision, external :: NAI_pol_mult_erf_ao_with1s double precision, external :: NAI_pol_mult_erf_ao_with1s
print*, ' providing v_ij_u_cst_mu_j1b_an_old ...' print*, ' providing v_ij_u_cst_mu_env_an_old ...'
call wall_time(wall0) call wall_time(wall0)
provide mu_erf final_grid_points j1b_pen provide mu_erf final_grid_points env_expo
PROVIDE List_all_comb_b2_size List_all_comb_b2_coef List_all_comb_b2_expo List_all_comb_b2_cent PROVIDE List_env1s_size List_env1s_coef List_env1s_expo List_env1s_cent
ct = inv_sq_pi_2 / mu_erf ct = inv_sq_pi_2 / mu_erf
v_ij_u_cst_mu_j1b_an_old = 0.d0 v_ij_u_cst_mu_env_an_old = 0.d0
!$OMP PARALLEL DEFAULT (NONE) & !$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, & !$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, &
!$OMP r1_2, tmp, int_c1, int_e1, int_o, int_c2, & !$OMP r1_2, tmp, int_c1, int_e1, int_o, int_c2, &
!$OMP int_e2, int_c3, int_e3) & !$OMP int_e2, int_c3, int_e3) &
!$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b2_size, & !$OMP SHARED (n_points_final_grid, ao_num, List_env1s_size, &
!$OMP final_grid_points, mu_erf, ct, & !$OMP final_grid_points, mu_erf, ct, &
!$OMP List_all_comb_b2_coef, List_all_comb_b2_expo, & !$OMP List_env1s_coef, List_env1s_expo, &
!$OMP List_all_comb_b2_cent, v_ij_u_cst_mu_j1b_an_old) !$OMP List_env1s_cent, v_ij_u_cst_mu_env_an_old)
!$OMP DO !$OMP DO
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
@ -353,11 +354,11 @@ BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_j1b_an_old, (ao_num, ao_num, n_p
! --- ! ---
coef = List_all_comb_b2_coef (1) coef = List_env1s_coef (1)
beta = List_all_comb_b2_expo (1) beta = List_env1s_expo (1)
B_center(1) = List_all_comb_b2_cent(1,1) B_center(1) = List_env1s_cent(1,1)
B_center(2) = List_all_comb_b2_cent(2,1) B_center(2) = List_env1s_cent(2,1)
B_center(3) = List_all_comb_b2_cent(3,1) B_center(3) = List_env1s_cent(3,1)
int_c1 = NAI_pol_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r) int_c1 = NAI_pol_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r)
int_e1 = NAI_pol_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r) int_e1 = NAI_pol_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r)
@ -379,14 +380,14 @@ BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_j1b_an_old, (ao_num, ao_num, n_p
! --- ! ---
do i_1s = 2, List_all_comb_b2_size do i_1s = 2, List_env1s_size
coef = List_all_comb_b2_coef (i_1s) coef = List_env1s_coef (i_1s)
if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0 if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0
beta = List_all_comb_b2_expo (i_1s) beta = List_env1s_expo (i_1s)
B_center(1) = List_all_comb_b2_cent(1,i_1s) B_center(1) = List_env1s_cent(1,i_1s)
B_center(2) = List_all_comb_b2_cent(2,i_1s) B_center(2) = List_env1s_cent(2,i_1s)
B_center(3) = List_all_comb_b2_cent(3,i_1s) B_center(3) = List_env1s_cent(3,i_1s)
int_c1 = NAI_pol_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r) int_c1 = NAI_pol_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r)
int_e1 = NAI_pol_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r) int_e1 = NAI_pol_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r)
@ -410,7 +411,7 @@ BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_j1b_an_old, (ao_num, ao_num, n_p
! --- ! ---
v_ij_u_cst_mu_j1b_an_old(j,i,ipoint) = tmp v_ij_u_cst_mu_env_an_old(j,i,ipoint) = tmp
enddo enddo
enddo enddo
enddo enddo
@ -420,23 +421,23 @@ BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_j1b_an_old, (ao_num, ao_num, n_p
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do i = 2, ao_num do i = 2, ao_num
do j = 1, i-1 do j = 1, i-1
v_ij_u_cst_mu_j1b_an_old(j,i,ipoint) = v_ij_u_cst_mu_j1b_an_old(i,j,ipoint) v_ij_u_cst_mu_env_an_old(j,i,ipoint) = v_ij_u_cst_mu_env_an_old(i,j,ipoint)
enddo enddo
enddo enddo
enddo enddo
call wall_time(wall1) call wall_time(wall1)
print*, ' wall time for v_ij_u_cst_mu_j1b_an_old', wall1 - wall0 print*, ' wall time for v_ij_u_cst_mu_env_an_old (min) = ', (wall1 - wall0) / 60.d0
END_PROVIDER END_PROVIDER
! --- ! ---
BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_points_final_grid)] BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_env_an, (ao_num, ao_num, n_points_final_grid)]
BEGIN_DOC BEGIN_DOC
! !
! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2) u(mu, r12) ! int dr2 phi_i(r2) phi_j(r2) 1s_env(r2) u(mu, r12)
! !
END_DOC END_DOC
@ -454,23 +455,23 @@ BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_point
double precision, external :: overlap_gauss_r12_ao_with1s double precision, external :: overlap_gauss_r12_ao_with1s
double precision, external :: NAI_pol_mult_erf_ao_with1s double precision, external :: NAI_pol_mult_erf_ao_with1s
print*, ' providing v_ij_u_cst_mu_j1b_an ...' print*, ' providing v_ij_u_cst_mu_env_an ...'
call wall_time(wall0) call wall_time(wall0)
provide mu_erf final_grid_points j1b_pen provide mu_erf final_grid_points env_expo
PROVIDE List_all_comb_b2_size List_all_comb_b2_coef List_all_comb_b2_expo List_all_comb_b2_cent PROVIDE List_env1s_size List_env1s_coef List_env1s_expo List_env1s_cent
ct = inv_sq_pi_2 / mu_erf ct = inv_sq_pi_2 / mu_erf
v_ij_u_cst_mu_j1b_an = 0.d0 v_ij_u_cst_mu_env_an = 0.d0
!$OMP PARALLEL DEFAULT (NONE) & !$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, & !$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, &
!$OMP r1_2, tmp, int_c, int_e, int_o) & !$OMP r1_2, tmp, int_c, int_e, int_o) &
!$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b2_size, & !$OMP SHARED (n_points_final_grid, ao_num, List_env1s_size, &
!$OMP final_grid_points, mu_erf, ct, & !$OMP final_grid_points, mu_erf, ct, &
!$OMP List_all_comb_b2_coef, List_all_comb_b2_expo, & !$OMP List_env1s_coef, List_env1s_expo, &
!$OMP List_all_comb_b2_cent, v_ij_u_cst_mu_j1b_an) !$OMP List_env1s_cent, v_ij_u_cst_mu_env_an)
!$OMP DO !$OMP DO
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
@ -484,11 +485,11 @@ BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_point
! --- ! ---
coef = List_all_comb_b2_coef (1) coef = List_env1s_coef (1)
beta = List_all_comb_b2_expo (1) beta = List_env1s_expo (1)
B_center(1) = List_all_comb_b2_cent(1,1) B_center(1) = List_env1s_cent(1,1)
B_center(2) = List_all_comb_b2_cent(2,1) B_center(2) = List_env1s_cent(2,1)
B_center(3) = List_all_comb_b2_cent(3,1) B_center(3) = List_env1s_cent(3,1)
call NAI_pol_012_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r, int_c) call NAI_pol_012_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r, int_c)
call NAI_pol_012_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r, int_e) call NAI_pol_012_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r, int_e)
@ -504,14 +505,14 @@ BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_point
! --- ! ---
do i_1s = 2, List_all_comb_b2_size do i_1s = 2, List_env1s_size
coef = List_all_comb_b2_coef (i_1s) coef = List_env1s_coef (i_1s)
if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0 if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0
beta = List_all_comb_b2_expo (i_1s) beta = List_env1s_expo (i_1s)
B_center(1) = List_all_comb_b2_cent(1,i_1s) B_center(1) = List_env1s_cent(1,i_1s)
B_center(2) = List_all_comb_b2_cent(2,i_1s) B_center(2) = List_env1s_cent(2,i_1s)
B_center(3) = List_all_comb_b2_cent(3,i_1s) B_center(3) = List_env1s_cent(3,i_1s)
call NAI_pol_012_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r, int_c) call NAI_pol_012_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r, int_c)
call NAI_pol_012_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r, int_e) call NAI_pol_012_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r, int_e)
@ -529,7 +530,7 @@ BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_point
! --- ! ---
v_ij_u_cst_mu_j1b_an(j,i,ipoint) = tmp v_ij_u_cst_mu_env_an(j,i,ipoint) = tmp
enddo enddo
enddo enddo
enddo enddo
@ -539,13 +540,13 @@ BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_point
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do i = 2, ao_num do i = 2, ao_num
do j = 1, i-1 do j = 1, i-1
v_ij_u_cst_mu_j1b_an(j,i,ipoint) = v_ij_u_cst_mu_j1b_an(i,j,ipoint) v_ij_u_cst_mu_env_an(j,i,ipoint) = v_ij_u_cst_mu_env_an(i,j,ipoint)
enddo enddo
enddo enddo
enddo enddo
call wall_time(wall1) call wall_time(wall1)
print*, ' wall time for v_ij_u_cst_mu_j1b_an', wall1 - wall0 print*, ' wall time for v_ij_u_cst_mu_env_an (min) = ', (wall1 - wall0) / 60.d0
END_PROVIDER END_PROVIDER

574
plugins/local/ao_many_one_e_ints/lin_fc_rsdft.irp.f Normal file
View File

@ -0,0 +1,574 @@
! ---
BEGIN_PROVIDER [double precision, Ir2_Mu_long_Du_0, (ao_num, ao_num, n_points_final_grid)]
&BEGIN_PROVIDER [double precision, Ir2_Mu_long_Du_x, (ao_num, ao_num, n_points_final_grid)]
&BEGIN_PROVIDER [double precision, Ir2_Mu_long_Du_y, (ao_num, ao_num, n_points_final_grid)]
&BEGIN_PROVIDER [double precision, Ir2_Mu_long_Du_z, (ao_num, ao_num, n_points_final_grid)]
&BEGIN_PROVIDER [double precision, Ir2_Mu_long_Du_2, (ao_num, ao_num, n_points_final_grid)]
BEGIN_DOC
!
! Ir2_Mu_long_Du_0 = int dr2 phi_i(r2) phi_j(r2) fc_env(r2) [(1 - erf(mu r_12) / r_12]
!
! Ir2_Mu_long_Du_x = int dr2 phi_i(r2) phi_j(r2) fc_env(r2) [(1 - erf(mu r_12) / r_12] * x2
! Ir2_Mu_long_Du_y = int dr2 phi_i(r2) phi_j(r2) fc_env(r2) [(1 - erf(mu r_12) / r_12] * y2
! Ir2_Mu_long_Du_z = int dr2 phi_i(r2) phi_j(r2) fc_env(r2) [(1 - erf(mu r_12) / r_12] * z2
!
! Ir2_Mu_long_Du_2 = int dr2 phi_i(r2) phi_j(r2) fc_env(r2) [(1 - erf(mu r_12) / r_12] * r2^2
!
END_DOC
implicit none
integer :: i, j, ipoint, i_1s
double precision :: r(3), int_clb(7), int_erf(7)
double precision :: c_1s, e_1s, R_1s(3)
double precision :: tmp_Du_0, tmp_Du_x, tmp_Du_y, tmp_Du_z, tmp_Du_2
double precision :: wall0, wall1
PROVIDE mu_erf
PROVIDE final_grid_points
PROVIDE List_env1s_size List_env1s_expo List_env1s_coef List_env1s_cent
print *, ' providing Ir2_Mu_long_Du ...'
call wall_time(wall0)
!$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_1s, r, c_1s, e_1s, R_1s, int_erf, int_clb, &
!$OMP tmp_Du_0, tmp_Du_x, tmp_Du_y, tmp_Du_z, tmp_Du_2) &
!$OMP SHARED (n_points_final_grid, ao_num, final_grid_points, mu_erf, &
!$OMP List_env1s_size, List_env1s_expo, &
!$OMP List_env1s_coef, List_env1s_cent, &
!$OMP Ir2_Mu_long_Du_0, Ir2_Mu_long_Du_x, &
!$OMP Ir2_Mu_long_Du_y, Ir2_Mu_long_Du_z, &
!$OMP Ir2_Mu_long_Du_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
call NAI_pol_012_mult_erf_ao(i, j, 1.d+9, r, int_clb)
call NAI_pol_012_mult_erf_ao(i, j, mu_erf, r, int_erf)
tmp_Du_0 = int_clb(1) - int_erf(1)
tmp_Du_x = int_clb(2) - int_erf(2)
tmp_Du_y = int_clb(3) - int_erf(3)
tmp_Du_z = int_clb(4) - int_erf(4)
tmp_Du_2 = int_clb(5) + int_clb(6) + int_clb(7) - int_erf(5) - int_erf(6) - int_erf(7)
do i_1s = 2, List_env1s_size
e_1s = List_env1s_expo(i_1s)
c_1s = List_env1s_coef(i_1s)
R_1s(1) = List_env1s_cent(1,i_1s)
R_1s(2) = List_env1s_cent(2,i_1s)
R_1s(3) = List_env1s_cent(3,i_1s)
call NAI_pol_012_mult_erf_ao_with1s(i, j, e_1s, R_1s, 1.d+9, r, int_clb)
call NAI_pol_012_mult_erf_ao_with1s(i, j, e_1s, R_1s, mu_erf, r, int_erf)
tmp_Du_0 = tmp_Du_0 + c_1s * (int_clb(1) - int_erf(1))
tmp_Du_x = tmp_Du_x + c_1s * (int_clb(2) - int_erf(2))
tmp_Du_y = tmp_Du_y + c_1s * (int_clb(3) - int_erf(3))
tmp_Du_z = tmp_Du_z + c_1s * (int_clb(4) - int_erf(4))
tmp_Du_2 = tmp_Du_2 + c_1s * (int_clb(5) + int_clb(6) + int_clb(7) - int_erf(5) - int_erf(6) - int_erf(7))
enddo
Ir2_Mu_long_Du_0(j,i,ipoint) = tmp_Du_0
Ir2_Mu_long_Du_x(j,i,ipoint) = tmp_Du_x
Ir2_Mu_long_Du_y(j,i,ipoint) = tmp_Du_y
Ir2_Mu_long_Du_z(j,i,ipoint) = tmp_Du_z
Ir2_Mu_long_Du_2(j,i,ipoint) = tmp_Du_2
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
Ir2_Mu_long_Du_0(j,i,ipoint) = Ir2_Mu_long_Du_0(i,j,ipoint)
Ir2_Mu_long_Du_x(j,i,ipoint) = Ir2_Mu_long_Du_x(i,j,ipoint)
Ir2_Mu_long_Du_y(j,i,ipoint) = Ir2_Mu_long_Du_y(i,j,ipoint)
Ir2_Mu_long_Du_z(j,i,ipoint) = Ir2_Mu_long_Du_z(i,j,ipoint)
Ir2_Mu_long_Du_2(j,i,ipoint) = Ir2_Mu_long_Du_2(i,j,ipoint)
enddo
enddo
enddo
call wall_time(wall1)
print*, ' wall time for Ir2_Mu_long_Du (min) = ', (wall1 - wall0) / 60.d0
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, Ir2_Mu_gauss_Du, (ao_num, ao_num, n_points_final_grid)]
BEGIN_DOC
!
! Ir2_Mu_gauss_Du = int dr2 phi_i(r2) phi_j(r2) fc_env(r2) e^{-(mu r_12)^2}
!
END_DOC
implicit none
integer :: i, j, ipoint, i_1s
double precision :: r(3)
double precision :: coef, beta, B_center(3)
double precision :: tmp_Du
double precision :: mu_sq, dx, dy, dz, tmp_arg, rmu_sq(3)
double precision :: e_1s, c_1s, R_1s(3)
double precision :: wall0, wall1
double precision, external :: overlap_gauss_r12_ao
PROVIDE mu_erf
PROVIDE final_grid_points
PROVIDE List_env1s_size List_env1s_expo List_env1s_coef List_env1s_cent
print *, ' providing Ir2_Mu_gauss_Du ...'
call wall_time(wall0)
mu_sq = mu_erf * mu_erf
!$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_1s, dx, dy, dz, r, tmp_arg, coef, &
!$OMP rmu_sq, e_1s, c_1s, R_1s, beta, B_center, tmp_Du) &
!$OMP SHARED (n_points_final_grid, ao_num, final_grid_points, mu_sq, &
!$OMP List_env1s_size, List_env1s_expo, &
!$OMP List_env1s_coef, List_env1s_cent, &
!$OMP Ir2_Mu_gauss_Du)
!$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)
rmu_sq(1) = mu_sq * r(1)
rmu_sq(2) = mu_sq * r(2)
rmu_sq(3) = mu_sq * r(3)
do i = 1, ao_num
do j = i, ao_num
tmp_Du = overlap_gauss_r12_ao(r, mu_sq, j, i)
do i_1s = 2, List_env1s_size
e_1s = List_env1s_expo(i_1s)
c_1s = List_env1s_coef(i_1s)
R_1s(1) = List_env1s_cent(1,i_1s)
R_1s(2) = List_env1s_cent(2,i_1s)
R_1s(3) = List_env1s_cent(3,i_1s)
dx = r(1) - R_1s(1)
dy = r(2) - R_1s(2)
dz = r(3) - R_1s(3)
beta = mu_sq + e_1s
tmp_arg = mu_sq * e_1s * (dx*dx + dy*dy + dz*dz) / beta
coef = c_1s * dexp(-tmp_arg)
B_center(1) = (rmu_sq(1) + e_1s * R_1s(1)) / beta
B_center(2) = (rmu_sq(2) + e_1s * R_1s(2)) / beta
B_center(3) = (rmu_sq(3) + e_1s * R_1s(3)) / beta
tmp_Du += coef * overlap_gauss_r12_ao(B_center, beta, j, i)
enddo
Ir2_Mu_gauss_Du(j,i,ipoint) = tmp_Du
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
Ir2_Mu_gauss_Du(j,i,ipoint) = Ir2_Mu_gauss_Du(i,j,ipoint)
enddo
enddo
enddo
call wall_time(wall1)
print*, ' wall time for Ir2_Mu_gauss_Du (min) = ', (wall1 - wall0) / 60.d0
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, Ir2_Mu_long_Du2_0, (ao_num, ao_num, n_points_final_grid)]
&BEGIN_PROVIDER [double precision, Ir2_Mu_long_Du2_x, (ao_num, ao_num, n_points_final_grid)]
&BEGIN_PROVIDER [double precision, Ir2_Mu_long_Du2_y, (ao_num, ao_num, n_points_final_grid)]
&BEGIN_PROVIDER [double precision, Ir2_Mu_long_Du2_z, (ao_num, ao_num, n_points_final_grid)]
&BEGIN_PROVIDER [double precision, Ir2_Mu_long_Du2_2, (ao_num, ao_num, n_points_final_grid)]
BEGIN_DOC
!
! Ir2_Mu_long_Du2_0 = int dr2 phi_i(r2) phi_j(r2) [fc_env(r2)]^2 [(1 - erf(mu r_12) / r_12]
!
! Ir2_Mu_long_Du2_x = int dr2 phi_i(r2) phi_j(r2) [fc_env(r2)]^2 [(1 - erf(mu r_12) / r_12] * x2
! Ir2_Mu_long_Du2_y = int dr2 phi_i(r2) phi_j(r2) [fc_env(r2)]^2 [(1 - erf(mu r_12) / r_12] * y2
! Ir2_Mu_long_Du2_z = int dr2 phi_i(r2) phi_j(r2) [fc_env(r2)]^2 [(1 - erf(mu r_12) / r_12] * z2
!
! Ir2_Mu_long_Du2_2 = int dr2 phi_i(r2) phi_j(r2) [fc_env(r2)]^2 [(1 - erf(mu r_12) / r_12] * r2^2
!
END_DOC
implicit none
integer :: i, j, ipoint, i_1s
double precision :: r(3), int_clb(7), int_erf(7)
double precision :: coef, beta, B_center(3)
double precision :: tmp_Du2_0, tmp_Du2_x, tmp_Du2_y, tmp_Du2_z, tmp_Du2_2
double precision :: mu_sq, tmp_arg, dx, dy, dz, rmu_sq(3)
double precision :: e_1s, c_1s, R_1s(3)
double precision :: wall0, wall1
PROVIDE mu_erf
PROVIDE final_grid_points
PROVIDE List_env1s_square_size List_env1s_square_expo List_env1s_square_coef List_env1s_square_cent
print *, ' providing Ir2_Mu_long_Du2 ...'
call wall_time(wall0)
mu_sq = mu_erf * mu_erf
!$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_1s, r, rmu_sq, dx, dy, dz, &
!$OMP e_1s, c_1s, R_1s, tmp_arg, coef, beta, B_center, &
!$OMP int_erf, int_clb, &
!$OMP tmp_Du2_0, tmp_Du2_x, tmp_Du2_y, tmp_Du2_z, tmp_Du2_2) &
!$OMP SHARED (n_points_final_grid, ao_num, final_grid_points, mu_sq, &
!$OMP mu_erf, List_env1s_square_size, List_env1s_square_expo, &
!$OMP List_env1s_square_coef, List_env1s_square_cent, &
!$OMP Ir2_Mu_long_Du2_0, Ir2_Mu_long_Du2_x, &
!$OMP Ir2_Mu_long_Du2_y, Ir2_Mu_long_Du2_z, &
!$OMP Ir2_Mu_long_Du2_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)
rmu_sq(1) = mu_sq * r(1)
rmu_sq(2) = mu_sq * r(2)
rmu_sq(3) = mu_sq * r(3)
do i = 1, ao_num
do j = i, ao_num
call NAI_pol_012_mult_erf_ao_with1s(i, j, mu_sq, r, 1.d+9, r, int_clb)
call NAI_pol_012_mult_erf_ao_with1s(i, j, mu_sq, r, mu_erf, r, int_erf)
tmp_Du2_0 = int_clb(1) - int_erf(1)
tmp_Du2_x = int_clb(2) - int_erf(2)
tmp_Du2_y = int_clb(3) - int_erf(3)
tmp_Du2_z = int_clb(4) - int_erf(4)
tmp_Du2_2 = int_clb(5) + int_clb(6) + int_clb(7) - int_erf(5) - int_erf(6) - int_erf(7)
do i_1s = 2, List_env1s_square_size
e_1s = List_env1s_square_expo(i_1s)
c_1s = List_env1s_square_coef(i_1s)
R_1s(1) = List_env1s_square_cent(1,i_1s)
R_1s(2) = List_env1s_square_cent(2,i_1s)
R_1s(3) = List_env1s_square_cent(3,i_1s)
dx = r(1) - R_1s(1)
dy = r(2) - R_1s(2)
dz = r(3) - R_1s(3)
beta = mu_sq + e_1s
tmp_arg = mu_sq * e_1s * (dx*dx + dy*dy + dz*dz) / beta
coef = c_1s * dexp(-tmp_arg)
B_center(1) = (rmu_sq(1) + e_1s * R_1s(1)) / beta
B_center(2) = (rmu_sq(2) + e_1s * R_1s(2)) / beta
B_center(3) = (rmu_sq(3) + e_1s * R_1s(3)) / beta
call NAI_pol_012_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r, int_clb)
call NAI_pol_012_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r, int_erf)
tmp_Du2_0 = tmp_Du2_0 + coef * (int_clb(1) - int_erf(1))
tmp_Du2_x = tmp_Du2_x + coef * (int_clb(2) - int_erf(2))
tmp_Du2_y = tmp_Du2_y + coef * (int_clb(3) - int_erf(3))
tmp_Du2_z = tmp_Du2_z + coef * (int_clb(4) - int_erf(4))
tmp_Du2_2 = tmp_Du2_2 + coef * (int_clb(5) + int_clb(6) + int_clb(7) - int_erf(5) - int_erf(6) - int_erf(7))
enddo
Ir2_Mu_long_Du2_0(j,i,ipoint) = tmp_Du2_0
Ir2_Mu_long_Du2_x(j,i,ipoint) = tmp_Du2_x
Ir2_Mu_long_Du2_y(j,i,ipoint) = tmp_Du2_y
Ir2_Mu_long_Du2_z(j,i,ipoint) = tmp_Du2_z
Ir2_Mu_long_Du2_2(j,i,ipoint) = tmp_Du2_2
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
Ir2_Mu_long_Du2_0(j,i,ipoint) = Ir2_Mu_long_Du2_0(i,j,ipoint)
Ir2_Mu_long_Du2_x(j,i,ipoint) = Ir2_Mu_long_Du2_x(i,j,ipoint)
Ir2_Mu_long_Du2_y(j,i,ipoint) = Ir2_Mu_long_Du2_y(i,j,ipoint)
Ir2_Mu_long_Du2_z(j,i,ipoint) = Ir2_Mu_long_Du2_z(i,j,ipoint)
Ir2_Mu_long_Du2_2(j,i,ipoint) = Ir2_Mu_long_Du2_2(i,j,ipoint)
enddo
enddo
enddo
call wall_time(wall1)
print*, ' wall time for Ir2_Mu_long_Du2 (min) = ', (wall1 - wall0) / 60.d0
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, Ir2_Mu_gauss_Du2, (ao_num, ao_num, n_points_final_grid)]
BEGIN_DOC
!
! Ir2_Mu_gauss_Du2 = int dr2 phi_i(r2) phi_j(r2) [fc_env(r2)]^2 e^{-(mu r_12)^2}
!
END_DOC
implicit none
integer :: i, j, ipoint, i_1s
double precision :: r(3)
double precision :: coef, beta, B_center(3)
double precision :: tmp_Du2
double precision :: mu_sq, dx, dy, dz, tmp_arg, rmu_sq(3)
double precision :: e_1s, c_1s, R_1s(3)
double precision :: wall0, wall1
double precision, external :: overlap_gauss_r12_ao
PROVIDE mu_erf
PROVIDE final_grid_points
PROVIDE List_env1s_square_size List_env1s_square_expo List_env1s_square_coef List_env1s_square_cent
print *, ' providing Ir2_Mu_gauss_Du2 ...'
call wall_time(wall0)
mu_sq = 2.d0 * mu_erf * mu_erf
!$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_1s, dx, dy, dz, r, tmp_arg, coef, &
!$OMP rmu_sq, e_1s, c_1s, R_1s, beta, B_center, tmp_Du2) &
!$OMP SHARED (n_points_final_grid, ao_num, final_grid_points, mu_sq, &
!$OMP List_env1s_square_size, List_env1s_square_expo, &
!$OMP List_env1s_square_coef, List_env1s_square_cent, &
!$OMP Ir2_Mu_gauss_Du2)
!$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)
rmu_sq(1) = mu_sq * r(1)
rmu_sq(2) = mu_sq * r(2)
rmu_sq(3) = mu_sq * r(3)
do i = 1, ao_num
do j = i, ao_num
tmp_Du2 = overlap_gauss_r12_ao(r, mu_sq, j, i)
do i_1s = 2, List_env1s_square_size
e_1s = List_env1s_square_expo(i_1s)
c_1s = List_env1s_square_coef(i_1s)
R_1s(1) = List_env1s_square_cent(1,i_1s)
R_1s(2) = List_env1s_square_cent(2,i_1s)
R_1s(3) = List_env1s_square_cent(3,i_1s)
dx = r(1) - R_1s(1)
dy = r(2) - R_1s(2)
dz = r(3) - R_1s(3)
beta = mu_sq + e_1s
tmp_arg = mu_sq * e_1s * (dx*dx + dy*dy + dz*dz) / beta
coef = c_1s * dexp(-tmp_arg)
B_center(1) = (rmu_sq(1) + e_1s * R_1s(1)) / beta
B_center(2) = (rmu_sq(2) + e_1s * R_1s(2)) / beta
B_center(3) = (rmu_sq(3) + e_1s * R_1s(3)) / beta
tmp_Du2 += coef * overlap_gauss_r12_ao(B_center, beta, j, i)
enddo
Ir2_Mu_gauss_Du2(j,i,ipoint) = tmp_Du2
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
Ir2_Mu_gauss_Du2(j,i,ipoint) = Ir2_Mu_gauss_Du2(i,j,ipoint)
enddo
enddo
enddo
call wall_time(wall1)
print*, ' wall time for Ir2_Mu_gauss_Du2 (min) = ', (wall1 - wall0) / 60.d0
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, Ir2_Mu_short_Du2_0, (ao_num, ao_num, n_points_final_grid)]
&BEGIN_PROVIDER [double precision, Ir2_Mu_short_Du2_x, (ao_num, ao_num, n_points_final_grid)]
&BEGIN_PROVIDER [double precision, Ir2_Mu_short_Du2_y, (ao_num, ao_num, n_points_final_grid)]
&BEGIN_PROVIDER [double precision, Ir2_Mu_short_Du2_z, (ao_num, ao_num, n_points_final_grid)]
&BEGIN_PROVIDER [double precision, Ir2_Mu_short_Du2_2, (ao_num, ao_num, n_points_final_grid)]
BEGIN_DOC
!
! Ir2_Mu_short_Du2_0 = int dr2 phi_i(r2) phi_j(r2) [fc_env(r2)]^2 [(1 - erf(mu r_12)]^2
!
! Ir2_Mu_short_Du2_x = int dr2 phi_i(r2) phi_j(r2) [fc_env(r2)]^2 [(1 - erf(mu r_12)]^2 * x2
! Ir2_Mu_short_Du2_y = int dr2 phi_i(r2) phi_j(r2) [fc_env(r2)]^2 [(1 - erf(mu r_12)]^2 * y2
! Ir2_Mu_short_Du2_z = int dr2 phi_i(r2) phi_j(r2) [fc_env(r2)]^2 [(1 - erf(mu r_12)]^2 * z2
!
! Ir2_Mu_short_Du2_2 = int dr2 phi_i(r2) phi_j(r2) [fc_env(r2)]^2 [(1 - erf(mu r_12)]^2 * r2^2
!
END_DOC
implicit none
integer :: i, j, ipoint, i_1s, i_fit
double precision :: r(3), ints(7)
double precision :: coef, beta, B_center(3)
double precision :: tmp_Du2_0, tmp_Du2_x, tmp_Du2_y, tmp_Du2_z, tmp_Du2_2
double precision :: tmp_arg, dx, dy, dz
double precision :: expo_fit, coef_fit, e_1s, c_1s, R_1s(3)
double precision :: wall0, wall1
PROVIDE final_grid_points
PROVIDE List_env1s_square_size List_env1s_square_expo List_env1s_square_coef List_env1s_square_cent
PROVIDE ng_fit_jast expo_gauss_1_erf_x_2 coef_gauss_1_erf_x_2
print *, ' providing Ir2_Mu_short_Du2 ...'
call wall_time(wall0)
!$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, dx, dy, dz, &
!$OMP expo_fit, coef_fit, e_1s, c_1s, R_1s, &
!$OMP tmp_arg, coef, beta, B_center, ints, &
!$OMP tmp_Du2_0, tmp_Du2_x, tmp_Du2_y, tmp_Du2_z, tmp_Du2_2) &
!$OMP SHARED (n_points_final_grid, ao_num, final_grid_points, &
!$OMP ng_fit_jast, expo_gauss_1_erf_x_2, coef_gauss_1_erf_x_2, &
!$OMP List_env1s_square_size, List_env1s_square_expo, &
!$OMP List_env1s_square_coef, List_env1s_square_cent, &
!$OMP Ir2_Mu_short_Du2_0, Ir2_Mu_short_Du2_x, &
!$OMP Ir2_Mu_short_Du2_y, Ir2_Mu_short_Du2_z, &
!$OMP Ir2_Mu_short_Du2_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_Du2_0 = 0.d0
tmp_Du2_x = 0.d0
tmp_Du2_y = 0.d0
tmp_Du2_z = 0.d0
tmp_Du2_2 = 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)
call overlap_gauss_r12_ao_012(r, expo_fit, i, j, ints)
tmp_Du2_0 += coef_fit * ints(1)
tmp_Du2_x += coef_fit * ints(2)
tmp_Du2_y += coef_fit * ints(3)
tmp_Du2_z += coef_fit * ints(4)
tmp_Du2_2 += coef_fit * (ints(5) + ints(6) + ints(7))
do i_1s = 2, List_env1s_square_size
e_1s = List_env1s_square_expo(i_1s)
c_1s = List_env1s_square_coef(i_1s)
R_1s(1) = List_env1s_square_cent(1,i_1s)
R_1s(2) = List_env1s_square_cent(2,i_1s)
R_1s(3) = List_env1s_square_cent(3,i_1s)
dx = r(1) - R_1s(1)
dy = r(2) - R_1s(2)
dz = r(3) - R_1s(3)
beta = expo_fit + e_1s
tmp_arg = expo_fit * e_1s * (dx*dx + dy*dy + dz*dz) / beta
coef = coef_fit * c_1s * dexp(-tmp_arg)
B_center(1) = (expo_fit * r(1) + e_1s * R_1s(1)) / beta
B_center(2) = (expo_fit * r(2) + e_1s * R_1s(2)) / beta
B_center(3) = (expo_fit * r(3) + e_1s * R_1s(3)) / beta
call overlap_gauss_r12_ao_012(B_center, beta, i, j, ints)
tmp_Du2_0 += coef * ints(1)
tmp_Du2_x += coef * ints(2)
tmp_Du2_y += coef * ints(3)
tmp_Du2_z += coef * ints(4)
tmp_Du2_2 += coef * (ints(5) + ints(6) + ints(7))
enddo ! i_1s
enddo ! i_fit
Ir2_Mu_short_Du2_0(j,i,ipoint) = tmp_Du2_0
Ir2_Mu_short_Du2_x(j,i,ipoint) = tmp_Du2_x
Ir2_Mu_short_Du2_y(j,i,ipoint) = tmp_Du2_y
Ir2_Mu_short_Du2_z(j,i,ipoint) = tmp_Du2_z
Ir2_Mu_short_Du2_2(j,i,ipoint) = tmp_Du2_2
enddo ! j
enddo ! i
enddo ! ipoint
!$OMP END DO
!$OMP END PARALLEL
do ipoint = 1, n_points_final_grid
do i = 2, ao_num
do j = 1, i-1
Ir2_Mu_short_Du2_0(j,i,ipoint) = Ir2_Mu_short_Du2_0(i,j,ipoint)
Ir2_Mu_short_Du2_x(j,i,ipoint) = Ir2_Mu_short_Du2_x(i,j,ipoint)
Ir2_Mu_short_Du2_y(j,i,ipoint) = Ir2_Mu_short_Du2_y(i,j,ipoint)
Ir2_Mu_short_Du2_z(j,i,ipoint) = Ir2_Mu_short_Du2_z(i,j,ipoint)
Ir2_Mu_short_Du2_2(j,i,ipoint) = Ir2_Mu_short_Du2_2(i,j,ipoint)
enddo
enddo
enddo
call wall_time(wall1)
print*, ' wall time for Ir2_Mu_short_Du2 (min) = ', (wall1 - wall0) / 60.d0
END_PROVIDER
! ---

366
plugins/local/ao_many_one_e_ints/listj1b.irp.f
View File

@ -1,366 +0,0 @@
! ---
BEGIN_PROVIDER [integer, List_all_comb_b2_size]
implicit none
PROVIDE j1b_type
if((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then
List_all_comb_b2_size = 2**nucl_num
elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then
List_all_comb_b2_size = nucl_num + 1
else
print *, 'j1b_type = ', j1b_type, 'is not implemented'
stop
endif
print *, ' nb of linear terms in the envelope is ', List_all_comb_b2_size
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
provide j1b_pen_coef
List_all_comb_b2_coef = 0.d0
List_all_comb_b2_expo = 0.d0
List_all_comb_b2_cent = 0.d0
if((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then
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
elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then
List_all_comb_b2_coef( 1) = 1.d0
List_all_comb_b2_expo( 1) = 0.d0
List_all_comb_b2_cent(1:3,1) = 0.d0
do i = 1, nucl_num
List_all_comb_b2_coef( i+1) = -1.d0 * j1b_pen_coef(i)
List_all_comb_b2_expo( i+1) = j1b_pen(i)
List_all_comb_b2_cent(1,i+1) = nucl_coord(i,1)
List_all_comb_b2_cent(2,i+1) = nucl_coord(i,2)
List_all_comb_b2_cent(3,i+1) = nucl_coord(i,3)
enddo
else
print *, 'j1b_type = ', j1b_type, 'is not implemented'
stop
endif
!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
double precision :: tmp
if((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then
List_all_comb_b3_size = 3**nucl_num
elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then
tmp = 0.5d0 * dble(nucl_num) * (dble(nucl_num) + 3.d0)
List_all_comb_b3_size = int(tmp) + 1
else
print *, 'j1b_type = ', j1b_type, 'is not implemented'
stop
endif
print *, ' nb of linear terms in the square of the envelope is ', List_all_comb_b3_size
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
integer :: ii
double precision :: tmp_alphaj, tmp_alphak, facto
double precision :: tmp1, tmp2, tmp3, tmp4
double precision :: xi, yi, zi, xj, yj, zj
double precision :: dx, dy, dz, r2
provide j1b_pen
provide j1b_pen_coef
List_all_comb_b3_coef = 0.d0
List_all_comb_b3_expo = 0.d0
List_all_comb_b3_cent = 0.d0
if((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then
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
elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then
ii = 1
List_all_comb_b3_coef( ii) = 1.d0
List_all_comb_b3_expo( ii) = 0.d0
List_all_comb_b3_cent(1:3,ii) = 0.d0
do i = 1, nucl_num
ii = ii + 1
List_all_comb_b3_coef( ii) = -2.d0 * j1b_pen_coef(i)
List_all_comb_b3_expo( ii) = j1b_pen(i)
List_all_comb_b3_cent(1,ii) = nucl_coord(i,1)
List_all_comb_b3_cent(2,ii) = nucl_coord(i,2)
List_all_comb_b3_cent(3,ii) = nucl_coord(i,3)
enddo
do i = 1, nucl_num
ii = ii + 1
List_all_comb_b3_coef( ii) = 1.d0 * j1b_pen_coef(i) * j1b_pen_coef(i)
List_all_comb_b3_expo( ii) = 2.d0 * j1b_pen(i)
List_all_comb_b3_cent(1,ii) = nucl_coord(i,1)
List_all_comb_b3_cent(2,ii) = nucl_coord(i,2)
List_all_comb_b3_cent(3,ii) = nucl_coord(i,3)
enddo
do i = 1, nucl_num-1
tmp1 = j1b_pen(i)
xi = nucl_coord(i,1)
yi = nucl_coord(i,2)
zi = nucl_coord(i,3)
do j = i+1, nucl_num
tmp2 = j1b_pen(j)
tmp3 = tmp1 + tmp2
tmp4 = 1.d0 / tmp3
xj = nucl_coord(j,1)
yj = nucl_coord(j,2)
zj = nucl_coord(j,3)
dx = xi - xj
dy = yi - yj
dz = zi - zj
r2 = dx*dx + dy*dy + dz*dz
ii = ii + 1
! x 2 to avoid doing integrals twice
List_all_comb_b3_coef( ii) = 2.d0 * dexp(-tmp1*tmp2*tmp4*r2) * j1b_pen_coef(i) * j1b_pen_coef(j)
List_all_comb_b3_expo( ii) = tmp3
List_all_comb_b3_cent(1,ii) = tmp4 * (tmp1 * xi + tmp2 * xj)
List_all_comb_b3_cent(2,ii) = tmp4 * (tmp1 * yi + tmp2 * yj)
List_all_comb_b3_cent(3,ii) = tmp4 * (tmp1 * zi + tmp2 * zj)
enddo
enddo
else
print *, 'j1b_type = ', j1b_type, 'is not implemented'
stop
endif
!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
! ---

346
plugins/local/ao_many_one_e_ints/listj1b_sorted.irp.f
View File

@ -1,181 +1,197 @@
BEGIN_PROVIDER [ integer, List_comb_thr_b2_size, (ao_num, ao_num)] ! ---
&BEGIN_PROVIDER [ integer, max_List_comb_thr_b2_size]
implicit none BEGIN_PROVIDER [integer, List_comb_thr_b2_size, (ao_num, ao_num)]
integer :: i_1s,i,j,ipoint &BEGIN_PROVIDER [integer, max_List_comb_thr_b2_size]
double precision :: coef,beta,center(3),int_j1b
double precision :: r(3),weight,dist implicit none
List_comb_thr_b2_size = 0 integer :: i_1s, i, j, ipoint
print*,'List_all_comb_b2_size = ',List_all_comb_b2_size integer :: list(ao_num)
! pause double precision :: coef,beta,center(3),int_env
do i = 1, ao_num double precision :: r(3),weight,dist
do j = i, ao_num
do i_1s = 1, List_all_comb_b2_size List_comb_thr_b2_size = 0
coef = List_all_comb_b2_coef (i_1s) print*,'List_env1s_size = ',List_env1s_size
if(dabs(coef).lt.thrsh_cycle_tc)cycle
beta = List_all_comb_b2_expo (i_1s) do i = 1, ao_num
beta = max(beta,1.d-12) do j = i, ao_num
center(1:3) = List_all_comb_b2_cent(1:3,i_1s) do i_1s = 1, List_env1s_size
int_j1b = 0.d0 coef = List_env1s_coef(i_1s)
do ipoint = 1, n_points_extra_final_grid if(dabs(coef).lt.thrsh_cycle_tc) cycle
r(1:3) = final_grid_points_extra(1:3,ipoint) beta = List_env1s_expo(i_1s)
weight = final_weight_at_r_vector_extra(ipoint) beta = max(beta,1.d-12)
dist = ( center(1) - r(1) )*( center(1) - r(1) ) center(1:3) = List_env1s_cent(1:3,i_1s)
dist += ( center(2) - r(2) )*( center(2) - r(2) ) int_env = 0.d0
dist += ( center(3) - r(3) )*( center(3) - r(3) ) do ipoint = 1, n_points_extra_final_grid
int_j1b += dabs(aos_in_r_array_extra_transp(ipoint,i) * aos_in_r_array_extra_transp(ipoint,j))*dexp(-beta*dist) * weight r(1:3) = final_grid_points_extra(1:3,ipoint)
enddo weight = final_weight_at_r_vector_extra(ipoint)
if(dabs(coef)*dabs(int_j1b).gt.thrsh_cycle_tc)then dist = ( center(1) - r(1) )*( center(1) - r(1) )
List_comb_thr_b2_size(j,i) += 1 dist += ( center(2) - r(2) )*( center(2) - r(2) )
endif dist += ( center(3) - r(3) )*( center(3) - r(3) )
enddo int_env += dabs(aos_in_r_array_extra_transp(ipoint,i) * aos_in_r_array_extra_transp(ipoint,j))*dexp(-beta*dist) * weight
enddo enddo
enddo if(dabs(coef)*dabs(int_env).gt.thrsh_cycle_tc)then
do i = 1, ao_num List_comb_thr_b2_size(j,i) += 1
do j = 1, i-1 endif
List_comb_thr_b2_size(j,i) = List_comb_thr_b2_size(i,j) enddo
enddo
enddo 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)
print*,'max_List_comb_thr_b2_size = ',max_List_comb_thr_b2_size
END_PROVIDER
BEGIN_PROVIDER [ double precision, List_comb_thr_b2_coef, ( max_List_comb_thr_b2_size,ao_num, ao_num )] do i = 1, ao_num
&BEGIN_PROVIDER [ double precision, List_comb_thr_b2_expo, ( max_List_comb_thr_b2_size,ao_num, ao_num )] do j = 1, i-1
&BEGIN_PROVIDER [ double precision, List_comb_thr_b2_cent, (3, max_List_comb_thr_b2_size,ao_num, ao_num )] List_comb_thr_b2_size(j,i) = List_comb_thr_b2_size(i,j)
&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
double precision :: r(3),weight,dist
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.thrsh_cycle_tc)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.thrsh_cycle_tc)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 enddo
enddo do i = 1, ao_num
list(i) = maxval(List_comb_thr_b2_size(:,i))
enddo
max_List_comb_thr_b2_size = maxval(list)
print*, ' max_List_comb_thr_b2_size = ',max_List_comb_thr_b2_size
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ integer, List_comb_thr_b3_size, (ao_num, ao_num)] BEGIN_PROVIDER [ double precision, List_comb_thr_b2_coef, ( max_List_comb_thr_b2_size,ao_num,ao_num)]
&BEGIN_PROVIDER [ integer, max_List_comb_thr_b3_size] &BEGIN_PROVIDER [ double precision, List_comb_thr_b2_expo, ( max_List_comb_thr_b2_size,ao_num,ao_num)]
implicit none &BEGIN_PROVIDER [ double precision, List_comb_thr_b2_cent, (3,max_List_comb_thr_b2_size,ao_num,ao_num)]
integer :: i_1s,i,j,ipoint &BEGIN_PROVIDER [ double precision, ao_abs_comb_b2_env , ( max_List_comb_thr_b2_size,ao_num,ao_num)]
double precision :: coef,beta,center(3),int_j1b
double precision :: r(3),weight,dist implicit none
List_comb_thr_b3_size = 0 integer :: i_1s,i,j,ipoint,icount
print*,'List_all_comb_b3_size = ',List_all_comb_b3_size double precision :: coef,beta,center(3),int_env
do i = 1, ao_num double precision :: r(3),weight,dist
do j = 1, ao_num
do i_1s = 1, List_all_comb_b3_size ao_abs_comb_b2_env = 10000000.d0
coef = List_all_comb_b3_coef (i_1s) do i = 1, ao_num
beta = List_all_comb_b3_expo (i_1s) do j = i, ao_num
center(1:3) = List_all_comb_b3_cent(1:3,i_1s) icount = 0
if(dabs(coef).lt.thrsh_cycle_tc)cycle do i_1s = 1, List_env1s_size
int_j1b = 0.d0 coef = List_env1s_coef (i_1s)
do ipoint = 1, n_points_extra_final_grid if(dabs(coef).lt.thrsh_cycle_tc)cycle
r(1:3) = final_grid_points_extra(1:3,ipoint) beta = List_env1s_expo (i_1s)
weight = final_weight_at_r_vector_extra(ipoint) center(1:3) = List_env1s_cent(1:3,i_1s)
dist = ( center(1) - r(1) )*( center(1) - r(1) ) int_env = 0.d0
dist += ( center(2) - r(2) )*( center(2) - r(2) ) do ipoint = 1, n_points_extra_final_grid
dist += ( center(3) - r(3) )*( center(3) - r(3) ) r(1:3) = final_grid_points_extra(1:3,ipoint)
int_j1b += dabs(aos_in_r_array_extra_transp(ipoint,i) * aos_in_r_array_extra_transp(ipoint,j))*dexp(-beta*dist) * weight weight = final_weight_at_r_vector_extra(ipoint)
enddo dist = ( center(1) - r(1) )*( center(1) - r(1) )
if(dabs(coef)*dabs(int_j1b).gt.thrsh_cycle_tc)then dist += ( center(2) - r(2) )*( center(2) - r(2) )
List_comb_thr_b3_size(j,i) += 1 dist += ( center(3) - r(3) )*( center(3) - r(3) )
endif int_env += dabs(aos_in_r_array_extra_transp(ipoint,i) * aos_in_r_array_extra_transp(ipoint,j))*dexp(-beta*dist) * weight
enddo enddo
enddo if(dabs(coef)*dabs(int_env).gt.thrsh_cycle_tc)then
enddo icount += 1
! do i = 1, ao_num List_comb_thr_b2_coef(icount,j,i) = coef
! do j = 1, i-1 List_comb_thr_b2_expo(icount,j,i) = beta
! List_comb_thr_b3_size(j,i) = List_comb_thr_b3_size(i,j) List_comb_thr_b2_cent(1:3,icount,j,i) = center(1:3)
! enddo ao_abs_comb_b2_env(icount,j,i) = int_env
! enddo 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
integer :: list(ao_num) integer :: list(ao_num)
do i = 1, ao_num double precision :: coef,beta,center(3),int_env
list(i) = maxval(List_comb_thr_b3_size(:,i)) double precision :: r(3),weight,dist
enddo
max_List_comb_thr_b3_size = maxval(list) List_comb_thr_b3_size = 0
print*,'max_List_comb_thr_b3_size = ',max_List_comb_thr_b3_size print*,'List_env1s_square_size = ',List_env1s_square_size
do i = 1, ao_num
do j = 1, ao_num
do i_1s = 1, List_env1s_square_size
coef = List_env1s_square_coef (i_1s)
beta = List_env1s_square_expo (i_1s)
center(1:3) = List_env1s_square_cent(1:3,i_1s)
if(dabs(coef).lt.thrsh_cycle_tc)cycle
int_env = 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_env += 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_env).gt.thrsh_cycle_tc) then
List_comb_thr_b3_size(j,i) += 1
endif
enddo
enddo
enddo
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 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, List_comb_thr_b3_coef, ( 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)] &BEGIN_PROVIDER [double precision, List_comb_thr_b3_expo, ( max_List_comb_thr_b3_size,ao_num,ao_num)]
implicit none &BEGIN_PROVIDER [double precision, List_comb_thr_b3_cent, (3, max_List_comb_thr_b3_size,ao_num,ao_num)]
integer :: i_1s,i,j,ipoint,icount &BEGIN_PROVIDER [double precision, ao_abs_comb_b3_env , ( max_List_comb_thr_b3_size,ao_num,ao_num)]
double precision :: coef,beta,center(3),int_j1b
double precision :: r(3),weight,dist implicit none
ao_abs_comb_b3_j1b = 10000000.d0 integer :: i_1s,i,j,ipoint,icount
do i = 1, ao_num double precision :: coef,beta,center(3),int_env
do j = 1, ao_num double precision :: r(3),weight,dist
icount = 0
do i_1s = 1, List_all_comb_b3_size ao_abs_comb_b3_env = 10000000.d0
coef = List_all_comb_b3_coef (i_1s) do i = 1, ao_num
beta = List_all_comb_b3_expo (i_1s) do j = 1, ao_num
beta = max(beta,1.d-12) icount = 0
center(1:3) = List_all_comb_b3_cent(1:3,i_1s) do i_1s = 1, List_env1s_square_size
if(dabs(coef).lt.thrsh_cycle_tc)cycle coef = List_env1s_square_coef (i_1s)
int_j1b = 0.d0 beta = List_env1s_square_expo (i_1s)
do ipoint = 1, n_points_extra_final_grid beta = max(beta,1.d-12)
r(1:3) = final_grid_points_extra(1:3,ipoint) center(1:3) = List_env1s_square_cent(1:3,i_1s)
weight = final_weight_at_r_vector_extra(ipoint) if(dabs(coef).lt.thrsh_cycle_tc)cycle
dist = ( center(1) - r(1) )*( center(1) - r(1) ) int_env = 0.d0
dist += ( center(2) - r(2) )*( center(2) - r(2) ) do ipoint = 1, n_points_extra_final_grid
dist += ( center(3) - r(3) )*( center(3) - r(3) ) r(1:3) = final_grid_points_extra(1:3,ipoint)
int_j1b += dabs(aos_in_r_array_extra_transp(ipoint,i) * aos_in_r_array_extra_transp(ipoint,j))*dexp(-beta*dist) * weight weight = final_weight_at_r_vector_extra(ipoint)
enddo dist = ( center(1) - r(1) )*( center(1) - r(1) )
if(dabs(coef)*dabs(int_j1b).gt.thrsh_cycle_tc)then dist += ( center(2) - r(2) )*( center(2) - r(2) )
icount += 1 dist += ( center(3) - r(3) )*( center(3) - r(3) )
List_comb_thr_b3_coef(icount,j,i) = coef int_env += dabs(aos_in_r_array_extra_transp(ipoint,i) * aos_in_r_array_extra_transp(ipoint,j))*dexp(-beta*dist) * weight
List_comb_thr_b3_expo(icount,j,i) = beta enddo
List_comb_thr_b3_cent(1:3,icount,j,i) = center(1:3) if(dabs(coef)*dabs(int_env).gt.thrsh_cycle_tc)then
ao_abs_comb_b3_j1b(icount,j,i) = int_j1b icount += 1
endif List_comb_thr_b3_coef(icount,j,i) = coef
enddo List_comb_thr_b3_expo(icount,j,i) = beta
enddo List_comb_thr_b3_cent(1:3,icount,j,i) = center(1:3)
enddo ao_abs_comb_b3_env(icount,j,i) = int_env
endif
enddo
enddo
enddo
END_PROVIDER END_PROVIDER
! ---

2
plugins/local/ao_many_one_e_ints/prim_int_gauss_gauss.irp.f
View File

@ -200,7 +200,7 @@ subroutine overlap_gauss_r12_v(D_center, LD_D, delta, A_center, B_center, power_
deallocate(A_new, A_center_new, fact_a_new, iorder_a_new, overlap) deallocate(A_new, A_center_new, fact_a_new, iorder_a_new, overlap)
end subroutine overlap_gauss_r12_v end
!--- !---

2
plugins/local/ao_tc_eff_map/NEED
View File

@ -3,3 +3,5 @@ mo_one_e_ints
ao_many_one_e_ints ao_many_one_e_ints
dft_utils_in_r dft_utils_in_r
tc_keywords tc_keywords
hamiltonian
jastrow

11
plugins/local/ao_tc_eff_map/compute_ints_eff_pot.irp.f
View File

@ -23,10 +23,9 @@ subroutine compute_ao_tc_sym_two_e_pot_jl(j, l, n_integrals, buffer_i, buffer_va
logical, external :: ao_two_e_integral_zero logical, external :: ao_two_e_integral_zero
double precision :: ao_tc_sym_two_e_pot, ao_two_e_integral_erf double precision :: ao_tc_sym_two_e_pot, ao_two_e_integral_erf
double precision :: j1b_gauss_2e_j1, j1b_gauss_2e_j2 double precision :: env_gauss_2e_j1, env_gauss_2e_j2
PROVIDE j1b_type
thr = ao_integrals_threshold thr = ao_integrals_threshold
@ -53,14 +52,6 @@ subroutine compute_ao_tc_sym_two_e_pot_jl(j, l, n_integrals, buffer_i, buffer_va
integral_erf = ao_two_e_integral_erf(i, k, j, l) integral_erf = ao_two_e_integral_erf(i, k, j, l)
integral = integral_erf + integral_pot integral = integral_erf + integral_pot
!if( j1b_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 if(abs(integral) < thr) then
cycle cycle
endif endif

145
plugins/local/ao_tc_eff_map/one_e_1bgauss_grad2.irp.f
View File

@ -1,10 +1,10 @@
! --- ! ---
BEGIN_PROVIDER [ double precision, j1b_gauss_hermII, (ao_num,ao_num)] BEGIN_PROVIDER [double precision, env_gauss_hermII, (ao_num,ao_num)]
BEGIN_DOC BEGIN_DOC
! !
! :math:`\langle \chi_A | -0.5 \grad \tau_{1b} \cdot \grad \tau_{1b} | \chi_B \rangle` ! :math:`\langle \chi_A | -0.5 \grad \tau_{env} \cdot \grad \tau_{env} | \chi_B \rangle`
! !
END_DOC END_DOC
@ -22,8 +22,6 @@ BEGIN_PROVIDER [ double precision, j1b_gauss_hermII, (ao_num,ao_num)]
double precision :: int_gauss_4G double precision :: int_gauss_4G
PROVIDE j1b_type j1b_pen j1b_coeff
! -------------------------------------------------------------------------------- ! --------------------------------------------------------------------------------
! -- Dummy call to provide everything ! -- Dummy call to provide everything
dim1 = 100 dim1 = 100
@ -38,10 +36,7 @@ BEGIN_PROVIDER [ double precision, j1b_gauss_hermII, (ao_num,ao_num)]
! -------------------------------------------------------------------------------- ! --------------------------------------------------------------------------------
j1b_gauss_hermII(1:ao_num,1:ao_num) = 0.d0 env_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 PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
@ -51,113 +46,51 @@ BEGIN_PROVIDER [ double precision, j1b_gauss_hermII, (ao_num,ao_num)]
!$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, & !$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, &
!$OMP ao_power, ao_nucl, nucl_coord, & !$OMP ao_power, ao_nucl, nucl_coord, &
!$OMP ao_coef_normalized_ordered_transp, & !$OMP ao_coef_normalized_ordered_transp, &
!$OMP nucl_num, j1b_pen, j1b_gauss_hermII) !$OMP nucl_num, env_expo, env_gauss_hermII)
!$OMP DO SCHEDULE (dynamic) !$OMP DO SCHEDULE (dynamic)
do j = 1, ao_num do j = 1, ao_num
num_A = ao_nucl(j) num_A = ao_nucl(j)
power_A(1:3) = ao_power(j,1:3) power_A(1:3) = ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3) A_center(1:3) = nucl_coord(num_A,1:3)
do i = 1, ao_num do i = 1, ao_num
num_B = ao_nucl(i) num_B = ao_nucl(i)
power_B(1:3) = ao_power(i,1:3) power_B(1:3) = ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3) B_center(1:3) = nucl_coord(num_B,1:3)
do l = 1, ao_prim_num(j) do l = 1, ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j) alpha = ao_expo_ordered_transp(l,j)
do m = 1, ao_prim_num(i) do m = 1, ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i) beta = ao_expo_ordered_transp(m,i)
c = 0.d0 c = 0.d0
do k1 = 1, nucl_num do k1 = 1, nucl_num
gama1 = j1b_pen(k1) gama1 = env_expo(k1)
C_center1(1:3) = nucl_coord(k1,1:3) C_center1(1:3) = nucl_coord(k1,1:3)
do k2 = 1, nucl_num do k2 = 1, nucl_num
gama2 = j1b_pen(k2) gama2 = env_expo(k2)
C_center2(1:3) = nucl_coord(k2,1:3) 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 > ! < 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 & c1 = int_gauss_4G( A_center, B_center, C_center1, C_center2 &
, power_A, power_B, alpha, beta, gama1, gama2 ) , power_A, power_B, alpha, beta, gama1, gama2 )
c = c - 2.d0 * gama1 * gama2 * c1 c = c - 2.d0 * gama1 * gama2 * c1
enddo
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
env_gauss_hermII(i,j) = env_gauss_hermII(i,j) &
+ ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i) * c
enddo enddo
enddo enddo
enddo enddo
enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
elseif(j1b_type .eq. 2) then
! \tau_1b = \sum_iA [c_A exp(-alpha_A r_iA^2)]
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, 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 END_PROVIDER

142
plugins/local/ao_tc_eff_map/one_e_1bgauss_lap.irp.f
View File

@ -1,10 +1,10 @@
! --- ! ---
BEGIN_PROVIDER [ double precision, j1b_gauss_hermI, (ao_num,ao_num)] BEGIN_PROVIDER [double precision, env_gauss_hermI, (ao_num,ao_num)]
BEGIN_DOC BEGIN_DOC
! !
! :math:`\langle \chi_A | -0.5 \Delta \tau_{1b} | \chi_B \rangle` ! :math:`\langle \chi_A | -0.5 \Delta \tau_{env} | \chi_B \rangle`
! !
END_DOC END_DOC
@ -22,8 +22,6 @@ BEGIN_PROVIDER [ double precision, j1b_gauss_hermI, (ao_num,ao_num)]
double precision :: int_gauss_r0, int_gauss_r2 double precision :: int_gauss_r0, int_gauss_r2
PROVIDE j1b_type j1b_pen j1b_coeff
! -------------------------------------------------------------------------------- ! --------------------------------------------------------------------------------
! -- Dummy call to provide everything ! -- Dummy call to provide everything
dim1 = 100 dim1 = 100
@ -37,10 +35,7 @@ BEGIN_PROVIDER [ double precision, j1b_gauss_hermI, (ao_num,ao_num)]
, overlap_y, d_a_2, overlap_z, overlap, dim1 ) , overlap_y, d_a_2, overlap_z, overlap, dim1 )
! -------------------------------------------------------------------------------- ! --------------------------------------------------------------------------------
j1b_gauss_hermI(1:ao_num,1:ao_num) = 0.d0 env_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 PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
@ -50,109 +45,50 @@ BEGIN_PROVIDER [ double precision, j1b_gauss_hermI, (ao_num,ao_num)]
!$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, & !$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, &
!$OMP ao_power, ao_nucl, nucl_coord, & !$OMP ao_power, ao_nucl, nucl_coord, &
!$OMP ao_coef_normalized_ordered_transp, & !$OMP ao_coef_normalized_ordered_transp, &
!$OMP nucl_num, j1b_pen, j1b_gauss_hermI) !$OMP nucl_num, env_expo, env_gauss_hermI)
!$OMP DO SCHEDULE (dynamic) !$OMP DO SCHEDULE (dynamic)
do j = 1, ao_num do j = 1, ao_num
num_A = ao_nucl(j) num_A = ao_nucl(j)
power_A(1:3) = ao_power(j,1:3) power_A(1:3) = ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3) A_center(1:3) = nucl_coord(num_A,1:3)
do i = 1, ao_num do i = 1, ao_num
num_B = ao_nucl(i) num_B = ao_nucl(i)
power_B(1:3) = ao_power(i,1:3) power_B(1:3) = ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3) B_center(1:3) = nucl_coord(num_B,1:3)
do l = 1, ao_prim_num(j) do l = 1, ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j) alpha = ao_expo_ordered_transp(l,j)
do m = 1, ao_prim_num(i) do m = 1, ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i) beta = ao_expo_ordered_transp(m,i)
c = 0.d0 c = 0.d0
do k = 1, nucl_num do k = 1, nucl_num
gama = j1b_pen(k) gama = env_expo(k)
C_center(1:3) = nucl_coord(k,1:3) C_center(1:3) = nucl_coord(k,1:3)
! < XA | exp[-gama r_C^2] | XB > ! < XA | exp[-gama r_C^2] | XB >
c1 = int_gauss_r0( A_center, B_center, C_center & c1 = int_gauss_r0( A_center, B_center, C_center &
, power_A, power_B, alpha, beta, gama ) , power_A, power_B, alpha, beta, gama )
! < XA | r_A^2 exp[-gama r_C^2] | XB > ! < XA | r_A^2 exp[-gama r_C^2] | XB >
c2 = int_gauss_r2( A_center, B_center, C_center & c2 = int_gauss_r2( A_center, B_center, C_center &
, power_A, power_B, alpha, beta, gama ) , power_A, power_B, alpha, beta, gama )
c = c + 3.d0 * gama * c1 - 2.d0 * gama * gama * c2 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
env_gauss_hermI(i,j) = env_gauss_hermI(i,j) &
+ ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i) * c
enddo enddo
enddo enddo
enddo enddo
enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
elseif(j1b_type .eq. 2) then
! \tau_1b = \sum_iA [c_A exp(-alpha_A r_iA^2)]
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, k, l, m, alpha, beta, gama, coef, &
!$OMP A_center, B_center, C_center, power_A, power_B, &
!$OMP num_A, num_B, c1, 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 END_PROVIDER

130
plugins/local/ao_tc_eff_map/one_e_1bgauss_nonherm.irp.f
View File

@ -1,10 +1,11 @@
! --- ! ---
BEGIN_PROVIDER [ double precision, j1b_gauss_nonherm, (ao_num,ao_num)] BEGIN_PROVIDER [double precision, env_gauss_nonherm, (ao_num,ao_num)]
BEGIN_DOC BEGIN_DOC
! !
! j1b_gauss_nonherm(i,j) = \langle \chi_j | - grad \tau_{1b} \cdot grad | \chi_i \rangle ! env_gauss_nonherm(i,j) = \langle \chi_j | - grad \tau_{env} \cdot grad | \chi_i \rangle
! !
END_DOC END_DOC
@ -22,8 +23,6 @@ BEGIN_PROVIDER [ double precision, j1b_gauss_nonherm, (ao_num,ao_num)]
double precision :: int_gauss_deriv double precision :: int_gauss_deriv
PROVIDE j1b_type j1b_pen j1b_coeff
! -------------------------------------------------------------------------------- ! --------------------------------------------------------------------------------
! -- Dummy call to provide everything ! -- Dummy call to provide everything
dim1 = 100 dim1 = 100
@ -38,10 +37,8 @@ BEGIN_PROVIDER [ double precision, j1b_gauss_nonherm, (ao_num,ao_num)]
! -------------------------------------------------------------------------------- ! --------------------------------------------------------------------------------
j1b_gauss_nonherm(1:ao_num,1:ao_num) = 0.d0 env_gauss_nonherm(1:ao_num,1:ao_num) = 0.d0
if(j1b_type .eq. 1) then
! \tau_1b = \sum_iA -[1 - exp(-alpha_A r_iA^2)]
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
@ -51,101 +48,46 @@ BEGIN_PROVIDER [ double precision, j1b_gauss_nonherm, (ao_num,ao_num)]
!$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, & !$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, &
!$OMP ao_power, ao_nucl, nucl_coord, & !$OMP ao_power, ao_nucl, nucl_coord, &
!$OMP ao_coef_normalized_ordered_transp, & !$OMP ao_coef_normalized_ordered_transp, &
!$OMP nucl_num, j1b_pen, j1b_gauss_nonherm) !$OMP nucl_num, env_expo, env_gauss_nonherm)
!$OMP DO SCHEDULE (dynamic) !$OMP DO SCHEDULE (dynamic)
do j = 1, ao_num do j = 1, ao_num
num_A = ao_nucl(j) num_A = ao_nucl(j)
power_A(1:3) = ao_power(j,1:3) power_A(1:3) = ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3) A_center(1:3) = nucl_coord(num_A,1:3)
do i = 1, ao_num do i = 1, ao_num
num_B = ao_nucl(i) num_B = ao_nucl(i)
power_B(1:3) = ao_power(i,1:3) power_B(1:3) = ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3) B_center(1:3) = nucl_coord(num_B,1:3)
do l = 1, ao_prim_num(j) do l = 1, ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j) alpha = ao_expo_ordered_transp(l,j)
do m = 1, ao_prim_num(i) do m = 1, ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i) beta = ao_expo_ordered_transp(m,i)
c = 0.d0 c = 0.d0
do k = 1, nucl_num do k = 1, nucl_num
gama = j1b_pen(k) gama = env_expo(k)
C_center(1:3) = nucl_coord(k,1:3) C_center(1:3) = nucl_coord(k,1:3)
! \langle \chi_A | exp[-gama r_C^2] r_C \cdot grad | \chi_B \rangle ! \langle \chi_A | exp[-gama r_C^2] r_C \cdot grad | \chi_B \rangle
c1 = int_gauss_deriv( A_center, B_center, C_center & c1 = int_gauss_deriv( A_center, B_center, C_center &
, power_A, power_B, alpha, beta, gama ) , power_A, power_B, alpha, beta, gama )
c = c + 2.d0 * gama * c1 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
env_gauss_nonherm(i,j) = env_gauss_nonherm(i,j) &
+ ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i) * c
enddo enddo
enddo enddo
enddo enddo
enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
elseif(j1b_type .eq. 2) then
! \tau_1b = \sum_iA [c_A exp(-alpha_A r_iA^2)]
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, k, l, m, alpha, beta, gama, coef, &
!$OMP A_center, B_center, C_center, power_A, power_B, &
!$OMP num_A, num_B, c1, c) &
!$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, &
!$OMP ao_power, ao_nucl, nucl_coord, &
!$OMP ao_coef_normalized_ordered_transp, &
!$OMP nucl_num, j1b_pen, j1b_gauss_nonherm, &
!$OMP j1b_coeff)
!$OMP DO SCHEDULE (dynamic)
do j = 1, ao_num
num_A = ao_nucl(j)
power_A(1:3) = ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
do i = 1, ao_num
num_B = ao_nucl(i)
power_B(1:3) = ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l = 1, ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
do m = 1, ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
c = 0.d0
do k = 1, nucl_num
gama = j1b_pen (k)
coef = j1b_coeff(k)
C_center(1:3) = nucl_coord(k,1:3)
! \langle \chi_A | exp[-gama r_C^2] r_C \cdot grad | \chi_B \rangle
c1 = int_gauss_deriv( A_center, B_center, C_center &
, power_A, power_B, alpha, beta, gama )
c = c + 2.d0 * gama * coef * c1
enddo
j1b_gauss_nonherm(i,j) = j1b_gauss_nonherm(i,j) &
+ ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i) * c
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
endif
END_PROVIDER END_PROVIDER

3
plugins/local/ao_tc_eff_map/providers_ao_eff_pot.irp.f
View File

@ -22,9 +22,6 @@ BEGIN_PROVIDER [ logical, ao_tc_sym_two_e_pot_in_map ]
integer :: kk, m, j1, i1, lmax integer :: kk, m, j1, i1, lmax
character*(64) :: fmt 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) integral = ao_tc_sym_two_e_pot(1,1,1,1)
double precision :: map_mb double precision :: map_mb

27
plugins/local/ao_tc_eff_map/two_e_1bgauss_j1.irp.f
View File

@ -1,6 +1,6 @@
! --- ! ---
double precision function j1b_gauss_2e_j1(i, j, k, l) double precision function env_gauss_2e_j1(i, j, k, l)
BEGIN_DOC BEGIN_DOC
! !
@ -36,10 +36,10 @@ double precision function j1b_gauss_2e_j1(i, j, k, l)
double precision :: I_center(3), J_center(3), K_center(3), L_center(3) double precision :: I_center(3), J_center(3), K_center(3), L_center(3)
double precision :: ff, gg, cx, cy, cz double precision :: ff, gg, cx, cy, cz
double precision :: j1b_gauss_2e_j1_schwartz double precision :: env_gauss_2e_j1_schwartz
if( ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then 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) env_gauss_2e_j1 = env_gauss_2e_j1_schwartz(i, j, k, l)
return return
endif endif
@ -59,7 +59,7 @@ double precision function j1b_gauss_2e_j1(i, j, k, l)
L_center(p) = nucl_coord(num_l,p) L_center(p) = nucl_coord(num_l,p)
enddo enddo
j1b_gauss_2e_j1 = 0.d0 env_gauss_2e_j1 = 0.d0
do p = 1, ao_prim_num(i) do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i) coef1 = ao_coef_normalized_ordered_transp(p, i)
@ -89,18 +89,18 @@ double precision function j1b_gauss_2e_j1(i, j, k, l)
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p & , P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p &
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q ) , Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q )
j1b_gauss_2e_j1 = j1b_gauss_2e_j1 + coef4 * ( cx + cy + cz ) env_gauss_2e_j1 = env_gauss_2e_j1 + coef4 * ( cx + cy + cz )
enddo ! s enddo ! s
enddo ! r enddo ! r
enddo ! q enddo ! q
enddo ! p enddo ! p
return return
end function j1b_gauss_2e_j1 end
! --- ! ---
double precision function j1b_gauss_2e_j1_schwartz(i, j, k, l) double precision function env_gauss_2e_j1_schwartz(i, j, k, l)
BEGIN_DOC BEGIN_DOC
! !
@ -137,8 +137,6 @@ double precision function j1b_gauss_2e_j1_schwartz(i, j, k, l)
double precision :: schwartz_ij, thr double precision :: schwartz_ij, thr
double precision, allocatable :: schwartz_kl(:,:) double precision, allocatable :: schwartz_kl(:,:)
PROVIDE j1b_pen
dim1 = n_pt_max_integrals dim1 = n_pt_max_integrals
thr = ao_integrals_threshold * ao_integrals_threshold thr = ao_integrals_threshold * ao_integrals_threshold
@ -186,8 +184,7 @@ double precision function j1b_gauss_2e_j1_schwartz(i, j, k, l)
schwartz_kl(0,0) = max( schwartz_kl(0,r) , schwartz_kl(0,0) ) schwartz_kl(0,0) = max( schwartz_kl(0,r) , schwartz_kl(0,0) )
enddo enddo
env_gauss_2e_j1_schwartz = 0.d0
j1b_gauss_2e_j1_schwartz = 0.d0
do p = 1, ao_prim_num(i) do p = 1, ao_prim_num(i)
expo1 = ao_expo_ordered_transp(p, i) expo1 = ao_expo_ordered_transp(p, i)
@ -226,7 +223,7 @@ double precision function j1b_gauss_2e_j1_schwartz(i, j, k, l)
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p & , P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p &
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q ) , Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q )
j1b_gauss_2e_j1_schwartz = j1b_gauss_2e_j1_schwartz + coef4 * ( cx + cy + cz ) env_gauss_2e_j1_schwartz = env_gauss_2e_j1_schwartz + coef4 * ( cx + cy + cz )
enddo ! s enddo ! s
enddo ! r enddo ! r
enddo ! q enddo ! q
@ -235,7 +232,7 @@ double precision function j1b_gauss_2e_j1_schwartz(i, j, k, l)
deallocate( schwartz_kl ) deallocate( schwartz_kl )
return return
end function j1b_gauss_2e_j1_schwartz end
! --- ! ---
@ -263,14 +260,12 @@ subroutine get_cxcycz_j1( dim1, cx, cy, cz &
double precision :: general_primitive_integral_erf_shifted double precision :: general_primitive_integral_erf_shifted
double precision :: general_primitive_integral_coul_shifted double precision :: general_primitive_integral_coul_shifted
PROVIDE j1b_pen
cx = 0.d0 cx = 0.d0
cy = 0.d0 cy = 0.d0
cz = 0.d0 cz = 0.d0
do ii = 1, nucl_num do ii = 1, nucl_num
expoii = j1b_pen(ii) expoii = env_expo(ii)
Centerii(1:3) = nucl_coord(ii, 1:3) Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(pp1, P1_center, expoii, Centerii, factii, pp2, P2_center) call gaussian_product(pp1, P1_center, expoii, Centerii, factii, pp2, P2_center)

26
plugins/local/ao_tc_eff_map/two_e_1bgauss_j2.irp.f
View File

@ -1,6 +1,6 @@
! --- ! ---
double precision function j1b_gauss_2e_j2(i, j, k, l) double precision function env_gauss_2e_j2(i, j, k, l)
BEGIN_DOC BEGIN_DOC
! !
@ -36,12 +36,12 @@ double precision function j1b_gauss_2e_j2(i, j, k, l)
double precision :: I_center(3), J_center(3), K_center(3), L_center(3) double precision :: I_center(3), J_center(3), K_center(3), L_center(3)
double precision :: ff, gg, cx, cy, cz double precision :: ff, gg, cx, cy, cz
double precision :: j1b_gauss_2e_j2_schwartz double precision :: env_gauss_2e_j2_schwartz
dim1 = n_pt_max_integrals dim1 = n_pt_max_integrals
if( ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then 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) env_gauss_2e_j2 = env_gauss_2e_j2_schwartz(i, j, k, l)
return return
endif endif
@ -61,7 +61,7 @@ double precision function j1b_gauss_2e_j2(i, j, k, l)
L_center(p) = nucl_coord(num_l,p) L_center(p) = nucl_coord(num_l,p)
enddo enddo
j1b_gauss_2e_j2 = 0.d0 env_gauss_2e_j2 = 0.d0
do p = 1, ao_prim_num(i) do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i) coef1 = ao_coef_normalized_ordered_transp(p, i)
@ -91,18 +91,18 @@ double precision function j1b_gauss_2e_j2(i, j, k, l)
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p & , P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p &
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q ) , Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q )
j1b_gauss_2e_j2 = j1b_gauss_2e_j2 + coef4 * ( cx + cy + cz ) env_gauss_2e_j2 = env_gauss_2e_j2 + coef4 * ( cx + cy + cz )
enddo ! s enddo ! s
enddo ! r enddo ! r
enddo ! q enddo ! q
enddo ! p enddo ! p
return return
end function j1b_gauss_2e_j2 end
! --- ! ---
double precision function j1b_gauss_2e_j2_schwartz(i, j, k, l) double precision function env_gauss_2e_j2_schwartz(i, j, k, l)
BEGIN_DOC BEGIN_DOC
! !
@ -187,7 +187,7 @@ double precision function j1b_gauss_2e_j2_schwartz(i, j, k, l)
enddo enddo
j1b_gauss_2e_j2_schwartz = 0.d0 env_gauss_2e_j2_schwartz = 0.d0
do p = 1, ao_prim_num(i) do p = 1, ao_prim_num(i)
expo1 = ao_expo_ordered_transp(p, i) expo1 = ao_expo_ordered_transp(p, i)
@ -226,7 +226,7 @@ double precision function j1b_gauss_2e_j2_schwartz(i, j, k, l)
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p & , P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p &
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q ) , Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q )
j1b_gauss_2e_j2_schwartz = j1b_gauss_2e_j2_schwartz + coef4 * ( cx + cy + cz ) env_gauss_2e_j2_schwartz = env_gauss_2e_j2_schwartz + coef4 * ( cx + cy + cz )
enddo ! s enddo ! s
enddo ! r enddo ! r
enddo ! q enddo ! q
@ -235,7 +235,7 @@ double precision function j1b_gauss_2e_j2_schwartz(i, j, k, l)
deallocate( schwartz_kl ) deallocate( schwartz_kl )
return return
end function j1b_gauss_2e_j2_schwartz end
! --- ! ---
@ -263,15 +263,13 @@ subroutine get_cxcycz_j2( dim1, cx, cy, cz &
double precision :: general_primitive_integral_erf_shifted double precision :: general_primitive_integral_erf_shifted
double precision :: general_primitive_integral_coul_shifted double precision :: general_primitive_integral_coul_shifted
PROVIDE j1b_pen j1b_coeff
cx = 0.d0 cx = 0.d0
cy = 0.d0 cy = 0.d0
cz = 0.d0 cz = 0.d0
do ii = 1, nucl_num do ii = 1, nucl_num
expoii = j1b_pen (ii) expoii = env_expo(ii)
coefii = j1b_coeff(ii) coefii = env_coef(ii)
Centerii(1:3) = nucl_coord(ii, 1:3) Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(pp1, P1_center, expoii, Centerii, factii, pp2, P2_center) call gaussian_product(pp1, P1_center, expoii, Centerii, factii, pp2, P2_center)

49
plugins/local/ao_tc_eff_map/useful_sub.irp.f
View File

@ -174,7 +174,7 @@ double precision function general_primitive_integral_coul_shifted( dim
general_primitive_integral_coul_shifted = fact_p * fact_q * accu * pi_5_2 * p_inv * q_inv / dsqrt(p_plus_q) general_primitive_integral_coul_shifted = fact_p * fact_q * accu * pi_5_2 * p_inv * q_inv / dsqrt(p_plus_q)
return return
end function general_primitive_integral_coul_shifted end
!______________________________________________________________________________________________________________________ !______________________________________________________________________________________________________________________
!______________________________________________________________________________________________________________________ !______________________________________________________________________________________________________________________
@ -354,7 +354,7 @@ double precision function general_primitive_integral_erf_shifted( dim
general_primitive_integral_erf_shifted = fact_p * fact_q * accu * pi_5_2 * p_inv * q_inv / dsqrt(p_plus_q) general_primitive_integral_erf_shifted = fact_p * fact_q * accu * pi_5_2 * p_inv * q_inv / dsqrt(p_plus_q)
return return
end function general_primitive_integral_erf_shifted end
!______________________________________________________________________________________________________________________ !______________________________________________________________________________________________________________________
!______________________________________________________________________________________________________________________ !______________________________________________________________________________________________________________________
@ -362,3 +362,48 @@ end function general_primitive_integral_erf_shifted
! ---
subroutine inv_r_times_poly(r, dist_r, dist_vec, poly)
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
implicit none
double precision, intent(in) :: r(3), dist_r, dist_vec(3)
double precision, intent(out) :: poly(3)
integer :: i
double precision :: inv_dist
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
poly(i) = 1.d0
endif
enddo
endif
end
! ---

37
plugins/local/bi_ort_ints/biorthog_mo_for_h.irp.f
View File

@ -1,4 +1,39 @@
! ---
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, external :: get_ao_two_e_integral
PROVIDE ao_integrals_map
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP SHARED(ao_num, ao_two_e_coul, ao_integrals_map) &
!$OMP PRIVATE(i, j, k, l)
!$OMP DO
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 >
ao_two_e_coul(k,i,l,j) = get_ao_two_e_integral(i, j, k, l, ao_integrals_map)
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
END_PROVIDER
! --- ! ---
double precision function bi_ortho_mo_coul_ints(l, k, j, i) double precision function bi_ortho_mo_coul_ints(l, k, j, i)
@ -25,7 +60,7 @@ double precision function bi_ortho_mo_coul_ints(l, k, j, i)
enddo enddo
enddo enddo
end function bi_ortho_mo_coul_ints end
! --- ! ---

17
plugins/local/bi_ort_ints/one_e_bi_ort.irp.f
View File

@ -8,23 +8,6 @@ BEGIN_PROVIDER [double precision, ao_one_e_integrals_tc_tot, (ao_num,ao_num)]
ao_one_e_integrals_tc_tot = ao_one_e_integrals ao_one_e_integrals_tc_tot = ao_one_e_integrals
!provide j1b_type
!if( (j1b_type .eq. 1) .or. (j1b_type .eq. 2) ) then
!
! print *, ' do things properly !'
! stop
! !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 END_PROVIDER
! --- ! ---

90
plugins/local/bi_ort_ints/total_twoe_pot.irp.f
View File

@ -1,91 +1,4 @@
! ---
BEGIN_PROVIDER [double precision, ao_two_e_vartc_tot, (ao_num, ao_num, ao_num, ao_num) ]
integer :: i, j, k, l
provide j1b_type
provide mo_r_coef mo_l_coef
do j = 1, ao_num
do l = 1, ao_num
do i = 1, ao_num
do k = 1, ao_num
ao_two_e_vartc_tot(k,i,l,j) = ao_vartc_int_chemist(k,i,l,j)
enddo
enddo
enddo
enddo
END_PROVIDER
! ---
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. 0) then
PROVIDE ao_tc_sym_two_e_pot_in_map
!!! TODO :: OPENMP
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
else
PROVIDE ao_tc_int_chemist
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
FREE ao_tc_int_chemist
endif
END_PROVIDER
! --- ! ---
double precision function bi_ortho_mo_ints(l, k, j, i) double precision function bi_ortho_mo_ints(l, k, j, i)
@ -118,8 +31,6 @@ 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_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC BEGIN_DOC
@ -267,7 +178,6 @@ 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, (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_exchange, (mo_num,mo_num)]
&BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_two_e_jj_anti, (mo_num,mo_num)] &BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_two_e_jj_anti, (mo_num,mo_num)]

83
plugins/local/jastrow/EZFIO.cfg
View File

@ -1,9 +1,22 @@
[jast_type]
doc: Type of Jastrow [None| Mu | Qmckl] [j2e_type]
type: character*(32) type: character*(32)
interface: ezfio, provider, ocaml doc: type of the 2e-Jastrow: [ None | Mu | Mur | Qmckl ]
interface: ezfio,provider,ocaml
default: Mu
[j1e_type]
type: character*(32)
doc: type of the 1e-Jastrow: [ None | Gauss | Charge_Harmonizer ]
interface: ezfio,provider,ocaml
default: None default: None
[env_type]
type: character*(32)
doc: type of envelop for Jastrow: [ None | Prod_Gauss | Sum_Gauss | Sum_Slat | Sum_Quartic ]
interface: ezfio, provider, ocaml
default: Sum_Gauss
[jast_qmckl_type_nucl_num] [jast_qmckl_type_nucl_num]
doc: Number of different nuclei types in QMCkl jastrow doc: Number of different nuclei types in QMCkl jastrow
type: integer type: integer
@ -64,6 +77,70 @@ type: double precision
size: (jastrow.jast_qmckl_c_vector_size) size: (jastrow.jast_qmckl_c_vector_size)
interface: ezfio, provider interface: ezfio, provider
[j1e_size]
type: integer
doc: number of functions per atom in 1e-Jastrow
interface: ezfio,provider,ocaml
default: 1
[j1e_coef]
type: double precision
doc: linear coef of functions in 1e-Jastrow
interface: ezfio
size: (jastrow.j1e_size,nuclei.nucl_num)
[j1e_coef_ao]
type: double precision
doc: coefficients of the 1-electrob Jastrow in AOs
interface: ezfio
size: (ao_basis.ao_num)
[j1e_coef_ao2]
type: double precision
doc: coefficients of the 1-electron Jastrow in AOsxAOs
interface: ezfio
size: (ao_basis.ao_num*ao_basis.ao_num)
[j1e_coef_ao3]
type: double precision
doc: coefficients of the 1-electron Jastrow in AOsxAOs
interface: ezfio
size: (ao_basis.ao_num,3)
[j1e_expo]
type: double precision
doc: exponenets of functions in 1e-Jastrow
interface: ezfio
size: (jastrow.j1e_size,nuclei.nucl_num)
[env_expo]
type: double precision
doc: exponents of the envelop for Jastrow
interface: ezfio
size: (nuclei.nucl_num)
[env_coef]
type: double precision
doc: coefficients of the envelop for Jastrow
interface: ezfio
size: (nuclei.nucl_num)
[murho_type]
type: integer
doc: type of mu(rho) Jastrow
interface: ezfio, provider, ocaml
default: 0
[ng_fit_jast]
type: integer
doc: nb of Gaussians used to fit Jastrow fcts
interface: ezfio,provider,ocaml
default: 20
[a_boys]
type: double precision
doc: cutting of the interaction in the range separated model
interface: ezfio,provider,ocaml
default: 1.0
ezfio_name: a_boys

1
plugins/local/jastrow/NEED
View File

@ -1,2 +1,3 @@
nuclei nuclei
electrons electrons
ao_basis

68
plugins/local/jastrow/README.md
View File

@ -1,3 +1,69 @@
# Jastrow # Jastrow
Information relative to the Jastrow factor in trans-correlated calculations. Information related to the Jastrow factor in trans-correlated calculations.
The main keywords are:
- `j2e_type`
- `j1e_type`
- `env_type`
## j2e_type Options
1. **None:** No 2e-Jastrow is used.
2. **Mu:** 2e-Jastrow inspired by Range Separated Density Functional Theory. It has the following shape:
<p align="center">
<img src="https://latex.codecogs.com/png.image?%5Cinline%20%5Clarge%20%5Cdpi%7B200%7D%5Cbg%7Bwhite%7D%5Ctau=%5Cfrac%7B1%7D%7B2%7D%5Csum_%7Bi,j%5Cneq%20i%7Du(%5Cmathbf%7Br%7D_i,%5Cmathbf%7Br%7D_j)">
</p>
with,
<p align="center">
<img src="https://latex.codecogs.com/png.image?%5Cinline%20%5Clarge%20%5Cdpi%7B200%7D%5Cbg%7Bwhite%7D%20u(%5Cmathbf%7Br%7D_1,%5Cmathbf%7Br%7D_2)=u(r_%7B12%7D)=%5Cfrac%7Br_%7B12%7D%7D%7B2%7D%5Cleft%5B1-%5Ctext%7Berf%7D(%5Cmu%20r_%7B12%7D)%5Cright%5D-%5Cfrac%7B%5Cexp%5B-(%5Cmu%20r_%7B12%7D)%5E2%5D%7D%7B2%5Csqrt%7B%5Cpi%7D%5Cmu%7D">
</p>
## env_type Options
The 2-electron Jastrow is multiplied by an envelope \(v\):
<p align="center">
<img src="https://latex.codecogs.com/png.image?%5Cinline%20%5Clarge%20%5Cdpi%7B200%7D%5Cbg%7Bwhite%7D%5Ctau=%5Cfrac%7B1%7D%7B2%7D%5Csum_%7Bi,j%5Cneq%20i%7Du(%5Cmathbf%7Br%7D_i,%5Cmathbf%7Br%7D_j)%5C,v(%5Cmathbf%7Br%7D_i)%5C,v(%5Cmathbf%7Br%7D_j)">
</p>
- if `env_type` is **None**: No envelope is used.
- if `env_type` is **Prod_Gauss**:
<p align="center">
<img src="https://latex.codecogs.com/png.image?%5Cinline%20%5Clarge%20%5Cdpi%7B200%7D%5Cbg%7Bwhite%7D%20v(%5Cmathbf%7Br%7D)=%5Cprod_%7BA%7D%5Cleft(1-e%5E%7B-%5Calpha_A(%5Cmathbf%7Br%7D-%5Cmathbf%7BR%7D_A)%5E2%7D%5Cright)">
</p>
- if `env_type` is **Sum_Gauss**:
<p align="center">
<img src="https://latex.codecogs.com/png.image?%5Cinline%20%5Clarge%20%5Cdpi%7B200%7D%5Cbg%7Bwhite%7D%20v(%5Cmathbf%7Br%7D)=1-%5Csum_%7BA%7Dc_A%20e%5E%7B-%5Calpha_A(%5Cmathbf%7Br%7D-%5Cmathbf%7BR%7D_A)%5E2%7D">
</p>
Here, \(A\) designates the nuclei, and the coefficients and exponents are defined in the tables `env_coef` and `env_expo` respectively.
## j1e_type Options
The 1-electron Jastrow used is:
<p align="center">
<img src="https://latex.codecogs.com/png.image?%5Cinline%20%5Clarge%20%5Cdpi%7B200%7D%5Cbg%7Bwhite%7D%5Ctau=%5Csum_i%20u_%7B1e%7D(%5Cmathbf%7Br%7D_i)">
</p>
- if `j1e_type` is **None**: No one-electron Jastrow is used.
- if `j1e_type` is **Gauss**: We use
<p align="center">
<img src="https://latex.codecogs.com/png.image?%5Cinline%20%5Clarge%20%5Cdpi%7B200%7D%5Cbg%7Bwhite%7Du_%7B1e%7D(%5Cmathbf%7Br%7D)=%5Csum_A%5Csum_%7Bp_A%7Dc_%7Bp_A%7De%5E%7B-%5Calpha_%7Bp_A%7D(%5Cmathbf%7Br%7D-%5Cmathbf%7BR%7D_A)%5E2%7D">
</p>
<img src="https://latex.codecogs.com/png.image?%5Cinline%20%5Clarge%20%5Cdpi%7B200%7D%5Cbg%7Bwhite%7D%20c_%7Bp_A%7D%5C,%5Ctext%7Band%7D%5C,%5Calpha_%7Bp_A%7D">
are defined by the tables `j1e_coef` and `j1e_expo`, respectively.
- if `j1e_type` is **Charge_Harmonizer**: The one-electron Jastrow factor aims to offset the adverse impact of modifying the charge density induced by the two-electron factor
<p align="center">
<img src="https://latex.codecogs.com/png.image?%5Cinline%20%5Clarge%20%5Cdpi%7B200%7D%5Cbg%7Bwhite%7Du_%7B1e%7D(%5Cmathbf%7Br%7D_1)=-%5Cfrac%7BN-1%7D%7B2N%7D%5C,%5Csum_%7B%5Csigma%7D%5C,%5Cint%20d%5Cmathbf%7Br%7D_2%5C,%5Crho%5E%7B%5Csigma%7D(%5Cmathbf%7Br%7D_2)%5C,u_%7B2e%7D(%5Cmathbf%7Br%7D_1,%5Cmathbf%7Br%7D_2)">
</p>
- if `j1e_type` is **Charge_Harmonizer_AO**: The one-electron Jastrow factor **Charge_Harmonizer** is fitted by the atomic orbitals

102
plugins/local/jastrow/env_param.irp.f Normal file
View File

@ -0,0 +1,102 @@
! ---
BEGIN_PROVIDER [double precision, env_expo, (nucl_num)]
&BEGIN_PROVIDER [double precision, env_coef, (nucl_num)]
BEGIN_DOC
!
! parameters of the env of the 2e-Jastrow
!
END_DOC
implicit none
logical :: exists
integer :: i
integer :: ierr
PROVIDE ezfio_filename
! ---
if (mpi_master) then
call ezfio_has_jastrow_env_expo(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'
call MPI_BCAST(env_expo, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read env_expo with MPI'
endif
IRP_ENDIF
if (exists) then
if (mpi_master) then
write(6,'(A)') '.. >>>>> [ IO READ: env_expo ] <<<<< ..'
call ezfio_get_jastrow_env_expo(env_expo)
IRP_IF MPI
call MPI_BCAST(env_expo, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read env_expo with MPI'
endif
IRP_ENDIF
endif
else
env_expo = 1d5
call ezfio_set_jastrow_env_expo(env_expo)
endif
! ---
if (mpi_master) then
call ezfio_has_jastrow_env_coef(exists)
endif
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI
call MPI_BCAST(env_coef, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read env_coef with MPI'
endif
IRP_ENDIF
if (exists) then
if (mpi_master) then
write(6,'(A)') '.. >>>>> [ IO READ: env_coef ] <<<<< ..'
call ezfio_get_jastrow_env_coef(env_coef)
IRP_IF MPI
call MPI_BCAST(env_coef, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read env_coef with MPI'
endif
IRP_ENDIF
endif
else
env_coef = 1d0
call ezfio_set_jastrow_env_coef(env_coef)
endif
! ---
print *, ' parameters for nuclei jastrow'
print *, ' i, Z, env_expo, env_coef'
do i = 1, nucl_num
write(*,'(I4, 2x, 3(E15.7, 2X))') i, nucl_charge(i), env_expo(i), env_coef(i)
enddo
END_PROVIDER
! ---

199
plugins/local/ao_tc_eff_map/fit_j.irp.f → plugins/local/jastrow/fit_j.irp.f
View File

@ -1,41 +1,67 @@
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 ] BEGIN_PROVIDER [double precision, expo_j_xmu_1gauss]
implicit none &BEGIN_PROVIDER [double precision, coef_j_xmu_1gauss]
expo_erfc_gauss = 1.41211d0
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 END_PROVIDER
BEGIN_PROVIDER [ double precision, expo_erfc_mu_gauss ] ! ---
implicit none
expo_erfc_mu_gauss = expo_erfc_gauss * mu_erf * mu_erf BEGIN_PROVIDER [double precision, expo_erfc_gauss]
implicit none
expo_erfc_gauss = 1.41211d0
END_PROVIDER 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) ] 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]
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
implicit none
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)]
BEGIN_DOC BEGIN_DOC
! F(x) = x * (1 - erf(x)) - 1/sqrt(pi) * exp(-x**2) is fitted with a gaussian and a Slater ! F(x) = x * (1 - erf(x)) - 1/sqrt(pi) * exp(-x**2) is fitted with a gaussian and a Slater
@ -465,53 +491,86 @@ END_PROVIDER
! --- ! ---
double precision function F_x_j(x) double precision function F_x_j(x)
implicit none
BEGIN_DOC BEGIN_DOC
! F_x_j(x) = dimension-less correlation factor = x (1 - erf(x)) - 1/sqrt(pi) exp(-x^2) !
END_DOC ! dimension-less correlation factor:
double precision, intent(in) :: x !
F_x_j = x * (1.d0 - derf(x)) - 1/dsqrt(dacos(-1.d0)) * dexp(-x**2) ! F_x_j(x) = x (1 - erf(x)) - 1/sqrt(pi) exp(-x^2)
!
END_DOC
implicit none
double precision, intent(in) :: x
F_x_j = x * (1.d0 - derf(x)) - 1/dsqrt(dacos(-1.d0)) * dexp(-x**2)
end end
! ---
double precision function j_mu_F_x_j(x) double precision function j_mu_F_x_j(x)
implicit none
BEGIN_DOC 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) !
! ! correlation factor:
! = 1/(2*mu) * F_x_j(mu*x) !
END_DOC ! j_mu_F_x_j(x) = 1/2 r12 * (1 - erf(mu*r12)) - 1/(2 sqrt(pi)*mu) exp(-(mu*r12)^2)
double precision :: F_x_j ! = 1/(2*mu) * F_x_j(mu*x)
double precision, intent(in) :: x !
j_mu_F_x_j = 0.5d0/mu_erf * F_x_j(x*mu_erf) END_DOC
implicit none
double precision, intent(in) :: x
double precision :: F_x_j
j_mu_F_x_j = 0.5d0/mu_erf * F_x_j(x*mu_erf)
end end
! ---
double precision function j_mu(x) 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) BEGIN_DOC
implicit none !
BEGIN_DOC ! correlation factor:
! j_mu_fit_gauss(x) = correlation factor = 1/2 r12 * (1 - erf(mu*r12)) - 1/(2 sqrt(pi)*mu) exp(-(mu*r12)^2) !
! ! j_mu(x) = 1/2 r12 * (1 - erf(mu*r12)) - 1/(2 sqrt(pi)*mu) exp(-(mu*r12)^2)
! but fitted with gaussians !
END_DOC END_DOC
double precision, intent(in) :: x
integer :: i implicit none
double precision :: alpha,coef double precision, intent(in) :: x
j_mu_fit_gauss = 0.d0
do i = 1, n_max_fit_slat 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))
alpha = expo_gauss_j_mu_x(i)
coef = coef_gauss_j_mu_x(i) end
j_mu_fit_gauss += coef * dexp(-alpha*x*x)
enddo ! ---
double precision function j_mu_fit_gauss(x)
BEGIN_DOC
!
! correlation factor fitted with gaussians:
!
! j_mu_fit_gauss(x) = 1/2 r12 * (1 - erf(mu*r12)) - 1/(2 sqrt(pi)*mu) exp(-(mu*r12)^2)
!
!
END_DOC
implicit none
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 end

146
plugins/local/ao_tc_eff_map/potential.irp.f → plugins/local/jastrow/fit_potential.irp.f
View File

@ -1,13 +1,16 @@
! --- ! ---
BEGIN_PROVIDER [integer, n_gauss_eff_pot] BEGIN_PROVIDER [integer, n_gauss_eff_pot]
BEGIN_DOC BEGIN_DOC
!
! number of gaussians to represent the effective potential : ! 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) ! 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) ! Here (1 - erf(mu*r12))^2 is expanded in Gaussians as Eqs A11-A20 in JCP 154, 084119 (2021)
!
END_DOC END_DOC
implicit none implicit none
@ -21,10 +24,13 @@ END_PROVIDER
BEGIN_PROVIDER [integer, n_gauss_eff_pot_deriv] BEGIN_PROVIDER [integer, n_gauss_eff_pot_deriv]
BEGIN_DOC BEGIN_DOC
!
! V(r12) = -(1 - erf(mu*r12))^2 is expanded in Gaussians as Eqs A11-A20 in JCP 154, 084119 (2021) ! V(r12) = -(1 - erf(mu*r12))^2 is expanded in Gaussians as Eqs A11-A20 in JCP 154, 084119 (2021)
!
END_DOC END_DOC
implicit none implicit none
n_gauss_eff_pot_deriv = ng_fit_jast n_gauss_eff_pot_deriv = ng_fit_jast
END_PROVIDER END_PROVIDER
@ -35,11 +41,13 @@ END_PROVIDER
&BEGIN_PROVIDER [double precision, coef_gauss_eff_pot, (n_gauss_eff_pot)] &BEGIN_PROVIDER [double precision, coef_gauss_eff_pot, (n_gauss_eff_pot)]
BEGIN_DOC 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) ! 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) ! 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) ! Relies on the fit proposed in Eqs A11-A20 in JCP 154, 084119 (2021)
!
END_DOC END_DOC
include 'constants.include.F' include 'constants.include.F'
@ -64,7 +72,9 @@ END_PROVIDER
double precision function eff_pot_gauss(x, mu) double precision function eff_pot_gauss(x, mu)
BEGIN_DOC BEGIN_DOC
!
! V(mu,r12) = -0.25 * (1 - erf(mu*r12))^2 + 1/(\sqrt(pi)mu) * exp(-(mu*r12)^2) ! V(mu,r12) = -0.25 * (1 - erf(mu*r12))^2 + 1/(\sqrt(pi)mu) * exp(-(mu*r12)^2)
!
END_DOC END_DOC
implicit none implicit none
@ -74,44 +84,58 @@ double precision function eff_pot_gauss(x, mu)
end end
! -------------------------------------------------------------------------------------------------
! --- ! ---
double precision function eff_pot_fit_gauss(x) double precision function eff_pot_fit_gauss(x)
implicit none
BEGIN_DOC BEGIN_DOC
! V(mu,r12) = -0.25 * (1 - erf(mu*r12))^2 + 1/(\sqrt(pi)mu) * exp(-(mu*r12)^2) !
! ! V(mu,r12) = -0.25 * (1 - erf(mu*r12))^2 + 1/(\sqrt(pi)mu) * exp(-(mu*r12)^2)
! but fitted with gaussians !
END_DOC ! but fitted with gaussians
double precision, intent(in) :: x !
integer :: i END_DOC
double precision :: alpha
eff_pot_fit_gauss = derf(mu_erf*x)/x implicit none
do i = 1, n_gauss_eff_pot double precision, intent(in) :: x
alpha = expo_gauss_eff_pot(i) integer :: i
eff_pot_fit_gauss += coef_gauss_eff_pot(i) * dexp(-alpha*x*x) double precision :: alpha
enddo
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 end
! ---
BEGIN_PROVIDER [integer, n_fit_1_erf_x] BEGIN_PROVIDER [integer, n_fit_1_erf_x]
implicit none
BEGIN_DOC implicit none
!
END_DOC n_fit_1_erf_x = 2
n_fit_1_erf_x = 2
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, expos_slat_gauss_1_erf_x, (n_fit_1_erf_x)] BEGIN_PROVIDER [double precision, expos_slat_gauss_1_erf_x, (n_fit_1_erf_x)]
implicit none
BEGIN_DOC 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) 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 ! 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}
expos_slat_gauss_1_erf_x(1) = 1.09529d0 !
expos_slat_gauss_1_erf_x(2) = 0.756023d0 END_DOC
implicit none
expos_slat_gauss_1_erf_x(1) = 1.09529d0
expos_slat_gauss_1_erf_x(2) = 0.756023d0
END_PROVIDER END_PROVIDER
! --- ! ---
@ -151,12 +175,14 @@ END_PROVIDER
double precision function fit_1_erf_x(x) double precision function fit_1_erf_x(x)
BEGIN_DOC BEGIN_DOC
!
! fit_1_erf_x(x) = \sum_i c_i exp (-alpha_i x^2) \approx (1 - erf(mu*x)) ! fit_1_erf_x(x) = \sum_i c_i exp (-alpha_i x^2) \approx (1 - erf(mu*x))
!
END_DOC END_DOC
implicit none implicit none
integer :: i
double precision, intent(in) :: x double precision, intent(in) :: x
integer :: i
fit_1_erf_x = 0.d0 fit_1_erf_x = 0.d0
do i = 1, n_max_fit_slat do i = 1, n_max_fit_slat
@ -171,11 +197,13 @@ end
&BEGIN_PROVIDER [double precision, coef_gauss_1_erf_x_2, (ng_fit_jast)] &BEGIN_PROVIDER [double precision, coef_gauss_1_erf_x_2, (ng_fit_jast)]
BEGIN_DOC 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) ! (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) ! 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 ! and the slater function exp(-alpha * x) is fitted with n_max_fit_slat gaussians
!
END_DOC END_DOC
implicit none implicit none
@ -286,50 +314,22 @@ END_PROVIDER
! --- ! ---
double precision function fit_1_erf_x_2(x) double precision function fit_1_erf_x_2(x)
implicit none
double precision, intent(in) :: x BEGIN_DOC
BEGIN_DOC !
! fit_1_erf_x_2(x) = \sum_i c_i exp (-alpha_i x^2) \approx (1 - erf(mu*x))^2 ! 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 END_DOC
fit_1_erf_x_2 = 0.d0
do i = 1, n_max_fit_slat implicit none
fit_1_erf_x_2 += dexp(-expo_gauss_1_erf_x_2(i) *x*x) * coef_gauss_1_erf_x_2(i) double precision, intent(in) :: x
enddo 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 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

0
plugins/local/ao_many_one_e_ints/fit_slat_gauss.irp.f → plugins/local/jastrow/fit_slat_gauss.irp.f
View File

104
plugins/local/jastrow/jast_1e_param.irp.f Normal file
View File

@ -0,0 +1,104 @@
! ---
BEGIN_PROVIDER [double precision, j1e_expo, (j1e_size, nucl_num)]
&BEGIN_PROVIDER [double precision, j1e_coef, (j1e_size, nucl_num)]
BEGIN_DOC
!
! parameters of the 1e-Jastrow
!
END_DOC
implicit none
logical :: exists
integer :: i, j
integer :: ierr
PROVIDE ezfio_filename
! ---
if (mpi_master) then
call ezfio_has_jastrow_j1e_expo(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'
call MPI_BCAST(j1e_expo, (j1e_size*nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read j1e_expo with MPI'
endif
IRP_ENDIF
if (exists) then
if (mpi_master) then
write(6,'(A)') '.. >>>>> [ IO READ: j1e_expo ] <<<<< ..'
call ezfio_get_jastrow_j1e_expo(j1e_expo)
IRP_IF MPI
call MPI_BCAST(j1e_expo, (j1e_size*nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read j1e_expo with MPI'
endif
IRP_ENDIF
endif
else
j1e_expo = 1.d0
call ezfio_set_jastrow_j1e_expo(j1e_expo)
endif
! ---
if (mpi_master) then
call ezfio_has_jastrow_j1e_coef(exists)
endif
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI
call MPI_BCAST(j1e_coef, (j1e_size*nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read j1e_coef with MPI'
endif
IRP_ENDIF
if (exists) then
if (mpi_master) then
write(6,'(A)') '.. >>>>> [ IO READ: j1e_coef ] <<<<< ..'
call ezfio_get_jastrow_j1e_coef(j1e_coef)
IRP_IF MPI
call MPI_BCAST(j1e_coef, (j1e_size*nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read j1e_coef with MPI'
endif
IRP_ENDIF
endif
else
j1e_coef = 0.d0
call ezfio_set_jastrow_j1e_coef(j1e_coef)
endif
! ---
print *, ' parameters of the 1e-Jastrow'
do i = 1, nucl_num
print*, ' for Z = ', nucl_charge(i)
do j = 1, j1e_size
write(*,'(I4, 2x, 2(E15.7, 2X))') j, j1e_coef(j,i), j1e_expo(j,i)
enddo
enddo
END_PROVIDER
! ---

371
plugins/local/jastrow/listj1b.irp.f Normal file
View File

@ -0,0 +1,371 @@
! ---
BEGIN_PROVIDER [integer, List_env1s_size]
implicit none
PROVIDE env_type
if(env_type .eq. "None") then
List_env1s_size = 1
elseif(env_type .eq. "Prod_Gauss") then
List_env1s_size = 2**nucl_num
elseif(env_type .eq. "Sum_Gauss") then
List_env1s_size = nucl_num + 1
else
print *, ' Error in List_env1s_size: Unknown env_type = ', env_type
stop
endif
print *, ' nb of 1s-Gaussian in the envelope = ', List_env1s_size
END_PROVIDER
! ---
BEGIN_PROVIDER [integer, List_env1s, (nucl_num, List_env1s_size)]
implicit none
integer :: i, j
if(nucl_num .gt. 32) then
print *, ' nucl_num = ', nucl_num, '> 32'
stop
endif
List_env1s = 0
do i = 0, List_env1s_size-1
do j = 0, nucl_num-1
if (btest(i,j)) then
List_env1s(j+1,i+1) = 1
endif
enddo
enddo
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, List_env1s_coef, ( List_env1s_size)]
&BEGIN_PROVIDER [ double precision, List_env1s_expo, ( List_env1s_size)]
&BEGIN_PROVIDER [ double precision, List_env1s_cent, (3, List_env1s_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 env_type env_expo env_coef
if(env_type .eq. "None") then
List_env1s_coef( 1) = 1.d0
List_env1s_expo( 1) = 0.d0
List_env1s_cent(1:3,1) = 0.d0
elseif(env_type .eq. "Prod_Gauss") then
List_env1s_coef = 0.d0
List_env1s_expo = 0.d0
List_env1s_cent = 0.d0
do i = 1, List_env1s_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_env1s(j,i)) * env_expo(j)
List_env1s_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_env1s_expo(i) .lt. 1d-10) cycle
List_env1s_cent(1,i) = tmp_cent_x / List_env1s_expo(i)
List_env1s_cent(2,i) = tmp_cent_y / List_env1s_expo(i)
List_env1s_cent(3,i) = tmp_cent_z / List_env1s_expo(i)
enddo
! ---
do i = 1, List_env1s_size
do j = 2, nucl_num, 1
tmp_alphaj = dble(List_env1s(j,i)) * env_expo(j)
do k = 1, j-1, 1
tmp_alphak = dble(List_env1s(k,i)) * env_expo(k)
List_env1s_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_env1s_expo(i) .lt. 1d-10) cycle
List_env1s_coef(i) = List_env1s_coef(i) / List_env1s_expo(i)
enddo
! ---
do i = 1, List_env1s_size
phase = 0
do j = 1, nucl_num
phase += List_env1s(j,i)
enddo
List_env1s_coef(i) = (-1.d0)**dble(phase) * dexp(-List_env1s_coef(i))
enddo
elseif(env_type .eq. "Sum_Gauss") then
List_env1s_coef( 1) = 1.d0
List_env1s_expo( 1) = 0.d0
List_env1s_cent(1:3,1) = 0.d0
do i = 1, nucl_num
List_env1s_coef( i+1) = -1.d0 * env_coef(i)
List_env1s_expo( i+1) = env_expo(i)
List_env1s_cent(1,i+1) = nucl_coord(i,1)
List_env1s_cent(2,i+1) = nucl_coord(i,2)
List_env1s_cent(3,i+1) = nucl_coord(i,3)
enddo
else
print *, ' Error in List_env1s: Unknown env_type = ', env_type
stop
endif
END_PROVIDER
! ---
BEGIN_PROVIDER [integer, List_env1s_square_size]
implicit none
double precision :: tmp
if(env_type .eq. "None") then
List_env1s_square_size = 1
elseif(env_type .eq. "Prod_Gauss") then
List_env1s_square_size = 3**nucl_num
elseif(env_type .eq. "Sum_Gauss") then
tmp = 0.5d0 * dble(nucl_num) * (dble(nucl_num) + 3.d0)
List_env1s_square_size = int(tmp) + 1
else
print *, ' Error in List_env1s_square_size: Unknown env_type = ', env_type
stop
endif
print *, ' nb of 1s-Gaussian in the square of envelope = ', List_env1s_square_size
END_PROVIDER
! ---
BEGIN_PROVIDER [integer, List_env1s_square, (nucl_num, List_env1s_square_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_env1s_square(:,:) = 0
List_env1s_square(:,List_env1s_square_size) = 2
allocate(p(nucl_num))
p = 0
do i = 2, List_env1s_square_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_env1s_square(j,i) = p(j)
enddo
enddo
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, List_env1s_square_coef, ( List_env1s_square_size)]
&BEGIN_PROVIDER [ double precision, List_env1s_square_expo, ( List_env1s_square_size)]
&BEGIN_PROVIDER [ double precision, List_env1s_square_cent, (3, List_env1s_square_size)]
implicit none
integer :: i, j, k, phase
integer :: ii
double precision :: tmp_alphaj, tmp_alphak, facto
double precision :: tmp1, tmp2, tmp3, tmp4
double precision :: xi, yi, zi, xj, yj, zj
double precision :: dx, dy, dz, r2
provide env_type env_expo env_coef
if(env_type .eq. "None") then
List_env1s_square_coef( 1) = 1.d0
List_env1s_square_expo( 1) = 0.d0
List_env1s_square_cent(1:3,1) = 0.d0
elseif(env_type .eq. "Prod_Gauss") then
List_env1s_square_coef = 0.d0
List_env1s_square_expo = 0.d0
List_env1s_square_cent = 0.d0
do i = 1, List_env1s_square_size
do j = 1, nucl_num
tmp_alphaj = dble(List_env1s_square(j,i)) * env_expo(j)
List_env1s_square_expo(i) += tmp_alphaj
List_env1s_square_cent(1,i) += tmp_alphaj * nucl_coord(j,1)
List_env1s_square_cent(2,i) += tmp_alphaj * nucl_coord(j,2)
List_env1s_square_cent(3,i) += tmp_alphaj * nucl_coord(j,3)
enddo
if(List_env1s_square_expo(i) .lt. 1d-10) cycle
List_env1s_square_cent(1,i) = List_env1s_square_cent(1,i) / List_env1s_square_expo(i)
List_env1s_square_cent(2,i) = List_env1s_square_cent(2,i) / List_env1s_square_expo(i)
List_env1s_square_cent(3,i) = List_env1s_square_cent(3,i) / List_env1s_square_expo(i)
enddo
! ---
do i = 1, List_env1s_square_size
do j = 2, nucl_num, 1
tmp_alphaj = dble(List_env1s_square(j,i)) * env_expo(j)
do k = 1, j-1, 1
tmp_alphak = dble(List_env1s_square(k,i)) * env_expo(k)
List_env1s_square_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_env1s_square_expo(i) .lt. 1d-10) cycle
List_env1s_square_coef(i) = List_env1s_square_coef(i) / List_env1s_square_expo(i)
enddo
! ---
do i = 1, List_env1s_square_size
facto = 1.d0
phase = 0
do j = 1, nucl_num
tmp_alphaj = dble(List_env1s_square(j,i))
facto *= 2.d0 / (gamma(tmp_alphaj+1.d0) * gamma(3.d0-tmp_alphaj))
phase += List_env1s_square(j,i)
enddo
List_env1s_square_coef(i) = (-1.d0)**dble(phase) * facto * dexp(-List_env1s_square_coef(i))
enddo
elseif(env_type .eq. "Sum_Gauss") then
ii = 1
List_env1s_square_coef( ii) = 1.d0
List_env1s_square_expo( ii) = 0.d0
List_env1s_square_cent(1:3,ii) = 0.d0
do i = 1, nucl_num
ii = ii + 1
List_env1s_square_coef( ii) = -2.d0 * env_coef(i)
List_env1s_square_expo( ii) = env_expo(i)
List_env1s_square_cent(1,ii) = nucl_coord(i,1)
List_env1s_square_cent(2,ii) = nucl_coord(i,2)
List_env1s_square_cent(3,ii) = nucl_coord(i,3)
enddo
do i = 1, nucl_num
ii = ii + 1
List_env1s_square_coef( ii) = 1.d0 * env_coef(i) * env_coef(i)
List_env1s_square_expo( ii) = 2.d0 * env_expo(i)
List_env1s_square_cent(1,ii) = nucl_coord(i,1)
List_env1s_square_cent(2,ii) = nucl_coord(i,2)
List_env1s_square_cent(3,ii) = nucl_coord(i,3)
enddo
do i = 1, nucl_num-1
tmp1 = env_expo(i)
xi = nucl_coord(i,1)
yi = nucl_coord(i,2)
zi = nucl_coord(i,3)
do j = i+1, nucl_num
tmp2 = env_expo(j)
tmp3 = tmp1 + tmp2
tmp4 = 1.d0 / tmp3
xj = nucl_coord(j,1)
yj = nucl_coord(j,2)
zj = nucl_coord(j,3)
dx = xi - xj
dy = yi - yj
dz = zi - zj
r2 = dx*dx + dy*dy + dz*dz
ii = ii + 1
! x 2 to avoid doing integrals twice
List_env1s_square_coef( ii) = 2.d0 * dexp(-tmp1*tmp2*tmp4*r2) * env_coef(i) * env_coef(j)
List_env1s_square_expo( ii) = tmp3
List_env1s_square_cent(1,ii) = tmp4 * (tmp1 * xi + tmp2 * xj)
List_env1s_square_cent(2,ii) = tmp4 * (tmp1 * yi + tmp2 * yj)
List_env1s_square_cent(3,ii) = tmp4 * (tmp1 * zi + tmp2 * zj)
enddo
enddo
else
print *, ' Error in List_env1s_square: Unknown env_type = ', env_type
stop
endif
END_PROVIDER
! ---

1
plugins/local/non_h_ints_mu/NEED
View File

@ -1,4 +1,5 @@
qmckl qmckl
hamiltonian
jastrow jastrow
ao_tc_eff_map ao_tc_eff_map
bi_ortho_mos bi_ortho_mos

56
plugins/local/non_h_ints_mu/deb_aos.irp.f Normal file
View File

@ -0,0 +1,56 @@
! ---
program deb_Aos
implicit none
my_grid_becke = .True.
PROVIDE tc_grid1_a tc_grid1_r
my_n_pt_r_grid = tc_grid1_r
my_n_pt_a_grid = tc_grid1_a
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
if(tc_integ_type .eq. "numeric") then
my_extra_grid_becke = .True.
PROVIDE tc_grid2_a tc_grid2_r
my_n_pt_r_extra_grid = tc_grid2_r
my_n_pt_a_extra_grid = tc_grid2_a
touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid
endif
call print_aos()
end
! ---
subroutine print_aos()
implicit none
integer :: i, ipoint
double precision :: r(3)
double precision :: ao_val, ao_der(3), ao_lap
PROVIDE final_grid_points aos_in_r_array aos_grad_in_r_array aos_lapl_in_r_array
do ipoint = 1, n_points_final_grid
r(:) = final_grid_points(:,ipoint)
print*, r
enddo
do ipoint = 1, n_points_final_grid
r(:) = final_grid_points(:,ipoint)
do i = 1, ao_num
ao_val = aos_in_r_array (i,ipoint)
ao_der(:) = aos_grad_in_r_array(i,ipoint,:)
ao_lap = aos_lapl_in_r_array(1,i,ipoint) + aos_lapl_in_r_array(2,i,ipoint) + aos_lapl_in_r_array(3,i,ipoint)
write(*, '(5(f15.7, 3X))') ao_val, ao_der, ao_lap
enddo
enddo
return
end
! ---

350
plugins/local/non_h_ints_mu/debug_fit.irp.f
View File

@ -11,9 +11,12 @@ program debug_fit
my_n_pt_a_grid = tc_grid1_a my_n_pt_a_grid = tc_grid1_a
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
PROVIDE mu_erf j1b_pen PROVIDE j2e_type mu_erf
PROVIDE j1e_type j1e_coef j1e_expo
PROVIDE env_type env_coef env_expo
provide tc_integ_type
if(j1b_type .ge. 100) then if(tc_integ_type .eq. "numeric") then
my_extra_grid_becke = .True. my_extra_grid_becke = .True.
PROVIDE tc_grid2_a tc_grid2_r PROVIDE tc_grid2_a tc_grid2_r
my_n_pt_r_extra_grid = tc_grid2_r my_n_pt_r_extra_grid = tc_grid2_r
@ -21,12 +24,8 @@ program debug_fit
touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid
endif endif
!call test_j1b_nucl() !call test_env_nucl()
!call test_grad_j1b_nucl() !call test_grad_env_nucl()
!call test_lapl_j1b_nucl()
!call test_list_b2()
!call test_list_b3()
!call test_fit_u() !call test_fit_u()
!call test_fit_u2() !call test_fit_u2()
@ -38,17 +37,17 @@ end
! --- ! ---
subroutine test_j1b_nucl() subroutine test_env_nucl()
implicit none implicit none
integer :: ipoint integer :: ipoint
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
double precision :: r(3) double precision :: r(3)
double precision, external :: j1b_nucl double precision, external :: env_nucl
print*, ' test_j1b_nucl ...' print*, ' test_env_nucl ...'
PROVIDE v_1b PROVIDE env_val
eps_ij = 1d-7 eps_ij = 1d-7
acc_tot = 0.d0 acc_tot = 0.d0
@ -60,11 +59,11 @@ subroutine test_j1b_nucl()
r(2) = final_grid_points(2,ipoint) r(2) = final_grid_points(2,ipoint)
r(3) = final_grid_points(3,ipoint) r(3) = final_grid_points(3,ipoint)
i_exc = v_1b(ipoint) i_exc = env_val(ipoint)
i_num = j1b_nucl(r) i_num = env_nucl(r)
acc_ij = dabs(i_exc - i_num) acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then if(acc_ij .gt. eps_ij) then
print *, ' problem in v_1b on', ipoint print *, ' problem in env_val on', ipoint
print *, ' analyt = ', i_exc print *, ' analyt = ', i_exc
print *, ' numeri = ', i_num print *, ' numeri = ', i_num
print *, ' diff = ', acc_ij print *, ' diff = ', acc_ij
@ -78,23 +77,23 @@ subroutine test_j1b_nucl()
print*, ' normalz = ', normalz print*, ' normalz = ', normalz
return return
end subroutine test_j1b_nucl end
! --- ! ---
subroutine test_grad_j1b_nucl() subroutine test_grad_env_nucl()
implicit none implicit none
integer :: ipoint integer :: ipoint
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
double precision :: r(3) double precision :: r(3)
double precision, external :: grad_x_j1b_nucl_num double precision, external :: grad_x_env_nucl_num
double precision, external :: grad_y_j1b_nucl_num double precision, external :: grad_y_env_nucl_num
double precision, external :: grad_z_j1b_nucl_num double precision, external :: grad_z_env_nucl_num
print*, ' test_grad_j1b_nucl ...' PROVIDE env_grad
PROVIDE v_1b_grad print*, ' test_grad_env_nucl ...'
eps_ij = 1d-7 eps_ij = 1d-7
acc_tot = 0.d0 acc_tot = 0.d0
@ -106,31 +105,31 @@ subroutine test_grad_j1b_nucl()
r(2) = final_grid_points(2,ipoint) r(2) = final_grid_points(2,ipoint)
r(3) = final_grid_points(3,ipoint) r(3) = final_grid_points(3,ipoint)
i_exc = v_1b_grad(1,ipoint) i_exc = env_grad(1,ipoint)
i_num = grad_x_j1b_nucl_num(r) i_num = grad_x_env_nucl_num(r)
acc_ij = dabs(i_exc - i_num) acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then if(acc_ij .gt. eps_ij) then
print *, ' problem in x of v_1b_grad on', ipoint print *, ' problem in x of env_grad on', ipoint
print *, ' analyt = ', i_exc print *, ' analyt = ', i_exc
print *, ' numeri = ', i_num print *, ' numeri = ', i_num
print *, ' diff = ', acc_ij print *, ' diff = ', acc_ij
endif endif
i_exc = v_1b_grad(2,ipoint) i_exc = env_grad(2,ipoint)
i_num = grad_y_j1b_nucl_num(r) i_num = grad_y_env_nucl_num(r)
acc_ij = dabs(i_exc - i_num) acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then if(acc_ij .gt. eps_ij) then
print *, ' problem in y of v_1b_grad on', ipoint print *, ' problem in y of env_grad on', ipoint
print *, ' analyt = ', i_exc print *, ' analyt = ', i_exc
print *, ' numeri = ', i_num print *, ' numeri = ', i_num
print *, ' diff = ', acc_ij print *, ' diff = ', acc_ij
endif endif
i_exc = v_1b_grad(3,ipoint) i_exc = env_grad(3,ipoint)
i_num = grad_z_j1b_nucl_num(r) i_num = grad_z_env_nucl_num(r)
acc_ij = dabs(i_exc - i_num) acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then if(acc_ij .gt. eps_ij) then
print *, ' problem in z of v_1b_grad on', ipoint print *, ' problem in z of env_grad on', ipoint
print *, ' analyt = ', i_exc print *, ' analyt = ', i_exc
print *, ' numeri = ', i_num print *, ' numeri = ', i_num
print *, ' diff = ', acc_ij print *, ' diff = ', acc_ij
@ -144,278 +143,7 @@ subroutine test_grad_j1b_nucl()
print*, ' normalz = ', normalz print*, ' normalz = ', normalz
return return
end subroutine test_grad_j1b_nucl end
! ---
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 :: grad_num(3), eps_der, eps_lap, tmp_der, tmp_lap, i0, ip, im
double precision, external :: j1b_nucl_square
print*, ' test_list_b3 ...'
eps_ij = 1d-7
eps_der = 1d-5
tmp_der = 0.5d0 / eps_der
eps_lap = 1d-4
tmp_lap = 1.d0 / (eps_lap*eps_lap)
! ---
PROVIDE v_1b_list_b3
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_num = j1b_nucl_square(r)
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in list_b3 on', ipoint
print *, ' r = ', r
print *, ' r2 = ', r(1)*r(1) + r(2)*r(2) + r(3)*r(3)
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 on val = ', acc_tot
print*, ' normalz on val = ', normalz
! ---
PROVIDE v_1b_square_grad
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_square_grad(ipoint,1)
r(1) = r(1) + eps_der
ip = j1b_nucl_square(r)
r(1) = r(1) - 2.d0 * eps_der
im = j1b_nucl_square(r)
r(1) = r(1) + eps_der
i_num = tmp_der * (ip - im)
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in grad_x list_b3 on', ipoint
print *, ' r = ', r
print *, ' r2 = ', r(1)*r(1) + r(2)*r(2) + r(3)*r(3)
print *, ' analyt = ', i_exc
print *, ' numeri = ', i_num
print *, ' diff = ', acc_ij
endif
acc_tot += acc_ij
normalz += dabs(i_num)
i_exc = v_1b_square_grad(ipoint,2)
r(2) = r(2) + eps_der
ip = j1b_nucl_square(r)
r(2) = r(2) - 2.d0 * eps_der
im = j1b_nucl_square(r)
r(2) = r(2) + eps_der
i_num = tmp_der * (ip - im)
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in grad_y list_b3 on', ipoint
print *, ' r = ', r
print *, ' r2 = ', r(1)*r(1) + r(2)*r(2) + r(3)*r(3)
print *, ' analyt = ', i_exc
print *, ' numeri = ', i_num
print *, ' diff = ', acc_ij
endif
acc_tot += acc_ij
normalz += dabs(i_num)
i_exc = v_1b_square_grad(ipoint,3)
r(3) = r(3) + eps_der
ip = j1b_nucl_square(r)
r(3) = r(3) - 2.d0 * eps_der
im = j1b_nucl_square(r)
r(3) = r(3) + eps_der
i_num = tmp_der * (ip - im)
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in grad_z list_b3 on', ipoint
print *, ' r = ', r
print *, ' r2 = ', r(1)*r(1) + r(2)*r(2) + r(3)*r(3)
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 on grad = ', acc_tot
print*, ' normalz on grad = ', normalz
! ---
PROVIDE v_1b_square_lapl
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)
i0 = j1b_nucl_square(r)
i_exc = v_1b_square_lapl(ipoint)
r(1) = r(1) + eps_lap
ip = j1b_nucl_square(r)
r(1) = r(1) - 2.d0 * eps_lap
im = j1b_nucl_square(r)
r(1) = r(1) + eps_lap
i_num = tmp_lap * (ip - 2.d0 * i0 + im)
r(2) = r(2) + eps_lap
ip = j1b_nucl_square(r)
r(2) = r(2) - 2.d0 * eps_lap
im = j1b_nucl_square(r)
r(2) = r(2) + eps_lap
i_num = i_num + tmp_lap * (ip - 2.d0 * i0 + im)
r(3) = r(3) + eps_lap
ip = j1b_nucl_square(r)
r(3) = r(3) - 2.d0 * eps_lap
im = j1b_nucl_square(r)
r(3) = r(3) + eps_lap
i_num = i_num + tmp_lap * (ip - 2.d0 * i0 + im)
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem in lapl list_b3 on', ipoint
print *, ' r = ', r
print *, ' r2 = ', r(1)*r(1) + r(2)*r(2) + r(3)*r(3)
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 on lapl = ', acc_tot
print*, ' normalz on lapl = ', normalz
! ---
return
end subroutine test_list_b3
! --- ! ---
@ -516,7 +244,7 @@ subroutine test_fit_ugradu()
enddo enddo
return return
end subroutine test_fit_ugradu end
! --- ! ---
@ -582,7 +310,7 @@ subroutine test_fit_u()
enddo enddo
return return
end subroutine test_fit_u end
! --- ! ---
@ -649,7 +377,7 @@ subroutine test_fit_u2()
enddo enddo
return return
end subroutine test_fit_u2 end
! --- ! ---
@ -673,10 +401,10 @@ subroutine test_grad1_u12_withsq_num()
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
call get_grad1_u12_withsq_r1_seq(final_grid_points(1,ipoint), n_points_extra_final_grid, tmp_grad1_u12(1,ipoint,1) & call get_grad1_u12_withsq_r1_seq(ipoint, n_points_extra_final_grid, tmp_grad1_u12(1,ipoint,1) &
, tmp_grad1_u12(1,ipoint,2) & , tmp_grad1_u12(1,ipoint,2) &
, tmp_grad1_u12(1,ipoint,3) & , tmp_grad1_u12(1,ipoint,3) &
, tmp_grad1_u12_squared(1,ipoint)) , tmp_grad1_u12_squared(1,ipoint))
do jpoint = 1, n_points_extra_final_grid do jpoint = 1, n_points_extra_final_grid
i_exc = grad1_u12_squared_num(jpoint,ipoint) i_exc = grad1_u12_squared_num(jpoint,ipoint)
@ -714,7 +442,7 @@ subroutine test_grad1_u12_withsq_num()
print*, ' accuracy (%) = ', 100.d0 * acc_tot / normalz print*, ' accuracy (%) = ', 100.d0 * acc_tot / normalz
return return
end subroutine test_grad1_u12_withsq_num end
! --- ! ---

343
plugins/local/non_h_ints_mu/debug_integ_jmu_modif.irp.f
View File

@ -11,40 +11,40 @@ program debug_integ_jmu_modif
my_n_pt_a_grid = tc_grid1_a my_n_pt_a_grid = tc_grid1_a
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
PROVIDE mu_erf j1b_pen PROVIDE mu_erf
! call test_v_ij_u_cst_mu_j1b() ! call test_v_ij_u_cst_mu_env()
! call test_v_ij_erf_rk_cst_mu_j1b() ! call test_v_ij_erf_rk_cst_mu_env()
! call test_x_v_ij_erf_rk_cst_mu_j1b() ! call test_x_v_ij_erf_rk_cst_mu_env()
! call test_int2_u2_j1b2() ! call test_int2_u2_env2()
! call test_int2_grad1u2_grad2u2_j1b2() ! call test_int2_grad1u2_grad2u2_env2()
! call test_int2_u_grad1u_total_j1b2() ! call test_int2_u_grad1u_total_env2()
! !
! call test_int2_grad1_u12_ao() ! call test_int2_grad1_u12_ao_num()
! !
! call test_grad12_j12() ! call test_grad12_j12()
call test_tchint_rsdft() ! call test_u12sq_envsq()
! call test_u12sq_j1bsq() ! call test_u12_grad1_u12_env_grad1_env()
! 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()
!call test_vect_overlap_gauss_r12_ao_with1s() !call test_vect_overlap_gauss_r12_ao_with1s()
!call test_Ir2_Mu_long_Du_0()
end end
! --- ! ---
subroutine test_v_ij_u_cst_mu_j1b() subroutine test_v_ij_u_cst_mu_env()
implicit none implicit none
integer :: i, j, ipoint integer :: i, j, ipoint
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
double precision, external :: num_v_ij_u_cst_mu_j1b double precision, external :: num_v_ij_u_cst_mu_env
print*, ' test_v_ij_u_cst_mu_j1b ...' print*, ' test_v_ij_u_cst_mu_env ...'
PROVIDE v_ij_u_cst_mu_j1b_fit PROVIDE v_ij_u_cst_mu_env_fit
eps_ij = 1d-3 eps_ij = 1d-3
acc_tot = 0.d0 acc_tot = 0.d0
@ -54,11 +54,11 @@ subroutine test_v_ij_u_cst_mu_j1b()
do j = 1, ao_num do j = 1, ao_num
do i = 1, ao_num do i = 1, ao_num
i_exc = v_ij_u_cst_mu_j1b_fit(i,j,ipoint) i_exc = v_ij_u_cst_mu_env_fit(i,j,ipoint)
i_num = num_v_ij_u_cst_mu_j1b (i,j,ipoint) i_num = num_v_ij_u_cst_mu_env (i,j,ipoint)
acc_ij = dabs(i_exc - i_num) acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then if(acc_ij .gt. eps_ij) then
print *, ' problem in v_ij_u_cst_mu_j1b_fit on', i, j, ipoint print *, ' problem in v_ij_u_cst_mu_env_fit on', i, j, ipoint
print *, ' analyt integ = ', i_exc print *, ' analyt integ = ', i_exc
print *, ' numeri integ = ', i_num print *, ' numeri integ = ', i_num
print *, ' diff = ', acc_ij print *, ' diff = ', acc_ij
@ -70,24 +70,23 @@ subroutine test_v_ij_u_cst_mu_j1b()
enddo enddo
enddo enddo
print*, ' acc_tot = ', acc_tot print*, ' acc_tot (%) = ', 100.d0 * acc_tot / normalz
print*, ' normalz = ', normalz
return return
end subroutine test_v_ij_u_cst_mu_j1b end
! --- ! ---
subroutine test_v_ij_erf_rk_cst_mu_j1b() subroutine test_v_ij_erf_rk_cst_mu_env()
implicit none implicit none
integer :: i, j, ipoint integer :: i, j, ipoint
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
double precision, external :: num_v_ij_erf_rk_cst_mu_j1b double precision, external :: num_v_ij_erf_rk_cst_mu_env
print*, ' test_v_ij_erf_rk_cst_mu_j1b ...' print*, ' test_v_ij_erf_rk_cst_mu_env ...'
PROVIDE v_ij_erf_rk_cst_mu_j1b PROVIDE v_ij_erf_rk_cst_mu_env
eps_ij = 1d-3 eps_ij = 1d-3
acc_tot = 0.d0 acc_tot = 0.d0
@ -98,11 +97,11 @@ subroutine test_v_ij_erf_rk_cst_mu_j1b()
do j = 1, ao_num do j = 1, ao_num
do i = 1, ao_num do i = 1, ao_num
i_exc = v_ij_erf_rk_cst_mu_j1b(i,j,ipoint) i_exc = v_ij_erf_rk_cst_mu_env(i,j,ipoint)
i_num = num_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint) i_num = num_v_ij_erf_rk_cst_mu_env(i,j,ipoint)
acc_ij = dabs(i_exc - i_num) acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then if(acc_ij .gt. eps_ij) then
print *, ' problem in v_ij_erf_rk_cst_mu_j1b on', i, j, ipoint print *, ' problem in v_ij_erf_rk_cst_mu_env on', i, j, ipoint
print *, ' analyt integ = ', i_exc print *, ' analyt integ = ', i_exc
print *, ' numeri integ = ', i_num print *, ' numeri integ = ', i_num
print *, ' diff = ', acc_ij print *, ' diff = ', acc_ij
@ -118,20 +117,20 @@ subroutine test_v_ij_erf_rk_cst_mu_j1b()
print*, ' normalz = ', normalz print*, ' normalz = ', normalz
return return
end subroutine test_v_ij_erf_rk_cst_mu_j1b end
! --- ! ---
subroutine test_x_v_ij_erf_rk_cst_mu_j1b() subroutine test_x_v_ij_erf_rk_cst_mu_env()
implicit none implicit none
integer :: i, j, ipoint integer :: i, j, ipoint
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
double precision :: integ(3) double precision :: integ(3)
print*, ' test_x_v_ij_erf_rk_cst_mu_j1b ...' print*, ' test_x_v_ij_erf_rk_cst_mu_env ...'
PROVIDE x_v_ij_erf_rk_cst_mu_j1b PROVIDE x_v_ij_erf_rk_cst_mu_env
eps_ij = 1d-3 eps_ij = 1d-3
acc_tot = 0.d0 acc_tot = 0.d0
@ -142,13 +141,13 @@ subroutine test_x_v_ij_erf_rk_cst_mu_j1b()
do j = 1, ao_num do j = 1, ao_num
do i = 1, ao_num do i = 1, ao_num
call num_x_v_ij_erf_rk_cst_mu_j1b(i, j, ipoint, integ) call num_x_v_ij_erf_rk_cst_mu_env(i, j, ipoint, integ)
i_exc = x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,1) i_exc = x_v_ij_erf_rk_cst_mu_env(i,j,ipoint,1)
i_num = integ(1) i_num = integ(1)
acc_ij = dabs(i_exc - i_num) acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then 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 *, ' problem in x part of x_v_ij_erf_rk_cst_mu_env on', i, j, ipoint
print *, ' analyt integ = ', i_exc print *, ' analyt integ = ', i_exc
print *, ' numeri integ = ', i_num print *, ' numeri integ = ', i_num
print *, ' diff = ', acc_ij print *, ' diff = ', acc_ij
@ -156,11 +155,11 @@ subroutine test_x_v_ij_erf_rk_cst_mu_j1b()
acc_tot += acc_ij acc_tot += acc_ij
normalz += dabs(i_num) normalz += dabs(i_num)
i_exc = x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,2) i_exc = x_v_ij_erf_rk_cst_mu_env(i,j,ipoint,2)
i_num = integ(2) i_num = integ(2)
acc_ij = dabs(i_exc - i_num) acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then 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 *, ' problem in y part of x_v_ij_erf_rk_cst_mu_env on', i, j, ipoint
print *, ' analyt integ = ', i_exc print *, ' analyt integ = ', i_exc
print *, ' numeri integ = ', i_num print *, ' numeri integ = ', i_num
print *, ' diff = ', acc_ij print *, ' diff = ', acc_ij
@ -168,11 +167,11 @@ subroutine test_x_v_ij_erf_rk_cst_mu_j1b()
acc_tot += acc_ij acc_tot += acc_ij
normalz += dabs(i_num) normalz += dabs(i_num)
i_exc = x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,3) i_exc = x_v_ij_erf_rk_cst_mu_env(i,j,ipoint,3)
i_num = integ(3) i_num = integ(3)
acc_ij = dabs(i_exc - i_num) acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then 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 *, ' problem in z part of x_v_ij_erf_rk_cst_mu_env on', i, j, ipoint
print *, ' analyt integ = ', i_exc print *, ' analyt integ = ', i_exc
print *, ' numeri integ = ', i_num print *, ' numeri integ = ', i_num
print *, ' diff = ', acc_ij print *, ' diff = ', acc_ij
@ -188,35 +187,34 @@ subroutine test_x_v_ij_erf_rk_cst_mu_j1b()
print*, ' normalz = ', normalz print*, ' normalz = ', normalz
return return
end subroutine test_x_v_ij_erf_rk_cst_mu_j1b end
! --- ! ---
subroutine test_int2_u2_j1b2() subroutine test_int2_u2_env2()
implicit none implicit none
integer :: i, j, ipoint integer :: i, j, ipoint
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
double precision, external :: num_int2_u2_j1b2 double precision, external :: num_int2_u2_env2
print*, ' test_int2_u2_j1b2 ...' print*, ' test_int2_u2_env2 ...'
PROVIDE int2_u2_j1b2 PROVIDE int2_u2_env2
eps_ij = 1d-3 eps_ij = 1d-3
acc_tot = 0.d0 acc_tot = 0.d0
normalz = 0.d0 normalz = 0.d0
!do ipoint = 1, 10
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do j = 1, ao_num do j = 1, ao_num
do i = 1, ao_num do i = 1, ao_num
i_exc = int2_u2_j1b2(i,j,ipoint) i_exc = int2_u2_env2(i,j,ipoint)
i_num = num_int2_u2_j1b2(i,j,ipoint) i_num = num_int2_u2_env2(i,j,ipoint)
acc_ij = dabs(i_exc - i_num) acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then if(acc_ij .gt. eps_ij) then
print *, ' problem in int2_u2_j1b2 on', i, j, ipoint print *, ' problem in int2_u2_env2 on', i, j, ipoint
print *, ' analyt integ = ', i_exc print *, ' analyt integ = ', i_exc
print *, ' numeri integ = ', i_num print *, ' numeri integ = ', i_num
print *, ' diff = ', acc_ij print *, ' diff = ', acc_ij
@ -233,20 +231,20 @@ subroutine test_int2_u2_j1b2()
print*, ' normalz = ', normalz print*, ' normalz = ', normalz
return return
end subroutine test_int2_u2_j1b2 end
! --- ! ---
subroutine test_int2_grad1u2_grad2u2_j1b2() subroutine test_int2_grad1u2_grad2u2_env2()
implicit none implicit none
integer :: i, j, ipoint integer :: i, j, ipoint
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
double precision, external :: num_int2_grad1u2_grad2u2_j1b2 double precision, external :: num_int2_grad1u2_grad2u2_env2
print*, ' test_int2_grad1u2_grad2u2_j1b2 ...' print*, ' test_int2_grad1u2_grad2u2_env2 ...'
PROVIDE int2_grad1u2_grad2u2_j1b2 PROVIDE int2_grad1u2_grad2u2_env2
eps_ij = 1d-3 eps_ij = 1d-3
acc_tot = 0.d0 acc_tot = 0.d0
@ -257,11 +255,11 @@ subroutine test_int2_grad1u2_grad2u2_j1b2()
do j = 1, ao_num do j = 1, ao_num
do i = 1, ao_num do i = 1, ao_num
i_exc = int2_grad1u2_grad2u2_j1b2(i,j,ipoint) i_exc = int2_grad1u2_grad2u2_env2(i,j,ipoint)
i_num = num_int2_grad1u2_grad2u2_j1b2(i,j,ipoint) i_num = num_int2_grad1u2_grad2u2_env2(i,j,ipoint)
acc_ij = dabs(i_exc - i_num) acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then if(acc_ij .gt. eps_ij) then
print *, ' problem in int2_grad1u2_grad2u2_j1b2 on', i, j, ipoint print *, ' problem in int2_grad1u2_grad2u2_env2 on', i, j, ipoint
print *, ' analyt integ = ', i_exc print *, ' analyt integ = ', i_exc
print *, ' numeri integ = ', i_num print *, ' numeri integ = ', i_num
print *, ' diff = ', acc_ij print *, ' diff = ', acc_ij
@ -277,18 +275,18 @@ subroutine test_int2_grad1u2_grad2u2_j1b2()
print*, ' normalz = ', normalz print*, ' normalz = ', normalz
return return
end subroutine test_int2_grad1u2_grad2u2_j1b2 end
! --- ! ---
subroutine test_int2_grad1_u12_ao() subroutine test_int2_grad1_u12_ao_num()
implicit none implicit none
integer :: i, j, ipoint integer :: i, j, ipoint
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
double precision :: integ(3) double precision :: integ(3)
print*, ' test_int2_grad1_u12_ao ...' print*, ' test_int2_grad1_u12_ao_num ...'
PROVIDE int2_grad1_u12_ao PROVIDE int2_grad1_u12_ao
@ -346,11 +344,11 @@ subroutine test_int2_grad1_u12_ao()
print*, ' normalz = ', normalz print*, ' normalz = ', normalz
return return
end subroutine test_int2_grad1_u12_ao end
! --- ! ---
subroutine test_int2_u_grad1u_total_j1b2() subroutine test_int2_u_grad1u_total_env2()
implicit none implicit none
integer :: i, j, ipoint integer :: i, j, ipoint
@ -358,10 +356,10 @@ subroutine test_int2_u_grad1u_total_j1b2()
double precision :: x, y, z double precision :: x, y, z
double precision :: integ(3) double precision :: integ(3)
print*, ' test_int2_u_grad1u_total_j1b2 ...' print*, ' test_int2_u_grad1u_total_env2 ...'
PROVIDE int2_u_grad1u_j1b2 PROVIDE int2_u_grad1u_env2
PROVIDE int2_u_grad1u_x_j1b2 PROVIDE int2_u_grad1u_x_env2
eps_ij = 1d-3 eps_ij = 1d-3
acc_tot = 0.d0 acc_tot = 0.d0
@ -376,13 +374,13 @@ subroutine test_int2_u_grad1u_total_j1b2()
do j = 1, ao_num do j = 1, ao_num
do i = 1, ao_num do i = 1, ao_num
call num_int2_u_grad1u_total_j1b2(i, j, ipoint, integ) call num_int2_u_grad1u_total_env2(i, j, ipoint, integ)
i_exc = x * int2_u_grad1u_j1b2(i,j,ipoint) - int2_u_grad1u_x_j1b2(i,j,ipoint,1) i_exc = x * int2_u_grad1u_env2(i,j,ipoint) - int2_u_grad1u_x_env2(i,j,ipoint,1)
i_num = integ(1) i_num = integ(1)
acc_ij = dabs(i_exc - i_num) acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then if(acc_ij .gt. eps_ij) then
print *, ' problem in x part of int2_u_grad1u_total_j1b2 on', i, j, ipoint print *, ' problem in x part of int2_u_grad1u_total_env2 on', i, j, ipoint
print *, ' analyt integ = ', i_exc print *, ' analyt integ = ', i_exc
print *, ' numeri integ = ', i_num print *, ' numeri integ = ', i_num
print *, ' diff = ', acc_ij print *, ' diff = ', acc_ij
@ -390,11 +388,11 @@ subroutine test_int2_u_grad1u_total_j1b2()
acc_tot += acc_ij acc_tot += acc_ij
normalz += dabs(i_num) normalz += dabs(i_num)
i_exc = y * int2_u_grad1u_j1b2(i,j,ipoint) - int2_u_grad1u_x_j1b2(i,j,ipoint,2) i_exc = y * int2_u_grad1u_env2(i,j,ipoint) - int2_u_grad1u_x_env2(i,j,ipoint,2)
i_num = integ(2) i_num = integ(2)
acc_ij = dabs(i_exc - i_num) acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then if(acc_ij .gt. eps_ij) then
print *, ' problem in y part of int2_u_grad1u_total_j1b2 on', i, j, ipoint print *, ' problem in y part of int2_u_grad1u_total_env2 on', i, j, ipoint
print *, ' analyt integ = ', i_exc print *, ' analyt integ = ', i_exc
print *, ' numeri integ = ', i_num print *, ' numeri integ = ', i_num
print *, ' diff = ', acc_ij print *, ' diff = ', acc_ij
@ -402,11 +400,11 @@ subroutine test_int2_u_grad1u_total_j1b2()
acc_tot += acc_ij acc_tot += acc_ij
normalz += dabs(i_num) normalz += dabs(i_num)
i_exc = z * int2_u_grad1u_j1b2(i,j,ipoint) - int2_u_grad1u_x_j1b2(i,j,ipoint,3) i_exc = z * int2_u_grad1u_env2(i,j,ipoint) - int2_u_grad1u_x_env2(i,j,ipoint,3)
i_num = integ(3) i_num = integ(3)
acc_ij = dabs(i_exc - i_num) acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then if(acc_ij .gt. eps_ij) then
print *, ' problem in z part of int2_u_grad1u_total_j1b2 on', i, j, ipoint print *, ' problem in z part of int2_u_grad1u_total_env2 on', i, j, ipoint
print *, ' analyt integ = ', i_exc print *, ' analyt integ = ', i_exc
print *, ' numeri integ = ', i_num print *, ' numeri integ = ', i_num
print *, ' diff = ', acc_ij print *, ' diff = ', acc_ij
@ -422,109 +420,7 @@ subroutine test_int2_u_grad1u_total_j1b2()
print*, ' normalz = ', normalz print*, ' normalz = ', normalz
return return
end subroutine test_int2_u_grad1u_total_j1b2 end
! ---
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_tchint_rsdft()
implicit none
integer :: i, j, m, ipoint, jpoint
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
double precision :: x(3), y(3), dj_1(3), dj_2(3), dj_3(3)
print*, ' test rsdft_jastrow ...'
PROVIDE grad1_u12_num
eps_ij = 1d-4
acc_tot = 0.d0
normalz = 0.d0
do ipoint = 1, n_points_final_grid
x(1) = final_grid_points(1,ipoint)
x(2) = final_grid_points(2,ipoint)
x(3) = final_grid_points(3,ipoint)
do jpoint = 1, n_points_extra_final_grid
y(1) = final_grid_points_extra(1,jpoint)
y(2) = final_grid_points_extra(2,jpoint)
y(3) = final_grid_points_extra(3,jpoint)
dj_1(1) = grad1_u12_num(jpoint,ipoint,1)
dj_1(2) = grad1_u12_num(jpoint,ipoint,2)
dj_1(3) = grad1_u12_num(jpoint,ipoint,3)
call get_tchint_rsdft_jastrow(x, y, dj_2)
do m = 1, 3
i_exc = dj_1(m)
i_num = dj_2(m)
acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then
print *, ' problem on', ipoint, jpoint, m
print *, ' x = ', x
print *, ' y = ', y
print *, ' exc, num, diff = ', i_exc, i_num, acc_ij
call grad1_jmu_modif_num(x, y, dj_3)
print *, ' check = ', dj_3(m)
stop
endif
acc_tot += acc_ij
normalz += dabs(i_exc)
enddo
enddo
enddo
print*, ' acc_tot = ', acc_tot
print*, ' normalz = ', normalz
return
end subroutine test_tchint_rsdft
! --- ! ---
@ -567,20 +463,20 @@ subroutine test_grad12_j12()
print*, ' normalz = ', normalz print*, ' normalz = ', normalz
return return
end subroutine test_grad12_j12 end
! --- ! ---
subroutine test_u12sq_j1bsq() subroutine test_u12sq_envsq()
implicit none implicit none
integer :: i, j, ipoint integer :: i, j, ipoint
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
double precision, external :: num_u12sq_j1bsq double precision, external :: num_u12sq_envsq
print*, ' test_u12sq_j1bsq ...' print*, ' test_u12sq_envsq ...'
PROVIDE u12sq_j1bsq PROVIDE u12sq_envsq
eps_ij = 1d-3 eps_ij = 1d-3
acc_tot = 0.d0 acc_tot = 0.d0
@ -590,11 +486,11 @@ subroutine test_u12sq_j1bsq()
do j = 1, ao_num do j = 1, ao_num
do i = 1, ao_num do i = 1, ao_num
i_exc = u12sq_j1bsq(i,j,ipoint) i_exc = u12sq_envsq(i,j,ipoint)
i_num = num_u12sq_j1bsq(i, j, ipoint) i_num = num_u12sq_envsq(i, j, ipoint)
acc_ij = dabs(i_exc - i_num) acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then if(acc_ij .gt. eps_ij) then
print *, ' problem in u12sq_j1bsq on', i, j, ipoint print *, ' problem in u12sq_envsq on', i, j, ipoint
print *, ' analyt integ = ', i_exc print *, ' analyt integ = ', i_exc
print *, ' numeri integ = ', i_num print *, ' numeri integ = ', i_num
print *, ' diff = ', acc_ij print *, ' diff = ', acc_ij
@ -610,20 +506,20 @@ subroutine test_u12sq_j1bsq()
print*, ' normalz = ', normalz print*, ' normalz = ', normalz
return return
end subroutine test_u12sq_j1bsq end
! --- ! ---
subroutine test_u12_grad1_u12_j1b_grad1_j1b() subroutine test_u12_grad1_u12_env_grad1_env()
implicit none implicit none
integer :: i, j, ipoint integer :: i, j, ipoint
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
double precision, external :: num_u12_grad1_u12_j1b_grad1_j1b double precision, external :: num_u12_grad1_u12_env_grad1_env
print*, ' test_u12_grad1_u12_j1b_grad1_j1b ...' print*, ' test_u12_grad1_u12_env_grad1_env ...'
PROVIDE u12_grad1_u12_j1b_grad1_j1b PROVIDE u12_grad1_u12_env_grad1_env
eps_ij = 1d-3 eps_ij = 1d-3
acc_tot = 0.d0 acc_tot = 0.d0
@ -633,11 +529,11 @@ subroutine test_u12_grad1_u12_j1b_grad1_j1b()
do j = 1, ao_num do j = 1, ao_num
do i = 1, ao_num do i = 1, ao_num
i_exc = u12_grad1_u12_j1b_grad1_j1b(i,j,ipoint) i_exc = u12_grad1_u12_env_grad1_env(i,j,ipoint)
i_num = num_u12_grad1_u12_j1b_grad1_j1b(i, j, ipoint) i_num = num_u12_grad1_u12_env_grad1_env(i, j, ipoint)
acc_ij = dabs(i_exc - i_num) acc_ij = dabs(i_exc - i_num)
if(acc_ij .gt. eps_ij) then if(acc_ij .gt. eps_ij) then
print *, ' problem in u12_grad1_u12_j1b_grad1_j1b on', i, j, ipoint print *, ' problem in u12_grad1_u12_env_grad1_env on', i, j, ipoint
print *, ' analyt integ = ', i_exc print *, ' analyt integ = ', i_exc
print *, ' numeri integ = ', i_num print *, ' numeri integ = ', i_num
print *, ' diff = ', acc_ij print *, ' diff = ', acc_ij
@ -653,7 +549,7 @@ subroutine test_u12_grad1_u12_j1b_grad1_j1b()
print*, ' normalz = ', normalz print*, ' normalz = ', normalz
return return
end subroutine test_u12_grad1_u12_j1b_grad1_j1b end
! --- ! ---
@ -670,7 +566,7 @@ subroutine test_vect_overlap_gauss_r12_ao()
print *, ' test_vect_overlap_gauss_r12_ao ...' print *, ' test_vect_overlap_gauss_r12_ao ...'
provide mu_erf final_grid_points_transp j1b_pen provide mu_erf final_grid_points_transp
expo_fit = expo_gauss_j_mu_x_2(1) expo_fit = expo_gauss_j_mu_x_2(1)
@ -740,7 +636,7 @@ subroutine test_vect_overlap_gauss_r12_ao()
print*, ' normalz = ', normalz print*, ' normalz = ', normalz
return return
end subroutine test_vect_overlap_gauss_r12_ao end
! --- ! ---
@ -757,13 +653,13 @@ subroutine test_vect_overlap_gauss_r12_ao_with1s()
print *, ' test_vect_overlap_gauss_r12_ao_with1s ...' print *, ' test_vect_overlap_gauss_r12_ao_with1s ...'
provide mu_erf final_grid_points_transp j1b_pen provide mu_erf final_grid_points_transp
expo_fit = expo_gauss_j_mu_x_2(1) expo_fit = expo_gauss_j_mu_x_2(1)
beta = List_all_comb_b3_expo (2) beta = List_env1s_square_expo (2)
B_center(1) = List_all_comb_b3_cent(1,2) B_center(1) = List_env1s_square_cent(1,2)
B_center(2) = List_all_comb_b3_cent(2,2) B_center(2) = List_env1s_square_cent(2,2)
B_center(3) = List_all_comb_b3_cent(3,2) B_center(3) = List_env1s_square_cent(3,2)
! --- ! ---
@ -831,5 +727,52 @@ subroutine test_vect_overlap_gauss_r12_ao_with1s()
print*, ' normalz = ', normalz print*, ' normalz = ', normalz
return return
end subroutine test_vect_overlap_gauss_r12_ao end
! ---
subroutine test_Ir2_Mu_long_Du_0()
implicit none
integer :: i, j, ipoint
double precision :: i_old, i_new
double precision :: acc_ij, acc_tot, eps_ij, normalz
print*, ' test_Ir2_Mu_long_Du_0 ...'
PROVIDE v_ij_erf_rk_cst_mu_env
PROVIDE Ir2_Mu_long_Du_0
eps_ij = 1d-10
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_old = v_ij_erf_rk_cst_mu_env(i,j,ipoint)
i_new = Ir2_Mu_long_Du_0 (i,j,ipoint)
acc_ij = dabs(i_old - i_new)
if(acc_ij .gt. eps_ij) then
print *, ' problem in Ir2_Mu_long_Du_0 on', i, j, ipoint
print *, ' old integ = ', i_old
print *, ' new integ = ', i_new
print *, ' diff = ', acc_ij
stop
endif
acc_tot += acc_ij
normalz += dabs(i_old)
enddo
enddo
enddo
print*, ' acc_tot (%) = ', 100.d0 * acc_tot / normalz
return
end
! ---

419
plugins/local/non_h_ints_mu/grad_squared.irp.f
View File

@ -1,224 +1,7 @@
! --- ! ---
! TODO : strong optmization : write the loops in a different way BEGIN_PROVIDER [double precision, grad12_j12, (ao_num, ao_num, n_points_final_grid)]
! : 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 implicit none
integer :: ipoint, i, j, m, igauss integer :: ipoint, i, j, m, igauss
@ -230,48 +13,28 @@ BEGIN_PROVIDER [ double precision, grad12_j12, (ao_num, ao_num, n_points_final_g
print*, ' providing grad12_j12 ...' print*, ' providing grad12_j12 ...'
call wall_time(time0) call wall_time(time0)
PROVIDE j1b_type PROVIDE int2_grad1u2_grad2u2_env2
PROVIDE int2_grad1u2_grad2u2_j1b2
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
tmp1 = v_1b(ipoint) tmp1 = env_val(ipoint)
tmp1 = tmp1 * tmp1 tmp1 = tmp1 * tmp1
do j = 1, ao_num do j = 1, ao_num
do i = 1, ao_num do i = 1, ao_num
grad12_j12(i,j,ipoint) = tmp1 * int2_grad1u2_grad2u2_j1b2(i,j,ipoint) grad12_j12(i,j,ipoint) = tmp1 * int2_grad1u2_grad2u2_env2(i,j,ipoint)
enddo enddo
enddo enddo
enddo enddo
FREE int2_grad1u2_grad2u2_j1b2 FREE int2_grad1u2_grad2u2_env2
!if(j1b_type .eq. 0) then
! 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) call wall_time(time1)
print*, ' Wall time for grad12_j12 = ', time1 - time0 print*, ' Wall time for grad12_j12 (min) = ', (time1 - time0) / 60.d0
call print_memory_usage()
END_PROVIDER END_PROVIDER
! --- ! ---
BEGIN_PROVIDER [double precision, u12sq_j1bsq, (ao_num, ao_num, n_points_final_grid)] BEGIN_PROVIDER [double precision, u12sq_envsq, (ao_num, ao_num, n_points_final_grid)]
implicit none implicit none
integer :: ipoint, i, j integer :: ipoint, i, j
@ -279,33 +42,32 @@ BEGIN_PROVIDER [double precision, u12sq_j1bsq, (ao_num, ao_num, n_points_final_g
double precision :: tmp1 double precision :: tmp1
double precision :: time0, time1 double precision :: time0, time1
print*, ' providing u12sq_j1bsq ...' print*, ' providing u12sq_envsq ...'
call wall_time(time0) call wall_time(time0)
! do not free here ! do not free here
PROVIDE int2_u2_j1b2 PROVIDE int2_u2_env2
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
tmp_x = v_1b_grad(1,ipoint) tmp_x = env_grad(1,ipoint)
tmp_y = v_1b_grad(2,ipoint) tmp_y = env_grad(2,ipoint)
tmp_z = v_1b_grad(3,ipoint) tmp_z = env_grad(3,ipoint)
tmp1 = -0.5d0 * (tmp_x * tmp_x + tmp_y * tmp_y + tmp_z * tmp_z) tmp1 = -0.5d0 * (tmp_x * tmp_x + tmp_y * tmp_y + tmp_z * tmp_z)
do j = 1, ao_num do j = 1, ao_num
do i = 1, ao_num do i = 1, ao_num
u12sq_j1bsq(i,j,ipoint) = tmp1 * int2_u2_j1b2(i,j,ipoint) u12sq_envsq(i,j,ipoint) = tmp1 * int2_u2_env2(i,j,ipoint)
enddo enddo
enddo enddo
enddo enddo
call wall_time(time1) call wall_time(time1)
print*, ' Wall time for u12sq_j1bsq = ', time1 - time0 print*, ' Wall time for u12sq_envsq (min) = ', (time1 - time0) / 60.d0
call print_memory_usage()
END_PROVIDER END_PROVIDER
! --- ! ---
BEGIN_PROVIDER [ double precision, u12_grad1_u12_j1b_grad1_j1b, (ao_num, ao_num, n_points_final_grid) ] BEGIN_PROVIDER [double precision, u12_grad1_u12_env_grad1_env, (ao_num, ao_num, n_points_final_grid)]
implicit none implicit none
integer :: ipoint, i, j, m, igauss integer :: ipoint, i, j, m, igauss
@ -315,21 +77,21 @@ BEGIN_PROVIDER [ double precision, u12_grad1_u12_j1b_grad1_j1b, (ao_num, ao_num,
double precision :: time0, time1 double precision :: time0, time1
double precision, external :: overlap_gauss_r12_ao double precision, external :: overlap_gauss_r12_ao
print*, ' providing u12_grad1_u12_j1b_grad1_j1b ...' print*, ' providing u12_grad1_u12_env_grad1_env ...'
call wall_time(time0) call wall_time(time0)
PROVIDE int2_u_grad1u_j1b2 PROVIDE int2_u_grad1u_env2
PROVIDE int2_u_grad1u_x_j1b2 PROVIDE int2_u_grad1u_x_env2
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
x = final_grid_points(1,ipoint) x = final_grid_points(1,ipoint)
y = final_grid_points(2,ipoint) y = final_grid_points(2,ipoint)
z = final_grid_points(3,ipoint) z = final_grid_points(3,ipoint)
tmp_v = v_1b (ipoint) tmp_v = env_val (ipoint)
tmp_x = v_1b_grad(1,ipoint) tmp_x = env_grad(1,ipoint)
tmp_y = v_1b_grad(2,ipoint) tmp_y = env_grad(2,ipoint)
tmp_z = v_1b_grad(3,ipoint) tmp_z = env_grad(3,ipoint)
tmp3 = tmp_v * tmp_x tmp3 = tmp_v * tmp_x
tmp4 = tmp_v * tmp_y tmp4 = tmp_v * tmp_y
@ -342,143 +104,20 @@ BEGIN_PROVIDER [ double precision, u12_grad1_u12_j1b_grad1_j1b, (ao_num, ao_num,
do j = 1, ao_num do j = 1, ao_num
do i = 1, ao_num do i = 1, ao_num
tmp9 = int2_u_grad1u_j1b2(i,j,ipoint) tmp9 = int2_u_grad1u_env2(i,j,ipoint)
u12_grad1_u12_j1b_grad1_j1b(i,j,ipoint) = tmp6 * tmp9 + tmp3 * int2_u_grad1u_x_j1b2(i,j,ipoint,1) & u12_grad1_u12_env_grad1_env(i,j,ipoint) = tmp6 * tmp9 + tmp3 * int2_u_grad1u_x_env2(i,j,ipoint,1) &
+ tmp7 * tmp9 + tmp4 * int2_u_grad1u_x_j1b2(i,j,ipoint,2) & + tmp7 * tmp9 + tmp4 * int2_u_grad1u_x_env2(i,j,ipoint,2) &
+ tmp8 * tmp9 + tmp5 * int2_u_grad1u_x_j1b2(i,j,ipoint,3) + tmp8 * tmp9 + tmp5 * int2_u_grad1u_x_env2(i,j,ipoint,3)
enddo enddo
enddo enddo
enddo enddo
FREE int2_u_grad1u_j1b2 FREE int2_u_grad1u_env2
FREE int2_u_grad1u_x_j1b2 FREE int2_u_grad1u_x_env2
call wall_time(time1) call wall_time(time1)
print*, ' Wall time for u12_grad1_u12_j1b_grad1_j1b = ', time1 - time0 print*, ' Wall time for u12_grad1_u12_env_grad1_env (min) = ', (time1 - time0) / 60.d0
call print_memory_usage()
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_k_r, ao_i_r
double precision :: der_envsq_x, der_envsq_y, der_envsq_z, lap_envsq
double precision :: time0, time1
double precision, allocatable :: b_mat(:,:,:), tmp(:,:,:)
print*, ' providing tc_grad_square_ao ...'
call wall_time(time0)
if(read_tc_integ) then
open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/tc_grad_square_ao', action="read")
read(11) tc_grad_square_ao
close(11)
else
! ---
PROVIDE int2_grad1_u12_square_ao
allocate(b_mat(n_points_final_grid,ao_num,ao_num))
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
tc_grad_square_ao = 0.d0
call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
, int2_grad1_u12_square_ao(1,1,1), ao_num*ao_num, b_mat(1,1,1), n_points_final_grid &
, 0.d0, tc_grad_square_ao, ao_num*ao_num)
FREE int2_grad1_u12_square_ao
! ---
if(((j1b_type .eq. 3) .or. (j1b_type .eq. 4)) .and. use_ipp) then
print*, " going through Manu's IPP"
! an additional term is added here directly instead of
! being added in int2_grad1_u12_square_ao for performance
PROVIDE int2_u2_j1b2
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, b_mat, ao_num, n_points_final_grid, final_weight_at_r_vector, &
!$OMP v_1b_square_grad, v_1b_square_lapl, aos_grad_in_r_array_transp_bis)
!$OMP DO SCHEDULE (static)
do i = 1, ao_num
do k = 1, ao_num
do ipoint = 1, n_points_final_grid
weight1 = 0.25d0 * 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) = weight1 * ( ao_k_r * ao_i_r * v_1b_square_lapl(ipoint) &
+ (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)) * v_1b_square_grad(ipoint,1) &
+ (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)) * v_1b_square_grad(ipoint,2) &
+ (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)) * v_1b_square_grad(ipoint,3) )
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
, int2_u2_j1b2(1,1,1), ao_num*ao_num, b_mat(1,1,1), n_points_final_grid &
, 1.d0, tc_grad_square_ao, ao_num*ao_num)
FREE int2_u2_j1b2
endif
! ---
deallocate(b_mat)
call sum_A_At(tc_grad_square_ao(1,1,1,1), ao_num*ao_num)
endif
if(write_tc_integ.and.mpi_master) then
open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/tc_grad_square_ao', action="write")
call ezfio_set_work_empty(.False.)
write(11) tc_grad_square_ao
close(11)
call ezfio_set_tc_keywords_io_tc_integ('Read')
endif
call wall_time(time1)
print*, ' Wall time for tc_grad_square_ao = ', time1 - time0
call print_memory_usage()
END_PROVIDER END_PROVIDER

84
plugins/local/non_h_ints_mu/grad_squared_manu.irp.f
View File

@ -1,4 +1,6 @@
! ---
BEGIN_PROVIDER [double precision, tc_grad_square_ao_test, (ao_num, ao_num, ao_num, ao_num)] BEGIN_PROVIDER [double precision, tc_grad_square_ao_test, (ao_num, ao_num, ao_num, ao_num)]
BEGIN_DOC BEGIN_DOC
@ -24,7 +26,7 @@ BEGIN_PROVIDER [double precision, tc_grad_square_ao_test, (ao_num, ao_num, ao_nu
else else
provide u12sq_j1bsq_test u12_grad1_u12_j1b_grad1_j1b_test grad12_j12_test provide u12sq_envsq_test u12_grad1_u12_env_grad1_env_test grad12_j12_test
allocate(b_mat(n_points_final_grid,ao_num,ao_num), tmp(ao_num,ao_num,n_points_final_grid)) allocate(b_mat(n_points_final_grid,ao_num,ao_num), tmp(ao_num,ao_num,n_points_final_grid))
@ -48,12 +50,12 @@ BEGIN_PROVIDER [double precision, tc_grad_square_ao_test, (ao_num, ao_num, ao_nu
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (j, l, ipoint) & !$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 SHARED (tmp, ao_num, n_points_final_grid, u12sq_envsq_test, u12_grad1_u12_env_grad1_env_test, grad12_j12_test)
!$OMP DO SCHEDULE (static) !$OMP DO SCHEDULE (static)
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do j = 1, ao_num do j = 1, ao_num
do l = 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) tmp(l,j,ipoint) = u12sq_envsq_test(l,j,ipoint) + u12_grad1_u12_env_grad1_env_test(l,j,ipoint) + 0.5d0 * grad12_j12_test(l,j,ipoint)
enddo enddo
enddo enddo
enddo enddo
@ -102,7 +104,7 @@ BEGIN_PROVIDER [double precision, tc_grad_square_ao_test_ref, (ao_num, ao_num, a
print*, ' providing tc_grad_square_ao_test_ref ...' print*, ' providing tc_grad_square_ao_test_ref ...'
call wall_time(time0) call wall_time(time0)
provide u12sq_j1bsq_test u12_grad1_u12_j1b_grad1_j1b_test grad12_j12_test provide u12sq_envsq_test u12_grad1_u12_env_grad1_env_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)) 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))
@ -126,12 +128,12 @@ BEGIN_PROVIDER [double precision, tc_grad_square_ao_test_ref, (ao_num, ao_num, a
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (j, l, ipoint) & !$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 SHARED (tmp, ao_num, n_points_final_grid, u12sq_envsq_test, u12_grad1_u12_env_grad1_env_test, grad12_j12_test)
!$OMP DO SCHEDULE (static) !$OMP DO SCHEDULE (static)
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do j = 1, ao_num do j = 1, ao_num
do l = 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) tmp(l,j,ipoint) = u12sq_envsq_test(l,j,ipoint) + u12_grad1_u12_env_grad1_env_test(l,j,ipoint) + 0.5d0 * grad12_j12_test(l,j,ipoint)
enddo enddo
enddo enddo
enddo enddo
@ -170,7 +172,7 @@ END_PROVIDER
! --- ! ---
BEGIN_PROVIDER [ double precision, u12sq_j1bsq_test, (ao_num, ao_num, n_points_final_grid) ] BEGIN_PROVIDER [ double precision, u12sq_envsq_test, (ao_num, ao_num, n_points_final_grid) ]
implicit none implicit none
integer :: ipoint, i, j integer :: ipoint, i, j
@ -178,29 +180,29 @@ BEGIN_PROVIDER [ double precision, u12sq_j1bsq_test, (ao_num, ao_num, n_points_f
double precision :: tmp1 double precision :: tmp1
double precision :: time0, time1 double precision :: time0, time1
print*, ' providing u12sq_j1bsq_test ...' print*, ' providing u12sq_envsq_test ...'
call wall_time(time0) call wall_time(time0)
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
tmp_x = v_1b_grad(1,ipoint) tmp_x = env_grad(1,ipoint)
tmp_y = v_1b_grad(2,ipoint) tmp_y = env_grad(2,ipoint)
tmp_z = v_1b_grad(3,ipoint) tmp_z = env_grad(3,ipoint)
tmp1 = -0.5d0 * (tmp_x * tmp_x + tmp_y * tmp_y + tmp_z * tmp_z) tmp1 = -0.5d0 * (tmp_x * tmp_x + tmp_y * tmp_y + tmp_z * tmp_z)
do j = 1, ao_num do j = 1, ao_num
do i = 1, ao_num do i = 1, ao_num
u12sq_j1bsq_test(i,j,ipoint) = tmp1 * int2_u2_j1b2_test(i,j,ipoint) u12sq_envsq_test(i,j,ipoint) = tmp1 * int2_u2_env2_test(i,j,ipoint)
enddo enddo
enddo enddo
enddo enddo
call wall_time(time1) call wall_time(time1)
print*, ' Wall time for u12sq_j1bsq_test = ', time1 - time0 print*, ' Wall time for u12sq_envsq_test (min) = ', (time1 - time0) / 60.d0
END_PROVIDER END_PROVIDER
! --- ! ---
BEGIN_PROVIDER [ double precision, u12_grad1_u12_j1b_grad1_j1b_test, (ao_num, ao_num, n_points_final_grid) ] BEGIN_PROVIDER [double precision, u12_grad1_u12_env_grad1_env_test, (ao_num, ao_num, n_points_final_grid)]
implicit none implicit none
integer :: ipoint, i, j, m, igauss integer :: ipoint, i, j, m, igauss
@ -210,9 +212,9 @@ BEGIN_PROVIDER [ double precision, u12_grad1_u12_j1b_grad1_j1b_test, (ao_num, ao
double precision :: time0, time1 double precision :: time0, time1
double precision, external :: overlap_gauss_r12_ao double precision, external :: overlap_gauss_r12_ao
print*, ' providing u12_grad1_u12_j1b_grad1_j1b_test ...' print*, ' providing u12_grad1_u12_env_grad1_env_test ...'
provide int2_u_grad1u_x_j1b2_test provide int2_u_grad1u_x_env2_test
call wall_time(time0) call wall_time(time0)
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
@ -220,10 +222,10 @@ BEGIN_PROVIDER [ double precision, u12_grad1_u12_j1b_grad1_j1b_test, (ao_num, ao
x = final_grid_points(1,ipoint) x = final_grid_points(1,ipoint)
y = final_grid_points(2,ipoint) y = final_grid_points(2,ipoint)
z = final_grid_points(3,ipoint) z = final_grid_points(3,ipoint)
tmp_v = v_1b (ipoint) tmp_v = env_val (ipoint)
tmp_x = v_1b_grad(1,ipoint) tmp_x = env_grad(1,ipoint)
tmp_y = v_1b_grad(2,ipoint) tmp_y = env_grad(2,ipoint)
tmp_z = v_1b_grad(3,ipoint) tmp_z = env_grad(3,ipoint)
tmp3 = tmp_v * tmp_x tmp3 = tmp_v * tmp_x
tmp4 = tmp_v * tmp_y tmp4 = tmp_v * tmp_y
@ -236,23 +238,23 @@ BEGIN_PROVIDER [ double precision, u12_grad1_u12_j1b_grad1_j1b_test, (ao_num, ao
do j = 1, ao_num do j = 1, ao_num
do i = 1, ao_num do i = 1, ao_num
tmp9 = int2_u_grad1u_j1b2_test(i,j,ipoint) tmp9 = int2_u_grad1u_env2_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) & u12_grad1_u12_env_grad1_env_test(i,j,ipoint) = tmp6 * tmp9 + tmp3 * int2_u_grad1u_x_env2_test(i,j,ipoint,1) &
+ tmp7 * tmp9 + tmp4 * int2_u_grad1u_x_j1b2_test(i,j,ipoint,2) & + tmp7 * tmp9 + tmp4 * int2_u_grad1u_x_env2_test(i,j,ipoint,2) &
+ tmp8 * tmp9 + tmp5 * int2_u_grad1u_x_j1b2_test(i,j,ipoint,3) + tmp8 * tmp9 + tmp5 * int2_u_grad1u_x_env2_test(i,j,ipoint,3)
enddo enddo
enddo enddo
enddo enddo
call wall_time(time1) call wall_time(time1)
print*, ' Wall time for u12_grad1_u12_j1b_grad1_j1b_test = ', time1 - time0 print*, ' Wall time for u12_grad1_u12_env_grad1_env_test (min) = ', (time1 - time0) / 60.d0
END_PROVIDER END_PROVIDER
! --- ! ---
BEGIN_PROVIDER [ double precision, grad12_j12_test, (ao_num, ao_num, n_points_final_grid) ] BEGIN_PROVIDER [double precision, grad12_j12_test, (ao_num, ao_num, n_points_final_grid)]
implicit none implicit none
integer :: ipoint, i, j, m, igauss integer :: ipoint, i, j, m, igauss
@ -260,46 +262,32 @@ BEGIN_PROVIDER [ double precision, grad12_j12_test, (ao_num, ao_num, n_points_fi
double precision :: tmp1 double precision :: tmp1
double precision :: time0, time1 double precision :: time0, time1
double precision, external :: overlap_gauss_r12_ao double precision, external :: overlap_gauss_r12_ao
provide int2_grad1u2_grad2u2_j1b2_test
provide int2_grad1u2_grad2u2_env2_test
print*, ' providing grad12_j12_test ...' print*, ' providing grad12_j12_test ...'
call wall_time(time0) call wall_time(time0)
PROVIDE j1b_type if((j2e_type .eq. "Mu") .and. (env_type .eq. "Prod_Gauss")) then
if(j1b_type .eq. 3) then
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
tmp1 = v_1b(ipoint) tmp1 = env_val(ipoint)
tmp1 = tmp1 * tmp1 tmp1 = tmp1 * tmp1
do j = 1, ao_num do j = 1, ao_num
do i = 1, ao_num do i = 1, ao_num
grad12_j12_test(i,j,ipoint) = tmp1 * int2_grad1u2_grad2u2_j1b2_test(i,j,ipoint) grad12_j12_test(i,j,ipoint) = tmp1 * int2_grad1u2_grad2u2_env2_test(i,j,ipoint)
enddo enddo
enddo enddo
enddo enddo
else else
grad12_j12_test = 0.d0 print *, ' Error in grad12_j12_test: Unknown Jastrow'
do ipoint = 1, n_points_final_grid stop
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 endif
call wall_time(time1) call wall_time(time1)
print*, ' Wall time for grad12_j12_test = ', time1 - time0 print*, ' Wall time for grad12_j12_test (min) = ', (time1 - time0) / 60.d0
END_PROVIDER END_PROVIDER

460
plugins/local/non_h_ints_mu/j12_nucl_utils.irp.f
View File

@ -1,14 +1,18 @@
! --- ! ---
BEGIN_PROVIDER [ double precision, v_1b, (n_points_final_grid)] BEGIN_PROVIDER [double precision, env_val, (n_points_final_grid)]
implicit none implicit none
integer :: ipoint, i, j, phase integer :: ipoint, i, j, phase
double precision :: x, y, z, dx, dy, dz double precision :: x, y, z, dx, dy, dz
double precision :: a, d, e, fact_r double precision :: a, d, e, fact_r
if(j1b_type .eq. 3) then if(env_type .eq. "None") then
env_val = 1.d0
elseif(env_type .eq. "Prod_Gauss") then
! v(r) = \Pi_{a} [1 - \exp(-\alpha_a (r - r_a)^2)] ! v(r) = \Pi_{a} [1 - \exp(-\alpha_a (r - r_a)^2)]
@ -20,7 +24,7 @@ BEGIN_PROVIDER [ double precision, v_1b, (n_points_final_grid)]
fact_r = 1.d0 fact_r = 1.d0
do j = 1, nucl_num do j = 1, nucl_num
a = j1b_pen(j) a = env_expo(j)
dx = x - nucl_coord(j,1) dx = x - nucl_coord(j,1)
dy = y - nucl_coord(j,2) dy = y - nucl_coord(j,2)
dz = z - nucl_coord(j,3) dz = z - nucl_coord(j,3)
@ -30,10 +34,10 @@ BEGIN_PROVIDER [ double precision, v_1b, (n_points_final_grid)]
fact_r = fact_r * e fact_r = fact_r * e
enddo enddo
v_1b(ipoint) = fact_r env_val(ipoint) = fact_r
enddo enddo
elseif(j1b_type .eq. 4) then elseif(env_type .eq. "Sum_Gauss") then
! v(r) = 1 - \sum_{a} \beta_a \exp(-\alpha_a (r - r_a)^2) ! v(r) = 1 - \sum_{a} \beta_a \exp(-\alpha_a (r - r_a)^2)
@ -45,21 +49,21 @@ BEGIN_PROVIDER [ double precision, v_1b, (n_points_final_grid)]
fact_r = 1.d0 fact_r = 1.d0
do j = 1, nucl_num do j = 1, nucl_num
a = j1b_pen(j) a = env_expo(j)
dx = x - nucl_coord(j,1) dx = x - nucl_coord(j,1)
dy = y - nucl_coord(j,2) dy = y - nucl_coord(j,2)
dz = z - nucl_coord(j,3) dz = z - nucl_coord(j,3)
d = dx*dx + dy*dy + dz*dz d = dx*dx + dy*dy + dz*dz
fact_r = fact_r - j1b_pen_coef(j) * dexp(-a*d) fact_r = fact_r - env_coef(j) * dexp(-a*d)
enddo enddo
v_1b(ipoint) = fact_r env_val(ipoint) = fact_r
enddo enddo
else else
print*, 'j1b_type = ', j1b_type, 'is not implemented for v_1b' print *, ' Error in env_val: Unknown env_type = ', env_type
stop stop
endif endif
@ -68,7 +72,7 @@ END_PROVIDER
! --- ! ---
BEGIN_PROVIDER [double precision, v_1b_grad, (3, n_points_final_grid)] BEGIN_PROVIDER [double precision, env_grad, (3, n_points_final_grid)]
implicit none implicit none
integer :: ipoint, i, j, phase integer :: ipoint, i, j, phase
@ -77,9 +81,11 @@ BEGIN_PROVIDER [double precision, v_1b_grad, (3, n_points_final_grid)]
double precision :: fact_x, fact_y, fact_z double precision :: fact_x, fact_y, fact_z
double precision :: ax_der, ay_der, az_der, a_expo double precision :: ax_der, ay_der, az_der, a_expo
PROVIDE j1b_type if(env_type .eq. "None") then
if(j1b_type .eq. 3) then env_grad = 0.d0
elseif(env_type .eq. "Prod_Gauss") then
! v(r) = \Pi_{a} [1 - \exp(-\alpha_a (r - r_a)^2)] ! v(r) = \Pi_{a} [1 - \exp(-\alpha_a (r - r_a)^2)]
@ -92,7 +98,7 @@ BEGIN_PROVIDER [double precision, v_1b_grad, (3, n_points_final_grid)]
fact_x = 0.d0 fact_x = 0.d0
fact_y = 0.d0 fact_y = 0.d0
fact_z = 0.d0 fact_z = 0.d0
do i = 1, List_all_comb_b2_size do i = 1, List_env1s_size
phase = 0 phase = 0
a_expo = 0.d0 a_expo = 0.d0
@ -100,12 +106,12 @@ BEGIN_PROVIDER [double precision, v_1b_grad, (3, n_points_final_grid)]
ay_der = 0.d0 ay_der = 0.d0
az_der = 0.d0 az_der = 0.d0
do j = 1, nucl_num do j = 1, nucl_num
a = dble(List_all_comb_b2(j,i)) * j1b_pen(j) a = dble(List_env1s(j,i)) * env_expo(j)
dx = x - nucl_coord(j,1) dx = x - nucl_coord(j,1)
dy = y - nucl_coord(j,2) dy = y - nucl_coord(j,2)
dz = z - nucl_coord(j,3) dz = z - nucl_coord(j,3)
phase += List_all_comb_b2(j,i) phase += List_env1s(j,i)
a_expo += a * (dx*dx + dy*dy + dz*dz) a_expo += a * (dx*dx + dy*dy + dz*dz)
ax_der += a * dx ax_der += a * dx
ay_der += a * dy ay_der += a * dy
@ -118,12 +124,12 @@ BEGIN_PROVIDER [double precision, v_1b_grad, (3, n_points_final_grid)]
fact_z += e * az_der fact_z += e * az_der
enddo enddo
v_1b_grad(1,ipoint) = fact_x env_grad(1,ipoint) = fact_x
v_1b_grad(2,ipoint) = fact_y env_grad(2,ipoint) = fact_y
v_1b_grad(3,ipoint) = fact_z env_grad(3,ipoint) = fact_z
enddo enddo
elseif(j1b_type .eq. 4) then elseif(env_type .eq. "Sum_Gauss") then
! v(r) = 1 - \sum_{a} \beta_a \exp(-\alpha_a (r - r_a)^2) ! v(r) = 1 - \sum_{a} \beta_a \exp(-\alpha_a (r - r_a)^2)
@ -143,22 +149,22 @@ BEGIN_PROVIDER [double precision, v_1b_grad, (3, n_points_final_grid)]
dz = z - nucl_coord(j,3) dz = z - nucl_coord(j,3)
r2 = dx*dx + dy*dy + dz*dz r2 = dx*dx + dy*dy + dz*dz
a = j1b_pen(j) a = env_expo(j)
e = a * j1b_pen_coef(j) * dexp(-a * r2) e = a * env_coef(j) * dexp(-a * r2)
ax_der += e * dx ax_der += e * dx
ay_der += e * dy ay_der += e * dy
az_der += e * dz az_der += e * dz
enddo enddo
v_1b_grad(1,ipoint) = 2.d0 * ax_der env_grad(1,ipoint) = 2.d0 * ax_der
v_1b_grad(2,ipoint) = 2.d0 * ay_der env_grad(2,ipoint) = 2.d0 * ay_der
v_1b_grad(3,ipoint) = 2.d0 * az_der env_grad(3,ipoint) = 2.d0 * az_der
enddo enddo
else else
print*, 'j1b_type = ', j1b_type, 'is not implemented' print *, ' Error in env_grad: Unknown env_type = ', env_type
stop stop
endif endif
@ -167,126 +173,8 @@ END_PROVIDER
! --- ! ---
BEGIN_PROVIDER [ double precision, v_1b_lapl, (n_points_final_grid)] BEGIN_PROVIDER [double precision, env_square_grad, (n_points_final_grid,3)]
&BEGIN_PROVIDER [double precision, env_square_lapl, (n_points_final_grid) ]
implicit none
integer :: ipoint, i, j, phase
double precision :: x, y, z, dx, dy, dz
double precision :: a, 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
! ---
BEGIN_PROVIDER [double precision, v_1b_square_grad, (n_points_final_grid,3)]
&BEGIN_PROVIDER [double precision, v_1b_square_lapl, (n_points_final_grid) ]
implicit none implicit none
integer :: ipoint, i integer :: ipoint, i
@ -294,42 +182,56 @@ END_PROVIDER
double precision :: coef, expo, a_expo, tmp double precision :: coef, expo, a_expo, tmp
double precision :: fact_x, fact_y, fact_z, fact_r double precision :: fact_x, fact_y, fact_z, fact_r
PROVIDE List_all_comb_b3_coef List_all_comb_b3_expo List_all_comb_b3_cent PROVIDE List_env1s_square_coef List_env1s_square_expo List_env1s_square_cent
do ipoint = 1, n_points_final_grid if(env_type .eq. "None") then
x = final_grid_points(1,ipoint) env_square_grad = 0.d0
y = final_grid_points(2,ipoint) env_square_lapl = 0.d0
z = final_grid_points(3,ipoint)
fact_x = 0.d0 elseif((env_type .eq. "Prod_Gauss") .or. (env_type .eq. "Sum_Gauss")) then
fact_y = 0.d0
fact_z = 0.d0
fact_r = 0.d0
do i = 1, List_all_comb_b3_size
coef = List_all_comb_b3_coef(i) do ipoint = 1, n_points_final_grid
expo = List_all_comb_b3_expo(i)
dx = x - List_all_comb_b3_cent(1,i) x = final_grid_points(1,ipoint)
dy = y - List_all_comb_b3_cent(2,i) y = final_grid_points(2,ipoint)
dz = z - List_all_comb_b3_cent(3,i) z = final_grid_points(3,ipoint)
r2 = dx * dx + dy * dy + dz * dz
a_expo = expo * r2 fact_x = 0.d0
tmp = coef * expo * dexp(-a_expo) fact_y = 0.d0
fact_z = 0.d0
fact_r = 0.d0
do i = 1, List_env1s_square_size
fact_x += tmp * dx coef = List_env1s_square_coef(i)
fact_y += tmp * dy expo = List_env1s_square_expo(i)
fact_z += tmp * dz
fact_r += tmp * (3.d0 - 2.d0 * a_expo) dx = x - List_env1s_square_cent(1,i)
dy = y - List_env1s_square_cent(2,i)
dz = z - List_env1s_square_cent(3,i)
r2 = dx * dx + dy * dy + dz * dz
a_expo = expo * r2
tmp = coef * expo * dexp(-a_expo)
fact_x += tmp * dx
fact_y += tmp * dy
fact_z += tmp * dz
fact_r += tmp * (3.d0 - 2.d0 * a_expo)
enddo
env_square_grad(ipoint,1) = -2.d0 * fact_x
env_square_grad(ipoint,2) = -2.d0 * fact_y
env_square_grad(ipoint,3) = -2.d0 * fact_z
env_square_lapl(ipoint) = -2.d0 * fact_r
enddo enddo
v_1b_square_grad(ipoint,1) = -2.d0 * fact_x else
v_1b_square_grad(ipoint,2) = -2.d0 * fact_y
v_1b_square_grad(ipoint,3) = -2.d0 * fact_z print *, ' Error in env_val_square_grad & env_val_square_lapl: Unknown env_type = ', env_type
v_1b_square_lapl(ipoint) = -2.d0 * fact_r stop
enddo
endif
END_PROVIDER END_PROVIDER
@ -348,7 +250,7 @@ double precision function j12_mu_r12(r12)
j12_mu_r12 = 0.5d0 * r12 * (1.d0 - derf(mu_r12)) - inv_sq_pi_2 * dexp(-mu_r12*mu_r12) / mu_erf j12_mu_r12 = 0.5d0 * r12 * (1.d0 - derf(mu_r12)) - inv_sq_pi_2 * dexp(-mu_r12*mu_r12) / mu_erf
return return
end function j12_mu_r12 end
! --- ! ---
@ -361,7 +263,7 @@ double precision function jmu_modif(r1, r2)
jmu_modif = j12_mu(r1, r2) * j12_nucl(r1, r2) jmu_modif = j12_mu(r1, r2) * j12_nucl(r1, r2)
return return
end function jmu_modif end
! --- ! ---
@ -385,7 +287,7 @@ double precision function j12_mu_gauss(r1, r2)
enddo enddo
return return
end function j12_mu_gauss end
! --- ! ---
@ -393,140 +295,138 @@ double precision function j12_nucl(r1, r2)
implicit none implicit none
double precision, intent(in) :: r1(3), r2(3) double precision, intent(in) :: r1(3), r2(3)
double precision, external :: j1b_nucl double precision, external :: env_nucl
j12_nucl = j1b_nucl(r1) * j1b_nucl(r2) j12_nucl = env_nucl(r1) * env_nucl(r2)
return return
end function j12_nucl end
! --- ! ---
! --------------------------------------------------------------------------------------- double precision function grad_x_env_nucl_num(r)
double precision function grad_x_j1b_nucl_num(r)
implicit none implicit none
double precision, intent(in) :: r(3) double precision, intent(in) :: r(3)
double precision :: r_eps(3), eps, fp, fm, delta double precision :: r_eps(3), eps, fp, fm, delta
double precision, external :: j1b_nucl double precision, external :: env_nucl
eps = 1d-6 eps = 1d-6
r_eps = r r_eps = r
delta = max(eps, dabs(eps*r(1))) delta = max(eps, dabs(eps*r(1)))
r_eps(1) = r_eps(1) + delta r_eps(1) = r_eps(1) + delta
fp = j1b_nucl(r_eps) fp = env_nucl(r_eps)
r_eps(1) = r_eps(1) - 2.d0 * delta r_eps(1) = r_eps(1) - 2.d0 * delta
fm = j1b_nucl(r_eps) fm = env_nucl(r_eps)
grad_x_j1b_nucl_num = 0.5d0 * (fp - fm) / delta grad_x_env_nucl_num = 0.5d0 * (fp - fm) / delta
return return
end function grad_x_j1b_nucl_num end
double precision function grad_y_j1b_nucl_num(r) ! ---
double precision function grad_y_env_nucl_num(r)
implicit none implicit none
double precision, intent(in) :: r(3) double precision, intent(in) :: r(3)
double precision :: r_eps(3), eps, fp, fm, delta double precision :: r_eps(3), eps, fp, fm, delta
double precision, external :: j1b_nucl double precision, external :: env_nucl
eps = 1d-6 eps = 1d-6
r_eps = r r_eps = r
delta = max(eps, dabs(eps*r(2))) delta = max(eps, dabs(eps*r(2)))
r_eps(2) = r_eps(2) + delta r_eps(2) = r_eps(2) + delta
fp = j1b_nucl(r_eps) fp = env_nucl(r_eps)
r_eps(2) = r_eps(2) - 2.d0 * delta r_eps(2) = r_eps(2) - 2.d0 * delta
fm = j1b_nucl(r_eps) fm = env_nucl(r_eps)
grad_y_j1b_nucl_num = 0.5d0 * (fp - fm) / delta grad_y_env_nucl_num = 0.5d0 * (fp - fm) / delta
return return
end function grad_y_j1b_nucl_num end
double precision function grad_z_j1b_nucl_num(r) ! ---
double precision function grad_z_env_nucl_num(r)
implicit none implicit none
double precision, intent(in) :: r(3) double precision, intent(in) :: r(3)
double precision :: r_eps(3), eps, fp, fm, delta double precision :: r_eps(3), eps, fp, fm, delta
double precision, external :: j1b_nucl double precision, external :: env_nucl
eps = 1d-6 eps = 1d-6
r_eps = r r_eps = r
delta = max(eps, dabs(eps*r(3))) delta = max(eps, dabs(eps*r(3)))
r_eps(3) = r_eps(3) + delta r_eps(3) = r_eps(3) + delta
fp = j1b_nucl(r_eps) fp = env_nucl(r_eps)
r_eps(3) = r_eps(3) - 2.d0 * delta r_eps(3) = r_eps(3) - 2.d0 * delta
fm = j1b_nucl(r_eps) fm = env_nucl(r_eps)
grad_z_j1b_nucl_num = 0.5d0 * (fp - fm) / delta grad_z_env_nucl_num = 0.5d0 * (fp - fm) / delta
return return
end function grad_z_j1b_nucl_num end
! ---------------------------------------------------------------------------------------
! --- ! ---
double precision function lapl_j1b_nucl(r) double precision function lapl_env_nucl(r)
implicit none implicit none
double precision, intent(in) :: r(3) double precision, intent(in) :: r(3)
double precision :: r_eps(3), eps, fp, fm, delta double precision :: r_eps(3), eps, fp, fm, delta
double precision, external :: grad_x_j1b_nucl_num double precision, external :: grad_x_env_nucl_num
double precision, external :: grad_y_j1b_nucl_num double precision, external :: grad_y_env_nucl_num
double precision, external :: grad_z_j1b_nucl_num double precision, external :: grad_z_env_nucl_num
eps = 1d-5 eps = 1d-5
r_eps = r r_eps = r
lapl_j1b_nucl = 0.d0 lapl_env_nucl = 0.d0
! --- ! ---
delta = max(eps, dabs(eps*r(1))) delta = max(eps, dabs(eps*r(1)))
r_eps(1) = r_eps(1) + delta r_eps(1) = r_eps(1) + delta
fp = grad_x_j1b_nucl_num(r_eps) fp = grad_x_env_nucl_num(r_eps)
r_eps(1) = r_eps(1) - 2.d0 * delta r_eps(1) = r_eps(1) - 2.d0 * delta
fm = grad_x_j1b_nucl_num(r_eps) fm = grad_x_env_nucl_num(r_eps)
r_eps(1) = r_eps(1) + delta r_eps(1) = r_eps(1) + delta
lapl_j1b_nucl += 0.5d0 * (fp - fm) / delta lapl_env_nucl += 0.5d0 * (fp - fm) / delta
! --- ! ---
delta = max(eps, dabs(eps*r(2))) delta = max(eps, dabs(eps*r(2)))
r_eps(2) = r_eps(2) + delta r_eps(2) = r_eps(2) + delta
fp = grad_y_j1b_nucl_num(r_eps) fp = grad_y_env_nucl_num(r_eps)
r_eps(2) = r_eps(2) - 2.d0 * delta r_eps(2) = r_eps(2) - 2.d0 * delta
fm = grad_y_j1b_nucl_num(r_eps) fm = grad_y_env_nucl_num(r_eps)
r_eps(2) = r_eps(2) + delta r_eps(2) = r_eps(2) + delta
lapl_j1b_nucl += 0.5d0 * (fp - fm) / delta lapl_env_nucl += 0.5d0 * (fp - fm) / delta
! --- ! ---
delta = max(eps, dabs(eps*r(3))) delta = max(eps, dabs(eps*r(3)))
r_eps(3) = r_eps(3) + delta r_eps(3) = r_eps(3) + delta
fp = grad_z_j1b_nucl_num(r_eps) fp = grad_z_env_nucl_num(r_eps)
r_eps(3) = r_eps(3) - 2.d0 * delta r_eps(3) = r_eps(3) - 2.d0 * delta
fm = grad_z_j1b_nucl_num(r_eps) fm = grad_z_env_nucl_num(r_eps)
r_eps(3) = r_eps(3) + delta r_eps(3) = r_eps(3) + delta
lapl_j1b_nucl += 0.5d0 * (fp - fm) / delta lapl_env_nucl += 0.5d0 * (fp - fm) / delta
! --- ! ---
return return
end function lapl_j1b_nucl end
! --- ! ---
! ---------------------------------------------------------------------------------------
double precision function grad1_x_jmu_modif(r1, r2) double precision function grad1_x_jmu_modif(r1, r2)
implicit none implicit none
@ -546,7 +446,9 @@ double precision function grad1_x_jmu_modif(r1, r2)
grad1_x_jmu_modif = 0.5d0 * (fp - fm) / delta grad1_x_jmu_modif = 0.5d0 * (fp - fm) / delta
return return
end function grad1_x_jmu_modif end
! ---
double precision function grad1_y_jmu_modif(r1, r2) double precision function grad1_y_jmu_modif(r1, r2)
@ -567,7 +469,9 @@ double precision function grad1_y_jmu_modif(r1, r2)
grad1_y_jmu_modif = 0.5d0 * (fp - fm) / delta grad1_y_jmu_modif = 0.5d0 * (fp - fm) / delta
return return
end function grad1_y_jmu_modif end
! ---
double precision function grad1_z_jmu_modif(r1, r2) double precision function grad1_z_jmu_modif(r1, r2)
@ -588,14 +492,10 @@ double precision function grad1_z_jmu_modif(r1, r2)
grad1_z_jmu_modif = 0.5d0 * (fp - fm) / delta grad1_z_jmu_modif = 0.5d0 * (fp - fm) / delta
return return
end function grad1_z_jmu_modif end
! ---------------------------------------------------------------------------------------
! --- ! ---
! ---------------------------------------------------------------------------------------
double precision function grad1_x_j12_mu_num(r1, r2) double precision function grad1_x_j12_mu_num(r1, r2)
implicit none implicit none
@ -615,7 +515,9 @@ double precision function grad1_x_j12_mu_num(r1, r2)
grad1_x_j12_mu_num = 0.5d0 * (fp - fm) / delta grad1_x_j12_mu_num = 0.5d0 * (fp - fm) / delta
return return
end function grad1_x_j12_mu_num end
! ---
double precision function grad1_y_j12_mu_num(r1, r2) double precision function grad1_y_j12_mu_num(r1, r2)
@ -636,7 +538,9 @@ double precision function grad1_y_j12_mu_num(r1, r2)
grad1_y_j12_mu_num = 0.5d0 * (fp - fm) / delta grad1_y_j12_mu_num = 0.5d0 * (fp - fm) / delta
return return
end function grad1_y_j12_mu_num end
! ---
double precision function grad1_z_j12_mu_num(r1, r2) double precision function grad1_z_j12_mu_num(r1, r2)
@ -657,9 +561,9 @@ double precision function grad1_z_j12_mu_num(r1, r2)
grad1_z_j12_mu_num = 0.5d0 * (fp - fm) / delta grad1_z_j12_mu_num = 0.5d0 * (fp - fm) / delta
return return
end function grad1_z_j12_mu_num end
! --------------------------------------------------------------------------------------- ! ---
subroutine grad1_jmu_modif_num(r1, r2, grad) subroutine grad1_jmu_modif_num(r1, r2, grad)
@ -671,103 +575,23 @@ subroutine grad1_jmu_modif_num(r1, r2, grad)
double precision :: tmp0, tmp1, tmp2, grad_u12(3) double precision :: tmp0, tmp1, tmp2, grad_u12(3)
double precision, external :: j12_mu double precision, external :: j12_mu
double precision, external :: j1b_nucl double precision, external :: env_nucl
double precision, external :: grad_x_j1b_nucl_num double precision, external :: grad_x_env_nucl_num
double precision, external :: grad_y_j1b_nucl_num double precision, external :: grad_y_env_nucl_num
double precision, external :: grad_z_j1b_nucl_num double precision, external :: grad_z_env_nucl_num
call grad1_j12_mu(r1, r2, grad_u12) call grad1_j12_mu(r1, r2, grad_u12)
tmp0 = j1b_nucl(r1) tmp0 = env_nucl(r1)
tmp1 = j1b_nucl(r2) tmp1 = env_nucl(r2)
tmp2 = j12_mu(r1, r2) tmp2 = j12_mu(r1, r2)
grad(1) = (tmp0 * grad_u12(1) + tmp2 * grad_x_j1b_nucl_num(r1)) * tmp1 grad(1) = (tmp0 * grad_u12(1) + tmp2 * grad_x_env_nucl_num(r1)) * tmp1
grad(2) = (tmp0 * grad_u12(2) + tmp2 * grad_y_j1b_nucl_num(r1)) * tmp1 grad(2) = (tmp0 * grad_u12(2) + tmp2 * grad_y_env_nucl_num(r1)) * tmp1
grad(3) = (tmp0 * grad_u12(3) + tmp2 * grad_z_j1b_nucl_num(r1)) * tmp1 grad(3) = (tmp0 * grad_u12(3) + tmp2 * grad_z_env_nucl_num(r1)) * tmp1
return return
end subroutine grad1_jmu_modif_num end
! --- ! ---
subroutine get_tchint_rsdft_jastrow(x, y, dj)
implicit none
double precision, intent(in) :: x(3), y(3)
double precision, intent(out) :: dj(3)
integer :: at
double precision :: a, mu_tmp, inv_sq_pi_2
double precision :: tmp_x, tmp_y, tmp_z, tmp
double precision :: dx2, dy2, pos(3), dxy, dxy2
double precision :: v1b_x, v1b_y
double precision :: u2b, grad1_u2b(3), grad1_v1b(3)
PROVIDE mu_erf
inv_sq_pi_2 = 0.5d0 / dsqrt(dacos(-1.d0))
dj = 0.d0
! double precision, external :: j12_mu, j1b_nucl
! v1b_x = j1b_nucl(x)
! v1b_y = j1b_nucl(y)
! call grad1_j1b_nucl(x, grad1_v1b)
! u2b = j12_mu(x, y)
! call grad1_j12_mu(x, y, grad1_u2b)
! 1b terms
v1b_x = 1.d0
v1b_y = 1.d0
tmp_x = 0.d0
tmp_y = 0.d0
tmp_z = 0.d0
do at = 1, nucl_num
a = j1b_pen(at)
pos(1) = nucl_coord(at,1)
pos(2) = nucl_coord(at,2)
pos(3) = nucl_coord(at,3)
dx2 = sum((x-pos)**2)
dy2 = sum((y-pos)**2)
tmp = dexp(-a*dx2) * a
v1b_x = v1b_x - dexp(-a*dx2)
v1b_y = v1b_y - dexp(-a*dy2)
tmp_x = tmp_x + tmp * (x(1) - pos(1))
tmp_y = tmp_y + tmp * (x(2) - pos(2))
tmp_z = tmp_z + tmp * (x(3) - pos(3))
end do
grad1_v1b(1) = 2.d0 * tmp_x
grad1_v1b(2) = 2.d0 * tmp_y
grad1_v1b(3) = 2.d0 * tmp_z
! 2b terms
dxy2 = sum((x-y)**2)
dxy = dsqrt(dxy2)
mu_tmp = mu_erf * dxy
u2b = 0.5d0 * dxy * (1.d0 - derf(mu_tmp)) - inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / mu_erf
if(dxy .lt. 1d-8) then
grad1_u2b(1) = 0.d0
grad1_u2b(2) = 0.d0
grad1_u2b(3) = 0.d0
else
tmp = 0.5d0 * (1.d0 - derf(mu_tmp)) / dxy
grad1_u2b(1) = tmp * (x(1) - y(1))
grad1_u2b(2) = tmp * (x(2) - y(2))
grad1_u2b(3) = tmp * (x(3) - y(3))
endif
dj(1) = (grad1_u2b(1) * v1b_x + u2b * grad1_v1b(1)) * v1b_y
dj(2) = (grad1_u2b(2) * v1b_x + u2b * grad1_v1b(2)) * v1b_y
dj(3) = (grad1_u2b(3) * v1b_x + u2b * grad1_v1b(3)) * v1b_y
return
end subroutine get_tchint_rsdft_jastrow
! ---

450
plugins/local/non_h_ints_mu/jast_1e.irp.f Normal file
View File

@ -0,0 +1,450 @@
! ---
BEGIN_PROVIDER [double precision, j1e_val, (n_points_final_grid)]
implicit none
integer :: ipoint, i, j, p
double precision :: x, y, z, dx, dy, dz, d2
double precision :: a, c, tmp
double precision :: time0, time1
PROVIDE j1e_type
call wall_time(time0)
print*, ' providing j1e_val ...'
if(j1e_type .eq. "None") then
j1e_val = 0.d0
elseif(j1e_type .eq. "Gauss") then
! \sum_{A} \sum_p c_{p_A} \exp(-\alpha_{p_A} (r - R_A)^2)
PROVIDE j1e_size j1e_coef j1e_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)
tmp = 0.d0
do j = 1, nucl_num
dx = x - nucl_coord(j,1)
dy = y - nucl_coord(j,2)
dz = z - nucl_coord(j,3)
d2 = dx*dx + dy*dy + dz*dz
do p = 1, j1e_size
c = j1e_coef(p,j)
a = j1e_expo(p,j)
tmp = tmp + c * dexp(-a*d2)
enddo
enddo
j1e_val(ipoint) = tmp
enddo
else
print *, ' Error in j1e_val: Unknown j1e_type = ', j1e_type
stop
endif
call wall_time(time1)
print*, ' Wall time for j1e_val (min) = ', (time1 - time0) / 60.d0
call print_memory_usage()
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, j1e_gradx, (n_points_final_grid)]
&BEGIN_PROVIDER [double precision, j1e_grady, (n_points_final_grid)]
&BEGIN_PROVIDER [double precision, j1e_gradz, (n_points_final_grid)]
implicit none
integer :: ipoint, i, j, ij, p
integer :: ierr
logical :: exists
double precision :: x, y, z, dx, dy, dz, d2
double precision :: a, c, g, tmp_x, tmp_y, tmp_z
double precision :: cx, cy, cz
double precision :: time0, time1
double precision, allocatable :: Pa(:,:), Pb(:,:), Pt(:,:)
double precision, allocatable :: coef_fit(:), coef_fit2(:), coef_fit3(:,:)
PROVIDE j1e_type
call wall_time(time0)
print*, ' providing j1e_grad ...'
if(j1e_type .eq. "None") then
j1e_gradx = 0.d0
j1e_grady = 0.d0
j1e_gradz = 0.d0
elseif(j1e_type .eq. "Gauss") then
! - \sum_{A} (r - R_A) \sum_p c_{p_A} \exp(-\alpha_{p_A} (r - R_A)^2)
PROVIDE j1e_size j1e_coef j1e_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)
tmp_x = 0.d0
tmp_y = 0.d0
tmp_z = 0.d0
do j = 1, nucl_num
dx = x - nucl_coord(j,1)
dy = y - nucl_coord(j,2)
dz = z - nucl_coord(j,3)
d2 = dx*dx + dy*dy + dz*dz
do p = 1, j1e_size
c = j1e_coef(p,j)
a = j1e_expo(p,j)
g = c * a * dexp(-a*d2)
tmp_x = tmp_x + g * dx
tmp_y = tmp_y + g * dy
tmp_z = tmp_z + g * dz
enddo
enddo
j1e_gradx(ipoint) = -2.d0 * tmp_x
j1e_grady(ipoint) = -2.d0 * tmp_y
j1e_gradz(ipoint) = -2.d0 * tmp_z
enddo
elseif(j1e_type .eq. "Charge_Harmonizer") then
! -[(N-1)/2N] x \sum_{\mu,\nu} P_{\mu,\nu} \int dr2 [\grad_r1 J_2e(r1,r2)] \phi_\mu(r2) \phi_nu(r2)
PROVIDE elec_alpha_num elec_beta_num elec_num
PROVIDE mo_coef
PROVIDE int2_grad1_u2e_ao
allocate(Pa(ao_num,ao_num), Pb(ao_num,ao_num), Pt(ao_num,ao_num))
call dgemm( 'N', 'T', ao_num, ao_num, elec_alpha_num, 1.d0 &
, mo_coef, size(mo_coef, 1), mo_coef, size(mo_coef, 1) &
, 0.d0, Pa, size(Pa, 1))
if(elec_alpha_num .eq. elec_beta_num) then
Pb = Pa
else
call dgemm( 'N', 'T', ao_num, ao_num, elec_beta_num, 1.d0 &
, mo_coef, size(mo_coef, 1), mo_coef, size(mo_coef, 1) &
, 0.d0, Pb, size(Pb, 1))
endif
Pt = Pa + Pb
g = -0.5d0 * (dble(elec_num) - 1.d0) / dble(elec_num)
call dgemv("T", ao_num*ao_num, n_points_final_grid, g, int2_grad1_u2e_ao(1,1,1,1), ao_num*ao_num, Pt, 1, 0.d0, j1e_gradx, 1)
call dgemv("T", ao_num*ao_num, n_points_final_grid, g, int2_grad1_u2e_ao(1,1,1,2), ao_num*ao_num, Pt, 1, 0.d0, j1e_grady, 1)
call dgemv("T", ao_num*ao_num, n_points_final_grid, g, int2_grad1_u2e_ao(1,1,1,3), ao_num*ao_num, Pt, 1, 0.d0, j1e_gradz, 1)
FREE int2_grad1_u2e_ao
deallocate(Pa, Pb, Pt)
! elseif(j1e_type .eq. "Charge_Harmonizer_AO") then
!
! ! \grad_1 \sum_{\eta} C_{\eta} \chi_{\eta}
! ! where
! ! \chi_{\eta} are the AOs
! ! C_{\eta} are fitted to mimic (j1e_type .eq. "Charge_Harmonizer")
! !
! ! The - sign is in the parameters C_{\eta}
!
! PROVIDE aos_grad_in_r_array
!
! allocate(coef_fit(ao_num))
!
! if(mpi_master) then
! call ezfio_has_jastrow_j1e_coef_ao(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'
! call MPI_BCAST(coef_fit, ao_num, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
! if (ierr /= MPI_SUCCESS) then
! stop 'Unable to read j1e_coef_ao with MPI'
! endif
! IRP_ENDIF
! if(exists) then
! if(mpi_master) then
! write(6,'(A)') '.. >>>>> [ IO READ: j1e_coef_ao ] <<<<< ..'
! call ezfio_get_jastrow_j1e_coef_ao(coef_fit)
! IRP_IF MPI
! call MPI_BCAST(coef_fit, ao_num, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
! if (ierr /= MPI_SUCCESS) then
! stop 'Unable to read j1e_coef_ao with MPI'
! endif
! IRP_ENDIF
! endif
! else
!
! call get_j1e_coef_fit_ao(ao_num, coef_fit)
! call ezfio_set_jastrow_j1e_coef_ao(coef_fit)
!
! endif
!
! !$OMP PARALLEL &
! !$OMP DEFAULT (NONE) &
! !$OMP PRIVATE (i, ipoint, c) &
! !$OMP SHARED (n_points_final_grid, ao_num, &
! !$OMP aos_grad_in_r_array, coef_fit, &
! !$OMP j1e_gradx, j1e_grady, j1e_gradz)
! !$OMP DO SCHEDULE (static)
! do ipoint = 1, n_points_final_grid
!
! j1e_gradx(ipoint) = 0.d0
! j1e_grady(ipoint) = 0.d0
! j1e_gradz(ipoint) = 0.d0
! do i = 1, ao_num
! c = coef_fit(i)
! j1e_gradx(ipoint) = j1e_gradx(ipoint) + c * aos_grad_in_r_array(i,ipoint,1)
! j1e_grady(ipoint) = j1e_grady(ipoint) + c * aos_grad_in_r_array(i,ipoint,2)
! j1e_gradz(ipoint) = j1e_gradz(ipoint) + c * aos_grad_in_r_array(i,ipoint,3)
! enddo
! enddo
! !$OMP END DO
! !$OMP END PARALLEL
!
! deallocate(coef_fit)
!
! elseif(j1e_type .eq. "Charge_Harmonizer_AO2") then
!
! ! \grad_1 \sum_{\eta,\beta} C_{\eta,\beta} \chi_{\eta} \chi_{\beta}
! ! where
! ! \chi_{\eta} are the AOs
! ! C_{\eta,\beta} are fitted to mimic (j1e_type .eq. "Charge_Harmonizer")
! !
! ! The - sign is in the parameters C_{\eta,\beta}
!
! PROVIDE aos_grad_in_r_array
!
! allocate(coef_fit2(ao_num*ao_num))
!
! if(mpi_master) then
! call ezfio_has_jastrow_j1e_coef_ao2(exists)
! endif
! IRP_IF MPI_DEBUG
! print *, irp_here, mpi_rank
! call MPI_BARRIER(MPI_COMM_WORLD, ierr)
! IRP_ENDIF
! IRP_IF MPI
! call MPI_BCAST(coef_fit2, ao_num*ao_num, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
! if (ierr /= MPI_SUCCESS) then
! stop 'Unable to read j1e_coef_ao2 with MPI'
! endif
! IRP_ENDIF
! if(exists) then
! if(mpi_master) then
! write(6,'(A)') '.. >>>>> [ IO READ: j1e_coef_ao2 ] <<<<< ..'
! call ezfio_get_jastrow_j1e_coef_ao2(coef_fit2)
! IRP_IF MPI
! call MPI_BCAST(coef_fit2, ao_num*ao_num, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
! if (ierr /= MPI_SUCCESS) then
! stop 'Unable to read j1e_coef_ao2 with MPI'
! endif
! IRP_ENDIF
! endif
! else
!
! call get_j1e_coef_fit_ao2(ao_num*ao_num, coef_fit2)
! call ezfio_set_jastrow_j1e_coef_ao2(coef_fit2)
!
! endif
!
! !$OMP PARALLEL &
! !$OMP DEFAULT (NONE) &
! !$OMP PRIVATE (i, j, ij, ipoint, c) &
! !$OMP SHARED (n_points_final_grid, ao_num, &
! !$OMP aos_grad_in_r_array, coef_fit2, &
! !$OMP aos_in_r_array, j1e_gradx, j1e_grady, j1e_gradz)
! !$OMP DO SCHEDULE (static)
! do ipoint = 1, n_points_final_grid
!
! j1e_gradx(ipoint) = 0.d0
! j1e_grady(ipoint) = 0.d0
! j1e_gradz(ipoint) = 0.d0
!
! do i = 1, ao_num
! do j = 1, ao_num
! ij = (i-1)*ao_num + j
!
! c = coef_fit2(ij)
!
! j1e_gradx(ipoint) += c * (aos_in_r_array(i,ipoint) * aos_grad_in_r_array(j,ipoint,1) + aos_grad_in_r_array(i,ipoint,1) * aos_in_r_array(j,ipoint))
! j1e_grady(ipoint) += c * (aos_in_r_array(i,ipoint) * aos_grad_in_r_array(j,ipoint,2) + aos_grad_in_r_array(i,ipoint,2) * aos_in_r_array(j,ipoint))
! j1e_gradz(ipoint) += c * (aos_in_r_array(i,ipoint) * aos_grad_in_r_array(j,ipoint,3) + aos_grad_in_r_array(i,ipoint,3) * aos_in_r_array(j,ipoint))
! enddo
! enddo
! enddo
! !$OMP END DO
! !$OMP END PARALLEL
!
! deallocate(coef_fit2)
elseif(j1e_type .eq. "Charge_Harmonizer_AO") then
! \sum_{\eta} \vec{C}_{\eta} \chi_{\eta}
! where
! \chi_{\eta} are the AOs
! \vec{C}_{\eta} are fitted to mimic (j1e_type .eq. "Charge_Harmonizer")
!
! The - sign is in the parameters \vec{C}_{\eta}
PROVIDE aos_grad_in_r_array
allocate(coef_fit3(ao_num,3))
if(mpi_master) then
call ezfio_has_jastrow_j1e_coef_ao3(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'
call MPI_BCAST(coef_fit3, (ao_num*3), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read j1e_coef_ao3 with MPI'
endif
IRP_ENDIF
if(exists) then
if(mpi_master) then
write(6,'(A)') '.. >>>>> [ IO READ: j1e_coef_ao3 ] <<<<< ..'
call ezfio_get_jastrow_j1e_coef_ao3(coef_fit3)
IRP_IF MPI
call MPI_BCAST(coef_fit3, (ao_num*3), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read j1e_coef_ao3 with MPI'
endif
IRP_ENDIF
endif
else
call get_j1e_coef_fit_ao3(ao_num, coef_fit3)
call ezfio_set_jastrow_j1e_coef_ao3(coef_fit3)
endif
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, ipoint, cx, cy, cz) &
!$OMP SHARED (n_points_final_grid, ao_num, &
!$OMP aos_grad_in_r_array, coef_fit3, &
!$OMP aos_in_r_array, j1e_gradx, j1e_grady, j1e_gradz)
!$OMP DO SCHEDULE (static)
do ipoint = 1, n_points_final_grid
j1e_gradx(ipoint) = 0.d0
j1e_grady(ipoint) = 0.d0
j1e_gradz(ipoint) = 0.d0
do i = 1, ao_num
cx = coef_fit3(i,1)
cy = coef_fit3(i,2)
cz = coef_fit3(i,3)
j1e_gradx(ipoint) += cx * aos_in_r_array(i,ipoint)
j1e_grady(ipoint) += cy * aos_in_r_array(i,ipoint)
j1e_gradz(ipoint) += cz * aos_in_r_array(i,ipoint)
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
deallocate(coef_fit3)
else
print *, ' Error in j1e_grad: Unknown j1e_type = ', j1e_type
stop
endif
call wall_time(time1)
print*, ' Wall time for j1e_grad (min) = ', (time1 - time0) / 60.d0
call print_memory_usage()
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, j1e_lapl, (n_points_final_grid)]
implicit none
integer :: ipoint, i, j, p
double precision :: x, y, z, dx, dy, dz, d2
double precision :: a, c, g, tmp
if(j1e_type .eq. "None") then
j1e_lapl = 0.d0
elseif(j1e_type .eq. "Gauss") then
! - \sum_{A} (r - R_A) \sum_p c_{p_A} \exp(-\alpha_{p_A} (r - R_A)^2)
PROVIDE j1e_size j1e_coef j1e_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)
tmp = 0.d0
do j = 1, nucl_num
dx = x - nucl_coord(j,1)
dy = y - nucl_coord(j,2)
dz = z - nucl_coord(j,3)
d2 = dx*dx + dy*dy + dz*dz
do p = 1, j1e_size
c = j1e_coef(p,j)
a = j1e_expo(p,j)
g = c * a * dexp(-a*d2)
tmp = tmp + (2.d0 * a * d2 - 3.d0) * g
enddo
enddo
j1e_lapl(ipoint) = tmp
enddo
else
print *, ' Error in j1e_lapl: Unknown j1e_type = ', j1e_type
stop
endif
END_PROVIDER
! ---

394
plugins/local/non_h_ints_mu/jast_1e_utils.irp.f Normal file
View File

@ -0,0 +1,394 @@
! ---
subroutine get_j1e_coef_fit_ao(dim_fit, coef_fit)
implicit none
integer , intent(in) :: dim_fit
double precision, intent(out) :: coef_fit(dim_fit)
integer :: i, ipoint
double precision :: g
double precision :: t0, t1
double precision, allocatable :: A(:,:), b(:), A_inv(:,:)
double precision, allocatable :: Pa(:,:), Pb(:,:), Pt(:,:)
double precision, allocatable :: u1e_tmp(:)
PROVIDE j1e_type
PROVIDE int2_u2e_ao
PROVIDE elec_alpha_num elec_beta_num elec_num
PROVIDE mo_coef
PROVIDE ao_overlap
call wall_time(t0)
print*, ' PROVIDING the representation of 1e-Jastrow in AOs ... '
! --- --- ---
! get u1e(r)
allocate(Pa(ao_num,ao_num), Pb(ao_num,ao_num), Pt(ao_num,ao_num))
call dgemm( 'N', 'T', ao_num, ao_num, elec_alpha_num, 1.d0 &
, mo_coef, size(mo_coef, 1), mo_coef, size(mo_coef, 1) &
, 0.d0, Pa, size(Pa, 1))
if(elec_alpha_num .eq. elec_beta_num) then
Pb = Pa
else
call dgemm( 'N', 'T', ao_num, ao_num, elec_beta_num, 1.d0 &
, mo_coef, size(mo_coef, 1), mo_coef, size(mo_coef, 1) &
, 0.d0, Pb, size(Pb, 1))
endif
Pt = Pa + Pb
allocate(u1e_tmp(n_points_final_grid))
g = -0.5d0 * (dble(elec_num) - 1.d0) / dble(elec_num)
call dgemv("T", ao_num*ao_num, n_points_final_grid, g, int2_u2e_ao, ao_num*ao_num, Pt, 1, 0.d0, u1e_tmp, 1)
FREE int2_u2e_ao
deallocate(Pa, Pb, Pt)
! --- --- ---
! get A & b
allocate(A(ao_num,ao_num), b(ao_num))
A(1:ao_num,1:ao_num) = ao_overlap(1:ao_num,1:ao_num)
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, ipoint) &
!$OMP SHARED (n_points_final_grid, ao_num, &
!$OMP final_weight_at_r_vector, aos_in_r_array_transp, u1e_tmp, b)
!$OMP DO SCHEDULE (static)
do i = 1, ao_num
b(i) = 0.d0
do ipoint = 1, n_points_final_grid
b(i) = b(i) + final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * u1e_tmp(ipoint)
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
deallocate(u1e_tmp)
! --- --- ---
! solve Ax = b
allocate(A_inv(ao_num,ao_num))
call get_inverse(A, ao_num, ao_num, A_inv, ao_num)
deallocate(A)
! coef_fit = A_inv x b
call dgemv("N", ao_num, ao_num, 1.d0, A_inv, ao_num, b, 1, 0.d0, coef_fit, 1)
!integer :: j, k
!double precision :: tmp
!print *, ' check A_inv'
!do i = 1, ao_num
! tmp = 0.d0
! do j = 1, ao_num
! tmp += ao_overlap(i,j) * coef_fit(j)
! enddo
! tmp = tmp - b(i)
! print*, i, tmp
!enddo
deallocate(A_inv, b)
call wall_time(t1)
print*, ' END after (min) ', (t1-t0)/60.d0
return
end
! ---
subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
implicit none
integer , intent(in) :: dim_fit
double precision, intent(out) :: coef_fit(dim_fit)
integer :: i, j, k, l, ipoint
integer :: ij, kl
double precision :: g
double precision :: t0, t1
double precision, allocatable :: A(:,:), b(:), A_inv(:,:)
double precision, allocatable :: Pa(:,:), Pb(:,:), Pt(:,:)
double precision, allocatable :: u1e_tmp(:)
PROVIDE j1e_type
PROVIDE int2_u2e_ao
PROVIDE elec_alpha_num elec_beta_num elec_num
PROVIDE mo_coef
call wall_time(t0)
print*, ' PROVIDING the representation of 1e-Jastrow in AOs x AOx ... '
! --- --- ---
! get u1e(r)
allocate(Pa(ao_num,ao_num), Pb(ao_num,ao_num), Pt(ao_num,ao_num))
call dgemm( 'N', 'T', ao_num, ao_num, elec_alpha_num, 1.d0 &
, mo_coef, size(mo_coef, 1), mo_coef, size(mo_coef, 1) &
, 0.d0, Pa, size(Pa, 1))
if(elec_alpha_num .eq. elec_beta_num) then
Pb = Pa
else
call dgemm( 'N', 'T', ao_num, ao_num, elec_beta_num, 1.d0 &
, mo_coef, size(mo_coef, 1), mo_coef, size(mo_coef, 1) &
, 0.d0, Pb, size(Pb, 1))
endif
Pt = Pa + Pb
allocate(u1e_tmp(n_points_final_grid))
g = -0.5d0 * (dble(elec_num) - 1.d0) / dble(elec_num)
call dgemv("T", ao_num*ao_num, n_points_final_grid, g, int2_u2e_ao, ao_num*ao_num, Pt, 1, 0.d0, u1e_tmp, 1)
FREE int2_u2e_ao
deallocate(Pa, Pb, Pt)
! --- --- ---
! get A
allocate(A(ao_num*ao_num,ao_num*ao_num))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, k, l, ij, kl, ipoint) &
!$OMP SHARED (n_points_final_grid, ao_num, &
!$OMP final_weight_at_r_vector, aos_in_r_array_transp, A)
!$OMP DO COLLAPSE(2)
do k = 1, ao_num
do l = 1, ao_num
kl = (k-1)*ao_num + l
do i = 1, ao_num
do j = 1, ao_num
ij = (i-1)*ao_num + j
A(ij,kl) = 0.d0
do ipoint = 1, n_points_final_grid
A(ij,kl) += final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j) &
* aos_in_r_array_transp(ipoint,k) * aos_in_r_array_transp(ipoint,l)
enddo
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
print *, ' A'
do ij = 1, ao_num*ao_num
write(*, '(100000(f15.7))') (A(ij,kl), kl = 1, ao_num*ao_num)
enddo
! --- --- ---
! get b
allocate(b(ao_num*ao_num))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, ij, ipoint) &
!$OMP SHARED (n_points_final_grid, ao_num, &
!$OMP final_weight_at_r_vector, aos_in_r_array_transp, u1e_tmp, b)
!$OMP DO COLLAPSE(2)
do i = 1, ao_num
do j = 1, ao_num
ij = (i-1)*ao_num + j
b(ij) = 0.d0
do ipoint = 1, n_points_final_grid
b(ij) = b(ij) + final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j) * u1e_tmp(ipoint)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
deallocate(u1e_tmp)
! --- --- ---
! solve Ax = b
allocate(A_inv(ao_num*ao_num,ao_num*ao_num))
call get_inverse(A, ao_num*ao_num, ao_num*ao_num, A_inv, ao_num*ao_num)
integer :: mn
print *, ' check A_inv'
do ij = 1, ao_num*ao_num
do kl = 1, ao_num*ao_num
tmp = 0.d0
do mn = 1, ao_num*ao_num
tmp += A(ij,mn) * A_inv(mn,kl)
enddo
print*, ij, kl, tmp
enddo
enddo
! coef_fit = A_inv x b
!call dgemv("N", ao_num*ao_num, ao_num*ao_num, 1.d0, A_inv, ao_num*ao_num, b, 1, 0.d0, coef_fit(1,1), 1)
do ij = 1, ao_num*ao_num
coef_fit(ij) = 0.d0
do kl = 1, ao_num*ao_num
coef_fit(ij) += A_inv(ij,kl) * b(kl)
enddo
enddo
double precision :: tmp
print *, ' check A_inv'
do ij = 1, ao_num*ao_num
tmp = 0.d0
do kl = 1, ao_num*ao_num
tmp += A(ij,kl) * coef_fit(kl)
enddo
tmp = tmp - b(ij)
print*, ij, tmp
enddo
deallocate(A)
deallocate(A_inv, b)
call wall_time(t1)
print*, ' END after (min) ', (t1-t0)/60.d0
return
end
! ---
subroutine get_j1e_coef_fit_ao3(dim_fit, coef_fit)
implicit none
integer , intent(in) :: dim_fit
double precision, intent(out) :: coef_fit(dim_fit,3)
integer :: i, d, ipoint
double precision :: g
double precision :: t0, t1
double precision, allocatable :: A(:,:), b(:,:), A_inv(:,:)
double precision, allocatable :: Pa(:,:), Pb(:,:), Pt(:,:)
double precision, allocatable :: u1e_tmp(:,:)
PROVIDE j1e_type
PROVIDE int2_grad1_u2e_ao
PROVIDE elec_alpha_num elec_beta_num elec_num
PROVIDE mo_coef
PROVIDE ao_overlap
call wall_time(t0)
print*, ' PROVIDING the representation of 1e-Jastrow in AOs ... '
! --- --- ---
! get u1e(r)
allocate(Pa(ao_num,ao_num), Pb(ao_num,ao_num), Pt(ao_num,ao_num))
call dgemm( 'N', 'T', ao_num, ao_num, elec_alpha_num, 1.d0 &
, mo_coef, size(mo_coef, 1), mo_coef, size(mo_coef, 1) &
, 0.d0, Pa, size(Pa, 1))
if(elec_alpha_num .eq. elec_beta_num) then
Pb = Pa
else
call dgemm( 'N', 'T', ao_num, ao_num, elec_beta_num, 1.d0 &
, mo_coef, size(mo_coef, 1), mo_coef, size(mo_coef, 1) &
, 0.d0, Pb, size(Pb, 1))
endif
Pt = Pa + Pb
allocate(u1e_tmp(n_points_final_grid,3))
g = -0.5d0 * (dble(elec_num) - 1.d0) / dble(elec_num)
do d = 1, 3
call dgemv("T", ao_num*ao_num, n_points_final_grid, g, int2_grad1_u2e_ao(1,1,1,d), ao_num*ao_num, Pt, 1, 0.d0, u1e_tmp(1,d), 1)
enddo
deallocate(Pa, Pb, Pt)
! --- --- ---
! get A & b
allocate(A(ao_num,ao_num), b(ao_num,3))
A(1:ao_num,1:ao_num) = ao_overlap(1:ao_num,1:ao_num)
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, ipoint) &
!$OMP SHARED (n_points_final_grid, ao_num, &
!$OMP final_weight_at_r_vector, aos_in_r_array_transp, u1e_tmp, b)
!$OMP DO SCHEDULE (static)
do i = 1, ao_num
b(i,1) = 0.d0
b(i,2) = 0.d0
b(i,3) = 0.d0
do ipoint = 1, n_points_final_grid
b(i,1) = b(i,1) + final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * u1e_tmp(ipoint,1)
b(i,2) = b(i,2) + final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * u1e_tmp(ipoint,2)
b(i,3) = b(i,3) + final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * u1e_tmp(ipoint,3)
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
deallocate(u1e_tmp)
! --- --- ---
! solve Ax = b
allocate(A_inv(ao_num,ao_num))
call get_inverse(A, ao_num, ao_num, A_inv, ao_num)
! coef_fit = A_inv x b
do d = 1, 3
call dgemv("N", ao_num, ao_num, 1.d0, A_inv, ao_num, b(1,d), 1, 0.d0, coef_fit(1,d), 1)
enddo
integer :: j
double precision :: tmp, acc, nrm
acc = 0.d0
nrm = 0.d0
print *, ' check A_inv'
do d = 1, 3
do i = 1, ao_num
tmp = 0.d0
do j = 1, ao_num
tmp += ao_overlap(i,j) * coef_fit(j,d)
enddo
tmp = tmp - b(i,d)
if(dabs(tmp) .gt. 1d-8) then
print*, d, i, tmp
endif
acc += dabs(tmp)
nrm += dabs(b(i,d))
enddo
enddo
print *, ' Relative Error (%) =', 100.d0*acc/nrm
deallocate(A, A_inv, b)
call wall_time(t1)
print*, ' END after (min) ', (t1-t0)/60.d0
return
end
! ---

188
plugins/local/non_h_ints_mu/jast_2e_utils.irp.f Normal file
View File

@ -0,0 +1,188 @@
! ---
BEGIN_PROVIDER [double precision, int2_u2e_ao, (ao_num, ao_num, n_points_final_grid)]
BEGIN_DOC
!
! int2_u2e_ao(i,j,ipoint,:) = \int dr2 J_2e(r1,r2) \phi_i(r2) \phi_j(r2)
!
! where r1 = r(ipoint)
!
END_DOC
implicit none
integer :: ipoint, i, j, jpoint
double precision :: time0, time1
double precision :: x, y, z, r2
double precision :: dx, dy, dz
double precision :: tmp_ct
double precision :: tmp0, tmp1, tmp2, tmp3
PROVIDE j2e_type
PROVIDE Env_type
call wall_time(time0)
print*, ' providing int2_u2e_ao ...'
if( (j2e_type .eq. "Mu") .and. &
( (env_type .eq. "None") .or. (env_type .eq. "Prod_Gauss") .or. (env_type .eq. "Sum_Gauss") ) ) then
PROVIDE mu_erf
PROVIDE env_type env_val
PROVIDE Ir2_Mu_long_Du_0 Ir2_Mu_long_Du_x Ir2_Mu_long_Du_y Ir2_Mu_long_Du_z Ir2_Mu_long_Du_2
PROVIDE Ir2_Mu_gauss_Du
tmp_ct = 0.5d0 / (dsqrt(dacos(-1.d0)) * mu_erf)
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, x, y, z, r2, dx, dy, dz, &
!$OMP tmp0, tmp1, tmp2, tmp3) &
!$OMP SHARED (ao_num, n_points_final_grid, final_grid_points, &
!$OMP tmp_ct, env_val, Ir2_Mu_long_Du_0, &
!$OMP Ir2_Mu_long_Du_x, Ir2_Mu_long_Du_y, &
!$OMP Ir2_Mu_long_Du_z, Ir2_Mu_gauss_Du, &
!$OMP Ir2_Mu_long_Du_2, int2_u2e_ao)
!$OMP DO SCHEDULE (static)
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)
r2 = x*x + y*y + z*z
dx = x * env_val(ipoint)
dy = y * env_val(ipoint)
dz = z * env_val(ipoint)
tmp0 = 0.5d0 * env_val(ipoint) * r2
tmp1 = 0.5d0 * env_val(ipoint)
tmp3 = tmp_ct * env_val(ipoint)
do j = 1, ao_num
do i = 1, ao_num
tmp2 = tmp1 * Ir2_Mu_long_Du_2(i,j,ipoint) - dx * Ir2_Mu_long_Du_x(i,j,ipoint) - dy * Ir2_Mu_long_Du_y(i,j,ipoint) - dz * Ir2_Mu_long_Du_z(i,j,ipoint)
int2_u2e_ao(i,j,ipoint) = tmp0 * Ir2_Mu_long_Du_0(i,j,ipoint) + tmp2 - tmp3 * Ir2_Mu_gauss_Du(i,j,ipoint)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
else
print *, ' Error in int2_u2e_ao: Unknown Jastrow'
stop
endif ! j2e_type
call wall_time(time1)
print*, ' wall time for int2_u2e_ao (min) =', (time1-time0)/60.d0
call print_memory_usage()
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, int2_grad1_u2e_ao, (ao_num, ao_num, n_points_final_grid, 3)]
BEGIN_DOC
!
! int2_grad1_u2e_ao(i,j,ipoint,:) = \int dr2 [\grad_r1 J_2e(r1,r2)] \phi_i(r2) \phi_j(r2)
!
! where r1 = r(ipoint)
!
END_DOC
implicit none
integer :: ipoint, i, j, m, jpoint
double precision :: time0, time1
double precision :: x, y, z, r2
double precision :: dx, dy, dz
double precision :: tmp_ct
double precision :: tmp0, tmp1, tmp2
double precision :: tmp0_x, tmp0_y, tmp0_z
double precision :: tmp1_x, tmp1_y, tmp1_z
PROVIDE j2e_type
PROVIDE Env_type
call wall_time(time0)
print*, ' providing int2_grad1_u2e_ao ...'
if( (j2e_type .eq. "Mu") .and. &
( (env_type .eq. "None") .or. (env_type .eq. "Prod_Gauss") .or. (env_type .eq. "Sum_Gauss") ) ) then
PROVIDE mu_erf
PROVIDE env_type env_val env_grad
PROVIDE Ir2_Mu_long_Du_0 Ir2_Mu_long_Du_x Ir2_Mu_long_Du_y Ir2_Mu_long_Du_z Ir2_Mu_long_Du_2
PROVIDE Ir2_Mu_gauss_Du
tmp_ct = 0.5d0 / (dsqrt(dacos(-1.d0)) * mu_erf)
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, x, y, z, r2, dx, dy, dz, tmp1, tmp2, &
!$OMP tmp0_x, tmp0_y, tmp0_z, tmp1_x, tmp1_y, tmp1_z) &
!$OMP SHARED (ao_num, n_points_final_grid, final_grid_points, &
!$OMP tmp_ct, env_val, env_grad, Ir2_Mu_long_Du_0, &
!$OMP Ir2_Mu_long_Du_x, Ir2_Mu_long_Du_y, &
!$OMP Ir2_Mu_long_Du_z, Ir2_Mu_gauss_Du, &
!$OMP Ir2_Mu_long_Du_2, int2_grad1_u2e_ao)
!$OMP DO SCHEDULE (static)
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)
r2 = x*x + y*y + z*z
dx = env_grad(1,ipoint)
dy = env_grad(2,ipoint)
dz = env_grad(3,ipoint)
tmp0_x = 0.5d0 * (env_val(ipoint) * x + r2 * dx)
tmp0_y = 0.5d0 * (env_val(ipoint) * y + r2 * dy)
tmp0_z = 0.5d0 * (env_val(ipoint) * z + r2 * dz)
tmp1 = 0.5d0 * env_val(ipoint)
tmp1_x = tmp_ct * dx
tmp1_y = tmp_ct * dy
tmp1_z = tmp_ct * dz
do j = 1, ao_num
do i = 1, ao_num
tmp2 = 0.5d0 * Ir2_Mu_long_Du_2(i,j,ipoint) - x * Ir2_Mu_long_Du_x(i,j,ipoint) - y * Ir2_Mu_long_Du_y(i,j,ipoint) - z * Ir2_Mu_long_Du_z(i,j,ipoint)
int2_grad1_u2e_ao(i,j,ipoint,1) = Ir2_Mu_long_Du_0(i,j,ipoint) * tmp0_x - tmp1 * Ir2_Mu_long_Du_x(i,j,ipoint) + dx * tmp2 - tmp1_x * Ir2_Mu_gauss_Du(i,j,ipoint)
int2_grad1_u2e_ao(i,j,ipoint,2) = Ir2_Mu_long_Du_0(i,j,ipoint) * tmp0_y - tmp1 * Ir2_Mu_long_Du_y(i,j,ipoint) + dy * tmp2 - tmp1_y * Ir2_Mu_gauss_Du(i,j,ipoint)
int2_grad1_u2e_ao(i,j,ipoint,3) = Ir2_Mu_long_Du_0(i,j,ipoint) * tmp0_z - tmp1 * Ir2_Mu_long_Du_z(i,j,ipoint) + dz * tmp2 - tmp1_z * Ir2_Mu_gauss_Du(i,j,ipoint)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
FREE Ir2_Mu_long_Du_0 Ir2_Mu_long_Du_x Ir2_Mu_long_Du_y Ir2_Mu_long_Du_z Ir2_Mu_long_Du_2
FREE Ir2_Mu_gauss_Du
else
print *, ' Error in int2_grad1_u2e_ao: Unknown Jastrow'
stop
endif ! j2e_type
call wall_time(time1)
print*, ' wall time for int2_grad1_u2e_ao (min) =', (time1-time0)/60.d0
call print_memory_usage()
END_PROVIDER
! ---

62
plugins/local/non_h_ints_mu/jast_deriv.irp.f
View File

@ -1,33 +1,27 @@
! --- ! ---
BEGIN_PROVIDER [ double precision, grad1_u12_num, (n_points_extra_final_grid, n_points_final_grid, 3)] BEGIN_PROVIDER [double precision, grad1_u12_num, (n_points_extra_final_grid, n_points_final_grid, 3)]
&BEGIN_PROVIDER [ double precision, grad1_u12_squared_num, (n_points_extra_final_grid, n_points_final_grid)] &BEGIN_PROVIDER [double precision, grad1_u12_squared_num, (n_points_extra_final_grid, n_points_final_grid)]
BEGIN_DOC BEGIN_DOC
! !
!
! grad_1 u(r1,r2) ! grad_1 u(r1,r2)
! ! numerical integration over r1 & r2
! this will be integrated numerically over r2:
! we use grid for r1 and extra_grid for r2
!
! for 99 < j1b_type < 199
!
! u(r1,r2) = j12_mu(r12) x v(r1) x v(r2)
! grad1 u(r1, r2) = [(grad1 j12_mu) v(r1) + j12_mu grad1 v(r1)] v(r2)
! !
END_DOC END_DOC
implicit none implicit none
integer :: ipoint, jpoint integer :: ipoint, jpoint
double precision :: r1(3), r2(3) double precision :: r1(3), r2(3)
double precision :: v1b_r1, v1b_r2, u2b_r12 double precision :: v_r1, v_r2, u2b_r12
double precision :: grad1_v1b(3), grad1_u2b(3) double precision :: grad1_v(3), grad1_u2b(3)
double precision :: dx, dy, dz double precision :: dx, dy, dz
double precision :: time0, time1 double precision :: time0, time1
double precision, external :: j12_mu, j1b_nucl double precision, external :: j12_mu, env_nucl
PROVIDE j1b_type PROVIDE env_type
PROVIDE final_grid_points_extra PROVIDE final_grid_points_extra
print*, ' providing grad1_u12_num & grad1_u12_squared_num ...' print*, ' providing grad1_u12_num & grad1_u12_squared_num ...'
@ -36,12 +30,12 @@
grad1_u12_num = 0.d0 grad1_u12_num = 0.d0
grad1_u12_squared_num = 0.d0 grad1_u12_squared_num = 0.d0
if( (j1b_type .eq. 100) .or. & if( ((j2e_type .eq. "Mu") .and. (env_type .eq. "None")) .or. &
(j1b_type .ge. 200) .and. (j1b_type .lt. 300) ) then (j2e_type .eq. "Mur") ) then
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, jpoint, r1, r2, v1b_r1, v1b_r2, u2b_r12, grad1_v1b, grad1_u2b, dx, dy, dz) & !$OMP PRIVATE (ipoint, jpoint, r1, r2, v_r1, v_r2, u2b_r12, grad1_v, grad1_u2b, dx, dy, dz) &
!$OMP SHARED (n_points_final_grid, n_points_extra_final_grid, final_grid_points, & !$OMP SHARED (n_points_final_grid, n_points_extra_final_grid, final_grid_points, &
!$OMP final_grid_points_extra, grad1_u12_num, grad1_u12_squared_num) !$OMP final_grid_points_extra, grad1_u12_num, grad1_u12_squared_num)
!$OMP DO SCHEDULE (static) !$OMP DO SCHEDULE (static)
@ -57,7 +51,7 @@
r2(2) = final_grid_points_extra(2,jpoint) r2(2) = final_grid_points_extra(2,jpoint)
r2(3) = final_grid_points_extra(3,jpoint) r2(3) = final_grid_points_extra(3,jpoint)
call grad1_j12_mu(r1, r2, grad1_u2b) call grad1_j12_mu(r2, r1, grad1_u2b)
dx = grad1_u2b(1) dx = grad1_u2b(1)
dy = grad1_u2b(2) dy = grad1_u2b(2)
@ -73,14 +67,14 @@
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
elseif((j1b_type .gt. 100) .and. (j1b_type .lt. 200)) then elseif((j2e_type .eq. "Mu") .and. (env_type .ne. "None")) then
PROVIDE final_grid_points PROVIDE final_grid_points
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, jpoint, r1, r2, v1b_r1, v1b_r2, u2b_r12, grad1_v1b, grad1_u2b, dx, dy, dz) & !$OMP PRIVATE (ipoint, jpoint, r1, r2, v_r1, v_r2, u2b_r12, grad1_v, grad1_u2b, dx, dy, dz) &
!$OMP SHARED (n_points_final_grid, n_points_extra_final_grid, final_grid_points, & !$OMP SHARED (n_points_final_grid, n_points_extra_final_grid, final_grid_points, &
!$OMP final_grid_points_extra, grad1_u12_num, grad1_u12_squared_num) !$OMP final_grid_points_extra, grad1_u12_num, grad1_u12_squared_num)
!$OMP DO SCHEDULE (static) !$OMP DO SCHEDULE (static)
do ipoint = 1, n_points_final_grid ! r1 do ipoint = 1, n_points_final_grid ! r1
@ -89,8 +83,8 @@
r1(2) = final_grid_points(2,ipoint) r1(2) = final_grid_points(2,ipoint)
r1(3) = final_grid_points(3,ipoint) r1(3) = final_grid_points(3,ipoint)
v1b_r1 = j1b_nucl(r1) v_r1 = env_nucl(r1)
call grad1_j1b_nucl(r1, grad1_v1b) call grad1_env_nucl(r1, grad1_v)
do jpoint = 1, n_points_extra_final_grid ! r2 do jpoint = 1, n_points_extra_final_grid ! r2
@ -98,13 +92,13 @@
r2(2) = final_grid_points_extra(2,jpoint) r2(2) = final_grid_points_extra(2,jpoint)
r2(3) = final_grid_points_extra(3,jpoint) r2(3) = final_grid_points_extra(3,jpoint)
v1b_r2 = j1b_nucl(r2) v_r2 = env_nucl(r2)
u2b_r12 = j12_mu(r1, r2) u2b_r12 = j12_mu(r1, r2)
call grad1_j12_mu(r1, r2, grad1_u2b) call grad1_j12_mu(r2, r1, grad1_u2b)
dx = (grad1_u2b(1) * v1b_r1 + u2b_r12 * grad1_v1b(1)) * v1b_r2 dx = (grad1_u2b(1) * v_r1 + u2b_r12 * grad1_v(1)) * v_r2
dy = (grad1_u2b(2) * v1b_r1 + u2b_r12 * grad1_v1b(2)) * v1b_r2 dy = (grad1_u2b(2) * v_r1 + u2b_r12 * grad1_v(2)) * v_r2
dz = (grad1_u2b(3) * v1b_r1 + u2b_r12 * grad1_v1b(3)) * v1b_r2 dz = (grad1_u2b(3) * v_r1 + u2b_r12 * grad1_v(3)) * v_r2
grad1_u12_num(jpoint,ipoint,1) = dx grad1_u12_num(jpoint,ipoint,1) = dx
grad1_u12_num(jpoint,ipoint,2) = dy grad1_u12_num(jpoint,ipoint,2) = dy
@ -116,7 +110,7 @@
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
elseif (j1b_type .eq. 1000) then elseif(j2e_type .eq. "Qmckl") then
double precision :: f double precision :: f
f = 1.d0 / dble(elec_num - 1) f = 1.d0 / dble(elec_num - 1)
@ -227,13 +221,13 @@
else else
print *, ' j1b_type = ', j1b_type, 'not implemented yet' print *, ' Error in grad1_u12_num & grad1_u12_squared_num: Unknown Jastrow'
stop stop
endif endif ! j2e_type
call wall_time(time1) call wall_time(time1)
print*, ' Wall time for grad1_u12_num & grad1_u12_squared_num (min) =', (time1-time0)/60.d0 print*, ' Wall time for grad1_u12_num & grad1_u12_squared_num (min) = ', (time1-time0)/60.d0
END_PROVIDER END_PROVIDER

432
plugins/local/non_h_ints_mu/jast_deriv_utils.irp.f
View File

@ -9,7 +9,7 @@ double precision function j12_mu(r1, r2)
double precision, intent(in) :: r1(3), r2(3) double precision, intent(in) :: r1(3), r2(3)
double precision :: mu_tmp, r12 double precision :: mu_tmp, r12
if((j1b_type .ge. 0) .and. (j1b_type .lt. 200)) then if(j2e_type .eq. "Mu") then
r12 = dsqrt( (r1(1) - r2(1)) * (r1(1) - r2(1)) & r12 = dsqrt( (r1(1) - r2(1)) * (r1(1) - r2(1)) &
+ (r1(2) - r2(2)) * (r1(2) - r2(2)) & + (r1(2) - r2(2)) * (r1(2) - r2(2)) &
@ -20,13 +20,13 @@ double precision function j12_mu(r1, r2)
else else
print *, ' j1b_type = ', j1b_type, 'not implemented for j12_mu' print *, ' Error in j12_mu: Unknown j2e_type = ', j2e_type
stop stop
endif endif ! j2e_type
return return
end function j12_mu end
! --- ! ---
@ -36,11 +36,11 @@ subroutine grad1_j12_mu(r1, r2, grad)
! !
! gradient of j(mu(r1,r2),r12) form of jastrow. ! gradient of j(mu(r1,r2),r12) form of jastrow.
! !
! if mu(r1,r2) = cst ---> j1b_type < 200 and ! if mu(r1,r2) = cst --->
! !
! d/dx1 j(mu,r12) = 0.5 * (1 - erf(mu *r12))/r12 * (x1 - x2) ! d/dx1 j(mu,r12) = 0.5 * (1 - erf(mu *r12))/r12 * (x1 - x2)
! !
! if mu(r1,r2) /= cst ---> 200 < j1b_type < 300 and ! if mu(r1,r2) /= cst --->
! !
! d/dx1 j(mu(r1,r2),r12) = exp(-(mu(r1,r2)*r12)**2) /(2 *sqrt(pi) * mu(r1,r2)**2 ) d/dx1 mu(r1,r2) ! d/dx1 j(mu(r1,r2),r12) = exp(-(mu(r1,r2)*r12)**2) /(2 *sqrt(pi) * mu(r1,r2)**2 ) d/dx1 mu(r1,r2)
! + 0.5 * (1 - erf(mu(r1,r2) *r12))/r12 * (x1 - x2) ! + 0.5 * (1 - erf(mu(r1,r2) *r12))/r12 * (x1 - x2)
@ -53,10 +53,11 @@ subroutine grad1_j12_mu(r1, r2, grad)
double precision, intent(in) :: r1(3), r2(3) double precision, intent(in) :: r1(3), r2(3)
double precision, intent(out) :: grad(3) double precision, intent(out) :: grad(3)
double precision :: dx, dy, dz, r12, tmp double precision :: dx, dy, dz, r12, tmp
double precision :: mu_val, mu_tmp, mu_der(3)
grad = 0.d0 grad = 0.d0
if((j1b_type .ge. 0) .and. (j1b_type .lt. 200)) then if(j2e_type .eq. "Mu") then
dx = r1(1) - r2(1) dx = r1(1) - r2(1)
dy = r1(2) - r2(2) dy = r1(2) - r2(2)
@ -71,9 +72,7 @@ subroutine grad1_j12_mu(r1, r2, grad)
grad(2) = tmp * dy grad(2) = tmp * dy
grad(3) = tmp * dz grad(3) = tmp * dz
elseif((j1b_type .ge. 200) .and. (j1b_type .lt. 300)) then elseif(j2e_type .eq. "Mur") then
double precision :: mu_val, mu_tmp, mu_der(3)
dx = r1(1) - r2(1) dx = r1(1) - r2(1)
dy = r1(2) - r2(2) dy = r1(2) - r2(2)
@ -95,152 +94,153 @@ subroutine grad1_j12_mu(r1, r2, grad)
else else
print *, ' j1b_type = ', j1b_type, 'not implemented yet' print *, ' Error in grad1_j12_mu: Unknown j2e_type = ', j2e_type
stop stop
endif endif ! j2e_type
grad = -grad grad = -grad
return return
end subroutine grad1_j12_mu end
! --- ! ---
double precision function j1b_nucl(r) double precision function env_nucl(r)
implicit none implicit none
double precision, intent(in) :: r(3) double precision, intent(in) :: r(3)
integer :: i integer :: i
double precision :: a, d, e, x, y, z double precision :: a, d, e, x, y, z
if((j1b_type .eq. 2) .or. (j1b_type .eq. 102)) then if(env_type .eq. "Sum_Slat") then
j1b_nucl = 1.d0 env_nucl = 1.d0
do i = 1, nucl_num do i = 1, nucl_num
a = j1b_pen(i) a = env_expo(i)
d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) & 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(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+ (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) ) + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
j1b_nucl = j1b_nucl - dexp(-a*dsqrt(d)) env_nucl = env_nucl - env_coef(i) * dexp(-a*dsqrt(d))
enddo enddo
elseif((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then elseif(env_type .eq. "Prod_Gauss") then
j1b_nucl = 1.d0 env_nucl = 1.d0
do i = 1, nucl_num do i = 1, nucl_num
a = j1b_pen(i) a = env_expo(i)
d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) & 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(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+ (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) ) + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
e = 1.d0 - dexp(-a*d) e = 1.d0 - dexp(-a*d)
j1b_nucl = j1b_nucl * e env_nucl = env_nucl * e
enddo enddo
elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then elseif(env_type .eq. "Sum_Gauss") then
j1b_nucl = 1.d0 env_nucl = 1.d0
do i = 1, nucl_num do i = 1, nucl_num
a = j1b_pen(i) a = env_expo(i)
d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) & 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(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+ (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) ) + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
j1b_nucl = j1b_nucl - j1b_pen_coef(i) * dexp(-a*d) env_nucl = env_nucl - env_coef(i) * dexp(-a*d)
enddo enddo
elseif((j1b_type .eq. 5) .or. (j1b_type .eq. 105)) then elseif(env_type .eq. "Sum_Quartic") then
j1b_nucl = 1.d0 env_nucl = 1.d0
do i = 1, nucl_num do i = 1, nucl_num
a = j1b_pen(i) a = env_expo(i)
x = r(1) - nucl_coord(i,1) x = r(1) - nucl_coord(i,1)
y = r(2) - nucl_coord(i,2) y = r(2) - nucl_coord(i,2)
z = r(3) - nucl_coord(i,3) z = r(3) - nucl_coord(i,3)
d = x*x + y*y + z*z d = x*x + y*y + z*z
j1b_nucl = j1b_nucl - dexp(-a*d*d) env_nucl = env_nucl - env_coef(i) * dexp(-a*d*d)
enddo enddo
else else
print *, ' j1b_type = ', j1b_type, 'not implemented for j1b_nucl' print *, ' Error in env_nucl: Unknown env_type = ', env_type
stop stop
endif endif
return return
end function j1b_nucl end
! --- ! ---
double precision function j1b_nucl_square(r) double precision function env_nucl_square(r)
implicit none implicit none
double precision, intent(in) :: r(3) double precision, intent(in) :: r(3)
integer :: i integer :: i
double precision :: a, d, e, x, y, z double precision :: a, d, e, x, y, z
if((j1b_type .eq. 2) .or. (j1b_type .eq. 102)) then if(env_type .eq. "Sum_Slat") then
j1b_nucl_square = 1.d0 env_nucl_square = 1.d0
do i = 1, nucl_num do i = 1, nucl_num
a = j1b_pen(i) a = env_expo(i)
d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) & 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(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+ (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) ) + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
j1b_nucl_square = j1b_nucl_square - dexp(-a*dsqrt(d)) env_nucl_square = env_nucl_square - env_coef(i) * dexp(-a*dsqrt(d))
enddo enddo
j1b_nucl_square = j1b_nucl_square * j1b_nucl_square env_nucl_square = env_nucl_square * env_nucl_square
elseif((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then elseif(env_type .eq. "Prod_Gauss") then
j1b_nucl_square = 1.d0 env_nucl_square = 1.d0
do i = 1, nucl_num do i = 1, nucl_num
a = j1b_pen(i) a = env_expo(i)
d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) & 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(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+ (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) ) + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
e = 1.d0 - dexp(-a*d) e = 1.d0 - dexp(-a*d)
j1b_nucl_square = j1b_nucl_square * e env_nucl_square = env_nucl_square * e
enddo enddo
j1b_nucl_square = j1b_nucl_square * j1b_nucl_square env_nucl_square = env_nucl_square * env_nucl_square
elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then elseif(env_type .eq. "Sum_Gauss") then
j1b_nucl_square = 1.d0 env_nucl_square = 1.d0
do i = 1, nucl_num do i = 1, nucl_num
a = j1b_pen(i) a = env_expo(i)
d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) & 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(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+ (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) ) + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
j1b_nucl_square = j1b_nucl_square - j1b_pen_coef(i) * dexp(-a*d) env_nucl_square = env_nucl_square - env_coef(i) * dexp(-a*d)
enddo enddo
j1b_nucl_square = j1b_nucl_square * j1b_nucl_square env_nucl_square = env_nucl_square * env_nucl_square
elseif((j1b_type .eq. 5) .or. (j1b_type .eq. 105)) then elseif(env_type .eq. "Sum_Quartic") then
j1b_nucl_square = 1.d0 env_nucl_square = 1.d0
do i = 1, nucl_num do i = 1, nucl_num
a = j1b_pen(i) a = env_expo(i)
x = r(1) - nucl_coord(i,1) x = r(1) - nucl_coord(i,1)
y = r(2) - nucl_coord(i,2) y = r(2) - nucl_coord(i,2)
z = r(3) - nucl_coord(i,3) z = r(3) - nucl_coord(i,3)
d = x*x + y*y + z*z d = x*x + y*y + z*z
j1b_nucl_square = j1b_nucl_square - dexp(-a*d*d) env_nucl_square = env_nucl_square - env_coef(i) * dexp(-a*d*d)
enddo enddo
j1b_nucl_square = j1b_nucl_square * j1b_nucl_square env_nucl_square = env_nucl_square * env_nucl_square
else else
print *, ' j1b_type = ', j1b_type, 'not implemented for j1b_nucl_square' print *, ' Error in env_nucl_square: Unknown env_type = ', env_type
stop stop
endif endif
return return
end function j1b_nucl_square end
! --- ! ---
subroutine grad1_j1b_nucl(r, grad) subroutine grad1_env_nucl(r, grad)
implicit none implicit none
double precision, intent(in) :: r(3) double precision, intent(in) :: r(3)
@ -251,18 +251,18 @@ subroutine grad1_j1b_nucl(r, grad)
double precision :: fact_x, fact_y, fact_z double precision :: fact_x, fact_y, fact_z
double precision :: ax_der, ay_der, az_der, a_expo double precision :: ax_der, ay_der, az_der, a_expo
if((j1b_type .eq. 2) .or. (j1b_type .eq. 102)) then if(env_type .eq. "Sum_Slat") then
fact_x = 0.d0 fact_x = 0.d0
fact_y = 0.d0 fact_y = 0.d0
fact_z = 0.d0 fact_z = 0.d0
do i = 1, nucl_num do i = 1, nucl_num
a = j1b_pen(i) a = env_expo(i)
x = r(1) - nucl_coord(i,1) x = r(1) - nucl_coord(i,1)
y = r(2) - nucl_coord(i,2) y = r(2) - nucl_coord(i,2)
z = r(3) - nucl_coord(i,3) z = r(3) - nucl_coord(i,3)
d = dsqrt(x*x + y*y + z*z) d = dsqrt(x*x + y*y + z*z)
e = a * dexp(-a*d) / d e = a * env_coef(i) * dexp(-a*d) / d
fact_x += e * x fact_x += e * x
fact_y += e * y fact_y += e * y
@ -273,7 +273,7 @@ subroutine grad1_j1b_nucl(r, grad)
grad(2) = fact_y grad(2) = fact_y
grad(3) = fact_z grad(3) = fact_z
elseif((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then elseif(env_type .eq. "Prod_Gauss") then
x = r(1) x = r(1)
y = r(2) y = r(2)
@ -282,7 +282,7 @@ subroutine grad1_j1b_nucl(r, grad)
fact_x = 0.d0 fact_x = 0.d0
fact_y = 0.d0 fact_y = 0.d0
fact_z = 0.d0 fact_z = 0.d0
do i = 1, List_all_comb_b2_size do i = 1, List_env1s_size
phase = 0 phase = 0
a_expo = 0.d0 a_expo = 0.d0
@ -290,12 +290,12 @@ subroutine grad1_j1b_nucl(r, grad)
ay_der = 0.d0 ay_der = 0.d0
az_der = 0.d0 az_der = 0.d0
do j = 1, nucl_num do j = 1, nucl_num
a = dble(List_all_comb_b2(j,i)) * j1b_pen(j) a = dble(List_env1s(j,i)) * env_expo(j)
dx = x - nucl_coord(j,1) dx = x - nucl_coord(j,1)
dy = y - nucl_coord(j,2) dy = y - nucl_coord(j,2)
dz = z - nucl_coord(j,3) dz = z - nucl_coord(j,3)
phase += List_all_comb_b2(j,i) phase += List_env1s(j,i)
a_expo += a * (dx*dx + dy*dy + dz*dz) a_expo += a * (dx*dx + dy*dy + dz*dz)
ax_der += a * dx ax_der += a * dx
ay_der += a * dy ay_der += a * dy
@ -312,18 +312,18 @@ subroutine grad1_j1b_nucl(r, grad)
grad(2) = fact_y grad(2) = fact_y
grad(3) = fact_z grad(3) = fact_z
elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then elseif(env_type .eq. "Sum_Gauss") then
fact_x = 0.d0 fact_x = 0.d0
fact_y = 0.d0 fact_y = 0.d0
fact_z = 0.d0 fact_z = 0.d0
do i = 1, nucl_num do i = 1, nucl_num
a = j1b_pen(i) a = env_expo(i)
x = r(1) - nucl_coord(i,1) x = r(1) - nucl_coord(i,1)
y = r(2) - nucl_coord(i,2) y = r(2) - nucl_coord(i,2)
z = r(3) - nucl_coord(i,3) z = r(3) - nucl_coord(i,3)
d = x*x + y*y + z*z d = x*x + y*y + z*z
e = a * j1b_pen_coef(i) * dexp(-a*d) e = a * env_coef(i) * dexp(-a*d)
fact_x += e * x fact_x += e * x
fact_y += e * y fact_y += e * y
@ -334,18 +334,18 @@ subroutine grad1_j1b_nucl(r, grad)
grad(2) = 2.d0 * fact_y grad(2) = 2.d0 * fact_y
grad(3) = 2.d0 * fact_z grad(3) = 2.d0 * fact_z
elseif((j1b_type .eq. 5) .or. (j1b_type .eq. 105)) then elseif(env_type .eq. "Sum_Quartic") then
fact_x = 0.d0 fact_x = 0.d0
fact_y = 0.d0 fact_y = 0.d0
fact_z = 0.d0 fact_z = 0.d0
do i = 1, nucl_num do i = 1, nucl_num
a = j1b_pen(i) a = env_expo(i)
x = r(1) - nucl_coord(i,1) x = r(1) - nucl_coord(i,1)
y = r(2) - nucl_coord(i,2) y = r(2) - nucl_coord(i,2)
z = r(3) - nucl_coord(i,3) z = r(3) - nucl_coord(i,3)
d = x*x + y*y + z*z d = x*x + y*y + z*z
e = a * d * dexp(-a*d*d) e = a * env_coef(i) * d * dexp(-a*d*d)
fact_x += e * x fact_x += e * x
fact_y += e * y fact_y += e * y
@ -358,13 +358,13 @@ subroutine grad1_j1b_nucl(r, grad)
else else
print *, ' j1b_type = ', j1b_type, 'not implemented for grad1_j1b_nucl' print *, ' Error in grad1_env_nucl: Unknown env_type = ', env_type
stop stop
endif endif
return return
end subroutine grad1_j1b_nucl end
! --- ! ---
@ -380,7 +380,10 @@ subroutine mu_r_val_and_grad(r1, r2, mu_val, mu_der)
double precision :: f_rho1, f_rho2, d_drho_f_rho1 double precision :: f_rho1, f_rho2, d_drho_f_rho1
double precision :: d_dx1_f_rho1(3),d_dx_rho_f_rho(3),nume double precision :: d_dx1_f_rho1(3),d_dx_rho_f_rho(3),nume
if(j1b_type .eq. 200) then PROVIDE murho_type
PROVIDE mu_r_ct mu_erf
if(murho_type .eq. 1) then
! !
! r = 0.5 (r1 + r2) ! r = 0.5 (r1 + r2)
@ -391,8 +394,6 @@ subroutine mu_r_val_and_grad(r1, r2, mu_val, mu_der)
! d mu[rho(r)] / dx = [0.5 alpha / sqrt(rho) - mu0 exp(-rho)] (d rho(r) / dx) ! d mu[rho(r)] / dx = [0.5 alpha / sqrt(rho) - mu0 exp(-rho)] (d rho(r) / dx)
! !
PROVIDE mu_r_ct mu_erf
r(1) = 0.5d0 * (r1(1) + r2(1)) r(1) = 0.5d0 * (r1(1) + r2(1))
r(2) = 0.5d0 * (r1(2) + r2(2)) r(2) = 0.5d0 * (r1(2) + r2(2))
r(3) = 0.5d0 * (r1(3) + r2(3)) r(3) = 0.5d0 * (r1(3) + r2(3))
@ -413,7 +414,7 @@ subroutine mu_r_val_and_grad(r1, r2, mu_val, mu_der)
mu_der(2) = tmp3 * (grad_dm_a(2,1) + grad_dm_b(2,1)) mu_der(2) = tmp3 * (grad_dm_a(2,1) + grad_dm_b(2,1))
mu_der(3) = tmp3 * (grad_dm_a(3,1) + grad_dm_b(3,1)) mu_der(3) = tmp3 * (grad_dm_a(3,1) + grad_dm_b(3,1))
elseif(j1b_type .eq. 201) then elseif(murho_type .eq. 2) then
! !
! r = 0.5 (r1 + r2) ! r = 0.5 (r1 + r2)
@ -424,8 +425,6 @@ subroutine mu_r_val_and_grad(r1, r2, mu_val, mu_der)
! d mu[rho(r)] / dx = [0.5 alpha / sqrt(rho) - mu0 exp(-rho)] (d rho(r) / dx) ! d mu[rho(r)] / dx = [0.5 alpha / sqrt(rho) - mu0 exp(-rho)] (d rho(r) / dx)
! !
PROVIDE mu_r_ct mu_erf
r(1) = 0.5d0 * (r1(1) + r2(1)) r(1) = 0.5d0 * (r1(1) + r2(1))
r(2) = 0.5d0 * (r1(2) + r2(2)) r(2) = 0.5d0 * (r1(2) + r2(2))
r(3) = 0.5d0 * (r1(3) + r2(3)) r(3) = 0.5d0 * (r1(3) + r2(3))
@ -442,7 +441,7 @@ subroutine mu_r_val_and_grad(r1, r2, mu_val, mu_der)
mu_der(2) = tmp3 * (grad_dm_a(2,1) + grad_dm_b(2,1)) mu_der(2) = tmp3 * (grad_dm_a(2,1) + grad_dm_b(2,1))
mu_der(3) = tmp3 * (grad_dm_a(3,1) + grad_dm_b(3,1)) mu_der(3) = tmp3 * (grad_dm_a(3,1) + grad_dm_b(3,1))
elseif(j1b_type .eq. 202) then elseif(murho_type .eq. 3) then
! mu(r1,r2) = {rho(r1) f[rho(r1)] + rho(r2) f[rho(r2)]} / RHO ! mu(r1,r2) = {rho(r1) f[rho(r1)] + rho(r2) f[rho(r2)]} / RHO
! !
@ -469,7 +468,8 @@ subroutine mu_r_val_and_grad(r1, r2, mu_val, mu_der)
nume = rho1 * f_rho1 + rho2 * f_rho2 nume = rho1 * f_rho1 + rho2 * f_rho2
mu_val = nume * inv_rho_tot mu_val = nume * inv_rho_tot
mu_der(1:3) = inv_rho_tot*inv_rho_tot * (rho_tot * d_dx_rho_f_rho(1:3) - grad_rho1(1:3) * nume) mu_der(1:3) = inv_rho_tot*inv_rho_tot * (rho_tot * d_dx_rho_f_rho(1:3) - grad_rho1(1:3) * nume)
elseif(j1b_type .eq. 203) then
elseif(murho_type .eq. 4) then
! mu(r1,r2) = {rho(r1) f[rho(r1)] + rho(r2) f[rho(r2)]} / RHO ! mu(r1,r2) = {rho(r1) f[rho(r1)] + rho(r2) f[rho(r2)]} / RHO
! !
@ -503,7 +503,8 @@ subroutine mu_r_val_and_grad(r1, r2, mu_val, mu_der)
nume = rho1 * f_rho1 + rho2 * f_rho2 nume = rho1 * f_rho1 + rho2 * f_rho2
mu_val = nume * inv_rho_tot mu_val = nume * inv_rho_tot
mu_der(1:3) = inv_rho_tot*inv_rho_tot * (rho_tot * d_dx_rho_f_rho(1:3) - grad_rho1(1:3) * nume) mu_der(1:3) = inv_rho_tot*inv_rho_tot * (rho_tot * d_dx_rho_f_rho(1:3) - grad_rho1(1:3) * nume)
elseif(j1b_type .eq. 204) then
elseif(murho_type .eq. 5) then
! mu(r1,r2) = 1/2 * (f[rho(r1)] + f[rho(r2)]} ! mu(r1,r2) = 1/2 * (f[rho(r1)] + f[rho(r2)]}
! !
@ -535,23 +536,24 @@ subroutine mu_r_val_and_grad(r1, r2, mu_val, mu_der)
mu_der(1:3) = inv_rho_tot*inv_rho_tot * (rho_tot * d_dx_rho_f_rho(1:3) - grad_rho1(1:3) * nume) mu_der(1:3) = inv_rho_tot*inv_rho_tot * (rho_tot * d_dx_rho_f_rho(1:3) - grad_rho1(1:3) * nume)
else else
print *, ' j1b_type = ', j1b_type, 'not implemented yet'
print *, ' Error in mu_r_val_and_grad: Unknown env_type = ', env_type
stop stop
endif endif
return return
end subroutine mu_r_val_and_grad end
! --- ! ---
subroutine grad1_j1b_nucl_square_num(r1, grad) subroutine grad1_env_nucl_square_num(r1, grad)
implicit none implicit none
double precision, intent(in) :: r1(3) double precision, intent(in) :: r1(3)
double precision, intent(out) :: grad(3) double precision, intent(out) :: grad(3)
double precision :: r(3), eps, tmp_eps, vp, vm double precision :: r(3), eps, tmp_eps, vp, vm
double precision, external :: j1b_nucl_square double precision, external :: env_nucl_square
eps = 1d-5 eps = 1d-5
tmp_eps = 0.5d0 / eps tmp_eps = 0.5d0 / eps
@ -559,28 +561,28 @@ subroutine grad1_j1b_nucl_square_num(r1, grad)
r(1:3) = r1(1:3) r(1:3) = r1(1:3)
r(1) = r(1) + eps r(1) = r(1) + eps
vp = j1b_nucl_square(r) vp = env_nucl_square(r)
r(1) = r(1) - 2.d0 * eps r(1) = r(1) - 2.d0 * eps
vm = j1b_nucl_square(r) vm = env_nucl_square(r)
r(1) = r(1) + eps r(1) = r(1) + eps
grad(1) = tmp_eps * (vp - vm) grad(1) = tmp_eps * (vp - vm)
r(2) = r(2) + eps r(2) = r(2) + eps
vp = j1b_nucl_square(r) vp = env_nucl_square(r)
r(2) = r(2) - 2.d0 * eps r(2) = r(2) - 2.d0 * eps
vm = j1b_nucl_square(r) vm = env_nucl_square(r)
r(2) = r(2) + eps r(2) = r(2) + eps
grad(2) = tmp_eps * (vp - vm) grad(2) = tmp_eps * (vp - vm)
r(3) = r(3) + eps r(3) = r(3) + eps
vp = j1b_nucl_square(r) vp = env_nucl_square(r)
r(3) = r(3) - 2.d0 * eps r(3) = r(3) - 2.d0 * eps
vm = j1b_nucl_square(r) vm = env_nucl_square(r)
r(3) = r(3) + eps r(3) = r(3) + eps
grad(3) = tmp_eps * (vp - vm) grad(3) = tmp_eps * (vp - vm)
return return
end subroutine grad1_j1b_nucl_square_num end
! --- ! ---
@ -622,7 +624,7 @@ subroutine grad1_j12_mu_square_num(r1, r2, grad)
grad(3) = tmp_eps * (vp - vm) grad(3) = tmp_eps * (vp - vm)
return return
end subroutine grad1_j12_mu_square_num end
! --- ! ---
@ -635,134 +637,172 @@ double precision function j12_mu_square(r1, r2)
j12_mu_square = j12_mu(r1, r2) * j12_mu(r1, r2) j12_mu_square = j12_mu(r1, r2) * j12_mu(r1, r2)
return return
end function j12_mu_square end
! --- ! ---
subroutine f_mu_and_deriv_mu(rho,alpha,mu0,beta,f_mu,d_drho_f_mu) subroutine f_mu_and_deriv_mu(rho, alpha, mu0, beta, f_mu, d_drho_f_mu)
implicit none
BEGIN_DOC BEGIN_DOC
! function giving mu as a function of rho ! function giving mu as a function of rho
! !
! f_mu = alpha * rho**beta + mu0 * exp(-rho) ! f_mu = alpha * rho**beta + mu0 * exp(-rho)
! !
! and its derivative with respect to rho d_drho_f_mu ! and its derivative with respect to rho d_drho_f_mu
END_DOC END_DOC
double precision, intent(in) :: rho,alpha,mu0,beta
double precision, intent(out) :: f_mu,d_drho_f_mu implicit none
f_mu = alpha * (rho)**beta + mu0 * dexp(-rho) double precision, intent(in) :: rho, alpha, mu0, beta
d_drho_f_mu = alpha * beta * rho**(beta-1.d0) - mu0 * dexp(-rho) double precision, intent(out) :: f_mu, d_drho_f_mu
f_mu = alpha * (rho)**beta + mu0 * dexp(-rho)
d_drho_f_mu = alpha * beta * rho**(beta-1.d0) - mu0 * dexp(-rho)
end end
! ---
subroutine get_all_rho_grad_rho(r1, r2, rho1, rho2, grad_rho1)
BEGIN_DOC
! returns the density in r1,r2 and grad_rho at r1
END_DOC
implicit none
double precision, intent(in) :: r1(3), r2(3)
double precision, intent(out) :: grad_rho1(3), rho1, rho2
double precision :: dm_a(1), dm_b(1), grad_dm_a(3,1), grad_dm_b(3,1)
call density_and_grad_alpha_beta(r1, dm_a, dm_b, grad_dm_a, grad_dm_b)
rho1 = dm_a(1) + dm_b(1)
grad_rho1(1:3) = grad_dm_a(1:3,1) + grad_dm_b(1:3,1)
call density_and_grad_alpha_beta(r2, dm_a, dm_b, grad_dm_a, grad_dm_b)
rho2 = dm_a(1) + dm_b(1)
subroutine get_all_rho_grad_rho(r1,r2,rho1,rho2,grad_rho1)
implicit none
BEGIN_DOC
! returns the density in r1,r2 and grad_rho at r1
END_DOC
double precision, intent(in) :: r1(3),r2(3)
double precision, intent(out):: grad_rho1(3),rho1,rho2
double precision :: dm_a(1), dm_b(1), grad_dm_a(3,1), grad_dm_b(3,1)
call density_and_grad_alpha_beta(r1, dm_a, dm_b, grad_dm_a, grad_dm_b)
rho1 = dm_a(1) + dm_b(1)
grad_rho1(1:3) = grad_dm_a(1:3,1) + grad_dm_b(1:3,1)
call density_and_grad_alpha_beta(r2, dm_a, dm_b, grad_dm_a, grad_dm_b)
rho2 = dm_a(1) + dm_b(1)
end end
subroutine get_all_f_rho(rho1,rho2,alpha,mu0,beta,f_rho1,d_drho_f_rho1,f_rho2) ! ---
implicit none
BEGIN_DOC subroutine get_all_f_rho(rho1, rho2, alpha, mu0, beta, f_rho1, d_drho_f_rho1, f_rho2)
! returns the values f(mu(r1)), f(mu(r2)) and d/drho(1) f(mu(r1))
END_DOC BEGIN_DOC
double precision, intent(in) :: rho1,rho2,alpha,mu0,beta ! returns the values f(mu(r1)), f(mu(r2)) and d/drho(1) f(mu(r1))
double precision, intent(out):: f_rho1,d_drho_f_rho1,f_rho2 END_DOC
double precision :: tmp
call f_mu_and_deriv_mu(rho1,alpha,mu0,beta,f_rho1,d_drho_f_rho1) implicit none
call f_mu_and_deriv_mu(rho2,alpha,mu0,beta,f_rho2,tmp) double precision, intent(in) :: rho1, rho2, alpha, mu0, beta
double precision, intent(out) :: f_rho1, d_drho_f_rho1, f_rho2
double precision :: tmp
call f_mu_and_deriv_mu(rho1, alpha, mu0, beta, f_rho1, d_drho_f_rho1)
call f_mu_and_deriv_mu(rho2, alpha, mu0, beta, f_rho2, tmp)
end end
! ---
subroutine get_all_f_rho_simple(rho1,rho2,alpha,mu0,beta,f_rho1,d_drho_f_rho1,f_rho2) subroutine get_all_f_rho_simple(rho1,rho2,alpha,mu0,beta,f_rho1,d_drho_f_rho1,f_rho2)
implicit none
BEGIN_DOC BEGIN_DOC
! returns the values f(mu(r1)), f(mu(r2)) and d/drho(1) f(mu(r1)) ! returns the values f(mu(r1)), f(mu(r2)) and d/drho(1) f(mu(r1))
END_DOC END_DOC
double precision, intent(in) :: rho1,rho2,alpha,mu0,beta
double precision, intent(out):: f_rho1,d_drho_f_rho1,f_rho2 implicit none
double precision :: tmp double precision, intent(in) :: rho1, rho2, alpha, mu0, beta
if(rho1.lt.1.d-10)then double precision, intent(out) :: f_rho1, d_drho_f_rho1, f_rho2
f_rho1 = 0.d0 double precision :: tmp
d_drho_f_rho1 = 0.d0
else if(rho1.lt.1.d-10) then
call f_mu_and_deriv_mu_simple(rho1,alpha,mu0,beta,f_rho1,d_drho_f_rho1) f_rho1 = 0.d0
endif d_drho_f_rho1 = 0.d0
if(rho2.lt.1.d-10)then else
f_rho2 = 0.d0 call f_mu_and_deriv_mu_simple(rho1, alpha, mu0, beta, f_rho1, d_drho_f_rho1)
else endif
call f_mu_and_deriv_mu_simple(rho2,alpha,mu0,beta,f_rho2,tmp)
endif if(rho2.lt.1.d-10)then
f_rho2 = 0.d0
else
call f_mu_and_deriv_mu_simple(rho2, alpha, mu0, beta, f_rho2, tmp)
endif
end end
subroutine f_mu_and_deriv_mu_simple(rho,alpha,mu0,beta,f_mu,d_drho_f_mu) ! ---
implicit none
BEGIN_DOC subroutine f_mu_and_deriv_mu_simple(rho, alpha, mu0, beta, f_mu, d_drho_f_mu)
! function giving mu as a function of rho
! BEGIN_DOC
! f_mu = alpha * rho**beta + mu0 ! function giving mu as a function of rho
! !
! and its derivative with respect to rho d_drho_f_mu ! f_mu = alpha * rho**beta + mu0
END_DOC !
double precision, intent(in) :: rho,alpha,mu0,beta ! and its derivative with respect to rho d_drho_f_mu
double precision, intent(out) :: f_mu,d_drho_f_mu END_DOC
f_mu = alpha**beta * (rho)**beta + mu0
d_drho_f_mu = alpha**beta * beta * rho**(beta-1.d0) implicit none
double precision, intent(in) :: rho, alpha, mu0, beta
double precision, intent(out) :: f_mu, d_drho_f_mu
f_mu = alpha**beta * (rho)**beta + mu0
d_drho_f_mu = alpha**beta * beta * rho**(beta-1.d0)
end end
! --- ! ---
subroutine f_mu_and_deriv_mu_erf(rho,alpha,zeta,mu0,beta,f_mu,d_drho_f_mu) subroutine f_mu_and_deriv_mu_erf(rho,alpha,zeta,mu0,beta,f_mu,d_drho_f_mu)
implicit none
include 'constants.include.F' include 'constants.include.F'
BEGIN_DOC
! function giving mu as a function of rho BEGIN_DOC
! ! function giving mu as a function of rho
! f_mu = (alpha * rho)**zeta * erf(beta * rho) + mu0 * (1 - erf(beta*rho)) !
! ! f_mu = (alpha * rho)**zeta * erf(beta * rho) + mu0 * (1 - erf(beta*rho))
! and its derivative with respect to rho d_drho_f_mu !
! ! and its derivative with respect to rho d_drho_f_mu
! d_drho_f_mu = 2 beta/sqrt(pi) * exp(-(beta*rho)**2) * ( (alpha*rho)**zeta - mu0) !
! + alpha * zeta * (alpha *rho)**(zeta-1) * erf(beta*rho) ! d_drho_f_mu = 2 beta/sqrt(pi) * exp(-(beta*rho)**2) * ( (alpha*rho)**zeta - mu0)
END_DOC ! + alpha * zeta * (alpha *rho)**(zeta-1) * erf(beta*rho)
double precision, intent(in) :: rho,alpha,mu0,beta,zeta END_DOC
double precision, intent(out) :: f_mu,d_drho_f_mu
f_mu = (alpha * rho)**zeta * derf(beta * rho) + mu0 * (1.d0 - derf(beta*rho)) implicit none
d_drho_f_mu = 2.d0 * beta * inv_sq_pi * dexp(-(beta*rho)**2) * ( (alpha*rho)**zeta - mu0) & double precision, intent(in) :: rho, alpha, mu0, beta, zeta
+ alpha * zeta * (alpha *rho)**(zeta-1) * derf(beta*rho) double precision, intent(out) :: f_mu, d_drho_f_mu
f_mu = (alpha * rho)**zeta * derf(beta * rho) + mu0 * (1.d0 - derf(beta*rho))
d_drho_f_mu = 2.d0 * beta * inv_sq_pi * dexp(-(beta*rho)**2) * ( (alpha*rho)**zeta - mu0) &
+ alpha * zeta * (alpha *rho)**(zeta-1) * derf(beta*rho)
end end
! ---
subroutine get_all_f_rho_erf(rho1, rho2, alpha, zeta, mu0, beta, f_rho1, d_drho_f_rho1, f_rho2)
BEGIN_DOC
! returns the values f(mu(r1)), f(mu(r2)) and d/drho(1) f(mu(r1))
! with f_mu = (alpha * rho)**zeta * erf(beta * rho) + mu0 * (1 - erf(beta*rho))
END_DOC
implicit none
double precision, intent(in) :: rho1, rho2, alpha, mu0, beta, zeta
double precision, intent(out) :: f_rho1, d_drho_f_rho1, f_rho2
double precision :: tmp
if(rho1 .lt. 1.d-10) then
f_rho1 = mu_erf
d_drho_f_rho1 = 0.d0
else
call f_mu_and_deriv_mu_erf(rho1, alpha, zeta, mu0, beta, f_rho1, d_drho_f_rho1)
endif
if(rho2 .lt. 1.d-10)then
f_rho2 = mu_erf
else
call f_mu_and_deriv_mu_erf(rho2, alpha, zeta, mu0, beta, f_rho2, tmp)
endif
subroutine get_all_f_rho_erf(rho1,rho2,alpha,zeta,mu0,beta,f_rho1,d_drho_f_rho1,f_rho2)
implicit none
BEGIN_DOC
! returns the values f(mu(r1)), f(mu(r2)) and d/drho(1) f(mu(r1))
! with f_mu = (alpha * rho)**zeta * erf(beta * rho) + mu0 * (1 - erf(beta*rho))
END_DOC
double precision, intent(in) :: rho1,rho2,alpha,mu0,beta,zeta
double precision, intent(out):: f_rho1,d_drho_f_rho1,f_rho2
double precision :: tmp
if(rho1.lt.1.d-10)then
f_rho1 = mu_erf
d_drho_f_rho1 = 0.d0
else
call f_mu_and_deriv_mu_erf(rho1,alpha,zeta,mu0,beta,f_rho1,d_drho_f_rho1)
endif
if(rho2.lt.1.d-10)then
f_rho2 = mu_erf
else
call f_mu_and_deriv_mu_erf(rho2,alpha,zeta,mu0,beta,f_rho2,tmp)
endif
end end
! ---

237
plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
View File

@ -1,100 +1,104 @@
! --- ! ---
subroutine get_grad1_u12_withsq_r1_seq(r1, n_grid2, resx, resy, resz, res) subroutine get_grad1_u12_withsq_r1_seq(ipoint, n_grid2, resx, resy, resz, res)
BEGIN_DOC BEGIN_DOC
! !
! grad_1 u(r1,r2) ! grad_1 u(r1,r2)
! !
! this will be integrated numerically over r2: ! we use grid for r1 and extra_grid for r2
! we use grid for r1 and extra_grid for r2
!
! for 99 < j1b_type < 199
!
! u(r1,r2) = j12_mu(r12) x v(r1) x v(r2)
! grad1 u(r1, r2) = [(grad1 j12_mu) v(r1) + j12_mu grad1 v(r1)] v(r2)
! !
END_DOC END_DOC
implicit none implicit none
integer, intent(in) :: n_grid2 integer, intent(in) :: ipoint, n_grid2
double precision, intent(in) :: r1(3)
double precision, intent(out) :: resx(n_grid2), resy(n_grid2), resz(n_grid2), res(n_grid2) double precision, intent(out) :: resx(n_grid2), resy(n_grid2), resz(n_grid2), res(n_grid2)
integer :: jpoint integer :: jpoint
double precision :: v1b_r1 double precision :: env_r1, tmp
double precision :: grad1_v1b(3) double precision :: grad1_env(3), r1(3)
double precision, allocatable :: v1b_r2(:) double precision, allocatable :: env_r2(:)
double precision, allocatable :: u2b_r12(:) double precision, allocatable :: u2b_r12(:)
double precision, allocatable :: gradx1_u2b(:), grady1_u2b(:), gradz1_u2b(:) double precision, allocatable :: gradx1_u2b(:), grady1_u2b(:), gradz1_u2b(:)
double precision, external :: j1b_nucl double precision, external :: env_nucl
PROVIDE j1b_type PROVIDE j1e_type j2e_type env_type
PROVIDE final_grid_points
PROVIDE final_grid_points_extra PROVIDE final_grid_points_extra
if( (j1b_type .eq. 100) .or. & r1(1) = final_grid_points(1,ipoint)
(j1b_type .ge. 200) .and. (j1b_type .lt. 300) ) then r1(2) = final_grid_points(2,ipoint)
r1(3) = final_grid_points(3,ipoint)
call grad1_j12_mu_r1_seq(r1, n_grid2, resx, resy, resz) if( (j2e_type .eq. "Mu") .or. &
do jpoint = 1, n_points_extra_final_grid (j2e_type .eq. "Mur") .or. &
res(jpoint) = resx(jpoint) * resx(jpoint) & (j2e_type .eq. "Boys") ) then
+ resy(jpoint) * resy(jpoint) &
+ resz(jpoint) * resz(jpoint)
enddo
elseif((j1b_type .gt. 100) .and. (j1b_type .lt. 200)) then if(env_type .eq. "None") then
allocate(v1b_r2(n_grid2)) call grad1_j12_r1_seq(r1, n_grid2, resx, resy, resz)
allocate(u2b_r12(n_grid2))
allocate(gradx1_u2b(n_grid2))
allocate(grady1_u2b(n_grid2))
allocate(gradz1_u2b(n_grid2))
v1b_r1 = j1b_nucl(r1) else
call grad1_j1b_nucl(r1, grad1_v1b)
call j1b_nucl_r1_seq(n_grid2, v1b_r2) ! u(r1,r2) = j12_mu(r12) x v(r1) x v(r2)
call j12_mu_r1_seq(r1, n_grid2, u2b_r12) ! grad1 u(r1, r2) = [(grad1 j12_mu) v(r1) + j12_mu grad1 v(r1)] v(r2)
call grad1_j12_mu_r1_seq(r1, n_grid2, gradx1_u2b, grady1_u2b, gradz1_u2b)
do jpoint = 1, n_points_extra_final_grid allocate(env_r2(n_grid2))
resx(jpoint) = (gradx1_u2b(jpoint) * v1b_r1 + u2b_r12(jpoint) * grad1_v1b(1)) * v1b_r2(jpoint) allocate(u2b_r12(n_grid2))
resy(jpoint) = (grady1_u2b(jpoint) * v1b_r1 + u2b_r12(jpoint) * grad1_v1b(2)) * v1b_r2(jpoint) allocate(gradx1_u2b(n_grid2))
resz(jpoint) = (gradz1_u2b(jpoint) * v1b_r1 + u2b_r12(jpoint) * grad1_v1b(3)) * v1b_r2(jpoint) allocate(grady1_u2b(n_grid2))
res (jpoint) = resx(jpoint) * resx(jpoint) & allocate(gradz1_u2b(n_grid2))
+ resy(jpoint) * resy(jpoint) &
+ resz(jpoint) * resz(jpoint)
enddo
deallocate(v1b_r2, u2b_r12, gradx1_u2b, grady1_u2b, gradz1_u2b) env_r1 = env_nucl(r1)
call grad1_env_nucl(r1, grad1_env)
call env_nucl_r1_seq(n_grid2, env_r2)
call j12_r1_seq(r1, n_grid2, u2b_r12)
call grad1_j12_r1_seq(r1, n_grid2, gradx1_u2b, grady1_u2b, gradz1_u2b)
do jpoint = 1, n_points_extra_final_grid
resx(jpoint) = (gradx1_u2b(jpoint) * env_r1 + u2b_r12(jpoint) * grad1_env(1)) * env_r2(jpoint)
resy(jpoint) = (grady1_u2b(jpoint) * env_r1 + u2b_r12(jpoint) * grad1_env(2)) * env_r2(jpoint)
resz(jpoint) = (gradz1_u2b(jpoint) * env_r1 + u2b_r12(jpoint) * grad1_env(3)) * env_r2(jpoint)
enddo
deallocate(env_r2, u2b_r12, gradx1_u2b, grady1_u2b, gradz1_u2b)
endif ! env_type
else else
print *, ' j1b_type = ', j1b_type, 'not implemented yet' print *, ' Error in get_grad1_u12_withsq_r1_seq: Unknown Jastrow'
stop stop
endif ! j2e_type
if(j1e_type .ne. "None") then
PROVIDE j1e_gradx j1e_grady j1e_gradz
PROVIDE elec_num
tmp = 1.d0 / (dble(elec_num) - 1.d0)
do jpoint = 1, n_points_extra_final_grid
resx(jpoint) = resx(jpoint) + tmp * j1e_gradx(ipoint)
resy(jpoint) = resy(jpoint) + tmp * j1e_grady(ipoint)
resz(jpoint) = resz(jpoint) + tmp * j1e_gradz(ipoint)
enddo
endif endif
do jpoint = 1, n_points_extra_final_grid
res(jpoint) = resx(jpoint) * resx(jpoint) + resy(jpoint) * resy(jpoint) + resz(jpoint) * resz(jpoint)
enddo
return return
end subroutine get_grad1_u12_withsq_r1_seq end
! --- ! ---
subroutine grad1_j12_mu_r1_seq(r1, n_grid2, gradx, grady, gradz) subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
BEGIN_DOC BEGIN_DOC
! !
! gradient of j(mu(r1,r2),r12) form of jastrow.
!
! if mu(r1,r2) = cst ---> j1b_type < 200 and
!
! d/dx1 j(mu,r12) = 0.5 * (1 - erf(mu *r12))/r12 * (x1 - x2)
!
! if mu(r1,r2) /= cst ---> 200 < j1b_type < 300 and
!
! d/dx1 j(mu(r1,r2),r12) = exp(-(mu(r1,r2)*r12)**2) /(2 *sqrt(pi) * mu(r1,r2)**2 ) d/dx1 mu(r1,r2)
! + 0.5 * (1 - erf(mu(r1,r2) *r12))/r12 * (x1 - x2)
! !
END_DOC END_DOC
@ -110,8 +114,12 @@ subroutine grad1_j12_mu_r1_seq(r1, n_grid2, gradx, grady, gradz)
integer :: jpoint integer :: jpoint
double precision :: r2(3) double precision :: r2(3)
double precision :: dx, dy, dz, r12, tmp double precision :: dx, dy, dz, r12, tmp
double precision :: mu_val, mu_tmp, mu_der(3)
if((j1b_type .ge. 0) .and. (j1b_type .lt. 200)) then if(j2e_type .eq. "Mu") then
! d/dx1 j(mu,r12) = 0.5 * (1 - erf(mu *r12))/r12 * (x1 - x2)
!
do jpoint = 1, n_points_extra_final_grid ! r2 do jpoint = 1, n_points_extra_final_grid ! r2
@ -138,9 +146,10 @@ subroutine grad1_j12_mu_r1_seq(r1, n_grid2, gradx, grady, gradz)
gradz(jpoint) = tmp * dz gradz(jpoint) = tmp * dz
enddo enddo
elseif((j1b_type .ge. 200) .and. (j1b_type .lt. 300)) then elseif(j2e_type .eq. "Mur") then
double precision :: mu_val, mu_tmp, mu_der(3) ! d/dx1 j(mu(r1,r2),r12) = exp(-(mu(r1,r2)*r12)**2) /(2 *sqrt(pi) * mu(r1,r2)**2 ) d/dx1 mu(r1,r2)
! + 0.5 * (1 - erf(mu(r1,r2) *r12))/r12 * (x1 - x2)
do jpoint = 1, n_points_extra_final_grid ! r2 do jpoint = 1, n_points_extra_final_grid ! r2
@ -174,19 +183,50 @@ subroutine grad1_j12_mu_r1_seq(r1, n_grid2, gradx, grady, gradz)
gradz(jpoint) = gradz(jpoint) + tmp * dz gradz(jpoint) = gradz(jpoint) + tmp * dz
enddo enddo
elseif(j2e_type .eq. "Boys") then
! j(r12) = 0.5 r12 / (1 + a_boys r_12)
PROVIDE a_boys
do jpoint = 1, n_points_extra_final_grid ! r2
r2(1) = final_grid_points_extra(1,jpoint)
r2(2) = final_grid_points_extra(2,jpoint)
r2(3) = final_grid_points_extra(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) then
gradx(jpoint) = 0.d0
grady(jpoint) = 0.d0
gradz(jpoint) = 0.d0
cycle
endif
tmp = 1.d0 + a_boys * r12
tmp = 0.5d0 / (r12 * tmp * tmp)
gradx(jpoint) = tmp * dx
grady(jpoint) = tmp * dy
gradz(jpoint) = tmp * dz
enddo
else else
print *, ' j1b_type = ', j1b_type, 'not implemented yet' print *, ' Error in grad1_j12_r1_seq: Unknown j2e_type = ', j2e_type
stop stop
endif endif ! j2e_type
return return
end subroutine grad1_j12_mu_r1_seq end
! --- ! ---
subroutine j12_mu_r1_seq(r1, n_grid2, res) subroutine j12_r1_seq(r1, n_grid2, res)
include 'constants.include.F' include 'constants.include.F'
@ -197,11 +237,36 @@ subroutine j12_mu_r1_seq(r1, n_grid2, res)
integer :: jpoint integer :: jpoint
double precision :: r2(3) double precision :: r2(3)
double precision :: dx, dy, dz
double precision :: mu_tmp, r12 double precision :: mu_tmp, r12
PROVIDE final_grid_points_extra PROVIDE final_grid_points_extra
if((j1b_type .ge. 0) .and. (j1b_type .lt. 200)) then if(j2e_type .eq. "Mu") then
PROVIDE mu_erf
do jpoint = 1, n_points_extra_final_grid ! r2
r2(1) = final_grid_points_extra(1,jpoint)
r2(2) = final_grid_points_extra(2,jpoint)
r2(3) = final_grid_points_extra(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)
mu_tmp = mu_erf * r12
res(jpoint) = 0.5d0 * r12 * (1.d0 - derf(mu_tmp)) - inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / mu_erf
enddo
elseif(j2e_type .eq. "Boys") then
! j(r12) = 0.5 r12 / (1 + a_boys r_12)
PROVIDE a_boys
do jpoint = 1, n_points_extra_final_grid ! r2 do jpoint = 1, n_points_extra_final_grid ! r2
@ -209,27 +274,27 @@ subroutine j12_mu_r1_seq(r1, n_grid2, res)
r2(2) = final_grid_points_extra(2,jpoint) r2(2) = final_grid_points_extra(2,jpoint)
r2(3) = final_grid_points_extra(3,jpoint) r2(3) = final_grid_points_extra(3,jpoint)
r12 = dsqrt( (r1(1) - r2(1)) * (r1(1) - r2(1)) & dx = r1(1) - r2(1)
+ (r1(2) - r2(2)) * (r1(2) - r2(2)) & dy = r1(2) - r2(2)
+ (r1(3) - r2(3)) * (r1(3) - r2(3)) ) dz = r1(3) - r2(3)
mu_tmp = mu_erf * r12 r12 = dsqrt(dx * dx + dy * dy + dz * dz)
res(jpoint) = 0.5d0 * r12 * (1.d0 - derf(mu_tmp)) - inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / mu_erf res(jpoint) = 0.5d0 * r12 / (1.d0 + a_boys * r12)
enddo enddo
else else
print *, ' j1b_type = ', j1b_type, 'not implemented for j12_mu_r1_seq' print *, ' Error in j12_r1_seq: Unknown j2e_type = ', j2e_type
stop stop
endif endif ! j2e_type
return return
end subroutine j12_mu_r1_seq end
! --- ! ---
subroutine j1b_nucl_r1_seq(n_grid2, res) subroutine env_nucl_r1_seq(n_grid2, res)
! TODO ! TODO
! change loops order ! change loops order
@ -242,7 +307,7 @@ subroutine j1b_nucl_r1_seq(n_grid2, res)
integer :: i, jpoint integer :: i, jpoint
double precision :: a, d, e, x, y, z double precision :: a, d, e, x, y, z
if((j1b_type .eq. 2) .or. (j1b_type .eq. 102)) then if(env_type .eq. "Sum_Slat") then
res = 1.d0 res = 1.d0
@ -252,16 +317,16 @@ subroutine j1b_nucl_r1_seq(n_grid2, res)
r(3) = final_grid_points_extra(3,jpoint) r(3) = final_grid_points_extra(3,jpoint)
do i = 1, nucl_num do i = 1, nucl_num
a = j1b_pen(i) a = env_expo(i)
d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) & 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(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+ (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) ) + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
res(jpoint) -= dexp(-a*dsqrt(d)) res(jpoint) -= env_coef(i) * dexp(-a*dsqrt(d))
enddo enddo
enddo enddo
elseif((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then elseif(env_type .eq. "Prod_Gauss") then
res = 1.d0 res = 1.d0
@ -271,7 +336,7 @@ subroutine j1b_nucl_r1_seq(n_grid2, res)
r(3) = final_grid_points_extra(3,jpoint) r(3) = final_grid_points_extra(3,jpoint)
do i = 1, nucl_num do i = 1, nucl_num
a = j1b_pen(i) a = env_expo(i)
d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) & 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(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+ (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) ) + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
@ -281,7 +346,7 @@ subroutine j1b_nucl_r1_seq(n_grid2, res)
enddo enddo
enddo enddo
elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then elseif(env_type .eq. "Sum_Gauss") then
res = 1.d0 res = 1.d0
@ -291,15 +356,15 @@ subroutine j1b_nucl_r1_seq(n_grid2, res)
r(3) = final_grid_points_extra(3,jpoint) r(3) = final_grid_points_extra(3,jpoint)
do i = 1, nucl_num do i = 1, nucl_num
a = j1b_pen(i) a = env_expo(i)
d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) & 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(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+ (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) ) + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
res(jpoint) -= j1b_pen_coef(i) * dexp(-a*d) res(jpoint) -= env_coef(i) * dexp(-a*d)
enddo enddo
enddo enddo
elseif((j1b_type .eq. 5) .or. (j1b_type .eq. 105)) then elseif(env_type .eq. "Sum_Quartic") then
res = 1.d0 res = 1.d0
@ -309,24 +374,24 @@ subroutine j1b_nucl_r1_seq(n_grid2, res)
r(3) = final_grid_points_extra(3,jpoint) r(3) = final_grid_points_extra(3,jpoint)
do i = 1, nucl_num do i = 1, nucl_num
a = j1b_pen(i) a = env_expo(i)
x = r(1) - nucl_coord(i,1) x = r(1) - nucl_coord(i,1)
y = r(2) - nucl_coord(i,2) y = r(2) - nucl_coord(i,2)
z = r(3) - nucl_coord(i,3) z = r(3) - nucl_coord(i,3)
d = x*x + y*y + z*z d = x*x + y*y + z*z
res(jpoint) -= dexp(-a*d*d) res(jpoint) -= env_coef(i) * dexp(-a*d*d)
enddo enddo
enddo enddo
else else
print *, ' j1b_type = ', j1b_type, 'not implemented for j1b_nucl_r1_seq' print *, ' Error in env_nucl_r1_seq: Unknown env_type = ', env_type
stop stop
endif endif
return return
end subroutine j1b_nucl_r1_seq end
! --- ! ---

171
plugins/local/non_h_ints_mu/new_grad_tc.irp.f
View File

@ -1,171 +0,0 @@
! ---
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 (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(k,ipoint)
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 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)
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)
! = 1/2 \int dr1 (phi_k(r1) \grad_r1 phi_i(r1) - phi_i(r1) \grad_r1 phi_k(r1)) . \int dr2 (-1) \grad_r1 u(r1,r2) \phi_l(r2) \phi_j(r2)
!
! -1 in \int dr2
!
! 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 :: b_mat(:,:,:,:)
print*, ' providing tc_grad_and_lapl_ao ...'
call wall_time(time0)
if(read_tc_integ) then
open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/tc_grad_and_lapl_ao', action="read")
read(11) tc_grad_and_lapl_ao
close(11)
else
PROVIDE int2_grad1_u12_ao
allocate(b_mat(n_points_final_grid,ao_num,ao_num,3))
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
tc_grad_and_lapl_ao = 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, tc_grad_and_lapl_ao, ao_num*ao_num)
enddo
deallocate(b_mat)
call sum_A_At(tc_grad_and_lapl_ao(1,1,1,1), ao_num*ao_num)
endif
if(write_tc_integ.and.mpi_master) then
open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/tc_grad_and_lapl_ao', action="write")
call ezfio_set_work_empty(.False.)
write(11) tc_grad_and_lapl_ao
close(11)
call ezfio_set_tc_keywords_io_tc_integ('Read')
endif
call wall_time(time1)
print*, ' Wall time for tc_grad_and_lapl_ao = ', time1 - time0
call print_memory_usage()
END_PROVIDER
! ---

61
plugins/local/non_h_ints_mu/new_grad_tc_manu.irp.f
View File

@ -3,6 +3,15 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_test, (ao_num, ao_num, n_po
BEGIN_DOC BEGIN_DOC
! !
! !!!!!! WARNING !!!!!!!!!
!
! DEFINED WITH - SIGN
!
! FOR 3e-iontegrals this doesn't matter
!
! !!!!!! WARNING !!!!!!!!!
!
!
! int2_grad1_u12_ao_test(i,j,ipoint,:) = \int dr2 [-1 * \grad_r1 J(r1,r2)] \phi_i(r2) \phi_j(r2) ! 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) ! where r1 = r(ipoint)
@ -16,9 +25,9 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_test, (ao_num, ao_num, n_po
! !
! 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) ] ! 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) ] ! - \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 env_val(ipoint) * v_ij_erf_rk_cst_mu_env(i,j,ipoint) * r(:)
! - 0.5 v_1b(ipoint) * x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,:) ! - 0.5 env_val(ipoint) * x_v_ij_erf_rk_cst_mu_env(i,j,ipoint,:)
! - v_1b_grad[:,ipoint] * v_ij_u_cst_mu_j1b(i,j,ipoint) ! - env_grad[:,ipoint] * v_ij_u_cst_mu_env(i,j,ipoint)
! !
! !
END_DOC END_DOC
@ -31,8 +40,6 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_test, (ao_num, ao_num, n_po
print*, ' providing int2_grad1_u12_ao_test ...' print*, ' providing int2_grad1_u12_ao_test ...'
call wall_time(time0) call wall_time(time0)
PROVIDE j1b_type
if(read_tc_integ) then if(read_tc_integ) then
open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/int2_grad1_u12_ao_test', action="read") open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/int2_grad1_u12_ao_test', action="read")
@ -41,41 +48,33 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_test, (ao_num, ao_num, n_po
else else
if(j1b_type .eq. 3) then if((j2e_type .eq. "Mu") .and. (env_type .eq. "Prod_Gauss")) then
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
x = final_grid_points(1,ipoint) x = final_grid_points(1,ipoint)
y = final_grid_points(2,ipoint) y = final_grid_points(2,ipoint)
z = final_grid_points(3,ipoint) z = final_grid_points(3,ipoint)
tmp0 = 0.5d0 * v_1b(ipoint) tmp0 = 0.5d0 * env_val(ipoint)
tmp_x = v_1b_grad(1,ipoint) tmp_x = env_grad(1,ipoint)
tmp_y = v_1b_grad(2,ipoint) tmp_y = env_grad(2,ipoint)
tmp_z = v_1b_grad(3,ipoint) tmp_z = env_grad(3,ipoint)
do j = 1, ao_num do j = 1, ao_num
do i = 1, ao_num do i = 1, ao_num
tmp1 = tmp0 * v_ij_erf_rk_cst_mu_j1b_test(i,j,ipoint) tmp1 = tmp0 * v_ij_erf_rk_cst_mu_env_test(i,j,ipoint)
tmp2 = v_ij_u_cst_mu_j1b_test(i,j,ipoint) tmp2 = v_ij_u_cst_mu_env_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,1) = tmp1 * x - tmp0 * x_v_ij_erf_rk_cst_mu_env_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,2) = tmp1 * y - tmp0 * x_v_ij_erf_rk_cst_mu_env_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 int2_grad1_u12_ao_test(i,j,ipoint,3) = tmp1 * z - tmp0 * x_v_ij_erf_rk_cst_mu_env_test(i,j,ipoint,3) - tmp2 * tmp_z
enddo enddo
enddo enddo
enddo enddo
else else
do ipoint = 1, n_points_final_grid
x = final_grid_points(1,ipoint) print *, ' Error in int2_grad1_u12_ao_test: Unknown j2e_type = ', j2e_type
y = final_grid_points(2,ipoint) stop
z = final_grid_points(3,ipoint)
do j = 1, ao_num endif ! j2e_type
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
endif endif
@ -191,7 +190,7 @@ BEGIN_PROVIDER [double precision, tc_grad_and_lapl_ao_test, (ao_num, ao_num, ao_
endif endif
call wall_time(time1) call wall_time(time1)
print*, ' Wall time for tc_grad_and_lapl_ao_test = ', time1 - time0 print*, ' Wall time for tc_grad_and_lapl_ao_test (min) = ', (time1 - time0) / 60.d0
END_PROVIDER END_PROVIDER

221
plugins/local/non_h_ints_mu/numerical_integ.irp.f
View File

@ -1,11 +1,11 @@
! --- ! ---
double precision function num_v_ij_u_cst_mu_j1b(i, j, ipoint) double precision function num_v_ij_u_cst_mu_env(i, j, ipoint)
BEGIN_DOC BEGIN_DOC
! !
! \int dr2 u12 \phi_i(r2) \phi_j(r2) x v_1b(r2) ! \int dr2 u12 \phi_i(r2) \phi_j(r2) x v_env(r2)
! !
END_DOC END_DOC
@ -17,31 +17,31 @@ double precision function num_v_ij_u_cst_mu_j1b(i, j, ipoint)
double precision :: r1(3), r2(3) double precision :: r1(3), r2(3)
double precision, external :: ao_value double precision, external :: ao_value
double precision, external :: j12_mu, j1b_nucl, j12_mu_gauss double precision, external :: j12_mu, env_nucl, j12_mu_gauss
r1(1) = final_grid_points(1,ipoint) r1(1) = final_grid_points(1,ipoint)
r1(2) = final_grid_points(2,ipoint) r1(2) = final_grid_points(2,ipoint)
r1(3) = final_grid_points(3,ipoint) r1(3) = final_grid_points(3,ipoint)
num_v_ij_u_cst_mu_j1b = 0.d0 num_v_ij_u_cst_mu_env = 0.d0
do jpoint = 1, n_points_final_grid do jpoint = 1, n_points_final_grid
r2(1) = final_grid_points(1,jpoint) r2(1) = final_grid_points(1,jpoint)
r2(2) = final_grid_points(2,jpoint) r2(2) = final_grid_points(2,jpoint)
r2(3) = final_grid_points(3,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) num_v_ij_u_cst_mu_env += ao_value(i, r2) * ao_value(j, r2) * j12_mu_gauss(r1, r2) * env_nucl(r2) * final_weight_at_r_vector(jpoint)
enddo enddo
return return
end function num_v_ij_u_cst_mu_j1b end
! --- ! ---
double precision function num_int2_u2_j1b2(i, j, ipoint) double precision function num_int2_u2_env2(i, j, ipoint)
BEGIN_DOC BEGIN_DOC
! !
! \int dr2 u12^2 \phi_i(r2) \phi_j(r2) x v_1b(r2)^2 ! \int dr2 u12^2 \phi_i(r2) \phi_j(r2) x v_env(r2)^2
! !
END_DOC END_DOC
@ -54,14 +54,14 @@ double precision function num_int2_u2_j1b2(i, j, ipoint)
double precision :: dx, dy, dz, r12, x2, tmp1, tmp2, tmp3, coef, expo double precision :: dx, dy, dz, r12, x2, tmp1, tmp2, tmp3, coef, expo
double precision, external :: ao_value double precision, external :: ao_value
double precision, external :: j1b_nucl double precision, external :: env_nucl
double precision, external :: j12_mu double precision, external :: j12_mu
r1(1) = final_grid_points(1,ipoint) r1(1) = final_grid_points(1,ipoint)
r1(2) = final_grid_points(2,ipoint) r1(2) = final_grid_points(2,ipoint)
r1(3) = final_grid_points(3,ipoint) r1(3) = final_grid_points(3,ipoint)
num_int2_u2_j1b2 = 0.d0 num_int2_u2_env2 = 0.d0
do jpoint = 1, n_points_final_grid do jpoint = 1, n_points_final_grid
r2(1) = final_grid_points(1,jpoint) r2(1) = final_grid_points(1,jpoint)
r2(2) = final_grid_points(2,jpoint) r2(2) = final_grid_points(2,jpoint)
@ -72,7 +72,7 @@ double precision function num_int2_u2_j1b2(i, j, ipoint)
x2 = dx * dx + dy * dy + dz * dz x2 = dx * dx + dy * dy + dz * dz
r12 = dsqrt(x2) r12 = dsqrt(x2)
tmp1 = j1b_nucl(r2) tmp1 = env_nucl(r2)
tmp2 = tmp1 * tmp1 * ao_value(i, r2) * ao_value(j, r2) * final_weight_at_r_vector(jpoint) tmp2 = tmp1 * tmp1 * ao_value(i, r2) * ao_value(j, r2) * final_weight_at_r_vector(jpoint)
!tmp3 = 0.d0 !tmp3 = 0.d0
@ -84,19 +84,19 @@ double precision function num_int2_u2_j1b2(i, j, ipoint)
tmp3 = j12_mu(r1, r2) tmp3 = j12_mu(r1, r2)
tmp3 = tmp3 * tmp3 tmp3 = tmp3 * tmp3
num_int2_u2_j1b2 += tmp2 * tmp3 num_int2_u2_env2 += tmp2 * tmp3
enddo enddo
return return
end function num_int2_u2_j1b2 end
! --- ! ---
double precision function num_int2_grad1u2_grad2u2_j1b2(i, j, ipoint) double precision function num_int2_grad1u2_grad2u2_env2(i, j, ipoint)
BEGIN_DOC BEGIN_DOC
! !
! \int dr2 \frac{-[erf(mu r12) -1]^2}{4} \phi_i(r2) \phi_j(r2) x v_1b(r2)^2 ! \int dr2 \frac{-[erf(mu r12) -1]^2}{4} \phi_i(r2) \phi_j(r2) x v_env(r2)^2
! !
END_DOC END_DOC
@ -109,13 +109,13 @@ double precision function num_int2_grad1u2_grad2u2_j1b2(i, j, ipoint)
double precision :: dx, dy, dz, r12, x2, tmp1, tmp2, tmp3, coef, expo double precision :: dx, dy, dz, r12, x2, tmp1, tmp2, tmp3, coef, expo
double precision, external :: ao_value double precision, external :: ao_value
double precision, external :: j1b_nucl double precision, external :: env_nucl
r1(1) = final_grid_points(1,ipoint) r1(1) = final_grid_points(1,ipoint)
r1(2) = final_grid_points(2,ipoint) r1(2) = final_grid_points(2,ipoint)
r1(3) = final_grid_points(3,ipoint) r1(3) = final_grid_points(3,ipoint)
num_int2_grad1u2_grad2u2_j1b2 = 0.d0 num_int2_grad1u2_grad2u2_env2 = 0.d0
do jpoint = 1, n_points_final_grid do jpoint = 1, n_points_final_grid
r2(1) = final_grid_points(1,jpoint) r2(1) = final_grid_points(1,jpoint)
r2(2) = final_grid_points(2,jpoint) r2(2) = final_grid_points(2,jpoint)
@ -126,7 +126,7 @@ double precision function num_int2_grad1u2_grad2u2_j1b2(i, j, ipoint)
x2 = dx * dx + dy * dy + dz * dz x2 = dx * dx + dy * dy + dz * dz
r12 = dsqrt(x2) r12 = dsqrt(x2)
tmp1 = j1b_nucl(r2) tmp1 = env_nucl(r2)
tmp2 = tmp1 * tmp1 * ao_value(i, r2) * ao_value(j, r2) * final_weight_at_r_vector(jpoint) tmp2 = tmp1 * tmp1 * ao_value(i, r2) * ao_value(j, r2) * final_weight_at_r_vector(jpoint)
!tmp3 = 0.d0 !tmp3 = 0.d0
@ -140,19 +140,19 @@ double precision function num_int2_grad1u2_grad2u2_j1b2(i, j, ipoint)
tmp3 = -0.25d0 * tmp3 tmp3 = -0.25d0 * tmp3
num_int2_grad1u2_grad2u2_j1b2 += tmp2 * tmp3 num_int2_grad1u2_grad2u2_env2 += tmp2 * tmp3
enddo enddo
return return
end function num_int2_grad1u2_grad2u2_j1b2 end
! --- ! ---
double precision function num_v_ij_erf_rk_cst_mu_j1b(i, j, ipoint) double precision function num_v_ij_erf_rk_cst_mu_env(i, j, ipoint)
BEGIN_DOC BEGIN_DOC
! !
! \int dr2 [erf(mu r12) -1]/r12 \phi_i(r2) \phi_j(r2) x v_1b(r2) ! \int dr2 [erf(mu r12) -1]/r12 \phi_i(r2) \phi_j(r2) x v_env(r2)
! !
END_DOC END_DOC
@ -165,13 +165,13 @@ double precision function num_v_ij_erf_rk_cst_mu_j1b(i, j, ipoint)
double precision :: dx, dy, dz, r12, tmp1, tmp2 double precision :: dx, dy, dz, r12, tmp1, tmp2
double precision, external :: ao_value double precision, external :: ao_value
double precision, external :: j1b_nucl double precision, external :: env_nucl
r1(1) = final_grid_points(1,ipoint) r1(1) = final_grid_points(1,ipoint)
r1(2) = final_grid_points(2,ipoint) r1(2) = final_grid_points(2,ipoint)
r1(3) = final_grid_points(3,ipoint) r1(3) = final_grid_points(3,ipoint)
num_v_ij_erf_rk_cst_mu_j1b = 0.d0 num_v_ij_erf_rk_cst_mu_env = 0.d0
do jpoint = 1, n_points_final_grid do jpoint = 1, n_points_final_grid
r2(1) = final_grid_points(1,jpoint) r2(1) = final_grid_points(1,jpoint)
r2(2) = final_grid_points(2,jpoint) r2(2) = final_grid_points(2,jpoint)
@ -183,21 +183,21 @@ double precision function num_v_ij_erf_rk_cst_mu_j1b(i, j, ipoint)
if(r12 .lt. 1d-10) cycle if(r12 .lt. 1d-10) cycle
tmp1 = (derf(mu_erf * r12) - 1.d0) / r12 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) tmp2 = tmp1 * ao_value(i, r2) * ao_value(j, r2) * env_nucl(r2) * final_weight_at_r_vector(jpoint)
num_v_ij_erf_rk_cst_mu_j1b += tmp2 num_v_ij_erf_rk_cst_mu_env += tmp2
enddo enddo
return return
end function num_v_ij_erf_rk_cst_mu_j1b end
! --- ! ---
subroutine num_x_v_ij_erf_rk_cst_mu_j1b(i, j, ipoint, integ) subroutine num_x_v_ij_erf_rk_cst_mu_env(i, j, ipoint, integ)
BEGIN_DOC BEGIN_DOC
! !
! \int dr2 [erf(mu r12) -1]/r12 \phi_i(r2) \phi_j(r2) x v_1b(r2) x r2 ! \int dr2 [erf(mu r12) -1]/r12 \phi_i(r2) \phi_j(r2) x v_env(r2) x r2
! !
END_DOC END_DOC
@ -212,7 +212,7 @@ subroutine num_x_v_ij_erf_rk_cst_mu_j1b(i, j, ipoint, integ)
double precision :: tmp_x, tmp_y, tmp_z double precision :: tmp_x, tmp_y, tmp_z
double precision, external :: ao_value double precision, external :: ao_value
double precision, external :: j1b_nucl double precision, external :: env_nucl
r1(1) = final_grid_points(1,ipoint) r1(1) = final_grid_points(1,ipoint)
r1(2) = final_grid_points(2,ipoint) r1(2) = final_grid_points(2,ipoint)
@ -232,7 +232,7 @@ subroutine num_x_v_ij_erf_rk_cst_mu_j1b(i, j, ipoint, integ)
if(r12 .lt. 1d-10) cycle if(r12 .lt. 1d-10) cycle
tmp1 = (derf(mu_erf * r12) - 1.d0) / r12 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) tmp2 = tmp1 * ao_value(i, r2) * ao_value(j, r2) * env_nucl(r2) * final_weight_at_r_vector(jpoint)
tmp_x += tmp2 * r2(1) tmp_x += tmp2 * r2(1)
tmp_y += tmp2 * r2(2) tmp_y += tmp2 * r2(2)
@ -244,7 +244,7 @@ subroutine num_x_v_ij_erf_rk_cst_mu_j1b(i, j, ipoint, integ)
integ(3) = tmp_z integ(3) = tmp_z
return return
end subroutine num_x_v_ij_erf_rk_cst_mu_j1b end
! --- ! ---
@ -252,7 +252,7 @@ subroutine num_int2_grad1_u12_ao(i, j, ipoint, integ)
BEGIN_DOC BEGIN_DOC
! !
! \int dr2 [-grad_1 u12] \phi_i(r2) \phi_j(r2) x v12_1b(r1, r2) ! \int dr2 [-grad_1 u12] \phi_i(r2) \phi_j(r2) x v12_env(r1, r2)
! !
END_DOC END_DOC
@ -292,78 +292,7 @@ subroutine num_int2_grad1_u12_ao(i, j, ipoint, integ)
integ(3) = tmp_z integ(3) = tmp_z
return return
end subroutine num_int2_grad1_u12_ao end
! ---
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_num
double precision, external :: grad_y_j1b_nucl_num
double precision, external :: grad_z_j1b_nucl_num
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_num(r1)
dy1_v1 = grad_y_j1b_nucl_num(r1)
dz1_v1 = grad_z_j1b_nucl_num(r1)
call grad1_j12_mu(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
! --- ! ---
@ -388,11 +317,11 @@ double precision function num_grad12_j12(i, j, ipoint)
double precision :: fst_term, scd_term, thd_term, tmp double precision :: fst_term, scd_term, thd_term, tmp
double precision, external :: ao_value double precision, external :: ao_value
double precision, external :: j1b_nucl double precision, external :: env_nucl
double precision, external :: j12_mu double precision, external :: j12_mu
double precision, external :: grad_x_j1b_nucl_num double precision, external :: grad_x_env_nucl_num
double precision, external :: grad_y_j1b_nucl_num double precision, external :: grad_y_env_nucl_num
double precision, external :: grad_z_j1b_nucl_num double precision, external :: grad_z_env_nucl_num
r1(1) = final_grid_points(1,ipoint) r1(1) = final_grid_points(1,ipoint)
r1(2) = final_grid_points(2,ipoint) r1(2) = final_grid_points(2,ipoint)
@ -410,15 +339,15 @@ double precision function num_grad12_j12(i, j, ipoint)
tmp_z = r1(3) - r2(3) tmp_z = r1(3) - r2(3)
r12 = dsqrt(tmp_x*tmp_x + tmp_y*tmp_y + tmp_z*tmp_z) r12 = dsqrt(tmp_x*tmp_x + tmp_y*tmp_y + tmp_z*tmp_z)
dx1_v1 = grad_x_j1b_nucl_num(r1) dx1_v1 = grad_x_env_nucl_num(r1)
dy1_v1 = grad_y_j1b_nucl_num(r1) dy1_v1 = grad_y_env_nucl_num(r1)
dz1_v1 = grad_z_j1b_nucl_num(r1) dz1_v1 = grad_z_env_nucl_num(r1)
call grad1_j12_mu(r1, r2, grad_u12) call grad1_j12_mu(r1, r2, grad_u12)
tmp1 = 1.d0 - derf(mu_erf * r12) tmp1 = 1.d0 - derf(mu_erf * r12)
v1_tmp = j1b_nucl(r1) v1_tmp = env_nucl(r1)
v2_tmp = j1b_nucl(r2) v2_tmp = env_nucl(r2)
u12_tmp = j12_mu(r1, r2) u12_tmp = j12_mu(r1, r2)
fst_term = 0.5d0 * tmp1 * tmp1 * v1_tmp * v1_tmp fst_term = 0.5d0 * tmp1 * tmp1 * v1_tmp * v1_tmp
@ -429,11 +358,11 @@ double precision function num_grad12_j12(i, j, ipoint)
enddo enddo
return return
end function num_grad12_j12 end
! --- ! ---
double precision function num_u12sq_j1bsq(i, j, ipoint) double precision function num_u12sq_envsq(i, j, ipoint)
BEGIN_DOC BEGIN_DOC
! !
@ -454,17 +383,17 @@ double precision function num_u12sq_j1bsq(i, j, ipoint)
double precision :: fst_term, scd_term, thd_term, tmp double precision :: fst_term, scd_term, thd_term, tmp
double precision, external :: ao_value double precision, external :: ao_value
double precision, external :: j1b_nucl double precision, external :: env_nucl
double precision, external :: j12_mu double precision, external :: j12_mu
double precision, external :: grad_x_j1b_nucl_num double precision, external :: grad_x_env_nucl_num
double precision, external :: grad_y_j1b_nucl_num double precision, external :: grad_y_env_nucl_num
double precision, external :: grad_z_j1b_nucl_num double precision, external :: grad_z_env_nucl_num
r1(1) = final_grid_points(1,ipoint) r1(1) = final_grid_points(1,ipoint)
r1(2) = final_grid_points(2,ipoint) r1(2) = final_grid_points(2,ipoint)
r1(3) = final_grid_points(3,ipoint) r1(3) = final_grid_points(3,ipoint)
num_u12sq_j1bsq = 0.d0 num_u12sq_envsq = 0.d0
do jpoint = 1, n_points_final_grid do jpoint = 1, n_points_final_grid
r2(1) = final_grid_points(1,jpoint) r2(1) = final_grid_points(1,jpoint)
@ -476,30 +405,30 @@ double precision function num_u12sq_j1bsq(i, j, ipoint)
tmp_z = r1(3) - r2(3) tmp_z = r1(3) - r2(3)
r12 = dsqrt(tmp_x*tmp_x + tmp_y*tmp_y + tmp_z*tmp_z) r12 = dsqrt(tmp_x*tmp_x + tmp_y*tmp_y + tmp_z*tmp_z)
dx1_v1 = grad_x_j1b_nucl_num(r1) dx1_v1 = grad_x_env_nucl_num(r1)
dy1_v1 = grad_y_j1b_nucl_num(r1) dy1_v1 = grad_y_env_nucl_num(r1)
dz1_v1 = grad_z_j1b_nucl_num(r1) dz1_v1 = grad_z_env_nucl_num(r1)
call grad1_j12_mu(r1, r2, grad_u12) call grad1_j12_mu(r1, r2, grad_u12)
tmp1 = 1.d0 - derf(mu_erf * r12) tmp1 = 1.d0 - derf(mu_erf * r12)
v1_tmp = j1b_nucl(r1) v1_tmp = env_nucl(r1)
v2_tmp = j1b_nucl(r2) v2_tmp = env_nucl(r2)
u12_tmp = j12_mu(r1, 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) 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 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 num_u12sq_envsq += tmp
enddo enddo
return return
end function num_u12sq_j1bsq end
! --- ! ---
double precision function num_u12_grad1_u12_j1b_grad1_j1b(i, j, ipoint) double precision function num_u12_grad1_u12_env_grad1_env(i, j, ipoint)
BEGIN_DOC BEGIN_DOC
! !
@ -520,17 +449,17 @@ double precision function num_u12_grad1_u12_j1b_grad1_j1b(i, j, ipoint)
double precision :: fst_term, scd_term, thd_term, tmp double precision :: fst_term, scd_term, thd_term, tmp
double precision, external :: ao_value double precision, external :: ao_value
double precision, external :: j1b_nucl double precision, external :: env_nucl
double precision, external :: j12_mu double precision, external :: j12_mu
double precision, external :: grad_x_j1b_nucl_num double precision, external :: grad_x_env_nucl_num
double precision, external :: grad_y_j1b_nucl_num double precision, external :: grad_y_env_nucl_num
double precision, external :: grad_z_j1b_nucl_num double precision, external :: grad_z_env_nucl_num
r1(1) = final_grid_points(1,ipoint) r1(1) = final_grid_points(1,ipoint)
r1(2) = final_grid_points(2,ipoint) r1(2) = final_grid_points(2,ipoint)
r1(3) = final_grid_points(3,ipoint) r1(3) = final_grid_points(3,ipoint)
num_u12_grad1_u12_j1b_grad1_j1b = 0.d0 num_u12_grad1_u12_env_grad1_env = 0.d0
do jpoint = 1, n_points_final_grid do jpoint = 1, n_points_final_grid
r2(1) = final_grid_points(1,jpoint) r2(1) = final_grid_points(1,jpoint)
@ -542,34 +471,34 @@ double precision function num_u12_grad1_u12_j1b_grad1_j1b(i, j, ipoint)
tmp_z = r1(3) - r2(3) tmp_z = r1(3) - r2(3)
r12 = dsqrt(tmp_x*tmp_x + tmp_y*tmp_y + tmp_z*tmp_z) r12 = dsqrt(tmp_x*tmp_x + tmp_y*tmp_y + tmp_z*tmp_z)
dx1_v1 = grad_x_j1b_nucl_num(r1) dx1_v1 = grad_x_env_nucl_num(r1)
dy1_v1 = grad_y_j1b_nucl_num(r1) dy1_v1 = grad_y_env_nucl_num(r1)
dz1_v1 = grad_z_j1b_nucl_num(r1) dz1_v1 = grad_z_env_nucl_num(r1)
call grad1_j12_mu(r1, r2, grad_u12) call grad1_j12_mu(r1, r2, grad_u12)
tmp1 = 1.d0 - derf(mu_erf * r12) tmp1 = 1.d0 - derf(mu_erf * r12)
v1_tmp = j1b_nucl(r1) v1_tmp = env_nucl(r1)
v2_tmp = j1b_nucl(r2) v2_tmp = env_nucl(r2)
u12_tmp = j12_mu(r1, 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)) 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 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 num_u12_grad1_u12_env_grad1_env += tmp
enddo enddo
return return
end function num_u12_grad1_u12_j1b_grad1_j1b end
! --- ! ---
subroutine num_int2_u_grad1u_total_j1b2(i, j, ipoint, integ) subroutine num_int2_u_grad1u_total_env2(i, j, ipoint, integ)
BEGIN_DOC BEGIN_DOC
! !
! \int dr2 u12 (grad_1 u12) \phi_i(r2) \phi_j(r2) x v_1b(r2)^2 ! \int dr2 u12 (grad_1 u12) \phi_i(r2) \phi_j(r2) x v_env(r2)^2
! !
END_DOC END_DOC
@ -584,7 +513,7 @@ subroutine num_int2_u_grad1u_total_j1b2(i, j, ipoint, integ)
double precision :: tmp_x, tmp_y, tmp_z double precision :: tmp_x, tmp_y, tmp_z
double precision, external :: ao_value double precision, external :: ao_value
double precision, external :: j1b_nucl double precision, external :: env_nucl
double precision, external :: j12_mu double precision, external :: j12_mu
r1(1) = final_grid_points(1,ipoint) r1(1) = final_grid_points(1,ipoint)
@ -604,7 +533,7 @@ subroutine num_int2_u_grad1u_total_j1b2(i, j, ipoint, integ)
r12 = dsqrt( dx * dx + dy * dy + dz * dz ) r12 = dsqrt( dx * dx + dy * dy + dz * dz )
if(r12 .lt. 1d-10) cycle if(r12 .lt. 1d-10) cycle
tmp0 = j1b_nucl(r2) tmp0 = env_nucl(r2)
tmp1 = 0.5d0 * j12_mu(r1, r2) * (1.d0 - derf(mu_erf * r12)) / r12 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) tmp2 = tmp0 * tmp0 * tmp1 * ao_value(i, r2) * ao_value(j, r2) * final_weight_at_r_vector(jpoint)
@ -618,6 +547,6 @@ subroutine num_int2_u_grad1u_total_j1b2(i, j, ipoint, integ)
integ(3) = tmp_z integ(3) = tmp_z
return return
end subroutine num_int2_u_grad1u_total_j1b2 end
! --- ! ---

398
plugins/local/non_h_ints_mu/tc_integ.irp.f Normal file
View File

@ -0,0 +1,398 @@
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 [\grad_r1 J(r1,r2)] \phi_i(r2) \phi_j(r2)
!
! where r1 = r(ipoint)
!
END_DOC
implicit none
integer :: ipoint, i, j, m, jpoint
double precision :: time0, time1
double precision :: x, y, z, r2
double precision :: dx, dy, dz
double precision :: tmp_ct
double precision :: tmp0, tmp1, tmp2
double precision :: tmp0_x, tmp0_y, tmp0_z
double precision :: tmp1_x, tmp1_y, tmp1_z
PROVIDE j2e_type
PROVIDE j1e_type
call wall_time(time0)
print*, ' providing int2_grad1_u12_ao ...'
if(read_tc_integ) then
print*, ' Reading int2_grad1_u12_ao from ', trim(ezfio_filename) // '/work/int2_grad1_u12_ao'
open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/int2_grad1_u12_ao', action="read")
read(11) int2_grad1_u12_ao
close(11)
else
if(tc_integ_type .eq. "analytic") then
write(*, '(A, A, A)') ' Error: The integration type ', trim(tc_integ_type), ' has not been implemented yet.'
stop
elseif(tc_integ_type .eq. "numeric") then
print *, ' Numerical integration over r1 and r2 will be performed'
! TODO combine 1shot & int2_grad1_u12_ao_num
PROVIDE int2_grad1_u12_ao_num
int2_grad1_u12_ao = int2_grad1_u12_ao_num
!PROVIDE int2_grad1_u12_ao_num_1shot
!int2_grad1_u12_ao = int2_grad1_u12_ao_num_1shot
elseif(tc_integ_type .eq. "semi-analytic") then
print*, ' Numerical integration over r1, with analytical integration over r2'
! ---
if(j2e_type .eq. "None") then
int2_grad1_u12_ao = 0.d0
elseif( (j2e_type .eq. "Mu") .and. &
( (env_type .eq. "None") .or. (env_type .eq. "Prod_Gauss") .or. (env_type .eq. "Sum_Gauss") ) ) then
PROVIDE int2_grad1_u2e_ao
int2_grad1_u12_ao = int2_grad1_u2e_ao
else
print *, ' Error in int2_grad1_u12_ao: Unknown Jastrow'
stop
endif ! j2e_type
! ---
if(j1e_type .ne. "None") then
PROVIDE elec_num
PROVIDE ao_overlap
PROVIDE j1e_gradx j1e_grady j1e_gradz
tmp_ct = 1.d0 / (dble(elec_num) - 1.d0)
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, tmp0_x, tmp0_y, tmp0_z) &
!$OMP SHARED (ao_num, n_points_final_grid, tmp_ct, ao_overlap, &
!$OMP j1e_gradx, j1e_grady, j1e_gradz, int2_grad1_u12_ao)
!$OMP DO
do ipoint = 1, n_points_final_grid
tmp0_x = tmp_ct * j1e_gradx(ipoint)
tmp0_y = tmp_ct * j1e_grady(ipoint)
tmp0_z = tmp_ct * j1e_gradz(ipoint)
do j = 1, ao_num
do i = 1, ao_num
int2_grad1_u12_ao(i,j,ipoint,1) = int2_grad1_u12_ao(i,j,ipoint,1) + tmp0_x * ao_overlap(i,j)
int2_grad1_u12_ao(i,j,ipoint,2) = int2_grad1_u12_ao(i,j,ipoint,2) + tmp0_y * ao_overlap(i,j)
int2_grad1_u12_ao(i,j,ipoint,3) = int2_grad1_u12_ao(i,j,ipoint,3) + tmp0_z * ao_overlap(i,j)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
endif ! j1e_type
! ---
else
write(*, '(A, A, A)') ' Error: The integration type ', trim(tc_integ_type), ' has not been implemented yet'
stop
endif ! tc_integ_type
endif ! read_tc_integ
if(write_tc_integ .and. mpi_master) then
print*, ' Writing int2_grad1_u12_ao in ', trim(ezfio_filename) // '/work/int2_grad1_u12_ao'
open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/int2_grad1_u12_ao', action="write")
call ezfio_set_work_empty(.False.)
write(11) int2_grad1_u12_ao
close(11)
call ezfio_set_tc_keywords_io_tc_integ('Read')
endif
call wall_time(time1)
print*, ' wall time for int2_grad1_u12_ao (min) =', (time1-time0)/60.d0
call print_memory_usage()
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, int2_grad1_u12_square_ao, (ao_num, ao_num, n_points_final_grid)]
BEGIN_DOC
!
! int2_grad1_u12_square_ao = -(1/2) x int dr2 chi_l(r2) chi_j(r2) [grad_1 u(r1,r2)]^2
!
END_DOC
implicit none
integer :: ipoint, i, j, m, jpoint
double precision :: x, y, z, r2
double precision :: dx, dy, dz, dr2
double precision :: dx1, dy1, dz1, dx2, dy2, dz2, dr12
double precision :: tmp_ct, tmp_ct1, tmp_ct2
double precision :: tmp0, tmp1, tmp2
double precision :: tmp3, tmp4, tmp5, tmp6
double precision :: tmp0_x, tmp0_y, tmp0_z
double precision :: tmp1_x, tmp1_y, tmp1_z
double precision :: time0, time1
PROVIDE j2e_type
PROVIDE j1e_type
PROVIDE tc_integ_type
call wall_time(time0)
print*, ' providing int2_grad1_u12_square_ao ...'
if(tc_integ_type .eq. "analytic") then
write(*, '(A, A, A)') ' Error: The integration type ', trim(tc_integ_type), ' has not been implemented yet.'
stop
elseif(tc_integ_type .eq. "numeric") then
print *, ' Numerical integration over r1 and r2 will be performed'
! TODO combine 1shot & int2_grad1_u12_square_ao_num
PROVIDE int2_grad1_u12_square_ao_num
int2_grad1_u12_square_ao = int2_grad1_u12_square_ao_num
!PROVIDE int2_grad1_u12_square_ao_num_1shot
!int2_grad1_u12_square_ao = int2_grad1_u12_square_ao_num_1shot
elseif(tc_integ_type .eq. "semi-analytic") then
print*, ' Numerical integration over r1, with analytical integration over r2'
! ---
if(j2e_type .eq. "None") then
int2_grad1_u12_square_ao = 0.d0
elseif((j2e_type .eq. "Mu") .and. (env_type .eq. "None")) then
PROVIDE int2_grad1u2_grad2u2
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, ipoint) &
!$OMP SHARED (int2_grad1_u12_square_ao, ao_num, n_points_final_grid, int2_grad1u2_grad2u2)
!$OMP DO SCHEDULE (static)
do ipoint = 1, n_points_final_grid
do j = 1, ao_num
do i = 1, ao_num
int2_grad1_u12_square_ao(i,j,ipoint) = -0.5d0 * int2_grad1u2_grad2u2(i,j,ipoint)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
FREE int2_grad1u2_grad2u2
elseif((j2e_type .eq. "Mu") .and. (env_type .eq. "Prod_Gauss")) then
PROVIDE mu_erf
PROVIDE env_val env_grad
if(use_ipp) then
! the term u12_grad1_u12_env_grad1_env is added directly for performance
PROVIDE u12sq_envsq grad12_j12
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, ipoint) &
!$OMP SHARED (int2_grad1_u12_square_ao, ao_num, n_points_final_grid, u12sq_envsq, grad12_j12)
!$OMP DO SCHEDULE (static)
do ipoint = 1, n_points_final_grid
do j = 1, ao_num
do i = 1, ao_num
int2_grad1_u12_square_ao(i,j,ipoint) = u12sq_envsq(i,j,ipoint) + 0.5d0 * grad12_j12(i,j,ipoint)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
FREE u12sq_envsq grad12_j12
else
PROVIDE u12sq_envsq u12_grad1_u12_env_grad1_env grad12_j12
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, ipoint) &
!$OMP SHARED (int2_grad1_u12_square_ao, ao_num, n_points_final_grid, u12sq_envsq, grad12_j12, u12_grad1_u12_env_grad1_env)
!$OMP DO SCHEDULE (static)
do ipoint = 1, n_points_final_grid
do j = 1, ao_num
do i = 1, ao_num
int2_grad1_u12_square_ao(i,j,ipoint) = u12sq_envsq(i,j,ipoint) + u12_grad1_u12_env_grad1_env(i,j,ipoint) + 0.5d0 * grad12_j12(i,j,ipoint)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
FREE u12sq_envsq u12_grad1_u12_env_grad1_env grad12_j12
endif ! use_ipp
elseif((j2e_type .eq. "Mu") .and. (env_type .eq. "Sum_Gauss")) then
PROVIDE mu_erf
PROVIDE env_type env_val env_grad
if(use_ipp) then
! do not free int2_u2_env2 here
PROVIDE int2_u2_env2
PROVIDE int2_grad1u2_grad2u2_env2
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, ipoint, tmp0_x, tmp0_y, tmp0_z, tmp1, tmp2) &
!$OMP SHARED (int2_grad1_u12_square_ao, ao_num, n_points_final_grid, &
!$OMP env_val, env_grad, int2_u2_env2, int2_grad1u2_grad2u2_env2)
!$OMP DO SCHEDULE (static)
do ipoint = 1, n_points_final_grid
tmp0_x = env_grad(1,ipoint)
tmp0_y = env_grad(2,ipoint)
tmp0_z = env_grad(3,ipoint)
tmp1 = -0.5d0 * (tmp0_x * tmp0_x + tmp0_y * tmp0_y + tmp0_z * tmp0_z)
tmp2 = 0.5d0 * env_val(ipoint) * env_val(ipoint)
do j = 1, ao_num
do i = 1, ao_num
int2_grad1_u12_square_ao(i,j,ipoint) = tmp1 * int2_u2_env2(i,j,ipoint) + tmp2 * int2_grad1u2_grad2u2_env2(i,j,ipoint)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
FREE int2_grad1u2_grad2u2_env2
else
PROVIDE u12sq_envsq u12_grad1_u12_env_grad1_env grad12_j12
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, ipoint) &
!$OMP SHARED (int2_grad1_u12_square_ao, ao_num, n_points_final_grid, u12sq_envsq, grad12_j12, u12_grad1_u12_env_grad1_env)
!$OMP DO SCHEDULE (static)
do ipoint = 1, n_points_final_grid
do j = 1, ao_num
do i = 1, ao_num
int2_grad1_u12_square_ao(i,j,ipoint) = u12sq_envsq(i,j,ipoint) + u12_grad1_u12_env_grad1_env(i,j,ipoint) + 0.5d0 * grad12_j12(i,j,ipoint)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
FREE u12sq_envsq u12_grad1_u12_env_grad1_env grad12_j12
endif ! use_ipp
else
print *, ' Error in int2_grad1_u12_square_ao: Unknown Jastrow'
stop
endif ! j2e_type
! ---
if(j1e_type .ne. "None") then
PROVIDE elec_num
PROVIDE ao_overlap
PROVIDE j1e_gradx j1e_grady j1e_gradz
PROVIDE int2_grad1_u2e_ao
tmp_ct1 = -1.0d0 / (dble(elec_num) - 1.d0)
tmp_ct2 = -0.5d0 / ((dble(elec_num) - 1.d0) * (dble(elec_num) - 1.d0))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, dx, dy, dz, r2, &
!$OMP tmp0, tmp0_x, tmp0_y, tmp0_z) &
!$OMP SHARED (ao_num, n_points_final_grid, &
!$OMP tmp_ct1, tmp_ct2, ao_overlap, &
!$OMP j1e_gradx, j1e_grady, j1e_gradz, &
!$OMP int2_grad1_u2e_ao, int2_grad1_u12_square_ao)
!$OMP DO
do ipoint = 1, n_points_final_grid
dx = j1e_gradx(ipoint)
dy = j1e_grady(ipoint)
dz = j1e_gradz(ipoint)
r2 = dx*dx + dy*dy + dz*dz
tmp0 = tmp_ct2 * r2
tmp0_x = tmp_ct1 * dx
tmp0_y = tmp_ct1 * dy
tmp0_z = tmp_ct1 * dz
do j = 1, ao_num
do i = 1, ao_num
int2_grad1_u12_square_ao(i,j,ipoint) = int2_grad1_u12_square_ao(i,j,ipoint) &
+ tmp0 * ao_overlap(i,j) &
+ tmp0_x * int2_grad1_u2e_ao(i,j,ipoint,1) &
+ tmp0_y * int2_grad1_u2e_ao(i,j,ipoint,2) &
+ tmp0_z * int2_grad1_u2e_ao(i,j,ipoint,3)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
endif ! j1e_type
! ---
else
write(*, '(A, A, A)') ' Error: The integration type ', trim(tc_integ_type), ' has not been implemented yet'
stop
endif ! tc_integ_type
call wall_time(time1)
print*, ' wall time for int2_grad1_u12_square_ao (min) = ', (time1-time0) / 60.d0
call print_memory_usage()
END_PROVIDER
! ---

248
plugins/local/non_h_ints_mu/tc_integ_an.irp.f
View File

@ -1,248 +0,0 @@
BEGIN_PROVIDER [double precision, int2_grad1_u12_ao, (ao_num, ao_num, n_points_final_grid, 3)]
BEGIN_DOC
!
! TODO
! combine with int2_grad1_u12_square_ao to avoid repeated calculation ?
!
! 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 (j1b_type .eq. 1)
!
! 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 (j1b_type .eq. 3)
!
! 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, m, jpoint
double precision :: time0, time1
double precision :: x, y, z, w, tmp_x, tmp_y, tmp_z, tmp0, tmp1, tmp2
print*, ' providing int2_grad1_u12_ao ...'
call wall_time(time0)
PROVIDE j1b_type
if(read_tc_integ) then
open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/int2_grad1_u12_ao', action="read")
read(11) int2_grad1_u12_ao
else
if(j1b_type .eq. 0) then
PROVIDE v_ij_erf_rk_cst_mu x_v_ij_erf_rk_cst_mu
int2_grad1_u12_ao = 0.d0
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, x, y, z, tmp1) &
!$OMP SHARED ( ao_num, n_points_final_grid, final_grid_points &
!$OMP , v_ij_erf_rk_cst_mu, x_v_ij_erf_rk_cst_mu, int2_grad1_u12_ao)
!$OMP DO SCHEDULE (static)
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) = 0.5d0 * (tmp1 * x - x_v_ij_erf_rk_cst_mu(i,j,ipoint,1))
int2_grad1_u12_ao(i,j,ipoint,2) = 0.5d0 * (tmp1 * y - x_v_ij_erf_rk_cst_mu(i,j,ipoint,2))
int2_grad1_u12_ao(i,j,ipoint,3) = 0.5d0 * (tmp1 * z - x_v_ij_erf_rk_cst_mu(i,j,ipoint,3))
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
elseif((j1b_type .eq. 3) .or. (j1b_type .eq. 4)) then
PROVIDE v_1b_grad
PROVIDE v_ij_erf_rk_cst_mu_j1b v_ij_u_cst_mu_j1b_an x_v_ij_erf_rk_cst_mu_j1b
int2_grad1_u12_ao = 0.d0
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, x, y, z, tmp0, tmp1, tmp2, tmp_x, tmp_y, tmp_z) &
!$OMP SHARED ( ao_num, n_points_final_grid, final_grid_points, v_1b, v_1b_grad &
!$OMP , v_ij_erf_rk_cst_mu_j1b, v_ij_u_cst_mu_j1b_an, x_v_ij_erf_rk_cst_mu_j1b, int2_grad1_u12_ao)
!$OMP DO SCHEDULE (static)
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_an(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
!$OMP END DO
!$OMP END PARALLEL
FREE v_ij_erf_rk_cst_mu_j1b v_ij_u_cst_mu_j1b_an x_v_ij_erf_rk_cst_mu_j1b
elseif(j1b_type .ge. 100) then
! PROVIDE int2_grad1_u12_ao_num
! int2_grad1_u12_ao = int2_grad1_u12_ao_num
PROVIDE int2_grad1_u12_ao_num_1shot
int2_grad1_u12_ao = int2_grad1_u12_ao_num_1shot
else
print *, ' j1b_type = ', j1b_type, 'not implemented yet'
stop
endif
endif
if(write_tc_integ.and.mpi_master) then
open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/int2_grad1_u12_ao', action="write")
call ezfio_set_work_empty(.False.)
write(11) int2_grad1_u12_ao
close(11)
call ezfio_set_tc_keywords_io_tc_integ('Read')
endif
call wall_time(time1)
print*, ' wall time for int2_grad1_u12_ao =', time1-time0
call print_memory_usage()
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, int2_grad1_u12_square_ao, (ao_num, ao_num, n_points_final_grid)]
BEGIN_DOC
!
! int2_grad1_u12_square_ao = -(1/2) x int dr2 chi_l(r2) chi_j(r2) [grad_1 u(r1,r2)]^2
!
END_DOC
implicit none
integer :: ipoint, i, j, m, jpoint
double precision :: time0, time1
double precision :: x, y, z, w, tmp_x, tmp_y, tmp_z, tmp0, tmp1, tmp2
print*, ' providing int2_grad1_u12_square_ao ...'
call wall_time(time0)
PROVIDE j1b_type
if(j1b_type .eq. 0) then
PROVIDE int2_grad1u2_grad2u2
int2_grad1_u12_square_ao = 0.d0
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, ipoint) &
!$OMP SHARED (int2_grad1_u12_square_ao, ao_num, n_points_final_grid, int2_grad1u2_grad2u2)
!$OMP DO SCHEDULE (static)
do ipoint = 1, n_points_final_grid
do j = 1, ao_num
do i = 1, ao_num
int2_grad1_u12_square_ao(i,j,ipoint) = int2_grad1u2_grad2u2(i,j,ipoint)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
elseif((j1b_type .eq. 3) .or. (j1b_type .eq. 4)) then
if(use_ipp) then
! the term u12_grad1_u12_j1b_grad1_j1b is added directly for performance
PROVIDE u12sq_j1bsq grad12_j12
int2_grad1_u12_square_ao = 0.d0
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, ipoint) &
!$OMP SHARED (int2_grad1_u12_square_ao, ao_num, n_points_final_grid, u12sq_j1bsq, grad12_j12)
!$OMP DO SCHEDULE (static)
do ipoint = 1, n_points_final_grid
do j = 1, ao_num
do i = 1, ao_num
int2_grad1_u12_square_ao(i,j,ipoint) = u12sq_j1bsq(i,j,ipoint) + 0.5d0 * grad12_j12(i,j,ipoint)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
FREE u12sq_j1bsq grad12_j12
else
PROVIDE u12sq_j1bsq u12_grad1_u12_j1b_grad1_j1b grad12_j12
int2_grad1_u12_square_ao = 0.d0
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, ipoint) &
!$OMP SHARED (int2_grad1_u12_square_ao, ao_num, n_points_final_grid, u12sq_j1bsq, grad12_j12, u12_grad1_u12_j1b_grad1_j1b)
!$OMP DO SCHEDULE (static)
do ipoint = 1, n_points_final_grid
do j = 1, ao_num
do i = 1, ao_num
int2_grad1_u12_square_ao(i,j,ipoint) = u12sq_j1bsq(i,j,ipoint) + u12_grad1_u12_j1b_grad1_j1b(i,j,ipoint) + 0.5d0 * grad12_j12(i,j,ipoint)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
FREE u12sq_j1bsq u12_grad1_u12_j1b_grad1_j1b grad12_j12
endif
elseif(j1b_type .ge. 100) then
! PROVIDE int2_grad1_u12_square_ao_num
! int2_grad1_u12_square_ao = int2_grad1_u12_square_ao_num
PROVIDE int2_grad1_u12_square_ao_num_1shot
int2_grad1_u12_square_ao = int2_grad1_u12_square_ao_num_1shot
else
print *, ' j1b_type = ', j1b_type, 'not implemented yet'
stop
endif
call wall_time(time1)
print*, ' wall time for int2_grad1_u12_square_ao =', time1-time0
call print_memory_usage()
END_PROVIDER
! ---

26
plugins/local/non_h_ints_mu/tc_integ_num.irp.f
View File

@ -1,10 +1,12 @@
! ---
BEGIN_PROVIDER [double precision, int2_grad1_u12_ao_num , (ao_num,ao_num,n_points_final_grid,3)] BEGIN_PROVIDER [double precision, int2_grad1_u12_ao_num , (ao_num,ao_num,n_points_final_grid,3)]
&BEGIN_PROVIDER [double precision, int2_grad1_u12_square_ao_num, (ao_num,ao_num,n_points_final_grid) ] &BEGIN_PROVIDER [double precision, int2_grad1_u12_square_ao_num, (ao_num,ao_num,n_points_final_grid) ]
BEGIN_DOC BEGIN_DOC
! !
! int2_grad1_u12_ao_num(i,j,ipoint,:) = \int dr2 [-1 * \grad_r1 J(r1,r2)] \phi_i(r2) \phi_j(r2) ! int2_grad1_u12_ao_num(i,j,ipoint,:) = \int dr2 [\grad_r1 J(r1,r2)] \phi_i(r2) \phi_j(r2)
! !
! int2_grad1_u12_square_ao_num = -(1/2) x int dr2 chi_l(r2) chi_j(r2) [grad_1 u(r1,r2)]^2 ! int2_grad1_u12_square_ao_num = -(1/2) x int dr2 chi_l(r2) chi_j(r2) [grad_1 u(r1,r2)]^2
! !
@ -71,10 +73,10 @@
!$OMP DO !$OMP DO
do i_blocks = 1, n_blocks do i_blocks = 1, n_blocks
ipoint = ii - 1 + i_blocks ! r1 ipoint = ii - 1 + i_blocks ! r1
call get_grad1_u12_withsq_r1_seq(final_grid_points(1,ipoint), n_points_extra_final_grid, tmp_grad1_u12(1,i_blocks,1) & call get_grad1_u12_withsq_r1_seq(ipoint, n_points_extra_final_grid, tmp_grad1_u12(1,i_blocks,1) &
, tmp_grad1_u12(1,i_blocks,2) & , tmp_grad1_u12(1,i_blocks,2) &
, tmp_grad1_u12(1,i_blocks,3) & , tmp_grad1_u12(1,i_blocks,3) &
, tmp_grad1_u12_squared(1,i_blocks)) , tmp_grad1_u12_squared(1,i_blocks))
enddo enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
@ -107,10 +109,10 @@
!$OMP DO !$OMP DO
do i_rest = 1, n_rest do i_rest = 1, n_rest
ipoint = ii - 1 + i_rest ! r1 ipoint = ii - 1 + i_rest ! r1
call get_grad1_u12_withsq_r1_seq(final_grid_points(1,ipoint), n_points_extra_final_grid, tmp_grad1_u12(1,i_rest,1) & call get_grad1_u12_withsq_r1_seq(ipoint, n_points_extra_final_grid, tmp_grad1_u12(1,i_rest,1) &
, tmp_grad1_u12(1,i_rest,2) & , tmp_grad1_u12(1,i_rest,2) &
, tmp_grad1_u12(1,i_rest,3) & , tmp_grad1_u12(1,i_rest,3) &
, tmp_grad1_u12_squared(1,i_rest)) , tmp_grad1_u12_squared(1,i_rest))
enddo enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
@ -142,7 +144,7 @@ END_PROVIDER
BEGIN_DOC BEGIN_DOC
! !
! int2_grad1_u12_ao_num_1shot(i,j,ipoint,:) = \int dr2 [-1 * \grad_r1 J(r1,r2)] \phi_i(r2) \phi_j(r2) ! int2_grad1_u12_ao_num_1shot(i,j,ipoint,:) = \int dr2 [\grad_r1 J(r1,r2)] \phi_i(r2) \phi_j(r2)
! !
! int2_grad1_u12_square_ao_num_1shot = -(1/2) x int dr2 chi_l(r2) chi_j(r2) [grad_1 u(r1,r2)]^2 ! int2_grad1_u12_square_ao_num_1shot = -(1/2) x int dr2 chi_l(r2) chi_j(r2) [grad_1 u(r1,r2)]^2
! !
@ -176,9 +178,7 @@ END_PROVIDER
!$OMP END PARALLEL !$OMP END PARALLEL
do m = 1, 3 do m = 1, 3
!call dgemm( "T", "N", ao_num*ao_num, n_points_final_grid, n_points_extra_final_grid, -1.d0 & call dgemm( "T", "N", ao_num*ao_num, n_points_final_grid, n_points_extra_final_grid, 1.d0 &
! this work also because of the symmetry in K(1,2) and sign compensation in L(1,2,3)
call dgemm( "T", "N", ao_num*ao_num, n_points_final_grid, n_points_extra_final_grid, +1.d0 &
, tmp(1,1,1), n_points_extra_final_grid, grad1_u12_num(1,1,m), n_points_extra_final_grid & , tmp(1,1,1), n_points_extra_final_grid, grad1_u12_num(1,1,m), n_points_extra_final_grid &
, 0.d0, int2_grad1_u12_ao_num_1shot(1,1,1,m), ao_num*ao_num) , 0.d0, int2_grad1_u12_ao_num_1shot(1,1,1,m), ao_num*ao_num)
enddo enddo

689
plugins/local/non_h_ints_mu/test_non_h_ints.irp.f
View File

@ -11,7 +11,7 @@ program test_non_h
my_n_pt_a_grid = tc_grid1_a my_n_pt_a_grid = tc_grid1_a
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
if(j1b_type .ge. 100) then if(tc_integ_type .eq. "numeric") then
my_extra_grid_becke = .True. my_extra_grid_becke = .True.
PROVIDE tc_grid2_a tc_grid2_r PROVIDE tc_grid2_a tc_grid2_r
my_n_pt_r_extra_grid = tc_grid2_r my_n_pt_r_extra_grid = tc_grid2_r
@ -19,111 +19,51 @@ program test_non_h
touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid
endif endif
PROVIDE j2e_type
PROVIDE j1e_type
PROVIDE env_type
print *, ' j2e_type = ', j2e_type
print *, ' j1e_type = ', j1e_type
print *, ' env_type = ', env_type
!call routine_grad_squared()
!call routine_fit() !call routine_fit()
!call test_ipp() !call test_ipp()
!call test_v_ij_u_cst_mu_j1b_an() !call test_v_ij_u_cst_mu_env_an()
call test_int2_grad1_u12_square_ao() !call test_int2_grad1_u12_square_ao()
call test_int2_grad1_u12_ao() !call test_int2_grad1_u12_ao()
!call test_j1e_grad()
!call test_j1e_fit_ao()
call test_tc_grad_and_lapl_ao_new()
call test_tc_grad_square_ao_new()
end 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 subroutine routine_fit
implicit none
integer :: i,nx implicit none
double precision :: dx,xmax,x,j_mu,j_mu_F_x_j,j_mu_fit_gauss integer :: i,nx
nx = 500 double precision :: dx,xmax,x,j_mu,j_mu_F_x_j,j_mu_fit_gauss
xmax = 5.d0
dx = xmax/dble(nx) nx = 500
x = 0.d0 xmax = 5.d0
print*,'coucou',mu_erf dx = xmax/dble(nx)
do i = 1, nx x = 0.d0
write(33,'(100(F16.10,X))') x,j_mu(x),j_mu_F_x_j(x),j_mu_fit_gauss(x) print*,'coucou',mu_erf
x += dx do i = 1, nx
enddo 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 end
! ---
subroutine test_ipp() subroutine test_ipp()
@ -145,7 +85,7 @@ subroutine test_ipp()
allocate(I1(ao_num,ao_num,ao_num,ao_num)) allocate(I1(ao_num,ao_num,ao_num,ao_num))
I1 = 0.d0 I1 = 0.d0
PROVIDE u12_grad1_u12_j1b_grad1_j1b PROVIDE u12_grad1_u12_env_grad1_env
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
@ -163,7 +103,7 @@ subroutine test_ipp()
!$OMP END PARALLEL !$OMP END PARALLEL
call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 & call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
, u12_grad1_u12_j1b_grad1_j1b(1,1,1), ao_num*ao_num, b_mat(1,1,1), n_points_final_grid & , u12_grad1_u12_env_grad1_env(1,1,1), ao_num*ao_num, b_mat(1,1,1), n_points_final_grid &
, 0.d0, I1, ao_num*ao_num) , 0.d0, I1, ao_num*ao_num)
! --- ! ---
@ -173,14 +113,14 @@ subroutine test_ipp()
allocate(I2(ao_num,ao_num,ao_num,ao_num)) allocate(I2(ao_num,ao_num,ao_num,ao_num))
I2 = 0.d0 I2 = 0.d0
PROVIDE int2_u2_j1b2 PROVIDE int2_u2_env2
b_mat = 0.d0 b_mat = 0.d0
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, k, ipoint, weight1, ao_i_r, ao_k_r) & !$OMP PRIVATE (i, k, ipoint, weight1, ao_i_r, ao_k_r) &
!$OMP SHARED (aos_in_r_array_transp, b_mat, ao_num, n_points_final_grid, final_weight_at_r_vector, & !$OMP SHARED (aos_in_r_array_transp, b_mat, ao_num, n_points_final_grid, final_weight_at_r_vector, &
!$OMP v_1b_square_grad, v_1b_square_lapl, aos_grad_in_r_array_transp_bis) !$OMP env_square_grad, env_square_lapl, aos_grad_in_r_array_transp_bis)
!$OMP DO SCHEDULE (static) !$OMP DO SCHEDULE (static)
do i = 1, ao_num do i = 1, ao_num
do k = 1, ao_num do k = 1, ao_num
@ -191,10 +131,10 @@ subroutine test_ipp()
ao_i_r = aos_in_r_array_transp(ipoint,i) ao_i_r = aos_in_r_array_transp(ipoint,i)
ao_k_r = aos_in_r_array_transp(ipoint,k) ao_k_r = aos_in_r_array_transp(ipoint,k)
b_mat(ipoint,k,i) = weight1 * ( ao_k_r * ao_i_r * v_1b_square_lapl(ipoint) & b_mat(ipoint,k,i) = weight1 * ( ao_k_r * ao_i_r * env_square_lapl(ipoint) &
+ (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)) * v_1b_square_grad(ipoint,1) & + (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)) * env_square_grad(ipoint,1) &
+ (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)) * v_1b_square_grad(ipoint,2) & + (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)) * env_square_grad(ipoint,2) &
+ (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)) * v_1b_square_grad(ipoint,3) ) + (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)) * env_square_grad(ipoint,3) )
enddo enddo
enddo enddo
enddo enddo
@ -202,7 +142,7 @@ subroutine test_ipp()
!$OMP END PARALLEL !$OMP END PARALLEL
call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 & call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
, int2_u2_j1b2(1,1,1), ao_num*ao_num, b_mat(1,1,1), n_points_final_grid & , int2_u2_env2(1,1,1), ao_num*ao_num, b_mat(1,1,1), n_points_final_grid &
, 0.d0, I2, ao_num*ao_num) , 0.d0, I2, ao_num*ao_num)
! --- ! ---
@ -268,7 +208,7 @@ subroutine I_grade_gradu_naive1(i, j, k, l, int)
double precision :: weight2_x, weight2_y, weight2_z double precision :: weight2_x, weight2_y, weight2_z
double precision :: aor_i, aor_j, aor_k, aor_l double precision :: aor_i, aor_j, aor_k, aor_l
double precision :: e1_val, e2_val, e1_der(3), u12_val, u12_der(3) double precision :: e1_val, e2_val, e1_der(3), u12_val, u12_der(3)
double precision, external :: j1b_nucl, j12_mu double precision, external :: env_nucl, j12_mu
int = 0.d0 int = 0.d0
@ -281,8 +221,8 @@ subroutine I_grade_gradu_naive1(i, j, k, l, int)
aor_i = aos_in_r_array_transp(ipoint,i) aor_i = aos_in_r_array_transp(ipoint,i)
aor_k = aos_in_r_array_transp(ipoint,k) aor_k = aos_in_r_array_transp(ipoint,k)
e1_val = j1b_nucl(r1) e1_val = env_nucl(r1)
call grad1_j1b_nucl(r1, e1_der) call grad1_env_nucl(r1, e1_der)
weight1_x = aor_i * aor_k * e1_val * final_weight_at_r_vector(ipoint) * e1_der(1) weight1_x = aor_i * aor_k * e1_val * final_weight_at_r_vector(ipoint) * e1_der(1)
weight1_y = aor_i * aor_k * e1_val * final_weight_at_r_vector(ipoint) * e1_der(2) weight1_y = aor_i * aor_k * e1_val * final_weight_at_r_vector(ipoint) * e1_der(2)
@ -297,7 +237,7 @@ subroutine I_grade_gradu_naive1(i, j, k, l, int)
aor_j = aos_in_r_array_extra_transp(jpoint,j) aor_j = aos_in_r_array_extra_transp(jpoint,j)
aor_l = aos_in_r_array_extra_transp(jpoint,l) aor_l = aos_in_r_array_extra_transp(jpoint,l)
e2_val = j1b_nucl(r2) e2_val = env_nucl(r2)
u12_val = j12_mu(r1, r2) u12_val = j12_mu(r1, r2)
call grad1_j12_mu(r1, r2, u12_der) call grad1_j12_mu(r1, r2, u12_der)
@ -326,7 +266,7 @@ subroutine I_grade_gradu_naive2(i, j, k, l, int)
double precision :: weight2_x, weight2_y, weight2_z double precision :: weight2_x, weight2_y, weight2_z
double precision :: aor_i, aor_j, aor_k, aor_l double precision :: aor_i, aor_j, aor_k, aor_l
double precision :: e1_square_der(3), e2_val, u12_square_der(3) double precision :: e1_square_der(3), e2_val, u12_square_der(3)
double precision, external :: j1b_nucl double precision, external :: env_nucl
int = 0.d0 int = 0.d0
@ -339,7 +279,7 @@ subroutine I_grade_gradu_naive2(i, j, k, l, int)
aor_i = aos_in_r_array_transp(ipoint,i) aor_i = aos_in_r_array_transp(ipoint,i)
aor_k = aos_in_r_array_transp(ipoint,k) aor_k = aos_in_r_array_transp(ipoint,k)
call grad1_j1b_nucl_square_num(r1, e1_square_der) call grad1_env_nucl_square_num(r1, e1_square_der)
weight1_x = aor_i * aor_k * final_weight_at_r_vector(ipoint) * e1_square_der(1) weight1_x = aor_i * aor_k * final_weight_at_r_vector(ipoint) * e1_square_der(1)
weight1_y = aor_i * aor_k * final_weight_at_r_vector(ipoint) * e1_square_der(2) weight1_y = aor_i * aor_k * final_weight_at_r_vector(ipoint) * e1_square_der(2)
@ -354,7 +294,7 @@ subroutine I_grade_gradu_naive2(i, j, k, l, int)
aor_j = aos_in_r_array_extra_transp(jpoint,j) aor_j = aos_in_r_array_extra_transp(jpoint,j)
aor_l = aos_in_r_array_extra_transp(jpoint,l) aor_l = aos_in_r_array_extra_transp(jpoint,l)
e2_val = j1b_nucl(r2) e2_val = env_nucl(r2)
call grad1_j12_mu_square_num(r1, r2, u12_square_der) call grad1_j12_mu_square_num(r1, r2, u12_square_der)
weight2_x = aor_j * aor_l * e2_val * e2_val * final_weight_at_r_vector_extra(jpoint) * u12_square_der(1) weight2_x = aor_j * aor_l * e2_val * e2_val * final_weight_at_r_vector_extra(jpoint) * u12_square_der(1)
@ -380,7 +320,7 @@ subroutine I_grade_gradu_naive3(i, j, k, l, int)
double precision :: weight1, weight2 double precision :: weight1, weight2
double precision :: aor_j, aor_l double precision :: aor_j, aor_l
double precision :: grad(3), e2_val, u12_val double precision :: grad(3), e2_val, u12_val
double precision, external :: j1b_nucl, j12_mu double precision, external :: env_nucl, j12_mu
int = 0.d0 int = 0.d0
@ -403,7 +343,7 @@ subroutine I_grade_gradu_naive3(i, j, k, l, int)
aor_j = aos_in_r_array_extra_transp(jpoint,j) aor_j = aos_in_r_array_extra_transp(jpoint,j)
aor_l = aos_in_r_array_extra_transp(jpoint,l) aor_l = aos_in_r_array_extra_transp(jpoint,l)
e2_val = j1b_nucl(r2) e2_val = env_nucl(r2)
u12_val = j12_mu(r1, r2) u12_val = j12_mu(r1, r2)
weight2 = aor_j * aor_l * e2_val * e2_val * u12_val * u12_val * final_weight_at_r_vector_extra(jpoint) weight2 = aor_j * aor_l * e2_val * e2_val * u12_val * u12_val * final_weight_at_r_vector_extra(jpoint)
@ -427,7 +367,7 @@ subroutine I_grade_gradu_naive4(i, j, k, l, int)
double precision :: weight1, weight2 double precision :: weight1, weight2
double precision :: aor_j, aor_l, aor_k, aor_i double precision :: aor_j, aor_l, aor_k, aor_i
double precision :: grad(3), e2_val, u12_val double precision :: grad(3), e2_val, u12_val
double precision, external :: j1b_nucl, j12_mu double precision, external :: env_nucl, j12_mu
int = 0.d0 int = 0.d0
@ -440,10 +380,10 @@ subroutine I_grade_gradu_naive4(i, j, k, l, int)
aor_i = aos_in_r_array_transp(ipoint,i) aor_i = aos_in_r_array_transp(ipoint,i)
aor_k = aos_in_r_array_transp(ipoint,k) aor_k = aos_in_r_array_transp(ipoint,k)
weight1 = final_weight_at_r_vector(ipoint) * ( aor_k * aor_i * v_1b_square_lapl(ipoint) & weight1 = final_weight_at_r_vector(ipoint) * ( aor_k * aor_i * env_square_lapl(ipoint) &
+ (aor_k * aos_grad_in_r_array_transp_bis(ipoint,i,1) + aor_i * aos_grad_in_r_array_transp_bis(ipoint,k,1)) * v_1b_square_grad(ipoint,1) & + (aor_k * aos_grad_in_r_array_transp_bis(ipoint,i,1) + aor_i * aos_grad_in_r_array_transp_bis(ipoint,k,1)) * env_square_grad(ipoint,1) &
+ (aor_k * aos_grad_in_r_array_transp_bis(ipoint,i,2) + aor_i * aos_grad_in_r_array_transp_bis(ipoint,k,2)) * v_1b_square_grad(ipoint,2) & + (aor_k * aos_grad_in_r_array_transp_bis(ipoint,i,2) + aor_i * aos_grad_in_r_array_transp_bis(ipoint,k,2)) * env_square_grad(ipoint,2) &
+ (aor_k * aos_grad_in_r_array_transp_bis(ipoint,i,3) + aor_i * aos_grad_in_r_array_transp_bis(ipoint,k,3)) * v_1b_square_grad(ipoint,3) ) + (aor_k * aos_grad_in_r_array_transp_bis(ipoint,i,3) + aor_i * aos_grad_in_r_array_transp_bis(ipoint,k,3)) * env_square_grad(ipoint,3) )
do jpoint = 1, n_points_extra_final_grid ! r2 do jpoint = 1, n_points_extra_final_grid ! r2
@ -454,7 +394,7 @@ subroutine I_grade_gradu_naive4(i, j, k, l, int)
aor_j = aos_in_r_array_extra_transp(jpoint,j) aor_j = aos_in_r_array_extra_transp(jpoint,j)
aor_l = aos_in_r_array_extra_transp(jpoint,l) aor_l = aos_in_r_array_extra_transp(jpoint,l)
e2_val = j1b_nucl(r2) e2_val = env_nucl(r2)
u12_val = j12_mu(r1, r2) u12_val = j12_mu(r1, r2)
weight2 = aor_j * aor_l * e2_val * e2_val * u12_val * u12_val * final_weight_at_r_vector_extra(jpoint) weight2 = aor_j * aor_l * e2_val * e2_val * u12_val * u12_val * final_weight_at_r_vector_extra(jpoint)
@ -464,7 +404,7 @@ subroutine I_grade_gradu_naive4(i, j, k, l, int)
enddo enddo
return return
end subroutine I_grade_gradu_naive4 end
! --- ! ---
@ -485,16 +425,16 @@ subroutine I_grade_gradu_seminaive(i, j, k, l, int)
aor_i = aos_in_r_array_transp(ipoint,i) aor_i = aos_in_r_array_transp(ipoint,i)
aor_k = aos_in_r_array_transp(ipoint,k) aor_k = aos_in_r_array_transp(ipoint,k)
weight1 = 0.25d0 * final_weight_at_r_vector(ipoint) * ( aor_k * aor_i * v_1b_square_lapl(ipoint) & weight1 = 0.25d0 * final_weight_at_r_vector(ipoint) * ( aor_k * aor_i * env_square_lapl(ipoint) &
+ (aor_k * aos_grad_in_r_array_transp_bis(ipoint,i,1) + aor_i * aos_grad_in_r_array_transp_bis(ipoint,k,1)) * v_1b_square_grad(ipoint,1) & + (aor_k * aos_grad_in_r_array_transp_bis(ipoint,i,1) + aor_i * aos_grad_in_r_array_transp_bis(ipoint,k,1)) * env_square_grad(ipoint,1) &
+ (aor_k * aos_grad_in_r_array_transp_bis(ipoint,i,2) + aor_i * aos_grad_in_r_array_transp_bis(ipoint,k,2)) * v_1b_square_grad(ipoint,2) & + (aor_k * aos_grad_in_r_array_transp_bis(ipoint,i,2) + aor_i * aos_grad_in_r_array_transp_bis(ipoint,k,2)) * env_square_grad(ipoint,2) &
+ (aor_k * aos_grad_in_r_array_transp_bis(ipoint,i,3) + aor_i * aos_grad_in_r_array_transp_bis(ipoint,k,3)) * v_1b_square_grad(ipoint,3) ) + (aor_k * aos_grad_in_r_array_transp_bis(ipoint,i,3) + aor_i * aos_grad_in_r_array_transp_bis(ipoint,k,3)) * env_square_grad(ipoint,3) )
int = int + weight1 * int2_u2_j1b2(j,l,ipoint) int = int + weight1 * int2_u2_env2(j,l,ipoint)
enddo enddo
return return
end subroutine I_grade_gradu_seminaive end
! --- ! ---
@ -508,7 +448,7 @@ subroutine aos_ik_grad1_esquare(i, k, r1, val)
double precision :: der(3), aos_array(ao_num), aos_grad_array(3,ao_num) double precision :: der(3), aos_array(ao_num), aos_grad_array(3,ao_num)
call give_all_aos_and_grad_at_r(r1, aos_array, aos_grad_array) call give_all_aos_and_grad_at_r(r1, aos_array, aos_grad_array)
call grad1_j1b_nucl_square_num(r1, der) call grad1_env_nucl_square_num(r1, der)
tmp = aos_array(i) * aos_array(k) tmp = aos_array(i) * aos_array(k)
val(1) = tmp * der(1) val(1) = tmp * der(1)
@ -559,14 +499,14 @@ end subroutine grad1_aos_ik_grad1_esquare
! --- ! ---
subroutine test_v_ij_u_cst_mu_j1b_an() subroutine test_v_ij_u_cst_mu_env_an()
implicit none implicit none
integer :: i, j, ipoint integer :: i, j, ipoint
double precision :: I_old, I_new double precision :: I_old, I_new
double precision :: norm, accu, thr, diff double precision :: norm, accu, thr, diff
PROVIDE v_ij_u_cst_mu_j1b_an_old v_ij_u_cst_mu_j1b_an PROVIDE v_ij_u_cst_mu_env_an_old v_ij_u_cst_mu_env_an
thr = 1d-12 thr = 1d-12
norm = 0.d0 norm = 0.d0
@ -575,8 +515,8 @@ subroutine test_v_ij_u_cst_mu_j1b_an()
do i = 1, ao_num do i = 1, ao_num
do j = 1, ao_num do j = 1, ao_num
I_old = v_ij_u_cst_mu_j1b_an_old(j,i,ipoint) I_old = v_ij_u_cst_mu_env_an_old(j,i,ipoint)
I_new = v_ij_u_cst_mu_j1b_an (j,i,ipoint) I_new = v_ij_u_cst_mu_env_an (j,i,ipoint)
diff = dabs(I_new-I_old) diff = dabs(I_new-I_old)
if(diff .gt. thr) then if(diff .gt. thr) then
@ -595,7 +535,7 @@ subroutine test_v_ij_u_cst_mu_j1b_an()
print*, ' accuracy(%) = ', 100.d0 * accu / norm print*, ' accuracy(%) = ', 100.d0 * accu / norm
return return
end subroutine test_v_ij_u_cst_mu_j1b_an end
! --- ! ---
@ -637,7 +577,7 @@ subroutine test_int2_grad1_u12_square_ao()
print*, ' accuracy(%) = ', 100.d0 * accu / norm print*, ' accuracy(%) = ', 100.d0 * accu / norm
return return
end subroutine test_int2_grad1_u12_square_ao end
! --- ! ---
@ -681,7 +621,494 @@ subroutine test_int2_grad1_u12_ao()
print*, ' accuracy(%) = ', 100.d0 * accu / norm print*, ' accuracy(%) = ', 100.d0 * accu / norm
return return
end subroutine test_int2_grad1_u12_ao end
! ---
subroutine test_j1e_grad()
implicit none
integer :: i, j, ipoint
double precision :: g
double precision :: x_loops, x_dgemm, diff, thr, accu, norm
double precision, allocatable :: pa(:,:), Pb(:,:), Pt(:,:)
double precision, allocatable :: x(:), y(:), z(:)
PROVIDE int2_grad1_u2e_ao
PROVIDE mo_coef
allocate(Pa(ao_num,ao_num), Pb(ao_num,ao_num), Pt(ao_num,ao_num))
call dgemm( 'N', 'T', ao_num, ao_num, elec_alpha_num, 1.d0 &
, mo_coef, size(mo_coef, 1), mo_coef, size(mo_coef, 1) &
, 0.d0, Pa, size(Pa, 1))
if(elec_alpha_num .eq. elec_beta_num) then
Pb = Pa
else
call dgemm( 'N', 'T', ao_num, ao_num, elec_beta_num, 1.d0 &
, mo_coef, size(mo_coef, 1), mo_coef, size(mo_coef, 1) &
, 0.d0, Pb, size(Pb, 1))
endif
Pt = Pa + Pa
g = 0.5d0 * (dble(elec_num) - 1.d0) / dble(elec_num)
allocate(x(n_points_final_grid), y(n_points_final_grid), z(n_points_final_grid))
do ipoint = 1, n_points_final_grid
x(ipoint) = 0.d0
y(ipoint) = 0.d0
z(ipoint) = 0.d0
do i = 1, ao_num
do j = 1, ao_num
x(ipoint) = x(ipoint) + g * Pt(i,j) * int2_grad1_u2e_ao(i,j,ipoint,1)
y(ipoint) = y(ipoint) + g * Pt(i,j) * int2_grad1_u2e_ao(i,j,ipoint,2)
z(ipoint) = z(ipoint) + g * Pt(i,j) * int2_grad1_u2e_ao(i,j,ipoint,3)
enddo
enddo
enddo
deallocate(Pa, Pb, Pt)
! ---
thr = 1d-10
norm = 0.d0
accu = 0.d0
do ipoint = 1, n_points_final_grid
x_loops = x (ipoint)
x_dgemm = j1e_gradx(ipoint)
diff = dabs(x_loops - x_dgemm)
if(diff .gt. thr) then
print *, ' problem in j1e_gradx on:', ipoint
print *, ' loops :', x_loops
print *, ' dgemm :', x_dgemm
stop
endif
accu += diff
norm += dabs(x_loops)
x_loops = y (ipoint)
x_dgemm = j1e_grady(ipoint)
diff = dabs(x_loops - x_dgemm)
if(diff .gt. thr) then
print *, ' problem in j1e_grady on:', ipoint
print *, ' loops :', x_loops
print *, ' dgemm :', x_dgemm
stop
endif
accu += diff
norm += dabs(x_loops)
x_loops = z (ipoint)
x_dgemm = j1e_gradz(ipoint)
diff = dabs(x_loops - x_dgemm)
if(diff .gt. thr) then
print *, ' problem in j1e_gradz on:', ipoint
print *, ' loops :', x_loops
print *, ' dgemm :', x_dgemm
stop
endif
accu += diff
norm += dabs(x_loops)
enddo
deallocate(x, y, z)
print*, ' accuracy(%) = ', 100.d0 * accu / norm
return
end
! ---
subroutine test_j1e_fit_ao()
implicit none
integer :: i, j, ipoint
double precision :: g, c
double precision :: x_loops, x_dgemm, diff, thr, accu, norm
double precision, allocatable :: pa(:,:), Pb(:,:), Pt(:,:)
double precision, allocatable :: x(:), y(:), z(:)
double precision, allocatable :: x_fit(:), y_fit(:), z_fit(:), coef_fit(:)
PROVIDE mo_coef
PROVIDE int2_grad1_u2e_ao
! ---
allocate(Pa(ao_num,ao_num), Pb(ao_num,ao_num), Pt(ao_num,ao_num))
call dgemm( 'N', 'T', ao_num, ao_num, elec_alpha_num, 1.d0 &
, mo_coef, size(mo_coef, 1), mo_coef, size(mo_coef, 1) &
, 0.d0, Pa, size(Pa, 1))
if(elec_alpha_num .eq. elec_beta_num) then
Pb = Pa
else
call dgemm( 'N', 'T', ao_num, ao_num, elec_beta_num, 1.d0 &
, mo_coef, size(mo_coef, 1), mo_coef, size(mo_coef, 1) &
, 0.d0, Pb, size(Pb, 1))
endif
Pt = Pa + Pa
allocate(x(n_points_final_grid), y(n_points_final_grid), z(n_points_final_grid))
g = -0.5d0 * (dble(elec_num) - 1.d0) / dble(elec_num)
call dgemv("T", ao_num*ao_num, n_points_final_grid, g, int2_grad1_u2e_ao(1,1,1,1), ao_num*ao_num, Pt, 1, 0.d0, x, 1)
call dgemv("T", ao_num*ao_num, n_points_final_grid, g, int2_grad1_u2e_ao(1,1,1,2), ao_num*ao_num, Pt, 1, 0.d0, y, 1)
call dgemv("T", ao_num*ao_num, n_points_final_grid, g, int2_grad1_u2e_ao(1,1,1,3), ao_num*ao_num, Pt, 1, 0.d0, z, 1)
FREE int2_grad1_u2e_ao
deallocate(Pa, Pb, Pt)
! ---
allocate(x_fit(n_points_final_grid), y_fit(n_points_final_grid), z_fit(n_points_final_grid))
allocate(coef_fit(ao_num))
call get_j1e_coef_fit_ao(ao_num, coef_fit)
!print *, ' coef fit in AO:'
!print*, coef_fit
! !$OMP PARALLEL &
! !$OMP DEFAULT (NONE) &
! !$OMP PRIVATE (i, ipoint, c) &
! !$OMP SHARED (n_points_final_grid, ao_num, &
! !$OMP aos_grad_in_r_array, coef_fit, x_fit, y_fit, z_fit)
! !$OMP DO SCHEDULE (static)
do ipoint = 1, n_points_final_grid
x_fit(ipoint) = 0.d0
y_fit(ipoint) = 0.d0
z_fit(ipoint) = 0.d0
do i = 1, ao_num
c = coef_fit(i)
x_fit(ipoint) = x_fit(ipoint) + c * aos_grad_in_r_array(i,ipoint,1)
y_fit(ipoint) = y_fit(ipoint) + c * aos_grad_in_r_array(i,ipoint,2)
z_fit(ipoint) = z_fit(ipoint) + c * aos_grad_in_r_array(i,ipoint,3)
enddo
enddo
! !$OMP END DO
! !$OMP END PARALLEL
deallocate(coef_fit)
! ---
thr = 1d-10
norm = 0.d0
accu = 0.d0
do ipoint = 1, n_points_final_grid
x_loops = x (ipoint)
x_dgemm = x_fit(ipoint)
diff = dabs(x_loops - x_dgemm)
!if(diff .gt. thr) then
! print *, ' problem in j1e_gradx on:', ipoint
! print *, ' loops :', x_loops
! print *, ' dgemm :', x_dgemm
! stop
!endif
accu += diff
norm += dabs(x_loops)
x_loops = y (ipoint)
x_dgemm = y_fit(ipoint)
diff = dabs(x_loops - x_dgemm)
!if(diff .gt. thr) then
! print *, ' problem in j1e_grady on:', ipoint
! print *, ' loops :', x_loops
! print *, ' dgemm :', x_dgemm
! stop
!endif
accu += diff
norm += dabs(x_loops)
x_loops = z (ipoint)
x_dgemm = z_fit(ipoint)
diff = dabs(x_loops - x_dgemm)
!if(diff .gt. thr) then
! print *, ' problem in j1e_gradz on:', ipoint
! print *, ' loops :', x_loops
! print *, ' dgemm :', x_dgemm
! stop
!endif
accu += diff
norm += dabs(x_loops)
enddo
deallocate(x, y, z)
deallocate(x_fit, y_fit, z_fit)
print*, ' fit accuracy (%) = ', 100.d0 * accu / norm
end
! ---
subroutine test_tc_grad_and_lapl_ao_new()
implicit none
integer :: i, j, k, l
double precision :: i_old, i_new, diff, thr, accu, norm
double precision, allocatable :: tc_grad_and_lapl_ao_old(:,:,:,:)
PROVIDE tc_grad_and_lapl_ao_new
thr = 1d-10
norm = 0.d0
accu = 0.d0
allocate(tc_grad_and_lapl_ao_old(ao_num,ao_num,ao_num,ao_num))
open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/tc_grad_and_lapl_ao_old', action="read")
read(11) tc_grad_and_lapl_ao_old
close(11)
do i = 1, ao_num
do j = 1, ao_num
do k = 1, ao_num
do l = 1, ao_num
i_old = tc_grad_and_lapl_ao_old(l,k,j,i)
i_new = tc_grad_and_lapl_ao_new(l,k,j,i)
diff = dabs(i_old - i_new)
if(diff .gt. thr) then
print *, ' problem in tc_grad_and_lapl_ao_new on:', l, k, j, i
print *, ' old :', i_old
print *, ' new :', i_new
stop
endif
accu += diff
norm += dabs(i_old)
enddo
enddo
enddo
enddo
deallocate(tc_grad_and_lapl_ao_old)
print*, ' accuracy (%) = ', 100.d0 * accu / norm
end
! ---
subroutine test_tc_grad_square_ao_new()
implicit none
integer :: i, j, k, l
double precision :: i_old, i_new, diff, thr, accu, norm
double precision, allocatable :: tc_grad_square_ao_old(:,:,:,:)
PROVIDE tc_grad_square_ao_new
thr = 1d-10
norm = 0.d0
accu = 0.d0
allocate(tc_grad_square_ao_old(ao_num,ao_num,ao_num,ao_num))
open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/tc_grad_square_ao_old', action="read")
read(11) tc_grad_square_ao_old
close(11)
do i = 1, ao_num
do j = 1, ao_num
do k = 1, ao_num
do l = 1, ao_num
i_old = tc_grad_square_ao_old(l,k,j,i)
i_new = tc_grad_square_ao_new(l,k,j,i)
diff = dabs(i_old - i_new)
if(diff .gt. thr) then
print *, ' problem in tc_grad_and_lapl_ao_new on:', l, k, j, i
print *, ' old :', i_old
print *, ' new :', i_new
stop
endif
accu += diff
norm += dabs(i_old)
enddo
enddo
enddo
enddo
deallocate(tc_grad_square_ao_old)
print*, ' accuracy (%) = ', 100.d0 * accu / norm
end
! ---
BEGIN_PROVIDER [double precision, tc_grad_square_ao_new, (ao_num, ao_num, ao_num, ao_num)]
implicit none
integer :: i, j, k, l, m, ipoint
double precision :: weight1, ao_k_r, ao_i_r
double precision :: der_envsq_x, der_envsq_y, der_envsq_z, lap_envsq
double precision :: time0, time1
double precision, allocatable :: b_mat(:,:,:,:), c_mat(:,:,:)
double precision, external :: get_ao_two_e_integral
PROVIDe tc_integ_type
PROVIDE env_type
PROVIDE j2e_type
PROVIDE j1e_type
call wall_time(time0)
print *, ' providing tc_grad_square_ao_new ...'
PROVIDE int2_grad1_u12_square_ao
allocate(c_mat(n_points_final_grid,ao_num,ao_num))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, k, ipoint) &
!$OMP SHARED (aos_in_r_array_transp, c_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
c_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
call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
, int2_grad1_u12_square_ao(1,1,1), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid &
, 0.d0, tc_grad_square_ao_new, ao_num*ao_num)
FREE int2_grad1_u12_square_ao
if( (tc_integ_type .eq. "semi-analytic") .and. &
(j2e_type .eq. "Mu") .and. &
((env_type .eq. "Prod_Gauss") .or. (env_type .eq. "Sum_Gauss")) .and. &
use_ipp ) then
! an additional term is added here directly instead of
! being added in int2_grad1_u12_square_ao for performance
PROVIDE int2_u2_env2
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, k, ipoint, weight1, ao_i_r, ao_k_r) &
!$OMP SHARED (aos_in_r_array_transp, c_mat, ao_num, n_points_final_grid, final_weight_at_r_vector, &
!$OMP env_square_grad, env_square_lapl, aos_grad_in_r_array_transp_bis)
!$OMP DO SCHEDULE (static)
do i = 1, ao_num
do k = 1, ao_num
do ipoint = 1, n_points_final_grid
weight1 = 0.25d0 * 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)
c_mat(ipoint,k,i) = weight1 * ( ao_k_r * ao_i_r * env_square_lapl(ipoint) &
+ (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)) * env_square_grad(ipoint,1) &
+ (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)) * env_square_grad(ipoint,2) &
+ (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)) * env_square_grad(ipoint,3) )
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
, int2_u2_env2(1,1,1), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid &
, 1.d0, tc_grad_square_ao_new, ao_num*ao_num)
FREE int2_u2_env2
endif ! use_ipp
deallocate(c_mat)
call sum_A_At(tc_grad_square_ao_new(1,1,1,1), ao_num*ao_num)
call wall_time(time1)
print*, ' Wall time for tc_grad_square_ao_new (min) = ', (time1 - time0) / 60.d0
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, tc_grad_and_lapl_ao_new, (ao_num, ao_num, ao_num, ao_num)]
implicit none
integer :: i, j, k, l, m, ipoint
double precision :: weight1, ao_k_r, ao_i_r
double precision :: der_envsq_x, der_envsq_y, der_envsq_z, lap_envsq
double precision :: time0, time1
double precision, allocatable :: b_mat(:,:,:,:), c_mat(:,:,:)
double precision, external :: get_ao_two_e_integral
PROVIDe tc_integ_type
PROVIDE env_type
PROVIDE j2e_type
PROVIDE j1e_type
call wall_time(time0)
print *, ' providing tc_grad_square_ao_new ...'
PROVIDE int2_grad1_u12_ao
allocate(b_mat(n_points_final_grid,ao_num,ao_num,3))
!$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
tc_grad_and_lapl_ao_new = 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, tc_grad_and_lapl_ao_new, ao_num*ao_num)
enddo
deallocate(b_mat)
FREE int2_grad1_u12_ao
FREE int2_grad1_u2e_ao
call sum_A_At(tc_grad_and_lapl_ao_new(1,1,1,1), ao_num*ao_num)
call wall_time(time1)
print*, ' Wall time for tc_grad_and_lapl_ao_new (min) = ', (time1 - time0) / 60.d0
END_PROVIDER
! --- ! ---

351
plugins/local/non_h_ints_mu/total_tc_int.irp.f
View File

@ -1,190 +1,223 @@
! --- ! ---
BEGIN_PROVIDER [double precision, ao_vartc_int_chemist, (ao_num, ao_num, ao_num, ao_num)] BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_num)]
BEGIN_DOC
!
! CHEMIST NOTATION IS USED
!
! 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
! = tc_grad_and_lapl_ao(k,i,l,j) + tc_grad_square_ao(k,i,l,j) + ao_two_e_coul(k,i,l,j)
! AND IF(var_tc):
!
! ao_two_e_tot(k,i,l,j) = (ki|V^TC(r_12) + [(V^TC)(r_12)]^\dagger|lj) / 2.0
! = tc_grad_square_ao(k,i,l,j) + ao_two_e_coul(k,i,l,j)
!
!
! where:
!
! 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)
! = 1/2 \int dr1 (phi_k(r1) \grad_r1 phi_i(r1) - phi_i(r1) \grad_r1 phi_k(r1)) . \int dr2 (-1) \grad_r1 u(r1,r2) \phi_l(r2) \phi_j(r2)
!
! tc_grad_square_ao(k,i,l,j) = -1/2 <kl | |\grad_1 u(r1,r2)|^2 + |\grad_2 u(r1,r2)|^2 | ij>
!
! ao_two_e_coul(k,i,l,j) = < l k | 1/r12 | j i > = ( k i | 1/r12 | l j )
!
END_DOC
implicit none implicit none
integer :: i, j, k, l integer :: i, j, k, l, m, ipoint
double precision :: wall1, wall0 double precision :: weight1, ao_k_r, ao_i_r
double precision :: der_envsq_x, der_envsq_y, der_envsq_z, lap_envsq
double precision :: time0, time1
double precision, allocatable :: b_mat(:,:,:,:), c_mat(:,:,:)
double precision, external :: get_ao_two_e_integral
print *, ' providing ao_vartc_int_chemist ...' PROVIDe tc_integ_type
call wall_time(wall0) PROVIDE env_type
PROVIDE j2e_type
if(test_cycle_tc) then PROVIDE j1e_type
PROVIDE j1b_type call wall_time(time0)
if(j1b_type .ne. 3) then
print*, ' TC integrals with cycle can not be used for j1b_type =', j1b_type
stop
endif
do j = 1, ao_num print *, ' providing ao_two_e_tc_tot ...'
do l = 1, ao_num print*, ' j2e_type: ', j2e_type
do i = 1, ao_num print*, ' j1e_type: ', j1e_type
do k = 1, ao_num print*, ' env_type: ', env_type
ao_vartc_int_chemist(k,i,l,j) = tc_grad_square_ao_test(k,i,l,j) + ao_two_e_coul(k,i,l,j)
enddo if(read_tc_integ) then
enddo
enddo print*, ' Reading ao_two_e_tc_tot from ', trim(ezfio_filename) // '/work/ao_two_e_tc_tot'
enddo
open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/ao_two_e_tc_tot', action="read")
read(11) ao_two_e_tc_tot
close(11)
else else
PROVIDE tc_integ_type
print*, ' approach for integrals: ', tc_integ_type
! ---
PROVIDE int2_grad1_u12_square_ao
allocate(c_mat(n_points_final_grid,ao_num,ao_num))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, k, ipoint) &
!$OMP SHARED (aos_in_r_array_transp, c_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
c_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
call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
, int2_grad1_u12_square_ao(1,1,1), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid &
, 0.d0, ao_two_e_tc_tot, ao_num*ao_num)
FREE int2_grad1_u12_square_ao
if( (tc_integ_type .eq. "semi-analytic") .and. &
(j2e_type .eq. "Mu") .and. &
((env_type .eq. "Prod_Gauss") .or. (env_type .eq. "Sum_Gauss")) .and. &
use_ipp ) then
! an additional term is added here directly instead of
! being added in int2_grad1_u12_square_ao for performance
PROVIDE int2_u2_env2
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, k, ipoint, weight1, ao_i_r, ao_k_r) &
!$OMP SHARED (aos_in_r_array_transp, c_mat, ao_num, n_points_final_grid, final_weight_at_r_vector, &
!$OMP env_square_grad, env_square_lapl, aos_grad_in_r_array_transp_bis)
!$OMP DO SCHEDULE (static)
do i = 1, ao_num
do k = 1, ao_num
do ipoint = 1, n_points_final_grid
weight1 = 0.25d0 * 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)
c_mat(ipoint,k,i) = weight1 * ( ao_k_r * ao_i_r * env_square_lapl(ipoint) &
+ (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)) * env_square_grad(ipoint,1) &
+ (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)) * env_square_grad(ipoint,2) &
+ (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)) * env_square_grad(ipoint,3) )
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
, int2_u2_env2(1,1,1), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid &
, 1.d0, ao_two_e_tc_tot, ao_num*ao_num)
FREE int2_u2_env2
endif ! use_ipp
deallocate(c_mat)
! ---
if(.not. var_tc) then
PROVIDE int2_grad1_u12_ao
allocate(b_mat(n_points_final_grid,ao_num,ao_num,3))
!$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
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, ao_two_e_tc_tot, ao_num*ao_num)
enddo
deallocate(b_mat)
FREE int2_grad1_u12_ao
FREE int2_grad1_u2e_ao
endif ! var_tc
! ---
call sum_A_At(ao_two_e_tc_tot(1,1,1,1), ao_num*ao_num)
PROVIDE ao_integrals_map
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP SHARED(ao_num, ao_two_e_tc_tot, ao_integrals_map) &
!$OMP PRIVATE(i, j, k, l)
!$OMP DO
do j = 1, ao_num do j = 1, ao_num
do l = 1, ao_num do l = 1, ao_num
do i = 1, ao_num do i = 1, ao_num
do k = 1, ao_num do k = 1, ao_num
ao_vartc_int_chemist(k,i,l,j) = tc_grad_square_ao(k,i,l,j) + ao_two_e_coul(k,i,l,j) ! < 1:i, 2:j | 1:k, 2:l >
ao_two_e_tc_tot(k,i,l,j) = ao_two_e_tc_tot(k,i,l,j) + get_ao_two_e_integral(i, j, k, l, ao_integrals_map)
enddo enddo
enddo enddo
enddo enddo
enddo enddo
!$OMP END DO
!$OMP END PARALLEL
endif if(tc_integ_type .eq. "numeric") then
FREE int2_grad1_u12_ao_num int2_grad1_u12_square_ao_num
call wall_time(wall1)
print *, ' wall time for ao_vartc_int_chemist ', wall1 - wall0
END_PROVIDER
! ---
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
PROVIDE j1b_type
print *, ' providing ao_tc_int_chemist ...'
call wall_time(wall0)
if(test_cycle_tc) then
if(j1b_type .ne. 3) then
print*, ' TC integrals with cycle can not be used for j1b_type =', j1b_type
stop
endif endif
ao_tc_int_chemist = ao_tc_int_chemist_test endif ! read_tc_integ
else if(write_tc_integ .and. mpi_master) then
print*, ' Saving ao_two_e_tc_tot in ', trim(ezfio_filename) // '/work/ao_two_e_tc_tot'
PROVIDE tc_grad_square_ao tc_grad_and_lapl_ao ao_two_e_coul open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/ao_two_e_tc_tot', action="write")
call ezfio_set_work_empty(.False.)
do j = 1, ao_num write(11) ao_two_e_tc_tot
do l = 1, ao_num close(11)
do i = 1, ao_num call ezfio_set_tc_keywords_io_tc_integ('Read')
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)
! ao_tc_int_chemist(k,i,l,j) = ao_two_e_coul(k,i,l,j)
enddo
enddo
enddo
enddo
endif endif
FREE tc_grad_square_ao tc_grad_and_lapl_ao ao_two_e_coul call wall_time(time1)
print*, ' Wall time for ao_two_e_tc_tot (min) = ', (time1 - time0) / 60.d0
if(j1b_type .ge. 100) then
FREE int2_grad1_u12_ao_num int2_grad1_u12_square_ao_num
endif
call wall_time(wall1)
print *, ' wall time for ao_tc_int_chemist ', wall1 - wall0
call print_memory_usage() call print_memory_usage()
END_PROVIDER END_PROVIDER
! --- ! ---
BEGIN_PROVIDER [double precision, ao_tc_int_chemist_no_cycle, (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_no_cycle ...'
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_no_cycle(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)
!ao_tc_int_chemist(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_no_cycle ', 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)
! ao_tc_int_chemist_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, external :: get_ao_two_e_integral
PROVIDE ao_integrals_map
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP SHARED(ao_num, ao_two_e_coul, ao_integrals_map) &
!$OMP PRIVATE(i, j, k, l)
!$OMP DO
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 >
ao_two_e_coul(k,i,l,j) = get_ao_two_e_integral(i, j, k, l, ao_integrals_map)
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
END_PROVIDER
! ---

63
plugins/local/non_hermit_dav/biorthog.irp.f
View File

@ -142,7 +142,7 @@ subroutine non_hrmt_diag_split_degen(n, A, leigvec, reigvec, n_real_eigv, eigval
enddo enddo
enddo enddo
end subroutine non_hrmt_diag_split_degen end
! --- ! ---
@ -248,7 +248,7 @@ subroutine non_hrmt_real_diag_new(n, A, leigvec, reigvec, n_real_eigv, eigval)
print*,'Your matrix intrinsically contains complex eigenvalues' print*,'Your matrix intrinsically contains complex eigenvalues'
endif endif
end subroutine non_hrmt_real_diag_new end
! --- ! ---
@ -275,10 +275,11 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei
double precision :: thr, thr_cut, thr_diag, thr_norm double precision :: thr, thr_cut, thr_diag, thr_norm
double precision :: accu_d, accu_nd double precision :: accu_d, accu_nd
integer, allocatable :: list_good(:), iorder(:) integer, allocatable :: list_good(:), iorder(:), deg_num(:)
double precision, allocatable :: WR(:), WI(:), VL(:,:), VR(:,:) double precision, allocatable :: WR(:), WI(:), VL(:,:), VR(:,:)
double precision, allocatable :: S(:,:) double precision, allocatable :: S(:,:)
double precision, allocatable :: phi_1_tilde(:),phi_2_tilde(:),chi_1_tilde(:),chi_2_tilde(:) double precision, allocatable :: phi_1_tilde(:),phi_2_tilde(:),chi_1_tilde(:),chi_2_tilde(:)
allocate(phi_1_tilde(n),phi_2_tilde(n),chi_1_tilde(n),chi_2_tilde(n)) allocate(phi_1_tilde(n),phi_2_tilde(n),chi_1_tilde(n),chi_2_tilde(n))
@ -305,11 +306,11 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei
print *, ' ' !print *, ' '
print *, ' eigenvalues' !print *, ' eigenvalues'
i = 1 i = 1
do while(i .le. n) do while(i .le. n)
write(*, '(I3,X,1000(F16.10,X))')i, WR(i), WI(i) !write(*, '(I3,X,1000(F16.10,X))')i, WR(i), WI(i)
if(.false.)then if(.false.)then
if(WI(i).ne.0.d0)then if(WI(i).ne.0.d0)then
print*,'*****************' print*,'*****************'
@ -386,7 +387,7 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei
thr_diag = 1d-06 thr_diag = 1d-06
thr_norm = 1d+10 thr_norm = 1d+10
call check_EIGVEC(n, n, A, WR, VL, VR, thr_diag, thr_norm, .false.) !call check_EIGVEC(n, n, A, WR, VL, VR, thr_diag, thr_norm, .false.)
! !
! ------------------------------------------------------------------------------------- ! -------------------------------------------------------------------------------------
@ -400,7 +401,7 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei
!thr = 100d0 !thr = 100d0
thr = Im_thresh_tcscf thr = Im_thresh_tcscf
do i = 1, n do i = 1, n
print*, 'Re(i) + Im(i)', WR(i), WI(i) !print*, 'Re(i) + Im(i)', WR(i), WI(i)
if(dabs(WI(i)) .lt. thr) then if(dabs(WI(i)) .lt. thr) then
n_good += 1 n_good += 1
else else
@ -479,15 +480,16 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei
return return
! accu_nd is modified after adding the normalization ! accu_nd is modified after adding the normalization
!elseif( (accu_nd .lt. thr_nd) .and. (dabs(accu_d-dble(n_real_eigv))/dble(n_real_eigv) .gt. thr_d) ) then elseif( (accu_nd .lt. thr_nd) .and. (dabs(accu_d-dble(n_real_eigv))/dble(n_real_eigv) .gt. thr_d) ) then
! print *, ' lapack vectors are not normalized but bi-orthogonalized' print *, ' lapack vectors are not normalized but bi-orthogonalized'
! call check_biorthog_binormalize(n, n_real_eigv, leigvec, reigvec, thr_d, thr_nd, .true.) call check_biorthog_binormalize(n, n_real_eigv, leigvec, reigvec, thr_d, thr_nd, .true.)
! call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, thr_diag, thr_norm, .true.) call check_biorthog(n, n_real_eigv, leigvec, reigvec, accu_d, accu_nd, S, thr_d, thr_nd, .true.)
call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, thr_diag, thr_norm, .true.)
! deallocate(S) deallocate(S)
! return return
else else
@ -495,18 +497,10 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei
! --- ! ---
! call impose_orthog_degen_eigvec(n, eigval, reigvec) allocate(deg_num(n))
! call impose_orthog_degen_eigvec(n, eigval, leigvec) call reorder_degen_eigvec(n, deg_num, eigval, leigvec, reigvec)
call impose_biorthog_degen_eigvec(n, deg_num, eigval, leigvec, reigvec)
call reorder_degen_eigvec(n, eigval, leigvec, reigvec) deallocate(deg_num)
call impose_biorthog_degen_eigvec(n, eigval, leigvec, reigvec)
!call impose_orthog_biorthog_degen_eigvec(n, thr_d, thr_nd, eigval, leigvec, reigvec)
!call impose_unique_biorthog_degen_eigvec(n, eigval, mo_coef, ao_overlap, leigvec, reigvec)
! ---
call check_biorthog(n, n_real_eigv, leigvec, reigvec, accu_d, accu_nd, S, thr_d, thr_nd, .false.) call check_biorthog(n, n_real_eigv, leigvec, reigvec, accu_d, accu_nd, S, thr_d, thr_nd, .false.)
if( (accu_nd .lt. thr_nd) .and. (dabs(accu_d-dble(n_real_eigv)) .gt. thr_d) ) then if( (accu_nd .lt. thr_nd) .and. (dabs(accu_d-dble(n_real_eigv)) .gt. thr_d) ) then
@ -514,12 +508,7 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei
endif endif
call check_biorthog(n, n_real_eigv, leigvec, reigvec, accu_d, accu_nd, S, thr_d, thr_nd, .true.) call check_biorthog(n, n_real_eigv, leigvec, reigvec, accu_d, accu_nd, S, thr_d, thr_nd, .true.)
!call impose_biorthog_qr(n, n_real_eigv, thr_d, thr_nd, leigvec, reigvec) !call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, thr_diag, thr_norm, .true.)
!call impose_biorthog_lu(n, n_real_eigv, thr_d, thr_nd, leigvec, reigvec)
! ---
call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, thr_diag, thr_norm, .true.)
deallocate(S) deallocate(S)
@ -530,7 +519,7 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei
return return
end subroutine non_hrmt_bieig end
! --- ! ---
@ -703,7 +692,7 @@ subroutine non_hrmt_bieig_random_diag(n, A, leigvec, reigvec, n_real_eigv, eigva
return return
end subroutine non_hrmt_bieig_random_diag end
! --- ! ---
@ -812,7 +801,7 @@ subroutine non_hrmt_real_im(n, A, leigvec, reigvec, n_real_eigv, eigval)
deallocate( S ) deallocate( S )
end subroutine non_hrmt_real_im end
! --- ! ---
@ -917,7 +906,7 @@ subroutine non_hrmt_generalized_real_im(n, A, B, leigvec, reigvec, n_real_eigv,
deallocate( S ) deallocate( S )
end subroutine non_hrmt_generalized_real_im end
! --- ! ---
@ -1053,7 +1042,7 @@ subroutine non_hrmt_bieig_fullvect(n, A, leigvec, reigvec, n_real_eigv, eigval)
return return
end subroutine non_hrmt_bieig_fullvect end
! --- ! ---

380
plugins/local/non_hermit_dav/lapack_diag_non_hermit.irp.f
View File

@ -54,7 +54,7 @@ subroutine lapack_diag_non_sym(n, A, WR, WI, VL, VR)
deallocate(Atmp, WORK) deallocate(Atmp, WORK)
end subroutine lapack_diag_non_sym end
subroutine non_sym_diag_inv_right(n,A,leigvec,reigvec,n_real_eigv,eigval) subroutine non_sym_diag_inv_right(n,A,leigvec,reigvec,n_real_eigv,eigval)
@ -269,7 +269,7 @@ subroutine lapack_diag_non_sym_new(n, A, WR, WI, VL, VR)
deallocate( Atmp ) deallocate( Atmp )
deallocate( WORK, SCALE_array, RCONDE, RCONDV, IWORK ) deallocate( WORK, SCALE_array, RCONDE, RCONDV, IWORK )
end subroutine lapack_diag_non_sym_new end
! --- ! ---
@ -323,7 +323,7 @@ subroutine lapack_diag_non_sym_right(n, A, WR, WI, VR)
! write(*, '(1000(F16.10,X))') VR(:,i) ! write(*, '(1000(F16.10,X))') VR(:,i)
! enddo ! enddo
end subroutine lapack_diag_non_sym_right end
! --- ! ---
@ -437,7 +437,7 @@ subroutine non_hrmt_real_diag(n, A, leigvec, reigvec, n_real_eigv, eigval)
print*, ' Notice that if you are interested in ground state it is not a problem :)' print*, ' Notice that if you are interested in ground state it is not a problem :)'
endif endif
end subroutine non_hrmt_real_diag end
! --- ! ---
@ -495,7 +495,7 @@ subroutine lapack_diag_general_non_sym(n, A, B, WR, WI, VL, VR)
deallocate( WORK, Atmp ) deallocate( WORK, Atmp )
end subroutine lapack_diag_general_non_sym end
! --- ! ---
@ -570,7 +570,7 @@ subroutine non_hrmt_general_real_diag(n, A, B, reigvec, leigvec, n_real_eigv, ei
enddo enddo
enddo enddo
end subroutine non_hrmt_general_real_diag end
! --- ! ---
@ -727,7 +727,7 @@ subroutine impose_biorthog_qr(m, n, thr_d, thr_nd, Vl, Vr)
deallocate(tmp) deallocate(tmp)
return return
end subroutine impose_biorthog_qr end
! --- ! ---
@ -890,7 +890,7 @@ subroutine impose_biorthog_lu(m, n, Vl, Vr, S)
!stop !stop
return return
end subroutine impose_biorthog_lu end
! --- ! ---
@ -996,7 +996,7 @@ subroutine check_EIGVEC(n, m, A, eigval, leigvec, reigvec, thr_diag, thr_norm, s
deallocate( Mtmp ) deallocate( Mtmp )
end subroutine check_EIGVEC end
! --- ! ---
@ -1066,7 +1066,7 @@ subroutine check_degen(n, m, eigval, leigvec, reigvec)
stop stop
endif endif
end subroutine check_degen end
! --- ! ---
@ -1169,7 +1169,7 @@ subroutine impose_weighted_orthog_svd(n, m, W, C)
! --- ! ---
end subroutine impose_weighted_orthog_svd end
! --- ! ---
@ -1266,7 +1266,7 @@ subroutine impose_orthog_svd(n, m, C)
! --- ! ---
end subroutine impose_orthog_svd end
! --- ! ---
@ -1365,7 +1365,7 @@ subroutine impose_orthog_svd_overlap(n, m, C, overlap)
!enddo !enddo
deallocate(S) deallocate(S)
end subroutine impose_orthog_svd_overlap end
! --- ! ---
@ -1442,7 +1442,7 @@ subroutine impose_orthog_GramSchmidt(n, m, C)
! --- ! ---
end subroutine impose_orthog_GramSchmidt end
! --- ! ---
@ -1484,7 +1484,7 @@ subroutine impose_orthog_ones(n, deg_num, C)
endif endif
enddo enddo
end subroutine impose_orthog_ones end
! --- ! ---
@ -1577,7 +1577,7 @@ subroutine impose_orthog_degen_eigvec(n, e0, C0)
endif endif
enddo enddo
end subroutine impose_orthog_degen_eigvec end
! --- ! ---
@ -1661,7 +1661,7 @@ subroutine get_halfinv_svd(n, S)
deallocate(S0, Stmp, Stmp2) deallocate(S0, Stmp, Stmp2)
end subroutine get_halfinv_svd end
! --- ! ---
@ -1776,7 +1776,7 @@ subroutine check_biorthog_binormalize(n, m, Vl, Vr, thr_d, thr_nd, stop_ifnot)
stop stop
endif endif
end subroutine check_biorthog_binormalize end
! --- ! ---
@ -1840,7 +1840,7 @@ subroutine check_weighted_biorthog(n, m, W, Vl, Vr, thr_d, thr_nd, accu_d, accu_
stop stop
endif endif
end subroutine check_weighted_biorthog end
! --- ! ---
@ -1865,10 +1865,11 @@ subroutine check_biorthog(n, m, Vl, Vr, accu_d, accu_nd, S, thr_d, thr_nd, stop_
, Vl, size(Vl, 1), Vr, size(Vr, 1) & , Vl, size(Vl, 1), Vr, size(Vr, 1) &
, 0.d0, S, size(S, 1) ) , 0.d0, S, size(S, 1) )
print *, ' overlap matrix:' ! print S s'il y a besoin
do i = 1, m !print *, ' overlap matrix:'
write(*,'(1000(F16.10,X))') S(i,:) !do i = 1, m
enddo ! write(*,'(1000(F16.10,X))') S(i,:)
!enddo
accu_d = 0.d0 accu_d = 0.d0
accu_nd = 0.d0 accu_nd = 0.d0
@ -1876,15 +1877,22 @@ subroutine check_biorthog(n, m, Vl, Vr, accu_d, accu_nd, S, thr_d, thr_nd, stop_
do j = 1, m do j = 1, m
if(i==j) then if(i==j) then
accu_d = accu_d + dabs(S(i,i)) accu_d = accu_d + dabs(S(i,i))
!print*, i, S(i,i)
else else
accu_nd = accu_nd + S(j,i) * S(j,i) accu_nd = accu_nd + S(j,i) * S(j,i)
endif endif
enddo enddo
enddo enddo
!accu_nd = dsqrt(accu_nd) / dble(m*m)
accu_nd = dsqrt(accu_nd) / dble(m) accu_nd = dsqrt(accu_nd) / dble(m)
print *, ' accu_nd = ', accu_nd if((accu_nd .gt. thr_nd) .or. dabs(accu_d-dble(m))/dble(m) .gt. thr_d) then
print *, ' accu_d = ', dabs(accu_d-dble(m))/dble(m) print *, ' non bi-orthogonal vectors !'
print *, ' accu_nd = ', accu_nd
print *, ' accu_d = ', dabs(accu_d-dble(m))/dble(m)
else
print *, ' vectors are bi-orthogonals'
endif
! --- ! ---
@ -1899,7 +1907,7 @@ subroutine check_biorthog(n, m, Vl, Vr, accu_d, accu_nd, S, thr_d, thr_nd, stop_
stop stop
endif endif
end subroutine check_biorthog end
! --- ! ---
@ -1941,27 +1949,25 @@ subroutine check_orthog(n, m, V, accu_d, accu_nd, S)
!print*, ' diag acc: ', accu_d !print*, ' diag acc: ', accu_d
!print*, ' nondiag acc: ', accu_nd !print*, ' nondiag acc: ', accu_nd
end subroutine check_orthog end
! --- ! ---
subroutine reorder_degen_eigvec(n, e0, L0, R0)
subroutine reorder_degen_eigvec(n, deg_num, e0, L0, R0)
implicit none implicit none
integer, intent(in) :: n integer, intent(in) :: n
double precision, intent(in) :: e0(n) double precision, intent(inout) :: e0(n), L0(n,n), R0(n,n)
double precision, intent(inout) :: L0(n,n), R0(n,n) integer, intent(out) :: deg_num(n)
logical :: complex_root logical :: complex_root
integer :: i, j, k, m integer :: i, j, k, m, ii, j_tmp
double precision :: ei, ej, de, de_thr double precision :: ei, ej, de, de_thr
double precision :: accu_d, accu_nd double precision :: accu_d, accu_nd
integer, allocatable :: deg_num(:) double precision :: e0_tmp, L0_tmp(n), R0_tmp(n)
double precision, allocatable :: L(:,:), R(:,:), S(:,:), S_inv_half(:,:) double precision, allocatable :: L(:,:), R(:,:), S(:,:), S_inv_half(:,:)
! ---
allocate( deg_num(n) )
do i = 1, n do i = 1, n
deg_num(i) = 1 deg_num(i) = 1
enddo enddo
@ -1972,74 +1978,104 @@ subroutine reorder_degen_eigvec(n, e0, L0, R0)
ei = e0(i) ei = e0(i)
! already considered in degen vectors ! already considered in degen vectors
if(deg_num(i).eq.0) cycle if(deg_num(i) .eq. 0) cycle
ii = 0
do j = i+1, n do j = i+1, n
ej = e0(j) ej = e0(j)
de = dabs(ei - ej) de = dabs(ei - ej)
if(de .lt. de_thr) then if(de .lt. de_thr) then
deg_num(i) = deg_num(i) + 1 ii = ii + 1
deg_num(j) = 0
endif j_tmp = i + ii
deg_num(j_tmp) = 0
e0_tmp = e0(j_tmp)
e0(j_tmp) = e0(j)
e0(j) = e0_tmp
L0_tmp(1:n) = L0(1:n,j_tmp)
L0(1:n,j_tmp) = L0(1:n,j)
L0(1:n,j) = L0_tmp(1:n)
R0_tmp(1:n) = R0(1:n,j_tmp)
R0(1:n,j_tmp) = R0(1:n,j)
R0(1:n,j) = R0_tmp(1:n)
endif
enddo enddo
deg_num(i) = ii + 1
enddo enddo
ii = 0
do i = 1, n do i = 1, n
if(deg_num(i) .gt. 1) then if(deg_num(i) .gt. 1) then
print *, ' degen on', i, deg_num(i), e0(i) !print *, ' degen on', i, deg_num(i), e0(i)
ii = ii + 1
endif endif
enddo enddo
if(ii .eq. 0) then
print*, ' WARNING: bi-orthogonality is lost but there is no degeneracies'
print*, ' rotations may change energy'
stop
endif
print *, ii, ' type of degeneracies'
! --- ! ---
do i = 1, n ! do i = 1, n
m = deg_num(i) ! m = deg_num(i)
!
! if(m .gt. 1) then
!
! allocate(L(n,m))
! allocate(R(n,m),S(m,m))
!
! do j = 1, m
! L(1:n,j) = L0(1:n,i+j-1)
! R(1:n,j) = R0(1:n,i+j-1)
! enddo
!
! !call dgemm( 'T', 'N', m, m, n, 1.d0 &
! ! , L, size(L, 1), R, size(R, 1) &
! ! , 0.d0, S, size(S, 1) )
! !print*, 'Overlap matrix '
! !accu_nd = 0.d0
! !do j = 1, m
! ! write(*,'(100(F16.10,X))') S(1:m,j)
! ! do k = 1, m
! ! if(j==k) cycle
! ! accu_nd += dabs(S(j,k))
! ! enddo
! !enddo
! !print*,'accu_nd = ',accu_nd
!! if(accu_nd .gt.1.d-10) then
!! stop
!! endif
!
! do j = 1, m
! L0(1:n,i+j-1) = L(1:n,j)
! R0(1:n,i+j-1) = R(1:n,j)
! enddo
!
! deallocate(L, R, S)
!
! endif
! enddo
!
end
if(m .gt. 1) then ! ---
allocate(L(n,m))
allocate(R(n,m),S(m,m))
do j = 1, m subroutine impose_biorthog_degen_eigvec(n, deg_num, e0, L0, R0)
L(1:n,j) = L0(1:n,i+j-1)
R(1:n,j) = R0(1:n,i+j-1)
enddo
call dgemm( 'T', 'N', m, m, n, 1.d0 &
, L, size(L, 1), R, size(R, 1) &
, 0.d0, S, size(S, 1) )
print*,'Overlap matrix '
accu_nd = 0.D0
do j = 1, m
write(*,'(100(F16.10,X))')S(1:m,j)
do k = 1, m
if(j==k)cycle
accu_nd += dabs(S(j,k))
enddo
enddo
print*,'accu_nd = ',accu_nd
! if(accu_nd .gt.1.d-10)then
! stop
! endif
do j = 1, m
L0(1:n,i+j-1) = L(1:n,j)
R0(1:n,i+j-1) = R(1:n,j)
enddo
deallocate(L, R,S)
endif
enddo
end subroutine reorder_degen_eigvec
subroutine impose_biorthog_degen_eigvec(n, e0, L0, R0)
implicit none implicit none
integer, intent(in) :: n integer, intent(in) :: n, deg_num(n)
double precision, intent(in) :: e0(n) double precision, intent(in) :: e0(n)
double precision, intent(inout) :: L0(n,n), R0(n,n) double precision, intent(inout) :: L0(n,n), R0(n,n)
@ -2047,41 +2083,13 @@ subroutine impose_biorthog_degen_eigvec(n, e0, L0, R0)
integer :: i, j, k, m integer :: i, j, k, m
double precision :: ei, ej, de, de_thr double precision :: ei, ej, de, de_thr
double precision :: accu_d, accu_nd double precision :: accu_d, accu_nd
integer, allocatable :: deg_num(:)
double precision, allocatable :: L(:,:), R(:,:), S(:,:), S_inv_half(:,:) double precision, allocatable :: L(:,:), R(:,:), S(:,:), S_inv_half(:,:)
! --- !do i = 1, n
! if(deg_num(i) .gt. 1) then
allocate( deg_num(n) ) ! print *, ' degen on', i, deg_num(i), e0(i)
do i = 1, n ! endif
deg_num(i) = 1 !enddo
enddo
de_thr = thr_degen_tc
do i = 1, n-1
ei = e0(i)
! already considered in degen vectors
if(deg_num(i).eq.0) cycle
do j = i+1, n
ej = e0(j)
de = dabs(ei - ej)
if(de .lt. de_thr) then
deg_num(i) = deg_num(i) + 1
deg_num(j) = 0
endif
enddo
enddo
do i = 1, n
if(deg_num(i) .gt. 1) then
print *, ' degen on', i, deg_num(i), e0(i)
endif
enddo
! --- ! ---
@ -2090,8 +2098,7 @@ subroutine impose_biorthog_degen_eigvec(n, e0, L0, R0)
if(m .gt. 1) then if(m .gt. 1) then
allocate(L(n,m)) allocate(L(n,m), R(n,m), S(m,m))
allocate(R(n,m))
do j = 1, m do j = 1, m
L(1:n,j) = L0(1:n,i+j-1) L(1:n,j) = L0(1:n,i+j-1)
@ -2100,8 +2107,53 @@ subroutine impose_biorthog_degen_eigvec(n, e0, L0, R0)
! --- ! ---
! call impose_orthog_svd(n, m, L) !print*, 'Overlap matrix before'
call impose_orthog_svd(n, m, R) call dgemm( 'T', 'N', m, m, n, 1.d0 &
, L, size(L, 1), R, size(R, 1) &
, 0.d0, S, size(S, 1) )
accu_nd = 0.d0
do j = 1, m
!write(*,'(100(F16.10,X))') S(1:m,j)
do k = 1, m
if(j==k) cycle
accu_nd += dabs(S(j,k))
enddo
enddo
if(accu_nd .lt. 1d-12) then
deallocate(S, L, R)
cycle
endif
!print*, ' accu_nd before = ', accu_nd
call impose_biorthog_svd(n, m, L, R)
!print*, 'Overlap matrix after'
call dgemm( 'T', 'N', m, m, n, 1.d0 &
, L, size(L, 1), R, size(R, 1) &
, 0.d0, S, size(S, 1) )
accu_nd = 0.d0
do j = 1, m
!write(*,'(100(F16.10,X))') S(1:m,j)
do k = 1, m
if(j==k) cycle
accu_nd += dabs(S(j,k))
enddo
enddo
!print*,' accu_nd after = ', accu_nd
if(accu_nd .gt. 1d-12) then
print*, ' your strategy for degenerates orbitals failed !'
print*, m, 'deg on', i
stop
endif
deallocate(S)
! ---
!call impose_orthog_svd(n, m, L)
!call impose_orthog_GramSchmidt(n, m, L) !call impose_orthog_GramSchmidt(n, m, L)
!call impose_orthog_GramSchmidt(n, m, R) !call impose_orthog_GramSchmidt(n, m, R)
@ -2120,8 +2172,7 @@ subroutine impose_biorthog_degen_eigvec(n, e0, L0, R0)
!call bi_ortho_s_inv_half(m, L, R, S_inv_half) !call bi_ortho_s_inv_half(m, L, R, S_inv_half)
!deallocate(S, S_inv_half) !deallocate(S, S_inv_half)
call impose_biorthog_svd(n, m, L, R) !call impose_biorthog_inverse(n, m, L, R)
! call impose_biorthog_inverse(n, m, L, R)
!call impose_biorthog_qr(n, m, thr_d, thr_nd, L, R) !call impose_biorthog_qr(n, m, thr_d, thr_nd, L, R)
@ -2136,9 +2187,8 @@ subroutine impose_biorthog_degen_eigvec(n, e0, L0, R0)
endif endif
enddo enddo
! call impose_biorthog_inverse(n, n, L0, R0)
end subroutine impose_biorthog_degen_eigvec end
! --- ! ---
@ -2232,7 +2282,7 @@ subroutine impose_orthog_biorthog_degen_eigvec(n, thr_d, thr_nd, e0, L0, R0)
endif endif
enddo enddo
end subroutine impose_orthog_biorthog_degen_eigvec end
! --- ! ---
@ -2370,7 +2420,7 @@ subroutine impose_unique_biorthog_degen_eigvec(n, thr_d, thr_nd, e0, C0, W0, L0,
endif endif
enddo enddo
end subroutine impose_unique_biorthog_degen_eigvec end
! --- ! ---
@ -2453,7 +2503,7 @@ subroutine max_overlap_qr(m, n, S0, V)
! --- ! ---
return return
end subroutine max_overlap_qr end
! --- ! ---
@ -2488,7 +2538,7 @@ subroutine max_overlap_invprod(n, m, S, V)
deallocate(tmp, invS) deallocate(tmp, invS)
return return
end subroutine max_overlap_invprod end
! --- ! ---
@ -2504,18 +2554,16 @@ subroutine impose_biorthog_svd(n, m, L, R)
double precision, allocatable :: S(:,:), tmp(:,:) double precision, allocatable :: S(:,:), tmp(:,:)
double precision, allocatable :: U(:,:), V(:,:), Vt(:,:), D(:) double precision, allocatable :: U(:,:), V(:,:), Vt(:,:), D(:)
! ---
allocate(S(m,m)) allocate(S(m,m))
call dgemm( 'T', 'N', m, m, n, 1.d0 & call dgemm( 'T', 'N', m, m, n, 1.d0 &
, L, size(L, 1), R, size(R, 1) & , L, size(L, 1), R, size(R, 1) &
, 0.d0, S, size(S, 1) ) , 0.d0, S, size(S, 1) )
print *, ' overlap bef SVD: ' !print *, ' overlap bef SVD: '
do i = 1, m !do i = 1, m
write(*, '(1000(F16.10,X))') S(i,:) ! write(*, '(1000(F16.10,X))') S(i,:)
enddo !enddo
! --- ! ---
@ -2552,51 +2600,32 @@ subroutine impose_biorthog_svd(n, m, L, R)
! --- ! ---
allocate(tmp(n,m)) ! R <-- R x V x D^{-0.5}
! L <-- L x U x D^{-0.5}
! tmp <-- R x V
call dgemm( 'N', 'N', n, m, m, 1.d0 &
, R, size(R, 1), V, size(V, 1) &
, 0.d0, tmp, size(tmp, 1) )
deallocate(V)
! R <-- tmp x sigma^-0.5
do j = 1, m
do i = 1, n
R(i,j) = tmp(i,j) * D(j)
enddo
enddo
! tmp <-- L x U
call dgemm( 'N', 'N', n, m, m, 1.d0 &
, L, size(L, 1), U, size(U, 1) &
, 0.d0, tmp, size(tmp, 1) )
deallocate(U)
! L <-- tmp x sigma^-0.5
do j = 1, m
do i = 1, n
L(i,j) = tmp(i,j) * D(j)
enddo
enddo
deallocate(D, tmp)
! ---
allocate(S(m,m))
call dgemm( 'T', 'N', m, m, n, 1.d0 &
, L, size(L, 1), R, size(R, 1) &
, 0.d0, S, size(S, 1) )
print *, ' overlap aft SVD: '
do i = 1, m do i = 1, m
write(*, '(1000(F16.10,X))') S(i,:) do j = 1, m
V(j,i) = V(j,i) * D(i)
U(j,i) = U(j,i) * D(i)
enddo
enddo enddo
deallocate(S) allocate(tmp(n,m))
tmp(:,:) = R(:,:)
call dgemm( 'N', 'N', n, m, m, 1.d0 &
, tmp, size(tmp, 1), V, size(V, 1) &
, 0.d0, R, size(R, 1))
! --- tmp(:,:) = L(:,:)
call dgemm( 'N', 'N', n, m, m, 1.d0 &
, tmp, size(tmp, 1), U, size(U, 1) &
, 0.d0, L, size(L, 1))
end subroutine impose_biorthog_svd deallocate(tmp, U, V, D)
end
! ---
subroutine impose_biorthog_inverse(n, m, L, R) subroutine impose_biorthog_inverse(n, m, L, R)
@ -2639,8 +2668,7 @@ subroutine impose_biorthog_inverse(n, m, L, R)
deallocate(S,Lt) deallocate(S,Lt)
end subroutine impose_biorthog_svd end
! --- ! ---
@ -2802,7 +2830,7 @@ subroutine impose_weighted_biorthog_qr(m, n, thr_d, thr_nd, Vl, W, Vr)
call check_weighted_biorthog_binormalize(m, n, Vl, W, Vr, thr_d, thr_nd, .false.) call check_weighted_biorthog_binormalize(m, n, Vl, W, Vr, thr_d, thr_nd, .false.)
return return
end subroutine impose_weighted_biorthog_qr end
! --- ! ---
@ -2919,7 +2947,7 @@ subroutine check_weighted_biorthog_binormalize(n, m, Vl, W, Vr, thr_d, thr_nd, s
stop stop
endif endif
end subroutine check_weighted_biorthog_binormalize end
! --- ! ---
@ -3037,7 +3065,7 @@ subroutine impose_weighted_biorthog_svd(n, m, overlap, L, R)
deallocate(S) deallocate(S)
return return
end subroutine impose_weighted_biorthog_svd end
! --- ! ---

6
plugins/local/tc_bi_ortho/compute_deltamu_right.irp.f
View File

@ -24,10 +24,6 @@ subroutine delta_right()
integer :: k integer :: k
double precision, allocatable :: delta(:,:) double precision, allocatable :: delta(:,:)
print *, j1b_type
print *, j1b_pen
print *, mu_erf
allocate( delta(N_det,N_states) ) allocate( delta(N_det,N_states) )
delta = 0.d0 delta = 0.d0
@ -48,7 +44,7 @@ subroutine delta_right()
deallocate(delta) deallocate(delta)
return return
end subroutine delta_right end
! --- ! ---

10
plugins/local/tc_bi_ortho/print_tc_energy.irp.f
View File

@ -17,8 +17,14 @@ program print_tc_energy
read_wf = .True. read_wf = .True.
touch read_wf touch read_wf
PROVIDE j1b_type
print*, 'j1b_type = ', j1b_type PROVIDE j2e_type
PROVIDE j1e_type
PROVIDE env_type
print *, ' j2e_type = ', j2e_type
print *, ' j1e_type = ', j1e_type
print *, ' env_type = ', env_type
call write_tc_energy() call write_tc_energy()

2
plugins/local/tc_bi_ortho/save_tc_bi_ortho_nat.irp.f
View File

@ -17,7 +17,7 @@ program tc_natorb_bi_ortho
my_n_pt_a_grid = tc_grid1_a my_n_pt_a_grid = tc_grid1_a
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
if(j1b_type .ge. 100) then if(tc_integ_type .eq. "numeric") then
my_extra_grid_becke = .True. my_extra_grid_becke = .True.
PROVIDE tc_grid2_a tc_grid2_r PROVIDE tc_grid2_a tc_grid2_r
my_n_pt_r_extra_grid = tc_grid2_r my_n_pt_r_extra_grid = tc_grid2_r

12
plugins/local/tc_bi_ortho/slater_tc_slow.irp.f
View File

@ -27,7 +27,7 @@ subroutine htilde_mu_mat_bi_ortho_tot_slow(key_j, key_i, Nint, htot)
call htilde_mu_mat_bi_ortho_slow(key_j, key_i, Nint, hmono, htwoe, hthree, htot) call htilde_mu_mat_bi_ortho_slow(key_j, key_i, Nint, hmono, htwoe, hthree, htot)
endif endif
end subroutine htilde_mu_mat_bi_ortho_tot_slow end
! -- ! --
@ -260,7 +260,6 @@ subroutine single_htilde_mu_mat_bi_ortho_slow(Nint, key_j, key_i, hmono, htwoe,
! !
! PROVIDE core_bitmask core_fock_operator mo_integrals_erf_map ! PROVIDE core_bitmask core_fock_operator mo_integrals_erf_map
! PROVIDE j1b_gauss
other_spin(1) = 2 other_spin(1) = 2
other_spin(2) = 1 other_spin(2) = 1
@ -295,15 +294,6 @@ subroutine single_htilde_mu_mat_bi_ortho_slow(Nint, key_j, key_i, hmono, htwoe,
hmono = mo_bi_ortho_tc_one_e(p1,h1) * phase hmono = mo_bi_ortho_tc_one_e(p1,h1) * phase
! if(j1b_gauss .eq. 1) then
! print*,'j1b not implemented for bi ortho TC'
! print*,'stopping ....'
! stop
! !hmono += ( mo_j1b_gauss_hermI (h1,p1) &
! ! + mo_j1b_gauss_hermII (h1,p1) &
! ! + mo_j1b_gauss_nonherm(h1,p1) ) * phase
! endif
! if(core_tc_op)then ! if(core_tc_op)then
! print*,'core_tc_op not already taken into account for bi ortho' ! print*,'core_tc_op not already taken into account for bi ortho'
! print*,'stopping ...' ! print*,'stopping ...'

2
plugins/local/tc_bi_ortho/tc_bi_ortho.irp.f
View File

@ -13,7 +13,7 @@ program tc_bi_ortho
my_n_pt_a_grid = tc_grid1_a my_n_pt_a_grid = tc_grid1_a
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
if(j1b_type .ge. 100) then if(tc_integ_type .eq. "numeric") then
my_extra_grid_becke = .True. my_extra_grid_becke = .True.
PROVIDE tc_grid2_a tc_grid2_r PROVIDE tc_grid2_a tc_grid2_r
my_n_pt_r_extra_grid = tc_grid2_r my_n_pt_r_extra_grid = tc_grid2_r

6
plugins/local/tc_bi_ortho/tc_som.irp.f
View File

@ -17,12 +17,6 @@ program tc_som
my_n_pt_a_grid = tc_grid1_a my_n_pt_a_grid = tc_grid1_a
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
PROVIDE mu_erf
print *, ' mu = ', mu_erf
PROVIDE j1b_type
print *, ' j1b_type = ', j1b_type
print *, j1b_pen
read_wf = .true. read_wf = .true.
touch read_wf touch read_wf

44
plugins/local/tc_keywords/EZFIO.cfg
View File

@ -130,30 +130,6 @@ doc: if +1: only positive is selected, -1: only negative is selected, :0 both po
interface: ezfio,provider,ocaml interface: ezfio,provider,ocaml
default: 0 default: 0
[j1b_pen]
type: double precision
doc: exponents of the 1-body Jastrow
interface: ezfio
size: (nuclei.nucl_num)
[j1b_pen_coef]
type: double precision
doc: coefficients 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
[mu_r_ct] [mu_r_ct]
type: double precision type: double precision
doc: a parameter used to define mu(r) doc: a parameter used to define mu(r)
@ -184,12 +160,6 @@ doc: If |true|, maximize the overlap between orthogonalized left- and right eige
interface: ezfio,provider,ocaml interface: ezfio,provider,ocaml
default: False default: False
[ng_fit_jast]
type: integer
doc: nb of Gaussians used to fit Jastrow fcts
interface: ezfio,provider,ocaml
default: 20
[max_dim_diis_tcscf] [max_dim_diis_tcscf]
type: integer type: integer
doc: Maximum size of the DIIS extrapolation procedure doc: Maximum size of the DIIS extrapolation procedure
@ -282,7 +252,7 @@ default: True
[tc_grid1_a] [tc_grid1_a]
type: integer type: integer
doc: size of angular grid over r1 doc: size of angular grid over r1: [ 6 | 14 | 26 | 38 | 50 | 74 | 86 | 110 | 146 | 170 | 194 | 230 | 266 | 302 | 350 | 434 | 590 | 770 | 974 | 1202 | 1454 | 1730 | 2030 | 2354 | 2702 | 3074 | 3470 | 3890 | 4334 | 4802 | 5294 | 5810 ]
interface: ezfio,provider,ocaml interface: ezfio,provider,ocaml
default: 50 default: 50
@ -294,13 +264,19 @@ default: 30
[tc_grid2_a] [tc_grid2_a]
type: integer type: integer
doc: size of angular grid over r2 doc: size of angular grid over r2: [ 6 | 14 | 26 | 38 | 50 | 74 | 86 | 110 | 146 | 170 | 194 | 230 | 266 | 302 | 350 | 434 | 590 | 770 | 974 | 1202 | 1454 | 1730 | 2030 | 2354 | 2702 | 3074 | 3470 | 3890 | 4334 | 4802 | 5294 | 5810 ]
interface: ezfio,provider,ocaml interface: ezfio,provider,ocaml
default: 194 default: 266
[tc_grid2_r] [tc_grid2_r]
type: integer type: integer
doc: size of radial grid over r2 doc: size of radial grid over r2
interface: ezfio,provider,ocaml interface: ezfio,provider,ocaml
default: 50 default: 70
[tc_integ_type]
type: character*(32)
doc: approach used to evaluate TC integrals [ analytic | numeric | semi-analytic ]
interface: ezfio,ocaml,provider
default: semi-analytic

155
plugins/local/tc_keywords/j1b_pen.irp.f
View File

@ -1,155 +0,0 @@
! ---
BEGIN_PROVIDER [ double precision, j1b_pen , (nucl_num) ]
&BEGIN_PROVIDER [ double precision, j1b_pen_coef, (nucl_num) ]
BEGIN_DOC
! parameters of the 1-body Jastrow
END_DOC
implicit none
logical :: exists
integer :: i
integer :: ierr
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'
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
do i = 1, nucl_num
j1b_pen(i) = 1d5
enddo
endif
! ---
if (mpi_master) then
call ezfio_has_tc_keywords_j1b_pen_coef(exists)
endif
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI
call MPI_BCAST(j1b_pen_coef, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read j1b_pen_coef with MPI'
endif
IRP_ENDIF
if (exists) then
if (mpi_master) then
write(6,'(A)') '.. >>>>> [ IO READ: j1b_pen_coef ] <<<<< ..'
call ezfio_get_tc_keywords_j1b_pen_coef(j1b_pen_coef)
IRP_IF MPI
call MPI_BCAST(j1b_pen_coef, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read j1b_pen_coef with MPI'
endif
IRP_ENDIF
endif
else
do i = 1, nucl_num
j1b_pen_coef(i) = 1d0
enddo
endif
! ---
print *, ' parameters for nuclei jastrow'
print *, ' i, Z, j1b_pen, j1b_pen_coef'
do i = 1, nucl_num
write(*,'(I4, 2x, 3(E15.7, 2X))') i, nucl_charge(i), j1b_pen(i), j1b_pen_coef(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
! ---

10
plugins/local/tc_scf/fock_vartc.irp.f
View File

@ -13,9 +13,9 @@
two_e_vartc_integral_alpha = 0.d0 two_e_vartc_integral_alpha = 0.d0
two_e_vartc_integral_beta = 0.d0 two_e_vartc_integral_beta = 0.d0
!$OMP PARALLEL DEFAULT (NONE) & !$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (i, j, k, l, density_a, density_b, density, tmp_a, tmp_b, I_coul, I_kjli) & !$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_vartc_tot, & !$OMP SHARED (ao_num, TCSCF_density_matrix_ao_alpha, TCSCF_density_matrix_ao_beta, ao_two_e_tc_tot, &
!$OMP two_e_vartc_integral_alpha, two_e_vartc_integral_beta) !$OMP two_e_vartc_integral_alpha, two_e_vartc_integral_beta)
allocate(tmp_a(ao_num,ao_num), tmp_b(ao_num,ao_num)) allocate(tmp_a(ao_num,ao_num), tmp_b(ao_num,ao_num))
@ -31,8 +31,8 @@
do i = 1, ao_num do i = 1, ao_num
do k = 1, ao_num do k = 1, ao_num
I_coul = density * ao_two_e_vartc_tot(k,i,l,j) I_coul = density * ao_two_e_tc_tot(k,i,l,j)
I_kjli = ao_two_e_vartc_tot(k,j,l,i) I_kjli = ao_two_e_tc_tot(k,j,l,i)
tmp_a(k,i) += I_coul - density_a * I_kjli tmp_a(k,i) += I_coul - density_a * I_kjli
tmp_b(k,i) += I_coul - density_b * I_kjli tmp_b(k,i) += I_coul - density_b * I_kjli

10
plugins/local/tc_scf/print_tcscf_energy.irp.f
View File

@ -24,11 +24,15 @@ subroutine main()
implicit none implicit none
double precision :: etc_tot, etc_1e, etc_2e, etc_3e double precision :: etc_tot, etc_1e, etc_2e, etc_3e
PROVIDE mu_erf PROVIDE j2e_type mu_erf
PROVIDE j1b_type PROVIDE j1e_type j1e_coef j1e_expo
PROVIDE env_type env_coef env_expo
print*, ' j2e_type = ', j2e_type
print*, ' j1e_type = ', j1e_type
print*, ' env_type = ', env_type
print*, ' mu_erf = ', mu_erf print*, ' mu_erf = ', mu_erf
print*, ' j1b_type = ', j1b_type
etc_tot = TC_HF_energy etc_tot = TC_HF_energy
etc_1e = TC_HF_one_e_energy etc_1e = TC_HF_one_e_energy

34
plugins/local/tc_scf/tc_scf.irp.f
View File

@ -7,11 +7,20 @@ program tc_scf
END_DOC END_DOC
implicit none implicit none
integer :: i
logical :: good_angles
PROVIDE j1e_type
PROVIDE j2e_type
PROVIDE tcscf_algorithm
PROVIDE var_tc
print *, ' TC-SCF with:'
print *, ' j1e_type = ', j1e_type
print *, ' j2e_type = ', j2e_type
write(json_unit,json_array_open_fmt) 'tc-scf' write(json_unit,json_array_open_fmt) 'tc-scf'
print *, ' starting ...'
my_grid_becke = .True. my_grid_becke = .True.
PROVIDE tc_grid1_a tc_grid1_r PROVIDE tc_grid1_a tc_grid1_r
my_n_pt_r_grid = tc_grid1_r my_n_pt_r_grid = tc_grid1_r
@ -22,13 +31,7 @@ program tc_scf
call write_int(6, my_n_pt_a_grid, 'angular external grid over') call write_int(6, my_n_pt_a_grid, 'angular external grid over')
PROVIDE mu_erf if(tc_integ_type .eq. "numeric") then
print *, ' mu = ', mu_erf
PROVIDE j1b_type
print *, ' j1b_type = ', j1b_type
print *, j1b_pen
if(j1b_type .ge. 100) then
my_extra_grid_becke = .True. my_extra_grid_becke = .True.
PROVIDE tc_grid2_a tc_grid2_r PROVIDE tc_grid2_a tc_grid2_r
my_n_pt_r_extra_grid = tc_grid2_r my_n_pt_r_extra_grid = tc_grid2_r
@ -42,8 +45,6 @@ program tc_scf
!call create_guess() !call create_guess()
!call orthonormalize_mos() !call orthonormalize_mos()
PROVIDE tcscf_algorithm
PROVIDE var_tc
if(var_tc) then if(var_tc) then
@ -69,7 +70,16 @@ program tc_scf
stop stop
endif endif
call minimize_tc_orb_angles() PROVIDE Fock_matrix_tc_diag_mo_tot
print*, ' Eigenvalues:'
do i = 1, mo_num
print*, i, Fock_matrix_tc_diag_mo_tot(i)
enddo
! TODO
! rotate angles in separate code only if necessary
!call minimize_tc_orb_angles()
call print_energy_and_mos(good_angles)
endif endif

392
plugins/local/tc_scf/test_int.irp.f
View File

@ -1,7 +1,7 @@
program test_ints program test_ints
BEGIN_DOC BEGIN_DOC
! TODO : Put the documentation of the program here ! TODO : Put the documentation of the program here
END_DOC END_DOC
implicit none implicit none
@ -20,41 +20,31 @@ program test_ints
touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid
!! OK !! OK
! call routine_int2_u_grad1u_j1b2 ! call routine_int2_u_grad1u_env2
! OK ! OK
! call routine_v_ij_erf_rk_cst_mu_j1b ! call routine_v_ij_erf_rk_cst_mu_env
! OK ! OK
! call routine_x_v_ij_erf_rk_cst_mu_j1b ! call routine_x_v_ij_erf_rk_cst_mu_env
! OK ! OK
! call routine_int2_u2_j1b2 ! call routine_int2_u2_env2
! OK ! OK
! call routine_int2_u_grad1u_x_j1b2 ! call routine_int2_u_grad1u_x_env2
! OK ! OK
! call routine_int2_grad1u2_grad2u2_j1b2 ! call routine_int2_grad1u2_grad2u2_env2
! call routine_int2_u_grad1u_j1b2 ! call routine_int2_u_grad1u_env2
! call test_total_grad_lapl
! call test_total_grad_square
! call test_int2_grad1_u12_ao_test ! call test_int2_grad1_u12_ao_test
! call routine_v_ij_u_cst_mu_j1b_test ! call routine_v_ij_u_cst_mu_env_test
! call test_ao_tc_int_chemist
! call test_grid_points_ao ! call test_grid_points_ao
! call test_tc_scf
!call test_int_gauss !call test_int_gauss
!call test_fock_3e_uhf_ao() !call test_fock_3e_uhf_ao()
!call test_fock_3e_uhf_mo() !call test_fock_3e_uhf_mo()
!call test_tc_grad_and_lapl_ao()
!call test_tc_grad_square_ao()
!call test_two_e_tc_non_hermit_integral() !call test_two_e_tc_non_hermit_integral()
! call test_tc_grad_square_ao_test()
!!PROVIDE TC_HF_energy VARTC_HF_energy !!PROVIDE TC_HF_energy VARTC_HF_energy
!!print *, ' TC_HF_energy = ', TC_HF_energy !!print *, ' TC_HF_energy = ', TC_HF_energy
!!print *, ' VARTC_HF_energy = ', VARTC_HF_energy !!print *, ' VARTC_HF_energy = ', VARTC_HF_energy
! call test_old_ints
call test_fock_3e_uhf_mo_cs() call test_fock_3e_uhf_mo_cs()
call test_fock_3e_uhf_mo_a() call test_fock_3e_uhf_mo_a()
@ -64,47 +54,21 @@ end
! --- ! ---
subroutine test_tc_scf subroutine routine_test_env
implicit none
integer :: i
! provide int2_u_grad1u_x_j1b2_test
provide x_v_ij_erf_rk_cst_mu_j1b_test
! do i = 1, ng_fit_jast
! print*,expo_gauss_1_erf_x_2(i),coef_gauss_1_erf_x_2(i)
! enddo
! provide tc_grad_square_ao_test
! provide tc_grad_and_lapl_ao_test
! provide int2_u_grad1u_x_j1b2_test
! provide x_v_ij_erf_rk_cst_mu_j1b_test
! print*,'TC_HF_energy = ',TC_HF_energy
! print*,'grad_non_hermit = ',grad_non_hermit
end
subroutine test_ao_tc_int_chemist
implicit none
provide ao_tc_int_chemist
! provide ao_tc_int_chemist_test
! provide tc_grad_square_ao_test
! provide tc_grad_and_lapl_ao_test
end
! ---
subroutine routine_test_j1b
implicit none implicit none
integer :: i,icount,j integer :: i,icount,j
icount = 0 icount = 0
do i = 1, List_all_comb_b3_size do i = 1, List_env1s_square_size
if(dabs(List_all_comb_b3_coef(i)).gt.1.d-10)then if(dabs(List_env1s_square_coef(i)).gt.1.d-10)then
print*,'' print*,''
print*,List_all_comb_b3_expo(i),List_all_comb_b3_coef(i) print*,List_env1s_square_expo(i),List_env1s_square_coef(i)
print*,List_all_comb_b3_cent(1:3,i) print*,List_env1s_square_cent(1:3,i)
print*,'' print*,''
icount += 1 icount += 1
endif endif
enddo enddo
print*,'List_all_comb_b3_coef,icount = ',List_all_comb_b3_size,icount print*,'List_env1s_square_coef,icount = ',List_env1s_square_size,icount
do i = 1, ao_num do i = 1, ao_num
do j = 1, ao_num do j = 1, ao_num
do icount = 1, List_comb_thr_b3_size(j,i) do icount = 1, List_comb_thr_b3_size(j,i)
@ -116,11 +80,11 @@ subroutine routine_test_j1b
! enddo ! enddo
enddo enddo
enddo enddo
print*,'max_List_comb_thr_b3_size = ',max_List_comb_thr_b3_size,List_all_comb_b3_size print*,'max_List_comb_thr_b3_size = ',max_List_comb_thr_b3_size,List_env1s_square_size
end end
subroutine routine_int2_u_grad1u_j1b2 subroutine routine_int2_u_grad1u_env2
implicit none implicit none
integer :: i,j,ipoint,k,l integer :: i,j,ipoint,k,l
double precision :: weight,accu_relat, accu_abs, contrib double precision :: weight,accu_relat, accu_abs, contrib
@ -136,8 +100,8 @@ subroutine routine_int2_u_grad1u_j1b2
do l = 1, ao_num do l = 1, ao_num
do i = 1, ao_num do i = 1, ao_num
do j = 1, ao_num do j = 1, ao_num
array(j,i,l,k) += int2_u_grad1u_j1b2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight array(j,i,l,k) += int2_u_grad1u_env2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
array_ref(j,i,l,k) += int2_u_grad1u_j1b2(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight array_ref(j,i,l,k) += int2_u_grad1u_env2(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
enddo enddo
enddo enddo
enddo enddo
@ -160,7 +124,7 @@ subroutine routine_int2_u_grad1u_j1b2
enddo enddo
print*,'******' print*,'******'
print*,'******' print*,'******'
print*,'routine_int2_u_grad1u_j1b2' print*,'routine_int2_u_grad1u_env2'
print*,'accu_abs = ',accu_abs/dble(ao_num)**4 print*,'accu_abs = ',accu_abs/dble(ao_num)**4
print*,'accu_relat = ',accu_relat/dble(ao_num)**4 print*,'accu_relat = ',accu_relat/dble(ao_num)**4
@ -168,7 +132,7 @@ subroutine routine_int2_u_grad1u_j1b2
end end
subroutine routine_v_ij_erf_rk_cst_mu_j1b subroutine routine_v_ij_erf_rk_cst_mu_env
implicit none implicit none
integer :: i,j,ipoint,k,l integer :: i,j,ipoint,k,l
double precision :: weight,accu_relat, accu_abs, contrib double precision :: weight,accu_relat, accu_abs, contrib
@ -183,8 +147,8 @@ subroutine routine_v_ij_erf_rk_cst_mu_j1b
do l = 1, ao_num do l = 1, ao_num
do i = 1, ao_num do i = 1, ao_num
do j = 1, ao_num do j = 1, ao_num
array(j,i,l,k) += v_ij_erf_rk_cst_mu_j1b_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight array(j,i,l,k) += v_ij_erf_rk_cst_mu_env_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
array_ref(j,i,l,k) += v_ij_erf_rk_cst_mu_j1b(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight array_ref(j,i,l,k) += v_ij_erf_rk_cst_mu_env(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
enddo enddo
enddo enddo
enddo enddo
@ -207,7 +171,7 @@ subroutine routine_v_ij_erf_rk_cst_mu_j1b
enddo enddo
print*,'******' print*,'******'
print*,'******' print*,'******'
print*,'routine_v_ij_erf_rk_cst_mu_j1b' print*,'routine_v_ij_erf_rk_cst_mu_env'
print*,'accu_abs = ',accu_abs/dble(ao_num)**4 print*,'accu_abs = ',accu_abs/dble(ao_num)**4
print*,'accu_relat = ',accu_relat/dble(ao_num)**4 print*,'accu_relat = ',accu_relat/dble(ao_num)**4
@ -216,7 +180,7 @@ subroutine routine_v_ij_erf_rk_cst_mu_j1b
end end
subroutine routine_x_v_ij_erf_rk_cst_mu_j1b subroutine routine_x_v_ij_erf_rk_cst_mu_env
implicit none implicit none
integer :: i,j,ipoint,k,l,m integer :: i,j,ipoint,k,l,m
double precision :: weight,accu_relat, accu_abs, contrib double precision :: weight,accu_relat, accu_abs, contrib
@ -232,8 +196,8 @@ subroutine routine_x_v_ij_erf_rk_cst_mu_j1b
do i = 1, ao_num do i = 1, ao_num
do j = 1, ao_num do j = 1, ao_num
do m = 1, 3 do m = 1, 3
array(j,i,l,k) += x_v_ij_erf_rk_cst_mu_j1b_test(j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight array(j,i,l,k) += x_v_ij_erf_rk_cst_mu_env_test(j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight
array_ref(j,i,l,k) += x_v_ij_erf_rk_cst_mu_j1b (j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight array_ref(j,i,l,k) += x_v_ij_erf_rk_cst_mu_env (j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight
enddo enddo
enddo enddo
enddo enddo
@ -258,7 +222,7 @@ subroutine routine_x_v_ij_erf_rk_cst_mu_j1b
print*,'******' print*,'******'
print*,'******' print*,'******'
print*,'routine_x_v_ij_erf_rk_cst_mu_j1b' print*,'routine_x_v_ij_erf_rk_cst_mu_env'
print*,'accu_abs = ',accu_abs/dble(ao_num)**4 print*,'accu_abs = ',accu_abs/dble(ao_num)**4
print*,'accu_relat = ',accu_relat/dble(ao_num)**4 print*,'accu_relat = ',accu_relat/dble(ao_num)**4
@ -268,7 +232,7 @@ end
subroutine routine_v_ij_u_cst_mu_j1b_test subroutine routine_v_ij_u_cst_mu_env_test
implicit none implicit none
integer :: i,j,ipoint,k,l integer :: i,j,ipoint,k,l
double precision :: weight,accu_relat, accu_abs, contrib double precision :: weight,accu_relat, accu_abs, contrib
@ -283,8 +247,8 @@ subroutine routine_v_ij_u_cst_mu_j1b_test
do l = 1, ao_num do l = 1, ao_num
do i = 1, ao_num do i = 1, ao_num
do j = 1, ao_num do j = 1, ao_num
array(j,i,l,k) += v_ij_u_cst_mu_j1b_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight array(j,i,l,k) += v_ij_u_cst_mu_env_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
array_ref(j,i,l,k) += v_ij_u_cst_mu_j1b_fit (j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight array_ref(j,i,l,k) += v_ij_u_cst_mu_env_fit (j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
enddo enddo
enddo enddo
enddo enddo
@ -307,15 +271,13 @@ subroutine routine_v_ij_u_cst_mu_j1b_test
enddo enddo
print*,'******' print*,'******'
print*,'******' print*,'******'
print*,'routine_v_ij_u_cst_mu_j1b_test' print*,'routine_v_ij_u_cst_mu_env_test'
print*,'accu_abs = ',accu_abs/dble(ao_num)**4 print*,'accu_abs = ',accu_abs/dble(ao_num)**4
print*,'accu_relat = ',accu_relat/dble(ao_num)**4 print*,'accu_relat = ',accu_relat/dble(ao_num)**4
end end
subroutine routine_int2_grad1u2_grad2u2_j1b2 subroutine routine_int2_grad1u2_grad2u2_env2
implicit none implicit none
integer :: i,j,ipoint,k,l integer :: i,j,ipoint,k,l
integer :: ii , jj integer :: ii , jj
@ -341,17 +303,17 @@ subroutine routine_int2_grad1u2_grad2u2_j1b2
do l = 1, ao_num do l = 1, ao_num
do i = 1, ao_num do i = 1, ao_num
do j = 1, ao_num do j = 1, ao_num
array(j,i,l,k) += int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight array(j,i,l,k) += int2_grad1u2_grad2u2_env2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
! !array(j,i,l,k) += int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight ! !array(j,i,l,k) += int2_grad1u2_grad2u2_env2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
! array_ref(j,i,l,k) += int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight ! array_ref(j,i,l,k) += int2_grad1u2_grad2u2_env2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
! !array(j,i,l,k) += ints(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight ! !array(j,i,l,k) += ints(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
! array_ref(j,i,l,k) += int2_grad1u2_grad2u2_j1b2(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight ! array_ref(j,i,l,k) += int2_grad1u2_grad2u2_env2(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
array_ref(j,i,l,k) += ints(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight array_ref(j,i,l,k) += ints(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
! if(dabs(int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint)).gt.1.d-6)then ! if(dabs(int2_grad1u2_grad2u2_env2_test(j,i,ipoint)).gt.1.d-6)then
! if(dabs(int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint) - int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint)).gt.1.d-6)then ! if(dabs(int2_grad1u2_grad2u2_env2_test(j,i,ipoint) - int2_grad1u2_grad2u2_env2_test(j,i,ipoint)).gt.1.d-6)then
! print*,j,i,ipoint ! print*,j,i,ipoint
! print*,int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint) , int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint), dabs(int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint) - int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint)) ! print*,int2_grad1u2_grad2u2_env2_test(j,i,ipoint) , int2_grad1u2_grad2u2_env2_test(j,i,ipoint), dabs(int2_grad1u2_grad2u2_env2_test(j,i,ipoint) - int2_grad1u2_grad2u2_env2_test(j,i,ipoint))
! print*,int2_grad1u2_grad2u2_j1b2_test(i,j,ipoint) , int2_grad1u2_grad2u2_j1b2_test(i,j,ipoint), dabs(int2_grad1u2_grad2u2_j1b2_test(i,j,ipoint) - int2_grad1u2_grad2u2_j1b2_test(i,j,ipoint)) ! print*,int2_grad1u2_grad2u2_env2_test(i,j,ipoint) , int2_grad1u2_grad2u2_env2_test(i,j,ipoint), dabs(int2_grad1u2_grad2u2_env2_test(i,j,ipoint) - int2_grad1u2_grad2u2_env2_test(i,j,ipoint))
! stop ! stop
! endif ! endif
! endif ! endif
@ -394,7 +356,7 @@ subroutine routine_int2_grad1u2_grad2u2_j1b2
end end
subroutine routine_int2_u2_j1b2 subroutine routine_int2_u2_env2
implicit none implicit none
integer :: i,j,ipoint,k,l integer :: i,j,ipoint,k,l
double precision :: weight,accu_relat, accu_abs, contrib double precision :: weight,accu_relat, accu_abs, contrib
@ -410,8 +372,8 @@ subroutine routine_int2_u2_j1b2
do l = 1, ao_num do l = 1, ao_num
do i = 1, ao_num do i = 1, ao_num
do j = 1, ao_num do j = 1, ao_num
array(j,i,l,k) += int2_u2_j1b2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight array(j,i,l,k) += int2_u2_env2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
array_ref(j,i,l,k) += int2_u2_j1b2(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight array_ref(j,i,l,k) += int2_u2_env2(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
enddo enddo
enddo enddo
enddo enddo
@ -434,7 +396,7 @@ subroutine routine_int2_u2_j1b2
enddo enddo
print*,'******' print*,'******'
print*,'******' print*,'******'
print*,'routine_int2_u2_j1b2' print*,'routine_int2_u2_env2'
print*,'accu_abs = ',accu_abs/dble(ao_num)**4 print*,'accu_abs = ',accu_abs/dble(ao_num)**4
print*,'accu_relat = ',accu_relat/dble(ao_num)**4 print*,'accu_relat = ',accu_relat/dble(ao_num)**4
@ -443,7 +405,7 @@ subroutine routine_int2_u2_j1b2
end end
subroutine routine_int2_u_grad1u_x_j1b2 subroutine routine_int2_u_grad1u_x_env2
implicit none implicit none
integer :: i,j,ipoint,k,l,m integer :: i,j,ipoint,k,l,m
double precision :: weight,accu_relat, accu_abs, contrib double precision :: weight,accu_relat, accu_abs, contrib
@ -460,8 +422,8 @@ subroutine routine_int2_u_grad1u_x_j1b2
do i = 1, ao_num do i = 1, ao_num
do j = 1, ao_num do j = 1, ao_num
do m = 1, 3 do m = 1, 3
array(j,i,l,k) += int2_u_grad1u_x_j1b2_test(j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight array(j,i,l,k) += int2_u_grad1u_x_env2_test(j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight
array_ref(j,i,l,k) += int2_u_grad1u_x_j1b2 (j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight array_ref(j,i,l,k) += int2_u_grad1u_x_env2 (j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight
enddo enddo
enddo enddo
enddo enddo
@ -485,7 +447,7 @@ subroutine routine_int2_u_grad1u_x_j1b2
enddo enddo
print*,'******' print*,'******'
print*,'******' print*,'******'
print*,'routine_int2_u_grad1u_x_j1b2' print*,'routine_int2_u_grad1u_x_env2'
print*,'accu_abs = ',accu_abs/dble(ao_num)**4 print*,'accu_abs = ',accu_abs/dble(ao_num)**4
print*,'accu_relat = ',accu_relat/dble(ao_num)**4 print*,'accu_relat = ',accu_relat/dble(ao_num)**4
@ -493,7 +455,7 @@ subroutine routine_int2_u_grad1u_x_j1b2
end end
subroutine routine_v_ij_u_cst_mu_j1b subroutine routine_v_ij_u_cst_mu_env
implicit none implicit none
integer :: i,j,ipoint,k,l integer :: i,j,ipoint,k,l
double precision :: weight,accu_relat, accu_abs, contrib double precision :: weight,accu_relat, accu_abs, contrib
@ -509,8 +471,8 @@ subroutine routine_v_ij_u_cst_mu_j1b
do l = 1, ao_num do l = 1, ao_num
do i = 1, ao_num do i = 1, ao_num
do j = 1, ao_num do j = 1, ao_num
array(j,i,l,k) += v_ij_u_cst_mu_j1b_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight array(j,i,l,k) += v_ij_u_cst_mu_env_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
array_ref(j,i,l,k) += v_ij_u_cst_mu_j1b_fit (j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight array_ref(j,i,l,k) += v_ij_u_cst_mu_env_fit (j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
enddo enddo
enddo enddo
enddo enddo
@ -533,7 +495,7 @@ subroutine routine_v_ij_u_cst_mu_j1b
enddo enddo
print*,'******' print*,'******'
print*,'******' print*,'******'
print*,'routine_v_ij_u_cst_mu_j1b' print*,'routine_v_ij_u_cst_mu_env'
print*,'accu_abs = ',accu_abs/dble(ao_num)**4 print*,'accu_abs = ',accu_abs/dble(ao_num)**4
print*,'accu_relat = ',accu_relat/dble(ao_num)**4 print*,'accu_relat = ',accu_relat/dble(ao_num)**4
@ -674,66 +636,10 @@ subroutine test_fock_3e_uhf_mo()
! --- ! ---
end subroutine test_fock_3e_uhf_mo end
! --- ! ---
subroutine test_total_grad_lapl
implicit none
integer :: i,j,ipoint,k,l
double precision :: weight,accu_relat, accu_abs, contrib
accu_relat = 0.d0
accu_abs = 0.d0
do k = 1, ao_num
do l = 1, ao_num
do i = 1, ao_num
do j = 1, ao_num
contrib = dabs(tc_grad_and_lapl_ao_test(j,i,l,k) - tc_grad_and_lapl_ao(j,i,l,k))
accu_abs += contrib
if(dabs(tc_grad_and_lapl_ao(j,i,l,k)).gt.1.d-10)then
accu_relat += contrib/dabs(tc_grad_and_lapl_ao(j,i,l,k))
endif
enddo
enddo
enddo
enddo
print*,'******'
print*,'******'
print*,' test_total_grad_lapl'
print*,'accu_abs = ',accu_abs/dble(ao_num)**4
print*,'accu_relat = ',accu_relat/dble(ao_num)**4
end
subroutine test_total_grad_square
implicit none
integer :: i,j,ipoint,k,l
double precision :: weight,accu_relat, accu_abs, contrib
accu_relat = 0.d0
accu_abs = 0.d0
do k = 1, ao_num
do l = 1, ao_num
do i = 1, ao_num
do j = 1, ao_num
contrib = dabs(tc_grad_square_ao_test(j,i,l,k) - tc_grad_square_ao(j,i,l,k))
accu_abs += contrib
if(dabs(tc_grad_square_ao(j,i,l,k)).gt.1.d-10)then
accu_relat += contrib/dabs(tc_grad_square_ao(j,i,l,k))
endif
enddo
enddo
enddo
enddo
print*,'******'
print*,'******'
print*,'test_total_grad_square'
print*,'accu_abs = ',accu_abs/dble(ao_num)**4
print*,'accu_relat = ',accu_relat/dble(ao_num)**4
end
subroutine test_grid_points_ao subroutine test_grid_points_ao
implicit none implicit none
integer :: i,j,ipoint,icount,icount_good, icount_bad,icount_full integer :: i,j,ipoint,icount,icount_good, icount_bad,icount_full
@ -748,26 +654,26 @@ subroutine test_grid_points_ao
icount_bad = 0 icount_bad = 0
icount_full = 0 icount_full = 0
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
! if(dabs(int2_u_grad1u_x_j1b2_test(j,i,ipoint,1)) & ! if(dabs(int2_u_grad1u_x_env2_test(j,i,ipoint,1)) &
! + dabs(int2_u_grad1u_x_j1b2_test(j,i,ipoint,2)) & ! + dabs(int2_u_grad1u_x_env2_test(j,i,ipoint,2)) &
! + dabs(int2_u_grad1u_x_j1b2_test(j,i,ipoint,3)) ) ! + dabs(int2_u_grad1u_x_env2_test(j,i,ipoint,3)) )
! if(dabs(int2_u2_j1b2_test(j,i,ipoint)).gt.thr)then ! if(dabs(int2_u2_env2_test(j,i,ipoint)).gt.thr)then
! icount += 1 ! icount += 1
! endif ! endif
if(dabs(v_ij_u_cst_mu_j1b_ng_1_test(j,i,ipoint)).gt.thr*0.1d0)then if(dabs(v_ij_u_cst_mu_env_ng_1_test(j,i,ipoint)).gt.thr*0.1d0)then
icount_full += 1 icount_full += 1
endif endif
if(dabs(v_ij_u_cst_mu_j1b_test(j,i,ipoint)).gt.thr)then if(dabs(v_ij_u_cst_mu_env_test(j,i,ipoint)).gt.thr)then
icount += 1 icount += 1
if(dabs(v_ij_u_cst_mu_j1b_ng_1_test(j,i,ipoint)).gt.thr*0.1d0)then if(dabs(v_ij_u_cst_mu_env_ng_1_test(j,i,ipoint)).gt.thr*0.1d0)then
icount_good += 1 icount_good += 1
else else
print*,j,i,ipoint print*,j,i,ipoint
print*,dabs(v_ij_u_cst_mu_j1b_test(j,i,ipoint)),dabs(v_ij_u_cst_mu_j1b_ng_1_test(j,i,ipoint)),dabs(v_ij_u_cst_mu_j1b_ng_1_test(j,i,ipoint))/dabs(v_ij_u_cst_mu_j1b_test(j,i,ipoint)) print*,dabs(v_ij_u_cst_mu_env_test(j,i,ipoint)), dabs(v_ij_u_cst_mu_env_ng_1_test(j,i,ipoint)),dabs(v_ij_u_cst_mu_env_ng_1_test(j,i,ipoint))/dabs(v_ij_u_cst_mu_env_test(j,i,ipoint))
icount_bad += 1 icount_bad += 1
endif endif
endif endif
! if(dabs(v_ij_u_cst_mu_j1b_ng_1_test(j,i,ipoint)).gt.thr)then ! if(dabs(v_ij_u_cst_mu_env_ng_1_test(j,i,ipoint)).gt.thr)then
! endif ! endif
enddo enddo
print*,'' print*,''
@ -822,90 +728,6 @@ end
! --- ! ---
subroutine test_tc_grad_and_lapl_ao()
implicit none
integer :: i, j, k, l
double precision :: diff_tot, diff, thr_ih, norm
thr_ih = 1d-10
PROVIDE tc_grad_and_lapl_ao tc_grad_and_lapl_ao_loop
norm = 0.d0
diff_tot = 0.d0
do i = 1, ao_num
do j = 1, ao_num
do k = 1, ao_num
do l = 1, ao_num
diff = dabs(tc_grad_and_lapl_ao_loop(l,k,j,i) - tc_grad_and_lapl_ao(l,k,j,i))
if(diff .gt. thr_ih) then
print *, ' difference on ', l, k, j, i
print *, ' loops : ', tc_grad_and_lapl_ao_loop(l,k,j,i)
print *, ' lapack: ', tc_grad_and_lapl_ao (l,k,j,i)
!stop
endif
norm += dabs(tc_grad_and_lapl_ao_loop(l,k,j,i))
diff_tot += diff
enddo
enddo
enddo
enddo
print *, ' diff tot = ', diff_tot / norm
print *, ' norm = ', norm
print *, ' '
return
end
! ---
subroutine test_tc_grad_square_ao()
implicit none
integer :: i, j, k, l
double precision :: diff_tot, diff, thr_ih, norm
thr_ih = 1d-10
PROVIDE tc_grad_square_ao tc_grad_square_ao_loop
norm = 0.d0
diff_tot = 0.d0
do i = 1, ao_num
do j = 1, ao_num
do k = 1, ao_num
do l = 1, ao_num
diff = dabs(tc_grad_square_ao_loop(l,k,j,i) - tc_grad_square_ao(l,k,j,i))
if(diff .gt. thr_ih) then
print *, ' difference on ', l, k, j, i
print *, ' loops : ', tc_grad_square_ao_loop(l,k,j,i)
print *, ' lapack: ', tc_grad_square_ao (l,k,j,i)
!stop
endif
norm += dabs(tc_grad_square_ao_loop(l,k,j,i))
diff_tot += diff
enddo
enddo
enddo
enddo
print *, ' diff tot = ', diff_tot / norm
print *, ' norm = ', norm
print *, ' '
return
end
! ---
subroutine test_two_e_tc_non_hermit_integral() subroutine test_two_e_tc_non_hermit_integral()
implicit none implicit none
@ -973,88 +795,6 @@ end
! --- ! ---
subroutine test_tc_grad_square_ao_test()
implicit none
integer :: i, j, k, l
double precision :: diff_tot, diff, thr_ih, norm
print*, ' test_tc_grad_square_ao_test '
thr_ih = 1d-7
PROVIDE tc_grad_square_ao_test tc_grad_square_ao_test_ref
norm = 0.d0
diff_tot = 0.d0
do i = 1, ao_num
do j = 1, ao_num
do k = 1, ao_num
do l = 1, ao_num
diff = dabs(tc_grad_square_ao_test(l,k,j,i) - tc_grad_square_ao_test_ref(l,k,j,i))
if(diff .gt. thr_ih) then
print *, ' difference on ', l, k, j, i
print *, ' new : ', tc_grad_square_ao_test (l,k,j,i)
print *, ' ref : ', tc_grad_square_ao_test_ref(l,k,j,i)
!stop
endif
norm += dabs(tc_grad_square_ao_test_ref(l,k,j,i))
diff_tot += diff
enddo
enddo
enddo
enddo
print *, ' diff tot = ', diff_tot / norm
print *, ' norm = ', norm
print *, ' '
return
end
! ---
subroutine test_old_ints
implicit none
integer :: i,j,k,l
double precision :: old, new, contrib, get_ao_tc_sym_two_e_pot
double precision :: integral_sym , integral_nsym,accu
PROVIDE ao_tc_sym_two_e_pot_in_map
accu = 0.d0
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)
! old = integral_sym + integral_nsym
! old = 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)
new = ao_tc_int_chemist_test(k,i,l,j)
old = ao_tc_int_chemist_no_cycle(k,i,l,j)
contrib = dabs(old - new)
if(contrib.gt.1.d-6)then
print*,'problem !!'
print*,i,j,k,l
print*,old, new, contrib
endif
accu += contrib
enddo
enddo
enddo
enddo
print*,'******'
print*,'******'
print*,'in test_old_ints'
print*,'accu = ',accu/dble(ao_num**4)
end
subroutine test_int2_grad1_u12_ao_test subroutine test_int2_grad1_u12_ao_test
implicit none implicit none
integer :: i,j,ipoint,m,k,l integer :: i,j,ipoint,m,k,l
@ -1146,7 +886,7 @@ subroutine test_fock_3e_uhf_mo_cs()
print *, ' diff tot (%) = ', 100.d0 * diff_tot / norm print *, ' diff tot (%) = ', 100.d0 * diff_tot / norm
return return
end subroutine test_fock_3e_uhf_mo_cs end
! --- ! ---
@ -1185,7 +925,7 @@ subroutine test_fock_3e_uhf_mo_a()
print *, ' diff tot (%) = ', 100.d0 * diff_tot / norm print *, ' diff tot (%) = ', 100.d0 * diff_tot / norm
return return
end subroutine test_fock_3e_uhf_mo_a end
! --- ! ---
@ -1224,7 +964,7 @@ subroutine test_fock_3e_uhf_mo_b()
print *, ' diff tot (%) = ', 100.d0 * diff_tot / norm print *, ' diff tot (%) = ', 100.d0 * diff_tot / norm
return return
end subroutine test_fock_3e_uhf_mo_b end
! --- ! ---

2
src/dav_general_mat/dav_ext_rout_nonsym_B1space.irp.f
View File

@ -346,7 +346,7 @@ subroutine davidson_general_ext_rout_nonsym_b1space(u_in, H_jj, energies, sze, N
endif endif
if(i_omax(l) .ne. l) then if(i_omax(l) .ne. l) then
print *, ' !!! WARNONG !!!' print *, ' !!! WARNING !!!'
print *, ' index of state', l, i_omax(l) print *, ' index of state', l, i_omax(l)
endif endif
enddo enddo

4
src/dft_utils_in_r/ao_prod_mlti_pl.irp.f
View File

@ -149,7 +149,3 @@ BEGIN_PROVIDER [ double precision, ao_prod_dist_grid, (ao_num, ao_num, n_points_
END_PROVIDER END_PROVIDER
!BEGIN_PROVIDER [ double precision, ao_abs_prod_j1b, (ao_num, ao_num)]
! implicit none
!
!END_PROVIDER

1
src/hamiltonian/EZFIO.cfg
View File

@ -5,4 +5,3 @@ interface: ezfio,provider,ocaml
default: 0.5 default: 0.5
ezfio_name: mu_erf ezfio_name: mu_erf

2
src/hamiltonian/NEED
View File

@ -0,0 +1,2 @@
ezfio_files
nuclei

114
src/hartree_fock/print_scf_int.irp.f Normal file
View File

@ -0,0 +1,114 @@
program print_scf_int
call main()
end
subroutine main()
implicit none
integer :: i, j, k, l
print *, " Hcore:"
do j = 1, ao_num
do i = 1, ao_num
print *, i, j, ao_one_e_integrals(i,j)
enddo
enddo
print *, " P:"
do j = 1, ao_num
do i = 1, ao_num
print *, i, j, SCF_density_matrix_ao_alpha(i,j)
enddo
enddo
double precision :: integ, density_a, density_b, density
double precision :: J_scf(ao_num, ao_num)
double precision :: K_scf(ao_num, ao_num)
double precision, external :: get_ao_two_e_integral
PROVIDE ao_integrals_map
print *, " J:"
!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 >
! print *, '< k l | i j >', k, l, i, j
! print *, get_ao_two_e_integral(i, j, k, l, ao_integrals_map)
! enddo
! enddo
! enddo
!enddo
!do k = 1, ao_num
! do i = 1, ao_num
! do j = 1, ao_num
! do l = 1, ao_num
! ! ( 1:k, 1:i | 2:l, 2:j )
! print *, '(k i | l j)', k, i, l, j
! print *, get_ao_two_e_integral(l, j, k, i, ao_integrals_map)
! enddo
! enddo
! print *, ''
! enddo
!enddo
J_scf = 0.d0
K_scf = 0.d0
do i = 1, ao_num
do k = 1, ao_num
do j = 1, ao_num
do l = 1, ao_num
density_a = SCF_density_matrix_ao_alpha(l,j)
density_b = SCF_density_matrix_ao_beta (l,j)
density = density_a + density_b
integ = get_ao_two_e_integral(l, j, k, i, ao_integrals_map)
J_scf(k,i) += density * integ
integ = get_ao_two_e_integral(l, i, k, j, ao_integrals_map)
K_scf(k,i) -= density_a * integ
enddo
enddo
enddo
enddo
print *, 'J x P'
do i = 1, ao_num
do k = 1, ao_num
print *, k, i, J_scf(k,i)
enddo
enddo
print *, ''
print *, 'K x P'
do i = 1, ao_num
do k = 1, ao_num
print *, k, i, K_scf(k,i)
enddo
enddo
print *, ''
print *, 'F in AO'
do i = 1, ao_num
do k = 1, ao_num
print *, k, i, Fock_matrix_ao(k,i)
enddo
enddo
print *, ''
print *, 'F in MO'
do i = 1, ao_num
do k = 1, ao_num
print *, k, i, 2.d0 * Fock_matrix_mo_alpha(k,i)
enddo
enddo
end

59
src/utils/util.irp.f
View File

@ -579,5 +579,64 @@ logical function is_same_spin(sigma_1, sigma_2)
end function is_same_spin end function is_same_spin
! --- ! ---
function Kronecker_delta(i, j) result(delta)
BEGIN_DOC
! Kronecker Delta
END_DOC
implicit none
integer, intent(in) :: i, j
double precision :: delta
if(i == j) then
delta = 1.d0
else
delta = 0.d0
endif
end function Kronecker_delta
! ---
subroutine diagonalize_sym_matrix(N, A, e)
BEGIN_DOC
!
! Diagonalize a symmetric matrix
!
END_DOC
implicit none
integer, intent(in) :: N
double precision, intent(inout) :: A(N,N)
double precision, intent(out) :: e(N)
integer :: lwork, info
double precision, allocatable :: work(:)
allocate(work(1))
lwork = -1
call dsyev('V', 'U', N, A, N, e, work, lwork, info)
lwork = int(work(1))
deallocate(work)
allocate(work(lwork))
call dsyev('V', 'U', N, A, N, e, work, lwork, info)
deallocate(work)
if(info /= 0) then
print*,'Problem in diagonalize_sym_matrix (dsyev)!!'
endif
end subroutine diagonalize_sym_matrix
! ---