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 ccsd_energy */ 20 SUBROUTINE CCSD_ENERGY(WORK,LWORK,APROXR12,CCR12RSP,CCR12LIM) 21C 22C Written by Henrik Koch 27-Mar-1990. 23C DIIS and Brueckner bit by Rika Kobayashi 1992. 24C 25C Ove juli-sept. 1995: RSP intermediates 26C noccit 27C Ove februar 1997: CCS, FD gradient hacks and restart. 28C Sonia/MFIozzi 2009: rCCD, drCCD 29C Sonia 2010: rTCCD 30C 31 USE PELIB_INTERFACE, ONLY: USE_PELIB, PELIB_IFC_PECC 32#include "implicit.h" 33#include "priunit.h" 34#include "dummy.h" 35#include "maxorb.h" 36 PARAMETER (XMONE = -1.0D0, IZERO = 0, TWO = 2.0D0, ZERO = 0.0D00) 37 LOGICAL CCSAV, CC1BSV, CC1ASV, CCPTSV, CCP3SV, LCCEQ, MLCCSAVE 38 LOGICAL MP2R12TST,LRES 39 DIMENSION WORK(LWORK) 40 COMMON /LUDIIS/ LUTDIS, LUSDIS 41#include "ccorb.h" 42#include "iratdef.h" 43#include "ccsdinp.h" 44#include "ccsections.h" 45#include "ccsdsym.h" 46#include "ccfro.h" 47#include "ccsdio.h" 48#include "ccinftap.h" 49#include "inftap.h" 50#include "cclr.h" 51#include "ccslvinf.h" 52#include "gnrinf.h" 53#include "ccfdgeo.h" 54#include "cbirea.h" 55#include "r12int.h" 56#include "ccr12int.h" 57!Sonia 58#include "ccfop.h" 59#include "ccnoddy.h" 60Cholesky 61#include "ccdeco.h" 62#include "chodbg.h" 63#include "cc_cho.h" 64#include "chocc2.h" 65C 66 LOGICAL CPTDBG 67Cholesky 68 LOGICAL LCONVG,RSPIM2,EX,LEXIST,LHTF,MKVABKL 69 LOGICAL CCR12RSP, CCR12LIM 70 LOGICAL LCONV1,LCONV2 71 CHARACTER*5 ETY0, ETY1, ETY2 72 CHARACTER MODEL*10, MODELR*10, ETYPE*24, MODELR12*24, MOPRPC*10 73 CHARACTER MODREF*10 74 CHARACTER*3 APROXR12 75 CHARACTER*24 BLANKS 76 DATA BLANKS /' '/ 77 INTEGER LENMOD 78 CHARACTER*8 LABEL1 79 LOGICAL DRPA_ISSTABILIZINGSOLUTION 80C 81 CALL QENTER('CCSD_ENERGY') 82celena 83 IF (R12PRP) INTTR = .TRUE. 84celena 85C 86C ------------------------------------------------------------- 87C set model for which the current t-amplitudes were calculated: 88C ------------------------------------------------------------- 89C 90 MODEL = 'UNKNOWN ' 91 IF (CIS) MODEL = 'CIS ' 92 IF (CCS) MODEL = 'CCS ' 93 IF (MP2) MODEL = 'MP2 ' 94 IF (CC2) MODEL = 'CC2 ' 95 IF (CCD) MODEL = 'CCD ' 96 IF (CCSD) MODEL = 'CCSD ' 97!SONIA/FRAN 98 IF (RCCD) MODEL = 'RCCD ' 99 IF (DRCCD) MODEL = 'DRCCD ' 100 IF (RTCCD) MODEL = 'RTCCD ' 101! 102 IF (CC3) MODEL = 'CC3 ' 103 IF (CC1A) MODEL = 'CCSDT-1a ' 104 IF (CC1B) MODEL = 'CCSDT-1b ' 105 IF (CCPT) MODEL = 'CCSD(T) ' 106 IF (CCP3) MODEL = 'CC(3) ' 107 IF (CCRT) MODEL = 'CCSDR(T) ' 108 IF (CCR3) MODEL = 'CCSDR(3) ' 109 IF (CCR1A) MODEL = 'CCSDR(1A) ' 110 IF (CCR1B) MODEL = 'CCSDR(1B) ' 111 IF (DCPT2) MODEL = 'DCPT2 ' 112 MOPRPC = MODEL 113 ! set model for CCR12 114 CALL CCSD_MODEL(MODELR12,LENMOD,24,MODEL,10,APROXR12) 115 MODEL = MODELR12(1:10) 116C 117#if defined (SYS_CRAY) 118C Open file for diis extrapolation 119C 120 CALL WOPEN('CC_DIIS',64,0,IERR) 121C 122 IF (IERR .NE. 0) CALL QUIT('Error opening CC_DIIS') 123#endif 124C 125 ETY0 = 'SCF ' 126C 127C Call the CCSD initialization routine. 128C 129 ISYMOP = 1 130C 131 RSPIM2 = .FALSE. 132 OMEGSQ = .FALSE. 133 OMEGOR = .TRUE. 134 DUMPCD = .TRUE. 135 CC3LR = .FALSE. 136 NEWGAM = .TRUE. 137 CCPTSV = .FALSE. 138 CCP3SV = .FALSE. 139 EX = .FALSE. 140C 141C------------------------------------------------- 142C Employ MP2-R12 method (WK/UniKA/04-11-2002). 143C------------------------------------------------- 144C 145 R12NOP = R12NOP .OR. .NOT. R12XXL 146 IF (R12CAL.AND..NOT.LISKIP) THEN 147 IPRSAVE = IPRINT 148 IPRINT = IPRINT / 10 149 CALL GETTIM(T0,W0) 150 CALL CCSD_R12(WORK,LWORK,WORK,LWORK,CCR12RSP) 151 CALL GETTIM(T1,W1) 152 WRITE(LUPRI,*)'Time for MP2-R12 part cpu :', T1-T0 153 WRITE(LUPRI,*)'Time for MP2-R12 part wall:', W1-W0 154 CALL FLSHFO(LUPRI) 155 ! restore print level 156 IPRINT = IPRSAVE 157C 158C Use LABEL (WK/UniKA/04-11-2002). 159 LABEL = 'TRCCINT ' 160 IF (LMULBS) THEN 161 NOAUXB = .TRUE. 162 IF (HERDIR) THEN 163 WRITE (LUPRI,'(/A/)') 'NOAUXB with HERDIR not implemented' 164 GOTO 9999 165 ENDIF 166C IF (.NOT. DIRECT) 167C & CALL QUIT('NOAUXB without DIRECT not implemented') 168 END IF 169C 170C reset nbas, etc. to original values: 171 CALL CCSD_INIT1(WORK,LWORK) 172 END IF 173C 174C switch off R12-MP12 for future calls 175 R12CAL = .FALSE. 176 CC2R12INT = .FALSE. 177 CCSDR12INT= .FALSE. 178C 179C use V^(alpha beta)_(kl)? 180 USEVABKL = CCR12 .AND. (USEVABKL .OR. .NOT.CC2) 181 MKVABKL = USEVABKL 182C 183 IF (CCR12.AND.MP2 .AND. .NOT. R12PRP) THEN 184 CALL QEXIT('CCSD_ENERGY') 185 RETURN 186 ELSE IF (CCR12.AND.(.NOT.LISKIP)) THEN 187 IF (MKVABKL .AND. .NOT. MP2) THEN 188 WRITE(LUPRI,*)'Preparing R12 V-interm. ... ONEAUX=',ONEAUX 189 CALL GETTIM(T0,W0) 190 CALL CC_R12PREPCCSD(WORK,LWORK) 191 CALL GETTIM(T1,W1) 192 WRITE(LUPRI,*)'Time used for V^albe_kl cpu:', T1-T0 193 WRITE(LUPRI,*)'Time used for V^albe_kl wall:',W1-W0 194 WRITE(LUPRI,*) 195 END IF 196 197 IF (MP2 .OR. (IANR12.EQ.1)) THEN 198 CONTINUE 199 ELSE IF (IANR12.EQ.2 .OR. IANR12.EQ.3) THEN 200 IF (.NOT.CC2 .AND. .NOT.R12CBS) 201 * CALL QUIT('This CC-R12 model is not implemented w/o CABS') 202 WRITE(LUPRI,*)'Preparing R12 Ansatz 2/3 ... ONEAUX=',ONEAUX 203 CALL CCR12PREP2(WORK,LWORK) 204 ELSE 205 WRITE(LUPRI,*) 'IANR12 = ',IANR12 206 CALL QUIT('This CC-R12 Ansatz is currently not implemented') 207 END IF 208 END IF 209 210C ---------------------------------------------------------------- 211C Read packed r12 amplitudes from file CCR12_D for present 212C Ansatz and approximation and put on CCR12_C and CCR0_1___1 213C ---------------------------------------------------------------- 214 IOPT = 0 215 IF (CCR12.AND..NOT.(CIS.OR.CCS.OR.MP2)) THEN 216 KTAMP12 = 1 217 KEND1 = KTAMP12 + NTR12AM(1) 218 LWRK1 = LWORK - KEND1 219 IF (LWRK1 .LT. 0) THEN 220 CALL QUIT('Not enough work space for R12') 221 END IF 222 LU43 = -43 223 CALL GPOPEN(LU43,FCCR12D,'UNKNOWN',' ','UNFORMATTED', 224 & IDUM,LDUM) 225 1816 READ(LU43,end=1817) IAN,IAP,APROXR12 226 READ(LU43) (WORK(KTAMP12-1+I),I=1,NTR12AM(1)) 227 IF ((IAN.NE.IANR12).OR.(IAP.NE.IAPR12)) GOTO 1816 228 CALL GPCLOSE(LU43,'KEEP') 229 CALL GPOPEN(LU43,FCCR12C,'UNKNOWN',' ','UNFORMATTED', 230 & IDUM,LDUM) 231 WRITE(LU43) (WORK(KTAMP12-1+I),I=1,NTR12AM(1)) 232 CALL GPCLOSE(LU43,'KEEP') 233C 234 IF (.NOT.CCRSTR) THEN 235C WRITE(LUPRI,*) 'Writing R12 amplitudes to disk, MODEL=',MODEL 236 IOPT = 32 237 CALL CC_WRRSP('R0 ',0,1,IOPT,MODEL,DUMMY,DUMMY, 238 & WORK(KTAMP12),WORK(KEND1),LWRK1) 239 END IF 240 END IF 241C 242C---------------------------------------------------------------------------- 243C Calculate X^V intermediates needed for CCR12 response and finite fields 244C---------------------------------------------------------------------------- 245C 246C IF (CCR12RSP) THEN 247C call cc_r12vxint(work,lwork,.false.) 248C END IF 249C 250C------------------- 251C Cholesky debug 252C------------------- 253C 254 IF (CHODBG) CALL CC_CHODBG(WORK,LWORK) 255C 256C---------------------------------------------------------------------- 257C Save RSPIM flag to calculate response global intermediates later. 258C If CCS or MP2 no intermediates is calculated. 259C---------------------------------------------------------------------- 260C 261 IF (RSPIM .AND. ( .NOT. (CCS .OR.(MP2.AND.(.NOT.CCP2))))) THEN 262 RSPIM2 = RSPIM 263 RSPIM = .FALSE. 264 ENDIF 265C 266C------------------------------ 267C Print information header. 268C------------------------------ 269C 270 WRITE (LUPRI,'(1x,A,/)') ' ' 271 WRITE (LUPRI,'(1x,A)') 272 *'*********************************************************'// 273 *'**********' 274 WRITE (LUPRI,'(1x,A)') 275 *'* '// 276 *' *' 277 WRITE (LUPRI,'(1x,A)') 278 *'*---------- >'// 279 *'---------*' 280 WRITE (LUPRI,'(1x,A)') 281 *'*---------- OUTPUT FROM COUPLED CLUSTER ENERGY PROGRAM >'// 282 *'---------*' 283 WRITE (LUPRI,'(1x,A)') 284 *'*---------- >'// 285 *'---------*' 286 WRITE (LUPRI,'(1x,A)') 287 *'* '// 288 *' *' 289 WRITE (LUPRI,'(1x,A,/)') 290 *'*********************************************************'// 291 *'**********' 292 WRITE(LUPRI,'(/13X,A)') 293 * 'The Direct Coupled Cluster Energy Program' 294 WRITE(LUPRI,'(13X,A)') 295 * '-----------------------------------------' 296 WRITE(LUPRI,'(//10X,A,I8)') 297 * 'Number of t1 amplitudes : ',NT1AMX 298 WRITE(LUPRI,'(10X,A,I10)') 299 * 'Number of t2 amplitudes :',NT2AMX 300 NCCVAR = NT1AMX + NT2AMX 301 IF (CCR12) THEN 302 WRITE(LUPRI,'(10X,A,I10)') 303 * "Number of t2' amplitudes for R12 part :",NTR12AM(1) 304 NCCVAR = NCCVAR + NTR12AM(1) 305 END IF 306 WRITE(LUPRI,'(10X,A,I10/)') 307 * 'Total number of amplitudes in ccsd :',NCCVAR 308 CALL FLSHFO(LUPRI) 309C 310C---------------------------------------------------------------- 311C If CCS then no the wavefunction optimization. 312C CCS energy is equal to HF energy -> find and put in ECCGRS. 313C For polarizabilities and oscillator strengths, 314C we need the (ia|jb) integrals. 315C---------------------------------------------------------------- 316C 317 IF (CCS ) THEN 318 WRITE(LUPRI,'(//10X,A,I8)') 319 * 'CCS CALC. - NO WAVEFUNCTION OPTIMIZATION' 320C 321 CALL GPOPEN(LUSIFC,'SIRIFC','OLD',' ','UNFORMATTED',IDUMMY, 322 & .FALSE.) 323 REWIND LUSIFC 324 CALL MOLLAB('SIR IPH ',LUSIFC,LUPRI) 325 READ (LUSIFC) POTNUC,EMY,EACTIV,EMCSCF,ISTATE,ISPIN,NACTEL, 326 * LSYM,MS2 327 ESCF = EMCSCF 328 ECCGRS = EMCSCF 329 CALL GPCLOSE(LUSIFC,'KEEP') 330C 331C write SCF energy to summary file: 332 WRITE(LURES,'(/12X,A,A,A,F32.10)') 333 * 'Total ',ETY0,' energy: ',ESCF 334C 335 LABEL1 = 'ENERGY ' 336 MODREF = 'CCS/SCF ' 337 CALL CC_PRPC(ESCF,MODREF,0, 338 * LABEL1,LABEL1,LABEL1,LABEL1, 339 * ZERO,ZERO,ZERO,1,0,0,0) 340 CALL WRIPRO(ESCF,MODREF,0, 341 * LABEL1,LABEL1,LABEL1,LABEL1, 342 * ZERO,ZERO,ZERO,1,0,0,0) 343 344 GO TO 9999 345C ... exit this routine 346 ENDIF 347C 348C 349C-------------------- 350C Cholesky stuff. 351C-------------------- 352C 353C Cholesky MP2 section. 354C --------------------- 355 356 IF (MP2 .AND. CHOINT) THEN 357 358 CALL GPOPEN(LUSIFC,'SIRIFC','OLD',' ','UNFORMATTED', 359 & IDUMMY,.FALSE.) 360 REWIND LUSIFC 361 CALL MOLLAB('SIR IPH ',LUSIFC,LUPRI) 362 READ (LUSIFC) POTNUC,EMY,EACTIV,EMCSCF,ISTATE,ISPIN,NACTEL, 363 & LSYM,MS2 364 ESCF = EMCSCF 365 CALL GPCLOSE(LUSIFC,'KEEP') 366 367C Calculate MP2 energy correction. 368C -------------------------------- 369 370 CALL CC_CHOMP2(WORK,LWORK,EMP2) 371C 372C Write SCF and MP2 energies to output and summary. 373C ------------------------------------------------- 374 375 ETY1 = 'MP2 ' 376 ECCGRS = ESCF + EMP2 377 378 CALL AROUND 379 & ('Final results from the Coupled Cluster energy program') 380 381 WRITE(LUPRI,'(/12X,A,A,A,F32.10)') 382 & 'Total ',ETY0,' energy: ',ESCF 383 WRITE(LUPRI,'(12X,A,A,A,F32.10)') 384 & 'Total ',ETY1,' energy: ',ECCGRS 385 WRITE(LURES,'(/12X,A,A,A,F32.10)') 386 & 'Total ',ETY0,' energy: ',ESCF 387 WRITE(LURES,'(12X,A,A,A,F32.10)') 388 & 'Total ',ETY1,' energy: ',ECCGRS 389 390 LABEL1 = 'ENERGY ' 391 MODREF = 'MP2/CHOLES' 392 CALL CC_PRPC(ECCGRS,MODREF,0, 393 * LABEL1,LABEL1,LABEL1,LABEL1, 394 * ZERO,ZERO,ZERO,1,0,0,0) 395 CALL WRIPRO(ECCGRS,MODREF,0, 396 * LABEL1,LABEL1,LABEL1,LABEL1, 397 * ZERO,ZERO,ZERO,1,0,0,0) 398 399 GOTO 9999 400 401 ENDIF 402C 403C Cholesky CC2 section. 404C --------------------- 405 406 IF (CC2 .AND. CHOINT) THEN 407 408 CALL CC_CHOECC2(WORK,LWORK,ESCF,ECC2,RSPIM2) 409 410 ETY1 = 'CC2 ' 411 ECCGRS = ECC2 412 413 CALL AROUND 414 & ('Final results from the Coupled Cluster energy program') 415 416 WRITE(LUPRI,'(/12X,A,A,A,F32.10)') 417 & 'Total ',ETY0,' energy: ',ESCF 418 WRITE(LUPRI,'(12X,A,A,A,F32.10)') 419 & 'Total ',ETY1,' energy: ',ECCGRS 420 WRITE(LURES,'(/12X,A,A,A,F32.10)') 421 & 'Total ',ETY0,' energy: ',ESCF 422 WRITE(LURES,'(12X,A,A,A,F32.10)') 423 & 'Total ',ETY1,' energy: ',ECCGRS 424 425 426 LABEL1 = 'ENERGY ' 427 MODREF = 'CC2/CHOLES' 428 CALL CC_PRPC(ECCGRS,MODREF,0, 429 * LABEL1,LABEL1,LABEL1,LABEL1, 430 * ZERO,ZERO,ZERO,1,0,0,0) 431 CALL WRIPRO(ECCGRS,MODREF,0, 432 * LABEL1,LABEL1,LABEL1,LABEL1, 433 * ZERO,ZERO,ZERO,1,0,0,0) 434 435 436 GOTO 9999 437 438 ENDIF 439C 440C------------------------ 441C Dynamic allocation. 442C------------------------ 443C 444 IF ((NSYM.NE.1) .AND. (RCCD.OR.DRCCD)) THEN 445 WRITE(LUPRI,*)'ERROR: Symmetry not yet available ', 446 & 'with RCCD, dRPA and SOSEX' 447 CALL QUIT('Symmetry not available with RCCD, dRPA and SOSEX!!!') 448 END IF 449 450 NTAMR12 = 0 451 IF ((CCD).or.(RCCD).or.(DRCCD).or.(RTCCD)) THEN 452 NTAMP = NT2AMX 453 ELSE 454 NTAMP = NT1AMX + NT2AMX 455 END IF 456 IF (LMULBS) THEN 457C add length of R12 part 458 NTAMR12 = NTR12AM(1) 459 NTAMP = NTAMP + NTAMR12 460 ENDIF 461C 462C CCRHSN assumes that T2AM can hold the cluster amplitudes 463C or the vector function in different storage schemes 464C (triangular, squared, half transformed) 465C --> R12 doubles cannot be stored directly after conv. doubles 466 KFOCKD = 1 467 KT1AM = KFOCKD + NORBTS 468 KOMEG1 = KT1AM + NT1AMX 469 KOMEG2 = KOMEG1 + NT1AM(ISYMOP) 470 KTAMP12 = KOMEG2 + NT2AMX 471 KT2AM = KOMEG2 + 472 * MAX(NTAMP,NT2AO(ISYMOP),2*NT2ORT(ISYMOP)) 473 IF ( (KTAMP12 + NTAMR12) .GT. KT2AM ) 474 * CALL QUIT('Allocation error for KTAMP12 in CCSD_ENERGY!') 475 KEND1 = KT2AM + 476 * MAX(NT2SQ(ISYMOP),(NT2AMX+NTAMR12),NT2R12(1),NTG2SQ(1)) 477 ! CCRHSN uses T2AM for a squared array. 478 ! This implies also, that we cannot store 479 ! the R12 doubles right after the doubles 480 ! before calling ccrhs. 481 IF (CCPAIR) THEN 482C Work space for printing of pair energies (WK/UniKA/21-11-2002). 483 KES = KEND1 484 KET = KES + NRHFT * (NRHFT + 1)/2 485 KQS = KET + NRHFT * (NRHFT + 1)/2 486 KQT = KQS + NRHFT * (NRHFT + 1)/2 487 KT1S = KQT + NRHFT * (NRHFT + 1)/2 488 KT1T = KT1S + NRHFT * (NRHFT + 1)/2 489 KT2S = KT1T + NRHFT * (NRHFT + 1)/2 490 KT2T = KT2S + NRHFT * (NRHFT + 1)/2 491 KEND1 = KT2T + NRHFT * (NRHFT + 1)/2 492 END IF 493 494 LWRK1 = LWORK - KEND1 495C 496 IF ( KEND1 .GT. LWORK ) THEN 497 CALL QUIT('Insufficient spaces in CCSD_ENERGY') 498 ENDIF 499C 500C------------------------------------- 501C Read canonical orbital energies. 502C------------------------------------- 503C 504 CALL GPOPEN(LUSIFC,'SIRIFC','OLD',' ','UNFORMATTED',IDUMMY, 505 & .FALSE.) 506 REWIND LUSIFC 507C 508 CALL MOLLAB('SIR IPH ',LUSIFC,LUPRI) 509 READ (LUSIFC) POTNUC,EMY,EACTIV,EMCSCF,ISTATE,ISPIN,NACTEL, 510 * LSYM,MS2 511C 512 ESCF = EMCSCF 513C 514 CALL MOLLAB('TRCCINT ',LUSIFC,LUPRI) 515 READ (LUSIFC) 516 READ (LUSIFC) (WORK(KFOCKD+I-1), I=1,NORBTS) 517C 518 CALL GPCLOSE(LUSIFC,'KEEP') 519C 520C---------------------------------------------------------- 521C Change symmetry-ordering of the Fock-matrix diagonal. 522C---------------------------------------------------------- 523C 524 IF (FROIMP .OR. FROEXP) 525 * CALL CCSD_DELFRO(WORK(KFOCKD),WORK(KEND1),LWRK1) 526C 527 CALL FOCK_REORDER(WORK(KFOCKD),WORK(KEND1),LWRK1) 528C 529C----------------------------------------------------------- 530C Calculate the ( ia | jb ) integrals and write to disk. 531C----------------------------------------------------------- 532C 533 IF (INTTR) THEN 534 CALL DZERO(WORK(KT1AM),NT1AMX) 535 LHTF = .FALSE. 536 CALL CCSD_IAJB(WORK(KT2AM),WORK(KT1AM),LHTF, 537 * .FALSE.,.FALSE.,WORK(KEND1),LWRK1) 538 REWIND(LUIAJB) 539 CALL WRITI(LUIAJB,IRAT*NT2AM(ISYMOP),WORK(KT2AM)) 540 ELSE 541 CALL DCOPY(NT2AM(ISYMOP),99.99D0,0,WORK(KT2AM),1) 542 REWIND(LUIAJB) 543 CALL READI(LUIAJB,IRAT*NT2AM(ISYMOP),WORK(KT2AM)) 544 ENDIF 545C 546C---------------------------------------------------------------------- 547C Setup the initial guess vector: 548C 1) if CCRSTR flag set try to restart from old amplitude vector 549C (ignored for MP2 calculations) 550C 2) if CCRSTR flag not set or if restart failed or if we do 551C a MP2 calculation, construct MP2 amplitude vector from 552C the integrals, which we have in memory 553C---------------------------------------------------------------------- 554C 555 IF (CCRSTR.AND.(.NOT.MP2).AND.(.NOT.DCPT2)) THEN 556 ETY1 = 'RSTAR' 557 IOPT = 33 558 CALL CC_RDRSP('R0',0,1,IOPT,MODELR,WORK(KT1AM),WORK(KT2AM)) 559 IF (IOPT.EQ.33) THEN 560 INQUIRE(FILE='CCSD_TAM',EXIST=LEXIST,IOSTAT=IOS,ERR=990) 561 IF (LEXIST) THEN ! read old CCSD_TAM file 562 LUTAM = -1 563 CALL GPOPEN(LUTAM,'CCSD_TAM','UNKNOWN',' ','UNFORMATTED', 564 * IDUMMY,.FALSE.) 565 REWIND (LUTAM) 566 WRITE(LUTAM) (WORK(KT1AM+I-1), I = 1,NT1AMX) 567 IF (.NOT.CCS) WRITE(LUTAM) (WORK(KT2AM+I-1), I = 1,NT2AMX) 568 CALL GPCLOSE(LUTAM,'KEEP') 569 IOPT = 3 570 END IF 571990 CONTINUE ! nothing to restart from ... 572 END IF 573 ENDIF 574 575 IF ( (.NOT.CCRSTR) .OR. MP2 .OR. (IOPT.EQ.33) .OR. DCPT2) THEN 576 IF (CCPAIR) THEN 577C Print MP2 pair energies (WK/UniKA/21-11-2002). 578 CALL CCSD_CBS1(WORK(KT2AM),WORK(KFOCKD), 579 * WORK(KES),WORK(KET), 580 * WORK(KQS),WORK(KQT)) 581 END IF 582 IF (CCR12.AND.CC2.AND.(IANR12.EQ.2.OR.IANR12.EQ.3)) THEN 583 LRES = .FALSE. 584 CALL CCRHS_EPPP(WORK(KT2AM),WORK(KEND1),LWRK1,APROXR12, 585 & LRES,IDUMMY,CDUMMY,IDUMMY,1) 586 END IF 587! 588!Sonia/Fran/TBP RCCD related stuff 589! 590 IF ((RCCD.OR.DRCCD) .AND. 591 * ((IT2START.EQ.-1).OR.(IT2START.EQ.1))) THEN 592 WRITE(LUPRI,*)'AMT: HERE IT2START IS',IT2START 593 IF (IT2START.EQ.-1) THEN 594 ! zero amplitudes (DEC-style initial guess) 595 CALL DZERO(WORK(KT1AM),NT1AMX) 596 CALL DZERO(WORK(KT2AM),NT2AMX) 597 ELSE IF (IT2START.EQ.1) THEN 598 ! Generate DRCCD start guess (also for RCCD) 599 KG=KEND1 600 KEND1=KG+NT2AMX 601 LWRK1=LWORK-KEND1+1 602 IF (LWRK1.LT.0) THEN 603 CALL QUIT( 604 * 'Insufficient memory in CCSD_ENERGY [RPA strt]') 605 END IF 606 CALL DSCAL(NT2AMX,2.0d0,WORK(KT2AM),1) 607 CALL DCOPY(NT2AMX,WORK(KT2AM),1,WORK(KG),1) 608 CALL DZERO(WORK(KOMEG2),NT2AMX) 609 CALL DRPA_NXTAM(WORK(KOMEG2),WORK(KT2AM),WORK(KFOCKD), 610 & WORK(KG),1.0d0,WORK(KT1AM),NT1AMX, 611 & NRHF(1),NVIR(1)) 612 CALL DZERO(WORK(KT1AM),NT1AMX) 613 KEND1=KG 614 LWRK1=LWORK-KEND1+1 615 ELSE 616 CALL QUIT('Ooops, logical error in CCSD_ENERGY [IG]') 617 END IF 618 IF (RCCD) THEN 619 ETY1 = 'RCCD ' 620 ELSE 621 IF (SOSEX) THEN 622 ETY1 = 'SOSEX' 623 ELSE 624 ETY1 = 'DRCCD' 625 END IF 626 END IF 627 IF (IPRINT .GT. 4) THEN 628 IF (IT2START.EQ.-1) THEN 629 CALL AROUND('Largest amplitudes in DEC-style guess') 630 ELSE IF (IT2START.EQ.1) THEN 631 CALL AROUND('Largest amplitudes in DRCCD guess') 632 ELSE 633 CALL QUIT('Ooops, logical error in CCSD_ENERGY [IGP]') 634 END IF 635 CALL DCOPY(NT1AMX,WORK(KT1AM),1,WORK(KOMEG1),1) 636 CALL DCOPY(NT2AMX,WORK(KT2AM),1,WORK(KOMEG1+NT1AMX),1) 637 CALL CC_PRAM(WORK(KOMEG1),PT1,1,.FALSE.) 638 ENDIF 639 ELSE 640 CALL CCSD_GUESS(WORK(KT1AM),WORK(KT2AM),WORK(KFOCKD),IPRINT) 641 IF (IPRINT .GT. 4) THEN 642 CALL AROUND('Largest amplitudes in MP2 guess') 643 CALL DCOPY(NT1AMX,WORK(KT1AM),1,WORK(KOMEG1),1) 644 CALL DCOPY(NT2AMX,WORK(KT2AM),1,WORK(KOMEG1+NT1AMX),1) 645 CALL CC_PRAM(WORK(KOMEG1),PT1,1,.FALSE.) 646 ENDIF 647 IF (DCPT2) THEN 648 ETY1 = 'DCPT2' 649 ELSE 650 ETY1 = 'MP2 ' 651 ENDIF 652 END IF 653 654 ENDIF 655C 656C----------------------------------------------------------------------- 657C START OF ITERATIVE LOOP 658C----------------------------------------------------------------------- 659C 660 EN1=0D0 661 EN2=99D0 662 EN1R12 = 0.0d0 663 EN2R12 = 0.0d0 664 LCONVG=.FALSE. 665 666!radovan: otherwise er12 and en1r12 and en2r12 become undefined if lr12 = .false. 667 er12 = 0.0d0 668 669 ITER=1 670C 671C 672 IF (LCOR .OR. LSEC ) THEN 673C 674 CALL CC_CORE(WORK(KT1AM),WORK(KT2AM),1) 675C 676 ENDIF 677C 678 !SONIA/FRAN 679 IF ((CCD).or.(RCCD).or.(DRCCD).or.(RTCCD)) THEN 680 CALL DZERO(WORK(KT1AM),NT1AMX) 681 ENDIF 682 IF (CCSTST) THEN 683 CALL DZERO(WORK(KT2AM),NT2AMX) 684 ENDIF 685C 686 IF (CCR12.AND..NOT.(CCS.OR.CIS)) THEN 687C read R12 amplitudes 688 IF (R12PRP) THEN 689 CALL DZERO(WORK(KTAMP12),NTR12AM(1)) 690 ELSE 691 IOPT = 32 692 CALL CC_RDRSP('R0 ',0,1,IOPT,MODELR,DUMMY,WORK(KTAMP12)) 693 END IF 694 END IF 695C 696 IT1 = 0 697 IF ( ETY1.EQ.'RSTAR' ) IT1 = 1 698 699 IF (DCPT2) THEN 700 CALL DCPT2_EN(WORK(KT1AM),WORK(KT2AM),WORK(KFOCKD), 701 * WORK(KTAMP12), 702 * WORK(KEND1),LWRK1,EN2,POTNUC,ESCF, 703 * ETY1,ER12,LMULBS,IT1,ITER,APROXR12) 704 ELSE 705 CALL CCSD_ECCSD(WORK(KT1AM),WORK(KT2AM),WORK(KFOCKD), 706 * WORK(KTAMP12), 707 * WORK(KEND1),LWRK1,EN2,POTNUC,ESCF, 708 * ETY1,ER12,LMULBS,IT1,ITER,APROXR12) 709 ENDIF 710C 711 EINI = EN2 712C 713CSPAS: 15.11.2009 adding AO-SOPPA 714CPi 11.08.16: Add .AND. MP2 715C----------------------------------------------- 716C For AO-SOPPA Write MP2 amplitudes to disk. 717C----------------------------------------------- 718C 719 IF (AOSOPPA .AND. MP2) THEN 720C IF (AOSOPPA) THEN 721 LUTAM = -1 722 CALL GPOPEN(LUTAM,'MP2__TAM',' ',' ','UNFORMATTED',IDUMMY, 723 & .FALSE.) 724 REWIND LUTAM 725 WRITE(LUTAM) (WORK(KT2AM+I-1), I = 1,NT2AMX) 726 CALL GPCLOSE(LUTAM,'KEEP') 727 ENDIF 728Cend-Pi 729CKeinSPASmehr 730C 731C---------------------------------------- 732C If MP2 or NOCCIT do not enter loop. 733C---------------------------------------- 734C 735 IF (MP2 .OR. NOCCIT .OR. DCPT2) GOTO 500 736C 737 IF (CCPT .OR. CCP3) THEN 738 CCSAV = CCSDT 739 CCSDT = .FALSE. 740 ENDIF 741C 742 200 CONTINUE 743C 744C--------------------------------- 745C Write amplitudes to disk. 746C--------------------------------- 747C 748 IOPT = 3 749 CALL CC_WRRSP('R0',0,1,IOPT,MODEL,DUMMY,WORK(KT1AM), 750 * WORK(KT2AM),WORK(KEND1),LWRK1) 751 IF (CCR12.AND..NOT.(CCS.OR.CIS)) THEN 752 IOPT =32 753 CALL CC_WRRSP('R0',0,1,IOPT,MODEL,DUMMY,DUMMY, 754 * WORK(KTAMP12),WORK(KEND1),LWRK1) 755 END IF 756C 757 EN1 = EN2 758 EN1R12 = ER12 759C 760 IF ( IPRINT .GT. 2 ) THEN 761 WRITE(LUPRI,249) ITER 762 249 FORMAT(/,3X,' Iteration no.:',I3) 763 WRITE(LUPRI,*)' -----------------' 764 WRITE(LUPRI,*) 765 ENDIF 766 !compute RHS of Newton, Omega_ai, Omega_aibj 767 !Sonia 768 IF ((RCCD).or.(DRCCD).or.(RTCCD)) THEN 769 CALL FLSHFO(LUPRI) 770 call CC_OMEGA2_RCCD(MODEL,WORK(KOMEG1),WORK(KOMEG2), 771 & WORK(KEND1),LWRK1) 772 else 773 CALL CCRHSN(WORK(KOMEG1),WORK(KOMEG2),WORK(KT1AM), 774 & WORK(KT2AM),WORK(KEND1),LWRK1,APROXR12) 775 end if 776C 777 240 CONTINUE 778C 779 IF (LCOR .OR. LSEC ) THEN 780 CALL CC_CORE(WORK(KOMEG1),WORK(KOMEG2),1) 781 ENDIF 782 IF (CCSTST) THEN 783 CALL DZERO(WORK(KOMEG2),NT2AMX) 784 ENDIF 785 IF ((CCD).or.(RCCD).or.(DRCCD).or.(RTCCD)) THEN 786 !Sonia & FRAN 787 CALL DZERO(WORK(KOMEG1),NT1AMX) 788 ENDIF 789C 790 IF (IPRINT .GE. 5) THEN 791 WRITE(LUPRI,529) 'Norm^2 of t1am after ccvec:', 792 * DDOT(NT1AMX,WORK(KT1AM),1,WORK(KT1AM),1) 793 WRITE(LUPRI,529) 'Norm^2 of t2am after ccvec:', 794 * DDOT(NT2AMX,WORK(KT2AM),1,WORK(KT2AM),1) 795 ENDIF 796 OMNM1 = DDOT(NT1AM(ISYMOP),WORK(KOMEG1),1,WORK(KOMEG1),1) 797 OMNM2 = DDOT(NT2AM(ISYMOP),WORK(KOMEG2),1,WORK(KOMEG2),1) 798 OMNM = DSQRT(OMNM1+OMNM2) 799 IF (IPRINT .GE. 3) THEN 800 WRITE(LUPRI,529) 'Norm^2 of omega1 after ccvec:',OMNM1 801 WRITE(LUPRI,529) 'Norm^2 of omega2 after ccvec:',OMNM2 802 END IF 803 804C 805 IF (CCSLV.OR.USE_PELIB()) THEN 806 IF (IPRINT .GE. 3) THEN 807 WRITE(LUPRI,529) 'Norm^2 of omega1 in sol. part.:', 808 * DDOT(NT1AM(ISYMOP),WORK(KOMEG1),1,WORK(KOMEG1),1) 809 WRITE(LUPRI,529) 'Norm^2 of omega2 in sol. part.:', 810 * DDOT(NT2AM(ISYMOP),WORK(KOMEG2),1,WORK(KOMEG2),1) 811 END IF 812 LUSLV = -1 813 CALL GPOPEN(LUSLV,'CC_OME','UNKNOWN',' ','UNFORMATTED', 814 * IDUMMY,.FALSE.) 815 REWIND (LUSLV) 816 WRITE(LUSLV) (WORK(KOMEG1+I-1), I = 1,NT1AMX) 817 WRITE(LUSLV) (WORK(KOMEG2+I-1), I = 1,NT2AMX) 818 CALL GPCLOSE(LUSLV,'KEEP') 819 ENDIF 820C 821 529 FORMAT(7X,A,D24.10) 822C 823 IF (NSYM.EQ.1 .AND. (RCCD.OR.DRCCD) .AND. IT2UPD.EQ.1) THEN 824 WRITE(LUPRI,'(A)') 825 & 'Using Henderson and Scuseria''s DRCCD amplitude update' 826 KG=KEND1 827 KUPDSCR=KG+NT2AMX 828 KEND1=KUPDSCR+NT1AMX 829 LWRK1=LWORK-KEND1+1 830 IF (LWRK1.LT.0) THEN 831 CALL QUIT('Insufficient memory for amplitude update') 832 END IF 833 REWIND(LUIAJB) 834 CALL READI(LUIAJB,IRAT*NT2AMX,WORK(KG)) 835 CALL DSCAL(NT2AMX,2.0d0,WORK(KG),1) 836 CALL DRPA_NXTAM(WORK(KT2AM),WORK(KOMEG2),WORK(KFOCKD), 837 * WORK(KG),1.0d0,WORK(KUPDSCR),NT1AMX, 838 * NRHF(1),NVIR(1)) 839 KEND1=KG 840 LWRK1=LWORK-KEND1+1 841 ELSE 842 IF ((NSYM.EQ.1.).AND.(RCCD.OR.DRCCD)) THEN 843 WRITE(LUPRI,'(A)') 844 & 'Using standard MP2-like amplitude update' 845 END IF 846 CALL CCSD_NXTAM(WORK(KT1AM),WORK(KT2AM),DUMMY,WORK(KOMEG1), 847 * WORK(KOMEG2),DUMMY,WORK(KFOCKD),.FALSE., 848 * ISYMOP,0.0D0) 849 END IF 850C IF (IPRINT .GE. 5) THEN 851C WRITE(LUPRI,529) 'Norm^2 of t1am after NXTAM:', 852C * DDOT(NT1AMX,WORK(KT1AM),1,WORK(KT1AM),1) 853C WRITE(LUPRI,529) 'Norm^2 of t2am after NXTAM:', 854C * DDOT(NT2AMX,WORK(KT2AM),1,WORK(KT2AM),1) 855C ENDIF 856C IF (IPRINT .GE. 3) THEN 857C WRITE(LUPRI,529) 'Norm^2 of omega1 after NXTAM:', 858C * DDOT(NT1AM(ISYMOP),WORK(KOMEG1),1,WORK(KOMEG1),1) 859C WRITE(LUPRI,529) 'Norm^2 of omega2 after NXTAM:', 860C * DDOT(NT2AM(ISYMOP),WORK(KOMEG2),1,WORK(KOMEG2),1) 861C END IF 862C ------------------------------------------------ 863C set address for singles amplitudes in DIIS 864C (have to be just before the doubles amplitudes) 865C ------------------------------------------------ 866 KTAMP1 = KT2AM - NT1AMX 867 IF ( KTAMP1 .LT. (KOMEG2+NT2AMX+NTAMR12) ) 868 * CALL QUIT('Allocation error in CCSD_ENERGY!') 869 870 IF (LMULBS) THEN 871C ----------------------------------------------------------- 872C for DIIS we put the R12 part of the vector function behind 873C the conventional doubles part 874C ----------------------------------------------------------- 875 KOMEG12 = KOMEG2 + NT2AMX 876 IF ( (KOMEG12+NTR12AM(1)) .GT. KTAMP1 ) 877 * CALL QUIT('Allocation error in CCSD_ENERGY!') 878C --------------------------------------- 879C and similar for the cluster amplitudes 880C --------------------------------------- 881 KTAMP12 = KT2AM + NT2AMX 882C -------------------------------------------------------- 883C read r12 part of the vector function and the amplitudes 884C and apply the perturbational update for the amplitudes: 885C -------------------------------------------------------- 886 LCCEQ = .TRUE. 887 CALL CC_R12NXTAM(WORK(KOMEG12),1, 888 & WORK(KTAMP12),LCCEQ, 889 & ER12,WORK(KEND1),LWRK1) 890C IF (IPRINT .GE. 5) THEN 891C WRITE(LUPRI,529) 'Norm^2 of R12amp. after NXTAM:', 892C * DDOT(NTR12AM(1),WORK(KTAMP12),1,WORK(KTAMP12),1) 893C ENDIF 894 END IF 895 896 IF (CCSTST) THEN 897 CALL DZERO(WORK(KT2AM),NT2AMX) 898 ENDIF 899 !SONIA/FRAN IF (CCD) THEN 900 IF ((CCD).or.(RCCD).or.(DRCCD).or.(RTCCD)) THEN 901 CALL CCSD_DIIS(WORK(KOMEG2),WORK(KT2AM),NTAMP,ITER) 902 ELSE 903 CALL DCOPY(NT1AMX,WORK(KT1AM),1,WORK(KTAMP1),1) 904 CALL CCSD_DIIS(WORK(KOMEG1),WORK(KTAMP1),NTAMP,ITER) 905 CALL DCOPY(NT1AMX,WORK(KTAMP1),1,WORK(KT1AM),1) 906 ENDIF 907C 908C--------------------------------- 909C The order is important !! 910C--------------------------------- 911C 912 ETY2 = MODEL(1:5)//' ' 913 IF (CCSD.OR.CCPT.OR.CCP3) ETY2 = 'CCSD ' 914 IF (CCD) ETY2 = 'CCD ' 915 IF (CCSDT) ETY2 = 'CC3 ' 916 IF (MLCC3) ETY2 = 'CC3 ' 917 IF (CC1B) ETY2 = 'CC-1b' 918 IF (CC1A) ETY2 = 'CC-1a' 919 IF (CC2) ETY2 = 'CC2 ' 920 IF (RCCD) ETY2 = 'RCCD ' 921 IF (DRCCD) ETY2 = 'DRCCD' 922 IF (SOSEX) ETY2 = 'SOSEX' 923 IF (RTCCD) ETY2 = 'RTCCD' 924 IF (DCPT2) ETY2 = 'DCPT2' 925C 926 IT1 = 1 927 CALL CCSD_ECCSD(WORK(KT1AM),WORK(KT2AM),WORK(KFOCKD), 928 * WORK(KTAMP12), 929 * WORK(KEND1),LWRK1,EN2,POTNUC,ESCF, 930 * ETY2,ER12,LMULBS,IT1,ITER, 931 * APROXR12) 932C 933 EN2R12 = ER12 934C 935 IF (CCR12.AND..NOT.(CCS.OR.CIS)) THEN 936C Save new R12 amplitudes on disk: 937 LUNIT = -1 938 CALL GPOPEN(LUNIT,FCCR12C,'UNKNOWN',' ','UNFORMATTED', 939 & IDUM,LDUM) 940 WRITE(LUNIT) (WORK(KTAMP12-1+I),I=1,NTR12AM(1)) 941 CALL GPCLOSE(LUNIT,'KEEP') 942 END IF 943C 944 CALL FLSHFO(LUPRI) 945C 946 LCONV1 = DABS(EN2-EN1) .LT. THRENR .AND. 947 & DABS(EN2R12-EN1R12).LT. THRENR 948 LCONV2 = OMNM .LT. THRVEC 949 LCONVG = LCONV1 .AND. LCONV2 950 951 ITER = ITER+1 952 IF (ITER .GT. MAXITE) THEN 953 WRITE(LUPRI,*) 'Energy not converged in ',MAXITE, 954 & ' iterations' 955 CALL QUIT('CC equations not converged.') 956 ENDIF 957C 958 NSLVINIT = NSLVINIT + 1 959C 960 IF ((CCSLV.OR.USE_PELIB()).AND.((ITER-1).GE.MXTINIT)) THEN 961 WRITE(LUPRI,241) ETY2 962 241 FORMAT(/,1x,A5, 963 * 'energy will not be converged further' 964 * //' right now in CCSLV/PE-CC calc.') 965 WRITE(LUPRI,242) NSLVINIT 966 242 FORMAT(' Accumulated inner iterations at this point are ',I5) 967C 968 ELSE 969 IF (.NOT. LCONVG) THEN 970 IF (IPRINT.GE.3 .AND. LCONV1) THEN 971 WRITE(LUPRI,'(3X,A,D15.6,A,D15.6)') 972 & 'Energy difference ',DABS(EN2-EN1), 973 & 'is less then threshold ',THRENR 974 WRITE(LUPRI,'(3X,A,A,D15.6,/,3X,A,D15.6)') 975 & 'Iterations continue, as the 2-norm of the vector ', 976 & ' function: ',OMNM, 977 & 'is larger than the threshold: ',THRVEC 978 CALL FLSHFO(LUPRI) 979 END IF 980 GOTO 200 ! go to next iteration 981 END IF 982 ENDIF 983C 984 CALL CCSD_MODEL(ETYPE,LENET,24,ETY2,5,APROXR12) 985 986 WRITE(LUPRI,250) ETYPE(1:LENET),THRENR,EN2 987 WRITE(LUPRI,'(1X,A,1P,D15.8)') 988 & 'Final 2-norm of the CC vector function: ',OMNM 989 250 FORMAT(/,1x,A,' energy converged to within ',D10.2,' is ',F25.12) 990 IF (CCR12) THEN 991 WRITE(LUPRI,'(A,D10.2,a,F16.9)') 992 & ' R12 energy converged to within ',THRENR,' is ',ER12 993 END IF 994c 995 IF (CCPAIR) THEN 996C Print CC pair energies (WK/UniKA/21-11-2002). 997 CALL CCSD_CBS2(WORK(KT1AM),WORK(KT2AM),WORK(KEND1),LWRK1, 998 * WORK(KT1S),WORK(KT1T),WORK(KT2S),WORK(KT2T), 999 * ETY2) 1000 END IF 1001C 1002C For drCCD=dRPA: check that solution is stabilizing 1003 IF (NSYM.EQ.1 .AND. DRCCD .AND. HURWITZ_CHECK) THEN 1004 REWIND(LUIAJB) 1005 CALL READI(LUIAJB,IRAT*NT2AMX,WORK(KOMEG2)) 1006 CALL DSCAL(NT2AMX,2.0d0,WORK(KOMEG2),1) 1007 IF (DRPA_ISSTABILIZINGSOLUTION(WORK(KT2AM),WORK(KOMEG2), 1008 * WORK(KFOCKD),WORK(KEND1),LWRK1, 1009 * NRHF(1),NVIR(1))) 1010 * THEN 1011 WRITE(LUPRI,'(/,1X,A,/)') 1012 * '====> Solution is stabilizing <====' 1013 ELSE 1014 WRITE(LUPRI,'(/,1X,A,/)') 1015 * '====> WARNING: Solution is not stabilizing <====' 1016 END IF 1017 CALL FLSHFO(LUPRI) 1018 END IF 1019C 1020C----------------- 1021C end of loop. 1022C----------------- 1023C 1024 1025#if defined (SYS_CRAY) 1026 CALL WCLOSE('CC_DIIS',IERR) 1027 INFO = ISHELL('rm CC_DIIS') 1028#else 1029 CALL GPCLOSE(LUTDIS,'DELETE') 1030 CALL GPCLOSE(LUSDIS,'DELETE') 1031#endif 1032C 1033C-------------------------------------------------------------- 1034C Print largest amplitudes in the zero order wave function. 1035C-------------------------------------------------------------- 1036C 1037 IF (IPRINT .GT. 2) THEN 1038C 1039 CALL AROUND('Largest amplitudes in converged solution') 1040C 1041 CALL DCOPY(NT1AMX,WORK(KT1AM),1,WORK(KOMEG1),1) 1042 CALL DCOPY(NT2AMX,WORK(KT2AM),1,WORK(KOMEG1+NT1AMX),1) 1043C 1044 CALL CC_PRAM(WORK(KOMEG1),PT1,1,.TRUE.) 1045C 1046 ENDIF 1047C 1048 500 CONTINUE 1049C 1050CSPAS 22.10.2003 implementing SOPPA(CCSD) 1051C 1052C------------------------------------------------------ 1053C Write interface to SIRIUS SOPPA response program. 1054C------------------------------------------------------ 1055C 1056 IF (SIRSOP) THEN 1057C 1058 CALL GPOPEN(LUSIFC,'SIRIFC','OLD',' ','UNFORMATTED',IDUMMY, 1059 & .FALSE.) 1060 REWIND LUSIFC 1061C 1062C 1063 IERR = -1 1064 CALL MOLLAB('MP2INFO ',LUSIFC,IERR) 1065 IF (IERR.EQ.0) THEN 1066 READ(LUSIFC) 1067 READ(LUSIFC) 1068 ELSE IF (IERR.EQ.-1) THEN 1069 REWIND LUSIFC 1070 CALL MOLLAB('EODATA ',LUSIFC,LUPRI) 1071 BACKSPACE(LUSIFC) 1072 ENDIF 1073 CALL GETDAT(CDATE,CTIME) 1074 IF (MP2) THEN 1075 WRITE(LUSIFC) '********',CDATE,CTIME,'MP2INFO ' 1076 ELSE 1077 WRITE(LUSIFC) '********',CDATE,CTIME,'CCSDINFO' 1078 ENDIF 1079C 1080 KSCR1 = KEND1 1081 KSCR2 = KSCR1 + NT2SQ(1) 1082 KSCR3 = KSCR2 + NT2SQ(1) 1083 KEND2 = KSCR3 + NORBTS*NORBTS 1084 LWRK2 = LWORK - KEND2 1085C 1086 IF (LWRK2 .LT. 0) THEN 1087 CALL QUIT('Insufficient memory in CCSD_ENERGY') 1088 ENDIF 1089C 1090 CALL CC_T2SQ(WORK(KT2AM),WORK(KSCR1),1) 1091 CALL CCRHS_T2TR(WORK(KSCR1),WORK(KEND2),LWRK2,1) 1092 CALL T2AM_REORDER(WORK(KSCR1),WORK(KSCR2),IPRINT) 1093C 1094 WRITE(LUSIFC) (WORK(KSCR2+I-1), I = 1,NT2SQ(1)) 1095C 1096C---------------------------------------------------------- 1097C Calculate density matrices D(ij), D(ab) and D(ia). 1098C---------------------------------------------------------- 1099C 1100 CALL CC_T2SQ(WORK(KT2AM),WORK(KSCR2),1) 1101C 1102 CALL SOPPA_DENSITY(WORK(KSCR3),WORK(KT1AM),WORK(KSCR2), 1103 * WORK(KSCR1),IPRINT) 1104C 1105 WRITE(LUSIFC) (WORK(KSCR3+I-1), I = 1,NORBTS*NORBTS) 1106C 1107 WRITE(LUSIFC) '********',CDATE,CTIME,'EODATA ' 1108C 1109 CALL GPCLOSE(LUSIFC,'KEEP') 1110C 1111C 1112 END IF 1113CKeinSPASmehr 1114C 1115C------------------------------------ 1116C Write final amplitudes to disk. 1117C------------------------------------ 1118C 1119 IF (CCSTST) THEN 1120 CALL DZERO(WORK(KT2AM),NT2AMX) 1121 ENDIF 1122C 1123CSPAS: 15.11.09 adding AO-SOPPA 1124CPi 11.08.16: Adding CC2 1125 IF (AOSOPPA .AND. CC2) THEN 1126 LUTAM = -1 1127 CALL GPOPEN(LUTAM,'CC2__TAM',' ',' ','UNFORMATTED',IDUMMY, 1128 & .FALSE.) 1129 REWIND LUTAM 1130 WRITE(LUTAM) (WORK(KT1AM+I-1), I = 1,NT1AMX) 1131 WRITE(LUTAM) (WORK(KT2AM+I-1), I = 1,NT2AMX) 1132 CALL GPCLOSE(LUTAM,'KEEP') 1133Cend-Pi 1134 ELSE IF (AOSOPPA .AND. CCSD) THEN 1135 LUTAM = -1 1136 CALL GPOPEN(LUTAM,'CCSD_TAM',' ',' ','UNFORMATTED',IDUMMY, 1137 & .FALSE.) 1138 REWIND LUTAM 1139 WRITE(LUTAM) (WORK(KT1AM+I-1), I = 1,NT1AMX) 1140 WRITE(LUTAM) (WORK(KT2AM+I-1), I = 1,NT2AMX) 1141 CALL GPCLOSE(LUTAM,'KEEP') 1142 ENDIF 1143CKeinSPASmehr 1144C 1145C---------------------------------- 1146C save a copy on file CCR0___0 1147C---------------------------------- 1148C 1149 KT0AM = KEND1 1150 KEND2 = KT0AM + 2*NALLAI(1) 1151 LWRK2 = LWORK - KEND2 1152 1153 IF ( LWRK2 .LT. 0 ) THEN 1154 write(lupri,*) 'LWORK, LWRK2: ',LWORK, LWRK2 1155 CALL QUIT('Insufficient spaces in CCSD_ENERGY (2)') 1156 ENDIF 1157 1158 CALL DZERO(WORK(KT0AM),2*NALLAI(1)) 1159C 1160 IOPT = 7 1161 CALL CC_WRRSP('R0',0,1,IOPT,MODEL,WORK(KT0AM),WORK(KT1AM), 1162 * WORK(KT2AM),WORK(KEND2),LWRK2) 1163C 1164C -------------------------------------------------------- 1165C for CC-R12 save also the R12 amplitudes on CCR0... file 1166C -------------------------------------------------------- 1167C 1168 !R12 amps. are still on KTAMP12 = KT2AM + NT2AMX! 1169 !do not overwrite them before! 1170 IF (CCR12) THEN 1171 IOPT=32 1172 CALL CC_WRRSP('R0 ',0,1,IOPT,MODEL,WORK(KT0AM),DUMMY, 1173 & WORK(KTAMP12),WORK(KEND2),LWRK2) 1174C 1175 END IF 1176 1177C 1178C SLV98,OC 1179C 1180 IF (CCSLV.OR.USE_PELIB()) THEN 1181 XTNCCCU = DDOT(NT2AMX,WORK(KT2AM),1,WORK(KT2AM),1) 1182 * + DDOT(NT1AMX,WORK(KT1AM),1,WORK(KT1AM),1) 1183 IF (ABS(XTNCCPR-XTNCCCU).LT.CVGTSOL) LSLTCVG = .TRUE. 1184 IF (IPRINT.GT.2) THEN 1185 WRITE(LUPRI,*)'Norm^2 of T-amplitudes in this solvent it.:', 1186 & XTNCCCU 1187 WRITE(LUPRI,*)'Norm^2 of T-amplitudes in prev solvent it.:', 1188 & XTNCCPR 1189 WRITE(LUPRI,*)'LSLTCVG: ',LSLTCVG 1190 ENDIF 1191 WRITE(LUPRI,*) 1192 * ' Change in norm^2 of T-amplitudes in this solvent it.:', 1193 * XTNCCCU-XTNCCPR 1194 XTNCCPR = XTNCCCU 1195 ENDIF 1196C 1197C 1198C --------------------- 1199C |Multi-Level CCSD(T)| 1200C --------------------- 1201C 1202 IF (MLCCSDPT) THEN 1203C 1204 CALL MLCCSDPT_DRV(ECCP,WORK,WORK,LWORK) 1205C 1206 ETOT = EN2 + ECCP 1207C 1208 END IF 1209C 1210C----------------------------------------------------- 1211C IF Triples corrections open files for integrals. 1212C----------------------------------------------------- 1213C 1214 IF (CCPT .OR. CCP3) THEN 1215C 1216C-------------------------------------------------- 1217C Calculate energy EN2 for CCSD(T) or CC(3). 1218C-------------------------------------------------- 1219C 1220 CCSDT = .TRUE. 1221C 1222 IF (.NOT. CHOPT) THEN 1223C 1224 IF (CCPT) THEN 1225 CC1BSV = CC1B 1226 CC1B = .TRUE. 1227 CC1ASV = CC1A 1228 CC1A = .TRUE. 1229 ENDIF 1230C 1231 CALL CCRHSN(WORK(KOMEG1),WORK(KOMEG2),WORK(KT1AM), 1232 * WORK(KT2AM),WORK(KEND1),LWRK1,APROXR12) 1233C 1234 IF (CCPT) THEN 1235 CC1B = CC1BSV 1236 CC1A = CC1ASV 1237 ENDIF 1238C 1239 IOPTTCME = 1 1240 CALL CCSD_TCMEPK(WORK(KT2AM),0.5d0,1,IOPTTCME) 1241 ECCP1 = TWO*DDOT(NT1AMX,WORK(KT1AM),1,WORK(KOMEG1),1) 1242 ECCP2 = TWO*DDOT(NT2AMX,WORK(KT2AM),1,WORK(KOMEG2),1) 1243C 1244 IOPT = 3 1245 CALL CC_RDRSP('R0',0,1,IOPT,MODELR,WORK(KT1AM),WORK(KT2AM)) 1246C 1247 ELSE 1248C 1249C---------------------------- 1250C Cholesky CCSD(T) 1251C---------------------------- 1252C 1253 INQUIRE(FILE='CC_CHOPT_DBG',EXIST=CPTDBG) 1254 IF (CPTDBG) THEN 1255 WRITE(LUPRI,'(//,15X,A,/,15X,A)') 1256 & '*** NOTICE ***', 1257 & 'File CC_CHOPT_DBG found. Calling CC_CHOPT_DBG.' 1258 CALL CC_CHOPT_DBG(WORK,LWORK) 1259 GOTO 9999 1260 ENDIF 1261C 1262C----------------------------------------------------------------------- 1263C NB! This assumes that the orbital energies and 1264C T1 amplitudes are in fact in these positions: 1265C----------------------------------------------------------------------- 1266C 1267 KFOCKD = 1 1268 KT1AM = KFOCKD + NORBTS 1269 KEND1 = KT1AM + NT1AMX 1270 LWRK1 = LWORK - KEND1 1271C 1272 CHOTIM = SECOND() 1273 CALL CC_CHOPT(WORK(KFOCKD),WORK(KT1AM),WORK(KEND1),LWRK1) 1274 CHOTIM = SECOND() - CHOTIM 1275 WRITE(LUPRI,9998) 'CC_CHOPT',CHOTIM 1276 9998 FORMAT(7X,'Time used in',2X,A12,2X,': ',F10.2,' seconds') 1277C 1278 ECCP1 = XEN5 1279 ECCP2 = XEN4 1280C 1281 END IF 1282C 1283 IF ( CCR3 ) THEN 1284C 1285C------------------------------------------- 1286C for perturbative correction CCT: 1287C scale vector and add to t. 1288C------------------------------------------- 1289C 1290 WRITE(LUPRI,'(/,1X,A,/)') 1291 * 'Perturbational corrected amplitudes calculated' 1292 CALL CC_VSCAL(WORK(KOMEG1),WORK(KOMEG2),ZERO, 1293 * WORK(KEND1),LWRK1,1) 1294C 1295 CALL DAXPY(NT1AM(ISYMOP),XMONE,WORK(KOMEG1),1, 1296 * WORK(KT1AM),1) 1297 CALL DAXPY(NT2AM(ISYMOP),XMONE,WORK(KOMEG2),1, 1298 * WORK(KT2AM),1) 1299C 1300 IF ( IPRINT .GT. 10 ) THEN 1301 CALL AROUND('CCSD_ENERGY: third order (T1,T2)') 1302 RHO1N = DDOT(NT1AMX,WORK(KT1AM),1,WORK(KT1AM),1) 1303 RHO2N = DDOT(NT2AMX,WORK(KT2AM),1,WORK(KT2AM),1) 1304 WRITE(LUPRI,*) 'Norm^2 of T1AM: ',RHO1N 1305 WRITE(LUPRI,*) 'Norm^2 of T2AM: ',RHO2N 1306 ENDIF 1307C 1308 IF (IPRINT .GT. 45) THEN 1309 CALL CC_PRP(WORK(KOMEG1),WORK(KOMEG2),1,1,1) 1310 ENDIF 1311C 1312 IOPT = 3 1313 CALL CC_WRRSP('R0',0,1,IOPT,MODEL,DUMMY,WORK(KT1AM), 1314 * WORK(KT2AM),WORK(KEND1),LWRK1) 1315C 1316 IF (IPRINT .GT. 4) THEN 1317C 1318 CALL AROUND('Largest amplitudes in pert. corr. ampl.') 1319C 1320 CALL DCOPY(NT1AMX,WORK(KT1AM),1,WORK(KOMEG1),1) 1321 CALL DCOPY(NT2AMX,WORK(KT2AM),1,WORK(KOMEG1+NT1AMX),1) 1322C 1323 CALL CC_PRAM(WORK(KOMEG1),PT1,1,.FALSE.) 1324C 1325 ENDIF 1326C 1327 ENDIF ! end CCR3 1328C 1329 ETOT = EN2 + ECCP1 + ECCP2 1330c IF (CCPT) THEN 1331c WRITE(LUPRI,'(20X,A,F20.10)') ' Total energy CCSD(T):',ETOT 1332c ELSE 1333c WRITE(LUPRI,'(20X,A,F20.10)') ' Total energy CC(3):',ETOT 1334c ENDIF 1335c WRITE(LUPRI,'(A,F13.10)')' T1 contribution:', ECCP1 1336c WRITE(LUPRI,'(A,F13.10)')' T2 contribution:', ECCP2 1337C 1338 CCSDT = CCSAV 1339 CCPTSV = CCPT 1340 CCP3SV = CCP3 1341 CCPT = .FALSE. 1342 CCP3 = .FALSE. 1343C 1344 IF (CCSDT) THEN 1345 ITER = 1 1346 GOTO 240 1347 ENDIF 1348C 1349 ENDIF !triples 1350C 1351C------------------------------------------------------------ 1352C Print and save (in ECCGRS) final ground state energies. 1353C------------------------------------------------------------ 1354C 1355 IF (.NOT. QM3) THEN 1356 WRITE(LUPRI,'(//)') 1357 CALL AROUND 1358 * ('Final results from the Coupled Cluster energy program') 1359 WRITE(LUPRI,'(//12X,A,A,A,F32.10,/)') 1360 & 'Total ',ETY0,' energy: ',ESCF 1361 WRITE(LURES,'(//12X,A,A,A,F32.10)') 1362 & 'Total ',ETY0,' energy: ',ESCF 1363 IF (ETY1.EQ.'RSTAR' .OR. ETY1.EQ.'MP2 ' 1364 & .OR. ETY1.EQ.'DCPT2') THEN 1365 CALL CCSD_MODEL(ETYPE,LENET,24,ETY1,5,APROXR12) 1366 WRITE(LUPRI,'(12X,A,A,A,A,F25.10,/)') 'Total ',ETYPE(1:LENET), 1367 & ' energy: ',BLANKS(1:12-LENET),EINI 1368 WRITE(LURES,'(12X,A,A,A,A,F25.10)') 'Total ',ETYPE(1:LENET), 1369 & ' energy: ',BLANKS(1:12-LENET),EINI 1370 END IF 1371C 1372 IF (RCCD) THEN 1373 !Sonia: is this needed? 1374 EMP2=EINI-ESCF 1375 ENDIF 1376 1377 IF (.NOT. (MP2 .OR. NOCCIT .OR. DCPT2)) THEN 1378 CALL CCSD_MODEL(ETYPE,LENET,24,ETY2,5,APROXR12) 1379 1380 IF (.NOT. (DRCCD.OR.RCCD.OR.RTCCD)) THEN 1381 WRITE(LUPRI,'(12X,A,A,A,A,F25.10)') 'Total ',ETYPE(1:LENET), 1382 & ' energy: ',BLANKS(1:12-LENET),EN2 1383 WRITE(LURES,'(12X,A,A,A,A,F25.10)') 'Total ',ETYPE(1:LENET), 1384 & ' energy: ',BLANKS(1:12-LENET),EN2 1385 END IF 1386! END IF 1387C 1388 IF (DRCCD) THEN 1389 IF (SOSEX) THEN 1390 WRITE(LUPRI,'(12X,A,F25.10)')'SOSEX Correlation Energy: ', 1391 & EN2-ESCF 1392 WRITE(LUPRI,'(12X,A,F25.10)')'Total SOSEX Energy: ', 1393 & EN2 1394 WRITE(LUPRI,'(12X,A,F25.10)')'DRCCD Correlation Energy: ', 1395 & ETMP-ESCF 1396 WRITE(LUPRI,'(12X,A,F25.10)')'Total DRCCD Energy: ', 1397 & ETMP 1398 WRITE(LURES,'(12X,A,F25.10)')'SOSEX Correlation Energy: ', 1399 & EN2-ESCF 1400 WRITE(LURES,'(12X,A,F25.10)')'Total SOSEX Energy: ', 1401 & EN2 1402 WRITE(LURES,'(12X,A,F25.10)')'DRCCD Correlation Energy: ', 1403 & ETMP-ESCF 1404 WRITE(LURES,'(12X,A,F25.10)')'Total DRCCD Energy: ', 1405 & ETMP 1406 ELSE 1407 WRITE(LUPRI,'(12X,A,F25.10)')'SOSEX Correlation Energy: ', 1408 & ETMP-ESCF 1409 WRITE(LUPRI,'(12X,A,F25.10)')'Total SOSEX Energy: ', 1410 & ETMP 1411 WRITE(LUPRI,'(12X,A,F25.10)')'DRCCD Correlation Energy: ', 1412 & EN2-ESCF 1413 WRITE(LUPRI,'(12X,A,F25.10)')'Total DRCCD Energy: ', 1414 & EN2 1415 WRITE(LURES,'(12X,A,F25.10)')'SOSEX Correlation Energy: ', 1416 & ETMP-ESCF 1417 WRITE(LURES,'(12X,A,F25.10)')'Total SOSEX Energy: ', 1418 & ETMP 1419 WRITE(LURES,'(12X,A,F25.10)')'DRCCD Correlation Energy: ', 1420 & EN2-ESCF 1421 WRITE(LURES,'(12X,A,F25.10)')'Total DRCCD Energy: ', 1422 & EN2 1423 END IF !sosex 1424 END IF !drccd 1425C---------------------- 1426 END IF 1427 END IF !(.NOT.QM3) 1428!----------- 1429 1430 ECCGRS = EN2 1431 1432 IF ( (.NOT.(CCSLV.OR.USE_PELIB()) .OR. (ICCSLIT.EQ.0))) THEN 1433 LABEL1 = 'ENERGY ' 1434 MODREF = 'SCF ' 1435 CALL CC_PRPC(ESCF,MODREF,0, 1436 * LABEL1,LABEL1,LABEL1,LABEL1, 1437 * ZERO,ZERO,ZERO,1,0,0,0) 1438 ENDIF 1439 IF (.NOT.(CCSLV.OR.USE_PELIB())) THEN 1440 LABEL1 = 'ENERGY ' 1441 CALL CC_PRPC(EN2,MOPRPC,0, 1442 * LABEL1,LABEL1,LABEL1,LABEL1, 1443 * ZERO,ZERO,ZERO,1,0,0,0) 1444 IF (CCPTSV .OR. CCP3SV) THEN 1445 CALL WRIPRO(ETOT,MOPRPC,0, 1446 * LABEL1,LABEL1,LABEL1,LABEL1, 1447 * ZERO,ZERO,ZERO,1,0,0,0) 1448 ELSE 1449 CALL WRIPRO(EN2,MOPRPC,0, 1450 * LABEL1,LABEL1,LABEL1,LABEL1, 1451 * ZERO,ZERO,ZERO,1,0,0,0) 1452 ENDIF 1453 ENDIF 1454C 1455 IF (MLCCSDPT) THEN 1456 WRITE(LUPRI,'(//,21X,A)') 'Perturbative triples corrections' 1457 WRITE(LUPRI,'(21X,A,/)') '--------------------------------' 1458 WRITE(LUPRI,'(12X,A,F25.10)') 1459 * 'MLCCSD(T) energy correction:', ECCP 1460 WRITE(LURES,'(//,21X,A)') 'Perturbative triples corrections' 1461 WRITE(LURES,'(21X,A,/)') '--------------------------------' 1462 WRITE(LURES,'(12X,A,F25.10)') 1463 * 'MLCCSD(T) energy correction:', ECCP 1464 WRITE(LUPRI,'(/,12X,A,F31.10)') 'Total energy MLCCSD(T):',ETOT 1465 WRITE(LURES,'(/,12X,A,F31.10)') 'Total energy MLCCSD(T):',ETOT 1466 ENDIF 1467C 1468 IF (CCPTSV .OR. CCP3SV) THEN 1469 WRITE(LUPRI,'(//,21X,A)') 'Perturbative triples corrections' 1470 WRITE(LUPRI,'(21X,A,/)') '--------------------------------' 1471 WRITE(LUPRI,'(12X,A,F25.10)') 1472 * 'The E4 doubles and triples:', ECCP2 1473 WRITE(LUPRI,'(12X,A,F25.10)') 1474 * 'The E5 singles and triples:', ECCP1 1475 WRITE(LURES,'(//,21X,A)') 'Perturbative triples corrections' 1476 WRITE(LURES,'(21X,A,/)') '--------------------------------' 1477 WRITE(LURES,'(12X,A,F25.10)') 1478 * 'The E4 doubles and triples:', ECCP2 1479 WRITE(LURES,'(12X,A,F25.10)') 1480 * 'The E5 singles and triples:', ECCP1 1481 IF (CCPTSV.AND..NOT.CCR12) THEN 1482 WRITE(LUPRI,'(/,12X,A,F31.10)') 'Total energy CCSD(T):',ETOT 1483 WRITE(LURES,'(/,12X,A,F31.10)') 'Total energy CCSD(T):',ETOT 1484 ELSE IF ((CCPTSV.AND.CCR12).AND.(IANR12.EQ.1)) THEN 1485 WRITE(LUPRI,'(/,12X,A,A,A,F23.10)') 1486 & 'Total CCSD(R12)(T)/',APROXR12,'energy:',ETOT 1487 WRITE(LURES,'(/,12X,A,A,A,F23.10)') 1488 & 'Total CCSD(R12)(T)/',APROXR12,'energy:',ETOT 1489 ELSE IF ((CCP3SV.AND.CCR12).AND.(IANR12.EQ.1)) THEN 1490 WRITE(LUPRI,'(/,12X,3A,F25.10)') 'Total CC(3)(R12)/', 1491 & APROXR12,'energy:',ETOT 1492 WRITE(LURES,'(/,12X,3A,F25.10)') 'Total CC(3)(R12)/', 1493 & APROXR12,'energy:',ETOT 1494 ELSE IF (CCP3SV.AND..NOT.CCR12) THEN 1495 WRITE(LUPRI,'(/,12X,A,F31.10)') 'Total energy CC(3): ',ETOT 1496 WRITE(LURES,'(/,12X,A,F31.10)') 'Total energy CC(3): ',ETOT 1497 ENDIF 1498 ECCGRS = ETOT 1499 END IF 1500C 1501 CCP3 = CCP3SV 1502 CCPT = CCPTSV 1503 1504 IF (RCCD) THEN 1505 ECRCCD=(EN2-ESCF) 1506 END IF 1507 IF (RTCCD) THEN 1508C IF (WDFTMP.NE.0.0d0) THEN 1509C ECRTCCD=WDFTMP*ECRTCCD 1510C ELSE 1511C ECRTCCD=XRTCCD_CORR 1512 ECRTCCD=XRTCCD 1513C ENDIF 1514C WRITE(LUPRI,*)'AMT: Scaled ? RTCCD E', 1515C & ECRTCCD 1516C WRITE(LUPRI,*)'SCF Energy:',ESCF 1517C WRITE(LUPRI,*)'RCCD Corr. Energy:',ECRCCD 1518C WRITE(LUPRI,*)'RTCCD Corr. Energy:',ECRTCCD 1519C WRITE(LUPRI,*)'Total RPA Corr. Energy:', 1520C & (ECRCCD+3.0d0*ECRTCCD)/2.0d0 1521 ECCGRS = ESCF + (ECRCCD + 3.0d0*ECRTCCD)/2.0d0 1522C WRITE(LUPRI,*)'RPA SCF+(RCCD+3*RTCCD)/2 Energy:', 1523C & ECCGRS 1524 ENDIF 1525 1526 1527C 1528C======================================================= 1529C Calculate Intermediates for response calculations: 1530C 1531C for cc2: E-intermediates 1532C 1533C for ccsd also: 1534C 1535C BF intermediate in ao., 1536C C & D intermediates, 1537C Gamma intermediates. 1538C 1539C OC 26-7-1995 1540C======================================================= 1541C 1542 IF (RSPIM2.AND.(.NOT.IMSKIP)) THEN 1543C 1544 RSPIM = RSPIM2 1545C 1546 WRITE(LUPRI,'(/)') 1547 CALL AROUND( 'Calculating singlet intermediates for CCLR ') 1548 WRITE(LUPRI,'(/)') 1549C 1550 MLCCSAVE = MLCC3 1551 MLCC3 = .FALSE. 1552C 1553 CCSAV = CCSDT 1554 CCSDT = .FALSE. 1555 1556 if ((RCCD).or.(DRCCD).or.(RTCCD)) then 1557 write(lupri,*)'RCCD/RPA: Skip RHSN to compute intermediates' 1558 else 1559 CALL CCRHSN(WORK(KOMEG1),WORK(KOMEG2),WORK(KT1AM),WORK(KT2AM), 1560 * WORK(KEND1),LWRK1,APROXR12) 1561C 1562 IF (IPRINT .GT. 1) WRITE(LUPRI,'(/)') 1563 WRITE(LUPRI,'(12X,A)') 'E-intermediates calculated ' 1564 WRITE(LUPRI,'(12X,A)') 'Fock-intermediate calculated ' 1565C 1566 IF (.NOT. CC2 ) THEN 1567C 1568 WRITE(LUPRI,'(12X,A)') 'Gamma-intermediate calculated ' 1569 WRITE(LUPRI,'(12X,A)') 'BF-intermediate calculated ' 1570 WRITE(LUPRI,'(12X,A)') 'C-intermediate calculated ' 1571 WRITE(LUPRI,'(12X,A)') 'D-intermediate calculated ' 1572C 1573 ENDIF 1574 end if 1575 1576 CCSDT = CCSAV 1577C 1578 MLCC3 = MLCCSAVE 1579C 1580 WRITE(LUPRI,'(/)') 1581C 1582 ELSE IF (RSPIM2.AND.IMSKIP) THEN 1583C 1584 RSPIM = RSPIM2 1585 WRITE(LUPRI,'(12X,A)') 1586 & 'Intermediates assumed to be restart IM. ' 1587C 1588 ENDIF 1589! 1590!---------------------------------------------------- 1591! 1592! Calculate the triplet global intermediates. 1593! 1594!---------------------------------------------------- 1595! 1596 IF (TRIPIM .AND. (.NOT.IMSKIP) .AND. (.NOT.(CCS.OR.CC2))) THEN 1597! 1598 RSPIM = RSPIM2 1599! 1600 WRITE(LUPRI,'(/)') 1601 CALL AROUND( 'Calculating triplet intermediates for CCLR ') 1602 WRITE(LUPRI,'(/)') 1603! 1604 CALL CCRHSN3(WORK,LWORK) 1605! 1606 WRITE(LUPRI,'(12X,A)') 1607 & 'Triplet D and CD intermediate calculated ' 1608! 1609 ENDIF 1610 1611C------------------------------------------------------------ 1612C Precompute intermediates needed for CC-R12 left transf. 1613C------------------------------------------------------------ 1614 IF (CCR12LIM .AND. .NOT.(CCS.OR.CC2)) THEN 1615C 1616 KT1AM = 1 1617 KLAMDP = KT1AM + NT1AMX 1618 KLAMDH = KLAMDP + NLAMDT 1619 KVABKL = KLAMDH + NLAMDT 1620 KEND1 = KVABKL + NVABKL(1) 1621 LWRK1 = LWORK - KEND1 1622 IF (LWRK1.LT.0) 1623 & CALL QUIT('Insufficient memory for VABKL in CCSD_ENERGY') 1624C 1625 IOPT = 1 1626 CALL CC_RDRSP('R0 ',0,1,IOPT,MODELR,WORK(KT1AM),DUMMY) 1627 CALL LAMMAT(WORK(KLAMDP),WORK(KLAMDH),WORK(KT1AM), 1628 & WORK(KEND1),LWRK1) 1629C 1630 LUNIT = -1 1631 CALL GPOPEN(LUNIT,FVABKL,'OLD',' ','UNFORMATTED',IDUM,.FALSE.) 1632 READ(LUNIT)(WORK(KVABKL+I-1),I=1,NVABKL(1)) 1633 CALL GPCLOSE(LUNIT,'KEEP') 1634C 1635 ! calculate V_(\tilde{a} \tilde{b})^(kl) and save on disk: 1636 IOPT = 1 1637 CALL CC_R12MKVIRT(WORK(KVABKL),WORK(KLAMDP),1,WORK(KLAMDP),1, 1638 & 'R12VCTDTKL',IOPT,WORK(KEND1),LWRK1) 1639 END IF 1640C-------------------------------------------------- 1641C Precompute some integrals and amplitudes for 1642C the CC3 noddy response code: 1643C-------------------------------------------------- 1644 IF (NODDY_INIT) THEN 1645 CALL CCSDT_INIT_NODDY(WORK,LWORK,.FALSE.) 1646 END IF 1647 1648 9999 CALL QEXIT('CCSD_ENERGY') 1649C 1650 RETURN 1651 1817 CALL QUIT('R12 amplitudes not found on disk') 1652 END 1653C /* Deck ccsd_guess */ 1654 SUBROUTINE CCSD_GUESS(T1AM,T2AM,FCDIAG,IPRINT) 1655C 1656C Written by Henrik Koch 27-Mar-1990. 1657C 1658#include "implicit.h" 1659 PARAMETER (ZERO = 0.0D0, TWO = 2.0D0, THREE = 3.0D0) 1660 DIMENSION T1AM(*),T2AM(*) 1661 DIMENSION FCDIAG(*) 1662#include "priunit.h" 1663#include "ccorb.h" 1664#include "ccsdsym.h" 1665C 1666 INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 1667C 1668 CALL QENTER('CCSD_GUESS') 1669C 1670C------------------------------------- 1671C Initial guess for t1 amplitudes. 1672C------------------------------------- 1673C 1674 CALL DZERO(T1AM,NT1AMX) 1675C 1676C------------------------------------- 1677C Initial guess for t2 amplitudes. 1678C------------------------------------- 1679C 1680 DO 100 ISYMBJ = 1,NSYM 1681 ISYMAI = ISYMBJ 1682 DO 110 ISYMJ = 1,NSYM 1683 ISYMB = MULD2H(ISYMJ,ISYMBJ) 1684 DO 120 ISYMI = 1,NSYM 1685 ISYMA = MULD2H(ISYMI,ISYMAI) 1686 DO 130 J = 1,NRHF(ISYMJ) 1687 KOFFJ = IRHF(ISYMJ) + J 1688 DO 140 B = 1,NVIR(ISYMB) 1689 KOFFB = IVIR(ISYMB) + B 1690 NBJ = IT1AM(ISYMB,ISYMJ)+NVIR(ISYMB)*(J-1)+B 1691 DO 150 I = 1,NRHF(ISYMI) 1692 KOFFI = IRHF(ISYMI) + I 1693 DO 160 A = 1,NVIR(ISYMA) 1694 KOFFA = IVIR(ISYMA) + A 1695 NAI = IT1AM(ISYMA,ISYMI)+NVIR(ISYMA)*(I-1)+A 1696C 1697 IF (NAI .GT. NBJ) GOTO 160 1698C 1699 NAIBJ = IT2AM(ISYMAI,ISYMBJ) + INDEX(NAI,NBJ) 1700C 1701 T2AM(NAIBJ) = T2AM(NAIBJ)/ 1702 * (FCDIAG(KOFFI) + FCDIAG(KOFFJ) 1703 * - FCDIAG(KOFFA) - FCDIAG(KOFFB)) 1704C 1705 160 CONTINUE 1706 150 CONTINUE 1707 140 CONTINUE 1708 130 CONTINUE 1709 120 CONTINUE 1710 110 CONTINUE 1711 100 CONTINUE 1712C 1713 IF (IPRINT .GT. 15) THEN 1714 CALL AROUND('T1 Guess vector') 1715 DO 200 ISYMI = 1,NSYM 1716 ISYMA = ISYMI 1717 KOFF = IT1AM(ISYMA,ISYMI) + 1 1718 NVIRA = NVIR(ISYMA) 1719 NRHFI = NRHF(ISYMI) 1720 CALL OUTPUT(T1AM(KOFF),1,NVIRA,1,NRHFI,NVIRA,NRHFI,1,LUPRI) 1721 200 CONTINUE 1722C 1723 CALL AROUND('T2 Guess vector') 1724 DO 250 ISYMBJ = 1,NSYM 1725 ISYMAI = ISYMBJ 1726 KOFF = IT2AM(ISYMAI,ISYMBJ) + 1 1727 NTOTAI = NT1AM(ISYMAI) 1728 CALL OUTPAK(T2AM(KOFF),NTOTAI,1,LUPRI) 1729 250 CONTINUE 1730 ENDIF 1731C 1732 CALL QEXIT('CCSD_GUESS') 1733C 1734 RETURN 1735 END 1736!----------- 1737C /* Deck drpa_nxtam */ 1738 Subroutine dRPA_NxtAm(T2Am,Omega2,OrbEn,g,alpha,Work,lWork,o,v) 1739C 1740C Thomas Bondo Pedersen, May 2011. 1741C 1742C Compute updated doubles amplitudes according to the appendix of 1743C Henderson and Scuseria, Mol. Phys. 108, 2511-2517 (2010) 1744C Intended for drCCD (=dRPA): 1745C Omega2(ai,bj) <-- T2Am(ai,bj) 1746C - alpha/2 * Omega2(ai,bj)/(G(ai,ai)-G(bj,bj)) 1747C G(ai,ai)=OrbEn(o+a)-OrbEn(i) 1748C +g(ai,ai) + 2*sum_bj T2Am(ai,bj)*g(ai,bj) 1749C 1750C On input, 1751C T2Am: current doubles amplitudes (packed, LT storage) 1752C Omega2: omega vector computed with T2Am (packed, LT storage) 1753C OrbEn: orbital energies (occupied then virtual) 1754C g: 2*(ai|bj) integrals (packed, LT storage) 1755C alpha: scaling constant 1756C Work(lWork): work space (lWork >= v*o) 1757C o: number of occupied orbitals 1758C v: number of virtual orbitals 1759C On exit, only Omega2 has changed: 1760C Omega2: updated doubles amplitudes 1761C 1762C NOTE: symmetry is not treated in this routine (but can be handled 1763C by calling it for each symmetry block). 1764C 1765 Implicit None 1766 Integer lWork, o, v 1767 Real*8 T2Am(*), Omega2(*) 1768 Real*8 OrbEn(o+v) 1769 Real*8 g(*) 1770 Real*8 alpha 1771 Real*8 Work(lWork) 1772 1773 Integer vo 1774 Integer ai, bj, aibj 1775 1776 Integer m, n 1777 Integer iTri, Occ, Vir 1778 Real*8 del 1779 iTri(m,n) = max(m,n)*(max(m,n)-3)/2+m+n 1780 Vir(m)=mod(m-1,v)+1 1781 Occ(m)=(m-Vir(m))/v+1 1782 del(m)=OrbEn(o+Vir(m))-OrbEn(Occ(m)) 1783 1784 ! Check memory 1785 vo=v*o 1786 If (vo.lt.1) Return 1787 If (lWork.lt.vo) Then 1788 Call Quit('Insufficient memory in dRPA_NxtAm') 1789 End If 1790 1791 ! Compute 2*G(ai,ai) 1792 Do ai=1,vo 1793 Work(ai)=0.0d0 1794 Do bj=1,vo 1795 aibj=iTri(ai,bj) 1796 Work(ai)=Work(ai)+T2Am(aibj)*g(aibj) 1797 End Do 1798 Work(ai)=2.0d0*(del(ai)+g(iTri(ai,ai))+2.0d0*Work(ai)) 1799 End Do 1800 1801 ! Compute updated amplitudes 1802 aibj=0 1803 Do ai=1,vo 1804 Do bj=1,ai 1805 aibj=aibj+1 1806 Omega2(aibj)=T2Am(aibj) 1807 & -alpha*Omega2(aibj)/(Work(ai)+Work(bj)) 1808 End Do 1809 End Do 1810 1811 End 1812!----------- 1813C /* Deck ccsd_nxtam */ 1814 SUBROUTINE CCSD_NXTAM(T1AM,T2AM,T2AM2,OMEGA1,OMEGA2,OMEGA22, 1815 * FCDIAG,TRIPLET,ISYMT,FREQ) 1816C 1817C Written by Henrik Koch 27-Mar-1990. 1818C Brueckner bit by Rika Kobayashi 1992. 1819C 1820#include "implicit.h" 1821 PARAMETER (ZERO = 0.0D0, TWO = 2.0D0, THREE = 3.0D0) 1822 DIMENSION T1AM(*),T2AM(*), T2AM2(*) 1823 DIMENSION OMEGA1(*),OMEGA2(*), OMEGA22(*) 1824 DIMENSION FCDIAG(*) 1825#include "priunit.h" 1826#include "ccorb.h" 1827#include "ccsdsym.h" 1828Cholesky 1829#include "ccsdinp.h" 1830#include "maxorb.h" 1831#include "ccdeco.h" 1832Cholesky 1833C 1834 LOGICAL TRIPLET 1835C 1836 INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 1837C 1838 CALL QENTER('CCSD_NXTAM') 1839C 1840c IF (.NOT. (CCD.OR.LBRUK)) THEN 1841C 1842 DO 100 ISYMI = 1,NSYM 1843 ISYMA = MULD2H(ISYMT,ISYMI) 1844 DO 110 I = 1,NRHF(ISYMI) 1845 KOFFI = IRHF(ISYMI) + I 1846 DO 120 A = 1,NVIR(ISYMA) 1847C 1848 KOFFA = IVIR(ISYMA) + A 1849 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + A 1850C 1851 OMEGA1(NAI) = T1AM(NAI) + OMEGA1(NAI)/ 1852 * (FREQ + FCDIAG(KOFFI) - FCDIAG(KOFFA)) 1853C 1854 120 CONTINUE 1855 110 CONTINUE 1856 100 CONTINUE 1857C 1858c ENDIF 1859c IF (LBRUK) CALL DCOPY(NVIRT*NRHFT,OMEGA1,1,T1AM,1) 1860C 1861C 1862 IF (CC2 .AND. CHOINT) GOTO 1000 ! Skip doubles part for Cholesky CC2. 1863C 1864 DO 200 ISYMBJ = 1,NSYM 1865 ISYMAI = MULD2H(ISYMBJ,ISYMT) 1866 IF (ISYMAI .LE. ISYMBJ) THEN 1867 DO 210 ISYMJ = 1,NSYM 1868 ISYMB = MULD2H(ISYMJ,ISYMBJ) 1869 DO 220 ISYMI = 1,NSYM 1870 ISYMA = MULD2H(ISYMI,ISYMAI) 1871 DO 230 J = 1,NRHF(ISYMJ) 1872 KOFFJ = IRHF(ISYMJ) + J 1873 DO 240 B = 1,NVIR(ISYMB) 1874 KOFFB = IVIR(ISYMB) + B 1875 NBJ = IT1AM(ISYMB,ISYMJ)+NVIR(ISYMB)*(J-1)+B 1876 DO 250 I = 1,NRHF(ISYMI) 1877 KOFFI = IRHF(ISYMI) + I 1878 DO 260 A = 1,NVIR(ISYMA) 1879 KOFFA = IVIR(ISYMA) + A 1880 NAI = IT1AM(ISYMA,ISYMI)+NVIR(ISYMA)*(I-1)+A 1881C 1882 IF (ISYMAI.EQ.ISYMBJ .AND. NAI.LE.NBJ) THEN 1883 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 1884 * + INDEX(NAI,NBJ) 1885 OMEGA2(NAIBJ) = T2AM(NAIBJ)+OMEGA2(NAIBJ)/ 1886 * (FREQ + 1887 * FCDIAG(KOFFI) + FCDIAG(KOFFJ) 1888 * - FCDIAG(KOFFA) - FCDIAG(KOFFB)) 1889 ELSE IF (ISYMAI.LT.ISYMBJ) THEN 1890 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 1891 * + NT1AM(ISYMAI)*(NBJ-1) + NAI 1892 OMEGA2(NAIBJ) = T2AM(NAIBJ)+OMEGA2(NAIBJ)/ 1893 * (FREQ + 1894 * FCDIAG(KOFFI) + FCDIAG(KOFFJ) 1895 * - FCDIAG(KOFFA) - FCDIAG(KOFFB)) 1896 ENDIF 1897C 1898C 1899 260 CONTINUE 1900 250 CONTINUE 1901 240 CONTINUE 1902 230 CONTINUE 1903 220 CONTINUE 1904 210 CONTINUE 1905 ENDIF 1906 200 CONTINUE 1907C 1908C Do second double block if triplet. 1909C 1910C 1911 IF (TRIPLET) THEN 1912C 1913 DO ISYMBJ = 1,NSYM 1914 ISYMAI = MULD2H(ISYMBJ,ISYMT) 1915 IF (ISYMAI .LE. ISYMBJ) THEN 1916 DO ISYMJ = 1,NSYM 1917 ISYMB = MULD2H(ISYMJ,ISYMBJ) 1918 DO ISYMI = 1,NSYM 1919 ISYMA = MULD2H(ISYMI,ISYMAI) 1920 DO J = 1,NRHF(ISYMJ) 1921 KOFFJ = IRHF(ISYMJ) + J 1922 DO B = 1,NVIR(ISYMB) 1923 KOFFB = IVIR(ISYMB) + B 1924 NBJ = IT1AM(ISYMB,ISYMJ)+NVIR(ISYMB)*(J-1)+B 1925 DO I = 1,NRHF(ISYMI) 1926 KOFFI = IRHF(ISYMI) + I 1927 DO A = 1,NVIR(ISYMA) 1928 KOFFA = IVIR(ISYMA) + A 1929 NAI = IT1AM(ISYMA,ISYMI)+NVIR(ISYMA)*(I-1)+A 1930C 1931 IF (ISYMAI.EQ.ISYMBJ .AND. NAI.LE.NBJ) THEN 1932 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 1933 * + INDEX(NAI,NBJ) 1934 OMEGA22(NAIBJ)=T2AM2(NAIBJ)+OMEGA22(NAIBJ)/ 1935 * (FREQ + 1936 * FCDIAG(KOFFI) + FCDIAG(KOFFJ) 1937 * - FCDIAG(KOFFA) - FCDIAG(KOFFB)) 1938 ELSE IF (ISYMAI.LT.ISYMBJ) THEN 1939 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 1940 * + NT1AM(ISYMAI)*(NBJ-1) + NAI 1941 OMEGA22(NAIBJ)=T2AM2(NAIBJ)+OMEGA22(NAIBJ)/ 1942 * (FREQ + 1943 * FCDIAG(KOFFI) + FCDIAG(KOFFJ) 1944 * - FCDIAG(KOFFA) - FCDIAG(KOFFB)) 1945 ENDIF 1946C 1947C 1948 END DO 1949 END DO 1950 END DO 1951 END DO 1952 END DO 1953 END DO 1954 ENDIF 1955 END DO 1956 ENDIF 1957C 1958 1000 CONTINUE 1959 CALL QEXIT('CCSD_NXTAM') 1960C 1961 RETURN 1962 END 1963C /* Deck ccsd_eccsd */ 1964 SUBROUTINE CCSD_ECCSD(T1AM,T2AM,FCDIAG,TAMR12, 1965 * WORK,LWORK,XECCSD,POTNUC, 1966 * ESCF,ETY,ER12,LR12,IT1,ITER, 1967 * APROXR12) 1968C 1969C Written by Henrik Koch 27-Mar-1990. 1970C 1971C Ove Christiansen 23-1-1996: Introduction of Finite field contribution. 1972C IT1 = 0 : no amplitudes on disk 1973C IT1 = 1 : t1 amplitudes read from disk 1974C 1975C Bug fix for frozen core in finite field calculations, 1976C C.Haettig, 23.3.05 1977C 1978#include "implicit.h" 1979#include "priunit.h" 1980#include "dummy.h" 1981 PARAMETER (ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0) 1982#include "iratdef.h" 1983 DIMENSION FCDIAG(*) 1984 DIMENSION T1AM(*),T2AM(*),TAMR12(*),WORK(*) 1985 CHARACTER ETY*5, ETYPE*24, MODEL*10 1986 CHARACTER*(*) APROXR12 1987 LOGICAL LEXIST, LR12, LOCDBG 1988 PARAMETER (LOCDBG = .FALSE.) 1989 INTEGER ICMO(8,8), NCMO(8), IGLMRHS(8,8), IGLMVIS(8,8), NGLMDS(8) 1990#include "ccorb.h" 1991#include "ccsdsym.h" 1992#include "ccsdinp.h" 1993#include "ccfield.h" 1994#include "ccinftap.h" 1995#include "r12int.h" 1996#include "ccr12int.h" 1997 1998C 1999 INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 2000C 2001 CALL QENTER('CCSD_ECCSD') 2002C 2003 XECCSD = ESCF 2004 !SONIA TO FRAN 2005 XDRCCD = ESCF 2006 XRTCCD = ESCF 2007 2008C 2009C--------------------------------- 2010C Dynamic allocation of space. 2011C--------------------------------- 2012C 2013 KIAJB = 1 2014 KEND1 = KIAJB + NT2AMX 2015 LWRK1 = LWORK - KEND1 2016C 2017 IF (LWRK1 .LT. 0) THEN 2018 CALL QUIT('Insufficient spaces in ECCSD') 2019 ENDIF 2020C 2021 REWIND(LUIAJB) 2022 CALL READI(LUIAJB,IRAT*NT2AMX,WORK) 2023C 2024 DO 100 ISYMJ = 1,NSYM 2025 DO 110 ISYMB = 1,NSYM 2026 ISYMBJ = MULD2H(ISYMB,ISYMJ) 2027 ISYMAI = ISYMBJ 2028 DO 120 ISYMI = 1,NSYM 2029 ISYMBI = MULD2H(ISYMB,ISYMI) 2030 ISYMA = MULD2H(ISYMI,ISYMAI) 2031 ISYMAJ = ISYMBI 2032C 2033 DO 130 J = 1,NRHF(ISYMJ) 2034 DO 140 B = 1,NVIR(ISYMB) 2035C 2036 KBJ = IT1AM(ISYMB,ISYMJ) 2037 NBJ = KBJ + NVIR(ISYMB)*(J-1) + B 2038C 2039 DO 150 I = 1,NRHF(ISYMI) 2040C 2041 KBI = IT1AM(ISYMB,ISYMI) 2042 NBI = KBI + NVIR(ISYMB)*(I-1) + B 2043C 2044 DO 160 A = 1,NVIR(ISYMA) 2045C 2046 KAI = IT1AM(ISYMA,ISYMI) 2047 NAI = KAI + NVIR(ISYMA)*(I-1) + A 2048 KAJ = IT1AM(ISYMA,ISYMJ) 2049 NAJ = KAJ + NVIR(ISYMA)*(J-1) + A 2050C 2051 NAIBJ = IT2AM(ISYMAI,ISYMBJ) + INDEX(NAI,NBJ) 2052 NAJBI = IT2AM(ISYMAJ,ISYMBI) + INDEX(NAJ,NBI) 2053C 2054 IF (ISYMB .EQ. ISYMJ) THEN 2055 XECCSD = XECCSD 2056 * + (TWO*WORK(NAIBJ) - WORK(NAJBI))* 2057 * (T2AM(NAIBJ) + T1AM(NAI)*T1AM(NBJ)) 2058 !SONIA TO FRAN 2059 !DRCCD energy is 2Coulomb*T^drccd 2060 if (DRCCD) then 2061 XDRCCD = XDRCCD 2062 * + (TWO*WORK(NAIBJ))* 2063 * (T2AM(NAIBJ) + T1AM(NAI)*T1AM(NBJ)) 2064 end if 2065 if (RTCCD) then 2066 !RTCCD energy is -Exchange*T^rtccd 2067 XRTCCD = XRTCCD 2068 * + (-WORK(NAJBI))* 2069 * (T2AM(NAIBJ) + T1AM(NAI)*T1AM(NBJ)) 2070 end if 2071 ELSE 2072 XECCSD = XECCSD 2073 * + (TWO*WORK(NAIBJ) - WORK(NAJBI))*T2AM(NAIBJ) 2074 !SONIA TO FRAN 2075 if (DRCCD) then 2076 XDRCCD = XDRCCD 2077 * + (TWO*WORK(NAIBJ))*T2AM(NAIBJ) 2078 end if 2079 if (RTCCD) then 2080 XRTCCD = XRTCCD 2081 * + (-WORK(NAJBI))*T2AM(NAIBJ) 2082 end if 2083 ENDIF 2084C 2085 160 CONTINUE 2086 150 CONTINUE 2087 140 CONTINUE 2088 130 CONTINUE 2089 120 CONTINUE 2090 110 CONTINUE 2091 100 CONTINUE 2092C 2093C------------------------------------------------------------------- 2094C Add field dependent energy in case of finite field ONEelectron 2095C Perturbation. The AO integral from ONEP is already scaled with 2096C the fieldstrengths!!! 2097C------------------------------------------------------------------- 2098C 2099 DO 13 IF = 1, NFIELD 2100 IF (NONHF) THEN 2101C 2102 DO ISYM = 1, NSYM 2103 ICOUNT = 0 2104 ICOUNT3 = 0 2105 DO ISYM2 = 1, NSYM 2106 ISYM1 = MULD2H(ISYM,ISYM2) 2107 ICMO(ISYM1,ISYM2) = ICOUNT 2108 ICOUNT = ICOUNT + NBAS(ISYM1)*NORBS(ISYM2) 2109 ICOUNT3 = ICOUNT3 + NBAS(ISYM1)*NRHFS(ISYM2) 2110 END DO 2111 NCMO(ISYM) = ICOUNT 2112 NGLMDS(ISYM) = ICOUNT 2113 2114 ICOUNT2 = 0 2115 DO ISYM2 = 1, NSYM 2116 ISYM1 = MULD2H(ISYM,ISYM2) 2117 IGLMRHS(ISYM1,ISYM2) = ICOUNT2 2118 IGLMVIS(ISYM1,ISYM2) = ICOUNT3 2119 ICOUNT2 = ICOUNT2 + NBAS(ISYM1)*NRHFS(ISYM2) 2120 ICOUNT3 = ICOUNT3 + NBAS(ISYM1)*NVIRS(ISYM2) 2121 END DO 2122 END DO 2123C 2124 KONEP = 1 2125 KT1AM = KONEP + N2BST(ISYMOP) 2126 KLAMDPS= KT1AM + NT1AMX 2127 KLAMDHS= KLAMDPS+ NGLMDS(1) 2128 KEND1 = KLAMDHS+ NGLMDS(1) 2129 LWRK1 = LWORK - KEND1 2130 IF ( LWRK1 .LT. 0 ) 2131 * CALL QUIT(' Too little workspace in ccsd_eccsd-2') 2132C 2133 CALL DZERO(WORK(KONEP),N2BST(ISYMOP)) 2134 FF = EFIELD(IF) 2135 CALL CC_ONEP(WORK(KONEP),WORK(KEND1),LWRK1,FF,1,LFIELD(IF)) 2136C 2137 IF (.NOT.(CCS.OR.CCP2)) THEN 2138C 2139 IF ( IT1 .EQ. 1 ) THEN 2140 IOPT = 1 2141 CALL CC_RDRSP('R0',0,1,IOPT,MODEL,WORK(KT1AM),DUMMY) 2142 ELSE IF (IT1 .EQ. 0) THEN 2143 CALL DZERO(WORK(KT1AM),NT1AMX) 2144 ELSE 2145 CALL QUIT('IT1 should be 0 or 1 in ccsd_eccsd') 2146 ENDIF 2147 ENDIF 2148 CALL LAMMATS(WORK(KLAMDPS),WORK(KLAMDHS),WORK(KT1AM), 2149 & 1,.FALSE.,.FALSE., 2150 & NGLMDS,IGLMRHS,IGLMVIS,ICMO,WORK(KEND1),LWRK1) 2151 2152 DO ISYM = 1, NSYM 2153 2154 KSCR1 = KEND1 2155 KEND2 = KSCR1 + NBAS(ISYM) * NRHFS(ISYM) 2156 LWRK2 = LWORK - KEND2 2157 IF ( LWRK2 .LT. 0 ) 2158 * CALL QUIT(' Too little workspace in ccsd_eccsd-3') 2159 2160 NBAS1 = MAX(NBAS(ISYM),1) 2161 KOFF1 = KONEP + IAODIS(ISYM,ISYM) 2162 KOFF2 = KLAMDHS + IGLMRHS(ISYM,ISYM) 2163 2164 CALL DGEMM('N','N',NBAS(ISYM),NRHFS(ISYM),NBAS(ISYM), 2165 * ONE,WORK(KOFF1),NBAS1,WORK(KOFF2),NBAS1, 2166 * ZERO,WORK(KSCR1),NBAS1) 2167 2168 KOFF2 = KLAMDPS + IGLMRHS(ISYM,ISYM) 2169 2170 TRACE = DDOT(NBAS(ISYM)*NRHFS(ISYM), 2171 & WORK(KOFF2),1,WORK(KSCR1),1) 2172C 2173 XECCSD = XECCSD + TWO * TRACE 2174CSonia 2175 XDRCCD = XDRCCD + TWO * TRACE 2176 XRTCCD = XRTCCD + TWO * TRACE 2177C 2178 END DO 2179 2180 ENDIF 2181 13 CONTINUE 2182C 2183C Thomas Bondo Pedersen: set XECCSD to be the energy of the model used. 2184C 2185 ETMP = XECCSD 2186 IF (ETY.NE.'MP2 ') THEN 2187 IF (DRCCD) THEN 2188 IF (SOSEX) THEN 2189 ETMP=XDRCCD 2190 ELSE 2191 XECCSD=XDRCCD 2192 END IF 2193 END IF 2194 IF (RTCCD) THEN 2195 XECCSD=XRTCCD 2196 ECRTCCD=XECCSD-ESCF 2197 END IF 2198 END IF 2199 2200 XCORR = XECCSD - ESCF 2201 2202 ETYPE(1:5) = ETY(1:5) 2203 LENET = 5 2204 2205 IF (LR12) THEN 2206C NRHFTRIA= NRHFT * (NRHFT+1) / 2 2207C N2 = NRHFTRIA * NRHFTRIA 2208C 2209C KVR12S = 1 2210C KVR12T = KVR12S + N2 2211C KEND1 = KVR12T + N2 2212C LWRK1 = LWORK - KEND1 2213C IF ( LWRK1 .LT. 0 ) 2214C * CALL QUIT(' Too little workspace in ccsd_eccsd-3') 2215C 2216C read V matrices 2217C LUNIT = -1 2218C CALL GPOPEN(LUNIT,FCCR12V,'UNKNOWN',' ','FORMATTED', 2219C & IDUM,LDUM) 2220C6666 READ(LUNIT,'(I3)') IAN 2221C READ(LUNIT,'(4E30.20)') (WORK(KVR12S+IJ), IJ = 0, N2-1) 2222C READ(LUNIT,'(4E30.20)') (WORK(KVR12T+IJ), IJ = 0, N2-1) 2223C IF (IAN.NE.IANR12) GOTO 6666 2224C CALL GPCLOSE(LUNIT,'KEEP') 2225C 2226C ER12S = DDOT(N2,WORK(KVR12S),1,TAMR12S,1) 2227C ER12T = 3.0D0*DDOT(N2,WORK(KVR12T),1,TAMR12T,1) 2228C 2229C XECCSD = XECCSD + ER12S + ER12T 2230 2231 KVR12 = 1 2232 KEND1 = KVR12 + NTR12AM(1) 2233 LWRK1 = LWORK - KEND1 2234 IF ( LWRK1 .LT. 0 ) 2235 * CALL QUIT(' Too little workspace in ccsd_eccsd-3') 2236C 2237C read V matrices 2238 LUNIT = -1 2239 CALL GPOPEN(LUNIT,FCCR12V,'UNKNOWN',' ','UNFORMATTED', 2240 & IDUM,LDUM) 22416666 READ(LUNIT) IAN 2242 READ(LUNIT) (WORK(KVR12-1+I), I=1, NTR12AM(1)) 2243 IF (IAN.NE.IANR12) GOTO 6666 2244 CALL GPCLOSE(LUNIT,'KEEP') 2245 CALL CC_R12TCMEPK(WORK(KVR12),1,.FALSE.) 2246 CALL CCLR_DIASCLR12(WORK(KVR12),0.5D0,1) 2247 2248 ER12 = 2.0D0*DDOT(NTR12AM(1),TAMR12,1,WORK(KVR12),1) 2249 2250 XECCSD = XECCSD + ER12 2251 2252 CALL CCSD_MODEL(ETYPE,LENET,24,ETY,5,APROXR12) 2253 END IF 2254C 2255 WRITE(LUPRI,'(1X,A,I3,A,A,A,F23.16)') 2256 * 'Iter.',ITER,': Coupled cluster ',ETYPE(1:LENET), 2257 * ' energy : ',XECCSD 2258C 2259 IF (IPRINT .GE. 2) THEN 2260 WRITE(LUPRI,'(5X,A,F23.16)') 2261 & 'Conventional correlation energy:',XCORR 2262 IF (LR12) THEN 2263 WRITE(LUPRI,'(3(5X,A,F23.16,/))') 2264C & 'Singlet R12 correlation energy :',ER12S, 2265C & 'Triplet R12 correlation energy :',ER12T, 2266 & 'R12 correlation energy :',ER12, 2267 & 'Total correlation energy :',XCORR+ER12 2268 END IF 2269 END IF 2270 IF (LOCDBG) THEN 2271 CALL AROUND('Amplitudes at this iteration:') 2272 CALL CC_PRP(T1AM,T2AM,1,1,1) 2273 IF (CCR12) CALL CC_PRPR12(TAMR12,1,1,.TRUE.) 2274 END IF 2275C 2276 CALL FLSHFO(LUPRI) 2277C 2278 CALL QEXIT('CCSD_ECCSD') 2279C 2280 RETURN 2281 END 2282 SUBROUTINE CCSD_MODEL(MODELR12,LENMR12,LMAX,MODEL,LENM,APROXR12) 2283 IMPLICIT NONE 2284#include "r12int.h" 2285#include "ccsdinp.h" 2286 2287 INTEGER LENM,LENMR12,LMAX,I 2288 CHARACTER*(*) MODELR12, MODEL, APROXR12 2289 2290 IF (LMAX.LT.LENM) CALL QUIT('LMAX too small in CCSD_MODEL') 2291 2292 IF (CCR12) THEN 2293 MODELR12(1:LENM) = MODEL(1:LENM) 2294 LENMR12 = LENM 2295 DO WHILE (LENMR12.GT.0 .AND. MODELR12(LENMR12:LENMR12).EQ.' ') 2296 LENMR12 = LENMR12 -1 2297 END DO 2298 2299 IF (LMAX.LT.LENMR12+5) CALL QUIT('LMAX too small in CCSD_MODEL') 2300 IF (MP2 .OR. CC2) THEN 2301 MODELR12(LENMR12+1:LENMR12+5) = '-R12/' 2302 LENMR12 = LENMR12 + 5 2303 ELSE IF (MODELR12(1:LENMR12).EQ.'MP2') THEN 2304 MODELR12(LENMR12+1:LENMR12+5) = '-R12/' 2305 LENMR12 = LENMR12 + 5 2306 ELSE 2307 MODELR12(LENMR12+1:LENMR12+6) = '(R12)/' 2308 LENMR12 = LENMR12 + 6 2309 END IF 2310 2311 I = 1 2312 DO WHILE(I.LE.LEN(APROXR12) .AND. APROXR12(I:I).NE.' ') 2313 IF (LMAX.LT.LENMR12+1) 2314 & CALL QUIT('LMAX too small in CCSD_MODEL') 2315 LENMR12 = LENMR12 + 1 2316 MODELR12(LENMR12:LENMR12) = APROXR12(I:I) 2317 I = I + 1 2318 END DO 2319 2320 ELSE 2321 MODELR12(1:5) = MODEL(1:5) 2322 LENMR12 = 5 2323 END IF 2324 2325 RETURN 2326 END 2327C /* Deck ccsd_iajb */ 2328 SUBROUTINE CCSD_IAJB(XAIBJ,T1AM,LHTF,CCR12RSP,MKVAJKL,WORK,LWORK) 2329C 2330C Written by Henrik Koch 27-Mar-1990. 2331C 2332C Small modifications by Asger Halkier 22/5 - 1998 for extra 2333C MO integrals needed for gradients and frozen core FOP. 2334C 2335C Added calculation of V(alpha j,kl) for CC2-R12, H.Fliegl, C. Haettig 2336C 2337C Added flag for computation of additional half transformed 2338C integrals needed for R12 response (e.g. r12 integrals with 2339C two auxiliary basis functions): CCR12RSP 2340C C. Neiss, 10.12.2004 2341C 2342#include "implicit.h" 2343#include "ccr12int.h" 2344 PARAMETER (ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0) 2345#include "priunit.h" 2346#include "dummy.h" 2347#include "maxorb.h" 2348#include "maxash.h" 2349#include "mxcent.h" 2350#include "aovec.h" 2351#include "iratdef.h" 2352#include "ccorb.h" 2353#include "ccisao.h" 2354#include "blocks.h" 2355#include "ccsdinp.h" 2356#include "ccsdsym.h" 2357#include "cbieri.h" 2358#include "distcl.h" 2359#include "eritap.h" 2360#include "ccfro.h" 2361#include "ccfop.h" 2362#include "ccsections.h" 2363#include "ccfield.h" 2364#include "r12int.h" 2365 DIMENSION XAIBJ(*),T1AM(*),WORK(*),INDEXA(MXCORB) 2366 INTEGER IDUM,LUNITR12,LUNITR12_2 2367 LOGICAL LDUM,LHTF,MKVAJKL,CCR12RSP 2368 INTEGER KO2AM,YS2AM,KOFFH,KOFFD 2369 integer ilmorb(8) 2370 INTEGER IGABJ(8),IBASX(8),ICMO(8,8),IGLMRHS(8,8),NCMO(8), 2371 & NGLMDS(8),KLAMDHS,KLAMDPS,KEND0,LWRK0,IGLMVIS(8,8) 2372 INTEGER IMAIJM(8,8),NMAIJM(8),IMATIJM(8,8),NMATIJM(8), 2373 & IGAMSM(8,8),NGAMSM(8),IRGIJS(8,8),NRGIJS(8), 2374 & IR1BASM(8,8),NR1BASM(8),IR2BASM(8,8),NR2BASM, 2375 & IR1XBASM(8,8),NR1XBASM(8),IR2XBASM(8,8),IMATF(8,8), 2376 & NMATF(8) 2377 INTEGER IMAKLM(8,8),NMAKLM(8) 2378C 2379 CHARACTER*5 FN3FOP 2380 CHARACTER*6 FN3VI, FN3FOP2 2381 CHARACTER*8 FN3SRT, FN3VI2, FNTOC 2382 CHARACTER*8 FILER12, FILER12_2 2383 CHARACTER*8 FILBACK 2384 CHARACTER*10 FILE_BACK 2385C 2386C INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 2387C 2388 CALL QENTER('CCSD_IAJB') 2389C----------------------------------------------------------- 2390C calculate some offsets and dimensions needed for R12 2391C----------------------------------------------------------- 2392 KEND0 = 1 2393 IF (MKVAJKL) THEN 2394 TIMVAJKL = 0.0D0 2395 2396celena 2397 IF (R12PRP) THEN 2398 DO ISYMAI = 1,NSYM 2399 ICOUN2 = 0 2400 DO ISYMI = 1,NSYM 2401 ISYMA = MULD2H(ISYMAI,ISYMI) 2402 ILMORB(ISYMI) = ICOUN2 2403 ICOUN2 = ICOUN2 + NBAS(ISYMI)* 2404 & (NORB1(ISYMI)-NRHFFR(ISYMI)) 2405 ENDDO 2406 ENDDO 2407 ENDIF 2408celena 2409 2410C CALL CC_R12OFFSET(NR1ORB,NR1XORB,NR1BAS,NR1XBAS,NR2BAS, 2411C & NRGKL,NRXGKL,N2BST1,IR1ORB,IR1XORB,IR1BAS,IR1XBAS,IR2BAS, 2412C & IR2XBAS,IRGKL,IRXGKL,IAODIS1,NALPHAJ,IALPHAJ) 2413c 2414 IF (IANR12.EQ.2 .OR. IANR12.EQ.3) then 2415c calculate some offsets and dimensions needed for Lambda 2416c including active and inactive occupied molecular orbitals 2417 2418 CALL CC_R12OFFS23(IGLMRHS,IGLMVIS,NGLMDS,ICMO,NCMO, 2419 & IMAIJM,NMAIJM,IMAKLM,NMAKLM, 2420 & IMATIJM,NMATIJM, 2421 & IGAMSM,NGAMSM,IRGIJS,NRGIJS, 2422 & IR1BASM,NR1BASM,IR2BASM,NR2BASM,IR1XBASM, 2423 & NR1XBASM,IR2XBASM,IMATF,NMATF) 2424 2425 KLAMDHS = KEND0 2426 KLAMDPS = KLAMDHS + NGLMDS(1) 2427 KT1AM = KLAMDPS + NGLMDS(1) 2428 KEND0 = KT1AM + NT1AMX 2429 LWRK0 = LWORK - KEND0 2430 IF (LWRK0.LT.0) THEN 2431 CALL QUIT('Insufficient work space in ccsd_iajb') 2432 END IF 2433 CALL DZERO(WORK(KT1AM),NT1AMX) 2434 CALL LAMMATS(WORK(KLAMDPS),WORK(KLAMDHS),WORK(KT1AM), 2435 & 1,.TRUE.,.FALSE., 2436 & NGLMDS,IGLMRHS,IGLMVIS,ICMO,WORK(KEND0),LWRK0) 2437 END IF 2438 END IF 2439C----------------------------------------- 2440C Initialize the XAIBJ integral array. 2441C----------------------------------------- 2442C 2443 IF (ONEAUX) THEN 2444 CALL DZERO(XAIBJ,NH2AM(ISYMOP)) 2445 ELSE IF (U12INT .OR. R12SQR) THEN 2446C Zero space for non-Hermitean integrals (WK/UniKA/04-11-2002). 2447 CALL DZERO(XAIBJ,NU2AM(ISYMOP)) 2448 ELSE 2449 CALL DZERO(XAIBJ,NT2AM(ISYMOP)) 2450 END IF 2451 2452C---------------------------------------- 2453C Open files needed for CC-R12: 2454C---------------------------------------- 2455 IF (LHTF) THEN 2456 LUNITR12 = -1 2457 IF (R12EOR.AND.CCR12SM) THEN 2458c case for new correlation factor: need (ialpha|f12/r12|jbeta) on file 2459c for initialisation if V-interm. 2460 FILER12 = FR12F12HTF 2461 ELSE 2462 FILER12 = FRHTF 2463 END IF 2464 CALL WOPEN2(LUNITR12,FILER12,64,0) 2465 IF (CCR12RSP.AND..NOT.CCR12SM) THEN 2466 LUNITR12_2 = -1 2467 FILER12_2 = FRHTF2 2468 CALL WOPEN2(LUNITR12_2,FILER12_2,64,0) 2469 CALL FLSHFO(LUPRI) 2470 END IF 2471 END IF 2472 2473 IF (CCR12.AND.V12INT.AND.LHTF.AND. 2474 & (IANR12.EQ.2.OR.IANR12.EQ.3)) THEN 2475 LUNITR12 = -1 2476 FILER12 = FGHTF 2477 CALL WOPEN2(LUNITR12,FILER12,64,0) 2478 LU44 = -1 2479 CALL WOPEN2(LU44,FCCGMNAB,64,0) 2480 END IF 2481C 2482C--------------------------------- 2483C Dynamic allocation of space. 2484C--------------------------------- 2485C 2486 KLAMDP = KEND0 2487 IF (R12SQR) THEN 2488C Read MO coefficients from GUMAT.n for n=1,2 (WK/UniKA/04-11-2002). 2489 KLAMDQ = KLAMDP + NLAMDT 2490 LU43 = -43 2491 IF (COMBSS) THEN 2492 CALL GPOPEN(LU43,'GUMAT.2','UNKNOWN',' ','UNFORMATTED', 2493 & IDUM,LDUM) 2494 ELSE 2495 CALL GPOPEN(LU43,'GUMAT.1','UNKNOWN',' ','UNFORMATTED', 2496 & IDUM,LDUM) 2497 END IF 2498 REWIND(LU43) 2499 READ(LU43) NTOTGU 2500 READ(LU43) (WORK(KLAMDQ+I-1), I = 1, NTOTGU) 2501 IF ((R12EIN .AND. INTGAC .EQ. 4) .OR. (R12PRP) 2502 * ) THEN 2503 CALL GPCLOSE(LU43,'KEEP') 2504 ELSE 2505 CALL GPCLOSE(LU43,'KEEP') 2506 END IF 2507 KLAMDH = KLAMDQ + NTOTGU 2508 ELSE 2509 KLAMDQ = KLAMDP 2510 KLAMDH = KLAMDQ + NLAMDT 2511 END IF 2512 KEND1 = KLAMDH + NLAMDT 2513C 2514 KCMO = KEND1 2515 KDNSHF = KCMO + NLAMDS 2516 KFCKHF = KDNSHF + N2BAST 2517 KEND1 = KFCKHF + N2BAST 2518 2519C 2520 IF (MKVAJKL) THEN 2521 KVAJKL = KEND1 2522 KEND1 = KVAJKL + NVAJKL(1) 2523 IF (R12PRP) THEN 2524 KXAJKL = KEND1 2525 KEND1 = KXAJKL+ NVAJKL(1) 2526 ENDIF 2527 END IF 2528 2529 LWRK1 = LWORK - KEND1 2530C 2531 IF (LWRK1 .LT. 0) THEN 2532 CALL QUIT('Insufficient space in CCSD_IAJB') 2533 ENDIF 2534C 2535C----------------------------------------------------- 2536C Calculate the lamda matrices and get CMO vector: 2537C----------------------------------------------------- 2538C 2539 CALL LAMMAT(WORK(KLAMDP),WORK(KLAMDH),T1AM,WORK(KEND1),LWRK1) 2540C 2541C--------------------------------------------------------------------- 2542C initialize CMO vector, SCF density and SCF AO-Fock matrix: 2543C we include in the SCF AO-Fock matrix ONLY fields added 2544C already at the SCF level (i.e. the ``relaxed'' fields) 2545C this matrix is needed for relaxed CC2 response, the 2546C numerical Xksi and Eta vectors (CC_FDXI, CC_FDETA) 2547C--------------------------------------------------------------------- 2548C 2549 LUSIFC = -1 2550 CALL GPOPEN(LUSIFC,'SIRIFC','OLD',' ','UNFORMATTED', 2551 * IDUMMY,.FALSE.) 2552 REWIND(LUSIFC) 2553C Use LABEL (WK/UniKA/04-11-2002). 2554 CALL MOLLAB(LABEL,LUSIFC,LUPRI) 2555 READ(LUSIFC) 2556 READ(LUSIFC) 2557 READ(LUSIFC) (WORK(KCMO+I-1),I=1,NLAMDS) 2558 CALL GPCLOSE(LUSIFC,'KEEP') 2559C 2560 CALL CMO_REORDER(WORK(KCMO),WORK(KEND1),LWRK1) 2561C 2562 CALL CC_AODENS(WORK(KCMO),WORK(KCMO),WORK(KDNSHF),1,1, 2563 * WORK(KEND1),LWRK1) 2564C 2565 CALL CCRHS_ONEAO(WORK(KFCKHF),WORK(KEND1),LWRK1) 2566 DO IF = 1, NFIELD 2567 IF ( .NOT. NHFFIELD(IF) ) THEN 2568 CALL CC_ONEP(WORK(KFCKHF),WORK(KEND1),LWRK1,EFIELD(IF), 2569 * 1,LFIELD(IF)) 2570 END IF 2571 END DO 2572C 2573C-------------------------------------- 2574C Additional work space allocation. 2575C-------------------------------------- 2576C 2577 IF ((FROIMP .OR. FROEXP) .AND. (.NOT. R12INT 2578 * .AND. .NOT. R12EIN .AND. .NOT. U12INT) .AND. 2579 * (R12TRA .OR. RELORB .OR. MP2) .OR. (FROIMP .AND. 2580 * R12PRP .AND. MKVAJKL)) THEN 2581C Not needed for R12 integrals (WK/UniKA/04-11-2002). 2582! * (RELORB .OR. (CCFOP .AND. MP2))) THEN 2583! Sonia: remove "FOP" condition to be able to do gradients MP2 2584 2585 KCMO = KEND1 2586 KFRIN = KCMO + NLAMDS 2587 KFRGR = KFRIN + NT2FRO(1) 2588 KFRGR1= KFRGR + NFROVR(1) 2589 KEND1 = KFRGR1+ NFROVF(1) 2590 LWRK1 = LWORK - KEND1 2591C 2592 IF (LWRK1 .LT. 0) THEN 2593 CALL QUIT('Insufficient space in CCSD_IAJB') 2594 ENDIF 2595C 2596 CALL DZERO(WORK(KCMO),NLAMDS) 2597 IF (R12TRA .AND. .NOT. R12PRP) THEN 2598 CALL DZERO(WORK(KFRIN),NF2FRO(1)) 2599 ELSE 2600 CALL DZERO(WORK(KFRIN),NT2FRO(1)) 2601 CALL DZERO(WORK(KFRGR),NFROVR(1)) 2602 CALL DZERO(WORK(KFRGR1),NFROVF(1)) 2603 END IF 2604C 2605C---------------------------------------------- 2606C Calculate the FULL MO coefficient matrix. 2607C---------------------------------------------- 2608C 2609 CALL CMO_ALL(WORK(KCMO),WORK(KEND1),LWRK1) 2610C 2611 ENDIF 2612C---------------------------------------------------- 2613C initialize V(alpha j,kl) 2614c---------------------------------------------------- 2615 IF (MKVAJKL .AND. (.NOT. FNVAJKL .EQ. 'CCR12XAJKL' 2616 & .AND. ( .NOT. FNVAJKL .EQ. 'CCR12QAJKL') 2617 & .AND. ( .NOT. FNVAJKL .EQ. 'CCR12QIJAL') 2618 & .AND. ( .NOT. FNVAJKL .EQ. 'CCR12UAJKL') 2619 & .AND. ( .NOT. FNVAJKL .EQ. 'CCR12UIJAL') )) THEN 2620 DTIME = SECOND() 2621 IOPT = 1 2622 CALL CC_R12MKVAMKL0(WORK(KVAJKL),NVAJKL(1),IOPT,WORK(KLAMDH),1, 2623 & WORK(KEND1),LWRK1) 2624 2625 TIMVAJKL = TIMVAJKL + ( SECOND() - DTIME ) 2626 ELSEIF ((MKVAJKL .AND. FNVAJKL .EQ. 'CCR12UIJAL') 2627 & .OR. (MKVAJKL .AND. FNVAJKL .EQ. 'CCR12QAJKL') 2628 & .OR. (MKVAJKL .AND. FNVAJKL .EQ. 'CCR12QIJAL') 2629 & .OR. (MKVAJKL .AND. FNVAJKL .EQ. 'CCR12UAJKL') 2630 & .OR. (MKVAJKL .AND. FNVAJKL .EQ. 'CCR12XAJKL')) THEN 2631 CALL DZERO(WORK(KVAJKL),NVAJKL(1)) 2632 CALL DZERO(WORK(KXAJKL),NVAJKL(1)) 2633 ENDIF 2634 2635C 2636C==================================================== 2637C Start the loop over distributions of integrals. 2638C==================================================== 2639C 2640 IF (DEBUG) THEN 2641C IPRERI = 5 2642 WRITE(LUPRI,'(1X,A,I10)') 'LWORK = ',LWORK 2643 END IF 2644C 2645 IF (DIRECT) THEN 2646 DTIME = SECOND() 2647 IF (HERDIR) THEN 2648 CALL HERDI1(WORK(KEND1),LWRK1,IPRERI) 2649 ELSE 2650 KCCFB1 = KEND1 2651 KINDXB = KCCFB1 + MXPRIM*MXCONT 2652 KEND1 = KINDXB + (8*MXSHEL*MXCONT + 1)/IRAT 2653 LWRK1 = LWORK - KEND1 2654 CALL ERIDI1(KODCL1,KODCL2,KODBC1,KODBC2,KRDBC1,KRDBC2, 2655 & KODPP1,KODPP2,KRDPP1,KRDPP2, 2656 & KFREE,LFREE,KEND1,WORK(KCCFB1),WORK(KINDXB), 2657 & WORK(KEND1),LWRK1,IPRERI) 2658 KEND1 = KFREE 2659 LWRK1 = LFREE 2660 ENDIF 2661 NTOSYM = 1 2662 ELSE 2663 NTOSYM = NSYM 2664 ENDIF 2665C 2666 THRDIS = 1.0D-8 2667 ICOUNT1 = 0 2668 ICOUNT2 = 0 2669C 2670 KENDSV = KEND1 2671 LWRKSV = LWRK1 2672C 2673 DO 100 ISYMD1 = 1,NTOSYM 2674C 2675 IF (DIRECT) THEN 2676 IF (HERDIR) THEN 2677 NTOT = MAXSHL 2678 ELSE 2679 NTOT = MXCALL 2680 ENDIF 2681 ELSE 2682 NTOT = NBAS(ISYMD1) 2683 ENDIF 2684C 2685 DO 110 ILLL = 1,NTOT 2686C 2687C--------------------------------------------- 2688C If direct calculate the integrals. 2689C--------------------------------------------- 2690C 2691 IF (DIRECT) THEN 2692C 2693 KEND1 = KENDSV 2694 LWRK1 = LWRKSV 2695C 2696 IF (HERDIR) THEN 2697 CALL HERDI2(WORK(KEND1),LWRK1,INDEXA,ILLL,NUMDIS, 2698 & IPRERI) 2699 ELSE 2700 CALL ERIDI2(ILLL,INDEXA,NUMDIS,0,0, 2701 & WORK(KODCL1),WORK(KODCL2),WORK(KODBC1), 2702 & WORK(KODBC2),WORK(KRDBC1),WORK(KRDBC2), 2703 & WORK(KODPP1),WORK(KODPP2),WORK(KRDPP1), 2704 & WORK(KRDPP2),WORK(KCCFB1),WORK(KINDXB), 2705 & WORK(KEND1), LWRK1,IPRERI) 2706 ENDIF 2707C 2708 KRECNR = KEND1 2709 KEND1 = KRECNR + (NBUFX(0) - 1)/IRAT + 1 2710 LWRK1 = LWORK - KEND1 2711 IF (LWRK1 .LT. 0) THEN 2712 CALL QUIT('Insufficient core in CCRHSN') 2713 END IF 2714C 2715 ELSE 2716 KRECNR = KEND1 2717 NUMDIS = 1 2718 ENDIF 2719C 2720C----------------------------------------------------- 2721C Loop over number of distributions in disk. 2722C----------------------------------------------------- 2723C 2724 DO 120 IDEL2 = 1,NUMDIS 2725C 2726 IF (DIRECT) THEN 2727 IDEL = INDEXA(IDEL2) 2728 IF (NOAUXB) THEN 2729 IDUM = 1 2730 CALL IJKAUX(IDEL,IDUM,IDUM,IDUM) 2731 END IF 2732 ISYMD = ISAO(IDEL) 2733 ELSE 2734 IDEL = IBAS(ISYMD1) + ILLL 2735 ISYMD = ISYMD1 2736 ENDIF 2737C 2738 ISYMB = ISYMD 2739 ISYDIS = MULD2H(ISYMD,ISYMOP) 2740C 2741C----------------------------------------------- 2742C Dynamic allocation of work space. 2743C----------------------------------------------- 2744C 2745 KXINT = KEND1 2746 KSCR1 = KXINT + NDISAO(ISYDIS) 2747 IF (U21INT) KSCR1 = KSCR1 + NDISAO(ISYDIS) 2748 KSCR2 = KSCR1 + NBAST*NBAST 2749 KEND2 = KSCR2 + NBAST*NRHFT 2750 LWRK2 = LWORK - KEND2 2751C 2752 IF (LWRK2 .LT. 0) THEN 2753 CALL QUIT('Insufficient space in CCSD_IAJB') 2754 ENDIF 2755 2756C 2757C----------------------------------------- 2758C Read in batch of integrals. 2759C----------------------------------------- 2760C 2761 IOFFU21 = NDISAO(ISYDIS) 2762 CALL DZERO(WORK(KXINT),2*NDISAO(ISYDIS)) 2763 CALL CCRDAO(WORK(KXINT),IDEL,IDEL2,WORK(KEND2),LWRK2, 2764 * WORK(KRECNR),DIRECT) 2765C 2766C----------------------------------------- 2767C compute the AO-Fock matrix: 2768C----------------------------------------- 2769C 2770C Not needed for R12 part (WK/UniKA/28-04-2003). 2771 IF (.NOT. R12TRA) 2772 * CALL CC_AOFOCK(WORK(KXINT),WORK(KDNSHF),WORK(KFCKHF), 2773 * WORK(KEND2),LWRK2,IDEL,ISYMD,.FALSE., 2774 * DUMMY,1) 2775C 2776C----------------------------------------------- 2777C Calculate integrals (cJ|dk) 2778C needed for frozen core gradients. 2779C----------------------------------------------- 2780C 2781C Modified for R12 method (WK/UniKA/04-11-2002). 2782C Modified (RELORB .OR. (CCFOP .AND. MP2)) for MP2 frozen-core gradients 2783C Sonia 2784 IF ((FROIMP .OR. FROEXP) .AND. (.NOT. R12INT 2785 * .AND. .NOT. R12EIN .AND. .NOT. U12INT) .AND. 2786 * (R12TRA .OR. RELORB .OR. MP2)) THEN 2787C 2788 IF (ONEAUX) THEN 2789 CALL CC_FRCR12(WORK(KFRIN),WORK(KXINT),WORK(KCMO), 2790 * WORK(KEND2),LWRK2,IDEL,ISYMD) 2791 ELSE 2792 CALL CC_FRCOIN(WORK(KFRIN),WORK(KXINT),WORK(KCMO), 2793 * WORK(KEND2),LWRK2,IDEL,ISYMD) 2794 IF (R12PRP .AND. R12TRA) THEN 2795 CALL CC_FRCOGR(WORK(KFRGR),WORK(KXINT), 2796 * WORK(KCMO),WORK(KEND2),LWRK2,IDEL,ISYMD) 2797 CALL CC_FRCOGR1(WORK(KFRGR1),WORK(KXINT), 2798 * WORK(KCMO),WORK(KEND2),LWRK2,IDEL,ISYMD) 2799 ENDIF 2800 2801 END IF 2802 END IF 2803C 2804C----------------------------------------------------------------------- 2805C For CC-R12 with Ansatz 2 calculate two-index transformed 2806C coulomb integrals (M alpha | N beta), where M,N are 2807C frozen and active occupied orbitals; 2808C integrals stored on file FCCGMNAB 2809C----------------------------------------------------------------------- 2810C 2811chf 2812 IF (CCR12.AND.V12INT.AND.LHTF.AND. 2813 & MKVAJKL.AND.(IANR12.EQ.2.OR.IANR12.EQ.3)) THEN 2814 CALL CC_R12MKGMNAB(WORK(KXINT),WORK(KLAMDHS),1,IDEL, 2815 & ISYMD,IGLMRHS,NGLMDS,LU44, 2816 & FCCGMNAB,WORK(KEND2),LWRK2) 2817 END IF 2818C 2819C--------------------------------------------------- 2820C Transform one index in the integrals. 2821C--------------------------------------------------- 2822C 2823 DO 130 ISYMG = 1,NSYM 2824C 2825 ISYMAB = MULD2H(ISYMG,ISYDIS) 2826 ISYMJ = ISYMG 2827 ISYMBJ = MULD2H(ISYMB,ISYMJ) 2828 ISYMAI = MULD2H(ISYMBJ,ISYMOP) 2829C 2830 IF (ISYMAI .GT. ISYMBJ) GOTO 130 2831C 2832 KOFF1 = KXINT + IDSAOG(ISYMG,ISYDIS) 2833 IF (U21INT) KOFFT = KOFF1 + NDISAO(ISYDIS) 2834C Use KLAMDQ instead of KLAMDP (WK/UniKA/04-11-2002). 2835 IF (FNVAJKL .EQ. 'CCR12QIJAL') THEN 2836 KOFF2 = KLAMDQ + ILMORB(ISYMJ) 2837 2838 ELSE 2839 KOFF2 = KLAMDQ + ILMRHF(ISYMJ) 2840 ENDIF 2841 KOFF6 = KLAMDP + ILMRHF(ISYMJ) 2842C 2843 IF (LWRK2 .LT. 2*NNBST(ISYMAB)*NRHF(ISYMJ)) THEN 2844 CALL QUIT('Insufficient core in CCSD_IAJB') 2845 ENDIF 2846C 2847C-------------------------------------------------------- 2848C Analyse size of integral distributions. 2849C-------------------------------------------------------- 2850C 2851 DO 140 G = 1,NBAS(ISYMG) 2852C 2853 2854 KOFFG = KXINT + IDSAOG(ISYMG,ISYDIS) 2855 * + NNBST(ISYMAB)*(G - 1) 2856 NAB = NNBST(ISYMAB) 2857C 2858 DO 150 IAB = 1,NAB 2859 IF (ABS(WORK(KOFFG+IAB)) .GT. THRDIS) GOTO 158 2860 150 CONTINUE 2861C 2862C WRITE(LUPRI,*) 'ISYMD,IDEL,ISYMG,G : ', 2863C * ISYMD,IDEL,ISYMG,G 2864 ICOUNT1 = ICOUNT1 + 1 2865C 2866 158 CONTINUE 2867C 2868 ICOUNT2 = ICOUNT2 + 1 2869C 2870 140 CONTINUE 2871C 2872C------------------------------------------------------------------- 2873C Transform the gamma index in the integral (AB|GD). 2874C------------------------------------------------------------------- 2875C 2876 NNBSAB = MAX(NNBST(ISYMAB),1) 2877 NBASG = MAX(NBAS(ISYMG),1) 2878 CALL DGEMM('N','N',NNBST(ISYMAB),NRHF(ISYMJ), 2879 * NBAS(ISYMG),ONE,WORK(KOFF1),NNBSAB, 2880 * WORK(KOFF2),NBASG,ZERO,WORK(KEND2), 2881 * NNBSAB) 2882 IF ((ONEAUX .OR. R12PRP) .AND. U21INT) THEN 2883 KENDT = KEND2 + NNBST(ISYMAB)*NRHF(ISYMJ) 2884 CALL DGEMM('N','N',NNBST(ISYMAB),NRHF(ISYMJ), 2885 * NBAS(ISYMG),ONE,WORK(KOFFT),NNBSAB, 2886 * WORK(KOFF2),NBASG,ZERO,WORK(KENDT), 2887 * NNBSAB) 2888 ELSE IF (ONEAUX .AND. R12SQR) THEN 2889 KENDT = KEND2 + NNBST(ISYMAB)*NRHF(ISYMJ) 2890 CALL DGEMM('N','N',NNBST(ISYMAB),NRHF(ISYMJ), 2891 * NBAS(ISYMG),ONE,WORK(KOFF1),NNBSAB, 2892 * WORK(KOFF6),NBASG,ZERO,WORK(KENDT), 2893 * NNBSAB) 2894 END IF 2895C------------------------------------------------------------------ 2896C Transform integrals and add to the result vector. 2897C------------------------------------------------------------------ 2898C 2899 IF (CCSDT .OR. CCPT .OR. CHOPT .OR. 2900 * CCP3 .OR. (CCRT.OR.CCR3.OR.CCR1A.OR.CCR1B)) THEN 2901 LUTOC = -1 2902 FNTOC = 'CCSDT_OC' 2903 CALL WOPEN2(LUTOC,FNTOC,64,0) 2904 ENDIF 2905C 2906 IF (ONEAUX) THEN 2907 KOFF4 = IH2AM(ISYMAI,ISYMBJ) + 1 2908 ELSE IF (U12INT .OR. R12SQR ) THEN 2909C KOFF4 for non-Hermitean integrals (WK/UniKA/04-11-2002). 2910 KOFF4 = IU2AM(ISYMAI,ISYMBJ) + 1 2911 ELSE 2912 KOFF4 = IT2AM(ISYMAI,ISYMBJ) + 1 2913 END IF 2914C 2915 CALL CCSD_AIBJ2(WORK(KEND2),XAIBJ(KOFF4),WORK(KLAMDP), 2916 * WORK(KLAMDH),WORK(KSCR1),WORK(KSCR2), 2917 * IDEL,ISYMD,ISYMJ,ISYMAB,LUTOC,FNTOC, 2918 * .FALSE.,LUNITR12,FILER12,LUNITR12_2, 2919 * FILER12_2,LHTF,CCR12RSP) 2920 IF (ONEAUX .AND. U21INT) THEN 2921 CALL CCSD_AIBJ2(WORK(KENDT),XAIBJ(KOFF4),WORK(KLAMDP), 2922 * WORK(KLAMDH),WORK(KSCR1),WORK(KSCR2), 2923 * IDEL,ISYMD,ISYMJ,ISYMAB,LUTOC,FNTOC, 2924 * .TRUE.,LUNITR12,FILER12,LUNITR12_2, 2925 * FILER12_2,LHTF,CCR12RSP) 2926 ELSE IF (ONEAUX .AND. R12SQR) THEN 2927 CALL CCSD_AIBJ2(WORK(KENDT),XAIBJ(KOFF4),WORK(KLAMDQ), 2928 * WORK(KLAMDH),WORK(KSCR1),WORK(KSCR2), 2929 * IDEL,ISYMD,ISYMJ,ISYMAB,LUTOC,FNTOC, 2930 * .FALSE.,LUNITR12,FILER12,LUNITR12_2, 2931 * FILER12_2,LHTF,CCR12RSP) 2932 END IF 2933C--------------------------------------------------------- 2934C compute contributions to V(alpha j,kl) 2935C--------------------------------------------------------- 2936 IF (MKVAJKL) THEN 2937 DTIME = SECOND() 2938 IF (MBAS1(ISYMG).GT.0 .OR. NRHF(ISYMJ).GT.0) THEN 2939 IBASX(1) = 0 2940 DO ISYM = 2, NSYM 2941 IBASX(ISYM) = IBASX(ISYM-1)+MBAS2(ISYM-1) 2942 END DO 2943 KGABJD = KEND2 2944 KEND3 = KGABJD + NNBST(ISYMAB)*NRHF(ISYMJ) 2945 IF (U21INT) THEN 2946 KTABJD = KENDT 2947 KEND3 = KTABJD + NNBST(ISYMAB)*NRHF(ISYMJ) 2948 END IF 2949 LWRK3 = LWORK - KEND3 2950 2951 IF (LWRK3 .LT. 0) THEN 2952 CALL QUIT('Insufficient space in CCSD_IAJB') 2953 END IF 2954 2955 KOFF5 = KXINT + IDSAOG(ISYMG,ISYDIS) 2956 IF(U21INT) KOFF6 = KOFF5 + NDISAO(ISYDIS) 2957 2958 IF (IANR12.EQ.1 .AND. (.NOT.R12PRP)) THEN 2959 FILBACK = FNBACK 2960celena 2961 ELSEIF (R12PRP) THEN 2962 IF (FNVAJKL .EQ. 'CCR12VIJAL') THEN 2963 FILE_BACK = FV12BACK 2964 ELSE IF (FNVAJKL .EQ. 'CCR12VAJKL') THEN 2965 FILBACK = FNBACK 2966 ELSE IF (FNVAJKL .EQ. 'CCR12BIJAL') THEN 2967 FILE_BACK = FT12BACK 2968 ELSE IF (FNVAJKL .EQ. 'CCR12BAJKL') THEN 2969 FILBACK = FNBACK 2970 ELSE IF (FNVAJKL .EQ. 'CCR12QAJKL') THEN 2971 FILBACK = FNBACK 2972 ELSE IF (FNVAJKL .EQ. 'CCR12QIJAL') THEN 2973 FILBACK = FNBACK 2974 ELSE IF (FNVAJKL .EQ. 'CCR12UAJKL') THEN 2975 FILE_BACK = FU12BACK 2976 ELSE IF (FNVAJKL .EQ. 'CCR12UIJAL') THEN 2977 FILE_BACK = FQ12BACK 2978 ELSE IF (FNVAJKL .EQ. 'CCR12XAJKL') THEN 2979 FILBACK = FNBACK 2980 ENDIF 2981celena 2982 ELSE IF (IANR12.EQ.2) THEN 2983c FILBACK = FRHTF 2984 FILBACK = FNBACK2 2985 ELSE IF (IANR12.EQ.3) THEN 2986 IDELTA = IDEL - IBAS(ISYMD) 2987 IF (IDELTA.LE.MBAS1(ISYMD)) THEN 2988 FILBACK = FNBACK 2989 ELSE 2990c FILBACK = FRHTF 2991 FILBACK = FNBACK2 2992 END IF 2993 ELSE 2994 WRITE(LUPRI,*) 'IANR12 = ',IANR12 2995 CALL QUIT('Illegal IANR12.') 2996 END IF 2997 IF (FNVAJKL .EQ. 'CCR12QIJAL') THEN 2998 CALL R12MKVAMKL(FILBACK,WORK(KGABJD), 2999 & WORK(KTABJD),WORK(KVAJKL), 3000 & WORK(KLAMDQ),1,WORK(KLAMDHS),WORK(KLAMDPS), 3001 & WORK(KOFF5),WORK(KOFF6), 3002 & IDEL,ISYMD,ISYMJ,ISYMAB,ISYMG, 3003 & WORK(KSCR1),IBASX,IGLMRHS,NGLMDS, 3004 & WORK(KEND3),LWRK3) 3005 ELSEIF (FNVAJKL .EQ. 'CCR12BIJAL' .OR. 3006 & FNVAJKL .EQ. 'CCR12UAJKL' .OR. 3007 & FNVAJKL .EQ. 'CCR12VIJAL' .OR. 3008 & FNVAJKL .EQ. 'CCR12UIJAL') THEN 3009 CALL R12MKVAMKL(FILE_BACK,WORK(KGABJD), 3010 & WORK(KTABJD),WORK(KVAJKL), 3011 & WORK(KLAMDQ),1,WORK(KLAMDHS),WORK(KLAMDPS), 3012 & WORK(KOFF5),WORK(KOFF6), 3013 & IDEL,ISYMD,ISYMJ,ISYMAB,ISYMG, 3014 & WORK(KSCR1),IBASX,IGLMRHS,NGLMDS, 3015 & WORK(KEND3),LWRK3) 3016 ELSE 3017 CALL R12MKVAMKL(FILBACK,WORK(KGABJD), 3018 & WORK(KTABJD),WORK(KVAJKL), 3019 & WORK(KLAMDH),1,WORK(KLAMDHS),WORK(KLAMDPS), 3020 & WORK(KOFF5),WORK(KOFF6), 3021 & IDEL,ISYMD,ISYMJ,ISYMAB,ISYMG, 3022 & WORK(KSCR1),IBASX,IGLMRHS,NGLMDS, 3023 & WORK(KEND3),LWRK3) 3024 IF (IANR12.EQ.3 .AND. R12CBS) THEN 3025 !once more in this case... 3026 IDELTA = IDEL - IBAS(ISYMD) 3027 IF (IDELTA.LE.MBAS1(ISYMD)) THEN 3028 IANR12 = 2 3029 FILBACK = FNBACK2 3030 CALL R12MKVAMKL(FILBACK,WORK(KGABJD), 3031 & WORK(KTABJD),WORK(KVAJKL), 3032 & WORK(KLAMDH),1,WORK(KLAMDHS), 3033 & WORK(KLAMDPS),WORK(KOFF5),WORK(KOFF6), 3034 & IDEL,ISYMD,ISYMJ,ISYMAB,ISYMG, 3035 & WORK(KSCR1),IBASX,IGLMRHS,NGLMDS, 3036 & WORK(KEND3),LWRK3) 3037 IANR12 = 3 3038 END IF 3039 END IF 3040 ENDIF 3041 END IF 3042 TIMVAJKL = TIMVAJKL + ( SECOND() - DTIME ) 3043 END IF 3044C 3045C---------------------------------------------------------------------- 3046C Construct I(kd,c) for fixed alpha. 3047C Not needed for R12 integrals (WK/UniKA/04-11-2002). 3048C---------------------------------------------------------------------- 3049C 3050 IF (CCSDT .OR. CCPT .OR. CHOPT .OR. 3051 * CCP3 .OR. (CCRT.OR.CCR3.OR.CCR1A.OR.CCR1B)) THEN 3052 CALL WCLOSE2(LUTOC,FNTOC,'KEEP') 3053 ENDIF 3054C 3055 IF (.NOT. R12TRA .AND. (CCSDT.OR.(CCPT.OR.CCP3).OR. 3056 * (CCRT.OR.CCR3.OR.CCR1A.OR.CCR1B.OR.CHOPT))) THEN 3057 3058 KINT3 = KEND2 3059 KINT4 = KINT3 + NT1AM(ISYMAB)*NVIR(ISYMG) 3060 KSCR3 = KINT4 + NT1AM(ISYMAB)*NVIR(ISYMG) 3061 KEND3 = KSCR3 + NT1AM(ISYMAB)*NBAS(ISYMG) 3062 LWRK3 = LWORK - KEND3 3063C 3064 IF (LWRK3 .LT. 0) THEN 3065 CALL QUIT('Insufficient space in CCSD_IAJB') 3066 END IF 3067 3068 KOFF5 = KXINT + IDSAOG(ISYMG,ISYDIS) 3069C 3070 LU3SRT = -1 3071 FN3SRT = 'CC3_SORT' 3072 CALL WOPEN2(LU3SRT,FN3SRT,64,0) 3073C 3074 CALL CCSD_AIBJ3(WORK(KOFF5),WORK(KINT3), 3075 * WORK(KINT4),WORK(KLAMDP), 3076 * WORK(KLAMDH),WORK(KSCR1), 3077 * WORK(KSCR2),WORK(KSCR3), 3078 * IDEL,ISYMD,ISYMG,ISYMAB, 3079 * LU3SRT,FN3SRT) 3080C 3081 CALL WCLOSE2(LU3SRT,FN3SRT,'KEEP') 3082C 3083 END IF 3084C 3085 130 CONTINUE 3086C 3087 120 CONTINUE 3088C 3089 110 CONTINUE 3090C 3091 100 CONTINUE 3092C 3093 KEND1 = KENDSV 3094 LWRK1 = LWRKSV 3095C 3096c------------------------------------- 3097C write AO-Fock matrix to file: 3098C------------------------------------- 3099C 3100 IF (.NOT. R12TRA) THEN 3101 LUFCK = -1 3102 CALL GPOPEN(LUFCK,'CC_FCKREF','UNKNOWN',' ','UNFORMATTED', 3103 * IDUMMY,.FALSE.) 3104 REWIND(LUFCK) 3105 WRITE(LUFCK)(WORK(KFCKHF + I-1),I = 1,N2BST(ISYMOP)) 3106 CALL GPCLOSE(LUFCK,'KEEP' ) 3107C 3108 IF (IPRINT .GT.150) THEN 3109 CALL AROUND( 'Fock AO matrix for reference state:' ) 3110 CALL CC_PRFCKAO(WORK(KFCKHF),1) 3111 ENDIF 3112 ENDIF 3113C 3114 IF (ANAAOD) THEN 3115 CALL AROUND('Analysis of integral distributions') 3116C 3117 WRITE(LUPRI,'(10X,/,A,D12.5)') 'Threshold in analysis : ', 3118 & THRDIS 3119 WRITE(LUPRI,'(10X,A,I7)')'Total number of dist. : ', 3120 * ICOUNT2 3121 WRITE(LUPRI,'(10X,A,I7)')'Total number larger than thr. : ', 3122 * ICOUNT2 - ICOUNT1 3123 WRITE(LUPRI,'(10X,A,I7)')'Total number smaller than thr. : ', 3124 * ICOUNT1 3125C 3126 IF (IPRINT .GT. 45) THEN 3127 CALL AROUND('(ia|jb) integral vector') 3128 IF (ONEAUX) THEN 3129 DO 250 ISYMBJ = 1,NSYM 3130 ISYMAI = ISYMBJ 3131 KOFF = IH2AM(ISYMAI,ISYMBJ) + 1 3132 NTOTAI = NH1AM(ISYMAI) 3133 CALL OUTPAK(XAIBJ(KOFF),NTOTAI,1,LUPRI) 3134 KOFF = KOFF + NTOTAI * (NTOTAI + 1) / 2 3135 NTOTBJ = NG1AM(ISYMAI) 3136 CALL OUTPUT(XAIBJ(KOFF),1,NTOTAI,1,NTOTBJ, 3137 & NTOTAI,NTOTBJ,1,LUPRI) 3138 250 CONTINUE 3139 ELSE IF (U12INT .OR. R12SQR) THEN 3140C Output of non-Hermitean integrals (WK/UniKA/04-11-2002). 3141 DO 251 ISYMBJ = 1,NSYM 3142 ISYMAI = ISYMBJ 3143 KOFF = IU2AM(ISYMAI,ISYMBJ) + 1 3144 NTOTAI = NT1AM(ISYMAI) 3145 CALL OUTPUT(XAIBJ(KOFF),1,NTOTAI,1,NTOTAI, 3146 & NTOTAI,NTOTAI,1,LUPRI) 3147 251 CONTINUE 3148 ELSE 3149 DO 252 ISYMBJ = 1,NSYM 3150 ISYMAI = ISYMBJ 3151 KOFF = IT2AM(ISYMAI,ISYMBJ) + 1 3152 NTOTAI = NT1AM(ISYMAI) 3153 CALL OUTPAK(XAIBJ(KOFF),NTOTAI,1,LUPRI) 3154 252 CONTINUE 3155 END IF 3156 ENDIF 3157 END IF 3158 3159C ----------------------------------------- 3160C write V(alpha j,kl) to disk 3161C ----------------------------------------- 3162 IF (MKVAJKL) THEN 3163 DTIME = SECOND() 3164 3165 IF (DEBUG) THEN 3166 CALL CC_R12MKVIJKL(WORK(KVAJKL),1,WORK(KLAMDH),1, 3167 & WORK(KEND1),LWRK1,.FALSE.,DUMMY,DUMMY) 3168 END IF 3169 3170 LUVAJKL = -1 3171 CALL GPOPEN(LUVAJKL,FVAJKL,'UNKNOWN',' ','UNFORMATTED', 3172 & IDUMMY,.FALSE.) 3173 REWIND(LUVAJKL) 3174 WRITE(LUVAJKL) (WORK(KVAJKL+I-1), I = 1,NVAJKL(1)) 3175 CALL GPCLOSE(LUVAJKL,'KEEP') 3176 3177C Compute Y(a,j,k,l) for MP2-R12 first order properties (Y=B,V,X) 3178 IF (R12PRP) THEN 3179 IF (FNVAJKL .EQ. 'CCR12QAJKL') THEN 3180 CALL CC_R12MKXAJKL(WORK(KVAJKL),WORK(KCMO),WORK(KEND1), 3181 & LWRK1,.true.) 3182 LUVAJKL = -1 3183 CALL GPOPEN(LUVAJKl,FNVAJKL,'UNKNOWN',' ','UNFORMATTED', 3184 & IDUMMY,.FALSE.) 3185 REWIND(LUVAJKL) 3186 WRITE(LUVAJKL) (WORK(KVAJKL+I-1), I = 1,NVAJKL(1)) 3187 CALL GPCLOSE(LUVAJKL,'KEEP') 3188 3189 ELSE 3190 CALL CC_R12MKXAJKL(WORK(KVAJKL),WORK(KCMO),WORK(KEND1), 3191 & LWRK1,.false.) 3192 ENDIF 3193 3194 IF (FROIMP) THEN 3195 IF (FNVAJKL .EQ. 'CCR12QAJKL') THEN 3196 CALL CC_R12MKXIJKL(WORK(KVAJKL),WORK(KCMO),WORK(KEND1) 3197 & ,LWRK1,.true.) 3198 ELSE 3199 CALL CC_R12MKXIJKL(WORK(KVAJKL),WORK(KCMO),WORK(KEND1) 3200 & ,LWRK1,.false.) 3201 ENDIF 3202 END IF 3203 END IF 3204 3205 3206 TIMVAJKL = TIMVAJKL + ( SECOND() - DTIME ) 3207 3208 WRITE(LUPRI,'(1X,A)') 3209 & 'Computation of V^aj_kl intermediate done' 3210 WRITE(LUPRI,'(/1X,A,F7.2,A)') 3211 & ' Time used for V^aj_kl is ',TIMVAJKL,' seconds' 3212 WRITE(LUPRI,*) 3213 END IF 3214C 3215C------------------------------------- 3216C Write integrals (cJ|dk) to disk. 3217C------------------------------------- 3218C 3219C Modified for R12 method (WK/UniKA/04-11-2002). 3220C Modified for MP2 frozen-core geometry opt. Sonia 2002 3221 IF ((FROIMP .OR. FROEXP) .AND. (.NOT. R12INT 3222 * .AND. .NOT. R12EIN .AND. .NOT. U12INT) .AND. 3223 * (R12TRA .OR. RELORB .OR. MP2)) THEN 3224C 3225 LUCJDK = -1 3226 CALL GPOPEN(LUCJDK,'INCJDK','UNKNOWN',' ','UNFORMATTED',IDUMMY, 3227 & .FALSE.) 3228 REWIND(LUCJDK) 3229 WRITE(LUCJDK) (WORK(KFRIN+I-1), I = 1,NT2FRO(1)) 3230 CALL GPCLOSE(LUCJDK,'KEEP') 3231 IF (R12PRP) THEN 3232 LUCJDK = -1 3233 CALL GPOPEN(LUCJDK,'INCJDA','UNKNOWN',' ','UNFORMATTED', 3234 & IDUMMY,.FALSE.) 3235 REWIND(LUCJDK) 3236 WRITE(LUCJDK) (WORK(KFRGR+I-1), I = 1,NFROVR(1)) 3237 CALL GPCLOSE(LUCJDK,'KEEP') 3238 3239 LUCJDK = -1 3240 CALL GPOPEN(LUCJDK,'INCJDI','UNKNOWN',' ','UNFORMATTED', 3241 & IDUMMY,.FALSE.) 3242 REWIND(LUCJDK) 3243 WRITE(LUCJDK) (WORK(KFRGR1+I-1), I = 1,NFROVF(1)) 3244 CALL GPCLOSE(LUCJDK,'KEEP') 3245 ENDIF 3246 ENDIF 3247C 3248 IF (.NOT.R12TRA.AND.(CCSDT.OR.(CCPT.OR.CCP3).OR. 3249 * (CCRT.OR.CCR3.OR.CCR1A.OR.CCR1B.OR.CHOPT))) THEN 3250C 3251C------------------------------------ 3252C Sort integrals (kc,d alpha). 3253C------------------------------------ 3254C 3255 LU3SRT = -1 3256 LU3VI = -1 3257 LU3VI2 = -1 3258 LU3FOP = -1 3259 LU3FOP2 = -1 3260 FN3SRT = 'CC3_SORT' 3261 FN3VI = 'CC3_VI' 3262 FN3VI2 = 'CC3_VI12' 3263 FN3FOP = 'PTFOP' 3264 FN3FOP2 = 'PTFOP2' 3265 CALL WOPEN2(LU3SRT,FN3SRT,64,0) 3266 CALL WOPEN2(LU3VI,FN3VI,64,0) 3267 CALL WOPEN2(LU3VI2,FN3VI2,64,0) 3268 CALL WOPEN2(LU3FOP,FN3FOP,64,0) 3269 CALL WOPEN2(LU3FOP2,FN3FOP2,64,0) 3270C 3271 ISYINT = ISYMOP 3272 CALL CC3_SORT1(WORK,LWORK,1,ISYINT,LU3SRT,FN3SRT, 3273 * LU3VI,FN3VI,LU3VI2,FN3VI2,LU3FOP,FN3FOP, 3274 * LU3FOP2,FN3FOP2) 3275C 3276 CALL WCLOSE2(LU3SRT,FN3SRT,'KEEP') 3277 CALL WCLOSE2(LU3VI,FN3VI,'KEEP') 3278 CALL WCLOSE2(LU3VI2,FN3VI2,'KEEP') 3279 CALL WCLOSE2(LU3FOP,FN3FOP,'KEEP') 3280 CALL WCLOSE2(LU3FOP2,FN3FOP2,'KEEP') 3281C 3282 ENDIF 3283C 3284 IF (LHTF) THEN 3285 CALL WCLOSE2(LUNITR12,FILER12,'KEEP') 3286 IF (CCR12RSP) THEN 3287 CALL WCLOSE2(LUNITR12_2,FRHTF2,'KEEP') 3288 END IF 3289 END IF 3290C 3291 IF (CCR12.AND.V12INT.AND.LHTF.AND. 3292 & (IANR12.EQ.2.OR.IANR12.EQ.3)) THEN 3293 CALL WCLOSE2(LU44,FCCGMNAB,'KEEP') 3294 END IF 3295C 3296 CALL QEXIT('CCSD_IAJB') 3297 3298 RETURN 3299 END 3300C /* Deck ccsd_aibj2 */ 3301 SUBROUTINE CCSD_AIBJ2(XINT,XAIBJ,XLAMDP,XLAMDH, 3302 * SCR1,SCR2,IDEL,ISYMD,ISYMJ,ISYMAB, 3303 * LUFILE,FNFILE,ANTISYM, 3304 * LUNITR12,FILER12,LUNITR12_2,FILER12_2, 3305 * LHTF,CCR12RSP) 3306C 3307C Written by Henrik Koch 27-Mar-1990. 3308C 3309#include "implicit.h" 3310 INTEGER LU43,LUNITR12,LUNITR12_2 3311 PARAMETER (ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0) 3312 DIMENSION XINT(*),XAIBJ(*), SCR1(*),SCR2(*) 3313 DIMENSION XLAMDP(*),XLAMDH(*) 3314#include "priunit.h" 3315#include "ccinftap.h" 3316#include "ccorb.h" 3317#include "r12int.h" 3318#include "ccsdsym.h" 3319#include "ccsdinp.h" 3320#include "ccfop.h" 3321C 3322 LOGICAL ANTISYM,LHTF,CCR12RSP 3323 CHARACTER*(*) FNFILE,FILER12,FILER12_2 3324C 3325C INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 3326C 3327 CALL QENTER('CCSD_AIBJ2') 3328C 3329 IF (ANTISYM) THEN 3330 FACDG = -ONE 3331 ELSE 3332 FACDG = ONE 3333 END IF 3334C 3335 DO 100 J = 1,NRHF(ISYMJ) 3336C 3337 KOFF1 = NNBST(ISYMAB)*(J-1) + 1 3338C 3339 IF (ANTISYM) THEN 3340 CALL CCSD_ASYMSQ(XINT(KOFF1),ISYMAB,SCR1,0,0) 3341 ELSE 3342 CALL CCSD_SYMSQ(XINT(KOFF1),ISYMAB,SCR1) 3343 END IF 3344C 3345C-------------------------------------------------- 3346C Transformation of the A-index to occupied. 3347C-------------------------------------------------- 3348C 3349 KOFF3 = 1 3350 DO 110 ISYMI = 1,NSYM 3351C 3352 ISYMA = ISYMI 3353 ISYMB = MULD2H(ISYMA,ISYMAB) 3354C 3355 KOFF1 = IAODIS(ISYMA,ISYMB) + 1 3356 KOFF2 = ILMRHF(ISYMI) + 1 3357C 3358 NBASA = MAX(NBAS(ISYMA),1) 3359 NBASB = MAX(NBAS(ISYMB),1) 3360 CALL DGEMM('T','N',NBAS(ISYMB),NRHF(ISYMI),NBAS(ISYMA), 3361 * FACDG,SCR1(KOFF1),NBASA,XLAMDP(KOFF2), 3362 * NBASA,ZERO,SCR2(KOFF3),NBASB) 3363C 3364 KOFF3 = KOFF3 + NBAS(ISYMB)*NRHF(ISYMI) 3365C 3366 110 CONTINUE 3367C 3368 IF (LHTF) THEN 3369 NSCR1 = NBAST*NBAST 3370 CALL CC_R12WHTF(SCR2,IDEL,ISYMD,J,ISYMJ,ISYMAB,CCR12RSP, 3371 & LUNITR12,FILER12,LUNITR12_2,FILER12_2, 3372 & SCR1,NSCR1) 3373 END IF 3374C 3375C------------------------------------------------- 3376C Transformation of the B-index to virtual. 3377C------------------------------------------------- 3378C 3379 KOFF2 = 1 3380 DO 120 ISYMI = 1,NSYM 3381C 3382 ISYMB = MULD2H(ISYMI,ISYMAB) 3383 ISYMA = ISYMB 3384C 3385 KOFF1 = ILMVIR(ISYMA) + 1 3386 NBASB = MAX(NBAS(ISYMB),1) 3387C 3388 IF (ONEAUX) THEN 3389 KOFF3 = IH1AM(ISYMA,ISYMI) + 1 3390 NVIRA = MAX(NORB1(ISYMA),1) 3391 CALL DGEMM('T','N',NORB1(ISYMA),NRHF(ISYMI),NBAS(ISYMB), 3392 * ONE,XLAMDH(KOFF1),NBASB,SCR2(KOFF2), 3393 * NBASB,ZERO,SCR1(KOFF3),NVIRA) 3394 ELSE 3395 KOFF3 = IT1AM(ISYMA,ISYMI) + 1 3396 NVIRA = MAX(NVIR(ISYMA),1) 3397 CALL DGEMM('T','N',NVIR(ISYMA),NRHF(ISYMI),NBAS(ISYMB), 3398 * ONE,XLAMDH(KOFF1),NBASB,SCR2(KOFF2), 3399 * NBASB,ZERO,SCR1(KOFF3),NVIRA) 3400 END IF 3401 KOFF2 = KOFF2 + NBAS(ISYMB)*NRHF(ISYMI) 3402C 3403 120 CONTINUE 3404c------------------------------------------------------------ 3405CHF write and grep out here occupied g_ijkdelta integrals 3406c------------------------------------------------------------ 3407C 3408C------------------------------------------ 3409C Write out integrals used in CCSDT. 3410C------------------------------------------ 3411C 3412 IF (CCSDT.OR.CCPT.OR.CCP3.OR.CCRT 3413 * .OR.CCR3.OR.CCR1A.OR.CCR1B .OR. CHOPT) THEN 3414C 3415 ISYMI = ISYMJ 3416 ISYMCK = ISYMAB 3417 ISYCKI = MULD2H(ISYMCK,ISYMI) 3418C 3419 I = J 3420 ID = IDEL - IBAS(ISYMD) 3421C 3422 IOFF = ICKID(ISYCKI,ISYMD) + NCKI(ISYCKI)*(ID - 1) 3423 * + ICKI(ISYMCK,ISYMI) + NT1AM(ISYMCK)*(I - 1) + 1 3424C 3425 IF (NT1AM(ISYMCK) .GT. 0) THEN 3426 CALL PUTWA2(LUFILE,FNFILE,SCR1,IOFF,NT1AM(ISYMCK)) 3427 ENDIF 3428 ENDIF 3429C 3430C-------------------------------------------------- 3431C Add the contribution to the result vector. 3432C-------------------------------------------------- 3433C 3434 ISYMB = ISYMD 3435 ISYMBJ = MULD2H(ISYMB,ISYMJ) 3436 ISYMAI = ISYMAB 3437C 3438 IF (ONEAUX) THEN 3439 DO 131 B = 1, NORB1(ISYMB) 3440 NBJ = IH1AM(ISYMB,ISYMJ) + NORB1(ISYMB)*(J-1) + B 3441 NTOTAI = NBJ 3442 KOFF1 = NBJ*(NBJ - 1)/2 + 1 3443 KOFF2 = ILMVIR(ISYMB) + NBAS(ISYMD)*(B-1) + IDEL 3444 * - IBAS(ISYMD) 3445 CALL DAXPY(NTOTAI,XLAMDH(KOFF2),SCR1,1,XAIBJ(KOFF1),1) 3446 131 CONTINUE 3447 NTOTAI = NH1AM(ISYMAI) 3448 KOFF0 = NTOTAI * (NTOTAI + 1) / 2 + 1 3449 DO 132 B = 1, NORB2(ISYMB) 3450 KKB = B + NORB1(ISYMB) 3451 NBJ = IG1AM(ISYMB,ISYMJ) + NORB2(ISYMB)*(J-1) + B 3452 KOFF1 = NTOTAI*(NBJ - 1) + KOFF0 3453 KOFF2 = ILMVIR(ISYMB) + NBAS(ISYMD)*(KKB-1) + IDEL 3454 * - IBAS(ISYMD) 3455 CALL DAXPY(NTOTAI,XLAMDH(KOFF2),SCR1,1,XAIBJ(KOFF1),1) 3456 132 CONTINUE 3457 ELSE 3458 DO 130 B = 1, NVIR(ISYMB) 3459 NBJ = IT1AM(ISYMB,ISYMJ) + NVIR(ISYMB)*(J-1) + B 3460 IF (ISYMAI .EQ. ISYMBJ .AND. .NOT. 3461 & (U12INT .OR. R12SQR)) THEN 3462 NTOTAI = NBJ 3463 KOFF1 = NBJ*(NBJ - 1)/2 + 1 3464 ELSE 3465 NTOTAI = NT1AM(ISYMAI) 3466 KOFF1 = NTOTAI*(NBJ - 1) + 1 3467 ENDIF 3468 KOFF2 = ILMVIR(ISYMB) + NBAS(ISYMD)*(B-1) + IDEL 3469 * - IBAS(ISYMD) 3470 CALL DAXPY(NTOTAI,XLAMDH(KOFF2),SCR1,1,XAIBJ(KOFF1),1) 3471 130 CONTINUE 3472 END IF 3473C 3474 100 CONTINUE 3475C 3476 CALL QEXIT('CCSD_AIBJ2') 3477C 3478 RETURN 3479 END 3480C /* Deck ccsd_aibj3 */ 3481 SUBROUTINE CCSD_AIBJ3(XINT,XINT3,XINT4,XLAMDP,XLAMDH,SCR1,SCR2, 3482 * SCR3,IDEL,ISYDEL,ISYMG,ISYMAB,LUFILE,FNFILE) 3483C 3484C Written by Henrik Koch 27-Mar-1990. 3485C Modified asm 3486C 3487#include "implicit.h" 3488 PARAMETER (ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0) 3489 DIMENSION XINT(*),XINT3(*),XINT4(*),SCR1(*),SCR2(*),SCR3(*) 3490 DIMENSION XLAMDP(*),XLAMDH(*) 3491#include "priunit.h" 3492#include "ccinftap.h" 3493#include "ccorb.h" 3494#include "ccsdsym.h" 3495#include "ccsdinp.h" 3496C 3497 CHARACTER*(*) FNFILE 3498C 3499C INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 3500C 3501 CALL QENTER('CCSD_AIBJ3') 3502C 3503 ISYMKD = ISYMAB 3504C 3505 DO 100 G = 1,NBAS(ISYMG) 3506C 3507 KOFF1 = NNBST(ISYMAB)*(G-1) + 1 3508C 3509 CALL CCSD_SYMSQ(XINT(KOFF1),ISYMAB,SCR1) 3510C 3511C-------------------------------------------------- 3512C Transformation of the A-index to occupied. 3513C-------------------------------------------------- 3514C 3515 KOFF3 = 1 3516 DO 110 ISYMK = 1,NSYM 3517C 3518 ISYMA = ISYMK 3519 ISYMB = MULD2H(ISYMA,ISYMAB) 3520C 3521 KOFF1 = IAODIS(ISYMA,ISYMB) + 1 3522 KOFF2 = ILMRHF(ISYMK) + 1 3523C 3524 NBASA = MAX(NBAS(ISYMA),1) 3525 NBASB = MAX(NBAS(ISYMB),1) 3526C 3527 CALL DGEMM('T','N',NBAS(ISYMB),NRHF(ISYMK),NBAS(ISYMA), 3528 * ONE,SCR1(KOFF1),NBASA,XLAMDP(KOFF2), 3529 * NBASA,ZERO,SCR2(KOFF3),NBASB) 3530C 3531 KOFF3 = KOFF3 + NBAS(ISYMB)*NRHF(ISYMK) 3532C 3533 110 CONTINUE 3534C 3535C------------------------------------------------- 3536C Transformation of the B-index to virtual. 3537C------------------------------------------------- 3538C 3539 KOFF2 = 1 3540 DO 120 ISYMK = 1,NSYM 3541C 3542 ISYMB = MULD2H(ISYMK,ISYMAB) 3543 ISYMC = ISYMB 3544 ISYMCK = MULD2H(ISYMC,ISYMK) 3545C 3546 KOFF1 = ILMVIR(ISYMC) + 1 3547 KOFF3 = NT1AM(ISYMCK)*(G - 1) + IT1AM(ISYMC,ISYMK) + 1 3548C 3549 NBASB = MAX(NBAS(ISYMB),1) 3550 NVIRC = MAX(NVIR(ISYMC),1) 3551C 3552 CALL DGEMM('T','N',NVIR(ISYMB),NRHF(ISYMK),NBAS(ISYMB), 3553 * ONE,XLAMDH(KOFF1),NBASB,SCR2(KOFF2), 3554 * NBASB,ZERO,SCR3(KOFF3),NVIRC) 3555C 3556 KOFF2 = KOFF2 + NBAS(ISYMB)*NRHF(ISYMK) 3557C 3558 120 CONTINUE 3559C 3560 100 CONTINUE 3561C 3562C-------------------------------- 3563C Transform gamma index to d. 3564C-------------------------------- 3565C 3566 ISYMCK = ISYMAB 3567 ISYMD = ISYMG 3568C 3569 NBASG = MAX(NBAS(ISYMG),1) 3570 NTOTCK = MAX(NT1AM(ISYMCK),1) 3571C 3572 KOFF = ILMVIR(ISYMG) + 1 3573C 3574 CALL DGEMM('N','N',NT1AM(ISYMCK),NVIR(ISYMD),NBAS(ISYMG),ONE, 3575 * SCR3,NTOTCK,XLAMDH(KOFF),NBASG,ZERO,XINT3,NTOTCK) 3576C 3577C------------------------------- 3578C Dump to disk (kc|d alpha). 3579C------------------------------- 3580C 3581 IA = IDEL - IBAS(ISYDEL) 3582 ISYMA = ISYDEL 3583 ISYCKD = MULD2H(ISYMCK,ISYMD) 3584C 3585 LENGTH = NT1AM(ISYMCK)*NVIR(ISYMD) 3586C 3587 IOFF = ICKDAO(ISYCKD,ISYMA) + NCKATR(ISYCKD)*(IA - 1) 3588 * + ICKATR(ISYMCK,ISYMD) + 1 3589C 3590 IF (LENGTH .GT. 0) THEN 3591 CALL PUTWA2(LUFILE,FNFILE,XINT3,IOFF,LENGTH) 3592 ENDIF 3593C 3594 CALL QEXIT('CCSD_AIBJ3') 3595 3596 RETURN 3597 END 3598C /* Deck inidat */ 3599 BLOCK DATA INIDAT 3600C 3601C Initialize MULD2H in common block /CCORB/ 3602C 3603#include "ccorb.h" 3604C 3605 DATA MULD2H/1,2,3,4,5,6,7,8, 3606 * 2,1,4,3,6,5,8,7, 3607 * 3,4,1,2,7,8,5,6, 3608 * 4,3,2,1,8,7,6,5, 3609 * 5,6,7,8,1,2,3,4, 3610 * 6,5,8,7,2,1,4,3, 3611 * 7,8,5,6,3,4,1,2, 3612 * 8,7,6,5,4,3,2,1/ 3613C 3614 END 3615C /* Deck ccsd_init1 */ 3616 SUBROUTINE CCSD_INIT1(WORK,LWORK) 3617C 3618C Henrik Koch and Alfredo Sanchez. 29-Jun-1994 3619C 3620C Set up indexing arrays 3621C 3622C FREEZE OC230899 3623C Frozen orbital bug-fix, tbp July 2003. 3624C 3625 3626 use dyn_iadrpk 3627 3628#include "implicit.h" 3629#include "priunit.h" 3630#include "dummy.h" 3631 DIMENSION WORK(LWORK) 3632C 3633 EXTERNAL INIDAT 3634C 3635#include "maxorb.h" 3636#include "ccsdinp.h" 3637#include "ccorb.h" 3638#include "ccsdsym.h" 3639#include "inftap.h" 3640#include "symsq.h" 3641#include "ccisao.h" 3642#include "r12int.h" 3643#include "cc3t3d.h" 3644Cholesky 3645#include "dccorb.h" 3646#include "dccsdsym.h" 3647#include "ccisvi.h" 3648Cholesky 3649C 3650 INTEGER NMATAK(8) 3651 LOGICAL FIRST 3652 DATA FIRST /.TRUE./ 3653C 3654C INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 3655C 3656 CALL QENTER('CCSD_INIT1') 3657C 3658C------------------------------------- 3659C Read in information from sirius. 3660C------------------------------------- 3661C 3662 CALL GPOPEN(LUSIFC,'SIRIFC','OLD',' ','UNFORMATTED',IDUMMY, 3663 & .FALSE.) 3664 REWIND LUSIFC 3665C 3666C LABEL is used (WK/UniKA/04-11-2002). 3667 CALL MOLLAB(LABEL,LUSIFC,LUPRI) 3668 READ (LUSIFC) NSYM, NORBTS, NBAST, NLAMDS, (NRHFS(I),I=1,NSYM), 3669 & (NORBS(I),I=1,NSYM), (NBAS(I),I=1,NSYM), PDUM, EDUM 3670cccms IF (FIRST .AND. LGLO) THEN 3671c DO ISYM = 1 , NSYM 3672c NORB1(ISYM) = NORB1(ISYM) + NRHFS(ISYM) 3673c ENDDO 3674c FIRST = .FALSE. 3675c END IF 3676C 3677 IF (FREEZE) THEN 3678 WRITE(LUPRI,*) 3679 WRITE(LUPRI,*) ' I am freezing!' 3680C 3681 KFOCKD = 1 3682 KFCS = KFOCKD + NORBTS 3683 KFVS = KFCS + NSYM 3684 KEND1 = KFVS + NSYM 3685 LEND1 = LWORK - KEND1 3686C 3687 READ (LUSIFC) (WORK(KFOCKD+I-1), I=1,NORBTS) 3688C 3689 CALL CC_FREEZER(WORK(KFOCKD),NORBTS,WORK(KFCS),WORK(KFVS), 3690 * WORK(KEND1),LEND1,LABEL) 3691C 3692 ENDIF 3693C 3694 CALL GPCLOSE(LUSIFC,'KEEP') 3695C 3696C----------------------------- 3697C Construct rest of CCORB. 3698C----------------------------- 3699C 3700 NNBASX = (NBAST*(NBAST+1))/2 3701 N2BASX = NBAST*NBAST 3702C 3703 NORBT = 0 3704 NRHFT = 0 3705 NRHFTS = 0 3706 N2BAST = 0 3707 NRHFTB = 0 3708C 3709 ICOUN1 = 0 3710 ICOUN2 = 0 3711 IOFF = 0 3712 JOFF = 0 ! ALFREDO OK? JOFF was not initialized in your ccsd_energy.F 3713C 3714 DO 5 ISYM = 1,NSYM 3715C 3716 NVIRS(ISYM) = NORBS(ISYM) - NRHFS(ISYM) 3717C 3718 NRHF(ISYM) = NRHFS(ISYM) - NRHFFR(ISYM) 3719 NVIR(ISYM) = NVIRS(ISYM) - NVIRFR(ISYM) 3720 NORB(ISYM) = NRHF(ISYM) + NVIR(ISYM) 3721C 3722 XRHF(ISYM) = 1.0D0 * NRHF(ISYM) 3723 XVIR(ISYM) = 1.0D0 * NVIR(ISYM) 3724C 3725 IF (LABEL.EQ.'TRCCINT ') THEN 3726 NRHFA(ISYM) = NRHF(ISYM) 3727 NRHFSA(ISYM) = NRHFS(ISYM) 3728 NRHFB(ISYM) = NRHF(ISYM) + NRXR12(ISYM) 3729 NRHFSB(ISYM) = NRHFS(ISYM) + NRXR12(ISYM) 3730 NRHFTB = NRHFTB + NRHFB(ISYM) 3731 ELSE 3732 NRHFA(ISYM) = NRHF(ISYM) - NRXR12(ISYM) 3733 NRHFSA(ISYM) = NRHFS(ISYM) - NRXR12(ISYM) 3734 NRHFB(ISYM) = NRHF(ISYM) 3735 NRHFSB(ISYM) = NRHFS(ISYM) 3736 NRHFTB = NRHFTB + NRHFB(ISYM) 3737 END IF 3738C 3739 NORBT = NORBT + NORB(ISYM) 3740 NRHFT = NRHFT + NRHF(ISYM) 3741 NRHFTS = NRHFTS + NRHFS(ISYM) 3742 N2BAST = N2BAST + NBAS(ISYM)*NBAS(ISYM) 3743C 3744 IORB(ISYM) = ICOUN1 3745 IBAS(ISYM) = ICOUN2 3746C 3747 ICOUN1 = ICOUN1 + NORB(ISYM) 3748 ICOUN2 = ICOUN2 + NBAS(ISYM) 3749C 3750 DO 6 I = 1,NBAS(ISYM) 3751C 3752 IOFF = IOFF + 1 3753 ISAO(IOFF) = ISYM 3754C 3755 6 CONTINUE 3756Cholesky 3757 DO I = 1,NVIR(ISYM) 3758 3759 JOFF = JOFF + 1 3760 ISVI(JOFF) = ISYM 3761 3762 ENDDO 3763Cholesky 3764 5 CONTINUE 3765C 3766 NVIRT = NORBT - NRHFT 3767 NVIRTS = NORBTS - NRHFTS 3768C 3769 IF (IPRINT .GT. 20) THEN 3770 CALL AROUND('Information from CCORB') 3771 WRITE(LUPRI,1) 'NBAS :',(NBAS(I), I=1,NSYM) 3772 WRITE(LUPRI,1) 'IBAS :',(IBAS(I), I=1,NSYM) 3773 WRITE(LUPRI,1) 'NRHF :',(NRHF(I), I=1,NSYM) 3774 WRITE(LUPRI,1) 'NVIR :',(NVIR(I), I=1,NSYM) 3775 WRITE(LUPRI,1) 'NRHFS :',(NRHFS(I), I=1,NSYM) 3776 WRITE(LUPRI,1) 'NVIRS :',(NVIRS(I), I=1,NSYM) 3777 WRITE(LUPRI,1) 'NRHFFR :',(NRHFFR(I), I=1,NSYM) 3778 WRITE(LUPRI,1) 'NVIRFR :',(NVIRFR(I), I=1,NSYM) 3779 WRITE(LUPRI,1) 'NORBTS :',NORBTS 3780 WRITE(LUPRI,1) 'NORBT :',NORBT 3781 WRITE(LUPRI,1) 'N2BAST :',N2BAST 3782 WRITE(LUPRI,1) 'N2BASX :',N2BASX 3783 WRITE(LUPRI,1) 'NNBASX :',NNBASX 3784 END IF 3785C 3786C-------------------------------------------------------- 3787C Construct implicitly frozen matrices. 3788C (Matrices for FROEXP constructed in input routine.) 3789C-------------------------------------------------------- 3790C 3791 IF (FROIMP) THEN 3792C 3793 DO 50 ISYM = 1,NSYM 3794C 3795 IF (NRHFFR(ISYM) .GT. MAXFRO) THEN 3796 WRITE(LUPRI,'(//,1X,2A,I3)') 'ERROR: Maximum number of ', 3797 & 'frozen orbitals per symmetry is:',MAXFRO 3798 CALL QUIT('Too many frozen orbitals') 3799 END IF 3800C 3801 DO 51 I = 1,NRHFFR(ISYM) 3802 KFRRHF(I,ISYM) = I 3803 51 CONTINUE 3804C 3805 IF (NVIRFR(ISYM) .GT. MAXFRO) THEN 3806 WRITE(LUPRI,'(//,1X,2A,I3)') 'ERROR: Maximum number of ', 3807 & 'frozen orbitals per symmetry is:',MAXFRO 3808 CALL QUIT('Too many frozen orbitals') 3809 END IF 3810C 3811 DO 52 I = 1,NVIRFR(ISYM) 3812 JORB = NVIRS(ISYM) - I + 1 3813 KFRVIR(I,ISYM) = JORB 3814 52 CONTINUE 3815C 3816 50 CONTINUE 3817C 3818 END IF 3819C 3820C------------------------------------------ 3821C Calculate the number of t-amplitudes. 3822C------------------------------------------ 3823C 3824 DO 100 ISYMAI = 1,NSYM 3825 NT1AM(ISYMAI) = 0 3826 NT1AO(ISYMAI) = 0 3827Chol 3828 XT1AM(ISYMAI) = 0.0D0 3829 XT1AO(ISYMAI) = 0.0D0 3830Chol 3831 NH1AM(ISYMAI) = 0 3832 NG1AM(ISYMAI) = 0 3833celena 3834 NT1VM(ISYMAI) = 0 3835celena 3836 DO 200 ISYMI = 1,NSYM 3837 ISYMA = MULD2H(ISYMAI,ISYMI) 3838 NT1AM(ISYMAI) = NT1AM(ISYMAI) + NVIR(ISYMA) * NRHF(ISYMI) 3839 NT1AO(ISYMAI) = NT1AO(ISYMAI) + NBAS(ISYMA) * NRHF(ISYMI) 3840Chol 3841 XT1AM(ISYMAI) = XT1AM(ISYMAI) + XVIR(ISYMA) * XRHF(ISYMI) 3842 XT1AO(ISYMAI) = XT1AO(ISYMAI) + NBAS(ISYMA) * XRHF(ISYMI) 3843Chol 3844 NH1AM(ISYMAI) = NH1AM(ISYMAI) + NORB1(ISYMA) * NRHF(ISYMI) 3845 NG1AM(ISYMAI) = NG1AM(ISYMAI) + NORB2(ISYMA) * NRHF(ISYMI) 3846celena 3847 NT1VM(ISYMAI) = NT1VM(ISYMAI) + NVIR(ISYMA) * 3848 & (NORB1(ISYMI)-NRHFFR(ISYMI)) 3849celena 3850 200 CONTINUE 3851 100 CONTINUE 3852C 3853 DO 300 ISAIBJ = 1,NSYM 3854 NT2AM(ISAIBJ) = 0 3855 NT2AO(ISAIBJ) = 0 3856 NT2AMA(ISAIBJ) = 0 3857 NT2AMT(ISAIBJ) = 0 3858 NH2AM(ISAIBJ) = 0 3859 NU2AM(ISAIBJ) = 0 3860Chol 3861 XT2AM(ISAIBJ) = 0.0D0 3862Chol 3863 DO 400 ISYMBJ = 1,NSYM 3864 ISYMAI = MULD2H(ISYMBJ,ISAIBJ) 3865 IF (ISYMBJ .GT. ISYMAI) THEN 3866 NT2AM(ISAIBJ) = NT2AM(ISAIBJ) + 3867 & NT1AM(ISYMAI) * NT1AM(ISYMBJ) 3868 NT2AO(ISAIBJ) = NT2AO(ISAIBJ) + 3869 & NT1AO(ISYMAI) * NT1AO(ISYMBJ) 3870 NT2AMA(ISAIBJ)= NT2AM(ISAIBJ) 3871 NT2AMT(ISAIBJ)= NT2AM(ISAIBJ) + NT2AMA(ISAIBJ) 3872Chol 3873 XT2AM(ISAIBJ) = XT2AM(ISAIBJ) + 3874 & XT1AM(ISYMAI) * XT1AM(ISYMBJ) 3875Chol 3876 NH2AM(ISAIBJ) = NH2AM(ISAIBJ) + 3877 & NH1AM(ISYMAI) * NT1AM(ISYMBJ) 3878 ELSE IF (ISYMBJ .EQ. ISYMAI) THEN 3879 NT2AM(ISAIBJ) = NT2AM(ISAIBJ) + 3880 & NT1AM(ISYMAI) * (NT1AM(ISYMBJ)+1)/2 3881 NT2AO(ISAIBJ) = NT2AO(ISAIBJ) + 3882 & NT1AO(ISYMAI) * (NT1AO(ISYMBJ)+1)/2 3883 NT2AMA(ISAIBJ)= NT2AM(ISAIBJ) 3884 NT2AMT(ISAIBJ)= NT2AM(ISAIBJ) + NT2AMA(ISAIBJ) 3885Chol 3886 XT2AM(ISAIBJ) = XT2AM(ISAIBJ) + 3887 & XT1AM(ISYMAI) * (XT1AM(ISYMBJ)+1.0D0) / 2.0D0 3888Chol 3889 NH2AM(ISAIBJ) = NH2AM(ISAIBJ) + 3890 & NH1AM(ISYMAI) * (NH1AM(ISYMBJ)+1)/2 + 3891 & NH1AM(ISYMAI) * NG1AM(ISYMBJ) 3892 END IF 3893C For [T1+T2,r12] integrals (WK/UniKA/04-11-2002). 3894 NU2AM(ISAIBJ) = NU2AM(ISAIBJ) + 3895 & NT1AM(ISYMAI) * NT1AM(ISYMBJ) 3896 400 CONTINUE 3897 300 CONTINUE 3898C 3899 NT1AMX = NT1AM(1) 3900 NT1AOX = NT1AO(1) 3901 NH1AMX = NH1AM(1) 3902 NT2AMX = NT2AM(1) 3903 NT2AOX = NT2AO(1) 3904 NU2AMX = NU2AM(1) 3905 NH2AMX = NH2AM(1) 3906 NT1VMX = NT1VM(1) 3907C 3908 ICOUN1 = 0 3909 DO 450 ISYM = 1,NSYM 3910C 3911 NNBST(ISYM) = 0 3912 N2BST(ISYM) = 0 3913C 3914 DO 460 ISYMB = 1,NSYM 3915C 3916 ISYMA = MULD2H(ISYMB,ISYM) 3917C 3918 N2BST(ISYM) = N2BST(ISYM) + NBAS(ISYMA)*NBAS(ISYMB) 3919C 3920 IF (ISYMB .GT. ISYMA) THEN 3921 NNBST(ISYM) = NNBST(ISYM) + NBAS(ISYMA)*NBAS(ISYMB) 3922 ELSE IF (ISYMB .EQ. ISYMA) THEN 3923 NNBST(ISYM) = NNBST(ISYM) + NBAS(ISYMA)*(NBAS(ISYMA)+1)/2 3924 ENDIF 3925C 3926 460 CONTINUE 3927C 3928 I2BST(ISYM) = ICOUN1 3929C 3930 ICOUN1 = ICOUN1 + N2BST(ISYM) 3931C 3932 450 CONTINUE 3933 N2BSTX = ICOUN1 3934C 3935 DO 500 ISYMD = 1,NSYM 3936 NDISAO(ISYMD) = 0 3937 NDSRHF(ISYMD) = 0 3938 NDISAOSQ(ISYMD) = 0 3939 NDSRHFSQ(ISYMD) = 0 3940 NT2BCD(ISYMD) = 0 3941 NT2BGD(ISYMD) = 0 3942 DO 510 ISYMG = 1,NSYM 3943 ISYMAB = MULD2H(ISYMG,ISYMD) 3944 NDISAO(ISYMD) = NDISAO(ISYMD) + NNBST(ISYMAB)*NBAS(ISYMG) 3945 NDSRHF(ISYMD) = NDSRHF(ISYMD) + NNBST(ISYMAB)*NRHF(ISYMG) 3946 NDISAOSQ(ISYMD)=NDISAOSQ(ISYMD)+N2BST(ISYMAB)*NBAS(ISYMG) 3947 NDSRHFSQ(ISYMD)=NDSRHFSQ(ISYMD)+N2BST(ISYMAB)*NRHF(ISYMG) 3948 NT2BCD(ISYMD) = NT2BCD(ISYMD) + NT1AM(ISYMAB)*NRHF(ISYMG) 3949 NT2BGD(ISYMD) = NT2BGD(ISYMD) + NT1AO(ISYMAB)*NRHF(ISYMG) 3950 510 CONTINUE 3951 500 CONTINUE 3952C 3953 ICOUN1 = 0 3954 ICOUN2 = 0 3955 ICOUN3 = 0 3956 ICOUN4 = NRHFT 3957 ICOUN5 = 0 3958 ICOUN6 = 0 3959 ICOUN7 = 0 3960 ICOUN8 = 0 3961 DO 600 ISYMP = 1,NSYM 3962 ICOUN1 = ICOUN1 + NBAS(ISYMP)*NORB(ISYMP) 3963 ICOUN2 = ICOUN2 + NBAS(ISYMP)*NRHF(ISYMP) 3964 ICOUN5 = ICOUN5 + NBAS(ISYMP)*NRHFS(ISYMP) 3965C 3966 IRHF(ISYMP) = ICOUN3 3967 IRHFA(ISYMP) = ICOUN7 3968 IRHFB(ISYMP) = ICOUN8 3969 IVIR(ISYMP) = ICOUN4 3970 ICOUN3 = ICOUN3 + NRHF(ISYMP) 3971 ICOUN4 = ICOUN4 + NVIR(ISYMP) 3972 ICOUN7 = ICOUN7 + NRHFA(ISYMP) 3973 ICOUN8 = ICOUN8 + NRHFB(ISYMP) 3974C 3975 600 CONTINUE 3976 NLAMDT = ICOUN1 3977 NLMRHF = ICOUN2 3978 NLRHSI = ICOUN5 3979C 3980 DO 610 ISYMK = 1,NSYM 3981 ICOUN1 = 0 3982 ICOUN2 = 0 3983 ICOUN3 = 0 3984 ICOUN4 = 0 3985Chol 3986 XCOUN4 = 0.0D0 3987Chol 3988 ICOUN5 = 0 3989 ICOUN6 = 0 3990 ICOUN7 = 0 3991 ICOUN8 = 0 3992 ICOUN9 = 0 3993 ICOU10 = 0 3994 ICOU11 = 0 3995 ICOU12 = 0 3996 ICOU13 = 0 3997 ICOU14 = 0 3998 ICOU15 = 0 3999 ICOU16 = 0 4000 ICOU17 = 0 4001 ICOU18 = 0 4002 ICOU19 = 0 4003C For [T1+T2,r12] integrals (WK/UniKA/04-11-2002). 4004 ICOU20 = 0 4005 ICOU21 = 0 4006 ICOU22 = 0 4007 ICOU23 = 0 4008C For R12-index pairs (C. Neiss): 4009 ICOU24 = 0 4010 ICOU25 = 0 4011 ICOU26 = 0 4012 DO 620 ISYMJ = 1,NSYM 4013C 4014 ISYMI = MULD2H(ISYMJ,ISYMK) 4015C 4016 IT1AM(ISYMI,ISYMJ) = ICOUN1 4017 IH1AM(ISYMI,ISYMJ) = ICOU21 4018 IG1AM(ISYMI,ISYMJ) = ICOU23 4019 IT1AO(ISYMI,ISYMJ) = ICOUN5 4020 IT1AMT(ISYMI,ISYMJ) = ICOU11 4021 IT1AOT(ISYMI,ISYMJ) = ICOU12 4022 IEMAT1(ISYMI,ISYMJ) = ICOU15 4023 IMATAV(ISYMI,ISYMJ) = ICOU18 4024C 4025 IF (ISYMJ .GE. ISYMI) THEN 4026C For [T1+T2,r12] integrals (WK/UniKA/04-11-2002). 4027 IU2AM(ISYMI,ISYMJ) = ICOU20 4028 IU2AM(ISYMJ,ISYMI) = ICOU20 4029 IH2AM(ISYMI,ISYMJ) = ICOU22 4030 IH2AM(ISYMJ,ISYMI) = ICOU22 4031 ICOU20 = ICOU20 + NT1AM(ISYMI)*NT1AM(ISYMJ) 4032 IF (ISYMJ .EQ. ISYMI) THEN 4033 ICOU22 = ICOU22 + NH1AM(ISYMI)*(NH1AM(ISYMJ)+1)/2 + 4034 & NH1AM(ISYMI)*NG1AM(ISYMJ) 4035 ELSE 4036 ICOU22 = ICOU22 + NH1AM(ISYMI)*NT1AM(ISYMJ) 4037 END IF 4038 END IF 4039C 4040 ICOUN1 = ICOUN1 + NRHF(ISYMJ)*NVIR(ISYMI) 4041 ICOU21 = ICOU21 + NRHF(ISYMJ)*NORB1(ISYMI) 4042 ICOU23 = ICOU23 + NRHF(ISYMJ)*NORB2(ISYMI) 4043 ICOUN5 = ICOUN5 + NRHF(ISYMJ)*NBAS(ISYMI) 4044 ICOU11 = ICOU11 + NRHF(ISYMI)*NVIR(ISYMJ) 4045 ICOU12 = ICOU12 + NRHF(ISYMI)*NBAS(ISYMJ) 4046 ICOU15 = ICOU15 + NVIR(ISYMI)*NBAS(ISYMJ) 4047 ICOU18 = ICOU18 + NBAS(ISYMI)*NVIR(ISYMJ) 4048C 4049 IF (ISYMJ .GT. ISYMI) THEN 4050 IT2AM(ISYMI,ISYMJ) = ICOUN2 4051 IT2AM(ISYMJ,ISYMI) = ICOUN2 4052 ICOUN2 = ICOUN2 + NT1AM(ISYMI)*NT1AM(ISYMJ) 4053 IT2AO(ISYMI,ISYMJ) = ICOUN6 4054 IT2AO(ISYMJ,ISYMI) = ICOUN6 4055 ICOUN6 = ICOUN6 + NT1AO(ISYMI)*NT1AO(ISYMJ) 4056 ELSE IF (ISYMK .EQ. 1) THEN 4057 IT2AM(ISYMI,ISYMJ) = ICOUN2 4058 ICOUN2 = ICOUN2 + NT1AM(ISYMI)*(NT1AM(ISYMI)+1)/2 4059 IT2AO(ISYMI,ISYMJ) = ICOUN6 4060 ICOUN6 = ICOUN6 + NT1AO(ISYMI)*(NT1AO(ISYMI)+1)/2 4061 ENDIF 4062C 4063 IT2BGD(ISYMI,ISYMJ) = ICOUN8 4064 IT2BCD(ISYMI,ISYMJ) = ICOUN9 4065 IDSRHF(ISYMI,ISYMJ) = ICOU10 4066 IT2BGT(ISYMI,ISYMJ) = ICOU13 4067 IT2BCT(ISYMI,ISYMJ) = ICOU14 4068 ICKALP(ISYMI,ISYMJ) = ICOU16 4069 ICKATR(ISYMI,ISYMJ) = ICOU17 4070 IDSRHFSQ(ISYMI,ISYMJ) = ICOU19 4071C 4072 ICOUN3 = ICOUN3 + NVIR(ISYMI)*NBAS(ISYMJ) 4073 ICOUN4 = ICOUN4 + NRHF(ISYMI)*NRHF(ISYMJ) 4074Chol 4075 XCOUN4 = XCOUN4 + XRHF(ISYMI)*XRHF(ISYMJ) 4076Chol 4077 ICOU24 = ICOU24 + NRHFB(ISYMI)*NRHFB(ISYMJ) 4078 ICOU25 = ICOU25 + NRHFB(ISYMI)*NRHFA(ISYMJ) 4079 ICOU26 = ICOU26 + NVIR(ISYMI)*NRHFB(ISYMJ) 4080C 4081 IT2SQ(ISYMI,ISYMJ) = ICOUN7 4082C 4083 ICOUN7 = ICOUN7 + NT1AM(ISYMI)*NT1AM(ISYMJ) 4084 ICOUN8 = ICOUN8 + NT1AO(ISYMI)*NRHF(ISYMJ) 4085 ICOUN9 = ICOUN9 + NT1AM(ISYMI)*NRHF(ISYMJ) 4086 ICOU10 = ICOU10 + NNBST(ISYMI)*NRHF(ISYMJ) 4087 ICOU13 = ICOU13 + NT1AO(ISYMJ)*NRHF(ISYMI) 4088 ICOU14 = ICOU14 + NT1AM(ISYMJ)*NRHF(ISYMI) 4089 ICOU16 = ICOU16 + NT1AM(ISYMI)*NBAS(ISYMJ) 4090 ICOU17 = ICOU17 + NT1AM(ISYMI)*NVIR(ISYMJ) 4091 ICOU19 = ICOU19 + N2BST(ISYMI)*NRHF(ISYMJ) 4092C 4093 620 CONTINUE 4094C 4095 NEMAT1(ISYMK) = ICOUN3 4096 NMATIJ(ISYMK) = ICOUN4 4097 NMATAV(ISYMK) = ICOU18 4098Chol 4099 XMATIJ(ISYMK) = XCOUN4 4100Chol 4101 NMATKL(ISYMK) = ICOU24 4102 NMATKI(ISYMK) = ICOU25 4103 NMATAK(ISYMK) = ICOU26 4104C 4105 610 CONTINUE 4106C 4107 DO 630 ISYMK = 1,NSYM 4108 ICOUN1 = 0 4109 ICOUN2 = 0 4110 ICOUN3 = 0 4111C For R12 (C. Neiss): 4112 ICOUN4 = 0 4113 ICOUN5 = 0 4114 ICOUN6 = 0 4115 ICOUN7 = 0 4116 ICOUN8 = 0 4117 DO 640 ISYMJ = 1,NSYM 4118 ISYMI = MULD2H(ISYMJ,ISYMK) 4119C 4120 IF (ISYMJ .GT. ISYMI) THEN 4121 ICOUN1 = ICOUN1 + NMATIJ(ISYMI)*NMATIJ(ISYMJ) 4122 ICOUN4 = ICOUN4 + NMATKI(ISYMI)*NMATKI(ISYMJ) 4123 ICOUN5 = ICOUN5 + NMATKL(ISYMI)*NMATKL(ISYMJ) 4124 IT2R12(ISYMI,ISYMJ) = ICOUN8 4125 IT2R12(ISYMJ,ISYMI) = ICOUN8 4126 ICOUN8 = ICOUN8 + NMATAK(ISYMI)* NMATAK(ISYMJ) 4127 ELSE IF (ISYMK .EQ. 1) THEN 4128 ICOUN1 = ICOUN1 + NMATIJ(ISYMI)*(NMATIJ(ISYMI)+1)/2 4129 ICOUN4 = ICOUN4 + NMATKI(ISYMI)*(NMATKI(ISYMI)+1)/2 4130 ICOUN5 = ICOUN5 + NMATKL(ISYMI)*(NMATKL(ISYMI)+1)/2 4131 IT2R12(ISYMI,ISYMJ) = ICOUN8 4132 ICOUN8 = ICOUN8 + NMATAK(ISYMI)*(NMATAK(ISYMJ)+1)/2 4133 ENDIF 4134C 4135 ICOUN2 = ICOUN2 + NVIR(ISYMI)*NVIR(ISYMJ) 4136 ICOUN3 = ICOUN3 + NMATIJ(ISYMI)*NMATIJ(ISYMJ) 4137 ICOUN6 = ICOUN6 + NMATIJ(ISYMI)*NMATKL(ISYMJ) 4138 ICOUN7 = ICOUN7 + NMATKL(ISYMI)*NMATKL(ISYMJ) 4139C 4140 640 CONTINUE 4141C 4142 NGAMMA(ISYMK) = ICOUN1 4143 NMATAB(ISYMK) = ICOUN2 4144 NGAMSQ(ISYMK) = ICOUN3 4145C For R12 (C. Neiss): 4146 NTR12AM(ISYMK) = ICOUN4 4147 NR12R12P(ISYMK) = ICOUN5 4148 NTR12SQ(ISYMK) = ICOUN6 4149 NR12R12SQ(ISYMK)= ICOUN7 4150 NT2R12(ISYMK) = ICOUN8 4151C 4152 630 CONTINUE 4153C 4154 IF ((.NOT. ONEAUX) .AND. (.NOT.LABEL.EQ.'TRCCINT ')) THEN 4155c IF (.NOT. ONEAUX) THEN 4156 NH1AMX = NT1AMX 4157 NH2AMX = NT2AMX 4158 DO ISYMI = 1,NSYM 4159 NH1AM(ISYMI) = NT1AM(ISYMI) 4160 NH2AM(ISYMI) = NT2AM(ISYMI) 4161 DO ISYMJ = 1,NSYM 4162 IH1AM(ISYMI,ISYMJ) = IT1AM(ISYMI,ISYMJ) 4163 IH2AM(ISYMI,ISYMJ) = IT2AM(ISYMI,ISYMJ) 4164 ENDDO 4165 ENDDO 4166 END IF 4167C 4168C-------------------------------------------------------- 4169C Section for calculating index arrays needed in left 4170C hand side transformation. Asger Halkier 30/10-1995! 4171C Revised 7/3-1996 for index arrays for densities! 4172C-------------------------------------------------------- 4173C 4174 DO 550 ISYIJK = 1,NSYM 4175 ICOUN1 = 0 4176 ICOUN2 = 0 4177 ICOUN3 = 0 4178 ICOUN4 = 0 4179 ICOUN5 = 0 4180 ICOUN6 = 0 4181 ICOUN7 = 0 4182 ICOUN8 = 0 4183 ICOUN9 = 0 4184 ICOUN10 = 0 4185 ICOUN11 = 0 4186 DO 560 ISYMK = 1,NSYM 4187 ISYMIJ = MULD2H(ISYMK,ISYIJK) 4188 IMAIJK(ISYMIJ,ISYMK) = ICOUN1 4189 IT2AIJ(ISYMIJ,ISYMK) = ICOUN2 4190 IMAIJA(ISYMIJ,ISYMK) = ICOUN3 4191 ID2IJG(ISYMIJ,ISYMK) = ICOUN4 4192 ID2AIG(ISYMIJ,ISYMK) = ICOUN5 4193 ID2ABG(ISYMIJ,ISYMK) = ICOUN6 4194 IMAABC(ISYMIJ,ISYMK) = ICOUN7 4195 IMAABI(ISYMIJ,ISYMK) = ICOUN8 4196 IMAIAB(ISYMIJ,ISYMK) = ICOUN9 4197 IMAIAJ(ISYMIJ,ISYMK) = ICOUN10 4198Cholesky 4199 IT2VO(ISYMIJ,ISYMK) = ICOUN11 4200Cholesky 4201 ICOUN1 = ICOUN1 + NMATIJ(ISYMIJ)*NRHF(ISYMK) 4202 ICOUN2 = ICOUN2 + NVIR(ISYMIJ)*NMATIJ(ISYMK) 4203 ICOUN3 = ICOUN3 + NMATIJ(ISYMIJ)*NVIR(ISYMK) 4204 ICOUN4 = ICOUN4 + NMATIJ(ISYMIJ)*NBAS(ISYMK) 4205 ICOUN5 = ICOUN5 + NT1AM(ISYMIJ)*NBAS(ISYMK) 4206 ICOUN6 = ICOUN6 + NMATAB(ISYMIJ)*NBAS(ISYMK) 4207 ICOUN7 = ICOUN7 + NMATAB(ISYMIJ)*NVIR(ISYMK) 4208 ICOUN8 = ICOUN8 + NMATAB(ISYMIJ)*NRHF(ISYMK) 4209 ICOUN9 = ICOUN9 + NT1AM(ISYMIJ)*NVIR(ISYMK) 4210 ICOUN10 = ICOUN10 + NRHF(ISYMIJ)*NT1AM(ISYMK) 4211Cholesky 4212 ICOUN11 = ICOUN11 + NMATAB(ISYMIJ)*NMATIJ(ISYMK) 4213Cholesky 4214 560 CONTINUE 4215 NMAIJK(ISYIJK) = ICOUN1 4216 NT2AIJ(ISYIJK) = ICOUN2 4217 NMAIJA(ISYIJK) = ICOUN3 4218 ND2IJG(ISYIJK) = ICOUN4 4219 ND2AIG(ISYIJK) = ICOUN5 4220 ND2ABG(ISYIJK) = ICOUN6 4221 NMAABC(ISYIJK) = ICOUN7 4222 NMAABI(ISYIJK) = ICOUN8 4223 NMAIAB(ISYIJK) = ICOUN9 4224 NMAIAJ(ISYIJK) = ICOUN10 4225 550 CONTINUE 4226C 4227 DO 570 ISIJKD = 1,NSYM 4228 ICOUN1 = 0 4229 ICOUN2 = 0 4230 ICOUN3 = 0 4231 ICOUN4 = 0 4232 ICOUN5 = 0 4233 ICOUN6 = 0 4234 ICOUN7 = 0 4235 ICOUN8 = 0 4236 ICOUN9 = 0!added by FP 16-03-04, needed for new CC3 LHTR 4237 ICOUN10 = 0!added by FP 16-03-04, needed for new CC3 LHTR 4238 ICOUN11 = 0!added by FP 16-03-04, needed for new CC3 LHTR 4239 4240C 4241 DO 580 ISYMD = 1,NSYM 4242 ISYIJK = MULD2H(ISYMD,ISIJKD) 4243 I3ODEL(ISYIJK,ISYMD) = ICOUN1 4244 I3ORHF(ISYIJK,ISYMD) = ICOUN2 4245 I3OVIR(ISYIJK,ISYMD) = ICOUN3 4246 I3VDEL(ISYIJK,ISYMD) = ICOUN4 4247 I3VVIR(ISYIJK,ISYMD) = ICOUN5 4248 I3VOOO(ISYIJK,ISYMD) = ICOUN6 4249 IMAABCI(ISYIJK,ISYMD) = ICOUN7 4250 IMAAB_CI(ISYIJK,ISYMD) = ICOUN8 4251 I3AORHF(ISYIJK,ISYMD) = ICOUN9!added by FP 16-03-04 (new CC3 LHTR) 4252 I3AO(ISYIJK,ISYMD) = ICOUN10!added by FP 16-03-04 (new CC3 LHTR) 4253 IRHF3O(ISYIJK,ISYMD) = ICOUN11!added by FP 29-03-04 (new CC3 LHTR) 4254 4255 ICOUN1 = ICOUN1 + NMAIJK(ISYIJK)*NBAS(ISYMD) 4256 ICOUN2 = ICOUN2 + NMAIJK(ISYIJK)*NRHF(ISYMD) 4257 ICOUN3 = ICOUN3 + NMAIJK(ISYIJK)*NVIR(ISYMD) 4258 ICOUN4 = ICOUN4 + NMAABC(ISYIJK)*NBAS(ISYMD) 4259 ICOUN5 = ICOUN5 + NMAABC(ISYIJK)*NVIR(ISYMD) 4260 ICOUN6 = ICOUN6 + NVIR(ISYIJK)*NMAIJK(ISYMD) 4261 ICOUN7 = ICOUN7 + NMAABC(ISYIJK)*NRHF(ISYMD) 4262 ICOUN8 = ICOUN8 + NMATAB(ISYIJK)*NT1AM(ISYMD) 4263 ICOUN9 = ICOUN9 + NDISAOSQ(ISYIJK)*NRHF(ISYMD)!FP 16-03-04(CC3 LHTR) 4264 ICOUN10 = ICOUN10 + N2BST(ISYIJK)*NBAS(ISYMD)!FP (CC3 LHTR) 4265 ICOUN11 = ICOUN11 + NRHF(ISYIJK)*NMAIJK(ISYMD)!FP (CC3 LHTR) 4266C 4267 580 CONTINUE 4268 N3ODEL(ISIJKD) = ICOUN1 4269 N3ORHF(ISIJKD) = ICOUN2 4270 N3OVIR(ISIJKD) = ICOUN3 4271 N3VDEL(ISIJKD) = ICOUN4 4272 N3VVIR(ISIJKD) = ICOUN5 4273 N3VOOO(ISIJKD) = ICOUN6 4274 NMAABCI(ISIJKD) = ICOUN7 4275 NMAAB_CI(ISIJKD) = ICOUN8 4276 N3AORHF(ISIJKD) = ICOUN9!FP 16-03-04(CC3 LHTR) 4277 N3AO(ISIJKD) = ICOUN10!FP 16-03-04(CC3 LHTR) 4278 NRHF3O(ISIJKD) = ICOUN11!FP 29-03-04(CC3 LHTR) 4279 4280 570 CONTINUE 4281C 4282 ICOUN = 0 4283C 4284 DO 590 ISYM = 1,NSYM 4285C 4286 IFCKDO(ISYM) = ICOUN 4287 ICOUN = ICOUN + NORB(ISYM)*NRHF(ISYM) 4288 IFCKDV(ISYM) = ICOUN 4289 ICOUN = ICOUN + NORB(ISYM)*NVIR(ISYM) 4290C 4291 590 CONTINUE 4292C 4293 ICOUN1 = 0 4294 ICOUN2 = NLMRHF 4295 ICOUN7 = 0 4296 ICOUN8 = NLRHSI 4297 DO 700 ISYMI = 1,NSYM 4298C 4299 ILMRHF(ISYMI) = ICOUN1 4300 ILMVIR(ISYMI) = ICOUN2 4301 ICOUN1 = ICOUN1 + NBAS(ISYMI)*NRHF(ISYMI) 4302 ICOUN2 = ICOUN2 + NBAS(ISYMI)*NVIR(ISYMI) 4303C 4304 ILRHSI(ISYMI) = ICOUN7 4305 ILVISI(ISYMI) = ICOUN8 4306 ICOUN7 = ICOUN7 + NBAS(ISYMI)*NRHFS(ISYMI) 4307 ICOUN8 = ICOUN8 + NBAS(ISYMI)*NVIRS(ISYMI) 4308C 4309 ICOUN3 = 0 4310 ICOUN4 = 0 4311 ICOUN5 = 0 4312 ICOUN6 = 0 4313 ICOUN9 = 0 4314 ICOU10 = 0 4315C For R12 (C. Neiss): 4316 ICOU11 = 0 4317 ICOU12 = 0 4318 ICOU13 = 0 4319 ICOU14 = 0 4320 ICOU15 = 0 4321 ICOU16 = 0 4322 ICOU17 = 0 4323C 4324 DO 710 ISYMJ = 1,NSYM 4325C 4326 ISYMK = MULD2H(ISYMJ,ISYMI) 4327C 4328 IDSAOG(ISYMJ,ISYMI) = ICOUN3 4329 IMATIJ(ISYMK,ISYMJ) = ICOUN4 4330 IGAMMA(ISYMK,ISYMJ) = ICOUN5 4331 IGAMMA(ISYMJ,ISYMK) = ICOUN5 4332 IGAMSQ(ISYMJ,ISYMK) = ICOU10 4333 IMATAB(ISYMK,ISYMJ) = ICOUN6 4334 IDSAOGSQ(ISYMJ,ISYMI) = ICOUN9 4335 IMATKL(ISYMK,ISYMJ) = ICOU11 4336 IMATKI(ISYMK,ISYMJ) = ICOU12 4337 ITR12AM(ISYMK,ISYMJ) = ICOU13 4338 ITR12AM(ISYMJ,ISYMK) = ICOU13 4339 ITR12SQ(ISYMJ,ISYMK) = ICOU14 4340 ITR12SQT(ISYMJ,ISYMK) = ICOU17 4341C ITR12SQT(ISYMJ,ISYMK) = ITR12SQ(ISYMJ,ISYMK) 4342 IR12R12P(ISYMK,ISYMJ) = ICOU15 4343 IR12R12P(ISYMJ,ISYMK) = ICOU15 4344 IR12R12SQ(ISYMJ,ISYMK)= ICOU16 4345C 4346 ICOUN3 = ICOUN3 + NNBST(ISYMK)*NBAS(ISYMJ) 4347 ICOUN4 = ICOUN4 + NRHF(ISYMK)*NRHF(ISYMJ) 4348 ICOUN6 = ICOUN6 + NVIR(ISYMK)*NVIR(ISYMJ) 4349 ICOUN9 = ICOUN9 + N2BST(ISYMK)*NBAS(ISYMJ) 4350 ICOU10 = ICOU10 + NMATIJ(ISYMK)*NMATIJ(ISYMJ) 4351 ICOU11 = ICOU11 + NRHFB(ISYMK)*NRHFB(ISYMJ) 4352 ICOU12 = ICOU12 + NRHFB(ISYMK)*NRHFA(ISYMJ) 4353 ICOU14 = ICOU14 + NMATIJ(ISYMK)*NMATKL(ISYMJ) 4354 ICOU17 = ICOU17 + NMATKL(ISYMK)*NMATIJ(ISYMJ) 4355 ICOU16 = ICOU16 + NMATKL(ISYMK)*NMATKL(ISYMJ) 4356C 4357 IF (ISYMJ .GT. ISYMK) THEN 4358 ICOUN5 = ICOUN5 + NMATIJ(ISYMK)*NMATIJ(ISYMJ) 4359 ICOU13 = ICOU13 + NMATKI(ISYMK)*NMATKI(ISYMJ) 4360 ICOU15 = ICOU15 + NMATKL(ISYMK)*NMATKL(ISYMJ) 4361 ELSE IF (ISYMI .EQ. 1) THEN 4362 ICOUN5 = ICOUN5 + NMATIJ(ISYMJ)*(NMATIJ(ISYMJ)+1)/2 4363 ICOU13 = ICOU13 + NMATKI(ISYMJ)*(NMATKI(ISYMJ)+1)/2 4364 ICOU15 = ICOU15 + NMATKL(ISYMJ)*(NMATKL(ISYMJ)+1)/2 4365 ENDIF 4366C 4367 710 CONTINUE 4368 700 CONTINUE 4369C 4370 DO 720 ISYMAB = 1,NSYM 4371 ICOUN1 = 0 4372 ICOUN2 = 0 4373 DO 730 ISYMB = 1,NSYM 4374C 4375 ISYMA = MULD2H(ISYMB,ISYMAB) 4376C 4377 IAODIS(ISYMA,ISYMB) = ICOUN1 4378 IAODPK(ISYMA,ISYMB) = ICOUN2 4379 IAODPK(ISYMB,ISYMA) = ICOUN2 4380C 4381 ICOUN1 = ICOUN1 + NBAS(ISYMA)*NBAS(ISYMB) 4382 IF (ISYMB .GT. ISYMA) THEN 4383 ICOUN2 = ICOUN2 + NBAS(ISYMA)*NBAS(ISYMB) 4384 ELSE IF (ISYMAB .EQ. 1) THEN 4385 ICOUN2 = ICOUN2 + NBAS(ISYMB)*(NBAS(ISYMB)+1)/2 4386 ENDIF 4387C 4388 730 CONTINUE 4389 720 CONTINUE 4390C 4391 DO 800 ISYM = 1,NSYM 4392C 4393 ICOUNT = 0 4394 DO 810 ISYMK = 1,NSYM 4395C 4396 ISYMP = MULD2H(ISYMK,ISYM) 4397C 4398 IFCRHF(ISYMP,ISYMK) = ICOUNT 4399C 4400 ICOUNT = ICOUNT + NORB(ISYMP)*NRHF(ISYMK) 4401C 4402 810 CONTINUE 4403C 4404 DO 820 ISYMC = 1,NSYM 4405C 4406 ISYMP = MULD2H(ISYMC,ISYM) 4407C 4408 IFCVIR(ISYMP,ISYMC) = ICOUNT 4409C 4410 ICOUNT = ICOUNT + NORB(ISYMP)*NVIR(ISYMC) 4411C 4412 820 CONTINUE 4413C 4414 800 CONTINUE 4415C 4416C 4417 DO 900 ISYM = 1,NSYM 4418C 4419 ICOUNT = 0 4420 ICOUN1 = 0 4421 ICOUN2 = 0 4422C 4423 XCOUN1 = 0.0D0 4424C 4425 DO 910 ISYMJ = 1,NSYM 4426C 4427 ISYMI = MULD2H(ISYMJ,ISYM) 4428 IT2AOS(ISYMI,ISYMJ) = ICOUNT 4429 ITG2SQ(ISYMI,ISYMJ) = ICOUN2 4430C 4431 ICOUNT = ICOUNT + NT1AO(ISYMI)*NT1AO(ISYMJ) 4432 ICOUN1 = ICOUN1 + NT1AM(ISYMI)*NT1AM(ISYMJ) 4433 ICOUN2 = ICOUN2 + NT1AM(ISYMI)*NG1AM(ISYMJ) 4434C 4435 XCOUN1 = XCOUN1 + XT1AM(ISYMI)*XT1AM(ISYMJ) 4436C 4437 910 CONTINUE 4438C 4439 NT2AOS(ISYM) = ICOUNT 4440 NT2SQ(ISYM) = ICOUN1 4441 NTG2SQ(ISYM) = ICOUN2 4442C 4443 XT2SQ(ISYM) = XCOUN1 4444C 4445 900 CONTINUE 4446C 4447 call get_iadrpk(lupri,nsym,muld2h,nbas,nbast,i2bst,iaodis,iaodpk) 4448C 4449 DO 1000 ISYM = 1,NSYM 4450C 4451 ICOUN1 = 0 4452 DO 1010 ISYMJ = 1,NSYM 4453C 4454 ISYMI = MULD2H(ISYMJ,ISYM) 4455C 4456 IF (ISYMI .GT. ISYMJ) GOTO 1010 4457C 4458 IMIJP(ISYMI,ISYMJ) = ICOUN1 4459 IMIJP(ISYMJ,ISYMI) = ICOUN1 4460C 4461 IF (ISYMI .EQ. ISYMJ) THEN 4462 ICOUN1 = ICOUN1 + NRHF(ISYMI)*(NRHF(ISYMI) + 1)/2 4463 ELSE 4464 ICOUN1 = ICOUN1 + NRHF(ISYMI)*NRHF(ISYMJ) 4465 ENDIF 4466C 4467 1010 CONTINUE 4468C 4469 NMIJP(ISYM) = ICOUN1 4470C 4471 1000 CONTINUE 4472C 4473C 4474 DO 1020 ISYM = 1,NSYM 4475C 4476 ICOUNT = 0 4477 ICOUN1 = 0 4478 ICOUN2 = 0 4479C 4480 DO 1030 ISYMJ = 1,NSYM 4481C 4482 ISYMI = MULD2H(ISYMJ,ISYM) 4483C 4484 IT2ORT(ISYMI,ISYMJ) = ICOUNT 4485 IT2AOIJ(ISYMI,ISYMJ) = ICOUN1 4486 IT2ORT3(ISYMI,ISYMJ) = ICOUN2 4487C 4488 ICOUNT = ICOUNT + NNBST(ISYMI)*NMIJP(ISYMJ) 4489 ICOUN1 = ICOUN1 + NT1AO(ISYMI)*NMATIJ(ISYMJ) 4490 ICOUN2 = ICOUN2 + NNBST(ISYMI)*NMATIJ(ISYMJ) 4491C 4492 1030 CONTINUE 4493C 4494 NT2ORT(ISYM) = ICOUNT 4495 NT2AOIJ(ISYM) = ICOUN1 4496 NT2ORT3(ISYM) = ICOUN2 4497C 4498 1020 CONTINUE 4499C 4500 DO 1040 ISYCKA = 1,NSYM 4501C 4502 ICOUN1 = 0 4503 ICOUN2 = 0 4504 ICOUN3 = 0 4505 ICOUN4 = 0 4506Chol 4507 XCOUN2 = 0.0D0 4508Chol 4509 DO 1050 ISYMA = 1,NSYM 4510C 4511 ISYMCK = MULD2H(ISYMA,ISYCKA) 4512C 4513 ICKA(ISYMCK,ISYMA) = ICOUN1 4514 ICKI(ISYMCK,ISYMA) = ICOUN2 4515 ISAIK(ISYMCK,ISYMA) = ICOUN2 4516 ICKATR(ISYMCK,ISYMA) = ICOUN3 4517 ICKASR(ISYMCK,ISYMA) = ICOUN4 4518C 4519 ICOUN1 = ICOUN1 + NT1AM(ISYMCK)*NBAS(ISYMA) 4520 ICOUN2 = ICOUN2 + NT1AM(ISYMCK)*NRHF(ISYMA) 4521 ICOUN3 = ICOUN3 + NT1AM(ISYMCK)*NVIR(ISYMA) 4522 ICOUN4 = ICOUN4 + NMATAB(ISYMCK)*NRHF(ISYMA) 4523C 4524 XCOUN2 = XCOUN2 + XT1AM(ISYMCK)*XRHF(ISYMA) 4525C 4526 1050 CONTINUE 4527C 4528 NCKA(ISYCKA) = ICOUN1 4529 NCKI(ISYCKA) = ICOUN2 4530 NCKATR(ISYCKA) = ICOUN3 4531 NCKASR(ISYCKA) = ICOUN4 4532C 4533 XCKI(ISYCKA) = XCOUN2 4534C 4535 1040 CONTINUE 4536C 4537C 4538C FIND MAX LENGTH OF NCKIJ(JSAIKJ) 4539C 4540 NCKAMAX = 0 4541 DO I = 1,NSYM 4542 NCKAMAX = MAX(NCKAMAX,NCKA(I)) 4543 ENDDO 4544C 4545 DO 1060 ISYMJ = 1,NSYM 4546C 4547 ICOUN2 = 0 4548 ICOUN3 = 0 4549C 4550 DO 1065 ISYMD = 1,NSYM 4551C 4552 ISYCKA = MULD2H(ISYMD,ISYMJ) 4553C 4554 ICOUN2 = ICOUN2 + NCKI(ISYCKA)*NBAS(ISYMD) 4555 ICOUN3 = ICOUN3 + NCKI(ISYCKA)*NRHF(ISYMD) 4556C 4557 1065 CONTINUE 4558C 4559 NTOTOC(ISYMJ) = ICOUN2 4560 NTRAOC(ISYMJ) = ICOUN3 4561C 4562 1060 CONTINUE 4563C 4564 DO 1070 JSAIKJ = 1,NSYM 4565C 4566 ICOUN1 = 0 4567 ICOUN2 = 0 4568 ICOUN3 = 0 4569 ICOUN4 = 0 4570 ICOUN5 = 0 4571 ICOUN6 = 0 4572 ICOUN7 = 0 4573 ICOUN8 = 0 4574 ICOUN9 = 0 4575 ICOUN10 = 0 4576 ICOUN11 = 0 4577C 4578 DO 1080 ISYMJ = 1, NSYM 4579C 4580 ISYAIK = MULD2H(JSAIKJ,ISYMJ) 4581C 4582 ISAIKJ(ISYAIK,ISYMJ) = ICOUN1 4583 ICKITR(ISYAIK,ISYMJ) = ICOUN1 4584 ICKID(ISYAIK,ISYMJ) = ICOUN2 4585 ICKAD(ISYAIK,ISYMJ) = ICOUN3 4586 ICKDAO(ISYAIK,ISYMJ) = ICOUN4 4587 ICKBD(ISYAIK,ISYMJ) = ICOUN5 4588 IT2SP(ISYAIK,ISYMJ) = ICOUN6 4589 ICDKAO(ISYAIK,ISYMJ) = ICOUN7 4590 ICDKVI(ISYAIK,ISYMJ) = ICOUN8 4591 IMAJBAI(ISYAIK,ISYMJ) = ICOUN9 4592 IMAAOBCI(ISYAIK,ISYMJ) = ICOUN10 4593 IMAJBAIT(ISYAIK,ISYMJ) = ICOUN11 4594C 4595 ICOUN1 = ICOUN1 + NCKI(ISYAIK)*NRHF(ISYMJ) 4596 ICOUN2 = ICOUN2 + NCKI(ISYAIK)*NBAS(ISYMJ) 4597 ICOUN3 = ICOUN3 + NCKA(ISYAIK)*NVIR(ISYMJ) 4598 ICOUN4 = ICOUN4 + NCKATR(ISYAIK)*NBAS(ISYMJ) 4599 ICOUN5 = ICOUN5 + NCKATR(ISYAIK)*NVIR(ISYMJ) 4600 ICOUN6 = ICOUN6 + NCKI(ISYAIK)*NVIR(ISYMJ) 4601 ICOUN7 = ICOUN7 + NCKASR(ISYAIK)*NBAS(ISYMJ) 4602 ICOUN8 = ICOUN8 + NCKASR(ISYAIK)*NVIR(ISYMJ) 4603 ICOUN9 = ICOUN9 + NRHF(ISYAIK)*NCKATR(ISYMJ) 4604 ICOUN10 = ICOUN10 + NVIR(ISYAIK)*NCKATR(ISYMJ) 4605 ICOUN11 = ICOUN11 + NCKATR(ISYAIK)*NRHF(ISYMJ) 4606C 4607 IF (CCSDT.OR.CCPT.OR.CCP3.OR.CCRT.OR. 4608 * CHOPT .OR. CCR3.OR.CCR1A.OR.CCR1B) THEN 4609 IF (ICOUN1 .LT. 0) WRITE(LUPRI,*) 4610 & 'Negative ICKITR in CCSD_INIT1' 4611 IF (ICOUN2 .LT. 0) WRITE(LUPRI,*) 4612 & 'Negative ICKID in CCSD_INIT1' 4613 IF (ICOUN6 .LT. 0) WRITE(LUPRI,*) 4614 & 'Negative IT2SP in CCSD_INIT1' 4615 IF (ICOUN9 .LT. 0) WRITE(LUPRI,*) 4616 & 'Negative ICKDAO in CCSD_INIT1' 4617 IF (ICOUN11 .LT. 0) WRITE(LUPRI,*) 4618 & 'Negative IMAJBAIT in CCSD_INIT1' 4619 IF ((ICOUN1 .LT. 0) .OR. (ICOUN2 .LT. 0) .OR. 4620 & (ICOUN6 .LT. 0) .OR. (ICOUN9 .LT. 0)) THEN 4621 WRITE(LUPRI,'(A,A)') 4622 & 'Calculation too large for 32-bit integers', 4623 & 'Try rebuilding Dalton using 64-bit integers' 4624 CALL QUIT('Negative index in CCSD_INIT1') 4625 END IF 4626 END IF 4627C 4628 1080 CONTINUE 4629C 4630 NCKIJ(JSAIKJ) = ICOUN1 4631 NMAAOBCI(JSAIKJ) = ICOUN10 4632C 4633 1070 CONTINUE 4634C 4635C FIND MAX LENGTH OF NCKIJ(JSAIKJ) 4636C 4637 NCKIJMAX = 0 4638 DO I = 1,NSYM 4639 NCKIJMAX = MAX(NCKIJMAX,NCKIJ(I)) 4640 ENDDO 4641C 4642 DO 1090 ISYJIK = 1,NSYM 4643C 4644 ICOUN1 = 0 4645 DO 1100 ISYMK = 1,NSYM 4646C 4647 ISYMJI = MULD2H(ISYJIK,ISYMK) 4648C 4649 ICOUN1 = ICOUN1 + NMATIJ(ISYMJI)*NRHF(ISYMK) 4650 1100 CONTINUE 4651C 4652 NMAJIK(ISYJIK) = ICOUN1 4653C 4654 1090 CONTINUE 4655C 4656 DO 1110 JSJIKA = 1,NSYM 4657C 4658 ICOUN1 = 0 4659 ICOUN2 = 0 4660 ICOUN3 = 0 4661 DO 1120 ISYMA = 1,NSYM 4662C 4663 ISYJIK = MULD2H(JSJIKA,ISYMA) 4664C 4665 ISJIKA(ISYJIK,ISYMA) = ICOUN1 4666 ISJIK(ISYJIK,ISYMA) = ICOUN2 4667 ISAIKL(ISYJIK,ISYMA) = ICOUN3 4668C 4669 ICOUN1 = ICOUN1 + NMAJIK(ISYJIK)*NVIR(ISYMA) 4670 ICOUN2 = ICOUN2 + NMATIJ(ISYJIK)*NRHF(ISYMA) 4671 ICOUN3 = ICOUN3 + NT1AM(ISYJIK)*NMATIJ(ISYMA) 4672C 4673 1120 CONTINUE 4674 1110 CONTINUE 4675C 4676C------------------------------------------------------------------ 4677C Section for making index matrices for general Lamda matrices. 4678C Needed for linear transformation. OC 10-2-1995 4679C------------------------------------------------------------------ 4680C 4681 DO 1200 ISYM = 1,NSYM 4682C 4683 ICOUN1 = 0 4684 ICOUN2 = 0 4685 ICOUN3 = 0 4686C 4687 DO 1210 ISYM2 = 1,NSYM 4688C 4689 ISYM1 = MULD2H(ISYM,ISYM2) 4690 ICOUN1 = ICOUN1 + NBAS(ISYM1)*NORB(ISYM2) 4691 ICOUN2 = ICOUN2 + NBAS(ISYM1)*NRHF(ISYM2) 4692 ICOUN3 = ICOUN3 + NORB(ISYM1)*NRHF(ISYM2) 4693C 4694 1210 CONTINUE 4695C 4696 NGLMDT(ISYM) = ICOUN1 4697 NGLMRH(ISYM) = ICOUN2 4698 NLRHFR(ISYM) = ICOUN3 4699 ICOUN1 = 0 4700C 4701 DO 1220 ISYM2 = 1,NSYM 4702C 4703 ISYM1 = MULD2H(ISYM,ISYM2) 4704 IGLMRH(ISYM1,ISYM2) = ICOUN1 4705 IGLMVI(ISYM1,ISYM2) = ICOUN2 4706C 4707 ICOUN1 = ICOUN1 + NBAS(ISYM1)*NRHF(ISYM2) 4708 ICOUN2 = ICOUN2 + NBAS(ISYM1)*NVIR(ISYM2) 4709C 4710 1220 CONTINUE 4711C 4712 1200 CONTINUE 4713C 4714 DO 1230 ISYMD = 1,NSYM 4715 DO 1240 ISYMTR = 1,NSYM 4716 NT2MMO(ISYMD,ISYMTR) = 0 4717 NT2MAO(ISYMD,ISYMTR) = 0 4718 ISYCIJ = MULD2H(ISYMD,ISYMTR) 4719 DO 1250 ISYMJ = 1,NSYM 4720 ISYMCI = MULD2H(ISYMJ,ISYCIJ) 4721 NT2MMO(ISYMD,ISYMTR) = NT2MMO(ISYMD,ISYMTR) + 4722 * NT1AM(ISYMCI)*NRHF(ISYMJ) 4723 NT2MAO(ISYMD,ISYMTR) = NT2MAO(ISYMD,ISYMTR) + 4724 * NT1AO(ISYMCI)*NRHF(ISYMJ) 4725 1250 CONTINUE 4726 1240 CONTINUE 4727 1230 CONTINUE 4728C 4729C---------------------------------------------------- 4730C Section for extra frozen core gradient indices. 4731C Asger Halkier 22/5 - 1998. 4732C---------------------------------------------------- 4733C 4734 CALL CC_INIFRO(WORK,LWORK) 4735C 4736C---------------------------------------------------------- 4737C Extra index array needed for F-matrix transformation. 4738C Ove Christiansen 17-6-1996 4739C---------------------------------------------------------- 4740C 4741 DO 1490 ISYMT = 1,NSYM 4742 DO 1500 ISYMD = 1,NSYM 4743 NDSGRH(ISYMD,ISYMT) = 0 4744 ISYABL = MULD2H(ISYMD,ISYMT) 4745 DO 1510 ISYMG = 1,NSYM 4746 ISYMAB = MULD2H(ISYMG,ISYMD) 4747 ISYML = MULD2H(ISYABL,ISYMAB) 4748 NDSGRH(ISYMD,ISYMT) = NDSGRH(ISYMD,ISYMT) 4749 * + NNBST(ISYMAB)*NRHF(ISYML) 4750 1510 CONTINUE 4751 1500 CONTINUE 4752 1490 CONTINUE 4753C 4754C------------------------------------------------------------ 4755C set offsets and dimensions for CCR12 4756C------------------------------------------------------------ 4757 DO ISYMAK = 1, NSYM 4758 NVAJKL(ISYMAK) = 0 4759 NVABKL(ISYMAK) = 0 4760 ICOUNT1 = 0 4761 ICOUNT2 = 0 4762 DO ISYMK = 1, NSYM 4763 ISYMA = MULD2H(ISYMAK,ISYMK) 4764 IVAJKL(ISYMA,ISYMK) = ICOUNT1 4765 IVABKL(ISYMA,ISYMK) = ICOUNT2 4766 NVAJKL(ISYMAK) = NVAJKL(ISYMAK) + NT1AO(ISYMA)*NMATKL(ISYMK) 4767 NVABKL(ISYMAK) = NVABKL(ISYMAK) + N2BST(ISYMA)*NMATKL(ISYMK) 4768 ICOUNT1 = ICOUNT1 + NT1AO(ISYMA)*NMATKL(ISYMK) 4769 ICOUNT2 = ICOUNT2 + N2BST(ISYMA)*NMATKL(ISYMK) 4770 END DO 4771 END DO 4772 4773C------------------------------------------------------------ 4774C set offset arrays ISWTL and ISTLN and dimensions NIMFN: 4775C------------------------------------------------------------ 4776C 4777 DO ISYMDL = 1, NSYM 4778 IOFF = 0 4779 DO ISYML = 1, NSYM 4780 ISWMAT = MULD2H(ISYMDL,ISYML) 4781 ISWTL(ISWMAT,ISYML) = IOFF 4782 IOFF = IOFF + NT2SQ(ISWMAT)*NRHF(ISYML) 4783 END DO 4784 END DO 4785 4786 DO ISAIBJ = 1, NSYM 4787 IOFF = 0 4788 DO ISYMJ = 1, NSYM 4789 ISAIB = MULD2H(ISAIBJ,ISYMJ) 4790 ISTLN(ISAIB,ISYMJ) = IOFF 4791 IOFF = IOFF + NCKATR(ISAIB)*NRHF(ISYMJ) 4792 END DO 4793 END DO 4794 4795 DO ISYM = 1, NSYM 4796 ILEN = 0 4797 DO ISYMFN = 1, NSYM 4798 ISYMIM = MULD2H(ISYM,ISYMFN) 4799 ILEN = ILEN + NMATIJ(ISYMIM)*NT1AM(ISYMFN) 4800 END DO 4801 NIMFN(ISYM) = ILEN 4802 END DO 4803C 4804 IF (IPRINT .GT. 9) THEN 4805 CALL AROUND('Information from CCSDSYM') 4806 WRITE(LUPRI,1) 'NRHF :',(NRHF(I), I=1,NSYM) 4807 WRITE(LUPRI,1) 'NRHFS :',(NRHFS(I), I=1,NSYM) 4808 WRITE(LUPRI,1) 'NRHFA :',(NRHFA(I), I=1,NSYM) 4809 WRITE(LUPRI,1) 'NRHFSA :',(NRHFSA(I), I=1,NSYM) 4810 WRITE(LUPRI,1) 'NRHFB :',(NRHFB(I), I=1,NSYM) 4811 WRITE(LUPRI,1) 'NORBS :',(NORBS(I), I=1,NSYM) 4812 WRITE(LUPRI,1) 'NNBST :',(NNBST(I), I=1,NSYM) 4813 WRITE(LUPRI,1) 'NT1AM :',(NT1AM(I), I=1,NSYM) 4814 WRITE(LUPRI,1) 'NT2AM :',(NT2AM(I), I=1,NSYM) 4815 WRITE(LUPRI,1) 'NG1AM :',(NG1AM(I), I=1,NSYM) 4816 WRITE(LUPRI,1) 'NH1AM :',(NH1AM(I), I=1,NSYM) 4817 WRITE(LUPRI,1) 'NH2AM :',(NH2AM(I), I=1,NSYM) 4818 WRITE(LUPRI,1) 'NDISAO :',(NDISAO(I), I=1,NSYM) 4819 WRITE(LUPRI,1) 'NDSRHF :',(NDSRHF(I), I=1,NSYM) 4820 WRITE(LUPRI,1) 'ILMRHF :',(ILMRHF(I), I=1,NSYM) 4821 WRITE(LUPRI,1) 'ILMVIR :',(ILMVIR(I), I=1,NSYM) 4822 WRITE(LUPRI,1) 'NT1AO :',(NT1AO(I), I=1,NSYM) 4823 WRITE(LUPRI,1) 'NT2AO :',(NT2AO(I), I=1,NSYM) 4824 WRITE(LUPRI,1) 'N2BST :',(N2BST(I), I=1,NSYM) 4825 WRITE(LUPRI,1) 'NT2BCD :',(NT2BCD(I), I=1,NSYM) 4826 WRITE(LUPRI,1) 'NT2BGD :',(NT2BGD(I), I=1,NSYM) 4827 WRITE(LUPRI,1) 'NMATIJ :',(NMATIJ(I), I=1,NSYM) 4828 WRITE(LUPRI,1) 'NMATKI :',(NMATKI(I), I=1,NSYM) 4829 WRITE(LUPRI,1) 'NMATKL :',(NMATKL(I), I=1,NSYM) 4830 WRITE(LUPRI,1) 'NGAMMA :',(NGAMMA(I), I=1,NSYM) 4831 WRITE(LUPRI,1) 'NTR12AM:',(NTR12AM(I),I=1,NSYM) 4832 WRITE(LUPRI,1) 'NGAMSQ :',(NGAMSQ(I), I=1,NSYM) 4833 WRITE(LUPRI,1) 'NTR12SQ:',(NTR12SQ(I),I=1,NSYM) 4834 WRITE(LUPRI,1) 'NEMAT1 :',(NEMAT1(I), I=1,NSYM) 4835 WRITE(LUPRI,1) 'NMATAB :',(NMATAB(I), I=1,NSYM) 4836 WRITE(LUPRI,1) 'NT2AOS :',(NT2AOS(I), I=1,NSYM) 4837 WRITE(LUPRI,1) 'NT2SQ :',(NT2SQ(I) , I=1,NSYM) 4838 WRITE(LUPRI,1) 'NMIJP :',(NMIJP(I) , I=1,NSYM) 4839 WRITE(LUPRI,1) 'NT2ORT :',(NT2ORT(I), I=1,NSYM) 4840 WRITE(LUPRI,1) 'NGLMDT :',(NGLMDT(I), I=1,NSYM) 4841 WRITE(LUPRI,1) 'NGLMRH :',(NGLMRH(I), I=1,NSYM) 4842 WRITE(LUPRI,1) 'NLRHFR :',(NLRHFR(I), I=1,NSYM) 4843 WRITE(LUPRI,*) 4844 DO 9901 I = 1,NSYM 4845 WRITE(LUPRI,1) 'IDSAOG :',(IDSAOG(I,J), J=1,NSYM) 4846 9901 CONTINUE 4847 WRITE(LUPRI,*) 4848 DO 9902 I = 1,NSYM 4849 WRITE(LUPRI,1) 'IT1AM :',(IT1AM(I,J), J=1,NSYM) 4850 9902 CONTINUE 4851 WRITE(LUPRI,*) 4852 DO I = 1,NSYM 4853 WRITE(LUPRI,1) 'IH1AM :',(IH1AM(I,J), J=1,NSYM) 4854 END DO 4855 WRITE(LUPRI,*) 4856 DO 9903 I = 1,NSYM 4857 WRITE(LUPRI,1) 'IT2AM :',(IT2AM(I,J), J=1,NSYM) 4858 9903 CONTINUE 4859 WRITE(LUPRI,*) 4860 DO 9904 I = 1,NSYM 4861 WRITE(LUPRI,1) 'IT1AO :',(IT1AO(I,J), J=1,NSYM) 4862 9904 CONTINUE 4863 WRITE(LUPRI,*) 4864 DO 9905 I = 1,NSYM 4865 WRITE(LUPRI,1) 'IT2AO :',(IT2AO(I,J), J=1,NSYM) 4866 9905 CONTINUE 4867 WRITE(LUPRI,*) 4868 DO 9906 I = 1,NSYM 4869 WRITE(LUPRI,1) 'IT2SQ :',(IT2SQ(I,J), J=1,NSYM) 4870 9906 CONTINUE 4871 WRITE(LUPRI,*) 4872 DO 9907 I = 1,NSYM 4873 WRITE(LUPRI,1) 'IAODIS :',(IAODIS(I,J), J=1,NSYM) 4874 9907 CONTINUE 4875 WRITE(LUPRI,*) 4876 DO 9908 I = 1,NSYM 4877 WRITE(LUPRI,1) 'IT2BCD :',(IT2BCD(I,J), J=1,NSYM) 4878 9908 CONTINUE 4879 WRITE(LUPRI,*) 4880 DO 9909 I = 1,NSYM 4881 WRITE(LUPRI,1) 'IT2BGD :',(IT2BGD(I,J), J=1,NSYM) 4882 9909 CONTINUE 4883 WRITE(LUPRI,*) 4884 DO 9910 I = 1,NSYM 4885 WRITE(LUPRI,1) 'IMATIJ :',(IMATIJ(I,J), J=1,NSYM) 4886 9910 CONTINUE 4887 WRITE(LUPRI,*) 4888 DO I = 1,NSYM 4889 WRITE(LUPRI,1) 'IMATKI :',(IMATKI(I,J), J=1,NSYM) 4890 END DO 4891 WRITE(LUPRI,*) 4892 DO I = 1,NSYM 4893 WRITE(LUPRI,1) 'IMATKL :',(IMATKL(I,J), J=1,NSYM) 4894 END DO 4895 WRITE(LUPRI,*) 4896 DO 9911 I = 1,NSYM 4897 WRITE(LUPRI,1) 'IGAMMA :',(IGAMMA(I,J), J=1,NSYM) 4898 9911 CONTINUE 4899 WRITE(LUPRI,*) 4900 DO I = 1, NSYM 4901 WRITE(LUPRI,1) 'ITR12AM:',(ITR12AM(I,J),J=1,NSYM) 4902 END DO 4903 WRITE(LUPRI,*) 4904 DO I = 1, NSYM 4905 WRITE(LUPRI,1) 'IGAMSQ :',(IGAMSQ(I,J), J=1,NSYM) 4906 END DO 4907 WRITE(LUPRI,*) 4908 DO I = 1, NSYM 4909 WRITE(LUPRI,1) 'ITR12SQ:',(ITR12SQ(I,J),J=1,NSYM) 4910 END DO 4911 WRITE(LUPRI,*) 4912 DO I = 1, NSYM 4913 WRITE(LUPRI,1) 'ITR12SQT:',(ITR12SQT(I,J),J=1,NSYM) 4914 END DO 4915 WRITE(LUPRI,*) 4916 DO I = 1, NSYM 4917 WRITE(LUPRI,1) 'IR12R12SQ:',(IR12R12SQ(I,J),J=1,NSYM) 4918 END DO 4919 WRITE(LUPRI,*) 4920 DO 9912 I = 1,NSYM 4921 WRITE(LUPRI,1) 'IDSRHF :',(IDSRHF(I,J), J=1,NSYM) 4922 9912 CONTINUE 4923 WRITE(LUPRI,*) 4924 DO 9913 I = 1,NSYM 4925 WRITE(LUPRI,1) 'IT1AMT :',(IT1AMT(I,J), J=1,NSYM) 4926 9913 CONTINUE 4927 WRITE(LUPRI,*) 4928 DO 9914 I = 1,NSYM 4929 WRITE(LUPRI,1) 'IT1AOT :',(IT1AOT(I,J), J=1,NSYM) 4930 9914 CONTINUE 4931 WRITE(LUPRI,*) 4932 DO 9915 I = 1,NSYM 4933 WRITE(LUPRI,1) 'IT2BCT :',(IT2BCT(I,J), J=1,NSYM) 4934 9915 CONTINUE 4935 WRITE(LUPRI,*) 4936 DO 9916 I = 1,NSYM 4937 WRITE(LUPRI,1) 'IT2BGT :',(IT2BGT(I,J), J=1,NSYM) 4938 9916 CONTINUE 4939 WRITE(LUPRI,*) 4940 DO 9917 I = 1,NSYM 4941 WRITE(LUPRI,1) 'IFCRHF :',(IFCRHF(I,J), J=1,NSYM) 4942 9917 CONTINUE 4943 WRITE(LUPRI,*) 4944 DO 9918 I = 1,NSYM 4945 WRITE(LUPRI,1) 'IFCVIR :',(IFCVIR(I,J), J=1,NSYM) 4946 9918 CONTINUE 4947 WRITE(LUPRI,*) 4948 DO 9919 I = 1,NSYM 4949 WRITE(LUPRI,1) 'IEMAT1 :',(IEMAT1(I,J), J=1,NSYM) 4950 9919 CONTINUE 4951 WRITE(LUPRI,*) 4952 DO 9920 I = 1,NSYM 4953 WRITE(LUPRI,1) 'IMATAB :',(IMATAB(I,J), J=1,NSYM) 4954 9920 CONTINUE 4955 WRITE(LUPRI,*) 4956 DO 9921 I = 1,NSYM 4957 WRITE(LUPRI,1) 'IT2AOS :',(IT2AOS(I,J), J=1,NSYM) 4958 9921 CONTINUE 4959 WRITE(LUPRI,*) 4960 DO 9922 I = 1,NSYM 4961 WRITE(LUPRI,1) 'IMIJP :',(IMIJP(I,J), J=1,NSYM) 4962 9922 CONTINUE 4963 WRITE(LUPRI,*) 4964 DO 9923 I = 1,NSYM 4965 WRITE(LUPRI,1) 'IT2ORT :',(IT2ORT(I,J), J=1,NSYM) 4966 9923 CONTINUE 4967 WRITE(LUPRI,*) 4968 DO 9924 I = 1,NSYM 4969 WRITE(LUPRI,1) 'IGLMRH :',(IGLMRH(I,J), J=1,NSYM) 4970 9924 CONTINUE 4971 WRITE(LUPRI,*) 4972 DO 9925 I = 1,NSYM 4973 WRITE(LUPRI,1) 'IGLMVI :',(IGLMVI(I,J), J=1,NSYM) 4974 9925 CONTINUE 4975 WRITE(LUPRI,*) 4976 DO 9926 I = 1,NSYM 4977 WRITE(LUPRI,1) 'NT2MMO :',(NT2MMO(I,J), J=1,NSYM) 4978 9926 CONTINUE 4979 WRITE(LUPRI,*) 4980 DO 9927 I = 1,NSYM 4981 WRITE(LUPRI,1) 'NT2MAO :',(NT2MAO(I,J), J=1,NSYM) 4982 9927 CONTINUE 4983 DO 9928 I = 1,NSYM 4984 WRITE(LUPRI,1) 'NDSGRH :',(NDSGRH(I,J), J=1,NSYM) 4985 9928 CONTINUE 4986 WRITE(LUPRI,*) 4987 WRITE(LUPRI,1) 'NLAMDS :',NLAMDS 4988 WRITE(LUPRI,1) 'NLRHSI :',NLRHSI 4989 WRITE(LUPRI,1) 'NLAMDT :',NLAMDT 4990 WRITE(LUPRI,1) 'NLMRHF :',NLMRHF 4991C 4992 CALL AROUND('Information from DCCSDSYM') 4993 WRITE(LUPRI,2) 'XT1AM :',(XT1AM(I), I=1,NSYM) 4994 WRITE(LUPRI,2) 'XT2AM :',(XT2AM(I), I=1,NSYM) 4995 WRITE(LUPRI,2) 'XT2SQ :',(XT2SQ(I), I=1,NSYM) 4996 WRITE(LUPRI,2) 'XCKI :',(XCKI(I), I=1,NSYM) 4997 WRITE(LUPRI,2) 'XMATIJ :',(XMATIJ(I), I=1,NSYM) 4998 WRITE(LUPRI,2) 'XT1AO :',(XT1AO(I), I=1,NSYM) 4999C 5000 END IF 5001C 5002 CALL QEXIT('CCSD_INIT1') 5003C 5004 RETURN 5005C 5006 1 FORMAT(3X,A8,8I8) 5007 2 FORMAT(3X,A8,8D10.3) 5008C 5009 END 5010C /* Deck fock_reorder */ 5011 SUBROUTINE FOCK_REORDER(FOCK,WORK,LWORK) 5012C 5013C Henrik Koch and Alfredo Sanchez. 29-Jun-1994 5014C 5015C Reorder the symmetry ordering of the fock matrix. 5016C First occupied orbitals in different symmetries and then 5017C the virtuals in different symmetries. 5018C 5019#include "implicit.h" 5020#include "priunit.h" 5021#include "ccorb.h" 5022 DIMENSION FOCK(NORBT),WORK(LWORK) 5023#include "ccsdinp.h" 5024#include "ccsdsym.h" 5025C 5026 CALL QENTER('FOCK_REORDER') 5027C 5028 IF (LWORK .LT. NORBT) THEN 5029 CALL QUIT('Insufficient space in FOCK_REORDER') 5030 ENDIF 5031C 5032 ICRHF = 0 5033 ICVIR = NRHFT 5034 ICOUNT = 0 5035 DO 100 ISYM = 1,NSYM 5036C 5037 DO 110 I = 1,NRHF(ISYM) 5038 ICRHF = ICRHF + 1 5039 ICOUNT = ICOUNT + 1 5040 WORK(ICRHF) = FOCK(ICOUNT) 5041 110 CONTINUE 5042C 5043 DO 120 A = 1,NVIR(ISYM) 5044 ICVIR = ICVIR + 1 5045 ICOUNT = ICOUNT + 1 5046 WORK(ICVIR) = FOCK(ICOUNT) 5047 120 CONTINUE 5048C 5049 100 CONTINUE 5050C 5051 IF (IPRINT .GT. 20) THEN 5052 CALL AROUND('Fock matrix diagonal in FOCK_REORDER') 5053 WRITE(LUPRI,1) 5054 DO 200 I = 1,NORBT 5055 WRITE(LUPRI,2) FOCK(I),WORK(I) 5056 WRITE(55,'(4e30.20)') FOCK(I) 5057 200 CONTINUE 5058 END IF 5059C 5060 CALL DCOPY(NORBT,WORK,1,FOCK,1) 5061C 5062 CALL QEXIT('FOCK_REORDER') 5063C 5064 RETURN 5065C 5066 1 FORMAT(7X,'Sirius order',5X,'CCSD order') 5067 2 FORMAT(6X,F14.10,3X,F14.10) 5068C 5069 END 5070C /* Deck cmo_reorder */ 5071 SUBROUTINE CMO_REORDER(CMO,WORK,LWORK) 5072C 5073C Henrik Koch and Alfredo Sanchez. 30-Jun-1994 5074C 5075C Reorder the symmetry ordering of the MO coefficient matrix. 5076C First occupied orbitals in different symmetries and then 5077C the virtuals in different symmetries. 5078C 5079#include "implicit.h" 5080 DIMENSION CMO(*),WORK(LWORK) 5081#include "priunit.h" 5082#include "ccorb.h" 5083#include "ccsdinp.h" 5084#include "ccsdsym.h" 5085C 5086 LOGICAL FRORHF, FROVIR 5087C 5088 CALL QENTER('CMO_REORDER') 5089C 5090C----------------------- 5091C Memory allocation. 5092C----------------------- 5093C 5094 KSCR1 = 1 5095 KSCR2 = KSCR1 + NLAMDS 5096 KEND = KSCR2 + NLAMDT 5097 LWRK1 = LWORK - KEND 5098C 5099 IF (LWRK1 .LT. 0) THEN 5100 CALL QUIT('Insufficient space in CMO_REORDER') 5101 ENDIF 5102C 5103C---------------------------------- 5104C Reorder all orbitals in work. 5105C---------------------------------- 5106C 5107 ICRHF = KSCR1 5108 ICVIR = KSCR1 + NLRHSI 5109 ICOUNT = 1 5110 DO 100 ISYM = 1,NSYM 5111C 5112 CALL DCOPY(NBAS(ISYM)*NRHFS(ISYM),CMO(ICOUNT),1,WORK(ICRHF),1) 5113 ICRHF = ICRHF + NBAS(ISYM)*NRHFS(ISYM) 5114 ICOUNT = ICOUNT + NBAS(ISYM)*NRHFS(ISYM) 5115C 5116 CALL DCOPY(NBAS(ISYM)*NVIRS(ISYM),CMO(ICOUNT),1,WORK(ICVIR),1) 5117 ICVIR = ICVIR + NBAS(ISYM)*NVIRS(ISYM) 5118 ICOUNT = ICOUNT + NBAS(ISYM)*NVIRS(ISYM) 5119C 5120 100 CONTINUE 5121C 5122C---------------------------- 5123C Delete frozen orbitals. 5124C---------------------------- 5125C 5126 IF ((.NOT. FROIMP) .AND. (.NOT. FROEXP)) THEN 5127C 5128 CALL DCOPY(NLAMDT,WORK(KSCR1),1,WORK(KSCR2),1) 5129C 5130 ELSE IF (FROIMP) THEN 5131C 5132 DO 110 ISYM = 1, NSYM 5133C 5134 KOFF1 = KSCR1 + ILRHSI(ISYM) + NBAS(ISYM)*NRHFFR(ISYM) 5135 KOFF2 = KSCR2 + ILMRHF(ISYM) 5136C 5137 LENGTH = NBAS(ISYM)*NRHF(ISYM) 5138 CALL DCOPY(LENGTH,WORK(KOFF1),1,WORK(KOFF2),1) 5139C 5140 KOFF1 = KSCR1 + ILVISI(ISYM) 5141 KOFF2 = KSCR2 + ILMVIR(ISYM) 5142C 5143 LENGTH = NBAS(ISYM)*NVIR(ISYM) 5144 CALL DCOPY(LENGTH,WORK(KOFF1),1,WORK(KOFF2),1) 5145C 5146 110 CONTINUE 5147C 5148 ELSE 5149C 5150 DO 120 ISYM = 1,NSYM 5151C 5152 KOFF1 = KSCR1 + ILRHSI(ISYM) 5153 KOFF2 = KSCR2 + ILMRHF(ISYM) 5154C 5155 DO 130 IOCC = 1,NRHFS(ISYM) 5156C 5157 IF (.NOT. FRORHF(IOCC,ISYM)) THEN 5158 CALL DCOPY(NBAS(ISYM),WORK(KOFF1),1,WORK(KOFF2),1) 5159 KOFF2 = KOFF2 + NBAS(ISYM) 5160 END IF 5161C 5162 KOFF1 = KOFF1 + NBAS(ISYM) 5163C 5164 130 CONTINUE 5165C 5166 KOFF1 = KSCR1 + ILVISI(ISYM) 5167 KOFF2 = KSCR2 + ILMVIR(ISYM) 5168C 5169 DO 140 IVIR1 = 1,NVIRS(ISYM) 5170C 5171 IF (.NOT. FROVIR(IVIR1,ISYM)) THEN 5172 CALL DCOPY(NBAS(ISYM),WORK(KOFF1),1,WORK(KOFF2),1) 5173 KOFF2 = KOFF2 + NBAS(ISYM) 5174 END IF 5175C 5176 KOFF1 = KOFF1 + NBAS(ISYM) 5177C 5178 140 CONTINUE 5179C 5180 120 CONTINUE 5181C 5182 END IF 5183C 5184C---------------------- 5185C Print if desired. 5186C---------------------- 5187C 5188 IF (IPRINT .GT. 200) THEN 5189 CALL AROUND('MO-coefficient matrix in CMO_REORDER') 5190 KOFF1 = 1 5191 KOFF2 = KSCR2 5192 KOFF3 = KSCR2 + NLMRHF 5193 DO 200 ISYM = 1,NSYM 5194 WRITE(LUPRI,1) ISYM 5195 IF (NORB(ISYM) .EQ. 0) THEN 5196 WRITE(LUPRI,8) 5197 GOTO 200 5198 ENDIF 5199 WRITE(LUPRI,2) 5200 WRITE(LUPRI,3) 5201 CALL OUTPUT(CMO(KOFF1),1,NBAS(ISYM),1,NORBS(ISYM), 5202 * NBAS(ISYM),NORBS(ISYM),1,LUPRI) 5203 WRITE(LUPRI,4) 5204 WRITE(LUPRI,5) 5205 CALL OUTPUT(WORK(KOFF2),1,NBAS(ISYM),1,NRHF(ISYM), 5206 * NBAS(ISYM),NRHF(ISYM),1,LUPRI) 5207 WRITE(LUPRI,6) 5208 WRITE(LUPRI,7) 5209 CALL OUTPUT(WORK(KOFF3),1,NBAS(ISYM),1,NVIR(ISYM), 5210 * NBAS(ISYM),NVIR(ISYM),1,LUPRI) 5211 KOFF1 = KOFF1 + NBAS(ISYM)*NORBS(ISYM) 5212 KOFF2 = KOFF2 + NBAS(ISYM)*NRHF(ISYM) 5213 KOFF3 = KOFF3 + NBAS(ISYM)*NVIR(ISYM) 5214 200 CONTINUE 5215 END IF 5216C 5217 CALL DCOPY(NLAMDT,WORK(KSCR2),1,CMO,1) 5218C 5219 CALL QEXIT('CMO_REORDER') 5220C 5221 RETURN 5222C 5223 1 FORMAT(//,7X,'Symmetry number :',I5) 5224 2 FORMAT(//,7X,'Sirius ordering') 5225 3 FORMAT(7X,'---------------') 5226 4 FORMAT(//,7X,'CCSD ordering occupied part') 5227 5 FORMAT(7X,'---------------------------') 5228 6 FORMAT(//,7X,'CCSD ordering virtual part') 5229 7 FORMAT(7X,'--------------------------') 5230 8 FORMAT(//,7X,'This symmetry is empty') 5231C 5232 END 5233C /* Deck ccsd_symsqo */ 5234 SUBROUTINE CCSD_SYMSQO(DISTAB,ISYMAB,SCR) 5235C 5236C Henrik Koch and Alfredo Sanchez. 1-July-1994 5237C 5238C Squareup the integral distribution. 5239C 5240#include "implicit.h" 5241 DIMENSION DISTAB(*), SCR(*) 5242#include "priunit.h" 5243#include "ccorb.h" 5244#include "ccsdsym.h" 5245C 5246 CALL QENTER('CCSD_SYMSQO') 5247C 5248 IF (ISYMAB .EQ. 1) THEN 5249C 5250 KOFF1 = 1 5251 KOFF2 = 1 5252 DO 100 ISYMB = 1,NSYM 5253 CALL SQMATR(NBAS(ISYMB),DISTAB(KOFF1),SCR(KOFF2)) 5254 KOFF1 = KOFF1 + NBAS(ISYMB)*(NBAS(ISYMB)+1)/2 5255 KOFF2 = KOFF2 + NBAS(ISYMB)*NBAS(ISYMB) 5256 100 CONTINUE 5257C 5258 ELSE 5259 KOFF1 = 1 5260 KOFF2 = 1 5261 DO 200 ISYMB = 1,NSYM 5262C 5263 ISYMA = MULD2H(ISYMB,ISYMAB) 5264 IF (ISYMB .GT. ISYMA) THEN 5265C 5266 NTOT = NBAS(ISYMA)*NBAS(ISYMB) 5267C 5268 KOFF2 = KOFF1 5269 KOFF3 = IAODIS(ISYMB,ISYMA) + 1 5270 DO 210 B = 1,NBAS(ISYMB) 5271 CALL DCOPY(NBAS(ISYMA),DISTAB(KOFF2),1,SCR(KOFF3), 5272 * NBAS(ISYMB)) 5273 KOFF2 = KOFF2 + NBAS(ISYMA) 5274 KOFF3 = KOFF3 + 1 5275 210 CONTINUE 5276C 5277 KOFF4 = IAODIS(ISYMA,ISYMB) + 1 5278 CALL DCOPY(NTOT,DISTAB(KOFF1),1,SCR(KOFF4),1) 5279C 5280 KOFF1 = KOFF1 + NTOT 5281C 5282 ENDIF 5283C 5284 200 CONTINUE 5285C 5286 ENDIF 5287C 5288 CALL QEXIT('CCSD_SYMSQO') 5289C 5290 RETURN 5291 END 5292 SUBROUTINE CCSD_SYMSQ(DISTAB,ISYMAB,SCR) 5293C 5294C Henrik Koch and Alfredo Sanchez. 1-July-1994 5295C 5296C Squareup the integral distribution. 5297C 5298 5299 use dyn_iadrpk 5300 5301#include "implicit.h" 5302 DIMENSION DISTAB(*), SCR(*) 5303#include "priunit.h" 5304#include "maxorb.h" 5305#include "ccorb.h" 5306#include "ccsdsym.h" 5307#include "symsq.h" 5308C 5309 CALL QENTER('CCSD_SYMSQ') 5310C 5311C 5312c ii_sum = 0 5313c do i = 1,n2bstx 5314c ii_sum = ii_sum + iadrpk(i) 5315c end do 5316c write(lupri,*) 'ii_sum in ccsd_symsq', ii_sum 5317c call flshfo(lupri) 5318 5319#if !defined (SYS_CRAY) 5320 DO 100 IJSQ = 1,N2BST(ISYMAB) 5321C 5322 KOFF = I2BST(ISYMAB) + IJSQ 5323 IJPK = IADRPK(KOFF) 5324C 5325 SCR(IJSQ) = DISTAB(IJPK) 5326C 5327 100 CONTINUE 5328#else 5329 5330C SYS_CRAY code 5331 5332 KOFF = I2BST(ISYMAB) + 1 5333 CALL GATHER(N2BST(ISYMAB),SCR,DISTAB,IADRPK(KOFF)) 5334#endif 5335C 5336 CALL QEXIT('CCSD_SYMSQ') 5337C 5338 RETURN 5339 END 5340 SUBROUTINE CCSD_SYMSQT(DISTAB1,ISYMAB,SCR) 5341 5342 use dyn_iadrpk 5343 5344#include "implicit.h" 5345 DIMENSION DISTAB1(*), SCR(*) 5346#include "priunit.h" 5347#include "maxorb.h" 5348#include "ccorb.h" 5349#include "ccsdsym.h" 5350#include "symsq.h" 5351C 5352 CALL QENTER('CCSD_SYMSQT') 5353C 5354#if defined (SYS_CRAY) 5355 WRITE(LUPRI,*) 'computation of Bijal on SYS_CRAY not implemented' 5356 CALL QUIT('computation of Bijal on SYS_CRAY not implemented') 5357#endif 5358C 5359 DO IJSQ = 1,N2BST(ISYMAB) 5360 KOFF = I2BST(ISYMAB) + IJSQ 5361 IJPK = IADRPK(KOFF) 5362 SCR(IJSQ) = -DISTAB1(IJPK) 5363 END DO 5364C 5365C 5366 CALL QEXIT('CCSD_SYMSQT') 5367C 5368 RETURN 5369 END 5370C /* Deck cc3_sort1 */ 5371 SUBROUTINE CC3_SORT1(WORK,LWORK,IOPT,ISYINT,LU3SRT,FN3SRT, 5372 * LU3VI,FN3VI,LU3VI2,FN3VI2, 5373 * LU3FOP,FN3FOP,LU3FOP2,FN3FOP2) 5374C 5375C Henrik Koch and Alfredo Sanchez. 28-May-1995 5376C 5377C Kasper Hald fall 2001 - Added 2*C-E for ccsd(t) f.o.p. 5378C 5379C FN3VI can be FN3VI or FNDELD 5380C 5381C Sort virtual integrals for perturbative triples. 5382C 5383#include "implicit.h" 5384 DIMENSION WORK(LWORK) 5385#include "priunit.h" 5386#include "ccorb.h" 5387#include "ccinftap.h" 5388#include "ccsdsym.h" 5389#include "ccfop.h" 5390#include "ccsdinp.h" 5391#include "ccsections.h" 5392C 5393 PARAMETER (TWO = 2.0D0) 5394C 5395 CHARACTER*(*) FN3SRT, FN3VI, FN3VI2, FN3FOP, FN3FOP2 5396C 5397 CALL QENTER('CC3_SORT1') 5398C 5399 IF ((IOPT .NE. 1) .AND. (IOPT .NE. 2)) THEN 5400 CALL QUIT('IOPT error in CC3_SORT1') 5401 END IF 5402C 5403C----------------------------------------- 5404C Start loop over symmetries of delta. 5405C----------------------------------------- 5406C 5407 MAXCK = 0 5408 DO 50 ISYMCK = 1,NSYM 5409 IF (NT1AM(ISYMCK) .GT. MAXCK) MAXCK = NT1AM(ISYMCK) 5410 50 CONTINUE 5411C 5412 DO 100 ISYMD = 1,NSYM 5413C 5414 IF (NBAS(ISYMD) .EQ. 0) GOTO 100 5415C 5416C-------------------------- 5417C Memory allocation. 5418C-------------------------- 5419C 5420 ISYCKB = MULD2H(ISYMD,ISYINT) 5421C 5422 LENMIN = NCKATR(ISYCKB) + MAXCK 5423 NDISTR = MIN(LWORK/LENMIN,NBAS(ISYMD)) 5424C 5425Casm Apparently, it is not possible to read more than 2 Gb (268435456 dw) 5426C 5427 MXDALF = 268435455 / NCKATR(ISYCKB) 5428 NDISTR = MIN(NDISTR,MXDALF) 5429C 5430 IF (NDISTR .EQ. 0) THEN 5431 CALL QUIT('Insufficient work space in CC3_SORT1') 5432 ENDIF 5433C 5434 NBATCH = (NBAS(ISYMD) - 1)/NDISTR + 1 5435C 5436 KSCR1 = 1 5437 KSCR2 = KSCR1 + NCKATR(ISYCKB)*NDISTR 5438 KEND1 = KSCR2 + MAXCK*NDISTR 5439C 5440 DO 110 IBATCH = 1,NBATCH 5441C 5442 NUMD = NDISTR 5443 IF (IBATCH .EQ. NBATCH) THEN 5444 NUMD = NBAS(ISYMD) - NDISTR*(NBATCH - 1) 5445 ENDIF 5446C 5447 ID1 = NDISTR*(IBATCH - 1) + 1 5448C 5449C-------------------------- 5450C Read integrals. 5451C-------------------------- 5452C 5453 LENGTH = NCKATR(ISYCKB)*NUMD 5454C 5455 IOFF = ICKDAO(ISYCKB,ISYMD) + NCKATR(ISYCKB)*(ID1 - 1) + 1 5456C 5457 IF (LENGTH .GT. 0) THEN 5458 CALL GETWA2(LU3SRT,FN3SRT,WORK(KSCR1),IOFF,LENGTH) 5459 ENDIF 5460C 5461C----------------------------------------------------- 5462C Sort integrals (ck,del,b) from (ck,b,del). 5463C----------------------------------------------------- 5464C 5465C 5466 DO 120 ISYMB = 1,NSYM 5467C 5468 ISYMCK = MULD2H(ISYCKB,ISYMB) 5469 ISYCKD = MULD2H(ISYMCK,ISYMD) 5470C 5471 DO 130 B = 1,NVIR(ISYMB) 5472C 5473 DO 140 I = 1,NUMD 5474C 5475 ID = ID1 + I - 1 5476C 5477 KOFF1 = KSCR1 5478 * + NCKATR(ISYCKB)*(I - 1) 5479 * + ICKATR(ISYMCK,ISYMB) 5480 * + NT1AM(ISYMCK)*(B - 1) 5481 KOFF2 = KSCR2 5482 * + NT1AM(ISYMCK)*(I - 1) 5483 5484 CALL DCOPY(NT1AM(ISYMCK),WORK(KOFF1),1, 5485 * WORK(KOFF2),1) 5486C 5487 140 CONTINUE 5488C 5489C---------------------------------------- 5490C Write sorted integrals. 5491C---------------------------------------- 5492C 5493 LENGTH = NT1AM(ISYMCK)*NUMD 5494C 5495 IF (LENGTH .GT. 0) THEN 5496C 5497 IOFF = ICKAD(ISYCKD,ISYMB) 5498 * + NCKA(ISYCKD)*(B - 1) 5499 * + ICKA(ISYMCK,ISYMD) 5500 * + NT1AM(ISYMCK)*(ID1 - 1) + 1 5501C 5502 CALL PUTWA2(LU3VI,FN3VI,WORK(KSCR2),IOFF,LENGTH) 5503C 5504 ENDIF 5505C 5506 130 CONTINUE 5507 120 CONTINUE 5508C 5509C---------------------------------------------------------------------- 5510C Sort integrals (ck,del,b) from (ck,b,del). 5511C for (ccpt and ccfop) = true and iopt = 1 5512C and construct 2*C-E. 5513C---------------------------------------------------------------------- 5514C 5515 IF ((IOPT .EQ. 1) .AND. 5516 & (CC3 .OR. (CCPT .AND. (CCFOP.OR.ETACCPT)))) THEN 5517C 5518 DO ISYMB = 1,NSYM 5519C 5520 ISYMCK = MULD2H(ISYCKB,ISYMB) 5521 ISYCKD = MULD2H(ISYMCK,ISYMD) 5522C 5523 DO B = 1,NVIR(ISYMB) 5524C 5525 DO I = 1,NUMD 5526C 5527 ID = ID1 + I - 1 5528C 5529 DO ISYMK = 1, NSYM 5530C 5531 ISYMC = MULD2H(ISYMCK,ISYMK) 5532 ISYMBK = MULD2H(ISYMB,ISYMK) 5533C 5534 DO K = 1, NRHF(ISYMK) 5535 DO C = 1, NVIR(ISYMC) 5536C 5537 KOFF1 = KSCR1 5538 * + NCKATR(ISYCKB)*(I - 1) 5539 * + ICKATR(ISYMCK,ISYMB) 5540 * + NT1AM(ISYMCK)*(B - 1) 5541 * + IT1AM(ISYMC,ISYMK) 5542 * + NVIR(ISYMC)*(K-1) + C - 1 5543 KOFF2 = KSCR1 5544 * + NCKATR(ISYCKB)*(I - 1) 5545 * + ICKATR(ISYMBK,ISYMC) 5546 * + NT1AM(ISYMBK)*(C - 1) 5547 * + IT1AM(ISYMB,ISYMK) 5548 * + NVIR(ISYMB)*(K-1) + B - 1 5549 KOFF3 = KSCR2 5550 * + NT1AM(ISYMCK)*(I - 1) 5551 * + IT1AM(ISYMC,ISYMK) 5552 * + NVIR(ISYMC)*(K-1) + C - 1 5553C 5554 WORK(KOFF3) = TWO*WORK(KOFF1) 5555 * - WORK(KOFF2) 5556C 5557 ENDDO ! B 5558 ENDDO ! K 5559 ENDDO ! ISYMK 5560 ENDDO ! I 5561C 5562C---------------------------------------- 5563C Write sorted integrals. 5564C---------------------------------------- 5565C 5566 LENGTH = NT1AM(ISYMCK)*NUMD 5567C 5568 IF (LENGTH .GT. 0) THEN 5569C 5570 IOFF = ICKAD(ISYCKD,ISYMB) 5571 * + NCKA(ISYCKD)*(B - 1) 5572 * + ICKA(ISYMCK,ISYMD) 5573 * + NT1AM(ISYMCK)*(ID1 - 1) + 1 5574C 5575 CALL PUTWA2(LU3FOP,FN3FOP,WORK(KSCR2), 5576 * IOFF,LENGTH) 5577C 5578 ENDIF 5579C 5580 ENDDO ! B 5581 ENDDO ! ISYMB 5582C 5583 ENDIF 5584C 5585 IF (IOPT .EQ. 2) GOTO 110 5586C 5587C----------------------------------------------------- 5588C Sort integrals (bk,del,c) from (ck,b,del). 5589C----------------------------------------------------- 5590C 5591 DO 150 ISYMC = 1,NSYM 5592C 5593 ISYMBK = MULD2H(ISYCKB,ISYMC) 5594 ISYBKD = MULD2H(ISYMBK,ISYMD) 5595C 5596 DO 160 C = 1,NVIR(ISYMC) 5597C 5598 DO 170 I = 1,NUMD 5599C 5600 ID = ID1 + I - 1 5601C 5602 DO 180 ISYMK = 1,NSYM 5603C 5604 ISYMB = MULD2H(ISYMBK,ISYMK) 5605 ISYMCK = MULD2H(ISYMC,ISYMK) 5606C 5607 NTOTCK = MAX(NT1AM(ISYMCK),1) 5608C 5609 DO 190 K = 1,NRHF(ISYMK) 5610 5611C 5612 KOFF1 = KSCR1 5613 * + NCKATR(ISYCKB)*(I - 1) 5614 * + ICKATR(ISYMCK,ISYMB) 5615 * + IT1AM(ISYMC,ISYMK) 5616 * + NVIR(ISYMC)*(K - 1) + C - 1 5617C 5618 KOFF2 = KSCR2 5619 * + NT1AM(ISYMBK)*(I - 1) 5620 * + IT1AM(ISYMB,ISYMK) 5621 * + NVIR(ISYMB)*(K - 1) 5622C 5623 CALL DCOPY(NVIR(ISYMB),WORK(KOFF1),NTOTCK, 5624 * WORK(KOFF2),1) 5625C 5626 190 CONTINUE 5627 180 CONTINUE 5628 170 CONTINUE 5629C 5630C---------------------------------------- 5631C Write sorted integrals. 5632C---------------------------------------- 5633C 5634 LENGTH = NT1AM(ISYMBK)*NUMD 5635C 5636 IF (LENGTH .GT. 0) THEN 5637C 5638 IOFF = ICKAD(ISYBKD,ISYMC) 5639 * + NCKA(ISYBKD)*(C - 1) 5640 * + ICKA(ISYMBK,ISYMD) 5641 * + NT1AM(ISYMBK)*(ID1 - 1) + 1 5642C 5643 CALL PUTWA2(LU3VI2,FN3VI2,WORK(KSCR2),IOFF, 5644 * LENGTH) 5645 ENDIF 5646C 5647 160 CONTINUE 5648 150 CONTINUE 5649C 5650C------------------------------------------------------------------------ 5651C For iopt = 1 and (ccpt.and.ccfop) = .true. construct 2*C - E 5652C Sort integrals 2*(bk,c,del) - (ck,b,del) 5653C from (ck,b,del). 5654C------------------------------------------------------------------------ 5655C 5656 IF ((IOPT .EQ. 1 .AND. 5657 * (CC3 .OR. (CCPT .AND. (CCFOP.OR.ETACCPT))) ) 5658 * .OR. (IOPT .EQ. 3)) THEN 5659 5660C 5661 DO ISYMC = 1,NSYM 5662C 5663 ISYMBK = MULD2H(ISYCKB,ISYMC) 5664 ISYBKD = MULD2H(ISYMBK,ISYMD) 5665C 5666 DO C = 1,NVIR(ISYMC) 5667 DO I = 1,NUMD 5668C 5669 ID = ID1 + I - 1 5670C 5671 DO ISYMK = 1,NSYM 5672C 5673 ISYMB = MULD2H(ISYMBK,ISYMK) 5674 ISYMCK = MULD2H(ISYMC,ISYMK) 5675C 5676 NTOTCK = MAX(NT1AM(ISYMCK),1) 5677C 5678 DO K = 1,NRHF(ISYMK) 5679 DO B = 1,NVIR(ISYMB) 5680 5681C 5682 KOFF1 = KSCR1 5683 * + NCKATR(ISYCKB)*(I - 1) 5684 * + ICKATR(ISYMCK,ISYMB) 5685 * + NT1AM(ISYMCK)*(B-1) 5686 * + IT1AM(ISYMC,ISYMK) 5687 * + NVIR(ISYMC)*(K - 1) + C - 1 5688 KOFF2 = KSCR1 5689 * + NCKATR(ISYCKB)*(I - 1) 5690 * + ICKATR(ISYMBK,ISYMC) 5691 * + NT1AM(ISYMBK)*(C-1) 5692 * + IT1AM(ISYMB,ISYMK) 5693 * + NVIR(ISYMB)*(K - 1) + B - 1 5694C 5695 KOFF3 = KSCR2 5696 * + NT1AM(ISYMBK)*(I - 1) 5697 * + IT1AM(ISYMB,ISYMK) 5698 * + NVIR(ISYMB)*(K - 1) + B - 1 5699C 5700 WORK(KOFF3) = TWO*WORK(KOFF1)-WORK(KOFF2) 5701C 5702 ENDDO ! B 5703 ENDDO ! K 5704 ENDDO ! ISYMK 5705 ENDDO ! I 5706C 5707C---------------------------------------- 5708C Write sorted integrals. 5709C---------------------------------------- 5710C 5711 LENGTH = NT1AM(ISYMBK)*NUMD 5712C 5713 IF (LENGTH .GT. 0) THEN 5714C 5715 IOFF = ICKAD(ISYBKD,ISYMC) 5716 * + NCKA(ISYBKD)*(C - 1) 5717 * + ICKA(ISYMBK,ISYMD) 5718 * + NT1AM(ISYMBK)*(ID1 - 1) + 1 5719C 5720 CALL PUTWA2(LU3FOP2,FN3FOP2,WORK(KSCR2), 5721 * IOFF,LENGTH) 5722 ENDIF 5723C 5724C 5725 ENDDO ! C 5726 ENDDO ! ISYMC 5727 ENDIF 5728C 5729 110 CONTINUE 5730 100 CONTINUE 5731C 5732 CALL QEXIT('CC3_SORT1') 5733C 5734 RETURN 5735 END 5736C /* Deck ccsd_delfro */ 5737 SUBROUTINE CCSD_DELFRO(FOCDIA,WORK,LWORK) 5738C 5739#include "implicit.h" 5740C 5741 DIMENSION FOCDIA(*),WORK(LWORK) 5742#include "priunit.h" 5743#include "ccorb.h" 5744#include "ccsdsym.h" 5745C 5746 LOGICAL FRORHF, FROVIR 5747C 5748 CALL QENTER('CCSD_DELFRO') 5749C 5750 IF (LWORK .LT. NORBT) THEN 5751 WRITE(LUPRI,*) 'Insufficient space in CCSD_DELFRO' 5752 CALL QUIT(' ') 5753 END IF 5754C 5755 KOFF1 = 0 5756 KOFF2 = 0 5757C 5758 DO 100 ISYM = 1,NSYM 5759C 5760 DO 110 I = 1,NRHFS(ISYM) 5761 KOFF1 = KOFF1 + 1 5762 IF (.NOT. FRORHF(I,ISYM)) THEN 5763 KOFF2 = KOFF2 + 1 5764 WORK(KOFF2) = FOCDIA(KOFF1) 5765 END IF 5766 110 CONTINUE 5767C 5768 DO 120 A = 1,NVIRS(ISYM) 5769 KOFF1 = KOFF1 + 1 5770 IF (.NOT. FROVIR(A,ISYM)) THEN 5771 KOFF2 = KOFF2 + 1 5772 WORK(KOFF2) = FOCDIA(KOFF1) 5773 END IF 5774 120 CONTINUE 5775C 5776 100 CONTINUE 5777C 5778 CALL DCOPY(NORBT,WORK,1,FOCDIA,1) 5779C 5780 CALL QEXIT('CCSD_DELFRO') 5781C 5782 RETURN 5783 END 5784C /* Deck CC_freezer*/ 5785 SUBROUTINE CC_FREEZER(FOCDIA,NF,NFCS,NFVS,WORK,LWORK,LABEL) 5786C 5787C Ove Christiansen 230899, Find and freeze NFC lowest-lying/NFV highest lying 5788C canonical orbitals in CC calculation. 5789C 5790#include "implicit.h" 5791#include "maxorb.h" 5792C 5793 DIMENSION FOCDIA(NF),WORK(LWORK),NFCS(8),NFVS(8),IPLACE(MXCORB) 5794 CHARACTER*8 LABEL 5795#include "ccorb.h" 5796#include "priunit.h" 5797#include "ccsdsym.h" 5798#include "ccsdinp.h" 5799C 5800 CALL QENTER('CC_FREEZER') 5801C 5802 IF (LABEL .EQ. 'FULLBAS ') THEN 5803 NFC0 = NFC*2 5804 ELSE 5805 NFC0 = NFC 5806 END IF 5807C 5808 IF (IPRINT.GT.5) WRITE(LUPRI,*) ' In CC_FREEZER: ' 5809 IF (IPRINT.GT.5) WRITE(LUPRI,*) 5810 *' Freezing occupied, virtual:',NFC,NFV 5811 IF (LWORK .LT. NORBT) THEN 5812 WRITE(LUPRI,*) 'Insufficient space in CCSD_DELFRO' 5813 CALL QUIT( 'Insufficient space in CCSD_DELFRO') 5814 END IF 5815 CALL FLSHFO(LUPRI) 5816C 5817 DO ISYM=1,NSYM 5818 NRHFFR(ISYM) = 0 5819 NVIRFR(ISYM) = 0 5820 ENDDO 5821C 5822C----------------------------------------------------------------------- 5823C Find NFC lowest orbital energies 5824C----------------------------------------------------------------------- 5825C 5826 IF (NFC.GT.0) THEN 5827 MXELMN = NFC0 5828 NELMN = NFC0 5829 THRDIA = 1.0D-06 5830 CALL FNDMN3(FOCDIA,NF,MXELMN,IPLACE, 5831 * NELMN,IPRINT,THRDIA) 5832C 5833C------------------------------------------------------------- 5834C Find # frozen orbitals in each symmetryclass: NRHFFR 5835C------------------------------------------------------------- 5836C 5837 DO I = 1,NFC0 5838 IF (LABEL .NE. 'FULLBAS ' .OR. 5839 * (LABEL .EQ. 'FULLBAS ' .AND. MOD(I,2) .NE. 0)) THEN 5840 IHFO = IPLACE(I) 5841 CALL CC_SYMHFO(IHFO,ISYMHFO) 5842 WRITE(LUPRI,'(A,I3,A,I3,A,F10.4)') 5843 * ' Freezing HF-orbital ',IHFO,' of symmetry ' 5844 * ,ISYMHFO,' and with orbital energy',FOCDIA(IHFO) 5845 NRHFFR(ISYMHFO) = NRHFFR(ISYMHFO)+1 5846 END IF 5847 ENDDO 5848 WRITE(LUPRI,'(A,8I3)') 5849 * ' In total frozen-core per symmetry-class:', 5850 * (NRHFFR(ISYM),ISYM=1,NSYM) 5851 WRITE(LUPRI,'(A)') ' ' 5852 ENDIF 5853C 5854C----------------------------------------------------------------------- 5855C Find NFV highest orbital energies 5856C----------------------------------------------------------------------- 5857C 5858 IF (NFV.GT.0) THEN 5859 MXELMN = NFV 5860 NELMN = NFV 5861 THRDIA = 1.0D-06 5862 ONEM = -1.0D0 5863 CALL DSCAL(NF,ONEM,FOCDIA,1) 5864 CALL FNDMN3(FOCDIA,NF,MXELMN,IPLACE, 5865 * NELMN,IPRINT,THRDIA) 5866 CALL DSCAL(NF,ONEM,FOCDIA,1) 5867C 5868C------------------------------------------------------------- 5869C Find # frozen orbitals in each symmetryclass: NVIRFR 5870C------------------------------------------------------------- 5871C 5872C 5873 DO I = 1,NFV 5874 IHFO = IPLACE(I) 5875 CALL CC_SYMHFO(IHFO,ISYMHFO) 5876 WRITE(LUPRI,'(A,I3,A,I3,A,F10.4)') 5877 * ' Freezing HF-orbital ',IHFO,' of symmetry ' 5878 * ,ISYMHFO,' and with orbital energy',FOCDIA(IHFO) 5879 NVIRFR(ISYMHFO) = NVIRFR(ISYMHFO)+1 5880 ENDDO 5881 WRITE(LUPRI,'(A,8I3)') 5882 * ' In total frozen-virtual per symmetry-class:', 5883 * (NVIRFR(ISYM),ISYM=1,NSYM) 5884 WRITE(LUPRI,'(A)') ' ' 5885 ENDIF 5886C 5887C----------------------------------------------------------------------- 5888c Put orbitals lowest and highest obital energies on the list of 5889C orbitals to be deleted. 5890C----------------------------------------------------------------------- 5891C 5892 DO ISYM = 1,NSYM 5893 5894 IF (NRHFFR(ISYM) .GT. MAXFRO) THEN 5895 WRITE(LUPRI,'(//,1X,2A,I3)') 'ERROR: Maximum number of ', 5896 * 'frozen orbitals per symmetry is:',MAXFRO 5897 CALL QUIT('Too many frozen orbitals') 5898 END IF 5899 DO I = 1,NRHFFR(ISYM) 5900 KFRRHF(I,ISYM) = I 5901 ENDDO 5902 5903 IF (NVIRFR(ISYM) .GT. MAXFRO) THEN 5904 WRITE(LUPRI,'(//,1X,2A,I3)') 'ERROR: Maximum number of ', 5905 * 'frozen orbitals per symmetry is:',MAXFRO 5906 CALL QUIT('Too many frozen orbitals') 5907 END IF 5908 DO I = 1,NVIRFR(ISYM) 5909 JORB = NVIRS(ISYM) - I + 1 5910 KFRVIR(I,ISYM) = JORB 5911 ENDDO 5912 5913 ENDDO 5914C 5915 CALL FLSHFO(LUPRI) 5916C 5917 CALL QEXIT('CC_FREEZER') 5918C 5919 RETURN 5920 END 5921C /* Deck CC_SYMHFO*/ 5922 SUBROUTINE CC_SYMHFO(IHFO,ISYMHFO) 5923C 5924C OC 230899, find symmetry ISYMHFO of HF orbital nr. IHFO 5925C 5926#include "implicit.h" 5927C 5928#include "priunit.h" 5929#include "ccorb.h" 5930#include "ccsdsym.h" 5931C 5932 CALL QENTER('CC_SYMHFO(IHFO,ISYMHFO') 5933C 5934C 5935 ISYMHFO = 0 5936 ICOUNT = 0 5937 DO ISYM = 1, NSYM 5938 IF ((IHFO.GT.ICOUNT).AND.(IHFO.LE.(ICOUNT+NORBS(ISYM)))) 5939 * ISYMHFO = ISYM 5940 ICOUNT = ICOUNT + NORBS(ISYM) 5941 ENDDO 5942 IF (ISYMHFO.EQ.0) WRITE(LUPRI,*) 'Something is wrong in CC_SYMHFO' 5943C 5944 CALL QEXIT('CC_SYMHFO(IHFO,ISYMHFO') 5945C 5946 RETURN 5947 END 5948C /* Deck ccsd_cbs1 */ 5949 SUBROUTINE CCSD_CBS1(T2AM,FCDIAG,ES,ET,QS,QT) 5950C 5951C Written by Wim Klopper (University of Karlsruhe, 21 November 2002). 5952C 5953C MP2 pair energies and CBS scaling factors 5954C 5955#include "implicit.h" 5956 PARAMETER (ZERO = 0.0D0, ONE = 1.0D0) 5957 PARAMETER (DP25 = 0.25D0, DP75 = 0.75D0) 5958#include "priunit.h" 5959 DIMENSION T2AM(*),FCDIAG(*),ES(*),ET(*),QS(*),QT(*) 5960#include "ccorb.h" 5961#include "ccsdsym.h" 5962 INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 5963 N12 = NRHFT * (NRHFT + 1)/2 5964 CALL DZERO(ES,N12) 5965 CALL DZERO(ET,N12) 5966 CALL DZERO(QS,N12) 5967 CALL DZERO(QT,N12) 5968 DO 100 ISYMBJ = 1,NSYM 5969 ISYMAI = ISYMBJ 5970 DO 110 ISYMJ = 1,NSYM 5971 ISYMB = MULD2H(ISYMJ,ISYMBJ) 5972 DO 120 ISYMI = 1,NSYM 5973 ISYMA = MULD2H(ISYMI,ISYMAI) 5974 DO 130 J = 1,NRHF(ISYMJ) 5975 KOFFJ = IRHF(ISYMJ) + J 5976 DO 140 B = 1,NVIR(ISYMB) 5977 KOFFB = IVIR(ISYMB) + B 5978 NBJ = IT1AM(ISYMB,ISYMJ)+NVIR(ISYMB)*(J-1)+B 5979 DO 150 I = 1,NRHF(ISYMI) 5980 KOFFI = IRHF(ISYMI) + I 5981 DO 160 A = 1,NVIR(ISYMA) 5982 KOFFA = IVIR(ISYMA) + A 5983 NAI = IT1AM(ISYMA,ISYMI)+NVIR(ISYMA)*(I-1)+A 5984 NAIBJ = IT2AM(ISYMAI,ISYMBJ) + INDEX(NAI,NBJ) 5985 DENOM = ONE/(FCDIAG(KOFFI) + FCDIAG(KOFFJ) 5986 * - FCDIAG(KOFFA) - FCDIAG(KOFFB)) 5987 IJ = INDEX(KOFFI,KOFFJ) 5988 ISYMJA = MULD2H(ISYMJ,ISYMA) 5989 ISYMIB = MULD2H(ISYMI,ISYMB) 5990 NAJ = IT1AM(ISYMA,ISYMJ) + 5991 * NVIR(ISYMA)*(J-1) + A 5992 NBI = IT1AM(ISYMB,ISYMI) + 5993 * NVIR(ISYMB)*(I-1) + B 5994 NAJBI = IT2AM(ISYMJA,ISYMIB) + 5995 * INDEX(NAJ,NBI) 5996 VAIBJ = T2AM(NAIBJ) 5997 VAJBI = T2AM(NAJBI) 5998 CS = ABS(VAIBJ + VAJBI) 5999 CT = ABS(VAIBJ - VAJBI) 6000 VS = CS**2 6001 VT = CT**2 6002 ES(IJ) = ES(IJ) + VS * DENOM 6003 ET(IJ) = ET(IJ) + VT * DENOM 6004 QS(IJ) = QS(IJ) + CS * DENOM 6005 QT(IJ) = QT(IJ) + CT * DENOM 6006 160 CONTINUE 6007 150 CONTINUE 6008 140 CONTINUE 6009 130 CONTINUE 6010 120 CONTINUE 6011 110 CONTINUE 6012 100 CONTINUE 6013 E2S = ZERO 6014 E2T = ZERO 6015 CALL AROUND('SECOND-ORDER PAIR ENERGIES') 6016 WRITE(LUPRI,'(4X,A8,4(7X,A8))') 6017 * ' I J','T_2(s=0)','T_2(s=1)' 6018CQST * 'Q_2(s=0)','Q_2(s=1)' 6019 I = 0 6020 DO 230 KI=1,NRHFT 6021 DO 230 KJ=1,KI 6022 I = I + 1 6023 ES(I) = ES(I) * DP25 6024 ET(I) = ET(I) * DP75 6025 E2S = E2S + ES(I) 6026 E2T = E2T + ET(I) 6027 WRITE(LUPRI,'(4X,2I4,4F15.9)') KI,KJ,ES(I),ET(I) 6028CQST * (ONE+QS(I))**2,(ONE+QT(I))**2 6029 230 CONTINUE 6030 E2 = E2S + E2T 6031 WRITE(LUPRI,'(/A5,7X,2F15.9 )') ' SUM ',E2S,E2T 6032 WRITE(LUPRI,'(/A5,7X, F15.9/)') ' TOT.',E2 6033 CALL FLSHFO(LUPRI) 6034 RETURN 6035 END 6036C /* Deck ccsd_cbs2 */ 6037 SUBROUTINE CCSD_CBS2(T1AM,T2AM,WORK,LWORK, 6038 * ET1S,ET1T,ET2S,ET2T,ETY) 6039C 6040C Written by Wim Klopper (University of Karlsruhe, 21 November 2002). 6041C 6042C Coupled-cluster pair energies and CBS scaling factors 6043C 6044#include "implicit.h" 6045 PARAMETER (ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0) 6046 PARAMETER (DP5 = 0.5D0, D1P5 = 1.5D0) 6047#include "priunit.h" 6048#include "iratdef.h" 6049 DIMENSION T1AM(*),T2AM(*),WORK(*), 6050 * ET1S(*),ET1T(*),ET2S(*),ET2T(*) 6051 CHARACTER*5 ETY 6052 LOGICAL LEXIST 6053#include "ccorb.h" 6054#include "ccsdsym.h" 6055#include "ccsdinp.h" 6056#include "ccfield.h" 6057#include "ccinftap.h" 6058 INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 6059 N12 = NRHFT * (NRHFT + 1)/2 6060 CALL DZERO(ET1S,N12) 6061 CALL DZERO(ET1T,N12) 6062 CALL DZERO(ET2S,N12) 6063 CALL DZERO(ET2T,N12) 6064 KIAJB = 1 6065 KEND1 = KIAJB + NT2AMX 6066 LWRK1 = LWORK - KEND1 6067 IF (LWRK1 .LT. 0) THEN 6068 CALL QUIT('Insufficient spaces in CCSD_CBS2') 6069 ENDIF 6070 REWIND(LUIAJB) 6071 CALL READI(LUIAJB,IRAT*NT2AMX,WORK) 6072 DO 100 ISYMJ = 1,NSYM 6073 DO 110 ISYMB = 1,NSYM 6074 ISYMBJ = MULD2H(ISYMB,ISYMJ) 6075 ISYMAI = ISYMBJ 6076 DO 120 ISYMI = 1,NSYM 6077 ISYMBI = MULD2H(ISYMB,ISYMI) 6078 ISYMA = MULD2H(ISYMI,ISYMAI) 6079 ISYMAJ = ISYMBI 6080 DO 130 J = 1,NRHF(ISYMJ) 6081 KOFFJ = IRHF(ISYMJ) + J 6082 DO 140 B = 1,NVIR(ISYMB) 6083 KBJ = IT1AM(ISYMB,ISYMJ) 6084 NBJ = KBJ + NVIR(ISYMB)*(J-1) + B 6085 DO 150 I = 1,NRHF(ISYMI) 6086 KOFFI = IRHF(ISYMI) + I 6087 IJ = INDEX(KOFFI,KOFFJ) 6088 KBI = IT1AM(ISYMB,ISYMI) 6089 NBI = KBI + NVIR(ISYMB)*(I-1) + B 6090 DO 160 A = 1,NVIR(ISYMA) 6091 KAI = IT1AM(ISYMA,ISYMI) 6092 NAI = KAI + NVIR(ISYMA)*(I-1) + A 6093 KAJ = IT1AM(ISYMA,ISYMJ) 6094 NAJ = KAJ + NVIR(ISYMA)*(J-1) + A 6095 NAIBJ = IT2AM(ISYMAI,ISYMBJ) + INDEX(NAI,NBJ) 6096 NAJBI = IT2AM(ISYMAJ,ISYMBI) + INDEX(NAJ,NBI) 6097 IF (ISYMB .EQ. ISYMJ) THEN 6098 ET1S(IJ) = ET1S(IJ) + 6099 * (WORK(NAIBJ) + WORK(NAJBI)) * 6100 * T1AM(NAI)*T1AM(NBJ) 6101 ET1T(IJ) = ET1T(IJ) + 6102 * (WORK(NAIBJ) - WORK(NAJBI)) * 6103 * T1AM(NAI)*T1AM(NBJ) 6104 ENDIF 6105 ET2S(IJ) = ET2S(IJ) + 6106 * (WORK(NAIBJ) + WORK(NAJBI)) * 6107 * T2AM(NAIBJ) 6108 ET2T(IJ) = ET2T(IJ) + 6109 * (WORK(NAIBJ) - WORK(NAJBI))* 6110 * T2AM(NAIBJ) 6111 160 CONTINUE 6112 150 CONTINUE 6113 140 CONTINUE 6114 130 CONTINUE 6115 120 CONTINUE 6116 110 CONTINUE 6117 100 CONTINUE 6118 EET1S = ZERO 6119 EET1T = ZERO 6120 EET2S = ZERO 6121 EET2T = ZERO 6122 CALL AROUND(ETY//' PAIR ENERGIES') 6123 WRITE(LUPRI,'(4X,A8,4(7X,A8))') 6124 * ' I J','T_1(s=0)','T_1(s=1)', 6125 * 'T_2(s=0)','T_2(s=1)' 6126 I = 0 6127 DO 230 KI=1,NRHFT 6128 DO 230 KJ=1,KI 6129 I = I + 1 6130 ET1S(I) = ET1S(I) * DP5 6131 ET2S(I) = ET2S(I) * DP5 6132 ET1T(I) = ET1T(I) * D1P5 6133 ET2T(I) = ET2T(I) * D1P5 6134 WRITE(LUPRI,'(4X,2I4,4F15.9)') KI,KJ, 6135 * ET1S(I), ET1T(I), ET2S(I), ET2T(I) 6136 EET1S = EET1S + ET1S(I) 6137 EET1T = EET1T + ET1T(I) 6138 EET2S = EET2S + ET2S(I) 6139 EET2T = EET2T + ET2T(I) 6140 230 CONTINUE 6141 EE = EET1S + EET1T + EET2S + EET2T 6142 WRITE(LUPRI,'(/A5,7X,4F15.9 )') ' SUM ',EET1S,EET1T,EET2S,EET2T 6143 WRITE(LUPRI,'(/A5,7X, F15.9/)') ' TOT.',EE 6144 CALL FLSHFO(LUPRI) 6145 RETURN 6146 END 6147C /* Deck frorhf */ 6148 LOGICAL FUNCTION FRORHF(I,ISYM) 6149C 6150C Thomas Bondo Pedersen, July 2003. 6151C 6152C Returns .TRUE. if occupied orbital I of symmetry ISYM is frozen. 6153C 6154#include "implicit.h" 6155#include "priunit.h" 6156#include "ccorb.h" 6157#include "ccsdinp.h" 6158 6159 LOGICAL LOCDBG 6160 PARAMETER (LOCDBG = .FALSE.) 6161 6162 FRORHF = .FALSE. 6163 6164 IF (FROIMP) THEN 6165 6166 IF (I .LE. NRHFFR(ISYM)) FRORHF = .TRUE. 6167 6168 ELSE IF (FROEXP) THEN 6169 6170 DO II = 1,NRHFFR(ISYM) 6171 IF (I .EQ. KFRRHF(II,ISYM)) THEN 6172 FRORHF = .TRUE. 6173 GO TO 100 6174 END IF 6175 END DO 6176 100 CONTINUE 6177 6178 END IF 6179 6180 IF (LOCDBG) THEN 6181 IF (FRORHF) THEN 6182 WRITE(LUPRI,'(A,I6,A,I2,A)') 6183 & 'Occupied orbital',I,' of sym.' ,ISYM,' is frozen' 6184 ELSE 6185 WRITE(LUPRI,'(A,I6,A,I2,A)') 6186 & 'Occupied orbital',I,' of sym.' ,ISYM,' is NOT frozen' 6187 END IF 6188 END IF 6189 6190 RETURN 6191 END 6192C /* Deck frovir */ 6193 LOGICAL FUNCTION FROVIR(A,ISYM) 6194C 6195C Thomas Bondo Pedersen, July 2003. 6196C 6197C Returns .TRUE. if virtual orbital A of symmetry ISYM is frozen. 6198C 6199#include "implicit.h" 6200#include "priunit.h" 6201#include "ccorb.h" 6202#include "ccsdinp.h" 6203 6204 INTEGER A 6205 INTEGER AA 6206 6207 LOGICAL LOCDBG 6208 PARAMETER (LOCDBG = .FALSE.) 6209 6210 FROVIR = .FALSE. 6211 6212 IF (FROIMP) THEN 6213 6214 IF (A .GT. NVIR(ISYM)) FROVIR = .TRUE. 6215 6216 ELSE IF (FROEXP) THEN 6217 6218 DO AA = 1,NVIRFR(ISYM) 6219 IF (A .EQ. KFRVIR(AA,ISYM)) THEN 6220 FROVIR = .TRUE. 6221 GO TO 100 6222 END IF 6223 END DO 6224 100 CONTINUE 6225 6226 END IF 6227 6228 IF (LOCDBG) THEN 6229 IF (FROVIR) THEN 6230 WRITE(LUPRI,'(A,I6,A,I2,A)') 6231 & 'Virtual orbital',A,' of sym.' ,ISYM,' is frozen' 6232 ELSE 6233 WRITE(LUPRI,'(A,I6,A,I2,A)') 6234 & 'Virtual orbital',A,' of sym.' ,ISYM,' is NOT frozen' 6235 END IF 6236 END IF 6237 6238 RETURN 6239 END 6240 6241 SUBROUTINE DCPT2_EN(T1AM,T2AM,FCDIAG,TAMR12, 6242 * WORK,LWORK,XECCSD,POTNUC, 6243 * ESCF,ETY,ER12,LR12,IT1,ITER, 6244 * APROXR12) 6245C 6246C 6247C 6248#include "implicit.h" 6249#include "priunit.h" 6250#include "dummy.h" 6251 PARAMETER (ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0) 6252#include "iratdef.h" 6253 DIMENSION FCDIAG(*) 6254 DIMENSION T1AM(*),T2AM(*),TAMR12(*),WORK(*) 6255 CHARACTER ETY*5, ETYPE*24, MODEL*10 6256 CHARACTER*(*) APROXR12 6257 LOGICAL LEXIST, LR12, LOCDBG 6258 PARAMETER (LOCDBG = .FALSE.) 6259 INTEGER ICMO(8,8), NCMO(8), IGLMRHS(8,8), IGLMVIS(8,8), NGLMDS(8) 6260#include "ccorb.h" 6261#include "ccsdsym.h" 6262#include "ccsdinp.h" 6263#include "ccfield.h" 6264#include "ccinftap.h" 6265#include "r12int.h" 6266#include "ccr12int.h" 6267#include "dftcom.h" 6268 6269C 6270 INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 6271C 6272 CALL QENTER('DCPT2_EN') 6273 6274C 6275 XECCSD = ESCF 6276C 6277C--------------------------------- 6278C Dynamic allocation of space. 6279C--------------------------------- 6280C 6281 KIAJB = 1 6282 KEND1 = KIAJB + NT2AMX 6283 LWRK1 = LWORK - KEND1 6284C 6285 IF (LWRK1 .LT. 0) THEN 6286 ENDIF 6287C 6288 REWIND(LUIAJB) 6289 CALL READI(LUIAJB,IRAT*NT2AMX,WORK) 6290 EDCPT2A=0.0d0 6291 EDCPT2B=0.0d0 6292C 6293 DO 100 ISYMJ = 1,NSYM 6294 DO 110 ISYMB = 1,NSYM 6295 ISYMBJ = MULD2H(ISYMB,ISYMJ) 6296 ISYMAI = ISYMBJ 6297 DO 120 ISYMI = 1,NSYM 6298 ISYMBI = MULD2H(ISYMB,ISYMI) 6299 ISYMA = MULD2H(ISYMI,ISYMAI) 6300 ISYMAJ = ISYMBI 6301C 6302 DO 130 J = 1,NRHF(ISYMJ) 6303 KOFFJ = IRHF(ISYMJ)+J 6304 DO 140 B = 1,NVIR(ISYMB) 6305C 6306 KOFFB=IVIR(ISYMB)+B 6307 KBJ = IT1AM(ISYMB,ISYMJ) 6308 NBJ = KBJ + NVIR(ISYMB)*(J-1) + B 6309C 6310 DO 150 I = 1,NRHF(ISYMI) 6311C 6312 KOFFI=IRHF(ISYMI)+I 6313 KBI = IT1AM(ISYMB,ISYMI) 6314 NBI = KBI + NVIR(ISYMB)*(I-1) + B 6315C 6316 DO 160 A = 1,NVIR(ISYMA) 6317C 6318 KOFFA=IVIR(ISYMA)+A 6319 KAI = IT1AM(ISYMA,ISYMI) 6320 NAI = KAI + NVIR(ISYMA)*(I-1) + A 6321 KAJ = IT1AM(ISYMA,ISYMJ) 6322 NAJ = KAJ + NVIR(ISYMA)*(J-1) + A 6323C 6324 NAIBJ = IT2AM(ISYMAI,ISYMBJ) + INDEX(NAI,NBJ) 6325 NAJBI = IT2AM(ISYMAJ,ISYMBI) + INDEX(NAJ,NBI) 6326 6327CAMT Compute second part of DCPT2 Energy 6328CAMT ie. 1/4 (DABIJ - DSQRT(DABIJ^2 + 4(<ij|ab>-<ij|ba>)^2) 6329 DABIJ=FCDIAG(KOFFA) 6330 * + FCDIAG(KOFFB) 6331 * - FCDIAG(KOFFI) - FCDIAG(KOFFJ) 6332 6333 FAC=1.0d0 6334 FAC1=1.0d0 6335 6336 CEINT=FAC*(WORK(NAIBJ) - WORK(NAJBI)) 6337 CINT=FAC*WORK(NAIBJ) 6338 EDCPTA=FAC1*0.5d0*(DABIJ - DSQRT(DABIJ**2 6339 * +4.0d0*(CINT**2))) 6340 6341 EDCPT2A=EDCPT2A+ FAC1*0.5d0*(DABIJ - 6342 * DSQRT(DABIJ**2+4.0d0*(CINT**2))) 6343 6344 EDCPTB=FAC1*0.25d0*(DABIJ - 6345 * DSQRT(DABIJ**2 6346 * +4.0d0*(CEINT**2))) 6347 6348 EDCPT2B=EDCPT2B+ FAC1*0.25d0*( 6349 * DABIJ - DSQRT(DABIJ**2 6350 * +4.0d0*(CEINT**2))) 6351C 6352 160 CONTINUE 6353 150 CONTINUE 6354 140 CONTINUE 6355 130 CONTINUE 6356 120 CONTINUE 6357 110 CONTINUE 6358 100 CONTINUE 6359 6360 EDDCPT2=EDCPT2A+EDCPT2B 6361 6362C WRITE(LUPRI,'(A40,F20.12)') 6363C & 'DCPT2 Total Energy',XECCSD+EDDCPT2 6364 6365 XECCSD=XECCSD+EDCPT2A+EDCPT2B 6366 6367C 6368C------------------------------------------------------------------- 6369C Add field dependent energy in case of finite field ONEelectron 6370C Perturbation. The AO integral from ONEP is already scaled with 6371C the fieldstrengths!!! 6372C------------------------------------------------------------------- 6373C 6374 DO 13 IF = 1, NFIELD 6375 IF (NONHF) THEN 6376C 6377 DO ISYM = 1, NSYM 6378 ICOUNT = 0 6379 ICOUNT3 = 0 6380 DO ISYM2 = 1, NSYM 6381 ISYM1 = MULD2H(ISYM,ISYM2) 6382 ICMO(ISYM1,ISYM2) = ICOUNT 6383 ICOUNT = ICOUNT + NBAS(ISYM1)*NORBS(ISYM2) 6384 ICOUNT3 = ICOUNT3 + NBAS(ISYM1)*NRHFS(ISYM2) 6385 END DO 6386 NCMO(ISYM) = ICOUNT 6387 NGLMDS(ISYM) = ICOUNT 6388 6389 ICOUNT2 = 0 6390 DO ISYM2 = 1, NSYM 6391 ISYM1 = MULD2H(ISYM,ISYM2) 6392 IGLMRHS(ISYM1,ISYM2) = ICOUNT2 6393 IGLMVIS(ISYM1,ISYM2) = ICOUNT3 6394 ICOUNT2 = ICOUNT2 + NBAS(ISYM1)*NRHFS(ISYM2) 6395 ICOUNT3 = ICOUNT3 + NBAS(ISYM1)*NVIRS(ISYM2) 6396 END DO 6397 END DO 6398C 6399 KONEP = 1 6400 KT1AM = KONEP + N2BST(ISYMOP) 6401 KLAMDPS= KT1AM + NT1AMX 6402 KLAMDHS= KLAMDPS+ NGLMDS(1) 6403 KEND1 = KLAMDHS+ NGLMDS(1) 6404 LWRK1 = LWORK - KEND1 6405 IF ( LWRK1 .LT. 0 ) 6406 * CALL QUIT(' Too little workspace in ccsd_eccsd-2') 6407C 6408 CALL DZERO(WORK(KONEP),N2BST(ISYMOP)) 6409 FF = EFIELD(IF) 6410 CALL CC_ONEP(WORK(KONEP),WORK(KEND1),LWRK1,FF,1,LFIELD(IF)) 6411C 6412 IF (.NOT.(CCS.OR.CCP2)) THEN 6413C 6414 IF ( IT1 .EQ. 1 ) THEN 6415 IOPT = 1 6416 CALL CC_RDRSP('R0',0,1,IOPT,MODEL,WORK(KT1AM),DUMMY) 6417 ELSE IF (IT1 .EQ. 0) THEN 6418 CALL DZERO(WORK(KT1AM),NT1AMX) 6419 ELSE 6420 CALL QUIT('IT1 should be 0 or 1 in ccsd_eccsd') 6421 ENDIF 6422 ENDIF 6423 CALL LAMMATS(WORK(KLAMDPS),WORK(KLAMDHS),WORK(KT1AM), 6424 & 1,.FALSE.,.FALSE., 6425 & NGLMDS,IGLMRHS,IGLMVIS,ICMO,WORK(KEND1),LWRK1) 6426 6427 DO ISYM = 1, NSYM 6428 6429 KSCR1 = KEND1 6430 KEND2 = KSCR1 + NBAS(ISYM) * NRHFS(ISYM) 6431 LWRK2 = LWORK - KEND2 6432 IF ( LWRK2 .LT. 0 ) 6433 * CALL QUIT(' Too little workspace in ccsd_eccsd-3') 6434 6435 NBAS1 = MAX(NBAS(ISYM),1) 6436 KOFF1 = KONEP + IAODIS(ISYM,ISYM) 6437 KOFF2 = KLAMDHS + IGLMRHS(ISYM,ISYM) 6438 6439 CALL DGEMM('N','N',NBAS(ISYM),NRHFS(ISYM),NBAS(ISYM), 6440 * ONE,WORK(KOFF1),NBAS1,WORK(KOFF2),NBAS1, 6441 * ZERO,WORK(KSCR1),NBAS1) 6442 6443 KOFF2 = KLAMDPS + IGLMRHS(ISYM,ISYM) 6444 6445 TRACE = DDOT(NBAS(ISYM)*NRHFS(ISYM), 6446 & WORK(KOFF2),1,WORK(KSCR1),1) 6447 XECCSD = XECCSD + TWO * TRACE 6448 XDRCCD = XDRCCD + TWO * TRACE 6449 END DO 6450 6451 ENDIF 6452 13 CONTINUE 6453C 6454 XCORR = XECCSD - ESCF 6455 XDRCCD_CORR = XDRCCD - ESCF 6456 6457 ETYPE(1:5) = ETY(1:5) 6458 LENET = 5 6459 6460 IF (LR12) THEN 6461 KVR12 = 1 6462 KEND1 = KVR12 + NTR12AM(1) 6463 LWRK1 = LWORK - KEND1 6464 IF ( LWRK1 .LT. 0 ) 6465 * CALL QUIT(' Too little workspace in ccsd_eccsd-3') 6466C 6467C read V matrices 6468 LUNIT = -1 6469 CALL GPOPEN(LUNIT,FCCR12V,'UNKNOWN',' ','UNFORMATTED', 6470 & IDUM,LDUM) 64716666 READ(LUNIT) IAN 6472 READ(LUNIT) (WORK(KVR12-1+I), I=1, NTR12AM(1)) 6473 IF (IAN.NE.IANR12) GOTO 6666 6474 CALL GPCLOSE(LUNIT,'KEEP') 6475 CALL CC_R12TCMEPK(WORK(KVR12),1,.FALSE.) 6476 CALL CCLR_DIASCLR12(WORK(KVR12),0.5D0,1) 6477 6478 ER12 = 2.0D0*DDOT(NTR12AM(1),TAMR12,1,WORK(KVR12),1) 6479 6480 XECCSD = XECCSD + ER12 6481 6482 CALL CCSD_MODEL(ETYPE,LENET,24,ETY,5,APROXR12) 6483 END IF 6484C 6485 WRITE(LUPRI,'(1X,A,I3,A,A,A,F23.16)') 6486 * 'Iter.',ITER,': Coupled cluster ',ETYPE(1:LENET), 6487 * ' energy : ',XECCSD 6488 6489C 6490 IF (IPRINT .GE. 2) THEN 6491 WRITE(LUPRI,'(5X,A,F23.16)') 6492 & 'Conventional correlation energy:',XCORR 6493 IF (LR12) THEN 6494 WRITE(LUPRI,'(3(5X,A,F23.16,/))') 6495C & 'Singlet R12 correlation energy :',ER12S, 6496C & 'Triplet R12 correlation energy :',ER12T, 6497 & 'R12 correlation energy :',ER12, 6498 & 'Total correlation energy :',XCORR+ER12 6499 END IF 6500 END IF 6501 6502 IF (LOCDBG) THEN 6503 CALL AROUND('Amplitudes at this iteration:') 6504 CALL CC_PRP(T1AM,T2AM,1,1,1) 6505 IF (CCR12) CALL CC_PRPR12(TAMR12,1,1,.TRUE.) 6506 END IF 6507C 6508 CALL FLSHFO(LUPRI) 6509C 6510 CALL QEXIT('DCPT2_EN') 6511C 6512 RETURN 6513 END 6514 6515 6516C /* Deck drpa_checkstability */ 6517 Logical Function dRPA_isStabilizingSolution(T2Am,g,OrbEn, 6518 & Work,lWork,o,v) 6519C 6520C Thomas Bondo Pedersen, May 2011. 6521C Check if T2Am is a stabilizing solution of the dRPA=drCCD 6522C equations. I.e. check that -A+2BT is Hurwitz (i.e. all eigenvalues 6523C have negative real part). 6524C A_aibj = (e_a-e_i)delta(ab)delta(ij) 6525C + 2(ai|bj) 6526C B_aibj = -2(ai|bj) 6527C On entry, 6528C T2Am --- amplitudes (solution vector), packed LT storage 6529C g --- 2(ai|bj), packed LT storage 6530C OrbEn --- orbital energies, occupied then virtual 6531C Work(lWork) --- work space 6532C o --- number of occupied orbs 6533C v --- number of occupied orbs 6534C Unchanged on exit. 6535C 6536C NOTE: symmetry not implemented! 6537 Implicit None 6538 Integer lWork, o, v 6539 Real*8 T2Am(*) 6540 Real*8 g(*) 6541 Real*8 OrbEn(*) 6542 Real*8 Work(lWork) 6543 6544 Logical isHurwitz 6545 6546 Integer vo, vo1 6547 Integer kM, kNext, lWrk 6548 Integer ai, bj, ck, kM0, kM1, kT, kg 6549 6550 Integer m, n 6551 Integer iTri, Occ, Vir 6552 Real*8 del 6553 iTri(m,n) = max(m,n)*(max(m,n)-3)/2+m+n 6554 Vir(m)=mod(m-1,v)+1 6555 Occ(m)=(m-Vir(m))/v+1 6556 del(m)=OrbEn(o+Vir(m))-OrbEn(Occ(m)) 6557 6558 ! Check memory 6559 vo=v*o 6560 If (vo.lt.1) Then 6561 dRPA_isStabilizingSolution=.True. 6562 Return 6563 End If 6564 kM=1 6565 kNext=kM+vo**2 6566 lWrk=lWork-kNext+1 6567 If (lWrk.lt.0) Then 6568 Call Quit('Insufficient memory in dRPA_isStabilizingSolution') 6569 End If 6570 6571 ! Compute M 6572 If (lWrk.gt.2*vo**2) Then 6573 kT=kNext 6574 kg=kT+vo**2 6575 Call CC_T2Sq(T2Am,Work(kT),1) 6576 Call CC_T2Sq(g,Work(kg),1) 6577 Call dCopy(vo**2,Work(kg),1,Work(kM),1) 6578 Call dGeMM('N','N',vo,vo,vo, 6579 & 2.0d0,Work(kg),vo,Work(kT),vo, 6580 & 1.0d0,Work(kM),vo) 6581 kM1=kM 6582 vo1=vo+1 6583 Do ai=1,vo 6584 Work(kM1)=Work(kM1)+del(ai) 6585 kM1=kM1+vo1 6586 End Do 6587 Else 6588 Do bj=1,vo 6589 kM0=kM-1+vo*(bj-1) 6590 Do ai=1,vo 6591 kM1=kM0+ai 6592 Work(kM1)=0.0d0 6593 Do ck=1,vo 6594 Work(kM1)=Work(kM1)+g(iTri(ai,ck))*T2Am(iTri(ck,bj)) 6595 End Do 6596 End Do 6597 End Do 6598 Call dScal(vo**2,2.0d0,Work(kM),1) 6599 Do bj=1,vo 6600 kM0=kM-1+vo*(bj-1) 6601 Do ai=1,bj-1 6602 Work(kM0+ai)=Work(kM0+ai)+g(iTri(ai,bj)) 6603 End Do 6604 Work(kM0+bj)=Work(kM0+bj)+del(bj)+g(iTri(bj,bj)) 6605 Do ai=bj+1,vo 6606 Work(kM0+ai)=Work(kM0+ai)+g(iTri(ai,bj)) 6607 End Do 6608 End Do 6609 End If 6610 Call dScal(vo**2,-1.0d0,Work(kM),1) 6611 6612 ! Check that M is Hurwitz 6613 dRPA_isStabilizingSolution=isHurwitz(Work(kM),vo,Work(kNext),lWrk) 6614 6615 End 6616C /* Deck isHurwitz */ 6617 Logical Function isHurwitz(X,n,Work,lWork) 6618C 6619C Thomas Bondo Pedersen, May 2011. 6620C 6621C Returns .True. if X(n,n) is Hurwitz. 6622C 6623C Version 1: check by brute force diagonalization that the real part 6624C of all eigenvalues is negative. 6625C 6626 Implicit None 6627 Integer n 6628 Real*8 X(n,n) 6629 Integer lWork 6630 Real*8 Work(lWork) 6631 6632 Real*8 Tol 6633 Parameter (Tol=-1.0d-16) 6634 6635 Character*53 Str 6636 Integer kwr, kwi, kduml, kdumr, kNext, lWrk, irc, i 6637 6638 isHurwitz=.True. 6639 irc = 0 6640 If (n.gt.0) Then 6641 kwr=1 6642 kwi=kwr+n 6643 kduml=kwi+n 6644 kdumr=kduml+1 6645 kNext=kdumr+1 6646 lWrk=lWork-kNext+1 6647 If (lWrk.lt.4*n) Then 6648 Call Quit('Insufficient memory in isHurwitz') 6649 End If 6650 Call dGeEV('N','N',n,X,n,Work(kwr),Work(kwi), 6651 & Work(kduml),1,Work(kdumr),1, 6652 & Work(kNext),lWrk,irc) 6653 If (irc.ne.0) Then 6654 Write(Str,'(A,I9)') 6655 & 'diagonalization failed, dGeEV returned code ',irc 6656 Call Quit('isHurwitz: '//Str) 6657 Else 6658 i=0 6659 Do While (i.lt.n .and. isHurwitz) 6660 isHurwitz=Work(kwr+i).lt.Tol 6661 i=i+1 6662 End Do 6663 End If 6664 End If 6665 End 6666