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