1! 2! Dalton, a molecular electronic structure program 3! Copyright (C) by the authors of Dalton. 4! 5! This program is free software; you can redistribute it and/or 6! modify it under the terms of the GNU Lesser General Public 7! License version 2.1 as published by the Free Software Foundation. 8! 9! This program is distributed in the hope that it will be useful, 10! but WITHOUT ANY WARRANTY; without even the implied warranty of 11! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12! Lesser General Public License for more details. 13! 14! If a copy of the GNU LGPL v2.1 was not distributed with this 15! code, you can obtain one at https://www.gnu.org/licenses/old-licenses/lgpl-2.1.en.html. 16! 17! 18C 19C /* Deck cc_fop */ 20 SUBROUTINE CC_FOP(IPDD,WORK,LWORK,APROXR12) 21C 22C----------------------------------------------------------------------------- 23C 24C Purpose: Direct calculation of Coupled Cluster 25C first order properties 26C 27C CCS(CIS/HF), MP2, CCD, CCSD, CC3, CCSD(T) 28C 29C CCSDT-1a, CCSDT-1b 30C 31C RCCD,DRCC (=closed shell RPA and DRPA) and SOSEX 32C 33C and calculates modified triples corrections MCCSD(T), MCC(3) 34C 35C Solves for CC t-bar amplitudes = Lagrangian multipliers. 36C For relaxed properties also for orbital multipliers. 37C Calculates various first order one-electron properties. 38C 39C Initiated by Ove Christiansen 15 November 1994. 40C CCSD one electron FOP by Asger Halkier April 1996. 41C MP2 one electron FOP by Asger Halkier September 1996. 42C New CC solvers introduced, Ove Christiansen November 1996. 43C Frozen core contribution to unrelaxed density Ove Christiansen May 1996. 44C Major clean-up of overall structure by Asger Halkier March 1998. 45C New MP2 & CCSD version based on canonical orbitals throughout the whole 46C surface by Asger Halkier Spring 1998. This includes frozen core for 47C the relaxed density. 48C 49C Relaxed CC2 FOP by A. Halkier & S. Coriani January 2000. 50C No frozen core possible for Relaxed CC2 initially. 51C 52C CCSD(T) introduced by Kasper Hald and Sonia Coriani in 2001/2002 53C 54C CC-R12 introduced by Christian Neiss 2005 55C CCD reactivated by Sonia, 2009 56C RCCD and DRCCD, Sonia & Maria Francesca Iozzi (Fran), 2010 57C SOSEX, Thomas Bondo Pedersen 2011 58C----------------------------------------------------------------------------- 59C 60 USE PELIB_INTERFACE, ONLY: USE_PELIB, PELIB_IFC_PECC 61#include "implicit.h" 62#include "priunit.h" 63#include "dummy.h" 64#include "maxorb.h" 65#include "mxcent.h" 66 PARAMETER (ZERO = 0.0D0, ONE = 1.0D0, IZERO = 0 , TWO = 2.0D0) 67#include "codata.h" 68#include "iratdef.h" 69#include "ccfop.h" 70#include "cclr.h" 71#include "ccorb.h" 72#include "ccsdsym.h" 73#include "ccrspprp.h" 74#include "ccsdio.h" 75#include "ccsdinp.h" 76#include "ccsections.h" 77#include "ccroper.h" 78#include "ccfield.h" 79#include "exeinf.h" 80#include "infvar.h" 81#include "inftap.h" 82#include "dipole.h" 83#include "quadru.h" 84#include "nqcc.h" 85#include "ccfdgeo.h" 86#include "ccfro.h" 87#include "ccinftap.h" 88#include "ccslvinf.h" 89#include "ccnoddy.h" 90#include "r12int.h" 91#include "maxaqn.h" 92#include "symmet.h" 93#include "qm3.h" 94!#include "qmmm.h" 95#include "ccqrinf.h" 96C 97 LOGICAL CCMMCONV,DIELCONV,CCDC 98 LOGICAL CC1BSV,CC1ASV,NEWCMO_SAVE,CICLC,HFCLC, DAR2SA, 99 * TRPCLC,OOTV, EXCLC, RLORBS, LPROJECT, EX, TRIPLET, 100 * LDUM, ETASAV, LCCPTSV 101 LOGICAL BP2SAV 102 DIMENSION WORK(LWORK), ELSEMO(3,3), SKODE(3,3), SKODN(3,3) 103 CHARACTER*(*) APROXR12 104 CHARACTER*17 MODELPRI2 105 CHARACTER*10 MODEL,MODELFM 106 CHARACTER*8 LABEL1, FNTOC, FN3VI2, LABELPE 107 CHARACTER*7 FN3FOP2X 108 CHARACTER*6 FN3VI, FN3FOP2, FNDPTIA2, FNDELD, FNCKJD, FN3FOPX 109 CHARACTER*5 ETY1, FN3FOP, FNDPTIA, FNDPTAB, FNDPTIJ, FNDKBC3 110 CHARACTER*4 MODELPRI, FNDKBC 111 CHARACTER*3 LIST 112 CHARACTER*1 LR, CDUM 113 PARAMETER(FNDPTIA='DPTIA', FNDPTIA2 = 'DPTIA2', 114 * FNDPTAB='DPTAB' ,FNDPTIJ = 'DPTIJ' ) 115C 116 LOGICAL LTESTE, NATOCC 117C 118 INTEGER ISYOF(8),KOFF(8,8),NCVAI1(8,8),NCVAI2(8,8),NCVAI3(8,8) 119 INTEGER NCVIJ(8,8),NCVAI5(8,8) 120 INTEGER IPDD 121 122 REAL*8, ALLOCATABLE :: FOCKMAT(:) 123C 124#include "leinf.h" 125Cholesky 126#include "ccdeco.h" 127Cholesky 128C 129 CALL QENTER('CC_FOP') 130C Initialize variable for natural occupation numbers to false 131 NATOCC = .FALSE. 132 133C Define CCDC and initialize local variables 134 CCDC = CCSLV .AND. (.NOT. CCMM) 135 CCMMCONV = .FALSE. 136 DIELCONV = .FALSE. 137C 138C------------------------------------ 139C Header of Property calculation. 140C------------------------------------ 141C 142 WRITE (LUPRI,'(1X,A,/)') ' ' 143 WRITE (LUPRI,'(1X,A)') 144 *'*********************************************************'// 145 *'**********' 146 WRITE (LUPRI,'(1X,A)') 147 *'* '// 148 *' *' 149 WRITE (LUPRI,'(1X,A)') 150 *'*---- OUTPUT FROM COUPLED CLUSTER RESPONSE ----'// 151 *'---------*' 152 IF ( CCFOP ) THEN 153 WRITE (LUPRI,'(1X,A)') 154 * '* '// 155 * ' *' 156 WRITE (LUPRI,'(1X,A)') 157 * '*---------- CALCULATION OF FIRST ORDER PROPERTIES >'// 158 * '---------*' 159 ENDIF 160 WRITE (LUPRI,'(1X,A)') 161 *'* '// 162 *' *' 163 WRITE (LUPRI,'(1X,A,/)') 164 *'*********************************************************'// 165 *'**********' 166C 167Cholesky 168C 169 IF (CHOINT) THEN 170 CALL FLSHFO(LUPRI) 171 CALL CC_CHOFOP(WORK,LWORK) 172 GO TO 9999 173 ENDIF 174Cholesky 175C 176 MODEL = 'CCSD' 177 178 IF (CC2) THEN 179 CALL AROUND('Coupled Cluster model is: CC2') 180 MODEL = 'CC2' 181 MODELPRI = ' CC2' 182 ENDIF 183 IF (MP2) THEN 184 CALL AROUND('Model is second order pert. theory: MP2 ') 185 MODEL = 'MP2' 186 MODELPRI = ' MP2' 187 ENDIF 188 IF (CCS.AND.(.NOT.CIS)) THEN 189 CALL AROUND('Coupled Cluster model is: CCS') 190 MODEL = 'CCS' 191 MODELPRI = ' CCS' 192 ENDIF 193 IF (CCS.AND.CIS) THEN 194 CALL AROUND('CIS model in use ') 195 MODEL = 'CCS' 196 MODELPRI = ' CIS' 197 ENDIF 198 IF (CCD) THEN 199 CALL AROUND('Coupled Cluster model is: CCD') 200 MODEL = 'CCD' 201 MODELPRI = ' CCD' 202 ENDIF 203 IF (RCCD) THEN 204 CALL AROUND('Coupled Cluster model is: RCCD = RPA') 205 MODEL = 'RCCD' 206 MODELPRI = 'RCCD' 207 ENDIF 208 IF (DRCCD) THEN 209 IF (SOSEX) THEN 210 CALL AROUND('Coupled Cluster model is: SOSEX') 211 MODEL = 'SOSEX' 212 MODELPRI = 'SOSX' 213 ELSE 214 CALL AROUND('Coupled Cluster model is: DRCCD = direct RPA') 215 MODEL = 'DRCCD' 216 MODELPRI = 'DRPA' 217 ENDIF 218 ENDIF 219 IF (CC3 ) THEN 220 CALL AROUND('Coupled Cluster model is: CC3') 221 MODEL = 'CC3' 222 MODELPRI = ' CC3' 223 ENDIF 224 IF (CC1A) THEN 225 CALL AROUND('Coupled Cluster model is: CCSDT-1a') 226 MODEL = 'CCSDT-1a' 227 CALL QUIT('CCSDT-1a first order properties not implemented') 228 ENDIF 229 IF (CC1B) THEN 230 CALL AROUND('Coupled Cluster model is: CCSDT-1b') 231 MODEL = 'CCSDT-1b' 232 CALL QUIT('CCSDT-1b first order properties not implemented') 233 ENDIF 234 IF (CCPT ) THEN 235 CALL AROUND('Coupled Cluster model is CCSD(T) ') 236 MODEL = 'CCSD' 237 MODELPRI = 'CCSD' 238 ENDIF 239 IF (CCSD) THEN 240 CALL AROUND('Coupled Cluster model is: CCSD') 241 MODEL = 'CCSD' 242 MODELPRI = 'CCSD' 243 ENDIF 244C 245 MODELFM=MODEL 246C 247 IF (RELORB .AND. CC2) THEN 248 IF ((FROIMP) .OR. (FROEXP)) THEN 249 WRITE(LUPRI,*) 250 * 'No frozen core for relaxed CC2 implemented yet' 251 CALL QUIT('NO FROZEN CORE FOR RELAXED CC2 YET') 252 ENDIF 253 ENDIF 254C 255 RLORBS = RELORB 256 IF ((.NOT.RELORB) .AND. MP2) THEN 257 NWARN = NWARN + 1 258 WRITE(LUPRI,*) 'WARNING: MP2 unrelaxed first order properties ' 259 * //'not implemented ' 260 WRITE(LUPRI,*) 'Orbital relaxation switched on for MP2.' 261 RELORB = .TRUE. 262 ENDIF 263C 264 TIMIO = 0.0D0 265 TIMT2SQ = 0.0D0 266C 267 IF (IPRINT.GT.10) WRITE(LUPRI,*) 'CC_FOP-1: Workspace:',LWORK 268C 269C----------------------------- 270C Initialize Variables. 271C----------------------------- 272C 273 ISYMTR = ISYMOP 274 LIST = 'L0 ' 275C 276C---------------------------------------------------------------- 277C In case of CCS calculation, no equations need to be solved, 278C and we jump directly to calculating the requested first 279C order properties, which are identical to the HF-results. 280C In case of MP2 calculation, we need not solve equations to 281C obtaine the amplitude multipliers, which are evaluated 282C straightforwardly from integrals L(iajb). 283C Otherwise we must set up the right hand side and solve the 284C equations. 285C---------------------------------------------------------------- 286C 287 IF (CCS) GOTO 47 288 IF (L0SKIP) GOTO 46 289C 290 IF (MP2) THEN 291C 292 KMP2LA = 1 293 KWRK1 = KMP2LA + NT1AMX + NT2AMX 294 LWRK1 = LWORK - KWRK1 295C 296 IF (LWRK1 .LT. 0) THEN 297 WRITE(LUPRI,*) 'Needed:', KWRK1, 'Available:', LWORK 298 CALL QUIT('Insufficient memory for initial allocation in '// 299 & 'cc_fop') 300 ENDIF 301C 302 CALL DZERO(WORK(KMP2LA),NT1AMX + NT2AMX) 303C 304 CALL MP_LAM(WORK(KMP2LA),WORK(KWRK1),LWRK1) 305C 306 KWRK2 = KMP2LA 307 LWRK2 = LWRK1 308C 309C 310 IF ( IPRINT .GT. 10 .OR. DEBUG) THEN 311 RHO1N = DDOT(NT1AM(ISYMTR),WORK(KWRK2),1,WORK(KWRK2),1) 312 RHO2N = DDOT(NT2AM(ISYMTR),WORK(KWRK2+NT1AMX),1, 313 * WORK(KWRK2+NT1AMX),1) 314 WRITE(LUPRI,*) 'Norm of singles Lambda vector :',RHO1N 315 WRITE(LUPRI,*) 'Norm of doubles Lambda vector :',RHO2N 316 ENDIF 317C 318 IF ( IPRINT .GT. 30 ) THEN 319 CALL AROUND('CCLR_FOP: Lambda vector in mo basis' ) 320 CALL OUTPUT(WORK(KWRK2),1,NT1AMX+NT2AMX,1,1, 321 * NT1AMX+NT2AMX,1,1,LUPRI) 322 ENDIF 323C 324 IF (IPRINT.GT.1) THEN 325 DDUMMY = 0.0D0 326 WRITE(LUPRI,'(//1X,A)') 327 * 'Analysis of the undifferentiated Lagrangian multipliers:' 328 WRITE(LUPRI,'(1X,A)') 329 * '--------------------------------------------------------' 330 CALL CC_PRAM(WORK(KWRK2),DDUMMY,ISYMTR,.FALSE.) 331 END IF 332C 333 KWRK3 = KWRK2 + NT1AMX + NT2AMX 334 LWRK3 = LWORK - KWRK3 335C 336 IOPT = 3 337 CALL CC_WRRSP('L0',0,1,IOPT,MODEL,DUMMY, 338 * WORK(KWRK2),WORK(KWRK2+NT1AM(ISYMTR)), 339 * WORK(KWRK3),LWRK3) 340 341 IF ( IPRINT .GT. 10 .OR. DEBUG) THEN 342 RHO1N = DDOT(NT1AM(ISYMTR),WORK(KWRK2),1,WORK(KWRK2),1) 343 RHO2N = DDOT(NT2AM(ISYMTR),WORK(KWRK2+NT1AMX),1, 344 * WORK(KWRK2+NT1AMX),1) 345 WRITE(LUPRI,*) 'Norm of singles Lambda vector :',RHO1N 346 WRITE(LUPRI,*) 'Norm of doubles Lambda vector :',RHO2N 347 ENDIF 348 ELSE 349 350 NSTAT = 0 351 ORDER = 0 352 ISIDE = -1 353 354 ISYOF(1) = 0 355 DO I = 2, NSYM 356 ISYOF(I) = 1 357 END DO 358 359C-------------------------------- 360C Set logicals for CCSD(T) 361C-------------------------------- 362 363 LCCPTSV = .FALSE. 364 365 IF (CCPT) THEN 366 LCCPTSV = .TRUE. 367 CCPT = .FALSE. 368 CCSD = .TRUE. 369 ETASAV = ETADSC 370 ETADSC = .TRUE. 371 ! 372 !Sonia: define here FIRST_ETADC (IGRDCCPT) 373 ! 374 END IF 375 376 !call driver for solving (tbar A = eta) 377 CALL CC_SOLDRV(LIST,NSTAT,ORDER,ISIDE,APROXR12, 378 * IDUM,IDUM,RDUM,LDUM, 379 * IDUM,CDUM,RDUM,IDUM, 380 * ISYOF,1,1,WORK,LWORK) 381 382C --------------------------------------------------- 383C If this is a CC3 code using noddy code (p)recompute 384C the triples L0 multipliers and save them on file: 385C --------------------------------------------------- 386 IF (NODDY_INIT) THEN 387 CALL CCSDT_INIT_NODDY(WORK,LWORK,.TRUE.) 388 END IF 389 390C------------------------------------------------------ 391C Calculate extra contributions from CCSD(T) 392C------------------------------------------------------ 393C 394 IF (LCCPTSV) THEN 395C 396C------------------------------------------------------ 397C Start from workspace before call to solver 398C------------------------------------------------------ 399C 400 KCMO = 1 401 KT1AM = KCMO + NLAMDS 402 KT2AM = KT1AM + NT1AM(1) 403 KDENS = KT2AM + NT2SQ(1) 404 KLAMDH = KDENS + N2BST(ISYMOP) 405 KLAMDP = KLAMDH + NLAMDT 406 KWRK1 = KLAMDP + NLAMDT 407 LWRK1 = LWORK - KWRK1 408C 409 IF (LWRK1 .LT. NT2AM(1)) THEN 410 CALL QUIT('Not enough working space in ' 411 * //'cc_fop (CCSD(T) F.O.P. part') 412 ENDIF 413C 414C-------------------------------------------- 415C Construct the CMO coefficients 416C-------------------------------------------- 417C 418 419 CALL GPOPEN(LUSIFC,'SIRIFC','OLD',' ', 420 & 'UNFORMATTED',IDUMMY,.FALSE.) 421 REWIND LUSIFC 422C 423 CALL MOLLAB('TRCCINT ',LUSIFC,LUPRI) 424 READ (LUSIFC) 425 READ (LUSIFC) 426 READ (LUSIFC) (WORK(KCMO+I-1), I=1,NLAMDS) 427C 428 CALL GPCLOSE(LUSIFC,'KEEP') 429C 430 CALL CMO_REORDER(WORK(KCMO),WORK(KWRK1),LWRK1) 431 432C 433C------------------------------------ 434C Read in T1 amplitudes. 435C------------------------------------ 436C 437 IOPT = 1 438 CALL CC_RDRSP('R0',0,1,IOPT,MODEL,WORK(KT1AM),DUMMY) 439C 440C---------------------------------- 441C Calculate the lambda matrices. 442C---------------------------------- 443C 444 CALL LAMMAT(WORK(KLAMDP),WORK(KLAMDH),WORK(KT1AM), 445 * WORK(KWRK1),LWRK1) 446 447C 448C------------------------------------ 449C Read in T2 amplitude. 450C------------------------------------ 451C 452 DTIME = SECOND() 453C 454 IOPT = 2 455 CALL CC_RDRSP('R0',0,1,IOPT,MODEL,DUMMY,WORK(KWRK1)) 456C 457 IF (IPRINT .GT. 55) THEN 458 XT2TP = DDOT(NT2AM(ISYMOP),WORK(KWRK1),1,WORK(KWRK1),1) 459 WRITE(LUPRI,*) 'Norm of T2 (packed before loop) = ',XT2TP 460 ENDIF 461C 462 DTIME = SECOND() - DTIME 463 TIMIO = TIMIO + DTIME 464C 465C-------------------------------- 466C Square up T2 amplitudes. 467C-------------------------------- 468C 469 DTIME = SECOND() 470 CALL CC_T2SQ(WORK(KWRK1),WORK(KT2AM),1) 471 DTIME = SECOND() - DTIME 472 TIMT2SQ = TIMT2SQ + DTIME 473C 474 IF (IPRINT.GT.55) THEN 475 CALL AROUND('CC_FOP: (T1,T2) vector readin') 476 CALL CC_PRSQ(WORK(KT1AM),WORK(KT2AM),1,1,1) 477 ENDIF 478C 479 IF (IPRINT .GT. 55) THEN 480 XT2TP = DDOT(NT2SQ(ISYMOP),WORK(KT2AM),1,WORK(KT2AM),1) 481 WRITE(LUPRI,*) 'Norm of T2 (squared before loop) = ',XT2TP 482 ENDIF 483C 484C-------------------------------- 485C Open files for CCSD(T) 486C-------------------------------- 487C 488 LUTOC = -1 489 LU3VI = -1 490 LU3VI2 = -1 491 LU3FOP = -1 492 LU3FOP2 = -1 493 LU3FOPX = -1 494 LU3FOP2X = -1 495C 496 FNTOC = 'CCSDT_OC' 497 FN3VI = 'CC3_VI' 498 FN3VI2 = 'CC3_VI12' 499 FN3FOP = 'PTFOP' 500 FN3FOP2 = 'PTFOP2' 501 FN3FOPX = 'PTFOPX' 502 FN3FOP2X = 'PTFOP2X' 503C 504 CALL WOPEN2(LUTOC,FNTOC,64,0) 505 CALL WOPEN2(LU3VI,FN3VI,64,0) 506 CALL WOPEN2(LU3VI2,FN3VI2,64,0) 507 CALL WOPEN2(LU3FOP,FN3FOP,64,0) 508 CALL WOPEN2(LU3FOP2,FN3FOP2,64,0) 509 CALL WOPEN2(LU3FOPX,FN3FOPX,64,0) 510 CALL WOPEN2(LU3FOP2X,FN3FOP2X,64,0) 511C 512C-------------------------------------------------------------- 513C Calculate the (T) one electron densities. 514C If (RELORB) calculate also the (T) two-electron densities that 515C are needed to calculate the KappaBAR orbital multiplier. 516C Read in T2 again since it is destroyed by CCSDPT_DENS2 517C 518C OBS: we are calculating here the tbar_3 contributions to 519C the densities as well as t_3 ones. As we don't have 520C tbar_3 and t_3 on file we need to regenerate them, so 521C we need the integrals according to eqs. (53) and (15) 522C-------------------------------------------------------------- 523C 524C ECURR2 = ECURR 525C ECURR = ZERO 526C 527 if (.true.) then 528! 529!Sonia: CCSDPT_DENS2 does not work for CCSD(T) Gradient 530! with symmetry. Used old version ftb 531! 532 CALL CCSDPT_DENS2_SC(WORK(KT1AM),1,WORK(KT2AM),1,MODEL, 533 * DUMMY,IDUMMY,DUMMY,IDUMMY, 534 * WORK(KWRK1),LWRK1,IDUMMY,CDUM,IDUMMY,CDUM, 535 * IDUMMY,CDUM,LUTOC,FNTOC,LU3VI,FN3VI, 536 * LU3VI2,FN3VI2,LU3FOP,FN3FOP, 537 * LU3FOP2,FN3FOP2, 538 * LU3FOPX,FN3FOPX,LU3FOP2X,FN3FOP2X) 539 else 540 CALL CCSDPT_DENS2(WORK(KT1AM),1,WORK(KT2AM),1,MODEL, 541 * DUMMY,IDUMMY,DUMMY,IDUMMY, 542 * WORK(KWRK1),LWRK1,IDUMMY,CDUM,IDUMMY,CDUM, 543 * IDUMMY,CDUM,LUTOC,FNTOC,LU3VI,FN3VI, 544 * LU3VI2,FN3VI2,LU3FOP,FN3FOP, 545 * LU3FOP2,FN3FOP2, 546 * LU3FOPX,FN3FOPX,LU3FOP2X,FN3FOP2X) 547 end if 548C ECURR = ECURR2 549C 550C------------------------------------------------ 551C Close (integrals) files 552C------------------------------------------------ 553C 554 CALL WCLOSE2(LUTOC,FNTOC,'KEEP') 555 CALL WCLOSE2(LU3VI,FN3VI,'KEEP') 556 CALL WCLOSE2(LU3VI2,FN3VI2,'KEEP') 557 CALL WCLOSE2(LU3FOP,FN3FOP,'KEEP') 558 CALL WCLOSE2(LU3FOP2,FN3FOP2,'KEEP') 559 CALL WCLOSE2(LU3FOPX,FN3FOPX,'KEEP') 560 CALL WCLOSE2(LU3FOP2X,FN3FOP2X,'KEEP') 561C 562C------------------------------------------- 563C Read in ground state T's again 564C------------------------------------------- 565C 566 DTIME = SECOND() 567C 568 IOPT = 2 569 CALL CC_RDRSP('R0',0,1,IOPT,MODEL,DUMMY,WORK(KWRK1)) 570C 571 DTIME = SECOND() - DTIME 572 TIMIO = TIMIO + DTIME 573C 574 DTIME = SECOND() 575 CALL CC_T2SQ(WORK(KWRK1),WORK(KT2AM),1) 576 DTIME = SECOND() - DTIME 577 TIMT2SQ = TIMT2SQ + DTIME 578C 579C---------------------------------------------------------- 580C 581 CCPT = .TRUE. 582 CCSD = .FALSE. 583 ETADSC = ETASAV 584 585 END IF ! LCCPTSAVE (that is, (T) densities) 586C 587C----------------------------------------------------- 588C Calculate extra contributions from CC3 589C----------------------------------------------------- 590C 591 IF (CC3) THEN 592 593 IF (NODDY_DEN) THEN 594 595c -------------------------------------------------------- 596c call simple noddy routine (needed f.x. for finite diff.) 597c -------------------------------------------------------- 598 CALL CCSDT_XI_CONT_NODDY('L0 ',DUMMY,1,1, 599 & IDUMMY,IDUMMY,0,0,.TRUE., 600 & FNDPTIA,FNDPTIA2,FNDPTAB,FNDPTIJ, 601 & WORK,LWORK) 602 603 ELSE 604C 605C------------------------------------------------------ 606C Start from workspace before call to solver 607C------------------------------------------------------ 608C 609 KT1AM = 1 610 KT2AM = KT1AM + NT1AM(1) 611 KL1AM = KT2AM + NT2SQ(1) 612 KL2AM = KL1AM + NT1AM(ISYMOP) 613 KDENS = KL2AM + NT2SQ(ISYMOP) 614 KLAMDH = KDENS + N2BST(ISYMOP) 615 KLAMDP = KLAMDH + NLAMDT 616 KWRK1 = KLAMDP + NLAMDT 617 LWRK1 = LWORK - KWRK1 618C 619 IF (LWRK1 .LT. NT2AM(1)) THEN 620 CALL QUIT('Not enough working space in ' 621 * //'cc_fop (CCSD(T) F.O.P. part') 622 ENDIF 623C 624C----------------------------------------------- 625C Read in the T1 and T2 amplitudes. 626C----------------------------------------------- 627C 628 IOPT = 3 629 CALL CC_RDRSP('R0',0,1,IOPT,MODEL,WORK(KT1AM),WORK(KWRK1)) 630C 631 IF (IPRINT .GT. 55) THEN 632 XT2TP = DDOT(NT1AM(1),WORK(KT1AM),1,WORK(KT1AM),1) 633 WRITE(LUPRI,*) 'Norm of T1 (before loop) = ',XT2TP 634 XT2TP = DDOT(NT2AM(1),WORK(KWRK1),1,WORK(KWRK1),1) 635 WRITE(LUPRI,*) 'Norm of T2 (packed before loop) = ',XT2TP 636 ENDIF 637C 638 DTIME = SECOND() - DTIME 639 TIMIO = TIMIO + DTIME 640C 641C-------------------------------- 642C Square up T2 amplitudes. 643C-------------------------------- 644C 645 DTIME = SECOND() 646 CALL CC_T2SQ(WORK(KWRK1),WORK(KT2AM),1) 647 DTIME = SECOND() - DTIME 648 TIMT2SQ = TIMT2SQ + DTIME 649C 650 IF (IPRINT.GT.110) THEN 651 CALL AROUND('CC_FOP: (T1,T2) vector readin') 652 CALL CC_PRSQ(WORK(KT1AM),WORK(KT2AM),1,1,1) 653 ENDIF 654C 655 IF (IPRINT .GT. 55) THEN 656 XT2TP = DDOT(NT2SQ(1),WORK(KT2AM),1,WORK(KT2AM),1) 657 WRITE(LUPRI,*) 'Norm of T2 (squared before loop) = ',XT2TP 658 ENDIF 659C 660C----------------------------------------------- 661C Read in the L1 and L2 amplitudes. 662C----------------------------------------------- 663C 664 IOPT = 3 665 CALL CC_RDRSP('L0',0,1,IOPT,MODEL,WORK(KL1AM),WORK(KWRK1)) 666C 667 IF (IPRINT .GT. 55) THEN 668 XT2TP = DDOT(NT1AM(ISYMOP),WORK(KT1AM),1,WORK(KT1AM),1) 669 WRITE(LUPRI,*) 'Norm of L1 (before loop) = ',XT2TP 670 XT2TP = DDOT(NT2AM(ISYMOP),WORK(KWRK1),1,WORK(KWRK1),1) 671 WRITE(LUPRI,*) 'Norm of L2 (packed before loop) = ',XT2TP 672 ENDIF 673C 674 DTIME = SECOND() - DTIME 675 TIMIO = TIMIO + DTIME 676C 677C-------------------------------- 678C Square up L2 amplitudes. 679C-------------------------------- 680C 681 DTIME = SECOND() 682 CALL CC_T2SQ(WORK(KWRK1),WORK(KL2AM),ISYMOP) 683 DTIME = SECOND() - DTIME 684 TIMT2SQ = TIMT2SQ + DTIME 685C 686 IF (IPRINT.GT.110) THEN 687 CALL AROUND('CC_FOP: (L1,L2) vector readin') 688 CALL CC_PRSQ(WORK(KL1AM),WORK(KL2AM),ISYMOP,1,1) 689 ENDIF 690C 691 IF (IPRINT .GT. 55) THEN 692 XT2TP = DDOT(NT2SQ(ISYMOP),WORK(KL2AM),1,WORK(KL2AM),1) 693 WRITE(LUPRI,*) 'Norm of L2 (squared before loop) = ',XT2TP 694 ENDIF 695C 696C---------------------------------------- 697C Open triples files 698C---------------------------------------- 699C 700 LUDELD = -1 701 LUCKJD = -1 702 LUDKBC = -1 703 LUTOC = -1 704 LU3VI = -1 705 LUDKBC3 = -1 706 LU3FOP = -1 707 LU3FOP2 = -1 708 LU3FOPX = -1 709 LU3FOP2X = -1 710C 711 FNDELD = 'CKDELD' 712 FNCKJD = 'CKJDEL' 713 FNDKBC = 'DKBC' 714 FNTOC = 'CCSDT_OC' 715 FN3VI = 'CC3_VI' 716 FNDKBC3 = 'DKBC3' 717 FN3FOP = 'PTFOP' 718 FN3FOP2 = 'PTFOP2' 719 FN3FOPX = 'PTFOPX' 720 FN3FOP2X = 'PTFOP2X' 721C 722 CALL WOPEN2(LUDELD,FNDELD,64,0) 723 CALL WOPEN2(LUCKJD,FNCKJD,64,0) 724 CALL WOPEN2(LUDKBC,FNDKBC,64,0) 725 CALL WOPEN2(LUTOC,FNTOC,64,0) 726 CALL WOPEN2(LU3VI,FN3VI,64,0) 727 CALL WOPEN2(LUDKBC3,FNDKBC3,64,0) 728 CALL WOPEN2(LU3FOP,FN3FOP,64,0) 729 CALL WOPEN2(LU3FOP2,FN3FOP2,64,0) 730 CALL WOPEN2(LU3FOPX,FN3FOPX,64,0) 731 CALL WOPEN2(LU3FOP2X,FN3FOP2X,64,0) 732C 733C--------------------------------------------- 734C Calculate densities from triples 735C--------------------------------------------- 736C 737C ECURR2 = ECURR 738C ECURR = ZERO 739 740!SOnia: replace? 741 742 CALL CCSDPT_DENS2(WORK(KT1AM),1,WORK(KT2AM),1,MODEL, 743 * WORK(KL1AM),ISYMOP,WORK(KL2AM),ISYMOP, 744 * WORK(KWRK1),LWRK1,LUDELD,FNDELD, 745 * LUCKJD,FNCKJD,LUDKBC,FNDKBC, 746 * LUTOC,FNTOC,LU3VI,FN3VI, 747 * LUDKBC3,FNDKBC3,LU3FOP,FN3FOP, 748 * LU3FOP2,FN3FOP2, 749 * LU3FOPX,FN3FOPX,LU3FOP2X,FN3FOP2X) 750C 751 CALL WCLOSE2(LUDELD,FNDELD,'KEEP') 752 CALL WCLOSE2(LUCKJD,FNCKJD,'KEEP') 753 CALL WCLOSE2(LUDKBC,FNDKBC,'KEEP') 754 CALL WCLOSE2(LUTOC,FNTOC,'KEEP') 755 CALL WCLOSE2(LU3VI,FN3VI,'KEEP') 756 CALL WCLOSE2(LUDKBC3,FNDKBC3,'KEEP') 757 CALL WCLOSE2(LU3FOP,FN3FOP,'KEEP') 758 CALL WCLOSE2(LU3FOP2,FN3FOP2,'KEEP') 759 CALL WCLOSE2(LU3FOPX,FN3FOPX,'KEEP') 760 CALL WCLOSE2(LU3FOP2X,FN3FOP2X,'KEEP') 761C 762C ECURR = ECURR2 763C 764 DTIME = SECOND() 765C 766 IOPT = 1 767 CALL CC_RDRSP('R0',0,1,IOPT,MODEL,WORK(KT1AM),WORK(KWRK1)) 768C 769 DTIME = SECOND() - DTIME 770 TIMIO = TIMIO + DTIME 771C 772 DTIME = SECOND() 773 CALL CC_T2SQ(WORK(KWRK1),WORK(KT2AM),1) 774 DTIME = SECOND() - DTIME 775 TIMT2SQ = TIMT2SQ + DTIME 776C 777 END IF ! NODDY DEN 778C 779 ENDIF ! CC3 780C 781 ENDIF ! MODEL SELECTION 782C 783C--------------------------------------------------- 784C SLV98,OC Solvent part 1 785C Calculate norm and test for convergence. 786C--------------------------------------------------- 787C 788 IF (CCSLV .AND. (.NOT. CCMM )) THEN 789C 790 KLAM = 1 791 KLAM2 = 1 + NT1AMX 792C 793 IOPT = 3 794 CALL CC_RDRSP('L0',0,1,IOPT,MODEL,WORK(KLAM),WORK(KLAM2)) 795 796 XLNCCCU = DDOT(NT1AMX+NT2AMX,WORK(KLAM),1,WORK(KLAM),1) 797 IF (ABS(XLNCCPR-XLNCCCU).LT.CVGLSOL) LSLLCVG = .TRUE. 798 IF (IPRINT.GT.2) THEN 799 WRITE(LUPRI,*) 800 * 'Norm of L-amplitudes in this solvent it.:',XLNCCCU 801 WRITE(LUPRI,*) 802 * 'Norm of L-amplitudes in prev solvent it.:',XLNCCPR 803 WRITE(LUPRI,*) 'LSLLCVG: ',LSLLCVG 804 ENDIF 805 WRITE(LUPRI,*) 806 * ' Change in norm^2 of L-amplitudes in this solvent it.:', 807 * XLNCCCU-XLNCCPR 808 809 XLNCCPR = XLNCCCU 810C 811 KWRK3 = KLAM + NT1AMX + NT2AMX 812 KRHO1 = KWRK3 813 KRHO2 = KRHO1 + NT1AMX 814 KWRK4 = KRHO2 + NT2AMX 815 LWRK4 = LWORK - KWRK4 816 IF (LWRK4.LE.0) CALL QUIT(' Too little work in cc_fop') 817 CALL DZERO(WORK(KRHO1),NT1AMX) 818 IF (.NOT.CCS) CALL DZERO(WORK(KRHO2),NT2AMX) 819 LR = '0' 820 CALL CCSL_LTRB(WORK(KRHO1),WORK(KRHO2),DUM1,DUM2, 821 * ISYMOP,LR,WORK(KWRK4),LWRK4) 822 KOMEG1 = KWRK4 823 KOMEG2 = KWRK4 + NT1AMX 824 LUOME = -9000 825 CALL GPOPEN(LUOME,'CC_OME','UNKNOWN',' ', 826 * 'UNFORMATTED',IDUMMY,.FALSE.) 827 REWIND (LUOME) 828 READ(LUOME) (WORK(KOMEG1+K-1), K = 1,NT1AMX) 829 IF (.NOT.CCS) THEN 830 READ(LUOME) (WORK(KOMEG2+K-1), K = 1,NT2AMX) 831 ENDIF 832 CALL GPCLOSE(LUOME,'KEEP') 833C 834 CALL DAXPY(NT1AM(ISYMOP),-ONE,WORK(KRHO1),1, 835 * WORK(KOMEG1),1) 836 IF (.NOT. CCS ) THEN 837 CALL DAXPY(NT2AM(ISYMOP),-ONE,WORK(KRHO2),1, 838 * WORK(KOMEG2),1) 839 ENDIF 840C 841 ECCP1 = DDOT(NT1AMX,WORK(KLAM),1,WORK(KOMEG1),1) 842 ECCP2 = 0.0D0 843 IF (.NOT.CCS) THEN 844c CALL CCLR_DIASCL(WORK(KOMEG2),0.5D0,ISYMTR) 845 ECCP2 = DDOT(NT2AMX,WORK(KLAM2), 846 * 1,WORK(KOMEG2),1) 847 ENDIF 848 IF (IPRINT .GE. 3) THEN 849 WRITE(LUPRI,*) 'Norm of omega1 in cc_fop:', 850 * DDOT(NT1AM(ISYMOP),WORK(KOMEG1),1,WORK(KOMEG1),1) 851 WRITE(LUPRI,*) 'Norm of omega2 in cc_fop:', 852 * DDOT(NT2AM(ISYMOP),WORK(KOMEG2),1,WORK(KOMEG2),1) 853 ENDIF 854 ECCL = ECCP1 + ECCP2 855 ECCGRS = ECCGRS + ECCL 856 WRITE(LUPRI,*)'Total <Lambda|H|CC> energy: ',ECCGRS 857 WRITE(LUPRI,'(12X,A,F25.10)') 858 * 'The singles contribution is:', ECCP1 859 WRITE(LUPRI,'(12X,A,F25.10)') 860 * 'The doubles contribution is:', ECCP2 861C 862 ENDIF 863C 864C--------------------------------------------------- 865C SLV98,OC solvent part 1 end 866C--------------------------------------------------- 867C 868C--------------------------------------------------- 869C CCMM02,JK+AO qm/mm part 1 start 870C NYQMMM10, KS 871C--------------------------------------------------- 872C 873 IF (CCMM) THEN 874C 875 KLAM = 1 876 KLAM2 = 1 + NT1AMX 877C 878 IOPT = 3 879 CALL CC_RDRSP('L0',0,1,IOPT,MODEL,WORK(KLAM),WORK(KLAM2)) 880C 881 XLNCCCU = DDOT(NT1AMX+NT2AMX,WORK(KLAM),1,WORK(KLAM),1) 882C 883 IF (ABS(XLNCCPR-XLNCCCU).LT.CVGLSOL.AND.LRSPFUL) 884 * LSLLCVG = .TRUE. 885 IF (IPRINT.GT.2) THEN 886 WRITE(LUPRI,*) 887 * 'Norm of L-amplitudes in this ccmm it.:',XLNCCCU 888 WRITE(LUPRI,*) 889 * 'Norm of L-amplitudes in prev ccmm it.:',XLNCCPR 890 WRITE(LUPRI,*) 'LSLLCVG: ',LSLLCVG 891 ENDIF 892 WRITE(LUPRI,*) 893 * ' Change in norm^2 of L-amplitudes in this ccmm it.:', 894 * XLNCCCU-XLNCCPR 895 896 XLNCCPR = XLNCCCU 897C 898 KWRK3 = KLAM + NT1AMX + NT2AMX 899 KRHO1 = KWRK3 900 KRHO2 = KRHO1 + NT1AMX 901 KWRK4 = KRHO2 + NT2AMX 902 LWRK4 = LWORK - KWRK4 903C 904 IF (LWRK4.LE.0) CALL QUIT(' Too little work in cc_fop') 905 CALL DZERO(WORK(KRHO1),NT1AMX) 906 IF (.NOT.CCS) CALL DZERO(WORK(KRHO2),NT2AMX) 907 LR = '0' 908 CALL TIMER('START ',TIMSTR,TIMEND) 909 IF (.NOT. NYQMMM) THEN 910 CALL CCMM_LTRB(WORK(KRHO1),WORK(KRHO2),DUM1,DUM2, 911 * ISYMOP,LR,WORK(KWRK4),LWRK4) 912 ELSE IF (NYQMMM) THEN 913 CALL CCMM_TRANSFORMER(WORK(KRHO1),WORK(KRHO2),DUM1, 914 * DUM2,MODEL,ISYMOP,LR,WORK(KWRK4),LWRK4) 915 END IF 916 CALL TIMER('LR=R',TIMSTR,TIMEND) 917 CALL FLSHFO(LUPRI) 918C 919 KOMEG1 = KWRK4 920 KOMEG2 = KWRK4 + NT1AMX 921 LUOME = -9000 922 CALL GPOPEN(LUOME,'CC_OME','UNKNOWN',' ', 923 * 'UNFORMATTED',IDUMMY,.FALSE.) 924 REWIND (LUOME) 925 READ(LUOME) (WORK(KOMEG1+K-1), K = 1,NT1AMX) 926 IF (.NOT.CCS) THEN 927 READ(LUOME) (WORK(KOMEG2+K-1), K = 1,NT2AMX) 928 ENDIF 929 CALL GPCLOSE(LUOME,'KEEP') 930C 931 CALL DAXPY(NT1AM(ISYMOP),-ONE,WORK(KRHO1),1, 932 * WORK(KOMEG1),1) 933 IF (.NOT. CCS ) THEN 934 CALL DAXPY(NT2AM(ISYMOP),-ONE,WORK(KRHO2),1, 935 * WORK(KOMEG2),1) 936 ENDIF 937C 938 ECCP1 = DDOT(NT1AMX,WORK(KLAM),1,WORK(KOMEG1),1) 939 ECCP2 = 0.0D0 940 IF (.NOT.CCS) THEN 941! CALL CCLR_DIASCL(WORK(KOMEG2),0.5D0,ISYMTR) 942 ECCP2 = DDOT(NT2AMX,WORK(KLAM2), 943 * 1,WORK(KOMEG2),1) 944 ENDIF 945 IF (IPRINT .GE. 3) THEN 946 WRITE(LUPRI,*) 'Norm of omega1 in cc_fop:', 947 * DDOT(NT1AM(ISYMOP),WORK(KOMEG1),1,WORK(KOMEG1),1) 948 WRITE(LUPRI,*) 'Norm of omega2 in cc_fop:', 949 * DDOT(NT2AM(ISYMOP),WORK(KOMEG2),1,WORK(KOMEG2),1) 950 ENDIF 951 ECCL = ECCP1 + ECCP2 952 ECCGRS = ECCGRS + ECCL 953 WRITE(LUPRI,*)'Total <Lambda|H|CC> energy: ',ECCGRS 954 WRITE(LUPRI,'(12X,A,F25.10)') 955 * 'The singles contribution is:', ECCP1 956 WRITE(LUPRI,'(12X,A,F25.10)') 957 * 'The doubles contribution is:', ECCP2 958C 959 ENDIF 960C 961! PElib implementation 962! DH, 2016 963 IF (USE_PELIB()) THEN 964C 965 KLAM = 1 966 KLAM2 = 1 + NT1AMX 967C 968 IOPT = 3 969 CALL CC_RDRSP('L0',0,1,IOPT,MODEL,WORK(KLAM),WORK(KLAM2)) 970C 971 XLNCCCU = DDOT(NT1AMX+NT2AMX,WORK(KLAM),1,WORK(KLAM),1) 972C 973 IF ((ABS(XLNCCPR-XLNCCCU).LT.CVGLSOL).AND.LRSPFUL) 974 & LSLLCVG = .TRUE. 975 IF (IPRINT.GT.2) THEN 976 WRITE(LUPRI,*) 977 & 'Norm of L-amplitudes in this pecc it.:',XLNCCCU 978 WRITE(LUPRI,*) 979 & 'Norm of L-amplitudes in prev pecc it.:',XLNCCPR 980 ENDIF 981 WRITE(LUPRI,*) 982 & ' Change in norm^2 of L-amplitudes in this PECC it.:', 983 & XLNCCCU-XLNCCPR 984 985 XLNCCPR = XLNCCCU 986C 987 KWRK3 = KLAM + NT1AMX + NT2AMX 988 KRHO1 = KWRK3 989 KRHO2 = KRHO1 + NT1AMX 990 KGMAT = KRHO2 + NT2AMX 991 KETA = KGMAT + N2BST(ISYMTR) 992 KWRK4 = KETA + NT1AMX + NT2AMX 993 LWRK4 = LWORK - KWRK4 994C 995 IF (LWRK4.LE.0) CALL QUIT(' Too little work in cc_fop') 996 CALL DZERO(WORK(KRHO1),NT1AMX) 997 IF (.NOT.CCS) CALL DZERO(WORK(KRHO2),NT2AMX) 998 LR = '0' 999 CALL TIMER('START ',TIMSTR,TIMEND) 1000 ALLOCATE(FOCKMAT(NNBASX)) 1001 IF (HFFLD) THEN 1002 CALL GET_FROM_FILE('FOCKMHF',NNBASX,FOCKMAT) 1003 ELSE 1004 CALL GET_FROM_FILE('FOCKMAT',NNBASX,FOCKMAT) 1005 END IF 1006 CALL DSPTSI(NBAS,FOCKMAT,WORK(KGMAT)) 1007 DEALLOCATE(FOCKMAT) 1008 LABELPE = 'GIVE INT' 1009 CALL CC_XKSI(WORK(KETA),LABELPE,ISYMTR,0,WORK(KGMAT), 1010 & WORK(KWRK4),LWRK4) 1011 KETA1 = KETA 1012 KETA2 = KETA1 + NT1AMX 1013 CALL DAXPY(NT1AMX,1.0d0,WORK(KETA1),1,WORK(KRHO1),1) 1014 CALL DAXPY(NT2AMX,1.0d0,WORK(KETA2),1,WORK(KRHO2),1) 1015C 1016 CALL TIMER('LR=R',TIMSTR,TIMEND) 1017 CALL FLSHFO(LUPRI) 1018 KOMEG1 = KWRK4 1019 KOMEG2 = KWRK4 + NT1AMX 1020 LUOME = -9000 1021 CALL GPOPEN(LUOME,'CC_OME','UNKNOWN',' ', 1022 & 'UNFORMATTED',IDUMMY,.FALSE.) 1023 REWIND (LUOME) 1024 READ(LUOME) (WORK(KOMEG1+K-1), K = 1,NT1AMX) 1025 IF (.NOT.CCS) THEN 1026 READ(LUOME) (WORK(KOMEG2+K-1), K = 1,NT2AMX) 1027 ENDIF 1028 CALL GPCLOSE(LUOME,'KEEP') 1029C 1030 CALL DAXPY(NT1AM(ISYMOP),-ONE,WORK(KRHO1),1, 1031 & WORK(KOMEG1),1) 1032 IF (.NOT. CCS ) THEN 1033 CALL DAXPY(NT2AM(ISYMOP),-ONE,WORK(KRHO2),1, 1034 & WORK(KOMEG2),1) 1035 ENDIF 1036C 1037 ECCP1 = DDOT(NT1AMX,WORK(KLAM),1,WORK(KOMEG1),1) 1038 ECCP2 = 0.0D0 1039 IF (.NOT.CCS) THEN 1040 ECCP2 = DDOT(NT2AMX,WORK(KLAM2), 1041 & 1,WORK(KOMEG2),1) 1042 ENDIF 1043 IF (IPRINT .GE. 3) THEN 1044 WRITE(LUPRI,*) 'Norm of omega1 in cc_fop:', 1045 & DDOT(NT1AM(ISYMOP),WORK(KOMEG1),1,WORK(KOMEG1),1) 1046 WRITE(LUPRI,*) 'Norm of omega2 in cc_fop:', 1047 & DDOT(NT2AM(ISYMOP),WORK(KOMEG2),1,WORK(KOMEG2),1) 1048 ENDIF 1049 ECCL = ECCP1 + ECCP2 1050 ECCGRS = ECCGRS + ECCL 1051 WRITE(LUPRI,*)'Total <Lambda|H|CC> energy: ',ECCGRS 1052 WRITE(LUPRI,'(12X,A,F25.10)') 1053 & 'The singles contribution is:', ECCP1 1054 WRITE(LUPRI,'(12X,A,F25.10)') 1055 & 'The doubles contribution is:', ECCP2 1056C 1057 ENDIF 1058C 1059C--------------------------------------------------- 1060C CCMM02,JA+AO qm/mm part 1 end 1061C NYQMMM10, KS 1062C--------------------------------------------------- 1063 1064 CALL FLSHFO(LUPRI) 1065C 1066 46 CONTINUE 1067C 1068C----------------------------------------------------------------- 1069C Calculate the coupled cluster energy using density matrices, 1070C in order to check the unrelaxed CC-density. 1071C----------------------------------------------------------------- 1072C 1073 IF ((TSTDEN) .AND. (CCSD .or. CCD)) THEN 1074C 1075 CALL GPOPEN(LUSIFC,'SIRIFC','OLD',' ','UNFORMATTED',IDUMMY, 1076 & .FALSE.) 1077 REWIND LUSIFC 1078C 1079 CALL MOLLAB('SIR IPH ',LUSIFC,LUPRI) 1080 READ (LUSIFC) POTNUC 1081 CALL GPCLOSE(LUSIFC,'KEEP') 1082C 1083 KDENS = 1 1084 KWRK2 = KDENS + N2BST(ISYMOP) 1085 LWRK2 = LWORK - KWRK2 1086C 1087 IF (LWRK2 .LT. 0) 1088 * CALL QUIT(' Too little workspace in cc_fop ') 1089C 1090 IOPT = 2 1091 CALL CC_DEN(POTNUC,WORK(KDENS),WORK(KWRK2),WORK(KWRK2), 1092 * LWRK2,IOPT) 1093C 1094 ENDIF 1095C 1096 LENDEN = 2*NT1AMX + NMATIJ(1) + NMATAB(1) 1097 * + 2*NCOFRO(1) + 2*NT1FRO(1) 1098 1099!@@@@@@@@@@@@@@@@@@@ 1100 1101 IF (RELORB) THEN 1102C 1103C--------------------------------------------------------- 1104C Set up diagonal block parts of Zeta-kappa-0, for 1105C which no coupled equations need to be solved, 1106C and right hand side for ai-part of the equations. 1107C--------------------------------------------------------- 1108C 1109 LENDEN = 2*NT1AMX + NMATIJ(1) + NMATAB(1) 1110 * + 2*NCOFRO(1) + 2*NT1FRO(1) 1111C 1112 KZKAM = 1 1113 KETAAI = KZKAM + LENDEN 1114 KEXVAL = KETAAI + NALLAI(1) 1115 KSOLUT = KEXVAL + 1 1116 KAJIJ = KSOLUT + NALLAI(1) 1117 KAJFR = KAJIJ + NALLAI(1) 1118 KWRK2 = KAJFR + NALLAI(1) 1119 LWRK2 = LWORK - KWRK2 1120C 1121 IF (LWRK2 .LT. 0) THEN 1122 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KWRK2 1123 CALL QUIT('Insufficient memory for ETA(kappa) in CC_FOP') 1124 ENDIF 1125C 1126 CALL DZERO(WORK(KZKAM),LENDEN) 1127 CALL DZERO(WORK(KETAAI),NALLAI(1)) 1128 CALL DZERO(WORK(KSOLUT),NALLAI(1)) 1129 CALL DZERO(WORK(KAJIJ),NALLAI(1)) 1130 CALL DZERO(WORK(KAJFR),NALLAI(1)) 1131C 1132 IF (MP2) THEN 1133 CALL MP2_ZKDIA(IPDD,R12PRP,MODEL,WORK(KZKAM), 1134 & WORK(KWRK2),LWRK2) 1135 CALL MP2_KANEW(MODEL,WORK(KETAAI),WORK(KZKAM), 1136 & WORK(KWRK2),LWRK2) 1137cElena 1138 IF (R12PRP .AND. (IPDD .EQ. 2 .OR. IPDD .EQ. 3 .OR. 1139 & IPDD .EQ. 5)) THEN 1140 LUVAJKL = -1 1141 IF (IPDD .EQ. 2) THEN 1142 CALL GPOPEN(LUVAJKL,'CCR12YAJIJ','UNKNOWN',' ', 1143 & 'UNFORMATTED',IDUMMY,.FALSE.) 1144 ELSEIF (IPDD .EQ. 3) THEN 1145 CALL GPOPEN(LUVAJKL,'CCR12ZAJIJ','UNKNOWN',' ', 1146 & 'UNFORMATTED',IDUMMY,.FALSE.) 1147 ELSEIF (IPDD .EQ. 5) THEN 1148 CALL GPOPEN(LUVAJKL,'CCR12XAJIJ','UNKNOWN',' ', 1149 & 'UNFORMATTED',IDUMMY,.FALSE.) 1150 IF (FROIMP) THEN 1151 LUFAJKL = -1 1152 CALL GPOPEN(LUFAJKL,'CCR12YAIFR','UNKNOWN',' ', 1153 & 'UNFORMATTED',IDUMMY,.FALSE.) 1154 ENDIF 1155 ENDIF 1156 IF (FROIMP) THEN 1157 DO ISYMAJ = 1,NSYM 1158 ISYMIJ = ISYMAJ 1159 NCVAI = 0 1160 NCVAIFR = 0 1161 ICOU1 = 0 1162 ICOU2 = 0 1163 ICOU3 = 0 1164 ICOU4 = 0 1165 DO ISYMA = 1,NSYM 1166 ISYMJ = MULD2H(ISYMAJ,ISYMA) 1167 ISYMI = MULD2H(ISYMIJ,ISYMJ) 1168 NCVAI = NCVAI + NVIRS(ISYMA)*NRHF(ISYMI) 1169 NCVAIFR = NCVAIFR + NVIRS(ISYMA)*NRHFFR(ISYMI) 1170 NCVAI1(ISYMA,ISYMI) = ICOU2 1171 NCVAI3(ISYMA,ISYMI) = ICOU4 1172 ICOU3 = NVIR(ISYMA)*NRHF(ISYMI) 1173 NCVAI2(ISYMA,ISYMI) = ICOU3 1174 ICOU5 = NVIR(ISYMA)*NRHFFR(ISYMI) 1175 NCVAI5(ISYMA,ISYMI) = ICOU5 1176 NCVIJ(ISYMA,ISYMI) = ICOU1 1177 ICOU1 = ICOU1 + NVIRS(ISYMA)*NRHFFR(ISYMI) 1178 KOFF(ISYMA,ISYMI) = ICOU1 1179 ICOU2 = ICOU2 + NVIR(ISYMA)*NRHF(ISYMI) 1180 ICOU4 = ICOU4 + NVIR(ISYMA)*NRHFS(ISYMI) 1181 ENDDO 1182 ENDDO 1183 READ(LUVAJKL) (WORK(KAJIJ+I-1),I=1,NCVAI) 1184 CALL GPCLOSE(LUVAJKL,'KEEP') 1185 DO ISYM = 1, NSYM 1186 CALL DAXPY(NCVAI2(ISYM,ISYM),ONE,WORK(KAJIJ+ 1187 & NCVAI1(ISYM,ISYM)),1,WORK(KETAAI 1188 & +NCVAI1(ISYM,ISYM) 1189 & +KOFF(ISYM,ISYM)),1) 1190 ENDDO 1191 IF (IPDD .EQ. 5 .AND. FROIMP) THEN 1192 READ(LUFAJKL) (WORK(KAJFR+I-1),I=1,NCVAIFR) 1193 CALL GPCLOSE(LUFAJKL,'KEEP') 1194 DO ISYM = 1, NSYM 1195 CALL DAXPY(NCVAI5(ISYM,ISYM),ONE,WORK(KAJFR+ 1196 & NCVIJ(ISYM,ISYM)),1, 1197 & WORK(KETAAI 1198 & +NCVAI3(ISYM,ISYM)),1) 1199 ENDDO 1200 ENDIF 1201 1202 ELSE 1203 READ(LUVAJKL) (WORK(KAJIJ+I-1),I=1,NALLAI(1)) 1204 CALL GPCLOSE(LUVAJKL,'KEEP') 1205 CALL DAXPY(NALLAI(1),ONE,WORK(KAJIJ),1,WORK(KETAAI),1) 1206 END IF 1207 ENDIF 1208cElena 1209 ELSE IF (CC2) THEN 1210 IOPT = 1 1211 CALL CC2_DEN(WORK(KETAAI),WORK(KZKAM),WORK(KWRK2),LWRK2, 1212 * IOPT) 1213 IOPT = 2 1214 CALL DZERO(WORK(KETAAI),NALLAI(1)) 1215 CALL CC2_DEN(WORK(KETAAI),WORK(KZKAM),WORK(KWRK2),LWRK2, 1216 * IOPT) 1217 ELSE IF (CCSD .or. CCD) THEN 1218 IOPT = 1 1219 CALL CC_DEN(DUMMY,WORK(KETAAI),WORK(KZKAM),WORK(KWRK2), 1220 * LWRK2,IOPT) 1221C 1222 ELSE IF (RCCD.or.DRCCD) THEN 1223 !Warning: RCCD/DRCCD/SOSEX CODE IS HIGHLY EXPERIMENTAL 1224 !NOT OPTIMIZED IN ANY WAY AND SHOULD BE USED WITH CARE. 1225 !NO SYMMETRY IS IMPLEMENTED 1226 !USE IT AT YOUR OWN RISK!!! SONIA 1227 IF (RCCD) THEN 1228 !IF (LPRNCC) 1229 WRITE(LUPRI,*) "CCFOP: COMPUTE KBAR FOR RCCD" 1230 ELSE 1231 IF (SOSEX) THEN 1232 !IF (LPRNCC) 1233 WRITE(LUPRI,*) "CCFOP: COMPUTE KBAR FOR SOSEX" 1234 ELSE 1235 !IF (LPRNCC) 1236 WRITE(LUPRI,*) "CCFOP: COMPUTE KBAR FOR DRCCD" 1237 END IF 1238 END IF 1239 CALL FLSHFO(LUPRI) 1240 IOPT = 2 1241 IMODEL = 1 1242 LTESTE = .true. 1243 POTNUC = DUMMY 1244 IF (LTESTE) THEN 1245 CALL GPOPEN(LUSIFC,'SIRIFC','OLD',' ','UNFORMATTED', 1246 & IDUMMY,.FALSE.) 1247 REWIND LUSIFC 1248C 1249 CALL MOLLAB('SIR IPH ',LUSIFC,LUPRI) 1250 READ (LUSIFC) POTNUC 1251 CALL GPCLOSE(LUSIFC,'KEEP') 1252 END IF 1253 CALL DZERO(WORK(KETAAI),NALLAI(1)) 1254 !IF (LPRNCC) 1255 write(lupri,*) "CCFOP:RCCD density-based build of eta-RHS" 1256 CALL FLSHFO(LUPRI) 1257 CALL CC_DEN_RCCD(POTNUC,WORK(KETAAI),WORK(KZKAM), 1258 * WORK(KWRK2),LWRK2,IOPT,IMODEL,LTESTE) 1259 CALL FLSHFO(LUPRI) 1260 1261 ELSE IF (CCPT) THEN 1262C 1263 IOPT = 2 1264 IMODEL = 1 1265 LTESTE = .false. 1266 CCSD = .TRUE. 1267C 1268 POTNUC = DUMMY 1269 IF (LTESTE) THEN 1270 CALL GPOPEN(LUSIFC,'SIRIFC','OLD',' ','UNFORMATTED', 1271 & IDUMMY,.FALSE.) 1272 REWIND LUSIFC 1273C 1274 CALL MOLLAB('SIR IPH ',LUSIFC,LUPRI) 1275 READ (LUSIFC) POTNUC 1276 CALL GPCLOSE(LUSIFC,'KEEP') 1277 END IF 1278 1279 CALL CC_DEN_PTFC(POTNUC,WORK(KETAAI),WORK(KZKAM), 1280 * WORK(KWRK2),LWRK2,IOPT,IMODEL,LTESTE) 1281C 1282 CCSD = .FALSE. 1283C 1284 ENDIF 1285C 1286C------------------------------------------------------------ 1287C Open files for right hand side and solution vectors, 1288C and residual vectors 1289C------------------------------------------------------------ 1290C 1291 LUREVE = -2000 1292 LUSOVE = -2001 1293 LUGDVE = -2002 1294 CALL GPOPEN(LUREVE,'ZEKA0RES','UNKNOWN',' ','UNFORMATTED', 1295 * IDUMMY,.FALSE.) 1296C 1297 CALL GPOPEN(LUSOVE,'ZEKA0SOL','UNKNOWN',' ','UNFORMATTED', 1298 * IDUMMY,.FALSE.) 1299 REWIND(LUSOVE) 1300C 1301 CALL GPOPEN(LUGDVE,'ZEKA0RHS','UNKNOWN',' ','UNFORMATTED', 1302 * IDUMMY,.FALSE.) 1303 REWIND(LUGDVE) 1304 CALL WRITT(LUGDVE,NALLAI(1),WORK(KETAAI)) 1305C 1306 !do NOT remove. This norm must ALWAYS be calculated! SCH 1307 RHSNORM = DDOT(NALLAI(1),WORK(KETAAI),1,WORK(KETAAI),1) 1308 WRITE(LUPRI,*) 'CC_FOP> Norm of RHS vector:',RHSNORM 1309C 1310C CALL HEADER('RHS vectors, MP2', -1) 1311C CALL OUTPUT(WORK(KETAAI),1,NALLAI(1),1,1,NALLAI(1),1,1,LUPRI) 1312C 1313C---------------------------------------------------- 1314C Solve equations for ai-part of Zeta-kappa-0. 1315C---------------------------------------------------- 1316C 1317 NEWCMO_SAVE = NEWCMO 1318 NCOSAV = NCONF 1319C 1320 IF (DIRECT) CALL CCDFFOP 1321C 1322C ----------------------------------------------------------- 1323C Direct kappabar, if more than 256 and not all direct 1324C DIRKAPB 1325C ----------------------------------------------------------- 1326C 1327 IF ((DIRKAPB).AND.(.NOT. DIRECT)) THEN 1328 WRITE(LUPRI,*) 'Warning: in CCFOP: DKABAR = ', DIRKAPB 1329 CALL CCDFFOP 1330 END IF 1331 1332C 1333C Close the 'AOTWOINT' file before entering the abarsp. 1334C 1335 IF (LUINTA .GT. 0) THEN 1336 CALL GPCLOSE(LUINTA,'KEEP') 1337 LUINTA = -1 1338 ENDIF 1339C 1340C Open the 'SIRIFC' file before entering the abarsp. 1341C 1342 IF (LUSIFC .LE. 0) THEN 1343 CALL GPOPEN(LUSIFC,'SIRIFC','OLD',' ','UNFORMATTED',IDUMMY, 1344 & .FALSE.) 1345 END IF 1346C 1347 CICLC = .FALSE. 1348 HFCLC = .TRUE. 1349 TRPCLC = .FALSE. 1350 OOTV = .FALSE. 1351 IOPSYM = 1 1352 EXCLC = .FALSE. 1353 WORK(KEXVAL)= ZERO 1354 NEXVAL = 1 1355 NABATY = 1 1356 NABAOP = 1 1357C-tbp: put max dimension of reduced space equal to maxiter 1358C-tbp MXRM = 40 1359 MXRM = maxite 1360 1361 MXPHP = 1 1362C 1363 NEWCMO = .TRUE. 1364 NCONF = 1 1365C 1366 IF (RHSNORM.GT.1.0D-12) THEN 1367C 1368 CALL HEADER('Solving for orbital relaxation vector',-1) 1369C 1370 LABEL1 = 'ETAKAPPA' 1371C 1372 CALL ABARSP(CICLC,HFCLC,TRPCLC,OOTV,IOPSYM,EXCLC,WORK(KEXVAL), 1373 * NEXVAL,NABATY,NABAOP,LABEL1,LUGDVE,LUSOVE,LUREVE, 1374 * THRLEQ,MAXITE,IPRINT,MXRM,MXPHP,WORK(KWRK2),LWRK2) 1375C 1376 REWIND(LUSOVE) 1377 CALL READT(LUSOVE,NALLAI(1),WORK(KSOLUT)) 1378C 1379 ELSE 1380 CALL HEADER('Skipped solving for orbital relax. vector',-1) 1381 CALL DZERO(WORK(KSOLUT),NALLAI(1)) 1382 END IF 1383C 1384C CALL HEADER('After ABARSP, MP2', -1) 1385C CALL OUTPUT(WORK(KSOLUT),1,NALLAI(1),1,1,NALLAI(1),1,1,LUPRI) 1386C 1387 IF (LUINTA .LE. 0) THEN 1388 CALL MAKE_AOTWOINT(WORK(KWRK2),LWRK2) 1389 CALL GPOPEN(LUINTA,'AOTWOINT','UNKNOWN',' ','UNFORMATTED', 1390 * IDUMMY,.FALSE.) 1391 END IF 1392C 1393C--------------------------------------------------------------- 1394C Unclosed leftover from response-solver has to be closed. 1395C--------------------------------------------------------------- 1396C 1397 CALL GPCLOSE(LUSOVE,'DELETE') 1398 CALL GPCLOSE(LUGDVE,'DELETE') 1399 CALL GPCLOSE(LUREVE,'DELETE') 1400C 1401 CALL GPCLOSE(LUSIFC,'KEEP') 1402 IF (LUPROP .GT. 0) CALL GPCLOSE(LUPROP,'KEEP') 1403 IF (LUINTM .GT. 0) CALL GPCLOSE(LUINTM,'DELETE') 1404C 1405C save a copy on file CCL0___0 1406C 1407 IOPT = 4 1408 CALL CC_WRRSP('L0',0,1,IOPT,MODEL,WORK(KSOLUT),DUMMY,DUMMY, 1409 & WORK(KWRK2),LWRK2) 1410C 1411 NEWCMO = NEWCMO_SAVE 1412 NCONF = NCOSAV 1413C 1414 WRITE(LUPRI,'(/A,F10.6)') 1415 & ' Equations converged to residual less than:',THRLEQ 1416C 1417 CALL FLSHFO(LUPRI) 1418C 1419C------------------------------------------------------------------ 1420C Scale and reorder solution vector according to coupled 1421C cluster standards, and write result to disc for later use. 1422C------------------------------------------------------------------ 1423C 1424 CALL DSCAL(NALLAI(1),-ONE,WORK(KSOLUT),1) 1425C 1426 CALL CC_KABRE(WORK(KSOLUT),WORK(KZKAM),WORK(KWRK2),LWRK2) 1427C 1428 IF (IPRINT .GT. 0) THEN 1429 ZKNOR = DDOT(LENDEN,WORK(KZKAM),1,WORK(KZKAM),1) 1430 WRITE(LUPRI,*) ' ' 1431 WRITE(LUPRI,*) 'Norm of zeta-kappa-0:', ZKNOR 1432 ENDIF 1433C 1434 LUBAR0 = -516 1435 CALL GPOPEN(LUBAR0,'CCKABAR0','UNKNOWN',' ','UNFORMATTED', 1436 & IDUMMY,.FALSE.) 1437 REWIND(LUBAR0) 1438 WRITE(LUBAR0) (WORK(KZKAM+I-1), I = 1,LENDEN) 1439c write(lupri,*) 'cc_fop, KKABAR' 1440c call output(WORK(KZKAM),1,nrhft,1,nrhft,nrhft,nrhft,1,lupri) 1441 CALL GPCLOSE(LUBAR0,'KEEP') 1442C 1443C------------------------------------------------------------- 1444C Calculate the coupled cluster energy using density 1445C matrices, in order to check the effective CC-density. 1446C------------------------------------------------------------- 1447C 1448 IF ((TSTDEN) .AND. (CCSD)) THEN 1449C 1450 CALL GPOPEN(LUSIFC,'SIRIFC','OLD',' ','UNFORMATTED',IDUMMY, 1451 & .FALSE.) 1452 REWIND LUSIFC 1453C 1454 CALL MOLLAB('SIR IPH ',LUSIFC,LUPRI) 1455 READ (LUSIFC) POTNUC 1456 CALL GPCLOSE(LUSIFC,'KEEP') 1457C 1458 KSCRD = KWRK2 1459 KENDD = KSCRD + N2BST(ISYMOP) 1460 LENDD = LWORK - KENDD 1461C 1462 IF (LENDD .LT. 0) 1463 * CALL QUIT(' Too little workspace in cc_fop ') 1464C 1465 IOPT = 3 1466 CALL CC_DEN(POTNUC,WORK(KSCRD),WORK(KENDD),WORK(KENDD), 1467 * LENDD,IOPT) 1468C 1469 ENDIF 1470C 1471 ELSE !if RELORB over 1472C 1473 KWRK2 = 1 1474C 1475 ENDIF 1476C 1477 KDENS = KWRK2 1478 KWRK3 = KDENS + N2BST(ISYMOP) 1479 LWRK3 = LWORK - KWRK3 1480C 1481 IF (LWRK3 .LT. 0) THEN 1482 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KWRK3 1483 CALL QUIT('Insufficient memory for one el density in CC_FOP') 1484 ENDIF 1485C 1486 IF (.NOT.(CCSLV.OR.CCMM.OR.DIPMOM.OR.QUADRU.OR.NQCC.OR. 1487 & RELCOR.OR.DPTECO.OR.SECMOM.OR.TSTDEN.OR.(NAFOP.GT.0) 1488 & .OR.USE_PELIB())) GOTO 47 1489C 1490C---------------------------------------------------------- 1491C Calculate one electron AO-density and CC nat.occ.num. 1492C One electron densities are now recalculated for all 1493C in order to get FOPs. Relaxation contributions are 1494C passed via KZKAM 1495C---------------------------------------------------------- 1496C 1497 ILSTNR = 1 1498 !Sonia 1499 !write(lupri,*)'CCFOP: call CC_D1AO to recalc the 1e Density' 1500 !call flshfo(lupri) 1501 NATOCC=.TRUE. 1502 ! 1503 CALL CC_D1AO(IPDD,R12PRP,WORK(KDENS),WORK(KZKAM),WORK(KWRK3), 1504 & LWRK3,MODEL,LIST,ILSTNR,NATOCC, 1505 & FNDPTIA,FNDPTIA2,FNDPTAB,FNDPTIJ) 1506C 1507 IF ((FROIMP .OR. FROEXP) .AND. (.NOT. MP2)) THEN 1508C 1509C 1510 CALL CC_FCD1AO(WORK(KDENS),WORK(KWRK3),LWRK3,MODEL) 1511C 1512C 1513 ENDIF 1514C 1515 CALL FLSHFO(LUPRI) 1516C 1517 IF (IPRINT .GT. 50) THEN 1518 CALL AROUND('One electron density with orb.rel in cc_fop') 1519 CALL CC_PRFCKAO(WORK(KDENS),1) 1520 ENDIF 1521 CALL FLSHFO(LUPRI) 1522C 1523Cholesky 1524C 1525C------------------------------ 1526C Write AO density to disk. 1527C------------------------------ 1528C 1529 IF (CHOINT) THEN 1530 WRITE(LUPRI,*) 1531 WRITE(LUPRI,*) '********************************' 1532 WRITE(LUPRI,*) 'Writing AO density do disk.' 1533 WRITE(LUPRI,*) 'WARNING : You should not be here' 1534 WRITE(LUPRI,*) ' Check program flow' 1535 WRITE(LUPRI,*) 1536 WRITE(LUPRI,*) '********************************' 1537 WRITE(LUPRI,*) 1538 CALL CC_WRRSPD('d00',1,1,MODEL,RELORB,WORK(KDENS), 1539 & WORK(KWRK3),LWRK3) 1540 ENDIF 1541C 1542Cholesky 1543C 1544C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1545C Solvent section 1546C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1547C 1548 IF (CCSLV .AND. (.NOT. CCMM )) THEN 1549C 1550 KETLM = KWRK3 1551 KWRK4 = KETLM + 2*NLMCU 1552 LWRK4 = LWORK - KWRK4 1553 IF (LWRK4 .LT. 0) THEN 1554 WRITE(LUPRI,*) 'Needed:', KWRK4, 'Available:', LWORK 1555 CALL QUIT('Insufficient memory for solvent alloc in cc_fop') 1556 ENDIF 1557 CALL CC_SLV(WORK(KDENS),WORK(KETLM),DIELCONV,WORK(KWRK4),LWRK4) 1558C 1559 ENDIF 1560 1561 IF (CCMM) THEN 1562 DTIME = SECOND() 1563 CALL AROUND('Calling CC_QM3 from CC_FOP') 1564 CALL CC_QM3(WORK(KDENS),CCMMCONV,WORK(KWRK3),LWRK3) 1565 IF (IPRINT .GT. 5) THEN 1566 WRITE(LUPRI,*)'Time used in CC_QM3 (CC_FOP):', 1567 * SECOND()-DTIME 1568 END IF 1569 ENDIF 1570 IF (USE_PELIB()) THEN 1571 CALL PELIB_IFC_PECC(WORK(KDENS),VDUMMY,CCMMCONV,IDUMMY) 1572 END IF 1573 1574C--------------------------------------------------------------------- 1575C Calculate the simple one electron AO-density in CCS calculation. 1576C--------------------------------------------------------------------- 1577C 1578 47 WRITE(LUPRI,*) ' ' 1579C 1580 IF (CCS) THEN 1581C 1582 KDENS = 1 1583 KWRK3 = KDENS + N2BST(ISYMOP) 1584 LWRK3 = LWORK - KWRK3 1585C 1586 IF (LWRK3 .LT. 0) THEN 1587 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KWRK3 1588 CALL QUIT('Insufficient memory for CCS AO-density in '// 1589 & 'CC_FOP') 1590 ENDIF 1591C 1592 CALL CCS_D1AO(WORK(KDENS),WORK(KWRK3),LWRK3) 1593 IF (FROIMP .OR. FROEXP) THEN 1594 CALL CC_FCD1AO(WORK(KDENS),WORK(KWRK3),LWRK3,MODEL) 1595 ENDIF 1596 IF (IPRINT .GT. 50) THEN 1597 CALL AROUND('CCS One electron density in cc_fop') 1598 CALL CC_PRFCKAO(WORK(KDENS),1) 1599 ENDIF 1600C 1601 ENDIF 1602C 1603Cholesky 1604C 1605 IF (CHOINT) THEN 1606 WRITE(LUPRI,*) 1607 WRITE(LUPRI,*) '***************************************' 1608 WRITE(LUPRI,*) 1609 WRITE(LUPRI,*) 'WARNING : You should not be here either' 1610 WRITE(LUPRI,*) ' Check program flow' 1611 WRITE(LUPRI,*) 1612 WRITE(LUPRI,*) '***************************************' 1613 WRITE(LUPRI,*) 1614 CALL CC_WRRSPD('d00',1,1,MODEL,RELORB, 1615 & WORK(KDENS),WORK(KWRK3),LWRK3) 1616 END IF 1617C 1618Cholesky 1619C 1620 MODELPRI2 = ' Relaxed '//MODELPRI 1621 IF (.NOT. RELORB) MODELPRI2 = 'Unrelaxed '//MODELPRI 1622 IF (SOSEX) THEN 1623 IF (.NOT. RELORB) THEN 1624 MODELPRI2 = 'Unrelaxed SOSEX' 1625 ELSE 1626 MODELPRI2 = ' Relaxed SOSEX' 1627 ENDIF 1628 END IF 1629 1630 IF (CCPT) THEN 1631 IF (.NOT. RELORB) THEN 1632 MODELPRI2 = 'Unrelaxed CCSD(T)' 1633 ELSE 1634 MODELPRI2 = ' Relaxed CCSD(T)' 1635 ENDIF 1636 END IF 1637 1638 IF (DIPMOM.OR.QUADRU.OR.NQCC.OR.RELCOR.OR.SECMOM.OR. 1639 * (NAFOP.GT.0)) THEN 1640 CALL AROUND(MODELPRI2//' First-order one-electron properties: ') 1641 ENDIF 1642C 1643 IF (CCPT) THEN 1644C 1645 KCMO = KWRK3 1646 KWRK3 = KCMO + NLAMDS 1647 LWRK3 = LWORK - KWRK3 1648C 1649 IF (LWRK3 .LT. 0) THEN 1650 CALL QUIT('Not enough working space in ' 1651 * //'cc_fop (CCSD(T) F.O.P. part') 1652 ENDIF 1653C 1654C-------------------------------------------- 1655C Construct the CMO coefficients 1656C-------------------------------------------- 1657C 1658 CALL GPOPEN(LUSIFC,'SIRIFC','OLD',' ', 1659 & 'UNFORMATTED',IDUMMY,.FALSE.) 1660 REWIND LUSIFC 1661C 1662 CALL MOLLAB('TRCCINT ',LUSIFC,LUPRI) 1663 READ (LUSIFC) 1664 READ (LUSIFC) 1665 READ (LUSIFC) (WORK(KCMO+I-1), I=1,NLAMDS) 1666C 1667 CALL GPCLOSE(LUSIFC,'KEEP') 1668C 1669 CALL CMO_REORDER(WORK(KCMO),WORK(KWRK3),LWRK3) 1670 1671 1672C========================================================== 1673C Add the explicit calculated triples contributions 1674C to the AO densities from the semi-CCSD terms with 1675C triples amplitudes. 1676C========================================================== 1677C 1678 IF (.NOT. RELORB) THEN 1679 KDENS2 = KWRK3 1680 KDENS3 = KDENS2 + N2BST(ISYMOP) 1681 KWRK3 = KDENS3 + N2BST(ISYMOP) 1682 LWRK3 = LWORK - KWRK3 1683C 1684 CALL DZERO(WORK(KDENS2),N2BST(ISYMOP)) 1685 CALL DZERO(WORK(KDENS3),N2BST(ISYMOP)) 1686 ENDIF 1687C 1688C 1689 KONEAI = KWRK3 1690 KONEAB = KONEAI + NT1AM(ISYMOP) 1691 KONEIJ = KONEAB + NMATAB(ISYMOP) 1692 KRMAT = KONEIJ + NMATIJ(ISYMOP) 1693 KONEIA = KRMAT + NMATIJ(ISYMOP) 1694 KWRK4 = KONEIA + NT1AM(ISYMOP) 1695 LWRK4 = LWORK - KWRK4 1696C 1697 IF (LWRK4 .LT. 0) THEN 1698 CALL QUIT('Not enough workspace in CC_FOP (CCSD(T) part)') 1699 ENDIF 1700C 1701 CALL DZERO(WORK(KONEAI),NT1AM(ISYMOP)) 1702 CALL DZERO(WORK(KONEAB),NMATAB(ISYMOP)) 1703 CALL DZERO(WORK(KONEIJ),NMATIJ(ISYMOP)) 1704 CALL DZERO(WORK(KONEIA),NT1AM(ISYMOP)) 1705C 1706C------------------------ 1707C Read in ia part : 1708C------------------------ 1709C 1710 LUPTIA = -1 1711 CALL WOPEN2(LUPTIA,FNDPTIA,64,0) 1712C 1713 IOFF = 1 1714 CALL GETWA2(LUPTIA,FNDPTIA,WORK(KONEIA),IOFF,NT1AM(ISYMOP)) 1715 CALL WCLOSE2(LUPTIA,FNDPTIA,'KEEP') 1716C 1717 IF (IPRINT .GT. 55) THEN 1718 RHO1N = DDOT(NT1AM(ISYMOP),WORK(KONEIA),1,WORK(KONEIA),1) 1719 WRITE(LUPRI,*) 'Norm of first D_{ia} (MO) : ',RHO1N 1720 ENDIF 1721C 1722C-------------------------------- 1723C Transform to AO 1724C-------------------------------- 1725C 1726 CALL CC_DENAO(WORK(KDENS),ISYMOP,WORK(KONEAI),WORK(KONEAB), 1727 * WORK(KONEIJ),WORK(KONEIA),ISYMOP,WORK(KCMO),1, 1728 * WORK(KCMO),1,WORK(KWRK4),LWRK4) 1729C 1730C 1731C------------------------------------------------- 1732C ia, ab and ij for semirelaxed: 1733C [V,T3] in dens2 and [[V,T2],T2] in dens3 1734C------------------------------------------------- 1735C 1736 IF (.NOT. RELORB) THEN 1737C 1738 LUPTAB = -1 1739 CALL WOPEN2(LUPTAB,FNDPTAB,64,0) 1740C 1741 IOFF = 1 1742 CALL GETWA2(LUPTAB,FNDPTAB,WORK(KONEAB),IOFF, 1743 * NMATAB(ISYMOP)) 1744 CALL WCLOSE2(LUPTAB,FNDPTAB,'KEEP') 1745C 1746 LUPTIJ = -1 1747 CALL WOPEN2(LUPTIJ,FNDPTIJ,64,0) 1748C 1749 IOFF = 1 1750 CALL GETWA2(LUPTIJ,FNDPTIJ,WORK(KONEIJ),IOFF, 1751 * NMATIJ(ISYMOP)) 1752 CALL WCLOSE2(LUPTIJ,FNDPTIJ,'KEEP') 1753C 1754 CALL DZERO(WORK(KONEAI),NT1AM(ISYMOP)) 1755 CALL DZERO(WORK(KONEIA),NT1AM(ISYMOP)) 1756C 1757 IF (IPRINT .GT. 55) THEN 1758 RHO1N = DDOT(NMATAB(ISYMOP),WORK(KONEAB),1, 1759 * WORK(KONEAB),1) 1760 WRITE(LUPRI,*) 'Norm of D_{ab} (MO) : ',RHO1N 1761 RHO1N = DDOT(NMATIJ(ISYMOP),WORK(KONEIJ),1, 1762 * WORK(KONEIJ),1) 1763 WRITE(LUPRI,*) 'Norm of D_{ij} (MO) : ',RHO1N 1764 ENDIF 1765C 1766 CALL CC_DENAO(WORK(KDENS2),ISYMOP,WORK(KONEAI), 1767 * WORK(KONEAB),WORK(KONEIJ),WORK(KONEIA), 1768 * ISYMOP,WORK(KCMO),1,WORK(KCMO),1,WORK(KWRK4), 1769 * LWRK4) 1770C 1771 LUPTIA2 = -1 1772 CALL WOPEN2(LUPTIA2,FNDPTIA2,64,0) 1773C 1774 IOFF = 1 1775 CALL GETWA2(LUPTIA2,FNDPTIA2,WORK(KONEIA),IOFF, 1776 * NT1AM(ISYMOP)) 1777 CALL WCLOSE2(LUPTIA2,FNDPTIA2,'KEEP') 1778C 1779 IF (IPRINT .GT. 55) THEN 1780 RHO1N = DDOT(NT1AM(ISYMOP),WORK(KONEIA),1,WORK(KONEIA),1) 1781 WRITE(LUPRI,*) 'Norm of second D_{ia} (MO) : ',RHO1N 1782 ENDIF 1783C 1784 CALL DZERO(WORK(KONEAI),NT1AM(ISYMOP)) 1785 CALL DZERO(WORK(KONEAB),NMATAB(ISYMOP)) 1786 CALL DZERO(WORK(KONEIJ),NMATIJ(ISYMOP)) 1787 CALL CC_DENAO(WORK(KDENS3),ISYMOP,WORK(KONEAI), 1788 * WORK(KONEAB),WORK(KONEIJ),WORK(KONEIA), 1789 * ISYMOP,WORK(KCMO),1,WORK(KCMO),1, 1790 * WORK(KWRK4),LWRK4) 1791 ENDIF 1792C 1793 END IF 1794C 1795C======================================= 1796C Calculate molecular dipole moment. 1797C======================================= 1798C 1799 IF (DIPMOM) THEN 1800C 1801 CALL AROUND(' Electric Dipole Moment ') 1802C 1803C------------------------------------------- 1804C Calculate the nuclear contribution. 1805C------------------------------------------- 1806C 1807 IASGER = IPRINT - 4 1808 CALL DIPNUC(WORK(KWRK3),WORK(KWRK3),IASGER,.FALSE.) 1809C 1810 DO 100 IDIP = 1,3 1811C 1812 IF (IDIP .EQ. 1) LABEL1 = 'XDIPLEN ' 1813 IF (IDIP .EQ. 2) LABEL1 = 'YDIPLEN ' 1814 IF (IDIP .EQ. 3) LABEL1 = 'ZDIPLEN ' 1815C 1816C---------------------------------- 1817C get property integrals. 1818C---------------------------------- 1819C 1820 KONEP = KWRK3 1821 KWRK4 = KONEP + N2BST(ISYMOP) 1822 LWRK4 = LWORK - KWRK4 1823C 1824 IF (LWRK4 .LT. 0) THEN 1825 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KWRK4 1826 CALL QUIT('Insufficient memory for DIPLEN-int. in '// 1827 & 'CC_FOP') 1828 ENDIF 1829C 1830 CALL DZERO(WORK(KONEP),N2BST(ISYMOP)) 1831 FF = 1.0D0 1832 ISY = -1 1833 CALL CC_ONEP(WORK(KONEP),WORK(KWRK4),LWRK4,FF,ISY,LABEL1) 1834C 1835 IF (IPRINT .GT. 50) THEN 1836 CALL AROUND('One electron property integrals in cc_fop') 1837 CALL CC_PRFCKAO(WORK(KONEP),ISYMOP) 1838 ENDIF 1839C 1840C---------------------------------------------- 1841C Calculate the electronic contribution. 1842C---------------------------------------------- 1843C 1844 if (.false.) then 1845 write(lupri,*)'Norm of dipole integrals in FOP (CCSD)', 1846 & ddot(n2bst(isymop),work(konep),1,work(konep),1) 1847 write(lupri,*)'Norm of density in FOP (CCSD)', 1848 & ddot(n2bst(isymop),work(kdens),1,work(kdens),1) 1849 end if 1850 IF (ISY .EQ. 1 ) THEN 1851 DIPME(IDIP) = -DDOT(N2BST(ISYMOP),WORK(KONEP),1, 1852 * WORK(KDENS),1) 1853 IF (CCPT .AND. (.NOT. RELORB)) THEN 1854 DIPME2(IDIP) = -DDOT(N2BST(ISYMOP),WORK(KONEP),1, 1855 * WORK(KDENS2),1) 1856 DIPME3(IDIP) = -DDOT(N2BST(ISYMOP),WORK(KONEP),1, 1857 * WORK(KDENS3),1) 1858 ELSE IF (CCR12 .AND. (.NOT. RELORB)) THEN 1859 IF (IANR12.EQ.1) THEN 1860 CALL CC_R12PROP(PROPR12,LABEL1,APROXR12,WORK(KWRK4), 1861 & LWRK4) 1862 DIPME(IDIP) = DIPME(IDIP) - PROPR12 1863 ELSE 1864 WRITE(LUPRI,*) 'IANR12 = ',IANR12 1865 CALL QUIT('Only Ansatz 1 implemented for higher '// 1866 & 'order property R12-calculations at the moment') 1867 END IF 1868 ELSE IF ((CCR12.AND..NOT.MP2) .AND. RELORB) THEN 1869 CALL QUIT('CC-R12 response can only handle '// 1870 & 'unrelaxed orbitals: use .NONREL in input!') 1871 ENDIF 1872 ELSE 1873 DIPME(IDIP) = 0 1874C 1875 IF ((CCPT .OR. CCR12) .AND. (.NOT. RELORB)) THEN 1876 DIPME2(IDIP) = 0.0D0 1877 DIPME3(IDIP) = 0.0D0 1878 ENDIF 1879C 1880 ENDIF 1881 DIPMN(IDIP) = DIPMN(IDIP) + DIPME(IDIP) 1882C 1883C-------------------------------------------------------- 1884C Saving the dipole moment vector for use in 1885C cc_hyppol.F when printing results: 1886C-------------------------------------------------------- 1887C 1888 IF (LAVANEW) THEN 1889 DIPSAVE(IDIP) = DIPMN(IDIP) 1890 END IF 1891C 1892C-------------------------------- 1893C Store on prpc common. 1894C-------------------------------- 1895C 1896 IF (.NOT.(CCSLV.OR.USE_PELIB()) .OR.(CCMM.AND.CCMMCONV) 1897 * .OR.(CCDC.AND.DIELCONV).OR.(USE_PELIB().AND.CCMMCONV)) 1898 * CALL WRIPRO(DIPMN(IDIP),MODELFM,1,LABEL1,LABEL1,LABEL1, 1899 * LABEL1,DUMMY,DUMMY,DUMMY,ISY,0,0,0) 1900 100 CONTINUE 1901C 1902C--------------------- 1903C Print result. 1904C--------------------- 1905C 1906 IF (IASGER .GT. 0 .or. R12PRP) THEN 1907 CALL HEADER('Electronic contribution to dipole moment',-1) 1908 CALL DP0PRI(DIPME) 1909 IF (IASGER.GT.1 .or. R12PRP) THEN 1910 ! print with all digits for finite difference calc. 1911 WRITE(LUPRI,'(1X,A,3G18.10//)') 1912 * 'Electronic dipole moment (au):',DIPME 1913 ENDIF 1914 ENDIF 1915 IF (CCPT .AND. (.NOT. RELORB)) THEN 1916 CALL HEADER('Total Molecular Dipole Moment (unrelaxed)', 1917 * -1) 1918 CALL DP0PRI(DIPMN) 1919 IF (IASGER .GT. 0) THEN 1920 CALL HEADER('[V,T3] contri. to dipole moment',-1) 1921 CALL DP0PRI(DIPME2) 1922 CALL HEADER('[[V,T2],T2] contri. to dipole moment',-1) 1923 CALL DP0PRI(DIPME3) 1924 ENDIF 1925C 1926 DO IDIP = 1, 3 1927 DIPMN(IDIP) = DIPMN(IDIP) 1928 * + DIPME2(IDIP) 1929 * + DIPME3(IDIP) 1930 DIPME(IDIP) = DIPME(IDIP) 1931 * + DIPME2(IDIP) 1932 * + DIPME3(IDIP) 1933 ENDDO 1934C 1935 IF (IASGER .GT. 0) THEN 1936 CALL HEADER( 1937 * 'Semirelaxed electronic contribution to dipole moment' 1938 * ,-1) 1939 CALL DP0PRI(DIPME) 1940 ENDIF 1941 CALL HEADER('Total Semirelaxed molecular Dipole Moment ', 1942 * -1) 1943 ELSE 1944 CALL HEADER('Total Molecular Dipole Moment',-1) 1945 ENDIF 1946 CALL DP0PRI(DIPMN) 1947C 1948 CALL FLSHFO(LUPRI) 1949C 1950 ENDIF 1951C 1952C=========================================== 1953C Calculate molecular quadrupole moment. 1954C=========================================== 1955C 1956 IF (QUADRU) THEN 1957C 1958 CALL AROUND(' Electric Quadrupole Moment ') 1959C 1960C------------------------------------------- 1961C Calculate the nuclear contribution. 1962C------------------------------------------- 1963C 1964 IOPT = 1 1965 IASGER = -1 1966 CALL CCNUCQUA(WORK(KWRK3),LWRK3,IOPT,IASGER) 1967 CALL DZERO(QDREL,9) 1968C 1969 IJ = 0 1970 DO 110 I = 1,3 1971 DO 120 J = I,3 1972 IJ = IJ + 1 1973C 1974 IF (IJ .EQ. 1) LABEL1 = 'XXTHETA ' 1975 IF (IJ .EQ. 2) LABEL1 = 'XYTHETA ' 1976 IF (IJ .EQ. 3) LABEL1 = 'XZTHETA ' 1977 IF (IJ .EQ. 4) LABEL1 = 'YYTHETA ' 1978 IF (IJ .EQ. 5) LABEL1 = 'YZTHETA ' 1979 IF (IJ .EQ. 6) LABEL1 = 'ZZTHETA ' 1980C 1981C------------------------------------- 1982C get property integrals. 1983C------------------------------------- 1984C 1985 KONEP = KWRK3 1986 KWRK4 = KONEP + N2BST(ISYMOP) 1987 LWRK4 = LWORK - KWRK4 1988C 1989 IF (LWRK4 .LT. 0) THEN 1990 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KWRK4 1991 CALL QUIT('Insufficient memory for THETA-int. in '// 1992 & 'CC_FOP') 1993 ENDIF 1994C 1995 CALL DZERO(WORK(KONEP),N2BST(ISYMOP)) 1996 FF = 1.0D0 1997 ISY = -1 1998 CALL CC_ONEP(WORK(KONEP),WORK(KWRK4),LWRK4,FF,ISY,LABEL1) 1999C 2000 IF (IPRINT .GT. 50) THEN 2001 CALL AROUND('One electron property int. in cc_fop') 2002 CALL CC_PRFCKAO(WORK(KONEP),ISYMOP) 2003 ENDIF 2004C 2005C------------------------------------------------- 2006C Calculate the electronic contribution. 2007C------------------------------------------------- 2008C 2009 LENGTH = N2BST(ISYMOP) 2010C 2011 IF ( ISY .EQ. 1) THEN 2012 CALL CCELQUA(WORK(KONEP),WORK(KDENS),LENGTH,I,J,QDREL) 2013C 2014 IF (CCPT .AND. (.NOT. RELORB)) THEN 2015 CALL CCELQUA(WORK(KONEP),WORK(KDENS2),LENGTH, 2016 * I,J,QDREL2) 2017 CALL CCELQUA(WORK(KONEP),WORK(KDENS3),LENGTH, 2018 * I,J,QDREL3) 2019 ELSEIF (CCR12 .AND. (.NOT. RELORB)) THEN 2020 IF (IANR12.EQ.1) THEN 2021 CALL CC_R12PROP(PROPR12,LABEL1,APROXR12, 2022 & WORK(KWRK4),LWRK4) 2023 QDREL(IPTAX(J,1),IPTAX(I,1)) = 2024 & QDREL(IPTAX(J,1),IPTAX(I,1)) + PROPR12 2025 IF (IPTAX(I,1).NE.IPTAX(J,1)) 2026 & QDREL(IPTAX(I,1),IPTAX(J,1)) = 2027 & QDREL(IPTAX(I,1),IPTAX(J,1)) + PROPR12 2028 ELSE 2029 WRITE(LUPRI,*) 'IANR12 = ',IANR12 2030 CALL QUIT('Only Ansatz 1 implemented for higher'// 2031 & ' order property R12-calculations at the moment') 2032 ENDIF 2033 ELSE IF ((CCR12.AND..NOT.MP2) .AND. RELORB) THEN 2034 CALL QUIT('CC-R12 response can only handle '// 2035 & 'unrelaxed orbitals: use .NONREL in input!') 2036 ENDIF 2037 ENDIF 2038C 2039 120 CONTINUE 2040 110 CONTINUE 2041C 2042C------------------------ 2043C Reorder storing. 2044C------------------------ 2045C 2046 CALL CC_QUAREO(QDREL,SKODE) 2047 CALL CC_QUAREO(QDRNUC,SKODN) 2048C 2049C--------------------- 2050C Print result. 2051C--------------------- 2052C 2053 IF (IPRINT .GT. 4) THEN 2054 CALL HEADER('Nuclear contr. to quadrupole moment',-1) 2055 WRITE(LUPRI,474) 'X','Y','Z' 2056 CALL OUTPUT(SKODN,1,3,1,3,3,3,1,LUPRI) 2057 CALL HEADER('Electronic contr. to quadrupole moment',-1) 2058 WRITE(LUPRI,474) 'X','Y','Z' 2059 CALL OUTPUT(SKODE,1,3,1,3,3,3,1,LUPRI) 2060 ENDIF 2061C 2062 CALL DAXPY(9,-ONE,SKODE,1,SKODN,1) 2063C 2064 IF (CCPT .AND. (.NOT. RELORB)) THEN 2065 CALL HEADER('Total unrelaxed molecular quadrupole moment', 2066 * -1) 2067 WRITE(LUPRI,474) 'X','Y','Z' 2068 CALL OUTPUT(SKODN,1,3,1,3,3,3,1,LUPRI) 2069C 2070 CALL CC_QUAREO(QDREL2,SKODE) 2071 CALL DAXPY(9,-ONE,SKODE,1,SKODN,1) 2072C 2073 IF (IPRINT .GT. 9) THEN 2074 CALL HEADER('[V,T3] contri. to quadrupole moment',-1) 2075 WRITE(LUPRI,474) 'X','Y','Z' 2076 CALL OUTPUT(SKODE,1,3,1,3,3,3,1,LUPRI) 2077 ENDIF 2078C 2079 CALL CC_QUAREO(QDREL3,SKODE) 2080 CALL DAXPY(9,-ONE,SKODE,1,SKODN,1) 2081C 2082 IF (IPRINT .GT. 9) THEN 2083 CALL HEADER('[[V,T2],T2] contri. to quadrupole moment', 2084 * -1) 2085 WRITE(LUPRI,474) 'X','Y','Z' 2086 CALL OUTPUT(SKODE,1,3,1,3,3,3,1,LUPRI) 2087 ENDIF 2088C 2089 CALL HEADER('Total semirelaxed molecular quadrupole mom.', 2090 * -1) 2091 ELSE 2092 CALL HEADER('Total Molecular quadrupole moment',-1) 2093 ENDIF 2094 WRITE(LUPRI,474) 'X','Y','Z' 2095 CALL OUTPUT(SKODN,1,3,1,3,3,3,1,LUPRI) 2096C 2097 CALL FLSHFO(LUPRI) 2098C 2099C-------------------------------- 2100C Store on prpc common. 2101C-------------------------------- 2102C 2103 IF (.NOT.(CCSLV.OR.USE_PELIB()) .OR.(CCMM.AND.CCMMCONV) 2104 * .OR.(CCDC.AND.DIELCONV).OR.(USE_PELIB().AND.CCMMCONV)) THEN 2105 IJ = 0 2106 DO 678 I = 1, 3 2107 DO 679 J = I, 3 2108C 2109 IJ = IJ + 1 2110C 2111 IF (IJ .EQ. 1) LABEL1 = 'XXTHETA ' 2112 IF (IJ .EQ. 2) LABEL1 = 'XYTHETA ' 2113 IF (IJ .EQ. 3) LABEL1 = 'XZTHETA ' 2114 IF (IJ .EQ. 4) LABEL1 = 'YYTHETA ' 2115 IF (IJ .EQ. 5) LABEL1 = 'YZTHETA ' 2116 IF (IJ .EQ. 6) LABEL1 = 'ZZTHETA ' 2117C 2118 CALL WRIPRO(SKODN(I,J),MODELFM,1,LABEL1, 2119 * LABEL1,LABEL1,LABEL1, 2120 * DUMMY,DUMMY,DUMMY,ISY,0,0,0) 2121 2122 679 CONTINUE 2123 678 CONTINUE 2124 END IF 2125C 2126 ENDIF 2127C 2128C================================================== 2129C Calculate electronic second moment of charge. 2130C================================================== 2131C 2132 IF (SECMOM) THEN 2133C 2134 CALL AROUND(' Electronic second moment of charge ') 2135C 2136 CALL DZERO(ELSEMO,9) 2137C 2138 IF (CCPT .AND. (.NOT. RELORB)) THEN 2139 KWRK3SAVE = KWRK3 2140 KRES2 = KWRK3 2141 KRES3 = KRES2 + 9 2142 KWRK3 = KRES3 + 9 2143 LWRK3 = LWORK - KWRK3 2144C 2145 IF (LWRK3 .LT. 0) THEN 2146 WRITE(LUPRI,*) 'Available:', LWORK 2147 WRITE(LUPRI,*) 'Needed:', KWRK3 2148 CALL QUIT('Out of memory in CC_FOP (semi)') 2149 ENDIF 2150C 2151 CALL DZERO(WORK(KRES2),9) 2152 CALL DZERO(WORK(KRES3),9) 2153 ENDIF 2154C 2155 IJ = 0 2156 DO 115 I = 1,3 2157 DO 125 J = I,3 2158 IJ = IJ + 1 2159C 2160 IF (IJ .EQ. 1) LABEL1 = 'XXSECMOM' 2161 IF (IJ .EQ. 2) LABEL1 = 'XYSECMOM' 2162 IF (IJ .EQ. 3) LABEL1 = 'XZSECMOM' 2163 IF (IJ .EQ. 4) LABEL1 = 'YYSECMOM' 2164 IF (IJ .EQ. 5) LABEL1 = 'YZSECMOM' 2165 IF (IJ .EQ. 6) LABEL1 = 'ZZSECMOM' 2166C 2167C------------------------------------- 2168C get property integrals. 2169C------------------------------------- 2170C 2171 KONEP = KWRK3 2172 KWRK4 = KONEP + N2BST(ISYMOP) 2173 LWRK4 = LWORK - KWRK4 2174C 2175 IF (LWRK4 .LT. 0) THEN 2176 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KWRK4 2177 CALL QUIT('Insufficient memory for SECMOM-int. in '// 2178 & 'CC_FOP') 2179 ENDIF 2180C 2181 CALL DZERO(WORK(KONEP),N2BST(ISYMOP)) 2182 FF = 1.0D0 2183 ISY = -1 2184 CALL CC_ONEP(WORK(KONEP),WORK(KWRK4),LWRK4,FF,ISY,LABEL1) 2185C 2186 IF (IPRINT .GT. 50) THEN 2187 CALL AROUND('One electron property int. in cc_fop') 2188 CALL CC_PRFCKAO(WORK(KONEP),ISYMOP) 2189 ENDIF 2190C 2191C------------------------------------------------- 2192C Calculate the electronic contribution. 2193C------------------------------------------------- 2194C 2195 LENGTH = N2BST(ISYMOP) 2196C 2197 IF (ISY.EQ.1) THEN 2198 CALL CCELQUA(WORK(KONEP),WORK(KDENS),LENGTH,I,J,ELSEMO) 2199C 2200 IF (CCPT .AND. (.NOT. RELORB)) THEN 2201 CALL CCELQUA(WORK(KONEP),WORK(KDENS2),LENGTH, 2202 * I,J,WORK(KRES2)) 2203 CALL CCELQUA(WORK(KONEP),WORK(KDENS3),LENGTH, 2204 * I,J,WORK(KRES3)) 2205 ELSEIF (CCR12 .AND. (.NOT. RELORB)) THEN 2206 IF (IANR12.EQ.1) THEN 2207 CALL CC_R12PROP(PROPR12,LABEL1,APROXR12, 2208 & WORK(KWRK4),LWRK4) 2209 ELSEMO(IPTAX(J,1),IPTAX(I,1)) = 2210 & ELSEMO(IPTAX(J,1),IPTAX(I,1)) + PROPR12 2211 IF (IPTAX(I,1).NE.IPTAX(J,1)) 2212 & ELSEMO(IPTAX(I,1),IPTAX(J,1)) = 2213 & ELSEMO(IPTAX(I,1),IPTAX(J,1)) + PROPR12 2214 ELSE 2215 WRITE(LUPRI,*) 'IANR12 = ',IANR12 2216 CALL QUIT('Only Ansatz 1 implemented for higher'// 2217 & ' order property R12-calculations at the moment') 2218 ENDIF 2219 ELSE IF ((CCR12.AND..NOT.MP2) .AND. RELORB) THEN 2220 CALL QUIT('CC-R12 response can only handle '// 2221 & 'unrelaxed orbitals: use .NONREL in input!') 2222 ENDIF 2223 ENDIF 2224C 2225 125 CONTINUE 2226 115 CONTINUE 2227C 2228C------------------------ 2229C Reorder storing. 2230C------------------------ 2231C 2232 CALL CC_QUAREO(ELSEMO,SKODE) 2233C 2234C--------------------- 2235C Print result. 2236C--------------------- 2237C 2238 IF (CCPT .AND. (.NOT. RELORB)) THEN 2239 CALL HEADER('Unrelaxed : ',-1) 2240 WRITE(LUPRI,474) 'X','Y','Z' 2241 CALL OUTPUT(SKODE,1,3,1,3,3,3,1,LUPRI) 2242 CALL CC_TNSRAN(SKODE,WORK(KWRK3),LWRK3) 2243C 2244 CALL DAXPY(9,ONE,WORK(KRES2),1,ELSEMO,1) 2245 CALL DAXPY(9,ONE,WORK(KRES3),1,ELSEMO,1) 2246 CALL CC_QUAREO(ELSEMO,SKODE) 2247C 2248 CALL HEADER('Semirelaxed : ',-1) 2249C 2250 KWRK3 = KWRK3SAVE 2251 ENDIF 2252C 2253 WRITE(LUPRI,474) 'X','Y','Z' 2254 CALL OUTPUT(SKODE,1,3,1,3,3,3,1,LUPRI) 2255 CALL CC_TNSRAN(SKODE,WORK(KWRK3),LWRK3) 2256C 2257 CALL FLSHFO(LUPRI) 2258C 2259 ENDIF 2260C 2261 474 FORMAT(20X,A1,14X,A1,14X,A1) 2262C 2263C======================================= 2264C Calculate electric field gradient. 2265C======================================= 2266C 2267 IF (NQCC) THEN 2268C 2269 CALL AROUND(' Electric Field Gradients ') 2270C 2271 if (.NOT.R12PRP.AND.CCR12) then 2272 call quit('CCFOP: CCR12 works only with DIPMOM, QUADRU, '// 2273 & 'SECMOM and OPERAT at the moment') 2274 end if 2275C 2276 IF (CCPT .AND. (.NOT. RELORB)) THEN 2277 CALL AROUND('Unrelaxed CCSD(T) electric field gradient') 2278 ENDIF 2279C------------------------------------------- 2280C Calculate the nuclear contribution. 2281C------------------------------------------- 2282C 2283 IOPT = 2 2284 IASGER = IPRINT - 5 2285 CALL CCNUCQUA(WORK(KWRK3),LWRK3,IOPT,IASGER) 2286C 2287C---------------------------------------------- 2288C Calculate the electronic contribution. 2289C---------------------------------------------- 2290C 2291 LENGTH = N2BST(ISYMOP) 2292 CALL CCELEFG(WORK(KDENS),LENGTH,WORK(KWRK3),LWRK3,IASGER) 2293C 2294C--------------------- 2295C Print result. 2296C--------------------- 2297C 2298 KDIAG = KWRK3 2299 KAXIS = KDIAG + 3*MXCENT 2300 KWRK4 = KAXIS + 9*MXCENT 2301 LWRK4 = LWORK - KWRK4 2302C 2303 IF (LWRK4 .LT. 0) THEN 2304 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KWRK4 2305 CALL QUIT('Insufficient memory for EFG-results in CC_FOP') 2306 ENDIF 2307C 2308 IF (CCPT .AND. (.NOT. RELORB)) THEN 2309C 2310 IASGER = 2 2311 ICCPRI = 2 2312 CALL NQCRES(IASGER,WORK(KDIAG),WORK(KAXIS),ICCPRI) 2313C 2314 CALL DZERO(WORK(KDIAG),3*MXCENT) 2315 CALL DZERO(WORK(KAXIS),9*MXCENT) 2316C 2317 CALL AROUND('Semirelaxed CCSD(T) electric field gradient') 2318C 2319 IOPT = 2 2320 IASGER = IPRINT - 5 2321 CALL CCNUCQUA(WORK(KWRK4),LWRK4,IOPT,IASGER) 2322C 2323 LENGTH = N2BST(ISYMOP) 2324 CALL DAXPY(LENGTH,ONE,WORK(KDENS2),1,WORK(KDENS),1) 2325 CALL DAXPY(LENGTH,ONE,WORK(KDENS3),1,WORK(KDENS),1) 2326C 2327 CALL CCELEFG(WORK(KDENS),LENGTH,WORK(KWRK4),LWRK4, 2328 * IASGER) 2329C 2330 CALL DAXPY(LENGTH,-ONE,WORK(KDENS2),1,WORK(KDENS),1) 2331 CALL DAXPY(LENGTH,-ONE,WORK(KDENS3),1,WORK(KDENS),1) 2332C 2333 ENDIF 2334C 2335 IASGER = 2 2336 ICCPRI = 2 2337 CALL NQCRES(IASGER,WORK(KDIAG),WORK(KAXIS),ICCPRI) 2338C 2339 CALL FLSHFO(LUPRI) 2340C 2341 ENDIF 2342C 2343C============================================== 2344C Calculate first-order relativistic energy 2345C corrections within the DPT framework. 2346C============================================== 2347C 2348 IF (DPTECO) THEN 2349C 2350 CALL AROUND(' First-order DPT corrections to the ground-state' 2351 * //' energy ') 2352C 2353 if (.NOT.R12PRP.AND.CCR12) then 2354 call quit('CCFOP: CCR12 works only with DIPMOM, QUADRU, '// 2355 & 'SECMOM and OPERAT at the moment') 2356 end if 2357C 2358 LABEL1 = 'DERXXPVP' 2359C 2360C---------------------------------------------------- 2361C Calculate the first and simplest correction. 2362C---------------------------------------------------- 2363C 2364 KONEP = KWRK3 2365 KWRK4 = KONEP + N2BST(ISYMOP) 2366 LWRK4 = LWORK - KWRK4 2367C 2368 IF (LWRK4 .LT. 0) THEN 2369 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KWRK4 2370 CALL QUIT('Insufficient memory for DPT-integrals in CC_FOP') 2371 ENDIF 2372C 2373 CALL DZERO(WORK(KONEP),N2BST(ISYMOP)) 2374 FF = 1.0D0 2375 ISY = 1 2376 CALL CC_ONEP(WORK(KONEP),WORK(KWRK4),LWRK4,FF,ISY,LABEL1) 2377C 2378 IF (IPRINT .GT. 50) THEN 2379 CALL AROUND('Relativistic integrals in cc_fop') 2380 CALL CC_PRFCKAO(WORK(KONEP),ISYMOP) 2381 ENDIF 2382C 2383 DPTONE = ALPHA2*DDOT(N2BST(ISYMOP),WORK(KONEP),1,WORK(KDENS),1) 2384C 2385 DPTFLD = ZERO 2386C 2387 IF (NFIELD .GT. 0) THEN 2388C 2389C ------------------------------------------------------------- 2390C Add contributions from external fields (WK/UniKA/11-03-2004). 2391C ------------------------------------------------------------- 2392C 2393 DO IFIELD = 1, NFIELD 2394 IF (LFIELD(IFIELD) .EQ. 'OVERLAP ') THEN 2395 LABEL1 = 'KINENERG' 2396 FF = 0.5D0 * EFIELD(IFIELD) 2397 ELSE IF (LFIELD(IFIELD) .EQ. 'CM000000') THEN 2398 LABEL1 = 'KINENERG' 2399 FF = 0.5D0 * EFIELD(IFIELD) 2400 ELSE IF (LFIELD(IFIELD) .EQ. 'XDIPLEN ') THEN 2401 LABEL1 = 'PXPDIPOL' 2402 FF = EFIELD(IFIELD) 2403 ELSE IF (LFIELD(IFIELD) .EQ. 'YDIPLEN ') THEN 2404 LABEL1 = 'PYPDIPOL' 2405 FF = EFIELD(IFIELD) 2406 ELSE IF (LFIELD(IFIELD) .EQ. 'ZDIPLEN ') THEN 2407 LABEL1 = 'PZPDIPOL' 2408 FF = EFIELD(IFIELD) 2409 ELSE 2410 CALL QUIT('DPT correction can not be computed with' 2411 * //' this finite field switched on') 2412 ENDIF 2413 KONEP = KWRK3 2414 KWRK4 = KONEP + N2BST(ISYMOP) 2415 LWRK4 = LWORK - KWRK4 2416C 2417 IF (LWRK4 .LT. 0) THEN 2418 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KWRK4 2419 CALL QUIT('Insufficient memory for '// 2420 * 'DPT-integrals in CC_FOP') 2421 ENDIF 2422C 2423 CALL DZERO(WORK(KONEP),N2BST(ISYMOP)) 2424 ISY = 1 2425 CALL CC_ONEP(WORK(KONEP),WORK(KWRK4),LWRK4,FF,ISY,LABEL1) 2426C 2427 IF (IPRINT .GT. 50) THEN 2428 CALL AROUND('Relativistic integrals in cc_fop') 2429 CALL CC_PRFCKAO(WORK(KONEP),ISYMOP) 2430 ENDIF 2431C 2432 DPTLAB = DDOT(N2BST(ISYMOP),WORK(KONEP),1,WORK(KDENS),1) 2433 DPTLAB = DPTLAB * ALPHA2 2434 DPTFLD = DPTFLD + DPTLAB 2435 WRITE(LUPRI,*) ' ' 2436 WRITE(LUPRI,1361) 'DPTFLD:', DPTLAB, LFIELD(IFIELD) 2437 WRITE(LUPRI,138) '------ ' 2438 ENDDO 2439 ENDIF 2440C 2441C---------------------------------------------------------- 2442C Calculate the second "one-electron term" - similar 2443C to the reorthonormalization term of the gradient. 2444C---------------------------------------------------------- 2445C 2446 RESONE = ZERO 2447 REORTH = ZERO 2448 IGROPT = 2 2449 ! 2450 ! Need to update this as well for CCSD(T) 2451 ! 2452 if (.false.) then 2453 CALL CC_GRAD(RESONE,REORTH,WORK(KWRK4),LWRK4,IGROPT) 2454 else 2455 CALL CC_GRAD_1(RESONE,REORTH,WORK(KWRK4),LWRK4,IGROPT) 2456 end if 2457 ! 2458 REORTH = ALPHA2*REORTH 2459 IF (NFIELD .GT. 0) THEN 2460 WRITE(LUPRI,*) ' ' 2461 WRITE(LUPRI,1361) 'DPTFLD:', DPTFLD, 'TOTAL ' 2462 WRITE(LUPRI,138) '------ ' 2463 WRITE(LUPRI,*) ' ' 2464 ENDIF 2465 WRITE(LUPRI,*) ' ' 2466 WRITE(LUPRI,136) 'DPTONE:', DPTONE 2467 WRITE(LUPRI,138) '------ ' 2468 WRITE(LUPRI,*) ' ' 2469 WRITE(LUPRI,136) 'DPTREO:', REORTH 2470 WRITE(LUPRI,138) '------ ' 2471C 2472 136 FORMAT(9X,A7,F20.12) 2473 1361 FORMAT(9X,A7,F20.12,4X,'(',A8,')') 2474 137 FORMAT(9X,A33,F20.12) 2475 138 FORMAT(9X,A7) 2476 139 FORMAT(9X,A32) 2477C 2478C------------------------------------------------------------ 2479C Calculate the "ordinary two-electron term" - similar 2480C to the "simple" two-electron term of the gradient. 2481C------------------------------------------------------------ 2482C 2483 DAR2SA = DAR2EL 2484 IF (DAR2EL) DAR2EL = .FALSE. 2485 BP2SAV = BP2EOO 2486 IF (BP2EOO) BP2EOO = .FALSE. 2487 2488 IOPREL = 2 2489 if (.false.) then 2490 CALL CC_2EEXP(WORK(KWRK4),LWRK4,IOPREL) 2491 else 2492 CALL CC_2EEXP_2(WORK(KWRK4),LWRK4,IOPREL) 2493 end if 2494 DAR2EL = DAR2SA 2495 BP2EOO = BP2SAV 2496C 2497 WRITE(LUPRI,*) ' ' 2498 WRITE(LUPRI,136) 'DPTTWO:', WORK(KWRK4) 2499 WRITE(LUPRI,138) '------ ' 2500 WRITE(LUPRI,*) ' ' 2501 WRITE(LUPRI,137) 'Total first-order DPT correction:', 2502 * DPTONE+REORTH+WORK(KWRK4)+DPTFLD 2503 WRITE(LUPRI,139) '--------------------------------' 2504C 2505 ENDIF 2506C 2507C========================================================================= 2508C Standard scalar relativistic corrections to the ground-state energy. 2509C========================================================================= 2510C 2511 IF (RELCOR) THEN 2512C 2513 CALL AROUND(' Pauli relativistic corrections to the' 2514 * //' ground-state energy ') 2515C 2516 if (.NOT.R12PRP.AND.CCR12) then 2517 call quit('CCFOP: CCR12 works only with DIPMOM, QUADRU, '// 2518 & 'SECMOM and OPERAT at the moment') 2519 end if 2520C 2521 DO 130 IRC = 1,2 2522C 2523 IF (IRC .EQ. 1) LABEL1 = 'DARWIN ' 2524 IF (IRC .EQ. 2) LABEL1 = 'MASSVELO' 2525C 2526C----------------------------- 2527C get the integrals. 2528C----------------------------- 2529C 2530 KONEP = KWRK3 2531 KWRK4 = KONEP + N2BST(ISYMOP) 2532 LWRK4 = LWORK - KWRK4 2533C 2534 IF (LWRK4 .LT. 0) THEN 2535 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KWRK4 2536 CALL QUIT('Insufficient memory for Darwin-int. in '// 2537 & 'CC_FOP') 2538 ENDIF 2539C 2540 CALL DZERO(WORK(KONEP),N2BST(ISYMOP)) 2541 FF = 1.0D0 2542 ISY = 1 2543 CALL CC_ONEP(WORK(KONEP),WORK(KWRK4),LWRK4,FF,ISY,LABEL1) 2544C 2545 IF (IPRINT .GT. 50) THEN 2546 CALL AROUND('Relativistic integrals in cc_fop') 2547 CALL CC_PRFCKAO(WORK(KONEP),ISYMOP) 2548 ENDIF 2549C 2550C------------------------------------- 2551C Calculate the corrections. 2552C------------------------------------- 2553C 2554 IF (IRC .EQ. 1) THEN 2555 DARW = DDOT(N2BST(ISYMOP),WORK(KONEP),1,WORK(KDENS),1) 2556C 2557 IF (CCPT .AND. (.NOT. RELORB)) THEN 2558 DARW2 = DDOT(N2BST(ISYMOP),WORK(KONEP),1, 2559 * WORK(KDENS2),1) 2560 DARW3 = DDOT(N2BST(ISYMOP),WORK(KONEP),1, 2561 * WORK(KDENS3),1) 2562 ENDIF 2563C 2564 ELSE IF (IRC .EQ. 2) THEN 2565 VELO = DDOT(N2BST(ISYMOP),WORK(KONEP),1,WORK(KDENS),1) 2566C 2567 IF (CCPT .AND. (.NOT. RELORB)) THEN 2568 VELO2 = DDOT(N2BST(ISYMOP),WORK(KONEP),1, 2569 * WORK(KDENS2),1) 2570 VELO3 = DDOT(N2BST(ISYMOP),WORK(KONEP),1, 2571 * WORK(KDENS3),1) 2572 ENDIF 2573 ENDIF 2574C 2575C-------------------------------- 2576C Store on prpc common. 2577C-------------------------------- 2578C 2579 IF (IRC.EQ.1) PROP = DARW 2580 IF (IRC.EQ.2) PROP = VELO 2581 IF (.NOT.(CCSLV.OR.USE_PELIB()) .OR.(CCMM.AND.CCMMCONV) 2582 * .OR.(CCDC.AND.DIELCONV).OR.(USE_PELIB().AND.CCMMCONV)) 2583 * CALL WRIPRO(PROP,MODELFM,1,LABEL1,LABEL1,LABEL1,LABEL1, 2584 * DUMMY,DUMMY,DUMMY,ISY,0,0,0) 2585 130 CONTINUE 2586C 2587C---------------------- 2588C Write out result. 2589C---------------------- 2590C 2591 IF (CCPT .AND. (.NOT. RELORB)) THEN 2592 WRITE(LUPRI,*) ' ' 2593 WRITE(LUPRI,135) 'Unrelaxed 1e Darwin term :', 2594 * DARW 2595 WRITE(LUPRI,135) '[V,T3] 1e Darwin term :', 2596 * DARW2 2597 WRITE(LUPRI,135) '[[V,T2],T2] 1e Darwin term :', 2598 * DARW3 2599 WRITE(LUPRI,135) 'Semirelaxed 1e Darwin term :', 2600 * DARW+DARW2+DARW3 2601 WRITE(LUPRI,132) '------------------- ' 2602 WRITE(LUPRI,*) ' ' 2603 WRITE(LUPRI,135) 'Unrelaxed Mass-Velocity term :', 2604 * VELO 2605 WRITE(LUPRI,135) '[V,T3] Mass-Velocity term :', 2606 * VELO2 2607 WRITE(LUPRI,135) '[[V,T2],T2] Mass-Velocity term :', 2608 * VELO3 2609 WRITE(LUPRI,135) 'Semirelaxed Mass-Velocity term :', 2610 * VELO+VELO2+VELO3 2611 WRITE(LUPRI,132) '------------------ ' 2612 WRITE(LUPRI,*) ' ' 2613 WRITE(LUPRI,135) 'Unrelaxed Mass-Velocity + 1e Darwin :', 2614 * DARW+VELO 2615 WRITE(LUPRI,135) 'Semirelaxed Mass-Velocity+ 1e Darwin:', 2616 * DARW+DARW2+DARW3+VELO+VELO2+VELO3 2617 WRITE(LUPRI,134) '------------------------------------ ' 2618 ELSE 2619 WRITE(LUPRI,*) ' ' 2620 WRITE(LUPRI,131) '1-elec. Darwin term:', DARW 2621 WRITE(LUPRI,132) '------------------- ' 2622 WRITE(LUPRI,*) ' ' 2623 WRITE(LUPRI,131) 'Mass-Velocity term: ', VELO 2624 WRITE(LUPRI,132) '------------------ ' 2625 WRITE(LUPRI,*) ' ' 2626 WRITE(LUPRI,133) 'Mass-Velocity + 1-elec. Darwin terms:', 2627 * DARW+VELO 2628 WRITE(LUPRI,134) '------------------------------------ ' 2629 ENDIF 2630C 2631 131 FORMAT(9X,A20,F17.9) 2632 132 FORMAT(9X,A20) 2633 133 FORMAT(9X,A37,1X,F17.9) 2634 134 FORMAT(9X,A37) 2635 135 FORMAT(9X,A36,1X,F17.9) 2636C 2637 ENDIF 2638C 2639C-------------------------------------------------------------------- 2640C Calculate the relativistic two-electron Darwin term correction. 2641C-------------------------------------------------------------------- 2642C 2643celena 2644 IF (R12PRP .AND. DAR2EL) THEN 2645 WRITE(LUPRI,*) 'Two-electron Darwin term correction 2646 & not implemented with R12' 2647 DAR2EL = .FALSE. 2648 ENDIF 2649 IF (DAR2EL) THEN 2650 if (.NOT.R12PRP.AND.CCR12) then 2651 call quit('CCFOP: CCR12 works only with DIPMOM, QUADRU, '// 2652 & 'SECMOM and OPERAT at the moment') 2653 end if 2654 IF (RELCOR) THEN 2655 IOPREL = 1 2656 WORK(KWRK3) = DARW + VELO 2657 ELSE 2658 IOPREL = 0 2659 ENDIF 2660!sonia 2661 if (.false.) then 2662 CALL CC_2EEXP(WORK(KWRK3),LWRK3,IOPREL) 2663 else 2664 CALL CC_2EEXP_2(WORK(KWRK3),LWRK3,IOPREL) 2665 end if 2666! 2667 ENDIF 2668C 2669C------------------------------------------------------------ 2670C Calculate the orbit-orbit two electron Hamiltonian 2671C expectation value 2672C------------------------------------------------------------ 2673C 2674 IF (BP2EOO) THEN 2675 CALL AROUND(' Breit-Pauli 2e- Orbit-Orbit corrections') 2676 DAR2SA = DAR2EL 2677 IF (DAR2EL) DAR2EL = .FALSE. 2678 !BP2SAV = BP2EOO 2679 !IF (BP2EOO) BP2EOO = .FALSE. 2680 IOPREL = 3 2681c if (CCR12) then 2682c call quit('CCFOP: CCR12 works only with general operator '// 2683c & 'input at the moment') 2684c end if 2685 if (.false.) then 2686 CALL CC_2EEXP(WORK(KWRK3),LWRK3,IOPREL) 2687 else 2688 !write(lupri,*)'CC_FOP: CALLING 2EEXP2, IOPREL =', IOPREL 2689 CALL CC_2EEXP_2(WORK(KWRK3),LWRK3,IOPREL) 2690 end if 2691 DAR2EL = DAR2SA 2692 !BP2EOO = BP2SAV 2693C 2694 WRITE(LUPRI,*) ' ' 2695 WRITE(LUPRI,136) 'BP2EOO:', WORK(KWRK3) 2696 WRITE(LUPRI,138) '-------' 2697 WRITE(LUPRI,*) ' ' 2698 2699 END IF 2700C 2701C-------------------------------------------------------------- 2702C Section for general operator APROP represented by LABEL1. 2703C Note that only the electronic contribution is calculated. 2704C-------------------------------------------------------------- 2705C 2706 DO 140 IOP = 1, NAFOP 2707C 2708 LABEL1 = PRPLBL_CC(IAFOP(IOP)) 2709C 2710 IF (IOP .EQ. 1) CALL AROUND( 2711 * ' Electronic contribution to operator ') 2712C 2713C-------------------------- 2714C get the integrals. 2715C-------------------------- 2716C 2717 KONEP = KWRK3 2718 KWRK4 = KONEP + N2BST(ISYMOP) 2719 LWRK4 = LWORK - KWRK4 2720C 2721 IF (LWRK4 .LT. 0) THEN 2722 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KWRK4 2723 CALL QUIT('Insufficient memory for property integrals '// 2724 & 'in CC_FOP') 2725 ENDIF 2726C 2727 CALL DZERO(WORK(KONEP),N2BST(ISYMOP)) 2728 FF = 1.0D0 2729 ISY = -1 2730 CALL CC_ONEP(WORK(KONEP),WORK(KWRK4),LWRK4,FF,ISY,LABEL1) 2731C 2732 IF (IPRINT .GT. 50) THEN 2733 CALL AROUND('APROP integrals in cc_fop') 2734 CALL CC_PRFCKAO(WORK(KONEP),ISYMOP) 2735 ENDIF 2736C 2737C-------------------------------------------------------------------- 2738C Calculate the electronic contribution to the given property. 2739C-------------------------------------------------------------------- 2740C 2741 IF (ISY.EQ.1) THEN 2742 PROP = DDOT(N2BST(ISYMOP),WORK(KONEP),1,WORK(KDENS),1) 2743 IF (CCPT .AND. (.NOT. RELORB)) THEN 2744 PROP2 = DDOT(N2BST(ISYMOP),WORK(KONEP),1,WORK(KDENS2),1) 2745 PROP2 = PROP2 + DDOT(N2BST(ISYMOP),WORK(KONEP),1, 2746 * WORK(KDENS3),1) 2747 ELSE IF (CCR12 .AND. (.NOT. RELORB)) THEN 2748 IF (IANR12.EQ.1) THEN 2749 CALL CC_R12PROP(PROPR12,LABEL1,APROXR12,WORK(KWRK4), 2750 & LWRK4) 2751 PROP = PROP + PROPR12 2752 ELSE 2753 WRITE(LUPRI,*) 'IANR12 = ',IANR12 2754 CALL QUIT('Only Ansatz 1 implemented for higher '// 2755 & 'order property R12-calculations at the moment') 2756 END IF 2757 ELSE IF ((CCR12.AND..NOT.MP2) .AND. RELORB) THEN 2758 CALL QUIT('CC-R12 response can only handle unrelaxed '// 2759 & 'orbitals: use .NONREL in input!') 2760 ENDIF 2761 ELSE 2762 PROP = 0.0D0 2763 IF ((CCPT .OR. CCR12) .AND. (.NOT. RELORB)) THEN 2764 PROP2 = 0.0D0 2765 ENDIF 2766 ENDIF 2767C 2768 CALL WRIPRO(PROP,MODELFM,1,LABEL1,LABEL1,LABEL1,LABEL1, 2769 * DUMMY,DUMMY,DUMMY,ISY,0,0,0) 2770C 2771C------------------------- 2772C Write out result. 2773C------------------------- 2774C 2775 WRITE(LUPRI,*) ' ' 2776 IF (ISY.EQ.1) THEN 2777 IF (CCPT .AND. (.NOT. RELORB)) THEN 2778 CALL AROUND('Unrelaxed : ') 2779 WRITE(LUPRI,141) LABEL1//':', PROP 2780 CALL AROUND('Semirelaxed : ') 2781 PROP = PROP + PROP2 2782 ENDIF 2783 WRITE(LUPRI,141) LABEL1//':', PROP 2784 ELSE 2785 WRITE(LUPRI,142) LABEL1//':','zero by symmetry' 2786 ENDIF 2787 WRITE(LUPRI,*) ' ' 2788 WRITE(LUPRI,*) ' ' 2789C 2790 141 FORMAT(20X,A9,1X,F12.8) 2791CCN 141 FORMAT(20X,A9,1X,F24.20) 2792 142 FORMAT(20X,A9,1X,A) 2793C 2794 140 CONTINUE 2795C 2796C------------------------------------------------------- 2797C Calculate energy for modifies CCSD(T) or CC(3). 2798C------------------------------------------------------- 2799C 2800 IF ((CCPT .OR. CCP3).AND. MTRIP) THEN 2801C 2802 CALL AROUND( ' Modified triples corrections ') 2803 CCSDT = .TRUE. 2804C 2805 IF (CCPT) THEN 2806 CC1BSV = CC1B 2807 CC1B = .TRUE. 2808 CC1ASV = CC1A 2809 CC1A = .TRUE. 2810 ENDIF 2811C 2812C--------------------------- 2813C Dynamic allocation. 2814C--------------------------- 2815C 2816 KT1AM = 1 2817 KOMEG1 = KT1AM + NT1AM(ISYMOP) 2818 KOMEG2 = KOMEG1 + NT1AM(ISYMOP) 2819 IF (OMEGSQ) THEN 2820 KT2AM = KOMEG2 2821 * + MAX(NT2AMX,NT2AM(ISYMOP),NT2AO(ISYMOP),NT2AOS(ISYMOP)) 2822 ELSE 2823 KT2AM = KOMEG2 2824 * + MAX(NT2AMX,NT2AM(ISYMOP),NT2AO(ISYMOP),2*NT2ORT(ISYMOP)) 2825 ENDIF 2826 KSCR2 = KT2AM + NT2AMX 2827 KEND1 = KSCR2 + NT2AMX + NT1AMX 2828 LWRK1 = LWORK - KEND1 2829C 2830 IF ( LWRK1 .LT. 0 ) THEN 2831 CALL QUIT('Insufficient space in CC_FOP ') 2832 ENDIF 2833C 2834 IOPT = 3 2835 CALL CC_RDRSP('R0',0,1,IOPT,MODEL,WORK(KT1AM),WORK(KT2AM)) 2836C 2837 IF ( IPRINT .GT. 50 ) THEN 2838 CALL AROUND( 'In CC_FOP: (T1,T2) vector before ' ) 2839 CALL CC_PRP(WORK(KT1AM),WORK(KT2AM),1,1,1) 2840 ENDIF 2841C 2842 RSPIM = .FALSE. 2843 CALL CCRHSN(WORK(KOMEG1),WORK(KOMEG2),WORK(KT1AM), 2844 * WORK(KT2AM),WORK(KEND1),LWRK1,'XXX') 2845C 2846 RSPIM = .TRUE. 2847C 2848 IF (CCPT) THEN 2849 CC1B = CC1BSV 2850 CC1A = CC1ASV 2851 ENDIF 2852C 2853 KFOCKD = KEND1 2854 KEND1 = KFOCKD + NORBTS 2855 LWRK1 = LWORK - KEND1 2856C 2857C---------------------------------------- 2858C Read canonical orbital energies. 2859C---------------------------------------- 2860C 2861 CALL GPOPEN(LUSIFC,'SIRIFC','OLD',' ','UNFORMATTED',IDUMMY, 2862 & .FALSE.) 2863 REWIND LUSIFC 2864C 2865 CALL MOLLAB('SIR IPH ',LUSIFC,LUPRI) 2866 READ (LUSIFC) POTNUC,EMY,EACTIV,EMCSCF,ISTATE,ISPIN,NACTEL, 2867 * LSYM,MS2 2868C 2869 ESCF = EMCSCF 2870C 2871 CALL MOLLAB('TRCCINT ',LUSIFC,LUPRI) 2872 READ (LUSIFC) 2873 READ (LUSIFC) (WORK(KFOCKD+I-1), I=1,NORBTS) 2874C 2875 CALL GPCLOSE(LUSIFC,'KEEP') 2876C 2877C------------------------------------------------------------- 2878C Change symmetry-ordering of the Fock-matrix diagonal. 2879C------------------------------------------------------------- 2880C 2881 IF (FROIMP .OR. FROEXP) 2882 * CALL CCSD_DELFRO(WORK(KFOCKD),WORK(KEND1),LWRK1) 2883C 2884 CALL FOCK_REORDER(WORK(KFOCKD),WORK(KEND1),LWRK1) 2885C 2886 ETY1 = 'CCSD' 2887 IT1 = 1 2888 ITER = 0 2889 CALL CCSD_ECCSD(WORK(KT1AM),WORK(KT2AM),WORK(KFOCKD),DUMMY, 2890 * WORK(KEND1),LWRK1,EN2,POTNUC,ESCF, 2891 * ETY1,0.0D0,.FALSE.,IT1,ITER,"xxx") 2892C 2893 NTAMP = NT1AMX + NT2AMX 2894C 2895 KLAM = KT2AM 2896 KEND1 = KLAM + NTAMP 2897 LWRK1 = LWORK - KEND1 2898C 2899 IF (LWRK1 .LT. 0) THEN 2900 WRITE(LUPRI,*) 'Needed:', KEND1, 'Available:', LWORK 2901 CALL QUIT('Insufficient memory for allocation in cc_fop') 2902 ENDIF 2903C 2904 IOPT = 3 2905 CALL CC_RDRSP('L0',0,1,IOPT,MODEL,WORK(KLAM), 2906 * WORK(KLAM+NT1AMX)) 2907C 2908 KLAM2 = KLAM + NT1AMX 2909C 2910 IF ( IPRINT .GT. 50 ) THEN 2911 CALL AROUND( 'In CC_FOP: (L1,L2) vector ' ) 2912 CALL CC_PRP(WORK(KLAM),WORK(KLAM2),1,1,1) 2913 ENDIF 2914C 2915 CALL CCLR_DIASCL(WORK(KOMEG2),0.5D0,ISYMTR) 2916 ECCP1 = DDOT(NT1AMX,WORK(KLAM),1,WORK(KOMEG1),1) 2917 ECCP2 = DDOT(NT2AMX,WORK(KLAM2),1,WORK(KOMEG2),1) 2918C 2919 ETOT = EN2 + ECCP1 + ECCP2 2920 WRITE(LUPRI,'(//,21X,A)') 'Perturbative triples corrections' 2921 WRITE(LUPRI,'(21X,A,/)') '--------------------------------' 2922 WRITE(LURES,'(//,21X,A)') 'Perturbative triples corrections' 2923 WRITE(LURES,'(21X,A,/)') '--------------------------------' 2924 IF (CCPT) THEN 2925 WRITE(LUPRI,'(12X,A,F30.10)') 'Total energy MCCSD(T):',ETOT 2926 WRITE(LURES,'(12X,A,F30.10)') 'Total energy MCCSD(T):', 2927 * ETOT 2928 ELSE 2929 WRITE(LUPRI,'(12X,A,F30.10)') 'Total energy MCC(3):',ETOT 2930 WRITE(LURES,'(12X,A,F30.10)') 'Total energy MCC(3):',ETOT 2931 ENDIF 2932C 2933 WRITE(LUPRI,'(12X,A,F25.10)') 2934 * 'The E4 doubles and triples:', ECCP2 2935 WRITE(LUPRI,'(12X,A,F25.10)') 2936 * 'The E5 singles and triples:', ECCP1 2937 WRITE(LURES,'(12X,A,F25.10)') 2938 * 'The E4 doubles and triples:', ECCP2 2939 WRITE(LURES,'(12X,A,F25.10)') 2940 * 'The E5 singles and triples:', ECCP1 2941 ECCGRS = ETOT 2942 ENDIF 2943C 2944C------------------------------------ 2945C Restore RELORB for MP2. 2946C------------------------------------ 2947C 2948 IF ((.NOT.RLORBS).AND.MP2) RELORB = RLORBS 2949C 2950 9999 CONTINUE 2951 CALL QEXIT('CC_FOP') 2952 RETURN 2953 END 2954c*DECK CC_ETA 2955 SUBROUTINE CC_ETA(ETA,WORK,LWORK) 2956C 2957C----------------------------------------------------------------------------- 2958C 2959C Purpose: Calculate ETA vector. 2960C 2961C Use F-hat and (iajb) on scratch. 2962C 2963C Written by Ove Christiansen 22 November 1994 2964C Triples corrections by K. Hald, Fall 2001. 2965C 2966C----------------------------------------------------------------------------- 2967C 2968#include "implicit.h" 2969#include "priunit.h" 2970#include "dummy.h" 2971#include "maxorb.h" 2972#include "ccorb.h" 2973#include "iratdef.h" 2974#include "cclr.h" 2975#include "ccsdsym.h" 2976#include "ccsdio.h" 2977#include "ccsdinp.h" 2978#include "ccinftap.h" 2979#include "r12int.h" 2980! 2981!SONIA SONIA SONIA 2982! 2983#include "grdccpt.h" 2984C 2985 LOGICAL LOCDBG 2986 PARAMETER(LOCDBG = .FALSE.) 2987 PARAMETER(ONE=1.0d0, TWO = 2.0D00 ) 2988 CHARACTER*5 FN3FOP 2989 CHARACTER*6 FN3VI, FN3FOP2 2990 CHARACTER*8 FNTOC, FN3VI2 2991 CHARACTER*10 MODEL 2992 DIMENSION ETA(*),WORK(LWORK) 2993C 2994 LOGICAL FIRST 2995 SAVE FIRST 2996 DATA FIRST /.TRUE./ 2997! 2998!SONIA SONIA SONIA 2999! 3000 SAVE IGRDCCPT_OLD 3001 DATA IGRDCCPT_OLD/-1/ 3002C 3003 CALL QENTER('CC_ETA') 3004C 3005! 3006!SONIA SONIA SONIA 3007! 3008 IF (IGRDCCPT.NE.IGRDCCPT_OLD) THEN 3009 FIRST = .TRUE. 3010 IGRDCCPT_OLD = IGRDCCPT 3011 END IF 3012! 3013!SONIA SONIA SONIA 3014! 3015 3016 IF ( IPRINT .GT. 10 ) THEN 3017 IF (ETADSC .AND. FIRST) THEN 3018 CALL AROUND( 'CC_ETA: Constructing Eta vector '// 3019 * 'and write it to disc' ) 3020 ELSE IF (ETADSC) THEN 3021 CALL AROUND( 'CC_ETA: Reading Eta from disc ') 3022 ELSE 3023 CALL AROUND( 'CC_ETA: Constructing Eta vector ') 3024 ENDIF 3025 ENDIF 3026C 3027 IF ( CCS ) THEN 3028 CALL DZERO(ETA,NT1AM(ISYMOP)) 3029 CALL QEXIT('CC_ETA') 3030 RETURN 3031 ENDIF 3032C 3033C---------------------------------------------- 3034C If ETA is on disc, read and exit 3035C---------------------------------------------- 3036C 3037 IF (ETADSC .AND. (.NOT. FIRST)) THEN 3038C 3039 LUETA = -1 3040 CALL GPOPEN(LUETA,'PT_ETA','OLD',' ','UNFORMATTED', 3041 * IDUMMY,.FALSE.) 3042C 3043 REWIND(LUETA) 3044 READ(LUETA) (ETA(I), I=1,NT1AMX+NT2AMX) 3045 CALL GPCLOSE(LUETA,'KEEP') 3046C 3047 IF (IPRINT .GT. 40 ) THEN 3048 CALL AROUND( 'In CC_ETA: Eta vector read ' ) 3049 CALL CC_PRP(ETA(1),ETA(1+NT1AMX),1,1,1) 3050 ENDIF 3051C 3052 IF ( IPRINT .GT. 10 ) THEN 3053 ETA1 = DDOT(NT1AMX,ETA(1),1,ETA(1),1) 3054 ETA2 = DDOT(NT2AMX,ETA(1+NT1AMX),1,ETA(1+NT1AMX),1) 3055 WRITE(LUPRI,*) 'Norm of eta1 read: ',ETA1 3056 WRITE(LUPRI,*) 'Norm of eta2 read: ',ETA2 3057 CALL AROUND( 'END OF CC_ETA ') 3058 ENDIF 3059C 3060 CALL QEXIT('CC_ETA') 3061 RETURN 3062 ENDIF 3063C 3064C--------------------------------------------------- 3065C Make eta(ai,bj) from integrals (iajb) on disk. 3066C--------------------------------------------------- 3067C 3068 REWIND(LUIAJB) 3069 CALL READI(LUIAJB,IRAT*NT2AM(ISYMOP),ETA(1+NT1AMX)) 3070C 3071 IF (IPRINT .GT. 40 ) THEN 3072 CALL AROUND( 'In CC_ETA: Integrals (ia|jb) ' ) 3073 CALL CC_PRP(DUM,ETA(1+NT1AMX),1,0,1) 3074 ENDIF 3075C 3076C Thomas Bondo Pedersen: SOSEX eta must be as in rCCD. 3077C 3078 if (DRCCD .AND. .NOT.SOSEX) then 3079 CALL DSCAL(NT2AMX,TWO,ETA(1+NT1AMX),1) 3080 else 3081 IOPTTCME = 1 3082 CALL CCSD_TCMEPK(ETA(1+NT1AMX),1.0D0,ISYMOP,IOPTTCME) 3083 end if 3084C 3085 KFOCK = 1 3086 KT1AM = KFOCK + N2BST(ISYMOP) 3087 KLAMDP = KT1AM + NT1AM(ISYMOP) 3088 KLAMDH = KLAMDP + NLAMDT 3089 KEND1 = KLAMDH + NLAMDT 3090 LWRK1 = LWORK - KEND1 3091C 3092C---------------------------------------------------- 3093C Make eta(ai) from AO fock matrix store on disk. 3094C---------------------------------------------------- 3095C 3096 IF ( (RSPIM).and.(.not.(RCCD.or.DRCCD)) ) THEN 3097C 3098 LUFCK = -1 3099 CALL GPOPEN(LUFCK,'CC_FCKH','UNKNOWN',' ','UNFORMATTED',IDUMMY, 3100 * .FALSE.) 3101 REWIND(LUFCK ) 3102 READ (LUFCK )(WORK(KFOCK + I-1),I = 1,N2BST(ISYMOP)) 3103 CALL GPCLOSE(LUFCK,'KEEP') 3104C 3105 ENDIF 3106C 3107 IF (IPRINT .GT.140) THEN 3108 CALL AROUND( 'Usual Fock AO matrix' ) 3109 ISYFAO = 1 3110 CALL CC_PRFCKAO(WORK(KFOCK),ISYFAO) 3111 ENDIF 3112C 3113 CALL DZERO(WORK(KT1AM),NT1AM(1)) 3114 !SONIA: CCD/RCCD ADDED 3115 IF (.NOT.(CCS.OR.CCP2.or.CCD.or.RCCD.or.DRCCD)) THEN 3116 IOPT = 1 3117 CALL CC_RDRSP('R0',0,1,IOPT,MODEL,WORK(KT1AM),DUMMY) 3118 ENDIF 3119C 3120 CALL LAMMAT(WORK(KLAMDP),WORK(KLAMDH),WORK(KT1AM), 3121 * WORK(KEND1),LWRK1) 3122C 3123 ISYFAO = 1 3124 ISYMPA = 1 3125 ISYMHO = 1 3126C 3127 CALL CC_FCKMO(WORK(KFOCK),WORK(KLAMDP),WORK(KLAMDH), 3128 * WORK(KEND1),LWRK1,ISYFAO,ISYMPA,ISYMHO) 3129C 3130 IF (IPRINT .GT. 50) THEN 3131 CALL AROUND( 'In CC_ETA: Fock MO matrix' ) 3132 CALL CC_PRFCKMO(WORK(KFOCK),ISYMOP) 3133 ENDIF 3134C 3135 if ((CCD).or.(RCCD).or.(DRCCD)) then 3136 CALL DZERO(ETA,NT1AM(ISYMOP)) 3137 else 3138 DO 100 ISYMI = 1,NSYM 3139C 3140 ISYMA = MULD2H(ISYMI,ISYMOP) 3141C 3142 DO 110 I = 1,NRHF(ISYMI) 3143C 3144 DO 120 A = 1,NVIR(ISYMA) 3145C 3146 KOFF1 = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + A 3147 KOFF2 = IFCVIR(ISYMI,ISYMA) + NORB(ISYMI)*(A - 1) + I 3148C 3149 ETA(KOFF1) = WORK(KOFF2) 3150C 3151 120 CONTINUE 3152 110 CONTINUE 3153C 3154 100 CONTINUE 3155 end if !CCD, RCCD, DRCCD (SONIA, FRAN) 3156C 3157C------------------------------------------- 3158C Scale the non-triples contributions 3159C------------------------------------------- 3160C 3161 CALL DSCAL(NT1AMX+NT2AMX,TWO,ETA,1) 3162C 3163C---------------------------------------------- 3164C If ETADSC calculate triples cont. 3165C Fock matrix and T2 is read from disc. 3166C---------------------------------------------- 3167C 3168 IF (ETADSC) THEN 3169C 3170 KT2AM = KEND1 3171 KEND2 = KT2AM + NT2SQ(1) 3172 LWRK2 = LWORK- KEND2 3173C 3174 IOPT = 2 3175 CALL CC_RDRSP('R0',0,1,IOPT,MODEL,DUMMY,WORK(KEND2)) 3176 CALL CC_T2SQ(WORK(KEND2),WORK(KT2AM),1) 3177C 3178 LUFCK = -1 3179 ISYFAO = 1 3180 ISYMPA = 1 3181 ISYMHO = 1 3182C 3183 CALL GPOPEN(LUFCK,'CC_FCKH','UNKNOWN',' ','UNFORMATTED', 3184 * IDUMMY,.FALSE.) 3185 REWIND(LUFCK ) 3186 READ (LUFCK )(WORK(KFOCK + I-1),I = 1,N2BST(ISYFAO)) 3187 CALL GPCLOSE(LUFCK,'KEEP') 3188C 3189 IF (IPRINT .GT. 140) THEN 3190 CALL AROUND( 'Usual Fock AO matrix' ) 3191 CALL CC_PRFCKAO(WORK(KFOCK),ISYFAO) 3192 ENDIF 3193C 3194 CALL CC_FCKMO(WORK(KFOCK),WORK(KLAMDP),WORK(KLAMDH), 3195 * WORK(KEND2),LWRK2,ISYFAO,ISYMPA,ISYMHO) 3196C 3197 IF (IPRINT .GT. 50) THEN 3198 CALL AROUND( 'In CC_ETA: Triples Fock MO matrix' ) 3199 CALL CC_PRFCKMO(WORK(KFOCK),ISYMOP) 3200 ENDIF 3201C 3202C-------------------------- 3203C Open files : 3204C-------------------------- 3205C 3206 LUTOC = -1 3207 LU3VI = -1 3208 LU3VI2 = -1 3209 LU3FOP = -1 3210 LU3FOP2 = -1 3211C 3212 FNTOC = 'CCSDT_OC' 3213 FN3VI = 'CC3_VI' 3214 FN3VI2 = 'CC3_VI12' 3215 FN3FOP = 'PTFOP' 3216 FN3FOP2 = 'PTFOP2' 3217C 3218 CALL WOPEN2(LUTOC,FNTOC,64,0) 3219 CALL WOPEN2(LU3VI,FN3VI,64,0) 3220 CALL WOPEN2(LU3VI2,FN3VI2,64,0) 3221 CALL WOPEN2(LU3FOP,FN3FOP,64,0) 3222 CALL WOPEN2(LU3FOP2,FN3FOP2,64,0) 3223C 3224 CALL CCSDPT_ETA(ETA,ETA(1+NT1AMX),WORK(KT1AM),1, 3225 * WORK(KT2AM),1,MODEL, 3226 * WORK(KEND2),LWRK2, 3227 * LUTOC,FNTOC, 3228 * LU3VI,FN3VI,LU3VI2,FN3VI2, 3229 * LU3FOP,FN3FOP,LU3FOP2,FN3FOP2) 3230C 3231C------------------------------------------- 3232C Write the contribution to disc. 3233C------------------------------------------- 3234C 3235 LUETA = -1 3236 CALL GPOPEN(LUETA,'PT_ETA','UNKNOWN',' ','UNFORMATTED', 3237 * IDUMMY,.FALSE.) 3238C 3239 REWIND(LUETA) 3240 WRITE(LUETA) (ETA(I), I=1,NT1AMX+NT2AMX) 3241 CALL GPCLOSE(LUETA,'KEEP') 3242C 3243C-------------------------------- 3244C Close files and end 3245C-------------------------------- 3246C 3247 CALL WCLOSE2(LUTOC,FNTOC,'KEEP') 3248 CALL WCLOSE2(LU3VI,FN3VI,'KEEP') 3249 CALL WCLOSE2(LU3VI2,FN3VI2,'KEEP') 3250 CALL WCLOSE2(LU3FOP,FN3FOP,'KEEP') 3251 CALL WCLOSE2(LU3FOP2,FN3FOP2,'KEEP') 3252C 3253 FIRST = .FALSE. 3254C 3255 ENDIF 3256 3257C 3258C----------------------------------------- 3259C Calculate R12 contribution 3260C Christian Neiss Mar. 2005 3261C----------------------------------------- 3262C 3263 IF (CCR12) THEN 3264 KETAR12SQ = KEND1 3265 KEND2 = KETAR12SQ + NTR12SQ(1) 3266 LWRK2 = LWORK - KEND2 3267 3268 CALL DZERO(WORK(KETAR12SQ),NTR12SQ(1)) 3269 CALL CC_R12ETA0(WORK(KETAR12SQ),WORK(KLAMDP),1,WORK(KEND2), 3270 & LWRK2) 3271 3272 KOFF1 = NT1AMX + NT2AMX + 1 3273 IOPT = 1 3274 CALL CCR12PCK2(ETA(KOFF1),1,.FALSE.,WORK(KETAR12SQ),'T', 3275 & IOPT) 3276 CALL CCLR_DIASCLR12(ETA(KOFF1),0.5D0*KETSCL,1) 3277 3278 !TEST: Sum_{kilj} (2V(ij,kl)-V(ji,kl))*c(ij,kl) should be E^(R12) 3279 !WORKS ONLY WITH BRASCL=KETSCL=1.0 3280 IF (LOCDBG) THEN 3281 KTR12 = KEND2 3282 KEND2 = KTR12 + NTR12AM(1) 3283 IOPT = 32 3284 CALL CC_RDRSP('R0 ',0,1,IOPT,MODEL,DUMMY,WORK(KTR12)) 3285 WRITE(LUPRI,*) 'E(R12) in CC_ETA: ', 3286 & DDOT(NTR12AM(1),ETA(KOFF1),1,WORK(KTR12),1) 3287 END IF 3288 ENDIF 3289 3290C 3291C----------------------------------------- 3292C Print? and end 3293C----------------------------------------- 3294C 3295 IF (LOCDBG) THEN 3296 CALL AROUND( 'In CC_ETA: Eta vector ' ) 3297 CALL CC_PRP(ETA(1),ETA(1+NT1AMX),1,1,1) 3298 if (CCR12) then 3299 call cc_prpr12(eta(1+nt1amx+nt2amx),1,1,.true.) 3300 end if 3301 ENDIF 3302C 3303 IF (CCSTST) THEN 3304 CALL DZERO(ETA(1+NT1AMX),NT2AMX) 3305 END IF 3306 3307 IF ( IPRINT .GT. 10 ) THEN 3308 ETA1 = DDOT(NT1AMX,ETA(1),1,ETA(1),1) 3309 ETA2 = DDOT(NT2AMX,ETA(1+NT1AMX),1,ETA(1+NT1AMX),1) 3310 WRITE(LUPRI,*) 'Norm of eta1: ',ETA1 3311 WRITE(LUPRI,*) 'Norm of eta2: ',ETA2 3312 IF (CCR12) THEN 3313 ETAR12 = DDOT(NTR12AM(1),ETA(1+NT1AMX+NT2AMX),1, 3314 & ETA(1+NT1AMX+NT2AMX),1) 3315 WRITE(LUPRI,*) 'Norm of etaR12: ',ETAR12 3316 END IF 3317 CALL AROUND( 'END OF CC_ETA ') 3318 ENDIF 3319C 3320 CALL QEXIT('CC_ETA') 3321 RETURN 3322 END 3323C /* Deck cc_d1orre */ 3324 SUBROUTINE CC_D1ORRE(D1AO,ZKAM,WORK,LWORK) 3325C 3326C Written by Asger Halkier 4/4 - 1996 3327C 3328C Version: 1.0 3329C 3330C Purpose: To add the orbital relaxation term to the 3331C CC one electron density in AO basis! 3332C 3333#include "implicit.h" 3334#include "priunit.h" 3335#include "dummy.h" 3336 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0) 3337 DIMENSION D1AO(*), ZKAM(*), WORK(LWORK) 3338#include "inftap.h" 3339#include "ccorb.h" 3340#include "ccsdsym.h" 3341#include "cclr.h" 3342C 3343 CALL QENTER('CC_D1ORRE') 3344C 3345C------------------------------- 3346C Work space allocation one. 3347C------------------------------- 3348C 3349 LENGHT = MAX(NLAMDT,NLAMDS) 3350C 3351 KCTRAN = 1 3352 KEND1 = KCTRAN + LENGHT 3353 LWRK1 = LWORK - KEND1 3354C 3355 IF (LWRK1 .LT. 0) THEN 3356 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND1 3357 CALL QUIT('Insufficient memory for first allocation in '// 3358 & 'CC_D1ORRE') 3359 ENDIF 3360C 3361C---------------------------------------------------- 3362C Read MO-coefficient matrix from interface file. 3363C---------------------------------------------------- 3364C 3365 CALL GPOPEN(LUSIFC,'SIRIFC','OLD',' ','UNFORMATTED',IDUMMY, 3366 & .FALSE.) 3367 REWIND LUSIFC 3368C 3369 CALL MOLLAB('TRCCINT ',LUSIFC,LUPRI) 3370 READ (LUSIFC) 3371 READ (LUSIFC) 3372 READ (LUSIFC) (WORK(KCTRAN+I-1), I=1,NLAMDS) 3373 CALL GPCLOSE(LUSIFC,'KEEP') 3374C 3375C------------------------------------------------------------ 3376C Reorder MO-coefficient matrix to lampda matrix storage. 3377C------------------------------------------------------------ 3378C 3379 CALL CMO_REORDER(WORK(KCTRAN),WORK(KEND1),LWRK1) 3380C 3381 DO 100 ISYM = 1,NSYM 3382C 3383C---------------------------------- 3384C Work space allocation two. 3385C---------------------------------- 3386C 3387 KSCR = KEND1 3388 KEND2 = KSCR + NBAS(ISYM)*NRHF(ISYM) 3389 LWRK2 = LWORK - KEND2 3390C 3391 IF (LWRK2 .LT. 0) THEN 3392 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND2 3393 CALL QUIT('Insufficient work for second allocation in '// 3394 & 'CC_D1ORRE') 3395 ENDIF 3396C 3397 CALL DZERO(WORK(KSCR),NBAS(ISYM)*NRHF(ISYM)) 3398C 3399C------------------------------------ 3400C Calculate the contributions. 3401C------------------------------------ 3402C 3403 KOFF1 = KCTRAN + ILMVIR(ISYM) 3404 KOFF2 = IT1AM(ISYM,ISYM) + 1 3405C 3406 NTOTAL = MAX(NBAS(ISYM),1) 3407 NTOTA = MAX(NVIR(ISYM),1) 3408C 3409 CALL DGEMM('N','N',NBAS(ISYM),NRHF(ISYM),NVIR(ISYM),ONE, 3410 * WORK(KOFF1),NTOTAL,ZKAM(KOFF2),NTOTA,ZERO, 3411 * WORK(KSCR),NTOTAL) 3412C 3413 KOFF3 = KCTRAN + ILMRHF(ISYM) 3414 KOFF4 = IAODIS(ISYM,ISYM) + 1 3415C 3416 NTOTAL = MAX(NBAS(ISYM),1) 3417 NTOTBE = MAX(NBAS(ISYM),1) 3418C 3419 CALL DGEMM('N','T',NBAS(ISYM),NBAS(ISYM),NRHF(ISYM),TWO, 3420 * WORK(KSCR),NTOTAL,WORK(KOFF3),NTOTBE,ONE, 3421 * D1AO(KOFF4),NTOTAL) 3422C 3423 100 CONTINUE 3424C 3425 CALL QEXIT('CC_D1ORRE') 3426C 3427 RETURN 3428 END 3429C /* Deck ccdffop */ 3430 subroutine CCDFFOP 3431C 3432C Written by Asger Halkier 5/4 - 1996 3433C 3434C Version: 1.0 3435C 3436C Purpose: Set flags for response solver properly for integral 3437C direct calculations! 3438C 3439C 3440#include "implicit.h" 3441#include "mxcent.h" 3442#include "abainf.h" 3443#include "inftra.h" 3444C 3445C 3446#include "grdccpt.h" 3447 3448 CALL QENTER('CCDFFOP') 3449C 3450 DODRCT = .TRUE. 3451 USEDRC = .TRUE. 3452 3453CSONIA SONIA 3454CSONIA SONIA 3455CSONIA SONIA 3456 3457 LGRDCCPT = .TRUE. 3458C 3459 CALL QEXIT('CCDFFOP') 3460C 3461 RETURN 3462 END 3463C /* Deck ccnucqau */ 3464 subroutine CCNUCQUA(WORK,LWORK,IOPT,IASGER) 3465C 3466C Written by Asger Halkier 9/4 - 1996 3467C 3468C Version: 1.0 3469C 3470C Purpose: Calculate the nuclear contribution to the 3471C molecular quadrupole moment (based on the 3472C equivalent ABACUS-routines)! 3473C 3474C 3475#include "implicit.h" 3476#include "iratdef.h" 3477#include "priunit.h" 3478#include "mxcent.h" 3479 DIMENSION WORK(LWORK) 3480#include "cbiher.h" 3481#include "orgcom.h" 3482#include "nuclei.h" 3483! gnrinf.h : QM3 3484#include "gnrinf.h" 3485#include "qm3.h" 3486C 3487 CALL QENTER('CCNUCQUA') 3488C 3489 KGEOM = 1 3490 KMASS = KGEOM + 3*(NATOMS + NFLOAT) 3491 KNAT = KMASS + NATOMS + NFLOAT 3492 KNUMI = KNAT + (NATOMS + NFLOAT + 1)/IRAT 3493 KEND1 = KNUMI + (NATOMS + NFLOAT + 1)/IRAT 3494 LWRK1 = LWORK - KEND1 3495C 3496 IF (LWRK1 .LT. 0) THEN 3497 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND1 3498 CALL QUIT('Insufficient memory for allocation in CCNUCQUA') 3499 ENDIF 3500C 3501 CALL CMMASS(WORK(KGEOM),WORK(KMASS),WORK(KNAT),WORK(KNUMI),IASGER) 3502 CALL DZERO(CMXYZ,3) 3503C 3504 IF (IOPT .EQ. 1) THEN 3505 CALL NUCQDR(WORK(KGEOM),CMXYZ,LUPRI,IASGER) 3506 ELSE IF (IOPT .EQ. 2) THEN 3507 CALL NUCNQC(WORK(KGEOM),LUPRI,IASGER) 3508C 3509 IF ( QM3 .AND. .NOT.SKIPNC ) THEN 3510 CALL QM3QCC1(LUPRI,IASGER) 3511 IF ( .NOT.LOSPC ) CALL QM3QCC2(LUPRI,IASGER) 3512 END IF 3513 END IF 3514C 3515 CALL QEXIT('CCNUCQUA') 3516C 3517 RETURN 3518 END 3519C /* Deck ccelqau */ 3520 subroutine CCELQUA(XONEP,DENS,LENGTH,I,J,RESVEC) 3521C 3522C Written by Asger Halkier 9/4 - 1996 3523C 3524C Version: 1.0 3525C 3526C Purpose: Calculate the electronic contribution to the 3527C molecular quadrupole moment (based on the 3528C equivalent ABACUS-routines)! 3529C 3530C 3531#include "implicit.h" 3532#include "maxorb.h" 3533#include "mxcent.h" 3534#include "maxaqn.h" 3535 DIMENSION XONEP(*), DENS(*), RESVEC(3,3) 3536#include "symmet.h" 3537#include "quadru.h" 3538C 3539 CALL QENTER('CCELQUA') 3540C 3541 RESVEC(IPTAX(J,1),IPTAX(I,1)) = DDOT(LENGTH,XONEP,1,DENS,1) 3542 RESVEC(IPTAX(I,1),IPTAX(J,1)) = DDOT(LENGTH,XONEP,1,DENS,1) 3543C 3544 CALL QEXIT('CCELQUA') 3545C 3546 RETURN 3547 END 3548C /* Deck cc_quareo */ 3549 subroutine CC_QUAREO(QORI,QNEW) 3550C 3551C Written by Asger Halkier 19/3 - 1998 3552C 3553C Version: 1.0 3554C 3555C Purpose: Reorder quadrupole and second moment tensors to 3556C CC storing. 3557C 3558C 3559#include "implicit.h" 3560#include "maxorb.h" 3561#include "mxcent.h" 3562#include "maxaqn.h" 3563 PARAMETER (ZERO = 0.0D0) 3564 DIMENSION QORI(3,3), QNEW(3,3) 3565#include "symmet.h" 3566#include "quadru.h" 3567C 3568 CALL QENTER('CC_QUAREO') 3569C 3570 DO 100 I = 1,3 3571 DO 110 J = 1,3 3572 QNEW(I,J) = ZERO 3573 110 CONTINUE 3574 100 CONTINUE 3575C 3576 DO 120 I = 1,3 3577 DO 130 J = I,3 3578 QNEW(I,J) = QORI(IPTAX(J,1),IPTAX(I,1)) 3579 QNEW(J,I) = QORI(IPTAX(I,1),IPTAX(J,1)) 3580 130 CONTINUE 3581 120 CONTINUE 3582C 3583 CALL QEXIT('CC_QUAREO') 3584C 3585 RETURN 3586 END 3587C /* Deck ccelefg */ 3588 subroutine CCELEFG(DENS,LENGTH,WORK,LWORK,IASGER) 3589C 3590C Written by Asger Halkier 16/4 - 1996 3591C 3592C Version: 1.0 3593C 3594C Purpose: Calculate the electronic contribution to the 3595C electric field gradients (based on the 3596C equivalent ABACUS-routines)! 3597C 3598C 3599#include "implicit.h" 3600#include "iratdef.h" 3601#include "priunit.h" 3602#include "mxcent.h" 3603 DIMENSION DENS(*), WORK(LWORK) 3604#include "nuclei.h" 3605C 3606 CALL QENTER('CCELEFG') 3607C 3608 NCOMP = 9*NUCDEP 3609C 3610C--------------------------- 3611C Work space allocation. 3612C--------------------------- 3613C 3614 KDOTPR = 1 3615 KCAINT = KDOTPR + NCOMP 3616 KEND1 = KCAINT + LENGTH 3617 LWRK1 = LWORK - KEND1 3618C 3619 IF (LWRK1 .LT. 0) THEN 3620 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND1 3621 CALL QUIT('Insufficient memory for initial allocation '// 3622 & 'in CCELEFG') 3623 ENDIF 3624C 3625 CALL DZERO(WORK(KDOTPR),NCOMP) 3626C 3627C------------------------------------------------------------------ 3628C Calculate contraction of density and cartesian efg-integrals. 3629C------------------------------------------------------------------ 3630C 3631 ITYPE = 30 3632 CALL CCELEFG1(WORK(KDOTPR),DENS,WORK(KCAINT), 3633 * WORK(KEND1),LWRK1,NCOMP,LENGTH,IASGER) 3634C 3635C------------------------------------------- 3636C Calculate the contribution to the EFG. 3637C------------------------------------------- 3638C 3639 KSCR1 = KEND1 3640 KEND2 = KSCR1 + 9*NUCDEP 3641 LWRK2 = LWORK - KEND2 3642C 3643 IF (LWRK2 .LT. 0) THEN 3644 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND2 3645 CALL QUIT('Insufficient memory for final allocation '// 3646 & 'in CCELEFG') 3647 ENDIF 3648C 3649 CALL NQCEL(WORK(KSCR1),WORK(KDOTPR),NCOMP,IASGER) 3650C 3651 CALL QEXIT('CCELEFG') 3652C 3653 RETURN 3654 END 3655C /* Deck ccelefg1 */ 3656 subroutine CCELEFG1(DOTPRO,DENS,EFGINT,WORK,LWORK, 3657 * NCOMP,LENGTH,IASGER) 3658C 3659C Written by Asger Halkier 16/4 - 1996 3660C 3661C Version: 1.0 3662C 3663C Purpose: To read in appropriate cartesian electric field 3664C gradient integrals and contract these with the 3665C one electron density matrix (Based on the equivalent 3666C ABACUS routines)! 3667C 3668C Merge to Dalton1.0 Ove 16-4-1997 3669C 3670#include "implicit.h" 3671#include "priunit.h" 3672#include "maxaqn.h" 3673#include "maxmom.h" 3674#include "mxcent.h" 3675#include "qm3.h" 3676#include "maxorb.h" 3677 DIMENSION DENS(*), EFGINT(*), DOTPRO(NCOMP), WORK(LWORK) 3678 CHARACTER*8 LABEL 3679#include "nuclei.h" 3680#include "symmet.h" 3681#include "chrxyz.h" 3682#include "chrnos.h" 3683 3684C 3685 CALL QENTER('CCELEFG1') 3686C 3687C--------------------------- 3688C Set up loop structure. 3689C--------------------------- 3690C 3691 ITYP = 0 3692C 3693 DO 100 IATOM = 1,NUCIND 3694 IF ( (ISUBSY(IATOM) .EQ. 0) .AND. 3695 & (ISUBSI(IATOM) .LE. NSISY(0)) ) THEN 3696 DO 110 ICOOR1 = 1,3 3697 DO 120 ICOOR2 = ICOOR1,3 3698C 3699 ISYMIJ = IEOR(ISYMAX(ICOOR1,1),ISYMAX(ICOOR2,1)) 3700C 3701 IOFF = 0 3702 3703 DO 130 IREPC = 0, MAXREP 3704C 3705 IF (IAND(ISTBNU(IATOM),IEOR(IREPC,ISYMIJ)) 3706 * .EQ.0) THEN 3707C 3708C--------------------------------------------------------------------- 3709C Get the integrals and contract with integrals. 3710C--------------------------------------------------------------------- 3711C 3712 IOFF = IOFF + 1 3713 ITYP = ITYP + 1 3714C 3715 LABEL = CHRXYZ(ICOOR1)//CHRXYZ(ICOOR2)//'EFG'// 3716 * CHRNOS(IATOM/10)//CHRNOS(MOD(IATOM,10))// 3717 & CHRNOS(IOFF) 3718C 3719 CALL DZERO(EFGINT,LENGTH) 3720 FF = 1.0D0 3721 ISY = -1 3722 CALL CC_ONEP(EFGINT,WORK,LWORK,FF,ISY,LABEL) 3723C 3724 IF (IASGER .GT. 45) THEN 3725 CALL AROUND('Cartesian EFG-int. in cc_fop') 3726 CALL CC_PRFCKAO(EFGINT,ISY) 3727 ENDIF 3728C 3729 IF (ISY .EQ. 1) THEN 3730 DOTPRO(ITYP) = DDOT(LENGTH,DENS,1,EFGINT,1) 3731 ELSE 3732 DOTPRO(ITYP) = 0.0D0 3733 ENDIF 3734C 3735 ENDIF 3736 130 CONTINUE 3737 120 CONTINUE 3738 110 CONTINUE 3739 END IF 3740 100 CONTINUE 3741C 3742 CALL QEXIT('CCELEFG1') 3743C 3744 RETURN 3745 END 3746C /* Deck ccs_d1ao */ 3747 SUBROUTINE CCS_D1AO(AODEN,WORK,LWORK) 3748C 3749C Written by Asger Halkier 17/4 - 1996 3750C 3751C Version: 1.0 3752C 3753C Purpose: To set up the one electron AO-density in case 3754C of a CCS calculation (equal to HF density)! 3755C 3756#include "implicit.h" 3757 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0) 3758 DIMENSION AODEN(*), WORK(LWORK) 3759#include "priunit.h" 3760#include "ccorb.h" 3761#include "ccsdsym.h" 3762#include "cclr.h" 3763C 3764 CALL QENTER('CCS_D1AO') 3765C 3766C--------------------------- 3767C Work space allocation. 3768C--------------------------- 3769C 3770 KONEAI = 1 3771 KONEAB = KONEAI + NT1AMX 3772 KONEIJ = KONEAB + NMATAB(1) 3773 KONEIA = KONEIJ + NMATIJ(1) 3774 KT1AM = KONEIA + NT1AMX 3775 KLAMDH = KT1AM + NT1AMX 3776 KLAMDP = KLAMDH + NLAMDT 3777 KEND1 = KLAMDP + NLAMDT 3778 LWRK1 = LWORK - KEND1 3779C 3780 IF (LWRK1 .LT. 0) THEN 3781 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND1 3782 CALL QUIT('Insufficient memory for work allocation '// 3783 & 'in CCS_D1AO') 3784 ENDIF 3785C 3786C-------------------------------------------------------------- 3787C Initialize arrays (note that the t1-amplitudes are zero). 3788C-------------------------------------------------------------- 3789C 3790 CALL DZERO(WORK(KONEAI),NT1AMX) 3791 CALL DZERO(WORK(KONEAB),NMATAB(1)) 3792 CALL DZERO(WORK(KONEIJ),NMATIJ(1)) 3793 CALL DZERO(WORK(KONEIA),NT1AMX) 3794 CALL DZERO(WORK(KT1AM),NT1AMX) 3795C 3796C----------------------- 3797C Set up MO-density. 3798C----------------------- 3799C 3800 DO 100 ISYM = 1,NSYM 3801 DO 110 I = 1,NRHF(ISYM) 3802C 3803 NII = IMATIJ(ISYM,ISYM) + NRHF(ISYM)*(I - 1) + I 3804C 3805 WORK(KONEIJ + NII - 1) = TWO 3806C 3807 110 CONTINUE 3808 100 CONTINUE 3809C 3810C------------------------------- 3811C Get MO coefficient matrix. 3812C------------------------------- 3813C 3814 CALL LAMMAT(WORK(KLAMDP),WORK(KLAMDH),WORK(KT1AM),WORK(KEND1), 3815 * LWRK1) 3816C 3817C----------------------------------- 3818C Transform density to AO basis. 3819C----------------------------------- 3820C 3821 CALL DZERO(AODEN,N2BST(1)) 3822C 3823 ISDEN = 1 3824 CALL CC_DENAO(AODEN,ISDEN,WORK(KONEAI),WORK(KONEAB), 3825 * WORK(KONEIJ),WORK(KONEIA),ISDEN,WORK(KLAMDP),1, 3826 * WORK(KLAMDH),1,WORK(KEND1),LWRK1) 3827C 3828 CALL QEXIT('CCS_D1AO') 3829C 3830 RETURN 3831 END 3832C /* Deck mp_lam */ 3833 SUBROUTINE MP_LAM(TBAM,WORK,LWORK) 3834C 3835C Written by Asger Halkier 6/9 - 1996 3836C 3837C Version: 1.0 3838C 3839C Purpose: To set up the zero'th order Lagrangian multipliers 3840C in the MP2 case. 3841C 3842#include "implicit.h" 3843#include "priunit.h" 3844#include "dummy.h" 3845 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0) 3846 DIMENSION TBAM(*), WORK(LWORK) 3847#include "maxorb.h" 3848#include "ccorb.h" 3849#include "iratdef.h" 3850#include "inftap.h" 3851#include "cclr.h" 3852#include "ccsdsym.h" 3853#include "ccinftap.h" 3854#include "ccsdio.h" 3855#include "ccsdinp.h" 3856C 3857 CALL QENTER('MP_LAM') 3858C 3859C----------------------------------------------------------------- 3860C Read integrals (ia|jb) from disc (file always assumed open). 3861C----------------------------------------------------------------- 3862C 3863 REWIND(LUIAJB) 3864 READ(LUIAJB) (TBAM(NT1AMX + I), I = 1,NT2AM(ISYMOP)) 3865C 3866C----------------------------------------------- 3867C Take two coulomb minus exchange on vector. 3868C----------------------------------------------- 3869C 3870 IOPTTCME = 1 3871 CALL CCSD_TCMEPK(TBAM(1+NT1AMX),1.0D0,ISYMOP,IOPTTCME) 3872C 3873C--------------------------- 3874C Work space allocation. 3875C--------------------------- 3876C 3877 KFOCKD = 1 3878 KEND1 = KFOCKD + NORBTS 3879 LWRK1 = LWORK - KEND1 3880C 3881 IF (LWRK1 .LT. 0) THEN 3882 WRITE(LUPRI,*) 'Need:', KEND1, 'Available:', LWORK 3883 CALL QUIT('Insufficient memory for allocation in MP_LAM') 3884 ENDIF 3885C 3886C------------------------------------- 3887C Read canonical orbital energies. 3888C------------------------------------- 3889C 3890 CALL GPOPEN(LUSIFC,'SIRIFC','OLD',' ','UNFORMATTED',IDUMMY, 3891 & .FALSE.) 3892 REWIND (LUSIFC) 3893C 3894 CALL MOLLAB('TRCCINT ',LUSIFC,LUPRI) 3895 READ (LUSIFC) 3896 READ (LUSIFC) (WORK(KFOCKD + I - 1), I = 1,NORBTS) 3897C 3898 CALL GPCLOSE(LUSIFC,'KEEP') 3899C 3900C---------------------------------------------------------------- 3901C Change symmetry ordering of the canonical orbital energies. 3902C---------------------------------------------------------------- 3903C 3904 IF (FROIMP .OR. FROEXP) 3905 * CALL CCSD_DELFRO(WORK(KFOCKD),WORK(KEND1),LWRK1) 3906C 3907 CALL FOCK_REORDER(WORK(KFOCKD),WORK(KEND1),LWRK1) 3908C 3909C------------------------------------- 3910C Divide with orbital differences. 3911C------------------------------------- 3912C 3913 CALL CCSD_GUESS(TBAM(1),TBAM(1+NT1AMX),WORK(KFOCKD),IPRINT) 3914C 3915C----------------------------------------- 3916C Final scalings for obtaining result. 3917C----------------------------------------- 3918C 3919 CALL DSCAL(NT2AM(ISYMOP),TWO,TBAM(1+NT1AMX),1) 3920C 3921 CALL QEXIT('MP_LAM') 3922C 3923 RETURN 3924 END 3925C /* Deck mp2_kari */ 3926 SUBROUTINE MP2_KARI(ETAAI,WORK,LWORK) 3927C 3928C Written by Asger Halkier 7/9 - 1996 3929C 3930C Version: 1.0 3931C 3932C Purpose: To calculate the right hand side ETAAI for the 3933C equations for the zero'th order orbital rotation 3934C multipliers in CCPT2 calculations. 3935C 3936#include "implicit.h" 3937#include "priunit.h" 3938#include "dummy.h" 3939#include "maxash.h" 3940#include "maxorb.h" 3941#include "mxcent.h" 3942#include "aovec.h" 3943#include "iratdef.h" 3944 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0) 3945 DIMENSION INDEXA(MXCORB_CC) 3946 DIMENSION ETAAI(*), WORK(LWORK) 3947 CHARACTER MODEL*(10) 3948#include "ccorb.h" 3949#include "ccisao.h" 3950#include "r12int.h" 3951#include "blocks.h" 3952#include "ccsdinp.h" 3953#include "ccinftap.h" 3954#include "ccsdsym.h" 3955#include "ccsdio.h" 3956#include "distcl.h" 3957#include "cbieri.h" 3958#include "eritap.h" 3959#include "cclr.h" 3960C 3961 CALL QENTER('MP2_KARI') 3962C 3963 CALL HEADER('Constructing right-hand-side for MP2-kappa-0(ai)',-1) 3964C 3965 TIMETO = ZERO 3966 TIMETO = SECOND() 3967C 3968C---------------------------------------------------------------------- 3969C Both and t-vectors and tbar-vectors (zeta) are totally symmetric. 3970C---------------------------------------------------------------------- 3971C 3972 ISYMTR = 1 3973 ISYMOP = 1 3974C 3975C------------------------------- 3976C Work space allocation one. 3977C------------------------------- 3978C 3979 KT2AM = 1 3980 KXMAT = KT2AM + NT2AMX 3981 KYMAT = KXMAT + NMATIJ(1) 3982 KXTMAT = KYMAT + NMATAB(1) 3983 KYTMAT = KXTMAT + NMATIJ(1) 3984 KDENSI = KYTMAT + NMATAB(1) 3985 KFOCK = KDENSI + N2BAST 3986 KLAMDP = KFOCK + N2BST(ISYMOP) 3987 KLAMDH = KLAMDP + NLAMDT 3988 KZ2AM = KLAMDH + NLAMDT 3989 KT1AM = KZ2AM + NT2SQ(1) 3990 KZ1AM = KT1AM + NT1AMX 3991 KEND1 = KZ1AM + NT1AMX 3992 LWRK1 = LWORK - KEND1 3993C 3994 IF (LWRK1 .LT. 0) THEN 3995 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND1 3996 CALL QUIT('Insufficient memory for initial allocation '// 3997 & 'in MP2_KARI') 3998 ENDIF 3999C 4000C---------------------------------------- 4001C Read zero'th order zeta amplitudes. 4002C---------------------------------------- 4003C 4004 IOPT = 3 4005 CALL CC_RDRSP('L0',0,1,IOPT,MODEL,WORK(KZ1AM),WORK(KZ2AM)) 4006C 4007 KEND1 = KZ1AM 4008 LWRK1 = LWORK - KEND1 4009C 4010C-------------------------------- 4011C Square up zeta2 amplitudes. 4012C-------------------------------- 4013C 4014 CALL DCOPY(NT2AMX,WORK(KZ2AM),1,WORK(KT2AM),1) 4015 CALL CC_T2SQ(WORK(KT2AM),WORK(KZ2AM),1) 4016C 4017C 4018C------------------------------------------- 4019C Read zero'th order cluster amplitudes. 4020C------------------------------------------- 4021C 4022 IOPT = 3 4023 CALL CC_RDRSP('R0',0,1,IOPT,MODEL,WORK(KT1AM),WORK(KT2AM)) 4024C 4025C---------------------------------- 4026C Calculate the lambda matrices. 4027C---------------------------------- 4028C 4029 CALL LAMMAT(WORK(KLAMDP),WORK(KLAMDH),WORK(KT1AM),WORK(KEND1), 4030 * LWRK1) 4031C 4032 KEND1 = KT1AM 4033 LWRK1 = LWORK - KEND1 4034C 4035C 4036C-------------------------------------------------------- 4037C Calculate X-intermediate of tbar- and t-amplitudes. 4038C-------------------------------------------------------- 4039C 4040 CALL CC_XI(WORK(KXMAT),WORK(KZ2AM),ISYMTR,WORK(KT2AM),ISYMOP, 4041 * WORK(KEND1),LWRK1) 4042C 4043C-------------------------------------------------------- 4044C Calculate Y-intermediate of tbar- and t-amplitudes. 4045C-------------------------------------------------------- 4046C 4047 CALL CC_YI(WORK(KYMAT),WORK(KZ2AM),ISYMTR,WORK(KT2AM),ISYMOP, 4048 * WORK(KEND1),LWRK1) 4049C 4050C--------------------------------------- 4051C Set up 2C-E of cluster amplitudes. 4052C--------------------------------------- 4053C 4054 ISYOPE = 1 4055 IOPTTCME = 1 4056 CALL CCSD_TCMEPK(WORK(KT2AM),1.0D0,ISYOPE,IOPTTCME) 4057C 4058C-------------------------------------------------------------------- 4059C Set up special modified amplitudes needed in the integral loop. 4060C (By doing it this way, we only need one packed vector in core 4061C along with the integral distribution in the delta loop.) 4062C-------------------------------------------------------------------- 4063C 4064 IOPT = 3 4065 CALL CC_RDRSP('L0',0,1,IOPT,MODEL,WORK(KZ1AM),WORK(KZ2AM)) 4066C 4067 CALL DSCAL(NT2AMX,TWO,WORK(KT2AM),1) 4068 CALL DAXPY(NT2AMX,ONE,WORK(KZ2AM),1,WORK(KT2AM),1) 4069C 4070C---------------------------------- 4071C Calculate the density matrix. 4072C---------------------------------- 4073C 4074 ISYMH = 1 4075 IC = 1 4076 CALL CC_AODENS(WORK(KLAMDP),WORK(KLAMDH),WORK(KDENSI),ISYMH, 4077 * IC,WORK(KEND1),LWRK1) 4078C 4079 KEND1 = KLAMDH 4080 LWRK1 = LWORK - KEND1 4081C 4082C------------------------------------------------ 4083C Read one-electron integrals in Fock-matrix. 4084C------------------------------------------------ 4085C 4086 CALL CCRHS_ONEAO(WORK(KFOCK),WORK(KEND1),LWRK1) 4087C 4088C------------------------------------------------------- 4089C Calculate special modified X- and Y-intermediates. 4090C------------------------------------------------------- 4091C 4092 CALL DCOPY(NMATAB(1),WORK(KYMAT),1,WORK(KYTMAT),1) 4093 CALL DCOPY(NMATIJ(1),WORK(KXMAT),1,WORK(KXTMAT),1) 4094 CALL CC_EITR(WORK(KYTMAT),WORK(KXTMAT),WORK(KEND1),LWRK1,1) 4095 CALL DAXPY(NMATAB(1),ONE,WORK(KYMAT),1,WORK(KYTMAT),1) 4096 CALL DAXPY(NMATIJ(1),ONE,WORK(KXMAT),1,WORK(KXTMAT),1) 4097C 4098C----------------------------------- 4099C Start the loop over integrals. 4100C----------------------------------- 4101C 4102 KENDS2 = KEND1 4103 LWRKS2 = LWRK1 4104C 4105 IF (DIRECT) THEN 4106 IF (HERDIR) THEN 4107 CALL HERDI1(WORK(KEND1),LWRK1,IPRERI) 4108 ELSE 4109 KCCFB1 = KEND1 4110 KINDXB = KCCFB1 + MXPRIM*MXCONT 4111 KEND1 = KINDXB + (8*MXSHEL*MXCONT + 1)/IRAT 4112 LWRK1 = LWORK - KEND1 4113 CALL ERIDI1(KODCL1,KODCL2,KODBC1,KODBC2,KRDBC1,KRDBC2, 4114 * KODPP1,KODPP2,KRDPP1,KRDPP2, 4115 * KFREE,LFREE,KEND1,WORK(KCCFB1),WORK(KINDXB), 4116 * WORK(KEND1),LWRK1,IPRERI) 4117 KEND1 = KFREE 4118 LWRK1 = LFREE 4119 END IF 4120 NTOSYM = 1 4121 ELSE 4122 NTOSYM = NSYM 4123 ENDIF 4124C 4125 KENDSV = KEND1 4126 LWRKSV = LWRK1 4127C 4128 ICDEL1 = 0 4129 DO 100 ISYMD1 = 1,NTOSYM 4130C 4131 IF (DIRECT) THEN 4132 IF (HERDIR) THEN 4133 NTOT = MAXSHL 4134 ELSE 4135 NTOT = MXCALL 4136 END IF 4137 ELSE 4138 NTOT = NBAS(ISYMD1) 4139 ENDIF 4140C 4141 DO 110 ILLL = 1,NTOT 4142C 4143C--------------------------------------------- 4144C If direct calculate the integrals. 4145C--------------------------------------------- 4146C 4147 IF (DIRECT) THEN 4148C 4149 KEND1 = KENDSV 4150 LWRK1 = LWRKSV 4151C 4152c DTIME = SECOND() 4153 IF (HERDIR) THEN 4154 CALL HERDI2(WORK(KEND1),LWRK1,INDEXA,ILLL,NUMDIS, 4155 & IPRERI) 4156 ELSE 4157 CALL ERIDI2(ILLL,INDEXA,NUMDIS,0,0, 4158 * WORK(KODCL1),WORK(KODCL2), 4159 * WORK(KODBC1),WORK(KODBC2), 4160 * WORK(KRDBC1),WORK(KRDBC2), 4161 * WORK(KODPP1),WORK(KODPP2), 4162 * WORK(KRDPP1),WORK(KRDPP2), 4163 * WORK(KCCFB1),WORK(KINDXB), 4164 * WORK(KEND1), LWRK1,IPRERI) 4165 END IF 4166c DTIME = SECOND() - DTIME 4167c TIMHE2 = TIMHE2 + DTIME 4168C 4169 KRECNR = KEND1 4170 KEND1 = KRECNR + (NBUFX(0) - 1)/IRAT + 1 4171 LWRK1 = LWORK - KEND1 4172 IF (LWRK1 .LT. 0) THEN 4173 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND1 4174 CALL QUIT('Insufficient memory for integrals '// 4175 & 'in MP2_KARI') 4176 END IF 4177C 4178 ELSE 4179 NUMDIS = 1 4180 ENDIF 4181C 4182C----------------------------------------------------- 4183C Loop over number of distributions in disk. 4184C----------------------------------------------------- 4185C 4186 DO 120 IDEL2 = 1,NUMDIS 4187C 4188 IF (DIRECT) THEN 4189 IDEL = INDEXA(IDEL2) 4190CCN ISYMD = ISAO(IDEL) 4191 IF (NOAUXB) THEN 4192 IDUM = 1 4193 CALL IJKAUX(IDEL,IDUM,IDUM,IDUM) 4194 END IF 4195 ISYMD = ISAO(IDEL) 4196 ELSE 4197 IDEL = IBAS(ISYMD1) + ILLL 4198 ISYMD = ISYMD1 4199 ENDIF 4200C 4201C---------------------------------------- 4202C Work space allocation two. 4203C---------------------------------------- 4204C 4205 ISYDIS = MULD2H(ISYMD,ISYMOP) 4206C 4207 KXINT = KEND1 4208 KEND2 = KXINT + NDISAO(ISYDIS) 4209 LWRK2 = LWORK - KEND2 4210C 4211 IF (LWRK2 .LT. 0) THEN 4212 WRITE(LUPRI,*) 'Need : ',KEND2,'Available : ',LWORK 4213 CALL QUIT('Insufficient memory for integrals '// 4214 & 'in MP2_KARI') 4215 ENDIF 4216C 4217C-------------------------------------------- 4218C Read AO integral distribution. 4219C-------------------------------------------- 4220C 4221 CALL CCRDAO(WORK(KXINT),IDEL,IDEL2,WORK(KEND2),LWRK2, 4222 * WORK(KRECNR),DIRECT) 4223C 4224C------------------------------------------- 4225C Calculate the AO-Fock matrix. 4226C------------------------------------------- 4227C 4228 ISYDEN = 1 4229 CALL CC_AOFOCK(WORK(KXINT),WORK(KDENSI),WORK(KFOCK), 4230 * WORK(KEND2),LWRK2,IDEL,ISYMD,.FALSE., 4231 * DUMMY,ISYDEN) 4232C 4233C------------------------------------------ 4234C Work space allocation three. 4235C------------------------------------------ 4236C 4237 KDSRHF = KEND2 4238 K3OINT = KDSRHF + NDSRHF(ISYMD) 4239 KSCRTI = K3OINT + NMAIJK(ISYDIS) 4240 KEND3 = KSCRTI + NT2BCD(ISYDIS) 4241 LWRK3 = LWORK - KEND3 4242C 4243 IF (LWRK3 .LT. 0) THEN 4244 WRITE(LUPRI,*) 'Need : ',KEND3,'Available : ',LWORK 4245 CALL QUIT('Insufficient memory for integrals '// 4246 & 'in MP2_KARI') 4247 ENDIF 4248C 4249C--------------------------------------------------------------------- 4250C Calculate partially backtransformed modified amplitude. 4251C--------------------------------------------------------------------- 4252C 4253 CALL CC_TI(WORK(KSCRTI),ISYMD,WORK(KT2AM),ISYMOP, 4254 * WORK(KLAMDP),1,WORK(KEND3),LWRK3,IDEL,ISYMD) 4255C 4256C-------------------------------------------------------- 4257C Transform one index in the integral batch. 4258C-------------------------------------------------------- 4259C 4260 CALL CCTRBT(WORK(KXINT),WORK(KDSRHF),WORK(KLAMDP),ISYMOP, 4261 * WORK(KEND3),LWRK3,ISYDIS) 4262C 4263C------------------------------------------------------------------ 4264C Calculate contributions involving integrals (vv|ov). 4265C------------------------------------------------------------------ 4266C 4267 CALL CCPT_3VT(ETAAI,WORK(KSCRTI),WORK(KDSRHF), 4268 * WORK(KLAMDP),WORK(KEND3),LWRK3,ISYDIS) 4269C 4270 CALL CCPT_YTV(ETAAI,WORK(KYTMAT),WORK(KDSRHF), 4271 * WORK(KLAMDP),WORK(KEND3),LWRK3,IDEL,ISYMD) 4272C 4273C------------------------------------------------------------------- 4274C Calculate integral batch with three occupied indices. 4275C------------------------------------------------------------------- 4276C 4277 CALL CC_INT3O(WORK(K3OINT),WORK(KDSRHF),WORK(KLAMDP), 4278 * ISYMOP,WORK(KLAMDP),WORK(KEND3),LWRK3, 4279 * IDEL,ISYMD,LUDUM,'DUMMY') 4280C 4281C------------------------------------------------------------------ 4282C Calculate contributions involving integrals (oo|ov). 4283C------------------------------------------------------------------ 4284C 4285 CALL CCPT_3OT(ETAAI,WORK(KSCRTI),WORK(K3OINT), 4286 * ISYDIS) 4287C 4288 CALL CCPT_NXY(ETAAI,WORK(KXMAT),WORK(KYMAT),WORK(K3OINT), 4289 * WORK(KDSRHF),WORK(KLAMDP),WORK(KEND3), 4290 * LWRK3,IDEL,ISYMD) 4291C 4292 CALL CCPT_XTO(ETAAI,WORK(KXTMAT),WORK(K3OINT), 4293 * WORK(KLAMDP),WORK(KEND3),LWRK3,IDEL,ISYMD) 4294C 4295 120 CONTINUE 4296 110 CONTINUE 4297 100 CONTINUE 4298C 4299C------------------------ 4300C Recover work space. 4301C------------------------ 4302C 4303 KEND1 = KENDS2 4304 LWRK1 = LWRKS2 4305C 4306C------------------------------------------ 4307C Transform AO Fock matrix to MO basis. 4308C------------------------------------------ 4309C 4310 IHELP = 1 4311 CALL CC_FCKMO(WORK(KFOCK),WORK(KLAMDP),WORK(KLAMDP), 4312 * WORK(KEND1),LWRK1,IHELP,IHELP,IHELP) 4313C 4314C------------------------------------------------------- 4315C Calculate contributions involving the Fock matrix. 4316C------------------------------------------------------- 4317C 4318 CALL CCPT_FCK(ETAAI,WORK(KFOCK),WORK(KXTMAT),WORK(KYTMAT), 4319 * WORK(KEND1),LWRK1) 4320C 4321C--------------------------------- 4322C Write out result and timing. 4323C--------------------------------- 4324C 4325 IF (IPRINT .GT. 20) THEN 4326C 4327 CALL AROUND('Eta-kappa-0 vector exiting MP2_KARI') 4328C 4329 DO 20 ISYM = 1,NSYM 4330C 4331 WRITE(LUPRI,*) ' ' 4332 WRITE(LUPRI,444) 'Sub-symmetry block number:', ISYM 4333 WRITE(LUPRI,555) '--------------------------' 4334 444 FORMAT(3X,A26,2X,I1) 4335 555 FORMAT(3X,A25) 4336C 4337 KOFF = IT1AM(ISYM,ISYM) + 1 4338 CALL OUTPUT(ETAAI(KOFF),1,NVIR(ISYM),1,NRHF(ISYM), 4339 * NVIR(ISYM),NRHF(ISYM),1,LUPRI) 4340C 4341 IF ((NVIR(ISYM) .EQ. 0) .OR. (NRHF(ISYM) .EQ. 0)) THEN 4342 WRITE(LUPRI,*) 'This sub-symmetry is empty' 4343 ENDIF 4344C 4345 20 CONTINUE 4346 ENDIF 4347C 4348 IF (IPRINT .GT. 9) THEN 4349 ETAKAN = DDOT(NT1AMX,ETAAI,1,ETAAI,1) 4350 WRITE(LUPRI,*) ' ' 4351 WRITE(LUPRI,*) 'Norm of Eta-kappa-0:', ETAKAN 4352 ENDIF 4353C 4354 TIMETO = SECOND() - TIMETO 4355C 4356 IF (IPRINT .GT. 3) THEN 4357 WRITE(LUPRI,*) ' ' 4358 WRITE(LUPRI,*) ' CCPT2 Eta-0(kappa) calculation completed' 4359 WRITE(LUPRI,*) 'Total time used in MP2_KARI:', TIMETO 4360 ENDIF 4361C 4362 CALL QEXIT('MP2_KARI') 4363C 4364 RETURN 4365 END 4366C /* Deck ccpt_fck */ 4367 SUBROUTINE CCPT_FCK(ETAAI,FCKMO,XTMAT,YTMAT,WORK,LWORK) 4368C 4369C Written by Asger Halkier 9/9 - 1996. 4370C 4371C Version: 1.0 4372C 4373C Purpose: To calculate the Fock matrix contributions to 4374C ETAAI(CCPT2). 4375C 4376#include "implicit.h" 4377 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0) 4378 DIMENSION ETAAI(*), FCKMO(*), XTMAT(*), YTMAT(*), WORK(LWORK) 4379#include "priunit.h" 4380#include "ccorb.h" 4381#include "ccsdsym.h" 4382#include "cclr.h" 4383C 4384 CALL QENTER('CCPT_FCK') 4385C 4386 IF (LWORK .LT. NT1AMX) THEN 4387 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', NT1AMX 4388 CALL QUIT('Insufficient memory for allocation in CCPT_FCK') 4389 ENDIF 4390C 4391C----------------------------------------------------------------- 4392C Copy out needed part of Fock matrix F(ka) and store as T1AM. 4393C----------------------------------------------------------------- 4394C 4395 DO 100 ISYMC = 1,NSYM 4396C 4397 ISYMK = MULD2H(ISYMC,ISYMOP) 4398C 4399 DO 110 K = 1,NRHF(ISYMK) 4400C 4401 DO 120 C = 1,NVIR(ISYMC) 4402C 4403 KOFF1 = IFCVIR(ISYMK,ISYMC) + NORB(ISYMK)*(C - 1) + K 4404 KOFF2 = IT1AM(ISYMC,ISYMK) + NVIR(ISYMC)*(K - 1) + C 4405C 4406 WORK(KOFF2) = FCKMO(KOFF1) 4407C 4408 120 CONTINUE 4409 110 CONTINUE 4410 100 CONTINUE 4411C 4412 DO 130 ISYMA = 1,NSYM 4413C 4414 ISYMI = MULD2H(ISYMA,ISYMOP) 4415 ISYMK = MULD2H(ISYMA,ISYMOP) 4416 ISYMC = ISYMK 4417C 4418C------------------------------------- 4419C Calculate XTMAT contribution. 4420C------------------------------------- 4421C 4422 KOFF1 = IT1AM(ISYMA,ISYMK) + 1 4423 KOFF2 = IMATIJ(ISYMK,ISYMI) + 1 4424 KOFF3 = IT1AM(ISYMA,ISYMI) + 1 4425C 4426 NTOTA = MAX(NVIR(ISYMA),1) 4427 NTOTK = MAX(NRHF(ISYMK),1) 4428C 4429 CALL DGEMM('N','N',NVIR(ISYMA),NRHF(ISYMI),NRHF(ISYMK),-ONE, 4430 * WORK(KOFF1),NTOTA,XTMAT(KOFF2),NTOTK,ONE, 4431 * ETAAI(KOFF3),NTOTA) 4432C 4433C------------------------------------- 4434C Calculate YTMAT contribution. 4435C------------------------------------- 4436C 4437 KOFF4 = IMATAB(ISYMA,ISYMC) + 1 4438 KOFF5 = IT1AM(ISYMC,ISYMI) + 1 4439 KOFF6 = IT1AM(ISYMA,ISYMI) + 1 4440C 4441 NTOTA = MAX(NVIR(ISYMA),1) 4442 NTOTC = MAX(NVIR(ISYMC),1) 4443C 4444 CALL DGEMM('N','N',NVIR(ISYMA),NRHF(ISYMI),NVIR(ISYMC),-ONE, 4445 * YTMAT(KOFF4),NTOTA,WORK(KOFF5),NTOTC,ONE, 4446 * ETAAI(KOFF6),NTOTA) 4447C 4448 130 CONTINUE 4449C 4450 CALL QEXIT('CCPT_FCK') 4451C 4452 RETURN 4453 END 4454C /* Deck ccpt_3ot */ 4455 SUBROUTINE CCPT_3OT(ETAAI,TSCR,X3OINT,ISYDIS) 4456C 4457C Written by Asger Halkier 10/9 - 1996. 4458C 4459C Version: 1.0 4460C 4461C Purpose: To calculate the contributions to ETAAI(CCPT2) 4462C originating from amplitudes directly contracted 4463C with integrals (oo|ov). 4464C 4465#include "implicit.h" 4466 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0) 4467 DIMENSION ETAAI(*), TSCR(*), X3OINT(*) 4468#include "priunit.h" 4469#include "ccorb.h" 4470#include "ccsdsym.h" 4471#include "cclr.h" 4472C 4473 CALL QENTER('CCPT_3OT') 4474C 4475 ISYALK = ISYDIS 4476 ISYLIK = ISYDIS 4477C 4478 DO 100 ISYMK = 1,NSYM 4479C 4480 ISYMAL = MULD2H(ISYMK,ISYALK) 4481 ISYMLI = MULD2H(ISYMK,ISYLIK) 4482C 4483 DO 110 K = 1,NRHF(ISYMK) 4484C 4485 DO 120 ISYMA = 1,NSYM 4486C 4487 ISYMI = ISYMA 4488 ISYML = MULD2H(ISYMA,ISYMAL) 4489C 4490C----------------------------------------- 4491C Calculate the contribution. 4492C----------------------------------------- 4493C 4494 KOFF1 = IT2BCD(ISYMAL,ISYMK) + NT1AM(ISYMAL)*(K - 1) 4495 * + IT1AM(ISYMA,ISYML) + 1 4496 KOFF2 = IMAIJK(ISYMLI,ISYMK) + NMATIJ(ISYMLI)*(K - 1) 4497 * + IMATIJ(ISYML,ISYMI) + 1 4498 KOFF3 = IT1AM(ISYMA,ISYMI) + 1 4499C 4500 NTOTA = MAX(NVIR(ISYMA),1) 4501 NTOTL = MAX(NRHF(ISYML),1) 4502C 4503 CALL DGEMM('N','N',NVIR(ISYMA),NRHF(ISYMI),NRHF(ISYML), 4504 * -ONE,TSCR(KOFF1),NTOTA,X3OINT(KOFF2),NTOTL, 4505 * ONE,ETAAI(KOFF3),NTOTA) 4506C 4507 120 CONTINUE 4508 110 CONTINUE 4509 100 CONTINUE 4510C 4511 CALL QEXIT('CCPT_3OT') 4512C 4513 RETURN 4514 END 4515C /* Deck ccpt_3vt */ 4516 SUBROUTINE CCPT_3VT(ETAAI,TSCR,DSRHF,XLAMDP,WORK,LWORK,ISYDIS) 4517C 4518C Written by Asger Halkier 10/9 - 1996. 4519C 4520C Version: 1.0 4521C 4522C Purpose: To calculate the contributions to ETAAI(CCPT2) 4523C originating from amplitudes directly contracted 4524C with integrals (oo|ov). 4525C 4526#include "implicit.h" 4527 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0) 4528 DIMENSION ETAAI(*), TSCR(*), DSRHF(*), XLAMDP(*), WORK(LWORK) 4529#include "priunit.h" 4530#include "ccorb.h" 4531#include "ccsdsym.h" 4532#include "cclr.h" 4533C 4534 CALL QENTER('CCPT_3VT') 4535C 4536 DO 100 ISYMK = 1,NSYM 4537C 4538 ISALBE = MULD2H(ISYMK,ISYDIS) 4539 ISYMAD = MULD2H(ISYMK,ISYDIS) 4540 ISYMDI = MULD2H(ISYMK,ISYDIS) 4541C 4542C---------------------------------- 4543C Work space allocation one. 4544C---------------------------------- 4545C 4546 KAOINT = 1 4547 KEND1 = KAOINT + N2BST(ISALBE) 4548 LWRK1 = LWORK - KEND1 4549C 4550 IF (LWRK1 .LT. 0) THEN 4551 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND1 4552 CALL QUIT('Insufficient memory for first allocation '// 4553 & 'in CCPT_3VT') 4554 ENDIF 4555C 4556 DO 110 K = 1,NRHF(ISYMK) 4557C 4558C---------------------------------------- 4559C Unpack integral distribution. 4560C---------------------------------------- 4561C 4562 KOFF1 = IDSRHF(ISALBE,ISYMK) + NNBST(ISALBE)*(K - 1) + 1 4563C 4564 CALL CCSD_SYMSQ(DSRHF(KOFF1),ISALBE,WORK(KAOINT)) 4565C 4566 DO 120 ISYMA = 1,NSYM 4567C 4568 ISYMAL = ISYMA 4569 ISYMI = ISYMA 4570 ISYMD = MULD2H(ISYMA,ISYMAD) 4571 ISYMBE = ISYMD 4572C 4573C---------------------------------------- 4574C Work space allocation two. 4575C---------------------------------------- 4576C 4577 KSCRAO = KEND1 4578 KSCRMO = KSCRAO + NBAS(ISYMAL)*NVIR(ISYMD) 4579 KEND2 = KSCRMO + NVIR(ISYMA)*NVIR(ISYMD) 4580 LWRK2 = LWORK - KEND2 4581C 4582 IF (LWRK2 .LT. 0) THEN 4583 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND2 4584 CALL QUIT('Insufficient memory for allocation '// 4585 & 'in CCPT_B3VT') 4586 ENDIF 4587C 4588 CALL DZERO(WORK(KSCRAO),NBAS(ISYMAL)*NVIR(ISYMD)) 4589 CALL DZERO(WORK(KSCRMO),NVIR(ISYMA)*NVIR(ISYMD)) 4590C 4591C-------------------------------------------------------------- 4592C Perform the three contractions to obtain result. 4593C-------------------------------------------------------------- 4594C 4595 KOFF2 = KAOINT + IAODIS(ISYMAL,ISYMBE) 4596 KOFF3 = ILMVIR(ISYMD) + 1 4597C 4598 NTOTAL = MAX(NBAS(ISYMAL),1) 4599 NTOTBE = MAX(NBAS(ISYMBE),1) 4600C 4601 CALL DGEMM('N','N',NBAS(ISYMAL),NVIR(ISYMD),NBAS(ISYMBE), 4602 * ONE,WORK(KOFF2),NTOTAL,XLAMDP(KOFF3),NTOTBE, 4603 * ZERO,WORK(KSCRAO),NTOTAL) 4604C 4605 KOFF4 = ILMVIR(ISYMA) + 1 4606C 4607 NTOTAL = MAX(NBAS(ISYMAL),1) 4608 NTOTA = MAX(NVIR(ISYMA),1) 4609C 4610 CALL DGEMM('T','N',NVIR(ISYMA),NVIR(ISYMD),NBAS(ISYMAL), 4611 * ONE,XLAMDP(KOFF4),NTOTAL,WORK(KSCRAO),NTOTAL, 4612 * ZERO,WORK(KSCRMO),NTOTA) 4613C 4614 KOFF5 = IT2BCD(ISYMDI,ISYMK) + NT1AM(ISYMDI)*(K - 1) 4615 * + IT1AM(ISYMD,ISYMI) + 1 4616 KOFF6 = IT1AM(ISYMA,ISYMI) + 1 4617C 4618 NTOTA = MAX(NVIR(ISYMA),1) 4619 NTOTD = MAX(NVIR(ISYMD),1) 4620C 4621 CALL DGEMM('N','N',NVIR(ISYMA),NRHF(ISYMI),NVIR(ISYMD), 4622 * ONE,WORK(KSCRMO),NTOTA,TSCR(KOFF5),NTOTD, 4623 * ONE,ETAAI(KOFF6),NTOTA) 4624C 4625 120 CONTINUE 4626 110 CONTINUE 4627 100 CONTINUE 4628C 4629 CALL QEXIT('CCPT_3VT') 4630C 4631 RETURN 4632 END 4633C /* Deck ccpt_nxy */ 4634 SUBROUTINE CCPT_NXY(ETAAI,XMAT,YMAT,X3OINT,DSRHF,XLAMDP,WORK, 4635 * LWORK,IDEL,ISYDEL) 4636C 4637C Written by Asger Halkier 10/9 - 1996. 4638C 4639C Version: 1.0 4640C 4641C Purpose: To calculate the contributions to ETAAI(CCPT2) 4642C containing the original (i.e. nonsymmetrized) 4643C X- and Y-matrices. 4644C 4645#include "implicit.h" 4646 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0, FOUR = 4.0D0) 4647 DIMENSION ETAAI(*), XMAT(*), YMAT(*), X3OINT(*), DSRHF(*) 4648 DIMENSION XLAMDP(*), WORK(LWORK) 4649#include "priunit.h" 4650#include "ccorb.h" 4651#include "ccsdsym.h" 4652#include "cclr.h" 4653C 4654 CALL QENTER('CCPT_NXY') 4655C 4656 ISYMA = ISYDEL 4657 ISYMI = ISYMA 4658C 4659C------------------------------- 4660C Work space allocation one. 4661C------------------------------- 4662C 4663 KAVEC = 1 4664 KEND1 = KAVEC + NVIR(ISYMA) 4665 LWRK1 = LWORK - KEND1 4666C 4667 IF (LWRK1 .LT. 0) THEN 4668 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND1 4669 CALL QUIT('Insufficient work space for allocation in '// 4670 & 'CCPT_NXY') 4671 ENDIF 4672C 4673 CALL DZERO(WORK(KAVEC),NVIR(ISYMA)) 4674C 4675C------------------------------------- 4676C Copy vector out of lambda matrix. 4677C------------------------------------- 4678C 4679 KOFF1 = ILMVIR(ISYMA) + IDEL - IBAS(ISYDEL) 4680C 4681 CALL DCOPY(NVIR(ISYMA),XLAMDP(KOFF1),NBAS(ISYDEL),WORK(KAVEC),1) 4682C 4683C---------------------------------------------- 4684C X- and Y- matrices are totally symmetric. 4685C---------------------------------------------- 4686C 4687 ISYMKL = 1 4688 ISYMCD = 1 4689 ISALBE = ISYMCD 4690C 4691 DO 100 I = 1,NRHF(ISYMI) 4692C 4693C----------------------------------------- 4694C Calculate contribution from XMAT. 4695C----------------------------------------- 4696C 4697 KOFF2 = IMAIJK(ISYMKL,ISYMI) + NMATIJ(ISYMKL)*(I - 1) + 1 4698 KOFF3 = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + 1 4699C 4700 FACT = DDOT(NMATIJ(ISYMKL),XMAT,1,X3OINT(KOFF2),1) 4701C 4702 CALL DAXPY(NVIR(ISYMA),-FOUR*FACT,WORK(KAVEC),1,ETAAI(KOFF3),1) 4703C 4704C---------------------------------- 4705C Work space allocation two. 4706C---------------------------------- 4707C 4708 KAOINT = KEND1 4709 KMOINT = KAOINT + N2BST(ISALBE) 4710 KEND2 = KMOINT + NMATAB(ISYMCD) 4711 LWRK2 = LWORK - KEND2 4712C 4713 IF (LWRK2 .LT. 0) THEN 4714 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND2 4715 CALL QUIT('Insufficient memory for allocation in CCPT_NXY') 4716 ENDIF 4717C 4718 CALL DZERO(WORK(KMOINT),NMATAB(ISYMCD)) 4719C 4720C------------------------------------- 4721C Unpack integral distribution. 4722C------------------------------------- 4723C 4724 KOFF4 = IDSRHF(ISALBE,ISYMI) + NNBST(ISALBE)*(I - 1) + 1 4725C 4726 CALL CCSD_SYMSQ(DSRHF(KOFF4),ISALBE,WORK(KAOINT)) 4727C 4728 DO 110 ISYMD = 1,NSYM 4729C 4730 ISYMAL = ISYMD 4731 ISYMC = MULD2H(ISYMD,ISYMCD) 4732 ISYMBE = ISYMC 4733C 4734C--------------------------------------- 4735C Work space allocation three. 4736C--------------------------------------- 4737C 4738 KSCRAO = KEND2 4739 KEND3 = KSCRAO + NBAS(ISYMAL)*NVIR(ISYMC) 4740 LWRK3 = LWORK - KEND3 4741C 4742 IF (LWRK3 .LT. 0) THEN 4743 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND3 4744 CALL QUIT('Insufficient memory for allocation in '// 4745 & 'CCPT_NXY') 4746 ENDIF 4747C 4748 CALL DZERO(WORK(KSCRAO),NBAS(ISYMAL)*NVIR(ISYMC)) 4749C 4750C------------------------------------------- 4751C Transform integrals to MO basis. 4752C------------------------------------------- 4753C 4754 KOFF5 = KAOINT + IAODIS(ISYMAL,ISYMBE) 4755 KOFF6 = ILMVIR(ISYMC) + 1 4756C 4757 NTOTAL = MAX(NBAS(ISYMAL),1) 4758 NTOTBE = MAX(NBAS(ISYMBE),1) 4759C 4760 CALL DGEMM('N','N',NBAS(ISYMAL),NVIR(ISYMC),NBAS(ISYMBE), 4761 * ONE,WORK(KOFF5),NTOTAL,XLAMDP(KOFF6),NTOTBE, 4762 * ONE,WORK(KSCRAO),NTOTAL) 4763C 4764 KOFF7 = ILMVIR(ISYMD) + 1 4765 KOFF8 = KMOINT + IMATAB(ISYMD,ISYMC) 4766C 4767 NTOTAL = MAX(NBAS(ISYMAL),1) 4768 NTOTD = MAX(NVIR(ISYMD),1) 4769C 4770 CALL DGEMM('T','N',NVIR(ISYMD),NVIR(ISYMC),NBAS(ISYMAL), 4771 * ONE,XLAMDP(KOFF7),NTOTAL,WORK(KSCRAO),NTOTAL, 4772 * ONE,WORK(KOFF8),NTOTD) 4773C 4774 110 CONTINUE 4775C 4776C------------------------------------------ 4777C Calculate contributions from YMAT. 4778C------------------------------------------ 4779C 4780 FACT = DDOT(NMATAB(ISYMCD),YMAT,1,WORK(KMOINT),1) 4781C 4782 KOFF9 = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + 1 4783C 4784 CALL DAXPY(NVIR(ISYMA),FOUR*FACT,WORK(KAVEC),1,ETAAI(KOFF9),1) 4785C 4786 100 CONTINUE 4787C 4788 CALL QEXIT('CCPT_NXY') 4789C 4790 RETURN 4791 END 4792C /* Deck ccpt_xto */ 4793 SUBROUTINE CCPT_XTO(ETAAI,XTMAT,X3OINT,XLAMDP,WORK, 4794 * LWORK,IDEL,ISYMD) 4795C 4796C Written by Asger Halkier 10/9 - 1996. 4797C 4798C Version: 1.0 4799C 4800C Purpose: To calculate the contribution to ETAAI(CCPT2) 4801C involving the symmetrized X-matrix (XTMAT) and the 4802C (oo|ov) integrals. 4803C 4804#include "implicit.h" 4805 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0, FOUR = 4.0D0) 4806 DIMENSION ETAAI(*), XTMAT(*), X3OINT(*), XLAMDP(*), WORK(LWORK) 4807#include "priunit.h" 4808#include "ccorb.h" 4809#include "ccsdsym.h" 4810#include "cclr.h" 4811C 4812 CALL QENTER('CCPT_XTO') 4813C 4814 ISYMA = ISYMD 4815 ISYMI = ISYMA 4816 ISYMKL = 1 4817C 4818C------------------------------- 4819C Work space allocation one. 4820C------------------------------- 4821C 4822 KAVEC = 1 4823 KIVEC = KAVEC + NVIR(ISYMA) 4824 KEND1 = KIVEC + NRHF(ISYMI) 4825 LWRK1 = LWORK - KEND1 4826C 4827 IF (LWRK1 .LT. 0) THEN 4828 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND1 4829 CALL QUIT('Insufficient work space for allocation '// 4830 & 'in CCPT_XTO') 4831 ENDIF 4832C 4833 CALL DZERO(WORK(KAVEC),NVIR(ISYMA)) 4834 CALL DZERO(WORK(KIVEC),NRHF(ISYMI)) 4835C 4836C------------------------------------- 4837C Copy vector out of lambda matrix. 4838C------------------------------------- 4839C 4840 KOFF1 = ILMVIR(ISYMA) + IDEL - IBAS(ISYMD) 4841C 4842 CALL DCOPY(NVIR(ISYMA),XLAMDP(KOFF1),NBAS(ISYMD),WORK(KAVEC),1) 4843C 4844 DO 100 ISYML = 1,NSYM 4845C 4846 ISYMK = MULD2H(ISYML,ISYMKL) 4847 ISYMIK = MULD2H(ISYMI,ISYMK) 4848C 4849 DO 110 L = 1,NRHF(ISYML) 4850C 4851C-------------------------------------------------------- 4852C Contract integrals with symmetrized X-matrix. 4853C-------------------------------------------------------- 4854C 4855 KOFF2 = IMAIJK(ISYMIK,ISYML) + NMATIJ(ISYMIK)*(L - 1) 4856 * + IMATIJ(ISYMI,ISYMK) + 1 4857 KOFF3 = IMATIJ(ISYMK,ISYML) + NRHF(ISYMK)*(L - 1) + 1 4858C 4859 NTOTI = MAX(NRHF(ISYMI),1) 4860C 4861 CALL DGEMV('N',NRHF(ISYMI),NRHF(ISYMK),ONE,X3OINT(KOFF2), 4862 * NTOTI,XTMAT(KOFF3),1,ONE,WORK(KIVEC),1) 4863C 4864 110 CONTINUE 4865 100 CONTINUE 4866C 4867C----------------------------- 4868C Final storage in result. 4869C----------------------------- 4870C 4871 DO 120 I = 1,NRHF(ISYMI) 4872C 4873 KOFF4 = KIVEC + I - 1 4874 KOFF5 = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + 1 4875C 4876 CALL DAXPY(NVIR(ISYMA),WORK(KOFF4),WORK(KAVEC),1, 4877 * ETAAI(KOFF5),1) 4878C 4879 120 CONTINUE 4880C 4881 CALL QEXIT('CCPT_XTO') 4882C 4883 RETURN 4884 END 4885C /* Deck ccpt_ytv */ 4886 SUBROUTINE CCPT_YTV(ETAAI,YTMAT,DSRHF,XLAMDP,WORK, 4887 * LWORK,IDEL,ISYDEL) 4888C 4889C Written by Asger Halkier 10/9 - 1996. 4890C 4891C Version: 1.0 4892C 4893C Purpose: To calculate the contribution to ETAAI(CCPT2) 4894C involving the symmetrized Y-matrix (YTMAT) and the 4895C (vv|ov) integrals. 4896C 4897#include "implicit.h" 4898 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0, FOUR = 4.0D0) 4899 DIMENSION ETAAI(*), YTMAT(*), DSRHF(*), XLAMDP(*), WORK(LWORK) 4900#include "priunit.h" 4901#include "ccorb.h" 4902#include "ccsdsym.h" 4903#include "cclr.h" 4904C 4905 CALL QENTER('CCPT_YTV') 4906C 4907 ISYMC = ISYDEL 4908 ISYMD = ISYMC 4909C 4910C------------------------------- 4911C Work space allocation one. 4912C------------------------------- 4913C 4914 KCVEC = 1 4915 KDVEC = KCVEC + NVIR(ISYMC) 4916 KEND1 = KDVEC + NVIR(ISYMD) 4917 LWRK1 = LWORK - KEND1 4918C 4919 IF (LWRK1 .LT. 0) THEN 4920 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND1 4921 CALL QUIT('Insufficient work space for allocation in '// 4922 & 'CCPT_YTV') 4923 ENDIF 4924C 4925 CALL DZERO(WORK(KCVEC),NVIR(ISYMC)) 4926 CALL DZERO(WORK(KDVEC),NVIR(ISYMD)) 4927C 4928C------------------------------------- 4929C Copy vector out of lambda matrix. 4930C------------------------------------- 4931C 4932 KOFF1 = ILMVIR(ISYMC) + IDEL - IBAS(ISYDEL) 4933C 4934 CALL DCOPY(NVIR(ISYMC),XLAMDP(KOFF1),NBAS(ISYDEL),WORK(KCVEC),1) 4935C 4936C---------------------------------------- 4937C Contract with symmetrized Y-matrix. 4938C---------------------------------------- 4939C 4940 KOFF1 = IMATAB(ISYMD,ISYMC) + 1 4941C 4942 NTOTD = MAX(NVIR(ISYMD),1) 4943C 4944 CALL DGEMV('N',NVIR(ISYMD),NVIR(ISYMC),ONE,YTMAT(KOFF1),NTOTD, 4945 * WORK(KCVEC),1,ZERO,WORK(KDVEC),1) 4946C 4947 DO 100 ISYMI = 1,NSYM 4948C 4949 ISYMA = ISYMI 4950 ISYMAL = ISYMA 4951 ISYMBE = ISYMD 4952 ISALBE = MULD2H(ISYMAL,ISYMBE) 4953C 4954C---------------------------------- 4955C Work space allocation two. 4956C---------------------------------- 4957C 4958 KAOINT = KEND1 4959 KSCRAO = KAOINT + N2BST(ISALBE) 4960 KMOINT = KSCRAO + NBAS(ISYMAL)*NVIR(ISYMD) 4961 KEND2 = KMOINT + NVIR(ISYMA)*NVIR(ISYMD) 4962 LWRK2 = LWORK - KEND2 4963C 4964 IF (LWRK2 .LT. 0) THEN 4965 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND2 4966 CALL QUIT('Insufficient work space for allocation '// 4967 & 'in CCPT_YTV') 4968 ENDIF 4969C 4970 CALL DZERO(WORK(KSCRAO),NBAS(ISYMAL)*NVIR(ISYMD)) 4971 CALL DZERO(WORK(KMOINT),NVIR(ISYMA)*NVIR(ISYMD)) 4972C 4973 DO 110 I = 1,NRHF(ISYMI) 4974C 4975C---------------------------------------- 4976C Unpack integral distribution. 4977C---------------------------------------- 4978C 4979 KOFF2 = IDSRHF(ISALBE,ISYMI) + NNBST(ISALBE)*(I - 1) + 1 4980C 4981 CALL CCSD_SYMSQ(DSRHF(KOFF2),ISALBE,WORK(KAOINT)) 4982C 4983C------------------------------------------- 4984C Transform integrals to MO basis. 4985C------------------------------------------- 4986C 4987 KOFF3 = KAOINT + IAODIS(ISYMAL,ISYMBE) 4988 KOFF4 = ILMVIR(ISYMD) + 1 4989C 4990 NTOTAL = MAX(NBAS(ISYMAL),1) 4991 NTOTBE = MAX(NBAS(ISYMBE),1) 4992C 4993 CALL DGEMM('N','N',NBAS(ISYMAL),NVIR(ISYMD),NBAS(ISYMBE), 4994 * ONE,WORK(KOFF3),NTOTAL,XLAMDP(KOFF4),NTOTBE, 4995 * ZERO,WORK(KSCRAO),NTOTAL) 4996C 4997 KOFF5 = ILMVIR(ISYMA) + 1 4998C 4999 NTOTAL = MAX(NBAS(ISYMAL),1) 5000 NTOTA = MAX(NVIR(ISYMA),1) 5001C 5002 CALL DGEMM('T','N',NVIR(ISYMA),NVIR(ISYMD),NBAS(ISYMAL), 5003 * ONE,XLAMDP(KOFF5),NTOTAL,WORK(KSCRAO),NTOTAL, 5004 * ZERO,WORK(KMOINT),NTOTA) 5005C 5006 KOFF6 = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + 1 5007C 5008 NTOTA = MAX(NVIR(ISYMA),1) 5009C 5010 CALL DGEMV('N',NVIR(ISYMA),NVIR(ISYMD),-ONE,WORK(KMOINT), 5011 * NTOTA,WORK(KDVEC),1,ONE,ETAAI(KOFF6),1) 5012C 5013 110 CONTINUE 5014 100 CONTINUE 5015C 5016 CALL QEXIT('CCPT_YTV') 5017C 5018 RETURN 5019 END 5020C /* Deck cc_dedian */ 5021 SUBROUTINE CC_DEDIAN(DENSI,MODEL,WORK,LWORK) 5022C 5023C Written by Asger Halkier 18/3 - 1998 5024C 5025C Version: 1.0 5026C 5027C Purpose: To diagonalize and analyse the correlated 5028C one-electron density matrix. 5029C 5030#include "implicit.h" 5031 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0) 5032 DIMENSION DENSI(*), WORK(LWORK) 5033#include "priunit.h" 5034#include "ccorb.h" 5035#include "ccsdsym.h" 5036#include "cclr.h" 5037#include "ccsdinp.h" 5038C 5039 CHARACTER MODEL*4 5040C 5041 CALL QENTER('CC_DEDIAN') 5042C 5043C--------------------------- 5044C Work space allocation. 5045C--------------------------- 5046C 5047 KNATOC = 1 5048 KIMANO = KNATOC + NORBT 5049 KIV1 = KIMANO + NORBT 5050 KFV1 = KIV1 + NORBT 5051 KEND1 = KFV1 + NORBT 5052 LWRK1 = LWORK - KEND1 5053C 5054 IF (LWRK1 .LT. 0) THEN 5055 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND1 5056 CALL QUIT('Insufficient memory for allocation in CC_DEDIAN') 5057 ENDIF 5058C 5059C------------------------------------------------ 5060C Diagonalize the density in symmetry blocks. 5061C------------------------------------------------ 5062C 5063 KOFF1 = 1 5064 KOFF2 = KNATOC 5065 KOFF3 = KIMANO 5066C 5067 CALL AROUND(MODEL//' Natural Occupations') 5068C 5069 DO 100 ISYM = 1,NSYM 5070C 5071 CALL DZERO(WORK(KIV1),NORBT) 5072 CALL DZERO(WORK(KFV1),NORBT) 5073C 5074 MATZ = 0 5075C 5076 CALL RG(NORB(ISYM),NORB(ISYM),DENSI(KOFF1),WORK(KOFF2), 5077 * WORK(KOFF3),MATZ,DUMMY,WORK(KIV1),WORK(KFV1),IERR) 5078C 5079 IF (IERR .NE. 0) THEN 5080 WRITE(LUPRI,*) 'RG returned non-zero status of IERR' 5081 WRITE(LUPRI,*) 'Diagonalization of one electron '// 5082 & 'density failed' 5083 ENDIF 5084C 5085 WRITE(LUPRI,*) ' ' 5086 WRITE(LUPRI,444) 'Symmetry block number:', ISYM 5087 WRITE(LUPRI,555) '---------------------' 5088 WRITE(LUPRI,*) ' ' 5089 IF (NORB(ISYM) .EQ. 0) THEN 5090 WRITE(LUPRI,777) 'No orbitals in this symmetry block' 5091 ELSE 5092 CALL SORTASH(WORK(KOFF2),WORK(KOFF3),NORB(ISYM)) 5093 WRITE(LUPRI,666) (WORK(KOFF2 + I - 1), I = NORB(ISYM),1,-1) 5094C 5095 SUMSYM = ZERO 5096C 5097 DO 110 I = 1,NORB(ISYM) 5098C 5099 SUMSYM = SUMSYM + WORK(KOFF2 + I - 1) 5100C 5101 110 CONTINUE 5102C 5103 WRITE(LUPRI,*) ' ' 5104 WRITE(LUPRI,888) 'Sum in this symmetry class:', SUMSYM 5105C 5106 ENDIF 5107C 5108 IF (IPRINT .GT. 50) THEN 5109C 5110 WRITE(LUPRI,*) ' ' 5111 WRITE(LUPRI,555) 'Natocc imaginary part' 5112 WRITE(LUPRI,*) ' ' 5113 WRITE(LUPRI,666) (WORK(KOFF3 + I - 1), I = NORB(ISYM),1,-1) 5114C 5115 ENDIF 5116C 5117 444 FORMAT(3X,A22,2X,I1) 5118 555 FORMAT(3X,A21) 5119 666 FORMAT(5F13.8) 5120 777 FORMAT(3X,A34) 5121 888 FORMAT(3X,A27,2X,F9.6) 5122C 5123 KOFF1 = KOFF1 + NORB(ISYM)*NORB(ISYM) 5124 KOFF2 = KOFF2 + NORB(ISYM) 5125 KOFF3 = KOFF3 + NORB(ISYM) 5126C 5127 100 CONTINUE 5128C 5129 CALL SORTASH(WORK(KNATOC),WORK(KIMANO),NORBT) 5130C 5131 CALL CCNAOCAN(WORK(KNATOC),WORK(KIMANO)) 5132C 5133 CALL QEXIT('CC_DEDIAN') 5134C 5135 RETURN 5136 END 5137C /* Deck mp_zkdia */ 5138 SUBROUTINE MP2_ZKDIA(IPDD,R12PRP,MODEL,ZKDIA,WORK,LWORK) 5139C 5140C Written by Asger Halkier 20/3 - 1998 5141C 5142C Version: 1.0 5143C 5144C Purpose: To calculate the pp, ab, & ij parts of kappa-bar-0 5145C that do not need the solution of any coupled equations. 5146C ZKDIA holds all the blocks pq in the following order: 5147C ij, ab, ai, ia; and these are stored full blocks after 5148C each other. After these, the blocks containing frozen 5149C core indices come: first cJ and then kJ. 5150C 5151#include "implicit.h" 5152#include "dummy.h" 5153 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0) 5154 CHARACTER MODEL*10 5155 DIMENSION ZKDIA(*), WORK(LWORK) 5156 LOGICAL R12PRP 5157#include "priunit.h" 5158#include "maxorb.h" 5159#include "ccorb.h" 5160#include "iratdef.h" 5161#include "cclr.h" 5162#include "ccsdsym.h" 5163#include "ccsdio.h" 5164#include "ccsdinp.h" 5165#include "ccinftap.h" 5166#include "ccfro.h" 5167C 5168 CALL QENTER('MP2_ZKDIA') 5169C 5170 TIMETO = SECOND() 5171C 5172 IF (IPRINT .GT. 3) THEN 5173 CALL HEADER('Calculating diagonal blocks of zeta-kappa-0',-1) 5174 ENDIF 5175C 5176C------------------------------------------------------------------ 5177C Both t-vectors and tbar-vectors (zeta) are totally symmetric. 5178C------------------------------------------------------------------ 5179C 5180 ISYMTR = 1 5181 ISYMOP = 1 5182C 5183C------------------------------- 5184C Work space allocation one. 5185C------------------------------- 5186C 5187 KT2AM = 1 5188 KXMAT = KT2AM + NT2AMX 5189 KYMAT = KXMAT + NMATIJ(1) 5190 KZ2AM = KYMAT + NMATAB(1) 5191 KT1AM = KZ2AM + NT2SQ(1) 5192 KZ1AM = KT1AM + NT1AMX 5193 KRMAT = KZ1AM + NT1AMX 5194 KEND1 = KRMAT + NMATIJ(1) 5195c KEND1 = KZ1AM + NT1AMX 5196 LWRK1 = LWORK - KEND1 5197C 5198 IF (LWRK1 .LT. 0) THEN 5199 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND1 5200 CALL QUIT('Insufficient memory for initial allocation '// 5201 & 'in MP2_ZKDIA') 5202 ENDIF 5203C 5204C---------------------------------------- 5205C Read zero'th order zeta amplitudes. 5206C---------------------------------------- 5207C 5208 IOPT = 3 5209 CALL CC_RDRSP('L0',0,1,IOPT,MODEL,WORK(KZ1AM),WORK(KZ2AM)) 5210C 5211 KEND1 = KZ1AM 5212 LWRK1 = LWORK - KEND1 5213C 5214C-------------------------------- 5215C Square up zeta2 amplitudes. 5216C-------------------------------- 5217C 5218 CALL DCOPY(NT2AMX,WORK(KZ2AM),1,WORK(KT2AM),1) 5219 5220 CALL CC_T2SQ(WORK(KT2AM),WORK(KZ2AM),1) 5221 5222C 5223C 5224C------------------------------------------- 5225C Read zero'th order cluster amplitudes. 5226C------------------------------------------- 5227C 5228 IOPT = 3 5229 CALL CC_RDRSP('R0',0,1,IOPT,MODEL,WORK(KT1AM),WORK(KT2AM)) 5230 5231C 5232 KEND1 = KT1AM 5233 LWRK1 = LWORK - KEND1 5234C 5235C 5236C-------------------------------------------------------- 5237C Calculate X-intermediate of tbar- and t-amplitudes. 5238C-------------------------------------------------------- 5239C 5240 CALL CC_XI(WORK(KXMAT),WORK(KZ2AM),ISYMTR,WORK(KT2AM),ISYMOP, 5241 * WORK(KEND1),LWRK1) 5242C 5243C-------------------------------------------------------- 5244C Calculate Y-intermediate of tbar- and t-amplitudes. 5245C-------------------------------------------------------- 5246C 5247 CALL CC_YI(WORK(KYMAT),WORK(KZ2AM),ISYMTR,WORK(KT2AM),ISYMOP, 5248 * WORK(KEND1),LWRK1) 5249C 5250C-------------------------------------------------------------------------- 5251C Calculate the diagonal elements ZK0(ii) = -X(ii) and ZK0(aa) = Y(aa). 5252C-------------------------------------------------------------------------- 5253C 5254 DO 100 ISYMI = 1,NSYM 5255 DO 110 I = 1,NRHF(ISYMI) 5256C 5257 NII = IMATIJ(ISYMI,ISYMI) + NRHF(ISYMI)*(I - 1) + I 5258C 5259 ZKDIA(NII) = -WORK(KXMAT + NII - 1) 5260C 5261 110 CONTINUE 5262 100 CONTINUE 5263C 5264 DO 120 ISYMA = 1,NSYM 5265 DO 130 A = 1,NVIR(ISYMA) 5266C 5267 NAA = IMATAB(ISYMA,ISYMA) + NVIR(ISYMA)*(A - 1) + A 5268C 5269 ZKDIA(NMATIJ(1) + NAA) = WORK(KYMAT + NAA - 1) 5270C 5271 130 CONTINUE 5272 120 CONTINUE 5273C 5274C--------------------------------------- 5275C Set up 2C-E of cluster amplitudes. 5276C--------------------------------------- 5277C 5278 ISYOPE = 1 5279 IOPTTCME = 1 5280 CALL CCSD_TCMEPK(WORK(KT2AM),1.0D0,ISYOPE,IOPTTCME) 5281C 5282C------------------------------------------------------------- 5283C Set up special modified amplitudes T(2c-e) + Tbar. 5284C Store it squared in KZ2AM to make smart contraction with 5285C packed integrals (ai|bj) using the X- and Y-routines. 5286C------------------------------------------------------------- 5287C 5288 IOPT = 3 5289 CALL CC_RDRSP('L0',0,1,IOPT,MODEL,WORK(KZ1AM),WORK(KZ2AM)) 5290C 5291 CALL DSCAL(NT2AMX,TWO,WORK(KT2AM),1) 5292 CALL DAXPY(NT2AMX,ONE,WORK(KZ2AM),1,WORK(KT2AM),1) 5293 CALL CC_T2SQ(WORK(KT2AM),WORK(KZ2AM),1) 5294C----------------------------------------------- 5295C Read integrals (ai|bj) = (ia|jb) from disc 5296C (file always assumed open) into KT2AM. 5297C----------------------------------------------- 5298C 5299 REWIND(LUIAJB) 5300 READ(LUIAJB) (WORK(KT2AM + I - 1), I = 1,NT2AMX) 5301C 5302C----------------------------------------------- 5303C Calculate modified X- and Y-intermediates. 5304C----------------------------------------------- 5305C 5306 CALL CC_XI(WORK(KXMAT),WORK(KZ2AM),ISYMTR,WORK(KT2AM),ISYMOP, 5307 * WORK(KEND1),LWRK1) 5308C 5309 CALL CC_YI(WORK(KYMAT),WORK(KZ2AM),ISYMTR,WORK(KT2AM),ISYMOP, 5310 * WORK(KEND1),LWRK1) 5311C 5312C--------------------------------------------- 5313C Calculate the ZK0(ab) and ZK0(ij) blocks 5314C from modified X- and Y-intermediates. 5315C--------------------------------------------- 5316C 5317 CALL MP2_ZKBLO(ZKDIA,WORK(KXMAT),WORK(KYMAT), 5318 & WORK(KEND1),LWRK1) 5319C 5320C--------------------------------------------------- 5321C Calculate frozen core occupied blocks ZK0(iJ). 5322C--------------------------------------------------- 5323C 5324 IF (FROIMP) THEN 5325 KOFRES = NMATIJ(1) + NMATAB(1) + 2*NT1AMX + 2*NT1FRO(1) + 1 5326 CALL MP2_ZKFCB(IPDD,R12PRP,ZKDIA(KOFRES),WORK(KZ2AM), 5327 & WORK(KEND1),LWRK1) 5328 ENDIF 5329C 5330C------------------------------------------------ 5331C Write out timings and results if requested. 5332C------------------------------------------------ 5333C 5334 IF (IPRINT .GT. 3) THEN 5335 CALL AROUND('Zeta-kappa-0 diagonal blocks') 5336 ZKAPI1 = DDOT(NMATIJ(1),ZKDIA(1),1,ZKDIA(1),1) 5337 ZKAPA1 = DDOT(NMATAB(1),ZKDIA(NMATIJ(1)+1),1, 5338 * ZKDIA(NMATIJ(1)+1),1) 5339 ZKAPIJ = ZKAPI1**0.5 5340 ZKAPAB = ZKAPA1**0.5 5341 WRITE(LUPRI,*) ' ' 5342 WRITE(LUPRI,*) 'Norm of occupied-occupied block:', ZKAPIJ 5343 WRITE(LUPRI,*) 'Norm of virtual-virtual block:', ZKAPAB 5344 IF (FROIMP) THEN 5345 ZKAPF1 = DDOT(NCOFRO(1),ZKDIA(KOFRES),1, 5346 * ZKDIA(KOFRES),1) 5347 ZKAPFR = ZKAPF1**0.5 5348 WRITE(LUPRI,*) 'Norm of frozen-core-occupied block:', ZKAPFR 5349 ENDIF 5350C 5351 IF (IPRINT .GT. 50) THEN 5352 DO 140 ISYM = 1,NSYM 5353 WRITE(LUPRI,*) ' ' 5354 WRITE(LUPRI,*) 'Symmetry block:', ISYM 5355 KIJ = IMATIJ(ISYM,ISYM) + 1 5356 KAB = IMATAB(ISYM,ISYM) + 1 + NMATIJ(1) 5357 CALL AROUND('occ-occ block') 5358 CALL OUTPUT(ZKDIA(KIJ),1,NRHF(ISYM),1,NRHF(ISYM), 5359 * NRHF(ISYM),NRHF(ISYM),1,LUPRI) 5360 CALL AROUND('vir-vir block') 5361 CALL OUTPUT(ZKDIA(KAB),1,NVIR(ISYM),1,NVIR(ISYM), 5362 * NVIR(ISYM),NVIR(ISYM),1,LUPRI) 5363 140 CONTINUE 5364 ENDIF 5365 ENDIF 5366C 5367 TIMETO = SECOND() - TIMETO 5368C 5369 IF (IPRINT .GT. 3) THEN 5370 WRITE(LUPRI,*) ' ' 5371 WRITE(LUPRI,*) 'Diagonal blocks of Zeta-kappa-0 calculated' 5372 WRITE(LUPRI,*) 'Total time used in MP2_ZKDIA:', TIMETO 5373 ENDIF 5374C 5375 CALL QEXIT('MP2_ZKDIA') 5376 RETURN 5377 END 5378C /* Deck mp_zkblo */ 5379 SUBROUTINE MP2_ZKBLO(ZKDIA,XMAT,YMAT,WORK,LWORK) 5380C 5381C Written by Asger Halkier 22/3 - 1998 5382C 5383C Version: 1.0 5384C 5385C Purpose: To calculate the ab & ij parts of kappa-bar-0, 5386C from modified X- and Y-intermediates (XMAT & YMAT) 5387C and canonical orbital energies. 5388C 5389C If degeneracies occur among the orbitals, the divergent terms 5390C with the corresponding orbital energy difference denominators 5391C are skipped. This is controlled via the THRDEM parameter. 5392C 5393C Small modifications for CC2 by A. Halkier & S. Coriani 5394C 14/01-2000. Introduce factor FACT to control antisymmetrization 5395C of eta_ij and eta_ab. 5396C 5397C Additional numerical stability, Thomas Bondo Pedersen, Jan. 2013. 5398C - if numerator is zero, then kappa-bar-0 is set to zero. 5399C - if numerator is non-zero and denominator is zero, the 5400C equation system is singular and we have to quit. 5401C - in addition, redundant zeroing eliminated. 5402C 5403#include "implicit.h" 5404#include "priunit.h" 5405#include "dummy.h" 5406 PARAMETER(ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, TWO = 2.0D0) 5407 PARAMETER (THRDEM = 1.0D-12) 5408 PARAMETER (EPSN = 1.0D-12, EPSD = 1.0D-12) 5409 DIMENSION ZKDIA(*), XMAT(*), YMAT(*), WORK(LWORK) 5410#include "maxorb.h" 5411#include "ccorb.h" 5412#include "iratdef.h" 5413#include "inftap.h" 5414#include "cclr.h" 5415#include "ccsdsym.h" 5416#include "ccsdio.h" 5417#include "ccsdinp.h" 5418C 5419 REAL*8 CC_PROTECTED_DIVISION 5420 EXTERNAL CC_PROTECTED_DIVISION 5421C 5422 CALL QENTER('MP2_ZKBLO') 5423C 5424 IF (MP2) THEN 5425 FACT = ONE 5426 ELSE IF (CC2) THEN 5427 FACT = ZERO 5428 ELSE IF (CCSD) THEN 5429 FACT = -ONE 5430 ELSE 5431 FACT = -ONE 5432 END IF 5433C 5434C--------------------------- 5435C Work space allocation. 5436C--------------------------- 5437C 5438 KFOCKD = 1 5439 KEND1 = KFOCKD + NORBTS 5440 LWRK1 = LWORK - KEND1 5441C 5442 IF (LWRK1 .LT. 0) THEN 5443 WRITE(LUPRI,*) 'Need:', KEND1, 'Available:', LWORK 5444 CALL QUIT('Insufficient memory for allocation in MP2_ZKBLO') 5445 ENDIF 5446C 5447 CALL DZERO(WORK(KFOCKD),NORBTS) 5448C 5449C------------------------------------- 5450C Read canonical orbital energies. 5451C------------------------------------- 5452C 5453 CALL GPOPEN(LUSIFC,'SIRIFC','OLD',' ','UNFORMATTED',IDUMMY, 5454 & .FALSE.) 5455 REWIND (LUSIFC) 5456C 5457 CALL MOLLAB('TRCCINT ',LUSIFC,LUPRI) 5458 READ (LUSIFC) 5459 READ (LUSIFC) (WORK(KFOCKD + I - 1), I = 1,NORBTS) 5460C 5461 CALL GPCLOSE(LUSIFC,'KEEP') 5462C 5463C---------------------------------------------------------------- 5464C Change symmetry ordering of the canonical orbital energies. 5465C---------------------------------------------------------------- 5466C 5467 IF (FROIMP) 5468 * CALL CCSD_DELFRO(WORK(KFOCKD),WORK(KEND1),LWRK1) 5469C 5470 CALL FOCK_REORDER(WORK(KFOCKD),WORK(KEND1),LWRK1) 5471C 5472C--------------------------- 5473C Calculate the results: 5474C Occupied block: 5475C--------------------------- 5476C 5477 DO 100 ISYMI = 1,NSYM 5478 ISYMJ = ISYMI 5479 DO 110 J = 1,NRHF(ISYMJ) 5480 KOFFJ = KFOCKD + IRHF(ISYMJ) + J - 1 5481 DO 120 I = J+1,NRHF(ISYMI) 5482 KOFFI = KFOCKD + IRHF(ISYMI) + I - 1 5483 DENOM = WORK(KOFFJ) - WORK(KOFFI) 5484 NIJ = IMATIJ(ISYMI,ISYMJ) + NRHF(ISYMI)*(J - 1) + I 5485 NJI = IMATIJ(ISYMJ,ISYMI) + NRHF(ISYMJ)*(I - 1) + J 5486 XNOMI = HALF*(XMAT(NIJ) - FACT*XMAT(NJI)) 5487 ZKDIA(NIJ) = CC_PROTECTED_DIVISION(XNOMI,DENOM,EPSN,EPSD) 5488 ZKDIA(NJI) = ZKDIA(NIJ) 5489! IF (ABS(DENOM) .GT. THRDEM) THEN 5490! NIJ = IMATIJ(ISYMI,ISYMJ) + NRHF(ISYMI)*(J - 1) + I 5491! NJI = IMATIJ(ISYMJ,ISYMI) + NRHF(ISYMJ)*(I - 1) + J 5492! ZKDIA(NIJ) = HALF*(XMAT(NIJ) - FACT*XMAT(NJI))/DENOM 5493! ZKDIA(NJI) = ZKDIA(NIJ) 5494! ENDIF 5495C 5496 120 CONTINUE 5497 110 CONTINUE 5498 100 CONTINUE 5499C 5500C------------------- 5501C Virtual block: 5502C------------------- 5503C 5504 DO 130 ISYMA = 1,NSYM 5505 ISYMB = ISYMA 5506 DO 140 B = 1,NVIR(ISYMB) 5507 KOFFB = KFOCKD + IVIR(ISYMB) + B - 1 5508 DO 150 A = B+1,NVIR(ISYMA) 5509 KOFFA = KFOCKD + IVIR(ISYMA) + A - 1 5510 DENOM = WORK(KOFFB) - WORK(KOFFA) 5511 NAB = IMATAB(ISYMA,ISYMB) + NVIR(ISYMA)*(B - 1) + A 5512 NBA = IMATAB(ISYMB,ISYMA) + NVIR(ISYMB)*(A - 1) + B 5513 XNOMI = HALF*(YMAT(NAB) - FACT*YMAT(NBA)) 5514 ZKDIA(NMATIJ(1)+NAB) = CC_PROTECTED_DIVISION(XNOMI,DENOM, 5515 & EPSN,EPSD) 5516 ZKDIA(NMATIJ(1)+NBA) = ZKDIA(NMATIJ(1)+NAB) 5517! IF (ABS(DENOM) .GT. THRDEM) THEN 5518! NAB = IMATAB(ISYMA,ISYMB) + NVIR(ISYMA)*(B - 1) + A 5519! NBA = IMATAB(ISYMB,ISYMA) + NVIR(ISYMB)*(A - 1) + B 5520!C 5521! ZKDIA(NMATIJ(1) + NAB) = 5522! * HALF*(YMAT(NAB) - FACT*YMAT(NBA))/DENOM 5523! ZKDIA(NMATIJ(1) + NBA) = ZKDIA(NMATIJ(1) + NAB) 5524! ENDIF 5525C 5526 150 CONTINUE 5527 140 CONTINUE 5528 130 CONTINUE 5529C 5530 CALL QEXIT('MP2_ZKBLO') 5531C 5532 RETURN 5533 END 5534C /* Deck mp2_kanew */ 5535 SUBROUTINE MP2_KANEW(MODEL,ETAAI,ZKDIA,WORK,LWORK) 5536C 5537C Written by Asger Halkier 23/3 - 1998 5538C 5539C Version: 1.0 5540C 5541C Purpose: To calculate the right hand side ETAAI for the 5542C equations for the zero'th order orbital rotation 5543C multipliers in MP2 calculations. 5544C 5545C Modifications for inclusion of frozen core contributions 5546C by Asger Halkier 28/5 - 1998. 5547C 5548#include "implicit.h" 5549#include "priunit.h" 5550#include "dummy.h" 5551#include "maxash.h" 5552#include "maxorb.h" 5553#include "mxcent.h" 5554#include "aovec.h" 5555#include "iratdef.h" 5556 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0) 5557 CHARACTER MODEL*10 5558 DIMENSION INDEXA(MXCORB_CC) 5559 DIMENSION ETAAI(*), ZKDIA(*), WORK(LWORK) 5560#include "ccorb.h" 5561CCN#include "infind.h" 5562#include "ccisao.h" 5563celena#include "ccisao.h" sonst falscher Wert fuer ISAO() in D2h 5564!CCN: Nicht, wenn man ISAO() NACH IJKAUX() aufruft! 5565#include "r12int.h" 5566#include "blocks.h" 5567#include "ccsdinp.h" 5568#include "ccsdsym.h" 5569#include "ccinftap.h" 5570#include "ccsdio.h" 5571#include "distcl.h" 5572#include "cbieri.h" 5573#include "eritap.h" 5574#include "cclr.h" 5575#include "ccfro.h" 5576C 5577 CALL QENTER('MP2_KANEW') 5578C 5579 CALL HEADER('Constructing right-hand-side for MP2-kappa-0(ai)',-1) 5580C 5581 TIMETO = ZERO 5582 TIMETO = SECOND() 5583C 5584C------------------------------------------------------------------ 5585C Both t-vectors and tbar-vectors (zeta) are totally symmetric. 5586C------------------------------------------------------------------ 5587C 5588 ISYMTR = 1 5589 ISYMOP = 1 5590C 5591C------------------------------- 5592C Work space allocation one. 5593C------------------------------- 5594C 5595 KAFROI = 1 5596 KT2AM = KAFROI + NT1FRO(1) 5597 KLAMDP = KT2AM + NT2AMX 5598 KLAMDH = KLAMDP + NLAMDT 5599 KZ2AM = KLAMDH + NLAMDT 5600 KT1AM = KZ2AM + NT2AMX 5601 KEND1 = KT1AM + NT1AMX 5602 LWRK1 = LWORK - KEND1 5603C 5604 IF (LWRK1 .LT. 0) THEN 5605 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND1 5606 CALL QUIT('Insufficient memory for initial allocation '// 5607 & 'in MP2_KANEW') 5608 ENDIF 5609C 5610 CALL DZERO(WORK(KAFROI),NT1FRO(1)) 5611C 5612C------------------------------------------- 5613C Read zero'th order cluster amplitudes. 5614C------------------------------------------- 5615C 5616 IOPT = 3 5617 CALL CC_RDRSP('R0',0,1,IOPT,MODEL,WORK(KT1AM),WORK(KT2AM)) 5618C 5619 CALL DZERO(WORK(KT1AM),NT1AMX) 5620C 5621C---------------------------------- 5622C Calculate the lambda matrices. 5623C---------------------------------- 5624C 5625 CALL LAMMAT(WORK(KLAMDP),WORK(KLAMDH),WORK(KT1AM),WORK(KEND1), 5626 * LWRK1) 5627C 5628C---------------------------------------- 5629C Read zero'th order zeta amplitudes. 5630C---------------------------------------- 5631C 5632 IOPT = 3 5633 CALL CC_RDRSP('L0',0,1,IOPT,MODEL,WORK(KT1AM),WORK(KZ2AM)) 5634C 5635C--------------------------------------- 5636C Set up 2C-E of cluster amplitudes. 5637C--------------------------------------- 5638C 5639 ISYOPE = 1 5640 IOPTTCME = 1 5641 CALL CCSD_TCMEPK(WORK(KT2AM),1.0D0,ISYOPE,IOPTTCME) 5642C 5643C-------------------------------------------------------------------- 5644C Set up special modified amplitudes needed in the integral loop. 5645C (By doing it this way, we only need one packed vector in core 5646C along with the integral distribution in the delta loop.) 5647C-------------------------------------------------------------------- 5648C 5649 CALL DSCAL(NT2AMX,TWO,WORK(KT2AM),1) 5650 CALL DAXPY(NT2AMX,ONE,WORK(KZ2AM),1,WORK(KT2AM),1) 5651C 5652 KEND1 = KLAMDH 5653 LWRK1 = LWORK - KEND1 5654C 5655C-------------------------------------------------------------------- 5656C Calculate the full MO coefficient matrix for frozen core calcs. 5657C-------------------------------------------------------------------- 5658C 5659 IF (FROIMP) THEN 5660C 5661 KCMO = KEND1 5662 KEND1 = KCMO + NLAMDS 5663 LWKR1 = LWORK - KEND1 5664C 5665 IF (LWRK1 .LT. 0) THEN 5666 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND1 5667 CALL QUIT('Insufficient memory for allocation '// 5668 & 'in MP2_KANEW') 5669 ENDIF 5670C 5671 CALL CMO_ALL(WORK(KCMO),WORK(KEND1),LWRK1) 5672C 5673 ENDIF 5674C 5675C----------------------------------- 5676C Start the loop over integrals. 5677C----------------------------------- 5678C 5679 KENDS2 = KEND1 5680 LWRKS2 = LWRK1 5681C 5682 IF (DIRECT) THEN 5683 IF (HERDIR) THEN 5684 CALL HERDI1(WORK(KEND1),LWRK1,IPRERI) 5685 ELSE 5686 KCCFB1 = KEND1 5687 KINDXB = KCCFB1 + MXPRIM*MXCONT 5688 KEND1 = KINDXB + (8*MXSHEL*MXCONT + 1)/IRAT 5689 LWRK1 = LWORK - KEND1 5690 CALL ERIDI1(KODCL1,KODCL2,KODBC1,KODBC2,KRDBC1,KRDBC2, 5691 * KODPP1,KODPP2,KRDPP1,KRDPP2, 5692 * KFREE,LFREE,KEND1,WORK(KCCFB1),WORK(KINDXB), 5693 * WORK(KEND1),LWRK1,IPRERI) 5694 KEND1 = KFREE 5695 LWRK1 = LFREE 5696 END IF 5697 NTOSYM = 1 5698 ELSE 5699 NTOSYM = NSYM 5700 ENDIF 5701C 5702 KENDSV = KEND1 5703 LWRKSV = LWRK1 5704C 5705 ICDEL1 = 0 5706 DO 100 ISYMD1 = 1,NTOSYM 5707C 5708 IF (DIRECT) THEN 5709 IF (HERDIR) THEN 5710 NTOT = MAXSHL 5711 ELSE 5712 NTOT = MXCALL 5713 END IF 5714 ELSE 5715 NTOT = NBAS(ISYMD1) 5716 ENDIF 5717C 5718 DO 110 ILLL = 1,NTOT 5719C 5720C--------------------------------------------- 5721C If direct calculate the integrals. 5722C--------------------------------------------- 5723C 5724 IF (DIRECT) THEN 5725C 5726 KEND1 = KENDSV 5727 LWRK1 = LWRKSV 5728C 5729c DTIME = SECOND() 5730 IF (HERDIR) THEN 5731 CALL HERDI2(WORK(KEND1),LWRK1,INDEXA,ILLL,NUMDIS, 5732 & IPRERI) 5733 ELSE 5734 CALL ERIDI2(ILLL,INDEXA,NUMDIS,0,0, 5735 * WORK(KODCL1),WORK(KODCL2), 5736 * WORK(KODBC1),WORK(KODBC2), 5737 * WORK(KRDBC1),WORK(KRDBC2), 5738 * WORK(KODPP1),WORK(KODPP2), 5739 * WORK(KRDPP1),WORK(KRDPP2), 5740 * WORK(KCCFB1),WORK(KINDXB), 5741 * WORK(KEND1), LWRK1,IPRERI) 5742 END IF 5743c DTIME = SECOND() - DTIME 5744c TIMHE2 = TIMHE2 + DTIME 5745C 5746 KRECNR = KEND1 5747 KEND1 = KRECNR + (NBUFX(0) - 1)/IRAT + 1 5748 LWRK1 = LWORK - KEND1 5749 IF (LWRK1 .LT. 0) THEN 5750 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND1 5751 CALL QUIT('Insufficient memory for integrals '// 5752 & 'in MP2_KANEW') 5753 END IF 5754C 5755 ELSE 5756 NUMDIS = 1 5757 ENDIF 5758C 5759C----------------------------------------------------- 5760C Loop over number of distributions in disk. 5761C----------------------------------------------------- 5762C 5763 DO 120 IDEL2 = 1,NUMDIS 5764C 5765 IF (DIRECT) THEN 5766 IDEL = INDEXA(IDEL2) 5767CCN ISYMD = ISAO(IDEL) 5768 IF (NOAUXB) THEN 5769 IDUM = 1 5770 CALL IJKAUX(IDEL,IDUM,IDUM,IDUM) 5771 END IF 5772 ISYMD = ISAO(IDEL) 5773 ELSE 5774 IDEL = IBAS(ISYMD1) + ILLL 5775 ISYMD = ISYMD1 5776 ENDIF 5777C 5778C---------------------------------------- 5779C Work space allocation two. 5780C---------------------------------------- 5781C 5782 ISYDIS = MULD2H(ISYMD,ISYMOP) 5783C 5784 KXINT = KEND1 5785 KEND2 = KXINT + NDISAO(ISYDIS) 5786 LWRK2 = LWORK - KEND2 5787C 5788 IF (LWRK2 .LT. 0) THEN 5789 WRITE(LUPRI,*) 'Need : ',KEND2,'Available : ',LWORK 5790 CALL QUIT('Insufficient memory for integrals '// 5791 & 'in MP2_KANEW') 5792 ENDIF 5793C 5794C-------------------------------------------- 5795C Read AO integral distribution. 5796C-------------------------------------------- 5797C 5798 CALL CCRDAO(WORK(KXINT),IDEL,IDEL2,WORK(KEND2),LWRK2, 5799 * WORK(KRECNR),DIRECT) 5800C 5801C------------------------------------------ 5802C Work space allocation three. 5803C------------------------------------------ 5804C 5805 KDSRHF = KEND2 5806 K3OINT = KDSRHF + NDSRHF(ISYMD) 5807 KSCRTI = K3OINT + NMAIJK(ISYDIS) 5808 IF (FROIMP) THEN 5809 KDSFRO = KSCRTI + NT2BCD(ISYDIS) 5810 KOFOIN = KDSFRO + NDSFRO(ISYDIS) 5811 KEND3 = KOFOIN + NOFROO(ISYDIS) 5812 ELSE 5813 KEND3 = KSCRTI + NT2BCD(ISYDIS) 5814 ENDIF 5815 LWRK3 = LWORK - KEND3 5816C 5817 IF (LWRK3 .LT. 0) THEN 5818 WRITE(LUPRI,*) 'Need : ',KEND3,'Available : ',LWORK 5819 CALL QUIT('Insufficient memory for integrals '// 5820 & 'in MP2_KANEW') 5821 ENDIF 5822C 5823C--------------------------------------------------------------------- 5824C Calculate partially backtransformed modified amplitude. 5825C--------------------------------------------------------------------- 5826C 5827 CALL CC_TI(WORK(KSCRTI),ISYMD,WORK(KT2AM),ISYMOP, 5828 * WORK(KLAMDP),1,WORK(KEND3),LWRK3,IDEL,ISYMD) 5829C 5830C---------------------------------------------------------------------- 5831C Transform one index in the integral batch to correlated. 5832C---------------------------------------------------------------------- 5833C 5834 CALL CCTRBT(WORK(KXINT),WORK(KDSRHF),WORK(KLAMDP),ISYMOP, 5835 * WORK(KEND3),LWRK3,ISYDIS) 5836C 5837C------------------------------------------------------------------ 5838C Transform one index in the integral batch to frozen. 5839C------------------------------------------------------------------ 5840C 5841 IF (FROIMP) THEN 5842C 5843 CALL CC_GTOFRO(WORK(KXINT),WORK(KDSFRO),WORK(KCMO), 5844 * WORK(KEND3),LWRK3,ISYDIS) 5845C 5846C-------------------------------------------------------------- 5847C Calculate integral batch (cor fro | cor del). 5848C-------------------------------------------------------------- 5849C 5850 CALL CC_OFROIN(WORK(KDSRHF),WORK(KOFOIN),WORK(KCMO), 5851 * WORK(KEND3),LWRK3,ISYDIS) 5852C 5853C--------------------------------------------------------------- 5854C Calculate direct contribution to frozen block. 5855C--------------------------------------------------------------- 5856C 5857 CALL MP2_ETFRD(WORK(KAFROI),WORK(KOFOIN), 5858 * WORK(KSCRTI),ISYDIS) 5859C 5860C------------------------------------------------------------------------- 5861C Calculate indirect virtual contribution to frozen block. 5862C------------------------------------------------------------------------- 5863C 5864 CALL MP2_EIDV1(WORK(KAFROI),WORK(KDSFRO), 5865 * ZKDIA(NMATIJ(1)+1),WORK(KCMO), 5866 * WORK(KEND3),LWRK3,IDEL,ISYMD) 5867C 5868 CALL MP2_EIDV2(WORK(KAFROI),WORK(KDSFRO), 5869 * ZKDIA(NMATIJ(1)+1),WORK(KCMO), 5870 * WORK(KEND3),LWRK3,IDEL,ISYMD) 5871C 5872C---------------------------------------------------------------------------- 5873C Calculate indirect correlated contribution to frozen block. 5874C---------------------------------------------------------------------------- 5875C 5876 CALL MP2_EIDC1(WORK(KAFROI),WORK(KDSFRO), 5877 * ZKDIA(1),WORK(KCMO),WORK(KEND3), 5878 * LWRK3,IDEL,ISYMD) 5879C 5880 CALL MP2_EIDC2(WORK(KAFROI),WORK(KOFOIN), 5881 * ZKDIA(1),WORK(KCMO),WORK(KEND3), 5882 * LWRK3,IDEL,ISYMD) 5883C 5884C----------------------------------------------------------------------------- 5885C Calculate indirect frozen contribution to both parts of eta. 5886C----------------------------------------------------------------------------- 5887C 5888 KOFFJK = NMATIJ(1) + NMATAB(1) + 2*NT1AMX 5889 * + 2*NT1FRO(1) + 1 5890C 5891 CALL MP2_EIDF1(ETAAI,WORK(KOFOIN),ZKDIA(KOFFJK), 5892 * WORK(KCMO),WORK(KEND3),LWRK3, 5893 * IDEL,ISYMD) 5894C 5895 5896C 5897 CALL MP2_EIDF2(WORK(KAFROI),WORK(KDSFRO), 5898 * ZKDIA(KOFFJK),WORK(KCMO),WORK(KEND3), 5899 * LWRK3,IDEL,ISYMD) 5900C 5901 CALL MP2_EIDF3(ETAAI,WORK(KOFOIN),ZKDIA(KOFFJK), 5902 * WORK(KCMO),WORK(KEND3),LWRK3, 5903 * IDEL,ISYMD) 5904C 5905 CALL MP2_EIDF4(ETAAI,WORK(KDSFRO),ZKDIA(KOFFJK), 5906 * WORK(KCMO),WORK(KEND3),LWRK3, 5907 * IDEL,ISYMD) 5908C 5909 CALL MP2_EIDF5(WORK(KAFROI),WORK(KDSRHF), 5910 * ZKDIA(KOFFJK),WORK(KCMO),WORK(KEND3), 5911 * LWRK3,IDEL,ISYMD) 5912C 5913 CALL MP2_EIDF6(WORK(KAFROI),WORK(KDSFRO), 5914 * ZKDIA(KOFFJK),WORK(KCMO),WORK(KEND3), 5915 * LWRK3,IDEL,ISYMD) 5916C 5917 ENDIF 5918C 5919C------------------------------------------------------------------ 5920C Calculate contributions involving integrals (vv|ov). 5921C------------------------------------------------------------------ 5922C 5923 CALL CCPT_3VT(ETAAI,WORK(KSCRTI),WORK(KDSRHF), 5924 * WORK(KLAMDP),WORK(KEND3),LWRK3,ISYDIS) 5925C 5926 CALL MP2_YTV(ETAAI,ZKDIA(NMATIJ(1)+1),WORK(KDSRHF), 5927 * WORK(KLAMDP),WORK(KEND3),LWRK3,IDEL,ISYMD) 5928C 5929C------------------------------------------------------------------- 5930C Calculate integral batch with three occupied indices. 5931C------------------------------------------------------------------- 5932C 5933 CALL CC_INT3O(WORK(K3OINT),WORK(KDSRHF),WORK(KLAMDP), 5934 * ISYMOP,WORK(KLAMDP),WORK(KEND3),LWRK3, 5935 * IDEL,ISYMD,LUDUM,'DUMMY') 5936C 5937C------------------------------------------------------------------ 5938C Calculate contributions involving integrals (oo|ov). 5939C------------------------------------------------------------------ 5940C 5941 CALL CCPT_3OT(ETAAI,WORK(KSCRTI),WORK(K3OINT), 5942 * ISYDIS) 5943C 5944 CALL MP2_NXY(ETAAI,ZKDIA(1),ZKDIA(NMATIJ(1)+1), 5945 * WORK(K3OINT),WORK(KDSRHF),WORK(KLAMDP), 5946 * WORK(KEND3),LWRK3,IDEL,ISYMD) 5947C 5948 CALL MP2_XTO(ETAAI,ZKDIA(1),WORK(K3OINT), 5949 * WORK(KLAMDP),WORK(KEND3),LWRK3,IDEL,ISYMD) 5950C 5951 120 CONTINUE 5952 110 CONTINUE 5953 100 CONTINUE 5954C 5955C--------------------- 5956C Reorder results. 5957C--------------------- 5958C 5959 CALL CC_ETARE(ETAAI,WORK(KAFROI),WORK(KENDS2),LWRKS2) 5960C 5961C--------------------------------- 5962C Write out result and timing. 5963C--------------------------------- 5964C 5965 IF (IPRINT .GT. 20) THEN 5966C 5967 CALL AROUND('Eta-kappa-0 vector exiting MP2_KANEW') 5968C 5969 DO 20 ISYM = 1,NSYM 5970C 5971 WRITE(LUPRI,*) ' ' 5972 WRITE(LUPRI,444) 'Sub-symmetry block number:', ISYM 5973 WRITE(LUPRI,555) '--------------------------' 5974 444 FORMAT(3X,A26,2X,I1) 5975 555 FORMAT(3X,A25) 5976C 5977 KOFF = IALLAI(ISYM,ISYM) + 1 5978 CALL OUTPUT(ETAAI(KOFF),1,NVIR(ISYM),1,NRHFS(ISYM), 5979 * NVIR(ISYM),NRHFS(ISYM),1,LUPRI) 5980C 5981 IF ((NVIR(ISYM) .EQ. 0) .OR. (NRHFS(ISYM) .EQ. 0)) THEN 5982 WRITE(LUPRI,*) 'This sub-symmetry is empty' 5983 ENDIF 5984C 5985 20 CONTINUE 5986 ENDIF 5987C 5988 IF (IPRINT .GT. 9) THEN 5989 ETAKAN = DDOT(NALLAI(1),ETAAI,1,ETAAI,1) 5990 WRITE(LUPRI,*) ' ' 5991 WRITE(LUPRI,*) 'Norm of Eta-kappa-0:', ETAKAN 5992 ENDIF 5993C 5994 TIMETO = SECOND() - TIMETO 5995C 5996 IF (IPRINT .GT. 3) THEN 5997 WRITE(LUPRI,*) ' ' 5998 WRITE(LUPRI,*) 'MP2 Eta-0(kappa) calculation completed' 5999 WRITE(LUPRI,*) 'Total time used in MP2_KANEW:', TIMETO 6000 ENDIF 6001C 6002 CALL QEXIT('MP2_KANEW') 6003C 6004 RETURN 6005 END 6006C /* Deck mp2_nxy */ 6007 SUBROUTINE MP2_NXY(ETAAI,XMAT,YMAT,X3OINT,DSRHF,XLAMDP,WORK, 6008 * LWORK,IDEL,ISYDEL) 6009C 6010C Written by Asger Halkier 23/3 - 1998. 6011C 6012C Version: 1.0 6013C 6014C Purpose: To calculate the contributions to ETAAI(MP2) 6015C originating from the coulomb part of the "extra 6016C terms" from the diagonal orbital multipliers. 6017C 6018#include "implicit.h" 6019 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0, FOUR = 4.0D0) 6020 DIMENSION ETAAI(*), XMAT(*), YMAT(*), X3OINT(*), DSRHF(*) 6021 DIMENSION XLAMDP(*), WORK(LWORK) 6022#include "priunit.h" 6023#include "ccorb.h" 6024#include "ccsdsym.h" 6025#include "cclr.h" 6026C 6027 CALL QENTER('MP2_NXY') 6028C 6029 ISYMA = ISYDEL 6030 ISYMI = ISYMA 6031C 6032C------------------------------- 6033C Work space allocation one. 6034C------------------------------- 6035C 6036 KAVEC = 1 6037 KEND1 = KAVEC + NVIR(ISYMA) 6038 LWRK1 = LWORK - KEND1 6039C 6040 IF (LWRK1 .LT. 0) THEN 6041 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND1 6042 CALL QUIT('Insufficient work space for allocation in MP2_NXY') 6043 ENDIF 6044C 6045 CALL DZERO(WORK(KAVEC),NVIR(ISYMA)) 6046C 6047C------------------------------------- 6048C Copy vector out of lambda matrix. 6049C------------------------------------- 6050C 6051 KOFF1 = ILMVIR(ISYMA) + IDEL - IBAS(ISYDEL) 6052C 6053 CALL DCOPY(NVIR(ISYMA),XLAMDP(KOFF1),NBAS(ISYDEL),WORK(KAVEC),1) 6054C 6055C---------------------------------------------- 6056C X- and Y- matrices are totally symmetric. 6057C---------------------------------------------- 6058C 6059 ISYMKL = 1 6060 ISYMCD = 1 6061 ISALBE = ISYMCD 6062C 6063 DO 100 I = 1,NRHF(ISYMI) 6064C 6065C----------------------------------------- 6066C Calculate contribution from XMAT. 6067C----------------------------------------- 6068C 6069 KOFF2 = IMAIJK(ISYMKL,ISYMI) + NMATIJ(ISYMKL)*(I - 1) + 1 6070 KOFF3 = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + 1 6071C 6072 FACT = DDOT(NMATIJ(ISYMKL),XMAT,1,X3OINT(KOFF2),1) 6073C 6074 CALL DAXPY(NVIR(ISYMA),FOUR*FACT,WORK(KAVEC),1,ETAAI(KOFF3),1) 6075C 6076C---------------------------------- 6077C Work space allocation two. 6078C---------------------------------- 6079C 6080 KAOINT = KEND1 6081 KMOINT = KAOINT + N2BST(ISALBE) 6082 KEND2 = KMOINT + NMATAB(ISYMCD) 6083 LWRK2 = LWORK - KEND2 6084C 6085 IF (LWRK2 .LT. 0) THEN 6086 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND2 6087 CALL QUIT('Insufficient memory for allocation in MP2_NXY') 6088 ENDIF 6089C 6090 CALL DZERO(WORK(KMOINT),NMATAB(ISYMCD)) 6091C 6092C------------------------------------- 6093C Unpack integral distribution. 6094C------------------------------------- 6095C 6096 KOFF4 = IDSRHF(ISALBE,ISYMI) + NNBST(ISALBE)*(I - 1) + 1 6097C 6098 CALL CCSD_SYMSQ(DSRHF(KOFF4),ISALBE,WORK(KAOINT)) 6099C 6100 DO 110 ISYMD = 1,NSYM 6101C 6102 ISYMAL = ISYMD 6103 ISYMC = MULD2H(ISYMD,ISYMCD) 6104 ISYMBE = ISYMC 6105C 6106C--------------------------------------- 6107C Work space allocation three. 6108C--------------------------------------- 6109C 6110 KSCRAO = KEND2 6111 KEND3 = KSCRAO + NBAS(ISYMAL)*NVIR(ISYMC) 6112 LWRK3 = LWORK - KEND3 6113C 6114 IF (LWRK3 .LT. 0) THEN 6115 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND3 6116 CALL QUIT('Insufficient memory for allocation '// 6117 & 'in MP2_NXY') 6118 ENDIF 6119C 6120 CALL DZERO(WORK(KSCRAO),NBAS(ISYMAL)*NVIR(ISYMC)) 6121C 6122C------------------------------------------- 6123C Transform integrals to MO basis. 6124C------------------------------------------- 6125C 6126 KOFF5 = KAOINT + IAODIS(ISYMAL,ISYMBE) 6127 KOFF6 = ILMVIR(ISYMC) + 1 6128C 6129 NTOTAL = MAX(NBAS(ISYMAL),1) 6130 NTOTBE = MAX(NBAS(ISYMBE),1) 6131C 6132 CALL DGEMM('N','N',NBAS(ISYMAL),NVIR(ISYMC),NBAS(ISYMBE), 6133 * ONE,WORK(KOFF5),NTOTAL,XLAMDP(KOFF6),NTOTBE, 6134 * ONE,WORK(KSCRAO),NTOTAL) 6135C 6136 KOFF7 = ILMVIR(ISYMD) + 1 6137 KOFF8 = KMOINT + IMATAB(ISYMD,ISYMC) 6138C 6139 NTOTAL = MAX(NBAS(ISYMAL),1) 6140 NTOTD = MAX(NVIR(ISYMD),1) 6141C 6142 CALL DGEMM('T','N',NVIR(ISYMD),NVIR(ISYMC),NBAS(ISYMAL), 6143 * ONE,XLAMDP(KOFF7),NTOTAL,WORK(KSCRAO),NTOTAL, 6144 * ONE,WORK(KOFF8),NTOTD) 6145C 6146 110 CONTINUE 6147C 6148C------------------------------------------ 6149C Calculate contributions from YMAT. 6150C------------------------------------------ 6151C 6152 FACT = DDOT(NMATAB(ISYMCD),YMAT,1,WORK(KMOINT),1) 6153C 6154 KOFF9 = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + 1 6155C 6156 CALL DAXPY(NVIR(ISYMA),FOUR*FACT,WORK(KAVEC),1,ETAAI(KOFF9),1) 6157C 6158 100 CONTINUE 6159C 6160 CALL QEXIT('MP2_NXY') 6161C 6162 RETURN 6163 END 6164C /* Deck mp2_xto */ 6165 SUBROUTINE MP2_XTO(ETAAI,XTMAT,X3OINT,XLAMDP,WORK, 6166 * LWORK,IDEL,ISYMD) 6167C 6168C Written by Asger Halkier 23/3 - 1998. 6169C 6170C Version: 1.0 6171C 6172C Purpose: To calculate the (oo|ov) contributions to ETAAI(MP2) 6173C originating from the exchange part of the "extra 6174C terms" from the diagonal orbital multipliers. 6175C 6176#include "implicit.h" 6177 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0) 6178 DIMENSION ETAAI(*), XTMAT(*), X3OINT(*), XLAMDP(*), WORK(LWORK) 6179#include "priunit.h" 6180#include "ccorb.h" 6181#include "ccsdsym.h" 6182#include "cclr.h" 6183C 6184 CALL QENTER('MP2_XTO') 6185C 6186 ISYMA = ISYMD 6187 ISYMI = ISYMA 6188 ISYMKL = 1 6189C 6190C------------------------------- 6191C Work space allocation one. 6192C------------------------------- 6193C 6194 KAVEC = 1 6195 KIVEC = KAVEC + NVIR(ISYMA) 6196 KEND1 = KIVEC + NRHF(ISYMI) 6197 LWRK1 = LWORK - KEND1 6198C 6199 IF (LWRK1 .LT. 0) THEN 6200 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND1 6201 CALL QUIT('Insufficient work space for allocation in MP2_XTO') 6202 ENDIF 6203C 6204 CALL DZERO(WORK(KAVEC),NVIR(ISYMA)) 6205 CALL DZERO(WORK(KIVEC),NRHF(ISYMI)) 6206C 6207C------------------------------------- 6208C Copy vector out of lambda matrix. 6209C------------------------------------- 6210C 6211 KOFF1 = ILMVIR(ISYMA) + IDEL - IBAS(ISYMD) 6212C 6213 CALL DCOPY(NVIR(ISYMA),XLAMDP(KOFF1),NBAS(ISYMD),WORK(KAVEC),1) 6214C 6215 DO 100 ISYML = 1,NSYM 6216C 6217 ISYMK = MULD2H(ISYML,ISYMKL) 6218 ISYMIK = MULD2H(ISYMI,ISYMK) 6219C 6220 DO 110 L = 1,NRHF(ISYML) 6221C 6222C-------------------------------------------------------- 6223C Contract integrals with symmetrized X-matrix. 6224C-------------------------------------------------------- 6225C 6226 KOFF2 = IMAIJK(ISYMIK,ISYML) + NMATIJ(ISYMIK)*(L - 1) 6227 * + IMATIJ(ISYMI,ISYMK) + 1 6228 KOFF3 = IMATIJ(ISYMK,ISYML) + NRHF(ISYMK)*(L - 1) + 1 6229C 6230 NTOTI = MAX(NRHF(ISYMI),1) 6231C 6232 CALL DGEMV('N',NRHF(ISYMI),NRHF(ISYMK),ONE,X3OINT(KOFF2), 6233 * NTOTI,XTMAT(KOFF3),1,ONE,WORK(KIVEC),1) 6234C 6235 110 CONTINUE 6236 100 CONTINUE 6237C 6238C----------------------------- 6239C Final storage in result. 6240C----------------------------- 6241C 6242 DO 120 I = 1,NRHF(ISYMI) 6243C 6244 KOFF4 = KIVEC + I - 1 6245 KOFF5 = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + 1 6246C 6247 CALL DAXPY(NVIR(ISYMA),-TWO*WORK(KOFF4),WORK(KAVEC),1, 6248 * ETAAI(KOFF5),1) 6249C 6250 120 CONTINUE 6251C 6252 CALL QEXIT('MP2_XTO') 6253C 6254 RETURN 6255 END 6256C /* Deck mp2_ytv */ 6257 SUBROUTINE MP2_YTV(ETAAI,YTMAT,DSRHF,XLAMDP,WORK, 6258 * LWORK,IDEL,ISYDEL) 6259C 6260C Written by Asger Halkier 23/3 - 1998. 6261C 6262C Version: 1.0 6263C 6264C Purpose: To calculate the (vv|ov) contributions to ETAAI(MP2) 6265C originating from the exchange part of the "extra 6266C terms" from the diagonal orbital multipliers. 6267C 6268#include "implicit.h" 6269 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0) 6270 DIMENSION ETAAI(*), YTMAT(*), DSRHF(*), XLAMDP(*), WORK(LWORK) 6271#include "priunit.h" 6272#include "ccorb.h" 6273#include "ccsdsym.h" 6274#include "cclr.h" 6275C 6276 CALL QENTER('MP2_YTV') 6277C 6278 ISYMC = ISYDEL 6279 ISYMD = ISYMC 6280C 6281C------------------------------- 6282C Work space allocation one. 6283C------------------------------- 6284C 6285 KCVEC = 1 6286 KDVEC = KCVEC + NVIR(ISYMC) 6287 KEND1 = KDVEC + NVIR(ISYMD) 6288 LWRK1 = LWORK - KEND1 6289C 6290 IF (LWRK1 .LT. 0) THEN 6291 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND1 6292 CALL QUIT('Insufficient work space for allocation in MP2_YTV') 6293 ENDIF 6294C 6295 CALL DZERO(WORK(KCVEC),NVIR(ISYMC)) 6296 CALL DZERO(WORK(KDVEC),NVIR(ISYMD)) 6297C 6298C------------------------------------- 6299C Copy vector out of lambda matrix. 6300C------------------------------------- 6301C 6302 KOFF1 = ILMVIR(ISYMC) + IDEL - IBAS(ISYDEL) 6303C 6304 CALL DCOPY(NVIR(ISYMC),XLAMDP(KOFF1),NBAS(ISYDEL),WORK(KCVEC),1) 6305C 6306C---------------------------------------- 6307C Contract with symmetrized Y-matrix. 6308C---------------------------------------- 6309C 6310 KOFF1 = IMATAB(ISYMD,ISYMC) + 1 6311C 6312 NTOTD = MAX(NVIR(ISYMD),1) 6313C 6314 CALL DGEMV('N',NVIR(ISYMD),NVIR(ISYMC),ONE,YTMAT(KOFF1),NTOTD, 6315 * WORK(KCVEC),1,ZERO,WORK(KDVEC),1) 6316C 6317 DO 100 ISYMI = 1,NSYM 6318C 6319 ISYMA = ISYMI 6320 ISYMAL = ISYMA 6321 ISYMBE = ISYMD 6322 ISALBE = MULD2H(ISYMAL,ISYMBE) 6323C 6324C---------------------------------- 6325C Work space allocation two. 6326C---------------------------------- 6327C 6328 KAOINT = KEND1 6329 KSCRAO = KAOINT + N2BST(ISALBE) 6330 KMOINT = KSCRAO + NBAS(ISYMAL)*NVIR(ISYMD) 6331 KEND2 = KMOINT + NVIR(ISYMA)*NVIR(ISYMD) 6332 LWRK2 = LWORK - KEND2 6333C 6334 IF (LWRK2 .LT. 0) THEN 6335 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND2 6336 CALL QUIT('Insufficient work space for allocation '// 6337 & 'in MP2_YTV') 6338 ENDIF 6339C 6340 CALL DZERO(WORK(KSCRAO),NBAS(ISYMAL)*NVIR(ISYMD)) 6341 CALL DZERO(WORK(KMOINT),NVIR(ISYMA)*NVIR(ISYMD)) 6342C 6343 DO 110 I = 1,NRHF(ISYMI) 6344C 6345C---------------------------------------- 6346C Unpack integral distribution. 6347C---------------------------------------- 6348C 6349 KOFF2 = IDSRHF(ISALBE,ISYMI) + NNBST(ISALBE)*(I - 1) + 1 6350C 6351 CALL CCSD_SYMSQ(DSRHF(KOFF2),ISALBE,WORK(KAOINT)) 6352C 6353C------------------------------------------- 6354C Transform integrals to MO basis. 6355C------------------------------------------- 6356C 6357 KOFF3 = KAOINT + IAODIS(ISYMAL,ISYMBE) 6358 KOFF4 = ILMVIR(ISYMD) + 1 6359C 6360 NTOTAL = MAX(NBAS(ISYMAL),1) 6361 NTOTBE = MAX(NBAS(ISYMBE),1) 6362C 6363 CALL DGEMM('N','N',NBAS(ISYMAL),NVIR(ISYMD),NBAS(ISYMBE), 6364 * ONE,WORK(KOFF3),NTOTAL,XLAMDP(KOFF4),NTOTBE, 6365 * ZERO,WORK(KSCRAO),NTOTAL) 6366C 6367 KOFF5 = ILMVIR(ISYMA) + 1 6368C 6369 NTOTAL = MAX(NBAS(ISYMAL),1) 6370 NTOTA = MAX(NVIR(ISYMA),1) 6371C 6372 CALL DGEMM('T','N',NVIR(ISYMA),NVIR(ISYMD),NBAS(ISYMAL), 6373 * ONE,XLAMDP(KOFF5),NTOTAL,WORK(KSCRAO),NTOTAL, 6374 * ZERO,WORK(KMOINT),NTOTA) 6375C 6376 KOFF6 = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + 1 6377C 6378 NTOTA = MAX(NVIR(ISYMA),1) 6379C 6380 CALL DGEMV('N',NVIR(ISYMA),NVIR(ISYMD),-TWO,WORK(KMOINT), 6381 * NTOTA,WORK(KDVEC),1,ONE,ETAAI(KOFF6),1) 6382C 6383 110 CONTINUE 6384 100 CONTINUE 6385C 6386 CALL QEXIT('MP2_YTV') 6387C 6388 RETURN 6389 END 6390C /* Deck cc_kanew */ 6391 SUBROUTINE CC_KANEW(ETAAI,ZKDIA,WORK,LWORK) 6392C 6393C Written by Asger Halkier 10/8 - 1998 6394C 6395C Version: 1.0 6396C 6397C Purpose: To calculate the contributions to the right hand 6398C side ETAAI from the diagonal multiplier blocks for 6399C the equations for kappa-bar-0. This includes the 6400C frozen core contributions. 6401C 6402#include "implicit.h" 6403#include "priunit.h" 6404#include "maxash.h" 6405#include "maxorb.h" 6406#include "mxcent.h" 6407#include "aovec.h" 6408#include "iratdef.h" 6409 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0) 6410 DIMENSION INDEXA(MXCORB_CC) 6411 DIMENSION ETAAI(*), ZKDIA(*), WORK(LWORK) 6412#include "ccorb.h" 6413#include "ccisao.h" 6414#include "r12int.h" 6415#include "blocks.h" 6416#include "ccsdinp.h" 6417#include "ccsdsym.h" 6418#include "ccsdio.h" 6419#include "distcl.h" 6420#include "cbieri.h" 6421#include "eritap.h" 6422#include "cclr.h" 6423#include "ccfro.h" 6424C 6425 CALL QENTER('CC_KANEW') 6426C 6427 CALL HEADER('Calculating diagonal contributions to eta-bar-0',-1) 6428C 6429 TIMETO = ZERO 6430 TIMETO = SECOND() 6431C 6432 ISYMOP = 1 6433C 6434C------------------------------- 6435C Work space allocation one. 6436C------------------------------- 6437C 6438 KAFROI = 1 6439 KLAMDP = KAFROI + NT1FRO(1) 6440 KLAMDH = KLAMDP + NLAMDT 6441 KT1AM = KLAMDH + NLAMDT 6442 KEND1 = KT1AM + NT1AMX 6443 LWRK1 = LWORK - KEND1 6444C 6445 IF (LWRK1 .LT. 0) THEN 6446 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND1 6447 CALL QUIT('Insufficient memory for first allocation '// 6448 & 'in CC_KANEW') 6449 ENDIF 6450C 6451 KOFFAI = 2*NT1AMX + NMATIJ(1) + NMATAB(1) + 1 6452 CALL DZERO(WORK(KAFROI),NT1FRO(1)) 6453 CALL DCOPY(NT1FRO(1),ZKDIA(KOFFAI),1,WORK(KAFROI),1) 6454 CALL DZERO(ZKDIA(KOFFAI),2*NT1FRO(1)) 6455 CALL DZERO(WORK(KT1AM),NT1AMX) 6456C 6457C---------------------------------- 6458C Calculate the lambda matrices. 6459C---------------------------------- 6460C 6461 CALL LAMMAT(WORK(KLAMDP),WORK(KLAMDH),WORK(KT1AM),WORK(KEND1), 6462 * LWRK1) 6463C 6464 KEND1 = KLAMDH 6465 LWRK1 = LWORK - KEND1 6466C 6467C-------------------------------------------------------------------- 6468C Calculate the full MO coefficient matrix for frozen core calcs. 6469C-------------------------------------------------------------------- 6470C 6471 IF (FROIMP) THEN 6472C 6473 KCMO = KEND1 6474 KEND1 = KCMO + NLAMDS 6475 LWKR1 = LWORK - KEND1 6476C 6477 IF (LWRK1 .LT. 0) THEN 6478 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND1 6479 CALL QUIT('Insufficient memory for allocation in CC_KANEW') 6480 ENDIF 6481C 6482 CALL CMO_ALL(WORK(KCMO),WORK(KEND1),LWRK1) 6483C 6484 ENDIF 6485C 6486C----------------------------------- 6487C Start the loop over integrals. 6488C----------------------------------- 6489C 6490 KENDS2 = KEND1 6491 LWRKS2 = LWRK1 6492C 6493 IF (DIRECT) THEN 6494 IF (HERDIR) THEN 6495 CALL HERDI1(WORK(KEND1),LWRK1,IPRERI) 6496 ELSE 6497 KCCFB1 = KEND1 6498 KINDXB = KCCFB1 + MXPRIM*MXCONT 6499 KEND1 = KINDXB + (8*MXSHEL*MXCONT + 1)/IRAT 6500 LWRK1 = LWORK - KEND1 6501 CALL ERIDI1(KODCL1,KODCL2,KODBC1,KODBC2,KRDBC1,KRDBC2, 6502 * KODPP1,KODPP2,KRDPP1,KRDPP2, 6503 * KFREE,LFREE,KEND1,WORK(KCCFB1),WORK(KINDXB), 6504 * WORK(KEND1),LWRK1,IPRERI) 6505 KEND1 = KFREE 6506 LWRK1 = LFREE 6507 END IF 6508 NTOSYM = 1 6509 ELSE 6510 NTOSYM = NSYM 6511 ENDIF 6512C 6513 KENDSV = KEND1 6514 LWRKSV = LWRK1 6515C 6516 ICDEL1 = 0 6517 DO 100 ISYMD1 = 1,NTOSYM 6518C 6519 IF (DIRECT) THEN 6520 IF (HERDIR) THEN 6521 NTOT = MAXSHL 6522 ELSE 6523 NTOT = MXCALL 6524 END IF 6525 ELSE 6526 NTOT = NBAS(ISYMD1) 6527 ENDIF 6528C 6529 DO 110 ILLL = 1,NTOT 6530C 6531C--------------------------------------------- 6532C If direct calculate the integrals. 6533C--------------------------------------------- 6534C 6535 IF (DIRECT) THEN 6536C 6537 KEND1 = KENDSV 6538 LWRK1 = LWRKSV 6539C 6540c DTIME = SECOND() 6541 IF (HERDIR) THEN 6542 CALL HERDI2(WORK(KEND1),LWRK1,INDEXA,ILLL,NUMDIS, 6543 & IPRERI) 6544 ELSE 6545 CALL ERIDI2(ILLL,INDEXA,NUMDIS,0,0, 6546 * WORK(KODCL1),WORK(KODCL2), 6547 * WORK(KODBC1),WORK(KODBC2), 6548 * WORK(KRDBC1),WORK(KRDBC2), 6549 * WORK(KODPP1),WORK(KODPP2), 6550 * WORK(KRDPP1),WORK(KRDPP2), 6551 * WORK(KCCFB1),WORK(KINDXB), 6552 * WORK(KEND1), LWRK1,IPRERI) 6553 END IF 6554c DTIME = SECOND() - DTIME 6555c TIMHE2 = TIMHE2 + DTIME 6556C 6557 KRECNR = KEND1 6558 KEND1 = KRECNR + (NBUFX(0) - 1)/IRAT + 1 6559 LWRK1 = LWORK - KEND1 6560 IF (LWRK1 .LT. 0) THEN 6561 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND1 6562 CALL QUIT('Insufficient memory for integrals '// 6563 & 'in CC_KANEW') 6564 END IF 6565C 6566 ELSE 6567 NUMDIS = 1 6568 ENDIF 6569C 6570C----------------------------------------------------- 6571C Loop over number of distributions in disk. 6572C----------------------------------------------------- 6573C 6574 DO 120 IDEL2 = 1,NUMDIS 6575C 6576 IF (DIRECT) THEN 6577 IDEL = INDEXA(IDEL2) 6578CCN ISYMD = ISAO(IDEL) 6579 IF (NOAUXB) THEN 6580 IDUM = 1 6581 CALL IJKAUX(IDEL,IDUM,IDUM,IDUM) 6582 END IF 6583 ISYMD = ISAO(IDEL) 6584 ELSE 6585 IDEL = IBAS(ISYMD1) + ILLL 6586 ISYMD = ISYMD1 6587 ENDIF 6588C 6589C---------------------------------------- 6590C Work space allocation two. 6591C---------------------------------------- 6592C 6593 ISYDIS = MULD2H(ISYMD,ISYMOP) 6594C 6595 KXINT = KEND1 6596 KEND2 = KXINT + NDISAO(ISYDIS) 6597 LWRK2 = LWORK - KEND2 6598C 6599 IF (LWRK2 .LT. 0) THEN 6600 WRITE(LUPRI,*) 'Need : ',KEND2,'Available : ',LWORK 6601 CALL QUIT('Insufficient memory for integrals '// 6602 & 'in CC_KANEW') 6603 ENDIF 6604C 6605C-------------------------------------------- 6606C Read AO integral distribution. 6607C-------------------------------------------- 6608C 6609 CALL CCRDAO(WORK(KXINT),IDEL,IDEL2,WORK(KEND2),LWRK2, 6610 * WORK(KRECNR),DIRECT) 6611C 6612C------------------------------------------ 6613C Work space allocation three. 6614C------------------------------------------ 6615C 6616 KDSRHF = KEND2 6617 K3OINT = KDSRHF + NDSRHF(ISYMD) 6618 IF (FROIMP) THEN 6619 KDSFRO = K3OINT + NMAIJK(ISYDIS) 6620 KOFOIN = KDSFRO + NDSFRO(ISYDIS) 6621 KEND3 = KOFOIN + NOFROO(ISYDIS) 6622 ELSE 6623 KEND3 = K3OINT + NMAIJK(ISYDIS) 6624 ENDIF 6625 LWRK3 = LWORK - KEND3 6626C 6627 IF (LWRK3 .LT. 0) THEN 6628 WRITE(LUPRI,*) 'Need : ',KEND3,'Available : ',LWORK 6629 CALL QUIT('Insufficient memory for integrals '// 6630 & 'in CC_KANEW') 6631 ENDIF 6632C 6633C---------------------------------------------------------------------- 6634C Transform one index in the integral batch to correlated. 6635C---------------------------------------------------------------------- 6636C 6637 CALL CCTRBT(WORK(KXINT),WORK(KDSRHF),WORK(KLAMDP),ISYMOP, 6638 * WORK(KEND3),LWRK3,ISYDIS) 6639C 6640C------------------------------------------------------------------ 6641C Transform one index in the integral batch to frozen. 6642C------------------------------------------------------------------ 6643C 6644 IF (FROIMP) THEN 6645C 6646 CALL CC_GTOFRO(WORK(KXINT),WORK(KDSFRO),WORK(KCMO), 6647 * WORK(KEND3),LWRK3,ISYDIS) 6648C 6649C-------------------------------------------------------------- 6650C Calculate integral batch (cor fro | cor del). 6651C-------------------------------------------------------------- 6652C 6653 CALL CC_OFROIN(WORK(KDSRHF),WORK(KOFOIN),WORK(KCMO), 6654 * WORK(KEND3),LWRK3,ISYDIS) 6655C 6656C------------------------------------------------------------------------- 6657C Calculate indirect virtual contribution to frozen block. 6658C------------------------------------------------------------------------- 6659C 6660 CALL MP2_EIDV1(WORK(KAFROI),WORK(KDSFRO), 6661 * ZKDIA(NMATIJ(1)+1),WORK(KCMO), 6662 * WORK(KEND3),LWRK3,IDEL,ISYMD) 6663C 6664 CALL MP2_EIDV2(WORK(KAFROI),WORK(KDSFRO), 6665 * ZKDIA(NMATIJ(1)+1),WORK(KCMO), 6666 * WORK(KEND3),LWRK3,IDEL,ISYMD) 6667C 6668C---------------------------------------------------------------------------- 6669C Calculate indirect correlated contribution to frozen block. 6670C---------------------------------------------------------------------------- 6671C 6672 CALL MP2_EIDC1(WORK(KAFROI),WORK(KDSFRO), 6673 * ZKDIA(1),WORK(KCMO),WORK(KEND3), 6674 * LWRK3,IDEL,ISYMD) 6675C 6676 CALL MP2_EIDC2(WORK(KAFROI),WORK(KOFOIN), 6677 * ZKDIA(1),WORK(KCMO),WORK(KEND3), 6678 * LWRK3,IDEL,ISYMD) 6679C 6680C----------------------------------------------------------------------------- 6681C Calculate indirect frozen contribution to both parts of eta. 6682C----------------------------------------------------------------------------- 6683C 6684 KOFFJK = NMATIJ(1) + NMATAB(1) + 2*NT1AMX 6685 * + 2*NT1FRO(1) + 1 6686C 6687 CALL MP2_EIDF1(ETAAI,WORK(KOFOIN),ZKDIA(KOFFJK), 6688 * WORK(KCMO),WORK(KEND3),LWRK3, 6689 * IDEL,ISYMD) 6690C 6691 CALL MP2_EIDF2(WORK(KAFROI),WORK(KDSFRO), 6692 * ZKDIA(KOFFJK),WORK(KCMO),WORK(KEND3), 6693 * LWRK3,IDEL,ISYMD) 6694C 6695 CALL MP2_EIDF3(ETAAI,WORK(KOFOIN),ZKDIA(KOFFJK), 6696 * WORK(KCMO),WORK(KEND3),LWRK3, 6697 * IDEL,ISYMD) 6698C 6699 CALL MP2_EIDF4(ETAAI,WORK(KDSFRO),ZKDIA(KOFFJK), 6700 * WORK(KCMO),WORK(KEND3),LWRK3, 6701 * IDEL,ISYMD) 6702C 6703 CALL MP2_EIDF5(WORK(KAFROI),WORK(KDSRHF), 6704 * ZKDIA(KOFFJK),WORK(KCMO),WORK(KEND3), 6705 * LWRK3,IDEL,ISYMD) 6706C 6707 CALL MP2_EIDF6(WORK(KAFROI),WORK(KDSFRO), 6708 * ZKDIA(KOFFJK),WORK(KCMO),WORK(KEND3), 6709 * LWRK3,IDEL,ISYMD) 6710C 6711 ENDIF 6712C 6713C------------------------------------------------------------------ 6714C Calculate contributions involving integrals (vv|ov). 6715C------------------------------------------------------------------ 6716C 6717 CALL MP2_YTV(ETAAI,ZKDIA(NMATIJ(1)+1),WORK(KDSRHF), 6718 * WORK(KLAMDP),WORK(KEND3),LWRK3,IDEL,ISYMD) 6719C 6720C------------------------------------------------------------------- 6721C Calculate integral batch with three occupied indices. 6722C------------------------------------------------------------------- 6723C 6724 CALL CC_INT3O(WORK(K3OINT),WORK(KDSRHF),WORK(KLAMDP), 6725 * ISYMOP,WORK(KLAMDP),WORK(KEND3),LWRK3, 6726 * IDEL,ISYMD,LUDUM,'DUMMY') 6727C 6728C------------------------------------------------------------------ 6729C Calculate contributions involving integrals (oo|ov). 6730C------------------------------------------------------------------ 6731C 6732 CALL MP2_NXY(ETAAI,ZKDIA(1),ZKDIA(NMATIJ(1)+1), 6733 * WORK(K3OINT),WORK(KDSRHF),WORK(KLAMDP), 6734 * WORK(KEND3),LWRK3,IDEL,ISYMD) 6735C 6736 CALL MP2_XTO(ETAAI,ZKDIA(1),WORK(K3OINT), 6737 * WORK(KLAMDP),WORK(KEND3),LWRK3,IDEL,ISYMD) 6738C 6739 120 CONTINUE 6740 110 CONTINUE 6741 100 CONTINUE 6742C 6743C--------------------- 6744C Reorder results. 6745C--------------------- 6746C 6747 CALL CC_ETARE(ETAAI,WORK(KAFROI),WORK(KENDS2),LWRKS2) 6748C 6749C--------------------------------- 6750C Write out result and timing. 6751C--------------------------------- 6752C 6753 IF (IPRINT .GT. 20) THEN 6754C 6755 CALL AROUND('Eta-bar-0-ai vector exiting CC_KANEW') 6756C 6757 DO 20 ISYM = 1,NSYM 6758C 6759 WRITE(LUPRI,*) ' ' 6760 WRITE(LUPRI,444) 'Sub-symmetry block number:', ISYM 6761 WRITE(LUPRI,555) '--------------------------' 6762 444 FORMAT(3X,A26,2X,I1) 6763 555 FORMAT(3X,A25) 6764C 6765 KOFF = IALLAI(ISYM,ISYM) + 1 6766 CALL OUTPUT(ETAAI(KOFF),1,NVIR(ISYM),1,NRHFS(ISYM), 6767 * NVIR(ISYM),NRHFS(ISYM),1,LUPRI) 6768C 6769 IF ((NVIR(ISYM) .EQ. 0) .OR. (NRHFS(ISYM) .EQ. 0)) THEN 6770 WRITE(LUPRI,*) 'This sub-symmetry is empty' 6771 ENDIF 6772C 6773 20 CONTINUE 6774 ENDIF 6775C 6776 IF (IPRINT .GT. 9) THEN 6777 ETAKAN = DDOT(NALLAI(1),ETAAI,1,ETAAI,1) 6778 WRITE(LUPRI,*) ' ' 6779 WRITE(LUPRI,*) 'Norm of Eta-bar-0:', ETAKAN 6780 ENDIF 6781C 6782 TIMETO = SECOND() - TIMETO 6783C 6784 IF (IPRINT .GT. 3) THEN 6785 WRITE(LUPRI,*) ' ' 6786 WRITE(LUPRI,*) 'CCSD Eta-bar-0 calculation completed' 6787 WRITE(LUPRI,*) 'Total time used in CC_KANEW:', TIMETO 6788 ENDIF 6789C 6790 CALL QEXIT('CC_KANEW') 6791C 6792 RETURN 6793 END 6794C /* Deck cc_2eexp */ 6795 SUBROUTINE CC_2EEXP(WORK,LWORK,IOPREL) 6796C 6797C Written by Asger Halkier january 1999. 6798C 6799C Version: 1.0 6800C 6801C Purpose: To calculate the contribution to the gradient 6802C from the derivative two-electron integrals 6803C using the Coupled Cluster density matrices and 6804C the new integral program! 6805C 6806C Current models: CCS, MP2, CCD, CCSD 6807C 6808C CC2 (without frozen core) by A. Halkier & S. Coriani 20/01-2000. 6809C 6810#include "implicit.h" 6811#include "priunit.h" 6812#include "maxash.h" 6813#include "maxorb.h" 6814#include "mxcent.h" 6815#include "maxaqn.h" 6816#include "aovec.h" 6817#include "iratdef.h" 6818#include "nuclei.h" 6819#include "symmet.h" 6820#include "chrnos.h" 6821#include "eridst.h" 6822 PARAMETER (ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, TWO = 2.0D0) 6823 PARAMETER (FOUR = 4.0D0) 6824 LOGICAL SAVDIR, LEX, SAVHER, OLDDX 6825 DIMENSION INDEXA(MXCORB_CC) 6826 DIMENSION IADR(MXCORB_CC,MXDIST) 6827 DIMENSION WORK(LWORK) 6828 CHARACTER*8 LABEL 6829 CHARACTER*10 MODEL 6830#include "ccorb.h" 6831#include "infind.h" 6832#include "blocks.h" 6833#include "ccfield.h" 6834#include "ccfop.h" 6835#include "ccsdinp.h" 6836#include "ccsdsym.h" 6837#include "ccsdio.h" 6838#include "distcl.h" 6839#include "cbieri.h" 6840#include "eritap.h" 6841#include "cclr.h" 6842#include "ccfro.h" 6843#include "drw2el.h" 6844C 6845 CALL QENTER('CC_2EEXP') 6846C 6847C------------------------------ 6848C Initialization of result. 6849C------------------------------ 6850C 6851 IF (IPRINT .GT. 9) CALL AROUND('Entering CC_2EEXP') 6852 CALL FLSHFO(LUPRI) 6853 RE2DAR = ZERO 6854 IF (IOPREL .EQ. 1) RELCO1 = WORK(1) 6855C 6856C----------------------------------------- 6857C Initialization of timing parameters. 6858C----------------------------------------- 6859C 6860 TIMTOT = ZERO 6861 TIMTOT = SECOND() 6862 TIMDEN = ZERO 6863 TIMDAO = ZERO 6864 TIRDAO = ZERO 6865 TIMHE2 = ZERO 6866 TIMONE = ZERO 6867 TIMONE = SECOND() 6868C 6869C---------------------------------------------------- 6870C Both zeta- and t-vectors are totally symmetric. 6871C---------------------------------------------------- 6872C 6873 ISYMTR = 1 6874 ISYMOP = 1 6875C 6876 IF (CC2) THEN 6877C 6878C 6879C----------------------------------- 6880C Initial work space allocation. 6881C----------------------------------- 6882C 6883 N2BSTM = 0 6884 DO ISYM = 1, NSYM 6885 N2BSTM = MAX(N2BSTM,N2BST(ISYM)) 6886 END DO 6887 6888 KFCKEF = 1 6889 KAODEN = KFCKEF + N2BST(1) 6890 KCMO = KAODEN + N2BSTM 6891 KT2AM = KCMO + NLAMDS 6892 KZ2AM = KT2AM + NT2AMX 6893 KLAMDP = KZ2AM + NT2SQ(1) 6894 KLAMDH = KLAMDP + NLAMDT 6895 KT1AM = KLAMDH + NLAMDT 6896 KZ1AM = KT1AM + NT1AMX 6897 KEND1 = KZ1AM + NT1AMX 6898 LWRK1 = LWORK - KEND1 6899C 6900 IF (LWRK1 .LT. 0) THEN 6901 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND1 6902 CALL QUIT( 6903 * 'Insufficient core for initial allocation in CC_2EEXP') 6904 ENDIF 6905C 6906C------------------------------------------------------------- 6907C Read MO-coefficients from interface file and reorder. 6908C------------------------------------------------------------- 6909C 6910 LUSIFC = -993 6911 CALL GPOPEN(LUSIFC,'SIRIFC','OLD',' ','UNFORMATTED',IDUMMY, 6912 & .FALSE.) 6913 REWIND LUSIFC 6914 CALL MOLLAB('TRCCINT ',LUSIFC,LUPRI) 6915 READ (LUSIFC) 6916 READ (LUSIFC) 6917 READ (LUSIFC) (WORK(KCMO+I-1), I=1,NLAMDS) 6918 CALL GPCLOSE(LUSIFC,'KEEP') 6919C 6920 CALL CMO_REORDER(WORK(KCMO),WORK(KEND1),LWRK1) 6921C 6922C------------------------------------------- 6923C Read zero'th order zeta amplitudes. 6924C------------------------------------------- 6925C 6926 IOPT = 3 6927 CALL CC_RDRSP('L0',0,1,IOPT,MODEL,WORK(KZ1AM),WORK(KZ2AM)) 6928C 6929C----------------------------------- 6930C Square up zeta2 amplitudes. 6931C----------------------------------- 6932C 6933 CALL DCOPY(NT2AMX,WORK(KZ2AM),1,WORK(KT2AM),1) 6934 CALL CC_T2SQ(WORK(KT2AM),WORK(KZ2AM),1) 6935C 6936C---------------------------------------------- 6937C Read zero'th order cluster amplitudes. 6938C---------------------------------------------- 6939C 6940 IOPT = 3 6941 CALL CC_RDRSP('R0',0,1,IOPT,MODEL,WORK(KT1AM),WORK(KT2AM)) 6942C 6943C------------------------------------- 6944C Calculate the lambda matrices. 6945C------------------------------------- 6946C 6947 CALL LAMMAT(WORK(KLAMDP),WORK(KLAMDH),WORK(KT1AM),WORK(KEND1), 6948 * LWRK1) 6949C 6950C 6951C----------------------------------------------- 6952C Set up 2C-E of cluster amplitudes and save 6953C in KT2AM, as we only need T(2c-e) below. 6954C----------------------------------------------- 6955C 6956 ISYOPE = 1 6957 IOPTTCME = 1 6958 CALL CCSD_TCMEPK(WORK(KT2AM),1.0D0,ISYOPE,IOPTTCME) 6959 KT2AMT = KT2AM !for safety 6960C 6961C------------------------------- 6962C Work space allocation one. 6963C Note that D(ai) = ZETA(ai) 6964C and both D(ia) and h(ia) 6965C are stored transposed! 6966C------------------------------- 6967C 6968 LENBAR = 2*NT1AMX + NMATIJ(1) + NMATAB(1) + 2*NT1FRO(1) 6969 * + 2*NCOFRO(1) 6970C 6971 KONEAI = KZ1AM 6972 KONEAB = KONEAI + NT1AMX 6973 KONEIJ = KONEAB + NMATAB(1) 6974 KONEIA = KONEIJ + NMATIJ(1) 6975 KONINT = KONEIA + NT1AMX 6976 KKABAR = KONINT + N2BST(ISYMOP) 6977 KDHFAO = KKABAR + LENBAR 6978 KKABAO = KDHFAO + N2BST(1) 6979 KINTIJ = KKABAO + N2BST(1) 6980 KEND1 = KINTIJ + NMATIJ(1) 6981 LWRK1 = LWORK - KEND1 6982C 6983 IF (LWRK1 .LT. 0) THEN 6984 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND1 6985 CALL QUIT('Insufficient core for allocation 1 in CC_2EEXP') 6986 ENDIF 6987C 6988C 6989C------------------------------------------------------ 6990C Initialize remaining one electron density arrays. 6991C------------------------------------------------------ 6992C 6993 CALL DZERO(WORK(KONEAB),NMATAB(1)) 6994 CALL DZERO(WORK(KONEIJ),NMATIJ(1)) 6995 CALL DZERO(WORK(KONEIA),NT1AMX) 6996C 6997C-------------------------------------------------------- 6998C Construct remaining blocks of one electron density. 6999C-------------------------------------------------------- 7000C 7001 CALL DZERO(WORK(KINTIJ),NMATIJ(1)) 7002 CALL DIJGEN(WORK(KONEIJ),WORK(KINTIJ)) 7003 CALL DIAGEN(WORK(KONEIA),WORK(KT2AMT),WORK(KONEAI)) 7004C 7005C 7006C-------------------------------------------------------- 7007C Backtransform the one electron density to AO-basis. 7008C-------------------------------------------------------- 7009C 7010 CALL DZERO(WORK(KAODEN),N2BST(1)) 7011C 7012 ISDEN = 1 7013 CALL CC_DENAO(WORK(KAODEN),ISDEN,WORK(KONEAI),WORK(KONEAB), 7014 * WORK(KONEIJ),WORK(KONEIA),ISDEN,WORK(KLAMDP),1, 7015 * WORK(KLAMDH),1,WORK(KEND1),LWRK1) 7016C 7017C---------------------------------------------- 7018C Read orbital relaxation vector from disc. 7019C---------------------------------------------- 7020C 7021 CALL DZERO(WORK(KKABAR),LENBAR) 7022C 7023 LUCCK = -987 7024 CALL GPOPEN(LUCCK,'CCKABAR0','UNKNOWN',' ','UNFORMATTED', 7025 * IDUMMY,.FALSE.) 7026 REWIND(LUCCK) 7027 READ(LUCCK) (WORK(KKABAR+I-1), I = 1,LENBAR) 7028 CALL GPCLOSE(LUCCK,'KEEP') 7029 7030C 7031C-------------------------------------------------------------- 7032C Calculate ao-transformed zeta-kappa-bar-0 and HF density. 7033C-------------------------------------------------------------- 7034C 7035 KOFDIJ = KKABAR 7036 KOFDAB = KOFDIJ + NMATIJ(1) 7037 KOFDAI = KOFDAB + NMATAB(1) 7038 KOFDIA = KOFDAI + NT1AMX 7039C 7040 ISDEN = 1 7041 CALL DZERO(WORK(KKABAO),N2BST(1)) 7042 CALL CC_DENAO(WORK(KKABAO),ISDEN,WORK(KOFDAI),WORK(KOFDAB), 7043 * WORK(KOFDIJ),WORK(KOFDIA),ISDEN,WORK(KCMO),1, 7044 * WORK(KCMO),1,WORK(KEND1),LWRK1) 7045C 7046 CALL CCS_D1AO(WORK(KDHFAO),WORK(KEND1),LWRK1) 7047 IF (FROIMP .OR. FROEXP) THEN 7048 MODEL = 'DUMMY' 7049 CALL CC_FCD1AO(WORK(KDHFAO),WORK(KEND1),LWRK1,MODEL) 7050 ENDIF 7051C 7052C------------------------------------------------------------ 7053C Add orbital relaxation for effective density matrix. 7054C------------------------------------------------------------ 7055C 7056 CALL DAXPY(N2BST(1),ONE,WORK(KKABAO),1,WORK(KAODEN),1) 7057C 7058 ELSE IF (CCSD) THEN 7059C 7060C----------------------------------- 7061C Initial work space allocation. 7062C----------------------------------- 7063C 7064 N2BSTM = 0 7065 DO ISYM = 1, NSYM 7066 N2BSTM = MAX(N2BSTM,N2BST(ISYM)) 7067 END DO 7068 7069 KFCKEF = 1 7070 KAODSY = KFCKEF + N2BST(1) 7071 KAODEN = KAODSY + N2BSTM 7072 KZ2AM = KAODEN + N2BSTM 7073 KT2AM = KZ2AM + NT2SQ(1) 7074 KT2AMT = KT2AM + NT2AMX 7075 KLAMDP = KT2AMT + NT2AMX 7076 KLAMDH = KLAMDP + NLAMDT 7077 KT1AM = KLAMDH + NLAMDT 7078 KZ1AM = KT1AM + NT1AMX 7079 KEND1 = KZ1AM + NT1AMX 7080 LWRK1 = LWORK - KEND1 7081C 7082 IF (LWRK1 .LT. 0) THEN 7083 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND1 7084 CALL QUIT( 7085 * 'Insufficient core for first allocation in CC_2EEXP') 7086 ENDIF 7087C 7088C---------------------------------------- 7089C Read zero'th order zeta amplitudes. 7090C---------------------------------------- 7091C 7092 IOPT = 3 7093 CALL CC_RDRSP('L0',0,1,IOPT,MODEL,WORK(KZ1AM),WORK(KZ2AM)) 7094C 7095C-------------------------------- 7096C Square up zeta2 amplitudes. 7097C-------------------------------- 7098C 7099 CALL DCOPY(NT2AMX,WORK(KZ2AM),1,WORK(KT2AM),1) 7100 CALL CC_T2SQ(WORK(KT2AM),WORK(KZ2AM),1) 7101C 7102C------------------------------------------- 7103C Read zero'th order cluster amplitudes. 7104C------------------------------------------- 7105C 7106 IOPT = 3 7107 CALL CC_RDRSP('R0',0,1,IOPT,MODEL,WORK(KT1AM),WORK(KT2AM)) 7108C 7109C------------------------------------------------ 7110C Zero out single vectors in CCD-calculation. 7111C------------------------------------------------ 7112C 7113 IF (CCD) THEN 7114 CALL DZERO(WORK(KT1AM),NT1AMX) 7115 CALL DZERO(WORK(KZ1AM),NT1AMX) 7116 ENDIF 7117C 7118C---------------------------------- 7119C Calculate the lambda matrices. 7120C---------------------------------- 7121C 7122 CALL LAMMAT(WORK(KLAMDP),WORK(KLAMDH),WORK(KT1AM),WORK(KEND1), 7123 * LWRK1) 7124C 7125C--------------------------------------- 7126C Set up 2C-E of cluster amplitudes. 7127C--------------------------------------- 7128C 7129 ISYOPE = 1 7130C 7131 CALL DCOPY(NT2AMX,WORK(KT2AM),1,WORK(KT2AMT),1) 7132 IOPTTCME = 1 7133 CALL CCSD_TCMEPK(WORK(KT2AMT),1.0D0,ISYOPE,IOPTTCME) 7134C 7135C------------------------------- 7136C Work space allocation one. 7137C Note that D(ai) = ZETA(ai) 7138C and both D(ia) and h(ia) 7139C are stored transposed! 7140C------------------------------- 7141C 7142 LENBAR = 2*NT1AMX + NMATIJ(1) + NMATAB(1) + 2*NT1FRO(1) 7143 * + 2*NCOFRO(1) 7144C 7145 KONEAI = KZ1AM 7146 KONEAB = KONEAI + NT1AMX 7147 KONEIJ = KONEAB + NMATAB(1) 7148 KONEIA = KONEIJ + NMATIJ(1) 7149 KXMAT = KONEIA + NT1AMX 7150 KYMAT = KXMAT + NMATIJ(1) 7151 KMINT = KYMAT + NMATAB(1) 7152 KONINT = KMINT + N3ORHF(1) 7153 KMIRES = KONINT + N2BST(ISYMOP) 7154 KD1ABT = KMIRES + N3ORHF(1) 7155 KD1IJT = KD1ABT + NMATAB(1) 7156 KKABAR = KD1IJT + NMATIJ(1) 7157 KDHFAO = KKABAR + LENBAR 7158 KKABAO = KDHFAO + N2BST(1) 7159 KCMO = KKABAO + N2BST(1) 7160 KEND1 = KCMO + NLAMDS 7161 LWRK1 = LWORK - KEND1 7162C 7163 IF (FROIMP) THEN 7164 KCMOF = KEND1 7165 KEND1 = KCMOF + NLAMDS 7166 LWRK1 = LWORK - KEND1 7167 ENDIF 7168C 7169 IF (LWRK1 .LT. 0) THEN 7170 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND1 7171 CALL QUIT('Insufficient memory for allocation 1 CC_2EEXP') 7172 ENDIF 7173C 7174 IF (FROIMP) THEN 7175C 7176C---------------------------------------------- 7177C Get the FULL MO coefficient matrix. 7178C---------------------------------------------- 7179C 7180 CALL CMO_ALL(WORK(KCMOF),WORK(KEND1),LWRK1) 7181C 7182 ENDIF 7183C 7184C------------------------------------------------------ 7185C Initialize remaining one electron density arrays. 7186C------------------------------------------------------ 7187C 7188 CALL DZERO(WORK(KONEAB),NMATAB(1)) 7189 CALL DZERO(WORK(KONEIJ),NMATIJ(1)) 7190 CALL DZERO(WORK(KONEIA),NT1AMX) 7191C 7192C-------------------------------------------------------- 7193C Calculate X-intermediate of zeta- and t-amplitudes. 7194C-------------------------------------------------------- 7195C 7196 CALL CC_XI(WORK(KXMAT),WORK(KZ2AM),ISYMTR,WORK(KT2AM),ISYMOP, 7197 * WORK(KEND1),LWRK1) 7198C 7199C-------------------------------------------------------- 7200C Calculate Y-intermediate of zeta- and t-amplitudes. 7201C-------------------------------------------------------- 7202C 7203 CALL CC_YI(WORK(KYMAT),WORK(KZ2AM),ISYMTR,WORK(KT2AM),ISYMOP, 7204 * WORK(KEND1),LWRK1) 7205C 7206C-------------------------------------------------------------- 7207C Construct three remaining blocks of one electron density. 7208C-------------------------------------------------------------- 7209C 7210 CALL DCOPY(NMATAB(1),WORK(KYMAT),1,WORK(KONEAB),1) 7211 CALL CC_EITR(WORK(KONEAB),WORK(KONEIJ),WORK(KEND1),LWRK1,1) 7212 CALL DIJGEN(WORK(KONEIJ),WORK(KXMAT)) 7213 CALL DIAGEN(WORK(KONEIA),WORK(KT2AMT),WORK(KONEAI)) 7214C 7215C--------------------------------- 7216C Set up transposed densities. 7217C--------------------------------- 7218C 7219 CALL DCOPY(NMATAB(1),WORK(KONEAB),1,WORK(KD1ABT),1) 7220 CALL DCOPY(NMATIJ(1),WORK(KONEIJ),1,WORK(KD1IJT),1) 7221 CALL CC_EITR(WORK(KD1ABT),WORK(KD1IJT),WORK(KEND1),LWRK1,1) 7222C 7223C---------------------------------------------- 7224C Read orbital relaxation vector from disc. 7225C---------------------------------------------- 7226C 7227 CALL DZERO(WORK(KKABAR),LENBAR) 7228C 7229 LUCCK = -678 7230 CALL GPOPEN(LUCCK,'CCKABAR0','UNKNOWN',' ', 7231 * 'UNFORMATTED',IDUMMY,.FALSE.) 7232 REWIND(LUCCK) 7233 READ(LUCCK) (WORK(KKABAR+I-1), I = 1,LENBAR) 7234 CALL GPCLOSE(LUCCK,'KEEP') 7235C 7236C---------------------------------------------------------- 7237C Read MO-coefficients from interface file and reorder. 7238C---------------------------------------------------------- 7239C 7240 LUSIFC = -1 7241 CALL GPOPEN(LUSIFC,'SIRIFC','UNKNOWN',' ', 7242 * 'UNFORMATTED',IDUMMY,.FALSE.) 7243 REWIND LUSIFC 7244 CALL MOLLAB('TRCCINT ',LUSIFC,LUPRI) 7245 READ (LUSIFC) 7246 READ (LUSIFC) 7247 READ (LUSIFC) (WORK(KCMO+I-1), I=1,NLAMDS) 7248 CALL GPCLOSE (LUSIFC,'KEEP') 7249C 7250 CALL CMO_REORDER(WORK(KCMO),WORK(KEND1),LWRK1) 7251C 7252C-------------------------------------------------------------- 7253C Calculate ao-transformed zeta-kappa-bar-0 and HF density. 7254C-------------------------------------------------------------- 7255C 7256 KOFDIJ = KKABAR 7257 KOFDAB = KOFDIJ + NMATIJ(1) 7258 KOFDAI = KOFDAB + NMATAB(1) 7259 KOFDIA = KOFDAI + NT1AMX 7260C 7261 ISDEN = 1 7262 CALL DZERO(WORK(KKABAO),N2BST(1)) 7263 CALL CC_DENAO(WORK(KKABAO),ISDEN,WORK(KOFDAI),WORK(KOFDAB), 7264 * WORK(KOFDIJ),WORK(KOFDIA),ISDEN,WORK(KCMO),1, 7265 * WORK(KCMO),1,WORK(KEND1),LWRK1) 7266C 7267 CALL CCS_D1AO(WORK(KDHFAO),WORK(KEND1),LWRK1) 7268 IF (FROIMP .OR. FROEXP) THEN 7269 MODEL = 'DUMMY' 7270 CALL CC_FCD1AO(WORK(KDHFAO),WORK(KEND1),LWRK1,MODEL) 7271 ENDIF 7272C 7273C------------------------------------------------------------ 7274C Add orbital relaxation for effective density matrix. 7275C------------------------------------------------------------ 7276C 7277 CALL DCOPY(N2BST(1),WORK(KKABAO),1,WORK(KAODEN),1) 7278C 7279C------------------------------------------------------ 7280C Add frozen core contributions to AO densities. 7281C------------------------------------------------------ 7282C 7283 IF (FROIMP) THEN 7284C 7285 KOFFAI = KKABAR + NMATIJ(1) + NMATAB(1) + 2*NT1AMX 7286 KOFFIA = KOFFAI + NT1FRO(1) 7287 KOFFIJ = KOFFIA + NT1FRO(1) 7288 KOFFJI = KOFFIJ + NCOFRO(1) 7289C 7290 ISDEN = 1 7291 ICON = 1 7292 CALL CC_D1FCB(WORK(KAODEN),WORK(KOFFIJ),WORK(KOFFJI), 7293 * WORK(KOFFAI),WORK(KOFFIA),WORK(KEND1), 7294 * LWRK1,ISDEN,ICON) 7295C 7296 ISDEN = 1 7297 ICON = 2 7298 CALL CC_D1FCB(WORK(KKABAO),WORK(KOFFIJ),WORK(KOFFJI), 7299 * WORK(KOFFAI),WORK(KOFFIA),WORK(KEND1), 7300 * LWRK1,ISDEN,ICON) 7301C 7302 ENDIF 7303C 7304C------------------------------------------------------------ 7305C Backtransform the one electron density to AO-basis. 7306C We thus have the entire effective one-electron density. 7307C------------------------------------------------------------ 7308C 7309 ISDEN = 1 7310 CALL CC_DENAO(WORK(KAODEN),ISDEN,WORK(KONEAI),WORK(KONEAB), 7311 * WORK(KONEIJ),WORK(KONEIA),ISDEN,WORK(KLAMDP),1, 7312 * WORK(KLAMDH),1,WORK(KEND1),LWRK1) 7313C 7314C-------------------------------------------------------- 7315C Calculate M-intermediate of zeta- and t-amplitudes. 7316C-------------------------------------------------------- 7317C 7318 CALL CC_MI(WORK(KMINT),WORK(KZ2AM),ISYMTR,WORK(KT2AM),ISYMOP, 7319 * WORK(KEND1),LWRK1) 7320C 7321C-------------------------------------------------------- 7322C Calculate resorted M-intermediate M(imjk)->M(mkij). 7323C-------------------------------------------------------- 7324C 7325 CALL CC_MIRS(WORK(KMIRES),WORK(KMINT)) 7326C 7327 ELSE IF (MP2) THEN 7328C 7329C--------------------------------- 7330C First work space allocation. 7331C--------------------------------- 7332C 7333 N2BSTM = 0 7334 DO ISYM = 1, NSYM 7335 N2BSTM = MAX(N2BSTM,N2BST(ISYM)) 7336 END DO 7337C 7338 LENBAR = 2*NT1AMX + NMATIJ(1) + NMATAB(1) + 2*NCOFRO(1) 7339 * + 2*NT1FRO(1) 7340C 7341 KFCKEF = 1 7342 KAODSY = KFCKEF + N2BST(1) 7343 KAODEN = KAODSY + N2BSTM 7344 KONEAI = KAODEN + N2BSTM 7345 KONEAB = KONEAI + NT1AMX 7346 KONEIJ = KONEAB + NMATAB(1) 7347 KONEIA = KONEIJ + NMATIJ(1) 7348 KCMO = KONEIA + NT1AMX 7349 KKABAR = KCMO + NLAMDS 7350 KDHFAO = KKABAR + LENBAR 7351 KKABAO = KDHFAO + N2BST(1) 7352 KLAMDH = KKABAO + N2BST(1) 7353 KLAMDP = KLAMDH + NLAMDT 7354 KEND1 = KLAMDP + NLAMDT 7355 LWRK1 = LWORK - KEND1 7356C 7357 IF (LWRK1 .LT. 0) THEN 7358 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND1 7359 CALL QUIT( 7360 * 'Insufficient memory for work allocation in CC_2EEXP') 7361 ENDIF 7362C 7363C-------------------------- 7364C Initialize arrays. 7365C-------------------------- 7366C 7367 CALL DZERO(WORK(KONEAI),NT1AMX) 7368 CALL DZERO(WORK(KONEAB),NMATAB(1)) 7369 CALL DZERO(WORK(KONEIJ),NMATIJ(1)) 7370 CALL DZERO(WORK(KONEIA),NT1AMX) 7371 CALL DZERO(WORK(KKABAR),LENBAR) 7372C 7373C----------------------------------------------------------- 7374C Calculate correlated part of MO coefficient matrix. 7375C----------------------------------------------------------- 7376C 7377 CALL LAMMAT(WORK(KLAMDP),WORK(KLAMDH),WORK(KONEAI), 7378 * WORK(KEND1),LWRK1) 7379 CALL DZERO(WORK(KONEAI),NT1AMX) 7380C 7381C------------------------------------------------- 7382C Read orbital relaxation vector from disc. 7383C------------------------------------------------- 7384C 7385 LUCCK = -6347 7386 CALL GPOPEN(LUCCK,'CCKABAR0','UNKNOWN',' ', 7387 * 'UNFORMATTED',IDUMMY,.FALSE.) 7388 REWIND(LUCCK) 7389 READ(LUCCK) (WORK(KKABAR+I-1), I = 1,LENBAR) 7390 CALL GPCLOSE(LUCCK,'KEEP') 7391C 7392C---------------------------------------------------------------- 7393C Set up the relaxation (correlation) part of the density. 7394C---------------------------------------------------------------- 7395C 7396 CALL DCOPY(NMATIJ(1),WORK(KKABAR),1,WORK(KONEIJ),1) 7397 CALL DCOPY(NMATAB(1),WORK(KKABAR+NMATIJ(1)),1,WORK(KONEAB),1) 7398 CALL DCOPY(NT1AMX,WORK(KKABAR+NMATIJ(1)+NMATAB(1)),1, 7399 * WORK(KONEAI),1) 7400 CALL DCOPY(NT1AMX,WORK(KONEAI),1,WORK(KONEIA),1) 7401C 7402C------------------------------------- 7403C Add the Hartree-Fock density. 7404C------------------------------------- 7405C 7406 DO 80 ISYM = 1,NSYM 7407 DO 85 I = 1,NRHF(ISYM) 7408 NII = IMATIJ(ISYM,ISYM) + NRHF(ISYM)*(I - 1) + I 7409 WORK(KONEIJ + NII - 1) = WORK(KONEIJ + NII - 1) + TWO 7410 85 CONTINUE 7411 80 CONTINUE 7412C 7413C-------------------------------------- 7414C Transform density to AO basis. 7415C-------------------------------------- 7416C 7417 CALL DZERO(WORK(KAODEN),N2BST(1)) 7418C 7419 ISDEN = 1 7420 CALL CC_DENAO(WORK(KAODEN),ISDEN,WORK(KONEAI),WORK(KONEAB), 7421 * WORK(KONEIJ),WORK(KONEIA),ISDEN,WORK(KLAMDP),1, 7422 * WORK(KLAMDH),1,WORK(KEND1),LWRK1) 7423C 7424C-------------------------------------------------------------- 7425C Calculate ao-transformed zeta-kappa-bar-0 and HF density. 7426C-------------------------------------------------------------- 7427C 7428 KOFDIJ = KKABAR 7429 KOFDAB = KOFDIJ + NMATIJ(1) 7430 KOFDAI = KOFDAB + NMATAB(1) 7431 KOFDIA = KOFDAI + NT1AMX 7432C 7433 ISDEN = 1 7434 CALL DZERO(WORK(KKABAO),N2BST(1)) 7435 CALL CC_DENAO(WORK(KKABAO),ISDEN,WORK(KOFDAI),WORK(KOFDAB), 7436 * WORK(KOFDIJ),WORK(KOFDIA),ISDEN,WORK(KLAMDP),1, 7437 * WORK(KLAMDH),1,WORK(KEND1),LWRK1) 7438C 7439 CALL CCS_D1AO(WORK(KDHFAO),WORK(KEND1),LWRK1) 7440 IF (FROIMP .OR. FROEXP) THEN 7441 MODEL = 'DUMMY' 7442 CALL CC_FCD1AO(WORK(KDHFAO),WORK(KEND1),LWRK1,MODEL) 7443 ENDIF 7444C 7445C------------------------------------------- 7446C Get the FULL MO coefficient matrix. 7447C------------------------------------------- 7448C 7449 CALL CMO_ALL(WORK(KCMO),WORK(KEND1),LWRK1) 7450C 7451C------------------------------------------------------ 7452C Add frozen core contributions to AO densities. 7453C------------------------------------------------------ 7454C 7455 IF (FROIMP) THEN 7456C 7457 KOFFAI = KKABAR + NMATIJ(1) + NMATAB(1) + 2*NT1AMX 7458 KOFFIA = KOFFAI + NT1FRO(1) 7459 KOFFIJ = KOFFIA + NT1FRO(1) 7460 KOFFJI = KOFFIJ + NCOFRO(1) 7461C 7462 ISDEN = 1 7463 ICON = 1 7464 CALL CC_D1FCB(WORK(KAODEN),WORK(KOFFIJ),WORK(KOFFJI), 7465 * WORK(KOFFAI),WORK(KOFFIA),WORK(KEND1), 7466 * LWRK1,ISDEN,ICON) 7467C 7468 ISDEN = 1 7469 ICON = 2 7470 CALL CC_D1FCB(WORK(KKABAO),WORK(KOFFIJ),WORK(KOFFJI), 7471 * WORK(KOFFAI),WORK(KOFFIA),WORK(KEND1), 7472 * LWRK1,ISDEN,ICON) 7473C 7474 ENDIF 7475C 7476C---------------------------------- 7477C Work space allocation two. 7478C---------------------------------- 7479C 7480 KT2AM = KEND1 7481 KZ2AM = KT2AM + NT2AMX 7482 KSKOD = KZ2AM + NT2AMX 7483 KEND1 = KSKOD + NT1AMX 7484 LWRK1 = LWORK - KEND1 7485C 7486 IF (LWRK1 .LT. 0) THEN 7487 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND1 7488 CALL QUIT( 7489 * 'Insufficient memory for work allocation in CC_2EEXP') 7490 ENDIF 7491C 7492C---------------------------------------- 7493C Read zero'th order zeta amplitudes. 7494C---------------------------------------- 7495C 7496 IOPT = 3 7497 CALL CC_RDRSP('L0',0,1,IOPT,MODEL,WORK(KSKOD),WORK(KZ2AM)) 7498C 7499C------------------------------------------- 7500C Read zero'th order cluster amplitudes. 7501C------------------------------------------- 7502C 7503 IOPT = 3 7504 CALL CC_RDRSP('R0',0,1,IOPT,MODEL,WORK(KSKOD),WORK(KT2AM)) 7505C 7506C----------------------------------------------------------------------- 7507C Set up special modified amplitudes needed in the integral loop. 7508C (By doing it this way, we only need one packed vector in core 7509C along with the integral distribution in the delta loop.) 7510C----------------------------------------------------------------------- 7511C 7512 ISYOPE = 1 7513 IOPTTCME = 1 7514 CALL CCSD_TCMEPK(WORK(KT2AM),1.0D0,ISYOPE,IOPTTCME) 7515 CALL DSCAL(NT2AMX,TWO,WORK(KT2AM),1) 7516 CALL DAXPY(NT2AMX,ONE,WORK(KZ2AM),1,WORK(KT2AM),1) 7517C 7518 KEND1 = KSKOD 7519 LWRK1 = LWORK - KEND1 7520C 7521 ELSE IF (CCS) THEN 7522C 7523C--------------------------------- 7524C First work space allocation. 7525C--------------------------------- 7526C 7527 N2BSTM = 0 7528 DO ISYM = 1, NSYM 7529 N2BSTM = MAX(N2BSTM,N2BST(ISYM)) 7530 END DO 7531 7532 KFCKEF = 1 7533 KAODSY = KFCKEF + N2BST(1) 7534 KAODEN = KAODSY + N2BSTM 7535 KCMO = KAODEN + N2BSTM 7536 KEND1 = KCMO + NLAMDS 7537 LWRK1 = LWORK - KEND1 7538C 7539 IF (LWRK1 .LT. 0) THEN 7540 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:', KEND1 7541 CALL QUIT 7542 * ('Insufficient memory for work allocation in CC_2EEXP') 7543 ENDIF 7544C 7545 CALL CCS_D1AO(WORK(KAODEN),WORK(KEND1),LWRK1) 7546 IF (FROIMP .OR. FROEXP) THEN 7547 MODEL = 'DUMMY' 7548 CALL CC_FCD1AO(WORK(KAODEN),WORK(KEND1),LWRK1,MODEL) 7549 ENDIF 7550C 7551C------------------------------------------- 7552C Get the FULL MO coefficient matrix. 7553C------------------------------------------- 7554C 7555 CALL CMO_ALL(WORK(KCMO),WORK(KEND1),LWRK1) 7556C 7557 ENDIF 7558C 7559C----------------------------------------- 7560C Test: calculate energy contribution. 7561C----------------------------------------- 7562C 7563 IF (.FALSE.) THEN 7564 KTEST1 = KEND1 7565 KENDTS = KEND1 + N2BST(1) 7566 LWRKTS = LWORK - KENDTS 7567 CALL CCRHS_ONEAO(WORK(KTEST1),WORK(KENDTS),LWRKTS) 7568 ECCSD1 = DDOT(N2BST(1),WORK(KTEST1),1,WORK(KAODEN),1) 7569 ENDIF 7570C 7571 TIMONE = SECOND() - TIMONE 7572 CALL FLSHFO(LUPRI) 7573C 7574C----------------------------------- 7575C Start the loop over integrals. 7576C----------------------------------- 7577C 7578 SAVDIR = DIRECT 7579 SAVHER = HERDIR 7580 DIRECT = .TRUE. 7581 HERDIR = .TRUE. 7582C 7583C 7584 IF (IOPREL .EQ. 2) THEN 7585 DPTINT = .TRUE. 7586 ENDIF 7587 IF (DAR2EL) THEN 7588 DO2DAR = .TRUE. 7589 AD2DAR = .FALSE. 7590 S4CENT = .FALSE. 7591 ENDIF 7592C 7593 KEND1A = KEND1 7594 LWRK1A = LWRK1 7595C 7596 DTIME = SECOND() 7597 IF (HERDIR) THEN 7598 CALL HERDI1(WORK(KEND1),LWRK1,IPRERI) 7599 ELSE 7600 KCCFB1 = KEND1 7601 KINDXB = KCCFB1 + MXPRIM*MXCONT 7602 KEND1 = KINDXB + (8*MXSHEL*MXCONT + 1)/IRAT 7603 LWRK1 = LWORK - KEND1 7604C 7605 CALL ERIDI1(KODCL1,KODCL2,KODBC1,KODBC2,KRDBC1,KRDBC2, 7606 * KODPP1,KODPP2,KRDPP1,KRDPP2, 7607 * KFREE,LFREE,KEND1,WORK(KCCFB1),WORK(KINDXB), 7608 * WORK(KEND1),LWRK1,IPRERI) 7609 KEND1 = KFREE 7610 LWRK1 = LFREE 7611 ENDIF 7612 DTIME = SECOND() - DTIME 7613 TIMHE2 = TIMHE2 + DTIME 7614 NTOSYM = 1 7615C 7616 KENDSV = KEND1 7617 LWRKSV = LWRK1 7618C 7619 ICDEL1 = 0 7620 IF (HERDIR) THEN 7621 NTOT = MAXSHL 7622 ELSE 7623 NTOT = MXCALL 7624 ENDIF 7625C 7626 DO 100 ILLL = 1,NTOT 7627C 7628C--------------------------------------------------------------- 7629C Determine which delta's to be calculated in this round. 7630C--------------------------------------------------------------- 7631C 7632 KEND1 = KENDSV 7633 LWRK1 = LWRKSV 7634C 7635 DTIME = SECOND() 7636 IF (HERDIR) THEN 7637 CALL HERDI2(WORK(KEND1),LWRK1,INDEXA,ILLL,NUMDIS, 7638 & IPRERI) 7639 ELSE 7640 CALL ERIDI2(ILLL,INDEXA,NUMDIS,0,0, 7641 * WORK(KODCL1),WORK(KODCL2), 7642 * WORK(KODBC1),WORK(KODBC2), 7643 * WORK(KRDBC1),WORK(KRDBC2), 7644 * WORK(KODPP1),WORK(KODPP2), 7645 * WORK(KRDPP1),WORK(KRDPP2), 7646 * WORK(KCCFB1),WORK(KINDXB), 7647 * WORK(KEND1), LWRK1,IPRERI) 7648 ENDIF 7649 DTIME = SECOND() - DTIME 7650 TIMHE2 = TIMHE2 + DTIME 7651C 7652 KRECNR = KEND1 7653 KEND1 = KRECNR + (NBUFX(0) - 1)/IRAT + 1 7654 LWRK1 = LWORK - KEND1 7655 IF (LWRK1 .LT. 0) THEN 7656 CALL QUIT('Insufficient core in CC_2EEXP') 7657 END IF 7658C 7659C------------------------------------------------------- 7660C Open file for effective two electron densities. 7661C------------------------------------------------------- 7662C 7663 NFRL = 8 7664C 7665C !OLD VERSION 7666C LDECH = N2BSTM*NFRL+1 7667C OPEN(LUDE,STATUS='UNKNOWN',FORM='UNFORMATTED',FILE='CCTWODEN', 7668C * ACCESS='DIRECT',RECL= LDECH) 7669C 7670 LDECH = N2BSTM*NFRL+1 7671 LUDE = -1 7672 CALL GPOPEN(LUDE,'CCTWODEN','UNKNOWN','DIRECT','UNFORMATTED', 7673 * LDECH,OLDDX) 7674C 7675C------------------------------------------------ 7676C Loop over number of delta distributions. 7677C------------------------------------------------ 7678C 7679 DO 110 IDEL2 = 1,NUMDIS 7680C 7681 IDEL = INDEXA(IDEL2) 7682 ISYMD = ISAO(IDEL) 7683C 7684C------------------------------------- 7685C Work space allocation two. 7686C------------------------------------- 7687C 7688 ISYDEN = ISYMD 7689C 7690 IF (CCSD .OR. CC2) THEN 7691 KD2IJG = KEND1 7692 KD2AIG = KD2IJG + ND2IJG(ISYDEN) 7693 KD2IAG = KD2AIG + ND2AIG(ISYDEN) 7694 KD2ABG = KD2IAG + ND2AIG(ISYDEN) 7695 KEND2 = KD2ABG + ND2ABG(ISYDEN) 7696 LWRK2 = LWORK - KEND2 7697 ELSE IF (MP2) THEN 7698 KD2IJG = KEND1 7699 KD2IAG = KD2IJG + NF2IJG(ISYDEN) 7700 KEND2 = KD2IAG + ND2AIG(ISYDEN) 7701 LWRK2 = LWORK - KEND2 7702 ELSE IF (CCS) THEN 7703 KD2IJG = KEND1 7704 KEND2 = KD2IJG + NF2IJG(ISYDEN) 7705 LWRK2 = LWORK - KEND2 7706 ENDIF 7707C 7708 IF (LWRK2 .LT. 0) THEN 7709 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:',KEND2 7710 CALL QUIT( 7711 * 'Insufficient core for allocation 2 in CC_2EEXP') 7712 ENDIF 7713C 7714C-------------------------------------------------- 7715C Initialize two electron density arrays. 7716C-------------------------------------------------- 7717C 7718 AUTIME = SECOND() 7719C 7720 CALL DZERO(WORK(KD2IJG),NF2IJG(ISYDEN)) 7721 IF (.NOT. CCS) THEN 7722 CALL DZERO(WORK(KD2IAG),ND2AIG(ISYDEN)) 7723 IF (CCSD .OR. CC2) THEN 7724 CALL DZERO(WORK(KD2AIG),ND2AIG(ISYDEN)) 7725 CALL DZERO(WORK(KD2ABG),ND2ABG(ISYDEN)) 7726 CALL DZERO(WORK(KD2IJG),ND2IJG(ISYDEN)) 7727 ENDIF 7728 ENDIF 7729C 7730C---------------------------------------------------------------- 7731C Calculate the two electron density d(pq,gamma;delta). 7732C---------------------------------------------------------------- 7733C 7734 IF (CCSD) THEN 7735 CALL CC_DEN2(WORK(KD2IJG),WORK(KD2AIG),WORK(KD2IAG), 7736 * WORK(KD2ABG),WORK(KZ2AM),WORK(KT2AM), 7737 * WORK(KT2AMT),WORK(KMINT),WORK(KXMAT), 7738 * WORK(KYMAT),WORK(KONEAB),WORK(KONEAI), 7739 * WORK(KONEIA),WORK(KMIRES),WORK(KLAMDH),1, 7740 * WORK(KLAMDP),1,WORK(KEND2),LWRK2,IDEL, 7741 * ISYMD) 7742 ELSE IF (CC2) THEN 7743 CALL CC_DEN2(WORK(KD2IJG),WORK(KD2AIG),WORK(KD2IAG), 7744 * WORK(KD2ABG),WORK(KZ2AM),WORK(KT2AM), 7745 * WORK(KT2AMT),WORK(KEND2),WORK(KEND2), 7746 * WORK(KEND2),WORK(KONEAB),WORK(KONEAI), 7747 * WORK(KONEIA),WORK(KEND2),WORK(KLAMDH),1, 7748 * WORK(KLAMDP),1,WORK(KEND2),LWRK2,IDEL,ISYMD) 7749 ELSE IF (MP2) THEN 7750 CALL CCS_DEN2(WORK(KD2IJG),WORK(KCMO),WORK(KEND2), 7751 * LWRK2,IDEL,ISYMD) 7752 CALL MP2_DEN2(WORK(KD2IAG),WORK(KT2AM),WORK(KLAMDH), 7753 * WORK(KEND2),LWRK2,IDEL,ISYMD) 7754 ELSE IF (CCS) THEN 7755 CALL CCS_DEN2(WORK(KD2IJG),WORK(KCMO),WORK(KEND2), 7756 * LWRK2,IDEL,ISYMD) 7757 ENDIF 7758 AUTIME = SECOND() - AUTIME 7759 TIMDEN = TIMDEN + AUTIME 7760C 7761C--------------------------------------------------- 7762C Start loop over second AO-index (gamma). 7763C--------------------------------------------------- 7764C 7765 DO 120 ISYMG = 1, NSYM 7766 DO 130 G = 1, NBAS(ISYMG) 7767C 7768 IGAM = G + IBAS(ISYMG) 7769 ISYMPQ = MULD2H(ISYMG,ISYDEN) 7770C 7771C-------------------------------------------------------- 7772C Set addresses for 2-electron densities. 7773C-------------------------------------------------------- 7774C 7775 AUTIME = SECOND() 7776 IF (CCSD .OR. CC2) THEN 7777 KD2GIJ = KD2IJG + ID2IJG(ISYMPQ,ISYMG) 7778 * + NMATIJ(ISYMPQ)*(G - 1) 7779 KD2GAI = KD2AIG + ID2AIG(ISYMPQ,ISYMG) 7780 * + NT1AM(ISYMPQ)*(G - 1) 7781 KD2GAB = KD2ABG + ID2ABG(ISYMPQ,ISYMG) 7782 * + NMATAB(ISYMPQ)*(G - 1) 7783 KD2GIA = KD2IAG + ID2AIG(ISYMPQ,ISYMG) 7784 * + NT1AM(ISYMPQ)*(G - 1) 7785 ELSE IF (MP2) THEN 7786 KD2GIJ = KD2IJG + IF2IJG(ISYMPQ,ISYMG) 7787 * + NFROIJ(ISYMPQ)*(G - 1) 7788 KD2GIA = KD2IAG + ID2AIG(ISYMPQ,ISYMG) 7789 * + NT1AM(ISYMPQ)*(G - 1) 7790 ELSE IF (CCS) THEN 7791 KD2GIJ = KD2IJG + IF2IJG(ISYMPQ,ISYMG) 7792 * + NFROIJ(ISYMPQ)*(G - 1) 7793 ENDIF 7794C 7795C---------------------------------------------------------- 7796C Calculate frozen core contributions to d. 7797C---------------------------------------------------------- 7798C 7799 CALL DZERO(WORK(KAODEN),N2BST(ISYMPQ)) 7800C 7801 IF ((CCSD) .AND. (FROIMP)) THEN 7802C 7803 KFD2IJ = KEND2 7804 KFD2JI = KFD2IJ + NCOFRO(ISYMPQ) 7805 KFD2AI = KFD2JI + NCOFRO(ISYMPQ) 7806 KFD2IA = KFD2AI + NT1FRO(ISYMPQ) 7807 KFD2II = KFD2IA + NT1FRO(ISYMPQ) 7808 KEND3 = KFD2II + NFROFR(ISYMPQ) 7809 LWRK3 = LWORK - KEND3 7810C 7811 IF (LWRK3 .LT. 0) THEN 7812 WRITE(LUPRI,*) 'Available:', LWORK 7813 WRITE(LUPRI,*) 'Needed:', KEND3 7814 CALL QUIT('Insufficient work space in CC_2EEXP') 7815 ENDIF 7816C 7817 CALL DZERO(WORK(KFD2IJ),NCOFRO(ISYMPQ)) 7818 CALL DZERO(WORK(KFD2JI),NCOFRO(ISYMPQ)) 7819 CALL DZERO(WORK(KFD2AI),NT1FRO(ISYMPQ)) 7820 CALL DZERO(WORK(KFD2IA),NT1FRO(ISYMPQ)) 7821 CALL DZERO(WORK(KFD2II),NFROFR(ISYMPQ)) 7822C 7823 CALL CC_FD2BL(WORK(KFD2II),WORK(KFD2IJ), 7824 * WORK(KFD2JI),WORK(KFD2AI), 7825 * WORK(KFD2IA),WORK(KONEIJ), 7826 * WORK(KONEAB),WORK(KONEAI), 7827 * WORK(KONEIA),WORK(KCMOF), 7828 * WORK(KLAMDH),WORK(KLAMDP), 7829 * WORK(KEND3),LWRK3,IDEL, 7830 * ISYMD,G,ISYMG) 7831C 7832 CALL CC_FD2AO(WORK(KAODEN),WORK(KFD2II), 7833 * WORK(KFD2IJ),WORK(KFD2JI), 7834 * WORK(KFD2AI),WORK(KFD2IA), 7835 * WORK(KCMOF),WORK(KLAMDH), 7836 * WORK(KLAMDP),WORK(KEND3),LWRK3, 7837 * ISYMPQ) 7838C 7839 CALL CC_D2GAF(WORK(KD2GIJ),WORK(KD2GAB), 7840 * WORK(KD2GAI),WORK(KD2GIA), 7841 * WORK(KONEIJ),WORK(KONEAB), 7842 * WORK(KONEAI),WORK(KONEIA), 7843 * WORK(KCMOF),IDEL,ISYMD,G,ISYMG) 7844C 7845 KEND4 = KEND3 7846 LWRK4 = LWRK3 7847C 7848 ELSE 7849C 7850 KEND4 = KEND2 7851 LWRK4 = LWRK2 7852 IF (CCS) KLAMDH = KEND4 7853C 7854 ENDIF 7855 AUTIME = SECOND() - AUTIME 7856 TIMDEN = TIMDEN + AUTIME 7857C 7858C--------------------------------------------------------- 7859C Backtransform density fully to AO basis. 7860C--------------------------------------------------------- 7861C 7862 AUTIM1 = SECOND() 7863 IF (CCSD .OR. CC2) THEN 7864 CALL CC_DENAO(WORK(KAODEN),ISYMPQ, 7865 * WORK(KD2GAI),WORK(KD2GAB), 7866 * WORK(KD2GIJ),WORK(KD2GIA),ISYMPQ, 7867 * WORK(KLAMDP),1,WORK(KLAMDH),1, 7868 * WORK(KEND4),LWRK4) 7869 ELSE 7870 CALL CCMP_DAO(WORK(KAODEN),WORK(KD2GIJ), 7871 * WORK(KD2GIA),WORK(KCMO), 7872 * WORK(KLAMDH),WORK(KEND4), 7873 * LWRK4,ISYMPQ) 7874 ENDIF 7875C 7876C----------------------------------------------------- 7877C Add relaxation terms to set up 7878C effective density. We thus have the 7879C entire effective 2-electron density. 7880C----------------------------------------------------- 7881C 7882 IF (.NOT. CCS) THEN 7883 ICON = 2 7884 CALL CC_D2EFF(WORK(KAODEN),G,ISYMG,IDEL,ISYMD, 7885 * WORK(KKABAO),WORK(KDHFAO),ICON) 7886 CALL CC_D2EFF(WORK(KAODEN),G,ISYMG,IDEL,ISYMD, 7887 * WORK(KDHFAO),WORK(KKABAO),ICON) 7888 ENDIF 7889 AUTIM1 = SECOND() - AUTIM1 7890 TIMDAO = TIMDAO + AUTIM1 7891C 7892C----------------------------------------------------- 7893C Write effective density to disc for 7894C subsequent use in integral program, 7895C which performs the contraction of 7896C the density with the 2 e- integrals. 7897C----------------------------------------------------- 7898C 7899 AUTIME = SECOND() 7900 NDAD = NBAST*(IDEL2 - 1) + IGAM 7901 NDENEL = N2BST(ISYMPQ) 7902 CALL DUMP2DEN(LUDE,WORK(KAODEN),NDENEL,NDAD) 7903 AUTIME = SECOND() - AUTIME 7904 TIRDAO = TIRDAO + AUTIME 7905C 7906 130 CONTINUE 7907 120 CONTINUE 7908 110 CONTINUE 7909C 7910C------------------------------------------------ 7911C Loop over number of delta distributions. 7912C------------------------------------------------ 7913C 7914 DO 140 IDEL2 = 1,NUMDIS 7915C 7916 IDEL = INDEXA(IDEL2) 7917 ISYMD = ISAO(IDEL) 7918 ISYDEN = ISYMD 7919C 7920C--------------------------------- 7921C Work space allocation. 7922C--------------------------------- 7923C 7924 ISYDIS = MULD2H(ISYMD,ISYMOP) 7925C 7926 KXINT = KEND1 7927 KEND2 = KXINT + NDISAO(ISYDIS) 7928 LWRK2 = LWORK - KEND2 7929C 7930 IF (LWRK2 .LT. 0) THEN 7931 WRITE(LUPRI,*) 'Available:', LWORK, 'Needed:',KEND2 7932 CALL QUIT('Insufficient core for allocation in CC_2EEXP') 7933 ENDIF 7934C 7935C----------------------------------------- 7936C Read AO integral distribution. 7937C----------------------------------------- 7938C 7939 AUTIME = SECOND() 7940 CALL CCRDAO(WORK(KXINT),IDEL,IDEL2,WORK(KEND2),LWRK2, 7941 * WORK(KRECNR),DIRECT) 7942 AUTIME = SECOND() - AUTIME 7943 TIRDAO = TIRDAO + AUTIME 7944C 7945C--------------------------------------------------- 7946C Start loop over second AO-index (gamma). 7947C--------------------------------------------------- 7948C 7949 DO 150 ISYMG = 1, NSYM 7950 DO 160 G = 1, NBAS(ISYMG) 7951C 7952 IGAM = G + IBAS(ISYMG) 7953 ISYMPQ = MULD2H(ISYMG,ISYDEN) 7954C 7955C-------------------------------------------- 7956C Work space allocation four. 7957C-------------------------------------------- 7958C 7959 KINTAO = KEND2 7960 KEND3 = KINTAO + N2BST(ISYMPQ) 7961 KCHE3 = KEND3 + N2BST(ISYMPQ) 7962 LWRK3 = LWORK - KCHE3 7963C 7964 IF (LWRK3 .LT. 0) THEN 7965 WRITE(LUPRI,*) 'Available:', LWORK 7966 WRITE(LUPRI,*) 'Needed:', KCHE3 7967 CALL QUIT('Insufficient work space in CC_2EEXP') 7968 ENDIF 7969C 7970C---------------------------------------------------- 7971C Square up AO-integral distribution. 7972C---------------------------------------------------- 7973C 7974 KOFFIN = KXINT + IDSAOG(ISYMG,ISYDIS) 7975 * + NNBST(ISYMPQ)*(G - 1) 7976C 7977 CALL CCSD_SYMSQ(WORK(KOFFIN),ISYMPQ,WORK(KINTAO)) 7978C 7979C---------------------------------------------- 7980C Read density block from disc. 7981C---------------------------------------------- 7982C 7983 AUTIME = SECOND() 7984 NDAD = NBAST*(IDEL2 - 1) + IGAM 7985 NDENEL = N2BST(ISYMPQ) 7986 CALL RETR2DEN(LUDE,WORK(KEND3),NDENEL,NDAD) 7987 AUTIME = SECOND() - AUTIME 7988 TIRDAO = TIRDAO + AUTIME 7989C 7990C-------------------------------------------------------- 7991C calculate the 2 e- density contribution 7992C to the requested property. 7993C-------------------------------------------------------- 7994C 7995 RE2DAR = RE2DAR + HALF*DDOT(N2BST(ISYMPQ), 7996 * WORK(KEND3),1,WORK(KINTAO),1) 7997C 7998 160 CONTINUE 7999 150 CONTINUE 8000 140 CONTINUE 8001C 8002C--------------------------------------------------------- 8003C Close file with effective two electron densities. 8004C--------------------------------------------------------- 8005C 8006 CALL GPCLOSE(LUDE,'DELETE') 8007C 8008 100 CONTINUE 8009C 8010C------------------------------------------------ 8011C Restore logical flags for integral program. 8012C------------------------------------------------ 8013C 8014 DIRECT = SAVDIR 8015 HERDIR = SAVHER 8016 IF (DAR2EL) DO2DAR = .FALSE. 8017 IF (IOPREL .EQ. 2) THEN 8018 DPTINT = .FALSE. 8019 ENDIF 8020C 8021C---------------------- 8022C Print out result. 8023C---------------------- 8024C 8025 IF (IOPREL .EQ. 2) THEN 8026 WORK(1) = RE2DAR 8027 ELSE IF ((DAR2EL).AND.(IOPREL.NE.2)) THEN 8028C 8029 IF (IOPREL .NE. 1) THEN 8030 CALL AROUND('Relativistic two-electron Darwin correction') 8031 ENDIF 8032C 8033 WRITE(LUPRI,*) ' ' 8034 WRITE(LUPRI,131) '2-elec. Darwin term:', RE2DAR 8035 WRITE(LUPRI,132) '------------------- ' 8036C 8037 IF (IOPREL .EQ. 1) THEN 8038 RELCO1 = RELCO1 + RE2DAR 8039 WRITE(LUPRI,*) ' ' 8040 WRITE(LUPRI,133) 'Total relativistic correction:', RELCO1 8041 WRITE(LUPRI,134) '----------------------------- ' 8042 ENDIF 8043C 8044 131 FORMAT(9X,A20,1X,F17.9) 8045 132 FORMAT(9X,A20) 8046 133 FORMAT(9X,A30,1X,F17.9) 8047 134 FORMAT(9X,A30) 8048C 8049 ENDIF 8050C 8051 IF (.FALSE.) THEN 8052C 8053 LUSIFC = -1 8054 CALL GPOPEN(LUSIFC,'SIRIFC','UNKNOWN',' ','UNFORMMATED', 8055 * IDUMMY,.FALSE.) 8056 REWIND LUSIFC 8057C 8058 CALL MOLLAB('SIR IPH ',LUSIFC,LUPRI) 8059 READ (LUSIFC) POTNUC 8060 CALL GPCLOSE (LUSIFC,'KEEP') 8061C 8062 ECCSD = ECCSD1 + RE2DAR + POTNUC 8063C 8064 WRITE(LUPRI,*) ' ' 8065 WRITE(LUPRI,*) 'Coupled Cluster energy constructed' 8066 WRITE(LUPRI,*) 'from density matrices:' 8067 WRITE(LUPRI,*) 'CCSD-energy:', ECCSD 8068 WRITE(LUPRI,*) 'H1 energy, ECCSD1 = ',ECCSD1 8069c WRITE(LUPRI,*) 'H2 energy, ECCSD2 = ',RE2DAR 8070 WRITE(LUPRI,*) 'Two-electron contribution to FODPT:',RE2DAR 8071 WRITE(LUPRI,*) 'Nuc. Pot. energy = ',POTNUC 8072C 8073 ENDIF 8074C 8075C----------------------- 8076C Write out timings. 8077C----------------------- 8078C 8079 99 TIMTOT = SECOND() - TIMTOT 8080C 8081 IF (IPRINT .GT. 3) THEN 8082 WRITE(LUPRI,*) ' ' 8083 WRITE(LUPRI,*) 'Two electron first-order property'// 8084 * ' calculation completed' 8085 WRITE(LUPRI,*) 'Total time used in CC_2EEXP:', TIMTOT 8086 ENDIF 8087 IF (IPRINT .GT. 9) THEN 8088 WRITE(LUPRI,*) 8089 * 'Time used for setting up d(pq,ga,de) :',TIMDEN 8090 WRITE(LUPRI,*) 8091 * 'Time used for full AO backtransformation :',TIMDAO 8092 WRITE(LUPRI,*) 8093 * 'Time used for reading and writing d and I :',TIRDAO 8094 WRITE(LUPRI,*) 8095 * 'Time used for calculating 2 e- AO-integrals:',TIMHE2 8096 WRITE(LUPRI,*) 8097 * 'Time used for 1 e- density & intermediates :',TIMONE 8098 ENDIF 8099C 8100 CALL QEXIT('CC_2EEXP') 8101C 8102 RETURN 8103 165 CALL QUIT('Error reading CCTWODEN') 8104 END 8105C 8106C/* Deck dump2den */ 8107 SUBROUTINE DUMP2DEN(LUDE,DEN,LENDEN,NDAD) 8108C 8109C Written by Asger Halkier 25/1 - 99. 8110C 8111C Purpose: Write block of effective two electron density matrix 8112C (DEN) to disc. 8113C 8114C 8115#include "implicit.h" 8116 DIMENSION DEN(LENDEN) 8117C 8118 CALL QENTER('DUMP2DEN') 8119C 8120 WRITE(LUDE,REC=NDAD) (DEN(I), I=1,LENDEN) 8121C 8122 CALL QEXIT('DUMP2DEN') 8123C 8124 RETURN 8125 END 8126C/* Deck retr2den */ 8127 SUBROUTINE RETR2DEN(LUDE,DEN,LENDEN,NDAD) 8128C 8129C Written by Asger Halkier 25/1 - 99. 8130C 8131C Purpose: Read block of effective two electron density matrix 8132C (AODEN) from disc. 8133C 8134C 8135#include "implicit.h" 8136 DIMENSION DEN(LENDEN) 8137C 8138 CALL QENTER('RETR2DEN') 8139C 8140 READ(LUDE,ERR=1000,REC=NDAD) DEN 8141C 8142 CALL QEXIT('RETR2DEN') 8143C 8144 RETURN 8145 1000 CALL QUIT('Error reading CCTWODEN') 8146 END 8147 8148