1C> \ingroup nwint 2C> @{ 3C> 4C> \brief Compute transposed 2-electron 3-center Gaussian periodic 5C> electron repulsion integrals 6C> 7C> The code in question always uses density fitting approaches for 8C> the 3-center 2-electron integrals are needed. See [1] for details. 9C> 10C> [1] JE Jaffe, AC Hess, 11C> <i>"Gaussian basis density functional theory for systems 12C> periodic in two or three dimensions: Energy and forces"</i>, 13C> J.Chem.Phys. <b>105</b>, 10983-10998 (1996), DOI: 14C> <a href="https://doi.org/10.1063/1.472866"> 15C> 10.1063/1.472866</a> 16C> 17 subroutine intp_2e3ct(brain, ish, jsh, ketin, ksh, Rj, Rk, 18 & lscr, scr, leri, eri) 19* 20* $Id$ 21* 22 implicit none 23c 24c basic api routine to generate a block of 3 center two 25c electron integrals 26c 27c eri = <bra_g(ish)bra_g(jsh)|ket_g(ksh)> 28c 29#include "apiP.fh" 30#include "errquit.fh" 31#include "bas.fh" 32#include "nwc_const.fh" 33#include "basP.fh" 34#include "basdeclsP.fh" 35#include "geomP.fh" 36#include "geobasmapP.fh" 37#include "stdio.fh" 38#include "mafdecls.fh" 39#include "bas_exndcf_dec.fh" 40#include "bas_ibs_dec.fh" 41#include "int_nbf.fh" 42c 43c::external subroutines used 44c errquit 45c::functions 46 logical cando_nw 47 logical int_chk_sh 48 logical int_chk_init 49 external cando_nw 50 external int_chk_sh 51 external int_chk_init 52c:: passed 53 integer brain !< [Input] basis set handle for bra function 54 integer ketin !< [Input] basis set handle for ket function 55 integer ish !< [Input] lexical contraction/shell index 56 integer jsh !< [Input] lexical contraction/shell index 57 integer ksh !< [Input] lexical contraction/shell index 58 integer lscr !< [Input] length of scratch array 59 integer leri !< [Input] length of ERI array 60 double precision scr(lscr) !< [Scratch] scratch array 61 double precision eri(leri) !< [Output] ERI array 62c translation vectors are in fractional coordinates ! 63 double precision Rk(3) !< [Input] translation vector for ksh center 64 double precision Rj(3) !< [Input] translation vector for jsh center 65c:: local 66 logical shells_ok 67 integer bra, ket 68 integer q_geom, ab_geom, ucont 69 integer Lq, q_prim, q_gen, q_iexp, q_icfp, q_cent 70 integer La, a_prim, a_gen, a_iexp, a_icfp, a_cent 71 integer Lb, b_prim, b_gen, b_iexp, b_icfp, b_cent 72 integer nintx 73 double precision xyz_new_k(3) ! new coordinates for ksh function 74 double precision xyz_new_j(3) ! new coordinates for jsh function 75c 76 integer WarnP 77 save WarnP 78 data WarnP /0/ 79c 80#include "bas_exndcf_sfn.fh" 81#include "bas_ibs_sfn.fh" 82c 83c check initialization 84c 85 if (.not.int_chk_init('intp_2e3ct')) 86 & call errquit('intp_2e3ct: int_init was not called' ,0, 87 & INT_ERR) 88c 89c check input shell ranges 90c 91 shells_ok = int_chk_sh(brain,ish) 92 shells_ok = shells_ok .and. int_chk_sh(brain,jsh) 93 shells_ok = shells_ok .and. int_chk_sh(ketin,ksh) 94 if (.not.shells_ok) 95 & call errquit('intp_2e3ct: invalid contraction/shell',0, 96 & BASIS_ERR) 97c 98c check if spherical/gencon/sp shell 99c 100 call int_nogencont_check(brain,'intp_2e3ct:bra') 101 call int_nogencont_check(ketin,'intp_2e3ct:ket') 102 call int_nospshell_check(brain,'intp_2e3ct:bra') 103 call int_nospshell_check(ketin,'intp_2e3ct:ket') 104c 105c define center information required 106c 107 bra = brain + BASIS_HANDLE_OFFSET 108 ket = ketin + BASIS_HANDLE_OFFSET 109 ab_geom = ibs_geom(bra) 110 q_geom = ibs_geom(ket) 111c 112 if (q_geom.ne.ab_geom.and.WarnP.eq.0) then 113 write(luout,*) 114 & 'intp_2e3ct: WARNING: possible geometry inconsistency' 115 write(luout,*)'bra geometry handle:',ab_geom 116 write(luout,*)'ket geometry handle:',q_geom 117 WarnP = 1 118 endif 119c 120 a_cent = (sf_ibs_cn2ce(ish,bra)) 121 b_cent = (sf_ibs_cn2ce(jsh,bra)) 122 q_cent = (sf_ibs_cn2ce(ksh,ket)) 123c.. translate ksh center coordinates based on Rk 124 call intp_txyz(q_cent,q_geom,Rk,xyz_new_k) 125c.. translate jsh center coordinates based on Rj 126 call intp_txyz(b_cent,ab_geom,Rj,xyz_new_j) 127c 128 if(cando_nw(brain,ish,jsh).and.cando_nw(ketin,ksh,0)) then 129c 130 ucont = (sf_ibs_cn2ucn(ish,bra)) 131 La = infbs_cont(CONT_TYPE ,ucont,bra) 132 a_prim = infbs_cont(CONT_NPRIM,ucont,bra) 133 a_gen = infbs_cont(CONT_NGEN ,ucont,bra) 134 a_iexp = infbs_cont(CONT_IEXP ,ucont,bra) 135 a_icfp = infbs_cont(CONT_ICFP ,ucont,bra) 136c 137 ucont = (sf_ibs_cn2ucn(jsh,bra)) 138 Lb = infbs_cont(CONT_TYPE ,ucont,bra) 139 b_prim = infbs_cont(CONT_NPRIM,ucont,bra) 140 b_gen = infbs_cont(CONT_NGEN ,ucont,bra) 141 b_iexp = infbs_cont(CONT_IEXP ,ucont,bra) 142 b_icfp = infbs_cont(CONT_ICFP ,ucont,bra) 143c 144 ucont = (sf_ibs_cn2ucn(ksh,ket)) 145 Lq = infbs_cont(CONT_TYPE ,ucont,ket) 146 q_prim = infbs_cont(CONT_NPRIM,ucont,ket) 147 q_gen = infbs_cont(CONT_NGEN ,ucont,ket) 148 q_iexp = infbs_cont(CONT_IEXP ,ucont,ket) 149 q_icfp = infbs_cont(CONT_ICFP ,ucont,ket) 150c 151 call hf2( 152 & coords(1,a_cent,ab_geom), dbl_mb(mb_exndcf(a_iexp,bra)), 153 & dbl_mb(mb_exndcf(a_icfp,bra)), a_prim,a_gen,La, 154 & xyz_new_j, dbl_mb(mb_exndcf(b_iexp,bra)), 155 & dbl_mb(mb_exndcf(b_icfp,bra)), b_prim, b_gen, Lb, 156 & xyz_new_k, dbl_mb(mb_exndcf(q_iexp,ket)), 157 & dbl_mb(mb_exndcf(q_icfp,ket)), q_prim, q_gen, Lq, 158 & xyz_new_k, DCexp, 159 & DCcoeff , 1, 1, 0, 160c......................... canAB canCD canPQ 161 & eri, leri, .false., .false., .false., 162c............ dryrun 163 & .false., scr, lscr) 164c 165 if (bas_spherical(ket).or.bas_spherical(bra)) then 166 nintx = int_nbf_x(Lq)*int_nbf_x(La)*int_nbf_x(Lb) 167 if (nintx.lt.lscr) 168 & call errquit 169 & ('intp_2e3ct: not enough scratch for spherical transform', 170 & 911, MEM_ERR) 171 call spcart_3ctran(eri,scr,lscr, 172 & int_nbf_x(La),int_nbf_s(La),La,a_gen,bas_spherical(bra), 173 & int_nbf_x(Lb),int_nbf_s(Lb),Lb,b_gen,bas_spherical(bra), 174 & int_nbf_x(Lq),int_nbf_s(Lq),Lq,q_gen,bas_spherical(ket), 175 & .false.) 176 endif 177 else 178 write(luout,*)'intp_2e3ct: could not do nw integrals' 179 write(luout,*)' brain :',brain 180 write(luout,*)' ketin :',ketin 181 write(luout,*)' ish :',ish 182 write(luout,*)' jsh :',jsh 183 write(luout,*)' ksh :',ksh 184 call errquit('intp_2e3ct: fatal error ',0, INT_ERR) 185 endif 186 end 187C> @} 188