LCPQ/qmcchem
10
1
Fork 1
mirror of https://gitlab.com/scemama/qmcchem.git synced 2024-06-01 10:55:18 +02:00
Code Releases Activity
4c69f202e5
qmcchem/src/PROPERTIES/properties_ci_postSVD.irp.f
Abdallah Ammar 1b9215d45c build_psi_SVD
2021-05-26 09:39:57 +02:00

259 lines
7.5 KiB
Fortran
Raw Blame History

BEGIN_PROVIDER [ double precision, ci_overlap_psidet_postSVD, (size_ci_overlap_psidet_postSVD) ]
implicit none
BEGIN_DOC
! !!!
! < psi_0 | det(j) >
! Dimensions : n_svd_coefs2
END_DOC
integer :: k, kp
do k = 1, n_svd_coefs
do kp = 1, n_svd_coefs
ci_overlap_psidet_postSVD(kp+(k-1)*n_svd_coefs) = det_alpha_value_SVD(k) * det_beta_value_SVD(kp) * psidet_inv_SVD
enddo
enddo
ci_overlap_psidet_postSVD_min = min(ci_overlap_psidet_postSVD_min,minval(ci_overlap_psidet_postSVD))
ci_overlap_psidet_postSVD_max = max(ci_overlap_psidet_postSVD_max,maxval(ci_overlap_psidet_postSVD))
SOFT_TOUCH ci_overlap_psidet_postSVD_min ci_overlap_psidet_postSVD_max
END_PROVIDER
BEGIN_PROVIDER [ double precision, ci_h_psidet_postSVD, (size_ci_h_psidet_postSVD) ]
implicit none
BEGIN_DOC
! !!!
! < psi_0 |H| det(j) >
! Dimensions : n_svd_coefs2
END_DOC
integer :: k, kp, e
double precision :: T
do k = 1, n_svd_coefs
do kp = 1, n_svd_coefs
T = 0.d0
do e = 1, elec_alpha_num
T += det_alpha_grad_lapl_SVD(4,e,k) * det_beta_value_SVD(kp)
enddo
do e = elec_beta_num+1, elec_num
T += det_alpha_value_SVD(k) * det_beta_grad_lapl_SVD(4,e,kp)
enddo
ci_h_psidet_postSVD(kp+(k-1)*n_svd_coefs) = -0.5d0*T + E_pot * det_alpha_value_SVD(k) * det_beta_value_SVD(kp)
ci_h_psidet_postSVD(kp+(k-1)*n_svd_coefs) *= psidet_inv_SVD
enddo
enddo
ci_h_psidet_postSVD_min = min(ci_h_psidet_postSVD_min,minval(ci_h_psidet_postSVD))
ci_h_psidet_postSVD_max = max(ci_h_psidet_postSVD_max,maxval(ci_h_psidet_postSVD))
SOFT_TOUCH ci_h_psidet_postSVD_min ci_h_psidet_postSVD_max
END_PROVIDER
BEGIN_PROVIDER [ double precision, ci_overlap_matrix_postSVD, (size_ci_overlap_matrix_postSVD) ]
implicit none
BEGIN_DOC
! !!!
! < det(i) | det(j) >
! Dimensions : n_svd_coefs2 * n_svd_coefs2
END_DOC
integer :: k, kp, l, lp
integer :: ii0, ii1, ii2, ii
double precision :: f
do k = 1, n_svd_coefs
ii0 = (k-1)*n_svd_coefs3
do kp = 1, n_svd_coefs
ii1 = ii0 + (kp-1)*n_svd_coefs2
f = det_alpha_value_SVD(k) * det_beta_value_SVD(kp) * psidet_inv_SVD * psidet_inv_SVD
do l = 1, n_svd_coefs
ii2 = ii1 + (l-1)*n_svd_coefs
do lp = 1, n_svd_coefs
ii = ii2 + lp
ci_overlap_matrix_postSVD(ii) = det_alpha_value_SVD(l) * det_beta_value_SVD(lp) * f
enddo
enddo
enddo
enddo
ci_overlap_matrix_postSVD_min = min(ci_overlap_matrix_postSVD_min,minval(ci_overlap_matrix_postSVD))
ci_overlap_matrix_postSVD_max = max(ci_overlap_matrix_postSVD_max,maxval(ci_overlap_matrix_postSVD))
SOFT_TOUCH ci_overlap_matrix_postSVD_min ci_overlap_matrix_postSVD_max
END_PROVIDER
BEGIN_PROVIDER [ double precision, ci_h_matrix_postSVD, (size_ci_h_matrix_postSVD) ]
implicit none
BEGIN_DOC
! !!!
! < det(i) | H | det(j) >
! Dimensions : n_svd_coefs2 * n_svd_coefs2
END_DOC
integer :: k, kp, l, lp, e
integer :: ii0, ii1, ii2, ii
double precision :: f, g, h, T, V
do l = 1, n_svd_coefs
ii0 = (l-1)*n_svd_coefs3
do lp = 1, n_svd_coefs
ii1 = ii0 + (lp-1)*n_svd_coefs2
! Lapl D
g = 0.d0
do e = 1, elec_alpha_num
g += det_alpha_grad_lapl_SVD(4,e,l) * det_beta_value_SVD(lp)
enddo
do e = elec_alpha_num+1, elec_num
g += det_alpha_value_SVD(l) * det_beta_grad_lapl_SVD(4,e,lp)
enddo
T = g
! D (Lapl J)/J
g = 0.d0
do e = 1, elec_num
g += jast_lapl_jast_inv(e)
enddo
T += det_alpha_value_SVD(l) * det_beta_value_SVD(lp) * g
! 2 (grad D).(Grad J)/J
g = 0.d0
do e = 1, elec_alpha_num
g += &
det_alpha_grad_lapl_SVD(1,e,l) * jast_grad_jast_inv_x(e) + &
det_alpha_grad_lapl_SVD(2,e,l) * jast_grad_jast_inv_y(e) + &
det_alpha_grad_lapl_SVD(3,e,l) * jast_grad_jast_inv_z(e)
enddo
h = 0.d0
do e = elec_alpha_num+1, elec_num
h += &
det_beta_grad_lapl_SVD(1,e,lp) * jast_grad_jast_inv_x(e) + &
det_beta_grad_lapl_SVD(2,e,lp) * jast_grad_jast_inv_y(e) + &
det_beta_grad_lapl_SVD(3,e,lp) * jast_grad_jast_inv_z(e)
enddo
T += 2.d0 * ( g * det_beta_value_SVD(lp) + h * det_alpha_value_SVD(l) )
g = det_alpha_value_SVD(l) * det_beta_value_SVD(lp)
V = E_pot * g
do e = 1, elec_alpha_num
V -= pseudo_non_local_SVD(e) * g
V += det_alpha_pseudo_SVD(e,l) * det_beta_value_SVD(lp)
enddo
do e = elec_alpha_num+1, elec_num
V -= pseudo_non_local_SVD(e) * g
V += det_alpha_value_SVD(l) * det_beta_pseudo_SVD(e,lp)
enddo
f = -0.5d0*T + V
f *= psidet_inv_SVD * psidet_inv_SVD
do k = 1, n_svd_coefs
ii2 = ii1 + (k-1)*n_svd_coefs
do kp = 1, n_svd_coefs
ii = ii2 + kp
ci_h_matrix_postSVD(ii) = f * det_alpha_value_SVD(k) * det_beta_value_SVD(kp)
enddo
enddo
enddo
enddo
ci_h_matrix_postSVD_min = min(ci_h_matrix_postSVD_min,minval(ci_h_matrix_postSVD))
ci_h_matrix_postSVD_max = max(ci_h_matrix_postSVD_max,maxval(ci_h_matrix_postSVD))
SOFT_TOUCH ci_h_matrix_postSVD_min ci_h_matrix_postSVD_max
END_PROVIDER
BEGIN_PROVIDER [ double precision, ci_h_matrix_diag_postSVD, (size_ci_h_matrix_diag_postSVD) ]
implicit none
BEGIN_DOC
! < det(i) |H| det(j) >
!
! Dimensions : n_svd_coefs2
END_DOC
integer :: l, lp, e
integer :: ii0, ii
double precision :: f, g, h, T, V
do l = 1, n_svd_coefs
ii0 = (l-1)*n_svd_coefs
do lp = 1, n_svd_coefs
ii = ii0 + lp
! Lapl D
g = 0.d0
do e = 1, elec_alpha_num
g += det_alpha_grad_lapl_SVD(4,e,l) * det_beta_value_SVD(lp)
enddo
do e = elec_alpha_num+1, elec_num
g += det_alpha_value_SVD(l) * det_beta_grad_lapl_SVD(4,e,lp)
enddo
T = g
! D (Lapl J)/J
g = 0.d0
do e = 1, elec_num
g += jast_lapl_jast_inv(e)
enddo
T += det_alpha_value_SVD(l) * det_beta_value_SVD(lp) * g
! 2 (grad D).(Grad J)/J
g = 0.d0
do e = 1, elec_alpha_num
g += &
det_alpha_grad_lapl_SVD(1,e,l) * jast_grad_jast_inv_x(e) + &
det_alpha_grad_lapl_SVD(2,e,l) * jast_grad_jast_inv_y(e) + &
det_alpha_grad_lapl_SVD(3,e,l) * jast_grad_jast_inv_z(e)
enddo
h = 0.d0
do e = elec_alpha_num+1, elec_num
h += &
det_beta_grad_lapl_SVD(1,e,lp) * jast_grad_jast_inv_x(e) + &
det_beta_grad_lapl_SVD(2,e,lp) * jast_grad_jast_inv_y(e) + &
det_beta_grad_lapl_SVD(3,e,lp) * jast_grad_jast_inv_z(e)
enddo
T += 2.d0 * ( g * det_beta_value_SVD(lp) + h * det_alpha_value_SVD(l) )
g = det_alpha_value_SVD(l) * det_beta_value_SVD(lp)
V = E_pot * g
do e = 1, elec_alpha_num
V -= pseudo_non_local_SVD(e) * g
V += det_alpha_pseudo_SVD(e,l) * det_beta_value_SVD(lp)
enddo
do e = elec_alpha_num+1, elec_num
V -= pseudo_non_local_SVD(e) * g
V += det_alpha_value_SVD(l) * det_beta_pseudo_SVD(e,lp)
enddo
f = -0.5d0*T + V
f *= psidet_inv_SVD * psidet_inv_SVD
ci_h_matrix_diag_postSVD(ii) = f * det_alpha_value_SVD(l) * det_beta_value_SVD(lp)
enddo
enddo
ci_h_matrix_diag_postSVD_min = min(ci_h_matrix_diag_postSVD_min,minval(ci_h_matrix_diag_postSVD))
ci_h_matrix_diag_postSVD_max = max(ci_h_matrix_diag_postSVD_max,maxval(ci_h_matrix_diag_postSVD))
SOFT_TOUCH ci_h_matrix_diag_postSVD_min ci_h_matrix_diag_postSVD_max
END_PROVIDER
View Git Blame Copy Permalink