mirror of
https://github.com/QuantumPackage/qp2.git
synced 2024-08-29 04:12:00 +02:00
Merge branch 'dev-stable-tc-scf' into dev-stable
This commit is contained in:
commit
518001ebbd
@ -12,21 +12,21 @@ double precision function ao_value(i,r)
|
|||||||
integer :: power_ao(3)
|
integer :: power_ao(3)
|
||||||
double precision :: accu,dx,dy,dz,r2
|
double precision :: accu,dx,dy,dz,r2
|
||||||
num_ao = ao_nucl(i)
|
num_ao = ao_nucl(i)
|
||||||
! power_ao(1:3)= ao_power(i,1:3)
|
power_ao(1:3)= ao_power(i,1:3)
|
||||||
! center_ao(1:3) = nucl_coord(num_ao,1:3)
|
center_ao(1:3) = nucl_coord(num_ao,1:3)
|
||||||
! dx = (r(1) - center_ao(1))
|
dx = (r(1) - center_ao(1))
|
||||||
! dy = (r(2) - center_ao(2))
|
dy = (r(2) - center_ao(2))
|
||||||
! dz = (r(3) - center_ao(3))
|
dz = (r(3) - center_ao(3))
|
||||||
! r2 = dx*dx + dy*dy + dz*dz
|
r2 = dx*dx + dy*dy + dz*dz
|
||||||
! dx = dx**power_ao(1)
|
dx = dx**power_ao(1)
|
||||||
! dy = dy**power_ao(2)
|
dy = dy**power_ao(2)
|
||||||
! dz = dz**power_ao(3)
|
dz = dz**power_ao(3)
|
||||||
|
|
||||||
accu = 0.d0
|
accu = 0.d0
|
||||||
! 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)
|
||||||
! accu += ao_coef_normalized_ordered_transp(m,i) * dexp(-beta*r2)
|
accu += ao_coef_normalized_ordered_transp(m,i) * dexp(-beta*r2)
|
||||||
! enddo
|
enddo
|
||||||
ao_value = accu * dx * dy * dz
|
ao_value = accu * dx * dy * dz
|
||||||
|
|
||||||
end
|
end
|
||||||
|
@ -3,3 +3,4 @@ ao_two_e_ints
|
|||||||
becke_numerical_grid
|
becke_numerical_grid
|
||||||
mo_one_e_ints
|
mo_one_e_ints
|
||||||
dft_utils_in_r
|
dft_utils_in_r
|
||||||
|
tc_keywords
|
||||||
|
@ -1,4 +1,72 @@
|
|||||||
|
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2, (ao_num, ao_num, n_points_final_grid)]
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
!
|
||||||
|
! -\frac{1}{4} x int dr2 phi_i(r2) phi_j(r2) [1 - erf(mu r12)]^2
|
||||||
|
!
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer :: i, j, ipoint, i_fit
|
||||||
|
double precision :: r(3), expo_fit, coef_fit
|
||||||
|
double precision :: tmp
|
||||||
|
double precision :: wall0, wall1
|
||||||
|
|
||||||
|
double precision, external :: overlap_gauss_r12_ao
|
||||||
|
|
||||||
|
print*, ' providing int2_grad1u2_grad2u2 ...'
|
||||||
|
call wall_time(wall0)
|
||||||
|
|
||||||
|
provide mu_erf final_grid_points j1b_pen
|
||||||
|
|
||||||
|
int2_grad1u2_grad2u2 = 0.d0
|
||||||
|
|
||||||
|
!$OMP PARALLEL DEFAULT (NONE) &
|
||||||
|
!$OMP PRIVATE (ipoint, i, j, i_fit, r, coef_fit, expo_fit, tmp) &
|
||||||
|
!$OMP SHARED (n_points_final_grid, ao_num, final_grid_points, ng_fit_jast, &
|
||||||
|
!$OMP expo_gauss_1_erf_x_2, coef_gauss_1_erf_x_2,int2_grad1u2_grad2u2)
|
||||||
|
!$OMP DO
|
||||||
|
do ipoint = 1, n_points_final_grid
|
||||||
|
r(1) = final_grid_points(1,ipoint)
|
||||||
|
r(2) = final_grid_points(2,ipoint)
|
||||||
|
r(3) = final_grid_points(3,ipoint)
|
||||||
|
|
||||||
|
do i = 1, ao_num
|
||||||
|
do j = i, ao_num
|
||||||
|
|
||||||
|
tmp = 0.d0
|
||||||
|
do i_fit = 1, ng_fit_jast
|
||||||
|
|
||||||
|
expo_fit = expo_gauss_1_erf_x_2(i_fit)
|
||||||
|
coef_fit = coef_gauss_1_erf_x_2(i_fit)
|
||||||
|
|
||||||
|
tmp += -0.25d0 * coef_fit * overlap_gauss_r12_ao(r, expo_fit, i, j)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
int2_grad1u2_grad2u2(j,i,ipoint) = tmp
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
!$OMP END DO
|
||||||
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
|
do ipoint = 1, n_points_final_grid
|
||||||
|
do i = 2, ao_num
|
||||||
|
do j = 1, i-1
|
||||||
|
int2_grad1u2_grad2u2(j,i,ipoint) = int2_grad1u2_grad2u2(i,j,ipoint)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
call wall_time(wall1)
|
||||||
|
print*, ' wall time for int2_grad1u2_grad2u2 =', wall1 - wall0
|
||||||
|
|
||||||
|
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_j1b2, (ao_num, ao_num, n_points_final_grid)]
|
||||||
@ -26,15 +94,15 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2, (ao_num, ao_num, n
|
|||||||
|
|
||||||
int2_grad1u2_grad2u2_j1b2 = 0.d0
|
int2_grad1u2_grad2u2_j1b2 = 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_all_comb_b3_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_all_comb_b3_coef, List_all_comb_b3_expo, &
|
||||||
!$OMP List_all_comb_b3_cent, int2_grad1u2_grad2u2_j1b2)
|
!$OMP List_all_comb_b3_cent, int2_grad1u2_grad2u2_j1b2)
|
||||||
!$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)
|
||||||
r(2) = final_grid_points(2,ipoint)
|
r(2) = final_grid_points(2,ipoint)
|
||||||
@ -53,7 +121,7 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2, (ao_num, ao_num, n
|
|||||||
|
|
||||||
int_fit = overlap_gauss_r12_ao(r, expo_fit, i, j)
|
int_fit = overlap_gauss_r12_ao(r, expo_fit, i, j)
|
||||||
tmp += -0.25d0 * coef_fit * int_fit
|
tmp += -0.25d0 * coef_fit * int_fit
|
||||||
! if(dabs(coef_fit*int_fit) .lt. 1d-12) cycle
|
! if(dabs(coef_fit*int_fit) .lt. 1d-12) cycle
|
||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
|
||||||
@ -78,8 +146,8 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2, (ao_num, ao_num, n
|
|||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
!$OMP END DO
|
!$OMP END DO
|
||||||
!$OMP END PARALLEL
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
do ipoint = 1, n_points_final_grid
|
do ipoint = 1, n_points_final_grid
|
||||||
do i = 2, ao_num
|
do i = 2, ao_num
|
||||||
@ -96,7 +164,7 @@ END_PROVIDER
|
|||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
|
||||||
BEGIN_PROVIDER [ double precision, int2_u2_j1b2, (ao_num, ao_num, n_points_final_grid)]
|
BEGIN_PROVIDER [double precision, int2_u2_j1b2, (ao_num, ao_num, n_points_final_grid)]
|
||||||
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
!
|
!
|
||||||
@ -120,15 +188,15 @@ BEGIN_PROVIDER [ double precision, int2_u2_j1b2, (ao_num, ao_num, n_points_final
|
|||||||
|
|
||||||
int2_u2_j1b2 = 0.d0
|
int2_u2_j1b2 = 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_all_comb_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_all_comb_b3_coef, List_all_comb_b3_expo, &
|
!$OMP List_all_comb_b3_coef, List_all_comb_b3_expo, &
|
||||||
!$OMP List_all_comb_b3_cent, int2_u2_j1b2)
|
!$OMP List_all_comb_b3_cent, int2_u2_j1b2)
|
||||||
!$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)
|
||||||
r(2) = final_grid_points(2,ipoint)
|
r(2) = final_grid_points(2,ipoint)
|
||||||
@ -147,7 +215,7 @@ BEGIN_PROVIDER [ double precision, int2_u2_j1b2, (ao_num, ao_num, n_points_final
|
|||||||
|
|
||||||
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
|
||||||
! if(dabs(coef_fit*int_fit) .lt. 1d-12) cycle
|
! if(dabs(coef_fit*int_fit) .lt. 1d-12) cycle
|
||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
|
||||||
@ -172,8 +240,8 @@ BEGIN_PROVIDER [ double precision, int2_u2_j1b2, (ao_num, ao_num, n_points_final
|
|||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
!$OMP END DO
|
!$OMP END DO
|
||||||
!$OMP END PARALLEL
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
do ipoint = 1, n_points_final_grid
|
do ipoint = 1, n_points_final_grid
|
||||||
do i = 2, ao_num
|
do i = 2, ao_num
|
||||||
|
@ -24,12 +24,12 @@ BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_po
|
|||||||
|
|
||||||
v_ij_erf_rk_cst_mu_j1b = 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_all_comb_b2_size, final_grid_points, &
|
||||||
!$OMP List_all_comb_b2_coef, List_all_comb_b2_expo, List_all_comb_b2_cent, &
|
!$OMP List_all_comb_b2_coef, List_all_comb_b2_expo, List_all_comb_b2_cent, &
|
||||||
!$OMP v_ij_erf_rk_cst_mu_j1b, mu_erf)
|
!$OMP v_ij_erf_rk_cst_mu_j1b, 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
|
||||||
r(1) = final_grid_points(1,ipoint)
|
r(1) = final_grid_points(1,ipoint)
|
||||||
@ -51,7 +51,7 @@ BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_po
|
|||||||
|
|
||||||
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
|
! if(dabs(coef)*dabs(int_mu - int_coulomb) .lt. 1d-12) cycle
|
||||||
|
|
||||||
tmp += coef * (int_mu - int_coulomb)
|
tmp += coef * (int_mu - int_coulomb)
|
||||||
|
|
||||||
@ -77,8 +77,8 @@ BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_po
|
|||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
!$OMP END DO
|
!$OMP END DO
|
||||||
!$OMP END PARALLEL
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
do ipoint = 1, n_points_final_grid
|
do ipoint = 1, n_points_final_grid
|
||||||
do i = 2, ao_num
|
do i = 2, ao_num
|
||||||
@ -112,13 +112,13 @@ 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 = 0.d0
|
x_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, 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_all_comb_b2_size, final_grid_points,&
|
||||||
!$OMP List_all_comb_b2_coef, List_all_comb_b2_expo, List_all_comb_b2_cent, &
|
!$OMP List_all_comb_b2_coef, List_all_comb_b2_expo, List_all_comb_b2_cent, &
|
||||||
!$OMP x_v_ij_erf_rk_cst_mu_j1b, mu_erf)
|
!$OMP x_v_ij_erf_rk_cst_mu_j1b, 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
|
||||||
r(1) = final_grid_points(1,ipoint)
|
r(1) = final_grid_points(1,ipoint)
|
||||||
@ -143,7 +143,7 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_
|
|||||||
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)
|
||||||
|
|
||||||
! if( dabs(coef)*(dabs(ints(1)-ints_coulomb(1)) + dabs(ints(2)-ints_coulomb(2)) + dabs(ints(3)-ints_coulomb(3))) .lt. 3d-10) cycle
|
! if( dabs(coef)*(dabs(ints(1)-ints_coulomb(1)) + dabs(ints(2)-ints_coulomb(2)) + dabs(ints(3)-ints_coulomb(3))) .lt. 3d-10) cycle
|
||||||
|
|
||||||
tmp_x += coef * (ints(1) - ints_coulomb(1))
|
tmp_x += coef * (ints(1) - ints_coulomb(1))
|
||||||
tmp_y += coef * (ints(2) - ints_coulomb(2))
|
tmp_y += coef * (ints(2) - ints_coulomb(2))
|
||||||
@ -175,8 +175,8 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_
|
|||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
!$OMP END DO
|
!$OMP END DO
|
||||||
!$OMP END PARALLEL
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
do ipoint = 1, n_points_final_grid
|
do ipoint = 1, n_points_final_grid
|
||||||
do i = 2, ao_num
|
do i = 2, ao_num
|
||||||
@ -220,15 +220,15 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b, (ao_num, ao_num, n_points_
|
|||||||
|
|
||||||
v_ij_u_cst_mu_j1b = 0.d0
|
v_ij_u_cst_mu_j1b = 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_all_comb_b2_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_all_comb_b2_coef, List_all_comb_b2_expo, &
|
||||||
!$OMP List_all_comb_b2_cent, v_ij_u_cst_mu_j1b)
|
!$OMP List_all_comb_b2_cent, v_ij_u_cst_mu_j1b)
|
||||||
!$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
|
||||||
r(1) = final_grid_points(1,ipoint)
|
r(1) = final_grid_points(1,ipoint)
|
||||||
@ -253,7 +253,7 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b, (ao_num, ao_num, n_points_
|
|||||||
B_center(3) = List_all_comb_b2_cent(3,1)
|
B_center(3) = List_all_comb_b2_cent(3,1)
|
||||||
|
|
||||||
int_fit = overlap_gauss_r12_ao_with1s(B_center, beta, r, expo_fit, i, j)
|
int_fit = overlap_gauss_r12_ao_with1s(B_center, beta, r, expo_fit, i, j)
|
||||||
! if(dabs(int_fit*coef) .lt. 1d-12) cycle
|
! if(dabs(int_fit*coef) .lt. 1d-12) cycle
|
||||||
|
|
||||||
tmp += coef * coef_fit * int_fit
|
tmp += coef * coef_fit * int_fit
|
||||||
|
|
||||||
@ -280,8 +280,8 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b, (ao_num, ao_num, n_points_
|
|||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
!$OMP END DO
|
!$OMP END DO
|
||||||
!$OMP END PARALLEL
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
do ipoint = 1, n_points_final_grid
|
do ipoint = 1, n_points_final_grid
|
||||||
do i = 2, ao_num
|
do i = 2, ao_num
|
||||||
|
@ -1,17 +1,34 @@
|
|||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
|
||||||
BEGIN_PROVIDER [ integer, List_all_comb_b2_size]
|
BEGIN_PROVIDER [integer, List_all_comb_b2_size]
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
|
|
||||||
List_all_comb_b2_size = 2**nucl_num
|
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
|
END_PROVIDER
|
||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
|
||||||
BEGIN_PROVIDER [ integer, List_all_comb_b2, (nucl_num, List_all_comb_b2_size)]
|
BEGIN_PROVIDER [integer, List_all_comb_b2, (nucl_num, List_all_comb_b2_size)]
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
integer :: i, j
|
integer :: i, j
|
||||||
@ -50,57 +67,79 @@ END_PROVIDER
|
|||||||
List_all_comb_b2_expo = 0.d0
|
List_all_comb_b2_expo = 0.d0
|
||||||
List_all_comb_b2_cent = 0.d0
|
List_all_comb_b2_cent = 0.d0
|
||||||
|
|
||||||
do i = 1, List_all_comb_b2_size
|
if((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then
|
||||||
|
|
||||||
tmp_cent_x = 0.d0
|
do i = 1, List_all_comb_b2_size
|
||||||
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
|
tmp_cent_x = 0.d0
|
||||||
|
tmp_cent_y = 0.d0
|
||||||
List_all_comb_b2_cent(1,i) = tmp_cent_x / List_all_comb_b2_expo(i)
|
tmp_cent_z = 0.d0
|
||||||
List_all_comb_b2_cent(2,i) = tmp_cent_y / List_all_comb_b2_expo(i)
|
do j = 1, nucl_num
|
||||||
List_all_comb_b2_cent(3,i) = tmp_cent_z / List_all_comb_b2_expo(i)
|
tmp_alphaj = dble(List_all_comb_b2(j,i)) * j1b_pen(j)
|
||||||
enddo
|
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)
|
||||||
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_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
|
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)
|
do i = 1, List_all_comb_b2_size
|
||||||
enddo
|
|
||||||
|
|
||||||
! ---
|
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)
|
||||||
|
|
||||||
do i = 1, List_all_comb_b2_size
|
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
|
||||||
|
|
||||||
phase = 0
|
if(List_all_comb_b2_expo(i) .lt. 1d-10) cycle
|
||||||
do j = 1, nucl_num
|
|
||||||
phase += List_all_comb_b2(j,i)
|
List_all_comb_b2_coef(i) = List_all_comb_b2_coef(i) / List_all_comb_b2_expo(i)
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
List_all_comb_b2_coef(i) = (-1.d0)**dble(phase) * dexp(-List_all_comb_b2_coef(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
|
||||||
|
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'
|
!print *, ' coeff, expo & cent of list b2'
|
||||||
!do i = 1, List_all_comb_b2_size
|
!do i = 1, List_all_comb_b2_size
|
||||||
@ -115,14 +154,31 @@ END_PROVIDER
|
|||||||
BEGIN_PROVIDER [ integer, List_all_comb_b3_size]
|
BEGIN_PROVIDER [ integer, List_all_comb_b3_size]
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
|
double precision :: tmp
|
||||||
|
|
||||||
List_all_comb_b3_size = 3**nucl_num
|
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
|
END_PROVIDER
|
||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
|
||||||
BEGIN_PROVIDER [ integer, List_all_comb_b3, (nucl_num, List_all_comb_b3_size)]
|
BEGIN_PROVIDER [integer, List_all_comb_b3, (nucl_num, List_all_comb_b3_size)]
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
integer :: i, j, ii, jj
|
integer :: i, j, ii, jj
|
||||||
@ -162,7 +218,11 @@ END_PROVIDER
|
|||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
integer :: i, j, k, phase
|
integer :: i, j, k, phase
|
||||||
|
integer :: ii
|
||||||
double precision :: tmp_alphaj, tmp_alphak, facto
|
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
|
||||||
|
|
||||||
@ -170,60 +230,127 @@ END_PROVIDER
|
|||||||
List_all_comb_b3_expo = 0.d0
|
List_all_comb_b3_expo = 0.d0
|
||||||
List_all_comb_b3_cent = 0.d0
|
List_all_comb_b3_cent = 0.d0
|
||||||
|
|
||||||
do i = 1, List_all_comb_b3_size
|
if((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then
|
||||||
|
|
||||||
do j = 1, nucl_num
|
do i = 1, List_all_comb_b3_size
|
||||||
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)
|
|
||||||
|
|
||||||
|
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
|
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)
|
do i = 1, List_all_comb_b3_size
|
||||||
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 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)
|
||||||
|
|
||||||
do i = 1, List_all_comb_b3_size
|
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
|
||||||
|
|
||||||
do j = 2, nucl_num, 1
|
if(List_all_comb_b3_expo(i) .lt. 1d-10) cycle
|
||||||
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)) &
|
List_all_comb_b3_coef(i) = List_all_comb_b3_coef(i) / List_all_comb_b3_expo(i)
|
||||||
+ (nucl_coord(j,2) - nucl_coord(k,2)) * (nucl_coord(j,2) - nucl_coord(k,2)) &
|
enddo
|
||||||
+ (nucl_coord(j,3) - nucl_coord(k,3)) * (nucl_coord(j,3) - nucl_coord(k,3)) )
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
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
|
||||||
|
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
|
||||||
|
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)
|
||||||
|
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
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
if(List_all_comb_b3_expo(i) .lt. 1d-10) cycle
|
else
|
||||||
|
|
||||||
List_all_comb_b3_coef(i) = List_all_comb_b3_coef(i) / List_all_comb_b3_expo(i)
|
print *, 'j1b_type = ', j1b_type, 'is not implemented'
|
||||||
enddo
|
stop
|
||||||
|
|
||||||
! ---
|
endif
|
||||||
|
|
||||||
do i = 1, List_all_comb_b3_size
|
|
||||||
|
|
||||||
facto = 1.d0
|
|
||||||
phase = 0
|
|
||||||
do j = 1, nucl_num
|
|
||||||
tmp_alphaj = dble(List_all_comb_b3(j,i))
|
|
||||||
|
|
||||||
facto *= 2.d0 / (gamma(tmp_alphaj+1.d0) * gamma(3.d0-tmp_alphaj))
|
|
||||||
phase += List_all_comb_b3(j,i)
|
|
||||||
enddo
|
|
||||||
|
|
||||||
List_all_comb_b3_coef(i) = (-1.d0)**dble(phase) * facto * dexp(-List_all_comb_b3_coef(i))
|
|
||||||
enddo
|
|
||||||
|
|
||||||
!print *, ' coeff, expo & cent of list b3'
|
!print *, ' coeff, expo & cent of list b3'
|
||||||
!do i = 1, List_all_comb_b3_size
|
!do i = 1, List_all_comb_b3_size
|
||||||
|
@ -1,2 +1,3 @@
|
|||||||
ao_basis
|
ao_basis
|
||||||
pseudo
|
pseudo
|
||||||
|
cosgtos_ao_int
|
||||||
|
@ -1,75 +1,99 @@
|
|||||||
BEGIN_PROVIDER [ double precision, ao_overlap,(ao_num,ao_num) ]
|
|
||||||
&BEGIN_PROVIDER [ double precision, ao_overlap_x,(ao_num,ao_num) ]
|
! ---
|
||||||
&BEGIN_PROVIDER [ double precision, ao_overlap_y,(ao_num,ao_num) ]
|
|
||||||
&BEGIN_PROVIDER [ double precision, ao_overlap_z,(ao_num,ao_num) ]
|
BEGIN_PROVIDER [ double precision, ao_overlap , (ao_num, ao_num) ]
|
||||||
implicit none
|
&BEGIN_PROVIDER [ double precision, ao_overlap_x, (ao_num, ao_num) ]
|
||||||
|
&BEGIN_PROVIDER [ double precision, ao_overlap_y, (ao_num, ao_num) ]
|
||||||
|
&BEGIN_PROVIDER [ double precision, ao_overlap_z, (ao_num, ao_num) ]
|
||||||
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Overlap between atomic basis functions:
|
! Overlap between atomic basis functions:
|
||||||
!
|
!
|
||||||
! :math:`\int \chi_i(r) \chi_j(r) dr`
|
! :math:`\int \chi_i(r) \chi_j(r) dr`
|
||||||
END_DOC
|
END_DOC
|
||||||
integer :: i,j,n,l
|
|
||||||
double precision :: f
|
implicit none
|
||||||
integer :: dim1
|
integer :: i, j, n, l, dim1, power_A(3), power_B(3)
|
||||||
double precision :: overlap, overlap_x, overlap_y, overlap_z
|
double precision :: overlap, overlap_x, overlap_y, overlap_z
|
||||||
double precision :: alpha, beta, c
|
double precision :: alpha, beta, c
|
||||||
double precision :: A_center(3), B_center(3)
|
double precision :: A_center(3), B_center(3)
|
||||||
integer :: power_A(3), power_B(3)
|
|
||||||
ao_overlap = 0.d0
|
ao_overlap = 0.d0
|
||||||
ao_overlap_x = 0.d0
|
ao_overlap_x = 0.d0
|
||||||
ao_overlap_y = 0.d0
|
ao_overlap_y = 0.d0
|
||||||
ao_overlap_z = 0.d0
|
ao_overlap_z = 0.d0
|
||||||
if (read_ao_integrals_overlap) then
|
|
||||||
call ezfio_get_ao_one_e_ints_ao_integrals_overlap(ao_overlap(1:ao_num, 1:ao_num))
|
if(read_ao_integrals_overlap) then
|
||||||
print *, 'AO overlap integrals read from disk'
|
|
||||||
|
call ezfio_get_ao_one_e_ints_ao_integrals_overlap(ao_overlap(1:ao_num, 1:ao_num))
|
||||||
|
print *, 'AO overlap integrals read from disk'
|
||||||
|
|
||||||
else
|
else
|
||||||
|
|
||||||
dim1=100
|
if(use_cosgtos) then
|
||||||
!$OMP PARALLEL DO SCHEDULE(GUIDED) &
|
!print*, ' use_cosgtos for ao_overlap ?', use_cosgtos
|
||||||
!$OMP DEFAULT(NONE) &
|
|
||||||
!$OMP PRIVATE(A_center,B_center,power_A,power_B,&
|
do j = 1, ao_num
|
||||||
!$OMP overlap_x,overlap_y, overlap_z, overlap, &
|
do i = 1, ao_num
|
||||||
!$OMP alpha, beta,i,j,c) &
|
ao_overlap (i,j) = ao_overlap_cosgtos (i,j)
|
||||||
!$OMP SHARED(nucl_coord,ao_power,ao_prim_num, &
|
ao_overlap_x(i,j) = ao_overlap_cosgtos_x(i,j)
|
||||||
!$OMP ao_overlap_x,ao_overlap_y,ao_overlap_z,ao_overlap,ao_num,ao_coef_normalized_ordered_transp,ao_nucl, &
|
ao_overlap_y(i,j) = ao_overlap_cosgtos_y(i,j)
|
||||||
!$OMP ao_expo_ordered_transp,dim1)
|
ao_overlap_z(i,j) = ao_overlap_cosgtos_z(i,j)
|
||||||
do j=1,ao_num
|
enddo
|
||||||
A_center(1) = nucl_coord( ao_nucl(j), 1 )
|
enddo
|
||||||
A_center(2) = nucl_coord( ao_nucl(j), 2 )
|
|
||||||
A_center(3) = nucl_coord( ao_nucl(j), 3 )
|
else
|
||||||
power_A(1) = ao_power( j, 1 )
|
|
||||||
power_A(2) = ao_power( j, 2 )
|
dim1=100
|
||||||
power_A(3) = ao_power( j, 3 )
|
!$OMP PARALLEL DO SCHEDULE(GUIDED) &
|
||||||
do i= 1,ao_num
|
!$OMP DEFAULT(NONE) &
|
||||||
B_center(1) = nucl_coord( ao_nucl(i), 1 )
|
!$OMP PRIVATE(A_center,B_center,power_A,power_B,&
|
||||||
B_center(2) = nucl_coord( ao_nucl(i), 2 )
|
!$OMP overlap_x,overlap_y, overlap_z, overlap, &
|
||||||
B_center(3) = nucl_coord( ao_nucl(i), 3 )
|
!$OMP alpha, beta,i,j,c) &
|
||||||
power_B(1) = ao_power( i, 1 )
|
!$OMP SHARED(nucl_coord,ao_power,ao_prim_num, &
|
||||||
power_B(2) = ao_power( i, 2 )
|
!$OMP ao_overlap_x,ao_overlap_y,ao_overlap_z,ao_overlap,ao_num,ao_coef_normalized_ordered_transp,ao_nucl, &
|
||||||
power_B(3) = ao_power( i, 3 )
|
!$OMP ao_expo_ordered_transp,dim1)
|
||||||
do n = 1,ao_prim_num(j)
|
do j=1,ao_num
|
||||||
alpha = ao_expo_ordered_transp(n,j)
|
A_center(1) = nucl_coord( ao_nucl(j), 1 )
|
||||||
do l = 1, ao_prim_num(i)
|
A_center(2) = nucl_coord( ao_nucl(j), 2 )
|
||||||
beta = ao_expo_ordered_transp(l,i)
|
A_center(3) = nucl_coord( ao_nucl(j), 3 )
|
||||||
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x,overlap_y,overlap_z,overlap,dim1)
|
power_A(1) = ao_power( j, 1 )
|
||||||
c = ao_coef_normalized_ordered_transp(n,j) * ao_coef_normalized_ordered_transp(l,i)
|
power_A(2) = ao_power( j, 2 )
|
||||||
ao_overlap(i,j) += c * overlap
|
power_A(3) = ao_power( j, 3 )
|
||||||
if(isnan(ao_overlap(i,j)))then
|
do i= 1,ao_num
|
||||||
print*,'i,j',i,j
|
B_center(1) = nucl_coord( ao_nucl(i), 1 )
|
||||||
print*,'l,n',l,n
|
B_center(2) = nucl_coord( ao_nucl(i), 2 )
|
||||||
print*,'c,overlap',c,overlap
|
B_center(3) = nucl_coord( ao_nucl(i), 3 )
|
||||||
print*,overlap_x,overlap_y,overlap_z
|
power_B(1) = ao_power( i, 1 )
|
||||||
stop
|
power_B(2) = ao_power( i, 2 )
|
||||||
endif
|
power_B(3) = ao_power( i, 3 )
|
||||||
ao_overlap_x(i,j) += c * overlap_x
|
do n = 1,ao_prim_num(j)
|
||||||
ao_overlap_y(i,j) += c * overlap_y
|
alpha = ao_expo_ordered_transp(n,j)
|
||||||
ao_overlap_z(i,j) += c * overlap_z
|
do l = 1, ao_prim_num(i)
|
||||||
|
beta = ao_expo_ordered_transp(l,i)
|
||||||
|
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x,overlap_y,overlap_z,overlap,dim1)
|
||||||
|
c = ao_coef_normalized_ordered_transp(n,j) * ao_coef_normalized_ordered_transp(l,i)
|
||||||
|
ao_overlap(i,j) += c * overlap
|
||||||
|
if(isnan(ao_overlap(i,j)))then
|
||||||
|
print*,'i,j',i,j
|
||||||
|
print*,'l,n',l,n
|
||||||
|
print*,'c,overlap',c,overlap
|
||||||
|
print*,overlap_x,overlap_y,overlap_z
|
||||||
|
stop
|
||||||
|
endif
|
||||||
|
ao_overlap_x(i,j) += c * overlap_x
|
||||||
|
ao_overlap_y(i,j) += c * overlap_y
|
||||||
|
ao_overlap_z(i,j) += c * overlap_z
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
enddo
|
!$OMP END PARALLEL DO
|
||||||
enddo
|
|
||||||
!$OMP END PARALLEL DO
|
endif
|
||||||
|
|
||||||
endif
|
endif
|
||||||
|
|
||||||
if (write_ao_integrals_overlap) then
|
if (write_ao_integrals_overlap) then
|
||||||
call ezfio_set_ao_one_e_ints_ao_integrals_overlap(ao_overlap(1:ao_num, 1:ao_num))
|
call ezfio_set_ao_one_e_ints_ao_integrals_overlap(ao_overlap(1:ao_num, 1:ao_num))
|
||||||
print *, 'AO overlap integrals written to disk'
|
print *, 'AO overlap integrals written to disk'
|
||||||
@ -77,6 +101,8 @@
|
|||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
BEGIN_PROVIDER [ double precision, ao_overlap_imag, (ao_num, ao_num) ]
|
BEGIN_PROVIDER [ double precision, ao_overlap_imag, (ao_num, ao_num) ]
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
@ -85,6 +111,8 @@ BEGIN_PROVIDER [ double precision, ao_overlap_imag, (ao_num, ao_num) ]
|
|||||||
ao_overlap_imag = 0.d0
|
ao_overlap_imag = 0.d0
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
BEGIN_PROVIDER [ complex*16, ao_overlap_complex, (ao_num, ao_num) ]
|
BEGIN_PROVIDER [ complex*16, ao_overlap_complex, (ao_num, ao_num) ]
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
@ -98,41 +126,43 @@ BEGIN_PROVIDER [ complex*16, ao_overlap_complex, (ao_num, ao_num) ]
|
|||||||
enddo
|
enddo
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ double precision, ao_overlap_abs, (ao_num, ao_num) ]
|
||||||
|
|
||||||
|
|
||||||
BEGIN_PROVIDER [ double precision, ao_overlap_abs,(ao_num,ao_num) ]
|
|
||||||
implicit none
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Overlap between absolute values of atomic basis functions:
|
! Overlap between absolute values of atomic basis functions:
|
||||||
!
|
!
|
||||||
! :math:`\int |\chi_i(r)| |\chi_j(r)| dr`
|
! :math:`\int |\chi_i(r)| |\chi_j(r)| dr`
|
||||||
END_DOC
|
END_DOC
|
||||||
integer :: i,j,n,l
|
|
||||||
double precision :: f
|
implicit none
|
||||||
integer :: dim1
|
integer :: i, j, n, l, dim1, power_A(3), power_B(3)
|
||||||
double precision :: overlap, overlap_x, overlap_y, overlap_z
|
double precision :: overlap_x, overlap_y, overlap_z
|
||||||
double precision :: alpha, beta
|
double precision :: alpha, beta
|
||||||
double precision :: A_center(3), B_center(3)
|
double precision :: A_center(3), B_center(3)
|
||||||
integer :: power_A(3), power_B(3)
|
|
||||||
double precision :: lower_exp_val, dx
|
double precision :: lower_exp_val, dx
|
||||||
if (is_periodic) then
|
|
||||||
do j=1,ao_num
|
if(is_periodic) then
|
||||||
do i= 1,ao_num
|
|
||||||
ao_overlap_abs(i,j)= cdabs(ao_overlap_complex(i,j))
|
do j = 1, ao_num
|
||||||
|
do i = 1, ao_num
|
||||||
|
ao_overlap_abs(i,j) = cdabs(ao_overlap_complex(i,j))
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
else
|
else
|
||||||
|
|
||||||
dim1=100
|
dim1=100
|
||||||
lower_exp_val = 40.d0
|
lower_exp_val = 40.d0
|
||||||
!$OMP PARALLEL DO SCHEDULE(GUIDED) &
|
!$OMP PARALLEL DO SCHEDULE(GUIDED) &
|
||||||
!$OMP DEFAULT(NONE) &
|
!$OMP DEFAULT(NONE) &
|
||||||
!$OMP PRIVATE(A_center,B_center,power_A,power_B, &
|
!$OMP PRIVATE(A_center,B_center,power_A,power_B, &
|
||||||
!$OMP overlap_x,overlap_y, overlap_z, overlap, &
|
!$OMP overlap_x,overlap_y, overlap_z, &
|
||||||
!$OMP alpha, beta,i,j,dx) &
|
!$OMP alpha, beta,i,j,dx) &
|
||||||
!$OMP SHARED(nucl_coord,ao_power,ao_prim_num, &
|
!$OMP SHARED(nucl_coord,ao_power,ao_prim_num, &
|
||||||
!$OMP ao_overlap_abs,ao_num,ao_coef_normalized_ordered_transp,ao_nucl,&
|
!$OMP ao_overlap_abs,ao_num,ao_coef_normalized_ordered_transp,ao_nucl,&
|
||||||
!$OMP ao_expo_ordered_transp,dim1,lower_exp_val)
|
!$OMP ao_expo_ordered_transp,dim1,lower_exp_val)
|
||||||
do j=1,ao_num
|
do j=1,ao_num
|
||||||
A_center(1) = nucl_coord( ao_nucl(j), 1 )
|
A_center(1) = nucl_coord( ao_nucl(j), 1 )
|
||||||
A_center(2) = nucl_coord( ao_nucl(j), 2 )
|
A_center(2) = nucl_coord( ao_nucl(j), 2 )
|
||||||
@ -160,10 +190,14 @@ BEGIN_PROVIDER [ double precision, ao_overlap_abs,(ao_num,ao_num) ]
|
|||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
!$OMP END PARALLEL DO
|
!$OMP END PARALLEL DO
|
||||||
|
|
||||||
endif
|
endif
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
BEGIN_PROVIDER [ double precision, S_inv,(ao_num,ao_num) ]
|
BEGIN_PROVIDER [ double precision, S_inv,(ao_num,ao_num) ]
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
|
@ -1,7 +1,10 @@
|
|||||||
BEGIN_PROVIDER [ double precision, ao_deriv2_x,(ao_num,ao_num) ]
|
|
||||||
&BEGIN_PROVIDER [ double precision, ao_deriv2_y,(ao_num,ao_num) ]
|
! ---
|
||||||
&BEGIN_PROVIDER [ double precision, ao_deriv2_z,(ao_num,ao_num) ]
|
|
||||||
implicit none
|
BEGIN_PROVIDER [ double precision, ao_deriv2_x, (ao_num, ao_num) ]
|
||||||
|
&BEGIN_PROVIDER [ double precision, ao_deriv2_y, (ao_num, ao_num) ]
|
||||||
|
&BEGIN_PROVIDER [ double precision, ao_deriv2_z, (ao_num, ao_num) ]
|
||||||
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Second derivative matrix elements in the |AO| basis.
|
! Second derivative matrix elements in the |AO| basis.
|
||||||
!
|
!
|
||||||
@ -11,114 +14,131 @@
|
|||||||
! \langle \chi_i(x,y,z) | \frac{\partial^2}{\partial x^2} |\chi_j (x,y,z) \rangle
|
! \langle \chi_i(x,y,z) | \frac{\partial^2}{\partial x^2} |\chi_j (x,y,z) \rangle
|
||||||
!
|
!
|
||||||
END_DOC
|
END_DOC
|
||||||
integer :: i,j,n,l
|
|
||||||
double precision :: f
|
implicit none
|
||||||
integer :: dim1
|
integer :: i, j, n, l, dim1, power_A(3), power_B(3)
|
||||||
double precision :: overlap, overlap_y, overlap_z
|
double precision :: overlap, overlap_y, overlap_z
|
||||||
double precision :: overlap_x0, overlap_y0, overlap_z0
|
double precision :: overlap_x0, overlap_y0, overlap_z0
|
||||||
double precision :: alpha, beta, c
|
double precision :: alpha, beta, c
|
||||||
double precision :: A_center(3), B_center(3)
|
double precision :: A_center(3), B_center(3)
|
||||||
integer :: power_A(3), power_B(3)
|
|
||||||
double precision :: d_a_2,d_2
|
double precision :: d_a_2,d_2
|
||||||
dim1=100
|
|
||||||
|
|
||||||
! -- Dummy call to provide everything
|
if(use_cosgtos) then
|
||||||
A_center(:) = 0.d0
|
!print*, 'use_cosgtos for ao_kinetic_integrals ?', use_cosgtos
|
||||||
B_center(:) = 1.d0
|
|
||||||
alpha = 1.d0
|
|
||||||
beta = .1d0
|
|
||||||
power_A = 1
|
|
||||||
power_B = 0
|
|
||||||
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,d_a_2,overlap_z,overlap,dim1)
|
|
||||||
! --
|
|
||||||
|
|
||||||
!$OMP PARALLEL DO SCHEDULE(GUIDED) &
|
do j = 1, ao_num
|
||||||
!$OMP DEFAULT(NONE) &
|
do i = 1, ao_num
|
||||||
!$OMP PRIVATE(A_center,B_center,power_A,power_B,&
|
ao_deriv2_x(i,j) = ao_deriv2_cosgtos_x(i,j)
|
||||||
!$OMP overlap_y, overlap_z, overlap, &
|
ao_deriv2_y(i,j) = ao_deriv2_cosgtos_y(i,j)
|
||||||
!$OMP alpha, beta,i,j,c,d_a_2,d_2,deriv_tmp, &
|
ao_deriv2_z(i,j) = ao_deriv2_cosgtos_z(i,j)
|
||||||
!$OMP overlap_x0,overlap_y0,overlap_z0) &
|
enddo
|
||||||
!$OMP SHARED(nucl_coord,ao_power,ao_prim_num, &
|
enddo
|
||||||
!$OMP ao_deriv2_x,ao_deriv2_y,ao_deriv2_z,ao_num,ao_coef_normalized_ordered_transp,ao_nucl, &
|
|
||||||
!$OMP ao_expo_ordered_transp,dim1)
|
|
||||||
do j=1,ao_num
|
|
||||||
A_center(1) = nucl_coord( ao_nucl(j), 1 )
|
|
||||||
A_center(2) = nucl_coord( ao_nucl(j), 2 )
|
|
||||||
A_center(3) = nucl_coord( ao_nucl(j), 3 )
|
|
||||||
power_A(1) = ao_power( j, 1 )
|
|
||||||
power_A(2) = ao_power( j, 2 )
|
|
||||||
power_A(3) = ao_power( j, 3 )
|
|
||||||
do i= 1,ao_num
|
|
||||||
ao_deriv2_x(i,j)= 0.d0
|
|
||||||
ao_deriv2_y(i,j)= 0.d0
|
|
||||||
ao_deriv2_z(i,j)= 0.d0
|
|
||||||
B_center(1) = nucl_coord( ao_nucl(i), 1 )
|
|
||||||
B_center(2) = nucl_coord( ao_nucl(i), 2 )
|
|
||||||
B_center(3) = nucl_coord( ao_nucl(i), 3 )
|
|
||||||
power_B(1) = ao_power( i, 1 )
|
|
||||||
power_B(2) = ao_power( i, 2 )
|
|
||||||
power_B(3) = ao_power( i, 3 )
|
|
||||||
do n = 1,ao_prim_num(j)
|
|
||||||
alpha = ao_expo_ordered_transp(n,j)
|
|
||||||
do l = 1, ao_prim_num(i)
|
|
||||||
beta = ao_expo_ordered_transp(l,i)
|
|
||||||
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x0,overlap_y0,overlap_z0,overlap,dim1)
|
|
||||||
c = ao_coef_normalized_ordered_transp(n,j) * ao_coef_normalized_ordered_transp(l,i)
|
|
||||||
|
|
||||||
power_A(1) = power_A(1)-2
|
else
|
||||||
if (power_A(1)>-1) then
|
|
||||||
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,d_a_2,overlap_y,overlap_z,overlap,dim1)
|
|
||||||
else
|
|
||||||
d_a_2 = 0.d0
|
|
||||||
endif
|
|
||||||
power_A(1) = power_A(1)+4
|
|
||||||
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,d_2,overlap_y,overlap_z,overlap,dim1)
|
|
||||||
power_A(1) = power_A(1)-2
|
|
||||||
|
|
||||||
double precision :: deriv_tmp
|
dim1=100
|
||||||
deriv_tmp = (-2.d0 * alpha * (2.d0 * power_A(1) +1.d0) * overlap_x0 &
|
|
||||||
+power_A(1) * (power_A(1)-1.d0) * d_a_2 &
|
|
||||||
+4.d0 * alpha * alpha * d_2 )*overlap_y0*overlap_z0
|
|
||||||
|
|
||||||
ao_deriv2_x(i,j) += c*deriv_tmp
|
! -- Dummy call to provide everything
|
||||||
power_A(2) = power_A(2)-2
|
A_center(:) = 0.d0
|
||||||
if (power_A(2)>-1) then
|
B_center(:) = 1.d0
|
||||||
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,d_a_2,overlap_z,overlap,dim1)
|
alpha = 1.d0
|
||||||
else
|
beta = .1d0
|
||||||
d_a_2 = 0.d0
|
power_A = 1
|
||||||
endif
|
power_B = 0
|
||||||
power_A(2) = power_A(2)+4
|
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,d_a_2,overlap_z,overlap,dim1)
|
||||||
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,d_2,overlap_z,overlap,dim1)
|
! --
|
||||||
power_A(2) = power_A(2)-2
|
|
||||||
|
|
||||||
deriv_tmp = (-2.d0 * alpha * (2.d0 * power_A(2) +1.d0 ) * overlap_y0 &
|
!$OMP PARALLEL DO SCHEDULE(GUIDED) &
|
||||||
+power_A(2) * (power_A(2)-1.d0) * d_a_2 &
|
!$OMP DEFAULT(NONE) &
|
||||||
+4.d0 * alpha * alpha * d_2 )*overlap_x0*overlap_z0
|
!$OMP PRIVATE(A_center,B_center,power_A,power_B,&
|
||||||
ao_deriv2_y(i,j) += c*deriv_tmp
|
!$OMP overlap_y, overlap_z, overlap, &
|
||||||
|
!$OMP alpha, beta,i,j,c,d_a_2,d_2,deriv_tmp, &
|
||||||
|
!$OMP overlap_x0,overlap_y0,overlap_z0) &
|
||||||
|
!$OMP SHARED(nucl_coord,ao_power,ao_prim_num, &
|
||||||
|
!$OMP ao_deriv2_x,ao_deriv2_y,ao_deriv2_z,ao_num,ao_coef_normalized_ordered_transp,ao_nucl, &
|
||||||
|
!$OMP ao_expo_ordered_transp,dim1)
|
||||||
|
do j=1,ao_num
|
||||||
|
A_center(1) = nucl_coord( ao_nucl(j), 1 )
|
||||||
|
A_center(2) = nucl_coord( ao_nucl(j), 2 )
|
||||||
|
A_center(3) = nucl_coord( ao_nucl(j), 3 )
|
||||||
|
power_A(1) = ao_power( j, 1 )
|
||||||
|
power_A(2) = ao_power( j, 2 )
|
||||||
|
power_A(3) = ao_power( j, 3 )
|
||||||
|
do i= 1,ao_num
|
||||||
|
ao_deriv2_x(i,j)= 0.d0
|
||||||
|
ao_deriv2_y(i,j)= 0.d0
|
||||||
|
ao_deriv2_z(i,j)= 0.d0
|
||||||
|
B_center(1) = nucl_coord( ao_nucl(i), 1 )
|
||||||
|
B_center(2) = nucl_coord( ao_nucl(i), 2 )
|
||||||
|
B_center(3) = nucl_coord( ao_nucl(i), 3 )
|
||||||
|
power_B(1) = ao_power( i, 1 )
|
||||||
|
power_B(2) = ao_power( i, 2 )
|
||||||
|
power_B(3) = ao_power( i, 3 )
|
||||||
|
do n = 1,ao_prim_num(j)
|
||||||
|
alpha = ao_expo_ordered_transp(n,j)
|
||||||
|
do l = 1, ao_prim_num(i)
|
||||||
|
beta = ao_expo_ordered_transp(l,i)
|
||||||
|
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x0,overlap_y0,overlap_z0,overlap,dim1)
|
||||||
|
c = ao_coef_normalized_ordered_transp(n,j) * ao_coef_normalized_ordered_transp(l,i)
|
||||||
|
|
||||||
power_A(3) = power_A(3)-2
|
power_A(1) = power_A(1)-2
|
||||||
if (power_A(3)>-1) then
|
if (power_A(1)>-1) then
|
||||||
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,overlap_z,d_a_2,overlap,dim1)
|
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,d_a_2,overlap_y,overlap_z,overlap,dim1)
|
||||||
else
|
else
|
||||||
d_a_2 = 0.d0
|
d_a_2 = 0.d0
|
||||||
endif
|
endif
|
||||||
power_A(3) = power_A(3)+4
|
power_A(1) = power_A(1)+4
|
||||||
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,overlap_z,d_2,overlap,dim1)
|
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,d_2,overlap_y,overlap_z,overlap,dim1)
|
||||||
power_A(3) = power_A(3)-2
|
power_A(1) = power_A(1)-2
|
||||||
|
|
||||||
deriv_tmp = (-2.d0 * alpha * (2.d0 * power_A(3) +1.d0 ) * overlap_z0 &
|
double precision :: deriv_tmp
|
||||||
+power_A(3) * (power_A(3)-1.d0) * d_a_2 &
|
deriv_tmp = (-2.d0 * alpha * (2.d0 * power_A(1) +1.d0) * overlap_x0 &
|
||||||
+4.d0 * alpha * alpha * d_2 )*overlap_x0*overlap_y0
|
+power_A(1) * (power_A(1)-1.d0) * d_a_2 &
|
||||||
ao_deriv2_z(i,j) += c*deriv_tmp
|
+4.d0 * alpha * alpha * d_2 )*overlap_y0*overlap_z0
|
||||||
|
|
||||||
|
ao_deriv2_x(i,j) += c*deriv_tmp
|
||||||
|
power_A(2) = power_A(2)-2
|
||||||
|
if (power_A(2)>-1) then
|
||||||
|
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,d_a_2,overlap_z,overlap,dim1)
|
||||||
|
else
|
||||||
|
d_a_2 = 0.d0
|
||||||
|
endif
|
||||||
|
power_A(2) = power_A(2)+4
|
||||||
|
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,d_2,overlap_z,overlap,dim1)
|
||||||
|
power_A(2) = power_A(2)-2
|
||||||
|
|
||||||
|
deriv_tmp = (-2.d0 * alpha * (2.d0 * power_A(2) +1.d0 ) * overlap_y0 &
|
||||||
|
+power_A(2) * (power_A(2)-1.d0) * d_a_2 &
|
||||||
|
+4.d0 * alpha * alpha * d_2 )*overlap_x0*overlap_z0
|
||||||
|
ao_deriv2_y(i,j) += c*deriv_tmp
|
||||||
|
|
||||||
|
power_A(3) = power_A(3)-2
|
||||||
|
if (power_A(3)>-1) then
|
||||||
|
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,overlap_z,d_a_2,overlap,dim1)
|
||||||
|
else
|
||||||
|
d_a_2 = 0.d0
|
||||||
|
endif
|
||||||
|
power_A(3) = power_A(3)+4
|
||||||
|
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,overlap_z,d_2,overlap,dim1)
|
||||||
|
power_A(3) = power_A(3)-2
|
||||||
|
|
||||||
|
deriv_tmp = (-2.d0 * alpha * (2.d0 * power_A(3) +1.d0 ) * overlap_z0 &
|
||||||
|
+power_A(3) * (power_A(3)-1.d0) * d_a_2 &
|
||||||
|
+4.d0 * alpha * alpha * d_2 )*overlap_x0*overlap_y0
|
||||||
|
ao_deriv2_z(i,j) += c*deriv_tmp
|
||||||
|
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
enddo
|
!$OMP END PARALLEL DO
|
||||||
enddo
|
|
||||||
!$OMP END PARALLEL DO
|
endif
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
BEGIN_PROVIDER [double precision, ao_kinetic_integrals, (ao_num,ao_num)]
|
BEGIN_PROVIDER [double precision, ao_kinetic_integrals, (ao_num,ao_num)]
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
|
@ -1,3 +1,6 @@
|
|||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
subroutine give_all_erf_kl_ao(integrals_ao,mu_in,C_center)
|
subroutine give_all_erf_kl_ao(integrals_ao,mu_in,C_center)
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
@ -15,36 +18,104 @@ subroutine give_all_erf_kl_ao(integrals_ao,mu_in,C_center)
|
|||||||
enddo
|
enddo
|
||||||
end
|
end
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
double precision function NAI_pol_mult_erf_ao(i_ao, j_ao, mu_in, C_center)
|
||||||
|
|
||||||
double precision function NAI_pol_mult_erf_ao(i_ao,j_ao,mu_in,C_center)
|
|
||||||
implicit none
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
|
!
|
||||||
! Computes the following integral :
|
! Computes the following integral :
|
||||||
! $\int_{-\infty}^{infty} dr \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
|
! $\int_{-\infty}^{infty} dr \chi_i(r) \chi_j(r) \frac{\erf(\mu |r - R_C|)}{|r - R_C|}$.
|
||||||
|
!
|
||||||
END_DOC
|
END_DOC
|
||||||
integer, intent(in) :: i_ao,j_ao
|
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: i_ao, j_ao
|
||||||
double precision, intent(in) :: mu_in, C_center(3)
|
double precision, intent(in) :: mu_in, C_center(3)
|
||||||
integer :: i,j,num_A,num_B, power_A(3), power_B(3), n_pt_in
|
|
||||||
double precision :: A_center(3), B_center(3),integral, alpha,beta
|
integer :: i, j, num_A, num_B, power_A(3), power_B(3), n_pt_in
|
||||||
|
double precision :: A_center(3), B_center(3), integral, alpha, beta
|
||||||
|
|
||||||
double precision :: NAI_pol_mult_erf
|
double precision :: NAI_pol_mult_erf
|
||||||
num_A = ao_nucl(i_ao)
|
|
||||||
power_A(1:3)= ao_power(i_ao,1:3)
|
num_A = ao_nucl(i_ao)
|
||||||
|
power_A(1:3) = ao_power(i_ao,1:3)
|
||||||
A_center(1:3) = nucl_coord(num_A,1:3)
|
A_center(1:3) = nucl_coord(num_A,1:3)
|
||||||
num_B = ao_nucl(j_ao)
|
num_B = ao_nucl(j_ao)
|
||||||
power_B(1:3)= ao_power(j_ao,1:3)
|
power_B(1:3) = ao_power(j_ao,1:3)
|
||||||
B_center(1:3) = nucl_coord(num_B,1:3)
|
B_center(1:3) = nucl_coord(num_B,1:3)
|
||||||
|
|
||||||
n_pt_in = n_pt_max_integrals
|
n_pt_in = n_pt_max_integrals
|
||||||
|
|
||||||
NAI_pol_mult_erf_ao = 0.d0
|
NAI_pol_mult_erf_ao = 0.d0
|
||||||
do i = 1, ao_prim_num(i_ao)
|
do i = 1, ao_prim_num(i_ao)
|
||||||
alpha = ao_expo_ordered_transp(i,i_ao)
|
alpha = ao_expo_ordered_transp(i,i_ao)
|
||||||
do j = 1, ao_prim_num(j_ao)
|
do j = 1, ao_prim_num(j_ao)
|
||||||
beta = ao_expo_ordered_transp(j,j_ao)
|
beta = ao_expo_ordered_transp(j,j_ao)
|
||||||
integral = NAI_pol_mult_erf(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in,mu_in)
|
|
||||||
NAI_pol_mult_erf_ao += integral * ao_coef_normalized_ordered_transp(j,j_ao)*ao_coef_normalized_ordered_transp(i,i_ao)
|
integral = NAI_pol_mult_erf(A_center, B_center, power_A, power_B, alpha, beta, C_center, n_pt_in,mu_in)
|
||||||
|
|
||||||
|
NAI_pol_mult_erf_ao += integral * ao_coef_normalized_ordered_transp(j,j_ao) * ao_coef_normalized_ordered_transp(i,i_ao)
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
end
|
end function NAI_pol_mult_erf_ao
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
double precision function NAI_pol_mult_erf_ao_with1s(i_ao, j_ao, beta, B_center, mu_in, C_center)
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
!
|
||||||
|
! Computes the following integral :
|
||||||
|
! $\int_{-\infty}^{infty} dr \chi_i(r) \chi_j(r) e^{-\beta (r - B_center)^2} \frac{\erf(\mu |r - R_C|)}{|r - R_C|}$.
|
||||||
|
!
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: i_ao, j_ao
|
||||||
|
double precision, intent(in) :: beta, B_center(3)
|
||||||
|
double precision, intent(in) :: mu_in, C_center(3)
|
||||||
|
|
||||||
|
integer :: i, j, power_A1(3), power_A2(3), n_pt_in
|
||||||
|
double precision :: A1_center(3), A2_center(3), alpha1, alpha2, coef12, coef1, integral
|
||||||
|
|
||||||
|
double precision, external :: NAI_pol_mult_erf_with1s, NAI_pol_mult_erf_ao
|
||||||
|
|
||||||
|
ASSERT(beta .ge. 0.d0)
|
||||||
|
if(beta .lt. 1d-10) then
|
||||||
|
NAI_pol_mult_erf_ao_with1s = NAI_pol_mult_erf_ao(i_ao, j_ao, mu_in, C_center)
|
||||||
|
return
|
||||||
|
endif
|
||||||
|
|
||||||
|
power_A1(1:3) = ao_power(i_ao,1:3)
|
||||||
|
power_A2(1:3) = ao_power(j_ao,1:3)
|
||||||
|
|
||||||
|
A1_center(1:3) = nucl_coord(ao_nucl(i_ao),1:3)
|
||||||
|
A2_center(1:3) = nucl_coord(ao_nucl(j_ao),1:3)
|
||||||
|
|
||||||
|
n_pt_in = n_pt_max_integrals
|
||||||
|
|
||||||
|
NAI_pol_mult_erf_ao_with1s = 0.d0
|
||||||
|
do i = 1, ao_prim_num(i_ao)
|
||||||
|
alpha1 = ao_expo_ordered_transp (i,i_ao)
|
||||||
|
coef1 = ao_coef_normalized_ordered_transp(i,i_ao)
|
||||||
|
|
||||||
|
do j = 1, ao_prim_num(j_ao)
|
||||||
|
alpha2 = ao_expo_ordered_transp(j,j_ao)
|
||||||
|
coef12 = coef1 * ao_coef_normalized_ordered_transp(j,j_ao)
|
||||||
|
if(dabs(coef12) .lt. 1d-14) cycle
|
||||||
|
|
||||||
|
integral = NAI_pol_mult_erf_with1s( A1_center, A2_center, power_A1, power_A2, alpha1, alpha2 &
|
||||||
|
, beta, B_center, C_center, n_pt_in, mu_in )
|
||||||
|
|
||||||
|
NAI_pol_mult_erf_ao_with1s += integral * coef12
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
end function NAI_pol_mult_erf_ao_with1s
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
double precision function NAI_pol_mult_erf(A_center, B_center, power_A, power_B, alpha, beta, C_center, n_pt_in, mu_in)
|
double precision function NAI_pol_mult_erf(A_center, B_center, power_A, power_B, alpha, beta, C_center, n_pt_in, mu_in)
|
||||||
|
|
||||||
@ -127,58 +198,221 @@ end function NAI_pol_mult_erf
|
|||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
|
||||||
|
subroutine NAI_pol_mult_erf_v(A_center, B_center, power_A, power_B, alpha, beta, C_center, LD_C, n_pt_in, mu_in, res_v, LD_resv, n_points)
|
||||||
double precision function NAI_pol_mult_erf_ao_with1s(i_ao, j_ao, beta, B_center, mu_in, C_center)
|
|
||||||
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
!
|
!
|
||||||
! Computes the following integral :
|
! Computes the following integral :
|
||||||
! $\int_{-\infty}^{infty} dr \chi_i(r) \chi_j(r) e^{-\beta (r - B_center)^2} \frac{\erf(\mu |r - R_C|)}{|r - R_C|}$.
|
!
|
||||||
|
! .. math::
|
||||||
|
!
|
||||||
|
! \int dr (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
|
||||||
|
! \frac{\erf(\mu |r - R_C |)}{| r - R_C |}$.
|
||||||
!
|
!
|
||||||
END_DOC
|
END_DOC
|
||||||
|
|
||||||
|
include 'utils/constants.include.F'
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
integer, intent(in) :: i_ao, j_ao
|
|
||||||
double precision, intent(in) :: beta, B_center(3)
|
|
||||||
double precision, intent(in) :: mu_in, C_center(3)
|
|
||||||
|
|
||||||
integer :: i, j, power_A1(3), power_A2(3), n_pt_in
|
integer, intent(in) :: n_pt_in, n_points, LD_C, LD_resv
|
||||||
double precision :: A1_center(3), A2_center(3), alpha1, alpha2, coef12, coef1, integral
|
integer, intent(in) :: power_A(3), power_B(3)
|
||||||
|
double precision, intent(in) :: A_center(3), B_center(3), alpha, beta, mu_in
|
||||||
|
double precision, intent(in) :: C_center(LD_C,3)
|
||||||
|
double precision, intent(out) :: res_v(LD_resv)
|
||||||
|
|
||||||
double precision, external :: NAI_pol_mult_erf_with1s, NAI_pol_mult_erf_ao
|
integer :: i, n_pt, n_pt_out, ipoint
|
||||||
|
double precision :: P_center(3)
|
||||||
|
double precision :: d(0:n_pt_in), coeff, dist, const, factor
|
||||||
|
double precision :: const_factor, dist_integral
|
||||||
|
double precision :: accu, p_inv, p, rho, p_inv_2
|
||||||
|
double precision :: p_new, p_new2, coef_tmp
|
||||||
|
|
||||||
ASSERT(beta .ge. 0.d0)
|
double precision :: rint
|
||||||
if(beta .lt. 1d-10) then
|
|
||||||
NAI_pol_mult_erf_ao_with1s = NAI_pol_mult_erf_ao(i_ao, j_ao, mu_in, C_center)
|
res_V(1:LD_resv) = 0.d0
|
||||||
|
|
||||||
|
p = alpha + beta
|
||||||
|
p_inv = 1.d0 / p
|
||||||
|
p_inv_2 = 0.5d0 * p_inv
|
||||||
|
rho = alpha * beta * p_inv
|
||||||
|
p_new = mu_in / dsqrt(p + mu_in * mu_in)
|
||||||
|
p_new2 = p_new * p_new
|
||||||
|
coef_tmp = p * p_new2
|
||||||
|
|
||||||
|
dist = 0.d0
|
||||||
|
do i = 1, 3
|
||||||
|
P_center(i) = (alpha * A_center(i) + beta * B_center(i)) * p_inv
|
||||||
|
dist += (A_center(i) - B_center(i)) * (A_center(i) - B_center(i))
|
||||||
|
enddo
|
||||||
|
|
||||||
|
const_factor = dist * rho
|
||||||
|
if(const_factor > 80.d0) then
|
||||||
|
return
|
||||||
|
endif
|
||||||
|
factor = dexp(-const_factor)
|
||||||
|
coeff = dtwo_pi * factor * p_inv * p_new
|
||||||
|
|
||||||
|
n_pt = 2 * ( power_A(1) + power_B(1) + power_A(2) + power_B(2) + power_A(3) + power_B(3) )
|
||||||
|
|
||||||
|
if(n_pt == 0) then
|
||||||
|
|
||||||
|
do ipoint = 1, n_points
|
||||||
|
dist_integral = 0.d0
|
||||||
|
do i = 1, 3
|
||||||
|
dist_integral += (P_center(i) - C_center(ipoint,i)) * (P_center(i) - C_center(ipoint,i))
|
||||||
|
enddo
|
||||||
|
const = coef_tmp * dist_integral
|
||||||
|
|
||||||
|
res_v(ipoint) = coeff * rint(0, const)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
else
|
||||||
|
|
||||||
|
do ipoint = 1, n_points
|
||||||
|
dist_integral = 0.d0
|
||||||
|
do i = 1, 3
|
||||||
|
dist_integral += (P_center(i) - C_center(ipoint,i)) * (P_center(i) - C_center(ipoint,i))
|
||||||
|
enddo
|
||||||
|
const = coef_tmp * dist_integral
|
||||||
|
|
||||||
|
do i = 0, n_pt_in
|
||||||
|
d(i) = 0.d0
|
||||||
|
enddo
|
||||||
|
call give_polynomial_mult_center_one_e_erf_opt(A_center, B_center, power_A, power_B, C_center(ipoint,1:3), n_pt_in, d, n_pt_out, p_inv_2, p_new2, P_center)
|
||||||
|
|
||||||
|
if(n_pt_out < 0) then
|
||||||
|
res_v(ipoint) = 0.d0
|
||||||
|
cycle
|
||||||
|
endif
|
||||||
|
|
||||||
|
! sum of integrals of type : int {t,[0,1]} exp-(rho.(P-Q)^2 * t^2) * t^i
|
||||||
|
accu = 0.d0
|
||||||
|
do i = 0, n_pt_out, 2
|
||||||
|
accu += d(i) * rint(i/2, const)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
res_v(ipoint) = accu * coeff
|
||||||
|
enddo
|
||||||
|
|
||||||
|
endif
|
||||||
|
|
||||||
|
end subroutine NAI_pol_mult_erf_v
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
double precision function NAI_pol_mult_erf_with1s( A1_center, A2_center, power_A1, power_A2, alpha1, alpha2 &
|
||||||
|
, beta, B_center, C_center, n_pt_in, mu_in )
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
!
|
||||||
|
! Computes the following integral :
|
||||||
|
!
|
||||||
|
! .. math::
|
||||||
|
!
|
||||||
|
! \int dx (x - A1_x)^a_1 (x - B1_x)^a_2 \exp(-\alpha_1 (x - A1_x)^2 - \alpha_2 (x - A2_x)^2)
|
||||||
|
! \int dy (y - A1_y)^b_1 (y - B1_y)^b_2 \exp(-\alpha_1 (y - A1_y)^2 - \alpha_2 (y - A2_y)^2)
|
||||||
|
! \int dz (x - A1_z)^c_1 (z - B1_z)^c_2 \exp(-\alpha_1 (z - A1_z)^2 - \alpha_2 (z - A2_z)^2)
|
||||||
|
! \exp(-\beta (r - B)^2)
|
||||||
|
! \frac{\erf(\mu |r - R_C|)}{|r - R_C|}$.
|
||||||
|
!
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
include 'utils/constants.include.F'
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: n_pt_in
|
||||||
|
integer, intent(in) :: power_A1(3), power_A2(3)
|
||||||
|
double precision, intent(in) :: C_center(3), A1_center(3), A2_center(3), B_center(3)
|
||||||
|
double precision, intent(in) :: alpha1, alpha2, beta, mu_in
|
||||||
|
|
||||||
|
integer :: i, n_pt, n_pt_out
|
||||||
|
double precision :: alpha12, alpha12_inv, alpha12_inv_2, rho12, A12_center(3), dist12, const_factor12
|
||||||
|
double precision :: p, p_inv, p_inv_2, rho, P_center(3), dist, const_factor
|
||||||
|
double precision :: dist_integral
|
||||||
|
double precision :: d(0:n_pt_in), coeff, const, factor
|
||||||
|
double precision :: accu
|
||||||
|
double precision :: p_new
|
||||||
|
|
||||||
|
double precision :: rint
|
||||||
|
|
||||||
|
|
||||||
|
! e^{-alpha1 (r - A1)^2} e^{-alpha2 (r - A2)^2} = e^{-K12} e^{-alpha12 (r - A12)^2}
|
||||||
|
alpha12 = alpha1 + alpha2
|
||||||
|
alpha12_inv = 1.d0 / alpha12
|
||||||
|
alpha12_inv_2 = 0.5d0 * alpha12_inv
|
||||||
|
rho12 = alpha1 * alpha2 * alpha12_inv
|
||||||
|
A12_center(1) = (alpha1 * A1_center(1) + alpha2 * A2_center(1)) * alpha12_inv
|
||||||
|
A12_center(2) = (alpha1 * A1_center(2) + alpha2 * A2_center(2)) * alpha12_inv
|
||||||
|
A12_center(3) = (alpha1 * A1_center(3) + alpha2 * A2_center(3)) * alpha12_inv
|
||||||
|
dist12 = (A1_center(1) - A2_center(1)) * (A1_center(1) - A2_center(1)) &
|
||||||
|
+ (A1_center(2) - A2_center(2)) * (A1_center(2) - A2_center(2)) &
|
||||||
|
+ (A1_center(3) - A2_center(3)) * (A1_center(3) - A2_center(3))
|
||||||
|
|
||||||
|
const_factor12 = dist12 * rho12
|
||||||
|
if(const_factor12 > 80.d0) then
|
||||||
|
NAI_pol_mult_erf_with1s = 0.d0
|
||||||
return
|
return
|
||||||
endif
|
endif
|
||||||
|
|
||||||
power_A1(1:3) = ao_power(i_ao,1:3)
|
! ---
|
||||||
power_A2(1:3) = ao_power(j_ao,1:3)
|
|
||||||
|
|
||||||
A1_center(1:3) = nucl_coord(ao_nucl(i_ao),1:3)
|
! e^{-K12} e^{-alpha12 (r - A12)^2} e^{-beta (r - B)^2} = e^{-K} e^{-p (r - P)^2}
|
||||||
A2_center(1:3) = nucl_coord(ao_nucl(j_ao),1:3)
|
p = alpha12 + beta
|
||||||
|
p_inv = 1.d0 / p
|
||||||
|
p_inv_2 = 0.5d0 * p_inv
|
||||||
|
rho = alpha12 * beta * p_inv
|
||||||
|
P_center(1) = (alpha12 * A12_center(1) + beta * B_center(1)) * p_inv
|
||||||
|
P_center(2) = (alpha12 * A12_center(2) + beta * B_center(2)) * p_inv
|
||||||
|
P_center(3) = (alpha12 * A12_center(3) + beta * B_center(3)) * p_inv
|
||||||
|
dist = (A12_center(1) - B_center(1)) * (A12_center(1) - B_center(1)) &
|
||||||
|
+ (A12_center(2) - B_center(2)) * (A12_center(2) - B_center(2)) &
|
||||||
|
+ (A12_center(3) - B_center(3)) * (A12_center(3) - B_center(3))
|
||||||
|
|
||||||
n_pt_in = n_pt_max_integrals
|
const_factor = const_factor12 + dist * rho
|
||||||
|
if(const_factor > 80.d0) then
|
||||||
|
NAI_pol_mult_erf_with1s = 0.d0
|
||||||
|
return
|
||||||
|
endif
|
||||||
|
|
||||||
NAI_pol_mult_erf_ao_with1s = 0.d0
|
dist_integral = (P_center(1) - C_center(1)) * (P_center(1) - C_center(1)) &
|
||||||
do i = 1, ao_prim_num(i_ao)
|
+ (P_center(2) - C_center(2)) * (P_center(2) - C_center(2)) &
|
||||||
alpha1 = ao_expo_ordered_transp (i,i_ao)
|
+ (P_center(3) - C_center(3)) * (P_center(3) - C_center(3))
|
||||||
coef1 = ao_coef_normalized_ordered_transp(i,i_ao)
|
|
||||||
|
|
||||||
do j = 1, ao_prim_num(j_ao)
|
! ---
|
||||||
alpha2 = ao_expo_ordered_transp(j,j_ao)
|
|
||||||
coef12 = coef1 * ao_coef_normalized_ordered_transp(j,j_ao)
|
|
||||||
if(dabs(coef12) .lt. 1d-14) cycle
|
|
||||||
|
|
||||||
integral = NAI_pol_mult_erf_with1s( A1_center, A2_center, power_A1, power_A2, alpha1, alpha2 &
|
p_new = mu_in / dsqrt(p + mu_in * mu_in)
|
||||||
, beta, B_center, C_center, n_pt_in, mu_in )
|
factor = dexp(-const_factor)
|
||||||
|
coeff = dtwo_pi * factor * p_inv * p_new
|
||||||
|
|
||||||
NAI_pol_mult_erf_ao_with1s += integral * coef12
|
n_pt = 2 * ( (power_A1(1) + power_A2(1)) + (power_A1(2) + power_A2(2)) + (power_A1(3) + power_A2(3)) )
|
||||||
enddo
|
const = p * dist_integral * p_new * p_new
|
||||||
|
if(n_pt == 0) then
|
||||||
|
NAI_pol_mult_erf_with1s = coeff * rint(0, const)
|
||||||
|
return
|
||||||
|
endif
|
||||||
|
|
||||||
|
do i = 0, n_pt_in
|
||||||
|
d(i) = 0.d0
|
||||||
enddo
|
enddo
|
||||||
|
p_new = p_new * p_new
|
||||||
|
call give_polynomial_mult_center_one_e_erf_opt( A1_center, A2_center, power_A1, power_A2, C_center, n_pt_in, d, n_pt_out, p_inv_2, p_new, P_center)
|
||||||
|
|
||||||
end function NAI_pol_mult_erf_ao_with1s
|
if(n_pt_out < 0) then
|
||||||
|
NAI_pol_mult_erf_with1s = 0.d0
|
||||||
|
return
|
||||||
|
endif
|
||||||
|
|
||||||
|
! sum of integrals of type : int {t,[0,1]} exp-(rho.(P-Q)^2 * t^2) * t^i
|
||||||
|
accu = 0.d0
|
||||||
|
do i = 0, n_pt_out, 2
|
||||||
|
accu += d(i) * rint(i/2, const)
|
||||||
|
enddo
|
||||||
|
NAI_pol_mult_erf_with1s = accu * coeff
|
||||||
|
|
||||||
|
end function NAI_pol_mult_erf_with1s
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
subroutine NAI_pol_mult_erf_with1s_v(A1_center, A2_center, power_A1, power_A2, alpha1, alpha2, beta, B_center, LD_B, C_center, LD_C, n_pt_in, mu_in, res_v, LD_resv, n_points)
|
subroutine NAI_pol_mult_erf_with1s_v(A1_center, A2_center, power_A1, power_A2, alpha1, alpha2, beta, B_center, LD_B, C_center, LD_C, n_pt_in, mu_in, res_v, LD_resv, n_points)
|
||||||
|
|
||||||
@ -428,107 +662,6 @@ subroutine give_polynomial_mult_center_one_e_erf_opt(A_center, B_center, power_A
|
|||||||
end subroutine give_polynomial_mult_center_one_e_erf_opt
|
end subroutine give_polynomial_mult_center_one_e_erf_opt
|
||||||
|
|
||||||
! ---
|
! ---
|
||||||
subroutine NAI_pol_mult_erf_v(A_center, B_center, power_A, power_B, alpha, beta, C_center, LD_C, n_pt_in, mu_in, res_v, LD_resv, n_points)
|
|
||||||
|
|
||||||
BEGIN_DOC
|
|
||||||
!
|
|
||||||
! Computes the following integral :
|
|
||||||
!
|
|
||||||
! .. math::
|
|
||||||
!
|
|
||||||
! \int dr (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
|
|
||||||
! \frac{\erf(\mu |r - R_C |)}{| r - R_C |}$.
|
|
||||||
!
|
|
||||||
END_DOC
|
|
||||||
|
|
||||||
include 'utils/constants.include.F'
|
|
||||||
|
|
||||||
implicit none
|
|
||||||
|
|
||||||
integer, intent(in) :: n_pt_in, n_points, LD_C, LD_resv
|
|
||||||
integer, intent(in) :: power_A(3), power_B(3)
|
|
||||||
double precision, intent(in) :: A_center(3), B_center(3), alpha, beta, mu_in
|
|
||||||
double precision, intent(in) :: C_center(LD_C,3)
|
|
||||||
double precision, intent(out) :: res_v(LD_resv)
|
|
||||||
|
|
||||||
integer :: i, n_pt, n_pt_out, ipoint
|
|
||||||
double precision :: P_center(3)
|
|
||||||
double precision :: d(0:n_pt_in), coeff, dist, const, factor
|
|
||||||
double precision :: const_factor, dist_integral
|
|
||||||
double precision :: accu, p_inv, p, rho, p_inv_2
|
|
||||||
double precision :: p_new, p_new2, coef_tmp
|
|
||||||
|
|
||||||
double precision :: rint
|
|
||||||
|
|
||||||
res_V(1:LD_resv) = 0.d0
|
|
||||||
|
|
||||||
p = alpha + beta
|
|
||||||
p_inv = 1.d0 / p
|
|
||||||
p_inv_2 = 0.5d0 * p_inv
|
|
||||||
rho = alpha * beta * p_inv
|
|
||||||
p_new = mu_in / dsqrt(p + mu_in * mu_in)
|
|
||||||
p_new2 = p_new * p_new
|
|
||||||
coef_tmp = p * p_new2
|
|
||||||
|
|
||||||
dist = 0.d0
|
|
||||||
do i = 1, 3
|
|
||||||
P_center(i) = (alpha * A_center(i) + beta * B_center(i)) * p_inv
|
|
||||||
dist += (A_center(i) - B_center(i)) * (A_center(i) - B_center(i))
|
|
||||||
enddo
|
|
||||||
|
|
||||||
const_factor = dist * rho
|
|
||||||
if(const_factor > 80.d0) then
|
|
||||||
return
|
|
||||||
endif
|
|
||||||
factor = dexp(-const_factor)
|
|
||||||
coeff = dtwo_pi * factor * p_inv * p_new
|
|
||||||
|
|
||||||
n_pt = 2 * ( power_A(1) + power_B(1) + power_A(2) + power_B(2) + power_A(3) + power_B(3) )
|
|
||||||
|
|
||||||
if(n_pt == 0) then
|
|
||||||
|
|
||||||
do ipoint = 1, n_points
|
|
||||||
dist_integral = 0.d0
|
|
||||||
do i = 1, 3
|
|
||||||
dist_integral += (P_center(i) - C_center(ipoint,i)) * (P_center(i) - C_center(ipoint,i))
|
|
||||||
enddo
|
|
||||||
const = coef_tmp * dist_integral
|
|
||||||
|
|
||||||
res_v(ipoint) = coeff * rint(0, const)
|
|
||||||
enddo
|
|
||||||
|
|
||||||
else
|
|
||||||
|
|
||||||
do ipoint = 1, n_points
|
|
||||||
dist_integral = 0.d0
|
|
||||||
do i = 1, 3
|
|
||||||
dist_integral += (P_center(i) - C_center(ipoint,i)) * (P_center(i) - C_center(ipoint,i))
|
|
||||||
enddo
|
|
||||||
const = coef_tmp * dist_integral
|
|
||||||
|
|
||||||
do i = 0, n_pt_in
|
|
||||||
d(i) = 0.d0
|
|
||||||
enddo
|
|
||||||
call give_polynomial_mult_center_one_e_erf_opt(A_center, B_center, power_A, power_B, C_center(ipoint,1:3), n_pt_in, d, n_pt_out, p_inv_2, p_new2, P_center)
|
|
||||||
|
|
||||||
if(n_pt_out < 0) then
|
|
||||||
res_v(ipoint) = 0.d0
|
|
||||||
cycle
|
|
||||||
endif
|
|
||||||
|
|
||||||
! sum of integrals of type : int {t,[0,1]} exp-(rho.(P-Q)^2 * t^2) * t^i
|
|
||||||
accu = 0.d0
|
|
||||||
do i = 0, n_pt_out, 2
|
|
||||||
accu += d(i) * rint(i/2, const)
|
|
||||||
enddo
|
|
||||||
|
|
||||||
res_v(ipoint) = accu * coeff
|
|
||||||
enddo
|
|
||||||
|
|
||||||
endif
|
|
||||||
|
|
||||||
end subroutine NAI_pol_mult_erf_v
|
|
||||||
|
|
||||||
|
|
||||||
subroutine give_polynomial_mult_center_one_e_erf(A_center,B_center,alpha,beta,power_A,power_B,C_center,n_pt_in,d,n_pt_out,mu_in)
|
subroutine give_polynomial_mult_center_one_e_erf(A_center,B_center,alpha,beta,power_A,power_B,C_center,n_pt_in,d,n_pt_out,mu_in)
|
||||||
|
|
||||||
@ -659,113 +792,3 @@ subroutine give_polynomial_mult_center_one_e_erf(A_center,B_center,alpha,beta,po
|
|||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
double precision function NAI_pol_mult_erf_with1s( A1_center, A2_center, power_A1, power_A2, alpha1, alpha2 &
|
|
||||||
, beta, B_center, C_center, n_pt_in, mu_in )
|
|
||||||
|
|
||||||
BEGIN_DOC
|
|
||||||
!
|
|
||||||
! Computes the following integral :
|
|
||||||
!
|
|
||||||
! .. math::
|
|
||||||
!
|
|
||||||
! \int dx (x - A1_x)^a_1 (x - B1_x)^a_2 \exp(-\alpha_1 (x - A1_x)^2 - \alpha_2 (x - A2_x)^2)
|
|
||||||
! \int dy (y - A1_y)^b_1 (y - B1_y)^b_2 \exp(-\alpha_1 (y - A1_y)^2 - \alpha_2 (y - A2_y)^2)
|
|
||||||
! \int dz (x - A1_z)^c_1 (z - B1_z)^c_2 \exp(-\alpha_1 (z - A1_z)^2 - \alpha_2 (z - A2_z)^2)
|
|
||||||
! \exp(-\beta (r - B)^2)
|
|
||||||
! \frac{\erf(\mu |r - R_C|)}{|r - R_C|}$.
|
|
||||||
!
|
|
||||||
END_DOC
|
|
||||||
|
|
||||||
include 'utils/constants.include.F'
|
|
||||||
|
|
||||||
implicit none
|
|
||||||
integer, intent(in) :: n_pt_in
|
|
||||||
integer, intent(in) :: power_A1(3), power_A2(3)
|
|
||||||
double precision, intent(in) :: C_center(3), A1_center(3), A2_center(3), B_center(3)
|
|
||||||
double precision, intent(in) :: alpha1, alpha2, beta, mu_in
|
|
||||||
|
|
||||||
integer :: i, n_pt, n_pt_out
|
|
||||||
double precision :: alpha12, alpha12_inv, alpha12_inv_2, rho12, A12_center(3), dist12, const_factor12
|
|
||||||
double precision :: p, p_inv, p_inv_2, rho, P_center(3), dist, const_factor
|
|
||||||
double precision :: dist_integral
|
|
||||||
double precision :: d(0:n_pt_in), coeff, const, factor
|
|
||||||
double precision :: accu
|
|
||||||
double precision :: p_new
|
|
||||||
|
|
||||||
double precision :: rint
|
|
||||||
|
|
||||||
|
|
||||||
! e^{-alpha1 (r - A1)^2} e^{-alpha2 (r - A2)^2} = e^{-K12} e^{-alpha12 (r - A12)^2}
|
|
||||||
alpha12 = alpha1 + alpha2
|
|
||||||
alpha12_inv = 1.d0 / alpha12
|
|
||||||
alpha12_inv_2 = 0.5d0 * alpha12_inv
|
|
||||||
rho12 = alpha1 * alpha2 * alpha12_inv
|
|
||||||
A12_center(1) = (alpha1 * A1_center(1) + alpha2 * A2_center(1)) * alpha12_inv
|
|
||||||
A12_center(2) = (alpha1 * A1_center(2) + alpha2 * A2_center(2)) * alpha12_inv
|
|
||||||
A12_center(3) = (alpha1 * A1_center(3) + alpha2 * A2_center(3)) * alpha12_inv
|
|
||||||
dist12 = (A1_center(1) - A2_center(1)) * (A1_center(1) - A2_center(1)) &
|
|
||||||
+ (A1_center(2) - A2_center(2)) * (A1_center(2) - A2_center(2)) &
|
|
||||||
+ (A1_center(3) - A2_center(3)) * (A1_center(3) - A2_center(3))
|
|
||||||
|
|
||||||
const_factor12 = dist12 * rho12
|
|
||||||
if(const_factor12 > 80.d0) then
|
|
||||||
NAI_pol_mult_erf_with1s = 0.d0
|
|
||||||
return
|
|
||||||
endif
|
|
||||||
|
|
||||||
! ---
|
|
||||||
|
|
||||||
! e^{-K12} e^{-alpha12 (r - A12)^2} e^{-beta (r - B)^2} = e^{-K} e^{-p (r - P)^2}
|
|
||||||
p = alpha12 + beta
|
|
||||||
p_inv = 1.d0 / p
|
|
||||||
p_inv_2 = 0.5d0 * p_inv
|
|
||||||
rho = alpha12 * beta * p_inv
|
|
||||||
P_center(1) = (alpha12 * A12_center(1) + beta * B_center(1)) * p_inv
|
|
||||||
P_center(2) = (alpha12 * A12_center(2) + beta * B_center(2)) * p_inv
|
|
||||||
P_center(3) = (alpha12 * A12_center(3) + beta * B_center(3)) * p_inv
|
|
||||||
dist = (A12_center(1) - B_center(1)) * (A12_center(1) - B_center(1)) &
|
|
||||||
+ (A12_center(2) - B_center(2)) * (A12_center(2) - B_center(2)) &
|
|
||||||
+ (A12_center(3) - B_center(3)) * (A12_center(3) - B_center(3))
|
|
||||||
|
|
||||||
const_factor = const_factor12 + dist * rho
|
|
||||||
if(const_factor > 80.d0) then
|
|
||||||
NAI_pol_mult_erf_with1s = 0.d0
|
|
||||||
return
|
|
||||||
endif
|
|
||||||
|
|
||||||
dist_integral = (P_center(1) - C_center(1)) * (P_center(1) - C_center(1)) &
|
|
||||||
+ (P_center(2) - C_center(2)) * (P_center(2) - C_center(2)) &
|
|
||||||
+ (P_center(3) - C_center(3)) * (P_center(3) - C_center(3))
|
|
||||||
|
|
||||||
! ---
|
|
||||||
|
|
||||||
p_new = mu_in / dsqrt(p + mu_in * mu_in)
|
|
||||||
factor = dexp(-const_factor)
|
|
||||||
coeff = dtwo_pi * factor * p_inv * p_new
|
|
||||||
|
|
||||||
n_pt = 2 * ( (power_A1(1) + power_A2(1)) + (power_A1(2) + power_A2(2)) + (power_A1(3) + power_A2(3)) )
|
|
||||||
const = p * dist_integral * p_new * p_new
|
|
||||||
if(n_pt == 0) then
|
|
||||||
NAI_pol_mult_erf_with1s = coeff * rint(0, const)
|
|
||||||
return
|
|
||||||
endif
|
|
||||||
|
|
||||||
do i = 0, n_pt_in
|
|
||||||
d(i) = 0.d0
|
|
||||||
enddo
|
|
||||||
p_new = p_new * p_new
|
|
||||||
call give_polynomial_mult_center_one_e_erf_opt( A1_center, A2_center, power_A1, power_A2, C_center, n_pt_in, d, n_pt_out, p_inv_2, p_new, P_center)
|
|
||||||
|
|
||||||
if(n_pt_out < 0) then
|
|
||||||
NAI_pol_mult_erf_with1s = 0.d0
|
|
||||||
return
|
|
||||||
endif
|
|
||||||
|
|
||||||
! sum of integrals of type : int {t,[0,1]} exp-(rho.(P-Q)^2 * t^2) * t^i
|
|
||||||
accu = 0.d0
|
|
||||||
do i = 0, n_pt_out, 2
|
|
||||||
accu += d(i) * rint(i/2, const)
|
|
||||||
enddo
|
|
||||||
NAI_pol_mult_erf_with1s = accu * coeff
|
|
||||||
|
|
||||||
end function NAI_pol_mult_erf_with1s
|
|
||||||
|
@ -1,4 +1,8 @@
|
|||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
BEGIN_PROVIDER [ double precision, ao_integrals_n_e, (ao_num,ao_num)]
|
BEGIN_PROVIDER [ double precision, ao_integrals_n_e, (ao_num,ao_num)]
|
||||||
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Nucleus-electron interaction, in the |AO| basis set.
|
! Nucleus-electron interaction, in the |AO| basis set.
|
||||||
!
|
!
|
||||||
@ -6,84 +10,100 @@ BEGIN_PROVIDER [ double precision, ao_integrals_n_e, (ao_num,ao_num)]
|
|||||||
!
|
!
|
||||||
! These integrals also contain the pseudopotential integrals.
|
! These integrals also contain the pseudopotential integrals.
|
||||||
END_DOC
|
END_DOC
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
double precision :: alpha, beta, gama, delta
|
integer :: num_A, num_B, power_A(3), power_B(3)
|
||||||
integer :: num_A,num_B
|
integer :: i, j, k, l, n_pt_in, m
|
||||||
double precision :: A_center(3),B_center(3),C_center(3)
|
double precision :: alpha, beta
|
||||||
integer :: power_A(3),power_B(3)
|
double precision :: A_center(3),B_center(3),C_center(3)
|
||||||
integer :: i,j,k,l,n_pt_in,m
|
double precision :: overlap_x,overlap_y,overlap_z,overlap,dx,NAI_pol_mult
|
||||||
double precision :: overlap_x,overlap_y,overlap_z,overlap,dx,NAI_pol_mult
|
|
||||||
|
ao_integrals_n_e = 0.d0
|
||||||
|
|
||||||
if (read_ao_integrals_n_e) then
|
if (read_ao_integrals_n_e) then
|
||||||
|
|
||||||
call ezfio_get_ao_one_e_ints_ao_integrals_n_e(ao_integrals_n_e)
|
call ezfio_get_ao_one_e_ints_ao_integrals_n_e(ao_integrals_n_e)
|
||||||
print *, 'AO N-e integrals read from disk'
|
print *, 'AO N-e integrals read from disk'
|
||||||
|
|
||||||
else
|
else
|
||||||
|
|
||||||
ao_integrals_n_e = 0.d0
|
if(use_cosgtos) then
|
||||||
|
!print *, " use_cosgtos for ao_integrals_n_e ?", use_cosgtos
|
||||||
|
|
||||||
! _
|
do j = 1, ao_num
|
||||||
! /| / |_)
|
do i = 1, ao_num
|
||||||
! | / | \
|
ao_integrals_n_e(i,j) = ao_integrals_n_e_cosgtos(i,j)
|
||||||
!
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
!$OMP PARALLEL &
|
else
|
||||||
!$OMP DEFAULT (NONE) &
|
|
||||||
!$OMP PRIVATE (i,j,k,l,m,alpha,beta,A_center,B_center,C_center,power_A,power_B,&
|
|
||||||
!$OMP num_A,num_B,Z,c,n_pt_in) &
|
|
||||||
!$OMP SHARED (ao_num,ao_prim_num,ao_expo_ordered_transp,ao_power,ao_nucl,nucl_coord,ao_coef_normalized_ordered_transp,&
|
|
||||||
!$OMP n_pt_max_integrals,ao_integrals_n_e,nucl_num,nucl_charge)
|
|
||||||
|
|
||||||
n_pt_in = n_pt_max_integrals
|
!$OMP PARALLEL &
|
||||||
|
!$OMP DEFAULT (NONE) &
|
||||||
|
!$OMP PRIVATE (i,j,k,l,m,alpha,beta,A_center,B_center,C_center,power_A,power_B,&
|
||||||
|
!$OMP num_A,num_B,Z,c,c1,n_pt_in) &
|
||||||
|
!$OMP SHARED (ao_num,ao_prim_num,ao_expo_ordered_transp,ao_power,ao_nucl,nucl_coord,ao_coef_normalized_ordered_transp,&
|
||||||
|
!$OMP n_pt_max_integrals,ao_integrals_n_e,nucl_num,nucl_charge)
|
||||||
|
|
||||||
!$OMP DO SCHEDULE (dynamic)
|
n_pt_in = n_pt_max_integrals
|
||||||
|
|
||||||
do j = 1, ao_num
|
!$OMP DO SCHEDULE (dynamic)
|
||||||
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
|
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)
|
||||||
|
|
||||||
num_B = ao_nucl(i)
|
do i = 1, ao_num
|
||||||
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)
|
num_B = ao_nucl(i)
|
||||||
alpha = ao_expo_ordered_transp(l,j)
|
power_B(1:3)= ao_power(i,1:3)
|
||||||
|
B_center(1:3) = nucl_coord(num_B,1:3)
|
||||||
|
|
||||||
do m=1,ao_prim_num(i)
|
do l=1,ao_prim_num(j)
|
||||||
beta = ao_expo_ordered_transp(m,i)
|
alpha = ao_expo_ordered_transp(l,j)
|
||||||
|
|
||||||
double precision :: c
|
do m=1,ao_prim_num(i)
|
||||||
c = 0.d0
|
beta = ao_expo_ordered_transp(m,i)
|
||||||
|
|
||||||
do k = 1, nucl_num
|
double precision :: c, c1
|
||||||
double precision :: Z
|
c = 0.d0
|
||||||
Z = nucl_charge(k)
|
|
||||||
|
|
||||||
C_center(1:3) = nucl_coord(k,1:3)
|
do k = 1, nucl_num
|
||||||
|
double precision :: Z
|
||||||
|
Z = nucl_charge(k)
|
||||||
|
|
||||||
c = c - Z * NAI_pol_mult(A_center,B_center, &
|
C_center(1:3) = nucl_coord(k,1:3)
|
||||||
power_A,power_B,alpha,beta,C_center,n_pt_in)
|
|
||||||
|
|
||||||
|
!print *, ' '
|
||||||
|
!print *, A_center, B_center, C_center, power_A, power_B
|
||||||
|
!print *, alpha, beta
|
||||||
|
|
||||||
|
c1 = NAI_pol_mult( A_center, B_center, power_A, power_B &
|
||||||
|
, alpha, beta, C_center, n_pt_in )
|
||||||
|
|
||||||
|
!print *, ' c1 = ', c1
|
||||||
|
|
||||||
|
c = c - Z * c1
|
||||||
|
|
||||||
|
enddo
|
||||||
|
ao_integrals_n_e(i,j) = ao_integrals_n_e(i,j) &
|
||||||
|
+ ao_coef_normalized_ordered_transp(l,j) &
|
||||||
|
* ao_coef_normalized_ordered_transp(m,i) * c
|
||||||
enddo
|
enddo
|
||||||
ao_integrals_n_e(i,j) = ao_integrals_n_e(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
|
||||||
IF (DO_PSEUDO) THEN
|
|
||||||
|
endif
|
||||||
|
|
||||||
|
|
||||||
|
IF(do_pseudo) THEN
|
||||||
ao_integrals_n_e += ao_pseudo_integrals
|
ao_integrals_n_e += ao_pseudo_integrals
|
||||||
ENDIF
|
ENDIF
|
||||||
IF(point_charges) THEN
|
|
||||||
ao_integrals_n_e += ao_integrals_pt_chrg
|
|
||||||
ENDIF
|
|
||||||
|
|
||||||
|
|
||||||
endif
|
endif
|
||||||
|
|
||||||
@ -102,7 +122,7 @@ BEGIN_PROVIDER [ double precision, ao_integrals_n_e_imag, (ao_num,ao_num)]
|
|||||||
! :math:`\langle \chi_i | -\sum_A \frac{1}{|r-R_A|} | \chi_j \rangle`
|
! :math:`\langle \chi_i | -\sum_A \frac{1}{|r-R_A|} | \chi_j \rangle`
|
||||||
END_DOC
|
END_DOC
|
||||||
implicit none
|
implicit none
|
||||||
double precision :: alpha, beta, gama, delta
|
double precision :: alpha, beta
|
||||||
integer :: num_A,num_B
|
integer :: num_A,num_B
|
||||||
double precision :: A_center(3),B_center(3),C_center(3)
|
double precision :: A_center(3),B_center(3),C_center(3)
|
||||||
integer :: power_A(3),power_B(3)
|
integer :: power_A(3),power_B(3)
|
||||||
@ -125,7 +145,7 @@ BEGIN_PROVIDER [ double precision, ao_integrals_n_e_per_atom, (ao_num,ao_num,nuc
|
|||||||
! :math:`\langle \chi_i | -\frac{1}{|r-R_A|} | \chi_j \rangle`
|
! :math:`\langle \chi_i | -\frac{1}{|r-R_A|} | \chi_j \rangle`
|
||||||
END_DOC
|
END_DOC
|
||||||
implicit none
|
implicit none
|
||||||
double precision :: alpha, beta, gama, delta
|
double precision :: alpha, beta
|
||||||
integer :: i_c,num_A,num_B
|
integer :: i_c,num_A,num_B
|
||||||
double precision :: A_center(3),B_center(3),C_center(3)
|
double precision :: A_center(3),B_center(3),C_center(3)
|
||||||
integer :: power_A(3),power_B(3)
|
integer :: power_A(3),power_B(3)
|
||||||
@ -268,6 +288,7 @@ double precision function NAI_pol_mult(A_center,B_center,power_A,power_B,alpha,b
|
|||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
subroutine give_polynomial_mult_center_one_e(A_center,B_center,alpha,beta,power_A,power_B,C_center,n_pt_in,d,n_pt_out)
|
subroutine give_polynomial_mult_center_one_e(A_center,B_center,alpha,beta,power_A,power_B,C_center,n_pt_in,d,n_pt_out)
|
||||||
implicit none
|
implicit none
|
||||||
@ -579,61 +600,3 @@ double precision function V_r(n,alpha)
|
|||||||
end
|
end
|
||||||
|
|
||||||
|
|
||||||
double precision function V_phi(n,m)
|
|
||||||
implicit none
|
|
||||||
BEGIN_DOC
|
|
||||||
! Computes the angular $\phi$ part of the nuclear attraction integral:
|
|
||||||
!
|
|
||||||
! $\int_{0}^{2 \pi} \cos(\phi)^n \sin(\phi)^m d\phi$.
|
|
||||||
END_DOC
|
|
||||||
integer :: n,m, i
|
|
||||||
double precision :: prod, Wallis
|
|
||||||
prod = 1.d0
|
|
||||||
do i = 0,shiftr(n,1)-1
|
|
||||||
prod = prod/ (1.d0 + dfloat(m+1)/dfloat(n-i-i-1))
|
|
||||||
enddo
|
|
||||||
V_phi = 4.d0 * prod * Wallis(m)
|
|
||||||
end
|
|
||||||
|
|
||||||
|
|
||||||
double precision function V_theta(n,m)
|
|
||||||
implicit none
|
|
||||||
BEGIN_DOC
|
|
||||||
! Computes the angular $\theta$ part of the nuclear attraction integral:
|
|
||||||
!
|
|
||||||
! $\int_{0}^{\pi} \cos(\theta)^n \sin(\theta)^m d\theta$
|
|
||||||
END_DOC
|
|
||||||
integer :: n,m,i
|
|
||||||
double precision :: Wallis, prod
|
|
||||||
include 'utils/constants.include.F'
|
|
||||||
V_theta = 0.d0
|
|
||||||
prod = 1.d0
|
|
||||||
do i = 0,shiftr(n,1)-1
|
|
||||||
prod = prod / (1.d0 + dfloat(m+1)/dfloat(n-i-i-1))
|
|
||||||
enddo
|
|
||||||
V_theta = (prod+prod) * Wallis(m)
|
|
||||||
end
|
|
||||||
|
|
||||||
|
|
||||||
double precision function Wallis(n)
|
|
||||||
implicit none
|
|
||||||
BEGIN_DOC
|
|
||||||
! Wallis integral:
|
|
||||||
!
|
|
||||||
! $\int_{0}^{\pi} \cos(\theta)^n d\theta$.
|
|
||||||
END_DOC
|
|
||||||
double precision :: fact
|
|
||||||
integer :: n,p
|
|
||||||
include 'utils/constants.include.F'
|
|
||||||
if(iand(n,1).eq.0)then
|
|
||||||
Wallis = fact(shiftr(n,1))
|
|
||||||
Wallis = pi * fact(n) / (dble(ibset(0_8,n)) * (Wallis+Wallis)*Wallis)
|
|
||||||
else
|
|
||||||
p = shiftr(n,1)
|
|
||||||
Wallis = fact(p)
|
|
||||||
Wallis = dble(ibset(0_8,p+p)) * Wallis*Wallis / fact(p+p+1)
|
|
||||||
endif
|
|
||||||
|
|
||||||
end
|
|
||||||
|
|
||||||
|
|
||||||
|
@ -53,13 +53,13 @@ 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
|
!if( j1b_type .eq. 1 ) then
|
||||||
!print *, ' j1b type 1 is added'
|
! !print *, ' j1b type 1 is added'
|
||||||
integral = integral + j1b_gauss_2e_j1(i, k, j, l)
|
! integral = integral + j1b_gauss_2e_j1(i, k, j, l)
|
||||||
elseif( j1b_type .eq. 2 ) then
|
!elseif( j1b_type .eq. 2 ) then
|
||||||
!print *, ' j1b type 2 is added'
|
! !print *, ' j1b type 2 is added'
|
||||||
integral = integral + j1b_gauss_2e_j2(i, k, j, l)
|
! integral = integral + j1b_gauss_2e_j2(i, k, j, l)
|
||||||
endif
|
!endif
|
||||||
|
|
||||||
if(abs(integral) < thr) then
|
if(abs(integral) < thr) then
|
||||||
cycle
|
cycle
|
||||||
|
@ -1,102 +1,123 @@
|
|||||||
double precision function ao_two_e_integral(i,j,k,l)
|
|
||||||
implicit none
|
! ---
|
||||||
|
|
||||||
|
double precision function ao_two_e_integral(i, j, k, l)
|
||||||
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! integral of the AO basis <ik|jl> or (ij|kl)
|
! integral of the AO basis <ik|jl> or (ij|kl)
|
||||||
! i(r1) j(r1) 1/r12 k(r2) l(r2)
|
! i(r1) j(r1) 1/r12 k(r2) l(r2)
|
||||||
END_DOC
|
END_DOC
|
||||||
|
|
||||||
integer,intent(in) :: i,j,k,l
|
implicit none
|
||||||
integer :: p,q,r,s
|
|
||||||
double precision :: I_center(3),J_center(3),K_center(3),L_center(3)
|
|
||||||
integer :: num_i,num_j,num_k,num_l,dim1,I_power(3),J_power(3),K_power(3),L_power(3)
|
|
||||||
double precision :: integral
|
|
||||||
include 'utils/constants.include.F'
|
include 'utils/constants.include.F'
|
||||||
|
|
||||||
|
integer, intent(in) :: i, j, k, l
|
||||||
|
|
||||||
|
integer :: p, q, r, s
|
||||||
|
integer :: num_i,num_j,num_k,num_l,dim1,I_power(3),J_power(3),K_power(3),L_power(3)
|
||||||
|
integer :: iorder_p(3), iorder_q(3)
|
||||||
|
double precision :: I_center(3), J_center(3), K_center(3), L_center(3)
|
||||||
|
double precision :: integral
|
||||||
double precision :: P_new(0:max_dim,3),P_center(3),fact_p,pp
|
double precision :: P_new(0:max_dim,3),P_center(3),fact_p,pp
|
||||||
double precision :: Q_new(0:max_dim,3),Q_center(3),fact_q,qq
|
double precision :: Q_new(0:max_dim,3),Q_center(3),fact_q,qq
|
||||||
integer :: iorder_p(3), iorder_q(3)
|
|
||||||
double precision :: ao_two_e_integral_schwartz_accel
|
double precision :: ao_two_e_integral_schwartz_accel
|
||||||
|
|
||||||
if (ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then
|
double precision :: ao_two_e_integral_cosgtos
|
||||||
ao_two_e_integral = ao_two_e_integral_schwartz_accel(i,j,k,l)
|
|
||||||
else
|
|
||||||
|
|
||||||
dim1 = n_pt_max_integrals
|
|
||||||
|
|
||||||
num_i = ao_nucl(i)
|
if(use_cosgtos) then
|
||||||
num_j = ao_nucl(j)
|
!print *, ' use_cosgtos for ao_two_e_integral ?', use_cosgtos
|
||||||
num_k = ao_nucl(k)
|
|
||||||
num_l = ao_nucl(l)
|
|
||||||
ao_two_e_integral = 0.d0
|
|
||||||
|
|
||||||
if (num_i /= num_j .or. num_k /= num_l .or. num_j /= num_k)then
|
ao_two_e_integral = ao_two_e_integral_cosgtos(i, j, k, l)
|
||||||
do p = 1, 3
|
|
||||||
I_power(p) = ao_power(i,p)
|
|
||||||
J_power(p) = ao_power(j,p)
|
|
||||||
K_power(p) = ao_power(k,p)
|
|
||||||
L_power(p) = ao_power(l,p)
|
|
||||||
I_center(p) = nucl_coord(num_i,p)
|
|
||||||
J_center(p) = nucl_coord(num_j,p)
|
|
||||||
K_center(p) = nucl_coord(num_k,p)
|
|
||||||
L_center(p) = nucl_coord(num_l,p)
|
|
||||||
enddo
|
|
||||||
|
|
||||||
double precision :: coef1, coef2, coef3, coef4
|
else
|
||||||
double precision :: p_inv,q_inv
|
|
||||||
double precision :: general_primitive_integral
|
|
||||||
|
|
||||||
do p = 1, ao_prim_num(i)
|
if (ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then
|
||||||
coef1 = ao_coef_normalized_ordered_transp(p,i)
|
|
||||||
do q = 1, ao_prim_num(j)
|
ao_two_e_integral = ao_two_e_integral_schwartz_accel(i,j,k,l)
|
||||||
coef2 = coef1*ao_coef_normalized_ordered_transp(q,j)
|
|
||||||
call give_explicit_poly_and_gaussian(P_new,P_center,pp,fact_p,iorder_p,&
|
|
||||||
ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j), &
|
|
||||||
I_power,J_power,I_center,J_center,dim1)
|
|
||||||
p_inv = 1.d0/pp
|
|
||||||
do r = 1, ao_prim_num(k)
|
|
||||||
coef3 = coef2*ao_coef_normalized_ordered_transp(r,k)
|
|
||||||
do s = 1, ao_prim_num(l)
|
|
||||||
coef4 = coef3*ao_coef_normalized_ordered_transp(s,l)
|
|
||||||
call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,&
|
|
||||||
ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l), &
|
|
||||||
K_power,L_power,K_center,L_center,dim1)
|
|
||||||
q_inv = 1.d0/qq
|
|
||||||
integral = general_primitive_integral(dim1, &
|
|
||||||
P_new,P_center,fact_p,pp,p_inv,iorder_p, &
|
|
||||||
Q_new,Q_center,fact_q,qq,q_inv,iorder_q)
|
|
||||||
ao_two_e_integral = ao_two_e_integral + coef4 * integral
|
|
||||||
enddo ! s
|
|
||||||
enddo ! r
|
|
||||||
enddo ! q
|
|
||||||
enddo ! p
|
|
||||||
|
|
||||||
else
|
else
|
||||||
|
|
||||||
do p = 1, 3
|
dim1 = n_pt_max_integrals
|
||||||
I_power(p) = ao_power(i,p)
|
|
||||||
J_power(p) = ao_power(j,p)
|
|
||||||
K_power(p) = ao_power(k,p)
|
|
||||||
L_power(p) = ao_power(l,p)
|
|
||||||
enddo
|
|
||||||
double precision :: ERI
|
|
||||||
|
|
||||||
do p = 1, ao_prim_num(i)
|
num_i = ao_nucl(i)
|
||||||
coef1 = ao_coef_normalized_ordered_transp(p,i)
|
num_j = ao_nucl(j)
|
||||||
do q = 1, ao_prim_num(j)
|
num_k = ao_nucl(k)
|
||||||
coef2 = coef1*ao_coef_normalized_ordered_transp(q,j)
|
num_l = ao_nucl(l)
|
||||||
do r = 1, ao_prim_num(k)
|
ao_two_e_integral = 0.d0
|
||||||
coef3 = coef2*ao_coef_normalized_ordered_transp(r,k)
|
|
||||||
do s = 1, ao_prim_num(l)
|
if (num_i /= num_j .or. num_k /= num_l .or. num_j /= num_k)then
|
||||||
coef4 = coef3*ao_coef_normalized_ordered_transp(s,l)
|
do p = 1, 3
|
||||||
integral = ERI( &
|
I_power(p) = ao_power(i,p)
|
||||||
ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),&
|
J_power(p) = ao_power(j,p)
|
||||||
I_power(1),J_power(1),K_power(1),L_power(1), &
|
K_power(p) = ao_power(k,p)
|
||||||
I_power(2),J_power(2),K_power(2),L_power(2), &
|
L_power(p) = ao_power(l,p)
|
||||||
I_power(3),J_power(3),K_power(3),L_power(3))
|
I_center(p) = nucl_coord(num_i,p)
|
||||||
ao_two_e_integral = ao_two_e_integral + coef4 * integral
|
J_center(p) = nucl_coord(num_j,p)
|
||||||
enddo ! s
|
K_center(p) = nucl_coord(num_k,p)
|
||||||
enddo ! r
|
L_center(p) = nucl_coord(num_l,p)
|
||||||
enddo ! q
|
enddo
|
||||||
enddo ! p
|
|
||||||
|
double precision :: coef1, coef2, coef3, coef4
|
||||||
|
double precision :: p_inv,q_inv
|
||||||
|
double precision :: general_primitive_integral
|
||||||
|
|
||||||
|
do p = 1, ao_prim_num(i)
|
||||||
|
coef1 = ao_coef_normalized_ordered_transp(p,i)
|
||||||
|
do q = 1, ao_prim_num(j)
|
||||||
|
coef2 = coef1*ao_coef_normalized_ordered_transp(q,j)
|
||||||
|
call give_explicit_poly_and_gaussian(P_new,P_center,pp,fact_p,iorder_p,&
|
||||||
|
ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j), &
|
||||||
|
I_power,J_power,I_center,J_center,dim1)
|
||||||
|
p_inv = 1.d0/pp
|
||||||
|
do r = 1, ao_prim_num(k)
|
||||||
|
coef3 = coef2*ao_coef_normalized_ordered_transp(r,k)
|
||||||
|
do s = 1, ao_prim_num(l)
|
||||||
|
coef4 = coef3*ao_coef_normalized_ordered_transp(s,l)
|
||||||
|
call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,&
|
||||||
|
ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l), &
|
||||||
|
K_power,L_power,K_center,L_center,dim1)
|
||||||
|
q_inv = 1.d0/qq
|
||||||
|
integral = general_primitive_integral(dim1, &
|
||||||
|
P_new,P_center,fact_p,pp,p_inv,iorder_p, &
|
||||||
|
Q_new,Q_center,fact_q,qq,q_inv,iorder_q)
|
||||||
|
ao_two_e_integral = ao_two_e_integral + coef4 * integral
|
||||||
|
enddo ! s
|
||||||
|
enddo ! r
|
||||||
|
enddo ! q
|
||||||
|
enddo ! p
|
||||||
|
|
||||||
|
else
|
||||||
|
|
||||||
|
do p = 1, 3
|
||||||
|
I_power(p) = ao_power(i,p)
|
||||||
|
J_power(p) = ao_power(j,p)
|
||||||
|
K_power(p) = ao_power(k,p)
|
||||||
|
L_power(p) = ao_power(l,p)
|
||||||
|
enddo
|
||||||
|
double precision :: ERI
|
||||||
|
|
||||||
|
do p = 1, ao_prim_num(i)
|
||||||
|
coef1 = ao_coef_normalized_ordered_transp(p,i)
|
||||||
|
do q = 1, ao_prim_num(j)
|
||||||
|
coef2 = coef1*ao_coef_normalized_ordered_transp(q,j)
|
||||||
|
do r = 1, ao_prim_num(k)
|
||||||
|
coef3 = coef2*ao_coef_normalized_ordered_transp(r,k)
|
||||||
|
do s = 1, ao_prim_num(l)
|
||||||
|
coef4 = coef3*ao_coef_normalized_ordered_transp(s,l)
|
||||||
|
integral = ERI( &
|
||||||
|
ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),&
|
||||||
|
I_power(1),J_power(1),K_power(1),L_power(1), &
|
||||||
|
I_power(2),J_power(2),K_power(2),L_power(2), &
|
||||||
|
I_power(3),J_power(3),K_power(3),L_power(3))
|
||||||
|
ao_two_e_integral = ao_two_e_integral + coef4 * integral
|
||||||
|
enddo ! s
|
||||||
|
enddo ! r
|
||||||
|
enddo ! q
|
||||||
|
enddo ! p
|
||||||
|
|
||||||
|
endif
|
||||||
|
|
||||||
endif
|
endif
|
||||||
|
|
||||||
@ -104,6 +125,8 @@ double precision function ao_two_e_integral(i,j,k,l)
|
|||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
double precision function ao_two_e_integral_schwartz_accel(i,j,k,l)
|
double precision function ao_two_e_integral_schwartz_accel(i,j,k,l)
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
@ -421,14 +444,17 @@ BEGIN_PROVIDER [ logical, ao_two_e_integrals_in_map ]
|
|||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
BEGIN_PROVIDER [ double precision, ao_two_e_integral_schwartz,(ao_num,ao_num) ]
|
! ---
|
||||||
implicit none
|
|
||||||
|
BEGIN_PROVIDER [ double precision, ao_two_e_integral_schwartz, (ao_num, ao_num) ]
|
||||||
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Needed to compute Schwartz inequalities
|
! Needed to compute Schwartz inequalities
|
||||||
END_DOC
|
END_DOC
|
||||||
|
|
||||||
integer :: i,k
|
implicit none
|
||||||
double precision :: ao_two_e_integral,cpu_1,cpu_2, wall_1, wall_2
|
integer :: i, k
|
||||||
|
double precision :: ao_two_e_integral,cpu_1,cpu_2, wall_1, wall_2
|
||||||
|
|
||||||
ao_two_e_integral_schwartz(1,1) = ao_two_e_integral(1,1,1,1)
|
ao_two_e_integral_schwartz(1,1) = ao_two_e_integral(1,1,1,1)
|
||||||
!$OMP PARALLEL DO PRIVATE(i,k) &
|
!$OMP PARALLEL DO PRIVATE(i,k) &
|
||||||
@ -445,6 +471,7 @@ BEGIN_PROVIDER [ double precision, ao_two_e_integral_schwartz,(ao_num,ao_num) ]
|
|||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
double precision function general_primitive_integral(dim, &
|
double precision function general_primitive_integral(dim, &
|
||||||
P_new,P_center,fact_p,p,p_inv,iorder_p, &
|
P_new,P_center,fact_p,p,p_inv,iorder_p, &
|
||||||
|
@ -64,3 +64,15 @@ doc: Number of angular extra_grid points given from input. Warning, this number
|
|||||||
interface: ezfio,provider,ocaml
|
interface: ezfio,provider,ocaml
|
||||||
default: 1202
|
default: 1202
|
||||||
|
|
||||||
|
[rad_grid_type]
|
||||||
|
type: character*(32)
|
||||||
|
doc: method used to sample the radial space. Possible choices are [KNOWLES | GILL]
|
||||||
|
interface: ezfio,provider,ocaml
|
||||||
|
default: KNOWLES
|
||||||
|
|
||||||
|
[extra_rad_grid_type]
|
||||||
|
type: character*(32)
|
||||||
|
doc: method used to sample the radial space. Possible choices are [KNOWLES | GILL]
|
||||||
|
interface: ezfio,provider,ocaml
|
||||||
|
default: KNOWLES
|
||||||
|
|
||||||
|
@ -1,96 +1,149 @@
|
|||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
BEGIN_PROVIDER [integer, n_points_extra_radial_grid]
|
BEGIN_PROVIDER [integer, n_points_extra_radial_grid]
|
||||||
&BEGIN_PROVIDER [integer, n_points_extra_integration_angular]
|
&BEGIN_PROVIDER [integer, n_points_extra_integration_angular]
|
||||||
implicit none
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! n_points_extra_radial_grid = number of radial grid points_extra per atom
|
! n_points_extra_radial_grid = number of radial grid points_extra per atom
|
||||||
!
|
!
|
||||||
! n_points_extra_integration_angular = number of angular grid points_extra per atom
|
! n_points_extra_integration_angular = number of angular grid points_extra per atom
|
||||||
!
|
!
|
||||||
! These numbers are automatically set by setting the grid_type_sgn parameter
|
! These numbers are automatically set by setting the grid_type_sgn parameter
|
||||||
END_DOC
|
END_DOC
|
||||||
if(.not.my_extra_grid_becke)then
|
|
||||||
select case (extra_grid_type_sgn)
|
implicit none
|
||||||
case(0)
|
|
||||||
n_points_extra_radial_grid = 23
|
if(.not.my_extra_grid_becke)then
|
||||||
n_points_extra_integration_angular = 170
|
select case (extra_grid_type_sgn)
|
||||||
case(1)
|
case(0)
|
||||||
n_points_extra_radial_grid = 50
|
n_points_extra_radial_grid = 23
|
||||||
n_points_extra_integration_angular = 194
|
n_points_extra_integration_angular = 170
|
||||||
case(2)
|
case(1)
|
||||||
n_points_extra_radial_grid = 75
|
n_points_extra_radial_grid = 50
|
||||||
n_points_extra_integration_angular = 302
|
n_points_extra_integration_angular = 194
|
||||||
case(3)
|
case(2)
|
||||||
n_points_extra_radial_grid = 99
|
n_points_extra_radial_grid = 75
|
||||||
n_points_extra_integration_angular = 590
|
n_points_extra_integration_angular = 302
|
||||||
case default
|
case(3)
|
||||||
write(*,*) '!!! Quadrature grid not available !!!'
|
n_points_extra_radial_grid = 99
|
||||||
stop
|
n_points_extra_integration_angular = 590
|
||||||
end select
|
case default
|
||||||
else
|
write(*,*) '!!! Quadrature grid not available !!!'
|
||||||
n_points_extra_radial_grid = my_n_pt_r_extra_grid
|
stop
|
||||||
n_points_extra_integration_angular = my_n_pt_a_extra_grid
|
end select
|
||||||
endif
|
else
|
||||||
|
n_points_extra_radial_grid = my_n_pt_r_extra_grid
|
||||||
|
n_points_extra_integration_angular = my_n_pt_a_extra_grid
|
||||||
|
endif
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
BEGIN_PROVIDER [integer, n_points_extra_grid_per_atom]
|
BEGIN_PROVIDER [integer, n_points_extra_grid_per_atom]
|
||||||
implicit none
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Number of grid points_extra per atom
|
! Number of grid points_extra per atom
|
||||||
END_DOC
|
END_DOC
|
||||||
|
|
||||||
|
implicit none
|
||||||
n_points_extra_grid_per_atom = n_points_extra_integration_angular * n_points_extra_radial_grid
|
n_points_extra_grid_per_atom = n_points_extra_integration_angular * n_points_extra_radial_grid
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
BEGIN_PROVIDER [double precision, grid_points_extra_radial, (n_points_extra_radial_grid)]
|
BEGIN_PROVIDER [double precision, grid_points_extra_radial, (n_points_extra_radial_grid)]
|
||||||
&BEGIN_PROVIDER [double precision, dr_radial_extra_integral]
|
&BEGIN_PROVIDER [double precision, dr_radial_extra_integral]
|
||||||
|
|
||||||
implicit none
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! points_extra in [0,1] to map the radial integral [0,\infty]
|
! points_extra in [0,1] to map the radial integral [0,\infty]
|
||||||
END_DOC
|
END_DOC
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer :: i
|
||||||
|
|
||||||
dr_radial_extra_integral = 1.d0/dble(n_points_extra_radial_grid-1)
|
dr_radial_extra_integral = 1.d0/dble(n_points_extra_radial_grid-1)
|
||||||
integer :: i
|
|
||||||
do i = 1, n_points_extra_radial_grid
|
do i = 1, n_points_extra_radial_grid
|
||||||
grid_points_extra_radial(i) = dble(i-1) * dr_radial_extra_integral
|
grid_points_extra_radial(i) = dble(i-1) * dr_radial_extra_integral
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
BEGIN_PROVIDER [double precision, grid_points_extra_per_atom, (3,n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num)]
|
BEGIN_PROVIDER [double precision, grid_points_extra_per_atom, (3,n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num)]
|
||||||
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! x,y,z coordinates of grid points_extra used for integration in 3d space
|
! x,y,z coordinates of grid points_extra used for integration in 3d space
|
||||||
END_DOC
|
END_DOC
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
integer :: i,j,k
|
integer :: i, j, k
|
||||||
double precision :: dr,x_ref,y_ref,z_ref
|
double precision :: dr, x_ref, y_ref, z_ref
|
||||||
double precision :: knowles_function
|
double precision :: x, r, tmp
|
||||||
do i = 1, nucl_num
|
double precision, external :: knowles_function
|
||||||
x_ref = nucl_coord(i,1)
|
|
||||||
y_ref = nucl_coord(i,2)
|
|
||||||
z_ref = nucl_coord(i,3)
|
|
||||||
do j = 1, n_points_extra_radial_grid-1
|
|
||||||
double precision :: x,r
|
|
||||||
! x value for the mapping of the [0, +\infty] to [0,1]
|
|
||||||
x = grid_points_extra_radial(j)
|
|
||||||
|
|
||||||
! value of the radial coordinate for the integration
|
grid_points_extra_per_atom = 0.d0
|
||||||
r = knowles_function(alpha_knowles(grid_atomic_number(i)),m_knowles,x)
|
|
||||||
|
|
||||||
! explicit values of the grid points_extra centered around each atom
|
PROVIDE extra_rad_grid_type
|
||||||
do k = 1, n_points_extra_integration_angular
|
if(extra_rad_grid_type .eq. "KNOWLES") then
|
||||||
grid_points_extra_per_atom(1,k,j,i) = &
|
|
||||||
x_ref + angular_quadrature_points_extra(k,1) * r
|
do i = 1, nucl_num
|
||||||
grid_points_extra_per_atom(2,k,j,i) = &
|
x_ref = nucl_coord(i,1)
|
||||||
y_ref + angular_quadrature_points_extra(k,2) * r
|
y_ref = nucl_coord(i,2)
|
||||||
grid_points_extra_per_atom(3,k,j,i) = &
|
z_ref = nucl_coord(i,3)
|
||||||
z_ref + angular_quadrature_points_extra(k,3) * r
|
do j = 1, n_points_extra_radial_grid-1
|
||||||
|
|
||||||
|
! x value for the mapping of the [0, +\infty] to [0,1]
|
||||||
|
x = grid_points_extra_radial(j)
|
||||||
|
! value of the radial coordinate for the integration
|
||||||
|
r = knowles_function(alpha_knowles(grid_atomic_number(i)), m_knowles, x)
|
||||||
|
|
||||||
|
! explicit values of the grid points_extra centered around each atom
|
||||||
|
do k = 1, n_points_extra_integration_angular
|
||||||
|
grid_points_extra_per_atom(1,k,j,i) = x_ref + angular_quadrature_points_extra(k,1) * r
|
||||||
|
grid_points_extra_per_atom(2,k,j,i) = y_ref + angular_quadrature_points_extra(k,2) * r
|
||||||
|
grid_points_extra_per_atom(3,k,j,i) = z_ref + angular_quadrature_points_extra(k,3) * r
|
||||||
|
enddo
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
enddo
|
|
||||||
|
elseif(extra_rad_grid_type .eq. "GILL") then
|
||||||
|
! GILL & CHIEN, 2002
|
||||||
|
|
||||||
|
do i = 1, nucl_num
|
||||||
|
x_ref = nucl_coord(i,1)
|
||||||
|
y_ref = nucl_coord(i,2)
|
||||||
|
z_ref = nucl_coord(i,3)
|
||||||
|
do j = 1, n_points_extra_radial_grid-1
|
||||||
|
|
||||||
|
r = R_gill * dble(j-1)**2 / dble(n_points_extra_radial_grid-j+1)**2
|
||||||
|
|
||||||
|
! explicit values of the grid points_extra centered around each atom
|
||||||
|
do k = 1, n_points_extra_integration_angular
|
||||||
|
grid_points_extra_per_atom(1,k,j,i) = x_ref + angular_quadrature_points_extra(k,1) * r
|
||||||
|
grid_points_extra_per_atom(2,k,j,i) = y_ref + angular_quadrature_points_extra(k,2) * r
|
||||||
|
grid_points_extra_per_atom(3,k,j,i) = z_ref + angular_quadrature_points_extra(k,3) * r
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
else
|
||||||
|
|
||||||
|
print*, " extra_rad_grid_type = ", extra_rad_grid_type, ' is not implemented'
|
||||||
|
stop
|
||||||
|
|
||||||
|
endif
|
||||||
|
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
BEGIN_PROVIDER [double precision, weight_at_r_extra, (n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num) ]
|
BEGIN_PROVIDER [double precision, weight_at_r_extra, (n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num) ]
|
||||||
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Weight function at grid points_extra : w_n(r) according to the equation (22)
|
! Weight function at grid points_extra : w_n(r) according to the equation (22)
|
||||||
! of Becke original paper (JCP, 88, 1988)
|
! of Becke original paper (JCP, 88, 1988)
|
||||||
@ -99,11 +152,14 @@ BEGIN_PROVIDER [double precision, weight_at_r_extra, (n_points_extra_integration
|
|||||||
! represented by the last dimension and the points_extra are labelled by the
|
! represented by the last dimension and the points_extra are labelled by the
|
||||||
! other dimensions.
|
! other dimensions.
|
||||||
END_DOC
|
END_DOC
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
integer :: i,j,k,l,m
|
integer :: i, j, k, l, m
|
||||||
double precision :: r(3)
|
double precision :: r(3)
|
||||||
double precision :: accu,cell_function_becke
|
double precision :: accu
|
||||||
double precision :: tmp_array(nucl_num)
|
double precision :: tmp_array(nucl_num)
|
||||||
|
double precision, external :: cell_function_becke
|
||||||
|
|
||||||
! run over all points_extra in space
|
! run over all points_extra in space
|
||||||
! that are referred to each atom
|
! that are referred to each atom
|
||||||
do j = 1, nucl_num
|
do j = 1, nucl_num
|
||||||
@ -114,6 +170,7 @@ BEGIN_PROVIDER [double precision, weight_at_r_extra, (n_points_extra_integration
|
|||||||
r(1) = grid_points_extra_per_atom(1,l,k,j)
|
r(1) = grid_points_extra_per_atom(1,l,k,j)
|
||||||
r(2) = grid_points_extra_per_atom(2,l,k,j)
|
r(2) = grid_points_extra_per_atom(2,l,k,j)
|
||||||
r(3) = grid_points_extra_per_atom(3,l,k,j)
|
r(3) = grid_points_extra_per_atom(3,l,k,j)
|
||||||
|
|
||||||
accu = 0.d0
|
accu = 0.d0
|
||||||
! For each of these points_extra in space, ou need to evaluate the P_n(r)
|
! For each of these points_extra in space, ou need to evaluate the P_n(r)
|
||||||
do i = 1, nucl_num
|
do i = 1, nucl_num
|
||||||
@ -124,18 +181,19 @@ BEGIN_PROVIDER [double precision, weight_at_r_extra, (n_points_extra_integration
|
|||||||
enddo
|
enddo
|
||||||
accu = 1.d0/accu
|
accu = 1.d0/accu
|
||||||
weight_at_r_extra(l,k,j) = tmp_array(j) * accu
|
weight_at_r_extra(l,k,j) = tmp_array(j) * accu
|
||||||
|
|
||||||
if(isnan(weight_at_r_extra(l,k,j)))then
|
if(isnan(weight_at_r_extra(l,k,j)))then
|
||||||
print*,'isnan(weight_at_r_extra(l,k,j))'
|
print*,'isnan(weight_at_r_extra(l,k,j))'
|
||||||
print*,l,k,j
|
print*,l,k,j
|
||||||
accu = 0.d0
|
accu = 0.d0
|
||||||
do i = 1, nucl_num
|
do i = 1, nucl_num
|
||||||
! function defined for each atom "i" by equation (13) and (21) with k == 3
|
! function defined for each atom "i" by equation (13) and (21) with k == 3
|
||||||
tmp_array(i) = cell_function_becke(r,i) ! P_n(r)
|
tmp_array(i) = cell_function_becke(r,i) ! P_n(r)
|
||||||
print*,i,tmp_array(i)
|
print*,i,tmp_array(i)
|
||||||
! Then you compute the summ the P_n(r) function for each of the "r" points_extra
|
! Then you compute the summ the P_n(r) function for each of the "r" points_extra
|
||||||
accu += tmp_array(i)
|
accu += tmp_array(i)
|
||||||
enddo
|
enddo
|
||||||
write(*,'(100(F16.10,X))')tmp_array(j) , accu
|
write(*,'(100(F16.10,X))')tmp_array(j) , accu
|
||||||
stop
|
stop
|
||||||
endif
|
endif
|
||||||
enddo
|
enddo
|
||||||
@ -144,35 +202,73 @@ BEGIN_PROVIDER [double precision, weight_at_r_extra, (n_points_extra_integration
|
|||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
|
||||||
BEGIN_PROVIDER [double precision, final_weight_at_r_extra, (n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num) ]
|
BEGIN_PROVIDER [double precision, final_weight_at_r_extra, (n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num) ]
|
||||||
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Total weight on each grid point which takes into account all Lebedev, Voronoi and radial weights.
|
! Total weight on each grid point which takes into account all Lebedev, Voronoi and radial weights.
|
||||||
END_DOC
|
END_DOC
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
integer :: i,j,k,l,m
|
integer :: i, j, k, l, m
|
||||||
double precision :: r(3)
|
double precision :: r(3)
|
||||||
double precision :: accu,cell_function_becke
|
double precision :: tmp_array(nucl_num)
|
||||||
double precision :: tmp_array(nucl_num)
|
double precision :: contrib_integration, x, tmp
|
||||||
double precision :: contrib_integration,x
|
double precision, external :: derivative_knowles_function, knowles_function
|
||||||
double precision :: derivative_knowles_function,knowles_function
|
|
||||||
! run over all points_extra in space
|
PROVIDE extra_rad_grid_type
|
||||||
do j = 1, nucl_num ! that are referred to each atom
|
if(extra_rad_grid_type .eq. "KNOWLES") then
|
||||||
do i = 1, n_points_extra_radial_grid -1 !for each radial grid attached to the "jth" atom
|
|
||||||
x = grid_points_extra_radial(i) ! x value for the mapping of the [0, +\infty] to [0,1]
|
! run over all points_extra in space
|
||||||
do k = 1, n_points_extra_integration_angular ! for each angular point attached to the "jth" atom
|
do j = 1, nucl_num ! that are referred to each atom
|
||||||
contrib_integration = derivative_knowles_function(alpha_knowles(grid_atomic_number(j)),m_knowles,x)&
|
do i = 1, n_points_extra_radial_grid -1 !for each radial grid attached to the "jth" atom
|
||||||
*knowles_function(alpha_knowles(grid_atomic_number(j)),m_knowles,x)**2
|
x = grid_points_extra_radial(i) ! x value for the mapping of the [0, +\infty] to [0,1]
|
||||||
final_weight_at_r_extra(k,i,j) = weights_angular_points_extra(k) * weight_at_r_extra(k,i,j) * contrib_integration * dr_radial_extra_integral
|
do k = 1, n_points_extra_integration_angular ! for each angular point attached to the "jth" atom
|
||||||
if(isnan(final_weight_at_r_extra(k,i,j)))then
|
contrib_integration = derivative_knowles_function(alpha_knowles(grid_atomic_number(j)),m_knowles,x)&
|
||||||
print*,'isnan(final_weight_at_r_extra(k,i,j))'
|
* knowles_function(alpha_knowles(grid_atomic_number(j)),m_knowles,x)**2
|
||||||
print*,k,i,j
|
final_weight_at_r_extra(k,i,j) = weights_angular_points_extra(k) * weight_at_r_extra(k,i,j) * contrib_integration * dr_radial_extra_integral
|
||||||
write(*,'(100(F16.10,X))')weights_angular_points_extra(k) , weight_at_r_extra(k,i,j) , contrib_integration , dr_radial_extra_integral
|
if(isnan(final_weight_at_r_extra(k,i,j)))then
|
||||||
stop
|
print*,'isnan(final_weight_at_r_extra(k,i,j))'
|
||||||
endif
|
print*,k,i,j
|
||||||
|
write(*,'(100(F16.10,X))')weights_angular_points_extra(k) , weight_at_r_extra(k,i,j) , contrib_integration , dr_radial_extra_integral
|
||||||
|
stop
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
enddo
|
|
||||||
|
elseif(extra_rad_grid_type .eq. "GILL") then
|
||||||
|
! GILL & CHIEN, 2002
|
||||||
|
|
||||||
|
PROVIDE R_gill
|
||||||
|
tmp = 2.d0 * R_gill * R_gill * R_gill * dble(n_points_extra_radial_grid)
|
||||||
|
|
||||||
|
! run over all points_extra in space
|
||||||
|
do j = 1, nucl_num ! that are referred to each atom
|
||||||
|
do i = 1, n_points_extra_radial_grid -1 !for each radial grid attached to the "jth" atom
|
||||||
|
contrib_integration = tmp * dble(i-1)**5 / dble(n_points_extra_radial_grid-i+1)**7
|
||||||
|
|
||||||
|
do k = 1, n_points_extra_integration_angular ! for each angular point attached to the "jth" atom
|
||||||
|
final_weight_at_r_extra(k,i,j) = weights_angular_points_extra(k) * weight_at_r_extra(k,i,j) * contrib_integration
|
||||||
|
if(isnan(final_weight_at_r_extra(k,i,j)))then
|
||||||
|
print*,'isnan(final_weight_at_r_extra(k,i,j))'
|
||||||
|
print*,k,i,j
|
||||||
|
write(*,'(100(F16.10,X))') weights_angular_points_extra(k), weight_at_r_extra(k,i,j), contrib_integration
|
||||||
|
stop
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
else
|
||||||
|
|
||||||
|
print*, " extra_rad_grid_type = ", extra_rad_grid_type, ' is not implemented'
|
||||||
|
stop
|
||||||
|
|
||||||
|
endif
|
||||||
|
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
@ -1,26 +1,35 @@
|
|||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
BEGIN_PROVIDER [integer, n_points_extra_final_grid]
|
BEGIN_PROVIDER [integer, n_points_extra_final_grid]
|
||||||
implicit none
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Number of points_extra which are non zero
|
! Number of points_extra which are non zero
|
||||||
END_DOC
|
END_DOC
|
||||||
integer :: i,j,k,l
|
|
||||||
|
implicit none
|
||||||
|
integer :: i, j, k, l
|
||||||
|
|
||||||
n_points_extra_final_grid = 0
|
n_points_extra_final_grid = 0
|
||||||
|
|
||||||
do j = 1, nucl_num
|
do j = 1, nucl_num
|
||||||
do i = 1, n_points_extra_radial_grid -1
|
do i = 1, n_points_extra_radial_grid -1
|
||||||
do k = 1, n_points_extra_integration_angular
|
do k = 1, n_points_extra_integration_angular
|
||||||
if(dabs(final_weight_at_r_extra(k,i,j)) < thresh_extra_grid)then
|
if(dabs(final_weight_at_r_extra(k,i,j)) < thresh_extra_grid) then
|
||||||
cycle
|
cycle
|
||||||
endif
|
endif
|
||||||
n_points_extra_final_grid += 1
|
n_points_extra_final_grid += 1
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
print*,'n_points_extra_final_grid = ',n_points_extra_final_grid
|
print*,'n_points_extra_final_grid = ',n_points_extra_final_grid
|
||||||
print*,'n max point = ',n_points_extra_integration_angular*(n_points_extra_radial_grid*nucl_num - 1)
|
print*,'n max point = ',n_points_extra_integration_angular*(n_points_extra_radial_grid*nucl_num - 1)
|
||||||
! call ezfio_set_becke_numerical_grid_n_points_extra_final_grid(n_points_extra_final_grid)
|
! call ezfio_set_becke_numerical_grid_n_points_extra_final_grid(n_points_extra_final_grid)
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
BEGIN_PROVIDER [double precision, final_grid_points_extra, (3,n_points_extra_final_grid)]
|
BEGIN_PROVIDER [double precision, final_grid_points_extra, (3,n_points_extra_final_grid)]
|
||||||
&BEGIN_PROVIDER [double precision, final_weight_at_r_vector_extra, (n_points_extra_final_grid) ]
|
&BEGIN_PROVIDER [double precision, final_weight_at_r_vector_extra, (n_points_extra_final_grid) ]
|
||||||
&BEGIN_PROVIDER [integer, index_final_points_extra, (3,n_points_extra_final_grid) ]
|
&BEGIN_PROVIDER [integer, index_final_points_extra, (3,n_points_extra_final_grid) ]
|
||||||
|
@ -1,103 +1,174 @@
|
|||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
BEGIN_PROVIDER [integer, n_points_radial_grid]
|
BEGIN_PROVIDER [integer, n_points_radial_grid]
|
||||||
&BEGIN_PROVIDER [integer, n_points_integration_angular]
|
&BEGIN_PROVIDER [integer, n_points_integration_angular]
|
||||||
implicit none
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! n_points_radial_grid = number of radial grid points per atom
|
! n_points_radial_grid = number of radial grid points per atom
|
||||||
!
|
!
|
||||||
! n_points_integration_angular = number of angular grid points per atom
|
! n_points_integration_angular = number of angular grid points per atom
|
||||||
!
|
!
|
||||||
! These numbers are automatically set by setting the grid_type_sgn parameter
|
! These numbers are automatically set by setting the grid_type_sgn parameter
|
||||||
END_DOC
|
END_DOC
|
||||||
if(.not.my_grid_becke)then
|
|
||||||
select case (grid_type_sgn)
|
implicit none
|
||||||
case(0)
|
|
||||||
n_points_radial_grid = 23
|
if(.not.my_grid_becke)then
|
||||||
n_points_integration_angular = 170
|
select case (grid_type_sgn)
|
||||||
case(1)
|
case(0)
|
||||||
n_points_radial_grid = 50
|
n_points_radial_grid = 23
|
||||||
n_points_integration_angular = 194
|
n_points_integration_angular = 170
|
||||||
case(2)
|
case(1)
|
||||||
n_points_radial_grid = 75
|
n_points_radial_grid = 50
|
||||||
n_points_integration_angular = 302
|
n_points_integration_angular = 194
|
||||||
case(3)
|
case(2)
|
||||||
n_points_radial_grid = 99
|
n_points_radial_grid = 75
|
||||||
n_points_integration_angular = 590
|
n_points_integration_angular = 302
|
||||||
case default
|
case(3)
|
||||||
write(*,*) '!!! Quadrature grid not available !!!'
|
n_points_radial_grid = 99
|
||||||
stop
|
n_points_integration_angular = 590
|
||||||
end select
|
case default
|
||||||
else
|
write(*,*) '!!! Quadrature grid not available !!!'
|
||||||
n_points_radial_grid = my_n_pt_r_grid
|
stop
|
||||||
n_points_integration_angular = my_n_pt_a_grid
|
end select
|
||||||
endif
|
else
|
||||||
|
n_points_radial_grid = my_n_pt_r_grid
|
||||||
|
n_points_integration_angular = my_n_pt_a_grid
|
||||||
|
endif
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
BEGIN_PROVIDER [integer, n_points_grid_per_atom]
|
BEGIN_PROVIDER [integer, n_points_grid_per_atom]
|
||||||
implicit none
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Number of grid points per atom
|
! Number of grid points per atom
|
||||||
END_DOC
|
END_DOC
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
|
||||||
n_points_grid_per_atom = n_points_integration_angular * n_points_radial_grid
|
n_points_grid_per_atom = n_points_integration_angular * n_points_radial_grid
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
BEGIN_PROVIDER [integer , m_knowles]
|
! ---
|
||||||
implicit none
|
|
||||||
|
BEGIN_PROVIDER [integer, m_knowles]
|
||||||
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! value of the "m" parameter in the equation (7) of the paper of Knowles (JCP, 104, 1996)
|
! value of the "m" parameter in the equation (7) of the paper of Knowles (JCP, 104, 1996)
|
||||||
END_DOC
|
END_DOC
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
|
||||||
m_knowles = 3
|
m_knowles = 3
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [double precision, R_gill]
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
R_gill = 3.d0
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
BEGIN_PROVIDER [double precision, grid_points_radial, (n_points_radial_grid)]
|
BEGIN_PROVIDER [double precision, grid_points_radial, (n_points_radial_grid)]
|
||||||
&BEGIN_PROVIDER [double precision, dr_radial_integral]
|
&BEGIN_PROVIDER [double precision, dr_radial_integral]
|
||||||
|
|
||||||
implicit none
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! points in [0,1] to map the radial integral [0,\infty]
|
! points in [0,1] to map the radial integral [0,\infty]
|
||||||
END_DOC
|
END_DOC
|
||||||
dr_radial_integral = 1.d0/dble(n_points_radial_grid-1)
|
|
||||||
integer :: i
|
implicit none
|
||||||
|
integer :: i
|
||||||
|
|
||||||
|
dr_radial_integral = 1.d0 / dble(n_points_radial_grid-1)
|
||||||
|
|
||||||
do i = 1, n_points_radial_grid
|
do i = 1, n_points_radial_grid
|
||||||
grid_points_radial(i) = dble(i-1) * dr_radial_integral
|
grid_points_radial(i) = dble(i-1) * dr_radial_integral
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_integration_angular,n_points_radial_grid,nucl_num)]
|
BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_integration_angular,n_points_radial_grid,nucl_num)]
|
||||||
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! x,y,z coordinates of grid points used for integration in 3d space
|
! x,y,z coordinates of grid points used for integration in 3d space
|
||||||
END_DOC
|
END_DOC
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
integer :: i,j,k
|
integer :: i, j, k
|
||||||
double precision :: dr,x_ref,y_ref,z_ref
|
double precision :: dr, x_ref, y_ref, z_ref
|
||||||
double precision :: knowles_function
|
double precision :: x, r, tmp
|
||||||
do i = 1, nucl_num
|
double precision, external :: knowles_function
|
||||||
x_ref = nucl_coord(i,1)
|
|
||||||
y_ref = nucl_coord(i,2)
|
|
||||||
z_ref = nucl_coord(i,3)
|
|
||||||
do j = 1, n_points_radial_grid-1
|
|
||||||
double precision :: x,r
|
|
||||||
! x value for the mapping of the [0, +\infty] to [0,1]
|
|
||||||
x = grid_points_radial(j)
|
|
||||||
|
|
||||||
! value of the radial coordinate for the integration
|
grid_points_per_atom = 0.d0
|
||||||
r = knowles_function(alpha_knowles(grid_atomic_number(i)),m_knowles,x)
|
|
||||||
|
|
||||||
! explicit values of the grid points centered around each atom
|
PROVIDE rad_grid_type
|
||||||
do k = 1, n_points_integration_angular
|
if(rad_grid_type .eq. "KNOWLES") then
|
||||||
grid_points_per_atom(1,k,j,i) = &
|
|
||||||
x_ref + angular_quadrature_points(k,1) * r
|
do i = 1, nucl_num
|
||||||
grid_points_per_atom(2,k,j,i) = &
|
x_ref = nucl_coord(i,1)
|
||||||
y_ref + angular_quadrature_points(k,2) * r
|
y_ref = nucl_coord(i,2)
|
||||||
grid_points_per_atom(3,k,j,i) = &
|
z_ref = nucl_coord(i,3)
|
||||||
z_ref + angular_quadrature_points(k,3) * r
|
do j = 1, n_points_radial_grid-1
|
||||||
|
|
||||||
|
! x value for the mapping of the [0, +\infty] to [0,1]
|
||||||
|
x = grid_points_radial(j)
|
||||||
|
! value of the radial coordinate for the integration
|
||||||
|
r = knowles_function(alpha_knowles(grid_atomic_number(i)), m_knowles, x)
|
||||||
|
|
||||||
|
! explicit values of the grid points centered around each atom
|
||||||
|
do k = 1, n_points_integration_angular
|
||||||
|
grid_points_per_atom(1,k,j,i) = x_ref + angular_quadrature_points(k,1) * r
|
||||||
|
grid_points_per_atom(2,k,j,i) = y_ref + angular_quadrature_points(k,2) * r
|
||||||
|
grid_points_per_atom(3,k,j,i) = z_ref + angular_quadrature_points(k,3) * r
|
||||||
|
enddo
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
enddo
|
|
||||||
|
elseif(rad_grid_type .eq. "GILL") then
|
||||||
|
! GILL & CHIEN, 2002
|
||||||
|
|
||||||
|
do i = 1, nucl_num
|
||||||
|
x_ref = nucl_coord(i,1)
|
||||||
|
y_ref = nucl_coord(i,2)
|
||||||
|
z_ref = nucl_coord(i,3)
|
||||||
|
do j = 1, n_points_radial_grid-1
|
||||||
|
|
||||||
|
r = R_gill * dble(j-1)**2 / dble(n_points_radial_grid-j+1)**2
|
||||||
|
|
||||||
|
! explicit values of the grid points centered around each atom
|
||||||
|
do k = 1, n_points_integration_angular
|
||||||
|
grid_points_per_atom(1,k,j,i) = x_ref + angular_quadrature_points(k,1) * r
|
||||||
|
grid_points_per_atom(2,k,j,i) = y_ref + angular_quadrature_points(k,2) * r
|
||||||
|
grid_points_per_atom(3,k,j,i) = z_ref + angular_quadrature_points(k,3) * r
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
else
|
||||||
|
|
||||||
|
print*, " rad_grid_type = ", rad_grid_type, ' is not implemented'
|
||||||
|
stop
|
||||||
|
|
||||||
|
endif
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
BEGIN_PROVIDER [double precision, weight_at_r, (n_points_integration_angular,n_points_radial_grid,nucl_num) ]
|
! ---
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [double precision, weight_at_r, (n_points_integration_angular,n_points_radial_grid,nucl_num)]
|
||||||
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Weight function at grid points : w_n(r) according to the equation (22)
|
! Weight function at grid points : w_n(r) according to the equation (22)
|
||||||
! of Becke original paper (JCP, 88, 1988)
|
! of Becke original paper (JCP, 88, 1988)
|
||||||
@ -106,11 +177,13 @@ BEGIN_PROVIDER [double precision, weight_at_r, (n_points_integration_angular,n_p
|
|||||||
! represented by the last dimension and the points are labelled by the
|
! represented by the last dimension and the points are labelled by the
|
||||||
! other dimensions.
|
! other dimensions.
|
||||||
END_DOC
|
END_DOC
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
integer :: i,j,k,l,m
|
integer :: i, j, k, l, m
|
||||||
double precision :: r(3)
|
double precision :: r(3), accu
|
||||||
double precision :: accu,cell_function_becke
|
double precision :: tmp_array(nucl_num)
|
||||||
double precision :: tmp_array(nucl_num)
|
double precision, external :: cell_function_becke
|
||||||
|
|
||||||
! run over all points in space
|
! run over all points in space
|
||||||
! that are referred to each atom
|
! that are referred to each atom
|
||||||
do j = 1, nucl_num
|
do j = 1, nucl_num
|
||||||
@ -121,28 +194,30 @@ BEGIN_PROVIDER [double precision, weight_at_r, (n_points_integration_angular,n_p
|
|||||||
r(1) = grid_points_per_atom(1,l,k,j)
|
r(1) = grid_points_per_atom(1,l,k,j)
|
||||||
r(2) = grid_points_per_atom(2,l,k,j)
|
r(2) = grid_points_per_atom(2,l,k,j)
|
||||||
r(3) = grid_points_per_atom(3,l,k,j)
|
r(3) = grid_points_per_atom(3,l,k,j)
|
||||||
|
|
||||||
accu = 0.d0
|
accu = 0.d0
|
||||||
! For each of these points in space, ou need to evaluate the P_n(r)
|
! For each of these points in space, ou need to evaluate the P_n(r)
|
||||||
do i = 1, nucl_num
|
do i = 1, nucl_num
|
||||||
! function defined for each atom "i" by equation (13) and (21) with k == 3
|
! function defined for each atom "i" by equation (13) and (21) with k == 3
|
||||||
tmp_array(i) = cell_function_becke(r,i) ! P_n(r)
|
tmp_array(i) = cell_function_becke(r, i) ! P_n(r)
|
||||||
! Then you compute the summ the P_n(r) function for each of the "r" points
|
! Then you compute the summ the P_n(r) function for each of the "r" points
|
||||||
accu += tmp_array(i)
|
accu += tmp_array(i)
|
||||||
enddo
|
enddo
|
||||||
accu = 1.d0/accu
|
accu = 1.d0/accu
|
||||||
weight_at_r(l,k,j) = tmp_array(j) * accu
|
weight_at_r(l,k,j) = tmp_array(j) * accu
|
||||||
if(isnan(weight_at_r(l,k,j)))then
|
|
||||||
print*,'isnan(weight_at_r(l,k,j))'
|
if(isnan(weight_at_r(l,k,j))) then
|
||||||
print*,l,k,j
|
print*,'isnan(weight_at_r(l,k,j))'
|
||||||
accu = 0.d0
|
print*,l,k,j
|
||||||
do i = 1, nucl_num
|
accu = 0.d0
|
||||||
! function defined for each atom "i" by equation (13) and (21) with k == 3
|
do i = 1, nucl_num
|
||||||
tmp_array(i) = cell_function_becke(r,i) ! P_n(r)
|
! function defined for each atom "i" by equation (13) and (21) with k == 3
|
||||||
print*,i,tmp_array(i)
|
tmp_array(i) = cell_function_becke(r,i) ! P_n(r)
|
||||||
! Then you compute the summ the P_n(r) function for each of the "r" points
|
print*,i,tmp_array(i)
|
||||||
accu += tmp_array(i)
|
! Then you compute the summ the P_n(r) function for each of the "r" points
|
||||||
enddo
|
accu += tmp_array(i)
|
||||||
write(*,'(100(F16.10,X))')tmp_array(j) , accu
|
enddo
|
||||||
|
write(*,'(100(F16.10,X))')tmp_array(j) , accu
|
||||||
stop
|
stop
|
||||||
endif
|
endif
|
||||||
enddo
|
enddo
|
||||||
@ -151,35 +226,76 @@ BEGIN_PROVIDER [double precision, weight_at_r, (n_points_integration_angular,n_p
|
|||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [double precision, final_weight_at_r, (n_points_integration_angular,n_points_radial_grid,nucl_num)]
|
||||||
|
|
||||||
BEGIN_PROVIDER [double precision, final_weight_at_r, (n_points_integration_angular,n_points_radial_grid,nucl_num) ]
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Total weight on each grid point which takes into account all Lebedev, Voronoi and radial weights.
|
! Total weight on each grid point which takes into account all Lebedev, Voronoi and radial weights.
|
||||||
END_DOC
|
END_DOC
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
integer :: i,j,k,l,m
|
integer :: i, j, k, l, m
|
||||||
double precision :: r(3)
|
double precision :: r(3)
|
||||||
double precision :: accu,cell_function_becke
|
double precision :: tmp_array(nucl_num)
|
||||||
double precision :: tmp_array(nucl_num)
|
double precision :: contrib_integration, x, tmp
|
||||||
double precision :: contrib_integration,x
|
double precision, external :: derivative_knowles_function, knowles_function
|
||||||
double precision :: derivative_knowles_function,knowles_function
|
|
||||||
! run over all points in space
|
final_weight_at_r = 0.d0
|
||||||
do j = 1, nucl_num ! that are referred to each atom
|
|
||||||
do i = 1, n_points_radial_grid -1 !for each radial grid attached to the "jth" atom
|
PROVIDE rad_grid_type
|
||||||
x = grid_points_radial(i) ! x value for the mapping of the [0, +\infty] to [0,1]
|
if(rad_grid_type .eq. "KNOWLES") then
|
||||||
do k = 1, n_points_integration_angular ! for each angular point attached to the "jth" atom
|
|
||||||
contrib_integration = derivative_knowles_function(alpha_knowles(grid_atomic_number(j)),m_knowles,x)&
|
! run over all points in space
|
||||||
*knowles_function(alpha_knowles(grid_atomic_number(j)),m_knowles,x)**2
|
do j = 1, nucl_num ! that are referred to each atom
|
||||||
final_weight_at_r(k,i,j) = weights_angular_points(k) * weight_at_r(k,i,j) * contrib_integration * dr_radial_integral
|
do i = 1, n_points_radial_grid -1 !for each radial grid attached to the "jth" atom
|
||||||
if(isnan(final_weight_at_r(k,i,j)))then
|
x = grid_points_radial(i) ! x value for the mapping of the [0, +\infty] to [0,1]
|
||||||
print*,'isnan(final_weight_at_r(k,i,j))'
|
|
||||||
print*,k,i,j
|
do k = 1, n_points_integration_angular ! for each angular point attached to the "jth" atom
|
||||||
write(*,'(100(F16.10,X))')weights_angular_points(k) , weight_at_r(k,i,j) , contrib_integration , dr_radial_integral
|
contrib_integration = derivative_knowles_function(alpha_knowles(grid_atomic_number(j)), m_knowles, x) &
|
||||||
stop
|
* knowles_function(alpha_knowles(grid_atomic_number(j)), m_knowles, x)**2
|
||||||
endif
|
|
||||||
|
final_weight_at_r(k,i,j) = weights_angular_points(k) * weight_at_r(k,i,j) * contrib_integration * dr_radial_integral
|
||||||
|
|
||||||
|
if(isnan(final_weight_at_r(k,i,j))) then
|
||||||
|
print*,'isnan(final_weight_at_r(k,i,j))'
|
||||||
|
print*,k,i,j
|
||||||
|
write(*,'(100(F16.10,X))') weights_angular_points(k), weight_at_r(k,i,j), contrib_integration
|
||||||
|
stop
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
enddo
|
|
||||||
|
elseif(rad_grid_type .eq. "GILL") then
|
||||||
|
! GILL & CHIEN, 2002
|
||||||
|
|
||||||
|
tmp = 2.d0 * R_gill * R_gill * R_gill * dble(n_points_radial_grid)
|
||||||
|
|
||||||
|
! run over all points in space
|
||||||
|
do j = 1, nucl_num ! that are referred to each atom
|
||||||
|
do i = 1, n_points_radial_grid - 1 !for each radial grid attached to the "jth" atom
|
||||||
|
contrib_integration = tmp * dble(i-1)**5 / dble(n_points_radial_grid-i+1)**7
|
||||||
|
do k = 1, n_points_integration_angular ! for each angular point attached to the "jth" atom
|
||||||
|
final_weight_at_r(k,i,j) = weights_angular_points(k) * weight_at_r(k,i,j) * contrib_integration
|
||||||
|
|
||||||
|
if(isnan(final_weight_at_r(k,i,j))) then
|
||||||
|
print*,'isnan(final_weight_at_r(k,i,j))'
|
||||||
|
print*,k,i,j
|
||||||
|
write(*,'(100(F16.10,X))') weights_angular_points(k), weight_at_r(k,i,j), contrib_integration, dr_radial_integral
|
||||||
|
stop
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
else
|
||||||
|
|
||||||
|
print*, " rad_grid_type = ", rad_grid_type, ' is not implemented'
|
||||||
|
stop
|
||||||
|
|
||||||
|
endif
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
@ -21,22 +21,27 @@ BEGIN_PROVIDER [integer, n_points_final_grid]
|
|||||||
call ezfio_set_becke_numerical_grid_n_points_final_grid(n_points_final_grid)
|
call ezfio_set_becke_numerical_grid_n_points_final_grid(n_points_final_grid)
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
BEGIN_PROVIDER [double precision, final_grid_points, (3,n_points_final_grid)]
|
! ---
|
||||||
&BEGIN_PROVIDER [double precision, final_weight_at_r_vector, (n_points_final_grid) ]
|
|
||||||
&BEGIN_PROVIDER [integer, index_final_points, (3,n_points_final_grid) ]
|
BEGIN_PROVIDER [double precision, final_grid_points, (3,n_points_final_grid)]
|
||||||
&BEGIN_PROVIDER [integer, index_final_points_reverse, (n_points_integration_angular,n_points_radial_grid,nucl_num) ]
|
&BEGIN_PROVIDER [double precision, final_weight_at_r_vector, (n_points_final_grid)]
|
||||||
implicit none
|
&BEGIN_PROVIDER [integer, index_final_points, (3,n_points_final_grid)]
|
||||||
|
&BEGIN_PROVIDER [integer, index_final_points_reverse, (n_points_integration_angular,n_points_radial_grid,nucl_num)]
|
||||||
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! final_grid_points(1:3,j) = (/ x, y, z /) of the jth grid point
|
! final_grid_points(1:3,j) = (/ x, y, z /) of the jth grid point
|
||||||
!
|
!
|
||||||
! final_weight_at_r_vector(i) = Total weight function of the ith grid point which contains the Lebedev, Voronoi and radial weights contributions
|
! final_weight_at_r_vector(i) = Total weight function of the ith grid point which contains the Lebedev, Voronoi and radial weights contributions
|
||||||
!
|
!
|
||||||
! index_final_points(1:3,i) = gives the angular, radial and atomic indices associated to the ith grid point
|
! index_final_points(1:3,i) = gives the angular, radial and atomic indices associated to the ith grid point
|
||||||
!
|
!
|
||||||
! index_final_points_reverse(i,j,k) = index of the grid point having i as angular, j as radial and l as atomic indices
|
! index_final_points_reverse(i,j,k) = index of the grid point having i as angular, j as radial and l as atomic indices
|
||||||
END_DOC
|
END_DOC
|
||||||
integer :: i,j,k,l,i_count
|
|
||||||
double precision :: r(3)
|
implicit none
|
||||||
|
integer :: i, j, k, l, i_count
|
||||||
|
double precision :: r(3)
|
||||||
|
|
||||||
i_count = 0
|
i_count = 0
|
||||||
do j = 1, nucl_num
|
do j = 1, nucl_num
|
||||||
do i = 1, n_points_radial_grid -1
|
do i = 1, n_points_radial_grid -1
|
||||||
@ -59,6 +64,8 @@ END_PROVIDER
|
|||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
BEGIN_PROVIDER [double precision, final_grid_points_transp, (n_points_final_grid,3)]
|
BEGIN_PROVIDER [double precision, final_grid_points_transp, (n_points_final_grid,3)]
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
|
@ -1,71 +1,93 @@
|
|||||||
double precision function knowles_function(alpha,m,x)
|
|
||||||
implicit none
|
|
||||||
BEGIN_DOC
|
|
||||||
! Function proposed by Knowles (JCP, 104, 1996) for distributing the radial points :
|
|
||||||
! the Log "m" function ( equation (7) in the paper )
|
|
||||||
END_DOC
|
|
||||||
double precision, intent(in) :: alpha,x
|
|
||||||
integer, intent(in) :: m
|
|
||||||
!print*, x
|
|
||||||
knowles_function = -alpha * dlog(1.d0-x**m)
|
|
||||||
end
|
|
||||||
|
|
||||||
double precision function derivative_knowles_function(alpha,m,x)
|
! ---
|
||||||
implicit none
|
|
||||||
BEGIN_DOC
|
|
||||||
! Derivative of the function proposed by Knowles (JCP, 104, 1996) for distributing the radial points
|
|
||||||
END_DOC
|
|
||||||
double precision, intent(in) :: alpha,x
|
|
||||||
integer, intent(in) :: m
|
|
||||||
double precision :: f
|
|
||||||
f = x**(m-1)
|
|
||||||
derivative_knowles_function = alpha * dble(m) * f / (1.d0 - x*f)
|
|
||||||
end
|
|
||||||
|
|
||||||
BEGIN_PROVIDER [double precision, alpha_knowles, (100)]
|
double precision function knowles_function(alpha, m, x)
|
||||||
implicit none
|
|
||||||
integer :: i
|
|
||||||
BEGIN_DOC
|
|
||||||
! Recommended values for the alpha parameters according to the paper of Knowles (JCP, 104, 1996)
|
|
||||||
! as a function of the nuclear charge
|
|
||||||
END_DOC
|
|
||||||
|
|
||||||
! H-He
|
BEGIN_DOC
|
||||||
alpha_knowles(1) = 5.d0
|
! Function proposed by Knowles (JCP, 104, 1996) for distributing the radial points :
|
||||||
alpha_knowles(2) = 5.d0
|
! the Log "m" function ( equation (7) in the paper )
|
||||||
|
END_DOC
|
||||||
|
|
||||||
! Li-Be
|
implicit none
|
||||||
alpha_knowles(3) = 7.d0
|
double precision, intent(in) :: alpha, x
|
||||||
alpha_knowles(4) = 7.d0
|
integer, intent(in) :: m
|
||||||
|
|
||||||
! B-Ne
|
!print*, x
|
||||||
do i = 5, 10
|
knowles_function = -alpha * dlog(1.d0-x**m)
|
||||||
alpha_knowles(i) = 5.d0
|
|
||||||
enddo
|
|
||||||
|
|
||||||
! Na-Mg
|
return
|
||||||
do i = 11, 12
|
end
|
||||||
alpha_knowles(i) = 7.d0
|
|
||||||
enddo
|
|
||||||
|
|
||||||
! Al-Ar
|
! ---
|
||||||
do i = 13, 18
|
|
||||||
alpha_knowles(i) = 5.d0
|
|
||||||
enddo
|
|
||||||
|
|
||||||
! K-Ca
|
double precision function derivative_knowles_function(alpha, m, x)
|
||||||
do i = 19, 20
|
|
||||||
alpha_knowles(i) = 7.d0
|
|
||||||
enddo
|
|
||||||
|
|
||||||
! Sc-Zn
|
BEGIN_DOC
|
||||||
do i = 21, 30
|
! Derivative of the function proposed by Knowles (JCP, 104, 1996) for distributing the radial points
|
||||||
alpha_knowles(i) = 5.d0
|
END_DOC
|
||||||
enddo
|
|
||||||
|
|
||||||
! Ga-Kr
|
implicit none
|
||||||
do i = 31, 100
|
double precision, intent(in) :: alpha, x
|
||||||
alpha_knowles(i) = 7.d0
|
integer, intent(in) :: m
|
||||||
enddo
|
double precision :: f
|
||||||
|
|
||||||
|
f = x**(m-1)
|
||||||
|
derivative_knowles_function = alpha * dble(m) * f / (1.d0 - x*f)
|
||||||
|
|
||||||
|
return
|
||||||
|
end
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [double precision, alpha_knowles, (100)]
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
! Recommended values for the alpha parameters according to the paper of Knowles (JCP, 104, 1996)
|
||||||
|
! as a function of the nuclear charge
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer :: i
|
||||||
|
|
||||||
|
! H-He
|
||||||
|
alpha_knowles(1) = 5.d0
|
||||||
|
alpha_knowles(2) = 5.d0
|
||||||
|
|
||||||
|
! Li-Be
|
||||||
|
alpha_knowles(3) = 7.d0
|
||||||
|
alpha_knowles(4) = 7.d0
|
||||||
|
|
||||||
|
! B-Ne
|
||||||
|
do i = 5, 10
|
||||||
|
alpha_knowles(i) = 5.d0
|
||||||
|
enddo
|
||||||
|
|
||||||
|
! Na-Mg
|
||||||
|
do i = 11, 12
|
||||||
|
alpha_knowles(i) = 7.d0
|
||||||
|
enddo
|
||||||
|
|
||||||
|
! Al-Ar
|
||||||
|
do i = 13, 18
|
||||||
|
alpha_knowles(i) = 5.d0
|
||||||
|
enddo
|
||||||
|
|
||||||
|
! K-Ca
|
||||||
|
do i = 19, 20
|
||||||
|
alpha_knowles(i) = 7.d0
|
||||||
|
enddo
|
||||||
|
|
||||||
|
! Sc-Zn
|
||||||
|
do i = 21, 30
|
||||||
|
alpha_knowles(i) = 5.d0
|
||||||
|
enddo
|
||||||
|
|
||||||
|
! Ga-Kr
|
||||||
|
do i = 31, 100
|
||||||
|
alpha_knowles(i) = 7.d0
|
||||||
|
enddo
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
END_PROVIDER
|
|
||||||
|
@ -20,31 +20,42 @@ double precision function f_function_becke(x)
|
|||||||
f_function_becke = 1.5d0 * x - 0.5d0 * x*x*x
|
f_function_becke = 1.5d0 * x - 0.5d0 * x*x*x
|
||||||
end
|
end
|
||||||
|
|
||||||
double precision function cell_function_becke(r,atom_number)
|
! ---
|
||||||
implicit none
|
|
||||||
double precision, intent(in) :: r(3)
|
double precision function cell_function_becke(r, atom_number)
|
||||||
integer, intent(in) :: atom_number
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! atom_number :: atom on which the cell function of Becke (1988, JCP,88(4))
|
! atom_number :: atom on which the cell function of Becke (1988, JCP,88(4))
|
||||||
! r(1:3) :: x,y,z coordinantes of the current point
|
! r(1:3) :: x,y,z coordinantes of the current point
|
||||||
END_DOC
|
END_DOC
|
||||||
double precision :: mu_ij,nu_ij
|
|
||||||
double precision :: distance_i,distance_j,step_function_becke
|
implicit none
|
||||||
integer :: j
|
double precision, intent(in) :: r(3)
|
||||||
distance_i = (r(1) - nucl_coord_transp(1,atom_number) ) * (r(1) - nucl_coord_transp(1,atom_number))
|
integer, intent(in) :: atom_number
|
||||||
|
integer :: j
|
||||||
|
double precision :: mu_ij, nu_ij
|
||||||
|
double precision :: distance_i, distance_j, step_function_becke
|
||||||
|
|
||||||
|
distance_i = (r(1) - nucl_coord_transp(1,atom_number) ) * (r(1) - nucl_coord_transp(1,atom_number))
|
||||||
distance_i += (r(2) - nucl_coord_transp(2,atom_number) ) * (r(2) - nucl_coord_transp(2,atom_number))
|
distance_i += (r(2) - nucl_coord_transp(2,atom_number) ) * (r(2) - nucl_coord_transp(2,atom_number))
|
||||||
distance_i += (r(3) - nucl_coord_transp(3,atom_number) ) * (r(3) - nucl_coord_transp(3,atom_number))
|
distance_i += (r(3) - nucl_coord_transp(3,atom_number) ) * (r(3) - nucl_coord_transp(3,atom_number))
|
||||||
distance_i = dsqrt(distance_i)
|
distance_i = dsqrt(distance_i)
|
||||||
|
|
||||||
cell_function_becke = 1.d0
|
cell_function_becke = 1.d0
|
||||||
do j = 1, nucl_num
|
do j = 1, nucl_num
|
||||||
if(j==atom_number)cycle
|
if(j==atom_number) cycle
|
||||||
distance_j = (r(1) - nucl_coord_transp(1,j) ) * (r(1) - nucl_coord_transp(1,j))
|
|
||||||
distance_j+= (r(2) - nucl_coord_transp(2,j) ) * (r(2) - nucl_coord_transp(2,j))
|
distance_j = (r(1) - nucl_coord_transp(1,j) ) * (r(1) - nucl_coord_transp(1,j))
|
||||||
distance_j+= (r(3) - nucl_coord_transp(3,j) ) * (r(3) - nucl_coord_transp(3,j))
|
distance_j += (r(2) - nucl_coord_transp(2,j) ) * (r(2) - nucl_coord_transp(2,j))
|
||||||
distance_j = dsqrt(distance_j)
|
distance_j += (r(3) - nucl_coord_transp(3,j) ) * (r(3) - nucl_coord_transp(3,j))
|
||||||
mu_ij = (distance_i - distance_j)*nucl_dist_inv(atom_number,j)
|
distance_j = dsqrt(distance_j)
|
||||||
|
|
||||||
|
mu_ij = (distance_i - distance_j) * nucl_dist_inv(atom_number,j)
|
||||||
nu_ij = mu_ij + slater_bragg_type_inter_distance_ua(atom_number,j) * (1.d0 - mu_ij*mu_ij)
|
nu_ij = mu_ij + slater_bragg_type_inter_distance_ua(atom_number,j) * (1.d0 - mu_ij*mu_ij)
|
||||||
|
|
||||||
cell_function_becke *= step_function_becke(nu_ij)
|
cell_function_becke *= step_function_becke(nu_ij)
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
|
return
|
||||||
end
|
end
|
||||||
|
|
||||||
|
@ -8,19 +8,22 @@ 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
|
!provide j1b_type
|
||||||
|
|
||||||
if( (j1b_type .eq. 1) .or. (j1b_type .eq. 2) ) then
|
!if( (j1b_type .eq. 1) .or. (j1b_type .eq. 2) ) then
|
||||||
|
!
|
||||||
|
! print *, ' do things properly !'
|
||||||
|
! stop
|
||||||
|
|
||||||
do i = 1, ao_num
|
! !do i = 1, ao_num
|
||||||
do j = 1, ao_num
|
! ! do j = 1, ao_num
|
||||||
ao_one_e_integrals_tc_tot(j,i) += ( j1b_gauss_hermI (j,i) &
|
! ! ao_one_e_integrals_tc_tot(j,i) += ( j1b_gauss_hermI (j,i) &
|
||||||
+ j1b_gauss_hermII (j,i) &
|
! ! + j1b_gauss_hermII (j,i) &
|
||||||
+ j1b_gauss_nonherm(j,i) )
|
! ! + j1b_gauss_nonherm(j,i) )
|
||||||
enddo
|
! ! enddo
|
||||||
enddo
|
! !enddo
|
||||||
|
|
||||||
endif
|
!endif
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
@ -110,27 +110,36 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_transp, (ao_num, ao_num, 3,
|
|||||||
print *, ' providing int2_grad1_u12_ao_transp ...'
|
print *, ' providing int2_grad1_u12_ao_transp ...'
|
||||||
call wall_time(wall0)
|
call wall_time(wall0)
|
||||||
|
|
||||||
if(test_cycle_tc)then
|
if(test_cycle_tc) then
|
||||||
do ipoint = 1, n_points_final_grid
|
|
||||||
do i = 1, ao_num
|
PROVIDE int2_grad1_u12_ao_test
|
||||||
do j = 1, ao_num
|
|
||||||
int2_grad1_u12_ao_transp(j,i,1,ipoint) = int2_grad1_u12_ao_test(j,i,ipoint,1)
|
do ipoint = 1, n_points_final_grid
|
||||||
int2_grad1_u12_ao_transp(j,i,2,ipoint) = int2_grad1_u12_ao_test(j,i,ipoint,2)
|
do i = 1, ao_num
|
||||||
int2_grad1_u12_ao_transp(j,i,3,ipoint) = int2_grad1_u12_ao_test(j,i,ipoint,3)
|
do j = 1, ao_num
|
||||||
enddo
|
int2_grad1_u12_ao_transp(j,i,1,ipoint) = int2_grad1_u12_ao_test(j,i,ipoint,1)
|
||||||
enddo
|
int2_grad1_u12_ao_transp(j,i,2,ipoint) = int2_grad1_u12_ao_test(j,i,ipoint,2)
|
||||||
enddo
|
int2_grad1_u12_ao_transp(j,i,3,ipoint) = int2_grad1_u12_ao_test(j,i,ipoint,3)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
else
|
else
|
||||||
do ipoint = 1, n_points_final_grid
|
|
||||||
do i = 1, ao_num
|
PROVIDE int2_grad1_u12_ao
|
||||||
do j = 1, ao_num
|
|
||||||
int2_grad1_u12_ao_transp(j,i,1,ipoint) = int2_grad1_u12_ao(j,i,ipoint,1)
|
do ipoint = 1, n_points_final_grid
|
||||||
int2_grad1_u12_ao_transp(j,i,2,ipoint) = int2_grad1_u12_ao(j,i,ipoint,2)
|
do i = 1, ao_num
|
||||||
int2_grad1_u12_ao_transp(j,i,3,ipoint) = int2_grad1_u12_ao(j,i,ipoint,3)
|
do j = 1, ao_num
|
||||||
enddo
|
int2_grad1_u12_ao_transp(j,i,1,ipoint) = int2_grad1_u12_ao(j,i,ipoint,1)
|
||||||
enddo
|
int2_grad1_u12_ao_transp(j,i,2,ipoint) = int2_grad1_u12_ao(j,i,ipoint,2)
|
||||||
enddo
|
int2_grad1_u12_ao_transp(j,i,3,ipoint) = int2_grad1_u12_ao(j,i,ipoint,3)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
endif
|
endif
|
||||||
|
|
||||||
call wall_time(wall1)
|
call wall_time(wall1)
|
||||||
print *, ' wall time for int2_grad1_u12_ao_transp ', wall1 - wall0
|
print *, ' wall time for int2_grad1_u12_ao_transp ', wall1 - wall0
|
||||||
|
|
||||||
@ -144,9 +153,12 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_transp, (mo_num, mo_num,
|
|||||||
integer :: ipoint
|
integer :: ipoint
|
||||||
double precision :: wall0, wall1
|
double precision :: wall0, wall1
|
||||||
|
|
||||||
!print *, ' providing int2_grad1_u12_bimo_transp'
|
PROVIDE mo_l_coef mo_r_coef
|
||||||
|
PROVIDE int2_grad1_u12_ao_transp
|
||||||
|
|
||||||
|
!print *, ' providing int2_grad1_u12_bimo_transp'
|
||||||
|
!call wall_time(wall0)
|
||||||
|
|
||||||
call wall_time(wall0)
|
|
||||||
!$OMP PARALLEL &
|
!$OMP PARALLEL &
|
||||||
!$OMP DEFAULT (NONE) &
|
!$OMP DEFAULT (NONE) &
|
||||||
!$OMP PRIVATE (ipoint) &
|
!$OMP PRIVATE (ipoint) &
|
||||||
@ -163,25 +175,31 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_transp, (mo_num, mo_num,
|
|||||||
!$OMP END DO
|
!$OMP END DO
|
||||||
!$OMP END PARALLEL
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
call wall_time(wall1)
|
!call wall_time(wall1)
|
||||||
!print *, ' Wall time for providing int2_grad1_u12_bimo_transp',wall1 - wall0
|
!print *, ' Wall time for providing int2_grad1_u12_bimo_transp',wall1 - wall0
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
|
||||||
BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_t, (n_points_final_grid,3, mo_num, mo_num )]
|
BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_t, (n_points_final_grid, 3, mo_num, mo_num)]
|
||||||
implicit none
|
|
||||||
integer :: i, j, ipoint
|
implicit none
|
||||||
do ipoint = 1, n_points_final_grid
|
integer :: i, j, ipoint
|
||||||
do i = 1, mo_num
|
|
||||||
do j = 1, mo_num
|
PROVIDE mo_l_coef mo_r_coef
|
||||||
int2_grad1_u12_bimo_t(ipoint,1,j,i) = int2_grad1_u12_bimo_transp(j,i,1,ipoint)
|
PROVIDE int2_grad1_u12_bimo_transp
|
||||||
int2_grad1_u12_bimo_t(ipoint,2,j,i) = int2_grad1_u12_bimo_transp(j,i,2,ipoint)
|
|
||||||
int2_grad1_u12_bimo_t(ipoint,3,j,i) = int2_grad1_u12_bimo_transp(j,i,3,ipoint)
|
do ipoint = 1, n_points_final_grid
|
||||||
enddo
|
do i = 1, mo_num
|
||||||
enddo
|
do j = 1, mo_num
|
||||||
enddo
|
int2_grad1_u12_bimo_t(ipoint,1,j,i) = int2_grad1_u12_bimo_transp(j,i,1,ipoint)
|
||||||
|
int2_grad1_u12_bimo_t(ipoint,2,j,i) = int2_grad1_u12_bimo_transp(j,i,2,ipoint)
|
||||||
|
int2_grad1_u12_bimo_t(ipoint,3,j,i) = int2_grad1_u12_bimo_transp(j,i,3,ipoint)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
@ -81,21 +81,24 @@ subroutine give_integrals_3_body_bi_ort(n, l, k, m, j, i, integral)
|
|||||||
integer :: ipoint
|
integer :: ipoint
|
||||||
double precision :: weight
|
double precision :: weight
|
||||||
|
|
||||||
|
PROVIDE mo_l_coef mo_r_coef
|
||||||
|
PROVIDE int2_grad1_u12_bimo_t
|
||||||
|
|
||||||
integral = 0.d0
|
integral = 0.d0
|
||||||
do ipoint = 1, n_points_final_grid
|
do ipoint = 1, n_points_final_grid
|
||||||
weight = final_weight_at_r_vector(ipoint)
|
weight = final_weight_at_r_vector(ipoint)
|
||||||
|
|
||||||
integral += weight * mos_l_in_r_array_transp(ipoint,k) * mos_r_in_r_array_transp(ipoint,i) &
|
integral += weight * mos_l_in_r_array_transp(ipoint,k) * mos_r_in_r_array_transp(ipoint,i) &
|
||||||
* ( int2_grad1_u12_bimo_t(ipoint,1,n,m) * int2_grad1_u12_bimo_t(ipoint,1,l,j) &
|
* ( int2_grad1_u12_bimo_t(ipoint,1,n,m) * int2_grad1_u12_bimo_t(ipoint,1,l,j) &
|
||||||
+ int2_grad1_u12_bimo_t(ipoint,2,n,m) * int2_grad1_u12_bimo_t(ipoint,2,l,j) &
|
+ int2_grad1_u12_bimo_t(ipoint,2,n,m) * int2_grad1_u12_bimo_t(ipoint,2,l,j) &
|
||||||
+ int2_grad1_u12_bimo_t(ipoint,3,n,m) * int2_grad1_u12_bimo_t(ipoint,3,l,j) )
|
+ int2_grad1_u12_bimo_t(ipoint,3,n,m) * int2_grad1_u12_bimo_t(ipoint,3,l,j) )
|
||||||
integral += weight * mos_l_in_r_array_transp(ipoint,l) * mos_r_in_r_array_transp(ipoint,j) &
|
integral += weight * mos_l_in_r_array_transp(ipoint,l) * mos_r_in_r_array_transp(ipoint,j) &
|
||||||
* ( int2_grad1_u12_bimo_t(ipoint,1,n,m) * int2_grad1_u12_bimo_t(ipoint,1,k,i) &
|
* ( int2_grad1_u12_bimo_t(ipoint,1,n,m) * int2_grad1_u12_bimo_t(ipoint,1,k,i) &
|
||||||
+ int2_grad1_u12_bimo_t(ipoint,2,n,m) * int2_grad1_u12_bimo_t(ipoint,2,k,i) &
|
+ int2_grad1_u12_bimo_t(ipoint,2,n,m) * int2_grad1_u12_bimo_t(ipoint,2,k,i) &
|
||||||
+ int2_grad1_u12_bimo_t(ipoint,3,n,m) * int2_grad1_u12_bimo_t(ipoint,3,k,i) )
|
+ int2_grad1_u12_bimo_t(ipoint,3,n,m) * int2_grad1_u12_bimo_t(ipoint,3,k,i) )
|
||||||
integral += weight * mos_l_in_r_array_transp(ipoint,n) * mos_r_in_r_array_transp(ipoint,m) &
|
integral += weight * mos_l_in_r_array_transp(ipoint,n) * mos_r_in_r_array_transp(ipoint,m) &
|
||||||
* ( int2_grad1_u12_bimo_t(ipoint,1,l,j) * int2_grad1_u12_bimo_t(ipoint,1,k,i) &
|
* ( int2_grad1_u12_bimo_t(ipoint,1,l,j) * int2_grad1_u12_bimo_t(ipoint,1,k,i) &
|
||||||
+ int2_grad1_u12_bimo_t(ipoint,2,l,j) * int2_grad1_u12_bimo_t(ipoint,2,k,i) &
|
+ int2_grad1_u12_bimo_t(ipoint,2,l,j) * int2_grad1_u12_bimo_t(ipoint,2,k,i) &
|
||||||
+ int2_grad1_u12_bimo_t(ipoint,3,l,j) * int2_grad1_u12_bimo_t(ipoint,3,k,i) )
|
+ int2_grad1_u12_bimo_t(ipoint,3,l,j) * int2_grad1_u12_bimo_t(ipoint,3,k,i) )
|
||||||
|
|
||||||
enddo
|
enddo
|
||||||
|
@ -20,6 +20,7 @@ BEGIN_PROVIDER [double precision, ao_two_e_vartc_tot, (ao_num, ao_num, ao_num, a
|
|||||||
enddo
|
enddo
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
|
||||||
BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_num) ]
|
BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_num) ]
|
||||||
@ -40,20 +41,7 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
|
|||||||
|
|
||||||
provide j1b_type
|
provide j1b_type
|
||||||
|
|
||||||
if(j1b_type .eq. 3) then
|
if(j1b_type .eq. 0) then
|
||||||
|
|
||||||
do j = 1, ao_num
|
|
||||||
do l = 1, ao_num
|
|
||||||
do i = 1, ao_num
|
|
||||||
do k = 1, ao_num
|
|
||||||
ao_two_e_tc_tot(k,i,l,j) = ao_tc_int_chemist(k,i,l,j)
|
|
||||||
!write(222,*) ao_two_e_tc_tot(k,i,l,j)
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
|
|
||||||
else
|
|
||||||
|
|
||||||
PROVIDE ao_tc_sym_two_e_pot_in_map
|
PROVIDE ao_tc_sym_two_e_pot_in_map
|
||||||
|
|
||||||
@ -77,6 +65,21 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
|
|||||||
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
|
||||||
|
|
||||||
endif
|
endif
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
@ -17,6 +17,8 @@ subroutine ao_to_mo_bi_ortho(A_ao, LDA_ao, A_mo, LDA_mo)
|
|||||||
double precision, intent(out) :: A_mo(LDA_mo,mo_num)
|
double precision, intent(out) :: A_mo(LDA_mo,mo_num)
|
||||||
double precision, allocatable :: T(:,:)
|
double precision, allocatable :: T(:,:)
|
||||||
|
|
||||||
|
PROVIDE mo_l_coef mo_r_coef
|
||||||
|
|
||||||
allocate ( T(ao_num,mo_num) )
|
allocate ( T(ao_num,mo_num) )
|
||||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T
|
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T
|
||||||
|
|
||||||
@ -54,6 +56,8 @@ subroutine mo_to_ao_bi_ortho(A_mo, LDA_mo, A_ao, LDA_ao)
|
|||||||
double precision, intent(out) :: A_ao(LDA_ao,ao_num)
|
double precision, intent(out) :: A_ao(LDA_ao,ao_num)
|
||||||
double precision, allocatable :: tmp_1(:,:), tmp_2(:,:)
|
double precision, allocatable :: tmp_1(:,:), tmp_2(:,:)
|
||||||
|
|
||||||
|
PROVIDE mo_l_coef mo_r_coef
|
||||||
|
|
||||||
! ao_overlap x mo_r_coef
|
! ao_overlap x mo_r_coef
|
||||||
allocate( tmp_1(ao_num,mo_num) )
|
allocate( tmp_1(ao_num,mo_num) )
|
||||||
call dgemm( 'N', 'N', ao_num, mo_num, ao_num, 1.d0 &
|
call dgemm( 'N', 'N', ao_num, mo_num, ao_num, 1.d0 &
|
||||||
|
@ -12,32 +12,27 @@
|
|||||||
double precision :: accu_d, accu_nd
|
double precision :: accu_d, accu_nd
|
||||||
double precision, allocatable :: tmp(:,:)
|
double precision, allocatable :: tmp(:,:)
|
||||||
|
|
||||||
! TODO : re do the DEGEMM
|
! overlap_bi_ortho = 0.d0
|
||||||
|
! do i = 1, mo_num
|
||||||
|
! do k = 1, mo_num
|
||||||
|
! do m = 1, ao_num
|
||||||
|
! do n = 1, ao_num
|
||||||
|
! overlap_bi_ortho(k,i) += ao_overlap(n,m) * mo_l_coef(n,k) * mo_r_coef(m,i)
|
||||||
|
! enddo
|
||||||
|
! enddo
|
||||||
|
! enddo
|
||||||
|
! enddo
|
||||||
|
|
||||||
overlap_bi_ortho = 0.d0
|
allocate( tmp(mo_num,ao_num) )
|
||||||
do i = 1, mo_num
|
! tmp <-- L.T x S_ao
|
||||||
do k = 1, mo_num
|
call dgemm( "T", "N", mo_num, ao_num, ao_num, 1.d0 &
|
||||||
do m = 1, ao_num
|
, mo_l_coef(1,1), size(mo_l_coef, 1), ao_overlap(1,1), size(ao_overlap, 1) &
|
||||||
do n = 1, ao_num
|
, 0.d0, tmp(1,1), size(tmp, 1) )
|
||||||
overlap_bi_ortho(k,i) += ao_overlap(n,m) * mo_l_coef(n,k) * mo_r_coef(m,i)
|
! S <-- tmp x R
|
||||||
enddo
|
call dgemm( "N", "N", mo_num, mo_num, ao_num, 1.d0 &
|
||||||
enddo
|
, tmp(1,1), size(tmp, 1), mo_r_coef(1,1), size(mo_r_coef, 1) &
|
||||||
enddo
|
, 0.d0, overlap_bi_ortho(1,1), size(overlap_bi_ortho, 1) )
|
||||||
enddo
|
deallocate(tmp)
|
||||||
|
|
||||||
! allocate( tmp(mo_num,ao_num) )
|
|
||||||
!
|
|
||||||
! ! tmp <-- L.T x S_ao
|
|
||||||
! call dgemm( "T", "N", mo_num, ao_num, ao_num, 1.d0 &
|
|
||||||
! , mo_l_coef, size(mo_l_coef, 1), ao_overlap, size(ao_overlap, 1) &
|
|
||||||
! , 0.d0, tmp, size(tmp, 1) )
|
|
||||||
!
|
|
||||||
! ! S <-- tmp x R
|
|
||||||
! call dgemm( "N", "N", mo_num, mo_num, ao_num, 1.d0 &
|
|
||||||
! , tmp, size(tmp, 1), mo_r_coef, size(mo_r_coef, 1) &
|
|
||||||
! , 0.d0, overlap_bi_ortho, size(overlap_bi_ortho, 1) )
|
|
||||||
!
|
|
||||||
! deallocate( tmp )
|
|
||||||
|
|
||||||
do i = 1, mo_num
|
do i = 1, mo_num
|
||||||
overlap_diag_bi_ortho(i) = overlap_bi_ortho(i,i)
|
overlap_diag_bi_ortho(i) = overlap_bi_ortho(i,i)
|
||||||
@ -84,20 +79,41 @@ END_PROVIDER
|
|||||||
END_DOC
|
END_DOC
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
integer :: i, j, p, q
|
integer :: i, j, p, q
|
||||||
|
double precision, allocatable :: tmp(:,:)
|
||||||
|
|
||||||
overlap_mo_r = 0.d0
|
!overlap_mo_r = 0.d0
|
||||||
overlap_mo_l = 0.d0
|
!overlap_mo_l = 0.d0
|
||||||
do i = 1, mo_num
|
!do i = 1, mo_num
|
||||||
do j = 1, mo_num
|
! do j = 1, mo_num
|
||||||
do p = 1, ao_num
|
! do p = 1, ao_num
|
||||||
do q = 1, ao_num
|
! do q = 1, ao_num
|
||||||
overlap_mo_r(j,i) += mo_r_coef(q,i) * mo_r_coef(p,j) * ao_overlap(q,p)
|
! overlap_mo_r(j,i) += mo_r_coef(q,i) * mo_r_coef(p,j) * ao_overlap(q,p)
|
||||||
overlap_mo_l(j,i) += mo_l_coef(q,i) * mo_l_coef(p,j) * ao_overlap(q,p)
|
! overlap_mo_l(j,i) += mo_l_coef(q,i) * mo_l_coef(p,j) * ao_overlap(q,p)
|
||||||
enddo
|
! enddo
|
||||||
enddo
|
! enddo
|
||||||
enddo
|
! enddo
|
||||||
enddo
|
!enddo
|
||||||
|
|
||||||
|
allocate( tmp(mo_num,ao_num) )
|
||||||
|
|
||||||
|
tmp = 0.d0
|
||||||
|
call dgemm( "T", "N", mo_num, ao_num, ao_num, 1.d0 &
|
||||||
|
, mo_r_coef(1,1), size(mo_r_coef, 1), ao_overlap(1,1), size(ao_overlap, 1) &
|
||||||
|
, 0.d0, tmp(1,1), size(tmp, 1) )
|
||||||
|
call dgemm( "N", "N", mo_num, mo_num, ao_num, 1.d0 &
|
||||||
|
, tmp(1,1), size(tmp, 1), mo_r_coef(1,1), size(mo_r_coef, 1) &
|
||||||
|
, 0.d0, overlap_mo_r(1,1), size(overlap_mo_r, 1) )
|
||||||
|
|
||||||
|
tmp = 0.d0
|
||||||
|
call dgemm( "T", "N", mo_num, ao_num, ao_num, 1.d0 &
|
||||||
|
, mo_l_coef(1,1), size(mo_l_coef, 1), ao_overlap(1,1), size(ao_overlap, 1) &
|
||||||
|
, 0.d0, tmp(1,1), size(tmp, 1) )
|
||||||
|
call dgemm( "N", "N", mo_num, mo_num, ao_num, 1.d0 &
|
||||||
|
, tmp(1,1), size(tmp, 1), mo_l_coef(1,1), size(mo_l_coef, 1) &
|
||||||
|
, 0.d0, overlap_mo_l(1,1), size(overlap_mo_l, 1) )
|
||||||
|
|
||||||
|
deallocate(tmp)
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
@ -1,4 +1,4 @@
|
|||||||
subroutine pt2_tc_bi_ortho
|
subroutine tc_pt2
|
||||||
use selection_types
|
use selection_types
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
@ -15,7 +15,7 @@ subroutine pt2_tc_bi_ortho
|
|||||||
double precision, external :: memory_of_double
|
double precision, external :: memory_of_double
|
||||||
double precision :: correlation_energy_ratio,E_denom,E_tc,norm
|
double precision :: correlation_energy_ratio,E_denom,E_tc,norm
|
||||||
double precision, allocatable :: ept2(:), pt1(:),extrap_energy(:)
|
double precision, allocatable :: ept2(:), pt1(:),extrap_energy(:)
|
||||||
PROVIDE H_apply_buffer_allocated distributed_davidson mo_two_e_integrals_in_map
|
PROVIDE H_apply_buffer_allocated distributed_davidson
|
||||||
|
|
||||||
print*,'Diagonal elements of the Fock matrix '
|
print*,'Diagonal elements of the Fock matrix '
|
||||||
do i = 1, mo_num
|
do i = 1, mo_num
|
||||||
@ -44,24 +44,14 @@ subroutine pt2_tc_bi_ortho
|
|||||||
pt2_data % overlap= 0.d0
|
pt2_data % overlap= 0.d0
|
||||||
pt2_data % variance = huge(1.e0)
|
pt2_data % variance = huge(1.e0)
|
||||||
|
|
||||||
if (s2_eig) then
|
!!!! WARNING !!!! SEEMS TO BE PROBLEM WTH make_s2_eigenfunction !!!! THE DETERMINANTS CAN APPEAR TWICE IN THE WFT DURING SELECTION
|
||||||
call make_s2_eigenfunction
|
! if (s2_eig) then
|
||||||
endif
|
! call make_s2_eigenfunction
|
||||||
|
! endif
|
||||||
print_pt2 = .False.
|
print_pt2 = .False.
|
||||||
call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2)
|
call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2)
|
||||||
! call routine_save_right
|
! call routine_save_right
|
||||||
|
|
||||||
if (N_det > N_det_max) then
|
|
||||||
psi_det(1:N_int,1:2,1:N_det) = psi_det_generators(1:N_int,1:2,1:N_det)
|
|
||||||
psi_coef(1:N_det,1:N_states) = psi_coef_sorted_tc_gen(1:N_det,1:N_states)
|
|
||||||
N_det = N_det_max
|
|
||||||
soft_touch N_det psi_det psi_coef
|
|
||||||
if (s2_eig) then
|
|
||||||
call make_s2_eigenfunction
|
|
||||||
endif
|
|
||||||
print_pt2 = .False.
|
|
||||||
call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2)
|
|
||||||
endif
|
|
||||||
|
|
||||||
allocate(ept2(1000),pt1(1000),extrap_energy(100))
|
allocate(ept2(1000),pt1(1000),extrap_energy(100))
|
||||||
|
|
||||||
@ -71,18 +61,11 @@ subroutine pt2_tc_bi_ortho
|
|||||||
! soft_touch thresh_it_dav
|
! soft_touch thresh_it_dav
|
||||||
|
|
||||||
print_pt2 = .True.
|
print_pt2 = .True.
|
||||||
to_select = int(sqrt(dble(N_states))*dble(N_det)*selection_factor)
|
|
||||||
to_select = max(N_states_diag, to_select)
|
|
||||||
|
|
||||||
E_denom = E_tc ! TC Energy of the current wave function
|
|
||||||
call pt2_dealloc(pt2_data)
|
call pt2_dealloc(pt2_data)
|
||||||
call pt2_dealloc(pt2_data_err)
|
call pt2_dealloc(pt2_data_err)
|
||||||
call pt2_alloc(pt2_data, N_states)
|
call pt2_alloc(pt2_data, N_states)
|
||||||
call pt2_alloc(pt2_data_err, N_states)
|
call pt2_alloc(pt2_data_err, N_states)
|
||||||
call ZMQ_pt2(E_denom, pt2_data, pt2_data_err, relative_error,to_select) ! Stochastic PT2 and selection
|
call ZMQ_pt2(E_tc, pt2_data, pt2_data_err, relative_error,0) ! Stochastic PT2 and selection
|
||||||
|
|
||||||
N_iter += 1
|
|
||||||
|
|
||||||
call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2)
|
call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2)
|
||||||
|
|
||||||
end
|
end
|
||||||
|
@ -868,7 +868,6 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
|
|||||||
! <det|H(j)|psi_0> and transpose
|
! <det|H(j)|psi_0> and transpose
|
||||||
! -------------------------------------------
|
! -------------------------------------------
|
||||||
|
|
||||||
! call htilde_mu_mat_bi_ortho_tot(det, det, N_int, Hii)
|
|
||||||
double precision :: hmono, htwoe, hthree
|
double precision :: hmono, htwoe, hthree
|
||||||
call diag_htilde_mu_mat_fock_bi_ortho(N_int, det, hmono, htwoe, hthree, hii)
|
call diag_htilde_mu_mat_fock_bi_ortho(N_int, det, hmono, htwoe, hthree, hii)
|
||||||
do istate = 1,N_states
|
do istate = 1,N_states
|
||||||
@ -878,8 +877,8 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
|
|||||||
psi_h_alpha = 0.d0
|
psi_h_alpha = 0.d0
|
||||||
alpha_h_psi = 0.d0
|
alpha_h_psi = 0.d0
|
||||||
do iii = 1, N_det_selectors
|
do iii = 1, N_det_selectors
|
||||||
call htilde_mu_mat_bi_ortho_tot(psi_selectors(1,1,iii), det, N_int, i_h_alpha)
|
call htilde_mu_mat_bi_ortho_tot_slow(psi_selectors(1,1,iii), det, N_int, i_h_alpha)
|
||||||
call htilde_mu_mat_bi_ortho_tot(det, psi_selectors(1,1,iii), N_int, alpha_h_i)
|
call htilde_mu_mat_bi_ortho_tot_slow(det, psi_selectors(1,1,iii), N_int, alpha_h_i)
|
||||||
call get_excitation_degree(psi_selectors(1,1,iii), det,degree,N_int)
|
call get_excitation_degree(psi_selectors(1,1,iii), det,degree,N_int)
|
||||||
if(degree == 0)then
|
if(degree == 0)then
|
||||||
print*,'problem !!!'
|
print*,'problem !!!'
|
||||||
|
19
src/cosgtos_ao_int/EZFIO.cfg
Normal file
19
src/cosgtos_ao_int/EZFIO.cfg
Normal file
@ -0,0 +1,19 @@
|
|||||||
|
[ao_expoim_cosgtos]
|
||||||
|
type: double precision
|
||||||
|
doc: imag part for Exponents for each primitive of each cosGTOs |AO|
|
||||||
|
size: (ao_basis.ao_num,ao_basis.ao_prim_num_max)
|
||||||
|
interface: ezfio, provider
|
||||||
|
|
||||||
|
[use_cosgtos]
|
||||||
|
type: logical
|
||||||
|
doc: If true, use cosgtos for AO integrals
|
||||||
|
interface: ezfio,provider,ocaml
|
||||||
|
default: False
|
||||||
|
|
||||||
|
[ao_integrals_threshold]
|
||||||
|
type: Threshold
|
||||||
|
doc: If | (pq|rs) | < `ao_integrals_threshold` then (pq|rs) is zero
|
||||||
|
interface: ezfio,provider,ocaml
|
||||||
|
default: 1.e-15
|
||||||
|
ezfio_name: threshold_ao
|
||||||
|
|
2
src/cosgtos_ao_int/NEED
Normal file
2
src/cosgtos_ao_int/NEED
Normal file
@ -0,0 +1,2 @@
|
|||||||
|
ezfio_files
|
||||||
|
ao_basis
|
4
src/cosgtos_ao_int/README.rst
Normal file
4
src/cosgtos_ao_int/README.rst
Normal file
@ -0,0 +1,4 @@
|
|||||||
|
==============
|
||||||
|
cosgtos_ao_int
|
||||||
|
==============
|
||||||
|
|
210
src/cosgtos_ao_int/aos_cosgtos.irp.f
Normal file
210
src/cosgtos_ao_int/aos_cosgtos.irp.f
Normal file
@ -0,0 +1,210 @@
|
|||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ double precision, ao_coef_norm_ord_transp_cosgtos, (ao_prim_num_max, ao_num) ]
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer :: i, j
|
||||||
|
|
||||||
|
do j = 1, ao_num
|
||||||
|
do i = 1, ao_prim_num_max
|
||||||
|
ao_coef_norm_ord_transp_cosgtos(i,j) = ao_coef_norm_ord_cosgtos(j,i)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ complex*16, ao_expo_ord_transp_cosgtos, (ao_prim_num_max, ao_num) ]
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer :: i, j
|
||||||
|
|
||||||
|
do j = 1, ao_num
|
||||||
|
do i = 1, ao_prim_num_max
|
||||||
|
ao_expo_ord_transp_cosgtos(i,j) = ao_expo_ord_cosgtos(j,i)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ double precision, ao_coef_norm_cosgtos, (ao_num, ao_prim_num_max) ]
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
integer :: i, j, powA(3), nz
|
||||||
|
double precision :: norm
|
||||||
|
complex*16 :: overlap_x, overlap_y, overlap_z, C_A(3)
|
||||||
|
complex*16 :: integ1, integ2, expo
|
||||||
|
|
||||||
|
nz = 100
|
||||||
|
|
||||||
|
C_A(1) = (0.d0, 0.d0)
|
||||||
|
C_A(2) = (0.d0, 0.d0)
|
||||||
|
C_A(3) = (0.d0, 0.d0)
|
||||||
|
|
||||||
|
ao_coef_norm_cosgtos = 0.d0
|
||||||
|
|
||||||
|
do i = 1, ao_num
|
||||||
|
|
||||||
|
powA(1) = ao_power(i,1)
|
||||||
|
powA(2) = ao_power(i,2)
|
||||||
|
powA(3) = ao_power(i,3)
|
||||||
|
|
||||||
|
! Normalization of the primitives
|
||||||
|
if(primitives_normalized) then
|
||||||
|
|
||||||
|
do j = 1, ao_prim_num(i)
|
||||||
|
|
||||||
|
expo = ao_expo(i,j) + (0.d0, 1.d0) * ao_expoim_cosgtos(i,j)
|
||||||
|
|
||||||
|
call overlap_cgaussian_xyz(C_A, C_A, expo, expo, powA, powA, overlap_x, overlap_y, overlap_z, integ1, nz)
|
||||||
|
call overlap_cgaussian_xyz(C_A, C_A, conjg(expo), expo, powA, powA, overlap_x, overlap_y, overlap_z, integ2, nz)
|
||||||
|
|
||||||
|
norm = 2.d0 * real( integ1 + integ2 )
|
||||||
|
|
||||||
|
ao_coef_norm_cosgtos(i,j) = ao_coef(i,j) / dsqrt(norm)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
else
|
||||||
|
|
||||||
|
do j = 1, ao_prim_num(i)
|
||||||
|
ao_coef_norm_cosgtos(i,j) = ao_coef(i,j)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
endif
|
||||||
|
|
||||||
|
enddo
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ double precision, ao_coef_norm_ord_cosgtos, (ao_num, ao_prim_num_max) ]
|
||||||
|
&BEGIN_PROVIDER [ complex*16 , ao_expo_ord_cosgtos, (ao_num, ao_prim_num_max) ]
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer :: i, j
|
||||||
|
integer :: iorder(ao_prim_num_max)
|
||||||
|
double precision :: d(ao_prim_num_max,3)
|
||||||
|
|
||||||
|
d = 0.d0
|
||||||
|
|
||||||
|
do i = 1, ao_num
|
||||||
|
|
||||||
|
do j = 1, ao_prim_num(i)
|
||||||
|
iorder(j) = j
|
||||||
|
d(j,1) = ao_expo(i,j)
|
||||||
|
d(j,2) = ao_coef_norm_cosgtos(i,j)
|
||||||
|
d(j,3) = ao_expoim_cosgtos(i,j)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
call dsort (d(1,1), iorder, ao_prim_num(i))
|
||||||
|
call dset_order(d(1,2), iorder, ao_prim_num(i))
|
||||||
|
call dset_order(d(1,3), iorder, ao_prim_num(i))
|
||||||
|
|
||||||
|
do j = 1, ao_prim_num(i)
|
||||||
|
ao_expo_ord_cosgtos (i,j) = d(j,1) + (0.d0, 1.d0) * d(j,3)
|
||||||
|
ao_coef_norm_ord_cosgtos(i,j) = d(j,2)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
enddo
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ double precision, ao_overlap_cosgtos, (ao_num, ao_num) ]
|
||||||
|
&BEGIN_PROVIDER [ double precision, ao_overlap_cosgtos_x, (ao_num, ao_num) ]
|
||||||
|
&BEGIN_PROVIDER [ double precision, ao_overlap_cosgtos_y, (ao_num, ao_num) ]
|
||||||
|
&BEGIN_PROVIDER [ double precision, ao_overlap_cosgtos_z, (ao_num, ao_num) ]
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer :: i, j, n, l, dim1, power_A(3), power_B(3)
|
||||||
|
double precision :: c, overlap, overlap_x, overlap_y, overlap_z
|
||||||
|
complex*16 :: alpha, beta, A_center(3), B_center(3)
|
||||||
|
complex*16 :: overlap1, overlap_x1, overlap_y1, overlap_z1
|
||||||
|
complex*16 :: overlap2, overlap_x2, overlap_y2, overlap_z2
|
||||||
|
|
||||||
|
ao_overlap_cosgtos = 0.d0
|
||||||
|
ao_overlap_cosgtos_x = 0.d0
|
||||||
|
ao_overlap_cosgtos_y = 0.d0
|
||||||
|
ao_overlap_cosgtos_z = 0.d0
|
||||||
|
|
||||||
|
dim1 = 100
|
||||||
|
|
||||||
|
!$OMP PARALLEL DO SCHEDULE(GUIDED) &
|
||||||
|
!$OMP DEFAULT(NONE) &
|
||||||
|
!$OMP PRIVATE( A_center, B_center, power_A, power_B, alpha, beta, i, j, n, l, c &
|
||||||
|
!$OMP , overlap_x , overlap_y , overlap_z , overlap &
|
||||||
|
!$OMP , overlap_x1, overlap_y1, overlap_z1, overlap1 &
|
||||||
|
!$OMP , overlap_x2, overlap_y2, overlap_z2, overlap2 ) &
|
||||||
|
!$OMP SHARED( nucl_coord, ao_power, ao_prim_num, ao_num, ao_nucl, dim1 &
|
||||||
|
!$OMP , ao_overlap_cosgtos_x, ao_overlap_cosgtos_y, ao_overlap_cosgtos_z, ao_overlap_cosgtos &
|
||||||
|
!$OMP , ao_coef_norm_ord_transp_cosgtos, ao_expo_ord_transp_cosgtos )
|
||||||
|
|
||||||
|
do j = 1, ao_num
|
||||||
|
|
||||||
|
A_center(1) = nucl_coord(ao_nucl(j),1) * (1.d0, 0.d0)
|
||||||
|
A_center(2) = nucl_coord(ao_nucl(j),2) * (1.d0, 0.d0)
|
||||||
|
A_center(3) = nucl_coord(ao_nucl(j),3) * (1.d0, 0.d0)
|
||||||
|
power_A(1) = ao_power(j,1)
|
||||||
|
power_A(2) = ao_power(j,2)
|
||||||
|
power_A(3) = ao_power(j,3)
|
||||||
|
|
||||||
|
do i = 1, ao_num
|
||||||
|
|
||||||
|
B_center(1) = nucl_coord(ao_nucl(i),1) * (1.d0, 0.d0)
|
||||||
|
B_center(2) = nucl_coord(ao_nucl(i),2) * (1.d0, 0.d0)
|
||||||
|
B_center(3) = nucl_coord(ao_nucl(i),3) * (1.d0, 0.d0)
|
||||||
|
power_B(1) = ao_power(i,1)
|
||||||
|
power_B(2) = ao_power(i,2)
|
||||||
|
power_B(3) = ao_power(i,3)
|
||||||
|
|
||||||
|
do n = 1, ao_prim_num(j)
|
||||||
|
alpha = ao_expo_ord_transp_cosgtos(n,j)
|
||||||
|
|
||||||
|
do l = 1, ao_prim_num(i)
|
||||||
|
c = ao_coef_norm_ord_transp_cosgtos(n,j) * ao_coef_norm_ord_transp_cosgtos(l,i)
|
||||||
|
beta = ao_expo_ord_transp_cosgtos(l,i)
|
||||||
|
|
||||||
|
call overlap_cgaussian_xyz( A_center, B_center, alpha, beta, power_A, power_B &
|
||||||
|
, overlap_x1, overlap_y1, overlap_z1, overlap1, dim1 )
|
||||||
|
|
||||||
|
call overlap_cgaussian_xyz( A_center, B_center, conjg(alpha), beta, power_A, power_B &
|
||||||
|
, overlap_x2, overlap_y2, overlap_z2, overlap2, dim1 )
|
||||||
|
|
||||||
|
overlap_x = 2.d0 * real( overlap_x1 + overlap_x2 )
|
||||||
|
overlap_y = 2.d0 * real( overlap_y1 + overlap_y2 )
|
||||||
|
overlap_z = 2.d0 * real( overlap_z1 + overlap_z2 )
|
||||||
|
overlap = 2.d0 * real( overlap1 + overlap2 )
|
||||||
|
|
||||||
|
ao_overlap_cosgtos(i,j) = ao_overlap_cosgtos(i,j) + c * overlap
|
||||||
|
|
||||||
|
if( isnan(ao_overlap_cosgtos(i,j)) ) then
|
||||||
|
print*,'i, j', i, j
|
||||||
|
print*,'l, n', l, n
|
||||||
|
print*,'c, overlap', c, overlap
|
||||||
|
print*, overlap_x, overlap_y, overlap_z
|
||||||
|
stop
|
||||||
|
endif
|
||||||
|
|
||||||
|
ao_overlap_cosgtos_x(i,j) = ao_overlap_cosgtos_x(i,j) + c * overlap_x
|
||||||
|
ao_overlap_cosgtos_y(i,j) = ao_overlap_cosgtos_y(i,j) + c * overlap_y
|
||||||
|
ao_overlap_cosgtos_z(i,j) = ao_overlap_cosgtos_z(i,j) + c * overlap_z
|
||||||
|
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
!$OMP END PARALLEL DO
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
|
||||||
|
|
7
src/cosgtos_ao_int/cosgtos_ao_int.irp.f
Normal file
7
src/cosgtos_ao_int/cosgtos_ao_int.irp.f
Normal file
@ -0,0 +1,7 @@
|
|||||||
|
program cosgtos_ao_int
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! TODO : Put the documentation of the program here
|
||||||
|
END_DOC
|
||||||
|
print *, 'Hello world'
|
||||||
|
end
|
535
src/cosgtos_ao_int/one_e_Coul_integrals.irp.f
Normal file
535
src/cosgtos_ao_int/one_e_Coul_integrals.irp.f
Normal file
@ -0,0 +1,535 @@
|
|||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ double precision, ao_integrals_n_e_cosgtos, (ao_num, ao_num)]
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
!
|
||||||
|
! Nucleus-electron interaction, in the cosgtos |AO| basis set.
|
||||||
|
!
|
||||||
|
! :math:`\langle \chi_i | -\sum_A \frac{1}{|r-R_A|} | \chi_j \rangle`
|
||||||
|
!
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer :: num_A, num_B, power_A(3), power_B(3)
|
||||||
|
integer :: i, j, k, l, n_pt_in, m
|
||||||
|
double precision :: c, Z, A_center(3), B_center(3), C_center(3)
|
||||||
|
complex*16 :: alpha, beta, c1, c2
|
||||||
|
|
||||||
|
complex*16 :: NAI_pol_mult_cosgtos
|
||||||
|
|
||||||
|
ao_integrals_n_e_cosgtos = 0.d0
|
||||||
|
|
||||||
|
!$OMP PARALLEL &
|
||||||
|
!$OMP DEFAULT (NONE) &
|
||||||
|
!$OMP PRIVATE ( i, j, k, l, m, alpha, beta, A_center, B_center, C_center &
|
||||||
|
!$OMP , power_A, power_B, num_A, num_B, Z, c, c1, c2, n_pt_in ) &
|
||||||
|
!$OMP SHARED ( ao_num, ao_prim_num, ao_nucl, nucl_coord, ao_power, nucl_num, nucl_charge &
|
||||||
|
!$OMP , ao_expo_ord_transp_cosgtos, ao_coef_norm_ord_transp_cosgtos &
|
||||||
|
!$OMP , n_pt_max_integrals, ao_integrals_n_e_cosgtos )
|
||||||
|
|
||||||
|
n_pt_in = n_pt_max_integrals
|
||||||
|
|
||||||
|
!$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_ord_transp_cosgtos(l,j)
|
||||||
|
|
||||||
|
do m = 1, ao_prim_num(i)
|
||||||
|
beta = ao_expo_ord_transp_cosgtos(m,i)
|
||||||
|
|
||||||
|
c = 0.d0
|
||||||
|
do k = 1, nucl_num
|
||||||
|
|
||||||
|
Z = nucl_charge(k)
|
||||||
|
|
||||||
|
C_center(1:3) = nucl_coord(k,1:3)
|
||||||
|
|
||||||
|
!print *, ' '
|
||||||
|
!print *, A_center, B_center, C_center, power_A, power_B
|
||||||
|
!print *, real(alpha), real(beta)
|
||||||
|
|
||||||
|
c1 = NAI_pol_mult_cosgtos( A_center, B_center, power_A, power_B &
|
||||||
|
, alpha, beta, C_center, n_pt_in )
|
||||||
|
|
||||||
|
!c2 = c1
|
||||||
|
c2 = NAI_pol_mult_cosgtos( A_center, B_center, power_A, power_B &
|
||||||
|
, conjg(alpha), beta, C_center, n_pt_in )
|
||||||
|
|
||||||
|
!print *, ' c1 = ', real(c1)
|
||||||
|
!print *, ' c2 = ', real(c2)
|
||||||
|
|
||||||
|
c = c - Z * 2.d0 * real(c1 + c2)
|
||||||
|
|
||||||
|
enddo
|
||||||
|
ao_integrals_n_e_cosgtos(i,j) = ao_integrals_n_e_cosgtos(i,j) &
|
||||||
|
+ ao_coef_norm_ord_transp_cosgtos(l,j) &
|
||||||
|
* ao_coef_norm_ord_transp_cosgtos(m,i) * c
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
!$OMP END DO
|
||||||
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
complex*16 function NAI_pol_mult_cosgtos(A_center, B_center, power_A, power_B, alpha, beta, C_center, n_pt_in)
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
!
|
||||||
|
! Computes the electron-nucleus attraction with two primitves cosgtos.
|
||||||
|
!
|
||||||
|
! :math:`\langle g_i | \frac{1}{|r-R_c|} | g_j \rangle`
|
||||||
|
!
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
include 'utils/constants.include.F'
|
||||||
|
|
||||||
|
integer, intent(in) :: n_pt_in, power_A(3), power_B(3)
|
||||||
|
double precision, intent(in) :: C_center(3), A_center(3), B_center(3)
|
||||||
|
complex*16, intent(in) :: alpha, beta
|
||||||
|
|
||||||
|
integer :: i, n_pt, n_pt_out
|
||||||
|
double precision :: dist, const_mod
|
||||||
|
complex*16 :: p, p_inv, rho, dist_integral, const, const_factor, coeff, factor
|
||||||
|
complex*16 :: accu, P_center(3)
|
||||||
|
complex*16 :: d(0:n_pt_in)
|
||||||
|
|
||||||
|
complex*16 :: V_n_e_cosgtos
|
||||||
|
complex*16 :: crint
|
||||||
|
|
||||||
|
if ( (A_center(1)/=B_center(1)) .or. (A_center(2)/=B_center(2)) .or. (A_center(3)/=B_center(3)) .or. &
|
||||||
|
(A_center(1)/=C_center(1)) .or. (A_center(2)/=C_center(2)) .or. (A_center(3)/=C_center(3)) ) then
|
||||||
|
|
||||||
|
continue
|
||||||
|
|
||||||
|
else
|
||||||
|
|
||||||
|
NAI_pol_mult_cosgtos = V_n_e_cosgtos( power_A(1), power_A(2), power_A(3) &
|
||||||
|
, power_B(1), power_B(2), power_B(3) &
|
||||||
|
, alpha, beta )
|
||||||
|
return
|
||||||
|
|
||||||
|
endif
|
||||||
|
|
||||||
|
p = alpha + beta
|
||||||
|
p_inv = (1.d0, 0.d0) / p
|
||||||
|
rho = alpha * beta * p_inv
|
||||||
|
|
||||||
|
dist = 0.d0
|
||||||
|
dist_integral = (0.d0, 0.d0)
|
||||||
|
do i = 1, 3
|
||||||
|
P_center(i) = (alpha * A_center(i) + beta * B_center(i)) * p_inv
|
||||||
|
dist += (A_center(i) - B_center(i)) * (A_center(i) - B_center(i))
|
||||||
|
dist_integral += (P_center(i) - C_center(i)) * (P_center(i) - C_center(i))
|
||||||
|
enddo
|
||||||
|
|
||||||
|
const_factor = dist * rho
|
||||||
|
const = p * dist_integral
|
||||||
|
|
||||||
|
const_mod = dsqrt(real(const_factor)*real(const_factor) + aimag(const_factor)*aimag(const_factor))
|
||||||
|
if(const_mod > 80.d0) then
|
||||||
|
NAI_pol_mult_cosgtos = (0.d0, 0.d0)
|
||||||
|
return
|
||||||
|
endif
|
||||||
|
|
||||||
|
factor = zexp(-const_factor)
|
||||||
|
coeff = dtwo_pi * factor * p_inv
|
||||||
|
|
||||||
|
do i = 0, n_pt_in
|
||||||
|
d(i) = (0.d0, 0.d0)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
n_pt = 2 * ( (power_A(1) + power_B(1)) + (power_A(2) + power_B(2)) + (power_A(3) + power_B(3)) )
|
||||||
|
if(n_pt == 0) then
|
||||||
|
NAI_pol_mult_cosgtos = coeff * crint(0, const)
|
||||||
|
return
|
||||||
|
endif
|
||||||
|
|
||||||
|
call give_cpolynomial_mult_center_one_e( A_center, B_center, alpha, beta &
|
||||||
|
, power_A, power_B, C_center, n_pt_in, d, n_pt_out)
|
||||||
|
|
||||||
|
if(n_pt_out < 0) then
|
||||||
|
NAI_pol_mult_cosgtos = (0.d0, 0.d0)
|
||||||
|
return
|
||||||
|
endif
|
||||||
|
|
||||||
|
accu = (0.d0, 0.d0)
|
||||||
|
do i = 0, n_pt_out, 2
|
||||||
|
accu += crint(shiftr(i, 1), const) * d(i)
|
||||||
|
|
||||||
|
! print *, shiftr(i, 1), real(const), real(d(i)), real(crint(shiftr(i, 1), const))
|
||||||
|
enddo
|
||||||
|
NAI_pol_mult_cosgtos = accu * coeff
|
||||||
|
|
||||||
|
end function NAI_pol_mult_cosgtos
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
subroutine give_cpolynomial_mult_center_one_e( A_center, B_center, alpha, beta &
|
||||||
|
, power_A, power_B, C_center, n_pt_in, d, n_pt_out)
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
! Returns the explicit polynomial in terms of the "t" variable of the following
|
||||||
|
!
|
||||||
|
! $I_{x1}(a_x, d_x,p,q) \times I_{x1}(a_y, d_y,p,q) \times I_{x1}(a_z, d_z,p,q)$.
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
integer, intent(in) :: n_pt_in, power_A(3), power_B(3)
|
||||||
|
double precision, intent(in) :: A_center(3), B_center(3), C_center(3)
|
||||||
|
complex*16, intent(in) :: alpha, beta
|
||||||
|
integer, intent(out) :: n_pt_out
|
||||||
|
complex*16, intent(out) :: d(0:n_pt_in)
|
||||||
|
|
||||||
|
integer :: a_x, b_x, a_y, b_y, a_z, b_z
|
||||||
|
integer :: n_pt1, n_pt2, n_pt3, dim, i, n_pt_tmp
|
||||||
|
complex*16 :: p, P_center(3), rho, p_inv, p_inv_2
|
||||||
|
complex*16 :: R1x(0:2), B01(0:2), R1xp(0:2),R2x(0:2)
|
||||||
|
complex*16 :: d1(0:n_pt_in), d2(0:n_pt_in), d3(0:n_pt_in)
|
||||||
|
|
||||||
|
ASSERT (n_pt_in > 1)
|
||||||
|
|
||||||
|
p = alpha + beta
|
||||||
|
p_inv = (1.d0, 0.d0) / p
|
||||||
|
p_inv_2 = 0.5d0 * p_inv
|
||||||
|
|
||||||
|
do i = 1, 3
|
||||||
|
P_center(i) = (alpha * A_center(i) + beta * B_center(i)) * p_inv
|
||||||
|
enddo
|
||||||
|
|
||||||
|
do i = 0, n_pt_in
|
||||||
|
d(i) = (0.d0, 0.d0)
|
||||||
|
d1(i) = (0.d0, 0.d0)
|
||||||
|
d2(i) = (0.d0, 0.d0)
|
||||||
|
d3(i) = (0.d0, 0.d0)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
n_pt1 = n_pt_in
|
||||||
|
|
||||||
|
R1x(0) = (P_center(1) - A_center(1))
|
||||||
|
R1x(1) = (0.d0, 0.d0)
|
||||||
|
R1x(2) = -(P_center(1) - C_center(1))
|
||||||
|
|
||||||
|
R1xp(0) = (P_center(1) - B_center(1))
|
||||||
|
R1xp(1) = (0.d0, 0.d0)
|
||||||
|
R1xp(2) = -(P_center(1) - C_center(1))
|
||||||
|
|
||||||
|
R2x(0) = p_inv_2
|
||||||
|
R2x(1) = (0.d0, 0.d0)
|
||||||
|
R2x(2) = -p_inv_2
|
||||||
|
|
||||||
|
a_x = power_A(1)
|
||||||
|
b_x = power_B(1)
|
||||||
|
call I_x1_pol_mult_one_e_cosgtos(a_x, b_x, R1x, R1xp, R2x, d1, n_pt1, n_pt_in)
|
||||||
|
|
||||||
|
if(n_pt1 < 0) then
|
||||||
|
n_pt_out = -1
|
||||||
|
do i = 0, n_pt_in
|
||||||
|
d(i) = (0.d0, 0.d0)
|
||||||
|
enddo
|
||||||
|
return
|
||||||
|
endif
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
n_pt2 = n_pt_in
|
||||||
|
|
||||||
|
R1x(0) = (P_center(2) - A_center(2))
|
||||||
|
R1x(1) = (0.d0, 0.d0)
|
||||||
|
R1x(2) = -(P_center(2) - C_center(2))
|
||||||
|
|
||||||
|
R1xp(0) = (P_center(2) - B_center(2))
|
||||||
|
R1xp(1) = (0.d0, 0.d0)
|
||||||
|
R1xp(2) = -(P_center(2) - C_center(2))
|
||||||
|
|
||||||
|
a_y = power_A(2)
|
||||||
|
b_y = power_B(2)
|
||||||
|
call I_x1_pol_mult_one_e_cosgtos(a_y, b_y, R1x, R1xp, R2x, d2, n_pt2, n_pt_in)
|
||||||
|
|
||||||
|
if(n_pt2 < 0) then
|
||||||
|
n_pt_out = -1
|
||||||
|
do i = 0, n_pt_in
|
||||||
|
d(i) = (0.d0, 0.d0)
|
||||||
|
enddo
|
||||||
|
return
|
||||||
|
endif
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
n_pt3 = n_pt_in
|
||||||
|
|
||||||
|
R1x(0) = (P_center(3) - A_center(3))
|
||||||
|
R1x(1) = (0.d0, 0.d0)
|
||||||
|
R1x(2) = -(P_center(3) - C_center(3))
|
||||||
|
|
||||||
|
R1xp(0) = (P_center(3) - B_center(3))
|
||||||
|
R1xp(1) = (0.d0, 0.d0)
|
||||||
|
R1xp(2) = -(P_center(3) - C_center(3))
|
||||||
|
|
||||||
|
a_z = power_A(3)
|
||||||
|
b_z = power_B(3)
|
||||||
|
call I_x1_pol_mult_one_e_cosgtos(a_z, b_z, R1x, R1xp, R2x, d3, n_pt3, n_pt_in)
|
||||||
|
|
||||||
|
if(n_pt3 < 0) then
|
||||||
|
n_pt_out = -1
|
||||||
|
do i = 0, n_pt_in
|
||||||
|
d(i) = (0.d0, 0.d0)
|
||||||
|
enddo
|
||||||
|
return
|
||||||
|
endif
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
n_pt_tmp = 0
|
||||||
|
call multiply_cpoly(d1, n_pt1, d2, n_pt2, d, n_pt_tmp)
|
||||||
|
do i = 0, n_pt_tmp
|
||||||
|
d1(i) = (0.d0, 0.d0)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
n_pt_out = 0
|
||||||
|
call multiply_cpoly(d, n_pt_tmp, d3, n_pt3, d1, n_pt_out)
|
||||||
|
do i = 0, n_pt_out
|
||||||
|
d(i) = d1(i)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
end subroutine give_cpolynomial_mult_center_one_e
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
recursive subroutine I_x1_pol_mult_one_e_cosgtos(a, c, R1x, R1xp, R2x, d, nd, n_pt_in)
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
! Recursive routine involved in the electron-nucleus potential
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
include 'utils/constants.include.F'
|
||||||
|
|
||||||
|
integer, intent(in) :: a, c, n_pt_in
|
||||||
|
complex*16, intent(in) :: R1x(0:2), R1xp(0:2), R2x(0:2)
|
||||||
|
integer, intent(inout) :: nd
|
||||||
|
complex*16, intent(inout) :: d(0:n_pt_in)
|
||||||
|
|
||||||
|
integer :: nx, ix, dim, iy, ny
|
||||||
|
complex*16 :: X(0:max_dim)
|
||||||
|
complex*16 :: Y(0:max_dim)
|
||||||
|
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: X, Y
|
||||||
|
|
||||||
|
dim = n_pt_in
|
||||||
|
|
||||||
|
if( (a==0) .and. (c==0)) then
|
||||||
|
|
||||||
|
nd = 0
|
||||||
|
d(0) = (1.d0, 0.d0)
|
||||||
|
return
|
||||||
|
|
||||||
|
elseif( (c < 0) .or. (nd < 0) ) then
|
||||||
|
|
||||||
|
nd = -1
|
||||||
|
return
|
||||||
|
|
||||||
|
elseif((a == 0) .and. (c .ne. 0)) then
|
||||||
|
|
||||||
|
call I_x2_pol_mult_one_e_cosgtos(c, R1x, R1xp, R2x, d, nd, n_pt_in)
|
||||||
|
|
||||||
|
elseif(a == 1) then
|
||||||
|
|
||||||
|
nx = nd
|
||||||
|
do ix = 0, n_pt_in
|
||||||
|
X(ix) = (0.d0, 0.d0)
|
||||||
|
Y(ix) = (0.d0, 0.d0)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
call I_x2_pol_mult_one_e_cosgtos(c-1, R1x, R1xp, R2x, X, nx, n_pt_in)
|
||||||
|
|
||||||
|
do ix = 0, nx
|
||||||
|
X(ix) *= dble(c)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
call multiply_cpoly(X, nx, R2x, 2, d, nd)
|
||||||
|
|
||||||
|
ny = 0
|
||||||
|
call I_x2_pol_mult_one_e_cosgtos(c, R1x, R1xp, R2x, Y, ny, n_pt_in)
|
||||||
|
call multiply_cpoly(Y, ny, R1x, 2, d, nd)
|
||||||
|
|
||||||
|
else
|
||||||
|
|
||||||
|
nx = 0
|
||||||
|
do ix = 0, n_pt_in
|
||||||
|
X(ix) = (0.d0, 0.d0)
|
||||||
|
Y(ix) = (0.d0, 0.d0)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
call I_x1_pol_mult_one_e_cosgtos(a-2, c, R1x, R1xp, R2x, X, nx, n_pt_in)
|
||||||
|
|
||||||
|
do ix = 0, nx
|
||||||
|
X(ix) *= dble(a-1)
|
||||||
|
enddo
|
||||||
|
call multiply_cpoly(X, nx, R2x, 2, d, nd)
|
||||||
|
|
||||||
|
nx = nd
|
||||||
|
do ix = 0, n_pt_in
|
||||||
|
X(ix) = (0.d0, 0.d0)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
call I_x1_pol_mult_one_e_cosgtos(a-1, c-1, R1x, R1xp, R2x, X, nx, n_pt_in)
|
||||||
|
do ix = 0, nx
|
||||||
|
X(ix) *= dble(c)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
call multiply_cpoly(X, nx, R2x, 2, d, nd)
|
||||||
|
|
||||||
|
ny = 0
|
||||||
|
call I_x1_pol_mult_one_e_cosgtos(a-1, c, R1x, R1xp, R2x, Y, ny, n_pt_in)
|
||||||
|
call multiply_cpoly(Y, ny, R1x, 2, d, nd)
|
||||||
|
|
||||||
|
endif
|
||||||
|
|
||||||
|
end subroutine I_x1_pol_mult_one_e_cosgtos
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
recursive subroutine I_x2_pol_mult_one_e_cosgtos(c, R1x, R1xp, R2x, d, nd, dim)
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
! Recursive routine involved in the electron-nucleus potential
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
include 'utils/constants.include.F'
|
||||||
|
|
||||||
|
integer, intent(in) :: dim, c
|
||||||
|
complex*16, intent(in) :: R1x(0:2), R1xp(0:2), R2x(0:2)
|
||||||
|
integer, intent(inout) :: nd
|
||||||
|
complex*16, intent(out) :: d(0:max_dim)
|
||||||
|
|
||||||
|
integer :: i, nx, ix, ny
|
||||||
|
complex*16 :: X(0:max_dim), Y(0:max_dim)
|
||||||
|
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: X, Y
|
||||||
|
|
||||||
|
if(c == 0) then
|
||||||
|
|
||||||
|
nd = 0
|
||||||
|
d(0) = (1.d0, 0.d0)
|
||||||
|
return
|
||||||
|
|
||||||
|
elseif((nd < 0) .or. (c < 0)) then
|
||||||
|
|
||||||
|
nd = -1
|
||||||
|
return
|
||||||
|
|
||||||
|
else
|
||||||
|
|
||||||
|
nx = 0
|
||||||
|
do ix = 0, dim
|
||||||
|
X(ix) = (0.d0, 0.d0)
|
||||||
|
Y(ix) = (0.d0, 0.d0)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
call I_x1_pol_mult_one_e_cosgtos(0, c-2, R1x, R1xp, R2x, X, nx, dim)
|
||||||
|
|
||||||
|
do ix = 0, nx
|
||||||
|
X(ix) *= dble(c-1)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
call multiply_cpoly(X, nx, R2x, 2, d, nd)
|
||||||
|
|
||||||
|
ny = 0
|
||||||
|
do ix = 0, dim
|
||||||
|
Y(ix) = (0.d0, 0.d0)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
call I_x1_pol_mult_one_e_cosgtos(0, c-1, R1x, R1xp, R2x, Y, ny, dim)
|
||||||
|
|
||||||
|
if(ny .ge. 0) then
|
||||||
|
call multiply_cpoly(Y, ny, R1xp, 2, d, nd)
|
||||||
|
endif
|
||||||
|
|
||||||
|
endif
|
||||||
|
|
||||||
|
end subroutine I_x2_pol_mult_one_e_cosgtos
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
complex*16 function V_n_e_cosgtos(a_x, a_y, a_z, b_x, b_y, b_z, alpha, beta)
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
! Primitve nuclear attraction between the two primitves centered on the same atom.
|
||||||
|
!
|
||||||
|
! $p_1 = x^{a_x} y^{a_y} z^{a_z} \exp(-\alpha r^2)$
|
||||||
|
!
|
||||||
|
! $p_2 = x^{b_x} y^{b_y} z^{b_z} \exp(-\beta r^2)$
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
integer, intent(in) :: a_x, a_y, a_z, b_x, b_y, b_z
|
||||||
|
complex*16, intent(in) :: alpha, beta
|
||||||
|
|
||||||
|
double precision :: V_phi, V_theta
|
||||||
|
complex*16 :: V_r_cosgtos
|
||||||
|
|
||||||
|
if( (iand(a_x + b_x, 1) == 1) .or. &
|
||||||
|
(iand(a_y + b_y, 1) == 1) .or. &
|
||||||
|
(iand(a_z + b_z, 1) == 1) ) then
|
||||||
|
|
||||||
|
V_n_e_cosgtos = (0.d0, 0.d0)
|
||||||
|
|
||||||
|
else
|
||||||
|
|
||||||
|
V_n_e_cosgtos = V_r_cosgtos(a_x + b_x + a_y + b_y + a_z + b_z + 1, alpha + beta) &
|
||||||
|
* V_phi(a_x + b_x, a_y + b_y) &
|
||||||
|
* V_theta(a_z + b_z, a_x + b_x + a_y + b_y + 1)
|
||||||
|
endif
|
||||||
|
|
||||||
|
end function V_n_e_cosgtos
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
complex*16 function V_r_cosgtos(n, alpha)
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
! Computes the radial part of the nuclear attraction integral:
|
||||||
|
!
|
||||||
|
! $\int_{0}^{\infty} r^n \exp(-\alpha r^2) dr$
|
||||||
|
!
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
include 'utils/constants.include.F'
|
||||||
|
|
||||||
|
integer , intent(in) :: n
|
||||||
|
complex*16, intent(in) :: alpha
|
||||||
|
|
||||||
|
double precision :: fact
|
||||||
|
|
||||||
|
if(iand(n, 1) .eq. 1) then
|
||||||
|
V_r_cosgtos = 0.5d0 * fact(shiftr(n, 1)) / (alpha**(shiftr(n, 1) + 1))
|
||||||
|
else
|
||||||
|
V_r_cosgtos = sqpi * fact(n) / fact(shiftr(n, 1)) * (0.5d0/zsqrt(alpha))**(n+1)
|
||||||
|
endif
|
||||||
|
|
||||||
|
end function V_r_cosgtos
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
223
src/cosgtos_ao_int/one_e_kin_integrals.irp.f
Normal file
223
src/cosgtos_ao_int/one_e_kin_integrals.irp.f
Normal file
@ -0,0 +1,223 @@
|
|||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ double precision, ao_deriv2_cosgtos_x, (ao_num, ao_num) ]
|
||||||
|
&BEGIN_PROVIDER [ double precision, ao_deriv2_cosgtos_y, (ao_num, ao_num) ]
|
||||||
|
&BEGIN_PROVIDER [ double precision, ao_deriv2_cosgtos_z, (ao_num, ao_num) ]
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer :: i, j, n, l, dim1, power_A(3), power_B(3)
|
||||||
|
double precision :: c, deriv_tmp
|
||||||
|
complex*16 :: alpha, beta, A_center(3), B_center(3)
|
||||||
|
complex*16 :: overlap_x, overlap_y, overlap_z, overlap
|
||||||
|
complex*16 :: overlap_x0_1, overlap_y0_1, overlap_z0_1
|
||||||
|
complex*16 :: overlap_x0_2, overlap_y0_2, overlap_z0_2
|
||||||
|
complex*16 :: overlap_m2_1, overlap_p2_1
|
||||||
|
complex*16 :: overlap_m2_2, overlap_p2_2
|
||||||
|
complex*16 :: deriv_tmp_1, deriv_tmp_2
|
||||||
|
|
||||||
|
|
||||||
|
dim1 = 100
|
||||||
|
|
||||||
|
! -- Dummy call to provide everything
|
||||||
|
|
||||||
|
A_center(:) = (0.0d0, 0.d0)
|
||||||
|
B_center(:) = (1.0d0, 0.d0)
|
||||||
|
alpha = (1.0d0, 0.d0)
|
||||||
|
beta = (0.1d0, 0.d0)
|
||||||
|
power_A = 1
|
||||||
|
power_B = 0
|
||||||
|
call overlap_cgaussian_xyz( A_center, B_center, alpha, beta, power_A, power_B &
|
||||||
|
, overlap_x0_1, overlap_y0_1, overlap_z0_1, overlap, dim1 )
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
!$OMP PARALLEL DO SCHEDULE(GUIDED) &
|
||||||
|
!$OMP DEFAULT(NONE) &
|
||||||
|
!$OMP PRIVATE( A_center, B_center, power_A, power_B, alpha, beta, i, j, l, n, c &
|
||||||
|
!$OMP , deriv_tmp, deriv_tmp_1, deriv_tmp_2 &
|
||||||
|
!$OMP , overlap_x, overlap_y, overlap_z, overlap &
|
||||||
|
!$OMP , overlap_m2_1, overlap_p2_1, overlap_m2_2, overlap_p2_2 &
|
||||||
|
!$OMP , overlap_x0_1, overlap_y0_1, overlap_z0_1, overlap_x0_2, overlap_y0_2, overlap_z0_2 ) &
|
||||||
|
!$OMP SHARED( nucl_coord, ao_power, ao_prim_num, ao_num, ao_nucl, dim1 &
|
||||||
|
!$OMP , ao_coef_norm_ord_transp_cosgtos, ao_expo_ord_transp_cosgtos &
|
||||||
|
!$OMP , ao_deriv2_cosgtos_x, ao_deriv2_cosgtos_y, ao_deriv2_cosgtos_z )
|
||||||
|
|
||||||
|
do j = 1, ao_num
|
||||||
|
A_center(1) = nucl_coord(ao_nucl(j),1) * (1.d0, 0.d0)
|
||||||
|
A_center(2) = nucl_coord(ao_nucl(j),2) * (1.d0, 0.d0)
|
||||||
|
A_center(3) = nucl_coord(ao_nucl(j),3) * (1.d0, 0.d0)
|
||||||
|
power_A(1) = ao_power(j,1)
|
||||||
|
power_A(2) = ao_power(j,2)
|
||||||
|
power_A(3) = ao_power(j,3)
|
||||||
|
|
||||||
|
do i = 1, ao_num
|
||||||
|
B_center(1) = nucl_coord(ao_nucl(i),1) * (1.d0, 0.d0)
|
||||||
|
B_center(2) = nucl_coord(ao_nucl(i),2) * (1.d0, 0.d0)
|
||||||
|
B_center(3) = nucl_coord(ao_nucl(i),3) * (1.d0, 0.d0)
|
||||||
|
power_B(1) = ao_power(i,1)
|
||||||
|
power_B(2) = ao_power(i,2)
|
||||||
|
power_B(3) = ao_power(i,3)
|
||||||
|
|
||||||
|
ao_deriv2_cosgtos_x(i,j) = 0.d0
|
||||||
|
ao_deriv2_cosgtos_y(i,j) = 0.d0
|
||||||
|
ao_deriv2_cosgtos_z(i,j) = 0.d0
|
||||||
|
|
||||||
|
do n = 1, ao_prim_num(j)
|
||||||
|
alpha = ao_expo_ord_transp_cosgtos(n,j)
|
||||||
|
|
||||||
|
do l = 1, ao_prim_num(i)
|
||||||
|
c = ao_coef_norm_ord_transp_cosgtos(n,j) * ao_coef_norm_ord_transp_cosgtos(l,i)
|
||||||
|
beta = ao_expo_ord_transp_cosgtos(l,i)
|
||||||
|
|
||||||
|
call overlap_cgaussian_xyz( A_center, B_center, alpha, beta, power_A, power_B &
|
||||||
|
, overlap_x0_1, overlap_y0_1, overlap_z0_1, overlap, dim1 )
|
||||||
|
|
||||||
|
call overlap_cgaussian_xyz( A_center, B_center, alpha, conjg(beta), power_A, power_B &
|
||||||
|
, overlap_x0_2, overlap_y0_2, overlap_z0_2, overlap, dim1 )
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
power_A(1) = power_A(1) - 2
|
||||||
|
if(power_A(1) > -1) then
|
||||||
|
call overlap_cgaussian_xyz( A_center, B_center, alpha, beta, power_A, power_B &
|
||||||
|
, overlap_m2_1, overlap_y, overlap_z, overlap, dim1 )
|
||||||
|
|
||||||
|
call overlap_cgaussian_xyz( A_center, B_center, alpha, conjg(beta), power_A, power_B &
|
||||||
|
, overlap_m2_2, overlap_y, overlap_z, overlap, dim1 )
|
||||||
|
else
|
||||||
|
overlap_m2_1 = (0.d0, 0.d0)
|
||||||
|
overlap_m2_2 = (0.d0, 0.d0)
|
||||||
|
endif
|
||||||
|
|
||||||
|
power_A(1) = power_A(1) + 4
|
||||||
|
call overlap_cgaussian_xyz( A_center, B_center, alpha, beta, power_A, power_B &
|
||||||
|
, overlap_p2_1, overlap_y, overlap_z, overlap, dim1 )
|
||||||
|
|
||||||
|
call overlap_cgaussian_xyz( A_center, B_center, alpha, conjg(beta), power_A, power_B &
|
||||||
|
, overlap_p2_2, overlap_y, overlap_z, overlap, dim1 )
|
||||||
|
|
||||||
|
power_A(1) = power_A(1) - 2
|
||||||
|
|
||||||
|
deriv_tmp_1 = ( -2.d0 * alpha * (2.d0 * power_A(1) + 1.d0) * overlap_x0_1 &
|
||||||
|
+ power_A(1) * (power_A(1) - 1.d0) * overlap_m2_1 &
|
||||||
|
+ 4.d0 * alpha * alpha * overlap_p2_1 ) * overlap_y0_1 * overlap_z0_1
|
||||||
|
|
||||||
|
deriv_tmp_2 = ( -2.d0 * alpha * (2.d0 * power_A(1) + 1.d0) * overlap_x0_2 &
|
||||||
|
+ power_A(1) * (power_A(1) - 1.d0) * overlap_m2_2 &
|
||||||
|
+ 4.d0 * alpha * alpha * overlap_p2_2 ) * overlap_y0_2 * overlap_z0_2
|
||||||
|
|
||||||
|
deriv_tmp = 2.d0 * real(deriv_tmp_1 + deriv_tmp_2)
|
||||||
|
|
||||||
|
ao_deriv2_cosgtos_x(i,j) += c * deriv_tmp
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
power_A(2) = power_A(2) - 2
|
||||||
|
if(power_A(2) > -1) then
|
||||||
|
call overlap_cgaussian_xyz( A_center, B_center, alpha, beta, power_A, power_B &
|
||||||
|
, overlap_x, overlap_m2_1, overlap_y, overlap, dim1 )
|
||||||
|
|
||||||
|
call overlap_cgaussian_xyz( A_center, B_center, alpha, conjg(beta), power_A, power_B &
|
||||||
|
, overlap_x, overlap_m2_2, overlap_y, overlap, dim1 )
|
||||||
|
else
|
||||||
|
overlap_m2_1 = (0.d0, 0.d0)
|
||||||
|
overlap_m2_2 = (0.d0, 0.d0)
|
||||||
|
endif
|
||||||
|
|
||||||
|
power_A(2) = power_A(2) + 4
|
||||||
|
call overlap_cgaussian_xyz( A_center, B_center, alpha, beta, power_A, power_B &
|
||||||
|
, overlap_x, overlap_p2_1, overlap_y, overlap, dim1 )
|
||||||
|
|
||||||
|
call overlap_cgaussian_xyz( A_center, B_center, alpha, conjg(beta), power_A, power_B &
|
||||||
|
, overlap_x, overlap_p2_2, overlap_y, overlap, dim1 )
|
||||||
|
|
||||||
|
power_A(2) = power_A(2) - 2
|
||||||
|
|
||||||
|
deriv_tmp_1 = ( -2.d0 * alpha * (2.d0 * power_A(2) + 1.d0) * overlap_y0_1 &
|
||||||
|
+ power_A(2) * (power_A(2) - 1.d0) * overlap_m2_1 &
|
||||||
|
+ 4.d0 * alpha * alpha * overlap_p2_1 ) * overlap_x0_1 * overlap_z0_1
|
||||||
|
|
||||||
|
deriv_tmp_2 = ( -2.d0 * alpha * (2.d0 * power_A(2) + 1.d0) * overlap_y0_2 &
|
||||||
|
+ power_A(2) * (power_A(2) - 1.d0) * overlap_m2_2 &
|
||||||
|
+ 4.d0 * alpha * alpha * overlap_p2_2 ) * overlap_x0_2 * overlap_z0_2
|
||||||
|
|
||||||
|
deriv_tmp = 2.d0 * real(deriv_tmp_1 + deriv_tmp_2)
|
||||||
|
|
||||||
|
ao_deriv2_cosgtos_y(i,j) += c * deriv_tmp
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
power_A(3) = power_A(3) - 2
|
||||||
|
if(power_A(3) > -1) then
|
||||||
|
call overlap_cgaussian_xyz( A_center, B_center, alpha, beta, power_A, power_B &
|
||||||
|
, overlap_x, overlap_y, overlap_m2_1, overlap, dim1 )
|
||||||
|
|
||||||
|
call overlap_cgaussian_xyz( A_center, B_center, alpha, conjg(beta), power_A, power_B &
|
||||||
|
, overlap_x, overlap_y, overlap_m2_2, overlap, dim1 )
|
||||||
|
else
|
||||||
|
overlap_m2_1 = (0.d0, 0.d0)
|
||||||
|
overlap_m2_2 = (0.d0, 0.d0)
|
||||||
|
endif
|
||||||
|
|
||||||
|
power_A(3) = power_A(3) + 4
|
||||||
|
call overlap_cgaussian_xyz( A_center, B_center, alpha, beta, power_A, power_B &
|
||||||
|
, overlap_x, overlap_y, overlap_p2_1, overlap, dim1 )
|
||||||
|
|
||||||
|
call overlap_cgaussian_xyz( A_center, B_center, alpha, conjg(beta), power_A, power_B &
|
||||||
|
, overlap_x, overlap_y, overlap_p2_2, overlap, dim1 )
|
||||||
|
|
||||||
|
power_A(3) = power_A(3) - 2
|
||||||
|
|
||||||
|
deriv_tmp_1 = ( -2.d0 * alpha * (2.d0 * power_A(3) + 1.d0) * overlap_z0_1 &
|
||||||
|
+ power_A(3) * (power_A(3) - 1.d0) * overlap_m2_1 &
|
||||||
|
+ 4.d0 * alpha * alpha * overlap_p2_1 ) * overlap_x0_1 * overlap_y0_1
|
||||||
|
|
||||||
|
deriv_tmp_2 = ( -2.d0 * alpha * (2.d0 * power_A(3) + 1.d0) * overlap_z0_2 &
|
||||||
|
+ power_A(3) * (power_A(3) - 1.d0) * overlap_m2_2 &
|
||||||
|
+ 4.d0 * alpha * alpha * overlap_p2_2 ) * overlap_x0_2 * overlap_y0_2
|
||||||
|
|
||||||
|
deriv_tmp = 2.d0 * real(deriv_tmp_1 + deriv_tmp_2)
|
||||||
|
|
||||||
|
ao_deriv2_cosgtos_z(i,j) += c * deriv_tmp
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
!$OMP END PARALLEL DO
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [double precision, ao_kinetic_integrals_cosgtos, (ao_num, ao_num)]
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
!
|
||||||
|
! Kinetic energy integrals in the cosgtos |AO| basis.
|
||||||
|
!
|
||||||
|
! $\langle \chi_i |\hat{T}| \chi_j \rangle$
|
||||||
|
!
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer :: i, j
|
||||||
|
|
||||||
|
!$OMP PARALLEL DO DEFAULT(NONE) &
|
||||||
|
!$OMP PRIVATE(i, j) &
|
||||||
|
!$OMP SHARED(ao_num, ao_kinetic_integrals_cosgtos, ao_deriv2_cosgtos_x, ao_deriv2_cosgtos_y, ao_deriv2_cosgtos_z)
|
||||||
|
do j = 1, ao_num
|
||||||
|
do i = 1, ao_num
|
||||||
|
ao_kinetic_integrals_cosgtos(i,j) = -0.5d0 * ( ao_deriv2_cosgtos_x(i,j) &
|
||||||
|
+ ao_deriv2_cosgtos_y(i,j) &
|
||||||
|
+ ao_deriv2_cosgtos_z(i,j) )
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
!$OMP END PARALLEL DO
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
1584
src/cosgtos_ao_int/two_e_Coul_integrals.irp.f
Normal file
1584
src/cosgtos_ao_int/two_e_Coul_integrals.irp.f
Normal file
File diff suppressed because it is too large
Load Diff
@ -1,71 +1,18 @@
|
|||||||
[threshold_davidson]
|
|
||||||
type: Threshold
|
|
||||||
doc: Thresholds of Davidson's algorithm if threshold_davidson_from_pt2 is false.
|
|
||||||
interface: ezfio,provider,ocaml
|
|
||||||
default: 1.e-10
|
|
||||||
|
|
||||||
[threshold_nonsym_davidson]
|
|
||||||
type: Threshold
|
|
||||||
doc: Thresholds of non-symetric Davidson's algorithm
|
|
||||||
interface: ezfio,provider,ocaml
|
|
||||||
default: 1.e-10
|
|
||||||
|
|
||||||
[threshold_davidson_from_pt2]
|
|
||||||
type: logical
|
|
||||||
doc: Thresholds of Davidson's algorithm is set to E(rPT2)*threshold_davidson_from_pt2
|
|
||||||
interface: ezfio,provider,ocaml
|
|
||||||
default: false
|
|
||||||
|
|
||||||
[n_states_diag]
|
|
||||||
type: States_number
|
|
||||||
doc: Controls the number of states to consider during the Davdison diagonalization. The number of states is n_states * n_states_diag
|
|
||||||
default: 4
|
|
||||||
interface: ezfio,ocaml
|
|
||||||
|
|
||||||
[davidson_sze_max]
|
|
||||||
type: Strictly_positive_int
|
|
||||||
doc: Number of micro-iterations before re-contracting
|
|
||||||
default: 15
|
|
||||||
interface: ezfio,provider,ocaml
|
|
||||||
|
|
||||||
[state_following]
|
|
||||||
type: logical
|
|
||||||
doc: If |true|, the states are re-ordered to match the input states
|
|
||||||
default: False
|
|
||||||
interface: ezfio,provider,ocaml
|
|
||||||
|
|
||||||
[disk_based_davidson]
|
|
||||||
type: logical
|
|
||||||
doc: If |true|, a memory-mapped file may be used to store the W and S2 vectors if not enough RAM is available
|
|
||||||
default: True
|
|
||||||
interface: ezfio,provider,ocaml
|
|
||||||
|
|
||||||
[csf_based]
|
[csf_based]
|
||||||
type: logical
|
type: logical
|
||||||
doc: If |true|, use the CSF-based algorithm
|
doc: If |true|, use the CSF-based algorithm
|
||||||
default: False
|
default: False
|
||||||
interface: ezfio,provider,ocaml
|
interface: ezfio,provider,ocaml
|
||||||
|
|
||||||
[distributed_davidson]
|
|
||||||
type: logical
|
|
||||||
doc: If |true|, use the distributed algorithm
|
|
||||||
default: True
|
|
||||||
interface: ezfio,provider,ocaml
|
|
||||||
|
|
||||||
[only_expected_s2]
|
[only_expected_s2]
|
||||||
type: logical
|
type: logical
|
||||||
doc: If |true|, use filter out all vectors with bad |S^2| values
|
doc: If |true|, use filter out all vectors with bad |S^2| values
|
||||||
default: True
|
default: True
|
||||||
interface: ezfio,provider,ocaml
|
interface: ezfio,provider,ocaml
|
||||||
|
|
||||||
[n_det_max_full]
|
|
||||||
type: Det_number_max
|
|
||||||
doc: Maximum number of determinants where |H| is fully diagonalized
|
|
||||||
interface: ezfio,provider,ocaml
|
|
||||||
default: 1000
|
|
||||||
|
|
||||||
[without_diagonal]
|
[without_diagonal]
|
||||||
type: logical
|
type: logical
|
||||||
doc: If |true|, don't use denominator
|
doc: If |true|, don't use denominator
|
||||||
default: False
|
default: False
|
||||||
interface: ezfio,provider,ocaml
|
interface: ezfio,provider,ocaml
|
||||||
|
|
||||||
|
@ -1 +1,2 @@
|
|||||||
csf
|
csf
|
||||||
|
davidson_keywords
|
||||||
|
@ -548,21 +548,6 @@ end
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
BEGIN_PROVIDER [ integer, nthreads_davidson ]
|
|
||||||
implicit none
|
|
||||||
BEGIN_DOC
|
|
||||||
! Number of threads for Davidson
|
|
||||||
END_DOC
|
|
||||||
nthreads_davidson = nproc
|
|
||||||
character*(32) :: env
|
|
||||||
call getenv('QP_NTHREADS_DAVIDSON',env)
|
|
||||||
if (trim(env) /= '') then
|
|
||||||
call lock_io()
|
|
||||||
read(env,*) nthreads_davidson
|
|
||||||
call unlock_io()
|
|
||||||
call write_int(6,nthreads_davidson,'Target number of threads for <Psi|H|Psi>')
|
|
||||||
endif
|
|
||||||
END_PROVIDER
|
|
||||||
|
|
||||||
|
|
||||||
integer function zmq_put_N_states_diag(zmq_to_qp_run_socket,worker_id)
|
integer function zmq_put_N_states_diag(zmq_to_qp_run_socket,worker_id)
|
||||||
|
@ -14,15 +14,6 @@ BEGIN_PROVIDER [ character*(64), diag_algorithm ]
|
|||||||
endif
|
endif
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
BEGIN_PROVIDER [ double precision, threshold_davidson_pt2 ]
|
|
||||||
implicit none
|
|
||||||
BEGIN_DOC
|
|
||||||
! Threshold of Davidson's algorithm, using PT2 as a guide
|
|
||||||
END_DOC
|
|
||||||
threshold_davidson_pt2 = threshold_davidson
|
|
||||||
|
|
||||||
END_PROVIDER
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
BEGIN_PROVIDER [ integer, dressed_column_idx, (N_states) ]
|
BEGIN_PROVIDER [ integer, dressed_column_idx, (N_states) ]
|
||||||
@ -66,7 +57,7 @@ subroutine davidson_diag_hs2(dets_in,u_in,s2_out,dim_in,energies,sze,N_st,N_st_d
|
|||||||
double precision, allocatable :: H_jj(:)
|
double precision, allocatable :: H_jj(:)
|
||||||
|
|
||||||
double precision, external :: diag_H_mat_elem, diag_S_mat_elem
|
double precision, external :: diag_H_mat_elem, diag_S_mat_elem
|
||||||
integer :: i,k
|
integer :: i,k,l
|
||||||
ASSERT (N_st > 0)
|
ASSERT (N_st > 0)
|
||||||
ASSERT (sze > 0)
|
ASSERT (sze > 0)
|
||||||
ASSERT (Nint > 0)
|
ASSERT (Nint > 0)
|
||||||
@ -87,9 +78,14 @@ subroutine davidson_diag_hs2(dets_in,u_in,s2_out,dim_in,energies,sze,N_st,N_st_d
|
|||||||
|
|
||||||
if (dressing_state > 0) then
|
if (dressing_state > 0) then
|
||||||
do k=1,N_st
|
do k=1,N_st
|
||||||
|
|
||||||
do i=1,sze
|
do i=1,sze
|
||||||
H_jj(i) += u_in(i,k) * dressing_column_h(i,k)
|
H_jj(i) += u_in(i,k) * dressing_column_h(i,k)
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
|
!l = dressed_column_idx(k)
|
||||||
|
!H_jj(l) += u_in(l,k) * dressing_column_h(l,k)
|
||||||
|
|
||||||
enddo
|
enddo
|
||||||
endif
|
endif
|
||||||
|
|
||||||
|
541
src/davidson/diagonalization_nonsym_h_dressed.irp.f
Normal file
541
src/davidson/diagonalization_nonsym_h_dressed.irp.f
Normal file
@ -0,0 +1,541 @@
|
|||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
subroutine davidson_diag_nonsym_h(dets_in, u_in, dim_in, energies, sze, N_st, N_st_diag, Nint, dressing_state, converged)
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
!
|
||||||
|
! non-sym Davidson diagonalization.
|
||||||
|
!
|
||||||
|
! dets_in : bitmasks corresponding to determinants
|
||||||
|
!
|
||||||
|
! u_in : guess coefficients on the various states. Overwritten on exit
|
||||||
|
!
|
||||||
|
! dim_in : leftmost dimension of u_in
|
||||||
|
!
|
||||||
|
! sze : Number of determinants
|
||||||
|
!
|
||||||
|
! N_st : Number of eigenstates
|
||||||
|
!
|
||||||
|
! Initial guess vectors are not necessarily orthonormal
|
||||||
|
!
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
use bitmasks
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint
|
||||||
|
integer, intent(in) :: dressing_state
|
||||||
|
integer(bit_kind), intent(in) :: dets_in(Nint,2,sze)
|
||||||
|
logical, intent(out) :: converged
|
||||||
|
double precision, intent(out) :: energies(N_st_diag)
|
||||||
|
double precision, intent(inout) :: u_in(dim_in,N_st_diag)
|
||||||
|
|
||||||
|
integer :: i, k, l
|
||||||
|
double precision :: f
|
||||||
|
double precision, allocatable :: H_jj(:)
|
||||||
|
|
||||||
|
double precision, external :: diag_H_mat_elem
|
||||||
|
|
||||||
|
ASSERT (N_st > 0)
|
||||||
|
ASSERT (sze > 0)
|
||||||
|
ASSERT (Nint > 0)
|
||||||
|
ASSERT (Nint == N_int)
|
||||||
|
PROVIDE mo_two_e_integrals_in_map
|
||||||
|
|
||||||
|
allocate(H_jj(sze))
|
||||||
|
|
||||||
|
H_jj(1) = diag_H_mat_elem(dets_in(1,1,1), Nint)
|
||||||
|
!$OMP PARALLEL DEFAULT(NONE) &
|
||||||
|
!$OMP SHARED(sze, H_jj, dets_in, Nint) &
|
||||||
|
!$OMP PRIVATE(i)
|
||||||
|
!$OMP DO SCHEDULE(static)
|
||||||
|
do i = 2, sze
|
||||||
|
H_jj(i) = diag_H_mat_elem(dets_in(1,1,i), Nint)
|
||||||
|
enddo
|
||||||
|
!$OMP END DO
|
||||||
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
|
if(dressing_state > 0) then
|
||||||
|
do k = 1, N_st
|
||||||
|
do l = 1, N_st
|
||||||
|
f = overlap_states_inv(k,l)
|
||||||
|
|
||||||
|
!do i = 1, N_det
|
||||||
|
! H_jj(i) += f * dressing_delta(i,k) * psi_coef(i,l)
|
||||||
|
do i = 1, dim_in
|
||||||
|
H_jj(i) += f * dressing_delta(i,k) * u_in(i,l)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
|
||||||
|
call davidson_diag_nonsym_hjj(dets_in, u_in, H_jj, energies, dim_in, sze, N_st, N_st_diag, Nint, dressing_state, converged)
|
||||||
|
|
||||||
|
deallocate(H_jj)
|
||||||
|
|
||||||
|
end subroutine davidson_diag_nonsym_h
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
subroutine davidson_diag_nonsym_hjj(dets_in, u_in, H_jj, energies, dim_in, sze, N_st, N_st_diag_in, Nint, dressing_state, converged)
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
!
|
||||||
|
! non-sym Davidson diagonalization with specific diagonal elements of the H matrix
|
||||||
|
!
|
||||||
|
! H_jj : specific diagonal H matrix elements to diagonalize de Davidson
|
||||||
|
!
|
||||||
|
! dets_in : bitmasks corresponding to determinants
|
||||||
|
!
|
||||||
|
! u_in : guess coefficients on the various states. Overwritten on exit
|
||||||
|
!
|
||||||
|
! dim_in : leftmost dimension of u_in
|
||||||
|
!
|
||||||
|
! sze : Number of determinants
|
||||||
|
!
|
||||||
|
! N_st : Number of eigenstates
|
||||||
|
!
|
||||||
|
! N_st_diag_in : Number of states in which H is diagonalized. Assumed > sze
|
||||||
|
!
|
||||||
|
! Initial guess vectors are not necessarily orthonormal
|
||||||
|
!
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
include 'constants.include.F'
|
||||||
|
|
||||||
|
use bitmasks
|
||||||
|
use mmap_module
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
integer, intent(in) :: dim_in, sze, N_st, N_st_diag_in, Nint
|
||||||
|
integer, intent(in) :: dressing_state
|
||||||
|
integer(bit_kind), intent(in) :: dets_in(Nint,2,sze)
|
||||||
|
double precision, intent(in) :: H_jj(sze)
|
||||||
|
double precision, intent(out) :: energies(N_st_diag_in)
|
||||||
|
logical, intent(inout) :: converged
|
||||||
|
double precision, intent(inout) :: u_in(dim_in,N_st_diag_in)
|
||||||
|
|
||||||
|
logical :: disk_based
|
||||||
|
character*(16384) :: write_buffer
|
||||||
|
integer :: i, j, k, l, m
|
||||||
|
integer :: iter, N_st_diag, itertot, shift, shift2, itermax, istate
|
||||||
|
integer :: nproc_target
|
||||||
|
integer :: order(N_st_diag_in)
|
||||||
|
integer :: maxab
|
||||||
|
double precision :: rss
|
||||||
|
double precision :: cmax
|
||||||
|
double precision :: to_print(2,N_st)
|
||||||
|
double precision :: r1, r2
|
||||||
|
double precision :: f
|
||||||
|
double precision, allocatable :: y(:,:), h(:,:), lambda(:)
|
||||||
|
double precision, allocatable :: s_tmp(:,:), u_tmp(:,:)
|
||||||
|
double precision, allocatable :: residual_norm(:)
|
||||||
|
double precision, allocatable :: U(:,:), overlap(:,:)
|
||||||
|
double precision, pointer :: W(:,:)
|
||||||
|
|
||||||
|
double precision, external :: u_dot_u
|
||||||
|
|
||||||
|
|
||||||
|
N_st_diag = N_st_diag_in
|
||||||
|
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, y, h, lambda
|
||||||
|
if(N_st_diag*3 > sze) then
|
||||||
|
print *, 'error in Davidson :'
|
||||||
|
print *, 'Increase n_det_max_full to ', N_st_diag*3
|
||||||
|
stop -1
|
||||||
|
endif
|
||||||
|
|
||||||
|
itermax = max(2, min(davidson_sze_max, sze/N_st_diag)) + 1
|
||||||
|
itertot = 0
|
||||||
|
|
||||||
|
if(state_following) then
|
||||||
|
allocate(overlap(N_st_diag*itermax, N_st_diag*itermax))
|
||||||
|
else
|
||||||
|
allocate(overlap(1,1)) ! avoid 'if' for deallocate
|
||||||
|
endif
|
||||||
|
overlap = 0.d0
|
||||||
|
|
||||||
|
PROVIDE nuclear_repulsion expected_s2 psi_bilinear_matrix_order psi_bilinear_matrix_order_reverse threshold_davidson_pt2 threshold_davidson_from_pt2
|
||||||
|
PROVIDE threshold_nonsym_davidson
|
||||||
|
|
||||||
|
call write_time(6)
|
||||||
|
write(6,'(A)') ''
|
||||||
|
write(6,'(A)') 'Davidson Diagonalization'
|
||||||
|
write(6,'(A)') '------------------------'
|
||||||
|
write(6,'(A)') ''
|
||||||
|
|
||||||
|
! Find max number of cores to fit in memory
|
||||||
|
! -----------------------------------------
|
||||||
|
|
||||||
|
nproc_target = nproc
|
||||||
|
maxab = max(N_det_alpha_unique, N_det_beta_unique) + 1
|
||||||
|
|
||||||
|
m=1
|
||||||
|
disk_based = .False.
|
||||||
|
call resident_memory(rss)
|
||||||
|
do
|
||||||
|
r1 = 8.d0 * &! bytes
|
||||||
|
( dble(sze)*(N_st_diag*itermax) &! U
|
||||||
|
+ 1.0d0*dble(sze*m)*(N_st_diag*itermax) &! W
|
||||||
|
+ 3.0d0*(N_st_diag*itermax)**2 &! h,y,s_tmp
|
||||||
|
+ 1.d0*(N_st_diag*itermax) &! lambda
|
||||||
|
+ 1.d0*(N_st_diag) &! residual_norm
|
||||||
|
! In H_u_0_nstates_zmq
|
||||||
|
+ 2.d0*(N_st_diag*N_det) &! u_t, v_t, on collector
|
||||||
|
+ 2.d0*(N_st_diag*N_det) &! u_t, v_t, on slave
|
||||||
|
+ 0.5d0*maxab &! idx0 in H_u_0_nstates_openmp_work_*
|
||||||
|
+ nproc_target * &! In OMP section
|
||||||
|
( 1.d0*(N_int*maxab) &! buffer
|
||||||
|
+ 3.5d0*(maxab) ) &! singles_a, singles_b, doubles, idx
|
||||||
|
) / 1024.d0**3
|
||||||
|
|
||||||
|
if(nproc_target == 0) then
|
||||||
|
call check_mem(r1, irp_here)
|
||||||
|
nproc_target = 1
|
||||||
|
exit
|
||||||
|
endif
|
||||||
|
|
||||||
|
if(r1+rss < qp_max_mem) then
|
||||||
|
exit
|
||||||
|
endif
|
||||||
|
|
||||||
|
if(itermax > 4) then
|
||||||
|
itermax = itermax - 1
|
||||||
|
else if(m==1 .and. disk_based_davidson) then
|
||||||
|
m = 0
|
||||||
|
disk_based = .True.
|
||||||
|
itermax = 6
|
||||||
|
else
|
||||||
|
nproc_target = nproc_target - 1
|
||||||
|
endif
|
||||||
|
|
||||||
|
enddo
|
||||||
|
|
||||||
|
nthreads_davidson = nproc_target
|
||||||
|
TOUCH nthreads_davidson
|
||||||
|
|
||||||
|
call write_int(6, N_st, 'Number of states')
|
||||||
|
call write_int(6, N_st_diag, 'Number of states in diagonalization')
|
||||||
|
call write_int(6, sze, 'Number of determinants')
|
||||||
|
call write_int(6, nproc_target, 'Number of threads for diagonalization')
|
||||||
|
call write_double(6, r1, 'Memory(Gb)')
|
||||||
|
if(disk_based) then
|
||||||
|
print *, 'Using swap space to reduce RAM'
|
||||||
|
endif
|
||||||
|
|
||||||
|
!---------------
|
||||||
|
|
||||||
|
write(6,'(A)') ''
|
||||||
|
write_buffer = '====='
|
||||||
|
do i = 1, N_st
|
||||||
|
write_buffer = trim(write_buffer)//' ================ ==========='
|
||||||
|
enddo
|
||||||
|
write(6, '(A)') write_buffer(1:6+41*N_st)
|
||||||
|
write_buffer = 'Iter'
|
||||||
|
do i = 1, N_st
|
||||||
|
write_buffer = trim(write_buffer)//' Energy Residual '
|
||||||
|
enddo
|
||||||
|
write(6,'(A)') write_buffer(1:6+41*N_st)
|
||||||
|
write_buffer = '====='
|
||||||
|
do i = 1, N_st
|
||||||
|
write_buffer = trim(write_buffer)//' ================ ==========='
|
||||||
|
enddo
|
||||||
|
write(6,'(A)') write_buffer(1:6+41*N_st)
|
||||||
|
|
||||||
|
|
||||||
|
if(disk_based) then
|
||||||
|
! Create memory-mapped files for W and S
|
||||||
|
type(c_ptr) :: ptr_w, ptr_s
|
||||||
|
integer :: fd_s, fd_w
|
||||||
|
call mmap(trim(ezfio_work_dir)//'davidson_w', (/int(sze,8),int(N_st_diag*itermax,8)/),&
|
||||||
|
8, fd_w, .False., ptr_w)
|
||||||
|
call c_f_pointer(ptr_w, w, (/sze,N_st_diag*itermax/))
|
||||||
|
else
|
||||||
|
allocate(W(sze,N_st_diag*itermax))
|
||||||
|
endif
|
||||||
|
|
||||||
|
allocate( &
|
||||||
|
! Large
|
||||||
|
U(sze,N_st_diag*itermax), &
|
||||||
|
! Small
|
||||||
|
h(N_st_diag*itermax,N_st_diag*itermax), &
|
||||||
|
y(N_st_diag*itermax,N_st_diag*itermax), &
|
||||||
|
s_tmp(N_st_diag*itermax,N_st_diag*itermax), &
|
||||||
|
residual_norm(N_st_diag), &
|
||||||
|
lambda(N_st_diag*itermax), &
|
||||||
|
u_tmp(N_st,N_st_diag))
|
||||||
|
|
||||||
|
h = 0.d0
|
||||||
|
U = 0.d0
|
||||||
|
y = 0.d0
|
||||||
|
s_tmp = 0.d0
|
||||||
|
|
||||||
|
|
||||||
|
ASSERT (N_st > 0)
|
||||||
|
ASSERT (N_st_diag >= N_st)
|
||||||
|
ASSERT (sze > 0)
|
||||||
|
ASSERT (Nint > 0)
|
||||||
|
ASSERT (Nint == N_int)
|
||||||
|
|
||||||
|
! Davidson iterations
|
||||||
|
! ===================
|
||||||
|
|
||||||
|
converged = .False.
|
||||||
|
|
||||||
|
do k = N_st+1, N_st_diag
|
||||||
|
do i = 1, sze
|
||||||
|
call random_number(r1)
|
||||||
|
call random_number(r2)
|
||||||
|
r1 = dsqrt(-2.d0*dlog(r1))
|
||||||
|
r2 = dtwo_pi*r2
|
||||||
|
u_in(i,k) = r1*dcos(r2) * u_in(i,k-N_st)
|
||||||
|
enddo
|
||||||
|
u_in(k,k) = u_in(k,k) + 10.d0
|
||||||
|
enddo
|
||||||
|
do k = 1, N_st_diag
|
||||||
|
call normalize(u_in(1,k), sze)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
do k = 1, N_st_diag
|
||||||
|
do i = 1, sze
|
||||||
|
U(i,k) = u_in(i,k)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
|
||||||
|
do while (.not.converged)
|
||||||
|
itertot = itertot + 1
|
||||||
|
if(itertot == 8) then
|
||||||
|
exit
|
||||||
|
endif
|
||||||
|
|
||||||
|
do iter = 1, itermax-1
|
||||||
|
|
||||||
|
shift = N_st_diag*(iter-1)
|
||||||
|
shift2 = N_st_diag*iter
|
||||||
|
|
||||||
|
! if( (iter > 1) .or. (itertot == 1) ) then
|
||||||
|
|
||||||
|
! Gram-Schmidt to orthogonalize all new guess with the previous vectors
|
||||||
|
call ortho_qr(U, size(U, 1), sze, shift2)
|
||||||
|
call ortho_qr(U, size(U, 1), sze, shift2)
|
||||||
|
|
||||||
|
! Compute |W_k> = \sum_i |i><i|H|u_k>
|
||||||
|
! -----------------------------------
|
||||||
|
|
||||||
|
if( (sze > 100000) .and. distributed_davidson ) then
|
||||||
|
call H_u_0_nstates_zmq (W(1,shift+1), U(1,shift+1), N_st_diag, sze)
|
||||||
|
else
|
||||||
|
call H_u_0_nstates_openmp(W(1,shift+1), U(1,shift+1), N_st_diag, sze)
|
||||||
|
endif
|
||||||
|
! else
|
||||||
|
! ! Already computed in update below
|
||||||
|
! continue
|
||||||
|
! endif
|
||||||
|
|
||||||
|
if(dressing_state > 0) then
|
||||||
|
|
||||||
|
call dgemm( 'T', 'N', N_st, N_st_diag, sze, 1.d0 &
|
||||||
|
, psi_coef, size(psi_coef, 1), U(1, shift+1), size(U, 1) &
|
||||||
|
, 0.d0, u_tmp, size(u_tmp, 1))
|
||||||
|
|
||||||
|
do istate = 1, N_st_diag
|
||||||
|
do k = 1, N_st
|
||||||
|
do l = 1, N_st
|
||||||
|
f = overlap_states_inv(k,l)
|
||||||
|
do i = 1, sze
|
||||||
|
W(i,shift+istate) += f * dressing_delta(i,k) * u_tmp(l,istate)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
endif
|
||||||
|
|
||||||
|
! Compute h_kl = <u_k | W_l> = <u_k| H |u_l>
|
||||||
|
! -------------------------------------------
|
||||||
|
|
||||||
|
call dgemm( 'T', 'N', shift2, shift2, sze, 1.d0 &
|
||||||
|
, U, size(U, 1), W, size(W, 1) &
|
||||||
|
, 0.d0, h, size(h, 1))
|
||||||
|
|
||||||
|
! Diagonalize h
|
||||||
|
! ---------------
|
||||||
|
call diag_nonsym_right(shift2, h(1,1), size(h, 1), y(1,1), size(y, 1), lambda(1), size(lambda, 1))
|
||||||
|
|
||||||
|
|
||||||
|
if (state_following) then
|
||||||
|
|
||||||
|
overlap = -1.d0
|
||||||
|
do k = 1, shift2
|
||||||
|
do i = 1, shift2
|
||||||
|
overlap(k,i) = dabs(y(k,i))
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
do k = 1, N_st
|
||||||
|
cmax = -1.d0
|
||||||
|
do i = 1, N_st
|
||||||
|
if(overlap(i,k) > cmax) then
|
||||||
|
cmax = overlap(i,k)
|
||||||
|
order(k) = i
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
do i = 1, N_st_diag
|
||||||
|
overlap(order(k),i) = -1.d0
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
overlap = y
|
||||||
|
do k = 1, N_st
|
||||||
|
l = order(k)
|
||||||
|
if (k /= l) then
|
||||||
|
y(1:shift2,k) = overlap(1:shift2,l)
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
do k = 1, N_st
|
||||||
|
overlap(k,1) = lambda(k)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
endif
|
||||||
|
|
||||||
|
! Express eigenvectors of h in the determinant basis
|
||||||
|
! --------------------------------------------------
|
||||||
|
|
||||||
|
call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 &
|
||||||
|
, U, size(U, 1), y, size(y, 1) &
|
||||||
|
, 0.d0, U(1,shift2+1), size(U, 1))
|
||||||
|
|
||||||
|
do k = 1, N_st_diag
|
||||||
|
call normalize(U(1,shift2+k), sze)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 &
|
||||||
|
, W, size(W, 1), y, size(y, 1) &
|
||||||
|
, 0.d0, W(1,shift2+1), size(W,1))
|
||||||
|
|
||||||
|
! Compute residual vector and davidson step
|
||||||
|
! -----------------------------------------
|
||||||
|
|
||||||
|
!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,k)
|
||||||
|
do k = 1, N_st_diag
|
||||||
|
do i = 1, sze
|
||||||
|
U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k)) / max(H_jj(i)-lambda(k), 1.d-2)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
if(k <= N_st) then
|
||||||
|
residual_norm(k) = u_dot_u(U(1,shift2+k), sze)
|
||||||
|
to_print(1,k) = lambda(k) + nuclear_repulsion
|
||||||
|
to_print(2,k) = residual_norm(k)
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
!$OMP END PARALLEL DO
|
||||||
|
|
||||||
|
if((itertot>1).and.(iter == 1)) then
|
||||||
|
!don't print
|
||||||
|
continue
|
||||||
|
else
|
||||||
|
write(*, '(1X, I3, 1X, 100(1X, F16.10, 1X, E11.3))') iter-1, to_print(1:2,1:N_st)
|
||||||
|
endif
|
||||||
|
|
||||||
|
! Check convergence
|
||||||
|
if(iter > 1) then
|
||||||
|
if(threshold_davidson_from_pt2) then
|
||||||
|
converged = dabs(maxval(residual_norm(1:N_st))) < threshold_davidson_pt2
|
||||||
|
else
|
||||||
|
converged = dabs(maxval(residual_norm(1:N_st))) < threshold_nonsym_davidson
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
|
||||||
|
do k = 1, N_st
|
||||||
|
if(residual_norm(k) > 1.d8) then
|
||||||
|
print *, 'Davidson failed'
|
||||||
|
stop -1
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
if(converged) then
|
||||||
|
exit
|
||||||
|
endif
|
||||||
|
|
||||||
|
logical, external :: qp_stop
|
||||||
|
if(qp_stop()) then
|
||||||
|
converged = .True.
|
||||||
|
exit
|
||||||
|
endif
|
||||||
|
|
||||||
|
|
||||||
|
enddo
|
||||||
|
|
||||||
|
! Re-contract U and update W
|
||||||
|
! --------------------------------
|
||||||
|
|
||||||
|
call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 &
|
||||||
|
, W, size(W, 1), y, size(y, 1) &
|
||||||
|
, 0.d0, u_in, size(u_in, 1))
|
||||||
|
do k = 1, N_st_diag
|
||||||
|
do i = 1, sze
|
||||||
|
W(i,k) = u_in(i,k)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 &
|
||||||
|
, U, size(U, 1), y, size(y, 1), 0.d0 &
|
||||||
|
, u_in, size(u_in, 1))
|
||||||
|
|
||||||
|
do k = 1, N_st_diag
|
||||||
|
do i = 1, sze
|
||||||
|
U(i,k) = u_in(i,k)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
enddo
|
||||||
|
|
||||||
|
|
||||||
|
call nullify_small_elements(sze, N_st_diag, U, size(U, 1), threshold_davidson_pt2)
|
||||||
|
do k = 1, N_st_diag
|
||||||
|
do i = 1, sze
|
||||||
|
u_in(i,k) = U(i,k)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
do k = 1, N_st_diag
|
||||||
|
energies(k) = lambda(k)
|
||||||
|
enddo
|
||||||
|
write_buffer = '======'
|
||||||
|
do i = 1, N_st
|
||||||
|
write_buffer = trim(write_buffer)//' ================ ==========='
|
||||||
|
enddo
|
||||||
|
write(6,'(A)') trim(write_buffer)
|
||||||
|
write(6,'(A)') ''
|
||||||
|
call write_time(6)
|
||||||
|
|
||||||
|
if(disk_based) then
|
||||||
|
! Remove temp files
|
||||||
|
integer, external :: getUnitAndOpen
|
||||||
|
call munmap( (/int(sze,8),int(N_st_diag*itermax,8)/), 8, fd_w, ptr_w )
|
||||||
|
fd_w = getUnitAndOpen(trim(ezfio_work_dir)//'davidson_w','r')
|
||||||
|
close(fd_w,status='delete')
|
||||||
|
else
|
||||||
|
deallocate(W)
|
||||||
|
endif
|
||||||
|
|
||||||
|
deallocate ( &
|
||||||
|
residual_norm, &
|
||||||
|
U, overlap, &
|
||||||
|
h, y, s_tmp, &
|
||||||
|
lambda, &
|
||||||
|
u_tmp &
|
||||||
|
)
|
||||||
|
FREE nthreads_davidson
|
||||||
|
|
||||||
|
end subroutine davidson_diag_nonsym_hjj
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
40
src/davidson/overlap_states.irp.f
Normal file
40
src/davidson/overlap_states.irp.f
Normal file
@ -0,0 +1,40 @@
|
|||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ double precision, overlap_states, (N_states,N_states) ]
|
||||||
|
&BEGIN_PROVIDER [ double precision, overlap_states_inv, (N_states,N_states) ]
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
!
|
||||||
|
! S_kl = ck.T x cl
|
||||||
|
! = psi_coef(:,k).T x psi_coef(:,l)
|
||||||
|
!
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer :: i
|
||||||
|
double precision :: o_tmp
|
||||||
|
|
||||||
|
if(N_states == 1) then
|
||||||
|
|
||||||
|
o_tmp = 0.d0
|
||||||
|
do i = 1, N_det
|
||||||
|
o_tmp = o_tmp + psi_coef(i,1) * psi_coef(i,1)
|
||||||
|
enddo
|
||||||
|
overlap_states (1,1) = o_tmp
|
||||||
|
overlap_states_inv(1,1) = 1.d0 / o_tmp
|
||||||
|
|
||||||
|
else
|
||||||
|
|
||||||
|
call dgemm( 'T', 'N', N_states, N_states, N_det, 1.d0 &
|
||||||
|
, psi_coef, size(psi_coef, 1), psi_coef, size(psi_coef, 1) &
|
||||||
|
, 0.d0, overlap_states, size(overlap_states, 1) )
|
||||||
|
|
||||||
|
call get_inverse(overlap_states, N_states, N_states, overlap_states_inv, N_states)
|
||||||
|
|
||||||
|
endif
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
188
src/davidson_dressed/nonsym_diagonalize_ci.irp.f
Normal file
188
src/davidson_dressed/nonsym_diagonalize_ci.irp.f
Normal file
@ -0,0 +1,188 @@
|
|||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ double precision, CI_energy_nonsym_dressed, (N_states_diag) ]
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
! N_states lowest eigenvalues of the CI matrix
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer :: j
|
||||||
|
character*(8) :: st
|
||||||
|
|
||||||
|
call write_time(6)
|
||||||
|
do j = 1, min(N_det, N_states_diag)
|
||||||
|
CI_energy_nonsym_dressed(j) = CI_electronic_energy_nonsym_dressed(j) + nuclear_repulsion
|
||||||
|
enddo
|
||||||
|
|
||||||
|
do j = 1, min(N_det, N_states)
|
||||||
|
write(st, '(I4)') j
|
||||||
|
call write_double(6, CI_energy_nonsym_dressed(j), 'Energy of state '//trim(st))
|
||||||
|
enddo
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ double precision, CI_electronic_energy_nonsym_dressed, (N_states_diag) ]
|
||||||
|
&BEGIN_PROVIDER [ double precision, CI_eigenvectors_nonsym_dressed, (N_det,N_states_diag) ]
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
! Eigenvectors/values of the CI matrix
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
logical :: converged
|
||||||
|
integer :: i, j, k
|
||||||
|
integer :: i_other_state
|
||||||
|
integer :: i_state
|
||||||
|
logical, allocatable :: good_state_array(:)
|
||||||
|
integer, allocatable :: index_good_state_array(:)
|
||||||
|
double precision, allocatable :: eigenvectors(:,:), eigenvalues(:)
|
||||||
|
|
||||||
|
PROVIDE threshold_nonsym_davidson nthreads_davidson
|
||||||
|
|
||||||
|
! Guess values for the "N_states" states of the CI_eigenvectors_nonsym_dressed
|
||||||
|
do j = 1, min(N_states, N_det)
|
||||||
|
do i = 1, N_det
|
||||||
|
CI_eigenvectors_nonsym_dressed(i,j) = psi_coef(i,j)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
do j = min(N_states, N_det)+1, N_states_diag
|
||||||
|
do i = 1, N_det
|
||||||
|
CI_eigenvectors_nonsym_dressed(i,j) = 0.d0
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
if(diag_algorithm == "Davidson") then
|
||||||
|
|
||||||
|
ASSERT(n_states_diag .lt. n_states)
|
||||||
|
|
||||||
|
do j = 1, min(N_states, N_det)
|
||||||
|
do i = 1, N_det
|
||||||
|
CI_eigenvectors_nonsym_dressed(i,j) = psi_coef(i,j)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
converged = .False.
|
||||||
|
call davidson_diag_nonsym_h( psi_det, CI_eigenvectors_nonsym_dressed &
|
||||||
|
, size(CI_eigenvectors_nonsym_dressed, 1) &
|
||||||
|
, CI_electronic_energy_nonsym_dressed &
|
||||||
|
, N_det, min(N_det, N_states), min(N_det, N_states_diag), N_int, 1, converged )
|
||||||
|
|
||||||
|
else if(diag_algorithm == "Lapack") then
|
||||||
|
|
||||||
|
allocate(eigenvectors(size(H_matrix_nonsym_dressed, 1),N_det))
|
||||||
|
allocate(eigenvalues(N_det))
|
||||||
|
|
||||||
|
call diag_nonsym_right( N_det, H_matrix_nonsym_dressed, size(H_matrix_nonsym_dressed, 1) &
|
||||||
|
, eigenvectors, size(eigenvectors, 1), eigenvalues, size(eigenvalues, 1) )
|
||||||
|
|
||||||
|
CI_electronic_energy_nonsym_dressed(:) = 0.d0
|
||||||
|
|
||||||
|
! Select the "N_states_diag" states of lowest energy
|
||||||
|
do j = 1, min(N_det, N_states_diag)
|
||||||
|
do i = 1, N_det
|
||||||
|
CI_eigenvectors_nonsym_dressed(i,j) = eigenvectors(i,j)
|
||||||
|
enddo
|
||||||
|
CI_electronic_energy_nonsym_dressed(j) = eigenvalues(j)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
deallocate(eigenvectors, eigenvalues)
|
||||||
|
|
||||||
|
! --- ---
|
||||||
|
|
||||||
|
endif
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
subroutine diagonalize_CI_nonsym_dressed()
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
! Replace the coefficients of the CI states by the coefficients of the
|
||||||
|
! eigenstates of the CI matrix
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer :: i, j
|
||||||
|
|
||||||
|
PROVIDE dressing_delta
|
||||||
|
|
||||||
|
do j = 1, N_states
|
||||||
|
do i = 1, N_det
|
||||||
|
psi_coef(i,j) = CI_eigenvectors_nonsym_dressed(i,j)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
SOFT_TOUCH psi_coef
|
||||||
|
|
||||||
|
end subroutine diagonalize_CI_nonsym_dressed
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ double precision, H_matrix_nonsym_dressed, (N_det,N_det) ]
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
! Dressed H with Delta_ij
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer :: i, j, l, k
|
||||||
|
double precision :: f
|
||||||
|
|
||||||
|
H_matrix_nonsym_dressed(1:N_det,1:N_det) = h_matrix_all_dets(1:N_det,1:N_det)
|
||||||
|
|
||||||
|
if(N_states == 1) then
|
||||||
|
|
||||||
|
! !symmetric formula
|
||||||
|
! l = dressed_column_idx(1)
|
||||||
|
! f = 1.0d0/psi_coef(l,1)
|
||||||
|
! do i=1,N_det
|
||||||
|
! h_matrix_nonsym_dressed(i,l) += dressing_column_h(i,1) *f
|
||||||
|
! h_matrix_nonsym_dressed(l,i) += dressing_column_h(i,1) *f
|
||||||
|
! enddo
|
||||||
|
|
||||||
|
! l = dressed_column_idx(1)
|
||||||
|
! f = 1.0d0 / psi_coef(l,1)
|
||||||
|
! do j = 1, N_det
|
||||||
|
! H_matrix_nonsym_dressed(j,l) += f * dressing_delta(j,1)
|
||||||
|
! enddo
|
||||||
|
|
||||||
|
k = 1
|
||||||
|
l = 1
|
||||||
|
f = overlap_states_inv(k,l)
|
||||||
|
do j = 1, N_det
|
||||||
|
do i = 1, N_det
|
||||||
|
H_matrix_nonsym_dressed(i,j) = H_matrix_nonsym_dressed(i,j) + f * dressing_delta(i,k) * psi_coef(j,l)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
else
|
||||||
|
|
||||||
|
do k = 1, N_states
|
||||||
|
do l = 1, N_states
|
||||||
|
f = overlap_states_inv(k,l)
|
||||||
|
|
||||||
|
do j = 1, N_det
|
||||||
|
do i = 1, N_det
|
||||||
|
H_matrix_nonsym_dressed(i,j) = H_matrix_nonsym_dressed(i,j) + f * dressing_delta(i,k) * psi_coef(j,l)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
endif
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
54
src/davidson_keywords/EZFIO.cfg
Normal file
54
src/davidson_keywords/EZFIO.cfg
Normal file
@ -0,0 +1,54 @@
|
|||||||
|
[threshold_davidson]
|
||||||
|
type: Threshold
|
||||||
|
doc: Thresholds of Davidson's algorithm if threshold_davidson_from_pt2 is false.
|
||||||
|
interface: ezfio,provider,ocaml
|
||||||
|
default: 1.e-10
|
||||||
|
|
||||||
|
[threshold_nonsym_davidson]
|
||||||
|
type: Threshold
|
||||||
|
doc: Thresholds of non-symetric Davidson's algorithm
|
||||||
|
interface: ezfio,provider,ocaml
|
||||||
|
default: 1.e-10
|
||||||
|
|
||||||
|
[davidson_sze_max]
|
||||||
|
type: Strictly_positive_int
|
||||||
|
doc: Number of micro-iterations before re-contracting
|
||||||
|
default: 15
|
||||||
|
interface: ezfio,provider,ocaml
|
||||||
|
|
||||||
|
[state_following]
|
||||||
|
type: logical
|
||||||
|
doc: If |true|, the states are re-ordered to match the input states
|
||||||
|
default: False
|
||||||
|
interface: ezfio,provider,ocaml
|
||||||
|
|
||||||
|
[disk_based_davidson]
|
||||||
|
type: logical
|
||||||
|
doc: If |true|, a memory-mapped file may be used to store the W and S2 vectors if not enough RAM is availabl
|
||||||
|
default: True
|
||||||
|
interface: ezfio,provider,ocaml
|
||||||
|
|
||||||
|
[n_states_diag]
|
||||||
|
type: States_number
|
||||||
|
doc: Controls the number of states to consider during the Davdison diagonalization. The number of states is n_states * n_states_diag
|
||||||
|
default: 4
|
||||||
|
interface: ezfio,ocaml
|
||||||
|
|
||||||
|
[n_det_max_full]
|
||||||
|
type: Det_number_max
|
||||||
|
doc: Maximum number of determinants where |H| is fully diagonalized
|
||||||
|
interface: ezfio,provider,ocaml
|
||||||
|
default: 1000
|
||||||
|
|
||||||
|
[threshold_davidson_from_pt2]
|
||||||
|
type: logical
|
||||||
|
doc: Thresholds of Davidson's algorithm is set to E(rPT2)*threshold_davidson_from_pt2
|
||||||
|
interface: ezfio,provider,ocaml
|
||||||
|
default: false
|
||||||
|
|
||||||
|
[distributed_davidson]
|
||||||
|
type: logical
|
||||||
|
doc: If |true|, use the distributed algorithm
|
||||||
|
default: True
|
||||||
|
interface: ezfio,provider,ocaml
|
||||||
|
|
1
src/davidson_keywords/NEED
Normal file
1
src/davidson_keywords/NEED
Normal file
@ -0,0 +1 @@
|
|||||||
|
ezfio_files
|
5
src/davidson_keywords/README.rst
Normal file
5
src/davidson_keywords/README.rst
Normal file
@ -0,0 +1,5 @@
|
|||||||
|
=================
|
||||||
|
davidson_keywords
|
||||||
|
=================
|
||||||
|
|
||||||
|
Keywords used for Davidson algorithms.
|
@ -1,3 +1,6 @@
|
|||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
BEGIN_PROVIDER [ integer, n_states_diag ]
|
BEGIN_PROVIDER [ integer, n_states_diag ]
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
@ -8,11 +11,11 @@ BEGIN_PROVIDER [ integer, n_states_diag ]
|
|||||||
PROVIDE ezfio_filename
|
PROVIDE ezfio_filename
|
||||||
if (mpi_master) then
|
if (mpi_master) then
|
||||||
|
|
||||||
call ezfio_has_davidson_n_states_diag(has)
|
call ezfio_has_davidson_keywords_n_states_diag(has)
|
||||||
if (has) then
|
if (has) then
|
||||||
call ezfio_get_davidson_n_states_diag(n_states_diag)
|
call ezfio_get_davidson_keywords_n_states_diag(n_states_diag)
|
||||||
else
|
else
|
||||||
print *, 'davidson/n_states_diag not found in EZFIO file'
|
print *, 'davidson_keywords/n_states_diag not found in EZFIO file'
|
||||||
stop 1
|
stop 1
|
||||||
endif
|
endif
|
||||||
n_states_diag = max(2,N_states * N_states_diag)
|
n_states_diag = max(2,N_states * N_states_diag)
|
||||||
@ -32,3 +35,4 @@ BEGIN_PROVIDER [ integer, n_states_diag ]
|
|||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
33
src/davidson_keywords/usef.irp.f
Normal file
33
src/davidson_keywords/usef.irp.f
Normal file
@ -0,0 +1,33 @@
|
|||||||
|
use bitmasks
|
||||||
|
use f77_zmq
|
||||||
|
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ integer, nthreads_davidson ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Number of threads for Davidson
|
||||||
|
END_DOC
|
||||||
|
nthreads_davidson = nproc
|
||||||
|
character*(32) :: env
|
||||||
|
call getenv('QP_NTHREADS_DAVIDSON',env)
|
||||||
|
if (trim(env) /= '') then
|
||||||
|
read(env,*) nthreads_davidson
|
||||||
|
call write_int(6,nthreads_davidson,'Target number of threads for <Psi|H|Psi>')
|
||||||
|
endif
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ double precision, threshold_davidson_pt2 ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Threshold of Davidson's algorithm, using PT2 as a guide
|
||||||
|
END_DOC
|
||||||
|
threshold_davidson_pt2 = threshold_davidson
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
@ -1,10 +1,12 @@
|
|||||||
BEGIN_PROVIDER [ double precision, dressing_column_h, (N_det,N_states) ]
|
BEGIN_PROVIDER [ double precision, dressing_column_h, (N_det,N_states) ]
|
||||||
&BEGIN_PROVIDER [ double precision, dressing_column_s, (N_det,N_states) ]
|
&BEGIN_PROVIDER [ double precision, dressing_column_s, (N_det,N_states) ]
|
||||||
|
&BEGIN_PROVIDER [ double precision, dressing_delta , (N_det,N_states) ]
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Null dressing vectors
|
! Null dressing vectors
|
||||||
END_DOC
|
END_DOC
|
||||||
dressing_column_h(:,:) = 0.d0
|
dressing_column_h(:,:) = 0.d0
|
||||||
dressing_column_s(:,:) = 0.d0
|
dressing_column_s(:,:) = 0.d0
|
||||||
|
dressing_delta (:,:) = 0.d0
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
@ -9,8 +9,11 @@ spindeterminants
|
|||||||
psi_det_beta integer*8 (spindeterminants_n_int*spindeterminants_bit_kind/8,spindeterminants_n_det_beta)
|
psi_det_beta integer*8 (spindeterminants_n_int*spindeterminants_bit_kind/8,spindeterminants_n_det_beta)
|
||||||
psi_coef_matrix_rows integer (spindeterminants_n_det)
|
psi_coef_matrix_rows integer (spindeterminants_n_det)
|
||||||
psi_coef_matrix_columns integer (spindeterminants_n_det)
|
psi_coef_matrix_columns integer (spindeterminants_n_det)
|
||||||
psi_coef_matrix_values double precision (spindeterminants_n_det,spindeterminants_n_states)
|
psi_coef_matrix_values double precision (spindeterminants_n_det,spindeterminants_n_states)
|
||||||
|
psi_left_coef_matrix_values double precision (spindeterminants_n_det,spindeterminants_n_states)
|
||||||
n_svd_coefs integer
|
n_svd_coefs integer
|
||||||
|
n_svd_alpha integer
|
||||||
|
n_svd_beta integer
|
||||||
psi_svd_alpha double precision (spindeterminants_n_det_alpha,spindeterminants_n_svd_coefs,spindeterminants_n_states)
|
psi_svd_alpha double precision (spindeterminants_n_det_alpha,spindeterminants_n_svd_coefs,spindeterminants_n_states)
|
||||||
psi_svd_beta double precision (spindeterminants_n_det_beta,spindeterminants_n_svd_coefs,spindeterminants_n_states)
|
psi_svd_beta double precision (spindeterminants_n_det_beta,spindeterminants_n_svd_coefs,spindeterminants_n_states)
|
||||||
psi_svd_coefs double precision (spindeterminants_n_svd_coefs,spindeterminants_n_states)
|
psi_svd_coefs double precision (spindeterminants_n_svd_coefs,spindeterminants_n_states)
|
||||||
|
@ -140,6 +140,8 @@ end
|
|||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
|
! TODO : build the vector of chi_i(r) chi_j(r) and conscequently grad_i(r) grad_j(r)
|
||||||
|
! : the same for gamma_ij and big dot product
|
||||||
do istate = 1, N_states
|
do istate = 1, N_states
|
||||||
! alpha density
|
! alpha density
|
||||||
! aos_array_bis = \rho_ao * aos_array
|
! aos_array_bis = \rho_ao * aos_array
|
||||||
|
@ -39,6 +39,9 @@ subroutine diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2)
|
|||||||
write(*,'(A28,X,I10,X,100(F16.8,X))')'Ndet,E,E+PT2,E+RPT2,|PT2|=',ndet,E_tc ,E_tc + pt2_tmp/norm,E_tc + rpt2_tmp/norm,abs_pt2
|
write(*,'(A28,X,I10,X,100(F16.8,X))')'Ndet,E,E+PT2,E+RPT2,|PT2|=',ndet,E_tc ,E_tc + pt2_tmp/norm,E_tc + rpt2_tmp/norm,abs_pt2
|
||||||
print*,'*****'
|
print*,'*****'
|
||||||
endif
|
endif
|
||||||
|
psi_energy(1:N_states) = eigval_right_tc_bi_orth(1:N_states)
|
||||||
|
psi_s2(1:N_states) = s2_eigvec_tc_bi_orth(1:N_states)
|
||||||
|
|
||||||
E_tc = eigval_right_tc_bi_orth(1)
|
E_tc = eigval_right_tc_bi_orth(1)
|
||||||
norm = norm_ground_left_right_bi_orth
|
norm = norm_ground_left_right_bi_orth
|
||||||
ndet = N_det
|
ndet = N_det
|
||||||
@ -50,7 +53,7 @@ subroutine diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2)
|
|||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
SOFT_TOUCH eigval_left_tc_bi_orth eigval_right_tc_bi_orth leigvec_tc_bi_orth reigvec_tc_bi_orth norm_ground_left_right_bi_orth
|
SOFT_TOUCH eigval_left_tc_bi_orth eigval_right_tc_bi_orth leigvec_tc_bi_orth reigvec_tc_bi_orth norm_ground_left_right_bi_orth
|
||||||
SOFT_TOUCH psi_l_coef_bi_ortho psi_r_coef_bi_ortho psi_coef
|
SOFT_TOUCH psi_l_coef_bi_ortho psi_r_coef_bi_ortho psi_coef psi_energy psi_s2
|
||||||
|
|
||||||
call save_tc_bi_ortho_wavefunction
|
call save_tc_bi_ortho_wavefunction
|
||||||
end
|
end
|
||||||
|
31
src/fci_tc_bi/pt2_tc.irp.f
Normal file
31
src/fci_tc_bi/pt2_tc.irp.f
Normal file
@ -0,0 +1,31 @@
|
|||||||
|
program tc_pt2_prog
|
||||||
|
implicit none
|
||||||
|
my_grid_becke = .True.
|
||||||
|
my_n_pt_r_grid = 30
|
||||||
|
my_n_pt_a_grid = 50
|
||||||
|
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||||
|
pruning = -1.d0
|
||||||
|
touch pruning
|
||||||
|
! pt2_relative_error = 0.01d0
|
||||||
|
! touch pt2_relative_error
|
||||||
|
call run_pt2_tc
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
|
subroutine run_pt2_tc
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
PROVIDE psi_det psi_coef mo_bi_ortho_tc_two_e mo_bi_ortho_tc_one_e
|
||||||
|
if(elec_alpha_num+elec_beta_num.ge.3)then
|
||||||
|
if(three_body_h_tc)then
|
||||||
|
call provide_all_three_ints_bi_ortho
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
! ---
|
||||||
|
|
||||||
|
call tc_pt2
|
||||||
|
|
||||||
|
|
||||||
|
end
|
@ -3,7 +3,7 @@ program print_mos
|
|||||||
integer :: i,nx
|
integer :: i,nx
|
||||||
double precision :: r(3), xmax, dx, accu
|
double precision :: r(3), xmax, dx, accu
|
||||||
double precision, allocatable :: mos_array(:)
|
double precision, allocatable :: mos_array(:)
|
||||||
double precision:: alpha,envelop
|
double precision:: alpha,envelop,dm_a,dm_b
|
||||||
allocate(mos_array(mo_num))
|
allocate(mos_array(mo_num))
|
||||||
xmax = 5.d0
|
xmax = 5.d0
|
||||||
nx = 1000
|
nx = 1000
|
||||||
@ -11,11 +11,12 @@ program print_mos
|
|||||||
r = 0.d0
|
r = 0.d0
|
||||||
alpha = 0.5d0
|
alpha = 0.5d0
|
||||||
do i = 1, nx
|
do i = 1, nx
|
||||||
|
call dm_dft_alpha_beta_at_r(r,dm_a,dm_b)
|
||||||
call give_all_mos_at_r(r,mos_array)
|
call give_all_mos_at_r(r,mos_array)
|
||||||
accu = mos_array(3)**2+mos_array(4)**2+mos_array(5)**2
|
accu = mos_array(3)**2+mos_array(4)**2+mos_array(5)**2
|
||||||
accu = dsqrt(accu)
|
accu = dsqrt(accu)
|
||||||
envelop = (1.d0 - dexp(-alpha * r(3)**2))
|
envelop = (1.d0 - dexp(-alpha * r(3)**2))
|
||||||
write(33,'(100(F16.10,X))')r(3), mos_array(1), mos_array(2), accu, envelop
|
write(33,'(100(F16.10,X))')r(3), mos_array(1), mos_array(2), accu, dm_a+dm_b, envelop
|
||||||
r(3) += dx
|
r(3) += dx
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
|
@ -9,6 +9,12 @@ doc: Coefficient of the i-th |AO| on the j-th |MO|
|
|||||||
interface: ezfio
|
interface: ezfio
|
||||||
size: (ao_basis.ao_num,mo_basis.mo_num)
|
size: (ao_basis.ao_num,mo_basis.mo_num)
|
||||||
|
|
||||||
|
[mo_coef_aux]
|
||||||
|
type: double precision
|
||||||
|
doc: AUX Coefficient of the i-th |AO| on the j-th |MO|
|
||||||
|
interface: ezfio
|
||||||
|
size: (ao_basis.ao_num,mo_basis.mo_num)
|
||||||
|
|
||||||
[mo_coef_imag]
|
[mo_coef_imag]
|
||||||
type: double precision
|
type: double precision
|
||||||
doc: Imaginary part of the MO coefficient of the i-th |AO| on the j-th |MO|
|
doc: Imaginary part of the MO coefficient of the i-th |AO| on the j-th |MO|
|
||||||
|
53
src/mo_basis/mos_aux.irp.f
Normal file
53
src/mo_basis/mos_aux.irp.f
Normal file
@ -0,0 +1,53 @@
|
|||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [double precision, mo_coef_aux, (ao_num,mo_num)]
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer :: i, j
|
||||||
|
logical :: exists
|
||||||
|
double precision, allocatable :: buffer(:,:)
|
||||||
|
|
||||||
|
PROVIDE ezfio_filename
|
||||||
|
|
||||||
|
if (mpi_master) then
|
||||||
|
! Coefs
|
||||||
|
call ezfio_has_mo_basis_mo_coef_aux(exists)
|
||||||
|
endif
|
||||||
|
|
||||||
|
IRP_IF MPI_DEBUG
|
||||||
|
print *, irp_here, mpi_rank
|
||||||
|
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
|
||||||
|
IRP_ENDIF
|
||||||
|
|
||||||
|
IRP_IF MPI
|
||||||
|
include 'mpif.h'
|
||||||
|
integer :: ierr
|
||||||
|
call MPI_BCAST(exists, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD, ierr)
|
||||||
|
if (ierr /= MPI_SUCCESS) then
|
||||||
|
stop 'Unable to read mo_coef_aux with MPI'
|
||||||
|
endif
|
||||||
|
IRP_ENDIF
|
||||||
|
|
||||||
|
if (exists) then
|
||||||
|
if (mpi_master) then
|
||||||
|
call ezfio_get_mo_basis_mo_coef_aux(mo_coef_aux)
|
||||||
|
write(*,*) 'Read mo_coef_aux'
|
||||||
|
endif
|
||||||
|
IRP_IF MPI
|
||||||
|
call MPI_BCAST(mo_coef_aux, mo_num*ao_num, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
|
||||||
|
if (ierr /= MPI_SUCCESS) then
|
||||||
|
stop 'Unable to read mo_coef_aux with MPI'
|
||||||
|
endif
|
||||||
|
IRP_ENDIF
|
||||||
|
else
|
||||||
|
! Orthonormalized AO basis
|
||||||
|
do i = 1, mo_num
|
||||||
|
do j = 1, ao_num
|
||||||
|
mo_coef_aux(j,i) = ao_ortho_canonical_coef(j,i)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
@ -18,13 +18,13 @@ program debug_fit
|
|||||||
PROVIDE mu_erf j1b_pen
|
PROVIDE mu_erf j1b_pen
|
||||||
|
|
||||||
!call test_j1b_nucl()
|
!call test_j1b_nucl()
|
||||||
call test_grad_j1b_nucl()
|
!call test_grad_j1b_nucl()
|
||||||
!call test_lapl_j1b_nucl()
|
!call test_lapl_j1b_nucl()
|
||||||
|
|
||||||
!call test_list_b2()
|
!call test_list_b2()
|
||||||
!call test_list_b3()
|
call test_list_b3()
|
||||||
|
|
||||||
call test_fit_u()
|
!call test_fit_u()
|
||||||
!call test_fit_u2()
|
!call test_fit_u2()
|
||||||
!call test_fit_ugradu()
|
!call test_fit_ugradu()
|
||||||
|
|
||||||
@ -82,9 +82,9 @@ subroutine test_grad_j1b_nucl()
|
|||||||
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
|
double precision, external :: grad_x_j1b_nucl_num
|
||||||
double precision, external :: grad_y_j1b_nucl
|
double precision, external :: grad_y_j1b_nucl_num
|
||||||
double precision, external :: grad_z_j1b_nucl
|
double precision, external :: grad_z_j1b_nucl_num
|
||||||
|
|
||||||
print*, ' test_grad_j1b_nucl ...'
|
print*, ' test_grad_j1b_nucl ...'
|
||||||
|
|
||||||
@ -101,7 +101,7 @@ subroutine test_grad_j1b_nucl()
|
|||||||
r(3) = final_grid_points(3,ipoint)
|
r(3) = final_grid_points(3,ipoint)
|
||||||
|
|
||||||
i_exc = v_1b_grad(1,ipoint)
|
i_exc = v_1b_grad(1,ipoint)
|
||||||
i_num = grad_x_j1b_nucl(r)
|
i_num = grad_x_j1b_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 v_1b_grad on', ipoint
|
||||||
@ -111,7 +111,7 @@ subroutine test_grad_j1b_nucl()
|
|||||||
endif
|
endif
|
||||||
|
|
||||||
i_exc = v_1b_grad(2,ipoint)
|
i_exc = v_1b_grad(2,ipoint)
|
||||||
i_num = grad_y_j1b_nucl(r)
|
i_num = grad_y_j1b_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 v_1b_grad on', ipoint
|
||||||
@ -121,7 +121,7 @@ subroutine test_grad_j1b_nucl()
|
|||||||
endif
|
endif
|
||||||
|
|
||||||
i_exc = v_1b_grad(3,ipoint)
|
i_exc = v_1b_grad(3,ipoint)
|
||||||
i_num = grad_z_j1b_nucl(r)
|
i_num = grad_z_j1b_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 v_1b_grad on', ipoint
|
||||||
@ -236,16 +236,25 @@ subroutine test_list_b3()
|
|||||||
integer :: ipoint
|
integer :: ipoint
|
||||||
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_tmp, i_num, normalz
|
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_tmp, i_num, normalz
|
||||||
double precision :: r(3)
|
double precision :: r(3)
|
||||||
double precision, external :: j1b_nucl
|
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 ...'
|
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
|
PROVIDE v_1b_list_b3
|
||||||
|
|
||||||
eps_ij = 1d-7
|
|
||||||
acc_tot = 0.d0
|
acc_tot = 0.d0
|
||||||
normalz = 0.d0
|
normalz = 0.d0
|
||||||
|
|
||||||
do ipoint = 1, n_points_final_grid
|
do ipoint = 1, n_points_final_grid
|
||||||
|
|
||||||
r(1) = final_grid_points(1,ipoint)
|
r(1) = final_grid_points(1,ipoint)
|
||||||
@ -253,11 +262,12 @@ subroutine test_list_b3()
|
|||||||
r(3) = final_grid_points(3,ipoint)
|
r(3) = final_grid_points(3,ipoint)
|
||||||
|
|
||||||
i_exc = v_1b_list_b3(ipoint)
|
i_exc = v_1b_list_b3(ipoint)
|
||||||
i_tmp = j1b_nucl(r)
|
i_num = j1b_nucl_square(r)
|
||||||
i_num = i_tmp * i_tmp
|
|
||||||
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 list_b3 on', ipoint
|
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 *, ' analyt = ', i_exc
|
||||||
print *, ' numeri = ', i_num
|
print *, ' numeri = ', i_num
|
||||||
print *, ' diff = ', acc_ij
|
print *, ' diff = ', acc_ij
|
||||||
@ -267,8 +277,136 @@ subroutine test_list_b3()
|
|||||||
normalz += dabs(i_num)
|
normalz += dabs(i_num)
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
print*, ' acc_tot = ', acc_tot
|
print*, ' acc_tot on val = ', acc_tot
|
||||||
print*, ' normalz = ', normalz
|
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
|
return
|
||||||
end subroutine test_list_b3
|
end subroutine test_list_b3
|
||||||
@ -317,7 +455,7 @@ subroutine test_fit_ugradu()
|
|||||||
i_fit = i_fit / dsqrt(x2)
|
i_fit = i_fit / dsqrt(x2)
|
||||||
|
|
||||||
tmp = j12_mu(r1, r2)
|
tmp = j12_mu(r1, r2)
|
||||||
call grad1_j12_mu_exc(r1, r2, grad)
|
call grad1_j12_mu(r1, r2, grad)
|
||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
|
||||||
|
@ -17,7 +17,7 @@ BEGIN_PROVIDER [ double precision, gradu_squared_u_ij_mu, (ao_num, ao_num, n_poi
|
|||||||
!
|
!
|
||||||
! if J(r1,r2) = u12 x v1 x v2
|
! 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) ]
|
! 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.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
|
! + -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
|
! + -1.00 x v1 (grad_1 v1) \int r2 \phi_i(2) \phi_j(2) (grad_1 u12) v2^2
|
||||||
@ -232,37 +232,33 @@ BEGIN_PROVIDER [ double precision, grad12_j12, (ao_num, ao_num, n_points_final_g
|
|||||||
|
|
||||||
PROVIDE j1b_type
|
PROVIDE j1b_type
|
||||||
|
|
||||||
if(j1b_type .eq. 3) then
|
do ipoint = 1, n_points_final_grid
|
||||||
|
tmp1 = v_1b(ipoint)
|
||||||
do ipoint = 1, n_points_final_grid
|
tmp1 = tmp1 * tmp1
|
||||||
tmp1 = v_1b(ipoint)
|
do j = 1, ao_num
|
||||||
tmp1 = tmp1 * tmp1
|
do i = 1, ao_num
|
||||||
do j = 1, ao_num
|
grad12_j12(i,j,ipoint) = tmp1 * int2_grad1u2_grad2u2_j1b2(i,j,ipoint)
|
||||||
do i = 1, ao_num
|
|
||||||
grad12_j12(i,j,ipoint) = tmp1 * int2_grad1u2_grad2u2_j1b2(i,j,ipoint)
|
|
||||||
enddo
|
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
else
|
!if(j1b_type .eq. 0) then
|
||||||
|
! grad12_j12 = 0.d0
|
||||||
grad12_j12 = 0.d0
|
! do ipoint = 1, n_points_final_grid
|
||||||
do ipoint = 1, n_points_final_grid
|
! r(1) = final_grid_points(1,ipoint)
|
||||||
r(1) = final_grid_points(1,ipoint)
|
! r(2) = final_grid_points(2,ipoint)
|
||||||
r(2) = final_grid_points(2,ipoint)
|
! r(3) = final_grid_points(3,ipoint)
|
||||||
r(3) = final_grid_points(3,ipoint)
|
! do j = 1, ao_num
|
||||||
do j = 1, ao_num
|
! do i = 1, ao_num
|
||||||
do i = 1, ao_num
|
! do igauss = 1, n_max_fit_slat
|
||||||
do igauss = 1, n_max_fit_slat
|
! delta = expo_gauss_1_erf_x_2(igauss)
|
||||||
delta = expo_gauss_1_erf_x_2(igauss)
|
! coef = coef_gauss_1_erf_x_2(igauss)
|
||||||
coef = coef_gauss_1_erf_x_2(igauss)
|
! grad12_j12(i,j,ipoint) += -0.25d0 * coef * overlap_gauss_r12_ao(r, delta, i, j)
|
||||||
grad12_j12(i,j,ipoint) += -0.25d0 * coef * overlap_gauss_r12_ao(r, delta, i, j)
|
! enddo
|
||||||
enddo
|
! enddo
|
||||||
enddo
|
! enddo
|
||||||
enddo
|
! enddo
|
||||||
enddo
|
!endif
|
||||||
|
|
||||||
endif
|
|
||||||
|
|
||||||
call wall_time(time1)
|
call wall_time(time1)
|
||||||
print*, ' Wall time for grad12_j12 = ', time1 - time0
|
print*, ' Wall time for grad12_j12 = ', time1 - time0
|
||||||
@ -271,7 +267,7 @@ END_PROVIDER
|
|||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
|
||||||
BEGIN_PROVIDER [ double precision, u12sq_j1bsq, (ao_num, ao_num, n_points_final_grid) ]
|
BEGIN_PROVIDER [double precision, u12sq_j1bsq, (ao_num, ao_num, n_points_final_grid)]
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
integer :: ipoint, i, j
|
integer :: ipoint, i, j
|
||||||
@ -351,17 +347,19 @@ END_PROVIDER
|
|||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
|
||||||
|
|
||||||
BEGIN_PROVIDER [double precision, tc_grad_square_ao, (ao_num, ao_num, ao_num, ao_num)]
|
BEGIN_PROVIDER [double precision, tc_grad_square_ao, (ao_num, ao_num, ao_num, ao_num)]
|
||||||
|
|
||||||
BEGIN_DOC
|
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>
|
! 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
|
END_DOC
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
integer :: ipoint, i, j, k, l
|
integer :: ipoint, i, j, k, l
|
||||||
double precision :: weight1, ao_ik_r, ao_i_r
|
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 :: time0, time1
|
||||||
double precision, allocatable :: b_mat(:,:,:), tmp(:,:,:)
|
double precision, allocatable :: b_mat(:,:,:), tmp(:,:,:)
|
||||||
|
|
||||||
@ -376,14 +374,18 @@ BEGIN_PROVIDER [double precision, tc_grad_square_ao, (ao_num, ao_num, ao_num, ao
|
|||||||
|
|
||||||
else
|
else
|
||||||
|
|
||||||
allocate(b_mat(n_points_final_grid,ao_num,ao_num), tmp(ao_num,ao_num,n_points_final_grid))
|
! ---
|
||||||
|
|
||||||
|
PROVIDE int2_grad1_u12_square_ao
|
||||||
|
|
||||||
|
allocate(b_mat(n_points_final_grid,ao_num,ao_num))
|
||||||
|
|
||||||
b_mat = 0.d0
|
b_mat = 0.d0
|
||||||
!$OMP PARALLEL &
|
!$OMP PARALLEL &
|
||||||
!$OMP DEFAULT (NONE) &
|
!$OMP DEFAULT (NONE) &
|
||||||
!$OMP PRIVATE (i, k, ipoint) &
|
!$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 SHARED (aos_in_r_array_transp, b_mat, ao_num, n_points_final_grid, final_weight_at_r_vector)
|
||||||
!$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
|
||||||
do ipoint = 1, n_points_final_grid
|
do ipoint = 1, n_points_final_grid
|
||||||
@ -391,30 +393,60 @@ BEGIN_PROVIDER [double precision, tc_grad_square_ao, (ao_num, ao_num, ao_num, ao
|
|||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
!$OMP END DO
|
!$OMP END DO
|
||||||
!$OMP END PARALLEL
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
tmp = 0.d0
|
|
||||||
!$OMP PARALLEL &
|
|
||||||
!$OMP DEFAULT (NONE) &
|
|
||||||
!$OMP PRIVATE (j, l, ipoint) &
|
|
||||||
!$OMP SHARED (tmp, ao_num, n_points_final_grid, u12sq_j1bsq, u12_grad1_u12_j1b_grad1_j1b, grad12_j12)
|
|
||||||
!$OMP DO SCHEDULE (static)
|
|
||||||
do ipoint = 1, n_points_final_grid
|
|
||||||
do j = 1, ao_num
|
|
||||||
do l = 1, ao_num
|
|
||||||
tmp(l,j,ipoint) = u12sq_j1bsq(l,j,ipoint) + u12_grad1_u12_j1b_grad1_j1b(l,j,ipoint) + 0.5d0 * grad12_j12(l,j,ipoint)
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
!$OMP END DO
|
|
||||||
!$OMP END PARALLEL
|
|
||||||
|
|
||||||
tc_grad_square_ao = 0.d0
|
tc_grad_square_ao = 0.d0
|
||||||
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 &
|
||||||
, tmp(1,1,1), ao_num*ao_num, b_mat(1,1,1), n_points_final_grid &
|
, int2_grad1_u12_square_ao(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)
|
, 0.d0, tc_grad_square_ao, ao_num*ao_num)
|
||||||
deallocate(tmp, b_mat)
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
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
|
||||||
|
! note that the factor
|
||||||
|
|
||||||
|
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)
|
||||||
|
endif
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
deallocate(b_mat)
|
||||||
|
|
||||||
call sum_A_At(tc_grad_square_ao(1,1,1,1), ao_num*ao_num)
|
call sum_A_At(tc_grad_square_ao(1,1,1,1), ao_num*ao_num)
|
||||||
|
|
||||||
@ -450,3 +482,4 @@ BEGIN_PROVIDER [double precision, tc_grad_square_ao, (ao_num, ao_num, ao_num, ao
|
|||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
|
||||||
|
@ -16,9 +16,11 @@ BEGIN_PROVIDER [double precision, ao_non_hermit_term_chemist, (ao_num, ao_num, a
|
|||||||
double precision :: wall1, wall0
|
double precision :: wall1, wall0
|
||||||
double precision, allocatable :: b_mat(:,:,:,:), ac_mat(:,:,:,:)
|
double precision, allocatable :: b_mat(:,:,:,:), ac_mat(:,:,:,:)
|
||||||
|
|
||||||
|
print*, ' providing ao_non_hermit_term_chemist ...'
|
||||||
|
call wall_time(wall0)
|
||||||
|
|
||||||
provide v_ij_erf_rk_cst_mu x_v_ij_erf_rk_cst_mu
|
provide v_ij_erf_rk_cst_mu x_v_ij_erf_rk_cst_mu
|
||||||
|
|
||||||
call wall_time(wall0)
|
|
||||||
allocate(b_mat(n_points_final_grid,ao_num,ao_num,3), ac_mat(ao_num,ao_num,ao_num,ao_num))
|
allocate(b_mat(n_points_final_grid,ao_num,ao_num,3), ac_mat(ao_num,ao_num,ao_num,ao_num))
|
||||||
|
|
||||||
!$OMP PARALLEL &
|
!$OMP PARALLEL &
|
||||||
@ -102,7 +104,7 @@ BEGIN_PROVIDER [double precision, ao_non_hermit_term_chemist, (ao_num, ao_num, a
|
|||||||
!$OMP END PARALLEL
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
call wall_time(wall1)
|
call wall_time(wall1)
|
||||||
print *, ' wall time dgemm ', wall1 - wall0
|
print *, ' wall time for ao_non_hermit_term_chemist ', wall1 - wall0
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
@ -8,79 +8,160 @@ BEGIN_PROVIDER [ double precision, v_1b, (n_points_final_grid)]
|
|||||||
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
|
||||||
|
|
||||||
do ipoint = 1, n_points_final_grid
|
if(j1b_type .eq. 3) then
|
||||||
|
|
||||||
x = final_grid_points(1,ipoint)
|
! v(r) = \Pi_{a} [1 - \exp(-\alpha_a (r - r_a)^2)]
|
||||||
y = final_grid_points(2,ipoint)
|
|
||||||
z = final_grid_points(3,ipoint)
|
|
||||||
|
|
||||||
fact_r = 1.d0
|
do ipoint = 1, n_points_final_grid
|
||||||
do j = 1, nucl_num
|
|
||||||
a = j1b_pen(j)
|
|
||||||
dx = x - nucl_coord(j,1)
|
|
||||||
dy = y - nucl_coord(j,2)
|
|
||||||
dz = z - nucl_coord(j,3)
|
|
||||||
d = dx*dx + dy*dy + dz*dz
|
|
||||||
e = 1.d0 - dexp(-a*d)
|
|
||||||
|
|
||||||
fact_r = fact_r * e
|
x = final_grid_points(1,ipoint)
|
||||||
|
y = final_grid_points(2,ipoint)
|
||||||
|
z = final_grid_points(3,ipoint)
|
||||||
|
|
||||||
|
fact_r = 1.d0
|
||||||
|
do j = 1, nucl_num
|
||||||
|
a = j1b_pen(j)
|
||||||
|
dx = x - nucl_coord(j,1)
|
||||||
|
dy = y - nucl_coord(j,2)
|
||||||
|
dz = z - nucl_coord(j,3)
|
||||||
|
d = dx*dx + dy*dy + dz*dz
|
||||||
|
e = 1.d0 - dexp(-a*d)
|
||||||
|
|
||||||
|
fact_r = fact_r * e
|
||||||
|
enddo
|
||||||
|
|
||||||
|
v_1b(ipoint) = fact_r
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
v_1b(ipoint) = fact_r
|
elseif(j1b_type .eq. 4) then
|
||||||
enddo
|
|
||||||
|
! v(r) = 1 - \sum_{a} \exp(-\alpha_a (r - r_a)^2)
|
||||||
|
|
||||||
|
do ipoint = 1, n_points_final_grid
|
||||||
|
|
||||||
|
x = final_grid_points(1,ipoint)
|
||||||
|
y = final_grid_points(2,ipoint)
|
||||||
|
z = final_grid_points(3,ipoint)
|
||||||
|
|
||||||
|
fact_r = 1.d0
|
||||||
|
do j = 1, nucl_num
|
||||||
|
a = j1b_pen(j)
|
||||||
|
dx = x - nucl_coord(j,1)
|
||||||
|
dy = y - nucl_coord(j,2)
|
||||||
|
dz = z - nucl_coord(j,3)
|
||||||
|
d = dx*dx + dy*dy + dz*dz
|
||||||
|
|
||||||
|
fact_r = fact_r - dexp(-a*d)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
v_1b(ipoint) = fact_r
|
||||||
|
enddo
|
||||||
|
|
||||||
|
else
|
||||||
|
|
||||||
|
print*, 'j1b_type = ', j1b_type, 'is not implemented for v_1b'
|
||||||
|
stop
|
||||||
|
|
||||||
|
endif
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
|
||||||
BEGIN_PROVIDER [ double precision, v_1b_grad, (3, n_points_final_grid)]
|
BEGIN_PROVIDER [double precision, v_1b_grad, (3, 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, r2
|
||||||
double precision :: a, d, e
|
double precision :: a, d, e
|
||||||
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
|
||||||
|
|
||||||
do ipoint = 1, n_points_final_grid
|
PROVIDE j1b_type
|
||||||
|
|
||||||
x = final_grid_points(1,ipoint)
|
if(j1b_type .eq. 3) then
|
||||||
y = final_grid_points(2,ipoint)
|
|
||||||
z = final_grid_points(3,ipoint)
|
|
||||||
|
|
||||||
fact_x = 0.d0
|
! v(r) = \Pi_{a} [1 - \exp(-\alpha_a (r - r_a)^2)]
|
||||||
fact_y = 0.d0
|
|
||||||
fact_z = 0.d0
|
do ipoint = 1, n_points_final_grid
|
||||||
do i = 1, List_all_comb_b2_size
|
|
||||||
|
x = final_grid_points(1,ipoint)
|
||||||
|
y = final_grid_points(2,ipoint)
|
||||||
|
z = final_grid_points(3,ipoint)
|
||||||
|
|
||||||
|
fact_x = 0.d0
|
||||||
|
fact_y = 0.d0
|
||||||
|
fact_z = 0.d0
|
||||||
|
do i = 1, List_all_comb_b2_size
|
||||||
|
|
||||||
|
phase = 0
|
||||||
|
a_expo = 0.d0
|
||||||
|
ax_der = 0.d0
|
||||||
|
ay_der = 0.d0
|
||||||
|
az_der = 0.d0
|
||||||
|
do j = 1, nucl_num
|
||||||
|
a = dble(List_all_comb_b2(j,i)) * j1b_pen(j)
|
||||||
|
dx = x - nucl_coord(j,1)
|
||||||
|
dy = y - nucl_coord(j,2)
|
||||||
|
dz = z - nucl_coord(j,3)
|
||||||
|
|
||||||
|
phase += List_all_comb_b2(j,i)
|
||||||
|
a_expo += a * (dx*dx + dy*dy + dz*dz)
|
||||||
|
ax_der += a * dx
|
||||||
|
ay_der += a * dy
|
||||||
|
az_der += a * dz
|
||||||
|
enddo
|
||||||
|
e = -2.d0 * (-1.d0)**dble(phase) * dexp(-a_expo)
|
||||||
|
|
||||||
|
fact_x += e * ax_der
|
||||||
|
fact_y += e * ay_der
|
||||||
|
fact_z += e * az_der
|
||||||
|
enddo
|
||||||
|
|
||||||
|
v_1b_grad(1,ipoint) = fact_x
|
||||||
|
v_1b_grad(2,ipoint) = fact_y
|
||||||
|
v_1b_grad(3,ipoint) = fact_z
|
||||||
|
enddo
|
||||||
|
|
||||||
|
elseif(j1b_type .eq. 4) then
|
||||||
|
|
||||||
|
! v(r) = 1 - \sum_{a} \exp(-\alpha_a (r - r_a)^2)
|
||||||
|
|
||||||
|
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)
|
||||||
|
|
||||||
phase = 0
|
|
||||||
a_expo = 0.d0
|
|
||||||
ax_der = 0.d0
|
ax_der = 0.d0
|
||||||
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)
|
|
||||||
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)
|
||||||
|
r2 = dx*dx + dy*dy + dz*dz
|
||||||
|
|
||||||
phase += List_all_comb_b2(j,i)
|
a = j1b_pen(j)
|
||||||
a_expo += a * (dx*dx + dy*dy + dz*dz)
|
e = a * dexp(-a * r2)
|
||||||
ax_der += a * dx
|
|
||||||
ay_der += a * dy
|
ax_der += e * dx
|
||||||
az_der += a * dz
|
ay_der += e * dy
|
||||||
|
az_der += e * dz
|
||||||
enddo
|
enddo
|
||||||
e = -2.d0 * (-1.d0)**dble(phase) * dexp(-a_expo)
|
|
||||||
|
|
||||||
fact_x += e * ax_der
|
v_1b_grad(1,ipoint) = 2.d0 * ax_der
|
||||||
fact_y += e * ay_der
|
v_1b_grad(2,ipoint) = 2.d0 * ay_der
|
||||||
fact_z += e * az_der
|
v_1b_grad(3,ipoint) = 2.d0 * az_der
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
v_1b_grad(1,ipoint) = fact_x
|
else
|
||||||
v_1b_grad(2,ipoint) = fact_y
|
|
||||||
v_1b_grad(3,ipoint) = fact_z
|
print*, 'j1b_type = ', j1b_type, 'is not implemented'
|
||||||
enddo
|
stop
|
||||||
|
|
||||||
|
endif
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
@ -91,7 +172,7 @@ BEGIN_PROVIDER [ double precision, v_1b_lapl, (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, b
|
double precision :: a, e, b
|
||||||
double precision :: fact_r
|
double precision :: fact_r
|
||||||
double precision :: ax_der, ay_der, az_der, a_expo
|
double precision :: ax_der, ay_der, az_der, a_expo
|
||||||
|
|
||||||
@ -204,36 +285,53 @@ END_PROVIDER
|
|||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
|
||||||
double precision function jmu_modif(r1, r2)
|
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
|
||||||
double precision, intent(in) :: r1(3), r2(3)
|
integer :: ipoint, i
|
||||||
double precision, external :: j12_mu, j12_nucl
|
double precision :: x, y, z, dx, dy, dz, r2
|
||||||
|
double precision :: coef, expo, a_expo, tmp
|
||||||
|
double precision :: fact_x, fact_y, fact_z, fact_r
|
||||||
|
|
||||||
jmu_modif = j12_mu(r1, r2) * j12_nucl(r1, r2)
|
PROVIDE List_all_comb_b3_coef List_all_comb_b3_expo List_all_comb_b3_cent
|
||||||
|
|
||||||
return
|
do ipoint = 1, n_points_final_grid
|
||||||
end function jmu_modif
|
|
||||||
|
|
||||||
! ---
|
x = final_grid_points(1,ipoint)
|
||||||
|
y = final_grid_points(2,ipoint)
|
||||||
|
z = final_grid_points(3,ipoint)
|
||||||
|
|
||||||
double precision function j12_mu(r1, r2)
|
fact_x = 0.d0
|
||||||
|
fact_y = 0.d0
|
||||||
|
fact_z = 0.d0
|
||||||
|
fact_r = 0.d0
|
||||||
|
do i = 1, List_all_comb_b3_size
|
||||||
|
|
||||||
include 'constants.include.F'
|
coef = List_all_comb_b3_coef(i)
|
||||||
|
expo = List_all_comb_b3_expo(i)
|
||||||
|
|
||||||
implicit none
|
dx = x - List_all_comb_b3_cent(1,i)
|
||||||
double precision, intent(in) :: r1(3), r2(3)
|
dy = y - List_all_comb_b3_cent(2,i)
|
||||||
double precision :: mu_r12, r12
|
dz = z - List_all_comb_b3_cent(3,i)
|
||||||
|
r2 = dx * dx + dy * dy + dz * dz
|
||||||
|
|
||||||
r12 = dsqrt( (r1(1) - r2(1)) * (r1(1) - r2(1)) &
|
a_expo = expo * r2
|
||||||
+ (r1(2) - r2(2)) * (r1(2) - r2(2)) &
|
tmp = coef * expo * dexp(-a_expo)
|
||||||
+ (r1(3) - r2(3)) * (r1(3) - r2(3)) )
|
|
||||||
mu_r12 = mu_erf * r12
|
|
||||||
|
|
||||||
j12_mu = 0.5d0 * r12 * (1.d0 - derf(mu_r12)) - inv_sq_pi_2 * dexp(-mu_r12*mu_r12) / mu_erf
|
fact_x += tmp * dx
|
||||||
|
fact_y += tmp * dy
|
||||||
|
fact_z += tmp * dz
|
||||||
|
fact_r += tmp * (3.d0 - 2.d0 * a_expo)
|
||||||
|
enddo
|
||||||
|
|
||||||
return
|
v_1b_square_grad(ipoint,1) = -2.d0 * fact_x
|
||||||
end function j12_mu
|
v_1b_square_grad(ipoint,2) = -2.d0 * fact_y
|
||||||
|
v_1b_square_grad(ipoint,3) = -2.d0 * fact_z
|
||||||
|
v_1b_square_lapl(ipoint) = -2.d0 * fact_r
|
||||||
|
enddo
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
|
||||||
@ -254,6 +352,19 @@ end function j12_mu_r12
|
|||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
|
||||||
|
double precision function jmu_modif(r1, r2)
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
double precision, intent(in) :: r1(3), r2(3)
|
||||||
|
double precision, external :: j12_mu, j12_nucl
|
||||||
|
|
||||||
|
jmu_modif = j12_mu(r1, r2) * j12_nucl(r1, r2)
|
||||||
|
|
||||||
|
return
|
||||||
|
end function jmu_modif
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
double precision function j12_mu_gauss(r1, r2)
|
double precision function j12_mu_gauss(r1, r2)
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
@ -278,30 +389,6 @@ end function j12_mu_gauss
|
|||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
|
||||||
double precision function j1b_nucl(r)
|
|
||||||
|
|
||||||
implicit none
|
|
||||||
double precision, intent(in) :: r(3)
|
|
||||||
integer :: i
|
|
||||||
double precision :: a, d, e
|
|
||||||
|
|
||||||
j1b_nucl = 1.d0
|
|
||||||
|
|
||||||
do i = 1, nucl_num
|
|
||||||
a = j1b_pen(i)
|
|
||||||
d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
|
|
||||||
+ (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
|
|
||||||
+ (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
|
|
||||||
e = 1.d0 - exp(-a*d)
|
|
||||||
|
|
||||||
j1b_nucl = j1b_nucl * e
|
|
||||||
enddo
|
|
||||||
|
|
||||||
return
|
|
||||||
end function j1b_nucl
|
|
||||||
|
|
||||||
! ---
|
|
||||||
|
|
||||||
double precision function j12_nucl(r1, r2)
|
double precision function j12_nucl(r1, r2)
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
@ -317,7 +404,7 @@ end function j12_nucl
|
|||||||
|
|
||||||
! ---------------------------------------------------------------------------------------
|
! ---------------------------------------------------------------------------------------
|
||||||
|
|
||||||
double precision function grad_x_j1b_nucl(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)
|
||||||
@ -333,12 +420,12 @@ double precision function grad_x_j1b_nucl(r)
|
|||||||
r_eps(1) = r_eps(1) - 2.d0 * delta
|
r_eps(1) = r_eps(1) - 2.d0 * delta
|
||||||
fm = j1b_nucl(r_eps)
|
fm = j1b_nucl(r_eps)
|
||||||
|
|
||||||
grad_x_j1b_nucl = 0.5d0 * (fp - fm) / delta
|
grad_x_j1b_nucl_num = 0.5d0 * (fp - fm) / delta
|
||||||
|
|
||||||
return
|
return
|
||||||
end function grad_x_j1b_nucl
|
end function grad_x_j1b_nucl_num
|
||||||
|
|
||||||
double precision function grad_y_j1b_nucl(r)
|
double precision function grad_y_j1b_nucl_num(r)
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
double precision, intent(in) :: r(3)
|
double precision, intent(in) :: r(3)
|
||||||
@ -354,12 +441,12 @@ double precision function grad_y_j1b_nucl(r)
|
|||||||
r_eps(2) = r_eps(2) - 2.d0 * delta
|
r_eps(2) = r_eps(2) - 2.d0 * delta
|
||||||
fm = j1b_nucl(r_eps)
|
fm = j1b_nucl(r_eps)
|
||||||
|
|
||||||
grad_y_j1b_nucl = 0.5d0 * (fp - fm) / delta
|
grad_y_j1b_nucl_num = 0.5d0 * (fp - fm) / delta
|
||||||
|
|
||||||
return
|
return
|
||||||
end function grad_y_j1b_nucl
|
end function grad_y_j1b_nucl_num
|
||||||
|
|
||||||
double precision function grad_z_j1b_nucl(r)
|
double precision function grad_z_j1b_nucl_num(r)
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
double precision, intent(in) :: r(3)
|
double precision, intent(in) :: r(3)
|
||||||
@ -375,10 +462,10 @@ double precision function grad_z_j1b_nucl(r)
|
|||||||
r_eps(3) = r_eps(3) - 2.d0 * delta
|
r_eps(3) = r_eps(3) - 2.d0 * delta
|
||||||
fm = j1b_nucl(r_eps)
|
fm = j1b_nucl(r_eps)
|
||||||
|
|
||||||
grad_z_j1b_nucl = 0.5d0 * (fp - fm) / delta
|
grad_z_j1b_nucl_num = 0.5d0 * (fp - fm) / delta
|
||||||
|
|
||||||
return
|
return
|
||||||
end function grad_z_j1b_nucl
|
end function grad_z_j1b_nucl_num
|
||||||
|
|
||||||
! ---------------------------------------------------------------------------------------
|
! ---------------------------------------------------------------------------------------
|
||||||
|
|
||||||
@ -389,9 +476,9 @@ double precision function lapl_j1b_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
|
double precision, external :: grad_x_j1b_nucl_num
|
||||||
double precision, external :: grad_y_j1b_nucl
|
double precision, external :: grad_y_j1b_nucl_num
|
||||||
double precision, external :: grad_z_j1b_nucl
|
double precision, external :: grad_z_j1b_nucl_num
|
||||||
|
|
||||||
eps = 1d-5
|
eps = 1d-5
|
||||||
r_eps = r
|
r_eps = r
|
||||||
@ -402,9 +489,9 @@ double precision function lapl_j1b_nucl(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 = grad_x_j1b_nucl(r_eps)
|
fp = grad_x_j1b_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(r_eps)
|
fm = grad_x_j1b_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_j1b_nucl += 0.5d0 * (fp - fm) / delta
|
||||||
@ -413,9 +500,9 @@ double precision function lapl_j1b_nucl(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 = grad_y_j1b_nucl(r_eps)
|
fp = grad_y_j1b_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(r_eps)
|
fm = grad_y_j1b_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_j1b_nucl += 0.5d0 * (fp - fm) / delta
|
||||||
@ -424,9 +511,9 @@ double precision function lapl_j1b_nucl(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 = grad_z_j1b_nucl(r_eps)
|
fp = grad_z_j1b_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(r_eps)
|
fm = grad_z_j1b_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_j1b_nucl += 0.5d0 * (fp - fm) / delta
|
||||||
@ -574,35 +661,6 @@ end function grad1_z_j12_mu_num
|
|||||||
|
|
||||||
! ---------------------------------------------------------------------------------------
|
! ---------------------------------------------------------------------------------------
|
||||||
|
|
||||||
! ---
|
|
||||||
|
|
||||||
subroutine grad1_j12_mu_exc(r1, r2, grad)
|
|
||||||
|
|
||||||
implicit none
|
|
||||||
double precision, intent(in) :: r1(3), r2(3)
|
|
||||||
double precision, intent(out) :: grad(3)
|
|
||||||
double precision :: dx, dy, dz, r12, tmp
|
|
||||||
|
|
||||||
grad = 0.d0
|
|
||||||
|
|
||||||
dx = r1(1) - r2(1)
|
|
||||||
dy = r1(2) - r2(2)
|
|
||||||
dz = r1(3) - r2(3)
|
|
||||||
|
|
||||||
r12 = dsqrt( dx * dx + dy * dy + dz * dz )
|
|
||||||
if(r12 .lt. 1d-10) return
|
|
||||||
|
|
||||||
tmp = 0.5d0 * (1.d0 - derf(mu_erf * r12)) / r12
|
|
||||||
|
|
||||||
grad(1) = tmp * dx
|
|
||||||
grad(2) = tmp * dy
|
|
||||||
grad(3) = tmp * dz
|
|
||||||
|
|
||||||
return
|
|
||||||
end subroutine grad1_j12_mu_exc
|
|
||||||
|
|
||||||
! ---
|
|
||||||
|
|
||||||
subroutine grad1_jmu_modif_num(r1, r2, grad)
|
subroutine grad1_jmu_modif_num(r1, r2, grad)
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
@ -614,11 +672,11 @@ subroutine grad1_jmu_modif_num(r1, r2, grad)
|
|||||||
|
|
||||||
double precision, external :: j12_mu
|
double precision, external :: j12_mu
|
||||||
double precision, external :: j1b_nucl
|
double precision, external :: j1b_nucl
|
||||||
double precision, external :: grad_x_j1b_nucl
|
double precision, external :: grad_x_j1b_nucl_num
|
||||||
double precision, external :: grad_y_j1b_nucl
|
double precision, external :: grad_y_j1b_nucl_num
|
||||||
double precision, external :: grad_z_j1b_nucl
|
double precision, external :: grad_z_j1b_nucl_num
|
||||||
|
|
||||||
call grad1_j12_mu_exc(r1, r2, grad_u12)
|
call grad1_j12_mu(r1, r2, grad_u12)
|
||||||
|
|
||||||
tmp0 = j1b_nucl(r1)
|
tmp0 = j1b_nucl(r1)
|
||||||
tmp1 = j1b_nucl(r2)
|
tmp1 = j1b_nucl(r2)
|
||||||
@ -626,9 +684,9 @@ subroutine grad1_jmu_modif_num(r1, r2, grad)
|
|||||||
tmp3 = tmp0 * tmp1
|
tmp3 = tmp0 * tmp1
|
||||||
tmp4 = tmp2 * tmp1
|
tmp4 = tmp2 * tmp1
|
||||||
|
|
||||||
grad(1) = tmp3 * grad_u12(1) + tmp4 * grad_x_j1b_nucl(r1)
|
grad(1) = tmp3 * grad_u12(1) + tmp4 * grad_x_j1b_nucl_num(r1)
|
||||||
grad(2) = tmp3 * grad_u12(2) + tmp4 * grad_y_j1b_nucl(r1)
|
grad(2) = tmp3 * grad_u12(2) + tmp4 * grad_y_j1b_nucl_num(r1)
|
||||||
grad(3) = tmp3 * grad_u12(3) + tmp4 * grad_z_j1b_nucl(r1)
|
grad(3) = tmp3 * grad_u12(3) + tmp4 * grad_z_j1b_nucl_num(r1)
|
||||||
|
|
||||||
return
|
return
|
||||||
end subroutine grad1_jmu_modif_num
|
end subroutine grad1_jmu_modif_num
|
||||||
|
851
src/non_h_ints_mu/jast_deriv.irp.f
Normal file
851
src/non_h_ints_mu/jast_deriv.irp.f
Normal file
@ -0,0 +1,851 @@
|
|||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
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_DOC
|
||||||
|
!
|
||||||
|
! grad_1 u(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
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer :: ipoint, jpoint
|
||||||
|
double precision :: r1(3), r2(3)
|
||||||
|
double precision :: v1b_r1, v1b_r2, u2b_r12
|
||||||
|
double precision :: grad1_v1b(3), grad1_u2b(3)
|
||||||
|
double precision :: dx, dy, dz
|
||||||
|
double precision, external :: j12_mu, j1b_nucl
|
||||||
|
|
||||||
|
PROVIDE j1b_type
|
||||||
|
PROVIDE final_grid_points_extra
|
||||||
|
|
||||||
|
grad1_u12_num = 0.d0
|
||||||
|
grad1_u12_squared_num = 0.d0
|
||||||
|
|
||||||
|
if(j1b_type .eq. 100) then
|
||||||
|
|
||||||
|
!$OMP PARALLEL &
|
||||||
|
!$OMP DEFAULT (NONE) &
|
||||||
|
!$OMP PRIVATE (ipoint, jpoint, r1, r2, v1b_r1, v1b_r2, u2b_r12, grad1_v1b, grad1_u2b, dx, dy, dz) &
|
||||||
|
!$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 DO SCHEDULE (static)
|
||||||
|
do ipoint = 1, n_points_final_grid ! r1
|
||||||
|
|
||||||
|
r1(1) = final_grid_points(1,ipoint)
|
||||||
|
r1(2) = final_grid_points(2,ipoint)
|
||||||
|
r1(3) = final_grid_points(3,ipoint)
|
||||||
|
|
||||||
|
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)
|
||||||
|
|
||||||
|
call grad1_j12_mu(r1, r2, grad1_u2b)
|
||||||
|
|
||||||
|
dx = grad1_u2b(1)
|
||||||
|
dy = grad1_u2b(2)
|
||||||
|
dz = grad1_u2b(3)
|
||||||
|
|
||||||
|
grad1_u12_num(jpoint,ipoint,1) = dx
|
||||||
|
grad1_u12_num(jpoint,ipoint,2) = dy
|
||||||
|
grad1_u12_num(jpoint,ipoint,3) = dz
|
||||||
|
|
||||||
|
grad1_u12_squared_num(jpoint,ipoint) = dx*dx + dy*dy + dz*dz
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
!$OMP END DO
|
||||||
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
|
elseif((j1b_type .gt. 100) .and. (j1b_type .lt. 200)) then
|
||||||
|
|
||||||
|
!$OMP PARALLEL &
|
||||||
|
!$OMP DEFAULT (NONE) &
|
||||||
|
!$OMP PRIVATE (ipoint, jpoint, r1, r2, v1b_r1, v1b_r2, u2b_r12, grad1_v1b, grad1_u2b, dx, dy, dz) &
|
||||||
|
!$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 DO SCHEDULE (static)
|
||||||
|
do ipoint = 1, n_points_final_grid ! r1
|
||||||
|
|
||||||
|
r1(1) = final_grid_points(1,ipoint)
|
||||||
|
r1(2) = final_grid_points(2,ipoint)
|
||||||
|
r1(3) = final_grid_points(3,ipoint)
|
||||||
|
|
||||||
|
v1b_r1 = j1b_nucl(r1)
|
||||||
|
call grad1_j1b_nucl(r1, grad1_v1b)
|
||||||
|
|
||||||
|
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)
|
||||||
|
|
||||||
|
v1b_r2 = j1b_nucl(r2)
|
||||||
|
u2b_r12 = j12_mu(r1, r2)
|
||||||
|
call grad1_j12_mu(r1, r2, grad1_u2b)
|
||||||
|
|
||||||
|
dx = (grad1_u2b(1) * v1b_r1 + u2b_r12 * grad1_v1b(1)) * v1b_r2
|
||||||
|
dy = (grad1_u2b(2) * v1b_r1 + u2b_r12 * grad1_v1b(2)) * v1b_r2
|
||||||
|
dz = (grad1_u2b(3) * v1b_r1 + u2b_r12 * grad1_v1b(3)) * v1b_r2
|
||||||
|
|
||||||
|
grad1_u12_num(jpoint,ipoint,1) = dx
|
||||||
|
grad1_u12_num(jpoint,ipoint,2) = dy
|
||||||
|
grad1_u12_num(jpoint,ipoint,3) = dz
|
||||||
|
|
||||||
|
grad1_u12_squared_num(jpoint,ipoint) = dx*dx + dy*dy + dz*dz
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
!$OMP END DO
|
||||||
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
|
elseif((j1b_type .ge. 200) .and. (j1b_type .lt. 300)) then
|
||||||
|
|
||||||
|
!$OMP PARALLEL &
|
||||||
|
!$OMP DEFAULT (NONE) &
|
||||||
|
!$OMP PRIVATE (ipoint, jpoint, r1, r2, grad1_u2b, dx, dy, dz) &
|
||||||
|
!$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 DO SCHEDULE (static)
|
||||||
|
do ipoint = 1, n_points_final_grid ! r1
|
||||||
|
|
||||||
|
r1(1) = final_grid_points(1,ipoint)
|
||||||
|
r1(2) = final_grid_points(2,ipoint)
|
||||||
|
r1(3) = final_grid_points(3,ipoint)
|
||||||
|
|
||||||
|
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)
|
||||||
|
|
||||||
|
call grad1_j12_mu(r1, r2, grad1_u2b)
|
||||||
|
|
||||||
|
dx = grad1_u2b(1)
|
||||||
|
dy = grad1_u2b(2)
|
||||||
|
dz = grad1_u2b(3)
|
||||||
|
|
||||||
|
grad1_u12_num(jpoint,ipoint,1) = dx
|
||||||
|
grad1_u12_num(jpoint,ipoint,2) = dy
|
||||||
|
grad1_u12_num(jpoint,ipoint,3) = dz
|
||||||
|
|
||||||
|
grad1_u12_squared_num(jpoint,ipoint) = dx*dx + dy*dy + dz*dz
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
!$OMP END DO
|
||||||
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
|
else
|
||||||
|
|
||||||
|
print *, ' j1b_type = ', j1b_type, 'not implemented yet'
|
||||||
|
stop
|
||||||
|
|
||||||
|
endif
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
double precision function j12_mu(r1, r2)
|
||||||
|
|
||||||
|
include 'constants.include.F'
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
double precision, intent(in) :: r1(3), r2(3)
|
||||||
|
double precision :: mu_tmp, r12
|
||||||
|
|
||||||
|
if((j1b_type .ge. 0) .and. (j1b_type .lt. 200)) then
|
||||||
|
|
||||||
|
r12 = dsqrt( (r1(1) - r2(1)) * (r1(1) - r2(1)) &
|
||||||
|
+ (r1(2) - r2(2)) * (r1(2) - r2(2)) &
|
||||||
|
+ (r1(3) - r2(3)) * (r1(3) - r2(3)) )
|
||||||
|
mu_tmp = mu_erf * r12
|
||||||
|
|
||||||
|
j12_mu = 0.5d0 * r12 * (1.d0 - derf(mu_tmp)) - inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / mu_erf
|
||||||
|
|
||||||
|
else
|
||||||
|
|
||||||
|
print *, ' j1b_type = ', j1b_type, 'not implemented for j12_mu'
|
||||||
|
stop
|
||||||
|
|
||||||
|
endif
|
||||||
|
|
||||||
|
return
|
||||||
|
end function j12_mu
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
subroutine grad1_j12_mu(r1, r2, grad)
|
||||||
|
|
||||||
|
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
|
||||||
|
include 'constants.include.F'
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
double precision, intent(in) :: r1(3), r2(3)
|
||||||
|
double precision, intent(out) :: grad(3)
|
||||||
|
double precision :: dx, dy, dz, r12, tmp
|
||||||
|
|
||||||
|
grad = 0.d0
|
||||||
|
|
||||||
|
if((j1b_type .ge. 0) .and. (j1b_type .lt. 200)) then
|
||||||
|
|
||||||
|
dx = r1(1) - r2(1)
|
||||||
|
dy = r1(2) - r2(2)
|
||||||
|
dz = r1(3) - r2(3)
|
||||||
|
|
||||||
|
r12 = dsqrt(dx * dx + dy * dy + dz * dz)
|
||||||
|
if(r12 .lt. 1d-10) return
|
||||||
|
|
||||||
|
tmp = 0.5d0 * (1.d0 - derf(mu_erf * r12)) / r12
|
||||||
|
|
||||||
|
grad(1) = tmp * dx
|
||||||
|
grad(2) = tmp * dy
|
||||||
|
grad(3) = tmp * dz
|
||||||
|
|
||||||
|
elseif((j1b_type .ge. 200) .and. (j1b_type .lt. 300)) then
|
||||||
|
|
||||||
|
double precision :: mu_val, mu_tmp, mu_der(3)
|
||||||
|
|
||||||
|
dx = r1(1) - r2(1)
|
||||||
|
dy = r1(2) - r2(2)
|
||||||
|
dz = r1(3) - r2(3)
|
||||||
|
r12 = dsqrt(dx * dx + dy * dy + dz * dz)
|
||||||
|
|
||||||
|
call mu_r_val_and_grad(r1, r2, mu_val, mu_der)
|
||||||
|
mu_tmp = mu_val * r12
|
||||||
|
tmp = inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / (mu_val * mu_val)
|
||||||
|
grad(1) = tmp * mu_der(1)
|
||||||
|
grad(2) = tmp * mu_der(2)
|
||||||
|
grad(3) = tmp * mu_der(3)
|
||||||
|
|
||||||
|
if(r12 .lt. 1d-10) return
|
||||||
|
tmp = 0.5d0 * (1.d0 - derf(mu_tmp)) / r12
|
||||||
|
grad(1) = grad(1) + tmp * dx
|
||||||
|
grad(2) = grad(2) + tmp * dy
|
||||||
|
grad(3) = grad(3) + tmp * dz
|
||||||
|
|
||||||
|
else
|
||||||
|
|
||||||
|
print *, ' j1b_type = ', j1b_type, 'not implemented yet'
|
||||||
|
stop
|
||||||
|
|
||||||
|
endif
|
||||||
|
|
||||||
|
return
|
||||||
|
end subroutine grad1_j12_mu
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
double precision function j1b_nucl(r)
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
double precision, intent(in) :: r(3)
|
||||||
|
integer :: i
|
||||||
|
double precision :: a, d, e, x, y, z
|
||||||
|
|
||||||
|
if((j1b_type .eq. 2) .or. (j1b_type .eq. 102)) then
|
||||||
|
|
||||||
|
j1b_nucl = 1.d0
|
||||||
|
do i = 1, nucl_num
|
||||||
|
a = j1b_pen(i)
|
||||||
|
d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
|
||||||
|
+ (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
|
||||||
|
+ (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
|
||||||
|
j1b_nucl = j1b_nucl - dexp(-a*dsqrt(d))
|
||||||
|
enddo
|
||||||
|
|
||||||
|
elseif((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then
|
||||||
|
|
||||||
|
j1b_nucl = 1.d0
|
||||||
|
do i = 1, nucl_num
|
||||||
|
a = j1b_pen(i)
|
||||||
|
d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
|
||||||
|
+ (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
|
||||||
|
+ (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
|
||||||
|
e = 1.d0 - dexp(-a*d)
|
||||||
|
j1b_nucl = j1b_nucl * e
|
||||||
|
enddo
|
||||||
|
|
||||||
|
elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then
|
||||||
|
|
||||||
|
j1b_nucl = 1.d0
|
||||||
|
do i = 1, nucl_num
|
||||||
|
a = j1b_pen(i)
|
||||||
|
d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
|
||||||
|
+ (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
|
||||||
|
+ (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
|
||||||
|
j1b_nucl = j1b_nucl - dexp(-a*d)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
elseif((j1b_type .eq. 5) .or. (j1b_type .eq. 105)) then
|
||||||
|
|
||||||
|
j1b_nucl = 1.d0
|
||||||
|
do i = 1, nucl_num
|
||||||
|
a = j1b_pen(i)
|
||||||
|
x = r(1) - nucl_coord(i,1)
|
||||||
|
y = r(2) - nucl_coord(i,2)
|
||||||
|
z = r(3) - nucl_coord(i,3)
|
||||||
|
d = x*x + y*y + z*z
|
||||||
|
j1b_nucl = j1b_nucl - dexp(-a*d*d)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
else
|
||||||
|
|
||||||
|
print *, ' j1b_type = ', j1b_type, 'not implemented for j1b_nucl'
|
||||||
|
stop
|
||||||
|
|
||||||
|
endif
|
||||||
|
|
||||||
|
return
|
||||||
|
end function j1b_nucl
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
double precision function j1b_nucl_square(r)
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
double precision, intent(in) :: r(3)
|
||||||
|
integer :: i
|
||||||
|
double precision :: a, d, e, x, y, z
|
||||||
|
|
||||||
|
if((j1b_type .eq. 2) .or. (j1b_type .eq. 102)) then
|
||||||
|
|
||||||
|
j1b_nucl_square = 1.d0
|
||||||
|
do i = 1, nucl_num
|
||||||
|
a = j1b_pen(i)
|
||||||
|
d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
|
||||||
|
+ (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
|
||||||
|
+ (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
|
||||||
|
j1b_nucl_square = j1b_nucl_square - dexp(-a*dsqrt(d))
|
||||||
|
enddo
|
||||||
|
j1b_nucl_square = j1b_nucl_square * j1b_nucl_square
|
||||||
|
|
||||||
|
elseif((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then
|
||||||
|
|
||||||
|
j1b_nucl_square = 1.d0
|
||||||
|
do i = 1, nucl_num
|
||||||
|
a = j1b_pen(i)
|
||||||
|
d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
|
||||||
|
+ (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
|
||||||
|
+ (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
|
||||||
|
e = 1.d0 - dexp(-a*d)
|
||||||
|
j1b_nucl_square = j1b_nucl_square * e
|
||||||
|
enddo
|
||||||
|
j1b_nucl_square = j1b_nucl_square * j1b_nucl_square
|
||||||
|
|
||||||
|
elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then
|
||||||
|
|
||||||
|
j1b_nucl_square = 1.d0
|
||||||
|
do i = 1, nucl_num
|
||||||
|
a = j1b_pen(i)
|
||||||
|
d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
|
||||||
|
+ (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
|
||||||
|
+ (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
|
||||||
|
j1b_nucl_square = j1b_nucl_square - dexp(-a*d)
|
||||||
|
enddo
|
||||||
|
j1b_nucl_square = j1b_nucl_square * j1b_nucl_square
|
||||||
|
|
||||||
|
elseif((j1b_type .eq. 5) .or. (j1b_type .eq. 105)) then
|
||||||
|
|
||||||
|
j1b_nucl_square = 1.d0
|
||||||
|
do i = 1, nucl_num
|
||||||
|
a = j1b_pen(i)
|
||||||
|
x = r(1) - nucl_coord(i,1)
|
||||||
|
y = r(2) - nucl_coord(i,2)
|
||||||
|
z = r(3) - nucl_coord(i,3)
|
||||||
|
d = x*x + y*y + z*z
|
||||||
|
j1b_nucl_square = j1b_nucl_square - dexp(-a*d*d)
|
||||||
|
enddo
|
||||||
|
j1b_nucl_square = j1b_nucl_square * j1b_nucl_square
|
||||||
|
|
||||||
|
else
|
||||||
|
|
||||||
|
print *, ' j1b_type = ', j1b_type, 'not implemented for j1b_nucl_square'
|
||||||
|
stop
|
||||||
|
|
||||||
|
endif
|
||||||
|
|
||||||
|
return
|
||||||
|
end function j1b_nucl_square
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
subroutine grad1_j1b_nucl(r, grad)
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
double precision, intent(in) :: r(3)
|
||||||
|
double precision, intent(out) :: grad(3)
|
||||||
|
integer :: ipoint, i, j, phase
|
||||||
|
double precision :: x, y, z, dx, dy, dz
|
||||||
|
double precision :: a, d, e
|
||||||
|
double precision :: fact_x, fact_y, fact_z
|
||||||
|
double precision :: ax_der, ay_der, az_der, a_expo
|
||||||
|
|
||||||
|
if((j1b_type .eq. 2) .or. (j1b_type .eq. 102)) then
|
||||||
|
|
||||||
|
fact_x = 0.d0
|
||||||
|
fact_y = 0.d0
|
||||||
|
fact_z = 0.d0
|
||||||
|
do i = 1, nucl_num
|
||||||
|
a = j1b_pen(i)
|
||||||
|
x = r(1) - nucl_coord(i,1)
|
||||||
|
y = r(2) - nucl_coord(i,2)
|
||||||
|
z = r(3) - nucl_coord(i,3)
|
||||||
|
d = dsqrt(x*x + y*y + z*z)
|
||||||
|
e = a * dexp(-a*d) / d
|
||||||
|
|
||||||
|
fact_x += e * x
|
||||||
|
fact_y += e * y
|
||||||
|
fact_z += e * z
|
||||||
|
enddo
|
||||||
|
|
||||||
|
grad(1) = fact_x
|
||||||
|
grad(2) = fact_y
|
||||||
|
grad(3) = fact_z
|
||||||
|
|
||||||
|
elseif((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then
|
||||||
|
|
||||||
|
x = r(1)
|
||||||
|
y = r(2)
|
||||||
|
z = r(3)
|
||||||
|
|
||||||
|
fact_x = 0.d0
|
||||||
|
fact_y = 0.d0
|
||||||
|
fact_z = 0.d0
|
||||||
|
do i = 1, List_all_comb_b2_size
|
||||||
|
|
||||||
|
phase = 0
|
||||||
|
a_expo = 0.d0
|
||||||
|
ax_der = 0.d0
|
||||||
|
ay_der = 0.d0
|
||||||
|
az_der = 0.d0
|
||||||
|
do j = 1, nucl_num
|
||||||
|
a = dble(List_all_comb_b2(j,i)) * j1b_pen(j)
|
||||||
|
dx = x - nucl_coord(j,1)
|
||||||
|
dy = y - nucl_coord(j,2)
|
||||||
|
dz = z - nucl_coord(j,3)
|
||||||
|
|
||||||
|
phase += List_all_comb_b2(j,i)
|
||||||
|
a_expo += a * (dx*dx + dy*dy + dz*dz)
|
||||||
|
ax_der += a * dx
|
||||||
|
ay_der += a * dy
|
||||||
|
az_der += a * dz
|
||||||
|
enddo
|
||||||
|
e = -2.d0 * (-1.d0)**dble(phase) * dexp(-a_expo)
|
||||||
|
|
||||||
|
fact_x += e * ax_der
|
||||||
|
fact_y += e * ay_der
|
||||||
|
fact_z += e * az_der
|
||||||
|
enddo
|
||||||
|
|
||||||
|
grad(1) = fact_x
|
||||||
|
grad(2) = fact_y
|
||||||
|
grad(3) = fact_z
|
||||||
|
|
||||||
|
elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then
|
||||||
|
|
||||||
|
fact_x = 0.d0
|
||||||
|
fact_y = 0.d0
|
||||||
|
fact_z = 0.d0
|
||||||
|
do i = 1, nucl_num
|
||||||
|
a = j1b_pen(i)
|
||||||
|
x = r(1) - nucl_coord(i,1)
|
||||||
|
y = r(2) - nucl_coord(i,2)
|
||||||
|
z = r(3) - nucl_coord(i,3)
|
||||||
|
d = x*x + y*y + z*z
|
||||||
|
e = a * dexp(-a*d)
|
||||||
|
|
||||||
|
fact_x += e * x
|
||||||
|
fact_y += e * y
|
||||||
|
fact_z += e * z
|
||||||
|
enddo
|
||||||
|
|
||||||
|
grad(1) = 2.d0 * fact_x
|
||||||
|
grad(2) = 2.d0 * fact_y
|
||||||
|
grad(3) = 2.d0 * fact_z
|
||||||
|
|
||||||
|
elseif((j1b_type .eq. 5) .or. (j1b_type .eq. 105)) then
|
||||||
|
|
||||||
|
fact_x = 0.d0
|
||||||
|
fact_y = 0.d0
|
||||||
|
fact_z = 0.d0
|
||||||
|
do i = 1, nucl_num
|
||||||
|
a = j1b_pen(i)
|
||||||
|
x = r(1) - nucl_coord(i,1)
|
||||||
|
y = r(2) - nucl_coord(i,2)
|
||||||
|
z = r(3) - nucl_coord(i,3)
|
||||||
|
d = x*x + y*y + z*z
|
||||||
|
e = a * d * dexp(-a*d*d)
|
||||||
|
|
||||||
|
fact_x += e * x
|
||||||
|
fact_y += e * y
|
||||||
|
fact_z += e * z
|
||||||
|
enddo
|
||||||
|
|
||||||
|
grad(1) = 4.d0 * fact_x
|
||||||
|
grad(2) = 4.d0 * fact_y
|
||||||
|
grad(3) = 4.d0 * fact_z
|
||||||
|
|
||||||
|
else
|
||||||
|
|
||||||
|
print *, ' j1b_type = ', j1b_type, 'not implemented for grad1_j1b_nucl'
|
||||||
|
stop
|
||||||
|
|
||||||
|
endif
|
||||||
|
|
||||||
|
return
|
||||||
|
end subroutine grad1_j1b_nucl
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
subroutine mu_r_val_and_grad(r1, r2, mu_val, mu_der)
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
double precision, intent(in) :: r1(3), r2(3)
|
||||||
|
double precision, intent(out) :: mu_val, mu_der(3)
|
||||||
|
double precision :: r(3)
|
||||||
|
double precision :: dm_a(1), dm_b(1), grad_dm_a(3,1), grad_dm_b(3,1)
|
||||||
|
double precision :: dm_tot, tmp1, tmp2, tmp3
|
||||||
|
double precision :: rho1, grad_rho1(3),rho2,rho_tot,inv_rho_tot
|
||||||
|
double precision :: f_rho1, f_rho2, d_drho_f_rho1
|
||||||
|
double precision :: d_dx1_f_rho1(3),d_dx_rho_f_rho(3),nume
|
||||||
|
|
||||||
|
if(j1b_type .eq. 200) then
|
||||||
|
|
||||||
|
!
|
||||||
|
! r = 0.5 (r1 + r2)
|
||||||
|
!
|
||||||
|
! mu[rho(r)] = alpha sqrt(rho) + mu0 exp(-rho)
|
||||||
|
!
|
||||||
|
! d mu[rho(r)] / dx1 = 0.5 d mu[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(2) = 0.5d0 * (r1(2) + r2(2))
|
||||||
|
r(3) = 0.5d0 * (r1(3) + r2(3))
|
||||||
|
|
||||||
|
call density_and_grad_alpha_beta(r, dm_a, dm_b, grad_dm_a, grad_dm_b)
|
||||||
|
|
||||||
|
dm_tot = dm_a(1) + dm_b(1)
|
||||||
|
tmp1 = dsqrt(dm_tot)
|
||||||
|
tmp2 = mu_erf * dexp(-dm_tot)
|
||||||
|
|
||||||
|
mu_val = mu_r_ct * tmp1 + tmp2
|
||||||
|
|
||||||
|
mu_der = 0.d0
|
||||||
|
if(dm_tot .lt. 1d-7) return
|
||||||
|
|
||||||
|
tmp3 = 0.25d0 * mu_r_ct / tmp1 - 0.5d0 * tmp2
|
||||||
|
mu_der(1) = tmp3 * (grad_dm_a(1,1) + grad_dm_b(1,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))
|
||||||
|
|
||||||
|
elseif(j1b_type .eq. 201) then
|
||||||
|
|
||||||
|
!
|
||||||
|
! r = 0.5 (r1 + r2)
|
||||||
|
!
|
||||||
|
! mu[rho(r)] = alpha rho + mu0 exp(-rho)
|
||||||
|
!
|
||||||
|
! d mu[rho(r)] / dx1 = 0.5 d mu[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(2) = 0.5d0 * (r1(2) + r2(2))
|
||||||
|
r(3) = 0.5d0 * (r1(3) + r2(3))
|
||||||
|
|
||||||
|
call density_and_grad_alpha_beta(r, dm_a, dm_b, grad_dm_a, grad_dm_b)
|
||||||
|
|
||||||
|
dm_tot = dm_a(1) + dm_b(1)
|
||||||
|
tmp2 = mu_erf * dexp(-dm_tot)
|
||||||
|
|
||||||
|
mu_val = mu_r_ct * dm_tot + tmp2
|
||||||
|
|
||||||
|
tmp3 = 0.5d0 * (mu_r_ct - tmp2)
|
||||||
|
mu_der(1) = tmp3 * (grad_dm_a(1,1) + grad_dm_b(1,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))
|
||||||
|
|
||||||
|
elseif(j1b_type .eq. 202) then
|
||||||
|
|
||||||
|
! mu(r1,r2) = {rho(r1) f[rho(r1)] + rho(r2) f[rho(r2)]} / RHO
|
||||||
|
!
|
||||||
|
! RHO = rho(r1) + rho(r2)
|
||||||
|
!
|
||||||
|
! f[rho] = alpha rho^beta + mu0 exp(-rho)
|
||||||
|
!
|
||||||
|
! d/dx1 mu(r1,r2) = 1/RHO^2 * {RHO * d/dx1 (rho(r1) f[rho(r1)])
|
||||||
|
! - d/dx1 rho(r1) * [rho(r1) f[rho(r1)] + rho(r2) f[rho(r2)]] }
|
||||||
|
!
|
||||||
|
! d/dx1 f[rho(r1)] = [0.5 alpha / sqrt(rho(r1)) - mu0 exp(-rho(r1))] (d rho(r1) / dx1)
|
||||||
|
!
|
||||||
|
! d/dx1 (rho(r1) f[rho(r1)] = rho(r1) * d/dx1 f[rho(r1)] + f[rho(r1)] * d/dx1 rho(r1)
|
||||||
|
|
||||||
|
!!!!!!!!! rho1,rho2,rho1+rho2
|
||||||
|
call get_all_rho_grad_rho(r1,r2,rho1,rho2,grad_rho1)
|
||||||
|
rho_tot = rho1 + rho2
|
||||||
|
if(rho_tot.lt.1.d-10)rho_tot = 1.d-10
|
||||||
|
inv_rho_tot = 1.d0/rho_tot
|
||||||
|
! f(rho) = mu_r_ct * rho**beta_rho_power + mu_erf * exp(-rho)
|
||||||
|
call get_all_f_rho(rho1,rho2,mu_r_ct,mu_erf,beta_rho_power,f_rho1,d_drho_f_rho1,f_rho2)
|
||||||
|
d_dx1_f_rho1(1:3) = d_drho_f_rho1 * grad_rho1(1:3)
|
||||||
|
d_dx_rho_f_rho(1:3) = rho1 * d_dx1_f_rho1(1:3) + f_rho1 * grad_rho1(1:3)
|
||||||
|
nume = rho1 * f_rho1 + rho2 * f_rho2
|
||||||
|
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)
|
||||||
|
elseif(j1b_type .eq. 203) then
|
||||||
|
|
||||||
|
! mu(r1,r2) = {rho(r1) f[rho(r1)] + rho(r2) f[rho(r2)]} / RHO
|
||||||
|
!
|
||||||
|
! RHO = rho(r1) + rho(r2)
|
||||||
|
!
|
||||||
|
! f[rho] = alpha rho^beta + mu0
|
||||||
|
!
|
||||||
|
! d/dx1 mu(r1,r2) = 1/RHO^2 * {RHO * d/dx1 (rho(r1) f[rho(r1)])
|
||||||
|
! - d/dx1 rho(r1) * [rho(r1) f[rho(r1)] + rho(r2) f[rho(r2)]] }
|
||||||
|
!
|
||||||
|
! d/dx1 f[rho(r1)] = [0.5 alpha / sqrt(rho(r1)) ] (d rho(r1) / dx1)
|
||||||
|
!
|
||||||
|
! d/dx1 (rho(r1) f[rho(r1)] = rho(r1) * d/dx1 f[rho(r1)] + f[rho(r1)] * d/dx1 rho(r1)
|
||||||
|
|
||||||
|
!!!!!!!!! rho1,rho2,rho1+rho2
|
||||||
|
call get_all_rho_grad_rho(r1,r2,rho1,rho2,grad_rho1)
|
||||||
|
rho_tot = rho1 + rho2
|
||||||
|
if(rho_tot.lt.1.d-10)rho_tot = 1.d-10
|
||||||
|
inv_rho_tot = 1.d0/rho_tot
|
||||||
|
! f(rho) = mu_r_ct * rho**beta_rho_power + mu_erf
|
||||||
|
call get_all_f_rho_simple(rho1,rho2,mu_r_ct,mu_erf,beta_rho_power,f_rho1,d_drho_f_rho1,f_rho2)
|
||||||
|
d_dx1_f_rho1(1:3) = d_drho_f_rho1 * grad_rho1(1:3)
|
||||||
|
d_dx_rho_f_rho(1:3) = rho1 * d_dx1_f_rho1(1:3) + f_rho1 * grad_rho1(1:3)
|
||||||
|
nume = rho1 * f_rho1 + rho2 * f_rho2
|
||||||
|
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)
|
||||||
|
elseif(j1b_type .eq. 204) then
|
||||||
|
|
||||||
|
! mu(r1,r2) = 1/2 * (f[rho(r1)] + f[rho(r2)]}
|
||||||
|
!
|
||||||
|
! f[rho] = alpha rho^beta + mu0
|
||||||
|
!
|
||||||
|
! d/dx1 mu(r1,r2) = 1/2 * d/dx1 (rho(r1) f[rho(r1)])
|
||||||
|
!
|
||||||
|
! d/dx1 f[rho(r1)] = [0.5 alpha / sqrt(rho(r1)) ] (d rho(r1) / dx1)
|
||||||
|
!
|
||||||
|
! d/dx1 (rho(r1) f[rho(r1)] = rho(r1) * d/dx1 f[rho(r1)] + f[rho(r1)] * d/dx1 rho(r1)
|
||||||
|
|
||||||
|
!!!!!!!!! rho1,rho2,rho1+rho2
|
||||||
|
call get_all_rho_grad_rho(r1,r2,rho1,rho2,grad_rho1)
|
||||||
|
rho_tot = rho1 + rho2
|
||||||
|
if(rho_tot.lt.1.d-10)rho_tot = 1.d-10
|
||||||
|
inv_rho_tot = 1.d0/rho_tot
|
||||||
|
! f(rho) = mu_r_ct * rho**beta_rho_power + mu_erf
|
||||||
|
call get_all_f_rho_simple(rho1,rho2,mu_r_ct,mu_erf,beta_rho_power,f_rho1,d_drho_f_rho1,f_rho2)
|
||||||
|
d_dx1_f_rho1(1:3) = d_drho_f_rho1 * grad_rho1(1:3)
|
||||||
|
d_dx_rho_f_rho(1:3) = rho1 * d_dx1_f_rho1(1:3) + f_rho1 * grad_rho1(1:3)
|
||||||
|
mu_val = 0.5d0 * ( f_rho1 + f_rho2)
|
||||||
|
mu_der(1:3) = d_dx_rho_f_rho(1:3)
|
||||||
|
else
|
||||||
|
print *, ' j1b_type = ', j1b_type, 'not implemented yet'
|
||||||
|
stop
|
||||||
|
|
||||||
|
endif
|
||||||
|
|
||||||
|
return
|
||||||
|
end subroutine mu_r_val_and_grad
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
subroutine grad1_j1b_nucl_square_num(r1, grad)
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
double precision, intent(in) :: r1(3)
|
||||||
|
double precision, intent(out) :: grad(3)
|
||||||
|
double precision :: r(3), eps, tmp_eps, vp, vm
|
||||||
|
double precision, external :: j1b_nucl_square
|
||||||
|
|
||||||
|
eps = 1d-5
|
||||||
|
tmp_eps = 0.5d0 / eps
|
||||||
|
|
||||||
|
r(1:3) = r1(1:3)
|
||||||
|
|
||||||
|
r(1) = r(1) + eps
|
||||||
|
vp = j1b_nucl_square(r)
|
||||||
|
r(1) = r(1) - 2.d0 * eps
|
||||||
|
vm = j1b_nucl_square(r)
|
||||||
|
r(1) = r(1) + eps
|
||||||
|
grad(1) = tmp_eps * (vp - vm)
|
||||||
|
|
||||||
|
r(2) = r(2) + eps
|
||||||
|
vp = j1b_nucl_square(r)
|
||||||
|
r(2) = r(2) - 2.d0 * eps
|
||||||
|
vm = j1b_nucl_square(r)
|
||||||
|
r(2) = r(2) + eps
|
||||||
|
grad(2) = tmp_eps * (vp - vm)
|
||||||
|
|
||||||
|
r(3) = r(3) + eps
|
||||||
|
vp = j1b_nucl_square(r)
|
||||||
|
r(3) = r(3) - 2.d0 * eps
|
||||||
|
vm = j1b_nucl_square(r)
|
||||||
|
r(3) = r(3) + eps
|
||||||
|
grad(3) = tmp_eps * (vp - vm)
|
||||||
|
|
||||||
|
return
|
||||||
|
end subroutine grad1_j1b_nucl_square_num
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
subroutine grad1_j12_mu_square_num(r1, r2, grad)
|
||||||
|
|
||||||
|
include 'constants.include.F'
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
double precision, intent(in) :: r1(3), r2(3)
|
||||||
|
double precision, intent(out) :: grad(3)
|
||||||
|
double precision :: r(3)
|
||||||
|
double precision :: eps, tmp_eps, vp, vm
|
||||||
|
double precision, external :: j12_mu_square
|
||||||
|
|
||||||
|
eps = 1d-5
|
||||||
|
tmp_eps = 0.5d0 / eps
|
||||||
|
|
||||||
|
r(1:3) = r1(1:3)
|
||||||
|
|
||||||
|
r(1) = r(1) + eps
|
||||||
|
vp = j12_mu_square(r, r2)
|
||||||
|
r(1) = r(1) - 2.d0 * eps
|
||||||
|
vm = j12_mu_square(r, r2)
|
||||||
|
r(1) = r(1) + eps
|
||||||
|
grad(1) = tmp_eps * (vp - vm)
|
||||||
|
|
||||||
|
r(2) = r(2) + eps
|
||||||
|
vp = j12_mu_square(r, r2)
|
||||||
|
r(2) = r(2) - 2.d0 * eps
|
||||||
|
vm = j12_mu_square(r, r2)
|
||||||
|
r(2) = r(2) + eps
|
||||||
|
grad(2) = tmp_eps * (vp - vm)
|
||||||
|
|
||||||
|
r(3) = r(3) + eps
|
||||||
|
vp = j12_mu_square(r, r2)
|
||||||
|
r(3) = r(3) - 2.d0 * eps
|
||||||
|
vm = j12_mu_square(r, r2)
|
||||||
|
r(3) = r(3) + eps
|
||||||
|
grad(3) = tmp_eps * (vp - vm)
|
||||||
|
|
||||||
|
return
|
||||||
|
end subroutine grad1_j12_mu_square_num
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
double precision function j12_mu_square(r1, r2)
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
double precision, intent(in) :: r1(3), r2(3)
|
||||||
|
double precision, external :: j12_mu
|
||||||
|
|
||||||
|
j12_mu_square = j12_mu(r1, r2) * j12_mu(r1, r2)
|
||||||
|
|
||||||
|
return
|
||||||
|
end function j12_mu_square
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
subroutine f_mu_and_deriv_mu(rho,alpha,mu0,beta,f_mu,d_drho_f_mu)
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! function giving mu as a function of rho
|
||||||
|
!
|
||||||
|
! f_mu = alpha * rho**beta + mu0 * exp(-rho)
|
||||||
|
!
|
||||||
|
! and its derivative with respect to rho d_drho_f_mu
|
||||||
|
END_DOC
|
||||||
|
double precision, intent(in) :: rho,alpha,mu0,beta
|
||||||
|
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
|
||||||
|
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
subroutine get_all_f_rho(rho1,rho2,alpha,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))
|
||||||
|
END_DOC
|
||||||
|
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
|
||||||
|
|
||||||
|
|
||||||
|
subroutine get_all_f_rho_simple(rho1,rho2,alpha,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))
|
||||||
|
END_DOC
|
||||||
|
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_simple(rho1,alpha,mu0,beta,f_rho1,d_drho_f_rho1)
|
||||||
|
call f_mu_and_deriv_mu_simple(rho2,alpha,mu0,beta,f_rho2,tmp)
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine f_mu_and_deriv_mu_simple(rho,alpha,mu0,beta,f_mu,d_drho_f_mu)
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! function giving mu as a function of rho
|
||||||
|
!
|
||||||
|
! f_mu = alpha * rho**beta + mu0
|
||||||
|
!
|
||||||
|
! and its derivative with respect to rho d_drho_f_mu
|
||||||
|
END_DOC
|
||||||
|
double precision, intent(in) :: rho,alpha,mu0,beta
|
||||||
|
double precision, intent(out) :: f_mu,d_drho_f_mu
|
||||||
|
f_mu = alpha * (rho)**beta + mu0
|
||||||
|
d_drho_f_mu = alpha * beta * rho**(beta-1.d0)
|
||||||
|
|
||||||
|
end
|
||||||
|
|
@ -1,164 +1,68 @@
|
|||||||
! ---
|
! ---
|
||||||
|
|
||||||
BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao, (ao_num, ao_num, n_points_final_grid, 3)]
|
!BEGIN_PROVIDER [ double precision, int1_grad2_u12_ao, (3, ao_num, ao_num, n_points_final_grid)]
|
||||||
|
!
|
||||||
BEGIN_DOC
|
! BEGIN_DOC
|
||||||
!
|
! !
|
||||||
! int2_grad1_u12_ao(i,j,ipoint,:) = \int dr2 [-1 * \grad_r1 J(r1,r2)] \phi_i(r2) \phi_j(r2)
|
! ! int1_grad2_u12_ao(:,i,j,ipoint) = \int dr1 [-1 * \grad_r2 J(r1,r2)] \phi_i(r1) \phi_j(r1)
|
||||||
!
|
! !
|
||||||
! where r1 = r(ipoint)
|
! ! where r1 = r(ipoint)
|
||||||
!
|
! !
|
||||||
! if J(r1,r2) = u12:
|
! ! if J(r1,r2) = u12:
|
||||||
!
|
! !
|
||||||
! int2_grad1_u12_ao(i,j,ipoint,:) = 0.5 x \int dr2 [(r1 - r2) (erf(mu * r12)-1)r_12] \phi_i(r2) \phi_j(r2)
|
! ! int1_grad2_u12_ao(:,i,j,ipoint) = +0.5 x \int dr1 [-(r1 - r2) (erf(mu * r12)-1)r_12] \phi_i(r1) \phi_j(r1)
|
||||||
! = 0.5 * [ v_ij_erf_rk_cst_mu(i,j,ipoint) * r(:) - x_v_ij_erf_rk_cst_mu(i,j,ipoint,:) ]
|
! ! = -0.5 * [ v_ij_erf_rk_cst_mu(i,j,ipoint) * r(:) - x_v_ij_erf_rk_cst_mu(i,j,ipoint,:) ]
|
||||||
!
|
! ! = -int2_grad1_u12_ao(i,j,ipoint,:)
|
||||||
! if J(r1,r2) = u12 x v1 x v2
|
! !
|
||||||
!
|
! ! if J(r1,r2) = u12 x v1 x v2
|
||||||
! int2_grad1_u12_ao(i,j,ipoint,:) = v1 x [ 0.5 x \int dr2 [(r1 - r2) (erf(mu * r12)-1)r_12] v2 \phi_i(r2) \phi_j(r2) ]
|
! !
|
||||||
! - \grad_1 v1 x [ \int dr2 u12 v2 \phi_i(r2) \phi_j(r2) ]
|
! ! int1_grad2_u12_ao(:,i,j,ipoint) = v2 x [ 0.5 x \int dr1 [-(r1 - r2) (erf(mu * r12)-1)r_12] v1 \phi_i(r1) \phi_j(r1) ]
|
||||||
! = 0.5 v_1b(ipoint) * v_ij_erf_rk_cst_mu_j1b(i,j,ipoint) * r(:)
|
! ! - \grad_2 v2 x [ \int dr1 u12 v1 \phi_i(r1) \phi_j(r1) ]
|
||||||
! - 0.5 v_1b(ipoint) * x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,:)
|
! ! = -0.5 v_1b(ipoint) * v_ij_erf_rk_cst_mu_j1b(i,j,ipoint) * r(:)
|
||||||
! - v_1b_grad[:,ipoint] * v_ij_u_cst_mu_j1b(i,j,ipoint)
|
! ! + 0.5 v_1b(ipoint) * x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,:)
|
||||||
!
|
! ! - v_1b_grad[:,ipoint] * v_ij_u_cst_mu_j1b(i,j,ipoint)
|
||||||
!
|
! !
|
||||||
END_DOC
|
! !
|
||||||
|
! END_DOC
|
||||||
implicit none
|
!
|
||||||
integer :: ipoint, i, j, m
|
! implicit none
|
||||||
double precision :: time0, time1
|
! integer :: ipoint, i, j
|
||||||
double precision :: x, y, z, tmp_x, tmp_y, tmp_z, tmp0, tmp1, tmp2
|
! double precision :: x, y, z, tmp_x, tmp_y, tmp_z, tmp0, tmp1, tmp2
|
||||||
|
!
|
||||||
print*, ' providing int2_grad1_u12_ao ...'
|
! PROVIDE j1b_type
|
||||||
call wall_time(time0)
|
!
|
||||||
|
! if(j1b_type .eq. 3) then
|
||||||
PROVIDE j1b_type
|
!
|
||||||
|
! do ipoint = 1, n_points_final_grid
|
||||||
if(read_tc_integ) then
|
! x = final_grid_points(1,ipoint)
|
||||||
|
! y = final_grid_points(2,ipoint)
|
||||||
open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/int2_grad1_u12_ao', action="read")
|
! z = final_grid_points(3,ipoint)
|
||||||
read(11) int2_grad1_u12_ao
|
!
|
||||||
close(11)
|
! tmp0 = 0.5d0 * v_1b(ipoint)
|
||||||
|
! tmp_x = v_1b_grad(1,ipoint)
|
||||||
else
|
! tmp_y = v_1b_grad(2,ipoint)
|
||||||
|
! tmp_z = v_1b_grad(3,ipoint)
|
||||||
if(j1b_type .eq. 3) then
|
!
|
||||||
do ipoint = 1, n_points_final_grid
|
! do j = 1, ao_num
|
||||||
x = final_grid_points(1,ipoint)
|
! do i = 1, ao_num
|
||||||
y = final_grid_points(2,ipoint)
|
!
|
||||||
z = final_grid_points(3,ipoint)
|
! tmp1 = tmp0 * v_ij_erf_rk_cst_mu_j1b(i,j,ipoint)
|
||||||
tmp0 = 0.5d0 * v_1b(ipoint)
|
! tmp2 = v_ij_u_cst_mu_j1b(i,j,ipoint)
|
||||||
tmp_x = v_1b_grad(1,ipoint)
|
!
|
||||||
tmp_y = v_1b_grad(2,ipoint)
|
! int1_grad2_u12_ao(1,i,j,ipoint) = -tmp1 * x + tmp0 * x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,1) - tmp2 * tmp_x
|
||||||
tmp_z = v_1b_grad(3,ipoint)
|
! int1_grad2_u12_ao(2,i,j,ipoint) = -tmp1 * y + tmp0 * x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,2) - tmp2 * tmp_y
|
||||||
do j = 1, ao_num
|
! int1_grad2_u12_ao(3,i,j,ipoint) = -tmp1 * z + tmp0 * x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,3) - tmp2 * tmp_z
|
||||||
do i = 1, ao_num
|
! enddo
|
||||||
tmp1 = tmp0 * v_ij_erf_rk_cst_mu_j1b(i,j,ipoint)
|
! enddo
|
||||||
tmp2 = v_ij_u_cst_mu_j1b(i,j,ipoint)
|
! enddo
|
||||||
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
|
! else
|
||||||
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
|
! int1_grad2_u12_ao = -1.d0 * int2_grad1_u12_ao
|
||||||
enddo
|
!
|
||||||
enddo
|
! endif
|
||||||
else
|
!
|
||||||
do ipoint = 1, n_points_final_grid
|
!END_PROVIDER
|
||||||
x = final_grid_points(1,ipoint)
|
|
||||||
y = final_grid_points(2,ipoint)
|
|
||||||
z = final_grid_points(3,ipoint)
|
|
||||||
do j = 1, ao_num
|
|
||||||
do i = 1, ao_num
|
|
||||||
tmp1 = v_ij_erf_rk_cst_mu(i,j,ipoint)
|
|
||||||
|
|
||||||
int2_grad1_u12_ao(i,j,ipoint,1) = tmp1 * x - x_v_ij_erf_rk_cst_mu_transp_bis(ipoint,i,j,1)
|
|
||||||
int2_grad1_u12_ao(i,j,ipoint,2) = tmp1 * y - x_v_ij_erf_rk_cst_mu_transp_bis(ipoint,i,j,2)
|
|
||||||
int2_grad1_u12_ao(i,j,ipoint,3) = tmp1 * z - x_v_ij_erf_rk_cst_mu_transp_bis(ipoint,i,j,3)
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
int2_grad1_u12_ao *= 0.5d0
|
|
||||||
endif
|
|
||||||
|
|
||||||
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
|
|
||||||
|
|
||||||
END_PROVIDER
|
|
||||||
|
|
||||||
! ---
|
|
||||||
|
|
||||||
BEGIN_PROVIDER [ double precision, int1_grad2_u12_ao, (3, ao_num, ao_num, n_points_final_grid)]
|
|
||||||
|
|
||||||
BEGIN_DOC
|
|
||||||
!
|
|
||||||
! int1_grad2_u12_ao(:,i,j,ipoint) = \int dr1 [-1 * \grad_r2 J(r1,r2)] \phi_i(r1) \phi_j(r1)
|
|
||||||
!
|
|
||||||
! where r1 = r(ipoint)
|
|
||||||
!
|
|
||||||
! if J(r1,r2) = u12:
|
|
||||||
!
|
|
||||||
! int1_grad2_u12_ao(:,i,j,ipoint) = +0.5 x \int dr1 [-(r1 - r2) (erf(mu * r12)-1)r_12] \phi_i(r1) \phi_j(r1)
|
|
||||||
! = -0.5 * [ v_ij_erf_rk_cst_mu(i,j,ipoint) * r(:) - x_v_ij_erf_rk_cst_mu(i,j,ipoint,:) ]
|
|
||||||
! = -int2_grad1_u12_ao(i,j,ipoint,:)
|
|
||||||
!
|
|
||||||
! if J(r1,r2) = u12 x v1 x v2
|
|
||||||
!
|
|
||||||
! int1_grad2_u12_ao(:,i,j,ipoint) = v2 x [ 0.5 x \int dr1 [-(r1 - r2) (erf(mu * r12)-1)r_12] v1 \phi_i(r1) \phi_j(r1) ]
|
|
||||||
! - \grad_2 v2 x [ \int dr1 u12 v1 \phi_i(r1) \phi_j(r1) ]
|
|
||||||
! = -0.5 v_1b(ipoint) * v_ij_erf_rk_cst_mu_j1b(i,j,ipoint) * r(:)
|
|
||||||
! + 0.5 v_1b(ipoint) * x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,:)
|
|
||||||
! - v_1b_grad[:,ipoint] * v_ij_u_cst_mu_j1b(i,j,ipoint)
|
|
||||||
!
|
|
||||||
!
|
|
||||||
END_DOC
|
|
||||||
|
|
||||||
implicit none
|
|
||||||
integer :: ipoint, i, j
|
|
||||||
double precision :: x, y, z, tmp_x, tmp_y, tmp_z, tmp0, tmp1, tmp2
|
|
||||||
|
|
||||||
PROVIDE j1b_type
|
|
||||||
|
|
||||||
if(j1b_type .eq. 3) then
|
|
||||||
|
|
||||||
do ipoint = 1, n_points_final_grid
|
|
||||||
x = final_grid_points(1,ipoint)
|
|
||||||
y = final_grid_points(2,ipoint)
|
|
||||||
z = final_grid_points(3,ipoint)
|
|
||||||
|
|
||||||
tmp0 = 0.5d0 * v_1b(ipoint)
|
|
||||||
tmp_x = v_1b_grad(1,ipoint)
|
|
||||||
tmp_y = v_1b_grad(2,ipoint)
|
|
||||||
tmp_z = v_1b_grad(3,ipoint)
|
|
||||||
|
|
||||||
do j = 1, ao_num
|
|
||||||
do i = 1, ao_num
|
|
||||||
|
|
||||||
tmp1 = tmp0 * v_ij_erf_rk_cst_mu_j1b(i,j,ipoint)
|
|
||||||
tmp2 = v_ij_u_cst_mu_j1b(i,j,ipoint)
|
|
||||||
|
|
||||||
int1_grad2_u12_ao(1,i,j,ipoint) = -tmp1 * x + tmp0 * x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,1) - tmp2 * tmp_x
|
|
||||||
int1_grad2_u12_ao(2,i,j,ipoint) = -tmp1 * y + tmp0 * x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,2) - tmp2 * tmp_y
|
|
||||||
int1_grad2_u12_ao(3,i,j,ipoint) = -tmp1 * z + tmp0 * x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,3) - tmp2 * tmp_z
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
|
|
||||||
else
|
|
||||||
|
|
||||||
int1_grad2_u12_ao = -1.d0 * int2_grad1_u12_ao
|
|
||||||
|
|
||||||
endif
|
|
||||||
|
|
||||||
END_PROVIDER
|
|
||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
|
||||||
@ -288,7 +192,10 @@ BEGIN_PROVIDER [double precision, tc_grad_and_lapl_ao, (ao_num, ao_num, ao_num,
|
|||||||
!
|
!
|
||||||
! 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 >
|
! 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 \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.
|
! This is obtained by integration by parts.
|
||||||
!
|
!
|
||||||
@ -305,20 +212,14 @@ BEGIN_PROVIDER [double precision, tc_grad_and_lapl_ao, (ao_num, ao_num, ao_num,
|
|||||||
|
|
||||||
if(read_tc_integ) then
|
if(read_tc_integ) then
|
||||||
|
|
||||||
open(unit=11, form="unformatted", file='tc_grad_and_lapl_ao', action="read")
|
open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/tc_grad_and_lapl_ao', action="read")
|
||||||
do i = 1, ao_num
|
read(11) tc_grad_and_lapl_ao
|
||||||
do j = 1, ao_num
|
|
||||||
do k = 1, ao_num
|
|
||||||
do l = 1, ao_num
|
|
||||||
read(11) tc_grad_and_lapl_ao(l,k,j,i)
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
close(11)
|
close(11)
|
||||||
|
|
||||||
else
|
else
|
||||||
|
|
||||||
|
PROVIDE int2_grad1_u12_ao
|
||||||
|
|
||||||
allocate(b_mat(n_points_final_grid,ao_num,ao_num,3))
|
allocate(b_mat(n_points_final_grid,ao_num,ao_num,3))
|
||||||
|
|
||||||
b_mat = 0.d0
|
b_mat = 0.d0
|
||||||
@ -350,7 +251,6 @@ BEGIN_PROVIDER [double precision, tc_grad_and_lapl_ao, (ao_num, ao_num, ao_num,
|
|||||||
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_grad1_u12_ao(1,1,1,m), ao_num*ao_num, b_mat(1,1,1,m), n_points_final_grid &
|
, 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)
|
, 1.d0, tc_grad_and_lapl_ao, ao_num*ao_num)
|
||||||
|
|
||||||
enddo
|
enddo
|
||||||
deallocate(b_mat)
|
deallocate(b_mat)
|
||||||
|
|
||||||
@ -374,18 +274,12 @@ BEGIN_PROVIDER [double precision, tc_grad_and_lapl_ao, (ao_num, ao_num, ao_num,
|
|||||||
|
|
||||||
endif
|
endif
|
||||||
|
|
||||||
if(write_tc_integ) then
|
if(write_tc_integ.and.mpi_master) then
|
||||||
open(unit=11, form="unformatted", file='tc_grad_and_lapl_ao', action="write")
|
open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/tc_grad_and_lapl_ao', action="write")
|
||||||
do i = 1, ao_num
|
call ezfio_set_work_empty(.False.)
|
||||||
do j = 1, ao_num
|
write(11) tc_grad_and_lapl_ao
|
||||||
do k = 1, ao_num
|
|
||||||
do l = 1, ao_num
|
|
||||||
write(11) tc_grad_and_lapl_ao(l,k,j,i)
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
close(11)
|
close(11)
|
||||||
|
call ezfio_set_tc_keywords_io_tc_integ('Read')
|
||||||
endif
|
endif
|
||||||
|
|
||||||
call wall_time(time1)
|
call wall_time(time1)
|
||||||
|
@ -39,7 +39,6 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_test, (ao_num, ao_num, n_po
|
|||||||
read(11) int2_grad1_u12_ao_test
|
read(11) int2_grad1_u12_ao_test
|
||||||
close(11)
|
close(11)
|
||||||
|
|
||||||
|
|
||||||
else
|
else
|
||||||
|
|
||||||
if(j1b_type .eq. 3) then
|
if(j1b_type .eq. 3) then
|
||||||
|
@ -322,9 +322,9 @@ double precision function num_gradu_squared_u_ij_mu(i, j, ipoint)
|
|||||||
double precision, external :: ao_value
|
double precision, external :: ao_value
|
||||||
double precision, external :: j1b_nucl
|
double precision, external :: j1b_nucl
|
||||||
double precision, external :: j12_mu
|
double precision, external :: j12_mu
|
||||||
double precision, external :: grad_x_j1b_nucl
|
double precision, external :: grad_x_j1b_nucl_num
|
||||||
double precision, external :: grad_y_j1b_nucl
|
double precision, external :: grad_y_j1b_nucl_num
|
||||||
double precision, external :: grad_z_j1b_nucl
|
double precision, external :: grad_z_j1b_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)
|
||||||
@ -342,11 +342,11 @@ double precision function num_gradu_squared_u_ij_mu(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(r1)
|
dx1_v1 = grad_x_j1b_nucl_num(r1)
|
||||||
dy1_v1 = grad_y_j1b_nucl(r1)
|
dy1_v1 = grad_y_j1b_nucl_num(r1)
|
||||||
dz1_v1 = grad_z_j1b_nucl(r1)
|
dz1_v1 = grad_z_j1b_nucl_num(r1)
|
||||||
|
|
||||||
call grad1_j12_mu_exc(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 = j1b_nucl(r1)
|
||||||
@ -390,9 +390,9 @@ double precision function num_grad12_j12(i, j, ipoint)
|
|||||||
double precision, external :: ao_value
|
double precision, external :: ao_value
|
||||||
double precision, external :: j1b_nucl
|
double precision, external :: j1b_nucl
|
||||||
double precision, external :: j12_mu
|
double precision, external :: j12_mu
|
||||||
double precision, external :: grad_x_j1b_nucl
|
double precision, external :: grad_x_j1b_nucl_num
|
||||||
double precision, external :: grad_y_j1b_nucl
|
double precision, external :: grad_y_j1b_nucl_num
|
||||||
double precision, external :: grad_z_j1b_nucl
|
double precision, external :: grad_z_j1b_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,11 +410,11 @@ 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(r1)
|
dx1_v1 = grad_x_j1b_nucl_num(r1)
|
||||||
dy1_v1 = grad_y_j1b_nucl(r1)
|
dy1_v1 = grad_y_j1b_nucl_num(r1)
|
||||||
dz1_v1 = grad_z_j1b_nucl(r1)
|
dz1_v1 = grad_z_j1b_nucl_num(r1)
|
||||||
|
|
||||||
call grad1_j12_mu_exc(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 = j1b_nucl(r1)
|
||||||
@ -456,9 +456,9 @@ double precision function num_u12sq_j1bsq(i, j, ipoint)
|
|||||||
double precision, external :: ao_value
|
double precision, external :: ao_value
|
||||||
double precision, external :: j1b_nucl
|
double precision, external :: j1b_nucl
|
||||||
double precision, external :: j12_mu
|
double precision, external :: j12_mu
|
||||||
double precision, external :: grad_x_j1b_nucl
|
double precision, external :: grad_x_j1b_nucl_num
|
||||||
double precision, external :: grad_y_j1b_nucl
|
double precision, external :: grad_y_j1b_nucl_num
|
||||||
double precision, external :: grad_z_j1b_nucl
|
double precision, external :: grad_z_j1b_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)
|
||||||
@ -476,11 +476,11 @@ 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(r1)
|
dx1_v1 = grad_x_j1b_nucl_num(r1)
|
||||||
dy1_v1 = grad_y_j1b_nucl(r1)
|
dy1_v1 = grad_y_j1b_nucl_num(r1)
|
||||||
dz1_v1 = grad_z_j1b_nucl(r1)
|
dz1_v1 = grad_z_j1b_nucl_num(r1)
|
||||||
|
|
||||||
call grad1_j12_mu_exc(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 = j1b_nucl(r1)
|
||||||
@ -522,9 +522,9 @@ double precision function num_u12_grad1_u12_j1b_grad1_j1b(i, j, ipoint)
|
|||||||
double precision, external :: ao_value
|
double precision, external :: ao_value
|
||||||
double precision, external :: j1b_nucl
|
double precision, external :: j1b_nucl
|
||||||
double precision, external :: j12_mu
|
double precision, external :: j12_mu
|
||||||
double precision, external :: grad_x_j1b_nucl
|
double precision, external :: grad_x_j1b_nucl_num
|
||||||
double precision, external :: grad_y_j1b_nucl
|
double precision, external :: grad_y_j1b_nucl_num
|
||||||
double precision, external :: grad_z_j1b_nucl
|
double precision, external :: grad_z_j1b_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)
|
||||||
@ -542,11 +542,11 @@ 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(r1)
|
dx1_v1 = grad_x_j1b_nucl_num(r1)
|
||||||
dy1_v1 = grad_y_j1b_nucl(r1)
|
dy1_v1 = grad_y_j1b_nucl_num(r1)
|
||||||
dz1_v1 = grad_z_j1b_nucl(r1)
|
dz1_v1 = grad_z_j1b_nucl_num(r1)
|
||||||
|
|
||||||
call grad1_j12_mu_exc(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 = j1b_nucl(r1)
|
||||||
|
33
src/non_h_ints_mu/plot_mu_of_r.irp.f
Normal file
33
src/non_h_ints_mu/plot_mu_of_r.irp.f
Normal file
@ -0,0 +1,33 @@
|
|||||||
|
program plot_mu_of_r
|
||||||
|
implicit none
|
||||||
|
read_wf = .False.
|
||||||
|
touch read_wf
|
||||||
|
call routine_print
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
|
subroutine routine_print
|
||||||
|
implicit none
|
||||||
|
character*(128) :: output
|
||||||
|
integer :: i_unit_output,getUnitAndOpen
|
||||||
|
output=trim(ezfio_filename)//'.mu_of_r'
|
||||||
|
i_unit_output = getUnitAndOpen(output,'w')
|
||||||
|
integer :: ipoint,nx
|
||||||
|
double precision :: xmax,xmin,r(3),dx
|
||||||
|
double precision :: mu_val, mu_der(3),dm_a,dm_b,grad
|
||||||
|
xmax = 5.D0
|
||||||
|
xmin = -5.D0
|
||||||
|
nx = 10000
|
||||||
|
dx = (xmax - xmin)/dble(nx)
|
||||||
|
r = 0.d0
|
||||||
|
r(1) = xmin
|
||||||
|
do ipoint = 1, nx
|
||||||
|
call mu_r_val_and_grad(r, r, mu_val, mu_der)
|
||||||
|
call dm_dft_alpha_beta_at_r(r,dm_a,dm_b)
|
||||||
|
grad = mu_der(1)**2 + mu_der(2)**2 + mu_der(3)**2
|
||||||
|
grad = dsqrt(grad)
|
||||||
|
write(i_unit_output,'(100(F16.7,X))')r(1),mu_val,dm_a+dm_b,grad
|
||||||
|
r(1) += dx
|
||||||
|
enddo
|
||||||
|
end
|
331
src/non_h_ints_mu/tc_integ.irp.f
Normal file
331
src/non_h_ints_mu/tc_integ.irp.f
Normal file
@ -0,0 +1,331 @@
|
|||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [double precision, int2_grad1_u12_ao, (ao_num, ao_num, n_points_final_grid, 3)]
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
!
|
||||||
|
! int2_grad1_u12_ao(i,j,ipoint,:) = \int dr2 [-1 * \grad_r1 J(r1,r2)] \phi_i(r2) \phi_j(r2)
|
||||||
|
!
|
||||||
|
! where r1 = r(ipoint)
|
||||||
|
!
|
||||||
|
! if J(r1,r2) = u12 (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 v_ij_erf_rk_cst_mu_j1b v_ij_u_cst_mu_j1b 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, 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(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
|
||||||
|
|
||||||
|
elseif(j1b_type .ge. 100) then
|
||||||
|
|
||||||
|
PROVIDE final_weight_at_r_vector_extra aos_in_r_array_extra
|
||||||
|
PROVIDE grad1_u12_num
|
||||||
|
|
||||||
|
double precision, allocatable :: tmp(:,:,:)
|
||||||
|
allocate(tmp(n_points_extra_final_grid,ao_num,ao_num))
|
||||||
|
tmp = 0.d0
|
||||||
|
!$OMP PARALLEL &
|
||||||
|
!$OMP DEFAULT (NONE) &
|
||||||
|
!$OMP PRIVATE (j, i, jpoint) &
|
||||||
|
!$OMP SHARED (tmp, ao_num, n_points_extra_final_grid, final_weight_at_r_vector_extra, aos_in_r_array_extra_transp)
|
||||||
|
!$OMP DO SCHEDULE (static)
|
||||||
|
do j = 1, ao_num
|
||||||
|
do i = 1, ao_num
|
||||||
|
do jpoint = 1, n_points_extra_final_grid
|
||||||
|
tmp(jpoint,i,j) = final_weight_at_r_vector_extra(jpoint) * aos_in_r_array_extra_transp(jpoint,i) * aos_in_r_array_extra_transp(jpoint,j)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
!$OMP END DO
|
||||||
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
|
int2_grad1_u12_ao = 0.d0
|
||||||
|
do m = 1, 3
|
||||||
|
!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 &
|
||||||
|
, 0.d0, int2_grad1_u12_ao(1,1,1,m), ao_num*ao_num)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
!! these dgemm are equivalent to
|
||||||
|
!!$OMP PARALLEL &
|
||||||
|
!!$OMP DEFAULT (NONE) &
|
||||||
|
!!$OMP PRIVATE (j, i, ipoint, jpoint, w) &
|
||||||
|
!!$OMP SHARED (int2_grad1_u12_ao, ao_num, n_points_final_grid, &
|
||||||
|
!!$OMP n_points_extra_final_grid, final_weight_at_r_vector_extra, &
|
||||||
|
!!$OMP aos_in_r_array_extra_transp, grad1_u12_num, tmp)
|
||||||
|
!!$OMP DO SCHEDULE (static)
|
||||||
|
!do ipoint = 1, n_points_final_grid
|
||||||
|
! do j = 1, ao_num
|
||||||
|
! do i = 1, ao_num
|
||||||
|
! do jpoint = 1, n_points_extra_final_grid
|
||||||
|
! w = -tmp(jpoint,i,j)
|
||||||
|
! !w = tmp(jpoint,i,j) this work also because of the symmetry in K(1,2)
|
||||||
|
! ! and sign compensation in L(1,2,3)
|
||||||
|
! int2_grad1_u12_ao(i,j,ipoint,1) += w * grad1_u12_num(jpoint,ipoint,1)
|
||||||
|
! int2_grad1_u12_ao(i,j,ipoint,2) += w * grad1_u12_num(jpoint,ipoint,2)
|
||||||
|
! int2_grad1_u12_ao(i,j,ipoint,3) += w * grad1_u12_num(jpoint,ipoint,3)
|
||||||
|
! enddo
|
||||||
|
! enddo
|
||||||
|
! enddo
|
||||||
|
!enddo
|
||||||
|
!!$OMP END DO
|
||||||
|
!!$OMP END PARALLEL
|
||||||
|
|
||||||
|
deallocate(tmp)
|
||||||
|
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
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
endif
|
||||||
|
|
||||||
|
elseif(j1b_type .ge. 100) then
|
||||||
|
|
||||||
|
PROVIDE final_weight_at_r_vector_extra aos_in_r_array_extra
|
||||||
|
PROVIDE grad1_u12_squared_num
|
||||||
|
|
||||||
|
double precision, allocatable :: tmp(:,:,:)
|
||||||
|
allocate(tmp(n_points_extra_final_grid,ao_num,ao_num))
|
||||||
|
tmp = 0.d0
|
||||||
|
!$OMP PARALLEL &
|
||||||
|
!$OMP DEFAULT (NONE) &
|
||||||
|
!$OMP PRIVATE (j, i, jpoint) &
|
||||||
|
!$OMP SHARED (tmp, ao_num, n_points_extra_final_grid, final_weight_at_r_vector_extra, aos_in_r_array_extra_transp)
|
||||||
|
!$OMP DO SCHEDULE (static)
|
||||||
|
do j = 1, ao_num
|
||||||
|
do i = 1, ao_num
|
||||||
|
do jpoint = 1, n_points_extra_final_grid
|
||||||
|
tmp(jpoint,i,j) = final_weight_at_r_vector_extra(jpoint) * aos_in_r_array_extra_transp(jpoint,i) * aos_in_r_array_extra_transp(jpoint,j)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
!$OMP END DO
|
||||||
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
|
int2_grad1_u12_square_ao = 0.d0
|
||||||
|
call dgemm( "T", "N", ao_num*ao_num, n_points_final_grid, n_points_extra_final_grid, -0.5d0 &
|
||||||
|
, tmp(1,1,1), n_points_extra_final_grid, grad1_u12_squared_num(1,1), n_points_extra_final_grid &
|
||||||
|
, 0.d0, int2_grad1_u12_square_ao(1,1,1), ao_num*ao_num)
|
||||||
|
|
||||||
|
!! this dgemm is equivalen to
|
||||||
|
!!$OMP PARALLEL &
|
||||||
|
!!$OMP DEFAULT (NONE) &
|
||||||
|
!!$OMP PRIVATE (i, j, ipoint, jpoint, w) &
|
||||||
|
!!$OMP SHARED (int2_grad1_u12_square_ao, ao_num, n_points_final_grid, &
|
||||||
|
!!$OMP n_points_extra_final_grid, final_weight_at_r_vector_extra, &
|
||||||
|
!!$OMP aos_in_r_array_extra_transp, grad1_u12_squared_num, tmp)
|
||||||
|
!!$OMP DO SCHEDULE (static)
|
||||||
|
!do ipoint = 1, n_points_final_grid
|
||||||
|
! do j = 1, ao_num
|
||||||
|
! do i = 1, ao_num
|
||||||
|
! do jpoint = 1, n_points_extra_final_grid
|
||||||
|
! w = -0.5d0 * tmp(jpoint,i,j)
|
||||||
|
! int2_grad1_u12_square_ao(i,j,ipoint) += w * grad1_u12_squared_num(jpoint,ipoint)
|
||||||
|
! enddo
|
||||||
|
! enddo
|
||||||
|
! enddo
|
||||||
|
!enddo
|
||||||
|
!!$OMP END DO
|
||||||
|
!!$OMP END PARALLEL
|
||||||
|
|
||||||
|
deallocate(tmp)
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
@ -1,15 +1,25 @@
|
|||||||
program test_non_h
|
program test_non_h
|
||||||
implicit none
|
|
||||||
|
implicit none
|
||||||
|
|
||||||
my_grid_becke = .True.
|
my_grid_becke = .True.
|
||||||
my_n_pt_r_grid = 50
|
my_n_pt_r_grid = 50
|
||||||
my_n_pt_a_grid = 74
|
my_n_pt_a_grid = 74
|
||||||
|
!my_n_pt_r_grid = 400
|
||||||
|
!my_n_pt_a_grid = 974
|
||||||
|
|
||||||
! my_n_pt_r_grid = 10 ! small grid for quick debug
|
! my_n_pt_r_grid = 10 ! small grid for quick debug
|
||||||
! my_n_pt_a_grid = 26 ! small grid for quick debug
|
! my_n_pt_a_grid = 26 ! small grid for quick debug
|
||||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||||
!call routine_grad_squared
|
|
||||||
call routine_fit
|
!call routine_grad_squared
|
||||||
|
!call routine_fit
|
||||||
|
|
||||||
|
call test_ipp()
|
||||||
end
|
end
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
subroutine routine_lapl_grad
|
subroutine routine_lapl_grad
|
||||||
implicit none
|
implicit none
|
||||||
integer :: i,j,k,l
|
integer :: i,j,k,l
|
||||||
@ -100,3 +110,445 @@ subroutine routine_fit
|
|||||||
enddo
|
enddo
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
|
|
||||||
|
subroutine test_ipp()
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer :: i, j, k, l, ipoint
|
||||||
|
double precision :: accu, norm, diff, old, new, eps, int_num
|
||||||
|
double precision :: weight1, ao_i_r, ao_k_r
|
||||||
|
double precision, allocatable :: b_mat(:,:,:), I1(:,:,:,:), I2(:,:,:,:)
|
||||||
|
|
||||||
|
eps = 1d-7
|
||||||
|
|
||||||
|
allocate(b_mat(n_points_final_grid,ao_num,ao_num))
|
||||||
|
b_mat = 0.d0
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
! first way
|
||||||
|
|
||||||
|
allocate(I1(ao_num,ao_num,ao_num,ao_num))
|
||||||
|
I1 = 0.d0
|
||||||
|
|
||||||
|
PROVIDE u12_grad1_u12_j1b_grad1_j1b
|
||||||
|
|
||||||
|
!$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
|
||||||
|
|
||||||
|
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 &
|
||||||
|
, 0.d0, I1, ao_num*ao_num)
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
! 2nd way
|
||||||
|
|
||||||
|
allocate(I2(ao_num,ao_num,ao_num,ao_num))
|
||||||
|
I2 = 0.d0
|
||||||
|
|
||||||
|
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 &
|
||||||
|
, 0.d0, I2, ao_num*ao_num)
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
deallocate(b_mat)
|
||||||
|
|
||||||
|
accu = 0.d0
|
||||||
|
norm = 0.d0
|
||||||
|
do i = 1, ao_num
|
||||||
|
do k = 1, ao_num
|
||||||
|
do l = 1, ao_num
|
||||||
|
do j = 1, ao_num
|
||||||
|
|
||||||
|
old = I1(j,l,k,i)
|
||||||
|
new = I2(j,l,k,i)
|
||||||
|
|
||||||
|
!print*, l, k, j, i
|
||||||
|
!print*, old, new
|
||||||
|
|
||||||
|
diff = new - old
|
||||||
|
if(dabs(diff) .gt. eps) then
|
||||||
|
print*, ' problem on :', j, l, k, i
|
||||||
|
print*, ' diff = ', diff
|
||||||
|
print*, ' old value = ', old
|
||||||
|
print*, ' new value = ', new
|
||||||
|
call I_grade_gradu_naive1(i, j, k, l, int_num)
|
||||||
|
print*, ' full num1 = ', int_num
|
||||||
|
call I_grade_gradu_naive2(i, j, k, l, int_num)
|
||||||
|
print*, ' full num2 = ', int_num
|
||||||
|
call I_grade_gradu_naive3(i, j, k, l, int_num)
|
||||||
|
print*, ' full num3 = ', int_num
|
||||||
|
call I_grade_gradu_naive4(i, j, k, l, int_num)
|
||||||
|
print*, ' full num4 = ', int_num
|
||||||
|
call I_grade_gradu_seminaive(i, j, k, l, int_num)
|
||||||
|
print*, ' semi num = ', int_num
|
||||||
|
endif
|
||||||
|
|
||||||
|
accu += dabs(diff)
|
||||||
|
norm += dabs(old)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
deallocate(I1, I2)
|
||||||
|
|
||||||
|
print*, ' accu = ', accu
|
||||||
|
print*, ' norm = ', norm
|
||||||
|
|
||||||
|
return
|
||||||
|
end subroutine test_ipp
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
subroutine I_grade_gradu_naive1(i, j, k, l, int)
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: i, j, k, l
|
||||||
|
double precision, intent(out) :: int
|
||||||
|
integer :: ipoint, jpoint
|
||||||
|
double precision :: r1(3), r2(3)
|
||||||
|
double precision :: weight1_x, weight1_y, weight1_z
|
||||||
|
double precision :: weight2_x, weight2_y, weight2_z
|
||||||
|
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, external :: j1b_nucl, j12_mu
|
||||||
|
|
||||||
|
int = 0.d0
|
||||||
|
|
||||||
|
do ipoint = 1, n_points_final_grid ! r1
|
||||||
|
|
||||||
|
r1(1) = final_grid_points(1,ipoint)
|
||||||
|
r1(2) = final_grid_points(2,ipoint)
|
||||||
|
r1(3) = final_grid_points(3,ipoint)
|
||||||
|
|
||||||
|
aor_i = aos_in_r_array_transp(ipoint,i)
|
||||||
|
aor_k = aos_in_r_array_transp(ipoint,k)
|
||||||
|
|
||||||
|
e1_val = j1b_nucl(r1)
|
||||||
|
call grad1_j1b_nucl(r1, e1_der)
|
||||||
|
|
||||||
|
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_z = aor_i * aor_k * e1_val * final_weight_at_r_vector(ipoint) * e1_der(3)
|
||||||
|
|
||||||
|
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)
|
||||||
|
|
||||||
|
aor_j = aos_in_r_array_extra_transp(jpoint,j)
|
||||||
|
aor_l = aos_in_r_array_extra_transp(jpoint,l)
|
||||||
|
|
||||||
|
e2_val = j1b_nucl(r2)
|
||||||
|
|
||||||
|
u12_val = j12_mu(r1, r2)
|
||||||
|
call grad1_j12_mu(r1, r2, u12_der)
|
||||||
|
|
||||||
|
weight2_x = aor_j * aor_l * e2_val * e2_val * u12_val * final_weight_at_r_vector_extra(jpoint) * u12_der(1)
|
||||||
|
weight2_y = aor_j * aor_l * e2_val * e2_val * u12_val * final_weight_at_r_vector_extra(jpoint) * u12_der(2)
|
||||||
|
weight2_z = aor_j * aor_l * e2_val * e2_val * u12_val * final_weight_at_r_vector_extra(jpoint) * u12_der(3)
|
||||||
|
|
||||||
|
int = int - (weight1_x * weight2_x + weight1_y * weight2_y + weight1_z * weight2_z)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
return
|
||||||
|
end subroutine I_grade_gradu_naive1
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
subroutine I_grade_gradu_naive2(i, j, k, l, int)
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: i, j, k, l
|
||||||
|
double precision, intent(out) :: int
|
||||||
|
integer :: ipoint, jpoint
|
||||||
|
double precision :: r1(3), r2(3)
|
||||||
|
double precision :: weight1_x, weight1_y, weight1_z
|
||||||
|
double precision :: weight2_x, weight2_y, weight2_z
|
||||||
|
double precision :: aor_i, aor_j, aor_k, aor_l
|
||||||
|
double precision :: e1_square_der(3), e2_val, u12_square_der(3)
|
||||||
|
double precision, external :: j1b_nucl
|
||||||
|
|
||||||
|
int = 0.d0
|
||||||
|
|
||||||
|
do ipoint = 1, n_points_final_grid ! r1
|
||||||
|
|
||||||
|
r1(1) = final_grid_points(1,ipoint)
|
||||||
|
r1(2) = final_grid_points(2,ipoint)
|
||||||
|
r1(3) = final_grid_points(3,ipoint)
|
||||||
|
|
||||||
|
aor_i = aos_in_r_array_transp(ipoint,i)
|
||||||
|
aor_k = aos_in_r_array_transp(ipoint,k)
|
||||||
|
|
||||||
|
call grad1_j1b_nucl_square_num(r1, e1_square_der)
|
||||||
|
|
||||||
|
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_z = aor_i * aor_k * final_weight_at_r_vector(ipoint) * e1_square_der(3)
|
||||||
|
|
||||||
|
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)
|
||||||
|
|
||||||
|
aor_j = aos_in_r_array_extra_transp(jpoint,j)
|
||||||
|
aor_l = aos_in_r_array_extra_transp(jpoint,l)
|
||||||
|
|
||||||
|
e2_val = j1b_nucl(r2)
|
||||||
|
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_y = aor_j * aor_l * e2_val * e2_val * final_weight_at_r_vector_extra(jpoint) * u12_square_der(2)
|
||||||
|
weight2_z = aor_j * aor_l * e2_val * e2_val * final_weight_at_r_vector_extra(jpoint) * u12_square_der(3)
|
||||||
|
|
||||||
|
int = int - 0.25d0 * (weight1_x * weight2_x + weight1_y * weight2_y + weight1_z * weight2_z)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
return
|
||||||
|
end subroutine I_grade_gradu_naive2
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
subroutine I_grade_gradu_naive3(i, j, k, l, int)
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: i, j, k, l
|
||||||
|
double precision, intent(out) :: int
|
||||||
|
integer :: ipoint, jpoint
|
||||||
|
double precision :: r1(3), r2(3)
|
||||||
|
double precision :: weight1, weight2
|
||||||
|
double precision :: aor_j, aor_l
|
||||||
|
double precision :: grad(3), e2_val, u12_val
|
||||||
|
double precision, external :: j1b_nucl, j12_mu
|
||||||
|
|
||||||
|
int = 0.d0
|
||||||
|
|
||||||
|
do ipoint = 1, n_points_final_grid ! r1
|
||||||
|
|
||||||
|
r1(1) = final_grid_points(1,ipoint)
|
||||||
|
r1(2) = final_grid_points(2,ipoint)
|
||||||
|
r1(3) = final_grid_points(3,ipoint)
|
||||||
|
|
||||||
|
call grad1_aos_ik_grad1_esquare(i, k, r1, grad)
|
||||||
|
|
||||||
|
weight1 = final_weight_at_r_vector(ipoint) * (grad(1) + grad(2) + grad(3))
|
||||||
|
|
||||||
|
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)
|
||||||
|
|
||||||
|
aor_j = aos_in_r_array_extra_transp(jpoint,j)
|
||||||
|
aor_l = aos_in_r_array_extra_transp(jpoint,l)
|
||||||
|
|
||||||
|
e2_val = j1b_nucl(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)
|
||||||
|
|
||||||
|
int = int + 0.25d0 * weight1 * weight2
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
return
|
||||||
|
end subroutine I_grade_gradu_naive3
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
subroutine I_grade_gradu_naive4(i, j, k, l, int)
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: i, j, k, l
|
||||||
|
double precision, intent(out) :: int
|
||||||
|
integer :: ipoint, jpoint
|
||||||
|
double precision :: r1(3), r2(3)
|
||||||
|
double precision :: weight1, weight2
|
||||||
|
double precision :: aor_j, aor_l, aor_k, aor_i
|
||||||
|
double precision :: grad(3), e2_val, u12_val
|
||||||
|
double precision, external :: j1b_nucl, j12_mu
|
||||||
|
|
||||||
|
int = 0.d0
|
||||||
|
|
||||||
|
do ipoint = 1, n_points_final_grid ! r1
|
||||||
|
|
||||||
|
r1(1) = final_grid_points(1,ipoint)
|
||||||
|
r1(2) = final_grid_points(2,ipoint)
|
||||||
|
r1(3) = final_grid_points(3,ipoint)
|
||||||
|
|
||||||
|
aor_i = aos_in_r_array_transp(ipoint,i)
|
||||||
|
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) &
|
||||||
|
+ (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,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,3) + aor_i * aos_grad_in_r_array_transp_bis(ipoint,k,3)) * v_1b_square_grad(ipoint,3) )
|
||||||
|
|
||||||
|
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)
|
||||||
|
|
||||||
|
aor_j = aos_in_r_array_extra_transp(jpoint,j)
|
||||||
|
aor_l = aos_in_r_array_extra_transp(jpoint,l)
|
||||||
|
|
||||||
|
e2_val = j1b_nucl(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)
|
||||||
|
|
||||||
|
int = int + 0.25d0 * weight1 * weight2
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
return
|
||||||
|
end subroutine I_grade_gradu_naive4
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
subroutine I_grade_gradu_seminaive(i, j, k, l, int)
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: i, j, k, l
|
||||||
|
double precision, intent(out) :: int
|
||||||
|
integer :: ipoint
|
||||||
|
double precision :: r1(3)
|
||||||
|
double precision :: weight1
|
||||||
|
double precision :: aor_i, aor_k
|
||||||
|
|
||||||
|
int = 0.d0
|
||||||
|
|
||||||
|
do ipoint = 1, n_points_final_grid ! r1
|
||||||
|
|
||||||
|
aor_i = aos_in_r_array_transp(ipoint,i)
|
||||||
|
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) &
|
||||||
|
+ (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,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,3) + aor_i * aos_grad_in_r_array_transp_bis(ipoint,k,3)) * v_1b_square_grad(ipoint,3) )
|
||||||
|
|
||||||
|
int = int + weight1 * int2_u2_j1b2(j,l,ipoint)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
return
|
||||||
|
end subroutine I_grade_gradu_seminaive
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
subroutine aos_ik_grad1_esquare(i, k, r1, val)
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: i, k
|
||||||
|
double precision, intent(in) :: r1(3)
|
||||||
|
double precision, intent(out) :: val(3)
|
||||||
|
double precision :: tmp
|
||||||
|
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 grad1_j1b_nucl_square_num(r1, der)
|
||||||
|
|
||||||
|
tmp = aos_array(i) * aos_array(k)
|
||||||
|
val(1) = tmp * der(1)
|
||||||
|
val(2) = tmp * der(2)
|
||||||
|
val(3) = tmp * der(3)
|
||||||
|
|
||||||
|
return
|
||||||
|
end subroutine phi_ik_grad1_esquare
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
subroutine grad1_aos_ik_grad1_esquare(i, k, r1, grad)
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: i, k
|
||||||
|
double precision, intent(in) :: r1(3)
|
||||||
|
double precision, intent(out) :: grad(3)
|
||||||
|
double precision :: r(3), eps, tmp_eps, val_p(3), val_m(3)
|
||||||
|
|
||||||
|
eps = 1d-5
|
||||||
|
tmp_eps = 0.5d0 / eps
|
||||||
|
|
||||||
|
r(1:3) = r1(1:3)
|
||||||
|
|
||||||
|
r(1) = r(1) + eps
|
||||||
|
call aos_ik_grad1_esquare(i, k, r, val_p)
|
||||||
|
r(1) = r(1) - 2.d0 * eps
|
||||||
|
call aos_ik_grad1_esquare(i, k, r, val_m)
|
||||||
|
r(1) = r(1) + eps
|
||||||
|
grad(1) = tmp_eps * (val_p(1) - val_m(1))
|
||||||
|
|
||||||
|
r(2) = r(2) + eps
|
||||||
|
call aos_ik_grad1_esquare(i, k, r, val_p)
|
||||||
|
r(2) = r(2) - 2.d0 * eps
|
||||||
|
call aos_ik_grad1_esquare(i, k, r, val_m)
|
||||||
|
r(2) = r(2) + eps
|
||||||
|
grad(2) = tmp_eps * (val_p(2) - val_m(2))
|
||||||
|
|
||||||
|
r(3) = r(3) + eps
|
||||||
|
call aos_ik_grad1_esquare(i, k, r, val_p)
|
||||||
|
r(3) = r(3) - 2.d0 * eps
|
||||||
|
call aos_ik_grad1_esquare(i, k, r, val_m)
|
||||||
|
r(3) = r(3) + eps
|
||||||
|
grad(3) = tmp_eps * (val_p(3) - val_m(3))
|
||||||
|
|
||||||
|
return
|
||||||
|
end subroutine grad1_aos_ik_grad1_esquare
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
@ -11,6 +11,13 @@ BEGIN_PROVIDER [double precision, ao_vartc_int_chemist, (ao_num, ao_num, ao_num,
|
|||||||
call wall_time(wall0)
|
call wall_time(wall0)
|
||||||
|
|
||||||
if(test_cycle_tc) then
|
if(test_cycle_tc) then
|
||||||
|
|
||||||
|
PROVIDE j1b_type
|
||||||
|
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
|
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
|
||||||
@ -20,7 +27,9 @@ BEGIN_PROVIDER [double precision, ao_vartc_int_chemist, (ao_num, ao_num, ao_num,
|
|||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
else
|
else
|
||||||
|
|
||||||
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
|
||||||
@ -30,6 +39,7 @@ BEGIN_PROVIDER [double precision, ao_vartc_int_chemist, (ao_num, ao_num, ao_num,
|
|||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
endif
|
endif
|
||||||
|
|
||||||
call wall_time(wall1)
|
call wall_time(wall1)
|
||||||
@ -48,9 +58,20 @@ BEGIN_PROVIDER [double precision, ao_tc_int_chemist, (ao_num, ao_num, ao_num, ao
|
|||||||
print *, ' providing ao_tc_int_chemist ...'
|
print *, ' providing ao_tc_int_chemist ...'
|
||||||
call wall_time(wall0)
|
call wall_time(wall0)
|
||||||
|
|
||||||
if(test_cycle_tc)then
|
if(test_cycle_tc) then
|
||||||
|
|
||||||
|
PROVIDE j1b_type
|
||||||
|
if(j1b_type .ne. 3) then
|
||||||
|
print*, ' TC integrals with cycle can not be used for j1b_type =', j1b_type
|
||||||
|
stop
|
||||||
|
endif
|
||||||
|
|
||||||
ao_tc_int_chemist = ao_tc_int_chemist_test
|
ao_tc_int_chemist = ao_tc_int_chemist_test
|
||||||
|
|
||||||
else
|
else
|
||||||
|
|
||||||
|
PROVIDE tc_grad_square_ao tc_grad_and_lapl_ao ao_two_e_coul
|
||||||
|
|
||||||
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
|
||||||
@ -68,27 +89,34 @@ BEGIN_PROVIDER [double precision, ao_tc_int_chemist, (ao_num, ao_num, ao_num, ao
|
|||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
BEGIN_PROVIDER [double precision, ao_tc_int_chemist_no_cycle, (ao_num, ao_num, ao_num, ao_num)]
|
|
||||||
! ---
|
! ---
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [double precision, ao_tc_int_chemist_no_cycle, (ao_num, ao_num, ao_num, ao_num)]
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
integer :: i, j, k, l
|
integer :: i, j, k, l
|
||||||
double precision :: wall1, wall0
|
double precision :: wall1, wall0
|
||||||
|
|
||||||
print *, ' providing ao_tc_int_chemist_no_cycle ...'
|
print *, ' providing ao_tc_int_chemist_no_cycle ...'
|
||||||
call wall_time(wall0)
|
call wall_time(wall0)
|
||||||
do j = 1, ao_num
|
|
||||||
do l = 1, ao_num
|
do j = 1, ao_num
|
||||||
do i = 1, ao_num
|
do l = 1, ao_num
|
||||||
do k = 1, ao_num
|
do i = 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)
|
do k = 1, ao_num
|
||||||
! ao_tc_int_chemist(k,i,l,j) = ao_two_e_coul(k,i,l,j)
|
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)
|
||||||
enddo
|
!ao_tc_int_chemist(k,i,l,j) = ao_two_e_coul(k,i,l,j)
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
call wall_time(wall1)
|
call wall_time(wall1)
|
||||||
print *, ' wall time for ao_tc_int_chemist_no_cycle ', wall1 - wall0
|
print *, ' wall time for ao_tc_int_chemist_no_cycle ', wall1 - wall0
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
BEGIN_PROVIDER [double precision, ao_tc_int_chemist_test, (ao_num, ao_num, ao_num, ao_num)]
|
BEGIN_PROVIDER [double precision, ao_tc_int_chemist_test, (ao_num, ao_num, ao_num, ao_num)]
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
|
@ -27,7 +27,7 @@ subroutine get_delta_bitc_right(psidet, psicoef, ndet, Nint, delta)
|
|||||||
|
|
||||||
i = 1
|
i = 1
|
||||||
j = 1
|
j = 1
|
||||||
call htilde_mu_mat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
|
call htilde_mu_mat_bi_ortho_slow(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
|
||||||
call hmat_bi_ortho (psidet(1,1,i), psidet(1,1,j), Nint, h_mono, h_twoe, h_tot)
|
call hmat_bi_ortho (psidet(1,1,i), psidet(1,1,j), Nint, h_mono, h_twoe, h_tot)
|
||||||
|
|
||||||
delta = 0.d0
|
delta = 0.d0
|
||||||
@ -39,7 +39,7 @@ subroutine get_delta_bitc_right(psidet, psicoef, ndet, Nint, delta)
|
|||||||
do j = 1, ndet
|
do j = 1, ndet
|
||||||
|
|
||||||
! < I | Htilde | J >
|
! < I | Htilde | J >
|
||||||
call htilde_mu_mat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
|
call htilde_mu_mat_bi_ortho_slow(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
|
||||||
! < I | H | J >
|
! < I | H | J >
|
||||||
call hmat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, h_mono, h_twoe, h_tot)
|
call hmat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, h_mono, h_twoe, h_tot)
|
||||||
|
|
||||||
@ -78,7 +78,7 @@ subroutine get_htc_bitc_right(psidet, psicoef, ndet, Nint, delta)
|
|||||||
|
|
||||||
i = 1
|
i = 1
|
||||||
j = 1
|
j = 1
|
||||||
call htilde_mu_mat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
|
call htilde_mu_mat_bi_ortho_slow(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
|
||||||
|
|
||||||
delta = 0.d0
|
delta = 0.d0
|
||||||
!$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) &
|
!$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) &
|
||||||
@ -88,7 +88,7 @@ subroutine get_htc_bitc_right(psidet, psicoef, ndet, Nint, delta)
|
|||||||
do j = 1, ndet
|
do j = 1, ndet
|
||||||
|
|
||||||
! < I | Htilde | J >
|
! < I | Htilde | J >
|
||||||
call htilde_mu_mat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
|
call htilde_mu_mat_bi_ortho_slow(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
|
||||||
|
|
||||||
delta(i) = delta(i) + psicoef(j) * htc_tot
|
delta(i) = delta(i) + psicoef(j) * htc_tot
|
||||||
enddo
|
enddo
|
||||||
|
@ -2,7 +2,7 @@
|
|||||||
BEGIN_PROVIDER [ double precision, e_tilde_00]
|
BEGIN_PROVIDER [ double precision, e_tilde_00]
|
||||||
implicit none
|
implicit none
|
||||||
double precision :: hmono,htwoe,hthree,htot
|
double precision :: hmono,htwoe,hthree,htot
|
||||||
call htilde_mu_mat_bi_ortho(HF_bitmask,HF_bitmask,N_int,hmono,htwoe,hthree,htot)
|
call htilde_mu_mat_bi_ortho_slow(HF_bitmask,HF_bitmask,N_int,hmono,htwoe,hthree,htot)
|
||||||
e_tilde_00 = htot
|
e_tilde_00 = htot
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
@ -18,11 +18,11 @@
|
|||||||
do i = 1, N_det
|
do i = 1, N_det
|
||||||
call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
|
call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
|
||||||
if(degree == 1 .or. degree == 2)then
|
if(degree == 1 .or. degree == 2)then
|
||||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
|
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
|
||||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0)
|
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0)
|
||||||
delta_e = e_tilde_00 - e_i0
|
delta_e = e_tilde_00 - e_i0
|
||||||
coef_pt1 = htilde_ij / delta_e
|
coef_pt1 = htilde_ij / delta_e
|
||||||
call htilde_mu_mat_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
|
call htilde_mu_mat_bi_ortho_slow(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
|
||||||
e_pt2_tc_bi_orth += coef_pt1 * htilde_ij
|
e_pt2_tc_bi_orth += coef_pt1 * htilde_ij
|
||||||
if(degree == 1)then
|
if(degree == 1)then
|
||||||
e_pt2_tc_bi_orth_single += coef_pt1 * htilde_ij
|
e_pt2_tc_bi_orth_single += coef_pt1 * htilde_ij
|
||||||
@ -37,7 +37,7 @@
|
|||||||
BEGIN_PROVIDER [ double precision, e_tilde_bi_orth_00]
|
BEGIN_PROVIDER [ double precision, e_tilde_bi_orth_00]
|
||||||
implicit none
|
implicit none
|
||||||
double precision :: hmono,htwoe,hthree,htilde_ij
|
double precision :: hmono,htwoe,hthree,htilde_ij
|
||||||
call htilde_mu_mat_bi_ortho(HF_bitmask,HF_bitmask,N_int,hmono,htwoe,hthree,e_tilde_bi_orth_00)
|
call htilde_mu_mat_bi_ortho_slow(HF_bitmask,HF_bitmask,N_int,hmono,htwoe,hthree,e_tilde_bi_orth_00)
|
||||||
e_tilde_bi_orth_00 += nuclear_repulsion
|
e_tilde_bi_orth_00 += nuclear_repulsion
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
@ -45,6 +45,9 @@
|
|||||||
&BEGIN_PROVIDER [ double precision, e_corr_bi_orth_proj ]
|
&BEGIN_PROVIDER [ double precision, e_corr_bi_orth_proj ]
|
||||||
&BEGIN_PROVIDER [ double precision, e_corr_single_bi_orth ]
|
&BEGIN_PROVIDER [ double precision, e_corr_single_bi_orth ]
|
||||||
&BEGIN_PROVIDER [ double precision, e_corr_double_bi_orth ]
|
&BEGIN_PROVIDER [ double precision, e_corr_double_bi_orth ]
|
||||||
|
&BEGIN_PROVIDER [ double precision, e_corr_bi_orth_proj_abs ]
|
||||||
|
&BEGIN_PROVIDER [ double precision, e_corr_single_bi_orth_abs ]
|
||||||
|
&BEGIN_PROVIDER [ double precision, e_corr_double_bi_orth_abs ]
|
||||||
implicit none
|
implicit none
|
||||||
integer :: i,degree
|
integer :: i,degree
|
||||||
double precision :: hmono,htwoe,hthree,htilde_ij
|
double precision :: hmono,htwoe,hthree,htilde_ij
|
||||||
@ -54,16 +57,18 @@
|
|||||||
e_corr_double_bi_orth = 0.d0
|
e_corr_double_bi_orth = 0.d0
|
||||||
do i = 1, N_det
|
do i = 1, N_det
|
||||||
call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
|
call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
|
||||||
call htilde_mu_mat_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
|
call htilde_mu_mat_bi_ortho_slow(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
|
||||||
if(degree == 1)then
|
if(degree == 1)then
|
||||||
e_corr_single_bi_orth += reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1)
|
e_corr_single_bi_orth += reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1)
|
||||||
|
e_corr_single_bi_orth_abs += dabs(reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1))
|
||||||
else if(degree == 2)then
|
else if(degree == 2)then
|
||||||
e_corr_double_bi_orth += reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1)
|
e_corr_double_bi_orth += reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1)
|
||||||
! print*,'coef_wf , e_cor',reigvec_tc_bi_orth(i,1)/reigvec_tc_bi_orth(1,1), reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1)
|
e_corr_double_bi_orth_abs += dabs(reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1))
|
||||||
endif
|
endif
|
||||||
enddo
|
enddo
|
||||||
e_corr_bi_orth_proj = e_corr_single_bi_orth + e_corr_double_bi_orth
|
e_corr_bi_orth_proj = e_corr_single_bi_orth + e_corr_double_bi_orth
|
||||||
e_corr_bi_orth = eigval_right_tc_bi_orth(1) - e_tilde_bi_orth_00
|
e_corr_bi_orth = eigval_right_tc_bi_orth(1) - e_tilde_bi_orth_00
|
||||||
|
e_corr_bi_orth_proj_abs = e_corr_single_bi_orth_abs + e_corr_double_bi_orth_abs
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
BEGIN_PROVIDER [ double precision, e_tc_left_right ]
|
BEGIN_PROVIDER [ double precision, e_tc_left_right ]
|
||||||
@ -75,7 +80,7 @@
|
|||||||
do i = 1, N_det
|
do i = 1, N_det
|
||||||
accu += reigvec_tc_bi_orth(i,1) * leigvec_tc_bi_orth(i,1)
|
accu += reigvec_tc_bi_orth(i,1) * leigvec_tc_bi_orth(i,1)
|
||||||
do j = 1, N_det
|
do j = 1, N_det
|
||||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,j),psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
|
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j),psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
|
||||||
e_tc_left_right += htilde_ij * reigvec_tc_bi_orth(i,1) * leigvec_tc_bi_orth(j,1)
|
e_tc_left_right += htilde_ij * reigvec_tc_bi_orth(i,1) * leigvec_tc_bi_orth(j,1)
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
@ -94,8 +99,8 @@ BEGIN_PROVIDER [ double precision, coef_pt1_bi_ortho, (N_det)]
|
|||||||
if(degree==0)then
|
if(degree==0)then
|
||||||
coef_pt1_bi_ortho(i) = 1.d0
|
coef_pt1_bi_ortho(i) = 1.d0
|
||||||
else
|
else
|
||||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
|
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
|
||||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0)
|
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0)
|
||||||
delta_e = e_tilde_00 - e_i0
|
delta_e = e_tilde_00 - e_i0
|
||||||
coef_pt1 = htilde_ij / delta_e
|
coef_pt1 = htilde_ij / delta_e
|
||||||
coef_pt1_bi_ortho(i)= coef_pt1
|
coef_pt1_bi_ortho(i)= coef_pt1
|
||||||
|
@ -1,4 +1,4 @@
|
|||||||
subroutine htc_bi_ortho_calc_tdav(v, u, N_st, sze)
|
subroutine htc_bi_ortho_calc_tdav_slow(v, u, N_st, sze)
|
||||||
|
|
||||||
use bitmasks
|
use bitmasks
|
||||||
|
|
||||||
@ -27,7 +27,7 @@ subroutine htc_bi_ortho_calc_tdav(v, u, N_st, sze)
|
|||||||
|
|
||||||
i = 1
|
i = 1
|
||||||
j = 1
|
j = 1
|
||||||
call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,j), N_int, htot)
|
call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,i), psi_det(1,1,j), N_int, htot)
|
||||||
|
|
||||||
v = 0.d0
|
v = 0.d0
|
||||||
!$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) &
|
!$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) &
|
||||||
@ -36,7 +36,7 @@ subroutine htc_bi_ortho_calc_tdav(v, u, N_st, sze)
|
|||||||
do istate = 1, N_st
|
do istate = 1, N_st
|
||||||
do i = 1, sze
|
do i = 1, sze
|
||||||
do j = 1, sze
|
do j = 1, sze
|
||||||
call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,j), N_int, htot)
|
call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,i), psi_det(1,1,j), N_int, htot)
|
||||||
v(i,istate) = v(i,istate) + htot * u(j,istate)
|
v(i,istate) = v(i,istate) + htot * u(j,istate)
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
@ -45,7 +45,7 @@ subroutine htc_bi_ortho_calc_tdav(v, u, N_st, sze)
|
|||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
subroutine htcdag_bi_ortho_calc_tdav(v, u, N_st, sze)
|
subroutine htcdag_bi_ortho_calc_tdav_slow(v, u, N_st, sze)
|
||||||
|
|
||||||
use bitmasks
|
use bitmasks
|
||||||
|
|
||||||
@ -71,7 +71,7 @@ subroutine htcdag_bi_ortho_calc_tdav(v, u, N_st, sze)
|
|||||||
|
|
||||||
i = 1
|
i = 1
|
||||||
j = 1
|
j = 1
|
||||||
call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,j), N_int, htot)
|
call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,i), psi_det(1,1,j), N_int, htot)
|
||||||
|
|
||||||
v = 0.d0
|
v = 0.d0
|
||||||
|
|
||||||
@ -81,7 +81,7 @@ subroutine htcdag_bi_ortho_calc_tdav(v, u, N_st, sze)
|
|||||||
do istate = 1, N_st
|
do istate = 1, N_st
|
||||||
do i = 1, sze
|
do i = 1, sze
|
||||||
do j = 1, sze
|
do j = 1, sze
|
||||||
call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,j), psi_det(1,1,i), N_int, htot)
|
call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, htot)
|
||||||
v(i,istate) = v(i,istate) + htot * u(j,istate)
|
v(i,istate) = v(i,istate) + htot * u(j,istate)
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
|
@ -1,7 +1,6 @@
|
|||||||
|
|
||||||
subroutine get_H_tc_s2_l0_r0(l_0,r_0,N_st,sze,energies, s2)
|
subroutine get_H_tc_s2_l0_r0(l_0, r_0, N_st, sze, energies, s2)
|
||||||
use bitmasks
|
|
||||||
implicit none
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Computes $e_0 = \langle l_0 | H | r_0\rangle$.
|
! Computes $e_0 = \langle l_0 | H | r_0\rangle$.
|
||||||
!
|
!
|
||||||
@ -11,26 +10,34 @@ subroutine get_H_tc_s2_l0_r0(l_0,r_0,N_st,sze,energies, s2)
|
|||||||
!
|
!
|
||||||
! istart, iend, ishift, istep are used in ZMQ parallelization.
|
! istart, iend, ishift, istep are used in ZMQ parallelization.
|
||||||
END_DOC
|
END_DOC
|
||||||
integer, intent(in) :: N_st,sze
|
|
||||||
double precision, intent(inout) :: l_0(sze,N_st), r_0(sze,N_st)
|
use bitmasks
|
||||||
double precision, intent(out) :: energies(N_st), s2(N_st)
|
implicit none
|
||||||
logical :: do_right
|
|
||||||
integer :: istate
|
integer, intent(in) :: N_st,sze
|
||||||
|
double precision, intent(in) :: l_0(sze,N_st), r_0(sze,N_st)
|
||||||
|
double precision, intent(out) :: energies(N_st), s2(N_st)
|
||||||
|
logical :: do_right
|
||||||
|
integer :: istate
|
||||||
double precision, allocatable :: s_0(:,:), v_0(:,:)
|
double precision, allocatable :: s_0(:,:), v_0(:,:)
|
||||||
double precision :: u_dot_v, norm
|
double precision :: u_dot_v, norm
|
||||||
|
|
||||||
allocate(s_0(sze,N_st), v_0(sze,N_st))
|
allocate(s_0(sze,N_st), v_0(sze,N_st))
|
||||||
do_right = .True.
|
do_right = .True.
|
||||||
call H_tc_s2_u_0_opt(v_0,s_0,r_0,N_st,sze)
|
call H_tc_s2_u_0_opt(v_0, s_0, r_0, N_st, sze)
|
||||||
|
|
||||||
do istate = 1, N_st
|
do istate = 1, N_st
|
||||||
norm = u_dot_v(l_0(1,istate),r_0(1,istate),sze)
|
norm = u_dot_v(l_0(1,istate),r_0(1,istate),sze)
|
||||||
energies(istate) = u_dot_v(l_0(1,istate),v_0(1,istate),sze)/norm
|
energies(istate) = u_dot_v(l_0(1,istate),v_0(1,istate),sze)/norm
|
||||||
s2(istate) = u_dot_v(l_0(1,istate),s_0(1,istate),sze)/norm
|
s2(istate) = u_dot_v(l_0(1,istate),s_0(1,istate),sze)/norm
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
subroutine H_tc_s2_u_0_opt(v_0,s_0,u_0,N_st,sze)
|
! ---
|
||||||
use bitmasks
|
|
||||||
implicit none
|
subroutine H_tc_s2_u_0_opt(v_0, s_0, u_0, N_st, sze)
|
||||||
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Computes $v_0 = H | u_0\rangle$.
|
! Computes $v_0 = H | u_0\rangle$.
|
||||||
!
|
!
|
||||||
@ -38,16 +45,24 @@ subroutine H_tc_s2_u_0_opt(v_0,s_0,u_0,N_st,sze)
|
|||||||
!
|
!
|
||||||
! istart, iend, ishift, istep are used in ZMQ parallelization.
|
! istart, iend, ishift, istep are used in ZMQ parallelization.
|
||||||
END_DOC
|
END_DOC
|
||||||
integer, intent(in) :: N_st,sze
|
|
||||||
double precision, intent(inout) :: v_0(sze,N_st), u_0(sze,N_st), s_0(sze,N_st)
|
use bitmasks
|
||||||
logical :: do_right
|
implicit none
|
||||||
|
|
||||||
|
integer, intent(in) :: N_st,sze
|
||||||
|
double precision, intent(in) :: u_0(sze,N_st)
|
||||||
|
double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st)
|
||||||
|
logical :: do_right
|
||||||
|
|
||||||
do_right = .True.
|
do_right = .True.
|
||||||
call H_tc_s2_u_0_nstates_openmp(v_0,s_0,u_0,N_st,sze, do_right)
|
call H_tc_s2_u_0_nstates_openmp(v_0, s_0, u_0, N_st, sze, do_right)
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
subroutine H_tc_s2_dagger_u_0_opt(v_0,s_0,u_0,N_st,sze)
|
! ---
|
||||||
use bitmasks
|
|
||||||
implicit none
|
subroutine H_tc_s2_dagger_u_0_opt(v_0, s_0, u_0, N_st, sze)
|
||||||
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Computes $v_0 = H | u_0\rangle$.
|
! Computes $v_0 = H | u_0\rangle$.
|
||||||
!
|
!
|
||||||
@ -55,17 +70,23 @@ subroutine H_tc_s2_dagger_u_0_opt(v_0,s_0,u_0,N_st,sze)
|
|||||||
!
|
!
|
||||||
! istart, iend, ishift, istep are used in ZMQ parallelization.
|
! istart, iend, ishift, istep are used in ZMQ parallelization.
|
||||||
END_DOC
|
END_DOC
|
||||||
integer, intent(in) :: N_st,sze
|
|
||||||
double precision, intent(inout) :: v_0(sze,N_st), u_0(sze,N_st), s_0(sze,N_st)
|
|
||||||
logical :: do_right
|
|
||||||
do_right = .False.
|
|
||||||
call H_tc_s2_u_0_nstates_openmp(v_0,s_0,u_0,N_st,sze, do_right)
|
|
||||||
end
|
|
||||||
|
|
||||||
|
|
||||||
subroutine H_tc_s2_u_0_nstates_openmp(v_0,s_0,u_0,N_st,sze, do_right)
|
|
||||||
use bitmasks
|
use bitmasks
|
||||||
implicit none
|
implicit none
|
||||||
|
integer, intent(in) :: N_st,sze
|
||||||
|
double precision, intent(in) :: u_0(sze,N_st)
|
||||||
|
double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st)
|
||||||
|
logical :: do_right
|
||||||
|
|
||||||
|
do_right = .False.
|
||||||
|
call H_tc_s2_u_0_nstates_openmp(v_0, s_0, u_0, N_st, sze, do_right)
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
subroutine H_tc_s2_u_0_nstates_openmp(v_0, s_0, u_0, N_st, sze, do_right)
|
||||||
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Computes $v_0 = H | u_0\rangle$.
|
! Computes $v_0 = H | u_0\rangle$.
|
||||||
!
|
!
|
||||||
@ -75,12 +96,18 @@ subroutine H_tc_s2_u_0_nstates_openmp(v_0,s_0,u_0,N_st,sze, do_right)
|
|||||||
!
|
!
|
||||||
! if do_right == True then you compute H_TC |Psi>, else H_TC^T |Psi>
|
! if do_right == True then you compute H_TC |Psi>, else H_TC^T |Psi>
|
||||||
END_DOC
|
END_DOC
|
||||||
integer, intent(in) :: N_st,sze
|
|
||||||
double precision, intent(inout) :: v_0(sze,N_st), u_0(sze,N_st), s_0(sze,N_st)
|
use bitmasks
|
||||||
logical, intent(in) :: do_right
|
implicit none
|
||||||
integer :: k
|
|
||||||
double precision, allocatable :: u_t(:,:), v_t(:,:), s_t(:,:)
|
integer, intent(in) :: N_st,sze
|
||||||
|
logical, intent(in) :: do_right
|
||||||
|
double precision, intent(in) :: u_0(sze,N_st)
|
||||||
|
double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st)
|
||||||
|
integer :: k
|
||||||
|
double precision, allocatable :: u_t(:,:), v_t(:,:), s_t(:,:)
|
||||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t
|
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t
|
||||||
|
|
||||||
allocate(u_t(N_st,N_det),v_t(N_st,N_det),s_t(N_st,N_det))
|
allocate(u_t(N_st,N_det),v_t(N_st,N_det),s_t(N_st,N_det))
|
||||||
do k=1,N_st
|
do k=1,N_st
|
||||||
call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det)
|
call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det)
|
||||||
@ -119,6 +146,7 @@ subroutine H_tc_s2_u_0_nstates_openmp(v_0,s_0,u_0,N_st,sze, do_right)
|
|||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
subroutine H_tc_s2_u_0_nstates_openmp_work(v_t,s_t,u_t,N_st,sze,istart,iend,ishift,istep, do_right)
|
subroutine H_tc_s2_u_0_nstates_openmp_work(v_t,s_t,u_t,N_st,sze,istart,iend,ishift,istep, do_right)
|
||||||
use bitmasks
|
use bitmasks
|
||||||
|
@ -48,10 +48,16 @@ BEGIN_PROVIDER [ double precision, normal_two_body_bi_orth, (mo_num, mo_num, mo_
|
|||||||
h2 = list_act(hh2)
|
h2 = list_act(hh2)
|
||||||
do pp2 = 1, n_act_orb
|
do pp2 = 1, n_act_orb
|
||||||
p2 = list_act(pp2)
|
p2 = list_act(pp2)
|
||||||
! opposite spin double excitations
|
! all contributions from the 3-e terms to the double excitations
|
||||||
|
! s1:(h1-->p1), s2:(h2-->p2) from the HF reference determinant
|
||||||
|
|
||||||
|
|
||||||
|
! opposite spin double excitations : s1 /= s2
|
||||||
call give_aba_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree_aba)
|
call give_aba_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree_aba)
|
||||||
! same spin double excitations with opposite spin contributions
|
|
||||||
|
! same spin double excitations : s1 == s2
|
||||||
if(h1<h2.and.p1.gt.p2)then
|
if(h1<h2.and.p1.gt.p2)then
|
||||||
|
! with opposite spin contributions
|
||||||
call give_aab_contraction(N_int, h2, h1, p1, p2, Ne, occ, hthree_aab) ! exchange h1<->h2
|
call give_aab_contraction(N_int, h2, h1, p1, p2, Ne, occ, hthree_aab) ! exchange h1<->h2
|
||||||
! same spin double excitations with same spin contributions
|
! same spin double excitations with same spin contributions
|
||||||
if(Ne(2).ge.3)then
|
if(Ne(2).ge.3)then
|
||||||
@ -60,8 +66,10 @@ BEGIN_PROVIDER [ double precision, normal_two_body_bi_orth, (mo_num, mo_num, mo_
|
|||||||
hthree_aaa = 0.d0
|
hthree_aaa = 0.d0
|
||||||
endif
|
endif
|
||||||
else
|
else
|
||||||
|
! with opposite spin contributions
|
||||||
call give_aab_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree_aab)
|
call give_aab_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree_aab)
|
||||||
if(Ne(2).ge.3)then
|
if(Ne(2).ge.3)then
|
||||||
|
! same spin double excitations with same spin contributions
|
||||||
call give_aaa_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree_aaa)
|
call give_aaa_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree_aaa)
|
||||||
else
|
else
|
||||||
hthree_aaa = 0.d0
|
hthree_aaa = 0.d0
|
||||||
@ -246,6 +254,9 @@ END_PROVIDER
|
|||||||
|
|
||||||
subroutine give_aaa_contraction(Nint, h1, h2, p1, p2, Ne, occ, hthree)
|
subroutine give_aaa_contraction(Nint, h1, h2, p1, p2, Ne, occ, hthree)
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
! pure same spin contribution to same spin double excitation s1=h1,p1, s2=h2,p2, with s1==s2
|
||||||
|
END_DOC
|
||||||
use bitmasks ! you need to include the bitmasks_module.f90 features
|
use bitmasks ! you need to include the bitmasks_module.f90 features
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
|
@ -1,4 +1,4 @@
|
|||||||
program tc_bi_ortho
|
program print_tc_energy
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! TODO : Put the documentation of the program here
|
! TODO : Put the documentation of the program here
|
||||||
@ -9,7 +9,11 @@ program tc_bi_ortho
|
|||||||
my_n_pt_a_grid = 50
|
my_n_pt_a_grid = 50
|
||||||
read_wf = .True.
|
read_wf = .True.
|
||||||
touch read_wf
|
touch read_wf
|
||||||
|
|
||||||
|
PROVIDE j1b_type
|
||||||
|
print*, 'j1b_type = ', j1b_type
|
||||||
|
|
||||||
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
|
||||||
call routine_save_left_right_bi_ortho
|
call write_tc_energy
|
||||||
! call test
|
|
||||||
end
|
end
|
||||||
|
|
20
src/tc_bi_ortho/print_tc_var.irp.f
Normal file
20
src/tc_bi_ortho/print_tc_var.irp.f
Normal file
@ -0,0 +1,20 @@
|
|||||||
|
program print_tc_var
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
! TODO : Put the documentation of the program here
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
print *, 'Hello world'
|
||||||
|
my_grid_becke = .True.
|
||||||
|
my_n_pt_r_grid = 30
|
||||||
|
my_n_pt_a_grid = 50
|
||||||
|
read_wf = .True.
|
||||||
|
touch read_wf
|
||||||
|
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||||
|
|
||||||
|
call write_tc_var()
|
||||||
|
|
||||||
|
end
|
||||||
|
|
@ -26,7 +26,8 @@ subroutine write_l_r_wf
|
|||||||
integer :: i
|
integer :: i
|
||||||
print*,'Writing the left-right wf'
|
print*,'Writing the left-right wf'
|
||||||
do i = 1, N_det
|
do i = 1, N_det
|
||||||
write(i_unit_output,*)i,psi_l_coef_sorted_bi_ortho_left(i),psi_r_coef_sorted_bi_ortho_right(i)
|
write(i_unit_output,*)i, psi_l_coef_sorted_bi_ortho_left(i)/psi_l_coef_sorted_bi_ortho_left(1) &
|
||||||
|
, psi_r_coef_sorted_bi_ortho_right(i)/psi_r_coef_sorted_bi_ortho_right(1)
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
|
|
||||||
@ -48,12 +49,12 @@ subroutine routine
|
|||||||
do i = 1, N_det
|
do i = 1, N_det
|
||||||
call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
|
call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
|
||||||
if(degree == 1 .or. degree == 2)then
|
if(degree == 1 .or. degree == 2)then
|
||||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
|
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
|
||||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0)
|
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0)
|
||||||
delta_e = e_tilde_00 - e_i0
|
delta_e = e_tilde_00 - e_i0
|
||||||
coef_pt1 = htilde_ij / delta_e
|
coef_pt1 = htilde_ij / delta_e
|
||||||
|
|
||||||
call htilde_mu_mat_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
|
call htilde_mu_mat_bi_ortho_slow(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
|
||||||
contrib_pt = coef_pt1 * htilde_ij
|
contrib_pt = coef_pt1 * htilde_ij
|
||||||
e_pt2 += contrib_pt
|
e_pt2 += contrib_pt
|
||||||
|
|
||||||
|
@ -17,6 +17,8 @@ BEGIN_PROVIDER [ double precision, psi_bitcleft_bilinear_matrix_values, (N_det,
|
|||||||
implicit none
|
implicit none
|
||||||
integer :: k, l
|
integer :: k, l
|
||||||
|
|
||||||
|
!print *, ' providing psi_bitcleft_bilinear_matrix_values'
|
||||||
|
|
||||||
if(N_det .eq. 1) then
|
if(N_det .eq. 1) then
|
||||||
|
|
||||||
do l = 1, N_states
|
do l = 1, N_states
|
||||||
@ -38,6 +40,8 @@ BEGIN_PROVIDER [ double precision, psi_bitcleft_bilinear_matrix_values, (N_det,
|
|||||||
|
|
||||||
endif
|
endif
|
||||||
|
|
||||||
|
!print *, ' psi_bitcleft_bilinear_matrix_values OK'
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
@ -136,7 +136,7 @@ BEGIN_PROVIDER [ double precision, psi_r_coef_bi_ortho, (psi_det_size,N_states)
|
|||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
subroutine save_tc_wavefunction_general(ndet,nstates,psidet,sze,dim_psicoef,psilcoef,psircoef)
|
subroutine save_tc_wavefunction_general(ndet, nstates, psidet, sze, dim_psicoef, psilcoef, psircoef)
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Save the wave function into the |EZFIO| file
|
! Save the wave function into the |EZFIO| file
|
||||||
@ -192,37 +192,78 @@ subroutine save_tc_wavefunction_general(ndet,nstates,psidet,sze,dim_psicoef,psil
|
|||||||
endif
|
endif
|
||||||
end
|
end
|
||||||
|
|
||||||
subroutine save_tc_bi_ortho_wavefunction
|
! ---
|
||||||
implicit none
|
|
||||||
if(save_sorted_tc_wf)then
|
subroutine save_tc_bi_ortho_wavefunction()
|
||||||
call save_tc_wavefunction_general(N_det,N_states,psi_det_sorted_tc,size(psi_det_sorted_tc, 3),size(psi_l_coef_sorted_bi_ortho, 1),psi_l_coef_sorted_bi_ortho,psi_r_coef_sorted_bi_ortho)
|
|
||||||
else
|
implicit none
|
||||||
call save_tc_wavefunction_general(N_det,N_states,psi_det,size(psi_det, 3), size(psi_l_coef_bi_ortho, 1),psi_l_coef_bi_ortho,psi_r_coef_bi_ortho)
|
|
||||||
endif
|
if(save_sorted_tc_wf) then
|
||||||
call routine_save_right_bi_ortho
|
|
||||||
|
call save_tc_wavefunction_general( N_det, N_states, psi_det_sorted_tc, size(psi_det_sorted_tc, 3) &
|
||||||
|
, size(psi_l_coef_sorted_bi_ortho, 1), psi_l_coef_sorted_bi_ortho, psi_r_coef_sorted_bi_ortho)
|
||||||
|
call routine_save_right_sorted_bi_ortho()
|
||||||
|
|
||||||
|
else
|
||||||
|
|
||||||
|
call save_tc_wavefunction_general( N_det, N_states, psi_det, size(psi_det, 3) &
|
||||||
|
, size(psi_l_coef_bi_ortho, 1), psi_l_coef_bi_ortho, psi_r_coef_bi_ortho )
|
||||||
|
call routine_save_right_bi_ortho()
|
||||||
|
|
||||||
|
endif
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
subroutine routine_save_right_bi_ortho
|
! ---
|
||||||
implicit none
|
|
||||||
double precision, allocatable :: coef_tmp(:,:)
|
subroutine routine_save_right_sorted_bi_ortho()
|
||||||
integer :: i
|
|
||||||
allocate(coef_tmp(N_det, N_states))
|
implicit none
|
||||||
do i = 1, N_det
|
integer :: i
|
||||||
coef_tmp(i,1:N_states) = psi_r_coef_sorted_bi_ortho(i,1:N_states)
|
double precision, allocatable :: coef_tmp(:,:)
|
||||||
enddo
|
|
||||||
call save_wavefunction_general_unormalized(N_det,N_states,psi_det_sorted_tc,size(coef_tmp,1),coef_tmp(1,1))
|
allocate(coef_tmp(N_det, N_states))
|
||||||
|
do i = 1, N_det
|
||||||
|
coef_tmp(i,1:N_states) = psi_r_coef_sorted_bi_ortho(i,1:N_states)
|
||||||
|
enddo
|
||||||
|
call save_wavefunction_general_unormalized(N_det, N_states, psi_det_sorted_tc, size(coef_tmp, 1), coef_tmp(1,1))
|
||||||
|
deallocate(coef_tmp)
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
subroutine routine_save_left_right_bi_ortho
|
subroutine routine_save_left_right_sorted_bi_ortho()
|
||||||
implicit none
|
|
||||||
double precision, allocatable :: coef_tmp(:,:)
|
implicit none
|
||||||
integer :: i,n_states_tmp
|
integer :: i, n_states_tmp
|
||||||
n_states_tmp = 2
|
double precision, allocatable :: coef_tmp(:,:)
|
||||||
allocate(coef_tmp(N_det, n_states_tmp))
|
|
||||||
do i = 1, N_det
|
n_states_tmp = 2
|
||||||
coef_tmp(i,1) = psi_r_coef_bi_ortho(i,1)
|
allocate(coef_tmp(N_det, n_states_tmp))
|
||||||
coef_tmp(i,2) = psi_l_coef_bi_ortho(i,1)
|
do i = 1, N_det
|
||||||
enddo
|
coef_tmp(i,1) = psi_r_coef_bi_ortho(i,1)
|
||||||
call save_wavefunction_general_unormalized(N_det,n_states_tmp,psi_det,size(coef_tmp,1),coef_tmp(1,1))
|
coef_tmp(i,2) = psi_l_coef_bi_ortho(i,1)
|
||||||
|
enddo
|
||||||
|
call save_wavefunction_general_unormalized(N_det, n_states_tmp, psi_det, size(coef_tmp, 1), coef_tmp(1,1))
|
||||||
|
deallocate(coef_tmp)
|
||||||
end
|
end
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
subroutine routine_save_right_bi_ortho()
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer :: i
|
||||||
|
double precision, allocatable :: coef_tmp(:,:)
|
||||||
|
|
||||||
|
allocate(coef_tmp(N_det, N_states))
|
||||||
|
do i = 1, N_det
|
||||||
|
coef_tmp(i,1:N_states) = psi_r_coef_bi_ortho(i,1:N_states)
|
||||||
|
enddo
|
||||||
|
call save_wavefunction_general_unormalized(N_det, N_states, psi_det, size(coef_tmp, 1), coef_tmp(1,1))
|
||||||
|
deallocate(coef_tmp)
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
|
||||||
|
125
src/tc_bi_ortho/pt2_tc_cisd.irp.f
Normal file
125
src/tc_bi_ortho/pt2_tc_cisd.irp.f
Normal file
@ -0,0 +1,125 @@
|
|||||||
|
program pt2_tc_cisd
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
!
|
||||||
|
! TODO : Reads psi_det in the EZFIO folder and prints out the left- and right-eigenvectors together
|
||||||
|
! with the energy. Saves the left-right wave functions at the end.
|
||||||
|
!
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
my_grid_becke = .True.
|
||||||
|
my_n_pt_r_grid = 30
|
||||||
|
my_n_pt_a_grid = 50
|
||||||
|
read_wf = .True.
|
||||||
|
touch read_wf
|
||||||
|
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||||
|
|
||||||
|
print*, ' nb of states = ', N_states
|
||||||
|
print*, ' nb of det = ', N_det
|
||||||
|
call routine_diag()
|
||||||
|
|
||||||
|
call routine
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine routine
|
||||||
|
implicit none
|
||||||
|
integer :: i,h1,p1,h2,p2,s1,s2,degree
|
||||||
|
double precision :: h0i,hi0,e00,ei,delta_e
|
||||||
|
double precision :: norm,e_corr,coef,e_corr_pos,e_corr_neg,e_corr_abs
|
||||||
|
|
||||||
|
integer :: exc(0:2,2,2)
|
||||||
|
double precision :: phase
|
||||||
|
double precision :: eh1,ep1,eh2,ep2
|
||||||
|
|
||||||
|
norm = 0.d0
|
||||||
|
e_corr = 0.d0
|
||||||
|
e_corr_abs = 0.d0
|
||||||
|
e_corr_pos = 0.d0
|
||||||
|
e_corr_neg = 0.d0
|
||||||
|
call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,1), psi_det(1,1,1), N_int, e00)
|
||||||
|
do i = 2, N_det
|
||||||
|
call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,i), psi_det(1,1,1), N_int, hi0)
|
||||||
|
call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,1), psi_det(1,1,i), N_int, h0i)
|
||||||
|
call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,i), psi_det(1,1,i), N_int, ei)
|
||||||
|
call get_excitation_degree(psi_det(1,1,1), psi_det(1,1,i),degree,N_int)
|
||||||
|
call get_excitation(psi_det(1,1,1), psi_det(1,1,i),exc,degree,phase,N_int)
|
||||||
|
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
|
||||||
|
eh1 = Fock_matrix_tc_diag_mo_tot(h1)
|
||||||
|
ep1 = Fock_matrix_tc_diag_mo_tot(p1)
|
||||||
|
delta_e = eh1 - ep1
|
||||||
|
if (degree==2)then
|
||||||
|
eh2 = Fock_matrix_tc_diag_mo_tot(h2)
|
||||||
|
ep2 = Fock_matrix_tc_diag_mo_tot(p2)
|
||||||
|
delta_e += eh2 - ep2
|
||||||
|
endif
|
||||||
|
! delta_e = e00 - ei
|
||||||
|
coef = hi0/delta_e
|
||||||
|
norm += coef*coef
|
||||||
|
e_corr = coef* h0i
|
||||||
|
if(e_corr.lt.0.d0)then
|
||||||
|
e_corr_neg += e_corr
|
||||||
|
elseif(e_corr.gt.0.d0)then
|
||||||
|
e_corr_pos += e_corr
|
||||||
|
endif
|
||||||
|
e_corr_abs += dabs(e_corr)
|
||||||
|
enddo
|
||||||
|
print*,'e_corr_abs = ',e_corr_abs
|
||||||
|
print*,'e_corr_pos = ',e_corr_pos
|
||||||
|
print*,'e_corr_neg = ',e_corr_neg
|
||||||
|
print*,'norm = ',dsqrt(norm)
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine routine_diag()
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer :: i, j, k
|
||||||
|
double precision :: dE
|
||||||
|
|
||||||
|
! provide eigval_right_tc_bi_orth
|
||||||
|
! provide overlap_bi_ortho
|
||||||
|
! provide htilde_matrix_elmt_bi_ortho
|
||||||
|
|
||||||
|
if(N_states .eq. 1) then
|
||||||
|
|
||||||
|
print*,'eigval_right_tc_bi_orth = ',eigval_right_tc_bi_orth(1)
|
||||||
|
print*,'e_tc_left_right = ',e_tc_left_right
|
||||||
|
print*,'e_tilde_bi_orth_00 = ',e_tilde_bi_orth_00
|
||||||
|
print*,'e_pt2_tc_bi_orth = ',e_pt2_tc_bi_orth
|
||||||
|
print*,'e_pt2_tc_bi_orth_single = ',e_pt2_tc_bi_orth_single
|
||||||
|
print*,'e_pt2_tc_bi_orth_double = ',e_pt2_tc_bi_orth_double
|
||||||
|
print*,'***'
|
||||||
|
print*,'e_corr_bi_orth = ',e_corr_bi_orth
|
||||||
|
print*,'e_corr_bi_orth_proj = ',e_corr_bi_orth_proj
|
||||||
|
print*,'e_corr_bi_orth_proj_abs = ',e_corr_bi_orth_proj_abs
|
||||||
|
print*,'e_corr_single_bi_orth = ',e_corr_single_bi_orth
|
||||||
|
print*,'e_corr_double_bi_orth = ',e_corr_double_bi_orth
|
||||||
|
print*,'e_corr_single_bi_orth_abs = ',e_corr_single_bi_orth_abs
|
||||||
|
print*,'e_corr_double_bi_orth_abs = ',e_corr_double_bi_orth_abs
|
||||||
|
print*,'Left/right eigenvectors'
|
||||||
|
do i = 1,N_det
|
||||||
|
write(*,'(I5,X,(100(F12.7,X)))')i,leigvec_tc_bi_orth(i,1),reigvec_tc_bi_orth(i,1),leigvec_tc_bi_orth(i,1)*reigvec_tc_bi_orth(i,1)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
else
|
||||||
|
|
||||||
|
print*,'eigval_right_tc_bi_orth : '
|
||||||
|
do i = 1, N_states
|
||||||
|
print*, i, eigval_right_tc_bi_orth(i)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
print*,''
|
||||||
|
print*,'******************************************************'
|
||||||
|
print*,'TC Excitation energies (au) (eV)'
|
||||||
|
do i = 2, N_states
|
||||||
|
dE = eigval_right_tc_bi_orth(i) - eigval_right_tc_bi_orth(1)
|
||||||
|
print*, i, dE, dE/0.0367502d0
|
||||||
|
enddo
|
||||||
|
print*,''
|
||||||
|
|
||||||
|
endif
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -1,5 +1,18 @@
|
|||||||
program save_bitcpsileft_for_qmcchem
|
program save_bitcpsileft_for_qmcchem
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
read_wf = .True.
|
||||||
|
TOUCH read_wf
|
||||||
|
|
||||||
|
call main()
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
|
subroutine main()
|
||||||
|
|
||||||
|
implicit none
|
||||||
integer :: iunit
|
integer :: iunit
|
||||||
logical :: exists
|
logical :: exists
|
||||||
double precision :: e_ref
|
double precision :: e_ref
|
||||||
@ -46,7 +59,7 @@ program save_bitcpsileft_for_qmcchem
|
|||||||
|
|
||||||
close(iunit)
|
close(iunit)
|
||||||
|
|
||||||
end
|
end subroutine main
|
||||||
|
|
||||||
! --
|
! --
|
||||||
|
|
||||||
@ -61,12 +74,18 @@ subroutine write_lr_spindeterminants()
|
|||||||
|
|
||||||
PROVIDE psi_bitcleft_bilinear_matrix_values
|
PROVIDE psi_bitcleft_bilinear_matrix_values
|
||||||
|
|
||||||
|
print *, ' saving left determinants'
|
||||||
|
print *, ' assuming save_for_qmc called before to save right determinants'
|
||||||
|
print *, ' N_det = ', N_det
|
||||||
|
print *, ' N_states = ', N_states
|
||||||
|
|
||||||
allocate(buffer(N_det,N_states))
|
allocate(buffer(N_det,N_states))
|
||||||
do l = 1, N_states
|
do l = 1, N_states
|
||||||
do k = 1, N_det
|
do k = 1, N_det
|
||||||
buffer(k,l) = psi_bitcleft_bilinear_matrix_values(k,l)
|
buffer(k,l) = psi_bitcleft_bilinear_matrix_values(k,l)
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
call ezfio_set_spindeterminants_psi_left_coef_matrix_values(buffer)
|
call ezfio_set_spindeterminants_psi_left_coef_matrix_values(buffer)
|
||||||
deallocate(buffer)
|
deallocate(buffer)
|
||||||
|
|
@ -1,23 +1,5 @@
|
|||||||
subroutine provide_all_three_ints_bi_ortho
|
|
||||||
implicit none
|
|
||||||
BEGIN_DOC
|
|
||||||
! routine that provides all necessary three-electron integrals
|
|
||||||
END_DOC
|
|
||||||
if(three_body_h_tc)then
|
|
||||||
PROVIDE three_e_3_idx_direct_bi_ort three_e_3_idx_cycle_1_bi_ort three_e_3_idx_cycle_2_bi_ort
|
|
||||||
PROVIDE three_e_3_idx_exch23_bi_ort three_e_3_idx_exch13_bi_ort three_e_3_idx_exch12_bi_ort
|
|
||||||
PROVIDE three_e_4_idx_direct_bi_ort three_e_4_idx_cycle_1_bi_ort three_e_4_idx_cycle_2_bi_ort
|
|
||||||
PROVIDE three_e_4_idx_exch23_bi_ort three_e_4_idx_exch13_bi_ort three_e_4_idx_exch12_bi_ort
|
|
||||||
endif
|
|
||||||
if(.not.double_normal_ord)then
|
|
||||||
PROVIDE three_e_5_idx_direct_bi_ort three_e_5_idx_cycle_1_bi_ort three_e_5_idx_cycle_2_bi_ort
|
|
||||||
PROVIDE three_e_5_idx_exch23_bi_ort three_e_5_idx_exch13_bi_ort three_e_5_idx_exch12_bi_ort
|
|
||||||
else
|
|
||||||
PROVIDE normal_two_body_bi_orth
|
|
||||||
endif
|
|
||||||
end
|
|
||||||
|
|
||||||
subroutine diag_htilde_three_body_ints_bi_ort(Nint, key_i, hthree)
|
subroutine diag_htilde_three_body_ints_bi_ort_slow(Nint, key_i, hthree)
|
||||||
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! diagonal element of htilde ONLY FOR THREE-BODY TERMS WITH BI ORTHONORMAL ORBITALS
|
! diagonal element of htilde ONLY FOR THREE-BODY TERMS WITH BI ORTHONORMAL ORBITALS
|
||||||
@ -108,7 +90,7 @@ subroutine diag_htilde_three_body_ints_bi_ort(Nint, key_i, hthree)
|
|||||||
end
|
end
|
||||||
|
|
||||||
|
|
||||||
subroutine single_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree)
|
subroutine single_htilde_three_body_ints_bi_ort_slow(Nint, key_j, key_i, hthree)
|
||||||
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! <key_j | H_tilde | key_i> for single excitation ONLY FOR THREE-BODY TERMS WITH BI ORTHONORMAL ORBITALS
|
! <key_j | H_tilde | key_i> for single excitation ONLY FOR THREE-BODY TERMS WITH BI ORTHONORMAL ORBITALS
|
||||||
@ -203,7 +185,7 @@ end
|
|||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
|
||||||
subroutine double_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree)
|
subroutine double_htilde_three_body_ints_bi_ort_slow(Nint, key_j, key_i, hthree)
|
||||||
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! <key_j | H_tilde | key_i> for double excitation ONLY FOR THREE-BODY TERMS WITH BI ORTHONORMAL ORBITALS
|
! <key_j | H_tilde | key_i> for double excitation ONLY FOR THREE-BODY TERMS WITH BI ORTHONORMAL ORBITALS
|
@ -1,3 +1,26 @@
|
|||||||
|
subroutine provide_all_three_ints_bi_ortho
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! routine that provides all necessary three-electron integrals
|
||||||
|
END_DOC
|
||||||
|
if(three_body_h_tc)then
|
||||||
|
if(three_e_3_idx_term)then
|
||||||
|
PROVIDE three_e_3_idx_direct_bi_ort three_e_3_idx_cycle_1_bi_ort three_e_3_idx_cycle_2_bi_ort
|
||||||
|
PROVIDE three_e_3_idx_exch23_bi_ort three_e_3_idx_exch13_bi_ort three_e_3_idx_exch12_bi_ort
|
||||||
|
endif
|
||||||
|
if(three_e_4_idx_term)then
|
||||||
|
PROVIDE three_e_4_idx_direct_bi_ort three_e_4_idx_cycle_1_bi_ort three_e_4_idx_cycle_2_bi_ort
|
||||||
|
PROVIDE three_e_4_idx_exch23_bi_ort three_e_4_idx_exch13_bi_ort three_e_4_idx_exch12_bi_ort
|
||||||
|
endif
|
||||||
|
if(.not.double_normal_ord.and.three_e_5_idx_term)then
|
||||||
|
PROVIDE three_e_5_idx_direct_bi_ort three_e_5_idx_cycle_1_bi_ort three_e_5_idx_cycle_2_bi_ort
|
||||||
|
PROVIDE three_e_5_idx_exch23_bi_ort three_e_5_idx_exch13_bi_ort three_e_5_idx_exch12_bi_ort
|
||||||
|
elseif (double_normal_ord .and. (.not. three_e_5_idx_term))then
|
||||||
|
PROVIDE normal_two_body_bi_orth
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
end
|
||||||
|
|
||||||
subroutine htilde_mu_mat_opt_bi_ortho_tot(key_j, key_i, Nint, htot)
|
subroutine htilde_mu_mat_opt_bi_ortho_tot(key_j, key_i, Nint, htot)
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
|
@ -7,11 +7,11 @@
|
|||||||
! Various component of the TC energy for the reference "HF" Slater determinant
|
! Various component of the TC energy for the reference "HF" Slater determinant
|
||||||
END_DOC
|
END_DOC
|
||||||
double precision :: hmono, htwoe, htot, hthree
|
double precision :: hmono, htwoe, htot, hthree
|
||||||
call diag_htilde_mu_mat_bi_ortho(N_int,HF_bitmask , hmono, htwoe, htot)
|
call diag_htilde_mu_mat_bi_ortho_slow(N_int,HF_bitmask , hmono, htwoe, htot)
|
||||||
ref_tc_energy_1e = hmono
|
ref_tc_energy_1e = hmono
|
||||||
ref_tc_energy_2e = htwoe
|
ref_tc_energy_2e = htwoe
|
||||||
if(three_body_h_tc)then
|
if(three_body_h_tc)then
|
||||||
call diag_htilde_three_body_ints_bi_ort(N_int, HF_bitmask, hthree)
|
call diag_htilde_three_body_ints_bi_ort_slow(N_int, HF_bitmask, hthree)
|
||||||
ref_tc_energy_3e = hthree
|
ref_tc_energy_3e = hthree
|
||||||
else
|
else
|
||||||
ref_tc_energy_3e = 0.d0
|
ref_tc_energy_3e = 0.d0
|
||||||
@ -156,7 +156,7 @@ subroutine ac_tc_operator(iorb,ispin,key,hmono,htwoe,hthree,Nint,na,nb)
|
|||||||
htwoe = htwoe + mo_bi_ortho_tc_two_e_jj(occ(i,other_spin),iorb)
|
htwoe = htwoe + mo_bi_ortho_tc_two_e_jj(occ(i,other_spin),iorb)
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
if(three_body_h_tc)then
|
if(three_body_h_tc.and.elec_num.gt.2.and.three_e_3_idx_term)then
|
||||||
!!!!! 3-e part
|
!!!!! 3-e part
|
||||||
!! same-spin/same-spin
|
!! same-spin/same-spin
|
||||||
do j = 1, na
|
do j = 1, na
|
||||||
@ -243,7 +243,7 @@ subroutine a_tc_operator(iorb,ispin,key,hmono,htwoe,hthree,Nint,na,nb)
|
|||||||
htwoe= htwoe- mo_bi_ortho_tc_two_e_jj(occ(i,other_spin),iorb)
|
htwoe= htwoe- mo_bi_ortho_tc_two_e_jj(occ(i,other_spin),iorb)
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
if(three_body_h_tc)then
|
if(three_body_h_tc.and.elec_num.gt.2.and.three_e_3_idx_term)then
|
||||||
!!!!! 3-e part
|
!!!!! 3-e part
|
||||||
!! same-spin/same-spin
|
!! same-spin/same-spin
|
||||||
do j = 1, na
|
do j = 1, na
|
||||||
|
@ -41,15 +41,15 @@ subroutine double_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe,
|
|||||||
if(s1.ne.s2)then
|
if(s1.ne.s2)then
|
||||||
! opposite spin two-body
|
! opposite spin two-body
|
||||||
htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)
|
htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)
|
||||||
if(three_body_h_tc)then
|
if(three_body_h_tc.and.elec_num.gt.2)then
|
||||||
if(.not.double_normal_ord)then
|
if(.not.double_normal_ord.and.three_e_5_idx_term)then
|
||||||
if(degree_i>degree_j)then
|
if(degree_i>degree_j)then
|
||||||
call three_comp_two_e_elem(key_j,h1,h2,p1,p2,s1,s2,hthree)
|
call three_comp_two_e_elem(key_j,h1,h2,p1,p2,s1,s2,hthree)
|
||||||
else
|
else
|
||||||
call three_comp_two_e_elem(key_i,h1,h2,p1,p2,s1,s2,hthree)
|
call three_comp_two_e_elem(key_i,h1,h2,p1,p2,s1,s2,hthree)
|
||||||
endif
|
endif
|
||||||
elseif(double_normal_ord.and.elec_num+elec_num.gt.2)then
|
elseif(double_normal_ord)then
|
||||||
htwoe += normal_two_body_bi_orth(p2,h2,p1,h1)!!! WTF ???
|
htwoe += normal_two_body_bi_orth(p2,h2,p1,h1)
|
||||||
endif
|
endif
|
||||||
endif
|
endif
|
||||||
else
|
else
|
||||||
@ -58,16 +58,16 @@ subroutine double_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe,
|
|||||||
htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)
|
htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)
|
||||||
! exchange terms
|
! exchange terms
|
||||||
htwoe -= mo_bi_ortho_tc_two_e(p1,p2,h2,h1)
|
htwoe -= mo_bi_ortho_tc_two_e(p1,p2,h2,h1)
|
||||||
if(three_body_h_tc)then
|
if(three_body_h_tc.and.elec_num.gt.2)then
|
||||||
if(.not.double_normal_ord)then
|
if(.not.double_normal_ord.and.three_e_5_idx_term)then
|
||||||
if(degree_i>degree_j)then
|
if(degree_i>degree_j)then
|
||||||
call three_comp_two_e_elem(key_j,h1,h2,p1,p2,s1,s2,hthree)
|
call three_comp_two_e_elem(key_j,h1,h2,p1,p2,s1,s2,hthree)
|
||||||
else
|
else
|
||||||
call three_comp_two_e_elem(key_i,h1,h2,p1,p2,s1,s2,hthree)
|
call three_comp_two_e_elem(key_i,h1,h2,p1,p2,s1,s2,hthree)
|
||||||
endif
|
endif
|
||||||
elseif(double_normal_ord.and.elec_num+elec_num.gt.2)then
|
elseif(double_normal_ord)then
|
||||||
htwoe -= normal_two_body_bi_orth(h2,p1,h1,p2)!!! WTF ???
|
htwoe -= normal_two_body_bi_orth(h2,p1,h1,p2)
|
||||||
htwoe += normal_two_body_bi_orth(h1,p1,h2,p2)!!! WTF ???
|
htwoe += normal_two_body_bi_orth(h1,p1,h2,p2)
|
||||||
endif
|
endif
|
||||||
endif
|
endif
|
||||||
endif
|
endif
|
||||||
|
@ -106,7 +106,7 @@ subroutine get_single_excitation_from_fock_tc(key_i,key_j,h,p,spin,phase,hmono,h
|
|||||||
htwoe -= buffer_x(i)
|
htwoe -= buffer_x(i)
|
||||||
enddo
|
enddo
|
||||||
hthree = 0.d0
|
hthree = 0.d0
|
||||||
if (three_body_h_tc)then
|
if (three_body_h_tc.and.elec_num.gt.2.and.three_e_4_idx_term)then
|
||||||
call three_comp_fock_elem(key_i,h,p,spin,hthree)
|
call three_comp_fock_elem(key_i,h,p,spin,hthree)
|
||||||
endif
|
endif
|
||||||
|
|
||||||
|
@ -1,7 +1,7 @@
|
|||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
|
||||||
subroutine htilde_mu_mat_bi_ortho_tot(key_j, key_i, Nint, htot)
|
subroutine htilde_mu_mat_bi_ortho_tot_slow(key_j, key_i, Nint, htot)
|
||||||
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! <key_j | H_tilde | key_i> where |key_j> is developed on the LEFT basis and |key_i> is developed on the RIGHT basis
|
! <key_j | H_tilde | key_i> where |key_j> is developed on the LEFT basis and |key_i> is developed on the RIGHT basis
|
||||||
@ -24,14 +24,14 @@ subroutine htilde_mu_mat_bi_ortho_tot(key_j, key_i, Nint, htot)
|
|||||||
if(degree.gt.2)then
|
if(degree.gt.2)then
|
||||||
htot = 0.d0
|
htot = 0.d0
|
||||||
else
|
else
|
||||||
call htilde_mu_mat_bi_ortho(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
|
end subroutine htilde_mu_mat_bi_ortho_tot_slow
|
||||||
|
|
||||||
! --
|
! --
|
||||||
|
|
||||||
subroutine htilde_mu_mat_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree, htot)
|
subroutine htilde_mu_mat_bi_ortho_slow(key_j, key_i, Nint, hmono, htwoe, hthree, htot)
|
||||||
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
!
|
!
|
||||||
@ -61,22 +61,22 @@ subroutine htilde_mu_mat_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree, htot
|
|||||||
if(degree.gt.2) return
|
if(degree.gt.2) return
|
||||||
|
|
||||||
if(degree == 0)then
|
if(degree == 0)then
|
||||||
call diag_htilde_mu_mat_bi_ortho(Nint, key_i, hmono, htwoe, htot)
|
call diag_htilde_mu_mat_bi_ortho_slow(Nint, key_i, hmono, htwoe, htot)
|
||||||
else if (degree == 1)then
|
else if (degree == 1)then
|
||||||
call single_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot)
|
call single_htilde_mu_mat_bi_ortho_slow(Nint, key_j, key_i, hmono, htwoe, htot)
|
||||||
else if(degree == 2)then
|
else if(degree == 2)then
|
||||||
call double_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot)
|
call double_htilde_mu_mat_bi_ortho_slow(Nint, key_j, key_i, hmono, htwoe, htot)
|
||||||
endif
|
endif
|
||||||
|
|
||||||
if(three_body_h_tc) then
|
if(three_body_h_tc) then
|
||||||
if(degree == 2) then
|
if(degree == 2) then
|
||||||
if(.not.double_normal_ord) then
|
if(.not.double_normal_ord.and.elec_num.gt.2.and.three_e_5_idx_term) then
|
||||||
call double_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree)
|
call double_htilde_three_body_ints_bi_ort_slow(Nint, key_j, key_i, hthree)
|
||||||
endif
|
endif
|
||||||
else if(degree == 1) then
|
else if(degree == 1.and.elec_num.gt.2.and.three_e_4_idx_term) then
|
||||||
call single_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree)
|
call single_htilde_three_body_ints_bi_ort_slow(Nint, key_j, key_i, hthree)
|
||||||
else if(degree == 0) then
|
else if(degree == 0.and.elec_num.gt.2.and.three_e_3_idx_term) then
|
||||||
call diag_htilde_three_body_ints_bi_ort(Nint, key_i, hthree)
|
call diag_htilde_three_body_ints_bi_ort_slow(Nint, key_i, hthree)
|
||||||
endif
|
endif
|
||||||
endif
|
endif
|
||||||
|
|
||||||
@ -89,7 +89,7 @@ end
|
|||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
|
||||||
subroutine diag_htilde_mu_mat_bi_ortho(Nint, key_i, hmono, htwoe, htot)
|
subroutine diag_htilde_mu_mat_bi_ortho_slow(Nint, key_i, hmono, htwoe, htot)
|
||||||
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! diagonal element of htilde ONLY FOR ONE- AND TWO-BODY TERMS
|
! diagonal element of htilde ONLY FOR ONE- AND TWO-BODY TERMS
|
||||||
@ -188,7 +188,7 @@ end
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
subroutine double_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot)
|
subroutine double_htilde_mu_mat_bi_ortho_slow(Nint, key_j, key_i, hmono, htwoe, htot)
|
||||||
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! <key_j | H_tilde | key_i> for double excitation ONLY FOR ONE- AND TWO-BODY TERMS
|
! <key_j | H_tilde | key_i> for double excitation ONLY FOR ONE- AND TWO-BODY TERMS
|
||||||
@ -227,18 +227,7 @@ subroutine double_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot)
|
|||||||
return
|
return
|
||||||
endif
|
endif
|
||||||
|
|
||||||
! if(core_tc_op)then
|
|
||||||
! print*,'core_tc_op not already taken into account for bi ortho'
|
|
||||||
! print*,'stopping ...'
|
|
||||||
! stop
|
|
||||||
! do i = 1, Nint
|
|
||||||
! key_i_core(i,1) = xor(key_i(i,1),core_bitmask(i,1))
|
|
||||||
! key_i_core(i,2) = xor(key_i(i,2),core_bitmask(i,2))
|
|
||||||
! enddo
|
|
||||||
! call bitstring_to_list_ab(key_i_core, occ, Ne, Nint)
|
|
||||||
! else
|
|
||||||
call bitstring_to_list_ab(key_i, occ, Ne, Nint)
|
call bitstring_to_list_ab(key_i, occ, Ne, Nint)
|
||||||
! endif
|
|
||||||
call get_double_excitation(key_i, key_j, exc, phase, Nint)
|
call get_double_excitation(key_i, key_j, exc, phase, Nint)
|
||||||
call decode_exc(exc, 2, h1, p1, h2, p2, s1, s2)
|
call decode_exc(exc, 2, h1, p1, h2, p2, s1, s2)
|
||||||
|
|
||||||
@ -246,7 +235,7 @@ subroutine double_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot)
|
|||||||
! opposite spin two-body
|
! opposite spin two-body
|
||||||
! key_j, key_i
|
! key_j, key_i
|
||||||
htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)
|
htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)
|
||||||
if(double_normal_ord.and.+Ne(1).gt.2)then
|
if(three_body_h_tc.and.double_normal_ord.and.+Ne(1).gt.2)then
|
||||||
htwoe += normal_two_body_bi_orth(p2,h2,p1,h1)!!! WTF ???
|
htwoe += normal_two_body_bi_orth(p2,h2,p1,h1)!!! WTF ???
|
||||||
endif
|
endif
|
||||||
else
|
else
|
||||||
@ -255,7 +244,7 @@ subroutine double_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot)
|
|||||||
htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)
|
htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)
|
||||||
! exchange terms
|
! exchange terms
|
||||||
htwoe -= mo_bi_ortho_tc_two_e(p1,p2,h2,h1)
|
htwoe -= mo_bi_ortho_tc_two_e(p1,p2,h2,h1)
|
||||||
if(double_normal_ord.and.+Ne(1).gt.2)then
|
if(three_body_h_tc.and.double_normal_ord.and.+Ne(1).gt.2)then
|
||||||
htwoe -= normal_two_body_bi_orth(h2,p1,h1,p2)!!! WTF ???
|
htwoe -= normal_two_body_bi_orth(h2,p1,h1,p2)!!! WTF ???
|
||||||
htwoe += normal_two_body_bi_orth(h1,p1,h2,p2)!!! WTF ???
|
htwoe += normal_two_body_bi_orth(h1,p1,h2,p2)!!! WTF ???
|
||||||
endif
|
endif
|
||||||
@ -266,7 +255,7 @@ subroutine double_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot)
|
|||||||
end
|
end
|
||||||
|
|
||||||
|
|
||||||
subroutine single_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot)
|
subroutine single_htilde_mu_mat_bi_ortho_slow(Nint, key_j, key_i, hmono, htwoe, htot)
|
||||||
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! <key_j | H_tilde | key_i> for single excitation ONLY FOR ONE- AND TWO-BODY TERMS
|
! <key_j | H_tilde | key_i> for single excitation ONLY FOR ONE- AND TWO-BODY TERMS
|
@ -1,16 +1,25 @@
|
|||||||
program tc_bi_ortho
|
program tc_bi_ortho
|
||||||
implicit none
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! TODO : Reads psi_det in the EZFIO folder and prints out the left- and right-eigenvectors together with the energy. Saves the left-right wave functions at the end.
|
!
|
||||||
|
! TODO : Reads psi_det in the EZFIO folder and prints out the left- and right-eigenvectors together
|
||||||
|
! with the energy. Saves the left-right wave functions at the end.
|
||||||
|
!
|
||||||
END_DOC
|
END_DOC
|
||||||
|
|
||||||
my_grid_becke = .True.
|
my_grid_becke = .True.
|
||||||
my_n_pt_r_grid = 30
|
my_n_pt_r_grid = 30
|
||||||
my_n_pt_a_grid = 50
|
my_n_pt_a_grid = 50
|
||||||
read_wf = .True.
|
read_wf = .True.
|
||||||
touch read_wf
|
touch read_wf
|
||||||
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
|
||||||
call routine_diag
|
|
||||||
call save_tc_bi_ortho_wavefunction
|
print*, ' nb of states = ', N_states
|
||||||
|
print*, ' nb of det = ', N_det
|
||||||
|
|
||||||
|
call routine_diag()
|
||||||
|
call write_tc_energy()
|
||||||
|
call save_tc_bi_ortho_wavefunction()
|
||||||
end
|
end
|
||||||
|
|
||||||
subroutine test
|
subroutine test
|
||||||
@ -27,26 +36,56 @@ subroutine test
|
|||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
subroutine routine_diag
|
subroutine routine_diag()
|
||||||
implicit none
|
|
||||||
! provide eigval_right_tc_bi_orth
|
implicit none
|
||||||
! provide overlap_bi_ortho
|
integer :: i, j, k
|
||||||
! provide htilde_matrix_elmt_bi_ortho
|
double precision :: dE
|
||||||
integer ::i,j
|
|
||||||
print*,'eigval_right_tc_bi_orth = ',eigval_right_tc_bi_orth(1)
|
! provide eigval_right_tc_bi_orth
|
||||||
print*,'e_tc_left_right = ',e_tc_left_right
|
! provide overlap_bi_ortho
|
||||||
print*,'e_tilde_bi_orth_00 = ',e_tilde_bi_orth_00
|
! provide htilde_matrix_elmt_bi_ortho
|
||||||
print*,'e_pt2_tc_bi_orth = ',e_pt2_tc_bi_orth
|
|
||||||
print*,'e_pt2_tc_bi_orth_single = ',e_pt2_tc_bi_orth_single
|
if(N_states .eq. 1) then
|
||||||
print*,'e_pt2_tc_bi_orth_double = ',e_pt2_tc_bi_orth_double
|
|
||||||
print*,'***'
|
print*,'eigval_right_tc_bi_orth = ',eigval_right_tc_bi_orth(1)
|
||||||
print*,'e_corr_bi_orth = ',e_corr_bi_orth
|
print*,'e_tc_left_right = ',e_tc_left_right
|
||||||
print*,'e_corr_bi_orth_proj = ',e_corr_bi_orth_proj
|
print*,'e_tilde_bi_orth_00 = ',e_tilde_bi_orth_00
|
||||||
print*,'e_corr_single_bi_orth = ',e_corr_single_bi_orth
|
print*,'e_pt2_tc_bi_orth = ',e_pt2_tc_bi_orth
|
||||||
print*,'e_corr_double_bi_orth = ',e_corr_double_bi_orth
|
print*,'e_pt2_tc_bi_orth_single = ',e_pt2_tc_bi_orth_single
|
||||||
print*,'Left/right eigenvectors'
|
print*,'e_pt2_tc_bi_orth_double = ',e_pt2_tc_bi_orth_double
|
||||||
do i = 1,N_det
|
print*,'***'
|
||||||
write(*,'(I5,X,(100(F12.7,X)))')i,leigvec_tc_bi_orth(i,1),reigvec_tc_bi_orth(i,1),leigvec_tc_bi_orth(i,1)*reigvec_tc_bi_orth(i,1)
|
print*,'e_corr_bi_orth = ',e_corr_bi_orth
|
||||||
enddo
|
print*,'e_corr_bi_orth_proj = ',e_corr_bi_orth_proj
|
||||||
|
print*,'e_corr_bi_orth_proj_abs = ',e_corr_bi_orth_proj_abs
|
||||||
|
print*,'e_corr_single_bi_orth = ',e_corr_single_bi_orth
|
||||||
|
print*,'e_corr_double_bi_orth = ',e_corr_double_bi_orth
|
||||||
|
print*,'e_corr_single_bi_orth_abs = ',e_corr_single_bi_orth_abs
|
||||||
|
print*,'e_corr_double_bi_orth_abs = ',e_corr_double_bi_orth_abs
|
||||||
|
print*,'Left/right eigenvectors'
|
||||||
|
do i = 1,N_det
|
||||||
|
write(*,'(I5,X,(100(F12.7,X)))')i,leigvec_tc_bi_orth(i,1),reigvec_tc_bi_orth(i,1),leigvec_tc_bi_orth(i,1)*reigvec_tc_bi_orth(i,1)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
else
|
||||||
|
|
||||||
|
print*,'eigval_right_tc_bi_orth : '
|
||||||
|
do i = 1, N_states
|
||||||
|
print*, i, eigval_right_tc_bi_orth(i)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
print*,''
|
||||||
|
print*,'******************************************************'
|
||||||
|
print*,'TC Excitation energies (au) (eV)'
|
||||||
|
do i = 2, N_states
|
||||||
|
dE = eigval_right_tc_bi_orth(i) - eigval_right_tc_bi_orth(1)
|
||||||
|
print*, i, dE, dE/0.0367502d0
|
||||||
|
enddo
|
||||||
|
print*,''
|
||||||
|
|
||||||
|
endif
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
@ -11,10 +11,10 @@
|
|||||||
allocate(H_jj(N_det),vec_tmp(N_det,n_states_diag),eigval_tmp(N_states))
|
allocate(H_jj(N_det),vec_tmp(N_det,n_states_diag),eigval_tmp(N_states))
|
||||||
dressing_dets = 0.d0
|
dressing_dets = 0.d0
|
||||||
do i = 1, N_det
|
do i = 1, N_det
|
||||||
call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,i), N_int, H_jj(i))
|
call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,i), psi_det(1,1,i), N_int, H_jj(i))
|
||||||
call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
|
call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
|
||||||
if(degree == 1 .or. degree == 2)then
|
if(degree == 1 .or. degree == 2)then
|
||||||
call htilde_mu_mat_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,h0j(i))
|
call htilde_mu_mat_bi_ortho_slow(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,h0j(i))
|
||||||
endif
|
endif
|
||||||
enddo
|
enddo
|
||||||
reigvec_tc_bi_orth_tmp = 0.d0
|
reigvec_tc_bi_orth_tmp = 0.d0
|
||||||
@ -29,7 +29,7 @@
|
|||||||
vec_tmp(istate,istate) = 1.d0
|
vec_tmp(istate,istate) = 1.d0
|
||||||
enddo
|
enddo
|
||||||
print*,'Diagonalizing the TC CISD '
|
print*,'Diagonalizing the TC CISD '
|
||||||
call davidson_general_diag_dressed_ext_rout_nonsym_b1space(vec_tmp, H_jj, dressing_dets,eigval_tmp, N_det, n_states, n_states_diag, converged, htc_bi_ortho_calc_tdav)
|
call davidson_general_diag_dressed_ext_rout_nonsym_b1space(vec_tmp, H_jj, dressing_dets,eigval_tmp, N_det, n_states, n_states_diag, converged, htc_bi_ortho_calc_tdav_slow)
|
||||||
do i = 1, N_det
|
do i = 1, N_det
|
||||||
e_corr_dets(i) = reigvec_tc_bi_orth_tmp(i,1) * h0j(i)/reigvec_tc_bi_orth_tmp(1,1)
|
e_corr_dets(i) = reigvec_tc_bi_orth_tmp(i,1) * h0j(i)/reigvec_tc_bi_orth_tmp(1,1)
|
||||||
enddo
|
enddo
|
||||||
@ -41,8 +41,8 @@
|
|||||||
it = 0
|
it = 0
|
||||||
dressing_dets = 0.d0
|
dressing_dets = 0.d0
|
||||||
double precision, allocatable :: H_jj(:),vec_tmp(:,:),eigval_tmp(:)
|
double precision, allocatable :: H_jj(:),vec_tmp(:,:),eigval_tmp(:)
|
||||||
external htc_bi_ortho_calc_tdav
|
external htc_bi_ortho_calc_tdav_slow
|
||||||
external htcdag_bi_ortho_calc_tdav
|
external htcdag_bi_ortho_calc_tdav_slow
|
||||||
logical :: converged
|
logical :: converged
|
||||||
do while (dabs(E_before-E_current).gt.thr)
|
do while (dabs(E_before-E_current).gt.thr)
|
||||||
it += 1
|
it += 1
|
||||||
@ -66,7 +66,7 @@
|
|||||||
do istate = N_states+1, n_states_diag
|
do istate = N_states+1, n_states_diag
|
||||||
vec_tmp(istate,istate) = 1.d0
|
vec_tmp(istate,istate) = 1.d0
|
||||||
enddo
|
enddo
|
||||||
call davidson_general_diag_dressed_ext_rout_nonsym_b1space(vec_tmp, H_jj, dressing_dets,eigval_tmp, N_det, n_states, n_states_diag, converged, htc_bi_ortho_calc_tdav)
|
call davidson_general_diag_dressed_ext_rout_nonsym_b1space(vec_tmp, H_jj, dressing_dets,eigval_tmp, N_det, n_states, n_states_diag, converged, htc_bi_ortho_calc_tdav_slow)
|
||||||
print*,'outside Davidson'
|
print*,'outside Davidson'
|
||||||
print*,'eigval_tmp(1) = ',eigval_tmp(1)
|
print*,'eigval_tmp(1) = ',eigval_tmp(1)
|
||||||
do i = 1, N_det
|
do i = 1, N_det
|
||||||
|
@ -43,7 +43,7 @@ end
|
|||||||
END_DOC
|
END_DOC
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
integer :: i, idx_dress, j, istate
|
integer :: i, idx_dress, j, istate, k
|
||||||
logical :: converged, dagger
|
logical :: converged, dagger
|
||||||
integer :: n_real_tc_bi_orth_eigval_right,igood_r,igood_l
|
integer :: n_real_tc_bi_orth_eigval_right,igood_r,igood_l
|
||||||
double precision, allocatable :: reigvec_tc_bi_orth_tmp(:,:),leigvec_tc_bi_orth_tmp(:,:),eigval_right_tmp(:)
|
double precision, allocatable :: reigvec_tc_bi_orth_tmp(:,:),leigvec_tc_bi_orth_tmp(:,:),eigval_right_tmp(:)
|
||||||
@ -52,116 +52,123 @@ end
|
|||||||
integer :: i_good_state,i_other_state, i_state
|
integer :: i_good_state,i_other_state, i_state
|
||||||
integer, allocatable :: index_good_state_array(:)
|
integer, allocatable :: index_good_state_array(:)
|
||||||
logical, allocatable :: good_state_array(:)
|
logical, allocatable :: good_state_array(:)
|
||||||
double precision, allocatable :: coef_hf_r(:),coef_hf_l(:)
|
double precision, allocatable :: coef_hf_r(:),coef_hf_l(:)
|
||||||
|
double precision, allocatable :: Stmp(:,:)
|
||||||
integer, allocatable :: iorder(:)
|
integer, allocatable :: iorder(:)
|
||||||
|
|
||||||
PROVIDE N_det N_int
|
PROVIDE N_det N_int
|
||||||
|
|
||||||
if(n_det.le.N_det_max_full)then
|
if(n_det .le. N_det_max_full) then
|
||||||
|
|
||||||
allocate(reigvec_tc_bi_orth_tmp(N_det,N_det),leigvec_tc_bi_orth_tmp(N_det,N_det),eigval_right_tmp(N_det),expect_e(N_det))
|
allocate(reigvec_tc_bi_orth_tmp(N_det,N_det),leigvec_tc_bi_orth_tmp(N_det,N_det),eigval_right_tmp(N_det),expect_e(N_det))
|
||||||
allocate (H_prime(N_det,N_det),s2_values_tmp(N_det))
|
allocate (H_prime(N_det,N_det),s2_values_tmp(N_det))
|
||||||
|
|
||||||
H_prime(1:N_det,1:N_det) = htilde_matrix_elmt_bi_ortho(1:N_det,1:N_det)
|
H_prime(1:N_det,1:N_det) = htilde_matrix_elmt_bi_ortho(1:N_det,1:N_det)
|
||||||
if(s2_eig)then
|
if(s2_eig) then
|
||||||
H_prime(1:N_det,1:N_det) += alpha * S2_matrix_all_dets(1:N_det,1:N_det)
|
H_prime(1:N_det,1:N_det) += alpha * S2_matrix_all_dets(1:N_det,1:N_det)
|
||||||
do j=1,N_det
|
do j=1,N_det
|
||||||
H_prime(j,j) = H_prime(j,j) - alpha*expected_s2
|
H_prime(j,j) = H_prime(j,j) - alpha*expected_s2
|
||||||
enddo
|
enddo
|
||||||
endif
|
endif
|
||||||
call non_hrmt_real_diag(N_det,H_prime,&
|
|
||||||
leigvec_tc_bi_orth_tmp,reigvec_tc_bi_orth_tmp,&
|
call non_hrmt_real_diag(N_det, H_prime, leigvec_tc_bi_orth_tmp, reigvec_tc_bi_orth_tmp, n_real_tc_bi_orth_eigval_right, eigval_right_tmp)
|
||||||
n_real_tc_bi_orth_eigval_right,eigval_right_tmp)
|
|
||||||
! do i = 1, N_det
|
! do i = 1, N_det
|
||||||
! call get_H_tc_s2_l0_r0(leigvec_tc_bi_orth_tmp(1,i),reigvec_tc_bi_orth_tmp(1,i),1,N_det,expect_e(i), s2_values_tmp(i))
|
! call get_H_tc_s2_l0_r0(leigvec_tc_bi_orth_tmp(1,i),reigvec_tc_bi_orth_tmp(1,i),1,N_det,expect_e(i), s2_values_tmp(i))
|
||||||
! enddo
|
! enddo
|
||||||
call get_H_tc_s2_l0_r0(leigvec_tc_bi_orth_tmp,reigvec_tc_bi_orth_tmp,N_det,N_det,expect_e, s2_values_tmp)
|
call get_H_tc_s2_l0_r0(leigvec_tc_bi_orth_tmp,reigvec_tc_bi_orth_tmp,N_det,N_det,expect_e, s2_values_tmp)
|
||||||
|
|
||||||
allocate(index_good_state_array(N_det),good_state_array(N_det))
|
allocate(index_good_state_array(N_det),good_state_array(N_det))
|
||||||
i_state = 0
|
i_state = 0
|
||||||
good_state_array = .False.
|
good_state_array = .False.
|
||||||
if(s2_eig)then
|
|
||||||
if (only_expected_s2) then
|
if(s2_eig) then
|
||||||
do j=1,N_det
|
|
||||||
|
if(only_expected_s2) then
|
||||||
|
do j = 1, N_det
|
||||||
! Select at least n_states states with S^2 values closed to "expected_s2"
|
! Select at least n_states states with S^2 values closed to "expected_s2"
|
||||||
! print*,'s2_values_tmp(j) = ',s2_values_tmp(j),eigval_right_tmp(j),expect_e(j)
|
! print*,'s2_values_tmp(j) = ',s2_values_tmp(j),eigval_right_tmp(j),expect_e(j)
|
||||||
if(dabs(s2_values_tmp(j)-expected_s2).le.0.5d0)then
|
if(dabs(s2_values_tmp(j) - expected_s2).le.0.5d0)then
|
||||||
i_state +=1
|
i_state +=1
|
||||||
index_good_state_array(i_state) = j
|
index_good_state_array(i_state) = j
|
||||||
good_state_array(j) = .True.
|
good_state_array(j) = .True.
|
||||||
endif
|
endif
|
||||||
if(i_state.eq.N_states) then
|
if(i_state.eq.N_states) then
|
||||||
exit
|
exit
|
||||||
endif
|
endif
|
||||||
enddo
|
enddo
|
||||||
else
|
else
|
||||||
do j=1,N_det
|
do j = 1, N_det
|
||||||
index_good_state_array(j) = j
|
index_good_state_array(j) = j
|
||||||
good_state_array(j) = .True.
|
good_state_array(j) = .True.
|
||||||
enddo
|
enddo
|
||||||
endif
|
endif
|
||||||
if(i_state .ne.0)then
|
|
||||||
! Fill the first "i_state" states that have a correct S^2 value
|
if(i_state .ne. 0) then
|
||||||
do j = 1, i_state
|
! Fill the first "i_state" states that have a correct S^2 value
|
||||||
do i=1,N_det
|
do j = 1, i_state
|
||||||
reigvec_tc_bi_orth(i,j) = reigvec_tc_bi_orth_tmp(i,index_good_state_array(j))
|
do i = 1, N_det
|
||||||
leigvec_tc_bi_orth(i,j) = leigvec_tc_bi_orth_tmp(i,index_good_state_array(j))
|
reigvec_tc_bi_orth(i,j) = reigvec_tc_bi_orth_tmp(i,index_good_state_array(j))
|
||||||
enddo
|
leigvec_tc_bi_orth(i,j) = leigvec_tc_bi_orth_tmp(i,index_good_state_array(j))
|
||||||
eigval_right_tc_bi_orth(j) = expect_e(index_good_state_array(j))
|
enddo
|
||||||
eigval_left_tc_bi_orth(j) = expect_e(index_good_state_array(j))
|
eigval_right_tc_bi_orth(j) = expect_e(index_good_state_array(j))
|
||||||
s2_eigvec_tc_bi_orth(j) = s2_values_tmp(index_good_state_array(j))
|
eigval_left_tc_bi_orth(j) = expect_e(index_good_state_array(j))
|
||||||
enddo
|
s2_eigvec_tc_bi_orth(j) = s2_values_tmp(index_good_state_array(j))
|
||||||
i_other_state = 0
|
enddo
|
||||||
do j = 1, N_det
|
i_other_state = 0
|
||||||
if(good_state_array(j))cycle
|
do j = 1, N_det
|
||||||
i_other_state +=1
|
if(good_state_array(j))cycle
|
||||||
if(i_state+i_other_state.gt.n_states)then
|
i_other_state +=1
|
||||||
exit
|
if(i_state+i_other_state.gt.n_states)then
|
||||||
endif
|
exit
|
||||||
do i=1,N_det
|
endif
|
||||||
reigvec_tc_bi_orth(i,i_state+i_other_state) = reigvec_tc_bi_orth_tmp(i,j)
|
do i = 1, N_det
|
||||||
leigvec_tc_bi_orth(i,i_state+i_other_state) = leigvec_tc_bi_orth_tmp(i,j)
|
reigvec_tc_bi_orth(i,i_state+i_other_state) = reigvec_tc_bi_orth_tmp(i,j)
|
||||||
enddo
|
leigvec_tc_bi_orth(i,i_state+i_other_state) = leigvec_tc_bi_orth_tmp(i,j)
|
||||||
eigval_right_tc_bi_orth(i_state+i_other_state) = eigval_right_tmp(j)
|
enddo
|
||||||
eigval_left_tc_bi_orth (i_state+i_other_state) = eigval_right_tmp(j)
|
eigval_right_tc_bi_orth(i_state+i_other_state) = eigval_right_tmp(j)
|
||||||
s2_eigvec_tc_bi_orth(i_state+i_other_state) = s2_values_tmp(i_state+i_other_state)
|
eigval_left_tc_bi_orth (i_state+i_other_state) = eigval_right_tmp(j)
|
||||||
enddo
|
s2_eigvec_tc_bi_orth(i_state+i_other_state) = s2_values_tmp(i_state+i_other_state)
|
||||||
else ! istate == 0
|
enddo
|
||||||
print*,''
|
else ! istate == 0
|
||||||
print*,'!!!!!!!! WARNING !!!!!!!!!'
|
print*,''
|
||||||
print*,' Within the ',N_det,'determinants selected'
|
print*,'!!!!!!!! WARNING !!!!!!!!!'
|
||||||
print*,' and the ',N_states_diag,'states requested'
|
print*,' Within the ',N_det,'determinants selected'
|
||||||
print*,' We did not find only states with S^2 values close to ',expected_s2
|
print*,' and the ',N_states_diag,'states requested'
|
||||||
print*,' We will then set the first N_states eigenvectors of the H matrix'
|
print*,' We did not find only states with S^2 values close to ',expected_s2
|
||||||
print*,' as the CI_eigenvectors'
|
print*,' We will then set the first N_states eigenvectors of the H matrix'
|
||||||
print*,' You should consider more states and maybe ask for s2_eig to be .True. or just enlarge the CI space'
|
print*,' as the CI_eigenvectors'
|
||||||
print*,''
|
print*,' You should consider more states and maybe ask for s2_eig to be .True. or just enlarge the CI space'
|
||||||
do j=1,min(N_states_diag,N_det)
|
print*,''
|
||||||
do i=1,N_det
|
do j = 1, min(N_states_diag, N_det)
|
||||||
leigvec_tc_bi_orth(i,j) = leigvec_tc_bi_orth_tmp(i,j)
|
do i = 1, N_det
|
||||||
reigvec_tc_bi_orth(i,j) = reigvec_tc_bi_orth_tmp(i,j)
|
leigvec_tc_bi_orth(i,j) = leigvec_tc_bi_orth_tmp(i,j)
|
||||||
enddo
|
reigvec_tc_bi_orth(i,j) = reigvec_tc_bi_orth_tmp(i,j)
|
||||||
eigval_right_tc_bi_orth(j) = eigval_right_tmp(j)
|
enddo
|
||||||
eigval_left_tc_bi_orth (j) = eigval_right_tmp(j)
|
eigval_right_tc_bi_orth(j) = eigval_right_tmp(j)
|
||||||
s2_eigvec_tc_bi_orth(j) = s2_values_tmp(j)
|
eigval_left_tc_bi_orth (j) = eigval_right_tmp(j)
|
||||||
enddo
|
s2_eigvec_tc_bi_orth(j) = s2_values_tmp(j)
|
||||||
endif ! istate .ne. 0
|
enddo
|
||||||
|
endif ! istate .ne. 0
|
||||||
|
|
||||||
else ! s2_eig
|
else ! s2_eig
|
||||||
allocate(coef_hf_r(N_det),coef_hf_l(N_det),iorder(N_det))
|
|
||||||
do i = 1,N_det
|
allocate(coef_hf_r(N_det),coef_hf_l(N_det),iorder(N_det))
|
||||||
|
do i = 1,N_det
|
||||||
iorder(i) = i
|
iorder(i) = i
|
||||||
coef_hf_r(i) = -dabs(reigvec_tc_bi_orth_tmp(index_HF_psi_det,i))
|
coef_hf_r(i) = -dabs(reigvec_tc_bi_orth_tmp(index_HF_psi_det,i))
|
||||||
enddo
|
enddo
|
||||||
call dsort(coef_hf_r,iorder,N_det)
|
call dsort(coef_hf_r,iorder,N_det)
|
||||||
igood_r = iorder(1)
|
igood_r = iorder(1)
|
||||||
print*,'igood_r, coef_hf_r = ',igood_r,coef_hf_r(1)
|
print*,'igood_r, coef_hf_r = ',igood_r,coef_hf_r(1)
|
||||||
do i = 1,N_det
|
do i = 1,N_det
|
||||||
iorder(i) = i
|
iorder(i) = i
|
||||||
coef_hf_l(i) = -dabs(leigvec_tc_bi_orth_tmp(index_HF_psi_det,i))
|
coef_hf_l(i) = -dabs(leigvec_tc_bi_orth_tmp(index_HF_psi_det,i))
|
||||||
enddo
|
enddo
|
||||||
call dsort(coef_hf_l,iorder,N_det)
|
call dsort(coef_hf_l,iorder,N_det)
|
||||||
igood_l = iorder(1)
|
igood_l = iorder(1)
|
||||||
print*,'igood_l, coef_hf_l = ',igood_l,coef_hf_l(1)
|
print*,'igood_l, coef_hf_l = ',igood_l,coef_hf_l(1)
|
||||||
|
|
||||||
if(igood_r.ne.igood_l.and.igood_r.ne.1)then
|
if(igood_r.ne.igood_l .and. igood_r.ne.1) then
|
||||||
print *,''
|
print *,''
|
||||||
print *,'Warning, the left and right eigenvectors are "not the same" '
|
print *,'Warning, the left and right eigenvectors are "not the same" '
|
||||||
print *,'Warning, the ground state is not dominated by HF...'
|
print *,'Warning, the ground state is not dominated by HF...'
|
||||||
@ -169,22 +176,22 @@ end
|
|||||||
print *,'coef of HF in RIGHT eigenvector = ',reigvec_tc_bi_orth_tmp(index_HF_psi_det,igood_r)
|
print *,'coef of HF in RIGHT eigenvector = ',reigvec_tc_bi_orth_tmp(index_HF_psi_det,igood_r)
|
||||||
print *,'State with largest LEFT coefficient of HF ',igood_l
|
print *,'State with largest LEFT coefficient of HF ',igood_l
|
||||||
print *,'coef of HF in LEFT eigenvector = ',leigvec_tc_bi_orth_tmp(index_HF_psi_det,igood_l)
|
print *,'coef of HF in LEFT eigenvector = ',leigvec_tc_bi_orth_tmp(index_HF_psi_det,igood_l)
|
||||||
endif
|
endif
|
||||||
if(state_following_tc)then
|
|
||||||
|
if(state_following_tc) then
|
||||||
print *,'Following the states with the largest coef on HF'
|
print *,'Following the states with the largest coef on HF'
|
||||||
print *,'igood_r,igood_l',igood_r,igood_l
|
print *,'igood_r,igood_l',igood_r,igood_l
|
||||||
i= igood_r
|
i = igood_r
|
||||||
eigval_right_tc_bi_orth(1) = eigval_right_tmp(i)
|
eigval_right_tc_bi_orth(1) = eigval_right_tmp(i)
|
||||||
do j = 1, N_det
|
do j = 1, N_det
|
||||||
reigvec_tc_bi_orth(j,1) = reigvec_tc_bi_orth_tmp(j,i)
|
reigvec_tc_bi_orth(j,1) = reigvec_tc_bi_orth_tmp(j,i)
|
||||||
! print*,reigvec_tc_bi_orth(j,1)
|
|
||||||
enddo
|
enddo
|
||||||
i= igood_l
|
i = igood_l
|
||||||
eigval_left_tc_bi_orth(1) = eigval_right_tmp(i)
|
eigval_left_tc_bi_orth(1) = eigval_right_tmp(i)
|
||||||
do j = 1, N_det
|
do j = 1, N_det
|
||||||
leigvec_tc_bi_orth(j,1) = leigvec_tc_bi_orth_tmp(j,i)
|
leigvec_tc_bi_orth(j,1) = leigvec_tc_bi_orth_tmp(j,i)
|
||||||
enddo
|
enddo
|
||||||
else
|
else
|
||||||
do i = 1, N_states
|
do i = 1, N_states
|
||||||
eigval_right_tc_bi_orth(i) = eigval_right_tmp(i)
|
eigval_right_tc_bi_orth(i) = eigval_right_tmp(i)
|
||||||
eigval_left_tc_bi_orth(i) = eigval_right_tmp(i)
|
eigval_left_tc_bi_orth(i) = eigval_right_tmp(i)
|
||||||
@ -193,46 +200,48 @@ end
|
|||||||
leigvec_tc_bi_orth(j,i) = leigvec_tc_bi_orth_tmp(j,i)
|
leigvec_tc_bi_orth(j,i) = leigvec_tc_bi_orth_tmp(j,i)
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
endif
|
endif
|
||||||
|
|
||||||
endif
|
endif
|
||||||
else
|
|
||||||
|
else ! n_det > N_det_max_full
|
||||||
|
|
||||||
double precision, allocatable :: H_jj(:),vec_tmp(:,:)
|
double precision, allocatable :: H_jj(:),vec_tmp(:,:)
|
||||||
external htc_bi_ortho_calc_tdav
|
|
||||||
external htcdag_bi_ortho_calc_tdav
|
|
||||||
external H_tc_u_0_opt
|
external H_tc_u_0_opt
|
||||||
external H_tc_dagger_u_0_opt
|
external H_tc_dagger_u_0_opt
|
||||||
external H_tc_s2_dagger_u_0_opt
|
external H_tc_s2_dagger_u_0_opt
|
||||||
external H_tc_s2_u_0_opt
|
external H_tc_s2_u_0_opt
|
||||||
|
|
||||||
allocate(H_jj(N_det),vec_tmp(N_det,n_states_diag))
|
allocate(H_jj(N_det),vec_tmp(N_det,n_states_diag))
|
||||||
|
|
||||||
do i = 1, N_det
|
do i = 1, N_det
|
||||||
call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,i), N_int, H_jj(i))
|
call htilde_mu_mat_opt_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,i), N_int, H_jj(i))
|
||||||
enddo
|
enddo
|
||||||
!!!! Preparing the left-eigenvector
|
|
||||||
print*,'---------------------------------'
|
print*,'---------------------------------'
|
||||||
print*,'---------------------------------'
|
print*,'---------------------------------'
|
||||||
print*,'Computing the left-eigenvector '
|
print*,'Computing the left-eigenvector '
|
||||||
print*,'---------------------------------'
|
print*,'---------------------------------'
|
||||||
print*,'---------------------------------'
|
print*,'---------------------------------'
|
||||||
|
!!!! Preparing the left-eigenvector
|
||||||
vec_tmp = 0.d0
|
vec_tmp = 0.d0
|
||||||
do istate = 1, N_states
|
do istate = 1, N_states
|
||||||
vec_tmp(1:N_det,istate) = psi_l_coef_bi_ortho(1:N_det,istate)
|
vec_tmp(1:N_det,istate) = psi_l_coef_bi_ortho(1:N_det,istate)
|
||||||
enddo
|
enddo
|
||||||
do istate = N_states+1, n_states_diag
|
do istate = N_states+1, n_states_diag
|
||||||
vec_tmp(istate,istate) = 1.d0
|
vec_tmp(istate,istate) = 1.d0
|
||||||
enddo
|
enddo
|
||||||
! call davidson_general_ext_rout_nonsym_b1space(vec_tmp, H_jj, eigval_left_tc_bi_orth, N_det, n_states, n_states_diag, converged, htcdag_bi_ortho_calc_tdav)
|
|
||||||
! call davidson_general_ext_rout_nonsym_b1space(vec_tmp, H_jj, eigval_left_tc_bi_orth, N_det, n_states, n_states_diag, converged, H_tc_dagger_u_0_opt)
|
|
||||||
integer :: n_it_max,i_it
|
integer :: n_it_max,i_it
|
||||||
n_it_max = 1
|
n_it_max = 1
|
||||||
converged = .False.
|
converged = .False.
|
||||||
i_it = 0
|
i_it = 0
|
||||||
do while (.not.converged)
|
do while (.not.converged)
|
||||||
call davidson_hs2_nonsym_b1space(vec_tmp, H_jj, s2_eigvec_tc_bi_orth, eigval_left_tc_bi_orth, N_det, n_states, n_states_diag, n_it_max, converged, H_tc_s2_dagger_u_0_opt)
|
call davidson_hs2_nonsym_b1space(vec_tmp, H_jj, s2_eigvec_tc_bi_orth, eigval_left_tc_bi_orth, N_det, n_states, n_states_diag, n_it_max, converged, H_tc_s2_dagger_u_0_opt)
|
||||||
i_it += 1
|
i_it += 1
|
||||||
if(i_it .gt. 5)exit
|
if(i_it .gt. 5) exit
|
||||||
enddo
|
enddo
|
||||||
do istate = 1, N_states
|
do istate = 1, N_states
|
||||||
leigvec_tc_bi_orth(1:N_det,istate) = vec_tmp(1:N_det,istate)
|
leigvec_tc_bi_orth(1:N_det,istate) = vec_tmp(1:N_det,istate)
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
print*,'---------------------------------'
|
print*,'---------------------------------'
|
||||||
@ -240,78 +249,124 @@ end
|
|||||||
print*,'Computing the right-eigenvector '
|
print*,'Computing the right-eigenvector '
|
||||||
print*,'---------------------------------'
|
print*,'---------------------------------'
|
||||||
print*,'---------------------------------'
|
print*,'---------------------------------'
|
||||||
!!!! Preparing the right-eigenvector
|
!!!! Preparing the right-eigenvector
|
||||||
vec_tmp = 0.d0
|
vec_tmp = 0.d0
|
||||||
do istate = 1, N_states
|
do istate = 1, N_states
|
||||||
vec_tmp(1:N_det,istate) = psi_r_coef_bi_ortho(1:N_det,istate)
|
vec_tmp(1:N_det,istate) = psi_r_coef_bi_ortho(1:N_det,istate)
|
||||||
enddo
|
enddo
|
||||||
do istate = N_states+1, n_states_diag
|
do istate = N_states+1, n_states_diag
|
||||||
vec_tmp(istate,istate) = 1.d0
|
vec_tmp(istate,istate) = 1.d0
|
||||||
enddo
|
enddo
|
||||||
! call davidson_general_ext_rout_nonsym_b1space(vec_tmp, H_jj, eigval_right_tc_bi_orth, N_det, n_states, n_states_diag, converged, htc_bi_ortho_calc_tdav)
|
!call davidson_general_ext_rout_nonsym_b1space(vec_tmp, H_jj, eigval_right_tc_bi_orth, N_det, n_states, n_states_diag, converged, H_tc_u_0_opt)
|
||||||
! call davidson_general_ext_rout_nonsym_b1space(vec_tmp, H_jj, eigval_right_tc_bi_orth, N_det, n_states, n_states_diag, converged, H_tc_u_0_opt)
|
|
||||||
converged = .False.
|
converged = .False.
|
||||||
i_it = 0
|
i_it = 0
|
||||||
do while (.not.converged)
|
do while (.not. converged)
|
||||||
call davidson_hs2_nonsym_b1space(vec_tmp, H_jj, s2_eigvec_tc_bi_orth, eigval_right_tc_bi_orth, N_det, n_states, n_states_diag, n_it_max, converged, H_tc_s2_dagger_u_0_opt)
|
call davidson_hs2_nonsym_b1space(vec_tmp, H_jj, s2_eigvec_tc_bi_orth, eigval_right_tc_bi_orth, N_det, n_states, n_states_diag, n_it_max, converged, H_tc_s2_u_0_opt)
|
||||||
i_it += 1
|
i_it += 1
|
||||||
if(i_it .gt. 5)exit
|
if(i_it .gt. 5) exit
|
||||||
enddo
|
enddo
|
||||||
do istate = 1, N_states
|
do istate = 1, N_states
|
||||||
reigvec_tc_bi_orth(1:N_det,istate) = vec_tmp(1:N_det,istate)
|
reigvec_tc_bi_orth(1:N_det,istate) = vec_tmp(1:N_det,istate)
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
deallocate(H_jj)
|
deallocate(H_jj)
|
||||||
endif
|
endif
|
||||||
call bi_normalize(leigvec_tc_bi_orth,reigvec_tc_bi_orth,size(reigvec_tc_bi_orth,1),N_det,N_states)
|
|
||||||
print*,'leigvec_tc_bi_orth(1,1),reigvec_tc_bi_orth(1,1) = ',leigvec_tc_bi_orth(1,1),reigvec_tc_bi_orth(1,1)
|
call bi_normalize(leigvec_tc_bi_orth, reigvec_tc_bi_orth, size(reigvec_tc_bi_orth, 1), N_det, N_states)
|
||||||
norm_ground_left_right_bi_orth = 0.d0
|
! check bi-orthogonality
|
||||||
do j = 1, N_det
|
allocate(Stmp(N_states,N_states))
|
||||||
norm_ground_left_right_bi_orth += leigvec_tc_bi_orth(j,1) * reigvec_tc_bi_orth(j,1)
|
call dgemm( 'T', 'N', N_states, N_states, N_det, 1.d0 &
|
||||||
enddo
|
, leigvec_tc_bi_orth(1,1), size(leigvec_tc_bi_orth, 1), reigvec_tc_bi_orth(1,1), size(reigvec_tc_bi_orth, 1) &
|
||||||
print*,'norm l/r = ',norm_ground_left_right_bi_orth
|
, 0.d0, Stmp(1,1), size(Stmp, 1) )
|
||||||
print*,'<S2> = ',s2_eigvec_tc_bi_orth(1)
|
print *, ' overlap matrix between states:'
|
||||||
|
do i = 1, N_states
|
||||||
|
write(*,'(1000(F16.10,X))') Stmp(i,:)
|
||||||
|
enddo
|
||||||
|
deallocate(Stmp)
|
||||||
|
|
||||||
|
print*,'leigvec_tc_bi_orth(1,1),reigvec_tc_bi_orth(1,1) = ', leigvec_tc_bi_orth(1,1), reigvec_tc_bi_orth(1,1)
|
||||||
|
do i = 1, N_states
|
||||||
|
norm_ground_left_right_bi_orth = 0.d0
|
||||||
|
do j = 1, N_det
|
||||||
|
norm_ground_left_right_bi_orth += leigvec_tc_bi_orth(j,i) * reigvec_tc_bi_orth(j,i)
|
||||||
|
enddo
|
||||||
|
print*,' state ', i
|
||||||
|
print*,' norm l/r = ', norm_ground_left_right_bi_orth
|
||||||
|
print*,' <S2> = ', s2_eigvec_tc_bi_orth(i)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
double precision, allocatable :: buffer(:,:)
|
||||||
|
allocate(buffer(N_det,N_states))
|
||||||
|
do k = 1, N_states
|
||||||
|
do i = 1, N_det
|
||||||
|
psi_l_coef_bi_ortho(i,k) = leigvec_tc_bi_orth(i,k)
|
||||||
|
buffer(i,k) = leigvec_tc_bi_orth(i,k)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
TOUCH psi_l_coef_bi_ortho
|
||||||
|
call ezfio_set_tc_bi_ortho_psi_l_coef_bi_ortho(buffer)
|
||||||
|
do k = 1, N_states
|
||||||
|
do i = 1, N_det
|
||||||
|
psi_r_coef_bi_ortho(i,k) = reigvec_tc_bi_orth(i,k)
|
||||||
|
buffer(i,k) = reigvec_tc_bi_orth(i,k)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
TOUCH psi_r_coef_bi_ortho
|
||||||
|
call ezfio_set_tc_bi_ortho_psi_r_coef_bi_ortho(buffer)
|
||||||
|
deallocate(buffer)
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
subroutine bi_normalize(u_l,u_r,n,ld,nstates)
|
subroutine bi_normalize(u_l, u_r, n, ld, nstates)
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
!!!! Normalization of the scalar product of the left/right eigenvectors
|
!!!! Normalization of the scalar product of the left/right eigenvectors
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: n, ld, nstates
|
||||||
double precision, intent(inout) :: u_l(ld,nstates), u_r(ld,nstates)
|
double precision, intent(inout) :: u_l(ld,nstates), u_r(ld,nstates)
|
||||||
integer, intent(in) :: n,ld,nstates
|
integer :: i, j
|
||||||
integer :: i
|
double precision :: accu, tmp
|
||||||
double precision :: accu, tmp
|
|
||||||
do i = 1, nstates
|
do i = 1, nstates
|
||||||
!!!! Normalization of right eigenvectors |Phi>
|
|
||||||
accu = 0.d0
|
!!!! Normalization of right eigenvectors |Phi>
|
||||||
do j = 1, n
|
accu = 0.d0
|
||||||
accu += u_r(j,i) * u_r(j,i)
|
do j = 1, n
|
||||||
enddo
|
accu += u_r(j,i) * u_r(j,i)
|
||||||
accu = 1.d0/dsqrt(accu)
|
enddo
|
||||||
print*,'accu_r = ',accu
|
|
||||||
do j = 1, n
|
|
||||||
u_r(j,i) *= accu
|
|
||||||
enddo
|
|
||||||
tmp = u_r(1,i) / dabs(u_r(1,i))
|
|
||||||
do j = 1, n
|
|
||||||
u_r(j,i) *= tmp
|
|
||||||
enddo
|
|
||||||
!!!! Adaptation of the norm of the left eigenvector such that <chi|Phi> = 1
|
|
||||||
accu = 0.d0
|
|
||||||
do j = 1, n
|
|
||||||
accu += u_l(j,i) * u_r(j,i)
|
|
||||||
! print*,j, u_l(j,i) , u_r(j,i)
|
|
||||||
enddo
|
|
||||||
if(accu.gt.0.d0)then
|
|
||||||
accu = 1.d0/dsqrt(accu)
|
accu = 1.d0/dsqrt(accu)
|
||||||
else
|
print*,'accu_r = ',accu
|
||||||
accu = 1.d0/dsqrt(-accu)
|
do j = 1, n
|
||||||
endif
|
u_r(j,i) *= accu
|
||||||
tmp = (u_l(1,i) * u_r(1,i) )/dabs(u_l(1,i) * u_r(1,i))
|
enddo
|
||||||
do j = 1, n
|
tmp = u_r(1,i) / dabs(u_r(1,i))
|
||||||
u_l(j,i) *= accu * tmp
|
do j = 1, n
|
||||||
u_r(j,i) *= accu
|
u_r(j,i) *= tmp
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
|
!!!! Adaptation of the norm of the left eigenvector such that <chi|Phi> = 1
|
||||||
|
accu = 0.d0
|
||||||
|
do j = 1, n
|
||||||
|
accu += u_l(j,i) * u_r(j,i)
|
||||||
|
!print*,j, u_l(j,i) , u_r(j,i)
|
||||||
|
enddo
|
||||||
|
print*,'accu_lr = ', accu
|
||||||
|
if(accu.gt.0.d0)then
|
||||||
|
accu = 1.d0/dsqrt(accu)
|
||||||
|
else
|
||||||
|
accu = 1.d0/dsqrt(-accu)
|
||||||
|
endif
|
||||||
|
tmp = (u_l(1,i) * u_r(1,i) )/dabs(u_l(1,i) * u_r(1,i))
|
||||||
|
do j = 1, n
|
||||||
|
u_l(j,i) *= accu * tmp
|
||||||
|
u_r(j,i) *= accu
|
||||||
|
enddo
|
||||||
|
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
|
@ -9,28 +9,25 @@
|
|||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
integer :: i, j
|
integer :: i, j
|
||||||
double precision :: hmono,htwoe,hthree,htot
|
double precision :: htot
|
||||||
|
|
||||||
PROVIDE N_int
|
PROVIDE N_int
|
||||||
!$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,j,hmono, htwoe, hthree, htot) &
|
|
||||||
|
i = 1
|
||||||
|
j = 1
|
||||||
|
call htilde_mu_mat_opt_bi_ortho_tot(psi_det(1,1,j), psi_det(1,1,i), N_int, htot)
|
||||||
|
|
||||||
|
!$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,j, htot) &
|
||||||
!$OMP SHARED (N_det, psi_det, N_int,htilde_matrix_elmt_bi_ortho)
|
!$OMP SHARED (N_det, psi_det, N_int,htilde_matrix_elmt_bi_ortho)
|
||||||
do i = 1, N_det
|
do i = 1, N_det
|
||||||
do j = 1, N_det
|
do j = 1, N_det
|
||||||
! < J | Htilde | I >
|
! < J | Htilde | I >
|
||||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
call htilde_mu_mat_opt_bi_ortho_tot(psi_det(1,1,j), psi_det(1,1,i), N_int, htot)
|
||||||
|
|
||||||
!print *, ' hmono = ', hmono
|
|
||||||
!print *, ' htwoe = ', htwoe
|
|
||||||
!print *, ' hthree = ', hthree
|
|
||||||
htilde_matrix_elmt_bi_ortho(j,i) = htot
|
htilde_matrix_elmt_bi_ortho(j,i) = htot
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
!$OMP END PARALLEL DO
|
!$OMP END PARALLEL DO
|
||||||
! print*,'htilde_matrix_elmt_bi_ortho = '
|
|
||||||
! do i = 1, min(100,N_det)
|
|
||||||
! write(*,'(100(F16.10,X))')htilde_matrix_elmt_bi_ortho(1:min(100,N_det),i)
|
|
||||||
! enddo
|
|
||||||
|
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
@ -56,8 +56,8 @@ subroutine main()
|
|||||||
U_SOM = 0.d0
|
U_SOM = 0.d0
|
||||||
do i = 1, N_det
|
do i = 1, N_det
|
||||||
if(i == i_HF) cycle
|
if(i == i_HF) cycle
|
||||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,i_HF), psi_det(1,1,i), N_int, hmono_1, htwoe_1, hthree_1, htot_1)
|
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i_HF), psi_det(1,1,i), N_int, hmono_1, htwoe_1, hthree_1, htot_1)
|
||||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,i), psi_det(1,1,i_HF), N_int, hmono_2, htwoe_2, hthree_2, htot_2)
|
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i), psi_det(1,1,i_HF), N_int, hmono_2, htwoe_2, hthree_2, htot_2)
|
||||||
U_SOM += htot_1 * htot_2
|
U_SOM += htot_1 * htot_2
|
||||||
enddo
|
enddo
|
||||||
U_SOM = 0.5d0 * U_SOM
|
U_SOM = 0.5d0 * U_SOM
|
||||||
|
60
src/tc_bi_ortho/tc_utils.irp.f
Normal file
60
src/tc_bi_ortho/tc_utils.irp.f
Normal file
@ -0,0 +1,60 @@
|
|||||||
|
|
||||||
|
subroutine write_tc_energy()
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer :: i, j, k
|
||||||
|
double precision :: hmono, htwoe, hthree, htot
|
||||||
|
double precision :: E_TC, O_TC
|
||||||
|
|
||||||
|
do k = 1, n_states
|
||||||
|
|
||||||
|
E_TC = 0.d0
|
||||||
|
do i = 1, N_det
|
||||||
|
do j = 1, N_det
|
||||||
|
!htot = htilde_matrix_elmt_bi_ortho(i,j)
|
||||||
|
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i), psi_det(1,1,j), N_int, hmono, htwoe, hthree, htot)
|
||||||
|
E_TC = E_TC + psi_l_coef_bi_ortho(i,k) * psi_r_coef_bi_ortho(j,k) * htot
|
||||||
|
!E_TC = E_TC + leigvec_tc_bi_orth(i,k) * reigvec_tc_bi_orth(j,k) * htot
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
O_TC = 0.d0
|
||||||
|
do i = 1, N_det
|
||||||
|
!O_TC = O_TC + leigvec_tc_bi_orth(i,k) * reigvec_tc_bi_orth(i,k)
|
||||||
|
O_TC = O_TC + psi_l_coef_bi_ortho(i,k) * psi_r_coef_bi_ortho(i,k)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
print *, ' state :', k
|
||||||
|
print *, " E_TC = ", E_TC / O_TC
|
||||||
|
print *, " O_TC = ", O_TC
|
||||||
|
|
||||||
|
enddo
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
subroutine write_tc_var()
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer :: i, j, k
|
||||||
|
double precision :: hmono, htwoe, hthree, htot
|
||||||
|
double precision :: SIGMA_TC
|
||||||
|
|
||||||
|
do k = 1, n_states
|
||||||
|
|
||||||
|
SIGMA_TC = 0.d0
|
||||||
|
do j = 2, N_det
|
||||||
|
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,1), psi_det(1,1,j), N_int, hmono, htwoe, hthree, htot)
|
||||||
|
SIGMA_TC = SIGMA_TC + htot * htot
|
||||||
|
enddo
|
||||||
|
|
||||||
|
print *, " state : ", k
|
||||||
|
print *, " SIGMA_TC = ", SIGMA_TC
|
||||||
|
|
||||||
|
enddo
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
@ -35,7 +35,7 @@ subroutine test
|
|||||||
det_i = ref_bitmask
|
det_i = ref_bitmask
|
||||||
call do_single_excitation(det_i,h1,p1,s1,i_ok)
|
call do_single_excitation(det_i,h1,p1,s1,i_ok)
|
||||||
call do_single_excitation(det_i,h2,p2,s2,i_ok)
|
call do_single_excitation(det_i,h2,p2,s2,i_ok)
|
||||||
call htilde_mu_mat_bi_ortho(det_i,HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
|
call htilde_mu_mat_bi_ortho_slow(det_i,HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
|
||||||
call get_excitation_degree(ref_bitmask,det_i,degree,N_int)
|
call get_excitation_degree(ref_bitmask,det_i,degree,N_int)
|
||||||
call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int)
|
call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int)
|
||||||
hthree *= phase
|
hthree *= phase
|
||||||
@ -67,7 +67,7 @@ do h1 = 1, elec_alpha_num
|
|||||||
if(i_ok.ne.1)cycle
|
if(i_ok.ne.1)cycle
|
||||||
call do_single_excitation(det_i,h2,p2,s2,i_ok)
|
call do_single_excitation(det_i,h2,p2,s2,i_ok)
|
||||||
if(i_ok.ne.1)cycle
|
if(i_ok.ne.1)cycle
|
||||||
call htilde_mu_mat_bi_ortho(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
|
call htilde_mu_mat_bi_ortho_slow(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
|
||||||
call get_excitation_degree(ref_bitmask,det_i,degree,N_int)
|
call get_excitation_degree(ref_bitmask,det_i,degree,N_int)
|
||||||
call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int)
|
call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int)
|
||||||
integer :: hh1, pp1, hh2, pp2, ss1, ss2
|
integer :: hh1, pp1, hh2, pp2, ss1, ss2
|
||||||
@ -103,7 +103,7 @@ do h1 = 1, elec_beta_num
|
|||||||
if(i_ok.ne.1)cycle
|
if(i_ok.ne.1)cycle
|
||||||
call do_single_excitation(det_i,h2,p2,s2,i_ok)
|
call do_single_excitation(det_i,h2,p2,s2,i_ok)
|
||||||
if(i_ok.ne.1)cycle
|
if(i_ok.ne.1)cycle
|
||||||
call htilde_mu_mat_bi_ortho(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
|
call htilde_mu_mat_bi_ortho_slow(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
|
||||||
call get_excitation_degree(ref_bitmask,det_i,degree,N_int)
|
call get_excitation_degree(ref_bitmask,det_i,degree,N_int)
|
||||||
call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int)
|
call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int)
|
||||||
call decode_exc(exc, 2, hh1, pp1, hh2, pp2, ss1, ss2)
|
call decode_exc(exc, 2, hh1, pp1, hh2, pp2, ss1, ss2)
|
||||||
|
@ -91,7 +91,7 @@ subroutine routine_test_s2_davidson
|
|||||||
external H_tc_s2_u_0_opt
|
external H_tc_s2_u_0_opt
|
||||||
allocate(H_jj(N_det),vec_tmp(N_det,n_states_diag),energies(n_states_diag), s2(n_states_diag))
|
allocate(H_jj(N_det),vec_tmp(N_det,n_states_diag),energies(n_states_diag), s2(n_states_diag))
|
||||||
do i = 1, N_det
|
do i = 1, N_det
|
||||||
call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,i), N_int, H_jj(i))
|
call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,i), psi_det(1,1,i), N_int, H_jj(i))
|
||||||
enddo
|
enddo
|
||||||
! Preparing the left-eigenvector
|
! Preparing the left-eigenvector
|
||||||
print*,'Computing the left-eigenvector '
|
print*,'Computing the left-eigenvector '
|
||||||
|
@ -31,7 +31,7 @@ subroutine test_h_u0
|
|||||||
u_0(i) = psi_r_coef_bi_ortho(i,1)
|
u_0(i) = psi_r_coef_bi_ortho(i,1)
|
||||||
enddo
|
enddo
|
||||||
call H_tc_u_0_nstates_openmp(v_0_new,u_0,N_states,N_det, do_right)
|
call H_tc_u_0_nstates_openmp(v_0_new,u_0,N_states,N_det, do_right)
|
||||||
call htc_bi_ortho_calc_tdav (v_0_ref,u_0,N_states,N_det)
|
call htc_bi_ortho_calc_tdav_slow (v_0_ref,u_0,N_states,N_det)
|
||||||
print*,'difference right '
|
print*,'difference right '
|
||||||
accu = 0.d0
|
accu = 0.d0
|
||||||
do i = 1, N_det
|
do i = 1, N_det
|
||||||
@ -42,7 +42,7 @@ subroutine test_h_u0
|
|||||||
do_right = .False.
|
do_right = .False.
|
||||||
v_0_new = 0.d0
|
v_0_new = 0.d0
|
||||||
call H_tc_u_0_nstates_openmp(v_0_new,u_0,N_states,N_det, do_right)
|
call H_tc_u_0_nstates_openmp(v_0_new,u_0,N_states,N_det, do_right)
|
||||||
call htcdag_bi_ortho_calc_tdav(v_0_ref_dagger,u_0,N_states,N_det, do_right)
|
call htcdag_bi_ortho_calc_tdav_slow(v_0_ref_dagger,u_0,N_states,N_det, do_right)
|
||||||
print*,'difference left'
|
print*,'difference left'
|
||||||
accu = 0.d0
|
accu = 0.d0
|
||||||
do i = 1, N_det
|
do i = 1, N_det
|
||||||
@ -63,7 +63,7 @@ subroutine test_slater_tc_opt
|
|||||||
i_count = 0.d0
|
i_count = 0.d0
|
||||||
do i = 1, N_det
|
do i = 1, N_det
|
||||||
do j = 1,N_det
|
do j = 1,N_det
|
||||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hnewmono, hnewtwoe, hnewthree, hnewtot)
|
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hnewmono, hnewtwoe, hnewthree, hnewtot)
|
||||||
if(dabs(htot).gt.1.d-15)then
|
if(dabs(htot).gt.1.d-15)then
|
||||||
i_count += 1.D0
|
i_count += 1.D0
|
||||||
@ -99,7 +99,7 @@ subroutine timing_tot
|
|||||||
do j = 1, N_det
|
do j = 1, N_det
|
||||||
! call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
|
! call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
|
||||||
i_count += 1.d0
|
i_count += 1.d0
|
||||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
call wall_time(wall1)
|
call wall_time(wall1)
|
||||||
@ -146,7 +146,7 @@ subroutine timing_diag
|
|||||||
do i = 1, N_det
|
do i = 1, N_det
|
||||||
do j = i,i
|
do j = i,i
|
||||||
i_count += 1.d0
|
i_count += 1.d0
|
||||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
call wall_time(wall1)
|
call wall_time(wall1)
|
||||||
@ -183,7 +183,7 @@ subroutine timing_single
|
|||||||
if(degree.ne.1)cycle
|
if(degree.ne.1)cycle
|
||||||
i_count += 1.d0
|
i_count += 1.d0
|
||||||
call wall_time(wall0)
|
call wall_time(wall0)
|
||||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||||
call wall_time(wall1)
|
call wall_time(wall1)
|
||||||
accu += wall1 - wall0
|
accu += wall1 - wall0
|
||||||
enddo
|
enddo
|
||||||
@ -225,7 +225,7 @@ subroutine timing_double
|
|||||||
if(degree.ne.2)cycle
|
if(degree.ne.2)cycle
|
||||||
i_count += 1.d0
|
i_count += 1.d0
|
||||||
call wall_time(wall0)
|
call wall_time(wall0)
|
||||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||||
call wall_time(wall1)
|
call wall_time(wall1)
|
||||||
accu += wall1 - wall0
|
accu += wall1 - wall0
|
||||||
enddo
|
enddo
|
||||||
|
@ -25,8 +25,7 @@ subroutine test_3e
|
|||||||
implicit none
|
implicit none
|
||||||
double precision :: integral_aaa,integral_aab,integral_abb,integral_bbb,accu
|
double precision :: integral_aaa,integral_aab,integral_abb,integral_bbb,accu
|
||||||
double precision :: hmono, htwoe, hthree, htot
|
double precision :: hmono, htwoe, hthree, htot
|
||||||
call htilde_mu_mat_bi_ortho(ref_bitmask, ref_bitmask, N_int, hmono, htwoe, hthree, htot)
|
call htilde_mu_mat_bi_ortho_slow(ref_bitmask, ref_bitmask, N_int, hmono, htwoe, hthree, htot)
|
||||||
! call diag_htilde_three_body_ints_bi_ort(N_int, ref_bitmask, hthree)
|
|
||||||
print*,'hmono = ',hmono
|
print*,'hmono = ',hmono
|
||||||
print*,'htwoe = ',htwoe
|
print*,'htwoe = ',htwoe
|
||||||
print*,'hthree= ',hthree
|
print*,'hthree= ',hthree
|
||||||
@ -88,7 +87,7 @@ subroutine routine_3()
|
|||||||
print*, ' excited det'
|
print*, ' excited det'
|
||||||
call debug_det(det_i, N_int)
|
call debug_det(det_i, N_int)
|
||||||
|
|
||||||
call htilde_mu_mat_bi_ortho(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij)
|
call htilde_mu_mat_bi_ortho_slow(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij)
|
||||||
if(dabs(hthree).lt.1.d-10)cycle
|
if(dabs(hthree).lt.1.d-10)cycle
|
||||||
ref = hthree
|
ref = hthree
|
||||||
if(s1 == 1)then
|
if(s1 == 1)then
|
||||||
@ -156,7 +155,7 @@ subroutine routine_tot()
|
|||||||
stop
|
stop
|
||||||
endif
|
endif
|
||||||
|
|
||||||
call htilde_mu_mat_bi_ortho(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij)
|
call htilde_mu_mat_bi_ortho_slow(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij)
|
||||||
print*,htilde_ij
|
print*,htilde_ij
|
||||||
if(dabs(htilde_ij).lt.1.d-10)cycle
|
if(dabs(htilde_ij).lt.1.d-10)cycle
|
||||||
print*, ' excited det'
|
print*, ' excited det'
|
||||||
|
@ -16,6 +16,24 @@ doc: If |true|, three-body terms are included
|
|||||||
interface: ezfio,provider,ocaml
|
interface: ezfio,provider,ocaml
|
||||||
default: True
|
default: True
|
||||||
|
|
||||||
|
[three_e_3_idx_term]
|
||||||
|
type: logical
|
||||||
|
doc: If |true|, the diagonal 3-idx terms of the 3-e interaction are taken
|
||||||
|
interface: ezfio,provider,ocaml
|
||||||
|
default: True
|
||||||
|
|
||||||
|
[three_e_4_idx_term]
|
||||||
|
type: logical
|
||||||
|
doc: If |true|, the off-diagonal 4-idx terms of the 3-e interaction are taken
|
||||||
|
interface: ezfio,provider,ocaml
|
||||||
|
default: True
|
||||||
|
|
||||||
|
[three_e_5_idx_term]
|
||||||
|
type: logical
|
||||||
|
doc: If |true|, the off-diagonal 5-idx terms of the 3-e interaction are taken
|
||||||
|
interface: ezfio,provider,ocaml
|
||||||
|
default: True
|
||||||
|
|
||||||
[pure_three_body_h_tc]
|
[pure_three_body_h_tc]
|
||||||
type: logical
|
type: logical
|
||||||
doc: If |true|, pure triple excitation three-body terms are included
|
doc: If |true|, pure triple excitation three-body terms are included
|
||||||
@ -124,6 +142,18 @@ doc: type of 1-body Jastrow
|
|||||||
interface: ezfio, provider, ocaml
|
interface: ezfio, provider, ocaml
|
||||||
default: 0
|
default: 0
|
||||||
|
|
||||||
|
[mu_r_ct]
|
||||||
|
type: double precision
|
||||||
|
doc: a parameter used to define mu(r)
|
||||||
|
interface: ezfio, provider, ocaml
|
||||||
|
default: 6.203504908994001e-1
|
||||||
|
|
||||||
|
[beta_rho_power]
|
||||||
|
type: double precision
|
||||||
|
doc: a parameter used to define mu(r)
|
||||||
|
interface: ezfio, provider, ocaml
|
||||||
|
default: 0.5
|
||||||
|
|
||||||
[thr_degen_tc]
|
[thr_degen_tc]
|
||||||
type: Threshold
|
type: Threshold
|
||||||
doc: Threshold to determine if two orbitals are degenerate in TCSCF in order to avoid random quasi orthogonality between the right- and left-eigenvector for the same eigenvalue
|
doc: Threshold to determine if two orbitals are degenerate in TCSCF in order to avoid random quasi orthogonality between the right- and left-eigenvector for the same eigenvalue
|
||||||
@ -170,7 +200,7 @@ default: 1.e-7
|
|||||||
type: logical
|
type: logical
|
||||||
doc: If |true|, the integrals of the three-body jastrow are computed with cycles
|
doc: If |true|, the integrals of the three-body jastrow are computed with cycles
|
||||||
interface: ezfio,provider,ocaml
|
interface: ezfio,provider,ocaml
|
||||||
default: True
|
default: False
|
||||||
|
|
||||||
[thresh_biorthog_diag]
|
[thresh_biorthog_diag]
|
||||||
type: Threshold
|
type: Threshold
|
||||||
@ -214,4 +244,9 @@ doc: If |true|, save the bi-ortho wave functions in a sorted way
|
|||||||
interface: ezfio,provider,ocaml
|
interface: ezfio,provider,ocaml
|
||||||
default: True
|
default: True
|
||||||
|
|
||||||
|
[use_ipp]
|
||||||
|
type: logical
|
||||||
|
doc: If |true|, use Manu IPP
|
||||||
|
interface: ezfio,provider,ocaml
|
||||||
|
default: True
|
||||||
|
|
||||||
|
@ -87,22 +87,31 @@ BEGIN_PROVIDER [double precision, FQS_SQF_ao, (ao_num, ao_num)]
|
|||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
integer :: i, j
|
integer :: i, j
|
||||||
|
double precision :: t0, t1
|
||||||
double precision, allocatable :: tmp(:,:)
|
double precision, allocatable :: tmp(:,:)
|
||||||
double precision, allocatable :: F(:,:)
|
double precision, allocatable :: F(:,:)
|
||||||
|
|
||||||
|
!print *, ' Providing FQS_SQF_ao ...'
|
||||||
|
!call wall_time(t0)
|
||||||
|
|
||||||
allocate(F(ao_num,ao_num))
|
allocate(F(ao_num,ao_num))
|
||||||
if(var_tc) then
|
if(var_tc) then
|
||||||
|
|
||||||
do i = 1, ao_num
|
do i = 1, ao_num
|
||||||
do j = 1, ao_num
|
do j = 1, ao_num
|
||||||
F(j,i) = Fock_matrix_vartc_ao_tot(j,i)
|
F(j,i) = Fock_matrix_vartc_ao_tot(j,i)
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
else
|
else
|
||||||
|
|
||||||
|
PROVIDE Fock_matrix_tc_ao_tot
|
||||||
do i = 1, ao_num
|
do i = 1, ao_num
|
||||||
do j = 1, ao_num
|
do j = 1, ao_num
|
||||||
F(j,i) = Fock_matrix_tc_ao_tot(j,i)
|
F(j,i) = Fock_matrix_tc_ao_tot(j,i)
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
endif
|
endif
|
||||||
|
|
||||||
allocate(tmp(ao_num,ao_num))
|
allocate(tmp(ao_num,ao_num))
|
||||||
@ -131,6 +140,9 @@ BEGIN_PROVIDER [double precision, FQS_SQF_ao, (ao_num, ao_num)]
|
|||||||
deallocate(tmp)
|
deallocate(tmp)
|
||||||
deallocate(F)
|
deallocate(F)
|
||||||
|
|
||||||
|
!call wall_time(t1)
|
||||||
|
!print *, ' Wall time for FQS_SQF_ao =', t1-t0
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
! ---
|
! ---
|
||||||
@ -138,10 +150,20 @@ END_PROVIDER
|
|||||||
BEGIN_PROVIDER [double precision, FQS_SQF_mo, (mo_num, mo_num)]
|
BEGIN_PROVIDER [double precision, FQS_SQF_mo, (mo_num, mo_num)]
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
|
double precision :: t0, t1
|
||||||
|
|
||||||
|
!print*, ' Providing FQS_SQF_mo ...'
|
||||||
|
!call wall_time(t0)
|
||||||
|
|
||||||
|
PROVIDE mo_r_coef mo_l_coef
|
||||||
|
PROVIDE FQS_SQF_ao
|
||||||
|
|
||||||
call ao_to_mo_bi_ortho( FQS_SQF_ao, size(FQS_SQF_ao, 1) &
|
call ao_to_mo_bi_ortho( FQS_SQF_ao, size(FQS_SQF_ao, 1) &
|
||||||
, FQS_SQF_mo, size(FQS_SQF_mo, 1) )
|
, FQS_SQF_mo, size(FQS_SQF_mo, 1) )
|
||||||
|
|
||||||
|
!call wall_time(t1)
|
||||||
|
!print*, ' Wall time for FQS_SQF_mo =', t1-t0
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
@ -4,17 +4,27 @@
|
|||||||
BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_cs, (mo_num, mo_num)]
|
BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_cs, (mo_num, mo_num)]
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
integer :: a, b, i, j
|
integer :: a, b, i, j
|
||||||
double precision :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
|
double precision :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
|
||||||
double precision :: ti, tf
|
double precision :: ti, tf
|
||||||
|
double precision, allocatable :: tmp(:,:)
|
||||||
|
|
||||||
PROVIDE mo_l_coef mo_r_coef
|
PROVIDE mo_l_coef mo_r_coef
|
||||||
|
call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, I_bij_aij)
|
||||||
|
|
||||||
!print *, ' PROVIDING fock_3e_uhf_mo_cs ...'
|
!print *, ' PROVIDING fock_3e_uhf_mo_cs ...'
|
||||||
call wall_time(ti)
|
!call wall_time(ti)
|
||||||
|
|
||||||
fock_3e_uhf_mo_cs = 0.d0
|
fock_3e_uhf_mo_cs = 0.d0
|
||||||
|
|
||||||
|
!$OMP PARALLEL DEFAULT (NONE) &
|
||||||
|
!$OMP PRIVATE (a, b, i, j, I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia, tmp) &
|
||||||
|
!$OMP SHARED (mo_num, elec_beta_num, fock_3e_uhf_mo_cs)
|
||||||
|
|
||||||
|
allocate(tmp(mo_num,mo_num))
|
||||||
|
tmp = 0.d0
|
||||||
|
|
||||||
|
!$OMP DO
|
||||||
do a = 1, mo_num
|
do a = 1, mo_num
|
||||||
do b = 1, mo_num
|
do b = 1, mo_num
|
||||||
|
|
||||||
@ -28,19 +38,31 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_cs, (mo_num, mo_num)]
|
|||||||
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
||||||
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
||||||
|
|
||||||
fock_3e_uhf_mo_cs(b,a) -= 0.5d0 * ( 4.d0 * I_bij_aij &
|
tmp(b,a) -= 0.5d0 * ( 4.d0 * I_bij_aij &
|
||||||
+ I_bij_ija &
|
+ I_bij_ija &
|
||||||
+ I_bij_jai &
|
+ I_bij_jai &
|
||||||
- 2.d0 * I_bij_aji &
|
- 2.d0 * I_bij_aji &
|
||||||
- 2.d0 * I_bij_iaj &
|
- 2.d0 * I_bij_iaj &
|
||||||
- 2.d0 * I_bij_jia )
|
- 2.d0 * I_bij_jia )
|
||||||
|
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
|
!$OMP END DO NOWAIT
|
||||||
|
|
||||||
call wall_time(tf)
|
!$OMP CRITICAL
|
||||||
|
do a = 1, mo_num
|
||||||
|
do b = 1, mo_num
|
||||||
|
fock_3e_uhf_mo_cs(b,a) += tmp(b,a)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
!$OMP END CRITICAL
|
||||||
|
|
||||||
|
deallocate(tmp)
|
||||||
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
|
!call wall_time(tf)
|
||||||
!print *, ' total Wall time for fock_3e_uhf_mo_cs =', tf - ti
|
!print *, ' total Wall time for fock_3e_uhf_mo_cs =', tf - ti
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
@ -50,24 +72,38 @@ END_PROVIDER
|
|||||||
BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a, (mo_num, mo_num)]
|
BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a, (mo_num, mo_num)]
|
||||||
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! ALPHA part of the Fock matrix from three-electron terms
|
!
|
||||||
!
|
! ALPHA part of the Fock matrix from three-electron terms
|
||||||
! WARNING :: non hermitian if bi-ortho MOS used
|
!
|
||||||
|
! WARNING :: non hermitian if bi-ortho MOS used
|
||||||
|
!
|
||||||
END_DOC
|
END_DOC
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
integer :: a, b, i, j, o
|
integer :: a, b, i, j, o
|
||||||
double precision :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
|
double precision :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
|
||||||
double precision :: ti, tf
|
double precision :: ti, tf
|
||||||
|
double precision, allocatable :: tmp(:,:)
|
||||||
|
|
||||||
PROVIDE mo_l_coef mo_r_coef
|
PROVIDE mo_l_coef mo_r_coef
|
||||||
|
PROVIDE fock_3e_uhf_mo_cs
|
||||||
|
|
||||||
!print *, ' PROVIDING fock_3e_uhf_mo_a ...'
|
!print *, ' Providing fock_3e_uhf_mo_a ...'
|
||||||
call wall_time(ti)
|
!call wall_time(ti)
|
||||||
|
|
||||||
o = elec_beta_num + 1
|
o = elec_beta_num + 1
|
||||||
|
call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, I_bij_aij)
|
||||||
|
|
||||||
fock_3e_uhf_mo_a = fock_3e_uhf_mo_cs
|
fock_3e_uhf_mo_a = fock_3e_uhf_mo_cs
|
||||||
|
|
||||||
|
!$OMP PARALLEL DEFAULT (NONE) &
|
||||||
|
!$OMP PRIVATE (a, b, i, j, I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia, tmp) &
|
||||||
|
!$OMP SHARED (mo_num, o, elec_alpha_num, elec_beta_num, fock_3e_uhf_mo_a)
|
||||||
|
|
||||||
|
allocate(tmp(mo_num,mo_num))
|
||||||
|
tmp = 0.d0
|
||||||
|
|
||||||
|
!$OMP DO
|
||||||
do a = 1, mo_num
|
do a = 1, mo_num
|
||||||
do b = 1, mo_num
|
do b = 1, mo_num
|
||||||
|
|
||||||
@ -83,12 +119,12 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a, (mo_num, mo_num)]
|
|||||||
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
||||||
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
||||||
|
|
||||||
fock_3e_uhf_mo_a(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
|
tmp(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
|
||||||
+ I_bij_ija &
|
+ I_bij_ija &
|
||||||
+ I_bij_jai &
|
+ I_bij_jai &
|
||||||
- I_bij_aji &
|
- I_bij_aji &
|
||||||
- I_bij_iaj &
|
- I_bij_iaj &
|
||||||
- 2.d0 * I_bij_jia )
|
- 2.d0 * I_bij_jia )
|
||||||
|
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
@ -105,12 +141,12 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a, (mo_num, mo_num)]
|
|||||||
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
||||||
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
||||||
|
|
||||||
fock_3e_uhf_mo_a(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
|
tmp(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
|
||||||
+ I_bij_ija &
|
+ I_bij_ija &
|
||||||
+ I_bij_jai &
|
+ I_bij_jai &
|
||||||
- I_bij_aji &
|
- I_bij_aji &
|
||||||
- 2.d0 * I_bij_iaj &
|
- 2.d0 * I_bij_iaj &
|
||||||
- I_bij_jia )
|
- I_bij_jia )
|
||||||
|
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
@ -127,12 +163,12 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a, (mo_num, mo_num)]
|
|||||||
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
||||||
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
||||||
|
|
||||||
fock_3e_uhf_mo_a(b,a) -= 0.5d0 * ( I_bij_aij &
|
tmp(b,a) -= 0.5d0 * ( I_bij_aij &
|
||||||
+ I_bij_ija &
|
+ I_bij_ija &
|
||||||
+ I_bij_jai &
|
+ I_bij_jai &
|
||||||
- I_bij_aji &
|
- I_bij_aji &
|
||||||
- I_bij_iaj &
|
- I_bij_iaj &
|
||||||
- I_bij_jia )
|
- I_bij_jia )
|
||||||
|
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
@ -141,35 +177,58 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a, (mo_num, mo_num)]
|
|||||||
|
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
|
!$OMP END DO NOWAIT
|
||||||
|
|
||||||
call wall_time(tf)
|
!$OMP CRITICAL
|
||||||
!print *, ' total Wall time for fock_3e_uhf_mo_a =', tf - ti
|
do a = 1, mo_num
|
||||||
|
do b = 1, mo_num
|
||||||
|
fock_3e_uhf_mo_a(b,a) += tmp(b,a)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
!$OMP END CRITICAL
|
||||||
|
|
||||||
|
deallocate(tmp)
|
||||||
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
|
!call wall_time(tf)
|
||||||
|
!print *, ' Wall time for fock_3e_uhf_mo_a =', tf - ti
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
|
||||||
BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b, (mo_num, mo_num)]
|
BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b, (mo_num, mo_num)]
|
||||||
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! BETA part of the Fock matrix from three-electron terms
|
! BETA part of the Fock matrix from three-electron terms
|
||||||
!
|
!
|
||||||
! WARNING :: non hermitian if bi-ortho MOS used
|
! WARNING :: non hermitian if bi-ortho MOS used
|
||||||
END_DOC
|
END_DOC
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
integer :: a, b, i, j, o
|
integer :: a, b, i, j, o
|
||||||
double precision :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
|
double precision :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
|
||||||
double precision :: ti, tf
|
double precision :: ti, tf
|
||||||
|
double precision, allocatable :: tmp(:,:)
|
||||||
|
|
||||||
PROVIDE mo_l_coef mo_r_coef
|
PROVIDE mo_l_coef mo_r_coef
|
||||||
|
|
||||||
!print *, ' PROVIDING fock_3e_uhf_mo_b ...'
|
!print *, ' PROVIDING fock_3e_uhf_mo_b ...'
|
||||||
call wall_time(ti)
|
!call wall_time(ti)
|
||||||
|
|
||||||
o = elec_beta_num + 1
|
o = elec_beta_num + 1
|
||||||
|
call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, I_bij_aij)
|
||||||
|
|
||||||
fock_3e_uhf_mo_b = fock_3e_uhf_mo_cs
|
fock_3e_uhf_mo_b = fock_3e_uhf_mo_cs
|
||||||
|
|
||||||
|
!$OMP PARALLEL DEFAULT (NONE) &
|
||||||
|
!$OMP PRIVATE (a, b, i, j, I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia, tmp) &
|
||||||
|
!$OMP SHARED (mo_num, o, elec_alpha_num, elec_beta_num, fock_3e_uhf_mo_b)
|
||||||
|
|
||||||
|
allocate(tmp(mo_num,mo_num))
|
||||||
|
tmp = 0.d0
|
||||||
|
|
||||||
|
!$OMP DO
|
||||||
do a = 1, mo_num
|
do a = 1, mo_num
|
||||||
do b = 1, mo_num
|
do b = 1, mo_num
|
||||||
|
|
||||||
@ -185,9 +244,9 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b, (mo_num, mo_num)]
|
|||||||
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
||||||
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
||||||
|
|
||||||
fock_3e_uhf_mo_b(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
|
tmp(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
|
||||||
- I_bij_aji &
|
- I_bij_aji &
|
||||||
- I_bij_iaj )
|
- I_bij_iaj )
|
||||||
|
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
@ -204,9 +263,9 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b, (mo_num, mo_num)]
|
|||||||
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
||||||
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
||||||
|
|
||||||
fock_3e_uhf_mo_b(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
|
tmp(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
|
||||||
- I_bij_aji &
|
- I_bij_aji &
|
||||||
- I_bij_jia )
|
- I_bij_jia )
|
||||||
|
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
@ -223,8 +282,8 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b, (mo_num, mo_num)]
|
|||||||
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
||||||
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
||||||
|
|
||||||
fock_3e_uhf_mo_b(b,a) -= 0.5d0 * ( I_bij_aij &
|
tmp(b,a) -= 0.5d0 * ( I_bij_aij &
|
||||||
- I_bij_aji )
|
- I_bij_aji )
|
||||||
|
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
@ -233,8 +292,20 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b, (mo_num, mo_num)]
|
|||||||
|
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
|
!$OMP END DO NOWAIT
|
||||||
|
|
||||||
call wall_time(tf)
|
!$OMP CRITICAL
|
||||||
|
do a = 1, mo_num
|
||||||
|
do b = 1, mo_num
|
||||||
|
fock_3e_uhf_mo_b(b,a) += tmp(b,a)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
!$OMP END CRITICAL
|
||||||
|
|
||||||
|
deallocate(tmp)
|
||||||
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
|
!call wall_time(tf)
|
||||||
!print *, ' total Wall time for fock_3e_uhf_mo_b =', tf - ti
|
!print *, ' total Wall time for fock_3e_uhf_mo_b =', tf - ti
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
@ -267,15 +338,15 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_ao_a, (ao_num, ao_num)]
|
|||||||
|
|
||||||
fock_3e_uhf_ao_a = 0.d0
|
fock_3e_uhf_ao_a = 0.d0
|
||||||
|
|
||||||
!$OMP PARALLEL DEFAULT (NONE) &
|
!$OMP PARALLEL DEFAULT (NONE) &
|
||||||
!$OMP PRIVATE (g, e, d, k, mu, nu, dm_ge_a, dm_ge_b, dm_ge, dm_dk_a, dm_dk_b, dm_dk, f_tmp, &
|
!$OMP PRIVATE (g, e, d, k, mu, nu, dm_ge_a, dm_ge_b, dm_ge, dm_dk_a, dm_dk_b, dm_dk, f_tmp, &
|
||||||
!$OMP i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu) &
|
!$OMP i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu) &
|
||||||
!$OMP SHARED (ao_num, TCSCF_bi_ort_dm_ao_alpha, TCSCF_bi_ort_dm_ao_beta, fock_3e_uhf_ao_a)
|
!$OMP SHARED (ao_num, TCSCF_bi_ort_dm_ao_alpha, TCSCF_bi_ort_dm_ao_beta, fock_3e_uhf_ao_a)
|
||||||
|
|
||||||
allocate(f_tmp(ao_num,ao_num))
|
allocate(f_tmp(ao_num,ao_num))
|
||||||
f_tmp = 0.d0
|
f_tmp = 0.d0
|
||||||
|
|
||||||
!$OMP DO
|
!$OMP DO
|
||||||
do g = 1, ao_num
|
do g = 1, ao_num
|
||||||
do e = 1, ao_num
|
do e = 1, ao_num
|
||||||
dm_ge_a = TCSCF_bi_ort_dm_ao_alpha(g,e)
|
dm_ge_a = TCSCF_bi_ort_dm_ao_alpha(g,e)
|
||||||
@ -307,18 +378,18 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_ao_a, (ao_num, ao_num)]
|
|||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
!$OMP END DO NOWAIT
|
!$OMP END DO NOWAIT
|
||||||
|
|
||||||
!$OMP CRITICAL
|
!$OMP CRITICAL
|
||||||
do mu = 1, ao_num
|
do mu = 1, ao_num
|
||||||
do nu = 1, ao_num
|
do nu = 1, ao_num
|
||||||
fock_3e_uhf_ao_a(mu,nu) += f_tmp(mu,nu)
|
fock_3e_uhf_ao_a(mu,nu) += f_tmp(mu,nu)
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
!$OMP END CRITICAL
|
!$OMP END CRITICAL
|
||||||
|
|
||||||
deallocate(f_tmp)
|
deallocate(f_tmp)
|
||||||
!$OMP END PARALLEL
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
call wall_time(tf)
|
call wall_time(tf)
|
||||||
print *, ' total Wall time for fock_3e_uhf_ao_a =', tf - ti
|
print *, ' total Wall time for fock_3e_uhf_ao_a =', tf - ti
|
||||||
@ -353,15 +424,15 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_ao_b, (ao_num, ao_num)]
|
|||||||
|
|
||||||
fock_3e_uhf_ao_b = 0.d0
|
fock_3e_uhf_ao_b = 0.d0
|
||||||
|
|
||||||
!$OMP PARALLEL DEFAULT (NONE) &
|
!$OMP PARALLEL DEFAULT (NONE) &
|
||||||
!$OMP PRIVATE (g, e, d, k, mu, nu, dm_ge_a, dm_ge_b, dm_ge, dm_dk_a, dm_dk_b, dm_dk, f_tmp, &
|
!$OMP PRIVATE (g, e, d, k, mu, nu, dm_ge_a, dm_ge_b, dm_ge, dm_dk_a, dm_dk_b, dm_dk, f_tmp, &
|
||||||
!$OMP i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu) &
|
!$OMP i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu) &
|
||||||
!$OMP SHARED (ao_num, TCSCF_bi_ort_dm_ao_alpha, TCSCF_bi_ort_dm_ao_beta, fock_3e_uhf_ao_b)
|
!$OMP SHARED (ao_num, TCSCF_bi_ort_dm_ao_alpha, TCSCF_bi_ort_dm_ao_beta, fock_3e_uhf_ao_b)
|
||||||
|
|
||||||
allocate(f_tmp(ao_num,ao_num))
|
allocate(f_tmp(ao_num,ao_num))
|
||||||
f_tmp = 0.d0
|
f_tmp = 0.d0
|
||||||
|
|
||||||
!$OMP DO
|
!$OMP DO
|
||||||
do g = 1, ao_num
|
do g = 1, ao_num
|
||||||
do e = 1, ao_num
|
do e = 1, ao_num
|
||||||
dm_ge_a = TCSCF_bi_ort_dm_ao_alpha(g,e)
|
dm_ge_a = TCSCF_bi_ort_dm_ao_alpha(g,e)
|
||||||
@ -393,18 +464,18 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_ao_b, (ao_num, ao_num)]
|
|||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
!$OMP END DO NOWAIT
|
!$OMP END DO NOWAIT
|
||||||
|
|
||||||
!$OMP CRITICAL
|
!$OMP CRITICAL
|
||||||
do mu = 1, ao_num
|
do mu = 1, ao_num
|
||||||
do nu = 1, ao_num
|
do nu = 1, ao_num
|
||||||
fock_3e_uhf_ao_b(mu,nu) += f_tmp(mu,nu)
|
fock_3e_uhf_ao_b(mu,nu) += f_tmp(mu,nu)
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
!$OMP END CRITICAL
|
!$OMP END CRITICAL
|
||||||
|
|
||||||
deallocate(f_tmp)
|
deallocate(f_tmp)
|
||||||
!$OMP END PARALLEL
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
call wall_time(tf)
|
call wall_time(tf)
|
||||||
print *, ' total Wall time for fock_3e_uhf_ao_b =', tf - ti
|
print *, ' total Wall time for fock_3e_uhf_ao_b =', tf - ti
|
||||||
|
@ -18,6 +18,8 @@
|
|||||||
double precision :: density, density_a, density_b
|
double precision :: density, density_a, density_b
|
||||||
double precision :: t0, t1
|
double precision :: t0, t1
|
||||||
|
|
||||||
|
PROVIDE ao_two_e_tc_tot
|
||||||
|
|
||||||
!print*, ' providing two_e_tc_non_hermit_integral_seq ...'
|
!print*, ' providing two_e_tc_non_hermit_integral_seq ...'
|
||||||
!call wall_time(t0)
|
!call wall_time(t0)
|
||||||
|
|
||||||
@ -80,22 +82,26 @@ END_PROVIDER
|
|||||||
double precision :: t0, t1
|
double precision :: t0, t1
|
||||||
double precision, allocatable :: tmp_a(:,:), tmp_b(:,:)
|
double precision, allocatable :: tmp_a(:,:), tmp_b(:,:)
|
||||||
|
|
||||||
!print*, ' providing two_e_tc_non_hermit_integral ...'
|
PROVIDE ao_two_e_tc_tot
|
||||||
|
PROVIDE mo_l_coef mo_r_coef
|
||||||
|
PROVIDE TCSCF_density_matrix_ao_alpha TCSCF_density_matrix_ao_beta
|
||||||
|
|
||||||
|
!print*, ' Providing two_e_tc_non_hermit_integral ...'
|
||||||
!call wall_time(t0)
|
!call wall_time(t0)
|
||||||
|
|
||||||
two_e_tc_non_hermit_integral_alpha = 0.d0
|
two_e_tc_non_hermit_integral_alpha = 0.d0
|
||||||
two_e_tc_non_hermit_integral_beta = 0.d0
|
two_e_tc_non_hermit_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_tc_tot, &
|
!$OMP SHARED (ao_num, TCSCF_density_matrix_ao_alpha, TCSCF_density_matrix_ao_beta, ao_two_e_tc_tot, &
|
||||||
!$OMP two_e_tc_non_hermit_integral_alpha, two_e_tc_non_hermit_integral_beta)
|
!$OMP two_e_tc_non_hermit_integral_alpha, two_e_tc_non_hermit_integral_beta)
|
||||||
|
|
||||||
allocate(tmp_a(ao_num,ao_num), tmp_b(ao_num,ao_num))
|
allocate(tmp_a(ao_num,ao_num), tmp_b(ao_num,ao_num))
|
||||||
tmp_a = 0.d0
|
tmp_a = 0.d0
|
||||||
tmp_b = 0.d0
|
tmp_b = 0.d0
|
||||||
|
|
||||||
!$OMP DO
|
!$OMP DO
|
||||||
do j = 1, ao_num
|
do j = 1, ao_num
|
||||||
do l = 1, ao_num
|
do l = 1, ao_num
|
||||||
density_a = TCSCF_density_matrix_ao_alpha(l,j)
|
density_a = TCSCF_density_matrix_ao_alpha(l,j)
|
||||||
@ -113,22 +119,22 @@ END_PROVIDER
|
|||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
!$OMP END DO NOWAIT
|
!$OMP END DO NOWAIT
|
||||||
|
|
||||||
!$OMP CRITICAL
|
!$OMP CRITICAL
|
||||||
do i = 1, ao_num
|
do i = 1, ao_num
|
||||||
do j = 1, ao_num
|
do j = 1, ao_num
|
||||||
two_e_tc_non_hermit_integral_alpha(j,i) += tmp_a(j,i)
|
two_e_tc_non_hermit_integral_alpha(j,i) += tmp_a(j,i)
|
||||||
two_e_tc_non_hermit_integral_beta (j,i) += tmp_b(j,i)
|
two_e_tc_non_hermit_integral_beta (j,i) += tmp_b(j,i)
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
!$OMP END CRITICAL
|
!$OMP END CRITICAL
|
||||||
|
|
||||||
deallocate(tmp_a, tmp_b)
|
deallocate(tmp_a, tmp_b)
|
||||||
!$OMP END PARALLEL
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
!call wall_time(t1)
|
!call wall_time(t1)
|
||||||
!print*, ' wall time for two_e_tc_non_hermit_integral after = ', t1 - t0
|
!print*, ' Wall time for two_e_tc_non_hermit_integral = ', t1 - t0
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
@ -141,8 +147,15 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_tc_ao_alpha, (ao_num, ao_num)]
|
|||||||
END_DOC
|
END_DOC
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
|
double precision :: t0, t1
|
||||||
|
|
||||||
Fock_matrix_tc_ao_alpha = ao_one_e_integrals_tc_tot + two_e_tc_non_hermit_integral_alpha
|
!print*, ' Providing Fock_matrix_tc_ao_alpha ...'
|
||||||
|
!call wall_time(t0)
|
||||||
|
|
||||||
|
Fock_matrix_tc_ao_alpha = ao_one_e_integrals_tc_tot + two_e_tc_non_hermit_integral_alpha
|
||||||
|
|
||||||
|
!call wall_time(t1)
|
||||||
|
!print*, ' Wall time for Fock_matrix_tc_ao_alpha =', t1-t0
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
@ -169,8 +182,12 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_alpha, (mo_num, mo_num) ]
|
|||||||
END_DOC
|
END_DOC
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
|
double precision :: t0, t1, tt0, tt1
|
||||||
double precision, allocatable :: tmp(:,:)
|
double precision, allocatable :: tmp(:,:)
|
||||||
|
|
||||||
|
!print*, ' Providing Fock_matrix_tc_mo_alpha ...'
|
||||||
|
!call wall_time(t0)
|
||||||
|
|
||||||
if(bi_ortho) then
|
if(bi_ortho) then
|
||||||
|
|
||||||
!allocate(tmp(ao_num,ao_num))
|
!allocate(tmp(ao_num,ao_num))
|
||||||
@ -181,19 +198,34 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_alpha, (mo_num, mo_num) ]
|
|||||||
!call ao_to_mo_bi_ortho(tmp, size(tmp, 1), Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1))
|
!call ao_to_mo_bi_ortho(tmp, size(tmp, 1), Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1))
|
||||||
!deallocate(tmp)
|
!deallocate(tmp)
|
||||||
|
|
||||||
|
PROVIDE mo_l_coef mo_r_coef
|
||||||
|
|
||||||
|
!call wall_time(tt0)
|
||||||
call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_alpha, size(Fock_matrix_tc_ao_alpha, 1) &
|
call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_alpha, size(Fock_matrix_tc_ao_alpha, 1) &
|
||||||
, Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1) )
|
, Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1) )
|
||||||
|
!call wall_time(tt1)
|
||||||
|
!print*, ' 2-e term:', tt1-tt0
|
||||||
|
|
||||||
if(three_body_h_tc) then
|
if(three_body_h_tc) then
|
||||||
|
!call wall_time(tt0)
|
||||||
|
!PROVIDE fock_a_tot_3e_bi_orth
|
||||||
!Fock_matrix_tc_mo_alpha += fock_a_tot_3e_bi_orth
|
!Fock_matrix_tc_mo_alpha += fock_a_tot_3e_bi_orth
|
||||||
|
PROVIDE fock_3e_uhf_mo_a
|
||||||
Fock_matrix_tc_mo_alpha += fock_3e_uhf_mo_a
|
Fock_matrix_tc_mo_alpha += fock_3e_uhf_mo_a
|
||||||
|
!call wall_time(tt1)
|
||||||
|
!print*, ' 3-e term:', tt1-tt0
|
||||||
endif
|
endif
|
||||||
|
|
||||||
else
|
else
|
||||||
|
|
||||||
call ao_to_mo( Fock_matrix_tc_ao_alpha, size(Fock_matrix_tc_ao_alpha, 1) &
|
call ao_to_mo( Fock_matrix_tc_ao_alpha, size(Fock_matrix_tc_ao_alpha, 1) &
|
||||||
, Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1) )
|
, Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1) )
|
||||||
|
|
||||||
endif
|
endif
|
||||||
|
|
||||||
|
!call wall_time(t1)
|
||||||
|
!print*, ' Wall time for Fock_matrix_tc_mo_alpha =', t1-t0
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
! ---
|
! ---
|
||||||
@ -220,7 +252,9 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_beta, (mo_num,mo_num) ]
|
|||||||
call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_beta, size(Fock_matrix_tc_ao_beta, 1) &
|
call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_beta, size(Fock_matrix_tc_ao_beta, 1) &
|
||||||
, Fock_matrix_tc_mo_beta, size(Fock_matrix_tc_mo_beta, 1) )
|
, Fock_matrix_tc_mo_beta, size(Fock_matrix_tc_mo_beta, 1) )
|
||||||
if(three_body_h_tc) then
|
if(three_body_h_tc) then
|
||||||
|
!PROVIDE fock_b_tot_3e_bi_orth
|
||||||
!Fock_matrix_tc_mo_beta += fock_b_tot_3e_bi_orth
|
!Fock_matrix_tc_mo_beta += fock_b_tot_3e_bi_orth
|
||||||
|
PROVIDE fock_3e_uhf_mo_b
|
||||||
Fock_matrix_tc_mo_beta += fock_3e_uhf_mo_b
|
Fock_matrix_tc_mo_beta += fock_3e_uhf_mo_b
|
||||||
endif
|
endif
|
||||||
|
|
||||||
@ -275,10 +309,20 @@ END_PROVIDER
|
|||||||
BEGIN_PROVIDER [ double precision, Fock_matrix_tc_ao_tot, (ao_num, ao_num) ]
|
BEGIN_PROVIDER [ double precision, Fock_matrix_tc_ao_tot, (ao_num, ao_num) ]
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
|
double precision :: t0, t1
|
||||||
|
|
||||||
|
!print*, ' Providing Fock_matrix_tc_ao_tot ...'
|
||||||
|
!call wall_time(t0)
|
||||||
|
|
||||||
|
PROVIDE mo_l_coef mo_r_coef
|
||||||
|
PROVIDE Fock_matrix_tc_mo_tot
|
||||||
|
|
||||||
call mo_to_ao_bi_ortho( Fock_matrix_tc_mo_tot, size(Fock_matrix_tc_mo_tot, 1) &
|
call mo_to_ao_bi_ortho( Fock_matrix_tc_mo_tot, size(Fock_matrix_tc_mo_tot, 1) &
|
||||||
, Fock_matrix_tc_ao_tot, size(Fock_matrix_tc_ao_tot, 1) )
|
, Fock_matrix_tc_ao_tot, size(Fock_matrix_tc_ao_tot, 1) )
|
||||||
|
|
||||||
|
!call wall_time(t1)
|
||||||
|
!print*, ' Wall time for Fock_matrix_tc_ao_tot =', t1-t0
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user