1! 2! Dalton, a molecular electronic structure program 3! Copyright (C) by the authors of Dalton. 4! 5! This program is free software; you can redistribute it and/or 6! modify it under the terms of the GNU Lesser General Public 7! License version 2.1 as published by the Free Software Foundation. 8! 9! This program is distributed in the hope that it will be useful, 10! but WITHOUT ANY WARRANTY; without even the implied warranty of 11! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12! Lesser General Public License for more details. 13! 14! If a copy of the GNU LGPL v2.1 was not distributed with this 15! code, you can obtain one at https://www.gnu.org/licenses/old-licenses/lgpl-2.1.en.html. 16! 17! 18C 19C FILE: abacus/aba2r12.F 20C 21C /* Deck eriher */ 22 SUBROUTINE ABEQ52(Q,R,W,A,PQX,PQY,PQZ,INDHER,JMAX, 23 & EXP12,EXP34,NUC12,NUC34,NUABCD, 24 & NTUV,IPQ0X,IPQ0Y,IPQ0Z,IODDHR,IPRINT) 25C 26C Written by Wim Klopper (University of Karlsruhe, 14 November 2002). 27C 28#include "implicit.h" 29#include "priunit.h" 30 PARAMETER (DM2 = -2.0D0) 31 DIMENSION Q(*), R(*), W(*), A(*), EXP12(NUC12), EXP34(NUC34), 32 & IODDHR(*), INDHER(*), PQX(*), PQY(*), PQZ(*) 33 IODS = 0 34 DO IOD12 = 1, NUC12 35 EXPP = EXP12(IOD12) 36 DO IOD34 = 1, NUC34 37 IODS = IODS + 1 38 EXPQ = EXP34(IOD34) 39 W(IODS) = DM2*EXPP*EXPQ/(EXPP + EXPQ) 40 END DO 41 END DO 42 CALL WKEQ52(Q,R,W,A,PQX,PQY,PQZ,INDHER,JMAX,NUABCD, 43 & NTUV,IPQ0X,IPQ0Y,IPQ0Z,IODDHR,IPRINT) 44 RETURN 45 END 46C /* Deck r00G */ 47 SUBROUTINE R00G(RJ000,COOR12,COOR34,EXP12,EXP34,FAC12,FAC34,PQX, 48 & PQY,PQZ,JMAX,NOINT,NUABCD,NUC1,NUC2,NUC12,NUC3, 49 & NUC4,NUC34,THRESH,ONECEN,IPRINT,IPQ0X,IPQ0Y,IPQ0Z, 50 & SIGNT,FACINT,HEXPP,HEXPQ) 51C Copy of R0001 for use with R12EIN (WK/UniKA/20-11-2002). 52#include "implicit.h" 53#include "priunit.h" 54#include "subdir.h" 55 PARAMETER (D0 = 0.D0, D1 = 1.D0, D2 = 2.D0, DP25 = 0.25D0) 56 LOGICAL ONECEN, NOINT 57 DIMENSION RJ000(NUABCD,0:JMAX), 58 & PQX(NUABCD), PQY(NUABCD), PQZ(NUABCD), 59 & COOR12(NUC1*NUC2,3), COOR34(NUC3*NUC4,3), 60 & EXP12(*), EXP34(*), FAC12 (*), FAC34(*), SIGNT(3), 61 & FACINT(*), HEXPP(*) ,HEXPQ(*) 62 NOINT = .FALSE. 63 IF (ONECEN) THEN 64 CALL DZERO(PQX,NUABCD) 65 CALL DZERO(PQY,NUABCD) 66 CALL DZERO(PQZ,NUABCD) 67 IPQ0X = 1 68 IPQ0Y = 1 69 IPQ0Z = 1 70 IODS = NUABCD 71 NODS = NUABCD 72 ELSE 73 IF (.NOT.DPATH1) THEN 74 SGN12X = - SIGNT(1) 75 SGN12Y = - SIGNT(2) 76 SGN12Z = - SIGNT(3) 77 SGN34X = - D1 78 SGN34Y = - D1 79 SGN34Z = - D1 80 ELSE 81 SGN12X = D1 82 SGN12Y = D1 83 SGN12Z = D1 84 SGN34X = SIGNT(1) 85 SGN34Y = SIGNT(2) 86 SGN34Z = SIGNT(3) 87 END IF 88C 89 IODS = 1 90 NODS = 1 91 DO 300 IOD12 = 1, NUC12 92 PX = SGN12X*COOR12(IOD12,1) 93 PY = SGN12Y*COOR12(IOD12,2) 94 PZ = SGN12Z*COOR12(IOD12,3) 95 DO 310 IOD34 = 1, NUC34 96 PQXI = PX - SGN34X*COOR34(IOD34,1) 97 PQYI = PY - SGN34Y*COOR34(IOD34,2) 98 PQZI = PZ - SGN34Z*COOR34(IOD34,3) 99 PQX(IODS) = PQXI 100 PQY(IODS) = PQYI 101 PQZ(IODS) = PQZI 102 IODS = IODS + 1 103 NODS = NODS + 1 104 310 CONTINUE 105 300 CONTINUE 106 107 IPQ0X = 1 108 IPQ0Y = 1 109 IPQ0Z = 1 110 IF (DASUM(NUABCD,PQX,1) .GT. THRESH) IPQ0X = 0 111 IF (DASUM(NUABCD,PQY,1) .GT. THRESH) IPQ0Y = 0 112 IF (DASUM(NUABCD,PQZ,1) .GT. THRESH) IPQ0Z = 0 113 END IF 114C 115 IJ = 0 116 DO IOD12 = 1, NUC12 117 FAC = FAC12(IOD12) 118 DO IOD34 = 1, NUC34 119 IJ = IJ + 1 120 FACINT(IJ) = FAC * FAC34(IOD34) 121 HEXPP(IJ) = EXP12(IOD12) 122 HEXPQ(IJ) = EXP34(IOD34) 123 END DO 124 END DO 125 RETURN 126 END 127C /* Deck r12wrt */ 128 SUBROUTINE R12WRT(BUF,LBUF,ICOUNT,ITYPE,INDA,IPRINT) 129#include "implicit.h" 130#include "priunit.h" 131#include "iratdef.h" 132#include "dummy.h" 133#include "maxorb.h" 134#include "mxcent.h" 135#include "maxaqn.h" 136#include "ibtpar.h" 137 DIMENSION BUF(LBUF,5) 138#include "twosta.h" 139#include "r12int.h" 140#include "inftap.h" 141#include "nuclei.h" 142#include "symmet.h" 143 144C 145 IF (ITYPE .EQ. -1) THEN 146 IDUM = 0 147 I = 1 148 CALL GPOPEN(LUR12(I),'AOXYZ','UNKNOWN',' ',' ',IDUM,.FALSE.) 149 CALL NEWLAB('AOXYZINT',LUR12(I),LUPRI) 150 IF (V12INT) THEN 151 I = I + 1 152 CALL GPOPEN(LUR12(I),'AOV12','UNKNOWN',' ',' ',IDUM,.FALSE.) 153 CALL NEWLAB('AOV12INT',LUR12(I),LUPRI) 154 END IF 155 IF (R12INT) THEN 156 I = I + 1 157 CALL GPOPEN(LUR12(I),'AOR12','UNKNOWN',' ',' ',IDUM,.FALSE.) 158 CALL NEWLAB('AOR12INT',LUR12(I),LUPRI) 159 END IF 160 IF (U12INT) THEN 161 I = I + 1 162 CALL GPOPEN(LUR12(I),'AOU12','UNKNOWN',' ',' ',IDUM,.FALSE.) 163 CALL NEWLAB('AOU12INT',LUR12(I),LUPRI) 164 END IF 165 IF (U21INT) THEN 166 I = I + 1 167 CALL GPOPEN(LUR12(I),'AOU21','UNKNOWN',' ',' ',IDUM,.FALSE.) 168 CALL NEWLAB('AOU21INT',LUR12(I),LUPRI) 169 END IF 170 END IF 171C 172 DO 100 KR12 = 1, NOPP12 + 1 173 IF (ITYPE .EQ. -1) THEN 174 ICOUNT = 0 175 ELSE IF (ITYPE .EQ. 0) THEN 176 IF (INDA .NE. 0) WRITE (LUR12(KR12)) INDA 177 WRITE (LUR12(KR12)) (BUF(L,KR12),L=1,LBUF),ICOUNT 178 IF (KR12 .EQ. NOPP12 + 1) ICOUNT = 0 179 ELSE 180 IF (INDA .NE. 0) THEN 181 WRITE (LUR12(KR12)) -INDA 182 WRITE (LUR12(KR12)) (BUF(L,KR12),L=1,LBUF),ICOUNT 183 ELSE 184 IF (ICOUNT .GT. 0) THEN 185 WRITE (LUR12(KR12)) (BUF(L,KR12),L=1,LBUF),ICOUNT 186 END IF 187 WRITE (LUR12(KR12)) (BUF(L,KR12),L=1,LBUF),-1 188 END IF 189 CALL GPCLOSE(LUR12(KR12),'KEEP') 190 END IF 191 100 CONTINUE 192 RETURN 193 END 194C /* Deck rn2out */ 195 SUBROUTINE RN2OUT(SO,NSOINT,IPNTNO,IPNTRP,IPNTLG,FIRST,LAST, 196 & THRESH,NINDAB,NINDCD,IPRINT) 197C 198C Version of UN2OUT for R12 integrals (WK/26-11-2002). 199C 200#include "implicit.h" 201#include "priunit.h" 202#include "r12int.h" 203#include "iratdef.h" 204#include "maxorb.h" 205#include "mxcent.h" 206#include "maxaqn.h" 207#include "aovec.h" 208 PARAMETER (LBUF_alloc = 600) 209 LOGICAL DCMPAB, DCMPCD, DCMPAC, DRALTB, DRCLTD, FIRST, LAST, 210 & DRABAB, DCABAB, IAEQIC, IALTIC, IPNTLG(3,*), NOTEST, 211 & GTTHRS 212 REAL*8 SO(NSOINT,*), BUF(LBUF_alloc,5), 213 & IPNTNO(4,*), IPNTRP(3,*), 214 & NINDAB(NORBA*NORBB,2), NINDCD(NORBC*NORBD,2) 215#include "nuclei.h" 216#include "eribuf.h" 217#include "twocom.h" 218#include "symmet.h" 219 SAVE BUF, XBUF, ICOUNT 220C 221C 222 IF (IPRINT .GT. 6) CALL HEADER('Subroutine RN2OUT',-1) 223 IF (IPRINT .GT. 10) THEN 224 WRITE (LUPRI,'(2X,A,4I5)') 'NHKT? ', NHKTA, NHKTB, NHKTC, NHKTD 225 WRITE (LUPRI,'(2X,A,4I5)') 'MUL? ', MULA, MULB, MULC, MULD 226 WRITE (LUPRI,'(2X,A,4I5)') 'NORB? ', NORBA, NORBB, NORBC, NORBD 227 WRITE (LUPRI,'(2X,A,4I5)') 'NSTR? ', NSTRA, NSTRB, NSTRC, NSTRD 228 WRITE (LUPRI,'(2X,A,2I5)') 'NORBCD', NORBCD 229 WRITE (LUPRI,'(2X,A,2I5)') 'NOABCD', NOABCD 230 WRITE (LUPRI,'(2X,A,2L5)') 'DIAGAB/CD', DIAGAB, DIAGCD 231 WRITE (LUPRI,'(2X,A,2L5)') 'TCONAB/CD', TCONAB, TCONCD 232 WRITE (LUPRI,'(2X,A,2L5)') 'SHAEQB/CD', SHAEQB, SHCEQD 233 WRITE (LUPRI,'(2X,A, L5)') 'SHABAB', SHABAB 234 END IF 235C 236C ******************************************************* 237C ***** Initialization when subroutine first called ***** 238C ******************************************************* 239C 240 IF (FIRST) THEN 241 LBUF = LBUF_alloc 242 CALL R12WRT(BUF,LBUF,ICOUNT,-1,0,IPRINT) 243 END IF 244C 245 ISOFF = 0 246 NBUFCL = 0 247 NSTART = ICOUNT 248 NOTEST = .NOT.(SHAEQB .OR. SHCEQD .OR. SHABAB) 249 DO 100 I = 1, NINTS 250 NSTRNA = IPNTNO(1,I) 251 NSTRNB = IPNTNO(2,I) 252 NSTRNC = IPNTNO(3,I) 253 NSTRND = IPNTNO(4,I) 254 IREPA = IPNTRP(1,I) 255 IREPB = IPNTRP(2,I) 256 IREPC = IPNTRP(3,I) 257 IREPD = IEOR(IEOR(IREPA,IREPB),IREPC) 258 IF (NOTEST) THEN 259 INT = 0 260 DO 200 IAB = 1, NORBAB 261 IA = KHKTA*(NINDAB(IAB,1) - 1) 262 IB = KHKTB*(NINDAB(IAB,2) - 1) 263 INDA = IPTSYM(NSTRNA + IA,IREPA) 264 INDB = IPTSYM(NSTRNB + IB,IREPB) 265 DO 210 ICD = 1, NORBCD 266 INT = INT + 1 267 IC = KHKTC*(NINDCD(ICD,1) - 1) 268 ID = KHKTD*(NINDCD(ICD,2) - 1) 269 INDC = IPTSYM(NSTRNC + IC,IREPC) 270 INDD = IPTSYM(NSTRND + ID,IREPD) 271 CALL LAB64U(SO(ISOFF+INT,1),NSOINT, 272 & INDA,INDB,INDC,INDD,XABCD, 273 & THRESH,GTTHRS,IPRINT) 274 IF (GTTHRS) THEN 275 ICOUNT = ICOUNT + 1 276 BUF(ICOUNT,1) = XABCD 277 DO IOPP = 1, NOPP12 278 BUF(ICOUNT,IOPP+1) = SO(ISOFF+INT,IOPP) 279 END DO 280 IF (ICOUNT .EQ. LBUF) THEN 281 NBUFCL = NBUFCL + 1 282 CALL R12WRT(BUF,LBUF,ICOUNT,0,0,IPRINT) 283 END IF 284 END IF 285 210 CONTINUE 286 200 CONTINUE 287 ELSE 288 DCMPAB = IPNTLG(1,I) 289 DCMPCD = IPNTLG(2,I) 290 DCABAB = IPNTLG(3,I) 291 DRALTB = IREPA .LT. IREPB 292 DRCLTD = IREPC .LT. IREPD 293 DRABAB = DCABAB .AND. IREPA.EQ.IREPC .AND. IREPB.EQ.IREPD 294 INT = 0 295 DO 300 IAB = 1, NORBAB 296 IA = KHKTA*(NINDAB(IAB,1) - 1) 297 IB = KHKTB*(NINDAB(IAB,2) - 1) 298 IF (DCMPAB) THEN 299 IF ((IB.GT.IA) .OR. (DRALTB.AND.IB.EQ.IA)) THEN 300 INT = INT + NORBCD 301 GO TO 300 302 END IF 303 END IF 304 INDA = IPTSYM(NSTRNA + IA,IREPA) 305 INDB = IPTSYM(NSTRNB + IB,IREPB) 306 DO 310 ICD = 1,NORBCD 307 IC = KHKTC*(NINDCD(ICD,1) - 1) 308 ID = KHKTD*(NINDCD(ICD,2) - 1) 309 INT = INT + 1 310 IF (DCMPCD ) THEN 311 IF (ID.GT.IC) GO TO 310 312 IF (DRCLTD .AND. ID.EQ.IC) GO TO 310 313 END IF 314 IF (DRABAB) THEN 315 IF (IA.LT.IC.OR.(IA.EQ.IC.AND.IB.LT.ID)) GOTO 310 316 END IF 317 INDC = IPTSYM(NSTRNC + IC,IREPC) 318 INDD = IPTSYM(NSTRND + ID,IREPD) 319 CALL LAB64U(SO(ISOFF+INT,1),NSOINT, 320 & INDA,INDB,INDC,INDD,XABCD, 321 & THRESH,GTTHRS,IPRINT) 322 IF (GTTHRS) THEN 323 ICOUNT = ICOUNT + 1 324 BUF(ICOUNT,1) = XABCD 325 DO IOPP = 1, NOPP12 326 BUF(ICOUNT,IOPP+1) = SO(ISOFF+INT,IOPP) 327 END DO 328 IF (ICOUNT .EQ. LBUF) THEN 329 CALL R12WRT(BUF,LBUF,ICOUNT,0,0,IPRINT) 330 NBUFCL = NBUFCL + 1 331 END IF 332 END IF 333 310 CONTINUE 334 300 CONTINUE 335 END IF 336 ISOFF = ISOFF + NOABCD 337 100 CONTINUE 338 NGINT = LBUF*NBUFCL + ICOUNT - NSTART 339 CALL DELSTA(0,NGINT) 340C 341C ************************************* 342C ***** Last call to empty buffer ***** 343C ************************************* 344C 345 IF (LAST) CALL R12WRT(BUF,LBUF,ICOUNT,1,0,IPRINT) 346 RETURN 347 END 348C /* Deck us2out */ 349 SUBROUTINE US2OUT(SO,NSOINT,WRKBUF, 350 & IPNTNO,IPNTRP,IPNTLG,FIRST,LAST, 351 & THRESH,NINDAB,NINDCD,IORBSH,IPRINT) 352C 353#include "implicit.h" 354#include "priunit.h" 355#include "iratdef.h" 356 LOGICAL FIRST, LAST, IPNTLG(*) 357 DIMENSION SO(NSOINT,*), WRKBUF(*), IPNTNO(*), IPNTRP(*), 358 & NINDAB(*), NINDCD(*), IORBSH(*) 359#include "disbuf.h" 360C 361C--------------------------------- 362C Call sort and write routine. 363C--------------------------------- 364C 365 CALL US2OU1(SO,NSOINT,WRKBUF(KDSBF),WRKBUF(KDUBF), 366 & WRKBUF(KDSIBF),WRKBUF(KDSNCT), 367 & WRKBUF(KDSORB),WRKBUF(KORBDS),IPNTNO,IPNTRP,IPNTLG, 368 & FIRST,LAST,THRESH,NINDAB,NINDCD,LDSBUF,NDIST,IORBSH, 369 & IPRINT) 370C 371 RETURN 372 END 373C /* Deck us2ou1 */ 374 SUBROUTINE US2OU1(SO,NSOINT,BUF,CUF, 375 & IBUF4,NCOUNT,IDSORB,IORBDS,IPNTNO,IPNTRP, 376 & IPNTLG,FIRST,LAST,THRESH,NINDAB,NINDCD,LDSBUF, 377 & NDIST,IORBSH,IPRINT) 378C 379C Write out blocks of symmetry integrals, eliminating duplicates 380C 381#include "implicit.h" 382#include "priunit.h" 383#include "iratdef.h" 384#include "maxorb.h" 385#include "mxcent.h" 386#include "maxaqn.h" 387#include "aovec.h" 388#include "eribuf.h" 389#include "nuclei.h" 390 LOGICAL DCMPCD, DRCLTD, FIRST, LAST, IPNTLG(3,*), NOTEST, 391 & DOINDX 392 DIMENSION SO(NSOINT,*), BUF(LBUF,NDIST), CUF(LBUF,NDIST), 393 & IPNTNO(4,*), IPNTRP(3,*), NCOUNT(NDIST), 394 & NINDAB(NORBA*NORBB,2), NINDCD(NORBC*NORBD,2), 395 & IDSORB(NDIST), IORBDS(NBASIS), IORBSH(*) 396 INTEGER*4 IBUF4(LBUF*NIBUF,NDIST) 397#include "twocom.h" 398#include "symmet.h" 399#include "drw2el.h" 400#include "r12int.h" 401C 402 INTEGER*8 NWRIT 403C 404 405C 406 IF (LBUF .NE. LDSBUF) THEN 407 WRITE (LUPRI,*) 'LBUF .ne. LDSBUF :',LBUF,LDSBUF 408 CALL QUIT('Error in US2OU1, LBUF .ne. LDSBUF') 409 END IF 410C 411 IF (IPRINT .GT. 6) CALL HEADER('Subroutine US2OUT',-1) 412 IF (IPRINT .GT. 10) THEN 413 WRITE (LUPRI,'(2X,A,4I5)') 'NHKT? ', NHKTA, NHKTB, NHKTC, NHKTD 414 WRITE (LUPRI,'(2X,A,4I5)') 'MUL? ', MULA, MULB, MULC, MULD 415 WRITE (LUPRI,'(2X,A,4I5)') 'NORB? ', NORBA, NORBB, NORBC, NORBD 416 WRITE (LUPRI,'(2X,A,4I5)') 'NSTR? ', NSTRA, NSTRB, NSTRC, NSTRD 417 WRITE (LUPRI,'(2X,A,2I5)') 'NORBCD', NORBCD 418 WRITE (LUPRI,'(2X,A,2I5)') 'NOABCD', NOABCD 419 WRITE (LUPRI,'(2X,A,2L5)') 'DIAGAB/CD', DIAGAB, DIAGCD 420 WRITE (LUPRI,'(2X,A,2L5)') 'TCONAB/CD', TCONAB, TCONCD 421 WRITE (LUPRI,'(2X,A,2L5)') 'SHAEQB/CD', SHAEQB, SHCEQD 422 WRITE (LUPRI,'(2X,A, L5)') 'SHABAB', SHABAB 423 WRITE (LUPRI,'(2X,A, I5)') 'NDIST ', NDIST 424 END IF 425C 426 IF (NIBUF .EQ. 1) THEN 427 NBITS = 8 428 IBIT1 = 2**8 - 1 429 IBIT2 = 2**16 - 1 430 ELSE IF (NIBUF .EQ. 2) THEN 431 NBITS = 16 432 IBIT1 = 2**16 - 1 433 IBIT2 = 0 ! not used when NIBUF .eq. 2 434 ELSE 435 CALL QUIT('ERROR US2OU1: NIBUF .ne. 1 .and. NIBUF .ne. 2') 436 END IF 437C 438C ******************************************************* 439C ***** Initialization when subroutine first called ***** 440C ******************************************************* 441C 442 IF (FIRST) THEN 443 CALL IZERO(NCOUNT,NDIST) 444 CALL UN2WRU(BUF,CUF,IBUF4,ICOUNT,-1,0,IPRINT) 445C CALL UN2WRT(BUF,IBUF4,LBUF,NIBUF,ICOUNT,-1,NBITS,0,IPRINT) 446 DOINDX = .TRUE. 447 CALL AINDEX(ISHELA,NAINTS,IDSORB,DOINDX,IORBSH,IPRINT) 448 DO 50 IDIST = 1, NDIST 449 IORBDS(IDSORB(IDIST)) = IDIST 450 50 CONTINUE 451 NWRIT = 0 452 END IF 453C 454 ISOFF = 0 455 NBUFCL = 0 456 NOTEST = .NOT.(SHAEQB .OR. SHCEQD .OR. SHABAB) 457 DO 100 I = 1, NINTS 458 NSTRNA = IPNTNO(1,I) 459 NSTRNB = IPNTNO(2,I) 460 NSTRNC = IPNTNO(3,I) 461 NSTRND = IPNTNO(4,I) 462 IREPA = IPNTRP(1,I) 463 IREPB = IPNTRP(2,I) 464 IREPC = IPNTRP(3,I) 465 IREPD = IEOR(IEOR(IREPA,IREPB),IREPC) 466 IF (NOTEST) THEN 467 IF (NIBUF .EQ. 1) THEN 468 INT = 0 469 DO 200 IAB = 1, NORBAB 470 IA = KHKTA*(NINDAB(IAB,1) - 1) 471 IB = KHKTB*(NINDAB(IAB,2) - 1) 472 INDA = IPTSYM(NSTRNA + IA,IREPA) 473 INDAB = INDA*(IBIT1 + 1) + IPTSYM(NSTRNB + IB,IREPB) 474 IDIST = IORBDS(INDA) 475 DO 210 ICD = 1, NORBCD 476 INT = INT + 1 477 SOINT1 = SO(ISOFF+INT,1) 478 SOINT2 = SO(ISOFF+INT,2) 479 IF (ABS(SOINT1) .GT. THRESH .OR. 480 & ABS(SOINT2) .GT. THRESH) THEN 481 NCOUNT(IDIST) = NCOUNT(IDIST) + 1 482 ICOUNT = NCOUNT(IDIST) 483 IC = KHKTC*(NINDCD(ICD,1) - 1) 484 ID = KHKTD*(NINDCD(ICD,2) - 1) 485 INDC = IPTSYM(NSTRNC + IC,IREPC) 486 INDD = IPTSYM(NSTRND + ID,IREPD) 487 INDCD = MAX(INDC,INDD)*IBIT1 + INDC + INDD 488 IF (INDD.GT.INDC) THEN 489 BUF (ICOUNT,IDIST) = SOINT1 490 CUF (ICOUNT,IDIST) = - SOINT2 491 ELSE 492 BUF (ICOUNT,IDIST) = SOINT1 493 CUF (ICOUNT,IDIST) = SOINT2 494 END IF 495 IBUF4(ICOUNT,IDIST) = INDAB*(IBIT2 + 1) + INDCD 496 IF (ICOUNT.EQ.LBUF) THEN 497 NBUFCL = NBUFCL + 1 498 CALL UN2WRU(BUF(1,IDIST),CUF(1,IDIST), 499 & IBUF4(1,IDIST), 500 & ICOUNT,0,INDA,IPRINT) 501C CALL UN2WRT(BUF(1,IDIST),IBUF4(1,IDIST),LBUF, 502C & NIBUF,ICOUNT,0,NBITS,INDA,IPRINT) 503 NCOUNT(IDIST) = 0 504 END IF 505 END IF 506 210 CONTINUE 507 200 CONTINUE 508 ELSE 509 INT = 0 510 DO 205 IAB = 1, NORBAB 511 IA = KHKTA*(NINDAB(IAB,1) - 1) 512 IB = KHKTB*(NINDAB(IAB,2) - 1) 513 INDA = IPTSYM(NSTRNA + IA,IREPA) 514 INDB = IPTSYM(NSTRNB + IB,IREPB) 515 INDAB = INDA*(IBIT1 + 1) + INDB 516 IDIST = IORBDS(INDA) 517 DO 215 ICD = 1, NORBCD 518 INT = INT + 1 519 SOINT1 = SO(ISOFF+INT,1) 520 SOINT2 = SO(ISOFF+INT,2) 521 IF (ABS(SOINT1) .GT. THRESH .OR. 522 & ABS(SOINT2) .GT. THRESH) THEN 523 NCOUNT(IDIST) = NCOUNT(IDIST) + 1 524 ICOUNT = NCOUNT(IDIST) 525 IC = KHKTC*(NINDCD(ICD,1) - 1) 526 ID = KHKTD*(NINDCD(ICD,2) - 1) 527 INDC = IPTSYM(NSTRNC + IC,IREPC) 528 INDD = IPTSYM(NSTRND + ID,IREPD) 529 INDCD = MAX(INDC,INDD)*IBIT1 + INDC + INDD 530 IF (INDD.GT.INDC) THEN 531 BUF (ICOUNT,IDIST) = SOINT1 532 CUF (ICOUNT,IDIST) = - SOINT2 533 ELSE 534 BUF (ICOUNT,IDIST) = SOINT1 535 CUF (ICOUNT,IDIST) = SOINT2 536 END IF 537 IBUF4(2*ICOUNT-1,IDIST) = INDAB 538 IBUF4(2*ICOUNT ,IDIST) = INDCD 539 IF (ICOUNT.EQ.LBUF) THEN 540 NBUFCL = NBUFCL + 1 541 CALL UN2WRU(BUF(1,IDIST),CUF(1,IDIST), 542 & IBUF4(1,IDIST), 543 & ICOUNT,0,INDA,IPRINT) 544 NCOUNT(IDIST) = 0 545 END IF 546 END IF 547 215 CONTINUE 548 205 CONTINUE 549 END IF 550 ELSE 551 DCMPCD = IPNTLG(2,I) 552 DRCLTD = IREPC .LT. IREPD 553 INT = 0 554 DO 300 IAB = 1, NORBAB 555 IA = KHKTA*(NINDAB(IAB,1) - 1) 556 IB = KHKTB*(NINDAB(IAB,2) - 1) 557 INDA = IPTSYM(NSTRNA + IA,IREPA) 558 INDB = IPTSYM(NSTRNB + IB,IREPB) 559 INDAB = INDA*(IBIT1 + 1) + INDB 560 IDIST = IORBDS(INDA) 561 DO 310 ICD = 1,NORBCD 562 IC = KHKTC*(NINDCD(ICD,1) - 1) 563 ID = KHKTD*(NINDCD(ICD,2) - 1) 564 INT = INT + 1 565 IF (DCMPCD ) THEN 566 IF (ID.GT.IC) GO TO 310 567 IF (DRCLTD .AND. ID.EQ.IC) GO TO 310 568 END IF 569 SOINT1 = SO(ISOFF+INT,1) 570 SOINT2 = SO(ISOFF+INT,2) 571 IF (ABS(SOINT1) .GT. THRESH .OR. 572 & ABS(SOINT2) .GT. THRESH) THEN 573 IF (NIBUF .EQ. 1) THEN 574 NCOUNT(IDIST) = NCOUNT(IDIST) + 1 575 ICOUNT = NCOUNT(IDIST) 576 INDC = IPTSYM(NSTRNC + IC,IREPC) 577 INDD = IPTSYM(NSTRND + ID,IREPD) 578 INDCD = MAX(INDC,INDD)*IBIT1 + INDC + INDD 579 IF (BPH2OO.AND.INDD.GT.INDC) THEN 580 BUF (ICOUNT,IDIST) = SOINT1 581 CUF (ICOUNT,IDIST) = - SOINT2 582 ELSE 583 BUF (ICOUNT,IDIST) = SOINT1 584 CUF (ICOUNT,IDIST) = SOINT2 585 END IF 586 IBUF4(ICOUNT,IDIST) = INDAB*(IBIT2 + 1) + INDCD 587 IF (ICOUNT.EQ.LBUF) THEN 588 CALL UN2WRU(BUF(1,IDIST),CUF(1,IDIST), 589 & IBUF4(1,IDIST), 590 & ICOUNT,0,INDA,IPRINT) 591 NBUFCL = NBUFCL + 1 592 NCOUNT(IDIST) = 0 593 END IF 594 ELSE 595 NCOUNT(IDIST) = NCOUNT(IDIST) + 1 596 ICOUNT = NCOUNT(IDIST) 597 INDC = IPTSYM(NSTRNC + IC,IREPC) 598 INDD = IPTSYM(NSTRND + ID,IREPD) 599 INDCD = MAX(INDC,INDD)*IBIT1 + INDC + INDD 600 IF (INDD.GT.INDC) THEN 601 BUF (ICOUNT,IDIST) = SOINT1 602 CUF (ICOUNT,IDIST) = - SOINT2 603 ELSE 604 BUF (ICOUNT,IDIST) = SOINT1 605 CUF (ICOUNT,IDIST) = SOINT2 606 END IF 607 IBUF4(2*ICOUNT-1,IDIST) = INDAB 608 IBUF4(2*ICOUNT ,IDIST) = INDCD 609 IF (ICOUNT.EQ.LBUF) THEN 610 CALL UN2WRU(BUF(1,IDIST),CUF(1,IDIST), 611 & IBUF4(1,IDIST), 612 & ICOUNT,0,INDA,IPRINT) 613 NBUFCL = NBUFCL + 1 614 NCOUNT(IDIST) = 0 615 END IF 616 END IF 617 END IF 618 310 CONTINUE 619 300 CONTINUE 620 END IF 621 ISOFF = ISOFF + NOABCD 622 100 CONTINUE 623 NWRIT = NWRIT + LBUF*NBUFCL 624C 625C ************************************* 626C ***** Last call to empty buffer ***** 627C ************************************* 628C 629 IF (LAST) THEN 630 DO 400 IDIST = 1, NDIST 631 NWRIT = NWRIT + NCOUNT(IDIST) 632 CALL UN2WRU(BUF(1,IDIST),CUF(1,IDIST),IBUF4(1,IDIST), 633 & NCOUNT(IDIST),1,IDSORB(IDIST),IPRINT) 634 400 CONTINUE 635 FNALL = (NBASIS*(NBASIS + 1))/2 636 FNALL = FNALL*NBASIS 637 FNALL = FNALL*NDIST 638 PERCNT = NWRIT 639 PERCNT = 100.D0*PERCNT / FNALL 640 IF (IPRINT.GT.0) WRITE (LUPRI,'(/1X,A,I10,A,F4.1,A)') 641 & 'Number of two-electron integrals written:',NWRIT, 642 & ' (',PERCNT,'%)' 643 END IF 644C 645 RETURN 646 END 647C /* Deck un2wru */ 648 SUBROUTINE UN2WRU(BUF,CUF,IBUF4,ICOUNT,ITYPE,INDA,IPRINT) 649#include "implicit.h" 650#include "priunit.h" 651#include "iratdef.h" 652#include "maxorb.h" 653#include "mxcent.h" 654#include "maxaqn.h" 655#include "ibtpar.h" 656#include "eritap.h" 657#include "eribuf.h" 658 DIMENSION BUF(LBUF), CUF(LBUF) 659 INTEGER*4 IBUF4(LBUF*NIBUF), ICOUNT4 660#include "drw2el.h" 661#include "r12int.h" 662#include "twosta.h" 663#include "inftap.h" 664#include "nuclei.h" 665#include "symmet.h" 666 667C 668 NBUFX(0) = NBUFX(0) + 1 669 ICOUNT4 = ICOUNT 670C 671 IF (ITYPE .EQ. -1) THEN 672 REWIND LUINTR 673 NBUFX(0) = NBUFX(0) - 1 674c CALL NEWLAB('BASINFO ',LUINTA,LUPRI) 675c WRITE (LUINTA) MAXREP+1,(NAOS(I),I=1,8),LBUF,NIBUF,NBITS 676c CALL NEWLAB('BASTWOEL',LUINTA,LUPRI) 677c ICOUNT = 0 678c NBUFX(0) = 0 679 ELSE IF (ITYPE .EQ. 0) THEN 680 IF (INDA .NE. 0) WRITE (LUINTR) INDA 681 WRITE (LUAORC(0),REC=NBUFX(0)) BUF,IBUF4,ICOUNT4 682 WRITE (LU21INT ,REC=NBUFX(0)) CUF,IBUF4,ICOUNT4 683C 684 IF (IPRINT .GE. 6) THEN 685 WRITE (LUPRI,'(2X,A,I5,A/)') 'UN2WRU '// 686 & 'Integral buffer #',NBUFX(0),' has been written.' 687 IBIT1 = 2**NBITS - 1 688 DO 100 INT = 1, ICOUNT 689 IF (NIBUF .EQ. 1) THEN 690 IJKL = IBUF4(INT) ! IJKL will always be standard integer 691 I = IAND(ISHFT(IJKL,-3*NBITS),IBIT1) 692 J = IAND(ISHFT(IJKL,-2*NBITS),IBIT1) 693 K = IAND(ISHFT(IJKL, -NBITS),IBIT1) 694 L = IAND( IJKL, IBIT1) 695 ELSE 696 IJ = IBUF4(2*INT-1) 697 KL = IBUF4(2*INT ) 698 I = IAND(ISHFT(IJ,-NBITS),IBIT1) 699 J = IAND( IJ, IBIT1) 700 K = IAND(ISHFT(KL,-NBITS),IBIT1) 701 L = IAND( KL, IBIT1) 702 END IF 703 WRITE (LUPRI,'(10X,A,2X,4I4,5X,2(1P,D16.8))') 704 & ' ## ', I, J, K, L, BUF(INT), CUF(INT) 705 100 CONTINUE 706 END IF 707 ICOUNT = 0 708 ELSE 709 IF (INDA .NE. 0) THEN 710 WRITE (LUINTR) INDA 711 WRITE (LUAORC(0),REC=NBUFX(0)) BUF,IBUF4,ICOUNT4 712 WRITE (LU21INT ,REC=NBUFX(0)) CUF,IBUF4,ICOUNT4 713 ELSE 714 CALL QUIT('Error in UN2WRU') 715 END IF 716C 717 IF (IPRINT .GE. 6) THEN 718 IF (ICOUNT .GT. 0) THEN 719 WRITE (LUPRI,'(2X,A,I5,A,I5/)') 'UN2WRU '// 720 & 'Integral buffer #',NBUFX(0),' has been written.'// 721 & ' INDA =',INDA 722 IBIT1 = 2**NBITS - 1 723 DO 200 INT = 1, ICOUNT 724 IF (NIBUF .EQ. 1) THEN 725 IJKL = IBUF4(INT) ! IJKL will always be standard integer 726 I = IAND(ISHFT(IJKL,-3*NBITS),IBIT1) 727 J = IAND(ISHFT(IJKL,-2*NBITS),IBIT1) 728 K = IAND(ISHFT(IJKL, -NBITS),IBIT1) 729 L = IAND( IJKL, IBIT1) 730 ELSE 731 IJ = IBUF4(2*INT-1) 732 KL = IBUF4(2*INT ) 733 I = IAND(ISHFT(IJ,-NBITS),IBIT1) 734 J = IAND( IJ, IBIT1) 735 K = IAND(ISHFT(KL,-NBITS),IBIT1) 736 L = IAND( KL, IBIT1) 737 END IF 738 WRITE (LUPRI,'(10X,A,2X,4I4,5X,2(1P,D16.8))') 739 & ' ## ', I, J, K, L, BUF(INT), CUF(INT) 740 200 CONTINUE 741 END IF 742 END IF 743C 744C Statistics 745C 746 IF (INDA .EQ. 0) THEN 747 N2WRIT = LBUF*NBUFX(0) + ICOUNT 748 IF (ICOUNT.GT.0 .AND. INDA.NE.0) THEN 749 NBUFX(0) = NBUFX(0) + 2 750 ELSE 751 NBUFX(0) = NBUFX(0) + 1 752 END IF 753 IF (IRAT .EQ. 1) LWORD = 8 754 IF (IRAT .EQ. 2) LWORD = 4 755 FMBYTES = LWORD*(LBUF*IRAT + NIBUF*LBUF + 1) 756 FMBYTES = NBUFX(0)*FMBYTES 757 FMBYTES = FMBYTES / (1024.D0**2) 758 FNALL = (NBASIS*(NBASIS + 1))/2 759 FNALL = FNALL*(FNALL + 1.0D0)*0.5D0 760 PERCNT = N2WRIT 761 PERCNT = 100.D0*PERCNT / FNALL 762 WRITE (LUPRI,'(/A,I10,A,F4.1,A/A,F10.3//)') 763 & ' Number of two-electron integrals written:',N2WRIT, 764 & ' (',PERCNT,'%)', 765 & ' Megabytes written: ',FMBYTES 766 END IF 767 END IF 768 RETURN 769 END 770C end of FILE: abacus/aba2r12.F 771