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_BMATRIX */ 21*=====================================================================* 22 SUBROUTINE CC_BMATRIX( IBTRAN, NBTRAN, LISTA, LISTB, IOPTRES, 23 & FILBMA, IBDOTS, BCONS, MXVEC, 24 & DO_O2, WORK, LWORK ) 25*---------------------------------------------------------------------* 26* 27* Purpose: batched loop over B matrix transformations 28* (needed if the number of transformations exceeds the 29* limit MAXSIM defined on ccsdio.h ) 30* 31* Written by Christof Haettig, March 1998. 32* 33*=====================================================================* 34#if defined (IMPLICIT_NONE) 35 IMPLICIT NONE 36#else 37# include "implicit.h" 38#endif 39#include "priunit.h" 40#include "maxorb.h" 41#include "ccsdio.h" 42 43 LOGICAL LOCDBG 44 PARAMETER (LOCDBG = .FALSE.) 45 46 LOGICAL DO_O2 47 CHARACTER*(*) LISTA, LISTB, FILBMA 48 INTEGER IOPTRES 49 INTEGER NBTRAN, MXVEC, LWORK 50 INTEGER IBTRAN(3,NBTRAN) 51 INTEGER IBDOTS(MXVEC,NBTRAN) 52 53 REAL*8 WORK(LWORK) 54 REAL*8 BCONS(MXVEC,NBTRAN) 55 56 INTEGER MAXBTRAN, NTRAN, ISTART, IBATCH, NBATCH 57 58 CALL QENTER('CC_BMATRIX') 59C 60 MAXBTRAN = MAXSIM 61 62 NBATCH = (NBTRAN+MAXBTRAN-1)/MAXBTRAN 63 64 IF (LOCDBG) THEN 65 WRITE (LUPRI,*) 'Batching over B matrix transformations:' 66 WRITE (LUPRI,*) 'nb. of batches needed:', NBATCH 67 END IF 68 69 DO IBATCH = 1, NBATCH 70 ISTART = (IBATCH-1) * MAXBTRAN + 1 71 NTRAN = MIN(NBTRAN-(ISTART-1),MAXBTRAN) 72 73 IF (LOCDBG) THEN 74 WRITE (LUPRI,*) 'Batch No.:',IBATCH 75 WRITE (LUPRI,*) 'start at :',ISTART 76 WRITE (LUPRI,*) '# transf.:',NTRAN 77 END IF 78 79 CALL CC_BMAT( IBTRAN(1,ISTART), NTRAN, 80 & LISTA, LISTB, IOPTRES, FILBMA, 81 & IBDOTS(1,ISTART), BCONS(1,ISTART), 82 & MXVEC, DO_O2, WORK, LWORK ) 83 84 END DO 85 86 CALL QEXIT('CC_BMATRIX') 87 88 RETURN 89 END 90 91*---------------------------------------------------------------------* 92* END OF SUBROUTINE CC_BMATRIX * 93*---------------------------------------------------------------------* 94 95*---------------------------------------------------------------------* 96c/* Deck CC_BMAT */ 97*=====================================================================* 98 SUBROUTINE CC_BMAT( IBTRAN, NBTRAN, LISTA, LISTB, IOPTRES, 99 & FILBMA, IBDOTS, BCONS, MXVEC, DO_O2, 100 & WORK, LWORK ) 101*---------------------------------------------------------------------* 102* 103* Purpose: AO-direct calculation of a linear transformation of two 104* CC amplitude vectors, T^A and T^B, with the CC B matrix 105* (derivatives of the CC lagrangian with respect to t) 106* 107* The linear transformations are calculated for a list 108* of T^A vectors and a list of T^B vectors: 109* 110* LISTA -- type of T^A vectors 111* LISTB -- type of T^B vectors 112* IBTRAN(1,*) -- indeces of T^A vectors 113* IBTRAN(2,*) -- indeces of T^B vectors 114* IBTRAN(3,*) -- indeces or addresses of result vectors 115* NBTRAN -- number of requested transformations 116* FILBMA -- file name / list type of result vectors 117* or list type of vectors to be dotted on 118* IBDOTS -- indeces of vectors to be dotted on 119* BCONS -- contains the dot products on return 120* 121* return of the result vectors: 122* 123* IOPTRES = 0 : all result vectors are written to a direct 124* access file, FILBMA is used as file name 125* the start addresses of the vectors are 126* returned in IBTRAN(3,*) 127* 128* IOPTRES = 1 : the vectors are kept and returned in WORK 129* if possible, start addresses returned in 130* IBTRAN(3,*). N.B.: if WORK is not large 131* enough IOPTRES is automatically reset to 0!! 132* 133* IOPTRES = 3 : each result vector is written to its own 134* file by a call to CC_WRRSP, FILBMA is used 135* as list type and IBTRAN(3,*) as list index 136* NOTE that IBTRAN(3,*) is in this case input! 137* 138* IOPTRES = 4 : each result vector is added to a vector on 139* file by a call to CC_WARSP, FILBMA is used 140* as list type and IBTRAN(3,*) as list index 141* NOTE that IBTRAN(3,*) is in this case input! 142* 143* IOPTRES = 5 : the result vectors are dotted on a array 144* of vectors, the type of the arrays given 145* by FILBMA and the indeces from IBDOTS 146* the result of the dot products is returned 147* in the BCONS array 148* 149* Written by Christof Haettig, Januar/Februar 1997. 150* BF terms rewritten in October 1998, Christof Haettig 151* CC3 noddy version, April 2002, Christof Haettig 152* 153*=====================================================================* 154 USE PELIB_INTERFACE, ONLY: USE_PELIB, PELIB_IFC_QRTRANSFORMER 155#if defined (IMPLICIT_NONE) 156 IMPLICIT NONE 157#else 158# include "implicit.h" 159#endif 160#include "priunit.h" 161#include "ccsdinp.h" 162#include "ccsdsym.h" 163#include "maxorb.h" 164#include "mxcent.h" 165#include "ccsdio.h" 166#include "ccorb.h" 167#include "cciccset.h" 168#include "cbieri.h" 169#include "distcl.h" 170#include "iratdef.h" 171#include "eritap.h" 172#include "ccisao.h" 173#include "ccfield.h" 174#include "aovec.h" 175#include "blocks.h" 176#include "second.h" 177#include "ccnoddy.h" 178#include "ccr1rsp.h" 179#include "r12int.h" 180#include "ccsections.h" 181#include "ccslvinf.h" 182#include "qm3.h" 183!#include "qmmm.h" 184 185* local parameters: 186 CHARACTER MSGDBG*(17) 187 PARAMETER (MSGDBG='[debug] CC_BMAT> ') 188 189 LOGICAL LOCDBG 190 PARAMETER (LOCDBG = .FALSE.) 191 192 LOGICAL APPEND, NOAPPEND 193 PARAMETER (APPEND = .TRUE., NOAPPEND = .FALSE.) 194 195 INTEGER KDUM, IDUM 196 PARAMETER( KDUM = +99 999 999 ) ! dummy address for work space 197 INTEGER ISYM0 198 PARAMETER( ISYM0 = 1 ) ! symmetry of the reference state 199 INTEGER ISYOVOV 200 PARAMETER( ISYOVOV = 1 ) ! symmetry of (ia|jb) integrals 201 202 INTEGER LUBF, LUBFD, LUC, LUD, LUF, LUFK, LUR 203 INTEGER LUAIBJ, LUCBAR, LUDBAR, LUBMAT 204 CHARACTER*(8) BFFIL, CBAFIL, DBAFIL, CTFIL, DTFIL, RFIL 205 CHARACTER*(8) FFIL, FKFIL, FNBFD, FNAIBJ 206 PARAMETER (BFFIL ='CCCR_BFI', FNBFD ='CCBFDENS', 207 & CBAFIL='CCCR_CBA', DBAFIL='CCCR_DBA', 208 & CTFIL ='CCCR_CIM', DTFIL ='CCCR_DIM', 209 & FFIL ='CCCR_FIM', FKFIL ='CCCR_FKI', 210 & FNAIBJ='CCB_AIBJ', RFIL ='CCCR_RIM') 211 212 213 CHARACTER*(1) RSPTYP 214 CHARACTER*(*) LISTA, LISTB, FILBMA 215 LOGICAL DO_O2 216 INTEGER IOPTRES 217 INTEGER NBTRAN, MXVEC, LWORK 218 INTEGER IBTRAN(3,NBTRAN) 219 INTEGER IBDOTS(MXVEC,NBTRAN) 220 221#if defined (SYS_CRAY) 222 REAL WORK(LWORK) 223 REAL ZERO, ONE, TWO, FREQ 224 REAL DUM, XNORM, FF, DUMMY 225 REAL BCONS(MXVEC,NBTRAN) 226#else 227 DOUBLE PRECISION WORK(LWORK) 228 DOUBLE PRECISION ZERO, ONE, TWO, FREQ 229 DOUBLE PRECISION DUM, XNORM, FF, DUMMY 230 DOUBLE PRECISION BCONS(MXVEC,NBTRAN) 231#endif 232 PARAMETER (ZERO = 0.0d0, ONE = 1.0d0, TWO = 2.0d0) 233 234 CHARACTER*(3) LIST, LIST2A, LIST2B 235 CHARACTER*(10) MODEL, MODELW, CDUMMY 236 INTEGER INDEXA(MXCORB_CC) 237 INTEGER INTMED1(2,2*MAXSIM), NINT1 238 INTEGER INTMEDA(2,MAXSIM), NINTA 239 INTEGER INTMED2(4,MAXSIM), NINT2 240 INTEGER I1HGH(0:MAXSIM), I2HGH(0:MAXSIM), NBATCH 241 INTEGER IOFFCD(0:MAXSIM+1) 242 INTEGER IADRD(MXCORB_CC,2*MAXSIM) ! big static array :-( 243 INTEGER IT2F(MXCORB_CC,2*MAXSIM) ! big static array :-( 244 INTEGER KLAMP(2*MAXSIM), KLAMH(2*MAXSIM), KDENS(2*MAXSIM) 245 INTEGER KFOCK(2*MAXSIM), KRHO2(2*MAXSIM), KRIM(2*MAXSIM) 246 INTEGER KFOCKOO(2*MAXSIM), KFOCKOV(2*MAXSIM), KFOCKVV(2*MAXSIM) 247 INTEGER KXBAR(2*MAXSIM), KYBAR(2*MAXSIM) 248 INTEGER KOMEGA2(MAXSIM) 249 INTEGER KLAMPA(MAXSIM),KLAMHA(MAXSIM) 250 INTEGER KLAMPB(MAXSIM),KLAMHB(MAXSIM) 251 252 LOGICAL NEWFTERM 253 PARAMETER (NEWFTERM = .TRUE.) 254 255 LOGICAL LGAMMA, LO3BF, OSQSAV, OORSAV 256 INTEGER ITRAN, ISYM, IDLST, IDLSTA, IDLSTB, IOPT, ICORE, ICON, IF 257 INTEGER ISYMA, ISYMB, ISYMAB, ISYMD1, NTOSYM, IDEL, ISYDEL 258 INTEGER IINT1, IINT2, ISYM1, ISYCDBAR, IDXA, ISYX4O, IOPTG 259 INTEGER IINT1A, IINT1B, IINTA, ICDEL2, NTOT, ILLL, NUMDIS 260 INTEGER IBATCH, IDEL2, IADRTH, IERR, IOFFCDB, IOPTB, IADRBFD 261 INTEGER MT2BGD, MDISAO, MDSRHF, KINDXB, KCCFB1, NVEC2 262 INTEGER MSCRATCH, MEMAVAIL, NNWORK, NWORK, NSECMAR 263 INTEGER KFOCK0, KDENS0, KT1AMP0, KLAMP0, KLAMH0, KEND0, LWRK0 264 INTEGER KEND, LWRK, KENDSV, LWRKSV, KFREE, LFREE, JEND1, KEND1 265 INTEGER KEND2, LWRK2, JEND2, KEND3, LWRK3, KEND4, LWRK4, LWRK1 266 INTEGER KODCL1, KODCL2, KODBC1, KODBC2, KRDBC1, KRDBC2 267 INTEGER KODPP1, KODPP2, KRDPP1, KRDPP2, KRECNR, KWRKSV 268 INTEGER KXINT, KDSRHF, KLIAJB, KFOCK0OO, KFOCK0OV, KFOCK0VV 269 INTEGER LEN, LENR, LENBF, LENF, LENFK, LENALL, IADRF, IVEC 270 INTEGER KXIAJB, KT2AMP0, KT2AMPA, KCDBAR, KTHETA0, KFCKC0 271 INTEGER KTHETA1, KTHETA2, KT1AMPA, KT1AMPB, KXLAMPA, KXLAMHA 272 INTEGER KFCKAOO, KFCKAVV, KFCKBOO, KFCKBVV, KDNSC0 273 INTEGER KFCKABOO, KFCKABOV, KFCKABVV, KXAIBJ, KBDRHF, KDCRHF 274 INTEGER KBF0, LUBF0, KCBAR0, KDBAR0, KX4O, KSCR, KSCR2, KSCR1 275 INTEGER KLAMDPB, KLAMDHB, KLAMDPA, KLAMDHA, IOPTW, IDUMMY 276 INTEGER NBSRHF(8), IBSRHF(8,8), ICOUNT, ISYMAK, ISYBET 277 INTEGER IOPTTCME, IOPTWE, KTHETA1EFF, KTHETA2EFF, KATRAN2 278 INTEGER IOPTWR12,LENMOD,KTHETAR12,KATRANR12,IAMP 279 CHARACTER APROXR12*3 280 281* external functions: 282 INTEGER ICCSET1 283 INTEGER ICCSET2 284 INTEGER ILSTSYM 285 REAL*8, ALLOCATABLE :: FOCKMAT(:), FOCKTEMP(:) 286 287#if defined (SYS_CRAY) 288 REAL DTIME, CONVRT, TIMALL, TIMTRN, TIMIO, TIMPRE 289 REAL TIMA, TIMBF, TIMF, TIME, TIMI, TIMC, TIMD, TIMIM0 290 REAL TIMINT, TIMRDAO, TIMTRBT, TIMIMA, TIMIMAB, TIMFCK 291 REAL DDOT, FREQLST 292#else 293 DOUBLE PRECISION DDOT, FREQLST 294 DOUBLE PRECISION DTIME, CONVRT, TIMALL, TIMTRN, TIMIO, TIMPRE 295 DOUBLE PRECISION TIMA,TIMBF,TIMF,TIME,TIMI,TIMC,TIMD,TIMIM0 296 DOUBLE PRECISION TIMINT, TIMRDAO, TIMTRBT, TIMIMA, TIMIMAB,TIMFCK 297#endif 298 299 CALL QENTER('CC_BMAT') 300 301*---------------------------------------------------------------------* 302* begin: 303*---------------------------------------------------------------------* 304 IF (LOCDBG) THEN 305 Call AROUND('ENTERED CC_BMAT') 306 IF (DIRECT) WRITE(LUPRI,'(/1X,A)') 'AO direct transformation' 307 WRITE (LUPRI,*) 'LISTA : ',LISTA 308 WRITE (LUPRI,*) 'LISTB : ',LISTB 309 WRITE (LUPRI,*) 'FILBMA: ',FILBMA 310 WRITE (LUPRI,*) 'NBTRAN: ',NBTRAN 311 WRITE (LUPRI,*) 'IOPTRES:',IOPTRES 312 CALL FLSHFO(LUPRI) 313 END IF 314 315 IF ( .not. (CCS .or. CC2 .or. CCSD .or. CC3) ) THEN 316 WRITE(LUPRI,'(/1x,a)') 'CC_BMAT called for a Coupled Cluster ' 317 & //'method not implemented in CC_BMAT...' 318 CALL QUIT('Unknown CC method in CC_BMAT.') 319 END IF 320 321 IF (LISTA(1:1).NE.'R' .OR. LISTB(1:1).NE.'R') THEN 322 WRITE(LUPRI,*) 'LISTA and LISTB must refer to t-amplitude', 323 & ' vectors in CC_BMAT.' 324 CALL QUIT('Illegal LISTA or LISTB in CC_BMAT.') 325 END IF 326 327 IF (.NOT. DUMPCD) THEN 328 WRITE(LUPRI,*) 'DUMPCD = ',DUMPCD 329 WRITE(LUPRI,*) 'CC_BMAT requires DUMPCD=.TRUE.' 330 CALL QUIT('DUMPCD=.FALSE. , CC_BMAT requires DUMPCD=.TRUE.') 331 END IF 332 333 IF (ISYMOP .NE. 1) THEN 334 WRITE(LUPRI,*) 'ISYMOP = ',ISYMOP 335 WRITE(LUPRI,*) 'CC_BMAT is not implemented for ISYMOP.NE.1' 336 CALL QUIT('CC_BMAT is not implemented for ISYMOP.NE.1') 337 END IF 338 339 IF (NBTRAN .GT. MAXSIM) THEN 340 WRITE(LUPRI,*) 'NBTRAN = ', NBTRAN 341 WRITE(LUPRI,*) 'MAXSIM = ', MAXSIM 342 WRITE(LUPRI,*) 'number of requested transformation is larger' 343 WRITE(LUPRI,*) 'than the maximum number of allowed ', 344 & 'simultaneous transformation.' 345 WRITE(LUPRI,*) 'Error in CC_BMAT: NBTRAN is larger than MAXSIM.' 346 CALL QUIT('Error in CC_BMAT: NBTRAN is larger than MAXSIM.') 347 END IF 348 349 IF (IPRINT.GT.0) THEN 350 351 WRITE (LUPRI,'(//1X,A1,50("="),A1)')'+','+' 352 353 WRITE (LUPRI,'(1x,A52)') 354 & '| B MATRIX TRANSFORMATION SECTION |' 355 356 IF (IOPTRES.EQ.3) THEN 357 WRITE (LUPRI,'(1X,A52)') 358 & '| (result is written to file) |' 359 ELSE IF (IOPTRES.EQ.4) THEN 360 WRITE (LUPRI,'(1X,A52)') 361 & '| (result is added to a vector on file) |' 362 ELSE IF (IOPTRES.EQ.5) THEN 363 WRITE (LUPRI,'(1X,A52)') 364 & '| (result used to calculate dot products) |' 365 END IF 366 367 WRITE (LUPRI,'(1X,A1,50("-"),A1)') '+','+' 368 369 END IF 370 371* initialize timings: 372 TIMALL = SECOND() 373 TIMIO = ZERO 374 TIMPRE = ZERO 375 TIMFCK = ZERO 376 TIMF = ZERO 377 TIMA = ZERO 378 TIMBF = ZERO 379 TIME = ZERO 380 TIMI = ZERO 381 TIMC = ZERO 382 TIMD = ZERO 383 TIMINT = ZERO 384 TIMRDAO = ZERO 385 TIMTRBT = ZERO 386 TIMIM0 = ZERO 387 TIMIMA = ZERO 388 TIMIMAB = ZERO 389 390* set option and model to write vectors to file: 391 IF (CCS) THEN 392 MODELW = 'CCS ' 393 IOPTW = 1 394 ELSE IF (CC2) THEN 395 MODELW = 'CC2 ' 396 IOPTW = 3 397 ELSE IF (CCSD) THEN 398 MODELW = 'CCSD ' 399 IOPTW = 3 400 ELSE IF (CC3) THEN 401 MODELW = 'CC3 ' 402 IOPTW = 3 403 IOPTWE = 24 404 ELSE 405 CALL QUIT('Unknown coupled cluster model in CC_BMAT.') 406 END IF 407 IF (CCR12) THEN 408 APROXR12 = ' ' 409 CALL CCSD_MODEL(MODELW,LENMOD,10,MODELW,10,APROXR12) 410 IOPTWR12 = 32 411 END IF 412 413* check return option for the result vectors: 414 LUBMAT = -1 415 IF (IOPTRES .EQ. 0 .OR. IOPTRES .EQ. 1) THEN 416 CALL WOPEN2(LUBMAT, FILBMA, 64, 0) 417 ELSE IF (IOPTRES .EQ. 3 .OR. IOPTRES .EQ. 4) THEN 418 CONTINUE 419 ELSE IF (IOPTRES .EQ. 5) THEN 420 IF (MXVEC*NBTRAN.NE.0) CALL DZERO(BCONS,MXVEC*NBTRAN) 421 ELSE 422 CALL QUIT('Illegal value of IOPTRES in CC_BMAT.') 423 END IF 424 425* precalculate symmetry array for BSRHF: 426 DO ISYM = 1, NSYM 427 ICOUNT = 0 428 DO ISYMAK = 1, NSYM 429 ISYBET = MULD2H(ISYMAK,ISYM) 430 IBSRHF(ISYMAK,ISYBET) = ICOUNT 431 ICOUNT = ICOUNT + NT1AO(ISYMAK)*NBAS(ISYBET) 432 END DO 433 NBSRHF(ISYM) = ICOUNT 434 END DO 435 436*=====================================================================* 437* build nonredundant arrays of response vectors and pairs of them 438* for which intermediates have to be calculated 439*=====================================================================* 440 DTIME = SECOND() 441 442* array for intermediates that depend on one response vector 443 NINT1 = 0 444 DO ITRAN = 1, NBTRAN 445 I=ICCSET1(INTMED1,LISTA,IBTRAN(1,ITRAN),NINT1,2*MAXSIM,APPEND) 446 I=ICCSET1(INTMED1,LISTB,IBTRAN(2,ITRAN),NINT1,2*MAXSIM,APPEND) 447 END DO 448 449* array for intermediates that are only required for the A vectors: 450 NINTA = 0 451 DO ITRAN = 1, NBTRAN 452 I=ICCSET1(INTMEDA,LISTA,IBTRAN(1,ITRAN),NINTA,MAXSIM,APPEND) 453 END DO 454 455* array for intermediates that depend on two response vectors 456 NINT2 = 0 457 DO ITRAN = 1, NBTRAN 458 I=ICCSET2(INTMED2,LISTA,IBTRAN(1,ITRAN), 459 & LISTB,IBTRAN(2,ITRAN),NINT2,MAXSIM,APPEND) 460 END DO 461 462 463 IF (LOCDBG) THEN 464 WRITE (LUPRI,'(/A)')'List of response vector for '// 465 & 'AO intermediates:' 466 WRITE (LUPRI,'((/5X,2I5))') ((INTMED1(I,J),I=1,2),J=1,NINT1) 467 WRITE (LUPRI,'(/A)') 'List of response vector for '// 468 & 'MO intermediates:' 469 WRITE (LUPRI,'((/5X,2I5))') ((INTMEDA(I,J),I=1,2),J=1,NINTA) 470 WRITE (LUPRI,'(/A)') 'List of vector pairs for '// 471 & 'AO F intermediates:' 472 WRITE (LUPRI,'((/5X,4I5))') ((INTMED2(I,J),I=1,4),J=1,NINT2) 473 END IF 474 475 TIMPRE = TIMPRE + SECOND() - DTIME 476*---------------------------------------------------------------------* 477* estimate scratch space requirements 478*---------------------------------------------------------------------* 479 DTIME = SECOND() 480 481 MT2BGD = 0 482 MDISAO = 0 483 MDSRHF = 0 484 DO ISYM = 1, NSYM 485 MT2BGD = MAX(MT2BGD,NT2BGD(ISYM)) 486 MDISAO = MAX(MDISAO,NDISAO(ISYM)) 487 MDSRHF = MAX(MDSRHF,NDSRHF(ISYM)) 488 END DO 489 490* 5 x a NT2BGD type intermediate 491* + integral arrays + some reserve 492 493 MSCRATCH = 5*MT2BGD + MDISAO + 10*N2BASX 494 IF (CCSD.OR.CCSDT) MSCRATCH = MAX(MSCRATCH,MDISAO+5*MDSRHF) 495 496 IF (LOCDBG) THEN 497 WRITE (LUPRI,*) 'CC_BMAT> scratch space estimate MSCRATCH:', 498 & MSCRATCH 499 CALL FLSHFO(LUPRI) 500 END IF 501 502 TIMPRE = TIMPRE + SECOND() - DTIME 503*---------------------------------------------------------------------* 504* estimate memory for 'in core' version and batched versions: 505*---------------------------------------------------------------------* 506 DTIME = SECOND() 507 508 MEMAVAIL = LWORK - MSCRATCH 509 510 NWORK = 0 511 NBATCH = 1 512 IF (CCS) THEN 513 NSECMAR = 10 * N2BASX 514 ELSE IF (CC2 .OR. CCSD .OR. CCSDT) THEN 515 NSECMAR = 10 * MT2BGD 516 ELSE 517 CALL QUIT('Unknown CC model in CC_BMAT.') 518 END IF 519 520 I1HGH(0) = 0 521 I2HGH(0) = 0 522 523* intermediates that dependent on one response vector: 524* (see routine ccbpre1 for details) 525 DO IINT1 = 1, NINT1 526 LIST = VTABLE(INTMED1(2,IINT1)) 527 IDLST = INTMED1(1,IINT1) 528 ISYM = ILSTSYM(LIST,IDLST) 529 530 NNWORK = 2*NGLMDT(ISYM) + 2*N2BST(ISYM) 531 IF (CCSD.OR.CCSDT) THEN 532 NNWORK = 2*NGLMDT(ISYM)+NT2AOIJ(ISYM)+NEMAT1(ISYM) 533 END IF 534 535 IF( (NWORK+NNWORK+NSECMAR).GT.MEMAVAIL ) THEN 536 I1HGH(NBATCH) = IINT1 - 1 537 I2HGH(NBATCH) = 0 538 539 NBATCH = NBATCH + 1 540 NWORK = 0 541 END IF 542 NWORK = NWORK + NNWORK 543 IF (NWORK .GT. LWORK) THEN 544 WRITE (LUPRI,*) 'Insufficient work space in CC_BMAT. (01)' 545 WRITE (LUPRI,*) 'Need at least:',NNWORK, ' words.' 546 CALL FLSHFO(LUPRI) 547 CALL QUIT('Insufficient work space in CC_BMAT. (01)') 548 END IF 549 END DO 550 551* intermediates that dependent on two response vectors: 552* (see routine ccbpre2 for details) 553 DO IINT2 = 1, NINT2 554 LIST2A = VTABLE(INTMED2(2,IINT2)) 555 LIST2B = VTABLE(INTMED2(4,IINT2)) 556 IDLSTA = INTMED2(1,IINT2) 557 IDLSTB = INTMED2(3,IINT2) 558 ISYMA = ILSTSYM(LIST2A,IDLSTA) 559 ISYMB = ILSTSYM(LIST2B,IDLSTB) 560 ISYMAB = MULD2H(ISYMA,ISYMB) 561 562 IF (CCS) THEN 563 NNWORK = 0 564 ELSE IF (CC2) THEN 565 NNWORK = NT2AM(ISYMAB) + 2*NGLMDT(ISYMA) + 2*NGLMDT(ISYMB) 566 ELSE IF (CCSD.OR.CCSDT) THEN 567 NNWORK = 2*NGLMDT(ISYMA) + 2*NGLMDT(ISYMB) 568 ELSE 569 CALL QUIT('Unknown CC model in CC_BMAT.') 570 END IF 571 572 IF( (NWORK+NNWORK+NSECMAR).GT.MEMAVAIL ) THEN 573 I1HGH(NBATCH) = NINT1 574 I2HGH(NBATCH) = IINT2 - 1 575 576 NBATCH = NBATCH + 1 577 NWORK = 0 578 END IF 579 NWORK = NWORK + NNWORK 580 IF (NWORK .GT. LWORK) THEN 581 WRITE (LUPRI,*) 'Insufficient work space in CC_BMAT. (02)' 582 WRITE (LUPRI,*) 'Need at least:',NNWORK,' words.' 583 CALL FLSHFO(LUPRI) 584 CALL QUIT('Insufficient work space in CC_BMAT. (02)') 585 END IF 586 END DO 587 588 I1HGH(NBATCH) = NINT1 589 I2HGH(NBATCH) = NINT2 590 591 IF (LOCDBG .AND. (NBATCH.EQ.1)) THEN 592 WRITE (LUPRI,*) 'CC_BMAT> one batch only... '// 593 & 'will be done in core.' 594 WRITE (LUPRI,*) 'CC_BMAT> memory for intermediates: ', NWORK 595 WRITE (LUPRI,*) 'CC_BMAT> remaining scratch space: ',LWORK-NWORK 596 CALL FLSHFO(LUPRI) 597 ELSE IF (LOCDBG .AND. (NBATCH.GT.1)) THEN 598 WRITE (LUPRI,*) 'CC_BMAT> more than one batch... '// 599 & 'choose I/O algorithm.' 600 WRITE (LUPRI,*) 'CC_BMAT> max. memory for intermediates: ', 601 & MEMAVAIL 602 WRITE (LUPRI,*) 'CC_BMAT> number of batches: ',NBATCH 603 CALL FLSHFO(LUPRI) 604 END IF 605 606 TIMPRE = TIMPRE + SECOND() - DTIME 607*---------------------------------------------------------------------* 608* read zeroth-order singles amplitudes, allocate space for Fock matrix, 609* and prepare zeroth-order lambda matrices and density: 610*---------------------------------------------------------------------* 611 DTIME = SECOND() 612 613 KFOCK0 = 1 614 KFOCK0OO = KFOCK0 + N2BAST 615 KFOCK0OV = KFOCK0OO + NMATIJ(ISYM0) 616 KFOCK0VV = KFOCK0OV + NT1AMX 617 KDENS0 = KFOCK0VV + NMATAB(ISYM0) 618 KT1AMP0 = KDENS0 + N2BAST 619 KLAMP0 = KT1AMP0 + NT1AMX 620 KLAMH0 = KLAMP0 + NLAMDT 621 KEND0 = KLAMH0 + NLAMDT 622 623 IF (FROIMP.OR.FROEXP) THEN 624 KFCKC0 = KEND0 625 KDNSC0 = KFCKC0 + N2BAST 626 KEND0 = KDNSC0 + N2BAST 627 ELSE 628 KFCKC0 = KDUM 629 KDNSC0 = KDUM 630 END IF 631 632 LWRK0 = LWORK - KEND0 633 IF (LWRK0 .LT. 0) THEN 634 CALL QUIT('Insufficient work space in CC_BMAT. (0)') 635 END IF 636 637* read zeroth order amplitudes: 638 IOPT = 1 639 Call CC_RDRSP('R0',0,1,IOPT,MODEL,WORK(KT1AMP0),WORK(KDUM)) 640 641* get unperturbed Lambda matrices: 642 Call LAMMAT(WORK(KLAMP0),WORK(KLAMH0),WORK(KT1AMP0), 643 & WORK(KEND0),LWRK0) 644 645* calculate the density matrix: 646 ICORE = 1 647 CALL CC_AODENS(WORK(KLAMP0),WORK(KLAMH0),WORK(KDENS0), 648 & ISYM0,ICORE, WORK(KEND0),LWRK0) 649 650* calculate pure core contribution to the density matrix, 651* and initialize core contribution to Fock matrix with zeros 652 IF (FROIMP.OR.FROEXP) THEN 653 ICORE = 0 ! exclude core contribution 654 CALL CC_AODENS(WORK(KLAMP0),WORK(KLAMH0),WORK(KDNSC0), 655 & ISYM0,ICORE, WORK(KEND0),LWRK0) 656 CALL DSCAL(N2BAST,-ONE,WORK(KDNSC0),1) 657 CALL DAXPY(N2BAST,+ONE,WORK(KDENS0),1,WORK(KDNSC0),1) 658 CALL DZERO(WORK(KFCKC0),N2BAST) 659 END IF 660 661* initialize Fock matrix with the one-electron integrals: 662 CALL CCRHS_ONEAO(WORK(KFOCK0),WORK(KEND0),LWRK0) 663 DO IF= 1, NFIELD 664 FF = EFIELD(IF) 665 CALL CC_ONEP(WORK(KFOCK0),WORK(KEND0),LWRK0,FF,1,LFIELD(IF) ) 666 END DO 667C 668C------------------------------------------------------------------------ 669C CCMM, 03 JK+OC 670C Solvent/QMMM contribution to one-electron integrals. 671C T^g contribution to transformation. 672C------------------------------------------------------------------------ 673C 674 IF (CCSLV) THEN 675 IF (.NOT.CCMM) CALL CCSL_RHSTG(WORK(KFOCK0),WORK(KEND0),LWRK0) 676 IF (CCMM) THEN 677 IF (.NOT. NYQMMM) THEN 678 CALL CCMM_RHSTG(WORK(KFOCK0),WORK(KEND0),LWRK0) 679 ELSE IF (NYQMMM) THEN 680 IF (HFFLD) THEN 681 WRITE(LUPRI,*) 'Is it justified to do B transformation ' 682 & //'with a HFFLD?' 683 CALL QUIT('HFFLD not implemented for QR') 684 ELSE 685 CALL CCMM_ADDG(WORK(KFOCK0),WORK(KEND0),LWRK0) 686 END IF 687 END IF 688 ENDIF 689 ENDIF 690 IF (USE_PELIB()) THEN 691 IF (HFFLD) THEN 692 CALL QUIT('HFFLD not implemented for QR') 693 ELSE 694 ALLOCATE(FOCKMAT(NNBASX),FOCKTEMP(N2BAST)) 695 CALL GET_FROM_FILE('FOCKMAT',NNBASX,FOCKMAT) 696 CALL DSPTSI(NBAS,FOCKMAT,FOCKTEMP) 697 CALL DAXPY(N2BAST,1.0d0,FOCKTEMP,1,WORK(KFOCK0),1) 698 DEALLOCATE(FOCKMAT,FOCKTEMP) 699 END IF 700 END IF 701C 702C 703C------------------------------------------------------------------------ 704C 705 IF (LOCDBG) THEN 706 WRITE (LUPRI,*) 'norm of T1AMP0:', 707 & DDOT(NT1AMX,WORK(KT1AMP0),1,WORK(KT1AMP0),1) 708 WRITE (LUPRI,*) 'norm of XLAMP0:', 709 & DDOT(NLAMDT,WORK(KLAMP0),1,WORK(KLAMP0),1) 710 WRITE (LUPRI,*) 'norm of XLAMH0:', 711 & DDOT(NLAMDT,WORK(KLAMH0),1,WORK(KLAMH0),1) 712 WRITE (LUPRI,*) 'norm of DENS0:', 713 & DDOT(N2BAST,WORK(KDENS0),1,WORK(KDENS0),1) 714 WRITE (LUPRI,*) 'norm of FOCK0:', 715 & DDOT(N2BAST,WORK(KFOCK0),1,WORK(KFOCK0),1) 716 END IF 717 718 TIMPRE = TIMPRE + SECOND() - DTIME 719 TIMIM0 = TIMIM0 + SECOND() - DTIME 720*---------------------------------------------------------------------* 721* open files for BF, C, D, F and Fock matrix intermediates: 722*---------------------------------------------------------------------* 723 DTIME = SECOND() 724 725 CALL CCBOPEN(LUBF,LUCBAR,LUDBAR,LUC,LUD,LUF,LUFK,LUR, 726 & BFFIL,CBAFIL,DBAFIL,CTFIL,DTFIL,FFIL,FKFIL,RFIL, 727 & LENBF, LENF, LENFK, LENR, 728 & NINT1, NINT2, WORK(KEND0), LWRK0 ) 729 730* open file for effective densities in BF term: 731 LUBFD = -1 732 LUAIBJ = -1 733 IF (.NOT.(CCS.OR.CC2)) CALL WOPEN2(LUBFD, FNBFD, 64, 0) 734 IF (.NOT.CCS) CALL WOPEN2(LUAIBJ, FNAIBJ, 64, 0) 735 736* initialize offsets for C & D intermediates: 737 ICDEL2 = 0 738 739* initialize offset for F term integrals: 740 IADRF = 1 741 742 TIMPRE = TIMPRE + SECOND() - DTIME 743 744*---------------------------------------------------------------------* 745* precalculate effective densities for BF intermediates: 746*---------------------------------------------------------------------* 747 DTIME = SECOND() 748 749 IADRBFD = 1 750 751 IF (.NOT. (CCS .OR. CC2)) THEN 752 DO IINT1 = 1, NINT1 753 LIST = VTABLE(INTMED1(2,IINT1)) 754 IDLST = INTMED1(1,IINT1) 755 ISYMA = ILSTSYM(LIST,IDLST) 756 757 KT1AMPA = KEND0 758 KT2AMPA = KT1AMPA + NT1AM(ISYMA) 759 KXLAMHA = KT2AMPA + NT2SQ(ISYMA) 760 KXLAMPA = KXLAMHA + NGLMDT(ISYMA) 761 KEND1 = KXLAMPA + NGLMDT(ISYMA) 762 LWRK1 = LWORK - KEND1 763 764 IF (LWRK1 .LT. NT2AM(ISYMA)) THEN 765 CALL QUIT('Insufficient work space in CC_BMAT.(CCBFDEN)') 766 END IF 767 768C ------------------------------------------------------ 769C read response amplitudes, scale and square T2 part 770C ------------------------------------------------------ 771 IOPT = 3 772 CALL CC_RDRSP(LIST,IDLST,ISYMA,IOPT,MODEL, 773 * WORK(KT1AMPA),WORK(KEND1)) 774 CALL CCLR_DIASCL(WORK(KEND1),TWO,ISYMA) 775 CALL CC_T2SQ(WORK(KEND1),WORK(KT2AMPA),ISYMA) 776 777C ------------------------------------------------------ 778C calculate response lambda matrices: 779C ------------------------------------------------------ 780 CALL CCLR_LAMTRA(WORK(KLAMP0),WORK(KXLAMPA), 781 * WORK(KLAMH0),WORK(KXLAMHA), 782 * WORK(KT1AMPA),ISYMA) 783 784C --------------------------------------------------------- 785C calculate effective density for BF term and store on disk 786C --------------------------------------------------------- 787 IOPT = 3 788 CALL CC_BFDEN(WORK(KT2AMPA),ISYMA, DUMMY, IDUMMY, 789 * WORK(KLAMH0), ISYM0, WORK(KLAMH0),ISYM0, 790 * WORK(KXLAMHA),ISYMA, DUMMY, IDUMMY, 791 * FNBFD, LUBFD,IADRD, IADRBFD, 792 * IINT1, IOPT, .FALSE., WORK(KEND1),LWRK1) 793 794 END DO 795 796 END IF 797 798 TIMBF = TIMBF + SECOND() - DTIME 799 TIMIMA = TIMIMA + SECOND() - DTIME 800 801*---------------------------------------------------------------------* 802* if all vectors and intermediates fit into the memory, read all 803* response vectors before the loop over AO integral shells: 804*---------------------------------------------------------------------* 805 DTIME = SECOND() 806 807 IF (NBATCH .EQ. 1) THEN 808 809 CALL CCBPRE1(INTMED1, 1, NINT1, 810 & KRHO2, KLAMP, KLAMH, KDENS, KFOCK, KRIM, 811 & LUBF,BFFIL,LENBF,LUFK,FKFIL,LENFK, 812 & LUR,RFIL,LENR, 813 & WORK(KLAMP0), WORK(KLAMH0), 814 & WORK, LWORK, KEND0, JEND1 ) 815 KEND1 = JEND1 816 817 CALL CCBPRE2(INTMED2,1,NINT2,LUF,FFIL,LENF, 818 & KOMEGA2,KLAMPA,KLAMHA,KLAMPB,KLAMHB, 819 & WORK(KLAMP0),WORK(KLAMH0), 820 & WORK, LWORK, KEND1, JEND1 ) 821 KEND1 = JEND1 822 823 IF (LOCDBG) THEN 824 WRITE (LUPRI,*) 'CC_BMAT> allocated work '// 825 & 'space for intermediates:' 826 WRITE (LUPRI,*) 'CC_BMAT> KRHO2 :',(KRHO2(I),I=1,NINT1) 827 WRITE (LUPRI,*) 'CC_BMAT> KLAMP :',(KLAMP(I),I=1,NINT1) 828 WRITE (LUPRI,*) 'CC_BMAT> KLAMH :',(KLAMH(I),I=1,NINT1) 829 WRITE (LUPRI,*) 'CC_BMAT> KDENS :',(KDENS(I),I=1,NINT1) 830 WRITE (LUPRI,*) 'CC_BMAT> KFOCK :',(KFOCK(I),I=1,NINT1) 831 WRITE (LUPRI,*) 'CC_BMAT> KOMEGA2:',(KOMEGA2(I),I=1,NINT2) 832 WRITE (LUPRI,*) 'CC_BMAT> KLAMPA:',(KLAMPA(I),I=1,NINT2) 833 WRITE (LUPRI,*) 'CC_BMAT> KLAMHA:',(KLAMHA(I),I=1,NINT2) 834 WRITE (LUPRI,*) 'CC_BMAT> KLAMPB:',(KLAMPB(I),I=1,NINT2) 835 WRITE (LUPRI,*) 'CC_BMAT> KLAMHB:',(KLAMHB(I),I=1,NINT2) 836 WRITE (LUPRI,*) 'CC_BMAT> KEND1:',KEND1 837 CALL FLSHFO(LUPRI) 838 END IF 839 840 ELSE 841 KEND1 = KEND0 842 END IF 843 844 LWRK1 = LWORK - KEND1 845 IF (LWRK1 .LT. 0) THEN 846 CALL QUIT('Insufficient work space in CC_BMAT. (1)') 847 END IF 848 849 TIMPRE = TIMPRE + SECOND() - DTIME 850*---------------------------------------------------------------------* 851* initialize integral calculation 852*---------------------------------------------------------------------* 853 DTIME = SECOND() 854 855 KEND = KEND1 856 LWRK = LWRK1 857 858 IF (DIRECT) THEN 859 NTOSYM = 1 860 861 IF (HERDIR) THEN 862 CALL HERDI1(WORK(KEND),LWRK,IPRERI) 863 ELSE 864 KCCFB1 = KEND 865 KINDXB = KCCFB1 + MXPRIM*MXCONT 866 KEND = KINDXB + (8*MXSHEL*MXCONT + 1)/IRAT 867 LWRK = LWORK - KEND 868 CALL ERIDI1(KODCL1,KODCL2,KODBC1,KODBC2,KRDBC1,KRDBC2, 869 * KODPP1,KODPP2,KRDPP1,KRDPP2, 870 * KFREE,LFREE,KEND,WORK(KCCFB1),WORK(KINDXB), 871 * WORK(KEND),LWRK,IPRERI) 872 873 KEND = KFREE 874 LWRK = LFREE 875 END IF 876 877 KENDSV = KEND 878 LWRKSV = LWRK 879 ELSE 880 NTOSYM = NSYM 881 END IF 882 883 TIMINT = TIMINT + SECOND() - DTIME 884*---------------------------------------------------------------------* 885* start loop over AO integrals shells: 886*---------------------------------------------------------------------* 887 DO ISYMD1 = 1, NTOSYM 888 889 IF (DIRECT) THEN 890 IF (HERDIR) THEN 891 NTOT = MAXSHL 892 ELSE 893 NTOT = MXCALL 894 ENDIF 895 ELSE 896 NTOT = NBAS(ISYMD1) 897 END IF 898 899 DO ILLL = 1, NTOT 900 901 DTIME = SECOND() 902 903 IF (DIRECT) THEN 904 KEND = KENDSV 905 LWRK = LWRKSV 906C 907 IF (HERDIR) THEN 908 CALL HERDI2(WORK(KEND),LWRK,INDEXA,ILLL,NUMDIS, 909 & IPRINT) 910 ELSE 911 CALL ERIDI2(ILLL,INDEXA,NUMDIS,0,0, 912 * WORK(KODCL1),WORK(KODCL2), 913 * WORK(KODBC1),WORK(KODBC2), 914 * WORK(KRDBC1),WORK(KRDBC2), 915 * WORK(KODPP1),WORK(KODPP2), 916 * WORK(KRDPP1),WORK(KRDPP2), 917 * WORK(KCCFB1),WORK(KINDXB), 918 * WORK(KEND), LWRK,IPRERI) 919 END IF 920C 921 KRECNR = KEND 922 KEND = KRECNR + (NBUFX(0) - 1)/IRAT + 1 923 LWRK = LWORK - KEND 924 925 IF (LWRK .LT. 0) THEN 926 CALL QUIT('Insufficient work space in CC_BMAT. (1a)') 927 END IF 928 929 ELSE 930 NUMDIS = 1 931 END IF 932 933 TIMINT = TIMINT + SECOND() - DTIME 934*---------------------------------------------------------------------* 935* if out of core: allocate memory and get response vectors: 936*---------------------------------------------------------------------* 937 DO IBATCH = 1, NBATCH 938 KEND2 = KEND ! reset memory for each batch 939 940 IF (LOCDBG) THEN 941 WRITE (LUPRI,*) MSGDBG, 942 & IBATCH,'-th. batch out of ',NBATCH 943 WRITE (LUPRI,*) MSGDBG, 'I1:',I1HGH(IBATCH-1)+1,' -- ', 944 & I1HGH(IBATCH) 945 WRITE (LUPRI,*) MSGDBG, 'I2:',I2HGH(IBATCH-1)+1,' -- ', 946 & I2HGH(IBATCH) 947 END IF 948 949 IF (NBATCH.GT.1) THEN 950 951 DTIME = SECOND() 952 953 CALL CCBPRE1(INTMED1,I1HGH(IBATCH-1)+1,I1HGH(IBATCH), 954 & KRHO2, KLAMP, KLAMH, KDENS, KFOCK, KRIM, 955 & LUBF,BFFIL,LENBF,LUFK,FKFIL,LENFK, 956 & LUR,RFIL,LENR, 957 & WORK(KLAMP0), WORK(KLAMH0), 958 & WORK, LWORK, KEND2, JEND2 ) 959 KEND2 = JEND2 960 961 CALL CCBPRE2(INTMED2,I2HGH(IBATCH-1)+1,I2HGH(IBATCH), 962 & LUF,FFIL,LENF, 963 & KOMEGA2,KLAMPA,KLAMHA,KLAMPB,KLAMHB, 964 & WORK(KLAMP0),WORK(KLAMH0), 965 & WORK, LWORK, KEND2, JEND2 ) 966 KEND2 = JEND2 967 968 TIMPRE = TIMPRE + SECOND() - DTIME 969 970 END IF 971 972 LWRK2 = LWORK - KEND2 973 IF (LWRK2 .LT. 0) THEN 974 CALL QUIT('Insufficient work space in CC_BMAT. (2)') 975 END IF 976 977*---------------------------------------------------------------------* 978* loop over number of distributions on the disk: 979*---------------------------------------------------------------------* 980 DO IDEL2 = 1, NUMDIS 981 982 IF (DIRECT) THEN 983 IDEL = INDEXA(IDEL2) 984 IF (NOAUXB) THEN 985 IDUM = 1 986 CALL IJKAUX(IDEL,IDUM,IDUM,IDUM) 987 END IF 988 ISYDEL = ISAO(IDEL) 989 ELSE 990 IDEL = IBAS(ISYMD1) + ILLL 991 ISYDEL = ISYMD1 992 END IF 993 994* read AO integral distribution and calculate integrals with 995* one index transformed to occupied MO (particle): 996 997 KXINT = KEND2 998 KEND3 = KXINT + NDISAO(ISYDEL) 999 1000 IF (CCSD.OR.CCSDT) THEN 1001 KBDRHF = KEND3 1002 KDCRHF = KBDRHF + NBSRHF(ISYDEL) 1003 KDSRHF = KDCRHF + NBSRHF(ISYDEL) 1004 KEND3 = KDSRHF + NDSRHF(ISYDEL) 1005 END IF 1006 1007 LWRK3 = LWORK - KEND3 1008 IF (LWRK3 .LT. 0) THEN 1009 CALL QUIT('Insufficient work space in CC_BMAT. (3)') 1010 END IF 1011 1012 DTIME = SECOND() 1013 CALL CCRDAO(WORK(KXINT),IDEL,IDEL2,WORK(KEND3),LWRK3, 1014 & WORK(KRECNR),DIRECT) 1015 TIMRDAO = TIMRDAO + SECOND() - DTIME 1016 1017 IF (CCSD.OR.CCSDT) THEN 1018 1019 DTIME = SECOND() 1020 1021 CALL CCTRBT(WORK(KXINT),WORK(KDSRHF),WORK(KLAMP0),ISYM0, 1022 & WORK(KEND3),LWRK3,ISYDEL) 1023 1024 CALL CC_BFBSORT(WORK(KDSRHF),WORK(KBDRHF),ISYDEL) 1025 1026 CALL CCB_CDSORT(WORK(KXINT),ISYDEL,WORK(KDCRHF), 1027 * WORK(KLAMP0),ISYM0,WORK(KEND3),LWRK3) 1028 1029 TIMTRBT = TIMTRBT + SECOND() - DTIME 1030 TIMIM0 = TIMIM0 + SECOND() - DTIME 1031 1032 KEND3 = KDSRHF 1033 LWRK3 = LWORK - KEND3 1034 1035 END IF 1036 1037* calculate zeroth-order Fock matrix (Fhat) 1038 IF (IBATCH .EQ. 1) THEN 1039 DTIME = SECOND() 1040 1041 CALL CC_AOFOCK(WORK(KXINT), WORK(KDENS0), 1042 * WORK(KFOCK0),WORK(KEND3), 1043 * LWRK3,IDEL,ISYDEL,.FALSE.,DUMMY,ISYM0) 1044 1045 IF (FROIMP.OR.FROEXP) THEN 1046 CALL CC_AOFOCK(WORK(KXINT), WORK(KDNSC0), 1047 * WORK(KFCKC0),WORK(KEND3), 1048 * LWRK3,IDEL,ISYDEL,.FALSE.,DUMMY,ISYM0) 1049 END IF 1050 1051 TIMFCK = TIMFCK + SECOND() - DTIME 1052 TIMIM0 = TIMIM0 + SECOND() - DTIME 1053 END IF 1054 1055* calculate intermediates that depend on one response vector: 1056 1057 DO IINT1 = I1HGH(IBATCH-1)+1, I1HGH(IBATCH) 1058 LIST = VTABLE(INTMED1(2,IINT1)) 1059 IDLST = INTMED1(1,IINT1) 1060 ISYM1 = ILSTSYM(LIST,IDLST) 1061 1062* calculate addresses for C & D intermediates: 1063 IT2DLR(IDEL,IINT1) = ICDEL2 1064 ICDEL2 = ICDEL2 + NT2BCD(MULD2H(ISYDEL,ISYM1)) 1065 1066 DTIME = SECOND() 1067 CALL CCBINT1(WORK(KXINT), WORK(KBDRHF), WORK(KDCRHF), 1068 & IDEL, ISYDEL, WORK(KRHO2(IINT1)), 1069 & WORK(KLAMP0), WORK(KLAMH0), 1070 & WORK(KLAMP(IINT1)), WORK(KLAMH(IINT1)), 1071 & ISYM1, IINT1, 1072 & WORK(KDENS(IINT1)), WORK(KFOCK(IINT1)), 1073 & WORK(KRIM(IINT1)), 1074 & LUC, CTFIL, LUD, DTFIL, 1075 & LUBFD, FNBFD, IADRD(1,IINT1), 1076 & WORK(KEND3), LWRK3, 1077 & TIMFCK, TIMBF, TIMC, TIMD ) 1078 TIMIMA = TIMIMA + SECOND() - DTIME 1079 1080 1081 IF (LOCDBG) THEN 1082 WRITE (LUPRI,'(2A,3i5)') 1083 & ' CC_BMAT> returned form CCBINT1 for', 1084 & ' IDEL,ISYDEL,IINT1=',IDEL,ISYDEL,IINT1 1085 IF (.NOT.(CCS.OR.CC2)) THEN 1086 XNORM = DDOT(NT2AOIJ(ISYM1),WORK(KRHO2(IINT1)),1, 1087 & WORK(KRHO2(IINT1)),1) 1088 WRITE (LUPRI,*) 'CC_BMAT> norm of BF int.:',XNORM 1089 END IF 1090 IF (.NOT.(CCSD.OR.CCSDT)) THEN 1091 XNORM = DDOT(N2BST(ISYM1),WORK(KFOCK(IINT1)),1, 1092 & WORK(KFOCK(IINT1)),1) 1093 WRITE (LUPRI,*) 'CC_BMAT> norm of FOCK int.:',XNORM 1094 END IF 1095 CALL FLSHFO(LUPRI) 1096 END IF 1097 1098 END DO 1099 1100 1101* calculate A & B vector dependend intermediates: 1102 1103 DO IINT2 = I2HGH(IBATCH-1)+1, I2HGH(IBATCH) 1104 LIST2A = VTABLE(INTMED2(2,IINT2)) 1105 LIST2B = VTABLE(INTMED2(4,IINT2)) 1106 IDLSTA = INTMED2(1,IINT2) 1107 IDLSTB = INTMED2(3,IINT2) 1108 ISYMA = ILSTSYM(LIST2A,IDLSTA) 1109 ISYMB = ILSTSYM(LIST2B,IDLSTB) 1110 ISYMAB = MULD2H(ISYMA,ISYMB) 1111 1112 DTIME = SECOND() 1113 CALL CCBINT2(WORK(KXINT), IDEL, ISYDEL, 1114 & WORK(KOMEGA2(IINT2)), ISYMAB, 1115 & LUAIBJ, FNAIBJ, IT2F(1,IINT2), IADRF, NEWFTERM, 1116 & WORK(KLAMPA(IINT2)),WORK(KLAMHA(IINT2)),ISYMA, 1117 & WORK(KLAMPB(IINT2)),WORK(KLAMHB(IINT2)),ISYMB, 1118 & WORK(KLAMP0), WORK(KLAMH0), 1119 & WORK(KEND3), LWRK3 ) 1120 TIMF = TIMF + SECOND() - DTIME 1121 TIMIMAB = TIMIMAB + SECOND() - DTIME 1122 1123 IF (LOCDBG) THEN 1124 WRITE (LUPRI,*) 1125 & 'CC_BMAT> returned form CCBINT2 for IDEL,', 1126 & 'ISYDEL,IINT2=',IDEL,ISYDEL,IINT2 1127 IF (CC2) THEN 1128 XNORM = DDOT(NT2AM(ISYMAB),WORK(KOMEGA2(IINT2)),1, 1129 & WORK(KOMEGA2(IINT2)),1) 1130 WRITE (LUPRI,*) 'CC_BMAT> norm of F int.:',XNORM 1131 END IF 1132 CALL FLSHFO(LUPRI) 1133 END IF 1134 1135 END DO 1136 1137 END DO ! IDEL2 1138*---------------------------------------------------------------------* 1139* end of the loop over integral distributions: 1140* if batched I/O algorithm used, save result on disc: 1141*---------------------------------------------------------------------* 1142 IF (NBATCH.GT.1) THEN 1143 DTIME = SECOND() 1144 CALL CCBSAVE(IBATCH, I1HGH, I2HGH, INTMED1, INTMED2, 1145 & KRHO2, LUBF, BFFIL, LENBF, 1146 & KOMEGA2, LUF, FFIL, LENF, 1147 & KFOCK, LUFK, FKFIL, LENFK, 1148 & KRIM, LUR, RFIL, LENR, 1149 & NINT1, NINT2, WORK, LWORK ) 1150 TIMIO = TIMIO + SECOND() - DTIME 1151 END IF 1152 1153 1154 END DO ! IBATCH 1155 END DO ! ILLL 1156 END DO ! ISYMD1 1157*=====================================================================* 1158* End of Loop over AO-integrals 1159*=====================================================================* 1160 1161*---------------------------------------------------------------------* 1162* if in-core algorithm used, save results now on disc: 1163*---------------------------------------------------------------------* 1164 IF (NBATCH.EQ.1) THEN 1165 DTIME = SECOND() 1166 CALL CCBSAVE(1, I1HGH, I2HGH, INTMED1, INTMED2, 1167 & KRHO2, LUBF, BFFIL, LENBF, 1168 & KOMEGA2, LUF, FFIL, LENF, 1169 & KFOCK, LUFK, FKFIL, LENFK, 1170 & KRIM, LUR, RFIL, LENR, 1171 & NINT1, NINT2, WORK, LWORK ) 1172 TIMIO = TIMIO + SECOND() - DTIME 1173 END IF 1174 1175*---------------------------------------------------------------------* 1176* recover workspace: 1177*---------------------------------------------------------------------* 1178 KEND1 = KEND0 1179 LWRK1 = LWRK0 1180 1181 1182 IF (LOCDBG) THEN 1183 WRITE (LUPRI,*) 'Loop over AO-integrals completed ', 1184 & ' & AO intermediates saved on file.' 1185 WRITE (LUPRI,*) 'recover work space: KEND1,LWRK1=',KEND1,LWRK1 1186 WRITE (LUPRI,*) 'norm of XLAMH0:', 1187 & DDOT(NLAMDT,WORK(KLAMH0),1,WORK(KLAMH0),1) 1188 CALL FLSHFO(LUPRI) 1189 END IF 1190 1191*=====================================================================* 1192* calculate CBAR and DBAR intermediates: 1193*=====================================================================* 1194 IF (.NOT. (CCS .OR. CC2)) THEN 1195 1196* initialize offset: 1197 IOFFCD(0) = 0 1198 1199* set KCDBAR to a dummy address: 1200 KCDBAR = KDUM 1201 1202* read (ia|jb) and square them: 1203 KXIAJB = KEND1 1204 KEND2 = KXIAJB + NT2SQ(ISYOVOV) 1205 LWRK2 = LWORK - KEND2 1206 1207 IF (LWRK2 .LT. NT2AM(ISYOVOV)) THEN 1208 CALL QUIT('Insufficient work space in CC_BMAT. (4)') 1209 END IF 1210 1211 DTIME = SECOND() 1212 1213 Call CCG_RDIAJB (WORK(KEND2),NT2AM(ISYOVOV)) 1214 1215 Call CC_T2SQ (WORK(KEND2), WORK(KXIAJB), ISYOVOV) 1216 1217 TIMIO = TIMIO + SECOND() - DTIME 1218 1219*----------------------------- 1220* zeroth order intermediates: 1221*----------------------------- 1222 ISYCDBAR = MULD2H(ISYM0,ISYOVOV) 1223 1224* read vector: 1225 KT2AMP0 = KEND2 1226 KEND3 = KT2AMP0 + NT2AM(ISYM0) 1227 LWRK3 = LWORK - KEND3 1228 1229 IF (LWRK3 .LT. 0) THEN 1230 CALL QUIT('Insufficient work space in CC_BMAT. (5)') 1231 END IF 1232 1233 IOPT = 2 1234 DTIME = SECOND() 1235 CALL CC_RDRSP('R0',0,ISYM0,IOPT,MODEL,WORK(KDUM),WORK(KT2AMP0)) 1236 TIMIO = TIMIO + SECOND() - DTIME 1237 1238* CBAR intermediate: 1239 IOPT = 2 1240 DTIME = SECOND() 1241 CALL CCB_CDBAR('C', WORK(KXIAJB),ISYOVOV, WORK(KT2AMP0),ISYM0, 1242 & WORK(KCDBAR),ISYCDBAR, WORK(KEND3),LWRK3, 1243 & CBAFIL, LUCBAR, IOFFCD(0), IOPT) 1244 TIMC = TIMC + SECOND() - DTIME 1245 TIMIM0 = TIMIM0 + SECOND() - DTIME 1246 1247* DBAR intermediate: 1248 IOPT = 2 1249 DTIME = SECOND() 1250 CALL CCB_CDBAR('D', WORK(KXIAJB),ISYOVOV, WORK(KT2AMP0),ISYM0, 1251 & WORK(KCDBAR),ISYCDBAR, WORK(KEND3),LWRK3, 1252 & DBAFIL, LUDBAR, IOFFCD(0), IOPT) 1253 TIMD = TIMD + SECOND() - DTIME 1254 TIMIM0 = TIMIM0 + SECOND() - DTIME 1255 1256* increment offset: 1257 IOFFCD(1) = IOFFCD(0) + NT2SQ(ISYCDBAR) 1258 1259 1260*--------------------------------------------- 1261* calculate intermediates for all A responses: 1262*--------------------------------------------- 1263 DO IDXA = 1, NINTA 1264 IDLSTA = INTMEDA(1,IDXA) 1265 ISYMA = ILSTSYM(LISTA,IDLSTA) 1266 ISYCDBAR = MULD2H(ISYMA,ISYOVOV) 1267 1268* read vector: 1269 KT2AMPA = KEND2 1270 KEND3 = KT2AMPA + NT2AM(ISYMA) 1271 LWRK3 = LWORK - KEND3 1272 1273 IF (LWRK3 .LT. 0) THEN 1274 CALL QUIT('Insufficient work space in CC_BMAT. (6)') 1275 END IF 1276 1277 DTIME = SECOND() 1278 1279 IOPT = 2 1280 CALL CC_RDRSP(LISTA,IDLSTA,ISYMA,IOPT,MODEL, 1281 & WORK(KDUM),WORK(KT2AMPA) ) 1282 CALL CCLR_DIASCL(WORK(KT2AMPA),TWO,ISYMA) 1283 1284 TIMIO = TIMIO + SECOND() - DTIME 1285 1286* CBAR intermediate: 1287 IF (LOCDBG) WRITE (LUPRI,*) 'CBAR', IDXA, ':' 1288 IOPT = 2 1289 DTIME = SECOND() 1290 CALL CCB_CDBAR('C', WORK(KXIAJB),ISYOVOV, WORK(KT2AMPA),ISYMA, 1291 & WORK(KCDBAR),ISYCDBAR, WORK(KEND3),LWRK3, 1292 & CBAFIL, LUCBAR, IOFFCD(IDXA), IOPT) 1293 TIMC = TIMC + SECOND() - DTIME 1294 TIMIMA = TIMIMA + SECOND() - DTIME 1295 1296* DBAR intermediate: 1297 IF (LOCDBG) WRITE (LUPRI,*) 'DBAR', IDXA, ':' 1298 IOPT = 2 1299 DTIME = SECOND() 1300 CALL CCB_CDBAR('D', WORK(KXIAJB),ISYOVOV, WORK(KT2AMPA),ISYMA, 1301 & WORK(KCDBAR),ISYCDBAR, WORK(KEND3),LWRK3, 1302 & DBAFIL, LUDBAR, IOFFCD(IDXA), IOPT) 1303 TIMD = TIMD + SECOND() - DTIME 1304 TIMIMA = TIMIMA + SECOND() - DTIME 1305 1306* increment offset: 1307 IOFFCD(IDXA+1) = IOFFCD(IDXA) + NT2SQ(ISYCDBAR) 1308 1309 END DO 1310 1311 IF (LOCDBG) THEN 1312 WRITE (LUPRI,*) 'all CBAR & DBAR intermediates calculated...' 1313 CALL FLSHFO(LUPRI) 1314 END IF 1315 1316 1317* correct response BF^A/B intermediates for CCSD(R12) and higher: 1318 1319 IF (CCR12) THEN 1320 DO IINT1 = 1, NINT1 1321 IDLST = INTMED1(1,IINT1) 1322 LIST = VTABLE(INTMED1(2,IINT1)) 1323 ISYM = ILSTSYM(LIST,IDLST) 1324 1325 !allocate scratch memory 1326 KSCR1 = KEND1 1327 KEND2 = KSCR1 + NT2AO(ISYM) 1328 LWRK2 = LWORK - KEND2 1329 IF (LWRK2 .LE. 0) THEN 1330 CALL QUIT('Insufficient work space in CC_BMAT.') 1331 END IF 1332 1333 CALL DZERO(WORK(KSCR1),NT2AO(ISYM)) 1334 1335 !calculate contribution: 1336 IOPT = 1 1337 IAMP = 2 1338 CALL CCRHS_BP(WORK(KSCR1),ISYM,IOPT,IAMP,DUMMY,IDUMMY, 1339 & IDUMMY,LIST,IDLST,KETSCL,WORK(KEND2),LWRK2) 1340 1341 !read in response BF intermediate 1342 KSCR2 = KEND2 1343 KEND2 = KSCR2 + NT2AOIJ(ISYM) 1344 LWRK2 = LWORK - KEND2 1345 IF (LWRK2 .LE. 0) THEN 1346 CALL QUIT('Insufficient work space in CC_BMAT.') 1347 END IF 1348 DTIME = SECOND() 1349 CALL CC_RVEC(LUBF,BFFIL,LENBF,NT2AOIJ(ISYM),IINT1,WORK(KSCR2)) 1350 TIMIO = TIMIO + SECOND() - DTIME 1351 1352 !transform beta index to occupied and add on BF intermediate: 1353 OSQSAV = OMEGSQ 1354 OORSAV = OMEGOR 1355 OMEGSQ = .FALSE. 1356 OMEGOR = .FALSE. 1357 ICON = 4 1358 CALL CC_T2MO(DUMMY,DUMMY,1,WORK(KSCR1),DUMMY,WORK(KSCR2), 1359 & WORK(KLAMP0),WORK(KLAMP0),1,WORK(KEND2),LWRK2, 1360 & ISYM,ICON) 1361 OMEGSQ = OSQSAV 1362 OMEGOR = OORSAV 1363 1364 !write out response BF intermediate 1365 DTIME = SECOND() 1366 CALL CC_WVEC(LUBF,BFFIL,LENBF,NT2AOIJ(ISYM),IINT1, 1367 & WORK(KSCR2)) 1368 TIMIO = TIMIO + SECOND() - DTIME 1369 1370 END DO 1371 END IF ! (CCR12) 1372 1373 END IF ! (.NOT. (CCS .OR. CC2)) 1374 1375*=====================================================================* 1376* transform zeroth-order Fock matrix to the MO representation: 1377*=====================================================================* 1378 DTIME = SECOND() 1379 CALL CC_FCKMO(WORK(KFOCK0),WORK(KLAMP0),WORK(KLAMH0), 1380 & WORK(KEND1),LWRK1,ISYM0,ISYM0,ISYM0) 1381 1382 CALL CC_GATHEROO(WORK(KFOCK0),WORK(KFOCK0OO),ISYM0) 1383 CALL CC_GATHEROV(WORK(KFOCK0),WORK(KFOCK0OV),ISYM0) 1384 CALL CC_GATHERVV(WORK(KFOCK0),WORK(KFOCK0VV),ISYM0) 1385 1386 TIMFCK = TIMFCK + SECOND() - DTIME 1387 TIMIM0 = TIMIM0 + SECOND() - DTIME 1388*=====================================================================* 1389* transform the response Fock^{*} matrices to MO representation 1390* and calculate the XBAR and YBAR intermediates: 1391*=====================================================================* 1392* read (ia|jb) integrals, calculate L(ia|jb) in place and square up: 1393* (stored and the upper end of the work space, 1394* to keep the lower end free for intermediates) 1395 KLIAJB = LWORK - NT2SQ(ISYOVOV) 1396 LFREE = KLIAJB-1 1397 1398 LWRK1 = LWORK - KEND1 1399 IF ( LWRK1 .LT. (NT2AM(ISYOVOV)+NT2SQ(ISYOVOV)) ) THEN 1400 CALL QUIT('Insufficient work space in CC_BMAT. (6c)') 1401 END IF 1402 1403 DTIME = SECOND() 1404 1405 CALL CCG_RDIAJB(WORK(KEND1), NT2AM(ISYOVOV)) 1406 1407 IOPTTCME = 1 1408 CALL CCSD_TCMEPK(WORK(KEND1),ONE,ISYOVOV,IOPTTCME) 1409 1410 CALL CC_T2SQ(WORK(KEND1), WORK(KLIAJB), ISYOVOV) 1411 1412 TIMIO = TIMIO + SECOND() - DTIME 1413 1414 1415 DTIME = SECOND() 1416 1417 DO IINT1 = 1, NINT1 1418 LIST = VTABLE(INTMED1(2,IINT1)) 1419 IDLST = INTMED1(1,IINT1) 1420 ISYM = ILSTSYM(LIST,IDLST) 1421 CALL CCBINT3(LIST, IDLST, 1422 & LUFK, FKFIL, LENFK, IINT1, KFOCK(IINT1), 1423 & KFOCKOO(IINT1), KFOCKOV(IINT1), KFOCKVV(IINT1), 1424 & KXBAR(IINT1), KYBAR(IINT1), 1425 & WORK(KLIAJB), ISYOVOV, 1426 & WORK(KLAMP0), WORK(KLAMH0), 1427 & WORK, LFREE, KEND1, JEND1, 1428 & TIMFCK,TIMIO,TIME) 1429 KEND1 = JEND1 1430 END DO 1431 1432 TIMIMA = TIMIMA + SECOND() - DTIME 1433 1434 1435 LWRK1 = LWORK - KEND1 1436 IF (LWRK1 .LE. 0) THEN 1437 CALL QUIT('Insufficient work space in CC_BMAT. (7)') 1438 END IF 1439 1440 IF (LOCDBG) THEN 1441 WRITE (LUPRI,*) 'all FOCK intermediates transformed '// 1442 & 'to MO basis...' 1443 CALL FLSHFO(LUPRI) 1444 END IF 1445 1446 IF (IPRINT.GT.0) THEN 1447 1448 WRITE (LUPRI,'(1X,A,F10.2,A)') 1449 & '| time for zero order intermediat.:',TIMIM0 ,' secs.|' 1450 WRITE (LUPRI,'(1X,A,I3,A,F10.2,A)') 1451 & '| time for',NINT1,' sets of 1. ord. int.:',TIMIMA ,' secs.|' 1452 WRITE (LUPRI,'(1X,A,I3,A,F10.2,A)') 1453 & '| time for',NINT2,' sets of 2. ord. int.:',TIMIMAB,' secs.|' 1454 WRITE (LUPRI,'(1X,A,I3,A)') 1455 & '| intermediates calculated in ',NBATCH,' batches |' 1456 1457 WRITE (LUPRI,'(1X,A1,50("-"),A1)') '+','+' 1458 1459 IF (IOPTRES.EQ.5) THEN 1460 WRITE (LUPRI,'(1X,A)') 1461 & '| R vector | R vector | # products | |' 1462 WRITE (LUPRI,'(1X,3(A,A3),A)') '| ',LISTA(1:3), ' No. | ', 1463 & LISTB(1:3),' No. | with ', FILBMA(1:3), 1464 & ' | time/secs |' 1465 ELSE 1466 WRITE (LUPRI,'(1X,A)') 1467 & '| R vector | R vector | result | |' 1468 WRITE (LUPRI,'(1X,A2,A3,2(A,A3),A)') '| ',LISTA(1:3), 1469 & ' No. | ', LISTB(1:3),' No. | ', FILBMA(1:3), 1470 & ' No. | time/secs |' 1471 END IF 1472 1473 WRITE (LUPRI,'(1X,A1,50("-"),A1)') '+','+' 1474 END IF 1475 1476*=====================================================================* 1477* calculate B matrix transformations: 1478*=====================================================================* 1479 IADRTH = 1 1480 DO ITRAN = 1, NBTRAN 1481 1482 IDLSTA = IBTRAN(1,ITRAN) 1483 IDLSTB = IBTRAN(2,ITRAN) 1484 1485 ISYMA = ILSTSYM(LISTA,IDLSTA) 1486 ISYMB = ILSTSYM(LISTB,IDLSTB) 1487 ISYMAB = MULD2H(ISYMA,ISYMB) 1488 1489 IINT1A = ICCSET1(INTMED1,LISTA,IDLSTA,NINT1,2*MAXSIM,NOAPPEND) 1490 IINT1B = ICCSET1(INTMED1,LISTB,IDLSTB,NINT1,2*MAXSIM,NOAPPEND) 1491 IINTA = ICCSET1(INTMEDA,LISTA,IDLSTA,NINTA,MAXSIM,NOAPPEND) 1492 IINT2 = ICCSET2(INTMED2,LISTA,IDLSTA, 1493 & LISTB,IDLSTB,NINT2,MAXSIM,NOAPPEND) 1494 1495 TIMTRN = SECOND() 1496 1497*---------------------------------------------------------------------* 1498* allocate work space for the result vector: 1499*---------------------------------------------------------------------* 1500 IF (CCS) THEN 1501 KTHETA1 = KEND1 1502 KTHETA2 = KDUM 1503 KEND2 = KTHETA1 + NT1AM(ISYMAB) 1504 ELSE 1505 KTHETA1 = KEND1 1506 KTHETA2 = KTHETA1 + NT1AM(ISYMAB) 1507 KEND2 = KTHETA2 + NT2AM(ISYMAB) 1508 IF (CCR12) THEN 1509 KTHETAR12 = KTHETA2 + NT2AM(ISYMAB) 1510 KEND2 = KTHETAR12 + NTR12AM(ISYMAB) 1511 END IF 1512 END IF 1513 1514 IF (LOCDBG) THEN 1515 WRITE (LUPRI,*) 'B matrix transformation for ITRAN,',ITRAN 1516 WRITE (LUPRI,*) 'IADRTH:',IADRTH 1517 WRITE (LUPRI,*) 'LISTA,IDLSTA:',LISTA,IDLSTA 1518 WRITE (LUPRI,*) 'LISTB,IDLSTB:',LISTB,IDLSTB 1519 WRITE (LUPRI,*) 'ISYMA,ISYMB,ISYMAB:',ISYMA,ISYMB,ISYMAB 1520 WRITE (LUPRI,*) 'IINT1A,IINT1B,IINTA,IINT2:',IINT1A,IINT1B, 1521 & IINTA,IINT2 1522 CALL FLSHFO(LUPRI) 1523 END IF 1524 1525*---------------------------------------------------------------------* 1526* read the single excitation part of the response vectors and 1527* calculate the response Lambda matrices: 1528*---------------------------------------------------------------------* 1529 DTIME = SECOND() 1530 1531 KT1AMPA = KEND2 1532 KT1AMPB = KT1AMPA + NT1AM(ISYMA) 1533 KLAMDPB = KT1AMPB + NT1AM(ISYMB) 1534 KLAMDHB = KLAMDPB + NGLMDT(ISYMB) 1535 KLAMDPA = KLAMDHB + NGLMDT(ISYMB) 1536 KLAMDHA = KLAMDPA + NGLMDT(ISYMA) 1537 KEND2 = KLAMDHA + NGLMDT(ISYMA) 1538 LWRK2 = LWORK - KEND2 1539 1540 IF (LWRK2 .LE. 0) THEN 1541 CALL QUIT('Insufficient work space in CC_BMAT. (8)') 1542 END IF 1543 1544 IOPT = 1 1545 1546 CALL CC_RDRSP(LISTA,IDLSTA,ISYMA,IOPT,MODEL, 1547 & WORK(KT1AMPA),WORK(KDUM)) 1548 1549 CALL CC_RDRSP(LISTB,IDLSTB,ISYMB,IOPT,MODEL, 1550 & WORK(KT1AMPB),WORK(KDUM)) 1551 1552 CALL CCLR_LAMTRA(WORK(KLAMP0),WORK(KLAMDPA), WORK(KLAMH0), 1553 & WORK(KLAMDHA),WORK(KT1AMPA),ISYMA) 1554 1555 CALL CCLR_LAMTRA(WORK(KLAMP0),WORK(KLAMDPB), WORK(KLAMH0), 1556 & WORK(KLAMDHB),WORK(KT1AMPB),ISYMB) 1557 1558 TIMPRE = TIMPRE + SECOND() - DTIME 1559*---------------------------------------------------------------------* 1560* calculate Ftilde^{A} = [Fhat, T1^A] + Ftilde^{A,*} and Ftilde^{B} 1561*---------------------------------------------------------------------* 1562 DTIME = SECOND() 1563 1564 KFCKAOO = KEND2 1565 KFCKAVV = KFCKAOO + NMATIJ(ISYMA) 1566 KFCKBOO = KFCKAVV + NMATAB(ISYMA) 1567 KFCKBVV = KFCKBOO + NMATIJ(ISYMB) 1568 KEND2 = KFCKBVV + NMATAB(ISYMB) 1569 LWRK2 = LWORK - KEND2 1570 1571 IF (LWRK2 .LE. 0) THEN 1572 CALL QUIT('Insufficient work space in CC_BMAT. (9)') 1573 END IF 1574 1575 IF (.NOT.(CCSD.OR.CCSDT)) THEN 1576 1577* Ftilde^{A}, occupied/occupied blocks: 1578 CALL CCG_1ITROO(WORK(KFCKAOO),ISYMA, 1579 & WORK(KFOCK0OV), ISYM0, WORK(KT1AMPA),ISYMA ) 1580 1581 CALL DAXPY(NMATIJ(ISYMA), ONE, 1582 & WORK(KFOCKOO(IINT1A)),1, WORK(KFCKAOO), 1) 1583 1584* Ftilde^{B}, occupied/occupied blocks: 1585 CALL CCG_1ITROO(WORK(KFCKBOO),ISYMB, 1586 & WORK(KFOCK0OV), ISYM0, WORK(KT1AMPB),ISYMB ) 1587 1588 CALL DAXPY(NMATIJ(ISYMB), ONE, 1589 & WORK(KFOCKOO(IINT1B)),1, WORK(KFCKBOO), 1) 1590 1591* Ftilde^{A}, virtual/virtual blocks: 1592 CALL CCG_1ITRVV(WORK(KFCKAVV),ISYMA, 1593 & WORK(KFOCK0OV), ISYM0, WORK(KT1AMPA),ISYMA ) 1594 1595 CALL DAXPY(NMATAB(ISYMA), ONE, 1596 & WORK(KFOCKVV(IINT1A)),1, WORK(KFCKAVV), 1) 1597 1598* Ftilde^{B}, virtual/virtual blocks: 1599 CALL CCG_1ITRVV(WORK(KFCKBVV),ISYMB, 1600 & WORK(KFOCK0OV), ISYM0, WORK(KT1AMPB),ISYMB ) 1601 1602 CALL DAXPY(NMATAB(ISYMB), ONE, 1603 & WORK(KFOCKVV(IINT1B)),1, WORK(KFCKBVV), 1) 1604 1605 IF (LOCDBG) THEN 1606 XNORM=DDOT(NMATIJ(ISYMA),WORK(KFCKAOO),1,WORK(KFCKAOO),1) 1607 WRITE (LUPRI,*) 'Norm of FCKAOO:',XNORM 1608 XNORM=DDOT(NMATAB(ISYMA),WORK(KFCKAVV),1,WORK(KFCKAVV),1) 1609 WRITE (LUPRI,*) 'Norm of FCKAVV:',XNORM 1610 XNORM=DDOT(NMATIJ(ISYMB),WORK(KFCKBOO),1,WORK(KFCKBOO),1) 1611 WRITE (LUPRI,*) 'Norm of FCKBOO:',XNORM 1612 XNORM=DDOT(NMATAB(ISYMB),WORK(KFCKBVV),1,WORK(KFCKBVV),1) 1613 WRITE (LUPRI,*) 'Norm of FCKBVV:',XNORM 1614 CALL FLSHFO(LUPRI) 1615 END IF 1616 1617 END IF 1618 1619 TIMFCK = TIMFCK + SECOND() - DTIME 1620*---------------------------------------------------------------------* 1621* initialize the singles part of the result vector THETA: 1622*---------------------------------------------------------------------* 1623 CALL DZERO(WORK(KTHETA1),NT1AM(ISYMAB)) 1624 1625*---------------------------------------------------------------------* 1626* contributions which do not require any double amplitudes: 1627*---------------------------------------------------------------------* 1628 1629*------------------------------------------------------------ 1630* F contribution: transform (a i~|delta j~) integrals to MO 1631* for CC2 add here also remaining part of the F contribution: 1632*------------------------------------------------------------ 1633 DTIME = SECOND() 1634 1635 IF (CCSTST.AND.(.NOT.CCS)) CALL DZERO(WORK(KTHETA2),NT2AM(ISYMAB)) 1636 1637 IF ( CCSD .OR. CCSDT) THEN 1638 1639 KXAIBJ = KEND2 1640 KEND3 = KXAIBJ + NT2SQ(ISYMAB) 1641 LWRK3 = LWORK - KEND3 1642 1643 IF (LWRK3 .LE. 0) THEN 1644 CALL QUIT('Insufficient work space in CC_BMAT. (CC_IAJB2)') 1645 END IF 1646 1647 CALL DZERO(WORK(KXAIBJ),NT2SQ(ISYMAB)) 1648 1649 IOPT = 1 1650 CALL CC_IAJB2(WORK(KXAIBJ),ISYMAB,IOPT,.FALSE.,.FALSE.,.FALSE., 1651 & LUAIBJ,FNAIBJ,IT2F(1,IINT2),WORK(KLAMP0),ISYM0, 1652 & IDUMMY,CDUMMY,IDUMMY,DUMMY,IDUMMY, 1653 & WORK(KEND3),LWRK3) 1654 1655 IOPT = 1 1656 CALL CC_T2PK(WORK(KTHETA2),WORK(KXAIBJ),ISYMAB,IOPT) 1657 1658 ELSE IF ( .NOT. (CCS .OR. CCSTST) ) THEN 1659 1660 LEN = NT2AM(ISYMAB) 1661 CALL CC_RVEC(LUF,FFIL,LENF,LEN,IINT2,WORK(KTHETA2)) 1662 1663 END IF 1664 1665 IF ( LOCDBG .AND. .NOT.(CCS.OR.CCSTST) ) THEN 1666 WRITE (LUPRI,*) 'read F contribution from file:' 1667 XNORM=DDOT(NT2AM(ISYMAB),WORK(KTHETA2),1,WORK(KTHETA2),1) 1668 WRITE (LUPRI,*) 'Norm of THETA2 after F contribution:',XNORM 1669 CALL CC_PRP(WORK(KTHETA1),WORK(KTHETA2),ISYMAB,1,1) 1670 CALL FLSHFO(LUPRI) 1671 END IF 1672 1673 TIMF = TIMF + SECOND() - DTIME 1674*--------------------------------------- 1675* BF contribution, LAM^A x LAM^B x BF^0: 1676*--------------------------------------- 1677 IF (.NOT. (CCS .OR. CC2 .OR. CCSTST) ) THEN 1678 1679 KBF0 = KEND2 1680 KEND3 = KBF0 + 2*NT2ORT(ISYM0) 1681 LWRK3 = LWORK - KEND3 1682 1683 IF (LWRK3 .LE. 0) THEN 1684 CALL QUIT('Insufficient work space in CC_BMAT. (12)') 1685 END IF 1686 1687* read zeroth-order BF intermediate: 1688 LUBF0 = -1 1689 DTIME = SECOND() 1690 CALL GPOPEN(LUBF0,'CC_BFIM','OLD',' ','UNFORMATTED',KDUM, 1691 & .FALSE.) 1692 READ(LUBF0) (WORK(KBF0-1+I),I=1,2*NT2ORT(1)) 1693 CALL GPCLOSE(LUBF0,'KEEP') 1694 TIMIO = TIMIO + SECOND() - DTIME 1695 1696* transform to MO representation using two response Lambda matrices: 1697* (skip the calculation of the Gamma intermediate) 1698 ICON = 2 1699 IOPTG = 0 1700 LGAMMA = .FALSE. 1701 LO3BF = .FALSE. 1702 DTIME = SECOND() 1703 CALL CC_T2MO3(DUM,DUM,1,WORK(KBF0), 1704 * WORK(KTHETA2),DUM,DUM,DUM, 1705 * WORK(KLAMDPA),ISYMA,WORK(KLAMDPB),ISYMB, 1706 * WORK(KEND3),LWRK3,ISYM0,ICON, 1707 * LGAMMA,IOPTG,LO3BF,.FALSE.) 1708 TIMBF = TIMBF + SECOND() - DTIME 1709 1710 IF (LOCDBG) THEN 1711 XNORM=DDOT(2*NT2ORT(ISYM0),WORK(KBF0),1,WORK(KBF0),1) 1712 WRITE (LUPRI,*) 'read BF(0) intermediate from file, norm is:', 1713 & XNORM 1714 XNORM=DDOT(NT2AM(ISYMAB),WORK(KTHETA2),1,WORK(KTHETA2),1) 1715 WRITE (LUPRI,*) 'Norm of THETA2 after BF contribution:',XNORM 1716 CALL FLSHFO(LUPRI) 1717 END IF 1718 1719 END IF 1720 1721*--------------------------------------- 1722* C contribution, CBAR^0 x T1^A x T1^B: 1723*--------------------------------------- 1724 IF (.NOT. (CCS .OR. CC2 .OR. CCSTST )) THEN 1725 KCBAR0 = KEND2 1726 KEND3 = KCBAR0 + NT2SQ(ISYM0) 1727 LWRK3 = LWORK - KEND3 1728 1729 IF (LWRK3 .LE. 0) THEN 1730 CALL QUIT('Insufficient work space in CC_BMAT. (13)') 1731 END IF 1732 1733 DTIME = SECOND() 1734 1735* read in CBAR^0 intermediate: 1736 CALL GETWA2(LUCBAR,CBAFIL,WORK(KCBAR0),IOFFCD(0)+1,NT2SQ(ISYM0)) 1737 1738 TIMIO = TIMIO + SECOND() - DTIME 1739 1740 IF (LOCDBG) THEN 1741 XNORM=DDOT(NT2SQ(ISYM0),WORK(KCBAR0),1,WORK(KCBAR0),1) 1742 WRITE (LUPRI,*) 'read CBAR0 intermediate from file, norm is:', 1743 & XNORM 1744 CALL FLSHFO(LUPRI) 1745 END IF 1746 1747 1748 DTIME = SECOND() 1749 CALL CCB_22CD(WORK(KTHETA2),ISYMAB,WORK(KCBAR0),ISYM0, 1750 & WORK(KT1AMPA),ISYMA, WORK(KT1AMPB),ISYMB, 1751 & 'C', WORK(KEND3),LWRK3) 1752 TIMC = TIMC + SECOND() - DTIME 1753 1754 IF (LOCDBG) THEN 1755 XNORM=DDOT(NT2AM(ISYMAB),WORK(KTHETA2),1,WORK(KTHETA2),1) 1756 WRITE (LUPRI,*) 'Norm of THETA2 after C contribution:',XNORM 1757 END IF 1758 1759 END IF 1760 1761*--------------------------------------- 1762* D contribution, DBAR^0 x T1^A x T1^B: 1763*--------------------------------------- 1764 IF (.NOT. (CCS .OR. CC2 .OR. CCSTST) ) THEN 1765 KDBAR0 = KEND2 1766 KEND3 = KDBAR0 + NT2SQ(ISYM0) 1767 LWRK3 = LWORK - KEND3 1768 1769 IF (LWRK3 .LE. 0) THEN 1770 CALL QUIT('Insufficient work space in CC_BMAT. (14)') 1771 END IF 1772 1773 DTIME = SECOND() 1774 1775* read in CBAR^0 intermediate: 1776 CALL GETWA2(LUDBAR,DBAFIL,WORK(KDBAR0),IOFFCD(0)+1,NT2SQ(ISYM0)) 1777 1778 TIMIO = TIMIO + SECOND() - DTIME 1779 1780 DTIME = SECOND() 1781 CALL CCB_22CD(WORK(KTHETA2),ISYMAB,WORK(KDBAR0),ISYM0, 1782 & WORK(KT1AMPA),ISYMA, WORK(KT1AMPB),ISYMB, 1783 & 'D', WORK(KEND3),LWRK3) 1784 TIMD = TIMD + SECOND() - DTIME 1785 1786 IF (LOCDBG) THEN 1787 XNORM=DDOT(NT2SQ(ISYM0),WORK(KDBAR0),1,WORK(KDBAR0),1) 1788 WRITE (LUPRI,*) 'read DBAR0 intermediate from file, norm is:', 1789 & XNORM 1790 XNORM=DDOT(NT2AM(ISYMAB),WORK(KTHETA2),1,WORK(KTHETA2),1) 1791 WRITE (LUPRI,*) 'Norm of THETA2 after D contribution:',XNORM 1792 CALL FLSHFO(LUPRI) 1793 END IF 1794 1795 END IF 1796 1797 1798*---------------------------------------------------------------------* 1799* CCSD contributions that require the zeroth order double amplitudes: 1800*---------------------------------------------------------------------* 1801 IF (.NOT. (CCS .OR. CC2) ) THEN 1802 KT2AMP0 = KEND2 1803 KEND3 = KT2AMP0 + NT2SQ(ISYM0) 1804 LWRK3 = LWORK - KEND3 1805 1806 IF (LWRK3 .LT. NT2AM(ISYM0)) THEN 1807 CALL QUIT('Insufficient work space in CC_BMAT. (15)') 1808 END IF 1809 1810 IOPT = 2 1811 DTIME = SECOND() 1812 CALL CC_RDRSP('R0',0,ISYM0,IOPT,MODEL,WORK(KDUM),WORK(KEND3)) 1813 1814 CALL CC_T2SQ(WORK(KEND3),WORK(KT2AMP0),ISYM0) 1815 TIMIO = TIMIO + SECOND() - DTIME 1816 1817 END IF 1818 1819*---------------------------------- 1820* A contribution, T^0 x (ki|lj)^AB: 1821*---------------------------------- 1822 IF (.NOT. (CCS .OR. CC2 .OR. CCSTST) ) THEN 1823 1824 ISYX4O = MULD2H(ISYOVOV,ISYMAB) 1825 IF (MULD2H(ISYX4O,ISYM0).NE.ISYMAB) THEN 1826 CALL QUIT('Symmetry mismatch in CC_BMAT, A term '// 1827 & 'T^0 x (ki|lj)^AB.') 1828 END IF 1829 1830 KXIAJB = KEND3 1831 KX4O = KXIAJB + NT2AM(ISYOVOV) 1832 KEND4 = KX4O + NGAMMA(ISYX4O) 1833 LWRK4 = LWORK - KEND4 1834 1835 IF (LWRK4 .LE. 0) THEN 1836 CALL QUIT('Insufficient work space in CC_BMAT. (16)') 1837 END IF 1838 1839* read (ia|jb) integrals: 1840 DTIME = SECOND() 1841 Call CCG_RDIAJB (WORK(KXIAJB),NT2AM(ISYOVOV)) 1842 TIMIO = TIMIO + SECOND() - DTIME 1843 1844* calculate double one-index transformed (ik|jl) integrals: 1845 DTIME = SECOND() 1846 1847 IOPT = 1 1848 CALL CCG_4O(WORK(KX4O),ISYX4O,WORK(KXIAJB),ISYOVOV, 1849 & WORK(KT1AMPA),ISYMA,WORK(KT1AMPB),ISYMB, 1850 & WORK(KEND4),LWRK4,IOPT) 1851 1852* calculate the contribution to THETA2: 1853 IOPT = 1 1854 CALL CCRHS_A(WORK(KTHETA2),WORK(KT2AMP0),WORK(KX4O), 1855 & WORK(KEND4),LWRK4,ISYX4O,ISYM0,IOPT) 1856 1857 TIMA = TIMA + SECOND() - DTIME 1858 1859 IF (LOCDBG) THEN 1860 XNORM=DDOT(NGAMMA(ISYX4O),WORK(KX4O),1,WORK(KX4O),1) 1861 WRITE (LUPRI,*) 'Norm of X4O intermediate:',XNORM 1862 XNORM=DDOT(NT2AM(ISYMAB),WORK(KTHETA2),1,WORK(KTHETA2),1) 1863 WRITE (LUPRI,*) 'Norm of THETA2 after A contribution:',XNORM 1864 CALL FLSHFO(LUPRI) 1865 END IF 1866 1867 END IF ! (.NOT. (CCS .OR. CC2)) 1868 1869*------------------------------------ 1870* E1 & E2 contributions, T^0 x F^AB: 1871*------------------------------------ 1872 IF (.NOT. (CCS .OR. CC2 .OR. CCSTST) ) THEN 1873 KFCKABOO = KEND3 1874 KFCKABVV = KFCKABOO + NMATIJ(ISYMAB) 1875 KSCR = KFCKABVV + NMATAB(ISYMAB) 1876 KEND4 = KSCR + MAX(NMATIJ(ISYMAB),NMATAB(ISYMAB)) 1877 LWRK4 = LWORK - KEND4 1878 1879 IF (LWRK4 .LE. 0) THEN 1880 CALL QUIT('Insufficient work space in CC_BMAT. (17)') 1881 END IF 1882 1883 DTIME = SECOND() 1884 1885* calculate occ/occ block of double one-index transformed Fock matrix: 1886 Call CCG_1ITROO(WORK(KFCKABOO), ISYMAB, 1887 & WORK(KFOCKOV(IINT1A)),ISYMA, 1888 & WORK(KT1AMPB), ISYMB ) 1889 1890 Call CCG_1ITROO(WORK(KSCR), ISYMAB, 1891 & WORK(KFOCKOV(IINT1B)),ISYMB, 1892 & WORK(KT1AMPA), ISYMA ) 1893 1894 Call DAXPY(NMATIJ(ISYMAB),ONE, WORK(KSCR),1, WORK(KFCKABOO),1) 1895 1896* calculate vir/vir block of double one-index transformed Fock matrix: 1897 Call CCG_1ITRVV(WORK(KFCKABVV), ISYMAB, 1898 & WORK(KFOCKOV(IINT1A)),ISYMA, 1899 & WORK(KT1AMPB), ISYMB ) 1900 1901 Call CCG_1ITRVV(WORK(KSCR), ISYMAB, 1902 & WORK(KFOCKOV(IINT1B)),ISYMB, 1903 & WORK(KT1AMPA), ISYMA ) 1904 1905 Call DAXPY(NMATAB(ISYMAB),ONE, WORK(KSCR),1, WORK(KFCKABVV),1) 1906 1907* calculate the contribution to THETA2: 1908 CALL CCRHS_E(WORK(KTHETA2),WORK(KT2AMP0),WORK(KFCKABVV), 1909 & WORK(KFCKABOO),WORK(KEND4),LWRK4,ISYM0,ISYMAB) 1910 1911 TIME = TIME + SECOND() - DTIME 1912 1913 IF (LOCDBG) THEN 1914 XNORM=DDOT(NMATIJ(ISYMAB),WORK(KFCKABOO),1,WORK(KFCKABOO),1) 1915 WRITE (LUPRI,*) 'Norm of KFCKABOO intermediate:',XNORM 1916 XNORM=DDOT(NMATAB(ISYMAB),WORK(KFCKABVV),1,WORK(KFCKABVV),1) 1917 WRITE (LUPRI,*) 'Norm of KFCKABVV intermediate:',XNORM 1918 XNORM=DDOT(NT2AM(ISYMAB),WORK(KTHETA2),1,WORK(KTHETA2),1) 1919 WRITE (LUPRI,*) 'Norm of THETA2 after E contribution:',XNORM 1920 WRITE (LUPRI,*) 'THETA2 after E contribution:' 1921 Call CC_PRP(WORK(KTHETA1),WORK(KTHETA2),ISYMAB,1,1) 1922 CALL FLSHFO(LUPRI) 1923 END IF 1924 1925 1926 END IF ! (.NOT. (CCS .OR. CC2 .OR. CCSTST) ) 1927 1928*---------------------------------------------------------------------* 1929* CC2/CCSD contributions that require the response B double amplitudes, 1930* and/or the response A BF and GAMMA intermediates, add here 1931* contributions from the CBAR and DBAR intermediates 1932*---------------------------------------------------------------------* 1933 IOFFCDB = IOFFCD(IINTA) 1934 IOPTB = 1 1935 1936 CALL CCBMAT2(WORK(KTHETA1),WORK(KTHETA2),ISYMAB,IOPTB,IOFFCDB, 1937 & LISTB, IDLSTB, IINT1A, ISYMA, ISYMB, 1938 & WORK(KFOCKOV(IINT1A)), WORK(KFOCKVV(IINT1A)), 1939 & WORK(KFCKAVV), WORK(KFCKAOO), WORK(KFOCK0OV), 1940 & WORK(KFCKC0), 1941 & WORK(KYBAR(IINT1A)), WORK(KXBAR(IINT1A)), 1942 & BFFIL, CTFIL, DTFIL, DBAFIL, CBAFIL, RFIL, 1943 & LUBF, LENBF, LUC,LUD, LUCBAR, LUDBAR, LUR,LENR, 1944 & WORK(KLAMDPB), WORK(KLAMDPA), WORK(KLAMDHA), 1945 & WORK(KLAMP0), WORK(KLAMH0), 1946 & WORK(KEND2), LWRK2, LISTA, IDLSTA, 1947 & TIMIO,TIMA,TIMBF,TIME,TIMC,TIMD,TIMI) 1948 1949 IF (LOCDBG) THEN 1950 WRITE (LUPRI,*) 'returned from CCBMAT2 (first call).' 1951 IF (.NOT. (CCS .OR. CCSTST) ) THEN 1952 XNORM=DDOT(NT2AM(ISYMAB),WORK(KTHETA2),1,WORK(KTHETA2),1) 1953 WRITE (LUPRI,*) 'Norm of THETA2 after these contributions:', 1954 & XNORM 1955 END IF 1956 CALL FLSHFO(LUPRI) 1957 END IF 1958 1959 1960*---------------------------------------------------------------------* 1961* CC2/CCSD contributions that require the response A double amplitudes, 1962* and/or the response B BF and GAMMA intermediates, skip here 1963* contributions from the CBAR and DBAR intermediates 1964*---------------------------------------------------------------------* 1965 IOFFCDB = -99 999 999 ! dummy address 1966 IOPTB = 0 1967 1968 CALL CCBMAT2(WORK(KTHETA1),WORK(KTHETA2),ISYMAB,IOPTB,IOFFCDB, 1969 & LISTA, IDLSTA, IINT1B, ISYMB, ISYMA, 1970 & WORK(KFOCKOV(IINT1B)), WORK(KFOCKVV(IINT1B)), 1971 & WORK(KFCKBVV), WORK(KFCKBOO), WORK(KFOCK0OV), 1972 & WORK(KFCKC0), 1973 & WORK(KYBAR(IINT1B)), WORK(KXBAR(IINT1B)), 1974 & BFFIL, CTFIL, DTFIL, DBAFIL, CBAFIL, RFIL, 1975 & LUBF, LENBF, LUC,LUD, LUCBAR, LUDBAR, LUR, LENR, 1976 & WORK(KLAMDPA), WORK(KLAMDPB), WORK(KLAMDHB), 1977 & WORK(KLAMP0), WORK(KLAMH0), 1978 & WORK(KEND2), LWRK2, LISTB, IDLSTB, 1979 & TIMIO,TIMA,TIMBF,TIME,TIMC,TIMD,TIMI) 1980 1981 IF (LOCDBG) THEN 1982 WRITE (LUPRI,*) 'returned from CCBMAT2 (second call).' 1983 IF (.NOT. (CCS .OR. CCSTST) ) THEN 1984 XNORM=DDOT(NT2AM(ISYMAB),WORK(KTHETA2),1,WORK(KTHETA2),1) 1985 WRITE (LUPRI,*) 'Norm of THETA2 after these contributions:', 1986 & XNORM 1987 END IF 1988 CALL FLSHFO(LUPRI) 1989 END IF 1990 1991C initialize R12 part of result: 1992 IF (CCR12) CALL DZERO(WORK(KTHETAR12),NTR12AM(ISYMAB)) 1993 1994 IF (CCSLV) THEN 1995 IF (.NOT. CCMM) CALL CCSL_BTR(WORK(KTHETA1),WORK(KTHETA2), 1996 * ISYMAB,LISTA,IDLSTA,ISYMA, 1997 * LISTB,IDLSTB,ISYMB, 1998 * MODEL,WORK(KEND2),LWRK2) 1999C 2000 IF (CCMM) THEN 2001 IF (.NOT. NYQMMM) THEN 2002 CALL CCMM_BTR(WORK(KTHETA1),WORK(KTHETA2), 2003 * ISYMAB,LISTA,IDLSTA,ISYMA, 2004 * LISTB,IDLSTB,ISYMB, 2005 * MODEL,WORK(KEND2),LWRK2) 2006 ELSE IF (NYQMMM) THEN 2007 RSPTYP='B' 2008 CALL CCMM_QRTRANSFORMER(WORK(KTHETA1),WORK(KTHETA2),ISYMAB, 2009 * LISTA,IDLSTA,ISYMA, 2010 * LISTB,IDLSTB,ISYMB, 2011 * MODEL,RSPTYP,WORK(KEND2),LWRK2) 2012 END IF 2013 END IF 2014 END IF 2015! 2016 IF (USE_PELIB()) THEN 2017 RSPTYP='B' 2018 CALL PELIB_IFC_QRTRANSFORMER(WORK(KTHETA1),WORK(KTHETA2), 2019 & ISYMAB,LISTA,IDLSTA,ISYMA,LISTB,IDLSTB,ISYMB, 2020 & MODEL,RSPTYP,WORK(KEND2),LWRK2) 2021 END IF 2022*---------------------------------------------------------------------* 2023* if DO_O2 flag is set include A{x} t^y + A{y} t^x contribution 2024* to the second-order rhs vector (here we do the CCS/CC2/CCSD parts): 2025*---------------------------------------------------------------------* 2026 IF (DO_O2) THEN 2027 IF ((FILBMA(1:3).NE.'O2 ' .AND. FILBMA(1:3).NE.'EO1') .OR. 2028 & IOPTRES.GE.5) THEN 2029 CALL QUIT('Illegal result type for DO_O2 flag in CC_BMAT') 2030 END IF 2031 2032 KATRAN2 = KEND2 + NT1AM(ISYMAB) 2033 KATRANR12 = KATRAN2 + NT2AM(ISYMAB) 2034 2035 IF (LISTA.EQ.'R1 ') THEN 2036 CALL CCCR_AA(LRTLBL(IDLSTA),ISYMA,LISTB,IDLSTB,DUMMY, 2037 & WORK(KEND2),LWRK2) 2038 CALL DAXPY(NT1AM(ISYMAB),ONE,WORK(KEND2),1,WORK(KTHETA1),1) 2039 IF (.NOT.CCS) THEN 2040 CALL CCLR_DIASCL(WORK(KATRAN2),2.0D0,ISYMAB) 2041 CALL DAXPY(NT2AM(ISYMAB),ONE,WORK(KATRAN2),1, 2042 & WORK(KTHETA2),1) 2043 END IF 2044 IF (CCR12) THEN 2045 CALL DAXPY(NTR12AM(ISYMAB),ONE,WORK(KATRANR12),1, 2046 & WORK(KTHETAR12),1) 2047 END IF 2048 END IF 2049 2050 IF (LISTB.EQ.'R1 ') THEN 2051 CALL CCCR_AA(LRTLBL(IDLSTB),ISYMB,LISTA,IDLSTA,DUMMY, 2052 & WORK(KEND2),LWRK2) 2053 CALL DAXPY(NT1AM(ISYMAB),ONE,WORK(KEND2),1,WORK(KTHETA1),1) 2054 IF (.NOT.CCS) THEN 2055 CALL CCLR_DIASCL(WORK(KATRAN2),2.0D0,ISYMAB) 2056 CALL DAXPY(NT2AM(ISYMAB),ONE,WORK(KATRAN2),1, 2057 & WORK(KTHETA2),1) 2058 END IF 2059 IF (CCR12) THEN 2060 CALL DAXPY(NTR12AM(ISYMAB),ONE,WORK(KATRANR12),1, 2061 & WORK(KTHETAR12),1) 2062 END IF 2063 END IF 2064 2065 END IF 2066 2067*---------------------------------------------------------------------* 2068* calculate R12 contributions: 2069* 2070* C. Neiss, June 2005 2071*---------------------------------------------------------------------* 2072 IF (CCR12) THEN 2073 CALL CC_R12BMAT(WORK(KTHETA1),WORK(KTHETA2), 2074 & WORK(KTHETAR12),ISYMAB, 2075 & LISTA,IDLSTA,WORK(KT1AMPA),ISYMA, 2076 & LISTB,IDLSTB,WORK(KT1AMPB),ISYMB, 2077 & WORK(KLAMDPA),WORK(KLAMDHA), 2078 & WORK(KLAMDPB),WORK(KLAMDHB), 2079 & WORK(KLAMP0),WORK(KLAMH0), 2080 & WORK(KEND2),LWRK2) 2081 END IF 2082 2083*---------------------------------------------------------------------* 2084* add CC3 contribution 2085*---------------------------------------------------------------------* 2086 IF (CCSDT) THEN 2087 IF (IOPTRES.LT.5) THEN 2088 KTHETA1EFF = KEND2 2089 KTHETA2EFF = KTHETA1EFF + NT1AM(ISYMAB) 2090 KEND2 = KTHETA2EFF + NT2AM(ISYMAB) 2091 LWRK2 = LWORK - KEND2 2092C 2093 CALL DZERO(WORK(KTHETA1EFF),NT1AM(ISYMAB)) 2094 CALL DZERO(WORK(KTHETA2EFF),NT2AM(ISYMAB)) 2095 END IF 2096 2097 IF (NODDY_BMAT) THEN 2098 2099 ! Old style noddy code: 2100 CALL CCSDT_BMAT_NODDY(LISTA,IDLSTA,LISTB,IDLSTB,IOPTRES, 2101 & WORK(KLAMP0),WORK(KLAMH0), 2102 & WORK(KTHETA1),WORK(KTHETA2), 2103 & WORK(KTHETA1EFF),WORK(KTHETA2EFF), 2104 & IBDOTS,BCONS,FILBMA,ITRAN, 2105 & NBTRAN,MXVEC,WORK(KEND2),LWRK2) 2106 2107 IF (DO_O2) THEN 2108 FREQ = FREQLST(FILBMA,IBTRAN(3,ITRAN)) 2109 IF (LISTA.EQ.'R1 ') THEN 2110 CALL CCSDT_AAMAT_NODDY(IOPTRES,FREQ,LRTLBL(IDLSTA),ISYMA, 2111 & LISTB,IDLSTB,.FALSE., 2112 & WORK(KTHETA1),WORK(KTHETA2), 2113 & WORK(KTHETA1EFF),WORK(KTHETA2EFF), 2114 & IBDOTS,BCONS,FILBMA,ITRAN, 2115 & NBTRAN,MXVEC,WORK(KEND2),LWRK2) 2116 END IF 2117 IF (LISTB.EQ.'R1 ') THEN 2118 CALL CCSDT_AAMAT_NODDY(IOPTRES,FREQ,LRTLBL(IDLSTB),ISYMB, 2119 & LISTA,IDLSTA,.FALSE., 2120 & WORK(KTHETA1),WORK(KTHETA2), 2121 & WORK(KTHETA1EFF),WORK(KTHETA2EFF), 2122 & IBDOTS,BCONS,FILBMA,ITRAN, 2123 & NBTRAN,MXVEC,WORK(KEND2),LWRK2) 2124 END IF 2125C ! noddy code based on similar intermediates as real code: 2126C ! is here called as dummy routine (which means, that it 2127C ! actually doesn't change the result vectors theta*) 2128C write(lupri,*) 'call now ccsdt_o32_noddy...' 2129C CALL CCSDT_O32_NODDY(LISTA,IDLSTA,LISTB,IDLSTB, 2130C * FILBMA,IBTRAN(3,ITRAN), 2131C * WORK(KLAMP0),WORK(KLAMH0),WORK(KFOCK0), 2132C * WORK(KEND2),LWRK2) 2133 END IF 2134 2135 ELSE 2136 2137 IF (IOPTRES .LT. 5) THEN 2138 IF (DO_O2) THEN 2139 ! OMEGAEFF = OMEGAEFF + contribution from aamat 2140 ! We assume that the singles and doubles contirbutions 2141 !(sitting in KTHETA1 and KTHETA2) are added in CC3_BMATSD 2142 2143 !Project triples part of AAMAT into singles and 2144 !doubles space 2145 CALL CC3_AAMATSD(LISTA,IDLSTA, 2146 * LISTB,IDLSTB, 2147 & DUMMY,DUMMY, 2148 & WORK(KTHETA1EFF),WORK(KTHETA2EFF), 2149 & ISYMAB,WORK(KEND2),LWRK2) 2150C 2151 !Calculate triples contributions that enter directly 2152 !doubles space simultanously for AAMAT and BMAT 2153 CALL CC3_AABMAT_DOUB(WORK(KTHETA2), 2154 * LISTA,IDLSTA,LISTB,IDLSTB, 2155 * WORK(KEND2),LWRK2) 2156 2157c 2158c 2159 ! OMEGAEFF = OMEGAEFF + contribution from bmatsd 2160 ! At the end: OMEGAEFF = OMEGAEFF + OMEGA 2161c 2162 CALL CC3_BMATSD(WORK(KTHETA1),WORK(KTHETA2), 2163 & WORK(KTHETA1EFF),WORK(KTHETA2EFF), 2164 & ISYMAB, 2165 * LISTA,IDLSTA,LISTB,IDLSTB, 2166 * WORK(KEND2),LWRK2) 2167 ELSE 2168 WRITE(LUPRI,*)'Second-order rhs equatioons only' 2169 WRITE(LUPRI,*)'implemented for TXY and EfX.' 2170 CALL QUIT('Wrong DO_O2 value in CC_BMAT ') 2171 END IF 2172 ELSE 2173 WRITE(LUPRI,*)'IOPTRES = ',IOPTRES 2174 CALL QUIT('Illegal IOPTRES in CC_BMAT (real CC3 code)') 2175 END IF 2176 2177 2178 END IF 2179 2180 END IF 2181 2182*---------------------------------------------------------------------* 2183* write result vector to output: 2184*---------------------------------------------------------------------* 2185 DTIME = SECOND() 2186 2187 IF (IOPTRES .EQ. 0 .OR. IOPTRES .EQ. 1) THEN 2188 2189* write to a common direct access file, 2190* store start address in IBTRAN(3,ITRAN) 2191 2192 IBTRAN(3,ITRAN) = IADRTH 2193 2194 CALL PUTWA2(LUBMAT,FILBMA,WORK(KTHETA1),IADRTH,NT1AM(ISYMAB)) 2195 IADRTH = IADRTH + NT1AM(ISYMAB) 2196 2197 IF (.NOT.CCS) THEN 2198 CALL PUTWA2(LUBMAT,FILBMA,WORK(KTHETA2),IADRTH,NT2AM(ISYMAB)) 2199 IADRTH = IADRTH + NT2AM(ISYMAB) 2200 END IF 2201 IF (CCR12) THEN 2202 CALL PUTWA2(LUBMAT,FILBMA,WORK(KTHETAR12),IADRTH, 2203 & NTR12AM(ISYMAB)) 2204 IADRTH = IADRTH + NTR12AM(ISYMAB) 2205 END IF 2206 2207 IF (LOCDBG) THEN 2208 WRITE (LUPRI,*) 'B matrix transformation nb. ',ITRAN, 2209 & ' saved on file.' 2210 WRITE (LUPRI,*) 'ADRESS, LENGTH:', 2211 & IBTRAN(3,ITRAN),IADRTH-IBTRAN(3,ITRAN) 2212 XNORM = DDOT(NT1AM(ISYMAB),WORK(KTHETA1),1,WORK(KTHETA1),1) 2213 IF (.NOT.CCS) XNORM = XNORM + 2214 & DDOT(NT2AM(ISYMAB),WORK(KTHETA2),1,WORK(KTHETA2),1) 2215 IF (CCR12) XNORM = XNORM + 2216 & DDOT(NTR12AM(ISYMAB),WORK(KTHETAR12),1,WORK(KTHETAR12),1) 2217 WRITE (LUPRI,*) 'Norm:', XNORM 2218 2219 Call AROUND('B matrix transformation written to file:') 2220 Call CC_PRP(WORK(KTHETA1),WORK(KTHETA2),ISYMAB,1,1) 2221 IF (CCR12) CALL CC_PRPR12(WORK(KTHETAR12),ISYMAB,1,.TRUE.) 2222 END IF 2223 2224 ELSE IF ( IOPTRES .EQ. 3 .OR. IOPTRES .EQ. 4 ) THEN 2225 2226* write to a sequential file by a call to CC_WRRSP/CC_WARSP, 2227* use FILBMA as LIST type and IBTRAN(3,ITRAN) as index 2228 KTHETA0 = -999999 2229 IF (IOPTRES.EQ.3) THEN 2230 CALL CC_WRRSP(FILBMA,IBTRAN(3,ITRAN),ISYMAB,IOPTW,MODELW, 2231 & WORK(KTHETA0),WORK(KTHETA1),WORK(KTHETA2), 2232 & WORK(KEND2),LWRK2) 2233 IF (CCR12) THEN 2234 CALL CC_WRRSP(FILBMA,IBTRAN(3,ITRAN),ISYMAB,IOPTWR12, 2235 & MODELW,DUMMY,DUMMY,WORK(KTHETAR12), 2236 & WORK(KEND2),LWRK2) 2237 END IF 2238 IF (CCSDT) THEN 2239 CALL CC_WRRSP(FILBMA,IBTRAN(3,ITRAN),ISYMAB,IOPTWE,MODELW, 2240 & WORK(KTHETA0),WORK(KTHETA1EFF), 2241 & WORK(KTHETA2EFF),WORK(KEND2),LWRK2) 2242 END IF 2243 ELSE IF (IOPTRES.EQ.4) THEN 2244 IF (CCSDT) THEN 2245 CALL CC_WARSP(FILBMA,IBTRAN(3,ITRAN),ISYMAB,IOPTWE,MODELW, 2246 & WORK(KTHETA0),WORK(KTHETA1EFF), 2247 & WORK(KTHETA2EFF),WORK(KEND2),LWRK2) 2248 END IF 2249 CALL CC_WARSP(FILBMA,IBTRAN(3,ITRAN),ISYMAB,IOPTW,MODELW, 2250 & WORK(KTHETA0),WORK(KTHETA1),WORK(KTHETA2), 2251 & WORK(KEND2),LWRK2) 2252 IF (CCR12) THEN 2253 CALL CC_WARSP(FILBMA,IBTRAN(3,ITRAN),ISYMAB,IOPTWR12, 2254 & MODELW,DUMMY,DUMMY,WORK(KTHETAR12), 2255 & WORK(KEND2),LWRK2) 2256 END IF 2257 END IF 2258 2259 IF (LOCDBG) THEN 2260 WRITE (LUPRI,*) 'Write B * ',LISTA,' * ',LISTB, 2261 & ' transformation', 2262 & ' as ',FILBMA,' type vector to file.' 2263 WRITE (LUPRI,*) 'index of inp. A vector:',IBTRAN(1,ITRAN) 2264 WRITE (LUPRI,*) 'index of inp. B vector:',IBTRAN(2,ITRAN) 2265 WRITE (LUPRI,*) 'index of result vector:',IBTRAN(3,ITRAN) 2266 NVEC2 = 1 2267 LEN = NT1AM(ISYMAB) + NT2AM(ISYMAB) 2268 IF (CCS) THEN 2269 NVEC2 = 0 2270 LEN = NT1AM(ISYMAB) 2271 END IF 2272 IF (CCR12) LEN = LEN + NTR12AM(ISYMAB) 2273 XNORM = DDOT(LEN,WORK(KTHETA1),1,WORK(KTHETA1),1) 2274 WRITE (LUPRI,*) 'norm^2 of result vector:',XNORM 2275 WRITE (LUPRI,*) 'Listing of the result vector:' 2276 CALL CC_PRP(WORK(KTHETA1),WORK(KTHETA2),ISYMAB,1,NVEC2) 2277 IF (CCR12) CALL CC_PRPR12(WORK(KTHETAR12),ISYMAB,1,.TRUE.) 2278 IF (CCSDT) THEN 2279 XNORM = DDOT(LEN,WORK(KTHETA1EFF),1,WORK(KTHETA1EFF),1) 2280 WRITE (LUPRI,*) 'norm^2 of eff. result vector:',XNORM 2281 WRITE (LUPRI,*) 'Listing of the eff. result vector:' 2282 CALL CC_PRP(WORK(KTHETA1EFF),WORK(KTHETA2EFF),ISYMAB,1,1) 2283 END IF 2284 END IF 2285 ELSE IF (IOPTRES.EQ.5) THEN 2286 CALL CCDOTRSP(IBDOTS,BCONS,IOPTW,FILBMA,ITRAN,NBTRAN,MXVEC, 2287 & WORK(KTHETA1),WORK(KTHETA2),ISYMAB, 2288 & WORK(KEND2),LWRK2) 2289 IF (CCR12) THEN 2290 CALL CCDOTRSP(IBDOTS,BCONS,IOPTWR12,FILBMA,ITRAN,NBTRAN, 2291 & MXVEC,DUMMY,WORK(KTHETAR12),ISYMAB, 2292 & WORK(KEND2),LWRK2) 2293 END IF 2294 ELSE 2295 CALL QUIT('Illegal value for IOPTRES in CC_BMAT.') 2296 END IF 2297 2298 TIMIO = TIMIO + SECOND() - DTIME 2299 2300 TIMTRN = SECOND() - TIMTRN 2301 2302 IF (IPRINT.GT.0) THEN 2303 2304 IF (IOPTRES.EQ.5) THEN 2305 IVEC = 1 2306 DO WHILE (IBDOTS(IVEC,ITRAN).NE.0 .AND. IVEC.LE.MXVEC) 2307 IVEC = IVEC + 1 2308 END DO 2309 WRITE (LUPRI,'(1X,2(A,I5),A,I6,A,F10.2,A)')'| ',IDLSTA, 2310 & ' | ',IDLSTB,' | ',IVEC-1,' | ',TIMTRN,' |' 2311 ELSE 2312 WRITE (LUPRI,'(1X,2(A,I5),A,I6,A,F10.2,A)') '| ',IDLSTA, 2313 & ' | ', 2314 & IDLSTB,' | ',IBTRAN(3,ITRAN),' | ',TIMTRN,' |' 2315 END IF 2316 2317 END IF 2318 2319*---------------------------------------------------------------------* 2320* End of loop over B matrix transformations 2321*---------------------------------------------------------------------* 2322 END DO 2323 2324*---------------------------------------------------------------------* 2325* close & remove scratch files: 2326*---------------------------------------------------------------------* 2327 DTIME = SECOND() 2328 2329 IF (.NOT. (CCS.OR.CC2)) THEN 2330 CALL WCLOSE2(LUBF, BFFIL, 'DELETE') 2331 CALL WCLOSE2(LUC, CTFIL, 'DELETE') 2332 CALL WCLOSE2(LUD, DTFIL, 'DELETE') 2333 CALL WCLOSE2(LUCBAR, CBAFIL, 'DELETE') 2334 CALL WCLOSE2(LUDBAR, DBAFIL, 'DELETE') 2335 CALL WCLOSE2(LUR, RFIL, 'DELETE') 2336 END IF 2337 2338 IF (.NOT. CCS) CALL WCLOSE2(LUAIBJ,FNAIBJ,'DELETE') 2339 IF (.NOT. CCS) CALL WCLOSE2(LUF, FFIL, 'DELETE') 2340 IF (CCSD.OR.CCSDT) CALL WCLOSE2(LUBFD, FNBFD, 'DELETE') 2341 2342 CALL WCLOSE2(LUFK, FKFIL, 'DELETE') 2343 2344 TIMIO = TIMIO + SECOND() - DTIME 2345 2346*---------------------------------------------------------------------* 2347* if IOPTRES=1 and enough work space available, read result 2348* vectors back into memory: 2349*---------------------------------------------------------------------* 2350 DTIME = SECOND() 2351 2352* check size of work space: 2353 IF (IOPTRES .EQ. 1) THEN 2354 LENALL = IADRTH-1 2355 IF (LENALL .GT. LWORK) IOPTRES = 0 2356 END IF 2357 2358* read the result vectors back into memory: 2359 IF (IOPTRES .EQ. 1) THEN 2360 2361 CALL GETWA2(LUBMAT,FILBMA,WORK(1),1,LENALL) 2362 2363 IF (LOCDBG) THEN 2364 DO ITRAN = 1, NBTRAN 2365 IF (ITRAN.LT.NBTRAN) THEN 2366 LEN = IBTRAN(3,ITRAN+1)-IBTRAN(3,ITRAN) 2367 ELSE 2368 LEN = IADRTH-IBTRAN(3,NBTRAN) 2369 END IF 2370 KTHETA1 = IBTRAN(3,ITRAN) 2371 XNORM = DDOT(LEN, WORK(KTHETA1),1, WORK(KTHETA1),1) 2372 WRITE (LUPRI,*) 'Read B matrix transformation nb. ',NBTRAN 2373 WRITE (LUPRI,*) 'Adress, length, NORM:',IBTRAN(3,NBTRAN), 2374 & LEN,XNORM 2375 END DO 2376 CALL FLSHFO(LUPRI) 2377 END IF 2378 END IF 2379 2380 TIMIO = TIMIO + SECOND() - DTIME 2381*---------------------------------------------------------------------* 2382* close B matrix file, print timings & return 2383*---------------------------------------------------------------------* 2384 DTIME = SECOND() 2385 2386 IF (IOPTRES.EQ.0 ) THEN 2387 CALL WCLOSE2(LUBMAT, FILBMA, 'KEEP') 2388 ELSE IF (IOPTRES.EQ.1) THEN 2389 CALL WCLOSE2(LUBMAT, FILBMA, 'DELETE') 2390 ELSE IF (IOPTRES.EQ.3 .OR. IOPTRES.EQ.4 .OR. IOPTRES.EQ.5) THEN 2391 CONTINUE 2392 ELSE 2393 CALL QUIT('Illegal value of IOPTRES in CC_BMAT.') 2394 END IF 2395 2396 TIMIO = TIMIO + SECOND() - DTIME 2397 TIMALL = SECOND() - TIMALL 2398 2399 IF (IPRINT.GE.0) THEN 2400 WRITE (LUPRI,'(1X,A1,50("-"),A1)') '+','+' 2401 WRITE (LUPRI,'(1X,A,I4,A,F10.2,A)') 2402 & '| total time for',NBTRAN,' B transforms.:',TIMALL,' secs.|' 2403 IF (TIMALL .GE. 1.0D0) THEN 2404 WRITE (LUPRI,'(1X,A1,50("-"),A1)') '+','+' 2405 CONVRT = 100.0D0/TIMALL 2406 WRITE (LUPRI,'(1X,"| % of time used in ",A,":", 2407 & F10.2," |")') 2408 & 'start up org.', TIMPRE*CONVRT, 2409 & 'Fock interm. ', TIMFCK*CONVRT, 2410 & 'ERI ', TIMINT*CONVRT, 2411 & 'CCRDAO ', TIMRDAO*CONVRT, 2412 & '(**|k del) ', TIMTRBT*CONVRT, 2413 & 'singles part ', TIMI*CONVRT, 2414 & 'A term ', TIMA*CONVRT, 2415 & 'BF term ', TIMBF*CONVRT, 2416 & 'F term ', TIMF*CONVRT, 2417 & 'E term ', TIME*CONVRT, 2418 & 'C term ', TIMC*CONVRT, 2419 & 'D term ', TIMD*CONVRT, 2420 & 'I/O ', TIMIO*CONVRT 2421 END IF 2422 2423 WRITE (LUPRI,'(1X,A1,50("="),A1,//)') '+','+' 2424 END IF 2425*=====================================================================* 2426 2427 CALL QEXIT('CC_BMAT') 2428 2429 RETURN 2430 END 2431*=====================================================================* 2432* END OF SUBROUTINE CC_BMAT 2433*=====================================================================* 2434*---------------------------------------------------------------------* 2435c/* Deck CCBMAT2 */ 2436*=====================================================================* 2437 SUBROUTINE CCBMAT2(THETA1, THETA2, ISYRES, IOPTB, IOFFCDB, 2438 & LISTB, IDLSTB, IINT1A, ISYMA, ISYMB, 2439 & FOCKA, FOCKVV, FCKAVV, FCKAOO, FCK0OV, FCKC0, 2440 & YBARA, XBARA, BFIL, CTFIL, DTFIL, 2441 & DBAFIL, CBAFIL, RFIL, LUBF, LENBF, 2442 & LUC,LUD, LUCBAR, LUDBAR,LUR, LENR, 2443 & XLAMPB, XLAMPA, XLAMHA, XLAMP0, XLAMH0, 2444 & WORK, LWORK, LISTA, IDLSTA, TIMIO, 2445 & TIMA, TIMBF, TIME, TIMC, TIMD, TIMI ) 2446*---------------------------------------------------------------------* 2447* Purpose: calculate CC2 & CCSD contributions to the B matrix 2448* transformation that require the response B double 2449* amplitudes and/or the response A BF and GAMMA 2450* intermediates 2451* 2452* Written by Christof Haettig, Januar 1997. 2453*=====================================================================* 2454 USE PELIB_INTERFACE, ONLY: USE_PELIB 2455#if defined (IMPLICIT_NONE) 2456 IMPLICIT NONE 2457#else 2458# include "implicit.h" 2459#endif 2460#include "priunit.h" 2461#include "ccsdsym.h" 2462#include "ccsdinp.h" 2463#include "ccorb.h" 2464#include "ccfield.h" 2465#include "second.h" 2466#include "ccsections.h" 2467#include "ccslvinf.h" 2468#include "qm3.h" 2469!#include "qmmm.h" 2470 2471 2472* local parameters: 2473 LOGICAL LOCDBG 2474 PARAMETER (LOCDBG = .FALSE.) 2475 INTEGER ISYM0, KDUM 2476 PARAMETER (ISYM0 = 1) 2477 PARAMETER (KDUM = +99 999 999) 2478 2479#if defined (SYS_CRAY) 2480 REAL ZERO, ONE, TWO, HALF, FACB 2481#else 2482 DOUBLE PRECISION ZERO, ONE, TWO, HALF, FACB 2483#endif 2484 PARAMETER (ZERO = 0.0d0, ONE = 1.0d0, TWO = 2.0d0, HALF = 0.5d0) 2485 2486 LOGICAL LGAMMA, LO3BF, LRCON, LGCON, FCKCON 2487 CHARACTER*(*) BFIL, CTFIL, DTFIL, DBAFIL, CBAFIL, RFIL 2488 CHARACTER*(*) LISTB, LISTA 2489 CHARACTER*(10) MODEL 2490 INTEGER LWORK, IOFFCDB 2491 INTEGER IOPTB, IOPTE 2492 INTEGER LUBF, LENBF, LUC, LUD, LUCBAR, LUDBAR, LUR, LENR 2493 INTEGER ISYMA, ISYMB, ISYRES, ISYMAB 2494 INTEGER IINT1A, IDLSTB, IDLSTA 2495 INTEGER KEND0, KGAMMA, KBFA, KEND1, LWRK1, LEN, ICON, IDUM 2496 INTEGER KT2AMPB, KGAMMAX, LWRK0, KEND2, LWRK2, KSCR, IOPT, IOPTG 2497 INTEGER KEMAT1A, KEMAT2A, NRHO, KRIM, KGIM, KCON, KFCKA 2498 INTEGER IF, KT1AMPA, KOV, KPERT, KT1AMPB, KONEHG, KONEHR 2499 2500#if defined (SYS_CRAY) 2501 REAL WORK(LWORK) 2502 REAL THETA1(*), THETA2(*), XLAMP0(*), XLAMH0(*) 2503 REAL XLAMPB(*), XLAMPA(*), XLAMHA(*) 2504 REAL FOCKA(*), FOCKVV(*), FCKAVV(*), FCKAOO(*) 2505 REAL YBARA(*), XBARA(*), FCK0OV(*), FCKC0(*) 2506 REAL DUM, XNORM, DTIME 2507 REAL TIMIO, TIMBF, TIMA, TIME, TIMI, TIMC, TIMD 2508 REAL DDOT 2509#else 2510 DOUBLE PRECISION WORK(LWORK) 2511 DOUBLE PRECISION THETA1(*), THETA2(*), XLAMP0(*), XLAMH0(*) 2512 DOUBLE PRECISION XLAMPB(*), XLAMPA(*), XLAMHA(*) 2513 DOUBLE PRECISION FOCKA(*), FOCKVV(*), FCKAVV(*), FCKAOO(*) 2514 DOUBLE PRECISION YBARA(*), XBARA(*), FCK0OV(*), FCKC0(*) 2515 DOUBLE PRECISION FF, DUM, XNORM, DTIME 2516 DOUBLE PRECISION TIMIO, TIMBF, TIMA, TIME, TIMI, TIMC, TIMD 2517 DOUBLE PRECISION DDOT 2518#endif 2519 REAL*8, ALLOCATABLE :: FOCKMAT(:), FOCKTEMP(:) 2520 2521 CALL QENTER('CCBMAT2') 2522 2523*---------------------------------------------------------------------* 2524* begin: 2525*---------------------------------------------------------------------* 2526 IF (LOCDBG) THEN 2527 WRITE (LUPRI,*) 'Entered CCBMAT2.' 2528 WRITE (LUPRI,*) 'norm of XLAMH0:', 2529 & DDOT(NLAMDT,XLAMH0,1,XLAMH0,1) 2530 CALL FLSHFO(LUPRI) 2531 END IF 2532 2533 ISYMAB = MULD2H(ISYMA,ISYMB) 2534 2535 IF (ISYRES .NE. ISYMAB) THEN 2536 CALL QUIT('Symmetry mismatch in CCBMAT2.') 2537 END IF 2538 2539*----------------------------------------------- 2540* allocate work space and read T1AMB amplitudes: 2541*----------------------------------------------- 2542 KT1AMPB = 1 2543 KCON = KT1AMPB + NT1AM(ISYMB) 2544 KEND0 = KCON + NT1AM(ISYMAB) 2545 LWRK0 = LWORK - KEND0 2546 2547 IF (LWRK0 .LT. 0) THEN 2548 CALL QUIT('Insufficient work space in CCBMAT2. (0)') 2549 END IF 2550 2551 IOPT = 1 2552 CALL CC_RDRSP(LISTB,IDLSTB,ISYMB,IOPT,MODEL, 2553 & WORK(KT1AMPB),WORK(KDUM)) 2554 2555*-------------------------------------------------- 2556* for CCS calculate here J contribution and return: 2557*-------------------------------------------------- 2558 IF (CCS .OR. CCSTST) THEN 2559 2560 IOPT = 1 2561 CALL CCG_1ITRVO(WORK(KCON),ISYMAB,FCKAOO,FOCKVV,ISYMA, 2562 & WORK(KT1AMPB),ISYMB,IOPT) 2563 2564 CALL DAXPY(NT1AM(ISYRES),ONE,WORK(KCON),1,THETA1,1) 2565 2566 CALL QEXIT('CCBMAT2') 2567 2568 RETURN 2569 2570 END IF 2571 2572 2573 KEMAT1A = KEND0 2574 KEMAT2A = KEMAT1A + NMATAB(ISYMA) 2575 KRIM = KEMAT2A + NMATIJ(ISYMA) 2576 KEND0 = KRIM + NEMAT1(ISYMA) 2577 LWRK0 = LWORK - KEND0 2578 2579*---------------------------------------- 2580* BF contribution: LAM^B x LAM^0 x BF^A: 2581*---------------------------------------- 2582 IF (.NOT. CC2) THEN 2583 2584 NRHO = NT2AOIJ(ISYMA) 2585 2586 KGAMMA = KEND0 2587 KGIM = KGAMMA + NGAMMA(ISYMA) 2588 KBFA = KGIM + NT1AO(ISYMA) 2589 KEND1 = KBFA + NRHO 2590 LWRK1 = LWORK - KEND1 2591 2592 IF (LWRK1 .LT. 0) THEN 2593 CALL QUIT('Insufficient work space in CCBMAT2. (1)') 2594 END IF 2595 2596* read BF^A intermediate: 2597 DTIME = SECOND() 2598 CALL CC_RVEC(LUBF,BFIL,LENBF,NRHO,IINT1A,WORK(KBFA)) 2599 TIMIO = TIMIO + SECOND() - DTIME 2600 2601* initialize GAMMA^A and G^A intermediates: 2602 CALL DZERO(WORK(KGAMMA),NGAMMA(ISYMA)) 2603 CALL DZERO(WORK(KGIM), NT1AO(ISYMA)) 2604 2605* transform to MO representation using one response Lambda matrix (B) 2606* and calculate the Gamma intermediate using XLAMP0 2607 ICON = 2 2608 IOPTG = 2 2609 LGAMMA = .TRUE. 2610 LO3BF = .TRUE. 2611 DTIME = SECOND() 2612 CALL CC_T2MO3(DUM,DUM,1,WORK(KBFA), 2613 * THETA2,WORK(KGAMMA),WORK(KGIM),DUM, 2614 * XLAMP0,ISYM0,WORK(KT1AMPB),ISYMB, 2615 * WORK(KEND1),LWRK1,ISYMA,ICON, 2616 * LGAMMA,IOPTG,LO3BF,.FALSE.) 2617 TIMBF = TIMBF + SECOND() - DTIME 2618 2619 2620 IF (LOCDBG) THEN 2621 XNORM=DDOT(NGAMMA(ISYMA),WORK(KGAMMA),1,WORK(KGAMMA),1) 2622 WRITE (LUPRI,*) 'Norm of response GAMMA intermediate:',XNORM 2623 XNORM=DDOT(NRHO,WORK(KBFA),1,WORK(KBFA),1) 2624 WRITE (LUPRI,*) 'Norm of response BF intermediate:',XNORM 2625 XNORM=DDOT(NT2AM(ISYMAB),THETA2,1,THETA2,1) 2626 WRITE (LUPRI,*) 'Norm of THETA2 after BF contribution:',XNORM 2627 WRITE (LUPRI,*) 'THETA after BF contribution:' 2628 Call CC_PRP(THETA1,THETA2,ISYMAB,1,1) 2629 CALL FLSHFO(LUPRI) 2630 END IF 2631 2632 END IF 2633 2634*------------------------------------------------------------------- 2635* for CCSD calculate here E intermed. from G, R, YBAR intermediates: 2636* This might miss a frozen core term!!!!!!!! 2637*------------------------------------------------------------------- 2638 IF (CCSD.OR.CCSDT) THEN 2639 KONEHR = KEND1 2640 KONEHG = KONEHR + MAX(N2BST(ISYM0),N2BST(ISYMA)) 2641 KEND1 = KONEHG + MAX(N2BST(ISYM0),N2BST(ISYMA)) 2642 LWRK1 = LWORK - KEND1 2643 2644 IF (LWRK1 .LT. 0) THEN 2645 CALL QUIT('Insufficient work space in CCBMAT2. (0)') 2646 END IF 2647 2648 DTIME = SECOND() 2649 2650 CALL CCRHS_ONEAO(WORK(KONEHR),WORK(KEND1),LWRK1) 2651 DO IF= 1, NFIELD 2652 FF = EFIELD(IF) 2653 CALL CC_ONEP(WORK(KONEHR),WORK(KEND1),LWRK1,FF,1,LFIELD(IF)) 2654 END DO 2655C 2656C------------------------------------------------------------------------ 2657C CCMM, 03 JK+OC 2658C Solvent/QMMM contribution to one-electron integrals. 2659C T^g contribution to transformation. 2660C------------------------------------------------------------------------ 2661C 2662 IF (CCSLV) THEN 2663 IF (.NOT.CCMM) CALL CCSL_RHSTG(WORK(KONEHR),WORK(KEND1),LWRK1) 2664 IF (CCMM) THEN 2665 IF (.NOT. NYQMMM) THEN 2666 CALL CCMM_RHSTG(WORK(KONEHR),WORK(KEND1),LWRK1) 2667 ELSE IF (NYQMMM) THEN 2668 IF (HFFLD) THEN 2669 WRITE(LUPRI,*) 'Is it justified to do B transformation' 2670 & //' with a HFFLD?' 2671 CALL QUIT('HFFLD not implemented for QR') 2672 ELSE 2673 CALL CCMM_ADDG(WORK(KONEHR),WORK(KEND1),LWRK1) 2674 END IF 2675 END IF 2676 END IF 2677 ENDIF 2678 IF (USE_PELIB()) THEN 2679 IF (HFFLD) THEN 2680 CALL QUIT('HFFLD not implemented for QR') 2681 ELSE 2682 ALLOCATE(FOCKMAT(NNBASX), 2683 & FOCKTEMP(MAX(N2BST(ISYM0),N2BST(ISYMA)))) 2684 CALL GET_FROM_FILE('FOCKMAT',NNBASX,FOCKMAT) 2685 CALL DSPTSI(NBAS,FOCKMAT,FOCKTEMP) 2686 CALL DAXPY(MAX(N2BST(ISYM0),N2BST(ISYMA)),1.0d0,FOCKTEMP, 2687 & 1,WORK(KONEHR),1) 2688 DEALLOCATE(FOCKMAT,FOCKTEMP) 2689 END IF 2690 END IF 2691C 2692C 2693C------------------------------------------------------------------------ 2694C 2695 IF (FROIMP.OR.FROEXP) THEN 2696 CALL DAXPY(N2BST(ISYM0),ONE,FCKC0,1,WORK(KONEHR),1) 2697 END IF 2698 CALL DCOPY(N2BST(ISYM0),WORK(KONEHR),1,WORK(KONEHG),1) 2699 2700 CALL CC_FCKMO(WORK(KONEHR),XLAMPA,XLAMH0,WORK(KEND1),LWRK1, 2701 * ISYM0,ISYMA,ISYM0) 2702 CALL CC_FCKMO(WORK(KONEHG),XLAMP0,XLAMHA,WORK(KEND1),LWRK1, 2703 * ISYM0,ISYM0,ISYMA) 2704 2705 TIME = TIME + SECOND() - DTIME 2706 2707* read R^A intermediate: 2708 DTIME = SECOND() 2709 CALL CC_RVEC(LUR,RFIL,LENR,NEMAT1(ISYMA),IINT1A,WORK(KRIM)) 2710 TIMIO = TIMIO + SECOND() - DTIME 2711 2712 DTIME = SECOND() 2713 2714* transform AO indizes of R^A and G^A intermediates and add 2715* one-electron hamiltonian contributions: 2716 LRCON = .TRUE. 2717 LGCON = .TRUE. 2718 FCKCON = .TRUE. 2719 IOPT = 1 2720 CALL CC_EIM(WORK(KEMAT1A),WORK(KEMAT2A), 2721 * WORK(KRIM),DUM,WORK(KGIM),DUM, 2722 * WORK(KONEHR),WORK(KONEHG), 2723 * XLAMH0,XLAMP0,ISYM0,DUM,DUM,IDUM, 2724 * FCKCON,LRCON,LGCON,.FALSE.,IOPT,ISYMA) 2725 2726* add T2^A contribution to E1 intermediate: 2727 CALL DAXPY(NMATAB(ISYMA),ONE,YBARA,1,WORK(KEMAT1A),1) 2728 2729 TIME = TIME + SECOND() - DTIME 2730 2731 IF (LOCDBG) THEN 2732 XNORM = DDOT(NEMAT1(ISYMA),WORK(KRIM),1,WORK(KRIM),1) 2733 WRITE (LUPRI,*) 'Norm^2 of RIM:',XNORM 2734 CALL AROUND( 'CCSD implementation of E2 intermediate:') 2735 CALL CC_PREI(WORK(KEMAT1A),WORK(KEMAT2A),ISYMA,1) 2736 CALL AROUND( 'ONEHR intermediate:') 2737 CALL CC_PRFCKMO(WORK(KONEHR),ISYMA) 2738 CALL AROUND( 'ONEHG intermediate:') 2739 CALL CC_PRFCKMO(WORK(KONEHG),ISYMA) 2740 END IF 2741 2742 END IF 2743 2744*------------------------------------------------------------------- 2745* read double excitation response T^B amplitudes and square them up: 2746*------------------------------------------------------------------- 2747 KT2AMPB = KEND0 2748 KEND0 = KT2AMPB + NT2SQ(ISYMB) 2749 LWRK0 = LWORK - KEND0 2750 2751 KGAMMAX = KGAMMA 2752 2753 KGAMMA = KEND0 2754 KEND1 = KGAMMA + NGAMMA(ISYMA) 2755 LWRK1 = LWORK - KEND1 2756 2757 KSCR = KEND0 2758 IF (.NOT. CC2) THEN ! take care of Gamma intermediate, 2759 KSCR = KEND1 ! shift it behind the T^B amplitudes 2760 DO I = NGAMMA(ISYMA), 1, -1 2761 WORK(KGAMMA-1+I) = WORK(KGAMMAX-1+I) 2762 END DO 2763 END IF 2764 KEND2 = KSCR + NT2AM(ISYMB) 2765 LWRK2 = LWORK - KEND2 2766 2767 IF (LWRK2 .LT. 0) THEN 2768 CALL QUIT('Insufficient work space in CCBMAT2. (3)') 2769 END IF 2770 2771 DTIME = SECOND() 2772 2773 IOPT = 2 2774 CALL CC_RDRSP(LISTB,IDLSTB,ISYMB,IOPT,MODEL, 2775 & WORK(KDUM),WORK(KSCR)) 2776 2777 CALL CCLR_DIASCL(WORK(KSCR),TWO,ISYMB) 2778 2779 CALL CC_T2SQ(WORK(KSCR),WORK(KT2AMPB),ISYMB) 2780 2781 TIMIO = TIMIO + SECOND() - DTIME 2782 2783*------------------------------------------------------ 2784* A contribution: T^B x GAMMA^A, (requires squared T2^B) 2785*------------------------------------------------------ 2786 IF (.NOT. CC2) THEN 2787 IOPT = 1 2788 DTIME = SECOND() 2789 2790* add E2 intermediate contribution to diagonal of GAMMA: 2791 CALL CC_GAMMA2(WORK(KGAMMA),WORK(KEMAT2A),ISYMA) 2792 2793* calculate A term contribution: 2794 CALL CCRHS_A(THETA2,WORK(KT2AMPB),WORK(KGAMMA), 2795 & WORK(KEND1),LWRK1,ISYMA,ISYMB,IOPT) 2796 2797 TIMA = TIMA + SECOND() - DTIME 2798 2799 IF (LOCDBG) THEN 2800 XNORM=DDOT(NGAMMA(ISYMA),WORK(KGAMMA),1,WORK(KGAMMA),1) 2801 WRITE (LUPRI,*) 'Norm of response GAMMA intermediated:',XNORM 2802 XNORM=DDOT(NT2AM(ISYMAB),THETA2,1,THETA2,1) 2803 WRITE (LUPRI,*) 'Norm of THETA2 after A contribution:',XNORM 2804 CALL FLSHFO(LUPRI) 2805 END IF 2806 2807 END IF 2808 2809*-------------------------------------------------------------- 2810* E1 & E2 contributions, T^B x E1/E2^A: (requires squared T2^B) 2811*-------------------------------------------------------------- 2812 2813 DTIME = SECOND() 2814 2815 IF(CC2.AND.(.NOT.CCSTST).AND. 2816 & ((NFIELD.GT.0) .OR. CCSLV .OR. USE_PELIB())) THEN 2817 2818 KPERT = KEND0 2819 KT1AMPA = KPERT + N2BST(ISYM0) 2820 KOV = KT1AMPA + NT1AM(ISYMA) 2821 KEND1 = KOV + NT1AM(ISYM0) 2822 LWRK1 = LWORK - KEND1 2823 2824 IF (LWRK1 .LT. 0) THEN 2825 CALL QUIT('Insufficient work space in CCBMAT2. (4)') 2826 END IF 2827 2828 ! read finite field perturb. integrals and transform to MO 2829 CALL DZERO(WORK(KPERT),N2BST(ISYM0)) 2830 DO IF = 1, NFIELD 2831 FF = EFIELD(IF) 2832 CALL CC_ONEP(WORK(KPERT),WORK(KEND1),LWRK1,FF,1,LFIELD(IF)) 2833 END DO 2834C 2835C---------------------------------------------------------------------- 2836C CCMM, 03 JK+OC 2837C Solvent/QMMM contribution to one-electron integrals. 2838C T^g contribution to transformation. 2839C---------------------------------------------------------------------- 2840C 2841 IF (CCSLV) THEN 2842 IF (.NOT.CCMM) CALL CCSL_RHSTG(WORK(KPERT),WORK(KEND1),LWRK1) 2843 IF (CCMM) THEN 2844 IF(.NOT. NYQMMM) THEN 2845 CALL CCMM_RHSTG(WORK(KPERT),WORK(KEND1),LWRK1) 2846 ELSE IF (NYQMMM) THEN 2847 IF (HFFLD) THEN 2848 WRITE(LUPRI,*) 'Is it justified to do B '// 2849 & 'transformation with a HFFLD?' 2850 CALL QUIT('HFFLD not implemented for QR') 2851 ELSE 2852 CALL CCMM_ADDG(WORK(KPERT),WORK(KEND1),LWRK1) 2853 END IF 2854 END IF 2855 END IF 2856 ENDIF 2857 IF (USE_PELIB()) THEN 2858 IF (HFFLD) THEN 2859 CALL QUIT('HFFLD not implemented for QR') 2860 ELSE 2861 ALLOCATE(FOCKMAT(NNBASX),FOCKTEMP(N2BST(ISYM0))) 2862 CALL GET_FROM_FILE('FOCKMAT',NNBASX,FOCKMAT) 2863 CALL DSPTSI(NBAS,FOCKMAT,FOCKTEMP) 2864 CALL DAXPY(N2BST(ISYM0),1.0d0,FOCKTEMP,1,WORK(KPERT),1) 2865 DEALLOCATE(FOCKMAT,FOCKTEMP) 2866 END IF 2867 END IF 2868C 2869C 2870C------------------------------------------------------------------------ 2871C 2872 CALL CC_FCKMO(WORK(KPERT),XLAMP0,XLAMH0,WORK(KEND1),LWRK1, 2873 & ISYM0,1,1) 2874 2875 ! gather occupied/virtual block and calculate one-index 2876 ! transformed V^A (occ/occ and vir/vir blocks) 2877 CALL CC_GATHEROV(WORK(KPERT),WORK(KOV),ISYM0) 2878 IOPT = 1 2879 CALL CC_RDRSP(LISTA,IDLSTA,ISYMA,IOPT,MODEL, 2880 & WORK(KT1AMPA),WORK(KDUM)) 2881 CALL CCG_1ITROO(WORK(KEMAT2A),ISYMA, 2882 & WORK(KOV), ISYM0, WORK(KT1AMPA),ISYMA) 2883 CALL CCG_1ITRVV(WORK(KEMAT1A),ISYMA, 2884 & WORK(KOV), ISYM0, WORK(KT1AMPA),ISYMA) 2885 2886* calculate the contribution to THETA2: 2887 CALL CCRHS_E(THETA2,WORK(KT2AMPB),WORK(KEMAT1A), 2888 & WORK(KEMAT2A),WORK(KEND1),LWRK1,ISYMB,ISYMA) 2889 2890 END IF 2891 2892 TIME = TIME + SECOND() - DTIME 2893 2894 IF (LOCDBG .AND. .NOT.(CCSD.OR.CCSDT)) THEN 2895 XNORM=DDOT(NT2SQ(ISYMB),WORK(KT2AMPB),1,WORK(KT2AMPB),1) 2896 WRITE (LUPRI,*) 'Norm of response T2AMPB amplitudes:',XNORM 2897 XNORM=DDOT(NMATAB(ISYMA),WORK(KEMAT1A),1,WORK(KEMAT1A),1) 2898 WRITE (LUPRI,*) 'Norm of response EMAT1A intermediated:',XNORM 2899 XNORM=DDOT(NMATIJ(ISYMA),WORK(KEMAT2A),1,WORK(KEMAT2A),1) 2900 WRITE (LUPRI,*) 'Norm of response EMAT2A intermediated:',XNORM 2901 XNORM=DDOT(NT2AM(ISYMAB),THETA2,1,THETA2,1) 2902 WRITE (LUPRI,*) 'Norm of THETA2 after E contribution:',XNORM 2903 WRITE (LUPRI,*) 'THETA2 after E contribution:' 2904 Call CC_PRP(THETA1,THETA2,ISYMAB,1,1) 2905 WRITE (LUPRI,*) 'ISYMA, ISYMB, ISYMAB:',ISYMA,ISYMB,ISYMAB 2906 CALL AROUND( 'response E-intermediates (1-el part)') 2907 CALL CC_PREI(FCKAVV,FCKAOO,ISYMA,1) 2908 CALL AROUND( 'response E-intermediates') 2909 CALL CC_PREI(WORK(KEMAT1A),WORK(KEMAT2A),ISYMA,1) 2910 CALL FLSHFO(LUPRI) 2911 END IF 2912 2913*---------------------------------------------------------------- 2914* C contribution: T^B x (CTILDE^A + CBAR^A) or with CTILDE only: 2915*---------------------------------------------------------------- 2916 IF (.NOT. CC2) THEN 2917 2918* transpose occupied indeces of the amplitudes: 2919 CALL CCSD_T2TP(WORK(KT2AMPB),WORK(KEND0),LWRK0,ISYMB) 2920 2921 IOPT = 2 2922 IOPTE = 1 2923 FACB = ONE 2924 DTIME = SECOND() 2925 CALL CCRHS_CIO2(THETA2,WORK(KT2AMPB),XLAMH0, 2926 & WORK(KEND0),LWRK0,ISYMB,ISYMA, 2927 & LUC,CTFIL,IINT1A,IOPT, 2928 & IOPTB,LUCBAR,CBAFIL,IOFFCDB,FACB, 2929 & IOPTE,WORK(KEMAT1A),.FALSE.) 2930 TIMC = TIMC + SECOND() - DTIME 2931 2932* restore original amplitudes: 2933 CALL CCSD_T2TP(WORK(KT2AMPB),WORK(KEND0),LWRK0,ISYMB) 2934 2935 IF (LOCDBG) THEN 2936 XNORM=DDOT(NT2AM(ISYMAB),THETA2,1,THETA2,1) 2937 WRITE (LUPRI,*) 'Norm of THETA2 after C contribution:',XNORM 2938 CALL FLSHFO(LUPRI) 2939 END IF 2940 2941 END IF 2942 2943 2944*---------------------------------------------------------------- 2945* calculate 2*t^B(iajb) - t^B(ibja) in place of the T2^B vector: 2946*---------------------------------------------------------------- 2947 CALL CCRHS_T2TR(WORK(KT2AMPB),WORK(KEND0),LWRK0,ISYMB) 2948 2949*---------------------------------- 2950* I contribution, (2T^B-T^B) x F^A 2951*---------------------------------- 2952 DTIME = SECOND() 2953 2954 IOPT = 1 2955 CALL CCG_LXD(WORK(KCON),ISYMAB,FOCKA,ISYMA, 2956 & WORK(KT2AMPB),ISYMB,IOPT) 2957 CALL DAXPY(NT1AM(ISYMAB),ONE,WORK(KCON),1,THETA1,1) 2958 2959 TIMI = TIMI + SECOND() - DTIME 2960 2961 IF (LOCDBG) THEN 2962 XNORM=DDOT(NT1AM(ISYMAB),THETA1,1,THETA1,1) 2963 WRITE (LUPRI,*) 'Norm of THETA1 after I contribution:',XNORM 2964 WRITE (LUPRI,*) 'THETA1 after I contribution:' 2965 Call CC_PRP(THETA1,THETA2,ISYMAB,1,0) 2966 CALL FLSHFO(LUPRI) 2967 END IF 2968 2969*---------------------------------------------------------------------- 2970* D contribution: (2T^B-T^B) x (DTILDE^A + DBAR^A) or with DTILDE only: 2971*---------------------------------------------------------------------- 2972 IF (.NOT. CC2) THEN 2973 2974 IOPT = 2 2975 IOPTE = 1 2976 FACB = ONE 2977 DTIME = SECOND() 2978 CALL CCRHS_DIO2(THETA2,WORK(KT2AMPB),XLAMH0, 2979 & WORK(KEND0),LWRK0,ISYMB,ISYMA, 2980 & LUD,DTFIL,LUC,CTFIL,IINT1A,IOPT, 2981 & IOPTB,LUDBAR,DBAFIL,IOFFCDB,FACB, 2982 & IOPTE,WORK(KEMAT1A),.FALSE.) 2983 TIMD = TIMD + SECOND() - DTIME 2984 2985 IF (LOCDBG) THEN 2986 XNORM=DDOT(NT2AM(ISYMAB),THETA2,1,THETA2,1) 2987 WRITE (LUPRI,*) 'Norm of THETA2 after D contribution:',XNORM 2988 CALL FLSHFO(LUPRI) 2989 END IF 2990 2991 END IF 2992 2993*-------------------------- 2994* J, G and H contributions: 2995*-------------------------- 2996 IF (CCSD.OR.CCSDT) THEN 2997 KT1AMPA = KEND0 2998 KFCKA = KT1AMPA + NT1AM(ISYMA) 2999 KEND0 = KFCKA + NMATAB(ISYMA) 3000 LWRK0 = LWORK - KEND0 3001 3002 IF (LWRK0 .LT. 0) THEN 3003 CALL QUIT('Insufficient work space in CCBMAT2. (J)') 3004 END IF 3005 3006 DTIME = SECOND() 3007 3008 IOPT = 1 3009 CALL CC_RDRSP(LISTA,IDLSTA,ISYMA,IOPT,MODEL, 3010 & WORK(KT1AMPA),WORK(KDUM)) 3011 3012 CALL CCG_1ITRVV(WORK(KFCKA),ISYMA,FCK0OV,ISYM0, 3013 & WORK(KT1AMPA),ISYMA) 3014 3015 CALL DAXPY(NMATAB(ISYMA),-ONE,WORK(KFCKA),1,WORK(KEMAT1A),1) 3016 3017 ELSE 3018 CALL DCOPY(NMATAB(ISYMA), FOCKVV,1,WORK(KEMAT1A),1) 3019 CALL DAXPY(NMATAB(ISYMA),ONE,YBARA, 1,WORK(KEMAT1A),1) 3020 3021 CALL DCOPY(NMATIJ(ISYMA), FCKAOO,1,WORK(KEMAT2A),1) 3022 CALL DAXPY(NMATIJ(ISYMA),ONE,XBARA, 1,WORK(KEMAT2A),1) 3023 END IF 3024 3025 IOPT = 1 3026 CALL CCG_1ITRVO(WORK(KCON),ISYMAB, 3027 & WORK(KEMAT2A),WORK(KEMAT1A),ISYMA, 3028 & WORK(KT1AMPB),ISYMB,IOPT) 3029 3030 CALL DAXPY(NT1AM(ISYRES),ONE,WORK(KCON),1,THETA1,1) 3031 3032 TIMI = TIMI + SECOND() - DTIME 3033 3034 IF (LOCDBG) THEN 3035 CALL AROUND( 'Intermediates for J, G & H terms:') 3036 CALL CC_PREI(WORK(KEMAT1A),WORK(KEMAT2A),ISYMA,1) 3037 WRITE (LUPRI,*) 'THETA1 after J, G & H contributions:' 3038 Call CC_PRP(THETA1,THETA2,ISYMAB,1,0) 3039 END IF 3040 3041*---------------------------------------------------------------------- 3042 3043 CALL QEXIT('CCBMAT2') 3044 3045 RETURN 3046 3047 END 3048 3049*=====================================================================* 3050* END OF SUBROUTINE CCBMAT2 3051*=====================================================================* 3052*---------------------------------------------------------------------* 3053c/* Deck CCBPRE1 */ 3054*=====================================================================* 3055 SUBROUTINE CCBPRE1(INTMED1,ISTART,IEND, 3056 & KRHO2,KLAMP,KLAMH,KDENS,KFOCK,KRIM, 3057 & LUBF,BFFIL,LENBF,LUFK,FKFIL,LENFK, 3058 & LUR,RFIL,LENR, 3059 & XLAMDP,XLAMDH,WORK,LWORK,KENDIN,KENDOUT) 3060*---------------------------------------------------------------------* 3061* Purpose: prepare for calculation of intermediates that depend 3062* on the AO integrals and one response vector 3063* 3064* N.B.: this routine allocates work space for CC_BMAT 3065* INPUT end of used space: KENDIN 3066* OUTPUT end of used space: KENDOUT 3067* 3068* Written by Christof Haettig, Januar/Februar 1997. 3069*=====================================================================* 3070#if defined (IMPLICIT_NONE) 3071 IMPLICIT NONE 3072#else 3073# include "implicit.h" 3074#endif 3075#include "priunit.h" 3076#include "ccsdsym.h" 3077#include "ccsdinp.h" 3078#include "ccorb.h" 3079#include "cciccset.h" 3080 3081* local parameters: 3082 LOGICAL LOCDBG 3083 PARAMETER (LOCDBG = .FALSE.) 3084 INTEGER KDUM 3085 PARAMETER (KDUM = -99 999 999) ! dummy address 3086 3087 INTEGER LWORK, KENDIN, KENDOUT 3088 INTEGER ISTART, IEND 3089 INTEGER LUBF, LENBF, LUFK, LENFK, LUR, LENR 3090 CHARACTER*(*) BFFIL, FKFIL, RFIL 3091 INTEGER INTMED1(2,IEND) 3092 INTEGER KLAMP(IEND), KLAMH(IEND) 3093 INTEGER KRHO2(IEND), KDENS(IEND), KFOCK(IEND), KRIM(IEND) 3094 3095 CHARACTER*(10) MODEL 3096 CHARACTER*(3) LIST 3097 INTEGER IOPT, IC, ISYM, IDX, IDLST 3098 INTEGER LEN, NRHO, KT1AMP 3099 3100#if defined (SYS_CRAY) 3101 REAL WORK(LWORK) 3102 REAL XLAMDP(NLAMDT), XLAMDH(NLAMDT) 3103 REAL XNORM, DDOT 3104 REAL TWO 3105#else 3106 DOUBLE PRECISION WORK(LWORK) 3107 DOUBLE PRECISION XLAMDP(NLAMDT), XLAMDH(NLAMDT) 3108 DOUBLE PRECISION XNORM, DDOT 3109 DOUBLE PRECISION TWO 3110#endif 3111 PARAMETER (TWO = 2.0d0) 3112 3113* external functions: 3114 INTEGER ILSTSYM 3115 3116 CALL QENTER('CCBPRE1') 3117 3118*---------------------------------------------------------------------* 3119* begin: 3120*---------------------------------------------------------------------* 3121 KENDOUT = KENDIN 3122 3123 DO IDX = ISTART, IEND 3124 LIST = VTABLE(INTMED1(2,IDX)) 3125 IDLST = INTMED1(1,IDX) 3126 ISYM = ILSTSYM(LIST,IDLST) 3127 NRHO = NT2AOIJ(ISYM) 3128 3129* memory allocation: 3130 IF (CCS .OR. CC2) THEN 3131 KRIM(IDX) = KDUM 3132 KRHO2(IDX) = KDUM 3133 KLAMP(IDX) = KENDOUT 3134 KLAMH(IDX) = KLAMP(IDX) + NGLMDT(ISYM) 3135 KDENS(IDX) = KLAMH(IDX) + NGLMDT(ISYM) 3136 KFOCK(IDX) = KDENS(IDX) + N2BST(ISYM) 3137 KENDOUT = KFOCK(IDX) + N2BST(ISYM) 3138 ELSE IF (CCSD.OR.CCSDT) THEN 3139 KRIM(IDX) = KENDOUT 3140 KRHO2(IDX) = KRIM(IDX) + NEMAT1(ISYM) 3141 KLAMP(IDX) = KRHO2(IDX) + NRHO 3142 KLAMH(IDX) = KLAMP(IDX) + NGLMDT(ISYM) 3143 KENDOUT = KLAMH(IDX) + NGLMDT(ISYM) 3144 KDENS(IDX) = KDUM 3145 KFOCK(IDX) = KDUM 3146 ELSE 3147 CALL QUIT('Unknown CC model in CCBPRE1.') 3148 END IF 3149 3150 IF ( (LWORK-KENDOUT) .LE. NT1AM(ISYM) ) THEN 3151 CALL QUIT('Insufficient work space in CCBPRE1.') 3152 END IF 3153 3154* read singles part of the response vector and 3155* calculate response Lambda matrices: 3156 KT1AMP = KENDOUT 3157 IOPT = 1 3158 CALL CC_RDRSP(LIST,IDLST,ISYM,IOPT,MODEL, 3159 & WORK(KT1AMP),WORK(KENDOUT)) 3160 3161 CALL CCLR_LAMTRA(XLAMDP,WORK(KLAMP(IDX)), 3162 & XLAMDH,WORK(KLAMH(IDX)), 3163 & WORK(KT1AMP),ISYM) 3164 3165* calculate response density matrix: 3166 IF (.NOT.(CCSD.OR.CCSDT)) THEN 3167 IC = 0 ! no core contribution 3168 CALL CC_AODENS(XLAMDP,WORK(KLAMH(IDX)),WORK(KDENS(IDX)),ISYM, 3169 & IC,WORK(KENDOUT),LWORK-KENDOUT) 3170 END IF 3171 3172* recover the R and BF intermediates: 3173 IF (CCSD.OR.CCSDT) THEN 3174 3175 CALL CC_RVEC(LUR,RFIL,LENR,NEMAT1(ISYM),IDX,WORK(KRIM(IDX))) 3176 3177 CALL CC_RVEC(LUBF,BFFIL,LENBF,NRHO,IDX,WORK(KRHO2(IDX))) 3178 3179 END IF 3180 3181* recover the response Fock matrix: 3182 IF (.NOT.(CCSD.OR.CCSDT)) THEN 3183 LEN = N2BST(ISYM) 3184 CALL CC_RVEC(LUFK,FKFIL,LENFK,LEN,IDX,WORK(KFOCK(IDX))) 3185 END IF 3186 3187 IF (LOCDBG) THEN 3188 XNORM = DDOT(NGLMDT(ISYM), 3189 & WORK(KLAMP(IDX)),1,WORK(KLAMP(IDX)),1) 3190 WRITE (LUPRI,*) 'Norm of response LAMDP nb. ', IDX, ' is ', 3191 & XNORM 3192 XNORM = DDOT(NGLMDT(ISYM), 3193 & WORK(KLAMH(IDX)),1,WORK(KLAMH(IDX)),1) 3194 WRITE (LUPRI,*) 'Norm of response LAMDH nb. ', IDX, ' is ', 3195 & XNORM 3196 IF (.NOT.(CCSD.OR.CCSDT)) THEN 3197 XNORM = DDOT(LEN,WORK(KDENS(IDX)),1,WORK(KDENS(IDX)),1) 3198 WRITE (LUPRI,*) 'Norm of response DENSITY nb. ', IDX, 3199 & ' is ',XNORM 3200 XNORM = DDOT(LEN,WORK(KFOCK(IDX)),1,WORK(KFOCK(IDX)),1) 3201 WRITE (LUPRI,*) 'Norm of recovered FOCK nb. ', IDX, ' is ', 3202 & XNORM 3203 ELSE IF (CCSD.OR.CCSDT) THEN 3204 XNORM = DDOT(NRHO,WORK(KRHO2(IDX)),1,WORK(KRHO2(IDX)),1) 3205 WRITE (LUPRI,*) 'Norm of recovered BF nb. ', IDX, ' is ', 3206 & XNORM 3207 END IF 3208 END IF 3209 3210 END DO 3211 3212 CALL QEXIT('CCBPRE1') 3213 3214 RETURN 3215 END 3216*=====================================================================* 3217* END OF SUBROUTINE CCBPRE1 3218*=====================================================================* 3219*---------------------------------------------------------------------* 3220c/* Deck CCBPRE2 */ 3221*=====================================================================* 3222 SUBROUTINE CCBPRE2(INTMED2,ISTART,IEND,LUF,FFIL,LENF, 3223 & KOMEGA2,KLAMPA,KLAMHA,KLAMPB,KLAMHB, 3224 & XLAMDP,XLAMDH,WORK,LWORK,KENDIN,KENDOUT ) 3225*---------------------------------------------------------------------* 3226* Purpose: prepare for calculation of intermediates that depend 3227* on the AO integrals and two response vector 3228* 3229* N.B.: this routine allocates work space for CC_BMAT 3230* INPUT end of used space: KENDIN 3231* OUTPUT end of used space: KENDOUT 3232* 3233* Written by Christof Haettig, Januar/Februar 1997. 3234*=====================================================================* 3235#if defined (IMPLICIT_NONE) 3236 IMPLICIT NONE 3237#else 3238# include "implicit.h" 3239#endif 3240#include "priunit.h" 3241#include "ccsdinp.h" 3242#include "ccsdsym.h" 3243#include "ccorb.h" 3244#include "cciccset.h" 3245 3246* local parameters: 3247 LOGICAL LOCDBG 3248 PARAMETER (LOCDBG = .FALSE.) 3249 INTEGER KDUM 3250 PARAMETER (KDUM = +99 999 999) ! dummy address on work space 3251 3252 INTEGER LWORK, KENDIN, KENDOUT 3253 INTEGER ISTART, IEND 3254 INTEGER LUF, LENF 3255 INTEGER INTMED2(4,IEND) 3256 INTEGER KLAMPA(IEND), KLAMHA(IEND) 3257 INTEGER KLAMPB(IEND), KLAMHB(IEND) 3258 INTEGER KOMEGA2(IEND) 3259 3260 CHARACTER*(*) FFIL 3261 CHARACTER*(3) LISTA, LISTB 3262 CHARACTER*(10) MODEL 3263 INTEGER KT1AMPA, KT1AMPB 3264 INTEGER LEN, KEND1, IOPT 3265 INTEGER IDLSTA, IDLSTB, ISYMA, ISYMB, ISYMAB, IINT2 3266 3267#if defined (SYS_CRAY) 3268 REAL WORK(LWORK) 3269 REAL XLAMDP(NLAMDT), XLAMDH(NLAMDT) 3270#else 3271 DOUBLE PRECISION WORK(LWORK) 3272 DOUBLE PRECISION XLAMDP(NLAMDT), XLAMDH(NLAMDT) 3273#endif 3274 3275* external functions: 3276 INTEGER ILSTSYM 3277 3278 CALL QENTER('CCBPRE2') 3279 3280*---------------------------------------------------------------------* 3281* begin: 3282*---------------------------------------------------------------------* 3283 KENDOUT = KENDIN 3284 3285 DO IINT2 = ISTART, IEND 3286 LISTA = VTABLE(INTMED2(2,IINT2)) 3287 LISTB = VTABLE(INTMED2(4,IINT2)) 3288 IDLSTA = INTMED2(1,IINT2) 3289 IDLSTB = INTMED2(3,IINT2) 3290 ISYMA = ILSTSYM(LISTA,IDLSTA) 3291 ISYMB = ILSTSYM(LISTB,IDLSTB) 3292 ISYMAB = MULD2H(ISYMA,ISYMB) 3293 3294 KOMEGA2(IINT2) = KDUM 3295 3296 IF (CCS) THEN 3297 KLAMPA(IINT2) = KDUM 3298 KLAMHA(IINT2) = KDUM 3299 KLAMPB(IINT2) = KDUM 3300 KLAMHB(IINT2) = KDUM 3301 KENDOUT = KENDOUT 3302 ELSE 3303 IF (CC2) THEN 3304 KOMEGA2(IINT2) = KENDOUT 3305 KENDOUT = KOMEGA2(IINT2) + NT2AM(ISYMAB) 3306 END IF 3307 3308 KLAMPA(IINT2) = KENDOUT 3309 KLAMHA(IINT2) = KLAMPA(IINT2) + NGLMDT(ISYMA) 3310 KLAMPB(IINT2) = KLAMHA(IINT2) + NGLMDT(ISYMA) 3311 KLAMHB(IINT2) = KLAMPB(IINT2) + NGLMDT(ISYMB) 3312 KENDOUT = KLAMHB(IINT2) + NGLMDT(ISYMB) 3313 3314 KT1AMPA = KENDOUT 3315 KT1AMPB = KT1AMPA + NT1AM(ISYMA) 3316 KEND1 = KT1AMPB + NT1AM(ISYMB) 3317 3318 IF ( (LWORK-KEND1) .LE. 0 ) THEN 3319 CALL QUIT('Insufficient work space in CCBPRE2.') 3320 END IF 3321 3322* recover F intermediate: 3323 IF (CC2) THEN 3324 LEN = NT2AM(ISYMAB) 3325 CALL CC_RVEC(LUF,FFIL,LENF,LEN,IINT2,WORK(KOMEGA2(IINT2))) 3326 END IF 3327 3328* A response Lambda matrices: 3329 IOPT = 1 ! read singles response vector 3330 CALL CC_RDRSP(LISTA,IDLSTA,ISYMA,IOPT,MODEL, 3331 & WORK(KT1AMPA),WORK(KDUM) ) 3332 3333 ! calculate response Lambda matrices: 3334 CALL CCLR_LAMTRA(XLAMDP,WORK(KLAMPA(IINT2)), 3335 & XLAMDH,WORK(KLAMHA(IINT2)), 3336 & WORK(KT1AMPA),ISYMA) 3337 3338* B response Lambda matrices: 3339 IOPT = 1 ! read singles response vector 3340 CALL CC_RDRSP(LISTB,IDLSTB,ISYMB,IOPT,MODEL, 3341 & WORK(KT1AMPB),WORK(KDUM) ) 3342 3343 ! calculate response Lambda matrices: 3344 CALL CCLR_LAMTRA(XLAMDP,WORK(KLAMPB(IINT2)), 3345 & XLAMDH,WORK(KLAMHB(IINT2)), 3346 & WORK(KT1AMPB),ISYMB) 3347 3348 END IF 3349 END DO 3350 3351 CALL QEXIT('CCBPRE2') 3352 3353 RETURN 3354 END 3355*=====================================================================* 3356* END OF SUBROUTINE CCBPRE2 3357*=====================================================================* 3358*---------------------------------------------------------------------* 3359c/* Deck CCBINT1 */ 3360*=====================================================================* 3361 SUBROUTINE CCBINT1(XINT, BDRHF, DCRHF, 3362 & IDEL, ISYMD, RHO2A, 3363 & XLAMP0, XLAMH0, XLAMPA, XLAMHA, 3364 & ISYMA, IVECA, DENSA, FOCKA, RIMA, 3365 & LUC, CTFIL, LUD, DTFIL, 3366 & LUBFD, FNBFD, IADRBFD, WORK, LWORK, 3367 & TIMFCK, TIMBF, TIMC, TIMD ) 3368*---------------------------------------------------------------------* 3369* 3370* Purpose: calculate intermediates for B matrix transformation 3371* which require AO integrals and depend on one response 3372* vector: 3373* 3374* RHO^{BF,A}, Ctilde^A, Dtilde^A, Ftilde^{A,*}, R^A 3375* 3376* input: XLAMPA - response A Lambda particle matrix 3377* XLAMHA - response A Lambda hole matrix 3378* XLAMP0 - zeroth order Lambda particle matrix 3379* XLAMH0 - zeroth order Lambda hole matrix 3380* DENSA - A response of the density matrix 3381* 3382* output: RHO2A - updated RHO^{BF,A} intermediate 3383* FOCKA - updated Ftilde^{A,*} intermediate 3384* RIMA - updated R^{A,*} intermediate 3385* 3386* written to file: contributions to Ctilde^A and Dtilde^A intermed. 3387* 3388* 3389* Written by Christof Haettig, Januar/Februar 1997. 3390* 3391*=====================================================================* 3392#if defined (IMPLICIT_NONE) 3393 IMPLICIT NONE 3394#else 3395# include "implicit.h" 3396#endif 3397#include "priunit.h" 3398#include "ccsdinp.h" 3399#include "ccsdsym.h" 3400#include "ccorb.h" 3401#include "second.h" 3402 3403* local parameters: 3404 LOGICAL LOCDBG 3405 PARAMETER (LOCDBG = .FALSE.) 3406 INTEGER ISYM0 3407 PARAMETER (ISYM0 = 1) 3408 3409 CHARACTER*(*) CTFIL, DTFIL, FNBFD 3410 INTEGER LWORK, IDEL, ISYMD, ISYMA 3411 INTEGER LUC, LUD, LUBFD, IVECA 3412 INTEGER IADRBFD(*) 3413 3414 INTEGER KEND0, KEND1, LWRK0, LWRK1, KSCRCM, IOPT, ISYMM 3415 INTEGER IADR, KMGD, NMGD, NRHO, IOPTR 3416 3417#if defined (SYS_CRAY) 3418 REAL WORK(LWORK) 3419 REAL XINT(*), BDRHF(*), DCRHF(*) 3420 REAL XLAMP0(*), XLAMH0(*), XLAMPA(*), XLAMHA(*) 3421 REAL RHO2A(*), DENSA(*), FOCKA(*), RIMA(*) 3422 3423 REAL FACTC, FACTD, DUMMY, XNORM 3424 REAL TIMFCK, TIMBF, TIMC, TIMD, DTIME 3425 REAL DDOT 3426#else 3427 DOUBLE PRECISION WORK(LWORK) 3428 DOUBLE PRECISION XINT(*), BDRHF(*), DCRHF(*) 3429 DOUBLE PRECISION XLAMP0(*), XLAMH0(*), XLAMPA(*), XLAMHA(*) 3430 DOUBLE PRECISION RHO2A(*), DENSA(*), FOCKA(*), RIMA(*) 3431 3432 DOUBLE PRECISION FACTC, FACTR, DUMMY, XNORM 3433 DOUBLE PRECISION TIMFCK, TIMBF, TIMC, TIMD, DTIME 3434 DOUBLE PRECISION DDOT 3435#endif 3436 3437 3438 CALL QENTER('CCBINT1') 3439 3440 3441*---------------------------------------------------------------------* 3442* begin: 3443*---------------------------------------------------------------------* 3444 KEND0 = 1 3445 LWRK0 = LWORK 3446 3447*---------------------------------------------------------------------* 3448* Ftilde^{A,*}: 3449*---------------------------------------------------------------------* 3450 IF (.NOT. (CCSD.OR.CCSDT)) THEN 3451 3452cch 3453c XNORM=DDOT(N2BST(ISYMA),FOCKA,1,FOCKA,1) 3454c WRITE (LUPRI,*) 'CCBINT1> norm of FOCKA matrix (before):',XNORM 3455cch 3456 DTIME = SECOND() 3457 CALL CC_AOFOCK( XINT, DENSA, FOCKA, 3458 * WORK(KEND0),LWRK0,IDEL,ISYMD,.FALSE.,DUMMY, 3459 * ISYMA ) 3460 TIMFCK = TIMFCK + SECOND() - DTIME 3461 3462cch IF (LOCDBG) THEN 3463c WRITE(LUPRI,*) 'ISYMD, ISYMA:',ISYMD, ISYMA 3464c XNORM = DDOT(NDISAO(ISYMD),XINT,1,XINT,1) 3465c WRITE (LUPRI,*) 'CCBINT1> norm of XINT matrix:',XNORM 3466c XNORM=DDOT(N2BST(ISYMA),DENSA,1,DENSA,1) 3467c WRITE (LUPRI,*) 'CCBINT1> norm of DENSA matrix:',XNORM 3468c XNORM=DDOT(N2BST(ISYMA),FOCKA,1,FOCKA,1) 3469c WRITE (LUPRI,*) 'CCBINT1> norm of FOCKA matrix:',XNORM 3470cch END IF 3471 3472 END IF 3473 3474*---------------------------------------------------------------------* 3475* RHO^{BF,A}: 3476*---------------------------------------------------------------------* 3477 IF (.NOT. (CCS .OR. CC2)) THEN 3478 DTIME = SECOND() 3479 3480 ISYMM = MULD2H(ISYMD,ISYMA) 3481 NMGD = NT2BGD(ISYMM) 3482 3483 KMGD = KEND0 3484 KEND1 = KMGD + NMGD 3485 LWRK1 = LWORK - KEND1 3486 3487 IF (LWRK1 .LT. 0) THEN 3488 CALL QUIT('Insufficient work space in CCBINT1.') 3489 END IF 3490 3491* read delta batch of the effective density: 3492 IADR = IADRBFD(IDEL) 3493 CALL GETWA2(LUBFD,FNBFD,WORK(KMGD),IADR,NMGD) 3494 3495* update BF intermediate: 3496 CALL CC_BFIB(RHO2A,BDRHF,ISYMD,WORK(KMGD),ISYMM, 3497 * WORK(KEND1),LWRK1) 3498 3499 TIMBF = TIMBF + SECOND() - DTIME 3500 3501 IF (LOCDBG) THEN 3502 WRITE (LUPRI,*) 'CCBINT1> IDEL, ISYMD:',IDEL,ISYMD 3503 XNORM=DDOT(NT2AOIJ(ISYMA),RHO2A,1,RHO2A,1) 3504 WRITE (LUPRI,*) 'CCBINT1> norm of RHO2A:',XNORM 3505 END IF 3506 3507 END IF 3508 3509*---------------------------------------------------------------------* 3510* Ctilde^A, Dtilde^A, and R^A: 3511*---------------------------------------------------------------------* 3512 IF (.NOT.(CCS .OR. CC2)) THEN 3513 3514 IOPTR = 1 3515 FACTR = -2.0D0 3516 DTIME = SECOND() 3517 CALL CC_CDB(DCRHF, ISYMD, IDEL, ISYMD, LUC, CTFIL, IVECA, 3518 * XLAMP0, XLAMH0, XLAMPA, XLAMHA, ISYMA, 3519 * IOPTR, FACTR, RIMA, WORK(KEND0), LWRK0 ) 3520 TIMC = TIMC + SECOND() - DTIME 3521 3522 3523 IOPTR = 1 3524 FACTR = 1.0D0 3525 DTIME = SECOND() 3526 CALL CC_CDB(BDRHF, ISYMD, IDEL, ISYMD, LUD, DTFIL, IVECA, 3527 * XLAMP0, XLAMH0, XLAMPA, XLAMHA, ISYMA, 3528 * IOPTR, FACTR, RIMA, WORK(KEND0), LWRK0 ) 3529 TIMD = TIMD + SECOND() - DTIME 3530 3531 ENDIF 3532 3533*---------------------------------------------------------------------* 3534 3535 CALL QEXIT('CCBINT1') 3536 3537 RETURN 3538 END 3539*=====================================================================* 3540* END OF SUBROUTINE CCBINT1 3541*=====================================================================* 3542*---------------------------------------------------------------------* 3543c/* Deck CCBINT2 */ 3544*=====================================================================* 3545 SUBROUTINE CCBINT2(XINT, IDEL, ISYMD, OMEGA2, ISYOMEG, 3546 & LUAIBJ, FNAIBJ, IT2F, IADRF, NEWFTERM, 3547 & XLAMPA, XLAMHA, ISYMA, 3548 & XLAMPB, XLAMHB, ISYMB, 3549 & XLAMP0, XLAMH0, WORK, LWORK ) 3550*---------------------------------------------------------------------* 3551* 3552* Purpose: calculate intermediates for B matrix transformation 3553* which require AO integrals and depend on two response 3554* vectors: 3555* 3556* 3557* input: XINT - AO integral distribution 3558* IDEL - delta index of XINT 3559* XLAMP0, XLAMH0 - ordinary zeroth order Lambda matrices 3560* XLAMPA, XLAMHA - response A Lambda matrices 3561* XLAMPB, XLAMHB - response B Lambda matrices 3562* 3563* output: F term contribution to B matrix in MO representation 3564* 3565* 3566* Written by Christof Haettig, Januar/Februar 1997. 3567* 3568*=====================================================================* 3569#if defined (IMPLICIT_NONE) 3570 IMPLICIT NONE 3571#else 3572# include "implicit.h" 3573#endif 3574#include "priunit.h" 3575#include "ccsdinp.h" 3576#include "ccsdsym.h" 3577#include "ccorb.h" 3578 3579* local parameters: 3580 LOGICAL LOCDBG 3581 PARAMETER (LOCDBG = .FALSE.) 3582 INTEGER ISYM0 3583 PARAMETER (ISYM0 = 1) 3584 3585 LOGICAL NEWFTERM 3586 CHARACTER*(*) FNAIBJ 3587 INTEGER IT2F(*) 3588 INTEGER LUAIBJ, LWORK, IDEL, ISYMD, ISYMA, ISYMB, ISYOMEG 3589 INTEGER IOPT, ISYALBE, IGAM, KXAIBJ, LEN, ISYIAJ, IADRF 3590 INTEGER ISYGAM, KEND1, LWRK1, IDUMMY, KOFF 3591 3592 3593#if defined (SYS_CRAY) 3594 REAL WORK(LWORK), XINT(*), OMEGA2(*) 3595 REAL XLAMP0(*), XLAMH0(*) 3596 REAL XLAMPA(*), XLAMHA(*), XLAMPB(*), XLAMHB(*) 3597 REAL DUMMY 3598#else 3599 DOUBLE PRECISION WORK(LWORK), XINT(*), OMEGA2(*) 3600 DOUBLE PRECISION XLAMP0(*), XLAMH0(*) 3601 DOUBLE PRECISION XLAMPA(*), XLAMHA(*), XLAMPB(*), XLAMHB(*) 3602 DOUBLE PRECISION DUMMY 3603#endif 3604 3605 3606 CALL QENTER('CCBINT2') 3607 3608 3609*---------------------------------------------------------------------* 3610* begin: 3611*---------------------------------------------------------------------* 3612 IF (CCS) THEN 3613 CONTINUE 3614 3615 ELSE IF (CC2) THEN 3616*---------------------------------------------------------------------* 3617* for CC2 calculate the complete F term: 3618*---------------------------------------------------------------------* 3619 IOPT = 3 3620 3621 CALL CC_MOFCON2(XINT,OMEGA2, 3622 & XLAMPA,XLAMHA,XLAMPB,XLAMHB, 3623 & XLAMP0,XLAMH0,ISYMA,ISYMB,ISYM0,ISYM0, 3624 & WORK,LWORK,IDEL,ISYMD,ISYOMEG,ISYM0,IOPT) 3625 3626 CALL CC_MOFCON2(XINT,OMEGA2, 3627 & XLAMPB,XLAMHB,XLAMP0,XLAMH0, 3628 & XLAMP0,XLAMHA,ISYMB,ISYM0,ISYM0,ISYMA, 3629 & WORK,LWORK,IDEL,ISYMD,ISYOMEG,ISYM0,IOPT) 3630 3631 CALL CC_MOFCON2(XINT,OMEGA2, 3632 & XLAMPB,XLAMHB,XLAMP0,XLAMH0, 3633 & XLAMPA,XLAMH0,ISYMB,ISYM0,ISYMA,ISYM0, 3634 & WORK,LWORK,IDEL,ISYMD,ISYOMEG,ISYM0,IOPT) 3635 3636 IF (LOCDBG) THEN 3637 WRITE (LUPRI,*) 'DEBUG_CCBINT2> used CC2 version of F term.' 3638 END IF 3639 3640 ELSE IF (CCSD.OR.CCSDT) THEN 3641*---------------------------------------------------------------------* 3642* for CCSD calculate only (a i^A | b j^B) + (a i^B | b j^A) : 3643*---------------------------------------------------------------------* 3644 ISYIAJ = MULD2H(ISYMD,MULD2H(ISYMA,ISYMB)) 3645 LEN = NT2BCD(ISYIAJ) 3646 3647 KXAIBJ = 1 3648 KEND1 = KXAIBJ + LEN 3649 LWRK1 = LWORK - KEND1 3650 3651 IF (LWRK1 .LT. 0) THEN 3652 CALL QUIT('Insufficient work space in CCBINT2.') 3653 END IF 3654 3655 CALL DZERO(WORK(KXAIBJ),LEN) 3656 3657 DO ISYGAM = 1, NSYM 3658 DO G = 1, NBAS(ISYGAM) 3659 3660 ISYALBE = MULD2H(ISYMD,ISYGAM) 3661 3662 IGAM = G + IBAS(ISYGAM) 3663 3664 KOFF = IDSAOG(ISYGAM,ISYMD) + NNBST(ISYALBE)*(G-1) + 1 3665 3666 IOPT = 0 3667 CALL CC_AIBJ( XINT(KOFF), ISYALBE, DUMMY, IDUMMY, 3668 & IDEL, IGAM, WORK(KXAIBJ), DUMMY, 3669 & XLAMHA,ISYMA, XLAMHB,ISYMB, 3670 & XLAMP0,ISYM0, WORK(KEND1), LWRK1, 3671 & IOPT, .FALSE., .FALSE. ) 3672 3673 END DO 3674 END DO 3675 3676 CALL PUTWA2(LUAIBJ, FNAIBJ, WORK(KXAIBJ), IADRF, LEN) 3677 3678 IT2F(IDEL) = IADRF 3679 IADRF = IADRF + LEN 3680 3681*---------------------------------------------------------------------* 3682 ELSE 3683 CALL QUIT('Unknown Coupled Cluster model in CCBINT2.') 3684 END IF 3685 3686 CALL QEXIT('CCBINT2') 3687 3688 RETURN 3689 END 3690*=====================================================================* 3691* END OF SUBROUTINE CCBINT2 3692*=====================================================================* 3693*---------------------------------------------------------------------* 3694c/* Deck CCBINT3 */ 3695*=====================================================================* 3696 SUBROUTINE CCBINT3(LIST,IDLST,LUFK,FKFIL,LENFK,IDXFK, 3697 & KFOCK,KFOCKOO,KFOCKOV,KFOCKVV,KXBAR,KYBAR, 3698 & XLIAJB,ISYOVOV,XLAMP0,XLAMH0, 3699 & WORK,LWORK,KENDIN,KENDOUT, 3700 & TIMFCK,TIMIO,TIME) 3701*---------------------------------------------------------------------* 3702* 3703* Purpose: calculate some intermediates for B matrix transformation 3704* which do NOT require AO integrals and depend on one 3705* response vector: 3706* 3707* Ftilde^{A,*} (o/o, o/v and v/v blocks), Xbar^A, Ybar^A 3708* 3709* N.B.: this routine allocates work space for CC_BMAT 3710* INPUT end of used space: KENDIN 3711* OUTPUT end of used space: KENDOUT 3712* 3713* Written by Christof Haettig, Januar 1997. 3714* 3715*=====================================================================* 3716#if defined (IMPLICIT_NONE) 3717 IMPLICIT NONE 3718#else 3719# include "implicit.h" 3720#endif 3721#include "priunit.h" 3722#include "ccsdinp.h" 3723#include "ccsdsym.h" 3724#include "ccorb.h" 3725#include "second.h" 3726 3727* local parameters: 3728 LOGICAL LOCDBG 3729 PARAMETER (LOCDBG = .FALSE.) 3730 3731 INTEGER KDUM, ISYM0 3732 PARAMETER ( KDUM = +99 999 999 ) ! dummy address 3733 PARAMETER (ISYM0 = 1) ! reference state symmetry 3734 3735 CHARACTER*(*) FKFIL, LIST 3736 INTEGER LWORK, KENDIN, KENDOUT 3737 INTEGER LUFK, LENFK, IDXFK, IDLST, ISYOVOV 3738 3739 CHARACTER*(10) MODEL 3740 INTEGER KFOCK, KFOCKOO, KFOCKOV, KFOCKVV, KXBAR, KYBAR 3741 INTEGER KEND1, LWRK1, KT1AMP, KT2AMP, LEN, ISYMA, IOPT 3742 3743#if defined (SYS_CRAY) 3744 REAL WORK(LWORK) 3745 REAL XLAMP0(NLAMDT), XLAMH0(NLAMDT), XLIAJB(*) 3746 REAL TWO, XNORM, TIMFCK, TIMIO, TIME, DTIME 3747 REAL DDOT 3748#else 3749 DOUBLE PRECISION WORK(LWORK) 3750 DOUBLE PRECISION XLAMP0(NLAMDT), XLAMH0(NLAMDT), XLIAJB(*) 3751 DOUBLE PRECISION TWO, XNORM, TIMFCK, TIMIO, TIME, DTIME 3752 DOUBLE PRECISION DDOT 3753#endif 3754 PARAMETER (TWO = 2.0d0) 3755 3756* external functions: 3757 INTEGER ILSTSYM 3758 3759 CALL QENTER('CCBINT3') 3760 3761 3762*---------------------------------------------------------------------* 3763* begin: 3764*---------------------------------------------------------------------* 3765 ISYMA = ILSTSYM(LIST,IDLST) 3766 3767 KFOCKOV = KENDIN 3768 KENDOUT = KFOCKOV + NT1AM(ISYMA) 3769 3770 IF (.NOT.(CCSD.OR.CCSDT)) THEN 3771 KFOCK = KENDOUT 3772 KFOCKOO = KFOCK + N2BST(ISYMA) 3773 KFOCKVV = KFOCKOO + NMATIJ(ISYMA) 3774 KENDOUT = KFOCKVV + NMATAB(ISYMA) 3775 ELSE 3776 KFOCK = KDUM 3777 KFOCKOO = KDUM 3778 KFOCKVV = KDUM 3779 END IF 3780 3781 IF (CCS) THEN 3782 KXBAR = KDUM 3783 KYBAR = KDUM 3784 ELSE 3785 KXBAR = KENDOUT 3786 KYBAR = KXBAR + NMATIJ(ISYMA) 3787 KENDOUT = KYBAR + NMATAB(ISYMA) 3788 END IF 3789 3790 KT1AMP = KENDOUT 3791 KEND1 = KT1AMP + NT1AM(ISYMA) 3792 3793 IF (.NOT. CCS) THEN 3794 KT2AMP = KEND1 3795 KEND1 = KT2AMP + NT2AM(ISYMA) 3796 END IF 3797 3798 LWRK1 = LWORK - KEND1 3799 IF (LWRK1 .LT. 0) THEN 3800 CALL QUIT('Insufficient work space in CCBINT3.') 3801 END IF 3802 3803 3804 IF (.NOT.(CCSD.OR.CCSDT)) THEN 3805 DTIME = SECOND() 3806 3807* read AO Ftilde^{A,*} matrix: 3808 LEN = N2BST(ISYMA) 3809 CALL CC_RVEC(LUFK,FKFIL,LENFK,LEN,IDXFK,WORK(KFOCK)) 3810 3811* transform to MO representation: 3812 CALL CC_FCKMO(WORK(KFOCK),XLAMP0,XLAMH0, 3813 & WORK(KEND1),LWRK1,ISYMA,ISYM0,ISYM0) 3814 3815* resort occ/occ and vir/vir blocks: 3816 CALL CC_GATHEROO(WORK(KFOCK),WORK(KFOCKOO),ISYMA) 3817 CALL CC_GATHERVV(WORK(KFOCK),WORK(KFOCKVV),ISYMA) 3818 3819 TIMFCK = TIMFCK + SECOND() - DTIME 3820 END IF 3821 3822* read the response A amplitudes: 3823 DTIME = SECOND() 3824 IOPT = 1 3825 IF (.NOT.CCS) IOPT = 3 3826 CALL CC_RDRSP(LIST,IDLST,ISYMA,IOPT,MODEL, 3827 & WORK(KT1AMP),WORK(KT2AMP)) 3828 IF (.NOT.CCS) Call CCLR_DIASCL(WORK(KT2AMP),TWO,ISYMA) 3829 TIMIO = TIMIO + SECOND() - DTIME 3830 3831* calculate the occ/vir block of the one-index transformed Fock matrix: 3832 IOPT = 1 3833 DTIME = SECOND() 3834 CALL CCG_LXD(WORK(KFOCKOV),ISYMA,WORK(KT1AMP),ISYMA, 3835 & XLIAJB,ISYM0,IOPT) 3836 TIMFCK = TIMFCK + SECOND() - DTIME 3837 3838* calculate the XBAR and YBAR intermediates: 3839 IF (.NOT.CCS) THEN 3840 DTIME = SECOND() 3841 CALL CC_XBAR(WORK(KXBAR),XLIAJB,ISYOVOV, 3842 & WORK(KT2AMP),ISYMA, WORK(KEND1),LWRK1 ) 3843 3844 CALL CC_YBAR(WORK(KYBAR),XLIAJB,ISYOVOV, 3845 & WORK(KT2AMP),ISYMA, WORK(KEND1),LWRK1 ) 3846 TIME = TIME + SECOND() - DTIME 3847 END IF 3848 3849 IF (LOCDBG) THEN 3850 WRITE (LUPRI,*) 'DEBUG CCBINT3> IDLST = ',IDLST 3851 XNORM = DDOT(N2BST(ISYMA),WORK(KFOCK),1,WORK(KFOCK),1) 3852 WRITE (LUPRI,*) 'DEBUG CCBINT3> NORM^2 of FOCK = ',XNORM 3853 XNORM = DDOT(NMATIJ(ISYMA),WORK(KFOCKOO),1,WORK(KFOCKOO),1) 3854 WRITE (LUPRI,*) 'DEBUG CCBINT3> NORM^2 of FOCKOO = ',XNORM 3855 XNORM = DDOT(NT1AM(ISYMA),WORK(KFOCKOV),1,WORK(KFOCKOV),1) 3856 WRITE (LUPRI,*) 'DEBUG CCBINT3> NORM^2 of FOCKOV = ',XNORM 3857 XNORM = DDOT(NMATAB(ISYMA),WORK(KFOCKVV),1,WORK(KFOCKVV),1) 3858 WRITE (LUPRI,*) 'DEBUG CCBINT3> NORM^2 of FOCKVV = ',XNORM 3859 END IF 3860 3861 CALL QEXIT('CCBINT3') 3862 3863 RETURN 3864 END 3865*=====================================================================* 3866* END OF SUBROUTINE CCBINT3 3867*=====================================================================* 3868*---------------------------------------------------------------------* 3869c/* Deck CCBOPEN*/ 3870*=====================================================================* 3871 SUBROUTINE CCBOPEN(LUBF,LUCBAR,LUDBAR,LUC,LUD,LUF,LUFK,LUR, 3872 & BFFIL,CBAFIL,DBAFIL,CTFIL,DTFIL,FFIL,FKFIL,RFIL, 3873 & LENBF, LENF, LENFK, LENR, 3874 & NINT1, NINT2, WORK, LWORK ) 3875*---------------------------------------------------------------------* 3876* Purpose: open files for intermediates in B matrix transformation 3877* 3878* Written by Christof Haettig, Januar/Februar 1997. 3879*=====================================================================* 3880#if defined (IMPLICIT_NONE) 3881 IMPLICIT NONE 3882#else 3883# include "implicit.h" 3884#endif 3885#include "priunit.h" 3886#include "ccsdinp.h" 3887#include "ccorb.h" 3888#include "ccsdsym.h" 3889 3890* local parameters: 3891 LOGICAL LOCDBG 3892 PARAMETER (LOCDBG = .FALSE.) 3893 3894 INTEGER LUBF, LUCBAR, LUDBAR, LUC, LUD, LUF, LUFK, LUR 3895 INTEGER LWORK, LENBF, LENF, LENFK, LENR, NINT1, NINT2 3896 CHARACTER*(*) BFFIL,CBAFIL,DBAFIL,CTFIL,DTFIL,FFIL,FKFIL,RFIL 3897 INTEGER LEN, IINT1, IINT2, ISYM 3898 3899#if defined (SYS_CRAY) 3900 REAL WORK(LWORK) 3901#else 3902 DOUBLE PRECISION WORK(LWORK) 3903#endif 3904 3905 CALL QENTER('CCBOPEN') 3906 3907*---------------------------------------------------------------------* 3908* open files for local intermediates: 3909*---------------------------------------------------------------------* 3910 LUBF = -1 3911 LUC = -1 3912 LUD = -1 3913 LUCBAR = -1 3914 LUDBAR = -1 3915 LUR = -1 3916 LUF = -1 3917 LUFK = -1 3918 IF (.NOT. (CCS.OR.CC2)) THEN 3919 CALL WOPEN2(LUBF, BFFIL, 64, 0) 3920 CALL WOPEN2(LUC, CTFIL, 64, 0) 3921 CALL WOPEN2(LUD, DTFIL, 64, 0) 3922 CALL WOPEN2(LUCBAR, CBAFIL, 64, 0) 3923 CALL WOPEN2(LUDBAR, DBAFIL, 64, 0) 3924 CALL WOPEN2(LUR, RFIL, 64, 0) 3925 END IF 3926 3927 IF (.NOT.CCS) THEN 3928 CALL WOPEN2(LUF, FFIL, 64, 0) 3929 END IF 3930 3931 CALL WOPEN2(LUFK, FKFIL,64, 0) 3932 3933*---------------------------------------------------------------------* 3934* calculate a common vector length for BF intermediates and 3935* initialize them with zeros: 3936*---------------------------------------------------------------------* 3937 IF (.NOT. (CCS.OR.CC2)) THEN 3938 LENBF = 0 3939 DO ISYM = 1, NSYM 3940 LENBF = MAX(LENBF,NT2AOIJ(ISYM)) 3941 END DO 3942 3943 IF (LWORK .LT. LENBF) THEN 3944 CALL QUIT('OUT OF MEMORY IN CCBOPEN.') 3945 END IF 3946 3947 CALL DZERO(WORK,LENBF) 3948 3949 DO IINT1 = 1, NINT1 3950 LEN = LENBF 3951 CALL CC_WVEC(LUBF,BFFIL,LENBF,LEN,IINT1,WORK) 3952 END DO 3953 3954 END IF 3955 3956*---------------------------------------------------------------------* 3957* calculate a common vector length for R intermediates and 3958* initialize them with zeros: 3959*---------------------------------------------------------------------* 3960 IF (.NOT. (CCS.OR.CC2)) THEN 3961 LENR = 0 3962 DO ISYM = 1, NSYM 3963 LENR = MAX(LENR,NEMAT1(ISYM)) 3964 END DO 3965 3966 IF (LWORK .LT. LENR) THEN 3967 CALL QUIT('OUT OF MEMORY IN CCBOPEN.') 3968 END IF 3969 3970 CALL DZERO(WORK,LENR) 3971 3972 DO IINT1 = 1, NINT1 3973 LEN = LENR 3974 CALL CC_WVEC(LUR,RFIL,LENR,LEN,IINT1,WORK) 3975 END DO 3976 3977 END IF 3978 3979*---------------------------------------------------------------------* 3980* calculate a common vector length for the F intermediates and 3981* initialize them with zeros: 3982*---------------------------------------------------------------------* 3983 IF (CC2) THEN 3984 LENF = 0 3985 DO ISYM = 1, NSYM 3986 LENF = MAX(LENF,NT2AM(ISYM)) 3987 END DO 3988 3989 IF (LWORK .LT. LENF) THEN 3990 CALL QUIT('OUT OF MEMORY IN CCBOPEN.') 3991 END IF 3992 3993 CALL DZERO(WORK,LENF) 3994 3995 DO IINT2 = 1, NINT2 3996 LEN = LENF 3997 CALL CC_WVEC(LUF,FFIL,LENF,LEN,IINT2,WORK) 3998 END DO 3999 END IF 4000 4001 4002*---------------------------------------------------------------------* 4003* calculate a common vector length for the response Fock matrices and 4004* initialize them with zeros: 4005*---------------------------------------------------------------------* 4006 LENFK = 0 4007 DO ISYM = 1, NSYM 4008 LENFK = MAX(LENFK,N2BST(ISYM)) 4009 END DO 4010 4011 IF (LWORK .LT. LENFK) THEN 4012 CALL QUIT('OUT OF MEMORY IN CCBOPEN.') 4013 END IF 4014 4015 CALL DZERO(WORK,LENFK) 4016 4017 DO IINT1 = 1, NINT1 4018 LEN = LENFK 4019 CALL CC_WVEC(LUFK,FKFIL,LENFK,LEN,IINT1,WORK) 4020 END DO 4021 4022 CALL QEXIT('CCBOPEN') 4023 4024 RETURN 4025 END 4026*=====================================================================* 4027* END OF SUBROUTINE CCBOPEN * 4028*=====================================================================* 4029*---------------------------------------------------------------------* 4030c/* Deck CCBSAVE*/ 4031*=====================================================================* 4032 SUBROUTINE CCBSAVE(IBATCH, I1HGH, I2HGH, INTMED1, INTMED2, 4033 & KRHO2, LUBF, BFFIL, LENBF, 4034 & KOMEG, LUF, FFIL, LENF, 4035 & KFOCK, LUFK, FKFIL, LENFK, 4036 & KRIM, LUR, RFIL, LENR, 4037 & NINT1, NINT2,WORK, LWORK ) 4038*---------------------------------------------------------------------* 4039* Purpose: save intermediates for B matrix transformation on file 4040* 4041* Written by Christof Haettig, Januar/Februar 1997. 4042*=====================================================================* 4043#if defined (IMPLICIT_NONE) 4044 IMPLICIT NONE 4045#else 4046# include "implicit.h" 4047#endif 4048#include "priunit.h" 4049#include "ccsdinp.h" 4050#include "ccsdsym.h" 4051#include "ccorb.h" 4052#include "cciccset.h" 4053 4054* local parameters: 4055 LOGICAL LOCDBG 4056 PARAMETER (LOCDBG = .FALSE.) 4057 4058 INTEGER LUBF, LUF, LUFK, LUR 4059 INTEGER NINT1, NINT2, LENBF, LENF, LENFK, LENR, LWORK, IBATCH 4060 CHARACTER*(*) BFFIL, FFIL, FKFIL, RFIL 4061 INTEGER I1HGH(0:IBATCH), I2HGH(0:IBATCH) 4062 INTEGER INTMED1(2,NINT1), INTMED2(4,NINT2) 4063 INTEGER KRHO2(NINT1), KFOCK(NINT1), KOMEG(NINT2), KRIM(NINT2) 4064 4065 CHARACTER*(3) LIST, LISTA, LISTB 4066 INTEGER IDLST, IDLSTA, IDLSTB, ISYM, ISYMA, ISYMB, ISYMAB, LEN 4067 INTEGER IINT1, IINT2 4068 4069#if defined (SYS_CRAY) 4070 REAL WORK(LWORK) 4071 REAL XNORM 4072 REAL DDOT 4073#else 4074 DOUBLE PRECISION WORK(LWORK) 4075 DOUBLE PRECISION XNORM 4076 DOUBLE PRECISION DDOT 4077#endif 4078 4079* external function: 4080 INTEGER ILSTSYM 4081 4082 CALL QENTER('CCBSAVE') 4083 4084*---------------------------------------------------------------------* 4085* Fock, BF and R intermediates: 4086*---------------------------------------------------------------------* 4087 DO IINT1 = I1HGH(IBATCH-1)+1, I1HGH(IBATCH) 4088 LIST = VTABLE(INTMED1(2,IINT1)) 4089 IDLST = INTMED1(1,IINT1) 4090 ISYM = ILSTSYM(LIST,IDLST) 4091 4092* BF intermediate: 4093 IF (.NOT. (CCS .OR. CC2)) THEN 4094 LEN = NT2AOIJ(ISYM) 4095 CALL CC_WVEC(LUBF,BFFIL, LENBF,LEN,IINT1,WORK(KRHO2(IINT1))) 4096 IF (LOCDBG) THEN 4097 XNORM = DDOT(LEN,WORK(KRHO2(IINT1)),1,WORK(KRHO2(IINT1)),1) 4098 WRITE (LUPRI,*) 'Norm of saved BF intermediate nb. ', 4099 & IINT1, ' is ', XNORM 4100 END IF 4101 END IF 4102 4103* R intermediate: 4104 IF (.NOT. (CCS .OR. CC2)) THEN 4105 LEN = NEMAT1(ISYM) 4106 CALL CC_WVEC(LUR,RFIL,LENR,LEN,IINT1,WORK(KRIM(IINT1))) 4107 IF (LOCDBG) THEN 4108 XNORM = DDOT(LEN,WORK(KRIM(IINT1)),1,WORK(KRIM(IINT1)),1) 4109 WRITE (LUPRI,*) 'Norm of saved R intermediate nb. ', 4110 & IINT1, ' is ', XNORM 4111 END IF 4112 END IF 4113 4114* Fock intermediate: 4115 IF (.NOT.(CCSD.OR.CCSDT)) THEN 4116 LEN = N2BST(ISYM) 4117 CALL CC_WVEC (LUFK,FKFIL,LENFK,LEN,IINT1,WORK(KFOCK(IINT1))) 4118 IF (LOCDBG) THEN 4119 XNORM = DDOT(LEN,WORK(KFOCK(IINT1)),1,WORK(KFOCK(IINT1)),1) 4120 WRITE (LUPRI,*) 'Norm of saved FOCK intermediate nb. ', 4121 & IINT1, ' is ', XNORM 4122 END IF 4123 END IF 4124 4125 4126 END DO 4127 4128*---------------------------------------------------------------------* 4129* F term: 4130*---------------------------------------------------------------------* 4131 IF (CC2) THEN 4132 DO IINT2 = I2HGH(IBATCH-1)+1, I2HGH(IBATCH) 4133 LISTA = VTABLE(INTMED2(2,IINT2)) 4134 LISTB = VTABLE(INTMED2(4,IINT2)) 4135 IDLSTA = INTMED2(1,IINT2) 4136 IDLSTB = INTMED2(3,IINT2) 4137 ISYMA = ILSTSYM(LISTA,IDLSTA) 4138 ISYMB = ILSTSYM(LISTB,IDLSTB) 4139 ISYMAB = MULD2H(ISYMA,ISYMB) 4140 LEN = NT2AM(ISYMAB) 4141 CALL CC_WVEC(LUF,FFIL,LENF,LEN,IINT2,WORK(KOMEG(IINT2))) 4142 IF (LOCDBG) THEN 4143 XNORM = DDOT(LEN,WORK(KOMEG(IINT2)),1,WORK(KOMEG(IINT2)),1) 4144 WRITE (LUPRI,*) 'Norm of saved F intermediate nb. ', 4145 & IINT2, ' is ', XNORM 4146 END IF 4147 END DO 4148 END IF 4149 4150 CALL QEXIT('CCBSAVE') 4151 4152 RETURN 4153 END 4154*=====================================================================* 4155* END OF SUBROUTINE CCBSAVE 4156*=====================================================================* 4157 4158*---------------------------------------------------------------------* 4159c/* Deck CCB_22CD */ 4160*=====================================================================* 4161 SUBROUTINE CCB_22CD(THETA2,ISYRES,CDBAR,ISYMCD, 4162 & T1AMPA,ISYMTA,T1AMPB,ISYMTB,TERM, WORK,LWORK) 4163*---------------------------------------------------------------------* 4164* 4165* Purpose: to calculate the contribution to the B matrix which 4166* are analog to the 22C/D contribution to the right transf. 4167* 4168* assumes: result vector THETA2 packed 4169* intermediate CDBAR squared 4170* 4171* TERM = 'C' : calculate 22C contribution 4172* 4173* TERM = 'D' : calculate 22D contribution 4174* 4175* 4176* symmetries & variables: 4177* 4178* ISYRES : result vector THETA2 4179* ISYMCD : CDBAR intermediate 4180* ISYMTA : response vector A 4181* ISYMTB : response vector B 4182* 4183* Christof Haettig, January 1997, based on CCG_22CD 4184*=====================================================================* 4185#if defined (IMPLICIT_NONE) 4186 IMPLICIT NONE 4187#else 4188# include "implicit.h" 4189#endif 4190#include "priunit.h" 4191#include "ccsdsym.h" 4192#include "ccorb.h" 4193 4194#if defined (SYS_CRAY) 4195 REAL ZERO, HALF, ONE, TWO 4196#else 4197 DOUBLE PRECISION ZERO, HALF, ONE, TWO 4198#endif 4199 PARAMETER (ZERO = 0.0d0, ONE = 1.0d0, TWO = 2.0d0, HALF = 0.5d0) 4200 4201 CHARACTER TERM*(1) 4202 4203 INTEGER ISYRES, ISYMCD, ISYMTB, ISYMTA 4204 INTEGER LWORK 4205 4206#if defined (SYS_CRAY) 4207 REAL THETA2(*) ! dimension (NT2AM(ISYRES)) 4208 REAL CDBAR(*) ! dimension (NT2SQ(ISYMCD)) 4209 REAL T1AMPA(*) ! dimension (NT1AM(ISYMTA)) 4210 REAL T1AMPB(*) ! dimension (NT1AM(ISYMTB)) 4211 REAL WORK(LWORK) 4212#else 4213 DOUBLE PRECISION THETA2(*) ! dimension (NT2AM(ISYRES)) 4214 DOUBLE PRECISION CDBAR(*) ! dimension (NT2SQ(ISYMCD)) 4215 DOUBLE PRECISION T1AMPA(*) ! dimension (NT1AM(ISYMTA)) 4216 DOUBLE PRECISION T1AMPB(*) ! dimension (NT1AM(ISYMTB)) 4217 DOUBLE PRECISION WORK(LWORK) 4218#endif 4219 4220 INTEGER ISYMB, ISYMAIJ, ISYMCKJ, ISYTATB, ISYMAI, ISYMBJ, ISYMJ 4221 INTEGER KJINT, KSCRT, KEND2, LEND2, KDUM 4222 INTEGER IOPT, IPCK, NAI, NJ, NBJ, NAIBJ 4223 4224 INTEGER INDEX 4225 INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 4226 4227 CALL QENTER('CCB_22CD') 4228 4229* check symmetries: 4230 ISYTATB = MULD2H(ISYMTA,ISYMTB) 4231 4232 IF (ISYRES .NE. MULD2H(ISYTATB,ISYMCD)) THEN 4233 CALL QUIT('Symmetry mismatch in CCB_22CD.') 4234 END IF 4235 4236* check TERM option: 4237 IF (TERM .NE. 'C' .AND. TERM .NE. 'D') THEN 4238 CALL QUIT('CCB_22CD CALLed with illegal TERM option.') 4239 END IF 4240 4241 DO ISYMB = 1, NSYM 4242 ISYMAIJ = MULD2H(ISYMB,ISYRES) ! b batch of result vector 4243 ISYMCKJ = MULD2H(ISYMB,ISYMCD) ! batch of CDBAR^{b}_{ld|i} 4244 4245 IF (ISYMAIJ .NE. MULD2H(ISYMCKJ,ISYTATB)) THEN 4246 CALL QUIT('Symmetry mismatch in CCB_22CD.') 4247 END IF 4248 4249 KJINT = 1 4250 KSCRT = KJINT + NT2BCD(ISYMAIJ) 4251 KEND2 = KSCRT + NT2BCD(ISYMAIJ) 4252 LEND2 = LWORK - KEND2 4253 4254 IF (LEND2 .LT. 0) THEN 4255 CALL QUIT('Insufficient work space in CCB_22CD.') 4256 END IF 4257 4258 DO B = 1, NVIR(ISYMB) 4259 4260*---------------------------------------------------------------------* 4261* calculate double transformed CDBAR intermediate 4262* CDBARtt(ai;j) = CDBAR_{a^A i^B, b j} + CDBAR_{a^B i^A, b j} 4263*---------------------------------------------------------------------* 4264 4265 IOPT = 1 ! coulomb type result (no exchange type) 4266 IPCK = 2 ! CDBAR intermediate is stored as a squared vector 4267 KDUM = -99 999 999 ! dummy address 4268 CALL CCG_OOVV(WORK(KJINT),WORK(KDUM),ISYMAIJ,CDBAR,ISYMCD, 4269 & T1AMPA, ISYMTA, T1AMPB, ISYMTB, 4270 & WORK(KEND2), LEND2, B, ISYMB, IOPT, IPCK) 4271 4272*---------------------------------------------------------------------* 4273* for 22D contribution scale with +1/2 4274*---------------------------------------------------------------------* 4275 IF (TERM .EQ. 'D') THEN 4276 CALL DSCAL(NT2BCD(ISYMAIJ),HALF,WORK(KJINT),1) 4277 END IF 4278 4279*---------------------------------------------------------------------* 4280* for the 22C contribution apply +1/2 * (1 + 2 * Pij) 4281*---------------------------------------------------------------------* 4282 IF (TERM .EQ. 'C') THEN 4283 CALL DCOPY(NT2BCD(ISYMAIJ), WORK(KJINT),1, WORK(KSCRT),1) 4284 4285 CALL CCLT_P21I(WORK(KSCRT), ISYMAIJ, WORK(KEND2), LEND2, 4286 & IT2BCD, NT2BCD, IT1AM, NT1AM, NVIR) 4287 4288 CALL DAXPY(NT2BCD(ISYMAIJ),TWO,WORK(KSCRT),1,WORK(KJINT),1) 4289 4290 CALL DSCAL(NT2BCD(ISYMAIJ),HALF,WORK(KJINT),1) 4291 END IF 4292 4293*---------------------------------------------------------------------* 4294* storage in result vector: 4295*---------------------------------------------------------------------* 4296 DO ISYMJ = 1, NSYM 4297 ISYMAI = MULD2H(ISYMJ,ISYMAIJ) 4298 ISYMBJ = MULD2H(ISYMJ,ISYMB) 4299 4300 IF (MULD2H(ISYMAI,ISYMBJ) .NE. ISYRES) THEN 4301 CALL QUIT('Symmetry mismatch in CCB_22CD.') 4302 END IF 4303 4304 DO J = 1, NRHF(ISYMJ) 4305 4306 NBJ = IT1AM(ISYMB,ISYMJ) + NVIR(ISYMB)*(J-1) + B 4307 NJ = KJINT-1+ IT2BCD(ISYMAI,ISYMJ) + NT1AM(ISYMAI)*(J-1) 4308 4309 IF (ISYMAI .EQ. ISYMBJ) THEN 4310 4311 DO NAI = 1, NT1AM(ISYMAI) 4312 NAIBJ = IT2AM(ISYMAI,ISYMBJ) + INDEX(NAI,NBJ) 4313 4314 THETA2(NAIBJ) = THETA2(NAIBJ) + WORK(NJ + NAI) 4315 4316 IF (NAI .EQ. NBJ) THEN 4317 THETA2(NAIBJ) = THETA2(NAIBJ) + WORK(NJ + NAI) 4318 END IF 4319 END DO 4320 4321 ELSE IF (ISYMAI .LT. ISYMBJ) THEN 4322 4323 NAIBJ = IT2AM(ISYMAI,ISYMBJ) + NT1AM(ISYMAI)*(NBJ-1)+1 4324 4325 CALL DAXPY (NT1AM(ISYMAI), ONE, WORK(NJ+1), 1, 4326 & THETA2(NAIBJ), 1) 4327 4328 ELSE IF (ISYMAI .GT. ISYMBJ) THEN 4329 4330 NAIBJ = IT2AM(ISYMBJ,ISYMAI) + NBJ 4331 4332 CALL DAXPY (NT1AM(ISYMAI), ONE, WORK(NJ+1), 1, 4333 & THETA2(NAIBJ), NT1AM(ISYMBJ)) 4334 4335 END IF 4336 4337 END DO ! J 4338 END DO ! ISYMJ 4339 4340 END DO ! B 4341 END DO ! ISYMB 4342 4343 CALL QEXIT('CCB_22CD') 4344 4345 RETURN 4346 END 4347*---------------------------------------------------------------------* 4348* END OF ROUTINE CCB_2CD * 4349*---------------------------------------------------------------------* 4350*---------------------------------------------------------------------* 4351c/* Deck CCB_CDBAR */ 4352*=====================================================================* 4353 SUBROUTINE CCB_CDBAR(TYPE, XIAJB, ISYINT, T2AMP, ISYTAM, 4354 & CDBAR, ISYCDBAR, WORK, LWORK, 4355 & FILE, LUNIT, IOFFSET, IOPT) 4356*---------------------------------------------------------------------* 4357* Purpose: calculate CBAR/DBAR intermediates 4358* 4359* TYPE='C' : calculate CBAR intermediate 4360* TYPE='D' : calculate DBAR intermediate 4361* 4362* IOPT=1,3 : store intermediate in CDBAR 4363* IOPT=2,3 : write CDBAR intermediate to FILE (LUNIT), starting 4364* at position IOFFSET+1 4365* 4366* 4367* N.B. for TYPE='D' the amplitudes T2AMP will be overwritten by 4368* 2*t(ai|bj) - t(aj|bi) 4369* 4370* Written by Christof Haettig, Januar/Februar 1997. 4371*=====================================================================* 4372#if defined (IMPLICIT_NONE) 4373 IMPLICIT NONE 4374#else 4375# include "implicit.h" 4376#endif 4377#include "priunit.h" 4378#include "ccsdinp.h" 4379#include "ccsdsym.h" 4380#include "ccorb.h" 4381 4382* local parameters: 4383 LOGICAL LOCDBG 4384 PARAMETER (LOCDBG = .FALSE.) 4385 4386 CHARACTER*(*) TYPE, FILE 4387 INTEGER LWORK, ISYTAM, ISYINT, ISYCDBAR, LUNIT, IOFFSET, IOPT 4388 INTEGER ISYMA, ISYMI, ISYMCK, ISYTINT, ISYCINT, ISYMAI 4389 INTEGER KTINT, KCINT, KEND1, LWRK1, KOFF1, KOFF2, LEN, NAI, IERR 4390 4391#if defined (SYS_CRAY) 4392 REAL WORK(LWORK) 4393 REAL T2AMP(*) ! dimension (NT2AM(ISYTAM)) 4394 REAL XIAJB(*) ! dimension (NT2SQ(ISYINT)) 4395 REAL CDBAR(*) ! dimension (NT2SQ(ISYCDBAR)) 4396 REAL ONE, XNORM, DDOT 4397#else 4398 DOUBLE PRECISION WORK(LWORK) 4399 DOUBLE PRECISION T2AMP(*) ! dimension (NT2AM(ISYTAM)) 4400 DOUBLE PRECISION XIAJB(*) ! dimension (NT2SQ(ISYINT)) 4401 DOUBLE PRECISION CDBAR(*) ! dimension (NT2SQ(ISYCDBAR)) 4402 DOUBLE PRECISION ONE, XNORM, DDOT 4403#endif 4404 PARAMETER (ONE = 1.0d0) 4405 4406 INTEGER IOPTZWVI, ISYTIN, ISYCIN, IOPTTCME 4407 4408 CALL QENTER('CCB_CDBAR') 4409 4410*---------------------------------------------------------------------* 4411* check symmetries: 4412*---------------------------------------------------------------------* 4413 IF (MULD2H(ISYTAM,ISYINT) .NE. ISYCDBAR) THEN 4414 WRITE (LUPRI,*) 'ERROR> SYMMETRY MISMATCH IN CCB_CDBAR.' 4415 CALL QUIT('SYMMETRY MISMATCH IN CCB_CDBAR.') 4416 END IF 4417 4418 IF (LOCDBG) THEN 4419 WRITE (LUPRI,*) 'Entered CDBAR: TYPE, LWORK:',TYPE,LWORK 4420 XNORM = 0.0d0 4421 END IF 4422 4423*---------------------------------------------------------------------* 4424* prepare (ia|jb) integrals, and amplitudes for contraction: 4425*---------------------------------------------------------------------* 4426 IF (TYPE(1:1).EQ.'C') THEN 4427 4428* for CBAR intermediate transpose (ia|jb) to (ja|ib): 4429 4430 CALL CCSD_T2TP(XIAJB,WORK,LWORK,ISYINT) 4431 4432 IOPTZWVI = 2 4433 4434 ELSE IF (TYPE(1:1).EQ.'D') THEN 4435 4436* for DBAR intermediate calculate L(ia|jb) and 4437* 2T(ia|jb)-T(ib|ja) in place: 4438 4439 CALL CCRHS_T2TR(XIAJB,WORK,LWORK,ISYINT) 4440 IOPTTCME = 1 4441 CALL CCSD_TCMEPK(T2AMP,ONE,ISYTAM,IOPTTCME) 4442 4443 IOPTZWVI = 1 4444 4445 ELSE 4446 CALL QUIT('ILLEGAL OPTION IN CCB_CDBAR.') 4447 END IF 4448 4449*---------------------------------------------------------------------* 4450* start loop over virtual orbital index a: 4451*---------------------------------------------------------------------* 4452 DO ISYMA = 1, NSYM 4453 ISYTIN = MULD2H(ISYTAM,ISYMA) 4454 ISYCIN = MULD2H(ISYTIN,ISYINT) 4455 4456 KTINT = 1 4457 KCINT = KTINT + NT2BCD(ISYTIN) 4458 KEND1 = KCINT + NT2BCD(ISYCIN) 4459 4460 LWRK1 = LWORK - KEND1 4461 IF (LWRK1 .LE. 0) THEN 4462 CALL QUIT('Insufficient work space in CCB_CDBAR.') 4463 END IF 4464 4465 DO A = 1, NVIR(ISYMA) 4466 4467*---------------------------------------------------------------------* 4468* get t^{a}(bj,i) submatrix of the t amplitudes 4469*---------------------------------------------------------------------* 4470 CALL CCG_TI(WORK(KTINT),ISYTIN,T2AMP,ISYTAM,A,ISYMA) 4471 4472*---------------------------------------------------------------------* 4473* calculate CBAR^{a}(ck,i) intermediate 4474*---------------------------------------------------------------------* 4475 Call CC_ZWVI(WORK(KCINT), XIAJB, ISYINT, WORK(KTINT), 4476 & ISYTIN, WORK(KEND1), LWRK1, IOPTZWVI) 4477 4478*---------------------------------------------------------------------* 4479* resort to CDBAR(ck,ai) and write to output variable/file: 4480* (for CBAR intermediate scale with -1) 4481*---------------------------------------------------------------------* 4482 DO ISYMI = 1, NSYM 4483 ISYMCK = MULD2H(ISYCIN,ISYMI) 4484 ISYMAI = MULD2H(ISYMA,ISYMI) 4485 LEN = NT1AM(ISYMCK) 4486 4487 IF (LEN.GT.0) THEN 4488 4489 DO I = 1, NRHF(ISYMI) 4490 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I-1) + A 4491 KOFF1 = KCINT + IT2BCD(ISYMCK,ISYMI) + NT1AM(ISYMCK)*(I-1) 4492 KOFF2 = IT2SQ(ISYMCK,ISYMAI) + NT1AM(ISYMCK)*(NAI-1) + 1 4493 4494 IF (TYPE(1:1).EQ.'C') CALL DSCAL(LEN,-ONE,WORK(KOFF1),1) 4495 4496 IF (IOPT.EQ.1 .OR. IOPT.EQ.3) THEN 4497 CALL DCOPY(LEN,WORK(KOFF1),1,CDBAR(KOFF2),1) 4498 END IF 4499 IF (LOCDBG) THEN 4500 XNORM = XNORM + DDOT(LEN,WORK(KOFF1),1,WORK(KOFF1),1) 4501 END IF 4502 4503 IF (IOPT.EQ.2 .OR. IOPT.EQ.3) THEN 4504 CALL PUTWA2(LUNIT,FILE,WORK(KOFF1),IOFFSET+KOFF2,LEN) 4505 END IF 4506 4507 END DO 4508 4509 END IF 4510 4511 END DO 4512 4513 4514 END DO 4515 END DO 4516 4517*---------------------------------------------------------------------* 4518* reconstruct (ia|jb) integrals: 4519*---------------------------------------------------------------------* 4520 IF (TYPE(1:1).EQ.'C') THEN 4521 CALL CCSD_T2TP(XIAJB,WORK,LWORK,ISYINT) 4522 ELSE IF (TYPE(1:1).EQ.'D') THEN 4523 CALL CCRHS_T2BT(XIAJB,WORK,LWORK,ISYINT) 4524 ELSE 4525 CALL QUIT('ILLEGAL OPTION IN CCB_CDBAR.') 4526 END IF 4527 4528 IF (LOCDBG) THEN 4529 WRITE (LUPRI,*) 'Norm of ',TYPE,'BAR intermediate is ',XNORM 4530 END IF 4531 4532 CALL QEXIT('CCB_CDBAR') 4533 4534 RETURN 4535 END 4536*=====================================================================* 4537* END OF SUBROUTINE CCB_CDBAR 4538*=====================================================================* 4539*=====================================================================* 4540 SUBROUTINE CC_FDB(NC1VEC,NC2VEC,NCR12VEC,TXAM,TYAM,RESULT, 4541 & WORK,LWORK,APROXR12) 4542*--------------------------------------------------------------------- 4543* Test routine for calculating the CC B matrix by finite difference 4544* on the right hand Jacobian transformation. 4545* Ch. Haettig, februar 1997 4546* 4547* adapted for CC-R12 4548* Christian Neiss, november 2005 4549*--------------------------------------------------------------------- 4550#include "implicit.h" 4551#include "priunit.h" 4552#include "dummy.h" 4553#include "maxorb.h" 4554#include "iratdef.h" 4555#include "ccorb.h" 4556#include "aovec.h" 4557#include "ccsdinp.h" 4558#include "cclr.h" 4559#include "ccsdsym.h" 4560#include "ccsdio.h" 4561#include "leinf.h" 4562#include "r12int.h" 4563#include "ccr12int.h" 4564C 4565 DIMENSION WORK(LWORK),ITADR(2),RESULT(*) 4566 PARAMETER (XHALF = 0.5D00,XMTWO = -2.0D00, DELTA = 1.0D-07) 4567 PARAMETER (ONE = 1.0d0, ZERO = 0.0d0, TWO = 2.0d0) 4568 CHARACTER MODEL*10, APROXR12*3 4569 LOGICAL L1TST,L2TST, LETST 4570C 4571 INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J 4572C 4573 CALL QENTER('CC_FDB') 4574C 4575 MODEL = 'CCSD ' 4576 IF (CCS) MODEL = 'CCS ' 4577 IF (CC2) MODEL = 'CC2 ' 4578 IF (CC3) MODEL = 'CC3 ' 4579C 4580 IF (CCR12) CALL CCSD_MODEL(MODEL,LENMOD,24,MODEL,10,APROXR12) 4581C 4582 IF (IPRINT.GT.5) THEN 4583 CALL AROUND( 'IN CC_FDB : MAKING FINITE DIFF. CC B Matrix') 4584 ENDIF 4585C 4586C---------------------- 4587C Set Test options. 4588C---------------------- 4589C 4590 L1TST = .FALSE. 4591 L2TST = .FALSE. 4592 LETST = .TRUE. 4593C 4594C---------------------------- 4595C Work space allocations. 4596C---------------------------- 4597C 4598 ISYMTR = 1 4599 ISYMOP = 1 4600C 4601 IF (CCR12) THEN 4602 NTAMR12 = NTR12AM(ISYMTR) 4603 ELSE 4604 NTAMR12 = 0 4605 END IF 4606C 4607 NTAMP = NT1AM(ISYMTR) + NT2AM(ISYMTR) + NTAMR12 4608 NTAMP2 = NTAMP*(NC1VEC + NC2VEC + NCR12VEC) 4609 KF = 1 4610 KRHO1 = KF + NTAMP2 4611 KRHO2 = KRHO1 + NT1AMX 4612 KRHO12 = KRHO2 + MAX(NT2AMX,NT2AM(ISYMTR)) 4613C KC1AM = KRHO12 + NTAMR12 4614C KC2AM = KC1AM + NT1AM(ISYMTR) 4615C KC12AM = KC2AM + NT2AM(ISYMTR) 4616C KEND1 = KC2AM 4617C * + MAX(NT2AMX,NT2AM(ISYMTR),NT2SQ(ISYMTR), 4618C * NT2R12(ISYMTR)) + NTAMR12 4619C KEND1 = KC12AM + NTAMR12 4620C LWRK1 = LWORK - KEND1 4621C 4622C KRHO1D = KEND1 4623C KRHO2D = KRHO1D + NT1AMX 4624C KRHO12D = KRHO2D + NT2AMX 4625C KEND2 = KRHO2D 4626C * + MAX(NT2AMX,NT2AM(ISYMTR),NT2AO(ISYMTR), 4627C * 2*NT2ORT(ISYMTR)) + NTAMR12 4628C LWRK2 = LWORK - KEND2 4629C 4630 KC1AM = KRHO12 + NTAMR12 4631 KEND1 = KC1AM + MAX(NT1AM(ISYMTR),NTAMP) 4632 LWRK1 = LWORK - KEND1 4633C 4634 KRHO1D = KEND1 4635 KRHO2D = KRHO1D + NT1AMX 4636 KRHO12D = KRHO2D + NT2AMX 4637 KC2AM = KRHO2D 4638 * + MAX(NT2AMX,NT2AM(ISYMTR),NT2AO(ISYMTR), 4639 * 2*NT2ORT(ISYMTR)) + NTAMR12 4640 KC12AM = KC2AM + NT2AM(ISYMTR) 4641 KEND2 = KC2AM 4642 * + MAX(NT2AMX,NT2AM(ISYMTR),NT2SQ(ISYMTR), 4643 * NT2R12(ISYMTR)) + NTAMR12 4644 LWRK2 = LWORK - KEND2 4645C 4646 IF (IPRINT .GT. 100 ) THEN 4647 WRITE(LUPRI,*) ' IN CC_FDB: KF = ',KF 4648 WRITE(LUPRI,*) ' IN CC_FDB: KRHO1 = ',KRHO1 4649 WRITE(LUPRI,*) ' IN CC_FDB: KRHO2 = ',KRHO2 4650 WRITE(LUPRI,*) ' IN CC_FDB: KC1AM = ',KC1AM 4651 WRITE(LUPRI,*) ' IN CC_FDB: KC2AM = ',KC2AM 4652 WRITE(LUPRI,*) ' IN CC_FDB: KRHO1D = ',KRHO1D 4653 WRITE(LUPRI,*) ' IN CC_FDB: KRHO2D = ',KRHO2D 4654 WRITE(LUPRI,*) ' IN CC_FDB: KEND2 = ',KEND2 4655 WRITE(LUPRI,*) ' IN CC_FDB: LWRK2 = ',LWRK2 4656 ENDIF 4657 IF (LWRK2.LT.0 ) THEN 4658 WRITE(LUPRI,*) 'Too little work space in CC_FDB ' 4659 WRITE(LUPRI,*) 'AVAILABLE: LWORK = ',LWORK 4660 WRITE(LUPRI,*) 'NEEDED (AT LEAST) = ',KEND2 4661 CALL QUIT('TOO LITTLE WORKSPACE IN CC_FDB ') 4662 ENDIF 4663 KF2 = KF + NC1VEC*NTAMP 4664 KFR = KF + (NC1VEC+NC2VEC)*NTAMP 4665C 4666C--------------------- 4667C Initializations. 4668C--------------------- 4669C 4670 CALL DZERO(WORK(KC1AM),NT1AMX) 4671 CALL DZERO(WORK(KC2AM),NT2AMX) 4672 CALL DZERO(WORK(KC12AM),NTAMR12) 4673 CALL DZERO(WORK(KF),NTAMP2) 4674 IF (ABS(DELTA) .GT. 1.0D-15 ) THEN 4675 DELTAI = 1.0D00/DELTA 4676 ELSE 4677 CALL QUIT('DELTA too small in CC_FDB') 4678C DELTAI = 1 4679 ENDIF 4680 X11 = 0.0D00 4681 X12 = 0.0D00 4682 X21 = 0.0D00 4683 X22 = 0.0D00 4684 XNJ = 0.0D00 4685 XR1 = 0.0D00 4686 X1R = 0.0D00 4687 XR2 = 0.0D00 4688 X2R = 0.0D00 4689 XRR = 0.0D00 4690C 4691C------------------------------------------------ 4692C Read the CC reference amplitudes From disk. 4693C------------------------------------------------ 4694C 4695 IOPT = 3 4696 CALL CC_RDRSP('R0',0,1,IOPT,MODEL,WORK(KC1AM),WORK(KC2AM)) 4697C 4698 IF (CCR12) THEN 4699 IOPT = 32 4700 CALL CC_RDRSP('R0 ',0,1,IOPT,MODEL,DUMMY,WORK(KC12AM)) 4701 END IF 4702C 4703C---------------------------------------------- 4704C Save the CC reference amplitudes on disk. 4705C---------------------------------------------- 4706C 4707 LUTAM = -1 4708 CALL GPOPEN(LUTAM,'TAM_SAV','UNKNOWN',' ','UNFORMATTED',IDUMMY, 4709 * .FALSE.) 4710 REWIND(LUTAM) 4711 WRITE(LUTAM) (WORK(KC1AM + I -1 ), I = 1, NT1AMX) 4712 WRITE(LUTAM) (WORK(KC2AM + I -1 ), I = 1, NT2AMX) 4713 WRITE(LUTAM) (WORK(KC12AM+ I -1 ), I = 1, NTAMR12) 4714 CALL GPCLOSE(LUTAM,'KEEP') 4715C 4716 IF (IPRINT.GT.125) THEN 4717 RHO1N = DDOT(NT1AMX,WORK(KC1AM),1,WORK(KC1AM),1) 4718 RHO2N = DDOT(NT2AMX,WORK(KC2AM),1,WORK(KC2AM),1) 4719 RHO12N = DDOT(NTAMR12,WORK(KC12AM),1,WORK(KC12AM),1) 4720 WRITE(LUPRI,*) 'Norm of T1AM: ',RHO1N 4721 WRITE(LUPRI,*) 'Norm of T2AM: ',RHO2N 4722 IF (CCR12) WRITE(LUPRI,*) 'Norm of R12 amplitudes: ',RHO12N 4723 CALL CC_PRP(WORK(KC1AM),WORK(KC2AM),1,1,1) 4724 IF (CCR12) CALL CC_PRPR12(WORK(KC12AM),1,1,.TRUE.) 4725 ENDIF 4726C 4727 RSPIM = .TRUE. 4728 CALL CCRHSN(WORK(KRHO1D),WORK(KRHO2D),WORK(KC1AM), 4729 * WORK(KC2AM),WORK(KEND2),LWRK2,APROXR12) 4730C 4731C------------------------------------------ 4732C Calculate reference A*T vector. 4733C------------------------------------------ 4734C 4735 CALL DCOPY(NTAMP,TXAM,1,WORK(KRHO1D),1) 4736 ISIDE = +1 4737 CALL CC_ATRR(0.0D0,1,ISIDE,WORK(KRHO1D),LWRK1,.FALSE.,DUMMY, 4738 & APROXR12,.FALSE.) 4739C 4740C------------------------- 4741C Zero out components. 4742C------------------------- 4743C 4744 IF (LCOR .OR. LSEC) THEN 4745C 4746 CALL CC_CORE(WORK(KRHO1D),WORK(KRHO2D),ISYMTR) 4747C 4748 ENDIF 4749C 4750 IF (IPRINT.GT.2) THEN 4751 RHO1N = DDOT(NT1AMX,WORK(KRHO1D),1,WORK(KRHO1D),1) 4752 RHO2N = DDOT(NT2AMX,WORK(KRHO2D),1,WORK(KRHO2D),1) 4753 RHO12N = DDOT(NTAMR12,WORK(KRHO12D),1,WORK(KRHO12D),1) 4754 WRITE(LUPRI,*) 'Norm of RHO1: ',RHO1N,'ref' 4755 WRITE(LUPRI,*) 'Norm of RHO2: ',RHO2N,'ref' 4756 IF (CCR12) WRITE(LUPRI,*) 'Norm of RHO-R12: ',RHO12N,'ref' 4757 ENDIF 4758 IF (IPRINT.GT.125) THEN 4759 CALL CC_PRP(WORK(KRHO1D),WORK(KRHO2D),1,1,1) 4760 IF (CCR12) CALL CC_PRPR12(WORK(KRHO12D),1,1,.TRUE.) 4761 ENDIF 4762 4763 CALL DCOPY(NT1AMX,WORK(KRHO1D),1,WORK(KRHO1),1) 4764 CALL DCOPY(NT2AMX,WORK(KRHO2D),1,WORK(KRHO2),1) 4765 CALL DCOPY(NTAMR12,WORK(KRHO12D),1,WORK(KRHO12),1) 4766C 4767C================================================== 4768C calculate intermediates for response vector TXAM: 4769C================================================== 4770C 4771 IF (.FALSE.) THEN 4772 IOPT = 3 4773 CALL CC_WRRSP('R0',0,1,IOPT,MODEL,DUMMY,WORK(KC1AM), 4774 * WORK(KC2AM),WORK(KEND2),LWRK2) 4775C 4776 IF (CCR12) THEN 4777 IOPT = 32 4778 CALL CC_WRRSP('R0 ',0,1,IOPT,MODEL,DUMMY,DUMMY, 4779 & WORK(KC12AM),WORK(KEND2),LWRK2) 4780 END IF 4781C 4782 WRITE (LUPRI,*) 'NTAMP:',NTAMP 4783 WRITE (LUPRI,*) 'NORM TXAM:',DDOT(NTAMP,TXAM,1,TXAM,1) 4784C 4785 RSPIM = .TRUE. 4786 CALL CCRHSN(WORK(KRHO1D),WORK(KRHO2D),WORK(KC1AM), 4787 * WORK(KC2AM),WORK(KEND2),LWRK2,APROXR12) 4788 END IF 4789C------------------------------------- 4790C read E intermediates: 4791C------------------------------------- 4792 IF (LETST) THEN 4793 KEI1 = KEND2 4794 KEI2 = KEI1 + NMATAB(1) 4795 KEND3 = KEI2 + NMATIJ(1) 4796 LWRK3 = LWORK - KEND3 4797 4798 IF (LWRK3.LT.0 ) THEN 4799 CALL QUIT('Insufficient memory in CC_FDB.') 4800 END IF 4801C 4802 LUE1 = -1 4803 CALL GPOPEN(LUE1,'CC_E1IM','UNKNOWN',' ','UNFORMATTED',IDUMMY, 4804 & .FALSE.) 4805 REWIND(LUE1) 4806 READ (LUE1)(WORK(KEI1+ J-1),J = 1,NMATAB(ISYMOP)) 4807 CALL GPCLOSE(LUE1,'KEEP' ) 4808C 4809 LUE2 = -1 4810 CALL GPOPEN(LUE2,'CC_E2IM','UNKNOWN',' ','UNFORMATTED',IDUMMY, 4811 & .FALSE.) 4812 REWIND(LUE2) 4813 READ (LUE2) (WORK(KEI2+ J-1),J = 1,NMATIJ(ISYMOP)) 4814 CALL GPCLOSE(LUE2,'KEEP' ) 4815C 4816 CALL AROUND( 'E^X-intermediates read from disk ') 4817 CALL CC_PREI(WORK(KEI1),WORK(KEI2),ISYMOP,1) 4818 END IF 4819 4820C 4821C============================================= 4822C Calculate B-matrix by finite difference. 4823C============================================= 4824C 4825 DO 100 I = 1, NC1VEC 4826 WRITE (LUPRI,*) 'singles index:',I 4827C 4828C---------------------------------------- 4829C Add finite displadement to t and 4830C calculate new intermediates. 4831C---------------------------------------- 4832C 4833 LUTAM = -1 4834 CALL GPOPEN(LUTAM,'TAM_SAV','UNKNOWN',' ','UNFORMATTED',IDUMMY, 4835 * .FALSE.) 4836 REWIND(LUTAM) 4837 READ(LUTAM) (WORK(KC1AM + J -1 ) , J = 1, NT1AMX) 4838 READ(LUTAM) (WORK(KC2AM + J -1 ) , J = 1, NT2AMX) 4839 READ(LUTAM) (WORK(KC12AM+ J -1 ) , J = 1, NTAMR12) 4840 CALL GPCLOSE(LUTAM,'KEEP') 4841C 4842 TI = SECOND() 4843 WORK(KC1AM +I -1) = WORK(KC1AM +I -1 ) + DELTA 4844 IF (LCOR .OR. LSEC) THEN 4845 CALL CC_CORE(WORK(KC1AM),WORK(KC2AM),ISYMTR) 4846 ENDIF 4847C 4848 IOPT = 3 4849 CALL CC_WRRSP('R0',0,1,IOPT,MODEL,DUMMY,WORK(KC1AM), 4850 * WORK(KC2AM),WORK(KEND2),LWRK2) 4851C 4852 IF (CCR12) THEN 4853 IOPT = 32 4854 CALL CC_WRRSP('R0 ',0,1,IOPT,MODEL,DUMMY,DUMMY, 4855 & WORK(KC12AM),WORK(KEND2),LWRK2) 4856 END IF 4857C 4858 RSPIM = .TRUE. 4859 CALL CCRHSN(WORK(KRHO1D),WORK(KRHO2D),WORK(KC1AM), 4860 * WORK(KC2AM),WORK(KEND2),LWRK2,APROXR12) 4861C 4862C--------------------------------------------- 4863C Get the CC response vector again. 4864C--------------------------------------------- 4865C 4866 CALL DCOPY(NTAMP,TXAM,1,WORK(KC1AM),1) 4867C 4868C--------------------------------------- 4869C For Test zero part of T vector. 4870C--------------------------------------- 4871C 4872 IF ( L1TST ) THEN 4873C CALL DZERO(WORK(KC2AM),NT2AMX) 4874C CALL DZERO(WORK(KC12AM),NTAMR12) 4875 CALL DZERO(WORK(KC1AM+NT1AMX),NT2AMX) 4876 CALL DZERO(WORK(KC1AM+NT1AMX+NT2AMX),NTAMR12) 4877 ENDIF 4878 IF ( L2TST ) THEN 4879 CALL DZERO(WORK(KC1AM),NT1AMX) 4880C CALL DZERO(WORK(KC12AM),NTAMR12) 4881 CALL DZERO(WORK(KC1AM+NT1AMX+NT2AMX),NTAMR12) 4882 ENDIF 4883C 4884C------------------ 4885C Transform. 4886C------------------ 4887C 4888 CALL DCOPY(NTAMP,WORK(KC1AM),1,WORK(KRHO1D),1) 4889 4890 ISIDE = +1 4891 CALL CC_ATRR(0.0D0,1,ISIDE,WORK(KRHO1D),LWRK1,.FALSE.,DUMMY, 4892 & APROXR12,.FALSE.) 4893C 4894 IF (LCOR .OR. LSEC) THEN 4895 CALL CC_CORE(WORK(KRHO1D),WORK(KRHO2D),ISYMTR) 4896 ENDIF 4897C 4898 IF (IPRINT.GT.2) THEN 4899 RHO1N = DDOT(NT1AMX,WORK(KRHO1D),1,WORK(KRHO1D),1) 4900 RHO2N = DDOT(NT2AMX,WORK(KRHO2D),1,WORK(KRHO2D),1) 4901 RHO12N = DDOT(NTAMR12,WORK(KRHO12D),1,WORK(KRHO12D),1) 4902 WRITE(LUPRI,*) 'Norm of RHO1: ',RHO1N,'ai=',I 4903 WRITE(LUPRI,*) 'Norm of RHO2: ',RHO2N,'ai=',I 4904 IF (CCR12) WRITE(LUPRI,*) 'Norm of RHO-R12: ',RHO12N,'ai=',I 4905 ENDIF 4906 IF (IPRINT.GT.125) THEN 4907 CALL CC_PRP(WORK(KRHO1D),WORK(KRHO2D),1,1,1) 4908 IF (CCR12) CALL CC_PRPR12(WORK(KRHO12D),1,1,.TRUE.) 4909 ENDIF 4910 4911 CALL DAXPY(NT1AMX,-1.0D00,WORK(KRHO1),1,WORK(KRHO1D),1) 4912 CALL DAXPY(NT2AMX,-1.0D00,WORK(KRHO2),1,WORK(KRHO2D),1) 4913 CALL DAXPY(NTAMR12,-1.0D00,WORK(KRHO12),1,WORK(KRHO12D),1) 4914 CALL DSCAL(NT1AMX,DELTAI,WORK(KRHO1D),1) 4915 CALL DSCAL(NT2AMX,DELTAI,WORK(KRHO2D),1) 4916 CALL DSCAL(NTAMR12,DELTAI,WORK(KRHO12D),1) 4917 CALL DCOPY(NT1AMX,WORK(KRHO1D),1, 4918 * WORK(KF+NTAMP*(I-1)),1) 4919 CALL DCOPY(NT2AMX,WORK(KRHO2D),1, 4920 * WORK(KF+NTAMP*(I-1)+NT1AMX),1) 4921 CALL DCOPY(NTAMR12,WORK(KRHO12D),1, 4922 & WORK(KF+NTAMP*(I-1)+NT1AMX+NT2AMX),1) 4923 X11 = X11 + DDOT(NT1AMX,WORK(KRHO1D),1,WORK(KRHO1D),1) 4924 X21 = X21 + DDOT(NT2AMX,WORK(KRHO2D),1,WORK(KRHO2D),1) 4925 XR1 = XR1 + DDOT(NTAMR12,WORK(KRHO12D),1,WORK(KRHO12D),1) 4926C 4927 TI = SECOND() - TI 4928 IF (IPRINT.GT.5 ) THEN 4929 WRITE(LUPRI,*) ' ' 4930 WRITE(LUPRI,*) 'FDB ROW NR. ',I,' DONE IN ',TI,' SEC.' 4931 ENDIF 4932C 4933 100 CONTINUE 4934C 4935C---------------------------------------------------------------- 4936C Loop over T2 amplitudes. Take care of diagonal t2 elements 4937C is in a different convention in the energy code. 4938C Factor 1/2 from right , and factor 2 from left. 4939C---------------------------------------------------------------- 4940C 4941 IF (.NOT. (CCS .OR. CCSTST)) THEN 4942 DO 200 NAI = 1, NT1AMX 4943 DO 300 NBJ = 1, NAI 4944 I = INDEX(NAI,NBJ) 4945C 4946 IF (I.LE.NC2VEC) THEN 4947 WRITE (LUPRI,*) 'doubles index:',I 4948C 4949C-------------------------------------------- 4950C Add finite displacement to t and 4951C calculate new intermediates. 4952C------------------------------------------- 4953C 4954 LUTAM = -1 4955 CALL GPOPEN(LUTAM,'TAM_SAV','UNKNOWN',' ','UNFORMATTED', 4956 * IDUMMY,.FALSE.) 4957 REWIND(LUTAM) 4958 READ(LUTAM) (WORK(KC1AM + J -1 ) , J = 1, NT1AMX) 4959 READ(LUTAM) (WORK(KC2AM + J -1 ) , J = 1, NT2AMX) 4960 READ(LUTAM) (WORK(KC12AM+ J -1 ) , J = 1, NTAMR12) 4961 CALL GPCLOSE(LUTAM,'KEEP') 4962C 4963 TI = SECOND() 4964 DELT = DELTA 4965 IF (NAI.EQ.NBJ) DELT = 2*DELTA 4966 WORK(KC2AM + I -1) = WORK(KC2AM+I -1) + DELT 4967 IF (LCOR .OR. LSEC) THEN 4968 CALL CC_CORE(WORK(KC1AM),WORK(KC2AM),ISYMTR) 4969 ENDIF 4970C 4971 IOPT = 3 4972 CALL CC_WRRSP('R0',0,1,IOPT,MODEL,DUMMY,WORK(KC1AM), 4973 * WORK(KC2AM),WORK(KEND2),LWRK2) 4974C 4975 IF (CCR12) THEN 4976 IOPT = 32 4977 CALL CC_WRRSP('R0 ',0,1,IOPT,MODEL,DUMMY,DUMMY, 4978 & WORK(KC12AM),WORK(KEND2),LWRK2) 4979 END IF 4980C 4981 RSPIM = .TRUE. 4982 CALL CCRHSN(WORK(KRHO1D),WORK(KRHO2D),WORK(KC1AM), 4983 * WORK(KC2AM),WORK(KEND2),LWRK2,APROXR12) 4984C 4985C----------------------------------------------- 4986C Get the CC response vector again. 4987C----------------------------------------------- 4988C 4989 CALL DCOPY(NTAMP,TXAM,1,WORK(KC1AM),1) 4990C 4991C----------------------------------------- 4992C For Test zero part of T vector. 4993C----------------------------------------- 4994C 4995 IF ( L1TST ) THEN 4996C CALL DZERO(WORK(KC2AM),NT2AMX) 4997C CALL DZERO(WORK(KC12AM),NTAMR12) 4998 CALL DZERO(WORK(KC1AM+NT1AMX),NT2AMX) 4999 CALL DZERO(WORK(KC1AM+NT1AMX+NT2AMX),NTAMR12) 5000 ENDIF 5001 IF ( L2TST ) THEN 5002 CALL DZERO(WORK(KC1AM),NT1AMX) 5003C CALL DZERO(WORK(KC12AM),NTAMR12) 5004 CALL DZERO(WORK(KC1AM+NT1AMX+NT2AMX),NTAMR12) 5005 ENDIF 5006C 5007 RHO1N = DDOT(NT1AMX,WORK(KC1AM),1,WORK(KC1AM),1) 5008 RHO2N = DDOT(NT2AMX,WORK(KC2AM),1,WORK(KC2AM),1) 5009 RHO12N = DDOT(NTAMR12,WORK(KC12AM),1,WORK(KC12AM),1) 5010 IF ( DEBUG ) THEN 5011 WRITE(LUPRI,*) 'Norm of L1AM-inp: ',RHO1N 5012 WRITE(LUPRI,*) 'Norm of L2AM-inp: ',RHO2N 5013 IF (CCR12) WRITE(LUPRI,*) 'Norm of LR12AM-inp: ',RHO12N 5014 ENDIF 5015C 5016C-------------------- 5017C Transform. 5018C-------------------- 5019C 5020 CALL DCOPY(NTAMP,WORK(KC1AM),1,WORK(KRHO1D),1) 5021 5022 ISIDE = +1 5023 CALL CC_ATRR(0.0D0,1,ISIDE,WORK(KRHO1D),LWRK1,.FALSE.,DUMMY, 5024 & APROXR12,.FALSE.) 5025C 5026 IF (LCOR .OR. LSEC) THEN 5027 CALL CC_CORE(WORK(KRHO1D),WORK(KRHO2D),ISYMTR) 5028 ENDIF 5029C 5030 IF (IPRINT.GT.2) THEN 5031 RHO1N = DDOT(NT1AMX,WORK(KRHO1D),1,WORK(KRHO1D),1) 5032 RHO2N = DDOT(NT2AMX,WORK(KRHO2D),1,WORK(KRHO2D),1) 5033 RHO12N = DDOT(NTAMR12,WORK(KRHO12D),1,WORK(KRHO12D),1) 5034 WRITE(LUPRI,*) 'Norm of RHO1: ',RHO1N,'aibj=',I 5035 WRITE(LUPRI,*) 'Norm of RHO2: ',RHO2N,'aibj=',I 5036 IF (CCR12) WRITE(LUPRI,*) 'Norm of RHO-R12: ',RHO12N, 5037 & 'aibj=',I 5038 ENDIF 5039 IF (IPRINT.GT.125) THEN 5040 CALL CC_PRP(WORK(KRHO1D),WORK(KRHO2D),1,1,1) 5041 IF (CCR12) CALL CC_PRPR12(WORK(KRHO12D),1,1,.TRUE.) 5042 ENDIF 5043C 5044 CALL DAXPY(NT1AMX,-1.0D00,WORK(KRHO1),1,WORK(KRHO1D),1) 5045 CALL DAXPY(NT2AMX,-1.0D00,WORK(KRHO2),1,WORK(KRHO2D),1) 5046 CALL DAXPY(NTAMR12,-1.0D00,WORK(KRHO12),1,WORK(KRHO12D),1) 5047 CALL DSCAL(NT1AMX,DELTAI,WORK(KRHO1D),1) 5048 CALL DSCAL(NT2AMX,DELTAI,WORK(KRHO2D),1) 5049 CALL DSCAL(NTAMR12,DELTAI,WORK(KRHO12D),1) 5050 CALL DCOPY(NT1AMX,WORK(KRHO1D),1,WORK(KF2+NTAMP*(I-1)),1) 5051 CALL DCOPY(NT2AMX,WORK(KRHO2D),1, 5052 * WORK(KF2+NTAMP*(I-1)+NT1AMX),1) 5053 CALL DCOPY(NTAMR12,WORK(KRHO12D),1, 5054 & WORK(KF2+NTAMP*(I-1)+NT1AMX+NT2AMX),1) 5055C 5056 X12 = X12 + DDOT(NT1AMX,WORK(KRHO1D),1,WORK(KRHO1D),1) 5057 X22 = X22 + DDOT(NT2AMX,WORK(KRHO2D),1,WORK(KRHO2D),1) 5058 XR2 = XR2 + DDOT(NTAMR12,WORK(KRHO12D),1,WORK(KRHO12D),1) 5059 TI = SECOND() - TI 5060 IF (IPRINT.GT.5 ) THEN 5061 WRITE(LUPRI,*) ' ' 5062 WRITE(LUPRI,*) 'FDB ROW NR. ',I+NT1AMX, 5063 * ' DONE IN ',TI,' SEC.' 5064 ENDIF 5065C 5066 ENDIF 5067C 5068 300 CONTINUE 5069 200 CONTINUE 5070 END IF 5071C 5072C---------------------------------------------------------------- 5073C Loop over R12 amplitudes. 5074C---------------------------------------------------------------- 5075C 5076 IF (CCR12) THEN 5077 DO NKI = 1, NMATKI(1) 5078 DO NLJ = 1, NKI 5079 I = INDEX(NKI,NLJ) 5080C 5081 IF (I.LE.NCR12VEC) THEN 5082 WRITE (LUPRI,*) 'R12 doubles index:',I 5083C 5084C-------------------------------------------- 5085C Add finite displacement to t and 5086C calculate new intermediates. 5087C------------------------------------------- 5088C 5089 LUTAM = -1 5090 CALL GPOPEN(LUTAM,'TAM_SAV','UNKNOWN',' ','UNFORMATTED', 5091 * IDUMMY,.FALSE.) 5092 REWIND(LUTAM) 5093 READ(LUTAM) (WORK(KC1AM + J -1 ) , J = 1, NT1AMX) 5094 READ(LUTAM) (WORK(KC2AM + J -1 ) , J = 1, NT2AMX) 5095 READ(LUTAM) (WORK(KC12AM+ J -1 ) , J = 1, NTAMR12) 5096 CALL GPCLOSE(LUTAM,'KEEP') 5097C 5098 TI = SECOND() 5099 DELT = DELTA 5100 IF (NKI.EQ.NLJ) DELT = KETSCL*DELTA 5101 WORK(KC12AM + I -1) = WORK(KC12AM+I -1) + DELT 5102 IF (LCOR .OR. LSEC) THEN 5103 CALL CC_CORE(WORK(KC1AM),WORK(KC2AM),ISYMTR) 5104 ENDIF 5105C 5106 IOPT = 3 5107 CALL CC_WRRSP('R0',0,1,IOPT,MODEL,DUMMY,WORK(KC1AM), 5108 * WORK(KC2AM),WORK(KEND2),LWRK2) 5109C 5110 IF (CCR12) THEN 5111 IOPT = 32 5112 CALL CC_WRRSP('R0 ',0,1,IOPT,MODEL,DUMMY,DUMMY, 5113 & WORK(KC12AM),WORK(KEND2),LWRK2) 5114 END IF 5115C 5116 RSPIM = .TRUE. 5117 CALL CCRHSN(WORK(KRHO1D),WORK(KRHO2D),WORK(KC1AM), 5118 * WORK(KC2AM),WORK(KEND2),LWRK2,APROXR12) 5119C 5120C----------------------------------------------- 5121C Get the CC response vector again. 5122C----------------------------------------------- 5123C 5124 CALL DCOPY(NTAMP,TXAM,1,WORK(KC1AM),1) 5125C 5126C----------------------------------------- 5127C For Test zero part of T vector. 5128C----------------------------------------- 5129C 5130 IF ( L1TST ) THEN 5131C CALL DZERO(WORK(KC2AM),NT2AMX) 5132C CALL DZERO(WORK(KC12AM),NTAMR12) 5133 CALL DZERO(WORK(KC1AM+NT1AMX),NT2AMX) 5134 CALL DZERO(WORK(KC1AM+NT1AMX+NT2AMX),NTAMR12) 5135 ENDIF 5136 IF ( L2TST ) THEN 5137 CALL DZERO(WORK(KC1AM),NT1AMX) 5138C CALL DZERO(WORK(KC12AM),NTAMR12) 5139 CALL DZERO(WORK(KC1AM+NT1AMX+NT2AMX),NTAMR12) 5140 ENDIF 5141C 5142 RHO1N = DDOT(NT1AMX,WORK(KC1AM),1,WORK(KC1AM),1) 5143 RHO2N = DDOT(NT2AMX,WORK(KC2AM),1,WORK(KC2AM),1) 5144 RHO12N = DDOT(NTAMR12,WORK(KC12AM),1,WORK(KC12AM),1) 5145 IF ( DEBUG ) THEN 5146 WRITE(LUPRI,*) 'Norm of L1AM-inp: ',RHO1N 5147 WRITE(LUPRI,*) 'Norm of L2AM-inp: ',RHO2N 5148 IF (CCR12) WRITE(LUPRI,*) 'Norm of LR12AM-inp: ',RHO12N 5149 ENDIF 5150C 5151C-------------------- 5152C Transform. 5153C-------------------- 5154C 5155 CALL DCOPY(NTAMP,WORK(KC1AM),1,WORK(KRHO1D),1) 5156 5157 ISIDE = +1 5158 CALL CC_ATRR(0.0D0,1,ISIDE,WORK(KRHO1D),LWRK1,.FALSE.,DUMMY, 5159 & APROXR12,.FALSE.) 5160C 5161 IF (LCOR .OR. LSEC) THEN 5162 CALL CC_CORE(WORK(KRHO1D),WORK(KRHO2D),ISYMTR) 5163 ENDIF 5164C 5165 IF (IPRINT.GT.2) THEN 5166 RHO1N = DDOT(NT1AMX,WORK(KRHO1D),1,WORK(KRHO1D),1) 5167 RHO2N = DDOT(NT2AMX,WORK(KRHO2D),1,WORK(KRHO2D),1) 5168 RHO12N = DDOT(NTAMR12,WORK(KRHO12D),1,WORK(KRHO12D),1) 5169 WRITE(LUPRI,*) 'Norm of RHO1: ',RHO1N,'kilj=',I 5170 WRITE(LUPRI,*) 'Norm of RHO2: ',RHO2N,'kilj=',I 5171 IF (CCR12) WRITE(LUPRI,*) 'Norm of RHO-R12: ',RHO12N, 5172 & 'kilj=',I 5173 ENDIF 5174 IF (IPRINT.GT.125) THEN 5175 CALL CC_PRP(WORK(KRHO1D),WORK(KRHO2D),1,1,1) 5176 IF (CCR12) CALL CC_PRPR12(WORK(KRHO12D),1,1,.TRUE.) 5177 ENDIF 5178C 5179 CALL DAXPY(NT1AMX,-1.0D00,WORK(KRHO1),1,WORK(KRHO1D),1) 5180 CALL DAXPY(NT2AMX,-1.0D00,WORK(KRHO2),1,WORK(KRHO2D),1) 5181 CALL DAXPY(NTAMR12,-1.0D00,WORK(KRHO12),1,WORK(KRHO12D),1) 5182 CALL DSCAL(NT1AMX,DELTAI,WORK(KRHO1D),1) 5183 CALL DSCAL(NT2AMX,DELTAI,WORK(KRHO2D),1) 5184 CALL DSCAL(NTAMR12,DELTAI,WORK(KRHO12D),1) 5185 CALL DCOPY(NT1AMX,WORK(KRHO1D),1,WORK(KFR+NTAMP*(I-1)),1) 5186 CALL DCOPY(NT2AMX,WORK(KRHO2D),1, 5187 * WORK(KFR+NTAMP*(I-1)+NT1AMX),1) 5188 CALL DCOPY(NTAMR12,WORK(KRHO12D),1, 5189 & WORK(KFR+NTAMP*(I-1)+NT1AMX+NT2AMX),1) 5190C 5191 X1R = X1R + DDOT(NT1AMX,WORK(KRHO1D),1,WORK(KRHO1D),1) 5192 X2R = X2R + DDOT(NT2AMX,WORK(KRHO2D),1,WORK(KRHO2D),1) 5193 XRR = XRR + DDOT(NTAMR12,WORK(KRHO12D),1,WORK(KRHO12D),1) 5194 TI = SECOND() - TI 5195 IF (IPRINT.GT.5 ) THEN 5196 WRITE(LUPRI,*) ' ' 5197 WRITE(LUPRI,*) 'FDB ROW NR. ',I+NT1AMX+NT2AMX, 5198 * ' DONE IN ',TI,' SEC.' 5199 ENDIF 5200C 5201 ENDIF 5202C 5203 END DO 5204 END DO 5205 END IF 5206C 5207 WRITE(LUPRI,*) ' ' 5208 WRITE(LUPRI,*) '** FINITE DIFF WITH DELTA ',DELTA, '**' 5209 WRITE(LUPRI,*) ' ' 5210 IF ( IPRINT .GT. 4 ) THEN 5211 CALL AROUND('FINITE DIFF. CC B*Tx-Matrix - 11 & 21 (& R12_1)'// 5212 & ' PART') 5213 CALL OUTPUT(WORK(KF),1,NTAMP,1,NC1VEC,NTAMP,NC1VEC,1,LUPRI) 5214 CALL AROUND('FINITE DIFF. CC B*Tx-Matrix - 12 & 22 (& R12_2)'// 5215 & ' PART') 5216 CALL OUTPUT(WORK(KF+NTAMP*NC1VEC),1,NTAMP,1,NC2VEC, 5217 * NTAMP,NC2VEC,1,LUPRI) 5218 IF (CCR12) THEN 5219 CALL AROUND('FINITE DIFF. CC B*Tx-Matrix - 1R12 & 2R12 & '// 5220 & 'R12R12 PART') 5221 CALL OUTPUT(WORK(KF+NTAMP*(NC1VEC+NC2VEC)),1,NTAMP, 5222 & 1,NCR12VEC,NTAMP,NCR12VEC,1,LUPRI) 5223 END IF 5224 ENDIF 5225 5226 XNJ = X11 + X12 + X21 + X22 + XR1 + XR2 + X1R + X2R + XRR 5227 WRITE(LUPRI,*) ' ' 5228 WRITE(LUPRI,*) ' NORM OF FIN. DIFF. B*Tx-Matrix.', SQRT(XNJ) 5229 WRITE(LUPRI,*) ' ' 5230 WRITE(LUPRI,*) ' NORM OF 11 PART OF FD. B*Tx-mat.: ', SQRT(X11) 5231 IF (.NOT.(CCS.OR.CCSTST)) THEN 5232 WRITE(LUPRI,*) ' NORM OF 21 PART OF FD. B*Tx-mat.: ', SQRT(X21) 5233 WRITE(LUPRI,*) ' NORM OF 12 PART OF FD. B*Tx-mat.: ', SQRT(X12) 5234 WRITE(LUPRI,*) ' NORM OF 22 PART OF FD. B*Tx-mat.: ', SQRT(X22) 5235 ENDIF 5236 IF (CCR12) THEN 5237 WRITE(LUPRI,*) ' NORM OF R12_1 PART OF FD. B*Tx-mat.: ', 5238 & SQRT(XR1) 5239 WRITE(LUPRI,*) ' NORM OF R12_2 PART OF FD. B*Tx-mat.: ', 5240 & SQRT(XR2) 5241 WRITE(LUPRI,*) ' NORM OF 1R12 PART OF FD. B*Tx-mat.: ', 5242 & SQRT(X1R) 5243 WRITE(LUPRI,*) ' NORM OF 2R12 PART OF FD. B*Tx-mat.: ', 5244 & SQRT(X2R) 5245 WRITE(LUPRI,*) ' NORM OF R12R12 PART OF FD. B*Tx-mat.: ', 5246 & SQRT(XRR) 5247 END IF 5248C 5249C-------------------------------------- 5250C Calculate Matrix times Ty vector. 5251C-------------------------------------- 5252C 5253 CALL DGEMV('N',NTAMP,NTAMP,ONE,WORK(KF),NTAMP,TYAM,1, 5254 * ZERO,RESULT,1) 5255 5256 IF (CCS.OR.CCSTST) THEN 5257 CALL DZERO(RESULT(NT1AM(1)+1),NT2AM(1)) 5258 END IF 5259C----------------------------------------------------------- 5260C scale diagonal with 1/2 and print norm of the vectors: 5261C----------------------------------------------------------- 5262 CALL CCLR_DIASCL(RESULT(NT1AM(1)+1),TWO,1) 5263 5264 WRITE (LUPRI,*) 'NTAMP:',NTAMP 5265 WRITE (LUPRI,*) 'NORM^2 OF TX VEC.:', 5266 & DDOT(NT1AM(1)+NT2AM(1),TXAM,1,TXAM,1) 5267 WRITE (LUPRI,*) 'single-excitation part:', 5268 & DDOT(NT1AM(1),TXAM,1,TXAM,1) 5269 WRITE (LUPRI,*) 'NORM^2 OF TY VEC.:', 5270 & DDOT(NT1AM(1)+NT2AM(1),TYAM,1,TYAM,1) 5271 WRITE (LUPRI,*) 'single-excitation part:', 5272 & DDOT(NT1AM(1),TYAM,1,TYAM,1) 5273 WRITE (LUPRI,*) 'NORM^2 OF RESULT VECTOR:', 5274 & DDOT(NTAMP,RESULT,1,RESULT,1) 5275 WRITE (LUPRI,*) 'single-excitation part:', 5276 & DDOT(NT1AM(1),RESULT,1,RESULT,1) 5277C 5278C------------------------------------------------- 5279C Restore the CC reference amplitudes on disk. 5280C------------------------------------------------- 5281C 5282 LUTAM = -1 5283 CALL GPOPEN(LUTAM,'TAM_SAV','UNKNOWN',' ','UNFORMATTED',IDUMMY, 5284 * .FALSE.) 5285 REWIND(LUTAM) 5286 READ(LUTAM) (WORK(KC1AM + I -1 ) , I = 1, NT1AMX) 5287 READ(LUTAM) (WORK(KC2AM + I -1 ) , I = 1, NT2AMX) 5288 READ(LUTAM) (WORK(KC12AM+ J -1 ) , J = 1, NTAMR12) 5289 CALL GPCLOSE(LUTAM,'DELETE') 5290C 5291 IOPT = 3 5292 CALL CC_WRRSP('R0',0,1,IOPT,MODEL,DUMMY,WORK(KC1AM), 5293 * WORK(KC2AM),WORK(KEND2),LWRK2) 5294C 5295 IF (CCR12) THEN 5296 IOPT = 32 5297 CALL CC_WRRSP('R0 ',0,1,IOPT,MODEL,DUMMY,DUMMY, 5298 & WORK(KC12AM),WORK(KEND2),LWRK2) 5299 END IF 5300C 5301 RSPIM = .TRUE. 5302 CALL CCRHSN(WORK(KRHO1D),WORK(KRHO2D),WORK(KC1AM),WORK(KC2AM), 5303 * WORK(KEND2),LWRK2,APROXR12) 5304C 5305 CALL AROUND(' END OF CC_FDB ') 5306C 5307 CALL QEXIT('CC_FDB') 5308C 5309 RETURN 5310 END 5311*=====================================================================* 5312c /* deck CCDOTRSP */ 5313*=====================================================================* 5314 SUBROUTINE CCDOTRSP(IDOTS,DOTPROD,IIOPT,TYPE,ITRAN,MXTRAN,MXVEC, 5315 & VEC1,VEC2,ISYVEC,WORK,LWORK) 5316*---------------------------------------------------------------------* 5317* 5318* Purpose: dot vector on a batch of other vectors 5319* which are read from file 5320* 5321* IDOTS -- arrays of vectors to be dotted on 5322* DOTPROD -- array for resulting dot products 5323* 5324* IIOPT -- 1 : use only singles 5325* 2 : use only doubles 5326* 3 : use singles and doubles 5327* 4 : triplet case, doubles only 5328* 5 : triplet case, singles and doubles 5329* 5330* TYPE -- type of vectors to be dotted on 5331* ITRAN -- index of present vector in the 5332* matrices IDOTS, DOTPROD 5333* 5334* VEC1,VEC2 -- singles and doubles part of vector 5335* ISYVEC -- symmetry of vector 5336* 5337* MXTRAN,MXVEC -- dimensions for IDOTS, DOTPROD 5338* 5339* Written by Christof Haettig, june 1997. 5340* 5341* adapted for R12 by Christian Neiss, Feb. 2005 5342* 5343*=====================================================================* 5344 IMPLICIT NONE 5345#include "priunit.h" 5346#include "ccorb.h" 5347#include "ccsdinp.h" 5348#include "ccsdsym.h" 5349 5350 LOGICAL LOCDBG 5351 PARAMETER (LOCDBG = .FALSE.) 5352 5353 CHARACTER TYPE*(*) 5354 INTEGER IIOPT, ITRAN, MXVEC, MXTRAN, ISYVEC, LWORK 5355 INTEGER IDOTS(MXVEC,MXTRAN) 5356 5357#if defined (SYS_CRAY) 5358 REAL DOTPROD(MXVEC,MXTRAN) 5359 REAL VEC1(*), VEC2(*) 5360 REAL WORK(LWORK) 5361 REAL CON1, CON2 5362 REAL ZERO, XNORM1,XNORM2 5363 REAL DDOT 5364#else 5365 DOUBLE PRECISION DOTPROD(MXVEC,MXTRAN) 5366 DOUBLE PRECISION VEC1(*), VEC2(*) 5367 DOUBLE PRECISION WORK(LWORK) 5368 DOUBLE PRECISION CON1, CON2 5369 DOUBLE PRECISION ZERO, XNORM1,XNORM2 5370 DOUBLE PRECISION DDOT 5371#endif 5372 PARAMETER (ZERO = 0.0d0) 5373 5374 CHARACTER MODEL*(10) 5375 INTEGER KZETA1, KZETA2, KEND, LEND, IVEC, ISYCTR, IZETAV 5376 INTEGER IOPT 5377* external functions: 5378 INTEGER ILSTSYM 5379 5380 5381 CALL QENTER('CCDOTRSP') 5382 IOPT = IIOPT 5383*---------------------------------------------------------------------* 5384* allocate memory for vectors to be read from file: 5385*---------------------------------------------------------------------* 5386 KZETA1 = 1 5387 KEND = KZETA1 + NT1AM(ISYVEC) 5388 IF (IIOPT.EQ.32) THEN 5389 KZETA2 = KEND 5390 KEND = KZETA2 + NTR12AM(ISYVEC) 5391 ELSE IF (IAND(IIOPT,4).EQ.4) THEN 5392 KZETA2 = KEND 5393 KEND = KZETA2 + 2*NT2AM(ISYVEC) 5394 IOPT = IIOPT - 2 5395 ELSE IF (IIOPT.GT.1) THEN 5396 KZETA2 = KEND 5397 KEND = KZETA2 + NT2AM(ISYVEC) 5398 END IF 5399 LEND = LWORK - KEND 5400 5401 IF (LEND .LT. 0) THEN 5402 CALL QUIT('Insufficient work space in CCDOTRSP.') 5403 END IF 5404 5405 IF (LOCDBG) THEN 5406 WRITE (LUPRI,*) 'CCDOTRSP:',IOPT 5407 XNORM1 = 0.0d0 5408 XNORM2 = 0.0d0 5409 IF (IOPT.EQ.1 .OR. IOPT.EQ.3) 5410 & XNORM1=DDOT(NT1AM(ISYVEC),VEC1,1,VEC1,1) 5411 IF (IOPT.EQ.2 .OR. IOPT.EQ.3) 5412 & XNORM2=DDOT(NT2AM(ISYVEC),VEC2,1,VEC2,1) 5413 IF (IOPT.EQ.32) 5414 & XNORM2=DDOT(NTR12AM(ISYVEC),VEC2,1,VEC2,1) 5415 IF (IOPT.NE.32) THEN 5416 WRITE (LUPRI,*) 'XNORM1/XNORM2:',XNORM1,XNORM2 5417 CALL CC_PRP(VEC1,VEC2,ISYVEC,1,1) 5418 ELSE 5419 WRITE (LUPRI,*) 'XNORM_R12:',XNORM2 5420 CALL CC_PRPR12(VEC2,ISYVEC,1,.true.) 5421 END IF 5422 END IF 5423 5424*---------------------------------------------------------------------* 5425* loop over all vectors to be dotted on: 5426*---------------------------------------------------------------------* 5427 IVEC = 1 5428 DO WHILE (IDOTS(IVEC,ITRAN).NE.0 .AND. IVEC.LE.MXVEC) 5429 5430 IZETAV = IDOTS(IVEC,ITRAN) 5431 ISYCTR = ILSTSYM(TYPE,IZETAV) 5432 5433 IF (ISYCTR.NE.ISYVEC) THEN 5434 WRITE (LUPRI,*) 'symmetry mismatch in CCDOTRSP:' 5435 WRITE (LUPRI,*) 'TYPE:',TYPE 5436 WRITE (LUPRI,*) 'ISYCTR:',ISYCTR 5437 WRITE (LUPRI,*) 'ISYVEC:',ISYVEC 5438 CALL QUIT('symmetry mismatch in CCDOTRSP.') 5439 END IF 5440 5441 CALL CC_RDRSP(TYPE,IZETAV,ISYCTR,IOPT,MODEL, 5442 & WORK(KZETA1),WORK(KZETA2)) 5443C 5444 IF (IOPT.EQ.1 .OR. IOPT.EQ.3) THEN 5445 CON1 = DDOT(NT1AM(ISYCTR),WORK(KZETA1),1,VEC1,1) 5446 ELSE 5447 CON1 = ZERO 5448 END IF 5449 5450 IF (IIOPT.EQ.2 .OR. IIOPT.EQ.3) THEN 5451 IF (.NOT.CCS) CALL CCLR_DIASCL(WORK(KZETA2),0.5d0,ISYCTR) 5452 CON2 = DDOT(NT2AM(ISYCTR),WORK(KZETA2),1,VEC2,1) 5453 ELSE IF (IAND(IIOPT,4).EQ.4) THEN 5454 CON2 = DDOT(2*NT2AM(ISYCTR),WORK(KZETA2),1,VEC2,1) 5455 ELSE IF (IOPT.EQ.32) THEN 5456 CON2 = DDOT(NTR12AM(ISYCTR),WORK(KZETA2),1,VEC2,1) 5457 ELSE 5458 CON2 = ZERO 5459 END IF 5460 5461 DOTPROD(IVEC,ITRAN) = DOTPROD(IVEC,ITRAN) + CON1 + CON2 5462 5463 IF (LOCDBG) THEN 5464 WRITE (LUPRI,*) 'CCDOTRSP:',IOPT,DOTPROD(IVEC,ITRAN), 5465 & CON1, CON2 5466 XNORM1 = 0.0d0 5467 XNORM2 = 0.0d0 5468 IF (IOPT.EQ.1 .OR. IOPT.EQ.3) 5469 & XNORM1=DDOT(NT1AM(ISYCTR),WORK(KZETA1),1,WORK(KZETA1),1) 5470 IF (IOPT.EQ.2 .OR. IOPT.EQ.3) THEN 5471 XNORM2=DDOT(NT2AM(ISYCTR),WORK(KZETA2),1,WORK(KZETA2),1) 5472 ELSE IF(IOPT.EQ.32) THEN 5473 XNORM2=DDOT(NTR12AM(ISYCTR),WORK(KZETA2),1,WORK(KZETA2),1) 5474 END IF 5475 WRITE (LUPRI,*) 'TYPE,IZETAV,XNORM:',TYPE(1:2),IZETAV,XNORM1, 5476 & XNORM2 5477 END IF 5478 5479 IVEC = IVEC + 1 5480 5481 END DO 5482 5483 CALL QEXIT('CCDOTRSP') 5484 5485 RETURN 5486 END 5487 5488*---------------------------------------------------------------------* 5489* END OF SUBROUTINE CCDOTRSP * 5490*---------------------------------------------------------------------* 5491 5492*---------------------------------------------------------------------* 5493c/* Deck CC_BTST */ 5494*=====================================================================* 5495 SUBROUTINE CC_BTST(WORK,LWORK,APROXR12) 5496#if defined (IMPLICIT_NONE) 5497 IMPLICIT NONE 5498#else 5499# include "implicit.h" 5500#endif 5501#include "priunit.h" 5502#include "ccsdinp.h" 5503#include "ccsdsym.h" 5504#include "ccorb.h" 5505#include "dummy.h" 5506#include "r12int.h" 5507#include "ccr12int.h" 5508 5509* local parameters: 5510 CHARACTER MSGDBG*(18) 5511 PARAMETER (MSGDBG='[debug] CC_BTST> ') 5512 5513 LOGICAL LOCDBG 5514 PARAMETER (LOCDBG = .FALSE.) 5515 INTEGER MXBTRAN 5516 PARAMETER (MXBTRAN = 2) 5517 5518 INTEGER LWORK 5519#if defined (SYS_CRAY) 5520 REAL WORK(LWORK) 5521 REAL DDOT 5522 REAL AATRAN1, EATRAN1, AATRAN2, EATRAN2,RDUM(2) 5523#else 5524 DOUBLE PRECISION WORK(LWORK) 5525 DOUBLE PRECISION DDOT 5526 DOUBLE PRECISION AATRAN1, EATRAN1, AATRAN2, EATRAN2, RDUM(2) 5527#endif 5528 5529 CHARACTER*(3) LISTA, LISTB, LISTC, APROXR12 5530 CHARACTER*(8) FILBMA, LABELA 5531 CHARACTER*(10) MODEL 5532 INTEGER IOPTRES 5533 INTEGER IBTRAN(3,MXBTRAN), NBTRAN 5534 INTEGER IDLSTA, IDLSTB, ISYMA, ISYMB, ISYMAB, IOPT 5535 INTEGER KRESLT1, KRESLT2, KT1AMPA, KT1AMPB, KT2AMPA, KT2AMPB 5536 INTEGER KTHETA1, KTHETA2, KEND1, LWRK1, LEND1, LEND2, LEND3 5537 INTEGER KEND2, KEND3, KETA1, KETA2, KT1AMPC, KT2AMPC, NTAMP 5538 INTEGER ISYMAC, ISYMC, IDLSTC, IDUM(2) 5539 INTEGER KTHETAR12, KT12AMPB, KT12AMPA, KRESLTR12 5540 INTEGER NTR12AB, NTR12A, NTR12B 5541 5542* external function: 5543 INTEGER IR1TAMP 5544 INTEGER IL1ZETA 5545 INTEGER ILSTSYM 5546 5547 5548 CALL QENTER('CC_BTST') 5549 5550 5551*---------------------------------------------------------------------* 5552* call B matrix transformation: 5553*---------------------------------------------------------------------* 5554 LISTA = 'R1 ' 5555 LISTB = 'R1 ' 5556 IDLSTA = IR1TAMP('ZDIPLEN ',.FALSE.,0.0D0,ISYMA) 5557 IDLSTB = IR1TAMP('ZDIPLEN ',.FALSE.,0.0D0,ISYMB) 5558 IBTRAN(1,1) = IDLSTA 5559 IBTRAN(2,1) = IDLSTB 5560 NBTRAN = 1 5561 5562 ISYMAB = MULD2H(ISYMA,ISYMB) 5563 5564 IOPTRES = 1 5565 FILBMA = 'CC__BMAT' 5566 5567 CALL CC_BMAT(IBTRAN, NBTRAN, LISTA, LISTB, IOPTRES, 5568 & FILBMA, IDUM, RDUM, 0, .FALSE., WORK, LWORK ) 5569 5570 IF (CCR12) THEN 5571 NTR12AB = NTR12AM(ISYMAB) 5572 NTR12A = NTR12AM(ISYMA) 5573 NTR12B = NTR12AM(ISYMB) 5574 ELSE 5575 NTR12AB = 0 5576 NTR12A = 0 5577 NTR12B = 0 5578 END IF 5579 5580 KTHETA1 = IBTRAN(3,1) 5581 KTHETA2 = KTHETA1 + NT1AM(ISYMAB) 5582 KTHETAR12 = KTHETA2 + NT2AM(ISYMAB) 5583 KEND1 = KTHETAR12 + NTR12AB 5584 5585 IF (NSYM.EQ.1 .AND. LOCDBG) THEN 5586 KT1AMPB = KEND1 5587 KT2AMPB = KT1AMPB + NT1AM(ISYMB) 5588 KT12AMPB = KT2AMPB + NT2AM(ISYMB) 5589 KT1AMPA = KT12AMPB + NTR12B 5590 KT2AMPA = KT1AMPA + NT1AM(ISYMA) 5591 KT12AMPA = KT2AMPA + NT2AM(ISYMA) 5592 KRESLT1 = KT12AMPA + NTR12A 5593 KRESLT2 = KRESLT1 + NT1AM(ISYMAB) 5594 KRESLTR12 = KRESLT2 + NT2AM(ISYMAB) 5595 KEND1 = KRESLTR12 + NTR12AB 5596 LEND1 = LWORK - KEND1 5597 5598 IF (LEND1 .LT. 0) THEN 5599 CALL QUIT('Insufficient work space in CC_BTST.') 5600 END IF 5601 5602 IOPT = 3 5603 Call CC_RDRSP(LISTA,IDLSTA,ISYMA,IOPT,MODEL, 5604 & WORK(KT1AMPA),WORK(KT2AMPA)) 5605 Call CC_RDRSP(LISTB,IDLSTB,ISYMB,IOPT,MODEL, 5606 & WORK(KT1AMPB),WORK(KT2AMPB)) 5607 5608 IF (CCR12) THEN 5609 IOPT = 32 5610 CALL CC_RDRSP(LISTA,IDLSTA,ISYMA,IOPT,MODEL, 5611 & DUMMY,WORK(KT12AMPA)) 5612 Call CC_RDRSP(LISTB,IDLSTB,ISYMB,IOPT,MODEL, 5613 & DUMMY,WORK(KT12AMPB)) 5614 END IF 5615 5616 ! zero doubles of B and/or C vector: 5617C CALL DZERO(WORK(KT1AMPA),NT1AM(ISYMA)) 5618C CALL DZERO(WORK(KT1AMPB),NT1AM(ISYMB)) 5619C CALL DZERO(WORK(KT2AMPA),NT2AM(ISYMA)) 5620C CALL DZERO(WORK(KT2AMPB),NT2AM(ISYMB)) 5621 CALL DZERO(WORK(KRESLT1),NT1AM(ISYMAB)+NT2AM(ISYMAB)+ 5622 & NTR12AB) 5623C IPRINT = 5 5624 5625 CALL CC_FDB(NT1AM(ISYMAB),NT2AM(ISYMAB),NTR12AB, 5626 > WORK(KT1AMPA), WORK(KT1AMPB), WORK(KRESLT1), 5627 > WORK(KEND1), LEND1, APROXR12) 5628 5629C IPRINT = 0 5630 5631 IF (.TRUE.) THEN 5632 WRITE (LUPRI,*) 'LISTA, IDLSTA, ISYMA:',LISTA,IDLSTA,ISYMA 5633 WRITE (LUPRI,*) 'LISTB, IDLSTB, ISYMB:',LISTB,IDLSTB,ISYMB 5634 WRITE (LUPRI,*) 'ISYMAB:',ISYMAB 5635 WRITE (LUPRI,*) 5636 WRITE (LUPRI,*) 'finite difference Theta vector:' 5637 Call CC_PRP(WORK(KRESLT1),WORK(KRESLT2),ISYMAB,1,1) 5638 IF (CCR12) THEN 5639 Call CC_PRPR12(WORK(KRESLTR12),ISYMAB,1,.TRUE.) 5640 END IF 5641 WRITE (LUPRI,*) 'analytical Theta vector:' 5642 Call CC_PRP(WORK(KTHETA1),WORK(KTHETA2),ISYMAB,1,1) 5643 IF (CCR12) THEN 5644 Call CC_PRPR12(WORK(KTHETAR12),ISYMAB,1,.TRUE.) 5645 END IF 5646 WRITE(LUPRI,*) 'Norm of analytical Theta vector: ', 5647 & DSQRT(DDOT(NT1AM(ISYMAB)+NT2AM(ISYMAB)+NTR12AB, 5648 & WORK(KTHETA1),1,WORK(KTHETA1),1)) 5649 END IF 5650 5651 Call DAXPY(NT1AM(ISYMAB),-1.0d0,WORK(KTHETA1),1, 5652 & WORK(KRESLT1),1) 5653 IF (.NOT.(CCS.OR.CCSTST)) THEN 5654 Call DAXPY(NT2AM(ISYMAB),-1.0d0,WORK(KTHETA2),1, 5655 & WORK(KRESLT2),1) 5656 ELSE 5657 Call DZERO(WORK(KRESLT2),NT2AM(ISYMAB)) 5658 END IF 5659 5660 IF (CCR12) THEN 5661 CALL DAXPY(NTR12AB,-1.0d0,WORK(KTHETAR12),1, 5662 & WORK(KRESLTR12),1) 5663 END IF 5664 5665 WRITE (LUPRI,*) 'Norm of difference between analytical THETA ' 5666 > // 'vector and the numerical result:' 5667 WRITE (LUPRI,*) 'singles excitation part:', 5668 > DSQRT(DDOT(NT1AM(ISYMAB),WORK(KRESLT1),1,WORK(KRESLT1),1)) 5669 WRITE (LUPRI,*) 'double excitation part: ', 5670 > DSQRT(DDOT(NT2AM(ISYMAB),WORK(KRESLT2),1,WORK(KRESLT2),1)) 5671 IF (CCR12) THEN 5672 WRITE (LUPRI,*) 'R12 double excitation part: ', 5673 & DSQRT(DDOT(NTR12AB,WORK(KRESLTR12),1, 5674 & WORK(KRESLTR12),1)) 5675 END IF 5676 5677 WRITE (LUPRI,*) 'difference vector:' 5678 Call CC_PRP(WORK(KRESLT1),WORK(KRESLT2),ISYMAB,1,1) 5679 IF (CCR12) THEN 5680 Call CC_PRPR12(WORK(KRESLTR12),ISYMAB,1,.TRUE.) 5681 END IF 5682 5683 CALL FLSHFO(LUPRI) 5684 5685 5686 ELSE IF (NSYM.NE.1 .AND. LOCDBG) THEN 5687 5688 WRITE (LUPRI,*) 5689 & 'CC_BTST> can not calculate finite difference B matrix' 5690 WRITE (LUPRI,*) 'CC_BTST> with symmetry.' 5691 5692 WRITE (LUPRI,*) 'analytical Theta vector:' 5693 Call CC_PRP(WORK(KTHETA1),WORK(KTHETA2),ISYMAB,1,1) 5694 IF (CCR12) THEN 5695 Call CC_PRPR12(WORK(KTHETAR12),ISYMAB,1,.TRUE.) 5696 END IF 5697 WRITE(LUPRI,*) 'Norm of analytical Theta vector: ', 5698 & DSQRT(DDOT(NT1AM(ISYMAB)+NT2AM(ISYMAB)+NTR12AB, 5699 & WORK(KTHETA1),1,WORK(KTHETA1),1)) 5700 CALL FLSHFO(LUPRI) 5701 5702 END IF 5703 5704*=====================================================================* 5705* test A{A} transformation: 5706*=====================================================================* 5707C This part is NOT adapted for CC-R12 yet! 5708 IF (.FALSE.) THEN 5709 WRITE (LUPRI,'(/,/5X,A)') 'TEST A{A} TRANSFORMATION:' 5710 IF (CCR12) CALL QUIT('Not adapted for CC-R12') 5711 5712 LABELA = 'ZDIPLEN ' 5713 LISTC = 'L1 ' 5714 IDLSTC = IL1ZETA('ZDIPLEN ',.FALSE.,0.0D0,1) 5715 ISYMC = ILSTSYM(LISTC,IDLSTC) 5716 5717 KRESLT1 = 1 5718 KRESLT2 = KRESLT1 + NT1AM(ISYMAB) 5719 KT1AMPC = KRESLT2 + NT2AM(ISYMAB) 5720 KT2AMPC = KT1AMPC + NT1AM(ISYMC) 5721 KEND1 = KT2AMPC + NT2AM(ISYMC) 5722 LEND1 = LWORK - KEND1 5723 5724 IF (LEND1 .LT. 0) THEN 5725 CALL QUIT('Insufficient work space in CC_BTST.') 5726 END IF 5727 5728 CALL CCCR_AA(LABELA,ISYMA,LISTB,IDLSTB,DUMMY,WORK,LWORK) 5729 5730 5731 IOPT = 3 5732 Call CC_RDRSP(LISTC,IDLSTC,ISYMC,IOPT,MODEL, 5733 & WORK(KT1AMPC),WORK(KT2AMPC)) 5734 5735 IF (ISYMC.NE.ISYMAB) THEN 5736 CALL QUIT('SYMMETRY MISMATCH IN CC_BTST.') 5737 END IF 5738 5739 AATRAN1 = DDOT(NT1AM(ISYMC),WORK(KRESLT1),1,WORK(KT1AMPC),1) 5740 IF (.NOT.CCS) THEN 5741 AATRAN2 = DDOT(NT2AM(ISYMC),WORK(KRESLT2),1,WORK(KT2AMPC),1) 5742 END IF 5743 5744 5745 ISYMAC = MULD2H(ISYMA,ISYMC) 5746 5747 KETA1 = KEND1 5748 KETA2 = KETA1 + NT1AM(ISYMAC) 5749 KEND2 = KETA2 + NT2AM(ISYMAC) 5750 LEND2 = LWORK - KEND2 5751 5752 KT1AMPB = KEND2 5753 KT2AMPB = KT1AMPB + NT1AM(ISYMB) 5754 KEND3 = KT2AMPB + NT2AM(ISYMB) 5755 LEND3 = LWORK - KEND3 5756 5757 IF (LEND3 .LT. 0) THEN 5758 CALL QUIT('Insufficient work space in CC_BTST.') 5759 END IF 5760 5761 CALL CC_ETAC(ISYMA,LABELA,WORK(KEND1), 5762 & LISTC,IDLSTC,0,DUMMY,WORK(KEND2),LEND2) 5763 5764 IOPT = 3 5765 CALL CC_RDRSP(LISTB,IDLSTB,ISYMB,IOPT,MODEL, 5766 & WORK(KT1AMPB),WORK(KT2AMPB)) 5767 5768 EATRAN1 = DDOT(NT1AM(ISYMB),WORK(KETA1),1,WORK(KT1AMPB),1) 5769 IF (.NOT.CCS) THEN 5770 EATRAN2 = DDOT(NT2AM(ISYMB),WORK(KETA2),1,WORK(KT2AMPB),1) 5771 END IF 5772 5773 WRITE (LUPRI,*) 'comparison of the results:' 5774 WRITE (LUPRI,*) 'C x AATRAN(A,B):', AATRAN1+AATRAN2, AATRAN1, 5775 & AATRAN2 5776 WRITE (LUPRI,*) 'EATRAN(C,A) x B:', EATRAN1+EATRAN2, EATRAN1, 5777 & EATRAN2 5778 5779 END IF 5780 5781 CALL QEXIT('CC_BTST') 5782 5783 RETURN 5784 END 5785*=====================================================================* 5786*=====================================================================* 5787C /* Deck ccb_cdsort */ 5788 SUBROUTINE CCB_CDSORT(XINT,ISYDIS,DDRHF,XLAMDP,ISYXLP,WORK,LWORK) 5789*---------------------------------------------------------------------* 5790* 5791* Purpose: calculated presorted one-index transformed integrals 5792* for D intermediate: 5793* 5794* DDRHF(k,alp bet) = 2 (alp bet|k del) - (k bet|alp del) 5795* 5796* Written by Christof Haettig November 1998 5797*---------------------------------------------------------------------* 5798#if defined (IMPLICIT_NONE) 5799 IMPLICIT NONE 5800#else 5801# include "implicit.h" 5802#endif 5803#include "priunit.h" 5804#include "ccorb.h" 5805#include "maxorb.h" 5806#include "ccsdsym.h" 5807#include "symsq.h" 5808 5809 INTEGER ISYALP, ISYBET, ISYGAM, ISYRHF, ISYDIS, ISYXLP, LWORK 5810 INTEGER ISYMAB, ISYMBK, ISYMGK, NRHFK, NBASA, KSCR1, KSCR2 5811 INTEGER KOFF0, KOFF1, KOFF2, KOFF3, KOFF4, KOFF5, KEND1, LWRK1 5812 INTEGER ICOUNT, NBSRHF(8), IBSRHF(8,8), ISYM, ISYMAK, ISYMK 5813 5814 5815#if defined (SYS_CRAY) 5816 REAL XINT(*), DDRHF(*), XLAMDP(*), WORK(LWORK) 5817 REAL TWO, ONE, ZERO 5818#else 5819 DOUBLE PRECISION XINT(*), DDRHF(*), XLAMDP(*), WORK(LWORK) 5820 DOUBLE PRECISION TWO, ONE, ZERO 5821#endif 5822 PARAMETER (TWO = 2.0D0, ONE = 1.0D0, ZERO = 0.0D0) 5823C 5824 CALL QENTER('CCB_CDSORT') 5825C 5826C -------------------------------------- 5827C precalculate symmetry array for DDRHF: 5828C -------------------------------------- 5829C 5830 DO ISYM = 1, NSYM 5831 ICOUNT = 0 5832 DO ISYMAK = 1, NSYM 5833 ISYBET = MULD2H(ISYMAK,ISYM) 5834 IBSRHF(ISYMAK,ISYBET) = ICOUNT 5835 ICOUNT = ICOUNT + NT1AO(ISYMAK)*NBAS(ISYBET) 5836 END DO 5837 NBSRHF(ISYM) = ICOUNT 5838 END DO 5839C 5840 ISYRHF = MULD2H(ISYDIS,ISYXLP) 5841C 5842 CALL DZERO(DDRHF,NBSRHF(ISYRHF)) 5843C 5844 DO ISYGAM = 1, NSYM 5845C 5846 ISYMAB = MULD2H(ISYGAM,ISYDIS) 5847 ISYMBK = MULD2H(ISYMAB,ISYXLP) 5848C 5849 KSCR1 = 1 5850 KSCR2 = KSCR1 + N2BST(ISYMAB) 5851 KEND1 = KSCR2 + NT1AO(ISYMBK) 5852 LWRK1 = LWORK - KEND1 5853C 5854 IF (LWRK1 .LT. 0) THEN 5855 CALL QUIT('Insufficient memory in CCB_CDSORT.') 5856 END IF 5857C 5858 DO G = 1, NBAS(ISYGAM) 5859C 5860 KOFF0 = IDSAOG(ISYGAM,ISYDIS) + NNBST(ISYMAB)*(G-1) + 1 5861 CALL CCSD_SYMSQ(XINT(KOFF0),ISYMAB,WORK(KSCR1)) 5862C 5863 DO ISYALP = 1, NSYM 5864 5865 ISYBET = MULD2H(ISYMAB,ISYALP) 5866 ISYMK = MULD2H(ISYALP,ISYXLP) 5867 ISYMGK = MULD2H(ISYGAM,ISYMK) 5868C 5869C ------------------------------- 5870C transform the alpha index to k: 5871C ------------------------------- 5872C 5873 KOFF1 = IGLMRH(ISYALP,ISYMK) + 1 5874 KOFF2 = KSCR1 + IAODIS(ISYALP,ISYBET) 5875 KOFF3 = KSCR2 + IT1AO(ISYBET,ISYMK) 5876 NBASA = MAX(NBAS(ISYALP),1) 5877 NRHFK = MAX(NRHF(ISYMK),1) 5878 5879 CALL DGEMM('T','N',NRHF(ISYMK),NBAS(ISYBET),NBAS(ISYALP), 5880 & ONE,XLAMDP(KOFF1),NBASA,WORK(KOFF2),NBASA, 5881 & ZERO,WORK(KOFF3),NRHFK) 5882C 5883C -------------------------- 5884C store as DDRHF(gam k;bet): 5885C -------------------------- 5886C 5887 DO B = 1, NBAS(ISYBET) 5888 5889 KOFF4 = KSCR2 + IT1AO(ISYBET,ISYMK) + NRHF(ISYMK)*(B-1) 5890 KOFF5 = IBSRHF(ISYMGK,ISYBET) + NT1AO(ISYMGK)*(B-1) 5891 & + IT1AO(ISYGAM,ISYMK) + G 5892 5893 CALL DCOPY(NRHF(ISYMK),WORK(KOFF4),1, 5894 & DDRHF(KOFF5),NBAS(ISYGAM)) 5895 END DO 5896C 5897 END DO 5898C 5899 END DO 5900C 5901 END DO 5902C 5903 CALL QEXIT('CCB_CDSORT') 5904C 5905 RETURN 5906 END 5907*=====================================================================* 5908*=====================================================================* 5909C /* Deck cc_cdb */ 5910 SUBROUTINE CC_CDB(DDRHF, ISYRHF, IDEL, ISYDEL, LUD, DFIL, IV, 5911 & XLAMDP, XLAMDH, XLAMPC, XLAMHC, ISYXLC, 5912 & IOPTR, FACTR, RIM, WORK, LWORK) 5913*---------------------------------------------------------------------* 5914* 5915* Purpose: calculate the D intermediate in the B matrix transf. 5916* 5917* Written by Christof Haettig November 1998 5918*---------------------------------------------------------------------* 5919#if defined (IMPLICIT_NONE) 5920 IMPLICIT NONE 5921#else 5922# include "implicit.h" 5923#endif 5924#include "priunit.h" 5925#include "ccorb.h" 5926#include "maxorb.h" 5927#include "ccsdsym.h" 5928#include "ccsdio.h" 5929 5930 CHARACTER*(*) DFIL 5931 INTEGER LWORK, ISYXLC, ISYRHF, LUD, IV, IOPTR, IDEL, ISYDEL 5932 5933#if defined (SYS_CRAY) 5934 REAL DDRHF(*), RIM(*), WORK(LWORK) 5935 REAL XLAMDP(*), XLAMDH(*), XLAMPC(*), XLAMHC(*) 5936 REAL FACTR, ONE, ZERO, DDOT, XNORM 5937#else 5938 DOUBLE PRECISION DDRHF(*), RIM(*), WORK(LWORK) 5939 DOUBLE PRECISION XLAMDP(*), XLAMDH(*), XLAMPC(*), XLAMHC(*) 5940 DOUBLE PRECISION FACTR, ONE, ZERO, DDOT, XNORM 5941#endif 5942 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0) 5943C 5944 INTEGER NBSRHF(8), IBSRHF(8,8), ISYM, ISYALK, ISYBET, ICOUNT 5945 INTEGER ISYMI, ISYMA, ISYMAI, KOFF1, KOFF2, KOFF3, KOFF4, KOFF5 5946 INTEGER NAI, ISYAIK, KSCR1, KSCR2, KEND1, LWRK1, KOFF6, ISYALP 5947 INTEGER ISYMK, NT1AK, NBASB, NBASA, NRHFK, IADR 5948C 5949 CALL QENTER('CC_CDB') 5950C 5951C -------------------------------------- 5952C precalculate symmetry array for BSRHF: 5953C -------------------------------------- 5954 DO ISYM = 1, NSYM 5955 ICOUNT = 0 5956 DO ISYALK = 1, NSYM 5957 ISYBET = MULD2H(ISYALK,ISYM) 5958 IBSRHF(ISYALK,ISYBET) = ICOUNT 5959 ICOUNT = ICOUNT + NT1AO(ISYALK)*NBAS(ISYBET) 5960 END DO 5961 NBSRHF(ISYM) = ICOUNT 5962 END DO 5963C 5964 ISYAIK = MULD2H(ISYRHF,ISYXLC) 5965C 5966 KSCR1 = 1 5967 KSCR2 = KSCR1 + MAX(NT2BGD(ISYAIK),NT2BGD(ISYRHF)) 5968 KEND1 = KSCR2 + NT2BCD(ISYAIK) 5969 LWRK1 = LWORK - KEND1 5970C 5971 CALL DZERO(WORK(KSCR2),NT2BCD(ISYAIK)) 5972C 5973 IF (LWRK1 .LT. 0) THEN 5974 CALL QUIT('Insufficient memory in CC_CDB.') 5975 END IF 5976C 5977 DO ISYALK = 1, NSYM 5978 5979 ISYBET = MULD2H(ISYALK,ISYRHF) 5980C 5981C ------------------------------------------------- 5982C transform beta index to i and alpha index to a^C: 5983C ------------------------------------------------- 5984C 5985 ISYMI = ISYBET 5986C 5987 KOFF1 = IBSRHF(ISYALK,ISYBET) + 1 5988 KOFF2 = IGLMRH(ISYBET,ISYMI) + 1 5989 KOFF3 = KSCR1 + IT2BGT(ISYMI,ISYALK) 5990 5991 NT1AK = MAX(NT1AO(ISYALK),1) 5992 NBASB = MAX(NBAS(ISYBET),1) 5993 5994 CALL DGEMM('N','N',NT1AO(ISYALK),NRHF(ISYMI),NBAS(ISYBET), 5995 & ONE,DDRHF(KOFF1),NT1AK,XLAMDH(KOFF2),NBASB, 5996 & ZERO,WORK(KOFF3),NT1AK) 5997 5998 DO I = 1, NRHF(ISYMI) 5999 6000 DO ISYALP = 1, NSYM 6001 6002 ISYMK = MULD2H(ISYALK,ISYALP) 6003 ISYMA = MULD2H(ISYALP,ISYXLC) 6004 ISYMAI = MULD2H(ISYMA,ISYMI) 6005 6006 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I-1) + 1 6007 6008 KOFF5 = IGLMVI(ISYALP,ISYMA) + 1 6009 KOFF6 = KSCR2 + IT2BCT(ISYMK,ISYMAI) + NRHF(ISYMK)*(NAI-1) 6010 KOFF4 = KSCR1 + IT2BGT(ISYMI,ISYALK) + 6011 & NT1AO(ISYALK)*(I-1) + IT1AO(ISYALP,ISYMK) 6012 6013 NBASA = MAX(NBAS(ISYALP),1) 6014 NRHFK = MAX(NRHF(ISYMK),1) 6015 6016 CALL DGEMM('T','N',NRHF(ISYMK),NVIR(ISYMA),NBAS(ISYALP), 6017 & ONE,WORK(KOFF4),NBASA,XLAMPC(KOFF5),NBASA, 6018 & ONE,WORK(KOFF6),NRHFK) 6019 6020 END DO 6021 6022 END DO 6023 6024 END DO 6025C 6026 DO ISYALK = 1, NSYM 6027 6028 ISYBET = MULD2H(ISYALK,ISYRHF) 6029C 6030C ------------------------------------------------- 6031C transform beta index to i^C and alpha index to a: 6032C ------------------------------------------------- 6033C 6034 ISYMI = MULD2H(ISYBET,ISYXLC) 6035C 6036 KOFF1 = IBSRHF(ISYALK,ISYBET) + 1 6037 KOFF2 = IGLMRH(ISYBET,ISYMI) + 1 6038 KOFF3 = KSCR1 + IT2BGT(ISYMI,ISYALK) 6039 6040 NT1AK = MAX(NT1AO(ISYALK),1) 6041 NBASB = MAX(NBAS(ISYBET),1) 6042 6043 CALL DGEMM('N','N',NT1AO(ISYALK),NRHF(ISYMI),NBAS(ISYBET), 6044 & ONE,DDRHF(KOFF1),NT1AK,XLAMHC(KOFF2),NBASB, 6045 & ZERO,WORK(KOFF3),NT1AK) 6046 6047 DO I = 1, NRHF(ISYMI) 6048 6049 DO ISYALP = 1, NSYM 6050 6051 ISYMK = MULD2H(ISYALK,ISYALP) 6052 ISYMA = ISYALP 6053 ISYMAI = MULD2H(ISYMA,ISYMI) 6054 6055 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I-1) + 1 6056 6057 KOFF5 = IGLMVI(ISYALP,ISYMA) + 1 6058 KOFF6 = KSCR2 + IT2BCT(ISYMK,ISYMAI) + NRHF(ISYMK)*(NAI-1) 6059 KOFF4 = KSCR1 + IT2BGT(ISYMI,ISYALK) + 6060 & NT1AO(ISYALK)*(I-1) + IT1AO(ISYALP,ISYMK) 6061 6062 NBASA = MAX(NBAS(ISYALP),1) 6063 NRHFK = MAX(NRHF(ISYMK),1) 6064 6065 CALL DGEMM('T','N',NRHF(ISYMK),NVIR(ISYMA),NBAS(ISYALP), 6066 & ONE,WORK(KOFF4),NBASA,XLAMDP(KOFF5),NBASA, 6067 & ONE,WORK(KOFF6),NRHFK) 6068 6069 END DO 6070 6071 END DO 6072 6073 END DO 6074C 6075C ------------------------------- 6076C write the intermediate to disk: 6077C ------------------------------- 6078C 6079 IADR = IT2DLR(IDEL,IV) + 1 6080 ISYAIK = MULD2H(ISYRHF,ISYXLC) 6081C 6082C XNORM = DDOT(NT2BCD(ISYAIK),WORK(KSCR2),1,WORK(KSCR2),1) 6083C WRITE (LUPRI,*) 'IDEL,XNORM:',IDEL,XNORM 6084C 6085 CALL PUTWA2(LUD,DFIL,WORK(KSCR2),IADR,NT2BCD(ISYAIK)) 6086C 6087C -------------------------------------------------- 6088C calculate contribution to R intermediate as trace: 6089C -------------------------------------------------- 6090C 6091 IF (IOPTR.EQ.1 .AND. NT2BCD(ISYAIK).GT.0 ) THEN 6092 6093 D = IDEL - IBAS(ISYDEL) 6094 6095 DO ISYMAI = 1, NSYM 6096 6097 ISYMK = MULD2H(ISYMAI,ISYAIK) 6098 ISYMI = ISYMK 6099 ISYMA = MULD2H(ISYMAI,ISYMI) 6100 6101 DO I = 1, NRHF(ISYMI) 6102 DO A = 1, NVIR(ISYMA) 6103 6104 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I-1) + A 6105 KOFF1 = IEMAT1(ISYMA,ISYDEL) + NVIR(ISYMA)*(D-1) + A 6106 KOFF3 = IT2BCT(ISYMI,ISYMAI) + NRHF(ISYMI)*(NAI-1) + I 6107 6108 RIM(KOFF1) = RIM(KOFF1) + FACTR * WORK(KSCR2-1+KOFF3) 6109 6110 END DO 6111 END DO 6112 6113 END DO 6114 6115 END IF 6116C 6117 CALL QEXIT('CC_CDB') 6118C 6119 RETURN 6120 END 6121*=====================================================================* 6122c /* deck cc_aibj */ 6123*=====================================================================* 6124 SUBROUTINE CC_AIBJ( X0INT, ISY0ALBE, X1INT, ISY1ALBE, 6125 & IDEL, IGAM, X0AIBJ, X1AIBJ, 6126 & XLAMDHA, ISYXLA, XLAMDHB, ISYXLB, 6127 & XLAMDP0, ISYXL0, WORK, LWORK, 6128 & IOPT, LDERIV, LRELAX ) 6129*---------------------------------------------------------------------* 6130* 6131* Purpose: generalized transformation to (ai|bj) integrals 6132* for the two-index (**|gam del) approach 6133* assumes three-index array XAIBJ in core 6134* 6135* this routine transforms the indeces ia and j, the 6136* transformation of the delta index to b has to be done 6137* from the outside. 6138* 6139* The (ai|bj) integrals are calculated by 6140* transforming the gamma index with XLAMDH matrices, 6141* this assumes symmetric AO integrals 6142* --> factor (-1) for London orbitals i guess... 6143* 6144* X0INT, X1IAJB : usual integrals 6145* X1INT, X1IAJB : derivative integrals 6146* 6147* 6148* IOPT=0: (a i^A|del j^B) as for F term in energy code 6149* 6150* IOPT=1: not used 6151* 6152* IF LDERIV=.TRUE. transform also the derivative integrals: 6153* not yet implemented... 6154* 6155* IF LRELAX=.TRUE. include relaxtion contribution to the 6156* derivative integrals: 6157* not yet implemented... 6158* 6159* i^A transform. with XLAMDHA with sym. ISYXLA 6160* j^B transform. with XLAMDHB with sym. ISYXLB 6161* a transform. with XLAMDP0 with sym. ISYXL0 6162* 6163* Written by Christof Haettig, October 1998. 6164* 6165*=====================================================================* 6166#if defined (IMPLICIT_NONE) 6167 IMPLICIT NONE 6168#else 6169# include "implicit.h" 6170#endif 6171#include "priunit.h" 6172#include "ccorb.h" 6173#include "ccsdsym.h" 6174#include "maxorb.h" 6175#include "ccisao.h" 6176 6177* local parameters: 6178 LOGICAL LOCDBG 6179 PARAMETER (LOCDBG = .FALSE.) 6180 6181 6182#if defined (SYS_CRAY) 6183 REAL ONE, ZERO 6184#else 6185 DOUBLE PRECISION ONE, ZERO 6186#endif 6187 PARAMETER (ONE = 1.0d0, ZERO = 0.0d0) 6188 6189 LOGICAL LDERIV, LRELAX 6190 INTEGER IDEL, IGAM, ISY0ALBE, ISY1ALBE, LWORK, IOPT, IDUMMY 6191 INTEGER ISYXL0, ISYXLA, ISYXLB 6192 6193#if defined (SYS_CRAY) 6194 REAL XLAMDP0(*), XLAMDHA(*), XLAMDHB(*) 6195 REAL X0INT(*), X1INT(*), X0AIBJ(*), X1AIBJ(*) 6196 REAL WORK(LWORK) 6197#else 6198 DOUBLE PRECISION XLAMDP0(*), XLAMDHA(*), XLAMDHB(*) 6199 DOUBLE PRECISION X0INT(*), X1INT(*), X0AIBJ(*), X1AIBJ(*) 6200 DOUBLE PRECISION WORK(LWORK) 6201#endif 6202 6203 INTEGER ISYMAI, ISYGAM, ISYALP, ISYBET 6204 INTEGER KSCR1, KSCR2, KSCR4, KEND1, LWRK1 6205 INTEGER KOFF1, KOFF2, KOFF4, KLAMD 6206 INTEGER NBASA, NBASB, NVIRA, ISYMA, ISYMI 6207 6208 CALL QENTER('CC_AIBJ') 6209 6210*---------------------------------------------------------------------* 6211* work space allocation: 6212* 6213* KSCR1 -- I^{del,gam}(alp bet) 6214* KSCR2 -- I^{del,gam}(i bet) 6215* KSCR4 -- I^{del,gam}(i a) 6216* 6217*---------------------------------------------------------------------* 6218 KSCR1 = 1 6219 KSCR2 = KSCR1 + N2BST(ISY0ALBE) 6220 KSCR4 = KSCR2 + NBAST*NRHFT 6221 KEND1 = KSCR4 + NVIRT*NRHFT 6222 6223 LWRK1 = LWORK - KEND1 6224 6225 IF ( LWRK1 .LT. 0) THEN 6226 CALL QUIT('Insufficient memory in CC_AIBJ.') 6227 END IF 6228 6229*---------------------------------------------------------------------* 6230* square integral matrix up 6231*---------------------------------------------------------------------* 6232 6233 CALL CCSD_SYMSQ(X0INT,ISY0ALBE,WORK(KSCR1)) 6234 6235*---------------------------------------------------------------------* 6236* transform alpha index to I using XLAMDHA 6237* -- store (i bet|gam del) in SCR2 6238*---------------------------------------------------------------------* 6239 KOFF2 = KSCR2 6240 6241 DO ISYMI = 1, NSYM 6242 6243 ISYALP = MULD2H(ISYXLA,ISYMI) 6244 ISYBET = MULD2H(ISYALP,ISY0ALBE) 6245 6246 KOFF1 = KSCR1 + IAODIS(ISYALP,ISYBET) 6247 KLAMD = IGLMRH(ISYALP,ISYMI) + 1 6248 6249 NBASA = MAX(NBAS(ISYALP),1) 6250 NBASB = MAX(NBAS(ISYBET),1) 6251 6252 CALL DGEMM('T','N',NBAS(ISYBET),NRHF(ISYMI),NBAS(ISYALP), 6253 * ONE,WORK(KOFF1),NBASA,XLAMDHA(KLAMD), 6254 * NBASA,ZERO,WORK(KOFF2),NBASB) 6255 6256 KOFF2 = KOFF2 + NBAS(ISYBET)*NRHF(ISYMI) 6257 6258 END DO 6259 6260*---------------------------------------------------------------------* 6261* transform beta index to a using XLAMDP0 6262* -- store (i a|gam del) in SCR4 6263*---------------------------------------------------------------------* 6264 KOFF2 = KSCR2 6265 6266 DO ISYMI = 1, NSYM 6267 6268 ISYALP = MULD2H(ISYXLA,ISYMI) 6269 ISYBET = MULD2H(ISYALP,ISY0ALBE) 6270 ISYMA = MULD2H(ISYXL0,ISYBET) 6271 6272 KLAMD = IGLMVI(ISYBET,ISYMA) + 1 6273 KOFF4 = KSCR4 + IT1AM(ISYMA,ISYMI) 6274 6275 NBASB = MAX(NBAS(ISYBET),1) 6276 NVIRA = MAX(NVIR(ISYMA),1) 6277 6278 CALL DGEMM('T','N',NVIR(ISYMA),NRHF(ISYMI),NBAS(ISYBET), 6279 * ONE,XLAMDP0(KLAMD),NBASB,WORK(KOFF2), 6280 * NBASB,ZERO,WORK(KOFF4),NVIRA) 6281 6282 KOFF2 = KOFF2 + NBAS(ISYBET)*NRHF(ISYMI) 6283 6284 END DO 6285 6286*---------------------------------------------------------------------* 6287* Add the contribution to the result XIAJB vector 6288* transform thereby gamma to j using XLAMDH1 and XLAMDH2 6289*---------------------------------------------------------------------* 6290 ISYGAM = ISAO(IGAM) 6291 6292C -------------------------- 6293C add (i a|j del) to X1IAJB: 6294C -------------------------- 6295 ISYMAI = MULD2H(ISY0ALBE,MULD2H(ISYXL0,ISYXLA)) 6296 6297 CALL CC_IAJB1(IGAM, WORK(KSCR4), ISYMAI, ISYGAM, 6298 & XLAMDHB, ISYXLB, X0AIBJ, .FALSE., IDUMMY) 6299 6300 CALL QEXIT('CC_AIBJ') 6301 6302 RETURN 6303 END 6304*=====================================================================* 6305* END OF SUBROUTINE CC_AIBJ * 6306*=====================================================================* 6307*=====================================================================* 6308C /* Deck ccbpre1int */ 6309 SUBROUTINE CCBPRE1INT(INTMED1,NINT1,IOFFCD,IADRBFD, 6310 & CBAFIL,DBAFIL,FNBFD, 6311 & XLAMDP0,XLAMDH0, 6312 & TIMIO,TIMC,TIMD,TIMBF,WORK,LWORK) 6313*---------------------------------------------------------------------* 6314* 6315* Purpose: precalculate some intermediates for B matrix transform. 6316* which depend only on one amplitude response vector: 6317* 6318* CBAR, DBAR, and the BF density 6319* 6320* the results are written to direct acces files 6321* 6322* Written by Christof Haettig November 1998 6323*---------------------------------------------------------------------* 6324#if defined (IMPLICIT_NONE) 6325 IMPLICIT NONE 6326#else 6327# include "implicit.h" 6328#endif 6329#include "priunit.h" 6330#include "ccorb.h" 6331#include "ccsdsym.h" 6332#include "ccsdinp.h" 6333#include "cciccset.h" 6334#include "second.h" 6335 6336 INTEGER ISYM0 6337 PARAMETER (ISYM0 = 1) 6338 6339 INTEGER LUCBAR, LUDBAR, LUBFD 6340 6341 CHARACTER*(*) CBAFIL, DBAFIL, FNBFD 6342 INTEGER LWORK, IDLSTR, NINT1 6343 INTEGER IADRBFD(*), ISTARTPQ, IOFFCD(0:NINT1), INTMED1(2,NINT1) 6344 6345#if defined (SYS_CRAY) 6346 REAL WORK(LWORK), XLAMDP0(*), XLAMDH0(*) 6347 REAL TIMC, TIMD, TIMBF, TIMIO, DTIME 6348 REAL TWO, ONE, ZERO, DDOT, DUMMY(2) 6349#else 6350 DOUBLE PRECISION WORK(LWORK), XLAMDP0(*), XLAMDH0(*) 6351 DOUBLE PRECISION TIMC, TIMD, TIMBF, TIMIO, DTIME 6352 DOUBLE PRECISION TWO, ONE, ZERO, DDOT, DUMMY(2) 6353#endif 6354 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0) 6355C 6356 CHARACTER MODEL*(10), LIST*(3) 6357 INTEGER IOPT,IINT1,ISTARTBFD,IDLST,ISYMA,KT2AMSQ,KXPACK,IDUMMY 6358 INTEGER KT1AMPA, KT2AMPA, KXLAMHA, KXLAMPA, KXIAJB, KEND1, LWRK1 6359 INTEGER ILSTSYM 6360 6361 CALL QENTER('CCBPRE1INT') 6362 6363*---------------------------------------------------------------------* 6364* test CC model, open files and do some initializations: 6365*---------------------------------------------------------------------* 6366 IF (CCS .OR. CC2) THEN 6367 CALL QEXIT('CCBPRE1INT') 6368 RETURN 6369 ENDIF 6370 6371 LUBFD = -1 6372 LUCBAR = -1 6373 LUDBAR = -1 6374 CALL WOPEN2(LUCBAR,CBAFIL,64,0) 6375 CALL WOPEN2(LUDBAR,DBAFIL,64,0) 6376 CALL WOPEN2(LUBFD, FNBFD, 64,0) 6377 6378 ISTARTBFD = 1 6379 IOFFCD(1) = 0 6380 6381*---------------------------------------------------------------------* 6382* loop over all amplitude vectors and compute the intermediates: 6383*---------------------------------------------------------------------* 6384 DO IINT1 = 1, NINT1 6385 LIST = VTABLE(INTMED1(2,IINT1)) 6386 IDLST = INTMED1(1,IINT1) 6387 ISYMA = ILSTSYM(LIST,IDLST) 6388 6389 KT1AMPA = 1 6390 KT2AMPA = KT1AMPA + NT1AM(ISYMA) 6391 KXLAMHA = KT2AMPA + MAX(NT2AM(ISYMA),NT2AM(ISYM0)) 6392 KXLAMPA = KXLAMHA + NGLMDT(ISYMA) 6393 KXIAJB = KXLAMPA + NGLMDT(ISYMA) 6394 KEND1 = KXIAJB + MAX(NT2SQ(ISYM0),NT2SQ(ISYMA)) 6395 LWRK1 = LWORK - KEND1 6396 6397 IF (LWRK1 .LT. 0) THEN 6398 CALL QUIT('Insufficient work space in CCBPRE1INT.') 6399 END IF 6400 6401* reuse integral array for squared amplitudes and 6402* amplitude array for packed integrals: 6403 KT2AMSQ = KXIAJB 6404 KXPACK = KT2AMPA 6405 6406C ----------------------------------------------------------- 6407C read packed integrals, square up and read packed amplitudes 6408C ----------------------------------------------------------- 6409 DTIME = SECOND() 6410 6411 CALL CCG_RDIAJB(WORK(KXPACK),NT2AM(ISYM0)) 6412 CALL CC_T2SQ(WORK(KXPACK),WORK(KXIAJB),ISYM0) 6413 6414 IOPT = 3 6415 CALL CC_RDRSP(LIST,IDLST,ISYMA,IOPT,MODEL, 6416 * WORK(KT1AMPA),WORK(KT2AMPA)) 6417 CALL CCLR_DIASCL(WORK(KT2AMPA),TWO,ISYMA) 6418 6419 TIMIO = TIMIO + SECOND() - DTIME 6420 6421C ----------------------------------------------------------- 6422C calculate CBAR intermediate: 6423C ----------------------------------------------------------- 6424 DTIME = SECOND() 6425 IOPT = 2 6426 CALL CCB_CDBAR('C',WORK(KXIAJB),ISYM0,WORK(KT2AMPA),ISYMA, 6427 & DUMMY,ISYMA, WORK(KEND1),LWRK1, 6428 & CBAFIL,LUCBAR,IOFFCD(IINT1),IOPT) 6429 TIMC = TIMC + SECOND() - DTIME 6430 6431C ----------------------------------------------------------- 6432C calculate DBAR intermediate: 6433C ----------------------------------------------------------- 6434 DTIME = SECOND() 6435 IOPT = 2 6436 CALL CCB_CDBAR('D',WORK(KXIAJB),ISYM0,WORK(KT2AMPA),ISYMA, 6437 & DUMMY,ISYMA, WORK(KEND1),LWRK1, 6438 & DBAFIL,LUDBAR,IOFFCD(IINT1),IOPT) 6439 TIMD = TIMD + SECOND() - DTIME 6440 6441C --------------------------------------------------------- 6442C increment offset for CBAR & DBAR intermediate: 6443C --------------------------------------------------------- 6444 IF (IINT1.LT.NINT1) THEN 6445 IOFFCD(IINT1+1) = IOFFCD(IINT1) + NT2SQ(ISYMA) 6446 END IF 6447 6448C ------------------------------------------------------ 6449C reread response amplitudes, scale and square T2 part 6450C ------------------------------------------------------ 6451 DTIME = SECOND() 6452 6453 IOPT = 3 6454 CALL CC_RDRSP(LIST,IDLST,ISYMA,IOPT,MODEL, 6455 * WORK(KT1AMPA),WORK(KT2AMPA)) 6456 CALL CCLR_DIASCL(WORK(KT2AMPA),TWO,ISYMA) 6457 CALL CC_T2SQ(WORK(KT2AMPA),WORK(KT2AMSQ),ISYMA) 6458 6459 TIMIO = TIMIO + SECOND() - DTIME 6460 6461C ------------------------------------------------------ 6462C calculate response lambda matrices: 6463C ------------------------------------------------------ 6464 CALL CCLR_LAMTRA(XLAMDP0,WORK(KXLAMPA), 6465 * XLAMDH0,WORK(KXLAMHA), 6466 * WORK(KT1AMPA),ISYMA) 6467 6468C --------------------------------------------------------- 6469C calculate effective density for BF term and store on disk 6470C --------------------------------------------------------- 6471 DTIME = SECOND() 6472 IOPT = 3 6473 CALL CC_BFDEN(WORK(KT2AMSQ),ISYMA, DUMMY, IDUMMY, 6474 * XLAMDH0, ISYM0, XLAMDH0,ISYM0, 6475 * WORK(KXLAMHA),ISYMA, DUMMY, IDUMMY, 6476 * FNBFD, LUBFD,IADRBFD, ISTARTBFD, 6477 * IINT1, IOPT, .FALSE., WORK(KEND1),LWRK1) 6478 TIMBF = TIMBF + SECOND() - DTIME 6479 6480 END DO 6481 6482*---------------------------------------------------------------------* 6483* that's it; close files and return: 6484*---------------------------------------------------------------------* 6485 CALL WCLOSE2(LUCBAR,CBAFIL,'KEEP') 6486 CALL WCLOSE2(LUDBAR,DBAFIL,'KEEP') 6487 CALL WCLOSE2(LUBFD, FNBFD, 'KEEP') 6488 6489 CALL QEXIT('CCBPRE1INT') 6490 6491 RETURN 6492 END 6493*=====================================================================* 6494c/* Deck CC_R12BMAT */ 6495*=====================================================================* 6496 SUBROUTINE CC_R12BMAT(THETA1, THETA2, THETAR12, ISYRES, 6497 & LISTA, IDLSTA, T1AMPA, ISYMA, 6498 & LISTB, IDLSTB, T1AMPB, ISYMB, 6499 & LAMDPA, LAMDHA, LAMDPB, LAMDHB, 6500 & LAMP0, LAMH0, WORK, LWRK) 6501*---------------------------------------------------------------------* 6502* 6503* Purpose: calculate R12 contributions for B-matrix transformations 6504* 6505* C. Neiss june 2005 6506* 6507*=====================================================================* 6508 implicit none 6509#include "priunit.h" 6510#include "ccsdinp.h" 6511#include "ccsdsym.h" 6512#include "ccorb.h" 6513#include "dummy.h" 6514#include "r12int.h" 6515#include "ccr12int.h" 6516#include "ccfield.h" 6517 6518 LOGICAL LOCDBG 6519 PARAMETER (LOCDBG = .FALSE.) 6520 6521 LOGICAL LV, LVAJKL, LVIJKL 6522 INTEGER LWRK, ISYRES, IDLSTA, ISYMA, IDLSTB, ISYMB, KEND1, LWRK1 6523 INTEGER ISYM1, ISYM2, IDLST1, KEIM, KSCR, KT1AMP, KVAJKL, KVIJKL 6524 INTEGER KEND0, KT12AMP, KXINTTRI, KXINTSQ, KFIELDAO, IFLD 6525 INTEGER LUNIT, IAN, IOPT 6526 INTEGER KVABKL, KEND2, LWRK2 6527 CHARACTER LISTA*3, LISTB*3, CDUMMY*3, LIST1*3 6528 6529#if defined (SYS_CRAY) 6530 REAL WORK(LWRK), THETA1(*), THETA2(*), THETAR12(*), 6531 & T1AMPA(*),T1AMPB(*), 6532 & LAMDPA(*), LAMDHA(*), LAMDPB(*), LAMDHB(*), 6533 & LAMP0(*), LAMH0(*) 6534 REAL TIM1, TIM2, TIM3 6535 REAL ONE 6536#else 6537 DOUBLE PRECISION WORK(LWRK), THETA1(*), THETA2(*), THETAR12(*), 6538 & T1AMPA(*),T1AMPB(*), 6539 & LAMDPA(*), LAMDHA(*), LAMDPB(*), LAMDHB(*), 6540 & LAMP0(*), LAMH0(*) 6541 DOUBLE PRECISION TIM1, TIM2, TIM3 6542 DOUBLE PRECISION ONE 6543#endif 6544 PARAMETER (ONE = 1.0D0) 6545 6546 CALL QENTER('CC_R12BMAT') 6547 IF (LOCDBG) THEN 6548 WRITE(LUPRI,*) 'Entered CC_R12BMAT' 6549 CALL FLSHFO(LUPRI) 6550 ENDIF 6551C 6552 IF (ISYRES.NE.MULD2H(ISYMA,ISYMB)) THEN 6553 CALL QUIT('Symmetry error in CC_R12BMAT') 6554 ENDIF 6555C 6556 IF (CC2) THEN 6557C 6558C -------------------------------------------------------------- 6559C calculate G'-Term Singles contributions: 6560C do first E-intermediate calculation, then contract with 6561C singles Lagrangian multipliers and add to conventional term 6562C -------------------------------------------------------------- 6563C 6564 KEIM = 1 6565 KSCR = KEIM + MAX(NMATIJ(ISYMA),NMATIJ(ISYMB)) 6566 KT1AMP= KSCR + MAX(NMATAB(ISYMA),NMATAB(ISYMB)) 6567 KEND1 = KT1AMP + MAX(NT1AM(ISYMA),NT1AM(ISYMB)) 6568 LWRK1 = LWRK - KEND1 6569 IF (LWRK1 .LT. 0) THEN 6570 CALL QUIT('Insufficient work space in CC_R12BMAT') 6571 END IF 6572C 6573 DO I = 1, 2 6574C E(R12)-Intermediate: 6575C 6576 IF (I.EQ.1) THEN 6577 ISYM1 = ISYMA 6578 ISYM2 = ISYMB 6579 LIST1 = LISTA 6580 IDLST1 = IDLSTA 6581 CALL DCOPY(NT1AM(ISYMB),T1AMPB,1,WORK(KT1AMP),1) 6582 ELSE IF (I.EQ.2) THEN 6583 ISYM1 = ISYMB 6584 ISYM2 = ISYMA 6585 LIST1 = LISTB 6586 IDLST1 = IDLSTB 6587 CALL DCOPY(NT1AM(ISYMA),T1AMPA,1,WORK(KT1AMP),1) 6588 END IF 6589C 6590 CALL DZERO(WORK(KEIM),NMATIJ(ISYM1)) 6591 CALL CCRHS_EINTP(WORK(KEIM),LAMP0,WORK(KEND1),LWRK1, 6592 & 2,ISYM1,IDUMMY,IDUMMY,IDUMMY,LIST1,IDLST1) 6593C 6594 CALL DZERO(WORK(KSCR),NMATAB(ISYM1)) 6595 CALL CCLR_E1C1(THETA1,WORK(KT1AMP),WORK(KSCR),WORK(KEIM), 6596 & WORK(KEND1),LWRK1,ISYM2,ISYM1,'N') 6597C 6598 IF (LOCDBG) THEN 6599 WRITE(LUPRI,*) "E Intermediates in CC_R12BMAT:" 6600 CALL CC_PREI(WORK(KSCR),WORK(KEIM),ISYM1,1) 6601 END IF 6602C 6603 END DO 6604C 6605 END IF 6606C 6607C -------------------------------------------------------------- 6608C calculate F'-Term r12 doubles contribution 6609C -------------------------------------------------------------- 6610C 6611 KVIJKL = 1 6612 KEND0 = KVIJKL + NTR12SQ(ISYRES) 6613 KVAJKL = KEND0 6614 KSCR = KVAJKL + NVAJKL(ISYMA) 6615 KEND1 = KSCR + NTR12AM(ISYRES) 6616 LWRK1 = LWRK - KEND1 6617 IF (LWRK1 .LT. 0) THEN 6618 CALL QUIT('Insufficient work space in CC_R12BMAT') 6619 END IF 6620C 6621 CALL DZERO(WORK(KVAJKL),NVAJKL(ISYMA)) 6622 CALL DZERO(WORK(KVIJKL),NTR12SQ(ISYRES)) 6623C 6624 IF (.NOT.USEVABKL) THEN 6625C 6626 IOPT = 1 6627 CALL CC_R12MKVAMKL0(WORK(KVAJKL),NVAJKL(ISYMA),IOPT,LAMDHA, 6628 & ISYMA,WORK(KEND1),LWRK1) 6629 CALL CC_MOFCONR12(LAMDHA,ISYMA,IDUMMY,IDUMMY,IDUMMY, 6630 & IDUMMY,DUMMY,DUMMY,WORK(KVAJKL),IDUMMY, 6631 & .FALSE.,.TRUE.,.FALSE.,2, 6632 & TIM1,TIM2,TIM3, 6633 & DUMMY,IDUMMY,IDUMMY,IDUMMY,IDUMMY,IDUMMY, 6634 & WORK(KEND1),LWRK1) 6635C 6636 ELSE 6637C 6638 KVABKL = KEND1 6639 KEND2 = KVABKL + NVABKL(1) 6640 LWRK2 = LWRK - KEND2 6641 IF (LWRK2 .LT. 0) THEN 6642 CALL QUIT('Insufficient work space in CC_R12BMAT') 6643 END IF 6644C 6645 LV = .TRUE. 6646 LVAJKL = .FALSE. 6647 LVIJKL = .FALSE. 6648 CALL CC_R12MKVTF(WORK(KVABKL),WORK(KVAJKL),DUMMY, 6649 & LAMDHA,ISYMA, 6650 & LV,LVIJKL,LVAJKL,CDUMMY,WORK(KEND2),LWRK2) 6651C 6652 END IF 6653C 6654 CALL CC_R12MKVIJKL(WORK(KVAJKL),ISYMA,LAMDHB,ISYMB, 6655 & WORK(KEND1),LWRK1,.TRUE.,ONE,WORK(KVIJKL)) 6656 CALL CC_R12PKLIJ(WORK(KVIJKL),ISYRES,'T',WORK(KEND1),LWRK1) 6657C 6658C -------------------------------------------------------------- 6659C add finite field contributions 6660C -------------------------------------------------------------- 6661 IF (NONHF) THEN 6662 !allocate memory: 6663 KT12AMP = KEND0 6664 KXINTTRI = KT12AMP + MAX(NTR12SQ(ISYMA),NTR12SQ(ISYMB)) 6665 KXINTSQ = KXINTTRI + MAX(NR12R12P(1),NTR12SQ(ISYRES)) 6666 KFIELDAO = KXINTSQ + NR12R12SQ(1) 6667 KSCR = KFIELDAO + N2BST(1) 6668 KEND1 = KSCR + NTR12SQ(ISYRES) 6669 LWRK1 = LWRK - KEND1 6670 IF (LWRK1 .LT. 0) THEN 6671 CALL QUIT('Insufficient work space in CC_R12BMAT') 6672 END IF 6673C 6674 !initialize fields: 6675 CALL DZERO(WORK(KFIELDAO),N2BST(1)) 6676C 6677 IF (ISYMOP.NE.1) CALL QUIT('ISYMOP .NE. 1 not implemented') 6678C 6679 !sum up fields: 6680 DO IFLD = 1, NFIELD 6681 IF ( NHFFIELD(IFLD) ) THEN 6682 CALL CC_ONEP(WORK(KFIELDAO),WORK(KEND1),LWRK1, 6683 * EFIELD(IFLD),1,LFIELD(IFLD)) 6684 ELSE IF (.NOT. NHFFIELD(IFLD)) THEN 6685 CALL QUIT('CCR12 response can only handle '// 6686 & 'unrelaxed orbitals (w.r.t. the perturbation)') 6687 END IF 6688 END DO 6689C 6690 !read r12 overlap matrix 6691 LUNIT = -1 6692 CALL GPOPEN(LUNIT,FCCR12X,'OLD',' ','UNFORMATTED', 6693 & IDUMMY,.FALSE.) 6694 REWIND(LUNIT) 6695 8888 READ(LUNIT) IAN 6696 READ(LUNIT) (WORK(KXINTTRI-1+I), I=1, NR12R12P(1)) 6697 IF (IAN.NE.IANR12) GOTO 8888 6698 CALL GPCLOSE(LUNIT,'KEEP') 6699 IOPT = 2 6700 CALL CCR12UNPCK2(WORK(KXINTTRI),1,WORK(KXINTSQ),'N',IOPT) 6701C 6702 DO I = 1, 2 6703 IF (I.EQ.1) THEN 6704 ISYM1 = ISYMA 6705 ISYM2 = ISYMB 6706 LIST1 = LISTA 6707 IDLST1 = IDLSTA 6708 ELSE IF (I.EQ.2) THEN 6709 ISYM1 = ISYMB 6710 ISYM2 = ISYMA 6711 LIST1 = LISTB 6712 IDLST1 = IDLSTB 6713 END IF 6714 !read R12 response amplitudes 6715 CALL CC_R12GETCT(WORK(KT12AMP),ISYM1,2,KETSCL,.FALSE.,'N', 6716 & DUMMY,DUMMY,DUMMY,LIST1,IDLST1,WORK(KEND1),LWRK1) 6717 !calculate.... 6718 IF (I.EQ.1) THEN 6719 CALL CC_R12XI2A(WORK(KSCR),ISYRES,WORK(KT12AMP),ISYM1, 6720 & WORK(KFIELDAO),1,LAMP0,LAMDHB,ISYM2,'N', 6721 & WORK(KEND1),LWRK1) 6722 CALL DCOPY(NTR12SQ(ISYRES),WORK(KSCR),1,WORK(KXINTTRI),1) 6723 ELSE IF (I.EQ.2) THEN 6724 CALL CC_R12XI2A(WORK(KSCR),ISYRES,WORK(KT12AMP),ISYM1, 6725 & WORK(KFIELDAO),1,LAMP0,LAMDHA,ISYM2,'N', 6726 & WORK(KEND1),LWRK1) 6727 END IF 6728 END DO 6729C 6730 CALL DAXPY(NTR12SQ(ISYRES),ONE,WORK(KXINTTRI),1,WORK(KSCR),1) 6731 CALL CC_R12XI2B(WORK(KVIJKL),'T',WORK(KXINTSQ),1,'N', 6732 & WORK(KSCR),ISYRES,'N',-ONE) 6733C 6734 END IF 6735C 6736 !pack to triangular format: 6737 IOPT = 1 6738 CALL CCR12PCK2(WORK(KSCR),ISYRES,.FALSE.,WORK(KVIJKL),'T',IOPT) 6739 CALL CCLR_DIASCLR12(WORK(KSCR),BRASCL,ISYRES) 6740 !add to result: 6741 CALL DAXPY(NTR12AM(ISYRES),ONE,WORK(KSCR),1,THETAR12,1) 6742C 6743 IF (LOCDBG) THEN 6744 WRITE(LUPRI,*) "Theta at end of CC_R12BMAT:" 6745 CALL CC_PRP(THETA1,THETA2,ISYRES,1,1) 6746 CALL CC_PRPR12(THETAR12,ISYRES,1,.TRUE.) 6747 WRITE(LUPRI,*) 'Leaving CC_R12BMAT' 6748 END IF 6749C 6750 CALL QEXIT('CC_R12BMAT') 6751 CALL FLSHFO(LUPRI) 6752C 6753 RETURN 6754 END 6755*=====================================================================* 6756* END OF SUBROUTINE CC_R12BMAT * 6757*=====================================================================* 6758