1C> \ingroup nwint 2C> @{ 3C> 4C> \brief Compute the 4-center 2-electron integral derivatives 5C> 6C> Compute the 4-center 2-electron integral derivatives as given by 7C> \f{eqnarray*}{ 8C> \frac{\partial({\mu}{\rho}|{\nu}{\lambda})}{\partial X_x} = \int_{-\infty}^{\infty} \frac{\partial g_{\mu}(X_{\mu},r_{1})g_{\rho}(X_{\rho},r_{1})\frac{1}{r_{12}}g_{\nu}(X_{\nu},r_{2})g_{\lambda}(X_{\lambda},r_{2})}{\partial X_x}dr_{1}dr_{2} 9C> \f} 10C> The integral derivatives are stored in an order that is consistent with 11C> the declaration `ERI(nint,ncoord,natom)`, where `nint` is the number of 12C> integrals in the shell pair, `ncoord` is the number of Cartesian coordinates 13C> and `natom` equals 4 for the 4 basis set expansion centers. The actual 14C> lexical indeces of the atoms on which the shells `ish`, `jsh`, `ksh` and 15C> `lsh` are centered are returned in `idatom`. 16C> 17 subroutine intd_2e4c(brain, ish, jsh, ketin, ksh, lsh, 18 & lscr, scr, leri, eri, idatom) 19c $Id$ 20 implicit none 21c 22c basic api routine to generate 4 center two electron integral derivatives 23c 24#include "stdio.fh" 25#include "errquit.fh" 26#include "bas.fh" 27#include "nwc_const.fh" 28#include "basP.fh" 29#include "basdeclsP.fh" 30#include "geomP.fh" 31#include "geobasmapP.fh" 32#include "mafdecls.fh" 33#include "bas_exndcf_dec.fh" 34#include "bas_ibs_dec.fh" 35#include "apiP.fh" 36#include "rel_nwc.fh" 37c 38c::external subroutines used 39c errquit 40c::functions 41 integer int_nint_cart 42 external int_nint_cart 43ckw 44 integer int_nint 45 external int_nint 46c 47 logical cando_nw 48 logical cando_txs 49 logical cando_sim 50 external cando_nw 51 external cando_txs 52 external cando_sim 53ckw 54c::passed 55 integer brain !< [Input] basis set handle for bra basis 56 integer ish !< [Input] lexical contraction index 57 integer jsh !< [Input] lexical contraction index 58 integer ketin !< [Input] basis set handle for ket basis 59 integer ksh !< [Input] lexical contraction index 60 integer lsh !< [Input] lexical contraction index 61 integer lscr !< [Input] length of scratch array 62 integer leri !< [Input] length of eri array 63 double precision scr(lscr) !< [Scratch] scratch array for integral code. 64 double precision eri(leri) !< [Output] array for two electron integral derivatives. 65c NOTE: length of idatom is always 4 because there can be at most 4 centers involved 66 integer idatom(4) !< [Output] array identifying centers for derivatives 67c 68c ! e.g., the first nint*3 derivatives go to center idatom(1) 69c ! the second nint*3 derivatives go to center idatom(2) 70c ! the third nint*3 derivatives go to center idatom(3) 71c ! the fourth nint*3 derivatives go to center idatom(4) 72c 73c Order is... nint*3*4 (3=> xyz, 4=atoms) 74c 75c / | 76c | nint, d <ij|kl> | 77c | --------------| 78c \ d[idatom(1),x]| 79c | 80c nint, d <ij|kl> | 81c --------------| 82c d[idatom(1),y]| 83c | 84c nint, d <ij|kl> | 85c --------------| 86c d[idatom(1),z]| 87c | 88c nint, d <ij|kl> | 89c --------------| 90c d[idatom(2),x]| 91c | 92c nint, d <ij|kl> | 93c --------------| 94c d[idatom(2),y]| 95c | 96c nint, d <ij|kl> | 97c -------------- | 98c d[idatom(2),z] | 99c | 100c nint, d <ij|kl> | 101c --------------| 102c d[idatom(3),x]| 103c | 104c nint, d <ij|kl> | 105c --------------| 106c d[idatom(3),y]| 107c | 108c nint, d <ij|kl> | 109c --------------| 110c d[idatom(3),z]| 111c | 112c nint, d <ij|kl> | 113c --------------| 114c d[idatom(4),x]| 115c | 116c nint, d <ij|kl> | 117c --------------| 118c d[idatom(4),y]| 119c \ 120c nint, d <ij|kl> | 121c -------------- | 122c d[idatom(4),z] / 123c 124c::local 125 integer nint_ck, ucont 126 integer bra, ket, ab_geom, cd_geom 127 integer inp, igen, iexp, icf, icfs, itype, iatom 128 integer jnp, jgen, jexp, jcf, jcfs, jtype, jatom 129 integer knp, kgen, kexp, kcf, kcfs, ktype, katom 130 integer lnp, lgen, lexp, lcf, lcfs, ltype, latom 131c.rel-dmd 132 logical status_rel, bra_rel, ket_rel 133 logical i_rel, j_rel, k_rel, l_rel 134 integer sbas, abas, bras, kets 135ckw 136 double precision roff(3) 137 integer txs_i, txs_j, txs_k, txs_l 138 logical status_nw, status_txs, status_sim 139 logical dum_log 140 integer nintzero, num_quart, dummy_lab 141 double precision q4 142 integer momentum 143 integer scr_ptr,ii 144ckw 145c 146#include "bas_exndcf_sfn.fh" 147#include "bas_ibs_sfn.fh" 148#include "int_nbf.fh" 149c 150 i_rel = .false. 151 j_rel = .false. 152 k_rel = .false. 153 l_rel = .false. 154 nint_ck = int_nint_cart(brain,ish,brain,jsh,ketin,ksh,ketin,lsh) 155 if (nint_ck*3*4.gt.leri) then 156 write(luout,*) 'nint*3*4 = ',nint_ck*3*4 157 write(luout,*) 'leri = ',leri 158 call errquit('intd_2e4c: nint>leri error',911, INT_ERR) 159 endif 160c 161c check if spherical/gencon/sp shell 162c 163 call int_nogencont_check(brain,'intd_2e4c:bra') 164 call int_nogencont_check(ketin,'intd_2e4c:ket') 165 call int_nospshell_check(brain,'intd_2e4c:bra') 166 call int_nospshell_check(ketin,'intd_2e4c:ket') 167c 168 bra = brain + BASIS_HANDLE_OFFSET 169 ket = ketin + BASIS_HANDLE_OFFSET 170 bras = bra 171 kets = ket 172c 173 ab_geom = ibs_geom(bra) 174 cd_geom = ibs_geom(ket) 175 if (ab_geom.ne.cd_geom) then 176 write(luout,*) 177 & 'intd_2e4c.F: two different geometries for', 178 & ' derivatives?' 179 call errquit('intd_2e4c: geom error ',911, INT_ERR) 180 endif 181 182c... stat rel 183 status_rel = dyall_mod_dir .and. .not.nesc_1e_approx 184 & .and. (brain .eq. ketin) .and. (brain .eq. ao_bsh) 185 if (status_rel) then 186c 187c get basis set handles; relativistic integral option valid 188c if bra or ket are the ao basis and bra and ket have both 189c functions relativistic 190c 191 bra_rel = .false. 192 ket_rel = .false. 193 sbas = sc_bsh + BASIS_HANDLE_OFFSET 194 abas = ao_bsh + BASIS_HANDLE_OFFSET 195 bras = sbas 196 kets = sbas 197 bra_rel = bra .eq. abas 198 if (bra_rel) then 199 ucont = sf_ibs_cn2ucn(ish,bra) 200 i_rel = infbs_cont(CONT_RELLS ,ucont,bra) .ne. 0 201 ucont = sf_ibs_cn2ucn(jsh,bra) 202 j_rel = infbs_cont(CONT_RELLS ,ucont,bra) .ne. 0 203 bra_rel = bra_rel .and. i_rel .and. j_rel 204 end if 205 ket_rel = ket .eq. abas 206 if (ket_rel) then 207 ucont = sf_ibs_cn2ucn(ksh,ket) 208 k_rel = infbs_cont(CONT_RELLS ,ucont,ket) .ne. 0 209 ucont = sf_ibs_cn2ucn(lsh,ket) 210 l_rel = infbs_cont(CONT_RELLS ,ucont,ket) .ne. 0 211 ket_rel = ket_rel .and. k_rel .and. l_rel 212 end if 213 status_rel = status_rel .and. (bra_rel .or. ket_rel) 214 end if 215c 216 ucont = (sf_ibs_cn2ucn(ish,bra)) 217 inp = infbs_cont(CONT_NPRIM,ucont,bra) 218 igen = infbs_cont(CONT_NGEN,ucont,bra) 219 iexp = infbs_cont(CONT_IEXP,ucont,bra) 220 icf = infbs_cont(CONT_ICFP,ucont,bra) 221 itype = infbs_cont(CONT_TYPE,ucont,bra) 222 iatom = (sf_ibs_cn2ce(ish,bra)) 223 if (i_rel) ucont = ao_to_ls(ucont) 224 icfs = infbs_cont(CONT_ICFP,ucont,bras) 225c 226 ucont = (sf_ibs_cn2ucn(jsh,bra)) 227 jnp = infbs_cont(CONT_NPRIM,ucont,bra) 228 jgen = infbs_cont(CONT_NGEN,ucont,bra) 229 jexp = infbs_cont(CONT_IEXP,ucont,bra) 230 jcf = infbs_cont(CONT_ICFP,ucont,bra) 231 jtype = infbs_cont(CONT_TYPE,ucont,bra) 232 jatom = (sf_ibs_cn2ce(jsh,bra)) 233 if (j_rel) ucont = ao_to_ls(ucont) 234 jcfs = infbs_cont(CONT_ICFP,ucont,bras) 235c 236 ucont = (sf_ibs_cn2ucn(ksh,ket)) 237 knp = infbs_cont(CONT_NPRIM,ucont,ket) 238 kgen = infbs_cont(CONT_NGEN,ucont,ket) 239 kexp = infbs_cont(CONT_IEXP,ucont,ket) 240 kcf = infbs_cont(CONT_ICFP,ucont,ket) 241 ktype = infbs_cont(CONT_TYPE,ucont,ket) 242 katom = (sf_ibs_cn2ce(ksh,ket)) 243 if (k_rel) ucont = ao_to_ls(ucont) 244 kcfs = infbs_cont(CONT_ICFP,ucont,kets) 245c 246 ucont = (sf_ibs_cn2ucn(lsh,ket)) 247 lnp = infbs_cont(CONT_NPRIM,ucont,ket) 248 lgen = infbs_cont(CONT_NGEN,ucont,ket) 249 lexp = infbs_cont(CONT_IEXP,ucont,ket) 250 lcf = infbs_cont(CONT_ICFP,ucont,ket) 251 ltype = infbs_cont(CONT_TYPE,ucont,ket) 252 latom = (sf_ibs_cn2ce(lsh,ket)) 253 if (l_rel) ucont = ao_to_ls(ucont) 254 lcfs = infbs_cont(CONT_ICFP,ucont,kets) 255c 256c... new logic 257 if (iatom.eq.jatom.and.jatom.eq.katom.and.katom.eq.latom) then 258 call dcopy((nint_ck*3*4),0.0d00,0,eri,1) 259 call ifill(4,-1,idatom,1) 260 return 261 endif 262c 263ckw-------- 264ckw 265 momentum=abs(itype)+abs(jtype)+abs(ktype)+abs(ltype) 266 status_txs =.true. 267 if( momentum.lt.4) then 268 status_txs =.false. 269 endif 270 status_txs = status_txs .and. 271 & cando_txs(brain,ish,jsh).and.cando_txs(ketin,ksh,lsh) 272 status_nw = 273 & cando_nw(brain,ish,jsh).and.cando_nw(ketin,ksh,lsh) 274 if (lgen.gt.1.or.kgen.gt.1.or.jgen.gt.1.or.igen.gt.1) then 275 status_txs = status_txs .and. .true. 276 status_nw = .false. 277 endif 278 status_sim = cando_sim(brain,ish,jsh).and.cando_sim(ketin,ksh,lsh) 279************************************************************************* 280* texas one at a time is broke for now: temporary fix 281************************************************************************* 282 status_txs = .false. 283************************************************************************* 284c 285 if (status_txs .and. .not.status_rel) then 286 call dcopy(3,0.0d00,0,roff,1) 287 q4 = 1.0d00 288 txs_i = ish 289 txs_j = jsh 290 txs_k = ksh 291 txs_l = lsh 292 num_quart=1 293 dum_log=.false. 294c 295 call texas_hf2_m( 296 & brain,txs_i,txs_j, 297 & ketin,txs_k,txs_l,num_quart, 298 & q4,.false., 299c...............................use roff set false 300 & roff,roff,roff,roff,.false., 301 & eri, leri, dummy_lab, dummy_lab, dummy_lab, dummy_lab, 302c...............gen labs .. more_integrals 303 & nint_ck, .false., dum_log, scr, lscr, 0.0d0,'der1_int') 304 if (nint_ck .eq. 0) then 305 nintzero = int_nint(brain,ish,brain,jsh,ketin,ksh,ketin,lsh) 306 nintzero = nintzero*12 307 call dcopy(nintzero, 0.0d0, 0, eri, 1) 308 endif 309c 310 if (nint_ck*12.gt.lscr) call errquit 311 $ ('intd_2e4c: lscr is too small for texas derivatives', 312 $ 911, INT_ERR) 313 scr_ptr = lscr - nint_ck*12 - 1 314 call dcopy((nint_ck*12),eri,1,scr(scr_ptr),1) 315 call intd_texas_grad_switch(nint_ck,eri,scr(scr_ptr)) 316 call intd_sum(eri,nint_ck,idatom,iatom,jatom,katom,latom) 317c 318 else if (status_nw) then 319 if (status_rel) then 320 call rel_2e4cd_sf ( 321 & coords(1,iatom,ab_geom),dbl_mb(mb_exndcf(iexp,bra)), 322 & dbl_mb(mb_exndcf(icf,bra)),dbl_mb(mb_exndcf(icfs,bras)), 323 & inp,igen,itype,iatom, 324c 325 & coords(1,jatom,ab_geom),dbl_mb(mb_exndcf(jexp,bra)), 326 & dbl_mb(mb_exndcf(jcf,bra)),dbl_mb(mb_exndcf(jcfs,bras)), 327 & jnp,jgen,jtype,jatom, 328c 329 & coords(1,katom,cd_geom),dbl_mb(mb_exndcf(kexp,ket)), 330 & dbl_mb(mb_exndcf(kcf,ket)),dbl_mb(mb_exndcf(kcfs,kets)), 331 & knp,kgen,ktype,katom, 332c 333 & coords(1,latom,cd_geom),dbl_mb(mb_exndcf(lexp,ket)), 334 & dbl_mb(mb_exndcf(lcf,ket)),dbl_mb(mb_exndcf(lcfs,kets)), 335 & lnp,lgen,ltype,latom, 336c 337 & eri,nint_ck,.false.,.false.,.false.,.false., 338 & scr,lscr,bra_rel,ket_rel,ss_one_cent,do_ssss,rel_dbg) 339 else 340 call hf2d( 341 & coords(1,iatom,ab_geom),dbl_mb(mb_exndcf(iexp,bra)), 342 & dbl_mb(mb_exndcf(icf,bra)),inp,igen,itype,iatom, 343c 344 & coords(1,jatom,ab_geom),dbl_mb(mb_exndcf(jexp,bra)), 345 & dbl_mb(mb_exndcf(jcf,bra)),jnp,jgen,jtype,jatom, 346c 347 & coords(1,katom,cd_geom),dbl_mb(mb_exndcf(kexp,ket)), 348 & dbl_mb(mb_exndcf(kcf,ket)),knp,kgen,ktype,katom, 349c 350 & coords(1,latom,cd_geom),dbl_mb(mb_exndcf(lexp,ket)), 351 & dbl_mb(mb_exndcf(lcf,ket)),lnp,lgen,ltype,latom, 352c 353 & eri,nint_ck,.false.,.false.,.false.,.false., 354 & scr,lscr) 355 end if 356c 357 call intd_sum(eri,nint_ck,idatom,iatom,jatom,katom,latom) 358 call intd_2ec2s(eri,nint_ck,scr,lscr, 359 & itype,jtype,ktype,ltype,igen,jgen,kgen,lgen, 360 & bas_spherical(bra),bas_spherical(ket),idatom, 361 T .false.) 362c 363 else if (status_sim) then 364#ifdef SIMINT_GRADIENT 365 call nwcsim_hf2d( 366 & bra,ish,jsh, 367 & ket,ksh,lsh, 368 & nint_ck, eri, leri, scr, lscr) 369c 370 if(nint_ck.ne.0) then 371 nint_ck= 372 i int_nbf_x(itype)*int_nbf_x(jtype)* 373 k int_nbf_x(ktype)*int_nbf_x(ltype) 374 375c skip for sp 376 if((bas_spherical(bra).or.bas_spherical(ket)).and. 377 A (itype.gt.1.or.jtype.gt.1.or.ktype.gt.1.or.ltype.gt.1))then 378#if 1 379 call intd_sum_sim(eri,nint_ck,idatom,iatom,jatom,katom,latom) 380#else 381 idatom(1)=iatom 382 idatom(2)=jatom 383 idatom(3)=katom 384 idatom(4)=latom 385#endif 386 call intd_2ec2s(eri,nint_ck,scr,lscr, 387 & itype,jtype,ktype,ltype,igen,jgen,kgen,lgen, 388 & bas_spherical(bra),bas_spherical(ket),idatom, 389 T .true.) 390 endif 391 endif 392#else 393 call errquit(' simint 2e4c derivatives not ready yet',0,0) 394#endif 395 else 396 write(luout,*)'intd_2e4c: could not use either texas or nwchem' 397 write(luout,*)' integral derivatives' 398 write(luout,*)' Please open a github issue at' 399 write(luout,*) 400 W ' https://github.com/nwchemgit/nwchem/issues/new/choose' 401 write(luout,*)' attaching the input and output files' 402 call errquit('intd_2e4c: fatal error',911, INT_ERR) 403 endif 404c 405 end 406C> 407C> \brief Based on translational invariance combine integral derivatives 408C> 409 subroutine intd_sum(eri,nint_ck,idatom,iatom,jatom,katom,latom) 410 implicit none 411c 412 integer nint_ck 413 double precision eri(nint_ck,3,4) 414 integer idatom(4) 415 integer iatom,jatom,katom,latom 416c 417 integer iduse 418c 419 call intd_logic_atom(idatom,iatom,jatom,katom,latom) 420c 421 do 00100 iduse = 2,4 422 if (idatom(iduse).gt.0) then 423 continue 424 else 425 call daxpy(nint_ck*3,1.0d00,eri(1,1,iduse),1, 426 & eri(1,1,abs(idatom(iduse))),1) 427 endif 42800100 continue 429c 430 end 431 subroutine intd_sum_sim(eri,nint_ck, 432 I idatom,iatom,jatom,katom,latom) 433 implicit none 434c 435 integer nint_ck 436 double precision eri(3,4,nint_ck) 437 integer idatom(4) 438 integer iatom,jatom,katom,latom 439c 440 integer iduse,ii 441c 442 call intd_logic_atom(idatom,iatom,jatom,katom,latom) 443c 444 do iduse = 2,4 445 if (idatom(iduse).gt.0) then 446 continue 447 else 448 do ii=1,nint_ck 449c call yaxpy(nint_ck*3,1.0d00,eri(1,1,iduse),1, 450c & eri(1,1,abs(idatom(iduse))),1) 451 eri(1,abs(idatom(iduse)),ii)= 452 E eri(1,abs(idatom(iduse)),ii)+ 453 + eri(1,iduse,ii) 454 eri(1,iduse,ii)=0d0 455 eri(2,abs(idatom(iduse)),ii)= 456 E eri(2,abs(idatom(iduse)),ii)+ 457 + eri(2,iduse,ii) 458 eri(2,iduse,ii)=0d0 459 eri(3,abs(idatom(iduse)),ii)= 460 E eri(3,abs(idatom(iduse)),ii)+ 461 + eri(3,iduse,ii) 462 eri(3,iduse,ii)=0d0 463 enddo 464 endif 465 enddo 466c 467 end 468C> 469C> \brief Work out aspects of the translational invariance 470C> 471 subroutine intd_logic_atom(idat,iat,jat,kat,lat) 472 implicit none 473 integer iat,jat,kat,lat 474 integer idat(4) 475c 476 idat(1) = iat 477 idat(2) = jat 478 idat(3) = kat 479 idat(4) = lat 480 if (iat.eq.jat) idat(2) = -1 481 if (iat.eq.kat) idat(3) = -1 482 if (iat.eq.lat) idat(4) = -1 483 if (jat.eq.kat) then 484 if(idat(2).gt.0) then 485 idat(3) = -2 486 else 487 idat(3) = idat(2) 488 endif 489 endif 490 if (jat.eq.lat) then 491 if(idat(2).gt.0) then 492 idat(4) = -2 493 else 494 idat(4) = idat(2) 495 endif 496 endif 497 if (kat.eq.lat) then 498 if(idat(3).gt.0) then 499 idat(4) = -3 500 else 501 idat(4) = idat(3) 502 endif 503 endif 504 end 505C> 506C> \brief Transform 4-center 2-electron integral derivatives from 507C> Cartesian to spherical harmonic basis functions 508C> 509 subroutine intd_2ec2s(eri,nint_ck,scr,lscr, 510 & it,jt,kt,lt,igin,jgin,kgin,lgin, 511 & bra_sph,ket_sph,idatom,ltransp) 512 implicit none 513#include "nwc_const.fh" 514#include "errquit.fh" 515#include "int_nbf.fh" 516c::passed 517 integer nint_ck 518 integer lscr 519 double precision eri(nint_ck,3,4) 520 double precision scr(lscr) 521 integer it,jt,kt,lt 522 integer igin,jgin,kgin,lgin 523 logical bra_sph, ket_sph 524 integer idatom(4) 525c::local 526 integer ig,jg,kg,lg 527 integer nint_x, nint_s 528 integer i_nbf,j_nbf,k_nbf,l_nbf 529 integer i_nbf_s,j_nbf_s,k_nbf_s,l_nbf_s 530 integer zatom 531 integer zyx, lda, ldb 532 logical oprint,ltransp 533c 534 oprint=.false. 535c 536 ig = igin 537 jg = jgin 538 kg = kgin 539 lg = lgin 540c ... reset general contractions for sp shells to 1 since they are handled 541c as a block of 4. 542 if (it.eq.-1) ig = 1 543 if (jt.eq.-1) jg = 1 544 if (kt.eq.-1) kg = 1 545 if (lt.eq.-1) lg = 1 546 if (bra_sph.or.ket_sph) then 547 i_nbf = int_nbf_x(It) 548 j_nbf = int_nbf_x(Jt) 549 k_nbf = int_nbf_x(Kt) 550 l_nbf = int_nbf_x(Lt) 551 nint_x = i_nbf*j_nbf*k_nbf*l_nbf 552C should be 553C nint_x = i_nbf*j_nbf*k_nbf*l_nbf*ig*jg*kg*lg 554C ? 555 if (nint_ck.ne.nint_x) call errquit 556 & ('intd_2ec2s: nint_ck.ne.nint_x diff=',(nint_ck-nint_x), 557 & INT_ERR) 558c 559c transpose integrals X(12,nint_x) --> Y(nint_x,12) 560c 561 if(ltransp) then 562 lda=12 563 ldb=nint_x 564 if(lscr.lt.nint_x) call errquit(' lscr small ',0,0) 565 call dcopy((nint_x*lda),eri,1,scr,1) 566 call trspmo_block(scr,lda, eri,ldb) 567 endif 568 if(bra_sph) then 569 i_nbf_s = int_nbf_s(It) 570 j_nbf_s = int_nbf_s(Jt) 571 do zatom = 1,4 572 if (idatom(zatom).gt.0) then 573 do zyx = 1,3 574 call spcart_bra2etran(eri(1,zyx,zatom),scr, 575 & j_nbf,i_nbf,j_nbf_s,i_nbf_s, 576 & Jt, It, jg, ig, 577 & (k_nbf*l_nbf),oprint) 578C should be 579C & (k_nbf*l_nbf*kg*lg),.true.) 580C ? 581 enddo 582 endif 583 enddo 584 i_nbf = i_nbf_s 585 j_nbf = j_nbf_s 586 endif 587 if(ket_sph) then 588 k_nbf_s = int_nbf_s(Kt) 589 l_nbf_s = int_nbf_s(Lt) 590 do zatom = 1,4 591 if (idatom(zatom).gt.0) then 592 do zyx = 1,3 593 call spcart_ket2etran(eri(1,zyx,zatom),scr, 594 & l_nbf,k_nbf,l_nbf_s,k_nbf_s, 595 & Lt, Kt, lg, kg, 596 & (i_nbf*j_nbf),oprint) 597C should be 598C & (i_nbf*j_nbf*ig*jg),.true.) 599C ? 600 enddo 601 endif 602 enddo 603 k_nbf = k_nbf_s 604 l_nbf = l_nbf_s 605 endif 606 nint_s = i_nbf*j_nbf*k_nbf*l_nbf 607 if(ltransp) then 608c 609c transpose back integrals X(12,nint_x) --> Y(nint_x,12) 610c 611 call dcopy((nint_x*lda),eri,1,scr,1) 612 call trspmo_block(scr,ldb, eri,lda) 613 return 614 endif 615 if (nint_s.gt.nint_x) then 616 call errquit 617 & ('intd_2ec2s: nint_s >.nint_x diff=',(nint_s-nint_x), 618 & INT_ERR) 619 elseif (nint_s.eq.nint_x) then 620 return 621 else 622 call int_c2s_mv 623 & (eri,nint_x,nint_s,(3*4),scr,lscr,'intd_2e4c') 624 endif 625 endif 626 end 627 subroutine int_c2s_mv 628 & (int_buf,nint_x,nint_s,nblocks,scr,lscr,ctine) 629 implicit none 630#include "stdio.fh" 631#include "errquit.fh" 632c::passed 633 integer lscr 634 integer nint_x 635 integer nint_s 636 integer nblocks 637 double precision int_buf(*) 638 double precision scr(lscr) 639 character*(*) ctine 640c::local 641 integer i 642 integer z 643 integer offset_x, offset_s 644* 645#if defined(VECTOR_MODE) 646 if (nint_x*nblocks.gt.lscr) then 647 write(luout,*)' calling routine: ',ctine 648 call errquit 649 & ('int_c2s_mv: lscr to small by ',((nint_x*nblocks)-lscr), 650 & INT_ERR) 651 endif 652#endif 653 if (nint_s.gt.nint_x) then 654 call errquit 655 & ('int_c2s_mv: nint_s >.nint_x diff=',(nint_s-nint_x), 656 & INT_ERR) 657 elseif (nint_s.eq.nint_x) then 658 return 659 endif 660#if defined(VECTOR_MODE) 661 call dcopy((nint_x*nblocks),int_buf,1,scr,1) 662 call dcopy((nint_x*nblocks),0.0d00,0,int_buf,1) 663 do z = 1,nblocks 664 offset_x = (z-1)*nint_x + 1 665 offset_s = (z-1)*nint_s + 1 666 call dcopy(nint_s,scr(offset_x),1,int_buf(offset_s),1) 667 enddo 668#else 669c** scalar (in place) 670 do z = 2,nblocks 671 offset_x = (z-1)*nint_x 672 offset_s = (z-1)*nint_s 673 do i = 1,nint_s 674 int_buf(offset_s+i) = int_buf(offset_x+i) 675 enddo 676 enddo 677#endif 678 end 679c===================================================== 680C> 681C> \brief Reorder integrals derivatives from Texas to NWChem ordering 682C> 683 subroutine intd_texas_grad_switch(nint_ck,eri,scr) 684 implicit none 685 integer nint_ck 686 double precision eri(nint_ck,3,4) 687 double precision scr(12,nint_ck) 688c 689 double precision xa, xb, xc, xd 690 double precision ya, yb, yc, yd 691 double precision za, zb, zc, zd 692 integer i_int 693c 694 do i_int = 1,nint_ck 695 xa = scr(1,i_int) 696 ya = scr(2,i_int) 697 za = scr(3,i_int) 698 xb = scr(4,i_int) 699 yb = scr(5,i_int) 700 zb = scr(6,i_int) 701 xc = scr(7,i_int) 702 yc = scr(8,i_int) 703 zc = scr(9,i_int) 704 xd = scr(10,i_int) 705 yd = scr(11,i_int) 706 zd = scr(12,i_int) 707 eri(i_int,1,1) = xa 708 eri(i_int,2,1) = ya 709 eri(i_int,3,1) = za 710 eri(i_int,1,2) = xb 711 eri(i_int,2,2) = yb 712 eri(i_int,3,2) = zb 713 eri(i_int,1,3) = xc 714 eri(i_int,2,3) = yc 715 eri(i_int,3,3) = zc 716 eri(i_int,1,4) = xd 717 eri(i_int,2,4) = yd 718 eri(i_int,3,4) = zd 719 enddo 720 end 721 subroutine trspmo_block(in,ld_in,out,ld_out) 722#define CHUNK 16 723 implicit none 724 integer ld_in,ld_out 725 double precision out(ld_out,ld_in) 726 double precision in(ld_in,ld_out) 727c 728 integer i,j,i1,j1 729c 730 do i1=1,ld_in,CHUNK 731 do j1=1,ld_out,CHUNK 732 do i=i1,min(i1+CHUNK-1,ld_in) 733!DEC$ LOOP COUNT AVG=CHUNK 734cc!deC$ SIMD 735 do j=j1,min(j1+CHUNK-1,ld_out) 736 out(j,i)=in(i,j) 737 enddo 738 enddo 739 enddo 740 enddo 741 return 742 end 743c===================================================== 744C> @} 745