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 cc3_omeg3 */ 20 SUBROUTINE CC3_OMEG3(ECURR,OMEGA1,OMEGA2P,OMEGA2M,T1AM,ISYMT1, 21 * T2TP,ISYMT2,FOCK,XLAMDP,XLAMDH,WORK,LWORK, 22 * LU3SRT,FN3SRT,LUTOC,FNTOC,LUCKJD,FNCKJD) 23C 24C Routine to calculate triplet excitation 25C energies for triple methods. 26C Kasper Hald Jan. 2001. 27C 28C Based on cc3_omeg by: 29C Henrik Koch and Alfredo Sanchez. Dec 1994 30C Ove Christiansen Jan. 1996: 31C 32C 33 IMPLICIT NONE 34C 35#include "iratdef.h" 36#include "dummy.h" 37#include "inftap.h" 38#include "priunit.h" 39#include "ccinftap.h" 40#include "ccorb.h" 41#include "ccsdinp.h" 42#include "ccsdsym.h" 43#include "second.h" 44C 45 INTEGER LWORK, ISYMTR, ISYMT1, ISYMT2, ISYRES, ISINT1, ISINT2 46 INTEGER ISYMIM, KEND0, LWRK0, KEND1, LWRK1, KEND2, LWRK2 47 INTEGER KEND3, LWRK3, KEND4, LWRK4, KOFF1, KOFF2 48 INTEGER KFOCKD, KCMO, KFCKAK, KTROC, KTROC1, KTROC0 49 INTEGER KSMAT, KQMAT, KDIAG, KINDSQ, KINDEX, KTMAT, KRMAT1, KRMAT2 50 INTEGER KRMAT3, KRMAT4, KXIAJB, KINTVI, KINTOC, KTRVI, KTRVI0 51 INTEGER KTRVI1, KTRVI2, KTRVI3, KTRVI4, KTRVI5, KTRVI6, KTRVI7 52 INTEGER ISYMC, ISYMK, IOPT, IOFF, ISYOPE, LENGTH, LENSQ 53 INTEGER ISYMB, ISYALJ, ISAIJ2, ISYMBD, ISCKIJ, ISAIJ1 54 INTEGER ISYMD, ISYCKB, ISCKB1, ISCKB2, LU3SRT, LUTOC, LUCKJD 55 INTEGER LUDELD, LUDKBC 56! 57#if defined (SYS_CRAY) 58 REAL OMEGA1(*),OMEGA2P(*),OMEGA2M(*),T1AM(*),T2TP(*) 59 REAL FOCK(*),XLAMDP(*),XLAMDH(*),WORK(LWORK) 60 REAL XT2TP, XIAJB, XINT, XTROC, XTROC0, XTROC1 61 REAL XTRVI0, XTRVI, XTRVI1, XTRVI2, XTRVI3 62 REAL XFD, XDIA, XSMAT, XQMAT, XTMAT, XRMAT, RHO1N 63 REAL RHO2N, ECURR 64 REAL DTIME, TITRAN, TISORT, TISMAT, TIQMAT 65 REAL TIOME1, TICONV, TICONO, DDOT, XMONE, ONE, MFACTOR 66#else 67 DOUBLE PRECISION OMEGA1(*),OMEGA2P(*),OMEGA2M(*),T1AM(*),T2TP(*) 68 DOUBLE PRECISION FOCK(*),XLAMDP(*),XLAMDH(*),WORK(LWORK) 69 DOUBLE PRECISION XT2TP, XIAJB, XINT, XTROC, XTROC0, XTROC1 70 DOUBLE PRECISION XTRVI0, XTRVI, XTRVI1, XTRVI2, XTRVI3 71 DOUBLE PRECISION XFD, XDIA, XSMAT, XQMAT, XTMAT, XRMAT, RHO1N 72 DOUBLE PRECISION RHO2N, ECURR 73 DOUBLE PRECISION DTIME, TITRAN, TISORT, TISMAT, TIQMAT 74 DOUBLE PRECISION TIOME1, TICONV, TICONO, DDOT, XMONE, ONE, MFACTOR 75#endif 76 PARAMETER (XMONE = -1.0D0, ONE = 1.0D0) 77C 78 CHARACTER*(*) FN3SRT, FNTOC, FNCKJD 79 CHARACTER*11 FNDELD, FNDKBC 80 CHARACTER CDUMMY*1 81C 82 CALL QENTER('CC3_OMEG3') 83C 84C------------------------------------------------------------- 85C Set symmetry flags. 86C 87C omega = int1*T2*int2 88C isymres is symmetry of result(omega) 89C isint1 is symmetry of integrals in contraction.(int1) 90C isint2 is symmetry of integrals in the triples equation.(int2) 91C isymim is symmetry of S and Q intermediates.(t2*int2) 92C (sym is for all index of S and Q (cbd,klj) 93C thus cklj=b*d*isymim) 94C------------------------------------------------------------- 95C 96 CDUMMY = ' ' 97C 98 IPRCC = IPRINT 99 ISYMTR = MULD2H(ISYMT1,ISYMT2) 100 ISYRES = MULD2H(ISYMTR,ISYMOP) 101 ISINT1 = MULD2H(ISYMT1,ISYMOP) 102 ISINT2 = ISYMOP 103 ISYMIM = ISYMOP 104C 105 IF (IPRINT .GT. 20 ) THEN 106 WRITE(LUPRI,*) ' In CC3_OMEG3: CC1A = ',CC1A 107 WRITE(LUPRI,*) ' In CC3_OMEG3: CC1B = ',CC1B 108 WRITE(LUPRI,*) ' In CC3_OMEG3: CC3 = ',CC3 109 WRITE(LUPRI,*) ' In CC3_OMEG3: CC3LR = ',CC3LR 110 WRITE(LUPRI,*) ' In CC3_OMEG3: ISYMT1, ISYMT2:',ISYMT1,ISYMT2 111 WRITE(LUPRI,*) ' In CC3_OMEG3: ISYRES, ISYMOP:',ISYRES,ISYMOP 112 WRITE(LUPRI,*) ' In CC3_OMEG3: ISINT1, ISINT2:',ISINT1,ISINT2 113 ENDIF 114C 115C-------------------- 116C Time variables. 117C-------------------- 118C 119 TITRAN = 0.0D0 120 TISORT = 0.0D0 121 TISMAT = 0.0D0 122 TIQMAT = 0.0D0 123 TICONV = 0.0D0 124 TICONO = 0.0D0 125 TIOME1 = 0.0D0 126C 127C--------------------------- 128C Open files 129C--------------------------- 130C 131 LUDELD = -1 132 LUDKBC = -1 133 FNDELD = 'CC3_OMEG3_1' 134 FNDKBC = 'CC3_OMEG3_2' 135 CALL WOPEN2(LUDELD,FNDELD,64,0) 136 CALL WOPEN2(LUDKBC,FNDKBC,64,0) 137C 138C--------------------------------------------------------- 139C Transform and sort qmat integrals to smat integrals. 140C--------------------------------------------------------- 141C 142 CALL CC3_SORT1(WORK,LWORK,2,ISINT2,LU3SRT,FN3SRT,LUDELD,FNDELD, 143 * IDUMMY,CDUMMY,IDUMMY,CDUMMY,IDUMMY,CDUMMY) 144 CALL CC3_SINT(XLAMDH,WORK,LWORK,ISINT2,LUDELD,FNDELD, 145 * LUDKBC,FNDKBC) 146C 147C-------------------------------------- 148C Reorder the t2-amplitudes i T2TP. 149C-------------------------------------- 150C 151 IF (LWORK .LT. NT2SQ(ISYMT2)) THEN 152 CALL QUIT('Not enough memory to construct T2TP in CC3_OMEG3') 153 ENDIF 154C 155 CALL DCOPY(NT2SQ(ISYMT2),T2TP,1,WORK,1) 156 CALL CC3_T2TP(T2TP,WORK,ISYMT2) 157C 158 IF (IPRINT .GT. 55) THEN 159 XT2TP = DDOT(NT2SQ(ISYMT2),T2TP,1,T2TP,1) 160 WRITE(LUPRI,*) 'Norm of T2TP ',XT2TP 161 ENDIF 162C 163C--------------------------------------------------------- 164C Read canonical orbital energies and MO coefficients. 165C--------------------------------------------------------- 166C 167 KFOCKD = 1 168 KCMO = KFOCKD + NORBTS 169 KFCKAK = KCMO + NLAMDS 170 KEND0 = KFCKAK + NT1AM(ISINT1) 171 LWRK0 = LWORK - KEND0 172C 173 IF (LWRK0 .LT. 0) THEN 174 WRITE(LUPRI,*) 'Memory available : ',LWORK 175 WRITE(LUPRI,*) 'Memory needed : ',KEND0 176 CALL QUIT('Insufficient space in CC3_OMEG3') 177 END IF 178C 179 CALL GPOPEN(LUSIFC,'SIRIFC','OLD',' ','UNFORMATTED',IDUMMY, 180 & .FALSE.) 181 REWIND LUSIFC 182C 183 CALL MOLLAB('TRCCINT ',LUSIFC,LUPRI) 184 READ (LUSIFC) 185 READ (LUSIFC) (WORK(KFOCKD+I-1), I=1,NORBTS) 186 READ (LUSIFC) (WORK(KCMO+I-1), I=1,NLAMDS) 187C 188 CALL GPCLOSE(LUSIFC,'KEEP') 189C 190 CALL CMO_REORDER(WORK(KCMO),WORK(KEND0),LWRK0) 191C 192C--------------------------------------------- 193C Delete frozen orbitals in Fock diagonal. 194C--------------------------------------------- 195C 196 IF (FROIMP .OR. FROEXP) 197 * CALL CCSD_DELFRO(WORK(KFOCKD),WORK(KEND0),LWRK0) 198C 199C----------------------------- 200C Read occupied integrals. 201C----------------------------- 202C 203C Memory allocation. 204C 205 KTROC = KEND0 206 KTROC1 = KTROC + NTRAOC(ISINT1) 207 KTROC0 = KTROC1 + NTRAOC(ISINT1) 208 KXIAJB = KTROC0 + NTRAOC(ISINT2) 209 KEND1 = KXIAJB + NT2AM(ISYMOP) 210 LWRK1 = LWORK - KEND1 211C 212 KINTOC = KEND1 213 KEND2 = KINTOC + MAX(NTOTOC(ISYMOP),NTOTOC(ISINT2)) 214 LWRK2 = LWORK - KEND2 215C 216 IF (LWRK2 .LT. 0) THEN 217 WRITE(LUPRI,*) 'Memory available : ',LWORK 218 WRITE(LUPRI,*) 'Memory needed : ',KEND2 219 CALL QUIT('Insufficient space in CC3_OMEG3') 220 END IF 221C 222C----------------------------------------- 223C Calculate Fock matrix used in CC3LR. 224C----------------------------------------- 225C 226 LENGTH = IRAT*NT2AM(ISYMOP) 227C 228 REWIND(LUIAJB) 229 CALL READI(LUIAJB,LENGTH,WORK(KXIAJB)) 230C 231 ISYOPE = ISYMOP 232 IOPT = 2 233 CALL CCSD_TCMEPK(WORK(KXIAJB),1.0D0,ISYOPE,IOPT) 234C 235 CALL CC3LR_MFOCK(WORK(KFCKAK),T1AM,WORK(KXIAJB),ISYMT1) 236C 237 IF (IPRINT .GT. 55) THEN 238 XFD = DDOT(NT1AM(ISINT1),WORK(KFCKAK),1, 239 * WORK(KFCKAK),1) 240 WRITE(LUPRI,*) 'Norm of MFOCK',XFD 241 ENDIF 242C 243C 244C------------------------ 245C Construct L(ia,jb). 246C------------------------ 247C 248 LENGTH = IRAT*NT2AM(ISYMOP) 249C 250 REWIND(LUIAJB) 251 CALL READI(LUIAJB,LENGTH,WORK(KXIAJB)) 252C 253 IF ( IPRINT .GT. 55) THEN 254 XIAJB = DDOT(NT2AM(ISYMOP),WORK(KXIAJB),1, 255 * WORK(KXIAJB),1) 256 WRITE(LUPRI,*) 'Norm of IAJB ',XIAJB 257 ENDIF 258C 259C------------------------ 260C Occupied integrals. 261C------------------------ 262C 263 IOFF = 1 264 IF (NTOTOC(ISYMOP) .GT. 0) THEN 265 CALL GETWA2(LUTOC,FNTOC,WORK(KINTOC),IOFF,NTOTOC(ISYMOP)) 266 ENDIF 267C 268C---------------------------------- 269C Write out norms of Integrals. 270C---------------------------------- 271C 272 IF (IPRINT .GT. 55) THEN 273 XINT = DDOT(NTOTOC(ISYMOP),WORK(KINTOC),1, 274 * WORK(KINTOC),1) 275 WRITE(LUPRI,*) 'Norm of CCSDT_OC-INT ',XINT 276 ENDIF 277C 278C---------------------------------------------------------------------- 279C Transform (ia|j delta) integrals to (ia|j k) and sort as (ij,k,a) 280C---------------------------------------------------------------------- 281C 282 DTIME = SECOND() 283C 284 CALL DZERO(WORK(KTROC),NTRAOC(ISINT1)) 285 CALL CC3LR_QINT(WORK(KTROC),T1AM,WORK(KXIAJB),WORK(KEND2), 286 * LWRK2,ISYMT1) 287C 288 IF (IPRINT .GT. 55) THEN 289 XTROC = DDOT(NTRAOC(ISINT1),WORK(KTROC),1, 290 * WORK(KTROC),1) 291 WRITE(LUPRI,*) 'Norm of TROC after QINT',XTROC 292 ENDIF 293C 294 IF (LWRK2 .LT. NTRAOC(ISINT1)) THEN 295 CALL QUIT('Insufficient space in CC3_OMEG3') 296 END IF 297C 298 CALL CCSDT_SRTOCC(WORK(KTROC),WORK(KEND2),ISINT1) 299 CALL DCOPY(NTRAOC(ISINT1),WORK(KEND2),1,WORK(KTROC),1) 300C 301C----------------------- 302C Read in integrals. 303C----------------------- 304C 305 IOFF = 1 306 IF (NTOTOC(ISINT2) .GT. 0) THEN 307 CALL GETWA2(LUCKJD,FNCKJD,WORK(KINTOC),IOFF,NTOTOC(ISINT2)) 308 ENDIF 309C 310C---------------------------------------------------------------------- 311C Transform (ia|j delta) integrals to (ia|j k) and sort as (ij,k,a) 312C---------------------------------------------------------------------- 313C 314 CALL CC3_TROCC(WORK(KINTOC),WORK(KTROC0),WORK(KCMO), 315 * WORK(KEND2),LWRK2,ISINT2) 316C 317 DTIME = SECOND() - DTIME 318 TITRAN = TITRAN + DTIME 319 320C 321 DTIME = SECOND() 322C 323 CALL CCSDT_SRTOC2(WORK(KTROC),WORK(KTROC1),ISINT1, 324 * WORK(KEND2),LWRK2) 325C 326 DTIME = SECOND() - DTIME 327 TISORT = TISORT + DTIME 328C 329C------------------------------- 330C Write out norms of arrays. 331C------------------------------- 332C 333 IF (IPRINT .GT. 55) THEN 334 XTROC = DDOT(NTRAOC(ISINT1),WORK(KTROC),1, 335 * WORK(KTROC),1) 336 WRITE(LUPRI,*) 'Norm of TROC ',XTROC 337 ENDIF 338C 339 IF (IPRINT .GT. 55) THEN 340 XINT = DDOT(NTOTOC(ISINT2),WORK(KINTOC),1, 341 * WORK(KINTOC),1) 342 WRITE(LUPRI,*) 'Norm of CKJDEL-INT ',XINT 343 ENDIF 344C 345 IF (IPRINT .GT. 55) THEN 346 XTROC1 = DDOT(NTRAOC(ISINT1),WORK(KTROC1),1, 347 * WORK(KTROC1),1) 348 WRITE(LUPRI,*) 'Norm of TROC1 ',XTROC1 349 ENDIF 350C 351 IF (IPRINT .GT. 55) THEN 352 XTROC0 = DDOT(NTRAOC(ISINT2),WORK(KTROC0),1, 353 * WORK(KTROC0),1) 354 WRITE(LUPRI,*) 'Norm of TROC0 ',XTROC0 355 ENDIF 356C 357C---------------------------- 358C General loop structure. 359C---------------------------- 360C 361 DO 100 ISYMD = 1,NSYM 362C 363 ISAIJ1 = MULD2H(ISYMD,ISYRES) 364 ISYCKB = MULD2H(ISYMD,ISYMOP) 365 ISCKB1 = MULD2H(ISINT1,ISYMD) 366 ISCKB2 = MULD2H(ISINT2,ISYMD) 367C 368 IF (IPRINT .GT. 55) THEN 369C 370 WRITE(LUPRI,*) 'In CC3_OMEG3: ISAIJ1:',ISAIJ1 371 WRITE(LUPRI,*) 'In CC3_OMEG3: ISYCKB:',ISYCKB 372 WRITE(LUPRI,*) 'In CC3_OMEG3: ISCKB1:',ISCKB1 373 WRITE(LUPRI,*) 'In CC3_OMEG3: ISCKB2:',ISCKB2 374C 375 ENDIF 376C 377C-------------------------- 378C Memory allocation. 379C-------------------------- 380C 381 KTRVI = KEND1 382 KTRVI1 = KTRVI + NCKATR(ISCKB1) 383 KTRVI2 = KTRVI1 + NCKATR(ISCKB1) 384 KRMAT1 = KTRVI2 + NCKATR(ISCKB2) 385 KRMAT4 = KRMAT1 + NCKI(ISAIJ1) 386 KEND2 = KRMAT4 + NCKI(ISAIJ1) 387 LWRK2 = LWORK - KEND2 388C 389 KTRVI0 = KEND2 390 KTRVI3 = KTRVI0 + NCKATR(ISCKB2) 391 KEND3 = KTRVI3 + NCKATR(ISCKB2) 392 LWRK3 = LWORK - KEND3 393C 394 KINTVI = KEND3 395 KEND4 = KINTVI + MAX(NCKA(ISYMD),NCKA(ISCKB2)) 396 LWRK4 = LWORK - KEND4 397C 398 IF (LWRK4 .LT. 0) THEN 399 WRITE(LUPRI,*) 'Memory available : ',LWORK 400 WRITE(LUPRI,*) 'Memory needed : ',KEND4 401 CALL QUIT('Insufficient space in CC3_OMEG3') 402 END IF 403C 404 DO 110 D = 1,NVIR(ISYMD) 405C 406C---------------------------------------- 407C Initialize the R1/R4 matrix. 408C---------------------------------------- 409C 410 CALL DZERO(WORK(KRMAT1),NCKI(ISAIJ1)) 411 CALL DZERO(WORK(KRMAT4),NCKI(ISAIJ1)) 412C 413C----------------------------------------------- 414C Read virtual integrals used in s3am. 415C----------------------------------------------- 416C 417 IOFF = ICKBD(ISCKB2,ISYMD) + NCKATR(ISCKB2)*(D - 1) + 1 418 IF (NCKATR(ISCKB2) .GT. 0) THEN 419 CALL GETWA2(LUDKBC,FNDKBC,WORK(KTRVI0),IOFF, 420 & NCKATR(ISCKB2)) 421 ENDIF 422C 423C--------------------------------------- 424C Sort the integrals for s3am. 425C--------------------------------------- 426C 427 DTIME = SECOND() 428 CALL CCSDT_SRTVIR(WORK(KTRVI0),WORK(KTRVI2),WORK(KEND4), 429 * LWRK4,ISYMD,ISINT2) 430C 431 DTIME = SECOND() - DTIME 432 TISORT = TISORT + DTIME 433C 434 IF (IPRINT .GT. 55) THEN 435 XTRVI0= DDOT(NCKATR(ISCKB2),WORK(KTRVI0),1, 436 * WORK(KTRVI0),1) 437 WRITE(LUPRI,*) 'Norm of TRVI0 ',XTRVI0 438 ENDIF 439C 440 IF (IPRINT .GT. 55) THEN 441 XTRVI2= DDOT(NCKATR(ISCKB2),WORK(KTRVI2),1, 442 * WORK(KTRVI2),1) 443 WRITE(LUPRI,*) 'Norm of TRVI2 ',XTRVI2 444 ENDIF 445C 446C----------------------------------------------- 447C Read virtual integrals used in q3am. 448C----------------------------------------------- 449C 450 IOFF = ICKAD(ISCKB2,ISYMD) + NCKA(ISCKB2)*(D - 1) + 1 451 IF (NCKA(ISCKB2) .GT. 0) THEN 452 CALL GETWA2(LUDELD,FNDELD,WORK(KINTVI),IOFF, 453 * NCKA(ISCKB2)) 454 ENDIF 455C 456 CALL CCSDT_TRVIR(WORK(KINTVI),WORK(KTRVI3),XLAMDH, 457 * ISYMD,D,ISINT2,WORK(KEND4),LWRK4) 458C 459 IF (LWRK3 .LT. NCKATR(ISYCKB)) THEN 460 CALL QUIT('Insufficient space for allocation in '// 461 & 'CC3_OMEG3') 462 END IF 463C 464 DTIME = SECOND() 465 CALL CCSDT_SRVIR3(WORK(KTRVI3),WORK(KEND3),ISYMD,D,ISINT2) 466C 467 DTIME = SECOND() - DTIME 468 TISORT = TISORT + DTIME 469C 470 IF (IPRINT .GT. 55) THEN 471 XTRVI3= DDOT(NCKATR(ISCKB2),WORK(KTRVI3),1, 472 * WORK(KTRVI3),1) 473 WRITE(LUPRI,*) 'Norm of TRVI3 ',XTRVI3 474 ENDIF 475C 476C--------------------------------------------- 477C Construct integrals used in CC3LR. 478C--------------------------------------------- 479C 480 CALL CC3LR_PINT(WORK(KTRVI),WORK(KTRVI1),T1AM, 481 * WORK(KXIAJB),WORK(KEND4),LWRK4, 482 * ISYMD,D,ISYMT1) 483C 484 IF (IPRINT .GT. 55) THEN 485 XTRVI= DDOT(NCKATR(ISCKB1),WORK(KTRVI),1, 486 * WORK(KTRVI),1) 487 WRITE(LUPRI,*) 'Norm of TRVI ',XTRVI 488C 489 XTRVI1= DDOT(NCKATR(ISCKB1),WORK(KTRVI1),1, 490 * WORK(KTRVI1),1) 491 WRITE(LUPRI,*) 'Norm of TRVI1 ',XTRVI1 492 ENDIF 493C 494C--------------------- 495C Calculate. 496C--------------------- 497C 498 DO 120 ISYMB = 1,NSYM 499C 500 ISYALJ = MULD2H(ISYMB,ISYMT2) 501 ISAIJ2 = MULD2H(ISYMB,ISYRES) 502 ISYMBD = MULD2H(ISYMB,ISYMD) 503 ISCKIJ = MULD2H(ISYMBD,ISYMIM) 504C 505 IF (IPRINT .GT. 55) THEN 506C 507 WRITE(LUPRI,*) 'In CC3_OMEG3: ISYMD :',ISYMD 508 WRITE(LUPRI,*) 'In CC3_OMEG3: ISYMB :',ISYMB 509 WRITE(LUPRI,*) 'In CC3_OMEG3: ISYALJ:',ISYALJ 510 WRITE(LUPRI,*) 'In CC3_OMEG3: ISAIJ2:',ISAIJ2 511 WRITE(LUPRI,*) 'In CC3_OMEG3: ISYMBD:',ISYMBD 512 WRITE(LUPRI,*) 'In CC3_OMEG3: ISCKIJ:',ISCKIJ 513C 514 ENDIF 515C 516 KSMAT = KEND3 517 KQMAT = KSMAT + NCKIJ(ISCKIJ) 518 KDIAG = KQMAT + NCKIJ(ISCKIJ) 519 KINDSQ = KDIAG + NCKIJ(ISCKIJ) 520 KINDEX = KINDSQ + (6*NCKIJ(ISCKIJ) - 1)/IRAT + 1 521 KTMAT = KINDEX + (NCKI(ISYALJ) - 1)/IRAT + 1 522 KRMAT2 = KTMAT + NCKIJ(ISCKIJ) 523 KRMAT3 = KRMAT2 + NCKI(ISAIJ2) 524 KEND4 = KRMAT3 + NCKI(ISAIJ2) 525 LWRK4 = LWORK - KEND4 526C 527 IF (LWRK4 .LT. 0) THEN 528 WRITE(LUPRI,*) 'Memory available : ',LWORK 529 WRITE(LUPRI,*) 'Memory needed : ',KEND4 530 CALL QUIT('Insufficient space in CC3_OMEG3') 531 END IF 532C 533C--------------------------------------------- 534C Construct part of the diagonal. 535C--------------------------------------------- 536C 537 CALL CC3_DIAG(WORK(KDIAG),WORK(KFOCKD),ISCKIJ) 538C 539 IF (IPRINT .GT. 55) THEN 540 XDIA = DDOT(NCKIJ(ISCKIJ),WORK(KDIAG),1, 541 * WORK(KDIAG),1) 542 WRITE(LUPRI,*) 'Norm of DIA ',XDIA 543 ENDIF 544 545C 546C------------------------------------- 547C Construct index arrays. 548C------------------------------------- 549C 550 LENSQ = NCKIJ(ISCKIJ) 551 CALL CC3_INDSQ(WORK(KINDSQ),LENSQ,ISCKIJ) 552 CALL CC3_INDEX(WORK(KINDEX),ISYALJ) 553C 554 DO 130 B = 1,NVIR(ISYMB) 555C 556C----------------------------------------------------- 557C Initialize the R2/R3 matrices. 558C----------------------------------------------------- 559C 560 CALL DZERO(WORK(KRMAT2),NCKI(ISAIJ2)) 561 CALL DZERO(WORK(KRMAT3),NCKI(ISAIJ2)) 562C 563C-------------------------------------------------- 564C Calculate the S(ci,bk,dj) matrix. 565C-------------------------------------------------- 566C 567 DTIME = SECOND() 568 CALL CC3_SMAT(ECURR,T2TP,ISYMT2,WORK(KTMAT), 569 * WORK(KTRVI0), 570 * WORK(KTRVI2),WORK(KTROC0),ISINT2, 571 * WORK(KFOCKD),WORK(KDIAG), 572 * WORK(KSMAT),WORK(KEND4),LWRK4, 573 * WORK(KINDEX),WORK(KINDSQ),LENSQ, 574 * ISYMB,B,ISYMD,D) 575C 576 DTIME = SECOND() - DTIME 577 TISMAT = TISMAT + DTIME 578C 579 IF (IPRINT .GT. 55) THEN 580 XSMAT = DDOT(NCKIJ(ISCKIJ),WORK(KSMAT),1, 581 * WORK(KSMAT),1) 582 WRITE(LUPRI,*) 'Norm of SMAT ',XSMAT 583 ENDIF 584C 585 IF (IPRINT .GT. 55) THEN 586 XTMAT = DDOT(NCKIJ(ISCKIJ),WORK(KTMAT),1, 587 * WORK(KTMAT),1) 588 WRITE(LUPRI,*) 'Norm of TMAT ',XTMAT 589 ENDIF 590C 591C-------------------------------------------------- 592C Calculate Q(ci,jk) for fixed b,d. 593C-------------------------------------------------- 594C 595 DTIME = SECOND() 596 CALL CC3_QMAT(ECURR,T2TP,ISYMT2,WORK(KTRVI3), 597 * WORK(KTROC0),ISINT2,WORK(KFOCKD), 598 * WORK(KDIAG),WORK(KQMAT), 599 * WORK(KEND4),LWRK4,WORK(KINDSQ),LENSQ, 600 * ISYMB,B,ISYMD,D) 601C 602 DTIME = SECOND() - DTIME 603 TIQMAT = TIQMAT + DTIME 604C 605 IF (IPRINT .GT. 55) THEN 606 XQMAT = DDOT(NCKIJ(ISCKIJ),WORK(KQMAT),1, 607 * WORK(KQMAT),1) 608 WRITE(LUPRI,*) 'Norm of QMAT ',XQMAT 609 ENDIF 610C 611C----------------------------------------- 612C Contract with integrals. 613C----------------------------------------- 614C 615 DTIME = SECOND() 616 CALL CC3_CONVIR(WORK(KRMAT3),WORK(KSMAT), 617 * WORK(KQMAT),WORK(KTMAT),ISYMIM, 618 * WORK(KTRVI),WORK(KTRVI1),ISINT1, 619 * WORK(KEND4),LWRK4, 620 * WORK(KINDSQ),LENSQ,ISYMB,B,ISYMD,D) 621C 622 IF (IPRINT .GT. 55) THEN 623 XRMAT = DDOT(NCKI(ISAIJ1),WORK(KRMAT1),1, 624 * WORK(KRMAT1),1) 625 WRITE(LUPRI,*) 'Norm of RMAT1 after CONVIR ',XRMAT 626 XRMAT = DDOT(NCKI(ISAIJ2),WORK(KRMAT2),1, 627 * WORK(KRMAT2),1) 628 WRITE(LUPRI,*) 'Norm of RMAT2 after CONVIR',XRMAT 629 XRMAT = DDOT(NCKI(ISAIJ2),WORK(KRMAT3),1, 630 * WORK(KRMAT3),1) 631 WRITE(LUPRI,*) 'Norm of RMAT3 after CONVIR',XRMAT 632 XRMAT = DDOT(NCKI(ISAIJ1),WORK(KRMAT4),1, 633 * WORK(KRMAT4),1) 634 WRITE(LUPRI,*) 'Norm of RMAT4 after CONVIR ',XRMAT 635 ENDIF 636C 637 IF (IPRINT .GT. 220) THEN 638 CALL AROUND('After CC3_CONVIR: Rho2+') 639 CALL CC_PRP(OMEGA1,OMEGA2P,ISYRES,0,1) 640 CALL AROUND('After CC3_CONVIR: Rho2-') 641 CALL CC_PRP(OMEGA1,OMEGA2M,ISYRES,0,1) 642 ENDIF 643C 644 DTIME = SECOND() - DTIME 645 TICONV = TICONV + DTIME 646C 647 DTIME = SECOND() 648 CALL CC3_CONOCC3(OMEGA2P,OMEGA2M,WORK(KRMAT1), 649 * WORK(KRMAT2),WORK(KSMAT),WORK(KTMAT), 650 * ISYMIM,WORK(KTROC),WORK(KTROC1), 651 * ISINT1,WORK(KEND4),LWRK4, 652 * WORK(KINDSQ),LENSQ,ISYMB,B,ISYMD,D) 653C 654 IF (IPRINT .GT. 55) THEN 655 XRMAT = DDOT(NCKI(ISAIJ1),WORK(KRMAT1),1, 656 * WORK(KRMAT1),1) 657 WRITE(LUPRI,*) 'Norm of RMAT1 after CONOCC3',XRMAT 658 XRMAT = DDOT(NCKI(ISAIJ2),WORK(KRMAT2),1, 659 * WORK(KRMAT2),1) 660 WRITE(LUPRI,*) 'Norm of RMAT2 after CONOCC3',XRMAT 661 XRMAT = DDOT(NCKI(ISAIJ2),WORK(KRMAT3),1, 662 * WORK(KRMAT3),1) 663 WRITE(LUPRI,*) 'Norm of RMAT3 after CONOCC3',XRMAT 664 XRMAT = DDOT(NCKI(ISAIJ1),WORK(KRMAT4),1, 665 * WORK(KRMAT4),1) 666 WRITE(LUPRI,*) 'Norm of RMAT4 after CONOCC3',XRMAT 667 RHO1N = DDOT(NT1AM(ISYRES),OMEGA1,1,OMEGA1,1) 668 WRITE(LUPRI,*) 'Norm of Rho1 -after CC3_CONOCC', 669 * RHO1N 670 RHO2N = DDOT(NT2AM(ISYRES),OMEGA2P,1,OMEGA2P,1) 671 WRITE(LUPRI,*) 'Norm of Rho2+ after CC3_CONOCC3', 672 * RHO2N 673 RHO2N = DDOT(NT2AM(ISYRES),OMEGA2M,1,OMEGA2M,1) 674 WRITE(LUPRI,*) 'Norm of Rho2+ after CC3_CONOCC3', 675 * RHO2N 676 ENDIF 677C 678 IF (IPRINT .GT. 220) THEN 679 CALL AROUND('After CC3_CONOCC: Rho2+') 680 CALL CC_PRP(OMEGA1,OMEGA2P,ISYRES,0,1) 681 CALL AROUND('After CC3_CONOCC: Rho2-') 682 CALL CC_PRP(OMEGA1,OMEGA2M,ISYRES,0,1) 683 ENDIF 684C 685 DTIME = SECOND() - DTIME 686 TICONO = TICONO + DTIME 687C 688C---------------------------------- 689C Calculate Omega1. 690C---------------------------------- 691C 692 DTIME = SECOND() 693C 694 CALL CC3_ONEL3(OMEGA1,OMEGA2P,OMEGA2M,WORK(KRMAT4), 695 * WORK(KRMAT3),WORK(KFCKAK),WORK(KSMAT), 696 * WORK(KTMAT),ISYMIM,WORK(KXIAJB),ISINT1, 697 * WORK(KINDSQ),LENSQ,WORK(KEND4),LWRK4, 698 * ISYMB,B,ISYMD,D) 699C 700 IF (IPRINT .GT. 55) THEN 701 RHO1N = DDOT(NT1AM(ISYRES),OMEGA1,1,OMEGA1,1) 702 WRITE(LUPRI,*) 'Norm of Rho1 after CC3_ONEL3', 703 * RHO1N 704 RHO2N = DDOT(NT2AM(ISYRES),OMEGA2P,1,OMEGA2P,1) 705 WRITE(LUPRI,*) 'Norm of Rho2+ after CC3_ONEL3', 706 * RHO2N 707 RHO2N = DDOT(NT2AM(ISYRES),OMEGA2M,1,OMEGA2M,1) 708 WRITE(LUPRI,*) 'Norm of Rho2- after CC3_ONEL3', 709 * RHO2N 710 XRMAT = DDOT(NCKI(ISAIJ1),WORK(KRMAT1),1, 711 * WORK(KRMAT1),1) 712 WRITE(LUPRI,*) 'Norm of RMAT1 after ONEL',XRMAT 713 XRMAT = DDOT(NCKI(ISAIJ2),WORK(KRMAT2),1, 714 * WORK(KRMAT2),1) 715 WRITE(LUPRI,*) 'Norm of RMAT2 after ONEL',XRMAT 716 XRMAT = DDOT(NCKI(ISAIJ2),WORK(KRMAT3),1, 717 * WORK(KRMAT3),1) 718 WRITE(LUPRI,*) 'Norm of RMAT3 after ONEL',XRMAT 719 XRMAT = DDOT(NCKI(ISAIJ1),WORK(KRMAT4),1, 720 * WORK(KRMAT4),1) 721 WRITE(LUPRI,*) 'Norm of RMAT4 after ONEL',XRMAT 722 XTMAT = DDOT(NCKIJ(ISCKIJ),WORK(KSMAT),1, 723 * WORK(KSMAT),1) 724 WRITE(LUPRI,*) 'Norm of SMAT after ONEL',XSMAT 725 XTMAT = DDOT(NCKIJ(ISCKIJ),WORK(KTMAT),1, 726 * WORK(KTMAT),1) 727 WRITE(LUPRI,*) 'Norm of TMAT after ONEL',XTMAT 728 ENDIF 729C 730 IF (IPRINT .GT. 220) THEN 731 CALL AROUND('After CC3_ONEL3: Rho1 & Rho2+ ') 732 CALL CC_PRP(OMEGA1,OMEGA2P,ISYRES,1,1) 733 CALL AROUND('After CC3_ONEL3: Rho2- ') 734 CALL CC_PRP(OMEGA1,OMEGA2M,ISYRES,0,1) 735 ENDIF 736C 737 DTIME = SECOND() - DTIME 738 TIOME1 = TIOME1 + DTIME 739C 740C------------------------------------------------------------------- 741C Accumulate the R2 and R3 matrix in Omega2+ & Omega2-. 742C------------------------------------------------------------------- 743C 744 MFACTOR = ONE 745 IOPT = 1 746 CALL CC3_RACC3(OMEGA2P,OMEGA2M,WORK(KRMAT2),ISYMB,B, 747 * ISYRES,MFACTOR,IOPT) 748C 749 MFACTOR = XMONE 750 IOPT = 1 751 CALL CC3_RACC3(OMEGA2P,OMEGA2M,WORK(KRMAT3),ISYMB,B, 752 * ISYRES,MFACTOR,IOPT) 753C 754 IF (IPRINT .GT. 55) THEN 755 RHO1N = DDOT(NT1AM(ISYRES),OMEGA1,1,OMEGA1,1) 756 WRITE(LUPRI,*) 'Norm of Rho1 after CC3_RACC3', 757 * RHO1N 758 RHO2N = DDOT(NT2AM(ISYRES),OMEGA2P,1,OMEGA2P,1) 759 WRITE(LUPRI,*) 'Norm of Rho2+ after CC3_RACC3', 760 * RHO2N 761 RHO2N = DDOT(NT2AM(ISYRES),OMEGA2M,1,OMEGA2M,1) 762 WRITE(LUPRI,*) 'Norm of Rho2- after CC3_RACC3', 763 * RHO2N 764 ENDIF 765C 766 IF (IPRINT .GT. 220) THEN 767 CALL AROUND('After CC3_RACC3: Rho1 & Rho2+') 768 CALL CC_PRP(OMEGA1,OMEGA2P,ISYRES,1,1) 769 CALL AROUND('After CC3_RACC3: Rho2-') 770 CALL CC_PRP(OMEGA1,OMEGA2M,ISYRES,0,1) 771 ENDIF 772C 773 130 CONTINUE 774 120 CONTINUE 775C 776C--------------------------------------------------------------------- 777C Accumulate the R1 & R4 matrices in Omega2+ & Omega2-. 778C--------------------------------------------------------------------- 779C 780 MFACTOR = ONE 781 IOPT = 1 782 CALL CC3_RACC3(OMEGA2P,OMEGA2M,WORK(KRMAT1),ISYMD,D,ISYRES, 783 * MFACTOR,IOPT) 784 MFACTOR = XMONE 785 IOPT = 1 786 CALL CC3_RACC3(OMEGA2P,OMEGA2M,WORK(KRMAT4),ISYMD,D,ISYRES, 787 * MFACTOR,IOPT) 788C 789 IF (IPRINT .GT. 55) THEN 790 RHO1N = DDOT(NT1AM(ISYRES),OMEGA1,1,OMEGA1,1) 791 WRITE(LUPRI,*) 'Norm of Rho1 after CC3_RACC3-2',RHO1N 792 RHO2N = DDOT(NT2AM(ISYRES),OMEGA2P,1,OMEGA2P,1) 793 WRITE(LUPRI,*) 'Norm of Rho2+ after CC3_RACC3-2',RHO2N 794 RHO2N = DDOT(NT2AM(ISYRES),OMEGA2M,1,OMEGA2M,1) 795 WRITE(LUPRI,*) 'Norm of Rho2- after CC3_RACC3-2',RHO2N 796 ENDIF 797C 798 IF (IPRINT .GT. 220) THEN 799 CALL AROUND('After CC3_RACC3-2: Rho1 & Rho2+') 800 CALL CC_PRP(OMEGA1,OMEGA2P,ISYRES,1,1) 801 CALL AROUND('After CC3_RACC3-2: Rho2-') 802 CALL CC_PRP(OMEGA1,OMEGA2M,ISYRES,0,1) 803 ENDIF 804C 805 110 CONTINUE 806 100 CONTINUE 807C 808C----------------------- 809C Close files 810C----------------------- 811C 812 CALL WCLOSE2(LUDELD,FNDELD,'DELETE') 813 CALL WCLOSE2(LUDKBC,FNDKBC,'DELETE') 814C 815C------------------- 816C Print timings. 817C------------------- 818C 819 IF (IPRINT .GT. 9) THEN 820 WRITE(LUPRI,*) 821 WRITE(LUPRI,*) '** Timings in CC3_OMEG3 **' 822 WRITE(LUPRI,1) 'CC3_TRAN : ',TITRAN 823 WRITE(LUPRI,1) 'CC3_SORT : ',TISORT 824 WRITE(LUPRI,1) 'CC3_SMAT : ',TISMAT 825 WRITE(LUPRI,1) 'CC3_QMAT : ',TIQMAT 826 WRITE(LUPRI,1) 'CC3_CONV : ',TICONV 827 WRITE(LUPRI,1) 'CC3_CONO : ',TICONO 828 WRITE(LUPRI,1) 'CC3_OME1 : ',TIOME1 829 WRITE(LUPRI,*) 830 END IF 831C 832 CALL QEXIT('CC3_OMEG3') 833C 834 RETURN 835C 836 1 FORMAT(7X,'Time used in',2X,A12,F12.2,' seconds') 837C 838 END 839C /* Deck cc3_onel3 */ 840 SUBROUTINE CC3_ONEL3(OMEGA1,OMEGA2P,OMEGA2M,RMAT1,RMAT2,FOCKAK, 841 * SMAT,TMAT,ISYMIM,XIAJB,ISYINT,INDSQ,LENSQ, 842 * WORK,LWORK,ISYMIB,IB,ISYMID,ID) 843C 844C Henrik Koch and Alfredo Sanchez. Dec 1994 845C 846C Calculate Omega1 and Fock contibution to Omega2. 847C 848C Ove Christiansen 9-1-1996: 849C 850C General symmetry: ISYMIM is symmetry of SMAT and TMAT 851C intermdiates.(incl isymd,isymb) 852C ISYINT is symmetry of FOCKAK and XIAJB 853C ISYRES = ISYMIM*ISYINT 854C 855C K. Hald, Jan. 2001 : Adapted to triplet. 856C 857 IMPLICIT NONE 858C 859#include "priunit.h" 860#include "ccorb.h" 861#include "ccsdinp.h" 862#include "ccsdsym.h" 863C 864 INTEGER ISYMIM, ISYINT, LENSQ, LWORK, ISYMIB, IB, ISYMID, ID 865 INTEGER ISYRES, ISYMB, ISYMC, ISYMK, ISYMBC, ISYAIJ 866 INTEGER ISYMCK, LENGTH, NCK, NTOAIJ, NTOTC, ISYMI 867 INTEGER ISYAKJ, ISYMJ, ISYMBJ, ISYMAK, NBJ, NAK, NAKBJ, NAKJ 868 INTEGER NTOAKJ, NBK, ISYMBK, NTOTB, ISYMKJ, ISYMAI, NCI, NIJ 869 INTEGER NCIBJ, NTOTIJ, NTOTAK, ISYMIJ, JSAIKJ, KOFF1, KOFF2 870 INTEGER NKJ, NCKBJ, NTOTAI, JSAKIJ, ISYMCI 871 INTEGER INDEX, INDSQ(LENSQ,6) 872C 873#if defined (SYS_CRAY) 874 REAL OMEGA1(*),OMEGA2P(*), OMEGA2M(*), RMAT1(*) 875 REAL RMAT2(*), FOCKAK(*),SMAT(*), TMAT(*), XIAJB(*) 876 REAL WORK(LWORK), ZERO, ONE, TWO, HALF 877#else 878 DOUBLE PRECISION OMEGA1(*),OMEGA2P(*), OMEGA2M(*), RMAT1(*) 879 DOUBLE PRECISION RMAT2(*), FOCKAK(*),SMAT(*), TMAT(*), XIAJB(*) 880 DOUBLE PRECISION WORK(LWORK), ZERO, ONE, TWO, HALF 881#endif 882C 883 PARAMETER (ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, HALF = 0.5D0) 884C 885 INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 886C 887 CALL QENTER('CC3_ONEL3') 888C 889 ISYRES = MULD2H(ISYMIM,ISYINT) 890C 891 B = IB 892 C = ID 893C 894 ISYMB = ISYMIB 895 ISYMC = ISYMID 896C 897C---------------------------------- 898C First contribution to Omega2. 899C---------------------------------- 900C 901 ISYMK = MULD2H(ISYMC,ISYINT) 902 ISYMBC = MULD2H(ISYMB,ISYMC) 903 JSAIKJ = MULD2H(ISYMBC,ISYMIM) 904 ISYAIJ = MULD2H(ISYMK,JSAIKJ) 905 ISYMCK = MULD2H(ISYMC,ISYMK) 906C 907 LENGTH = NCKIJ(JSAIKJ) 908C 909 IF (LWORK .LT. LENGTH) THEN 910 CALL QUIT('Not enough core in CCSDT_ONEL') 911 END IF 912C 913c CALL CC_GATHER(LENGTH,TMAT,SMAT,INDSQ(1,4)) 914c CALL CC_GATHER(LENGTH,WORK,SMAT,INDSQ(1,3)) 915c CALL DAXPY(LENGTH,-ONE,WORK,1,TMAT,1) 916C 917 DO I = 1,LENGTH 918 TMAT(I) = SMAT(INDSQ(I,4)) 919 ENDDO 920C 921 NCK = IT1AM(ISYMC,ISYMK) + C 922C 923 KOFF1 = ISAIKJ(ISYAIJ,ISYMK) + 1 924C 925 NTOAIJ = MAX(NCKI(ISYAIJ),1) 926 NTOTC = MAX(NVIR(ISYMC),1) 927C 928 CALL DGEMV('N',NCKI(ISYAIJ),NRHF(ISYMK),ONE,TMAT(KOFF1),NTOAIJ, 929 * FOCKAK(NCK),NTOTC,ONE,RMAT2,1) 930C 931C---------------------------------- 932C First contribution to Omega1. 933C---------------------------------- 934C 935 ISYMI = MULD2H(ISYMC,ISYRES) 936 ISYAKJ = MULD2H(ISYMB,ISYINT) 937C 938 IF ((.NOT. CC3LR) .AND. (NRHF(ISYMI) .NE. 0)) THEN 939C 940 IF (LWORK .LT. NCKI(ISYAKJ)) THEN 941 CALL QUIT('Not enough core in CCSDT_ONEL') 942 END IF 943C 944C Construct M(ak,j) = L(ak,bj) 945C --------------------------- 946C 947 DO 100 ISYMJ = 1,NSYM 948C 949 ISYMBJ = MULD2H(ISYMB,ISYMJ) 950 ISYMAK = MULD2H(ISYMJ,ISYAKJ) 951C 952 DO 110 J = 1,NRHF(ISYMJ) 953C 954 NBJ = IT1AM(ISYMB,ISYMJ) + NVIR(ISYMB)*(J - 1) + B 955C 956 DO 120 NAK = 1,NT1AM(ISYMAK) 957C 958 NAKBJ = IT2AM(ISYMAK,ISYMBJ) + INDEX(NAK,NBJ) 959 NAKJ = ICKI(ISYMAK,ISYMJ) 960 * + NT1AM(ISYMAK)*(J - 1) + NAK 961C 962 WORK(NAKJ) = XIAJB(NAKBJ) 963C 964 120 CONTINUE 965 110 CONTINUE 966 100 CONTINUE 967C 968 NTOTC = MAX(NVIR(ISYMC),1) 969 NTOAKJ = MAX(NCKI(ISYAKJ),1) 970C 971 KOFF1 = ISAIKJ(ISYAKJ,ISYMI) + 1 972 KOFF2 = IT1AM(ISYMC,ISYMI) + C 973C 974 CALL DGEMV('T',NCKI(ISYAKJ),NRHF(ISYMI),ONE,TMAT(KOFF1), 975 * NTOAKJ,WORK,1,ONE,OMEGA1(KOFF2),NTOTC) 976C 977 ENDIF 978C 979C----------------------------------- 980C Second contribution to Omega2. 981C----------------------------------- 982C 983 ISYMK = MULD2H(ISYMB,ISYINT) 984 ISYMBC = MULD2H(ISYMB,ISYMC) 985 JSAIKJ = MULD2H(ISYMBC,ISYMIM) 986 ISYAIJ = MULD2H(ISYMK,JSAIKJ) 987 ISYMBK = MULD2H(ISYMB,ISYMK) 988C 989 LENGTH = NCKIJ(JSAIKJ) 990C 991 IF (LWORK .LT. LENGTH) THEN 992 CALL QUIT('Not enough core in CCSDT_ONEL') 993 END IF 994C 995c CALL CC_GATHER(LENGTH,TMAT,SMAT,INDSQ(1,5)) 996c CALL DAXPY(LENGTH,-ONE,SMAT,1,TMAT,1) 997C 998 DO I = 1,LENGTH 999 TMAT(I) = SMAT(INDSQ(I,5)) 1000 ENDDO 1001C 1002 NBK = IT1AM(ISYMB,ISYMK) + B 1003C 1004 KOFF1 = ISAIKJ(ISYAIJ,ISYMK) + 1 1005C 1006 NTOAIJ = MAX(NCKI(ISYAIJ),1) 1007 NTOTB = MAX(NVIR(ISYMB),1) 1008C 1009 CALL DGEMV('N',NCKI(ISYAIJ),NRHF(ISYMK),ONE,TMAT(KOFF1),NTOAIJ, 1010 * FOCKAK(NBK),NTOTB,ONE,RMAT1,1) 1011C 1012C----------------------------------- 1013C Second contribution to Omega1. 1014C----------------------------------- 1015C 1016 IF (.NOT. CC3LR) THEN 1017C 1018C Symmetry sorting if symmetry 1019C ---------------------------- 1020C 1021 IF (NSYM .GT. 1) THEN 1022 CALL CC_GATHER(LENGTH,WORK,TMAT,INDSQ(1,6)) 1023 CALL DCOPY(LENGTH,WORK,1,TMAT,1) 1024 ENDIF 1025C 1026 ISYMKJ = MULD2H(ISYMBC,ISYINT) 1027 ISYMAI = ISYRES 1028C 1029C Construct M(k,j) = L(ck,bj) 1030C --------------------------- 1031C 1032 DO 200 ISYMJ = 1,NSYM 1033C 1034 ISYMK = MULD2H(ISYMJ,ISYMKJ) 1035 ISYMCK = MULD2H(ISYMC,ISYMK) 1036 ISYMBJ = MULD2H(ISYMB,ISYMJ) 1037C 1038 DO 210 J = 1,NRHF(ISYMJ) 1039C 1040 NBJ = IT1AM(ISYMB,ISYMJ) + NVIR(ISYMB)*(J - 1) + B 1041C 1042 DO 220 K = 1,NRHF(ISYMK) 1043C 1044 NKJ = IMATIJ(ISYMK,ISYMJ)+ NRHF(ISYMK)*(J - 1) + K 1045 NCK = IT1AM(ISYMC,ISYMK) + NVIR(ISYMC)*(K - 1) + C 1046C 1047 NCKBJ = IT2AM(ISYMCK,ISYMBJ) + INDEX(NCK,NBJ) 1048C 1049 WORK(NKJ) = XIAJB(NCKBJ) 1050C 1051 220 CONTINUE 1052 210 CONTINUE 1053 200 CONTINUE 1054C 1055 NTOTAI = MAX(NT1AM(ISYMAI),1) 1056C 1057 KOFF1 = ISAIKL(ISYMAI,ISYMKJ) + 1 1058C 1059 CALL DGEMV('N',NT1AM(ISYMAI),NMATIJ(ISYMKJ),ONE,TMAT(KOFF1), 1060 * NTOTAI,WORK,1,ONE,OMEGA1,1) 1061C 1062 ENDIF 1063C 1064C---------------------------------- 1065C Third contribution to Omega2. 1066C---------------------------------- 1067C 1068 ISYMBC = MULD2H(ISYMB,ISYMC) 1069 JSAKIJ = MULD2H(ISYMBC,ISYMIM) 1070 ISYMIJ = MULD2H(ISYMBC,ISYRES) 1071 ISYMAK = MULD2H(JSAKIJ,ISYMIJ) 1072C 1073 LENGTH = NCKIJ(JSAKIJ) 1074C 1075 IF (LWORK .LT. LENGTH) THEN 1076 CALL QUIT('Not enough core in CCSDT_ONEL') 1077 END IF 1078C 1079c CALL CC_GATHER(LENGTH,TMAT,SMAT,INDSQ(1,1)) 1080c CALL DAXPY(LENGTH,-ONE,SMAT,1,TMAT,1) 1081C 1082 DO I = 1,LENGTH 1083 TMAT(I) = SMAT(INDSQ(I,1)) 1084 ENDDO 1085C 1086C Symmetry sorting if symmetry 1087C ---------------------------- 1088C 1089 IF (NSYM .GT. 1) THEN 1090 CALL CC_GATHER(LENGTH,WORK,TMAT,INDSQ(1,6)) 1091 CALL DCOPY(LENGTH,WORK,1,TMAT,1) 1092 ENDIF 1093C 1094 NTOTAK = MAX(NT1AM(ISYMAK),1) 1095 NTOTIJ = MAX(NMATIJ(ISYMIJ),1) 1096C 1097 KOFF1 = ISAIKL(ISYMAK,ISYMIJ) + 1 1098C 1099 CALL DGEMV('T',NT1AM(ISYMAK),NMATIJ(ISYMIJ),ONE,TMAT(KOFF1), 1100 * NTOTAK,FOCKAK,1,ZERO,WORK,1) 1101C 1102 DO 300 ISYMJ = 1,NSYM 1103C 1104 ISYMI = MULD2H(ISYMIJ,ISYMJ) 1105C 1106 ISYMBJ = MULD2H(ISYMB,ISYMJ) 1107 ISYMCI = MULD2H(ISYMC,ISYMI) 1108C 1109 DO 310 J = 1,NRHF(ISYMJ) 1110C 1111 NBJ = IT1AM(ISYMB,ISYMJ) + NVIR(ISYMB)*(J - 1) + B 1112C 1113 IF (ISYMCI .EQ. ISYMBJ) THEN 1114C 1115 DO 320 I = 1,NRHF(ISYMI) 1116C 1117 NIJ = IMATIJ(ISYMI,ISYMJ) + NRHF(ISYMI)*(J - 1) + I 1118 NCI = IT1AM(ISYMC,ISYMI) + NVIR(ISYMC)*(I - 1) + C 1119C 1120 NCIBJ = IT2AM(ISYMCI,ISYMBJ) + INDEX(NCI,NBJ) 1121C 1122 IF (NCI .EQ. NBJ) THEN 1123C 1124 OMEGA2P(NCIBJ) = OMEGA2P(NCIBJ) + TWO*WORK(NIJ) 1125 OMEGA2M(NCIBJ) = ZERO 1126C 1127 ELSE IF (NCI .GT. NBJ) THEN 1128C 1129 OMEGA2P(NCIBJ) = OMEGA2P(NCIBJ) + WORK(NIJ) 1130 OMEGA2M(NCIBJ) = OMEGA2M(NCIBJ) - HALF*WORK(NIJ) 1131C 1132 ELSE IF (NCI .LT. NBJ) THEN 1133C 1134 OMEGA2P(NCIBJ) = OMEGA2P(NCIBJ) + WORK(NIJ) 1135 OMEGA2M(NCIBJ) = OMEGA2M(NCIBJ) + HALF*WORK(NIJ) 1136C 1137 ENDIF 1138C 1139 320 CONTINUE 1140C 1141 ELSE IF (ISYMCI .LT. ISYMBJ) THEN 1142C 1143 DO 330 I = 1,NRHF(ISYMI) 1144C 1145 NIJ = IMATIJ(ISYMI,ISYMJ) + NRHF(ISYMI)*(J - 1) + I 1146 NCI = IT1AM(ISYMC,ISYMI) + NVIR(ISYMC)*(I - 1) + C 1147C 1148 NCIBJ = IT2AM(ISYMCI,ISYMBJ) 1149 * + NT1AM(ISYMCI)*(NBJ-1) + NCI 1150C 1151 OMEGA2P(NCIBJ) = OMEGA2P(NCIBJ) + WORK(NIJ) 1152 OMEGA2M(NCIBJ) = OMEGA2M(NCIBJ) + HALF*WORK(NIJ) 1153C 1154 330 CONTINUE 1155C 1156 ELSE IF (ISYMBJ .LT. ISYMCI) THEN 1157C 1158 DO 340 I = 1,NRHF(ISYMI) 1159C 1160 NIJ = IMATIJ(ISYMI,ISYMJ) + NRHF(ISYMI)*(J - 1) + I 1161 NCI = IT1AM(ISYMC,ISYMI) + NVIR(ISYMC)*(I - 1) + C 1162C 1163 NCIBJ = IT2AM(ISYMBJ,ISYMCI) 1164 * + NT1AM(ISYMBJ)*(NCI-1) + NBJ 1165C 1166 OMEGA2P(NCIBJ) = OMEGA2P(NCIBJ) + WORK(NIJ) 1167 OMEGA2M(NCIBJ) = OMEGA2M(NCIBJ) - HALF*WORK(NIJ) 1168C 1169 340 CONTINUE 1170C 1171 ENDIF 1172C 1173 310 CONTINUE 1174C 1175 300 CONTINUE 1176C 1177C---------------------------------- 1178C Third contribution to Omega1. 1179C---------------------------------- 1180C 1181 333 CONTINUE 1182C 1183 IF (.NOT. CC3LR) THEN 1184C 1185 ISYMKJ = MULD2H(ISYMBC,ISYINT) 1186 ISYMAI = ISYRES 1187C 1188C Construct M(k,j) = L(ck,bj) 1189C --------------------------- 1190C 1191 DO 400 ISYMJ = 1,NSYM 1192C 1193 ISYMK = MULD2H(ISYMJ,ISYMKJ) 1194 ISYMCK = MULD2H(ISYMC,ISYMK) 1195 ISYMBJ = MULD2H(ISYMB,ISYMJ) 1196C 1197 DO 410 J = 1,NRHF(ISYMJ) 1198C 1199 NBJ = IT1AM(ISYMB,ISYMJ) + NVIR(ISYMB)*(J - 1) + B 1200C 1201 DO 420 K = 1,NRHF(ISYMK) 1202C 1203 NKJ = IMATIJ(ISYMK,ISYMJ)+ NRHF(ISYMK)*(J - 1) + K 1204 NCK = IT1AM(ISYMC,ISYMK) + NVIR(ISYMC)*(K - 1) + C 1205C 1206 NCKBJ = IT2AM(ISYMCK,ISYMBJ) + INDEX(NCK,NBJ) 1207C 1208 WORK(NKJ) = XIAJB(NCKBJ) 1209C 1210 420 CONTINUE 1211 410 CONTINUE 1212 400 CONTINUE 1213C 1214 NTOTAI = MAX(NT1AM(ISYMAI),1) 1215C 1216 KOFF1 = ISAIKL(ISYMAI,ISYMKJ) + 1 1217C 1218 CALL DGEMV('N',NT1AM(ISYMAI),NMATIJ(ISYMKJ),ONE,TMAT(KOFF1), 1219 * NTOTAI,WORK,1,ONE,OMEGA1,1) 1220C 1221 ENDIF 1222C 1223 CALL QEXIT('CC3_ONEL3') 1224C 1225 RETURN 1226 END 1227C /* Deck cc3_racc3 */ 1228 SUBROUTINE CC3_RACC3(OMEGA2P,OMEGA2M,RMAT,ISYMB,B,ISYRES,MFACTOR, 1229 * IOPT) 1230C 1231C Written by HK and ASM Maj 1995. 1232C 1233C Purpose : Accumulate the R matrix into the Omega vector. 1234C 1235C OC: 9-1-1996 general symmetry, ISYRES is symmetry of resulting vector. 1236C 1237C K. Hald, Jan 2001 : Adapted to triplet. 1238C 1239 IMPLICIT NONE 1240C 1241#include "priunit.h" 1242#include "ccorb.h" 1243#include "ccsdsym.h" 1244C 1245 INTEGER ISYMB, ISYRES, ISYAIJ, ISYMJ, ISYMAI, ISYMBJ 1246 INTEGER NBJ, NBJJ, NAI, KOFF1, KOFF2, KOFF5, KOFF6, IOPT 1247 INTEGER INDEX 1248C 1249#if defined (SYS_CRAY) 1250 REAL OMEGA2P(*), OMEGA2M(*), RMAT(*), MFACTOR 1251 REAL ZERO, HALF, TWO, FACT 1252#else 1253 DOUBLE PRECISION OMEGA2P(*), OMEGA2M(*), RMAT(*), MFACTOR 1254 DOUBLE PRECISION ZERO, HALF, TWO, FACT 1255#endif 1256 PARAMETER (TWO = 2.0D0, HALF = 0.5D0, ZERO = 0.0D0) 1257C 1258 INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 1259C 1260 CALL QENTER('CC3_RACC3') 1261C 1262C--------------------------- 1263C Sanity check. 1264C--------------------------- 1265C 1266 IF ((IOPT .NE. 1) .AND. (IOPT .NE. 2)) 1267 * CALL QUIT('Wrong IOPT in CC3_RACC3') 1268C 1269C--------------------------- 1270C Calculate. 1271C--------------------------- 1272C 1273 ISYAIJ = MULD2H(ISYMB,ISYRES) 1274C 1275 FACT = HALF * MFACTOR 1276C 1277 DO 100 ISYMJ = 1,NSYM 1278C 1279 ISYMAI = MULD2H(ISYMJ,ISYAIJ) 1280 ISYMBJ = MULD2H(ISYMB,ISYMJ) 1281C 1282 IF (NT1AM(ISYMAI) .LE. 0 ) GO TO 100 1283C 1284 DO 110 J = 1,NRHF(ISYMJ) 1285C 1286 NBJ = IT1AM(ISYMB,ISYMJ) + NVIR(ISYMB)*(J - 1) + B 1287C 1288 IF (ISYMAI .EQ. ISYMBJ) THEN 1289C 1290 NBJJ = ISAIK(ISYMBJ,ISYMJ) 1291 * + NT1AM(ISYMBJ)*(J - 1) + NBJ 1292C 1293 RMAT(NBJJ) = TWO * RMAT(NBJJ) 1294C 1295 DO 230 NAI = 1,NT1AM(ISYMAI) 1296C 1297 KOFF1 = IT2AM(ISYMAI,ISYMBJ) + INDEX(NAI,NBJ) 1298 KOFF2 = ISAIK(ISYMAI,ISYMJ) 1299 * + NT1AM(ISYMAI)*(J - 1) + NAI 1300C 1301 IF (NAI .EQ. NBJ) THEN 1302 IF (IOPT .EQ. 1) THEN 1303 OMEGA2P(KOFF1) = OMEGA2P(KOFF1) + RMAT(KOFF2) 1304 ENDIF 1305 OMEGA2M(KOFF1) = ZERO 1306 ELSE IF (NAI .GT. NBJ) THEN 1307 IF (IOPT .EQ. 1) THEN 1308 OMEGA2P(KOFF1) = OMEGA2P(KOFF1) + RMAT(KOFF2) 1309 ENDIF 1310 OMEGA2M(KOFF1) = OMEGA2M(KOFF1) + FACT*RMAT(KOFF2) 1311 ELSE 1312 IF (IOPT .EQ. 1) THEN 1313 OMEGA2P(KOFF1) = OMEGA2P(KOFF1) + RMAT(KOFF2) 1314 ENDIF 1315 OMEGA2M(KOFF1) = OMEGA2M(KOFF1) - FACT*RMAT(KOFF2) 1316 ENDIF 1317C 1318 230 CONTINUE 1319C 1320 ENDIF 1321C 1322 IF (ISYMAI .LT. ISYMBJ) THEN 1323C 1324 DO 240 NAI = 1,NT1AM(ISYMAI) 1325C 1326 KOFF5 = IT2AM(ISYMAI,ISYMBJ) 1327 * + NT1AM(ISYMAI)*(NBJ-1) + NAI 1328C 1329 KOFF6 = ISAIK(ISYMAI,ISYMJ) 1330 * + NT1AM(ISYMAI)*(J - 1) + NAI 1331C 1332 IF (IOPT .EQ. 1) THEN 1333 OMEGA2P(KOFF5) = OMEGA2P(KOFF5) + RMAT(KOFF6) 1334 ENDIF 1335 OMEGA2M(KOFF5) = OMEGA2M(KOFF5) - FACT*RMAT(KOFF6) 1336C 1337 240 CONTINUE 1338C 1339 ENDIF 1340C 1341 IF (ISYMAI .GT. ISYMBJ) THEN 1342C 1343 DO 250 NAI = 1,NT1AM(ISYMAI) 1344C 1345 KOFF5 = IT2AM(ISYMAI,ISYMBJ) 1346 * + NT1AM(ISYMBJ)*(NAI-1) + NBJ 1347C 1348 KOFF6 = ISAIK(ISYMAI,ISYMJ) 1349 * + NT1AM(ISYMAI)*(J - 1) + NAI 1350C 1351 IF (IOPT .EQ. 1) THEN 1352 OMEGA2P(KOFF5) = OMEGA2P(KOFF5) + RMAT(KOFF6) 1353 ENDIF 1354 OMEGA2M(KOFF5) = OMEGA2M(KOFF5) + FACT*RMAT(KOFF6) 1355C 1356 250 CONTINUE 1357C 1358 ENDIF 1359C 1360 110 CONTINUE 1361 100 CONTINUE 1362C 1363 CALL QEXIT('CC3_RACC3') 1364C 1365 RETURN 1366 END 1367C /* Deck cc3_conocc3 */ 1368 SUBROUTINE CC3_CONOCC3(OMEGA2P,OMEGA2M,RMAT1,RMAT2,SMAT,TMAT, 1369 * ISYMIM,TROCC,TROCC1,ISYINT,WORK,LWORK, 1370 * INDSQ,LENSQ,ISYMIB,IB,ISYMID,ID) 1371C 1372C Henrik Koch and Alfredo Sanchez. Dec 1994 1373C 1374C Set up combinations of Q's and S's and contract with integrals. 1375C 1376C Ove Christiansen 9-1-1996: 1377C 1378C General symmetry: ISYMIM is symmetry of SMAT and TMAT intermediates. 1379C (including isymib*isymid) 1380C ISYINT is symmetry of integrals in TROCC and TROCC1. 1381C ISYRES = ISYMIM*ISYINT 1382C 1383C K. Hald, Jan 2001, Adapted to triplet. 1384C 1385 IMPLICIT NONE 1386C 1387#include "priunit.h" 1388#include "ccorb.h" 1389#include "ccsdinp.h" 1390#include "ccsdsym.h" 1391C 1392 INTEGER ISYMIM, ISYINT, LWORK, LENSQ, ISYMIB, IB, ISYMID, ID 1393 INTEGER ISYRES, ISYMB, ISYMJ, ISYMBJ, ISYMC, ISYMBC, ISYCKL 1394 INTEGER ISYMA, ISYMI, ISYMAI, ISYMAB, ISYMKL, ISYKLJ, JSAIKL 1395 INTEGER KOFF1, KOFF2, KOFF3, KOFF5, KOFF6, LENGTH, NTOTAI, NTOTKL 1396 INTEGER NAI, NBJ, NRHFI, NTOCKL, JSCKLI 1397 INTEGER INDEX, INDSQ(LENSQ,6) 1398C 1399#if defined (SYS_CRAY) 1400 REAL OMEGA2P(*), OMEGA2M(*), RMAT1(*), RMAT2(*) 1401 REAL SMAT(*),TMAT(*), TROCC(*),TROCC1(*),WORK(LWORK) 1402 REAL XRMAT, XTMAT, DDOT, ZERO, ONE, TWO, HALF 1403#else 1404 DOUBLE PRECISION OMEGA2P(*), OMEGA2M(*), RMAT1(*), RMAT2(*) 1405 DOUBLE PRECISION SMAT(*),TMAT(*), TROCC(*),TROCC1(*),WORK(LWORK) 1406 DOUBLE PRECISION XRMAT, XTMAT, DDOT, ZERO, ONE, TWO, HALF 1407#endif 1408 PARAMETER (ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, HALF = 0.5D0) 1409C 1410 INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 1411C 1412 CALL QENTER('CC3_CONOCC3') 1413C 1414 IF (LWORK .LT. LENSQ) THEN 1415 CALL QUIT('Insufficient core in CONOCC3') 1416 ENDIF 1417C 1418 ISYRES = MULD2H(ISYMIM,ISYINT) 1419C 1420C------------------------- 1421C First occupied term. 1422C------------------------- 1423C 1424 C = ID 1425 B = IB 1426C 1427 ISYMC = ISYMID 1428 ISYMB = ISYMIB 1429C 1430 ISYMBC = MULD2H(ISYMB,ISYMC) 1431 JSAIKL = MULD2H(ISYMBC,ISYMIM) 1432C 1433 LENGTH = NCKIJ(JSAIKL) 1434C 1435C---------------------------------- 1436C Setup combinations of smat's. 1437C---------------------------------- 1438C 1439c CALL DCOPY(LENGTH,SMAT,1,TMAT,1) 1440C 1441c CALL CC_GATHER(LENGTH,WORK,SMAT,INDSQ(1,3)) 1442c CALL DAXPY(LENGTH,-TWO,WORK,1,TMAT,1) 1443C 1444c CALL CC_GATHER(LENGTH,WORK,SMAT,INDSQ(1,4)) 1445c CALL DAXPY(LENGTH,ONE,WORK,1,TMAT,1) 1446C 1447 DO I = 1,LENGTH 1448C 1449 TMAT(I) = SMAT(I) 1450 * - TWO*SMAT(INDSQ(I,3)) 1451 * + SMAT(INDSQ(I,4)) 1452C 1453 ENDDO 1454C 1455C---------------------------------- 1456C Symmetry sorting if symmetry. 1457C---------------------------------- 1458C 1459 IF (NSYM .GT. 1) THEN 1460 CALL CC_GATHER(LENGTH,WORK,TMAT,INDSQ(1,6)) 1461 CALL DCOPY(LENGTH,WORK,1,TMAT,1) 1462 ENDIF 1463C 1464 IF (IPRINT .GT. 55) THEN 1465 XTMAT = DDOT(NCKIJ(JSAIKL),TMAT,1,TMAT,1) 1466 WRITE(LUPRI,*) 'In CC3_CONOCC3: 1. Norm of TMAT = ',XTMAT 1467 ENDIF 1468C 1469C----------------------- 1470C First contraction. 1471C----------------------- 1472C 1473 DO 200 ISYMJ = 1,NSYM 1474C 1475 ISYMBJ = MULD2H(ISYMB,ISYMJ) 1476 ISYMAI = MULD2H(ISYMBJ,ISYRES) 1477 ISYMKL = MULD2H(JSAIKL,ISYMAI) 1478 ISYKLJ = MULD2H(ISYMKL,ISYMJ) 1479C 1480 NTOTAI = MAX(NT1AM(ISYMAI),1) 1481 NTOTKL = MAX(NMATIJ(ISYMKL),1) 1482C 1483 KOFF1 = ISAIKL(ISYMAI,ISYMKL) + 1 1484 KOFF2 = ISJIKA(ISYKLJ,ISYMC) 1485 * + NMAJIK(ISYKLJ)*(C - 1) 1486 * + ISJIK(ISYMKL,ISYMJ) + 1 1487 KOFF3 = ISAIK(ISYMAI,ISYMJ) + 1 1488C 1489 CALL DGEMM('N','N',NT1AM(ISYMAI),NRHF(ISYMJ),NMATIJ(ISYMKL), 1490 * -ONE,TMAT(KOFF1),NTOTAI,TROCC(KOFF2),NTOTKL, 1491 * ONE,RMAT2(KOFF3),NTOTAI) 1492C 1493 200 CONTINUE 1494C 1495 IF (IPRINT .GT. 55) THEN 1496 XRMAT = DDOT(NCKI(ISYRES),RMAT2,1,RMAT2,1) 1497 WRITE(LUPRI,*) 'In CC3_CONOCC3: Norm of RMAT2 = ',XRMAT 1498 ENDIF 1499C 1500C-------------------------- 1501C Second occupied term. 1502C-------------------------- 1503C 1504 B = ID 1505 C = IB 1506C 1507 ISYMB = ISYMID 1508 ISYMC = ISYMIB 1509C 1510 ISYMBC = MULD2H(ISYMB,ISYMC) 1511 JSAIKL = MULD2H(ISYMBC,ISYMIM) 1512C 1513 LENGTH = NCKIJ(JSAIKL) 1514C 1515C---------------------------------- 1516C Setup combinations of smat's. 1517C---------------------------------- 1518C 1519c CALL DCOPY(LENGTH,SMAT,1,TMAT,1) 1520c CALL DSCAL(LENGTH,-TWO,TMAT,1) 1521C 1522c CALL CC_GATHER(LENGTH,WORK,SMAT,INDSQ(1,3)) 1523c CALL DAXPY(LENGTH,ONE,WORK,1,TMAT,1) 1524C 1525c CALL CC_GATHER(LENGTH,WORK,SMAT,INDSQ(1,5)) 1526c CALL DAXPY(LENGTH,ONE,WORK,1,TMAT,1) 1527C 1528 DO I = 1,LENGTH 1529C 1530 TMAT(I) = - TWO*SMAT(I) 1531 * + SMAT(INDSQ(I,3)) 1532 * + SMAT(INDSQ(I,5)) 1533C 1534 ENDDO 1535C 1536C---------------------------------- 1537C Symmetry sorting if symmetry. 1538C---------------------------------- 1539C 1540 IF (NSYM .GT. 1) THEN 1541 CALL CC_GATHER(LENGTH,WORK,TMAT,INDSQ(1,6)) 1542 CALL DCOPY(LENGTH,WORK,1,TMAT,1) 1543 ENDIF 1544C 1545 IF (IPRINT .GT. 55) THEN 1546 XTMAT = DDOT(NCKIJ(JSAIKL),TMAT,1,TMAT,1) 1547 WRITE(LUPRI,*) 'In CC3_CONOCC3: 2. Norm of TMAT = ',XTMAT 1548 ENDIF 1549C 1550C------------------------ 1551C Second contraction. 1552C------------------------ 1553C 1554 DO 400 ISYMJ = 1,NSYM 1555C 1556 ISYMBJ = MULD2H(ISYMB,ISYMJ) 1557 ISYMAI = MULD2H(ISYMBJ,ISYRES) 1558 ISYMKL = MULD2H(JSAIKL,ISYMAI) 1559 ISYKLJ = MULD2H(ISYMKL,ISYMJ) 1560C 1561 NTOTAI = MAX(NT1AM(ISYMAI),1) 1562 NTOTKL = MAX(NMATIJ(ISYMKL),1) 1563C 1564 KOFF1 = ISAIKL(ISYMAI,ISYMKL) + 1 1565 KOFF2 = ISJIKA(ISYKLJ,ISYMC) 1566 * + NMAJIK(ISYKLJ)*(C - 1) 1567 * + ISJIK(ISYMKL,ISYMJ) + 1 1568 KOFF3 = ISAIK(ISYMAI,ISYMJ) + 1 1569C 1570 CALL DGEMM('N','N',NT1AM(ISYMAI),NRHF(ISYMJ),NMATIJ(ISYMKL), 1571 * -ONE,TMAT(KOFF1),NTOTAI,TROCC(KOFF2),NTOTKL, 1572 * ONE,RMAT1(KOFF3),NTOTAI) 1573C 1574 400 CONTINUE 1575C 1576 IF (IPRINT .GT. 55) THEN 1577 XRMAT = DDOT(NCKI(ISYRES),RMAT1,1,RMAT1,1) 1578 WRITE(LUPRI,*) 'In CC3_CONOCC3: Norm of RMAT1 = ',XRMAT 1579 ENDIF 1580C 1581C------------------------- 1582C Third occupied term. 1583C------------------------- 1584C 1585 A = ID 1586 B = IB 1587C 1588 ISYMA = ISYMID 1589 ISYMB = ISYMIB 1590C 1591 ISYMAB = MULD2H(ISYMA,ISYMB) 1592 JSCKLI = MULD2H(ISYMAB,ISYMIM) 1593C 1594 LENGTH = NCKIJ(JSCKLI) 1595C 1596C---------------------------------- 1597C Setup combinations of smat's. 1598C---------------------------------- 1599C 1600c CALL CC_GATHER(LENGTH,TMAT,SMAT,INDSQ(1,5)) 1601C 1602c CALL CC_GATHER(LENGTH,WORK,SMAT,INDSQ(1,2)) 1603c CALL DAXPY(LENGTH,-TWO,WORK,1,TMAT,1) 1604C 1605c CALL CC_GATHER(LENGTH,WORK,SMAT,INDSQ(1,3)) 1606c CALL DAXPY(LENGTH,ONE,WORK,1,TMAT,1) 1607C 1608 DO I = 1,LENGTH 1609C 1610 TMAT(I) = SMAT(INDSQ(I,5)) 1611 * - TWO*SMAT(INDSQ(I,2)) 1612 * + SMAT(INDSQ(I,3)) 1613C 1614 ENDDO 1615C 1616 IF (IPRINT .GT. 55) THEN 1617 XTMAT = DDOT(NCKIJ(JSAIKL),TMAT,1,TMAT,1) 1618 WRITE(LUPRI,*) 'In CC3_CONOCC3: 3. Norm of TMAT = ',XTMAT 1619 ENDIF 1620C 1621C----------------------- 1622C Third contraction. 1623C----------------------- 1624C 1625 DO 600 ISYMJ = 1,NSYM 1626C 1627 ISYMBJ = MULD2H(ISYMB,ISYMJ) 1628 ISYMAI = MULD2H(ISYMBJ,ISYRES) 1629 ISYMI = MULD2H(ISYMAI,ISYMA) 1630 ISYCKL = MULD2H(ISYMI,JSCKLI) 1631C 1632 IF (LWORK .LT. NRHF(ISYMI)*NRHF(ISYMJ)) THEN 1633 CALL QUIT('Insufficient memory in CC3_CONOCC3') 1634 END IF 1635C 1636 NTOCKL = MAX(NCKI(ISYCKL),1) 1637 NRHFI = MAX(NRHF(ISYMI),1) 1638C 1639 KOFF1 = ISAIKJ(ISYCKL,ISYMI) + 1 1640 KOFF2 = ISAIKJ(ISYCKL,ISYMJ) + 1 1641 KOFF3 = 1 1642C 1643 CALL DGEMM('T','N',NRHF(ISYMI),NRHF(ISYMJ),NCKI(ISYCKL), 1644 * ONE,TMAT(KOFF1),NTOCKL,TROCC1(KOFF2),NTOCKL, 1645 * ZERO,WORK(KOFF3),NRHFI) 1646C 1647 DO 610 J = 1,NRHF(ISYMJ) 1648C 1649 NBJ = IT1AM(ISYMB,ISYMJ) + NVIR(ISYMB)*(J - 1) + B 1650C 1651 IF (ISYMAI.EQ.ISYMBJ) THEN 1652C 1653 DO 620 I = 1,NRHF(ISYMI) 1654C 1655 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + A 1656C 1657 KOFF5 = IT2AM(ISYMAI,ISYMBJ) 1658 * + INDEX(NAI,NBJ) 1659C 1660 KOFF6 = NRHF(ISYMI)*(J - 1) + I 1661C 1662 IF (NAI .EQ. NBJ) THEN 1663 OMEGA2P(KOFF5) = OMEGA2P(KOFF5) - TWO*WORK(KOFF6) 1664 OMEGA2M(KOFF5) = ZERO 1665 ELSE IF (NAI .LT. NBJ) THEN 1666 OMEGA2P(KOFF5) = OMEGA2P(KOFF5) - WORK(KOFF6) 1667 OMEGA2M(KOFF5) = OMEGA2M(KOFF5) + HALF*WORK(KOFF6) 1668 ELSE IF (NAI .GT. NBJ) THEN 1669 OMEGA2P(KOFF5) = OMEGA2P(KOFF5) - WORK(KOFF6) 1670 OMEGA2M(KOFF5) = OMEGA2M(KOFF5) - HALF*WORK(KOFF6) 1671 ENDIF 1672C 1673 620 CONTINUE 1674C 1675 ELSE IF (ISYMAI .LT. ISYMBJ) THEN 1676C 1677 DO 630 I = 1,NRHF(ISYMI) 1678C 1679 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + A 1680C 1681 KOFF5 = IT2AM(ISYMAI,ISYMBJ) 1682 * + NT1AM(ISYMAI)*(NBJ-1) + NAI 1683C 1684 KOFF6 = NRHF(ISYMI)*(J - 1) + I 1685 OMEGA2P(KOFF5) = OMEGA2P(KOFF5) - WORK(KOFF6) 1686 OMEGA2M(KOFF5) = OMEGA2M(KOFF5) + HALF*WORK(KOFF6) 1687C 1688 630 CONTINUE 1689C 1690 ELSE IF (ISYMBJ .LT. ISYMAI) THEN 1691C 1692 DO 640 I = 1,NRHF(ISYMI) 1693C 1694 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + A 1695C 1696 KOFF5 = IT2AM(ISYMAI,ISYMBJ) 1697 * + NT1AM(ISYMBJ)*(NAI-1) + NBJ 1698C 1699 KOFF6 = NRHF(ISYMI)*(J - 1) + I 1700 OMEGA2P(KOFF5) = OMEGA2P(KOFF5) - WORK(KOFF6) 1701 OMEGA2M(KOFF5) = OMEGA2M(KOFF5) - HALF*WORK(KOFF6) 1702C 1703 640 CONTINUE 1704C 1705 ENDIF 1706C 1707 610 CONTINUE 1708C 1709 600 CONTINUE 1710C 1711 CALL QEXIT('CC3_CONOCC3') 1712C 1713 RETURN 1714 END 1715C /* Deck cc3_convir3 */ 1716 SUBROUTINE CC3_CONVIR3(RMAT,SMAT,QMAT,TMAT,ISYMIM,TRVIR, 1717 * TRVIR1,ISYINT,WORK,LWORK,INDSQ,LENSQ, 1718 * ISYMB,B,ISYMD,D) 1719C 1720C Henrik Koch and Alfredo Sanchez. Dec 1994 1721C 1722C Set up combinations of Q's and S's and contract with integrals. 1723C 1724C Ove Christiansen 9-1-1996: 1725C 1726C General symmetry: ISYMIM is symmetry of SMAT and TMAT intermdiates. 1727C ISYINT is symmetry of FOCKAK and XIAJB 1728C ISYRES = ISYMIM*ISYINT 1729C 1730C K. Hald, Jan 2001, Adapted to triplet. 1731C 1732 IMPLICIT NONE 1733C 1734#include "priunit.h" 1735#include "ccorb.h" 1736#include "ccsdinp.h" 1737#include "ccsdsym.h" 1738C 1739 INTEGER ISYMIM, ISYINT, LWORK, LENSQ, ISYMB, ISYMD 1740 INTEGER KOFF1, KOFF2, KOFF3, LENGTH 1741 INTEGER KSCR1, KEND1, LWRK1 1742 INTEGER ISYRES, ISYMBD, ISCKIJ, ISYMJ, ISYMBJ, ISYMAI 1743 INTEGER ISYCKI, ISYMI, ISYMA, ISYMCK 1744 INTEGER NTOTCK, NVIRA 1745 INTEGER INDEX, INDSQ(LENSQ,6) 1746C 1747#if defined (SYS_CRAY) 1748 REAL RMAT(*),SMAT(*),QMAT(*), TMAT(*),TRVIR(*) 1749 REAL TRVIR1(*), WORK(LWORK), ZERO, ONE, TWO 1750#else 1751 DOUBLE PRECISION RMAT(*),SMAT(*),QMAT(*), TMAT(*),TRVIR(*) 1752 DOUBLE PRECISION TRVIR1(*), WORK(LWORK), ZERO, ONE, TWO 1753#endif 1754C 1755 PARAMETER (ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0) 1756C 1757C INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 1758C 1759 CALL QENTER('CC3_CONVIR3') 1760C 1761 ISYRES = MULD2H(ISYMIM,ISYINT) 1762C 1763 ISYMBD = MULD2H(ISYMB,ISYMD) 1764 ISCKIJ = MULD2H(ISYMBD,ISYMIM) 1765C 1766 LENGTH = NCKIJ(ISCKIJ) 1767C 1768C------------------------ 1769C First virtual term. 1770C------------------------ 1771C 1772 IF (LWORK .LT. NCKIJ(ISCKIJ)) THEN 1773 CALL QUIT('Insufficient core in CCSDT_CONVIR') 1774 ENDIF 1775C 1776c CALL DCOPY(LENGTH,SMAT,1,TMAT,1) 1777C 1778c CALL CC_GATHER(LENGTH,WORK,SMAT,INDSQ(1,1)) 1779c CALL DAXPY(LENGTH,-TWO,WORK,1,TMAT,1) 1780C 1781c CALL CC_GATHER(LENGTH,WORK,QMAT,INDSQ(1,1)) 1782c CALL DAXPY(LENGTH,ONE,WORK,1,TMAT,1) 1783C 1784c CALL CC_GATHER(LENGTH,WORK,SMAT,INDSQ(1,2)) 1785c CALL DAXPY(LENGTH,ONE,WORK,1,TMAT,1) 1786C 1787c CALL CC_GATHER(LENGTH,WORK,QMAT,INDSQ(1,2)) 1788c CALL DAXPY(LENGTH,-TWO,WORK,1,TMAT,1) 1789C 1790c CALL CC_GATHER(LENGTH,WORK,QMAT,INDSQ(1,3)) 1791c CALL DAXPY(LENGTH,ONE,WORK,1,TMAT,1) 1792C 1793 DO I = 1,LENGTH 1794C 1795 TMAT(I) = SMAT(I) 1796 * - TWO*SMAT(INDSQ(I,1)) 1797 * + QMAT(INDSQ(I,1)) 1798 * + SMAT(INDSQ(I,2)) 1799 * - TWO*QMAT(INDSQ(I,2)) 1800 * + QMAT(INDSQ(I,3)) 1801C 1802 ENDDO 1803C 1804C--------------------------- 1805C Contract with (ac|kd). 1806C--------------------------- 1807C 1808 DO 200 ISYMJ = 1,NSYM 1809C 1810 ISYMBJ = MULD2H(ISYMB,ISYMJ) 1811 ISYMAI = MULD2H(ISYMBJ,ISYRES) 1812 ISYCKI = MULD2H(ISCKIJ,ISYMJ) 1813C 1814 KSCR1 = 1 1815 KEND1 = KSCR1 + NT1AM(ISYMAI) 1816 LWRK1 = LWORK - KEND1 1817C 1818 IF (LWRK1 .LT. 0) THEN 1819 CALL QUIT('Insufficient work space in CCSDT_CONVIR') 1820 ENDIF 1821C 1822 DO 210 J = 1,NRHF(ISYMJ) 1823C 1824 DO 220 ISYMI = 1,NSYM 1825C 1826 ISYMCK = MULD2H(ISYCKI,ISYMI) 1827 ISYMA = MULD2H(ISYMAI,ISYMI) 1828C 1829 NTOTCK = MAX(NT1AM(ISYMCK),1) 1830 NVIRA = MAX(NVIR(ISYMA),1) 1831C 1832 KOFF1 = ICKATR(ISYMCK,ISYMA) + 1 1833 KOFF2 = ISAIKJ(ISYCKI,ISYMJ) 1834 * + NCKI(ISYCKI)*(J - 1) 1835 * + ISAIK(ISYMCK,ISYMI) + 1 1836 KOFF3 = ISAIK(ISYMAI,ISYMJ) 1837 * + NT1AM(ISYMAI)*(J - 1) 1838 * + IT1AM(ISYMA,ISYMI) + 1 1839C 1840 CALL DGEMM('T','N',NVIR(ISYMA),NRHF(ISYMI),NT1AM(ISYMCK), 1841 * ONE,TRVIR(KOFF1),NTOTCK,TMAT(KOFF2),NTOTCK, 1842 * ONE,RMAT(KOFF3),NVIRA) 1843C 1844 220 CONTINUE 1845 210 CONTINUE 1846 200 CONTINUE 1847C 1848C------------------------- 1849C Second virtual term. 1850C------------------------- 1851C 1852c CALL DCOPY(LENGTH,SMAT,1,TMAT,1) 1853c CALL DSCAL(LENGTH,-TWO,TMAT,1) 1854C 1855c CALL CC_GATHER(LENGTH,WORK,SMAT,INDSQ(1,1)) 1856c CALL DAXPY(LENGTH,ONE,WORK,1,TMAT,1) 1857C 1858c CALL CC_GATHER(LENGTH,WORK,QMAT,INDSQ(1,2)) 1859c CALL DAXPY(LENGTH,ONE,WORK,1,TMAT,1) 1860C 1861c CALL CC_GATHER(LENGTH,WORK,QMAT,INDSQ(1,3)) 1862c CALL DAXPY(LENGTH,-TWO,WORK,1,TMAT,1) 1863C 1864c CALL CC_GATHER(LENGTH,WORK,QMAT,INDSQ(1,4)) 1865c CALL DAXPY(LENGTH,ONE,WORK,1,TMAT,1) 1866C 1867c CALL CC_GATHER(LENGTH,WORK,SMAT,INDSQ(1,5)) 1868c CALL DAXPY(LENGTH,ONE,WORK,1,TMAT,1) 1869C 1870 DO I = 1,LENGTH 1871C 1872 TMAT(I) = - TWO*SMAT(I) 1873 * + SMAT(INDSQ(I,1)) 1874 * + QMAT(INDSQ(I,2)) 1875 * - TWO*QMAT(INDSQ(I,3)) 1876 * + QMAT(INDSQ(I,4)) 1877 * + SMAT(INDSQ(I,5)) 1878C 1879 ENDDO 1880C 1881C--------------------------- 1882C Contract with (ad|kc). 1883C--------------------------- 1884C 1885 DO 300 ISYMJ = 1,NSYM 1886C 1887 ISYMBJ = MULD2H(ISYMB,ISYMJ) 1888 ISYMAI = MULD2H(ISYMBJ,ISYRES) 1889 ISYCKI = MULD2H(ISCKIJ,ISYMJ) 1890C 1891 KSCR1 = 1 1892 KEND1 = KSCR1 + NT1AM(ISYMAI) 1893 LWRK1 = LWORK - KEND1 1894C 1895 IF (LWRK1 .LT. 0) THEN 1896 CALL QUIT('Insufficient work space in CCSDT_CONVIR') 1897 ENDIF 1898C 1899 DO 310 J = 1,NRHF(ISYMJ) 1900C 1901 DO 320 ISYMI = 1,NSYM 1902C 1903 ISYMCK = MULD2H(ISYCKI,ISYMI) 1904 ISYMA = MULD2H(ISYMAI,ISYMI) 1905C 1906 NTOTCK = MAX(NT1AM(ISYMCK),1) 1907 NVIRA = MAX(NVIR(ISYMA),1) 1908C 1909 KOFF1 = ICKATR(ISYMCK,ISYMA) + 1 1910 KOFF2 = ISAIKJ(ISYCKI,ISYMJ) 1911 * + NCKI(ISYCKI)*(J - 1) 1912 * + ISAIK(ISYMCK,ISYMI) + 1 1913 KOFF3 = ISAIK(ISYMAI,ISYMJ) 1914 * + NT1AM(ISYMAI)*(J - 1) 1915 * + IT1AM(ISYMA,ISYMI) + 1 1916C 1917 CALL DGEMM('T','N',NVIR(ISYMA),NRHF(ISYMI),NT1AM(ISYMCK), 1918 * ONE,TRVIR1(KOFF1),NTOTCK,TMAT(KOFF2),NTOTCK, 1919 * ONE,RMAT(KOFF3),NVIRA) 1920C 1921 320 CONTINUE 1922 310 CONTINUE 1923 300 CONTINUE 1924C 1925 CALL QEXIT('CC3_CONVIR3') 1926C 1927 RETURN 1928 END 1929C /* Deck cc3_omeg33 */ 1930 SUBROUTINE CC3_OMEG33(ECURR,OMEGA1,OMEGA2P,OMEGA2M, 1931 * T1AM,ISYMT1,T2TP, 1932 * ISYMT2,C2AMP,C2AMM,ISYMC2,ISYMT12, 1933 * FOCK,XLAMDP,XLAMDH,WORK,LWORK,LU3SRT,FN3SRT, 1934 * LU3VI,FN3VI,LU3VI2,FN3VI2,LUCKJD,FNCKJD, 1935 * LUCKJD2,FNCKJD2,LUCKJD3,FNCKJD3, 1936 * LU3SRT2,FN3SRT2,LU3SRT3,FN3SRT3,LUTOC,FNTOC) 1937C 1938C K. Hald, Spring 2001. 1939C 1940C Based on CC3_OMEG 1941C 1942C Add the triples contribution to the result vectors 1943C 1944C 1945C ISYMT2 is symmetry of T2TP 1946C ISYMT1 is symmetry of T1AM input when CC3LR 1947C else ISYMT1 is symmetry of the C1 that the 1948C triples integrals have been transformed with. 1949C ISYMC2 is symmetry of C2+ and C2-. 1950C 1951C FN3VI3 and FN3VI4 are used to store various integrals, 1952C but contains name correct integrals after virtint 1953C 1954 IMPLICIT NONE 1955C 1956#include "iratdef.h" 1957#include "dummy.h" 1958#include "inftap.h" 1959#include "priunit.h" 1960#include "ccinftap.h" 1961#include "ccorb.h" 1962#include "ccsdinp.h" 1963#include "ccsdsym.h" 1964#include "second.h" 1965C 1966 INTEGER ISYMT1, ISYMT2, ISYMC2, ISYMT12, LWORK, ISYMTR, ISYMTR2 1967 INTEGER KEND0, LWRK0, KEND1, LWRK1, KEND2, LWRK2, KEND3, LWRK3 1968 INTEGER KEND4, LWRK4, BSTART, BEND, IOPT 1969 INTEGER KOFF1, KOFF2, ISYMIM, ISYRES, ISYOPE, LENSQ, LENGTH 1970 INTEGER KSMAT, KSMAT2, KQMAT, KDIAG, KINDSQ, KINDEX, KINDEX2 1971 INTEGER KINDEX3, KINDEX4, KTMAT, KRMAT1, KRMAT2, KRMAT3, KRMAT4 1972 INTEGER KCMO, KFOCKD, ISINT1, ISINT2, ISINT22, ISYMB, ISYMD 1973 INTEGER ISYMBD, ISYALJ, ISYMC, ISYMK, IOFF, ISAIJ1, ISAIJ2 1974 INTEGER ISYCKB, ISCKB1, ISCKIJ, ISCKB2, KTRVI, KTRVI0, KTRVI1 1975 INTEGER KTRVI2, KTRVI3, KTRVI4, KTRVI5, KTRVI6, KTRVI7 1976 INTEGER KTRVIB0, KTRVIB2, KTRVIB4, KTRVIB5, KTRVIB6, KTRVIB7 1977 INTEGER KINTVI, KINTOC, KTROC, KTROC0, KTROC1, KTROC2, KTROC3 1978 INTEGER KXIAJB, KFCKAK, ISYALJ2, ISYALJ3, ISYALJ4 1979 INTEGER KTROC4, KTROC5, ISYCKD, ISCKD1, ISCKD2, ISCKD3, ISCKB3 1980 INTEGER KTRVI8, KTRVI9, KXIAJB2 1981 INTEGER KRES2P, KRES2M 1982 INTEGER KR3 1983 INTEGER LUDKBC2, LUDKBC3, LUDKBC4, LUDKBC5, LU3VI3, LU3VI4 1984 INTEGER LUDELD, LUDKBC, LU3SRT, LU3VI, LU3VI2, LUCKJD 1985 INTEGER LUCKJD2, LUCKJD3, LU3SRT2, LU3SRT3, LUTOC 1986C 1987#if defined (SYS_CRAY) 1988 REAL OMEGA1(*), OMEGA2P(*), OMEGA2M(*), T1AM(*) 1989 REAL T2TP(*), C2AMP(*), C2AMM(*),FOCK(*),XLAMDP(*) 1990 REAL XLAMDH(*),WORK(LWORK), RHO1N, RHO2N 1991 REAL XIAJB, XINT, XTROC, XTROC0, XTROC1, XT2TP 1992 REAL XTRVI, XTRVI0, XTRVI1, XTRVI2, XTRVI3 1993 REAL XSMAT, XTMAT, XQMAT, XRMAT, XDIA, XFD 1994 REAL TITRAN, TISORT, TISMAT, TICONV, TICONO, TIIO, TIVINT, TIOME1 1995 REAL TIME1P, TIME2P,TIME3P, TIME1M, TIME2M, TSORTP, TSORTM 1996 REAL XTIME, DTIME, DDOT, XMONE, FACTOR, ONE, ECURR 1997#else 1998 DOUBLE PRECISION OMEGA1(*), OMEGA2P(*), OMEGA2M(*), T1AM(*) 1999 DOUBLE PRECISION T2TP(*), C2AMP(*), C2AMM(*),FOCK(*),XLAMDP(*) 2000 DOUBLE PRECISION XLAMDH(*),WORK(LWORK), RHO1N, RHO2N 2001 DOUBLE PRECISION XIAJB, XINT, XTROC, XTROC0, XTROC1, XT2TP 2002 DOUBLE PRECISION XTRVI, XTRVI0, XTRVI1, XTRVI2, XTRVI3 2003 DOUBLE PRECISION XSMAT, XTMAT, XQMAT, XRMAT, XDIA, XFD 2004 DOUBLE PRECISION TITRAN, TISORT, TISMAT, TICONV, TICONO, TIIO 2005 DOUBLE PRECISION TIVINT, TIOME1 2006 DOUBLE PRECISION TIME1P, TIME2P, TIME3P, TIME1M, TIME2M 2007 DOUBLE PRECISION TSORTP, TSORTM 2008 DOUBLE PRECISION XTIME, DTIME, DDOT, XMONE, FACTOR, ONE, ECURR 2009#endif 2010C 2011 PARAMETER (XMONE = -1.0D0, ONE = 1.0D0) 2012C 2013 LOGICAL LDEBUG 2014C 2015 CHARACTER*12 FNDKBC2, FNDKBC3, FNDKBC4, FNDKBC5, FN3VI3, FN3VI4 2016 CHARACTER*12 FNDELD, FNDKBC 2017 CHARACTER*1 CDUMMY 2018 CHARACTER*(*) FN3SRT, FN3VI, FN3VI2, FNCKJD, FNCKJD2, FNCKJD3 2019 CHARACTER*(*) FN3SRT2, FN3SRT3, FNTOC 2020C 2021 CALL QENTER('CC3_OMEG33') 2022C 2023 LDEBUG = .FALSE. 2024C 2025 CDUMMY = ' ' 2026C 2027C------------------------------------------------------------- 2028C Set symmetry flags. 2029C 2030C omega = int1*T2*int2 2031C isymres is symmetry of result(omega) 2032C isint1 is symmetry of integrals in contraction. 2033C isint2 is symmetry of integrals in the triples equation 2034C used with T2. 2035C isintt12 is symmetry of integrals in contraction 2036C isint22 is symmetry of integrals in the triples equation 2037C used with C2AMP and C2AMM. 2038C isymim is symmetry of S and Q intermediates.(t2*int2) 2039C (sym is for all index of S and Q (cbd,klj) 2040C thus cklj=b*d*isymim) 2041C------------------------------------------------------------- 2042C 2043 IPRCC = IPRINT 2044 ISYMTR = MULD2H(ISYMT1,ISYMT2) 2045 ISYMTR2 = MULD2H(ISYMT12,ISYMC2) 2046 IF (ISYMTR .NE. ISYMTR2) THEN 2047 CALL QUIT('Symmetry error in CC3_OMEG33') 2048 ENDIF 2049 ISYRES = MULD2H(ISYMTR,ISYMOP) 2050 ISINT1 = ISYMOP 2051 ISINT2 = MULD2H(ISYMT1,ISYMOP) 2052 ISINT22 = MULD2H(ISYMT12,ISYMOP) 2053 ISYMIM = MULD2H(ISYMTR,ISYMOP) 2054 IF (CC3LR) THEN 2055 ISINT1 = MULD2H(ISYMT1,ISYMOP) 2056 ISINT2 = ISYMOP 2057 ISYMIM = ISYMOP 2058 ENDIF 2059C 2060 IF (IPRINT .GT. 20 .OR. LDEBUG) THEN 2061 WRITE(LUPRI,*) ' In CC3_OMEG33: CC1A = ',CC1A 2062 WRITE(LUPRI,*) ' In CC3_OMEG33: CC1B = ',CC1B 2063 WRITE(LUPRI,*) ' In CC3_OMEG33: CC3 = ',CC3 2064 WRITE(LUPRI,*) ' In CC3_OMEG33: CC3LR = ',CC3LR 2065 WRITE(LUPRI,*) ' In CC3_OMEG33: ISYMT1 , ISYMT2:',ISYMT1,ISYMT2 2066 WRITE(LUPRI,*) ' In CC3_OMEG33: ISYMT12, ISYMC2:',ISYMT12,ISYMT2 2067 WRITE(LUPRI,*) ' In CC3_OMEG33: ISYRES , ISYMOP:',ISYRES,ISYMOP 2068 WRITE(LUPRI,*) ' In CC3_OMEG33: ISINT1 , ISINT2:',ISINT1,ISINT2 2069 WRITE(LUPRI,*) ' In CC3_OMEG33: ISINT22 ',ISINT22 2070 ENDIF 2071C 2072C-------------------- 2073C Time variables. 2074C-------------------- 2075C 2076 TITRAN = 0.0D0 2077 TISORT = 0.0D0 2078 TISMAT = 0.0D0 2079 TICONO = 0.0D0 2080 TIVINT = 0.0D0 2081 TIIO = 0.0D0 2082 TICONV = 0.0D0 2083 TIME1P = 0.0D0 2084 TIME2P = 0.0D0 2085 TIME3P = 0.0D0 2086 TIME1M = 0.0D0 2087 TIME2M = 0.0D0 2088 TSORTP = 0.0D0 2089 TSORTM = 0.0D0 2090 TIOME1 = 0.0D0 2091C 2092C------------------------------- 2093C Open temp. files. 2094C------------------------------- 2095C 2096 LUDKBC2 = -1 2097 LUDKBC3 = -1 2098 LUDKBC4 = -1 2099 LUDKBC5 = -1 2100 LU3VI3 = -1 2101 LU3VI4 = -1 2102 LUDELD = -1 2103 LUDKBC = -1 2104C 2105 FNDKBC2 = 'CC3_OMEG33_1' 2106 FNDKBC3 = 'CC3_OMEG33_2' 2107 FNDKBC4 = 'CC3_OMEG33_3' 2108 FNDKBC5 = 'CC3_OMEG33_4' 2109 FN3VI3 = 'CC3_OMEG33_5' 2110 FN3VI4 = 'CC3_OMEG33_6' 2111 FNDELD = 'CC3_OMEG33_7' 2112 FNDKBC = 'CC3_OMEG33_8' 2113C 2114 CALL WOPEN2(LUDKBC2,FNDKBC2,64,0) 2115 CALL WOPEN2(LUDKBC3,FNDKBC3,64,0) 2116 CALL WOPEN2(LUDKBC4,FNDKBC4,64,0) 2117 CALL WOPEN2(LUDKBC5,FNDKBC5,64,0) 2118 CALL WOPEN2(LU3VI3,FN3VI3,64,0) 2119 CALL WOPEN2(LU3VI4,FN3VI4,64,0) 2120 CALL WOPEN2(LUDELD,FNDELD,64,0) 2121 CALL WOPEN2(LUDKBC,FNDKBC,64,0) 2122C 2123C-------------------------------------------------- 2124C Allocate and initialise two result vectors 2125C-------------------------------------------------- 2126C 2127 KRES2P = 1 2128 KRES2M = KRES2P + NT2SQ(ISYRES) 2129 KEND0 = KRES2M + NT2SQ(ISYRES) 2130C 2131 CALL DZERO(WORK(KRES2P),NT2SQ(ISYRES)) 2132 CALL DZERO(WORK(KRES2M),NT2SQ(ISYRES)) 2133C 2134C--------------------------------------------------------- 2135C Transform and sort qmat integrals to smat integrals. 2136C 2137C CHECK IF THE IOPT = 2 (SORT) and IOPT = 1 (SINT) 2138C IS NECESSARY (MAYBE CALCULATED IN T3 PART) 2139C 2140C--------------------------------------------------------- 2141C 2142 CALL CC3_SORT1(WORK,LWORK,2,ISINT22,LU3SRT,FN3SRT, 2143 * LUDELD,FNDELD,IDUMMY,CDUMMY,IDUMMY,CDUMMY, 2144 * IDUMMY,CDUMMY) 2145 CALL CC3_SINT(XLAMDH,WORK,LWORK,ISINT22,LUDELD,FNDELD, 2146 * LUDKBC,FNDKBC) 2147 CALL CC3_SORT3(WORK,LWORK,1,ISINT2,LU3SRT2,FN3SRT2, 2148 * LU3SRT3,FN3SRT3,LU3VI4,FN3VI4,LU3VI3,FN3VI3) 2149 CALL CC3_SINT(XLAMDH,WORK,LWORK,ISINT2,LU3VI4,FN3VI4, 2150 * LUDKBC2,FNDKBC2) 2151 CALL CC3_SINT(XLAMDH,WORK,LWORK,ISINT2,LU3VI3,FN3VI3, 2152 * LUDKBC3,FNDKBC3) 2153 CALL CC3_SORT3(WORK,LWORK,2,ISINT2,LU3SRT2,FN3SRT2, 2154 * LU3SRT3,FN3SRT3,LU3VI4,FN3VI4,IDUMMY,CDUMMY) 2155 CALL CC3_SINT(XLAMDH,WORK,LWORK,ISINT2,LU3VI4,FN3VI4, 2156 * LUDKBC4,FNDKBC4) 2157 CALL CC3_SORT2(WORK,LWORK,ISINT22,LU3SRT,FN3SRT,LU3VI4,FN3VI4) 2158 CALL CC3_SINT(XLAMDH,WORK,LWORK,ISINT22,LU3VI4,FN3VI4, 2159 * LUDKBC5,FNDKBC5) 2160C 2161C--------------------------------------------- 2162C Reorder the t2 amplitudes in T2TP. 2163C--------------------------------------------- 2164C 2165 IF (LWORK .LT. NT2SQ(ISYMT2)) THEN 2166 CALL QUIT('Not enough memory to construct T2TP in CC3_OMEG33') 2167 ENDIF 2168C 2169 CALL DCOPY(NT2SQ(ISYMT2),T2TP,1,WORK,1) 2170 CALL CC3_T2TP(T2TP,WORK,ISYMT2) 2171C 2172 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 2173 XT2TP = DDOT(NT2SQ(ISYMT2),T2TP,1,T2TP,1) 2174 WRITE(LUPRI,*) 'Norm of T2TP ',XT2TP 2175 ENDIF 2176C 2177C----------------------------------------------------- 2178C Reorder the R2+ and R2- amplitudes in C2AMP. 2179C----------------------------------------------------- 2180C 2181 IF (LWORK .LT. NT2SQ(ISYMC2)) THEN 2182 CALL QUIT('Not enough memory to construct C2AMP in CC3_OMEG33') 2183 ENDIF 2184C 2185 CALL DCOPY(NT2SQ(ISYMC2),C2AMP,1,WORK,1) 2186 CALL CC3_T2TP(C2AMP,WORK,ISYMC2) 2187C 2188 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 2189 XT2TP = DDOT(NT2SQ(ISYMC2),C2AMP,1,C2AMP,1) 2190 WRITE(LUPRI,*) 'Norm of C2AMM ',XT2TP 2191 ENDIF 2192C 2193C 2194 IF (LWORK .LT. NT2SQ(ISYMC2)) THEN 2195 CALL QUIT('Not enough memory to construct C2AMM in CC3_OMEG33') 2196 ENDIF 2197C 2198 CALL DCOPY(NT2SQ(ISYMC2),C2AMM,1,WORK,1) 2199 CALL CC3_T2TP(C2AMM,WORK,ISYMC2) 2200C 2201 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 2202 XT2TP = DDOT(NT2SQ(ISYMC2),C2AMM,1,C2AMM,1) 2203 WRITE(LUPRI,*) 'Norm of C2AMM ',XT2TP 2204 ENDIF 2205C 2206C--------------------------------------------------------- 2207C Read canonical orbital energies and MO coefficients. 2208C--------------------------------------------------------- 2209C 2210 KFOCKD = KEND0 2211 KCMO = KFOCKD + NORBTS 2212 KFCKAK = KCMO + NLAMDS 2213 KEND0 = KFCKAK + NT1AM(ISINT1) 2214 LWRK0 = LWORK - KEND0 2215C 2216 IF (LWRK0 .LT. 0) THEN 2217 WRITE(LUPRI,*) 'Memory available : ',LWORK 2218 WRITE(LUPRI,*) 'Memory needed : ',KEND0 2219 CALL QUIT('Insufficient space in CC3_OMEG33') 2220 END IF 2221C 2222 CALL GPOPEN(LUSIFC,'SIRIFC','OLD',' ','UNFORMATTED',IDUMMY, 2223 & .FALSE.) 2224 REWIND LUSIFC 2225C 2226 CALL MOLLAB('TRCCINT ',LUSIFC,LUPRI) 2227 READ (LUSIFC) 2228 READ (LUSIFC) (WORK(KFOCKD+I-1), I=1,NORBTS) 2229 READ (LUSIFC) (WORK(KCMO+I-1), I=1,NLAMDS) 2230C 2231 CALL GPCLOSE(LUSIFC,'KEEP') 2232C 2233 CALL CMO_REORDER(WORK(KCMO),WORK(KEND0),LWRK0) 2234C 2235C--------------------------------------------- 2236C Delete frozen orbitals in Fock diagonal. 2237C--------------------------------------------- 2238C 2239 IF (FROIMP .OR. FROEXP) 2240 * CALL CCSD_DELFRO(WORK(KFOCKD),WORK(KEND0),LWRK0) 2241C 2242C------------------------------ 2243C Resort Fock matrix F(kc). 2244C------------------------------ 2245C 2246 DO 50 ISYMC = 1,NSYM 2247C 2248 ISYMK = MULD2H(ISYMC,ISYMOP) 2249C 2250 DO 60 K = 1,NRHF(ISYMK) 2251C 2252 DO 70 C = 1,NVIR(ISYMC) 2253C 2254 KOFF1 = IFCVIR(ISYMK,ISYMC) + NORB(ISYMK)*(C - 1) + K 2255 KOFF2 = KFCKAK + IT1AM(ISYMC,ISYMK) 2256 * + NVIR(ISYMC)*(K - 1) + C - 1 2257C 2258 WORK(KOFF2) = FOCK(KOFF1) 2259C 2260 70 CONTINUE 2261 60 CONTINUE 2262 50 CONTINUE 2263C 2264C--------------------------------------------------------- 2265C Transform the "virtual" integrals and store them 2266C on file. 2267C--------------------------------------------------------- 2268C 2269 DTIME = SECOND() 2270 CALL CC3_VIRTINT(XLAMDP,WORK(KEND0),LWRK0,ISINT1,ISINT2, 2271 * LU3VI,FN3VI,LU3VI2,FN3VI2,LU3VI4,FN3VI4, 2272 * LU3VI3,FN3VI3) 2273 DTIME = SECOND() - DTIME 2274 TIVINT = TIVINT + DTIME 2275C 2276C----------------------------- 2277C Read occupied integrals. 2278C----------------------------- 2279C 2280C Memory allocation. 2281C 2282 KTROC = KEND0 2283 KTROC1 = KTROC + NTRAOC(ISINT1) 2284 KTROC0 = KTROC1 + NTRAOC(ISINT1) 2285 KTROC2 = KTROC0 + NTRAOC(ISINT22) 2286 KTROC3 = KTROC2 + NTRAOC(ISINT2) 2287 KXIAJB = KTROC3 + NTRAOC(ISINT2) 2288 KXIAJB2 = KXIAJB + NT2AM(ISYMOP) 2289 KEND1 = KXIAJB2 + NT2AM(ISYMOP) 2290C 2291 IF (LDEBUG) THEN 2292 KR3 = KEND1 2293 KEND1 = KR3 + NVIRT*NVIRT*NVIRT*NRHFT*NRHFT*NRHFT 2294 CALL DZERO(WORK(KR3),NVIRT*NVIRT*NVIRT*NRHFT*NRHFT*NRHFT) 2295 ENDIF 2296C 2297 KTROC4 = KEND1 2298 KTROC5 = KTROC4 + MAX(NTRAOC(ISINT2),NTRAOC(ISINT22)) 2299 KEND1 = KTROC5 + NTRAOC(ISINT2) 2300 LWRK1 = LWORK - KEND1 2301C 2302 KINTOC = KEND1 2303 KEND2 = KINTOC + MAX(NTOTOC(ISYMOP),NTOTOC(ISINT2)) 2304 LWRK2 = LWORK - KEND2 2305C 2306 IF (LWRK2 .LT. 0) THEN 2307 WRITE(LUPRI,*) 'Memory available : ',LWORK 2308 WRITE(LUPRI,*) 'Memory needed : ',KEND2 2309 CALL QUIT('Insufficient space in CC3_OMEG33') 2310 END IF 2311C 2312C--------------------------------- 2313C Construct -Exchange(ia,jb) 2314C--------------------------------- 2315C 2316 LENGTH = IRAT*NT2AM(ISYMOP) 2317C 2318 REWIND(LUIAJB) 2319 CALL READI(LUIAJB,LENGTH,WORK(KXIAJB)) 2320C 2321 ISYOPE = ISYMOP 2322 IOPT = 2 2323 CALL CCSD_TCMEPK(WORK(KXIAJB),1.0D0,ISYOPE,IOPT) 2324C 2325C------------------------ 2326C Occupied integrals. 2327C------------------------ 2328C 2329 DTIME = SECOND() 2330 IOFF = 1 2331 IF (NTOTOC(ISYMOP) .GT. 0) THEN 2332 CALL GETWA2(LUTOC,FNTOC,WORK(KINTOC),IOFF,NTOTOC(ISYMOP)) 2333 ENDIF 2334 DTIME = SECOND() - DTIME 2335 TIIO = TIIO + DTIME 2336C 2337C---------------------------------- 2338C Write out norms of Integrals. 2339C---------------------------------- 2340C 2341 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 2342 XINT = DDOT(NTOTOC(ISYMOP),WORK(KINTOC),1, 2343 * WORK(KINTOC),1) 2344 WRITE(LUPRI,*) 'Norm of CC3_OMEG33_OC-INT ',XINT 2345 ENDIF 2346C 2347C---------------------------------------------------------------------- 2348C Transform (ia|j delta) integrals to (ia|j k) and sort as (ij,k,a) 2349C---------------------------------------------------------------------- 2350C 2351 DTIME = SECOND() 2352 CALL CCSDT_TROCC(WORK(KINTOC),WORK(KTROC),XLAMDH, 2353 * WORK(KEND2),LWRK2) 2354 DTIME = SECOND() - DTIME 2355 TITRAN = TITRAN + DTIME 2356C 2357C------------------------------------ 2358C Read in integrals part 2. 2359C------------------------------------ 2360C 2361 DTIME = SECOND() 2362 IOFF = 1 2363 IF (NTOTOC(ISINT2) .GT. 0) THEN 2364 CALL GETWA2(LUCKJD2,FNCKJD2,WORK(KINTOC),IOFF, 2365 * NTOTOC(ISINT2)) 2366 ENDIF 2367 DTIME = SECOND() - DTIME 2368 TIIO = TIIO + DTIME 2369C 2370C 2371C---------------------------------------------------------------------- 2372C Transform (ia|j delta) integrals to (ia|j k) and sort as (ik,j,a) 2373C---------------------------------------------------------------------- 2374C 2375 DTIME = SECOND() 2376 CALL CC3_TROCC(WORK(KINTOC),WORK(KTROC2),WORK(KCMO), 2377 * WORK(KEND2),LWRK2,ISINT2) 2378 DTIME = SECOND() - DTIME 2379 TIIO = TIIO + DTIME 2380C 2381C------------------------------------ 2382C Read in integrals part 3. 2383C------------------------------------ 2384C 2385 DTIME = SECOND() 2386 IOFF = 1 2387 IF (NTOTOC(ISINT2) .GT. 0) THEN 2388 CALL GETWA2(LUCKJD3,FNCKJD3,WORK(KINTOC),IOFF, 2389 * NTOTOC(ISINT2)) 2390 ENDIF 2391 DTIME = SECOND() - DTIME 2392 TIIO = TIIO + DTIME 2393C 2394C---------------------------------------------------------------------- 2395C Transform (ia|j delta) integrals to (ia|j k) and sort as (ik,j,a) 2396C---------------------------------------------------------------------- 2397C 2398 DTIME = SECOND() 2399 CALL CC3_TROCC3(WORK(KINTOC),WORK(KTROC3),WORK(KTROC4), 2400 * WORK(KCMO),WORK(KEND2),LWRK2,ISINT2) 2401C 2402 DTIME = SECOND() - DTIME 2403 TITRAN = TITRAN + DTIME 2404C 2405C--------------------------------------------------- 2406C Construct the special occupied integrals. 2407C (g^3 and g^4) 2408C--------------------------------------------------- 2409C 2410 DTIME = SECOND() 2411 CALL DAXPY(NTRAOC(ISINT2),XMONE,WORK(KTROC2),1,WORK(KTROC3),1) 2412 CALL DAXPY(NTRAOC(ISINT2),XMONE,WORK(KTROC4),1,WORK(KTROC2),1) 2413C 2414 CALL CCSDT_SRTOC3(WORK(KTROC3),WORK(KTROC5),ISINT2, 2415 * WORK(KEND2),LWRK2) 2416C 2417 DTIME = SECOND() - DTIME 2418 TISORT = TISORT + DTIME 2419C 2420C----------------------- 2421C Read in integrals. 2422C----------------------- 2423C 2424 DTIME = SECOND() 2425 IOFF = 1 2426 IF (NTOTOC(ISINT22) .GT. 0) THEN 2427 CALL GETWA2(LUCKJD,FNCKJD,WORK(KINTOC),IOFF,NTOTOC(ISINT22)) 2428 ENDIF 2429 DTIME = SECOND() - DTIME 2430 TIIO = TIIO + DTIME 2431C 2432C---------------------------------------------------------------------- 2433C Transform (ia|j delta) integrals to (ia|j k) and sort as (ik,j,a) 2434C---------------------------------------------------------------------- 2435C 2436 DTIME = SECOND() 2437 CALL CC3_TROCC(WORK(KINTOC),WORK(KTROC0),WORK(KCMO), 2438 * WORK(KEND2),LWRK2,ISINT22) 2439C 2440 DTIME = SECOND() - DTIME 2441 TITRAN = TITRAN + DTIME 2442 2443C 2444 DTIME = SECOND() 2445C 2446 CALL CCSDT_SRTOC2(WORK(KTROC),WORK(KTROC1),ISINT1, 2447 * WORK(KEND2),LWRK2) 2448C 2449 CALL DZERO(WORK(KTROC4),MAX(NTRAOC(ISINT2),NTRAOC(ISINT22))) 2450 CALL CCSDT_SRTOC3(WORK(KTROC0),WORK(KTROC4),ISINT22, 2451 * WORK(KEND2),LWRK2) 2452C 2453 DTIME = SECOND() - DTIME 2454 TISORT = TISORT + DTIME 2455C 2456C 2457C------------------------------- 2458C Write out norms of arrays. 2459C------------------------------- 2460C 2461 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 2462C 2463 XTROC = DDOT(NTRAOC(ISINT1),WORK(KTROC),1, 2464 * WORK(KTROC),1) 2465 WRITE(LUPRI,*) 'Norm of TROC ',XTROC 2466C 2467 XTROC0 = DDOT(NTRAOC(ISINT22),WORK(KTROC0),1, 2468 * WORK(KTROC0),1) 2469 WRITE(LUPRI,*) 'Norm of TROC0 ',XTROC0 2470C 2471 XTROC1 = DDOT(NTRAOC(ISINT1),WORK(KTROC1),1, 2472 * WORK(KTROC1),1) 2473 WRITE(LUPRI,*) 'Norm of TROC1 ',XTROC1 2474C 2475 XTROC0 = DDOT(NTRAOC(ISINT2),WORK(KTROC2),1, 2476 * WORK(KTROC2),1) 2477 WRITE(LUPRI,*) 'Norm of TROC2 ',XTROC0 2478C 2479 XTROC0 = DDOT(NTRAOC(ISINT2),WORK(KTROC3),1, 2480 * WORK(KTROC3),1) 2481 WRITE(LUPRI,*) 'Norm of TROC3 ',XTROC0 2482C 2483 XTROC0 = DDOT(NTRAOC(ISINT22),WORK(KTROC4),1, 2484 * WORK(KTROC4),1) 2485 WRITE(LUPRI,*) 'Norm of TROC4 ',XTROC0 2486C 2487 XINT = DDOT(NTOTOC(ISINT2),WORK(KINTOC),1, 2488 * WORK(KINTOC),1) 2489 WRITE(LUPRI,*) 'Norm of CKJDEL-INT ',XINT 2490C 2491 ENDIF 2492C 2493C---------------------------- 2494C General loop structure. 2495C---------------------------- 2496C 2497 DO 100 ISYMD = 1,NSYM 2498C 2499 ISAIJ1 = MULD2H(ISYMD,ISYRES) 2500 ISYCKB = MULD2H(ISYMD,ISYMOP) 2501 ISCKB1 = MULD2H(ISINT1,ISYMD) 2502 ISCKB2 = MULD2H(ISINT2,ISYMD) 2503 ISCKB3 = MULD2H(ISINT22,ISYMD) 2504 ISYALJ3= MULD2H(ISYMD,ISYMT2) 2505 ISYALJ4= MULD2H(ISYMD,ISYMC2) 2506C 2507 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 2508C 2509 WRITE(LUPRI,*) 'In CC3_OMEG33: ISAIJ1:',ISAIJ1 2510 WRITE(LUPRI,*) 'In CC3_OMEG33: ISYCKB:',ISYCKB 2511 WRITE(LUPRI,*) 'In CC3_OMEG33: ISCKB1:',ISCKB1 2512 WRITE(LUPRI,*) 'In CC3_OMEG33: ISCKB2:',ISCKB2 2513 WRITE(LUPRI,*) 'In CC3_OMEG33: ISCKB3:',ISCKB3 2514C 2515 ENDIF 2516C 2517C-------------------------- 2518C Memory allocation. 2519C-------------------------- 2520C 2521 KTRVI = KEND1 2522 KTRVI1 = KTRVI + NCKATR(ISCKB1) 2523 KTRVI2 = KTRVI1 + NCKATR(ISCKB1) 2524 KRMAT1 = KTRVI2 + NCKATR(ISCKB3) 2525 KRMAT3 = KRMAT1 + NCKI(ISAIJ1) 2526 KEND2 = KRMAT3 + NCKI(ISAIJ1) 2527 LWRK2 = LWORK - KEND2 2528C 2529 KTRVI0 = KEND2 2530 KTRVI3 = KTRVI0 + NCKATR(ISCKB3) 2531 KTRVI4 = KTRVI3 + NCKATR(ISCKB2) 2532 KTRVI5 = KTRVI4 + NCKATR(ISCKB2) 2533 KTRVI6 = KTRVI5 + NCKATR(ISCKB2) 2534 KTRVI7 = KTRVI6 + MAX(NCKATR(ISCKB2),NCKATR(ISCKB3)) 2535 KINDEX3= KTRVI7 + NCKATR(ISCKB3) 2536 KINDEX4= KINDEX3 + (NCKI(ISYALJ3) - 1)/IRAT + 1 2537 KEND3 = KINDEX4 + (NCKI(ISYALJ4) - 1)/IRAT + 1 2538 LWRK3 = LWORK - KEND3 2539C 2540 KINTVI = KEND3 2541 KEND4 = KINTVI + MAX(NCKA(ISYMD),NCKA(ISCKB2)) 2542 LWRK4 = LWORK - KEND4 2543C 2544 IF (LWRK4 .LT. 0) THEN 2545 WRITE(LUPRI,*) 'Memory available : ',LWORK 2546 WRITE(LUPRI,*) 'Memory needed : ',KEND4 2547 CALL QUIT('Insufficient space in CC3_OMEG33') 2548 END IF 2549C 2550C------------------------------------------ 2551C Construct the first index arrays. 2552C------------------------------------------ 2553C 2554 CALL CC3_INDEX(WORK(KINDEX3),ISYALJ3) 2555 CALL CC3_INDEX(WORK(KINDEX4),ISYALJ4) 2556C 2557C----------------------------------------------------------- 2558C Initialise the result vectors for cc3_convir33. 2559C----------------------------------------------------------- 2560C 2561 CALL DZERO(WORK(KRES2P),NT2SQ(ISYRES)) 2562 CALL DZERO(WORK(KRES2M),NT2SQ(ISYRES)) 2563C 2564C-------------------------- 2565C Sum over D. 2566C-------------------------- 2567C 2568 DO 110 D = 1,NVIR(ISYMD) 2569C 2570 CALL DZERO(WORK(KRMAT1),NCKI(ISAIJ1)) 2571 CALL DZERO(WORK(KRMAT3),NCKI(ISAIJ1)) 2572C 2573C------------------------------------------------------------ 2574C Read and transform integrals used in contraction. 2575C The integrals are stored transformed! 2576C------------------------------------------------------------ 2577C 2578 DTIME = SECOND() 2579C 2580 IOFF = ICKBD(ISYCKB,ISYMD) + NCKATR(ISYCKB)*(D - 1) + 1 2581 IF (NCKATR(ISYCKB) .GT. 0) THEN 2582 CALL GETWA2(LU3VI3,FN3VI3,WORK(KTRVI),IOFF, 2583 & NCKATR(ISYCKB)) 2584 ENDIF 2585C 2586C----------------------------------------------------------- 2587C Read virtual integrals used in s3am part 1. 2588C----------------------------------------------------------- 2589C 2590 IOFF = ICKBD(ISCKB3,ISYMD) + NCKATR(ISCKB3)*(D - 1) + 1 2591 IF (NCKATR(ISCKB3) .GT. 0) THEN 2592 CALL GETWA2(LUDKBC,FNDKBC,WORK(KTRVI0),IOFF, 2593 & NCKATR(ISCKB3)) 2594C 2595 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 2596 XTRVI0= DDOT(NCKATR(ISCKB3),WORK(KTRVI0),1, 2597 * WORK(KTRVI0),1) 2598 WRITE(LUPRI,*) 'Norm of TRVI0 readin',XTRVI0 2599 ENDIF 2600 ENDIF 2601C 2602 DTIME = SECOND() - DTIME 2603 TIIO = TIIO + DTIME 2604C 2605C--------------------------------------- 2606C Sort the integrals for s3am. 2607C--------------------------------------- 2608C 2609 DTIME = SECOND() 2610 CALL CCSDT_SRTVIR(WORK(KTRVI0),WORK(KTRVI2),WORK(KEND4), 2611 * LWRK4,ISYMD,ISINT22) 2612C 2613 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 2614 XTRVI0= DDOT(NCKATR(ISCKB3),WORK(KTRVI0),1, 2615 * WORK(KTRVI0),1) 2616 WRITE(LUPRI,*) 'Norm of TRVI0 ',XTRVI0 2617C 2618 XTRVI2= DDOT(NCKATR(ISCKB3),WORK(KTRVI2),1, 2619 * WORK(KTRVI2),1) 2620 WRITE(LUPRI,*) 'Norm of TRVI2 ',XTRVI2 2621 ENDIF 2622C 2623 DTIME = SECOND() - DTIME 2624 TISORT = TISORT + DTIME 2625C 2626C----------------------------------------------------------- 2627C Read virtual integrals used in s3am part 2. 2628C----------------------------------------------------------- 2629C 2630 DTIME = SECOND() 2631 IOFF = ICKBD(ISCKB2,ISYMD) + NCKATR(ISCKB2)*(D - 1) + 1 2632 IF (NCKATR(ISCKB2) .GT. 0) THEN 2633 CALL GETWA2(LUDKBC2,FNDKBC2,WORK(KTRVI4),IOFF, 2634 & NCKATR(ISCKB2)) 2635C 2636 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 2637 XTRVI0= DDOT(NCKATR(ISCKB2),WORK(KTRVI4),1, 2638 * WORK(KTRVI4),1) 2639 WRITE(LUPRI,*) 'Norm of TRVI4 readin',XTRVI0 2640 ENDIF 2641 ENDIF 2642 DTIME = SECOND() - DTIME 2643 TIIO = TIIO + DTIME 2644C 2645C 2646C------------------------------------------------- 2647C Sort the integrals for s3am part 2. 2648C------------------------------------------------- 2649C 2650 DTIME = SECOND() 2651 CALL CCSDT_SRTVIR(WORK(KTRVI4),WORK(KTRVI5),WORK(KEND4), 2652 * LWRK4,ISYMD,ISINT2) 2653C 2654 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 2655 XTRVI2= DDOT(NCKATR(ISCKB2),WORK(KTRVI5),1, 2656 * WORK(KTRVI5),1) 2657 WRITE(LUPRI,*) 'Norm of TRVI5 ',XTRVI2 2658 ENDIF 2659C 2660 DTIME = SECOND() - DTIME 2661 TISORT = TISORT + DTIME 2662C 2663C----------------------------------------------------------- 2664C Read virtual integrals used in s3am part 2b. 2665C----------------------------------------------------------- 2666C 2667 DTIME = SECOND() 2668C 2669 IOFF = ICKBD(ISCKB2,ISYMD) + NCKATR(ISCKB2)*(D - 1) + 1 2670 IF (NCKATR(ISCKB2) .GT. 0) THEN 2671 CALL GETWA2(LUDKBC4,FNDKBC4,WORK(KTRVI6),IOFF, 2672 & NCKATR(ISCKB2)) 2673 ENDIF 2674C 2675 DTIME = SECOND() - DTIME 2676 TIIO = TIIO + DTIME 2677C 2678C---------------------------------------------------- 2679C Sort the integrals for s3am part 2b. 2680C---------------------------------------------------- 2681C 2682 DTIME = SECOND() 2683 CALL CCSDT_SRTVIR(WORK(KTRVI6),WORK(KTRVI4),WORK(KEND4), 2684 * LWRK4,ISYMD,ISINT2) 2685C 2686 DTIME = SECOND() - DTIME 2687 TISORT = TISORT + DTIME 2688C 2689 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 2690 XTRVI0= DDOT(NCKATR(ISCKB2),WORK(KTRVI4),1, 2691 * WORK(KTRVI4),1) 2692 WRITE(LUPRI,*) 'Norm of TRVI4 ',XTRVI0 2693C 2694 XTRVI2= DDOT(NCKATR(ISCKB2),WORK(KTRVI5),1, 2695 * WORK(KTRVI5),1) 2696 WRITE(LUPRI,*) 'Norm of TRVI5 ',XTRVI2 2697 ENDIF 2698C 2699C------------------------------------------------------------------- 2700C Read virtual integrals used in s3am part 3a. 2701C g integrals. Need only the transformed. 2702C------------------------------------------------------------------- 2703C 2704 DTIME = SECOND() 2705C 2706 CALL DZERO(WORK(KTRVI6),MAX(NCKATR(ISCKB2),NCKATR(ISCKB3))) 2707 IOFF = ICKBD(ISCKB3,ISYMD) + NCKATR(ISCKB3)*(D - 1) + 1 2708 IF (NCKATR(ISCKB3) .GT. 0) THEN 2709 CALL GETWA2(LUDKBC5,FNDKBC5,WORK(KTRVI6),IOFF, 2710 & NCKATR(ISCKB3)) 2711 ENDIF 2712C 2713 DTIME = SECOND() - DTIME 2714 TIIO = TIIO + DTIME 2715C 2716C--------------------------------------- 2717C Sort the integrals for s3am. 2718C--------------------------------------- 2719C 2720 DTIME = SECOND() 2721 CALL CCSDT_SRTVIR(WORK(KTRVI6),WORK(KTRVI7),WORK(KEND4), 2722 * LWRK4,ISYMD,ISINT22) 2723C 2724 DTIME = SECOND() - DTIME 2725 TISORT = TISORT + DTIME 2726C 2727 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 2728 XTRVI2= DDOT(NCKATR(ISCKB3),WORK(KTRVI7),1, 2729 * WORK(KTRVI7),1) 2730 WRITE(LUPRI,*) 'Norm of TRVI7 ',XTRVI2 2731 ENDIF 2732C 2733C------------------------------------------------------------------- 2734C Read virtual integrals used in s3am part 3b. 2735C This is the g^1 integral. Do not need the transformed. 2736C------------------------------------------------------------------- 2737C 2738 DTIME = SECOND() 2739C 2740 CALL DZERO(WORK(KTRVI6),MAX(NCKATR(ISCKB2),NCKATR(ISCKB3))) 2741 IOFF = ICKBD(ISCKB2,ISYMD) + NCKATR(ISCKB2)*(D - 1) + 1 2742 IF (NCKATR(ISCKB2) .GT. 0) THEN 2743 CALL GETWA2(LUDKBC3,FNDKBC3,WORK(KTRVI6),IOFF, 2744 & NCKATR(ISCKB2)) 2745 ENDIF 2746C 2747C----------------------------------------------------------- 2748C Read virtual integrals used in contraction. 2749C----------------------------------------------------------- 2750C 2751 IOFF = ICKBD(ISYCKB,ISYMD) + NCKATR(ISYCKB)*(D - 1) + 1 2752 IF (NCKATR(ISYCKB) .GT. 0) THEN 2753 CALL GETWA2(LU3VI4,FN3VI4,WORK(KTRVI1),IOFF, 2754 & NCKATR(ISYCKB)) 2755 ENDIF 2756C 2757C----------------------------------------------- 2758C Read virtual integrals used in q3am. 2759C----------------------------------------------- 2760C 2761 IOFF = ICKAD(ISCKB2,ISYMD) + NCKA(ISCKB2)*(D - 1) + 1 2762 IF (NCKA(ISCKB2) .GT. 0) THEN 2763 CALL GETWA2(LUDELD,FNDELD,WORK(KINTVI),IOFF, 2764 & NCKA(ISCKB2)) 2765 ENDIF 2766C 2767 DTIME = SECOND() - DTIME 2768 TIIO = TIIO + DTIME 2769C 2770 DTIME = SECOND() 2771 CALL CCSDT_TRVIR(WORK(KINTVI),WORK(KTRVI3),XLAMDH, 2772 * ISYMD,D,ISINT2,WORK(KEND4),LWRK4) 2773C 2774 IF (LWRK3 .LT. NCKATR(ISYCKB)) THEN 2775 CALL QUIT('Insufficient space for allocation in '// 2776 & 'CC3_OMEG33') 2777 END IF 2778C 2779 DTIME = SECOND() - DTIME 2780 TITRAN = TITRAN + DTIME 2781C 2782 DTIME = SECOND() 2783 CALL CCSDT_SRVIR3(WORK(KTRVI3),WORK(KEND3),ISYMD,D,ISINT2) 2784C 2785 DTIME = SECOND() - DTIME 2786 TISORT = TISORT + DTIME 2787C 2788 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 2789 XTRVI3= DDOT(NCKATR(ISCKB2),WORK(KTRVI3),1, 2790 * WORK(KTRVI3),1) 2791 WRITE(LUPRI,*) 'Norm of TRVI3 ',XTRVI3 2792 ENDIF 2793C 2794C--------------------- 2795C Calculate. 2796C--------------------- 2797C 2798 DO 120 ISYMB = 1,NSYM 2799C 2800 ISYALJ = MULD2H(ISYMB,ISYMT2) 2801 ISYALJ2 = MULD2H(ISYMB,ISYMC2) 2802 ISAIJ2 = MULD2H(ISYMB,ISYRES) 2803 ISYMBD = MULD2H(ISYMB,ISYMD) 2804 ISCKIJ = MULD2H(ISYMBD,ISYMIM) 2805C 2806 ISYCKD = MULD2H(ISYMB,ISYMOP) 2807 ISCKD1 = MULD2H(ISINT1,ISYMB) 2808 ISCKD2 = MULD2H(ISINT2,ISYMB) 2809 ISCKD3 = MULD2H(ISINT22,ISYMB) 2810C 2811 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 2812C 2813 WRITE(LUPRI,*) 'In CC3_OMEG33: ISYMD :',ISYMD 2814 WRITE(LUPRI,*) 'In CC3_OMEG33: ISYMB :',ISYMB 2815 WRITE(LUPRI,*) 'In CC3_OMEG33: ISYALJ:',ISYALJ 2816 WRITE(LUPRI,*) 'In CC3_OMEG33: ISAIJ2:',ISAIJ2 2817 WRITE(LUPRI,*) 'In CC3_OMEG33: ISYMBD:',ISYMBD 2818 WRITE(LUPRI,*) 'In CC3_OMEG33: ISCKIJ:',ISCKIJ 2819 WRITE(LUPRI,*) 'In CC3_OMEG33: ISYCKD:',ISYCKD 2820 WRITE(LUPRI,*) 'In CC3_OMEG33: ISCKD1:',ISCKD1 2821C 2822 ENDIF 2823C 2824 KSMAT = KEND3 2825 KSMAT2 = KSMAT + NCKIJ(ISCKIJ) 2826 KQMAT = KSMAT2 + NCKIJ(ISCKIJ) 2827 KDIAG = KQMAT + NCKIJ(ISCKIJ) 2828 KINDSQ = KDIAG + NCKIJ(ISCKIJ) 2829 KINDEX = KINDSQ + (6*NCKIJ(ISCKIJ) - 1)/IRAT + 1 2830 KINDEX2 = KINDEX + (NCKI(ISYALJ) - 1)/IRAT + 1 2831 KTMAT = KINDEX2 + (NCKI(ISYALJ2) - 1)/IRAT + 1 2832 KRMAT2 = KTMAT + NCKIJ(ISCKIJ) 2833 KRMAT4 = KRMAT2 + NCKI(ISAIJ2) 2834 KEND4 = KRMAT4 + NCKI(ISAIJ2) 2835 LWRK4 = LWORK - KEND4 2836 KTRVI8 = KEND4 2837 KTRVI9 = KTRVI8 + NCKATR(ISCKD1) 2838 KTRVIB0 = KTRVI9 + NCKATR(ISCKD1) 2839 KTRVIB2 = KTRVIB0 + NCKATR(ISCKD3) 2840 KTRVIB4 = KTRVIB2 + NCKATR(ISCKD3) 2841 KTRVIB5 = KTRVIB4 + NCKATR(ISCKD2) 2842 KTRVIB6 = KTRVIB5 + NCKATR(ISCKD2) 2843 KTRVIB7 = KTRVIB6 + MAX(NCKATR(ISCKD2),NCKATR(ISCKD3)) 2844 KEND4 = KTRVIB7 + NCKATR(ISCKD3) 2845 LWRK4 = LWORK - KEND4 2846C 2847 IF (LWRK4 .LT. 0) THEN 2848 WRITE(LUPRI,*) 'Memory available : ',LWORK 2849 WRITE(LUPRI,*) 'Memory needed : ',KEND4 2850 CALL QUIT('Insufficient space in CC3_OMEG33') 2851 END IF 2852C 2853C--------------------------------------------- 2854C Construct part of the diagonal. 2855C--------------------------------------------- 2856C 2857 CALL CC3_DIAG(WORK(KDIAG),WORK(KFOCKD),ISCKIJ) 2858C 2859 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 2860 XDIA = DDOT(NCKIJ(ISCKIJ),WORK(KDIAG),1, 2861 * WORK(KDIAG),1) 2862 WRITE(LUPRI,*) 'Norm of DIA ',XDIA 2863 ENDIF 2864C 2865C------------------------------------- 2866C Construct index arrays. 2867C------------------------------------- 2868C 2869 LENSQ = NCKIJ(ISCKIJ) 2870 CALL CC3_INDSQ(WORK(KINDSQ),LENSQ,ISCKIJ) 2871 CALL CC3_INDEX(WORK(KINDEX),ISYALJ) 2872 CALL CC3_INDEX(WORK(KINDEX2),ISYALJ2) 2873C 2874C-------------------------------------- 2875C Sum over B 2876C-------------------------------------- 2877C 2878 IF (ISYMB .GT. ISYMD) THEN 2879 BSTART = 1 2880 BEND = NVIR(ISYMB) 2881 ELSE IF (ISYMB .EQ. ISYMD) THEN 2882 BSTART = D + 1 2883 BEND = NVIR(ISYMB) 2884 ELSE 2885 BSTART = 1 2886 BEND = 0 2887 ENDIF 2888C 2889C 2890 DO 130 B = BSTART,BEND 2891C 2892C---------------------------------------------------------- 2893C Initialize the R2/R4/SMAT/TMAT matrices. 2894C---------------------------------------------------------- 2895C 2896 CALL DZERO(WORK(KRMAT2),NCKI(ISAIJ2)) 2897 CALL DZERO(WORK(KRMAT4),NCKI(ISAIJ2)) 2898 CALL DZERO(WORK(KSMAT),NCKIJ(ISCKIJ)) 2899 CALL DZERO(WORK(KSMAT2),NCKIJ(ISCKIJ)) 2900 CALL DZERO(WORK(KTMAT),NCKIJ(ISCKIJ)) 2901C 2902C--------------------------------------------------------- 2903C Read the integrals for given B that is 2904C needed to calculate the SMAT. 2905C--------------------------------------------------------- 2906C 2907 DTIME = SECOND() 2908 IOFF = ICKBD(ISCKD3,ISYMB) + NCKATR(ISCKD3)*(B-1) + 1 2909 IF (NCKATR(ISCKD3) .GT. 0) THEN 2910 CALL GETWA2(LUDKBC,FNDKBC,WORK(KTRVIB0),IOFF, 2911 & NCKATR(ISCKD3)) 2912C 2913 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 2914 XTRVI0= DDOT(NCKATR(ISCKD3),WORK(KTRVIB0),1, 2915 * WORK(KTRVIB0),1) 2916 WRITE(LUPRI,*) 'Norm of TRVIB0 readin',XTRVI0 2917 ENDIF 2918 ENDIF 2919 DTIME = SECOND() - DTIME 2920 TIIO = TIIO + DTIME 2921C 2922C--------------------------- 2923C Sort. 2924C--------------------------- 2925C 2926 DTIME = SECOND() 2927 CALL CCSDT_SRTVIR(WORK(KTRVIB0),WORK(KTRVIB2), 2928 * WORK(KEND4),LWRK4,ISYMB,ISINT22) 2929C 2930 DTIME = SECOND() - DTIME 2931 TISORT = TISORT + DTIME 2932C 2933 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 2934 XTRVI0= DDOT(NCKATR(ISCKD3),WORK(KTRVIB0),1, 2935 * WORK(KTRVIB0),1) 2936 WRITE(LUPRI,*) 'Norm of TRVIB0 ',XTRVI0 2937C 2938 XTRVI2= DDOT(NCKATR(ISCKD3),WORK(KTRVIB2),1, 2939 * WORK(KTRVIB2),1) 2940 WRITE(LUPRI,*) 'Norm of TRVIB2 ',XTRVI2 2941 ENDIF 2942C 2943C----------------------------------------- 2944C Readin part2. 2945C----------------------------------------- 2946C 2947 DTIME = SECOND() 2948 IOFF = ICKBD(ISCKD2,ISYMB) + NCKATR(ISCKD2)*(B-1) + 1 2949 IF (NCKATR(ISCKD2) .GT. 0) THEN 2950 CALL GETWA2(LUDKBC2,FNDKBC2,WORK(KTRVIB4),IOFF, 2951 & NCKATR(ISCKD2)) 2952C 2953 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 2954 XTRVI0= DDOT(NCKATR(ISCKD2),WORK(KTRVIB4),1, 2955 * WORK(KTRVIB4),1) 2956 WRITE(LUPRI,*) 'Norm of TRVIB4 readin',XTRVI0 2957 ENDIF 2958 ENDIF 2959 DTIME = SECOND() - DTIME 2960 TIIO = TIIO + DTIME 2961C 2962C------------------------------------------------- 2963C Sort the integrals part 2. 2964C------------------------------------------------- 2965C 2966 DTIME = SECOND() 2967 CALL CCSDT_SRTVIR(WORK(KTRVIB4),WORK(KTRVIB5), 2968 * WORK(KEND4),LWRK4,ISYMB,ISINT2) 2969C 2970 DTIME = SECOND() - DTIME 2971 TISORT = TISORT + DTIME 2972C 2973 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 2974 XTRVI2= DDOT(NCKATR(ISCKD2),WORK(KTRVIB5),1, 2975 * WORK(KTRVIB5),1) 2976 WRITE(LUPRI,*) 'Norm of TRVI5 ',XTRVI2 2977 ENDIF 2978C 2979C----------------------------------------------------------- 2980C Read virtual integrals part 2b. 2981C----------------------------------------------------------- 2982C 2983 DTIME = SECOND() 2984 IOFF = ICKBD(ISCKD2,ISYMB) + NCKATR(ISCKD2)*(B-1) + 1 2985 IF (NCKATR(ISCKD2) .GT. 0) THEN 2986 CALL GETWA2(LUDKBC4,FNDKBC4,WORK(KTRVIB6),IOFF, 2987 & NCKATR(ISCKD2)) 2988 ENDIF 2989 DTIME = SECOND() - DTIME 2990 TIIO = TIIO + DTIME 2991C 2992C---------------------------------------------------- 2993C Sort the integrals for s3am part 2b. 2994C---------------------------------------------------- 2995C 2996 DTIME = SECOND() 2997 CALL CCSDT_SRTVIR(WORK(KTRVIB6),WORK(KTRVIB4), 2998 & WORK(KEND4),LWRK4,ISYMB,ISINT2) 2999C 3000 DTIME = SECOND() - DTIME 3001 TISORT = TISORT + DTIME 3002C 3003 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 3004 XTRVI0= DDOT(NCKATR(ISCKD2),WORK(KTRVIB4),1, 3005 * WORK(KTRVIB4),1) 3006 WRITE(LUPRI,*) 'Norm of TRVI4 ',XTRVI0 3007C 3008 XTRVI2= DDOT(NCKATR(ISCKD2),WORK(KTRVIB5),1, 3009 * WORK(KTRVIB5),1) 3010 WRITE(LUPRI,*) 'Norm of TRVI5 ',XTRVI2 3011 ENDIF 3012C 3013C---------------------------------------------------- 3014C Read some more integrals. 3015C---------------------------------------------------- 3016C 3017 DTIME = SECOND() 3018 CALL DZERO(WORK(KTRVIB6), 3019 & MAX(NCKATR(ISCKD2),NCKATR(ISCKD3))) 3020 IOFF = ICKBD(ISCKD3,ISYMB) + NCKATR(ISCKD3)*(B-1) + 1 3021 IF (NCKATR(ISCKD3) .GT. 0) THEN 3022 CALL GETWA2(LUDKBC5,FNDKBC5,WORK(KTRVIB6),IOFF, 3023 & NCKATR(ISCKD3)) 3024 ENDIF 3025 DTIME = SECOND() - DTIME 3026 TIIO = TIIO + DTIME 3027C 3028C--------------------------------------------------- 3029C Sort again. 3030C--------------------------------------------------- 3031C 3032 DTIME = SECOND() 3033 CALL CCSDT_SRTVIR(WORK(KTRVIB6),WORK(KTRVIB7), 3034 * WORK(KEND4),LWRK4,ISYMB,ISINT22) 3035C 3036 DTIME = SECOND() - DTIME 3037 TISORT = TISORT + DTIME 3038C 3039 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 3040 XTRVI2= DDOT(NCKATR(ISCKD3),WORK(KTRVIB7),1, 3041 * WORK(KTRVIB7),1) 3042 WRITE(LUPRI,*) 'Norm of TRVI7 ',XTRVI2 3043 ENDIF 3044C 3045C--------------------------------------------- 3046C Read for the last time. 3047C--------------------------------------------- 3048C 3049 DTIME = SECOND() 3050C 3051 CALL DZERO(WORK(KTRVIB6), 3052 & MAX(NCKATR(ISCKD2),NCKATR(ISCKD3))) 3053 IOFF = ICKBD(ISCKD2,ISYMB) + NCKATR(ISCKD2)*(B-1) + 1 3054 IF (NCKATR(ISCKD2) .GT. 0) THEN 3055 CALL GETWA2(LUDKBC3,FNDKBC3,WORK(KTRVIB6),IOFF, 3056 & NCKATR(ISCKD2)) 3057 ENDIF 3058C 3059C--------------------------------------------------------------- 3060C Read the contraction integrals for given B 3061C--------------------------------------------------------------- 3062C 3063 IOFF = ICKBD(ISYCKD,ISYMB)+NCKATR(ISYCKD)*(B - 1)+1 3064 IF (NCKATR(ISYCKD) .GT. 0) THEN 3065 CALL GETWA2(LU3VI3,FN3VI3,WORK(KTRVI8),IOFF, 3066 & NCKATR(ISYCKD)) 3067 ENDIF 3068 IOFF = ICKBD(ISYCKD,ISYMB)+NCKATR(ISYCKD)*(B - 1)+1 3069 IF (NCKATR(ISYCKD) .GT. 0) THEN 3070 CALL GETWA2(LU3VI4,FN3VI4,WORK(KTRVI9),IOFF, 3071 & NCKATR(ISYCKD)) 3072 ENDIF 3073C 3074 DTIME = SECOND() - DTIME 3075 TIIO = TIIO + DTIME 3076C 3077C------------------------------------------------------- 3078C Calculate the part of the R3 matrix 3079C------------------------------------------------------- 3080C 3081 DTIME = SECOND() 3082 CALL CC3_SMAT3(ECURR,T2TP,ISYMT2,C2AMP,C2AMM,ISYMC2, 3083 * WORK(KTMAT),WORK(KTRVI0), 3084 * WORK(KTRVI2), 3085 * WORK(KTRVI4),WORK(KTRVI5), 3086 * WORK(KTRVI6),WORK(KTRVI7), 3087 * WORK(KTROC0),WORK(KTROC2), 3088 * WORK(KTROC3),WORK(KTROC4), 3089 * WORK(KTROC5),ISINT2, 3090 * ISINT22,WORK(KFOCKD),WORK(KDIAG), 3091 * WORK(KSMAT),WORK(KEND4),LWRK4, 3092 * WORK(KINDEX),WORK(KINDEX2), 3093 * WORK(KINDSQ),LENSQ,ISYMB,B,ISYMD,D) 3094C 3095 CALL CC3_SMAT3(ECURR,T2TP,ISYMT2,C2AMP,C2AMM,ISYMC2, 3096 * WORK(KTMAT),WORK(KTRVIB0), 3097 * WORK(KTRVIB2), 3098 * WORK(KTRVIB4),WORK(KTRVIB5), 3099 * WORK(KTRVIB6),WORK(KTRVIB7), 3100 * WORK(KTROC0),WORK(KTROC2), 3101 * WORK(KTROC3),WORK(KTROC4), 3102 * WORK(KTROC5),ISINT2, 3103 * ISINT22,WORK(KFOCKD),WORK(KDIAG), 3104 * WORK(KSMAT2),WORK(KEND4),LWRK4, 3105 * WORK(KINDEX3),WORK(KINDEX4), 3106 * WORK(KINDSQ),LENSQ,ISYMD,D,ISYMB,B) 3107C 3108 CALL DAXPY(NCKIJ(ISCKIJ),XMONE,WORK(KSMAT2),1, 3109 * WORK(KSMAT),1) 3110C 3111 DTIME = SECOND() - DTIME 3112 TISMAT = TISMAT + DTIME 3113C 3114 IF (LDEBUG) THEN 3115C 3116CKH DO NOT REMOVE THIS CALL. USED FOR DEBUGGING. 3117CKH USES A STATIC ALL. ARRAY OF N^6 THUS THE SUBROUTINE 3118CKH (AND THEREFORE ALL CALLS) SHOULD BE OUTCOMMENTED 3119C 3120C CALL SUM_R3(WORK(KSMAT),ISYMD,D,ISYMB,B, 3121C * NCKIJ(ISCKIJ),WORK(KR3)) 3122C 3123 ENDIF 3124C 3125 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 3126 XSMAT = DDOT(NCKIJ(ISCKIJ),WORK(KSMAT),1, 3127 * WORK(KSMAT),1) 3128 WRITE(LUPRI,*) 'Norm of SMAT ',XSMAT 3129 ENDIF 3130C 3131C----------------------------------------------- 3132C Contract with integrals. 3133C----------------------------------------------- 3134C 3135C 3136 DTIME = SECOND() 3137 IOPT = 1 3138 CALL CC3_CONVIR33(OMEGA2P,WORK(KRES2P),OMEGA2M, 3139 * WORK(KRES2M),WORK(KRMAT1), 3140 * WORK(KRMAT2),WORK(KRMAT3), 3141 * WORK(KRMAT4),WORK(KSMAT), 3142 * WORK(KTMAT),ISYMIM,WORK(KTRVI), 3143 * WORK(KTRVI1),WORK(KTRVI8), 3144 * WORK(KTRVI9),ISINT1,WORK(KEND4), 3145 * LWRK4,WORK(KINDSQ),LENSQ, 3146 * ISYMB,B,ISYMD,D,IOPT, 3147 * TIME1P,TIME2P,TIME3P,TIME1M, 3148 * TIME2M,TSORTP,TSORTM) 3149C 3150 IOPT = 2 3151 CALL CC3_CONVIR33(OMEGA2P,WORK(KRES2P),OMEGA2M, 3152 * WORK(KRES2M),WORK(KRMAT1), 3153 * WORK(KRMAT2),WORK(KRMAT3), 3154 * WORK(KRMAT4),WORK(KSMAT), 3155 * WORK(KTMAT),ISYMIM,WORK(KTRVI), 3156 * WORK(KTRVI1),WORK(KTRVI8), 3157 * WORK(KTRVI9),ISINT1,WORK(KEND4), 3158 * LWRK4,WORK(KINDSQ),LENSQ, 3159 * ISYMB,B,ISYMD,D,IOPT, 3160 * TIME1P,TIME2P,TIME3P,TIME1M, 3161 * TIME2M,TSORTP,TSORTM) 3162C 3163C 3164 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 3165 XRMAT = DDOT(NCKI(ISAIJ1),WORK(KRMAT1),1, 3166 * WORK(KRMAT1),1) 3167 WRITE(LUPRI,*) 'RMAT1 norm -after CONVIR33',XRMAT 3168 XRMAT = DDOT(NCKI(ISAIJ2),WORK(KRMAT2),1, 3169 * WORK(KRMAT2),1) 3170 WRITE(LUPRI,*) 'RMAT2 norm -after CONVIR33',XRMAT 3171 XRMAT = DDOT(NCKI(ISAIJ1),WORK(KRMAT3),1, 3172 * WORK(KRMAT3),1) 3173 WRITE(LUPRI,*) 'RMAT3 norm -after CONVIR33',XRMAT 3174 XRMAT = DDOT(NCKI(ISAIJ2),WORK(KRMAT4),1, 3175 * WORK(KRMAT4),1) 3176 WRITE(LUPRI,*) 'RMAT4 norm -after CONVIR33',XRMAT 3177 ENDIF 3178C 3179 IF (IPRINT .GT. 220 .OR. LDEBUG) THEN 3180 CALL AROUND('After CC3_CONVIR: Rho+') 3181 CALL CC_PRP(OMEGA1,OMEGA2P,ISYRES,0,1) 3182 CALL AROUND('After CC3_CONVIR: Rho-') 3183 CALL CC_PRP(OMEGA1,OMEGA2M,ISYRES,0,1) 3184 ENDIF 3185C 3186 DTIME = SECOND() - DTIME 3187 TICONV = TICONV + DTIME 3188C 3189 DTIME = SECOND() 3190C 3191 IOPT = 1 3192 CALL CC3_CONOCC33(OMEGA2P,OMEGA2M,WORK(KRMAT1), 3193 * WORK(KRMAT2),WORK(KRMAT3), 3194 * WORK(KRMAT4),WORK(KSMAT), 3195 * WORK(KTMAT),ISYMIM,WORK(KTROC), 3196 * WORK(KTROC1),ISINT1,WORK(KEND4), 3197 * LWRK4,WORK(KINDSQ),LENSQ,ISYMB,B, 3198 * ISYMD,D,IOPT) 3199 IOPT = 2 3200 CALL CC3_CONOCC33(OMEGA2P,OMEGA2M,WORK(KRMAT1), 3201 * WORK(KRMAT2),WORK(KRMAT3), 3202 * WORK(KRMAT4),WORK(KSMAT), 3203 * WORK(KTMAT),ISYMIM,WORK(KTROC), 3204 * WORK(KTROC1),ISINT1,WORK(KEND4), 3205 * LWRK4,WORK(KINDSQ),LENSQ,ISYMB,B, 3206 * ISYMD,D,IOPT) 3207C 3208 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 3209 XRMAT = DDOT(NCKI(ISAIJ1),WORK(KRMAT1),1, 3210 * WORK(KRMAT1),1) 3211 WRITE(LUPRI,*) 'RMAT1 norm -after CONOCC33',XRMAT 3212 XRMAT = DDOT(NCKI(ISAIJ2),WORK(KRMAT2),1, 3213 * WORK(KRMAT2),1) 3214 WRITE(LUPRI,*) 'RMAT2 norm -after CONOCC33',XRMAT 3215 XRMAT = DDOT(NCKI(ISAIJ1),WORK(KRMAT3),1, 3216 * WORK(KRMAT3),1) 3217 WRITE(LUPRI,*) 'RMAT3 norm -after CONOCC33',XRMAT 3218 XRMAT = DDOT(NCKI(ISAIJ2),WORK(KRMAT4),1, 3219 * WORK(KRMAT4),1) 3220 WRITE(LUPRI,*) 'RMAT4 norm -after CONOCC33',XRMAT 3221 RHO1N = DDOT(NT1AM(ISYRES),OMEGA1,1,OMEGA1,1) 3222 WRITE(LUPRI,*) 'Rho1 norm after CC3_CONOCC33', 3223 * RHO1N 3224 RHO2N = DDOT(NT2AM(ISYRES),OMEGA2P,1,OMEGA2P,1) 3225 WRITE(LUPRI,*) 'Rho2+ norm after CC3_CONOCC33', 3226 * RHO2N 3227 RHO2N = DDOT(NT2AM(ISYRES),OMEGA2M,1,OMEGA2M,1) 3228 WRITE(LUPRI,*) 'Rho2- norm after CC3_CONOCC33', 3229 * RHO2N 3230 ENDIF 3231C 3232 IF (IPRINT .GT. 220 .OR. LDEBUG) THEN 3233 CALL AROUND('After CC3_CONOCC33: Rho2+ ') 3234 CALL CC_PRP(OMEGA1,OMEGA2P,ISYRES,0,1) 3235 CALL AROUND('After CC3_CONOCC33: Rho2- ') 3236 CALL CC_PRP(OMEGA1,OMEGA2M,ISYRES,0,1) 3237 ENDIF 3238C 3239 DTIME = SECOND() - DTIME 3240 TICONO = TICONO + DTIME 3241C 3242C-------------------------------------------------------------------- 3243C Calculate Omega1 and the Fock cont. to omega2P/M 3244C-------------------------------------------------------------------- 3245C 3246 DTIME = SECOND() 3247C 3248 IOPT = 1 3249 CALL CC3_ONEL33(OMEGA1,OMEGA2P,OMEGA2M,WORK(KRMAT1), 3250 * WORK(KRMAT2),WORK(KRMAT3),WORK(KRMAT4) 3251 * ,WORK(KFCKAK),WORK(KSMAT), 3252 * WORK(KTMAT),ISYMIM,WORK(KXIAJB), 3253 * WORK(KXIAJB2), 3254 * ISINT1,WORK(KINDSQ),LENSQ,WORK(KEND4), 3255 * LWRK4,ISYMB,B,ISYMD,D,IOPT) 3256 IOPT = 2 3257 CALL CC3_ONEL33(OMEGA1,OMEGA2P,OMEGA2M,WORK(KRMAT1), 3258 * WORK(KRMAT2),WORK(KRMAT3),WORK(KRMAT4) 3259 * ,WORK(KFCKAK),WORK(KSMAT), 3260 * WORK(KTMAT),ISYMIM,WORK(KXIAJB), 3261 * WORK(KXIAJB2), 3262 * ISINT1,WORK(KINDSQ),LENSQ,WORK(KEND4), 3263 * LWRK4,ISYMB,B,ISYMD,D,IOPT) 3264C 3265 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 3266 XRMAT = DDOT(NCKI(ISAIJ1),WORK(KRMAT1),1, 3267 * WORK(KRMAT1),1) 3268 WRITE(LUPRI,*) 'Norm of RMAT1 -after ONEL33',XRMAT 3269 XRMAT = DDOT(NCKI(ISAIJ2),WORK(KRMAT2),1, 3270 * WORK(KRMAT2),1) 3271 WRITE(LUPRI,*) 'Norm of RMAT2 -after ONEL33',XRMAT 3272 XTMAT = DDOT(NCKIJ(ISCKIJ),WORK(KSMAT),1, 3273 * WORK(KSMAT),1) 3274 WRITE(LUPRI,*) 'Norm of SMAT -after ONEL33',XSMAT 3275 XTMAT = DDOT(NCKIJ(ISCKIJ),WORK(KTMAT),1, 3276 * WORK(KTMAT),1) 3277 WRITE(LUPRI,*) 'Norm of TMAT -after ONEL33',XTMAT 3278 RHO1N = DDOT(NT1AM(ISYRES),OMEGA1,1,OMEGA1,1) 3279 WRITE(LUPRI,*) 'Norm of Rho1 -after CC3_ONEL33', 3280 * RHO1N 3281 RHO2N = DDOT(NT2AM(ISYRES),OMEGA2P,1,OMEGA2P,1) 3282 WRITE(LUPRI,*) 'Norm of Rho2+ after CC3_ONEL33', 3283 * RHO2N 3284 RHO2N = DDOT(NT2AM(ISYRES),OMEGA2M,1,OMEGA2M,1) 3285 WRITE(LUPRI,*) 'Norm of Rho2- after CC3_ONEL33', 3286 * RHO2N 3287 ENDIF 3288C 3289 IF (IPRINT .GT. 220 .OR. LDEBUG) THEN 3290 CALL AROUND('After CC3_ONEL33: Rho1 & Rho2+ ') 3291 CALL CC_PRP(OMEGA1,OMEGA2P,ISYRES,1,1) 3292 CALL AROUND('After CC3_ONEL:33 Rho2- ') 3293 CALL CC_PRP(OMEGA1,OMEGA2M,ISYRES,0,1) 3294 ENDIF 3295C 3296 DTIME = SECOND() - DTIME 3297 TIOME1 = TIOME1 + DTIME 3298C 3299C---------------------------------------------------- 3300C Accumulate the R2 matrix in Omega2. 3301C---------------------------------------------------- 3302C 3303 CALL CC3_RACC(OMEGA2P,WORK(KRMAT2),ISYMB,B,ISYRES) 3304 IOPT = 2 3305 FACTOR = ONE 3306 CALL CC3_RACC3(VDUMMY,OMEGA2M,WORK(KRMAT4),ISYMB,B, 3307 * ISYRES,FACTOR,IOPT) 3308C 3309 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 3310 RHO1N = DDOT(NT1AM(ISYRES),OMEGA1,1,OMEGA1,1) 3311 WRITE(LUPRI,*) 'Norm of Rho1 -after CC3_RACC',RHO1N 3312 RHO2N = DDOT(NT2AM(ISYRES),OMEGA2P,1,OMEGA2P,1) 3313 WRITE(LUPRI,*) 'Norm of Rho2+ after CC3_RACC',RHO2N 3314 RHO2N = DDOT(NT2AM(ISYRES),OMEGA2M,1,OMEGA2M,1) 3315 WRITE(LUPRI,*) 'Norm of Rho2- after CC3_RACC',RHO2N 3316 ENDIF 3317C 3318 IF (IPRINT .GT. 220 .OR. LDEBUG) THEN 3319 CALL AROUND('After CC3_RACC: Rho1 & Rho2+') 3320 CALL CC_PRP(OMEGA1,OMEGA2P,ISYRES,1,1) 3321 CALL AROUND('After CC3_RACC: Rho2-') 3322 CALL CC_PRP(OMEGA1,OMEGA2M,ISYRES,0,1) 3323 ENDIF 3324C 3325 130 CONTINUE 3326C 3327 120 CONTINUE 3328C 3329C---------------------------------------------- 3330C Accumulate the R1 matrix in Omega2. 3331C---------------------------------------------- 3332C 3333 CALL CC3_RACC(OMEGA2P,WORK(KRMAT1),ISYMD,D,ISYRES) 3334 IOPT = 2 3335 FACTOR = ONE 3336 CALL CC3_RACC3(VDUMMY,OMEGA2M,WORK(KRMAT3),ISYMD,D,ISYRES, 3337 * FACTOR,IOPT) 3338C 3339 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 3340 RHO1N = DDOT(NT1AM(ISYRES),OMEGA1,1,OMEGA1,1) 3341 WRITE(LUPRI,*) 'Norm of Rho1 -after CC3_RACC-2',RHO1N 3342 RHO2N = DDOT(NT2AM(ISYRES),OMEGA2P,1,OMEGA2P,1) 3343 WRITE(LUPRI,*) 'Norm of Rho2+ after CC3_RACC-2',RHO2N 3344 RHO2N = DDOT(NT2AM(ISYRES),OMEGA2M,1,OMEGA2M,1) 3345 WRITE(LUPRI,*) 'Norm of Rho2- after CC3_RACC-2',RHO2N 3346 ENDIF 3347C 3348 IF (IPRINT .GT. 220 .OR. LDEBUG) THEN 3349 CALL AROUND('After CC3_RACC-2: Rho1 & Rho2+ ') 3350 CALL CC_PRP(OMEGA1,OMEGA2P,ISYRES,1,1) 3351 CALL AROUND('After CC3_RACC-2: Rho2- ') 3352 CALL CC_PRP(OMEGA1,OMEGA2M,ISYRES,0,1) 3353 ENDIF 3354C 3355 110 CONTINUE 3356C 3357C----------------------------------------------------------- 3358C Accumulate the result vectors from cc3_convir33 3359C and last loop stop. 3360C----------------------------------------------------------- 3361C 3362 DTIME = SECOND() 3363 CALL CC3_SORTPLUS(OMEGA2P,WORK(KRES2P),ISYRES) 3364 CALL CC3_SORTMINUS(OMEGA2M,WORK(KRES2M),ISYRES) 3365 DTIME = SECOND() - DTIME 3366 TISORT = TISORT + DTIME 3367C 3368 100 CONTINUE 3369C 3370C----------------------------------------- 3371C Close and delete files. 3372C----------------------------------------- 3373C 3374 CALL WCLOSE2(LUDKBC2,FNDKBC2,'DELETE') 3375 CALL WCLOSE2(LUDKBC3,FNDKBC3,'DELETE') 3376 CALL WCLOSE2(LUDKBC4,FNDKBC4,'DELETE') 3377 CALL WCLOSE2(LUDKBC5,FNDKBC5,'DELETE') 3378 CALL WCLOSE2(LU3VI3,FN3VI3,'DELETE') 3379 CALL WCLOSE2(LU3VI4,FN3VI4,'DELETE') 3380 CALL WCLOSE2(LUDELD,FNDELD,'DELETE') 3381 CALL WCLOSE2(LUDKBC,FNDKBC,'DELETE') 3382C 3383C---------------------------------------- 3384C Print timings and R3 if LDEBUG. 3385C---------------------------------------- 3386C 3387 IF (LDEBUG) THEN 3388C 3389CKH DO NOT REMOVE THIS CALL. USED FOR DEBUGGING. 3390CKH USES A STATIC ALL. ARRAY OF N^6 THUS THE SUBROUTINE 3391CKH (AND THEREFORE ALL CALLS) SHOULD BE OUTCOMMENTED 3392C 3393C WRITE(LUPRI,*) 'THE R3 AMPLITUDES : ' 3394C CALL PRINT_R3(WORK(KR3),ISYMIM) 3395C 3396 ENDIF 3397C 3398 IF (IPRINT .GT. 9 .OR. LDEBUG) THEN 3399 WRITE(LUPRI,*) 3400 WRITE(LUPRI,*) 3401 WRITE(LUPRI,1) 'CC3_TRAN : ',TITRAN 3402 WRITE(LUPRI,1) 'CC3_SORT : ',TISORT 3403 WRITE(LUPRI,1) 'CC3_SMAT : ',TISMAT 3404 WRITE(LUPRI,1) 'CC3_CONV : ',TICONV 3405 WRITE(LUPRI,2) '1.ST + : ',TIME1P 3406 WRITE(LUPRI,2) '2.ND + : ',TIME2P 3407 WRITE(LUPRI,2) '3.RD + : ',TIME3P 3408 WRITE(LUPRI,2) '1.ST - : ',TIME1M 3409 WRITE(LUPRI,2) '2.ND - : ',TIME2M 3410 WRITE(LUPRI,1) 'CC3_CONO : ',TICONO 3411 WRITE(LUPRI,1) 'CC3_OME1 : ',TIOME1 3412 WRITE(LUPRI,1) 'CC3_IO : ',TIIO 3413 WRITE(LUPRI,1) 'CC3_IVINT : ',TIVINT 3414 WRITE(LUPRI,*) 3415 END IF 3416C 3417 CALL QEXIT('CC3_OMEG33') 3418C 3419 RETURN 3420C 3421 1 FORMAT(7X,'Time used in',2X,A12,F12.2,' seconds') 3422 2 FORMAT(7X,'CC3_CONV consists of',2X,A12,F12.2,' seconds') 3423C 3424 END 3425C /* Deck cc3_smat3 */ 3426 SUBROUTINE CC3_SMAT3(ECURR,T2TP,ISYMT2,C2AMP,C2AMM,ISYMC2, 3427 * TMAT,TRVIR, 3428 * TRVIR2,TRVIR4,TRVIR5,TRVIR6,TRVIR7,TROCC, 3429 * TROCC2,TROCC3,TROCC4,TROCC5,ISYINT,ISYINT2, 3430 * FOCKD,DIAG,SMAT,WORK,LWORK,INDAJL,INDAJL2, 3431 * INDSQ,LENSQ,ISYMB,B,ISYMC,C) 3432C 3433C Written by Kasper Hald, Spring 2001. 3434C Based on CC3_SMAT by 3435C Henrik Koch and Alfredo Sanchez. Dec 1994 3436C Generalised for symmetry: Ove Christiansen Nov. 1995 3437C Jan. 1996 3438C 3439C Calculate the S matrix for approximate triples. 3440C 3441C S(ck,bj,ai) = sum(d)[ 3442C + t(ck,di)g(1)(ajbd) + t(bj,di)g(2)(ckad) 3443C + t(bi,dk)g(2)(ajcd) + r+(di,bj) (ad|ck) 3444C + r-(ai,dk) (bj|cd) + r-(ck,di) (aj|bd) ] 3445C - sum(l)[ 3446C + t(ck,al)g(3)(bilj) + t(bj,al)g(4)(ckli) 3447C + t(bi,cl)g(4)(ajlk) + r+(al,bj) (ck|li) 3448C - r-(cl,ai) (bj|lk) - r-(bl,ck) (aj|li) ] 3449C 3450C S is stored as S(ai,k,j) for fixed b and c 3451C 3452C 3453C General symmetry: ISYINT is symmetry of integrals for T2, 3454C ISYMT2 is the symmetry of T2TP, 3455C ISYINT2 is the symmetry of integrals for C2, 3456C and ISYMC2 is the symmetry of C2AMP and C2AMM. 3457C 3458 IMPLICIT NONE 3459C 3460#include "priunit.h" 3461#include "ccorb.h" 3462#include "ccsdinp.h" 3463#include "ccsdsym.h" 3464C 3465 INTEGER ISYMT2, ISYMC2, ISYINT, ISYINT2, LENSQ, INDSQ(LENSQ,6) 3466 INTEGER ISYMB, ISYMC, LENGTH, ISYMA, ISYMAJ, ISYAIK, ISYMBC 3467 INTEGER KOFF, KOFF1, KOFF2, KOFF3 3468 INTEGER NTOAIJ, NVIRD, ISYAKD, ISYDIJ, ISYMJ, ISYMDI, ISYMI 3469 INTEGER ISYMAK, ISYAKI, NTOTAK, ISYAIL, ISYLKJ, ISYMLK 3470 INTEGER NTOTAI, NRHFL, ISYAJL, ISYLKI, NB, NC, NTOTAJ, ISYAJK 3471 INTEGER ISYMAI, ISYML, ISYAIJ, ISYMD, ISYMK, ISYMDK, ISYMDK2 3472 INTEGER JSAIKJ, INDAJL(*), INDAJL2(*), LWORK, ISYRES, ISYRES2 3473 INTEGER ISYBJL, ISYCJL, ISYMBJ, ISYMCJ, ISYMJL 3474 INTEGER NTOAIK, NTOTL 3475C 3476#if defined (SYS_CRAY) 3477 REAL TRVIR(*),TRVIR2(*),TROCC(*),SMAT(*),FOCKD(*) 3478 REAL C2AMP(*), C2AMM(*), XSMAT, DDOT, EPSIBC 3479 REAL DIAG(*),T2TP(*),TMAT(*), TROCC2(*), TROCC3(*) 3480 REAL TROCC4(*), TROCC5(*) 3481 REAL TRVIR4(*),TRVIR5(*),TRVIR6(*),TRVIR7(*) 3482 REAL WORK(LWORK), ZERO, ONE, XMONE, TWO, HALF 3483 REAL FACTOR, XMHALF, XDOT, ECURR 3484#else 3485 DOUBLE PRECISION TRVIR(*),TRVIR2(*),TROCC(*),SMAT(*),FOCKD(*) 3486 DOUBLE PRECISION C2AMP(*), C2AMM(*), XSMAT, DDOT, EPSIBC 3487 DOUBLE PRECISION DIAG(*),T2TP(*),TMAT(*), TROCC2(*), TROCC3(*) 3488 DOUBLE PRECISION TROCC4(*), TROCC5(*) 3489 DOUBLE PRECISION TRVIR4(*),TRVIR5(*),TRVIR6(*),TRVIR7(*) 3490 DOUBLE PRECISION WORK(LWORK), ZERO, ONE, XMONE, TWO, HALF 3491 DOUBLE PRECISION FACTOR, XMHALF, XDOT, ECURR 3492#endif 3493C 3494 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0, XMONE = -1.0D0) 3495 PARAMETER(TWO = 2.0D0, HALF = 0.5D0, XMHALF = -0.5D0) 3496C 3497 LOGICAL LDEBUG 3498C 3499 CALL QENTER('CC3_SMAT3') 3500C 3501 LDEBUG = .FALSE. 3502C 3503C-------------------------- 3504C Initialitation. 3505C-------------------------- 3506C 3507 ISYMBC = MULD2H(ISYMB,ISYMC) 3508 ISYRES = MULD2H(ISYINT,ISYMT2) 3509 ISYRES2 = MULD2H(ISYINT2,ISYMC2) 3510 JSAIKJ = MULD2H(ISYMBC,ISYRES) 3511 ISYMDK = MULD2H(ISYMBC,ISYINT) 3512 ISYMDK2 = MULD2H(ISYMBC,ISYINT2) 3513C 3514 IF (ISYRES .NE. ISYRES2) THEN 3515 CALL QUIT('Symmetry error in CC3_SMAT3') 3516 ENDIF 3517C 3518 LENGTH = NCKIJ(JSAIKJ) 3519C 3520 IF (LWORK .LT. LENGTH) THEN 3521 CALL QUIT('Insufficient core in CC3_SMAT3') 3522 ENDIF 3523C 3524 IF (LDEBUG) THEN 3525 WRITE(LUPRI,*) 'Entered CC3_SMAT3 with B = ',B,' & C = ',C 3526 WRITE(LUPRI,*) 'ISYMB = ',ISYMB,' and ISYMC = ',ISYMC 3527 WRITE(LUPRI,*) 'ISYMT2 = ',ISYMT2,' and ISYMC2 = ',ISYMC2 3528 WRITE(LUPRI,*) 'ISYINT = ',ISYINT,' and ISYINT2 = ',ISYINT2 3529 WRITE(LUPRI,*) 'JSAIKJ = ',JSAIKJ,' and ISYRES=ISYRES2=',ISYRES 3530 WRITE(LUPRI,*) 'ISYMDK = ',ISYMDK,' and ISYMDK2 = ',ISYMDK2 3531C 3532 XDOT = DDOT(NT2SQ(ISYMT2),T2TP,1,T2TP,1) 3533 WRITE(LUPRI,*) 'Norm of T2 Amplitudes in SMAT3 = ',XDOT 3534 XDOT = DDOT(NT2SQ(ISYMC2),C2AMP,1,C2AMP,1) 3535 WRITE(LUPRI,*) 'Norm of R2+ Amplitudes in SMAT3 = ',XDOT 3536 XDOT = DDOT(NT2SQ(ISYMC2),C2AMM,1,C2AMM,1) 3537 WRITE(LUPRI,*) 'Norm of R2- Amplitudes in SMAT3 = ',XDOT 3538 ENDIF 3539C 3540C--------------------------------------------- 3541C First virtual contribution for T2. 3542C--------------------------------------------- 3543C 3544 FACTOR = HALF 3545 DO 100 ISYMK = 1,NSYM 3546C 3547 ISYMD = MULD2H(ISYMK,ISYMDK) 3548 ISYAIJ = MULD2H(ISYMK,JSAIKJ) 3549C 3550 KOFF1 = IT2SP(ISYAIJ,ISYMD) + 1 3551 KOFF2 = ICKATR(ISYMDK,ISYMB) + NT1AM(ISYMDK)*(B - 1) 3552 * + IT1AM(ISYMD,ISYMK) + 1 3553 KOFF3 = ISAIKJ(ISYAIJ,ISYMK) + 1 3554C 3555 NTOAIJ = MAX(1,NCKI(ISYAIJ)) 3556 NVIRD = MAX(NVIR(ISYMD),1) 3557C 3558 CALL DGEMM('N','N',NCKI(ISYAIJ),NRHF(ISYMK), 3559 * NVIR(ISYMD),factor,T2TP(KOFF1),NTOAIJ, 3560 * TRVIR6(KOFF2),NVIRD,ZERO, 3561 * WORK(KOFF3),NTOAIJ) 3562C 3563 100 CONTINUE 3564C 3565 CALL DZERO(TMAT,LENGTH) 3566 CALL CC_GATHER(LENGTH,TMAT,WORK,INDSQ(1,3)) 3567 CALL DAXPY(LENGTH,ONE,TMAT,1,SMAT,1) 3568C 3569 CALL DZERO(TMAT,LENGTH) 3570 CALL DCOPY(LENGTH,WORK,1,TMAT,1) 3571 CALL DAXPY(LENGTH,XMONE,TMAT,1,SMAT,1) 3572C 3573 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 3574 XSMAT = DDOT(NCKIJ(JSAIKJ),SMAT,1,SMAT,1) 3575 WRITE(LUPRI,*) 'In CC3_SMAT3: 1. Norm of SMAT ',XSMAT 3576 ENDIF 3577C 3578C-------------------------------------------------- 3579C First virtual contribution from C2+. 3580C-------------------------------------------------- 3581C 3582 FACTOR = ONE 3583 DO ISYMK = 1,NSYM 3584C 3585 ISYMD = MULD2H(ISYMK,ISYMDK2) 3586 ISYAIJ = MULD2H(ISYMK,JSAIKJ) 3587C 3588 KOFF1 = IT2SP(ISYAIJ,ISYMD) + 1 3589 KOFF2 = ICKATR(ISYMDK2,ISYMB) + NT1AM(ISYMDK2)*(B - 1) 3590 * + IT1AM(ISYMD,ISYMK) + 1 3591 KOFF3 = ISAIKJ(ISYAIJ,ISYMK) + 1 3592C 3593 NTOAIJ = MAX(1,NCKI(ISYAIJ)) 3594 NVIRD = MAX(NVIR(ISYMD),1) 3595C 3596 CALL DGEMM('N','N',NCKI(ISYAIJ),NRHF(ISYMK), 3597 * NVIR(ISYMD),factor,C2AMM(KOFF1),NTOAIJ, 3598 * TRVIR(KOFF2),NVIRD,ZERO, 3599 * WORK(KOFF3),NTOAIJ) 3600C 3601 ENDDO 3602C 3603 CALL DZERO(TMAT,LENGTH) 3604 CALL CC_GATHER(LENGTH,TMAT,WORK,INDSQ(1,3)) 3605 CALL DAXPY(LENGTH,ONE,TMAT,1,SMAT,1) 3606C 3607 CALL DZERO(TMAT,LENGTH) 3608 CALL DCOPY(LENGTH,WORK,1,TMAT,1) 3609 CALL DAXPY(LENGTH,XMONE,TMAT,1,SMAT,1) 3610C 3611 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 3612 XSMAT = DDOT(NCKIJ(JSAIKJ),SMAT,1,SMAT,1) 3613 WRITE(LUPRI,*) 'In CC3_SMAT3: 2. Norm of SMAT ',XSMAT 3614 ENDIF 3615C 3616C--------------------------------------------- 3617C Second virtual contribution for T2. 3618C--------------------------------------------- 3619C 3620 ISYAKD = MULD2H(ISYMC,ISYINT) 3621 ISYDIJ = MULD2H(ISYMB,ISYMT2) 3622C 3623 FACTOR = HALF 3624C 3625 DO 200 ISYMJ = 1,NSYM 3626C 3627 ISYMDI = MULD2H(ISYMJ,ISYDIJ) 3628C 3629 DO 210 J = 1,NRHF(ISYMJ) 3630C 3631 DO 220 ISYMI = 1,NSYM 3632C 3633 ISYMD = MULD2H(ISYMDI,ISYMI) 3634 ISYMAK = MULD2H(ISYMD,ISYAKD) 3635 ISYAKI = MULD2H(ISYMAK,ISYMI) 3636C 3637 KOFF1 = ICKATR(ISYMAK,ISYMD) + 1 3638C 3639 KOFF2 = IT2SP(ISYDIJ,ISYMB) 3640 * + NCKI(ISYDIJ)*(B - 1) 3641 * + ISAIK(ISYMDI,ISYMJ) 3642 * + NT1AM(ISYMDI)*(J - 1) 3643 * + IT1AM(ISYMD,ISYMI) + 1 3644C 3645 KOFF3 = ISAIKJ(ISYAKI,ISYMJ) 3646 * + NCKI(ISYAKI)*(J - 1) 3647 * + ISAIK(ISYMAK,ISYMI) + 1 3648C 3649 NVIRD = MAX(NVIR(ISYMD),1) 3650 NTOTAK = MAX(NT1AM(ISYMAK),1) 3651C 3652 CALL DGEMM('N','N',NT1AM(ISYMAK),NRHF(ISYMI), 3653 * NVIR(ISYMD),factor,TRVIR5(KOFF1),NTOTAK, 3654 * T2TP(KOFF2),NVIRD,ZERO,TMAT(KOFF3), 3655 * NTOTAK) 3656C 3657 220 CONTINUE 3658 210 CONTINUE 3659 200 CONTINUE 3660C 3661 DO I = 1,LENGTH 3662 SMAT(I) = SMAT(I) + TMAT(INDSQ(I,1)) - TMAT(INDSQ(I,4)) 3663 ENDDO 3664C 3665 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 3666 XSMAT = DDOT(NCKIJ(JSAIKJ),SMAT,1,SMAT,1) 3667 WRITE(LUPRI,*) 'In CC3_SMAT3: 3. Norm of SMAT ',XSMAT 3668 ENDIF 3669C 3670C--------------------------------------------- 3671C Second virtual contribution for R2- 3672C--------------------------------------------- 3673C 3674 ISYAKD = MULD2H(ISYMC,ISYINT2) 3675 ISYDIJ = MULD2H(ISYMB,ISYMC2) 3676C 3677 FACTOR = ONE 3678C 3679 DO ISYMJ = 1,NSYM 3680C 3681 ISYMDI = MULD2H(ISYMJ,ISYDIJ) 3682C 3683 DO J = 1,NRHF(ISYMJ) 3684C 3685 DO ISYMI = 1,NSYM 3686C 3687 ISYMD = MULD2H(ISYMDI,ISYMI) 3688 ISYMAK = MULD2H(ISYMD,ISYAKD) 3689 ISYAKI = MULD2H(ISYMAK,ISYMI) 3690C 3691 KOFF1 = ICKATR(ISYMAK,ISYMD) + 1 3692C 3693 KOFF2 = IT2SP(ISYDIJ,ISYMB) 3694 * + NCKI(ISYDIJ)*(B - 1) 3695 * + ISAIK(ISYMDI,ISYMJ) 3696 * + NT1AM(ISYMDI)*(J - 1) 3697 * + IT1AM(ISYMD,ISYMI) + 1 3698C 3699 KOFF3 = ISAIKJ(ISYAKI,ISYMJ) 3700 * + NCKI(ISYAKI)*(J - 1) 3701 * + ISAIK(ISYMAK,ISYMI) + 1 3702C 3703 NVIRD = MAX(NVIR(ISYMD),1) 3704 NTOTAK = MAX(NT1AM(ISYMAK),1) 3705C 3706 CALL DGEMM('N','N',NT1AM(ISYMAK),NRHF(ISYMI), 3707 * NVIR(ISYMD),factor,TRVIR2(KOFF1),NTOTAK, 3708 * C2AMM(KOFF2),NVIRD,ZERO,TMAT(KOFF3), 3709 * NTOTAK) 3710C 3711 ENDDO 3712 ENDDO 3713 ENDDO 3714C 3715 DO I = 1,LENGTH 3716 SMAT(I) = SMAT(I) + TMAT(INDSQ(I,1)) - TMAT(INDSQ(I,4)) 3717 ENDDO 3718C 3719 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 3720 XSMAT = DDOT(NCKIJ(JSAIKJ),SMAT,1,SMAT,1) 3721 WRITE(LUPRI,*) 'In CC3_SMAT3: 4. Norm of SMAT ',XSMAT 3722 ENDIF 3723C 3724C--------------------------------------------- 3725C Third virtual contribution for T2. 3726C--------------------------------------------- 3727C 3728 ISYAKD = MULD2H(ISYMC,ISYINT) 3729 ISYDIJ = MULD2H(ISYMB,ISYMT2) 3730C 3731 FACTOR = XMHALF 3732C 3733 DO ISYMJ = 1,NSYM 3734C 3735 ISYMDI = MULD2H(ISYMJ,ISYDIJ) 3736C 3737 DO J = 1,NRHF(ISYMJ) 3738C 3739 DO ISYMI = 1,NSYM 3740C 3741 ISYMD = MULD2H(ISYMDI,ISYMI) 3742 ISYMAK = MULD2H(ISYMD,ISYAKD) 3743 ISYAKI = MULD2H(ISYMAK,ISYMI) 3744C 3745 KOFF1 = ICKATR(ISYMAK,ISYMD) + 1 3746C 3747 KOFF2 = IT2SP(ISYDIJ,ISYMB) 3748 * + NCKI(ISYDIJ)*(B - 1) 3749 * + ISAIK(ISYMDI,ISYMJ) 3750 * + NT1AM(ISYMDI)*(J - 1) 3751 * + IT1AM(ISYMD,ISYMI) + 1 3752C 3753 KOFF3 = ISAIKJ(ISYAKI,ISYMJ) 3754 * + NCKI(ISYAKI)*(J - 1) 3755 * + ISAIK(ISYMAK,ISYMI) + 1 3756C 3757 NVIRD = MAX(NVIR(ISYMD),1) 3758 NTOTAK = MAX(NT1AM(ISYMAK),1) 3759C 3760 CALL DGEMM('N','N',NT1AM(ISYMAK),NRHF(ISYMI), 3761 * NVIR(ISYMD),factor,TRVIR4(KOFF1),NTOTAK, 3762 * T2TP(KOFF2),NVIRD,ZERO,TMAT(KOFF3), 3763 * NTOTAK) 3764C 3765 ENDDO 3766 ENDDO 3767 ENDDO 3768C 3769 DO I = 1,LENGTH 3770 SMAT(I) = SMAT(I) + TMAT(I) - TMAT(INDSQ(I,3)) 3771 ENDDO 3772C 3773 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 3774 XSMAT = DDOT(NCKIJ(JSAIKJ),SMAT,1,SMAT,1) 3775 WRITE(LUPRI,*) 'In CC3_SMAT3: 5. Norm of SMAT ',XSMAT 3776 ENDIF 3777C 3778C----------------------------------- 3779C Virtual contribution for R2+ 3780C----------------------------------- 3781C 3782 ISYAKD = MULD2H(ISYMC,ISYINT2) 3783 ISYDIJ = MULD2H(ISYMB,ISYMC2) 3784C 3785 FACTOR = XMHALF 3786C 3787 DO ISYMJ = 1,NSYM 3788C 3789 ISYMDI = MULD2H(ISYMJ,ISYDIJ) 3790C 3791 DO J = 1,NRHF(ISYMJ) 3792C 3793 DO ISYMI = 1,NSYM 3794C 3795 ISYMD = MULD2H(ISYMDI,ISYMI) 3796 ISYMAK = MULD2H(ISYMD,ISYAKD) 3797 ISYAKI = MULD2H(ISYMAK,ISYMI) 3798C 3799 KOFF1 = ICKATR(ISYMAK,ISYMD) + 1 3800C 3801 KOFF2 = IT2SP(ISYDIJ,ISYMB) 3802 * + NCKI(ISYDIJ)*(B - 1) 3803 * + ISAIK(ISYMDI,ISYMJ) 3804 * + NT1AM(ISYMDI)*(J - 1) 3805 * + IT1AM(ISYMD,ISYMI) + 1 3806C 3807 KOFF3 = ISAIKJ(ISYAKI,ISYMJ) 3808 * + NCKI(ISYAKI)*(J - 1) 3809 * + ISAIK(ISYMAK,ISYMI) + 1 3810C 3811 NVIRD = MAX(NVIR(ISYMD),1) 3812 NTOTAK = MAX(NT1AM(ISYMAK),1) 3813C 3814 CALL DGEMM('N','N',NT1AM(ISYMAK),NRHF(ISYMI), 3815 * NVIR(ISYMD),factor,TRVIR7(KOFF1),NTOTAK, 3816 * C2AMP(KOFF2),NVIRD,ZERO,TMAT(KOFF3), 3817 * NTOTAK) 3818C 3819 ENDDO 3820 ENDDO 3821 ENDDO 3822C 3823 DO I = 1,LENGTH 3824 SMAT(I) = SMAT(I) + TMAT(I) - TMAT(INDSQ(I,3)) 3825 ENDDO 3826C 3827 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 3828 XSMAT = DDOT(NCKIJ(JSAIKJ),SMAT,1,SMAT,1) 3829 WRITE(LUPRI,*) 'In CC3_SMAT3: 6. Norm of SMAT ',XSMAT 3830 ENDIF 3831C 3832C-------------------------------------------- 3833C First occupied contribution from T2. 3834C-------------------------------------------- 3835C 3836 ISYAIL = MULD2H(ISYMB,ISYMT2) 3837 ISYLKJ = MULD2H(ISYMC,ISYINT) 3838C 3839 CALL DZERO(TMAT,LENGTH) 3840 FACTOR = HALF 3841C 3842 DO 300 ISYMJ = 1,NSYM 3843C 3844 ISYMLK = MULD2H(ISYMJ,ISYLKJ) 3845C 3846 DO 310 J = 1,NRHF(ISYMJ) 3847C 3848 DO 320 ISYMK = 1,NSYM 3849C 3850 ISYML = MULD2H(ISYMK,ISYMLK) 3851 ISYMAI = MULD2H(ISYAIL,ISYML) 3852 ISYAIK = MULD2H(ISYMAI,ISYMK) 3853C 3854 KOFF1 = IT2SP(ISYAIL,ISYMB) 3855 * + NCKI(ISYAIL)*(B - 1) 3856 * + ICKI(ISYMAI,ISYML) + 1 3857 KOFF2 = ISJIKA(ISYLKJ,ISYMC) 3858 * + NMAJIK(ISYLKJ)*(C - 1) 3859 * + ISJIK(ISYMLK,ISYMJ) 3860 * + NMATIJ(ISYMLK)*(J - 1) 3861 * + IMATIJ(ISYML,ISYMK) + 1 3862 KOFF3 = ISAIKJ(ISYAIK,ISYMJ) 3863 * + NCKI(ISYAIK)*(J - 1) 3864 * + ICKI(ISYMAI,ISYMK) + 1 3865C 3866 NTOTAI = MAX(1,NT1AM(ISYMAI)) 3867 NRHFL = MAX(1,NRHF(ISYML)) 3868C 3869 CALL DGEMM('N','N',NT1AM(ISYMAI),NRHF(ISYMK), 3870 * NRHF(ISYML),factor,T2TP(KOFF1),NTOTAI, 3871 * TROCC2(KOFF2),NRHFL,ONE,TMAT(KOFF3), 3872 * NTOTAI) 3873C 3874 320 CONTINUE 3875 310 CONTINUE 3876 300 CONTINUE 3877C 3878 DO I = 1, LENGTH 3879 SMAT(I) = SMAT(I) + TMAT(I) - TMAT(INDSQ(I,3)) 3880 ENDDO 3881C 3882 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 3883 XSMAT = DDOT(NCKIJ(JSAIKJ),SMAT,1,SMAT,1) 3884 WRITE(LUPRI,*) 'In CC3_SMAT3: 7. Norm of SMAT ',XSMAT 3885 ENDIF 3886C 3887C-------------------------------------------- 3888C First occupied contribution from R2-. 3889C-------------------------------------------- 3890C 3891 ISYAIL = MULD2H(ISYMB,ISYMC2) 3892 ISYLKJ = MULD2H(ISYMC,ISYINT2) 3893C 3894 CALL DZERO(TMAT,LENGTH) 3895 FACTOR = XMONE 3896C 3897 DO ISYMJ = 1,NSYM 3898C 3899 ISYMLK = MULD2H(ISYMJ,ISYLKJ) 3900C 3901 DO J = 1,NRHF(ISYMJ) 3902C 3903 DO ISYMK = 1,NSYM 3904C 3905 ISYML = MULD2H(ISYMK,ISYMLK) 3906 ISYMAI = MULD2H(ISYAIL,ISYML) 3907 ISYAIK = MULD2H(ISYMAI,ISYMK) 3908C 3909 KOFF1 = IT2SP(ISYAIL,ISYMB) 3910 * + NCKI(ISYAIL)*(B - 1) 3911 * + ICKI(ISYMAI,ISYML) + 1 3912 KOFF2 = ISJIKA(ISYLKJ,ISYMC) 3913 * + NMAJIK(ISYLKJ)*(C - 1) 3914 * + ISJIK(ISYMLK,ISYMJ) 3915 * + NMATIJ(ISYMLK)*(J - 1) 3916 * + IMATIJ(ISYML,ISYMK) + 1 3917 KOFF3 = ISAIKJ(ISYAIK,ISYMJ) 3918 * + NCKI(ISYAIK)*(J - 1) 3919 * + ICKI(ISYMAI,ISYMK) + 1 3920C 3921 NTOTAI = MAX(1,NT1AM(ISYMAI)) 3922 NRHFL = MAX(1,NRHF(ISYML)) 3923C 3924 CALL DGEMM('N','N',NT1AM(ISYMAI),NRHF(ISYMK), 3925 * NRHF(ISYML),factor,C2AMM(KOFF1),NTOTAI, 3926 * TROCC(KOFF2),NRHFL,ONE,TMAT(KOFF3), 3927 * NTOTAI) 3928C 3929 ENDDO ! ISYMK 3930 ENDDO ! J 3931 ENDDO !ISYMJ 3932C 3933 DO I = 1, LENGTH 3934 SMAT(I) = SMAT(I) + TMAT(I) - TMAT(INDSQ(I,3)) 3935 ENDDO 3936C 3937 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 3938 XSMAT = DDOT(NCKIJ(JSAIKJ),SMAT,1,SMAT,1) 3939 WRITE(LUPRI,*) 'In CC3_SMAT3: 8. Norm of SMAT ',XSMAT 3940 ENDIF 3941C 3942C--------------------------------------------- 3943C Second occupied contribution for T2. 3944C--------------------------------------------- 3945C 3946 ISYAJL = MULD2H(ISYMB,ISYMT2) 3947 ISYLKI = MULD2H(ISYMC,ISYINT) 3948C 3949 IF (LWORK .LT. NCKI(ISYAJL)) THEN 3950 CALL QUIT('Not enough space in CC3_SMAT3') 3951 END IF 3952C 3953 FACTOR = HALF 3954C 3955 KOFF = IT2SP(ISYAJL,ISYMB) + NCKI(ISYAJL)*(B - 1) + 1 3956 CALL CC_GATHER(NCKI(ISYAJL),WORK,T2TP(KOFF),INDAJL) 3957C 3958 DO 400 ISYMI = 1,NSYM 3959C 3960 ISYMLK = MULD2H(ISYMI,ISYLKI) 3961C 3962 DO 410 I = 1,NRHF(ISYMI) 3963C 3964 DO 420 ISYMK = 1,NSYM 3965C 3966 ISYML = MULD2H(ISYMK,ISYMLK) 3967 ISYMAJ = MULD2H(ISYAJL,ISYML) 3968 ISYAJK = MULD2H(ISYMAJ,ISYMK) 3969C 3970 KOFF1 = ICKI(ISYMAJ,ISYML) + 1 3971C 3972 KOFF2 = ISJIKA(ISYLKI,ISYMC) 3973 * + NMAJIK(ISYLKI)*(C - 1) 3974 * + ISJIK(ISYMLK,ISYMI) 3975 * + NMATIJ(ISYMLK)*(I - 1) 3976 * + IMATIJ(ISYML,ISYMK) + 1 3977C 3978 KOFF3 = ISAIKJ(ISYAJK,ISYMI) 3979 * + NCKI(ISYAJK)*(I - 1) 3980 * + ICKI(ISYMAJ,ISYMK) + 1 3981C 3982 NTOTAJ = MAX(1,NT1AM(ISYMAJ)) 3983 NRHFL = MAX(1,NRHF(ISYML)) 3984C 3985 CALL DGEMM('N','N',NT1AM(ISYMAJ),NRHF(ISYMK), 3986 * NRHF(ISYML),factor,WORK(KOFF1),NTOTAJ, 3987 * TROCC3(KOFF2),NRHFL,ZERO,TMAT(KOFF3), 3988 * NTOTAJ) 3989C 3990 420 CONTINUE 3991 410 CONTINUE 3992 400 CONTINUE 3993C 3994 DO I = 1,NCKIJ(JSAIKJ) 3995 SMAT(I) = SMAT(I) + TMAT(INDSQ(I,2)) - TMAT(INDSQ(I,5)) 3996 ENDDO 3997C 3998 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 3999 XSMAT = DDOT(NCKIJ(JSAIKJ),SMAT,1,SMAT,1) 4000 WRITE(LUPRI,*) 'In CC3_SMAT3: 9. Norm of SMAT ',XSMAT 4001 ENDIF 4002C 4003C--------------------------------------------- 4004C Second occupied contribution for R2-. 4005C--------------------------------------------- 4006C 4007 ISYAJL = MULD2H(ISYMB,ISYMC2) 4008 ISYLKI = MULD2H(ISYMC,ISYINT2) 4009C 4010 IF (LWORK .LT. NCKI(ISYAJL)) THEN 4011 CALL QUIT('Not enough space in CC3_SMAT3') 4012 END IF 4013C 4014 FACTOR = ONE 4015C 4016 KOFF = IT2SP(ISYAJL,ISYMB) + NCKI(ISYAJL)*(B - 1) + 1 4017 CALL CC_GATHER(NCKI(ISYAJL),WORK,C2AMM(KOFF),INDAJL2) 4018C 4019 DO ISYMI = 1,NSYM 4020C 4021 ISYMLK = MULD2H(ISYMI,ISYLKI) 4022C 4023 DO I = 1,NRHF(ISYMI) 4024C 4025 DO ISYMK = 1,NSYM 4026C 4027 ISYML = MULD2H(ISYMK,ISYMLK) 4028 ISYMAJ = MULD2H(ISYAJL,ISYML) 4029 ISYAJK = MULD2H(ISYMAJ,ISYMK) 4030C 4031 KOFF1 = ICKI(ISYMAJ,ISYML) + 1 4032C 4033 KOFF2 = ISJIKA(ISYLKI,ISYMC) 4034 * + NMAJIK(ISYLKI)*(C - 1) 4035 * + ISJIK(ISYMLK,ISYMI) 4036 * + NMATIJ(ISYMLK)*(I - 1) 4037 * + IMATIJ(ISYML,ISYMK) + 1 4038C 4039 KOFF3 = ISAIKJ(ISYAJK,ISYMI) 4040 * + NCKI(ISYAJK)*(I - 1) 4041 * + ICKI(ISYMAJ,ISYMK) + 1 4042C 4043 NTOTAJ = MAX(1,NT1AM(ISYMAJ)) 4044 NRHFL = MAX(1,NRHF(ISYML)) 4045C 4046 CALL DGEMM('N','N',NT1AM(ISYMAJ),NRHF(ISYMK), 4047 * NRHF(ISYML),factor,WORK(KOFF1),NTOTAJ, 4048 * TROCC(KOFF2),NRHFL,ZERO,TMAT(KOFF3), 4049 * NTOTAJ) 4050C 4051 ENDDO ! ISYMK 4052 ENDDO ! I 4053 ENDDO ! ISYMI 4054C 4055 DO I = 1,NCKIJ(JSAIKJ) 4056 SMAT(I) = SMAT(I) + TMAT(INDSQ(I,2)) - TMAT(INDSQ(I,5)) 4057 ENDDO 4058C 4059 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 4060 XSMAT = DDOT(NCKIJ(JSAIKJ),SMAT,1,SMAT,1) 4061 WRITE(LUPRI,*) 'In CC3_SMAT3: 10. Norm of SMAT ',XSMAT 4062 ENDIF 4063C 4064C-------------------------------------------- 4065C First occupied contribution from R2+. 4066C-------------------------------------------- 4067C 4068 ISYBJL = MULD2H(ISYMC,ISYMC2) 4069 ISYCJL = MULD2H(ISYMB,ISYMC2) 4070 ISYMJL = MULD2H(ISYMC,ISYCJL) 4071 IF (LWORK .LE. NMATIJ(ISYMJL)) 4072 * CALL QUIT('OUT OF WORKSPACE IN CC33_SMAT3 (Sort)') 4073C 4074 CALL CC33_T2SORT(C2AMP,ISYMC2,WORK,ISYMB,B,ISYMC,C) 4075C 4076 CALL DZERO(TMAT,LENGTH) 4077 FACTOR = HALF 4078C 4079 DO ISYMJ = 1,NSYM 4080C 4081 ISYML = MULD2H(ISYMJL,ISYMJ) 4082 ISYAIK = MULD2H(ISYINT2,ISYML) 4083 ISYMAI = MULD2H(ISYAIK,ISYMK) 4084 ISYMBJ = MULD2H(ISYMB,ISYMJ) 4085 ISYMCJ = MULD2H(ISYMC,ISYMJ) 4086C 4087 KOFF1 = ISAIKJ(ISYAIK,ISYML) 4088 * + 1 4089 KOFF2 = IMATIJ(ISYML,ISYMJ) 4090 * + 1 4091 KOFF3 = ISAIKJ(ISYAIK,ISYMJ) 4092 * + 1 4093C 4094 NTOAIK = MAX(1,NCKI(ISYAIK)) 4095 NTOTL = MAX(1,NRHF(ISYML)) 4096C 4097 CALL DGEMM('N','N',NCKI(ISYAIK),NRHF(ISYMJ), 4098 * NRHF(ISYML),factor,TROCC4(KOFF1),NTOAIK, 4099 * WORK(KOFF2),NTOTL,ONE,TMAT(KOFF3), 4100 * NTOAIK) 4101C 4102 ENDDO 4103C 4104 DO I = 1, LENGTH 4105 SMAT(I) = SMAT(I) + TMAT(I) - TMAT(INDSQ(I,3)) 4106 ENDDO 4107C 4108 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 4109 XSMAT = DDOT(NCKIJ(JSAIKJ),SMAT,1,SMAT,1) 4110 WRITE(LUPRI,*) 'In CC3_SMAT3: 11. Norm of SMAT ',XSMAT 4111 ENDIF 4112C 4113C-------------------------------------------- 4114C Third occupied contribution from T2. 4115C-------------------------------------------- 4116C 4117 ISYAIL = MULD2H(ISYMB,ISYMT2) 4118 ISYLKJ = MULD2H(ISYMC,ISYINT) 4119C 4120 ISYBJL = MULD2H(ISYMC,ISYMT2) 4121 ISYCJL = MULD2H(ISYMB,ISYMT2) 4122 ISYMJL = MULD2H(ISYMC,ISYCJL) 4123 IF (LWORK .LE. NMATIJ(ISYMJL)) 4124 * CALL QUIT('OUT OF WORKSPACE IN CC33_smat3 (SORT)') 4125C 4126 CALL CC33_T2SORT(T2TP,ISYMT2,WORK,ISYMB,B,ISYMC,C) 4127C 4128 CALL DZERO(TMAT,LENGTH) 4129 FACTOR = HALF 4130C 4131 DO ISYMJ = 1,NSYM 4132C 4133 ISYMLK = MULD2H(ISYMJ,ISYLKJ) 4134 ISYML = MULD2H(ISYMJL,ISYMJ) 4135 ISYAIK = MULD2H(ISYINT,ISYML) 4136 ISYMBJ = MULD2H(ISYMB,ISYMJ) 4137 ISYMCJ = MULD2H(ISYMC,ISYMJ) 4138C 4139 KOFF1 = ISAIKJ(ISYAIK,ISYML) 4140 * + 1 4141 KOFF2 = IMATIJ(ISYML,ISYMJ) 4142 * + 1 4143 KOFF3 = ISAIKJ(ISYAIK,ISYMJ) 4144 * + 1 4145 NTOAIK = MAX(1,NCKI(ISYAIK)) 4146 NTOTL = MAX(1,NRHF(ISYML)) 4147C 4148 CALL DGEMM('N','N',NCKI(ISYAIK),NRHF(ISYMJ), 4149 * NRHF(ISYML),factor,TROCC5(KOFF1),NTOAIK, 4150 * WORK(KOFF2),NTOTL,ONE,TMAT(KOFF3),NTOAIK) 4151C 4152 ENDDO 4153C 4154 DO I = 1, LENGTH 4155 SMAT(I) = SMAT(I) + TMAT(I) - TMAT(INDSQ(I,3)) 4156 ENDDO 4157C 4158 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 4159 XSMAT = DDOT(NCKIJ(JSAIKJ),SMAT,1,SMAT,1) 4160 WRITE(LUPRI,*) 'In CC3_SMAT3: 12. Norm of SMAT ',XSMAT 4161 ENDIF 4162C 4163C----------------------------------------- 4164C Divide by the Fock matrix diagonals. 4165C----------------------------------------- 4166C 4167 NB = IORB(ISYMB) + NRHF(ISYMB) + B 4168 NC = IORB(ISYMC) + NRHF(ISYMC) + C 4169C 4170 EPSIBC = FOCKD(NB) + FOCKD(NC) - ECURR 4171C 4172 DO 500 L = 1,NCKIJ(JSAIKJ) 4173C 4174 SMAT(L) = -SMAT(L)/(DIAG(L) + EPSIBC) 4175C 4176 500 CONTINUE 4177C 4178 IF (IPRINT .GT. 55) THEN 4179 XSMAT = DDOT(NCKIJ(JSAIKJ),SMAT,1,SMAT,1) 4180 WRITE(LUPRI,*) 'In CC3_SMAT: Norm of SMAT (end) ',XSMAT 4181 ENDIF 4182C 4183C 4184 CALL QEXIT('CC3_SMAT3') 4185C 4186 RETURN 4187 END 4188C /* Deck cc3_sort3 */ 4189 SUBROUTINE CC3_SORT3(WORK,LWORK,IOPT,ISYINT,LU3SRT2,FN3SRT2, 4190 * LU3SRT3,FN3SRT3,LUDELD2,FNDELD2, 4191 * LUDELD3,FNDELD3) 4192C 4193C Written by K. Hald, Feb. 2001. 4194C Based on cc3_sort1 written by 4195C Henrik Koch and Alfredo Sanchez. 28-May-1995 4196C 4197C Sort virtual integrals for perturbative triples. 4198C 4199 IMPLICIT NONE 4200C 4201#include "priunit.h" 4202#include "ccorb.h" 4203#include "ccinftap.h" 4204#include "ccsdsym.h" 4205! 4206 INTEGER LWORK, ISYINT, MAXCK, ISYMCK, ISYMD, ISYCKB, LENMIN 4207 INTEGER NDISTR, NBATCH, KSCR1, KSCR2, KSCR3, KSCR4, KSCR5, KSCR6 4208 INTEGER KEND1, NUMD, IBATCH, ID1, LENGTH, IOFF, ISYMB, ISYCKD 4209 INTEGER ID, ISYMK, ISYMC, ISYMBK, NTOTBK, KOFF1, KOFF2 4210 INTEGER IOPT, LU3SRT2, LU3SRT3, LUDELD2, LUDELD3 4211C 4212! 4213#if defined (SYS_CRAY) 4214 REAL WORK(LWORK), ONE, XMONE 4215 REAL DDOT, XNORM 4216#else 4217 DOUBLE PRECISION WORK(LWORK), ONE, XMONE 4218 DOUBLE PRECISION DDOT, XNORM 4219#endif 4220! 4221 PARAMETER (ONE = 1.0D0, XMONE = -1.0D0) 4222! 4223 CHARACTER*(*) FN3SRT2, FN3SRT3, FNDELD2, FNDELD3 4224! 4225 CALL QENTER('CC3_SORT3') 4226! 4227C--------------------------------- 4228C Sanity check of iopt. 4229C--------------------------------- 4230C 4231 IF (IOPT .NE. 1 .AND. IOPT .NE. 2) THEN 4232 CALL QUIT('Wrong iopt in cc3_sort3') 4233 ENDIF 4234C 4235C----------------------------------------- 4236C Start loop over symmetries of delta. 4237C----------------------------------------- 4238C 4239 MAXCK = 0 4240 DO ISYMCK = 1,NSYM 4241 IF (NT1AM(ISYMCK) .GT. MAXCK) MAXCK = NT1AM(ISYMCK) 4242 ENDDO 4243C 4244 DO ISYMD = 1,NSYM 4245C 4246 IF (NBAS(ISYMD) .NE. 0) THEN 4247C 4248C-------------------------- 4249C Memory allocation. 4250C-------------------------- 4251C 4252 ISYCKB = MULD2H(ISYMD,ISYINT) 4253C 4254 LENMIN = NCKATR(ISYCKB) + MAXCK 4255 NDISTR = MIN(LWORK/LENMIN,NBAS(ISYMD)) 4256C 4257 IF (NDISTR .EQ. 0) THEN 4258 CALL QUIT('Insufficient work space in CC3_SORT3') 4259 ENDIF 4260C 4261 NBATCH = (NBAS(ISYMD) - 1)/NDISTR + 1 4262C 4263 KSCR1 = 1 4264 KSCR2 = KSCR1 + NCKATR(ISYCKB)*NDISTR 4265 KSCR3 = KSCR2 + MAXCK*NDISTR 4266 KSCR4 = KSCR3 + NCKATR(ISYCKB)*NDISTR 4267 KSCR5 = KSCR4 + MAXCK*NDISTR 4268 KSCR6 = KSCR5 + NCKATR(ISYCKB)*NDISTR 4269 KEND1 = KSCR6 + MAXCK*NDISTR 4270C 4271 DO IBATCH = 1,NBATCH 4272C 4273 NUMD = NDISTR 4274 IF (IBATCH .EQ. NBATCH) THEN 4275 NUMD = NBAS(ISYMD) - NDISTR*(NBATCH - 1) 4276 ENDIF 4277C 4278 ID1 = NDISTR*(IBATCH - 1) + 1 4279C 4280C-------------------------- 4281C Read integrals. 4282C-------------------------- 4283C 4284 LENGTH = NCKATR(ISYCKB)*NUMD 4285C 4286 IOFF = ICKDAO(ISYCKB,ISYMD) + NCKATR(ISYCKB)*(ID1 - 1) + 1 4287C 4288 IF (LENGTH .GT. 0) THEN 4289 CALL GETWA2(LU3SRT2,FN3SRT2,WORK(KSCR1),IOFF,LENGTH) 4290 CALL GETWA2(LU3SRT3,FN3SRT3,WORK(KSCR3),IOFF,LENGTH) 4291 ENDIF 4292C 4293C---------------------------------------------------- 4294C Copy g(c,k,b-bar,del) to scr5 4295C---------------------------------------------------- 4296C 4297 CALL DCOPY(LENGTH,WORK(KSCR3),1,WORK(KSCR5),1) 4298C 4299C-------------------------------------------------------------------- 4300C For iopt = 1. 4301C Sort g(c-bar,k,b,del) to g(b,k,del,c-bar) 4302C Sort g(c-bar,k,b,del) + g(c,k-bar,b,del) to g(c,k,del,b) 4303C Sort g(c,k,b-bar,del) to g(c,k,del,b) 4304C For iopt = 2. 4305C Sort g(c-bar,k,b,del) + g(c,k-bar,b,del) to g(b,k,del,c) 4306C Sort g(c,k,b-bar,del) to g(b,k,del,c) 4307C-------------------------------------------------------------------- 4308C 4309 DO ISYMB = 1,NSYM 4310C 4311 ISYMCK = MULD2H(ISYCKB,ISYMB) 4312 ISYCKD = MULD2H(ISYMCK,ISYMD) 4313C 4314 DO B = 1,NVIR(ISYMB) 4315C 4316 DO I = 1,NUMD 4317C 4318 ID = ID1 + I - 1 4319C 4320 DO ISYMK = 1,NSYM 4321C 4322 ISYMC = MULD2H(ISYMCK,ISYMK) 4323 ISYMBK = MULD2H(ISYMB,ISYMK) 4324C 4325 NTOTBK = MAX(NT1AM(ISYMBK),1) 4326C 4327 IF (IOPT .EQ. 1) THEN 4328 DO K = 1,NRHF(ISYMK) 4329C 4330 KOFF1 = KSCR5 4331 * + NCKATR(ISYCKB)*(I - 1) 4332 * + ICKATR(ISYMBK,ISYMC) 4333 * + IT1AM(ISYMB,ISYMK) 4334 * + NVIR(ISYMB)*(K - 1) + B - 1 4335C 4336 KOFF2 = KSCR6 4337 * + NT1AM(ISYMCK)*(I - 1) 4338 * + IT1AM(ISYMC,ISYMK) 4339 * + NVIR(ISYMC)*(K - 1) 4340C 4341 CALL DCOPY(NVIR(ISYMC),WORK(KOFF1), 4342 * NTOTBK,WORK(KOFF2),1) 4343C 4344 ENDDO ! K loop 4345C 4346 ELSE IF (IOPT .EQ. 2) THEN 4347C 4348 DO K = 1,NRHF(ISYMK) 4349C 4350 KOFF1 = KSCR1 4351 * + NCKATR(ISYCKB)*(I - 1) 4352 * + ICKATR(ISYMBK,ISYMC) 4353 * + IT1AM(ISYMB,ISYMK) 4354 * + NVIR(ISYMB)*(K - 1) + B - 1 4355C 4356 KOFF2 = KSCR2 4357 * + NT1AM(ISYMCK)*(I - 1) 4358 * + IT1AM(ISYMC,ISYMK) 4359 * + NVIR(ISYMC)*(K - 1) 4360C 4361 CALL DCOPY(NVIR(ISYMC),WORK(KOFF1), 4362 * NTOTBK,WORK(KOFF2),1) 4363C 4364 KOFF1 = KSCR3 4365 * + NCKATR(ISYCKB)*(I - 1) 4366 * + ICKATR(ISYMBK,ISYMC) 4367 * + IT1AM(ISYMB,ISYMK) 4368 * + NVIR(ISYMB)*(K - 1) + B - 1 4369C 4370 KOFF2 = KSCR4 4371 * + NT1AM(ISYMCK)*(I - 1) 4372 * + IT1AM(ISYMC,ISYMK) 4373 * + NVIR(ISYMC)*(K - 1) 4374C 4375 CALL DCOPY(NVIR(ISYMC),WORK(KOFF1), 4376 * NTOTBK,WORK(KOFF2),1) 4377C 4378 ENDDO 4379C 4380 ENDIF 4381C 4382 ENDDO ! ISYMK loop 4383 4384C 4385 IF (IOPT .EQ. 1) THEN 4386 KOFF1 = KSCR1 4387 * + NCKATR(ISYCKB)*(I - 1) 4388 * + ICKATR(ISYMCK,ISYMB) 4389 * + NT1AM(ISYMCK)*(B - 1) 4390 KOFF2 = KSCR2 4391 * + NT1AM(ISYMCK)*(I - 1) 4392C 4393 CALL DCOPY(NT1AM(ISYMCK),WORK(KOFF1),1, 4394 * WORK(KOFF2),1) 4395C 4396 KOFF1 = KSCR3 4397 * + NCKATR(ISYCKB)*(I - 1) 4398 * + ICKATR(ISYMCK,ISYMB) 4399 * + NT1AM(ISYMCK)*(B - 1) 4400 KOFF2 = KSCR4 4401 * + NT1AM(ISYMCK)*(I - 1) 4402C 4403 CALL DCOPY(NT1AM(ISYMCK),WORK(KOFF1),1, 4404 * WORK(KOFF2),1) 4405 ENDIF 4406C 4407 ENDDO ! I loop 4408C 4409C 4410C---------------------------------------- 4411C Add the contributions : 4412C g^(1) = g(c-bar,k,b,del) + g(c,k-bar,b,del) - g(b,k,c-bar,del) 4413C g^(2) = g(c-bar,k,b,del) + g(c,k-bar,b,del) - g(c,k,b-bar,del) 4414C---------------------------------------- 4415C 4416 CALL DAXPY(NT1AM(ISYMCK)*NUMD,XMONE,WORK(KSCR2),1, 4417 * WORK(KSCR4),1) 4418C 4419 IF (IOPT .EQ. 1) THEN 4420 CALL DAXPY(NT1AM(ISYMCK)*NUMD,XMONE,WORK(KSCR2), 4421 * 1,WORK(KSCR6),1) 4422 endif 4423C 4424C---------------------------------------- 4425C Write sorted integrals. 4426C---------------------------------------- 4427C 4428 LENGTH = NT1AM(ISYMCK)*NUMD 4429C 4430 IF (LENGTH .GT. 0) THEN 4431C 4432 IOFF = ICKAD(ISYCKD,ISYMB) 4433 * + NCKA(ISYCKD)*(B - 1) 4434 * + ICKA(ISYMCK,ISYMD) 4435 * + NT1AM(ISYMCK)*(ID1 - 1) + 1 4436C 4437 IF (IOPT .EQ. 1) THEN 4438C THIS IS THE OUTPUT FOR G1 4439 CALL PUTWA2(LUDELD3,FNDELD3,WORK(KSCR6), 4440 * IOFF,LENGTH) 4441C THIS IS THE OUTPUT FOR G2 4442 CALL PUTWA2(LUDELD2,FNDELD2,WORK(KSCR4), 4443 * IOFF,LENGTH) 4444 ELSE IF (IOPT .EQ. 2) THEN 4445C THIS IS THE OUTPUT FOR THE SPECIAL G2 4446 CALL PUTWA2(LUDELD2,FNDELD2,WORK(KSCR4), 4447 * IOFF,LENGTH) 4448 ENDIF 4449 ENDIF 4450C 4451 ENDDO ! B loop 4452 ENDDO ! ISYMB loop 4453C 4454 ENDDO !IBATCH loop 4455 ENDIF 4456 ENDDO ! ISYMD loop 4457C 4458 CALL QEXIT('CC3_SORT3') 4459C 4460 RETURN 4461 END 4462C /* Deck cc3_onel33 */ 4463 SUBROUTINE CC3_ONEL33(OMEGA1,OMEGA2P,OMEGA2M,RMAT1,RMAT2,RMAT3, 4464 * RMAT4,FOCKAK,SMAT,TMAT,ISYMIM,XIAJB,XIAJB2, 4465 * ISYINT,INDSQ,LENSQ,WORK,LWORK,ISYMIB,IB, 4466 * ISYMID,ID,IOPT) 4467C 4468C K. Hald, Spring 2001 4469C 4470C Based on cc3_onel by : 4471C Henrik Koch and Alfredo Sanchez. Dec 1994 4472C Ove Christiansen 9-1-1996 4473C 4474C Calculate Omega1 and Fock contibution to Omega2. 4475C 4476C General symmetry: ISYMIM is symmetry of SMAT and TMAT 4477C intermdiates.(incl isymd,isymb) 4478C ISYINT is symmetry of FOCKAK and XIAJB 4479C ISYRES = ISYMIM*ISYINT 4480C 4481 IMPLICIT NONE 4482C 4483#include "priunit.h" 4484#include "ccorb.h" 4485#include "ccsdinp.h" 4486#include "ccsdsym.h" 4487C 4488 INTEGER ISYMIM, ISYINT, LENSQ, LWORK, ISYMIB, IB, ISYMID, ID 4489 INTEGER ISYRES, ISYMB, ISYMC, ISYMK, ISYMBC, ISYAIJ 4490 INTEGER ISYMCK, LENGTH, NCK, NTOAIJ, NTOTC, ISYMI 4491 INTEGER ISYAKJ, ISYMJ, ISYMBJ, ISYMAK, NBJ, NAK, NAKBJ, NAKJ 4492 INTEGER NTOAKJ, NBK, ISYMBK, NTOTB, ISYMKJ, ISYMAI, NCI, NIJ 4493 INTEGER NCIBJ, NTOTIJ, NTOTAK, ISYMIJ, JSAIKJ, KOFF1, KOFF2 4494 INTEGER NKJ, NCKBJ, NTOTAI, JSAKIJ, ISYMCI 4495 INTEGER ISYMLJ, ISYML, ISYMCL, NCL, NCLBJ, NLJ 4496 INTEGER INDEX, INDSQ(LENSQ,6), IOPT 4497C 4498#if defined (SYS_CRAY) 4499 REAL OMEGA1(*),OMEGA2P(*), OMEGA2M(*), RMAT1(*) 4500 REAL RMAT2(*), RMAT3(*), RMAT4(*), FOCKAK(*), SMAT(*) 4501 REAL TMAT(*), XIAJB(*), XIAJB2(*) 4502 REAL WORK(LWORK), ZERO, ONE, TWO, HALF 4503 REAL XMTWO, XMONE, FACT, XDOT, DDOT 4504#else 4505 DOUBLE PRECISION OMEGA1(*),OMEGA2P(*), OMEGA2M(*), RMAT1(*) 4506 DOUBLE PRECISION RMAT2(*), RMAT3(*), RMAT4(*), FOCKAK(*),SMAT(*) 4507 DOUBLE PRECISION TMAT(*), XIAJB(*), XIAJB2(*) 4508 DOUBLE PRECISION WORK(LWORK), ZERO, ONE, TWO, HALF 4509 DOUBLE PRECISION XMTWO, XMONE, FACT, XDOT, DDOT 4510#endif 4511C 4512 PARAMETER (ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, HALF = 0.5D0) 4513 PARAMETER (XMTWO = -2.0D0, XMONE = -1.0D0) 4514C 4515 LOGICAL LDEBUG 4516C 4517 INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 4518C 4519 CALL QENTER('CC3_ONEL33') 4520C 4521 LDEBUG = .FALSE. 4522C 4523C---------------------- 4524C General setup. 4525C---------------------- 4526C 4527 ISYRES = MULD2H(ISYMIM,ISYINT) 4528C 4529 IF (IOPT. EQ. 2) THEN 4530 B = IB 4531 C = ID 4532 ISYMB = ISYMIB 4533 ISYMC = ISYMID 4534 FACT = ONE 4535 ELSE 4536 C = IB 4537 B = ID 4538 ISYMC = ISYMIB 4539 ISYMB = ISYMID 4540 FACT = XMONE 4541 ENDIF 4542C 4543C---------------------------------------- 4544C First contribution to Omega2P. 4545C---------------------------------------- 4546C 4547 ISYMK = MULD2H(ISYMC,ISYINT) 4548 ISYMBC = MULD2H(ISYMB,ISYMC) 4549 JSAIKJ = MULD2H(ISYMBC,ISYMIM) 4550 ISYAIJ = MULD2H(ISYMK,JSAIKJ) 4551 ISYMCK = MULD2H(ISYMC,ISYMK) 4552C 4553 LENGTH = NCKIJ(JSAIKJ) 4554C 4555 IF (LWORK .LT. LENGTH) THEN 4556 CALL QUIT('Not enough core in CCSDT_ONEL33') 4557 END IF 4558C 4559 DO I = 1,LENGTH 4560 TMAT(I) = FACT*(TWO*SMAT(I) + SMAT(INDSQ(I,4))) 4561 ENDDO 4562C 4563 NCK = IT1AM(ISYMC,ISYMK) + C 4564C 4565 KOFF1 = ISAIKJ(ISYAIJ,ISYMK) + 1 4566C 4567 NTOAIJ = MAX(NCKI(ISYAIJ),1) 4568 NTOTC = MAX(NVIR(ISYMC),1) 4569C 4570 IF (IOPT .EQ. 1) THEN 4571 CALL DGEMV('N',NCKI(ISYAIJ),NRHF(ISYMK),ONE,TMAT(KOFF1),NTOAIJ, 4572 * FOCKAK(NCK),NTOTC,ONE,RMAT1,1) 4573 ELSE 4574 CALL DGEMV('N',NCKI(ISYAIJ),NRHF(ISYMK),ONE,TMAT(KOFF1),NTOAIJ, 4575 * FOCKAK(NCK),NTOTC,ONE,RMAT2,1) 4576 ENDIF 4577C 4578 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 4579 IF (IOPT .EQ. 1) THEN 4580 XDOT = DDOT(NCKI(ISYAIJ),RMAT1,1,RMAT1,1) 4581 WRITE(LUPRI,*) 'CC3_ONEL33 : NORM RMAT1 (1) = ',XDOT 4582 ELSE 4583 XDOT = DDOT(NCKI(ISYAIJ),RMAT2,1,RMAT2,1) 4584 WRITE(LUPRI,*) 'CC3_ONEL33 : NORM RMAT2 (1) = ',XDOT 4585 ENDIF 4586 ENDIF 4587C 4588C---------------------------------------- 4589C First contribution to Omega2M. 4590C---------------------------------------- 4591C 4592 ISYMK = MULD2H(ISYMC,ISYINT) 4593 ISYMBC = MULD2H(ISYMB,ISYMC) 4594 JSAIKJ = MULD2H(ISYMBC,ISYMIM) 4595 ISYAIJ = MULD2H(ISYMK,JSAIKJ) 4596 ISYMCK = MULD2H(ISYMC,ISYMK) 4597C 4598 LENGTH = NCKIJ(JSAIKJ) 4599C 4600 IF (LWORK .LT. LENGTH) THEN 4601 CALL QUIT('Not enough core in CCSDT_ONEL') 4602 END IF 4603C 4604 DO I = 1,LENGTH 4605 TMAT(I) = TWO*FACT*SMAT(I) 4606 ENDDO 4607C 4608 NCK = IT1AM(ISYMC,ISYMK) + C 4609C 4610 KOFF1 = ISAIKJ(ISYAIJ,ISYMK) + 1 4611C 4612 NTOAIJ = MAX(NCKI(ISYAIJ),1) 4613 NTOTC = MAX(NVIR(ISYMC),1) 4614C 4615 IF (IOPT .EQ. 1) THEN 4616 CALL DGEMV('N',NCKI(ISYAIJ),NRHF(ISYMK),ONE,TMAT(KOFF1),NTOAIJ, 4617 * FOCKAK(NCK),NTOTC,ONE,RMAT3,1) 4618 ELSE 4619 CALL DGEMV('N',NCKI(ISYAIJ),NRHF(ISYMK),ONE,TMAT(KOFF1),NTOAIJ, 4620 * FOCKAK(NCK),NTOTC,ONE,RMAT4,1) 4621 ENDIF 4622C 4623 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 4624 IF (IOPT .EQ. 1) THEN 4625 XDOT = DDOT(NCKI(ISYAIJ),RMAT3,1,RMAT3,1) 4626 WRITE(LUPRI,*) 'CC3_ONEL33 : NORM RMAT3 (1) = ',XDOT 4627 ELSE 4628 XDOT = DDOT(NCKI(ISYAIJ),RMAT4,1,RMAT4,1) 4629 WRITE(LUPRI,*) 'CC3_ONEL33 : NORM RMAT4 (1) = ',XDOT 4630 ENDIF 4631 ENDIF 4632C 4633C---------------------------------- 4634C First contribution to Omega1. 4635C---------------------------------- 4636C 4637 ISYMI = MULD2H(ISYMC,ISYRES) 4638 ISYAKJ = MULD2H(ISYMB,ISYINT) 4639C 4640C----------------------------------------- 4641C Start by calculating the correct 4642C linear combination in TMAT. 4643C------------------------------------------ 4644C 4645 DO I = 1,LENGTH 4646 TMAT(I) = SMAT(INDSQ(I,3)) - TWO*SMAT(INDSQ(I,2)) 4647 * - SMAT(INDSQ(I,4)) 4648 ENDDO 4649C 4650 IF ((.NOT. CC3LR) .AND. (NRHF(ISYMI) .NE. 0)) THEN 4651C 4652 IF (LWORK .LT. NCKI(ISYAKJ)) THEN 4653 CALL QUIT('Not enough core in CCSDT_ONEL33') 4654 END IF 4655C 4656C Construct M(ak,j) = g(ak,bj) 4657C --------------------------- 4658C Interchanged the a and b index here!!!! 4659C 4660 DO ISYMJ = 1,NSYM 4661C 4662 ISYMBJ = MULD2H(ISYMB,ISYMJ) 4663 ISYMAK = MULD2H(ISYMJ,ISYAKJ) 4664C 4665 DO J = 1,NRHF(ISYMJ) 4666C 4667 NBJ = IT1AM(ISYMB,ISYMJ) + NVIR(ISYMB)*(J - 1) + B 4668C 4669 DO NAK = 1,NT1AM(ISYMAK) 4670C 4671 NAKBJ = IT2AM(ISYMAK,ISYMBJ) + INDEX(NAK,NBJ) 4672 NAKJ = ICKI(ISYMAK,ISYMJ) 4673 * + NT1AM(ISYMAK)*(J - 1) + NAK 4674C 4675 WORK(NAKJ) = FACT*XMTWO*XIAJB(NAKBJ) 4676C 4677 ENDDO 4678 ENDDO 4679 ENDDO 4680C 4681 NTOTC = MAX(NVIR(ISYMC),1) 4682 NTOAKJ = MAX(NCKI(ISYAKJ),1) 4683C 4684 KOFF1 = ISAIKJ(ISYAKJ,ISYMI) + 1 4685 KOFF2 = IT1AM(ISYMC,ISYMI) + C 4686C 4687 CALL DGEMV('T',NCKI(ISYAKJ),NRHF(ISYMI),ONE,TMAT(KOFF1), 4688 * NTOAKJ,WORK,1,ONE,OMEGA1(KOFF2),NTOTC) 4689C 4690 ENDIF 4691C 4692 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 4693 XDOT = DDOT(NT1AM(ISYMCK),OMEGA1,1,OMEGA1,1) 4694 WRITE(LUPRI,*) 'CC3_ONEL33 :OMEGA1 NORM (1) = ',XDOT 4695 ENDIF 4696C 4697C------------------------------------- 4698C Second contribution to Omega1. 4699C------------------------------------- 4700C 4701 ISYMAI = MULD2H(ISYMIM,ISYINT) 4702 ISYAKJ = MULD2H(ISYMB,ISYINT) 4703 ISYMBC = MULD2H(ISYMB,ISYMC) 4704 ISYMLJ = MULD2H(ISYINT,ISYMBC) 4705C 4706C----------------------------------------- 4707C Start by calculating the correct 4708C linear combination in TMAT. 4709C------------------------------------------ 4710C 4711 DO I = 1,LENGTH 4712 TMAT(I) = SMAT(INDSQ(I,4)) 4713 ENDDO 4714C 4715C Symmetry sorting if symmetry 4716C ---------------------------- 4717C 4718 IF (NSYM .GT. 1) THEN 4719 CALL CC_GATHER(LENGTH,WORK,TMAT,INDSQ(1,6)) 4720 CALL DCOPY(LENGTH,WORK,1,TMAT,1) 4721 ENDIF 4722C 4723C Construct M(l,j) = g(cl,bj) 4724C --------------------------- 4725C 4726 DO ISYMJ = 1,NSYM 4727C 4728 ISYMBJ = MULD2H(ISYMB,ISYMJ) 4729 ISYML = MULD2H(ISYMLJ,ISYMJ) 4730 ISYMCL = MULD2H(ISYMC,ISYML) 4731C 4732 DO J = 1,NRHF(ISYMJ) 4733C 4734 NBJ = IT1AM(ISYMB,ISYMJ) + NVIR(ISYMB)*(J - 1) + B 4735C 4736 DO L = 1,NRHF(ISYML) 4737C 4738 NCL = IT1AM(ISYMC,ISYML) + NVIR(ISYMC)*(L - 1) + C 4739C 4740 NCLBJ = IT2AM(ISYMCL,ISYMBJ) + INDEX(NCL,NBJ) 4741 NLJ = IMATIJ(ISYML,ISYMJ) 4742 * + NRHF(ISYML)*(J-1) + L 4743C 4744 WORK(NLJ) = FACT*XMTWO*XIAJB(NCLBJ) 4745C 4746 ENDDO 4747 ENDDO 4748 ENDDO 4749C 4750 NTOTC = MAX(NVIR(ISYMC),1) 4751 NTOAKJ = MAX(NCKI(ISYAKJ),1) 4752 NTOTAI = MAX(1,NT1AM(ISYMAI)) 4753C 4754 KOFF1 = ISAIKL(ISYMAI,ISYMLJ) + 1 4755 KOFF2 = 1 4756C 4757 CALL DGEMV('N',NT1AM(ISYMAI),NMATIJ(ISYMLJ),ONE,TMAT(KOFF1), 4758 * NTOTAI,WORK,1,ONE,OMEGA1(KOFF2),1) 4759C 4760 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 4761 XDOT = DDOT(NT1AM(ISYMAI),OMEGA1,1,OMEGA1,1) 4762 WRITE(LUPRI,*) 'CC3_ONEL33 : OMEGA1 NORM (2) = ',XDOT 4763 ENDIF 4764C 4765C--------------------------------------- 4766C Second contribution to Omega2P. 4767C--------------------------------------- 4768C 4769 ISYMBC = MULD2H(ISYMB,ISYMC) 4770 JSAKIJ = MULD2H(ISYMBC,ISYMIM) 4771 ISYMIJ = MULD2H(ISYMBC,ISYRES) 4772 ISYMAK = MULD2H(JSAKIJ,ISYMIJ) 4773C 4774 LENGTH = NCKIJ(JSAKIJ) 4775C 4776 IF (LWORK .LT. LENGTH) THEN 4777 CALL QUIT('Not enough core in CC3_ONEL33') 4778 END IF 4779C 4780 DO I = 1,LENGTH 4781 TMAT(I) = -FACT*(SMAT(I)+SMAT(INDSQ(I,4))) 4782 ENDDO 4783C 4784C Symmetry sorting if symmetry 4785C ---------------------------- 4786C 4787 IF (NSYM .GT. 1) THEN 4788 CALL CC_GATHER(LENGTH,WORK,TMAT,INDSQ(1,6)) 4789 CALL DCOPY(LENGTH,WORK,1,TMAT,1) 4790 ENDIF 4791C 4792 NTOTAK = MAX(NT1AM(ISYMAK),1) 4793 NTOTIJ = MAX(NMATIJ(ISYMIJ),1) 4794C 4795 KOFF1 = ISAIKL(ISYMAK,ISYMIJ) + 1 4796C 4797 CALL DGEMV('T',NT1AM(ISYMAK),NMATIJ(ISYMIJ),ONE,TMAT(KOFF1), 4798 * NTOTAK,FOCKAK,1,ZERO,WORK,1) 4799C 4800 DO 300 ISYMJ = 1,NSYM 4801C 4802 ISYMI = MULD2H(ISYMIJ,ISYMJ) 4803C 4804 ISYMBJ = MULD2H(ISYMB,ISYMJ) 4805 ISYMCI = MULD2H(ISYMC,ISYMI) 4806C 4807 DO 310 J = 1,NRHF(ISYMJ) 4808C 4809 NBJ = IT1AM(ISYMB,ISYMJ) + NVIR(ISYMB)*(J - 1) + B 4810C 4811 IF (ISYMCI .EQ. ISYMBJ) THEN 4812C 4813 DO 320 I = 1,NRHF(ISYMI) 4814C 4815 NIJ = IMATIJ(ISYMI,ISYMJ) + NRHF(ISYMI)*(J - 1) + I 4816 NCI = IT1AM(ISYMC,ISYMI) + NVIR(ISYMC)*(I - 1) + C 4817C 4818 NCIBJ = IT2AM(ISYMCI,ISYMBJ) + INDEX(NCI,NBJ) 4819C 4820 IF (NCI .EQ. NBJ) THEN 4821C 4822 OMEGA2P(NCIBJ) = ZERO 4823C 4824 ELSE IF (NCI .GT. NBJ) THEN 4825C 4826 OMEGA2P(NCIBJ) = OMEGA2P(NCIBJ) + WORK(NIJ) 4827C 4828 ELSE IF (NCI .LT. NBJ) THEN 4829C 4830 OMEGA2P(NCIBJ) = OMEGA2P(NCIBJ) + WORK(NIJ) 4831C 4832 ENDIF 4833C 4834 320 CONTINUE 4835C 4836 ELSE IF (ISYMCI .LT. ISYMBJ) THEN 4837C 4838 DO 330 I = 1,NRHF(ISYMI) 4839C 4840 NIJ = IMATIJ(ISYMI,ISYMJ) + NRHF(ISYMI)*(J - 1) + I 4841 NCI = IT1AM(ISYMC,ISYMI) + NVIR(ISYMC)*(I - 1) + C 4842C 4843 NCIBJ = IT2AM(ISYMCI,ISYMBJ) 4844 * + NT1AM(ISYMCI)*(NBJ-1) + NCI 4845C 4846 OMEGA2P(NCIBJ) = OMEGA2P(NCIBJ) + WORK(NIJ) 4847C 4848 330 CONTINUE 4849C 4850 ELSE IF (ISYMBJ .LT. ISYMCI) THEN 4851C 4852 DO 340 I = 1,NRHF(ISYMI) 4853C 4854 NIJ = IMATIJ(ISYMI,ISYMJ) + NRHF(ISYMI)*(J - 1) + I 4855 NCI = IT1AM(ISYMC,ISYMI) + NVIR(ISYMC)*(I - 1) + C 4856C 4857 NCIBJ = IT2AM(ISYMBJ,ISYMCI) 4858 * + NT1AM(ISYMBJ)*(NCI-1) + NBJ 4859C 4860 OMEGA2P(NCIBJ) = OMEGA2P(NCIBJ) + WORK(NIJ) 4861C 4862 340 CONTINUE 4863C 4864 ENDIF 4865C 4866 310 CONTINUE 4867C 4868 300 CONTINUE 4869C 4870 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 4871 XDOT = DDOT(NT2AM(ISYRES),OMEGA2P,1,OMEGA2P,1) 4872 WRITE(LUPRI,*) 'OMEGA2P NORM (END) = ',XDOT 4873 ENDIF 4874C 4875 CALL QEXIT('CC3_ONEL33') 4876C 4877 RETURN 4878 END 4879CC /* DECK SUM_R3 */ 4880CC SUBROUTINE SUM_R3(SMAT,ISYMB,B,ISYMD,D,NCKIJ,R3SUM) 4881CC 4882CC Sum up the R3 amplitudes. 4883CC This routine should only be commented in when debugging 4884CC the CC3 triplet triple amplitudes, since we statically allocate 4885CC the r3sum array. 4886CC 4887CC HOWEVER : PLEASE DO NOT REMOVE THIS ROUTINE 4888CC 4889CC K. Hald, Spring 2001. 4890CC 4891C IMPLICIT NONE 4892CC 4893C#include "priunit.h" 4894C#include "ccorb.h" 4895CC 4896C INTEGER ISYMB, ISYMD, B, D, nckij, i 4897C INTEGER KOFF1, KOFF2 4898CC 4899C#if defined (SYS_CRAY) 4900C REAL SMAT(*), r3sum(nvirt,nvirt,nvirt*nrhft*nrhft*nrhft) 4901C REAL one, xmone, fact 4902C#else 4903C DOUBLE PRECISION SMAT(*), one, xmone, fact 4904C DOUBLE PRECISION r3sum(nvirt,nvirt,nvirt*nrhft*nrhft*nrhft) 4905C#endif 4906CC 4907C PARAMETER (one = 1.0D0, xmone = -1.0D0) 4908C LOGICAL LDEBUG 4909CC 4910C CALL QENTER('SUM_R3') 4911CC 4912C LDEBUG = .FALSE. 4913CC 4914C IF ((ISYMB .EQ. ISYMD) .AND. (B .EQ. D)) THEN 4915C CALL QUIT('SUM_R3 CALLED WITH B = D') 4916C ENDIF 4917CC 4918C KOFF1 = 0 4919C KOFF2 = 0 4920CC 4921C DO I = 1, ISYMB-1 4922C KOFF1 = KOFF1 + NVIR(I) 4923C ENDDO 4924C DO I = 1, ISYMD-1 4925C KOFF2 = KOFF2 + NVIR(I) 4926C ENDDO 4927CC 4928C DO I = 1, NCKIJ 4929CC 4930C IF (LDEBUG) THEN 4931C IF (ABS(SMAT(I)) .GT. 1.0d-9) THEN 4932C WRITE(LUPRI,*) 'CONTRIBUTION FROM I = ',I,' WITH SMAT = ', 4933C * SMAT(I) 4934C WRITE(LUPRI,*) 'KOFF1 = ',KOFF1,' KOFF2 = ',KOFF2 4935C endif 4936C ENDIF 4937CC 4938C R3SUM(B+KOFF1,D+KOFF2,I) = R3SUM(B+KOFF1,D+KOFF2,I) + SMAT(I) 4939C R3SUM(D+KOFF2,B+KOFF1,I) = R3SUM(D+KOFF2,B+KOFF1,I) - SMAT(I) 4940CC 4941C ENDDO 4942CC 4943C CALL QEXIT('SUM_R3') 4944CC 4945C RETURN 4946C END 4947CC /* Deck print_r3 */ 4948C SUBROUTINE PRINT_R3(R3SUM,ISYAMP) 4949CC 4950CC Print the R3 amplitudes. 4951CC This routine should only be commented in when debugging 4952CC the CC3 triplet triple amplitudes, since we statically allocate 4953CC the r3sum array. 4954CC 4955CC HOWEVER : PLEASE DO NOT REMOVE THIS ROUTINE 4956CC 4957CC K. Hald, Spring 2001. 4958C#include "priunit.h" 4959C#include "ccorb.h" 4960C#include "ccsdsym.h" 4961CC 4962C integer isyamp, koff1, isckij, koff2, isyma, isymb, isymi, isymab 4963CC 4964C#if defined (SYS_CRAY) 4965C REAL r3sum(nvirt,nvirt,nvirt*nrhft*nrhft*nrhft) 4966C#else 4967C DOUBLE PRECISION r3sum(nvirt,nvirt,nvirt*nrhft*nrhft*nrhft) 4968C#endif 4969CC 4970C CALL QENTER('PRINT_R3') 4971CC 4972C do isyma = 1, nsym 4973CC 4974C koff1 = 0 4975C do isymi = 1, isyma-1 4976C koff1 = koff1 + nvir(isymi) 4977C enddo 4978CC 4979C do isymb = 1, nsym 4980CC 4981C koff2 = 0 4982C do isymi = 1, isymb-1 4983C koff2 = koff2 + nvir(isymi) 4984C enddo 4985CC 4986C isymab = muld2h(isyma,isymb) 4987C isckij = muld2h(isymab,isyamp) 4988CC 4989C do a = 1, nvir(isyma) 4990C do b = 1, nvir(isymb) 4991C do i = 1, nckij(isckij) 4992C if (abs(r3sum(a+koff1,b+koff2,i)) .gt. 1.0D-9) then 4993C write(lupri,*) 'R3(',a+koff1,',',b+koff2,',',i,') = ', 4994C * r3sum(a+koff1,b+koff2,i) 4995C endif 4996C enddo 4997C enddo 4998C enddo 4999C enddo 5000C enddo 5001CC 5002C CALL QEXIT('PRINT_R3') 5003CC 5004C RETURN 5005C END 5006C /* Deck cc3_sort2 */ 5007 SUBROUTINE CC3_SORT2(WORK,LWORK,ISYINT,LU3SRT,FN3SRT, 5008 * LUDELD5,FNDELD5) 5009C 5010C KH April 2001 based on cc3_sort1 by 5011C Henrik Koch and Alfredo Sanchez. 28-May-1995 5012C 5013C Sort virtual integrals for perturbative triples. 5014C 5015#include "implicit.h" 5016#include "priunit.h" 5017#include "ccorb.h" 5018#include "ccinftap.h" 5019#include "ccsdsym.h" 5020 DIMENSION WORK(LWORK) 5021C 5022 CALL QENTER('CC3_SORT2') 5023C 5024C----------------------------------------- 5025C Start loop over symmetries of delta. 5026C----------------------------------------- 5027C 5028 MAXCK = 0 5029 DO 50 ISYMCK = 1,NSYM 5030 IF (NT1AM(ISYMCK) .GT. MAXCK) MAXCK = NT1AM(ISYMCK) 5031 50 CONTINUE 5032C 5033 DO 100 ISYMD = 1,NSYM 5034C 5035 IF (NBAS(ISYMD) .EQ. 0) GOTO 100 5036C 5037C-------------------------- 5038C Memory allocation. 5039C-------------------------- 5040C 5041 ISYCKB = MULD2H(ISYMD,ISYINT) 5042C 5043 LENMIN = NCKATR(ISYCKB) + MAXCK 5044 NDISTR = MIN(LWORK/LENMIN,NBAS(ISYMD)) 5045C 5046 IF (NDISTR .EQ. 0) THEN 5047 CALL QUIT('Insufficient work space in CC3_SORT2') 5048 ENDIF 5049C 5050 NBATCH = (NBAS(ISYMD) - 1)/NDISTR + 1 5051C 5052 KSCR1 = 1 5053 KSCR2 = KSCR1 + NCKATR(ISYCKB)*NDISTR 5054 KEND1 = KSCR2 + MAXCK*NDISTR 5055C 5056 DO 110 IBATCH = 1,NBATCH 5057C 5058 NUMD = NDISTR 5059 IF (IBATCH .EQ. NBATCH) THEN 5060 NUMD = NBAS(ISYMD) - NDISTR*(NBATCH - 1) 5061 ENDIF 5062C 5063 ID1 = NDISTR*(IBATCH - 1) + 1 5064C 5065C-------------------------- 5066C Read integrals. 5067C-------------------------- 5068C 5069 LENGTH = NCKATR(ISYCKB)*NUMD 5070C 5071 IOFF = ICKDAO(ISYCKB,ISYMD) + NCKATR(ISYCKB)*(ID1 - 1) + 1 5072C 5073 IF (LENGTH .GT. 0) THEN 5074 CALL GETWA2(LU3SRT,FN3SRT,WORK(KSCR1),IOFF,LENGTH) 5075 ENDIF 5076C 5077C----------------------------------------------------- 5078C Sort integrals (bk,del,c) from (ck,b,del). 5079C----------------------------------------------------- 5080C 5081 DO 150 ISYMC = 1,NSYM 5082C 5083 ISYMBK = MULD2H(ISYCKB,ISYMC) 5084 ISYBKD = MULD2H(ISYMBK,ISYMD) 5085C 5086 DO 160 C = 1,NVIR(ISYMC) 5087C 5088 DO 170 I = 1,NUMD 5089C 5090 ID = ID1 + I - 1 5091C 5092 DO 180 ISYMK = 1,NSYM 5093C 5094 ISYMB = MULD2H(ISYMBK,ISYMK) 5095 ISYMCK = MULD2H(ISYMC,ISYMK) 5096C 5097 NTOTCK = MAX(NT1AM(ISYMCK),1) 5098C 5099 DO 190 K = 1,NRHF(ISYMK) 5100 5101C 5102 KOFF1 = KSCR1 5103 * + NCKATR(ISYCKB)*(I - 1) 5104 * + ICKATR(ISYMCK,ISYMB) 5105 * + IT1AM(ISYMC,ISYMK) 5106 * + NVIR(ISYMC)*(K - 1) + C - 1 5107C 5108 KOFF2 = KSCR2 5109 * + NT1AM(ISYMBK)*(I - 1) 5110 * + IT1AM(ISYMB,ISYMK) 5111 * + NVIR(ISYMB)*(K - 1) 5112C 5113 CALL DCOPY(NVIR(ISYMB),WORK(KOFF1),NTOTCK, 5114 * WORK(KOFF2),1) 5115C 5116 190 CONTINUE 5117 180 CONTINUE 5118 170 CONTINUE 5119C 5120C---------------------------------------- 5121C Write sorted integrals. 5122C---------------------------------------- 5123C 5124 LENGTH = NT1AM(ISYMBK)*NUMD 5125C 5126 IF (LENGTH .GT. 0) THEN 5127C 5128 IOFF = ICKAD(ISYBKD,ISYMC) 5129 * + NCKA(ISYBKD)*(C - 1) 5130 * + ICKA(ISYMBK,ISYMD) 5131 * + NT1AM(ISYMBK)*(ID1 - 1) + 1 5132C 5133 CALL PUTWA2(LUDELD5,FNDELD5,WORK(KSCR2), 5134 * IOFF,LENGTH) 5135 ENDIF 5136C 5137 160 CONTINUE 5138 150 CONTINUE 5139C 5140 110 CONTINUE 5141 100 CONTINUE 5142C 5143 CALL QEXIT('CC3_SORT2') 5144C 5145 RETURN 5146 END 5147C /* Deck cc3_trocc3 */ 5148 SUBROUTINE CC3_TROCC3(XINT,TRINT,TRINT2,XLAMDH,WORK,LWORK,ISYINT) 5149C 5150C Adapted to triplet by Kasper Hald, April 2001. 5151C Henrik Koch and Alfredo Sanchez. Dec 1994 5152C 5153C Transform (ia|j delta) integrals to (ia|j k) and sort as (ij,k,a) 5154C 5155C Debugged for ISYINT .NE. 1 Ove Christiansen 11-1-1996 5156C 5157 IMPLICIT NONE 5158C 5159#include "priunit.h" 5160#include "ccorb.h" 5161#include "ccsdsym.h" 5162#include "ccsdinp.h" 5163C 5164 INTEGER LWORK, ISYINT, KOFF1, KOFF2, KOFF3, ISYMD, ISYMK 5165 INTEGER ISYAIJ, NTOIAJ, NBASD, ISYMJ, ISYMAI, ISYAIK, ISYMI 5166 INTEGER ISYMA, ISYMJI, ISYJIK, NTOJIK, ISYMJK 5167C 5168#if defined (SYS_CRAY) 5169 REAL XINT(*),TRINT(*), TRINT2(*), XLAMDH(*),WORK(LWORK) 5170 REAL XTROC, DDOT, ZERO, ONE 5171#else 5172 DOUBLE PRECISION XINT(*),TRINT(*), TRINT2(*), XLAMDH(*) 5173 DOUBLE PRECISION WORK(LWORK), XTROC, DDOT, ZERO, ONE 5174#endif 5175 PARAMETER (ZERO = 0.0D0, ONE = 1.0D0) 5176C 5177 CALL QENTER('CC3_TROCC3') 5178C 5179 IF (LWORK .LT. NTRAOC(ISYINT)) THEN 5180 CALL QUIT('Insufficient space in CC3_TROCC3') 5181 END IF 5182C 5183C write out integral norm 5184C 5185 IF (IPRINT .GT. 55) THEN 5186 XTROC = DDOT(NTOTOC(ISYINT),XINT,1,XINT,1) 5187 WRITE(LUPRI,*) 'In CC3_TROCC3: Norm of INT = ',XTROC 5188 ENDIF 5189C 5190C Transform 5191C 5192 DO 100 ISYMD = 1,NSYM 5193C 5194 ISYMK = ISYMD 5195 ISYAIJ = MULD2H(ISYMD,ISYINT) 5196C 5197 NTOIAJ = MAX(NCKI(ISYAIJ),1) 5198 NBASD = MAX(NBAS(ISYMD),1) 5199C 5200 KOFF1 = ICKID(ISYAIJ,ISYMD) + 1 5201 KOFF2 = ILMRHF(ISYMD) + 1 5202 KOFF3 = ICKITR(ISYAIJ,ISYMK) + 1 5203C 5204 CALL DGEMM('N','N',NCKI(ISYAIJ),NRHF(ISYMK),NBAS(ISYMD), 5205 * ONE,XINT(KOFF1),NTOIAJ,XLAMDH(KOFF2),NBASD, 5206 * ZERO,TRINT(KOFF3),NTOIAJ) 5207C 5208 100 CONTINUE 5209C 5210C write out integral norm 5211C 5212 IF (IPRINT .GT. 55) THEN 5213 XTROC = DDOT(NTRAOC(ISYINT),TRINT,1,TRINT,1) 5214 WRITE(LUPRI,*) 'CC3_TROCC3: Norm of transformed INT = ',XTROC 5215 ENDIF 5216C 5217C 5218C Intechange j and k 5219C 5220 DO 200 ISYMK = 1,NSYM 5221C 5222 ISYAIJ = MULD2H(ISYMK,ISYINT) 5223C 5224 DO 210 ISYMJ = 1,NSYM 5225C 5226 ISYMAI = MULD2H(ISYAIJ,ISYMJ) 5227 ISYAIK = MULD2H(ISYMAI,ISYMK) 5228C 5229 DO 220 K = 1,NRHF(ISYMK) 5230C 5231 DO 230 J = 1,NRHF(ISYMJ) 5232C 5233 KOFF1 = ISAIKJ(ISYAIJ,ISYMK) 5234 * + NCKI(ISYAIJ)*(K - 1) 5235 * + ISAIK(ISYMAI,ISYMJ) 5236 * + NT1AM(ISYMAI)*(J - 1) + 1 5237C 5238 KOFF2 = ISAIKJ(ISYAIK,ISYMJ) 5239 * + NCKI(ISYAIK)*(J - 1) 5240 * + ISAIK(ISYMAI,ISYMK) 5241 * + NT1AM(ISYMAI)*(K - 1) + 1 5242C 5243 CALL DCOPY(NT1AM(ISYMAI),TRINT(KOFF1),1, 5244 * WORK(KOFF2),1) 5245C 5246 230 CONTINUE 5247 220 CONTINUE 5248 210 CONTINUE 5249 200 CONTINUE 5250C 5251C write out integral norm 5252C 5253 IF (IPRINT .GT. 55) THEN 5254 XTROC = DDOT(NTRAOC(ISYINT),TRINT,1,TRINT,1) 5255 WRITE(LUPRI,*) 'In CC3_TROCC: Norm of INT interchaged = ',XTROC 5256 ENDIF 5257C 5258C Resort 5259C 5260 DO 300 ISYMK = 1,NSYM 5261C 5262 ISYAIJ = MULD2H(ISYMK,ISYINT) 5263C 5264 DO 310 ISYMJ = 1,NSYM 5265C 5266 ISYMJK = MULD2H(ISYMJ,ISYMK) 5267 ISYMAI = MULD2H(ISYAIJ,ISYMJ) 5268C 5269 DO 320 ISYMI = 1,NSYM 5270C 5271 ISYMA = MULD2H(ISYMAI,ISYMI) 5272 ISYMJI = MULD2H(ISYMJ,ISYMI) 5273 ISYJIK = MULD2H(ISYMJI,ISYMK) 5274C 5275 DO 330 K = 1,NRHF(ISYMK) 5276C 5277 DO 340 J = 1,NRHF(ISYMJ) 5278C 5279 DO 350 I = 1,NRHF(ISYMI) 5280C 5281 NTOJIK = NMAJIK(ISYJIK) 5282C 5283 KOFF1 = ISAIKJ(ISYAIJ,ISYMK) 5284 * + NCKI(ISYAIJ)*(K - 1) 5285 * + ISAIK(ISYMAI,ISYMJ) 5286 * + NT1AM(ISYMAI)*(J - 1) 5287 * + IT1AM(ISYMA,ISYMI) 5288 * + NVIR(ISYMA)*(I - 1) + 1 5289 KOFF2 = ISJIKA(ISYJIK,ISYMA) 5290 * + ISJIK(ISYMJI,ISYMK) 5291 * + NMATIJ(ISYMJI)*(K - 1) 5292 * + IMATIJ(ISYMJ,ISYMI) 5293 * + NRHF(ISYMJ)*(I - 1) + J 5294 KOFF3 = ISJIKA(ISYJIK,ISYMA) 5295 * + ISJIK(ISYMJK,ISYMI) 5296 * + NMATIJ(ISYMJK)*(I - 1) 5297 * + IMATIJ(ISYMJ,ISYMK) 5298 * + NRHF(ISYMJ)*(K - 1) + J 5299C 5300 CALL DCOPY(NVIR(ISYMA),WORK(KOFF1),1, 5301 * TRINT(KOFF2),NTOJIK) 5302 CALL DCOPY(NVIR(ISYMA),WORK(KOFF1),1, 5303 * TRINT2(KOFF3),NTOJIK) 5304C 5305 350 CONTINUE 5306 340 CONTINUE 5307 330 CONTINUE 5308C 5309 320 CONTINUE 5310 310 CONTINUE 5311 300 CONTINUE 5312C 5313C write out integral norm 5314C 5315 IF (IPRINT .GT. 55) THEN 5316 XTROC = DDOT(NTRAOC(ISYINT),TRINT,1,TRINT,1) 5317 WRITE(LUPRI,*) 'In CC3_TROCC3: Norm of INT Resorted = ',XTROC 5318 ENDIF 5319C 5320 CALL QEXIT('CC3_TROCC3') 5321C 5322 RETURN 5323 END 5324C /* Deck ccsdt_srtoc3 */ 5325 SUBROUTINE CCSDT_SRTOC3(TROCC,TROCC1,ISYINT,WORK,LWORK) 5326C 5327C Henrik Koch and Alfredo Sanchez. Dec 1994 5328C 5329C Sort occupied integrals I(kl,j,c) as I'(cj,l,k) 5330C 5331C Ove Christiansen 16-1-1996: ISYINT sym of I(kl,j,c) 5332C KH April 2001: Adapted to triplet. 5333C 5334 IMPLICIT NONE 5335C 5336#include "priunit.h" 5337#include "ccorb.h" 5338#include "ccsdsym.h" 5339#include "ccsdinp.h" 5340C 5341 INTEGER ISYINT, LWORK, KOFF1, KOFF2, ISYMC, ISYKLJ, ISYMJ 5342 INTEGER ISYCKL, ISYCJL, ISYMKL 5343 INTEGER ISYMCL, ISYML, ISYMK, ISYMCK 5344C 5345#if defined (SYS_CRAY) 5346 REAL TROCC(*),TROCC1(*), WORK(LWORK), ZERO, ONE, TWO 5347#else 5348 DOUBLE PRECISION TROCC(*),TROCC1(*), WORK(LWORK), ZERO, ONE, TWO 5349#endif 5350 5351C 5352 PARAMETER (ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0) 5353C 5354C 5355 CALL QENTER('CCSDT_SRTOC3') 5356C 5357 KOFF2 = 0 5358 DO 100 ISYMC = 1,NSYM 5359C 5360 ISYKLJ = MULD2H(ISYMC,ISYINT) 5361C 5362 DO 110 C = 1,NVIR(ISYMC) 5363C 5364 DO 120 ISYMJ = 1,NSYM 5365C 5366 ISYMKL = MULD2H(ISYKLJ,ISYMJ) 5367 ISYCKL = MULD2H(ISYMJ,ISYINT) 5368C 5369 DO 130 J = 1,NRHF(ISYMJ) 5370C 5371 DO 140 ISYML = 1,NSYM 5372C 5373 ISYMK = MULD2H(ISYMKL,ISYML) 5374 ISYCJL = MULD2H(ISYINT,ISYMK) 5375 ISYMCL = MULD2H(ISYMC,ISYML) 5376C 5377 DO 150 L = 1,NRHF(ISYML) 5378C 5379 DO 160 K = 1,NRHF(ISYMK) 5380C 5381 KOFF1 = ISAIKJ(ISYCJL,ISYMK) 5382 * + NCKI(ISYCJL)*(K - 1) 5383 * + ISAIK(ISYMCL,ISYMJ) 5384 * + NT1AM(ISYMCL)*(J - 1) 5385 * + IT1AM(ISYMC,ISYML) 5386 * + NVIR(ISYMC)*(L - 1) + C 5387C 5388 KOFF2 = KOFF2 + 1 5389C 5390 TROCC1(KOFF1) = TROCC(KOFF2) 5391C 5392 160 CONTINUE 5393 150 CONTINUE 5394 140 CONTINUE 5395 130 CONTINUE 5396 120 CONTINUE 5397 110 CONTINUE 5398 100 CONTINUE 5399C 5400 CALL QEXIT('CCSDT_SRTOC3') 5401C 5402 RETURN 5403 END 5404C /* Deck cc33_t2sort */ 5405 SUBROUTINE CC33_T2SORT(C2,ISYAMP,C2TRANS,ISYMB,B,ISYMC,C) 5406C 5407C Written April 2001 by KH. 5408C 5409C Sort the C2 amplitudes from C2(cl,bj) stored as (cljb) 5410C to a sorting of (ljcb) for a given b and c. 5411C 5412 IMPLICIT NONE 5413C 5414#include "priunit.h" 5415#include "ccorb.h" 5416#include "ccsdsym.h" 5417C 5418 INTEGER ISYAMP, LWORK, ISYMB, ISYMC 5419 INTEGER ISYCLJ, ISYMLJ, ISYML, ISYMJ, ISYMCL, ISYMBJ 5420 integer KOFF1, KOFF2 5421C 5422#if defined (SYS_CRAY) 5423 REAL C2(*), C2TRANS(*) 5424#else 5425 DOUBLE PRECISION C2(*), C2TRANS(*) 5426#endif 5427C 5428 CALL QENTER('CC33_T2SORT') 5429C 5430C---------------------------------- 5431C Symmetry initialitation 5432C---------------------------------- 5433C 5434 ISYCLJ = MULD2H(ISYAMP,ISYMB) 5435 ISYMLJ = MULD2H(ISYCLJ,ISYMC) 5436C 5437 DO ISYML = 1, NSYM 5438C 5439 ISYMJ = MULD2H(ISYMLJ,ISYML) 5440 ISYMCL = MULD2H(ISYMC,ISYML) 5441 ISYMBJ = MULD2H(ISYMB,ISYMJ) 5442C 5443C---------------------------------- 5444C Sort. 5445C---------------------------------- 5446C 5447 DO L = 1, NRHF(ISYML) 5448C 5449 DO J = 1, NRHF(ISYMJ) 5450C 5451 KOFF1 = IT2SP(ISYCLJ,ISYMB) 5452 * + NCKI(ISYCLJ)*(B-1) 5453 * + ISAIK(ISYMCL,ISYMJ) 5454 * + NT1AM(ISYMCL)*(J-1) 5455 * + IT1AM(ISYMC,ISYML) 5456 * + NVIR(ISYMC)*(L-1) + C 5457C 5458 KOFF2 = IMATIJ(ISYML,ISYMJ) 5459 * + NRHF(ISYML)*(J-1) + L 5460C 5461 C2TRANS(KOFF2) = C2(KOFF1) 5462C 5463 ENDDO 5464 ENDDO 5465 ENDDO 5466C 5467 CALL QEXIT('CC33_T2SORT') 5468C 5469 RETURN 5470 END 5471C /* Deck cc3_conocc33 */ 5472 SUBROUTINE CC3_CONOCC33(OMEGA2P,OMEGA2M,RMAT1,RMAT2,RMAT3,RMAT4, 5473 * SMAT,TMAT,ISYMIM,TROCC,TROCC1,ISYINT, 5474 * WORK,LWORK,INDSQ,LENSQ,ISYMIB,IB,ISYMID, 5475 * ID,IOPT) 5476C 5477C Henrik Koch and Alfredo Sanchez. Dec 1994 5478C 5479C Set up combinations of S's and contract with integrals. 5480C 5481C Ove Christiansen 9-1-1996: 5482C 5483C General symmetry: ISYMIM is symmetry of SMAT. 5484C (including isymib*isymid) 5485C ISYINT is symmetry of integrals in 5486C TROCC and TROCC1. 5487C ISYRES = ISYMIM*ISYINT 5488C 5489C Changed to triplet. Kasper Hald April 2001 5490C 5491 IMPLICIT NONE 5492C 5493#include "priunit.h" 5494#include "ccorb.h" 5495#include "ccsdinp.h" 5496#include "ccsdsym.h" 5497C 5498 INTEGER LWORK, ISYMIM, ISYINT, LENSQ, ISYMIB, IB, ISYMID, ID 5499 INTEGER IOPT, KOFF1, KOFF2, KOFF3, KOFF5, KOFF6, LENGTH 5500 INTEGER ISYRES, INDEX 5501 INTEGER NAI, NBJ, NRHFI, NTOCKL, ISYCKL, ISYMI, JSCKLI, ISYMAB 5502 INTEGER ISYMA, NTOTKL, NTOTAI, ISYKLJ, ISYMKL, ISYMAI, ISYMBJ 5503 INTEGER ISYMJ, JSAIKL, ISYMBC, ISYMB, ISYMC, ISYAIJ 5504 INTEGER INDSQ(LENSQ,6) 5505C 5506#if defined (SYS_CRAY) 5507 REAL OMEGA2P(*), OMEGA2M(*), RMAT1(*), RMAT2(*) 5508 REAL RMAT3(*), RMAT4(*) 5509 REAL SMAT(*), TMAT(*), TROCC(*), TROCC1(*) 5510 REAL WORK(LWORK), FACT, ZERO, ONE, TWO, XMONE 5511 REAL DDOT, XRMAT, XTMAT, XDOT 5512#else 5513 DOUBLE PRECISION OMEGA2P(*), OMEGA2M(*), RMAT1(*), RMAT2(*) 5514 DOUBLE PRECISION RMAT3(*), RMAT4(*) 5515 DOUBLE PRECISION SMAT(*), TMAT(*), TROCC(*), TROCC1(*) 5516 DOUBLE PRECISION WORK(LWORK), FACT, ZERO, ONE, TWO, XMONE 5517 DOUBLE PRECISION DDOT, XRMAT, XTMAT, XDOT 5518#endif 5519C 5520 PARAMETER (ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, XMONE = -1.0D0) 5521C 5522 LOGICAL LDEBUG 5523C 5524 INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 5525C 5526 CALL QENTER('CC3_CONOCC33') 5527C 5528 LDEBUG = .FALSE. 5529C 5530 ISYRES = MULD2H(ISYMIM,ISYINT) 5531C 5532C------------------------ 5533C Sanity check. 5534C------------------------ 5535C 5536 IF (LWORK .LT. LENSQ) THEN 5537 CALL QUIT('Insufficient core in CONOCC33') 5538 ENDIF 5539C 5540 IF ((IOPT .NE. 1) .AND. (IOPT .NE. 2)) 5541 * CALL QUIT('WRONG IOPT IN CC3_CONOCC33') 5542C 5543C--------------------------------- 5544C First occupied R2+ term. 5545C--------------------------------- 5546C 5547 IF (IOPT .EQ. 1) THEN 5548 C = ID 5549 B = IB 5550 ISYMC = ISYMID 5551 ISYMB = ISYMIB 5552 FACT = ONE 5553 ELSE 5554 C = IB 5555 B = ID 5556 ISYMC = ISYMIB 5557 ISYMB = ISYMID 5558 FACT = XMONE 5559 ENDIF 5560C 5561 ISYMBC = MULD2H(ISYMB,ISYMC) 5562 JSAIKL = MULD2H(ISYMBC,ISYMIM) 5563C 5564 LENGTH = NCKIJ(JSAIKL) 5565C 5566C---------------------------------- 5567C Setup combinations of smat's. 5568C---------------------------------- 5569C 5570 DO I = 1,LENGTH 5571 TMAT(I) = -FACT*TWO*(SMAT(INDSQ(I,1))-SMAT(I)+SMAT(INDSQ(I,5))) 5572 ENDDO 5573C 5574C---------------------------------- 5575C Symmetry sorting if symmetry. 5576C---------------------------------- 5577C 5578 IF (NSYM .GT. 1) THEN 5579 CALL CC_GATHER(LENGTH,WORK,TMAT,INDSQ(1,6)) 5580 CALL DCOPY(LENGTH,WORK,1,TMAT,1) 5581 ENDIF 5582C 5583 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 5584 XTMAT = DDOT(NCKIJ(JSAIKL),TMAT,1,TMAT,1) 5585 WRITE(LUPRI,*) 'In CC3_CONOCC: 1. Norm of TMAT = ',XTMAT 5586 ENDIF 5587C 5588C----------------------- 5589C First contraction. 5590C----------------------- 5591C 5592 DO 200 ISYMJ = 1,NSYM 5593C 5594 ISYMBJ = MULD2H(ISYMB,ISYMJ) 5595 ISYMAI = MULD2H(ISYMBJ,ISYRES) 5596 ISYMKL = MULD2H(JSAIKL,ISYMAI) 5597 ISYKLJ = MULD2H(ISYMKL,ISYMJ) 5598C 5599 NTOTAI = MAX(NT1AM(ISYMAI),1) 5600 NTOTKL = MAX(NMATIJ(ISYMKL),1) 5601C 5602 KOFF1 = ISAIKL(ISYMAI,ISYMKL) + 1 5603 KOFF2 = ISJIKA(ISYKLJ,ISYMC) 5604 * + NMAJIK(ISYKLJ)*(C - 1) 5605 * + ISJIK(ISYMKL,ISYMJ) + 1 5606 KOFF3 = ISAIK(ISYMAI,ISYMJ) + 1 5607C 5608 IF (IOPT .EQ. 1) THEN 5609 CALL DGEMM('N','N',NT1AM(ISYMAI),NRHF(ISYMJ),NMATIJ(ISYMKL), 5610 * -ONE,TMAT(KOFF1),NTOTAI,TROCC(KOFF2),NTOTKL, 5611 * ONE,RMAT2(KOFF3),NTOTAI) 5612 ELSE 5613 CALL DGEMM('N','N',NT1AM(ISYMAI),NRHF(ISYMJ),NMATIJ(ISYMKL), 5614 * -ONE,TMAT(KOFF1),NTOTAI,TROCC(KOFF2),NTOTKL, 5615 * ONE,RMAT1(KOFF3),NTOTAI) 5616 ENDIF 5617C 5618 200 CONTINUE 5619C 5620 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 5621 ISYAIJ = MULD2H(ISYRES,ISYMB) 5622 IF (IOPT .EQ. 1) THEN 5623 XRMAT = DDOT(NCKI(ISYAIJ),RMAT2,1,RMAT2,1) 5624 WRITE(LUPRI,*) 'CC3_CONOCC33: RMAT2 norm (1) = ',XRMAT 5625 ELSE 5626 XRMAT = DDOT(NCKI(ISYAIJ),RMAT1,1,RMAT1,1) 5627 WRITE(LUPRI,*) 'CC3_CONOCC33: RMAT1 norm (1) = ',XRMAT 5628 ENDIF 5629 ENDIF 5630C 5631C--------------------------------- 5632C First occupied R2- term. 5633C--------------------------------- 5634C 5635 IF (IOPT .EQ. 1) THEN 5636 C = ID 5637 B = IB 5638 ISYMC = ISYMID 5639 ISYMB = ISYMIB 5640 FACT = ONE 5641 ELSE 5642 C = IB 5643 B = ID 5644 ISYMC = ISYMIB 5645 ISYMB = ISYMID 5646 FACT = XMONE 5647 ENDIF 5648C 5649 ISYMBC = MULD2H(ISYMB,ISYMC) 5650 JSAIKL = MULD2H(ISYMBC,ISYMIM) 5651C 5652 LENGTH = NCKIJ(JSAIKL) 5653C 5654C---------------------------------- 5655C Setup combinations of smat's. 5656C---------------------------------- 5657C 5658 DO I = 1,LENGTH 5659 TMAT(I) = FACT*TWO*SMAT(I) 5660 ENDDO 5661C 5662C---------------------------------- 5663C Symmetry sorting if symmetry. 5664C---------------------------------- 5665C 5666 IF (NSYM .GT. 1) THEN 5667 CALL CC_GATHER(LENGTH,WORK,TMAT,INDSQ(1,6)) 5668 CALL DCOPY(LENGTH,WORK,1,TMAT,1) 5669 ENDIF 5670C 5671 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 5672 XTMAT = DDOT(NCKIJ(JSAIKL),TMAT,1,TMAT,1) 5673 WRITE(LUPRI,*) 'In CC3_CONOCC: 1. Norm of TMAT = ',XTMAT 5674 ENDIF 5675C 5676C----------------------- 5677C First contraction. 5678C----------------------- 5679C 5680 DO ISYMJ = 1,NSYM 5681C 5682 ISYMBJ = MULD2H(ISYMB,ISYMJ) 5683 ISYMAI = MULD2H(ISYMBJ,ISYRES) 5684 ISYMKL = MULD2H(JSAIKL,ISYMAI) 5685 ISYKLJ = MULD2H(ISYMKL,ISYMJ) 5686C 5687 NTOTAI = MAX(NT1AM(ISYMAI),1) 5688 NTOTKL = MAX(NMATIJ(ISYMKL),1) 5689C 5690 KOFF1 = ISAIKL(ISYMAI,ISYMKL) + 1 5691 KOFF2 = ISJIKA(ISYKLJ,ISYMC) 5692 * + NMAJIK(ISYKLJ)*(C - 1) 5693 * + ISJIK(ISYMKL,ISYMJ) + 1 5694 KOFF3 = ISAIK(ISYMAI,ISYMJ) + 1 5695C 5696 IF (IOPT .EQ. 1) THEN 5697 CALL DGEMM('N','N',NT1AM(ISYMAI),NRHF(ISYMJ),NMATIJ(ISYMKL), 5698 * -ONE,TMAT(KOFF1),NTOTAI,TROCC(KOFF2),NTOTKL, 5699 * ONE,RMAT4(KOFF3),NTOTAI) 5700 ELSE 5701 CALL DGEMM('N','N',NT1AM(ISYMAI),NRHF(ISYMJ),NMATIJ(ISYMKL), 5702 * -ONE,TMAT(KOFF1),NTOTAI,TROCC(KOFF2),NTOTKL, 5703 * ONE,RMAT3(KOFF3),NTOTAI) 5704 ENDIF 5705C 5706 ENDDO ! ISYMJ 5707C 5708 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 5709 isyaij = muld2h(isyres,isymb) 5710 IF (IOPT .EQ. 1) THEN 5711 XRMAT = DDOT(NCKI(ISYAIJ),RMAT4,1,RMAT4,1) 5712 WRITE(LUPRI,*) 'CC3_CONOCC33: Norm of RMAT4 (1)= ',XRMAT 5713 ELSE 5714 XRMAT = DDOT(NCKI(ISYAIJ),RMAT3,1,RMAT3,1) 5715 WRITE(LUPRI,*) 'CC3_CONOCC33: Norm of RMAT3 (1)= ',XRMAT 5716 ENDIF 5717 ENDIF 5718C 5719C--------------------------------- 5720C Second occupied R2- term. 5721C--------------------------------- 5722C 5723 IF (IOPT .EQ. 1) THEN 5724 B = ID 5725 C = IB 5726 ISYMB = ISYMID 5727 ISYMC = ISYMIB 5728 FACT = ONE 5729 ELSE 5730 B = IB 5731 C = ID 5732 ISYMB = ISYMIB 5733 ISYMC = ISYMID 5734 FACT = XMONE 5735 ENDIF 5736C 5737 ISYMBC = MULD2H(ISYMB,ISYMC) 5738 JSAIKL = MULD2H(ISYMBC,ISYMIM) 5739C 5740 LENGTH = NCKIJ(JSAIKL) 5741C 5742C---------------------------------- 5743C Setup combinations of smat's. 5744C---------------------------------- 5745C 5746 DO I = 1,LENGTH 5747 TMAT(I) = FACT*TWO*SMAT(INDSQ(I,2)) 5748 ENDDO 5749C 5750C---------------------------------- 5751C Symmetry sorting if symmetry. 5752C---------------------------------- 5753C 5754 IF (NSYM .GT. 1) THEN 5755 CALL CC_GATHER(LENGTH,WORK,TMAT,INDSQ(1,6)) 5756 CALL DCOPY(LENGTH,WORK,1,TMAT,1) 5757 ENDIF 5758C 5759 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 5760 XTMAT = DDOT(NCKIJ(JSAIKL),TMAT,1,TMAT,1) 5761 WRITE(LUPRI,*) 'In CC3_CONOCC33: 2. Norm of TMAT = ',XTMAT 5762 ENDIF 5763C 5764C------------------------ 5765C Second contraction. 5766C------------------------ 5767C 5768 DO ISYMJ = 1,NSYM 5769C 5770 ISYMBJ = MULD2H(ISYMB,ISYMJ) 5771 ISYMAI = MULD2H(ISYMBJ,ISYRES) 5772 ISYMKL = MULD2H(JSAIKL,ISYMAI) 5773 ISYKLJ = MULD2H(ISYMKL,ISYMJ) 5774C 5775 NTOTAI = MAX(NT1AM(ISYMAI),1) 5776 NTOTKL = MAX(NMATIJ(ISYMKL),1) 5777C 5778 KOFF1 = ISAIKL(ISYMAI,ISYMKL) + 1 5779 KOFF2 = ISJIKA(ISYKLJ,ISYMC) 5780 * + NMAJIK(ISYKLJ)*(C - 1) 5781 * + ISJIK(ISYMKL,ISYMJ) + 1 5782 KOFF3 = ISAIK(ISYMAI,ISYMJ) + 1 5783C 5784 CALL DGEMM('N','N',NT1AM(ISYMAI),NRHF(ISYMJ),NMATIJ(ISYMKL), 5785 * -ONE,TMAT(KOFF1),NTOTAI,TROCC(KOFF2),NTOTKL, 5786 * ZERO,WORK(KOFF3),NTOTAI) 5787C 5788 ENDDO 5789C 5790C---------------------------------------- 5791C Sort result into result vector. 5792C---------------------------------------- 5793C 5794 ISYAIJ = MULD2H(ISYMB,ISYRES) 5795 IF (IOPT .EQ. 1) THEN 5796 CALL CC3_SORTIJ(WORK,RMAT3,ISYAIJ) 5797 ELSE 5798 CALL CC3_SORTIJ(WORK,RMAT4,ISYAIJ) 5799 ENDIF 5800C 5801 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 5802 IF (IOPT .EQ. 1) THEN 5803 XRMAT = DDOT(NCKI(ISYAIJ),RMAT3,1,RMAT3,1) 5804 WRITE(LUPRI,*) 'CC3_CONOCC33: Norm of RMAT3 (1)= ',XRMAT 5805 ELSE 5806 XRMAT = DDOT(NCKI(ISYAIJ),RMAT4,1,RMAT4,1) 5807 WRITE(LUPRI,*) 'CC3_CONOCC33: Norm of RMAT4 (1)= ',XRMAT 5808 ENDIF 5809 ENDIF 5810C 5811C-------------------------------- 5812C Second occupied R2+ term. 5813C-------------------------------- 5814C 5815 IF (IOPT .EQ. 1) THEN 5816 A = ID 5817 B = IB 5818 ISYMA = ISYMID 5819 ISYMB = ISYMIB 5820 FACT = ONE 5821 ELSE 5822 A = IB 5823 B = ID 5824 ISYMA = ISYMIB 5825 ISYMB = ISYMID 5826 FACT = XMONE 5827 ENDIF 5828C 5829 ISYMAB = MULD2H(ISYMA,ISYMB) 5830 JSCKLI = MULD2H(ISYMAB,ISYMIM) 5831C 5832 LENGTH = NCKIJ(JSCKLI) 5833C 5834C---------------------------------- 5835C Setup combinations of smat's. 5836C---------------------------------- 5837C 5838 DO I = 1,LENGTH 5839 TMAT(I) = FACT*(TWO*SMAT(INDSQ(I,1))-SMAT(I)-SMAT(INDSQ(I,4))) 5840 ENDDO 5841C 5842 IF (IPRINT .GT. 55) THEN 5843 XTMAT = DDOT(NCKIJ(JSAIKL),TMAT,1,TMAT,1) 5844 WRITE(LUPRI,*) 'In CC3_CONOCC33: 3. Norm of TMAT = ',XTMAT 5845 ENDIF 5846C 5847C----------------------- 5848C Third contraction. 5849C----------------------- 5850C 5851 DO 600 ISYMJ = 1,NSYM 5852C 5853 ISYMBJ = MULD2H(ISYMB,ISYMJ) 5854 ISYMAI = MULD2H(ISYMBJ,ISYRES) 5855 ISYMI = MULD2H(ISYMAI,ISYMA) 5856 ISYCKL = MULD2H(ISYMI,JSCKLI) 5857C 5858 IF (LWORK .LT. NRHF(ISYMI)*NRHF(ISYMJ)) THEN 5859 CALL QUIT('Insufficient memory in CC3_CONOCC33') 5860 END IF 5861C 5862 NTOCKL = MAX(NCKI(ISYCKL),1) 5863 NRHFI = MAX(NRHF(ISYMI),1) 5864C 5865 KOFF1 = ISAIKJ(ISYCKL,ISYMI) + 1 5866 KOFF2 = ISAIKJ(ISYCKL,ISYMJ) + 1 5867 KOFF3 = 1 5868C 5869 CALL DGEMM('T','N',NRHF(ISYMI),NRHF(ISYMJ),NCKI(ISYCKL), 5870 * ONE,TMAT(KOFF1),NTOCKL,TROCC1(KOFF2),NTOCKL, 5871 * ZERO,WORK(KOFF3),NRHFI) 5872C 5873 DO 610 J = 1,NRHF(ISYMJ) 5874C 5875 NBJ = IT1AM(ISYMB,ISYMJ) + NVIR(ISYMB)*(J - 1) + B 5876C 5877 IF (ISYMAI.EQ.ISYMBJ) THEN 5878C 5879 DO 620 I = 1,NRHF(ISYMI) 5880C 5881 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + A 5882C 5883 KOFF5 = IT2AM(ISYMAI,ISYMBJ) 5884 * + INDEX(NAI,NBJ) 5885C 5886 KOFF6 = NRHF(ISYMI)*(J - 1) + I 5887C 5888 IF (NAI .NE. NBJ) THEN 5889 OMEGA2P(KOFF5) = OMEGA2P(KOFF5) - WORK(KOFF6) 5890 ENDIF 5891C 5892 620 CONTINUE 5893C 5894 ELSE IF (ISYMAI .LT. ISYMBJ) THEN 5895C 5896 DO 630 I = 1,NRHF(ISYMI) 5897C 5898 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + A 5899C 5900 KOFF5 = IT2AM(ISYMAI,ISYMBJ) 5901 * + NT1AM(ISYMAI)*(NBJ-1) + NAI 5902C 5903 KOFF6 = NRHF(ISYMI)*(J - 1) + I 5904 OMEGA2P(KOFF5) = OMEGA2P(KOFF5) - WORK(KOFF6) 5905C 5906 630 CONTINUE 5907C 5908 ELSE IF (ISYMBJ .LT. ISYMAI) THEN 5909C 5910 DO 640 I = 1,NRHF(ISYMI) 5911C 5912 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + A 5913C 5914 KOFF5 = IT2AM(ISYMAI,ISYMBJ) 5915 * + NT1AM(ISYMBJ)*(NAI-1) + NBJ 5916C 5917 KOFF6 = NRHF(ISYMI)*(J - 1) + I 5918 OMEGA2P(KOFF5) = OMEGA2P(KOFF5) - WORK(KOFF6) 5919C 5920 640 CONTINUE 5921C 5922 ENDIF 5923C 5924 610 CONTINUE 5925C 5926 600 CONTINUE 5927C 5928 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 5929 XDOT = DDOT(NT2AM(ISYRES),OMEGA2P,1,OMEGA2P,1) 5930 WRITE(LUPRI,*) 'CC3_CONOCC33 : Norm OMEGA2P (1) = ',XDOT 5931 ENDIF 5932C 5933 CALL QEXIT('CC3_CONOCC33') 5934C 5935 RETURN 5936 END 5937C /* Deck cc3_sortij */ 5938 SUBROUTINE CC3_SORTIJ(TEMPRMAT,RESRMAT,ISYAIJ) 5939C 5940C Written by Kasper Hald, April 2001. 5941C 5942C Sort the cc3 result vector ai,j to aj,i 5943C 5944 IMPLICIT NONE 5945C 5946#include "priunit.h" 5947#include "ccorb.h" 5948#include "ccsdsym.h" 5949C 5950 INTEGER ISYAIJ, ISYMJ, ISYMAI, ISYMA, ISYMI, ISYMAJ, NAI 5951 INTEGER NAJ, KOFF1, KOFF2 5952C 5953#if defined (SYS_CRAY) 5954 REAL TEMPRMAT(*), RESRMAT(*) 5955#else 5956 DOUBLE PRECISION TEMPRMAT(*), RESRMAT(*) 5957#endif 5958C 5959 CALL QENTER('CC3_SORTIJ') 5960C 5961 DO ISYMJ = 1, NSYM 5962C 5963 ISYMAI = MULD2H(ISYAIJ,ISYMJ) 5964C 5965 DO ISYMA = 1, NSYM 5966C 5967 ISYMI = MULD2H(ISYMAI,ISYMA) 5968 ISYMAJ = MULD2H(ISYMA,ISYMJ) 5969C 5970 DO A = 1, NVIR(ISYMA) 5971C 5972 DO J = 1, NRHF(ISYMJ) 5973C 5974 NAJ = IT1AM(ISYMA,ISYMJ) + NVIR(ISYMA)*(J-1) + A 5975C 5976 DO I = 1, NRHF(ISYMI) 5977C 5978 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I-1) + A 5979 KOFF1 = ISAIK(ISYMAI,ISYMJ) 5980 * + NT1AM(ISYMAI)*(J-1) + NAI 5981 KOFF2 = ISAIK(ISYMAJ,ISYMI) 5982 * + NT1AM(ISYMAJ)*(I-1) + NAJ 5983C 5984 RESRMAT(KOFF2) = RESRMAT(KOFF2) + TEMPRMAT(KOFF1) 5985C 5986 ENDDO 5987 ENDDO 5988 ENDDO 5989 ENDDO 5990 ENDDO 5991C 5992 CALL QEXIT('CC3_SORTIJ') 5993C 5994 RETURN 5995 END 5996C /* Deck cc3_virtint */ 5997 SUBROUTINE CC3_VIRTINT(XLAMDP,WORK,LWRK,ISINT1,ISINT2, 5998 * LU3VI,FN3VI,LU3VI2,FN3VI2,LU3VI4,FN3VI4, 5999 * LU3VI3,FN3VI3) 6000C 6001C Written by Kasper Hald, April 2001. 6002C 6003C Transform the integrals from (ai|del c) to (ai|bc) 6004C and store them on file. 6005C 6006 IMPLICIT NONE 6007#include "priunit.h" 6008#include "ccsdsym.h" 6009#include "ccorb.h" 6010#include "ccinftap.h" 6011C 6012 INTEGER LWRK, ISINT1, ISINT2, ISYMD, ISYCKB, ISCKB1 6013 INTEGER ISCKB2, KENDLO, LWRKLO, IOFF, KTRVI, KINTVI 6014 INTEGER LU3VI, LU3VI2, LU3VI4, LU3VI3 6015C 6016#if defined (SYS_CRAY) 6017 REAL XLAMDP(*), WORK(LWRK) 6018#else 6019 DOUBLE PRECISION XLAMDP(*), WORK(LWRK) 6020#endif 6021C 6022 CHARACTER*(*) FN3VI, FN3VI2, FN3VI4, FN3VI3 6023C 6024 CALL QENTER('CC3_VIRTINT') 6025C 6026 DO ISYMD = 1, NSYM 6027C 6028 ISYCKB = MULD2H(ISYMD,ISYMOP) 6029 ISCKB1 = MULD2H(ISYMD,ISINT1) 6030 ISCKB2 = MULD2H(ISYMD,ISINT2) 6031C 6032 KTRVI = 1 6033 KINTVI = KTRVI + NCKATR(ISCKB1) 6034 KENDLO = KINTVI + MAX(NCKA(ISYMD),NCKA(ISCKB2)) 6035 LWRKLO = LWRK - KENDLO 6036C 6037 IF (LWRKLO .LE. 0) THEN 6038 CALL QUIT('OUT OF MEMORY IN CC3_VIRTINT') 6039 ENDIF 6040C 6041 DO D = 1, NVIR(ISYMD) 6042C 6043C----------------------------------------------- 6044C Read and transform the first integral. 6045C Afterwards write to file. 6046C----------------------------------------------- 6047C 6048 IOFF = ICKAD(ISYCKB,ISYMD) + NCKA(ISYCKB)*(D-1) + 1 6049 IF (NCKA(ISYCKB) .GT. 0) THEN 6050 CALL GETWA2(LU3VI2,FN3VI2,WORK(KINTVI),IOFF, 6051 * NCKA(ISYCKB)) 6052 ENDIF 6053C 6054 CALL CCSDT_TRVIR(WORK(KINTVI),WORK(KTRVI),XLAMDP, 6055 * ISYMD,D,ISYMOP,WORK(KENDLO),LWRKLO) 6056C 6057 IF (NCKATR(ISCKB1) .GT. 0) THEN 6058 IOFF = ICKBD(ISYCKB,ISYMD) + NCKATR(ISYCKB)*(D-1) + 1 6059 CALL PUTWA2(LU3VI3,FN3VI3,WORK(KTRVI),IOFF,NCKATR(ISCKB1)) 6060 ENDIF 6061C 6062C 6063C----------------------------------------------- 6064C Read and transform the second integral. 6065C Afterwards write to file. 6066C----------------------------------------------- 6067C 6068 IOFF = ICKAD(ISYCKB,ISYMD) + NCKA(ISYCKB)*(D - 1) + 1 6069 IF (NCKA(ISYCKB) .GT. 0) THEN 6070 CALL GETWA2(LU3VI,FN3VI,WORK(KINTVI),IOFF, 6071 * NCKA(ISYCKB)) 6072 ENDIF 6073 CALL CCSDT_TRVIR(WORK(KINTVI),WORK(KTRVI),XLAMDP, 6074 * ISYMD,D,ISYMOP,WORK(KENDLO),LWRKLO) 6075C 6076 IF (NCKATR(ISCKB1) .GT. 0) THEN 6077 IOFF = ICKBD(ISYCKB,ISYMD) + NCKATR(ISYCKB)*(D-1) + 1 6078 CALL PUTWA2(LU3VI4,FN3VI4,WORK(KTRVI),IOFF,NCKATR(ISCKB1)) 6079 ENDIF 6080C 6081 ENDDO 6082 ENDDO 6083C 6084 CALL QEXIT('CC3_VIRTINT') 6085C 6086 RETURN 6087 END 6088C /* Deck cc3_convir33 */ 6089 SUBROUTINE CC3_CONVIR33(OMEGA2P,RES2P,OMEGA2M,RES2M,RMAT1,RMAT2, 6090 * RMAT3,RMAT4,SMAT,TMAT,ISYMIM,TRVIR,TRVIR1, 6091 * TRVIR2,TRVIR3,ISYINT,WORK,LWORK,INDSQ, 6092 * LENSQ,ISYMB1,B1,ISYMD1,D1,IOPT,TIME1P, 6093 * TIME2P,TIME3P,TIME1M,TIME2M,TSORTP,TSORTM) 6094C 6095C Written by Kasper Hald, April 2001. 6096C 6097C Based on CC3_CONVIR by 6098C Henrik Koch and Alfredo Sanchez. Dec 1994 & 6099C Ove Christiansen 9-1-1996: 6100C 6101 IMPLICIT NONE 6102C 6103#include "priunit.h" 6104#include "ccorb.h" 6105#include "ccsdsym.h" 6106#include "ccsdinp.h" 6107#include "second.h" 6108C 6109 INTEGER LWORK, ISYMIM, ISYINT, LENSQ, ISYMB1, B1 6110 INTEGER ISYMD1, D1, IOPT, ISYRES, ISYMBD, ISCKIJ, LENGTH, ISYMJ 6111 INTEGER KSCR1, KEND1, LWRK1, ISYMI, ISYMCK, ISYMA, NTOTCK, KOFF1 6112 INTEGER KOFF2, KOFF3, ISYMBJ, ISYMAI, ISYCKI, ISYMD, ISYMB, NVIRA 6113 INTEGER INDSQ(LENSQ,6), INDEX, KOFF4, KOFF5, NAI, NBJ, ISYAIB 6114 INTEGER NTOBIJ, NTOTL, ISYBIJ, ISYML, ISYMAL, ISYAEL, KRESP 6115 INTEGER ISBIJL, ISYMED, ISYME, ISYMAB, NTOTA, NMAXAI, KINT1 6116 INTEGER ISYCKA, ISYDOT, ISYMEL 6117C 6118#if defined (SYS_CRAY) 6119 REAL RES2P(*), RES2M(*) 6120 REAL OMEGA2P(*), OMEGA2M(*), RMAT1(*), RMAT2(*) 6121 REAL RMAT3(*), RMAT4(*), SMAT(*), TMAT(*), TRVIR(*), TRVIR1(*) 6122 REAL TRVIR2(*), TRVIR3(*), WORK(LWORK) 6123 REAL FACT, FACT2, ZERO, ONE, TWO, XMONE, XDOT, DDOT 6124 REAL TIME1P, TIME2P, TIME3P, TIME1M, TIME2M, DTIME 6125 REAL TSORTP, TSORTM 6126#else 6127 DOUBLE PRECISION RES2P(*), RES2M(*) 6128 DOUBLE PRECISION OMEGA2P(*), OMEGA2M(*), RMAT1(*), RMAT2(*) 6129 DOUBLE PRECISION RMAT3(*), RMAT4(*), SMAT(*), TMAT(*), TRVIR(*) 6130 DOUBLE PRECISION TRVIR1(*), TRVIR2(*), TRVIR3(*), WORK(LWORK) 6131 DOUBLE PRECISION FACT, FACT2, ZERO, ONE, TWO, XMONE, XDOT, DDOT 6132 DOUBLE PRECISION TIME1P, TIME2P, TIME3P, TIME1M, TIME2M, DTIME 6133 DOUBLE PRECISION TSORTP, TSORTM 6134#endif 6135C 6136 PARAMETER (ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, XMONE = -1.0D0) 6137C 6138 LOGICAL LDEBUG 6139C 6140C INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 6141C 6142 CALL QENTER('CC3_CONVIR33') 6143C 6144 LDEBUG = .FALSE. 6145C 6146C------------------------ 6147C Sanity check. 6148C------------------------ 6149C 6150 IF ((IOPT .NE. 1) .AND. (IOPT .NE. 2)) THEN 6151 CALL QUIT('Wrong IOPT in CC3_CONVIR3') 6152 ENDIF 6153C 6154C------------------------------------------ 6155C First virtual contribution to (+). 6156C------------------------------------------ 6157C 6158 DTIME = SECOND() 6159C 6160 IF (IOPT .EQ. 1) THEN 6161 ISYMB = ISYMB1 6162 B = B1 6163 ISYMD = ISYMD1 6164 D = D1 6165 FACT = ONE 6166 ELSE 6167 ISYMB = ISYMD1 6168 B = D1 6169 ISYMD = ISYMB1 6170 D = B1 6171 FACT = XMONE 6172 ENDIF 6173C 6174 ISYRES = MULD2H(ISYMIM,ISYINT) 6175C 6176 ISYMBD = MULD2H(ISYMB,ISYMD) 6177 ISCKIJ = MULD2H(ISYMBD,ISYMIM) 6178C 6179 LENGTH = NCKIJ(ISCKIJ) 6180C 6181 IF (LWORK .LT. NCKIJ(ISCKIJ)) THEN 6182 CALL QUIT('Insufficient core in CCSDT_CONVIR33 (1)') 6183 ENDIF 6184C 6185 DO I = 1,LENGTH 6186 TMAT(I) = -FACT*TWO*(SMAT(I)+SMAT(INDSQ(I,4))) 6187 ENDDO 6188C 6189C--------------------------- 6190C Contract with (ac|kd). 6191C--------------------------- 6192C 6193 DO 200 ISYMJ = 1,NSYM 6194C 6195 ISYMBJ = MULD2H(ISYMB,ISYMJ) 6196 ISYMAI = MULD2H(ISYMBJ,ISYRES) 6197 ISYCKI = MULD2H(ISCKIJ,ISYMJ) 6198C 6199 KSCR1 = 1 6200 KEND1 = KSCR1 + NT1AM(ISYMAI) 6201 LWRK1 = LWORK - KEND1 6202C 6203 IF (LWRK1 .LT. 0) THEN 6204 CALL QUIT('Insufficient work space in CC3_CONVIR33 (1)') 6205 ENDIF 6206C 6207 DO 210 J = 1,NRHF(ISYMJ) 6208C 6209 DO 220 ISYMI = 1,NSYM 6210C 6211 ISYMCK = MULD2H(ISYCKI,ISYMI) 6212 ISYMA = MULD2H(ISYMAI,ISYMI) 6213 ISYCKA = MULD2H(ISYMCK,ISYMA) 6214C 6215 NTOTCK = MAX(NT1AM(ISYMCK),1) 6216 NVIRA = MAX(NVIR(ISYMA),1) 6217C 6218 KOFF1 = ICKATR(ISYMCK,ISYMA) + 1 6219 KOFF2 = ISAIKJ(ISYCKI,ISYMJ) 6220 * + NCKI(ISYCKI)*(J - 1) 6221 * + ISAIK(ISYMCK,ISYMI) + 1 6222 KOFF3 = ISAIK(ISYMAI,ISYMJ) 6223 * + NT1AM(ISYMAI)*(J - 1) 6224 * + IT1AM(ISYMA,ISYMI) + 1 6225C 6226 IF (IOPT .EQ. 1) THEN 6227 CALL DGEMM('T','N',NVIR(ISYMA),NRHF(ISYMI), 6228 * NT1AM(ISYMCK),ONE,TRVIR1(KOFF1),NTOTCK, 6229 * TMAT(KOFF2),NTOTCK,ONE,RMAT2(KOFF3),NVIRA) 6230 ELSE 6231 CALL DGEMM('T','N',NVIR(ISYMA),NRHF(ISYMI), 6232 * NT1AM(ISYMCK),ONE,TRVIR3(KOFF1),NTOTCK, 6233 * TMAT(KOFF2),NTOTCK,ONE,RMAT1(KOFF3),NVIRA) 6234 ENDIF 6235C 6236 220 CONTINUE 6237 210 CONTINUE 6238 200 CONTINUE 6239 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 6240 ISYDOT = MULD2H(ISYMB,ISYRES) 6241 IF (IOPT .EQ. 1) THEN 6242 XDOT = DDOT(NCKI(ISYDOT),RMAT2,1,RMAT2,1) 6243 WRITE(LUPRI,*) 'CC3_CONVIR33 : Norm RMAT2 (1) = ',XDOT 6244 ELSE 6245 XDOT = DDOT(NCKI(ISYDOT),RMAT1,1,RMAT1,1) 6246 WRITE(LUPRI,*) 'CC3_CONVIR33 : Norm RMAT1 (1) = ',XDOT 6247 ENDIF 6248 ENDIF 6249C 6250 DTIME = SECOND() - DTIME 6251 TIME1P = TIME1P + DTIME 6252C 6253C-------------------------------------------- 6254C Second virtual contribution to (+). 6255C-------------------------------------------- 6256C 6257 DTIME = SECOND() 6258C 6259 IF (IOPT .EQ. 1) THEN 6260 ISYMB = ISYMB1 6261 B = B1 6262 ISYMD = ISYMD1 6263 D = D1 6264 FACT = ONE 6265 ELSE 6266 ISYMB = ISYMD1 6267 B = D1 6268 ISYMD = ISYMB1 6269 D = B1 6270 FACT = XMONE 6271 ENDIF 6272C 6273 ISYRES = MULD2H(ISYMIM,ISYINT) 6274C 6275 ISYMBD = MULD2H(ISYMB,ISYMD) 6276 ISCKIJ = MULD2H(ISYMBD,ISYMIM) 6277C 6278 LENGTH = NCKIJ(ISCKIJ) 6279C 6280 IF (LWORK .LT. NCKIJ(ISCKIJ)) THEN 6281 CALL QUIT('Insufficient core in CC3_CONVIR33 (2)') 6282 ENDIF 6283C 6284 DO I = 1,LENGTH 6285 TMAT(I) = FACT*(SMAT(I)+TWO*SMAT(INDSQ(I,4))) 6286 ENDDO 6287C 6288C--------------------------- 6289C Contract with (ac|kd). 6290C--------------------------- 6291C 6292 DO ISYMJ = 1,NSYM 6293C 6294 ISYMBJ = MULD2H(ISYMB,ISYMJ) 6295 ISYMAI = MULD2H(ISYMBJ,ISYRES) 6296 ISYCKI = MULD2H(ISCKIJ,ISYMJ) 6297C 6298 KSCR1 = 1 6299 KEND1 = KSCR1 + NT1AM(ISYMAI) 6300 LWRK1 = LWORK - KEND1 6301C 6302 IF (LWRK1 .LT. 0) THEN 6303 CALL QUIT('Insufficient work space in CC3_CONVIR33 (2)') 6304 ENDIF 6305C 6306 DO J = 1,NRHF(ISYMJ) 6307C 6308 DO ISYMI = 1,NSYM 6309C 6310 ISYMCK = MULD2H(ISYCKI,ISYMI) 6311 ISYMA = MULD2H(ISYMAI,ISYMI) 6312 ISYCKA = MULD2H(ISYMCK,ISYMA) 6313C 6314 NTOTCK = MAX(NT1AM(ISYMCK),1) 6315 NVIRA = MAX(NVIR(ISYMA),1) 6316C 6317 KOFF1 = ICKATR(ISYMCK,ISYMA) + 1 6318 KOFF2 = ISAIKJ(ISYCKI,ISYMJ) 6319 * + NCKI(ISYCKI)*(J - 1) 6320 * + ISAIK(ISYMCK,ISYMI) + 1 6321 KOFF3 = ISAIK(ISYMAI,ISYMJ) 6322 * + NT1AM(ISYMAI)*(J - 1) 6323 * + IT1AM(ISYMA,ISYMI) + 1 6324C 6325 IF (IOPT .EQ. 1) THEN 6326 CALL DGEMM('T','N',NVIR(ISYMA),NRHF(ISYMI), 6327 * NT1AM(ISYMCK),ONE,TRVIR(KOFF1),NTOTCK, 6328 * TMAT(KOFF2),NTOTCK,ONE,RMAT2(KOFF3),NVIRA) 6329 ELSE 6330 CALL DGEMM('T','N',NVIR(ISYMA),NRHF(ISYMI), 6331 * NT1AM(ISYMCK),ONE,TRVIR2(KOFF1),NTOTCK, 6332 * TMAT(KOFF2),NTOTCK,ONE,RMAT1(KOFF3),NVIRA) 6333 ENDIF 6334C 6335 ENDDO ! ISYMI 6336 ENDDO ! J 6337 ENDDO ! ISYMJ 6338C 6339 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 6340 ISYDOT = MULD2H(ISYMB,ISYRES) 6341 IF (IOPT .EQ. 1) THEN 6342 XDOT = DDOT(NCKI(ISYDOT),RMAT2,1,RMAT2,1) 6343 WRITE(LUPRI,*) 'CC3_CONVIR33 : Norm RMAT2 (2) = ',XDOT 6344 ELSE 6345 XDOT = DDOT(NCKI(ISYDOT),RMAT1,1,RMAT1,1) 6346 WRITE(LUPRI,*) 'CC3_CONVIR33 : Norm RMAT1 (2) = ',XDOT 6347 ENDIF 6348 ENDIF 6349C 6350 DTIME = SECOND() - DTIME 6351 TIME2P = TIME2P + DTIME 6352C 6353C-------------------------------------------- 6354C First virtual contribution to (-). 6355C-------------------------------------------- 6356C 6357 DTIME = SECOND() 6358C 6359 IF (IOPT .EQ. 1) THEN 6360 ISYMB = ISYMB1 6361 B = B1 6362 ISYMD = ISYMD1 6363 D = D1 6364 FACT = ONE 6365 ELSE 6366 ISYMB = ISYMD1 6367 B = D1 6368 ISYMD = ISYMB1 6369 D = B1 6370 FACT = XMONE 6371 ENDIF 6372C 6373 ISYRES = MULD2H(ISYMIM,ISYINT) 6374C 6375 ISYMBD = MULD2H(ISYMB,ISYMD) 6376 ISCKIJ = MULD2H(ISYMBD,ISYMIM) 6377C 6378 LENGTH = NCKIJ(ISCKIJ) 6379C 6380 IF (LWORK .LT. NCKIJ(ISCKIJ)) THEN 6381 CALL QUIT('Insufficient core in CC3_CONVIR33 (2)') 6382 ENDIF 6383C 6384 DO I = 1,LENGTH 6385 TMAT(I) = -FACT*TWO*SMAT(INDSQ(I,1)) 6386 ENDDO 6387C 6388C--------------------------- 6389C Contract with (ac|kd). 6390C--------------------------- 6391C 6392 DO ISYMJ = 1,NSYM 6393C 6394 ISYMBJ = MULD2H(ISYMB,ISYMJ) 6395 ISYMAI = MULD2H(ISYMBJ,ISYRES) 6396 ISYCKI = MULD2H(ISCKIJ,ISYMJ) 6397C 6398 KSCR1 = 1 6399 KEND1 = KSCR1 + NT1AM(ISYMAI) 6400 LWRK1 = LWORK - KEND1 6401C 6402 IF (LWRK1 .LT. 0) THEN 6403 CALL QUIT('Insufficient work space in CC3_CONVIR33 (2)') 6404 ENDIF 6405C 6406 DO J = 1,NRHF(ISYMJ) 6407C 6408 DO ISYMI = 1,NSYM 6409C 6410 ISYMCK = MULD2H(ISYCKI,ISYMI) 6411 ISYMA = MULD2H(ISYMAI,ISYMI) 6412 ISYCKA = MULD2H(ISYMCK,ISYMA) 6413C 6414 NTOTCK = MAX(NT1AM(ISYMCK),1) 6415 NVIRA = MAX(NVIR(ISYMA),1) 6416C 6417 KOFF1 = ICKATR(ISYMCK,ISYMA) + 1 6418 KOFF2 = ISAIKJ(ISYCKI,ISYMJ) 6419 * + NCKI(ISYCKI)*(J - 1) 6420 * + ISAIK(ISYMCK,ISYMI) + 1 6421 KOFF3 = ISAIK(ISYMAI,ISYMJ) 6422 * + NT1AM(ISYMAI)*(J - 1) 6423 * + IT1AM(ISYMA,ISYMI) + 1 6424C 6425 IF (IOPT .EQ. 1) THEN 6426 CALL DGEMM('T','N',NVIR(ISYMA),NRHF(ISYMI), 6427 * NT1AM(ISYMCK),ONE,TRVIR(KOFF1),NTOTCK, 6428 * TMAT(KOFF2),NTOTCK,ONE,RMAT4(KOFF3),NVIRA) 6429 ELSE 6430 CALL DGEMM('T','N',NVIR(ISYMA),NRHF(ISYMI), 6431 * NT1AM(ISYMCK),ONE,TRVIR2(KOFF1),NTOTCK, 6432 * TMAT(KOFF2),NTOTCK,ONE,RMAT3(KOFF3),NVIRA) 6433 ENDIF 6434C 6435 ENDDO ! ISYMI 6436 ENDDO ! J 6437 ENDDO ! ISYMJ 6438C 6439 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 6440 ISYDOT = MULD2H(ISYMB,ISYRES) 6441 IF (IOPT .EQ. 1) THEN 6442 XDOT = DDOT(NCKI(ISYDOT),RMAT4,1,RMAT4,1) 6443 WRITE(LUPRI,*) 'CC3_CONVIR33 : Norm RMAT4 (1) = ',XDOT 6444 ELSE 6445 XDOT = DDOT(NCKI(ISYDOT),RMAT3,1,RMAT3,1) 6446 WRITE(LUPRI,*) 'CC3_CONVIR33 : Norm RMAT3 (1) = ',XDOT 6447 ENDIF 6448 ENDIF 6449C 6450 DTIME = SECOND() - DTIME 6451 TIME1M = TIME1M + DTIME 6452C 6453C--------------------------------------- 6454C Third virtual contribution to (+). 6455C--------------------------------------- 6456C 6457 DTIME = SECOND() 6458C 6459 IF (IOPT .EQ. 1) THEN 6460 ISYME = ISYMB1 6461 E = B1 6462 ISYMD = ISYMD1 6463 D = D1 6464 FACT = ONE 6465 ELSE 6466 ISYME = ISYMD1 6467 E = D1 6468 ISYMD = ISYMB1 6469 D = B1 6470 FACT = XMONE 6471 ENDIF 6472C 6473 NMAXAI = 0 6474 DO ISYMI = 1, NSYM 6475 IF (NT1AM(ISYMI) .GT. NMAXAI) NMAXAI = NT1AM(ISYMI) 6476 ENDDO 6477C 6478 ISYRES = MULD2H(ISYMIM,ISYINT) 6479 ISYMED = MULD2H(ISYME,ISYMD) 6480 ISYAEL = MULD2H(ISYINT,ISYMD) 6481 ISYMAL = MULD2H(ISYAEL,ISYME) 6482 ISBIJL = MULD2H(ISYMIM,ISYMED) 6483C 6484 KINT1 = 1 6485 KEND1 = KINT1 + NMAXAI 6486 LWRK1 = LWORK - KEND1 6487C 6488 IF (LWRK1 .LE. 0) THEN 6489 CALL QUIT('Insufficient work space in CC3_CONVIR33 (3)') 6490 ENDIF 6491C 6492 LENGTH = NCKIJ(ISBIJL) 6493 DO I = 1,LENGTH 6494 TMAT(I) = -FACT*(TWO*SMAT(I)+SMAT(INDSQ(I,4))) 6495 ENDDO 6496C 6497C-------------------------------- 6498C Calculate 6499C-------------------------------- 6500C 6501 DO ISYML = 1, NSYM 6502C 6503 ISYMA = MULD2H(ISYMAL,ISYML) 6504 ISYBIJ = MULD2H(ISBIJL,ISYML) 6505 ISYMEL = MULD2H(ISYME,ISYML) 6506C 6507C-------------------------------- 6508C Sort the integrals. 6509C-------------------------------- 6510C 6511 DO L = 1, NRHF(ISYML) 6512 DO A = 1, NVIR(ISYMA) 6513 KOFF1 = KINT1 - 1 6514 * + NVIR(ISYMA)*(L-1) + A 6515 KOFF2 = ICKATR(ISYMEL,ISYMA) 6516 * + NT1AM(ISYMEL)*(A-1) 6517 * + IT1AM(ISYME,ISYML) 6518 * + NVIR(ISYME)*(L-1) + E 6519C 6520 IF (IOPT .EQ. 1) THEN 6521 WORK(KOFF1) = TRVIR(KOFF2) 6522 ELSE 6523 WORK(KOFF1) = TRVIR2(KOFF2) 6524 ENDIF 6525 ENDDO 6526 ENDDO 6527C 6528C------------------------------------- 6529C Contract. 6530C------------------------------------- 6531C 6532C 6533 NTOTL = MAX(1,NRHF(ISYML)) 6534 NTOBIJ = MAX(1,NCKI(ISYBIJ)) 6535 NTOTA = MAX(1,NVIR(ISYMA)) 6536C 6537 KOFF1 = ISAIKJ(ISYBIJ,ISYML) 6538 * + 1 6539 KOFF2 = KINT1 6540 KOFF3 = 1 6541 * + IT2SP(ISYBIJ,ISYMA) 6542C 6543 IF (IOPT .EQ. 1) THEN 6544 CALL DGEMM('N','T',NCKI(ISYBIJ),NVIR(ISYMA),NRHF(ISYML), 6545 * ONE,TMAT(KOFF1),NTOBIJ,WORK(KOFF2),NTOTA,ONE, 6546 * RES2P(KOFF3),NTOBIJ) 6547 ELSE 6548 CALL DGEMM('N','T',NCKI(ISYBIJ),NVIR(ISYMA),NRHF(ISYML), 6549 * ONE,TMAT(KOFF1),NTOBIJ,WORK(KOFF2),NTOTA,ONE, 6550 * RES2P(KOFF3),NTOBIJ) 6551 ENDIF 6552C 6553 ENDDO !ISYML 6554C 6555 DTIME = SECOND() - DTIME 6556 TIME3P = TIME3P + DTIME 6557C 6558C--------------------------------------- 6559C Sort result into result vector. 6560C--------------------------------------- 6561C 6562 DTIME = SECOND() 6563C 6564 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 6565 XDOT = DDOT(NT2AM(ISYRES),OMEGA2P,1,OMEGA2P,1) 6566 WRITE(LUPRI,*) 'CC3_CONVIR33 : Norm OMEGA2P (1) = ',XDOT 6567 ENDIF 6568C 6569 DTIME = SECOND() - DTIME 6570 TSORTP = TSORTP + DTIME 6571C 6572C------------------------------------------ 6573C Second virtual contribution to (-). 6574C------------------------------------------ 6575C 6576 DTIME = SECOND() 6577C 6578 IF (IOPT .EQ. 1) THEN 6579 ISYME = ISYMB1 6580 E = B1 6581 ISYMD = ISYMD1 6582 D = D1 6583 FACT = ONE 6584 ELSE 6585 ISYME = ISYMD1 6586 E = D1 6587 ISYMD = ISYMB1 6588 D = B1 6589 FACT = XMONE 6590 ENDIF 6591C 6592 NMAXAI = 0 6593 DO ISYMI = 1, NSYM 6594 IF (NT1AM(ISYMI) .GT. NMAXAI) NMAXAI = NT1AM(ISYMI) 6595 ENDDO 6596C 6597 ISYRES = MULD2H(ISYMIM,ISYINT) 6598 ISYMED = MULD2H(ISYME,ISYMD) 6599 ISYAEL = MULD2H(ISYINT,ISYMD) 6600 ISYMAL = MULD2H(ISYAEL,ISYME) 6601 ISBIJL = MULD2H(ISYMIM,ISYMED) 6602C 6603 KINT1 = 1 6604 KEND1 = KINT1 + NMAXAI 6605 LWRK1 = LWORK - KEND1 6606C 6607 IF (LWRK1 .LE. 0) THEN 6608 CALL QUIT('Insufficient work space in CC3_CONVIR33 (3)') 6609 ENDIF 6610C 6611 CALL DZERO(WORK(KINT1),NMAXAI) 6612C 6613 LENGTH = NCKIJ(ISBIJL) 6614 DO I = 1,LENGTH 6615 TMAT(I) = -FACT*SMAT(INDSQ(I,3)) 6616 ENDDO 6617C 6618C-------------------------------- 6619C Calculate 6620C-------------------------------- 6621C 6622 DO ISYML = 1, NSYM 6623C 6624 ISYMA = MULD2H(ISYMAL,ISYML) 6625 ISYBIJ = MULD2H(ISBIJL,ISYML) 6626 ISYMEL = MULD2H(ISYME,ISYML) 6627C 6628C-------------------------------- 6629C Sort the integrals. 6630C-------------------------------- 6631C 6632 DO L = 1, NRHF(ISYML) 6633 DO A = 1, NVIR(ISYMA) 6634 KOFF1 = KINT1 - 1 6635 * + NVIR(ISYMA)*(L-1) + A 6636 KOFF2 = ICKATR(ISYMEL,ISYMA) 6637 * + NT1AM(ISYMEL)*(A-1) 6638 * + IT1AM(ISYME,ISYML) 6639 * + NVIR(ISYME)*(L-1) + E 6640C 6641 IF (IOPT .EQ. 1) THEN 6642 WORK(KOFF1) = TRVIR(KOFF2) 6643 ELSE 6644 WORK(KOFF1) = TRVIR2(KOFF2) 6645 ENDIF 6646 ENDDO 6647 ENDDO 6648C 6649C------------------------------------- 6650C Contract. 6651C------------------------------------- 6652C 6653C 6654 NTOTL = MAX(1,NRHF(ISYML)) 6655 NTOBIJ = MAX(1,NCKI(ISYBIJ)) 6656 NTOTA = MAX(1,NVIR(ISYMA)) 6657C 6658 KOFF1 = ISAIKJ(ISYBIJ,ISYML) 6659 * + 1 6660 KOFF2 = KINT1 6661 KOFF3 = 1 6662 * + IT2SP(ISYBIJ,ISYMA) 6663C 6664 IF (IOPT .EQ. 1) THEN 6665 CALL DGEMM('N','T',NCKI(ISYBIJ),NVIR(ISYMA),NRHF(ISYML), 6666 * ONE,TMAT(KOFF1),NTOBIJ,WORK(KOFF2),NTOTA,ONE, 6667 * RES2M(KOFF3),NTOBIJ) 6668 ELSE 6669 CALL DGEMM('N','T',NCKI(ISYBIJ),NVIR(ISYMA),NRHF(ISYML), 6670 * ONE,TMAT(KOFF1),NTOBIJ,WORK(KOFF2),NTOTA,ONE, 6671 * RES2M(KOFF3),NTOBIJ) 6672 ENDIF 6673C 6674 ENDDO !ISYML 6675C 6676 DTIME = SECOND() - DTIME 6677 TIME2M = TIME2M + DTIME 6678C 6679C--------------------------------------- 6680C Sort result into result vector. 6681C--------------------------------------- 6682C 6683 DTIME = SECOND() 6684C 6685 IF (IPRINT .GT. 55 .OR. LDEBUG) THEN 6686 XDOT = DDOT(NT2AM(ISYRES),OMEGA2M,1,OMEGA2M,1) 6687 WRITE(LUPRI,*) 'CC3_CONVIR33 : Norm OMEGA2M (1) = ',XDOT 6688 ENDIF 6689C 6690 DTIME = SECOND() - DTIME 6691 TSORTM = TSORTM + DTIME 6692C 6693 CALL QEXIT('CC3_CONVIR33') 6694C 6695 RETURN 6696 END 6697C /* Deck cc3_sortminus */ 6698 SUBROUTINE CC3_SORTMINUS(OMEGA2M,RES2M,ISYRES) 6699C 6700C K. Hald, April 2001. 6701C 6702 IMPLICIT NONE 6703C 6704#include "priunit.h" 6705#include "ccorb.h" 6706#include "ccsdsym.h" 6707C 6708 INTEGER ISYMA, ISYMB, ISYMAB, ISYMI, ISYMAI, ISYAIB, ISYMJ 6709 INTEGER ISYMBJ, ISYBIJ, NAI, NBJ, KOFF4, KOFF5, INDEX, ISYRES 6710C 6711#if defined (SYS_CRAY) 6712 REAL OMEGA2M(*), RES2M(*), ZERO, ONE, XMONE, FACT2 6713#else 6714 DOUBLE PRECISION OMEGA2M(*), RES2M(*), ZERO, ONE, XMONE, FACT2 6715#endif 6716C 6717 PARAMETER (ZERO = 0.0D0, ONE = 1.0D0, XMONE = -1.0D0) 6718C 6719 INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 6720C 6721 CALL QENTER('CC3_SORTMINUS') 6722C 6723C--------------------------------- 6724C Sort the (-) part. 6725C--------------------------------- 6726C 6727 DO ISYMA = 1, NSYM 6728C 6729 DO ISYMB = 1, NSYM 6730C 6731 ISYMAB = MULD2H(ISYMA,ISYMB) 6732C 6733 DO ISYMI = 1, NSYM 6734C 6735 ISYMAI = MULD2H(ISYMA,ISYMI) 6736 ISYAIB = MULD2H(ISYMAI,ISYMB) 6737 ISYMJ = MULD2H(ISYAIB,ISYRES) 6738 ISYMBJ = MULD2H(ISYMB,ISYMJ) 6739 ISYBIJ = MULD2H(ISYMBJ,ISYMI) 6740C 6741 DO A = 1, NVIR(ISYMA) 6742 DO I = 1, NRHF(ISYMI) 6743 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + A 6744C 6745 DO B = 1, NVIR(ISYMB) 6746 DO J = 1, NRHF(ISYMJ) 6747C 6748 NBJ = IT1AM(ISYMB,ISYMJ) + NVIR(ISYMB)*(J - 1) + B 6749C 6750 KOFF4 = IT2SP(ISYBIJ,ISYMA) 6751 * + NCKI(ISYBIJ)*(A-1) 6752 * + ISAIK(ISYMBJ,ISYMI) 6753 * + NT1AM(ISYMBJ)*(I-1) + NBJ 6754C 6755 IF (ISYMAI.EQ.ISYMBJ) THEN 6756 KOFF5 = IT2AM(ISYMAI,ISYMBJ) 6757 * + INDEX(NAI,NBJ) 6758 IF (NAI .EQ. NBJ) THEN 6759 FACT2 = ZERO 6760 ELSE IF (NAI .GT. NBJ) THEN 6761 FACT2 = ONE 6762 ELSE 6763 FACT2 = XMONE 6764 ENDIF 6765 ELSE IF (ISYMAI .LT. ISYMBJ) THEN 6766 KOFF5 = IT2AM(ISYMAI,ISYMBJ) 6767 * + NT1AM(ISYMAI)*(NBJ-1) + NAI 6768 FACT2 = XMONE 6769 ELSE IF (ISYMBJ .LT. ISYMAI) THEN 6770 KOFF5 = IT2AM(ISYMAI,ISYMBJ) 6771 * + NT1AM(ISYMBJ)*(NAI-1) + NBJ 6772 FACT2 = ONE 6773 ENDIF 6774C 6775 OMEGA2M(KOFF5) = OMEGA2M(KOFF5) -FACT2*RES2M(KOFF4) 6776C 6777 ENDDO ! J 6778 ENDDO ! B 6779 ENDDO ! I 6780 ENDDO ! A 6781 ENDDO ! ISYMI 6782 ENDDO ! ISYMB 6783 ENDDO ! ISYMA 6784C 6785 CALL QEXIT('CC3_SORTMINUS') 6786C 6787 RETURN 6788 END 6789C /* Deck cc3_sortplus */ 6790 SUBROUTINE CC3_SORTPLUS(OMEGA2P,RES2P,ISYRES) 6791C 6792C K. Hald, April 2001. 6793C 6794 IMPLICIT NONE 6795C 6796#include "priunit.h" 6797#include "ccorb.h" 6798#include "ccsdsym.h" 6799C 6800 INTEGER ISYMA, ISYMB, ISYMAB, ISYMI, ISYMAI, ISYAIB, ISYMJ 6801 INTEGER ISYMBJ, ISYBIJ, NAI, NBJ, KOFF4, KOFF5, INDEX, ISYRES 6802C 6803#if defined (SYS_CRAY) 6804 REAL OMEGA2P(*), RES2P(*), ZERO 6805#else 6806 DOUBLE PRECISION OMEGA2P(*), RES2P(*), ZERO 6807#endif 6808C 6809 PARAMETER(ZERO = 0.0D0) 6810C 6811 INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 6812C 6813 CALL QENTER('CC3_SORTPLUS') 6814C 6815C-------------------------------------- 6816C Sort the (+) result. 6817C-------------------------------------- 6818C 6819 DO ISYMA = 1, NSYM 6820C 6821 DO ISYMB = 1, NSYM 6822C 6823 ISYMAB = MULD2H(ISYMA,ISYMB) 6824C 6825 DO ISYMI = 1, NSYM 6826C 6827 ISYMAI = MULD2H(ISYMA,ISYMI) 6828 ISYAIB = MULD2H(ISYMAI,ISYMB) 6829 ISYMJ = MULD2H(ISYAIB,ISYRES) 6830 ISYMBJ = MULD2H(ISYMB,ISYMJ) 6831 ISYBIJ = MULD2H(ISYMBJ,ISYMI) 6832C 6833 DO A = 1, NVIR(ISYMA) 6834 DO I = 1, NRHF(ISYMI) 6835 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + A 6836C 6837 DO B = 1, NVIR(ISYMB) 6838 DO J = 1, NRHF(ISYMJ) 6839C 6840 NBJ = IT1AM(ISYMB,ISYMJ) + NVIR(ISYMB)*(J - 1) + B 6841C 6842 KOFF4 = IT2SP(ISYBIJ,ISYMA) 6843 * + NCKI(ISYBIJ)*(A-1) 6844 * + ISAIK(ISYMBJ,ISYMI) 6845 * + NT1AM(ISYMBJ)*(I-1) + NBJ 6846C 6847 IF (ISYMAI.EQ.ISYMBJ) THEN 6848 KOFF5 = IT2AM(ISYMAI,ISYMBJ) 6849 * + INDEX(NAI,NBJ) 6850 IF (NAI .EQ. NBJ) THEN 6851 RES2P(KOFF4) = ZERO 6852 ENDIF 6853 ELSE IF (ISYMAI .LT. ISYMBJ) THEN 6854 KOFF5 = IT2AM(ISYMAI,ISYMBJ) 6855 * + NT1AM(ISYMAI)*(NBJ-1) + NAI 6856 ELSE IF (ISYMBJ .LT. ISYMAI) THEN 6857 KOFF5 = IT2AM(ISYMAI,ISYMBJ) 6858 * + NT1AM(ISYMBJ)*(NAI-1) + NBJ 6859 ENDIF 6860C 6861 OMEGA2P(KOFF5) = OMEGA2P(KOFF5) - RES2P(KOFF4) 6862C 6863 ENDDO ! J 6864 ENDDO ! B 6865 ENDDO ! I 6866 ENDDO ! A 6867 ENDDO ! ISYMI 6868 ENDDO ! ISYMB 6869 ENDDO ! ISYMA 6870C 6871 CALL QEXIT('CC3_SORTPLUS') 6872C 6873 RETURN 6874 END 6875