1 block data block_int1e 2 implicit none 3#include "cint1cache.fh" 4 data ocache /.false./ 5 end 6c 7C> \brief Compute 1-electron integrals and add them to a global array 8C> 9C> This routine computes 1-electron integrals of the specified kind and 10C> adds them to a global array. The routine always computes a 11C> rectangular matrix. It is even capable of using two different 12C> basis sets. Different kinds of integrals can be computed, they are: 13C> 14C> * "kinetic": the kinetic energy integrals 15C> 16C> * "potential": the nuclear attraction 17C> 18C> * "overlap": the overlap integrals 19C> 20C> * "pvp": ??? 21C> 22C> * "so": spin-orbit integrals 23C> 24C> * "cos_chg_pot": the integrals with the COSMO charges 25C> 26C> * "bq_pot": the integrals with BQ-charges 27C> 28cc AJL/Begin 29C> * "potential_beta": the nuclear attraction with ECPs for the 30C> beta channel 31cc AJL/End 32C> 33C> The routine can exploit symmetry. If oskel is true then the 34C> "petite-list" symmetry will be used, although this requires both 35C> basis sets to be the same. 36C 37 subroutine int_1e_ga(ibas, jbas, g, integ_type, oskel) 38C$Id$ 39 implicit none 40#include "errquit.fh" 41#include "cint1cache.fh" 42#include "mafdecls.fh" 43#include "global.fh" 44#include "rtdb.fh" 45#include "inp.fh" 46#include "apiP.fh" 47#include "bas.fh" 48#include "cscfps.fh" 49#include "sym.fh" 50#include "geom.fh" 51c 52c Compute the desired type of integrals (kinetic, potential, overlap) 53c and ADD them into the given global array. 54c This version computes the full square of integrals and should work 55c OK even if ibas != jbas. 56c 57c Oskel indicates that the skeleton (petite-list symmetry) matrix should be 58c built ... requires that ibas = jbas. 59c 60c arguments 61c 62 integer ibas !< [Input] bra basis sets 63 integer jbas !< [Input] ket basis sets 64 integer g(*) !< [Output] GA handle to array 65 character*(*) integ_type !< [Input] Name of integrals to compute 66 logical oskel !< [Input] If true generate symmetry unique list 67c 68c local variables 69c 70 integer type 71 logical dobq 72 character*255 integ_type1 73c 74 call ga_sync() 75c 76 dobq = geom_extbq_on() 77 integ_type1 = integ_type 78c 79 if (inp_compare(.false., integ_type1, 'potential0')) then 80 integ_type1='potential' 81 dobq=.false. 82cc AJL/Begin/SPIN-POLARISED ECPs 83 elseif (inp_compare(.false., integ_type1, 'potential_beta0')) then 84 integ_type1='potential_beta' 85 dobq=.false. 86cc AJL/End 87 end if 88c 89 if (oskel) then 90 if (ibas.ne.jbas) call errquit 91 $ ('int_1e_ga: use of symmetry requires ibas=jbas', ibas, 92 & BASIS_ERR) 93 end if 94c 95 if (inp_compare(.false., integ_type1, 'kinetic')) then 96 type = 1 97 else if (inp_compare(.false., integ_type1, 'potential')) then 98 type = 2 99 else if (inp_compare(.false., integ_type1, 'overlap')) then 100 type = 3 101 else if (inp_compare(.false., integ_type1, 'pvp')) then 102 type = 4 103 else if (inp_compare(.false., integ_type1, 'so'))then 104 type = 5 105 else if (inp_compare(.false., integ_type1, 'cos_chg_pot'))then 106 type = 6 107 else if (inp_compare(.false., integ_type1, 'bq_pot'))then 108 type=7 109 if(.not.dobq) return 110cc AJL/Begin/SPIN-POLARISED ECPs 111 else if (inp_compare(.false., integ_type1, 'potential_beta')) then 112 type = 8 113cc AJL/End 114 else 115 write(6,*) ' integ_type1 = ', integ_type1 116 call errquit('int_1e_ga: unknown integ_type', 0, INT_ERR) 117 end if 118 if(type.lt.0.or.type.gt.10) call 119 E errquit(' bogus int1 type',0,INT_ERR) 120c 121c Check if Douglas-Kroll is required, if so: 122c getting the Douglas-Kroll kinetic and potential energy 123c integrals 124c 125cc AJL/Begin/SPIN-POLARISED ECPs 126c if (doug_kroll .and. (type.le.2)) then 127 if (doug_kroll .and. ((type.le.2) .or. (type.eq.8))) then 128cc AJL/End 129 if (ibas.ne.jbas) call errquit 130 $ ('int_1e_ga: Douglas-Kroll requires ibas=jbas', ibas, 131 & BASIS_ERR) 132 call int_1edk_ga(ibas,g,type,oskel) 133 call ga_sync() ! So that no nasty races can result 134 return 135 endif 136c 137c Doing Douglas-Kroll Spin-Orbit terms 138c 139 if (doug_kroll .and. (type.eq.5)) then 140 if (ibas.ne.jbas) call errquit 141 $ ('int_1e_ga: Douglas-Kroll requires ibas=jbas', ibas, 142 & BASIS_ERR) 143 call int_1edk_so_ga(ibas,g,type,oskel) 144 call ga_sync() ! So that no nasty races can result 145 return 146 endif 147c 148 if (dobq) then 149 call int_1e_ooldga(ibas, jbas, g, integ_type1, oskel) 150cc AJL/Begin/SPIN-POLARISED ECPs 151cc if(inp_compare(.false., integ_type1, 'potential')) 152cc & call int_1e_ooldga(ibas, jbas, g, 'bq_pot', oskel) 153 if (type.eq.2.or.type.eq.8) ! potential or potential_beta 154 & call int_1e_ooldga(ibas, jbas, g, 'bq_pot', oskel) 155cc AJL/End 156 else 157 call int_1e_oldga(ibas, jbas, g, integ_type1, oskel) 158 end if 159c 160 end 161c 162 subroutine int_1e_ooldga(ibas, jbas, g, integ_type, oskel) 163 implicit none 164#include "errquit.fh" 165#include "cint1cache.fh" 166#include "mafdecls.fh" 167#include "global.fh" 168#include "rtdb.fh" 169#include "inp.fh" 170#include "apiP.fh" 171#include "bas.fh" 172#include "cscfps.fh" 173#include "sym.fh" 174c 175c This is the original routine of int_1e_ga. It is still needed by the 176c Douglas-Kroll routines to avoid recursive routine calling. 177c 178c Compute the desired type of integrals (kinetic, potential, overlap) 179c and ADD them into the given global array. 180c This version computes the full square of integrals and should work 181c OK even if ibas != jbas. 182c 183c Oskel indicates that the skeleton (petite-list symmetry) matrix should be 184c built ... requires that ibas = jbas. 185c 186c arguments 187c 188 integer ibas, jbas ! [input] bra and ket basis sets 189 integer g(3) ! [output] GA handle to array. g(1..3) are used only 190 ! for spin-orbit calculations. All other calculations use 191 ! g(1) only 192 character*(*) integ_type ! [input] Name of integrals to compute 193 logical oskel ! [input] If true generate symmetry unique list 194c 195c local variables 196c 197 integer nshell_i, nshell_j 198 integer ishell, jshell, iproc, nproc, mem1, max1e 199 integer ijshell, ilo, ihi, jlo, jhi, idim 200 integer l_buf, l_scr 201 integer k_buf, k_scr 202 integer type 203 logical odoit 204 double precision q2 205 external block_int1e ! For T3D 206 integer i, noffset,g_loc 207c 208 logical ocache_save 209c 210 logical odbug 211 logical osome 212c 213 odbug=.false. 214 osome=.false. 215 osome=osome.or.odbug 216 odbug=odbug.and.(ga_nodeid().eq.0) 217 osome=osome.and.(ga_nodeid().eq.0) 218 if(osome) then 219 write(6,*) 'in -int_1e_ooldga- ... integ_type = ', 220 $ integ_type,ga_nodeid() 221 call util_flush(6) 222 endif 223c 224 call ga_sync() 225 if (oscfps) call pstat_on(ps_int_1e) 226c 227 if (oskel) then 228 if (ibas.ne.jbas) call errquit 229 $ ('int_1e_ga: use of symmetry requires ibas=jbas', ibas, 230 & BASIS_ERR) 231 end if 232c 233 if (inp_compare(.false., integ_type, 'kinetic')) then 234 type = 1 235 else if (inp_compare(.false., integ_type, 'potential')) then 236 type = 2 237 else if (inp_compare(.false., integ_type, 'overlap')) then 238 type = 3 239 else if (inp_compare(.false., integ_type, 'pvp')) then 240 type = 4 241 else if (inp_compare(.false., integ_type, 'so'))then 242 type = 5 243 else if (inp_compare(.false., integ_type, 'cos_chg_pot'))then 244 type = 6 245 else if (inp_compare(.false., integ_type, 'bq_pot'))then 246 type = 7 247cc AJL/Begin/SPIN ECPs 248 else if (inp_compare(.false., integ_type, 'potential_beta')) then 249 type = 8 250cc AJL/End 251 else 252 write(6,*) ' integ_type = ', integ_type,ga_nodeid() 253 call errquit('int_1e_ga: unknown integ_type', 0, INT_ERR) 254 end if 255c 256c ----- save ocache logical variable ----- 257c 258 if(type.eq.6 .or. type.eq.7 ) then 259 ocache_save=ocache 260 ocache =.false. 261 endif 262c 263c In-core caching 264c 265c ocache = .false. 266 if(osome) then 267 write(6,*) 'ocache = ',ocache,ga_nodeid() 268 call util_flush(6) 269 endif 270 if (ocache .and. (ibas.eq.bas1) .and. (jbas.eq.bas1)) then 271* if (ga_nodeid().eq.0) then 272* call ga_summarize(1) 273* call util_flush(6) 274* endif 275* call ga_sync() 276c 277cc AJL/Begin/SPIN-POLARISED ECPs 278 if (type.ne.8) then 279 call ga_dadd(1.0d0, g_cache(type), 1.0d0, g, g) 280 else ! accomodate for potential_beta, stored in g_cache(4) 281 call ga_dadd(1.0d0, g_cache(4), 1.0d0, g, g) 282 endif 283cc AJL/End 284c 285 if (oscfps) call pstat_off(ps_int_1e) 286 return 287 endif 288c 289c Get info about the basis sets 290c 291 if (.not. bas_numcont(ibas, nshell_i)) call errquit 292 $ ('rhf_fock_1e: bas_numcont failed for ibas', ibas, 293 & BASIS_ERR) 294 if (.not. bas_numcont(jbas, nshell_j)) call errquit 295 $ ('rhf_fock_1e: bas_numcont failed for jbas', jbas, 296 & BASIS_ERR) 297c 298c allocate necessary local temporary arrays on the stack 299c 300c l_buf ... buffer to hold shell block of matrix 301c l_s ... buffer to hold shell block of matrix 302c l_scr ... workspace for integral routines 303c 304c k_* are the offsets corrsponding to the l_* handles 305c 306cso 307 call int_mem_1e(max1e, mem1) 308 if (type .eq. 5) then 309 max1e = 3*max1e 310 mem1 = 3*mem1 311 endif 312cso 313 if (.not. MA_push_get(MT_DBL,max1e,'int_1e_ga:buf',l_buf,k_buf)) 314 $ call errquit('int_1e_ga: ma failed', max1e, MA_ERR) 315 if (.not. MA_push_get(MT_DBL, mem1,'int_1e_ga:scr',l_scr,k_scr)) 316 $ call errquit('int_1e_ga: ma failed', mem1, MA_ERR) 317c 318c Loop thru shells with static parallel work decomposition 319c 320 if (.not.inp_compare(.false., integ_type, 'so')) then 321 if(.not.ga_duplicate(g,g_loc,'local g')) call 322 . errquit('int1e: dupl failed',0, GA_ERR) 323 call ga_zero(g_loc) 324 endif 325 iproc = ga_nodeid() 326 nproc = ga_nnodes() 327 ijshell = 0 328 q2 = 1.0d0 329 do jshell = 1, nshell_j 330 do ishell = 1, nshell_i 331c 332 if (mod(ijshell, nproc) .eq. iproc) then 333 odoit = .true. 334 if (oskel) 335 $ odoit = sym_shell_pair(ibas, ishell, jshell, q2) 336c 337 if (odoit) then 338 if (.not. bas_cn2bfr(ibas, ishell, ilo, ihi)) 339 $ call errquit('int_1e_ga: bas_cn2bfr ?', ibas, 340 & BASIS_ERR) 341 if (.not. bas_cn2bfr(jbas, jshell, jlo, jhi)) 342 $ call errquit('int_1e_ga: bas_cn2bfr ?', jbas, 343 & BASIS_ERR) 344 idim = ihi - ilo + 1 345c 346c Generate the integrals 347c 348 if (type .eq. 1) then 349 call int_1eke (jbas, jshell, ibas, ishell, 350 $ mem1, dbl_mb(k_scr), max1e, dbl_mb(k_buf)) 351 else if (type .eq. 2) then 352 call int_1epe (jbas, jshell, ibas, ishell, 353 $ mem1, dbl_mb(k_scr), max1e, dbl_mb(k_buf)) 354 else if (type .eq. 3) then 355 call int_1eov (jbas, jshell, ibas, ishell, 356 $ mem1, dbl_mb(k_scr), max1e, dbl_mb(k_buf)) 357 else if (type .eq. 4) then 358 call int_1epvpe (jbas, jshell, ibas, ishell, 359 $ mem1, dbl_mb(k_scr), max1e, dbl_mb(k_buf)) 360 else if (type .eq. 5) then 361 call intso_1e (jbas, jshell, ibas, ishell, 362 $ mem1, dbl_mb(k_scr), max1e, dbl_mb(k_buf)) 363 else if (type .eq. 6) then 364 if(odbug) then 365 write(6,*) 'type = 6 ... potential ...', 366 $ ga_nodeid() 367 call util_flush(6) 368 endif 369 call int_1epot (jbas, jshell, ibas, ishell, 370 $ mem1, dbl_mb(k_scr), max1e, dbl_mb(k_buf)) 371 else if (type .eq. 7) then 372 call int_1epot1 (jbas, jshell, ibas, ishell, 373 $ mem1, dbl_mb(k_scr), max1e, dbl_mb(k_buf)) 374cc AJL/Begin/SPIN ECPs 375 else if (type .eq. 8) then 376 call int_1epe_beta (jbas, jshell, ibas, ishell, 377 $ mem1, dbl_mb(k_scr), max1e, dbl_mb(k_buf)) 378cc AJL/End 379 else 380 call errquit('int_1e_ga: invalid type?', type, 381 & GA_ERR) 382 end if 383c 384c Add the integrals into the global array 385c 386 if (inp_compare(.false., integ_type, 'so')) then 387 do i = 1, 3 388 noffset = (ihi-ilo+1)*(jhi-jlo+1)*(i-1) 389 call ga_acc(g(i), ilo, ihi, jlo, jhi, 390 $ dbl_mb(k_buf+noffset), 391 $ idim, q2) 392 enddo 393 else 394 if(odbug) then 395 write(6,*) 'ga_acc = ...',ga_nodeid() 396 call util_flush(6) 397 endif 398cedo call ga_acc(g, ilo, ihi, jlo, jhi, dbl_mb(k_buf), 399cedo $ idim, q2) 400 if(q2.ne.1) then 401 call dscal((ihi-ilo+1)*(jhi-jlo+1), 402 , q2,dbl_mb(k_buf),1) 403 endif 404 call ga_put(g_loc, ilo, ihi, jlo, jhi, 405 , dbl_mb(k_buf), idim) 406 end if 407 end if 408 endif 409 ijshell = ijshell + 1 410 end do 411 end do 412c 413c chop stack at first item allocated 414c 415 if (.not. MA_pop_stack(l_scr)) call errquit 416 $ ('int_1e_ga: pop failed', 0, GA_ERR) 417 if (.not. MA_pop_stack(l_buf)) call errquit 418 $ ('int_1e_ga: pop failed', 0, GA_ERR) 419c 420c ----- restore ocache ----- 421c 422 if(type.eq.6 .or. type.eq.7) then 423 ocache=ocache_save 424 endif 425c 426 if (.not.inp_compare(.false., integ_type, 'so')) then 427 call ga_dadd(1.0d0, g_loc, 1.0d0, g, g) 428 if (.not. ga_destroy(g_loc)) call errquit('i1ega: gad?',0, 429 & GA_ERR) 430 endif 431 call ga_sync() ! So that no nasty races can result 432c 433 if (oscfps) call pstat_off(ps_int_1e) 434c 435 end 436 subroutine int_1e_cache_ga(basis, oskel) 437 implicit none 438#include "errquit.fh" 439#include "cint1cache.fh" 440#include "bas.fh" 441 integer basis 442 logical oskel 443c 444 integer geom 445 integer ga_create_atom_blocked 446 external ga_create_atom_blocked 447c 448cc AJL/Begin/SPIN ECPs 449#include "global.fh" 450 integer ecp_handle 451cc AJL/End 452c 453 if (ocache) call int_1e_uncache_ga() 454c 455 if (.not. bas_geom(basis, geom)) call errquit 456 $ ('int_1e_cache_ga: basis corrupt?', 0, BASIS_ERR) 457c 458c The use of ga_dadd to do the copy requires all uses of 459c these integrals to be allocated via ga_create_atom_blocked 460c 461* write(6,*) ' Enabling caching of 1-e integrals ' 462c 463 g_cache(1) = ga_create_atom_blocked(geom, basis,'int1e: t') 464 g_cache(2) = ga_create_atom_blocked(geom, basis,'int1e: v') 465 g_cache(3) = ga_create_atom_blocked(geom, basis,'int1e: s') 466 call ga_zero(g_cache(1)) 467 call ga_zero(g_cache(2)) 468 call ga_zero(g_cache(3)) 469 call int_1e_ga(basis, basis, g_cache(1), 'kinetic', oskel) 470 call int_1e_ga(basis, basis, g_cache(2), 'potential0', oskel) 471 call int_1e_ga(basis, basis, g_cache(3), 'overlap', .false.) 472c 473cc AJL/Begin/SPIN ECPs 474 if (bas_get_ecp_handle(basis,ecp_handle)) then 475 if (.not.ecp_get_high_chan(ecp_handle,channels)) channels = 1 476 if (channels.gt.1) then 477 if (ga_nodeid().eq.0) then 478 write(6,*) 'ECP Channels : ', channels 479 call util_flush(6) 480 endif 481 g_cache(4) = 482 & ga_create_atom_blocked(geom, basis,'int1e: v_beta') 483 call ga_zero(g_cache(4)) 484 call int_1e_ga(basis, basis, g_cache(4), 485 & 'potential_beta0', oskel) 486 end if 487 end if 488cc AJL/End 489c 490 bas1 = basis 491 ocache = .true. 492c 493 end 494 subroutine int_1e_uncache_ga() 495 implicit none 496#include "errquit.fh" 497#include "cint1cache.fh" 498 logical ga_destroy 499c 500* write(6,*) ' Disabling caching of 1-e integrals ' 501c 502 if (.not. ocache) return 503 if (.not. ga_destroy(g_cache(1))) call errquit('i1ega: gad?',0, 504 & BASIS_ERR) 505 if (.not. ga_destroy(g_cache(2))) call errquit('i1ega: gad?',0, 506 & BASIS_ERR) 507 if (.not. ga_destroy(g_cache(3))) call errquit('i1ega: gad?',0, 508 & BASIS_ERR) 509c 510cc AJL/Begin/SPIN ECPs 511 if (channels.gt.1) then 512 if (.not. ga_destroy(g_cache(4))) call errquit('i1ega: gad?',0, 513 & BASIS_ERR) 514 end if 515cc AJL/End 516c 517 bas1 = -1 518 ocache = .false. 519 end 520 subroutine int_1e_oldga(ibas, jbas, g, integ_type, oskel) 521 implicit none 522#include "inp.fh" 523#include "errquit.fh" 524#include "global.fh" 525 integer ibas, jbas ! [input] bra and ket basis sets 526 integer g(3) ! [output] GA handle to array. g(1..3) are used only 527 ! for spin-orbit calculations. All other calculations use 528 ! g(1) only 529 character*(*) integ_type ! [input] Name of integrals to compute 530 logical oskel ! [input] If true generate symmetry unique list 531c 532 external int_1eke,int_1epe,int_1eov,int_1epvpe, 533 I int_1epot,int_1epot1, 534cc AJL/Begin/SPIN ECPs 535 I int_1epe_beta 536cc AJL/End 537 integer type 538c 539 540 if(ibas.ne.jbas) then 541 call int_1e_ooldga(ibas, jbas, g,integ_type,oskel) 542 return 543 endif 544 if (inp_compare(.false., integ_type, 'so'))then 545cso 546 call int_1e_ooldga(ibas, jbas, g,integ_type,oskel) 547 return 548 endif 549 if (inp_compare(.false., integ_type, 'kinetic')) then 550 type = 1 551 call int_1e_oldga0(ibas, g, type,oskel,int_1eke) 552 else if (inp_compare(.false., integ_type, 'potential')) then 553 type = 2 554 call int_1e_oldga0(ibas, g, type,oskel,int_1epe) 555 else if (inp_compare(.false., integ_type, 'overlap')) then 556 type = 3 557 call int_1e_oldga0(ibas, g, type,oskel,int_1eov) 558 else if (inp_compare(.false., integ_type, 'pvp')) then 559 type = 4 560 call int_1e_oldga0(ibas, g, type,oskel,int_1epvpe) 561 else if (inp_compare(.false., integ_type, 'cos_chg_pot'))then 562 type = 6 563 call int_1e_oldga0(ibas, g, type,oskel,int_1epot) 564 else if (inp_compare(.false., integ_type, 'bq_pot'))then 565 type = 7 566 call int_1e_oldga0(ibas, g, type,oskel,int_1epot1) 567cc AJL/Begin/SPIN ECPs 568 else if (inp_compare(.false., integ_type, 'potential_beta')) then 569 type = 8 570 call int_1e_oldga0(ibas, g, type, oskel, int_1epe_beta) 571cc AJL/End/SPIN ECPs 572 else 573 write(6,*) ' integ_type = ', integ_type,ga_nodeid() 574 call errquit('int_1e_oldga: unknown integ_type', 0, INT_ERR) 575 end if 576 577 return 578 end 579 subroutine int_1e_oldga0(ibas, g, type, oskel, 580 I int_call) 581 implicit none 582#include "errquit.fh" 583#include "cint1cache.fh" 584#include "mafdecls.fh" 585#include "global.fh" 586#include "rtdb.fh" 587#include "inp.fh" 588#include "apiP.fh" 589#include "bas.fh" 590#include "cscfps.fh" 591#include "sym.fh" 592#include "geom.fh" 593c 594c This is the original routine of int_1e_ga. It is still needed by the 595c Douglas-Kroll routines to avoid recursive routine calling. 596c 597c Compute the desired type of integrals (kinetic, potential, overlap) 598c and ADD them into the given global array. 599c 600c Oskel indicates that the skeleton (petite-list symmetry) matrix should be 601c built ... requires that ibas = jbas. 602c 603c arguments 604c 605 integer ibas ! [input] bra and ket basis sets 606 integer g(3) ! [output] GA handle to array. g(1..3) are used only 607 ! for spin-orbit calculations. All other calculations use 608 ! g(1) only 609 integer type ! [input] Name of integrals to compute 610 logical oskel ! [input] If true generate symmetry unique list 611c 612c local variables 613c 614 integer nshell_i, nshell_j 615 integer ishell, jshell, iproc, nproc, mem1, max1e 616 integer ijshell, ilo, ihi, jlo, jhi, idim 617 integer l_buf, l_scr 618 integer k_buf, k_scr 619 logical odoit 620 double precision q2 621 external block_int1e ! For T3D 622 integer i, g_loc 623 integer geom 624c 625 logical ocache_save 626c 627 logical odbug 628 logical osome 629 external int_call 630c 631 odbug=.false. 632 osome=.false. 633 osome=osome.or.odbug 634 odbug=odbug.and.(ga_nodeid().eq.0) 635 osome=osome.and.(ga_nodeid().eq.0) 636 if(osome) then 637 write(6,*) 'in -int_1e_oldga0- ... integ_type = ', 638 $ type,ga_nodeid() 639 call util_flush(6) 640 endif 641c 642 call ga_sync() 643c 644 if (oscfps) call pstat_on(ps_int_1e) 645c 646c ----- save ocache logical variable ----- 647c 648 if(type.eq.6 .or. type.eq.7 ) then 649 ocache_save=ocache 650 ocache =.false. 651 endif 652c 653c In-core caching 654c 655c ocache = .false. 656 if(osome) then 657 write(6,*) 'ocache = ',ocache,ga_nodeid() 658 call util_flush(6) 659 endif 660 if (ocache .and. (ibas.eq.bas1)) then 661cc AJL/Begin/SPIN ECPs 662 if (type.ne.8) then ! everything except potential_beta 663 call ga_dadd(1.0d0, g_cache(type), 1.0d0, g, g) 664 else 665 call ga_dadd(1.0d0, g_cache(4), 1.0d0, g, g) 666 end if 667cc AJL/End 668 if (oscfps) call pstat_off(ps_int_1e) 669 return 670 endif 671c 672c Get info about the basis sets 673c 674 if (.not. bas_numcont(ibas, nshell_i)) call errquit 675 $ ('int_1e_oldga0: bas_numcont failed for ibas', ibas, 676 & BASIS_ERR) 677 nshell_j=nshell_i 678c 679c allocate necessary local temporary arrays on the stack 680c 681c l_buf ... buffer to hold shell block of matrix 682c l_s ... buffer to hold shell block of matrix 683c l_scr ... workspace for integral routines 684c 685c k_* are the offsets corrsponding to the l_* handles 686c 687cso 688c 689c Loop thru shells with static parallel work decomposition 690c 691 if(.not.ga_duplicate(g,g_loc,'local g')) call 692 . errquit('int_1e_oldga0: dupl failed',0, GA_ERR) 693 call ga_zero(g_loc) 694 iproc = ga_nodeid() 695 nproc = ga_nnodes() 696 if (.not. bas_geom(ibas, geom)) call errquit 697 $ ('int_1e_oldga0: basis corrupt?', 0, BASIS_ERR) 698c 699 call int_mem_1e(max1e, mem1) 700 call ga_get2eri(ibas, g_loc, oskel, max1e, mem1, int_call) 701 if (oskel) call sym_symmetrize(geom,ibas,.false.,g_loc) 702c 703c ----- restore ocache ----- 704c 705 if(type.eq.6 .or. type.eq.7) then 706 ocache=ocache_save 707 endif 708c 709 call ga_dadd(1.0d0, g_loc, 1.0d0, g, g) 710 call ga_sync() ! So that no nasty races can result 711 if (.not. ga_destroy(g_loc)) call errquit('int_1e_oldga0: gad?',0, 712 & GA_ERR) 713 call ga_sync() ! So that no nasty races can result 714c 715 if (oscfps) call pstat_off(ps_int_1e) 716c 717 end 718