1c $Id$ 2* 3C> \ingroup nwint 4C> @{ 5C> 6C> \brief Compute the 3 center overlap integral derivatives 7C> 8C> Compute the 3 center overlap integral derivatives as defined by 9C> \f{eqnarray*}{ 10C> \frac{\partial}{\partial X_x}({\mu}{\nu}{\lambda}) &=& \int_{-\infty}^{\infty} 11C> \frac{\partial g_{\mu}(X_\mu,r_{1})g_{\nu}(X_\nu,r_{1})g_{\lambda}(X_\lambda,r_{1})}{\partial X_x}dr_{1} 12C> \f} 13C> Where \f$X_x\f$ refers to a nuclear coordinate that can be any of 14C> \f$X_\mu\f$, \f$X_\nu\f$ or \f$X_\lambda\f$. 15C> 16C> The integral derivatives are returned in `dOV3`. The order in which the 17C> integrals are stored is equivalent to the array being dimensioned as: 18C> `dOV3(nint,ncoord,natom)` where `ncoord` is equal to 3 for the Cartesian 19C> coordinates, and `natom` is equal to 3 for the atoms on which the Gaussians 20C> are centered. The lexical indeces of the atoms are returned in `idatom`. 21C> This relationship can be stated as: the integrals `dOV3(*,*,i)` belong to 22C> atom `idatom(i)`. 23C> 24C> Finally, if any of the entries in `idatom` equals 0 then the data in `dOV3` 25C> is invalid. 26C> 27c:tex-% this is part of the API Standard Integral routines. 28c:tex-\subsection{intd\_1e3ov} 29c:tex-This routine computes the 3 center overlap integral derivatives: 30c:tex-\[ 31c:tex-\frac{\partial}{\partial q}({\mu}{\nu}{\lamda}) = \int_{-\infty}^{\infty} 32c:tex-g_{\mu}(X,r_{1})g_{\nu}(X-R,r_{1})g_{\lamda}(X-R,r_{1})dr_{1} 33c:tex-\] 34c:tex-{\it Syntax:} 35c:tex-\begin{verbatim} 36 subroutine intd_1e3ov (i_basis, ish, j_basis, jsh, k_basis, ksh, 37 & lscr, scr, ldov3, dOV3, idatom) 38c:tex-\end{verbatim} 39 implicit none 40#include "nwc_const.fh" 41#include "errquit.fh" 42#include "basP.fh" 43#include "basdeclsP.fh" 44#include "geobasmapP.fh" 45#include "geomP.fh" 46#include "mafdecls.fh" 47#include "bas_exndcf_dec.fh" 48#include "bas_ibs_dec.fh" 49#include "int_nbf.fh" 50#include "stdio.fh" 51c:: external subroutines used 52c.. errquit 53c::functions 54 logical int_chk_sh, int_chk_init 55 external int_chk_sh, int_chk_init 56c::passed 57c:tex-\begin{verbatim} 58 integer i_basis !< [Input] basis set handle for ish 59 integer ish !< [Input] i shell/contraction 60 integer j_basis !< [Input] basis set handle for jsh 61 integer jsh !< [Input] j shell/contraction 62 integer k_basis !< [Input] basis set handle for ksh 63 integer ksh !< [Input] k shell/contraction 64 integer lscr !< [Input] length of scratch array 65 double precision scr(lscr) !< [Scratch] scratch array 66 integer ldov3 !< [Input] length of 3c overlap integrals array 67 double precision dOV3(*) !< [Output] 3c overlap integrals 68 integer idatom(3) !< [Output] array identifying centers for derivatives 69c ! e.g., the first nint*3 derivatives go to center idatom(1) 70c ! the second nint*3 derivatives go to center idatom(2) 71c:tex-\end{verbatim} 72c 73c Order is... nint*3*3 (3=> xyz, 3=atoms) 74c 75c / | 76c | nint,d <ij> | 77c | --------------| 78c \ d[idatom(1),x]| 79c | 80c nint,d <ij> | 81c --------------| 82c d[idatom(1),y]| 83c | 84c nint,d <ij> | 85c --------------| 86c d[idatom(1),z]| 87c | 88c nint,d <ij> | 89c --------------| 90c d[idatom(2),x]| 91c | 92c nint,d <ij> | 93c --------------| 94c d[idatom(2),y]| 95c | 96c nint,d <ij> | 97c --------------| 98c d[idatom(2),z]| 99c | 100c nint,d <ij> | 101c --------------| 102c d[idatom(3),x]| 103c | 104c nint,d <ij> | 105c --------------| 106c d[idatom(3),y]| 107c \ 108c nint,d <ij> | 109c -------------- | 110c d[idatom(3),z]/ 111c If idatom(?) = 0 then do not use this 3*nint block of integral derivatives 112c::local 113 logical any_spherical 114 logical shells_ok 115 integer nint_intrnl 116 integer ucont 117 integer ibas, jbas, kbas 118 integer i_geom, j_geom, k_geom 119 integer Li, i_prim, i_gen, i_iexp, i_icfp, i_cent 120 integer Lj, j_prim, j_gen, j_iexp, j_icfp, j_cent 121 integer Lk, k_prim, k_gen, k_iexp, k_icfp, k_cent 122c 123 integer i_pov3, j_pov3, k_pov3 124 integer WarnP 125 save WarnP 126 data WarnP /0/ 127c 128#include "bas_exndcf_sfn.fh" 129#include "bas_ibs_sfn.fh" 130c 131c check initialization and shells 132c 133 if (.not.int_chk_init('intd_1e3ov')) 134 & call errquit('intd_1e3ov: int_init was not called' ,0, 135 & INT_ERR) 136c 137 shells_ok = int_chk_sh(i_basis,ish) 138 shells_ok = shells_ok .and. int_chk_sh(j_basis,jsh) 139 shells_ok = shells_ok .and. int_chk_sh(k_basis,ksh) 140 if (.not.shells_ok) 141 & call errquit('intd_1e3ov: invalid contraction/shell',0, 142 & BASIS_ERR) 143c 144 call int_nogencont_check(i_basis,'intd_1e3ov:i_basis') 145 call int_nogencont_check(j_basis,'intd_1e3ov:j_basis') 146 call int_nogencont_check(k_basis,'intd_1e3ov:k_basis') 147 call int_nospshell_check(i_basis,'intd_1e3ov:i_basis') 148 call int_nospshell_check(j_basis,'intd_1e3ov:j_basis') 149 call int_nospshell_check(k_basis,'intd_1e3ov:k_basis') 150c 151 ibas = i_basis + BASIS_HANDLE_OFFSET 152 jbas = j_basis + BASIS_HANDLE_OFFSET 153 kbas = k_basis + BASIS_HANDLE_OFFSET 154c 155 ucont = (sf_ibs_cn2ucn(ish,ibas)) 156 Li = infbs_cont(CONT_TYPE ,ucont,ibas) 157 i_prim = infbs_cont(CONT_NPRIM,ucont,ibas) 158 i_gen = infbs_cont(CONT_NGEN ,ucont,ibas) 159 i_iexp = infbs_cont(CONT_IEXP ,ucont,ibas) 160 i_icfp = infbs_cont(CONT_ICFP ,ucont,ibas) 161 i_cent = (sf_ibs_cn2ce(ish,ibas)) 162 i_geom = ibs_geom(ibas) 163c 164 ucont = (sf_ibs_cn2ucn(jsh,jbas)) 165 Lj = infbs_cont(CONT_TYPE ,ucont,jbas) 166 j_prim = infbs_cont(CONT_NPRIM,ucont,jbas) 167 j_gen = infbs_cont(CONT_NGEN ,ucont,jbas) 168 j_iexp = infbs_cont(CONT_IEXP ,ucont,jbas) 169 j_icfp = infbs_cont(CONT_ICFP ,ucont,jbas) 170 j_cent = (sf_ibs_cn2ce(jsh,jbas)) 171 j_geom = ibs_geom(jbas) 172c 173 ucont = (sf_ibs_cn2ucn(ksh,kbas)) 174 Lk = infbs_cont(CONT_TYPE ,ucont,kbas) 175 k_prim = infbs_cont(CONT_NPRIM,ucont,kbas) 176 k_gen = infbs_cont(CONT_NGEN ,ucont,kbas) 177 k_iexp = infbs_cont(CONT_IEXP ,ucont,kbas) 178 k_icfp = infbs_cont(CONT_ICFP ,ucont,kbas) 179 k_cent = (sf_ibs_cn2ce(ksh,kbas)) 180 k_geom = ibs_geom(kbas) 181c 182 nint_intrnl = int_nbf_x(Li)*int_nbf_x(Lj)*int_nbf_x(Lk) 183 if ((nint_intrnl*9).gt.ldov3) then 184 write(luout,*)' buffer size too small ' 185 write(luout,*)' buffer size : ',ldov3 186 write(luout,*)' needed : ',(nint_intrnl*9) 187 stop ' intd_1e3ov: fatal error ' 188 endif 189c 190 if ((i_cent.eq.j_cent).and.(j_cent.eq.k_cent)) then 191 idatom(1) = 0 192 idatom(2) = 0 193 idatom(3) = 0 194 call dcopy((9*nint_intrnl),0.0d00,0,dOV3,1) 195 return 196 endif 197c 198 if ((i_geom.ne.j_geom.or.j_geom.ne.k_geom).and.WarnP.eq.0) then 199 write(luout,*) 200 & 'intd_1e3ov: WARNING: possible geometry inconsistency' 201 write(luout,*)'i_basis geometry handle:',i_geom 202 write(luout,*)'j_basis geometry handle:',j_geom 203 write(luout,*)'k_basis geometry handle:',k_geom 204 WarnP = 1 205 endif 206c 207 call hfd3ois( 208 & coords(1,i_cent,i_geom), 209 & dbl_mb(mb_exndcf(i_iexp,ibas)), 210 & dbl_mb(mb_exndcf(i_icfp,ibas)), 211 & i_prim, 1, Li, 212 & coords(1,j_cent,j_geom), 213 & dbl_mb(mb_exndcf(j_iexp,jbas)), 214 & dbl_mb(mb_exndcf(j_icfp,jbas)), 215 & j_prim, 1, Lj, 216 & coords(1,k_cent,k_geom), 217 & dbl_mb(mb_exndcf(k_iexp,kbas)), 218 & dbl_mb(mb_exndcf(k_icfp,kbas)), 219 & k_prim, 1, Lk, 220 & dOV3,nint_intrnl, 221c.........DryRun 222 & .false.,scr,lscr) 223c 224 i_pov3 = 1 ! pointer to i block of derivs 225 j_pov3 = 3*nint_intrnl+i_pov3 ! pointer to j block of derivs 226 k_pov3 = 3*nint_intrnl+j_pov3 ! pointer to k block of derivs 227c 228 any_spherical = bas_spherical(ibas).or. 229 & bas_spherical(jbas).or.bas_spherical(kbas) 230 if ((i_cent.ne.j_cent).and.(i_cent.ne.k_cent).and. 231 & (j_cent.ne.k_cent)) then 232 idatom(1) = i_cent 233 idatom(2) = j_cent 234 idatom(3) = k_cent 235 if (any_spherical) then 236 if (Li.eq.-1) i_gen = 1 237 if (Lj.eq.-1) j_gen = 1 238 if (Lk.eq.-1) k_gen = 1 239 call spcart_3cBtran(dOV3,scr,lscr, 240 & int_nbf_x(Li),int_nbf_s(Li),Li,i_gen,bas_spherical(ibas), 241 & int_nbf_x(Lj),int_nbf_s(Lj),Lj,j_gen,bas_spherical(jbas), 242 & int_nbf_x(Lk),int_nbf_s(Lk),Lk,k_gen,bas_spherical(kbas), 243 & 9,.false.) 244 endif 245 else if (i_cent.eq.j_cent) then 246 call daxpy(3*nint_intrnl,1.0d00,dOV3(j_pov3),1,dOV3(i_pov3),1) 247 call dcopy(3*nint_intrnl,dOV3(k_pov3),1,dOV3(j_pov3),1) 248 call dcopy(3*nint_intrnl,0.0d00,0,dOV3(k_pov3),1) 249 idatom(1) = i_cent 250 idatom(2) = k_cent 251 idatom(3) = 0 252 if (any_spherical) then 253 if (Li.eq.-1) i_gen = 1 254 if (Lj.eq.-1) j_gen = 1 255 if (Lk.eq.-1) k_gen = 1 256 call spcart_3cBtran(dOV3,scr,lscr, 257 & int_nbf_x(Li),int_nbf_s(Li),Li,i_gen,bas_spherical(ibas), 258 & int_nbf_x(Lj),int_nbf_s(Lj),Lj,j_gen,bas_spherical(jbas), 259 & int_nbf_x(Lk),int_nbf_s(Lk),Lk,k_gen,bas_spherical(kbas), 260 & 6,.false.) 261 endif 262 else if (i_cent.eq.k_cent) then 263 call daxpy(3*nint_intrnl,1.0d00,dOV3(k_pov3),1,dOV3(i_pov3),1) 264 call dcopy(3*nint_intrnl,0.0d00,0,dOV3(k_pov3),1) 265 idatom(1) = i_cent 266 idatom(2) = j_cent 267 idatom(3) = 0 268 if (any_spherical) then 269 if (Li.eq.-1) i_gen = 1 270 if (Lj.eq.-1) j_gen = 1 271 if (Lk.eq.-1) k_gen = 1 272 call spcart_3cBtran(dOV3,scr,lscr, 273 & int_nbf_x(Li),int_nbf_s(Li),Li,i_gen,bas_spherical(ibas), 274 & int_nbf_x(Lj),int_nbf_s(Lj),Lj,j_gen,bas_spherical(jbas), 275 & int_nbf_x(Lk),int_nbf_s(Lk),Lk,k_gen,bas_spherical(kbas), 276 & 6,.false.) 277 endif 278 else if (j_cent.eq.k_cent) then 279 call daxpy(3*nint_intrnl,1.0d00,dOV3(k_pov3),1,dOV3(j_pov3),1) 280 call dcopy(3*nint_intrnl,0.0d00,0,dOV3(k_pov3),1) 281 idatom(1) = i_cent 282 idatom(2) = j_cent 283 idatom(3) = 0 284 if (any_spherical) then 285 if (Li.eq.-1) i_gen = 1 286 if (Lj.eq.-1) j_gen = 1 287 if (Lk.eq.-1) k_gen = 1 288 call spcart_3cBtran(dOV3,scr,lscr, 289 & int_nbf_x(Li),int_nbf_s(Li),Li,i_gen,bas_spherical(ibas), 290 & int_nbf_x(Lj),int_nbf_s(Lj),Lj,j_gen,bas_spherical(jbas), 291 & int_nbf_x(Lk),int_nbf_s(Lk),Lk,k_gen,bas_spherical(kbas), 292 & 6,.false.) 293 endif 294 else 295 write(luout,*)'ijk->centers',i_cent,j_cent,k_cent 296 write(luout,*)' fatal error ' 297 stop 'intd_1e3ov: how did I get here' 298 endif 299 end 300C> @} 301