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 ccrhsn */ 20 SUBROUTINE CCRHSN(OMEGA1,OMEGA2,T1AM,T2AM,WORK,LWORK,APROXR12) 21C 22C Written by Henrik Koch 25-Sep-1993 23C 24C Version 3.0 25C 26C Purpose: 27C 28C Calculation of the Coupled Cluster vector function using 29C AO-integrals directly from disk. 30C 31C 32C NB! It is assumed that the vectors are allocated in the following 33C order: 34C T1AM(*), OMEGA1(*), OMEGA2(*), T2AM(*), WORK(*). 35C 36C some changes for CC2 with non-Hatree-Fock fields (NONHF=.true.) 37C to allow for finite difference also w.r.t. orbital coefficients 38C (i.e. the CMO vector), spring 2000, Ch. Haettig 39C 40 USE PELIB_INTERFACE, ONLY: USE_PELIB 41#include "implicit.h" 42#include "priunit.h" 43#include "dummy.h" 44#include "maxash.h" 45#include "maxorb.h" 46#include "mxcent.h" 47#include "aovec.h" 48#include "iratdef.h" 49#include "ccorb.h" 50#include "ccisao.h" 51#include "blocks.h" 52#include "ccfield.h" 53#include "ccsections.h" 54#include "ccsdinp.h" 55#include "ccsdsym.h" 56#include "ccsdio.h" 57#include "distcl.h" 58#include "cbieri.h" 59#include "eritap.h" 60#include "eribuf.h" 61#include "ccnoddy.h" 62#include "cbirea.h" 63#include "r12int.h" 64#include "ccr12int.h" 65#include "qm3.h" 66!#include "qmmm.h" 67C 68 PARAMETER (ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, TWO = 2.0D0) 69 PARAMETER (XMHALF = -0.5D0, XMONE= -1.0D0 ) 70 PARAMETER (ISYM0 = 1) 71C 72 LOGICAL FCKCON,CC1BSA,ETRAN,CC2R12,CCSDR12,LV,LVAJKL,LRES, 73 & DEBUGV,LVIJKL,LVABKL 74 PARAMETER (DEBUGV = .FALSE.) 75C 76 DIMENSION INDEXA(MXCORB_CC) 77 DIMENSION OMEGA1(*),OMEGA2(*),T1AM(*),T2AM(*),WORK(LWORK) 78C 79 CHARACTER CFIL*6,DFIL*6, FN3SRT*8, FNDELD*6, CDUMMY*8 80 CHARACTER FNCKJD*6, FNDKBC*4, FNTOC*8, FN3VI*6, FN3VI2*8 81 CHARACTER FNIADJ*8, FNIJDA*8, CPFIL*8, DPFIL*8 82 CHARACTER*(*) APROXR12 83 CHARACTER MODEL*10 84C 85 PARAMETER (FNIADJ = 'CCXIADJ0', FNIJDA = 'CCXIJDA0') 86 PARAMETER (CPFIL = 'CC_CPR12', DPFIL = 'CC_DPR12') 87C 88 89 INTEGER IGLMRHS(8,8),IGLMVIS(8,8),NGLMDS(8),ICMO(8,8),NCMO(8), 90 & IMAIJM(8,8),NMAIJM(8), 91 & IMATIJM(8,8),NMATIJM(8),NGAMSM(8),IGAMSM(8,8), 92 & IRGIJS(8,8),NRGIJS(8),IR1BASM(8,8),NR1BASM(8), 93 & IR2BASM(8,8),NR2BASM,IR1XBASM(8,8),NR1XBASM(8), 94 & IR2XBASM(8,8),IMATF(8,8),NMATF(8),IMAKLM(8,8),NMAKLM(8) 95 INTEGER NADP(8),IADP(8,8),NLAMDX(8),ILAMDX(8,8) 96C 97 LOGICAL MLCC3_RESPONSE 98C 99 REAL*8, ALLOCATABLE :: DENMAT(:), FOCKMAT(:), FOCKTEMP(:) 100C 101 CALL QENTER('CCRHSN') 102C 103 CC2R12 = CC2 .AND. LMULBS 104 IF (LMULBS.AND. .NOT.(CC2R12 .OR. CCS .OR. CIS)) THEN 105 CCSDR12 = .TRUE. 106 IF (IANR12.EQ.2) CALL QUIT('CCSD(R12) only implemented for '// 107 & 'Ansaetze 1 and 3') 108 ELSE 109 CCSDR12 = .FALSE. 110 END IF 111 IF (LMULBS.AND.NONHF.AND.IANR12.NE.1) THEN 112 CALL QUIT('CC-R12 with finite fields only implemented for '// 113 & 'Ansatz 1') 114 END IF 115CTesT 116C CCSDR12 = .TRUE. 117C DUMPCD = .TRUE. 118CTesT 119C 120C----------------------------------------------------------- 121C For energy calculation trial vector is totalsymmetric. 122C----------------------------------------------------------- 123C 124 ISYMTR = 1 125C 126C----------------------------------------- 127C Save CC1B flag and if CC1A set true. 128C----------------------------------------- 129C 130 CC1BSA = CC1B 131 IF ( CC1A ) CC1B = .TRUE. 132C 133 IF ( IPRINT .GT. 10 ) THEN 134C 135 WRITE(LUPRI,*) ' In ccsd_rhs : ' 136 WRITE(LUPRI,*) ' CCSD, CC2: ',CCSD,CC2 137 WRITE(LUPRI,*) ' CC1A, CC1B, CC3: ', CC1A, CC1B, CC3 138C 139 ENDIF 140C 141C---------------- 142C Open files. 143C---------------- 144C 145 LUC = -1 146 LUD = -1 147 CFIL = 'PMAT_C' 148 DFIL = 'PMAT_D' 149C 150 IF (DEBUG) WRITE(LUPRI,*) 'DUMPCD = ',DUMPCD 151 IF (DUMPCD) THEN 152 CALL WOPEN2(LUC,CFIL,64,0) 153 CALL WOPEN2(LUD,DFIL,64,0) 154C 155 END IF 156C 157 IF (CCSDT) THEN 158C 159 LU3SRT = -1 160 LUCKJD = -1 161 LUDELD = -1 162 LUDKBC = -1 163 LUTOC = -1 164 LU3VI = -1 165 LU3VI2 = -1 166 FN3SRT = 'CC3_SORT' 167 FNCKJD = 'CKJDEL' 168 FNDELD = 'CKDELD' 169 FNDKBC = 'DKBC' 170 FNTOC = 'CCSDT_OC' 171 FN3VI = 'CC3_VI' 172 FN3VI2 = 'CC3_VI12' 173C 174 CALL WOPEN2(LU3SRT,FN3SRT,64,0) 175 CALL WOPEN2(LUCKJD,FNCKJD,64,0) 176 CALL WOPEN2(LUDELD,FNDELD,64,0) 177 CALL WOPEN2(LUDKBC,FNDKBC,64,0) 178 CALL WOPEN2(LUTOC,FNTOC,64,0) 179 CALL WOPEN2(LU3VI,FN3VI,64,0) 180 CALL WOPEN2(LU3VI2,FN3VI2,64,0) 181C 182 ENDIF 183 184 IF (CCSDR12 .AND. (IANR12.EQ.2.OR.IANR12.EQ.3)) THEN 185 LUIADJ = -1 186 LUIJDA = -1 187 CALL WOPEN2(LUIADJ,FNIADJ,64,0) 188 CALL WOPEN2(LUIJDA,FNIJDA,64,0) 189 LUCP = -1 190 LUDP = -1 191 CALL WOPEN2(LUCP,CPFIL,64,0) 192 CALL WOPEN2(LUDP,DPFIL,64,0) 193 END IF 194C 195C---------------------------------- 196C Initialize timing parameters. 197C---------------------------------- 198C 199 TIMALL = SECOND() 200 TIMA = 0.0D00 201 TIMB = 0.0D00 202 TIMBF = 0.0D00 203 TIMC = 0.0D00 204 TIMD = 0.0D00 205 TIME = 0.0D00 206 TIMEP = 0.0D00 207 TIMF = 0.0D00 208 TIMFP = 0.0D00 209 TIMG = 0.0D00 210 TIMGP = 0.0D00 211 TIMH = 0.0D00 212 TIMI = 0.0D00 213 TIMJ = 0.0D00 214 TIMGAM = 0.0D00 215 TIMEI = 0.0D00 216 TIMLAM = 0.0D00 217 TIMRDAO = 0.0D00 218 TIMHER1 = 0.0D00 219 TIMHER2 = 0.0D00 220 TIMT2AO = 0.0D00 221 TIMFCK = 0.0D00 222 TIMDM = 0.0D00 223 TIMFCKMO= 0.0D00 224 TIMT2TR = 0.0D00 225 TIMT2BT = 0.0D00 226 TIMTRBT = 0.0D00 227 TIMRDAOR12 = 0.0D00 228 TIMINTR12 = 0.0D00 229C 230C--------------------------- 231C Check inconsistencies. 232C--------------------------- 233C 234 IF (NEWGAM) THEN 235 IF ((.NOT. DUMPCD) .OR. (.NOT. OMEGOR)) THEN 236 WRITE(LUPRI,*) 'NEWGAM requires both DUMPCD and OMEGOR' 237 CALL QUIT('ERROR: NEWGAM inconsistency') 238 END IF 239 END IF 240C 241C--------------------------------- 242C Work space allocation no. 1. 243C--------------------------------- 244C 245 KLAMDP = 1 246 KLAMIP = KLAMDP + NLAMDT 247 IF (.NOT. DUMPCD) THEN 248 KLAMDH = KLAMIP + NLAMDT 249 ELSE 250 KLAMDH = KLAMIP + 1 251 END IF 252 KDENSI = KLAMDH + NLAMDT 253 KFOCK = KDENSI + N2BAST 254 KEMAT1 = KFOCK + N2BST(ISYMOP) 255 KEMAT2 = KEMAT1 + NEMAT1(ISYMOP) 256 KGAMMA = KEMAT2 + NMATIJ(ISYMOP) 257 IF (NEWGAM) THEN 258 KEND1 = KGAMMA 259 ELSE 260 KEND1 = KGAMMA + NGAMMA(ISYMOP) 261 END IF 262 IF (CC2 .AND. NONHF) THEN 263 KFCKHF = KEND1 264 KEND1 = KFCKHF + N2BAST 265 END IF 266c 267 IF (CCR12) THEN 268 KVIJKL = KEND1 269 KEND1 = KVIJKL + NTR12SQ(1) 270 END IF 271 272 IF (CCR12) THEN 273 CALL CC_R12OFFS23(IGLMRHS,IGLMVIS,NGLMDS,ICMO,NCMO, 274 & IMAIJM,NMAIJM,IMAKLM,NMAKLM, 275 & IMATIJM,NMATIJM, 276 & IGAMSM,NGAMSM,IRGIJS,NRGIJS, 277 & IR1BASM,NR1BASM,IR2BASM,NR2BASM,IR1XBASM, 278 & NR1XBASM,IR2XBASM,IMATF,NMATF) 279 KLAMDHS = KEND1 280 KLAMDPS = KLAMDHS + NGLMDS(1) 281 KEND1 = KLAMDPS + NGLMDS(1) 282 283 CALL LAMMATS(WORK(KLAMDPS),WORK(KLAMDHS),T1AM, 284 & 1,.FALSE.,.FALSE., 285 & NGLMDS,IGLMRHS,IGLMVIS,ICMO,WORK(KEND1),LWRK1) 286 END IF 287 288 IF (CCR12.AND..NOT.USEVABKL) THEN 289 KVAJKL = KEND1 290 KEND1 = KVAJKL + NVAJKL(1) 291 END IF 292C 293 IF (CCSDR12 .AND. (IANR12.EQ.2.OR.IANR12.EQ.3)) THEN 294 DO ISYM = 1, NSYM 295 NLAMDX(ISYM) = 0 296 NADP(ISYM) = 0 297 DO ISYM2 = 1, NSYM 298 ISYM1 = MULD2H(ISYM,ISYM2) 299 ILAMDX(ISYM1,ISYM2) = NLAMDX(ISYM) 300 NLAMDX(ISYM) = NLAMDX(ISYM) + 301 & (MBAS1(ISYM1)+MBAS2(ISYM1))*(NORB1(ISYM2)+NORB2(ISYM2)) 302 IADP(ISYM1,ISYM2) = NADP(ISYM) 303 NADP(ISYM) = NADP(ISYM) + 304 & NVIR(ISYM1)*(MBAS1(ISYM2)+MBAS2(ISYM2)) 305 END DO 306 END DO 307 308 KFCKVAO = KEND1 309 KEND1 = KFCKVAO + NEMAT1(1) 310 311 KE1PIM = KEND1 312 KEND1 = KE1PIM + NADP(1) 313 ELSE 314 KE1PIM = KEND1 315 END IF 316C 317 LWRK1 = LWORK - KEND1 318C 319 IF (LWRK1 .LT. 0) THEN 320 WRITE(LUPRI,*) 'Need : ',KEND1,'Available : ',LWORK 321 CALL QUIT('Insufficient space in CCRHSN') 322 ENDIF 323C 324C------------------------------------ 325C Save the CC amplitudes on disk. 326C------------------------------------ 327C 328 LURHS1 = -1 329 CALL GPOPEN(LURHS1,'CCRHS1','UNKNOWN',' ','UNFORMATTED',IDUMMY, 330 & .FALSE.) 331 REWIND(LURHS1) 332 WRITE (LURHS1) (T1AM(I), I = 1,NT1AMX) 333 WRITE (LURHS1) (T2AM(I), I = 1,NT2AMX) 334C 335C---------------------------------- 336C Calculate the lamda matrices. 337C---------------------------------- 338C 339 TIMLAM = SECOND() 340 CALL LAMMAT(WORK(KLAMDP),WORK(KLAMDH),T1AM,WORK(KEND1),LWRK1) 341 TIMLAM = SECOND() - TIMLAM 342C 343C----------------------------------------- 344C Calculate the inverse xlamdp matrix. 345C----------------------------------------- 346C 347 IF (.NOT. DUMPCD) 348 * CALL CCSD_INVLDP(WORK(KLAMDP),WORK(KLAMIP),WORK(KEND1),LWRK1) 349C 350C----------------------------------- 351C initialize R12 vector function 352C----------------------------------- 353 IF (CCR12) CALL DZERO(WORK(KVIJKL),NTR12SQ(1)) 354 IF (CCR12.AND..NOT.USEVABKL) THEN 355 IOPT = 2 356 CALL CC_R12MKVAMKL0(WORK(KVIJKL),NTR12SQ(1),IOPT,WORK(KLAMDH), 357 & 1,WORK(KEND1),LWRK1) 358 IF (RSPIM) THEN 359 IOPT = 1 360 CALL CC_R12MKVAMKL0(WORK(KVAJKL),NVAJKL(1),IOPT,WORK(KLAMDH), 361 & 1,WORK(KEND1),LWRK1) 362 END IF 363 END IF 364 IF (CCSDR12 .AND. (IANR12.EQ.2.OR.IANR12.EQ.3)) THEN 365 ! initialize the Fhat(a,del) matrix 366 CALL DZERO(WORK(KFCKVAO),NEMAT1(1)) 367 END IF 368C 369C------------------------------- 370C Prepare the t2-amplitudes. 371C------------------------------- 372C 373 CALL DCOPY(NT2AMX,T2AM,1,OMEGA2,1) 374 CALL CC_T2SQ(OMEGA2,T2AM,ISYMTR) 375C 376C----------------------------------------- 377C Construct the transposed amplitudes. 378C----------------------------------------- 379C 380 IF (CCSDT .OR. CCSDR12) THEN 381 KEND1T = KEND1 382 LWRK1T = LWRK1 383 ENDIF 384C 385 IF ((.NOT. DIRECT) .AND. T2TCOR) THEN 386C 387 KT2AMT = KEND1 388 KEND1 = KT2AMT + NT2SQ(1) 389 LWRK1 = LWORK - KEND1 390 IF (LWRK1 .LT. 0) THEN 391 CALL QUIT('Insufficient core in CCRHSN') 392 END IF 393C 394 JSYM = 1 395 CALL DCOPY(NT2SQ(1),T2AM,1,WORK(KT2AMT),1) 396 CALL CCSD_T2TP(WORK(KT2AMT),WORK(KEND1),LWRK1,JSYM) 397C 398 END IF 399C 400C------------------------------- 401C Initialize OMEGA1 & OMEGA2 402C------------------------------- 403C 404 CALL DZERO(OMEGA1,NT1AM(ISYMOP)) 405 IF (.NOT. OMEGSQ) THEN 406 IF (OMEGOR) THEN 407 CALL DZERO(OMEGA2,2*NT2ORT(ISYMOP)) 408 ELSE 409 CALL DZERO(OMEGA2,NT2AO(ISYMOP)) 410 ENDIF 411 ELSE 412 CALL DZERO(OMEGA2,NT2AOS(ISYMOP)) 413 ENDIF 414C 415C------------------------------------- 416C Initialize GAMMA, EMAT1 & EMAT2. 417C------------------------------------- 418C 419 IF (.NOT. NEWGAM) CALL DZERO(WORK(KGAMMA),NGAMMA(ISYMOP)) 420 CALL DZERO(WORK(KEMAT1),NEMAT1(ISYMOP)) 421 CALL DZERO(WORK(KEMAT2),NMATIJ(ISYMOP)) 422 IF (CCSDR12 .AND. (IANR12.EQ.2.OR.IANR12.EQ.3)) THEN 423 CALL DZERO(WORK(KE1PIM),NADP(1)) 424 END IF 425C 426C---------------------------------------- 427C Calculate the density matrix. 428C includes core contribution, ic = 1. 429C---------------------------------------- 430C 431 TIMDM = SECOND() 432 ISYMH = 1 433 IC = 1 434 CALL CC_AODENS(WORK(KLAMDP),WORK(KLAMDH),WORK(KDENSI),ISYMH, 435 * IC,WORK(KEND1),LWRK1) 436 TIMDM = SECOND() - TIMDM 437C 438C------------------------------------------------ 439C Read one-electron integrals in Fock-matrix. 440C------------------------------------------------ 441C 442 TIMFCK = SECOND() 443 CALL CCRHS_ONEAO(WORK(KFOCK),WORK(KEND1),LWRK1) 444 TIMFCK = SECOND() - TIMFCK 445C 446C------------------------------------------------ 447C Read one-electron integrals into Fock-matrix for 448C finite field. 449C------------------------------------------------ 450C 451 DO 13 IF = 1, NFIELD 452 DTIME = SECOND() 453 FF = EFIELD(IF) 454 CALL CC_ONEP(WORK(KFOCK),WORK(KEND1),LWRK1,FF,1,LFIELD(IF)) 455 DTIME = SECOND() - DTIME 456 TIMFCK = TIMFCK + DTIME 457 13 CONTINUE 458C 459C------------------------------------- 460C Solvent contribution. 461C Put into one-electron integrals. 462C SLV98,OC 463C------------------------------------- 464C 465 IF (CCSLV .AND. (.NOT. CCMM )) THEN 466 CALL CCSL_RHSTG(WORK(KFOCK),WORK(KEND1),LWRK1) 467 ENDIF 468C 469C------------------------------------- 470C Solvent contribution. 471C Put into one-electron integrals. 472C CCMM02,JA+AO 473C------------------------------------- 474C 475 IF (CCMM) THEN 476 IF (.NOT. NYQMMM) THEN 477 CALL CCMM_RHSTG(WORK(KFOCK),WORK(KEND1),LWRK1) 478 ELSE IF (NYQMMM) THEN 479 IF (HFFLD ) THEN 480 CALL CCMM_ADDGHF(WORK(KFOCK),WORK(KEND1),LWRK1) 481 ELSE 482 CALL CCMM_ADDG(WORK(KFOCK),WORK(KEND1),LWRK1) 483 END IF 484 END IF 485 ENDIF 486C 487 IF (USE_PELIB()) THEN 488 ALLOCATE(FOCKMAT(NNBASX),FOCKTEMP(N2BST(ISYMOP))) 489 IF (HFFLD) THEN 490 CALL GET_FROM_FILE('FOCKMHF',NNBASX,FOCKMAT) 491 ELSE 492 CALL GET_FROM_FILE('FOCKMAT',NNBASX,FOCKMAT) 493 END IF 494 CALL DSPTSI(NBAS,FOCKMAT,FOCKTEMP) 495 CALL DAXPY(N2BST(ISYMOP),1.0d0,FOCKTEMP,1,WORK(KFOCK),1) 496 DEALLOCATE(FOCKMAT,FOCKTEMP) 497 END IF 498C 499 IF (IPRINT .GT.15) THEN 500 CALL AROUND( 'Fock AO matrix after ff/slv/pe/mm contribution' ) 501 CALL CC_PRFCKAO(WORK(KFOCK),1) 502 ENDIF 503C 504C==================================================== 505C Start the loop over distributions of integrals. 506C==================================================== 507C 508 KENDS2 = KEND1 509 LWRKS2 = LWRK1 510C 511 IF (DIRECT) THEN 512 DTIME = SECOND() 513 IF (HERDIR) THEN 514 CALL HERDI1(WORK(KEND1),LWRK1,IPRERI) 515 ELSE 516 KCCFB1 = KEND1 517 KINDXB = KCCFB1 + MXPRIM*MXCONT 518 KEND1 = KINDXB + (8*MXSHEL*MXCONT + 1)/IRAT 519 LWRK1 = LWORK - KEND1 520 CALL ERIDI1(KODCL1,KODCL2,KODBC1,KODBC2,KRDBC1,KRDBC2, 521 & KODPP1,KODPP2,KRDPP1,KRDPP2, 522 & KFREE,LFREE,KEND1,WORK(KCCFB1),WORK(KINDXB), 523 & WORK(KEND1),LWRK1,IPRERI) 524 KEND1 = KFREE 525 LWRK1 = LFREE 526 ENDIF 527 DTIME = SECOND() - DTIME 528 TIMHER1 = TIMHER1 + DTIME 529 NTOSYM = 1 530 ELSE 531 NTOSYM = NSYM 532 ENDIF 533C 534 KENDSV = KEND1 535 LWRKSV = LWRK1 536C 537 ICDEL1 = 0 538 DO 100 ISYMD1 = 1,NTOSYM 539C 540 IF (DIRECT) THEN 541 IF (HERDIR) THEN 542 NTOT = MAXSHL 543 ELSE 544 NTOT = MXCALL 545 ENDIF 546 ELSE 547 NTOT = NBAS(ISYMD1) 548 ENDIF 549C 550 DO 110 ILLL = 1,NTOT 551C 552C----------------------------------------------------------------- 553C If direct calculate the integrals and transposed t2am. 554C----------------------------------------------------------------- 555C 556 IF (DIRECT) THEN 557C 558 KEND1 = KENDSV 559 LWRK1 = LWRKSV 560C 561 DTIME = SECOND() 562 IF (HERDIR) THEN 563 CALL HERDI2(WORK(KEND1),LWRK1,INDEXA,ILLL,NUMDIS, 564 & IPRERI) 565 ELSE 566 CALL ERIDI2(ILLL,INDEXA,NUMDIS,0,0, 567 & WORK(KODCL1),WORK(KODCL2), 568 & WORK(KODBC1),WORK(KODBC2), 569 & WORK(KRDBC1),WORK(KRDBC2), 570 & WORK(KODPP1),WORK(KODPP2), 571 & WORK(KRDPP1),WORK(KRDPP2), 572 & WORK(KCCFB1),WORK(KINDXB), 573 & WORK(KEND1), LWRK1,IPRERI) 574 ENDIF 575 DTIME = SECOND() - DTIME 576 TIMHER2 = TIMHER2 + DTIME 577C 578 KRECNR = KEND1 579 KEND1 = KRECNR + (NBUFX(0) - 1)/IRAT + 1 580 LWRK1 = LWORK - KEND1 581 IF (LWRK1 .LT. 0) THEN 582 CALL QUIT('Insufficient core in CCRHSN') 583 END IF 584C 585 IF (T2TCOR) THEN 586 KT2AMT = KEND1 587 KEND1 = KT2AMT + NT2SQ(1) 588 LWRK1 = LWORK - KEND1 589 IF (LWRK1 .LT. 0) THEN 590 CALL QUIT('Insufficient core in CCRHSN') 591 END IF 592C 593 JSYM = 1 594 CALL DCOPY(NT2SQ(1),T2AM,1,WORK(KT2AMT),1) 595 CALL CCSD_T2TP(WORK(KT2AMT),WORK(KEND1),LWRK1,JSYM) 596 END IF 597C 598 ELSE 599 NUMDIS = 1 600 KRECNR = KENDSV 601 ENDIF 602C 603C----------------------------------------------------- 604C Loop over number of distributions in disk. 605C----------------------------------------------------- 606C 607 DO 120 IDEL2 = 1,NUMDIS 608C 609 IF (DIRECT) THEN 610 IDEL = INDEXA(IDEL2) 611 IF (NOAUXB) THEN 612 IDUM = 1 613 CALL IJKAUX(IDEL,IDUM,IDUM,IDUM) 614 END IF 615 ISYMD = ISAO(IDEL) 616 ELSE 617 IDEL = IBAS(ISYMD1) + ILLL 618 ISYMD = ISYMD1 619 ENDIF 620C 621 ISYDIS = MULD2H(ISYMD,ISYMOP) 622C 623 IT2DEL(IDEL) = ICDEL1 624 ICDEL1 = ICDEL1 + NT2BCD(ISYDIS) 625C 626C------------------------------------------ 627C Work space allocation no. 2. 628C------------------------------------------ 629C 630 KXINT = KEND1 631 KEND2 = KXINT + NDISAO(ISYDIS) 632 LWRK2 = LWORK - KEND2 633C 634 IF (LWRK2 .LT. 0) THEN 635 WRITE(LUPRI,*) 'Need : ',KEND2,'Available : ',LWORK 636 CALL QUIT('Insufficient space in CCRHSN') 637 ENDIF 638C 639C 640C----------------------------------------- 641C Read in batch of integrals. 642C----------------------------------------- 643C 644 DTIME = SECOND() 645 CALL CCRDAO(WORK(KXINT),IDEL,IDEL2,WORK(KEND2),LWRK2, 646 * WORK(KRECNR),DIRECT) 647 DTIME = SECOND() - DTIME 648 TIMRDAO = TIMRDAO + DTIME 649C 650C----------------------------------------------------------- 651C Calculate transformed integrals used in t3am. 652C----------------------------------------------------------- 653C 654 IF (CCSDT .AND. ((.NOT. CC1B) .OR. (.NOT. CC1A))) THEN 655C 656 CALL CC3_T3INT(WORK(KXINT),WORK(KLAMDP),WORK(KLAMDH), 657 * T1AM,1,WORK(KEND2),LWRK2,IDEL,ISYMD,1, 658 * LU3SRT,FN3SRT,LUCKJD,FNCKJD) 659C 660 ENDIF 661C 662C------------------------------------------------------------------- 663C Calculate additional integrals needed for CCSD(R12)/2 664C------------------------------------------------------------------- 665C 666 IF (CCSDR12 .AND. (IANR12.EQ.2.OR.IANR12.EQ.3)) THEN 667 LENIAJ = NT2BCD(ISYDIS) 668 669 KXIADJ = KEND2 670 KXIJDA = KXIADJ + LENIAJ 671 KEND3 = KXIJDA + LENIAJ 672 LWRK3 = LWORK - KEND3 673 IF (LWRK3 .LT. 0) THEN 674 WRITE(LUPRI,*) 'Need : ',KEND3,'Available : ',LWORK 675 CALL QUIT('Insufficient space in CCRHSN') 676 ENDIF 677 678 CALL DZERO(WORK(KXIADJ),LENIAJ) 679 CALL DZERO(WORK(KXIJDA),LENIAJ) 680 681 DO ISYGAM = 1, NSYM 682 ISYALBE = MULD2H(ISYDIS,ISYGAM) 683 DO G = 1, NBAS(ISYGAM) 684 IGAM = G + IBAS(ISYGAM) 685 686 KOFFG = KXINT + IDSAOG(ISYGAM,ISYDIS) 687 & + NNBST(ISYALBE)*(G-1) 688 689 CALL CC_IAJB( WORK(KOFFG), ISYALBE, DUMMY, ISYM0, 690 & IDEL, IGAM, .FALSE., IDUMMY, 691 & DUMMY, WORK(KXIADJ), WORK(KXIJDA), 692 & DUMMY, DUMMY, DUMMY, 693 & WORK(KLAMDP), WORK(KLAMDH), ISYM0, 694 & DUMMY, DUMMY, ISYM0, 695 & WORK(KLAMDP), WORK(KLAMDH), ISYM0, 696 & DUMMY, DUMMY, ISYM0, 697 & WORK(KEND3), LWRK3, 3, 698 & .FALSE., .FALSE., .TRUE., 699 & .FALSE., .FALSE., 0 ) 700 END DO 701 END DO 702 703c ------------------------------------ 704c update Fhat_{del a}: 705c ------------------------------------ 706 D = IDEL - IBAS(ISYMD) 707 CALL CC_FCKDELA(D,ISYMD,WORK(KFCKVAO),ISYM0, 708 & WORK(KXIJDA),WORK(KXIADJ),IEMAT1) 709 710C ------------------------------------ 711C transform (ia|del j) to L(ia|del j): 712C ------------------------------------ 713 CALL DSCAL(LENIAJ, TWO,WORK(KXIADJ),1) 714 CALL DAXPY(LENIAJ,-ONE,WORK(KXIJDA),1, 715 * WORK(KXIADJ),1) 716 717C -------------------------------------------- 718C write 3-index transformed integrals to disk: 719C -------------------------------------------- 720 IADR = IT2DEL(IDEL) + 1 721 CALL PUTWA2(LUIADJ,FNIADJ,WORK(KXIADJ),IADR,LENIAJ) 722 CALL PUTWA2(LUIJDA,FNIJDA,WORK(KXIJDA),IADR,LENIAJ) 723 724 END IF 725C 726C------------------------------------------- 727C Calculate the AO-Fock matrix. 728C------------------------------------------- 729C 730 DTIME = SECOND() 731C 732 ISYDEN = 1 733 CALL CC_AOFOCK(WORK(KXINT),WORK(KDENSI),WORK(KFOCK), 734 * WORK(KEND2),LWRK2,IDEL,ISYMD,.FALSE., 735 * DUMMY,ISYDEN) 736 DTIME = SECOND() - DTIME 737 TIMFCK = TIMFCK + DTIME 738C 739C------------------------------------------ 740C Work space allocation no. 3. 741C------------------------------------------ 742C 743 KSCRM = KEND2 744 KEND3 = KSCRM + NT2BCD(ISYMD) 745 LWRK3 = LWORK - KEND3 746C 747 IF (LWRK3 .LT. 0) THEN 748 WRITE(LUPRI,*) 'Need : ',KEND3,'Available : ',LWORK 749 CALL QUIT('Insufficient space in CCRHSN') 750 ENDIF 751C 752C---------------------------------------------------------------- 753C Construct the partially transformed T2-amplitudes. 754C---------------------------------------------------------------- 755C 756 DTIME = SECOND() 757 ICON = 1 758 ISYMLH = 1 759 CALL CC_T2AO(T2AM,WORK(KLAMDH),ISYMLH,WORK(KSCRM), 760 * WORK(KEND3),LWRK3,IDEL,ISYMD, 761 * ISYMTR,ICON) 762 DTIME = SECOND() - DTIME 763 TIMT2AO = TIMT2AO + DTIME 764C 765C----------------------------------- 766C Calculate the F-term. 767C----------------------------------- 768C 769 DTIME = SECOND() 770 IF (.NOT. OMEGOR) THEN 771 CALL CCRHS_F(WORK(KXINT),OMEGA2,WORK(KLAMDH), 772 * WORK(KEND3),LWRK3,IDEL,ISYMD) 773 ENDIF 774 DTIME = SECOND() - DTIME 775 TIMF = TIMF + DTIME 776C 777C------------------------------------------------------- 778C Calculate the F-term in MO basis for CC2. 779C------------------------------------------------------- 780C 781 IF ( CC2 ) THEN 782 DTIME = SECOND() - TIMFP 783 IOPT = 1 784 CALL GETTIM(T0,W0) 785 LVIJKL = .NOT.USEVABKL .AND. CC2R12 786 LVAJKL = LVIJKL .AND. RSPIM 787 CALL CC_MOFCON(WORK(KXINT),OMEGA2, 788 * WORK(KLAMDP),WORK(KLAMDH), 789 * WORK(KLAMDP),WORK(KLAMDH), 790 * WORK(KEND3),LWRK3,IDEL, 791 * ISYMD,ISYMTR,IOPT, 792 * WORK(KVIJKL),LVIJKL,IANR12, 793 * WORK(KVAJKL),LVAJKL,TIMFP) 794 CALL GETTIM(T1,W1) 795 TIMMOFCPU = T1-T0 796 TIMMOFWAL = W1-W0 797 DTIME = (SECOND() - TIMFP) - DTIME 798 TIMF = TIMF + DTIME 799 ENDIF 800C 801C----------------------------------- 802C Calculate the B-term. 803C----------------------------------- 804C 805 DTIME = SECOND() 806 IF ((.NOT. OMEGOR) .AND. (.NOT. CC2)) THEN 807 CALL CCRHS_B(WORK(KXINT),OMEGA2,WORK(KLAMDP), 808 * WORK(KLAMDH),WORK(KSCRM),WORK(KEND3), 809 * LWRK3,IDEL,ISYMD) 810 ENDIF 811 DTIME = SECOND() - DTIME 812 TIMB = TIMB + DTIME 813C 814C------------------------------------------ 815C Calculate the B and F terms. 816C------------------------------------------ 817C 818 DTIME = SECOND() 819 IF (OMEGOR .AND. ( .NOT. CC2) ) THEN 820 IOPT = 1 821 CALL CC_BF(WORK(KXINT),OMEGA2,WORK(KLAMDH),1, 822 * WORK(KLAMDH),1,WORK(KLAMDH),1, 823 * WORK(KSCRM),ISYMD,DUMMY,ISYMD, 824 * WORK(KEND3),LWRK3,IDEL,ISYMD,IOPT) 825 ENDIF 826 DTIME = SECOND() - DTIME 827 TIMBF = TIMBF + DTIME 828C 829C------------------------------------------ 830C Work space allocation no. 4. 831C------------------------------------------ 832C 833 KDSRHF = KEND3 834 KEND4 = KDSRHF + NDSRHF(ISYMD) 835 LWRK4 = LWORK - KEND4 836C 837 IF (LWRK4 .LT. 0) THEN 838 WRITE(LUPRI,*) 'Need : ',KEND4,'Available : ',LWORK 839 CALL QUIT('Insufficient space in CCRHSN') 840 ENDIF 841C 842C-------------------------------------------------------- 843C Transform one index in the integral batch. 844C-------------------------------------------------------- 845C 846 DTIME = SECOND() 847 ISYMLP = 1 848 CALL CCTRBT(WORK(KXINT),WORK(KDSRHF),WORK(KLAMDP), 849 * ISYMLP,WORK(KEND4),LWRK4,ISYDIS) 850 DTIME = SECOND() - DTIME 851 TIMTRBT = TIMTRBT + DTIME 852C 853C------------------------------------------------------------- 854C Calculate the gamma matrix entering the A-term. 855C------------------------------------------------------------- 856C 857 DTIME = SECOND() 858 IF ((.NOT. CC2) .AND. (.NOT. NEWGAM)) THEN 859 CALL CCRHS_GAM(WORK(KDSRHF),WORK(KGAMMA),WORK(KLAMDP), 860 * WORK(KLAMDH),WORK(KSCRM),WORK(KEND4), 861 * LWRK4,IDEL,ISYMD) 862 ENDIF 863 DTIME = SECOND() - DTIME 864 TIMGAM = TIMGAM + DTIME 865C 866C----------------------------------- 867C Calculate the C-term. 868C----------------------------------- 869C 870 DTIME = SECOND() 871C 872 IF ( RSPIM ) THEN 873 FACTC = XMONE 874 ELSE 875 FACTC = XMHALF 876 ENDIF 877C 878 ICON = 2 879 IV = 1 880C 881 IF (CCSDR12 .AND. (IANR12.EQ.2 .OR.IANR12.EQ.3)) THEN 882 IOPTR12 = 1 883 IOPTE = 1 884 ELSE 885 IOPTR12 = 0 886 IOPTE = 0 887 END IF 888C 889 IF (.NOT. T2TCOR) THEN 890 CALL CCRHS_C(WORK(KXINT),WORK(KDSRHF),OMEGA2, 891 * T2AM,ISYMOP,WORK(KLAMDP),WORK(KLAMIP), 892 * WORK(KLAMDH),WORK(KLAMDP),ISYMTR, 893 * WORK(KLAMDP),ISYMTR, 894 * WORK(KSCRM),WORK(KE1PIM),WORK(KEND4), 895 * LWRK4,IDEL,ISYMD,FACTC,ICON,IOPTR12, 896 * IOPTE,LUC,CFIL,LUCP,CPFIL,IV) 897 ELSE 898 CALL CCRHS_C(WORK(KXINT),WORK(KDSRHF),OMEGA2, 899 * WORK(KT2AMT),ISYMOP, 900 * WORK(KLAMDP),WORK(KLAMIP), 901 * WORK(KLAMDH),WORK(KLAMDP),ISYMTR, 902 * WORK(KLAMDP),ISYMTR, 903 * WORK(KSCRM),WORK(KE1PIM),WORK(KEND4), 904 * LWRK4,IDEL,ISYMD,FACTC,ICON,IOPTR12, 905 * IOPTE,LUC,CFIL,LUCP,CPFIL,IV) 906 END IF 907CTesT 908C WRITE(LUPRI,*) 'E1PIM after CCRHS_C:' 909C WRITE(LUPRI,*) 'Norm^2: ', 910C & DDOT(NADP(1),WORK(KE1PIM),1,WORK(KE1PIM),1) 911C DO ISYM = 1,NSYM 912C CALL OUTPUT(WORK(KE1PIM+IADP(ISYM,ISYM)), 913C & 1,NVIR(ISYM),1,MBAS1(ISYM)+MBAS2(ISYM), 914C & NVIR(ISYM),MBAS1(ISYM)+MBAS2(ISYM), 915C & 1, LUPRI) 916C END DO 917C CALL FLSHFO(LUPRI) 918CTesT 919C 920 DTIME = SECOND() - DTIME 921 TIMC = TIMC + DTIME 922C 923C--------------------------------------- 924C Transform T2 to 2T2 - T2. 925C--------------------------------------- 926C 927 DTIME = SECOND() 928 IF (T2TCOR) THEN 929 CALL DSCAL(NT2SQ(1),TWO,T2AM,1) 930 CALL DAXPY(NT2SQ(1),-ONE,WORK(KT2AMT),1,T2AM,1) 931 ELSE 932 ISYM = 1 933 CALL CCRHS_T2TR(T2AM,WORK(KEND4),LWRK4,ISYM) 934 END IF 935 DTIME = SECOND() - DTIME 936 TIMT2TR = TIMT2TR + DTIME 937C 938C----------------------------------------------- 939C Transform the cluster amplitudes. 940C----------------------------------------------- 941C 942 CALL CC_MTCME(WORK(KSCRM),WORK(KEND4),LWRK4, 943 * ISYMD,ISYMTR) 944C 945C----------------------------------- 946C Calculate the D-term. 947C----------------------------------- 948C 949 DTIME = SECOND() 950C 951 IF ( RSPIM ) THEN 952 FACTD = ONE 953 ELSE 954 FACTD = HALF 955 ENDIF 956C 957 ICON = 2 958 IV = 1 959C 960 IF (CCSDR12 .AND. (IANR12.EQ.2 .OR. IANR12.EQ.3)) THEN 961 IOPTR12 = 1 962 IOPTE = 1 963 ELSE 964 IOPTR12 = 0 965 IOPTE = 0 966 END IF 967C 968 IF ( .NOT. CC2) THEN 969 CALL CCRHS_D(WORK(KXINT),WORK(KDSRHF),OMEGA2,T2AM, 970 * ISYMTR,WORK(KLAMDP),WORK(KLAMIP), 971 * WORK(KLAMDH),WORK(KLAMDP),ISYMTR, 972 * WORK(KLAMDH),ISYMTR, 973 * WORK(KSCRM),WORK(KE1PIM),WORK(KEND4), 974 * LWRK4,IDEL,ISYMD,FACTD,ICON,IOPTR12, 975 * IOPTE,LUD,DFIL,LUDP,DPFIL,IV) 976 ENDIF 977CTesT 978C WRITE(LUPRI,*) 'E1PIM after CCRHS_D:' 979C WRITE(LUPRI,*) 'Norm^2: ', 980C & DDOT(NADP(1),WORK(KE1PIM),1,WORK(KE1PIM),1) 981C DO ISYM = 1,NSYM 982C CALL OUTPUT(WORK(KE1PIM+IADP(ISYM,ISYM)), 983C & 1,NVIR(ISYM),1,MBAS1(ISYM)+MBAS2(ISYM), 984C & NVIR(ISYM),MBAS1(ISYM)+MBAS2(ISYM), 985C & 1, LUPRI) 986C END DO 987C CALL FLSHFO(LUPRI) 988CTesT 989C 990 DTIME = SECOND() - DTIME 991 TIMD = TIMD + DTIME 992C 993C---------------------------------------- 994C Calculate E-intermediates. 995C---------------------------------------- 996C 997 DTIME = SECOND() 998 IF ((.NOT. CC2) .OR. RSPIM) THEN 999 CALL CCRHS_EI(WORK(KDSRHF),WORK(KEMAT1),WORK(KEMAT2), 1000 * T2AM,WORK(KSCRM),WORK(KLAMDP), 1001 * WORK(KLAMDH),WORK(KEND4),LWRK4, 1002 * IDEL,ISYMD,ISYDIS,ISYMTR) 1003 ENDIF 1004 DTIME = SECOND() - DTIME 1005 TIMEI = TIMEI + DTIME 1006C 1007C----------------------------------- 1008C Calculate the G-term. 1009C----------------------------------- 1010C 1011 DTIME = SECOND() 1012 ISYMP1 = 1 1013 ISYMH1 = 1 1014 CALL CCRHS_G(WORK(KDSRHF),OMEGA1,WORK(KLAMDP),ISYMP1, 1015 * WORK(KLAMDH),ISYMH1,WORK(KSCRM),WORK(KEND4), 1016 * LWRK4,ISYDIS,ISYMD,ISYMTR) 1017 DTIME = SECOND() - DTIME 1018 TIMG = TIMG + DTIME 1019C 1020C----------------------------------- 1021C Calculate the H-term. 1022C----------------------------------- 1023C 1024 DTIME = SECOND() 1025 CALL CCRHS_H(WORK(KDSRHF),OMEGA1,WORK(KLAMDP), 1026 * WORK(KLAMDH),WORK(KSCRM),WORK(KEND4), 1027 * LWRK4,ISYDIS,ISYMD,ISYMTR) 1028 DTIME = SECOND() - DTIME 1029 TIMH = TIMH + DTIME 1030C 1031C--------------------------------------------- 1032C BackTransform T2 from 2T2 - T2. 1033C--------------------------------------------- 1034C 1035 DTIME = SECOND() 1036 IF (T2TCOR) THEN 1037 CALL DAXPY(NT2SQ(1),ONE,WORK(KT2AMT),1,T2AM,1) 1038 CALL DSCAL(NT2SQ(1),HALF,T2AM,1) 1039 ELSE 1040 ISYM = 1 1041 CALL CCRHS_T2BT(T2AM,WORK(KEND4),LWRK4,ISYM) 1042 END IF 1043 DTIME = SECOND() - DTIME 1044 TIMT2BT = TIMT2BT + DTIME 1045C 1046 120 CONTINUE 1047 110 CONTINUE 1048 100 CONTINUE 1049C 1050C ------------------------------------------------------------------ 1051C save the special fock matrix computed for CCSD(R12) ansaetze 2/3 1052C ------------------------------------------------------------------ 1053 IF (CCSDR12 .AND. (IANR12.EQ.2 .OR. IANR12.EQ.3)) THEN 1054 LUFHATAD = -1 1055 CALL GPOPEN(LUFHATAD,'CCFHATADEL','UNKNOWN',' ','UNFORMATTED', 1056 & IDUMMY,.FALSE.) 1057 REWIND(LUFHATAD) 1058 WRITE(LUFHATAD) (WORK(KFCKVAO-1+I),I=1,NEMAT1(1)) 1059 CALL GPCLOSE(LUFHATAD,'KEEP') 1060 END IF 1061C 1062C ------------------------------------------------------------------ 1063C for CCSD(R12) ansaetze 2/3 do here the C, D, and E terms requiring 1064C the calculation of integrals with delta from the auxiliary basis 1065C ------------------------------------------------------------------ 1066C 1067 IF (CCSDR12 .AND. (IANR12.EQ.2 .OR. IANR12.EQ.3)) THEN 1068 CALL CCSDR12AO(CCSDR12, 1069 & T2AM,WORK(KLAMDP),WORK(KLAMDH), 1070 & FNIADJ,LUIADJ,FNIJDA,LUIJDA, 1071 & CPFIL,LUCP,DPFIL,LUDP,WORK(KE1PIM), 1072 & TIMINTR12,TIMRDAOR12,TIMTRBT, 1073 & TIMC,TIMD,TIMT2TR,TIMT2BT, 1074 & WORK(KEND1T),LWRK1T) 1075 END IF 1076CTesT 1077C WRITE(LUPRI,*) 'E1PIM after CCSDR12AO:' 1078C WRITE(LUPRI,*) 'Norm^2: ', 1079C & DDOT(NADP(1),WORK(KE1PIM),1,WORK(KE1PIM),1) 1080C DO ISYM = 1,NSYM 1081C CALL OUTPUT(WORK(KE1PIM+IADP(ISYM,ISYM)), 1082C & 1,NVIR(ISYM),1,MBAS1(ISYM)+MBAS2(ISYM), 1083C & NVIR(ISYM),MBAS1(ISYM)+MBAS2(ISYM), 1084C & 1, LUPRI) 1085C END DO 1086C CALL FLSHFO(LUPRI) 1087CTesT 1088C 1089C------------------------ 1090C Recover work space. 1091C------------------------ 1092C 1093 IF (CCSDT) THEN 1094 KEND1 = KEND1T 1095 LWRK1 = LWRK1T 1096 ELSE 1097 KEND1 = KENDS2 1098 LWRK1 = LWRKS2 1099 ENDIF 1100C 1101 IF (IPRINT .GT. 120) THEN 1102 CALL AROUND('After Delta Loop: Omega1') 1103 CALL CC_PRP(OMEGA1,OMEGA2,1,1,0) 1104 ENDIF 1105C 1106C ---------------------------------------------------------------- 1107C for CC2-R12 ansatz 3 add (ai|bj)-hat x (ka|r12|lb) to V intermediate 1108C (Note: this requires that omega2 contains the integral 1109C (ai|bj)-hat in packed triangular storage) 1110C ---------------------------------------------------------------- 1111C 1112 IF (CC2 .AND. CCR12 .AND. IANR12.EQ.3) THEN 1113 ! get R12 integrals 1114 lunit = -1 1115 call gpopen(lunit,fr12r12,'unknown',' ','unformatted', 1116 & idum,.false.) 1117 read(lunit)(t2am(i),i=1,nt2r12(1)) 1118 call gpclose(lunit,'KEEP') 1119 1120 CALL CC_R12MI2(WORK(KVIJKL),T2AM,OMEGA2,1,1,-1.0d0, 1121 & WORK(KEND1),LWRK1) 1122 1123 ! restore amplitudes stored as full square matrix 1124 IF (LWRK1.LT.NT2AMX) CALL QUIT('Out of memory in CCRHSN') 1125 REWIND (LURHS1) 1126 READ (LURHS1) 1127 READ (LURHS1) (WORK(KEND1+I-1), I = 1,NT2AMX) 1128 CALL CC_T2SQ(WORK(KEND1),T2AM,1) 1129 END IF 1130C 1131C--------------------------------------------------------------------- 1132C for CC2 and NONHF=.true. calculate Fock matrix entering E-terms: 1133C the SCF Fock matrix is in principle given by the SCF orbital 1134C energies, but in recomputing it here from the SCF AO-Fock 1135C matrix computed in CCSD_IAJB allows to do finite difference 1136C on the vector function with respect to the CMO vector 1137C (see CC_FDXI & CC_FDETA). Note the SCF AO-Fock matrix read 1138C from file includes the `relaxed' external fields, so we 1139C only have to add the unrelaxed fields. 1140C--------------------------------------------------------------------- 1141C 1142 DTIME = SECOND() 1143 IF ((CC2 .OR. CCR12) .AND. NONHF) THEN 1144 KFIELD = KEND1 1145 KEND2 = KFIELD + N2BAST 1146 IF (CC2) THEN 1147 KCMO = KEND2 1148 KEND2 = KCMO + MAX(NLAMDT,NLAMDS) 1149 END IF 1150 IF (CCR12) THEN 1151 if (isymop.ne.1) call quit('Symmetry problem in CCSD_RHS') 1152 kvxintsq = kend2 1153 kxint = kvxintsq + nr12r12sq(isymop) 1154 kxintsq = kxint + nr12r12p(1) 1155 ktr12 = kxintsq + nr12r12sq(1) 1156 ktr12sq = ktr12 + ntr12am(1) 1157 kxir12 = ktr12sq + ntr12sq(1) 1158 kend2 = kxir12 + ntr12sq(1) 1159 END IF 1160 LWRK2 = LWORK - KEND2 1161 IF (LWRK2 .LT. 0) THEN 1162 CALL QUIT('Insufficient memory in CCRHSN.') 1163 END IF 1164 1165 CALL DZERO(WORK(KFIELD),N2BAST) 1166 IF (CCR12) THEN 1167 CALL DZERO(WORK(KVXINTSQ),NR12R12SQ(1)) 1168 END IF 1169 DO IF = 1, NFIELD 1170 IF ( NHFFIELD(IF) ) THEN 1171 DTIME = SECOND() 1172 CALL CC_ONEP(WORK(KFIELD),WORK(KEND2),LWRK2,EFIELD(IF),1, 1173 * LFIELD(IF)) 1174 TIMFCKMO = TIMFCKMO + SECOND() - DTIME 1175 IF (CCR12) THEN 1176 DTIME = SECOND() 1177 CALL CC_R12RDVXINT(WORK(KVXINTSQ),WORK(KEND2),LWRK2, 1178 & EFIELD(IF),1, LFIELD(IF)) 1179 TIMEP = TIMEP + SECOND() - DTIME 1180 END IF 1181 ELSE IF (.NOT. NHFFIELD(IF) .AND. CCR12) THEN 1182 CALL QUIT('CCR12 response can only handle unrelaxed '// 1183 & 'orbitals (w.r.t. the perturbation)') 1184 END IF 1185 END DO 1186 1187 IF (CCR12) THEN 1188 DTIME = SECOND() 1189 ! read R12 amplitudes and reorder to full square 1190 iopt=32 1191 call cc_rdrsp('R0 ',0,1,iopt,model,dummy,work(ktr12)) 1192 iopt = 1 1193 call ccr12unpck2(work(ktr12),1,work(ktr12sq),'N',iopt) 1194 1195 ! read R12 overlap matrix and reorder to full square 1196 lunit = -1 1197 call gpopen(lunit,fccr12x,'old',' ','unformatted',idummy, 1198 & .false.) 1199 rewind(lunit) 1200 8888 read(lunit) ian 1201 read(lunit) (work(kxint-1+i), i=1, nr12r12p(1)) 1202 if (ian.ne.ianr12) goto 8888 1203 call gpclose(lunit,'KEEP') 1204 iopt = 2 1205 call ccr12unpck2(work(kxint),1,work(kxintsq),'N',iopt) 1206 1207 ! calculate R12 response contribution to Omega_{kilj}: 1208 CALL CC_R12XI(work(kxir12),1,'T',work(ktr12sq),1, 1209 & work(kxintsq),work(kvxintsq),1,work(kfield), 1210 & work(klamdp),work(klamdh),'N',work(kend2), 1211 & lwrk2) 1212 1213C ! transpose Xi: in Xi the r12-pair index (kl) is leading, 1214C ! in Vijkl the occ. index pair (ij) is leading!!! 1215C call cclr_trsqr12(work(kxir12),1) 1216 1217 ! add it to Omega_FP term = VIJKL 1218 call daxpy(ntr12sq(1),one,work(kxir12),1,work(kvijkl),1) 1219 1220 TIMEP = TIMEP + SECOND() - DTIME 1221 END IF 1222 1223 IF (CC2) THEN 1224 DTIME = SECOND() 1225 LUSIFC = -1 1226 CALL GPOPEN(LUSIFC,'SIRIFC','OLD',' ','UNFORMATTED', 1227 * IDUMMY,.FALSE.) 1228 REWIND(LUSIFC) 1229 CALL MOLLAB('TRCCINT ',LUSIFC,LUPRI) 1230 READ(LUSIFC) 1231 READ(LUSIFC) 1232 READ(LUSIFC) (WORK(KCMO+I-1),I=1,NLAMDS) 1233 CALL GPCLOSE(LUSIFC,'KEEP') 1234 1235 CALL CMO_REORDER(WORK(KCMO),WORK(KEND2),LWRK2) 1236 1237 LUFCK = -1 1238 CALL GPOPEN(LUFCK,'CC_FCKREF','UNKNOWN',' ','UNFORMATTED', 1239 * IDUMMY,.FALSE.) 1240 REWIND(LUFCK) 1241 READ(LUFCK)(WORK(KFCKHF + I-1),I = 1,N2BST(ISYMOP)) 1242 CALL GPCLOSE(LUFCK,'KEEP' ) 1243 1244 ! SCF Fock matrix in transformed using CMO vector 1245 CALL CC_FCKMO(WORK(KFCKHF),WORK(KCMO),WORK(KCMO), 1246 * WORK(KEND2),LWRK2,1,1,1) 1247C 1248C------------------------------------- 1249C Solvent contribution. 1250C Put into one-electron integrals. 1251C SLV98,OC 1252C------------------------------------- 1253C 1254 IF (CCSLV .AND. (.NOT. CCMM )) THEN 1255 CALL CCSL_RHSTG(WORK(KFIELD),WORK(KEND2),LWRK2) 1256 ENDIF 1257C 1258C------------------------------------- 1259C Solvent contribution. 1260C Put into one-electron integrals. 1261C CCMM02,JA+AO 1262C------------------------------------- 1263C 1264 IF (CCMM) THEN 1265 IF (.NOT. NYQMMM) THEN 1266 CALL CCMM_RHSTG(WORK(KFIELD),WORK(KEND2),LWRK2) 1267 ELSE IF (NYQMMM) THEN 1268 IF ( HFFLD ) THEN 1269 CALL CCMM_ADDGHF(WORK(KFIELD),WORK(KEND2),LWRK2) 1270 ELSE 1271 CALL CCMM_ADDG(WORK(KFIELD),WORK(KEND2),LWRK2) 1272 END IF 1273 END IF 1274 ENDIF 1275C 1276 IF (USE_PELIB()) THEN 1277 ALLOCATE(FOCKMAT(NNBASX),FOCKTEMP(N2BAST)) 1278 IF (HFFLD) THEN 1279 CALL GET_FROM_FILE('FOCKMHF',NNBASX,FOCKMAT) 1280 ELSE 1281 CALL GET_FROM_FILE('FOCKMAT',NNBASX,FOCKMAT) 1282 END IF 1283 CALL DSPTSI(NBAS,FOCKMAT,FOCKTEMP) 1284 CALL DAXPY(N2BAST,1.0d0,FOCKTEMP,1,WORK(KFIELD),1) 1285 DEALLOCATE(FOCKMAT,FOCKTEMP) 1286 END IF 1287C 1288C---------------------------------- 1289C 1290 ! unrelaxed fields are transformed using the Lambda matrices 1291 CALL CC_FCKMO(WORK(KFIELD),WORK(KLAMDP),WORK(KLAMDH), 1292 * WORK(KEND2),LWRK2,1,1,1) 1293 1294 CALL DAXPY(N2BAST,ONE,WORK(KFIELD),1,WORK(KFCKHF),1) 1295 TIMFCKMO = TIMFCKMO + SECOND() - DTIME 1296 END IF 1297 1298 END IF 1299 1300C 1301C------------------------------------------------------------------ 1302C for CCSD(R12) add the R12 contribution to the BF intermediate 1303C which at this place is (still) stored in OMEGA2: 1304C------------------------------------------------------------------ 1305 IF (CCSDR12) THEN 1306 TIMR12CPU = 0.0d0 1307 TIMR12WAL = 0.0d0 1308 CALL GETTIM(T0,W0) 1309c 1310 IOPT = 0 1311 IAMP = 0 1312 CALL CCRHS_BP(OMEGA2,1,IOPT,IAMP,DUMMY,IDUMMY,IDUMMY,DUMMY, 1313 & IDUMMY,DUMMY,WORK(KEND1),LWRK1) 1314c 1315 CALL GETTIM(T1,W1) 1316 IF (IPRINT .GT. 9) THEN 1317 WRITE(LUPRI,*)'Time used for CCRHS_BP cpu:', T1-T0 1318 WRITE(LUPRI,*)'Time used for CCRHS_BP wall:', W1-W0 1319 END IF 1320 TIMR12CPU = TIMR12CPU + (T1-T0) 1321 TIMR12WAL = TIMR12WAL + (W1-W0) 1322 END IF 1323C 1324C------------------------------------------------- 1325C for CC-R12: 1326C------------------------------------------------- 1327C 1328 IF (CCR12) THEN 1329 TIMR12CPU = 0.0d0 1330 TIMR12WAL = 0.0d0 1331 CALL GETTIM(T0,W0) 1332 IF (.NOT.USEVABKL) THEN 1333 LVIJKL = .TRUE. 1334 LVAJKL = RSPIM 1335 LVABKL = .FALSE. 1336 IOPTBAS = 1 1337 IF (R12CBS .AND. (IANR12.NE.1)) IOPTBAS = 2 1338 FACTERM23 = TWO 1339 CALL CC_MOFCONR12(WORK(KLAMDH),1,WORK(KLAMDHS), 1340 & WORK(KLAMDPS),WORK(KLAMDHS),ISYMTR, 1341 & WORK(KVIJKL),FACTERM23,WORK(KVAJKL),IDUMMY, 1342 & LVIJKL,LVAJKL,LVABKL,IOPTBAS, 1343 & TIMRDAOR12,TIMFP,TIMINTR12, 1344 & IGLMRHS,NGLMDS,IMAIJM,NMAIJM, 1345 & IMAKLM,NMAKLM,WORK(KEND1),LWRK1) 1346C 1347C write V(alpha jtilde,kl) to disk 1348C 1349 IF (RSPIM) THEN 1350 IF (IANR12.EQ.2.OR.IANR12.EQ.3) THEN 1351C calculate contributions for ansatz 2 1352 ISYMH = ISYMTR 1353 ISYMV = 1 1354 CALL CC_R12MKVAJ2(WORK(KVAJKL),ISYMV,WORK(KLAMDH),ISYMH, 1355 & WORK(KLAMDHS),ISYMH,WORK(KEND1),LWRK1) 1356 END IF 1357C WRITE(LUPRI,*)'write Vajtkl on disk' 1358 LUVAJTKL = -1 1359 CALL GPOPEN(LUVAJTKl,FVAJTKL,'UNKNOWN',' ','UNFORMATTED', 1360 & IDUMMY,.FALSE.) 1361 REWIND(LUVAJTKL) 1362 WRITE(LUVAJTKL) (WORK(KVAJKL+I-1), I = 1,NVAJKL(1)) 1363 CALL GPCLOSE(LUVAJTKL,'KEEP') 1364 END IF 1365 ELSE 1366 KVABKL = KEND1 1367 KVAJKL = KVABKL + NVABKL(1) 1368 KEND2 = KVAJKL + NVAJKL(1) 1369 LWRK2 = LWORK - KEND2 1370 IF (LWRK2.LT.0) THEN 1371 CALL QUIT('Insufficient work space in ccrhsn') 1372 END IF 1373 ISYMC = 1 1374 LV = .TRUE. 1375 LVIJKL = .TRUE. 1376 LVAJKL = RSPIM 1377c 1378 CALL CC_R12MKVTF(WORK(KVABKL),WORK(KVAJKL),WORK(KVIJKL), 1379 & WORK(KLAMDH),ISYMC, 1380 & LV,LVIJKL,LVAJKL,FVAJTKL,WORK(KEND2),LWRK2) 1381c 1382 END IF 1383 CALL GETTIM(T1,W1) 1384 IF (IPRINT .GT. 9) THEN 1385 WRITE(LUPRI,*)'Time used for F''-term cpu:', T1-T0 1386 WRITE(LUPRI,*)'Time used for F''-term wall:',W1-W0 1387 END IF 1388 TIMR12CPU = TIMR12CPU + (T1-T0) 1389 TIMR12WAL = TIMR12WAL + (W1-W0) 1390 CALL GETTIM(T1,W1) 1391 TIMMOFR12CPU = T1-T0 1392 TIMMOFR12WAL = W1-W0 1393C 1394C------------------------------------------------- 1395C for CC2-R12: 1396C------------------------------------------------- 1397C 1398 IF (CC2) THEN 1399 IF (IANR12.EQ.2 .OR. IANR12.EQ.3) THEN 1400 ISYMV = 1 1401 ISYMH = 1 1402 CALL GETTIM(T0,W0) 1403 CALL CC_R12INTF2(WORK(KVIJKL),WORK(KLAMDH),ISYMH, 1404 & WORK(KLAMDHS),ISYMV,WORK(KLAMDHS),ISYMH, 1405 & WORK(KEND1),LWRK1) 1406 CALL GETTIM(T1,W1) 1407 TIMINTF2CPU = T1-T0 1408 TIMINTF2WAL = W1-W0 1409 TIMR12CPU = TIMR12CPU + (T1-T0) 1410 TIMR12WAL = TIMR12WAL + (W1-W0) 1411 END IF 1412 1413 IF ((IANR12.EQ.2.OR.IANR12.EQ.3).AND.DEBUGV) THEN 1414c symmetrize Vijkl 1415 ISYMV = 1 1416 KVSYM = KEND1 1417 KEND1 = KVSYM + NTR12SQ(1) 1418 CALL SYMV(WORK(KVIJKL),ISYMV,WORK(KVSYM), 1419 & NRHF,IMATIJ,ITR12SQT,NMATIJ,WORK(KEND1),LWRK1) 1420 1421c write V^ij_kl on file to calculate later numerically V bar 1422 LUVIJKL = -1 1423 CALL GPOPEN(LUVIJKL,FVIJKL,'UNKNOWN',' ','UNFORMATTED', 1424 & IDUMMY,.FALSE.) 1425 WRITE(LUVIJKL)(WORK(KVSYM-1+I),I=1,NTR12SQ(1)) 1426 CALL GPCLOSE(LUVIJKL,'KEEP') 1427 WRITE(LUPRI,*)'VIJKL WRITTEN ON FILE' 1428 1429 DO ISYMIJ = 1, NSYM 1430 ISYMKL = MULD2H(ISYMIJ,ISYMTR) 1431 WRITE(LUPRI,*) 'ISYMIJ,ISYMKL:',ISYMIJ,ISYMKL 1432 CALL OUTPUT(WORK(KVSYM+ITR12SQT(ISYMIJ,ISYMKL)),1, 1433 & NMATIJ(ISYMIJ),1,NMATKL(ISYMKL),NMATIJ(ISYMIJ), 1434 & NMATKL(ISYMKL),1,LUPRI) 1435 END DO 1436 END IF 1437 END IF 1438C 1439 IF (IANR12.EQ.2 .OR. IANR12.EQ.3) THEN 1440 LRES = .FALSE. 1441 CALL GETTIM(T0,W0) 1442 CALL CCRHS_EPP(WORK(KVIJKL),T2AM,1,WORK(KEND1),LWRK1, 1443 & APROXR12,LRES,IDUMMY,CDUMMY,IDUMMY) 1444 CALL GETTIM(T1,W1) 1445 TIMEPPCPU = T1-T0 1446 TIMEPPWAL = W1-W0 1447 TIMR12CPU = TIMR12CPU + (T1-T0) 1448 TIMR12WAL = TIMR12WAL + (W1-W0) 1449c 1450 CALL GETTIM(T0,W0) 1451 IOPTE = 0 1452 CALL CCRHS_HP(OMEGA1,WORK(KLAMDH),ISYMH,WORK(KLAMDH),ISYMH, 1453 & WORK(KEND1),LWRK1,0,1,CDUMMY,IDUMMY,IDUMMY, 1454 & IOPTE) 1455 CALL GETTIM(T1,W1) 1456 TIMHPCPU = T1-T0 1457 TIMHPWAL = W1-W0 1458 TIMR12CPU = TIMR12CPU + (T1-T0) 1459 TIMR12WAL = TIMR12WAL + (W1-W0) 1460c 1461 CALL GETTIM(T0,W0) 1462 CALL CCRHS_IP(OMEGA1,T1AM,1,WORK(KLAMDH),ISYMH,0,1, 1463 & CDUMMY,IDUMMY,IDUMMY,WORK(KEND1),LWRK1) 1464c 1465 CALL GETTIM(T1,W1) 1466 TIMIPCPU = T1-T0 1467 TIMIPWAL = W1-W0 1468 TIMR12CPU = TIMR12CPU + (T1-T0) 1469 TIMR12WAL = TIMR12WAL + (W1-W0) 1470 END IF 1471C 1472 IF (CCSDR12) THEN 1473 CALL GETTIM(T0,W0) 1474c 1475 CALL CCRHS_BPP(WORK(KVIJKL),T2AM,1,.FALSE., 1476 & FVCDKL,1,WORK(KEND1),LWRK1) 1477c 1478 CALL GETTIM(T1,W1) 1479 IF (IPRINT .GT. 9) THEN 1480 WRITE(LUPRI,*)'Time used for CCRHS_BPP cpu:', T1-T0 1481 WRITE(LUPRI,*)'Time used for CCRHS_BPP wall:',W1-W0 1482 END IF 1483 TIMR12CPU = TIMR12CPU + (T1-T0) 1484 TIMR12WAL = TIMR12WAL + (W1-W0) 1485 END IF 1486c 1487 ISYMV = 1 1488 CALL GETTIM(T0,W0) 1489c 1490 CALL CCRHS_EP(WORK(KVIJKL),ISYMV,.FALSE.,DUMMY, 1491 & WORK(KEND1),LWRK1,0, 1492 & CDUMMY,IDUMMY,CDUMMY,IDUMMY,IDUMMY,APROXR12, 1493 & BRASCL,KETSCL) 1494 CALL GETTIM(T1,W1) 1495 TIMEPCPU = T1-T0 1496 TIMEPWAL = W1-W0 1497 TIMR12CPU = TIMR12CPU + (T1-T0) 1498 TIMR12WAL = TIMR12WAL + (W1-W0) 1499c 1500 IF ((IANR12.EQ.2.OR.IANR12.EQ.3).AND.DEBUGV) THEN 1501c write V^ij_kl on file to calculate later numerically RHOR12 1502 LUVIJKL = -1 1503 CALL GPOPEN(LUVIJKL,FVIJKL,'UNKNOWN',' ','UNFORMATTED', 1504 & IDUMMY,.FALSE.) 1505 WRITE(LUVIJKL)(WORK(KVIJKL-1+I),I=1,NTR12SQ(1)) 1506 CALL GPCLOSE(LUVIJKL,'KEEP') 1507 WRITE(LUPRI,*)'VIJKL WRITTEN ON FILE' 1508 END IF 1509c 1510 CALL GETTIM(T0,W0) 1511 CALL CCRHS_GP(OMEGA1,WORK(KLAMDP), 1512 & WORK(KEND1),LWRK1,0,1,CDUMMY,IDUMMY,IDUMMY) 1513 CALL GETTIM(T1,W1) 1514 TIMGPCPU = T1-T0 1515 TIMGPWAL = W1-W0 1516 TIMR12CPU = TIMR12CPU + (T1-T0) 1517 TIMR12WAL = TIMR12WAL + (W1-W0) 1518c TIMGP = TIMGP + ( SECOND() - DTIME ) 1519 1520 END IF !CCR12 1521C 1522C------------------------------------------------- 1523C Transform the Omega2 vector to the MO basis. 1524C------------------------------------------------- 1525C 1526 IF (NT2AM(ISYMOP) .GT. 2*NT2AMX) THEN 1527 WRITE(LUPRI,*) 1528 & 'Length of T2AM is smaller than OMEGA2 in MO basis' 1529 CALL QUIT('Insufficient space in CC_T2MO') 1530 ENDIF 1531C 1532 IF ( .NOT. CC2 ) THEN 1533C 1534C--------------------------------------- 1535C Save the CC amplitudes on disk. 1536C--------------------------------------- 1537C 1538 WRITE (LURHS1) (T2AM(I), I = 1,NT2AM(ISYMOP)) 1539C 1540C---------------------------------------------------------------------- 1541C Write Omega2 vector to disk if needed in response calculation. 1542C---------------------------------------------------------------------- 1543C 1544 IF ( RSPIM ) THEN 1545C 1546 LUBF = -1 1547 CALL GPOPEN(LUBF,'CC_BFIM','UNKNOWN',' ','UNFORMATTED', 1548 * IDUMMY,.FALSE.) 1549 REWIND(LUBF) 1550 WRITE(LUBF) (OMEGA2(I),I = 1,2*NT2ORT(1)) 1551 CALL GPCLOSE(LUBF,'KEEP') 1552C 1553 ENDIF 1554C 1555C-------------------------------------------- 1556C Allocate space for the gamma matrix. 1557C-------------------------------------------- 1558C 1559 IF (NEWGAM) THEN 1560C 1561 KGAMMA = KEND1 1562 KEND1 = KGAMMA + NGAMMA(ISYMOP) 1563 LWRK1 = LWORK - KEND1 1564C 1565 IF (LWRK1 .LT. 0) CALL QUIT('Insufficient memory in GAMMA') 1566C 1567 END IF 1568C 1569C---------------------------------------------------- 1570C Transform the Omega2 vector to the MO basis. 1571C---------------------------------------------------- 1572C 1573 IF (NT2AM(ISYMOP) .GT. 2*NT2AMX) THEN 1574 WRITE(LUPRI,*) 1575 * 'Length of T2AM is smaller than OMEGA2 in AO basis' 1576 CALL QUIT('Insufficient space in CC_T2MO') 1577 ENDIF 1578C 1579 TIMOME2 = SECOND() 1580 ISYMBF = ISYMOP 1581 ICON = 1 1582 1583 CALL CC_T2MO(FAKE,PHONEY,ISYMOP,OMEGA2,T2AM,WORK(KGAMMA), 1584 * WORK(KLAMDP),WORK(KLAMDP),ISYMTR, 1585 * WORK(KEND1),LWRK1,ISYMBF,ICON) 1586 CALL DCOPY(NT2AM(ISYMTR),T2AM,1,OMEGA2,1) 1587 TIMOME2 = SECOND() - TIMOME2 1588C 1589 IF (IPRINT .GT. 51) THEN 1590 RHO1N = DDOT(NT1AMX,OMEGA1,1,OMEGA1,1) 1591 RHO2N = DDOT(NT2AMX,OMEGA2,1,OMEGA2,1) 1592 WRITE(LUPRI,*) 'Norm of OMEGA1 -after CC_T2MO: ',RHO1N 1593 WRITE(LUPRI,*) 'Norm of OMEGA2 -after CC_T2MO: ',RHO2N 1594 ENDIF 1595C 1596 IF (IPRINT .GT. 120) THEN 1597 CALL AROUND('After T2MO: BF ') 1598 CALL CC_PRP(OMEGA1,OMEGA2,1,1,1) 1599 ENDIF 1600C 1601C--------------------------------------------------------------------- 1602C Write Gamma vector to disk if needed in response calculation. 1603C--------------------------------------------------------------------- 1604C 1605 IF ( RSPIM ) THEN 1606C 1607 LUGAM = -1 1608 CALL GPOPEN(LUGAM,'CC_GAMIM','UNKNOWN',' ','UNFORMATTED', 1609 * IDUMMY,.FALSE.) 1610 REWIND(LUGAM) 1611 WRITE(LUGAM)(WORK(KGAMMA+I-1),I = 1,NGAMMA(ISYMOP)) 1612 CALL GPCLOSE(LUGAM,'KEEP') 1613C 1614 ENDIF 1615C 1616C------------------------------- 1617C Print the Gamma matrix. 1618C------------------------------- 1619C 1620 IF (IPRINT .GT. 120) THEN 1621 CALL AROUND('The Gamma matrix') 1622 DO 200 ISYM = 1,NSYM 1623 KOFF = KGAMMA + IGAMMA(ISYM,ISYM) 1624 CALL OUTPAK(WORK(KOFF),NMATIJ(ISYM),1,LUPRI) 1625 200 CONTINUE 1626C 1627 WRITE(LUPRI,*) 'Norm of gamma matrix: ', 1628 * DDOT(NGAMMA(ISYMOP),WORK(KGAMMA),1,WORK(KGAMMA),1) 1629 END IF 1630C 1631C-------------------------------------------- 1632C Restore the CC amplitudes from disk. 1633C-------------------------------------------- 1634C 1635 REWIND (LURHS1) 1636 READ (LURHS1) 1637 READ (LURHS1) 1638 READ (LURHS1) (T2AM(I), I = 1,NT2AM(ISYMOP)) 1639C 1640 ENDIF 1641C 1642C--------------------------------------- 1643C Write out AO fock as intermediate. 1644C--------------------------------------- 1645C 1646 IF ( RSPIM ) THEN 1647C 1648 LUFCK = -1 1649 CALL GPOPEN(LUFCK,'CC_FCKH','UNKNOWN',' ','UNFORMATTED',IDUMMY, 1650 * .FALSE.) 1651 REWIND(LUFCK) 1652 WRITE(LUFCK)(WORK(KFOCK + I-1),I = 1,N2BST(ISYMOP)) 1653 CALL GPCLOSE(LUFCK,'KEEP' ) 1654C 1655 IF (IPRINT .GT.150) THEN 1656 CALL AROUND( 'Fock AO matrix written to disk' ) 1657 CALL CC_PRFCKAO(WORK(KFOCK),1) 1658 ENDIF 1659C 1660 ENDIF 1661C 1662C------------------------------------------ 1663C Transform AO Fock matrix to MO basis. 1664C------------------------------------------ 1665C 1666 TIMFCKMO = SECOND() 1667 CALL CC_FCKMO(WORK(KFOCK),WORK(KLAMDP),WORK(KLAMDH), 1668 * WORK(KEND1),LWRK1,1,1,1) 1669 TIMFCKMO = SECOND() - TIMFCKMO 1670C 1671C--------------------- 1672C Reallocate T2TP. 1673C--------------------- 1674C 1675 IF (DIRECT .AND. T2TCOR) THEN 1676C 1677 KT2AMT = KEND1 1678 KEND2 = KT2AMT + NT2SQ(1) 1679 LWRK2 = LWORK - KEND2 1680C 1681 IF (LWRK2. LT. 0) THEN 1682 CALL QUIT('Insufficient memory in CCSD_RHS') 1683 END IF 1684C 1685 ELSE 1686C 1687 KEND2 = KEND1 1688 LWRK2 = LWRK1 1689C 1690 END IF 1691C 1692C-------------------------------------------------------------- 1693C Add connected triples corrections to the vector function. 1694C-------------------------------------------------------------- 1695C 1696C 1697C MLCC3 contribution 1698 IF(MLCC3) THEN 1699C 1700 MLCC3_RESPONSE = .FALSE. !ONLY ENERGY CALCULATION 1701 FREQUENCY = ZERO 1702C 1703 CALL MLCC3_DRV(OMEGA1,OMEGA2,CDUMMY,CDUMMY,FREQUENCY, 1704 * MLCC3_RESPONSE,WORK(KEND1),WORK(KEND1),LWRK2) 1705 END IF 1706C 1707C 1708 IF (CCSDT) THEN 1709 1710 IF (NODDY_OMEGA) THEN 1711C Unrelaxed noddy 1712C CALL CC_FOPTRIPLES(OMEGA1,DUMMY,DUMMY,T1AM,T2AM, 1713C * WORK(KLAMDP),WORK(KLAMDH), 1714C * WORK(KEND2),LWRK2) 1715C Original noddy part 1716C Used to calculate Finite difference CC3 1717 CALL CCSD_TRIPLE(OMEGA1,OMEGA2,T1AM,T2AM,WORK(KFOCK), 1718 * WORK(KLAMDP),WORK(KLAMDH),WORK(KEND2), 1719 * LWRK2) 1720 ELSE 1721 1722C Normal triples part 1723 CALL CC3_OMEG(0.0D0,OMEGA1,OMEGA2,T1AM,ISYMTR,T2AM,ISYMTR, 1724 * WORK(KFOCK),WORK(KLAMDP),WORK(KLAMDH), 1725 * WORK(KEND2),LWRK2,LU3SRT,FN3SRT,LUDELD, 1726 * FNDELD,LUCKJD,FNCKJD,LUDKBC,FNDKBC, 1727 * LUTOC,FNTOC,LU3VI,FN3VI,LU3VI2,FN3VI2) 1728 1729 END IF 1730C 1731C 1732C---------------------------------------- 1733C Reconstruct full square of T2AM. 1734C---------------------------------------- 1735C 1736 IF (LWRK1 .LT. NT2AMX) THEN 1737 CALL QUIT('Insufficient core in CCRHSN') 1738 ENDIF 1739C 1740 REWIND (LURHS1) 1741 READ (LURHS1) 1742 READ (LURHS1) (WORK(KEND1+I-1), I = 1,NT2AMX) 1743C 1744 CALL CC_T2SQ(WORK(KEND1),T2AM,1) 1745C 1746 ENDIF 1747C 1748 IF (IPRINT .GT. 51) THEN 1749 RHO1N = DDOT(NT1AMX,OMEGA1,1,OMEGA1,1) 1750 RHO2N = DDOT(NT2AMX,OMEGA2,1,OMEGA2,1) 1751 WRITE(LUPRI,*) 'Norm of OMEGA1 -after cc3_omeg: ',RHO1N 1752 WRITE(LUPRI,*) 'Norm of OMEGA2 -after cc3_omeg: ',RHO2N 1753 ENDIF 1754C 1755 IF (IPRINT .GT. 120) THEN 1756 CALL AROUND('After CC3_OMEG Omega is ') 1757 CALL CC_PRP(OMEGA1,OMEGA2,1,1,1) 1758 ENDIF 1759C 1760C--------------------- 1761C Reallocate T2TP. 1762C--------------------- 1763C 1764 IF ((DIRECT .AND. T2TCOR) .OR. (CCSDT .AND. T2TCOR)) THEN 1765C 1766 KT2AMT = KEND1 1767 KEND2 = KT2AMT + NT2SQ(1) 1768 LWRK2 = LWORK - KEND2 1769C 1770 IF (LWRK2. LT. 0) THEN 1771 CALL QUIT('Insufficient memory in CCSD_RHS') 1772 END IF 1773C 1774 ELSE 1775C 1776 KEND2 = KEND1 1777 LWRK2 = LWRK1 1778C 1779 END IF 1780C 1781C---------------------- 1782C Recalculate T2TP. 1783C---------------------- 1784C 1785 IF (T2TCOR) THEN 1786C 1787 JSYM = 1 1788 CALL DCOPY(NT2SQ(1),T2AM,1,WORK(KT2AMT),1) 1789 CALL CCSD_T2TP(WORK(KT2AMT),WORK(KEND2),LWRK2,JSYM) 1790C 1791 END IF 1792C---------------------- 1793C Calculate J-term. 1794C---------------------- 1795C 1796 TIMJ = SECOND() 1797 CALL CCRHS_J(OMEGA1,1,WORK(KFOCK)) 1798 TIMJ = SECOND() - TIMJ 1799C 1800C---------------------- 1801C Calculate A-term. 1802C---------------------- 1803C 1804 IOPT = 1 1805 TIMA = SECOND() 1806 IF (.NOT. CC2) THEN 1807 CALL CCRHS_A(OMEGA2,T2AM,WORK(KGAMMA),WORK(KEND2),LWRK2, 1808 * ISYMTR,ISYMTR,IOPT) 1809 ENDIF 1810 TIMA = SECOND() - TIMA 1811C 1812C------------------------------------------------------------------ 1813C Calculate E-term. 1814C Write out the matrices if response calculation is to be done. 1815C------------------------------------------------------------------ 1816C 1817 TIME = SECOND() 1818 IF (CC2 .AND. (.NOT.RSPIM)) THEN 1819 IF (.NOT. NONHF) THEN 1820 ISIDE = 1 1821 CALL CC2_FCK(OMEGA2,T2AM,WORK(KEND2),LWRK2,ISYMTR, 1822 * WORK(KLAMDP),WORK(KLAMDH),ISIDE) 1823 ELSE 1824 ETRAN = .FALSE. 1825 FCKCON = .TRUE. 1826 ISYMEI = ISYMTR 1827 CALL CCRHS_EFCK(WORK(KEMAT1),WORK(KEMAT2),WORK(KLAMDH), 1828 * WORK(KFCKHF),WORK(KEND2),LWRK2,FCKCON, 1829 * ETRAN,ISYMEI) 1830 CALL CCRHS_E(OMEGA2,T2AM,WORK(KEMAT1),WORK(KEMAT2), 1831 * WORK(KEND2),LWRK2,ISYMTR,ISYMOP) 1832 END IF 1833 ENDIF 1834C 1835 IF (CCR12 .AND. (IANR12.EQ.2 .OR. IANR12.EQ.3)) THEN 1836 LRES = .FALSE. 1837 CALL GETTIM(T0,W0) 1838 CALL CCRHS_EPPP(OMEGA2,WORK(KEND2),LWRK2,APROXR12,LRES, 1839 & IDUMMY,CDUMMY,IDUMMY,ISYMTR) 1840 CALL GETTIM(T1,W1) 1841 TIMEPPPCPU = T1-T0 1842 TIMEPPPWAL = W1-W0 1843 TIMR12CPU = TIMR12CPU + (T1-T0) 1844 TIMR12WAL = TIMR12WAL + (W1-W0) 1845 END IF 1846c 1847 IF ((.NOT.CC2) .OR. RSPIM) THEN 1848C 1849 ETRAN = .TRUE. 1850 FCKCON = .TRUE. 1851 ISYMEI = ISYMTR 1852 CALL CCRHS_EFCK(WORK(KEMAT1),WORK(KEMAT2),WORK(KLAMDH), 1853 * WORK(KFOCK),WORK(KEND2),LWRK2,FCKCON, 1854 * ETRAN,ISYMEI) 1855C 1856 IF (CCR12) THEN 1857 KEMAT2P = KEND2 1858 KEND3 = KEMAT2P + NMATIJ(ISYMOP) 1859 LWRK3 = LWORK - KEND3 1860 IF (LWRK3.LT.0) CALL QUIT('Insufficient memory in CCSD_RHS') 1861 1862 CALL GETTIM(T0,W0) 1863 CALL DZERO(WORK(KEMAT2P),NMATIJ(ISYMOP)) 1864 CALL CCRHS_EINTP(WORK(KEMAT2P),WORK(KLAMDP), 1865 & WORK(KEND3),LWRK3,0,1,CDUMMY,IDUMMY, 1866 & IDUMMY,CDUMMY,IDUMMY) 1867 CALL GETTIM(T1,W1) 1868 IF (IPRINT .GT. 9) THEN 1869 WRITE(LUPRI,*)'Time used for CCRHS_EINTP cpu:', T1-T0 1870 WRITE(LUPRI,*)'Time used for CCRHS_EINTP wall:',W1-W0 1871 END IF 1872 TIMR12CPU = TIMR12CPU + (T1-T0) 1873 TIMR12WAL = TIMR12WAL + (W1-W0) 1874C 1875 ! add R12 contribution to usual E_ij intermediate 1876 CALL DAXPY(NMATIJ(ISYMOP),ONE,WORK(KEMAT2P),1,WORK(KEMAT2),1) 1877C 1878 IF (IANR12.NE.1) THEN 1879 ! add R12 contribution to usual E_ab intermediate 1880 IOPTE = 1 1881 CALL GETTIM(T0,W0) 1882 CALL CCRHS_HP(WORK(KEMAT1),WORK(KLAMDH),1,WORK(KLAMDH),1, 1883 & WORK(KEND2),LWRK2,0,1,CDUMMY,IDUMMY,IDUMMY, 1884 & IOPTE) 1885 CALL GETTIM(T1,W1) 1886 TIMR12CPU = TIMR12CPU + (T1-T0) 1887 TIMR12WAL = TIMR12WAL + (W1-W0) 1888 END IF 1889C 1890 IF (IPRINT .GT. 9) THEN 1891 WRITE(LUPRI,*)'Time used for R12 part in CCSD_RHS cpu:', 1892 & TIMR12CPU 1893 WRITE(LUPRI,*)'Time used for R12 part in CCSD_RHS wall:', 1894 & TIMR12WAL 1895 END IF 1896 END IF 1897C 1898 IF ( RSPIM ) THEN 1899C 1900 LUE1 = -1 1901 CALL GPOPEN(LUE1,'CC_E1IM','UNKNOWN',' ','UNFORMATTED', 1902 * IDUMMY,.FALSE.) 1903 REWIND(LUE1) 1904 WRITE(LUE1)(WORK(KEMAT1+ I-1),I = 1,NMATAB(ISYMOP)) 1905 CALL GPCLOSE(LUE1,'KEEP' ) 1906C 1907 LUE2 = -1 1908 CALL GPOPEN(LUE2,'CC_E2IM','UNKNOWN',' ','UNFORMATTED', 1909 * IDUMMY,.FALSE.) 1910 REWIND(LUE2) 1911 WRITE(LUE2)(WORK(KEMAT2+ I-1),I = 1,NMATIJ(ISYMOP)) 1912 CALL GPCLOSE(LUE2,'KEEP' ) 1913C 1914 IF (CCR12) THEN 1915 LUE2P = -1 1916 CALL GPOPEN(LUE2P,'CC_E2PIM','UNKNOWN',' ','UNFORMATTED', 1917 * IDUMMY,.FALSE.) 1918 REWIND(LUE2P) 1919 WRITE(LUE2P)(WORK(KEMAT2P+ I-1),I = 1,NMATIJ(ISYMOP)) 1920 CALL GPCLOSE(LUE2P,'KEEP' ) 1921 END IF 1922C 1923 IF (IPRINT.GT.40) THEN 1924 CALL AROUND( 'E-intermediates written to disk ') 1925 CALL CC_PREI(WORK(KEMAT1),WORK(KEMAT2),ISYMOP,1) 1926 ENDIF 1927 IF (DEBUG) THEN 1928 XNORM1 = DDOT(NMATAB(1),WORK(KEMAT1),1,WORK(KEMAT1),1) 1929 XNORM2 = DDOT(NMATIJ(1),WORK(KEMAT2),1,WORK(KEMAT2),1) 1930 WRITE(LUPRI,*) 'Norm of E1 intermediate:',XNORM1 1931 WRITE(LUPRI,*) 'Norm of E2 intermediate:',XNORM2 1932 IF (CCR12) THEN 1933 XNORM2=DDOT(NMATIJ(1),WORK(KEMAT2P),1,WORK(KEMAT2P),1) 1934 WRITE(LUPRI,*) 'Norm of E2P intermediate:',XNORM2 1935 END IF 1936 END IF 1937C 1938 ENDIF 1939C 1940 IF (.NOT.CC2) THEN 1941C 1942 CALL CCRHS_E(OMEGA2,T2AM,WORK(KEMAT1),WORK(KEMAT2), 1943 * WORK(KEND2),LWRK2,ISYMTR,ISYMOP) 1944C 1945 ENDIF 1946C 1947 ENDIF 1948 TIME = SECOND() - TIME 1949C 1950C-------------------------------------- 1951C If (DUMPCD) calculate the C-term. 1952C-------------------------------------- 1953C 1954 IF (DUMPCD .AND. (.NOT. CC2)) THEN 1955C 1956 ISYVEC = 1 1957 ISYCIM = 1 1958 IOPT = 1 1959 IVECNR = 1 1960C 1961 TIMCIO = SECOND() 1962 IF (T2TCOR) THEN 1963 CALL CCRHS_CIO(OMEGA2,WORK(KT2AMT),WORK(KLAMDH), 1964 * WORK(KEND2),LWRK2,ISYVEC,ISYCIM, 1965 * LUC,CFIL,IVECNR,IOPT) 1966 ELSE 1967 ISYM = 1 1968 CALL CCSD_T2TP(T2AM,WORK(KEND2),LWRK2,ISYM) 1969 CALL CCRHS_CIO(OMEGA2,T2AM,WORK(KLAMDH),WORK(KEND2), 1970 * LWRK2,ISYVEC,ISYCIM,LUC,CFIL,IVECNR,IOPT) 1971 CALL CCSD_T2TP(T2AM,WORK(KEND2),LWRK2,ISYM) 1972 ENDIF 1973C 1974 TIMCIO = SECOND() - TIMCIO 1975C 1976 ENDIF 1977C 1978C------------------------------ 1979C Transform T2 to 2T2 - T2. 1980C------------------------------ 1981C 1982 DTIME = SECOND() 1983 IF (T2TCOR) THEN 1984 CALL DSCAL(NT2SQ(1),TWO,T2AM,1) 1985 CALL DAXPY(NT2SQ(1),-ONE,WORK(KT2AMT),1,T2AM,1) 1986 ELSE 1987 ISYM = 1 1988 CALL CCRHS_T2TR(T2AM,WORK(KEND2),LWRK2,ISYM) 1989 END IF 1990 DTIME = SECOND() - DTIME 1991 TIMT2TR = TIMT2TR + DTIME 1992C 1993C-------------------------------------- 1994C If (DUMPCD) calculate the D-term. 1995C-------------------------------------- 1996C 1997 IF (DUMPCD .AND. (.NOT. CC2)) THEN 1998C 1999 ISYDIM = 1 2000 ISYVEC = 1 2001 IOPT = 1 2002 IVECNR = 1 2003C 2004 TIMDIO = SECOND() 2005 CALL CCRHS_DIO(OMEGA2,T2AM,WORK(KLAMDH),WORK(KEND2),LWRK2, 2006 * ISYVEC,ISYDIM,LUD,DFIL,IVECNR,IOPT) 2007 TIMDIO = SECOND() - TIMDIO 2008 END IF 2009C 2010C---------------------- 2011C Calculate I-term. 2012C---------------------- 2013C 2014 TIMI = SECOND() 2015 CALL CCRHS_I(OMEGA1,T2AM,WORK(KFOCK),WORK(KEND2),LWRK2,ISYMTR,1) 2016 TIMI = SECOND() - TIMI 2017 2018C----------------------------------------------------------------- 2019C Add the remaining CCSDR12 C-, D- and E-contributions 2020C to Omega2 2021C----------------------------------------------------------------- 2022C 2023 IF (CCSDR12 .AND. (IANR12.EQ.2.OR.IANR12.EQ.3)) THEN 2024C 2025 !calculate t(bj,p'k) amplitudes: 2026 CALL CC_R12MKTBJPK(T2AM,WORK(KEND2),LWRK2) 2027C 2028 !Read CMO-Matrix incl. aux.-orbitals: 2029 KCMOX = KEND2 2030 KEND3 = KCMOX + NLAMDX(1) 2031 LWRK3 = LWORK - KEND3 2032 IF (LWRK3.LT.0) CALL QUIT('Insuff. memory for CCRHS_CIO') 2033 CALL CC_R12CMO(WORK(KCMOX),WORK(KEND3),LWRK3) 2034C 2035 !calculate E1P_(ap') intermediate: 2036 CALL CCRHS_E1PIM(WORK(KE1PIM),WORK(KCMOX),ILAMDX,WORK(KLAMDH), 2037 & WORK(KEND3),LWRK3) 2038C 2039CTesT 2040C WRITE(LUPRI,*) 'E1PIM after transformation to MO:' 2041C KOFF = 0 2042C DO ISYM = 1,NSYM 2043C CALL OUTPUT(WORK(KE1PIM+KOFF), 2044C & 1,NVIR(ISYM),1,NORB2(ISYM), 2045C & NVIR(ISYM),NORB2(ISYM),1, LUPRI) 2046C KOFF = KOFF + NVIR(ISYM)*NORB2(ISYM) 2047C END DO 2048C WRITE(LUPRI,*) 'Norm^2: ', 2049C & DDOT(KOFF,WORK(KE1PIM),1,WORK(KE1PIM),1) 2050C CALL FLSHFO(LUPRI) 2051C 2052C WRITE(LUPRI,*) "OMEGA2 before C', D', E' contr.:" 2053C WRITE(LUPRI,*) "Norm^2: ", DDOT(NT2AMX,OMEGA2,1,OMEGA2,1) 2054C DO ISYM = 1,NSYM 2055C WRITE(LUPRI,*) 'Symmetry block number : ',ISYM 2056C KOFF = IT2AM(ISYM,ISYM) + 1 2057C CALL OUTPAK(OMEGA2(KOFF),NT1AM(ISYM),1,LUPRI) 2058C END DO 2059CTesT 2060C 2061 ISYVEC = 1 2062 ISYCIM = 1 2063 ISYDIM = 1 2064 IVECNR = 1 2065 IOPT = 1 2066 IOPTB = 0 2067 IOPTE = 1 2068 CALL CCRHS_CIO2(OMEGA2,T2AM,WORK(KCMOX), 2069 * WORK(KEND3),LWRK3,ISYVEC,ISYCIM, 2070 * LUCP,CPFIL,IVECNR,IOPT,IOPTB,IDUMMY, 2071 * DUMMY,IDUMMY,DUMMY,IOPTE,WORK(KE1PIM),.TRUE.) 2072 2073 CALL CCRHS_DIO2(OMEGA2,T2AM,WORK(KCMOX), 2074 * WORK(KEND3),LWRK3,ISYVEC,ISYDIM, 2075 * LUDP,DPFIL,IDUMMY,DUMMY,IVECNR,IOPT, 2076 * IOPTB,IDUMMY,DUMMY,IDUMMY,DUMMY, 2077 * IOPTE,WORK(KE1PIM),.TRUE.) 2078C 2079CTesT 2080C WRITE(LUPRI,*) "OMEGA2 after C', D', E' contr.:" 2081C WRITE(LUPRI,*) "Norm^2: ", DDOT(NT2AMX,OMEGA2,1,OMEGA2,1) 2082C DO ISYM = 1,NSYM 2083C WRITE(LUPRI,*) 'Symmetry block number : ',ISYM 2084C KOFF = IT2AM(ISYM,ISYM) + 1 2085C CALL OUTPAK(OMEGA2(KOFF),NT1AM(ISYM),1,LUPRI) 2086C END DO 2087C STOP 2088CTesT 2089 END IF 2090C 2091C----------------------------------------------------------------- 2092C Calculate the C and D contributions to the R12 result vector 2093C----------------------------------------------------------------- 2094C 2095 IF (CCSDR12 .AND. (IANR12.EQ.2.OR.IANR12.EQ.3)) THEN 2096 ! save vector function on disk, since memory is needed 2097 LUOME1 = -1 2098 CALL GPOPEN(LUOME1,'CCOME1','UNKNOWN',' ','UNFORMATTED',IDUMMY, 2099 & .FALSE.) 2100cch 2101 write(lupri,*) 'Norm of OMEGA2:',ddot(nt2amx,OMEGA2,1,OMEGA2,1) 2102cch 2103 REWIND(LUOME1) 2104 WRITE(LUOME1) (OMEGA2(I), I = 1,NT2AMX) 2105 CALL GPCLOSE(LUOME1,'KEEP') 2106 2107 ! read cluster amlitudes in packed form into memory 2108 REWIND(LURHS1) 2109 READ(LURHS1) 2110 READ(LURHS1) (OMEGA2(I), I = 1,NT2AMX) 2111 2112 !Read CMO-Matrix incl. aux.-orbitals: 2113 KCMOX = KEND2 2114 KEND3 = KCMOX + NLAMDX(1) 2115 LWRK3 = LWORK - KEND3 2116 IF (LWRK3.LT.0) CALL QUIT('Insuff. memory for CCRHS_CIO') 2117 CALL CC_R12CMO(WORK(KCMOX),WORK(KEND3),LWRK3) 2118 2119 CALL CCSDR12CD(CCSDR12, 2120 & T2AM,1,OMEGA2,1,1, 2121 & FNIADJ,LUIADJ,FNIJDA,LUIJDA,IT2DEL, 2122 & WORK(KLAMDH),1, 2123 & WORK(KCMOX),ILAMDX, 2124 & WORK(KEND3),LWRK3) 2125 2126 ! restore vector function 2127 LUOME1 = -1 2128 CALL GPOPEN(LUOME1,'CCOME1','UNKNOWN',' ','UNFORMATTED',IDUMMY, 2129 & .FALSE.) 2130 REWIND(LUOME1) 2131 READ(LUOME1) (OMEGA2(I), I = 1,NT2AMX) 2132 CALL GPCLOSE(LUOME1,'DELETE') 2133cch 2134 write(lupri,*) 'Norm of OMEGA2:',ddot(nt2amx,OMEGA2,1,OMEGA2,1) 2135cch 2136 END IF 2137C 2138C------------------------ 2139C Scale final result. 2140C------------------------ 2141C 2142C CALL DSCAL(NT1AM,TWO,OMEGA1,1) 2143C CALL DSCAL(NT2IND,TWO,OMEGA2,1) 2144C 2145 IF (IPRINT .GT. 25) THEN 2146 CALL AROUND('END OF CCRHS:OMEGA 1') 2147 DO 300 ISYM = 1,NSYM 2148 WRITE(LUPRI,*) 'Symmetry block number : ',ISYM 2149 KOFF = IT1AM(ISYM,ISYM) + 1 2150 CALL OUTPUT(OMEGA1(KOFF),1,NVIR(ISYM),1,NRHF(ISYM), 2151 * NVIR(ISYM),NRHF(ISYM),1,LUPRI) 2152 300 CONTINUE 2153 WRITE(LUPRI,*) 2154 CALL AROUND('END OF CCRHS:OMEGA 2') 2155 DO 310 ISYM = 1,NSYM 2156 WRITE(LUPRI,*) 'Symmetry block number : ',ISYM 2157 KOFF = IT2AM(ISYM,ISYM) + 1 2158 CALL OUTPAK(OMEGA2(KOFF),NT1AM(ISYM),1,LUPRI) 2159 310 CONTINUE 2160 ENDIF 2161 TIMALL = SECOND() - TIMALL 2162 IF ( IPRINT .GT. 2) THEN 2163 WRITE(LUPRI,9999) 'RHS - TOTAL', TIMALL 2164 ENDIF 2165 IF (IPRINT .GT. 9) THEN 2166 WRITE(LUPRI,9999) 'CCRHS_A ', TIMA 2167 WRITE(LUPRI,9999) 'CCRHS_B ', TIMB 2168 WRITE(LUPRI,9999) 'CCRHS_BF ', TIMBF 2169 WRITE(LUPRI,9999) 'CCRHS_C ', TIMC 2170 WRITE(LUPRI,9999) 'CCRHS_CIO ', TIMCIO 2171 WRITE(LUPRI,9999) 'CCRHS_C-tot', TIMCIO + TIMC 2172 WRITE(LUPRI,9999) 'CCRHS_D ', TIMD 2173 WRITE(LUPRI,9999) 'CCRHS_DIO ', TIMDIO 2174 WRITE(LUPRI,9999) 'CCRHS_D-tot', TIMDIO + TIMD 2175 WRITE(LUPRI,9999) 'CCRHS_E ', TIME 2176 WRITE(LUPRI,9999) 'CCRHS_EI ', TIMEI 2177 WRITE(LUPRI,9999) 'CCRHS_E-tot', TIMEI + TIME 2178 WRITE(LUPRI,9999) 'CCRHS_F ', TIMF 2179 WRITE(LUPRI,9999) 'CCRHS_G ', TIMG 2180 WRITE(LUPRI,9999) 'CCRHS_H ', TIMH 2181 WRITE(LUPRI,9999) 'CCRHS_I ', TIMI 2182 WRITE(LUPRI,9999) 'CCRHS_J ', TIMJ 2183 WRITE(LUPRI,9999) 'CCRHS_GAM ', TIMGAM 2184 WRITE(LUPRI,9999) 'CCRHS_LAM ', TIMLAM 2185 WRITE(LUPRI,9999) 'CCRHS_RDAO ', TIMRDAO 2186 WRITE(LUPRI,9999) 'HERDIS1 ', TIMHER1 2187 WRITE(LUPRI,9999) 'HERDIS2 ', TIMHER2 2188 WRITE(LUPRI,9999) 'CC_T2AO ', TIMT2AO 2189 WRITE(LUPRI,9999) 'CC_FCKMO ', TIMFCKMO 2190 WRITE(LUPRI,9999) 'CCRHS_FCK ', TIMFCK 2191 WRITE(LUPRI,9999) 'CCRHS_DM ', TIMDM 2192 WRITE(LUPRI,9999) 'CCRHS_TRBT ', TIMTRBT 2193 WRITE(LUPRI,9999) 'CCRHS_T2TR ', TIMT2TR 2194 WRITE(LUPRI,9999) 'CCRHS_T2BT ', TIMT2BT 2195 IF (CCR12.AND.(IANR12.EQ.1)) THEN 2196 WRITE(LUPRI,9999) 'CCRHS_FP ', TIMFP 2197 WRITE(LUPRI,9999)'CC_MOFCON cpu:', TIMMOFCPU 2198 WRITE(LUPRI,9999)'CC_MOFCON wall:', TIMMOFWAL 2199 WRITE(LUPRI,9999)'CC_MOFCONR12 cpu:', TIMMOFR12CPU 2200 WRITE(LUPRI,9999)'CC_MOFCONR12 wall:', TIMMOFR12WAL 2201 WRITE(LUPRI,9999)'CCRHS_EP cpu:', TIMEPCPU 2202 WRITE(LUPRI,9999)'CCRHS_EP wall:',TIMEPWAL 2203 WRITE(LUPRI,9999)'CCRHS_GP cpu:', TIMGPCPU 2204 WRITE(LUPRI,9999)'CCRHS_GP wall:', TIMGPWAL 2205 WRITE(LUPRI,9999) 'INTEG. R12 ', TIMINTR12 2206 WRITE(LUPRI,9999) 'RDAO R12 ', TIMRDAOR12 2207 ELSE IF (CCR12.AND.(IANR12.EQ.2.OR.IANR12.EQ.3)) THEN 2208 WRITE(LUPRI,9999)'CC_MOFCON cpu:', TIMMOFCPU 2209 WRITE(LUPRI,9999)'CC_MOFCON wall:', TIMMOFWAL 2210 WRITE(LUPRI,9999)'CC_R12INTF2 cpu:', TIMINTF2CPU 2211 WRITE(LUPRI,9999)'CC_R12INTF2 wall:', TIMINTF2WAL 2212 WRITE(LUPRI,9999)'CC_MOFCONR12 cpu:', TIMMOFR12CPU 2213 WRITE(LUPRI,9999)'CC_MOFCONR12 wall:', TIMMOFR12WAL 2214 WRITE(LUPRI,9999)'CCRHS_EPP cpu:', TIMEPPCPU 2215 WRITE(LUPRI,9999)'CCRHS_EPP wall:', TIMEPPWAL 2216 WRITE(LUPRI,9999)'CCRHS_EPPP cpu:', TIMEPPPCPU 2217 WRITE(LUPRI,9999)'CCRHS_EPPP wall:', TIMEPPPWAL 2218 WRITE(LUPRI,9999)'CCRHS_HP cpu:', TIMHPCPU 2219 WRITE(LUPRI,9999)'CCRHS_HP wall:', TIMHPWAL 2220 WRITE(LUPRI,9999)'CCRHS_IP cpu:', TIMIPCPU 2221 WRITE(LUPRI,9999)'CCRHS_IP wall:', TIMIPWAL 2222 WRITE(LUPRI,9999)'CCRHS_EP cpu:', TIMEPCPU 2223 WRITE(LUPRI,9999)'CCRHS_EP wall:',TIMEPWAL 2224 WRITE(LUPRI,9999)'CCRHS_GP cpu:', TIMGPCPU 2225 WRITE(LUPRI,9999)'CCRHS_GP wall:', TIMGPWAL 2226 WRITE(LUPRI,9999)'R12 cpu:', TIMR12CPU 2227 WRITE(LUPRI,9999)'R12 wall:', TIMR12WAL 2228 WRITE(LUPRI,9999) 'INTEG. R12 ', TIMINTR12 2229 WRITE(LUPRI,9999) 'RDAO R12 ', TIMRDAOR12 2230 END IF 2231 ENDIF 22329999 FORMAT(7x,'Time used in',2x,A12,2x,': ',f10.2,' seconds') 2233C 2234C----------------------------------------- 2235C Restore the CC amplitudes from disk. 2236C----------------------------------------- 2237C 2238 REWIND (LURHS1) 2239 READ(LURHS1) (T1AM(I), I = 1,NT1AMX) 2240 READ(LURHS1) (T2AM(I), I = 1,NT2AMX) 2241 CALL GPCLOSE(LURHS1,'DELETE') 2242C 2243C----------------- 2244C Close files. 2245C----------------- 2246C 2247 IF (DUMPCD) THEN 2248 CALL WCLOSE2(LUC,CFIL,'KEEP') 2249 CALL WCLOSE2(LUD,DFIL,'KEEP') 2250 END IF 2251C 2252 IF (CCSDT) THEN 2253 CALL WCLOSE2(LU3SRT,FN3SRT,'KEEP') 2254 CALL WCLOSE2(LUCKJD,FNCKJD,'KEEP') 2255 CALL WCLOSE2(LUDELD,FNDELD,'KEEP') 2256 CALL WCLOSE2(LUDKBC,FNDKBC,'KEEP') 2257 CALL WCLOSE2(LUTOC,FNTOC,'KEEP') 2258 CALL WCLOSE2(LU3VI,FN3VI,'KEEP') 2259 CALL WCLOSE2(LU3VI2,FN3VI2,'KEEP') 2260 ENDIF 2261 2262 IF (CCSDR12 .AND. (IANR12.EQ.2.OR.IANR12.EQ.3)) THEN 2263 CALL WCLOSE2(LUIADJ,FNIADJ,'KEEP') 2264 CALL WCLOSE2(LUIJDA,FNIJDA,'KEEP') 2265 CALL WCLOSE2(LUCP,CPFIL,'KEEP') 2266 CALL WCLOSE2(LUDP,DPFIL,'KEEP') 2267 END IF 2268C 2269C----------------------- 2270C Restore CC1B flag. 2271C----------------------- 2272C 2273 CC1B = CC1BSA 2274C 2275 CALL QEXIT('CCRHSN') 2276C 2277 RETURN 2278 END 2279C /* Deck ccrhs_e */ 2280 SUBROUTINE CCRHS_E(OMEGA2,T2AM,EMAT1,EMAT2,WORK,LWORK, 2281 * ISYMTR,ISYMIM) 2282C 2283C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 2284C Written by Henrik Koch & Ove Christiansen 20-Jan-1994 2285C Symmetry 3-aug 2286C Contraction of EI intermediates with double excitaion amplitudes. 2287C It is assumed that the fock matrix is included. OC 13-1-1995 2288C 2289C Purpose: Calculate E-terms 2290C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 2291C 2292#include "implicit.h" 2293 PARAMETER(ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) 2294 DIMENSION EMAT1(*),EMAT2(*) 2295 DIMENSION T2AM(*),OMEGA2(*) 2296 DIMENSION WORK(LWORK) 2297#include "priunit.h" 2298#include "ccorb.h" 2299#include "ccsdsym.h" 2300#include "ccsdinp.h" 2301C 2302 INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J 2303C 2304C-------------------------------------------------------------- 2305C Contract and accumulate the first intermediate in OMEGA2. 2306C-------------------------------------------------------------- 2307C 2308 ISYAIBJ = MULD2H(ISYMTR,ISYMIM) 2309C 2310 DO 300 ISYMAI = 1,NSYM 2311C 2312 ISYMCJ = MULD2H(ISYMAI,ISYMTR) 2313 ISYMBJ = MULD2H(ISYMAI,ISYAIBJ) 2314C 2315 IF (LWORK .LT. NT1AM(ISYMBJ)) THEN 2316 CALL QUIT('Insufficient space for allocation in CCRHS_E1') 2317 END IF 2318C 2319 DO 310 NAI = 1,NT1AM(ISYMAI) 2320C 2321 CALL DZERO(WORK,NT1AM(ISYMBJ)) 2322C 2323 DO 320 ISYMJ = 1,NSYM 2324C 2325 ISYMC = MULD2H(ISYMJ,ISYMCJ) 2326 ISYMB = MULD2H(ISYMJ,ISYMBJ) 2327C 2328 NVIRB = MAX(NVIR(ISYMB),1) 2329 NVIRC = MAX(NVIR(ISYMC),1) 2330C 2331 KOFF1 = IMATAB(ISYMB,ISYMC) + 1 2332 KOFF2 = IT2SQ(ISYMCJ,ISYMAI) + NT1AM(ISYMCJ)*(NAI - 1) 2333 * + IT1AM(ISYMC,ISYMJ) + 1 2334 KOFF3 = IT1AM(ISYMB,ISYMJ) + 1 2335C 2336 CALL DGEMM('N','N',NVIR(ISYMB),NRHF(ISYMJ), 2337 * NVIR(ISYMC),ONE,EMAT1(KOFF1),NVIRB, 2338 * T2AM(KOFF2),NVIRC, 2339 * ONE,WORK(KOFF3),NVIRB) 2340 320 CONTINUE 2341C 2342 IF (ISYMAI .EQ. ISYMBJ ) THEN 2343C 2344 WORK(NAI) = TWO*WORK(NAI) 2345 DO 330 NBJ = 1,NT1AM(ISYMBJ) 2346 NAIBJ = IT2AM(ISYMAI,ISYMBJ) + INDEX(NAI,NBJ) 2347 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + WORK(NBJ) 2348 330 CONTINUE 2349C 2350 ENDIF 2351C 2352 IF (ISYMAI .LT. ISYMBJ) THEN 2353C 2354 DO 340 NBJ = 1,NT1AM(ISYMBJ) 2355 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 2356 * + NT1AM(ISYMAI)*(NBJ - 1) + NAI 2357 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + WORK(NBJ) 2358 340 CONTINUE 2359C 2360 ENDIF 2361C 2362 IF (ISYMBJ .LT. ISYMAI) THEN 2363C 2364 DO 350 NBJ = 1,NT1AM(ISYMBJ) 2365 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 2366 * + NT1AM(ISYMBJ)*(NAI - 1) + NBJ 2367 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + WORK(NBJ) 2368 350 CONTINUE 2369C 2370 ENDIF 2371C 2372 310 CONTINUE 2373 300 CONTINUE 2374C 2375C----------------------------------------------------- 2376C Contract and accumulate the second intermediate. 2377C----------------------------------------------------- 2378C 2379C 2380 DO 400 ISYMAI = 1,NSYM 2381C 2382 ISYMBK = MULD2H(ISYMAI,ISYMTR) 2383 ISYMBJ = MULD2H(ISYMAI,ISYAIBJ) 2384C 2385 IF (LWORK .LT. NT1AM(ISYMBJ)) THEN 2386 CALL QUIT('Insufficient space for allocation in CCRHS_E1') 2387 END IF 2388C 2389 DO 410 NAI = 1,NT1AM(ISYMAI) 2390C 2391 CALL DZERO(WORK,NT1AM(ISYMBJ)) 2392C 2393 DO 420 ISYMB = 1,NSYM 2394C 2395 ISYMJ = MULD2H(ISYMB,ISYMBJ) 2396 ISYMK = MULD2H(ISYMJ,ISYMIM) 2397C 2398 NVIRB = MAX(NVIR(ISYMB),1) 2399 NRHFK = MAX(NRHF(ISYMK),1) 2400C 2401 KOFF1 = IT2SQ(ISYMBK,ISYMAI) + NT1AM(ISYMBK)*(NAI - 1) 2402 * + IT1AM(ISYMB,ISYMK) + 1 2403 KOFF2 = IMATIJ(ISYMK,ISYMJ) + 1 2404 KOFF3 = IT1AM(ISYMB,ISYMJ) + 1 2405C 2406 CALL DGEMM('N','N',NVIR(ISYMB),NRHF(ISYMJ), 2407 * NRHF(ISYMK),ONE,T2AM(KOFF1),NVIRB, 2408 * EMAT2(KOFF2),NRHFK, 2409 * ONE,WORK(KOFF3),NVIRB) 2410 420 CONTINUE 2411C 2412C 2413 IF (ISYMAI .EQ. ISYMBJ ) THEN 2414C 2415 WORK(NAI) = TWO*WORK(NAI) 2416C 2417 DO 430 NBJ = 1,NT1AM(ISYMBJ) 2418 NAIBJ = IT2AM(ISYMAI,ISYMBJ) + INDEX(NAI,NBJ) 2419 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) - WORK(NBJ) 2420 430 CONTINUE 2421C 2422 ENDIF 2423C 2424 IF (ISYMAI .LT. ISYMBJ) THEN 2425C 2426 DO 440 NBJ = 1,NT1AM(ISYMBJ) 2427 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 2428 * + NT1AM(ISYMAI)*(NBJ - 1) + NAI 2429 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) - WORK(NBJ) 2430 440 CONTINUE 2431C 2432 ENDIF 2433C 2434 IF (ISYMBJ .LT. ISYMAI) THEN 2435C 2436 DO 450 NBJ = 1,NT1AM(ISYMBJ) 2437 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 2438 * + NT1AM(ISYMBJ)*(NAI - 1) + NBJ 2439 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) - WORK(NBJ) 2440 450 CONTINUE 2441C 2442 ENDIF 2443C 2444 410 CONTINUE 2445 400 CONTINUE 2446C 2447 RETURN 2448 END 2449C /* Deck ccrhs_i */ 2450 SUBROUTINE CCRHS_I(OMEGA1,T2AM,FOCK,WORK,LWORK,ISYMT2,ISYMCK) 2451C 2452C Written by Henrik Koch & Ove Christiansen 20-Jan-1994 2453C 2454C Purpose: Calculate I-term. 2455C 2456#include "implicit.h" 2457 PARAMETER(ONE=1.0D0) 2458 DIMENSION OMEGA1(*),WORK(*) 2459 DIMENSION T2AM(*),FOCK(*) 2460#include "priunit.h" 2461#include "ccorb.h" 2462#include "ccsdsym.h" 2463C 2464C-------------------------------- 2465C Calculate the contribution. 2466C-------------------------------- 2467C 2468 ISYMAI = MULD2H(ISYMT2,ISYMCK) 2469C 2470 KSCR1 = 1 2471 KEND1 = KSCR1 + NT1AM(ISYMCK) 2472 LWRK1 = LWORK - KEND1 2473C 2474 IF (LWRK1 .LT. 0) THEN 2475 CALL QUIT('Insufficient space for allocation in CCRHS_I') 2476 END IF 2477C 2478 DO 110 ISYMK = 1,NSYM 2479C 2480 ISYMC = MULD2H(ISYMK,ISYMCK) 2481C 2482 NVIRC = MAX(NVIR(ISYMC),1) 2483C 2484 DO 120 K = 1,NRHF(ISYMK) 2485C 2486 KOFF1 = IFCVIR(ISYMK,ISYMC) + K 2487 KOFF2 = KSCR1 + IT1AM(ISYMC,ISYMK) + NVIR(ISYMC)*(K - 1) 2488C 2489 CALL DCOPY(NVIR(ISYMC),FOCK(KOFF1),NORB(ISYMK), 2490 * WORK(KOFF2),1) 2491C 2492 120 CONTINUE 2493C 2494 110 CONTINUE 2495C 2496 NTOTAI = MAX(NT1AM(ISYMAI),1) 2497C 2498 KOFF3 = IT2SQ(ISYMAI,ISYMCK) + 1 2499C 2500 CALL DGEMV('N',NT1AM(ISYMAI),NT1AM(ISYMCK),ONE,T2AM(KOFF3), 2501 * NTOTAI,WORK(KSCR1),1,ONE,OMEGA1,1) 2502C 2503 RETURN 2504 END 2505 SUBROUTINE CCRHS_A(OMEGA2,T2AM,GAMMA,WORK,LWORK,ISYGAM,ISYVEC, 2506 * IOPT) 2507C 2508C Written by Henrik Koch & Ove Christiansen 20-Jan-1994 2509C 2510C Generalised to non. total sym gamma (isygam) og non. tot. sym 2511C double excitation vector (isyvec) Ove Christiansen 29-7-1995 2512C 2513C Generalised to handle left hand side contribution (IOPT 2) as 2514C well as usual contributions (IOPT 1) by Asger Halkier 22/11-95. 2515C 2516C Purpose: Calculate A-term. 2517C 2518#include "implicit.h" 2519 PARAMETER(ZERO=0.0D0, ONE=1.0D0) 2520 DIMENSION OMEGA2(*),GAMMA(*),T2AM(*),WORK(LWORK) 2521#include "priunit.h" 2522#include "ccorb.h" 2523#include "ccsdsym.h" 2524C 2525 INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J 2526C 2527C---------------------------- 2528C Calculate contribution. 2529C---------------------------- 2530C 2531 ISAIBJ = MULD2H(ISYGAM,ISYVEC) 2532C 2533 DO 100 ISYMLJ = 1,NSYM 2534C 2535 ISYMKI = MULD2H(ISYMLJ,ISYGAM) 2536C 2537 KSCR1 = 1 2538 KEND1 = KSCR1 + NMATIJ(ISYMKI) 2539 LWRK1 = LWORK - KEND1 2540C 2541 IF (LWRK1 .LT. 0) THEN 2542 CALL QUIT('Insufficient space for allocation in CCRHS_A') 2543 END IF 2544C 2545 DO 110 ISYMJ = 1,NSYM 2546C 2547 ISYML = MULD2H(ISYMJ,ISYMLJ) 2548C 2549 DO 120 J = 1,NRHF(ISYMJ) 2550C 2551 DO 130 L = 1,NRHF(ISYML) 2552C 2553 IF (IOPT .EQ. 1) THEN 2554C 2555 NLJ = IMATIJ(ISYML,ISYMJ) 2556 * + NRHF(ISYML)*(J - 1) + L 2557C 2558 ELSE IF (IOPT .EQ. 2) THEN 2559C 2560 NLJ = IMATIJ(ISYMJ,ISYML) 2561 * + NRHF(ISYMJ)*(L - 1) + J 2562C 2563 ENDIF 2564C 2565 DO 140 ISYMK = 1,NSYM 2566C 2567 ISYMI = MULD2H(ISYMK,ISYMKI) 2568C 2569 DO 150 I = 1,NRHF(ISYMI) 2570C 2571 DO 160 K = 1,NRHF(ISYMK) 2572C 2573 IF (IOPT .EQ. 1) THEN 2574C 2575 NKI = IMATIJ(ISYMK,ISYMI) 2576 * + NRHF(ISYMK)*(I - 1) + K 2577C 2578 ELSE IF (IOPT .EQ. 2) THEN 2579C 2580 NKI = IMATIJ(ISYMI,ISYMK) 2581 * + NRHF(ISYMI)*(K - 1) + I 2582C 2583 ENDIF 2584C 2585 IF (ISYMKI .EQ. ISYMLJ) THEN 2586 NKILJ = IGAMMA(ISYMKI,ISYMLJ) 2587 * + INDEX(NKI,NLJ) 2588 ELSE 2589 IF (ISYMKI .LT. ISYMLJ) THEN 2590 NKILJ = IGAMMA(ISYMKI,ISYMLJ) 2591 * + NMATIJ(ISYMKI)*(NLJ - 1) + NKI 2592 ELSE 2593 NKILJ = IGAMMA(ISYMLJ,ISYMKI) 2594 * + NMATIJ(ISYMLJ)*(NKI - 1) + NLJ 2595 ENDIF 2596 ENDIF 2597C 2598 NSTO = IMATIJ(ISYMK,ISYMI) 2599 * + NRHF(ISYMK)*(I - 1) + K 2600C 2601 WORK(KSCR1 + NSTO - 1) = GAMMA(NKILJ) 2602C 2603 160 CONTINUE 2604 150 CONTINUE 2605 140 CONTINUE 2606C 2607 DO 170 ISYMB = 1,NSYM 2608C 2609 ISYMBJ = MULD2H(ISYMB,ISYMJ) 2610 ISYMAI = MULD2H(ISYMBJ,ISAIBJ) 2611 ISYMBL = MULD2H(ISYMB,ISYML) 2612 ISYMAK = MULD2H(ISYVEC,ISYMBL) 2613C 2614 KSCR2 = KEND1 2615 KEND2 = KSCR2 + NT1AM(ISYMAI) 2616 LWRK2 = LWORK - KEND2 2617C 2618 IF (LWRK2 .LT. 0) THEN 2619 CALL QUIT('Insufficient space in CCRHS_A') 2620 END IF 2621C 2622 IF (ISYMAI .GT. ISYMBJ) GOTO 170 2623C 2624 DO 180 B = 1,NVIR(ISYMB) 2625C 2626 NBJ = IT1AM(ISYMB,ISYMJ) 2627 * + NVIR(ISYMB)*(J - 1) + B 2628 NBL = IT1AM(ISYMB,ISYML) 2629 * + NVIR(ISYMB)*(L - 1) + B 2630C 2631 CALL DZERO(WORK(KSCR2),NT1AM(ISYMAI)) 2632C 2633 DO 190 ISYMI = 1,NSYM 2634C 2635 ISYMK = MULD2H(ISYMI,ISYMKI) 2636 ISYMA = MULD2H(ISYMK,ISYMAK) 2637C 2638 NVIRA = MAX(NVIR(ISYMA),1) 2639 NRHFK = MAX(NRHF(ISYMK),1) 2640C 2641 KOFF1 = IT2SQ(ISYMAK,ISYMBL) 2642 * + NT1AM(ISYMAK)*(NBL - 1) 2643 * + IT1AM(ISYMA,ISYMK) + 1 2644 KOFF2 = KSCR1 + IMATIJ(ISYMK,ISYMI) 2645 KOFF3 = KSCR2 + IT1AM(ISYMA,ISYMI) 2646C 2647 CALL DGEMM('N','N',NVIR(ISYMA),NRHF(ISYMI), 2648 * NRHF(ISYMK),ONE,T2AM(KOFF1), 2649 * NVIRA,WORK(KOFF2),NRHFK,ZERO, 2650 * WORK(KOFF3),NVIRA) 2651C 2652 190 CONTINUE 2653C 2654 IF (ISYMAI .EQ. ISYMBJ) THEN 2655 NTOT = NBJ 2656 ELSE 2657 NTOT = NT1AM(ISYMAI) 2658 ENDIF 2659C 2660 DO 200 NAI = 1,NTOT 2661C 2662 IF (ISYMAI .EQ. ISYMBJ) THEN 2663 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 2664 * + INDEX(NAI,NBJ) 2665 ELSE 2666 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 2667 * + NT1AM(ISYMAI)*(NBJ - 1) + NAI 2668 ENDIF 2669C 2670 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) 2671 * + WORK(KSCR2 + NAI - 1) 2672C 2673 200 CONTINUE 2674C 2675 180 CONTINUE 2676 170 CONTINUE 2677C 2678 130 CONTINUE 2679 120 CONTINUE 2680 110 CONTINUE 2681 100 CONTINUE 2682C 2683 RETURN 2684 END 2685C /* Deck ccrhs_j */ 2686 SUBROUTINE CCRHS_J(OMEGA1,ISYM,FOCK) 2687C 2688C Written by Henrik Koch & Ove Christiansen 19-Jan-1994 2689C 2690C Purpose: Calculate J-term. 2691C 2692#include "implicit.h" 2693 DIMENSION FOCK(*),OMEGA1(*) 2694#include "priunit.h" 2695#include "ccorb.h" 2696#include "ccsdsym.h" 2697C 2698C-------------------- 2699C Calculate term. 2700C-------------------- 2701C 2702 DO 100 ISYMI = 1,NSYM 2703C 2704 ISYMA = MULD2H(ISYMI,ISYM) 2705C 2706 DO 110 I = 1,NRHF(ISYMI) 2707C 2708 DO 120 A = 1,NVIR(ISYMA) 2709C 2710 KOFF1 = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + A 2711 KOFF2 = IFCRHF(ISYMA,ISYMI) + NORB(ISYMA)*(I - 1) 2712 * + NRHF(ISYMA) + A 2713C 2714 OMEGA1(KOFF1) = OMEGA1(KOFF1) + FOCK(KOFF2) 2715C 2716 120 CONTINUE 2717 110 CONTINUE 2718C 2719 100 CONTINUE 2720C 2721 RETURN 2722 END 2723C /* Deck cc_fckmo */ 2724 SUBROUTINE CC_FCKMO(FOCK,XLAMDP,XLAMDH,WORK,LWORK,ISYFAO, 2725 * ISYMPA,ISYMHO) 2726C 2727C Written by Henrik Koch & Ove Christiansen 19-Jan-1994 2728C Symmetry by Henrik Koch and Alfredo Sanchez. 11-July-1994 2729C 2730C Ove Christiansen 14-7-1994 generalized to 1. non-tot.symmetric FockAO 2731C 2. non-tot symmetric LAM. 2732C 2733C Filip Pawlowski 03-Jan-2007: introduced zeroing of fock array as 2734C a symmetry bug fix 2735C 2736C ISYFAO is the symmtry of the AO fock matrix. 2737C isymp(isymh) is the symmetry of lamp(lamh) 2738C 2739C Purpose: Calculate MO Fock Matrix. 2740C 2741#include "implicit.h" 2742 PARAMETER (ONE = 1.0D0, ZERO = 0.0D0) 2743 DIMENSION FOCK(*),XLAMDP(*),XLAMDH(*),WORK(LWORK) 2744#include "priunit.h" 2745#include "ccorb.h" 2746#include "ccsdsym.h" 2747C 2748 ISYML = MULD2H(ISYMPA,ISYMHO) 2749 ISYFMO = MULD2H(ISYML,ISYFAO) 2750C 2751 KFOCK = 1 2752 KEND1 = KFOCK + N2BST(ISYFMO) 2753 LWRK1 = LWORK - KEND1 2754C 2755 KOFF1 = 1 2756 KOFF2 = KFOCK 2757C 2758 DO 100 ISYMQ = 1,NSYM 2759C 2760 ISYMB = MULD2H(ISYMQ,ISYMHO) 2761 ISYMA = MULD2H(ISYMB,ISYFAO) 2762 ISYMP = MULD2H(ISYFMO,ISYMQ) 2763C 2764C----------------------------------------- 2765C Dynamic allocation of work space. 2766C----------------------------------------- 2767C 2768 NBQ = NBAS(ISYMB)*NORB(ISYMQ) 2769 NAP = NBAS(ISYMA)*NORB(ISYMP) 2770 KLAMDA = KEND1 2771 KSCR1 = KLAMDA + MAX(NAP,NBQ) 2772 KEND2 = KSCR1 + NBAS(ISYMA)*NORB(ISYMQ) 2773 LWRK2 = LWORK - KEND2 2774 IF (LWRK2 .LT. 0) THEN 2775 CALL QUIT('Insufficient space in CC_FCKMO') 2776 ENDIF 2777C 2778C----------------------------------------- 2779C Copy transformation coefficients. 2780C----------------------------------------- 2781C 2782 NTOTR = NBAS(ISYMB)*NRHF(ISYMQ) 2783 KOFF = IGLMRH(ISYMB,ISYMQ) + 1 2784 CALL DCOPY(NTOTR,XLAMDH(KOFF),1,WORK(KLAMDA),1) 2785C 2786 NTOTV = NBAS(ISYMB)*NVIR(ISYMQ) 2787 KOFF = IGLMVI(ISYMB,ISYMQ) + 1 2788 CALL DCOPY(NTOTV,XLAMDH(KOFF),1,WORK(KLAMDA+NTOTR),1) 2789C 2790C---------------------------------------- 2791C Do first partial transformation. 2792C---------------------------------------- 2793C 2794 NBASB = MAX(NBAS(ISYMB),1) 2795 NBASA = MAX(NBAS(ISYMA),1) 2796C 2797 KOFF1 = IAODIS(ISYMA,ISYMB) + 1 2798C 2799 CALL DGEMM('N','N',NBAS(ISYMA),NORB(ISYMQ),NBAS(ISYMB), 2800 * ONE,FOCK(KOFF1),NBASA,WORK(KLAMDA),NBASB, 2801 * ZERO,WORK(KSCR1),NBASA) 2802C 2803C----------------------------------------- 2804C Copy transformation coefficients. 2805C----------------------------------------- 2806C 2807 NTOTR = NBAS(ISYMA)*NRHF(ISYMP) 2808 KOFF = IGLMRH(ISYMA,ISYMP) + 1 2809 CALL DCOPY(NTOTR,XLAMDP(KOFF),1,WORK(KLAMDA),1) 2810C 2811 NTOTV = NBAS(ISYMA)*NVIR(ISYMP) 2812 KOFF = IGLMVI(ISYMA,ISYMP) + 1 2813 CALL DCOPY(NTOTV,XLAMDP(KOFF),1,WORK(KLAMDA+NTOTR),1) 2814C 2815C----------------------------------------- 2816C Do second partial transformation. 2817C----------------------------------------- 2818C 2819 NBASA = MAX(NBAS(ISYMA),1) 2820 NORBP = MAX(NORB(ISYMP),1) 2821C 2822 CALL DGEMM('T','N',NORB(ISYMP),NORB(ISYMQ),NBAS(ISYMA),ONE, 2823 * WORK(KLAMDA),NBASA,WORK(KSCR1),NBASA,ZERO, 2824 * WORK(KOFF2),NORBP) 2825C 2826 KOFF2 = KOFF2 + NORB(ISYMP)*NORB(ISYMQ) 2827C 2828 100 CONTINUE 2829C 2830C----------------------------------------------------- 2831C Reorder the Fock matrix in occupied and virtual. 2832C----------------------------------------------------- 2833C 2834 KOFF1 = KFOCK 2835 KOFF2 = 1 2836 KOFF3 = NLRHFR(ISYFMO) + 1 2837 2838 CALL DZERO(FOCK,N2BST(ISYFMO)) 2839 2840 DO 110 ISYMQ = 1,NSYM 2841C 2842 ISYMP = MULD2H(ISYMQ,ISYFMO) 2843C 2844 NTOTR = NORB(ISYMP)*NRHF(ISYMQ) 2845 CALL DCOPY(NTOTR,WORK(KOFF1),1,FOCK(KOFF2),1) 2846C 2847 NTOTV = NORB(ISYMP)*NVIR(ISYMQ) 2848 CALL DCOPY(NTOTV,WORK(KOFF1+NTOTR),1,FOCK(KOFF3),1) 2849C 2850 KOFF1 = KOFF1 + NORB(ISYMP)*NORB(ISYMQ) 2851 KOFF2 = KOFF2 + NORB(ISYMP)*NRHF(ISYMQ) 2852 KOFF3 = KOFF3 + NORB(ISYMP)*NVIR(ISYMQ) 2853C 2854 110 CONTINUE 2855C 2856 END 2857C /* Deck ccrhs_h */ 2858 SUBROUTINE CCRHS_H(DSRHF,OMEGA1,XLAMDP,XLAMDH,SCRM, 2859 * WORK,LWORK,ISYDIS,ISYDEL,ISYMTR) 2860C 2861C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 2862C Written by Henrik Koch & Ove Christiansen 19-Jan-1994 2863C Generalized to do linear transformation parts by 2864C OC 30-1-1995 2865C 2866C Purpose: Calculate H-term. 2867C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 2868C 2869#include "implicit.h" 2870 PARAMETER (ONE = 1.0D0, TWO = 2.0D0) 2871 DIMENSION DSRHF(*),OMEGA1(*),XLAMDH(*),WORK(LWORK) 2872 DIMENSION XLAMDP(*),SCRM(*) 2873#include "priunit.h" 2874#include "ccorb.h" 2875#include "ccsdsym.h" 2876C 2877C-------------------------------- 2878C Calculate the contribution. 2879C-------------------------------- 2880C 2881 CALL CCRHS_H1(DSRHF,OMEGA1,SCRM,XLAMDP,XLAMDH,WORK,LWORK, 2882 * ISYDIS,ISYDEL,ISYMTR) 2883C 2884C 2885 RETURN 2886 END 2887 SUBROUTINE CCRHS_H1(DSRHF,OMEGA1,SCRM,XLAMDP,XLAMDH,WORK,LWORK, 2888 * ISYDIS,ISYDEL,ISYMTR) 2889C 2890C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 2891C Written by Henrik Koch & Ove Christiansen 19-Jan-1994 2892C Generalized to do linear transformation parts by 2893C OC 30-1-1995 2894C 2895C Purpose: Calculate H-term. 2896C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 2897C 2898#include "implicit.h" 2899 PARAMETER(ZERO=0.0D0,ONE=1.0D0) 2900 DIMENSION DSRHF(*),OMEGA1(*),SCRM(*) 2901 DIMENSION XLAMDP(*),XLAMDH(*),WORK(LWORK) 2902#include "priunit.h" 2903#include "ccorb.h" 2904#include "ccsdsym.h" 2905C 2906C INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J 2907C 2908C-------------------------------------- 2909C Calculate contribution. 2910C-------------------------------------- 2911C 2912 ISYAKL = MULD2H(ISYMTR,ISYDEL) 2913C 2914 DO 100 ISYML = 1,NSYM 2915C 2916 ISYMGB = MULD2H(ISYML,ISYDIS) 2917 ISYMAK = MULD2H(ISYML,ISYAKL) 2918 ISYMKI = ISYMGB 2919C 2920 KSCR1 = 1 2921 KEND1 = KSCR1 + N2BST(ISYMGB) 2922 LWRK1 = LWORK - KEND1 2923C 2924 IF (LWRK1 .LT. 0) THEN 2925 WRITE(LUPRI,*) 'Need : ',KEND1,'Available : ',LWORK 2926 CALL QUIT('Insufficient space in CCRHS_H1') 2927 ENDIF 2928C 2929 DO 110 L = 1,NRHF(ISYML) 2930C 2931 KOFF1 = IDSRHF(ISYMGB,ISYML) + NNBST(ISYMGB)*(L - 1) + 1 2932 CALL CCSD_SYMSQ(DSRHF(KOFF1),ISYMGB,WORK(KSCR1)) 2933C 2934 DO 120 ISYMI = 1,NSYM 2935C 2936 ISYMB = ISYMI 2937 ISYMG = MULD2H(ISYMB,ISYMGB) 2938 ISYMK = ISYMG 2939 ISYMA = MULD2H(ISYMK,ISYMAK) 2940C 2941 KSCR2 = KEND1 2942 KSCR3 = KSCR2 + NBAS(ISYMG)*NRHF(ISYMI) 2943 KEND2 = KSCR3 + NRHF(ISYMK)*NRHF(ISYMI) 2944 LWRK2 = LWORK - KEND2 2945C 2946 IF (LWRK2 .LT. 0) THEN 2947 WRITE(LUPRI,*) 'Need : ',KEND2,'Available : ',LWORK 2948 CALL QUIT('Insufficient space in CCRHS_H1') 2949 ENDIF 2950C 2951 NBASG = MAX(NBAS(ISYMG),1) 2952 NBASB = MAX(NBAS(ISYMB),1) 2953 NRHFK = MAX(NRHF(ISYMK),1) 2954 NVIRA = MAX(NVIR(ISYMA),1) 2955C 2956 KOFF2 = KSCR1 + IAODIS(ISYMG,ISYMB) 2957 KOFF3 = ILMRHF(ISYMI) + 1 2958C 2959 CALL DGEMM('N','N',NBAS(ISYMG),NRHF(ISYMI),NBAS(ISYMB), 2960 * ONE,WORK(KOFF2),NBASG,XLAMDH(KOFF3),NBASB, 2961 * ZERO,WORK(KSCR2),NBASG) 2962C 2963 KOFF4 = ILMRHF(ISYMK) + 1 2964C 2965 CALL DGEMM('T','N',NRHF(ISYMK),NRHF(ISYMI),NBAS(ISYMG), 2966 * ONE,XLAMDP(KOFF4),NBASG,WORK(KSCR2),NBASG, 2967 * ZERO,WORK(KSCR3),NRHFK) 2968C 2969 KOFF5 = IT2BCD(ISYMAK,ISYML) + NT1AM(ISYMAK)*(L - 1) 2970 * + IT1AM(ISYMA,ISYMK) + 1 2971 KOFF6 = IT1AM(ISYMA,ISYMI) + 1 2972C 2973 CALL DGEMM('N','N',NVIR(ISYMA),NRHF(ISYMI),NRHF(ISYMK), 2974 * -ONE,SCRM(KOFF5),NVIRA,WORK(KSCR3),NRHFK, 2975 * ONE,OMEGA1(KOFF6),NVIRA) 2976C 2977 120 CONTINUE 2978C 2979 110 CONTINUE 2980C 2981 100 CONTINUE 2982C 2983 RETURN 2984 END 2985C /* Deck ccrhs_g */ 2986 SUBROUTINE CCRHS_G(DSRHF,OMEGA1,XLAMP1,ISYMP1,XLAMH1,ISYMH1,SCRM, 2987 * WORK,LWORK,ISYDIS,ISYDEL,ISYMTR) 2988C 2989C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 2990C Written by Henrik Koch & Ove Christiansen 19-Jan-1994 2991C Generalized to calculated term of linear transformation 2992C and handle different transformations on integral indices by OC 30-1-1995 2993C 2994C G(a,i) = sum(cdk)[t(ci,dk)*Lackd] 2995C G(a,i)for fixed del = sum(ck)[M(ci,k)*L(alfa gamma k] 2996C 2997C XLAMP1 is the transformation matrix for a ; XLAMP or a oneindex transformed. 2998C XLAMH1 is the transformation matrix for c ; XLAMH or a oneindex transformed. 2999C DSRHF is the (alfa gamma | k) array for a given delta. 3000C 3001C not implemented yet with DSRHF and SCRM index transformed. 3002C 3003C tested for energy with symmetry: ordinary XLAM matrices - OC 10-2-1995 3004C tested for linear transformation without symmetry. - OC spring 95. 3005C 3006C Purpose: Calculate G-term. 3007C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 3008C 3009#include "implicit.h" 3010 PARAMETER (ONE = 1.0D0, TWO = 2.0D0) 3011 DIMENSION DSRHF(*),OMEGA1(*),XLAMP1(*),WORK(LWORK) 3012 DIMENSION XLAMH1(*),SCRM(*) 3013#include "priunit.h" 3014#include "ccorb.h" 3015#include "ccsdsym.h" 3016C 3017C------------------------ 3018C Dynamic allocation. 3019C------------------------ 3020C 3021 ISYINT = MULD2H(ISYMH1,ISYMOP) 3022 ISYALI = MULD2H(ISYINT,ISYMTR) 3023C 3024 KSCR1 = 1 3025 KEND1 = KSCR1 + NT1AO(ISYALI) 3026 LWRK1 = LWORK - KEND1 3027C 3028 IF (LWRK1 .LT. 0) THEN 3029 WRITE(LUPRI,*) 'Need : ',KEND1,'Available : ',LWORK 3030 CALL QUIT('Insufficient space in CCRHS_G') 3031 ENDIF 3032C 3033C-------------------------------- 3034C Calculate the contribution. 3035C-------------------------------- 3036C 3037 CALL CCRHS_G1(DSRHF,OMEGA1,SCRM,XLAMP1,ISYMP1,XLAMH1,ISYMH1, 3038 * WORK(KSCR1),WORK(KEND1),LWRK1,ISYDIS,ISYDEL,ISYMTR) 3039C 3040C 3041 RETURN 3042 END 3043 SUBROUTINE CCRHS_G1(DSRHF,OMEGA1,SCRM,XLAMP1,ISYMP1,XLAMH1,ISYMH1, 3044 * SCR1,WORK,LWORK,ISYDIS,ISYDEL,ISYMTR) 3045C 3046C 3047C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 3048C Written by Henrik Koch & Ove Christiansen 19-Jan-1994 3049C Generalized to calculated term of linear transformation 3050C by OC 30-1-1995 3051C 3052C Purpose: Calculate G-term. 3053C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 3054C 3055#include "implicit.h" 3056 PARAMETER(ZERO=0.0D0,ONE=1.0D0) 3057 PARAMETER(TWO=2.0D0) 3058 DIMENSION DSRHF(*),OMEGA1(*),SCRM(*),SCR1(*) 3059 DIMENSION XLAMP1(*),XLAMH1(*),WORK(LWORK) 3060#include "priunit.h" 3061#include "ccorb.h" 3062#include "ccsdsym.h" 3063C 3064C INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J 3065C 3066 ISYINT = MULD2H(ISYMH1,ISYMOP) 3067 ISYALI = MULD2H(ISYINT,ISYMTR) 3068 ISYMAI = MULD2H(ISYALI,ISYMP1) 3069 ISYCIK = MULD2H(ISYMTR,ISYDEL) 3070C 3071 CALL DZERO(SCR1,NT1AO(ISYMAI)) 3072C 3073 DO 100 ISYMK = 1,NSYM 3074C 3075 ISYMAG = MULD2H(ISYMK,ISYDIS) 3076 ISYMCI = MULD2H(ISYMK,ISYCIK) 3077 ISYMGI = MULD2H(ISYALI,ISYMAG) 3078C 3079 KSCR10 = 1 3080 KEND1 = KSCR10 + N2BST(ISYMAG) 3081 LWRK1 = LWORK - KEND1 3082C 3083 IF (LWRK1 .LT. 0) THEN 3084 WRITE(LUPRI,*) 'Need : ',KEND1,'Available : ',LWORK 3085 CALL QUIT('Insufficient space in CCRHS_G1') 3086 ENDIF 3087C 3088 DO 110 K = 1,NRHF(ISYMK) 3089C 3090 KOFF1 = IDSRHF(ISYMAG,ISYMK) + NNBST(ISYMAG)*(K - 1) + 1 3091 CALL CCSD_SYMSQ(DSRHF(KOFF1),ISYMAG,WORK(KSCR10)) 3092C 3093 DO 120 ISYMI = 1,NSYM 3094C 3095 ISYMG = MULD2H(ISYMI,ISYMGI) 3096 ISYMA = MULD2H(ISYMG,ISYMAG) 3097 ISYMC = ISYMG 3098C 3099 NBASG = MAX(NBAS(ISYMG),1) 3100 NBASA = MAX(NBAS(ISYMA),1) 3101 NVIRC = MAX(NVIR(ISYMC),1) 3102C 3103 KSCR11 = KEND1 3104 KEND2 = KSCR11 + NBAS(ISYMG)*NRHF(ISYMI) 3105 LWRK2 = LWORK - KEND2 3106C 3107 IF (LWRK2 .LT. 0) THEN 3108 WRITE(LUPRI,*) 'Need : ',KEND2,'Available : ',LWORK 3109 CALL QUIT('Insufficient space in CCRHS_G1') 3110 ENDIF 3111C 3112 KOFF2 = IGLMVI(ISYMG,ISYMC) + 1 3113 KOFF3 = IT2BCD(ISYMCI,ISYMK) + NT1AM(ISYMCI)*(K - 1) 3114 * + IT1AM(ISYMC,ISYMI) + 1 3115C 3116 CALL DGEMM('N','N',NBAS(ISYMG),NRHF(ISYMI),NVIR(ISYMC), 3117 * ONE,XLAMH1(KOFF2),NBASG,SCRM(KOFF3),NVIRC, 3118 * ZERO,WORK(KSCR11),NBASG) 3119C 3120 KOFF4 = KSCR10 + IAODIS(ISYMA,ISYMG) 3121 KOFF6 = IT1AO(ISYMA,ISYMI) + 1 3122C 3123 CALL DGEMM('N','N',NBAS(ISYMA),NRHF(ISYMI),NBAS(ISYMG), 3124 * ONE,WORK(KOFF4),NBASA,WORK(KSCR11),NBASG, 3125 * ONE,SCR1(KOFF6),NBASA) 3126C 3127 120 CONTINUE 3128C 3129 110 CONTINUE 3130C 3131 100 CONTINUE 3132C 3133C---------------------------------------------- 3134C Accumulation into OMEGA1 in the MO basis. 3135C---------------------------------------------- 3136C 3137 DO 200 ISYMI = 1,NSYM 3138C 3139 ISYMA = MULD2H(ISYMI,ISYMAI) 3140 ISYMAL= MULD2H(ISYMI,ISYALI) 3141C 3142 NBASA = MAX(NBAS(ISYMA),1) 3143 NVIRA = MAX(NVIR(ISYMA),1) 3144C 3145 KOFF1 = IGLMVI(ISYMAL,ISYMA) + 1 3146 KOFF2 = IT1AO(ISYMA,ISYMI) + 1 3147 KOFF3 = IT1AM(ISYMA,ISYMI) + 1 3148C 3149 CALL DGEMM('T','N',NVIR(ISYMA),NRHF(ISYMI),NBAS(ISYMA),ONE, 3150 * XLAMP1(KOFF1),NBASA,SCR1(KOFF2),NBASA,ONE, 3151 * OMEGA1(KOFF3),NVIRA) 3152C 3153 200 CONTINUE 3154C 3155 RETURN 3156 END 3157C /* Deck ccrhs_ei */ 3158 SUBROUTINE CCRHS_EI(DSRHF,EMAT1,EMAT2,T2AM,SCRM,XLAMDP,XLAMDH, 3159 * WORK,LWORK,IDEL,ISYMD,ISYDIS,ISYMTR) 3160C 3161C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 3162C Written by Henrik Koch 12-Jan-1994 3163C Symmetry 2-aug 3164C Modified slightly by Ove Christiansen 31-1-95 for construction of 3165C linear transformation intermediates. ISYMTR = SYM OF T2-VEC 3166C 3167C Purpose: Calculate E-intermediates. 3168C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 3169C 3170#include "implicit.h" 3171 PARAMETER (ONE = 1.0D0, TWO = 2.0D0) 3172 DIMENSION EMAT1(*), EMAT2(*) 3173 DIMENSION DSRHF(*),WORK(LWORK) 3174 DIMENSION T2AM(*),SCRM(*) 3175 DIMENSION XLAMDP(*),XLAMDH(*) 3176#include "priunit.h" 3177#include "ccorb.h" 3178#include "ccsdsym.h" 3179C 3180C 3181C------------------------ 3182C Dynamic allocation. 3183C------------------------ 3184C 3185 KSCR1 = 1 3186 KSCR2 = KSCR1 + NT2BCD(ISYDIS) 3187 KSCR3 = KSCR2 + NT2BGD(ISYDIS) 3188 KEND1 = KSCR3 + NT2BGD(ISYDIS) 3189 LWRK1 = LWORK - KEND1 3190C 3191 IF (LWRK1 .LT. 0) THEN 3192 WRITE(LUPRI,*) 'Need : ',KEND1,'Available : ',LWORK 3193 CALL QUIT('Insufficient space in CCRHS_EI') 3194 ENDIF 3195C 3196C-------------------------------- 3197C Calculate the contribution. 3198C-------------------------------- 3199C 3200 CALL CCRHS_EI1(DSRHF,EMAT1,EMAT2,T2AM,SCRM, 3201 * WORK(KSCR1),WORK(KSCR2),WORK(KSCR3), 3202 * XLAMDP,XLAMDH,WORK(KEND1),LWRK1,IDEL, 3203 * ISYMD,ISYDIS,ISYMTR) 3204C 3205 RETURN 3206 END 3207 SUBROUTINE CCRHS_EI1(DSRHF,EMAT1,EMAT2,T2AM,SCRM,SCR1,SCR2, 3208 * SCR3,XLAMDP,XLAMDH,WORK,LWORK,IDEL, 3209 * ISYMD,ISYDIS,ISYMTR) 3210C 3211C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 3212C Written by Henrik Koch 12-Jan-1994 3213C Symmetry 2-aug 3214C Modified slightly by Ove Christiansen 31-1-95 for construction of 3215C linear transformation intermediates. ISYMTR = SYM OF T2-VEC 3216C 3217C Purpose: Calculate E-intermediates. 3218C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 3219C 3220#include "implicit.h" 3221 PARAMETER(ZERO=0.0D0,HALF=0.5D0,ONE=1.0D0,TWO=2.0D0) 3222 DIMENSION DSRHF(*) 3223 DIMENSION EMAT1(*),EMAT2(*) 3224 DIMENSION T2AM(*),SCRM(*) 3225 DIMENSION SCR1(*),SCR2(*),SCR3(*) 3226 DIMENSION XLAMDP(*),XLAMDH(*) 3227 DIMENSION WORK(LWORK) 3228#include "priunit.h" 3229#include "ccorb.h" 3230#include "ccsdsym.h" 3231C 3232C INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J 3233C 3234C 3235C=================================== 3236C First intermediate I(b,delta). 3237C=================================== 3238C 3239C------------------------------------------------------- 3240C Construct the integrals I(dl,m) = (l d | m delta). 3241C------------------------------------------------------- 3242C 3243 DO 100 ISYMM = 1,NSYM 3244C 3245 ISYMAG = MULD2H(ISYMM,ISYDIS) 3246 ISYMDL = ISYMAG 3247 ISYMGL = ISYMAG 3248C 3249 DO 110 M = 1,NRHF(ISYMM) 3250C 3251 KSCR1 = 1 3252 KEND1 = KSCR1 + N2BST(ISYMAG) 3253 LWRK1 = LWORK - KEND1 3254 IF (LWRK1. LT. 0) THEN 3255 CALL QUIT('Insufficient core in CCRHS_EI1') 3256 END IF 3257C 3258 KOFF1 = IDSRHF(ISYMAG,ISYMM) + NNBST(ISYMAG)*(M - 1) + 1 3259 CALL CCSD_SYMSQ(DSRHF(KOFF1),ISYMAG,WORK(KSCR1)) 3260C 3261 DO 120 ISYML = 1,NSYM 3262C 3263 ISYMD1 = MULD2H(ISYML,ISYMDL) 3264 ISYMA = ISYML 3265 ISYMG = ISYMD1 3266C 3267 NBASA = MAX(NBAS(ISYMA),1) 3268 NBASG = MAX(NBAS(ISYMG),1) 3269 NVIRD = MAX(NVIR(ISYMD1),1) 3270C 3271 KOFF2 = KSCR1 + IAODIS(ISYMA,ISYMG) 3272 KOFF3 = ILMRHF(ISYML) + 1 3273 KOFF4 = IT2BGD(ISYMGL,ISYMM) + NT1AO(ISYMGL)*(M - 1) 3274 * + IT1AO(ISYMG,ISYML) + 1 3275C 3276 CALL DGEMM('T','N',NBAS(ISYMG),NRHF(ISYML),NBAS(ISYMA), 3277 * ONE,WORK(KOFF2),NBASA,XLAMDP(KOFF3),NBASA, 3278 * ZERO,SCR2(KOFF4),NBASG) 3279C 3280 KOFF5 = ILMVIR(ISYMD1) + 1 3281 KOFF6 = IT2BCD(ISYMDL,ISYMM) + NT1AM(ISYMDL)*(M - 1) 3282 * + IT1AM(ISYMD1,ISYML) + 1 3283C 3284 CALL DGEMM('T','N',NVIR(ISYMD1),NRHF(ISYML), 3285 * NBAS(ISYMG),ONE,XLAMDH(KOFF5),NBASG, 3286 * SCR2(KOFF4),NBASG,ZERO,SCR1(KOFF6),NVIRD) 3287C 3288 120 CONTINUE 3289C 3290 110 CONTINUE 3291C 3292 100 CONTINUE 3293C 3294C------------------------------------------------------- 3295C Contract the integrals in SCR1 with t2 amplitudes. 3296C------------------------------------------------------- 3297C 3298 DO 200 ISYMM = 1,NSYM 3299C 3300 ISYMDL = MULD2H(ISYMM,ISYDIS) 3301 ISYMBM = MULD2H(ISYMDL,ISYMTR) 3302 ISYMB = MULD2H(ISYMBM,ISYMM) 3303C 3304 DO 210 M = 1,NRHF(ISYMM) 3305C 3306 NT1DL = MAX(NT1AM(ISYMDL),1) 3307C 3308 KBM = IT1AM(ISYMB,ISYMM) + NVIR(ISYMB)*(M - 1) + 1 3309 KOFF1 = IT2SQ(ISYMDL,ISYMBM) 3310 * + NT1AM(ISYMDL)*(KBM - 1) + 1 3311 KOFF2 = IT2BCD(ISYMDL,ISYMM) 3312 * + NT1AM(ISYMDL)*(M - 1) + 1 3313 KOFF3 = IEMAT1(ISYMB,ISYMD) 3314 * + (IDEL - IBAS(ISYMD) - 1)*NVIR(ISYMB) + 1 3315C 3316 CALL DGEMV('T',NT1AM(ISYMDL),NVIR(ISYMB),ONE,T2AM(KOFF1), 3317 * NT1DL,SCR1(KOFF2),1,ONE,EMAT1(KOFF3),1) 3318C 3319 210 CONTINUE 3320C 3321 200 CONTINUE 3322C 3323C================================ 3324C Second intermediate I(k,j). 3325C================================ 3326C 3327C------------------------------------------- 3328C Transform the SCRM amplitudes to SCR3. 3329C------------------------------------------- 3330C 3331 DO 300 ISYMJ = 1,NSYM 3332C 3333 ISYMDJ = MULD2H(ISYMD,ISYMJ) 3334 ISYMEM = MULD2H(ISYMDJ,ISYMTR) 3335 ISYMGM = ISYMEM 3336C 3337 DO 310 J = 1,NRHF(ISYMJ) 3338C 3339 DO 320 ISYMM = 1,NSYM 3340C 3341 ISYME = MULD2H(ISYMM,ISYMEM) 3342 ISYMG = ISYME 3343C 3344 NVIRE = MAX(NVIR(ISYME),1) 3345 NBASG = MAX(NBAS(ISYMG),1) 3346C 3347 KOFF1 = ILMVIR(ISYME) + 1 3348 KOFF2 = IT2BCD(ISYMEM,ISYMJ) + NT1AM(ISYMEM)*(J - 1) 3349 * + IT1AM(ISYME,ISYMM) + 1 3350 KOFF3 = IT2BGD(ISYMGM,ISYMJ) + NT1AO(ISYMGM)*(J - 1) 3351 * + IT1AO(ISYMG,ISYMM) + 1 3352C 3353 CALL DGEMM('N','N',NBAS(ISYMG),NRHF(ISYMM),NVIR(ISYME), 3354 * ONE,XLAMDH(KOFF1),NBASG,SCRM(KOFF2),NVIRE, 3355 * ZERO,SCR3(KOFF3),NBASG) 3356C 3357 320 CONTINUE 3358 310 CONTINUE 3359 300 CONTINUE 3360C 3361C---------------------------------------------------------------- 3362C Contract the integrals in SCR2 with the amplitudes in SCR3. 3363C---------------------------------------------------------------- 3364C 3365 DO 400 ISYMJ = 1,NSYM 3366C 3367 ISYMDJ = MULD2H(ISYMD,ISYMJ) 3368 ISYMEM = MULD2H(ISYMDJ,ISYMTR) 3369 ISYMGM = ISYMEM 3370 ISYMK = MULD2H(ISYMGM,ISYDIS) 3371C 3372 NT1GM = MAX(NT1AO(ISYMGM),1) 3373 NRHFK = MAX(NRHF(ISYMK),1) 3374C 3375 KOFF1 = IT2BGD(ISYMGM,ISYMK) + 1 3376 KOFF2 = IT2BGD(ISYMGM,ISYMJ) + 1 3377 KOFF3 = IMATIJ(ISYMK,ISYMJ) + 1 3378C 3379 CALL DGEMM('T','N',NRHF(ISYMK),NRHF(ISYMJ),NT1AO(ISYMGM), 3380 * ONE,SCR2(KOFF1),NT1GM,SCR3(KOFF2),NT1GM, 3381 * ONE,EMAT2(KOFF3),NRHFK) 3382C 3383 400 CONTINUE 3384C 3385 RETURN 3386 END 3387C /* Deck cc_aofock */ 3388 SUBROUTINE CC_AOFOCK(XINT,DENSIT,FOCK,WORK,LWORK,IDEL, 3389 * ISYMD,LAUXD,IBASX,ISYDEN) 3390C 3391C Written by Asger Halkier and Henrik Koch 27-4-95. 3392C 3393C Debugged Ove Christiansen august 1995 3394C 3395C Purpose: Calculate the two electron contribution to the 3396C AO-fock matrix using matrix vector routines. 3397C 3398C Obs: It can be done as F(g>=d) = G(a>=b) I(a>=b,g,d) where 3399C G(a>=b) = D(a,b) + D(b,a), the diagonal properly scaled 3400C 3401C Adapted for R12: LAUXD=.TRUE.: Delta runs also over aux-functions 3402C Christian Neiss, spring 2006 3403C 3404#include "implicit.h" 3405#include "priunit.h" 3406#include "maxorb.h" 3407#include "ccorb.h" 3408#include "symsq.h" 3409#include "ccsdsym.h" 3410#include "r12int.h" 3411 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0) 3412 DIMENSION XINT(*),DENSIT(*) 3413 DIMENSION FOCK(*),WORK(LWORK) 3414 LOGICAL LAUXD 3415 INTEGER IBASX(8),NBAS2(8),NGDP(8),IGDP(8,8) 3416C 3417 IF (LAUXD) THEN 3418 DO ISYM = 1, NSYM 3419 NBAS2(ISYM) = MBAS1(ISYM)+MBAS2(ISYM) 3420 END DO 3421 DO ISYM = 1, NSYM 3422 NGDP(ISYM) = 0 3423 DO ISYM2 = 1, NSYM 3424 ISYM1 = MULD2H(ISYM,ISYM2) 3425 IGDP(ISYM1,ISYM2) = NGDP(ISYM) 3426 NGDP(ISYM) = NGDP(ISYM) + MBAS1(ISYM1)*NBAS2(ISYM2) 3427 END DO 3428 END DO 3429 END IF 3430C 3431 ISYDIS = MULD2H(ISYMD,ISYMOP) 3432C 3433 DO 100 ISYMG = 1,NSYM 3434C 3435 IF (NBAS(ISYMG) .EQ. 0) GOTO 100 3436C 3437 ISYMAB = MULD2H(ISYMG,ISYDIS) 3438C 3439 NDISTG = MIN(LWORK/MAX(N2BST(ISYMAB),1),NBAS(ISYMG)) 3440C 3441 IF (NDISTG .LT. 1) THEN 3442 CALL QUIT('Insufficient work space in CC_AOFOCK1') 3443 ENDIF 3444C 3445 NBATCH = (NBAS(ISYMG) - 1)/NDISTG + 1 3446C 3447C------------------------------------- 3448C Start the loops over batches. 3449C------------------------------------- 3450C 3451 DO 110 IBATCH = 1,NBATCH 3452C 3453 NUMG = NDISTG 3454 IF (IBATCH .EQ. NBATCH) THEN 3455 NUMG = NBAS(ISYMG) - NDISTG*(NBATCH - 1) 3456 ENDIF 3457C 3458 IG1 = NDISTG*(IBATCH - 1) + 1 3459 IG2 = NDISTG*(IBATCH - 1) + NUMG 3460C 3461 KOFF2 = 1 3462 DO 120 IG = IG1,IG2 3463C 3464 KOFF1 = IDSAOG(ISYMG,ISYDIS) 3465 * + (IG - 1)*NNBST(ISYMAB) + 1 3466C 3467 CALL CCSD_SYMSQ(XINT(KOFF1),ISYMAB,WORK(KOFF2)) 3468C 3469 KOFF2 = KOFF2 + N2BST(ISYMAB) 3470C 3471 120 CONTINUE 3472C 3473 IF (ISYMAB .EQ. ISYDEN) THEN 3474C 3475 IF (LAUXD) THEN 3476 KGD = IGDP(ISYMG,ISYMD) 3477 * + (IDEL-IBAS(ISYMD)-IBASX(ISYMD) - 1)*NBAS(ISYMG) 3478 * + IG1 3479 ELSE 3480 KGD = IAODIS(ISYMG,ISYMD) 3481 * + (IDEL-IBAS(ISYMD) - 1)*NBAS(ISYMG) + IG1 3482 END IF 3483C 3484 NTOBST = MAX(N2BST(ISYMAB),1) 3485C 3486 CALL DGEMV('T',N2BST(ISYMAB),NUMG,TWO,WORK,NTOBST, 3487 * DENSIT,1,ONE,FOCK(KGD),1) 3488C 3489 ENDIF 3490C 3491 ISYMA = MULD2H(ISYMD,ISYDEN) 3492 ISYMB = MULD2H(ISYMA,ISYMAB) 3493C 3494 IF (LAUXD) THEN 3495 KAD = IGDP(ISYMA,ISYMD) 3496 * + NBAS(ISYMA)*(IDEL-IBAS(ISYMD)-IBASX(ISYMD) - 1) + 1 3497 ELSE 3498 KAD = IAODIS(ISYMA,ISYMD) 3499 * + NBAS(ISYMA)*(IDEL - IBAS(ISYMD) - 1) + 1 3500 END IF 3501C 3502 DO 130 IG = IG1,IG2 3503C 3504 KOFF1 = (IG - IG1)*N2BST(ISYMAB) 3505 * + IAODIS(ISYMA,ISYMB) + 1 3506 KGB = IAODIS(ISYMG,ISYMB) + IG 3507C 3508 NTOTA = MAX(NBAS(ISYMA),1) 3509 NTOTG = MAX(NBAS(ISYMG),1) 3510C 3511C CALL DGEMV('T',NBAS(ISYMA),NBAS(ISYMB),-ONE,WORK(KOFF1), 3512C * NTOTA,DENSIT(KAD),1,ONE,FOCK(KGB),NTOTG) 3513C 3514 CALL DGEMV('N',NBAS(ISYMA),NBAS(ISYMB),-ONE,WORK(KOFF1), 3515 * NTOTA,DENSIT(KGB),NTOTG,ONE,FOCK(KAD),1) 3516C 3517 130 CONTINUE 3518C 3519 110 CONTINUE 3520 100 CONTINUE 3521C 3522 RETURN 3523 END 3524C /* Deck ccrhs_d */ 3525 SUBROUTINE CCRHS_D(XINT,DSRHF,OMEGA2,T2AM,ISYMT2, 3526 * XLAMDP,XLAMIP,XLAMDH, 3527 * XLAMPC,ISYMPC,XLAMHC,ISYMHC, 3528 * SCRM,E1PIM,WORK,LWORK,IDEL,ISYMD,FACTD,ICON, 3529 * IOPTR12,IOPTE,LUD,DFIL,LUDP,DPFIL,IV) 3530C 3531C Written by Henrik Koch 9-Jan-1994 3532C 3533C Generalisation for CCLR by Ove Christiansen august-september 1995 3534C (right transformation) and september 1996 (F-matrix). 3535C 3536C adapted for CCSDR12, C. Neiss, spring 2006 3537C IOPTR12 = 1 Calculate both conv. D and r12 D' intermediates 3538C T2-dependent contr. to D' interm. is added with a prefactor 3539C of 2*FACTD 3540C IOPTE = 1 Calculate the T-dependent part of the 3541C E_{a delta')^1' intermediate (on E1PIM). 3542C 3543C Purpose: Calculate D-term. 3544C 3545#include "implicit.h" 3546 PARAMETER (ONE = 1.0D0, TWO = 2.0D0) 3547 DIMENSION XINT(*),DSRHF(*),OMEGA2(*),WORK(LWORK) 3548 DIMENSION XLAMDP(*),XLAMIP(*),XLAMDH(*),SCRM(*) 3549 DIMENSION XLAMPC(*),XLAMHC(*) 3550 DIMENSION T2AM(*),E1PIM(*) 3551 CHARACTER DFIL*(*),DPFIL 3552#include "priunit.h" 3553#include "ccorb.h" 3554#include "ccsdsym.h" 3555#include "ccsdinp.h" 3556C 3557 ISYDIS = MULD2H(ISYMD,ISYMOP) 3558 ISYAIK = MULD2H(ISYDIS,ISYMPC) 3559 IF (ISYMT2 .NE. ISYMPC) CALL QUIT('Symmetry Mismatch in CCRHS_D' ) 3560C 3561C------------------------ 3562C Dynamic allocation. 3563C------------------------ 3564C 3565 KSCR1 = 1 3566 KSCR2 = KSCR1 + MAX(NT2BCD(ISYAIK),NT2BCD(ISYDIS)) 3567 KSCR3 = KSCR2 + NT2BGD(ISYDIS) 3568 IF (ICON .EQ. 2) THEN 3569 KEND1 = KSCR3 + NT2BGD(ISYMD) 3570 ELSE 3571 KEND1 = KSCR3 + NT2BGD(ISYAIK) 3572 ENDIF 3573 IF (IOPTR12.EQ.1) THEN 3574 KSCR4 = KEND1 3575 KEND1 = KSCR4 + NT2BCD(ISYAIK) 3576 END IF 3577 3578 LWRK1 = LWORK - KEND1 3579C 3580 IF (LWRK1 .LT. 0) THEN 3581 WRITE(LUPRI,*) 'Need : ',KEND1,'Available : ',LWORK 3582 CALL QUIT('Insufficient space in CCRHS_D') 3583 ENDIF 3584C 3585C-------------------------------- 3586C Calculate the contribution. 3587C-------------------------------- 3588C 3589 CALL CCRHS_D1(XINT,DSRHF,OMEGA2,T2AM,ISYMT2, 3590 * SCRM,E1PIM,WORK(KSCR1), 3591 * WORK(KSCR2),WORK(KSCR3),WORK(KSCR4),XLAMDP,XLAMIP, 3592 * XLAMDH,XLAMPC,ISYMPC,XLAMHC,ISYMHC, 3593 * WORK(KEND1),LWRK1,ISYDIS,IDEL, 3594 * ISYMD,FACTD,ICON,IOPTR12,IOPTE, 3595 * LUD,DFIL,LUDP,DPFIL,IV) 3596C 3597 RETURN 3598 END 3599 SUBROUTINE CCRHS_D1(XINT,DSRHF,OMEGA2,T2AM,ISYMT2, 3600 * SCRM,E1PIM,SCR1,SCR2,SCR3,SCR4, 3601 * XLAMDP,XLAMIP,XLAMDH,XLAMPC,ISYMPC,XLAMHC, 3602 * ISYMHC,WORK,LWORK,ISYDIS,IDEL,ISYDEL,FACTD, 3603 * ICON,IOPTR12,IOPTE,LUD,DFIL,LUDP,DPFIL,IV) 3604C 3605C Written by Henrik Koch 3-Jan-1994 3606C 3607C Modification by Ove Christiansen 25-7-1995 to allow for a 3608C general factor (FACTD). NB: Assumes DUMCD. 3609C - calculate intermediates for CCLR. 3610C 3611C 29-9-1995 (17-9-1996 F-matrix.) Ove Christiansen: 3612C 3613C 1. If Icon = 2 both contributions are calculated, 3614C for total sym. case. Otherwise 3615C a.ICON = 1 only the integral Laikc(del) 3616C = La-bar,i,k,c + La,i-bar,k,c 3617C for Jacobian right transformation 3618C b.ICON = 3 3619C La-bar,i,k,c + La,i-bar,k,c + Tx*Int 3620C for F-matrix times vector. 3621C 3622C 2. Allow for general transformation matrix for 3623C alpha to a(XLAMPC) and for i (XLAMHC). 3624C (the extra i transformation introduces new 3625C blocks which is only entered when icon = 1 or 3) 3626C 3627C 3. If icon diff. from 2 (we have linear response) 3628C The D intermediate is stored according to 3629C the number of simultaneous trial vector 3630C given by IV. This is ensured using IT2DLR. 3631C 3632C 3633C This to calculate terms in 2C1 right transformation in CCLR. 3634C 3635C adapted for CCSDR12, C. Neiss spring 2006 3636C 3637C Purpose: Calculate D-term. 3638C 3639#include "implicit.h" 3640#include "priunit.h" 3641#include "maxorb.h" 3642#include "ccsdinp.h" 3643 PARAMETER(ZERO=0.0D0,ONE=1.0D0,HALF=0.5D0,XMHALF=-0.5D0) 3644 PARAMETER(TWO=2.0D0) 3645 DIMENSION XINT(*),OMEGA2(*),T2AM(*),DSRHF(*) 3646 DIMENSION SCRM(*),E1PIM(*) 3647 DIMENSION SCR1(*),SCR2(*),SCR3(*),SCR4(*) 3648 DIMENSION XLAMDP(*),XLAMIP(*),XLAMDH(*) 3649 DIMENSION XLAMPC(*),XLAMHC(*) 3650 DIMENSION WORK(LWORK) 3651 INTEGER NADP(8),IADP(8,8),IBASX(8) 3652 CHARACTER DFIL*(*),DPFIL*(*) 3653#include "ccorb.h" 3654#include "symsq.h" 3655#include "ccsdsym.h" 3656#include "ccsdio.h" 3657#include "r12int.h" 3658C 3659 INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J 3660C 3661 IF (IOPTE.EQ.1) THEN 3662 IF (.NOT.CCR12) CALL QUIT('IOPTE only implemented for CC-R12') 3663 IBASX(1) = 0 3664 DO ISYM = 2, NSYM 3665 IBASX(ISYM) = IBASX(ISYM-1) + MBAS2(ISYM-1) 3666 END DO 3667 DO ISYM = 1, NSYM 3668 NADP(ISYM) = 0 3669 DO ISYM2 = 1, NSYM 3670 ISYM1 = MULD2H(ISYM,ISYM2) 3671 IADP(ISYM1,ISYM2) = NADP(ISYM) 3672 NADP(ISYM) = NADP(ISYM) + 3673 & NVIR(ISYM1)*(MBAS1(ISYM2)+MBAS2(ISYM2)) 3674 END DO 3675 END DO 3676 END IF 3677C 3678 ISYAIK = MULD2H(ISYDIS,ISYMPC) 3679C 3680C------------------------------------------------------- 3681C Calculate the integrals K(k,dl) = (k d | l delta). 3682C------------------------------------------------------- 3683C 3684 IF (ICON .GE. 2) THEN 3685C 3686 DO 100 ISYMK = 1,NSYM 3687C 3688 ISYMAG = MULD2H(ISYMK,ISYDIS) 3689C 3690 DO 110 K = 1,NRHF(ISYMK) 3691C 3692 ISYMDL = MULD2H(ISYMK,ISYDIS) 3693C 3694 KSCR10 = 1 3695 KEND1 = KSCR10 + N2BST(ISYMAG) 3696 LWRK1 = LWORK - KEND1 3697C 3698 IF (LWRK1 .LT. 0) THEN 3699 CALL QUIT('Not enough space for '// 3700 & 'allocation in CCRHS_D1') 3701 END IF 3702C 3703 KOFF1 = IDSRHF(ISYMAG,ISYMK) + NNBST(ISYMAG)*(K-1) + 1 3704 CALL CCSD_SYMSQ(DSRHF(KOFF1),ISYMAG,WORK(KSCR10)) 3705C 3706 DO 120 ISYML = 1,NSYM 3707C 3708 ISYMD = MULD2H(ISYML,ISYMDL) 3709 ISYMA = ISYML 3710 ISYMG = ISYMD 3711C 3712 NBASA = MAX(NBAS(ISYMA),1) 3713 NBASG = MAX(NBAS(ISYMG),1) 3714 NVIRD = MAX(NVIR(ISYMD),1) 3715C 3716 KSCR11 = KEND1 3717 KEND2 = KSCR11 + NBAS(ISYMG)*NRHF(ISYML) 3718 LWRK2 = LWORK - KEND2 3719C 3720 IF (LWRK2 .LT. 0) THEN 3721 CALL QUIT('Not enough space for '// 3722 & 'allocation in CCRHS_D1') 3723 END IF 3724C 3725 KOFF2 = KSCR10 + IAODIS(ISYMA,ISYMG) 3726 KOFF3 = ILMRHF(ISYML) + 1 3727C 3728 CALL DGEMM('T','N',NBAS(ISYMG),NRHF(ISYML), 3729 * NBAS(ISYMA),ONE,WORK(KOFF2),NBASA, 3730 * XLAMDP(KOFF3),NBASA, 3731 * ZERO,WORK(KSCR11),NBASG) 3732C 3733 KOFF5 = ILMVIR(ISYMD) + 1 3734 KOFF6 = IT2BCD(ISYMDL,ISYMK) + NT1AM(ISYMDL)*(K - 1) 3735 * + IT1AM(ISYMD,ISYML) + 1 3736C 3737 CALL DGEMM('T','N',NVIR(ISYMD),NRHF(ISYML), 3738 * NBAS(ISYMG),ONE,XLAMDH(KOFF5),NBASG, 3739 * WORK(KSCR11),NBASG, 3740 * ZERO,SCR1(KOFF6),NVIRD) 3741C 3742 120 CONTINUE 3743C 3744 110 CONTINUE 3745C 3746 100 CONTINUE 3747C 3748C--------------------------------- 3749C Transpose integral array. 3750C--------------------------------- 3751C 3752 CALL CC_MTCME(SCR1,WORK,LWORK,ISYDIS,1) 3753C 3754 IF (LWORK .LT. NT2BCD(ISYDIS)) THEN 3755 CALL QUIT('Not enough space for allocation in CCRHS_D1') 3756 END IF 3757C 3758 DO 130 ISYMK = 1,NSYM 3759C 3760 ISYMDL = MULD2H(ISYMK,ISYDIS) 3761C 3762 NRHFK = MAX(NRHF(ISYMK),1) 3763C 3764 DO 140 K = 1,NRHF(ISYMK) 3765C 3766 KOFF1 = IT2BCD(ISYMDL,ISYMK) + NT1AM(ISYMDL)*(K - 1) + 1 3767 KOFF2 = IT2BCT(ISYMK,ISYMDL) + K 3768C 3769 CALL DCOPY(NT1AM(ISYMDL),SCR1(KOFF1),1,WORK(KOFF2),NRHFK) 3770C 3771 140 CONTINUE 3772C 3773 130 CONTINUE 3774C 3775 CALL DCOPY(NT2BCD(ISYDIS),WORK,1,SCR1,1) 3776C 3777C----------------------------------------- 3778C Calculate the first contribution. 3779C sum(2*t(ai,dl)-t(di,al))*L(ldkc) 3780C----------------------------------------- 3781C 3782 IF (LWORK .LT. NT2BCD(ISYAIK)) THEN 3783 CALL QUIT('Insufficient work space in CCRHS_D1') 3784 ENDIF 3785C 3786 DO 200 ISYMK = 1,NSYM 3787C 3788 ISYMDL = MULD2H(ISYMK,ISYDIS) 3789 ISYMAI = MULD2H(ISYAIK,ISYMK) 3790C 3791 NRHFK = MAX(NRHF(ISYMK),1) 3792 NTOTDL = MAX(NT1AM(ISYMDL),1) 3793C 3794 KOFF1 = IT2BCT(ISYMK,ISYMDL) + 1 3795 KOFF2 = IT2SQ(ISYMDL,ISYMAI) + 1 3796 KOFF3 = IT2BCT(ISYMK,ISYMAI) + 1 3797C 3798 CALL DGEMM('N','N',NRHF(ISYMK),NT1AM(ISYMAI),NT1AM(ISYMDL), 3799 * ONE,SCR1(KOFF1),NRHFK,T2AM(KOFF2),NTOTDL,ZERO, 3800 * WORK(KOFF3),NRHFK) 3801C 3802 200 CONTINUE 3803C 3804 CALL DCOPY(NT2BCD(ISYAIK),WORK,1,SCR1,1) 3805C 3806 !save a copy of first contribution: 3807 IF (IOPTR12.EQ.1) THEN 3808 CALL DCOPY(NT2BCD(ISYAIK),WORK,1,SCR4,1) 3809 END IF 3810C 3811 ENDIF 3812C 3813C---------------------------------------------------------- 3814C Calculate the integrals K(k,ai) = (k i | alfa delta). 3815C---------------------------------------------------------- 3816C 3817 DO 300 ISYMA = 1,NSYM 3818C 3819 ISYMBG = MULD2H(ISYMA,ISYDIS) 3820C 3821 KSCR10 = 1 3822 KEND1 = KSCR10 + N2BST(ISYMBG) 3823 LWRK1 = LWORK - KEND1 3824 IF (LWRK1 .LT. 0) THEN 3825 CALL QUIT('Not enough space for allocation in CCRHS_D1') 3826 END IF 3827C 3828 DO 310 A = 1,NBAS(ISYMA) 3829C 3830 KOFF1 = IDSAOG(ISYMA,ISYDIS) + NNBST(ISYMBG)*(A - 1) + 1 3831 CALL CCSD_SYMSQ(XINT(KOFF1),ISYMBG,WORK(KSCR10)) 3832C 3833 DO 320 ISYMG = 1,NSYM 3834C 3835 ISYMI = ISYMG 3836 ISYMB = MULD2H(ISYMG,ISYMBG) 3837 ISYMK = ISYMB 3838 ISYMAI = MULD2H(ISYMA,ISYMI) 3839C 3840 NBASB = MAX(NBAS(ISYMB),1) 3841 NBASG = MAX(NBAS(ISYMG),1) 3842 NRHFK = MAX(NRHF(ISYMK),1) 3843C 3844 KSCR11 = KEND1 3845 KSCR12 = KSCR11 + NRHF(ISYMK)*NBAS(ISYMG) 3846 KEND2 = KSCR12 + NRHF(ISYMK)*NRHF(ISYMI) 3847 LWRK2 = LWORK - KEND2 3848 IF (LWRK2 .LT. 0) THEN 3849 CALL QUIT('Not enough space for '// 3850 & 'allocation in CCRHS_D1') 3851 END IF 3852C 3853 KOFF2 = ILMRHF(ISYMK) + 1 3854 KOFF3 = KSCR10 + IAODIS(ISYMB,ISYMG) 3855C 3856 CALL DGEMM('T','N',NRHF(ISYMK),NBAS(ISYMG),NBAS(ISYMB), 3857 * ONE,XLAMDP(KOFF2),NBASB,WORK(KOFF3),NBASB, 3858 * ZERO,WORK(KSCR11),NRHFK) 3859C 3860 KOFF5 = ILMRHF(ISYMI) + 1 3861C 3862 CALL DGEMM('N','N',NRHF(ISYMK),NRHF(ISYMI),NBAS(ISYMG), 3863 * ONE,WORK(KSCR11),NRHFK,XLAMDH(KOFF5),NBASG, 3864 * ZERO,WORK(KSCR12),NRHFK) 3865C 3866 DO 330 I = 1,NRHF(ISYMI) 3867C 3868 NAI = IT1AO(ISYMA,ISYMI) + NBAS(ISYMA)*(I-1) + A 3869C 3870 KOFF8 = IT2BGT(ISYMK,ISYMAI) 3871 * + NRHF(ISYMK)*(NAI - 1) + 1 3872 KOFF7 = KSCR12 + NRHF(ISYMK)*(I - 1) 3873C 3874 CALL DCOPY(NRHF(ISYMK),WORK(KOFF7),1,SCR2(KOFF8),1) 3875C 3876 330 CONTINUE 3877C 3878C------------------------------------------------------- 3879C In 2C1 linear transformation extra cont. 3880C------------------------------------------------------- 3881C 3882 IF ((ICON .EQ. 1) .OR. (ICON.EQ.3)) THEN 3883C 3884 ISYMI = MULD2H(ISYMG,ISYMHC) 3885 ISYMAI = MULD2H(ISYMA,ISYMI) 3886C 3887 KEND2 = KSCR12 + NRHF(ISYMK)*NRHF(ISYMI) 3888 LWRK2 = LWORK - KEND2 3889 IF (LWRK2 .LT. 0) THEN 3890 CALL QUIT('Not enough space for '// 3891 & 'allocation in CCRHS_D1') 3892 END IF 3893C 3894 KOFF5 = IGLMRH(ISYMG,ISYMI) + 1 3895C 3896 CALL DGEMM('N','N',NRHF(ISYMK),NRHF(ISYMI), 3897 * NBAS(ISYMG),ONE,WORK(KSCR11),NRHFK, 3898 * XLAMHC(KOFF5),NBASG, 3899 * ZERO,WORK(KSCR12),NRHFK) 3900C 3901 DO 331 I = 1,NRHF(ISYMI) 3902C 3903 NAI = IT1AO(ISYMA,ISYMI) + NBAS(ISYMA)*(I-1) + A 3904C 3905 KOFF8 = IT2BGT(ISYMK,ISYMAI) 3906 * + NRHF(ISYMK)*(NAI - 1) + 1 3907 KOFF7 = KSCR12 + NRHF(ISYMK)*(I - 1) 3908C 3909 CALL DCOPY(NRHF(ISYMK),WORK(KOFF7),1,SCR3(KOFF8),1) 3910C 3911 331 CONTINUE 3912C 3913 ENDIF 3914C 3915 320 CONTINUE 3916C 3917 310 CONTINUE 3918C 3919 300 CONTINUE 3920C 3921 CALL DSCAL(NT2BGD(ISYDIS),-ONE,SCR2,1) 3922C 3923 ISALIK = MULD2H(ISYDIS,ISYMHC) 3924C 3925 CALL DSCAL(NT2BGD(ISALIK),-ONE,SCR3,1) 3926C 3927 DO 340 ISYMK = 1,NSYM 3928C 3929 ISYALG = MULD2H(ISYMK,ISYDIS) 3930 ISYALI = MULD2H(ISYMHC,ISYALG) 3931 NT1AOM = MAX(NT1AO(ISYALG),NT1AO(ISYALI)) 3932C 3933 KSCR10 = 1 3934 KSCR11 = KSCR10 + N2BST(ISYALG) 3935 KEND1 = KSCR11 + NT1AOM 3936 LWRK1 = LWORK - KEND1 3937 IF (LWRK1 .LT. 0) THEN 3938 CALL QUIT('Insufficient space for allocation in CCRHS_D1') 3939 END IF 3940C 3941 DO 350 K = 1,NRHF(ISYMK) 3942C 3943 KOFF1 = IDSRHF(ISYALG,ISYMK) + NNBST(ISYALG)*(K - 1) + 1 3944 CALL CCSD_SYMSQ(DSRHF(KOFF1),ISYALG,WORK(KSCR10)) 3945C 3946 ISYALI = ISYALG 3947 CALL DZERO(WORK(KSCR11),NT1AO(ISYALI)) 3948C 3949C------------------------------ 3950C Usual contribution. 3951C------------------------------ 3952C 3953 DO 360 ISYMI = 1,NSYM 3954C 3955 ISYMAL = MULD2H(ISYMI,ISYALI) 3956 ISYMG = ISYMI 3957C 3958 NBASAL = MAX(NBAS(ISYMAL),1) 3959 NBASG = MAX(NBAS(ISYMG),1) 3960C 3961 KOFF2 = KSCR10 + IAODIS(ISYMAL,ISYMG) 3962 KOFF3 = ILMRHF(ISYMI) + 1 3963 KOFF4 = KSCR11 + IT1AO(ISYMAL,ISYMI) 3964C 3965 CALL DGEMM('N','N',NBAS(ISYMAL),NRHF(ISYMI),NBAS(ISYMG), 3966 * ONE,WORK(KOFF2),NBASAL,XLAMDH(KOFF3),NBASG, 3967 * ZERO,WORK(KOFF4),NBASAL) 3968C 3969 360 CONTINUE 3970C 3971 NRHFK = MAX(NRHF(ISYMK),1) 3972 KOFF5 = IT2BGT(ISYMK,ISYALI) + K 3973 CALL DAXPY(NT1AO(ISYALI),TWO,WORK(KSCR11),1,SCR2(KOFF5), 3974 * NRHFK) 3975C 3976C---------------------------------------------------- 3977C In 2C1 linear tronsformation extra cont. 3978C---------------------------------------------------- 3979C 3980 IF ((ICON .EQ. 3) .OR. (ICON .EQ. 1)) THEN 3981C 3982 ISYALI = MULD2H(ISYALG,ISYMHC) 3983C 3984 CALL DZERO(WORK(KSCR11),NT1AO(ISYALI)) 3985C 3986 DO 361 ISYMI = 1,NSYM 3987C 3988 ISYMAL = MULD2H(ISYMI,ISYALI) 3989 ISYMG = MULD2H(ISYMI,ISYMHC) 3990C 3991 NBASAL = MAX(NBAS(ISYMAL),1) 3992 NBASG = MAX(NBAS(ISYMG),1) 3993C 3994 KOFF2 = KSCR10 + IAODIS(ISYMAL,ISYMG) 3995 KOFF3 = IGLMRH(ISYMG,ISYMI) + 1 3996 KOFF4 = KSCR11 + IT1AO(ISYMAL,ISYMI) 3997C 3998 CALL DGEMM('N','N',NBAS(ISYMAL),NRHF(ISYMI), 3999 * NBAS(ISYMG),ONE,WORK(KOFF2),NBASAL, 4000 * XLAMHC(KOFF3),NBASG, 4001 * ZERO,WORK(KOFF4),NBASAL) 4002C 4003 361 CONTINUE 4004C 4005 NRHFK = MAX(NRHF(ISYMK),1) 4006 KOFF5 = IT2BGT(ISYMK,ISYALI) + K 4007 CALL DAXPY(NT1AO(ISYALI),TWO,WORK(KSCR11),1, 4008 * SCR3(KOFF5),NRHFK) 4009C 4010 ENDIF 4011C 4012 350 CONTINUE 4013C 4014 340 CONTINUE 4015C 4016 IF (DUMPCD) GOTO 700 4017C 4018 IF (CCR12) CALL QUIT('CCSDR12 requires DUMPCD=.TRUE.') 4019C 4020C----------------------------------------- 4021C Back transformation to the AO basis. 4022C----------------------------------------- 4023C 4024 DO 400 ISYMAI = 1,NSYM 4025C 4026 ISYMK = MULD2H(ISYMAI,ISYDIS) 4027C 4028 NRHFK = MAX(NRHF(ISYMK),1) 4029C 4030 DO 410 ISYMI = 1,NSYM 4031C 4032 ISYMA = MULD2H(ISYMI,ISYMAI) 4033C 4034 NBASA = MAX(NBAS(ISYMA),1) 4035C 4036 DO 420 I = 1,NRHF(ISYMI) 4037C 4038 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + 1 4039 MAI = IT1AO(ISYMA,ISYMI) + NBAS(ISYMA)*(I - 1) + 1 4040C 4041 KOFF1 = IT2BCT(ISYMK,ISYMAI) + NRHF(ISYMK)*(NAI - 1) + 1 4042 KOFF2 = ILMVIR(ISYMA) + 1 4043 KOFF3 = IT2BGT(ISYMK,ISYMAI) + NRHF(ISYMK)*(MAI - 1) + 1 4044C 4045 CALL DGEMM('N','T',NRHF(ISYMK),NBAS(ISYMA),NVIR(ISYMA), 4046 * HALF,SCR1(KOFF1),NRHFK,XLAMIP(KOFF2),NBASA, 4047 * ONE,SCR2(KOFF3),NRHFK) 4048C 4049 420 CONTINUE 4050C 4051 410 CONTINUE 4052C 4053 400 CONTINUE 4054C 4055C 4056 DO 500 ISYMK = 1,NSYM 4057C 4058 ISYMBJ = MULD2H(ISYMK,ISYDEL) 4059C 4060 DO 510 K = 1,NRHF(ISYMK) 4061C 4062 DO 520 ISYMJ = 1,NSYM 4063C 4064 ISYMB = MULD2H(ISYMJ,ISYMBJ) 4065C 4066 NBASB = MAX(NBAS(ISYMB),1) 4067 NVIRB = MAX(NVIR(ISYMB),1) 4068C 4069 KOFF1 = ILMVIR(ISYMB) + 1 4070 KOFF2 = IT2BCD(ISYMBJ,ISYMK) + NT1AM(ISYMBJ)*(K - 1) 4071 * + IT1AM(ISYMB,ISYMJ) + 1 4072 KOFF3 = IT2BGD(ISYMBJ,ISYMK) + NT1AO(ISYMBJ)*(K - 1) 4073 * + IT1AO(ISYMB,ISYMJ) + 1 4074C 4075 CALL DGEMM('N','N',NBAS(ISYMB),NRHF(ISYMJ),NVIR(ISYMB), 4076 * ONE,XLAMIP(KOFF1),NBASB,SCRM(KOFF2),NVIRB, 4077 * ZERO,SCR3(KOFF3),NBASB) 4078C 4079 520 CONTINUE 4080C 4081 510 CONTINUE 4082C 4083 500 CONTINUE 4084C 4085C--------------------------------------- 4086C Calculate the second contribution. 4087C--------------------------------------- 4088C 4089 DO 600 ISYMAI = 1,NSYM 4090C 4091 ISYMK = MULD2H(ISYMAI,ISYDIS) 4092 ISYMBJ = MULD2H(ISYMK,ISYDEL) 4093C 4094 IF (NRHF(ISYMK) .EQ. 0) GOTO 600 4095C 4096 IF (LWORK .LT. NT1AO(ISYMBJ)) THEN 4097 CALL QUIT('Insufficient work space in CCRHS_D1') 4098 ENDIF 4099C 4100 NTOTBJ = MAX(NT1AO(ISYMBJ),1) 4101 NRHFK = MAX(NRHF(ISYMK),1) 4102C 4103 IF (.NOT. OMEGSQ) THEN 4104C 4105 DO 610 NAI = 1,NT1AO(ISYMAI) 4106C 4107 KOFF1 = IT2BGD(ISYMBJ,ISYMK) + 1 4108 KOFF2 = IT2BGT(ISYMK,ISYMAI) 4109 * + NRHF(ISYMK)*(NAI - 1) + 1 4110C 4111 CALL DGEMV('N',NT1AO(ISYMBJ),NRHF(ISYMK),ONE, 4112 * SCR3(KOFF1),NTOTBJ,SCR2(KOFF2),1, 4113 * ZERO,WORK,1) 4114C 4115 IF (ISYMAI .EQ. ISYMBJ) THEN 4116 WORK(NAI) = TWO*WORK(NAI) 4117 ENDIF 4118C 4119 DO 620 NBJ = 1,NT1AO(ISYMBJ) 4120 NAIBJ = IT2AO(ISYMAI,ISYMBJ) + INDEX(NAI,NBJ) 4121 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + HALF*WORK(NBJ) 4122 620 CONTINUE 4123C 4124 610 CONTINUE 4125C 4126 ELSE 4127C 4128 KOFF1 = IT2BGD(ISYMBJ,ISYMK) + 1 4129 KOFF2 = IT2BGT(ISYMK,ISYMAI) + 1 4130 KOFF3 = IT2AOS(ISYMBJ,ISYMAI) + 1 4131C 4132 CALL DGEMM('N','N',NT1AO(ISYMBJ),NT1AO(ISYMAI),NRHF(ISYMK), 4133 * HALF,SCR3(KOFF1),NTOTBJ,SCR2(KOFF2),NRHFK, 4134 * ONE,OMEGA2(KOFF3),NT1AO(ISYMBJ)) 4135C 4136 ENDIF 4137C 4138 600 CONTINUE 4139C 4140 GOTO 999 4141C 4142C------------------- 4143C I/O algorithm. 4144C------------------- 4145C 4146 700 CONTINUE 4147C 4148C-------------------------------------------------------------------------- 4149C Transform the alpha index of K(k,ai) to a. 4150C for 2C1 transformation this means lamdpc is a C1 transformed lambda. 4151C-------------------------------------------------------------------------- 4152C 4153 ISYAIK = MULD2H(ISYDIS,ISYMPC) 4154C 4155 DO 710 ISYMAI = 1,NSYM 4156C 4157 ISYMK = MULD2H(ISYMAI,ISYAIK) 4158 NRHFK = MAX(NRHF(ISYMK),1) 4159C 4160 DO 720 ISYMI = 1,NSYM 4161C 4162 ISYMA = MULD2H(ISYMI,ISYMAI) 4163 ISYMAL = MULD2H(ISYMPC,ISYMA) 4164 ISYALI = MULD2H(ISYMAL,ISYMI) 4165 NBASAL = MAX(NBAS(ISYMAL),1) 4166C 4167 DO 730 I = 1,NRHF(ISYMI) 4168C 4169 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + 1 4170 MALI = IT1AO(ISYMAL,ISYMI) + NBAS(ISYMAL)*(I - 1) + 1 4171C 4172 KOFF1 = IT2BGT(ISYMK,ISYALI) + NRHF(ISYMK)*(MALI - 1) + 1 4173 KOFF2 = IGLMVI(ISYMAL,ISYMA) + 1 4174 KOFF3 = IT2BCT(ISYMK,ISYMAI) + NRHF(ISYMK)*(NAI - 1) + 1 4175C 4176 CALL DGEMM('N','N',NRHF(ISYMK),NVIR(ISYMA),NBAS(ISYMAL), 4177 * ONE,SCR2(KOFF1),NRHFK,XLAMPC(KOFF2),NBASAL, 4178 * FACTD ,SCR1(KOFF3),NRHFK) 4179C 4180 IF (IOPTE.EQ.1) THEN 4181 IF (ISYMI.EQ.ISYMK) THEN 4182 KOFF3 = IT2BCT(ISYMK,ISYMAI) + 4183 & NRHF(ISYMK)*(NAI - 1) + I 4184 IF (IDEL.GT.NBAST) THEN 4185 D = IDEL-IBASX(ISYDEL)-NBAST+MBAS1(ISYDEL) 4186 ELSE 4187 D = IDEL-IBAS(ISYDEL) 4188 END IF 4189 KOFFE = IADP(ISYMA,ISYDEL) + 4190 & NVIR(ISYMA)*(D-1) + 1 4191 CALL DAXPY(NVIR(ISYMA),-0.5D0,SCR1(KOFF3), 4192 & NRHF(ISYMK),E1PIM(KOFFE),1) 4193 END IF 4194 END IF 4195C 4196 730 CONTINUE 4197 720 CONTINUE 4198 710 CONTINUE 4199C 4200C----------------------------------------------- 4201C Transform the alpha index of K(k,ai) to a. 4202C I is C1 transformed. 4203C----------------------------------------------- 4204C 4205 IF ((ICON .EQ. 3) .OR. (ICON .EQ. 1)) THEN 4206C 4207 ISYAIK = MULD2H(ISYDIS,ISYMHC) 4208C 4209 DO 750 ISYMAI = 1,NSYM 4210C 4211 ISYMK = MULD2H(ISYMAI,ISYAIK) 4212 NRHFK = MAX(NRHF(ISYMK),1) 4213C 4214 DO 760 ISYMI = 1,NSYM 4215C 4216 ISYMA = MULD2H(ISYMI,ISYMAI) 4217 ISYMAL= ISYMA 4218 ISYALI= MULD2H(ISYMAL,ISYMI) 4219 NBASAL = MAX(NBAS(ISYMAL),1) 4220C 4221 DO 770 I = 1,NRHF(ISYMI) 4222C 4223 NAI = IT1AM(ISYMA,ISYMI) 4224 * + NVIR(ISYMA)*(I - 1) + 1 4225 MALI = IT1AO(ISYMAL,ISYMI) 4226 * + NBAS(ISYMAL)*(I - 1) + 1 4227C 4228 KOFF1 = IT2BGT(ISYMK,ISYALI) 4229 * + NRHF(ISYMK)*(MALI - 1) + 1 4230 KOFF2 = ILMVIR(ISYMA) + 1 4231 KOFF3 = IT2BCT(ISYMK,ISYMAI) 4232 * + NRHF(ISYMK)*(NAI - 1) + 1 4233C 4234 CALL DGEMM('N','N',NRHF(ISYMK),NVIR(ISYMA), 4235 * NBAS(ISYMAL),ONE,SCR3(KOFF1),NRHFK, 4236 * XLAMDP(KOFF2),NBASAL, 4237 * ONE,SCR1(KOFF3),NRHFK) 4238C 4239 770 CONTINUE 4240 760 CONTINUE 4241 750 CONTINUE 4242C 4243 ENDIF 4244C 4245C--------------------------------------- 4246C Dump to disk the new contribution. 4247C--------------------------------------- 4248C 4249C 4250 IF ( ICON .EQ. 2 ) THEN 4251 IOFF = IT2DEL(IDEL) + 1 4252 ELSE 4253 IOFF = IT2DLR(IDEL,IV) + 1 4254 ENDIF 4255C 4256 IF (NT2BCD(ISYAIK) .GT. 0) THEN 4257 CALL PUTWA2(LUD,DFIL,SCR1,IOFF,NT2BCD(ISYAIK)) 4258 ENDIF 4259C 4260 IF (IOPTR12.EQ.1) THEN 4261 CALL DAXPY(NT2BCD(ISYAIK),FACTD,SCR4,1,SCR1,1) 4262 IF (NT2BCD(ISYAIK) .GT. 0) THEN 4263 CALL PUTWA2(LUDP,DPFIL,SCR1,IOFF,NT2BCD(ISYAIK)) 4264 END IF 4265 END IF 4266C 4267 999 CONTINUE 4268C 4269 RETURN 4270 END 4271C /* Deck ccrhs_c */ 4272 SUBROUTINE CCRHS_C(XINT,DSRHF,OMEGA2,T2AM,ISYMT2, 4273 * XLAMDP,XLAMIP,XLAMDH, 4274 * XLAMPC,ISYMPC,XLAMHC,ISYMHC,SCRM,E1PIM, 4275 * WORK,LWORK,IDEL,ISYMD,FACTC,ICON,IOPTR12, 4276 * IOPTE,LUC,CFIL,LUCP,CPFIL,IV) 4277C 4278C Written by Henrik Koch 3-Jan-1994 4279C Symmetry by Henrik Koch and Alfredo Sanchez. 27-July-1994 4280C Generalisation for CCLR by Ove Christiansen august-september 1995 4281C (right transformation) and september 1996 (F-matrix). 4282C 4283C Extended for CCSDR12, C. Neiss spring 2006 4284C IOPTR12 = 1 Calculate both conv. C and r12 C' intermediates; 4285C T2-dependent contr. to C' interm. is added with a prefactor 4286C of 2*FACTC 4287C IOPTE = 1 Calculate the T-dependent part of the 4288C E_{a delta')^1' intermediate (on E1PIM). 4289C 4290C Purpose: Calculate C-term. 4291C 4292#include "implicit.h" 4293#include "priunit.h" 4294#include "maxorb.h" 4295 DIMENSION XINT(*),DSRHF(*),OMEGA2(*),XLAMDH(*),WORK(LWORK) 4296 DIMENSION XLAMDP(*),XLAMIP(*),SCRM(*),XLAMPC(*),XLAMHC(*) 4297 DIMENSION T2AM(*),E1PIM(*) 4298 CHARACTER CFIL*(*),CPFIL*(*) 4299#include "ccorb.h" 4300#include "symsq.h" 4301#include "ccsdsym.h" 4302#include "ccsdio.h" 4303#include "ccsdinp.h" 4304C 4305 ISYDIS = MULD2H(ISYMD,ISYMOP) 4306 ISYAIK = MULD2H(ISYDIS,ISYMPC) 4307C 4308C-------------------------------------- 4309C Dynamic allocation of work space. 4310C-------------------------------------- 4311C 4312 KSCR1 = 1 4313 KSCR2 = KSCR1 + MAX(NT2BCD(ISYAIK),NT2BCD(ISYDIS)) 4314 KSCR3 = KSCR2 + NT2BGD(ISYDIS) 4315 IF (ICON .EQ. 2) THEN 4316 KEND1 = KSCR3 + NT2BGD(ISYMD) 4317 ELSE 4318 KEND1 = KSCR3 + NT2BGD(ISYAIK) 4319 ENDIF 4320 IF (IOPTR12.EQ.1) THEN 4321 KSCR4 = KEND1 4322 KEND1 = KSCR4 + NT2BCD(ISYAIK) 4323 END IF 4324 4325 LWRK1 = LWORK - KEND1 4326 IF (LWRK1 .LT. 0) THEN 4327 CALL QUIT('Insufficient space for allocation in CCRHS_C') 4328 END IF 4329C 4330C-------------------------------------- 4331C Transpose the cluster amplitudes. 4332C-------------------------------------- 4333C 4334 IF (ICON .GE. 2) THEN 4335 IF (.NOT. T2TCOR) THEN 4336 CALL CCSD_T2TP(T2AM,WORK(KEND1),LWRK1,ISYMT2) 4337 ENDIF 4338 IF (.NOT. DUMPCD) CALL CCSD_T2MTP(SCRM,WORK(KEND1),LWRK1,ISYMD) 4339 ENDIF 4340C 4341C-------------------------------- 4342C Calculate the contribution. 4343C-------------------------------- 4344C 4345 IF (.NOT. CC2) THEN 4346 CALL CCRHS_C1(XINT,DSRHF,OMEGA2,T2AM,ISYMT2,SCRM,E1PIM, 4347 * WORK(KSCR1),WORK(KSCR2),WORK(KSCR3),WORK(KSCR4), 4348 * XLAMDP,XLAMIP,XLAMDH,XLAMPC,ISYMPC,XLAMHC,ISYMHC, 4349 * WORK(KEND1),LWRK1, 4350 * ISYDIS,IDEL,ISYMD,FACTC,ICON,IOPTR12,IOPTE, 4351 * LUC,CFIL,LUCP,CPFIL,IV) 4352 ENDIF 4353C 4354C-------------------------------------- 4355C Transpose the cluster amplitudes. 4356C-------------------------------------- 4357C 4358 IF (ICON .GE. 2) THEN 4359 IF (.NOT. T2TCOR) THEN 4360 CALL CCSD_T2TP(T2AM,WORK(KEND1),LWRK1,ISYMT2) 4361 ENDIF 4362 IF (.NOT. DUMPCD) CALL CCSD_T2MTP(SCRM,WORK(KEND1),LWRK1,ISYMD) 4363 ENDIF 4364C 4365 RETURN 4366 END 4367 SUBROUTINE CCRHS_C1(XINT,DSRHF,OMEGA2,T2AM,ISYMT2,SCRM,E1PIM, 4368 * SCR1,SCR2,SCR3,SCR4,XLAMDP,XLAMIP, 4369 * XLAMDH,XLAMPC,ISYMPC,XLAMHC,ISYMHC,WORK, 4370 * LWORK,ISYDIS,IDEL,ISYDEL,FACTC,ICON,IOPTR12, 4371 * IOPTE,LUC,CFIL,LUCP,CPFIL,IV) 4372C 4373C Written by Henrik Koch 3-Jan-1994 4374C Symmetry by Henrik Koch and Alfredo Sanchez. 27-July-1994 4375C 4376C modification by Ove Christiansen 25-7-1995 to allow for a 4377C general factor (FACTC) ( assumes DUMCD ) 4378C and - calculate intermediates for CCLR. 4379C 4380C modification by Ove Christiansen 17-9-1996 for calculating 4381C local C-intermediate for F-matrix transformation. 4382C 4383C Thus: 4384C 4385C Modification to calculate terms in 2C1 right transformation in CCLR: 4386C 4387C 1. if icon = 2 both contributions are calculated, 4388C otherwise if ICON = 4389C 1:only the integral (ki | ac) 4390C = (k i-bar | a c) + (k i | a-bar c) 4391C 4392C 3: (k i-bar | a c) + (k i | a-bar c) 4393C + FACTC*Sum(xT*int) 4394C where xT may be non total symmetric. 4395C 4396C 2. Allow for general transformation matrix for 4397C alpha to a(XLAMPC) and for i (XLAMHC). 4398C (the extra i transformation introduces new 4399C blocks which is only entered when 4400C icon =1 or 3) 4401C 4402C 3. If icon diff. from 2 (we have linear response) 4403C The C intermediate is stored according to 4404C the number of simultaneous trial vector 4405C given by IV. This is ensured using IT2DLR. 4406C 4407C Thus in energy calc: icon = 2,fact = 1/2 4408C For right transformation: 4409C icon=1,fact=anything, iv = current vector being transformed 4410C For F-matrix transformation: 4411C icon=3,fact=1.0, NB - not implemented several vectors yet. 4412C 4413C extended for CCSDR12, C. Neiss spring 2006 4414C 4415C Purpose: Calculate C-term intermediate. 4416C 4417#include "implicit.h" 4418#include "priunit.h" 4419#include "maxorb.h" 4420#include "ccsdinp.h" 4421 PARAMETER (ZERO=0.0D0,ONE=1.0D0,HALF=0.5D0,XMHALF=-0.5D0) 4422 PARAMETER (TWO=2.0D0) 4423 DIMENSION XINT(*),OMEGA2(*),T2AM(*),DSRHF(*) 4424 DIMENSION SCRM(*),E1PIM(*) 4425 DIMENSION SCR1(*), SCR2(*), SCR3(*), SCR4(*) 4426 DIMENSION XLAMDP(*),XLAMIP(*),XLAMDH(*),XLAMPC(*),XLAMHC(ISYMHC) 4427 DIMENSION WORK(LWORK) 4428 INTEGER NADP(8),IADP(8,8),IBASX(8) 4429 CHARACTER CFIL*(*),CPFIL*(*) 4430#include "ccorb.h" 4431#include "symsq.h" 4432#include "ccsdsym.h" 4433#include "ccsdio.h" 4434#include "r12int.h" 4435C 4436 INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J 4437C 4438 IF (IOPTE.EQ.1) THEN 4439 IF (.NOT.CCR12) CALL QUIT('IOPTE only implemented for CC-R12') 4440 IBASX(1) = 0 4441 DO ISYM = 2, NSYM 4442 IBASX(ISYM) = IBASX(ISYM-1) + MBAS2(ISYM-1) 4443 END DO 4444 DO ISYM = 1, NSYM 4445 NADP(ISYM) = 0 4446 DO ISYM2 = 1, NSYM 4447 ISYM1 = MULD2H(ISYM,ISYM2) 4448 IADP(ISYM1,ISYM2) = NADP(ISYM) 4449 NADP(ISYM) = NADP(ISYM) + 4450 & NVIR(ISYM1)*(MBAS1(ISYM2)+MBAS2(ISYM2)) 4451 END DO 4452 END DO 4453 END IF 4454C 4455 ISYAIK = MULD2H(ISYDIS,ISYMPC) 4456 ISAIK2 = MULD2H(ISYDIS,ISYMT2) 4457 IF (ISYAIK .NE. ISAIK2) CALL QUIT('Symmetry mismatch in CCRHS_C') 4458C 4459C------------------------------------------------------- 4460C Calculate the integrals K(k,dl) = (k d | l delta). 4461C------------------------------------------------------- 4462C 4463 IF (ICON .GE. 2) THEN 4464C 4465 DO 100 ISYML = 1,NSYM 4466C 4467 ISYMAG = MULD2H(ISYML,ISYDIS) 4468C 4469 DO 110 L = 1,NRHF(ISYML) 4470C 4471 KSCR10 = 1 4472 KEND1 = KSCR10 + N2BST(ISYMAG) 4473 LWRK1 = LWORK - KEND1 4474 IF (LWRK1 .LT. 0) THEN 4475 CALL QUIT('Not enough space for '// 4476 & 'allocation in CCRHS_C1') 4477 END IF 4478C 4479 KOFF1 = IDSRHF(ISYMAG,ISYML) + NNBST(ISYMAG)*(L-1) + 1 4480 CALL CCSD_SYMSQ(DSRHF(KOFF1),ISYMAG,WORK(KSCR10)) 4481C 4482 DO 120 ISYMDL = 1,NSYM 4483C 4484 ISYMD = MULD2H(ISYML,ISYMDL) 4485 ISYMK = MULD2H(ISYMDL,ISYDIS) 4486 ISYMA = ISYMK 4487 ISYMG = ISYMD 4488C 4489 NBASA = MAX(NBAS(ISYMA),1) 4490 NBASG = MAX(NBAS(ISYMG),1) 4491 NRHFK = MAX(NRHF(ISYMK),1) 4492C 4493 KSCR11 = KEND1 4494 KEND2 = KSCR11 + NRHF(ISYMK)*NBAS(ISYMG) 4495 LWRK2 = LWORK - KEND2 4496 IF (LWRK2 .LT. 0) THEN 4497 CALL QUIT('Not enough space for '// 4498 & 'allocation in CCRHS_C1') 4499 END IF 4500C 4501 KOFF2 = ILMRHF(ISYMK) + 1 4502 KOFF3 = IAODIS(ISYMA,ISYMG) + 1 4503C 4504 CALL DGEMM('T','N',NRHF(ISYMK),NBAS(ISYMG), 4505 * NBAS(ISYMA),ONE,XLAMDP(KOFF2),NBASA, 4506 * WORK(KOFF3),NBASA, 4507 * ZERO,WORK(KSCR11),NRHFK) 4508C 4509 NDL = IT1AM(ISYMD,ISYML) 4510 * + NVIR(ISYMD)*(L - 1) + 1 4511 KOFF5 = ILMVIR(ISYMD) + 1 4512 KOFF6 = IT2BCT(ISYMK,ISYMDL) 4513 * + NRHF(ISYMK)*(NDL - 1) + 1 4514C 4515 CALL DGEMM('N','N',NRHF(ISYMK),NVIR(ISYMD), 4516 * NBAS(ISYMG),ONE,WORK(KSCR11),NRHFK, 4517 * XLAMDH(KOFF5),NBASG, 4518 * ZERO,SCR1(KOFF6),NRHFK) 4519C 4520 120 CONTINUE 4521C 4522 110 CONTINUE 4523C 4524 100 CONTINUE 4525C 4526C----------------------------------------- 4527C Calculate the first contribution. 4528C Sum(dl)T(al,di)*I(lckd) 4529C----------------------------------------- 4530C 4531 IF (LWORK .LT. NT2BCD(ISYAIK)) THEN 4532 CALL QUIT('Insufficient work space in CCRHS_C1') 4533 ENDIF 4534C 4535 DO 200 ISYMK = 1,NSYM 4536C 4537 ISYMAI = MULD2H(ISYAIK,ISYMK) 4538 ISYMDL = MULD2H(ISYDIS,ISYMK) 4539C 4540 NRHFK = MAX(NRHF(ISYMK),1) 4541 NTOTDL = MAX(NT1AM(ISYMDL),1) 4542C 4543 KOFF1 = IT2BCT(ISYMK,ISYMDL) + 1 4544 KOFF2 = IT2SQ(ISYMDL,ISYMAI) + 1 4545 KOFF3 = IT2BCT(ISYMK,ISYMAI) + 1 4546C 4547 CALL DGEMM('N','N',NRHF(ISYMK),NT1AM(ISYMAI),NT1AM(ISYMDL), 4548 * ONE,SCR1(KOFF1),NRHFK,T2AM(KOFF2),NTOTDL,ZERO, 4549 * WORK(KOFF3),NRHFK) 4550C 4551 200 CONTINUE 4552C 4553 CALL DCOPY(NT2BCD(ISYAIK),WORK,1,SCR1,1) 4554C 4555 !save a copy for first contribution: 4556 IF (IOPTR12.EQ.1) THEN 4557 CALL DCOPY(NT2BCD(ISYAIK),WORK,1,SCR4,1) 4558 END IF 4559C 4560 ENDIF 4561C 4562C---------------------------------------------------------- 4563C Calculate the integrals K(k,ai) = (k i | alfa delta). 4564C---------------------------------------------------------- 4565C 4566 DO 300 ISYMA = 1,NSYM 4567C 4568 ISYMBG = MULD2H(ISYMA,ISYDIS) 4569C 4570 KSCR10 = 1 4571 KEND1 = KSCR10 + N2BST(ISYMBG) 4572 LWRK1 = LWORK - KEND1 4573 IF (LWRK1 .LT. 0) THEN 4574 CALL QUIT('Not enough space for allocation in CCRHS_C1') 4575 END IF 4576C 4577 DO 310 A = 1,NBAS(ISYMA) 4578C 4579 KOFF1 = IDSAOG(ISYMA,ISYDIS) + NNBST(ISYMBG)*(A - 1) + 1 4580 CALL CCSD_SYMSQ(XINT(KOFF1),ISYMBG,WORK(KSCR10)) 4581C 4582 DO 320 ISYMG = 1,NSYM 4583C 4584 ISYMI = ISYMG 4585 ISYMB = MULD2H(ISYMG,ISYMBG) 4586 ISYMK = ISYMB 4587 ISYMAI = MULD2H(ISYMA,ISYMI) 4588C 4589 NBASB = MAX(NBAS(ISYMB),1) 4590 NBASG = MAX(NBAS(ISYMG),1) 4591 NRHFK = MAX(NRHF(ISYMK),1) 4592C 4593 KSCR11 = KEND1 4594 KSCR12 = KSCR11 + NRHF(ISYMK)*NBAS(ISYMG) 4595 KEND2 = KSCR12 + NRHF(ISYMK)*NRHF(ISYMI) 4596 LWRK2 = LWORK - KEND2 4597 IF (LWRK2 .LT. 0) THEN 4598 CALL QUIT('Not enough space for '// 4599 & 'allocation in CCRHS_C1') 4600 END IF 4601C 4602 KOFF2 = ILMRHF(ISYMK) + 1 4603 KOFF3 = KSCR10 + IAODIS(ISYMB,ISYMG) 4604C 4605 CALL DGEMM('T','N',NRHF(ISYMK),NBAS(ISYMG),NBAS(ISYMB), 4606 * ONE,XLAMDP(KOFF2),NBASB,WORK(KOFF3),NBASB, 4607 * ZERO,WORK(KSCR11),NRHFK) 4608C 4609 KOFF5 = ILMRHF(ISYMI) + 1 4610C 4611 CALL DGEMM('N','N',NRHF(ISYMK),NRHF(ISYMI),NBAS(ISYMG), 4612 * ONE,WORK(KSCR11),NRHFK,XLAMDH(KOFF5),NBASG, 4613 * ZERO,WORK(KSCR12),NRHFK) 4614C 4615C 4616 DO 330 I = 1,NRHF(ISYMI) 4617C 4618 NAI = IT1AO(ISYMA,ISYMI) + NBAS(ISYMA)*(I-1) + A 4619C 4620 KOFF8 = IT2BGT(ISYMK,ISYMAI) 4621 * + NRHF(ISYMK)*(NAI - 1) + 1 4622 KOFF7 = KSCR12 + NRHF(ISYMK)*(I - 1) 4623C 4624 CALL DCOPY(NRHF(ISYMK),WORK(KOFF7),1,SCR2(KOFF8),1) 4625C 4626 330 CONTINUE 4627C 4628C 4629C------------------------------------------------------- 4630C In 2C1 linear transformation extra cont. 4631C------------------------------------------------------- 4632C 4633 IF ((ICON .EQ. 3) .OR. (ICON .EQ. 1)) THEN 4634C 4635 ISYMI = MULD2H(ISYMG,ISYMHC) 4636 ISYMAI = MULD2H(ISYMA,ISYMI) 4637C 4638 KEND2 = KSCR12 + NRHF(ISYMK)*NRHF(ISYMI) 4639 LWRK2 = LWORK - KEND2 4640 IF (LWRK2 .LT. 0) THEN 4641 CALL QUIT('Not enough space for '// 4642 & 'allocation in CCRHS_D1') 4643 END IF 4644C 4645 KOFF5 = IGLMRH(ISYMG,ISYMI) + 1 4646C 4647 CALL DGEMM('N','N',NRHF(ISYMK),NRHF(ISYMI), 4648 * NBAS(ISYMG),ONE,WORK(KSCR11),NRHFK, 4649 * XLAMHC(KOFF5),NBASG, 4650 * ZERO,WORK(KSCR12),NRHFK) 4651C 4652 DO 331 I = 1,NRHF(ISYMI) 4653C 4654 NAI = IT1AO(ISYMA,ISYMI) + NBAS(ISYMA)*(I-1) + A 4655C 4656 KOFF8 = IT2BGT(ISYMK,ISYMAI) 4657 * + NRHF(ISYMK)*(NAI - 1) + 1 4658 KOFF7 = KSCR12 + NRHF(ISYMK)*(I - 1) 4659C 4660 CALL DCOPY(NRHF(ISYMK),WORK(KOFF7),1,SCR3(KOFF8),1) 4661C 4662 331 CONTINUE 4663C 4664 ENDIF 4665C 4666 320 CONTINUE 4667C 4668 310 CONTINUE 4669C 4670 300 CONTINUE 4671C 4672 IF (DUMPCD) GOTO 800 4673C 4674 IF (CCR12) CALL QUIT('CCSDR12 requires DUMPCD=.TRUE.') 4675C 4676C----------------------------------------- 4677C Back transformation to the AO basis. 4678C----------------------------------------- 4679C 4680 DO 400 ISYMAI = 1,NSYM 4681C 4682 ISYMK = MULD2H(ISYMAI,ISYDIS) 4683C 4684 NRHFK = MAX(NRHF(ISYMK),1) 4685C 4686 DO 410 ISYMI = 1,NSYM 4687C 4688 ISYMA = MULD2H(ISYMI,ISYMAI) 4689C 4690 NBASA = MAX(NBAS(ISYMA),1) 4691C 4692 DO 420 I = 1,NRHF(ISYMI) 4693C 4694 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + 1 4695 MAI = IT1AO(ISYMA,ISYMI) + NBAS(ISYMA)*(I - 1) + 1 4696C 4697 KOFF1 = IT2BCT(ISYMK,ISYMAI) + NRHF(ISYMK)*(NAI - 1) + 1 4698 KOFF2 = ILMVIR(ISYMA) + 1 4699 KOFF3 = IT2BGT(ISYMK,ISYMAI) + NRHF(ISYMK)*(MAI - 1) + 1 4700C 4701 CALL DGEMM('N','T',NRHF(ISYMK),NBAS(ISYMA),NVIR(ISYMA), 4702 * XMHALF,SCR1(KOFF1),NRHFK,XLAMIP(KOFF2),NBASA, 4703 * ONE,SCR2(KOFF3),NRHFK) 4704C 4705 420 CONTINUE 4706C 4707 410 CONTINUE 4708C 4709 400 CONTINUE 4710C 4711C 4712 DO 500 ISYMK = 1,NSYM 4713C 4714 ISYMBJ = MULD2H(ISYMK,ISYDEL) 4715C 4716 DO 510 K = 1,NRHF(ISYMK) 4717C 4718 DO 520 ISYMJ = 1,NSYM 4719C 4720 ISYMB = MULD2H(ISYMJ,ISYMBJ) 4721C 4722 NBASB = MAX(NBAS(ISYMB),1) 4723 NVIRB = MAX(NVIR(ISYMB),1) 4724C 4725 KOFF1 = ILMVIR(ISYMB) + 1 4726 KOFF2 = IT2BCD(ISYMBJ,ISYMK) + NT1AM(ISYMBJ)*(K - 1) 4727 * + IT1AM(ISYMB,ISYMJ) + 1 4728 KOFF3 = IT2BGD(ISYMBJ,ISYMK) + NT1AO(ISYMBJ)*(K - 1) 4729 * + IT1AO(ISYMB,ISYMJ) + 1 4730C 4731 CALL DGEMM('N','N',NBAS(ISYMB),NRHF(ISYMJ),NVIR(ISYMB), 4732 * ONE,XLAMIP(KOFF1),NBASB,SCRM(KOFF2),NVIRB, 4733 * ZERO,SCR3(KOFF3),NBASB) 4734C 4735 520 CONTINUE 4736C 4737 510 CONTINUE 4738C 4739 500 CONTINUE 4740C 4741C--------------------------------------- 4742C Calculate the second contribution. 4743C 4744C Alfredo will introduce the batching over ai before the 4745C end of august 1994. 4746C--------------------------------------- 4747C 4748 DO 600 ISYMAI = 1,NSYM 4749C 4750 ISYMK = MULD2H(ISYMAI,ISYDIS) 4751 ISYMBJ = MULD2H(ISYMK,ISYDEL) 4752C 4753 IF (NRHF(ISYMK) .EQ. 0) GOTO 600 4754C 4755 IF (LWORK .LT. NT1AO(ISYMBJ)) THEN 4756 CALL QUIT('Insufficient work space in CCRHS_C1') 4757 ENDIF 4758C 4759 NTOTBJ = MAX(NT1AO(ISYMBJ),1) 4760C 4761 DO 610 ISYMI = 1,NSYM 4762C 4763 ISYMA = MULD2H(ISYMI,ISYMAI) 4764C 4765 DO 620 I = 1,NRHF(ISYMI) 4766C 4767 DO 630 A = 1,NBAS(ISYMA) 4768C 4769 NAI = IT1AO(ISYMA,ISYMI) + NBAS(ISYMA)*(I-1) + A 4770C 4771 KOFF1 = IT2BGD(ISYMBJ,ISYMK) + 1 4772 KOFF2 = IT2BGT(ISYMK,ISYMAI) 4773 * + NRHF(ISYMK)*(NAI - 1) + 1 4774C 4775 CALL DGEMV('N',NT1AO(ISYMBJ),NRHF(ISYMK),ONE, 4776 * SCR3(KOFF1),NTOTBJ,SCR2(KOFF2),1, 4777 * ZERO,WORK,1) 4778C 4779 IF (.NOT. OMEGSQ) THEN 4780C 4781C 4782 IF (ISYMAI .EQ. ISYMBJ) THEN 4783 WORK(NAI) = TWO*WORK(NAI) 4784 ENDIF 4785C 4786 DO 640 ISYMJ = 1,NSYM 4787C 4788 ISYMB = MULD2H(ISYMJ,ISYMBJ) 4789 ISYMAJ = MULD2H(ISYMA,ISYMJ) 4790 ISYMBI = MULD2H(ISYMB,ISYMI) 4791C 4792 DO 650 J = 1,NRHF(ISYMJ) 4793C 4794 NAJ = IT1AO(ISYMA,ISYMJ) + NBAS(ISYMA)*(J-1) + A 4795C 4796 DO 660 B = 1,NBAS(ISYMB) 4797C 4798 NBI = IT1AO(ISYMB,ISYMI) 4799 * + NBAS(ISYMB)*(I-1) + B 4800 NBJ = IT1AO(ISYMB,ISYMJ) 4801 * + NBAS(ISYMB)*(J-1) + B 4802C 4803 NAIBJ = IT2AO(ISYMAI,ISYMBJ) + INDEX(NAI,NBJ) 4804 NAJBI = IT2AO(ISYMAJ,ISYMBI) + INDEX(NAJ,NBI) 4805C 4806 OMEGA2(NAIBJ) = OMEGA2(NAIBJ)-HALF*WORK(NBJ) 4807 OMEGA2(NAJBI) = OMEGA2(NAJBI)-WORK(NBJ) 4808C 4809 660 CONTINUE 4810 650 CONTINUE 4811 640 CONTINUE 4812C 4813C 4814 ELSE 4815C 4816C 4817 KOFF = IT2AOS(ISYMBJ,ISYMAI) 4818 * + NT1AO(ISYMBJ)*(NAI - 1) + 1 4819 CALL DAXPY(NT1AO(ISYMBJ),-HALF,WORK,1,OMEGA2(KOFF),1) 4820C 4821 DO 740 ISYMJ = 1,NSYM 4822C 4823 ISYMB = MULD2H(ISYMJ,ISYMBJ) 4824 ISYMAJ = MULD2H(ISYMA,ISYMJ) 4825 ISYMBI = MULD2H(ISYMB,ISYMI) 4826C 4827 NBI = IT1AO(ISYMB,ISYMI) + NBAS(ISYMB)*(I-1) + 1 4828 4829C 4830 DO 750 J = 1,NRHF(ISYMJ) 4831C 4832 NAJ = IT1AO(ISYMA,ISYMJ) + NBAS(ISYMA)*(J-1) + A 4833 NBJ = IT1AO(ISYMB,ISYMJ) + NBAS(ISYMB)*(J-1) + 1 4834C 4835 NBIAJ = IT2AOS(ISYMBI,ISYMAJ) 4836 * + NT1AO(ISYMBI)*(NAJ - 1) + NBI 4837C 4838 CALL DAXPY(NBAS(ISYMB),-ONE,WORK(NBJ),1, 4839 * OMEGA2(NBIAJ),1) 4840C 4841 750 CONTINUE 4842 740 CONTINUE 4843C 4844 ENDIF 4845C 4846 630 CONTINUE 4847 620 CONTINUE 4848C 4849 610 CONTINUE 4850 600 CONTINUE 4851C 4852 GOTO 999 4853C 4854C------------------- 4855C I/O algorithm. 4856C------------------- 4857C 4858 800 CONTINUE 4859C 4860C----------------------------------------------- 4861C Transform the alpha index of K(k,ai) to a. 4862C----------------------------------------------- 4863C 4864 ISYAIK = MULD2H(ISYDIS,ISYMPC) 4865C 4866 IF ( ICON .EQ. 1 ) CALL DZERO(SCR1,NT2BCD(ISYAIK)) 4867C 4868 DO 810 ISYMAI = 1,NSYM 4869C 4870 ISYMK = MULD2H(ISYMAI,ISYAIK) 4871 NRHFK = MAX(NRHF(ISYMK),1) 4872C 4873 DO 820 ISYMI = 1,NSYM 4874C 4875 ISYMA = MULD2H(ISYMI,ISYMAI) 4876 ISYMAL= MULD2H(ISYMPC,ISYMA) 4877 ISYALI= MULD2H(ISYMAL,ISYMI) 4878 NBASAL = MAX(NBAS(ISYMAL),1) 4879C 4880 DO 830 I = 1,NRHF(ISYMI) 4881C 4882 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + 1 4883 MALI = IT1AO(ISYMAL,ISYMI) + NBAS(ISYMAL)*(I - 1) + 1 4884C 4885 KOFF1 = IT2BGT(ISYMK,ISYALI) + NRHF(ISYMK)*(MALI- 1) + 1 4886 KOFF2 = IGLMVI(ISYMAL,ISYMA) + 1 4887 KOFF3 = IT2BCT(ISYMK,ISYMAI) + NRHF(ISYMK)*(NAI - 1) + 1 4888C 4889 CALL DGEMM('N','N',NRHF(ISYMK),NVIR(ISYMA),NBAS(ISYMAL), 4890 * ONE,SCR2(KOFF1),NRHFK,XLAMPC(KOFF2),NBASAL, 4891 * FACTC,SCR1(KOFF3),NRHFK) 4892C 4893 IF (IOPTE.EQ.1) THEN 4894 IF (ISYMI.EQ.ISYMK) THEN 4895 KOFF3 = IT2BCT(ISYMK,ISYMAI) + 4896 & NRHF(ISYMK)*(NAI - 1) + I 4897 IF (IDEL.GT.NBAST) THEN 4898 D = IDEL-IBASX(ISYDEL)-NBAST+MBAS1(ISYDEL) 4899 ELSE 4900 D = IDEL-IBAS(ISYDEL) 4901 END IF 4902C WRITE(LUPRI,*)'ISYDEL, IDEL, D:',ISYDEL, IDEL, D 4903 KOFFE = IADP(ISYMA,ISYDEL) + 4904 & NVIR(ISYMA)*(D-1) + 1 4905 CALL DAXPY(NVIR(ISYMA),1.5D0,SCR1(KOFF3),NRHF(ISYMK), 4906 & E1PIM(KOFFE),1) 4907 END IF 4908 END IF 4909C 4910 830 CONTINUE 4911 820 CONTINUE 4912 810 CONTINUE 4913C 4914C----------------------------------------------- 4915C Transform the alpha index of K(k,ai) to a. 4916C I is C1 transformed. 4917C----------------------------------------------- 4918C 4919 IF ((ICON .EQ. 3) .OR. (ICON .EQ. 1)) THEN 4920C 4921 ISYAIK = MULD2H(ISYDIS,ISYMHC) 4922C 4923 DO 850 ISYMAI = 1,NSYM 4924C 4925 ISYMK = MULD2H(ISYMAI,ISYAIK) 4926 NRHFK = MAX(NRHF(ISYMK),1) 4927C 4928 DO 860 ISYMI = 1,NSYM 4929C 4930 ISYMA = MULD2H(ISYMI,ISYMAI) 4931 ISYMAL= ISYMA 4932 ISYALI= MULD2H(ISYMAL,ISYMI) 4933 NBASAL = MAX(NBAS(ISYMAL),1) 4934C 4935 DO 870 I = 1,NRHF(ISYMI) 4936C 4937 NAI = IT1AM(ISYMA,ISYMI) 4938 * + NVIR(ISYMA)*(I - 1) + 1 4939 MALI = IT1AO(ISYMAL,ISYMI) 4940 * + NBAS(ISYMAL)*(I - 1) + 1 4941C 4942 KOFF1 = IT2BGT(ISYMK,ISYALI) 4943 * + NRHF(ISYMK)*(MALI - 1) + 1 4944 KOFF2 = ILMVIR(ISYMA) + 1 4945 KOFF3 = IT2BCT(ISYMK,ISYMAI) 4946 * + NRHF(ISYMK)*(NAI - 1) + 1 4947C 4948 CALL DGEMM('N','N',NRHF(ISYMK),NVIR(ISYMA), 4949 * NBAS(ISYMAL),ONE,SCR3(KOFF1),NRHFK, 4950 * XLAMDP(KOFF2),NBASAL, 4951 * ONE,SCR1(KOFF3),NRHFK) 4952C 4953 870 CONTINUE 4954 860 CONTINUE 4955 850 CONTINUE 4956C 4957 ENDIF 4958C--------------------------------------------------------- 4959C Dump to disk the new contribution. 4960C energy calc icon = 2 4961C rsp calc. write to position given by it2dlr(idel,iv) 4962C--------------------------------------------------------- 4963C 4964 IF ( ICON .EQ. 2 ) THEN 4965C 4966 IOFF = IT2DEL(IDEL) + 1 4967C 4968 ELSE 4969C 4970 IOFF = IT2DLR(IDEL,IV) + 1 4971C 4972 ENDIF 4973C 4974 IF (NT2BCD(ISYAIK) .GT. 0) THEN 4975 CALL PUTWA2(LUC,CFIL,SCR1,IOFF,NT2BCD(ISYAIK)) 4976 ENDIF 4977C 4978 IF (IOPTR12.EQ.1) THEN 4979 CALL DAXPY(NT2BCD(ISYAIK),FACTC,SCR4,1,SCR1,1) 4980 IF (NT2BCD(ISYAIK) .GT. 0) THEN 4981 CALL PUTWA2(LUCP,CPFIL,SCR1,IOFF,NT2BCD(ISYAIK)) 4982 END IF 4983 END IF 4984C 4985 999 CONTINUE 4986C 4987 RETURN 4988 END 4989C /* Deck ccrhs_gam */ 4990 SUBROUTINE CCRHS_GAM(DSRHF,GAMMA,XLAMDP,XLAMDH,SCRM, 4991 * WORK,LWORK,IDEL,ISYMD) 4992C 4993C Written by Henrik Koch 3-Jan-1994 4994C Symmetry by Henrik Koch and Alfredo Sanchez. 21-July-1994 4995C 4996C Purpose: Calculate the gamma intermediate. 4997C 4998#include "implicit.h" 4999 DIMENSION DSRHF(*),GAMMA(*),SCRM(*) 5000 DIMENSION WORK(LWORK) 5001 DIMENSION XLAMDP(*),XLAMDH(*) 5002#include "priunit.h" 5003#include "ccorb.h" 5004#include "ccsdsym.h" 5005C 5006C------------------------ 5007C Dynamic allocation. 5008C------------------------ 5009C 5010 KLAMDA = 1 5011 KEND1 = KLAMDA + NRHF(ISYMD) 5012 LWRK1 = LWORK - KEND1 5013C 5014 IF (LWRK1 .LT. 0) THEN 5015 WRITE(LUPRI,*) 'Need : ',KEND1,'Available : ',LWORK 5016 CALL QUIT('Insufficient space in CCRHS_GAM') 5017 ENDIF 5018C 5019C--------------------------------------- 5020C Copy XLAMDH vector for given IDEL. 5021C--------------------------------------- 5022C 5023 KOFF1 = ILMRHF(ISYMD) + IDEL - IBAS(ISYMD) 5024 CALL DCOPY(NRHF(ISYMD),XLAMDH(KOFF1),NBAS(ISYMD),WORK(KLAMDA),1) 5025C 5026C-------------------------------- 5027C Calculate the contribution. 5028C-------------------------------- 5029C 5030 ISYDIS = MULD2H(ISYMD,ISYMOP) 5031C 5032 DO 100 ISYML = 1,NSYM 5033C 5034 ISYMAG = MULD2H(ISYML,ISYDIS) 5035C 5036C--------------------------- 5037C Dynamic allocation. 5038C--------------------------- 5039C 5040 KSCR1 = KEND1 5041 KSCR2 = KSCR1 + N2BST(ISYMAG) 5042 KSCR3 = KSCR2 + NT1AO(ISYMAG) 5043 KSCR4 = KSCR3 + NT1AM(ISYMAG) 5044 KEND2 = KSCR4 + NMATIJ(ISYMAG) 5045 LWRK2 = LWORK - KEND2 5046C 5047 IF (LWRK2 .LT. 0) THEN 5048 WRITE(LUPRI,*) 'Need : ',KEND2,'Available : ',LWORK 5049 CALL QUIT('Insufficient space in CCRHS_GAM') 5050 ENDIF 5051C 5052 CALL CCRHS_GAM1(DSRHF,GAMMA,SCRM,WORK(KLAMDA),XLAMDP,XLAMDH, 5053 * WORK(KSCR1),WORK(KSCR2),WORK(KSCR3), 5054 * WORK(KSCR4),WORK(KEND2),LWRK2,ISYMD,ISYML, 5055 * ISYMAG) 5056C 5057 100 CONTINUE 5058C 5059 RETURN 5060 END 5061 SUBROUTINE CCRHS_GAM1(DSRHF,GAMMA,SCRM,XLAM, 5062 * XLAMDP,XLAMDH,SCR1,SCR2,SCR3,SCR4,WORK, 5063 * LWORK,ISYMD,ISYML,ISYMAG) 5064C 5065C Written by Henrik Koch 3-Jan-1994 5066C 5067C Purpose: Calculate the gamma intermediate. 5068C 5069#include "implicit.h" 5070 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0) 5071 DIMENSION DSRHF(*),GAMMA(*),SCRM(*),XLAM(*) 5072 DIMENSION SCR1(*),SCR2(*),SCR3(*),SCR4(*),WORK(*) 5073 DIMENSION XLAMDP(*),XLAMDH(*) 5074#include "priunit.h" 5075#include "ccorb.h" 5076#include "ccsdsym.h" 5077C 5078C INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J 5079C 5080 ISYMKC = ISYMAG 5081C 5082 DO 100 L = 1,NRHF(ISYML) 5083C 5084 KOFF1 = IDSRHF(ISYMAG,ISYML) + NNBST(ISYMAG)*(L - 1) + 1 5085C 5086 CALL CCSD_SYMSQ(DSRHF(KOFF1),ISYMAG,SCR1) 5087C 5088 DO 110 ISYMG = 1,NSYM 5089C 5090 ISYMA = MULD2H(ISYMG,ISYMAG) 5091 ISYMK = ISYMA 5092 ISYMC = ISYMG 5093 ISYMI = ISYMG 5094C 5095 NBASA = MAX(NBAS(ISYMA),1) 5096 NBASG = MAX(NBAS(ISYMG),1) 5097 NRHFK = MAX(NRHF(ISYMK),1) 5098C 5099 KOFF2 = ILMRHF(ISYMK) + 1 5100 KOFF3 = IAODIS(ISYMA,ISYMG) + 1 5101 KOFF4 = IT1AOT(ISYMK,ISYMG) + 1 5102C 5103 CALL DGEMM('T','N',NRHF(ISYMK),NBAS(ISYMG),NBAS(ISYMA), 5104 * ONE,XLAMDP(KOFF2),NBASA,SCR1(KOFF3),NBASA, 5105 * ZERO,SCR2(KOFF4),NRHFK) 5106C 5107 KOFF5 = ILMVIR(ISYMC) + 1 5108 KOFF6 = IT1AMT(ISYMK,ISYMC) + 1 5109C 5110 CALL DGEMM('N','N',NRHF(ISYMK),NVIR(ISYMC),NBAS(ISYMG), 5111 * ONE,SCR2(KOFF4),NRHFK,XLAMDH(KOFF5),NBASG, 5112 * ZERO,SCR3(KOFF6),NRHFK) 5113C 5114 KOFF7 = ILMRHF(ISYMI) + 1 5115 KOFF8 = IMATIJ(ISYMK,ISYMI) + 1 5116C 5117 CALL DGEMM('N','N',NRHF(ISYMK),NRHF(ISYMI),NBAS(ISYMG), 5118 * ONE,SCR2(KOFF4),NRHFK,XLAMDH(KOFF7),NBASG, 5119 * ZERO,SCR4(KOFF8),NRHFK) 5120C 5121 110 CONTINUE 5122C 5123 DO 120 ISYMJ = 1,NSYM 5124C 5125 ISYMLJ = MULD2H(ISYML,ISYMJ) 5126 ISYMKI = MULD2H(ISYMLJ,ISYMOP) 5127 ISYMCI = MULD2H(ISYMJ,ISYMD) 5128C 5129 KSCR5 = 1 5130 KEND1 = KSCR5 + NMATIJ(ISYMKI) 5131C 5132 IF (ISYMKI .GT. ISYMLJ) GOTO 120 5133C 5134 DO 130 J = 1,NRHF(ISYMJ) 5135C 5136 DO 140 ISYMI = 1,NSYM 5137C 5138 ISYMC = MULD2H(ISYMI,ISYMCI) 5139 ISYMK = MULD2H(ISYMI,ISYMKI) 5140C 5141 NVIRC = MAX(NVIR(ISYMC),1) 5142 NRHFK = MAX(NRHF(ISYMK),1) 5143C 5144 KOFF2 = IT1AMT(ISYMK,ISYMC) + 1 5145 KOFF3 = IT2BCD(ISYMCI,ISYMJ) 5146 * + NT1AM(ISYMCI)*(J - 1) 5147 * + IT1AM(ISYMC,ISYMI) + 1 5148 KOFF4 = KSCR5 + IMATIJ(ISYMK,ISYMI) 5149C 5150 CALL DGEMM('N','N',NRHF(ISYMK),NRHF(ISYMI), 5151 * NVIR(ISYMC),ONE,SCR3(KOFF2),NRHFK, 5152 * SCRM(KOFF3),NVIRC,ZERO,WORK(KOFF4),NRHFK) 5153C 5154 140 CONTINUE 5155C 5156 IF (ISYMJ .EQ. ISYMD) THEN 5157 CALL DAXPY(NMATIJ(ISYMKI),XLAM(J),SCR4,1, 5158 * WORK(KSCR5),1) 5159 ENDIF 5160C 5161 NLJ = IMATIJ(ISYML,ISYMJ) + NRHF(ISYML)*(J - 1) + L 5162C 5163 IF (ISYMOP .EQ. 1) THEN 5164 KKILJ = IGAMMA(ISYMKI,ISYMLJ) + NLJ*(NLJ-1)/2 5165 DO 150 NKI = 1,NLJ 5166C 5167 KOFF = KSCR5 + NKI - 1 5168 NKILJ = KKILJ + NKI 5169 GAMMA(NKILJ) = GAMMA(NKILJ) + WORK(KOFF) 5170C 5171 150 CONTINUE 5172 ELSE 5173 KKILJ = IGAMMA(ISYMKI,ISYMLJ) 5174 * + NMATIJ(ISYMKI)*(NLJ - 1) 5175 DO 160 NKI = 1,NMATIJ(ISYMKI) 5176C 5177 KOFF = KSCR5 + NKI - 1 5178 NKILJ = KKILJ + NKI 5179 GAMMA(NKILJ) = GAMMA(NKILJ) + WORK(KOFF) 5180C 5181 160 CONTINUE 5182 END IF 5183C 5184 130 CONTINUE 5185 120 CONTINUE 5186C 5187 100 CONTINUE 5188C 5189 RETURN 5190 END 5191C /* Deck ccrhs_b */ 5192 SUBROUTINE CCRHS_B(XINT,OMEGA2,XLAMDP,XLAMDH,SCRM, 5193 * WORK,LWORK,IDEL,ISYMD) 5194C 5195C Written by Henrik Koch 3-Jan-1994 5196C Symmetry by Henrik Koch and Alfredo Sanchez. 18-July-1994 5197C 5198C Purpose: Calculate B-term. 5199C 5200#include "implicit.h" 5201 PARAMETER(ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, TWO = 2.0D0) 5202 DIMENSION XINT(*),OMEGA2(*),XLAMDH(*),WORK(LWORK) 5203 DIMENSION XLAMDP(*),SCRM(*) 5204#include "priunit.h" 5205#include "ccorb.h" 5206#include "ccsdsym.h" 5207C 5208C------------------------ 5209C Dynamic allocation. 5210C------------------------ 5211C 5212 KMGD = 1 5213 KEND1 = KMGD + NT2BGD(ISYMD) 5214 LWRK1 = LWORK - KEND1 5215C 5216 IF (LWRK1 .LT. 0) THEN 5217 WRITE(LUPRI,*) 'Need : ',KEND1,'Available : ',LWORK 5218 CALL QUIT('Insufficient space in CCRHS_B') 5219 ENDIF 5220C 5221C----------------------------- 5222C Prepare the data arrays. 5223C----------------------------- 5224C 5225C 5226 DO 100 ISYMJ = 1,NSYM 5227C 5228 ISYMCI = MULD2H(ISYMJ,ISYMD) 5229 ISYMGI = ISYMCI 5230C 5231 DO 110 ISYMI = 1,NSYM 5232C 5233 ISYMC = MULD2H(ISYMI,ISYMCI) 5234 ISYMG = ISYMC 5235C 5236 NVIRC = MAX(NVIR(ISYMC),1) 5237 NBASG = MAX(NBAS(ISYMG),1) 5238C 5239 KOFF1 = ILMVIR(ISYMC) + 1 5240C 5241 DO 120 J = 1,NRHF(ISYMJ) 5242C 5243 KOFF2 = IT2BCD(ISYMCI,ISYMJ) + IT1AM(ISYMC,ISYMI) 5244 * + NT1AM(ISYMCI)*(J - 1) + 1 5245 KOFF3 = IT2BGD(ISYMGI,ISYMJ) + IT1AO(ISYMG,ISYMI) 5246 * + NT1AO(ISYMGI)*(J - 1) + 1 5247C 5248 CALL DGEMM('N','N',NBAS(ISYMG),NRHF(ISYMI),NVIR(ISYMC), 5249 * ONE,XLAMDH(KOFF1),NBASG,SCRM(KOFF2),NVIRC, 5250 * ZERO,WORK(KOFF3),NBASG) 5251C 5252 IF (ISYMG .EQ. ISYMD) THEN 5253 KOFF4 = KOFF3 + IDEL - IBAS(ISYMD) - 1 5254 CALL DSCAL(NRHF(ISYMI),HALF,WORK(KOFF4),NBAS(ISYMG)) 5255 ENDIF 5256C 5257 120 CONTINUE 5258C 5259 110 CONTINUE 5260C 5261 100 CONTINUE 5262C 5263C-------------------------------- 5264C Calculate the contribution. 5265C-------------------------------- 5266C 5267 CALL CCRHS_B1(XINT,OMEGA2,WORK(KMGD),WORK(KEND1),LWRK1,IDEL,ISYMD) 5268C 5269 RETURN 5270 END 5271 SUBROUTINE CCRHS_B1(XINT,OMEGA2,XMGD,WORK,LWORK,IDEL,ISYMD) 5272C 5273C Written by Henrik Koch 3-Jan-1994 5274C 5275C Purpose: Calculate B-term. 5276C 5277#include "implicit.h" 5278#include "priunit.h" 5279#include "maxorb.h" 5280 PARAMETER(ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, TWO = 2.0D0) 5281 DIMENSION XINT(*),OMEGA2(*),XMGD(*) 5282 DIMENSION WORK(LWORK) 5283#include "ccorb.h" 5284#include "symsq.h" 5285#include "ccsdsym.h" 5286C 5287 INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J 5288C 5289 ISYDIS = MULD2H(ISYMOP,ISYMD) 5290C 5291C-------------------------------- 5292C Calculate the contribution. 5293C-------------------------------- 5294C 5295 IF (OMEGSQ) GOTO 200 5296C 5297 DO 100 ISYMB = 1,NSYM 5298C 5299 ISYMAG = MULD2H(ISYMB,ISYDIS) 5300C 5301 KSCR1 = 1 5302 KEND1 = KSCR1 + N2BST(ISYMAG) 5303 LWRK1 = LWORK - KEND1 5304C 5305 DO 110 B = 1,NBAS(ISYMB) 5306C 5307 KOFF1 = IDSAOG(ISYMB,ISYDIS) + NNBST(ISYMAG)*(B - 1) + 1 5308 CALL CCSD_SYMSQ(XINT(KOFF1),ISYMAG,WORK(KSCR1)) 5309C 5310 DO 120 ISYMJ = 1,NSYM 5311C 5312 ISYMBJ = MULD2H(ISYMB,ISYMJ) 5313 ISYMAI = MULD2H(ISYMBJ,ISYMOP) 5314 ISYMGI = MULD2H(ISYMJ,ISYMD) 5315C 5316 KSCR2 = KEND1 5317 KEND2 = KSCR2 + NT1AO(ISYMAI) 5318 LWRK2 = LWORK - KEND2 5319C 5320 DO 130 J = 1,NRHF(ISYMJ) 5321C 5322 CALL DZERO(WORK(KSCR2),NT1AO(ISYMAI)) 5323C 5324 DO 140 ISYMI = 1,NSYM 5325C 5326 ISYMG = MULD2H(ISYMI,ISYMGI) 5327C 5328 IF (ISYMG .GT. ISYMD) GOTO 140 5329C 5330 ISYMA = MULD2H(ISYMG,ISYMAG) 5331C 5332 KOFF2 = KSCR1 + IAODIS(ISYMA,ISYMG) 5333 KOFF3 = IT2BGD(ISYMGI,ISYMJ) 5334 * + NT1AO(ISYMGI)*(J - 1) + 1 5335 * + IT1AO(ISYMG,ISYMI) 5336 KOFF4 = KSCR2 + IT1AO(ISYMA,ISYMI) 5337C 5338 NBASA = MAX(NBAS(ISYMA),1) 5339 NBASG = MAX(NBAS(ISYMG),1) 5340C 5341 IF (ISYMG .LT. ISYMD) THEN 5342 NTOTG = NBAS(ISYMG) 5343 ELSE 5344 NTOTG = IDEL - IBAS(ISYMD) 5345 ENDIF 5346C 5347 CALL DGEMM('N','N',NBAS(ISYMA),NRHF(ISYMI), 5348 * NTOTG,ONE,WORK(KOFF2),NBASA, 5349 * XMGD(KOFF3),NBASG,ZERO,WORK(KOFF4), 5350 * NBASA) 5351C 5352 140 CONTINUE 5353C 5354C--------------------------------------- 5355C Accumulate the result. 5356C--------------------------------------- 5357C 5358 NBJ = IT1AO(ISYMB,ISYMJ) + NBAS(ISYMB)*(J - 1) + B 5359C 5360 IF (ISYMAI .EQ. ISYMBJ) THEN 5361 WORK(KSCR2+NBJ-1) = TWO*WORK(KSCR2+NBJ-1) 5362 ENDIF 5363C 5364 DO 150 NAI = 1,NT1AO(ISYMAI) 5365 KOFF5 = KSCR2 + NAI - 1 5366 NAIBJ = IT2AO(ISYMAI,ISYMBJ) + INDEX(NAI,NBJ) 5367 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + WORK(KOFF5) 5368 150 CONTINUE 5369C 5370 130 CONTINUE 5371 120 CONTINUE 5372C 5373 110 CONTINUE 5374 100 CONTINUE 5375C 5376 RETURN 5377C 5378 200 CONTINUE 5379C 5380 DO 300 ISYMB = 1,NSYM 5381C 5382 ISYMAG = MULD2H(ISYMB,ISYDIS) 5383C 5384 KSCR1 = 1 5385 KEND1 = KSCR1 + N2BST(ISYMAG) 5386 LWRK1 = LWORK - KEND1 5387C 5388 DO 310 B = 1,NBAS(ISYMB) 5389C 5390 KOFF1 = IDSAOG(ISYMB,ISYDIS) + NNBST(ISYMAG)*(B - 1) + 1 5391 CALL CCSD_SYMSQ(XINT(KOFF1),ISYMAG,WORK(KSCR1)) 5392C 5393 DO 320 ISYMJ = 1,NSYM 5394C 5395 ISYMBJ = MULD2H(ISYMB,ISYMJ) 5396 ISYMAI = MULD2H(ISYMBJ,ISYMOP) 5397 ISYMGI = MULD2H(ISYMJ,ISYMD) 5398C 5399 KSCR2 = KEND1 5400 KEND2 = KSCR2 + NT1AO(ISYMAI) 5401 LWRK2 = LWORK - KEND2 5402C 5403 DO 330 J = 1,NRHF(ISYMJ) 5404C 5405 NBJ = IT1AO(ISYMB,ISYMJ) + NBAS(ISYMB)*(J - 1) + B 5406C 5407 DO 340 ISYMI = 1,NSYM 5408C 5409 ISYMG = MULD2H(ISYMI,ISYMGI) 5410C 5411 IF (ISYMG .GT. ISYMD) GOTO 340 5412C 5413 ISYMA = MULD2H(ISYMG,ISYMAG) 5414C 5415 KOFF2 = KSCR1 + IAODIS(ISYMA,ISYMG) 5416 KOFF3 = IT2BGD(ISYMGI,ISYMJ) 5417 * + NT1AO(ISYMGI)*(J - 1) + 1 5418 * + IT1AO(ISYMG,ISYMI) 5419C 5420 KOFF4 = IT2AOS(ISYMAI,ISYMBJ) 5421 * + NT1AO(ISYMAI)*(NBJ - 1) 5422 * + IT1AO(ISYMA,ISYMI) + 1 5423C 5424 NBASA = MAX(NBAS(ISYMA),1) 5425 NBASG = MAX(NBAS(ISYMG),1) 5426C 5427 IF (ISYMG .LT. ISYMD) THEN 5428 NTOTG = NBAS(ISYMG) 5429 ELSE 5430 NTOTG = IDEL - IBAS(ISYMD) 5431 ENDIF 5432C 5433 CALL DGEMM('N','N',NBAS(ISYMA),NRHF(ISYMI), 5434 * NTOTG,ONE,WORK(KOFF2),NBASA, 5435 * XMGD(KOFF3),NBASG,ONE,OMEGA2(KOFF4), 5436 * NBASA) 5437C 5438 340 CONTINUE 5439C 5440 330 CONTINUE 5441 320 CONTINUE 5442C 5443 310 CONTINUE 5444 300 CONTINUE 5445C 5446 RETURN 5447 END 5448C /* Deck ccrhs_f */ 5449 SUBROUTINE CCRHS_F(XINT,OMEGA2,XLAMDH,WORK,LWORK,IDEL,ISYMD) 5450C 5451C Written by Henrik Koch 3-Jan-1994 5452C Symmetry by Henrik Koch and Alfredo Sanchez. 13-July-1994 5453C 5454C Purpose: Calculate F-term. 5455C 5456#include "implicit.h" 5457#include "priunit.h" 5458#include "maxorb.h" 5459 PARAMETER (HALF = 0.5D0) 5460 DIMENSION XINT(*),OMEGA2(*) 5461 DIMENSION XLAMDH(*),WORK(LWORK) 5462#include "ccorb.h" 5463#include "symsq.h" 5464#include "ccsdsym.h" 5465C 5466 ISYMJ = ISYMD 5467 ISYDIS = MULD2H(ISYMD,ISYMOP) 5468C 5469C------------------------ 5470C Dynamic allocation. 5471C------------------------ 5472C 5473 KLAMDA = 1 5474 KEND1 = KLAMDA + NRHF(ISYMJ) 5475 LWRK1 = LWORK - KEND1 5476C 5477 IF (LWRK1 .LT. 0) THEN 5478 WRITE(LUPRI,*) 'Need : ',KEND1,'Available : ',LWORK 5479 CALL QUIT('Insufficient space in CCRHS_F') 5480 ENDIF 5481C 5482C--------------------------------------- 5483C Copy XLAMDH vector for given IDEL. 5484C--------------------------------------- 5485C 5486 KOFF = ILMRHF(ISYMJ) + IDEL - IBAS(ISYMD) 5487 CALL DCOPY(NRHF(ISYMD),XLAMDH(KOFF),NBAS(ISYMD),WORK(KLAMDA),1) 5488C 5489 IF (OMEGSQ) THEN 5490 CALL DSCAL(NRHF(ISYMD),HALF,WORK(KLAMDA),1) 5491 ENDIF 5492C 5493C-------------------------------- 5494C Calculate the contribution. 5495C-------------------------------- 5496C 5497 DO 100 ISYMB = 1,NSYM 5498C 5499 ISYMBJ = MULD2H(ISYMB,ISYMJ) 5500 ISYMAI = MULD2H(ISYMBJ,ISYMOP) 5501C 5502 IF (ISYMAI .GT. ISYMBJ) GOTO 100 5503C 5504 KOFF1 = IDSAOG(ISYMB,ISYDIS) + 1 5505C 5506 IF (.NOT. OMEGSQ) THEN 5507 KOFF2 = IT2AO(ISYMAI,ISYMBJ) + 1 5508 ELSE 5509 KOFF2 = IT2AOS(ISYMAI,ISYMBJ) + 1 5510 ENDIF 5511C 5512C--------------------------------- 5513C Allocation of work space. 5514C--------------------------------- 5515C 5516 KSCR1 = KEND1 5517 KSCR2 = KSCR1 + N2BST(ISYMAI) 5518 KEND2 = KSCR2 + NT1AO(ISYMAI) 5519 LWRK2 = LWORK - KEND2 5520C 5521 IF (LWRK2 .LT. 0) THEN 5522 WRITE(LUPRI,*) 'Need : ',KEND2,'Available : ',LWORK 5523 CALL QUIT('Insufficient space in CCRHS_F') 5524 ENDIF 5525C 5526 CALL CCRHS_F1(XINT(KOFF1),OMEGA2(KOFF2),WORK(KLAMDA), 5527 * WORK(KSCR1),WORK(KSCR2), XLAMDH,ISYMJ, 5528 * ISYMB,ISYMAI) 5529C 5530 100 CONTINUE 5531C 5532 RETURN 5533 END 5534 SUBROUTINE CCRHS_F1(XINT,OMEGA2,XLAM,SCR1,SCR2,XLAMDH,ISYMJ, 5535 * ISYMB,ISYMAI) 5536C 5537C Written by Henrik Koch 3-Jan-1994 5538C Symmetry by Henrik Koch and Alfredo Sanchez. 13-July-1994 5539C 5540C Purpose: Calculate F-term. 5541C 5542#include "implicit.h" 5543 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0) 5544 DIMENSION XINT(*),OMEGA2(*),XLAM(*) 5545 DIMENSION SCR1(*),SCR2(*) 5546 DIMENSION XLAMDH(*) 5547#include "priunit.h" 5548#include "ccorb.h" 5549#include "ccsdsym.h" 5550C 5551 DO 100 B = 1,NBAS(ISYMB) 5552C 5553 KOFF1 = NNBST(ISYMAI)*(B-1) + 1 5554 CALL CCSD_SYMSQ(XINT(KOFF1),ISYMAI,SCR1) 5555C 5556 DO 110 ISYMI = 1,NSYM 5557C 5558 ISYMG = ISYMI 5559 ISYMA = MULD2H(ISYMI,ISYMAI) 5560C 5561 KOFF2 = IAODIS(ISYMA,ISYMG) + 1 5562 KOFF3 = ILMRHF(ISYMI) + 1 5563 KOFF4 = IT1AO(ISYMA,ISYMI) + 1 5564C 5565 NBASA = MAX(NBAS(ISYMA),1) 5566 NBASG = MAX(NBAS(ISYMG),1) 5567C 5568 CALL DGEMM('N','N',NBAS(ISYMA),NRHF(ISYMI),NBAS(ISYMG), 5569 * ONE,SCR1(KOFF2),NBASA,XLAMDH(KOFF3),NBASG, 5570 * ZERO,SCR2(KOFF4),NBASA) 5571C 5572 110 CONTINUE 5573C 5574 IF (.NOT. OMEGSQ) THEN 5575 DO 120 J = 1,NRHF(ISYMJ) 5576C 5577 NBJ = IT1AO(ISYMB,ISYMJ) + NBAS(ISYMB)*(J-1) + B 5578C 5579 IF (ISYMOP .EQ. 1) THEN 5580 NTOTAI = NBJ 5581 KOFF5 = NBJ*(NBJ - 1)/2 + 1 5582 ELSE 5583 NTOTAI = NT1AO(ISYMAI) 5584 KOFF5 = NT1AO(ISYMAI)*(NBJ - 1) + 1 5585 ENDIF 5586C 5587 IF (XLAM(J) .NE. ZERO) THEN 5588 CALL DAXPY(NTOTAI,XLAM(J),SCR2,1,OMEGA2(KOFF5),1) 5589 ENDIF 5590C 5591 120 CONTINUE 5592 ELSE 5593 DO 130 J = 1,NRHF(ISYMJ) 5594C 5595 NBJ = IT1AO(ISYMB,ISYMJ) + NBAS(ISYMB)*(J-1) + B 5596C 5597 KOFF5 = NT1AO(ISYMAI)*(NBJ - 1) + 1 5598C 5599 CALL DAXPY(NT1AO(ISYMAI),XLAM(J),SCR2,1,OMEGA2(KOFF5),1) 5600C 5601 130 CONTINUE 5602 ENDIF 5603C 5604 100 CONTINUE 5605C 5606 RETURN 5607 END 5608C /* Deck cctrbt */ 5609 SUBROUTINE CCTRBT(XINT,DSRHF,XLAMDP,ISYMLP,WORK,LWORK,ISYDIS) 5610C 5611C Written by Henrik Koch 3-Jan-1994 5612C Symmetry by Henrik Koch and Alfredo Sanchez. 12-July-1994 5613C 5614C Ove Christiansen 14-6-1996: General sym. lambda matrix ISYMLP 5615C 5616C Purpose: Transform integral batch. 5617C 5618#include "implicit.h" 5619 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0) 5620C 5621 DIMENSION XINT(*),DSRHF(*),XLAMDP(*),WORK(LWORK) 5622C 5623#include "priunit.h" 5624#include "ccorb.h" 5625#include "ccsdsym.h" 5626C 5627 KOFF1 = 1 5628 KOFF2 = 1 5629 KOFF3 = 1 5630 DO 100 ISYMG = 1,NSYM 5631C 5632 ISYMJ = MULD2H(ISYMLP,ISYMG) 5633 ISYMAB = MULD2H(ISYMG,ISYDIS) 5634C 5635 NNBSAB = MAX(NNBST(ISYMAB),1) 5636 NBASG = MAX(NBAS(ISYMG),1) 5637C 5638 KOFF2 = 1 + IGLMRH(ISYMG,ISYMJ) 5639 KOFF3 = 1 + IDSRHF(ISYMAB,ISYMJ) 5640C 5641 CALL DGEMM('N','N',NNBST(ISYMAB),NRHF(ISYMJ),NBAS(ISYMG), 5642 * ONE,XINT(KOFF1),NNBSAB,XLAMDP(KOFF2),NBASG, 5643 * ZERO,DSRHF(KOFF3),NNBSAB) 5644C 5645 KOFF1 = KOFF1 + NNBST(ISYMAB)*NBAS(ISYMG) 5646C 5647 100 CONTINUE 5648C 5649 RETURN 5650 END 5651C /* Deck ccrdao */ 5652 SUBROUTINE CCRDAO(XINT,IDELTA,IDEL2,WORK,LWORK,IRECNR,DIRECT) 5653C 5654C Written by Henrik Koch 25-Sep-1993 5655C 5656C Purpose: Read distribution of AO integrals. 5657C 5658#include "implicit.h" 5659#include "priunit.h" 5660#include "mxcent.h" 5661#include "maxorb.h" 5662#include "maxash.h" 5663#include "iratdef.h" 5664C 5665 LOGICAL FIRST, DIRECT 5666 DIMENSION XINT(*),WORK(LWORK) 5667 DIMENSION IRECNR(*) 5668C 5669 CHARACTER*8 NAME(8) 5670C 5671#include "ccorb.h" 5672C 5673C #include "infind.h" replaced by: #include <ccisao.h> 5674C (WK/UniKA/28-04-2003). 5675C 5676#include "ccisao.h" 5677C 5678#include "ccsdsym.h" 5679#include "cbieri.h" 5680#include "eribuf.h" 5681#include "ccpack.h" 5682#include "r12int.h" 5683C 5684 SAVE FIRST 5685 DATA FIRST /.TRUE./ 5686C 5687 DATA NAME /'CCAOIN_1','CCAOIN_2','CCAOIN_3','CCAOIN_4', 5688 * 'CCAOIN_5','CCAOIN_6','CCAOIN_7','CCAOIN_8'/ 5689 COMMON/SORTIO/LUAOIN(8) 5690C 5691 CALL QENTER('CCRDAO') 5692C 5693 ISYMD = ISAO(IDELTA) 5694 ISYDIS = MULD2H(ISYMD,ISYMOP) 5695C 5696 IF (.NOT. DIRECT) THEN 5697C 5698 NFILE = LUAOIN(ISYMD) 5699 IF (NFILE.LE.0) THEN 5700 NFILE = 0 5701 CALL WOPEN2(NFILE,NAME(ISYMD),64,0) 5702 LUAOIN(ISYMD) = NFILE 5703 END IF 5704C 5705 LENGTH = NDISAO(ISYDIS) 5706 NBYTE = NPCKINT(IDELTA) 5707 IOFF = IOFFINT(IDELTA) 5708 NDWORDS = LENGTH 5709C 5710 IF (LPACKINT) NDWORDS = (NBYTE+7)/8 5711C 5712 CALL GETWA2(NFILE,NAME(ISYMD),XINT,IOFF,NDWORDS) 5713C 5714 IF (LPACKINT) THEN 5715 DTIME = SECOND() 5716 CALL UNPCKR8(XINT,LENGTH,XINT,NBYTE, 5717 & IPCKTABINT,LPACKINT) 5718 PCKTIME = PCKTIME + SECOND() - DTIME 5719 END IF 5720C 5721 GOTO 999 5722 ENDIF 5723C 5724C---------------------------- 5725C Construct index arrays. 5726C---------------------------- 5727C 5728 KADR1 = 1 5729 KADR2 = KADR1 + (NBAST + 1)/IRAT + 1 5730 KEND1 = KADR2 + (NBAST*NBAST + 1)/IRAT + 1 5731 LWRK1 = LWORK - KEND1 5732C 5733 IF (LWRK1 .LT. 0) THEN 5734 CALL QUIT('Insufficient space for allocation in CCRDAO') 5735 END IF 5736C 5737 CALL CCRD_INIT(WORK(KADR1),WORK(KADR2),ISYDIS) 5738C 5739C-------------------- 5740C Construct XINT. 5741C-------------------- 5742C 5743 IF (U21INT) THEN 5744 CALL DZERO(XINT,2*NDISAO(ISYDIS)) 5745 ELSE 5746 CALL DZERO(XINT,NDISAO(ISYDIS)) 5747 END IF 5748C 5749C Buffer allocation 5750C 5751 KIBUF = KEND1 5752 KRBUF = KIBUF + (NIBUF*LBUF-1)/IRAT + 1 5753 KEND2 = KRBUF + LBUF 5754 LWRK2 = LWORK - KEND2 5755 IF (LWRK2 .LT. 0) THEN 5756 CALL QUIT('Insufficient work space in CCRDAO') 5757 ENDIF 5758C 5759 CALL CCRDA1(XINT,WORK(KIBUF),WORK(KRBUF),IDELTA,IDEL2, 5760 * WORK(KADR1),WORK(KADR2),IRECNR) 5761C 5762 999 CONTINUE 5763 CALL QEXIT('CCRDAO') 5764 RETURN 5765 END 5766C /* Deck ccrda1 */ 5767 SUBROUTINE CCRDA1(XINT,IBUF4,RBUF,IDELTA,IDEL2,KADR1,KADR2, 5768 * IRECNR) 5769C 5770C Written by Henrik Koch 25-Sep-1993 5771C 5772#include "implicit.h" 5773#include "priunit.h" 5774#include "dummy.h" 5775#include "ibtpar.h" 5776#include "ccorb.h" 5777#include "mxcent.h" 5778#include "eribuf.h" 5779 DIMENSION XINT(*) 5780 DIMENSION KADR1(NBAST),KADR2(NBAST,NBAST) 5781 DIMENSION RBUF(LBUF) 5782 INTEGER*4 IBUF4(LBUF*NIBUF), LENGTH4 5783 INTEGER INDX4(4,LBUF) 5784 DIMENSION IRECNR(*) 5785 CHARACTER*8 FAODER 5786 LOGICAL OLDDX 5787 LOGICAL LOCDBG 5788 PARAMETER (LOCDBG = .FALSE.) 5789#include "ccinftap.h" 5790#include "nuclei.h" 5791#include "inftap.h" 5792#include "eritap.h" 5793#include "chrnos.h" 5794#include "r12int.h" 5795C 5796 5797C 5798C INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 5799C 5800 IF (NEWDIS) THEN 5801C 5802 NEWDIS = .FALSE. 5803C 5804 IF (LUINTR .LE. 0) THEN 5805 CALL GPOPEN(LUINTR,'AOTWODIS','UNKNOWN',' ', 5806 & 'UNFORMATTED',IDUMMY,.FALSE.) 5807 END IF 5808 REWIND (LUINTR) 5809 DO 50 I = 1,NBUFX(0) 5810 READ(LUINTR) IRECNR(I) 5811 50 CONTINUE 5812C 5813 ENDIF 5814 5815 IF (LUAORC(0) .LE. 0) THEN 5816 LBFINP = LBUF 5817C 5818#if defined (SYS_NEC) 5819 LRECL = LBFINP + NIBUF*LBFINP/2 + 1 ! in integer*8 units 5820#else 5821 LRECL = 2*LBFINP + NIBUF*LBFINP + 1 ! in integer*4 units 5822#endif 5823 FAODER = 'AO2DIS'//CHRNOS(0)//CHRNOS(0) 5824 CALL GPOPEN(LUAORC(0),FAODER,'UNKNOWN','DIRECT', 5825 & 'UNFORMATTED',LRECL,OLDDX) 5826 IF (U21INT) 5827 & CALL GPOPEN(LU21INT,'AOTDIS00','UNKNOWN','DIRECT', 5828 & 'UNFORMATTED',LRECL,OLDDX) 5829 END IF 5830C 5831 ICOUNT = 0 5832 IDUM = 1 5833C 5834 DO 100 J = 1,NBUFX(0) 5835C 5836 IRECJ = IRECNR(J) 5837 IF (NOAUXB.AND..NOT.LOOPDP) THEN 5838 IDUM = 1 5839 CALL IJKAUX(IRECJ,IDUM,IDUM,IDUM) 5840 END IF 5841 IF (IRECJ .EQ. IDELTA) THEN 5842 ICOUNT = ICOUNT + 1 5843 NREC = J 5844 READ(LUAORC(0),ERR=2000,REC=NREC) RBUF,IBUF4,LENGTH4 5845 LENGTH = LENGTH4 5846 CALL AOLAB4_cc(IBUF4,NIBUF,NBITS,INDX4,LENGTH) 5847 DO 110 I = 1,LENGTH 5848 IP = INDX4(4,I) 5849 IQ = INDX4(3,I) 5850 IR = INDX4(2,I) 5851 IF (NOAUXB) THEN 5852 IDUM = 1 5853 CALL IJKAUX(IP,IQ,IR,IDUM) 5854 END IF 5855 IADR = KADR1(IR) + KADR2(IP,IQ) + 1 5856 XINT(IADR) = RBUF(I) 5857 5858 110 CONTINUE 5859 IF (U21INT) THEN 5860 READ(LU21INT,ERR=2000,REC=NREC) RBUF,IBUF4,LENGTH4 5861 LENGTH = LENGTH4 5862 CALL AOLAB4_cc(IBUF4,NIBUF,NBITS,INDX4,LENGTH) 5863 DO 115 I = 1,LENGTH 5864 IP = INDX4(4,I) 5865 IQ = INDX4(3,I) 5866 IR = INDX4(2,I) 5867 IF (NOAUXB) THEN 5868 IDUM = 1 5869 CALL IJKAUX(IP,IQ,IR,IDUM) 5870 END IF 5871 IADR = KADR1(IR) + KADR2(IP,IQ) + 1 5872 XINT(IADR + IOFFU21) = RBUF(I) 5873 115 CONTINUE 5874 ENDIF 5875 ENDIF 5876C 5877 100 CONTINUE 5878C 5879C 5880 CALL GPCLOSE(LUAORC(0),'KEEP') 5881 IF (U21INT) CALL GPCLOSE(LU21INT,'KEEP') 5882C 5883 RETURN 5884 2000 CALL QUIT('Error in CCRDA1 reading Integral distribution') 5885 END 5886C /* Deck lammat */ 5887 SUBROUTINE LAMMAT(XLAMDP,XLAMDH,T1AM,WORK,LWORK) 5888C 5889C Written by Henrik Koch 19-oct-1990. 5890C 5891C PURPOSE: 5892C Calculate transformation matrices used in ccsd 5893C calculations. 5894C 5895#include "implicit.h" 5896#include "priunit.h" 5897#include "dummy.h" 5898 DIMENSION XLAMDH(*),XLAMDP(*),WORK(LWORK),T1AM(*) 5899#include "inftap.h" 5900#include "ccorb.h" 5901#include "ccsdinp.h" 5902#include "ccsdsym.h" 5903#include "r12int.h" 5904 LOGICAL LOCDBG 5905 PARAMETER (LOCDBG = .FALSE.) 5906 CALL QENTER('LAMMAT') 5907C 5908C--------------------------- 5909C Work space allocation. 5910C--------------------------- 5911C 5912 KCMO = 1 5913 KEND = KCMO + NLAMDS 5914 LWRK1 = LWORK - KEND 5915C 5916 IF (LWRK1 .LT. 0) THEN 5917 CALL QUIT('Insufficient spaces in LAMMAT') 5918 ENDIF 5919C 5920C---------------------------------------------- 5921C Read MO-coefficients from interface file. 5922C---------------------------------------------- 5923C 5924 CALL GPOPEN(LUSIFC,'SIRIFC','OLD',' ','UNFORMATTED',IDUMMY, 5925 & .FALSE.) 5926 REWIND LUSIFC 5927C 5928C LABEL is used instead of 'TRCCINT' (WK/UniKA/04-11-2002). 5929 CALL MOLLAB(LABEL,LUSIFC,LUPRI) 5930 READ (LUSIFC) 5931C 5932 READ (LUSIFC) 5933 READ (LUSIFC) (WORK(KCMO+I-1), I=1,NLAMDS) 5934CHF 5935c WRITE(LUPRI,*)'CMO out in lammat' 5936c CALL OUTPUT(WORK(KCMO),1,NLAMDS,1,NLAMDS,NLAMDS,NLAMDS,1,LUPRI) 5937CHF 5938C 5939 CALL GPCLOSE(LUSIFC,'KEEP') 5940C 5941C--------------------------------------- 5942C Reorder the MO-coefficient matrix. 5943C--------------------------------------- 5944C 5945 CALL CMO_REORDER(WORK(KCMO),WORK(KEND),LWRK1) 5946C 5947C------------------------------------------- 5948C Calculate the transformation matrices. 5949C------------------------------------------- 5950C 5951 CALL DCOPY(NLAMDT,WORK(KCMO),1,XLAMDH,1) 5952 CALL DCOPY(NLAMDT,WORK(KCMO),1,XLAMDP,1) 5953C 5954 CALL LAMDA1(XLAMDP,XLAMDH,T1AM,WORK(KCMO)) 5955C 5956 IF (IPRINT .GT. 200 .OR. LOCDBG) THEN 5957C 5958 CALL AROUND('Lambda Particle matrix in LAMMAT') 5959 KOFF1 = 1 5960 KOFF2 = NLMRHF + 1 5961 DO 200 ISYM = 1,NSYM 5962 WRITE(LUPRI,1) ISYM 5963 WRITE(LUPRI,2) 5964 WRITE(LUPRI,3) 5965 IF (NRHF(ISYM) .EQ. 0) THEN 5966 WRITE(LUPRI,4) 5967 GOTO 210 5968 ENDIF 5969 CALL OUTPUT(XLAMDP(KOFF1),1,NBAS(ISYM),1,NRHF(ISYM), 5970 * NBAS(ISYM),NRHF(ISYM),1,LUPRI) 5971 210 WRITE(LUPRI,5) 5972 WRITE(LUPRI,6) 5973 IF (NVIR(ISYM) .EQ. 0) THEN 5974 WRITE(LUPRI,4) 5975 GOTO 220 5976 ENDIF 5977 CALL OUTPUT(XLAMDP(KOFF2),1,NBAS(ISYM),1,NVIR(ISYM), 5978 * NBAS(ISYM),NVIR(ISYM),1,LUPRI) 5979C 5980 220 CONTINUE 5981 KOFF1 = KOFF1 + NBAS(ISYM)*NRHF(ISYM) 5982 KOFF2 = KOFF2 + NBAS(ISYM)*NVIR(ISYM) 5983 200 CONTINUE 5984C 5985 CALL AROUND('Lambda Hole matrix in LAMMAT') 5986 KOFF1 = 1 5987 KOFF2 = NLMRHF + 1 5988 DO 300 ISYM = 1,NSYM 5989 WRITE(LUPRI,1) ISYM 5990 WRITE(LUPRI,7) 5991 WRITE(LUPRI,8) 5992 IF (NRHF(ISYM) .EQ. 0) THEN 5993 WRITE(LUPRI,4) 5994 GOTO 310 5995 ENDIF 5996 CALL OUTPUT(XLAMDH(KOFF1),1,NBAS(ISYM),1,NRHF(ISYM), 5997 * NBAS(ISYM),NRHF(ISYM),1,LUPRI) 5998 310 WRITE(LUPRI,9) 5999 WRITE(LUPRI,10) 6000 IF (NVIR(ISYM) .EQ. 0) THEN 6001 WRITE(LUPRI,4) 6002 GOTO 320 6003 ENDIF 6004 CALL OUTPUT(XLAMDH(KOFF2),1,NBAS(ISYM),1,NVIR(ISYM), 6005 * NBAS(ISYM),NVIR(ISYM),1,LUPRI) 6006C 6007 320 CONTINUE 6008 KOFF1 = KOFF1 + NBAS(ISYM)*NRHF(ISYM) 6009 KOFF2 = KOFF2 + NBAS(ISYM)*NVIR(ISYM) 6010 300 CONTINUE 6011C 6012 END IF 6013C 6014 CALL QEXIT('LAMMAT') 6015 RETURN 6016C 6017 1 FORMAT(/,/,7X,'Symmetry number :',I5) 6018 2 FORMAT(/,/,7X,'Lambda particle occupied part') 6019 3 FORMAT(7X,'-----------------------------') 6020 4 FORMAT(/,/,7X,'This symmetry is empty') 6021 5 FORMAT(/,/,7X,'Lambda particle virtual part') 6022 6 FORMAT(7X,'----------------------------') 6023 7 FORMAT(/,/,7X,'Lambda hole occupied part') 6024 8 FORMAT(7X,'-------------------------') 6025 9 FORMAT(/,/,7X,'Lambda hole virtual part') 6026 10 FORMAT(7X,'------------------------') 6027C 6028 END 6029C /* Deck lamda1 */ 6030 SUBROUTINE LAMDA1(XLAMDP,XLAMDH,T1AM,CMO) 6031C 6032C Calculate the lambda matrices. asm 05-08-94 6033C 6034C 6035#include "implicit.h" 6036 PARAMETER (ONE = 1.0D0) 6037 DIMENSION XLAMDH(*),XLAMDP(*) 6038 DIMENSION T1AM(*),CMO(*) 6039#include "priunit.h" 6040#include "ccorb.h" 6041#include "ccsdsym.h" 6042C 6043 DO 100 ISYMP = 1,NSYM 6044C 6045 ISYMI = ISYMP 6046 ISYMB = ISYMI 6047 ISYMA = ISYMP 6048 ISYMJ = ISYMA 6049C 6050 NBASP = MAX(NBAS(ISYMP),1) 6051 NVIRB = MAX(NVIR(ISYMB),1) 6052 NVIRA = MAX(NVIR(ISYMA),1) 6053C 6054 KOFF1 = ILMVIR(ISYMB) + 1 6055 KOFF2 = IT1AM(ISYMB,ISYMI) + 1 6056 KOFF3 = ILMRHF(ISYMI) + 1 6057C 6058 CALL DGEMM('N','N',NBAS(ISYMP),NRHF(ISYMI),NVIR(ISYMB), 6059 * ONE,CMO(KOFF1),NBASP,T1AM(KOFF2),NVIRB, 6060 * ONE,XLAMDH(KOFF3),NBASP) 6061C 6062 KOFF4 = ILMRHF(ISYMJ) + 1 6063 KOFF5 = IT1AM(ISYMA,ISYMJ) + 1 6064 KOFF6 = ILMVIR(ISYMJ) + 1 6065C 6066 CALL DGEMM('N','T',NBAS(ISYMP),NVIR(ISYMA),NRHF(ISYMJ), 6067 * -ONE,CMO(KOFF4),NBASP,T1AM(KOFF5),NVIRA, 6068 * ONE,XLAMDP(KOFF6),NBASP) 6069C 6070 100 CONTINUE 6071C 6072 RETURN 6073 END 6074C /* Deck sqmatr */ 6075 SUBROUTINE SQMATR(NDIM,PKMAT,SQMAT) 6076C 6077C Written by Henrik Koch 19-oct-1990. 6078C 6079C PURPOSE: 6080C Square up packed matrix. 6081C 6082 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 6083 DIMENSION PKMAT(*),SQMAT(NDIM,NDIM) 6084C 6085 DO 100 I = 1,NDIM 6086 DO 110 J = 1,I 6087C 6088 IJ = I*(I-1)/2 + J 6089 SQMAT(I,J) = PKMAT(IJ) 6090 SQMAT(J,I) = PKMAT(IJ) 6091C 6092 110 CONTINUE 6093 100 CONTINUE 6094C 6095 RETURN 6096 END 6097C /* Deck cc_t2ao */ 6098 SUBROUTINE CC_T2AO(T2AM,XLAMDH,ISYMLH,SCRM,WORK,LWORK, 6099 * IDEL,ISYMD,ISYMTR,IOPT) 6100C 6101C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 6102C Written by Henrik Koch 22-dec-1993. 6103C Symmetry due to Alfredo Sanchez and Henrik Koch 11-July 1994 6104C Nontotal symmetric amplitudes Ove Christiansen 14-2-1995. 6105C LAMDH is still assumed tot. sym. 6106C Asger Halkier 13/2-1996: Generalised to handle "non-direct" 6107C AO-index gamma in lampda matrix (IOPT = 2), as well as the 6108C usual "direct" delta AO-index (IOPT = 1). 6109C Ove Christiansen 16-6-1996: 6110C Generalised to non-total symmetric Lamdba matrices. 6111C PURPOSE: 6112C Tdjci -> Tci,j (delta) 6113C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 6114C 6115#include "implicit.h" 6116#include "priunit.h" 6117#include "iratdef.h" 6118 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0) 6119 DIMENSION T2AM(*),XLAMDH(*) 6120 DIMENSION SCRM(*),WORK(LWORK) 6121#include "ccorb.h" 6122#include "ccsdsym.h" 6123C 6124C----------------------------------------------------- 6125C Calculate the transformed t2-amplitude and save. 6126C----------------------------------------------------- 6127C 6128 ISYDVI = MULD2H(ISYMLH,ISYMD) 6129 ISYMM = MULD2H(ISYMTR,ISYDVI) 6130 CALL DZERO(SCRM,NT2BCD(ISYMM)) 6131C 6132 IF ( LWORK .LT. NVIR(ISYDVI)) THEN 6133 CALL QUIT('Insufficient core in CC_T2AO') 6134 ENDIF 6135C 6136 CALL DZERO(WORK,NVIR(ISYDVI)) 6137C 6138 IF (IOPT .EQ. 1) THEN 6139 KOFF1 = IGLMVI(ISYMD,ISYDVI) + IDEL - IBAS(ISYMD) 6140 ELSE IF (IOPT .EQ. 2) THEN 6141 KOFF1 = IGLMVI(ISYMD,ISYDVI) + IDEL 6142 ENDIF 6143 CALL DCOPY(NVIR(ISYDVI),XLAMDH(KOFF1),NBAS(ISYMD),WORK,1) 6144C 6145 DO 100 ISYMJ = 1,NSYM 6146C 6147 ISYMDJ = MULD2H(ISYMJ,ISYDVI) 6148 ISYMCI = MULD2H(ISYMTR,ISYMDJ) 6149C 6150 NTOTCI = MAX(NT1AM(ISYMCI),1) 6151C 6152 DO 110 J = 1,NRHF(ISYMJ) 6153C 6154 KDJ = IT1AM(ISYDVI,ISYMJ) + NVIR(ISYDVI)*(J-1) + 1 6155 KOFF2 = IT2SQ(ISYMCI,ISYMDJ) 6156 * + NT1AM(ISYMCI)*(KDJ - 1) + 1 6157 KOFF3 = IT2BCD(ISYMCI,ISYMJ) 6158 * + NT1AM(ISYMCI)*(J-1) + 1 6159C 6160 CALL DGEMV('N',NT1AM(ISYMCI),NVIR(ISYDVI),ONE, 6161 * T2AM(KOFF2),NTOTCI,WORK,1,ZERO, 6162 * SCRM(KOFF3),1) 6163C 6164 110 CONTINUE 6165 100 CONTINUE 6166C 6167 RETURN 6168 END 6169C /* Deck trsrec */ 6170 SUBROUTINE TRSREC(NDIM1,NDIM2,XMAT1,XMAT2) 6171C 6172C Written by Henrik Koch 19-oct-1990. 6173C 6174C PURPOSE: 6175C Transpose rectangular matrix. 6176C 6177 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 6178 DIMENSION XMAT1(NDIM1,NDIM2),XMAT2(NDIM2,NDIM1) 6179C 6180 DO 100 I = 1,NDIM1 6181 DO 110 J = 1,NDIM2 6182C 6183 XMAT2(J,I) = XMAT1(I,J) 6184C 6185 110 CONTINUE 6186 100 CONTINUE 6187C 6188 RETURN 6189 END 6190C /* Deck ccrhs_oneao */ 6191 SUBROUTINE CCRHS_ONEAO(FOCK,WORK,LWRK) 6192C 6193C Written by Henrik Koch & Ove Christiansen 24-jan-1994. 6194C Symmetry due to Alfredo Sanchez and Henrik Koch 11-July 1994 6195C 6196C PURPOSE: 6197C Read one electron integrals into matrix. 6198C 6199#include "implicit.h" 6200#include "priunit.h" 6201#include "dummy.h" 6202 DIMENSION FOCK(*),WORK(*) 6203#include "inftap.h" 6204#include "ccorb.h" 6205#include "ccsdsym.h" 6206#include "ccsdinp.h" 6207C 6208 LOGICAL EX 6209C 6210 IF (LWRK .LT. NNBST(ISYMOP)) 6211 * CALL QUIT('Insufficient space in CCRHS_ONEAO') 6212C 6213 CALL RDONEL('ONEHAMIL',.TRUE.,WORK,NNBST(ISYMOP)) 6214 CALL CCSD_SYMSQ(WORK,ISYMOP,FOCK) 6215C 6216 IF (IPRINT .GT. 120) THEN 6217 CALL AROUND('One electron AO-integrals in fock matrix') 6218 KOFF1 = 1 6219 DO 110 ISYMB = 1,NSYM 6220 WRITE(LUPRI,*) 'Symmetry number : ',ISYMB 6221 NBASB = NBAS(ISYMB) 6222 CALL OUTPUT(FOCK(KOFF1),1,NBASB,1,NBASB,NBASB,NBASB,1,LUPRI) 6223 KOFF1 = KOFF1 + NBAS(ISYMB)*NBAS(ISYMB) 6224 110 CONTINUE 6225C 6226 ENDIF 6227 RETURN 6228 END 6229C /* Deck cc_t2sq */ 6230 SUBROUTINE CC_T2SQ(T2AM,T2SQ,ISYM) 6231C 6232C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 6233C Henrik Koch and Alfredo Sanchez. 11-July-1994 6234C Modified by Ove Christiansen 24-1-1995 to handle 6235C a general non total symmetric vector. 6236C Squareup the t2-amplitudes distribution. 6237C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 6238C 6239#include "implicit.h" 6240 DIMENSION T2AM(*),T2SQ(*) 6241#include "priunit.h" 6242#include "ccorb.h" 6243#include "ccsdsym.h" 6244C 6245 IF (ISYM.EQ.1) THEN 6246 KOFF1 = 1 6247 KOFF2 = 1 6248 DO 100 ISYMBJ = 1,NSYM 6249 CALL SQMATR(NT1AM(ISYMBJ),T2AM(KOFF1),T2SQ(KOFF2)) 6250 KOFF1 = KOFF1 + NT1AM(ISYMBJ)*(NT1AM(ISYMBJ)+1)/2 6251 KOFF2 = KOFF2 + NT1AM(ISYMBJ)*NT1AM(ISYMBJ) 6252 100 CONTINUE 6253C 6254 ELSE 6255C 6256 KOFF = 1 6257 DO 200 ISYMBJ = 1,NSYM 6258 ISYMAI = MULD2H(ISYM,ISYMBJ) 6259C 6260 IF (ISYMBJ.GT.ISYMAI) THEN 6261C 6262 NAMP = NT1AM(ISYMAI)*NT1AM(ISYMBJ) 6263 KOFF1 = IT2SQ(ISYMAI,ISYMBJ) + 1 6264 CALL DCOPY(NAMP,T2AM(KOFF),1,T2SQ(KOFF1),1) 6265 NAI = MAX(NT1AM(ISYMAI),1) 6266 NBJ = MAX(NT1AM(ISYMBJ),1) 6267 KOFF2 = IT2SQ(ISYMBJ,ISYMAI) + 1 6268 CALL TRM(T2AM(KOFF),NAI,NT1AM(ISYMAI),NT1AM(ISYMBJ), 6269 * T2SQ(KOFF2),NBJ) 6270 KOFF = KOFF + NAMP 6271C 6272 ENDIF 6273C 6274 200 CONTINUE 6275C 6276 ENDIF 6277C 6278 RETURN 6279 END 6280C /* Deck trm */ 6281 SUBROUTINE TRM(A,LDA,M,N,B,LDB) 6282C 6283C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 6284C 6285C Transpose matrix A dim m,n in array with logical dim. lda. 6286C and put result into B with logical dim. ldb. 6287C Use dcopy for vectorization. 6288C 6289C Ove Christiansen 14-2-1995 6290C 6291C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 6292C 6293#include "implicit.h" 6294C 6295 DIMENSION A(LDA,*),B(LDB,*) 6296C 6297 DO 100 I = 1, N 6298C 6299 CALL DCOPY(M,A(1,I),1,B(I,1),LDB) 6300C 6301 100 CONTINUE 6302C 6303 RETURN 6304 END 6305C /* Deck cc_aodens */ 6306 SUBROUTINE CC_AODENS(XLAMDP,XLAMDH,DENS,ISYMH,IC,WORK,LWORK) 6307C 6308C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 6309C 6310C Henrik Koch and Alfredo Sanchez. 11-July-1994 6311C 6312C Calculate the AO-density matrix used in constructing 6313C the AO Fock matrix. 6314C 6315C 6316C Ove Christiansen 13-7-1995 6317C generalise to non-totalsymmetric lambda matrices 6318C for C1 transformation. 6319C ISYMH is the symmetry of the transformed LAMBDAH 6320C 6321C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 6322C 6323#include "implicit.h" 6324#include "priunit.h" 6325#include "dummy.h" 6326 PARAMETER (ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0) 6327 DIMENSION XLAMDP(*), XLAMDH(*), DENS(*), WORK(LWORK) 6328#include "inftap.h" 6329#include "ccorb.h" 6330#include "ccsdinp.h" 6331#include "ccsdsym.h" 6332#include "r12int.h" 6333C 6334 KOFF1 = 1 6335 KOFF2 = 1 6336 KOFF3 = 1 6337C 6338 DO 100 ISYMB = 1,NSYM 6339C 6340 ISYMA = MULD2H(ISYMH,ISYMB) 6341 ISYMK = ISYMA 6342 NBASA = MAX(NBAS(ISYMA),1) 6343 NBASB = MAX(NBAS(ISYMB),1) 6344C 6345 KOFF1 = 1 + IGLMRH(ISYMA,ISYMK) 6346 KOFF2 = 1 + IGLMRH(ISYMB,ISYMK) 6347C 6348 CALL DGEMM('N','T',NBAS(ISYMA),NBAS(ISYMB),NRHF(ISYMK),ONE, 6349 * XLAMDP(KOFF1),NBASA,XLAMDH(KOFF2),NBASB,ZERO, 6350 * DENS(KOFF3),NBASA) 6351C 6352 KOFF3 = KOFF3 + NBAS(ISYMA)*NBAS(ISYMB) 6353C 6354 100 CONTINUE 6355C 6356C 6357C----------------------------- 6358C Include frozen orbitals. 6359C----------------------------- 6360C 6361 IF ((FROIMP .OR. FROEXP).AND.(IC .EQ. 1)) THEN 6362C 6363 IF (LWORK .LT. NLAMDS) THEN 6364 CALL QUIT('Insufficient space in CCSD_AODENS') 6365 ENDIF 6366C 6367C------------------------------------------------- 6368C Read MO-coefficients from interface file. 6369C------------------------------------------------- 6370C 6371 CALL GPOPEN(LUSIFC,'SIRIFC','OLD',' ','UNFORMATTED',IDUMMY, 6372 & .FALSE.) 6373 REWIND LUSIFC 6374C 6375C Use LABEL instead of 'TRCCINT ' (WK/UniKA/04-11-2002). 6376 CALL MOLLAB(LABEL,LUSIFC,LUPRI) 6377 READ (LUSIFC) 6378C 6379 READ (LUSIFC) 6380 READ (LUSIFC) (WORK(I), I=1,NLAMDS) 6381C 6382 CALL GPCLOSE(LUSIFC,'KEEP') 6383C 6384C------------------------------------------------------- 6385C Add contribution from frozen occupied orbitals. 6386C------------------------------------------------------- 6387C 6388 KOFF1 = 0 6389 KOFF2 = 0 6390 DO 200 ISYMK = 1,NSYM 6391C 6392 ISYMA = ISYMK 6393 ISYMB = ISYMK 6394C 6395 DO 210 II = 1,NRHFFR(ISYMK) 6396C 6397 K = KFRRHF(II,ISYMK) 6398C 6399 DO 220 B = 1,NBAS(ISYMB) 6400 DO 230 A = 1,NBAS(ISYMA) 6401C 6402 NAK = KOFF1 + NBAS(ISYMA)*(K - 1) + A 6403 NBK = KOFF1 + NBAS(ISYMB)*(K - 1) + B 6404 NAB = KOFF2 + NBAS(ISYMA)*(B - 1) + A 6405C 6406 DENS(NAB) = DENS(NAB) + WORK(NAK)*WORK(NBK) 6407C 6408 230 CONTINUE 6409 220 CONTINUE 6410C 6411 210 CONTINUE 6412C 6413 KOFF1 = KOFF1 + NBAS(ISYMK)*NORBS(ISYMK) 6414 KOFF2 = KOFF2 + NBAS(ISYMA)*NBAS(ISYMB) 6415C 6416 200 CONTINUE 6417C 6418 ENDIF 6419C 6420 END 6421C /* Deck cc_t2mo */ 6422 SUBROUTINE CC_T2MO(RHO1,CTR2,ISYMC2,OMEGA2,RHO2,GAMMA,XLAMDP, 6423 * XLAMPC,ISYMPC,WORK,LWORK,ISYMBF,ICON) 6424C 6425C Henrik Koch and Alfredo Sanchez. 15-July-1994 6426C 6427C Transform the Omega2 vector from the AO basis to the MO 6428C basis. 6429C 6430C Ove Christiansen 4-8-1995: 6431C 6432C Generalizations for CC response. 6433C 6434C 1.ISYMBF is the symmetry of the BF (ali,bej) vector. 6435C 2.Transform with a non total symmetric lambda matrix. 6436C (one with sym 1 and one with sym isympc) 6437C 6438C note that if newgam is true gamma is the gamma vector on return 6439C with the same symmetry as the input BF. (transformed with xlamdp) 6440C 6441C if newgam is false the gamma intermediate is not returned. 6442C 6443C ICON is 2 for response to calculat a-tild,ibj and ai,b-tilde,j 6444C 6445C NB these changes are only carried through completely and 6446C tested for omegor 6447C 6448C Asger Halkier 2/11-1995: 6449C 6450C For ICON equal to 3 the contraction of the (ali,bej) vector with 6451C the trialvector CTR2 (i.e the LT21BF-term) is calculated and 6452C stored in RHO1! 6453C 6454C Ove Christiansen 4-10-1996: 6455C 6456C For use in F-matrix generalize ICON .EQ. 3 section 6457C 6458C NOTE: Linear response options only valid and debugged for OMEGOR! 6459C 6460C Christian Neiss 09/11/2005: 6461C ICON .EQ. 4: transform only beta index to occupied using XLAMDP 6462C (--> only total-symmetric transf. allowed); result is 6463C added on GAMMA; RHO2 will not be used 6464C Dimension of GAMMA = NT2AOIJ(ISYMO2) 6465C 6466#include "implicit.h" 6467#include "priunit.h" 6468#include "maxorb.h" 6469 PARAMETER (ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, TWO = 2.0D0) 6470 DIMENSION RHO1(*), CTR2(*), OMEGA2(*), RHO2(*), GAMMA(*), 6471 * XLAMDP(*), WORK(*), XLAMPC(*) 6472#include "ccorb.h" 6473#include "ccsdsym.h" 6474#include "symsq.h" 6475#include "cclr.h" 6476C 6477 INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J 6478C 6479 ISYMO2 = MULD2H(ISYMBF,ISYMPC) 6480 ISYMO1 = MULD2H(ISYMO2,ISYMC2) 6481C 6482 IF ((ICON.EQ.1).OR.(ICON.EQ.2)) THEN 6483 CALL DZERO(RHO2,NT2AM(ISYMO2)) 6484 ENDIF 6485C 6486 DO 100 ISYMJ = 1,NSYM 6487 DO 110 ISYMI = 1,NSYM 6488C 6489 ISYMIJ = MULD2H(ISYMI,ISYMJ) 6490 ISALBE = MULD2H(ISYMIJ,ISYMBF) 6491 ISYMAB = MULD2H(ISYMIJ,ISYMO2) 6492C 6493 DO 120 ISYBE = 1,NSYM 6494C 6495 ISYAL = MULD2H(ISYBE,ISALBE) 6496 ISYALI = MULD2H(ISYAL,ISYMI) 6497 ISYBEJ = MULD2H(ISYBE,ISYMJ) 6498C 6499C----------------------------------------------- 6500C Dynamic allocation of work space. 6501C----------------------------------------------- 6502C 6503 ISYMA = MULD2H(ISYAL,ISYMPC) 6504 NVA = MAX(NVIR(ISYMA),NVIR(ISYAL)) 6505 NRA = MAX(NRHF(ISYMA),NRHF(ISYAL)) 6506 ISYMB = MULD2H(ISYBE,ISYMPC) 6507 NVB = MAX(NVIR(ISYMB),NVIR(ISYBE),NRHF(ISYBE)) 6508 NRB = MAX(NRHF(ISYMB),NRHF(ISYBE)) 6509C 6510 KSCR1 = 1 6511 IF (ICON.NE.4) THEN 6512 KSCR2 = KSCR1 + NBAS(ISYAL)*NBAS(ISYBE) 6513 KSCR3 = KSCR2 + NBAS(ISYAL)*NVB 6514 IF (NEWGAM) THEN 6515 KSCR4 = KSCR3 + NVA*NVB 6516 KSCR5 = KSCR4 + NBAS(ISYAL)*NRB 6517 KEND1 = KSCR5 + NRA*NRB 6518 ELSE 6519 KEND1 = KSCR3 + NVA*NVB 6520 END IF 6521 ELSE 6522 KSCR4 = KSCR1 + NBAS(ISYAL)*NBAS(ISYBE) 6523 KEND1 = KSCR4 + NBAS(ISYAL)*NRB 6524 END IF 6525 LWRK1 = LWORK - KEND1 6526C 6527 IF (LWRK1 .LT. 0) THEN 6528 CALL QUIT('Not enough space in CC_T2MO') 6529 END IF 6530C 6531 DO 130 J = 1,NRHF(ISYMJ) 6532 DO 140 I = 1,NRHF(ISYMI) 6533C 6534C------------------------------------------ 6535C Squareup the AB block. 6536C------------------------------------------ 6537C 6538 IF ((.NOT. OMEGSQ) .AND. (.NOT. OMEGOR)) THEN 6539C 6540 DO 150 B = 1,NBAS(ISYBE) 6541 NBJ = IT1AO(ISYBE,ISYMJ) 6542 * + NBAS(ISYBE)*(J-1) + B 6543 DO 155 A = 1,NBAS(ISYAL) 6544C 6545 NAI = IT1AO(ISYAL,ISYMI) 6546 * + NBAS(ISYAL)*(I-1) + A 6547 NAB = KSCR1 + NBAS(ISYAL)*(B - 1) + A - 1 6548C 6549 IF (ISYMO2 .EQ. 1) THEN 6550 NAIBJ = IT2AO(ISYALI,ISYBEJ) 6551 * + INDEX(NAI,NBJ) 6552 ELSEIF (ISYALI .LT. ISYBEJ) THEN 6553 NAIBJ = IT2AO(ISYALI,ISYBEJ) 6554 * + NT1AO(ISYALI)*(NBJ - 1) + NAI 6555 ELSEIF (ISYALI .GT. ISYBEJ) THEN 6556 NAIBJ = IT2AO(ISYALI,ISYBEJ) 6557 * + NT1AO(ISYBEJ)*(NAI - 1) + NBJ 6558 ENDIF 6559C 6560 WORK(NAB) = OMEGA2(NAIBJ) 6561C 6562 155 CONTINUE 6563 150 CONTINUE 6564C 6565 ENDIF 6566C 6567 IF (OMEGSQ) THEN 6568C 6569 DO 160 B = 1,NBAS(ISYBE) 6570 NBJ = IT1AO(ISYBE,ISYMJ) 6571 * + NBAS(ISYBE)*(J-1) + B 6572 DO 165 A = 1,NBAS(ISYAL) 6573C 6574 NAI = IT1AO(ISYAL,ISYMI) 6575 * + NBAS(ISYAL)*(I-1) + A 6576 NAB = KSCR1 + NBAS(ISYAL)*(B - 1) + A - 1 6577C 6578 NAIBJ = IT2AOS(ISYALI,ISYBEJ) 6579 * + NT1AO(ISYALI)*(NBJ - 1) + NAI 6580 NBJAI = IT2AOS(ISYBEJ,ISYALI) 6581 * + NT1AO(ISYBEJ)*(NAI - 1) + NBJ 6582C 6583 WORK(NAB) = OMEGA2(NAIBJ) + OMEGA2(NBJAI) 6584C 6585 165 CONTINUE 6586 160 CONTINUE 6587C 6588 ENDIF 6589C 6590 IF (OMEGOR) THEN 6591C 6592 IF (ISYMI .EQ. ISYMJ) THEN 6593 NIJ = IMIJP(ISYMI,ISYMJ) + INDEX(I,J) 6594 FAC1 = ONE 6595 IF (I .GT. J) FAC1 = -ONE 6596 ELSE IF (ISYMI .LT. ISYMJ) THEN 6597 NIJ = IMIJP(ISYMI,ISYMJ) 6598 * + NRHF(ISYMI)*(J - 1) + I 6599 FAC1 = ONE 6600 ELSE 6601 NIJ = IMIJP(ISYMI,ISYMJ) 6602 * + NRHF(ISYMJ)*(I - 1) + J 6603 FAC1 = -ONE 6604 ENDIF 6605C 6606 DO 166 B = 1,NBAS(ISYBE) 6607 DO 167 A = 1,NBAS(ISYAL) 6608C 6609 IF (ISYAL .EQ. ISYBE) THEN 6610 NABP = IAODPK(ISYAL,ISYBE) 6611 * + INDEX(A,B) 6612 FAC2 = ONE 6613 IF (A .GT. B) FAC2 = -ONE 6614 ELSE IF (ISYAL .LT. ISYBE) THEN 6615 NABP = IAODPK(ISYAL,ISYBE) 6616 * + NBAS(ISYAL)*(B - 1) + A 6617 FAC2 = ONE 6618 ELSE 6619 NABP = IAODPK(ISYAL,ISYBE) 6620 * + NBAS(ISYBE)*(A - 1) + B 6621 FAC2 = -ONE 6622 ENDIF 6623C 6624 NABIJP = IT2ORT(ISALBE,ISYMIJ) 6625 * + NNBST(ISALBE)*(NIJ - 1) + NABP 6626C 6627 NABIJM = NT2ORT(ISYMBF) 6628 * + IT2ORT(ISALBE,ISYMIJ) 6629 * + NNBST(ISALBE)*(NIJ - 1) + NABP 6630C 6631 NAB = KSCR1 + NBAS(ISYAL)*(B - 1) + A - 1 6632C 6633 FAC = FAC1*FAC2 6634C 6635 WORK(NAB) = 6636 * HALF*(OMEGA2(NABIJP) + FAC*OMEGA2(NABIJM)) 6637C 6638 167 CONTINUE 6639 166 CONTINUE 6640C 6641 ENDIF 6642C 6643C------------------------------------------------------------ 6644C Transform the AB block to virtual space. 6645C------------------------------------------------------------ 6646C 6647 IF ((ICON.EQ.1).OR.(ICON.EQ.2)) THEN 6648C 6649 ISYMA = MULD2H(ISYAL,ISYMPC) 6650 ISYMB = ISYBE 6651 ISYMAI = MULD2H(ISYMA,ISYMI) 6652 ISYMBJ = MULD2H(ISYMB,ISYMJ) 6653C 6654 NBASA = MAX(NBAS(ISYAL),1) 6655 NBASB = MAX(NBAS(ISYBE),1) 6656 NVIRA = MAX(NVIR(ISYMA),1) 6657C 6658 KOFF1 = ILMVIR(ISYBE) + 1 6659C 6660 CALL DGEMM('N','N',NBAS(ISYAL),NVIR(ISYMB), 6661 * NBAS(ISYBE),ONE,WORK(KSCR1),NBASA, 6662 * XLAMDP(KOFF1),NBASB,ZERO,WORK(KSCR2), 6663 * NBASA) 6664C 6665 KOFF2 = IGLMVI(ISYAL,ISYMA) + 1 6666C 6667 CALL DGEMM('T','N',NVIR(ISYMA),NVIR(ISYMB), 6668 * NBAS(ISYAL),ONE,XLAMPC(KOFF2),NBASA, 6669 * WORK(KSCR2),NBASA,ZERO,WORK(KSCR3), 6670 * NVIRA) 6671C 6672C-------------------------------------------- 6673C Store the omega2 vector. 6674C-------------------------------------------- 6675C 6676 DO 170 B = 1,NVIR(ISYMB) 6677 NBJ = IT1AM(ISYMB,ISYMJ) 6678 * + NVIR(ISYMB)*(J-1) + B 6679 DO 180 A = 1,NVIR(ISYMA) 6680C 6681 NAI = IT1AM(ISYMA,ISYMI) 6682 * + NVIR(ISYMA)*(I-1) + A 6683 NAB = KSCR3 + NVIR(ISYMA)*(B - 1) + A - 1 6684C 6685 IF (ISYMAI .EQ. ISYMBJ) THEN 6686C 6687 IF (NAI .GT. NBJ) GOTO 180 6688C 6689 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 6690 * + INDEX(NAI,NBJ) 6691 ELSEIF (ISYMAI .LT. ISYMBJ) THEN 6692 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 6693 * + NT1AM(ISYMAI)*(NBJ - 1) + NAI 6694 ELSEIF (ISYMAI .GT. ISYMBJ) THEN 6695 GOTO 180 6696chjaaj: next two lines are commented because it is dead code 6697c NAIBJ = IT2AM(ISYMAI,ISYMBJ) 6698c * + NT1AM(ISYMBJ)*(NAI - 1) + NBJ 6699 ENDIF 6700C 6701 RHO2(NAIBJ) = RHO2(NAIBJ) + WORK(NAB) 6702C 6703 180 CONTINUE 6704 170 CONTINUE 6705C 6706 ENDIF 6707C 6708C-------------------------------------- 6709C CCLR contribution. 6710C-------------------------------------- 6711C 6712 IF (ICON .EQ. 2 ) THEN 6713C 6714 CALL DZERO(WORK(KSCR2),NVA*NVB) 6715 ISYMA = ISYAL 6716 ISYMB = MULD2H(ISYBE,ISYMPC) 6717 ISYMAI = MULD2H(ISYMA,ISYMI) 6718 ISYMBJ = MULD2H(ISYMB,ISYMJ) 6719C 6720 NBASA = MAX(NBAS(ISYAL),1) 6721 NBASB = MAX(NBAS(ISYBE),1) 6722 NVIRA = MAX(NVIR(ISYMA),1) 6723C 6724 KOFF1 = IGLMVI(ISYBE,ISYMB) + 1 6725C 6726 CALL DGEMM('N','N',NBAS(ISYAL),NVIR(ISYMB), 6727 * NBAS(ISYBE),ONE,WORK(KSCR1),NBASA, 6728 * XLAMPC(KOFF1),NBASB,ZERO,WORK(KSCR2), 6729 * NBASA) 6730C 6731 KOFF2 = ILMVIR(ISYAL) + 1 6732C 6733 CALL DGEMM('T','N',NVIR(ISYMA),NVIR(ISYMB), 6734 * NBAS(ISYAL),ONE,XLAMDP(KOFF2),NBASA, 6735 * WORK(KSCR2),NBASA,ZERO,WORK(KSCR3), 6736 * NVIRA) 6737C 6738C-------------------------------------------- 6739C Store the omega2 vector. 6740C-------------------------------------------- 6741C 6742 DO 181 B = 1,NVIR(ISYMB) 6743 NBJ = IT1AM(ISYMB,ISYMJ) 6744 * + NVIR(ISYMB)*(J-1) + B 6745 DO 182 A = 1,NVIR(ISYMA) 6746C 6747 NAI = IT1AM(ISYMA,ISYMI) 6748 * + NVIR(ISYMA)*(I-1) + A 6749C 6750 IF (ISYMAI .EQ. ISYMBJ) THEN 6751 IF (NAI .GT. NBJ ) GOTO 182 6752 NAIBJ = IT2AM(ISYALI,ISYBEJ) 6753 * + INDEX(NAI,NBJ) 6754 ELSEIF (ISYMAI .LT. ISYMBJ) THEN 6755 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 6756 * + NT1AM(ISYMAI)*(NBJ - 1) + NAI 6757 ELSEIF (ISYMAI .GT. ISYMBJ) THEN 6758 GOTO 182 6759chjaaj: next two lines are commented because it is dead code 6760c NAIBJ = IT2AM(ISYMAI,ISYMBJ) 6761c * + NT1AM(ISYMBJ)*(NAI - 1) + NBJ 6762 ENDIF 6763C 6764 NAB = KSCR3+ NVIR(ISYMA)*(B - 1) + A - 1 6765 RHO2(NAIBJ) = RHO2(NAIBJ) + WORK(NAB) 6766C 6767 182 CONTINUE 6768 181 CONTINUE 6769C 6770 ENDIF 6771C 6772C============================================================ 6773C Section for calculating the LT21BF-term. 6774C============================================================ 6775C 6776 IF (ICON .EQ. 3) THEN 6777C 6778 ISYMK = ISYBE 6779 ISYMD = MULD2H(ISYAL,ISYMPC) 6780 ISYMC = MULD2H(ISYMK,ISYMO1) 6781 ISYDI = MULD2H(ISYMD,ISYMI) 6782 ISYCJ = MULD2H(ISYMC,ISYMJ) 6783C 6784 LENGTH = NBAS(ISYAL)*NRHF(ISYMK) 6785C 6786 CALL DZERO(WORK(KSCR2),LENGTH) 6787C 6788C---------------------------------------------------------- 6789C Transform the AO-block to MO-basis. 6790C---------------------------------------------------------- 6791C 6792 KOFF1 = ILMRHF(ISYMK) + 1 6793C 6794 NTOTAL = MAX(NBAS(ISYAL),1) 6795 NTOTBE = MAX(NBAS(ISYBE),1) 6796C 6797 CALL DGEMM('N','N',NBAS(ISYAL),NRHF(ISYMK), 6798 * NBAS(ISYBE),ONE,WORK(KSCR1),NTOTAL, 6799 * XLAMDP(KOFF1),NTOTBE,ZERO, 6800 * WORK(KSCR2),NTOTAL) 6801C 6802 KOFF2 = IGLMVI(ISYAL,ISYMD) + 1 6803C 6804 NTOTAL = MAX(NBAS(ISYAL),1) 6805 NTOTK = MAX(NRHF(ISYMK),1) 6806C 6807 CALL DGEMM('T','N',NRHF(ISYMK),NVIR(ISYMD), 6808 * NBAS(ISYAL),ONE,WORK(KSCR2),NTOTAL, 6809 * XLAMPC(KOFF2),NTOTAL,ZERO, 6810 * WORK(KSCR3),NTOTK) 6811C 6812C----------------------------------------------------------------- 6813C Contraction with CTR2 & storage in result. 6814C----------------------------------------------------------------- 6815C 6816 DO 47 C = 1,NVIR(ISYMC) 6817C 6818 NCJ = IT1AM(ISYMC,ISYMJ) 6819 * + NVIR(ISYMC)*(J - 1) + C 6820 NDICJ = IT2SQ(ISYDI,ISYCJ) 6821 * + NT1AM(ISYDI)*(NCJ - 1) 6822 * + IT1AM(ISYMD,ISYMI) 6823 * + NVIR(ISYMD)*(I - 1) + 1 6824 NCK = IT1AM(ISYMC,ISYMK) + C 6825C 6826 CALL DGEMV('N',NRHF(ISYMK),NVIR(ISYMD), 6827 * -ONE,WORK(KSCR3),NTOTK, 6828 * CTR2(NDICJ),1,ONE,RHO1(NCK), 6829 * NVIR(ISYMC)) 6830C 6831 47 CONTINUE 6832C 6833 ENDIF 6834C 6835C------------------------------------------------------------- 6836C Transform the AB block to occupied space. 6837C------------------------------------------------------------- 6838C 6839 IF (.NOT.(NEWGAM.OR.(ICON.EQ.4))) GOTO 999 6840C 6841 NBASA = MAX(NBAS(ISYAL),1) 6842 NBASB = MAX(NBAS(ISYBE),1) 6843 NRHFA1 = MAX(NRHF(ISYAL),1) 6844C 6845 KOFF1 = ILMRHF(ISYBE) + 1 6846C 6847 CALL DGEMM('N','N',NBAS(ISYAL),NRHF(ISYBE), 6848 * NBAS(ISYBE),ONE,WORK(KSCR1),NBASA, 6849 * XLAMDP(KOFF1),NBASB,ZERO,WORK(KSCR4), 6850 * NBASA) 6851C 6852 IF (ICON.NE.4) THEN 6853C 6854 KOFF2 = ILMRHF(ISYAL) + 1 6855C 6856 CALL DGEMM('T','N',NRHF(ISYAL),NRHF(ISYBE), 6857 * NBAS(ISYAL),ONE,XLAMDP(KOFF2),NBASA, 6858 * WORK(KSCR4),NBASA,ZERO,WORK(KSCR5), 6859 * NRHFA1) 6860C 6861C------------------------------------------- 6862C Store the gamma matrix. 6863C------------------------------------------- 6864C 6865 ISYMK = ISYAL 6866 ISYML = ISYBE 6867C 6868 ISYMKI = MULD2H(ISYMK,ISYMI) 6869 ISYMLJ = MULD2H(ISYML,ISYMJ) 6870C 6871 DO 190 L = 1,NRHF(ISYML) 6872C 6873 NLJ = IMATIJ(ISYML,ISYMJ) 6874 * + NRHF(ISYML)*(J - 1) + L 6875C 6876 DO 200 K = 1,NRHF(ISYMK) 6877C 6878 NKL = KSCR5 + NRHF(ISYMK)*(L - 1) + K - 1 6879C 6880 NKI = IMATIJ(ISYMK,ISYMI) 6881 * + NRHF(ISYMK)*(I - 1) + K 6882C 6883 IF (ISYMKI .EQ. ISYMLJ) THEN 6884 NKILJ = IGAMMA(ISYMKI,ISYMLJ) 6885 * + INDEX(NKI,NLJ) 6886 GAMMA(NKILJ) = WORK(NKL) 6887 ELSE IF (ISYMKI .LT. ISYMLJ) THEN 6888 NKILJ = IGAMMA(ISYMKI,ISYMLJ) 6889 * + NMATIJ(ISYMKI)*(NLJ - 1) + NKI 6890 GAMMA(NKILJ) = WORK(NKL) 6891 ENDIF 6892C 6893 200 CONTINUE 6894 190 CONTINUE 6895C 6896 ELSE 6897C 6898C------------------------------------------------------------------ 6899C Store "half-transformed" GAMMA for ICON .EQ. 4 6900C------------------------------------------------------------------ 6901C 6902 ISYML = ISYBE 6903 ISYLAL = MULD2H(ISYAL,ISYML) 6904C 6905 NIJ = IMATIJ(ISYMI,ISYMJ) + 6906 * NRHF(ISYMI)*(J-1) + I 6907C 6908 NALIJ = IT2AOIJ(ISYLAL,ISYMIJ) + 6909 * NT1AO(ISYLAL)*(NIJ-1) + 6910 * IT1AO(ISYAL,ISYML) + 1 6911C 6912 CALL DAXPY(NBAS(ISYAL)*NRHF(ISYML),ONE, 6913 * WORK(KSCR4),1,GAMMA(NALIJ),1) 6914C 6915 END IF 6916C 6917 999 CONTINUE 6918 140 CONTINUE 6919 130 CONTINUE 6920 120 CONTINUE 6921 110 CONTINUE 6922 100 CONTINUE 6923C 6924 RETURN 6925 END 6926C /* Deck ccsd_t2mtp */ 6927 SUBROUTINE CCSD_T2MTP(SCRM,WORK,LWORK,ISYMD) 6928C 6929C Alfredo Sanchez and Henrik Koch 26-July 1994 6930C 6931C PURPOSE: 6932C Transpose ij index of the T2M-amplitudes. 6933C 6934#include "implicit.h" 6935 DIMENSION SCRM(*) 6936 DIMENSION WORK(LWORK) 6937#include "priunit.h" 6938#include "ccorb.h" 6939#include "ccsdsym.h" 6940C 6941C------------------------------------------- 6942C Calculate the transposed t2-amplitude. 6943C------------------------------------------- 6944C 6945 DO 100 ISYMJ = 1,NSYM 6946C 6947 ISYMCI = MULD2H(ISYMJ,ISYMD) 6948C 6949 DO 110 J = 1,NRHF(ISYMJ) 6950C 6951 DO 120 ISYMI = 1,ISYMJ 6952C 6953 ISYMC = MULD2H(ISYMI,ISYMCI) 6954 ISYMCJ = MULD2H(ISYMC,ISYMJ) 6955C 6956 IF (LWORK .LT. NVIR(ISYMC)) THEN 6957 CALL QUIT('Insufficient space in CCSD_T2MTP') 6958 ENDIF 6959C 6960 IF (ISYMI .EQ. ISYMJ) THEN 6961 NRHFI = J - 1 6962 ELSE 6963 NRHFI = NRHF(ISYMI) 6964 END IF 6965C 6966 DO 130 I = 1,NRHFI 6967C 6968 NCIJ = IT2BCD(ISYMCI,ISYMJ) + NT1AM(ISYMCI)*(J-1) 6969 * + IT1AM(ISYMC,ISYMI) + NVIR(ISYMC)*(I-1) + 1 6970 NCJI = IT2BCD(ISYMCJ,ISYMI) + NT1AM(ISYMCJ)*(I-1) 6971 * + IT1AM(ISYMC,ISYMJ) + NVIR(ISYMC)*(J-1) + 1 6972C 6973 CALL DCOPY(NVIR(ISYMC),SCRM(NCIJ),1,WORK,1) 6974 CALL DCOPY(NVIR(ISYMC),SCRM(NCJI),1,SCRM(NCIJ),1) 6975 CALL DCOPY(NVIR(ISYMC),WORK,1,SCRM(NCJI),1) 6976C 6977 130 CONTINUE 6978C 6979 120 CONTINUE 6980C 6981 110 CONTINUE 6982C 6983 100 CONTINUE 6984C 6985 RETURN 6986 END 6987C /* Deck ccsd_t2tp */ 6988 SUBROUTINE CCSD_T2TP(T2AM,WORK,LWORK,ISYM) 6989C 6990C Alfredo Sanchez and Henrik Koch 26-July 1994 6991C 6992C PURPOSE: 6993C Transpose ij index of the T2-amplitudes. 6994C The amplitudes are assumed to be a square matrix. 6995C 6996#include "implicit.h" 6997 DIMENSION T2AM(*) 6998 DIMENSION WORK(LWORK) 6999#include "priunit.h" 7000#include "ccorb.h" 7001#include "ccsdsym.h" 7002C 7003C------------------------------------------- 7004C Calculate the transposed t2-amplitude. 7005C------------------------------------------- 7006C 7007 DO 100 ISYMJ = 1,NSYM 7008C 7009 DO 110 J = 1,NRHF(ISYMJ) 7010C 7011 DO 120 ISYMB = 1,NSYM 7012C 7013 ISYMBJ = MULD2H(ISYMB,ISYMJ) 7014 ISYMAI = MULD2H(ISYMBJ,ISYM) 7015C 7016 DO 130 B = 1,NVIR(ISYMB) 7017C 7018 NBJ = IT1AM(ISYMB,ISYMJ)+NVIR(ISYMB)*(J-1)+B 7019C 7020 DO 140 ISYMI = 1,ISYMJ 7021C 7022 ISYMA = MULD2H(ISYMI,ISYMAI) 7023 ISYMAJ = MULD2H(ISYMA,ISYMJ) 7024 ISYMBI = MULD2H(ISYMB,ISYMI) 7025C 7026 IF (LWORK .LT. NVIR(ISYMA)) THEN 7027 CALL QUIT('Insufficient space in CCSD_T2TP') 7028 ENDIF 7029C 7030 IF (ISYMI .EQ. ISYMJ) THEN 7031 NRHFI = J - 1 7032 ELSE 7033 NRHFI = NRHF(ISYMI) 7034 END IF 7035C 7036 DO 150 I = 1,NRHFI 7037C 7038 NBI = IT1AM(ISYMB,ISYMI)+NVIR(ISYMB)*(I-1)+B 7039C 7040 NAIBJ = IT2SQ(ISYMAI,ISYMBJ) 7041 * + NT1AM(ISYMAI)*(NBJ-1) 7042 * + IT1AM(ISYMA,ISYMI)+NVIR(ISYMA)*(I-1)+1 7043C 7044 NAJBI = IT2SQ(ISYMAJ,ISYMBI) 7045 * + NT1AM(ISYMAJ)*(NBI-1) 7046 * + IT1AM(ISYMA,ISYMJ)+NVIR(ISYMA)*(J-1)+1 7047C 7048 CALL DCOPY(NVIR(ISYMA),T2AM(NAIBJ),1,WORK,1) 7049 CALL DCOPY(NVIR(ISYMA),T2AM(NAJBI),1, 7050 * T2AM(NAIBJ),1) 7051 CALL DCOPY(NVIR(ISYMA),WORK,1,T2AM(NAJBI),1) 7052C 7053 150 CONTINUE 7054C 7055 140 CONTINUE 7056C 7057 130 CONTINUE 7058C 7059 120 CONTINUE 7060C 7061 110 CONTINUE 7062C 7063 100 CONTINUE 7064C 7065 RETURN 7066 END 7067C /* Deck ccsd_invldp */ 7068 SUBROUTINE CCSD_INVLDP(XLAMDP,XLAMIP,WORK,LWORK) 7069C 7070C Alfredo Sanchez and Henrik Koch 26-July 1994 7071C 7072C PURPOSE: 7073C Invert the lambda particle matrix. 7074C 7075#include "implicit.h" 7076#include "priunit.h" 7077 PARAMETER (ZERO = 0.0D0, ONE = 1.0D0) 7078#include "iratdef.h" 7079 DIMENSION XLAMDP(*), XLAMIP(*) 7080 DIMENSION WORK(LWORK) 7081 DIMENSION DET(2) 7082#include "ccorb.h" 7083#include "ccsdsym.h" 7084#include "ccsdinp.h" 7085C 7086 DO 100 ISYMA = 1,NSYM 7087C 7088 KSCR = 1 7089 KEND1 = KSCR + NBAS(ISYMA)*NORB(ISYMA) 7090 LWRK1 = LWORK - KEND1 7091C 7092 IF (LWRK1 .LT. 0) THEN 7093 CALL QUIT('Insufficient space for '// 7094 & 'allocation in CCSD_INVLDP') 7095 END IF 7096C 7097 NTOTR = NBAS(ISYMA)*NRHF(ISYMA) 7098C 7099 KOFF1 = ILMRHF(ISYMA) + 1 7100C 7101 CALL DCOPY(NTOTR,XLAMDP(KOFF1),1,WORK(KSCR),1) 7102C 7103 NTOTV = NBAS(ISYMA)*NVIR(ISYMA) 7104 KOFF2 = ILMVIR(ISYMA) + 1 7105 KOFF3 = KSCR + NTOTR 7106C 7107 CALL DCOPY(NTOTV,XLAMDP(KOFF2),1,WORK(KOFF3),1) 7108C 7109C 7110 NBASA = MAX(NBAS(ISYMA),1) 7111C 7112#if defined (SYS_xxx) 7113 NAUX = INT(32.5D0*DFLOAT(NBAS(ISYMA))) + 1 7114 IF (LWRK1. LT. NAUX) THEN 7115 CALL QUIT('Not enough space for DGEICD in CCSD_INVLDP') 7116 END IF 7117 7118 CALL DGEICD(WORK(KSCR),NBASA,NBAS(ISYMA),0,RCOND,DET, 7119 * WORK(KEND1),LWRK1) 7120#else 7121 NBASA2 = MAX(NBAS(ISYMA),1) 7122 NBASA1 = NBAS(ISYMA) 7123C 7124 KIPVT = KEND1 7125 KEND2 = KIPVT + NBAS(ISYMA)/IRAT + 1 7126 LWRK2 = LWORK - KEND2 7127 IF (LWRK2. LT. NBASA1) THEN 7128 CALL QUIT('Not enough space for DGEDI in CCSD_INVLDP') 7129 END IF 7130C 7131#if !defined (SYS_CRAY) 7132 IF (NBAS(ISYMA) .GT. 1) THEN 7133 CALL DGEFA(WORK(KSCR),NBAS(ISYMA),NBAS(ISYMA), 7134 * WORK(KIPVT),IERR) 7135 END IF 7136C 7137 CALL DGEDI(WORK(KSCR),NBASA2,NBASA1,WORK(KIPVT),DET, 7138 * WORK(KEND2),1) 7139#else 7140 IF (NBAS(ISYMA) .GT. 1) THEN 7141 CALL SGEFA(WORK(KSCR),NBAS(ISYMA),NBAS(ISYMA), 7142 * WORK(KIPVT),IERR) 7143 END IF 7144C 7145 CALL SGEDI(WORK(KSCR),NBASA2,NBASA1,WORK(KIPVT),DET, 7146 * WORK(KEND2),1) 7147#endif 7148#endif 7149C 7150 DO 110 I = 1,NRHF(ISYMA) 7151C 7152 KOFF1 = KSCR + I - 1 7153 KOFF2 = ILMRHF(ISYMA) + NBAS(ISYMA)*(I-1) + 1 7154C 7155 CALL DCOPY(NBAS(ISYMA),WORK(KOFF1),NBAS(ISYMA), 7156 * XLAMIP(KOFF2),1) 7157C 7158 110 CONTINUE 7159C 7160 DO 120 A = 1,NVIR(ISYMA) 7161C 7162 KOFF1 = KSCR + NRHF(ISYMA) + A - 1 7163 KOFF2 = ILMVIR(ISYMA) + NBAS(ISYMA)*(A-1) + 1 7164C 7165 CALL DCOPY(NBAS(ISYMA),WORK(KOFF1),NBAS(ISYMA), 7166 * XLAMIP(KOFF2),1) 7167C 7168 120 CONTINUE 7169C 7170100 CONTINUE 7171C 7172C------------------ 7173C Test section. 7174C------------------ 7175C 7176 IF (IPRINT .GT. 120) THEN 7177C 7178 CALL AROUND('The inverse lambda matrix. Occupied part') 7179 DO 199 ISYMI = 1,NSYM 7180C 7181 WRITE(LUPRI,*) 'The symmetry of the block :',ISYMI 7182C 7183 KOFF1 = ILMRHF(ISYMI) + 1 7184C 7185 CALL OUTPUT(XLAMIP(KOFF1),1,NBAS(ISYMI),1,NRHF(ISYMI), 7186 * NBAS(ISYMI),NRHF(ISYMI),1,LUPRI) 7187C 7188 199 CONTINUE 7189C 7190 CALL AROUND('Test of the occupied part of inverse xlamdp') 7191 DO 200 ISYMI = 1,NSYM 7192C 7193 WRITE(LUPRI,*) 'The symmetry of the block :',ISYMI 7194C 7195 NBASI = MAX(NBAS(ISYMI),1) 7196 NRHFI = MAX(NRHF(ISYMI),1) 7197C 7198 KOFF1 = ILMRHF(ISYMI) + 1 7199C 7200 CALL DGEMM('T','N',NRHF(ISYMI),NRHF(ISYMI),NBAS(ISYMI),ONE, 7201 * XLAMDP(KOFF1),NBASI,XLAMIP(KOFF1),NBASI,ZERO, 7202 * WORK,NRHFI) 7203C 7204 CALL OUTPUT(WORK,1,NRHF(ISYMI),1,NRHF(ISYMI),NRHF(ISYMI), 7205 * NRHF(ISYMI),1,LUPRI) 7206C 7207 200 CONTINUE 7208C 7209 CALL AROUND('The inverse lambda matrix. Virtual part') 7210 DO 209 ISYMA = 1,NSYM 7211C 7212 WRITE(LUPRI,*) 'The symmetry of the block :',ISYMI 7213C 7214 KOFF1 = ILMVIR(ISYMA) + 1 7215C 7216 CALL OUTPUT(XLAMIP(KOFF1),1,NBAS(ISYMA),1,NVIR(ISYMA), 7217 * NBAS(ISYMA),NVIR(ISYMA),1,LUPRI) 7218C 7219 209 CONTINUE 7220C 7221 CALL AROUND('Test of the virtual part of inverse xlamdp') 7222 DO 210 ISYMA = 1,NSYM 7223C 7224 WRITE(LUPRI,*) 'The symmetry of the block :',ISYMA 7225C 7226 NBASA = MAX(NBAS(ISYMA),1) 7227 NVIRA = MAX(NVIR(ISYMA),1) 7228C 7229 KOFF1 = ILMVIR(ISYMA) + 1 7230C 7231 CALL DGEMM('T','N',NVIR(ISYMA),NVIR(ISYMA),NBAS(ISYMA),ONE, 7232 * XLAMDP(KOFF1),NBASA,XLAMIP(KOFF1),NBASA,ZERO, 7233 * WORK,NVIRA) 7234C 7235 CALL OUTPUT(WORK,1,NVIR(ISYMA),1,NVIR(ISYMA),NVIR(ISYMA), 7236 * NVIR(ISYMA),1,LUPRI) 7237C 7238 210 CONTINUE 7239C 7240 ENDIF 7241C 7242 RETURN 7243 END 7244C /* Deck ccrhs_t2tr */ 7245 SUBROUTINE CCRHS_T2TR(T2AM,WORK,LWORK,ISYM) 7246C 7247C Alfredo Sanchez and Henrik Koch 30-July 1994 7248C 7249C PURPOSE: 7250C Calculate two coulomb minus exchange of t2 amplitudes. 7251C The amplitudes are assumed to be a square matrix. 7252C 7253#include "implicit.h" 7254 PARAMETER (ONE = 1.0D0, TWO = 2.0D0) 7255 DIMENSION T2AM(*) 7256 DIMENSION WORK(LWORK) 7257#include "priunit.h" 7258#include "ccorb.h" 7259#include "ccsdsym.h" 7260#include "ccsdinp.h" 7261C 7262C---------------------------------------------------------- 7263C Calculate two coulomb minus exchange of t2-amplitude. 7264C---------------------------------------------------------- 7265C 7266 DO 100 ISYMJ = 1,NSYM 7267C 7268 DO 110 J = 1,NRHF(ISYMJ) 7269C 7270 DO 120 ISYMB = 1,NSYM 7271C 7272 ISYMBJ = MULD2H(ISYMB,ISYMJ) 7273 ISYMAI = MULD2H(ISYMBJ,ISYM) 7274C 7275 DO 130 B = 1,NVIR(ISYMB) 7276C 7277 NBJ = IT1AM(ISYMB,ISYMJ)+NVIR(ISYMB)*(J-1)+B 7278C 7279 DO 140 ISYMI = 1,ISYMJ 7280C 7281 ISYMA = MULD2H(ISYMI,ISYMAI) 7282 ISYMAJ = MULD2H(ISYMA,ISYMJ) 7283 ISYMBI = MULD2H(ISYMB,ISYMI) 7284C 7285 KSCR1 = 1 7286 KSCR2 = KSCR1 + NVIR(ISYMA) 7287 KEND1 = KSCR2 + NVIR(ISYMA) 7288 LWRK1 = LWORK - KEND1 7289 IF (LWRK1 .LT. 0) THEN 7290 CALL QUIT('Insufficient space in CCRHS_T2TR') 7291 ENDIF 7292C 7293 IF (ISYMI .EQ. ISYMJ) THEN 7294 NRHFI = J - 1 7295 ELSE 7296 NRHFI = NRHF(ISYMI) 7297 END IF 7298C 7299 DO 150 I = 1,NRHFI 7300C 7301 NBI = IT1AM(ISYMB,ISYMI)+NVIR(ISYMB)*(I-1)+B 7302C 7303 NAIBJ = IT2SQ(ISYMAI,ISYMBJ) 7304 * + NT1AM(ISYMAI)*(NBJ-1) 7305 * + IT1AM(ISYMA,ISYMI)+NVIR(ISYMA)*(I-1)+1 7306C 7307 NAJBI = IT2SQ(ISYMAJ,ISYMBI) 7308 * + NT1AM(ISYMAJ)*(NBI-1) 7309 * + IT1AM(ISYMA,ISYMJ)+NVIR(ISYMA)*(J-1)+1 7310C 7311 CALL DCOPY(NVIR(ISYMA),T2AM(NAIBJ),1, 7312 * WORK(KSCR1),1) 7313 CALL DCOPY(NVIR(ISYMA),T2AM(NAJBI),1, 7314 * WORK(KSCR2),1) 7315C 7316 CALL DSCAL(NVIR(ISYMA),TWO,T2AM(NAIBJ),1) 7317 CALL DSCAL(NVIR(ISYMA),TWO,T2AM(NAJBI),1) 7318C 7319 CALL DAXPY(NVIR(ISYMA),-ONE,WORK(KSCR2),1, 7320 * T2AM(NAIBJ),1) 7321 CALL DAXPY(NVIR(ISYMA),-ONE,WORK(KSCR1),1, 7322 * T2AM(NAJBI),1) 7323C 7324 150 CONTINUE 7325C 7326 140 CONTINUE 7327C 7328 130 CONTINUE 7329C 7330 120 CONTINUE 7331C 7332 110 CONTINUE 7333C 7334 100 CONTINUE 7335C 7336 IF (IPRINT .GT. 120) THEN 7337 CALL AROUND('Two coulomb minus exchamge of t2am') 7338 DO 200 ISYMBJ = 1,NSYM 7339 ISYMAI = MULD2H(ISYMBJ,ISYM) 7340 KOFF = IT2SQ(ISYMAI,ISYMBJ) + 1 7341 WRITE(LUPRI,*) 7342 WRITE(LUPRI,*) 'Symmetry block:',ISYMBJ 7343 CALL OUTPUT(T2AM(KOFF),1,NT1AM(ISYMAI),1,NT1AM(ISYMBJ), 7344 * NT1AM(ISYMAI),NT1AM(ISYMBJ),1,LUPRI) 7345 200 CONTINUE 7346 END IF 7347C 7348 RETURN 7349 END 7350C /* Deck ccrhs_t2bt */ 7351 SUBROUTINE CCRHS_T2BT(T2AM,WORK,LWORK,ISYM) 7352C 7353C Alfredo Sanchez and Henrik Koch 30-July 1994 7354C 7355C PURPOSE: 7356C Back transform t2 amplitudes. 7357C The amplitudes are assumed to be a square matrix. 7358C 7359#include "implicit.h" 7360 PARAMETER(ONETHD = 1.0D0/3.0D0,TWOTHD = 2.0D0/3.0D0) 7361 DIMENSION T2AM(*) 7362 DIMENSION WORK(LWORK) 7363#include "priunit.h" 7364#include "ccorb.h" 7365#include "ccsdsym.h" 7366#include "ccsdinp.h" 7367C 7368C---------------------------------- 7369C Back transform t2-amplitudes. 7370C---------------------------------- 7371C 7372 DO 100 ISYMJ = 1,NSYM 7373C 7374 DO 110 J = 1,NRHF(ISYMJ) 7375C 7376 DO 120 ISYMB = 1,NSYM 7377C 7378 ISYMBJ = MULD2H(ISYMB,ISYMJ) 7379 ISYMAI = MULD2H(ISYMBJ,ISYM) 7380C 7381 DO 130 B = 1,NVIR(ISYMB) 7382C 7383 NBJ = IT1AM(ISYMB,ISYMJ)+NVIR(ISYMB)*(J-1)+B 7384C 7385 DO 140 ISYMI = 1,ISYMJ 7386C 7387 ISYMA = MULD2H(ISYMI,ISYMAI) 7388 ISYMAJ = MULD2H(ISYMA,ISYMJ) 7389 ISYMBI = MULD2H(ISYMB,ISYMI) 7390C 7391 KSCR1 = 1 7392 KSCR2 = KSCR1 + NVIR(ISYMA) 7393 KEND1 = KSCR2 + NVIR(ISYMA) 7394 LWRK1 = LWORK - KEND1 7395 IF (LWRK1 .LT. 0) THEN 7396 CALL QUIT('Insufficient space in CCRHS_T2TR') 7397 ENDIF 7398C 7399 IF (ISYMI .EQ. ISYMJ) THEN 7400 NRHFI = J - 1 7401 ELSE 7402 NRHFI = NRHF(ISYMI) 7403 END IF 7404C 7405 DO 150 I = 1,NRHFI 7406C 7407 NBI = IT1AM(ISYMB,ISYMI)+NVIR(ISYMB)*(I-1)+B 7408C 7409 NAIBJ = IT2SQ(ISYMAI,ISYMBJ) 7410 * + NT1AM(ISYMAI)*(NBJ-1) 7411 * + IT1AM(ISYMA,ISYMI)+NVIR(ISYMA)*(I-1)+1 7412C 7413 NAJBI = IT2SQ(ISYMAJ,ISYMBI) 7414 * + NT1AM(ISYMAJ)*(NBI-1) 7415 * + IT1AM(ISYMA,ISYMJ)+NVIR(ISYMA)*(J-1)+1 7416C 7417 CALL DCOPY(NVIR(ISYMA),T2AM(NAIBJ),1, 7418 * WORK(KSCR1),1) 7419 CALL DCOPY(NVIR(ISYMA),T2AM(NAJBI),1, 7420 * WORK(KSCR2),1) 7421C 7422 CALL DSCAL(NVIR(ISYMA),TWOTHD,T2AM(NAIBJ),1) 7423 CALL DSCAL(NVIR(ISYMA),TWOTHD,T2AM(NAJBI),1) 7424C 7425 CALL DAXPY(NVIR(ISYMA),ONETHD,WORK(KSCR2),1, 7426 * T2AM(NAIBJ),1) 7427 CALL DAXPY(NVIR(ISYMA),ONETHD,WORK(KSCR1),1, 7428 * T2AM(NAJBI),1) 7429C 7430 150 CONTINUE 7431C 7432 140 CONTINUE 7433C 7434 130 CONTINUE 7435C 7436 120 CONTINUE 7437C 7438 110 CONTINUE 7439C 7440 100 CONTINUE 7441C 7442 IF (IPRINT .GT. 120) THEN 7443 CALL AROUND('Back-transformed t2am') 7444 DO 200 ISYMBJ = 1,NSYM 7445 ISYMAI = MULD2H(ISYMBJ,ISYM) 7446 KOFF = IT2SQ(ISYMAI,ISYMBJ) + 1 7447 WRITE(LUPRI,*) 7448 WRITE(LUPRI,*) 'Symmetry block:',ISYMBJ 7449 CALL OUTPUT(T2AM(KOFF),1,NT1AM(ISYMAI),1,NT1AM(ISYMBJ), 7450 * NT1AM(ISYMAI),NT1AM(ISYMBJ),1,LUPRI) 7451 200 CONTINUE 7452 END IF 7453C 7454 RETURN 7455 END 7456C /* Deck cc_mtcme */ 7457 SUBROUTINE CC_MTCME(SCRM,WORK,LWORK,ISYMD,ISYMTR) 7458C 7459C Alfredo Sanchez and Henrik Koch 26-July 1994 7460C General non. total sym. Ampl. Ove Christiansen 15-2-1994. 7461C 7462C PURPOSE: 7463C Calculate 2 Coulomb minus exchange of the T2M-amplitudes. 7464C 7465#include "implicit.h" 7466 PARAMETER (ONE = 1.0D0, TWO = 2.0D0) 7467 DIMENSION SCRM(*) 7468 DIMENSION WORK(LWORK) 7469#include "priunit.h" 7470#include "ccorb.h" 7471#include "ccsdsym.h" 7472C 7473 ISYMM = MULD2H(ISYMD,ISYMTR) 7474C 7475 DO 100 ISYMJ = 1,NSYM 7476C 7477 ISYMCI = MULD2H(ISYMJ,ISYMM) 7478C 7479 DO 110 J = 1,NRHF(ISYMJ) 7480C 7481 DO 120 ISYMI = 1,ISYMJ 7482C 7483 ISYMC = MULD2H(ISYMI,ISYMCI) 7484 ISYMCJ = MULD2H(ISYMC,ISYMJ) 7485C 7486 KSCR1 = 1 7487 KSCR2 = KSCR1 + NVIR(ISYMC) 7488 KEND1 = KSCR2 + NVIR(ISYMC) 7489 LWRK1 = LWORK - KEND1 7490C 7491 IF (LWRK1 .LT. 0) THEN 7492 CALL QUIT('Insufficient space in CCSD_T2MTP') 7493 ENDIF 7494C 7495 IF (ISYMI .EQ. ISYMJ) THEN 7496 NRHFI = J - 1 7497 ELSE 7498 NRHFI = NRHF(ISYMI) 7499 END IF 7500C 7501 DO 130 I = 1,NRHFI 7502C 7503 NCIJ = IT2BCD(ISYMCI,ISYMJ) + NT1AM(ISYMCI)*(J-1) 7504 * + IT1AM(ISYMC,ISYMI) + NVIR(ISYMC)*(I-1) + 1 7505 NCJI = IT2BCD(ISYMCJ,ISYMI) + NT1AM(ISYMCJ)*(I-1) 7506 * + IT1AM(ISYMC,ISYMJ) + NVIR(ISYMC)*(J-1) + 1 7507C 7508 CALL DCOPY(NVIR(ISYMC),SCRM(NCIJ),1,WORK(KSCR1),1) 7509 CALL DCOPY(NVIR(ISYMC),SCRM(NCJI),1,WORK(KSCR2),1) 7510 CALL DSCAL(NVIR(ISYMC),TWO,SCRM(NCIJ),1) 7511 CALL DSCAL(NVIR(ISYMC),TWO,SCRM(NCJI),1) 7512 CALL DAXPY(NVIR(ISYMC),-ONE,WORK(KSCR2),1, 7513 * SCRM(NCIJ),1) 7514 CALL DAXPY(NVIR(ISYMC),-ONE,WORK(KSCR1),1, 7515 * SCRM(NCJI),1) 7516C 7517 130 CONTINUE 7518C 7519 120 CONTINUE 7520C 7521 110 CONTINUE 7522C 7523 100 CONTINUE 7524C 7525 RETURN 7526 END 7527C /* Deck ccsd_index */ 7528 SUBROUTINE CCSD_INDEX(INDV1,INDV2,ISYMAB) 7529C 7530C Written by Henrik Koch 17-aug-1994. 7531C 7532C 7533#include "implicit.h" 7534#include "maxorb.h" 7535 DIMENSION INDV1(*), INDV2(*) 7536#include "priunit.h" 7537#include "ccorb.h" 7538#include "ccsdsym.h" 7539#include "symsq.h" 7540C 7541 NAB = 0 7542 DO 100 ISYMB = 1,NSYM 7543C 7544 ISYMA = MULD2H(ISYMB,ISYMAB) 7545C 7546 IF (ISYMA .GT. ISYMB) GOTO 100 7547C 7548 NTOTA = NBAS(ISYMA) 7549C 7550 DO 110 B = 1,NBAS(ISYMB) 7551C 7552 IF (ISYMAB .EQ. 1) NTOTA = B 7553C 7554 DO 120 A = 1,NTOTA 7555C 7556 NAB = NAB + 1 7557C 7558 NRAB = IAODIS(ISYMA,ISYMB) + NBAS(ISYMA)*(B - 1) + A 7559 NRBA = IAODIS(ISYMB,ISYMA) + NBAS(ISYMB)*(A - 1) + B 7560C 7561 INDV1(NAB) = NRAB 7562 INDV2(NAB) = NRBA 7563C 7564 120 CONTINUE 7565 110 CONTINUE 7566C 7567 100 CONTINUE 7568C 7569 RETURN 7570 END 7571 SUBROUTINE CCRHS_IPM(XINT,XINTP,XINTM,SCRAB,INDV1,INDV2, 7572 * ISYMAB,ISYMG,NUMG,IG1,IG2) 7573C 7574C Written by Henrik Koch 17-aug-1994. 7575C 7576C 7577C Purpose: Making plus and minus combination of integrals. 7578C (a>=g|bd) -> K+ og K- where 7579C K+- = (ag|bd) +- (bg|ad) a<=b,g<=d 7580C 7581#include "implicit.h" 7582#include "priunit.h" 7583#include "maxorb.h" 7584 PARAMETER(ONE = 1.0D0, TWO = 2.0D0) 7585 DIMENSION XINT(*),XINTP(*),XINTM(*),SCRAB(*) 7586 DIMENSION INDV1(*), INDV2(*) 7587#include "ccorb.h" 7588#include "ccsdsym.h" 7589#include "symsq.h" 7590C 7591 INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J 7592C 7593 ISYDIS = MULD2H(ISYMAB,ISYMG) 7594C 7595C 7596 DO 100 G = IG1,IG2 7597C 7598 IG = G - IG1 + 1 7599C 7600 DO 110 ISYMB = 1,NSYM 7601C 7602 ISYMA = MULD2H(ISYMB,ISYMAB) 7603 ISYMAG = MULD2H(ISYMA,ISYMG) 7604C 7605 NTOTA = MAX(NBAS(ISYMA),1) 7606 NTOTAG = MAX(NNBST(ISYMAG),1) 7607C 7608 DO 120 A = 1,NBAS(ISYMA) 7609C 7610 IF (ISYMA .EQ. ISYMG) THEN 7611 KOFF1 = IDSAOG(ISYMB,ISYDIS) + IAODPK(ISYMA,ISYMG) 7612 * + INDEX(G,A) 7613 ELSE IF (ISYMA .LT. ISYMG) THEN 7614 KOFF1 = IDSAOG(ISYMB,ISYDIS) + IAODPK(ISYMA,ISYMG) 7615 * + NBAS(ISYMA)*(G - 1) + A 7616 ELSE 7617 KOFF1 = IDSAOG(ISYMB,ISYDIS) + IAODPK(ISYMA,ISYMG) 7618 * + NBAS(ISYMG)*(A - 1) + G 7619 ENDIF 7620C 7621 KOFF2 = IAODIS(ISYMA,ISYMB) + A 7622C 7623 CALL DCOPY(NBAS(ISYMB),XINT(KOFF1),NTOTAG, 7624 * SCRAB(KOFF2),NTOTA) 7625C 7626 120 CONTINUE 7627C 7628 110 CONTINUE 7629C 7630 KOFF = NNBST(ISYMAB)*(IG - 1) 7631C 7632#if !defined (SYS_CRAY) 7633 DO 130 I = 1,NNBST(ISYMAB) 7634C 7635 XINTP(KOFF + I) = SCRAB(INDV1(I)) 7636 XINTM(KOFF + I) = SCRAB(INDV2(I)) 7637C 7638 130 CONTINUE 7639#else 7640 CALL GATHER(NNBST(ISYMAB),XINTP(KOFF + 1),SCRAB,INDV1) 7641 CALL GATHER(NNBST(ISYMAB),XINTM(KOFF + 1),SCRAB,INDV2) 7642#endif 7643C 7644 100 CONTINUE 7645C 7646C 7647 NTOT = NNBST(ISYMAB)*NUMG 7648C 7649 CALL DAXPY(NTOT,ONE,XINTM,1,XINTP,1) 7650 CALL DSCAL(NTOT,-TWO,XINTM,1) 7651 CALL DAXPY(NTOT,ONE,XINTP,1,XINTM,1) 7652C 7653 RETURN 7654 END 7655C /* Deck ccrhs_cio */ 7656 SUBROUTINE CCRHS_CIO(OMEGA2,T2AM,XLAMDH,WORK,LWORK, 7657 * ISYVEC,ISYCIM,LUC,CFIL,IV,IOPT) 7658C 7659C asm 17-aug-1994 7660C 7661C Ove Christiansen 30-7-1995: modified to account for general 7662C non. total symmetric vectors (ISYVEC) and 7663C intermediates (ISYCIM). LUC and CFIL is 7664C used to control from which file the 7665C intermediate is obtained. 7666C 7667C if iopt = 1 the C intermediate is assumed 7668C to be as in energy calc. 7669C 7670C if iopt ne. 1 we use the intermediate 7671C on luc with address given according to 7672C transformed vector nr iv (iv is not 1 7673C if several vectors are transformed 7674C simultaneously.) 7675C 7676C in energy calc: iv=1,iopt=1 7677C 7678C PURPOSE: 7679C Calculate the C-term making I/O 7680C 7681#include "implicit.h" 7682 PARAMETER (ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, TWO = 2.0D0) 7683 DIMENSION OMEGA2(*),T2AM(*),XLAMDH(*) 7684 DIMENSION WORK(LWORK) 7685 CHARACTER CFIL*(*) 7686#include "priunit.h" 7687#include "ccorb.h" 7688#include "ccsdsym.h" 7689#include "maxorb.h" 7690#include "ccsdio.h" 7691C 7692C INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J 7693C 7694 IF (OMEGSQ) THEN 7695 WRITE(LUPRI,*) 7696 & 'I/O in C-term not implemented for square Omega2' 7697 CALL QUIT('OMEGSQ = .TRUE. in CCRHS_CIO') 7698 END IF 7699C 7700 ISAIBJ = MULD2H(ISYVEC,ISYCIM) 7701C 7702 DO 100 ISYMAI = 1,NSYM 7703C 7704 IF (NT1AM(ISYMAI) .EQ. 0) GOTO 100 7705C 7706 ISYMBJ = MULD2H(ISYMAI,ISAIBJ) 7707 ISYMCK = MULD2H(ISYVEC,ISYMBJ) 7708 ISYMDK = MULD2H(ISYCIM,ISYMAI) 7709C 7710C------------------------ 7711C Batch structure. 7712C------------------------ 7713C 7714 NT1AI = NT1AM(ISYMAI) 7715C 7716 LENAI = NT1AO(ISYMDK) 7717 LENMIN = 2*LENAI 7718 IF (LENMIN .EQ. 0) GOTO 100 7719C 7720 NDISAI = LWORK / LENMIN 7721 IF (NDISAI .LT. 1) THEN 7722 CALL QUIT('Insufficient space for '// 7723 & 'allocation in CCRHS_CIO-1') 7724 END IF 7725 NDISAI = MIN(NDISAI,NT1AI) 7726C 7727 NBATAI = (NT1AI - 1) / NDISAI + 1 7728C 7729C-------------------------- 7730C Loop over batches. 7731C-------------------------- 7732C 7733 ILSTAI = 0 7734 DO 110 IBATAI = 1,NBATAI 7735C 7736 IFSTAI = ILSTAI + 1 7737 ILSTAI = ILSTAI + NDISAI 7738 IF (ILSTAI .GT. NT1AI) THEN 7739 ILSTAI = NT1AI 7740 NDISAI = ILSTAI - IFSTAI + 1 7741 END IF 7742C 7743C----------------------------- 7744C Memory allocation. 7745C----------------------------- 7746C 7747 KSCR1 = 1 7748 KSCR2 = KSCR1 + NDISAI*NT1AO(ISYMDK) 7749 KEND = KSCR2 + NDISAI*NT1AO(ISYMDK) 7750 LWRK1 = LWORK - KEND 7751C 7752 IF (LWRK1 .LT. 0) THEN 7753 CALL QUIT('Insufficient space for '// 7754 & 'allocation in CCRHS_CIO-2') 7755 END IF 7756C 7757C---------------------------------- 7758C Construct P(del k,#ai). 7759C---------------------------------- 7760C 7761 KOFF1 = KSCR1 7762 DO 120 ISYDEL = 1,NSYM 7763C 7764 ISYMK = MULD2H(ISYDEL,ISYMDK) 7765C 7766 DO 130 IDELTA = 1,NBAS(ISYDEL) 7767C 7768 ID = IDELTA + IBAS(ISYDEL) 7769C 7770 IF (IOPT .EQ. 1 ) THEN 7771 IOFF = IT2DEL(ID) + IT2BCT(ISYMK,ISYMAI) 7772 * + NRHF(ISYMK)*(IFSTAI - 1) + 1 7773 ELSE 7774 IOFF = IT2DLR(ID,IV) + IT2BCT(ISYMK,ISYMAI) 7775 * + NRHF(ISYMK)*(IFSTAI - 1) + 1 7776 ENDIF 7777C 7778 LEN = NDISAI*NRHF(ISYMK) 7779C 7780 IF (LEN .GT. 0) THEN 7781 CALL GETWA2(LUC,CFIL,WORK(KOFF1),IOFF,LEN) 7782 ENDIF 7783C 7784 DO 140 NAI = IFSTAI,ILSTAI 7785C 7786 KAI = NAI - IFSTAI + 1 7787C 7788 KOFF2 = KOFF1 + NRHF(ISYMK)*(KAI - 1) 7789 KOFF3 = KSCR2 + NT1AO(ISYMDK)*(KAI - 1) 7790 * + IT1AO(ISYDEL,ISYMK) + IDELTA - 1 7791C 7792 CALL DCOPY(NRHF(ISYMK),WORK(KOFF2),1,WORK(KOFF3), 7793 * NBAS(ISYDEL)) 7794C 7795 140 CONTINUE 7796C 7797 KOFF1 = KOFF1 + LEN 7798C 7799 130 CONTINUE 7800 120 CONTINUE 7801C 7802C----------------------------------------- 7803C Transform delta index to c. 7804C----------------------------------------- 7805C 7806 DO 150 NAI = IFSTAI,ILSTAI 7807C 7808 KAI = NAI - IFSTAI + 1 7809C 7810 DO 160 ISYMC = 1,NSYM 7811C 7812 ISYDEL = ISYMC 7813 ISYMK = MULD2H(ISYMC,ISYMCK) 7814C 7815 NBASD = MAX(NBAS(ISYDEL),1) 7816 NVIRC = MAX(NVIR(ISYMC),1) 7817C 7818 KOFF4 = ILMVIR(ISYDEL) + 1 7819 KOFF5 = KSCR2 + NT1AO(ISYMDK)*(KAI - 1) 7820 * + IT1AO(ISYDEL,ISYMK) 7821 KOFF6 = KSCR1 + NT1AM(ISYMCK)*(KAI - 1) 7822 * + IT1AM(ISYMC,ISYMK) 7823C 7824 CALL DGEMM('T','N',NVIR(ISYMC),NRHF(ISYMK), 7825 * NBAS(ISYDEL),ONE,XLAMDH(KOFF4),NBASD, 7826 * WORK(KOFF5),NBASD,ZERO,WORK(KOFF6), 7827 * NVIRC) 7828C 7829 160 CONTINUE 7830 150 CONTINUE 7831C 7832C-------------------------------------------- 7833C Contract P(ck,#ai) with T(bj,ck). 7834C-------------------------------------------- 7835C 7836 NT1BJ = MAX(NT1AM(ISYMBJ),1) 7837 NT1CK = MAX(NT1AM(ISYMCK),1) 7838C 7839 KOFF7 = IT2SQ(ISYMBJ,ISYMCK) + 1 7840C 7841 CALL DGEMM('N','N',NT1AM(ISYMBJ),NDISAI,NT1AM(ISYMCK), 7842 * ONE,T2AM(KOFF7),NT1BJ,WORK(KSCR1),NT1CK, 7843 * ZERO,WORK(KSCR2),NT1BJ) 7844C 7845C------------------------------ 7846C Scale the diagonal. 7847C------------------------------ 7848C 7849 IF (ISYMBJ .EQ. ISYMAI) THEN 7850C 7851 DO 170 NAI = IFSTAI,ILSTAI 7852 KOFF8 = KSCR2 + NT1AM(ISYMBJ)*(NAI-IFSTAI) + NAI - 1 7853 WORK(KOFF8) = TWO * WORK(KOFF8) 7854 170 CONTINUE 7855C 7856 END IF 7857C 7858C----------------------------------------------- 7859C Add the result to the packed omega2. 7860C----------------------------------------------- 7861C 7862 DO 180 ISYMI = 1,NSYM 7863C 7864 ISYMA = MULD2H(ISYMI,ISYMAI) 7865C 7866 DO 190 I = 1,NRHF(ISYMI) 7867C 7868 DO 200 A = 1,NVIR(ISYMA) 7869C 7870 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + A 7871 IF ((NAI .LT. IFSTAI) .OR. (NAI .GT. ILSTAI)) 7872 * GOTO 200 7873C 7874 DO 210 ISYMJ = 1,NSYM 7875C 7876 ISYMB = MULD2H(ISYMJ,ISYMBJ) 7877 ISYMAJ = MULD2H(ISYMA,ISYMJ) 7878 ISYMBI = MULD2H(ISYMB,ISYMI) 7879C 7880 DO 220 J = 1,NRHF(ISYMJ) 7881C 7882 NAJ = IT1AM(ISYMA,ISYMJ) 7883 * + NVIR(ISYMA)*(J-1) + A 7884C 7885 CALL CC_PUTC(WORK(KSCR2),OMEGA2,ISYMAI, 7886 * ISYMAJ,ISYMBI,ISYMBJ,ISYMB, 7887 * ISYMI,ISYMJ,NAI,NAJ,I,J, 7888 * IFSTAI) 7889C 7890 220 CONTINUE 7891 210 CONTINUE 7892 200 CONTINUE 7893 190 CONTINUE 7894 180 CONTINUE 7895C 7896 110 CONTINUE 7897 100 CONTINUE 7898C 7899 RETURN 7900 END 7901C /* Deck cc_putc */ 7902 SUBROUTINE CC_PUTC(SCR2,OMEGA2,ISYMAI,ISYMAJ,ISYMBI,ISYMBJ, 7903 * ISYMB,ISYMI,ISYMJ,NAI,NAJ,I,J,IFSTAI) 7904C 7905C Ove Christiansen 30-10-1995: Put in C contribution in omega vector 7906C avoid troble on cray with optimization. 7907C 7908#include "implicit.h" 7909 PARAMETER (ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, TWO = 2.0D0) 7910C 7911 DIMENSION SCR2(*),OMEGA2(*) 7912#include "priunit.h" 7913#include "ccorb.h" 7914#include "ccsdsym.h" 7915#include "maxorb.h" 7916#include "ccsdio.h" 7917C 7918 INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J 7919C 7920 IF ( ISYMAI .EQ. ISYMBJ ) THEN 7921C 7922 DO 100 B = 1,NVIR(ISYMB) 7923C 7924 NBJ = IT1AM(ISYMB,ISYMJ) 7925 * + NVIR(ISYMB)*(J-1) + B 7926 KOFF9 = NT1AM(ISYMBJ)*(NAI - IFSTAI) + NBJ 7927 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 7928 * + INDEX(NAI,NBJ) 7929 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) 7930 * - HALF * SCR2(KOFF9) 7931C 7932 100 CONTINUE 7933C 7934 ENDIF 7935C 7936 IF ( ISYMAI .LT. ISYMBJ ) THEN 7937C 7938 DO 200 B = 1,NVIR(ISYMB) 7939C 7940 NBJ = IT1AM(ISYMB,ISYMJ) 7941 * + NVIR(ISYMB)*(J-1) + B 7942 KOFF9 = NT1AM(ISYMBJ)*(NAI - IFSTAI) + NBJ 7943 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 7944 * + NT1AM(ISYMAI)*(NBJ - 1) + NAI 7945 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) 7946 * - HALF * SCR2(KOFF9) 7947C 7948 200 CONTINUE 7949C 7950 ENDIF 7951C 7952 IF ( ISYMBJ .LT. ISYMAI ) THEN 7953C 7954 DO 300 B = 1,NVIR(ISYMB) 7955C 7956 NBJ = IT1AM(ISYMB,ISYMJ) 7957 * + NVIR(ISYMB)*(J-1) + B 7958 KOFF9 = NT1AM(ISYMBJ)*(NAI - IFSTAI) + NBJ 7959 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 7960 * + NT1AM(ISYMBJ)*(NAI - 1) + NBJ 7961 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) 7962 * - HALF * SCR2(KOFF9) 7963C 7964 300 CONTINUE 7965C 7966 ENDIF 7967C 7968 IF (ISYMAJ .EQ. ISYMBI) THEN 7969C 7970 DO 400 B = 1,NVIR(ISYMB) 7971C 7972 NBI = IT1AM(ISYMB,ISYMI) 7973 * + NVIR(ISYMB)*(I-1) + B 7974 NBJ = IT1AM(ISYMB,ISYMJ) 7975 * + NVIR(ISYMB)*(J-1) + B 7976 KOFF9 = NT1AM(ISYMBJ)*(NAI - IFSTAI) + NBJ 7977 NAJBI = IT2AM(ISYMAJ,ISYMBI) 7978 * + INDEX(NAJ,NBI) 7979 OMEGA2(NAJBI) = OMEGA2(NAJBI) - SCR2(KOFF9) 7980C 7981 400 CONTINUE 7982C 7983 ENDIF 7984C 7985 IF (ISYMAJ .LT. ISYMBI) THEN 7986C 7987 DO 500 B = 1,NVIR(ISYMB) 7988C 7989 NBI = IT1AM(ISYMB,ISYMI) 7990 * + NVIR(ISYMB)*(I-1) + B 7991 NBJ = IT1AM(ISYMB,ISYMJ) 7992 * + NVIR(ISYMB)*(J-1) + B 7993 KOFF9 = NT1AM(ISYMBJ)*(NAI - IFSTAI) + NBJ 7994 NAJBI = IT2AM(ISYMAJ,ISYMBI) 7995 * + NT1AM(ISYMAJ)*(NBI - 1) 7996 * + NAJ 7997 OMEGA2(NAJBI) = OMEGA2(NAJBI) - SCR2(KOFF9) 7998C 7999 500 CONTINUE 8000C 8001 ENDIF 8002C 8003 IF (ISYMBI .LT. ISYMAJ) THEN 8004C 8005 DO 600 B = 1,NVIR(ISYMB) 8006C 8007 NBI = IT1AM(ISYMB,ISYMI) 8008 * + NVIR(ISYMB)*(I-1) + B 8009 NBJ = IT1AM(ISYMB,ISYMJ) 8010 * + NVIR(ISYMB)*(J-1) + B 8011 KOFF9 = NT1AM(ISYMBJ)*(NAI - IFSTAI) + NBJ 8012 NAJBI = IT2AM(ISYMAJ,ISYMBI) 8013 * + NT1AM(ISYMBI)*(NAJ - 1) 8014 * + NBI 8015 OMEGA2(NAJBI) = OMEGA2(NAJBI) - SCR2(KOFF9) 8016C 8017 600 CONTINUE 8018C 8019 ENDIF 8020C 8021 END 8022C /* Deck ccrhs_dio */ 8023 SUBROUTINE CCRHS_DIO(OMEGA2,T2AM,XLAMDH,WORK,LWORK, 8024 * ISYVEC,ISYDIM,LUD,DFIL,IV,IOPT) 8025C 8026C asm 20-aug-1994 8027C 8028C Ove Christiansen 30-7-1995: Modified to account for general 8029C non. total symmetric vectors (ISYVEC) and 8030C intermediates (ISYDIM). LUD and DFIL is 8031C used to control from which file the 8032C intermediate is obtained. 8033C 8034C if iopt = 1 the D intermediate is assumed 8035C to be as in energy calc. 8036C 8037C if iopt ne. 1 we use the intermediate 8038C on luc with address given according to 8039C transformed vector nr iv (iv is not 1 8040C if several vectors are transformed 8041C simultaneously.) 8042C 8043C in energy calc: iv=1,iopt=1 8044C 8045C PURPOSE: 8046C Calculate the D-term making I/O 8047C 8048#include "implicit.h" 8049 PARAMETER (ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, TWO = 2.0D0) 8050 DIMENSION OMEGA2(*),T2AM(*),XLAMDH(*) 8051 DIMENSION WORK(LWORK) 8052 CHARACTER DFIL*(*) 8053#include "priunit.h" 8054#include "ccorb.h" 8055#include "ccsdsym.h" 8056#include "maxorb.h" 8057#include "ccsdio.h" 8058C 8059C INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J 8060C 8061 IF (OMEGSQ) THEN 8062 WRITE(LUPRI,*) 8063 & 'I/O in D-term not implemented for square Omega2' 8064 CALL QUIT('OMEGSQ = .TRUE. in CCRHS_DIO') 8065 END IF 8066C 8067 ISAIBJ = MULD2H(ISYVEC,ISYDIM) 8068C 8069 DO 100 ISYMAI = 1,NSYM 8070C 8071 IF (NT1AM(ISYMAI) .EQ. 0) GOTO 100 8072C 8073C 8074 ISYMBJ = MULD2H(ISYMAI,ISAIBJ) 8075 ISYMCK = MULD2H(ISYVEC,ISYMBJ) 8076 ISYMDK = MULD2H(ISYDIM,ISYMAI) 8077C 8078C------------------------ 8079C Batch structure. 8080C------------------------ 8081C 8082 NT1AI = NT1AM(ISYMAI) 8083C 8084 LENAI = NT1AO(ISYMDK) 8085 LENMIN = 2*LENAI 8086 IF (LENMIN .EQ. 0) GOTO 100 8087C 8088 NDISAI = LWORK / LENMIN 8089 IF (NDISAI .LT. 1) THEN 8090 CALL QUIT('Insufficient space for allocation in CCRHS_DIO') 8091 END IF 8092 NDISAI = MIN(NDISAI,NT1AI) 8093C 8094 NBATAI = (NT1AI - 1) / NDISAI + 1 8095C 8096C-------------------------- 8097C Loop over batches. 8098C-------------------------- 8099C 8100 ILSTAI = 0 8101 DO 110 IBATAI = 1,NBATAI 8102C 8103 IFSTAI = ILSTAI + 1 8104 ILSTAI = ILSTAI + NDISAI 8105 IF (ILSTAI .GT. NT1AI) THEN 8106 ILSTAI = NT1AI 8107 NDISAI = ILSTAI - IFSTAI + 1 8108 END IF 8109C 8110C----------------------------- 8111C Memory allocation. 8112C----------------------------- 8113C 8114 KSCR1 = 1 8115 KSCR2 = KSCR1 + NDISAI*NT1AO(ISYMDK) 8116 KEND = KSCR2 + NDISAI*NT1AO(ISYMDK) 8117 LWRK1 = LWORK - KEND 8118C 8119 IF (LWRK1 .LT. 0) THEN 8120 CALL QUIT('Insufficient space for '// 8121 & 'allocation in CCRHS_DIO') 8122 END IF 8123C 8124C---------------------------------- 8125C Construct P(del k,#ai). 8126C---------------------------------- 8127C 8128 KOFF1 = KSCR1 8129 DO 120 ISYDEL = 1,NSYM 8130C 8131 ISYMK = MULD2H(ISYDEL,ISYMDK) 8132C 8133 DO 130 IDELTA = 1,NBAS(ISYDEL) 8134C 8135 ID = IDELTA + IBAS(ISYDEL) 8136C 8137 IF (IOPT .EQ. 1 ) THEN 8138 IOFF = IT2DEL(ID) + IT2BCT(ISYMK,ISYMAI) 8139 * + NRHF(ISYMK)*(IFSTAI - 1) + 1 8140 ELSE 8141 IOFF = IT2DLR(ID,IV) + IT2BCT(ISYMK,ISYMAI) 8142 * + NRHF(ISYMK)*(IFSTAI - 1) + 1 8143 ENDIF 8144C 8145 LEN = NDISAI*NRHF(ISYMK) 8146C 8147 IF (LEN .GT. 0) THEN 8148 CALL GETWA2(LUD,DFIL,WORK(KOFF1),IOFF,LEN) 8149 ENDIF 8150C 8151 DO 140 NAI = IFSTAI,ILSTAI 8152C 8153 KAI = NAI - IFSTAI + 1 8154C 8155 KOFF2 = KOFF1 + NRHF(ISYMK)*(KAI - 1) 8156 KOFF3 = KSCR2 + NT1AO(ISYMDK)*(KAI - 1) 8157 * + IT1AO(ISYDEL,ISYMK) + IDELTA - 1 8158C 8159 CALL DCOPY(NRHF(ISYMK),WORK(KOFF2),1,WORK(KOFF3), 8160 * NBAS(ISYDEL)) 8161C 8162 140 CONTINUE 8163C 8164 KOFF1 = KOFF1 + LEN 8165C 8166 130 CONTINUE 8167 120 CONTINUE 8168C 8169C-------------------------------------- 8170C Transform delta index to c. 8171C-------------------------------------- 8172C 8173 DO 150 NAI = IFSTAI,ILSTAI 8174C 8175 KAI = NAI - IFSTAI + 1 8176C 8177 DO 160 ISYMC = 1,NSYM 8178C 8179 ISYDEL = ISYMC 8180 ISYMK = MULD2H(ISYMC,ISYMCK) 8181C 8182 NBASD = MAX(NBAS(ISYDEL),1) 8183 NVIRC = MAX(NVIR(ISYMC),1) 8184C 8185 KOFF4 = ILMVIR(ISYDEL) + 1 8186 KOFF5 = KSCR2 + NT1AO(ISYMDK)*(KAI - 1) 8187 * + IT1AO(ISYDEL,ISYMK) 8188 KOFF6 = KSCR1 + NT1AM(ISYMCK)*(KAI - 1) 8189 * + IT1AM(ISYMC,ISYMK) 8190C 8191 CALL DGEMM('T','N',NVIR(ISYMC),NRHF(ISYMK), 8192 * NBAS(ISYDEL),ONE,XLAMDH(KOFF4),NBASD, 8193 * WORK(KOFF5),NBASD,ZERO,WORK(KOFF6), 8194 * NVIRC) 8195C 8196 160 CONTINUE 8197 150 CONTINUE 8198C 8199C-------------------------------------------- 8200C Contract P(ck,#ai) with T(bj,ck). 8201C-------------------------------------------- 8202C 8203 NT1BJ = MAX(NT1AM(ISYMBJ),1) 8204 NT1CK = MAX(NT1AM(ISYMCK),1) 8205C 8206 KOFF7 = IT2SQ(ISYMBJ,ISYMCK) + 1 8207C 8208 CALL DGEMM('N','N',NT1AM(ISYMBJ),NDISAI,NT1AM(ISYMCK), 8209 * ONE,T2AM(KOFF7),NT1BJ,WORK(KSCR1),NT1CK, 8210 * ZERO,WORK(KSCR2),NT1BJ) 8211C 8212C------------------------------ 8213C Scale the diagonal. 8214C------------------------------ 8215C 8216 IF (ISYMBJ .EQ. ISYMAI) THEN 8217C 8218 DO 170 NAI = IFSTAI,ILSTAI 8219 KOFF8 = KSCR2 + NT1AM(ISYMBJ)*(NAI-IFSTAI) + NAI - 1 8220 WORK(KOFF8) = TWO * WORK(KOFF8) 8221 170 CONTINUE 8222C 8223 END IF 8224C 8225C----------------------------------------------- 8226C Add the result to the packed omega2. 8227C----------------------------------------------- 8228C 8229 DO 180 NAI = IFSTAI,ILSTAI 8230C 8231 CALL CC_PUTD(WORK(KSCR2),OMEGA2,ISYMAI,ISYMBJ,NAI,IFSTAI) 8232C 8233 180 CONTINUE 8234C 8235 110 CONTINUE 8236 100 CONTINUE 8237C 8238 RETURN 8239 END 8240C /* Deck cc_putd */ 8241 SUBROUTINE CC_PUTD(SCR2,OMEGA2,ISYMAI,ISYMBJ,NAI,IFSTAI) 8242C 8243C Ove Christiansen 30-10-1995: Put in D contribution in omega vector 8244C avoid troble on cray with optimization. 8245C 8246#include "implicit.h" 8247 PARAMETER (ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, TWO = 2.0D0) 8248C 8249 DIMENSION SCR2(*),OMEGA2(*) 8250C 8251#include "priunit.h" 8252#include "ccorb.h" 8253#include "ccsdsym.h" 8254#include "maxorb.h" 8255#include "ccsdio.h" 8256C 8257 INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J 8258C 8259 IF ( ISYMAI .EQ. ISYMBJ) THEN 8260 DO 190 NBJ = 1,NT1AM(ISYMBJ) 8261C 8262 KOFF9 = NT1AM(ISYMBJ)*(NAI-IFSTAI)+ NBJ 8263 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 8264 * + INDEX(NAI,NBJ) 8265C 8266 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + HALF*SCR2(KOFF9) 8267C 8268 190 CONTINUE 8269C 8270 ENDIF 8271C 8272 IF ( ISYMAI .LT. ISYMBJ) THEN 8273 DO 200 NBJ = 1,NT1AM(ISYMBJ) 8274C 8275 KOFF9 = NT1AM(ISYMBJ)*(NAI-IFSTAI)+ NBJ 8276 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 8277 * + NT1AM(ISYMAI)*(NBJ - 1) + NAI 8278 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + HALF*SCR2(KOFF9) 8279C 8280 200 CONTINUE 8281C 8282 ENDIF 8283C 8284 IF (ISYMBJ .LT. ISYMAI) THEN 8285 DO 210 NBJ = 1,NT1AM(ISYMBJ) 8286C 8287 KOFF9 = NT1AM(ISYMBJ)*(NAI-IFSTAI)+ NBJ 8288 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 8289 * + NT1AM(ISYMBJ)*(NAI - 1) + NBJ 8290 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + HALF*SCR2(KOFF9) 8291C 8292 210 CONTINUE 8293C 8294 ENDIF 8295C 8296 END 8297C /* Deck ccrd_init */ 8298 SUBROUTINE CCRD_INIT(KADR1,KADR2,ISYDIS) 8299C 8300C asm 22-aug-1994 8301C 8302C Purpose: Construct index arrays for CCRDAO 8303C 8304#include "implicit.h" 8305#include "priunit.h" 8306#include "ccorb.h" 8307C 8308 DIMENSION KADR1(NBAST),KADR2(NBAST,NBAST) 8309C 8310#include "ccsdsym.h" 8311C 8312 ICOUN1 = 0 8313 DO 100 ISYMG = 1,NSYM 8314C 8315 ISYMAB = MULD2H(ISYMG,ISYDIS) 8316C 8317 DO 110 G = 1,NBAS(ISYMG) 8318 NG = IBAS(ISYMG) + G 8319C 8320 KADR1(NG) = ICOUN1 8321 ICOUN1 = ICOUN1 + NNBST(ISYMAB) 8322C 8323 110 CONTINUE 8324 100 CONTINUE 8325C 8326C 8327 DO 200 ISYMAB = 1,NSYM 8328C 8329 ICOUN2 = 0 8330 DO 210 ISYMB = 1,NSYM 8331C 8332 ISYMA = MULD2H(ISYMB,ISYMAB) 8333C 8334 IF (ISYMB .GT. ISYMA) THEN 8335 8336 DO 220 B = 1,NBAS(ISYMB) 8337 NB = IBAS(ISYMB) + B 8338C 8339 DO 230 A = 1,NBAS(ISYMA) 8340 NA = IBAS(ISYMA) + A 8341C 8342 KADR2(NA,NB) = ICOUN2 8343 KADR2(NB,NA) = ICOUN2 8344C 8345 ICOUN2 = ICOUN2 + 1 8346C 8347 230 CONTINUE 8348 220 CONTINUE 8349C 8350 ELSE IF (ISYMA .EQ. ISYMB) THEN 8351C 8352 DO 240 B = 1,NBAS(ISYMB) 8353 NB = IBAS(ISYMB) + B 8354C 8355 DO 250 A = 1,B 8356 NA = IBAS(ISYMA) + A 8357C 8358 KADR2(NA,NB) = ICOUN2 8359 KADR2(NB,NA) = ICOUN2 8360C 8361 ICOUN2 = ICOUN2 + 1 8362C 8363 250 CONTINUE 8364 240 CONTINUE 8365C 8366 END IF 8367C 8368 210 CONTINUE 8369 200 CONTINUE 8370C 8371 RETURN 8372 END 8373C /* Deck cc2_fck */ 8374 SUBROUTINE CC2_FCK(OMEGA2,T2AM,WORK,LWORK,ISYMTR, 8375 * XLAMDP,XLAMDH,ISIDE) 8376C 8377C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 8378C hko 5-jan-1995 8379C sym debugged 25-1-1995 oc 8380C CC2 finite diff. fix - march 1997 oc 8381C 8382C Purpose: Fock contribution in CC2 model. 8383C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 8384C 8385 USE PELIB_INTERFACE, ONLY: USE_PELIB 8386#include "implicit.h" 8387#include "priunit.h" 8388#include "dummy.h" 8389C 8390 DIMENSION OMEGA2(*),T2AM(*),WORK(LWORK) 8391 DIMENSION XLAMDP(*),XLAMDH(*) 8392 LOGICAL FCKCON,ETRAN 8393C 8394#include "inftap.h" 8395#include "ccorb.h" 8396#include "ccsdsym.h" 8397#include "ccsdinp.h" 8398#include "ccfield.h" 8399#include "leinf.h" 8400#include "ccsections.h" 8401#include "qm3.h" 8402 REAL*8, ALLOCATABLE :: GMATRIX(:), HARTREEFOCK(:) 8403C 8404 INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 8405C 8406C 8407C----------------------- 8408C Memory allocation. 8409C----------------------- 8410C 8411 KSCR1 = 1 8412 KEND = KSCR1 + NORBTS 8413 LWRK = LWORK - KEND 8414C 8415 IF (LWRK .LT. 0) THEN 8416 CALL QUIT('Insufficient space in CC2_FCK') 8417 ENDIF 8418C 8419C------------------------------------- 8420C Read canonical orbital energies. 8421C------------------------------------- 8422C 8423 CALL GPOPEN(LUSIFC,'SIRIFC','UNKNOWN',' ','UNFORMATTED',IDUMMY, 8424 & .FALSE.) 8425 REWIND LUSIFC 8426C 8427 CALL MOLLAB('TRCCINT ',LUSIFC,LUPRI) 8428 READ (LUSIFC) 8429 READ (LUSIFC) (WORK(I), I=1,NORBTS) 8430C 8431 CALL GPCLOSE(LUSIFC,'KEEP') 8432C 8433 IF (FROIMP .OR. FROEXP) 8434 * CALL CCSD_DELFRO(WORK(KSCR1),WORK(KEND),LWRK) 8435C 8436 IF (IPRINT .GT. 80 .OR. DEBUG) THEN 8437 CALL AROUND('CC2_FCK - Orbital energies. ') 8438 write (LUPRI,*) (WORK(I), I=1,NORBT) 8439 CALL AROUND('CC2_FCK - start - : RHO2 ') 8440 CALL CC_PRP(DUMMY,OMEGA2,ISYMTR,0,1) 8441 CALL AROUND('CC2_FCK - start - : T2AM ') 8442 CALL CC_PRSQ(DUMMY,T2AM,ISYMTR,0,1) 8443 ENDIF 8444C 8445C---------------------------- 8446C Calculate contribution. 8447C---------------------------- 8448C 8449 DO 100 ISYMBJ = 1,NSYM 8450C 8451 ISYMAI = MULD2H(ISYMBJ,ISYMTR) 8452C 8453 DO 110 ISYMJ = 1,NSYM 8454C 8455 ISYMB = MULD2H(ISYMJ,ISYMBJ) 8456C 8457 DO 120 ISYMI = 1,NSYM 8458C 8459 ISYMA = MULD2H(ISYMI,ISYMAI) 8460C 8461 DO 130 J = 1,NRHF(ISYMJ) 8462C 8463 MJ = IORB(ISYMJ) + J 8464C 8465 DO 140 B = 1,NVIR(ISYMB) 8466C 8467 NBJ = IT1AM(ISYMB,ISYMJ) 8468 * + NVIR(ISYMB)*(J - 1) + B 8469C 8470 MB = IORB(ISYMB) + NRHF(ISYMB) + B 8471C 8472 DO 150 I = 1,NRHF(ISYMI) 8473C 8474 MI = IORB(ISYMI) + I 8475C 8476 DO 160 A = 1,NVIR(ISYMA) 8477C 8478 NAI = IT1AM(ISYMA,ISYMI) 8479 * + NVIR(ISYMA)*(I - 1) + A 8480C 8481 MA = IORB(ISYMA) + NRHF(ISYMA) + A 8482C 8483 IF (((ISYMAI.EQ.ISYMBJ).AND. 8484 * (NAI .LT. NBJ)).OR.(ISYMBJ.LT.ISYMAI)) 8485 * GOTO 160 8486C 8487 IF (ISYMAI.EQ.ISYMBJ) THEN 8488 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 8489 * + INDEX(NAI,NBJ) 8490 ELSE 8491 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 8492 * + NT1AM(ISYMAI)*(NBJ-1) + NAI 8493 ENDIF 8494C 8495 MAIBJ = IT2SQ(ISYMAI,ISYMBJ) 8496 * + NT1AM(ISYMAI)*(NBJ - 1) + NAI 8497C 8498 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) 8499 * + T2AM(MAIBJ)*(WORK(MA) + WORK(MB) - WORK(MI) - WORK(MJ)) 8500C 8501 160 CONTINUE 8502 150 CONTINUE 8503 140 CONTINUE 8504 130 CONTINUE 8505 120 CONTINUE 8506 110 CONTINUE 8507 100 CONTINUE 8508C 8509 IF (((NFIELD.GT.0).OR.CCSLV.OR.USE_PELIB()) 8510 * .AND.NONHF.AND.(ISIDE.NE.0)) THEN 8511C 8512 KFOCK = 1 8513 KEMAT1 = KFOCK + N2BST(ISYMOP) 8514 KEMAT2 = KEMAT1 + NEMAT1(ISYMOP) 8515 KCC = KEMAT2 + NMATIJ(ISYMOP) 8516 KEND1 = KCC + N2BST(ISYMOP) 8517 LWRK1 = LWORK - KEND1 8518C 8519 CALL DZERO(WORK(KFOCK),N2BST(ISYMOP)) 8520 CALL DZERO(WORK(KEMAT1),NEMAT1(ISYMOP)) 8521 CALL DZERO(WORK(KEMAT2),NMATIJ(ISYMOP)) 8522 DO 13 IF = 1, NFIELD 8523 FF = EFIELD(IF) 8524 CALL CC_ONEP(WORK(KFOCK),WORK(KEND1),LWRK1,FF,1,LFIELD(IF)) 8525 13 CONTINUE 8526C 8527C------------------------------------- 8528C Solvent contribution. 8529C Put into one-electron integrals. 8530C SLV98,OC 8531C------------------------------------- 8532C 8533 IF (CCSLV .AND. (.NOT. CCMM )) THEN 8534 CALL CCSL_RHSTG(WORK(KFOCK),WORK(KEND1),LWRK1) 8535 ENDIF 8536C 8537C 8538C------------------------------------- 8539C Solvent contribution. 8540C Put into one-electron integrals. 8541C CCMM02,JA+AO 8542C------------------------------------- 8543C 8544 IF (CCMM) THEN 8545 IF (.NOT. NYQMMM) THEN 8546 CALL CCMM_RHSTG(WORK(KFOCK),WORK(KEND1),LWRK1) 8547 ELSE IF (NYQMMM .AND. (.NOT. HFFLD)) THEN 8548 !WRITE(LUPRI,*) 'About to add difference density contri' 8549 CALL CCMM_ADDGDIFF(WORK(KFOCK),WORK(KEND1),LWRK1) 8550 ELSE IF (NYQMMM .AND. HFFLD) THEN 8551 ! WRITE(LUPRI,*) 'You are using a hffld so no corr. needed' 8552 CONTINUE 8553 END IF 8554 ENDIF 8555C 8556C 8557C------------------------------------- 8558C Solvent contribution. 8559C Put into one-electron integrals. 8560C PECC16,DH 8561C------------------------------------- 8562C 8563 IF (USE_PELIB().AND.(.NOT.HFFLD)) THEN 8564 ALLOCATE(GMATRIX(NNBASX),HARTREEFOCK(NNBASX)) 8565 CALL GET_FROM_FILE('FOCKMAT',NNBASX,GMATRIX) 8566 CALL GET_FROM_FILE('FOCKMHF',NNBASX,HARTREEFOCK) 8567 CALL DAXPY(NNBASX,-1.0d0,HARTREEFOCK,1,GMATRIX,1) 8568 CALL DSPTSI(NBAS,GMATRIX,WORK(KCC)) 8569 DEALLOCATE(GMATRIX,HARTREEFOCK) 8570 CALL DAXPY(N2BST(ISYMOP),1.0d0,WORK(KCC),1,WORK(KFOCK),1) 8571 END IF 8572C 8573C------------------------------------- 8574C 8575 CALL CC_FCKMO(WORK(KFOCK),XLAMDP,XLAMDH,WORK(KEND1), 8576 * LWRK1,ISYMOP,1,1) 8577 ETRAN = .FALSE. 8578 FCKCON = .TRUE. 8579 ISYMEI = ISYMOP 8580 CALL CCRHS_EFCK(WORK(KEMAT1),WORK(KEMAT2),XLAMDH, 8581 * WORK(KFOCK),WORK(KEND1),LWRK1, 8582 * FCKCON,ETRAN,ISYMEI) 8583C 8584 IF (ISIDE .EQ. -1 ) THEN 8585 CALL CC_EITR(WORK(KEMAT1),WORK(KEMAT2),WORK(KEND1),LWRK1, 8586 * ISYMEI) 8587 ENDIF 8588C 8589 CALL CCRHS_E(OMEGA2,T2AM,WORK(KEMAT1),WORK(KEMAT2), 8590 * WORK(KEND1),LWRK1,ISYMTR,ISYMEI) 8591C 8592 ENDIF 8593C 8594 IF (IPRINT .GT. 80 .OR. DEBUG) THEN 8595 CALL AROUND('CC2_FCK - end - : RHO2 (RHO1=dummy') 8596 CALL CC_PRP(DUMMY,OMEGA2,ISYMTR,0,1) 8597 CALL AROUND('CC2_FCK - end - : T2AM (T1AM=dummy') 8598 CALL CC_PRSQ(DUMMY,T2AM,ISYMTR,0,1) 8599 ENDIF 8600C 8601 RETURN 8602 END 8603C /* Deck ccrhs_efck */ 8604 SUBROUTINE CCRHS_EFCK(EMAT1,EMAT2,XLAMDH,FOCK,WORK,LWORK, 8605 * FCKCON,ETRAN,ISYMEI) 8606C 8607C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 8608C 8609C Transforms E-intermediates to molecular basis and add Fock Matrix. 8610C 8611C Written by Henrik Koch & Ove Christiansen 20-Jan-1994 8612C Symmetry 3-aug HK, Separated from contraction OC 13-2-1995 8613C 8614C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 8615C 8616#include "implicit.h" 8617 PARAMETER (ONE = 1.0D0, TWO = 2.0D0) 8618 DIMENSION EMAT1(*), EMAT2(*) 8619 DIMENSION WORK(LWORK),FOCK(*),XLAMDH(*) 8620#include "priunit.h" 8621#include "ccorb.h" 8622#include "ccsdsym.h" 8623#include "ccsdinp.h" 8624C 8625 LOGICAL FCKCON,ETRAN 8626C 8627C------------------------ 8628C Dynamic allocation. 8629C------------------------ 8630C 8631 KSCR1 = 1 8632 KEND1 = KSCR1 + NMATAB(ISYMEI) 8633 LWRK1 = LWORK - KEND1 8634C 8635 IF (LWRK1 .LT. 0) THEN 8636 WRITE(LUPRI,*) 'Need : ',KEND1,'Available : ',LWORK 8637 CALL QUIT('Insufficient space in CCRHS_E') 8638 ENDIF 8639C 8640C-------------------------------- 8641C Calculate the contribution. 8642C-------------------------------- 8643C 8644 CALL CCRHS_EFCK1(EMAT1,EMAT2,FOCK,WORK(KSCR1),XLAMDH, 8645 * WORK(KEND1),LWRK1,FCKCON,ETRAN,ISYMEI) 8646C 8647 RETURN 8648 END 8649 SUBROUTINE CCRHS_EFCK1(EMAT1,EMAT2,FOCK,SCR1,XLAMDH, 8650 * WORK,LWORK,FCKCON,ETRAN,ISYMEI) 8651C 8652C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 8653C 8654C Transforms E-intermediates to molecular basis and add Fock Matrix. 8655C 8656C Written by Henrik Koch & Ove Christiansen 20-Jan-1994 8657C Symmetry 3-aug HK, Separated from contraction OC 13-2-1995 8658C 8659C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 8660C 8661#include "implicit.h" 8662 PARAMETER(ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) 8663 DIMENSION EMAT1(*),EMAT2(*),SCR1(*) 8664 DIMENSION XLAMDH(*),FOCK(*),WORK(LWORK) 8665#include "priunit.h" 8666#include "ccorb.h" 8667#include "ccsdsym.h" 8668#include "ccsdinp.h" 8669C 8670 LOGICAL FCKCON,ETRAN 8671C 8672C--------------------------------------------- 8673C Transform the delta index of EMAT1 to c. 8674C--------------------------------------------- 8675C 8676 IF ( ETRAN ) THEN 8677 DO 100 ISYMD = 1,NSYM 8678C 8679 ISYMC = ISYMD 8680 ISYMB = MULD2H(ISYMD,ISYMEI) 8681C 8682 NVIRB = MAX(NVIR(ISYMB),1) 8683 NBASD = MAX(NBAS(ISYMD),1) 8684C 8685 KOFF1 = IEMAT1(ISYMB,ISYMD) + 1 8686 KOFF2 = ILMVIR(ISYMD) + 1 8687 KOFF3 = IMATAB(ISYMB,ISYMC) + 1 8688C 8689 CALL DGEMM('N','N',NVIR(ISYMB),NVIR(ISYMC),NBAS(ISYMD), 8690 * ONE,EMAT1(KOFF1),NVIRB,XLAMDH(KOFF2),NBASD, 8691 * ZERO,SCR1(KOFF3),NVIRB) 8692C 8693 100 CONTINUE 8694C 8695 CALL DSCAL(NMATAB(ISYMEI),-ONE,SCR1,1) 8696C 8697 ELSE 8698C 8699 CALL DZERO(SCR1,NMATAB(ISYMEI)) 8700 CALL DZERO(EMAT2,NMATIJ(ISYMEI)) 8701C 8702 ENDIF 8703C 8704C-------------------------------- 8705C Add the Fock contributions. 8706C-------------------------------- 8707C 8708 IF (FCKCON) THEN 8709C 8710 DO 200 ISYMC = 1,NSYM 8711C 8712 ISYMB = MULD2H(ISYMC,ISYMEI) 8713C 8714 DO 210 C = 1,NVIR(ISYMC) 8715C 8716 KOFF1 = IFCVIR(ISYMB,ISYMC) + NORB(ISYMB)*(C - 1) 8717 * + NRHF(ISYMB) + 1 8718 KOFF2 = IMATAB(ISYMB,ISYMC) + NVIR(ISYMB)*(C - 1) + 1 8719C 8720 CALL DAXPY(NVIR(ISYMB),ONE,FOCK(KOFF1),1,SCR1(KOFF2),1) 8721C 8722 210 CONTINUE 8723 200 CONTINUE 8724C 8725 DO 220 ISYMJ = 1,NSYM 8726C 8727 ISYMK = MULD2H(ISYMJ,ISYMEI) 8728C 8729 DO 230 J = 1,NRHF(ISYMJ) 8730C 8731 KOFF1 = IFCRHF(ISYMK,ISYMJ) + NORB(ISYMK)*(J - 1) + 1 8732 KOFF2 = IMATIJ(ISYMK,ISYMJ) + NRHF(ISYMK)*(J - 1) + 1 8733C 8734 CALL DAXPY(NRHF(ISYMK),ONE,FOCK(KOFF1),1,EMAT2(KOFF2),1) 8735C 8736 230 CONTINUE 8737 220 CONTINUE 8738C 8739 ENDIF 8740C 8741C----------------------------------- 8742C Put E1 transformed back in E1. 8743C----------------------------------- 8744C 8745 CALL DCOPY(NMATAB(ISYMEI),SCR1,1,EMAT1,1) 8746C 8747 RETURN 8748 END 8749C /* Deck cc_mofcon */ 8750 SUBROUTINE CC_MOFCON(XINT,OMEGA2,XLAMDP,XLAMDH,XLAMPC,XLAMHC, 8751 * WORK,LWORK,IDEL,ISYMD,ISYMTR,IOPT, 8752 * VIJKL,CC2R12,IANR12,VAJKL,MKVAJKL,TIMR12) 8753C 8754C Written by Asger Halkier and Henrik Koch 3-5-95. 8755C 8756C Debugged By Ove Christiansen 25-7-1995 8757C 8758C Purpose: To calculate the F-term's contribution to the 8759C vector function using matrix vector routines. 8760C 8761C N.B. This routine assumes AO-symmetric integrals, and can therefor 8762C not be used directly for calculations with London-orbitals!!! 8763C 8764#include "implicit.h" 8765#include "maxorb.h" 8766#include "priunit.h" 8767#include "ccorb.h" 8768#include "symsq.h" 8769#include "ccsdsym.h" 8770#include "dummy.h" 8771#include "ccr12int.h" 8772 PARAMETER(ZERO = 0.0D0,ONE = 1.0D0,XMONE=-1.0D0,TWO = 2.0D0) 8773 LOGICAL CC2R12,MKVAJKL,LRES 8774 INTEGER IANR12 8775 DIMENSION XINT(*),OMEGA2(*) 8776 DIMENSION XLAMPC(*),XLAMHC(*),XLAMDH(*),XLAMDP(*) 8777 DIMENSION WORK(LWORK),VIJKL(*),VAJKL(*) 8778 CHARACTER*8 FILBACK 8779C 8780 INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 8781C 8782 call qenter('mofcon') 8783 ISYDIS = MULD2H(ISYMD,ISYMOP) 8784 8785 KEND0 = 1 8786 8787 IF (CC2R12) THEN 8788 KGAIJD = KEND0 8789 KEND0 = KGAIJD + ND2IJG(ISYDIS) 8790 END IF 8791 8792 LWRK0 = LWORK - KEND0 8793C 8794 IF (LWRK0 .LT. 0) THEN 8795 WRITE(LUPRI,*) 'Lwrk0 = ',LWRK0 8796 CALL QUIT('Insufficient work space area in CC_MOFCON') 8797 ENDIF 8798C 8799 DO 100 ISYMG = 1,NSYM 8800C 8801 IF (NBAS(ISYMG) .EQ. 0) GOTO 100 8802C 8803 ISALBE = MULD2H(ISYMG,ISYDIS) 8804 ISYMAI = MULD2H(ISALBE,ISYMTR) 8805 ISYMJ = ISYMG 8806C 8807C----------------------------------------- 8808C Dynamic allocation of work space. 8809C----------------------------------------- 8810C 8811 KSCR1 = KEND0 8812 KSCR2 = KSCR1 + NNBST(ISALBE)*NRHF(ISYMJ) 8813 KSCR3 = KSCR2 + N2BST(ISALBE) 8814 KSCR4 = KSCR3 + NT1AM(ISYMAI) 8815 KEND1 = KSCR4 + NT1AM(ISYMAI) 8816 LWRK1 = LWORK - KEND1 8817C 8818 IF (LWRK1 .LT. 0) THEN 8819 WRITE(LUPRI,*) 'Lwrk1 = ',LWRK1 8820 CALL QUIT('Insufficient work space area in CC_MOFCON') 8821 ENDIF 8822C 8823C-------------------------------- 8824C Do first transformation. 8825C-------------------------------- 8826C 8827 KOFF1 = IDSAOG(ISYMG,ISYDIS) + 1 8828 KOFF2 = ILMRHF(ISYMJ) + 1 8829C 8830 NTALBE = MAX(NNBST(ISALBE),1) 8831 NTOTG = MAX(NBAS(ISYMG),1) 8832C 8833 CALL DGEMM('N','N',NNBST(ISALBE),NRHF(ISYMJ),NBAS(ISYMG), 8834 * ONE,XINT(KOFF1),NTALBE,XLAMDH(KOFF2),NTOTG, 8835 * ZERO,WORK(KSCR1),NTALBE) 8836 8837C--------------------------------------------------------- 8838C compute contributions to V(alpha j,kl) 8839C--------------------------------------------------------- 8840 IF (MKVAJKL .AND. IANR12.EQ.1) THEN 8841 DTIME = SECOND() 8842 IF (NBAS(ISYMG).GT.0 .OR. NRHF(ISYMJ).GT.0) THEN 8843 KGABJD = KSCR1 8844 KSCR5 = KGABJD + NNBST(ISALBE)*NRHF(ISYMJ) 8845 KEND2 = KSCR5 + NBAST*NBAST 8846 LWRK2 = LWORK - KEND2 8847 8848 IF (LWRK2 .LT. 0) THEN 8849 CALL QUIT('Insufficient space in CC_MOFCON') 8850 END IF 8851 8852 KOFF1 = 1 + IDSAOG(ISYMG,ISYDIS) 8853 FILBACK = FNBACK 8854 CALL R12MKVAMKL(FILBACK,WORK(KGABJD),WORK(KGABJD),VAJKL, 8855 & XLAMDH,1,DUMMY,DUMMY,XINT(KOFF1),XINT(KOFF1), 8856 & IDEL,ISYMD,ISYMJ, 8857 & ISALBE,ISYMG,WORK(KSCR5),IDUMMY,IGLMRHS, 8858 & NGLMDS,WORK(KEND2),LWRK2) 8859 END IF 8860 TIMR12 = TIMR12 + (SECOND()-DTIME) 8861 END IF 8862C 8863C----------------------------------- 8864C Last index transformations. 8865C----------------------------------- 8866C 8867 DO 110 J = 1,NRHF(ISYMJ) 8868C 8869 KOFF1 = KSCR1 + NNBST(ISALBE)*(J - 1) 8870C 8871 CALL CCSD_SYMSQ(WORK(KOFF1),ISALBE,WORK(KSCR2)) 8872C 8873 DO 120 ISYMI = 1,NSYM 8874C 8875 ISYMBE = ISYMI 8876 ISYMAL = MULD2H(ISYMBE,ISALBE) 8877 ISYMA = MULD2H(ISYMAL,ISYMTR) 8878C 8879 KSCR5 = KEND1 8880 KEND2 = KSCR5 + NBAS(ISYMAL)*NRHF(ISYMI) 8881 LWRK2 = LWORK - KEND2 8882 IF (LWRK2 .LT. 0) THEN 8883 CALL QUIT('Insufficient space for 2. trf. '// 8884 & 'in CC_MOFCON') 8885 ENDIF 8886C 8887 KOFF2 = KSCR2 + IAODIS(ISYMAL,ISYMBE) 8888 KOFF3 = ILMRHF(ISYMI) + 1 8889 KOFF4 = IGLMVI(ISYMAL,ISYMA) + 1 8890 KOFF5 = KSCR3 + IT1AM(ISYMA,ISYMI) 8891C 8892 NTOTAL = MAX(NBAS(ISYMAL),1) 8893 NTOTBE = MAX(NBAS(ISYMBE),1) 8894 NTOTA = MAX(NVIR(ISYMA),1) 8895C 8896 CALL DGEMM('N','N',NBAS(ISYMAL),NRHF(ISYMI),NBAS(ISYMBE), 8897 * ONE,WORK(KOFF2),NTOTAL,XLAMDH(KOFF3),NTOTBE, 8898 * ZERO,WORK(KSCR5),NTOTAL) 8899C 8900 CALL DGEMM('T','N',NVIR(ISYMA),NRHF(ISYMI),NBAS(ISYMAL), 8901 * ONE,XLAMPC(KOFF4),NTOTAL,WORK(KSCR5),NTOTAL, 8902 * ZERO,WORK(KOFF5),NTOTA) 8903C 8904C ----------------------------------------- 8905C save g(aijd) as three index array 8906C ---------------------------------------- 8907C 8908 IF (CC2R12.AND.IANR12.EQ.1) THEN 8909 DTIME = SECOND() 8910 8911 ISYMIJ = MULD2H(ISYMI,ISYMJ) 8912 DO I = 1, NRHF(ISYMI) 8913 DO A = 1, NBAS(ISYMAL) 8914 IDXAI = NBAS(ISYMAL)*(I-1)+A 8915 IDXIJ = IMATIJ(ISYMI,ISYMJ)+NRHF(ISYMI)*(J-1)+I 8916 IDXAIJ = ID2IJG(ISYMIJ,ISYMAL)+ 8917 & NBAS(ISYMAL)*(IDXIJ-1)+A 8918 WORK(KGAIJD-1+IDXAIJ) = WORK(KSCR5-1+IDXAI) 8919 END DO 8920 END DO 8921 8922 TIMR12 = TIMR12 + (SECOND()-DTIME) 8923 END IF 8924 8925 IF (IOPT .EQ. 2) THEN 8926C 8927 ISYMBE = MULD2H(ISYMI,ISYMTR) 8928 ISYMAL = MULD2H(ISYMBE,ISALBE) 8929 ISYMA = ISYMAL 8930C 8931 IF (LWRK1 .LT. NBAS(ISYMAL)*NRHF(ISYMI)) THEN 8932 CALL QUIT('Insufficient space for 2. '// 8933 & 'trf. in CC_MOFCON') 8934 ENDIF 8935C 8936 KOFF2 = KSCR2 + IAODIS(ISYMAL,ISYMBE) 8937 KOFF3 = IGLMRH(ISYMBE,ISYMI) + 1 8938 KOFF4 = ILMVIR(ISYMA) + 1 8939 KOFF5 = KSCR3 + IT1AM(ISYMA,ISYMI) 8940C 8941 NTOTAL = MAX(NBAS(ISYMAL),1) 8942 NTOTBE = MAX(NBAS(ISYMBE),1) 8943 NTOTA = MAX(NVIR(ISYMA),1) 8944C 8945 CALL DGEMM('N','N',NBAS(ISYMAL),NRHF(ISYMI), 8946 * NBAS(ISYMBE),ONE,WORK(KOFF2),NTOTAL, 8947 * XLAMHC(KOFF3),NTOTBE,ZERO,WORK(KEND1), 8948 * NTOTAL) 8949C 8950 CALL DGEMM('T','N',NVIR(ISYMA),NRHF(ISYMI), 8951 * NBAS(ISYMAL),ONE,XLAMDP(KOFF4),NTOTAL, 8952 * WORK(KEND1),NTOTAL,ONE,WORK(KOFF5),NTOTA) 8953C 8954 ENDIF 8955C 8956 8957 120 CONTINUE 8958C 8959C-------------------------------------------------- 8960C Storing the result in the omega2-array. 8961C-------------------------------------------------- 8962C 8963 ISYMB = ISYMD 8964 ISYMBJ = MULD2H(ISYMB,ISYMJ) 8965C 8966 DO 130 B = 1,NVIR(ISYMB) 8967C 8968 NBJ = IT1AM(ISYMB,ISYMJ) + NVIR(ISYMB)*(J - 1) + B 8969 NDB = ILMVIR(ISYMB) + NBAS(ISYMD)*(B - 1) 8970 * + IDEL - IBAS(ISYMD) 8971C 8972 CALL DZERO(WORK(KSCR4),NT1AM(ISYMAI)) 8973C 8974 XLB = XLAMDP(NDB) 8975C 8976 CALL DAXPY(NT1AM(ISYMAI),XLB,WORK(KSCR3),1,WORK(KSCR4),1) 8977C 8978 IF (ISYMBJ .EQ. ISYMAI) THEN 8979C 8980 NTOTAI = NBJ 8981C 8982 IF (IOPT .EQ. 2) THEN 8983 NTOTAI = NT1AM(ISYMAI) 8984 WORK(KSCR4+NBJ-1) = TWO*WORK(KSCR4+NBJ-1) 8985 ENDIF 8986C 8987 DO 140 NAI = 1,NTOTAI 8988C 8989 NAIBJ = IT2AM(ISYMAI,ISYMBJ) + INDEX(NAI,NBJ) 8990C 8991 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + WORK(KSCR4+NAI-1) 8992C 8993 140 CONTINUE 8994C 8995 ENDIF 8996C 8997 IF (ISYMAI .LT. ISYMBJ) THEN 8998C 8999 DO 150 NAI = 1,NT1AM(ISYMAI) 9000C 9001 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 9002 * + NT1AM(ISYMAI)*(NBJ - 1) + NAI 9003C 9004 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + WORK(KSCR4+NAI-1) 9005C 9006 150 CONTINUE 9007C 9008 ENDIF 9009C 9010 IF ((ISYMBJ .LT. ISYMAI) .AND. (IOPT .EQ. 2)) THEN 9011C 9012 DO 160 NAI = 1,NT1AM(ISYMAI) 9013C 9014 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 9015 * + NT1AM(ISYMBJ)*(NAI - 1) + NBJ 9016C 9017 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + WORK(KSCR4+NAI-1) 9018C 9019 160 CONTINUE 9020C 9021 ENDIF 9022C 9023 130 CONTINUE 9024C 9025 110 CONTINUE 9026C 9027 100 CONTINUE 9028 9029 IF (CC2R12.AND.IANR12.EQ.1) THEN 9030 DTIME = SECOND() 9031 FACTERM23 = ONE 9032 CALL CC_R12MKVKL(WORK(KGAIJD),VIJKL,FACTERM23,XLAMDH,IGLMRH, 9033 & ISYMD, 9034 & ISYMTR,IDEL,IDUMMY,IDUMMY,IDUMMY,IDUMMY, 9035 & IDUMMY,.FALSE., 9036 & WORK(KEND0),LWRK0,FNBACK) 9037 9038 TIMR12 = TIMR12 + (SECOND()-DTIME) 9039 END IF 9040 9041 call qexit('mofcon') 9042 RETURN 9043 END 9044C /* Deck cc_onep */ 9045 SUBROUTINE CC_ONEP(FOCK,WORK,LWRK,FF,ISYMPT,LABPT) 9046C 9047C Ove Christiansen 22-jan-1996. 9048C 9049C PURPOSE: 9050C Read one electron perturbation integrals 9051C into FOCK AO-matrix. 9052C 9053C If ISYMPT is input as -1 CC_ONEP returns 9054C ISYMPT as correct irrep of operator given 9055C by label. This thus assumes that FOCK is allocated 9056C as max dim = n2bst(1). 9057C 9058C Asger Halkier 6/2 - 1995: Fieldstrength now passed to 9059C routine through the variable FF. 9060C 9061#include "implicit.h" 9062#include "priunit.h" 9063#include "maxorb.h" 9064#include "iratdef.h" 9065 LOGICAL LOCDBG, LSYUNK 9066 PARAMETER (LOCDBG = .FALSE.) 9067 DIMENSION FOCK(*),WORK(*) 9068#include "ccorb.h" 9069#include "ccsdinp.h" 9070#include "ccsdsym.h" 9071#include "symsq.h" 9072C 9073 CHARACTER LABPT*(*) 9074C 9075 LSYUNK = .FALSE. 9076 IF (ISYMPT .EQ.-1) THEN 9077 LSYUNK =.TRUE. 9078 ISYMPT = 1 9079 ENDIF 9080C 9081C 9082 IF (IPRINT .GT. 20 ) THEN 9083 DN = DDOT(N2BST(ISYMPT),FOCK,1,FOCK,1) 9084 WRITE(LUPRI,*) 'IN ONEP: FOCK in norm:',DN 9085 ENDIF 9086C 9087 K2 = 1 9088 KEND1 = K2 + N2BST(ISYMPT) 9089 LEND1 = LWRK - KEND1 9090C 9091 IF (LEND1 .LT. 0 )CALL QUIT('Insufficient space in CC_ONEP') 9092C 9093 CALL DZERO(WORK(K2),N2BST(ISYMPT)) 9094 IERR = -1 9095 CALL CCPRPAO(LABPT,.TRUE.,WORK(K2),IRREP,ISYM,IERR, 9096 & WORK(KEND1),LEND1) 9097 IF (IERR.GT.0) THEN 9098 CALL QUIT('CC_ONEP: I/O error while reading operator ' 9099 & //LABPT(1:8)) 9100 ELSE IF (IERR.LT.0) THEN 9101 CALL DZERO(WORK(K2),N2BST(ISYMPT)) 9102 ELSE IF ((IERR.EQ.0 .AND. IRREP.NE.ISYMPT).AND.(.NOT.LSYUNK)) THEN 9103 CALL QUIT('CC_ONEP: symmetry mismatch for operator ' 9104 & //LABPT(1:8)) 9105 END IF 9106C 9107 IF (IPRINT .GT. 50 .OR. LOCDBG) THEN 9108 CALL AROUND( ' In CC_ONEP: one el. pert. integrals') 9109 CALL CC_PRFCKAO(WORK(K2),IRREP) 9110 ENDIF 9111C 9112 IF (LSYUNK) ISYMPT = IRREP 9113C 9114 CALL DAXPY(N2BST(ISYMPT),FF,WORK(K2),1,FOCK,1) 9115C 9116 IF (IPRINT .GT. 50 ) THEN 9117 CALL AROUND( ' In CC_ONEP: Fock AO matrix with oneel. pert') 9118 CALL CC_PRFCKAO(FOCK,ISYMPT) 9119 ENDIF 9120C 9121 IF (IPRINT .GT. 20 ) THEN 9122 DN = DDOT(N2BST(ISYMPT),FOCK,1,FOCK,1) 9123 WRITE(LUPRI,*) 'IN ONEP: FOCK out norm:',DN 9124 ENDIF 9125C 9126 RETURN 9127 END 9128C /* Deck cc_bf */ 9129 SUBROUTINE CC_BF(XINT,OMEGA2,XLAMD1,ISYML1,XLAMD2, 9130 * ISYML2,XLAMD3,ISYML3, 9131 * SCRM,ISYMM1,SCRM2,ISYMM2,WORK,LWORK, 9132 * IDEL,ISYMD,IOPT) 9133C 9134C Written by Henrik Koch 3-Jan-1994 9135C Symmetry by Henrik Koch and Alfredo Sanchez. 18-July-1994 9136C Generalized by Asger Halkier and Henrik Koch 19/9 - 1995 9137C to handle left-hand-side transformation contribution as well. 9138C Righthand generalizations and debugging Ove Christiansen 23-9-1995 9139C 9140C Ove Christiansen 24-9-1996: Generalization for calculating 9141C terms similar to B and F-terms in the transformation 9142C of vectors with the F-matrix. 9143C 9144C 9145C Purpose: Calculate B-term and F-term in the orthonormal basis. 9146C 9147C IOPT equals one for energy-calculations and two or three for 9148C response calculations (2 for left trans. and 3 for right trans.) 9149C IOPT eq. 4 for F*vector contributions. 9150C 9151C XLAMD1 is always a true lamda matrix whereas XLAMD2 9152C is an AO transformed trialvector in the case af a 9153C response calculation. 9154C 9155C 9156C 24-9-1996: 9157C 9158C IF (IOPT .EQ. 1): 9159C scrm is ordinary t2: tci,j(delta) 9160C XLAMD1 and XLAMD2 is ordinary lamda Hole 9161C matrices. 9162C (XLAMD1(gam,i)*XLAMD1(del,j)) 9163C 9164C IF (IOPT .EQ. 2/3) 9165C scrm is left/right vector transformed 9166C to tci,j(delta): vector general symmetry 9167C lambda particle/hole matrix is tot.sym. 9168C XLAMD1 is ordinary lambda particle/hole matrix. 9169C XLAMD2 is transformed (barred) 9170C lambda particle/hole matrix. 9171C (XLAMD1(gam,i)*XLAMD2(del,j) 9172C +XLAMD2(gam,i)*XLAMD1(del,j)) 9173C 9174C IF (IOPT .EQ. 4) 9175C scrm is left/right vector transformed 9176C to tci,j(delta): vector general symmetry 9177C lambda particle matrix is transformed. 9178C 9179C scrm2 is left/right vector transformed 9180C to tci,j(delta): vector general symmetry 9181C lambda particle matrix is tot.sym. ordinary 9182C lambda particle matrixes. 9183C 9184C Total transformed vector to be contracted 9185C with integrals is therefore 9186C 9187C XLAMD1 is an ordinary lambda particle matrix. 9188C XLAMD2 is a double transformed 9189C lambda particle matrix. 9190C (both R1 and L1) 9191C XLAMD3 is R1-transformed lambda particle matrix. 9192C 9193C sum(gam,del)(T(gam-bar,i,j,del)+T(gam,i,j,del-bar) 9194C +3(XLAMD1(del,j)*XLAMD2(gam,i) 9195C +XLAMD1(del,j)*XLAMD2(gam,i))) 9196C 9197C The symmetry input to this routine is somewhat redundant but 9198C hopefully logical and flexible: 9199C Isymm1 is symmetry of SCRM 9200C Isymm2 is symmetry of SCRM2 9201C Isyml1 is symmetry of XLAMD1 9202C Isyml2 is symmetry of XLAMD2 9203C Isyml3 is symmetry of XLAMD3 9204C 9205#include "implicit.h" 9206 PARAMETER(ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, TWO = 2.0D0) 9207 DIMENSION XINT(*),OMEGA2(*),XLAMD1(*),XLAMD2(*),XLAMD3(*) 9208 DIMENSION SCRM(*),SCRM2(*),WORK(LWORK) 9209#include "priunit.h" 9210#include "ccorb.h" 9211#include "ccsdsym.h" 9212C 9213C------------------------ 9214C Dynamic allocation. 9215C------------------------ 9216C 9217 ISYMGD = MULD2H(ISYMM1,ISYML1) 9218C 9219 KMGD = 1 9220 KEND1 = KMGD + NT2BGD(ISYMGD) 9221 LWRK1 = LWORK - KEND1 9222C 9223 IF (LWRK1 .LT. 0) THEN 9224 WRITE(LUPRI,*) 'Need : ',KEND1,'Available : ',LWORK 9225 CALL QUIT('Insufficient space in CC_BF') 9226 ENDIF 9227C 9228C----------------------------- 9229C Prepare the data arrays. 9230C----------------------------- 9231C 9232 DO 100 ISYMJ = 1,NSYM 9233C 9234 ISYMCI = MULD2H(ISYMJ,ISYMM1) 9235C 9236 DO 110 ISYMI = 1,NSYM 9237C 9238 ISYMC = MULD2H(ISYMI,ISYMCI) 9239 ISYMG = MULD2H(ISYMC,ISYML1) 9240 ISYMGI = MULD2H(ISYMG,ISYMI) 9241C 9242 NVIRC = MAX(NVIR(ISYMC),1) 9243 NBASG = MAX(NBAS(ISYMG),1) 9244C 9245 KOFF1 = IGLMVI(ISYMG,ISYMC) + 1 9246C 9247 DO 120 J = 1,NRHF(ISYMJ) 9248C 9249 KOFF2 = IT2BCD(ISYMCI,ISYMJ) + IT1AM(ISYMC,ISYMI) 9250 * + NT1AM(ISYMCI)*(J - 1) + 1 9251 KOFF3 = IT2BGD(ISYMGI,ISYMJ) + IT1AO(ISYMG,ISYMI) 9252 * + NT1AO(ISYMGI)*(J - 1) + 1 9253C 9254 CALL DGEMM('N','N',NBAS(ISYMG),NRHF(ISYMI),NVIR(ISYMC), 9255 * ONE,XLAMD1(KOFF1),NBASG,SCRM(KOFF2),NVIRC, 9256 * ZERO,WORK(KOFF3),NBASG) 9257C 9258 120 CONTINUE 9259C 9260 110 CONTINUE 9261C 9262 100 CONTINUE 9263C 9264C--------------------------------------------------------- 9265C Calculate extra contribution to T2 double AO transf. 9266C if F-matrix transformation. 9267C--------------------------------------------------------- 9268C 9269 IF (IOPT .EQ. 4) THEN 9270C 9271 IF (MULD2H(ISYML3,ISYMM2).NE.ISYMGD) THEN 9272 CALL QUIT('CC_BF: Symmetry mismatch') 9273 ENDIF 9274 DO 200 ISYMJ = 1,NSYM 9275C 9276 ISYMCI = MULD2H(ISYMJ,ISYMM2) 9277C 9278 DO 210 ISYMI = 1,NSYM 9279C 9280 ISYMC = MULD2H(ISYMI,ISYMCI) 9281 ISYMG = MULD2H(ISYMC,ISYML3) 9282 ISYMGI = MULD2H(ISYMG,ISYMI) 9283C 9284 NVIRC = MAX(NVIR(ISYMC),1) 9285 NBASG = MAX(NBAS(ISYMG),1) 9286C 9287 KOFF1 = IGLMVI(ISYMG,ISYMC) + 1 9288C 9289 DO 220 J = 1,NRHF(ISYMJ) 9290C 9291 KOFF2 = IT2BCD(ISYMCI,ISYMJ) + IT1AM(ISYMC,ISYMI) 9292 * + NT1AM(ISYMCI)*(J - 1) + 1 9293 KOFF3 = IT2BGD(ISYMGI,ISYMJ) + IT1AO(ISYMG,ISYMI) 9294 * + NT1AO(ISYMGI)*(J - 1) + 1 9295C 9296 CALL DGEMM('N','N',NBAS(ISYMG),NRHF(ISYMI),NVIR(ISYMC) 9297 * ,ONE,XLAMD3(KOFF1),NBASG,SCRM2(KOFF2),NVIRC, 9298 * ONE,WORK(KOFF3),NBASG) 9299C 9300 220 CONTINUE 9301C 9302 210 CONTINUE 9303C 9304 200 CONTINUE 9305C 9306 ENDIF 9307C 9308C-------------------------------- 9309C Calculate the contribution. 9310C-------------------------------- 9311C 9312 CALL CC_BF1(XINT,OMEGA2,WORK(KMGD),ISYMGD,XLAMD1,ISYML1, 9313 * XLAMD2,ISYML2,WORK(KEND1),LWRK1, 9314 * IDEL,ISYMD,IOPT) 9315C 9316 RETURN 9317 END 9318C /* Deck cc_bf1 */ 9319 SUBROUTINE CC_BF1(XINT,OMEGA2,XMGD,ISYMGD,XLAMD1,ISYML1, 9320 * XLAMD2,ISYML2,WORK,LWORK, 9321 * IDEL,ISYMD,IOPT) 9322C 9323C Written by Henrik Koch 3-Jan-1994 9324C 9325C Purpose: Calculate B-term. 9326C 9327C See CC_BF( for more info. 9328C 9329#include "implicit.h" 9330#include "priunit.h" 9331#include "iratdef.h" 9332 PARAMETER(ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0) 9333 PARAMETER(FOURTH = 0.25D0, TWO = 2.0D0, THREE = 3.0D0) 9334 DIMENSION XINT(*),OMEGA2(*),XMGD(*),XLAMD1(*),XLAMD2(*) 9335 DIMENSION WORK(LWORK) 9336#include "ccorb.h" 9337#include "ccsdsym.h" 9338#include "ccsdinp.h" 9339C 9340 INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J 9341C 9342 ISYDIS = MULD2H(ISYMOP,ISYMD) 9343 ISYRES = MULD2H(ISYDIS,ISYMGD) 9344 ISYCH = MULD2H(ISYML2,ISYMD) 9345C 9346 IF (ISYML1 .NE. 1) CALL QUIT('CC_BF: Symmetry of '// 9347 & 'XLAMD1 must be 1') 9348 IF (ISYML2 .NE. MULD2H(ISYMGD,ISYMD)) 9349 * CALL QUIT('Symmetry mismatch in CC_BF1') 9350C 9351C================================ 9352C Calculate the contribution. 9353C================================ 9354C 9355 DO 100 ISYMIJ = 1,NSYM 9356C 9357 ISYMAB = MULD2H(ISYMIJ,ISYRES) 9358 ISYMG = MULD2H(ISYMAB,ISYDIS) 9359 D = IDEL - IBAS(ISYMD) 9360C 9361 KSCRAB = 1 9362 KINDV1 = KSCRAB + N2BST(ISYMAB) 9363 KINDV2 = KINDV1 + (NNBST(ISYMAB) - 1)/IRAT + 1 9364 KEND1 = KINDV2 + (NNBST(ISYMAB) - 1)/IRAT + 1 9365 LWRK1 = LWORK - KEND1 9366C 9367 IF (LWRK1 .LT. 0) THEN 9368 CALL QUIT('Insufficient space in CC_BF1') 9369 ENDIF 9370C 9371C-------------------------------- 9372C Calculate index vectors. 9373C-------------------------------- 9374C 9375 CALL CCSD_INDEX(WORK(KINDV1),WORK(KINDV2),ISYMAB) 9376C 9377C------------------------------ 9378C Work space allocation. 9379C------------------------------ 9380C 9381 NSIZE = 2*(NNBST(ISYMAB) + NMIJP(ISYMIJ)) 9382C 9383 IF ((NNBST(ISYMAB) .EQ. 0) .OR. 9384 * (NMIJP(ISYMIJ) .EQ. 0)) GOTO 100 9385C 9386 IF (ISYMG .EQ. ISYMD) THEN 9387 IMAXG = D 9388 ELSE IF (ISYMG .LT. ISYMD) THEN 9389 IMAXG = NBAS(ISYMG) 9390 ELSE 9391 GOTO 100 9392 ENDIF 9393C 9394 IF (IMAXG.EQ.0) GOTO 100 9395C 9396 IF (LWRK1.LT.NSIZE) THEN 9397 CALL QUIT('Insufficient memory in CC_BF1.') 9398 END IF 9399C 9400 NMAXG = MIN(IMAXG,LWRK1/NSIZE) 9401 NBATCH = (IMAXG - 1)/NMAXG + 1 9402C 9403 DO 110 IBATCH = 1,NBATCH 9404C 9405 NUMG = NMAXG 9406 IF (IBATCH .EQ. NBATCH) THEN 9407 NUMG = IMAXG - NMAXG*(NBATCH - 1) 9408 ENDIF 9409C 9410 IG1 = NMAXG*(IBATCH - 1) + 1 9411 IG2 = NMAXG*(IBATCH - 1) + NUMG 9412C 9413 KINTP = KEND1 9414 KINTM = KINTP + NNBST(ISYMAB)*NUMG 9415 KT2MP = KINTM + NNBST(ISYMAB)*NUMG 9416 KT2MM = KT2MP + NUMG*NMIJP(ISYMIJ) 9417 KEND2 = KT2MM + NUMG*NMIJP(ISYMIJ) 9418 LWRK2 = LWORK - KEND2 9419C 9420 IF (LWRK2 .LT. 0) THEN 9421 CALL QUIT('Insufficient space in CC_BF1') 9422 ENDIF 9423C 9424C----------------------------------- 9425C Construct T2MP and T2MM. 9426C----------------------------------- 9427C 9428 DO 200 ISYMJ = 1,NSYM 9429C 9430 ISYMI = MULD2H(ISYMJ,ISYMIJ) 9431 ISYMGI = MULD2H(ISYMI,ISYMG) 9432 ISYMGJ = MULD2H(ISYMJ,ISYMG) 9433C 9434 IF (ISYMI .GT. ISYMJ) GOTO 200 9435C 9436 NTOTI = NRHF(ISYMI) 9437C 9438 DO 210 J = 1,NRHF(ISYMJ) 9439C 9440 IF (ISYMI .EQ. ISYMJ) NTOTI = J 9441C 9442 DO 220 I = 1,NTOTI 9443C 9444 NGIJ = IT2BGD(ISYMGI,ISYMJ) 9445 * + NT1AO(ISYMGI)*(J - 1) 9446 * + IT1AO(ISYMG,ISYMI) 9447 * + NBAS(ISYMG)*(I - 1) + IG1 9448C 9449 NGJI = IT2BGD(ISYMGJ,ISYMI) 9450 * + NT1AO(ISYMGJ)*(I - 1) 9451 * + IT1AO(ISYMG,ISYMJ) 9452 * + NBAS(ISYMG)*(J - 1) + IG1 9453C 9454 IF (ISYMI .EQ. ISYMJ) THEN 9455 NIJ = IMIJP(ISYMI,ISYMJ) + INDEX(I,J) 9456 ELSE 9457 NIJ = IMIJP(ISYMI,ISYMJ) 9458 * + NRHF(ISYMI)*(J - 1) + I 9459 ENDIF 9460C 9461 NGIJPM = NUMG*(NIJ - 1) 9462C 9463 KOFFP = KT2MP + NGIJPM 9464 KOFFM = KT2MM + NGIJPM 9465C 9466 IF (CC2) THEN 9467 CALL DZERO(WORK(KOFFP),NUMG) 9468 CALL DZERO(WORK(KOFFM),NUMG) 9469 ELSE 9470 CALL DCOPY(NUMG,XMGD(NGIJ),1,WORK(KOFFP),1) 9471 CALL DCOPY(NUMG,XMGD(NGIJ),1,WORK(KOFFM),1) 9472C 9473 CALL DAXPY(NUMG,ONE,XMGD(NGJI),1,WORK(KOFFP),1) 9474 CALL DAXPY(NUMG,-ONE,XMGD(NGJI),1,WORK(KOFFM),1) 9475 ENDIF 9476C 9477C------------------------------------------------- 9478C Add the F-term contributions. 9479C------------------------------------------------- 9480C 9481 FACT = ONE 9482C 9483 IF ((IOPT .EQ. 2) .OR. (IOPT .EQ. 4)) THEN 9484 FACT = THREE 9485 ENDIF 9486C 9487 IF ((ISYMJ .EQ. ISYCH).AND.(ISYMI .EQ. ISYMG)) THEN 9488C 9489 KOFF1 = IGLMRH(ISYMD,ISYMJ) 9490 & + NBAS(ISYMD)*(J - 1) + D 9491 KOFF2 = ILMRHF(ISYMI) + NBAS(ISYMG)*(I - 1) +IG1 9492C 9493 CALL DAXPY(NUMG,XLAMD2(KOFF1),XLAMD1(KOFF2),1, 9494 * WORK(KOFFP),1) 9495 CALL DAXPY(NUMG,FACT*XLAMD2(KOFF1), 9496 * XLAMD1(KOFF2),1,WORK(KOFFM),1) 9497C 9498 ENDIF 9499C 9500 IF ((ISYMI .EQ. ISYCH).AND.(ISYMJ .EQ. ISYMG)) THEN 9501C 9502 KOFF1 = IGLMRH(ISYMD,ISYMI) 9503 & + NBAS(ISYMD)*(I - 1) + D 9504 KOFF2 = ILMRHF(ISYMJ) + NBAS(ISYMG)*(J - 1) +IG1 9505C 9506 CALL DAXPY(NUMG,XLAMD2(KOFF1),XLAMD1(KOFF2),1, 9507 * WORK(KOFFP),1) 9508 CALL DAXPY(NUMG,-FACT*XLAMD2(KOFF1), 9509 * XLAMD1(KOFF2),1,WORK(KOFFM),1) 9510C 9511 ENDIF 9512C 9513C--------------------------------------------------------------- 9514C For response calculation add permuted terms. 9515C--------------------------------------------------------------- 9516C 9517 IF (IOPT .GE. 2) THEN 9518C 9519 ISHELP = MULD2H(ISYMG,ISYML2) 9520C 9521 IF ((IOPT .EQ. 2) .OR. (IOPT .EQ. 4)) THEN 9522 FACT = THREE 9523 ENDIF 9524C 9525 IF ((ISYMJ .EQ. ISYMD) .AND. 9526 & (ISYMI .EQ. ISHELP)) THEN 9527C 9528 KOFF1 = ILMRHF(ISYMJ) 9529 & + NBAS(ISYMD)*(J - 1) + D 9530 KOFF2 = IGLMRH(ISYMG,ISYMI) 9531 & + NBAS(ISYMG)*(I - 1) +IG1 9532C 9533 CALL DAXPY(NUMG,XLAMD1(KOFF1), 9534 & XLAMD2(KOFF2),1,WORK(KOFFP),1) 9535 CALL DAXPY(NUMG,FACT*XLAMD1(KOFF1), 9536 & XLAMD2(KOFF2),1,WORK(KOFFM),1) 9537C 9538 ENDIF 9539C 9540 IF ((ISYMI .EQ. ISYMD) .AND. 9541 & (ISYMJ .EQ. ISHELP)) THEN 9542C 9543 KOFF1 = ILMRHF(ISYMI) 9544 & + NBAS(ISYMD)*(I - 1) + D 9545 KOFF2 = IGLMRH(ISYMG,ISYMJ) 9546 & + NBAS(ISYMG)*(J - 1) + IG1 9547C 9548 CALL DAXPY(NUMG,XLAMD1(KOFF1), 9549 & XLAMD2(KOFF2),1,WORK(KOFFP),1) 9550 CALL DAXPY(NUMG,-FACT*XLAMD1(KOFF1), 9551 & XLAMD2(KOFF2),1,WORK(KOFFM),1) 9552C 9553 ENDIF 9554C 9555 ENDIF 9556C 9557 220 CONTINUE 9558C 9559 210 CONTINUE 9560C 9561 200 CONTINUE 9562C 9563C----------------------------------- 9564C Construct INTP and INTM. 9565C----------------------------------- 9566C 9567 CALL CCRHS_IPM(XINT,WORK(KINTP),WORK(KINTM),WORK(KSCRAB), 9568 * WORK(KINDV1),WORK(KINDV2),ISYMAB,ISYMG, 9569 * NUMG,IG1,IG2) 9570C 9571C------------------------------- 9572C Scale the diagonals. 9573C------------------------------- 9574C 9575 IF ((ISYMG .EQ. ISYMD) .AND. (IBATCH .EQ. NBATCH)) THEN 9576 KOFF = KINTP + NNBST(ISYMAB)*(NUMG - 1) 9577 CALL DSCAL(NNBST(ISYMAB),HALF,WORK(KOFF),1) 9578 ENDIF 9579C 9580C---------------------------------------- 9581C Add the B-term contributions. 9582C---------------------------------------- 9583C 9584 NUMGM = MAX(NUMG,1) 9585 NTOTAB = MAX(NNBST(ISYMAB),1) 9586C 9587 KOFF1 = IT2ORT(ISYMAB,ISYMIJ) + 1 9588C 9589 CALL DGEMM('N','N',NNBST(ISYMAB),NMIJP(ISYMIJ),NUMG, 9590 * ONE,WORK(KINTP),NTOTAB,WORK(KT2MP),NUMGM, 9591 * ONE,OMEGA2(KOFF1),NTOTAB) 9592C 9593 KOFF2 = NT2ORT(ISYRES) + IT2ORT(ISYMAB,ISYMIJ) + 1 9594C 9595 CALL DGEMM('N','N',NNBST(ISYMAB),NMIJP(ISYMIJ),NUMG, 9596 * ONE,WORK(KINTM),NTOTAB,WORK(KT2MM),NUMGM, 9597 * ONE,OMEGA2(KOFF2),NTOTAB) 9598C 9599 110 CONTINUE 9600C 9601 100 CONTINUE 9602C 9603 RETURN 9604 END 9605