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 19*======================================================================* 20C /* Deck cc_rdaod */ 21 SUBROUTINE CC_RDAOD(XINT,JSCOOR,JCOOR,JCORSY,IGAM,IDEL,NUMG,NUMD, 22 * WORK,LWORK,IRECNR,NRECS,MXBUF,NFILES, 23 * DIRINT,ITYPE,MXCOMP,LDERINT) 24*----------------------------------------------------------------------* 25C 26C Purpose: Read (**|GD) distribution of (derivative) AO integrals 27C for a given symmetry coordinate (JCOOR,JCORSY) 28C 29C direct option (DIRINT=.TRUE.) disabled, because the derivative 30C integrals are only available non-direct (for the time beeing) 31C 32C --> WORK is not used, IRECNR, LWORK are dummy 33C 34C ITYPE = 0 -- two-electron integrals of unperturbed integrals 35C ITYPE = 1 -- geometric first derivatives of 2-el integrals 36C ITYPE = 5 -- magnetic first derivatives of 2-el integrals 37C 38C 39C Written by Christof Haettig 06-May-1998 40C based on Henrik Kochs CC_RDAO routine 41C magnetic derivatives introduced 20-Sep-1999 42C 43*----------------------------------------------------------------------* 44#include "implicit.h" 45C 46#include "priunit.h" 47#include "maxorb.h" 48#include "mxcent.h" 49#include "maxash.h" 50#include "iratdef.h" 51#include "ccorb.h" 52CCN #include "infind.h" replaced by #include <ccisao.h> 53#include "ccisao.h" 54#include "ccsdsym.h" 55#include "cbieri.h" 56#include "eribuf.h" 57#include "nuclei.h" 58#include "chrnos.h" 59C 60 LOGICAL LOCDBG 61 PARAMETER (LOCDBG = .FALSE.) 62C 63 LOGICAL DIRINT 64 LOGICAL LDERINT(8,*) 65 INTEGER JSCOOR, JCOOR, JCORSY, MXCOMP, NFILES 66 DIMENSION XINT(*),WORK(LWORK) 67 INTEGER IGAM(NUMG),IDEL(NUMD) 68 INTEGER IRECNR(MXBUF,0:NFILES-1), NRECS(0:JSCOOR) 69C 70 LOGICAL OLDDX, LONDON2 71 INTEGER LENGTH(8), NDIMAB(8), NDIMDIS(8),IDSAO(8,8) 72 INTEGER KSCOOR, KCOOR, KCORSY, MAXCMP, MCSYM, UNIAO2 73 CHARACTER*8 NAME(16) 74 CHARACTER*8 FNAME, FAODER 75C 76C 77 DATA NAME /'CCAOIN_1','CCAOIN_2','CCAOIN_3','CCAOIN_4', 78 * 'CCAOIN_5','CCAOIN_6','CCAOIN_7','CCAOIN_8', 79 * 'CCAODER1','CCAODER2','CCAODER3','CCAODER4', 80 * 'CCAODER5','CCAODER6','CCAODER7','CCAODER8'/ 81 COMMON/SORTIO/LUAOIN(8) 82C 83 LOGICAL LDUMMY 84 85*----------------------------------------------------------------------* 86* check ITYPE option and set some integers: 87* KCOOR : required coordinate 88* KCORSY : required symmetry class 89* KSCOOR : symmetry coordinate (used as file index) 90* MAXCMP : maximum # of coordinates 91* MCSYM : maximum symmetry class 92* for ITYPE = 0 the loops over the coordinates/symmetries are 93* suppressed --> all for integers are set to 1 94*----------------------------------------------------------------------* 95 IF (ITYPE.EQ.0) THEN 96 KCOOR = 1 97 KCORSY = 1 98 KSCOOR = 0 ! direct undiff. integrals are on file nb. 0 99 MAXCMP = 1 100 MCSYM = 1 101 ELSE IF (ITYPE.EQ.1) THEN 102 KCOOR = JCOOR 103 KCORSY = JCORSY 104 IF (DIRINT) THEN 105 KSCOOR = JSCOOR 106 ELSE 107 KSCOOR = JCOOR ! symmetry coordinate = coordinate index 108 END IF 109 MAXCMP = MXCOMP 110 MCSYM = NSYM 111 ELSE IF (ITYPE.EQ.5) THEN 112 KCOOR = JCOOR 113 KCORSY = JCORSY 114 KSCOOR = JSCOOR 115 MAXCMP = MXCOMP 116 MCSYM = NSYM 117 ELSE 118 WRITE (LUPRI,*) 'CC_RDAOD called with illegal value for ITYPE:', 119 & ITYPE 120 CALL QUIT('CC_RDAOD called with illegal value for ITYPE.') 121 END IF 122C 123C set length of alpha,beta (2 index), and length and offsets of 124C alpha,beta,gamma (3 index) subblocks: 125C 126 IF (ITYPE.EQ.0 .OR. ITYPE.EQ.1) THEN 127 DO ISYM = 1, NSYM 128 NDIMAB(ISYM) = NNBST(ISYM) 129 NDIMDIS(ISYM) = NDISAO(ISYM) 130 DO ISYMI = 1, NSYM 131 IDSAO(ISYM,ISYMI) = IDSAOG(ISYM,ISYMI) 132 END DO 133 END DO 134 ELSE IF (ITYPE.EQ.5) THEN 135 DO ISYM = 1, NSYM 136 NDIMAB(ISYM) = N2BST(ISYM) 137 NDIMDIS(ISYM) = NDISAOSQ(ISYM) 138 DO ISYMI = 1, NSYM 139 IDSAO(ISYM,ISYMI) = IDSAOGSQ(ISYM,ISYMI) 140 END DO 141 END DO 142 ELSE 143 CALL QUIT('Unknown ITYPE in CC_RDAOD.') 144 END IF 145C 146C precalculate length of distributions: 147C 148 DO ISYMD = 1, NSYM 149 LENGTH(ISYMD) = 0 150 DO ICOOR = 1, MAXCMP 151 DO ICORSY = 1, MCSYM 152 IF ( ITYPE.EQ.0 .OR. LDERINT(ICORSY,ICOOR) ) THEN 153 ISYDIS = MULD2H(ISYMD,ICORSY) 154 LENGTH(ISYMD) = LENGTH(ISYMD) + NDIMDIS(ISYDIS) 155 END IF 156 END DO 157 END DO 158 END DO 159 160 IF (LOCDBG) THEN 161 WRITE(LUPRI,*) 'entered CC_RDAOD> DIRINT = ',DIRINT 162 WRITE(LUPRI,*) 'entered CC_RDAOD> ITYPE,KSCOOR :',ITYPE,KSCOOR 163 WRITE(LUPRI,*) 'entered CC_RDAOD> KCORSY,KCOOR :',KCORSY,KCOOR 164 END IF 165 166*----------------------------------------------------------------------* 167* Non-direct first derivative integrals. 168*----------------------------------------------------------------------* 169 170 IF (.NOT. DIRINT) THEN 171 172 IF ( .NOT. (ITYPE.EQ.0 .OR. LDERINT(KCORSY,KCOOR)) ) THEN 173C WRITE (LUPRI,*) 174C * 'CC_RDAOD> Warning: required integrals are zero...' 175C WRITE (LUPRI,*) 176C * 'CC_RDAOD> ITYPE = ',ITYPE 177C WRITE (LUPRI,*) 178C * 'CC_RDAOD> KCORSY/KCOOR = ',KCORSY,KCOOR 179C WRITE (LUPRI,*) 180C * 'CC_RDAOD> LDERINT = ',LDERINT(KCORSY,KCOOR) 181 182 KOFF = 1 183 DO ID = 1, NUMD 184 DO IG = 1, NUMG 185 ISYMD = ISAO(IDEL(ID)) 186 ISYMG = ISAO(IGAM(IG)) 187 ISYDIS = MULD2H(ISYMD,KCORSY) 188 ISYMAB = MULD2H(ISYDIS,ISYMG) 189 CALL DZERO(XINT(KOFF),NDIMAB(ISYMAB)) 190 KOFF = KOFF + NDIMAB(ISYMAB) 191 END DO 192 END DO 193 194 RETURN 195 END IF 196 197 KOFF = 1 198 DO ID = 1,NUMD 199C 200 ISYMD = ISAO(IDEL(ID)) 201 D = IDEL(ID) - IBAS(ISYMD) 202 IOFF0 = LENGTH(ISYMD)*(D-1) 203 204 IF (D.LT.0 .OR. D.GT.NBAST) THEN 205 WRITE (LUPRI,*) 'ORBITAL INDEX OUT OF RANGE IN CC_RDAOD.' 206 WRITE (LUPRI,*) 207 & 'CC_RDAOD: read distribution IDEL(ID) = ',IDEL(ID) 208 WRITE (LUPRI,*) 'CC_RDAOD: ISYMD, D, IOFF0 = ',ISYMD,D, 209 & IOFF0 210 CALL QUIT('ORBITAL INDEX OUT OF RANGE IN CC_RDAOD.') 211 END IF 212 213 IF (ITYPE.EQ.0) THEN 214 NFILE = LUAOIN(ISYMD) 215 FNAME = NAME(ISYMD) 216 ELSE IF (ITYPE.EQ.1 .OR. ITYPE.EQ.5) THEN 217 NFILE = 0 218 FNAME = NAME(8+ISYMD) 219 CALL WOPEN2(NFILE,FNAME,64,0) 220 END IF 221 222 IF (LOCDBG) THEN 223 WRITE (LUPRI,*) 'CC_RDAOD: FNAME = ', FNAME 224 WRITE (LUPRI,*) 'CC_RDAOD: NFILE = ', NFILE 225 WRITE (LUPRI,*) 'CC_RDAOD: ITYPE = ', ITYPE 226 WRITE (LUPRI,*) 'CC_RDAOD: LENGTH= ', LENGTH(ISYMD) 227 END IF 228 229 230 DO ICOOR = 1, MXCOMP 231 DO ICORSY = 1, NSYM 232 233 ISYDIS = MULD2H(ISYMD,ICORSY) 234 235 IF ( ITYPE.EQ.0 .OR. LDERINT(ICORSY,ICOOR) ) THEN 236C 237 IF ( ICOOR.EQ.KCOOR .AND. ICORSY.EQ.KCORSY ) THEN 238 239 DO IG = 1,NUMG 240 ISYMG = ISAO(IGAM(IG)) 241 G = IGAM(IG) - IBAS(ISYMG) 242 ISYMAB = MULD2H(ISYDIS,ISYMG) 243 244 IOFF = IOFF0 + IDSAO(ISYMG,ISYDIS) 245 * + NDIMAB(ISYMAB)*(G - 1) + 1 246 247 248 CALL GETWA2 ( NFILE, FNAME, XINT(KOFF), IOFF, 249 * NDIMAB(ISYMAB)) 250 251 IF (LOCDBG) THEN 252 XNORM=DDOT(NDIMAB(ISYMAB),XINT(KOFF),1, 253 * XINT(KOFF),1) 254 WRITE (LUPRI,'(a,2i5,f10.5)') 'CC_RDAOD> ', 255 * IDEL(ID),IGAM(IG),XNORM 256 CALL OUTPUT(XINT(KOFF),1,NDIMAB(ISYMAB),1,1, 257 * NDIMAB(ISYMAB),1,1,LUPRI) 258 END IF 259 260 KOFF = KOFF + NDIMAB(ISYMAB) 261 END DO 262 263 END IF 264 265 IOFF0 = IOFF0 + NDIMDIS(ISYDIS) 266 267 END IF 268 END DO 269 END DO 270 271 IF (ITYPE.EQ.1 .OR. ITYPE.EQ.5) THEN 272 CALL WCLOSE2(NFILE,NAME(ISYM),'KEEP') 273 END IF 274 275 END DO 276 277 ELSE 278C 279C record length 280C 281C 282 LBFINP = LBUF 283C 284 CALL ERIBUF_INI ! set NIBUF, NBITS, IBIT1, IBIT2 285#if defined (SYS_NEC) 286 LRECL = LBFINP + NIBUF*LBFINP/2 + 1 ! in integer*8 units 287#else 288 LRECL = 2*LBFINP + NIBUF*LBFINP + 1 ! in integer*4 units 289#endif 290C 291 IF (LOCDBG) THEN 292 WRITE(LUPRI,*) 'LBFINP,NBASIS,LRECL:',LBFINP,NBASIS,LRECL 293 END IF 294C 295C Buffer allocation 296C 297 KAOAB = 1 298 KDIST = KAOAB + (NBAST*NBAST+1)/IRAT + 1 299 KRBUF = KDIST + (NUMD*NBAST+1)/IRAT + 1 300 KIBUF = KRBUF + LBUF 301 KEND1 = KIBUF + (NIBUF*LBUF+1)/2 ! "/2" because in integer*4 units 302 LWRK1 = LWORK - KEND1 303 IF (LWRK1 .LT. 0) THEN 304 WRITE(LUPRI,*) 'Insufficient work space in CC_RDAOD:' 305 WRITE(LUPRI,*) 'Need:',KEND1 306 WRITE(LUPRI,*) 'Available:',LWORK 307 CALL QUIT('Insufficient work space in CC_RDAOD') 308 ENDIF 309 310 CALL CCSD_INIT2B(WORK(KAOAB),DUMMY,DUMMY,ITYPE, 311 & .TRUE.,1,LDUMMY) 312 313*----------------------------------------------------------------------* 314* open file, read integral distributions and close file again: 315*----------------------------------------------------------------------* 316 !SONIA, changed to -1, UNIAO2 = 0 317 UNIAO2 = -1 318 FAODER = 'AO2DIS'//CHRNOS(KSCOOR/10) 319 & //CHRNOS(MOD(KSCOOR,10)) 320 CALL GPOPEN(UNIAO2,FAODER,'OLD','DIRECT', 321 & 'UNFORMATTED',LRECL,OLDDX) 322 IF (LOCDBG) WRITE(LUPRI,*) 'CC_RDAOD> opened file:',FAODER 323C 324C read integrals and close file 325C 326 LONDON2 = .FALSE. 327 CALL CCRDAOD1(XINT,WORK(KIBUF),WORK(KRBUF),UNIAO2,LONDON2, 328 & KCORSY,IGAM,IDEL,NUMG,NUMD,ITYPE, 329 & WORK(KAOAB),NDIMAB,WORK(KDIST), 330 & IRECNR(1,KSCOOR),NRECS(KSCOOR)) 331 332 CALL GPCLOSE(UNIAO2,'KEEP') 333 334*----------------------------------------------------------------------* 335* for London integrals read second half of the integral matrices: 336*----------------------------------------------------------------------* 337 IF (ITYPE.EQ.5) THEN 338 LONDON2 = .TRUE. 339 KSCOOR = KSCOOR + 3 340 341 !SONIA, changed to -1, UNIAO2 = 0 342 UNIAO2 = -1 343 FAODER = 'AO2DIS'//CHRNOS(KSCOOR/10) 344 & //CHRNOS(MOD(KSCOOR,10)) 345 CALL GPOPEN(UNIAO2,FAODER,'OLD','DIRECT', 346 & 'UNFORMATTED',LRECL,OLDDX) 347 348 CALL CCRDAOD1(XINT,WORK(KIBUF),WORK(KRBUF),UNIAO2,LONDON2, 349 & KCORSY,IGAM,IDEL,NUMG,NUMD,ITYPE, 350 & WORK(KAOAB),NDIMAB,WORK(KDIST), 351 & IRECNR(1,KSCOOR),NRECS(KSCOOR)) 352 353 CALL GPCLOSE(UNIAO2,'KEEP') 354 END IF 355 356 ENDIF 357 358 IF (LOCDBG) THEN 359 WRITE(LUPRI,*) 'leaving CC_RDAOD> ' 360 END IF 361 362 RETURN 363 END 364*======================================================================* 365*======================================================================* 366C /* Deck ccrdaod1 */ 367 SUBROUTINE CCRDAOD1(XINT,IBUF,RBUF,UNIAO2,LONDON2, 368 * ICORSY,IGAM,IDEL,NUMG,NUMD,ITYPE, 369 * IADRPQ,NDIMPQ,IOFFRD,IRECNR,NRECORDS) 370*----------------------------------------------------------------------* 371C 372C Purpose: Read (**|GD) distribution of (derivative) AO integrals 373C for a given symmetry coordinate (JCOOR,JCORSY) 374C 375C direct option (DIRINT=.TRUE.) disabled, because the derivative 376C integrals are only available non-direct (for the time beeing) 377C 378C --> WORK is not used, IRECNR, LWORK are dummy 379C 380C ITYPE = 0 -- two-electron integrals of unperturbed integrals 381C ITYPE = 1 -- geometric first derivatives of 2-el integrals 382C ITYPE = 5 -- magnetic first derivatives of 2-el integrals 383C 384C 385C Written by Christof Haettig 06-May-1998 386C based on Henrik Kochs CC_RDAO routine 387C magnetic derivatives introduced 20-Sep-1999 388C 389*----------------------------------------------------------------------* 390#include "implicit.h" 391#include "priunit.h" 392#include "mxcent.h" 393#include "maxorb.h" 394#include "eribuf.h" 395#include "ccorb.h" 396#include "ccisao.h" 397#include "ibtpar.h" 398C 399 LOGICAL LOCDBG 400 PARAMETER ( LOCDBG = .FALSE. ) 401C 402 DIMENSION XINT(*), RBUF(LBUF) 403 INTEGER*4 IBUF4(LBUF*NIBUF), LENGTH4 404 LOGICAL LONDON2 405 INTEGER UNIAO2,ICORSY,NUMG,NUMD,ITYPE 406 INTEGER IGAM(NUMG),IDEL(NUMD),IRECNR(*), NRECORDS 407 INTEGER IADRPQ(NBAST,NBAST), IOFFRD(NBAST,NUMD) 408 INTEGER NDIMPQ(NSYM) 409C 410C functions: 411 412C 413 IF (LOCDBG) THEN 414 WRITE(LUPRI,*) 'entered CCRDAOD1' 415 WRITE(LUPRI,*) 'UNIAO2:',UNIAO2 416 WRITE(LUPRI,*) 'NRECORDS:',NRECORDS 417 CALL FLSHFO(LUPRI) 418 END IF 419C 420 IF (ITYPE.EQ.0 .OR. ITYPE.EQ.1) THEN 421 SIGN = 1.0d0 422 ELSE IF (ITYPE.EQ.5) THEN 423 SIGN = -1.0d0 424 END IF 425 426 IF (.NOT.LONDON2) THEN 427C 428C initialize XINT and set up IOFFRD: 429C (set to -1 for those gammas we don't want to read) 430C 431 KOFF = 1 432 DO ID = 1, NUMD 433 DO IGAMMA = 1, NBAST 434 IOFFRD(IGAMMA,ID) = -1 435 END DO 436 DO IG = 1, NUMG 437 ISYMD = ISAO(IDEL(ID)) 438 ISYMG = ISAO(IGAM(IG)) 439 ISYPQ = MULD2H(MULD2H(ISYMD,ISYMG),ICORSY) 440 IOFFRD(IGAM(IG),ID) = KOFF - 1 441 CALL DZERO(XINT(KOFF),NDIMPQ(ISYPQ)) 442 KOFF = KOFF + NDIMPQ(ISYPQ) 443 IF(LOCDBG) WRITE(LUPRI,'(A,5I5)')'ID,IDEL,IG,IGAM,IOFFRD:', 444 & ID,IDEL(ID),IG,IGAM(IG),IOFFRD(IGAM(IG),ID) 445 END DO 446 END DO 447 448C 449C loop over all records and read all those with relevant 450C delta indices 451C 452 DO NREC = 1, NRECORDS 453 454 ! find delta index ID, if not found skip record... 455 ID = 0 456 DO JD = 1, NUMD 457 IF (IRECNR(NREC).EQ.IDEL(JD)) ID = JD 458 IF (LOCDBG) 459 & WRITE(LUPRI,*)'IRECNR,JD,IDEL,ID:', 460 & IRECNR(NREC),JD,IDEL(JD),ID 461 END DO 462 463 IF (ID.GT.0) THEN 464 READ(UNIAO2,ERR=2000,REC=NREC) RBUF,IBUF4,LENGTH4 465 IF (NIBUF.EQ.1) THEN 466 DO I = 1,LENGTH4 467 I_PQR = IBUF4(I) ! change to default integer type 468 IP = IAND( I_PQR ,IBIT1) 469 IQ = IAND(ISHFT(I_PQR, -NBITS),IBIT1) 470 IR = IAND(ISHFT(I_PQR,-2*NBITS),IBIT1) 471 IF (IOFFRD(IR,ID).GE.0) THEN 472 IADR = IOFFRD(IR,ID) + IADRPQ(IP,IQ) 473 474C WRITE(LUPRI,*) 'IR,ID,IP,IQ,IADR:',IR,ID,IP,IQ,IADR 475C IF (IP.LT.1 .OR. IP.GT.NBAST .OR. 476C & IQ.LT.1 .OR. IQ.GT.NBAST .OR. 477C & IR.LT.1 .OR. IR.GT.NBAST ) THEN 478C CALL QUIT('INDICES OUT OF RANGE IN CCRDAOD1.') 479C END IF 480C CALL FLSHFO(LUPRI) 481 482 XINT(IADR) = SIGN*RBUF(I) 483 END IF 484 END DO 485 ELSE 486 DO I = 1,LENGTH4 487 I_PQ = IBUF4(2*I ) ! change to default integer type 488 I_RS = IBUF4(2*I-1) ! change to default integer type 489 IP = IAND( I_PQ ,IBIT1) 490 IQ = IAND(ISHFT(I_PQ,-NBITS),IBIT1) 491 IR = IAND( I_RS ,IBIT1) 492 IF (IOFFRD(IR,ID).GE.0) THEN 493 IADR = IOFFRD(IR,ID) + IADRPQ(IP,IQ) 494 XINT(IADR) = SIGN*RBUF(I) 495 END IF 496 END DO 497 END IF 498 499c IF (LOCDBG .AND. NIBUF.EQ.1) THEN 500c WRITE(LUPRI,*) 'INTEGRALS READ FROM RECORD:',NREC 501c DO I = 1,LENGTH4 502c I_PQR = IBUF4(I) ! change to default integer type 503c IP = IAND( I_PQR ,IBIT1) 504c IQ = IAND(ISHFT(I_PQR, -NBITS),IBIT1) 505c IR = IAND(ISHFT(I_PQR,-2*NBITS),IBIT1) 506c IF (IOFFRD(IR,ID).GE.0) THEN 507c IADR = IOFFRD(IR,ID) + IADRPQ(IP,IQ) 508c WRITE (LUPRI,'(10X,A,2X,4I4,5X,1P,D16.8,5X,I5)') 509c & ' ## ', IP, IQ , IR, IDEL(ID), XINT(IADR), IADR 510c ELSE 511c WRITE (LUPRI,'(10X,A,2X,4I4,5X,1P,D16.8,5X,A)') 512c & ' ## ', IP, IQ , IR, IDEL(ID),SIGN*RBUF(I),'skipped' 513c END IF 514c END DO 515c END IF 516 517 ENDIF 518 519 END DO 520 521 ELSE 522 523C 524C loop over all records and read all those with relevant 525C delta indices, exchange P and Q 526C 527 DO NREC = 1, NRECORDS 528 529 ! find delta index ID, if not found skip record... 530 ID = 0 531 DO JD = 1, NUMD 532 IF (IRECNR(NREC).EQ.IDEL(JD)) ID = JD 533 END DO 534 535 IF (ID.GT.0) THEN 536 READ(UNIAO2,ERR=2000,REC=NREC) RBUF,IBUF4,LENGTH4 537 IF (NIBUF.EQ.1) THEN 538 DO I = 1,LENGTH4 539 I_PQR = IBUF4(I) ! change to default integer type 540 IP = IAND( I_PQR ,IBIT1) 541 IQ = IAND(ISHFT(I_PQR, -NBITS),IBIT1) 542 IR = IAND(ISHFT(I_PQR,-2*NBITS),IBIT1) 543 IF (IOFFRD(IR,ID).GE.0) THEN 544 IADR = IOFFRD(IR,ID) + IADRPQ(IQ,IP) 545 546C WRITE(LUPRI,*) 'IR,ID,IP,IQ,IADR:',IR,ID,IP,IQ,IADR 547C IF (IP.LT.1 .OR. IP.GT.NBAST .OR. 548C & IQ.LT.1 .OR. IQ.GT.NBAST .OR. 549C & IR.LT.1 .OR. IR.GT.NBAST ) THEN 550C CALL QUIT('INDICES OUT OF RANGE IN CCRDAOD1.') 551C END IF 552C CALL FLSHFO(LUPRI) 553 554 XINT(IADR) = SIGN*RBUF(I) 555 END IF 556 END DO 557 ELSE 558 DO I = 1,LENGTH4 559 I_PQ = IBUF4(2*I ) ! change to default integer type 560 I_RS = IBUF4(2*I-1) ! change to default integer type 561 IP = IAND( I_PQ ,IBIT1) 562 IQ = IAND(ISHFT(I_PQ,-NBITS),IBIT1) 563 IR = IAND( I_RS ,IBIT1) 564 IF (IOFFRD(IR,ID).GE.0) THEN 565 IADR = IOFFRD(IR,ID) + IADRPQ(IQ,IP) 566 XINT(IADR) = SIGN*RBUF(I) 567 END IF 568 END DO 569 END IF 570 571 IF (LOCDBG .AND. NIBUF.EQ.1) THEN 572 WRITE(LUPRI,*) 'INTEGRALS READ FROM RECORD:',NREC 573 DO I = 1,LENGTH4 574 I_PQR = IBUF4(I) ! change to default integer type 575 IP = IAND( I_PQR ,IBIT1) 576 IQ = IAND(ISHFT(I_PQR, -NBITS),IBIT1) 577 IR = IAND(ISHFT(I_PQR,-2*NBITS),IBIT1) 578 IF (IOFFRD(IR,ID).GE.0) THEN 579 IADR = IOFFRD(IR,ID) + IADRPQ(IQ,IP) 580 WRITE (LUPRI,'(10X,A,2X,4I4,5X,1P,D16.8,5X,I5)') 581 & ' ## ', IP, IQ , IR, IDEL(ID), XINT(IADR), IADR 582 ELSE 583 WRITE (LUPRI,'(10X,A,2X,4I4,5X,1P,D16.8,5X,A)') 584 & ' ## ', IP, IQ , IR, IDEL(ID),SIGN*RBUF(I),'skipped' 585 END IF 586 END DO 587 END IF 588 589 ENDIF 590 591 END DO 592 593 END IF 594 595 IF (LOCDBG) THEN 596 IF (LONDON2) WRITE(LUPRI,*) 'CCRDAOD1> LONDON2!' 597 DO ID = 1, NUMD 598 DO IG = 1, NUMG 599 ISYMD = ISAO(IDEL(ID)) 600 ISYMG = ISAO(IGAM(IG)) 601 ISYPQ = MULD2H(MULD2H(ISYMD,ISYMG),ICORSY) 602 KOFF = IOFFRD(IGAM(IG),ID) + 1 603 XNORM=DDOT(NDIMPQ(ISYPQ),XINT(KOFF),1, 604 * XINT(KOFF),1) 605 WRITE (LUPRI,'(a,2i5,f10.5)') 'CCRDAOD1> ', 606 * IDEL(ID),IGAM(IG),XNORM 607 CALL OUTPUT(XINT(KOFF),1,NDIMPQ(ISYPQ),1,1, 608 * NDIMPQ(ISYPQ),1,1,LUPRI) 609 END DO 610 END DO 611 END IF 612 613 614 RETURN 615*----------------------------------------------------------------------* 616C I/O error handling: 617*----------------------------------------------------------------------* 6182000 CONTINUE 619 CALL QUIT('I/O error in CCRDAOD...') 620 621 END 622*======================================================================* 623*======================================================================* 624C /* Deck RDERILBS */ 625 SUBROUTINE RDERILBS(IRECNR,NRECS,MXBUF,NFILES) 626*----------------------------------------------------------------------* 627C read orbital (delta) indices for all records on all files 628C into array IRECNR 629*----------------------------------------------------------------------* 630 IMPLICIT NONE 631 632#include "priunit.h" 633#include "mxcent.h" 634#include "dummy.h" 635#include "inftap.h" 636#include "eritap.h" 637 638 LOGICAL LOCDBG 639 PARAMETER (LOCDBG = .FALSE.) 640 641 INTEGER MXBUF, NFILES, IDELTA, ISCOOR, ILINE, NBUFTOT 642 INTEGER IRECNR(MXBUF,0:NFILES-1), NRECS(0:NFILES-1) 643 644 IF (LOCDBG) THEN 645 WRITE(LUPRI,*) 'entered RDERILBS...' 646 WRITE(LUPRI,*) 'NBUFX,NFILES:',NBUFX,NFILES 647 CALL FLSHFO(2) 648 END IF 649 650 IF (LUINTR .LE. 0) THEN 651 IF (LOCDBG) WRITE(LUPRI,*) 'Open AOTWODIS file...' 652 CALL GPOPEN(LUINTR,'AOTWODIS','OLD',' ', 653 & 'UNFORMATTED',IDUMMY,.FALSE.) 654 END IF 655 656 REWIND (LUINTR) 657 658 NBUFTOT = 0 659 DO ISCOOR = 0, NFILES-1 660 NRECS(ISCOOR) = 0 661 NBUFTOT = NBUFTOT + NBUFX(ISCOOR) 662 END DO 663 664 DO ILINE = 1, NBUFTOT 665 READ(LUINTR) IDELTA, ISCOOR 666 NRECS(ISCOOR) = NRECS(ISCOOR) + 1 667 IRECNR(NRECS(ISCOOR),ISCOOR) = IDELTA 668 IF (LOCDBG) WRITE(LUPRI,*) 'ILINE,IDELTA,ISCOOR,NRECS:', 669 & ILINE,IDELTA,ISCOOR,NRECS(ISCOOR) 670 END DO 671 672 IF (LOCDBG) WRITE(LUPRI,*) 'leaving RDERILBS...' 673 674 RETURN 675 END 676*======================================================================* 677