From de3a7412e331e48b793d9c2df9f1ccfad986d28d Mon Sep 17 00:00:00 2001 From: Dorothea Golze Date: Mon, 30 May 2016 10:50:45 +0000 Subject: [PATCH] SHG integrals: performance improvement, new operators svn-origin-rev: 16962 --- src/aobasis/ai_construct_shg.F | 1017 +++++++++++++ src/aobasis/ai_contraction_sphi.F | 215 +++ src/aobasis/ai_derivatives.F | 122 +- src/aobasis/ai_operators_r12.F | 620 ++++++++ src/aobasis/ai_operators_r12.h | 17 + src/aobasis/ai_s_contract_shg.F | 1015 +++++++++++++ src/aobasis/ai_shg_overlap.F | 1336 ----------------- src/aobasis/basis_set_types.F | 2 +- src/aobasis/orbital_pointers.F | 15 +- ...debug_integrals.F => debug_os_integrals.F} | 14 +- ..._os_integrals.F => generic_os_integrals.F} | 464 +++--- src/generic_shg_integrals.F | 849 +++++++++++ src/input_constants.F | 6 + src/input_cp2k_subsys.F | 3 +- src/library_tests.F | 10 +- src/lri_environment_init.F | 3 +- src/lri_environment_methods.F | 86 +- src/lri_environment_types.F | 32 +- src/lri_shg_integrals.F | 732 --------- src/shg_integrals_test.F | 423 ++++++ src/start/input_cp2k.F | 5 + tests/LIBTEST/TEST_FILES | 1 + tests/LIBTEST/test_shg_integrals_01.inp | 70 + 23 files changed, 4680 insertions(+), 2377 deletions(-) create mode 100644 src/aobasis/ai_construct_shg.F create mode 100644 src/aobasis/ai_contraction_sphi.F create mode 100644 src/aobasis/ai_operators_r12.F create mode 100644 src/aobasis/ai_operators_r12.h create mode 100644 src/aobasis/ai_s_contract_shg.F delete mode 100644 src/aobasis/ai_shg_overlap.F rename src/{lri_debug_integrals.F => debug_os_integrals.F} (97%) rename src/{lri_os_integrals.F => generic_os_integrals.F} (72%) create mode 100644 src/generic_shg_integrals.F delete mode 100644 src/lri_shg_integrals.F create mode 100644 src/shg_integrals_test.F create mode 100644 tests/LIBTEST/test_shg_integrals_01.inp diff --git a/src/aobasis/ai_construct_shg.F b/src/aobasis/ai_construct_shg.F new file mode 100644 index 0000000000..3ec188bf13 --- /dev/null +++ b/src/aobasis/ai_construct_shg.F @@ -0,0 +1,1017 @@ +!--------------------------------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright (C) 2000 - 2016 CP2K developers group ! +!--------------------------------------------------------------------------------------------------! + +! ************************************************************************************************** +!> \brief Calculation of the integrals over solid harmonic Gaussian(SHG) functions. +!> Routines for (a|O(r12)|b) and overlap integrals (ab), (aba) and (abb). +!> \par Literature (partly) +!> T.J. Giese and D. M. York, J. Chem. Phys, 128, 064104 (2008) +!> T. Helgaker, P Joergensen, J. Olsen, Molecular Electronic-Structure +!> Theory, Wiley +!> \par History +!> created [04.2015] +!> \author Dorothea Golze +! ************************************************************************************************** +MODULE ai_construct_shg + USE kinds, ONLY: dp + USE mathconstants, ONLY: dfac,& + fac + USE orbital_pointers, ONLY: indso,& + indso_inv,& + nsoset +#include "../base/base_uses.f90" + + IMPLICIT NONE + + PRIVATE + + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'ai_construct_shg' + +! *** Public subroutines *** + PUBLIC :: get_real_scaled_solid_harmonic, get_W_matrix, get_dW_matrix, & + construct_int_shg_ab, construct_dev_shg_ab, construct_overlap_shg_aba, & + dev_overlap_shg_aba, construct_overlap_shg_abb, dev_overlap_shg_abb + +CONTAINS + +! ************************************************************************************************** +!> \brief computes the real scaled solid harmonics Rlm up to a given l +!> \param Rlm_c cosine part of real scaled soldi harmonics +!> \param Rlm_s sine part of real scaled soldi harmonics +!> \param l maximal l quantum up to where Rlm is calculated +!> \param r distance vector between a and b +!> \param r2 square of distance vector +! ************************************************************************************************** + SUBROUTINE get_real_scaled_solid_harmonic(Rlm_c, Rlm_s, l, r, r2) + + INTEGER, INTENT(IN) :: l + REAL(KIND=dp), DIMENSION(0:l, -2*l:2*l), & + INTENT(OUT) :: Rlm_s, Rlm_c + REAL(KIND=dp), DIMENSION(3) :: r + REAL(KIND=dp) :: r2 + + CHARACTER(len=*), PARAMETER :: routineN = 'get_real_scaled_solid_harmonic', & + routineP = moduleN//':'//routineN + + INTEGER :: handle, li, mi, prefac + REAL(KIND=dp) :: Rc, Rc_00, Rlm, Rmlm, Rplm, Rs, Rs_00, & + temp_c + + CALL timeset(routineN, handle) + + Rc_00 = 1.0_dp + Rs_00 = 0.0_dp + + Rlm_c(0, 0) = Rc_00 + Rlm_s(0, 0) = Rs_00 + + ! generate elements Rmm + ! start + IF (l > 0) THEN + Rc = -0.5_dp*r(1)*Rc_00 + Rs = -0.5_dp*r(2)*Rc_00 + Rlm_c(1, 1) = Rc + Rlm_s(1, 1) = Rs + Rlm_c(1, -1) = -Rc + Rlm_s(1, -1) = Rs + ENDIF + DO li = 2, l + temp_c = (-r(1)*Rc+r(2)*Rs)/(REAL(2*(li-1)+2, dp)) + Rs = (-r(2)*Rc-r(1)*Rs)/(REAL(2*(li-1)+2, dp)) + Rc = temp_c + Rlm_c(li, li) = Rc + Rlm_s(li, li) = Rs + IF (MODULO(li, 2) /= 0) THEN + Rlm_c(li, -li) = -Rc + Rlm_s(li, -li) = Rs + ELSE + Rlm_c(li, -li) = Rc + Rlm_s(li, -li) = -Rs + ENDIF + ENDDO + + DO mi = 0, l-1 + Rmlm = Rlm_c(mi, mi) + Rlm = r(3)*Rlm_c(mi, mi) + Rlm_c(mi+1, mi) = Rlm + IF (MODULO(mi, 2) /= 0) THEN + Rlm_c(mi+1, -mi) = -Rlm + ELSE + Rlm_c(mi+1, -mi) = Rlm + ENDIF + DO li = mi+2, l + prefac = (li+mi)*(li-mi) + Rplm = (REAL(2*li-1, dp)*r(3)*Rlm-r2*Rmlm)/REAL(prefac, dp) + Rmlm = Rlm + Rlm = Rplm + Rlm_c(li, mi) = Rlm + IF (MODULO(mi, 2) /= 0) THEN + Rlm_c(li, -mi) = -Rlm + ELSE + Rlm_c(li, -mi) = Rlm + ENDIF + ENDDO + ENDDO + DO mi = 1, l-1 + Rmlm = Rlm_s(mi, mi) + Rlm = r(3)*Rlm_s(mi, mi) + Rlm_s(mi+1, mi) = Rlm + IF (MODULO(mi, 2) /= 0) THEN + Rlm_s(mi+1, -mi) = Rlm + ELSE + Rlm_s(mi+1, -mi) = -Rlm + ENDIF + DO li = mi+2, l + prefac = (li+mi)*(li-mi) + Rplm = (REAL(2*li-1, dp)*r(3)*Rlm-r2*Rmlm)/REAL(prefac, dp) + Rmlm = Rlm + Rlm = Rplm + Rlm_s(li, mi) = Rlm + IF (MODULO(mi, 2) /= 0) THEN + Rlm_s(li, -mi) = Rlm + ELSE + Rlm_s(li, -mi) = -Rlm + ENDIF + ENDDO + ENDDO + + CALL timestop(handle) + + END SUBROUTINE get_real_scaled_solid_harmonic + +! ************************************************************************************************** +!> \brief Calculate the prefactor A(l,m) = (-1)^m \sqrt[(2-delta(m,0))(l+m)!(l-m)!] +!> \param lmax maximal l quantum number +!> \param A matrix storing the prefactor for a given l and m +! ************************************************************************************************** + SUBROUTINE get_Alm(lmax, A) + + INTEGER, INTENT(IN) :: lmax + REAL(KIND=dp), DIMENSION(0:lmax, 0:lmax), & + INTENT(INOUT) :: A + + CHARACTER(len=*), PARAMETER :: routineN = 'get_Alm', routineP = moduleN//':'//routineN + + INTEGER :: l, m + REAL(KIND=dp) :: temp + + DO l = 0, lmax + DO m = 0, l + temp = SQRT(fac(l+m)*fac(l-m)) + IF (MODULO(m, 2) /= 0) temp = -temp + IF (m /= 0) temp = temp*SQRT(2.0_dp) + A(l, m) = temp + ENDDO + ENDDO + + END SUBROUTINE get_Alm + +! ************************************************************************************************** +!> \brief calculates the prefactors for the derivatives of the W matrix +!> \param lmax maximal l quantum number +!> \param dA_p = A(l,m)/A(l-1,m+1) +!> \param dA_m = A(l,m)/A(l-1,m-1) +!> \param dA = A(l,m)/A(l-1,m) +!> \note for m=0, W_l-1,-1 can't be read from Waux_mat, but we use +!> W_l-1,-1 = -W_l-1,1 [cc(1), cs(2)] or W_l-1,-1 = W_l-1,1 [[sc(3), ss(4)], i.e. +!> effectively we multiply dA_p by 2 +! ************************************************************************************************** + SUBROUTINE get_dA_prefactors(lmax, dA_p, dA_m, dA) + + INTEGER, INTENT(IN) :: lmax + REAL(KIND=dp), DIMENSION(0:lmax, 0:lmax), & + INTENT(INOUT) :: dA_p, dA_m, dA + + CHARACTER(len=*), PARAMETER :: routineN = 'get_dA_prefactors', & + routineP = moduleN//':'//routineN + + INTEGER :: l, m + REAL(KIND=dp) :: bm, bm_m, bm_p + + DO l = 0, lmax + DO m = 0, l + bm = 1.0_dp + bm_m = 1.0_dp + bm_p = 1.0_dp + IF (m /= 0) bm = SQRT(2.0_dp) + IF (m-1 /= 0) bm_m = SQRT(2.0_dp) + IF (m+1 /= 0) bm_p = SQRT(2.0_dp) + dA_p(l, m) = -bm/bm_p*SQRT(REAL((l-m)*(l-m-1), dp)) + dA_m(l, m) = -bm/bm_m*SQRT(REAL((l+m)*(l+m-1), dp)) + dA(l, m) = 2.0_dp*SQRT(REAL((l+m)*(l-m), dp)) + IF (m == 0) dA_p(l, m) = 2.0_dp*dA_p(l, m) + ENDDO + ENDDO + END SUBROUTINE get_dA_prefactors + +! ************************************************************************************************** +!> \brief calculates the angular dependent-part of the SHG integrals, +!> transformation matrix W, see literature above +!> \param lamax array of maximal l quantum number on a; +!> lamax(lb) with lb= 0..lbmax +!> \param lbmax maximal l quantum number on b +!> \param lmax maximal l quantum number +!> \param Rc cosine part of real scaled solid harmonics +!> \param Rs sine part of real scaled solid harmonics +!> \param Waux_mat stores the angular-dependent part of the SHG integrals +! ************************************************************************************************** + SUBROUTINE get_W_matrix(lamax, lbmax, lmax, Rc, Rs, Waux_mat) + + INTEGER, DIMENSION(:), POINTER :: lamax + INTEGER, INTENT(IN) :: lbmax, lmax + REAL(KIND=dp), DIMENSION(0:lmax, -2*lmax:2*lmax), & + INTENT(IN) :: Rc, Rs + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: Waux_mat + + CHARACTER(len=*), PARAMETER :: routineN = 'get_W_matrix', routineP = moduleN//':'//routineN + + INTEGER :: handle, j, k, la, labmin, laj, lb, lbj, & + ma, ma_m, ma_p, mb, mb_m, mb_p, nla, & + nlb + REAL(KIND=dp) :: A_jk, A_lama, A_lbmb, Alm_fac, delta_k, prefac, Rca_m, Rca_p, Rcb_m, Rcb_p, & + Rsa_m, Rsa_p, Rsb_m, Rsb_p, sign_fac, Wa(4), Wb(4), Wmat(4) + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: A + + CALL timeset(routineN, handle) + + Wa(:) = 0.0_dp + Wb(:) = 0.0_dp + Wmat(:) = 0.0_dp + + ALLOCATE (A(0:lmax, 0:lmax)) + CALL get_Alm(lmax, A) + + DO lb = 0, lbmax + nlb = nsoset(lb-1) + DO la = 0, lamax(lb) + nla = nsoset(la-1) + labmin = MIN(la, lb) + DO mb = 0, lb + A_lbmb = A(lb, mb) + IF (MODULO(lb, 2) /= 0) A_lbmb = -A_lbmb + DO ma = 0, la + A_lama = A(la, ma) + Alm_fac = A_lama*A_lbmb + DO j = 0, labmin + laj = la-j + lbj = lb-j + prefac = Alm_fac*REAL(2**(la+lb-j), dp)*dfac(2*j-1) + delta_k = 0.5_dp + Wmat = 0.0_dp + DO k = 0, j + ma_m = ma-k + ma_p = ma+k + IF (laj < ABS(ma_m) .AND. laj < ABS(ma_p)) CYCLE + mb_m = mb-k + mb_p = mb+k + IF (lbj < ABS(mb_m) .AND. lbj < ABS(mb_p)) CYCLE + IF (k /= 0) delta_k = 1.0_dp + A_jk = fac(j+k)*fac(j-k) + IF (k /= 0) A_jk = 2.0_dp*A_jk + IF (MODULO(k, 2) /= 0) THEN + sign_fac = -1.0_dp + ELSE + sign_fac = 1.0_dp + ENDIF + Rca_m = Rc(laj, ma_m) + Rsa_m = Rs(laj, ma_m) + Rca_p = Rc(laj, ma_p) + Rsa_p = Rs(laj, ma_p) + Rcb_m = Rc(lbj, mb_m) + Rsb_m = Rs(lbj, mb_m) + Rcb_p = Rc(lbj, mb_p) + Rsb_p = Rs(lbj, mb_p) + Wa(1) = delta_k*(Rca_m+sign_fac*Rca_p) + Wb(1) = delta_k*(Rcb_m+sign_fac*Rcb_p) + Wa(2) = -Rsa_m+sign_fac*Rsa_p + Wb(2) = -Rsb_m+sign_fac*Rsb_p + Wmat(1) = Wmat(1)+prefac/A_jk*(Wa(1)*Wb(1)+Wa(2)*Wb(2)) + IF (mb > 0) THEN + Wb(3) = delta_k*(Rsb_m+sign_fac*Rsb_p) + Wb(4) = Rcb_m-sign_fac*Rcb_p + Wmat(2) = Wmat(2)+prefac/A_jk*(Wa(1)*Wb(3)+Wa(2)*Wb(4)) + ENDIF + IF (ma > 0) THEN + Wa(3) = delta_k*(Rsa_m+sign_fac*Rsa_p) + Wa(4) = Rca_m-sign_fac*Rca_p + Wmat(3) = Wmat(3)+prefac/A_jk*(Wa(3)*Wb(1)+Wa(4)*Wb(2)) + ENDIF + IF (ma > 0 .AND. mb > 0) THEN + Wmat(4) = Wmat(4)+prefac/A_jk*(Wa(3)*Wb(3)+Wa(4)*Wb(4)) + ENDIF + ENDDO + Waux_mat(j+1, nla+la+1+ma, nlb+lb+1+mb) = Wmat(1) + IF (mb > 0) Waux_mat(j+1, nla+la+1+ma, nlb+lb+1-mb) = Wmat(2) + IF (ma > 0) Waux_mat(j+1, nla+la+1-ma, nlb+lb+1+mb) = Wmat(3) + IF (ma > 0 .AND. mb > 0) Waux_mat(j+1, nla+la+1-ma, nlb+lb+1-mb) = Wmat(4) + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + + DEALLOCATE (A) + + CALL timestop(handle) + + END SUBROUTINE get_W_matrix + +! ************************************************************************************************** +!> \brief calculates derivatives of transformation matrix W, +!> \param lamax array of maximal l quantum number on a; +!> lamax(lb) with lb= 0..lbmax +!> \param lbmax maximal l quantum number on b +!> \param Waux_mat stores the angular-dependent part of the SHG integrals +!> \param dWaux_mat stores the derivatives of the angular-dependent part of +!> the SHG integrals +! ************************************************************************************************** + SUBROUTINE get_dW_matrix(lamax, lbmax, Waux_mat, dWaux_mat) + + INTEGER, DIMENSION(:), POINTER :: lamax + INTEGER, INTENT(IN) :: lbmax + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: Waux_mat + REAL(KIND=dp), DIMENSION(:, :, :, :), & + INTENT(INOUT) :: dWaux_mat + + CHARACTER(len=*), PARAMETER :: routineN = 'get_dW_matrix', routineP = moduleN//':'//routineN + + INTEGER :: handle, ima, imam, imb, imbm, ipa, ipam, & + ipb, ipbm, j, jmax, la, labm, labmin, & + lamb, lb, lmax, ma, mb, nla, nlam, & + nlb, nlbm + REAL(KIND=dp) :: dAa, dAa_m, dAa_p, dAb, dAb_m, dAb_p + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: dA, dA_m, dA_p, Wam, Wamm, Wamp, Wbm, & + Wbmm, Wbmp + + CALL timeset(routineN, handle) + + jmax = MIN(MAXVAL(lamax), lbmax) + ALLOCATE (Wam(0:jmax, 4), Wamm(0:jmax, 4), Wamp(0:jmax, 4)) + ALLOCATE (Wbm(0:jmax, 4), Wbmm(0:jmax, 4), Wbmp(0:jmax, 4)) + + !*** get dA_p=A(l,m)/A(l-1,m+1) + !*** get dA_m=A(l,m)/A(l-1,m-1) + !*** get dA=2*A(l,m)/A(l-1,m) + lmax = MAX(MAXVAL(lamax), lbmax) + ALLOCATE (dA_p(0:lmax, 0:lmax), dA_m(0:lmax, 0:lmax), dA(0:lmax, 0:lmax)) + CALL get_dA_prefactors(lmax, dA_p, dA_m, dA) + + DO lb = 0, lbmax + nlb = nsoset(lb-1) + nlbm = 0 + IF (lb > 0) nlbm = nsoset(lb-2) + DO la = 0, lamax(lb) + nla = nsoset(la-1) + nlam = 0 + IF (la > 0) nlam = nsoset(la-2) + labmin = MIN(la, lb) + lamb = MIN(la-1, lb) + labm = MIN(la, lb-1) + DO mb = 0, lb + dAb = dA(lb, mb) + dAb_p = dA_p(lb, mb) + dAb_m = dA_m(lb, mb) + ipb = nlb+lb+mb+1 + imb = nlb+lb-mb+1 + ipbm = nlbm+lb+mb + imbm = nlbm+lb-mb + DO ma = 0, la + dAa = dA(la, ma) + dAa_p = dA_p(la, ma) + dAa_m = dA_m(la, ma) + ipa = nla+la+ma+1 + ima = nla+la-ma+1 + ipam = nlam+la+ma + imam = nlam+la-ma + Wam(:, :) = 0.0_dp + Wamm(:, :) = 0.0_dp + Wamp(:, :) = 0.0_dp + !*** Wam: la-1, ma + IF (ma <= la-1) THEN + Wam(0:lamb, 1) = Waux_mat(1:lamb+1, ipam, ipb) + IF (mb > 0) Wam(0:lamb, 2) = Waux_mat(1:lamb+1, ipam, imb) + IF (ma > 0) Wam(0:lamb, 3) = Waux_mat(1:lamb+1, imam, ipb) + IF (ma > 0 .AND. mb > 0) Wam(0:lamb, 4) = Waux_mat(1:lamb+1, imam, imb) + ENDIF + !*** Wamm: la-1, ma-1 + IF (ma-1 >= 0) THEN + Wamm(0:lamb, 1) = Waux_mat(1:lamb+1, ipam-1, ipb) + IF (mb > 0) Wamm(0:lamb, 2) = Waux_mat(1:lamb+1, ipam-1, imb) + IF (ma-1 > 0) Wamm(0:lamb, 3) = Waux_mat(1:lamb+1, imam+1, ipb) !order: e.g. -1 0 1, if < 0 |m|, -1 means -m+1 + IF (ma-1 > 0 .AND. mb > 0) Wamm(0:lamb, 4) = Waux_mat(1:lamb+1, imam+1, imb) + ENDIF + !*** Wamp: la-1, ma+1 + IF (ma+1 <= la-1) THEN + Wamp(0:lamb, 1) = Waux_mat(1:lamb+1, ipam+1, ipb) + IF (mb > 0) Wamp(0:lamb, 2) = Waux_mat(1:lamb+1, ipam+1, imb) + IF (ma+1 > 0) Wamp(0:lamb, 3) = Waux_mat(1:lamb+1, imam-1, ipb) + IF (ma+1 > 0 .AND. mb > 0) Wamp(0:lamb, 4) = Waux_mat(1:lamb+1, imam-1, imb) + ENDIF + Wbm(:, :) = 0.0_dp + Wbmm(:, :) = 0.0_dp + Wbmp(:, :) = 0.0_dp + !*** Wbm: lb-1, mb + IF (mb <= lb-1) THEN + Wbm(0:labm, 1) = Waux_mat(1:labm+1, ipa, ipbm) + IF (mb > 0) Wbm(0:labm, 2) = Waux_mat(1:labm+1, ipa, imbm) + IF (ma > 0) Wbm(0:labm, 3) = Waux_mat(1:labm+1, ima, ipbm) + IF (ma > 0 .AND. mb > 0) Wbm(0:labm, 4) = Waux_mat(1:labm+1, ima, imbm) + ENDIF + !*** Wbmm: lb-1, mb-1 + IF (mb-1 >= 0) THEN + Wbmm(0:labm, 1) = Waux_mat(1:labm+1, ipa, ipbm-1) + IF (mb-1 > 0) Wbmm(0:labm, 2) = Waux_mat(1:labm+1, ipa, imbm+1) + IF (ma > 0) Wbmm(0:labm, 3) = Waux_mat(1:labm+1, ima, ipbm-1) + IF (ma > 0 .AND. mb-1 > 0) Wbmm(0:labm, 4) = Waux_mat(1:labm+1, ima, imbm+1) + ENDIF + !*** Wbmp: lb-1, mb+1 + IF (mb+1 <= lb-1) THEN + Wbmp(0:labm, 1) = Waux_mat(1:labm+1, ipa, ipbm+1) + IF (mb+1 > 0) Wbmp(0:labm, 2) = Waux_mat(1:labm+1, ipa, imbm-1) + IF (ma > 0) Wbmp(0:labm, 3) = Waux_mat(1:labm+1, ima, ipbm+1) + IF (ma > 0 .AND. mb+1 > 0) Wbmp(0:labm, 4) = Waux_mat(1:labm+1, ima, imbm-1) + ENDIF + DO j = 0, labmin + !*** x component + dWaux_mat(1, j+1, ipa, ipb) = dAa_p*Wamp(j, 1)-dAa_m*Wamm(j, 1) & + -dAb_p*Wbmp(j, 1)+dAb_m*Wbmm(j, 1) + IF (mb > 0) THEN + dWaux_mat(1, j+1, ipa, imb) = dAa_p*Wamp(j, 2)-dAa_m*Wamm(j, 2) & + -dAb_p*Wbmp(j, 2)+dAb_m*Wbmm(j, 2) + ENDIF + IF (ma > 0) THEN + dWaux_mat(1, j+1, ima, ipb) = dAa_p*Wamp(j, 3)-dAa_m*Wamm(j, 3) & + -dAb_p*Wbmp(j, 3)+dAb_m*Wbmm(j, 3) + ENDIF + IF (ma > 0 .AND. mb > 0) THEN + dWaux_mat(1, j+1, ima, imb) = dAa_p*Wamp(j, 4)-dAa_m*Wamm(j, 4) & + -dAb_p*Wbmp(j, 4)+dAb_m*Wbmm(j, 4) + ENDIF + + !**** y component + dWaux_mat(2, j+1, ipa, ipb) = dAa_p*Wamp(j, 3)+dAa_m*Wamm(j, 3) & + -dAb_p*Wbmp(j, 2)-dAb_m*Wbmm(j, 2) + IF (mb > 0) THEN + dWaux_mat(2, j+1, ipa, imb) = dAa_p*Wamp(j, 4)+dAa_m*Wamm(j, 4) & + +dAb_p*Wbmp(j, 1)+dAb_m*Wbmm(j, 1) + ENDIF + IF (ma > 0) THEN + dWaux_mat(2, j+1, ima, ipb) = -dAa_p*Wamp(j, 1)-dAa_m*Wamm(j, 1) & + -dAb_p*Wbmp(j, 4)-dAb_m*Wbmm(j, 4) + ENDIF + IF (ma > 0 .AND. mb > 0) THEN + dWaux_mat(2, j+1, ima, imb) = -dAa_p*Wamp(j, 2)-dAa_m*Wamm(j, 2) & + +dAb_p*Wbmp(j, 3)+dAb_m*Wbmm(j, 3) + ENDIF + !**** z compnent + dWaux_mat(3, j+1, ipa, ipb) = dAa*Wam(j, 1)-dAb*Wbm(j, 1) + IF (mb > 0) THEN + dWaux_mat(3, j+1, ipa, imb) = dAa*Wam(j, 2)-dAb*Wbm(j, 2) + ENDIF + IF (ma > 0) THEN + dWaux_mat(3, j+1, ima, ipb) = dAa*Wam(j, 3)-dAb*Wbm(j, 3) + ENDIF + IF (ma > 0 .AND. mb > 0) THEN + dWaux_mat(3, j+1, ima, imb) = dAa*Wam(j, 4)-dAb*Wbm(j, 4) + ENDIF + + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + + DEALLOCATE (Wam, Wamm, Wamp) + DEALLOCATE (Wbm, Wbmm, Wbmp) + DEALLOCATE (dA, dA_p, dA_m) + + CALL timestop(handle) + + END SUBROUTINE get_dW_matrix + +! ************************************************************************************************** +!> \brief calculates [ab] SHG overlap integrals using precomputed angular- +!> dependent part +!> \param la set of l quantum number on a +!> \param first_sgfa indexing +!> \param nshella number of shells for a +!> \param lb set of l quantum number on b +!> \param first_sgfb indexing +!> \param nshellb number of shells for b +!> \param swork_cont contracted and normalized [s|s] integrals +!> \param Waux_mat precomputed angular-dependent part +!> \param sab contracted overlap of spherical harmonic Gaussianslm +! ************************************************************************************************** + SUBROUTINE construct_int_shg_ab(la, first_sgfa, nshella, lb, first_sgfb, nshellb, & + swork_cont, Waux_mat, sab) + + INTEGER, DIMENSION(:), INTENT(IN) :: la, first_sgfa + INTEGER, INTENT(IN) :: nshella + INTEGER, DIMENSION(:), INTENT(IN) :: lb, first_sgfb + INTEGER, INTENT(IN) :: nshellb + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: swork_cont, Waux_mat + REAL(KIND=dp), DIMENSION(:, :), INTENT(INOUT) :: sab + + CHARACTER(len=*), PARAMETER :: routineN = 'construct_int_shg_ab', & + routineP = moduleN//':'//routineN + + INTEGER :: fnla, fnlb, fsgfa, fsgfb, handle, & + ishella, j, jshellb, labmin, lai, lbj, & + lnla, lnlb, lsgfa, lsgfb, mai, mbj + REAL(KIND=dp) :: prefac + + CALL timeset(routineN, handle) + + DO jshellb = 1, nshellb + lbj = lb(jshellb) + fnlb = nsoset(lbj-1)+1 + lnlb = nsoset(lbj) + fsgfb = first_sgfb(jshellb) + lsgfb = fsgfb+2*lbj + DO ishella = 1, nshella + lai = la(ishella) + fnla = nsoset(lai-1)+1 + lnla = nsoset(lai) + fsgfa = first_sgfa(ishella) + lsgfa = fsgfa+2*lai + labmin = MIN(lai, lbj) + DO mbj = 0, 2*lbj + DO mai = 0, 2*lai + DO j = 0, labmin + prefac = swork_cont(lai+lbj-j+1, ishella, jshellb) + sab(fsgfa+mai, fsgfb+mbj) = sab(fsgfa+mai, fsgfb+mbj) & + +prefac*Waux_mat(j+1, fnla+mai, fnlb+mbj) + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + + CALL timestop(handle) + + END SUBROUTINE construct_int_shg_ab + +! ************************************************************************************************** +!> \brief calculates derivatives of [ab] SHG overlap integrals using precomputed +!> angular-dependent part +!> \param la set of l quantum number on a +!> \param first_sgfa indexing +!> \param nshella number of shells for a +!> \param lb set of l quantum number on b +!> \param first_sgfb indexing +!> \param nshellb number of shells for b +!> \param rab distance vector Ra-Rb +!> \param swork_cont contracted and normalized [s|s] integrals +!> \param Waux_mat precomputed angular-dependent part +!> \param dWaux_mat ... +!> \param dsab derivative of contracted overlap of spherical harmonic Gaussians +! ************************************************************************************************** + SUBROUTINE construct_dev_shg_ab(la, first_sgfa, nshella, lb, first_sgfb, nshellb, rab, & + swork_cont, Waux_mat, dWaux_mat, dsab) + + INTEGER, DIMENSION(:), INTENT(IN) :: la, first_sgfa + INTEGER, INTENT(IN) :: nshella + INTEGER, DIMENSION(:), INTENT(IN) :: lb, first_sgfb + INTEGER, INTENT(IN) :: nshellb + REAL(KIND=dp), INTENT(IN) :: rab(3) + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: swork_cont, Waux_mat + REAL(KIND=dp), DIMENSION(:, :, :, :), INTENT(IN) :: dWaux_mat + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: dsab + + CHARACTER(len=*), PARAMETER :: routineN = 'construct_dev_shg_ab', & + routineP = moduleN//':'//routineN + + INTEGER :: fnla, fnlb, fsgfa, fsgfb, handle, i, & + ishella, j, jshellb, labmin, lai, lbj, & + lnla, lnlb, lsgfa, lsgfb + REAL(KIND=dp) :: dprefac, prefac, rabx2(3) + + CALL timeset(routineN, handle) + + rabx2(:) = 2.0_dp*rab + DO jshellb = 1, nshellb + lbj = lb(jshellb) + fnlb = nsoset(lbj-1)+1 + lnlb = nsoset(lbj) + fsgfb = first_sgfb(jshellb) + lsgfb = fsgfb+2*lbj + DO ishella = 1, nshella + lai = la(ishella) + fnla = nsoset(lai-1)+1 + lnla = nsoset(lai) + fsgfa = first_sgfa(ishella) + lsgfa = fsgfa+2*lai + labmin = MIN(lai, lbj) + DO j = 0, labmin + prefac = swork_cont(lai+lbj-j+1, ishella, jshellb) + dprefac = swork_cont(lai+lbj-j+2, ishella, jshellb) !j+1 + DO i = 1, 3 + dsab(fsgfa:lsgfa, fsgfb:lsgfb, i) = dsab(fsgfa:lsgfa, fsgfb:lsgfb, i) & + +rabx2(i)*dprefac*Waux_mat(j+1, fnla:lnla, fnlb:lnlb) & + +prefac*dWaux_mat(i, j+1, fnla:lnla, fnlb:lnlb) + ENDDO + ENDDO + ENDDO + ENDDO + + CALL timestop(handle) + + END SUBROUTINE construct_dev_shg_ab + +! ************************************************************************************************** +!> \brief calculates [aba] SHG overlap integrals using precomputed angular- +!> dependent part +!> \param la set of l quantum number on a, orbital basis +!> \param first_sgfa indexing +!> \param nshella number of shells for a, orbital basis +!> \param lb set of l quantum number on b. orbital basis +!> \param first_sgfb indexing +!> \param nshellb number of shells for b, orbital basis +!> \param lca of l quantum number on a, aux basis +!> \param first_sgfca indexing +!> \param nshellca number of shells for a, aux basis +!> \param cg_coeff Clebsch-Gordon coefficients +!> \param cg_none0_list list of none-zero Clebsch-Gordon coefficients +!> \param ncg_none0 number of non-zero Clebsch-Gordon coefficients +!> \param swork_cont contracted and normalized [s|ra^n|s] integrals +!> \param Waux_mat precomputed angular-dependent part +!> \param saba contracted overlap [aba] of spherical harmonic Gaussians +! ************************************************************************************************** + SUBROUTINE construct_overlap_shg_aba(la, first_sgfa, nshella, lb, first_sgfb, nshellb, & + lca, first_sgfca, nshellca, cg_coeff, cg_none0_list, & + ncg_none0, swork_cont, Waux_mat, saba) + + INTEGER, DIMENSION(:), INTENT(IN) :: la, first_sgfa + INTEGER, INTENT(IN) :: nshella + INTEGER, DIMENSION(:), INTENT(IN) :: lb, first_sgfb + INTEGER, INTENT(IN) :: nshellb + INTEGER, DIMENSION(:), INTENT(IN) :: lca, first_sgfca + INTEGER, INTENT(IN) :: nshellca + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: cg_coeff + INTEGER, DIMENSION(:, :, :), INTENT(IN) :: cg_none0_list + INTEGER, DIMENSION(:, :), INTENT(IN) :: ncg_none0 + REAL(KIND=dp), DIMENSION(:, 0:, :, :, :), & + INTENT(IN) :: swork_cont + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: Waux_mat + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: saba + + CHARACTER(len=*), PARAMETER :: routineN = 'construct_overlap_shg_aba', & + routineP = moduleN//':'//routineN + + INTEGER :: handle, ia, il, ilist, ishella, isoa1, isoa2, isoaa, j, jb, jshellb, ka, kshella, & + laa, labmin, lai, lak, lbj, maa, mai, mak, mbj, nla, nlb, sgfa, sgfb, sgfca + REAL(KIND=dp) :: prefac, stemp + + CALL timeset(routineN, handle) + + DO kshella = 1, nshellca + lak = lca(kshella) + sgfca = first_sgfca(kshella) + ka = sgfca+lak + DO jshellb = 1, nshellb + lbj = lb(jshellb) + nlb = nsoset(lbj-1)+lbj+1 + sgfb = first_sgfb(jshellb) + jb = sgfb+lbj + DO ishella = 1, nshella + lai = la(ishella) + sgfa = first_sgfa(ishella) + ia = sgfa+lai + DO mai = -lai, lai, 1 + DO mak = -lak, lak, 1 + isoa1 = indso_inv(lai, mai) + isoa2 = indso_inv(lak, mak) + DO mbj = -lbj, lbj, 1 + DO ilist = 1, ncg_none0(isoa1, isoa2) + isoaa = cg_none0_list(isoa1, isoa2, ilist) + laa = indso(1, isoaa) + maa = indso(2, isoaa) + nla = nsoset(laa-1)+laa+1 + labmin = MIN(laa, lbj) + il = INT((lai+lak-laa)/2) + stemp = 0.0_dp + DO j = 0, labmin + prefac = swork_cont(laa+lbj-j+1, il, ishella, jshellb, kshella) + stemp = stemp+prefac*Waux_mat(j+1, nla+maa, nlb+mbj) + ENDDO + saba(ia+mai, jb+mbj, ka+mak) = saba(ia+mai, jb+mbj, ka+mak)+cg_coeff(isoa1, isoa2, isoaa)*stemp + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + + CALL timestop(handle) + + END SUBROUTINE construct_overlap_shg_aba + +! ************************************************************************************************** +!> \brief calculates derivatives of [aba] SHG overlap integrals using +!> precomputed angular-dependent part +!> \param la set of l quantum number on a, orbital basis +!> \param first_sgfa indexing +!> \param nshella number of shells for a, orbital basis +!> \param lb set of l quantum number on b. orbital basis +!> \param first_sgfb indexing +!> \param nshellb number of shells for b, orbital basis +!> \param lca of l quantum number on a, aux basis +!> \param first_sgfca indexing +!> \param nshellca number of shells for a, aux basis +!> \param cg_coeff Clebsch-Gordon coefficients +!> \param cg_none0_list list of none-zero Clebsch-Gordon coefficients +!> \param ncg_none0 number of non-zero Clebsch-Gordon coefficients +!> \param rab distance vector Ra-Rb +!> \param swork_cont contracted and normalized [s|ra^n|s] integrals +!> \param Waux_mat precomputed angular-dependent part +!> \param dWaux_mat derivatives of precomputed angular-dependent part +!> \param dsaba derivative of contracted overlap [aba] of spherical harmonic +!> Gaussians +! ************************************************************************************************** + SUBROUTINE dev_overlap_shg_aba(la, first_sgfa, nshella, lb, first_sgfb, nshellb, & + lca, first_sgfca, nshellca, cg_coeff, cg_none0_list, & + ncg_none0, rab, swork_cont, Waux_mat, dWaux_mat, dsaba) + + INTEGER, DIMENSION(:), INTENT(IN) :: la, first_sgfa + INTEGER, INTENT(IN) :: nshella + INTEGER, DIMENSION(:), INTENT(IN) :: lb, first_sgfb + INTEGER, INTENT(IN) :: nshellb + INTEGER, DIMENSION(:), INTENT(IN) :: lca, first_sgfca + INTEGER, INTENT(IN) :: nshellca + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: cg_coeff + INTEGER, DIMENSION(:, :, :), INTENT(IN) :: cg_none0_list + INTEGER, DIMENSION(:, :), INTENT(IN) :: ncg_none0 + REAL(KIND=dp), INTENT(IN) :: rab(3) + REAL(KIND=dp), DIMENSION(:, 0:, :, :, :), & + INTENT(IN) :: swork_cont + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: Waux_mat + REAL(KIND=dp), DIMENSION(:, :, :, :), INTENT(IN) :: dWaux_mat + REAL(KIND=dp), DIMENSION(:, :, :, :), & + INTENT(INOUT) :: dsaba + + CHARACTER(len=*), PARAMETER :: routineN = 'dev_overlap_shg_aba', & + routineP = moduleN//':'//routineN + + INTEGER :: handle, i, ia, il, ilist, ishella, isoa1, isoa2, isoaa, j, jb, jshellb, ka, & + kshella, laa, labmin, lai, lak, lbj, maa, mai, mak, mbj, nla, nlb, sgfa, sgfb, sgfca + REAL(KIND=dp) :: dprefac, dtemp(3), prefac, rabx2(3) + + CALL timeset(routineN, handle) + + rabx2(:) = 2.0_dp*rab + + DO kshella = 1, nshellca + lak = lca(kshella) + sgfca = first_sgfca(kshella) + ka = sgfca+lak + DO jshellb = 1, nshellb + lbj = lb(jshellb) + nlb = nsoset(lbj-1)+lbj+1 + sgfb = first_sgfb(jshellb) + jb = sgfb+lbj + DO ishella = 1, nshella + lai = la(ishella) + sgfa = first_sgfa(ishella) + ia = sgfa+lai + DO mai = -lai, lai, 1 + DO mak = -lak, lak, 1 + isoa1 = indso_inv(lai, mai) + isoa2 = indso_inv(lak, mak) + DO mbj = -lbj, lbj, 1 + DO ilist = 1, ncg_none0(isoa1, isoa2) + isoaa = cg_none0_list(isoa1, isoa2, ilist) + laa = indso(1, isoaa) + maa = indso(2, isoaa) + nla = nsoset(laa-1)+laa+1 + labmin = MIN(laa, lbj) + il = (lai+lak-laa)/2 ! lai+lak-laa always even + dtemp = 0.0_dp + DO j = 0, labmin + prefac = swork_cont(laa+lbj-j+1, il, ishella, jshellb, kshella) + dprefac = swork_cont(laa+lbj-j+2, il, ishella, jshellb, kshella) + DO i = 1, 3 + dtemp(i) = dtemp(i)+rabx2(i)*dprefac*Waux_mat(j+1, nla+maa, nlb+mbj) & + +prefac*dWaux_mat(i, j+1, nla+maa, nlb+mbj) + ENDDO + ENDDO + DO i = 1, 3 + dsaba(ia+mai, jb+mbj, ka+mak, i) = dsaba(ia+mai, jb+mbj, ka+mak, i) & + +cg_coeff(isoa1, isoa2, isoaa)*dtemp(i) + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + + CALL timestop(handle) + + END SUBROUTINE dev_overlap_shg_aba + +! ************************************************************************************************** +!> \brief calculates [abb] SHG overlap integrals using precomputed angular- +!> dependent part +!> \param la set of l quantum number on a, orbital basis +!> \param first_sgfa indexing +!> \param nshella number of shells for a, orbital basis +!> \param lb set of l quantum number on b. orbital basis +!> \param first_sgfb indexing +!> \param nshellb number of shells for b, orbital basis +!> \param lcb l quantum number on b, aux basis +!> \param first_sgfcb indexing +!> \param nshellcb number of shells for b, aux basis +!> \param cg_coeff Clebsch-Gordon coefficients +!> \param cg_none0_list list of none-zero Clebsch-Gordon coefficients +!> \param ncg_none0 number of non-zero Clebsch-Gordon coefficients +!> \param swork_cont contracted and normalized [s|rb^n|s] integrals +!> \param Waux_mat precomputed angular-dependent part +!> \param sabb contracted overlap [abb] of spherical harmonic Gaussians +! ************************************************************************************************** + SUBROUTINE construct_overlap_shg_abb(la, first_sgfa, nshella, lb, first_sgfb, nshellb, & + lcb, first_sgfcb, nshellcb, cg_coeff, cg_none0_list, & + ncg_none0, swork_cont, Waux_mat, sabb) + + INTEGER, DIMENSION(:), INTENT(IN) :: la, first_sgfa + INTEGER, INTENT(IN) :: nshella + INTEGER, DIMENSION(:), INTENT(IN) :: lb, first_sgfb + INTEGER, INTENT(IN) :: nshellb + INTEGER, DIMENSION(:), INTENT(IN) :: lcb, first_sgfcb + INTEGER, INTENT(IN) :: nshellcb + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: cg_coeff + INTEGER, DIMENSION(:, :, :), INTENT(IN) :: cg_none0_list + INTEGER, DIMENSION(:, :), INTENT(IN) :: ncg_none0 + REAL(KIND=dp), DIMENSION(:, 0:, :, :, :), & + INTENT(IN) :: swork_cont + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: Waux_mat + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: sabb + + CHARACTER(len=*), PARAMETER :: routineN = 'construct_overlap_shg_abb', & + routineP = moduleN//':'//routineN + + INTEGER :: handle, ia, il, ilist, ishella, isob1, isob2, isobb, j, jb, jshellb, kb, kshellb, & + labmin, lai, lbb, lbj, lbk, mai, mbb, mbj, mbk, nla, nlb, sgfa, sgfb, sgfcb + REAL(KIND=dp) :: prefac, stemp, tsign + + CALL timeset(routineN, handle) + + DO kshellb = 1, nshellcb + lbk = lcb(kshellb) + sgfcb = first_sgfcb(kshellb) + kb = sgfcb+lbk + DO jshellb = 1, nshellb + lbj = lb(jshellb) + sgfb = first_sgfb(jshellb) + jb = sgfb+lbj + DO ishella = 1, nshella + lai = la(ishella) + nla = nsoset(lai-1)+lai+1 + sgfa = first_sgfa(ishella) + ia = sgfa+lai + DO mbj = -lbj, lbj, 1 + DO mbk = -lbk, lbk, 1 + isob1 = indso_inv(lbj, mbj) + isob2 = indso_inv(lbk, mbk) + DO mai = -lai, lai, 1 + DO ilist = 1, ncg_none0(isob1, isob2) + isobb = cg_none0_list(isob1, isob2, ilist) + lbb = indso(1, isobb) + mbb = indso(2, isobb) + nlb = nsoset(lbb-1)+lbb+1 + ! tsgin: because we take the transpose of auxmat (calculated for (la,lb)) + tsign = 1.0_dp + IF (MODULO(lbb-lai, 2) /= 0) tsign = -1.0_dp + labmin = MIN(lai, lbb) + il = INT((lbj+lbk-lbb)/2) + stemp = 0.0_dp + DO j = 0, labmin + prefac = swork_cont(lai+lbb-j+1, il, ishella, jshellb, kshellb) + stemp = stemp+prefac*Waux_mat(j+1, nlb+mbb, nla+mai) + ENDDO + sabb(ia+mai, jb+mbj, kb+mbk) = sabb(ia+mai, jb+mbj, kb+mbk)+tsign*cg_coeff(isob1, isob2, isobb)*stemp + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + + CALL timestop(handle) + + END SUBROUTINE construct_overlap_shg_abb + +! ************************************************************************************************** +!> \brief calculates derivatives of [abb] SHG overlap integrals using +!> precomputed angular-dependent part +!> \param la set of l quantum number on a, orbital basis +!> \param first_sgfa indexing +!> \param nshella number of shells for a, orbital basis +!> \param lb set of l quantum number on b. orbital basis +!> \param first_sgfb indexing +!> \param nshellb number of shells for b, orbital basis +!> \param lcb l quantum number on b, aux basis +!> \param first_sgfcb indexing +!> \param nshellcb number of shells for b, aux basis +!> \param cg_coeff Clebsch-Gordon coefficients +!> \param cg_none0_list list of none-zero Clebsch-Gordon coefficients +!> \param ncg_none0 number of non-zero Clebsch-Gordon coefficients +!> \param rab distance vector Ra-Rb +!> \param swork_cont contracted and normalized [s|rb^n|s] integrals +!> \param Waux_mat precomputed angular-dependent part +!> \param dWaux_mat derivatives of precomputed angular-dependent part +!> \param dsabb derivative of contracted overlap [abb] of spherical harmonic +!> Gaussians +! ************************************************************************************************** + SUBROUTINE dev_overlap_shg_abb(la, first_sgfa, nshella, lb, first_sgfb, nshellb, & + lcb, first_sgfcb, nshellcb, cg_coeff, cg_none0_list, & + ncg_none0, rab, swork_cont, Waux_mat, dWaux_mat, dsabb) + + INTEGER, DIMENSION(:), INTENT(IN) :: la, first_sgfa + INTEGER, INTENT(IN) :: nshella + INTEGER, DIMENSION(:), INTENT(IN) :: lb, first_sgfb + INTEGER, INTENT(IN) :: nshellb + INTEGER, DIMENSION(:), INTENT(IN) :: lcb, first_sgfcb + INTEGER, INTENT(IN) :: nshellcb + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: cg_coeff + INTEGER, DIMENSION(:, :, :), INTENT(IN) :: cg_none0_list + INTEGER, DIMENSION(:, :), INTENT(IN) :: ncg_none0 + REAL(KIND=dp), INTENT(IN) :: rab(3) + REAL(KIND=dp), DIMENSION(:, 0:, :, :, :), & + INTENT(IN) :: swork_cont + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: Waux_mat + REAL(KIND=dp), DIMENSION(:, :, :, :), INTENT(IN) :: dWaux_mat + REAL(KIND=dp), DIMENSION(:, :, :, :), & + INTENT(INOUT) :: dsabb + + CHARACTER(len=*), PARAMETER :: routineN = 'dev_overlap_shg_abb', & + routineP = moduleN//':'//routineN + + INTEGER :: handle, i, ia, il, ilist, ishella, isob1, isob2, isobb, j, jb, jshellb, kb, & + kshellb, labmin, lai, lbb, lbj, lbk, mai, mbb, mbj, mbk, nla, nlb, sgfa, sgfb, sgfcb + REAL(KIND=dp) :: dprefac, dtemp(3), prefac, rabx2(3), & + tsign + + CALL timeset(routineN, handle) + + rabx2(:) = 2.0_dp*rab + + DO kshellb = 1, nshellcb + lbk = lcb(kshellb) + sgfcb = first_sgfcb(kshellb) + kb = sgfcb+lbk + DO jshellb = 1, nshellb + lbj = lb(jshellb) + sgfb = first_sgfb(jshellb) + jb = sgfb+lbj + DO ishella = 1, nshella + lai = la(ishella) + nla = nsoset(lai-1)+lai+1 + sgfa = first_sgfa(ishella) + ia = sgfa+lai + DO mbj = -lbj, lbj, 1 + DO mbk = -lbk, lbk, 1 + isob1 = indso_inv(lbj, mbj) + isob2 = indso_inv(lbk, mbk) + DO mai = -lai, lai, 1 + DO ilist = 1, ncg_none0(isob1, isob2) + isobb = cg_none0_list(isob1, isob2, ilist) + lbb = indso(1, isobb) + mbb = indso(2, isobb) + nlb = nsoset(lbb-1)+lbb+1 + ! tsgin: because we take the transpose of auxmat (calculated for (la,lb)) + tsign = 1.0_dp + IF (MODULO(lbb-lai, 2) /= 0) tsign = -1.0_dp + labmin = MIN(lai, lbb) + il = (lbj+lbk-lbb)/2 + dtemp = 0.0_dp + DO j = 0, labmin + prefac = swork_cont(lai+lbb-j+1, il, ishella, jshellb, kshellb) + dprefac = swork_cont(lai+lbb-j+2, il, ishella, jshellb, kshellb) + DO i = 1, 3 + dtemp(i) = dtemp(i)+rabx2(i)*dprefac*Waux_mat(j+1, nlb+mbb, nla+mai) & + +prefac*dWaux_mat(i, j+1, nlb+mbb, nla+mai) + ENDDO + ENDDO + DO i = 1, 3 + dsabb(ia+mai, jb+mbj, kb+mbk, i) = dsabb(ia+mai, jb+mbj, kb+mbk, i) & + +tsign*cg_coeff(isob1, isob2, isobb)*dtemp(i) + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + + CALL timestop(handle) + + END SUBROUTINE dev_overlap_shg_abb + +END MODULE ai_construct_shg + diff --git a/src/aobasis/ai_contraction_sphi.F b/src/aobasis/ai_contraction_sphi.F new file mode 100644 index 0000000000..d6ba53323b --- /dev/null +++ b/src/aobasis/ai_contraction_sphi.F @@ -0,0 +1,215 @@ +!--------------------------------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright (C) 2000 - 2016 CP2K developers group ! +!--------------------------------------------------------------------------------------------------! + +! ************************************************************************************************** +!> \brief Contraction of integrals over primitive Cartesian Gaussians based on the contraction +!> matrix sphi which is part of the gto_basis_set_type +!> \par History +!> none +!> \author Dorothea Golze (05.2016) +! ************************************************************************************************** +MODULE ai_contraction_sphi + + USE kinds, ONLY: dp +#include "../base/base_uses.f90" + + IMPLICIT NONE + + PRIVATE + + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'ai_contraction_sphi' + + PUBLIC :: ab_contract, abc_contract, abcd_contract + +CONTAINS + +! ************************************************************************************************** +!> \brief contract overlap integrals (a,b) and transfer to spherical Gaussians +!> \param abint contracted, normalized integrals of spherical Gaussians +!> \param sab uncontracted, unnormalized integrals of primitive Cartesian Gaussians +!> \param sphi_a contraction matrix for center a +!> \param sphi_b contraction matrix for center b +!> \param ncoa number of cartesian orbitals on a +!> \param ncob number of cartesian orbitals on b +!> \param nsgfa number of spherical Gaussian functions on a +!> \param nsgfb number of sperical Gaussian functions on b +! ************************************************************************************************** + SUBROUTINE ab_contract(abint, sab, sphi_a, sphi_b, ncoa, ncob, nsgfa, nsgfb) + + REAL(KIND=dp), DIMENSION(:, :), INTENT(INOUT) :: abint + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: sab, sphi_a, sphi_b + INTEGER, INTENT(IN) :: ncoa, ncob, nsgfa, nsgfb + + CHARACTER(LEN=*), PARAMETER :: routineN = 'ab_contract', routineP = moduleN//':'//routineN + + INTEGER :: m1, m2, msphia, msphib, nn + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: cpp + + msphia = SIZE(sphi_a, 1) + msphib = SIZE(sphi_b, 1) + + m1 = SIZE(sab, 1) + m2 = SIZE(sab, 2) + + nn = SIZE(abint, 1) + + ALLOCATE (cpp(nsgfa, m2)) + + CALL dgemm("T", "N", nsgfa, m2, ncoa, 1._dp, sphi_a, msphia, sab, m1, 0.0_dp, cpp, nsgfa) + CALL dgemm("N", "N", nsgfa, nsgfb, ncob, 1._dp, cpp, nsgfa, sphi_b, msphib, 0.0_dp, & + abint, nn) + + DEALLOCATE (cpp) + + END SUBROUTINE ab_contract + +! ************************************************************************************************** +!> \brief contract three-center overlap integrals (a,b,c) and transfer +!> to spherical Gaussians +!> \param abcint contracted, normalized integrals of spherical Gaussians +!> \param sabc uncontracted, unnormalized integrals of primitive Cartesian Gaussians +!> \param sphi_a contraction matrix for center a +!> \param sphi_b contraction matrix for center b +!> \param sphi_c contraction matrix for center c +!> \param ncoa number of cartesian orbitals on a +!> \param ncob number of cartesian orbitals on b +!> \param ncoc number of cartesian orbitals on c +!> \param nsgfa number of spherical Gaussian functions on a +!> \param nsgfb number of spherical Gaussian functions on b +!> \param nsgfc number of spherical Gaussian functions on c +! ************************************************************************************************** + SUBROUTINE abc_contract(abcint, sabc, sphi_a, sphi_b, sphi_c, ncoa, ncob, ncoc, & + nsgfa, nsgfb, nsgfc) + + REAL(KIND=dp), DIMENSION(:, :, :) :: abcint, sabc + REAL(KIND=dp), DIMENSION(:, :) :: sphi_a, sphi_b, sphi_c + INTEGER, INTENT(IN) :: ncoa, ncob, ncoc, nsgfa, nsgfb, nsgfc + + CHARACTER(LEN=*), PARAMETER :: routineN = 'abc_contract', routineP = moduleN//':'//routineN + + INTEGER :: handle, isgfc, m1, m2, m3, msphia, & + msphib, msphic + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: temp_ccc, work_cpc + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: cpc, cpp + + CALL timeset(routineN, handle) + + msphia = SIZE(sphi_a, 1) + msphib = SIZE(sphi_b, 1) + msphic = SIZE(sphi_c, 1) + + m1 = SIZE(sabc, 1) + m2 = SIZE(sabc, 2) + m3 = SIZE(sabc, 3) + + ALLOCATE (cpp(nsgfa, m2, m3), cpc(nsgfa, m2, nsgfc)) + cpp = 0._dp + cpc = 0._dp + ALLOCATE (work_cpc(nsgfa, m2), temp_ccc(nsgfa, nsgfb)) + work_cpc(:, :) = 0._dp + temp_ccc(:, :) = 0._dp + + CALL dgemm("T", "N", nsgfa, m2*m3, ncoa, 1._dp, sphi_a, msphia, sabc, m1, 0.0_dp, cpp, nsgfa) + CALL dgemm("N", "N", nsgfa*m2, nsgfc, ncoc, 1._dp, cpp, nsgfa*m2, sphi_c, msphic, 0.0_dp, & + cpc, nsgfa*m2) + + DO isgfc = 1, nsgfc + work_cpc(:, :) = cpc(:, :, isgfc) + CALL dgemm("N", "N", nsgfa, nsgfb, ncob, 1._dp, work_cpc, nsgfa, sphi_b, msphib, & + 0.0_dp, temp_ccc, nsgfa) + abcint(:, :, isgfc) = temp_ccc(:, :) + END DO + + DEALLOCATE (cpp, cpc, work_cpc, temp_ccc) + + CALL timestop(handle) + + END SUBROUTINE abc_contract + +! ************************************************************************************************** +!> \brief contract four-center overlap integrals (a,b,c,d) and transfer +!> to spherical Gaussians +!> \param abcdint contracted, normalized integrals of spherical Gaussians +!> \param sabcd uncontracted, unnormalized integrals of primitive Cartesian Gaussians +!> \param sphi_a contraction matrix for center a +!> \param sphi_b contraction matrix for center b +!> \param sphi_c contraction matrix for center c +!> \param sphi_d contraction matrix for center d +!> \param ncoa number of cartesian orbitals on a +!> \param ncob number of cartesian orbitals on b +!> \param ncoc number of cartesian orbitals on c +!> \param ncod number of cartesian orbitals on d +!> \param nsgfa number of spherical Gaussian functions on a +!> \param nsgfb number of spherical Gaussian functions on b +!> \param nsgfc number of spherical Gaussian functions on c +!> \param nsgfd number of spherical Gaussian functions on d +! ************************************************************************************************** + SUBROUTINE abcd_contract(abcdint, sabcd, sphi_a, sphi_b, sphi_c, sphi_d, ncoa, ncob, & + ncoc, ncod, nsgfa, nsgfb, nsgfc, nsgfd) + + REAL(KIND=dp), DIMENSION(:, :, :, :), & + INTENT(INOUT) :: abcdint + REAL(KIND=dp), DIMENSION(:, :, :, :), INTENT(IN) :: sabcd + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: sphi_a, sphi_b, sphi_c, sphi_d + INTEGER, INTENT(IN) :: ncoa, ncob, ncoc, ncod, nsgfa, nsgfb, & + nsgfc, nsgfd + + CHARACTER(LEN=*), PARAMETER :: routineN = 'abcd_contract', routineP = moduleN//':'//routineN + + INTEGER :: handle, isgfc, isgfd, m1, m2, m3, m4, & + msphia, msphib, msphic, msphid + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: temp_cccc, work_cpcc + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: temp_cpcc, work_cppc + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :, :) :: cpcc, cppc, cppp + + CALL timeset(routineN, handle) + + msphia = SIZE(sphi_a, 1) + msphib = SIZE(sphi_b, 1) + msphic = SIZE(sphi_c, 1) + msphid = SIZE(sphi_d, 1) + + m1 = SIZE(sabcd, 1) + m2 = SIZE(sabcd, 2) + m3 = SIZE(sabcd, 3) + m4 = SIZE(sabcd, 4) + + ALLOCATE (cppp(nsgfa, m2, m3, m4), cppc(nsgfa, m2, m3, nsgfd), & + cpcc(nsgfa, m2, nsgfc, nsgfd)) + + ALLOCATE (work_cppc(nsgfa, m2, m3), temp_cpcc(nsgfa, m2, nsgfc)) + work_cppc = 0._dp + temp_cpcc = 0._dp + + ALLOCATE (work_cpcc(nsgfa, m2), temp_cccc(nsgfa, nsgfb)) + work_cpcc = 0._dp + temp_cccc = 0._dp + + CALL dgemm("T", "N", nsgfa, m2*m3*m4, ncoa, 1._dp, sphi_a, msphia, sabcd, m1, & + 0.0_dp, cppp, nsgfa) + CALL dgemm("N", "N", nsgfa*m2*m3, nsgfd, ncod, 1._dp, cppp, nsgfa*m2*m3, & + sphi_d, msphid, 0.0_dp, cppc, nsgfa*m2*m3) + + DO isgfd = 1, nsgfd + work_cppc(:, :, :) = cppc(:, :, :, isgfd) + CALL dgemm("N", "N", nsgfa*m2, nsgfc, ncoc, 1._dp, work_cppc, nsgfa*m2, & + sphi_c, msphic, 0.0_dp, temp_cpcc, nsgfa*m2) + cpcc(:, :, :, isgfd) = temp_cpcc(:, :, :) + DO isgfc = 1, nsgfc + work_cpcc(:, :) = cpcc(:, :, isgfc, isgfd) + CALL dgemm("N", "N", nsgfa, nsgfb, ncob, 1._dp, work_cpcc, nsgfa, sphi_b, & + msphib, 0.0_dp, temp_cccc, nsgfa) + abcdint(:, :, isgfc, isgfd) = temp_cccc(:, :) + END DO + END DO + + DEALLOCATE (cpcc, cppc, cppp) + DEALLOCATE (work_cpcc, work_cppc, temp_cpcc, temp_cccc) + + CALL timestop(handle) + + END SUBROUTINE abcd_contract + +END MODULE ai_contraction_sphi diff --git a/src/aobasis/ai_derivatives.F b/src/aobasis/ai_derivatives.F index 072183483f..c64e2f1fce 100644 --- a/src/aobasis/ai_derivatives.F +++ b/src/aobasis/ai_derivatives.F @@ -41,7 +41,7 @@ MODULE ai_derivatives PRIVATE ! *** Public subroutines *** - PUBLIC :: adbdr, dabdr + PUBLIC :: adbdr, dabdr, dabdr_noscreen CONTAINS @@ -344,6 +344,126 @@ CONTAINS END DO END SUBROUTINE adbdr +! ************************************************************************************************** +!> \brief Calculate the first derivative of an integral block. +!> This takes the derivative with respect to +!> the atomic position Ra, i.e. the center of the primitive on the left. +!> Difference to routine dabdr: employs no (!!) screening, which is relevant when +!> calculating the derivatives of Coulomb integrals +!> \param la_max ... +!> \param npgfa ... +!> \param zeta ... +!> \param lb_max ... +!> \param npgfb ... +!> \param ab ... +!> \param dabdx ... +!> \param dabdy ... +!> \param dabdz ... +! ************************************************************************************************** + SUBROUTINE dabdr_noscreen(la_max, npgfa, zeta, lb_max, npgfb, ab, dabdx, dabdy, dabdz) + INTEGER, INTENT(IN) :: la_max, npgfa + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zeta + INTEGER, INTENT(IN) :: lb_max, npgfb + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: ab + REAL(KIND=dp), DIMENSION(:, :), INTENT(OUT) :: dabdx, dabdy, dabdz + + INTEGER :: ax, ay, az, bx, by, bz, coa, coamx, & + coamy, coamz, coapx, coapy, coapz, & + cob, codb, ipgf, jpgf, la, lb, na, nb, & + nda, ndb + REAL(KIND=dp) :: fa, fx, fy, fz + +! *** Loop over all pairs of primitive Gaussian-type functions *** + + na = 0 + nda = 0 + + dabdx = 0.0_dp + dabdy = 0.0_dp + dabdz = 0.0_dp + + DO ipgf = 1, npgfa + + fa = 2.0_dp*zeta(ipgf) + + nb = 0 + ndb = 0 + + DO jpgf = 1, npgfb + + !*** [da/dRi|O|b] = 2*zeta*[a+1i|O|b] - Ni(a)[a-1i|O|b] *** + + DO la = 0, la_max !MAX(0,la_min),la_max + + IF (la == 0) THEN + + coa = na+1 + coapx = nda+2 + coapy = nda+3 + coapz = nda+4 + + DO lb = 0, lb_max !lb_min,lb_max + DO bx = 0, lb + DO by = 0, lb-bx + bz = lb-bx-by + cob = nb+coset(bx, by, bz) + codb = ndb+coset(bx, by, bz) + dabdx(coa, cob) = fa*ab(coapx, codb) + dabdy(coa, cob) = fa*ab(coapy, codb) + dabdz(coa, cob) = fa*ab(coapz, codb) + END DO + END DO + END DO + + ELSE + + DO ax = 0, la + DO ay = 0, la-ax + az = la-ax-ay + + coa = na+coset(ax, ay, az) + coamx = nda+coset(MAX(0, ax-1), ay, az) + coamy = nda+coset(ax, MAX(0, ay-1), az) + coamz = nda+coset(ax, ay, MAX(0, az-1)) + coapx = nda+coset(ax+1, ay, az) + coapy = nda+coset(ax, ay+1, az) + coapz = nda+coset(ax, ay, az+1) + + fx = REAL(ax, dp) + fy = REAL(ay, dp) + fz = REAL(az, dp) + + DO lb = 0, lb_max !lb_min,lb_max + DO bx = 0, lb + DO by = 0, lb-bx + bz = lb-bx-by + cob = nb+coset(bx, by, bz) + codb = ndb+coset(bx, by, bz) + dabdx(coa, cob) = fa*ab(coapx, codb)-fx*ab(coamx, codb) + dabdy(coa, cob) = fa*ab(coapy, codb)-fy*ab(coamy, codb) + dabdz(coa, cob) = fa*ab(coapz, codb)-fz*ab(coamz, codb) + END DO + END DO + END DO + + END DO + END DO + + END IF + + END DO + + nb = nb+ncoset(lb_max) + ndb = ndb+ncoset(lb_max+1) + + END DO + + na = na+ncoset(la_max) + nda = nda+ncoset(la_max+1) + + END DO + + END SUBROUTINE dabdr_noscreen END MODULE ai_derivatives diff --git a/src/aobasis/ai_operators_r12.F b/src/aobasis/ai_operators_r12.F new file mode 100644 index 0000000000..2fa74334a4 --- /dev/null +++ b/src/aobasis/ai_operators_r12.F @@ -0,0 +1,620 @@ +!--------------------------------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright (C) 2000 - 2016 CP2K developers group ! +!--------------------------------------------------------------------------------------------------! + +! ************************************************************************************************** +!> \brief Calculation of integrals over Cartesian Gaussian-type functions for different r12 +!> operators: 1/r12, erf(omega*r12/r12), erfc(omega*r12/r12), exp(-omega*r12^2)/r12 and +!> exp(-omega*r12^2) +!> \par Literature +!> S. Obara and A. Saika, J. Chem. Phys. 84, 3963 (1986) +!> R. Ahlrichs, PCCP, 8, 3072 (2006) +!> \par History +!> none +!> \par Parameters +!> - ax,ay,az : Angular momentum index numbers of orbital a. +!> - cx,cy,cz : Angular momentum index numbers of orbital c. +!> - coset : Cartesian orbital set pointer. +!> - dac : Distance between the atomic centers a and c. +!> - l{a,c} : Angular momentum quantum number of shell a or c. +!> - l{a,c}_max : Maximum angular momentum quantum number of shell a or c. +!> - l{a,c}_min : Minimum angular momentum quantum number of shell a or c. +!> - ncoset : Number of orbitals in a Cartesian orbital set. +!> - npgf{a,c} : Degree of contraction of shell a or c. +!> - rac : Distance vector between the atomic centers a and c. +!> - rac2 : Square of the distance between the atomic centers a and c. +!> - zet{a,c} : Exponents of the Gaussian-type functions a or c. +!> - zetp : Reciprocal of the sum of the exponents of orbital a and b. +!> - zetw : Reciprocal of the sum of the exponents of orbital a and c. +!> - omega : Parameter in the operator +!> \author Dorothea Golze (05.2016) +! ************************************************************************************************** +MODULE ai_operators_r12 + + USE gamma, ONLY: fgamma=>fgamma_0 + USE kinds, ONLY: dp + USE mathconstants, ONLY: fac,& + pi + USE orbital_pointers, ONLY: coset,& + ncoset +#include "../base/base_uses.f90" + + IMPLICIT NONE + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'ai_operators_r12' + PRIVATE + + ! *** Public subroutines *** + + PUBLIC :: operator2, cps_coulomb2, cps_verf2, cps_verfc2, cps_vgauss2, cps_gauss2 + +#include "./ai_operators_r12.h" + +CONTAINS + +! ************************************************************************************************** +!> \brief Calculation of the primitive two-center integrals over Cartesian Gaussian-type +!> functions for different r12 operators. +!> \param cps_operator2 procedure pointer for the respective operator. The integrals evaluation +!> differs only in the evaluation of the cartesian primitive s (cps) integrals [s|O(r12)|s] +!> and auxiliary integrals [s|O(r12)|s]^n. This pointer selects the correct routine. +!> \param la_max ... +!> \param npgfa ... +!> \param zeta ... +!> \param la_min ... +!> \param lc_max ... +!> \param npgfc ... +!> \param zetc ... +!> \param lc_min ... +!> \param omega ... +!> \param rac ... +!> \param rac2 ... +!> \param vac matrix storing the integrals +!> \param v temporary work array +!> \param maxder maximal derivative +!> \param vac_plus matrix storing the integrals for highler l-quantum numbers; used to +!> construct the derivatives +! ************************************************************************************************** + + SUBROUTINE operator2(cps_operator2, la_max, npgfa, zeta, la_min, lc_max, npgfc, zetc, lc_min, & + omega, rac, rac2, vac, v, maxder, vac_plus) + PROCEDURE(ab_sint_os), POINTER :: cps_operator2 + INTEGER, INTENT(IN) :: la_max, npgfa + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zeta + INTEGER, INTENT(IN) :: la_min, lc_max, npgfc + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zetc + INTEGER, INTENT(IN) :: lc_min + REAL(KIND=dp), INTENT(IN) :: omega + REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rac + REAL(KIND=dp), INTENT(IN) :: rac2 + REAL(KIND=dp), DIMENSION(:, :), INTENT(INOUT) :: vac + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: v + INTEGER, INTENT(IN), OPTIONAL :: maxder + REAL(KIND=dp), DIMENSION(:, :), OPTIONAL :: vac_plus + + CHARACTER(len=*), PARAMETER :: routineN = 'operator2', routineP = moduleN//':'//routineN + + INTEGER :: ax, ay, az, coc, cocx, cocy, cocz, cx, & + cy, cz, i, ipgf, j, jpgf, la, lc, & + maxder_local, n, na, nap, nc, ncp, nmax + REAL(KIND=dp) :: dac, f1, f2, f3, f4, f5, f6, fcx, & + fcy, fcz, rho, zetp, zetq, zetw + REAL(KIND=dp), DIMENSION(3) :: raw, rcw + + v = 0.0_dp + + maxder_local = 0 + IF (PRESENT(maxder)) THEN + maxder_local = maxder + vac_plus = 0.0_dp + END IF + + nmax = la_max+lc_max+1 + + ! *** Calculate the distance of the centers a and c *** + + dac = SQRT(rac2) + + ! *** Loop over all pairs of primitive Gaussian-type functions *** + + na = 0 + nap = 0 + + DO ipgf = 1, npgfa + + nc = 0 + ncp = 0 + + DO jpgf = 1, npgfc + + ! *** Calculate some prefactors *** + + zetp = 1.0_dp/zeta(ipgf) + zetq = 1.0_dp/zetc(jpgf) + zetw = 1.0_dp/(zeta(ipgf)+zetc(jpgf)) + + rho = zeta(ipgf)*zetc(jpgf)*zetw + + ! *** Calculate the basic two-center integrals [s||s]{n} *** + + CALL cps_operator2(v, nmax, zetp, zetq, zetw, rho, rac2, omega) + + ! *** Vertical recurrence steps: [s||s] -> [s||c] *** + + IF (lc_max > 0) THEN + + f1 = 0.5_dp*zetq + f2 = -rho*zetq + + rcw(:) = -zeta(ipgf)*zetw*rac(:) + + ! *** [s||p]{n} = (Wi - Ci)*[s||s]{n+1} (i = x,y,z) *** + + DO n = 1, nmax-1 + v(1, 2, n) = rcw(1)*v(1, 1, n+1) + v(1, 3, n) = rcw(2)*v(1, 1, n+1) + v(1, 4, n) = rcw(3)*v(1, 1, n+1) + END DO + + ! ** [s||c]{n} = (Wi - Ci)*[s||c-1i]{n+1} + *** + ! ** f1*Ni(c-1i)*( [s||c-2i]{n} + *** + ! ** f2*[s||c-2i]{n+1} *** + + DO lc = 2, lc_max + + DO n = 1, nmax-lc + + ! **** Increase the angular momentum component z of c *** + + v(1, coset(0, 0, lc), n) = & + rcw(3)*v(1, coset(0, 0, lc-1), n+1)+ & + f1*REAL(lc-1, dp)*(v(1, coset(0, 0, lc-2), n)+ & + f2*v(1, coset(0, 0, lc-2), n+1)) + + ! *** Increase the angular momentum component y of c *** + + cz = lc-1 + v(1, coset(0, 1, cz), n) = rcw(2)*v(1, coset(0, 0, cz), n+1) + + DO cy = 2, lc + cz = lc-cy + v(1, coset(0, cy, cz), n) = & + rcw(2)*v(1, coset(0, cy-1, cz), n+1)+ & + f1*REAL(cy-1, dp)*(v(1, coset(0, cy-2, cz), n)+ & + f2*v(1, coset(0, cy-2, cz), n+1)) + END DO + + ! *** Increase the angular momentum component x of c *** + + DO cy = 0, lc-1 + cz = lc-1-cy + v(1, coset(1, cy, cz), n) = rcw(1)*v(1, coset(0, cy, cz), n+1) + END DO + + DO cx = 2, lc + f6 = f1*REAL(cx-1, dp) + DO cy = 0, lc-cx + cz = lc-cx-cy + v(1, coset(cx, cy, cz), n) = & + rcw(1)*v(1, coset(cx-1, cy, cz), n+1)+ & + f6*(v(1, coset(cx-2, cy, cz), n)+ & + f2*v(1, coset(cx-2, cy, cz), n+1)) + END DO + END DO + + END DO + + END DO + + END IF + + ! *** Vertical recurrence steps: [s||c] -> [a||c] *** + + IF (la_max > 0) THEN + + f3 = 0.5_dp*zetp + f4 = -rho*zetp + f5 = 0.5_dp*zetw + + raw(:) = zetc(jpgf)*zetw*rac(:) + + ! *** [p||s]{n} = (Wi - Ai)*[s||s]{n+1} (i = x,y,z) *** + + DO n = 1, nmax-1 + v(2, 1, n) = raw(1)*v(1, 1, n+1) + v(3, 1, n) = raw(2)*v(1, 1, n+1) + v(4, 1, n) = raw(3)*v(1, 1, n+1) + END DO + + ! *** [a||s]{n} = (Wi - Ai)*[a-1i||s]{n+1} + *** + ! *** f3*Ni(a-1i)*( [a-2i||s]{n} + *** + ! *** f4*[a-2i||s]{n+1}) *** + + DO la = 2, la_max + + DO n = 1, nmax-la + + ! *** Increase the angular momentum component z of a *** + + v(coset(0, 0, la), 1, n) = & + raw(3)*v(coset(0, 0, la-1), 1, n+1)+ & + f3*REAL(la-1, dp)*(v(coset(0, 0, la-2), 1, n)+ & + f4*v(coset(0, 0, la-2), 1, n+1)) + + ! *** Increase the angular momentum component y of a *** + + az = la-1 + v(coset(0, 1, az), 1, n) = raw(2)*v(coset(0, 0, az), 1, n+1) + + DO ay = 2, la + az = la-ay + v(coset(0, ay, az), 1, n) = & + raw(2)*v(coset(0, ay-1, az), 1, n+1)+ & + f3*REAL(ay-1, dp)*(v(coset(0, ay-2, az), 1, n)+ & + f4*v(coset(0, ay-2, az), 1, n+1)) + END DO + + ! *** Increase the angular momentum component x of a *** + + DO ay = 0, la-1 + az = la-1-ay + v(coset(1, ay, az), 1, n) = raw(1)*v(coset(0, ay, az), 1, n+1) + END DO + + DO ax = 2, la + f6 = f3*REAL(ax-1, dp) + DO ay = 0, la-ax + az = la-ax-ay + v(coset(ax, ay, az), 1, n) = & + raw(1)*v(coset(ax-1, ay, az), 1, n+1)+ & + f6*(v(coset(ax-2, ay, az), 1, n)+ & + f4*v(coset(ax-2, ay, az), 1, n+1)) + END DO + END DO + + END DO + + END DO + + DO lc = 1, lc_max + + DO cx = 0, lc + DO cy = 0, lc-cx + cz = lc-cx-cy + + coc = coset(cx, cy, cz) + cocx = coset(MAX(0, cx-1), cy, cz) + cocy = coset(cx, MAX(0, cy-1), cz) + cocz = coset(cx, cy, MAX(0, cz-1)) + + fcx = f5*REAL(cx, dp) + fcy = f5*REAL(cy, dp) + fcz = f5*REAL(cz, dp) + + ! *** [p||c]{n} = (Wi - Ai)*[s||c]{n+1} + *** + ! *** f5*Ni(c)*[s||c-1i]{n+1} *** + + DO n = 1, nmax-1-lc + v(2, coc, n) = raw(1)*v(1, coc, n+1)+fcx*v(1, cocx, n+1) + v(3, coc, n) = raw(2)*v(1, coc, n+1)+fcy*v(1, cocy, n+1) + v(4, coc, n) = raw(3)*v(1, coc, n+1)+fcz*v(1, cocz, n+1) + END DO + + ! *** [a||c]{n} = (Wi - Ai)*[a-1i||c]{n+1} + *** + ! *** f3*Ni(a-1i)*( [a-2i||c]{n} + *** + ! *** f4*[a-2i||c]{n+1}) + *** + ! *** f5*Ni(c)*[a-1i||c-1i]{n+1} *** + + DO la = 2, la_max + + DO n = 1, nmax-la-lc + + ! *** Increase the angular momentum component z of a *** + + v(coset(0, 0, la), coc, n) = & + raw(3)*v(coset(0, 0, la-1), coc, n+1)+ & + f3*REAL(la-1, dp)*(v(coset(0, 0, la-2), coc, n)+ & + f4*v(coset(0, 0, la-2), coc, n+1))+ & + fcz*v(coset(0, 0, la-1), cocz, n+1) + + ! *** Increase the angular momentum component y of a *** + + az = la-1 + v(coset(0, 1, az), coc, n) = & + raw(2)*v(coset(0, 0, az), coc, n+1)+ & + fcy*v(coset(0, 0, az), cocy, n+1) + + DO ay = 2, la + az = la-ay + v(coset(0, ay, az), coc, n) = & + raw(2)*v(coset(0, ay-1, az), coc, n+1)+ & + f3*REAL(ay-1, dp)*(v(coset(0, ay-2, az), coc, n)+ & + f4*v(coset(0, ay-2, az), coc, n+1))+ & + fcy*v(coset(0, ay-1, az), cocy, n+1) + END DO + + ! *** Increase the angular momentum component x of a *** + + DO ay = 0, la-1 + az = la-1-ay + v(coset(1, ay, az), coc, n) = & + raw(1)*v(coset(0, ay, az), coc, n+1)+ & + fcx*v(coset(0, ay, az), cocx, n+1) + END DO + + DO ax = 2, la + f6 = f3*REAL(ax-1, dp) + DO ay = 0, la-ax + az = la-ax-ay + v(coset(ax, ay, az), coc, n) = & + raw(1)*v(coset(ax-1, ay, az), coc, n+1)+ & + f6*(v(coset(ax-2, ay, az), coc, n)+ & + f4*v(coset(ax-2, ay, az), coc, n+1))+ & + fcx*v(coset(ax-1, ay, az), cocx, n+1) + END DO + END DO + + END DO + + END DO + + END DO + END DO + + END DO + + END IF + + DO j = ncoset(lc_min-1)+1, ncoset(lc_max-maxder_local) + DO i = ncoset(la_min-1)+1, ncoset(la_max-maxder_local) + vac(na+i, nc+j) = v(i, j, 1) + END DO + END DO + + IF (PRESENT(maxder)) THEN + DO j = 1, ncoset(lc_max) + DO i = 1, ncoset(la_max) + vac_plus(nap+i, ncp+j) = v(i, j, 1) + END DO + END DO + END IF + + nc = nc+ncoset(lc_max-maxder_local) + ncp = ncp+ncoset(lc_max) + + END DO + + na = na+ncoset(la_max-maxder_local) + nap = nap+ncoset(la_max) + + END DO + + END SUBROUTINE operator2 + +! ************************************************************************************************** +!> \brief Calculation of Coulomb integrals for s-function, i.e, [s|1/r12|s], and the auxiliary +!> integrals [s|1/r12|s]^n +!> \param v matrix storing the integrals +!> \param nmax maximal n in the auxiliary integrals [s|1/r12|s]^n +!> \param zetp = 1/zeta +!> \param zetq = 1/zetc +!> \param zetw = 1/(zeta+zetc) +!> \param rho = zeta*zetc*zetw +!> \param rac2 square distance between center A and C, |Ra-Rc|^2 +!> \param omega this parameter is actually not used, but included for the sake of the abstract +!> interface +! ************************************************************************************************** + SUBROUTINE cps_coulomb2(v, nmax, zetp, zetq, zetw, rho, rac2, omega) + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: v + INTEGER, INTENT(IN) :: nmax + REAL(KIND=dp), INTENT(IN) :: zetp, zetq, zetw, rho, rac2, omega + + CHARACTER(len=*), PARAMETER :: routineN = 'cps_coulomb2', routineP = moduleN//':'//routineN + + INTEGER :: n + REAL(KIND=dp) :: dummy, f0, t + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: f + + ALLOCATE (f(0:nmax)) + dummy = omega + f0 = 2.0_dp*SQRT(pi**5*zetw)*zetp*zetq + + ! *** Calculate the incomplete Gamma/Boys function *** + + t = rho*rac2 + CALL fgamma(nmax-1, t, f) + + ! *** Calculate the basic two-center integrals [s||s]{n} *** + + DO n = 1, nmax + v(1, 1, n) = f0*f(n-1) + END DO + + DEALLOCATE (f) + END SUBROUTINE cps_coulomb2 + +! ************************************************************************************************** +!> \brief Calculation of verf integrals for s-function, i.e, [s|erf(omega*r12)/r12|s], and the +!> auxiliary integrals [s|erf(omega*r12)/r12|s]^n +!> \param v matrix storing the integrals +!> \param nmax maximal n in the auxiliary integrals [s|erf(omega*r12)/r12|s]^n +!> \param zetp = 1/zeta +!> \param zetq = 1/zetc +!> \param zetw = 1/(zeta+zetc) +!> \param rho = zeta*zetc*zetw +!> \param rac2 square distance between center A and C, |Ra-Rc|^2 +!> \param omega parameter in the operator +! ************************************************************************************************** + SUBROUTINE cps_verf2(v, nmax, zetp, zetq, zetw, rho, rac2, omega) + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: v + INTEGER, INTENT(IN) :: nmax + REAL(KIND=dp), INTENT(IN) :: zetp, zetq, zetw, rho, rac2, omega + + CHARACTER(len=*), PARAMETER :: routineN = 'cps_verf2', routineP = moduleN//':'//routineN + + INTEGER :: n + REAL(KIND=dp) :: arg, comega, f0, t + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: f + + ALLOCATE (f(0:nmax)) + comega = omega**2/(omega**2+rho) + f0 = 2.0_dp*SQRT(pi**5*zetw*comega)*zetp*zetq + + ! *** Calculate the incomplete Gamma/Boys function *** + + t = rho*rac2 + arg = comega*t + CALL fgamma(nmax-1, arg, f) + + ! *** Calculate the basic two-center integrals [s||s]{n} *** + + DO n = 1, nmax + v(1, 1, n) = f0*f(n-1)*comega**(n-1) + END DO + + DEALLOCATE (f) + + END SUBROUTINE cps_verf2 + +! ************************************************************************************************** +!> \brief Calculation of verfc integrals for s-function, i.e, [s|erfc(omega*r12)/r12|s], and +!> the auxiliary integrals [s|erfc(omega*r12)/r12|s]^n +!> \param v matrix storing the integrals +!> \param nmax maximal n in the auxiliary integrals [s|erfc(omega*r12)/r12|s]^n +!> \param zetp = 1/zeta +!> \param zetq = 1/zetc +!> \param zetw = 1/(zeta+zetc) +!> \param rho = zeta*zetc*zetw +!> \param rac2 square distance between center A and C, |Ra-Rc|^2 +!> \param omega parameter in the operator +! ************************************************************************************************** + SUBROUTINE cps_verfc2(v, nmax, zetp, zetq, zetw, rho, rac2, omega) + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: v + INTEGER, INTENT(IN) :: nmax + REAL(KIND=dp), INTENT(IN) :: zetp, zetq, zetw, rho, rac2, omega + + CHARACTER(len=*), PARAMETER :: routineN = 'cps_verfc2', routineP = moduleN//':'//routineN + + INTEGER :: n + REAL(KIND=dp) :: argerf, comega, f0, t + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: fv, fverf + + ALLOCATE (fv(0:nmax), fverf(0:nmax)) + comega = omega**2/(omega**2+rho) + f0 = 2.0_dp*SQRT(pi**5*zetw)*zetp*zetq + + ! *** Calculate the incomplete Gamma/Boys function *** + + t = rho*rac2 + argerf = comega*t + + CALL fgamma(nmax-1, t, fv) + CALL fgamma(nmax-1, argerf, fverf) + + ! *** Calculate the basic two-center integrals [s||s]{n} *** + + DO n = 1, nmax + v(1, 1, n) = f0*(fv(n-1)-SQRT(comega)*comega**(n-1)*fverf(n-1)) + END DO + + DEALLOCATE (fv, fverf) + + END SUBROUTINE cps_verfc2 + +! ************************************************************************************************** +!> \brief Calculation of vgauss integrals for s-function, i.e, [s|exp(-omega*r12^2)/r12|s], and +!> the auxiliary integrals [s|exp(-omega*r12^2)/r12|s] +!> \param v matrix storing the integrals +!> \param nmax maximal n in the auxiliary integrals [s|exp(-omega*r12^2)/r12|s] +!> \param zetp = 1/zeta +!> \param zetq = 1/zetc +!> \param zetw = 1/(zeta+zetc) +!> \param rho = zeta*zetc*zetw +!> \param rac2 square distance between center A and C, |Ra-Rc|^2 +!> \param omega parameter in the operator +! ************************************************************************************************** + SUBROUTINE cps_vgauss2(v, nmax, zetp, zetq, zetw, rho, rac2, omega) + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: v + INTEGER, INTENT(IN) :: nmax + REAL(KIND=dp), INTENT(IN) :: zetp, zetq, zetw, rho, rac2, omega + + CHARACTER(len=*), PARAMETER :: routineN = 'cps_vgauss2', routineP = moduleN//':'//routineN + + INTEGER :: j, n + REAL(KIND=dp) :: arg, dummy, eta, expT, f0, fsign, t, tau + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: f + + ALLOCATE (f(0:nmax)) + + dummy = zetp + dummy = zetq + eta = rho/(rho+omega) + tau = omega/(rho+omega) + + ! *** Calculate the incomplete Gamma/Boys function *** + + t = rho*rac2 + arg = eta*t + + CALL fgamma(nmax-1, arg, f) + + expT = EXP(-omega/(omega+rho)*t) + f0 = 2.0_dp*SQRT(pi**5*zetw**3)/(rho+omega)*expT + + ! *** Calculate the basic two-center integrals [s||s]{n} *** + v(1, 1, 1:nmax) = 0.0_dp + DO n = 1, nmax + fsign = (-1.0_dp)**(n-1) + DO j = 0, n-1 + v(1, 1, n) = v(1, 1, n)+f0*fsign* & + fac(n-1)/fac(n-j-1)/fac(j)*(-tau)**(n-j-1)*(-eta)**j*f(j) + ENDDO + ENDDO + + DEALLOCATE (f) + + END SUBROUTINE cps_vgauss2 + +! ************************************************************************************************** +!> \brief Calculation of gauss integrals for s-function, i.e, [s|exp(-omega*r12^2)|s], and +!> the auxiliary integrals [s|exp(-omega*r12^2)|s] +!> \param v matrix storing the integrals +!> \param nmax maximal n in the auxiliary integrals [s|exp(-omega*r12^2)|s] +!> \param zetp = 1/zeta +!> \param zetq = 1/zetc +!> \param zetw = 1/(zeta+zetc) +!> \param rho = zeta*zetc*zetw +!> \param rac2 square distance between center A and C, |Ra-Rc|^2 +!> \param omega parameter in the operator +! ************************************************************************************************** + SUBROUTINE cps_gauss2(v, nmax, zetp, zetq, zetw, rho, rac2, omega) + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: v + INTEGER, INTENT(IN) :: nmax + REAL(KIND=dp), INTENT(IN) :: zetp, zetq, zetw, rho, rac2, omega + + CHARACTER(len=*), PARAMETER :: routineN = 'cps_gauss2', routineP = moduleN//':'//routineN + + INTEGER :: n + REAL(KIND=dp) :: dummy, expT, f0, t, tau + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: f + + ALLOCATE (f(0:nmax)) + + dummy = zetp + dummy = zetq + tau = omega/(rho+omega) + t = rho*rac2 + expT = EXP(-tau*t) + f0 = pi**3*SQRT(zetw**3/(rho+omega)**3)*expT + + ! *** Calculate the basic two-center integrals [s||s]{n} *** + + DO n = 1, nmax + v(1, 1, n) = f0*tau**(n-1) + END DO + + DEALLOCATE (f) + + END SUBROUTINE cps_gauss2 + +END MODULE ai_operators_r12 diff --git a/src/aobasis/ai_operators_r12.h b/src/aobasis/ai_operators_r12.h new file mode 100644 index 0000000000..ecb89399b6 --- /dev/null +++ b/src/aobasis/ai_operators_r12.h @@ -0,0 +1,17 @@ +!--------------------------------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright (C) 2000 - 2016 CP2K developers group ! +!--------------------------------------------------------------------------------------------------! +! ************************************************************************************************** +!> \brief Interface for the calculation of integrals over s-functions and the s-type auxiliary +!> integrals using the Obara-Saika (OS) scheme +! ************************************************************************************************** + ABSTRACT INTERFACE + SUBROUTINE ab_sint_os(v, nmax, zetp, zetq, zetw, rho, rac2, omega) + USE kinds, ONLY: dp + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: v + INTEGER, INTENT(IN) :: nmax + REAL(KIND=dp), INTENT(IN) :: zetp, zetq, zetw, rho, rac2, omega + + END SUBROUTINE ab_sint_os + END INTERFACE diff --git a/src/aobasis/ai_s_contract_shg.F b/src/aobasis/ai_s_contract_shg.F new file mode 100644 index 0000000000..68f068ef93 --- /dev/null +++ b/src/aobasis/ai_s_contract_shg.F @@ -0,0 +1,1015 @@ +!--------------------------------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright (C) 2000 - 2016 CP2K developers group ! +!--------------------------------------------------------------------------------------------------! + +! ************************************************************************************************** +!> \brief Routines for calculating the s-integrals and their scalar derivatives with respect to rab2 +!> over solid harmonic Gaussian (SHG) functions + contraction routines for these integrals +!> i) (s|O(r12)|s) where O(r12) is the overlap, coulomb operator etc. +!> ii) (aba) and (abb) s-overlaps +!> \par Literature (partly) +!> T.J. Giese and D. M. York, J. Chem. Phys, 128, 064104 (2008) +!> T. Helgaker, P Joergensen, J. Olsen, Molecular Electronic-Structure +!> Theory, Wiley +!> R. Ahlrichs, PCCP, 8, 3072 (2006) +!> \par History +!> created [05.2016] +!> \author Dorothea Golze +! ************************************************************************************************** +MODULE ai_s_contract_shg + USE gamma, ONLY: fgamma=>fgamma_0 + USE kinds, ONLY: dp + USE mathconstants, ONLY: fac,& + ifac,& + pi +#include "../base/base_uses.f90" + + IMPLICIT NONE + + PRIVATE + + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'ai_s_contract_shg' + +! *** Public subroutines *** + PUBLIC :: s_overlap_ab, s_overlap_abx, s_coulomb_ab, s_verf_ab, s_verfc_ab, & + s_vgauss_ab, s_gauss_ab + + PUBLIC :: contract_sint_ab_clow, contract_sint_ab_chigh, contract_s_overlap_aba, & + contract_s_overlap_abb + +CONTAINS + +! ************************************************************************************************** +!> \brief calculates the uncontracted, not normalized [s|s] overlap +!> \param la_max maximal l quantum number on a +!> \param npgfa number of primitive Gaussian on a +!> \param zeta set of exponents on a +!> \param lb_max maximal l quantum number on b +!> \param npgfb number of primitive Gaussian on a +!> \param zetb set of exponents on a +!> \param rab distance vector between a and b +!> \param s uncontracted overlap of s functions +!> \param calculate_forces ... +! ************************************************************************************************** + SUBROUTINE s_overlap_ab(la_max, npgfa, zeta, lb_max, npgfb, zetb, rab, s, calculate_forces) + + INTEGER, INTENT(IN) :: la_max, npgfa + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zeta + INTEGER, INTENT(IN) :: lb_max, npgfb + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zetb + REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rab + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: s + LOGICAL, INTENT(IN) :: calculate_forces + + CHARACTER(len=*), PARAMETER :: routineN = 's_overlap_ab', routineP = moduleN//':'//routineN + + INTEGER :: handle, ids, ipgfa, jpgfb, ndev + REAL(KIND=dp) :: a, b, rab2, xhi, zet + + CALL timeset(routineN, handle) + + ! Distance of the centers a and b + rab2 = rab(1)*rab(1)+rab(2)*rab(2)+rab(3)*rab(3) + ndev = 0 + IF (calculate_forces) ndev = 1 + ! Loops over all pairs of primitive Gaussian-type functions + DO ipgfa = 1, npgfa + DO jpgfb = 1, npgfb + + ! Distance Screening !maybe later + + ! Calculate some prefactors + a = zeta(ipgfa) + b = zetb(jpgfb) + zet = a+b + xhi = a*b/zet + + ! [s|s] integral + s(ipgfa, jpgfb, 1) = (pi/zet)**(1.5_dp)*EXP(-xhi*rab2) + + DO ids = 2, la_max+lb_max+ndev+1 + s(ipgfa, jpgfb, ids) = -xhi*s(ipgfa, jpgfb, ids-1) + ENDDO + + END DO + END DO + + CALL timestop(handle) + + END SUBROUTINE s_overlap_ab + +! ************************************************************************************************** +!> \brief calculates [s|ra^n|s] integrals for [aba] and the [s|rb^n|s] +!> integrals for [abb] +!> abx ... x stands either for a and b respectively +!> \param la_max maximal l quantum number on a, orbital basis +!> \param npgfa number of primitive Gaussian on a, orbital basis +!> \param zeta set of exponents on a, orbital basis +!> \param lb_max maximal l quantum number on b, orbital basis +!> \param npgfb number of primitive Gaussian on a, orbital basis +!> \param zetb set of exponents on b, orbital basis +!> \param lx_max maximal l quantum number of aux basis on x (a or b) +!> \param npgfx number of primitive Gaussian on x, aux basis +!> \param zetx set of exponents on x, aux basis +!> \param rab distance vector between a and b +!> \param s uncontracted [s|r^n|s] integrals +!> \param calculate_forces ... +!> \param calc_aba flag if [aba] or [abb] is calculated +! ************************************************************************************************** + SUBROUTINE s_overlap_abx(la_max, npgfa, zeta, lb_max, npgfb, zetb, lx_max, npgfx, zetx, & + rab, s, calculate_forces, calc_aba) + + INTEGER, INTENT(IN) :: la_max, npgfa + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zeta + INTEGER, INTENT(IN) :: lb_max, npgfb + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zetb + INTEGER, INTENT(IN) :: lx_max, npgfx + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zetx + REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rab + REAL(KIND=dp), DIMENSION(:, :, :, 0:, :), & + INTENT(INOUT) :: s + LOGICAL, INTENT(IN) :: calculate_forces, calc_aba + + CHARACTER(len=*), PARAMETER :: routineN = 's_overlap_abx', routineP = moduleN//':'//routineN + + INTEGER :: handle, ids, il, ipgfa, jpgfb, kpgfx, & + laa_max, lbb_max, lmax, n, ndev, nds, & + nl + REAL(KIND=dp) :: a, b, exp_rab2, k, pfac, prefac, rab2, & + sqrt_pi3, sqrt_zet, sr_int, temp, x, & + xhi, zet + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: dsr_int, dtemp + + CALL timeset(routineN, handle) + + ! Distance of the centers a and b + rab2 = rab(1)*rab(1)+rab(2)*rab(2)+rab(3)*rab(3) + ndev = 0 + IF (calculate_forces) ndev = 1 + + IF (calc_aba) THEN + laa_max = la_max+lx_max + nl = INT(laa_max/2) + IF (la_max == 0 .OR. lx_max == 0) nl = 0 + lmax = laa_max+lb_max + ELSE + lbb_max = lb_max+lx_max + nl = INT(lbb_max/2) + IF (lb_max == 0 .OR. lx_max == 0) nl = 0 + lmax = la_max+lbb_max + ENDIF + + ALLOCATE (dtemp(nl+1), dsr_int(nl+1)) + + sqrt_pi3 = SQRT(pi**3) + + ! Loops over all pairs of primitive Gaussian-type functions + DO ipgfa = 1, npgfa + DO jpgfb = 1, npgfb + DO kpgfx = 1, npgfx + + ! Calculate some prefactors + IF (calc_aba) THEN + a = zeta(ipgfa)+zetx(kpgfx) + b = zetb(jpgfb) + x = b + ELSE + a = zeta(ipgfa) + b = zetb(jpgfb)+zetx(kpgfx) + x = a + ENDIF + + zet = a+b + xhi = a*b/zet + exp_rab2 = EXP(-xhi*rab2) + + pfac = x**2/zet + sqrt_zet = SQRT(zet) + + DO il = 0, nl + nds = lmax-2*il+ndev+1 + SELECT CASE (il) + CASE (0) + ! [s|s] integral + s(ipgfa, jpgfb, kpgfx, il, 1) = (pi/zet)**(1.5_dp)*exp_rab2 + DO ids = 2, nds + n = ids-1 + s(ipgfa, jpgfb, kpgfx, il, ids) = (-xhi)**n*s(ipgfa, jpgfb, kpgfx, il, 1) + ENDDO + CASE (1) + ![s|r^2|s] integral + sr_int = sqrt_pi3/sqrt_zet**5*(3.0_dp+2.0_dp*pfac*rab2)/2.0_dp + s(ipgfa, jpgfb, kpgfx, il, 1) = exp_rab2*sr_int + k = sqrt_pi3*x**2/sqrt_zet**7 + DO ids = 2, nds + n = ids-1 + s(ipgfa, jpgfb, kpgfx, il, ids) = (-xhi)**n*exp_rab2*sr_int & + +n*(-xhi)**(n-1)*k*exp_rab2 + ENDDO + CASE (2) + ![s|r^4|s] integral + prefac = sqrt_pi3/4.0_dp/sqrt_zet**7 + temp = 15.0_dp+20.0_dp*pfac*rab2+4.0_dp*(pfac*rab2)**2 + sr_int = prefac*temp + s(ipgfa, jpgfb, kpgfx, il, 1) = exp_rab2*sr_int + !** derivatives + k = sqrt_pi3*x**4/sqrt_zet**11 + dsr_int(1) = prefac*(20.0_dp*pfac+8.0_dp*pfac**2*rab2) + DO ids = 2, nds + n = ids-1 + dtemp(1) = (-xhi)**n*exp_rab2*sr_int + dtemp(2) = n*(-xhi)**(n-1)*exp_rab2*dsr_int(1) + dtemp(3) = (n**2-n)*(-xhi)**(n-2)*k*exp_rab2 + s(ipgfa, jpgfb, kpgfx, il, ids) = dtemp(1)+dtemp(2)+dtemp(3) + ENDDO + CASE (3) + ![s|r^6|s] integral + prefac = sqrt_pi3/8.0_dp/sqrt_zet**9 + temp = 105.0_dp+210.0_dp*pfac*rab2 + temp = temp+84.0_dp*(pfac*rab2)**2+8.0_dp*(pfac*rab2)**3 + sr_int = prefac*temp + s(ipgfa, jpgfb, kpgfx, il, 1) = exp_rab2*sr_int + !** derivatives + k = sqrt_pi3*x**6/sqrt_zet**15 + dsr_int(1) = prefac*(210.0_dp*pfac+168.0_dp*pfac**2*rab2 & + +24.0_dp*pfac**3*rab2**2) + dsr_int(2) = prefac*(168.0_dp*pfac**2+48.0_dp*pfac**3*rab2) + DO ids = 2, nds + n = ids-1 + dtemp(1) = (-xhi)**n*exp_rab2*sr_int + dtemp(2) = REAL(n, dp)*(-xhi)**(n-1)*exp_rab2*dsr_int(1) + dtemp(3) = REAL(n**2-n, dp)/2.0_dp*(-xhi)**(n-2) & + *exp_rab2*dsr_int(2) + dtemp(4) = REAL(n*(n-1)*(n-2), dp)*(-xhi)**(n-3)*k*exp_rab2 + s(ipgfa, jpgfb, kpgfx, il, ids) = dtemp(1)+dtemp(2) & + +dtemp(3)+dtemp(4) + ENDDO + CASE (4) + ![s|r^8|s] integral + prefac = sqrt_pi3/16.0_dp/sqrt_zet**11 + temp = 945.0_dp+2520.0_dp*pfac*rab2+1512.0_dp*(pfac*rab2)**2 + temp = temp+288.0_dp*(pfac*rab2)**3+16.0_dp*(pfac*rab2)**4 + sr_int = prefac*temp + s(ipgfa, jpgfb, kpgfx, il, 1) = exp_rab2*sr_int + !** derivatives + k = sqrt_pi3*x**8/sqrt_zet**19 + dsr_int(1) = 2520.0_dp*pfac+3024.0_dp*pfac**2*rab2 + dsr_int(1) = dsr_int(1)+864.0_dp*pfac**3*rab2**2 & + +64.0_dp*pfac**4*rab2**3 + dsr_int(1) = prefac*dsr_int(1) + dsr_int(2) = 3024.0_dp*pfac**2+1728.0_dp*pfac**3*rab2 + dsr_int(2) = dsr_int(2)+192.0_dp*pfac**4*rab2**2 + dsr_int(2) = prefac*dsr_int(2) + dsr_int(3) = 1728.0_dp*pfac**3+384.0_dp*pfac**4*rab2 + dsr_int(3) = prefac*dsr_int(3) + DO ids = 2, nds + n = ids-1 + dtemp(1) = (-xhi)**n*exp_rab2*sr_int + dtemp(2) = REAL(n, dp)*(-xhi)**(n-1)*exp_rab2*dsr_int(1) + dtemp(3) = REAL(n**2-n, dp)/2.0_dp*(-xhi)**(n-2) & + *exp_rab2*dsr_int(2) + dtemp(4) = REAL(n*(n-1)*(n-2), dp)/6.0_dp*(-xhi)**(n-3) & + *exp_rab2*dsr_int(3) + dtemp(5) = REAL(n*(n-1)*(n-2)*(n-3), dp)*(-xhi)**(n-4) & + *k*exp_rab2 + s(ipgfa, jpgfb, kpgfx, il, ids) = dtemp(1)+dtemp(2)+dtemp(3) & + +dtemp(4)+dtemp(5) + ENDDO + CASE (5) + ![s|r^10|s] integral + prefac = sqrt_pi3/32.0_dp/sqrt_zet**13 + temp = 10395.0_dp+34650.0_dp*pfac*rab2 + temp = temp+27720.0_dp*(pfac*rab2)**2+7920.0_dp*(pfac*rab2)**3 + temp = temp+880.0_dp*(pfac*rab2)**4+32.0_dp*(pfac*rab2)**5 + sr_int = prefac*temp + s(ipgfa, jpgfb, kpgfx, il, 1) = exp_rab2*sr_int + !** derivatives + k = sqrt_pi3*x**10/sqrt_zet**23 + dsr_int(1) = 34650.0_dp*pfac+55440.0_dp*pfac**2*rab2 + dsr_int(1) = dsr_int(1)+23760.0_dp*pfac**3*rab2**2 + dsr_int(1) = dsr_int(1)+3520.0_dp*pfac**4*rab2**3 + dsr_int(1) = dsr_int(1)+160.0_dp*pfac**5*rab2**4 + dsr_int(1) = prefac*dsr_int(1) + dsr_int(2) = 55440.0_dp*pfac**2+47520.0_dp*pfac**3*rab2 + dsr_int(2) = dsr_int(2)+10560.0_dp*pfac**4*rab2**2 + dsr_int(2) = dsr_int(2)+640.0_dp*pfac**5*rab2**3 + dsr_int(2) = prefac*dsr_int(2) + dsr_int(3) = 47520.0_dp*pfac**3+21120.0_dp*pfac**4*rab2 + dsr_int(3) = dsr_int(3)+1920.0_dp*pfac**5*rab2**2 + dsr_int(3) = prefac*dsr_int(3) + dsr_int(4) = 21120.0_dp*pfac**4+3840.0_dp*pfac**5*rab2 + dsr_int(4) = prefac*dsr_int(4) + DO ids = 2, nds + n = ids-1 + dtemp(1) = (-xhi)**n*exp_rab2*sr_int + dtemp(2) = REAL(n, dp)*(-xhi)**(n-1)*exp_rab2*dsr_int(1) + dtemp(3) = REAL(n**2-n, dp)/2.0_dp*(-xhi)**(n-2) & + *exp_rab2*dsr_int(2) + dtemp(4) = REAL(n*(n-1)*(n-2), dp)/6.0_dp*(-xhi)**(n-3) & + *exp_rab2*dsr_int(3) + dtemp(5) = REAL(n*(n-1)*(n-2)*(n-3), dp)/24.0_dp*(-xhi)**(n-4) & + *exp_rab2*dsr_int(4) + dtemp(6) = REAL(n*(n-1)*(n-2)*(n-3)*(n-4), dp)*(-xhi)**(n-5) & + *k*exp_rab2 + s(ipgfa, jpgfb, kpgfx, il, ids) = dtemp(1)+dtemp(2)+dtemp(3) & + +dtemp(4)+dtemp(5)+dtemp(6) + ENDDO + CASE DEFAULT + CALL cp_abort(__LOCATION__, & + "SHG integrals not implemented when sum of l quantum"// & + " number of orbital and ri basis larger than 11") + END SELECT + + ENDDO + + END DO + END DO + END DO + + DEALLOCATE (dtemp, dsr_int) + + CALL timestop(handle) + + END SUBROUTINE s_overlap_abx + +! ************************************************************************************************** +!> \brief calculates the uncontracted, not normalized [s|1/r12|s] two-center coulomb integral +!> \param la_max maximal l quantum number on a +!> \param npgfa number of primitive Gaussian on a +!> \param zeta set of exponents on a +!> \param lb_max maximal l quantum number on b +!> \param npgfb number of primitive Gaussian on a +!> \param zetb set of exponents on a +!> \param omega parameter not needed, but given for the sake of the abstract interface +!> \param rab distance vector between a and b +!> \param v uncontracted coulomb integral of s functions +!> \param calculate_forces ... +! ************************************************************************************************** + SUBROUTINE s_coulomb_ab(la_max, npgfa, zeta, lb_max, npgfb, zetb, omega, rab, v, calculate_forces) + + INTEGER, INTENT(IN) :: la_max, npgfa + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zeta + INTEGER, INTENT(IN) :: lb_max, npgfb + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zetb + REAL(KIND=dp), INTENT(IN) :: omega + REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rab + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: v + LOGICAL, INTENT(IN) :: calculate_forces + + CHARACTER(len=*), PARAMETER :: routineN = 's_coulomb_ab', routineP = moduleN//':'//routineN + + INTEGER :: handle, ids, ipgfa, jpgfb, n, ndev, nmax + REAL(KIND=dp) :: a, b, dummy, prefac, rab2, T, xhi, zet + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: f + + CALL timeset(routineN, handle) + + dummy = omega + + ! Distance of the centers a and b + rab2 = rab(1)*rab(1)+rab(2)*rab(2)+rab(3)*rab(3) + ndev = 0 + IF (calculate_forces) ndev = 1 + nmax = la_max+lb_max+ndev+1 + ALLOCATE (f(0:nmax)) + ! Loops over all pairs of primitive Gaussian-type functions + DO ipgfa = 1, npgfa + DO jpgfb = 1, npgfb + + ! Calculate some prefactors + a = zeta(ipgfa) + b = zetb(jpgfb) + zet = a+b + xhi = a*b/zet + prefac = 2.0_dp*SQRT(pi**5)/(a*b)/SQRT(zet) + T = xhi*rab2 + CALL fgamma(nmax-1, T, f) + + DO ids = 1, nmax + n = ids-1 + v(ipgfa, jpgfb, ids) = prefac*(-xhi)**n*f(n) + ENDDO + + END DO + END DO + DEALLOCATE (f) + + CALL timestop(handle) + + END SUBROUTINE s_coulomb_ab + +! ************************************************************************************************** +!> \brief calculates the uncontracted, not normalized [s|1/erf(omega*r12)/r12|s] two-center integral +!> \param la_max maximal l quantum number on a +!> \param npgfa number of primitive Gaussian on a +!> \param zeta set of exponents on a +!> \param lb_max maximal l quantum number on b +!> \param npgfb number of primitive Gaussian on a +!> \param zetb set of exponents on a +!> \param omega parameter in the operator +!> \param rab distance vector between a and b +!> \param v uncontracted erf(r)/r integral of s functions +!> \param calculate_forces ... +! ************************************************************************************************** + SUBROUTINE s_verf_ab(la_max, npgfa, zeta, lb_max, npgfb, zetb, omega, rab, v, calculate_forces) + + INTEGER, INTENT(IN) :: la_max, npgfa + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zeta + INTEGER, INTENT(IN) :: lb_max, npgfb + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zetb + REAL(KIND=dp), INTENT(IN) :: omega + REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rab + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: v + LOGICAL, INTENT(IN) :: calculate_forces + + CHARACTER(len=*), PARAMETER :: routineN = 's_verf_ab', routineP = moduleN//':'//routineN + + INTEGER :: handle, ids, ipgfa, jpgfb, n, ndev, nmax + REAL(KIND=dp) :: a, Arg, b, comega, prefac, rab2, T, xhi, & + zet + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: f + + CALL timeset(routineN, handle) + + ! Distance of the centers a and b + rab2 = rab(1)*rab(1)+rab(2)*rab(2)+rab(3)*rab(3) + ndev = 0 + IF (calculate_forces) ndev = 1 + nmax = la_max+lb_max+ndev+1 + ALLOCATE (f(0:nmax)) + ! Loops over all pairs of primitive Gaussian-type functions + DO ipgfa = 1, npgfa + DO jpgfb = 1, npgfb + + ! Calculate some prefactors + a = zeta(ipgfa) + b = zetb(jpgfb) + zet = a+b + xhi = a*b/zet + comega = omega**2/(omega**2+xhi) + prefac = 2.0_dp*SQRT(pi**5)*SQRT(comega)/(a*b)/SQRT(zet) + T = xhi*rab2 + Arg = comega*T + CALL fgamma(nmax-1, Arg, f) + + DO ids = 1, nmax + n = ids-1 + v(ipgfa, jpgfb, ids) = prefac*(-xhi*comega)**n*f(n) + ENDDO + + END DO + END DO + DEALLOCATE (f) + + CALL timestop(handle) + + END SUBROUTINE s_verf_ab + +! ************************************************************************************************** +!> \brief calculates the uncontracted, not normalized [s|1/erfc(omega*r12)/r12|s] two-center +!> integral +!> \param la_max maximal l quantum number on a +!> \param npgfa number of primitive Gaussian on a +!> \param zeta set of exponents on a +!> \param lb_max maximal l quantum number on b +!> \param npgfb number of primitive Gaussian on a +!> \param zetb set of exponents on a +!> \param omega parameter in the operator +!> \param rab distance vector between a and b +!> \param v uncontracted erf(r)/r integral of s functions +!> \param calculate_forces ... +! ************************************************************************************************** + SUBROUTINE s_verfc_ab(la_max, npgfa, zeta, lb_max, npgfb, zetb, omega, rab, v, calculate_forces) + + INTEGER, INTENT(IN) :: la_max, npgfa + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zeta + INTEGER, INTENT(IN) :: lb_max, npgfb + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zetb + REAL(KIND=dp), INTENT(IN) :: omega + REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rab + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: v + LOGICAL, INTENT(IN) :: calculate_forces + + CHARACTER(len=*), PARAMETER :: routineN = 's_verfc_ab', routineP = moduleN//':'//routineN + + INTEGER :: handle, ids, ipgfa, jpgfb, n, ndev, nmax + REAL(KIND=dp) :: a, b, comega, comegaT, prefac, rab2, T, & + xhi, zet + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: fv, fverf + + CALL timeset(routineN, handle) + + ! Distance of the centers a and b + rab2 = rab(1)*rab(1)+rab(2)*rab(2)+rab(3)*rab(3) + ndev = 0 + IF (calculate_forces) ndev = 1 + nmax = la_max+lb_max+ndev+1 + ALLOCATE (fv(0:nmax), fverf(0:nmax)) + ! Loops over all pairs of primitive Gaussian-type functions + DO ipgfa = 1, npgfa + DO jpgfb = 1, npgfb + + ! Calculate some prefactors + a = zeta(ipgfa) + b = zetb(jpgfb) + zet = a+b + xhi = a*b/zet + comega = omega**2/(omega**2+xhi) + prefac = 2.0_dp*SQRT(pi**5)/(a*b)/SQRT(zet) + T = xhi*rab2 + comegaT = comega*T + CALL fgamma(nmax-1, T, fv) + CALL fgamma(nmax-1, comegaT, fverf) + + DO ids = 1, nmax + n = ids-1 + v(ipgfa, jpgfb, ids) = prefac*(-xhi)**n*(fv(n)-SQRT(comega)*comega**n*fverf(n)) + ENDDO + + END DO + END DO + DEALLOCATE (fv, fverf) + + CALL timestop(handle) + + END SUBROUTINE s_verfc_ab + +! ************************************************************************************************** +!> \brief calculates the uncontracted, not normalized [s|exp(-omega*r12**2)/r12|s] two-center +!> integral +!> \param la_max maximal l quantum number on a +!> \param npgfa number of primitive Gaussian on a +!> \param zeta set of exponents on a +!> \param lb_max maximal l quantum number on b +!> \param npgfb number of primitive Gaussian on a +!> \param zetb set of exponents on a +!> \param omega parameter in the operator +!> \param rab distance vector between a and b +!> \param v uncontracted exp(-omega*r**2)/r integral of s functions +!> \param calculate_forces ... +! ************************************************************************************************** + SUBROUTINE s_vgauss_ab(la_max, npgfa, zeta, lb_max, npgfb, zetb, omega, rab, v, calculate_forces) + + INTEGER, INTENT(IN) :: la_max, npgfa + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zeta + INTEGER, INTENT(IN) :: lb_max, npgfb + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zetb + REAL(KIND=dp), INTENT(IN) :: omega + REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rab + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: v + LOGICAL, INTENT(IN) :: calculate_forces + + CHARACTER(len=*), PARAMETER :: routineN = 's_vgauss_ab', routineP = moduleN//':'//routineN + + INTEGER :: handle, ids, ipgfa, j, jpgfb, n, ndev, & + nmax + REAL(KIND=dp) :: a, b, eta, etaT, expT, oeta, prefac, & + rab2, T, xeta, xhi, zet + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: f + + CALL timeset(routineN, handle) + + ! Distance of the centers a and b + rab2 = rab(1)*rab(1)+rab(2)*rab(2)+rab(3)*rab(3) + ndev = 0 + IF (calculate_forces) ndev = 1 + nmax = la_max+lb_max+ndev+1 + ALLOCATE (f(0:nmax)) + ! Loops over all pairs of primitive Gaussian-type functions + v = 0.0_dp + DO ipgfa = 1, npgfa + DO jpgfb = 1, npgfb + + ! Calculate some prefactors + a = zeta(ipgfa) + b = zetb(jpgfb) + zet = a+b + xhi = a*b/zet + eta = xhi/(xhi+omega) + oeta = omega*eta + xeta = xhi*eta + T = xhi*rab2 + expT = EXP(-omega/(omega+xhi)*T) + prefac = 2.0_dp*SQRT(pi**5/zet**3)/(xhi+omega)*expT + etaT = eta*T + CALL fgamma(nmax-1, etaT, f) + + DO ids = 1, nmax + n = ids-1 + DO j = 0, n + v(ipgfa, jpgfb, ids) = v(ipgfa, jpgfb, ids) & + +prefac*fac(n)/fac(j)/fac(n-j)*(-oeta)**(n-j)*(-xeta)**j*f(j) + ENDDO + ENDDO + + END DO + END DO + DEALLOCATE (f) + + CALL timestop(handle) + + END SUBROUTINE s_vgauss_ab + +! ************************************************************************************************** +!> \brief calculates the uncontracted, not normalized [s|exp(-omega*r12**2)|s] two-center +!> integral +!> \param la_max maximal l quantum number on a +!> \param npgfa number of primitive Gaussian on a +!> \param zeta set of exponents on a +!> \param lb_max maximal l quantum number on b +!> \param npgfb number of primitive Gaussian on a +!> \param zetb set of exponents on a +!> \param omega parameter in the operator +!> \param rab distance vector between a and b +!> \param v uncontracted exp(-omega*r**2) integral of s functions +!> \param calculate_forces ... +! ************************************************************************************************** + SUBROUTINE s_gauss_ab(la_max, npgfa, zeta, lb_max, npgfb, zetb, omega, rab, v, calculate_forces) + + INTEGER, INTENT(IN) :: la_max, npgfa + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zeta + INTEGER, INTENT(IN) :: lb_max, npgfb + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zetb + REAL(KIND=dp), INTENT(IN) :: omega + REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rab + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: v + LOGICAL, INTENT(IN) :: calculate_forces + + CHARACTER(len=*), PARAMETER :: routineN = 's_gauss_ab', routineP = moduleN//':'//routineN + + INTEGER :: handle, ids, ipgfa, jpgfb, n, ndev, nmax + REAL(KIND=dp) :: a, b, eta, expT, oeta, prefac, rab2, T, & + xhi, zet + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: f + + CALL timeset(routineN, handle) + + ! Distance of the centers a and b + rab2 = rab(1)*rab(1)+rab(2)*rab(2)+rab(3)*rab(3) + ndev = 0 + IF (calculate_forces) ndev = 1 + nmax = la_max+lb_max+ndev+1 + ALLOCATE (f(0:nmax)) + ! Loops over all pairs of primitive Gaussian-type functions + DO ipgfa = 1, npgfa + DO jpgfb = 1, npgfb + + ! Calculate some prefactors + a = zeta(ipgfa) + b = zetb(jpgfb) + zet = a+b + xhi = a*b/zet + eta = xhi/(xhi+omega) + oeta = omega*eta + T = xhi*rab2 + expT = EXP(-omega/(omega+xhi)*T) + prefac = pi**3/SQRT(zet**3)/SQRT((xhi+omega)**3)*expT + + DO ids = 1, nmax + n = ids-1 + v(ipgfa, jpgfb, ids) = prefac*(-oeta)**n + ENDDO + + END DO + END DO + DEALLOCATE (f) + + CALL timestop(handle) + + END SUBROUTINE s_gauss_ab + +! ************************************************************************************************** +!> \brief Contraction and normalization of the [s|O(r12)|s] integrals and their scalar derivatives; +!> this routine is more efficient for uncontracted basis sets (clow), e.g. for ri basis sets +!> \param la set of l quantum numbers for a +!> \param npgfa number of primitive Gaussian on a +!> \param nshella number of shells for a +!> \param zeta set of exponents on a +!> \param scona_shg SHG contraction/normalization matrix for a +!> \param lb set of l quantum numbers for b +!> \param npgfb number of primitive Gaussian on b +!> \param nshellb number of shells for b +!> \param zetb set of exponents on b +!> \param sconb_shg SHG contraction/normalization matrix for b +!> \param swork matrix storing the uncontracted and unnormalized s-integrals and derivatives +!> \param swork_cont matrix storing the contracted and normalized s-integrals and derivatives +!> \param calculate_forces ... +! ************************************************************************************************** + SUBROUTINE contract_sint_ab_clow(la, npgfa, nshella, zeta, scona_shg, & + lb, npgfb, nshellb, zetb, sconb_shg, & + swork, swork_cont, calculate_forces) + + INTEGER, DIMENSION(:), INTENT(IN) :: la + INTEGER, INTENT(IN) :: npgfa, nshella + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zeta + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: scona_shg + INTEGER, DIMENSION(:), INTENT(IN) :: lb + INTEGER, INTENT(IN) :: npgfb, nshellb + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zetb + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: sconb_shg + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: swork, swork_cont + LOGICAL, INTENT(IN) :: calculate_forces + + CHARACTER(LEN=*), PARAMETER :: routineN = 'contract_sint_ab_clow', & + routineP = moduleN//':'//routineN + + INTEGER :: handle, ids, ids_start, ipgfa, ishella, & + jpgfb, jshellb, lai, lbj, ndev, nds + REAL(KIND=dp) :: aif, bjf + + CALL timeset(routineN, handle) + + ndev = 0 + IF (calculate_forces) ndev = 1 + + swork_cont = 0.0_dp + DO ishella = 1, nshella + lai = la(ishella) + DO jshellb = 1, nshellb + lbj = lb(jshellb) + nds = lai+lbj+1 + ids_start = nds-MIN(lai, lbj) + DO ipgfa = 1, npgfa + aif = 1.0_dp/((2._dp*zeta(ipgfa))**lai) + DO jpgfb = 1, npgfb + bjf = 1.0_dp/((2._dp*zetb(jpgfb))**lbj) + DO ids = ids_start, nds+ndev + swork_cont(ids, ishella, jshellb) = swork_cont(ids, ishella, jshellb) & + +scona_shg(ipgfa, ishella) & + *sconb_shg(jpgfb, jshellb) & + *aif*bjf*swork(ipgfa, jpgfb, ids) + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + + CALL timestop(handle) + + END SUBROUTINE contract_sint_ab_clow + +! ************************************************************************************************** +!> \brief Contraction and normalization of the [s|O(r12)|s] integrals and their scalar derivatives; +!> this routine is more efficient for highly contracted basis sets (chigh) +!> \param npgfa number of primitive Gaussian on a +!> \param nshella number of shells for a +!> \param scona SHG contraction/normalization matrix for a +!> \param npgfb number of primitive Gaussian on b +!> \param nshellb number of shells for b +!> \param sconb SHG contraction/normalization matrix for b +!> \param nds maximal derivative of [s|O(r12)|s] with respect to rab2 +!> \param swork matrix storing the uncontracted and unnormalized s-integrals and derivatives +!> \param swork_cont matrix storing the contracted and normalized s-integrals and derivatives +! ************************************************************************************************** + SUBROUTINE contract_sint_ab_chigh(npgfa, nshella, scona, & + npgfb, nshellb, sconb, & + nds, swork, swork_cont) + + INTEGER, INTENT(IN) :: npgfa, nshella + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: scona + INTEGER, INTENT(IN) :: npgfb, nshellb + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: sconb + INTEGER, INTENT(IN) :: nds + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: swork, swork_cont + + CHARACTER(LEN=*), PARAMETER :: routineN = 'contract_sint_ab_chigh', & + routineP = moduleN//':'//routineN + + INTEGER :: handle + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: work_cc, work_pc + + CALL timeset(routineN, handle) + + swork_cont = 0.0_dp + ALLOCATE (work_pc(npgfb, nds, nshella)) + ALLOCATE (work_cc(nds, nshella, nshellb)) + + CALL dgemm("T", "N", npgfb*nds, nshella, npgfa, 1._dp, swork, npgfa, scona, npgfa, & + 0.0_dp, work_pc, npgfb*nds) + CALL dgemm("T", "N", nds*nshella, nshellb, npgfb, 1._dp, work_pc, npgfb, sconb, npgfb, & + 0.0_dp, swork_cont, nds*nshella) + + DEALLOCATE (work_pc, work_cc) + CALL timestop(handle) + + END SUBROUTINE contract_sint_ab_chigh + +! ************************************************************************************************** +!> \brief Contraction and normalization of the (aba) overlap +!> \param la set of l quantum numbers on a; orbital basis +!> \param npgfa number of primitive Gaussians functions on a; orbital basis +!> \param nshella number of shells for a; orbital basis +!> \param zeta set of exponents on a; orbital basis +!> \param scona_shg SHG contraction/normalization matrix for a; orbital basis +!> \param lb set of l quantum numbers on b; orbital basis +!> \param npgfb number of primitive Gaussians functions on b; orbital basis +!> \param nshellb number of shells for b; orbital basis +!> \param zetb set of exponents on b; orbital basis +!> \param sconb_shg SHG contraction/normalization matrix for b; orbital basis +!> \param lca set of l quantum numbers on a; ri basis +!> \param npgfca number of primitive Gaussians functions on a; ri basis +!> \param nshellca number of shells for a; ri basis +!> \param zetca set of exponents on a; ri basis +!> \param sconca_shg SHG contraction/normalization matrix for a; ri basis +!> \param swork matrix of storing the uncontracted and unnormalized s-integrals and derivatives +!> \param swork_cont matrix storing the contracted and normalized s-integrals and derivatives +!> \param calculate_forces ... +! ************************************************************************************************** + SUBROUTINE contract_s_overlap_aba(la, npgfa, nshella, zeta, scona_shg, & + lb, npgfb, nshellb, zetb, sconb_shg, & + lca, npgfca, nshellca, zetca, sconca_shg, & + swork, swork_cont, calculate_forces) + + INTEGER, DIMENSION(:), INTENT(IN) :: la + INTEGER, INTENT(IN) :: npgfa, nshella + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zeta + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: scona_shg + INTEGER, DIMENSION(:), INTENT(IN) :: lb + INTEGER, INTENT(IN) :: npgfb, nshellb + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zetb + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: sconb_shg + INTEGER, DIMENSION(:), INTENT(IN) :: lca + INTEGER, INTENT(IN) :: npgfca, nshellca + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zetca + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: sconca_shg + REAL(KIND=dp), DIMENSION(:, :, :, 0:, :), & + INTENT(IN) :: swork + REAL(KIND=dp), DIMENSION(:, 0:, :, :, :), & + INTENT(INOUT) :: swork_cont + LOGICAL, INTENT(IN) :: calculate_forces + + CHARACTER(len=*), PARAMETER :: routineN = 'contract_s_overlap_aba', & + routineP = moduleN//':'//routineN + + INTEGER :: handle, ids, ids_start, iil, il, ipgfa, & + ishella, jpgfb, jshellb, kpgfa, & + kshella, laa, lai, lak, lbj, ndev, & + nds, nl + REAL(KIND=dp) :: a, aif, bjf, const, consta, constca, & + prefac, shg_fac(0:5) + + CALL timeset(routineN, handle) + + ndev = 0 + IF (calculate_forces) ndev = 1 + shg_fac(0) = 1.0_dp + + swork_cont = 0.0_dp + DO ishella = 1, nshella + lai = la(ishella) + consta = SQRT(1.0_dp/REAL(2*lai+1, dp)) + DO jshellb = 1, nshellb + lbj = lb(jshellb) + DO kshella = 1, nshellca + lak = lca(kshella) + constca = SQRT(1.0_dp/REAL(2*lak+1, dp)) + nl = INT((lai+lak)/2) + IF (lai == 0 .OR. lak == 0) nl = 0 + DO il = 0, nl + laa = lai+lak-2*il + nds = laa+lbj+1 + ids_start = nds-MIN(laa, lbj) + const = consta*constca*2.0_dp*SQRT(pi*REAL(2*laa+1, dp)) + DO iil = 1, il + shg_fac(iil) = fac(laa+iil-1)*ifac(laa)*REAL(laa, dp) & + *fac(il)/fac(il-iil)/fac(iil) + ENDDO + DO ipgfa = 1, npgfa + DO jpgfb = 1, npgfb + bjf = 1.0_dp/((2._dp*zetb(jpgfb))**lbj) + DO kpgfa = 1, npgfca + a = zeta(ipgfa)+zetca(kpgfa) + aif = 1.0_dp/((2._dp*a)**laa) + prefac = const*aif*bjf & + *scona_shg(ipgfa, ishella) & + *sconb_shg(jpgfb, jshellb) & + *sconca_shg(kpgfa, kshella) + DO ids = ids_start, nds+ndev + DO iil = 0, il + swork_cont(ids, il, ishella, jshellb, kshella) = & + swork_cont(ids, il, ishella, jshellb, kshella) & + +prefac*shg_fac(iil)*swork(ipgfa, jpgfb, kpgfa, il-iil, ids)/a**iil + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + + CALL timestop(handle) + + END SUBROUTINE contract_s_overlap_aba + +! ************************************************************************************************** +!> \brief Contraction and normalization of the (abb) overlap +!> \param la set of l quantum numbers on a +!> \param npgfa number of primitive Gaussians functions on a; orbital basis +!> \param nshella number of shells for a; orbital basis +!> \param zeta set of exponents on a; orbital basis +!> \param scona_shg SHG contraction/normalization matrix for a; orbital basis +!> \param lb set of l quantum numbers on b; orbital basis +!> \param npgfb number of primitive Gaussians functions on b; orbital basis +!> \param nshellb number of shells for b; orbital basis +!> \param zetb set of exponents on b; orbital basis +!> \param sconb_shg SHG contraction/normalization matrix for b; orbital basis +!> \param lcb set of l quantum numbers on b; ri basis +!> \param npgfcb number of primitive Gaussians functions on b; ri basis +!> \param nshellcb number of shells for b; ri basis +!> \param zetcb set of exponents on b; ri basis +!> \param sconcb_shg SHG contraction/normalization matrix for b; ri basis +!> \param swork matrix of storing the uncontracted and unnormalized s-integrals and derivatives +!> \param swork_cont matrix storing the contracted and normalized s-integrals and derivatives +!> \param calculate_forces ... +! ************************************************************************************************** + SUBROUTINE contract_s_overlap_abb(la, npgfa, nshella, zeta, scona_shg, & + lb, npgfb, nshellb, zetb, sconb_shg, & + lcb, npgfcb, nshellcb, zetcb, sconcb_shg, & + swork, swork_cont, calculate_forces) + + INTEGER, DIMENSION(:), INTENT(IN) :: la + INTEGER, INTENT(IN) :: npgfa, nshella + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zeta + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: scona_shg + INTEGER, DIMENSION(:), INTENT(IN) :: lb + INTEGER, INTENT(IN) :: npgfb, nshellb + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zetb + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: sconb_shg + INTEGER, DIMENSION(:), INTENT(IN) :: lcb + INTEGER, INTENT(IN) :: npgfcb, nshellcb + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zetcb + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: sconcb_shg + REAL(KIND=dp), DIMENSION(:, :, :, 0:, :), & + INTENT(IN) :: swork + REAL(KIND=dp), DIMENSION(:, 0:, :, :, :), & + INTENT(INOUT) :: swork_cont + LOGICAL, INTENT(IN) :: calculate_forces + + CHARACTER(len=*), PARAMETER :: routineN = 'contract_s_overlap_abb', & + routineP = moduleN//':'//routineN + + INTEGER :: handle, ids, ids_start, iil, il, ipgfa, & + ishella, jpgfb, jshellb, kpgfb, & + kshellb, lai, lbb, lbj, lbk, ndev, & + nds, nl + REAL(KIND=dp) :: aif, b, bjf, const, constb, constcb, & + prefac, shg_fac(0:5) + + CALL timeset(routineN, handle) + + ndev = 0 + IF (calculate_forces) ndev = 1 + shg_fac(0) = 1.0_dp + + swork_cont = 0.0_dp + DO kshellb = 1, nshellcb + lbk = lcb(kshellb) + constcb = SQRT(1.0_dp/REAL(2*lbk+1, dp)) + DO jshellb = 1, nshellb + lbj = lb(jshellb) + constb = SQRT(1.0_dp/REAL(2*lbj+1, dp)) + nl = INT((lbj+lbk)/2) + IF (lbj == 0 .OR. lbk == 0) nl = 0 + DO ishella = 1, nshella + lai = la(ishella) + DO il = 0, nl + lbb = lbj+lbk-2*il + nds = lai+lbb+1 + ids_start = nds-MIN(lai, lbb) + const = constb*constcb*2.0_dp*SQRT(pi*REAL(2*lbb+1, dp)) + DO iil = 1, il + shg_fac(iil) = fac(lbb+iil-1)*ifac(lbb)*REAL(lbb, dp) & + *fac(il)/fac(il-iil)/fac(iil) + ENDDO + DO ipgfa = 1, npgfa + aif = 1.0_dp/((2._dp*zeta(ipgfa))**lai) + DO jpgfb = 1, npgfb + DO kpgfb = 1, npgfcb + b = zetb(jpgfb)+zetcb(kpgfb) + bjf = 1.0_dp/((2._dp*b)**lbb) + prefac = const*aif*bjf & + *scona_shg(ipgfa, ishella) & + *sconb_shg(jpgfb, jshellb) & + *sconcb_shg(kpgfb, kshellb) + DO ids = ids_start, nds+ndev + DO iil = 0, il + swork_cont(ids, il, ishella, jshellb, kshellb) = & + swork_cont(ids, il, ishella, jshellb, kshellb) & + +prefac*shg_fac(iil)*swork(ipgfa, jpgfb, kpgfb, il-iil, ids)/b**iil + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + CALL timestop(handle) + + END SUBROUTINE contract_s_overlap_abb + +END MODULE ai_s_contract_shg diff --git a/src/aobasis/ai_shg_overlap.F b/src/aobasis/ai_shg_overlap.F deleted file mode 100644 index cc269fa90a..0000000000 --- a/src/aobasis/ai_shg_overlap.F +++ /dev/null @@ -1,1336 +0,0 @@ -!--------------------------------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 - 2016 CP2K developers group ! -!--------------------------------------------------------------------------------------------------! - -! ************************************************************************************************** -!> \brief Calculation of the overlap integrals over solid harmonic Gaussian -!> (SHG) functions. -!> \par Literature (partly) -!> T.J. Giese and D. M. York, J. Chem. Phys, 128, 064104 (2008) -!> T. Helgaker, P Joergensen, J. Olsen, Molecular Electronic-Structure -!> Theory, Wiley -!> \par History -!> created [04.2015] -!> \author Dorothea Golze -! ************************************************************************************************** -MODULE ai_shg_overlap - USE kinds, ONLY: dp - USE mathconstants, ONLY: dfac,& - fac,& - pi - USE orbital_pointers, ONLY: indso,& - indso_inv,& - nsoset_pm -#include "../base/base_uses.f90" - - IMPLICIT NONE - - PRIVATE - - CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'ai_shg_overlap' - -! *** Public subroutines *** - PUBLIC :: get_dW_matrix, get_W_matrix, get_real_scaled_solid_harmonic, & - overlap_shg_ab, dev_overlap_shg_ab, overlap_shg_aba, dev_overlap_shg_aba, & - overlap_shg_abb, dev_overlap_shg_abb, s_overlap_ab, s_overlap_abx - -CONTAINS - -! ************************************************************************************************** -!> \brief calculates the uncontracted, not normalized [s|s] overlap -!> \param la_max maximal l quantum number on a -!> \param npgfa number of primitive Gaussian on a -!> \param zeta set of exponents on a -!> \param lb_max maximal l quantum number on b -!> \param npgfb number of primitive Gaussian on a -!> \param zetb set of exponents on a -!> \param rab distance vector between a and b -!> \param s uncontracted overlap of s functions -!> \param calculate_forces ... -! ************************************************************************************************** - SUBROUTINE s_overlap_ab(la_max, npgfa, zeta, lb_max, npgfb, zetb, rab, s, calculate_forces) - - INTEGER, INTENT(IN) :: la_max, npgfa - REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zeta - INTEGER, INTENT(IN) :: lb_max, npgfb - REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zetb - REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rab - REAL(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: s - LOGICAL, INTENT(IN) :: calculate_forces - - CHARACTER(len=*), PARAMETER :: routineN = 's_overlap_ab', routineP = moduleN//':'//routineN - - INTEGER :: handle, ids, ipgfa, jpgfb, ndev - REAL(KIND=dp) :: a, b, rab2, xhi, zet - - CALL timeset(routineN, handle) - - ! Distance of the centers a and b - rab2 = rab(1)*rab(1)+rab(2)*rab(2)+rab(3)*rab(3) - ndev = 0 - IF (calculate_forces) ndev = 1 - ! Loops over all pairs of primitive Gaussian-type functions - DO ipgfa = 1, npgfa - DO jpgfb = 1, npgfb - - ! Distance Screening !maybe later - - ! Calculate some prefactors - a = zeta(ipgfa) - b = zetb(jpgfb) - zet = a+b - xhi = a*b/zet - - ! [s|s] integral - s(ipgfa, jpgfb, 1) = (pi/zet)**(1.5_dp)*EXP(-xhi*rab2) - - DO ids = 2, la_max+lb_max+ndev+1 - s(ipgfa, jpgfb, ids) = -xhi*s(ipgfa, jpgfb, ids-1) - ENDDO - - END DO - END DO - - CALL timestop(handle) - - END SUBROUTINE s_overlap_ab - -! ************************************************************************************************** -!> \brief calculates [s|ra^n|s] integrals for [aba] and the [s|rb^n|s] -!> integrals for [abb] -!> abx ... x stands either for a and b respectively -!> \param la_max maximal l quantum number on a, orbital basis -!> \param npgfa number of primitive Gaussian on a, orbital basis -!> \param zeta set of exponents on a, orbital basis -!> \param lb_max maximal l quantum number on b, orbital basis -!> \param npgfb number of primitive Gaussian on a, orbital basis -!> \param zetb set of exponents on b, orbital basis -!> \param lx_max maximal l quantum number of aux basis on x (a or b) -!> \param npgfx number of primitive Gaussian on x, aux basis -!> \param zetx set of exponents on x, aux basis -!> \param rab distance vector between a and b -!> \param s uncontracted [s|r^n|s] integrals -!> \param calculate_forces ... -!> \param calc_aba flag if [aba] or [abb] is calculated -! ************************************************************************************************** - SUBROUTINE s_overlap_abx(la_max, npgfa, zeta, lb_max, npgfb, zetb, lx_max, npgfx, zetx, & - rab, s, calculate_forces, calc_aba) - - INTEGER, INTENT(IN) :: la_max, npgfa - REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zeta - INTEGER, INTENT(IN) :: lb_max, npgfb - REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zetb - INTEGER, INTENT(IN) :: lx_max, npgfx - REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zetx - REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rab - REAL(KIND=dp), DIMENSION(:, :, :, :, :), POINTER :: s - LOGICAL, INTENT(IN) :: calculate_forces, calc_aba - - CHARACTER(len=*), PARAMETER :: routineN = 's_overlap_abx', routineP = moduleN//':'//routineN - - INTEGER :: handle, ids, il, ipgfa, jpgfb, kpgfx, & - laa_max, lbb_max, lmax, n, ndev, nds, & - nl - REAL(KIND=dp) :: a, b, exp_rab2, k, pfac, prefac, rab2, & - sqrt_pi3, sqrt_zet, sr_int, temp, x, & - xhi, zet - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: dsr_int, dtemp - - CALL timeset(routineN, handle) - - ! Distance of the centers a and b - rab2 = rab(1)*rab(1)+rab(2)*rab(2)+rab(3)*rab(3) - ndev = 0 - IF (calculate_forces) ndev = 1 - - IF (calc_aba) THEN - laa_max = la_max+lx_max - nl = INT(laa_max/2) - IF (la_max == 0 .OR. lx_max == 0) nl = 0 - lmax = laa_max+lb_max - ELSE - lbb_max = lb_max+lx_max - nl = INT(lbb_max/2) - IF (lb_max == 0 .OR. lx_max == 0) nl = 0 - lmax = la_max+lbb_max - ENDIF - - ALLOCATE (dtemp(nl+1), dsr_int(nl+1)) - - sqrt_pi3 = SQRT(pi**3) - - ! Loops over all pairs of primitive Gaussian-type functions - DO ipgfa = 1, npgfa - DO jpgfb = 1, npgfb - DO kpgfx = 1, npgfx - - ! Calculate some prefactors - IF (calc_aba) THEN - a = zeta(ipgfa)+zetx(kpgfx) - b = zetb(jpgfb) - x = b - ELSE - a = zeta(ipgfa) - b = zetb(jpgfb)+zetx(kpgfx) - x = a - ENDIF - - zet = a+b - xhi = a*b/zet - exp_rab2 = EXP(-xhi*rab2) - - pfac = x**2/zet - sqrt_zet = SQRT(zet) - - DO il = 0, nl - nds = lmax-2*il+ndev+1 - SELECT CASE (il) - CASE (0) - ! [s|s] integral - s(ipgfa, jpgfb, kpgfx, il, 1) = (pi/zet)**(1.5_dp)*exp_rab2 - DO ids = 2, nds - n = ids-1 - s(ipgfa, jpgfb, kpgfx, il, ids) = (-xhi)**n*s(ipgfa, jpgfb, kpgfx, il, 1) - ENDDO - CASE (1) - ![s|r^2|s] integral - sr_int = sqrt_pi3/sqrt_zet**5*(3.0_dp+2.0_dp*pfac*rab2)/2.0_dp - s(ipgfa, jpgfb, kpgfx, il, 1) = exp_rab2*sr_int - k = sqrt_pi3*x**2/sqrt_zet**7 - DO ids = 2, nds - n = ids-1 - s(ipgfa, jpgfb, kpgfx, il, ids) = (-xhi)**n*exp_rab2*sr_int & - +n*(-xhi)**(n-1)*k*exp_rab2 - ENDDO - CASE (2) - ![s|r^4|s] integral - prefac = sqrt_pi3/4.0_dp/sqrt_zet**7 - temp = 15.0_dp+20.0_dp*pfac*rab2+4.0_dp*(pfac*rab2)**2 - sr_int = prefac*temp - s(ipgfa, jpgfb, kpgfx, il, 1) = exp_rab2*sr_int - !** derivatives - k = sqrt_pi3*x**4/sqrt_zet**11 - dsr_int(1) = prefac*(20.0_dp*pfac+8.0_dp*pfac**2*rab2) - DO ids = 2, nds - n = ids-1 - dtemp(1) = (-xhi)**n*exp_rab2*sr_int - dtemp(2) = n*(-xhi)**(n-1)*exp_rab2*dsr_int(1) - dtemp(3) = (n**2-n)*(-xhi)**(n-2)*k*exp_rab2 - s(ipgfa, jpgfb, kpgfx, il, ids) = dtemp(1)+dtemp(2)+dtemp(3) - ENDDO - CASE (3) - ![s|r^6|s] integral - prefac = sqrt_pi3/8.0_dp/sqrt_zet**9 - temp = 105.0_dp+210.0_dp*pfac*rab2 - temp = temp+84.0_dp*(pfac*rab2)**2+8.0_dp*(pfac*rab2)**3 - sr_int = prefac*temp - s(ipgfa, jpgfb, kpgfx, il, 1) = exp_rab2*sr_int - !** derivatives - k = sqrt_pi3*x**6/sqrt_zet**15 - dsr_int(1) = prefac*(210.0_dp*pfac+168.0_dp*pfac**2*rab2 & - +24.0_dp*pfac**3*rab2**2) - dsr_int(2) = prefac*(168.0_dp*pfac**2+48.0_dp*pfac**3*rab2) - DO ids = 2, nds - n = ids-1 - dtemp(1) = (-xhi)**n*exp_rab2*sr_int - dtemp(2) = REAL(n, dp)*(-xhi)**(n-1)*exp_rab2*dsr_int(1) - dtemp(3) = REAL(n**2-n, dp)/2.0_dp*(-xhi)**(n-2) & - *exp_rab2*dsr_int(2) - dtemp(4) = REAL(n*(n-1)*(n-2), dp)*(-xhi)**(n-3)*k*exp_rab2 - s(ipgfa, jpgfb, kpgfx, il, ids) = dtemp(1)+dtemp(2) & - +dtemp(3)+dtemp(4) - ENDDO - CASE (4) - ![s|r^8|s] integral - prefac = sqrt_pi3/16.0_dp/sqrt_zet**11 - temp = 945.0_dp+2520.0_dp*pfac*rab2+1512.0_dp*(pfac*rab2)**2 - temp = temp+288.0_dp*(pfac*rab2)**3+16.0_dp*(pfac*rab2)**4 - sr_int = prefac*temp - s(ipgfa, jpgfb, kpgfx, il, 1) = exp_rab2*sr_int - !** derivatives - k = sqrt_pi3*x**8/sqrt_zet**19 - dsr_int(1) = 2520.0_dp*pfac+3024.0_dp*pfac**2*rab2 - dsr_int(1) = dsr_int(1)+864.0_dp*pfac**3*rab2**2 & - +64.0_dp*pfac**4*rab2**3 - dsr_int(1) = prefac*dsr_int(1) - dsr_int(2) = 3024.0_dp*pfac**2+1728.0_dp*pfac**3*rab2 - dsr_int(2) = dsr_int(2)+192.0_dp*pfac**4*rab2**2 - dsr_int(2) = prefac*dsr_int(2) - dsr_int(3) = 1728.0_dp*pfac**3+384.0_dp*pfac**4*rab2 - dsr_int(3) = prefac*dsr_int(3) - DO ids = 2, nds - n = ids-1 - dtemp(1) = (-xhi)**n*exp_rab2*sr_int - dtemp(2) = REAL(n, dp)*(-xhi)**(n-1)*exp_rab2*dsr_int(1) - dtemp(3) = REAL(n**2-n, dp)/2.0_dp*(-xhi)**(n-2) & - *exp_rab2*dsr_int(2) - dtemp(4) = REAL(n*(n-1)*(n-2), dp)/6.0_dp*(-xhi)**(n-3) & - *exp_rab2*dsr_int(3) - dtemp(5) = REAL(n*(n-1)*(n-2)*(n-3), dp)*(-xhi)**(n-4) & - *k*exp_rab2 - s(ipgfa, jpgfb, kpgfx, il, ids) = dtemp(1)+dtemp(2)+dtemp(3) & - +dtemp(4)+dtemp(5) - ENDDO - CASE (5) - ![s|r^10|s] integral - prefac = sqrt_pi3/32.0_dp/sqrt_zet**13 - temp = 10395.0_dp+34650.0_dp*pfac*rab2 - temp = temp+27720.0_dp*(pfac*rab2)**2+7920.0_dp*(pfac*rab2)**3 - temp = temp+880.0_dp*(pfac*rab2)**4+32.0_dp*(pfac*rab2)**5 - sr_int = prefac*temp - s(ipgfa, jpgfb, kpgfx, il, 1) = exp_rab2*sr_int - !** derivatives - k = sqrt_pi3*x**10/sqrt_zet**23 - dsr_int(1) = 34650.0_dp*pfac+55440.0_dp*pfac**2*rab2 - dsr_int(1) = dsr_int(1)+23760.0_dp*pfac**3*rab2**2 - dsr_int(1) = dsr_int(1)+3520.0_dp*pfac**4*rab2**3 - dsr_int(1) = dsr_int(1)+160.0_dp*pfac**5*rab2**4 - dsr_int(1) = prefac*dsr_int(1) - dsr_int(2) = 55440.0_dp*pfac**2+47520.0_dp*pfac**3*rab2 - dsr_int(2) = dsr_int(2)+10560.0_dp*pfac**4*rab2**2 - dsr_int(2) = dsr_int(2)+640.0_dp*pfac**5*rab2**3 - dsr_int(2) = prefac*dsr_int(2) - dsr_int(3) = 47520.0_dp*pfac**3+21120.0_dp*pfac**4*rab2 - dsr_int(3) = dsr_int(3)+1920.0_dp*pfac**5*rab2**2 - dsr_int(3) = prefac*dsr_int(3) - dsr_int(4) = 21120.0_dp*pfac**4+3840.0_dp*pfac**5*rab2 - dsr_int(4) = prefac*dsr_int(4) - DO ids = 2, nds - n = ids-1 - dtemp(1) = (-xhi)**n*exp_rab2*sr_int - dtemp(2) = REAL(n, dp)*(-xhi)**(n-1)*exp_rab2*dsr_int(1) - dtemp(3) = REAL(n**2-n, dp)/2.0_dp*(-xhi)**(n-2) & - *exp_rab2*dsr_int(2) - dtemp(4) = REAL(n*(n-1)*(n-2), dp)/6.0_dp*(-xhi)**(n-3) & - *exp_rab2*dsr_int(3) - dtemp(5) = REAL(n*(n-1)*(n-2)*(n-3), dp)/24.0_dp*(-xhi)**(n-4) & - *exp_rab2*dsr_int(4) - dtemp(6) = REAL(n*(n-1)*(n-2)*(n-3)*(n-4), dp)*(-xhi)**(n-5) & - *k*exp_rab2 - s(ipgfa, jpgfb, kpgfx, il, ids) = dtemp(1)+dtemp(2)+dtemp(3) & - +dtemp(4)+dtemp(5)+dtemp(6) - ENDDO - CASE DEFAULT - CALL cp_abort(__LOCATION__, & - "SHG integrals not implemented when sum of l quantum"// & - " number of orbital and ri basis larger than 11") - END SELECT - - ENDDO - - END DO - END DO - END DO - - DEALLOCATE (dtemp, dsr_int) - - CALL timestop(handle) - - END SUBROUTINE s_overlap_abx - -! ************************************************************************************************** -!> \brief computes the real scaled solid harmonics Rlm up to a given l -!> \param Rlm_c cosine part of real scaled soldi harmonics -!> \param Rlm_s sine part of real scaled soldi harmonics -!> \param l maximal l quantum up to where Rlm is calculated -!> \param r distance vector between a and b -!> \param r2 square of distance vector -! ************************************************************************************************** - SUBROUTINE get_real_scaled_solid_harmonic(Rlm_c, Rlm_s, l, r, r2) - - INTEGER, INTENT(IN) :: l - REAL(KIND=dp), DIMENSION(0:l, -2*l:2*l), & - INTENT(OUT) :: Rlm_s, Rlm_c - REAL(KIND=dp), DIMENSION(3) :: r - REAL(KIND=dp) :: r2 - - CHARACTER(len=*), PARAMETER :: routineN = 'get_real_scaled_solid_harmonic', & - routineP = moduleN//':'//routineN - - INTEGER :: handle, li, mi, prefac - REAL(KIND=dp) :: Rc, Rc_00, Rlm, Rmlm, Rplm, Rs, Rs_00, & - temp_c - - CALL timeset(routineN, handle) - - Rc_00 = 1.0_dp - Rs_00 = 0.0_dp - - Rlm_c(0, 0) = Rc_00 - Rlm_s(0, 0) = Rs_00 - - ! generate elements Rmm - ! start - IF (l > 0) THEN - Rc = -0.5_dp*r(1)*Rc_00 - Rs = -0.5_dp*r(2)*Rc_00 - Rlm_c(1, 1) = Rc - Rlm_s(1, 1) = Rs - Rlm_c(1, -1) = -Rc - Rlm_s(1, -1) = Rs - ENDIF - DO li = 2, l - temp_c = (-r(1)*Rc+r(2)*Rs)/(REAL(2*(li-1)+2, dp)) - Rs = (-r(2)*Rc-r(1)*Rs)/(REAL(2*(li-1)+2, dp)) - Rc = temp_c - Rlm_c(li, li) = Rc - Rlm_s(li, li) = Rs - IF (MODULO(li, 2) /= 0) THEN - Rlm_c(li, -li) = -Rc - Rlm_s(li, -li) = Rs - ELSE - Rlm_c(li, -li) = Rc - Rlm_s(li, -li) = -Rs - ENDIF - ENDDO - - DO mi = 0, l-1 - Rmlm = Rlm_c(mi, mi) - Rlm = r(3)*Rlm_c(mi, mi) - Rlm_c(mi+1, mi) = Rlm - IF (MODULO(mi, 2) /= 0) THEN - Rlm_c(mi+1, -mi) = -Rlm - ELSE - Rlm_c(mi+1, -mi) = Rlm - ENDIF - DO li = mi+2, l - prefac = (li+mi)*(li-mi) - Rplm = (REAL(2*li-1, dp)*r(3)*Rlm-r2*Rmlm)/REAL(prefac, dp) - Rmlm = Rlm - Rlm = Rplm - Rlm_c(li, mi) = Rlm - IF (MODULO(mi, 2) /= 0) THEN - Rlm_c(li, -mi) = -Rlm - ELSE - Rlm_c(li, -mi) = Rlm - ENDIF - ENDDO - ENDDO - DO mi = 1, l-1 - Rmlm = Rlm_s(mi, mi) - Rlm = r(3)*Rlm_s(mi, mi) - Rlm_s(mi+1, mi) = Rlm - IF (MODULO(mi, 2) /= 0) THEN - Rlm_s(mi+1, -mi) = Rlm - ELSE - Rlm_s(mi+1, -mi) = -Rlm - ENDIF - DO li = mi+2, l - prefac = (li+mi)*(li-mi) - Rplm = (REAL(2*li-1, dp)*r(3)*Rlm-r2*Rmlm)/REAL(prefac, dp) - Rmlm = Rlm - Rlm = Rplm - Rlm_s(li, mi) = Rlm - IF (MODULO(mi, 2) /= 0) THEN - Rlm_s(li, -mi) = Rlm - ELSE - Rlm_s(li, -mi) = -Rlm - ENDIF - ENDDO - ENDDO - - CALL timestop(handle) - - END SUBROUTINE get_real_scaled_solid_harmonic - -! ************************************************************************************************** -!> \brief calculates the angular dependent-part of the SHG integrals, -!> transformation matrix W, see literature above -!> \param lamax array of maximal l quantum number on a; -!> lamax(lb) with lb= 0..lbmax -!> \param lbmax maximal l quantum number on b -!> \param lmax maximal l quantum number -!> \param Rc cosine part of real scaled solid harmonics -!> \param Rs sine part of real scaled solid harmonics -!> \param Waux_mat stores the angular-dependent part of the SHG integrals -!> last dimension is (1:4): cc(1), cs(2), sc(3), ss(4) -! ************************************************************************************************** - SUBROUTINE get_W_matrix(lamax, lbmax, lmax, Rc, Rs, Waux_mat) - - INTEGER, DIMENSION(:), POINTER :: lamax - INTEGER, INTENT(IN) :: lbmax, lmax - REAL(KIND=dp), DIMENSION(0:lmax, -2*lmax:2*lmax), & - INTENT(IN) :: Rc, Rs - REAL(KIND=dp), DIMENSION(:, :, :, :), POINTER :: Waux_mat - - CHARACTER(len=*), PARAMETER :: routineN = 'get_W_matrix', routineP = moduleN//':'//routineN - - INTEGER :: handle, j, k, la, labmin, laj, lb, lbj, & - ma, ma_m, ma_p, mb, mb_m, mb_p, nla, & - nlb - REAL(KIND=dp) :: A_jk, A_lama, A_lbmb, Alm_fac, delta_k, prefac, Rca_m, Rca_p, Rcb_m, Rcb_p, & - Rsa_m, Rsa_p, Rsb_m, Rsb_p, sign_fac, Wa(4), Wb(4), Wmat(4) - - CALL timeset(routineN, handle) - - Wa(:) = 0.0_dp - Wb(:) = 0.0_dp - Wmat(:) = 0.0_dp - - DO lb = 0, lbmax - nlb = nsoset_pm(lb-1) - DO la = 0, lamax(lb) - nla = nsoset_pm(la-1) - labmin = MIN(la, lb) - DO mb = 0, lb - A_lbmb = SQRT(fac(lb+mb)*fac(lb-mb)) - IF (MODULO(mb, 2) /= 0) A_lbmb = -A_lbmb - IF (mb /= 0) A_lbmb = A_lbmb*SQRT(2.0_dp) - IF (MODULO(lb, 2) /= 0) A_lbmb = -A_lbmb - DO ma = 0, la - A_lama = SQRT(fac(la+ma)*fac(la-ma)) - IF (MODULO(ma, 2) /= 0) A_lama = -A_lama - IF (ma /= 0) A_lama = A_lama*SQRT(2.0_dp) - Alm_fac = A_lama*A_lbmb - DO j = 0, labmin - laj = la-j - lbj = lb-j - prefac = Alm_fac*REAL(2**(la+lb-j), dp)*dfac(2*j-1) - delta_k = 0.5_dp - Wmat = 0.0_dp - DO k = 0, j - ma_m = ma-k - ma_p = ma+k - IF (laj < ABS(ma_m) .AND. laj < ABS(ma_p)) CYCLE - mb_m = mb-k - mb_p = mb+k - IF (lbj < ABS(mb_m) .AND. lbj < ABS(mb_p)) CYCLE - IF (k /= 0) delta_k = 1.0_dp - A_jk = fac(j+k)*fac(j-k) - IF (k /= 0) A_jk = 2.0_dp*A_jk - IF (MODULO(k, 2) /= 0) THEN - sign_fac = -1.0_dp - ELSE - sign_fac = 1.0_dp - ENDIF - Rca_m = Rc(laj, ma_m) - Rsa_m = Rs(laj, ma_m) - Rca_p = Rc(laj, ma_p) - Rsa_p = Rs(laj, ma_p) - Rcb_m = Rc(lbj, mb_m) - Rsb_m = Rs(lbj, mb_m) - Rcb_p = Rc(lbj, mb_p) - Rsb_p = Rs(lbj, mb_p) - Wa(1) = delta_k*(Rca_m+sign_fac*Rca_p) - Wb(1) = delta_k*(Rcb_m+sign_fac*Rcb_p) - Wa(2) = -Rsa_m+sign_fac*Rsa_p - Wb(2) = -Rsb_m+sign_fac*Rsb_p - Wmat(1) = Wmat(1)+prefac/A_jk*(Wa(1)*Wb(1)+Wa(2)*Wb(2)) - IF (mb > 0) THEN - Wb(3) = delta_k*(Rsb_m+sign_fac*Rsb_p) - Wb(4) = Rcb_m-sign_fac*Rcb_p - Wmat(2) = Wmat(2)+prefac/A_jk*(Wa(1)*Wb(3)+Wa(2)*Wb(4)) - ENDIF - IF (ma > 0) THEN - Wa(3) = delta_k*(Rsa_m+sign_fac*Rsa_p) - Wa(4) = Rca_m-sign_fac*Rca_p - Wmat(3) = Wmat(3)+prefac/A_jk*(Wa(3)*Wb(1)+Wa(4)*Wb(2)) - ENDIF - IF (ma > 0 .AND. mb > 0) THEN - Wmat(4) = Wmat(4)+prefac/A_jk*(Wa(3)*Wb(3)+Wa(4)*Wb(4)) - ENDIF - ENDDO - Waux_mat(nla+ma+1, nlb+mb+1, j+1, 1) = Wmat(1) - IF (mb > 0) Waux_mat(nla+ma+1, nlb+mb+1, j+1, 2) = Wmat(2) - IF (ma > 0) Waux_mat(nla+ma+1, nlb+mb+1, j+1, 3) = Wmat(3) - IF (ma > 0 .AND. mb > 0) Waux_mat(nla+ma+1, nlb+mb+1, j+1, 4) = Wmat(4) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - - CALL timestop(handle) - - END SUBROUTINE get_W_matrix - -! ************************************************************************************************** -!> \brief calculates derivatives of transformation matrix W, -!> \param lamax array of maximal l quantum number on a; -!> lamax(lb) with lb= 0..lbmax -!> \param lbmax maximal l quantum number on b -!> \param Waux_mat stores the angular-dependent part of the SHG integrals -!> \param dWaux_mat stores the derivatives of the angular-dependent part of -!> the SHG integrals -!> last dimension is (1:4): cc(1), cs(2), sc(3), ss(4) -! ************************************************************************************************** - SUBROUTINE get_dW_matrix(lamax, lbmax, Waux_mat, dWaux_mat) - - INTEGER, DIMENSION(:), POINTER :: lamax - INTEGER, INTENT(IN) :: lbmax - REAL(KIND=dp), DIMENSION(:, :, :, :), POINTER :: Waux_mat - REAL(KIND=dp), DIMENSION(:, :, :, :, :), POINTER :: dWaux_mat - - CHARACTER(len=*), PARAMETER :: routineN = 'get_dW_matrix', routineP = moduleN//':'//routineN - - INTEGER :: handle, ia, iam, ib, ibm, j, jmax, la, & - labm, labmin, lamb, lb, ma, mb, nla, & - nlam, nlb, nlbm - REAL(KIND=dp) :: bma, bma_m, bma_p, bmb, bmb_m, bmb_p, & - dAa, dAa_m, dAa_p, dAb, dAb_m, dAb_p - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: Wam, Wamm, Wamp, Wbm, Wbmm, Wbmp - - CALL timeset(routineN, handle) - - jmax = MIN(MAXVAL(lamax), lbmax) - ALLOCATE (Wam(0:jmax, 4), Wamm(0:jmax, 4), Wamp(0:jmax, 4)) - ALLOCATE (Wbm(0:jmax, 4), Wbmm(0:jmax, 4), Wbmp(0:jmax, 4)) - - DO lb = 0, lbmax - nlb = nsoset_pm(lb-1) - nlbm = 0 - IF (lb > 0) nlbm = nsoset_pm(lb-2) - DO la = 0, lamax(lb) - nla = nsoset_pm(la-1) - nlam = 0 - IF (la > 0) nlam = nsoset_pm(la-2) - labmin = MIN(la, lb) - lamb = MIN(la-1, lb) - labm = MIN(la, lb-1) - DO mb = 0, lb - bmb = 1.0_dp - bmb_m = 1.0_dp - bmb_p = 1.0_dp - IF (mb /= 0) bmb = SQRT(2.0_dp) - IF (mb-1 /= 0) bmb_m = SQRT(2.0_dp) - IF (mb+1 /= 0) bmb_p = SQRT(2.0_dp) - dAb_p = -bmb/bmb_p*SQRT(REAL((lb-mb)*(lb-mb-1), dp)) - dAb_m = -bmb/bmb_m*SQRT(REAL((lb+mb)*(lb+mb-1), dp)) - dAb = 2.0_dp*SQRT(REAL((lb+mb)*(lb-mb), dp)) - !*** for m=0 W_l-1,-1 can't be read from Waux_mat, but we use - !*** W_l-1,-1 = -W_l-1,1 [cc(1), cs(2)] or W_l-1,-1 = W_l-1,1 [[sc(3), ss(4)] - IF (mb == 0) dAb_p = 2.0_dp*dAb_p - ib = nlb+mb+1 - ibm = nlbm+mb+1 - DO ma = 0, la - bma = 1.0_dp - bma_m = 1.0_dp - bma_p = 1.0_dp - IF (ma /= 0) bma = SQRT(2.0_dp) - IF (ma-1 /= 0) bma_m = SQRT(2.0_dp) - IF (ma+1 /= 0) bma_p = SQRT(2.0_dp) - dAa_p = -bma/bma_p*SQRT(REAL((la-ma)*(la-ma-1), dp)) - dAa_m = -bma/bma_m*SQRT(REAL((la+ma)*(la+ma-1), dp)) - dAa = 2.0_dp*SQRT(REAL((la+ma)*(la-ma), dp)) - IF (ma == 0) dAa_p = 2.0_dp*dAa_p - ia = nla+ma+1 - iam = nlam+ma+1 - Wam(:, :) = 0.0_dp - Wamm(:, :) = 0.0_dp - Wamp(:, :) = 0.0_dp - !*** Wam: la-1, ma - IF (ma <= la-1) THEN - Wam(0:lamb, 1) = Waux_mat(iam, ib, 1:lamb+1, 1) - IF (mb > 0) Wam(0:lamb, 2) = Waux_mat(iam, ib, 1:lamb+1, 2) - IF (ma > 0) Wam(0:lamb, 3) = Waux_mat(iam, ib, 1:lamb+1, 3) - IF (ma > 0 .AND. mb > 0) Wam(0:lamb, 4) = Waux_mat(iam, ib, 1:lamb+1, 4) - ENDIF - !*** Wamm: la-1, ma-1 - IF (ma-1 >= 0) THEN - Wamm(0:lamb, 1) = Waux_mat(iam-1, ib, 1:lamb+1, 1) - IF (mb > 0) Wamm(0:lamb, 2) = Waux_mat(iam-1, ib, 1:lamb+1, 2) - IF (ma-1 > 0) Wamm(0:lamb, 3) = Waux_mat(iam-1, ib, 1:lamb+1, 3) - IF (ma-1 > 0 .AND. mb > 0) Wamm(0:lamb, 4) = Waux_mat(iam-1, ib, 1:lamb+1, 4) - ENDIF - !*** Wamp: la-1, ma+1 - IF (ma+1 <= la-1) THEN - Wamp(0:lamb, 1) = Waux_mat(iam+1, ib, 1:lamb+1, 1) - IF (mb > 0) Wamp(0:lamb, 2) = Waux_mat(iam+1, ib, 1:lamb+1, 2) - IF (ma+1 > 0) Wamp(0:lamb, 3) = Waux_mat(iam+1, ib, 1:lamb+1, 3) - IF (ma+1 > 0 .AND. mb > 0) Wamp(0:lamb, 4) = Waux_mat(iam+1, ib, 1:lamb+1, 4) - ENDIF - Wbm(:, :) = 0.0_dp - Wbmm(:, :) = 0.0_dp - Wbmp(:, :) = 0.0_dp - !*** Wbm: lb-1, mb - IF (mb <= lb-1) THEN - Wbm(0:labm, 1) = Waux_mat(ia, ibm, 1:labm+1, 1) - IF (mb > 0) Wbm(0:labm, 2) = Waux_mat(ia, ibm, 1:labm+1, 2) - IF (ma > 0) Wbm(0:labm, 3) = Waux_mat(ia, ibm, 1:labm+1, 3) - IF (ma > 0 .AND. mb > 0) Wbm(0:labm, 4) = Waux_mat(ia, ibm, 1:labm+1, 4) - ENDIF - !*** Wbmm: lb-1, mb-1 - IF (mb-1 >= 0) THEN - Wbmm(0:labm, 1) = Waux_mat(ia, ibm-1, 1:labm+1, 1) - IF (mb-1 > 0) Wbmm(0:labm, 2) = Waux_mat(ia, ibm-1, 1:labm+1, 2) - IF (ma > 0) Wbmm(0:labm, 3) = Waux_mat(ia, ibm-1, 1:labm+1, 3) - IF (ma > 0 .AND. mb-1 > 0) Wbmm(0:labm, 4) = Waux_mat(ia, ibm-1, 1:labm+1, 4) - ENDIF - !*** Wbmp: lb-1, mb+1 - IF (mb+1 <= lb-1) THEN - Wbmp(0:labm, 1) = Waux_mat(ia, ibm+1, 1:labm+1, 1) - IF (mb+1 > 0) Wbmp(0:labm, 2) = Waux_mat(ia, ibm+1, 1:labm+1, 2) - IF (ma > 0) Wbmp(0:labm, 3) = Waux_mat(ia, ibm+1, 1:labm+1, 3) - IF (ma > 0 .AND. mb+1 > 0) Wbmp(0:labm, 4) = Waux_mat(ia, ibm+1, 1:labm+1, 4) - ENDIF - DO j = 0, labmin - !*** x component - dWaux_mat(1, ia, ib, j+1, 1) = dAa_p*Wamp(j, 1)-dAa_m*Wamm(j, 1) & - -dAb_p*Wbmp(j, 1)+dAb_m*Wbmm(j, 1) - IF (mb > 0) THEN - dWaux_mat(1, ia, ib, j+1, 2) = dAa_p*Wamp(j, 2)-dAa_m*Wamm(j, 2) & - -dAb_p*Wbmp(j, 2)+dAb_m*Wbmm(j, 2) - ENDIF - IF (ma > 0) THEN - dWaux_mat(1, ia, ib, j+1, 3) = dAa_p*Wamp(j, 3)-dAa_m*Wamm(j, 3) & - -dAb_p*Wbmp(j, 3)+dAb_m*Wbmm(j, 3) - ENDIF - IF (ma > 0 .AND. mb > 0) THEN - dWaux_mat(1, ia, ib, j+1, 4) = dAa_p*Wamp(j, 4)-dAa_m*Wamm(j, 4) & - -dAb_p*Wbmp(j, 4)+dAb_m*Wbmm(j, 4) - ENDIF - !**** y component - dWaux_mat(2, ia, ib, j+1, 1) = dAa_p*Wamp(j, 3)+dAa_m*Wamm(j, 3) & - -dAb_p*Wbmp(j, 2)-dAb_m*Wbmm(j, 2) - IF (mb > 0) THEN - dWaux_mat(2, ia, ib, j+1, 2) = dAa_p*Wamp(j, 4)+dAa_m*Wamm(j, 4) & - +dAb_p*Wbmp(j, 1)+dAb_m*Wbmm(j, 1) - ENDIF - IF (ma > 0) THEN - dWaux_mat(2, ia, ib, j+1, 3) = -dAa_p*Wamp(j, 1)-dAa_m*Wamm(j, 1) & - -dAb_p*Wbmp(j, 4)-dAb_m*Wbmm(j, 4) - ENDIF - IF (ma > 0 .AND. mb > 0) THEN - dWaux_mat(2, ia, ib, j+1, 4) = -dAa_p*Wamp(j, 2)-dAa_m*Wamm(j, 2) & - +dAb_p*Wbmp(j, 3)+dAb_m*Wbmm(j, 3) - ENDIF - !**** z compnent - dWaux_mat(3, ia, ib, j+1, 1) = dAa*Wam(j, 1)-dAb*Wbm(j, 1) - IF (mb > 0) THEN - dWaux_mat(3, ia, ib, j+1, 2) = dAa*Wam(j, 2)-dAb*Wbm(j, 2) - ENDIF - IF (ma > 0) THEN - dWaux_mat(3, ia, ib, j+1, 3) = dAa*Wam(j, 3)-dAb*Wbm(j, 3) - ENDIF - IF (ma > 0 .AND. mb > 0) THEN - dWaux_mat(3, ia, ib, j+1, 4) = dAa*Wam(j, 4)-dAb*Wbm(j, 4) - ENDIF - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - - DEALLOCATE (Wam, Wamm, Wamp) - DEALLOCATE (Wbm, Wbmm, Wbmp) - - CALL timestop(handle) - - END SUBROUTINE get_dW_matrix - -! ************************************************************************************************** -!> \brief calculates [ab] SHG overlap integrals using precomputed angular- -!> dependent part -!> \param la set of l quantum number on a -!> \param first_sgfa indexing -!> \param nshella number of shells for a -!> \param lb set of l quantum number on b -!> \param first_sgfb indexing -!> \param nshellb number of shells for b -!> \param swork_cont contracted and normalized [s|s] integrals -!> \param Waux_mat precomputed angular-dependent part -!> \param sab contracted overlap of spherical harmonic Gaussians -! ************************************************************************************************** - SUBROUTINE overlap_shg_ab(la, first_sgfa, nshella, lb, first_sgfb, nshellb, & - swork_cont, Waux_mat, sab) - - INTEGER, DIMENSION(:), INTENT(IN) :: la, first_sgfa - INTEGER, INTENT(IN) :: nshella - INTEGER, DIMENSION(:), INTENT(IN) :: lb, first_sgfb - INTEGER, INTENT(IN) :: nshellb - REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: swork_cont - REAL(KIND=dp), DIMENSION(:, :, :, :), INTENT(IN) :: Waux_mat - REAL(KIND=dp), DIMENSION(:, :), INTENT(INOUT) :: sab - - CHARACTER(len=*), PARAMETER :: routineN = 'overlap_shg_ab', routineP = moduleN//':'//routineN - - INTEGER :: handle, ia, iaa, ishella, j, jb, jbb, & - jshellb, labmin, lai, lbj, mai, mbj, & - nla, nlb, sgfa, sgfb - REAL(KIND=dp) :: prefac - - CALL timeset(routineN, handle) - - DO ishella = 1, nshella - lai = la(ishella) - nla = nsoset_pm(lai-1) - sgfa = first_sgfa(ishella) - ia = sgfa+lai - DO jshellb = 1, nshellb - lbj = lb(jshellb) - nlb = nsoset_pm(lbj-1) - sgfb = first_sgfb(jshellb) - jb = sgfb+lbj - labmin = MIN(lai, lbj) - DO j = 0, labmin - prefac = swork_cont(ishella, jshellb, lai+lbj-j+1) - ! mai = 0 and mbj = 0 - iaa = nla+1 - jbb = nlb+1 - sab(ia, jb) = sab(ia, jb)+prefac*Waux_mat(iaa, jbb, j+1, 1) - ! mai = 0 and mbj /= 0 - DO mbj = 1, lbj - jbb = nlb+mbj+1 - sab(ia, jb+mbj) = sab(ia, jb+mbj)+prefac*Waux_mat(iaa, jbb, j+1, 1) - sab(ia, jb-mbj) = sab(ia, jb-mbj)+prefac*Waux_mat(iaa, jbb, j+1, 2) - ENDDO - ! mai /= 0 and mbj = 0 - jbb = nlb+1 - DO mai = 1, lai - iaa = nla+mai+1 - sab(ia+mai, jb) = sab(ia+mai, jb)+prefac*Waux_mat(iaa, jbb, j+1, 1) - sab(ia-mai, jb) = sab(ia-mai, jb)+prefac*Waux_mat(iaa, jbb, j+1, 3) - ENDDO - ! mai /= 0 and mbj /= 0 - DO mai = 1, lai - iaa = nla+mai+1 - DO mbj = 1, lbj - jbb = nlb+mbj+1 - sab(ia+mai, jb+mbj) = sab(ia+mai, jb+mbj)+prefac*Waux_mat(iaa, jbb, j+1, 1) - sab(ia+mai, jb-mbj) = sab(ia+mai, jb-mbj)+prefac*Waux_mat(iaa, jbb, j+1, 2) - sab(ia-mai, jb+mbj) = sab(ia-mai, jb+mbj)+prefac*Waux_mat(iaa, jbb, j+1, 3) - sab(ia-mai, jb-mbj) = sab(ia-mai, jb-mbj)+prefac*Waux_mat(iaa, jbb, j+1, 4) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - - CALL timestop(handle) - - END SUBROUTINE overlap_shg_ab - -! ************************************************************************************************** -!> \brief calculates derivatives of [ab] SHG overlap integrals using precomputed -!> angular-dependent part -!> \param la set of l quantum number on a -!> \param first_sgfa indexing -!> \param nshella number of shells for a -!> \param lb set of l quantum number on b -!> \param first_sgfb indexing -!> \param nshellb number of shells for b -!> \param rab distance vector Ra-Rb -!> \param swork_cont contracted and normalized [s|s] integrals -!> \param Waux_mat precomputed angular-dependent part -!> \param dWaux_mat derivatives of precomputed angular-dependent part -!> \param dsab derivative of contracted overlap of spherical harmonic Gaussians -! ************************************************************************************************** - SUBROUTINE dev_overlap_shg_ab(la, first_sgfa, nshella, lb, first_sgfb, nshellb, rab, & - swork_cont, Waux_mat, dWaux_mat, dsab) - - INTEGER, DIMENSION(:), INTENT(IN) :: la, first_sgfa - INTEGER, INTENT(IN) :: nshella - INTEGER, DIMENSION(:), INTENT(IN) :: lb, first_sgfb - INTEGER, INTENT(IN) :: nshellb - REAL(KIND=dp), INTENT(IN) :: rab(3) - REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: swork_cont - REAL(KIND=dp), DIMENSION(:, :, :, :), INTENT(IN) :: Waux_mat - REAL(KIND=dp), DIMENSION(:, :, :, :, :), & - INTENT(IN) :: dWaux_mat - REAL(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: dsab - - CHARACTER(len=*), PARAMETER :: routineN = 'dev_overlap_shg_ab', & - routineP = moduleN//':'//routineN - - INTEGER :: handle, i, ia, iaa, ishella, j, jb, jbb, & - jshellb, labmin, lai, lbj, mai, mbj, & - nla, nlb, sgfa, sgfb - REAL(KIND=dp) :: dprefac, prefac, rabx2(3) - - CALL timeset(routineN, handle) - - rabx2(:) = 2.0_dp*rab - DO ishella = 1, nshella - lai = la(ishella) - nla = nsoset_pm(lai-1) - sgfa = first_sgfa(ishella) - ia = sgfa+lai - DO jshellb = 1, nshellb - lbj = lb(jshellb) - nlb = nsoset_pm(lbj-1) - sgfb = first_sgfb(jshellb) - jb = sgfb+lbj - labmin = MIN(lai, lbj) - DO j = 0, labmin - prefac = swork_cont(ishella, jshellb, lai+lbj-j+1) - dprefac = swork_cont(ishella, jshellb, lai+lbj-j+2) !j+1 - ! mai = 0 and mbj = 0 - iaa = nla+1 - jbb = nlb+1 - DO i = 1, 3 - dsab(ia, jb, i) = dsab(ia, jb, i)+rabx2(i)*dprefac*Waux_mat(iaa, jbb, j+1, 1) & - +prefac*dWaux_mat(i, iaa, jbb, j+1, 1) - ENDDO - ! mai = 0 and mbj /= 0 - DO mbj = 1, lbj - jbb = nlb+mbj+1 - DO i = 1, 3 - dsab(ia, jb+mbj, i) = dsab(ia, jb+mbj, i)+rabx2(i)*dprefac*Waux_mat(iaa, jbb, j+1, 1) & - +prefac*dWaux_mat(i, iaa, jbb, j+1, 1) - dsab(ia, jb-mbj, i) = dsab(ia, jb-mbj, i)+rabx2(i)*dprefac*Waux_mat(iaa, jbb, j+1, 2) & - +prefac*dWaux_mat(i, iaa, jbb, j+1, 2) - ENDDO - ENDDO - ! mai /= 0 and mbj = 0 - jbb = nlb+1 - DO mai = 1, lai - iaa = nla+mai+1 - DO i = 1, 3 - dsab(ia+mai, jb, i) = dsab(ia+mai, jb, i)+rabx2(i)*dprefac*Waux_mat(iaa, jbb, j+1, 1) & - +prefac*dWaux_mat(i, iaa, jbb, j+1, 1) - dsab(ia-mai, jb, i) = dsab(ia-mai, jb, i)+rabx2(i)*dprefac*Waux_mat(iaa, jbb, j+1, 3) & - +prefac*dWaux_mat(i, iaa, jbb, j+1, 3) - ENDDO - ENDDO - ! mai /= 0 and mbj /= 0 - DO mai = 1, lai - iaa = nla+mai+1 - DO mbj = 1, lbj - jbb = nlb+mbj+1 - DO i = 1, 3 - dsab(ia+mai, jb+mbj, i) = dsab(ia+mai, jb+mbj, i)+rabx2(i)*dprefac*Waux_mat(iaa, jbb, j+1, 1) & - +prefac*dWaux_mat(i, iaa, jbb, j+1, 1) - dsab(ia+mai, jb-mbj, i) = dsab(ia+mai, jb-mbj, i)+rabx2(i)*dprefac*Waux_mat(iaa, jbb, j+1, 2) & - +prefac*dWaux_mat(i, iaa, jbb, j+1, 2) - dsab(ia-mai, jb+mbj, i) = dsab(ia-mai, jb+mbj, i)+rabx2(i)*dprefac*Waux_mat(iaa, jbb, j+1, 3) & - +prefac*dWaux_mat(i, iaa, jbb, j+1, 3) - dsab(ia-mai, jb-mbj, i) = dsab(ia-mai, jb-mbj, i)+rabx2(i)*dprefac*Waux_mat(iaa, jbb, j+1, 4) & - +prefac*dWaux_mat(i, iaa, jbb, j+1, 4) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - - CALL timestop(handle) - - END SUBROUTINE dev_overlap_shg_ab - -! ************************************************************************************************** -!> \brief calculates [aba] SHG overlap integrals using precomputed angular- -!> dependent part -!> \param la set of l quantum number on a, orbital basis -!> \param first_sgfa indexing -!> \param nshella number of shells for a, orbital basis -!> \param lb set of l quantum number on b. orbital basis -!> \param first_sgfb indexing -!> \param nshellb number of shells for b, orbital basis -!> \param lca of l quantum number on a, aux basis -!> \param first_sgfca indexing -!> \param nshellca number of shells for a, aux basis -!> \param cg_coeff Clebsch-Gordon coefficients -!> \param cg_none0_list list of none-zero Clebsch-Gordon coefficients -!> \param ncg_none0 number of non-zero Clebsch-Gordon coefficients -!> \param swork_cont contracted and normalized [s|ra^n|s] integrals -!> \param Waux_mat precomputed angular-dependent part -!> \param saba contracted overlap [aba] of spherical harmonic Gaussians -! ************************************************************************************************** - SUBROUTINE overlap_shg_aba(la, first_sgfa, nshella, lb, first_sgfb, nshellb, & - lca, first_sgfca, nshellca, cg_coeff, cg_none0_list, & - ncg_none0, swork_cont, Waux_mat, saba) - - INTEGER, DIMENSION(:), INTENT(IN) :: la, first_sgfa - INTEGER, INTENT(IN) :: nshella - INTEGER, DIMENSION(:), INTENT(IN) :: lb, first_sgfb - INTEGER, INTENT(IN) :: nshellb - INTEGER, DIMENSION(:), INTENT(IN) :: lca, first_sgfca - INTEGER, INTENT(IN) :: nshellca - REAL(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: cg_coeff - INTEGER, DIMENSION(:, :, :), INTENT(IN) :: cg_none0_list - INTEGER, DIMENSION(:, :), INTENT(IN) :: ncg_none0 - REAL(KIND=dp), DIMENSION(:, :, :, :, :), POINTER :: swork_cont - REAL(KIND=dp), DIMENSION(:, :, :, :), INTENT(IN) :: Waux_mat - REAL(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: saba - - CHARACTER(len=*), PARAMETER :: routineN = 'overlap_shg_aba', & - routineP = moduleN//':'//routineN - - INTEGER :: handle, ia, il, ilist, ishella, isoa1, isoa2, isoaa, j, jb, jshellb, ka, kshella, & - laa, labmin, lai, lak, lbj, maa, mai, mak, mbj, nla, nlb, sgfa, sgfb, sgfca - REAL(KIND=dp) :: prefac, stemp - - CALL timeset(routineN, handle) - - DO ishella = 1, nshella - lai = la(ishella) - sgfa = first_sgfa(ishella) - ia = sgfa+lai - DO jshellb = 1, nshellb - lbj = lb(jshellb) - nlb = nsoset_pm(lbj-1) - sgfb = first_sgfb(jshellb) - jb = sgfb+lbj - DO kshella = 1, nshellca - lak = lca(kshella) - sgfca = first_sgfca(kshella) - ka = sgfca+lak - DO mai = -lai, lai, 1 - DO mbj = -lbj, lbj, 1 - DO mak = -lak, lak, 1 - isoa1 = indso_inv(lai, mai) - isoa2 = indso_inv(lak, mak) - DO ilist = 1, ncg_none0(isoa1, isoa2) - isoaa = cg_none0_list(isoa1, isoa2, ilist) - laa = indso(1, isoaa) - maa = indso(2, isoaa) - nla = nsoset_pm(laa-1) - labmin = MIN(laa, lbj) - il = INT((lai+lak-laa)/2) - stemp = 0.0_dp - DO j = 0, labmin - prefac = swork_cont(ishella, jshellb, kshella, il, laa+lbj-j+1) - IF (maa >= 0 .AND. mbj >= 0) stemp = stemp+prefac*Waux_mat(nla+ABS(maa)+1, nlb+ABS(mbj)+1, j+1, 1) - IF (maa >= 0 .AND. mbj < 0) stemp = stemp+prefac*Waux_mat(nla+ABS(maa)+1, nlb+ABS(mbj)+1, j+1, 2) - IF (maa < 0 .AND. mbj >= 0) stemp = stemp+prefac*Waux_mat(nla+ABS(maa)+1, nlb+ABS(mbj)+1, j+1, 3) - IF (maa < 0 .AND. mbj < 0) stemp = stemp+prefac*Waux_mat(nla+ABS(maa)+1, nlb+ABS(mbj)+1, j+1, 4) - ENDDO - saba(ia+mai, jb+mbj, ka+mak) = saba(ia+mai, jb+mbj, ka+mak)+cg_coeff(isoa1, isoa2, isoaa)*stemp - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - - CALL timestop(handle) - - END SUBROUTINE overlap_shg_aba - -! ************************************************************************************************** -!> \brief calculates derivatives of [aba] SHG overlap integrals using -!> precomputed angular-dependent part -!> \param la set of l quantum number on a, orbital basis -!> \param first_sgfa indexing -!> \param nshella number of shells for a, orbital basis -!> \param lb set of l quantum number on b. orbital basis -!> \param first_sgfb indexing -!> \param nshellb number of shells for b, orbital basis -!> \param lca of l quantum number on a, aux basis -!> \param first_sgfca indexing -!> \param nshellca number of shells for a, aux basis -!> \param cg_coeff Clebsch-Gordon coefficients -!> \param cg_none0_list list of none-zero Clebsch-Gordon coefficients -!> \param ncg_none0 number of non-zero Clebsch-Gordon coefficients -!> \param rab distance vector Ra-Rb -!> \param swork_cont contracted and normalized [s|ra^n|s] integrals -!> \param Waux_mat precomputed angular-dependent part -!> \param dWaux_mat derivatives of precomputed angular-dependent part -!> \param dsaba derivative of contracted overlap [aba] of spherical harmonic -!> Gaussians -! ************************************************************************************************** - SUBROUTINE dev_overlap_shg_aba(la, first_sgfa, nshella, lb, first_sgfb, nshellb, & - lca, first_sgfca, nshellca, cg_coeff, cg_none0_list, & - ncg_none0, rab, swork_cont, Waux_mat, dWaux_mat, dsaba) - - INTEGER, DIMENSION(:), INTENT(IN) :: la, first_sgfa - INTEGER, INTENT(IN) :: nshella - INTEGER, DIMENSION(:), INTENT(IN) :: lb, first_sgfb - INTEGER, INTENT(IN) :: nshellb - INTEGER, DIMENSION(:), INTENT(IN) :: lca, first_sgfca - INTEGER, INTENT(IN) :: nshellca - REAL(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: cg_coeff - INTEGER, DIMENSION(:, :, :), INTENT(IN) :: cg_none0_list - INTEGER, DIMENSION(:, :), INTENT(IN) :: ncg_none0 - REAL(KIND=dp), INTENT(IN) :: rab(3) - REAL(KIND=dp), DIMENSION(:, :, :, :, :), POINTER :: swork_cont - REAL(KIND=dp), DIMENSION(:, :, :, :), INTENT(IN) :: Waux_mat - REAL(KIND=dp), DIMENSION(:, :, :, :, :), & - INTENT(IN) :: dWaux_mat - REAL(KIND=dp), DIMENSION(:, :, :, :), & - INTENT(INOUT) :: dsaba - - CHARACTER(len=*), PARAMETER :: routineN = 'dev_overlap_shg_aba', & - routineP = moduleN//':'//routineN - - INTEGER :: handle, i, ia, il, ilist, ishella, isoa1, isoa2, isoaa, j, jb, jshellb, ka, & - kshella, laa, labmin, lai, lak, lbj, maa, mai, mak, mbj, nla, nlb, sgfa, sgfb, sgfca - REAL(KIND=dp) :: dprefac, dtemp(3), prefac, rabx2(3) - - CALL timeset(routineN, handle) - - rabx2(:) = 2.0_dp*rab - - DO ishella = 1, nshella - lai = la(ishella) - sgfa = first_sgfa(ishella) - ia = sgfa+lai - DO jshellb = 1, nshellb - lbj = lb(jshellb) - nlb = nsoset_pm(lbj-1) - sgfb = first_sgfb(jshellb) - jb = sgfb+lbj - DO kshella = 1, nshellca - lak = lca(kshella) - sgfca = first_sgfca(kshella) - ka = sgfca+lak - DO mai = -lai, lai, 1 - DO mbj = -lbj, lbj, 1 - DO mak = -lak, lak, 1 - isoa1 = indso_inv(lai, mai) - isoa2 = indso_inv(lak, mak) - DO ilist = 1, ncg_none0(isoa1, isoa2) - isoaa = cg_none0_list(isoa1, isoa2, ilist) - laa = indso(1, isoaa) - maa = indso(2, isoaa) - nla = nsoset_pm(laa-1) - labmin = MIN(laa, lbj) - il = INT((lai+lak-laa)/2) - dtemp = 0.0_dp - DO j = 0, labmin - prefac = swork_cont(ishella, jshellb, kshella, il, laa+lbj-j+1) - dprefac = swork_cont(ishella, jshellb, kshella, il, laa+lbj-j+2) - DO i = 1, 3 - IF (maa >= 0 .AND. mbj >= 0) THEN - dtemp(i) = dtemp(i)+rabx2(i)*dprefac*Waux_mat(nla+ABS(maa)+1, nlb+ABS(mbj)+1, j+1, 1) & - +prefac*dWaux_mat(i, nla+ABS(maa)+1, nlb+ABS(mbj)+1, j+1, 1) - ELSEIF (maa >= 0 .AND. mbj < 0) THEN - dtemp(i) = dtemp(i)+rabx2(i)*dprefac*Waux_mat(nla+ABS(maa)+1, nlb+ABS(mbj)+1, j+1, 2) & - +prefac*dWaux_mat(i, nla+ABS(maa)+1, nlb+ABS(mbj)+1, j+1, 2) - ELSEIF (maa < 0 .AND. mbj >= 0) THEN - dtemp(i) = dtemp(i)+rabx2(i)*dprefac*Waux_mat(nla+ABS(maa)+1, nlb+ABS(mbj)+1, j+1, 3) & - +prefac*dWaux_mat(i, nla+ABS(maa)+1, nlb+ABS(mbj)+1, j+1, 3) - ELSEIF (maa < 0 .AND. mbj < 0) THEN - dtemp(i) = dtemp(i)+rabx2(i)*dprefac*Waux_mat(nla+ABS(maa)+1, nlb+ABS(mbj)+1, j+1, 4) & - +prefac*dWaux_mat(i, nla+ABS(maa)+1, nlb+ABS(mbj)+1, j+1, 4) - ENDIF - ENDDO - ENDDO - DO i = 1, 3 - dsaba(ia+mai, jb+mbj, ka+mak, i) = dsaba(ia+mai, jb+mbj, ka+mak, i) & - +cg_coeff(isoa1, isoa2, isoaa)*dtemp(i) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - - CALL timestop(handle) - - END SUBROUTINE dev_overlap_shg_aba - -! ************************************************************************************************** -!> \brief calculates [abb] SHG overlap integrals using precomputed angular- -!> dependent part -!> \param la set of l quantum number on a, orbital basis -!> \param first_sgfa indexing -!> \param nshella number of shells for a, orbital basis -!> \param lb set of l quantum number on b. orbital basis -!> \param first_sgfb indexing -!> \param nshellb number of shells for b, orbital basis -!> \param lcb l quantum number on b, aux basis -!> \param first_sgfcb indexing -!> \param nshellcb number of shells for b, aux basis -!> \param cg_coeff Clebsch-Gordon coefficients -!> \param cg_none0_list list of none-zero Clebsch-Gordon coefficients -!> \param ncg_none0 number of non-zero Clebsch-Gordon coefficients -!> \param swork_cont contracted and normalized [s|rb^n|s] integrals -!> \param Waux_mat precomputed angular-dependent part -!> \param sabb contracted overlap [abb] of spherical harmonic Gaussians -! ************************************************************************************************** - SUBROUTINE overlap_shg_abb(la, first_sgfa, nshella, lb, first_sgfb, nshellb, & - lcb, first_sgfcb, nshellcb, cg_coeff, cg_none0_list, & - ncg_none0, swork_cont, Waux_mat, sabb) - - INTEGER, DIMENSION(:), INTENT(IN) :: la, first_sgfa - INTEGER, INTENT(IN) :: nshella - INTEGER, DIMENSION(:), INTENT(IN) :: lb, first_sgfb - INTEGER, INTENT(IN) :: nshellb - INTEGER, DIMENSION(:), INTENT(IN) :: lcb, first_sgfcb - INTEGER, INTENT(IN) :: nshellcb - REAL(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: cg_coeff - INTEGER, DIMENSION(:, :, :), INTENT(IN) :: cg_none0_list - INTEGER, DIMENSION(:, :), INTENT(IN) :: ncg_none0 - REAL(KIND=dp), DIMENSION(:, :, :, :, :), POINTER :: swork_cont - REAL(KIND=dp), DIMENSION(:, :, :, :), INTENT(IN) :: Waux_mat - REAL(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: sabb - - CHARACTER(len=*), PARAMETER :: routineN = 'overlap_shg_abb', & - routineP = moduleN//':'//routineN - - INTEGER :: handle, ia, il, ilist, ishella, isob1, isob2, isobb, j, jb, jshellb, kb, kshellb, & - labmin, lai, lbb, lbj, lbk, mai, mbb, mbj, mbk, nla, nlb, sgfa, sgfb, sgfcb - REAL(KIND=dp) :: prefac, stemp, tsign - - CALL timeset(routineN, handle) - - DO ishella = 1, nshella - lai = la(ishella) - nla = nsoset_pm(lai-1)+1 - sgfa = first_sgfa(ishella) - ia = sgfa+lai - DO jshellb = 1, nshellb - lbj = lb(jshellb) - nlb = nsoset_pm(lbj-1) - sgfb = first_sgfb(jshellb) - jb = sgfb+lbj - DO kshellb = 1, nshellcb - lbk = lcb(kshellb) - sgfcb = first_sgfcb(kshellb) - kb = sgfcb+lbk - DO mai = -lai, lai, 1 - DO mbj = -lbj, lbj, 1 - DO mbk = -lbk, lbk, 1 - isob1 = indso_inv(lbj, mbj) - isob2 = indso_inv(lbk, mbk) - DO ilist = 1, ncg_none0(isob1, isob2) - isobb = cg_none0_list(isob1, isob2, ilist) - lbb = indso(1, isobb) - mbb = indso(2, isobb) - nlb = nsoset_pm(lbb-1)+1 - tsign = 1.0_dp - IF (MODULO(lbb-lai, 2) /= 0) tsign = -1.0_dp - labmin = MIN(lai, lbb) - il = INT((lbj+lbk-lbb)/2) - stemp = 0.0_dp - DO j = 0, labmin - prefac = swork_cont(ishella, jshellb, kshellb, il, lai+lbb-j+1) - IF (mai >= 0 .AND. mbb >= 0) stemp = stemp+prefac*Waux_mat(nlb+ABS(mbb), nla+ABS(mai), j+1, 1) - ! take the transpose, since auxmat calculated for (lbb,lai) - IF (mai >= 0 .AND. mbb < 0) stemp = stemp+prefac*Waux_mat(nlb+ABS(mbb), nla+ABS(mai), j+1, 3) - IF (mai < 0 .AND. mbb >= 0) stemp = stemp+prefac*Waux_mat(nlb+ABS(mbb), nla+ABS(mai), j+1, 2) - IF (mai < 0 .AND. mbb < 0) stemp = stemp+prefac*Waux_mat(nlb+ABS(mbb), nla+ABS(mai), j+1, 4) - ENDDO - sabb(ia+mai, jb+mbj, kb+mbk) = sabb(ia+mai, jb+mbj, kb+mbk)+tsign*cg_coeff(isob1, isob2, isobb)*stemp - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - - CALL timestop(handle) - - END SUBROUTINE overlap_shg_abb - -! ************************************************************************************************** -!> \brief calculates derivatives of [abb] SHG overlap integrals using -!> precomputed angular-dependent part -!> \param la set of l quantum number on a, orbital basis -!> \param first_sgfa indexing -!> \param nshella number of shells for a, orbital basis -!> \param lb set of l quantum number on b. orbital basis -!> \param first_sgfb indexing -!> \param nshellb number of shells for b, orbital basis -!> \param lcb l quantum number on b, aux basis -!> \param first_sgfcb indexing -!> \param nshellcb number of shells for b, aux basis -!> \param cg_coeff Clebsch-Gordon coefficients -!> \param cg_none0_list list of none-zero Clebsch-Gordon coefficients -!> \param ncg_none0 number of non-zero Clebsch-Gordon coefficients -!> \param rab distance vector Ra-Rb -!> \param swork_cont contracted and normalized [s|rb^n|s] integrals -!> \param Waux_mat precomputed angular-dependent part -!> \param dWaux_mat derivatives of precomputed angular-dependent part -!> \param dsabb derivative of contracted overlap [abb] of spherical harmonic -!> Gaussians -! ************************************************************************************************** - SUBROUTINE dev_overlap_shg_abb(la, first_sgfa, nshella, lb, first_sgfb, nshellb, & - lcb, first_sgfcb, nshellcb, cg_coeff, cg_none0_list, & - ncg_none0, rab, swork_cont, Waux_mat, dWaux_mat, dsabb) - - INTEGER, DIMENSION(:), INTENT(IN) :: la, first_sgfa - INTEGER, INTENT(IN) :: nshella - INTEGER, DIMENSION(:), INTENT(IN) :: lb, first_sgfb - INTEGER, INTENT(IN) :: nshellb - INTEGER, DIMENSION(:), INTENT(IN) :: lcb, first_sgfcb - INTEGER, INTENT(IN) :: nshellcb - REAL(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: cg_coeff - INTEGER, DIMENSION(:, :, :), INTENT(IN) :: cg_none0_list - INTEGER, DIMENSION(:, :), INTENT(IN) :: ncg_none0 - REAL(KIND=dp), INTENT(IN) :: rab(3) - REAL(KIND=dp), DIMENSION(:, :, :, :, :), POINTER :: swork_cont - REAL(KIND=dp), DIMENSION(:, :, :, :), INTENT(IN) :: Waux_mat - REAL(KIND=dp), DIMENSION(:, :, :, :, :), & - INTENT(IN) :: dWaux_mat - REAL(KIND=dp), DIMENSION(:, :, :, :), & - INTENT(INOUT) :: dsabb - - CHARACTER(len=*), PARAMETER :: routineN = 'dev_overlap_shg_abb', & - routineP = moduleN//':'//routineN - - INTEGER :: handle, i, ia, il, ilist, ishella, isob1, isob2, isobb, j, jb, jshellb, kb, & - kshellb, labmin, lai, lbb, lbj, lbk, mai, mbb, mbj, mbk, nla, nlb, sgfa, sgfb, sgfcb - REAL(KIND=dp) :: dprefac, dtemp(3), prefac, rabx2(3), & - tsign - - CALL timeset(routineN, handle) - - rabx2(:) = 2.0_dp*rab - - DO ishella = 1, nshella - lai = la(ishella) - nla = nsoset_pm(lai-1)+1 - sgfa = first_sgfa(ishella) - ia = sgfa+lai - DO jshellb = 1, nshellb - lbj = lb(jshellb) - nlb = nsoset_pm(lbj-1) - sgfb = first_sgfb(jshellb) - jb = sgfb+lbj - DO kshellb = 1, nshellcb - lbk = lcb(kshellb) - sgfcb = first_sgfcb(kshellb) - kb = sgfcb+lbk - DO mai = -lai, lai, 1 - DO mbj = -lbj, lbj, 1 - DO mbk = -lbk, lbk, 1 - isob1 = indso_inv(lbj, mbj) - isob2 = indso_inv(lbk, mbk) - DO ilist = 1, ncg_none0(isob1, isob2) - isobb = cg_none0_list(isob1, isob2, ilist) - lbb = indso(1, isobb) - mbb = indso(2, isobb) - nlb = nsoset_pm(lbb-1)+1 - tsign = 1.0_dp - IF (MODULO(lbb-lai, 2) /= 0) tsign = -1.0_dp - labmin = MIN(lai, lbb) - il = INT((lbj+lbk-lbb)/2) - dtemp = 0.0_dp - DO j = 0, labmin - prefac = swork_cont(ishella, jshellb, kshellb, il, lai+lbb-j+1) - dprefac = swork_cont(ishella, jshellb, kshellb, il, lai+lbb-j+2) - DO i = 1, 3 - IF (mai >= 0 .AND. mbb >= 0) THEN - dtemp(i) = dtemp(i)+rabx2(i)*dprefac*Waux_mat(nlb+ABS(mbb), nla+ABS(mai), j+1, 1) & - +prefac*dWaux_mat(i, nlb+ABS(mbb), nla+ABS(mai), j+1, 1) - ENDIF - ! take the transpose, since auxmat calculated for (lbb,lai) - IF (mai >= 0 .AND. mbb < 0) THEN - dtemp(i) = dtemp(i)+rabx2(i)*dprefac*Waux_mat(nlb+ABS(mbb), nla+ABS(mai), j+1, 3) & - +prefac*dWaux_mat(i, nlb+ABS(mbb), nla+ABS(mai), j+1, 3) - ENDIF - IF (mai < 0 .AND. mbb >= 0) THEN - dtemp(i) = dtemp(i)+rabx2(i)*dprefac*Waux_mat(nlb+ABS(mbb), nla+ABS(mai), j+1, 2) & - +prefac*dWaux_mat(i, nlb+ABS(mbb), nla+ABS(mai), j+1, 2) - ENDIF - IF (mai < 0 .AND. mbb < 0) THEN - dtemp(i) = dtemp(i)+rabx2(i)*dprefac*Waux_mat(nlb+ABS(mbb), nla+ABS(mai), j+1, 4) & - +prefac*dWaux_mat(i, nlb+ABS(mbb), nla+ABS(mai), j+1, 4) - ENDIF - ENDDO - ENDDO - DO i = 1, 3 - dsabb(ia+mai, jb+mbj, kb+mbk, i) = dsabb(ia+mai, jb+mbj, kb+mbk, i) & - +tsign*cg_coeff(isob1, isob2, isobb)*dtemp(i) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - - CALL timestop(handle) - - END SUBROUTINE dev_overlap_shg_abb - -END MODULE ai_shg_overlap - diff --git a/src/aobasis/basis_set_types.F b/src/aobasis/basis_set_types.F index 3f01c76366..0d9425e0bf 100644 --- a/src/aobasis/basis_set_types.F +++ b/src/aobasis/basis_set_types.F @@ -1608,7 +1608,7 @@ CONTAINS CALL reallocate(gto_basis_set%norm_cgf, 1, ncgf) basis_type = "" - CALL section_vals_val_get(basis_section, "_SECTION_PARAMETERS_", i_rep_val=irep, c_val=basis_type) + CALL section_vals_val_get(basis_section, "_SECTION_PARAMETERS_", i_rep_section=irep, c_val=basis_type) IF (basis_type == "Orbital") basis_type = "ORB" NULLIFY (list, val) diff --git a/src/aobasis/orbital_pointers.F b/src/aobasis/orbital_pointers.F index 7406420afd..c31fd84fc2 100644 --- a/src/aobasis/orbital_pointers.F +++ b/src/aobasis/orbital_pointers.F @@ -22,8 +22,6 @@ MODULE orbital_pointers ! number l. ! nsoset: Number of spherical orbitals up to the angular momentum quantum ! number l. -! nsoset_pm: Number of spherical orbitals up to the angular momentum quantum -! number l for positive m only, i.e. m >= 0 USE kinds, ONLY: int_size USE termination, ONLY: stop_memory @@ -39,7 +37,7 @@ MODULE orbital_pointers INTEGER, SAVE :: current_maxl = -1 - INTEGER, DIMENSION(:), ALLOCATABLE :: nco, ncoset, nso, nsoset, nsoset_pm + INTEGER, DIMENSION(:), ALLOCATABLE :: nco, ncoset, nso, nsoset INTEGER, DIMENSION(:, :), ALLOCATABLE :: indco, indso, indso_inv INTEGER, DIMENSION(:, :), ALLOCATABLE :: so, soset INTEGER, DIMENSION(:, :, :), ALLOCATABLE :: co, coset @@ -61,7 +59,6 @@ MODULE orbital_pointers ncoset, & nso, & nsoset, & - nsoset_pm, & soset CONTAINS @@ -192,18 +189,10 @@ CONTAINS CALL stop_memory(routineN, moduleN, __LINE__, & "nsoset", (maxl+2)*int_size) END IF - ALLOCATE (nsoset_pm(-1:maxl), STAT=istat) - IF (istat /= 0) THEN - CALL stop_memory(routineN, moduleN, __LINE__, & - "nsoset_pm", (maxl+2)*int_size) - END IF - nsoset(-1) = 0 - nsoset_pm(-1) = 0 DO l = 0, maxl nsoset(l) = nsoset(l-1)+nso(l) - nsoset_pm(l) = nsoset_pm(l-1)+l+1 END DO ALLOCATE (indso(2, nsoset(maxl)), STAT=istat) @@ -281,8 +270,6 @@ CONTAINS DEALLOCATE (nsoset) - DEALLOCATE (nsoset_pm) - DEALLOCATE (so) DEALLOCATE (soset) diff --git a/src/lri_debug_integrals.F b/src/debug_os_integrals.F similarity index 97% rename from src/lri_debug_integrals.F rename to src/debug_os_integrals.F index c7198540a2..3b6eb32b04 100644 --- a/src/lri_debug_integrals.F +++ b/src/debug_os_integrals.F @@ -4,13 +4,12 @@ !--------------------------------------------------------------------------------------------------! ! ************************************************************************************************** -!> \brief Debugs the integral matrices for the LRIGPW method -!> lri : local resolution of the identity +!> \brief Debugs Obara-Saika integral matrices !> \par History !> created [07.2014] !> \authors Dorothea Golze ! ************************************************************************************************** -MODULE lri_debug_integrals +MODULE debug_os_integrals USE ai_overlap, ONLY: overlap USE ai_overlap3, ONLY: overlap3 @@ -31,7 +30,7 @@ MODULE lri_debug_integrals ! ************************************************************************************************** - CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'lri_debug_integrals' + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'debug_os_integrals' PUBLIC :: overlap_ab_test, overlap_abc_test, overlap_aabb_test @@ -247,11 +246,6 @@ CONTAINS lb_max_set=lb_max, npgfb=1, zetb=xb_work, rpgfb=rpgfb, lb_min_set=lb_min, & lc_max_set=lc_max, npgfc=1, zetc=xc_work, rpgfc=rpgfc, lc_min_set=lc_min, & rab=rab, dab=dab, rac=rac, dac=dac, rbc=rbc, dbc=dbc, sabc=sabc) - !sabc(:,:,:)=0._dp - !CALL overlap3_old(la_max=la_max,npgfa=1,zeta=xa_work,rpgfa=rpgfa,la_min=la_min,& - ! lb_max=lb_max,npgfb=1,zetb=xb_work,rpgfb=rpgfb,lb_min=lb_min,& - ! lc_max=lc_max,npgfc=1,zetc=xc,rpgfc=20._dp,lc_min=lc_min,& - ! rab=rab,dab=dab,rac=rac,dac=dac,rbc=rbc,dbc=dbc,sabc=sabc) !--------------------------------------- @@ -624,4 +618,4 @@ CONTAINS END SUBROUTINE overlap_aabb_test -END MODULE lri_debug_integrals +END MODULE debug_os_integrals diff --git a/src/lri_os_integrals.F b/src/generic_os_integrals.F similarity index 72% rename from src/lri_os_integrals.F rename to src/generic_os_integrals.F index 0c31ed9ecf..2c46a47e7d 100644 --- a/src/lri_os_integrals.F +++ b/src/generic_os_integrals.F @@ -4,23 +4,39 @@ !--------------------------------------------------------------------------------------------------! ! ************************************************************************************************** -!> \brief Calculates integral matrices for LRIGPW method using the Obara-Saika -!> (OS) integral scheme -!> lri : local resolution of the identity +!> \brief Calculation of contracted, spherical Gaussian integrals using the (OS) integral +!> scheme. Routines for the following two-center integrals: +!> i) (a|O(r12)|b) where O(r12) is the overlap, coulomb operator etc. +!> ii) (aba) and (abb) s-overlaps !> \par History !> created [06.2015] !> \author Dorothea Golze ! ************************************************************************************************** -MODULE lri_os_integrals +MODULE generic_os_integrals + USE ai_contraction_sphi, ONLY: ab_contract,& + abc_contract,& + abcd_contract + USE ai_derivatives, ONLY: dabdr_noscreen + USE ai_operators_r12, ONLY: cps_coulomb2,& + cps_gauss2,& + cps_verf2,& + cps_verfc2,& + cps_vgauss2,& + operator2 USE ai_overlap, ONLY: overlap USE ai_overlap3, ONLY: overlap3 USE ai_overlap_aabb, ONLY: overlap_aabb USE basis_set_types, ONLY: get_gto_basis_set,& gto_basis_set_type - USE kinds, ONLY: dp - USE lri_debug_integrals, ONLY: overlap_aabb_test,& + USE debug_os_integrals, ONLY: overlap_aabb_test,& overlap_ab_test,& overlap_abc_test + USE input_constants, ONLY: operator_coulomb,& + operator_gauss,& + operator_verf,& + operator_verfc,& + operator_vgauss + USE kinds, ONLY: dp USE orbital_pointers, ONLY: ncoset #include "./base/base_uses.f90" @@ -30,29 +46,220 @@ MODULE lri_os_integrals ! ************************************************************************************************** - CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'lri_os_integrals' + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'generic_os_integrals' - PUBLIC :: lri_int_ab, lri_int_aba, lri_int_abb, lri_int_aabb + PUBLIC :: two_center_os_integrals, int_overlap_ab_os, int_overlap_aba_os, & + int_overlap_abb_os, int_overlap_aabb_os + +#include "./aobasis/ai_operators_r12.h" ! ************************************************************************************************** CONTAINS +! ************************************************************************************************** +!> \brief Calcululates the two-center integrals of the type (a|O(r12)|b) using the OS scheme +!> \param r12_operator the integral operator, which depends on r12=|r1-r2| +!> \param vab integral matrix of spherical contracted Gaussian functions +!> \param dvab derivative of the integrals +!> \param rab distance vector between center A and B +!> \param fba basis at center A +!> \param fbb basis at center B +!> \param omega parameter in the operator +!> \param calculate_forces ... +! ************************************************************************************************** + SUBROUTINE two_center_os_integrals(r12_operator, vab, dvab, rab, fba, fbb, omega, calculate_forces) + + INTEGER, INTENT(IN) :: r12_operator + REAL(KIND=dp), DIMENSION(:, :), POINTER :: vab + REAL(KIND=dp), DIMENSION(:, :, :), OPTIONAL, & + POINTER :: dvab + REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rab + TYPE(gto_basis_set_type), POINTER :: fba, fbb + REAL(KIND=dp), INTENT(IN), OPTIONAL :: omega + LOGICAL, INTENT(IN) :: calculate_forces + + CHARACTER(LEN=*), PARAMETER :: routineN = 'two_center_os_integrals', & + routineP = moduleN//':'//routineN + + INTEGER :: handle + REAL(KIND=dp) :: my_omega + + PROCEDURE(ab_sint_os), POINTER :: cps_operator2 => null() + + CALL timeset(routineN, handle) + + my_omega = 1.0_dp + + SELECT CASE (r12_operator) + CASE (operator_coulomb) + cps_operator2 => cps_coulomb2 + CASE (operator_verf) + cps_operator2 => cps_verf2 + IF (PRESENT(omega)) my_omega = omega + CASE (operator_verfc) + cps_operator2 => cps_verfc2 + IF (PRESENT(omega)) my_omega = omega + CASE (operator_vgauss) + cps_operator2 => cps_vgauss2 + IF (PRESENT(omega)) my_omega = omega + CASE (operator_gauss) + cps_operator2 => cps_gauss2 + IF (PRESENT(omega)) my_omega = omega + CASE DEFAULT + CPABORT("Operator not available") + END SELECT + + CALL int_operator_ab_os(cps_operator2, vab, dvab, rab, fba, fbb, my_omega, calculate_forces) + + CALL timestop(handle) + + END SUBROUTINE two_center_os_integrals + +! ************************************************************************************************** +!> \brief calculate integrals (a|O(r12)|b) +!> \param cps_operator2 procedure pointer for the respective operator. +!> \param vab integral matrix of spherical contracted Gaussian functions +!> \param dvab derivative of the integrals +!> \param rab distance vector between center A and B +!> \param fba basis at center A +!> \param fbb basis at center B +!> \param omega parameter in the operator +!> \param calculate_forces ... +! ************************************************************************************************** + SUBROUTINE int_operator_ab_os(cps_operator2, vab, dvab, rab, fba, fbb, omega, calculate_forces) + + PROCEDURE(ab_sint_os), POINTER :: cps_operator2 + REAL(KIND=dp), DIMENSION(:, :), POINTER :: vab + REAL(KIND=dp), DIMENSION(:, :, :), OPTIONAL, & + POINTER :: dvab + REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rab + TYPE(gto_basis_set_type), POINTER :: fba, fbb + REAL(KIND=dp), INTENT(IN) :: omega + LOGICAL, INTENT(IN) :: calculate_forces + + CHARACTER(LEN=*), PARAMETER :: routineN = 'int_operator_ab_os', routineP = moduleN//':'//routineN + + INTEGER :: handle, i, iset, jset, lds, m1, m2, & + maxco, maxcoa, maxcob, maxl, maxla, & + maxlb, ncoa, ncoap, ncob, ncobp, & + nseta, nsetb, sgfa, sgfb + INTEGER, DIMENSION(:), POINTER :: la_max, la_min, lb_max, lb_min, npgfa, & + npgfb, nsgfa, nsgfb + INTEGER, DIMENSION(:, :), POINTER :: first_sgfa, first_sgfb + REAL(KIND=dp) :: dab, rab2 + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: vac, vac_plus + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: devab, vwork + REAL(KIND=dp), DIMENSION(:), POINTER :: set_radius_a, set_radius_b + REAL(KIND=dp), DIMENSION(:, :), POINTER :: rpgfa, rpgfb, sphi_a, sphi_b, zeta, zetb + + CALL timeset(routineN, handle) + NULLIFY (la_max, la_min, lb_max, lb_min, npgfa, npgfb, nsgfa, nsgfb, & + first_sgfa, first_sgfb, set_radius_a, set_radius_b, rpgfa, rpgfb, & + sphi_a, sphi_b, zeta, zetb) + + ! basis ikind + first_sgfa => fba%first_sgf + la_max => fba%lmax + la_min => fba%lmin + npgfa => fba%npgf + nseta = fba%nset + nsgfa => fba%nsgf_set + rpgfa => fba%pgf_radius + set_radius_a => fba%set_radius + sphi_a => fba%sphi + zeta => fba%zet + ! basis jkind + first_sgfb => fbb%first_sgf + lb_max => fbb%lmax + lb_min => fbb%lmin + npgfb => fbb%npgf + nsetb = fbb%nset + nsgfb => fbb%nsgf_set + rpgfb => fbb%pgf_radius + set_radius_b => fbb%set_radius + sphi_b => fbb%sphi + zetb => fbb%zet + + CALL get_gto_basis_set(fba, maxco=maxcoa, maxl=maxla) + CALL get_gto_basis_set(fbb, maxco=maxcob, maxl=maxlb) + maxco = MAX(maxcoa, maxcob) + IF (calculate_forces) THEN + maxl = MAX(maxla+1, maxlb) + ELSE + maxl = MAX(maxla, maxlb) + ENDIF + lds = ncoset(maxl) + + rab2 = SUM(rab*rab) + dab = SQRT(rab2) + + DO iset = 1, nseta + + ncoa = npgfa(iset)*ncoset(la_max(iset)) + ncoap = npgfa(iset)*ncoset(la_max(iset)+1) + sgfa = first_sgfa(1, iset) + + DO jset = 1, nsetb + + ncob = npgfb(jset)*ncoset(lb_max(jset)) + ncobp = npgfb(jset)*ncoset(lb_max(jset)+1) + sgfb = first_sgfb(1, jset) + m1 = sgfa+nsgfa(iset)-1 + m2 = sgfb+nsgfb(jset)-1 + + ! calculate integrals + IF (calculate_forces) THEN + ALLOCATE (vwork(ncoap, ncobp, la_max(iset)+lb_max(jset)+3), & + vac(ncoa, ncob), vac_plus(ncoap, ncobp), devab(ncoa, ncob, 3)) + devab = 0._dp + vwork = 0.0_dp + vac = 0.0_dp + CALL operator2(cps_operator2, la_max(iset)+1, npgfa(iset), zeta(:, iset), la_min(iset), & + lb_max(jset)+1, npgfb(jset), zetb(:, jset), lb_min(jset), & + omega, rab, rab2, vac, vwork, maxder=1, vac_plus=vac_plus) + CALL dabdr_noscreen(la_max(iset), npgfa(iset), zeta(:, iset), lb_max(jset), npgfb(jset), & + vac_plus, devab(:, :, 1), devab(:, :, 2), devab(:, :, 3)) + DO i = 1, 3 + CALL ab_contract(dvab(sgfa:m1, sgfb:m2, i), devab(:, :, i), sphi_a(:, sgfa:), & + sphi_b(:, sgfb:), ncoa, ncob, nsgfa(iset), nsgfb(jset)) + ENDDO + + ELSE + ALLOCATE (vwork(ncoa, ncob, la_max(iset)+lb_max(jset)+1), & + vac(ncoa, ncob), vac_plus(ncoap, ncobp), devab(ncoa, ncob, 3)) + vwork = 0.0_dp + vac = 0.0_dp + CALL operator2(cps_operator2, la_max(iset), npgfa(iset), zeta(:, iset), la_min(iset), & + lb_max(jset), npgfb(jset), zetb(:, jset), lb_min(jset), & + omega, rab, rab2, vac, vwork) + ENDIF + + CALL ab_contract(vab(sgfa:m1, sgfb:m2), vac(1:ncoa, 1:ncob), sphi_a(:, sgfa:), sphi_b(:, sgfb:), & + ncoa, ncob, nsgfa(iset), nsgfb(jset)) + DEALLOCATE (vwork, vac, vac_plus, devab) + END DO + END DO + + CALL timestop(handle) + + END SUBROUTINE int_operator_ab_os + ! ************************************************************************************************** !> \brief calculate overlap integrals (a,b) !> \param sab integral (a,b) !> \param dsab derivative of sab with respect to A -!> \param ra ... -!> \param rb ... -!> \param rab ... +!> \param ra position center A, for debug only +!> \param rb position center B, for debug only +!> \param rab distance vector between center A and B !> \param fba basis at center A !> \param fbb basis at center B !> \param calculate_forces ... !> \param debug integrals are debugged by recursive routines if requested !> \param dmax maximal deviation between integrals when debugging ! ************************************************************************************************** - SUBROUTINE lri_int_ab(sab, dsab, ra, rb, rab, fba, fbb, calculate_forces, debug, & - dmax) + SUBROUTINE int_overlap_ab_os(sab, dsab, ra, rb, rab, fba, fbb, calculate_forces, debug, & + dmax) REAL(KIND=dp), DIMENSION(:, :), POINTER :: sab REAL(KIND=dp), DIMENSION(:, :, :), OPTIONAL, & @@ -62,7 +269,8 @@ CONTAINS LOGICAL, INTENT(IN) :: calculate_forces, debug REAL(KIND=dp), INTENT(INOUT) :: dmax - CHARACTER(LEN=*), PARAMETER :: routineN = 'lri_int_ab', routineP = moduleN//':'//routineN + CHARACTER(LEN=*), PARAMETER :: routineN = 'int_overlap_ab_os', & + routineP = moduleN//':'//routineN INTEGER :: handle, i, iset, jset, lds, m1, m2, & maxco, maxcoa, maxcob, maxl, maxla, & @@ -181,15 +389,15 @@ CONTAINS CALL timestop(handle) - END SUBROUTINE lri_int_ab + END SUBROUTINE int_overlap_ab_os ! ************************************************************************************************** !> \brief calculate integrals (a,b,fa) !> \param abaint integral (a,b,fa) !> \param dabdaint derivative of abaint with respect to A -!> \param ra ... -!> \param rb ... -!> \param rab ... +!> \param ra position center A, for debug only +!> \param rb position center B, for debug only +!> \param rab distance vector between center A and B !> \param oba orbital basis at center A !> \param obb orbital basis at center B !> \param fba auxiliary basis set at center A @@ -197,8 +405,8 @@ CONTAINS !> \param debug integrals are debugged by recursive routines if requested !> \param dmax maximal deviation between integrals when debugging ! ************************************************************************************************** - SUBROUTINE lri_int_aba(abaint, dabdaint, ra, rb, rab, oba, obb, fba, & - calculate_forces, debug, dmax) + SUBROUTINE int_overlap_aba_os(abaint, dabdaint, ra, rb, rab, oba, obb, fba, & + calculate_forces, debug, dmax) REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: abaint REAL(KIND=dp), DIMENSION(:, :, :, :), OPTIONAL, & @@ -208,7 +416,8 @@ CONTAINS LOGICAL, INTENT(IN) :: calculate_forces, debug REAL(KIND=dp), INTENT(INOUT) :: dmax - CHARACTER(LEN=*), PARAMETER :: routineN = 'lri_int_aba', routineP = moduleN//':'//routineN + CHARACTER(LEN=*), PARAMETER :: routineN = 'int_overlap_aba_os', & + routineP = moduleN//':'//routineN INTEGER :: handle, i, iset, jset, kaset, m1, m2, & m3, ncoa, ncob, ncoc, nseta, nsetb, & @@ -345,15 +554,15 @@ CONTAINS CALL timestop(handle) - END SUBROUTINE lri_int_aba + END SUBROUTINE int_overlap_aba_os ! ************************************************************************************************** !> \brief calculate integrals (a,b,fb) !> \param abbint integral (a,b,fb) !> \param dabbint derivative of abbint with respect to A -!> \param ra ... -!> \param rb ... -!> \param rab ... +!> \param ra position center A, for debug only +!> \param rb position center B, for debug only +!> \param rab distance vector between center A and B !> \param oba orbital basis at center A !> \param obb orbital basis at center B !> \param fbb auxiliary basis set at center B @@ -361,8 +570,8 @@ CONTAINS !> \param debug integrals are debugged by recursive routines if requested !> \param dmax maximal deviation between integrals when debugging ! ************************************************************************************************** - SUBROUTINE lri_int_abb(abbint, dabbint, ra, rb, rab, oba, obb, fbb, calculate_forces, & - debug, dmax) + SUBROUTINE int_overlap_abb_os(abbint, dabbint, ra, rb, rab, oba, obb, fbb, calculate_forces, & + debug, dmax) REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: abbint REAL(KIND=dp), DIMENSION(:, :, :, :), OPTIONAL, & @@ -372,7 +581,8 @@ CONTAINS LOGICAL, INTENT(IN) :: calculate_forces, debug REAL(KIND=dp), INTENT(INOUT) :: dmax - CHARACTER(LEN=*), PARAMETER :: routineN = 'lri_int_abb', routineP = moduleN//':'//routineN + CHARACTER(LEN=*), PARAMETER :: routineN = 'int_overlap_abb_os', & + routineP = moduleN//':'//routineN INTEGER :: handle, i, iset, jset, kbset, m1, m2, & m3, ncoa, ncob, ncoc, nseta, nsetb, & @@ -501,7 +711,7 @@ CONTAINS CALL timestop(handle) - END SUBROUTINE lri_int_abb + END SUBROUTINE int_overlap_abb_os ! ************************************************************************************************** !> \brief calculate overlap integrals (aa,bb) @@ -514,7 +724,7 @@ CONTAINS !> \param debug integrals are debugged by recursive routines if requested !> \param dmax maximal deviation between integrals when debugging ! ************************************************************************************************** - SUBROUTINE lri_int_aabb(saabb, oba, obb, rab, ra, rb, debug, dmax) + SUBROUTINE int_overlap_aabb_os(saabb, oba, obb, rab, ra, rb, debug, dmax) REAL(KIND=dp), DIMENSION(:, :, :, :), POINTER :: saabb TYPE(gto_basis_set_type), POINTER :: oba, obb @@ -522,7 +732,8 @@ CONTAINS LOGICAL, INTENT(IN) :: debug REAL(KIND=dp), INTENT(INOUT) :: dmax - CHARACTER(LEN=*), PARAMETER :: routineN = 'lri_int_aabb', routineP = moduleN//':'//routineN + CHARACTER(LEN=*), PARAMETER :: routineN = 'int_overlap_aabb_os', & + routineP = moduleN//':'//routineN INTEGER :: handle, iset, isgfa1, jset, jsgfa2, kset, ksgfb1, lds, lset, lsgfb2, m1, m2, m3, & m4, maxco, maxcoa, maxcob, maxl, maxla, maxlb, ncoa1, ncoa2, ncob1, ncob2, nseta, nsetb, & @@ -649,193 +860,6 @@ CONTAINS CALL timestop(handle) - END SUBROUTINE lri_int_aabb + END SUBROUTINE int_overlap_aabb_os -! ************************************************************************************************** -!> \brief contract overlap integrals (a,b) and transfer to spherical Gaussians -!> \param abint ... -!> \param sab ... -!> \param sphi_a ... -!> \param sphi_b ... -!> \param ncoa ... -!> \param ncob ... -!> \param nsgfa ... -!> \param nsgfb ... -! ************************************************************************************************** - SUBROUTINE ab_contract(abint, sab, sphi_a, sphi_b, ncoa, ncob, nsgfa, nsgfb) - - REAL(KIND=dp), DIMENSION(:, :), INTENT(INOUT) :: abint - REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: sab, sphi_a, sphi_b - INTEGER, INTENT(IN) :: ncoa, ncob, nsgfa, nsgfb - - CHARACTER(LEN=*), PARAMETER :: routineN = 'ab_contract', routineP = moduleN//':'//routineN - - INTEGER :: m1, m2, msphia, msphib, nn - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: cpp - - msphia = SIZE(sphi_a, 1) - msphib = SIZE(sphi_b, 1) - - m1 = SIZE(sab, 1) - m2 = SIZE(sab, 2) - - nn = SIZE(abint, 1) - - ALLOCATE (cpp(nsgfa, m2)) - - CALL dgemm("T", "N", nsgfa, m2, ncoa, 1._dp, sphi_a, msphia, sab, m1, 0.0_dp, cpp, nsgfa) - CALL dgemm("N", "N", nsgfa, nsgfb, ncob, 1._dp, cpp, nsgfa, sphi_b, msphib, 0.0_dp, & - abint, nn) - - DEALLOCATE (cpp) - - END SUBROUTINE ab_contract - -! ************************************************************************************************** -!> \brief contract three-center overlap integrals (a,b,c) and transfer -!> to spherical Gaussians -!> \param abcint ... -!> \param sabc ... -!> \param sphi_a ... -!> \param sphi_b ... -!> \param sphi_c ... -!> \param ncoa ... -!> \param ncob ... -!> \param ncoc ... -!> \param nsgfa ... -!> \param nsgfb ... -!> \param nsgfc ... -! ************************************************************************************************** - SUBROUTINE abc_contract(abcint, sabc, sphi_a, sphi_b, sphi_c, ncoa, ncob, ncoc, & - nsgfa, nsgfb, nsgfc) - - REAL(KIND=dp), DIMENSION(:, :, :) :: abcint, sabc - REAL(KIND=dp), DIMENSION(:, :) :: sphi_a, sphi_b, sphi_c - INTEGER, INTENT(IN) :: ncoa, ncob, ncoc, nsgfa, nsgfb, nsgfc - - CHARACTER(LEN=*), PARAMETER :: routineN = 'abc_contract', routineP = moduleN//':'//routineN - - INTEGER :: handle, isgfc, m1, m2, m3, msphia, & - msphib, msphic - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: temp_ccc, work_cpc - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: cpc, cpp - - CALL timeset(routineN, handle) - - msphia = SIZE(sphi_a, 1) - msphib = SIZE(sphi_b, 1) - msphic = SIZE(sphi_c, 1) - - m1 = SIZE(sabc, 1) - m2 = SIZE(sabc, 2) - m3 = SIZE(sabc, 3) - - ALLOCATE (cpp(nsgfa, m2, m3), cpc(nsgfa, m2, nsgfc)) - cpp = 0._dp - cpc = 0._dp - ALLOCATE (work_cpc(nsgfa, m2), temp_ccc(nsgfa, nsgfb)) - work_cpc(:, :) = 0._dp - temp_ccc(:, :) = 0._dp - - CALL dgemm("T", "N", nsgfa, m2*m3, ncoa, 1._dp, sphi_a, msphia, sabc, m1, 0.0_dp, cpp, nsgfa) - CALL dgemm("N", "N", nsgfa*m2, nsgfc, ncoc, 1._dp, cpp, nsgfa*m2, sphi_c, msphic, 0.0_dp, & - cpc, nsgfa*m2) - - DO isgfc = 1, nsgfc - work_cpc(:, :) = cpc(:, :, isgfc) - CALL dgemm("N", "N", nsgfa, nsgfb, ncob, 1._dp, work_cpc, nsgfa, sphi_b, msphib, & - 0.0_dp, temp_ccc, nsgfa) - abcint(:, :, isgfc) = temp_ccc(:, :) - END DO - - DEALLOCATE (cpp, cpc, work_cpc, temp_ccc) - - CALL timestop(handle) - - END SUBROUTINE abc_contract - -! ************************************************************************************************** -!> \brief contract four-center overlap integrals (a,b,c,d) and transfer -!> to spherical Gaussians -!> \param abcdint ... -!> \param sabcd ... -!> \param sphi_a ... -!> \param sphi_b ... -!> \param sphi_c ... -!> \param sphi_d ... -!> \param ncoa ... -!> \param ncob ... -!> \param ncoc ... -!> \param ncod ... -!> \param nsgfa ... -!> \param nsgfb ... -!> \param nsgfc ... -!> \param nsgfd ... -! ************************************************************************************************** - SUBROUTINE abcd_contract(abcdint, sabcd, sphi_a, sphi_b, sphi_c, sphi_d, ncoa, ncob, & - ncoc, ncod, nsgfa, nsgfb, nsgfc, nsgfd) - - REAL(KIND=dp), DIMENSION(:, :, :, :), & - INTENT(INOUT) :: abcdint - REAL(KIND=dp), DIMENSION(:, :, :, :), INTENT(IN) :: sabcd - REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: sphi_a, sphi_b, sphi_c, sphi_d - INTEGER, INTENT(IN) :: ncoa, ncob, ncoc, ncod, nsgfa, nsgfb, & - nsgfc, nsgfd - - CHARACTER(LEN=*), PARAMETER :: routineN = 'abcd_contract', routineP = moduleN//':'//routineN - - INTEGER :: handle, isgfc, isgfd, m1, m2, m3, m4, & - msphia, msphib, msphic, msphid - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: temp_cccc, work_cpcc - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: temp_cpcc, work_cppc - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :, :) :: cpcc, cppc, cppp - - CALL timeset(routineN, handle) - - msphia = SIZE(sphi_a, 1) - msphib = SIZE(sphi_b, 1) - msphic = SIZE(sphi_c, 1) - msphid = SIZE(sphi_d, 1) - - m1 = SIZE(sabcd, 1) - m2 = SIZE(sabcd, 2) - m3 = SIZE(sabcd, 3) - m4 = SIZE(sabcd, 4) - - ALLOCATE (cppp(nsgfa, m2, m3, m4), cppc(nsgfa, m2, m3, nsgfd), & - cpcc(nsgfa, m2, nsgfc, nsgfd)) - - ALLOCATE (work_cppc(nsgfa, m2, m3), temp_cpcc(nsgfa, m2, nsgfc)) - work_cppc = 0._dp - temp_cpcc = 0._dp - - ALLOCATE (work_cpcc(nsgfa, m2), temp_cccc(nsgfa, nsgfb)) - work_cpcc = 0._dp - temp_cccc = 0._dp - - CALL dgemm("T", "N", nsgfa, m2*m3*m4, ncoa, 1._dp, sphi_a, msphia, sabcd, m1, & - 0.0_dp, cppp, nsgfa) - CALL dgemm("N", "N", nsgfa*m2*m3, nsgfd, ncod, 1._dp, cppp, nsgfa*m2*m3, & - sphi_d, msphid, 0.0_dp, cppc, nsgfa*m2*m3) - - DO isgfd = 1, nsgfd - work_cppc(:, :, :) = cppc(:, :, :, isgfd) - CALL dgemm("N", "N", nsgfa*m2, nsgfc, ncoc, 1._dp, work_cppc, nsgfa*m2, & - sphi_c, msphic, 0.0_dp, temp_cpcc, nsgfa*m2) - cpcc(:, :, :, isgfd) = temp_cpcc(:, :, :) - DO isgfc = 1, nsgfc - work_cpcc(:, :) = cpcc(:, :, isgfc, isgfd) - CALL dgemm("N", "N", nsgfa, nsgfb, ncob, 1._dp, work_cpcc, nsgfa, sphi_b, & - msphib, 0.0_dp, temp_cccc, nsgfa) - abcdint(:, :, isgfc, isgfd) = temp_cccc(:, :) - END DO - END DO - - DEALLOCATE (cpcc, cppc, cppp) - DEALLOCATE (work_cpcc, work_cppc, temp_cpcc, temp_cccc) - - CALL timestop(handle) - - END SUBROUTINE abcd_contract - -END MODULE lri_os_integrals +END MODULE generic_os_integrals diff --git a/src/generic_shg_integrals.F b/src/generic_shg_integrals.F new file mode 100644 index 0000000000..1f64d96c9b --- /dev/null +++ b/src/generic_shg_integrals.F @@ -0,0 +1,849 @@ +!--------------------------------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright (C) 2000 - 2016 CP2K developers group ! +!--------------------------------------------------------------------------------------------------! + +! ************************************************************************************************** +!> \brief Calculation of contracted, spherical Gaussian integrals using the solid harmonic +!> Gaussian (SHG) integral scheme. Routines for the following two-center integrals: +!> i) (a|O(r12)|b) where O(r12) is the overlap, coulomb operator etc. +!> ii) (aba) and (abb) s-overlaps +!> \par Literature +!> T.J. Giese and D. M. York, J. Chem. Phys, 128, 064104 (2008) +!> T. Helgaker, P Joergensen, J. Olsen, Molecular Electronic-Structure +!> Theory, Wiley +!> \par History +!> created [05.2016] +!> \author Dorothea Golze +! ************************************************************************************************** +MODULE generic_shg_integrals + USE ai_construct_shg, ONLY: & + construct_dev_shg_ab, construct_int_shg_ab, construct_overlap_shg_aba, & + construct_overlap_shg_abb, dev_overlap_shg_aba, dev_overlap_shg_abb, get_W_matrix, & + get_dW_matrix, get_real_scaled_solid_harmonic + USE ai_s_contract_shg, ONLY: & + contract_s_overlap_aba, contract_s_overlap_abb, contract_sint_ab_chigh, & + contract_sint_ab_clow, s_coulomb_ab, s_gauss_ab, s_overlap_ab, s_overlap_abx, s_verf_ab, & + s_verfc_ab, s_vgauss_ab + USE basis_set_types, ONLY: gto_basis_set_type + USE input_constants, ONLY: operator_coulomb,& + operator_gauss,& + operator_verf,& + operator_verfc,& + operator_vgauss + USE kinds, ONLY: dp + USE orbital_pointers, ONLY: nsoset +#include "base/base_uses.f90" + + IMPLICIT NONE + + PRIVATE + + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'generic_shg_integrals' + + PUBLIC :: two_center_shg_integrals, lri_precalc_angular_shg_part, & + int_overlap_ab_shg, int_overlap_aba_shg, int_overlap_abb_shg + + ABSTRACT INTERFACE +! ************************************************************************************************** +!> \brief Interface for the calculation of integrals over s-functions and their scalar derivatives +!> with respect to rab2 +!> \param la_max ... +!> \param npgfa ... +!> \param zeta ... +!> \param lb_max ... +!> \param npgfb ... +!> \param zetb ... +!> \param omega ... +!> \param rab ... +!> \param v matrix storing the integrals and scalar derivatives +!> \param calculate_forces ... +! ************************************************************************************************** + SUBROUTINE ab_sint_shg(la_max, npgfa, zeta, lb_max, npgfb, zetb, omega, rab, v, calculate_forces) + USE kinds, ONLY: dp + INTEGER, INTENT(IN) :: la_max, npgfa + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zeta + INTEGER, INTENT(IN) :: lb_max, npgfb + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zetb + REAL(KIND=dp), INTENT(IN) :: omega + REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rab + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: v + LOGICAL, INTENT(IN) :: calculate_forces + + END SUBROUTINE ab_sint_shg + END INTERFACE + +! ************************************************************************************************** + +CONTAINS + +! ************************************************************************************************** +!> \brief Calcululates the two-center integrals of the type (a|O(r12)|b) using the SHG scheme +!> \param r12_operator the integral operator, which depends on r12=|r1-r2| +!> \param vab integral matrix of spherical contracted Gaussian functions +!> \param dvab derivative of the integrals +!> \param rab distance vector between center A and B +!> \param fba basis at center A +!> \param fbb basis at center B +!> \param scona_shg SHG contraction matrix for A +!> \param sconb_shg SHG contraction matrix for B +!> \param omega parameter in the operator +!> \param calculate_forces ... +! ************************************************************************************************** + SUBROUTINE two_center_shg_integrals(r12_operator, vab, dvab, rab, fba, fbb, scona_shg, sconb_shg, & + omega, calculate_forces) + + INTEGER, INTENT(IN) :: r12_operator + REAL(KIND=dp), DIMENSION(:, :), POINTER :: vab + REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: dvab + REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rab + TYPE(gto_basis_set_type), POINTER :: fba, fbb + REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: scona_shg, sconb_shg + REAL(KIND=dp), INTENT(IN), OPTIONAL :: omega + LOGICAL, INTENT(IN) :: calculate_forces + + CHARACTER(LEN=*), PARAMETER :: routineN = 'two_center_shg_integrals', & + routineP = moduleN//':'//routineN + + INTEGER :: handle + REAL(KIND=dp) :: my_omega + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: Waux_mat + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :, :) :: dWaux_mat + + PROCEDURE(ab_sint_shg), POINTER :: s_operator_ab => null() + + CALL timeset(routineN, handle) + + CALL precalc_angular_shg_part(fba, fbb, rab, Waux_mat, dWaux_mat, calculate_forces) + my_omega = 1.0_dp + + SELECT CASE (r12_operator) + CASE (operator_coulomb) + s_operator_ab => s_coulomb_ab + CASE (operator_verf) + s_operator_ab => s_verf_ab + IF (PRESENT(omega)) my_omega = omega + CASE (operator_verfc) + s_operator_ab => s_verfc_ab + IF (PRESENT(omega)) my_omega = omega + CASE (operator_vgauss) + s_operator_ab => s_vgauss_ab + IF (PRESENT(omega)) my_omega = omega + CASE (operator_gauss) + s_operator_ab => s_gauss_ab + IF (PRESENT(omega)) my_omega = omega + CASE DEFAULT + CPABORT("Operator not available") + END SELECT + + CALL int_operator_ab_shg(s_operator_ab, vab, dvab, rab, fba, fbb, scona_shg, sconb_shg, & + my_omega, Waux_mat, dWaux_mat, calculate_forces) + + DEALLOCATE (Waux_mat, dWaux_mat) + + CALL timestop(handle) + + END SUBROUTINE two_center_shg_integrals + +! ************************************************************************************************** +!> \brief precalculates the angular part of the SHG integrals +!> \param fba basis at center A +!> \param fbb basis at center B +!> \param rab distance vector between a and b +!> \param Waux_mat W matrix that contains the angular-dependent part +!> \param dWaux_mat derivative of the W matrix +!> \param calculate_forces ... +! ************************************************************************************************** + SUBROUTINE precalc_angular_shg_part(fba, fbb, rab, Waux_mat, dWaux_mat, calculate_forces) + + TYPE(gto_basis_set_type), POINTER :: fba, fbb + REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rab + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :), & + INTENT(OUT) :: Waux_mat + REAL(KIND=dp), ALLOCATABLE, & + DIMENSION(:, :, :, :), INTENT(OUT) :: dWaux_mat + LOGICAL, INTENT(IN) :: calculate_forces + + CHARACTER(len=*), PARAMETER :: routineN = 'precalc_angular_shg_part', & + routineP = moduleN//':'//routineN + + INTEGER :: handle, la_max, lb_max, lmax, mdim(3) + INTEGER, DIMENSION(:), POINTER :: la_max_all + REAL(KIND=dp) :: rab2 + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: Rc, Rs + + CALL timeset(routineN, handle) + + NULLIFY (la_max_all) + rab2 = rab(1)*rab(1)+rab(2)*rab(2)+rab(3)*rab(3) + + la_max = MAXVAL(fba%lmax) + lb_max = MAXVAL(fbb%lmax) + lmax = MAX(la_max, lb_max) + + ALLOCATE (la_max_all(0:lb_max)) + ALLOCATE (Rc(0:lmax, -2*lmax:2*lmax), Rs(0:lmax, -2*lmax:2*lmax)) + Rc = 0._dp + Rs = 0._dp + mdim(1) = MIN(la_max, lb_max)+1 + mdim(2) = nsoset(la_max)+1 + mdim(3) = nsoset(lb_max)+1 + ALLOCATE (Waux_mat(mdim(1), mdim(2), mdim(3))) + ALLOCATE (dWaux_mat(3, mdim(1), mdim(2), mdim(3))) + + la_max_all(0:lb_max) = la_max + !*** -rab, since Eq. in Ref. use Ra-Rb, not Rb-Ra + CALL get_real_scaled_solid_harmonic(Rc, Rs, lmax, -rab, rab2) + CALL get_W_matrix(la_max_all, lb_max, lmax, Rc, Rs, Waux_mat) + IF (calculate_forces) THEN + CALL get_dW_matrix(la_max_all, lb_max, Waux_mat, dWaux_mat) + ENDIF + + DEALLOCATE (Rc, Rs, la_max_all) + CALL timestop(handle) + + END SUBROUTINE precalc_angular_shg_part + +! ************************************************************************************************** +!> \brief calculate integrals (a|O(r12)|b) +!> \param s_operator_ab procedure pointer for the respective operator. The integral evaluation +!> differs only in the calculation of the [s|O(r12)|s] integrals and their scalar +!> derivatives. +!> \param vab integral matrix of spherical contracted Gaussian functions +!> \param dvab derivative of the integrals +!> \param rab distance vector between center A and B +!> \param fba basis at center A +!> \param fbb basis at center B +!> \param scona_shg SHG contraction matrix for A +!> \param sconb_shg SHG contraction matrix for B +!> \param omega parameter in the operator +!> \param Waux_mat W matrix that contains the angular-dependent part +!> \param dWaux_mat derivative of the W matrix +!> \param calculate_forces ... +! ************************************************************************************************** + SUBROUTINE int_operator_ab_shg(s_operator_ab, vab, dvab, rab, fba, fbb, scona_shg, sconb_shg, & + omega, Waux_mat, dWaux_mat, calculate_forces) + + PROCEDURE(ab_sint_shg), POINTER :: s_operator_ab + REAL(KIND=dp), DIMENSION(:, :), POINTER :: vab + REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: dvab + REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rab + TYPE(gto_basis_set_type), POINTER :: fba, fbb + REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: scona_shg, sconb_shg + REAL(KIND=dp), INTENT(IN) :: omega + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: Waux_mat + REAL(KIND=dp), DIMENSION(:, :, :, :), INTENT(IN) :: dWaux_mat + LOGICAL, INTENT(IN) :: calculate_forces + + CHARACTER(LEN=*), PARAMETER :: routineN = 'int_operator_ab_shg', routineP = moduleN//':'//routineN + + INTEGER :: handle, iset, jset, la_max_set, lb_max_set, ndev, nds, nds_max, npgfa_set, & + npgfb_set, nseta, nsetb, nsgfa_set, nsgfb_set, nshella_set, nshellb_set, sgfa, sgfb + INTEGER, DIMENSION(:), POINTER :: la_max, lb_max, npgfa, npgfb, nsgfa, & + nsgfb, nshella, nshellb + INTEGER, DIMENSION(:, :), POINTER :: first_sgfa, first_sgfb, la, lb + REAL(KIND=dp) :: dab + REAL(KIND=dp), DIMENSION(:), POINTER :: set_radius_a, set_radius_b + REAL(KIND=dp), DIMENSION(:, :), POINTER :: zeta, zetb + REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: swork, swork_cont + + CALL timeset(routineN, handle) + NULLIFY (la_max, lb_max, npgfa, npgfb, first_sgfa, first_sgfb, set_radius_a, & + set_radius_b, zeta, zetb) + + ! basis ikind + first_sgfa => fba%first_sgf + la_max => fba%lmax + la => fba%l + npgfa => fba%npgf + nsgfa => fba%nsgf_set + nseta = fba%nset + set_radius_a => fba%set_radius + zeta => fba%zet + nshella => fba%nshell + ! basis jkind + first_sgfb => fbb%first_sgf + lb_max => fbb%lmax + lb => fbb%l + npgfb => fbb%npgf + nsgfb => fbb%nsgf_set + nsetb = fbb%nset + set_radius_b => fbb%set_radius + zetb => fbb%zet + nshellb => fbb%nshell + + dab = SQRT(SUM(rab**2)) + + la_max_set = MAXVAL(la_max) + lb_max_set = MAXVAL(lb_max) + + ! allocate some work matrices + npgfa_set = MAXVAL(npgfa) + npgfb_set = MAXVAL(npgfb) + nshella_set = MAXVAL(nshella) + nshellb_set = MAXVAL(nshellb) + nsgfa_set = MAXVAL(nsgfa) + nsgfb_set = MAXVAL(nsgfb) + ndev = 0 + IF (calculate_forces) ndev = 1 + nds_max = la_max_set+lb_max_set+ndev+1 + ALLOCATE (swork(npgfa_set, npgfb_set, nds_max)) + ALLOCATE (swork_cont(nds_max, nshella_set, nshellb_set)) + + vab = 0.0_dp + dvab = 0.0_dp + + DO iset = 1, nseta + sgfa = first_sgfa(1, iset) + + DO jset = 1, nsetb + + sgfb = first_sgfb(1, jset) + CALL s_operator_ab(la_max(iset), npgfa(iset), zeta(:, iset), & + lb_max(jset), npgfb(jset), zetb(:, jset), & + omega, rab, swork, calculate_forces) + nds = la_max(iset)+lb_max(jset)+ndev+1 + CALL contract_sint_ab_chigh(npgfa(iset), nshella(iset), scona_shg(1:npgfa(iset), 1:nshella(iset), iset), & + npgfb(jset), nshellb(jset), sconb_shg(1:npgfb(jset), 1:nshellb(jset), jset), & + nds, swork(1:npgfa(iset), 1:npgfb(jset), 1:nds), & + swork_cont(1:nds, 1:nshella(iset), 1:nshellb(jset))) + CALL construct_int_shg_ab(la(:, iset), first_sgfa(:, iset), nshella(iset), & + lb(:, jset), first_sgfb(:, jset), nshellb(jset), & + swork_cont, Waux_mat, vab) + IF (calculate_forces) THEN + !*** -rab, since Eq. in Ref. use Ra-Rb, not Rb-Ra + CALL construct_dev_shg_ab(la(:, iset), first_sgfa(:, iset), nshella(iset), & + lb(:, jset), first_sgfb(:, jset), nshellb(jset), & + -rab, swork_cont, Waux_mat, dWaux_mat, dvab) + ENDIF + END DO + END DO + + DEALLOCATE (swork, swork_cont) + + CALL timestop(handle) + END SUBROUTINE int_operator_ab_shg + +! ************************************************************************************************** +!> \brief calculate overlap integrals (a,b) +!> \param sab integral (a,b) +!> \param dsab derivative of sab +!> \param rab distance vector +!> \param fba basis at center A +!> \param fbb basis at center B +!> \param scona_shg contraction matrix A +!> \param sconb_shg contraxtion matrix B +!> \param Waux_mat W matrix that contains the angular-dependent part +!> \param dWaux_mat derivative of the W matrix +!> \param calculate_forces ... +! ************************************************************************************************** + SUBROUTINE int_overlap_ab_shg(sab, dsab, rab, fba, fbb, scona_shg, sconb_shg, Waux_mat, dWaux_mat, & + calculate_forces) + + REAL(KIND=dp), DIMENSION(:, :), POINTER :: sab + REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: dsab + REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rab + TYPE(gto_basis_set_type), POINTER :: fba, fbb + REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: scona_shg, sconb_shg + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: Waux_mat + REAL(KIND=dp), DIMENSION(:, :, :, :), INTENT(IN) :: dWaux_mat + LOGICAL, INTENT(IN) :: calculate_forces + + CHARACTER(LEN=*), PARAMETER :: routineN = 'int_overlap_ab_shg', & + routineP = moduleN//':'//routineN + + INTEGER :: handle, iset, jset, la_max_set, & + lb_max_set, ndev, nds_max, npgfa_set, & + npgfb_set, nseta, nsetb, nshella_set, & + nshellb_set + INTEGER, DIMENSION(:), POINTER :: la_max, lb_max, npgfa, npgfb, nshella, & + nshellb + INTEGER, DIMENSION(:, :), POINTER :: first_sgfa, first_sgfb, la, lb + REAL(KIND=dp) :: dab + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: swork, swork_cont + REAL(KIND=dp), DIMENSION(:), POINTER :: set_radius_a, set_radius_b + REAL(KIND=dp), DIMENSION(:, :), POINTER :: zeta, zetb + + CALL timeset(routineN, handle) + NULLIFY (la_max, lb_max, npgfa, npgfb, first_sgfa, first_sgfb, set_radius_a, & + set_radius_b, zeta, zetb) + + ! basis ikind + first_sgfa => fba%first_sgf + la_max => fba%lmax + la => fba%l + npgfa => fba%npgf + nseta = fba%nset + set_radius_a => fba%set_radius + zeta => fba%zet + nshella => fba%nshell + ! basis jkind + first_sgfb => fbb%first_sgf + lb_max => fbb%lmax + lb => fbb%l + npgfb => fbb%npgf + nsetb = fbb%nset + set_radius_b => fbb%set_radius + zetb => fbb%zet + nshellb => fbb%nshell + + dab = SQRT(SUM(rab**2)) + + la_max_set = MAXVAL(la_max) + lb_max_set = MAXVAL(lb_max) + + ! allocate some work matrices + npgfa_set = MAXVAL(npgfa) + npgfb_set = MAXVAL(npgfb) + nshella_set = MAXVAL(nshella) + nshellb_set = MAXVAL(nshellb) + ndev = 0 + IF (calculate_forces) ndev = 1 + nds_max = la_max_set+lb_max_set+ndev+1 + ALLOCATE (swork(npgfa_set, npgfb_set, nds_max)) + ALLOCATE (swork_cont(nds_max, nshella_set, nshellb_set)) + + DO iset = 1, nseta + + DO jset = 1, nsetb + + IF (set_radius_a(iset)+set_radius_b(jset) < dab) CYCLE + + CALL s_overlap_ab(la_max(iset), npgfa(iset), zeta(:, iset), & + lb_max(jset), npgfb(jset), zetb(:, jset), & + rab, swork, calculate_forces) + CALL contract_sint_ab_clow(la(:, iset), npgfa(iset), nshella(iset), & + zeta(:, iset), scona_shg(:, :, iset), & + lb(:, jset), npgfb(jset), nshellb(jset), & + zetb(:, jset), sconb_shg(:, :, jset), & + swork, swork_cont, calculate_forces) + CALL construct_int_shg_ab(la(:, iset), first_sgfa(:, iset), nshella(iset), & + lb(:, jset), first_sgfb(:, jset), nshellb(jset), & + swork_cont, Waux_mat, sab) + IF (calculate_forces) THEN + !*** -rab, since Eq. in Ref. use Ra-Rb, not Rb-Ra + CALL construct_dev_shg_ab(la(:, iset), first_sgfa(:, iset), nshella(iset), & + lb(:, jset), first_sgfb(:, jset), nshellb(jset), & + -rab, swork_cont, Waux_mat, dWaux_mat, dsab) + ENDIF + END DO + END DO + + DEALLOCATE (swork, swork_cont) + + CALL timestop(handle) + + END SUBROUTINE int_overlap_ab_shg + +! ************************************************************************************************** +!> \brief calculate integrals (a,b,fa) +!> \param abaint integral (a,b,fa) +!> \param dabdaint ... +!> \param rab distance vector between A and B +!> \param oba orbital basis at center A +!> \param obb orbital basis at center B +!> \param fba auxiliary basis set at center A +!> \param scona_shg contraction matrix for orb bas on A +!> \param sconb_shg contraction matrix for orb bas on B +!> \param sconca_shg contraction matrix for aux bas on A +!> \param cg_coeff Clebsch-Gordon coefficients +!> \param cg_none0_list list of none-zero Clebsch-Gordon coefficients +!> \param ncg_none0 number of non-zero Clebsch-Gordon coefficients +!> \param Waux_mat W matrix that contains the angular-dependent part +!> \param dWaux_mat derivative of the W matrix +!> \param calculate_forces ... +! ************************************************************************************************** + SUBROUTINE int_overlap_aba_shg(abaint, dabdaint, rab, oba, obb, fba, scona_shg, & + sconb_shg, sconca_shg, cg_coeff, cg_none0_list, ncg_none0, & + Waux_mat, dWaux_mat, calculate_forces) + + REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: abaint + REAL(KIND=dp), DIMENSION(:, :, :, :), POINTER :: dabdaint + REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rab + TYPE(gto_basis_set_type), POINTER :: oba, obb, fba + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: scona_shg, sconb_shg, sconca_shg, & + cg_coeff + INTEGER, DIMENSION(:, :, :), INTENT(IN) :: cg_none0_list + INTEGER, DIMENSION(:, :), INTENT(IN) :: ncg_none0 + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: Waux_mat + REAL(KIND=dp), DIMENSION(:, :, :, :), INTENT(IN) :: dWaux_mat + LOGICAL, INTENT(IN) :: calculate_forces + + CHARACTER(LEN=*), PARAMETER :: routineN = 'int_overlap_aba_shg', & + routineP = moduleN//':'//routineN + + INTEGER :: handle, iset, jset, kset, la_max_set, laa_max_set, lb_max_set, lca_max_set, ndev, & + nds_max, nl_set, npgfa_set, npgfb_set, npgfca_set, nseta, nsetb, nsetca, nshella_set, & + nshellb_set, nshellca_set + INTEGER, DIMENSION(:), POINTER :: la_max, lb_max, lca_max, npgfa, npgfb, & + npgfca, nshella, nshellb, nshellca + INTEGER, DIMENSION(:, :), POINTER :: first_sgfa, first_sgfb, first_sgfca, la, & + lb, lca + REAL(KIND=dp) :: dab, rab2 + REAL(KIND=dp), ALLOCATABLE, & + DIMENSION(:, :, :, :, :) :: swork, swork_cont + REAL(KIND=dp), DIMENSION(:), POINTER :: set_radius_a, set_radius_b, set_radius_ca + REAL(KIND=dp), DIMENSION(:, :), POINTER :: zeta, zetb, zetca + + CALL timeset(routineN, handle) + NULLIFY (la_max, lb_max, lca_max, npgfa, npgfb, npgfca) + NULLIFY (first_sgfa, first_sgfb, first_sgfca, set_radius_a, set_radius_b, & + set_radius_ca, zeta, zetb, zetca) + + ! basis ikind + first_sgfa => oba%first_sgf + la_max => oba%lmax + la => oba%l + npgfa => oba%npgf + nshella => oba%nshell + nseta = oba%nset + set_radius_a => oba%set_radius + zeta => oba%zet + ! basis jkind + first_sgfb => obb%first_sgf + lb_max => obb%lmax + lb => obb%l + npgfb => obb%npgf + nshellb => obb%nshell + nsetb = obb%nset + set_radius_b => obb%set_radius + zetb => obb%zet + + ! basis RI A + first_sgfca => fba%first_sgf + lca_max => fba%lmax + lca => fba%l + npgfca => fba%npgf + nshellca => fba%nshell + nsetca = fba%nset + set_radius_ca => fba%set_radius + zetca => fba%zet + + dab = SQRT(SUM(rab**2)) + rab2 = rab(1)*rab(1)+rab(2)*rab(2)+rab(3)*rab(3) + + la_max_set = MAXVAL(la_max) + lb_max_set = MAXVAL(lb_max) + lca_max_set = MAXVAL(lca_max) + npgfa_set = MAXVAL(npgfa) + npgfb_set = MAXVAL(npgfb) + npgfca_set = MAXVAL(npgfca) + nshella_set = MAXVAL(nshella) + nshellb_set = MAXVAL(nshellb) + nshellca_set = MAXVAL(nshellca) + !*** for forces: derivative+1 in auxiliary vector required + ndev = 0 + IF (calculate_forces) ndev = 1 + + laa_max_set = la_max_set+lca_max_set + + ! allocate some work storage.... + nds_max = laa_max_set+lb_max_set+ndev+1 + nl_set = INT((laa_max_set)/2) + ALLOCATE (swork(npgfa_set, npgfb_set, npgfca_set, 0:nl_set, nds_max)) + ALLOCATE (swork_cont(nds_max, 0:nl_set, nshella_set, nshellb_set, nshellca_set)) + + DO iset = 1, nseta + + DO jset = 1, nsetb + + IF (set_radius_a(iset)+set_radius_b(jset) < dab) CYCLE + + DO kset = 1, nsetca + + IF (set_radius_b(jset)+set_radius_ca(kset) < dab) CYCLE + + CALL s_overlap_abx(la_max(iset), npgfa(iset), zeta(:, iset), & + lb_max(jset), npgfb(jset), zetb(:, jset), & + lca_max(kset), npgfca(kset), zetca(:, kset), & + rab, swork, calculate_forces, calc_aba=.TRUE.) + + CALL contract_s_overlap_aba(la(:, iset), npgfa(iset), nshella(iset), zeta(:, iset), scona_shg(:, :, iset), & + lb(:, jset), npgfb(jset), nshellb(jset), zetb(:, jset), sconb_shg(:, :, jset), & + lca(:, kset), npgfca(kset), nshellca(kset), zetca(:, kset), sconca_shg(:, :, kset), & + swork, swork_cont, calculate_forces) + + CALL construct_overlap_shg_aba(la(:, iset), first_sgfa(:, iset), nshella(iset), & + lb(:, jset), first_sgfb(:, jset), nshellb(jset), & + lca(:, kset), first_sgfca(:, kset), nshellca(kset), & + cg_coeff, cg_none0_list, ncg_none0, & + swork_cont, Waux_mat, abaint) + IF (calculate_forces) THEN + !*** -rab, since Eq. in Ref. use Ra-Rb, not Rb-Ra + CALL dev_overlap_shg_aba(la(:, iset), first_sgfa(:, iset), nshella(iset), & + lb(:, jset), first_sgfb(:, jset), nshellb(jset), & + lca(:, kset), first_sgfca(:, kset), nshellca(kset), & + cg_coeff, cg_none0_list, ncg_none0, & + -rab, swork_cont, Waux_mat, dWaux_mat, dabdaint) + ENDIF + + END DO + END DO + END DO + + DEALLOCATE (swork_cont) + DEALLOCATE (swork) + + CALL timestop(handle) + + END SUBROUTINE int_overlap_aba_shg + +! ************************************************************************************************** +!> \brief calculate integrals (a,b,fb) +!> \param abbint integral (a,b,fb) +!> \param dabbint derivative of abbint +!> \param rab distance vector between A and B +!> \param oba orbital basis at center A +!> \param obb orbital basis at center B +!> \param fbb auxiliary basis set at center B +!> \param scona_shg contraction matrix for orb bas on A +!> \param sconb_shg contraction matrix for orb bas on B +!> \param sconcb_shg contraction matrix for aux bas on B +!> \param cg_coeff Clebsch-Gordon coefficients +!> \param cg_none0_list list of none-zero Clebsch-Gordon coefficients +!> \param ncg_none0 number of non-zero Clebsch-Gordon coefficients +!> \param Waux_mat W matrix that contains the angular-dependent part +!> \param dWaux_mat derivative of the W matrix +!> \param calculate_forces ... +! ************************************************************************************************** + SUBROUTINE int_overlap_abb_shg(abbint, dabbint, rab, oba, obb, fbb, scona_shg, & + sconb_shg, sconcb_shg, cg_coeff, cg_none0_list, ncg_none0, & + Waux_mat, dWaux_mat, calculate_forces) + + REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: abbint + REAL(KIND=dp), DIMENSION(:, :, :, :), POINTER :: dabbint + REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rab + TYPE(gto_basis_set_type), POINTER :: oba, obb, fbb + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: scona_shg, sconb_shg, sconcb_shg, & + cg_coeff + INTEGER, DIMENSION(:, :, :), INTENT(IN) :: cg_none0_list + INTEGER, DIMENSION(:, :), INTENT(IN) :: ncg_none0 + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: Waux_mat + REAL(KIND=dp), DIMENSION(:, :, :, :), INTENT(IN) :: dWaux_mat + LOGICAL, INTENT(IN) :: calculate_forces + + CHARACTER(LEN=*), PARAMETER :: routineN = 'int_overlap_abb_shg', & + routineP = moduleN//':'//routineN + + INTEGER :: handle, iset, jset, kset, la_max_set, lb_max_set, lbb_max_set, lcb_max_set, ndev, & + nds_max, nl_set, npgfa_set, npgfb_set, npgfcb_set, nseta, nsetb, nsetcb, nshella_set, & + nshellb_set, nshellcb_set + INTEGER, DIMENSION(:), POINTER :: la_max, lb_max, lcb_max, npgfa, npgfb, & + npgfcb, nshella, nshellb, nshellcb + INTEGER, DIMENSION(:, :), POINTER :: first_sgfa, first_sgfb, first_sgfcb, la, & + lb, lcb + REAL(KIND=dp) :: dab, rab2 + REAL(KIND=dp), ALLOCATABLE, & + DIMENSION(:, :, :, :, :) :: swork, swork_cont + REAL(KIND=dp), DIMENSION(:), POINTER :: set_radius_a, set_radius_b, set_radius_cb + REAL(KIND=dp), DIMENSION(:, :), POINTER :: zeta, zetb, zetcb + + CALL timeset(routineN, handle) + NULLIFY (la_max, lb_max, lcb_max, npgfa, npgfb, npgfcb) + NULLIFY (first_sgfa, first_sgfb, first_sgfcb, set_radius_a, set_radius_b, & + set_radius_cb, zeta, zetb, zetcb) + + ! basis ikind + first_sgfa => oba%first_sgf + la_max => oba%lmax + la => oba%l + npgfa => oba%npgf + nshella => oba%nshell + nseta = oba%nset + set_radius_a => oba%set_radius + zeta => oba%zet + ! basis jkind + first_sgfb => obb%first_sgf + lb_max => obb%lmax + lb => obb%l + npgfb => obb%npgf + nshellb => obb%nshell + nsetb = obb%nset + set_radius_b => obb%set_radius + zetb => obb%zet + + ! basis RI on B + first_sgfcb => fbb%first_sgf + lcb_max => fbb%lmax + lcb => fbb%l + npgfcb => fbb%npgf + nshellcb => fbb%nshell + nsetcb = fbb%nset + set_radius_cb => fbb%set_radius + zetcb => fbb%zet + + dab = SQRT(SUM(rab**2)) + rab2 = rab(1)*rab(1)+rab(2)*rab(2)+rab(3)*rab(3) + + la_max_set = MAXVAL(la_max) + lb_max_set = MAXVAL(lb_max) + lcb_max_set = MAXVAL(lcb_max) + npgfa_set = MAXVAL(npgfa) + npgfb_set = MAXVAL(npgfb) + npgfcb_set = MAXVAL(npgfcb) + nshella_set = MAXVAL(nshella) + nshellb_set = MAXVAL(nshellb) + nshellcb_set = MAXVAL(nshellcb) + !*** for forces: derivative+1 in auxiliary vector required + ndev = 0 + IF (calculate_forces) ndev = 1 + + lbb_max_set = lb_max_set+lcb_max_set + + ! allocate some work storage.... + nds_max = la_max_set+lbb_max_set+ndev+1 + nl_set = INT((lbb_max_set)/2) + ALLOCATE (swork(1:npgfa_set, 1:npgfb_set, 1:npgfcb_set, 0:nl_set, 1:nds_max)) + ALLOCATE (swork_cont(nds_max, 0:nl_set, nshella_set, nshellb_set, nshellcb_set)) + + DO iset = 1, nseta + + DO jset = 1, nsetb + + IF (set_radius_a(iset)+set_radius_b(jset) < dab) CYCLE + + DO kset = 1, nsetcb + + IF (set_radius_a(iset)+set_radius_cb(kset) < dab) CYCLE + + CALL s_overlap_abx(la_max(iset), npgfa(iset), zeta(:, iset), & + lb_max(jset), npgfb(jset), zetb(:, jset), & + lcb_max(kset), npgfcb(kset), zetcb(:, kset), & + rab, swork, calculate_forces, calc_aba=.FALSE.) + + CALL contract_s_overlap_abb(la(:, iset), npgfa(iset), nshella(iset), zeta(:, iset), scona_shg(:, :, iset), & + lb(:, jset), npgfb(jset), nshellb(jset), zetb(:, jset), sconb_shg(:, :, jset), & + lcb(:, kset), npgfcb(kset), nshellcb(kset), zetcb(:, kset), sconcb_shg(:, :, kset), & + swork, swork_cont, calculate_forces) + + CALL construct_overlap_shg_abb(la(:, iset), first_sgfa(:, iset), nshella(iset), & + lb(:, jset), first_sgfb(:, jset), nshellb(jset), & + lcb(:, kset), first_sgfcb(:, kset), nshellcb(kset), & + cg_coeff, cg_none0_list, & + ncg_none0, swork_cont, Waux_mat, abbint) + IF (calculate_forces) THEN + !*** -rab, since Eq. in Ref. use Ra-Rb, not Rb-Ra + CALL dev_overlap_shg_abb(la(:, iset), first_sgfa(:, iset), nshella(iset), & + lb(:, jset), first_sgfb(:, jset), nshellb(jset), & + lcb(:, kset), first_sgfcb(:, kset), nshellcb(kset), & + cg_coeff, cg_none0_list, ncg_none0, -rab, swork_cont, & + Waux_mat, dWaux_mat, dabbint) + ENDIF + + END DO + END DO + END DO + + DEALLOCATE (swork_cont) + DEALLOCATE (swork) + + CALL timestop(handle) + + END SUBROUTINE int_overlap_abb_shg + +! ************************************************************************************************** +!> \brief precalculates the angular part of the SHG integrals for the matrices +!> (fa,fb), (a,b), (a,b,fa) and (b,fb,a); the same Waux_mat can then be used for all +!> for integrals; specific for LRIGPW +!> \param oba orbital basis on a +!> \param obb orbital basis on b +!> \param fba aux basis on a +!> \param fbb aux basis on b +!> \param rab distance vector between a and b +!> \param Waux_mat W matrix that contains the angular-dependent part +!> \param dWaux_mat derivative of the W matrix +!> \param calculate_forces ... +! ************************************************************************************************** + SUBROUTINE lri_precalc_angular_shg_part(oba, obb, fba, fbb, rab, Waux_mat, dWaux_mat, calculate_forces) + + TYPE(gto_basis_set_type), POINTER :: oba, obb, fba, fbb + REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rab + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :), & + INTENT(OUT) :: Waux_mat + REAL(KIND=dp), ALLOCATABLE, & + DIMENSION(:, :, :, :), INTENT(OUT) :: dWaux_mat + LOGICAL, INTENT(IN) :: calculate_forces + + CHARACTER(len=*), PARAMETER :: routineN = 'lri_precalc_angular_shg_part', & + routineP = moduleN//':'//routineN + + INTEGER :: handle, i, isize, j, k, la_max, laa_max, & + lb_max, lbb_max, lca_max, lcb_max, & + li_max, lj_max, lmax, mdim(3), & + size_int(4, 2), temp + INTEGER, DIMENSION(:), POINTER :: li_max_all + REAL(KIND=dp) :: rab2 + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: Rc, Rs + + CALL timeset(routineN, handle) + + rab2 = rab(1)*rab(1)+rab(2)*rab(2)+rab(3)*rab(3) + + !*** 1 Waux_mat of size (li_max,lj_max) for elements + ! i j + ! [aab] --> (laa_max, lb_max) + ! [bba] --> (lbb_max, la_max) --> use for [abb] + ! [ab] ri --> (lca_max, lcb_max) + ! [ab] orb --> (la_max , lb_max) + + la_max = MAXVAL(oba%lmax) + lb_max = MAXVAL(obb%lmax) + lca_max = MAXVAL(fba%lmax) + lcb_max = MAXVAL(fbb%lmax) + + laa_max = la_max+lca_max + lbb_max = lb_max+lcb_max + li_max = MAX(laa_max, lbb_max) + lj_max = MAX(la_max, lb_max, lcb_max) + lmax = li_max + + ALLOCATE (li_max_all(0:lj_max)) + ALLOCATE (Rc(0:lmax, -2*lmax:2*lmax), Rs(0:lmax, -2*lmax:2*lmax)) + Rc = 0._dp + Rs = 0._dp + mdim(1) = li_max+lj_max+1 + mdim(2) = nsoset(li_max)+1 + mdim(3) = nsoset(lj_max)+1 + ALLOCATE (Waux_mat(mdim(1), mdim(2), mdim(3))) + ALLOCATE (dWaux_mat(3, mdim(1), mdim(2), mdim(3))) + !Waux_mat = 0._dp !.. takes time + !dWaux_mat =0._dp !.. takes time + + !*** Waux_mat (li_max,lj_max) contains elements not needed, + !*** make indixing so that only required ones are computed + !*** li_max_all(j) --> li_max dependent on j + size_int(1, :) = (/laa_max, lb_max/) + size_int(2, :) = (/lbb_max, la_max/) + size_int(3, :) = (/lca_max, lcb_max/) + size_int(4, :) = (/la_max, lb_max/) + + li_max_all(:) = 0 + DO isize = 1, 4 + i = size_int(isize, 1) + j = size_int(isize, 2) + k = li_max_all(j) + IF (k < i) li_max_all(j) = i + ENDDO + temp = li_max_all(lj_max) + DO j = lj_max, 0, -1 + IF (li_max_all(j) < temp) THEN + li_max_all(j) = temp + ELSE + temp = li_max_all(j) + ENDIF + ENDDO + + !*** -rab, since Eq. in Ref. use Ra-Rb, not Rb-Ra + CALL get_real_scaled_solid_harmonic(Rc, Rs, lmax, -rab, rab2) + CALL get_W_matrix(li_max_all, lj_max, lmax, Rc, Rs, Waux_mat) + IF (calculate_forces) THEN + CALL get_dW_matrix(li_max_all, lj_max, Waux_mat, dWaux_mat) + ENDIF + + DEALLOCATE (Rc, Rs, li_max_all) + + CALL timestop(handle) + + END SUBROUTINE lri_precalc_angular_shg_part + +END MODULE generic_shg_integrals diff --git a/src/input_constants.F b/src/input_constants.F index 33a45dd3b9..840db566af 100644 --- a/src/input_constants.F +++ b/src/input_constants.F @@ -989,4 +989,10 @@ MODULE input_constants INTEGER, PARAMETER, PUBLIC :: do_eri_gpw = 0, & do_eri_mme = 1 + ! operators for integrals + INTEGER, PARAMETER, PUBLIC :: operator_coulomb = 0, & + operator_verf = 1, & + operator_verfc = 2, & + operator_vgauss = 3, & + operator_gauss = 4 END MODULE input_constants diff --git a/src/input_cp2k_subsys.F b/src/input_cp2k_subsys.F index f838f9e1ba..621935439c 100644 --- a/src/input_cp2k_subsys.F +++ b/src/input_cp2k_subsys.F @@ -62,7 +62,8 @@ MODULE input_cp2k_subsys PUBLIC :: create_subsys_section, & create_cell_section, & create_structure_data_section, & - create_rng_section + create_rng_section, & + create_basis_section !*** CONTAINS diff --git a/src/library_tests.F b/src/library_tests.F index 44ba5d3fff..06dbd8de7e 100644 --- a/src/library_tests.F +++ b/src/library_tests.F @@ -105,6 +105,7 @@ MODULE library_tests pw2rs, realspace_grid_desc_type, realspace_grid_input_type, realspace_grid_type, rs2pw, & rs_grid_create, rs_grid_create_descriptor, rs_grid_print, rs_grid_release, & rs_grid_release_descriptor, rs_grid_zero, rs_pw_transfer + USE shg_integrals_test, ONLY: shg_integrals_perf_acc_test USE termination, ONLY: stop_memory #include "./base/base_uses.f90" @@ -141,7 +142,8 @@ CONTAINS LOGICAL :: explicit TYPE(cp_logger_type), POINTER :: logger TYPE(section_vals_type), POINTER :: cp_dbcsr_test_section, cp_fm_gemm_test_section, & - eigensolver_section, eri_mme_test_section, pw_transfer_section, rs_pw_transfer_section + eigensolver_section, eri_mme_test_section, pw_transfer_section, rs_pw_transfer_section, & + shg_integrals_test_section CALL timeset(routineN, handle) @@ -206,6 +208,12 @@ CONTAINS CALL eri_mme_perf_acc_test(para_env, iw, eri_mme_test_section) ENDIF + shg_integrals_test_section => section_vals_get_subs_vals(root_section, "TEST%SHG_INTEGRALS_TEST") + CALL section_vals_get(shg_integrals_test_section, explicit=explicit) + IF (explicit) THEN + CALL shg_integrals_perf_acc_test(iw, shg_integrals_test_section) + ENDIF + ! DBCSR tests ! matrix_multiplication cp_dbcsr_test_section => section_vals_get_subs_vals(root_section, & diff --git a/src/lri_environment_init.F b/src/lri_environment_init.F index 470469c52d..7fff0e2a49 100644 --- a/src/lri_environment_init.F +++ b/src/lri_environment_init.F @@ -410,7 +410,7 @@ CONTAINS END SUBROUTINE basis_ovlp -!***************************************************************************** +! ************************************************************************************************** !> \brief contraction matrix for SHG integrals !> \param basis ... !> \param scon_shg contraction matrix @@ -438,6 +438,7 @@ CONTAINS maxshell = SIZE(basis%gcc, 2) ALLOCATE (norm(basis%nset, maxshell)) ALLOCATE (scon_shg(maxpgf, maxshell, nset)) + scon_shg = 0.0_dp CALL basis_norm_shg(basis, norm) diff --git a/src/lri_environment_methods.F b/src/lri_environment_methods.F index 4ad1784337..081f21cd23 100644 --- a/src/lri_environment_methods.F +++ b/src/lri_environment_methods.F @@ -29,6 +29,14 @@ MODULE lri_environment_methods USE cp_output_handling, ONLY: cp_print_key_finished_output,& cp_print_key_unit_nr USE cp_para_types, ONLY: cp_para_env_type + USE generic_os_integrals, ONLY: int_overlap_aabb_os,& + int_overlap_ab_os,& + int_overlap_aba_os,& + int_overlap_abb_os + USE generic_shg_integrals, ONLY: int_overlap_ab_shg,& + int_overlap_aba_shg,& + int_overlap_abb_shg,& + lri_precalc_angular_shg_part USE input_constants, ONLY: do_lri_inv,& do_lri_inv_auto,& do_lri_pseudoinv_diag,& @@ -40,14 +48,6 @@ MODULE lri_environment_methods deallocate_lri_ints, deallocate_lri_ints_rho, lri_density_create, lri_density_release, & lri_density_type, lri_environment_type, lri_int_rho_type, lri_int_type, lri_kind_type, & lri_list_type, lri_rhoab_type - USE lri_os_integrals, ONLY: lri_int_aabb,& - lri_int_ab,& - lri_int_aba,& - lri_int_abb - USE lri_shg_integrals, ONLY: lri_int_ab_shg,& - lri_int_aba_shg,& - lri_int_abb_shg,& - precalc_angular_shg_part USE mathlib, ONLY: get_pseudo_inverse_diag,& get_pseudo_inverse_svd,& invmat_symm @@ -165,7 +165,6 @@ CONTAINS CALL get_iterator_info(nl_iterator, ikind=ikind, jkind=jkind, & nlist=nlist, ilist=ilist, nnode=nneighbor, inode=jneighbor, & iatom=iatom, jatom=jatom, r=rab) - iac = ikind+nkind*(jkind-1) dab = SQRT(SUM(rab*rab)) @@ -200,7 +199,6 @@ CONTAINS CALL lri_int_os(lri_env, lrii, ra, rb, rab, obasa, obasb, fbasa, fbasb, & iatom, jatom, ikind) ENDIF - ! construct and invert S matrix lrii%sinv(1:nfa, 1:nfa) = lri_env%bas_prop(ikind)%ri_ovlp(1:nfa, 1:nfa) IF (dab > lri_env%delta) THEN @@ -311,8 +309,8 @@ CONTAINS rb(:) = pbc(particle_set(jatom)%r, cell) ! calculate integrals (aa,bb) - CALL lri_int_aabb(lriir%soaabb, obasa, obasb, rab, ra, rb, lri_env%debug, & - lriir%dmax_aabb) + CALL int_overlap_aabb_os(lriir%soaabb, obasa, obasb, rab, ra, rb, lri_env%debug, & + lriir%dmax_aabb) END DO @@ -678,26 +676,26 @@ CONTAINS lrii%soo(1:nba, 1:nba) = lri_env%bas_prop(ikind)%orb_ovlp(1:nba, 1:nba) lrii%dsoo = 0._dp !*** (a,a,fa) - CALL lri_int_aba(lrii%abaint, ra=ra, rb=rb, rab=rab, oba=obasa, obb=obasb, & - fba=fbasa, calculate_forces=.FALSE., debug=lri_env%debug, & - dmax=lrii%dmax_aba) + CALL int_overlap_aba_os(lrii%abaint, ra=ra, rb=rb, rab=rab, oba=obasa, obb=obasb, & + fba=fbasa, calculate_forces=.FALSE., debug=lri_env%debug, & + dmax=lrii%dmax_aba) lrii%dabdaint = 0.0_dp lrii%dabbint = 0.0_dp ELSE !*** (fa,fb) - CALL lri_int_ab(lrii%sab, lrii%dsab, ra, rb, rab, fbasa, fbasb, & - lrii%calc_force_pair, lri_env%debug, & - lrii%dmax_ab) + CALL int_overlap_ab_os(lrii%sab, lrii%dsab, ra, rb, rab, fbasa, fbasb, & + lrii%calc_force_pair, lri_env%debug, & + lrii%dmax_ab) !*** (a,b) - CALL lri_int_ab(lrii%soo, lrii%dsoo, ra, rb, rab, obasa, obasb, & - lrii%calc_force_pair, lri_env%debug, & - lrii%dmax_oo) + CALL int_overlap_ab_os(lrii%soo, lrii%dsoo, ra, rb, rab, obasa, obasb, & + lrii%calc_force_pair, lri_env%debug, & + lrii%dmax_oo) !*** (a,b,fa) - CALL lri_int_aba(lrii%abaint, lrii%dabdaint, ra, rb, rab, obasa, obasb, fbasa, & - lrii%calc_force_pair, lri_env%debug, lrii%dmax_aba) + CALL int_overlap_aba_os(lrii%abaint, lrii%dabdaint, ra, rb, rab, obasa, obasb, fbasa, & + lrii%calc_force_pair, lri_env%debug, lrii%dmax_aba) !*** (a,b,fb) - CALL lri_int_abb(lrii%abbint, lrii%dabbint, ra, rb, rab, obasa, obasb, fbasb, & - lrii%calc_force_pair, lri_env%debug, lrii%dmax_abb) + CALL int_overlap_abb_os(lrii%abbint, lrii%dabbint, ra, rb, rab, obasa, obasb, fbasb, & + lrii%calc_force_pair, lri_env%debug, lrii%dmax_abb) ENDIF CALL timestop(handle) @@ -733,13 +731,12 @@ CONTAINS INTEGER :: handle, nba, nbb, nfa, nfb REAL(KIND=dp) :: dab + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: Waux_mat + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :, :) :: dWaux_mat REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: scon_orba, scon_orbb, scon_ria, scon_rib - REAL(KIND=dp), DIMENSION(:, :, :, :), POINTER :: Waux_mat - REAL(KIND=dp), DIMENSION(:, :, :, :, :), POINTER :: dWaux_mat CALL timeset(routineN, handle) - NULLIFY (scon_orba, scon_orbb, scon_ria, scon_rib, Waux_mat, dWaux_mat) - + NULLIFY (scon_orba, scon_orbb, scon_ria, scon_rib) dab = SQRT(SUM(rab*rab)) nba = obasa%nsgf nbb = obasb%nsgf @@ -755,9 +752,9 @@ CONTAINS lrii%soo(1:nba, 1:nba) = lri_env%bas_prop(ikind)%orb_ovlp(1:nba, 1:nba) lrii%dsoo = 0._dp !*** (a,a,fa) - CALL lri_int_aba(lrii%abaint, ra=ra, rb=rb, rab=rab, oba=obasa, obb=obasb, & - fba=fbasa, calculate_forces=.FALSE., debug=lri_env%debug, & - dmax=lrii%dmax_aba) + CALL int_overlap_aba_os(lrii%abaint, ra=ra, rb=rb, rab=rab, oba=obasa, obb=obasb, & + fba=fbasa, calculate_forces=.FALSE., debug=lri_env%debug, & + dmax=lrii%dmax_aba) lrii%dabdaint = 0.0_dp lrii%dabbint = 0.0_dp ELSE @@ -765,22 +762,23 @@ CONTAINS scon_orbb => lri_env%bas_prop(jkind)%scon_orb scon_ria => lri_env%bas_prop(ikind)%scon_ri scon_rib => lri_env%bas_prop(jkind)%scon_ri - CALL precalc_angular_shg_part(obasa, obasb, fbasa, fbasb, rab, Waux_mat, dWaux_mat, & - lrii%calc_force_pair) + CALL lri_precalc_angular_shg_part(obasa, obasb, fbasa, fbasb, rab, Waux_mat, dWaux_mat, lrii%calc_force_pair) !*** (fa,fb) - CALL lri_int_ab_shg(lrii%sab, lrii%dsab, rab, fbasa, fbasb, scon_ria, scon_rib, & - Waux_mat, dWaux_mat, lrii%calc_force_pair) + CALL int_overlap_ab_shg(lrii%sab, lrii%dsab, rab, fbasa, fbasb, scon_ria, scon_rib, & + Waux_mat, dWaux_mat, lrii%calc_force_pair) !*** (a,b) - CALL lri_int_ab_shg(lrii%soo, lrii%dsoo, rab, obasa, obasb, scon_orba, scon_orbb, & - Waux_mat, dWaux_mat, lrii%calc_force_pair) + CALL int_overlap_ab_shg(lrii%soo, lrii%dsoo, rab, obasa, obasb, scon_orba, scon_orbb, & + Waux_mat, dWaux_mat, lrii%calc_force_pair) !*** (a,b,fa) - CALL lri_int_aba_shg(lri_env, lrii%abaint, lrii%dabdaint, rab, obasa, obasb, fbasa, & - scon_orba, scon_orbb, scon_ria, Waux_mat, dWaux_mat, & - lrii%calc_force_pair) + CALL int_overlap_aba_shg(lrii%abaint, lrii%dabdaint, rab, obasa, obasb, fbasa, & + scon_orba, scon_orbb, scon_ria, & + lri_env%cg_shg%cg_coeff, lri_env%cg_shg%cg_none0_list, & + lri_env%cg_shg%ncg_none0, Waux_mat, dWaux_mat, lrii%calc_force_pair) !*** (a,b,fb) - CALL lri_int_abb_shg(lri_env, lrii%abbint, lrii%dabbint, rab, obasa, obasb, fbasb, & - scon_orba, scon_orbb, scon_rib, Waux_mat, dWaux_mat, & - lrii%calc_force_pair) + CALL int_overlap_abb_shg(lrii%abbint, lrii%dabbint, rab, obasa, obasb, fbasb, & + scon_orba, scon_orbb, scon_rib, & + lri_env%cg_shg%cg_coeff, lri_env%cg_shg%cg_none0_list, & + lri_env%cg_shg%ncg_none0, Waux_mat, dWaux_mat, lrii%calc_force_pair) DEALLOCATE (Waux_mat, dWaux_mat) ENDIF diff --git a/src/lri_environment_types.F b/src/lri_environment_types.F index 932c9e10b4..f0bb79abcf 100644 --- a/src/lri_environment_types.F +++ b/src/lri_environment_types.F @@ -72,25 +72,25 @@ MODULE lri_environment_types ! condition number of overlap matrix REAL(KIND=dp) :: cond_num ! integrals (a,b,ai) - REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: abaint - ! integrals (a,b,bi) - REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: abbint + REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: abaint + ! integrals (a,b,b) + REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: abbint ! integrals (da/dA,b,dai/dA) - REAL(KIND=dp), DIMENSION(:, :, :, :), POINTER :: dabdaint + REAL(KIND=dp), DIMENSION(:, :, :, :), POINTER :: dabdaint ! integrals (da/dA,b,bi) - REAL(KIND=dp), DIMENSION(:, :, :, :), POINTER :: dabbint + REAL(KIND=dp), DIMENSION(:, :, :, :), POINTER :: dabbint ! integrals (a,b) - REAL(KIND=dp), DIMENSION(:, :), POINTER :: soo + REAL(KIND=dp), DIMENSION(:, :), POINTER :: soo ! derivative d(a,b)/dA - REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: dsoo + REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: dsoo ! integrals (ai,bi) - REAL(KIND=dp), DIMENSION(:, :), POINTER :: sab + REAL(KIND=dp), DIMENSION(:, :), POINTER :: sab ! derivative d(ai,bi)/dA - REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: dsab + REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: dsab ! derivative of fit coeff dacoef/dpmatrix - REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: dacoef + REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: dacoef ! inverse of integrals (ai,bi) - REAL(KIND=dp), DIMENSION(:, :), POINTER :: sinv + REAL(KIND=dp), DIMENSION(:, :), POINTER :: sinv ! integral (ai) / (bi), dim(1..nfa,nfa+1..nfa+nfb) REAL(KIND=dp), DIMENSION(:), POINTER :: n ! sinv * (ai) @@ -142,13 +142,13 @@ MODULE lri_environment_types ! integral of ri basis fbas REAL(KIND=dp), DIMENSION(:), POINTER :: int_fbas ! self overlap ri basis - REAL(KIND=dp), DIMENSION(:, :), POINTER :: ri_ovlp + REAL(KIND=dp), DIMENSION(:, :), POINTER :: ri_ovlp ! self overlap orb basis - REAL(KIND=dp), DIMENSION(:, :), POINTER :: orb_ovlp + REAL(KIND=dp), DIMENSION(:, :), POINTER :: orb_ovlp ! contraction matrix for SHG integrals ri basis - REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: scon_ri + REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: scon_ri ! contraction matrix for SHG integrals orb basis - REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: scon_orb + REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: scon_orb END TYPE lri_bas_type ! ************************************************************************************************** @@ -159,7 +159,7 @@ MODULE lri_environment_types ! list of non-zero CG coefficients INTEGER, DIMENSION(:, :, :), POINTER :: cg_none0_list ! number of non-zero CG coefficients - INTEGER, DIMENSION(:, :), POINTER :: ncg_none0 + INTEGER, DIMENSION(:, :), POINTER :: ncg_none0 END TYPE lri_clebsch_gordon_type ! ************************************************************************************************** diff --git a/src/lri_shg_integrals.F b/src/lri_shg_integrals.F deleted file mode 100644 index 88d753a2e6..0000000000 --- a/src/lri_shg_integrals.F +++ /dev/null @@ -1,732 +0,0 @@ -!--------------------------------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 - 2016 CP2K developers group ! -!--------------------------------------------------------------------------------------------------! - -! ************************************************************************************************** -!> \brief Calculates integral matrices for LRIGPW method using solid harmonic -!> Gaussians (SHG) -!> lri : local resolution of the identity -!> \par History -!> created [06.2015] -!> \author Dorothea Golze -! ************************************************************************************************** -MODULE lri_shg_integrals - USE ai_shg_overlap, ONLY: & - dev_overlap_shg_ab, dev_overlap_shg_aba, dev_overlap_shg_abb, get_W_matrix, get_dW_matrix, & - get_real_scaled_solid_harmonic, overlap_shg_ab, overlap_shg_aba, overlap_shg_abb, & - s_overlap_ab, s_overlap_abx - USE basis_set_types, ONLY: gto_basis_set_type - USE kinds, ONLY: dp - USE lri_environment_types, ONLY: lri_environment_type - USE mathconstants, ONLY: fac,& - ifac,& - pi - USE orbital_pointers, ONLY: nsoset -#include "./base/base_uses.f90" - - IMPLICIT NONE - - PRIVATE - -! ************************************************************************************************** - - CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'lri_shg_integrals' - - PUBLIC :: precalc_angular_shg_part, lri_int_ab_shg, lri_int_aba_shg, & - lri_int_abb_shg - -! ************************************************************************************************** - -CONTAINS - -! ************************************************************************************************** -!> \brief precalculates the angular part of the SHG integrals for the matrices -!> (fa,fb), (a,b), (a,b,fa) and (b,fb,a) -!> \param oba orbital basis on a -!> \param obb orbital basis on b -!> \param fba aux basis on a -!> \param fbb aux basis on b -!> \param rab distance vector between a and b -!> \param Waux_mat matrix storing angular-dependent part -!> \param dWaux_mat ... -!> \param calculate_forces ... -! ************************************************************************************************** - SUBROUTINE precalc_angular_shg_part(oba, obb, fba, fbb, rab, Waux_mat, dWaux_mat, & - calculate_forces) - - TYPE(gto_basis_set_type), POINTER :: oba, obb, fba, fbb - REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rab - REAL(KIND=dp), DIMENSION(:, :, :, :), POINTER :: Waux_mat - REAL(KIND=dp), DIMENSION(:, :, :, :, :), POINTER :: dWaux_mat - LOGICAL, INTENT(IN) :: calculate_forces - - CHARACTER(len=*), PARAMETER :: routineN = 'precalc_angular_shg_part', & - routineP = moduleN//':'//routineN - - INTEGER :: handle, i, isize, j, k, la_max, laa_max, & - lb_max, lbb_max, lca_max, lcb_max, & - li_max, lj_max, lmax, mdim(4), & - size_int(4, 2), temp - INTEGER, DIMENSION(:), POINTER :: li_max_all - REAL(KIND=dp) :: rab2 - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: Rc, Rs - - CALL timeset(routineN, handle) - NULLIFY (li_max_all) - - rab2 = rab(1)*rab(1)+rab(2)*rab(2)+rab(3)*rab(3) - - !*** 1 Waux_mat of size (li_max,lj_max) for elements - ! i j - ! [aab] --> (laa_max, lb_max) - ! [bba] --> (lbb_max, la_max) --> use for [abb] - ! [ab] ri --> (lca_max, lcb_max) - ! [ab] orb --> (la_max , lb_max) - - la_max = MAXVAL(oba%lmax) - lb_max = MAXVAL(obb%lmax) - lca_max = MAXVAL(fba%lmax) - lcb_max = MAXVAL(fbb%lmax) - - laa_max = la_max+lca_max - lbb_max = lb_max+lcb_max - li_max = MAX(laa_max, lbb_max) - lj_max = MAX(la_max, lb_max, lcb_max) - lmax = li_max - - ALLOCATE (li_max_all(0:lj_max)) - ALLOCATE (Rc(0:lmax, -2*lmax:2*lmax), Rs(0:lmax, -2*lmax:2*lmax)) - Rc = 0._dp - Rs = 0._dp - mdim(1) = nsoset(li_max)+1 - mdim(2) = nsoset(lj_max)+1 - mdim(3) = li_max+lj_max+1 - mdim(4) = 4 - ALLOCATE (Waux_mat(mdim(1), mdim(2), mdim(3), mdim(4))) - ALLOCATE (dWaux_mat(3, mdim(1), mdim(2), mdim(3), mdim(4))) - !Waux_mat = 0._dp !.. takes time - - !*** Waux_mat (li_max,lj_max) contains elements not needed, - !*** make indixing so that only required ones are computed - !*** li_max_all(j) --> li_max dependent on j - size_int(1, :) = (/laa_max, lb_max/) - size_int(2, :) = (/lbb_max, la_max/) - size_int(3, :) = (/lca_max, lcb_max/) - size_int(4, :) = (/la_max, lb_max/) - - li_max_all(:) = 0 - DO isize = 1, 4 - i = size_int(isize, 1) - j = size_int(isize, 2) - k = li_max_all(j) - IF (k < i) li_max_all(j) = i - ENDDO - temp = li_max_all(lj_max) - DO j = lj_max, 0, -1 - IF (li_max_all(j) < temp) THEN - li_max_all(j) = temp - ELSE - temp = li_max_all(j) - ENDIF - ENDDO - - !*** -rab, since Eq. in Ref. use Ra-Rb, not Rb-Ra - CALL get_real_scaled_solid_harmonic(Rc, Rs, lmax, -rab, rab2) - CALL get_W_matrix(li_max_all, lj_max, lmax, Rc, Rs, Waux_mat) - IF (calculate_forces) THEN - CALL get_dW_matrix(li_max_all, lj_max, Waux_mat, dWaux_mat) - ENDIF - - DEALLOCATE (Rc, Rs, li_max_all) - - CALL timestop(handle) - - END SUBROUTINE precalc_angular_shg_part - -! ************************************************************************************************** -!> \brief calculate integrals (a,b,fa) -!> \param lri_env ... -!> \param abaint integral (a,b,fa) -!> \param dabdaint ... -!> \param rab distance vector between A and B -!> \param oba orbital basis at center A -!> \param obb orbital basis at center B -!> \param fba auxiliary basis set at center A -!> \param scona_shg contraction matrix for orb bas on A -!> \param sconb_shg contraction matrix for orb bas on B -!> \param sconca_shg contraction matrix for aux bas on A -!> \param Waux_mat angular-depedent part -!> \param dWaux_mat derivative of Waux_mat -!> \param calculate_forces ... -! ************************************************************************************************** - SUBROUTINE lri_int_aba_shg(lri_env, abaint, dabdaint, rab, oba, obb, fba, scona_shg, & - sconb_shg, sconca_shg, Waux_mat, dWaux_mat, & - calculate_forces) - - TYPE(lri_environment_type), POINTER :: lri_env - REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: abaint - REAL(KIND=dp), DIMENSION(:, :, :, :), POINTER :: dabdaint - REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rab - TYPE(gto_basis_set_type), POINTER :: oba, obb, fba - REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: scona_shg, sconb_shg, sconca_shg - REAL(KIND=dp), DIMENSION(:, :, :, :), POINTER :: Waux_mat - REAL(KIND=dp), DIMENSION(:, :, :, :, :), POINTER :: dWaux_mat - LOGICAL, INTENT(IN) :: calculate_forces - - CHARACTER(LEN=*), PARAMETER :: routineN = 'lri_int_aba_shg', & - routineP = moduleN//':'//routineN - - INTEGER :: handle, ids, ids_start, iil, il, ipgfa, iset, ishella, jpgfb, jset, jshellb, & - kpgfa, kset, kshella, la_max_set, laa, laa_max_set, lai, lak, lb_max_set, lbj, & - lca_max_set, ndev, nds, nds_max, nl, nl_set, npgfa_set, npgfb_set, npgfca_set, nseta, & - nsetb, nsetca, nshella_set, nshellb_set, nshellca_set - INTEGER, DIMENSION(:), POINTER :: la_max, lb_max, lca_max, npgfa, npgfb, & - npgfca, nshella, nshellb, nshellca - INTEGER, DIMENSION(:, :), POINTER :: first_sgfa, first_sgfb, first_sgfca, la, & - lb, lca - REAL(KIND=dp) :: a, aif, bjf, const, consta, constca, & - dab, prefac, rab2, shg_fac(5) - REAL(KIND=dp), DIMENSION(:), POINTER :: set_radius_a, set_radius_b, set_radius_ca - REAL(KIND=dp), DIMENSION(:, :), POINTER :: zeta, zetb, zetca - REAL(KIND=dp), DIMENSION(:, :, :, :, :), POINTER :: swork, swork_cont - - CALL timeset(routineN, handle) - NULLIFY (la_max, lb_max, lca_max, npgfa, npgfb, npgfca) - NULLIFY (first_sgfa, first_sgfb, first_sgfca, set_radius_a, set_radius_b, & - set_radius_ca, zeta, zetb, zetca) - - ! basis ikind - first_sgfa => oba%first_sgf - la_max => oba%lmax - la => oba%l - npgfa => oba%npgf - nshella => oba%nshell - nseta = oba%nset - set_radius_a => oba%set_radius - zeta => oba%zet - ! basis jkind - first_sgfb => obb%first_sgf - lb_max => obb%lmax - lb => obb%l - npgfb => obb%npgf - nshellb => obb%nshell - nsetb = obb%nset - set_radius_b => obb%set_radius - zetb => obb%zet - - ! basis RI A - first_sgfca => fba%first_sgf - lca_max => fba%lmax - lca => fba%l - npgfca => fba%npgf - nshellca => fba%nshell - nsetca = fba%nset - set_radius_ca => fba%set_radius - zetca => fba%zet - - dab = SQRT(SUM(rab**2)) - rab2 = rab(1)*rab(1)+rab(2)*rab(2)+rab(3)*rab(3) - - la_max_set = MAXVAL(la_max) - lb_max_set = MAXVAL(lb_max) - lca_max_set = MAXVAL(lca_max) - npgfa_set = MAXVAL(npgfa) - npgfb_set = MAXVAL(npgfb) - npgfca_set = MAXVAL(npgfca) - nshella_set = MAXVAL(nshella) - nshellb_set = MAXVAL(nshellb) - nshellca_set = MAXVAL(nshellca) - !*** for forces: derivative+1 in auxiliary vector required - ndev = 0 - IF (calculate_forces) ndev = 1 - - laa_max_set = la_max_set+lca_max_set - - ! allocate some work storage.... - nds_max = laa_max_set+lb_max_set+ndev+1 - nl_set = INT((laa_max_set)/2) - ALLOCATE (swork(npgfa_set, npgfb_set, npgfca_set, 0:nl_set, nds_max)) - ALLOCATE (swork_cont(nshella_set, nshellb_set, nshellca_set, 0:nl_set, nds_max)) - - DO iset = 1, nseta - - DO jset = 1, nsetb - - IF (set_radius_a(iset)+set_radius_b(jset) < dab) CYCLE - - DO kset = 1, nsetca - - IF (set_radius_b(jset)+set_radius_ca(kset) < dab) CYCLE - - CALL s_overlap_abx(la_max(iset), npgfa(iset), zeta(:, iset), & - lb_max(jset), npgfb(jset), zetb(:, jset), & - lca_max(kset), npgfca(kset), zetca(:, kset), & - rab, swork, calculate_forces, calc_aba=.TRUE.) - - swork_cont = 0.0_dp - DO ishella = 1, nshella(iset) - lai = la(ishella, iset) - consta = SQRT(1.0_dp/REAL(2*lai+1, dp)) - DO jshellb = 1, nshellb(jset) - lbj = lb(jshellb, jset) - DO kshella = 1, nshellca(kset) - lak = lca(kshella, kset) - constca = SQRT(1.0_dp/REAL(2*lak+1, dp)) - nl = INT((lai+lak)/2) - IF (lai == 0 .OR. lak == 0) nl = 0 - DO il = 0, nl - laa = lai+lak-2*il - nds = laa+lbj+1 - ids_start = nds-MIN(laa, lbj) - const = consta*constca*2.0_dp*SQRT(pi*REAL(2*laa+1, dp)) - DO iil = 1, il - shg_fac(iil) = fac(laa+iil-1)*ifac(laa)*REAL(laa, dp) & - *fac(il)/fac(il-iil)/fac(iil) - ENDDO - DO ipgfa = 1, npgfa(iset) - DO jpgfb = 1, npgfb(jset) - bjf = 1.0_dp/((2._dp*zetb(jpgfb, jset))**lbj) - DO kpgfa = 1, npgfca(kset) - a = zeta(ipgfa, iset)+zetca(kpgfa, kset) - aif = 1.0_dp/((2._dp*a)**laa) - prefac = const*aif*bjf & - *scona_shg(ipgfa, ishella, iset) & - *sconb_shg(jpgfb, jshellb, jset) & - *sconca_shg(kpgfa, kshella, kset) - DO ids = ids_start, nds+ndev - IF (il == 0) THEN - swork_cont(ishella, jshellb, kshella, il, ids) = & - swork_cont(ishella, jshellb, kshella, il, ids) & - +prefac*swork(ipgfa, jpgfb, kpgfa, il, ids) - ELSEIF (il == 1) THEN - swork_cont(ishella, jshellb, kshella, il, ids) = & - swork_cont(ishella, jshellb, kshella, il, ids) & - +prefac*(swork(ipgfa, jpgfb, kpgfa, il, ids) & - +shg_fac(il)*swork(ipgfa, jpgfb, kpgfa, il-1, ids)/a) - ELSEIF (il == 2) THEN - swork_cont(ishella, jshellb, kshella, il, ids) = & - swork_cont(ishella, jshellb, kshella, il, ids) & - +prefac*(swork(ipgfa, jpgfb, kpgfa, il, ids) & - +shg_fac(il-1)*swork(ipgfa, jpgfb, kpgfa, il-1, ids)/a & - +shg_fac(il)*swork(ipgfa, jpgfb, kpgfa, il-2, ids)/(a**2)) - ELSEIF (il == 3) THEN - swork_cont(ishella, jshellb, kshella, il, ids) = & - swork_cont(ishella, jshellb, kshella, il, ids) & - +prefac*(swork(ipgfa, jpgfb, kpgfa, il, ids) & - +shg_fac(il-2)*swork(ipgfa, jpgfb, kpgfa, il-1, ids)/a & - +shg_fac(il-1)*swork(ipgfa, jpgfb, kpgfa, il-2, ids)/(a**2) & - +shg_fac(il)*swork(ipgfa, jpgfb, kpgfa, il-3, ids)/(a**3)) - ELSEIF (il == 4) THEN - swork_cont(ishella, jshellb, kshella, il, ids) = & - swork_cont(ishella, jshellb, kshella, il, ids) & - +prefac*(swork(ipgfa, jpgfb, kpgfa, il, ids) & - +shg_fac(il-3)*swork(ipgfa, jpgfb, kpgfa, il-1, ids)/a & - +shg_fac(il-2)*swork(ipgfa, jpgfb, kpgfa, il-2, ids)/(a**2) & - +shg_fac(il-1)*swork(ipgfa, jpgfb, kpgfa, il-3, ids)/(a**3) & - +shg_fac(il)*swork(ipgfa, jpgfb, kpgfa, il-4, ids)/(a**4)) - ELSEIF (il == 5) THEN - swork_cont(ishella, jshellb, kshella, il, ids) = & - swork_cont(ishella, jshellb, kshella, il, ids) & - +prefac*(swork(ipgfa, jpgfb, kpgfa, il, ids) & - +shg_fac(il-4)*swork(ipgfa, jpgfb, kpgfa, il-1, ids)/a & - +shg_fac(il-3)*swork(ipgfa, jpgfb, kpgfa, il-2, ids)/a**2 & - +shg_fac(il-2)*swork(ipgfa, jpgfb, kpgfa, il-3, ids)/(a**3) & - +shg_fac(il-1)*swork(ipgfa, jpgfb, kpgfa, il-4, ids)/(a**4) & - +shg_fac(il)*swork(ipgfa, jpgfb, kpgfa, il-5, ids)/(a**5)) - ELSE - CALL cp_abort(__LOCATION__, & - "SHG integrals not implemented when l quantum number"// & - " of orbital and ri basis larger than 11") - ENDIF - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - CALL overlap_shg_aba(la(:, iset), first_sgfa(:, iset), nshella(iset), & - lb(:, jset), first_sgfb(:, jset), nshellb(jset), & - lca(:, kset), first_sgfca(:, kset), nshellca(kset), & - lri_env%cg_shg%cg_coeff, lri_env%cg_shg%cg_none0_list, & - lri_env%cg_shg%ncg_none0, swork_cont, Waux_mat, abaint) - ! - IF (calculate_forces) THEN - !*** -rab, since Eq. in Ref. use Ra-Rb, not Rb-Ra - CALL dev_overlap_shg_aba(la(:, iset), first_sgfa(:, iset), nshella(iset), & - lb(:, jset), first_sgfb(:, jset), nshellb(jset), & - lca(:, kset), first_sgfca(:, kset), nshellca(kset), & - lri_env%cg_shg%cg_coeff, lri_env%cg_shg%cg_none0_list, & - lri_env%cg_shg%ncg_none0, -rab, swork_cont, & - Waux_mat, dWaux_mat, dabdaint) - ENDIF - - END DO - END DO - END DO - - DEALLOCATE (swork_cont) - DEALLOCATE (swork) - - CALL timestop(handle) - - END SUBROUTINE lri_int_aba_shg - -! ************************************************************************************************** -!> \brief calculate integrals (a,b,fb) -!> \param lri_env ... -!> \param abbint integral (a,b,fb) -!> \param dabbint derivative of abbint -!> \param rab distance vector between A and B -!> \param oba orbital basis at center A -!> \param obb orbital basis at center B -!> \param fbb auxiliary basis set at center B -!> \param scona_shg contraction matrix for orb bas on A -!> \param sconb_shg contraction matrix for orb bas on B -!> \param sconcb_shg contraction matrix for aux bas on B -!> \param Waux_mat angular-dependent part -!> \param dWaux_mat derivative of Waux_mat -!> \param calculate_forces ... -! ************************************************************************************************** - SUBROUTINE lri_int_abb_shg(lri_env, abbint, dabbint, rab, oba, obb, fbb, scona_shg, & - sconb_shg, sconcb_shg, Waux_mat, dWaux_mat, & - calculate_forces) - - TYPE(lri_environment_type), POINTER :: lri_env - REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: abbint - REAL(KIND=dp), DIMENSION(:, :, :, :), POINTER :: dabbint - REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rab - TYPE(gto_basis_set_type), POINTER :: oba, obb, fbb - REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: scona_shg, sconb_shg, sconcb_shg - REAL(KIND=dp), DIMENSION(:, :, :, :), POINTER :: Waux_mat - REAL(KIND=dp), DIMENSION(:, :, :, :, :), POINTER :: dWaux_mat - LOGICAL, INTENT(IN) :: calculate_forces - - CHARACTER(LEN=*), PARAMETER :: routineN = 'lri_int_abb_shg', & - routineP = moduleN//':'//routineN - - INTEGER :: handle, ids, ids_start, iil, il, ipgfa, iset, ishella, jpgfb, jset, jshellb, & - kpgfb, kset, kshellb, la_max_set, lai, lb_max_set, lbb, lbb_max_set, lbj, lbk, & - lcb_max_set, ndev, nds, nds_max, nl, nl_set, npgfa_set, npgfb_set, npgfcb_set, nseta, & - nsetb, nsetcb, nshella_set, nshellb_set, nshellcb_set - INTEGER, DIMENSION(:), POINTER :: la_max, lb_max, lcb_max, npgfa, npgfb, & - npgfcb, nshella, nshellb, nshellcb - INTEGER, DIMENSION(:, :), POINTER :: first_sgfa, first_sgfb, first_sgfcb, la, & - lb, lcb - REAL(KIND=dp) :: aif, b, bjf, const, constb, constcb, & - dab, prefac, rab2, shg_fac(5) - REAL(KIND=dp), DIMENSION(:), POINTER :: set_radius_a, set_radius_b, set_radius_cb - REAL(KIND=dp), DIMENSION(:, :), POINTER :: zeta, zetb, zetcb - REAL(KIND=dp), DIMENSION(:, :, :, :, :), POINTER :: swork, swork_cont - - CALL timeset(routineN, handle) - NULLIFY (la_max, lb_max, lcb_max, npgfa, npgfb, npgfcb) - NULLIFY (first_sgfa, first_sgfb, first_sgfcb, set_radius_a, set_radius_b, & - set_radius_cb, zeta, zetb, zetcb) - - ! basis ikind - first_sgfa => oba%first_sgf - la_max => oba%lmax - la => oba%l - npgfa => oba%npgf - nshella => oba%nshell - nseta = oba%nset - set_radius_a => oba%set_radius - zeta => oba%zet - ! basis jkind - first_sgfb => obb%first_sgf - lb_max => obb%lmax - lb => obb%l - npgfb => obb%npgf - nshellb => obb%nshell - nsetb = obb%nset - set_radius_b => obb%set_radius - zetb => obb%zet - - ! basis RI on B - first_sgfcb => fbb%first_sgf - lcb_max => fbb%lmax - lcb => fbb%l - npgfcb => fbb%npgf - nshellcb => fbb%nshell - nsetcb = fbb%nset - set_radius_cb => fbb%set_radius - zetcb => fbb%zet - - dab = SQRT(SUM(rab**2)) - rab2 = rab(1)*rab(1)+rab(2)*rab(2)+rab(3)*rab(3) - - la_max_set = MAXVAL(la_max) - lb_max_set = MAXVAL(lb_max) - lcb_max_set = MAXVAL(lcb_max) - npgfa_set = MAXVAL(npgfa) - npgfb_set = MAXVAL(npgfb) - npgfcb_set = MAXVAL(npgfcb) - nshella_set = MAXVAL(nshella) - nshellb_set = MAXVAL(nshellb) - nshellcb_set = MAXVAL(nshellcb) - !*** for forces: derivative+1 in auxiliary vector required - ndev = 0 - IF (calculate_forces) ndev = 1 - - lbb_max_set = lb_max_set+lcb_max_set - - ! allocate some work storage.... - nds_max = la_max_set+lbb_max_set+ndev+1 - nl_set = INT((lbb_max_set)/2) - ALLOCATE (swork(1:npgfa_set, 1:npgfb_set, 1:npgfcb_set, 0:nl_set, 1:nds_max)) - ALLOCATE (swork_cont(nshella_set, nshellb_set, nshellcb_set, 0:nl_set, nds_max)) - - DO iset = 1, nseta - - DO jset = 1, nsetb - - IF (set_radius_a(iset)+set_radius_b(jset) < dab) CYCLE - - DO kset = 1, nsetcb - - IF (set_radius_a(iset)+set_radius_cb(kset) < dab) CYCLE - - CALL s_overlap_abx(la_max(iset), npgfa(iset), zeta(:, iset), & - lb_max(jset), npgfb(jset), zetb(:, jset), & - lcb_max(kset), npgfcb(kset), zetcb(:, kset), & - rab, swork, calculate_forces, calc_aba=.FALSE.) - - swork_cont = 0.0_dp - DO ishella = 1, nshella(iset) - lai = la(ishella, iset) - DO jshellb = 1, nshellb(jset) - lbj = lb(jshellb, jset) - constb = SQRT(1.0_dp/REAL(2*lbj+1, dp)) - DO kshellb = 1, nshellcb(kset) - lbk = lcb(kshellb, kset) - constcb = SQRT(1.0_dp/REAL(2*lbk+1, dp)) - nl = INT((lbj+lbk)/2) - IF (lbj == 0 .OR. lbk == 0) nl = 0 - DO il = 0, nl - lbb = lbj+lbk-2*il - nds = lai+lbb+1 - ids_start = nds-MIN(lai, lbb) - const = constb*constcb*2.0_dp*SQRT(pi*REAL(2*lbb+1, dp)) - DO iil = 1, il - shg_fac(iil) = fac(lbb+iil-1)*ifac(lbb)*REAL(lbb, dp) & - *fac(il)/fac(il-iil)/fac(iil) - ENDDO - DO ipgfa = 1, npgfa(iset) - aif = 1.0_dp/((2._dp*zeta(ipgfa, iset))**lai) - DO jpgfb = 1, npgfb(jset) - DO kpgfb = 1, npgfcb(kset) - b = zetb(jpgfb, jset)+zetcb(kpgfb, kset) - bjf = 1.0_dp/((2._dp*b)**lbb) - prefac = const*aif*bjf & - *scona_shg(ipgfa, ishella, iset) & - *sconb_shg(jpgfb, jshellb, jset) & - *sconcb_shg(kpgfb, kshellb, kset) - DO ids = ids_start, nds+ndev - IF (il == 0) THEN - swork_cont(ishella, jshellb, kshellb, il, ids) = & - swork_cont(ishella, jshellb, kshellb, il, ids) & - +prefac*swork(ipgfa, jpgfb, kpgfb, il, ids) - ELSEIF (il == 1) THEN - swork_cont(ishella, jshellb, kshellb, il, ids) = & - swork_cont(ishella, jshellb, kshellb, il, ids) & - +prefac*(swork(ipgfa, jpgfb, kpgfb, il, ids) & - +shg_fac(il)*swork(ipgfa, jpgfb, kpgfb, il-1, ids)/b) - ELSEIF (il == 2) THEN - swork_cont(ishella, jshellb, kshellb, il, ids) = & - swork_cont(ishella, jshellb, kshellb, il, ids) & - +prefac*(swork(ipgfa, jpgfb, kpgfb, il, ids) & - +shg_fac(il-1)*swork(ipgfa, jpgfb, kpgfb, il-1, ids)/b & - +shg_fac(il)*swork(ipgfa, jpgfb, kpgfb, il-2, ids)/(b**2)) - ELSEIF (il == 3) THEN - swork_cont(ishella, jshellb, kshellb, il, ids) = & - swork_cont(ishella, jshellb, kshellb, il, ids) & - +prefac*(swork(ipgfa, jpgfb, kpgfb, il, ids) & - +shg_fac(il-2)*swork(ipgfa, jpgfb, kpgfb, il-1, ids)/b & - +shg_fac(il-1)*swork(ipgfa, jpgfb, kpgfb, il-2, ids)/(b**2) & - +shg_fac(il)*swork(ipgfa, jpgfb, kpgfb, il-3, ids)/(b**3)) - ELSEIF (il == 4) THEN - swork_cont(ishella, jshellb, kshellb, il, ids) = & - swork_cont(ishella, jshellb, kshellb, il, ids) & - +prefac*(swork(ipgfa, jpgfb, kpgfb, il, ids) & - +shg_fac(il-3)*swork(ipgfa, jpgfb, kpgfb, il-1, ids)/b & - +shg_fac(il-2)*swork(ipgfa, jpgfb, kpgfb, il-2, ids)/(b**2) & - +shg_fac(il-1)*swork(ipgfa, jpgfb, kpgfb, il-3, ids)/(b**3) & - +shg_fac(il)*swork(ipgfa, jpgfb, kpgfb, il-4, ids)/(b**4)) - ELSEIF (il == 5) THEN - swork_cont(ishella, jshellb, kshellb, il, ids) = & - swork_cont(ishella, jshellb, kshellb, il, ids) & - +prefac*(swork(ipgfa, jpgfb, kpgfb, il, ids) & - +shg_fac(il-4)*swork(ipgfa, jpgfb, kpgfb, il-1, ids)/b & - +shg_fac(il-3)*swork(ipgfa, jpgfb, kpgfb, il-2, ids)/b**2 & - +shg_fac(il-2)*swork(ipgfa, jpgfb, kpgfb, il-3, ids)/(b**3) & - +shg_fac(il-1)*swork(ipgfa, jpgfb, kpgfb, il-4, ids)/(b**4) & - +shg_fac(il)*swork(ipgfa, jpgfb, kpgfb, il-5, ids)/(b**5)) - ELSE - CALL cp_abort(__LOCATION__, & - "SHG integrals not implemented when l quantum number"// & - " of orbital and ri basis larger than 11") - ENDIF - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - CALL overlap_shg_abb(la(:, iset), first_sgfa(:, iset), nshella(iset), & - lb(:, jset), first_sgfb(:, jset), nshellb(jset), & - lcb(:, kset), first_sgfcb(:, kset), nshellcb(kset), & - lri_env%cg_shg%cg_coeff, lri_env%cg_shg%cg_none0_list, & - lri_env%cg_shg%ncg_none0, swork_cont, Waux_mat, abbint) - IF (calculate_forces) THEN - !*** -rab, since Eq. in Ref. use Ra-Rb, not Rb-Ra - CALL dev_overlap_shg_abb(la(:, iset), first_sgfa(:, iset), nshella(iset), & - lb(:, jset), first_sgfb(:, jset), nshellb(jset), & - lcb(:, kset), first_sgfcb(:, kset), nshellcb(kset), & - lri_env%cg_shg%cg_coeff, lri_env%cg_shg%cg_none0_list, & - lri_env%cg_shg%ncg_none0, -rab, swork_cont, & - Waux_mat, dWaux_mat, dabbint) - ENDIF - - END DO - END DO - END DO - - DEALLOCATE (swork_cont) - DEALLOCATE (swork) - - CALL timestop(handle) - - END SUBROUTINE lri_int_abb_shg - -! ************************************************************************************************** -!> \brief calculate overlap integrals (a,b) -!> \param sab integral (a,b) -!> \param dsab derivative of sab -!> \param rab distance vector -!> \param fba basis at center A -!> \param fbb basis at center B -!> \param scona_shg contraction matrix A -!> \param sconb_shg contraxtion matrix B -!> \param Waux_mat angular-dependent part -!> \param dWaux_mat derivative of Waux_mat -!> \param calculate_forces ... -! ************************************************************************************************** - SUBROUTINE lri_int_ab_shg(sab, dsab, rab, fba, fbb, scona_shg, sconb_shg, Waux_mat, & - dWaux_mat, calculate_forces) - - REAL(KIND=dp), DIMENSION(:, :), POINTER :: sab - REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: dsab - REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rab - TYPE(gto_basis_set_type), POINTER :: fba, fbb - REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: scona_shg, sconb_shg - REAL(KIND=dp), DIMENSION(:, :, :, :), POINTER :: Waux_mat - REAL(KIND=dp), DIMENSION(:, :, :, :, :), POINTER :: dWaux_mat - LOGICAL, INTENT(IN) :: calculate_forces - - CHARACTER(LEN=*), PARAMETER :: routineN = 'lri_int_ab_shg', routineP = moduleN//':'//routineN - - INTEGER :: handle, ids, ids_start, ipgfa, iset, ishella, jpgfb, jset, jshellb, la_max_set, & - lai, lb_max_set, lbj, ndev, nds, nds_max, npgfa_set, npgfb_set, nseta, nsetb, & - nshella_set, nshellb_set - INTEGER, DIMENSION(:), POINTER :: la_max, lb_max, npgfa, npgfb, nshella, & - nshellb - INTEGER, DIMENSION(:, :), POINTER :: first_sgfa, first_sgfb, la, lb - REAL(KIND=dp) :: aif, bjf, dab - REAL(KIND=dp), DIMENSION(:), POINTER :: set_radius_a, set_radius_b - REAL(KIND=dp), DIMENSION(:, :), POINTER :: zeta, zetb - REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: swork, swork_cont - - CALL timeset(routineN, handle) - NULLIFY (la_max, lb_max, npgfa, npgfb, first_sgfa, first_sgfb, set_radius_a, & - set_radius_b, zeta, zetb) - - ! basis ikind - first_sgfa => fba%first_sgf - la_max => fba%lmax - la => fba%l - npgfa => fba%npgf - nseta = fba%nset - set_radius_a => fba%set_radius - zeta => fba%zet - nshella => fba%nshell - ! basis jkind - first_sgfb => fbb%first_sgf - lb_max => fbb%lmax - lb => fbb%l - npgfb => fbb%npgf - nsetb = fbb%nset - set_radius_b => fbb%set_radius - zetb => fbb%zet - nshellb => fbb%nshell - - dab = SQRT(SUM(rab**2)) - - la_max_set = MAXVAL(la_max) - lb_max_set = MAXVAL(lb_max) - - ! allocate some work matrices - npgfa_set = MAXVAL(npgfa) - npgfb_set = MAXVAL(npgfb) - nshella_set = MAXVAL(nshella) - nshellb_set = MAXVAL(nshellb) - ndev = 0 - IF (calculate_forces) ndev = 1 - nds_max = la_max_set+lb_max_set+ndev+1 - ALLOCATE (swork(npgfa_set, npgfb_set, nds_max)) - ALLOCATE (swork_cont(nshella_set, nshellb_set, nds_max)) - - DO iset = 1, nseta - - DO jset = 1, nsetb - - IF (set_radius_a(iset)+set_radius_b(jset) < dab) CYCLE - - CALL s_overlap_ab(la_max(iset), npgfa(iset), zeta(:, iset), & - lb_max(jset), npgfb(jset), zetb(:, jset), & - rab, swork, calculate_forces) - - swork_cont = 0.0_dp - DO ishella = 1, nshella(iset) - lai = la(ishella, iset) - DO jshellb = 1, nshellb(jset) - lbj = lb(jshellb, jset) - nds = lai+lbj+1 - ids_start = nds-MIN(lai, lbj) - DO ipgfa = 1, npgfa(iset) - aif = 1.0_dp/((2._dp*zeta(ipgfa, iset))**lai) - DO jpgfb = 1, npgfb(jset) - bjf = 1.0_dp/((2._dp*zetb(jpgfb, jset))**lbj) - DO ids = ids_start, nds+ndev - swork_cont(ishella, jshellb, ids) = swork_cont(ishella, jshellb, ids) & - +scona_shg(ipgfa, ishella, iset) & - *sconb_shg(jpgfb, jshellb, jset) & - *aif*bjf*swork(ipgfa, jpgfb, ids) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - CALL overlap_shg_ab(la(:, iset), first_sgfa(:, iset), nshella(iset), & - lb(:, jset), first_sgfb(:, jset), nshellb(jset), & - swork_cont, Waux_mat, sab) - IF (calculate_forces) THEN - !*** -rab, since Eq. in Ref. use Ra-Rb, not Rb-Ra - CALL dev_overlap_shg_ab(la(:, iset), first_sgfa(:, iset), nshella(iset), & - lb(:, jset), first_sgfb(:, jset), nshellb(jset), & - -rab, swork_cont, Waux_mat, dWaux_mat, dsab) - ENDIF - END DO - END DO - - DEALLOCATE (swork, swork_cont) - - CALL timestop(handle) - - END SUBROUTINE lri_int_ab_shg - -END MODULE lri_shg_integrals diff --git a/src/shg_integrals_test.F b/src/shg_integrals_test.F new file mode 100644 index 0000000000..721cd6f256 --- /dev/null +++ b/src/shg_integrals_test.F @@ -0,0 +1,423 @@ +!--------------------------------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright (C) 2000 - 2016 CP2K developers group ! +!--------------------------------------------------------------------------------------------------! + +! ************************************************************************************************** +!> \brief Calculates 2-center integrals for different r12 operators comparing the Solid harmonic +!> Gaussian integral scheme to the Obara-Saika (OS) scheme +!> \author Dorothea Golze [05.2016] +! ************************************************************************************************** +MODULE shg_integrals_test + + USE basis_set_types, ONLY: allocate_gto_basis_set,& + deallocate_gto_basis_set,& + gto_basis_set_type,& + init_orb_basis_set,& + read_gto_basis_set + USE generic_os_integrals, ONLY: two_center_os_integrals + USE generic_shg_integrals, ONLY: two_center_shg_integrals + USE input_constants, ONLY: operator_coulomb,& + operator_gauss,& + operator_verf,& + operator_verfc,& + operator_vgauss + USE input_cp2k_subsys, ONLY: create_basis_section + USE input_keyword_types, ONLY: keyword_create,& + keyword_release,& + keyword_type + USE input_section_types, ONLY: & + section_add_keyword, section_add_subsection, section_create, section_release, & + section_type, section_vals_get, section_vals_get_subs_vals, section_vals_type, & + section_vals_val_get + USE input_val_types, ONLY: real_t + USE kinds, ONLY: default_string_length,& + dp + USE mathconstants, ONLY: fac,& + pi + USE orbital_pointers, ONLY: init_orbital_pointers + USE orbital_transformation_matrices, ONLY: init_spherical_harmonics +#include "./base/base_uses.f90" + + IMPLICIT NONE + + PRIVATE + +! ************************************************************************************************** + + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'shg_integrals_test' + + PUBLIC :: create_shg_integrals_test_section, shg_integrals_perf_acc_test + +CONTAINS + +! ************************************************************************************************** +!> \brief Create input section for unit testing +!> \param section ... +! ************************************************************************************************** + SUBROUTINE create_shg_integrals_test_section(section) + TYPE(section_type), INTENT(INOUT), POINTER :: section + + CHARACTER(len=*), PARAMETER :: routineN = 'create_shg_integrals_test_section', & + routineP = moduleN//':'//routineN + + TYPE(keyword_type), POINTER :: keyword + TYPE(section_type), POINTER :: subsection + + NULLIFY (keyword, subsection) + + CPASSERT(.NOT. ASSOCIATED(section)) + CALL section_create(section, "SHG_INTEGRALS_TEST", & + description="Parameters for testing the SHG 2-center integrals for "// & + "different r12 operators. Test w.r.t. performance and accurarcy.", & + n_keywords=4, n_subsections=1) + + CALL create_basis_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) + + CALL keyword_create(keyword, & + name="_SECTION_PARAMETERS_", & + description="Controls the activation the SHG integral test. ", & + default_l_val=.FALSE., & + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) + + CALL keyword_create(keyword, name="ABC", & + description="Specify the lengths of the cell vectors A, B, and C. ", & + usage="ABC 10.000 10.000 10.000", unit_str="angstrom", & + n_var=3, type_of_var=real_t) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) + + CALL keyword_create(keyword, name="NAB_MIN", & + description="Minimum number of atomic distances to consider. ", & + default_i_val=8) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) + + CALL keyword_create(keyword, name="NREP", & + description="Number of repeated calculation of each integral. ", & + default_i_val=1) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) + + CALL keyword_create(keyword, name="CHECK_ACCURACY", & + description="Causes abortion when SHG and OS integrals differ "// & + "more than 1.0E-08.", & + default_l_val=.TRUE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) + + END SUBROUTINE create_shg_integrals_test_section + +! ************************************************************************************************** +!> \brief Unit test for performance and accuracy of the SHG integrals +!> \param iw output unit +!> \param shg_integrals_test_section ... +! ************************************************************************************************** + SUBROUTINE shg_integrals_perf_acc_test(iw, shg_integrals_test_section) + INTEGER, INTENT(IN) :: iw + TYPE(section_vals_type), INTENT(INOUT), POINTER :: shg_integrals_test_section + + CHARACTER(len=*), PARAMETER :: routineN = 'shg_integrals_perf_acc_test', & + routineP = moduleN//':'//routineN + + CHARACTER(LEN=default_string_length) :: basis_type + INTEGER :: count_ab, iab, irep, jab, kab, lamax, & + lbmax, lmax, nab, nab_min, nab_xyz, & + nfa, nfb, nrep, nrep_bas + LOGICAL :: acc_check + REAL(KIND=dp) :: acc_param, ddmax_coulomb, ddmax_gauss, ddmax_verf, ddmax_verfc, & + ddmax_vgauss, ddtemp, dmax_coulomb, dmax_gauss, dmax_verf, dmax_verfc, dmax_vgauss, & + dtemp, omega + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: rab + REAL(KIND=dp), DIMENSION(:), POINTER :: cell_par + REAL(KIND=dp), DIMENSION(:, :), POINTER :: vab_os, vab_shg + REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: dvab_os, dvab_shg, scona_shg, sconb_shg + TYPE(gto_basis_set_type), POINTER :: fba, fbb + TYPE(section_vals_type), POINTER :: basis_section + + NULLIFY (fba, fbb, basis_section, cell_par) + CALL section_vals_val_get(shg_integrals_test_section, "ABC", r_vals=cell_par) + CALL section_vals_val_get(shg_integrals_test_section, "NAB_MIN", i_val=nab_min) + CALL section_vals_val_get(shg_integrals_test_section, "NREP", i_val=nrep) + CALL section_vals_val_get(shg_integrals_test_section, "CHECK_ACCURACY", l_val=acc_check) + + !*** Read the basis set information + basis_section => section_vals_get_subs_vals(shg_integrals_test_section, "BASIS") + CALL section_vals_get(basis_section, n_repetition=nrep_bas) + IF (nrep_bas /= 2) RETURN + CALL allocate_gto_basis_set(fba) + CALL read_gto_basis_set(TRIM("A"), basis_type, fba, basis_section, irep=1) + lamax = MAXVAL(fba%lmax) + CALL allocate_gto_basis_set(fbb) + CALL read_gto_basis_set(TRIM("B"), basis_type, fbb, basis_section, irep=2) + lbmax = MAXVAL(fbb%lmax) + lmax = MAX(lamax, lbmax) + + !*** Initialize basis set information + CALL init_orbital_pointers(lmax+1) + CALL init_spherical_harmonics(lmax, output_unit=-100) + fba%norm_type = 2 + CALL init_orb_basis_set(fba) + fbb%norm_type = 2 + CALL init_orb_basis_set(fbb) + ! if shg integrals are later actually used in the code, contraction_matrix_shg should be + ! moved to init_orb_basis_set and scon_shg should become an element of gto_basis_set_type + CALL contraction_matrix_shg(fba, scona_shg) + CALL contraction_matrix_shg(fbb, sconb_shg) + + !*** Create range of rab (atomic distances) to be tested + nab_xyz = CEILING(REAL(nab_min, KIND=dp)**(1.0_dp/3.0_dp)-1.0E-06) + nab = nab_xyz**3 + + ALLOCATE (rab(3, nab)) + count_ab = 0 + DO iab = 1, nab_xyz + DO jab = 1, nab_xyz + DO kab = 1, nab_xyz + count_ab = count_ab+1 + rab(:, count_ab) = [iab*ABS(cell_par(1)), jab*ABS(cell_par(2)), kab*ABS(cell_par(3))]/nab_xyz + ENDDO + ENDDO + ENDDO + + !*** Calculate the SHG integrals + nfa = fba%nsgf + nfb = fbb%nsgf + ALLOCATE (vab_shg(nfa, nfb), dvab_shg(nfa, nfb, 3)) + ALLOCATE (vab_os(nfa, nfb), dvab_os(nfa, nfb, 3)) + omega = 2.3_dp + dmax_coulomb = 0.0_dp + ddmax_coulomb = 0.0_dp + dmax_verf = 0.0_dp + ddmax_verf = 0.0_dp + dmax_verfc = 0.0_dp + ddmax_verfc = 0.0_dp + dmax_vgauss = 0.0_dp + ddmax_vgauss = 0.0_dp + dmax_gauss = 0.0_dp + ddmax_gauss = 0.0_dp + DO irep = 1, nrep + DO iab = 1, nab + !*** Coulomb: (a|1/r12|b) + CALL two_center_shg_integrals(operator_coulomb, vab_shg, dvab_shg, rab(:, iab), & + fba, fbb, scona_shg, sconb_shg, calculate_forces=.TRUE.) + CALL two_center_os_integrals(operator_coulomb, vab_os, dvab_os, rab(:, iab), fba, fbb, & + calculate_forces=.TRUE.) + CALL calculate_deviation(vab_shg, vab_os, dvab_shg, dvab_os, dtemp, ddtemp) + dmax_coulomb = MAX(dmax_coulomb, dtemp) + ddmax_coulomb = MAX(ddmax_coulomb, ddtemp) + !*** verf: (a|erf(omega*r12)/r12|b) + CALL two_center_shg_integrals(operator_verf, vab_shg, dvab_shg, rab(:, iab), & + fba, fbb, scona_shg, sconb_shg, omega, & + calculate_forces=.TRUE.) + CALL two_center_os_integrals(operator_verf, vab_os, dvab_os, rab(:, iab), fba, fbb, & + omega, calculate_forces=.TRUE.) + CALL calculate_deviation(vab_shg, vab_os, dvab_shg, dvab_os, dtemp, ddtemp) + dmax_verf = MAX(dmax_verf, dtemp) + ddmax_verf = MAX(ddmax_verf, ddtemp) + !*** verfc: (a|erfc(omega*r12)/r12|b) + CALL two_center_shg_integrals(operator_verfc, vab_shg, dvab_shg, rab(:, iab), & + fba, fbb, scona_shg, sconb_shg, omega, & + calculate_forces=.TRUE.) + CALL two_center_os_integrals(operator_verfc, vab_os, dvab_os, rab(:, iab), fba, fbb, & + omega, calculate_forces=.TRUE.) + CALL calculate_deviation(vab_shg, vab_os, dvab_shg, dvab_os, dtemp, ddtemp) + dmax_verfc = MAX(dmax_verfc, dtemp) + ddmax_verfc = MAX(ddmax_verfc, ddtemp) + !*** vgauss: (a|exp(omega*r12^2)/r12|b) + CALL two_center_shg_integrals(operator_vgauss, vab_shg, dvab_shg, rab(:, iab), & + fba, fbb, scona_shg, sconb_shg, omega, & + calculate_forces=.TRUE.) + CALL two_center_os_integrals(operator_vgauss, vab_os, dvab_os, rab(:, iab), fba, fbb, & + omega, calculate_forces=.TRUE.) + CALL calculate_deviation(vab_shg, vab_os, dvab_shg, dvab_os, dtemp, ddtemp) + dmax_vgauss = MAX(dmax_vgauss, dtemp) + ddmax_vgauss = MAX(ddmax_vgauss, ddtemp) + !*** gauss: (a|exp(omega*r12^2)|b) + CALL two_center_shg_integrals(operator_gauss, vab_shg, dvab_shg, rab(:, iab), & + fba, fbb, scona_shg, sconb_shg, omega, & + calculate_forces=.TRUE.) + CALL two_center_os_integrals(operator_gauss, vab_os, dvab_os, rab(:, iab), fba, fbb, & + omega, calculate_forces=.TRUE.) + CALL calculate_deviation(vab_shg, vab_os, dvab_shg, dvab_os, dtemp, ddtemp) + dmax_gauss = MAX(dmax_gauss, dtemp) + ddmax_gauss = MAX(ddmax_gauss, ddtemp) + ENDDO + ENDDO + + IF (iw > 0) THEN + WRITE (iw, FMT="(/,T2,A)") "TEST INFO FOR 2-CENTER SHG and OS INTEGRALS:" + WRITE (iw, FMT="(T2,A)") "Maximal deviation between SHG and OS integrals and their derivatives" + WRITE (iw, FMT="(T2,A,T53,ES12.5,4X,ES12.5)") "SHG_INTEGRALS | [a|1/r12|b]", & + dmax_coulomb, ddmax_coulomb + WRITE (iw, FMT="(T2,A,T53,ES12.5,4X,ES12.5)") "SHG_INTEGRALS | [a|erf(omega*r12)/r12|b]", & + dmax_verf, ddmax_verf + WRITE (iw, FMT="(T2,A,T53,ES12.5,4X,ES12.5)") "SHG_INTEGRALS | [a|erfc(omega*r12)/r12|b]", & + dmax_verfc, ddmax_verfc + WRITE (iw, FMT="(T2,A,T53,ES12.5,4X,ES12.5)") "SHG_INTEGRALS | [a|exp(-omega*r12^2)/r12|b]", & + dmax_vgauss, ddmax_vgauss + WRITE (iw, FMT="(T2,A,T53,ES12.5,4X,ES12.5)") "SHG_INTEGRALS | [a|exp(-omega*r12^2)|b]", & + dmax_gauss, ddmax_gauss + + IF (acc_check) THEN + acc_param = 1.0E-08_dp + IF ((dmax_coulomb >= acc_param) .OR. (ddmax_coulomb >= acc_param)) THEN + CPABORT("[a|1/r12|b]: Deviation between SHG and OS larger than 1.0E-08") + ENDIF + IF ((dmax_verf >= acc_param) .OR. (ddmax_verf >= acc_param)) THEN + CPABORT("[a|erf(omega*r12)/r12|b]: Deviation between SHG and OS larger than 1.0E-08") + ENDIF + IF ((dmax_verfc >= acc_param) .OR. (ddmax_verfc >= acc_param)) THEN + CPABORT("[a|erfc(omega*r12)/r12|b]: Deviation between SHG and OS larger than 1.0E-08") + ENDIF + IF ((dmax_vgauss >= acc_param) .OR. (ddmax_vgauss >= acc_param)) THEN + CPABORT("[a|exp(-omega*r12^2)/r12|b]: Dev. between SHG and OS larger than 1.0E-08") + ENDIF + IF ((dmax_gauss >= acc_param) .OR. (ddmax_gauss >= acc_param)) THEN + CPABORT("[a|exp(-omega*r12^2)|b]: Deviation between SHG and OS larger than 1.0E-08") + ENDIF + ENDIF + ENDIF + DEALLOCATE (scona_shg, sconb_shg, rab, vab_shg, dvab_shg, vab_os, dvab_os) + CALL deallocate_gto_basis_set(fba) + CALL deallocate_gto_basis_set(fbb) + + END SUBROUTINE shg_integrals_perf_acc_test + +! ************************************************************************************************** +!> \brief contraction matrix for the SHG integrals. If these integrals are actually used, +!> this routine should be moved, e.g. in basis_set_types.F, where the basis set +!> information are initialized +!> \param basis ... +!> \param scon_shg contraction matrix +! ************************************************************************************************** + SUBROUTINE contraction_matrix_shg(basis, scon_shg) + + TYPE(gto_basis_set_type), POINTER :: basis + REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: scon_shg + + CHARACTER(len=*), PARAMETER :: routineN = 'contraction_matrix_shg', & + routineP = moduleN//':'//routineN + + INTEGER :: ipgf, iset, ishell, l, maxpgf, maxshell, & + nset + INTEGER, DIMENSION(:), POINTER :: npgf, nshell + REAL(KIND=dp) :: aif, gcc, norm_w + REAL(KIND=dp), DIMENSION(:, :), POINTER :: norm, zet + + nset = basis%nset + npgf => basis%npgf + nshell => basis%nshell + zet => basis%zet + + maxpgf = SIZE(basis%gcc, 1) + maxshell = SIZE(basis%gcc, 2) + ALLOCATE (norm(basis%nset, maxshell)) + ALLOCATE (scon_shg(maxpgf, maxshell, nset)) + scon_shg = 0.0_dp + + CALL basis_norm_shg(basis, norm) + + DO iset = 1, nset + DO ishell = 1, nshell(iset) + l = basis%l(ishell, iset) + norm_w = norm(iset, ishell) + DO ipgf = 1, npgf(iset) + aif = 1.0_dp/((2._dp*zet(ipgf, iset))**l) + gcc = basis%gcc(ipgf, ishell, iset) + scon_shg(ipgf, ishell, iset) = norm(iset, ishell)*gcc*aif + END DO + END DO + END DO + + DEALLOCATE (norm) + + END SUBROUTINE contraction_matrix_shg + +!***************************************************************************** +!> \brief normalization solid harmonic Gaussians (SHG) +!> \param basis ... +!> \param norm ... +! ************************************************************************************************** + SUBROUTINE basis_norm_shg(basis, norm) + + TYPE(gto_basis_set_type), POINTER :: basis + REAL(dp), DIMENSION(:, :), POINTER :: norm + + CHARACTER(len=*), PARAMETER :: routineN = 'basis_norm_shg', routineP = moduleN//':'//routineN + + INTEGER :: ipgf, iset, ishell, jpgf, l + REAL(KIND=dp) :: aai, aaj, cci, ccj, expa, ppl + + norm = 0._dp + + DO iset = 1, basis%nset + DO ishell = 1, basis%nshell(iset) + l = basis%l(ishell, iset) + expa = 0.5_dp*REAL(2*l+3, dp) + ppl = fac(2*l+2)*pi**(1.5_dp)/fac(l+1) + ppl = ppl/(2._dp**REAL(2*l+1, dp)) + ppl = ppl/REAL(2*l+1, dp) + DO ipgf = 1, basis%npgf(iset) + cci = basis%gcc(ipgf, ishell, iset) + aai = basis%zet(ipgf, iset) + DO jpgf = 1, basis%npgf(iset) + ccj = basis%gcc(jpgf, ishell, iset) + aaj = basis%zet(jpgf, iset) + norm(iset, ishell) = norm(iset, ishell)+cci*ccj*ppl/(aai+aaj)**expa + END DO + END DO + norm(iset, ishell) = 1.0_dp/SQRT(norm(iset, ishell)) + END DO + END DO + + END SUBROUTINE basis_norm_shg + +! ************************************************************************************************** +!> \brief Calculation of the deviation between SHG and OS integrals +!> \param vab_shg integral matrix obtained from the SHG scheme +!> \param vab_os integral matrix obtained from the OS scheme +!> \param dvab_shg derivative of the integrals, SHG +!> \param dvab_os derivative of the integrals, OS +!> \param dmax maximal deviation of vab matrices +!> \param ddmax maximal deviation of dvab matrices +! ************************************************************************************************** + SUBROUTINE calculate_deviation(vab_shg, vab_os, dvab_shg, dvab_os, dmax, ddmax) + + REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: vab_shg, vab_os + REAL(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: dvab_shg, dvab_os + REAL(KIND=dp), INTENT(OUT) :: dmax, ddmax + + CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_deviation', & + routineP = moduleN//':'//routineN + + INTEGER :: i, j, k + REAL(KIND=dp) :: diff + + dmax = 0.0_dp + ddmax = 0.0_dp + + ! integrals vab + DO j = 1, SIZE(vab_shg, 2) + DO i = 1, SIZE(vab_shg, 1) + diff = ABS(vab_shg(i, j)-vab_os(i, j)) + dmax = MAX(dmax, diff) + ENDDO + ENDDO + + ! derivatives dvab + DO k = 1, 3 + DO j = 1, SIZE(dvab_shg, 2) + DO i = 1, SIZE(dvab_shg, 1) + diff = ABS(dvab_shg(i, j, k)-dvab_os(i, j, k)) + ddmax = MAX(ddmax, diff) + ENDDO + ENDDO + ENDDO + + END SUBROUTINE +END MODULE shg_integrals_test diff --git a/src/start/input_cp2k.F b/src/start/input_cp2k.F index 2bc41e31b1..65eadd81ba 100644 --- a/src/start/input_cp2k.F +++ b/src/start/input_cp2k.F @@ -50,6 +50,7 @@ MODULE input_cp2k USE pw_grids, ONLY: do_pw_grid_blocked_false,& do_pw_grid_blocked_free,& do_pw_grid_blocked_true + USE shg_integrals_test, ONLY: create_shg_integrals_test_section USE string_utilities, ONLY: newline,& s2a USE swarm_input, ONLY: create_swarm_section @@ -276,6 +277,10 @@ CONTAINS CALL section_add_subsection(section, subsection) CALL section_release(subsection) + CALL create_shg_integrals_test_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) + END SUBROUTINE create_test_section ! ************************************************************************************************** diff --git a/tests/LIBTEST/TEST_FILES b/tests/LIBTEST/TEST_FILES index b976fc1dfa..aaeb762fa9 100644 --- a/tests/LIBTEST/TEST_FILES +++ b/tests/LIBTEST/TEST_FILES @@ -29,4 +29,5 @@ dbcsr_order_N.inp 58 1.0E-14 test_eri_mme_accuracy.inp 0 test_eri_mme_performance.inp 0 test_minimax.inp 0 +test_shg_integrals_01.inp 0 #EOF diff --git a/tests/LIBTEST/test_shg_integrals_01.inp b/tests/LIBTEST/test_shg_integrals_01.inp new file mode 100644 index 0000000000..2cfc805a75 --- /dev/null +++ b/tests/LIBTEST/test_shg_integrals_01.inp @@ -0,0 +1,70 @@ +&GLOBAL + PROJECT test_shg_integrals + PRINT_LEVEL MEDIUM + PROGRAM_NAME TEST + RUN_TYPE NONE +&END GLOBAL +&TEST + &SHG_INTEGRALS_TEST + ABC 10.0 10.0 10.0 + NAB_MIN 8 + NREP 2 + CHECK_ACCURACY + &BASIS + 10 + 2 0 0 1 1 + 22.956000679816 1.0 + 2 0 1 1 1 1 + 11.437045132575 1.0 1.0 + 2 0 2 1 1 1 1 + 5.698118029748 1.0 1.0 1.0 + 2 0 2 1 1 1 1 + 2.838893149810 1.0 1.0 1.0 + 2 0 3 1 1 1 1 1 + 1.414381779030 1.0 1.0 1.0 1.0 + 2 0 3 1 1 1 1 1 + 0.704667527549 1.0 1.0 1.0 1.0 + 2 0 3 1 1 1 1 1 + 0.351076584656 1.0 1.0 1.0 1.0 + 2 0 3 1 1 1 1 1 + 0.174911945670 1.0 1.0 1.0 1.0 + 2 0 3 1 1 1 1 1 + 0.087143916955 1.0 1.0 1.0 1.0 + 2 0 3 1 1 1 1 1 + 0.043416487268 1.0 1.0 1.0 1.0 + &END + &BASIS + 15 + 2 0 0 1 1 + 24.031909411024 1.0 + 2 0 0 1 1 + 16.167926705922 1.0 + 2 0 1 1 1 1 + 10.877281929506 1.0 1.0 + 2 0 1 1 1 1 + 7.317899463920 1.0 1.0 + 2 0 2 1 1 1 1 + 4.923256831173 1.0 1.0 1.0 + 2 0 3 1 1 1 1 1 + 3.312215198528 1.0 1.0 1.0 1.0 + 2 0 3 1 1 1 1 1 + 2.228356126354 1.0 1.0 1.0 1.0 + 2 0 4 1 1 1 1 1 1 + 1.499169204968 1.0 1.0 1.0 1.0 1.0 + 2 0 4 1 1 1 1 1 1 + 1.008594756710 1.0 1.0 1.0 1.0 1.0 + 2 0 4 1 1 1 1 1 1 + 0.678551413605 1.0 1.0 1.0 1.0 1.0 + 2 0 4 1 1 1 1 1 1 + 0.456508441910 1.0 1.0 1.0 1.0 1.0 + 2 0 4 1 1 1 1 1 1 + 0.307124785767 1.0 1.0 1.0 1.0 1.0 + 2 0 4 1 1 1 1 1 1 + 0.206624073890 1.0 1.0 1.0 1.0 1.0 + 2 0 4 1 1 1 1 1 1 + 0.139010297734 1.0 1.0 1.0 1.0 1.0 + 2 0 4 1 1 1 1 1 1 + 0.093521836600 1.0 1.0 1.0 1.0 1.0 + &END + &END SHG_INTEGRALS_TEST +&END TEST