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_aden_cub */ 20 SUBROUTINE CC3_ADEN_CUB(LISTL,IDLSTL,LISTR,IDLSTR, 21 * XLAMDP0,XLAMDH0,FOCK0, 22 * DIJ,DAB,DIA,ISYDEN, 23 * WORK,LWORK, 24 * LUDELD,FNDELD,LUCKJD,FNCKJD,LUDKBC, 25 * FNDKBC,LUTOC,FNTOC,LU3VI,FN3VI, 26 * LUDKBC3,FNDKBC3,LU3FOPX,FN3FOPX, 27 * LU3FOP2X,FN3FOP2X) 28C 29 IMPLICIT NONE 30#include "priunit.h" 31#include "dummy.h" 32#include "ccsdsym.h" 33#include "ccorb.h" 34#include "ccsdinp.h" 35C 36 CHARACTER LISTL*3, LISTR*3 37 CHARACTER*(*) FNTOC, FN3VI, FNDKBC3, FN3FOPX, FN3FOP2X 38 CHARACTER*(*) FNDKBC,FNDELD,FNCKJD 39 CHARACTER*5 FN3FOP 40 CHARACTER*8 FN3VI2 41 CHARACTER*6 FN3FOP2 42 CHARACTER*10 MODEL 43C 44 PARAMETER (FN3FOP = 'PTFOP') 45 PARAMETER (FN3VI2 = 'CC3_VI12') 46 PARAMETER (FN3FOP2 = 'PTFOP2') 47C 48 INTEGER ISYDEN,IDLSTL,IDLSTR,LWORK 49 INTEGER LUTOC, LU3VI, LUDKBC3, LU3FOPX, LU3FOP2X 50 INTEGER LUDKBC,LUDELD,LUCKJD 51 INTEGER LU3FOP 52 INTEGER LU3VI2, LU3FOP2 53 INTEGER ISYM0,KT1AMP,KLAMP0,KLAMH0,KEND1,LWRK1,IOPT 54C 55#if defined (SYS_CRAY) 56 REAL XLAMDP0(*),XLAMDH0(*),FOCK0(*) 57 REAL DAB(*),DIJ(*),DIA(*) 58 REAL WORK(LWORK) 59#else 60 DOUBLE PRECISION XLAMDP0(*),XLAMDH0(*),FOCK0(*) 61 DOUBLE PRECISION DAB(*),DIJ(*),DIA(*) 62 DOUBLE PRECISION WORK(LWORK) 63#endif 64C 65 CALL QENTER('CC3DENCB') 66 67 ISYM0 = 1 68C 69 KT1AMP = 1 70 KLAMP0 = KT1AMP + NT1AM(ISYM0) 71 KLAMH0 = KLAMP0 + NLAMDT 72 KEND1 = KLAMH0 + NLAMDT 73 LWRK1 = LWORK - KEND1 74C 75 IF (LWRK1 .LT. 0) THEN 76 CALL QUIT('Insufficient space in CC3_ADEN_CUB (1)') 77 ENDIF 78C 79*---------------------------------------------------------------------* 80* initialize 0.th-order Lambda: 81*---------------------------------------------------------------------* 82 IOPT = 1 83 CALL CC_RDRSP('R0',0,ISYM0,IOPT,MODEL,WORK(KT1AMP),DUMMY) 84 85 CALL LAMMAT(WORK(KLAMP0),WORK(KLAMH0),WORK(KT1AMP), 86 & WORK(KEND1),LWRK1) 87C 88 89C 90 CALL DZERO(DAB,NMATAB(ISYDEN)) 91 CALL DZERO(DIJ,NMATIJ(ISYDEN)) 92 CALL DZERO(DIA,NT1AM(ISYDEN)) 93C 94C Open the file 95C 96 LU3FOP = -1 97 LU3VI2 = -1 98 LU3FOP2 = -1 99 CALL WOPEN2(LU3FOP,FN3FOP,64,0) 100 CALL WOPEN2(LU3VI2,FN3VI2,64,0) 101 CALL WOPEN2(LU3FOP2,FN3FOP2,64,0) 102C 103 CALL CC3_ADENVIR_CUB(DIJ,DAB,DIA,ISYDEN,LISTL,IDLSTL,LISTR,IDLSTR, 104 * LUTOC,FNTOC,LU3VI,FN3VI,LU3VI2,FN3VI2, 105 * LUDKBC3,FNDKBC3, 106 * LU3FOPX,FN3FOPX,LU3FOP2X,FN3FOP2X, 107 * LU3FOP,FN3FOP,LU3FOP2,FN3FOP2, 108 * LUCKJD,FNCKJD,LUDKBC,FNDKBC,LUDELD,FNDELD, 109 * WORK(KEND1),LWRK1) 110C 111 IF (IPRINT .GT. 55) THEN 112 WRITE(LUPRI,*)'DAB density after CC3_ADENVIR_CUB ' 113 CALL PRINT_MATAB(DAB,ISYDEN) 114 WRITE(LUPRI,*)'DIJ density after CC3_ADENVIR_CUB ' 115 CALL PRINT_MATIJ(DIJ,ISYDEN) 116 WRITE(LUPRI,*)'DIA density after CC3_ADENVIR_CUB ' 117 CALL PRINT_MATAI(DIA,ISYDEN) 118 END IF 119C 120 IF (LISTR(1:3).EQ.'R2 ') THEN 121 CALL CC3_ADENOCC_CUB(LISTL,IDLSTL,LISTR,IDLSTR, 122 * WORK(KLAMP0),WORK(KLAMH0),FOCK0, 123 * DIJ,DAB,DIA,ISYDEN, 124 * WORK(KEND1),LWRK1, 125 * LUDELD,FNDELD,LUCKJD,FNCKJD,LUDKBC, 126 * FNDKBC,LUTOC,FNTOC,LU3VI,FN3VI, 127 * LUDKBC3,FNDKBC3,LU3FOP,FN3FOP, 128 * LU3FOPX,FN3FOPX, 129 * LU3FOP2X,FN3FOP2X) 130C 131 IF (IPRINT .GT. 55) THEN 132 WRITE(LUPRI,*)'DAB density after CC3_ADENOCC_CUB ' 133 CALL PRINT_MATAB(DAB,ISYDEN) 134 WRITE(LUPRI,*)'DIJ density after CC3_ADENOCC_CUB ' 135 CALL PRINT_MATIJ(DIJ,ISYDEN) 136 WRITE(LUPRI,*)'DIA density after CC3_ADENOCC_CUB ' 137 CALL PRINT_MATAI(DIA,ISYDEN) 138 END IF 139C 140 END IF 141C 142 CALL WCLOSE2(LU3FOP,FN3FOP,'KEEP') 143 CALL WCLOSE2(LU3VI2,FN3VI2,'KEEP') 144 CALL WCLOSE2(LU3FOP2,FN3FOP2,'KEEP') 145C 146C---------- 147C End. 148C---------- 149C 150 CALL QEXIT('CC3DENCB') 151C 152 RETURN 153 END 154C /* Deck cc3_adenocc_cub */ 155 SUBROUTINE CC3_ADENOCC_CUB(LISTL,IDLSTL,LISTR,IDLSTR, 156 * XLAMDP0,XLAMDH0,FOCK0, 157 * DIJ,DAB,DIA,ISYDEN, 158 * WORK,LWORK, 159 * LUDELD,FNDELD,LUCKJD,FNCKJD,LUDKBC, 160 * FNDKBC,LUTOC,FNTOC,LU3VI,FN3VI, 161 * LUDKBC3,FNDKBC3,LU3FOP,FN3FOP, 162 * LU3FOPX,FN3FOPX, 163 * LU3FOP2X,FN3FOP2X) 164* 165************************************************************************* 166* 167* Calculate all those contractions for A density which should be 168* evaluated for 2 fixed occupied indeces: 169* 170* 1) Contributions to Dab density: 171* 172* Dab <-- 1/2 Wbar^LM(naed) theta^{d--e--b--}_{LMn} 173* + Wbar^LM(nead) theta^{d--b--e--}_{LMn} 174* + thetabar^{d-ae}_{LMn} theta^{dbe-}_{LMn-} 175* + thetabar^{d-ea}_{LMn} theta^{de-b}_{LMn-} 176* + thetabar^{aed-}_{LMn} theta^{be-d}_{LMn-} 177* 178* 2) Contributions to Dij density: 179* 180* Dij <-- 1/2 Wbar^LM(fjed) theta^{d--e--f--}_{LMi} 181* + thetabar^{d-ef}_{LMj} theta^{de-f-}_{LMi} 182* 183* 3) Contributions to Dai density: 184* 185* Dai <-- T2bar^{de}_{LM} ( theta^{d--e--a--}_{LMi} 186* - theta^{d--a--e--}_{LMi} ) 187* 188* 189* where single bar "-" denotes single transformation of an index 190* and double bar "--" denotes double transformation of an index. 191* 192************************************************************************* 193* 194* Before the contractions are carried out the following intermediates 195* must be evaluated in this routine ("eps" denotes orbital energy 196* difference and "ome_X" denotes a frequency associated with perturnation X): 197* 198* 199* 200* 1) Intermediates for the first-order triples multipliers tbarZ: 201* 202* 1a) Wbar^LM(naed) intermadiate known from quadratic response densities: 203* 204* 1b) thetabar^{d-ae}_{LMn} = 205* - (Z_dc tbar0^{cae}_{LMn}) / (eps^{dae}_{LMn}+omega_Z) 206* 207* 1c) thetabar^{d-ea}_{LMn} defined in the same way as 1b) 208* 209* 1d) thetabar^{aed-}_{LMn} defined in the same way as 1b), but requiring 210* the transformation of the last index in tbar0 211* 212*------------------------------------------------------------------------- 213* 214* 215* 2) Intermediates for the second-order triples amplitudes tXY: 216* 217* 2a) theta^{d--e--b--}_{LMn} = theta^{d--eb}_{LMn} + theta^{d-e-b}_{LMn} 218* 219* where 220* 221* 2aa) theta^{d--eb}_{LMn} = 222* PXY (X_dc theta^{c-eb}_{LMn}) / (eps^{deb}_{LMn} - ome_X - ome_Y) 223* 224* 2ab) theta^{d-e-b}_{LMn} = 225* PXY (X_dc theta^{ce-b}_{LMn} + X_ec theta^{d-cb}_{LMn}) 226* / (eps^{deb}_{LMn} - ome_X - ome_Y) 227* 228* where 229* 230* 2aaa) theta^{c-eb}_{LMn} = 231* (Y_ca t0^{aeb}_{LMn}) / (eps^{ceb}_{LMn} - ome_Y) 232* 233* and 234* 235* PXY is the permutation operator (permutes X and Y perturbations) 236* 237* 238* 2b) theta^{dbe-}_{LMn-} = 239* PXY ( X_ec w^{dbc}_{LMn-} + X^{Y}_ec t0^{dbc}_{LMn} 240* - X_jn theta^{dbe-}_{LMj} ) / (eps^{dbe}_{LMn} - ome_X - ome_Y) 241* 242* where 243* 244* 2ba) w^{dbc}_{lmn-} = Wdb(cnlm) - theta^{dbe-}_{lmn} 245* 246* 2bb) theta^{dbe-}_{LMj} is calculated like in 2aaa) 247* 248* 2bc) X^{Y} = [X,T1Y] 249* 250* 251* 2c) theta^{be-d}_{LMn-} = 252* PXY ( X_ec w^{bcd}_{LMn-} - X_jn theta^{be-d}_{LMj} ) 253* / (eps^{deb}_{LMn} - ome_X - ome_Y) 254* 255* where w^{bcd}_{LMn-} and theta^{be-d}_{LMj} have been defined 256* in 2ba) and 2bb) respectively. 257* 258* 259************************************************************************* 260* Written by Filip Pawlowski, Fall 2003, Aarhus 261************************************************************************* 262* 263 IMPLICIT NONE 264#include "ccl1rsp.h" 265#include "ccr1rsp.h" 266#include "ccorb.h" 267#include "ccsdsym.h" 268#include "dummy.h" 269#include "priunit.h" 270#include "iratdef.h" 271#include "ccinftap.h" 272#include "ccsdinp.h" 273#include "ccr2rsp.h" 274C 275 INTEGER ISYM0 276 PARAMETER(ISYM0 = 1) 277C 278 CHARACTER CDUMMY*1 279 PARAMETER (CDUMMY = ' ') 280C 281 CHARACTER*14 FN3SRTR, FNCKJDRZ, FNDELDRZ, FNDKBCRZ 282 PARAMETER(FN3SRTR = 'CCSDT_FBMAT1_Z',FNCKJDRZ = 'CCSDT_FBMAT2_Z', 283 * FNDELDRZ = 'CCSDT_FBMAT3_Z',FNDKBCRZ = 'CCSDT_FBMAT4_Z') 284 INTEGER LU3SRTR, LUCKJDRZ, LUDELDRZ, LUDKBCRZ 285C 286 CHARACTER*14 FNCKJDRU, FNDELDRU, FNDKBCRU 287 PARAMETER(FNCKJDRU = 'CCSDT_FBMAT2_U', 288 * FNDELDRU = 'CCSDT_FBMAT3_U',FNDKBCRU = 'CCSDT_FBMAT4_U') 289 INTEGER LUCKJDRU, LUDELDRU, LUDKBCRU 290C 291 INTEGER ISYDEN,IDLSTL,IDLSTR,IDLSTL0,LWORK 292 INTEGER LUTOC, LU3VI, LUDKBC3, LU3FOPX, LU3FOP2X, LU3FOP 293 INTEGER LUDKBC,LUDELD,LUCKJD 294 INTEGER ISYML0,ISYML1,ISYMRZ,ISINT1,ISINT2,ISINT1RZ,ISYFCKL1R 295 INTEGER ISYMK,ISYML,ISYMT3,ISYMKL,ISYT30KL 296 INTEGER IOPT,LENGTH 297 INTEGER KFOCKD,KFCKBA,KT2TP,KL1AM,KL2TP,KEND0,LWRK0 298 INTEGER KL1,KL2,KFOCKL1,KT1RZ,KT2RZ,KFOCKRZ,KEND1,LWRK1 299 INTEGER KXIAJB,KT3BOG1,KT3BOL1,KT3BOG2,KT3BOL2,KT3OG1,KT3OG2 300 INTEGER KLAMPL1R,KLAMHL1R,KT30KL 301 INTEGER KFOCKL1RCK,KT3VIJG1 302 INTEGER ISYMT3B,ISYT3B0KL,ISYW3BXKL 303 INTEGER KXGADCK,KXLADCK 304 INTEGER KT3B0KL,KW3BXKL,ISYMW3BX 305 INTEGER KT3BOG2X,KT3BOL2X,KXGADCKX,KXLADCKX 306 INTEGER ISYMTETAZ,ISTETAZKL 307 INTEGER KTETAXKL 308 INTEGER IDLSTL1R,ISYML1R 309 INTEGER ISINT2L1R,KT1L1R 310C 311 INTEGER IDLSTZU,IDLSTRZ,IDLSTRU,ISYMRU 312 INTEGER KFOCKRU,ISYMZU,ISYMTETAU,ISYMTETAZU,ISTETAUKL,ISTETAZUKL 313 INTEGER MAXX1 314 INTEGER K1,K1X,KABCI 315 INTEGER KFCKZUV,KFCKUZV,KLAMDPZ,KLAMDHTMP,KLAMDPU 316C 317 INTEGER KGBCDK 318 INTEGER KT1RU,KT2RU 319C 320 INTEGER ISINT2RZ,ISINT1RU,ISINT2RU,KT3OG2Z 321 INTEGER KT3OG2U,KGBCDKZ,KGBCDKU 322 INTEGER KEND2,LWRK2 323 INTEGER KEND3,LWRK3 324C 325 INTEGER IR1TAMP 326C 327 CHARACTER LISTL*3, LISTR*3, LISTL0*3, LISTL1R*3 328 CHARACTER*(*) FNTOC, FN3VI, FNDKBC3, FN3FOPX, FN3FOP2X, FN3FOP 329 CHARACTER*(*) FNDKBC,FNDELD,FNCKJD 330 CHARACTER LABELL1*8,LABELRZ*8,LABELRU*8 331C 332 CHARACTER LISTRZ*3,LISTRU*3 333C 334 LOGICAL LOCDBG,LORXL1 335 PARAMETER (LOCDBG = .FALSE.) 336 LOGICAL LORXRZ,LORXRU 337C 338 integer kx3am 339C 340#if defined (SYS_CRAY) 341 REAL XLAMDP0(*),XLAMDH0(*),FOCK0(*) 342 REAL DAB(*),DIJ(*),DIA(*) 343 REAL WORK(LWORK) 344 REAL FREQL1,FREQRZ,FREQL1R,FREQRU,FREQZU 345 REAL DDOT,XNORMVAL,ONE 346#else 347 DOUBLE PRECISION XLAMDP0(*),XLAMDH0(*),FOCK0(*) 348 DOUBLE PRECISION DAB(*),DIJ(*),DIA(*) 349 DOUBLE PRECISION WORK(LWORK) 350 DOUBLE PRECISION FREQL1,FREQRZ,FREQL1R,FREQRU,FREQZU 351 DOUBLE PRECISION DDOT,XNORMVAL,ONE 352#endif 353C 354 PARAMETER (ONE = 1.0D0) 355C 356 CALL QENTER('CC3AOCB') 357C 358C-------------------------------- 359C Open temporary files 360C-------------------------------- 361C 362 LU3SRTR = -1 363 LUCKJDRZ = -1 364 LUDELDRZ = -1 365 LUDKBCRZ = -1 366C 367 CALL WOPEN2(LU3SRTR,FN3SRTR,64,0) 368 CALL WOPEN2(LUCKJDRZ,FNCKJDRZ,64,0) 369 CALL WOPEN2(LUDELDRZ,FNDELDRZ,64,0) 370 CALL WOPEN2(LUDKBCRZ,FNDKBCRZ,64,0) 371C 372 LUCKJDRU = -1 373 LUDELDRU = -1 374 LUDKBCRU = -1 375C 376 CALL WOPEN2(LUCKJDRU,FNCKJDRU,64,0) 377 CALL WOPEN2(LUDELDRU,FNDELDRU,64,0) 378 CALL WOPEN2(LUDKBCRU,FNDKBCRU,64,0) 379C 380C------------------------------------------------------------ 381C some initializations: 382C------------------------------------------------------------ 383C 384 ISINT1 = 1 385 ISINT2 = 1 386C 387 LISTL0 = 'L0 ' 388 IDLSTL0 = 0 389 ISYML0 = ISYM0 390C 391 ISYMT3 = ISYM0 392 ISYMT3B = ISYM0 393 394 IF (LISTL(1:3).EQ.'L1 ') THEN 395 ! get symmetry, frequency and integral label for left list 396 ! from common blocks defined in ccl1rsp.h 397 ISYML1 = ISYLRZ(IDLSTL) 398 FREQL1 = FRQLRZ(IDLSTL) 399 LABELL1 = LRZLBL(IDLSTL) 400 LORXL1 = LORXLRZ(IDLSTL) 401 402 IF (LORXL1) CALL QUIT('NO ORBITAL RELAX. IN CC3_ADENOCC_CUB') 403 404 LISTL1R = 'R1 ' 405 IDLSTL1R = IR1TAMP(LABELL1,LORXL1,FREQL1,ISYML1) 406 ! get symmetry and frequency from common blocks 407 ! defined in ccl1rsp.h 408 ISYML1R = ISYLRT(IDLSTL1R) 409 FREQL1R = FRQLRT(IDLSTL1R) 410C 411 IF (FREQL1R .NE. FREQL1) THEN 412 WRITE(LUPRI,*)'FREQL1R: ', FREQL1R 413 WRITE(LUPRI,*)'FREQL1: ', FREQL1 414 CALL QUIT('Frequency mismatch in CC3_ADENOCC_CUB') 415 END IF 416 417 ELSE 418 CALL QUIT('Unknown left list in CC3_ADENOCC_CUB') 419 END IF 420 421 IF (LISTR(1:3).EQ.'R2 ') THEN 422 IDLSTZU = IDLSTR 423 ! get symmetry, frequency and integral label for right list 424 ! from common blocks defined in ccr1rsp.h 425 LISTRZ = 'R1 ' 426 LABELRZ = LBLR2T(IDLSTZU,1) 427 ISYMRZ = ISYR2T(IDLSTZU,1) 428 FREQRZ = FRQR2T(IDLSTZU,1) 429 LORXRZ = LORXR2T(IDLSTZU,1) 430 IDLSTRZ = IR1TAMP(LABELRZ,LORXRZ,FREQRZ,ISYMRZ) 431 432 LISTRU = 'R1 ' 433 LABELRU = LBLR2T(IDLSTZU,2) 434 ISYMRU = ISYR2T(IDLSTZU,2) 435 FREQRU = FRQR2T(IDLSTZU,2) 436 LORXRU = LORXR2T(IDLSTZU,2) 437 IDLSTRU = IR1TAMP(LABELRU,LORXRU,FREQRU,ISYMRU) 438 439C 440 IF (LORXRZ.OR.LORXRU) THEN 441 CALL QUIT('Orbital relaxation not allowed in CC3_ADENVIR_CUB') 442 END IF 443C 444 ELSE 445 WRITE(LUPRI,*)'LISTR = ',LISTR(1:3) 446 WRITE(LUPRI,*)'CC3_ADENVIR_CUB is designed for LISTR = R2' 447 CALL QUIT('Unknown right list in CC3_ADENOCC_CUB') 448 END IF 449 450 FREQZU = FREQRZ + FREQRU 451 ISYMZU = MULD2H(ISYMRZ,ISYMRU) 452 453C 454C--------------------------------------------------------------------- 455C initial allocations, orbital energy, fock matrix and T2 and L2 : 456C--------------------------------------------------------------------- 457C 458 KFOCKD = 1 459 KFCKBA = KFOCKD + NORBTS 460 KT2TP = KFCKBA + NT1AMX 461 KL1AM = KT2TP + NT2SQ(ISYM0) 462 KL2TP = KL1AM + NT1AM(ISYML0) 463 KEND0 = KL2TP + NT2SQ(ISYML0) 464 LWRK0 = LWORK - KEND0 465C 466 KL1 = KEND0 467 KL2 = KL1 + NT1AM(ISYML1) 468 KFOCKL1 = KL2 + NT2SQ(ISYML1) 469 KT1RZ = KFOCKL1 + N2BST(ISYML1) 470 KT2RZ = KT1RZ + NT1AM(ISYMRZ) 471 KFOCKRZ = KT2RZ + NT2SQ(ISYMRZ) 472 KEND1 = KFOCKRZ + N2BST(ISYMRZ) 473 LWRK1 = LWORK - KEND1 474C 475 KT1RU = KEND1 476 KT2RU = KT1RU + NT1AM(ISYMRU) 477 KEND1 = KT2RU + NT2SQ(ISYMRU) 478 LWRK1 = LWORK - KEND1 479C 480 KFOCKRU = KEND1 481 KEND1 = KFOCKRU + N2BST(ISYMRU) 482 LWRK1 = LWORK - KEND1 483C 484 KFCKZUV = KEND1 + N2BST(ISYMZU) 485 KFCKUZV = KFCKZUV + N2BST(ISYMZU) 486 KEND1 = KFCKUZV + N2BST(ISYMZU) 487 LWRK1 = LWORK - KEND1 488C 489 KLAMDPZ = KEND1 490 KLAMDPU = KLAMDPZ + NLAMDT 491 KLAMDHTMP = KLAMDPU + NLAMDT 492 KEND1 = KLAMDHTMP + NLAMDT 493 LWRK1 = LWORK - KEND1 494C 495 IF (LWRK1 .LT. 0) THEN 496 CALL QUIT('Insufficient space in CC3_ADENOCC_CUB (1)') 497 ENDIF 498C 499C------------------------------------- 500C Read T2 amplitudes 501C------------------------------------- 502C 503 IOPT = 2 504 CALL GET_T1_T2(IOPT,.FALSE.,DUMMY,WORK(KT2TP),'R0',0,ISYM0, 505 * WORK(KEND1),LWRK1) 506C 507 IF (LOCDBG) WRITE(LUPRI,*) 'Norm of T2TP ', 508 * DDOT(NT2SQ(ISYM0),WORK(KT2TP),1,WORK(KT2TP),1) 509C 510C------------------------------------- 511C Read L1 and L2 amplitudes 512C------------------------------------- 513C 514 IOPT = 3 515 CALL GET_T1_T2(IOPT,.FALSE.,WORK(KL1AM),WORK(KL2TP),LISTL0, 516 * IDLSTL0,ISYML0,WORK(KEND1),LWRK1) 517C 518C WRITE(LUPRI,*) 'Norm of L2TP (after readeing)', 519C * DDOT(NT2SQ(ISYML0),WORK(KL2TP),1,WORK(KL2TP),1) 520 521C 522C--------------------------------------------------------------- 523C Read canonical orbital energies and delete frozen orbitals 524C in Fock diagonal, if required 525C--------------------------------------------------------------- 526C 527 CALL GET_ORBEN(WORK(KFOCKD),WORK(KEND1),LWRK1) 528C 529C-------------------------------------------- 530C Sort the Fock matrix to get F(ck) block 531C-------------------------------------------- 532C 533 CALL SORT_FOCKCK(WORK(KFCKBA),FOCK0,ISYM0) 534C 535C--------------------------------------------------------------------- 536C Read information for L1 list 537C--------------------------------------------------------------------- 538C 539 IF (LISTL(1:3).EQ.'L1 ') THEN 540C 541C--------------------------------------------------------------------- 542C Read the matrix the property integrals and trasform it to lambda 543C basis (unsorted - need in WBX_JK_ETA) 544C--------------------------------------------------------------------- 545C 546 CALL GET_FOCKX(WORK(KFOCKL1),LABELL1,IDLSTL,ISYML1,XLAMDP0, 547 * ISYM0,XLAMDH0,ISYM0,WORK(KEND1),LWRK1) 548C 549C------------------------------------- 550C Read L1 and L2 multipliers 551C------------------------------------- 552C 553 IOPT = 3 554 CALL GET_T1_T2(IOPT,.FALSE.,WORK(KL1),WORK(KL2),LISTL, 555 * IDLSTL,ISYML1,WORK(KEND1),LWRK1) 556 END IF 557C 558C--------------------------------------------------------------------- 559C Read the matrix the property integrals and trasform it to lambda 560C basis (Z operator) 561C--------------------------------------------------------------------- 562C 563 CALL GET_FOCKX(WORK(KFOCKRZ),LABELRZ,IDLSTRZ,ISYMRZ,XLAMDP0, 564 * ISYM0,XLAMDH0,ISYM0,WORK(KEND1),LWRK1) 565C 566C--------------------------------------------------------------------- 567C Read the matrix the property integrals and trasform it to lambda 568C basis (U operator) 569C--------------------------------------------------------------------- 570C 571 CALL GET_FOCKX(WORK(KFOCKRU),LABELRU,IDLSTRU,ISYMRU,XLAMDP0, 572 * ISYM0,XLAMDH0,ISYM0,WORK(KEND1),LWRK1) 573C 574C------------------------------------------ 575C Calculate the [U,T1^Z] matrix 576C Recall that we only need vir-vir block. 577C------------------------------------------ 578C 579 CALL GET_LAMBDAX(WORK(KLAMDPZ),WORK(KLAMDHTMP),LISTRZ,IDLSTRZ, 580 * ISYMRZ,XLAMDP0,XLAMDH0,WORK(KEND1), 581 * LWRK1) 582 ! get vir-vir block U_(c-,d) 583 CALL GET_FOCKX(WORK(KFCKUZV),LABELRU,IDLSTRU,ISYMRU,WORK(KLAMDPZ), 584 * ISYMRZ,XLAMDH0,ISYM0,WORK(KEND1),LWRK1) 585C 586C------------------------------------------ 587C Calculate the [Z,T1^U] matrix 588C Recall that we only need the vir-vir block. 589C------------------------------------------ 590C 591 CALL GET_LAMBDAX(WORK(KLAMDPU),WORK(KLAMDHTMP),LISTRU,IDLSTRU, 592 * ISYMRU,XLAMDP0,XLAMDH0,WORK(KEND1), 593 * LWRK1) 594 ! get vir-vir block Z_(c-,d) 595 CALL GET_FOCKX(WORK(KFCKZUV),LABELRZ,IDLSTRZ,ISYMRZ,WORK(KLAMDPU), 596 * ISYMRU,XLAMDH0,ISYM0,WORK(KEND1),LWRK1) 597C 598C------------------------------------- 599C Read R1 and R2 amplitudes 600C------------------------------------- 601C 602 IOPT = 3 603 CALL GET_T1_T2(IOPT,.TRUE.,WORK(KT1RZ),WORK(KT2RZ),LISTRZ, 604 * IDLSTRZ,ISYMRZ,WORK(KEND1),LWRK1) 605C 606C------------------------------------- 607C Read R1 and R2 amplitudes 608C------------------------------------- 609C 610 IOPT = 3 611 CALL GET_T1_T2(IOPT,.TRUE.,WORK(KT1RU),WORK(KT2RU),LISTRU, 612 * IDLSTRU,ISYMRU,WORK(KEND1),LWRK1) 613C 614C 615C---------------------------------------- 616C Integrals [H,T1Z] where Z is LISTRZ 617C---------------------------------------- 618C 619 ISINT1RZ = MULD2H(ISINT1,ISYMRZ) 620 ISINT2RZ = MULD2H(ISINT2,ISYMRZ) 621C 622 CALL CC3_BARINT(WORK(KT1RZ),ISYMRZ,XLAMDP0, 623 * XLAMDH0,WORK(KEND1),LWRK1, 624 * LU3SRTR,FN3SRTR,LUCKJDRZ,FNCKJDRZ) 625C 626 CALL CC3_SORT1(WORK(KEND1),LWRK1,2,ISINT1RZ,LU3SRTR,FN3SRTR, 627 * LUDELDRZ,FNDELDRZ,IDUMMY,CDUMMY,IDUMMY,CDUMMY, 628 * IDUMMY,CDUMMY) 629C 630 CALL CC3_SINT(XLAMDH0,WORK(KEND1),LWRK1,ISINT1RZ, 631 * LUDELDRZ,FNDELDRZ,LUDKBCRZ,FNDKBCRZ) 632C 633C---------------------------------------- 634C Integrals [H,T1U] where U is LISTRU 635C---------------------------------------- 636C 637 ISINT1RU = MULD2H(ISINT1,ISYMRU) 638 ISINT2RU = MULD2H(ISINT2,ISYMRU) 639C 640 CALL CC3_BARINT(WORK(KT1RU),ISYMRU,XLAMDP0, 641 * XLAMDH0,WORK(KEND1),LWRK1, 642 * LU3SRTR,FN3SRTR,LUCKJDRU,FNCKJDRU) 643C 644 CALL CC3_SORT1(WORK(KEND1),LWRK1,2,ISINT1RU,LU3SRTR,FN3SRTR, 645 * LUDELDRU,FNDELDRU,IDUMMY,CDUMMY,IDUMMY,CDUMMY, 646 * IDUMMY,CDUMMY) 647C 648 CALL CC3_SINT(XLAMDH0,WORK(KEND1),LWRK1,ISINT1RU, 649 * LUDELDRU,FNDELDRU,LUDKBCRU,FNDKBCRU) 650 651C 652C--------------------------------------------------- 653C If we want to sum the T3 amplitudes (for debugging) 654C--------------------------------------------------- 655C 656 if (.false.) then 657 kx3am = kend1 658 kend1 = kx3am + nrhft*nrhft*nrhft*nvirt*nvirt*nvirt 659 call dzero(work(kx3am),nrhft*nrhft*nrhft*nvirt*nvirt*nvirt) 660 lwrk0 = lwork - kend1 661 if (lwrk0 .lt. 0) then 662 write(lupri,*) 'Memory available : ',lwork 663 write(lupri,*) 'Memory needed : ',kend1 664 call quit('Insufficient space(kx3am) in CC3_ADENOCC_CUB (2)') 665 END IF 666 endif 667C 668C----------------------------- 669C Memory allocation. 670C----------------------------- 671C 672C isint1, isint2 - symmetry of integrals in standard H, transformed 673C with LambdaH_0 674C ISINT1RZ - symmetry of integrals in standard H, transformed 675C with LambdaH_R1 676 677 ISINT1 = 1 678 ISINT2 = 1 679 ISINT1RZ = MULD2H(ISINT1,ISYMRZ) 680 ISINT2L1R = MULD2H(ISYML1R,ISINT2) 681 ISYFCKL1R = MULD2H(ISYMOP,ISYML1R) 682 683 KXIAJB = KEND1 684 KEND1 = KXIAJB + NT2AM(ISYM0) 685C 686 MAXX1 = MAX(NTRAOC(ISINT2RZ),NTRAOC(ISINT2RU)) 687 688 KT3BOG1 = KEND1 689 KT3BOL1 = KT3BOG1 + MAX(NTRAOC(ISINT2L1R),NTRAOC(ISYM0)) 690 KT3BOG2 = KT3BOL1 + MAX(NTRAOC(ISINT2L1R),NTRAOC(ISYM0)) 691 KT3BOL2 = KT3BOG2 + NTRAOC(ISYM0) 692 KT3OG1 = KT3BOL2 + NTRAOC(ISYM0) 693 KT3OG2 = KT3OG1 + MAX(NTRAOC(ISINT2),MAXX1) 694 KLAMPL1R = KT3OG2 + NTRAOC(ISINT2) 695 KLAMHL1R = KLAMPL1R + NLAMDT 696 KEND1 = KLAMHL1R + NLAMDT 697C 698 KT3OG2Z = KEND1 699 KEND1 = KT3OG2Z + NTRAOC(ISINT2RZ) 700 LWRK1 = LWORK - KEND1 701C 702 KT3OG2U = KEND1 703 KEND1 = KT3OG2U + NTRAOC(ISINT2RU) 704 LWRK1 = LWORK - KEND1 705C 706 KFOCKL1RCK = KEND1 707 KT3VIJG1 = KFOCKL1RCK + NT1AM(ISYFCKL1R) 708 KEND1 = KT3VIJG1 + NMAABCI(ISYM0) 709 LWRK1 = LWORK - KEND1 710C 711 KT3BOG2X = KEND1 712 KT3BOL2X = KT3BOG2X + NTRAOC(ISINT2L1R) 713 KEND1 = KT3BOL2X + NTRAOC(ISINT2L1R) 714C 715 KXGADCK = KEND1 716 KXLADCK = KXGADCK + NMAABCI(ISYM0) 717 KEND1 = KXLADCK + NMAABCI(ISYM0) 718 LWRK1 = LWORK - KEND1 719C 720 KXGADCKX = KEND1 721 KXLADCKX = KXGADCKX + NMAABCI(ISINT2L1R) 722 KEND1 = KXLADCKX + NMAABCI(ISINT2L1R) 723 LWRK1 = LWORK - KEND1 724C 725 KGBCDK = KEND1 726 KEND1 = KGBCDK + NMAABCI(ISYM0) 727 LWRK1 = LWORK - KEND1 728C 729 KGBCDKZ = KEND1 730 KEND1 = KGBCDKZ + NMAABCI(ISYMRZ) 731 LWRK1 = LWORK - KEND1 732C 733 KGBCDKU = KEND1 734 KEND1 = KGBCDKU + NMAABCI(ISYMRU) 735 LWRK1 = LWORK - KEND1 736C 737 KT1L1R = KEND1 738 KEND1 = KT1L1R + NT1AM(ISYML1R) 739 LWRK1 = LWORK - KEND1 740C 741 IF (LWRK1 .LT. 0) THEN 742 WRITE(LUPRI,*) 'Memory available : ',LWORK 743 WRITE(LUPRI,*) 'Memory needed : ',KEND1 744 CALL QUIT('Insufficient space in CC3_ADENOCC_CUB (3)') 745 END IF 746C 747C------------------------ 748C Construct L(ia,jb). 749C------------------------ 750C 751 LENGTH = IRAT*NT2AM(ISYM0) 752 753 REWIND(LUIAJB) 754 CALL READI(LUIAJB,LENGTH,WORK(KXIAJB)) 755 756 CALL CCSD_TCMEPK(WORK(KXIAJB),1.0D0,ISYM0,1) 757C 758C-------------------------------------------------------------- 759C Prepare to construct the integrals (occupied and virtual) 760C-------------------------------------------------------------- 761C 762C 763C---------------------------------------------------------- 764C Get Lambda for right list depended on left LISTL list 765C---------------------------------------------------------- 766C 767 CALL GET_LAMBDAX(WORK(KLAMPL1R),WORK(KLAMHL1R),LISTL1R, 768 * IDLSTL1R, 769 * ISYML1R,XLAMDP0,XLAMDH0,WORK(KEND1),LWRK1) 770C 771C------------------------------------------------------------------ 772C Calculate the F^L1R matrix (kc elements evaluated and stored 773C as ck) 774C------------------------------------------------------------------ 775C 776 IOPT = 1 777 CALL GET_T1_T2(IOPT,.FALSE.,WORK(KT1L1R),DUMMY,LISTL1R, 778 * IDLSTL1R, 779 * ISYML1R,WORK(KEND1),LWRK1) 780 CALL CC3LR_MFOCK(WORK(KFOCKL1RCK),WORK(KT1L1R),WORK(KXIAJB), 781 * ISYFCKL1R) 782C 783C----------------------------------------------------------------- 784C Construct occupied integrals which are required to calculate 785C t3bar_0 multipliers 786C----------------------------------------------------------------- 787C 788 CALL INTOCC_T3BAR0(LUTOC,FNTOC,XLAMDH0,ISYM0,WORK(KT3BOG1), 789 * WORK(KT3BOL1),WORK(KT3BOG2),WORK(KT3BOL2), 790 * WORK(KEND1),LWRK1) 791 792C 793C----------------------------------------------------------------- 794C Construct occupied integrals which are required to calculate 795C t3_x amplitudes 796C----------------------------------------------------------------- 797C 798 CALL INTVIR_T3X_JK(WORK(KGBCDK),ISYM0,LUDKBC,FNDKBC, 799 * WORK(KEND1),LWRK1) 800C 801 CALL INTVIR_T3X_JK(WORK(KGBCDKZ),ISYMRZ,LUDKBCRZ,FNDKBCRZ, 802 * WORK(KEND1),LWRK1) 803C 804 CALL INTVIR_T3X_JK(WORK(KGBCDKU),ISYMRU,LUDKBCRU,FNDKBCRU, 805 * WORK(KEND1),LWRK1) 806C 807C----------------------------------------------------------------- 808C Construct occupied integrals which are required to calculate 809C t3_0 amplitudes 810C----------------------------------------------------------------- 811C 812 CALL INTOCC_T30(LUCKJD,FNCKJD,XLAMDP0,ISINT2,WORK(KT3OG1), 813 * WORK(KT3OG2),WORK(KEND1),LWRK1) 814C 815C----------------------------------------------------------------- 816C Construct occupied integrals which are required to calculate 817C t3_x amplitudes 818C----------------------------------------------------------------- 819C 820 CALL INTOCC_T30(LUCKJDRZ,FNCKJDRZ,XLAMDP0,ISINT2RZ,WORK(KT3OG1), 821 * WORK(KT3OG2Z),WORK(KEND1),LWRK1) 822C 823 CALL INTOCC_T30(LUCKJDRU,FNCKJDRU,XLAMDP0,ISINT2RU,WORK(KT3OG1), 824 * WORK(KT3OG2U),WORK(KEND1),LWRK1) 825C 826C----------------------------------------------------------------- 827C Construct occupied integrals which are required to calculate 828C t3bar_Y multipliers 829C----------------------------------------------------------------- 830C 831 CALL INTOCC_T3BARX_JK(LUTOC,FNTOC,ISYMOP, 832 * WORK(KLAMHL1R),ISYML1R,ISINT2L1R, 833 * DUMMY,DUMMY,.TRUE., 834 * WORK(KT3BOG2X),WORK(KT3BOL2X), 835 * WORK(KEND1),LWRK1) 836C 837C---------------------------------------------- 838C Get virtual integrals for t30 amplitudes 839C KT3VIJG1 : (ck|da) sorted as I(ad|ck) 840C---------------------------------------------- 841C 842 CALL INTVIR_T30_IJ(WORK(KT3VIJG1),ISYM0,XLAMDH0,LUDELD,FNDELD, 843 * WORK(KEND1),LWRK1) 844C 845C---------------------------------------------- 846C Get virtual integrals for t3b0 multipliers 847C KXGADCK g(kcad) = (kc ! ad) sorted as I(adck) 848C KXLADCK L(kcad) sorted as I(adck) 849C---------------------------------------------- 850C 851 CALL INTVIR_T3B0_JK(2,WORK(KXGADCK),WORK(KXLADCK),ISYM0,XLAMDP0, 852 * ISYM0, 853 * LU3VI,FN3VI,LU3FOP,FN3FOP, 854 * WORK(KEND1),LWRK1) 855C 856C---------------------------------------------- 857C Get virtual integrals for t3b0 multipliers 858C---------------------------------------------- 859C 860 CALL INTVIR_T3BX_JK(WORK(KXGADCKX),WORK(KXLADCKX),ISINT2L1R, 861 * WORK(KLAMPL1R),ISYML1R, 862 * LU3VI,FN3VI,LU3FOP,FN3FOP, 863 * WORK(KEND1),LWRK1) 864C 865C---------------------------- 866C Loop over K 867C---------------------------- 868C 869 ISYMW3BX = MULD2H(ISYM0,ISYML1) 870 ISYMTETAZ = MULD2H(ISYM0,ISYMRZ) 871 ISYMTETAU = MULD2H(ISYM0,ISYMRU) 872 ISYMTETAZU = MULD2H(ISYM0,ISYMZU) 873 DO ISYMK = 1,NSYM 874 875 DO K = 1,NRHF(ISYMK) 876C 877 DO ISYML = 1,NSYM 878C 879 ISYMKL = MULD2H(ISYMK,ISYML) 880 ISYT30KL = MULD2H(ISYMKL,ISYMT3) 881 ISYT3B0KL = MULD2H(ISYMKL,ISYMT3B) 882 ISYW3BXKL = MULD2H(ISYMKL,ISYMW3BX) 883 ISTETAZKL = MULD2H(ISYMKL,ISYMTETAZ) 884 ISTETAUKL = MULD2H(ISYMKL,ISYMTETAU) 885 ISTETAZUKL = MULD2H(ISYMKL,ISYMTETAZU) 886C 887 MAXX1 = MAX(NMAABCI(ISTETAZKL),NMAABCI(ISTETAUKL)) 888C 889 KT30KL = KEND1 890 KT3B0KL = KT30KL + NMAABCI(ISYT30KL) 891 KW3BXKL = KT3B0KL + MAX( NMAABCI(ISYT3B0KL),MAXX1) 892 KTETAXKL = KW3BXKL 893 * + MAX(NMAABCI(ISYW3BXKL),NMAABCI(ISTETAZKL)) 894 KEND2 = KTETAXKL + MAX(MAXX1,NMAABCI(ISTETAZUKL)) 895 LWRK2 = LWORK - KEND2 896C 897 IF (LWRK2 .LT. 0) THEN 898 WRITE(LUPRI,*) 'Memory available : ',LWORK 899 WRITE(LUPRI,*) 'Memory needed : ',KEND2 900 CALL QUIT('Insufficient space in CC3_ADENOCC_CUB (4)') 901 END IF 902C 903 DO L = 1,NRHF(ISYML) 904C 905C 906C------------------------------------------- 907C Get T30^KL amplitudes 908C------------------------------------------- 909C 910 CALL DZERO(WORK(KT30KL),NMAABCI(ISYT30KL)) 911C 912 CALL GET_T30_IJ_O(WORK(KT30KL),ISYT30KL,WORK(KT2TP), 913 * ISYM0, 914 * WORK(KT3OG2),ISYM0,ISYML,L,ISYMK,K, 915 * WORK(KEND2),LWRK2) 916C 917 CALL GET_T30_IJ_V(WORK(KT30KL),ISYT30KL,WORK(KT2TP), 918 * ISYM0,WORK(KT3VIJG1), 919 * ISYM0,ISYML,L,ISYMK,K, 920 * WORK(KEND2),LWRK2) 921 922 !Divide by orbital energy difference and remove 923 !forbidden elements 924 CALL T3JK_DIA(WORK(KT30KL),ISYT30KL,ISYML,L,ISYMK,K, 925 * WORK(KFOCKD)) 926 CALL T3_FORBIDDEN_JK(WORK(KT30KL),ISYMT3,ISYML,L, 927 * ISYMK,K) 928C 929c call sum_pt3_jk(work(kt30kl),isyml,l,isymk,k,isyt30kl, 930c * work(kx3am),1) 931C 932 IF (IPRINT .GT. 55) THEN 933 WRITE(LUPRI,*)'ISYML,L,ISYMK,K ', ISYML,L,ISYMK,K 934 XNORMVAL = DDOT(NMAABCI(ISYT30KL),WORK(KT30KL),1, 935 * WORK(KT30KL),1) 936 WRITE(LUPRI,*)'NORM OF KT30KL IN CC3_ADENOCC_CUB ', 937 * XNORMVAL 938 END IF 939C 940C--------------------------------------------------------------------------- 941C Calculate KT3B0KL(d- e- b-)_(LMn) = KT3B0KL(d- e- b)_(LMn) 942C + KT30KL(deb)_(LMn) * FOCKZ 943C--------------------------------------------------------------------------- 944C 945 !KT3B0KL is used here first time 946 CALL DZERO(WORK(KT3B0KL),NMAABCI(ISTETAZKL)) 947 948 IOPT = 2 949 CALL TETAX_JK_BC_CUB(.TRUE.,.FALSE., 950 * IOPT,WORK(KT30KL),ISYT30KL, 951 * WORK(KFOCKRZ),ISYMRZ, 952 * WORK(KT3B0KL),ISTETAZKL, 953 * WORK(KEND2),LWRK2) 954 955C 956C KT3B0KL(d- e- b-)_(LMn) = KT3B0KL(d- e- b)_(LMn) 957C + KT30KL(deb)_(LMn) * FOCKZ 958C 959 CALL TETAX_JK_A(WORK(KT30KL),ISYT30KL,WORK(KFOCKRZ), 960 * ISYMRZ,WORK(KT3B0KL),ISTETAZKL, 961 * WORK(KEND2),LWRK2) 962 963C 964 CALL W3JK_DIA(WORK(KT3B0KL),ISTETAZKL,ISYML,L,ISYMK,K, 965 * WORK(KFOCKD),FREQRZ) 966C 967 CALL T3_FORBIDDEN_JK(WORK(KT3B0KL),ISYMTETAZ,ISYML,L, 968 * ISYMK,K) 969 970C 971C ------------------------------------------ 972C KTETAXKL = KT3B0KL(d- e- b-)_(LMn) * FOCKU 973C ------------------------------------------ 974C 975 976 CALL DZERO(WORK(KTETAXKL),NMAABCI(ISTETAZUKL)) 977C 978 IOPT = 2 979 CALL TETAX_JK_BC_CUB(.TRUE.,.FALSE., 980 * IOPT,WORK(KT3B0KL),ISTETAZKL, 981 * WORK(KFOCKRU),ISYMRU, 982 * WORK(KTETAXKL),ISTETAZUKL, 983 * WORK(KEND2),LWRK2) 984C 985 CALL TETAX_JK_A(WORK(KT3B0KL),ISTETAZKL,WORK(KFOCKRU), 986 * ISYMRU,WORK(KTETAXKL),ISTETAZUKL, 987 * WORK(KEND2),LWRK2) 988C 989C 990C INCLUDE P(ZU) permutation 991C 992C 993 994C 995C ------------------------------------------ 996C KT3B0KL(d- e- b)_(LMn) = KT30KL(deb)_(LMn) * FOCKU 997C ------------------------------------------ 998C 999 !KT3B0KL is reused here 1000 CALL DZERO(WORK(KT3B0KL),NMAABCI(ISTETAUKL)) 1001 1002 IOPT = 2 1003 CALL TETAX_JK_BC_CUB(.TRUE.,.FALSE., 1004 * IOPT,WORK(KT30KL),ISYT30KL, 1005 * WORK(KFOCKRU),ISYMRU, 1006 * WORK(KT3B0KL),ISTETAUKL, 1007 * WORK(KEND2),LWRK2) 1008 1009C 1010C ------------------------------------------ 1011C KT3B0KL(d- e- b-)_(LMn) = KT3B0KL(d- e- b)_(LMn) 1012C + KT30KL(deb)_(LMn) * FOCKU 1013C ------------------------------------------ 1014C 1015 CALL TETAX_JK_A(WORK(KT30KL),ISYT30KL,WORK(KFOCKRU), 1016 * ISYMRU,WORK(KT3B0KL),ISTETAUKL, 1017 * WORK(KEND2),LWRK2) 1018 1019C 1020 CALL W3JK_DIA(WORK(KT3B0KL),ISTETAUKL,ISYML,L,ISYMK,K, 1021 * WORK(KFOCKD),FREQRU) 1022C 1023 CALL T3_FORBIDDEN_JK(WORK(KT3B0KL),ISYMTETAU,ISYML,L, 1024 * ISYMK,K) 1025 1026C 1027C ------------------------------------------ 1028C KTETAXKL = KT3B0KL(d- e- b-)_(LMn) * FOCKZ 1029C ------------------------------------------ 1030C 1031C 1032 IOPT = 2 1033 CALL TETAX_JK_BC_CUB(.TRUE.,.FALSE., 1034 * IOPT,WORK(KT3B0KL),ISTETAUKL, 1035 * WORK(KFOCKRZ),ISYMRZ, 1036 * WORK(KTETAXKL),ISTETAZUKL, 1037 * WORK(KEND2),LWRK2) 1038C 1039 CALL TETAX_JK_A(WORK(KT3B0KL),ISTETAUKL,WORK(KFOCKRZ), 1040 * ISYMRZ,WORK(KTETAXKL),ISTETAZUKL, 1041 * WORK(KEND2),LWRK2) 1042C 1043 CALL W3JK_DIA(WORK(KTETAXKL),ISTETAZUKL,ISYML,L, 1044 * ISYMK,K,WORK(KFOCKD),FREQZU) 1045C 1046 CALL T3_FORBIDDEN_JK(WORK(KTETAXKL),ISYMTETAZU, 1047 * ISYML,L,ISYMK,K) 1048 1049c call sum_pt3_jk(work(KTETAXKL),isyml,l,isymk,k, 1050c * ISYMTETAZU, 1051c * work(kx3am),4) 1052 1053 1054C 1055C------------------------------------------- 1056C Get T3BAR0^KL multipliers 1057C------------------------------------------- 1058C 1059 !KT3B0KL is reused here 1060 CALL DZERO(WORK(KT3B0KL),NMAABCI(ISYT3B0KL)) 1061C 1062 CALL GET_T3B0_JK_O(WORK(KT3B0KL),ISYT3B0KL, 1063 * WORK(KL2TP),ISYML0, 1064 * WORK(KT3BOL2),WORK(KT3BOG2),ISYM0, 1065 * ISYML,L,ISYMK,K, 1066 * WORK(KEND2),LWRK2) 1067 CALL GET_T3B0_JK_V(WORK(KT3B0KL),ISYT3B0KL, 1068 * WORK(KL2TP),ISYML0, 1069 * WORK(KXGADCK),WORK(KXLADCK), 1070 * ISYM0,ISYML,L,ISYMK,K, 1071 * WORK(KEND2),LWRK2) 1072C 1073 CALL GET_T3B0_JK_L1F(WORK(KT3B0KL),ISYT3B0KL, 1074 * WORK(KL1AM),ISYML0, 1075 * WORK(KXIAJB),ISYM0, 1076 * WORK(KL2TP),ISYML0, 1077 * WORK(KFCKBA),ISYM0, 1078 * ISYML,L,ISYMK,K) 1079 1080 1081 !Divide by orbital energy difference and remove 1082 !forbidden elements 1083 CALL T3JK_DIA(WORK(KT3B0KL),ISYT3B0KL,ISYML,L,ISYMK,K, 1084 * WORK(KFOCKD)) 1085 CALL T3_FORBIDDEN_JK(WORK(KT3B0KL),ISYMT3B,ISYML,L, 1086 * ISYMK,K) 1087 1088c call sum_pt3_jk(work(kt3b0kl),isyml,l,isymk,k,isyt3b0kl, 1089c * work(kx3am),6) 1090C 1091 IF (IPRINT .GT. 55) THEN 1092 XNORMVAL = DDOT(NMAABCI(ISYT3B0KL),WORK(KT3B0KL),1, 1093 * WORK(KT3B0KL),1) 1094 WRITE(LUPRI,*)'NORM OF KT3B0KL CC3_ADENOCC_CUB ', 1095 * XNORMVAL 1096 END IF 1097 1098C 1099C------------------------------------------- 1100C Get W3BARX^KL multipliers 1101C------------------------------------------- 1102C 1103 CALL DZERO(WORK(KW3BXKL),NMAABCI(ISYW3BXKL)) 1104C 1105C <L2|[Y,tau3]|HF> + <L3|[Y^,tau3]|HF> 1106C 1107 CALL WBX_JK_ETA(WORK(KT3B0KL),ISYT3B0KL,WORK(KFOCKL1), 1108 * ISYML1,WORK(KW3BXKL),ISYW3BXKL, 1109 * WORK(KL2TP),ISYML0,ISYML,L,ISYMK,K, 1110 * WORK(KEND2),LWRK2) 1111C 1112C <L2Y|[H^,tau3]|HF> 1113C 1114 CALL WBX_JK_FMAT(WORK(KW3BXKL),ISYW3BXKL, 1115 * WORK(KL2),ISYML1, 1116 * WORK(KFCKBA),ISYM0, 1117 * WORK(KT3BOL2),WORK(KT3BOG2), 1118 * WORK(KXGADCK),WORK(KXLADCK),ISYM0, 1119 * ISYML,L,ISYMK,K, 1120 * WORK(KEND2),LWRK2) 1121C 1122C <L2|[H^Y,tau3]|HF> 1123C 1124 CALL WBX_JK_FMAT(WORK(KW3BXKL),ISYW3BXKL, 1125 * WORK(KL2TP),ISYML0, 1126 * WORK(KFOCKL1RCK),ISYFCKL1R, 1127 * WORK(KT3BOL2X),WORK(KT3BOG2X), 1128 * WORK(KXGADCKX),WORK(KXLADCKX), 1129 * ISINT2L1R, 1130 * ISYML,L,ISYMK,K, 1131 * WORK(KEND2),LWRK2) 1132C 1133C <L1Y|[H^,tau3]|HF> 1134C 1135 CALL WBX_JK_L1(WORK(KW3BXKL),ISYW3BXKL, 1136 * WORK(KL1),ISYML1, 1137 * WORK(KXIAJB),ISYM0, 1138 * ISYML,L,ISYMK,K) 1139C 1140C-------------------------------------------------------------- 1141C Divide by orbital energy difference and remove 1142C forbidden elements 1143C-------------------------------------------------------------- 1144C 1145 CALL W3JK_DIA(WORK(KW3BXKL),ISYW3BXKL,ISYML,L,ISYMK,K, 1146 * WORK(KFOCKD),-FREQL1) 1147 CALL T3_FORBIDDEN_JK(WORK(KW3BXKL),ISYMW3BX,ISYML,L, 1148 * ISYMK,K) 1149C 1150 !To conform with real sign of t3b multipliers 1151 !(noddy code definition) 1152 CALL DSCAL(NMAABCI(ISYW3BXKL),-ONE,WORK(KW3BXKL),1) 1153 1154c call sum_pt3_jk(work(kw3bxkl),isyml,l,isymk,k,isyw3bxkl, 1155c * work(kx3am),4) 1156C 1157 IF (IPRINT .GT. 55) THEN 1158 XNORMVAL = DDOT(NMAABCI(ISYW3BXKL),WORK(KW3BXKL),1, 1159 * WORK(KW3BXKL),1) 1160 WRITE(LUPRI,*)'NORM OF KW3BXKL IN CC3_ADENOCC_CUB ', 1161 * XNORMVAL 1162 END IF 1163 1164 1165 !CONTRACTION: 3rd line of Eq. 61: 1166 1167 !1/2 Wbar^LM(naed) theta^{d--e--b--}_{LMn} 1168 ! + Wbar^LM(nead) theta^{d--b--e--}_{LMn} 1169 !(-- denotes double transformation of an index) 1170 IOPT = 2 1171 CALL ADEN_DAB_LM_CUB(IOPT,DAB, 1172 * WORK(KTETAXKL),ISTETAZUKL, 1173 * WORK(KW3BXKL),ISYW3BXKL, 1174 * WORK(KEND2),LWRK2) 1175C 1176 !CONTRACTION: last line of Eq. 62 (1st term): 1177 1178 !1/2 Wbar^LM(fjed) theta^{d--e--f--}_{LMi} 1179 CALL ADEN_DIJ_JK(DIJ,WORK(KTETAXKL),ISTETAZUKL, 1180 * WORK(KW3BXKL),ISYW3BXKL) 1181 1182C 1183 !CONTRACTION: last term of Eq. 63 1184 1185 !T2bar^{de}_{LM} ( theta^{d--e--a--}_{LMi} 1186 ! - theta^{d--a--e--}_{LMi} ) 1187 CALL ADEN_DAI_LM(DIA,WORK(KL2),ISYML1, 1188 * WORK(KTETAXKL),ISTETAZUKL, 1189 * ISYML,L,ISYMK,K, 1190 * WORK(KEND2),LWRK2) 1191 1192 1193 1194 CALL DZERO(WORK(KW3BXKL),NMAABCI(ISTETAZKL)) 1195C 1196 CALL WJK_GROUND_OCC(WORK(KW3BXKL),ISTETAZKL, 1197 * WORK(KT2RZ),ISYMRZ, 1198 * WORK(KT3OG2),ISYM0, 1199 * ISYML,L,ISYMK,K, 1200 * WORK(KEND2),LWRK2) 1201C 1202 CALL WJK_GROUND_OCC(WORK(KW3BXKL),ISTETAZKL, 1203 * WORK(KT2TP),ISYM0, 1204 * WORK(KT3OG2Z),ISYMRZ, 1205 * ISYML,L,ISYMK,K, 1206 * WORK(KEND2),LWRK2) 1207C 1208 !allocation !!! 1209 KABCI = KEND2 1210 KEND3 = KABCI + NMAABCI(ISTETAUKL) 1211 LWRK3 = LWORK - KEND3 1212C 1213 IF (LWRK3 .LT. 0) THEN 1214 WRITE(LUPRI,*) 'Memory available : ',LWORK 1215 WRITE(LUPRI,*) 'Memory needed : ',KEND3 1216 CALL QUIT('Insufficient space in CC3_ADENOCC_CUB (5)') 1217 END IF 1218 1219 CALL DZERO(WORK(KABCI),NMAABCI(ISTETAUKL)) 1220C 1221 CALL WJK_GROUND_OCC(WORK(KABCI),ISTETAUKL, 1222 * WORK(KT2RU),ISYMRU, 1223 * WORK(KT3OG2),ISYM0, 1224 * ISYML,L,ISYMK,K, 1225 * WORK(KEND3),LWRK3) 1226C 1227 CALL WJK_GROUND_OCC(WORK(KABCI),ISTETAUKL, 1228 * WORK(KT2TP),ISYM0, 1229 * WORK(KT3OG2U),ISYMRU, 1230 * ISYML,L,ISYMK,K, 1231 * WORK(KEND3),LWRK3) 1232C 1233 !the real construction of wJK(abci-) 1234 CALL TETAX_JK_I(WORK(KT30KL),ISYT30KL, 1235 * WORK(KFOCKRZ),ISYMRZ, 1236 * WORK(KW3BXKL),ISTETAZKL, 1237 * WORK(KEND3),LWRK3) 1238C 1239 CALL WJK_T2(ONE,L,ISYML,K,ISYMK,WORK(KT2TP),ISYM0, 1240 * WORK(KT2TP), 1241 * ISYM0, 1242 * WORK(KFOCKRZ),ISYMRZ, 1243 * WORK(KW3BXKL),ISTETAZKL, 1244 * WORK(KEND3),LWRK3) 1245 1246c call sum_pt3_jk(work(KW3BXKL),isyml,l,isymk,k,ISTETAZKL, 1247c * work(kx3am),7) 1248C 1249 CALL WJK_GROUND(WORK(KW3BXKL),ISTETAZKL, 1250 * WORK(KT2RZ),ISYMRZ, 1251 * WORK(KGBCDK),ISYM0, 1252 * ISYML,L,ISYMK,K, 1253 * WORK(KEND3),LWRK3) 1254C 1255 1256 CALL WJK_GROUND(WORK(KW3BXKL),ISTETAZKL, 1257 * WORK(KT2TP),ISYM0, 1258 * WORK(KGBCDKZ),ISYMRZ, 1259 * ISYML,L,ISYMK,K, 1260 * WORK(KEND3),LWRK3) 1261C 1262 1263 1264c call sum_pt3_jk(work(KW3BXKL),isyml,l,isymk,k,ISTETAZKL, 1265c * work(kx3am),7) 1266 1267C 1268 CALL W3JK_DIA(WORK(KW3BXKL),ISTETAZKL,ISYML,L,ISYMK,K, 1269 * WORK(KFOCKD),FREQRZ) 1270C 1271 CALL T3_FORBIDDEN_JK(WORK(KW3BXKL),ISYMTETAZ,ISYML,L, 1272 * ISYMK,K) 1273 1274c call sum_pt3_jk(work(KW3BXKL),isyml,l,isymk,k,ISTETAZKL, 1275c * work(kx3am),7) 1276 1277 1278 1279 !to include P(ZU) permutation in KABCI 1280 1281 CALL TETAX_JK_I(WORK(KT30KL),ISYT30KL, 1282 * WORK(KFOCKRU),ISYMRU, 1283 * WORK(KABCI),ISTETAUKL, 1284 * WORK(KEND3),LWRK3) 1285 1286 CALL WJK_T2(ONE,L,ISYML,K,ISYMK,WORK(KT2TP),ISYM0, 1287 * WORK(KT2TP), 1288 * ISYM0, 1289 * WORK(KFOCKRU),ISYMRU, 1290 * WORK(KABCI),ISTETAUKL, 1291 * WORK(KEND3),LWRK3) 1292C 1293 CALL WJK_GROUND(WORK(KABCI),ISTETAUKL, 1294 * WORK(KT2RU),ISYMRU, 1295 * WORK(KGBCDK),ISYM0, 1296 * ISYML,L,ISYMK,K, 1297 * WORK(KEND3),LWRK3) 1298C 1299 CALL WJK_GROUND(WORK(KABCI),ISTETAUKL, 1300 * WORK(KT2TP),ISYM0, 1301 * WORK(KGBCDKU),ISYMRU, 1302 * ISYML,L,ISYMK,K, 1303 * WORK(KEND3),LWRK3) 1304C 1305 1306C 1307 CALL W3JK_DIA(WORK(KABCI),ISTETAUKL,ISYML,L,ISYMK,K, 1308 * WORK(KFOCKD),FREQRU) 1309C 1310 CALL T3_FORBIDDEN_JK(WORK(KABCI),ISYMTETAU,ISYML,L, 1311 * ISYMK,K) 1312 1313 1314 !allocation !!! 1315 K1 = KEND3 1316 K1X = K1 + NMAABCI(ISYW3BXKL) 1317 KEND3 = K1X + NMAABCI(ISYW3BXKL) 1318 LWRK3 = LWORK - KEND3 1319C 1320 IF (LWRK3 .LT. 0) THEN 1321 WRITE(LUPRI,*) 'Memory available : ',LWORK 1322 WRITE(LUPRI,*) 'Memory needed : ',KEND3 1323 CALL QUIT('Insufficient space in CC3_ADENOCC_CUB(6)') 1324 END IF 1325 1326c get extra thetaBAR(d-ea)_(LMn) intermediate (special for cubic) 1327 CALL DZERO(WORK(K1),NMAABCI(ISYW3BXKL)) 1328 1329 IOPT = 1 1330 CALL TETAX_JK_BC_CUB(.FALSE.,.TRUE., 1331 * IOPT,WORK(KT3B0KL),ISYT3B0KL, 1332 * WORK(KFOCKL1),ISYML1, 1333 * WORK(K1),ISYW3BXKL, 1334 * WORK(KEND3),LWRK3) 1335C 1336 CALL W3JK_DIA(WORK(K1),ISYW3BXKL,ISYML,L,ISYMK,K, 1337 * WORK(KFOCKD),-FREQL1) 1338 CALL T3_FORBIDDEN_JK(WORK(K1),ISYMW3BX,ISYML,L, 1339 * ISYMK,K) 1340C 1341 !To conform with real sign of t3b multipliers 1342 !(noddy code definition) 1343 CALL DSCAL(NMAABCI(ISYW3BXKL),-ONE,WORK(K1),1) 1344 1345c get extra thetaBAR(aed-)_(LMn) intermediate (special for cubic) 1346 CALL DZERO(WORK(K1X),NMAABCI(ISYW3BXKL)) 1347 1348 CALL TETAX_JK_A_CUB(.FALSE.,.TRUE., 1349 * WORK(KT3B0KL),ISYT3B0KL, 1350 * WORK(KFOCKL1),ISYML1, 1351 * WORK(K1X),ISYW3BXKL, 1352 * WORK(KEND3),LWRK3) 1353C 1354 CALL W3JK_DIA(WORK(K1X),ISYW3BXKL,ISYML,L,ISYMK,K, 1355 * WORK(KFOCKD),-FREQL1) 1356 CALL T3_FORBIDDEN_JK(WORK(K1X),ISYMW3BX,ISYML,L, 1357 * ISYMK,K) 1358C 1359 !To conform with real sign of t3b multipliers 1360 !(noddy code definition) 1361 CALL DSCAL(NMAABCI(ISYW3BXKL),-ONE,WORK(K1X),1) 1362 1363c call sum_pt3_jk(work(KW3BXKL),isyml,l,isymk,k,ISTETAZKL, 1364c * work(kx3am),7) 1365 1366 CALL DZERO(WORK(KTETAXKL),NMAABCI(ISTETAZUKL)) 1367C 1368 !1st cont to 57 1369 !theta^{dbe-}_{LMn-} <-- U_ec w^{dbc}_{LMn-} 1370 CALL TETAX_JK_A(WORK(KW3BXKL),ISTETAZKL, 1371 * WORK(KFOCKRU),ISYMRU, 1372 * WORK(KTETAXKL),ISTETAZUKL, 1373 * WORK(KEND3),LWRK3) 1374C 1375 !2nd cont to 57 1376 !theta^{dbe-}_{LMn-} <-- U^{Z}_ec t0^{dbc}_{LMn} 1377 CALL TETAX_JK_A(WORK(KT30KL),ISYT30KL, 1378 * WORK(KFCKUZV),ISYMZU, 1379 * WORK(KTETAXKL),ISTETAZUKL, 1380 * WORK(KEND3),LWRK3) 1381 !3rd cont to 57 1382 !theta^{dbe-}_{LMn-} <-- - U_jn theta^{dbe-}_{LMj} 1383 CALL DZERO(WORK(KT3B0KL),NMAABCI(ISTETAZKL)) 1384C 1385 ! thetaZ(deb-)_(LMn) 1386 IOPT = 3 1387 CALL TETAX_JK_A(WORK(KT30KL),ISYT30KL, 1388 * WORK(KFOCKRZ),ISYMRZ, 1389 * WORK(KT3B0KL),ISTETAZKL, 1390 * WORK(KEND3),LWRK3) 1391C 1392 CALL W3JK_DIA(WORK(KT3B0KL),ISTETAZKL,ISYML,L,ISYMK,K, 1393 * WORK(KFOCKD),FREQRZ) 1394C 1395 CALL T3_FORBIDDEN_JK(WORK(KT3B0KL),ISYMTETAZ,ISYML,L, 1396 * ISYMK,K) 1397C 1398 ! thetaZU(deb-)_(LMn-) = thetaZ(deb- )_(LMk) *FOCKU(k,n) 1399 CALL TETAX_JK_I(WORK(KT3B0KL),ISTETAZKL, 1400 * WORK(KFOCKRU),ISYMRU, 1401 * WORK(KTETAXKL),ISTETAZUKL, 1402 * WORK(KEND3),LWRK3) 1403C 1404C INCLUDE P(ZU) permutation 1405C 1406 !1st cont to 57 1407 !theta^{dbe-}_{LMn-} <-- Z_ec w^{dbc}_{LMn-} 1408 CALL TETAX_JK_A(WORK(KABCI),ISTETAUKL, 1409 * WORK(KFOCKRZ),ISYMRZ, 1410 * WORK(KTETAXKL),ISTETAZUKL, 1411 * WORK(KEND3),LWRK3) 1412 1413 !2nd cont to 57 1414 !theta^{dbe-}_{LMn-} <-- Z^{U}_ec t0^{dbc}_{LMn} 1415 CALL TETAX_JK_A(WORK(KT30KL),ISYT30KL, 1416 * WORK(KFCKZUV),ISYMZU, 1417 * WORK(KTETAXKL),ISTETAZUKL, 1418 * WORK(KEND3),LWRK3) 1419 !3rd cont to 57 1420 !theta^{dbe-}_{LMn-} <-- - Z_jn theta^{dbe-}_{LMj} 1421 CALL DZERO(WORK(KT3B0KL),NMAABCI(ISTETAUKL)) 1422C 1423 ! thetaU(deb-)_(LMn) 1424 IOPT = 3 1425 CALL TETAX_JK_A(WORK(KT30KL),ISYT30KL, 1426 * WORK(KFOCKRU),ISYMRU, 1427 * WORK(KT3B0KL),ISTETAUKL, 1428 * WORK(KEND3),LWRK3) 1429C 1430 CALL W3JK_DIA(WORK(KT3B0KL),ISTETAUKL,ISYML,L,ISYMK,K, 1431 * WORK(KFOCKD),FREQRU) 1432C 1433 CALL T3_FORBIDDEN_JK(WORK(KT3B0KL),ISYMTETAU,ISYML,L, 1434 * ISYMK,K) 1435C 1436 ! thetaZU(deb-)_(LMn-) = thetaU(deb- )_(LMk) *FOCKZ(k,n) 1437C 1438 CALL TETAX_JK_I(WORK(KT3B0KL),ISTETAUKL, 1439 * WORK(KFOCKRZ),ISYMRZ, 1440 * WORK(KTETAXKL),ISTETAZUKL, 1441 * WORK(KEND3),LWRK3) 1442 CALL W3JK_DIA(WORK(KTETAXKL),ISTETAZUKL,ISYML,L, 1443 * ISYMK,K,WORK(KFOCKD),FREQZU) 1444 1445 CALL T3_FORBIDDEN_JK(WORK(KTETAXKL),ISYMTETAZU, 1446 * ISYML,L,ISYMK,K) 1447 1448 !last line in Eq. 61 (term 1) 1449 !thetabar^{d-ae}_{LMn} theta^{dbe-}_{LMn-} 1450 IOPT = 3 1451 CALL ADEN_DAB_LM_CUB(IOPT,DAB, 1452 * WORK(KTETAXKL),ISTETAZUKL, 1453 * WORK(k1),ISYW3BXKL, 1454 * WORK(KEND3),LWRK3) 1455 1456 1457 !construct theta for last line in 61 (term 2 & 3) 1458 !KT3B0KL is reused 1459 CALL DZERO(WORK(KT3B0KL),NMAABCI(ISTETAZKL)) 1460C 1461 ! thetaZ(de- b)_(LMn) 1462 IOPT = 3 1463 CALL TETAX_JK_BC_CUB(.TRUE.,.FALSE., 1464 * IOPT,WORK(KT30KL),ISYT30KL, 1465 * WORK(KFOCKRZ),ISYMRZ, 1466 * WORK(KT3B0KL),ISTETAZKL, 1467 * WORK(KEND3),LWRK3) 1468C 1469 CALL W3JK_DIA(WORK(KT3B0KL),ISTETAZKL,ISYML,L,ISYMK,K, 1470 * WORK(KFOCKD),FREQRZ) 1471C 1472 CALL T3_FORBIDDEN_JK(WORK(KT3B0KL),ISYMTETAZ,ISYML,L, 1473 * ISYMK,K) 1474C 1475 ! thetaZU(de- b)_(LMn-) = thetaZ(de- b)_(LMk) *FOCKU(k,n) 1476 CALL DZERO(WORK(KTETAXKL),NMAABCI(ISTETAZUKL)) 1477C 1478 CALL TETAX_JK_I(WORK(KT3B0KL),ISTETAZKL, 1479 * WORK(KFOCKRU),ISYMRU, 1480 * WORK(KTETAXKL),ISTETAZUKL, 1481 * WORK(KEND3),LWRK3) 1482C 1483C INCLUDE P(ZU) permutation now 1484C 1485 1486 CALL DZERO(WORK(KT3B0KL),NMAABCI(ISTETAUKL)) 1487C 1488 ! thetaU(de- b)_(LMn) 1489 IOPT = 3 1490 CALL TETAX_JK_BC_CUB(.TRUE.,.FALSE., 1491 * IOPT,WORK(KT30KL),ISYT30KL, 1492 * WORK(KFOCKRU),ISYMRU, 1493 * WORK(KT3B0KL),ISTETAUKL, 1494 * WORK(KEND3),LWRK3) 1495C 1496 CALL W3JK_DIA(WORK(KT3B0KL),ISTETAUKL,ISYML,L,ISYMK,K, 1497 * WORK(KFOCKD),FREQRU) 1498C 1499 CALL T3_FORBIDDEN_JK(WORK(KT3B0KL),ISYMTETAU,ISYML,L, 1500 * ISYMK,K) 1501C 1502 ! thetaZU(de- b)_(LMn-) = thetaU(de- b)_(LMk) *FOCKZ(k,n) 1503 CALL TETAX_JK_I(WORK(KT3B0KL),ISTETAUKL, 1504 * WORK(KFOCKRZ),ISYMRZ, 1505 * WORK(KTETAXKL),ISTETAZUKL, 1506 * WORK(KEND3),LWRK3) 1507C 1508 1509 IOPT = 3 1510 CALL TETAX_JK_BC_CUB(.TRUE.,.FALSE., 1511 * IOPT,WORK(KW3BXKL),ISTETAZKL, 1512 * WORK(KFOCKRU),ISYMRU, 1513 * WORK(KTETAXKL),ISTETAZUKL, 1514 * WORK(KEND3),LWRK3) 1515C 1516C INCLUDE P(ZU) permutation 1517C 1518 IOPT = 3 1519 CALL TETAX_JK_BC_CUB(.TRUE.,.FALSE., 1520 * IOPT,WORK(KABCI),ISTETAUKL, 1521 * WORK(KFOCKRZ),ISYMRZ, 1522 * WORK(KTETAXKL),ISTETAZUKL, 1523 * WORK(KEND3),LWRK3) 1524 1525 CALL W3JK_DIA(WORK(KTETAXKL),ISTETAZUKL,ISYML,L, 1526 * ISYMK,K,WORK(KFOCKD),FREQZU) 1527 1528 CALL T3_FORBIDDEN_JK(WORK(KTETAXKL),ISYMTETAZU, 1529 * ISYML,L,ISYMK,K) 1530 1531 1532 1533 !last line in Eq. 61 (term 2) 1534 !thetabar^{d-ea}_{LMn} theta^{de-b}_{LMn-} 1535 IOPT = 1 1536 CALL DSCAL(NMAABCI(ISYW3BXKL),2.0D0,WORK(K1),1) 1537 CALL ADEN_DAB_LM_CUB(IOPT,DAB, 1538 * WORK(KTETAXKL),ISTETAZUKL, 1539 * WORK(k1),ISYW3BXKL, 1540 * WORK(KEND3),LWRK3) 1541 !last line in Eq. 61 (term 3) 1542 !thetabar^{aed-}_{LMn} theta^{be-d}_{LMn-} 1543 IOPT = 0 1544 CALL ADEN_DAB_LM_CUB(IOPT,DAB, 1545 * WORK(KTETAXKL),ISTETAZUKL, 1546 * WORK(k1x),ISYW3BXKL, 1547 * WORK(KEND3),LWRK3) 1548 1549 !intermmediates for last line of Eq. 62 (2nd term) 1550 CALL DZERO(WORK(KT3B0KL),NMAABCI(ISTETAZKL)) 1551C 1552 ! thetaZ(de- b)_(LMn) 1553 IOPT = 3 1554 CALL TETAX_JK_BC_CUB(.TRUE.,.FALSE., 1555 * IOPT,WORK(KT30KL),ISYT30KL, 1556 * WORK(KFOCKRZ),ISYMRZ, 1557 * WORK(KT3B0KL),ISTETAZKL, 1558 * WORK(KEND3),LWRK3) 1559C 1560 CALL W3JK_DIA(WORK(KT3B0KL),ISTETAZKL,ISYML,L,ISYMK,K, 1561 * WORK(KFOCKD),FREQRZ) 1562C 1563 CALL T3_FORBIDDEN_JK(WORK(KT3B0KL),ISYMTETAZ,ISYML,L, 1564 * ISYMK,K) 1565C 1566 CALL DZERO(WORK(KTETAXKL),NMAABCI(ISTETAZUKL)) 1567 ! thetaZU(de- b-)_(LMn) 1568 CALL TETAX_JK_A(WORK(KT3B0KL),ISTETAZKL, 1569 * WORK(KFOCKRU),ISYMRU, 1570 * WORK(KTETAXKL),ISTETAZUKL, 1571 * WORK(KEND3),LWRK3) 1572C 1573 CALL DZERO(WORK(KT3B0KL),NMAABCI(ISTETAZKL)) 1574C 1575 ! thetaZ(deb- )_(LMn) 1576 CALL TETAX_JK_A(WORK(KT30KL),ISYT30KL, 1577 * WORK(KFOCKRZ),ISYMRZ, 1578 * WORK(KT3B0KL),ISTETAZKL, 1579 * WORK(KEND3),LWRK3) 1580C 1581 CALL W3JK_DIA(WORK(KT3B0KL),ISTETAZKL,ISYML,L,ISYMK,K, 1582 * WORK(KFOCKD),FREQRZ) 1583C 1584 CALL T3_FORBIDDEN_JK(WORK(KT3B0KL),ISYMTETAZ,ISYML,L, 1585 * ISYMK,K) 1586C 1587 ! thetaZU(de- b-)_(LMn) 1588 CALL TETAX_JK_BC_CUB(.TRUE.,.FALSE., 1589 * IOPT,WORK(KT3B0KL),ISTETAZKL, 1590 * WORK(KFOCKRU),ISYMRU, 1591 * WORK(KTETAXKL),ISTETAZUKL, 1592 * WORK(KEND3),LWRK3) 1593 1594 1595C 1596C INCLUDE P(ZU) permutation 1597C 1598 1599 CALL DZERO(WORK(KT3B0KL),NMAABCI(ISTETAUKL)) 1600C 1601 ! thetaU(de- b)_(LMn) 1602 IOPT = 3 1603 CALL TETAX_JK_BC_CUB(.TRUE.,.FALSE., 1604 * IOPT,WORK(KT30KL),ISYT30KL, 1605 * WORK(KFOCKRU),ISYMRU, 1606 * WORK(KT3B0KL),ISTETAUKL, 1607 * WORK(KEND3),LWRK3) 1608C 1609 CALL W3JK_DIA(WORK(KT3B0KL),ISTETAUKL,ISYML,L,ISYMK,K, 1610 * WORK(KFOCKD),FREQRU) 1611C 1612 CALL T3_FORBIDDEN_JK(WORK(KT3B0KL),ISYMTETAU,ISYML,L, 1613 * ISYMK,K) 1614C 1615 ! thetaZU(de- b-)_(LMn) 1616 CALL TETAX_JK_A(WORK(KT3B0KL),ISTETAUKL, 1617 * WORK(KFOCKRZ),ISYMRZ, 1618 * WORK(KTETAXKL),ISTETAZUKL, 1619 * WORK(KEND3),LWRK3) 1620C 1621 CALL DZERO(WORK(KT3B0KL),NMAABCI(ISTETAUKL)) 1622C 1623 ! thetaZ(deb- )_(LMn) 1624 CALL TETAX_JK_A(WORK(KT30KL),ISYT30KL, 1625 * WORK(KFOCKRU),ISYMRU, 1626 * WORK(KT3B0KL),ISTETAUKL, 1627 * WORK(KEND3),LWRK3) 1628C 1629 CALL W3JK_DIA(WORK(KT3B0KL),ISTETAUKL,ISYML,L,ISYMK,K, 1630 * WORK(KFOCKD),FREQRU) 1631C 1632 CALL T3_FORBIDDEN_JK(WORK(KT3B0KL),ISYMTETAU,ISYML,L, 1633 * ISYMK,K) 1634C 1635 ! thetaZU(de- b-)_(LMn) 1636 CALL TETAX_JK_BC_CUB(.TRUE.,.FALSE., 1637 * IOPT,WORK(KT3B0KL),ISTETAUKL, 1638 * WORK(KFOCKRZ),ISYMRZ, 1639 * WORK(KTETAXKL),ISTETAZUKL, 1640 * WORK(KEND3),LWRK3) 1641C 1642 CALL W3JK_DIA(WORK(KTETAXKL),ISTETAZUKL,ISYML,L, 1643 * ISYMK,K,WORK(KFOCKD),FREQZU) 1644 1645 CALL T3_FORBIDDEN_JK(WORK(KTETAXKL),ISYMTETAZU, 1646 * ISYML,L,ISYMK,K) 1647 1648 1649 1650 !CONTRACTION: last line of Eq. 62 (2nd term) 1651 !thetabar^{d-ef}_{LMj} theta^{de-f-}_{LMi} 1652C 1653 CALL ADEN_DIJ_JK(DIJ,WORK(KTETAXKL),ISTETAZUKL, 1654 * WORK(k1),ISYW3BXKL) 1655 1656C 1657 IF (IPRINT .GT. 55) THEN 1658 XNORMVAL = DDOT(NMATAB(ISYDEN),DAB,1,DAB,1) 1659 WRITE(LUPRI,*)'NORM OF DAB AFTER ADEN_DAB_LM ', 1660 * XNORMVAL 1661 END IF 1662C 1663 IF (IPRINT .GT. 55) THEN 1664 XNORMVAL = DDOT(NT1AM(ISYDEN),DIA,1,DIA,1) 1665 WRITE(LUPRI,*)'NORM OF DIA AFTER ADEN_DAI_LM ', 1666 * XNORMVAL 1667 END IF 1668C 1669 ENDDO ! L 1670 ENDDO ! ISYML 1671 ENDDO ! K 1672 ENDDO ! ISYMK 1673C 1674c write(lupri,*) 'W3BAR in CC3_ADENOCC_CUB' 1675c write(lupri,*) 'T30KL in CC3_ADENOCC_CUB' 1676c call print_pt3(work(kx3am),isym0,4) 1677C 1678C-------------------------------- 1679C Close files for "response" 1680C-------------------------------- 1681C 1682 CALL WCLOSE2(LU3SRTR,FN3SRTR,'DELETE') 1683 CALL WCLOSE2(LUCKJDRZ,FNCKJDRZ,'DELETE') 1684 CALL WCLOSE2(LUDELDRZ,FNDELDRZ,'DELETE') 1685 CALL WCLOSE2(LUDKBCRZ,FNDKBCRZ,'DELETE') 1686C 1687 CALL WCLOSE2(LUCKJDRU,FNCKJDRU,'DELETE') 1688 CALL WCLOSE2(LUDELDRU,FNDELDRU,'DELETE') 1689 CALL WCLOSE2(LUDKBCRU,FNDKBCRU,'DELETE') 1690C 1691C 1692C------------- 1693C End 1694C------------- 1695C 1696 1697 CALL QEXIT('CC3AOCB') 1698C 1699 RETURN 1700 END 1701C /* Deck tetax_jk_a_cub */ 1702 SUBROUTINE TETAX_JK_A_CUB(LAMP,LMUL,T0JK,IST0JK,XOP,ISYMXOP, 1703 * TETAXJK,ISTETAXJK,WORK,LWORK) 1704C 1705C TETAXJK(bcai) = TETAXJK(bcai) 1706C 1707C - xop(ad) t0_jk(bcdi) 1708C 1709C LAMP = .TRUE. : carry out amplitudes-like transformations 1710C LMUL = .TRUE. : carry out multipliers-like transformations 1711 1712 1713 IMPLICIT NONE 1714C 1715 LOGICAL LAMP,LMUL 1716 INTEGER IST0JK, ISYMXOP, ISTETAXJK, LWORK 1717 INTEGER KAD, KEND1, LWRK1, KOFF1, KOFF2, KOFF3 1718 INTEGER ISYMI, ISYMBCD, ISYMD, ISYMA, ISYMBCA, ISYMBC 1719 INTEGER NTOTBC, NTOTA 1720 INTEGER NTOTD 1721C 1722#if defined (SYS_CRAY) 1723 REAL TB0JK(*), TETAXJK(*), XOP(*), WORK(LWORK) 1724 REAL ONE 1725 real xnormval,ddot 1726#else 1727 DOUBLE PRECISION T0JK(*), TETAXJK(*), XOP(*), WORK(LWORK) 1728 DOUBLE PRECISION ONE 1729 double precision xnormval,ddot 1730#endif 1731C 1732 PARAMETER (ONE = 1.0D0) 1733C 1734#include "priunit.h" 1735#include "ccsdsym.h" 1736#include "ccorb.h" 1737#include "ccsdinp.h" 1738C 1739 CALL QENTER('TETACB') 1740C 1741 !initial test of logic 1742 IF (LAMP .EQV. LMUL) THEN 1743 WRITE(LUPRI,*)'LAMP = ', LAMP 1744 WRITE(LUPRI,*)'LMUL = ', LMUL 1745 WRITE(LUPRI,*)'LAMP and LMUL must have opposite values ' 1746 CALL QUIT('Logic fault in TETAX_JK_A_CUB') 1747 END IF 1748 1749 KAD = 1 1750 KEND1 = KAD + NMATAB(ISYMXOP) 1751 LWRK1 = LWORK - KEND1 1752C 1753 IF (LWRK1 .LT. 0) THEN 1754 WRITE(LUPRI,*) 'Memory available : ',LWRK1 1755 WRITE(LUPRI,*) 'Memory needed : ',KEND1 1756 CALL QUIT('Insufficient space in TETAX_JK_A_CUB') 1757 END IF 1758C 1759C SORT VIR-VIR XOP ELEMENTS (A,D) 1760C 1761C 1762 DO ISYMD = 1,NSYM 1763 ISYMA = MULD2H(ISYMD,ISYMXOP) 1764 DO D = 1,NVIR(ISYMD) 1765 KOFF1 = IFCVIR(ISYMA,ISYMD) + NORB(ISYMA)*(D - 1) 1766 * + NRHF(ISYMA) + 1 1767 KOFF2 = KAD + IMATAB(ISYMA,ISYMD) + NVIR(ISYMA)*(D - 1) 1768 CALL DCOPY(NVIR(ISYMA),XOP(KOFF1),1,WORK(KOFF2),1) 1769 END DO 1770 END DO 1771C 1772C TETAXJK(bcai) = TETAXJK(bcai) 1773C 1774C - xop(ad) t0_jk(bcdi) 1775 DO ISYMI = 1,NSYM 1776 ISYMBCD = MULD2H(IST0JK,ISYMI) 1777 DO I = 1,NRHF(ISYMI) 1778 DO ISYMD = 1,NSYM 1779 ISYMA = MULD2H(ISYMD,ISYMXOP) 1780 ISYMBCA = MULD2H(ISYMXOP,ISYMBCD) 1781 ISYMBC = MULD2H(ISYMBCD,ISYMD) 1782 KOFF1 = 1 1783 * + IMAABCI(ISYMBCD,ISYMI) 1784 * + NMAABC(ISYMBCD)*(I-1) 1785 * + IMAABC(ISYMBC,ISYMD) 1786C 1787 IF (LAMP) THEN 1788 KOFF2 = KAD 1789 * + IMATAB(ISYMA,ISYMD) 1790 ELSE 1791 KOFF2 = KAD 1792 * + IMATAB(ISYMD,ISYMA) 1793 END IF 1794C 1795 KOFF3 = 1 1796 * + IMAABCI(ISYMBCA,ISYMI) 1797 * + NMAABC(ISYMBCA)*(I-1) 1798 * + IMAABC(ISYMBC,ISYMA) 1799C 1800 NTOTBC = MAX(1,NMATAB(ISYMBC)) 1801 IF (LAMP) THEN 1802 NTOTA = MAX(1,NVIR(ISYMA)) 1803 ELSE 1804 NTOTD = MAX(1,NVIR(ISYMD)) 1805 END IF 1806C 1807C TETAXJK(bcai) = TETAXJK(bcai) - xop(ad) tb0_jk(bcdi) 1808C 1809 IF (LAMP) THEN 1810 CALL DGEMM('N','T',NMATAB(ISYMBC),NVIR(ISYMA), 1811 * NVIR(ISYMD),-ONE,T0JK(KOFF1),NTOTBC, 1812 * WORK(KOFF2),NTOTA, 1813 * ONE,TETAXJK(KOFF3),NTOTBC) 1814 ELSE 1815 CALL DGEMM('N','N',NMATAB(ISYMBC),NVIR(ISYMA), 1816 * NVIR(ISYMD),-ONE,T0JK(KOFF1),NTOTBC, 1817 * WORK(KOFF2),NTOTD, 1818 * ONE,TETAXJK(KOFF3),NTOTBC) 1819 1820 END IF 1821C 1822 END DO 1823 END DO 1824 END DO 1825C 1826 CALL QEXIT('TETACB') 1827 RETURN 1828 END 1829C /* Deck wjk_ground */ 1830 SUBROUTINE WJK_GROUND(T30JK,ISYT30JK,T2TP, 1831 * ISYMT2,T3VIJG1, 1832 * ISYINT,ISYMJ,J,ISYMK,K, 1833 * WORK,LWORK) 1834 1835*********************************************************** 1836* T3VIJG1 : g(ck|bd) sitting as I(bcd,k) 1837* 1838* T30KL sitting as (bcai) 1839*********************************************************** 1840C 1841C T3X^(abc)_(iJK) = 1842C P(ai,bj,ck) (sum_d t^(ad)_(ij) (ck|bd) ) + 1843C - P(ai,bj,ck) (sum_l t^(ab)_(il) (ck|lj) ) 1844C 1845C In this routine we calculate the first contribution in terms of 1846C W intermediate: 1847C 1848C W^JK(bcai) = W^JK(bcai) 1849C 1850C 1) + t^ad_ij (ck|bd) 1851C 1852C 4) + t^ad_ik (bj|cd) 1853C 1854C F. Pawlowski, 02-10-2003, Aarhus. 1855C 1856 IMPLICIT NONE 1857C 1858#include "priunit.h" 1859#include "ccsdsym.h" 1860#include "ccorb.h" 1861C 1862 INTEGER ISYT30JK, ISYMT2, ISYINT, ISYMJ, ISYMK, LWORK 1863 INTEGER ISYMDAI, ISYMBCD, ISYMDA, ISYMBC, ISYMBCA, ISYMDBI 1864 INTEGER ISYMACD, ISYMACBI, ISYMDB, ISYMAC, ISYMACB 1865 INTEGER ISYMJK, ISYMBD, ISYMCAI, ISYMDCI, ISYMBAD, ISYMBACI 1866 INTEGER ISYMDC, ISYMBA, ISYMBAC, ISYMKJ, ISYMCD, ISYMCBAI 1867 INTEGER ISYMI, ISYMD, ISYMA, ISYMB, ISYMC 1868 INTEGER NTOTBC, NTOTD, NTOTAC, NTOTB, NTOTBA, NTOTC 1869 INTEGER KDAI, KBCD, KEND1, LWRK1, KDBI, KACD, KACBI, KBD 1870 INTEGER KDCI, KBAD, KBACI, KCD, KCBAI 1871 INTEGER KOFF1, KOFF2, KOFF3 1872 INTEGER ISYMBAI 1873 INTEGER KBCAI,KTEMP,KEND2,LWRK2 1874 INTEGER KDCAI,KDBAI 1875 integer isyabc 1876C 1877#if defined (SYS_CRAY) 1878 REAL T30JK(*), T2TP(*), T3VIJG1(*), WORK(LWORK) 1879 REAL ONE 1880 real xnormval,ddot 1881#else 1882 DOUBLE PRECISION T30JK(*), T2TP(*), T3VIJG1(*), WORK(LWORK) 1883 DOUBLE PRECISION ONE 1884 double precision xnormval,ddot 1885#endif 1886C 1887 PARAMETER (ONE = 1.0D0) 1888C 1889 CALL QENTER('WJKGR') 1890C 1891C*************************************************** 1892C 1) t^ad_ij * (ck|bd) 1893C*************************************************** 1894C 1895C t2tp(djia) = I^J(dai) 1896C 1897C (ck|bd) = I(bcd,k) = I^K(bcd) 1898C 1899C W^JK(bcai) = W^JK(bcai) + I^K(bcd)*I^J(dai) 1900C 1901C symmetry and work allocation 1902C 1903 1904 ISYMDAI = MULD2H(ISYMT2,ISYMJ) 1905 ISYMBCD = MULD2H(ISYINT,ISYMK) 1906C 1907 KDAI = 1 1908 KEND1 = KDAI + NMAABI(ISYMDAI) 1909 LWRK1 = LWORK - KEND1 1910C 1911 IF (LWRK1 .LT. 0) THEN 1912 WRITE(LUPRI,*) 'Memory available : ',LWORK 1913 WRITE(LUPRI,*) 'Memory needed : ',KEND1 1914 CALL QUIT('Insufficient space in WJK_GROUND (1)') 1915 END IF 1916C 1917C sort t^ad_ij = t2tp(djia) as I^J(dai) 1918C 1919 CALL SORT_T2_ABJ(WORK(KDAI),ISYMJ,J,T2TP,ISYMT2) 1920C 1921C T^JK(bcai) = T^JK(bcai) + I^K(bcd)*I^J(dai) 1922C 1923 DO ISYMI = 1,NSYM 1924 ISYMDA = MULD2H(ISYMDAI,ISYMI) 1925 DO I = 1,NRHF(ISYMI) 1926 DO ISYMD = 1,NSYM 1927 ISYMBC = MULD2H(ISYMBCD,ISYMD) 1928 ISYMA = MULD2H(ISYMDA,ISYMD) 1929 ISYMBCA = MULD2H(ISYMBC,ISYMA) 1930 KOFF1 = 1 + IMAABCI(ISYMBCD,ISYMK) 1931 * + NMAABC(ISYMBCD)*(K-1) 1932 * + IMAABC(ISYMBC,ISYMD) 1933 KOFF2 = KDAI 1934 * + IMAABI(ISYMDA,ISYMI) 1935 * + NMATAB(ISYMDA)*(I-1) 1936 * + IMATAB(ISYMD,ISYMA) 1937 KOFF3 = 1 + IMAABCI(ISYMBCA,ISYMI) 1938 * + NMAABC(ISYMBCA)*(I-1) 1939 * + IMAABC(ISYMBC,ISYMA) 1940C 1941 NTOTBC = MAX(1,NMATAB(ISYMBC)) 1942 NTOTD = MAX(1,NVIR(ISYMD)) 1943C 1944C add_vir(1) 1945C 1946 CALL DGEMM('N','N',NMATAB(ISYMBC),NVIR(ISYMA), 1947 * NVIR(ISYMD),ONE,T3VIJG1(KOFF1),NTOTBC, 1948 * WORK(KOFF2),NTOTD, 1949 * ONE,T30JK(KOFF3),NTOTBC) 1950 END DO 1951 END DO 1952 END DO 1953C 1954C**************************************************** 1955C 4) + t^ad_ik (bj|cd) 1956C**************************************************** 1957C 1958C t2tp(dkia) = I^K(dai) 1959C 1960C (bj|cd) = I(cbdj) = I^J(cbd) 1961C 1962C T^JK(bcai) = T^JK(bcai) + I^J(bcd)*I^K(dai) 1963C 1964C symmetry and work allocation 1965C 1966 ISYMDAI = MULD2H(ISYMT2,ISYMK) 1967 ISYMBCD = MULD2H(ISYINT,ISYMJ) 1968C 1969 KDAI = 1 1970 KEND1 = KDAI + NMAABI(ISYMDAI) 1971 LWRK1 = LWORK - KEND1 1972C 1973 KCBAI = KEND1 1974 KEND1 = KCBAI + NMAABCI(ISYT30JK) 1975 LWRK1 = LWORK - KEND1 1976C 1977 IF (LWRK1 .LT. 0) THEN 1978 WRITE(LUPRI,*) 'Memory available : ',LWORK 1979 WRITE(LUPRI,*) 'Memory needed : ',KEND1 1980 CALL QUIT('Insufficient space in WJK_GROUND (4)') 1981 END IF 1982C 1983 CALL DZERO(WORK(KCBAI),NMAABCI(ISYT30JK)) 1984C 1985C t2tp(dkia) = I^K(dai) 1986C 1987 CALL SORT_T2_ABJ(WORK(KDAI),ISYMK,K,T2TP,ISYMT2) 1988C 1989C T^JK(bcai) = T^JK(bcai) + I^K(cbd)*I^J(dai) 1990C 1991 DO ISYMI = 1,NSYM 1992 ISYMDA = MULD2H(ISYMDAI,ISYMI) 1993 DO I = 1,NRHF(ISYMI) 1994 DO ISYMD = 1,NSYM 1995 ISYMBC = MULD2H(ISYMBCD,ISYMD) 1996 ISYMA = MULD2H(ISYMDA,ISYMD) 1997 ISYMBCA = MULD2H(ISYMBC,ISYMA) 1998 KOFF1 = 1 + IMAABCI(ISYMBCD,ISYMJ) 1999 * + NMAABC(ISYMBCD)*(J-1) 2000 * + IMAABC(ISYMBC,ISYMD) 2001 KOFF2 = KDAI 2002 * + IMAABI(ISYMDA,ISYMI) 2003 * + NMATAB(ISYMDA)*(I-1) 2004 * + IMATAB(ISYMD,ISYMA) 2005 KOFF3 = KCBAI + IMAABCI(ISYMBCA,ISYMI) 2006 * + NMAABC(ISYMBCA)*(I-1) 2007 * + IMAABC(ISYMBC,ISYMA) 2008C 2009 NTOTBC = MAX(1,NMATAB(ISYMBC)) 2010 NTOTD = MAX(1,NVIR(ISYMD)) 2011C 2012C add_vir(4) 2013C 2014 CALL DGEMM('N','N',NMATAB(ISYMBC),NVIR(ISYMA), 2015 * NVIR(ISYMD),ONE,T3VIJG1(KOFF1),NTOTBC, 2016 * WORK(KOFF2),NTOTD, 2017 * ONE,WORK(KOFF3),NTOTBC) 2018 END DO 2019 END DO 2020 END DO 2021C 2022 !put W(cbai) to W(bcai) 2023 CALL FBACI(T30JK,WORK(KCBAI),ISYT30JK) 2024C 2025 CALL QEXIT('WJKGR') 2026C 2027 RETURN 2028 END 2029C /* Deck tetax_jk_bc_cub */ 2030 SUBROUTINE TETAX_JK_BC_CUB(LAMP,LMUL,IOPT,T0JK,IST0JK,XOP,ISYMXOP, 2031 * TETAXJK,ISTETAXJK,WORK,LWORK) 2032C 2033C TETAXJK(bcai) = TETAXJK(bcai) 2034C 2035C - xop(bd) t0_jk(dcai) (1) 2036C 2037C - xop(cd) t0_jk(bdai) (2) 2038C 2039C IOPT = 1 : calculate only term (1) 2040C IOPT = 2 : calculate both terms 2041C IOPT = 3 : calculate only term (2) 2042C 2043C LAMP = .TRUE. : carry out amplitudes-like transformations 2044C LMUL = .TRUE. : carry out multipliers-like transformations 2045 2046 IMPLICIT NONE 2047C 2048 LOGICAL LAMP,LMUL 2049 INTEGER IOPT 2050 INTEGER IST0JK, ISYMXOP, ISTETAXJK, LWORK 2051 INTEGER KAD, KEND1, LWRK1, KOFF1, KOFF2, KOFF3 2052 INTEGER ISYMI, ISYMBD, ISYMBDA, ISYMD, ISYMA 2053 INTEGER ISYMC, ISYMBCA, ISYMBC 2054 INTEGER ISYMB, ISYMDCA, ISYMDC 2055 2056 INTEGER NTOTC, NTOTB, NTOTD 2057C 2058#if defined (SYS_CRAY) 2059 REAL TB0JK(*), TETAXJK(*), XOP(*), WORK(LWORK) 2060 REAL ONE 2061 real ddot,xnormval 2062#else 2063 DOUBLE PRECISION T0JK(*), TETAXJK(*), XOP(*), WORK(LWORK) 2064 DOUBLE PRECISION ONE 2065 double precision ddot,xnormval 2066#endif 2067C 2068 PARAMETER (ONE = 1.0D0) 2069C 2070#include "priunit.h" 2071#include "ccsdsym.h" 2072#include "ccorb.h" 2073#include "ccsdinp.h" 2074C 2075 CALL QENTER('TETJKCB') 2076C 2077 !initial test of logic 2078 IF (LAMP .EQV. LMUL) THEN 2079 WRITE(LUPRI,*)'LAMP = ', LAMP 2080 WRITE(LUPRI,*)'LMUL = ', LMUL 2081 WRITE(LUPRI,*)'LAMP and LMUL must have opposite values ' 2082 CALL QUIT('Logic fault in TETAX_JK_BC_CUB') 2083 END IF 2084C 2085 KAD = 1 2086 KEND1 = KAD + NMATAB(ISYMXOP) 2087 LWRK1 = LWORK - KEND1 2088C 2089 IF (LWRK1 .LT. 0) THEN 2090 WRITE(LUPRI,*) 'Memory available : ',LWRK1 2091 WRITE(LUPRI,*) 'Memory needed : ',KEND1 2092 CALL QUIT('Insufficient space in TETAX_JK_BC_CUB') 2093 END IF 2094C 2095C SORT VIR-VIR XOP ELEMENTS (A,D) 2096C 2097C 2098 DO ISYMD = 1,NSYM 2099 ISYMA = MULD2H(ISYMD,ISYMXOP) 2100 DO D = 1,NVIR(ISYMD) 2101 KOFF1 = IFCVIR(ISYMA,ISYMD) + NORB(ISYMA)*(D - 1) 2102 * + NRHF(ISYMA) + 1 2103 KOFF2 = KAD + IMATAB(ISYMA,ISYMD) + NVIR(ISYMA)*(D - 1) 2104 CALL DCOPY(NVIR(ISYMA),XOP(KOFF1),1,WORK(KOFF2),1) 2105 END DO 2106 END DO 2107 2108 IF (IOPT .GE. 2) THEN 2109C 2110C TETAXJK(bcai) = TETAXJK(bcai) - xop(cd) t0_jk(bdai) (term 2) 2111C 2112 DO ISYMI = 1,NSYM 2113 ISYMBDA = MULD2H(IST0JK,ISYMI) 2114 DO ISYMA = 1,NSYM 2115 ISYMBD = MULD2H(ISYMBDA,ISYMA) 2116 DO ISYMD = 1,NSYM 2117 ISYMC = MULD2H(ISYMD,ISYMXOP) 2118 ISYMB = MULD2H(ISYMBD,ISYMD) 2119 ISYMBC = MULD2H(ISYMB,ISYMC) 2120 ISYMBCA = MULD2H(ISYMBC,ISYMA) 2121 DO I = 1,NRHF(ISYMI) 2122 DO A = 1,NVIR(ISYMA) 2123C 2124 KOFF1 = 1 2125 * + IMAABCI(ISYMBDA,ISYMI) 2126 * + NMAABC(ISYMBDA)*(I-1) 2127 * + IMAABC(ISYMBD,ISYMA) 2128 * + NMATAB(ISYMBD)*(A-1) 2129 * + IMATAB(ISYMB,ISYMD) 2130C 2131 IF (LAMP) THEN 2132 KOFF2 = KAD 2133 * + IMATAB(ISYMC,ISYMD) 2134 ELSE 2135 KOFF2 = KAD 2136 * + IMATAB(ISYMD,ISYMC) 2137 END IF 2138C 2139 KOFF3 = 1 2140 * + IMAABCI(ISYMBCA,ISYMI) 2141 * + NMAABC(ISYMBCA)*(I-1) 2142 * + IMAABC(ISYMBC,ISYMA) 2143 * + NMATAB(ISYMBC)*(A-1) 2144 * + IMATAB(ISYMB,ISYMC) 2145C 2146 NTOTB = MAX(1,NVIR(ISYMB)) 2147C 2148 IF (LAMP) THEN 2149 NTOTC = MAX(1,NVIR(ISYMC)) 2150 ELSE 2151 NTOTD = MAX(1,NVIR(ISYMD)) 2152 END IF 2153C 2154C TETAXJK(bcai) = TETAXJK(bcai) - xop(cd) t0_jk(bdai) 2155C 2156 IF (LAMP) THEN 2157 CALL DGEMM('N','T',NVIR(ISYMB),NVIR(ISYMC), 2158 * NVIR(ISYMD),-ONE,T0JK(KOFF1),NTOTB, 2159 * WORK(KOFF2),NTOTC, 2160 * ONE,TETAXJK(KOFF3),NTOTB) 2161 ELSE 2162 CALL DGEMM('N','N',NVIR(ISYMB),NVIR(ISYMC), 2163 * NVIR(ISYMD),-ONE,T0JK(KOFF1),NTOTB, 2164 * WORK(KOFF2),NTOTD, 2165 * ONE,TETAXJK(KOFF3),NTOTB) 2166 END IF 2167C 2168 END DO 2169 END DO 2170 END DO 2171 END DO 2172 END DO 2173C 2174 END IF 2175C 2176 IF (IOPT .LE. 2) THEN 2177 2178C 2179C TETAXJK(bcai) = TETAXJK(bcai) - xop(bd) t0_jk(dcai) (term 1) 2180C 2181 DO ISYMI = 1,NSYM 2182 ISYMDCA = MULD2H(IST0JK,ISYMI) 2183 DO ISYMA = 1,NSYM 2184 ISYMDC = MULD2H(ISYMDCA,ISYMA) 2185 DO ISYMC = 1,NSYM 2186 ISYMD = MULD2H(ISYMDC,ISYMC) 2187 ISYMB = MULD2H(ISYMD,ISYMXOP) 2188 ISYMBC = MULD2H(ISYMB,ISYMC) 2189 ISYMBCA = MULD2H(ISYMBC,ISYMA) 2190 DO I = 1,NRHF(ISYMI) 2191 DO A = 1,NVIR(ISYMA) 2192C 2193 IF (LAMP) THEN 2194 KOFF1 = KAD 2195 * + IMATAB(ISYMB,ISYMD) 2196 ELSE 2197 KOFF1 = KAD 2198 * + IMATAB(ISYMD,ISYMB) 2199 END IF 2200C 2201 KOFF2 = 1 2202 * + IMAABCI(ISYMDCA,ISYMI) 2203 * + NMAABC(ISYMDCA)*(I-1) 2204 * + IMAABC(ISYMDC,ISYMA) 2205 * + NMATAB(ISYMDC)*(A-1) 2206 * + IMATAB(ISYMD,ISYMC) 2207 KOFF3 = 1 2208 * + IMAABCI(ISYMBCA,ISYMI) 2209 * + NMAABC(ISYMBCA)*(I-1) 2210 * + IMAABC(ISYMBC,ISYMA) 2211 * + NMATAB(ISYMBC)*(A-1) 2212 * + IMATAB(ISYMB,ISYMC) 2213C 2214 NTOTB = MAX(1,NVIR(ISYMB)) 2215 NTOTD = MAX(1,NVIR(ISYMD)) 2216C 2217C TETAXJK(bcai) = TETAXJK(bcai) - xop(bd) t0_jk(dcai) 2218C 2219 IF (LAMP) THEN 2220 CALL DGEMM('N','N',NVIR(ISYMB),NVIR(ISYMC), 2221 * NVIR(ISYMD),-ONE,WORK(KOFF1),NTOTB, 2222 * T0JK(KOFF2),NTOTD, 2223 * ONE,TETAXJK(KOFF3),NTOTB) 2224 ELSE 2225 CALL DGEMM('T','N',NVIR(ISYMB),NVIR(ISYMC), 2226 * NVIR(ISYMD),-ONE,WORK(KOFF1),NTOTD, 2227 * T0JK(KOFF2),NTOTD, 2228 * ONE,TETAXJK(KOFF3),NTOTB) 2229 END IF 2230C 2231 END DO 2232 END DO 2233 END DO 2234 END DO 2235 END DO 2236C 2237 END IF 2238C 2239 CALL QEXIT('TETJKCB') 2240 RETURN 2241 END 2242C /* Deck aden_dab_lm_cub */ 2243 SUBROUTINE ADEN_DAB_LM_CUB(IOPT,DAB,THLM,ISYMTHLM,WLM, 2244 * ISYMWLM, 2245 * WORK,LWORK) 2246C 2247 IMPLICIT NONE 2248#include "priunit.h" 2249#include "dummy.h" 2250#include "ccsdsym.h" 2251#include "ccorb.h" 2252C 2253 INTEGER IOPT 2254 INTEGER ISYMTHLM,ISYMWLM,LWORK 2255 INTEGER ISYMN,ISYMDEB,ISYMDEA,ISYMB,ISYMDE,ISYMA 2256 INTEGER KOFF1,KOFF2,KOFF3 2257 INTEGER NTOTDE,NTOTA 2258 INTEGER KWDAEN,KTHDBEN,KEND1,LWRK1 2259 INTEGER ISYMDBE,ISYMDAE,ISYME,ISYMDB,ISYMDA,ISYMEN,ISYMD 2260 INTEGER NTOTD 2261 INTEGER ISYMEDN,NTOTB 2262C 2263#if defined (SYS_CRAY) 2264 REAL DAB(*),THLM(*),WLM(*) 2265 REAL ONE,HALF 2266 REAL WORK(LWORK) 2267#else 2268 DOUBLE PRECISION DAB(*),THLM(*),WLM(*) 2269 DOUBLE PRECISION ONE,HALF 2270 DOUBLE PRECISION WORK(LWORK) 2271#endif 2272C 2273 PARAMETER (HALF = 0.5D0, ONE = 1.0D0) 2274C 2275 CALL QENTER('DABLMCB') 2276C 2277 IF (IOPT .GT. 3) 2278 * CALL QUIT('Wrong IOPT value in ADEN_DAB_LM_CUB') 2279C 2280 IF ((IOPT .EQ. 1) .OR. (IOPT .EQ. 2)) THEN 2281 2282C 2283C D(ab) = W^LM(dean) * THETA^LM(debn) 2284C 2285 DO ISYMN = 1,NSYM 2286 ISYMDEB = MULD2H(ISYMTHLM,ISYMN) 2287 ISYMDEA = MULD2H(ISYMWLM,ISYMN) 2288 DO ISYMB = 1,NSYM 2289 ISYMDE = MULD2H(ISYMDEB,ISYMB) 2290 ISYMA = MULD2H(ISYMDEA,ISYMDE) 2291 DO N = 1,NRHF(ISYMN) 2292C 2293 KOFF1 = IMAABCI(ISYMDEA,ISYMN) 2294 * + NMAABC(ISYMDEA)*(N-1) 2295 * + IMAABC(ISYMDE,ISYMA) 2296 * + 1 2297 KOFF2 = IMAABCI(ISYMDEB,ISYMN) 2298 * + NMAABC(ISYMDEB)*(N-1) 2299 * + IMAABC(ISYMDE,ISYMB) 2300 * + 1 2301 KOFF3 = IMATAB(ISYMA,ISYMB) + 1 2302C 2303 NTOTDE = MAX(NMATAB(ISYMDE),1) 2304 NTOTA = MAX(NVIR(ISYMA),1) 2305C 2306 CALL DGEMM('T','N',NVIR(ISYMA),NVIR(ISYMB), 2307 * NMATAB(ISYMDE),-HALF,WLM(KOFF1),NTOTDE, 2308 * THLM(KOFF2),NTOTDE,ONE,DAB(KOFF3),NTOTA) 2309C 2310 END DO ! N 2311 END DO ! ISYMB 2312 END DO ! ISYMN 2313C 2314 END IF 2315C 2316 IF ((IOPT .EQ. 2).OR.(IOPT .EQ. 3)) THEN 2317C 2318C Calculate second contribution to D(ab) 2319C 2320 KWDAEN = 1 2321 KTHDBEN = KWDAEN + NMAABCI(ISYMWLM) 2322 KEND1 = KTHDBEN + NMAABCI(ISYMTHLM) 2323 LWRK1 = LWORK - KEND1 2324C 2325 IF (LWRK1 .LT. 0) THEN 2326 WRITE(LUPRI,*) 'Memory available : ',LWORK 2327 WRITE(LUPRI,*) 'Memory needed : ',KEND1 2328 CALL QUIT('Insufficient space in ADEN_DAB_LM_CUB') 2329 END IF 2330C 2331 CALL DZERO(WORK(KWDAEN),NMAABCI(ISYMWLM)) 2332 CALL DZERO(WORK(KTHDBEN),NMAABCI(ISYMTHLM)) 2333 2334 !Sort W^LM(dean) to W^LM(daen) 2335 CALL FACBI(WORK(KWDAEN),WLM,ISYMWLM) 2336 2337 !Sort THETA^LM(debn) to THETA^LM(dben) 2338 CALL FACBI(WORK(KTHDBEN),THLM,ISYMTHLM) 2339C 2340C D(ab) = W^LM(daen) * THETA^LM(dben) 2341C 2342 DO ISYMN = 1,NSYM 2343 ISYMDEB = MULD2H(ISYMTHLM,ISYMN) 2344 ISYMDEA = MULD2H(ISYMWLM,ISYMN) 2345 DO ISYMB = 1,NSYM 2346 ISYMDE = MULD2H(ISYMDEB,ISYMB) 2347 ISYMA = MULD2H(ISYMDEA,ISYMDE) 2348 DO N = 1,NRHF(ISYMN) 2349C 2350 KOFF1 = IMAABCI(ISYMDEA,ISYMN) 2351 * + NMAABC(ISYMDEA)*(N-1) 2352 * + IMAABC(ISYMDE,ISYMA) 2353 * + KWDAEN 2354 KOFF2 = IMAABCI(ISYMDEB,ISYMN) 2355 * + NMAABC(ISYMDEB)*(N-1) 2356 * + IMAABC(ISYMDE,ISYMB) 2357 * + KTHDBEN 2358 KOFF3 = IMATAB(ISYMA,ISYMB) + 1 2359C 2360 NTOTDE = MAX(NMATAB(ISYMDE),1) 2361 NTOTA = MAX(NVIR(ISYMA),1) 2362C 2363 CALL DGEMM('T','N',NVIR(ISYMA),NVIR(ISYMB), 2364 * NMATAB(ISYMDE),-ONE,WORK(KOFF1),NTOTDE, 2365 * WORK(KOFF2),NTOTDE,ONE,DAB(KOFF3),NTOTA) 2366C 2367 END DO ! N 2368 END DO ! ISYMB 2369 END DO ! ISYMN 2370C 2371 END IF 2372C 2373 IF (IOPT .EQ. 0) THEN 2374C 2375 KWDAEN = 1 2376 KTHDBEN = KWDAEN + NMAABCI(ISYMWLM) 2377 KEND1 = KTHDBEN + NMAABCI(ISYMTHLM) 2378 LWRK1 = LWORK - KEND1 2379C 2380 IF (LWRK1 .LT. 0) THEN 2381 WRITE(LUPRI,*) 'Memory available : ',LWORK 2382 WRITE(LUPRI,*) 'Memory needed : ',KEND1 2383 CALL QUIT('Insufficient space in ADEN_DAB_LM_CUB (2)') 2384 END IF 2385C 2386 CALL DZERO(WORK(KWDAEN),NMAABCI(ISYMWLM)) 2387 CALL DZERO(WORK(KTHDBEN),NMAABCI(ISYMTHLM)) 2388 2389 !Sort W^LM(aedn) to W^LM(a,edn) 2390 CALL FA_BCI(WORK(KWDAEN),WLM,ISYMWLM,2) 2391 2392 !Sort THETA^LM(bedn) to THETA^LM(b,edn) 2393 CALL FA_BCI(WORK(KTHDBEN),THLM,ISYMTHLM,2) 2394 2395C 2396C D(ab) = W^LM(aedn) * THETA^LM(bedn) 2397C 2398 DO ISYMEDN = 1,NSYM 2399 ISYMB = MULD2H(ISYMTHLM,ISYMEDN) 2400 ISYMA = MULD2H(ISYMWLM,ISYMEDN) 2401C 2402 KOFF1 = IMAAOBCI(ISYMA,ISYMEDN) 2403 * + KWDAEN 2404 KOFF2 = IMAAOBCI(ISYMB,ISYMEDN) 2405 * + KTHDBEN 2406 KOFF3 = IMATAB(ISYMA,ISYMB) + 1 2407C 2408 NTOTB = MAX(NVIR(ISYMB),1) 2409 NTOTA = MAX(NVIR(ISYMA),1) 2410C 2411 CALL DGEMM('N','T',NVIR(ISYMA),NVIR(ISYMB), 2412 * NMAABI(ISYMEDN),-ONE,WORK(KOFF1),NTOTA, 2413 * WORK(KOFF2),NTOTB,ONE,DAB(KOFF3),NTOTA) 2414C 2415 END DO ! ISYMEDN 2416C 2417 END IF 2418C 2419 CALL QEXIT('DABLMCB') 2420C 2421 RETURN 2422 END 2423C /* Deck cc3_adenvir_cub */ 2424 SUBROUTINE CC3_ADENVIR_CUB(DIJ,DAB,DIA,ISYDEN,LISTL,IDLSTL,LISTR, 2425 * IDLSTR, 2426 * LUTOC,FNTOC,LU3VI,FN3VI,LU3VI2,FN3VI2, 2427 * LUDKBC3,FNDKBC3, 2428 * LU3FOPX,FN3FOPX,LU3FOP2X,FN3FOP2X, 2429 * LU3FOP,FN3FOP,LU3FOP2,FN3FOP2, 2430 * LUCKJD,FNCKJD,LUDKBC,FNDKBC,LUDELD,FNDELD, 2431 * WORK,LWORK) 2432*---------------------------------------------------------------------* 2433* 2434* Calculate these terms to A density for cubic reponse that 2435* should be calculated for 2 fixed virtual indeces. 2436* 2437* (see comments in this routines for the formulas) 2438* 2439* Written by Filip Pawlowski, Fall 2003, Aarhus 2440* 2441*=====================================================================* 2442C 2443 IMPLICIT NONE 2444C 2445#include "priunit.h" 2446#include "dummy.h" 2447#include "iratdef.h" 2448#include "ccsdsym.h" 2449#include "ccorb.h" 2450#include "ccsdinp.h" 2451#include "ccinftap.h" 2452#include "inftap.h" 2453#include "cc3t3d.h" 2454#include "ccl1rsp.h" 2455#include "ccr1rsp.h" 2456#include "cclrmrsp.h" 2457#include "ccexci.h" 2458#include "ccr2rsp.h" 2459#include "ccer1rsp.h" 2460 2461C 2462 INTEGER ISYM0 2463 PARAMETER(ISYM0 = 1) 2464 CHARACTER LISTL0*3, LISTL*3,LISTR*3,LISTL1R*3,LABELL1*8,LABELRZ*8 2465 CHARACTER LABELRU*8 2466 CHARACTER LISTRZ*3,LISTRU*3 2467 CHARACTER*(*) FNTOC, FN3VI, FNDKBC3, FN3FOPX, FN3FOP2X 2468 CHARACTER*(*) FNDKBC,FNDELD,FN3VI2,FN3FOP,FN3FOP2,FNCKJD 2469C 2470 CHARACTER*10 FNT3, FNWBMAT,FNWBZU 2471 CHARACTER*14 FNTHETA,FNWZU 2472 PARAMETER(FNT3 = 'CC3_T3_TMP', FNWBMAT = 'CC3_W3_TMP', 2473 * FNWBZU = 'CC3_WZUTMP', 2474 * FNTHETA = 'CC3_THETA3_TMP',FNWZU = 'CC3_WZU____TMP') 2475C 2476 CHARACTER*14 FN3SRTR, FNCKJDRZ, FNDELDRZ, FNDKBCRZ 2477 PARAMETER(FN3SRTR = 'CCSDT_FBMAT1_Z',FNCKJDRZ = 'CCSDT_FBMAT2_Z', 2478 * FNDELDRZ = 'CCSDT_FBMAT3_Z',FNDKBCRZ = 'CCSDT_FBMAT4_Z') 2479 INTEGER LU3SRTR, LUCKJDRZ, LUDELDRZ, LUDKBCRZ 2480C 2481 CHARACTER*14 FNCKJDRU, FNDELDRU, FNDKBCRU 2482 PARAMETER(FNCKJDRU = 'CCSDT_FBMAT2_U', 2483 * FNDELDRU = 'CCSDT_FBMAT3_U',FNDKBCRU = 'CCSDT_FBMAT4_U') 2484 INTEGER LUCKJDRU, LUDELDRU, LUDKBCRU 2485C 2486 ![[H,T1Z],T1U] 2487 CHARACTER*14 FNCKJDRZU, FNDELDRZU, FNDKBCRZU 2488 PARAMETER(FNCKJDRZU ='CCSDT_FBMAT2ZU', 2489 * FNDELDRZU ='CCSDT_FBMAT3ZU',FNDKBCRZU ='CCSDT_FBMAT4ZU') 2490 INTEGER LUCKJDRZU, LUDELDRZU, LUDKBCRZU 2491C 2492 ![H,T1ZU] 2493 CHARACTER*14 FNCKJDR2, FNDELDR2, FNDKBCR2 2494 PARAMETER(FNCKJDR2 = 'CCSDT_FBMAT2R2', 2495 * FNDELDR2 = 'CCSDT_FBMAT3R2',FNDKBCR2 = 'CCSDT_FBMAT4R2') 2496 INTEGER LUCKJDR2, LUDELDR2, LUDKBCR2 2497C 2498C 2499 INTEGER LUTOC, LU3VI, LUDKBC3, LU3FOPX, LU3FOP2X 2500 INTEGER LUDKBC,LUDELD,LU3VI2,LU3FOP,LU3FOP2,LUCKJD 2501 INTEGER LUT3,LUWBMAT,LUTHETA,LUWZU,LUWBZU 2502C 2503 LOGICAL LOCDBG,LORXL1 2504 LOGICAL LORXRZ,LORXRU 2505 PARAMETER (LOCDBG = .FALSE.) 2506C 2507 INTEGER AIBJCK_PERM 2508 LOGICAL QUADR 2509 LOGICAL CUBIC 2510 LOGICAL T2XNET2Y 2511 LOGICAL T2XNET2Z,NOVIRT 2512 LOGICAL LSKIPL1R 2513C 2514 CHARACTER CDUMMY*1 2515 PARAMETER (CDUMMY = ' ') 2516 2517 INTEGER ISYDEN,IDLSTL,IDLSTR,LWORK 2518C 2519 INTEGER IDLSTL0,IDLSTL1R 2520 INTEGER ISYML1,ISYML1R,ISYMRZ,ISYMRU 2521 INTEGER ISINT1,ISINT2 2522 INTEGER KLAMP0,KLAMH0,KFOCKD,KFOCK0CK,KT2TP,KL1AM,KL2TP 2523 INTEGER KEND0,LWRK0 2524 INTEGER KL1L1,KL2L1,KT1RZ,KT2RZ,KFOCK0,KFOCKL1,KFOCKRZ 2525 INTEGER KEND1,LWRK1 2526 INTEGER IOPT 2527 INTEGER ISINT1RZ,ISINT2RZ,ISINT2L1R,ISYFCKL1R 2528 INTEGER KXIAJB,KT3BOG1,KT3BOL1,KT3BOG2,KT3BOL2,KT3OG1,KT3OG2 2529 INTEGER KLAMPL1R,KLAMHL1R,KW3ZOGZ1,KFOCKL1RCK,KW3BXOG1 2530 INTEGER KW3BXOL1,KW3BXOGX1,KW3BXOLX1,KT1L1R,KT2L1R 2531 INTEGER KEND2,LWRK2 2532 INTEGER LENGTH 2533 INTEGER ISINT1L1R 2534 INTEGER ISYMD,ISYCKBD0,ISYCKBL1R,ISYCKBDR1Z 2535 INTEGER KT3VDG1,KT3VDG2,KT3VDG3,KT3BVDL1,KT3BVDL2,KT3BVDL3 2536 INTEGER KEND3,LWRK3 2537 INTEGER KT3BVDG1,KT3BVDG2,KT3BVDG3,KW3BXVDG1,KW3BXVDG2 2538 INTEGER KW3BXVDL1,KW3BXVDL2,KW3BXVDGX1,KW3BXVDGX2,KW3BXVDLX1 2539 INTEGER KW3BXVDLX2,KW3ZVDGZ1,KINTVI,KTRVI6 2540 INTEGER KEND4,LWRK4 2541 INTEGER IOFF 2542 INTEGER ISYMB,ISYALJB0,ISYALJD0,ISYALJBL1,ISYALJDL1,ISYMBD 2543 INTEGER ISCKIJ,ISWBMAT,ISWMATZ,ISYCKD,ISYCKDBR1Z 2544 INTEGER KSMAT2,KUMAT2,KDIAG,KDIAGWB,KDIAGWZ,KINDSQ,KINDSQWB 2545 INTEGER KINDSQWZ,KINDEX,KINDEX2,KINDEXBL1,KINDEXDL1,KTMAT 2546 INTEGER KT3MAT,KW3BMAT,KW3MATZ,KWTEMP,KS3MAT,KU3MAT,KS3MAT3 2547 INTEGER KU3MAT3,KT3VBG1,KT3VBG2,KT3VBG3,KT3BVBG1,KT3BVBG2 2548 INTEGER KT3BVBG3,KSMAT4,KUMAT4,KT3BVBL1,KT3BVBL2,KT3BVBL3 2549 INTEGER KW3ZVDGZ2 2550 INTEGER KEND5,LWRK5 2551 INTEGER LENSQ,LENSQWB,LENSQWZ 2552 INTEGER ISYML,ISYMDL,ISAIBJ,ISYMJ,ISYMBJ,ISYMAI,ISYAIL 2553 INTEGER KOFF1,NBJ,IADR 2554 INTEGER KDAB0,KDIJ0 2555 INTEGER KT3VBGZ3 2556 INTEGER IDLSTZU,IDLSTRZ,IDLSTRU 2557 INTEGER KT3VDGZ3,KFOCKRU,KWMATZU,KFCKUZO,KLAMDPZ,KLAMDHZ,KINDSQWZU 2558 INTEGER LENSQWZU,KDIAGWZU,ISYMZU,MAXX1,MAXX2,ISWMATZU 2559 INTEGER KW3MATU,ISWMATU,KINDSQWU,LENSQWU,KDIAGWU,KT2RU,KT1RU 2560 INTEGER KW3UVDGU1,KW3UVDGU2,KT3VBGU3,KT3VDGU3,KW3UOGU1 2561 INTEGER ISINT1RU,ISINT2RU,ISYCKBDR1U,MAXX3,ISYCKDBR1U 2562 INTEGER KFCKZUO,KLAMDPU,KLAMDHU 2563 INTEGER KWMATZUD 2564 INTEGER ISINT1RZU,ISINT2RZU,KW3ZUOGZU1,ISYCKBDR1ZU,KW3ZUVDGZU1 2565 INTEGER MAXX4,ISYCKDBR1ZU,KW3ZUVDGZU2,KT3VBGZU3,KT3VDGZU3 2566 INTEGER KT1ZU,KT2ZU 2567 INTEGER KWZUVDGR21,KWZUVDGR22,KWZUVBGR23,KWZUVDGR23,KWZUOGR21 2568 INTEGER ISINT1R2,ISINT2R2 2569 INTEGER KFCKZUV,KFCKUZV 2570C 2571 INTEGER IR1TAMP 2572 INTEGER ILSTSYM 2573C 2574 integer kx3am 2575C 2576 INTEGER FKW3BXVDG1,FKW3BXVDG2,FKW3BXVDL1,FKW3BXVDL2 2577 INTEGER FKW3BXVDGX1,FKW3BXVDGX2,FKW3BXVDLX1,FKW3BXVDLX2 2578 INTEGER ISYCKDL1R 2579 2580#if defined (SYS_CRAY) 2581 REAL FREQL1,FREQL1R,FREQRZ,FREQRU,FREQZU 2582 REAL WORK(LWORK) 2583 REAL XNORMVAL 2584 REAL DAB(*),DIJ(*),DIA(*) 2585 REAL DDOT,HALF,ONE 2586#else 2587 DOUBLE PRECISION FREQL1,FREQL1R,FREQRZ,FREQRU,FREQZU 2588 DOUBLE PRECISION WORK(LWORK) 2589 DOUBLE PRECISION XNORMVAL 2590 DOUBLE PRECISION DAB(*),DIJ(*),DIA(*) 2591 DOUBLE PRECISION DDOT,HALF,ONE 2592#endif 2593C 2594 PARAMETER(HALF = 0.5D0, ONE = 1.0D0) 2595C 2596 CALL QENTER('CC3DENVCB') 2597C-------------------------------- 2598C Open temporary files 2599C-------------------------------- 2600C 2601 LU3SRTR = -1 2602 LUCKJDRZ = -1 2603 LUDELDRZ = -1 2604 LUDKBCRZ = -1 2605C 2606 CALL WOPEN2(LU3SRTR,FN3SRTR,64,0) 2607 CALL WOPEN2(LUCKJDRZ,FNCKJDRZ,64,0) 2608 CALL WOPEN2(LUDELDRZ,FNDELDRZ,64,0) 2609 CALL WOPEN2(LUDKBCRZ,FNDKBCRZ,64,0) 2610C 2611 LUCKJDRU = -1 2612 LUDELDRU = -1 2613 LUDKBCRU = -1 2614C 2615 CALL WOPEN2(LUCKJDRU,FNCKJDRU,64,0) 2616 CALL WOPEN2(LUDELDRU,FNDELDRU,64,0) 2617 CALL WOPEN2(LUDKBCRU,FNDKBCRU,64,0) 2618C 2619 ![[H,T1Z],T1U] 2620 LUCKJDRZU = -1 2621 LUDELDRZU = -1 2622 LUDKBCRZU = -1 2623C 2624 CALL WOPEN2(LUCKJDRZU,FNCKJDRZU,64,0) 2625 CALL WOPEN2(LUDELDRZU,FNDELDRZU,64,0) 2626 CALL WOPEN2(LUDKBCRZU,FNDKBCRZU,64,0) 2627C 2628 ![H,T1ZU] 2629 LUCKJDR2 = -1 2630 LUDELDR2 = -1 2631 LUDKBCR2 = -1 2632C 2633 CALL WOPEN2(LUCKJDR2,FNCKJDR2,64,0) 2634 CALL WOPEN2(LUDELDR2,FNDELDR2,64,0) 2635 CALL WOPEN2(LUDKBCR2,FNDKBCR2,64,0) 2636C 2637C------------------------------------------------------------ 2638C some initializations: 2639C------------------------------------------------------------ 2640C 2641 LISTL0 = 'L0 ' 2642 IDLSTL0 = 0 2643 2644 IF (LISTL(1:3).EQ.'L1 ') THEN 2645 2646 ! get symmetry, frequency and integral label from common blocks 2647 ! defined in ccl1rsp.h 2648 ISYML1 = ISYLRZ(IDLSTL) 2649 FREQL1 = FRQLRZ(IDLSTL) 2650 LABELL1 = LRZLBL(IDLSTL) 2651 LORXL1 = LORXLRZ(IDLSTL) 2652c 2653 2654 IF (LORXL1) CALL QUIT('NO ORBITAL RELAX. IN CC3_ADENVIR_CUB') 2655 2656 LISTL1R = 'R1 ' 2657 IDLSTL1R = IR1TAMP(LABELL1,LORXL1,FREQL1,ISYML1) 2658 ! get symmetry and frequency from common blocks 2659 ! defined in ccl1rsp.h 2660 ISYML1R = ISYLRT(IDLSTL1R) 2661 FREQL1R = FRQLRT(IDLSTL1R) 2662C 2663 IF (ISYML1 .NE. ISYML1R) THEN 2664 WRITE(LUPRI,*)'ISYML1: ', ISYML1 2665 WRITE(LUPRI,*)'ISYML1R: ', ISYML1R 2666 CALL QUIT('Symmetry mismatch in CC3_ADENVIR_CUB') 2667 END IF 2668C 2669 IF (FREQL1R .NE. FREQL1) THEN 2670 WRITE(LUPRI,*)'FREQL1R: ', FREQL1R 2671 WRITE(LUPRI,*)'FREQL1: ', FREQL1 2672 CALL QUIT('Frequency mismatch in CC3_ADENVIR_CUB') 2673 END IF 2674C 2675 ELSE IF (LISTL(1:3).EQ.'LE ') THEN 2676 ISYML1 = ILSTSYM(LISTL,IDLSTL) 2677 FREQL1 = -EIGVAL(IDLSTL) 2678 LABELL1 = '- none -' 2679C 2680 !we don't have any "right" vector entering a right hand side 2681 LISTL1R = '---' 2682 IDLSTL1R = -99 2683 ISYML1R = IDUMMY 2684 FREQL1R = DUMMY 2685C 2686 ELSE 2687 CALL QUIT('Unknown left list in CC3_ADENVIR_CUB') 2688 END IF 2689 2690 IF (LISTR(1:3).EQ.'R2 ') THEN 2691 IDLSTZU = IDLSTR 2692 ! get symmetry, frequency and integral label for right list 2693 ! from common blocks defined in ccr1rsp.h 2694 LISTRZ = 'R1 ' 2695 LABELRZ = LBLR2T(IDLSTZU,1) 2696 ISYMRZ = ISYR2T(IDLSTZU,1) 2697 FREQRZ = FRQR2T(IDLSTZU,1) 2698 LORXRZ = LORXR2T(IDLSTZU,1) 2699 IDLSTRZ = IR1TAMP(LABELRZ,LORXRZ,FREQRZ,ISYMRZ) 2700 2701 LISTRU = 'R1 ' 2702 LABELRU = LBLR2T(IDLSTZU,2) 2703 ISYMRU = ISYR2T(IDLSTZU,2) 2704 FREQRU = FRQR2T(IDLSTZU,2) 2705 LORXRU = LORXR2T(IDLSTZU,2) 2706 IDLSTRU = IR1TAMP(LABELRU,LORXRU,FREQRU,ISYMRU) 2707C 2708 ELSE IF (LISTR(1:3).EQ.'ER1') THEN 2709 IDLSTZU = IDLSTR 2710C 2711 LISTRZ = 'R1 ' 2712 LABELRZ = lbler1(IDLSTZU) 2713 ISYMRZ = isyoer1(IDLSTZU) 2714 FREQRZ = frqer1(IDLSTZU) 2715 LORXRZ = lorxer1(IDLSTZU) 2716 IDLSTRZ = IR1TAMP(LABELRZ,LORXRZ,FREQRZ,ISYMRZ) 2717C 2718 LISTRU = 'RE ' 2719 LABELRU = '-- XX --' 2720 ISYMRU = isyser1(IDLSTZU) 2721 FREQRU = eiger1(IDLSTZU) 2722 LORXRU = .FALSE. 2723 IDLSTRU = ister1(IDLSTZU) 2724C 2725 ELSE 2726 WRITE(LUPRI,*)'LISTR = ',LISTR(1:3) 2727 WRITE(LUPRI,*)'CC3_ADENVIR_CUB is designed for LISTR = R2 or ER1' 2728 CALL QUIT('Unknown right list in CC3_ADENVIR_CUB') 2729 END IF 2730C 2731 IF (LORXRZ.OR.LORXRU) THEN 2732 CALL QUIT('Orbital relaxation not allowed in CC3_ADENVIR_CUB') 2733 END IF 2734C 2735 FREQZU = FREQRZ + FREQRU 2736C 2737C------------------------------------------------------- 2738C initial allocations, orbital energy, fock matrix and T2 and L2 : 2739C------------------------------------------------------- 2740C 2741C Symmetry of integrals in contraction: 2742C 2743 ISINT1 = ISYM0 2744 ISINT2 = ISYM0 2745 ISYMZU = MULD2H(ISYMRZ,ISYMRU) 2746C 2747 KLAMP0 = 1 2748 KLAMH0 = KLAMP0 + NLAMDT 2749 KFOCKD = KLAMH0 + NLAMDT 2750 KFOCK0CK = KFOCKD + NORBTS 2751 KT2TP = KFOCK0CK + NT1AMX 2752 KL1AM = KT2TP + NT2SQ(ISYM0) 2753 KL2TP = KL1AM + NT1AM(ISYM0) 2754 KEND0 = KL2TP + NT2SQ(ISYM0) 2755 LWRK0 = LWORK - KEND0 2756C 2757 KL1L1 = KEND0 2758 KL2L1 = KL1L1 + NT1AM(ISYML1) 2759 KT1RZ = KL2L1 + NT2SQ(ISYML1) 2760 KT2RZ = KT1RZ + NT1AM(ISYMRZ) 2761 KFOCK0 = KT2RZ + NT2SQ(ISYMRZ) 2762 KFOCKL1 = KFOCK0 + N2BST(ISYM0) 2763 KFOCKRZ = KFOCKL1 + N2BST(ISYML1) 2764 KEND1 = KFOCKRZ + N2BST(ISYMRZ) 2765 LWRK1 = LWORK - KEND1 2766C 2767 KT2RU = KEND1 2768 KT1RU = KT2RU + NT2SQ(ISYMRU) 2769 KEND1 = KT1RU + NT1AM(ISYMRU) 2770 LWRK1 = LWORK - KEND1 2771C 2772 KT2ZU = KEND1 2773 KEND1 = KT2ZU + NT2SQ(ISYMZU) 2774 LWRK1 = LWORK - KEND1 2775C 2776 KT1ZU = KEND1 2777 KEND1 = KT1ZU + NT1AM(ISYMZU) 2778 LWRK1 = LWORK - KEND1 2779C 2780 KFOCKRU = KEND1 2781 KEND1 = KFOCKRU + N2BST(ISYMRU) 2782 LWRK1 = LWORK - KEND1 2783C 2784 KFCKUZO = KEND1 2785 KFCKZUO = KFCKUZO + N2BST(ISYMZU) 2786 KFCKZUV = KFCKZUO + N2BST(ISYMZU) 2787 KFCKUZV = KFCKZUV + N2BST(ISYMZU) 2788 KEND1 = KFCKUZV + N2BST(ISYMZU) 2789C 2790 KDAB0 = KEND1 2791 KDIJ0 = KDAB0 + NMATAB(ISYML1) 2792 KEND1 = KDIJ0 + NMATIJ(ISYML1) 2793 LWRK1 = LWORK - KEND1 2794C 2795 KLAMDPZ = KEND1 2796 KLAMDHZ = KLAMDPZ + NLAMDT 2797 KLAMDPU = KLAMDHZ + NLAMDT 2798 KLAMDHU = KLAMDPU + NLAMDT 2799 KEND1 = KLAMDHU + NLAMDT 2800 LWRK1 = LWORK - KEND1 2801C 2802 IF (LWRK1 .LT. 0) THEN 2803 CALL QUIT('Out of memory in CC3_ADENVIR_CUB (00) ') 2804 END IF 2805C 2806 CALL DZERO(WORK(KDAB0),NMATAB(ISYML1)) 2807 CALL DZERO(WORK(KDIJ0),NMATIJ(ISYML1)) 2808C 2809C------------------------------------- 2810C Read in lamdap and lamdh 2811C------------------------------------- 2812C 2813 CALL GET_LAMBDA0(WORK(KLAMP0),WORK(KLAMH0),WORK(KEND1),LWRK1) 2814C 2815C--------------------------------------------------------------------- 2816C Read zeroth-order AO Fock matrix from file and trasform it to 2817C lambda basis 2818C--------------------------------------------------------------------- 2819C 2820 CALL GET_FOCK0(WORK(KFOCK0),WORK(KLAMP0),WORK(KLAMH0),WORK(KEND1), 2821 * LWRK1) 2822C 2823C--------------------------------------------------------------------- 2824C Read the matrix the property integrals and trasform it to lambda 2825C basis for L1 list and R1 list 2826C--------------------------------------------------------------------- 2827C 2828 IF (LISTL(1:3).EQ.'L1 ') THEN 2829 CALL GET_FOCKX(WORK(KFOCKL1),LABELL1,IDLSTL,ISYML1, 2830 * WORK(KLAMP0),ISYM0, 2831 * WORK(KLAMH0),ISYM0,WORK(KEND1),LWRK1) 2832 END IF 2833C 2834 ! FZ 2835 IF (LISTRZ(1:3).EQ.'R1 ') THEN 2836 CALL GET_FOCKX(WORK(KFOCKRZ),LABELRZ,IDLSTRZ,ISYMRZ, 2837 * WORK(KLAMP0),ISYM0, 2838 * WORK(KLAMH0),ISYM0,WORK(KEND1),LWRK1) 2839 END IF 2840 2841 ! FU 2842 IF (LISTRU(1:3).EQ.'R1 ') THEN 2843 CALL GET_FOCKX(WORK(KFOCKRU),LABELRU,IDLSTRU,ISYMRU, 2844 * WORK(KLAMP0),ISYM0, 2845 * WORK(KLAMH0),ISYM0,WORK(KEND1),LWRK1) 2846 END IF 2847C 2848C------------------------------------------ 2849C Calculate the [U,T1^Z] matrix 2850C Recall that we only need the occ-occ and vir-vir block. 2851C------------------------------------------ 2852C 2853 IF (LISTRU(1:3).EQ.'R1 ') THEN 2854 CALL GET_LAMBDAX(WORK(KLAMDPZ),WORK(KLAMDHZ),LISTRZ,IDLSTRZ, 2855 * ISYMRZ,WORK(KLAMP0),WORK(KLAMH0),WORK(KEND1), 2856 * LWRK1) 2857 ! get vir-vir block U_(c-,d) 2858 CALL GET_FOCKX(WORK(KFCKUZV),LABELRU,IDLSTRU,ISYMRU, 2859 * WORK(KLAMDPZ), 2860 * ISYMRZ,WORK(KLAMH0),ISYM0,WORK(KEND1),LWRK1) 2861 ! get occ-occ block U_(l,k-) 2862 CALL GET_FOCKX(WORK(KFCKUZO),LABELRU,IDLSTRU,ISYMRU, 2863 * WORK(KLAMP0), 2864 * ISYM0,WORK(KLAMDHZ),ISYMRZ,WORK(KEND1),LWRK1) 2865 END IF 2866C 2867C------------------------------------------ 2868C Calculate the [Z,T1^U] matrix 2869C Recall that we only need the occ-occ and vir-vir block. 2870C------------------------------------------ 2871C 2872 CALL GET_LAMBDAX(WORK(KLAMDPU),WORK(KLAMDHU),LISTRU,IDLSTRU, 2873 * ISYMRU,WORK(KLAMP0),WORK(KLAMH0),WORK(KEND1), 2874 * LWRK1) 2875 ! get vir-vir block Z_(c-,d) 2876 CALL GET_FOCKX(WORK(KFCKZUV),LABELRZ,IDLSTRZ,ISYMRZ,WORK(KLAMDPU), 2877 * ISYMRU,WORK(KLAMH0),ISYM0,WORK(KEND1),LWRK1) 2878 ! get occ-occ block Z_(l,k-) 2879 CALL GET_FOCKX(WORK(KFCKZUO),LABELRZ,IDLSTRZ,ISYMRZ,WORK(KLAMP0), 2880 * ISYM0,WORK(KLAMDHU),ISYMRU,WORK(KEND1),LWRK1) 2881 2882C 2883C------------------------------------- 2884C Read T2 amplitudes 2885C------------------------------------- 2886C 2887 IOPT = 2 2888 CALL GET_T1_T2(IOPT,.FALSE.,DUMMY,WORK(KT2TP),'R0',0,ISYM0, 2889 * WORK(KEND1),LWRK1) 2890C 2891 IF (LOCDBG) WRITE(LUPRI,*) 'Norm of T2TP ', 2892 * DDOT(NT2SQ(ISYM0),WORK(KT2TP),1,WORK(KT2TP),1) 2893C 2894C------------------------------------- 2895C Read L1 and L2 zeroth-order multipliers 2896C------------------------------------- 2897C 2898 IOPT = 3 2899 CALL GET_T1_T2(IOPT,.FALSE.,WORK(KL1AM),WORK(KL2TP),LISTL0, 2900 * IDLSTL0, 2901 * ISYM0,WORK(KEND1),LWRK1) 2902C 2903 IF (LOCDBG) WRITE(LUPRI,*) 'Norm of L2TP ', 2904 * DDOT(NT2SQ(ISYM0),WORK(KL2TP),1,WORK(KL2TP),1) 2905 2906C 2907C------------------------------------- 2908C Read L1L1 and L2L1 multipliers 2909C------------------------------------- 2910C 2911 IOPT = 3 2912 CALL GET_T1_T2(IOPT,.FALSE.,WORK(KL1L1),WORK(KL2L1),LISTL, 2913 * IDLSTL,ISYML1,WORK(KEND1),LWRK1) 2914C 2915C------------------------------------- 2916C Read T1Z and T2Z amplitudes 2917C------------------------------------- 2918C 2919 IOPT = 3 2920 CALL GET_T1_T2(IOPT,.TRUE.,WORK(KT1RZ),WORK(KT2RZ),LISTRZ, 2921 * IDLSTRZ,ISYMRZ,WORK(KEND1),LWRK1) 2922C 2923C------------------------------------- 2924C Read T1U and T2U amplitudes 2925C------------------------------------- 2926C 2927 IOPT = 3 2928 CALL GET_T1_T2(IOPT,.TRUE.,WORK(KT1RU),WORK(KT2RU),LISTRU, 2929 * IDLSTRU,ISYMRU,WORK(KEND1),LWRK1) 2930C 2931C------------------------------------------------------- 2932C Read in T1^ZU and T2^ZU !second-order amplitudes 2933C------------------------------------------------------- 2934C 2935 IOPT = 3 2936 CALL GET_T1_T2(IOPT,.TRUE.,WORK(KT1ZU),WORK(KT2ZU),LISTR,IDLSTR, 2937 * ISYMZU,WORK(KEND1),LWRK1) 2938C 2939C---------------------------------------- 2940C Integrals [H,T1Z] where Z is LISTRZ 2941C---------------------------------------- 2942C 2943 ISINT1RZ = MULD2H(ISINT1,ISYMRZ) 2944 ISINT2RZ = MULD2H(ISINT2,ISYMRZ) 2945C 2946 CALL CC3_BARINT(WORK(KT1RZ),ISYMRZ,WORK(KLAMP0), 2947 * WORK(KLAMH0),WORK(KEND1),LWRK1, 2948 * LU3SRTR,FN3SRTR,LUCKJDRZ,FNCKJDRZ) 2949C 2950 CALL CC3_SORT1(WORK(KEND1),LWRK1,2,ISINT1RZ,LU3SRTR,FN3SRTR, 2951 * LUDELDRZ,FNDELDRZ,IDUMMY,CDUMMY,IDUMMY,CDUMMY, 2952 * IDUMMY,CDUMMY) 2953C 2954 CALL CC3_SINT(WORK(KLAMH0),WORK(KEND1),LWRK1,ISINT1RZ, 2955 * LUDELDRZ,FNDELDRZ,LUDKBCRZ,FNDKBCRZ) 2956C 2957C---------------------------------------- 2958C Integrals [H,T1U] where U is LISTRU 2959C---------------------------------------- 2960C 2961 ISINT1RU = MULD2H(ISINT1,ISYMRU) 2962 ISINT2RU = MULD2H(ISINT2,ISYMRU) 2963C 2964 CALL CC3_BARINT(WORK(KT1RU),ISYMRU,WORK(KLAMP0), 2965 * WORK(KLAMH0),WORK(KEND1),LWRK1, 2966 * LU3SRTR,FN3SRTR,LUCKJDRU,FNCKJDRU) 2967C 2968 CALL CC3_SORT1(WORK(KEND1),LWRK1,2,ISINT1RU,LU3SRTR,FN3SRTR, 2969 * LUDELDRU,FNDELDRU,IDUMMY,CDUMMY,IDUMMY,CDUMMY, 2970 * IDUMMY,CDUMMY) 2971C 2972 CALL CC3_SINT(WORK(KLAMH0),WORK(KEND1),LWRK1,ISINT1RU, 2973 * LUDELDRU,FNDELDRU,LUDKBCRU,FNDKBCRU) 2974 2975C 2976C------------------------------------------------------ 2977C Calculate the (ck|de)-{Z,U}tilde and (ck|lm)-{Z,U}tilde 2978C (double one-index transformed with first-order amplitudes) 2979C------------------------------------------------------ 2980C 2981 ISINT1RZU = MULD2H(ISINT1,ISYMZU) 2982 ISINT2RZU = MULD2H(ISINT2,ISYMZU) 2983 2984 CALL CC3_3BARINT(ISYMRZ,LISTRZ,IDLSTRZ,ISYMRU,LISTRU,IDLSTRU, 2985 * IDUMMY,CDUMMY,IDUMMY,.FALSE., 2986 * WORK(KLAMP0),WORK(KLAMH0),WORK(KEND1),LWRK1, 2987 * LU3SRTR,FN3SRTR,LUCKJDRZU,FNCKJDRZU) 2988C 2989 CALL CC3_SORT1(WORK(KEND1),LWRK1,2,ISINT1RZU,LU3SRTR,FN3SRTR, 2990 * LUDELDRZU,FNDELDRZU,IDUMMY,CDUMMY,IDUMMY,CDUMMY, 2991 * IDUMMY,CDUMMY) 2992C 2993 CALL CC3_SINT(WORK(KLAMH0),WORK(KEND1),LWRK1,ISINT1RZU, 2994 * LUDELDRZU,FNDELDRZU,LUDKBCRZU,FNDKBCRZU) 2995 2996C 2997C---------------------------------------- 2998C Integrals [H,T1ZU] where ZU is LISTR 2999C (one-index transformed with second-order amplitudes) 3000C---------------------------------------- 3001C 3002 ISINT1R2 = MULD2H(ISINT1,ISYMZU) 3003 ISINT2R2 = MULD2H(ISINT2,ISYMZU) 3004C 3005 CALL CC3_BARINT(WORK(KT1ZU),ISYMZU,WORK(KLAMP0), 3006 * WORK(KLAMH0),WORK(KEND1),LWRK1, 3007 * LU3SRTR,FN3SRTR,LUCKJDR2,FNCKJDR2) 3008C 3009 CALL CC3_SORT1(WORK(KEND1),LWRK1,2,ISINT1R2,LU3SRTR,FN3SRTR, 3010 * LUDELDR2,FNDELDR2,IDUMMY,CDUMMY,IDUMMY,CDUMMY, 3011 * IDUMMY,CDUMMY) 3012C 3013 CALL CC3_SINT(WORK(KLAMH0),WORK(KEND1),LWRK1,ISINT1R2, 3014 * LUDELDR2,FNDELDR2,LUDKBCR2,FNDKBCR2) 3015C 3016C--------------------------------------------------------------- 3017C Read canonical orbital energies and delete frozen orbitals 3018C in Fock diagonal, if required 3019C--------------------------------------------------------------- 3020C 3021 CALL GET_ORBEN(WORK(KFOCKD),WORK(KEND1),LWRK1) 3022C 3023C-------------------------------------------- 3024C Sort the Fock matrix to get F(ck) block 3025C-------------------------------------------- 3026C 3027 CALL SORT_FOCKCK(WORK(KFOCK0CK),WORK(KFOCK0),ISYM0) 3028C 3029C---------------------------------------- 3030C If we want to sum the T3 amplitudes 3031C---------------------------------------- 3032C 3033 if (.false.) then 3034 kx3am = kend1 3035 kend1 = kx3am + nrhft*nrhft*nrhft*nvirt*nvirt*nvirt 3036 call dzero(work(kx3am),nrhft*nrhft*nrhft*nvirt*nvirt*nvirt) 3037 lwrk0 = lwork - kend1 3038 if (lwrk0 .lt. 0) then 3039 write(lupri,*) 'Memory available : ',lwork 3040 write(lupri,*) 'Memory needed : ',kend1 3041 call quit('Insufficient space (T3) in CC3_ADENVIR_CUB') 3042 END IF 3043 endif 3044C 3045C write(lupri,*) 'WBMAT after dzero' 3046C call print_pt3(work(kx3am),ISYML1,4) 3047C 3048C----------------------------- 3049C Memory allocation. 3050C----------------------------- 3051C 3052 IF (LISTL(1:3).EQ.'L1 ') THEN 3053 ISINT2L1R = MULD2H(ISYML1R,ISINT2) 3054 ISYFCKL1R = MULD2H(ISYMOP,ISYML1R) 3055 END IF 3056 3057 KXIAJB = KEND1 3058 KEND1 = KXIAJB + NT2AM(ISYM0) 3059 3060 KT3BOG1 = KEND1 3061 KT3BOL1 = KT3BOG1 + NTRAOC(ISYM0) 3062 KT3BOG2 = KT3BOL1 + NTRAOC(ISYM0) 3063 KT3BOL2 = KT3BOG2 + NTRAOC(ISYM0) 3064 KT3OG1 = KT3BOL2 + NTRAOC(ISYM0) 3065 KT3OG2 = KT3OG1 + NTRAOC(ISINT2) 3066 KLAMPL1R = KT3OG2 + NTRAOC(ISINT2) 3067 KLAMHL1R = KLAMPL1R + NLAMDT 3068 KEND1 = KLAMHL1R + NLAMDT 3069 LWRK1 = LWORK - KEND1 3070C 3071 KW3ZOGZ1 = KEND1 3072 KEND1 = KW3ZOGZ1 + NTRAOC(ISINT2RZ) 3073C 3074 KWZUOGR21 = KEND1 3075 KEND1 = KWZUOGR21 + NTRAOC(ISINT2RZU) 3076C 3077 KW3UOGU1 = KEND1 3078 KEND1 = KW3UOGU1 + NTRAOC(ISINT2RU) 3079C 3080 KW3ZUOGZU1 = KEND1 3081 KEND1 = KW3ZUOGZU1 + NTRAOC(ISINT2RZU) 3082C 3083 KW3BXOG1 = KEND1 3084 KW3BXOL1 = KW3BXOG1 + NTRAOC(ISYM0) 3085 KEND1 = KW3BXOL1 + NTRAOC(ISYM0) 3086 LWRK1 = LWORK - KEND1 3087C 3088 IF (LISTL(1:3).EQ.'L1 ') THEN 3089 KFOCKL1RCK = KEND1 3090 KW3BXOGX1 = KFOCKL1RCK + NT1AM(ISYFCKL1R) 3091 KW3BXOLX1 = KW3BXOGX1 + NTRAOC(ISINT2L1R) 3092 KEND1 = KW3BXOLX1 + NTRAOC(ISINT2L1R) 3093 LWRK1 = LWORK - KEND1 3094C 3095 KT2L1R = KEND1 3096 KEND1 = KT2L1R + NT2SQ(ISYML1R) 3097 LWRK1 = LWORK - KEND1 3098C 3099 KT1L1R = KEND1 3100 KEND2 = KT1L1R + NT1AM(ISYML1R) 3101 LWRK2 = LWORK - KEND2 3102 ELSE IF (LISTL(1:3).EQ.'LE ') THEN 3103 KEND2 = KEND1 3104 LWRK2 = LWRK1 3105 END IF 3106C 3107 IF (LWRK2 .LT. 0) THEN 3108 WRITE(LUPRI,*) 'Memory available : ',LWORK 3109 WRITE(LUPRI,*) 'Memory needed : ',KEND2 3110 CALL QUIT('Insufficient space in CC3_ADENVIR_CUB') 3111 END IF 3112C 3113C------------------------ 3114C Construct L(ia,jb). 3115C------------------------ 3116C 3117 LENGTH = IRAT*NT2AM(ISYM0) 3118 3119 REWIND(LUIAJB) 3120 CALL READI(LUIAJB,LENGTH,WORK(KXIAJB)) 3121 3122 CALL CCSD_TCMEPK(WORK(KXIAJB),1.0D0,ISYM0,1) 3123 3124C 3125C--------------------------------------------------- 3126C Prepare to construct the occupied integrals... 3127C--------------------------------------------------- 3128C 3129C isint1 - symmetry of integrals in standard H, transformed 3130C with LambdaH_0 3131C ISINT1L1R - symmetry of integrals in standard H, transformed 3132C with LambdaH_L1R 3133 3134 ISINT1 = 1 3135C 3136 IF (LISTL(1:3).EQ.'L1 ') THEN 3137 ISINT1L1R = MULD2H(ISINT1,ISYML1R) 3138C 3139C-------------------------- 3140C Get Lambda for right list depended on left LISTL list 3141C-------------------------- 3142C 3143 CALL GET_LAMBDAX(WORK(KLAMPL1R),WORK(KLAMHL1R),LISTL1R, 3144 * IDLSTL1R, 3145 * ISYML1R, 3146 * WORK(KLAMP0),WORK(KLAMH0),WORK(KEND2),LWRK2) 3147C 3148C------------------------------------------------------------------ 3149C Calculate the F^L1R matrix (kc elements evaluated and stored 3150C as ck) 3151C------------------------------------------------------------------ 3152C 3153 IOPT = 3 3154 CALL GET_T1_T2(IOPT,.TRUE.,WORK(KT1L1R),WORK(KT2L1R),LISTL1R, 3155 * IDLSTL1R, 3156 * ISYML1R,WORK(KEND2),LWRK2) 3157 CALL CC3LR_MFOCK(WORK(KFOCKL1RCK),WORK(KT1L1R),WORK(KXIAJB), 3158 * ISYFCKL1R) 3159C 3160 ! From now on WORK(KEND1) is used again, since we do not need 3161 ! KT1L1R amplitudes any more... 3162C 3163 END IF 3164C 3165C----------------------------------------------------------------- 3166C Construct occupied integrals which are required to calculate 3167C t3bar_0 multipliers 3168C----------------------------------------------------------------- 3169C 3170 CALL INTOCC_T3BAR0(LUTOC,FNTOC,WORK(KLAMH0),ISYM0,WORK(KT3BOG1), 3171 * WORK(KT3BOL1),WORK(KT3BOG2),WORK(KT3BOL2), 3172 * WORK(KEND1),LWRK1) 3173C 3174C----------------------------------------------------------------- 3175C Construct occupied integrals which are required to calculate 3176C t3_0 amplitudes 3177C----------------------------------------------------------------- 3178C 3179 CALL INTOCC_T30(LUCKJD,FNCKJD,WORK(KLAMP0),ISINT2,WORK(KT3OG1), 3180 * WORK(KT3OG2),WORK(KEND1),LWRK1) 3181C 3182C----------------------------------------------------------------- 3183C Construct occupied integrals which are required to calculate 3184C t3bar_Y multipliers 3185C----------------------------------------------------------------- 3186C 3187 IF (LISTL(1:3).EQ.'L1 ') THEN 3188 LSKIPL1R = .FALSE. 3189 CALL INTOCC_T3BARX(LSKIPL1R, 3190 * LUTOC,FNTOC,ISYMOP,WORK(KLAMH0),ISYM0,ISINT1, 3191 * WORK(KLAMHL1R),ISYML1R,ISINT1L1R, 3192 * WORK(KW3BXOG1), 3193 * WORK(KW3BXOL1),WORK(KW3BXOGX1),WORK(KW3BXOLX1), 3194 * WORK(KEND1),LWRK1) 3195 ELSE IF (LISTL(1:3).EQ.'LE ') THEN 3196 LSKIPL1R = .TRUE. 3197 CALL INTOCC_T3BARX(LSKIPL1R, 3198 * LUTOC,FNTOC,ISYMOP,WORK(KLAMH0),ISYM0,ISINT1, 3199 * DUMMY,IDUMMY,IDUMMY, 3200 * WORK(KW3BXOG1), 3201 * WORK(KW3BXOL1),DUMMY,DUMMY, 3202 * WORK(KEND1),LWRK1) 3203 END IF 3204C 3205C------------------------------------------------------------------ 3206C Read occupied integrals [H,T1Z] where Z is LISTRZ (used in WZ) 3207C----------------------------------------------------------------- 3208C 3209 CALL INTOCC_T3X(LUCKJDRZ,FNCKJDRZ,WORK(KLAMP0),ISINT2RZ, 3210 * WORK(KW3ZOGZ1),WORK(KEND1),LWRK1) 3211 3212C 3213C------------------------------------------------------------------ 3214C Read occupied integrals [H,T1ZU] (used in WZU) 3215C----------------------------------------------------------------- 3216C 3217 CALL INTOCC_T3X(LUCKJDR2,FNCKJDR2,WORK(KLAMP0),ISINT2RZU, 3218 * WORK(KWZUOGR21),WORK(KEND1),LWRK1) 3219C 3220C------------------------------------------------------------------ 3221C Read occupied integrals [H,T1U] where U is LISTRU (used in WU) 3222C----------------------------------------------------------------- 3223C 3224 CALL INTOCC_T3X(LUCKJDRU,FNCKJDRU,WORK(KLAMP0),ISINT2RU, 3225 * WORK(KW3UOGU1),WORK(KEND1),LWRK1) 3226 3227C 3228C------------------------------------------------------------------ 3229C Read occupied integrals [[H,T1Z],T1U] (used in WZU) 3230C----------------------------------------------------------------- 3231C 3232 CALL INTOCC_T3X(LUCKJDRZU,FNCKJDRZU,WORK(KLAMP0),ISINT2RZU, 3233 * WORK(KW3ZUOGZU1),WORK(KEND1),LWRK1) 3234 3235C 3236C--------------------------------------------- 3237C Open files for Tbar and W intermediates: 3238C--------------------------------------------- 3239C 3240 LUT3 = -1 3241 LUWBMAT = -1 3242 LUWBZU = -1 3243 LUTHETA = -1 3244 LUWZU = -1 3245 3246 CALL WOPEN2(LUT3,FNT3,64,0) 3247 CALL WOPEN2(LUWBMAT,FNWBMAT,64,0) 3248 CALL WOPEN2(LUWBZU,FNWBZU,64,0) 3249 CALL WOPEN2(LUTHETA,FNTHETA,64,0) 3250 CALL WOPEN2(LUWZU,FNWZU,64,0) 3251C 3252C---------------------------- 3253C Loop over D 3254C---------------------------- 3255C 3256 DO ISYMD = 1,NSYM 3257 3258 ISYCKBD0 = MULD2H(ISYMD,ISYM0) 3259 ISYCKBDR1Z = MULD2H(ISYMD,ISINT2RZ) 3260 ISYCKBDR1U = MULD2H(ISYMD,ISINT2RU) 3261 ISYCKBDR1ZU = MULD2H(ISYMD,ISINT2RZU) 3262 IF (LISTL(1:3).EQ.'L1 ') THEN 3263 ISYCKBL1R = MULD2H(ISYMD,ISYML1R) 3264 END IF 3265C 3266 DO D = 1,NVIR(ISYMD) 3267C 3268C ------------------ 3269C Memory allocation. 3270C ------------------ 3271 KT3VDG1 = KEND1 3272 KT3VDG2 = KT3VDG1 + NCKATR(ISYCKBD0) 3273 KT3VDG3 = KT3VDG2 + NCKATR(ISYCKBD0) 3274 KEND1 = KT3VDG3 + NCKATR(ISYCKBD0) 3275C 3276 KT3BVDL1 = KEND1 3277 KT3BVDL2 = KT3BVDL1 + NCKATR(ISYCKBD0) 3278 KT3BVDL3 = KT3BVDL2 + NCKATR(ISYCKBD0) 3279 KEND3 = KT3BVDL3 + NCKATR(ISYCKBD0) 3280 LWRK3 = LWORK - KEND3 3281 3282 KT3BVDG1 = KEND3 3283 KT3BVDG2 = KT3BVDG1 + NCKATR(ISYCKBD0) 3284 KT3BVDG3 = KT3BVDG2 + NCKATR(ISYCKBD0) 3285 KEND3 = KT3BVDG3 + NCKATR(ISYCKBD0) 3286 LWRK3 = LWORK - KEND3 3287 3288 KW3BXVDG1 = KEND3 3289 KW3BXVDG2 = KW3BXVDG1 + NCKATR(ISYCKBD0) 3290 KW3BXVDL1 = KW3BXVDG2 + NCKATR(ISYCKBD0) 3291 KW3BXVDL2 = KW3BXVDL1 + NCKATR(ISYCKBD0) 3292 KEND3 = KW3BXVDL2 + NCKATR(ISYCKBD0) 3293 LWRK3 = LWORK - KEND3 3294 3295 IF (LISTL(1:3).EQ.'L1 ') THEN 3296 KW3BXVDGX1 = KEND3 3297 KW3BXVDGX2 = KW3BXVDGX1 + NCKATR(ISYCKBL1R) 3298 KW3BXVDLX1 = KW3BXVDGX2 + NCKATR(ISYCKBL1R) 3299 KW3BXVDLX2 = KW3BXVDLX1 + NCKATR(ISYCKBL1R) 3300 KEND3 = KW3BXVDLX2 + NCKATR(ISYCKBL1R) 3301 LWRK3 = LWORK - KEND3 3302 END IF 3303C 3304 KW3ZVDGZ1 = KEND3 3305 KEND3 = KW3ZVDGZ1 + NCKATR(ISYCKBDR1Z) 3306 LWRK3 = LWORK - KEND3 3307C 3308 KWZUVDGR21 = KEND3 3309 KEND3 = KWZUVDGR21 + NCKATR(ISYCKBDR1ZU) 3310 LWRK3 = LWORK - KEND3 3311C 3312 KT3VDGZ3 = KEND3 3313 KEND3 = KT3VDGZ3 + NCKATR(ISYCKBDR1Z) 3314 LWRK3 = LWORK - KEND3 3315C 3316 KWZUVDGR23 = KEND3 3317 KEND3 = KWZUVDGR23 + NCKATR(ISYCKBDR1ZU) 3318 LWRK3 = LWORK - KEND3 3319C 3320 KW3UVDGU1 = KEND3 3321 KEND3 = KW3UVDGU1 + NCKATR(ISYCKBDR1U) 3322 LWRK3 = LWORK - KEND3 3323C 3324 KW3ZUVDGZU1 = KEND3 3325 KEND3 = KW3ZUVDGZU1 + NCKATR(ISYCKBDR1ZU) 3326 LWRK3 = LWORK - KEND3 3327C 3328 KT3VDGU3 = KEND3 3329 KEND3 = KT3VDGU3 + NCKATR(ISYCKBDR1U) 3330 LWRK3 = LWORK - KEND3 3331C 3332 KT3VDGZU3 = KEND3 3333 KEND3 = KT3VDGZU3 + NCKATR(ISYCKBDR1ZU) 3334 LWRK3 = LWORK - KEND3 3335C 3336 IF (LISTL(1:3).EQ.'L1 ') THEN 3337 MAXX1 = MAX(NCKA(ISYCKBD0),NCKA(ISYCKBL1R)) 3338 ELSE IF (LISTL(1:3).EQ.'LE ') THEN 3339 MAXX1 = NCKA(ISYCKBD0) 3340 END IF 3341 MAXX2 = MAX(MAXX1,NCKA(ISYCKBDR1Z)) 3342 MAXX3 = MAX(MAXX2,NCKA(ISYCKBDR1U)) 3343 MAXX4 = MAX(MAXX3,NCKA(ISYCKBDR1ZU)) 3344C 3345 KINTVI = KEND3 3346 KTRVI6 = KINTVI + MAXX4 3347 KEND4 = KTRVI6 + NCKATR(ISYCKBD0) 3348 LWRK4 = LWORK - KEND4 3349 3350 IF (LWRK4 .LT. 0) THEN 3351 WRITE(LUPRI,*) 'Memory available : ',LWORK 3352 WRITE(LUPRI,*) 'Memory needed : ',KEND4 3353 CALL QUIT('Insufficient space in CC3_ADENVIR_CUB') 3354 END IF 3355C 3356C----------------------------------------------------------------------- 3357C Construct virtual integrals (for fixed D) which are required 3358C to calculate t3_0 amplitudes 3359C----------------------------------------------------------------------- 3360C 3361 CALL INTVIR_T30_D(LUDKBC,FNDKBC,LUDELD,FNDELD,ISINT2, 3362 * WORK(KT3VDG1),WORK(KT3VDG2),WORK(KT3VDG3), 3363 * WORK(KLAMH0),ISYMD,D,WORK(KEND4),LWRK4) 3364C 3365C----------------------------------------------------------------------- 3366C Construct virtual integrals (for fixed D) which are required 3367C to calculate t3bar_0 multipliers 3368C----------------------------------------------------------------------- 3369C 3370 CALL INTVIR_T3BAR0_D(LU3FOPX,FN3FOPX,LU3FOP2X,FN3FOP2X, 3371 * LUDKBC3,FNDKBC3,LU3VI,FN3VI,ISYM0, 3372 * WORK(KT3BVDL1),WORK(KT3BVDG1), 3373 * WORK(KT3BVDG2),WORK(KT3BVDL2), 3374 * WORK(KT3BVDG3),WORK(KT3BVDL3), 3375 * WORK(KLAMP0),ISYMD,D,WORK(KEND4),LWRK4) 3376C 3377C----------------------------------------------------------------------- 3378C Construct virtual integrals (for fixed D) which are required 3379C to calculate t3bar_X multipliers 3380C----------------------------------------------------------------------- 3381C 3382 IF (LISTL(1:3).EQ.'L1 ') THEN 3383 LSKIPL1R = .FALSE. 3384 CALL INTVIR_T3BARX_D(LSKIPL1R, 3385 * ISYMOP,LU3VI,FN3VI,LU3VI2,FN3VI2, 3386 * LU3FOP,FN3FOP,LU3FOP2,FN3FOP2, 3387 * WORK(KW3BXVDGX1),WORK(KW3BXVDG1), 3388 * WORK(KW3BXVDGX2),WORK(KW3BXVDG2), 3389 * WORK(KW3BXVDLX1),WORK(KW3BXVDL1), 3390 * WORK(KW3BXVDLX2),WORK(KW3BXVDL2), 3391 * WORK(KLAMPL1R),ISYML1R,WORK(KLAMP0), 3392 * ISYM0,ISYMD,D,WORK(KEND4),LWRK4) 3393 ELSE IF (LISTL(1:3).EQ.'LE ') THEN 3394 LSKIPL1R = .TRUE. 3395 CALL INTVIR_T3BARX_D(LSKIPL1R, 3396 * ISYMOP,LU3VI,FN3VI,LU3VI2,FN3VI2, 3397 * LU3FOP,FN3FOP,LU3FOP2,FN3FOP2, 3398 * DUMMY,WORK(KW3BXVDG1), 3399 * DUMMY,WORK(KW3BXVDG2), 3400 * DUMMY,WORK(KW3BXVDL1), 3401 * DUMMY,WORK(KW3BXVDL2), 3402 * DUMMY,IDUMMY,WORK(KLAMP0), 3403 * ISYM0,ISYMD,D,WORK(KEND4),LWRK4) 3404 END IF 3405C 3406C----------------------------------------------------------------------- 3407C Read virtual integrals [H,T1Z] where Z is LISTRZ (used in WZ) 3408C----------------------------------------------------------------------- 3409C 3410 IOFF = ICKBD(ISYCKBDR1Z,ISYMD) + NCKATR(ISYCKBDR1Z)*(D - 1) 3411 * + 1 3412 IF (NCKATR(ISYCKBDR1Z) .GT. 0) THEN 3413 CALL GETWA2(LUDKBCRZ,FNDKBCRZ,WORK(KW3ZVDGZ1),IOFF, 3414 & NCKATR(ISYCKBDR1Z)) 3415 ENDIF 3416 3417C 3418C----------------------------------------------------------------------- 3419C Read virtual integrals [H,T1ZU] (used in WZU) 3420C----------------------------------------------------------------------- 3421C 3422 IOFF = ICKBD(ISYCKBDR1ZU,ISYMD) + NCKATR(ISYCKBDR1ZU)*(D-1) 3423 * + 1 3424 IF (NCKATR(ISYCKBDR1ZU) .GT. 0) THEN 3425 CALL GETWA2(LUDKBCR2,FNDKBCR2,WORK(KWZUVDGR21),IOFF, 3426 & NCKATR(ISYCKBDR1ZU)) 3427 ENDIF 3428C 3429C----------------------------------------------------------------------- 3430C Read virtual integrals [H,T1U] where U is LISTRU (used in WU) 3431C----------------------------------------------------------------------- 3432C 3433 IOFF = ICKBD(ISYCKBDR1U,ISYMD) + NCKATR(ISYCKBDR1U)*(D - 1) 3434 * + 1 3435 IF (NCKATR(ISYCKBDR1U) .GT. 0) THEN 3436 CALL GETWA2(LUDKBCRU,FNDKBCRU,WORK(KW3UVDGU1),IOFF, 3437 & NCKATR(ISYCKBDR1U)) 3438 ENDIF 3439 3440C 3441C----------------------------------------------------------------------- 3442C Read virtual integrals [[H,T1Z],T1U] (used in WZU) 3443C----------------------------------------------------------------------- 3444C 3445 IOFF = ICKBD(ISYCKBDR1ZU,ISYMD) + NCKATR(ISYCKBDR1ZU)*(D-1) 3446 * + 1 3447 IF (NCKATR(ISYCKBDR1ZU) .GT. 0) THEN 3448 CALL GETWA2(LUDKBCRZU,FNDKBCRZU,WORK(KW3ZUVDGZU1),IOFF, 3449 & NCKATR(ISYCKBDR1ZU)) 3450 ENDIF 3451 3452C 3453C-------------------------------------------------------------------- 3454C Read virtual integrals [H,T1Z] where Z is LISTRZ (used in W^Z) 3455C-------------------------------------------------------------------- 3456C 3457 IF (NCKA(ISYCKBDR1Z) .GT. 0) THEN 3458 IOFF = ICKAD(ISYCKBDR1Z,ISYMD) + 3459 & NCKA(ISYCKBDR1Z)*(D - 1) + 1 3460 CALL GETWA2(LUDELDRZ,FNDELDRZ,WORK(KINTVI),IOFF, 3461 * NCKA(ISYCKBDR1Z)) 3462 ENDIF 3463C 3464 CALL CCSDT_TRVIR(WORK(KINTVI),WORK(KT3VDGZ3), 3465 * WORK(KLAMH0),ISYMD,D,ISINT2RZ, 3466 * WORK(KEND4),LWRK4) 3467 3468C 3469C-------------------------------------------------------------------- 3470C Read virtual integrals [H,T1ZU] (used in W^ZU) 3471C-------------------------------------------------------------------- 3472C 3473 IF (NCKA(ISYCKBDR1ZU) .GT. 0) THEN 3474 IOFF = ICKAD(ISYCKBDR1ZU,ISYMD) + 3475 & NCKA(ISYCKBDR1ZU)*(D - 1) + 1 3476 CALL GETWA2(LUDELDR2,FNDELDR2,WORK(KINTVI),IOFF, 3477 * NCKA(ISYCKBDR1ZU)) 3478 ENDIF 3479C 3480 CALL CCSDT_TRVIR(WORK(KINTVI),WORK(KWZUVDGR23), 3481 * WORK(KLAMH0),ISYMD,D,ISINT2RZU, 3482 * WORK(KEND4),LWRK4) 3483 3484C 3485C-------------------------------------------------------------------- 3486C Read virtual integrals [H,T1U] where U is LISTRU (used in W^U) 3487C-------------------------------------------------------------------- 3488C 3489 IF (NCKA(ISYCKBDR1U) .GT. 0) THEN 3490 IOFF = ICKAD(ISYCKBDR1U,ISYMD) + 3491 & NCKA(ISYCKBDR1U)*(D - 1) + 1 3492 CALL GETWA2(LUDELDRU,FNDELDRU,WORK(KINTVI),IOFF, 3493 * NCKA(ISYCKBDR1U)) 3494 ENDIF 3495C 3496 CALL CCSDT_TRVIR(WORK(KINTVI),WORK(KT3VDGU3), 3497 * WORK(KLAMH0),ISYMD,D,ISINT2RU, 3498 * WORK(KEND4),LWRK4) 3499C 3500C-------------------------------------------------------------------- 3501C Read virtual integrals [[H,T1Z],T1U] (used in W^ZU) 3502C-------------------------------------------------------------------- 3503C 3504 IF (NCKA(ISYCKBDR1ZU) .GT. 0) THEN 3505 IOFF = ICKAD(ISYCKBDR1ZU,ISYMD) + 3506 & NCKA(ISYCKBDR1ZU)*(D - 1) + 1 3507 CALL GETWA2(LUDELDRZU,FNDELDRZU,WORK(KINTVI),IOFF, 3508 * NCKA(ISYCKBDR1ZU)) 3509 ENDIF 3510C 3511 CALL CCSDT_TRVIR(WORK(KINTVI),WORK(KT3VDGZU3), 3512 * WORK(KLAMH0),ISYMD,D,ISINT2RZU, 3513 * WORK(KEND4),LWRK4) 3514 3515 3516 3517C 3518 DO ISYMB = 1,NSYM 3519 3520 ISYALJB0 = MULD2H(ISYMB,ISYM0) 3521 ISYALJD0 = MULD2H(ISYMD,ISYM0) 3522 ISYALJBL1 = MULD2H(ISYMB,ISYML1) 3523 ISYALJDL1 = MULD2H(ISYMD,ISYML1) 3524 ISYMBD = MULD2H(ISYMD,ISYMB) 3525 ISCKIJ = MULD2H(ISYMBD,ISYM0) 3526 ISWBMAT = MULD2H(ISCKIJ,ISYML1) 3527 ISWMATZ = MULD2H(ISCKIJ,ISYMRZ) 3528 ISWMATU = MULD2H(ISCKIJ,ISYMRU) 3529 ISWMATZU = MULD2H(ISWMATZ,ISYMRU) 3530 ISYCKD = MULD2H(ISYM0,ISYMB) 3531C 3532 ISYCKDBR1Z = MULD2H(ISYMB,ISINT2RZ) 3533 ISYCKDBR1U = MULD2H(ISYMB,ISINT2RU) 3534 ISYCKDBR1ZU = MULD2H(ISYMB,ISINT2RZU) 3535 3536C Can use kend3 since we do not need the integrals anymore. 3537 KSMAT2 = KEND3 3538 KUMAT2 = KSMAT2 + NCKIJ(ISCKIJ) 3539 KDIAG = KUMAT2 + NCKIJ(ISCKIJ) 3540 KDIAGWB = KDIAG + NCKIJ(ISCKIJ) 3541 KDIAGWZ = KDIAGWB + NCKIJ(ISWBMAT) 3542 KINDSQ = KDIAGWZ + NCKIJ(ISWMATZ) 3543 KINDSQWB = KINDSQ + (6*NCKIJ(ISCKIJ) - 1)/IRAT + 1 3544 KINDSQWZ = KINDSQWB + (6*NCKIJ(ISWBMAT) - 1)/IRAT + 1 3545 KINDEX = KINDSQWZ + (6*NCKIJ(ISWMATZ) - 1)/IRAT + 1 3546 KINDEX2 = KINDEX + (NCKI(ISYALJB0) - 1)/IRAT + 1 3547 KINDEXBL1 = KINDEX2 + (NCKI(ISYALJD0) - 1)/IRAT + 1 3548 KINDEXDL1 = KINDEXBL1 + (NCKI(ISYALJBL1) - 1)/IRAT + 1 3549 KTMAT = KINDEXDL1 + (NCKI(ISYALJDL1) - 1)/IRAT + 1 3550 KT3MAT = KTMAT + MAX(NCKIJ(ISCKIJ),NCKIJ(ISWBMAT)) 3551 KW3BMAT = KT3MAT + NCKIJ(ISCKIJ) 3552 KW3MATZ = KW3BMAT + NCKIJ(ISWBMAT) 3553c 3554C 3555 KWTEMP = KW3MATZ + NCKIJ(ISWMATZ) 3556 KEND4 = KWTEMP + NCKIJMAX 3557 LWRK4 = LWORK - KEND4 3558C 3559 KW3MATU = KEND4 3560 KINDSQWU = KW3MATU + NCKIJ(ISWMATU) 3561 KDIAGWU = KINDSQWU + (6*NCKIJ(ISWMATU) - 1)/IRAT + 1 3562 KEND4 = KDIAGWU + NCKIJ(ISWMATU) 3563 LWRK4 = LWORK - KEND4 3564 3565 KS3MAT = KEND4 3566 KU3MAT = KS3MAT + NCKIJ(ISCKIJ) 3567 KS3MAT3 = KU3MAT + NCKIJ(ISCKIJ) 3568 KU3MAT3 = KS3MAT3 + NCKIJ(ISCKIJ) 3569 KEND4 = KU3MAT3 + NCKIJ(ISCKIJ) 3570 3571 KT3VBG1 = KEND4 3572 KT3VBG2 = KT3VBG1 + NCKATR(ISYCKD) 3573 KT3VBG3 = KT3VBG2 + NCKATR(ISYCKD) 3574 KEND4 = KT3VBG3 + NCKATR(ISYCKD) 3575 3576 KT3BVBG1 = KEND4 3577 KT3BVBG2 = KT3BVBG1 + NCKATR(ISYCKD) 3578 KT3BVBG3 = KT3BVBG2 + NCKATR(ISYCKD) 3579 KEND4 = KT3BVBG3 + NCKATR(ISYCKD) 3580 LWRK4 = LWORK - KEND4 3581 3582 KSMAT4 = KEND4 3583 KUMAT4 = KSMAT4 + NCKIJ(ISCKIJ) 3584 KT3BVBL1 = KUMAT4 + NCKIJ(ISCKIJ) 3585 KT3BVBL2 = KT3BVBL1 + NCKATR(ISYCKD) 3586 KT3BVBL3 = KT3BVBL2 + NCKATR(ISYCKD) 3587 KEND4 = KT3BVBL3 + NCKATR(ISYCKD) 3588 LWRK4 = LWORK - KEND4 3589c 3590C 3591 KWMATZU = KEND4 3592 KEND4 = KWMATZU + NCKIJ(ISWMATZU) 3593 LWRK4 = LWORK - KEND4 3594C 3595 KWMATZUD = KEND4 3596 KEND4 = KWMATZUD + NCKIJ(ISWMATZU) 3597 LWRK4 = LWORK - KEND4 3598C 3599 KINDSQWZU = KEND4 3600 KDIAGWZU = KINDSQWZU + (6*NCKIJ(ISWMATZU) - 1)/IRAT + 1 3601 KEND4 = KDIAGWZU + NCKIJ(ISWMATZU) 3602 LWRK4 = LWORK - KEND4 3603C 3604 KW3ZVDGZ2 = KEND4 3605 KEND4 = KW3ZVDGZ2 + NCKATR(ISYCKDBR1Z) 3606C 3607 KWZUVDGR22 = KEND4 3608 KEND4 = KWZUVDGR22 + NCKATR(ISYCKDBR1ZU) 3609C 3610 KW3UVDGU2 = KEND4 3611 KEND4 = KW3UVDGU2 + NCKATR(ISYCKDBR1U) 3612C 3613 KW3ZUVDGZU2 = KEND4 3614 KEND4 = KW3ZUVDGZU2 + NCKATR(ISYCKDBR1ZU) 3615C 3616 KT3VBGZ3 = KEND4 3617 KEND4 = KT3VBGZ3 + NCKATR(ISYCKDBR1Z) 3618C 3619 KWZUVBGR23 = KEND4 3620 KEND4 = KWZUVBGR23 + NCKATR(ISYCKDBR1ZU) 3621C 3622 KT3VBGU3 = KEND4 3623 KEND4 = KT3VBGU3 + NCKATR(ISYCKDBR1U) 3624C 3625 KT3VBGZU3 = KEND4 3626 KEND4 = KT3VBGZU3 + NCKATR(ISYCKDBR1ZU) 3627C 3628 MAXX1 = MAX(NCKA(ISYCKDBR1Z),NCKA(ISYCKDBR1U)) 3629 MAXX2 = MAX(MAXX1,NCKA(ISYCKDBR1ZU)) 3630C 3631 FKW3BXVDG1 = KEND4 3632 FKW3BXVDG2 = FKW3BXVDG1 + NCKATR(ISYALJB0) 3633 FKW3BXVDL1 = FKW3BXVDG2 + NCKATR(ISYALJB0) 3634 FKW3BXVDL2 = FKW3BXVDL1 + NCKATR(ISYALJB0) 3635 KEND4 = FKW3BXVDL2 + NCKATR(ISYALJB0) 3636 LWRK4 = LWORK - KEND4 3637 3638 IF (LISTL(1:3).EQ.'L1 ') THEN 3639 ISYCKDL1R = MULD2H(ISYMB,ISYML1R) 3640 FKW3BXVDGX1 = KEND4 3641 FKW3BXVDGX2 = FKW3BXVDGX1 + NCKATR(ISYCKDL1R) 3642 FKW3BXVDLX1 = FKW3BXVDGX2 + NCKATR(ISYCKDL1R) 3643 FKW3BXVDLX2 = FKW3BXVDLX1 + NCKATR(ISYCKDL1R) 3644 KEND4 = FKW3BXVDLX2 + NCKATR(ISYCKDL1R) 3645 LWRK4 = LWORK - KEND4 3646 END IF 3647C 3648 KINTVI = KEND4 3649 KEND5 = KINTVI + MAXX2 3650 LWRK5 = LWORK - KEND5 3651 3652 IF (LWRK5 .LT. 0) THEN 3653 WRITE(LUPRI,*) 'Memory available : ',LWORK 3654 WRITE(LUPRI,*) 'Memory needed : ',KEND5 3655 CALL QUIT('Insufficient space in CC3_ADENVIR_CUB') 3656 END IF 3657C 3658C 3659C ------------------------------- 3660C Construct part of the diagonal. 3661C ------------------------------- 3662C 3663 CALL CC3_DIAG(WORK(KDIAG), WORK(KFOCKD),ISCKIJ) 3664 CALL CC3_DIAG(WORK(KDIAGWB),WORK(KFOCKD),ISWBMAT) 3665 CALL CC3_DIAG(WORK(KDIAGWZ),WORK(KFOCKD),ISWMATZ) 3666 CALL CC3_DIAG(WORK(KDIAGWU),WORK(KFOCKD),ISWMATU) 3667 CALL CC3_DIAG(WORK(KDIAGWZU),WORK(KFOCKD),ISWMATZU) 3668 3669C 3670C ----------------------- 3671C Construct index arrays. 3672C ----------------------- 3673C 3674 LENSQ = NCKIJ(ISCKIJ) 3675 CALL CC3_INDSQ(WORK(KINDSQ),LENSQ,ISCKIJ) 3676 LENSQWB = NCKIJ(ISWBMAT) 3677 CALL CC3_INDSQ(WORK(KINDSQWB),LENSQWB,ISWBMAT) 3678 LENSQWZ = NCKIJ(ISWMATZ) 3679 CALL CC3_INDSQ(WORK(KINDSQWZ),LENSQWZ,ISWMATZ) 3680 LENSQWU = NCKIJ(ISWMATU) 3681 CALL CC3_INDSQ(WORK(KINDSQWU),LENSQWU,ISWMATU) 3682 LENSQWZU = NCKIJ(ISWMATZU) 3683 CALL CC3_INDSQ(WORK(KINDSQWZU),LENSQWZU,ISWMATZU) 3684 3685 CALL CC3_INDEX(WORK(KINDEX),ISYALJB0) 3686 CALL CC3_INDEX(WORK(KINDEX2),ISYALJD0) 3687 CALL CC3_INDEX(WORK(KINDEXBL1),ISYALJBL1) 3688 CALL CC3_INDEX(WORK(KINDEXDL1),ISYALJDL1) 3689 3690 DO B = 1,NVIR(ISYMB) 3691 CALL DZERO(WORK(KW3BMAT),NCKIJ(ISWBMAT)) 3692 CALL DZERO(WORK(KW3MATZ),NCKIJ(ISWMATZ)) 3693 CALL DZERO(WORK(KW3MATU),NCKIJ(ISWMATU)) 3694 CALL DZERO(WORK(KWMATZU),NCKIJ(ISWMATZU)) 3695 CALL DZERO(WORK(KWMATZUD),NCKIJ(ISWMATZU)) 3696C 3697 IF (LISTL(1:3).EQ.'L1 ') THEN 3698 LSKIPL1R = .FALSE. 3699 CALL INTVIR_T3BARX_D(LSKIPL1R, 3700 * ISYMOP,LU3VI,FN3VI,LU3VI2,FN3VI2, 3701 * LU3FOP,FN3FOP,LU3FOP2,FN3FOP2, 3702 * WORK(FKW3BXVDGX1),WORK(FKW3BXVDG1), 3703 * WORK(FKW3BXVDGX2),WORK(FKW3BXVDG2), 3704 * WORK(FKW3BXVDLX1),WORK(FKW3BXVDL1), 3705 * WORK(FKW3BXVDLX2),WORK(FKW3BXVDL2), 3706 * WORK(KLAMPL1R),ISYML1R,WORK(KLAMP0), 3707 * ISYM0,ISYMB,B,WORK(KEND5),LWRK5) 3708 ELSE IF (LISTL(1:3).EQ.'LE ') THEN 3709 LSKIPL1R = .TRUE. 3710 CALL INTVIR_T3BARX_d(LSKIPL1R, 3711 * ISYMOP,LU3VI,FN3VI,LU3VI2,FN3VI2, 3712 * LU3FOP,FN3FOP,LU3FOP2,FN3FOP2, 3713 * DUMMY,WORK(FKW3BXVDG1), 3714 * DUMMY,WORK(FKW3BXVDG2), 3715 * DUMMY,WORK(FKW3BXVDL1), 3716 * DUMMY,WORK(FKW3BXVDL2), 3717 * DUMMY,IDUMMY,WORK(KLAMP0), 3718 * ISYM0,ISYMB,B,WORK(KEND5),LWRK5) 3719 END IF 3720C 3721C----------------------------------------------------------------------- 3722C Construct virtual integrals (for fixed B) which are required 3723C to calculate t3_0 amplitudes 3724C (the same routine as in d-loop is used) 3725C----------------------------------------------------------------------- 3726C 3727 CALL INTVIR_T30_D(LUDKBC,FNDKBC,LUDELD,FNDELD,ISINT2, 3728 * WORK(KT3VBG1),WORK(KT3VBG2), 3729 * WORK(KT3VBG3),WORK(KLAMH0),ISYMB,B, 3730 * WORK(KEND5),LWRK5) 3731 3732C 3733C----------------------------------------------------------------------- 3734C Construct virtual integrals (for fixed B) which are required 3735C to calculate t3bar_0 multipliers 3736C (the same routine as in d-loop is used) 3737C----------------------------------------------------------------------- 3738C 3739 CALL INTVIR_T3BAR0_D(LU3FOPX,FN3FOPX,LU3FOP2X, 3740 * FN3FOP2X,LUDKBC3,FNDKBC3, 3741 * LU3VI,FN3VI,ISYM0,WORK(KT3BVBL1), 3742 * WORK(KT3BVBG1),WORK(KT3BVBG2), 3743 * WORK(KT3BVBL2),WORK(KT3BVBG3), 3744 * WORK(KT3BVBL3),WORK(KLAMP0), 3745 * ISYMB,B,WORK(KEND5),LWRK5) 3746c 3747C-------------------------------------------------------------------- 3748C Read virtual integrals [H,T1Z] where Z is LISTRZ (used in WZ) 3749C-------------------------------------------------------------------- 3750C 3751 IOFF = ICKBD(ISYCKDBR1Z,ISYMB) + 3752 & NCKATR(ISYCKDBR1Z)*(B - 1) + 1 3753 IF (NCKATR(ISYCKDBR1Z) .GT. 0) THEN 3754 CALL GETWA2(LUDKBCRZ,FNDKBCRZ,WORK(KW3ZVDGZ2),IOFF, 3755 & NCKATR(ISYCKDBR1Z)) 3756 ENDIF 3757C 3758 IOFF = ICKAD(ISYCKDBR1Z,ISYMB) + 3759 & NCKA(ISYCKDBR1Z)*(B - 1) + 1 3760 IF (NCKA(ISYCKDBR1Z) .GT. 0) THEN 3761 CALL GETWA2(LUDELDRZ,FNDELDRZ,WORK(KINTVI),IOFF, 3762 * NCKA(ISYCKDBR1Z)) 3763 ENDIF 3764C 3765 CALL CCSDT_TRVIR(WORK(KINTVI),WORK(KT3VBGZ3), 3766 * WORK(KLAMH0),ISYMB,B,ISINT2RZ, 3767 * WORK(KEND5),LWRK5) 3768 3769C 3770C-------------------------------------------------------------------- 3771C Read virtual integrals [H,T1ZU] (used in WZU) 3772C-------------------------------------------------------------------- 3773C 3774 IOFF = ICKBD(ISYCKDBR1ZU,ISYMB) + 3775 & NCKATR(ISYCKDBR1ZU)*(B - 1) + 1 3776 IF (NCKATR(ISYCKDBR1ZU) .GT. 0) THEN 3777 CALL GETWA2(LUDKBCR2,FNDKBCR2,WORK(KWZUVDGR22), 3778 * IOFF,NCKATR(ISYCKDBR1ZU)) 3779 ENDIF 3780C 3781 IOFF = ICKAD(ISYCKDBR1ZU,ISYMB) + 3782 & NCKA(ISYCKDBR1ZU)*(B - 1) + 1 3783 IF (NCKA(ISYCKDBR1ZU) .GT. 0) THEN 3784 CALL GETWA2(LUDELDR2,FNDELDR2,WORK(KINTVI),IOFF, 3785 * NCKA(ISYCKDBR1ZU)) 3786 ENDIF 3787C 3788 CALL CCSDT_TRVIR(WORK(KINTVI),WORK(KWZUVBGR23), 3789 * WORK(KLAMH0),ISYMB,B,ISINT2RZU, 3790 * WORK(KEND5),LWRK5) 3791C 3792C-------------------------------------------------------------------- 3793C Read virtual integrals [H,T1U] where U is LISTRU (used in WU) 3794C-------------------------------------------------------------------- 3795C 3796 IOFF = ICKBD(ISYCKDBR1U,ISYMB) + 3797 & NCKATR(ISYCKDBR1U)*(B - 1) + 1 3798 IF (NCKATR(ISYCKDBR1U) .GT. 0) THEN 3799 CALL GETWA2(LUDKBCRU,FNDKBCRU,WORK(KW3UVDGU2),IOFF, 3800 & NCKATR(ISYCKDBR1U)) 3801 ENDIF 3802C 3803 IOFF = ICKAD(ISYCKDBR1U,ISYMB) + 3804 & NCKA(ISYCKDBR1U)*(B - 1) + 1 3805 IF (NCKA(ISYCKDBR1U) .GT. 0) THEN 3806 CALL GETWA2(LUDELDRU,FNDELDRU,WORK(KINTVI),IOFF, 3807 * NCKA(ISYCKDBR1U)) 3808 ENDIF 3809C 3810 CALL CCSDT_TRVIR(WORK(KINTVI),WORK(KT3VBGU3), 3811 * WORK(KLAMH0),ISYMB,B,ISINT2RU, 3812 * WORK(KEND5),LWRK5) 3813 3814C 3815C-------------------------------------------------------------------- 3816C Read virtual integrals [[H,T1Z],T1U] (used in WZU) 3817C-------------------------------------------------------------------- 3818C 3819 IOFF = ICKBD(ISYCKDBR1ZU,ISYMB) + 3820 & NCKATR(ISYCKDBR1ZU)*(B - 1) + 1 3821 IF (NCKATR(ISYCKDBR1ZU) .GT. 0) THEN 3822 CALL GETWA2(LUDKBCRZU,FNDKBCRZU,WORK(KW3ZUVDGZU2), 3823 * IOFF,NCKATR(ISYCKDBR1ZU)) 3824 ENDIF 3825C 3826 IOFF = ICKAD(ISYCKDBR1ZU,ISYMB) + 3827 & NCKA(ISYCKDBR1ZU)*(B - 1) + 1 3828 IF (NCKA(ISYCKDBR1ZU) .GT. 0) THEN 3829 CALL GETWA2(LUDELDRZU,FNDELDRZU,WORK(KINTVI),IOFF, 3830 * NCKA(ISYCKDBR1ZU)) 3831 ENDIF 3832C 3833 CALL CCSDT_TRVIR(WORK(KINTVI),WORK(KT3VBGZU3), 3834 * WORK(KLAMH0),ISYMB,B,ISINT2RZU, 3835 * WORK(KEND5),LWRK5) 3836 3837C 3838C----------------------------------------------------- 3839C Get T3_BD amplitudes (using S and U) 3840C----------------------------------------------------- 3841C 3842 CALL GET_T30_BD(ISYM0,ISINT2,WORK(KT2TP),ISYM0, 3843 * WORK(KT3MAT),WORK(KFOCKD),WORK(KDIAG), 3844 * WORK(KINDSQ),LENSQ,WORK(KS3MAT), 3845 * WORK(KT3VDG1),WORK(KT3VDG2), 3846 * WORK(KT3OG1),WORK(KINDEX), 3847 * WORK(KS3MAT3),WORK(KT3VBG1), 3848 * WORK(KT3VBG2),WORK(KINDEX2), 3849 * WORK(KU3MAT),WORK(KT3VDG3), 3850 * WORK(KT3OG2),WORK(KU3MAT3), 3851 * WORK(KT3VBG3),ISYMB,B,ISYMD,D,ISCKIJ, 3852 * WORK(KEND5),LWRK5) 3853C 3854c call sum_pt3(work(KT3MAT),isymb,b,isymd,d, 3855c * ISYM0,work(kx3am),4) 3856C 3857C--------------------------------------------------------- 3858C Get T3bar_BD multipliers (using S and U) 3859C--------------------------------------------------------- 3860C 3861 CALL GET_T3BAR0_BD(ISYM0,WORK(KL1AM),ISYM0, 3862 * WORK(KL2TP),ISYM0,WORK(KTMAT), 3863 * WORK(KFOCK0CK),WORK(KFOCKD), 3864 * WORK(KDIAG),WORK(KXIAJB),ISYM0, 3865 * ISYM0,WORK(KINDSQ),LENSQ, 3866 * WORK(KSMAT2),WORK(KT3BVDG1), 3867 * WORK(KT3BVDG2),WORK(KT3BVDL1), 3868 * WORK(KT3BVDL2),WORK(KT3BOG1), 3869 * WORK(KT3BOL1),WORK(KINDEX), 3870 * WORK(KSMAT4),WORK(KT3BVBG1), 3871 * WORK(KT3BVBG2),WORK(KT3BVBL1), 3872 * WORK(KT3BVBL2),WORK(KINDEX2), 3873 * WORK(KUMAT2),WORK(KT3BVDG3), 3874 * WORK(KT3BVDL3),WORK(KT3BOG2), 3875 * WORK(KT3BOL2),WORK(KUMAT4), 3876 * WORK(KT3BVBG3),WORK(KT3BVBL3), 3877 * ISYMB,B,ISYMD,D,ISCKIJ, 3878 * WORK(KEND5),LWRK5) 3879c 3880c call sum_pt3(work(KTMAT),isymb,b,isymd,d, 3881c * ISYM0,work(kx3am),4) 3882C 3883 IF (LISTL(1:3).EQ.'L1 ') THEN 3884 !<L3|[Y^,tau3]|HF> (virt. part) 3885 CALL WBARBD_V(WORK(KTMAT),ISCKIJ, 3886 * WORK(KFOCKL1), 3887 * ISYML1,WORK(KW3BMAT),ISWBMAT, 3888 * WORK(KEND5),LWRK5) 3889C 3890 !<L3|[Y^,tau3]|HF> (occ. part) 3891 CALL WX_BD_O(1,.FALSE.,.TRUE.,WORK(KTMAT),ISCKIJ, 3892 * WORK(KFOCKL1), 3893 * ISYML1,WORK(KW3BMAT),ISWBMAT, 3894 * WORK(KEND5),LWRK5) 3895 3896 ! <L2|[Y,tau3]|HF> 3897 CALL WBARXBD_T2(1,B,ISYMB,D,ISYMD,WORK(KL2TP),ISYM0, 3898 * WORK(KFOCKL1), 3899 * ISYML1,WORK(KW3BMAT),ISWBMAT) 3900 3901C 3902 !<L2|[H^Y,tau3]|HF> 3903 CALL WBARXBD_TMAT(1, 3904 * WORK(KL2TP),ISYM0,WORK(KW3BMAT),WORK(KWTEMP), 3905 * ISWBMAT,WORK(KFOCKL1RCK),ISYFCKL1R, 3906 * WORK(KW3BXVDLX2),WORK(KW3BXVDLX1), 3907 * WORK(KW3BXVDGX2), 3908 * WORK(KW3BXVDGX1),WORK(KW3BXOLX1), 3909 * WORK(KW3BXOGX1),ISINT2L1R, 3910 * WORK(KEND5),LWRK5, 3911 * WORK(KINDEX),WORK(KINDEX2), 3912 * WORK(KINDSQWB),LENSQWB, 3913 * ISYMB,B,ISYMD,D) 3914 END IF 3915C 3916 !<L2Y|[H^,tau3]|HF> 3917 CALL WBARXBD_TMAT(1, 3918 * WORK(KL2L1),ISYML1,WORK(KW3BMAT),WORK(KWTEMP), 3919 * ISWBMAT,WORK(KFOCK0CK),ISYM0, 3920 * WORK(KW3BXVDL2),WORK(KW3BXVDL1), 3921 * WORK(KW3BXVDG2),WORK(KW3BXVDG1), 3922 * WORK(KW3BXOL1),WORK(KW3BXOG1), 3923 * ISINT2, 3924 * WORK(KEND5),LWRK5,WORK(KINDEXBL1), 3925 * WORK(KINDEXDL1),WORK(KINDSQWB),LENSQWB, 3926 * ISYMB,B,ISYMD,D) 3927C 3928 !<L1Y|[H^,tau3]|HF> 3929 CALL WBARXBD_L1(1,WORK(KL1L1),ISYML1,WORK(KWTEMP), 3930 * WORK(KXIAJB), 3931 * ISINT1,WORK(KW3BMAT),WORK(KEND5),LWRK5, 3932 * WORK(KINDSQWB),LENSQWB,ISYMB,B,ISYMD,D) 3933C 3934 CALL WBD_DIA(B,ISYMB,D,ISYMD,-FREQL1,ISWBMAT, 3935 * WORK(KW3BMAT),WORK(KDIAGWB),WORK(KFOCKD)) 3936 CALL T3_FORBIDDEN(WORK(KW3BMAT),ISYML1,ISYMB,B, 3937 * ISYMD,D) 3938C 3939 !To conform with real sign of t3b multipliers 3940 !(noddy code definition) 3941 CALL DSCAL(NCKIJ(ISWBMAT),-ONE,WORK(KW3BMAT),1) 3942c 3943c call sum_pt3(work(KW3BMAT),isymb,b,isymd,d, 3944c * ISWBMAT,work(kx3am),4) 3945c 3946C 3947C-------------------------------------------------------- 3948C Write WBMAT as WBMAT^D(ai,bj,l) to disc 3949C-------------------------------------------------------- 3950 CALL WRITE_T3_DL(LUWBMAT,FNWBMAT,WORK(KW3BMAT),ISYML1, 3951 * ISYMD,ISYMB,B) 3952 3953C 3954C-------------------------------------------------------- 3955C Get T2ZU T20 contribution to DIA density 3956C (comes from tX * A{Y} * tZU ) 3957C-------------------------------------------------------- 3958C 3959 T2XNET2Y = .TRUE. 3960 CALL CC_XI_DEN_IA(T2XNET2Y,DIA,WORK(KW3BMAT),ISWBMAT, 3961 * WORK(KT2ZU),ISYMZU, 3962 * WORK(KT2TP),ISYM0,WORK(KINDSQWB), 3963 * LENSQWB, 3964 * B,ISYMB,D,ISYMD,WORK(KEND5),LWRK5) 3965C 3966C---------------------------------------------------------- 3967C Get again T3barX_BD multipliers (using W) 3968C but now without virtual contribution: 3969C---------------------------------------------------------- 3970C 3971 3972 !reuse KW3BMAT array 3973 CALL DZERO(WORK(KW3BMAT),NCKIJ(ISWBMAT)) 3974C 3975 IF (LISTL(1:3).EQ.'L1 ') THEN 3976 3977 !<L3|[Y^,tau3]|HF> (occ. part) 3978 CALL WX_BD_O(3,.FALSE.,.TRUE.,WORK(KTMAT),ISCKIJ, 3979 * WORK(KFOCKL1), 3980 * ISYML1,WORK(KW3BMAT),ISWBMAT, 3981 * WORK(KEND5),LWRK5) 3982 3983 ! <L2|[Y,tau3]|HF> 3984 CALL WBARXBD_T2(3,B,ISYMB,D,ISYMD,WORK(KL2TP),ISYM0, 3985 * WORK(KFOCKL1), 3986 * ISYML1,WORK(KW3BMAT),ISWBMAT) 3987C 3988 3989 !<L2|[H^Y,tau3]|HF> 3990 CALL WBARXBD_TMAT(3, 3991 * WORK(KL2TP),ISYM0,WORK(KW3BMAT),WORK(KTMAT), 3992 * ISWBMAT,WORK(KFOCKL1RCK),ISYFCKL1R, 3993 * WORK(fKW3BXVDLX2),WORK(fKW3BXVDLX1), 3994 * WORK(fKW3BXVDGX2), 3995 * WORK(fKW3BXVDGX1),WORK(KW3BXOLX1), 3996 * WORK(KW3BXOGX1),ISINT2L1R, 3997 * WORK(KEND5),LWRK5, 3998 * WORK(KINDEX),WORK(KINDEX2), 3999 * WORK(KINDSQWB),LENSQWB, 4000 * ISYMB,B,ISYMD,D) 4001 END IF 4002C 4003 !<L2Y|[H^,tau3]|HF> 4004 CALL WBARXBD_TMAT(3, 4005 * WORK(KL2L1),ISYML1,WORK(KW3BMAT),WORK(KTMAT), 4006 * ISWBMAT,WORK(KFOCK0CK),ISYM0, 4007 * WORK(fKW3BXVDL2),WORK(fKW3BXVDL1), 4008 * WORK(fKW3BXVDG2),WORK(fKW3BXVDG1), 4009 * WORK(KW3BXOL1),WORK(KW3BXOG1), 4010 * ISINT2, 4011 * WORK(KEND5),LWRK5,WORK(KINDEXBL1), 4012 * WORK(KINDEXDL1),WORK(KINDSQWB),LENSQWB, 4013 * ISYMB,B,ISYMD,D) 4014C 4015 !<L1Y|[H^,tau3]|HF> 4016 CALL WBARXBD_L1(3,WORK(KL1L1),ISYML1,WORK(KTMAT), 4017 * WORK(KXIAJB), 4018 * ISINT1,WORK(KW3BMAT),WORK(KEND5),LWRK5, 4019 * WORK(KINDSQWB),LENSQWB,ISYMB,B,ISYMD,D) 4020C 4021 CALL WBD_DIA(B,ISYMB,D,ISYMD,-FREQL1,ISWBMAT, 4022 * WORK(KW3BMAT),WORK(KDIAGWB),WORK(KFOCKD)) 4023 CALL T3_FORBIDDEN(WORK(KW3BMAT),ISYML1,ISYMB,B, 4024 * ISYMD,D) 4025 !To conform with real sign of t3b multipliers 4026 !(noddy code definition) 4027 CALL DSCAL(NCKIJ(ISWBMAT),-ONE,WORK(KW3BMAT),1) 4028c 4029c call sum_pt3(work(KW3BMAT),isymb,b,isymd,d, 4030c * ISWBMAT,work(kx3am),4) 4031c 4032C 4033C-------------------------------------------------------- 4034C Write WBMAT as WBMAT^D(ai,bj,l) to disc 4035C-------------------------------------------------------- 4036 4037 CALL WRITE_T3_DL(LUWBZU,FNWBZU,WORK(KW3BMAT),ISYML1, 4038 * ISYMD,ISYMB,B) 4039 4040 CALL DZERO(WORK(KW3MATZ),NCKIJ(ISWMATZ)) 4041 CALL DZERO(WORK(KW3MATU),NCKIJ(ISWMATU)) 4042C 4043***************************************************************** 4044***************************************************************** 4045* 4046* Now we prepare 4047* theta^{abc}_{i-- j-- k--} = C^{abc}_{ijk} wZU^{abc}_{i-- j- k-} 4048* 4049***************************************************************** 4050***************************************************************** 4051C 4052 4053C 4054C===================================================================== 4055C Start with wZU^{abc}_{i-- j- k-} = 4056C 4057C = - [ P(ZU) { U_{li} wZ^{abc}_{l- j- k-} (1) 4058C 4059C + U(Z)_{li} t{abc}_{ljk} (2) 4060C 4061C + b^{abc}_{ijk}(U, t2Z, t20) (3) 4062C 4063C + A^{abc}_{ijk} (t2UZ) (4) 4064C 4065C + B^{abc}_{ijk} (t2U, t2Z) ] (5) 4066C 4067C * 1 / (epsilon^{abc}_{ijk} - omega_Z - omega_U) 4068C 4069C Permutation P(ZU) is explicit in the following ! 4070C 4071C===================================================================== 4072C 4073 4074C --------- 4075C TERM (1) 4076C --------- 4077 4078C 4079C------------------------------------------------------ 4080C Calculate wZ^{abc}_{l- j- k-} 4081C------------------------------------------------------ 4082C 4083 IF (LISTRU(1:3).EQ.'R1 ') THEN 4084 AIBJCK_PERM = 4 ! means that we transform ALL occupied 4085 ! indeces 4086 4087 ! <mu3|[Z,T30]|HF> occupied contribution 4088 4089 CALL WXBD_O(AIBJCK_PERM,WORK(KT3MAT),ISCKIJ, 4090 * WORK(KFOCKRZ),ISYMRZ, 4091 * WORK(KW3MATZ),ISWMATZ,WORK(KEND5),LWRK5) 4092C 4093 ! <mu3|[[Z,T2],T2]|HF> 4094 CALL WXBD_T2(AIBJCK_PERM,B,ISYMB,D,ISYMD, 4095 * WORK(KT2TP), 4096 * ISYM0,WORK(KFOCKRZ), 4097 * ISYMRZ,WORK(KINDSQWZ),LENSQWZ, 4098 * WORK(KW3MATZ),ISWMATZ,WORK(KEND5),LWRK5) 4099 4100 !<mu3|[H^Z,T2]|HF> + <mu3|[H,T2^Z]|HF> 4101 CALL WXBD_GROUND(AIBJCK_PERM, 4102 * WORK(KT2RZ),ISYMRZ,WORK(KWTEMP), 4103 * WORK(KT3VDG1),WORK(KT3VBG1),WORK(KT3VBG3), 4104 * WORK(KT3VDG3), 4105 * WORK(KT3OG1),ISINT2, 4106 * WORK(KW3MATZ),WORK(KEND5),LWRK5, 4107 * WORK(KINDSQWZ),LENSQWZ, 4108 * ISYMB,B,ISYMD,D) 4109C 4110 CALL WXBD_GROUND(AIBJCK_PERM, 4111 * WORK(KT2TP),ISYM0,WORK(KWTEMP), 4112 * WORK(KW3ZVDGZ1),WORK(KW3ZVDGZ2), 4113 * WORK(KT3VBGZ3),WORK(KT3VDGZ3), 4114 * WORK(KW3ZOGZ1),ISINT2RZ, 4115 * WORK(KW3MATZ),WORK(KEND5),LWRK5, 4116 * WORK(KINDSQWZ),LENSQWZ, 4117 * ISYMB,B,ISYMD,D) 4118 4119 !Divide by the energy difference and 4120 !remove the forbidden elements 4121 CALL WBD_DIA(B,ISYMB,D,ISYMD,FREQRZ,ISWMATZ, 4122 * WORK(KW3MATZ),WORK(KDIAGWZ),WORK(KFOCKD)) 4123 CALL T3_FORBIDDEN(WORK(KW3MATZ),ISYMRZ,ISYMB,B, 4124 * ISYMD,D) 4125 4126 4127c call sum_pt3(work(KW3MATZ),isymb,b,isymd,d, 4128c * ISWMATZ,work(kx3am),5) 4129 4130C 4131C------------------------------------------------------------------- 4132C Contract wZ with U operator: 4133C wZU^{abc}_{i-- j- k-} = wZU^{abc}_{i-- j- k-} 4134C + U_{li} wZ^{abc}_{l- j- k-} 4135C------------------------------------------------------------------- 4136C 4137 4138 CALL WBD_O(WORK(KW3MATZ),ISWMATZ,WORK(KFOCKRU), 4139 * ISYMRU, 4140 * WORK(KWMATZU),ISWMATZU,WORK(KEND5),LWRK5) 4141 4142c do the same to get wZU^{abc}_{i- j- k--} (put in KWMATZUD) 4143 4144 AIBJCK_PERM = 3 4145 CALL WXBD_O(AIBJCK_PERM,WORK(KW3MATZ),ISWMATZ, 4146 * WORK(KFOCKRU),ISYMRU, 4147 * WORK(KWMATZUD),ISWMATZU,WORK(KEND5),LWRK5) 4148 4149 END IF 4150 4151C --------- 4152C TERM (2) 4153C --------- 4154 4155C 4156C---------------------------------------------------------------- 4157C wZU^{abc}_{i-- j- k-} = wZU^{abc}_{i-- j- k-} 4158C + U(Z)_{li} t{abc}_{ljk} 4159C---------------------------------------------------------------- 4160C 4161 IF (LISTRU(1:3).EQ.'R1 ') THEN 4162 !Calculate <mu3|[[U,T1Z],T30]|HF> 4163 CALL WBD_O(WORK(KT3MAT),ISCKIJ,WORK(KFCKUZO),ISYMZU, 4164 * WORK(KWMATZU),ISWMATZU,WORK(KEND5),LWRK5) 4165 4166c do the same to get wZU^{abc}_{i- j- k--} (put in KWMATZUD) 4167 4168 AIBJCK_PERM = 3 4169 CALL WXBD_O(AIBJCK_PERM,WORK(KT3MAT),ISCKIJ, 4170 * WORK(KFCKUZO),ISYMZU, 4171 * WORK(KWMATZUD),ISWMATZU,WORK(KEND5),LWRK5) 4172 END IF 4173 4174C --------- 4175C TERM (3) 4176C --------- 4177 4178C 4179C-------------------------------------------------------------------- 4180C wZU^{abc}_{i-- j- k-} = wZU^{abc}_{i-- j- k-} 4181C + b^{abc}_{ijk}(U, t2Z, t20) 4182C-------------------------------------------------------------------- 4183C 4184 IF (LISTRU(1:3).EQ.'R1 ') THEN 4185 !Calculate <mu3|[[U,T2Z],T20]|HF> 4186 T2XNET2Z = .TRUE. 4187 CALL WBD_T2(T2XNET2Z,B,ISYMB,D,ISYMD, 4188 * WORK(KT2RZ),ISYMRZ,WORK(KT2TP),ISYM0, 4189 * WORK(KFOCKRU),ISYMRU, 4190 * WORK(KINDSQWZU),LENSQWZU,WORK(KWMATZU), 4191 * ISWMATZU,WORK(KEND5),LWRK5) 4192 4193c do the same to get wZU^{abc}_{i- j- k--} (put in KWMATZUD) 4194 4195 T2XNET2Z = .TRUE. 4196 AIBJCK_PERM = 3 4197 CALL WXBD_T2_CUB(T2XNET2Z,AIBJCK_PERM,B,ISYMB,D, 4198 * ISYMD, 4199 * WORK(KT2RZ),ISYMRZ,WORK(KT2TP),ISYM0, 4200 * WORK(KFOCKRU),ISYMRU, 4201 * WORK(KINDSQWZU),LENSQWZU,WORK(KWMATZUD), 4202 * ISWMATZU,WORK(KEND5),LWRK5) 4203 END IF 4204 4205C --------- 4206C TERM (4) 4207C --------- 4208 !P(ZU) permutation does not apply here: see the formula 4209C 4210C------------------------------------------------------ 4211C Calculate A^{abc}_{ijk} (t2UZ) 4212C------------------------------------------------------ 4213C 4214 !<mu3|[[H,T1^ZU],T2^0]|HF> 4215 AIBJCK_PERM = 1 ! means wZU^{abc}_{i-- j- k-} 4216 CALL WXBD_GROUND(AIBJCK_PERM, 4217 * WORK(KT2TP),ISYM0,WORK(KWTEMP), 4218 * WORK(KWZUVDGR21),WORK(KWZUVDGR22), 4219 * WORK(KWZUVBGR23),WORK(KWZUVDGR23), 4220 * WORK(KWZUOGR21),ISINT2RZU, 4221 * WORK(KWMATZU),WORK(KEND5),LWRK5, 4222 * WORK(KINDSQWZU),LENSQWZU, 4223 * ISYMB,B,ISYMD,D) 4224 4225 !<mu3|[H^0,T2^ZU]|HF> 4226 AIBJCK_PERM = 1 ! means wZU^{abc}_{i-- j- k-} 4227 CALL WXBD_GROUND(AIBJCK_PERM, 4228 * WORK(KT2ZU),ISYMZU,WORK(KWTEMP), 4229 * WORK(KT3VDG1),WORK(KT3VBG1),WORK(KT3VBG3), 4230 * WORK(KT3VDG3), 4231 * WORK(KT3OG1),ISINT2, 4232 * WORK(KWMATZU),WORK(KEND5),LWRK5, 4233 * WORK(KINDSQWZU),LENSQWZU, 4234 * ISYMB,B,ISYMD,D) 4235 4236c do the same to get wZU^{abc}_{i- j- k--} (put in KWMATZUD) 4237 4238 !<mu3|[[H,T1^ZU],T2^0]|HF> 4239 AIBJCK_PERM = 3 ! means wZU^{abc}_{i- j- k--} 4240 CALL WXBD_GROUND(AIBJCK_PERM, 4241 * WORK(KT2TP),ISYM0,WORK(KWTEMP), 4242 * WORK(KWZUVDGR21),WORK(KWZUVDGR22), 4243 * WORK(KWZUVBGR23),WORK(KWZUVDGR23), 4244 * WORK(KWZUOGR21),ISINT2RZU, 4245 * WORK(KWMATZUD),WORK(KEND5),LWRK5, 4246 * WORK(KINDSQWZU),LENSQWZU, 4247 * ISYMB,B,ISYMD,D) 4248 4249 !<mu3|[H^0,T2^ZU]|HF> 4250 AIBJCK_PERM = 3 ! means wZU^{abc}_{i- j- k--} 4251 CALL WXBD_GROUND(AIBJCK_PERM, 4252 * WORK(KT2ZU),ISYMZU,WORK(KWTEMP), 4253 * WORK(KT3VDG1),WORK(KT3VBG1),WORK(KT3VBG3), 4254 * WORK(KT3VDG3), 4255 * WORK(KT3OG1),ISINT2, 4256 * WORK(KWMATZUD),WORK(KEND5),LWRK5, 4257 * WORK(KINDSQWZU),LENSQWZU, 4258 * ISYMB,B,ISYMD,D) 4259 4260C --------- 4261C TERM (5) 4262C --------- 4263 4264C 4265C------------------------------------------------------ 4266C Calculate B^{abc}_{ijk} (t2U, t2Z) 4267C------------------------------------------------------ 4268C 4269 4270 !<mu3|[H^U,T2^Z]|HF> 4271 AIBJCK_PERM = 1 ! means wZU^{abc}_{i-- j- k-} 4272 CALL WXBD_GROUND(AIBJCK_PERM, 4273 * WORK(KT2RZ),ISYMRZ,WORK(KWTEMP), 4274 * WORK(KW3UVDGU1),WORK(KW3UVDGU2), 4275 * WORK(KT3VBGU3), 4276 * WORK(KT3VDGU3), 4277 * WORK(KW3UOGU1),ISINT2RU, 4278 * WORK(KWMATZU),WORK(KEND5),LWRK5, 4279 * WORK(KINDSQWZU),LENSQWZU, 4280 * ISYMB,B,ISYMD,D) 4281 4282 !<mu3|[[[H,T1^Z],T1^U],T2^0]|HF> 4283 4284 !P(ZU) permutation taken into account here simply by 4285 ! skipping the factor 1/2 from the formula. 4286 ! Thus there is no need to have this term again in the 4287 ! "permutation" part of this routine. 4288 4289 AIBJCK_PERM = 1 ! means wZU^{abc}_{i-- j- k-} 4290 CALL WXBD_GROUND(AIBJCK_PERM, 4291 * WORK(KT2TP),ISYM0,WORK(KWTEMP), 4292 * WORK(KW3ZUVDGZU1),WORK(KW3ZUVDGZU2), 4293 * WORK(KT3VBGZU3),WORK(KT3VDGZU3), 4294 * WORK(KW3ZUOGZU1),ISINT2RZU, 4295 * WORK(KWMATZU),WORK(KEND5),LWRK5, 4296 * WORK(KINDSQWZU),LENSQWZU, 4297 * ISYMB,B,ISYMD,D) 4298 4299 4300c do the same to get wZU^{abc}_{i- j- k--} (put in KWMATZUD) 4301 4302 !<mu3|[H^U,T2^Z]|HF> 4303 AIBJCK_PERM = 3 !means wZU^{abc}_{i- j- k--} (put in KWMATZUD) 4304 CALL WXBD_GROUND(AIBJCK_PERM, 4305 * WORK(KT2RZ),ISYMRZ,WORK(KWTEMP), 4306 * WORK(KW3UVDGU1),WORK(KW3UVDGU2), 4307 * WORK(KT3VBGU3), 4308 * WORK(KT3VDGU3), 4309 * WORK(KW3UOGU1),ISINT2RU, 4310 * WORK(KWMATZUD),WORK(KEND5),LWRK5, 4311 * WORK(KINDSQWZU),LENSQWZU, 4312 * ISYMB,B,ISYMD,D) 4313 !<mu3|[[[H,T1^Z],T1^U],T2^0]|HF> 4314 AIBJCK_PERM = 3 !means wZU^{abc}_{i- j- k--} (put in KWMATZUD) 4315 CALL WXBD_GROUND(AIBJCK_PERM, 4316 * WORK(KT2TP),ISYM0,WORK(KWTEMP), 4317 * WORK(KW3ZUVDGZU1),WORK(KW3ZUVDGZU2), 4318 * WORK(KT3VBGZU3),WORK(KT3VDGZU3), 4319 * WORK(KW3ZUOGZU1),ISINT2RZU, 4320 * WORK(KWMATZUD),WORK(KEND5),LWRK5, 4321 * WORK(KINDSQWZU),LENSQWZU, 4322 * ISYMB,B,ISYMD,D) 4323 4324 4325 4326 4327 4328 4329 4330 !Divide by the energy difference and 4331 !remove the forbidden elements (here only for debugging) 4332 4333c call wbd_dia(b,isymb,d,isymd,freqzu,iswmatzu, 4334c * work(kwmatzu),work(kdiagwzu),work(kfockd)) 4335c call t3_forbidden(work(kwmatzu),isymzu,isymb,b, 4336c * isymd,d) 4337 4338 4339c call sum_pt3(work(KWMATZU),isymb,b,isymd,d, 4340c * ISWMATZU,work(kx3am),5) 4341 4342 4343C ------------------------------------- 4344C Repeat the TERMS (1)--(3) to include 4345C P(ZU) PERMUTATION explicitly 4346C ------------------------------------- 4347 4348 4349C --------- 4350C TERM (1) (permuted) 4351C --------- 4352 4353C 4354C------------------------------------------------------ 4355C Calculate wU^{abc}_{l- j- k-} 4356C------------------------------------------------------ 4357C 4358 AIBJCK_PERM = 4 ! means that we transform ALL occupied 4359 ! indeces 4360 4361 IF (LISTRU(1:3).EQ.'R1 ') THEN 4362 ! <mu3|[U,T30]|HF> occupied contribution 4363 CALL WXBD_O(AIBJCK_PERM,WORK(KT3MAT),ISCKIJ, 4364 * WORK(KFOCKRU),ISYMRU, 4365 * WORK(KW3MATU),ISWMATU,WORK(KEND5),LWRK5) 4366C 4367 ! <mu3|[[U,T2],T2]|HF> 4368 CALL WXBD_T2(AIBJCK_PERM,B,ISYMB,D,ISYMD, 4369 * WORK(KT2TP), 4370 * ISYM0,WORK(KFOCKRU), 4371 * ISYMRU,WORK(KINDSQWU),LENSQWU, 4372 * WORK(KW3MATU),ISWMATU,WORK(KEND5),LWRK5) 4373 END IF 4374 4375 !<mu3|[H^U,T2]|HF> + <mu3|[H,T2^U]|HF> 4376 CALL WXBD_GROUND(AIBJCK_PERM, 4377 * WORK(KT2RU),ISYMRU,WORK(KWTEMP), 4378 * WORK(KT3VDG1),WORK(KT3VBG1),WORK(KT3VBG3), 4379 * WORK(KT3VDG3), 4380 * WORK(KT3OG1),ISINT2, 4381 * WORK(KW3MATU),WORK(KEND5),LWRK5, 4382 * WORK(KINDSQWU),LENSQWU, 4383 * ISYMB,B,ISYMD,D) 4384C 4385 CALL WXBD_GROUND(AIBJCK_PERM, 4386 * WORK(KT2TP),ISYM0,WORK(KWTEMP), 4387 * WORK(KW3UVDGU1),WORK(KW3UVDGU2), 4388 * WORK(KT3VBGU3),WORK(KT3VDGU3), 4389 * WORK(KW3UOGU1),ISINT2RU, 4390 * WORK(KW3MATU),WORK(KEND5),LWRK5, 4391 * WORK(KINDSQWU),LENSQWU, 4392 * ISYMB,B,ISYMD,D) 4393 4394 !Divide by the energy difference and 4395 !remove the forbidden elements 4396 CALL WBD_DIA(B,ISYMB,D,ISYMD,FREQRU,ISWMATU, 4397 * WORK(KW3MATU),WORK(KDIAGWU),WORK(KFOCKD)) 4398 CALL T3_FORBIDDEN(WORK(KW3MATU),ISYMRU,ISYMB,B, 4399 * ISYMD,D) 4400 4401 4402c call sum_pt3(work(KW3MATU),isymb,b,isymd,d, 4403c * ISWMATU,work(kx3am),5) 4404 4405C 4406C------------------------------------------------------------------- 4407C Contract wU with Z operator: 4408C wZU^{abc}_{i-- j- k-} = wZU^{abc}_{i-- j- k-} 4409C + Z_{li} wU^{abc}_{l- j- k-} 4410C------------------------------------------------------------------- 4411C 4412 CALL WBD_O(WORK(KW3MATU),ISWMATU,WORK(KFOCKRZ),ISYMRZ, 4413 * WORK(KWMATZU),ISWMATZU,WORK(KEND5),LWRK5) 4414 4415 4416c do the same to get wZU^{abc}_{i- j- k--} (put in KWMATZUD) 4417 4418 AIBJCK_PERM = 3 4419 CALL WXBD_O(AIBJCK_PERM,WORK(KW3MATU),ISWMATU, 4420 * WORK(KFOCKRZ),ISYMRZ, 4421 * WORK(KWMATZUD),ISWMATZU,WORK(KEND5),LWRK5) 4422 4423C --------- 4424C TERM (2) (permuted) 4425C --------- 4426 4427C 4428C---------------------------------------------------------------- 4429C wZU^{abc}_{i-- j- k-} = wZU^{abc}_{i-- j- k-} 4430C + Z(U)_{li} t{abc}_{ljk} 4431C---------------------------------------------------------------- 4432C 4433 !Calculate <mu3|[[Z,T1U],T30]|HF> 4434 CALL WBD_O(WORK(KT3MAT),ISCKIJ,WORK(KFCKZUO),ISYMZU, 4435 * WORK(KWMATZU),ISWMATZU,WORK(KEND5),LWRK5) 4436 4437 4438c do the same to get wZU^{abc}_{i- j- k--} (put in KWMATZUD) 4439 4440 AIBJCK_PERM = 3 4441 CALL WXBD_O(AIBJCK_PERM,WORK(KT3MAT),ISCKIJ, 4442 * WORK(KFCKZUO),ISYMZU, 4443 * WORK(KWMATZUD),ISWMATZU,WORK(KEND5),LWRK5) 4444 4445C --------- 4446C TERM (3) (permuted) 4447C --------- 4448 4449C 4450C-------------------------------------------------------------------- 4451C wZU^{abc}_{i-- j- k-} = wZU^{abc}_{i-- j- k-} 4452C + b^{abc}_{ijk}(Z, t2U, t20) 4453C-------------------------------------------------------------------- 4454C 4455 !Calculate <mu3|[[Z,T2U],T20]|HF> 4456 T2XNET2Z = .TRUE. 4457 CALL WBD_T2(T2XNET2Z,B,ISYMB,D,ISYMD, 4458 * WORK(KT2RU),ISYMRU,WORK(KT2TP),ISYM0, 4459 * WORK(KFOCKRZ),ISYMRZ, 4460 * WORK(KINDSQWZU),LENSQWZU,WORK(KWMATZU), 4461 * ISWMATZU,WORK(KEND5),LWRK5) 4462 4463 4464c do the same to get wZU^{abc}_{i- j- k--} (put in KWMATZUD) 4465 T2XNET2Z = .TRUE. 4466 AIBJCK_PERM = 3 4467 CALL WXBD_T2_CUB(T2XNET2Z,AIBJCK_PERM,B,ISYMB,D,ISYMD, 4468 * WORK(KT2RU),ISYMRU, 4469 * WORK(KT2TP),ISYM0,WORK(KFOCKRZ),ISYMRZ, 4470 * WORK(KINDSQWZU),LENSQWZU,WORK(KWMATZUD), 4471 * ISWMATZU,WORK(KEND5),LWRK5) 4472 4473C --------- 4474C TERM (5) (permuted) 4475C --------- 4476 4477C 4478C------------------------------------------------------ 4479C Calculate B^{abc}_{ijk} (t2Z, t2U) 4480C------------------------------------------------------ 4481C 4482 4483 !<mu3|[H^Z,T2^U]|HF> 4484 AIBJCK_PERM = 1 ! means wZU^{abc}_{i-- j- k-} 4485 CALL WXBD_GROUND(AIBJCK_PERM, 4486 * WORK(KT2RU),ISYMRU,WORK(KWTEMP), 4487 * WORK(KW3ZVDGZ1),WORK(KW3ZVDGZ2), 4488 * WORK(KT3VBGZ3), 4489 * WORK(KT3VDGZ3), 4490 * WORK(KW3ZOGZ1),ISINT2RZ, 4491 * WORK(KWMATZU),WORK(KEND5),LWRK5, 4492 * WORK(KINDSQWZU),LENSQWZU, 4493 * ISYMB,B,ISYMD,D) 4494 4495c do the same to get wZU^{abc}_{i- j- k--} (put in KWMATZUD) 4496 4497 !<mu3|[H^Z,T2^U]|HF> 4498 AIBJCK_PERM = 3 !means wZU^{abc}_{i- j- k--} (put in KWMATZUD) 4499 CALL WXBD_GROUND(AIBJCK_PERM, 4500 * WORK(KT2RU),ISYMRU,WORK(KWTEMP), 4501 * WORK(KW3ZVDGZ1),WORK(KW3ZVDGZ2), 4502 * WORK(KT3VBGZ3), 4503 * WORK(KT3VDGZ3), 4504 * WORK(KW3ZOGZ1),ISINT2RZ, 4505 * WORK(KWMATZUD),WORK(KEND5),LWRK5, 4506 * WORK(KINDSQWZU),LENSQWZU, 4507 * ISYMB,B,ISYMD,D) 4508 4509 4510 4511 4512 !Divide by the energy difference and 4513 !remove the forbidden elements 4514 CALL WBD_DIA(B,ISYMB,D,ISYMD,FREQZU,ISWMATZU, 4515 * WORK(KWMATZU),WORK(KDIAGWZU),WORK(KFOCKD)) 4516 CALL T3_FORBIDDEN(WORK(KWMATZU),ISYMZU,ISYMB,B, 4517 * ISYMD,D) 4518 4519 4520c call sum_pt3(work(KWMATZU),isymb,b,isymd,d, 4521c * ISWMATZU,work(kx3am),5) 4522 4523 4524c do the same for wZU^{abc}_{i- j- k--} (put in KWMATZUD) 4525 4526 !Divide by the energy difference and 4527 !remove the forbidden elements 4528 CALL WBD_DIA(B,ISYMB,D,ISYMD,FREQZU,ISWMATZU, 4529 * WORK(KWMATZUD),WORK(KDIAGWZU),WORK(KFOCKD)) 4530 CALL T3_FORBIDDEN(WORK(KWMATZUD),ISYMZU,ISYMB,B, 4531 * ISYMD,D) 4532 4533c call sum_pt3(work(KWMATZUD),isymb,b,isymd,d, 4534c * ISWMATZU,work(kx3am),5) 4535 4536 4537c get now wtildeU^{abc}_{ijk} = (1 + 0.5 P(ck,ai) ) wZU^{abc}_{i-- j- k-} 4538 4539 CALL DAXPY(NCKIJ(ISWMATZU),HALF,WORK(KWMATZUD),1, 4540 * WORK(KWMATZU),1) 4541 4542C----------------------------------------------------------------------- 4543C Write WORK(KWMATZU) + 0.5*WORK(KWMATZUD) as KW3MATZU^D(ai,bj,l) to disc 4544C----------------------------------------------------------------------- 4545 !To conform with noddy code 4546 CALL DSCAL(NCKIJ(ISWMATZU),-ONE,WORK(KWMATZU),1) 4547C 4548 4549 CALL WRITE_T3_DL(LUTHETA,FNTHETA,WORK(KWMATZU),ISYMZU, 4550 * ISYMD,ISYMB,B) 4551 4552 4553C ...now KWMATZU and KWMATZUD can be reused... 4554 4555 4556C 4557***************************************************************** 4558***************************************************************** 4559* 4560* Now we prepare 4561* wZU^{a- bc}_{i- j- k-} = w^{a- bc}_{i- j- k-} = theta^{a- bc}_{i- j- k-} 4562* 4563***************************************************************** 4564***************************************************************** 4565C 4566 4567C 4568C===================================================================== 4569C wZU^{a- bc}_{i- j- k-} = 4570C 4571C = - [ P(ZU) { U_{ad} wZ^{dbc}_{i- j- k-} (1) 4572C 4573C + U(Z)_{ad} t{dbc}_{ijk} (2) 4574C 4575C + U_{li} thetaZ^{a- bc}_{ljk} (3) 4576C 4577C + U_{lj} thetaZ^{a- bc}_{ilk} (4) 4578C 4579C + U_{lk} thetaZ^{a- bc}_{ijl} ] (5) 4580C 4581C * 1 / (epsilon^{abc}_{ijk} - omega_Z - omega_U) 4582C 4583C Permutation P(ZU) is explicit in the following ! 4584C 4585C===================================================================== 4586C 4587 4588 4589C We will reuse here KWMATZU 4590 CALL DZERO(WORK(KWMATZU),NCKIJ(ISWMATZU)) 4591 4592C --------- 4593C TERM (1) 4594C --------- 4595 4596C 4597C-------------------------------------------------------------------- 4598C wZU^{a- bc}_{i- j- k-} = wZU^{a- bc}_{i- j- k-} 4599C + U_{ad} wZ^{dbc}_{i- j- k-} 4600C-------------------------------------------------------------------- 4601C 4602 4603C wZ^{abc}_{l- j- k-} is already there sitting in 4604C KW3MATZ array. 4605 4606 IF (LISTRU(1:3).EQ.'R1 ') THEN 4607 CALL WBD_V(WORK(KW3MATZ),ISWMATZ,WORK(KFOCKRU), 4608 * ISYMRU, 4609 * WORK(KWMATZU),ISWMATZU,WORK(KEND5),LWRK5) 4610 END IF 4611 4612C --------- 4613C TERM (1) (permuted) 4614C --------- 4615 4616C 4617C-------------------------------------------------------------------- 4618C wZU^{a- bc}_{i- j- k-} = wZU^{a- bc}_{i- j- k-} 4619C + Z_{ad} wU^{dbc}_{i- j- k-} 4620C-------------------------------------------------------------------- 4621C 4622 4623C wU^{abc}_{l- j- k-} is already there sitting in 4624C KW3MATU array. 4625 4626 CALL WBD_V(WORK(KW3MATU),ISWMATU,WORK(KFOCKRZ),ISYMRZ, 4627 * WORK(KWMATZU),ISWMATZU,WORK(KEND5),LWRK5) 4628 4629 4630C --------- 4631C TERM (2) 4632C --------- 4633 4634C 4635C-------------------------------------------------------------------- 4636C wZU^{a- bc}_{i- j- k-} = wZU^{a- bc}_{i- j- k-} 4637C + Z(U)_{ad} t{dbc}_{ijk} 4638C-------------------------------------------------------------------- 4639C 4640 4641C t{dbc}_{ijk} is already there sitting in 4642C KT3MAT array. 4643 4644 !Calculate <mu3|[[Z,T1U],T30]|HF> 4645 CALL WBD_V(WORK(KT3MAT),ISCKIJ,WORK(KFCKZUV),ISYMZU, 4646 * WORK(KWMATZU),ISWMATZU,WORK(KEND5),LWRK5) 4647 4648C --------- 4649C TERM (2) (permuted) 4650C --------- 4651 4652C 4653C-------------------------------------------------------------------- 4654C wZU^{a- bc}_{i- j- k-} = wZU^{a- bc}_{i- j- k-} 4655C + U(Z)_{ad} t{dbc}_{ijk} 4656C-------------------------------------------------------------------- 4657C 4658 4659C t{dbc}_{ijk} is already there sitting in 4660C KT3MAT array. 4661 4662 IF (LISTRU(1:3).EQ.'R1 ') THEN 4663 !Calculate <mu3|[[U,T1Z],T30]|HF> 4664 CALL WBD_V(WORK(KT3MAT),ISCKIJ,WORK(KFCKUZV),ISYMZU, 4665 * WORK(KWMATZU),ISWMATZU,WORK(KEND5),LWRK5) 4666 END IF 4667 4668 IF (LISTRU(1:3).EQ.'R1 ') THEN 4669C --------------------- 4670C TERM (3) + (4) + (5) 4671C --------------------- 4672 4673C 4674C------------------------------------------------------------------------- 4675C wZU^{a- bc}_{i- j- k-} = wZU^{a- bc}_{i- j- k-} 4676C + U_{li} thetaZ^{a- bc}_{ljk} (3) 4677C + U_{lj} thetaZ^{a- bc}_{ilk} (4) 4678C + U_{lk} thetaZ^{a- bc}_{ijl} (5) 4679C------------------------------------------------------------------------- 4680C 4681 4682C------------------------------------------------------- 4683C First we need thetaZ^{a- bc}_{ijk}... 4684C------------------------------------------------------- 4685 4686C Let's reuse KW3MATZ array 4687 CALL DZERO(WORK(KW3MATZ),NCKIJ(ISWMATZ)) 4688 4689 ! <mu3|[Z,T30]|HF> virtual contribution 4690 CALL WBD_V(WORK(KT3MAT),ISCKIJ, 4691 * WORK(KFOCKRZ),ISYMRZ, 4692 * WORK(KW3MATZ),ISWMATZ,WORK(KEND5),LWRK5) 4693 4694 !Divide by the energy difference and 4695 !remove the forbidden elements 4696 CALL WBD_DIA(B,ISYMB,D,ISYMD,FREQRZ,ISWMATZ, 4697 * WORK(KW3MATZ),WORK(KDIAGWZ),WORK(KFOCKD)) 4698 CALL T3_FORBIDDEN(WORK(KW3MATZ),ISYMRZ,ISYMB,B, 4699 * ISYMD,D) 4700 4701 4702c call sum_pt3(work(KW3MATZ),isymb,b,isymd,d, 4703c * ISWMATZ,work(kx3am),5) 4704 4705C 4706C------------------------------------------------------------------------- 4707C Now contract thetaZ with U operator: 4708C wZU^{a- bc}_{i- j- k-} = wZU^{a- bc}_{i- j- k-} 4709C + U_{li} thetaZ^{a- bc}_{ljk} 4710C + U_{lj} thetaZ^{a- bc}_{ilk} 4711C + U_{lk} thetaZ^{a- bc}_{ijl} 4712C------------------------------------------------------------------------- 4713C 4714 4715 AIBJCK_PERM = 4 ! transform all occ indeces simultanously 4716 CALL WXBD_O(AIBJCK_PERM,WORK(KW3MATZ),ISWMATZ, 4717 * WORK(KFOCKRU),ISYMRU, 4718 * WORK(KWMATZU),ISWMATZU,WORK(KEND5),LWRK5) 4719 4720C --------------------- 4721C TERM (3) + (4) + (5) (permuted) 4722C --------------------- 4723 4724C 4725C------------------------------------------------------------------------- 4726C wZU^{a- bc}_{i- j- k-} = wZU^{a- bc}_{i- j- k-} 4727C + Z_{li} thetaU^{a- bc}_{ljk} (3) 4728C + Z_{lj} thetaU^{a- bc}_{ilk} (4) 4729C + Z_{lk} thetaU^{a- bc}_{ijl} (5) 4730C------------------------------------------------------------------------- 4731C 4732 4733C------------------------------------------------------- 4734C First we need thetaU^{a- bc}_{ijk}... 4735C------------------------------------------------------- 4736 4737C Let's reuse KW3MATU array 4738 CALL DZERO(WORK(KW3MATU),NCKIJ(ISWMATU)) 4739 4740 ! <mu3|[U,T30]|HF> virtual contribution 4741 CALL WBD_V(WORK(KT3MAT),ISCKIJ, 4742 * WORK(KFOCKRU),ISYMRU, 4743 * WORK(KW3MATU),ISWMATU,WORK(KEND5),LWRK5) 4744 4745 !Divide by the energy difference and 4746 !remove the forbidden elements 4747 CALL WBD_DIA(B,ISYMB,D,ISYMD,FREQRU,ISWMATU, 4748 * WORK(KW3MATU),WORK(KDIAGWU),WORK(KFOCKD)) 4749 CALL T3_FORBIDDEN(WORK(KW3MATU),ISYMRU,ISYMB,B, 4750 * ISYMD,D) 4751 4752 4753c call sum_pt3(work(KW3MATU),isymb,b,isymd,d, 4754c * ISWMATU,work(kx3am),5) 4755 4756C 4757C------------------------------------------------------------------------- 4758C Now contract thetaU with Z operator: 4759C wZU^{a- bc}_{i- j- k-} = wZU^{a- bc}_{i- j- k-} 4760C + Z_{li} thetaU^{a- bc}_{ljk} 4761C + Z_{lj} thetaU^{a- bc}_{ilk} 4762C + Z_{lk} thetaU^{a- bc}_{ijl} 4763C------------------------------------------------------------------------- 4764C 4765 4766 AIBJCK_PERM = 4 ! transform all occ indeces simultanously 4767 CALL WXBD_O(AIBJCK_PERM,WORK(KW3MATU),ISWMATU, 4768 * WORK(KFOCKRZ),ISYMRZ, 4769 * WORK(KWMATZU),ISWMATZU,WORK(KEND5),LWRK5) 4770 4771 END IF ! LISTRU .EQ. 'R1 ' 4772C 4773 !Divide by the energy difference and 4774 !remove the forbidden elements 4775 CALL WBD_DIA(B,ISYMB,D,ISYMD,FREQZU,ISWMATZU, 4776 * WORK(KWMATZU),WORK(KDIAGWZU),WORK(KFOCKD)) 4777 CALL T3_FORBIDDEN(WORK(KWMATZU),ISYMZU,ISYMB,B, 4778 * ISYMD,D) 4779 4780 4781c call sum_pt3(work(KWMATZU),isymb,b,isymd,d, 4782c * ISWMATZU,work(kx3am),5) 4783 4784C----------------------------------------------------------------------- 4785C Write wZU^{a- bc}_{i- j- k-} to file 4786C----------------------------------------------------------------------- 4787 !To conform with noddy code 4788 CALL DSCAL(NCKIJ(ISWMATZU),-ONE,WORK(KWMATZU),1) 4789C 4790 CALL WRITE_T3_DL(LUWZU,FNWZU,WORK(KWMATZU),ISYMZU, 4791 * ISYMD,ISYMB,B) 4792 4793C 4794 !To conform with real sign of t3 amplitudes 4795 CALL DSCAL(NCKIJ(ISCKIJ),-ONE,WORK(KT3MAT),1) 4796C------------------------------------------------------------- 4797C Write T3 amplitudes as T3^D(ai,bj,l) to disc 4798C------------------------------------------------------------- 4799 CALL WRITE_T3_DL(LUT3,FNT3,WORK(KT3MAT),ISYM0, 4800 * ISYMD,ISYMB,B) 4801C 4802C 4803 ENDDO ! B 4804 ENDDO ! ISYMB 4805C 4806C------------------------------------------------------- 4807C Get DAB0 and DIJ0 densities 4808C------------------------------------------------------- 4809C 4810 QUADR = .FALSE. 4811 CALL CC_XI_DEN_ABIJ(QUADR,LISTR,WORK(KDAB0),WORK(KDIJ0), 4812 * .FALSE.,DUMMY, 4813 * DUMMY,IDUMMY, 4814 * IDUMMY,DUMMY, 4815 * ISYM0,ISYML1,IDUMMY, 4816 * LUT3,FNT3,LUWBMAT,FNWBMAT, 4817 * IDUMMY,CDUMMY, 4818 * DUMMY,DUMMY, 4819 * WORK(KEND5),LWRK5,ISYMD,D) 4820 4821C 4822C------------------------------------------------------- 4823C Get DAB and DIJ densities 4824C------------------------------------------------------- 4825C 4826 CUBIC = .TRUE. 4827 CALL CC_XI_DEN_ABIJ_CUB(CUBIC,LISTL,LISTRZ,LISTRU, 4828 * DAB,DIJ,DIA,ISYDEN, 4829 * WORK(KL2L1),ISYML1, 4830 * ISYMRZ,WORK(KFOCKRZ), 4831 * ISYMRU,WORK(KFOCKRU), 4832 * ISYM0,ISYML1,ISYMZU, 4833 * LUT3,FNT3,LUWBMAT,FNWBMAT, 4834 * LUTHETA,FNTHETA, 4835 * LUWZU,FNWZU, 4836 * LUWBZU,FNWBZU, 4837 * WORK(KFOCKD),FREQRZ,FREQRU, 4838 * WORK(KEND5),LWRK5,ISYMD,D) 4839C 4840 ENDDO ! D 4841 ENDDO ! ISYMD 4842C 4843 CALL CC3_XI_DEN_AI_T1(DIA,ISYDEN,WORK(KDAB0),WORK(KDIJ0),ISYML1, 4844 * WORK(KT1ZU),ISYMZU) 4845C 4846c write(lupri,*) 'w3x (usual) in CC3_ADENVIR_CUB' 4847c write(lupri,*) 'w3xD in CC3_ADENVIR_CUB' 4848c write(lupri,*) 'w3bx in CC3_ADENVIR_CUB' 4849c write(lupri,*) 'w3x + 0.5w3xD in CC3_ADENVIR_CUB' 4850c write(lupri,*) 'w3zu in CC3_ADENVIR_CUB' 4851c call print_pt3(work(kx3am),ISYM0,4) 4852C 4853C--------------------------------- 4854C Close the files 4855C--------------------------------- 4856C 4857 CALL WCLOSE2(LUT3,FNT3,'DELETE') 4858 CALL WCLOSE2(LUWBMAT,FNWBMAT,'DELETE') 4859 CALL WCLOSE2(LUWBZU,FNWBZU,'DELETE') 4860 CALL WCLOSE2(LUTHETA,FNTHETA,'DELETE') 4861 CALL WCLOSE2(LUWZU,FNWZU,'DELETE') 4862C 4863C-------------------------------- 4864C Close files for "response" 4865C-------------------------------- 4866C 4867 CALL WCLOSE2(LU3SRTR,FN3SRTR,'DELETE') 4868 CALL WCLOSE2(LUCKJDRZ,FNCKJDRZ,'DELETE') 4869 CALL WCLOSE2(LUDELDRZ,FNDELDRZ,'DELETE') 4870 CALL WCLOSE2(LUDKBCRZ,FNDKBCRZ,'DELETE') 4871C 4872 CALL WCLOSE2(LUCKJDRU,FNCKJDRU,'DELETE') 4873 CALL WCLOSE2(LUDELDRU,FNDELDRU,'DELETE') 4874 CALL WCLOSE2(LUDKBCRU,FNDKBCRU,'DELETE') 4875C 4876 CALL WCLOSE2(LUCKJDRZU,FNCKJDRZU,'DELETE') 4877 CALL WCLOSE2(LUDELDRZU,FNDELDRZU,'DELETE') 4878 CALL WCLOSE2(LUDKBCRZU,FNDKBCRZU,'DELETE') 4879C 4880 CALL WCLOSE2(LUCKJDR2,FNCKJDR2,'DELETE') 4881 CALL WCLOSE2(LUDELDR2,FNDELDR2,'DELETE') 4882 CALL WCLOSE2(LUDKBCR2,FNDKBCR2,'DELETE') 4883C 4884C------------- 4885C End 4886C------------- 4887C 4888C 4889 CALL QEXIT('CC3DENVCB') 4890C 4891 RETURN 4892 END 4893C /* Deck wbarxbd_t2 */ 4894 SUBROUTINE WBARXBD_T2(AIBJCK_PERM,B,ISYMB,D,ISYMD,T2TP,ISYMT2, 4895 * FOCKY,ISYFKY,WMAT,ISWMAT) 4896C 4897C IF (AIBJCK_PERM = 1) THEN (aibjdk + aidkbj permutation) 4898C 4899C WBD(a,i,k,j) = WBD(a,i,k,j) + 4900C focky(j,B)*t2(ai,Dk) - focky(k,B)*t2(ai,Dj) 4901C focky(k,D)*t2(ai,Bj) - focky(j,D)*t2(ai,Bk) 4902C 4903C ELSE IF (AIBJCK_PERM = 3) THEN (dkbjai + dkaibj permutation) 4904C focky(j,B)*t2(Dk,ai) - focky(i,B)*t2(Dk,aj) 4905C focky(i,a)*t2(Dk,Bj) - focky(j,a)*t2(Dk,Bi) 4906C 4907C ELSE quit with the error message. 4908C 4909C 4910C Written by P. Jorgensen and F. Pawlowski, Spring 2002. 4911C (modified for AIBJCK_PERM option, Autumn 2003.) 4912C 4913 4914 IMPLICIT NONE 4915C 4916 INTEGER AIBJCK_PERM 4917 INTEGER ISYMB, ISYMD, ISYMT2, ISYFKY, ISWMAT 4918 INTEGER ISYMJ, KJB, KJD, ISYMK, KKB, KKD, ISYMI, ISYIJ, ISYIK 4919 INTEGER ISYMA, ISYAI, ISYAIK, ISYAIJ, KAIKD, KAIJD, KAIJB 4920 INTEGER KAIKB, KAIKJ 4921C 4922 INTEGER ISYDK,ISYDKI,KDKIA,ISYAJK,ISYAK,ISYDKJ,KIB,KDKJA 4923 INTEGER ISYBD,ISYKJ,KIA,KDKJB,ISYKI,KJA,KDKIB 4924C 4925#if defined (SYS_CRAY) 4926 REAL T2TP(*), FOCKY(*), WMAT(*) 4927#else 4928 DOUBLE PRECISION T2TP(*), FOCKY(*), WMAT(*) 4929#endif 4930C 4931#include "priunit.h" 4932#include "ccsdsym.h" 4933#include "ccorb.h" 4934#include "ccsdinp.h" 4935C 4936 CALL QENTER('WBXT2') 4937 4938 IF (AIBJCK_PERM .EQ. 1) THEN 4939C 4940C focky(j,B)*t2(ai,Dk) - focky(k,B)*t2(ai,Dj) 4941C focky(k,D)*t2(ai,Bj) - focky(j,D)*t2(ai,Bk) 4942C 4943 4944C 4945C (1) wmat(aikj) = wmat(aikj) + focky(j,B)*t2(ai,Dk) 4946C 4947 ISYMJ = MULD2H(ISYFKY,ISYMB) 4948 ISYAIK = MULD2H(ISYMT2,ISYMD) 4949 DO ISYMK = 1,NSYM 4950 ISYAI = MULD2H(ISYAIK,ISYMK) 4951 DO ISYMI = 1,NSYM 4952 ISYMA = MULD2H(ISYAI,ISYMI) 4953 DO J = 1,NRHF(ISYMJ) 4954 KJB = IFCVIR(ISYMJ,ISYMB) + NORB(ISYMJ)*(B - 1) + J 4955 DO K = 1,NRHF(ISYMK) 4956 DO I = 1,NRHF(ISYMI) 4957 DO A = 1,NVIR(ISYMA) 4958 KAIKD = IT2SP(ISYAIK,ISYMD) 4959 * + NCKI(ISYAIK)*(D-1) 4960 * + ISAIK(ISYAI,ISYMK) 4961 * + NT1AM(ISYAI)*(K-1) 4962 * + IT1AM(ISYMA,ISYMI) 4963 * + NVIR(ISYMA)*(I-1) 4964 * + A 4965 4966 KAIKJ = ISAIKJ(ISYAIK,ISYMJ) 4967 * + NCKI(ISYAIK)*(J-1) 4968 * + ISAIK(ISYAI,ISYMK) 4969 * + NT1AM(ISYAI)*(K-1) 4970 * + IT1AM(ISYMA,ISYMI) 4971 * + NVIR(ISYMA)*(I-1) 4972 * + A 4973 4974 WMAT(KAIKJ) = WMAT(KAIKJ) 4975 * + FOCKY(KJB)*T2TP(KAIKD) 4976 END DO 4977 END DO 4978 END DO 4979 END DO 4980 END DO 4981 END DO 4982 4983C 4984C (2) wmat(aikj) = wmat(aikj) - focky(k,B)*t2(ai,Dj) 4985C 4986 ISYMK = MULD2H(ISYFKY,ISYMB) 4987 ISYAIJ = MULD2H(ISYMT2,ISYMD) 4988 DO ISYMJ = 1,NSYM 4989 ISYAI = MULD2H(ISYAIJ,ISYMJ) 4990 ISYAIK = MULD2H(ISYAI,ISYMK) 4991 DO ISYMI = 1,NSYM 4992 ISYMA = MULD2H(ISYAI,ISYMI) 4993 DO J = 1,NRHF(ISYMJ) 4994 DO K = 1,NRHF(ISYMK) 4995 KKB = IFCVIR(ISYMK,ISYMB) + NORB(ISYMK)*(B - 1) + K 4996 DO I = 1,NRHF(ISYMI) 4997 DO A = 1,NVIR(ISYMA) 4998 4999 KAIJD = IT2SP(ISYAIJ,ISYMD) 5000 * + NCKI(ISYAIJ)*(D-1) 5001 * + ISAIK(ISYAI,ISYMJ) 5002 * + NT1AM(ISYAI)*(J-1) 5003 * + IT1AM(ISYMA,ISYMI) 5004 * + NVIR(ISYMA)*(I-1) 5005 * + A 5006 5007 KAIKJ = ISAIKJ(ISYAIK,ISYMJ) 5008 * + NCKI(ISYAIK)*(J-1) 5009 * + ISAIK(ISYAI,ISYMK) 5010 * + NT1AM(ISYAI)*(K-1) 5011 * + IT1AM(ISYMA,ISYMI) 5012 * + NVIR(ISYMA)*(I-1) 5013 * + A 5014 5015 WMAT(KAIKJ) = WMAT(KAIKJ) 5016 * - FOCKY(KKB)*T2TP(KAIJD) 5017 END DO 5018 END DO 5019 END DO 5020 END DO 5021 END DO 5022 END DO 5023 5024 5025C 5026C (3) wmat(aikj) = wmat(aikj) + focky(k,D)*t2(ai,Bj) 5027C 5028 ISYMK = MULD2H(ISYFKY,ISYMD) 5029 ISYAIJ = MULD2H(ISYMT2,ISYMB) 5030 DO ISYMJ = 1,NSYM 5031 ISYAI = MULD2H(ISYAIJ,ISYMJ) 5032 ISYAIK = MULD2H(ISYAI,ISYMK) 5033 DO ISYMI = 1,NSYM 5034 ISYMA = MULD2H(ISYAI,ISYMI) 5035 DO J = 1,NRHF(ISYMJ) 5036 DO K = 1,NRHF(ISYMK) 5037 KKD = IFCVIR(ISYMK,ISYMD) + NORB(ISYMK)*(D - 1) + K 5038 DO I = 1,NRHF(ISYMI) 5039 DO A = 1,NVIR(ISYMA) 5040 5041 KAIJB = IT2SP(ISYAIJ,ISYMB) 5042 * + NCKI(ISYAIJ)*(B-1) 5043 * + ISAIK(ISYAI,ISYMJ) 5044 * + NT1AM(ISYAI)*(J-1) 5045 * + IT1AM(ISYMA,ISYMI) 5046 * + NVIR(ISYMA)*(I-1) 5047 * + A 5048 5049 KAIKJ = ISAIKJ(ISYAIK,ISYMJ) 5050 * + NCKI(ISYAIK)*(J-1) 5051 * + ISAIK(ISYAI,ISYMK) 5052 * + NT1AM(ISYAI)*(K-1) 5053 * + IT1AM(ISYMA,ISYMI) 5054 * + NVIR(ISYMA)*(I-1) 5055 * + A 5056 5057 WMAT(KAIKJ) = WMAT(KAIKJ) 5058 * + FOCKY(KKD)*T2TP(KAIJB) 5059 END DO 5060 END DO 5061 END DO 5062 END DO 5063 END DO 5064 END DO 5065 5066C 5067C (4) wmat(aikj) = wmat(aikj) - focky(j,D)*t2(ai,Bk) 5068C 5069 ISYMJ = MULD2H(ISYFKY,ISYMD) 5070 ISYAIK = MULD2H(ISYMT2,ISYMB) 5071 DO ISYMK = 1,NSYM 5072 ISYAI = MULD2H(ISYAIK,ISYMK) 5073 DO ISYMI = 1,NSYM 5074 ISYMA = MULD2H(ISYAI,ISYMI) 5075 DO J = 1,NRHF(ISYMJ) 5076 KJD = IFCVIR(ISYMJ,ISYMD) + NORB(ISYMJ)*(D - 1) + J 5077 DO K = 1,NRHF(ISYMK) 5078 DO I = 1,NRHF(ISYMI) 5079 DO A = 1,NVIR(ISYMA) 5080 5081 KAIKB = IT2SP(ISYAIK,ISYMB) 5082 * + NCKI(ISYAIK)*(B-1) 5083 * + ISAIK(ISYAI,ISYMK) 5084 * + NT1AM(ISYAI)*(K-1) 5085 * + IT1AM(ISYMA,ISYMI) 5086 * + NVIR(ISYMA)*(I-1) 5087 * + A 5088 5089 KAIKJ = ISAIKJ(ISYAIK,ISYMJ) 5090 * + NCKI(ISYAIK)*(J-1) 5091 * + ISAIK(ISYAI,ISYMK) 5092 * + NT1AM(ISYAI)*(K-1) 5093 * + IT1AM(ISYMA,ISYMI) 5094 * + NVIR(ISYMA)*(I-1) 5095 * + A 5096 5097 WMAT(KAIKJ) = WMAT(KAIKJ) 5098 * - FOCKY(KJD)*T2TP(KAIKB) 5099 END DO 5100 END DO 5101 END DO 5102 END DO 5103 END DO 5104 END DO 5105C 5106 ELSE IF (AIBJCK_PERM .EQ. 3) THEN 5107C 5108C focky(j,B)*t2(Dk,ai) - focky(i,B)*t2(Dk,aj) 5109C focky(i,a)*t2(Dk,Bj) - focky(j,a)*t2(Dk,Bi) 5110C 5111 5112C 5113C (1) wmat(aikj) = wmat(aikj) + focky(j,B)*t2(Dk,ai) 5114C 5115 ISYMJ = MULD2H(ISYFKY,ISYMB) 5116 ISYAIK = MULD2H(ISYMT2,ISYMD) 5117 DO ISYMK = 1,NSYM 5118 ISYDK = MULD2H(ISYMD,ISYMK) 5119 ISYAI = MULD2H(ISYAIK,ISYMK) 5120 DO ISYMI = 1,NSYM 5121 ISYDKI = MULD2H(ISYDK,ISYMI) 5122 ISYMA = MULD2H(ISYAI,ISYMI) 5123 DO J = 1,NRHF(ISYMJ) 5124 KJB = IFCVIR(ISYMJ,ISYMB) + NORB(ISYMJ)*(B - 1) + J 5125 DO K = 1,NRHF(ISYMK) 5126 DO I = 1,NRHF(ISYMI) 5127 DO A = 1,NVIR(ISYMA) 5128 KDKIA = IT2SP(ISYDKI,ISYMA) 5129 * + NCKI(ISYDKI)*(A-1) 5130 * + ISAIK(ISYDK,ISYMI) 5131 * + NT1AM(ISYDK)*(I-1) 5132 * + IT1AM(ISYMD,ISYMK) 5133 * + NVIR(ISYMD)*(K-1) 5134 * + D 5135 5136 KAIKJ = ISAIKJ(ISYAIK,ISYMJ) 5137 * + NCKI(ISYAIK)*(J-1) 5138 * + ISAIK(ISYAI,ISYMK) 5139 * + NT1AM(ISYAI)*(K-1) 5140 * + IT1AM(ISYMA,ISYMI) 5141 * + NVIR(ISYMA)*(I-1) 5142 * + A 5143 5144 WMAT(KAIKJ) = WMAT(KAIKJ) 5145 * + FOCKY(KJB)*T2TP(KDKIA) 5146 END DO 5147 END DO 5148 END DO 5149 END DO 5150 END DO 5151 END DO 5152 5153C (2) wmat(aikj) = wmat(aikj) - focky(i,B)*t2(Dk,aj) 5154C 5155 ISYMI = MULD2H(ISYFKY,ISYMB) 5156 ISYAJK = MULD2H(ISYMT2,ISYMD) 5157 DO ISYMJ = 1,NSYM 5158 ISYAK = MULD2H(ISYAJK,ISYMJ) 5159 ISYAIK = MULD2H(ISYAK,ISYMI) 5160 DO ISYMK = 1,NSYM 5161 ISYDK = MULD2H(ISYMK,ISYMD) 5162 ISYDKJ = MULD2H(ISYDK,ISYMJ) 5163 ISYMA = MULD2H(ISYAK,ISYMK) 5164 ISYAI = MULD2H(ISYAIK,ISYMK) 5165 DO J = 1,NRHF(ISYMJ) 5166 DO K = 1,NRHF(ISYMK) 5167 DO I = 1,NRHF(ISYMI) 5168 KIB = IFCVIR(ISYMI,ISYMB)+NORB(ISYMI)*(B-1) + I 5169 DO A = 1,NVIR(ISYMA) 5170 5171 KDKJA = IT2SP(ISYDKJ,ISYMA) 5172 * + NCKI(ISYDKJ)*(A-1) 5173 * + ISAIK(ISYDK,ISYMJ) 5174 * + NT1AM(ISYDK)*(J-1) 5175 * + IT1AM(ISYMD,ISYMK) 5176 * + NVIR(ISYMD)*(K-1) 5177 * + D 5178 5179 KAIKJ = ISAIKJ(ISYAIK,ISYMJ) 5180 * + NCKI(ISYAIK)*(J-1) 5181 * + ISAIK(ISYAI,ISYMK) 5182 * + NT1AM(ISYAI)*(K-1) 5183 * + IT1AM(ISYMA,ISYMI) 5184 * + NVIR(ISYMA)*(I-1) 5185 * + A 5186 5187 WMAT(KAIKJ) = WMAT(KAIKJ) 5188 * - FOCKY(KIB)*T2TP(KDKJA) 5189 END DO 5190 END DO 5191 END DO 5192 END DO 5193 END DO 5194 END DO 5195C 5196C (3) wmat(aikj) = wmat(aikj) + focky(i,a)*t2(Dk,Bj) 5197C 5198 ISYBD = MULD2H(ISYMD,ISYMB) 5199 ISYKJ = MULD2H(ISYMT2,ISYBD) 5200 ISYDKJ = MULD2H(ISYMD,ISYKJ) 5201 DO ISYMJ = 1,NSYM 5202 ISYMK = MULD2H(ISYKJ,ISYMJ) 5203 ISYDK = MULD2H(ISYMD,ISYMK) 5204 DO ISYMI = 1,NSYM 5205 ISYMA = MULD2H(ISYFKY,ISYMI) 5206 ISYAI = MULD2H(ISYMA,ISYMI) 5207 ISYAIK = MULD2H(ISYAI,ISYMK) 5208 DO J = 1,NRHF(ISYMJ) 5209 DO K = 1,NRHF(ISYMK) 5210 DO I = 1,NRHF(ISYMI) 5211 DO A = 1,NVIR(ISYMA) 5212 KIA = IFCVIR(ISYMI,ISYMA)+NORB(ISYMI)*(A-1)+I 5213 5214 KDKJB = IT2SP(ISYDKJ,ISYMB) 5215 * + NCKI(ISYDKJ)*(B-1) 5216 * + ISAIK(ISYDK,ISYMJ) 5217 * + NT1AM(ISYDK)*(J-1) 5218 * + IT1AM(ISYMD,ISYMK) 5219 * + NVIR(ISYMD)*(K-1) 5220 * + D 5221 5222 KAIKJ = ISAIKJ(ISYAIK,ISYMJ) 5223 * + NCKI(ISYAIK)*(J-1) 5224 * + ISAIK(ISYAI,ISYMK) 5225 * + NT1AM(ISYAI)*(K-1) 5226 * + IT1AM(ISYMA,ISYMI) 5227 * + NVIR(ISYMA)*(I-1) 5228 * + A 5229 5230 WMAT(KAIKJ) = WMAT(KAIKJ) 5231 * + FOCKY(KIA)*T2TP(KDKJB) 5232 END DO 5233 END DO 5234 END DO 5235 END DO 5236 END DO 5237 END DO 5238 5239C 5240C (4) wmat(aikj) = wmat(aikj) - focky(j,a)*t2(Dk,Bi) 5241C 5242 ISYDKI = MULD2H(ISYMT2,ISYMB) 5243 ISYKI = MULD2H(ISYDKI,ISYMD) 5244 DO ISYMJ = 1,NSYM 5245 ISYMA = MULD2H(ISYFKY,ISYMJ) 5246 DO ISYMK = 1,NSYM 5247 ISYMI = MULD2H(ISYKI,ISYMK) 5248 ISYAI = MULD2H(ISYMA,ISYMI) 5249 ISYDK = MULD2H(ISYDKI,ISYMI) 5250 ISYAIK = MULD2H(ISYAI,ISYMK) 5251 DO J = 1,NRHF(ISYMJ) 5252 DO K = 1,NRHF(ISYMK) 5253 DO I = 1,NRHF(ISYMI) 5254 DO A = 1,NVIR(ISYMA) 5255 KJA = IFCVIR(ISYMJ,ISYMA)+NORB(ISYMJ)*(A-1)+J 5256 5257 KDKIB = IT2SP(ISYDKI,ISYMB) 5258 * + NCKI(ISYDKI)*(B-1) 5259 * + ISAIK(ISYDK,ISYMI) 5260 * + NT1AM(ISYDK)*(I-1) 5261 * + IT1AM(ISYMD,ISYMK) 5262 * + NVIR(ISYMD)*(K-1) 5263 * + D 5264 5265 KAIKJ = ISAIKJ(ISYAIK,ISYMJ) 5266 * + NCKI(ISYAIK)*(J-1) 5267 * + ISAIK(ISYAI,ISYMK) 5268 * + NT1AM(ISYAI)*(K-1) 5269 * + IT1AM(ISYMA,ISYMI) 5270 * + NVIR(ISYMA)*(I-1) 5271 * + A 5272 5273 WMAT(KAIKJ) = WMAT(KAIKJ) 5274 * - FOCKY(KJA)*T2TP(KDKIB) 5275 END DO 5276 END DO 5277 END DO 5278 END DO 5279 END DO 5280 END DO 5281C 5282 ELSE 5283 WRITE(LUPRI,*) 'AIBJCK_PERM = ', AIBJCK_PERM 5284 WRITE(LUPRI,*) 'WBARXBD_T2 works for AIBJCK_PERM = 1 or 3' 5285 CALL QUIT('Wrong AIBJCK_PERM option in WBARXBD_T2') 5286 END IF 5287 5288 CALL QEXIT('WBXT2') 5289C 5290 RETURN 5291 END 5292C /* Deck wbarxbd_l1 */ 5293 SUBROUTINE WBARXBD_L1(AIBJCK_PERM,T1AM,ISYMT1,TMAT,XIAJB, 5294 * ISINT1, 5295 * WMAT,WORK,LWORK, 5296 * INDSQ,LENSQ,ISYMB,B,ISYMC,C) 5297*---------------------------------------------------------------------* 5298* 5299* Purpose: compute Tbar1^Y contribution to triples component of 5300* first-order multipliers vector: 5301* 5302* <Tbar1^Y|[H_0^,tau3]|HF> = P^(abc)_(ijk) ( t1bar^Y(ai)*L(jbkc) 5303* - t1bar^Y(ak)*L(jbic) ) 5304* 5305* Use W intermmediates: 5306* 5307* IF (AIBJCK_PERM .EQ. 1) THEN (aibjck + aickbj permutation) 5308* 5309* WMAT^BC(aikj) = WMAT^BC(aikj) + T1(ai)*L(jBkC) 5310* - T1(ak)*L(jBiC) 5311* + T1(ai)*L(kCjB) 5312* - T1(aj)*L(kCiB) 5313* 5314* ELSE IF (AIBJCK_PERM = 3) THEN (ckbjai + ckaibj permutation) 5315* 5316* WMAT^BC(aikj) = WMAT^BC(aikj) + T1(Ck)*L(jBia) 5317* - T1(Ci)*L(jBka) 5318* + T1(Ck)*L(iajB) 5319* - T1(Cj)*L(iakB) 5320* 5321* ELSE quit with the error message. 5322* 5323* Written by Filip Pawlowski, Fall 2002, Aarhus 5324* (modified for AIBJCK_PERM option, Fall 2003.) 5325* 5326*=====================================================================* 5327C 5328 IMPLICIT NONE 5329C 5330#include "priunit.h" 5331#include "ccorb.h" 5332#include "ccsdsym.h" 5333C 5334 INTEGER AIBJCK_PERM 5335 INTEGER ISYMT1, ISINT1, LENSQ, ISYMB, ISYMC 5336 INTEGER ISYMBC, ISYRES, JSAIKJ, LENGTH, ISYMK, ISYMJ 5337 INTEGER ISYMAI, ISYAIK, ISYMJK, ISYMCK, NBJ, NCK, ISYMBJ 5338 INTEGER NCKBJ, NBJCK, NAI, NAIKJ 5339 INTEGER INDEX, INDSQ(LENSQ,6) 5340 INTEGER LWORK 5341C 5342 INTEGER ISYBIA,NAIBJ,ISYAIB,NBJAI 5343C 5344#if defined (SYS_CRAY) 5345 REAL T1AM(*), TMAT(*), XIAJB(*) 5346 REAL WMAT(*),WORK(LWORK) 5347 real xnormval,ddot 5348#else 5349 DOUBLE PRECISION T1AM(*), TMAT(*), XIAJB(*) 5350 DOUBLE PRECISION WMAT(*),WORK(LWORK) 5351 double precision xnormval,ddot 5352#endif 5353C 5354 INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 5355C 5356 CALL QENTER('WBX_L1') 5357C 5358 ISYRES = MULD2H(ISYMT1,ISINT1) 5359C 5360 ISYMBC = MULD2H(ISYMB,ISYMC) 5361 JSAIKJ = MULD2H(ISYRES,ISYMBC) 5362 LENGTH = NCKIJ(JSAIKJ) 5363C 5364 IF (AIBJCK_PERM .EQ. 1) THEN 5365C 5366C----------------------------------------------- 5367C First contribution from both T1 terms 5368C 5369C WMAT^BC(aikj) = WMAT^BC(aikj) + T1(ai)*L(jBkC) 5370C - T1(ak)*L(jBiC) 5371C 5372C----------------------------------------------- 5373C 5374 ISYMJK = MULD2H(ISYMBC,ISINT1) 5375C 5376C------------------------------------------ 5377C Contract the integrals with T1. 5378C------------------------------------------ 5379C 5380 CALL DZERO(TMAT,LENGTH) 5381C 5382 ISYMAI = ISYMT1 5383 DO ISYMJ = 1, NSYM 5384 ISYMK = MULD2H(ISYMJK,ISYMJ) 5385 ISYAIK = MULD2H(ISYMK,ISYMAI) 5386 ISYMCK = MULD2H(ISYMC,ISYMK) 5387 ISYMBJ = MULD2H(ISYMB,ISYMJ) 5388C 5389 DO J = 1, NRHF(ISYMJ) 5390 NBJ = IT1AM(ISYMB,ISYMJ) + NVIR(ISYMB)*(J - 1) + B 5391C 5392 DO K = 1, NRHF(ISYMK) 5393C 5394 NCK = IT1AM(ISYMC,ISYMK) + NVIR(ISYMC)*(K - 1) + C 5395C 5396 NCKBJ = IT2AM(ISYMCK,ISYMBJ) + INDEX(NCK,NBJ) 5397C 5398 DO NAI = 1, NT1AM(ISYMAI) 5399C 5400 NAIKJ = ISAIKJ(ISYAIK,ISYMJ) 5401 * + NCKI(ISYAIK)*(J - 1) 5402 * + ICKI(ISYMAI,ISYMK) 5403 * + NT1AM(ISYMAI)*(K - 1) + NAI 5404C 5405 TMAT(NAIKJ) = T1AM(NAI)*XIAJB(NCKBJ) 5406C 5407 ENDDO 5408 ENDDO 5409 ENDDO 5410C 5411 ENDDO 5412C 5413C------------------------------------------- 5414C Sum the result into WMAT. 5415C------------------------------------------- 5416C 5417 JSAIKJ = MULD2H(ISYMAI,ISYMJK) 5418 DO I = 1, NCKIJ(JSAIKJ) 5419C First : WMAT^BC(aikj) = WMAT^BC(aikj) + T1(ai)*L(jBkC) 5420 WMAT(I) = WMAT(I) + TMAT(I) 5421C Second : WMAT^BC(aikj) = WMAT^BC(aikj) - T1(ak)*L(jBiC) 5422 WMAT(I) = WMAT(I) - TMAT(INDSQ(I,1)) 5423 ENDDO 5424C 5425C----------------------------------------------- 5426C Second contribution from both T1 terms 5427C 5428C WMAT^BC(aikj) = WMAT^BC(aikj) + T1(ai)*L(kCjB) 5429C - T1(aj)*L(kCiB) 5430C 5431C 5432C----------------------------------------------- 5433C 5434 ISYMJK = MULD2H(ISYMBC,ISINT1) 5435C 5436C------------------------------------------ 5437C Contract the integrals with T1. 5438C------------------------------------------ 5439C 5440 CALL DZERO(TMAT,LENGTH) 5441C 5442 ISYMAI = ISYMT1 5443 DO ISYMK = 1, NSYM 5444 ISYAIK = MULD2H(ISYMK,ISYMAI) 5445 ISYMJ = MULD2H(ISYMJK,ISYMK) 5446 ISYMCK = MULD2H(ISYMC,ISYMK) 5447 ISYMBJ = MULD2H(ISYMB,ISYMJ) 5448C 5449 DO K = 1, NRHF(ISYMK) 5450C 5451 NCK = IT1AM(ISYMC,ISYMK) + NVIR(ISYMC)*(K - 1) + C 5452C 5453 DO J = 1, NRHF(ISYMJ) 5454 NBJ = IT1AM(ISYMB,ISYMJ) + NVIR(ISYMB)*(J - 1) + B 5455C 5456 NBJCK = IT2AM(ISYMBJ,ISYMCK) + INDEX(NBJ,NCK) 5457C 5458 DO NAI = 1, NT1AM(ISYMAI) 5459C 5460 NAIKJ = ISAIKJ(ISYAIK,ISYMJ) 5461 * + NCKI(ISYAIK)*(J - 1) 5462 * + ICKI(ISYMAI,ISYMK) 5463 * + NT1AM(ISYMAI)*(K-1) + NAI 5464C 5465 TMAT(NAIKJ) = T1AM(NAI)*XIAJB(NBJCK) 5466C 5467 ENDDO 5468 ENDDO 5469 ENDDO 5470C 5471 ENDDO 5472c 5473C 5474C------------------------------------------- 5475C Sum the result into WMAT. 5476C------------------------------------------- 5477C 5478 JSAIKJ = MULD2H(ISYMAI,ISYMJK) 5479 DO I = 1, NCKIJ(JSAIKJ) 5480C First : WMAT^BC(aikj) = WMAT^BC(aikj) + T1(ai)*L(kCjB) 5481 WMAT(I) = WMAT(I) + TMAT(I) 5482C Second : WMAT^BC(aikj) = WMAT^BC(aikj) - T1(aj)*L(kCiB) 5483 WMAT(I) = WMAT(I) - TMAT(INDSQ(I,5)) 5484 ENDDO 5485C 5486 ELSE IF (AIBJCK_PERM .EQ. 3) THEN 5487C 5488C----------------------------------------------- 5489C First contribution from both T1 terms 5490C 5491C WMAT^BC(aikj) = WMAT^BC(aikj) + T1(Ck)*L(jBia) 5492C - T1(Ci)*L(jBka) 5493C 5494C----------------------------------------------- 5495C 5496C 5497C------------------------------------------ 5498C Contract the integrals with T1. 5499C------------------------------------------ 5500C 5501 CALL DZERO(TMAT,LENGTH) 5502C 5503 ISYMCK = ISYMT1 5504 ISYMK = MULD2H(ISYMCK,ISYMC) 5505 DO ISYMJ = 1, NSYM 5506 ISYBIA = MULD2H(ISINT1,ISYMJ) 5507 ISYMAI = MULD2H(ISYBIA,ISYMB) 5508 ISYMBJ = MULD2H(ISYMB,ISYMJ) 5509 ISYAIK = MULD2H(ISYMAI,ISYMK) 5510C 5511 DO J = 1, NRHF(ISYMJ) 5512 NBJ = IT1AM(ISYMB,ISYMJ) + NVIR(ISYMB)*(J - 1) + B 5513C 5514 DO K = 1, NRHF(ISYMK) 5515C 5516 NCK = IT1AM(ISYMC,ISYMK) + NVIR(ISYMC)*(K - 1) + C 5517C 5518 DO NAI = 1, NT1AM(ISYMAI) 5519C 5520 NAIBJ = IT2AM(ISYMAI,ISYMBJ) + INDEX(NAI,NBJ) 5521C 5522 NAIKJ = ISAIKJ(ISYAIK,ISYMJ) 5523 * + NCKI(ISYAIK)*(J - 1) 5524 * + ICKI(ISYMAI,ISYMK) 5525 * + NT1AM(ISYMAI)*(K - 1) + NAI 5526C 5527 TMAT(NAIKJ) = T1AM(NCK)*XIAJB(NAIBJ) 5528C 5529 ENDDO 5530 ENDDO 5531 ENDDO 5532 ENDDO 5533C 5534C------------------------------------------- 5535C Sum the result into WMAT. 5536C------------------------------------------- 5537C 5538c JSAIKJ = MULD2H(ISYMAI,ISYMJK) 5539c DO I = 1, NCKIJ(JSAIKJ) 5540 DO I = 1, LENGTH 5541C First : WMAT^BC(aikj) = WMAT^BC(aikj) + T1(Ck)*L(jBia) 5542 5543 WMAT(I) = WMAT(I) + TMAT(I) 5544C Second : WMAT^BC(aikj) = WMAT^BC(aikj) - T1(Ci)*L(jBka) 5545 WMAT(I) = WMAT(I) - TMAT(INDSQ(I,1)) 5546 ENDDO 5547C 5548C----------------------------------------------- 5549C Second contribution from both T1 terms 5550C 5551C WMAT^BC(aikj) = WMAT^BC(aikj) + T1(Ck)*L(iajB) 5552C - T1(Cj)*L(iakB) 5553C 5554C----------------------------------------------- 5555C 5556 5557C 5558C------------------------------------------ 5559C Contract the integrals with T1. 5560C------------------------------------------ 5561C 5562 CALL DZERO(TMAT,LENGTH) 5563C 5564 ISYMCK = ISYMT1 5565 ISYMK = MULD2H(ISYMCK,ISYMC) 5566 DO ISYMJ = 1, NSYM 5567 ISYAIB = MULD2H(ISINT1,ISYMJ) 5568 ISYMAI = MULD2H(ISYAIB,ISYMB) 5569 ISYAIK = MULD2H(ISYMAI,ISYMK) 5570 ISYMBJ = MULD2H(ISYMB,ISYMJ) 5571C 5572 DO K = 1, NRHF(ISYMK) 5573C 5574 NCK = IT1AM(ISYMC,ISYMK) + NVIR(ISYMC)*(K - 1) + C 5575C 5576 DO J = 1, NRHF(ISYMJ) 5577 NBJ = IT1AM(ISYMB,ISYMJ) + NVIR(ISYMB)*(J - 1) + B 5578C 5579 DO NAI = 1, NT1AM(ISYMAI) 5580C 5581 NBJAI = IT2AM(ISYMBJ,ISYMAI) + INDEX(NBJ,NAI) 5582C 5583 NAIKJ = ISAIKJ(ISYAIK,ISYMJ) 5584 * + NCKI(ISYAIK)*(J - 1) 5585 * + ICKI(ISYMAI,ISYMK) 5586 * + NT1AM(ISYMAI)*(K-1) + NAI 5587C 5588 TMAT(NAIKJ) = T1AM(NCK)*XIAJB(NBJAI) 5589C 5590 ENDDO 5591 ENDDO 5592 ENDDO 5593 ENDDO 5594C 5595C------------------------------------------- 5596C Sum the result into WMAT. 5597C------------------------------------------- 5598C 5599c JSAIKJ = MULD2H(ISYMAI,ISYMJK) 5600c DO I = 1, NCKIJ(JSAIKJ) 5601 DO I = 1, LENGTH 5602C First : WMAT^BC(aikj) = WMAT^BC(aikj) + T1(Ck)*L(iajB) 5603 WMAT(I) = WMAT(I) + TMAT(I) 5604C Second : WMAT^BC(aikj) = WMAT^BC(aikj) - T1(Cj)*L(iakB) 5605 WMAT(I) = WMAT(I) - TMAT(INDSQ(I,3)) 5606 ENDDO 5607C 5608 ELSE 5609 WRITE(LUPRI,*) 'AIBJCK_PERM = ', AIBJCK_PERM 5610 WRITE(LUPRI,*) 'WBARXBD_T2 works for AIBJCK_PERM = 1 or 3' 5611 CALL QUIT('Wrong AIBJCK_PERM option in WBARXBD_L1') 5612 END IF 5613 5614C 5615 CALL QEXIT('WBX_L1') 5616C 5617 RETURN 5618 END 5619C /* Deck wbarxbd_tmat */ 5620 SUBROUTINE WBARXBD_TMAT(AIBJCK_PERM, 5621 * T2TP,ISYMT2,WMAT,TMAT,ISWMAT,FOCK, 5622 * ISYFOCK,VLDKBC,VLDKCB,VGDKBC,VGDKCB,TROCCL, 5623 * TROCCG,ISINT2,WORK,LWORK,INDAJLB, 5624 * INDAJLC,INDSQ,LENSQ,ISYMB,B,ISYMC,C) 5625C 5626C Written by Kasper Hald, Fall 2001. 5627C (generalized for AIBJCK_PERM, F. Pawlowski, Fall 2003.) 5628C 5629C General symmetry: ISINT2 is symmetry of integrals 5630C ISYMT2 is symmetry of T2TP 5631C 5632C Virtual integrals stored as: 5633C L(kcd^b) -> IC(d^kB): VLDKBC 5634C L(kcd^b) -> IB(d^kC): VLDKCB 5635C g(kcd^b) -> IC(d^kB): VGDKBC 5636C g(kcd^b) -> IB(d^kC): VGDKCB 5637 5638C Occupied integrals stored as: 5639C L(ia|j k-) -> I(k-,i,j,a): TROCCL 5640C g(ia|j k-) -> I(k-,i,j,a): TROCCG 5641C 5642C 5643C IF (AIBJCK_PERM .EQ. 1) THEN (aibjck + aickbj permutation) 5644C 5645C WMAT^BC(aikj) = WMAT^BC(aikj) + T2TP(aijB)*F(kC) 5646C - T2TP(aikB)*F(jC) 5647C + T2TP(aikC)*F(jB) 5648C - T2TP(aijC)*F(kB) 5649C 5650C + T2TP(aijd)*L(d^BkC) 5651C - T2TP(ajkd)*g(iBd^C) 5652C + T2TP(aikd)*L(d^CjB) 5653C - T2TP(akjd)*g(iCd^B) 5654C 5655C + T2TP(ailB)*L(jl^kC) 5656C - T2TP(alkB)*g(il^jC) 5657C + T2TP(ailC)*L(kl^jB) 5658C - T2TP(aljC)*g(il^kB) 5659C 5660C ELSE IF (AIBJCK_PERM = 3) THEN (ckbjai + ckaibj permutation) 5661C 5662C WMAT^BC(aikj) = WMAT^BC(aikj) + T2TP(CkjB)*F(ia) 5663C - T2TP(CkiB)*F(ja) 5664C + T2TP(Ckia)*F(jB) 5665C - T2TP(Ckja)*F(iB) 5666C 5667C + T2TP(Ckjd)*L(d^Bia) 5668C - T2TP(Cjid)*g(kBd^a) 5669C + T2TP(Ckid)*L(d^ajB) 5670C - T2TP(Cijd)*g(kad^B) 5671C 5672C + T2TP(CklB)*L(jl^ia) 5673C - T2TP(CliB)*g(kl^ja) 5674C + T2TP(Ckla)*L(il^jB) 5675C - T2TP(Clja)*g(kl^iB) 5676C 5677C ELSE quit with the error message. 5678 5679C 5680 5681 IMPLICIT NONE 5682C 5683#include "priunit.h" 5684#include "ccorb.h" 5685#include "ccsdinp.h" 5686#include "ccsdsym.h" 5687C 5688 INTEGER AIBJCK_PERM 5689 INTEGER ISYMT2,ISWMAT,ISINT2,ISYMB,ISYMC,ISYRES,ISYMBC 5690 INTEGER JSAIKJ,ISYMK,ISYAIJ,ISYMJ,ISYMAI,ISYAIK,ISYMI 5691 INTEGER ISYMA,ISYMDK,ISYMD,ISYMDI,ISYAJK,ISYMDJ,ISYAIL 5692 INTEGER ISYLKJ,ISYMLK,ISYML,ISYALK,ISYLJI,ISYAKJ,ISYMLJ 5693 INTEGER ISYMAK,ISYAJL,ISYLKI,ISYMAJ,ISYFOCK 5694 INTEGER NAI,NAIJB,NCK,NAIKJ,NCJ,NAIKB,NBJ,NAIKC,NAIJC,NBK 5695 INTEGER NTOAIJ,NVIRD,NTOAJK,NTOAIK,NTOAKJ,NTOTAI,NRHFL 5696 INTEGER NTOTAK,NTOTAJ 5697 INTEGER INDAJLB,INDAJLC,LENSQ,INDSQ(LENSQ,6),INDEX 5698 INTEGER KOFF1,KOFF2,KOFF3,KALK,KEND1,KALJ,KOFF 5699 INTEGER LWORK,LENGTH,LWRK1 5700C 5701 INTEGER ISYCKJ,ISYKJ,ISYMCK,NCKJB 5702 INTEGER ISYAID,ISYDJK,KAID,ISYDJ,ISYAI 5703 INTEGER ILOOP 5704 INTEGER ISYLK,KLK,KAJIL,NTOTL,ISYAJI,NTOTAJI 5705 5706#if defined (SYS_CRAY) 5707 REAL T2TP(*),WMAT(*),TMAT(*),FOCK(*) 5708 REAL VLDKBC(*),VLDKCB(*),VGDKBC(*),VGDKCB(*),TROCCL(*),TROCCG(*) 5709 REAL WORK(*) 5710 REAL XWMAT,ONE,DDOT 5711#else 5712 DOUBLE PRECISION T2TP(*),WMAT(*),TMAT(*),FOCK(*) 5713 DOUBLE PRECISION VLDKBC(*),VLDKCB(*),VGDKBC(*),VGDKCB(*),TROCCL(*) 5714 DOUBLE PRECISION TROCCG(*),WORK(*) 5715 DOUBLE PRECISION XWMAT,ONE,DDOT 5716#endif 5717C 5718 PARAMETER(ONE = 1.0D0) 5719C 5720 CALL QENTER('WBXTMT') 5721C 5722 ISYRES = MULD2H(ISYMT2,ISINT2) 5723C 5724 ISYMBC = MULD2H(ISYMB,ISYMC) 5725 JSAIKJ = MULD2H(ISYRES,ISYMBC) 5726C 5727 IF (JSAIKJ .NE. ISWMAT) THEN 5728 WRITE(LUPRI,*)'JSAIKJ ', JSAIKJ 5729 WRITE(LUPRI,*)'ISWMAT ', ISWMAT 5730 WRITE(LUPRI,*)'ISWMAT and JSAIKJ should be equal ' 5731 CALL QUIT('Symmetry inconsistency in WBARXBD_TMAT') 5732 END IF 5733C 5734 LENGTH = NCKIJ(JSAIKJ) 5735C 5736 IF (AIBJCK_PERM .EQ. 1) THEN 5737C 5738C-------------------------------------------------------------------------- 5739C 5740C WMAT^BC(aikj) = WMAT^BC(aikj) + T2TP(aijB)*F(kC) 5741C - T2TP(aikB)*F(jC) 5742C + T2TP(aikC)*F(jB) 5743C - T2TP(aijC)*F(kB) 5744C 5745C-------------------------------------------------------------------------- 5746C Contribution from both Fock terms: 5747C-------------------------------------------------------------------------- 5748C 5749C 5750C WMAT^BC(aikj) = WMAT^BC(aikj) + T2TP(aijB)*F(kC) 5751C 5752 ISYMK = MULD2H(ISYFOCK,ISYMC) 5753 ISYAIJ = MULD2H(ISYMT2,ISYMB) 5754C 5755 DO ISYMJ = 1, NSYM 5756 ISYMAI = MULD2H(ISYAIJ,ISYMJ) 5757 ISYAIK = MULD2H(ISYMK,ISYMAI) 5758 DO ISYMI = 1, NSYM 5759 ISYMA = MULD2H(ISYMAI,ISYMI) 5760C 5761 DO J = 1, NRHF(ISYMJ) 5762C 5763 DO I = 1, NRHF(ISYMI) 5764 DO A = 1, NVIR(ISYMA) 5765C 5766 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I-1) + A 5767C 5768C Index for sorted T2 amplitudes. 5769C 5770 NAIJB = IT2SP(ISYAIJ,ISYMB) 5771 * + NCKI(ISYAIJ)*(B - 1) 5772 * + ICKI(ISYMAI,ISYMJ) 5773 * + NT1AM(ISYMAI)*(J - 1) + NAI 5774C 5775 DO K = 1, NRHF(ISYMK) 5776C 5777 NCK = IT1AM(ISYMC,ISYMK) + NVIR(ISYMC)*(K-1) +C 5778 NAIKJ = ISAIKJ(ISYAIK,ISYMJ) 5779 * + NCKI(ISYAIK)*(J - 1) 5780 * + ICKI(ISYMAI,ISYMK) 5781 * + NT1AM(ISYMAI)*(K-1) 5782 * + NAI 5783 5784C 5785C Fock 1.0 contribution addWMAT 5786C 5787 5788 WMAT(NAIKJ) = WMAT(NAIKJ)+T2TP(NAIJB)*FOCK(NCK) 5789C 5790 ENDDO 5791 ENDDO 5792 ENDDO 5793 ENDDO 5794 ENDDO 5795 ENDDO 5796C 5797C WMAT^BC(aikj) = WMAT^BC(aikj) - T2TP(aikB)*F(jC) 5798C 5799 ISYMJ = MULD2H(ISYFOCK,ISYMC) 5800 ISYAIK = MULD2H(ISYMT2,ISYMB) 5801C 5802 DO ISYMK = 1, NSYM 5803 ISYMAI = MULD2H(ISYAIK,ISYMK) 5804 DO ISYMI = 1, NSYM 5805 ISYMA = MULD2H(ISYMAI,ISYMI) 5806C 5807 DO J = 1, NRHF(ISYMJ) 5808 NCJ = IT1AM(ISYMC,ISYMJ) + NVIR(ISYMC)*(J-1) + C 5809C 5810 DO I = 1, NRHF(ISYMI) 5811 DO A = 1, NVIR(ISYMA) 5812C 5813 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I-1) + A 5814C 5815C Index for sorted T2 amplitudes. 5816C 5817 DO K = 1, NRHF(ISYMK) 5818C 5819 NAIKB = IT2SP(ISYAIK,ISYMB) 5820 * + NCKI(ISYAIK)*(B - 1) 5821 * + ICKI(ISYMAI,ISYMK) 5822 * + NT1AM(ISYMAI)*(K - 1) + NAI 5823C 5824 NAIKJ = ISAIKJ(ISYAIK,ISYMJ) 5825 * + NCKI(ISYAIK)*(J - 1) 5826 * + ICKI(ISYMAI,ISYMK) 5827 * + NT1AM(ISYMAI)*(K-1) 5828 * + NAI 5829 5830C 5831C Fock 2.0 contribution addWMAT 5832C 5833 WMAT(NAIKJ) = WMAT(NAIKJ)-T2TP(NAIKB)*FOCK(NCJ) 5834C 5835 ENDDO 5836 ENDDO 5837 ENDDO 5838 ENDDO 5839 ENDDO 5840 ENDDO 5841 5842C 5843C WMAT^BC(aikj) = WMAT^BC(aikj) + T2TP(aikC)*F(jB) 5844C 5845 ISYMJ = MULD2H(ISYFOCK,ISYMB) 5846 ISYAIK = MULD2H(ISYMT2,ISYMC) 5847C 5848 DO ISYMK = 1, NSYM 5849 ISYMAI = MULD2H(ISYAIK,ISYMK) 5850 DO ISYMI = 1, NSYM 5851 ISYMA = MULD2H(ISYMAI,ISYMI) 5852C 5853 DO J = 1, NRHF(ISYMJ) 5854 NBJ = IT1AM(ISYMB,ISYMJ) + NVIR(ISYMB)*(J-1) + B 5855C 5856 DO I = 1, NRHF(ISYMI) 5857 DO A = 1, NVIR(ISYMA) 5858C 5859 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I-1) + A 5860C 5861C Index for sorted T2 amplitudes. 5862C 5863 DO K = 1, NRHF(ISYMK) 5864C 5865 NAIKC = IT2SP(ISYAIK,ISYMC) 5866 * + NCKI(ISYAIK)*(C - 1) 5867 * + ICKI(ISYMAI,ISYMK) 5868 * + NT1AM(ISYMAI)*(K - 1) + NAI 5869C 5870 NAIKJ = ISAIKJ(ISYAIK,ISYMJ) 5871 * + NCKI(ISYAIK)*(J - 1) 5872 * + ICKI(ISYMAI,ISYMK) 5873 * + NT1AM(ISYMAI)*(K-1) 5874 * + NAI 5875 5876C 5877C Fock 3.0 contribution addWMAT 5878C 5879 WMAT(NAIKJ) = WMAT(NAIKJ)+T2TP(NAIKC)*FOCK(NBJ) 5880C 5881 ENDDO 5882 ENDDO 5883 ENDDO 5884 ENDDO 5885 ENDDO 5886 ENDDO 5887 5888C 5889C WMAT^BC(aikj) = WMAT^BC(aikj) - T2TP(aijC)*F(kB) 5890C 5891 ISYMK = MULD2H(ISYFOCK,ISYMB) 5892 ISYAIJ = MULD2H(ISYMT2,ISYMC) 5893C 5894 DO ISYMJ = 1, NSYM 5895 ISYMAI = MULD2H(ISYAIJ,ISYMJ) 5896 ISYAIK = MULD2H(ISYMK,ISYMAI) 5897 DO ISYMI = 1, NSYM 5898 ISYMA = MULD2H(ISYMAI,ISYMI) 5899C 5900 DO J = 1, NRHF(ISYMJ) 5901C 5902 DO I = 1, NRHF(ISYMI) 5903 DO A = 1, NVIR(ISYMA) 5904C 5905 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I-1) + A 5906C 5907C Index for sorted T2 amplitudes. 5908C 5909 NAIJC = IT2SP(ISYAIJ,ISYMC) 5910 * + NCKI(ISYAIJ)*(C - 1) 5911 * + ICKI(ISYMAI,ISYMJ) 5912 * + NT1AM(ISYMAI)*(J - 1) + NAI 5913C 5914 DO K = 1, NRHF(ISYMK) 5915C 5916 NBK = IT1AM(ISYMB,ISYMK) + NVIR(ISYMB)*(K-1) + B 5917 NAIKJ = ISAIKJ(ISYAIK,ISYMJ) 5918 * + NCKI(ISYAIK)*(J - 1) 5919 * + ICKI(ISYMAI,ISYMK) 5920 * + NT1AM(ISYMAI)*(K-1) 5921 * + NAI 5922 5923C 5924C Fock 4.0 contribution addWMAT 5925C 5926 WMAT(NAIKJ) = WMAT(NAIKJ)-T2TP(NAIJC)*FOCK(NBK) 5927C 5928 ENDDO 5929 ENDDO 5930 ENDDO 5931 ENDDO 5932 ENDDO 5933 ENDDO 5934C 5935C------------------------------------------------------------ 5936C First virtual contribution of L term. 5937C 5938C WMAT^BC(aikj) = WMAT^BC(aikj) + T2TP(aijd)*L(d^BkC) 5939C------------------------------------------------------------ 5940C 5941 ISYMBC = MULD2H(ISYMB,ISYMC) 5942 ISYRES = MULD2H(ISINT2,ISYMT2) 5943 JSAIKJ = MULD2H(ISYMBC,ISYRES) 5944 ISYMDK = MULD2H(ISYMBC,ISINT2) 5945C 5946 LENGTH = NCKIJ(JSAIKJ) 5947C 5948 CALL DZERO(TMAT,LENGTH) 5949C 5950 DO ISYMK = 1,NSYM 5951C 5952 ISYMD = MULD2H(ISYMK,ISYMDK) 5953 ISYAIJ = MULD2H(ISYMK,JSAIKJ) 5954C 5955 KOFF1 = IT2SP(ISYAIJ,ISYMD) + 1 5956 KOFF2 = ICKATR(ISYMDK,ISYMB) + NT1AM(ISYMDK)*(B - 1) 5957 * + IT1AM(ISYMD,ISYMK) + 1 5958 KOFF3 = ISAIKJ(ISYAIJ,ISYMK) + 1 5959C 5960 NTOAIJ = MAX(1,NCKI(ISYAIJ)) 5961 NVIRD = MAX(NVIR(ISYMD),1) 5962C 5963C Virtual-L 1.0 contribution addWMAT 5964C 5965* write(lupri,*)'T2TP(voo,v), isymb,b,isymc,c,isymk ', 5966* * isymb,b,isymc,c,isymk, 5967* * ddot(NCKI(ISYAIJ)*NVIR(ISYMD),T2TP(KOFF1),1,T2TP(KOFF1),1) 5968c call output(T2TP(KOFF1),1,NCKI(ISYAIJ),1,NVIR(ISYMD), 5969c * NCKI(ISYAIJ),NVIR(ISYMD),1,lupri) 5970* write(lupri,*)'VLDKBC(v,o) ', 5971* * ddot(NVIR(ISYMD)*NRHF(ISYMK),VLDKBC(KOFF2),1,VLDKBC(KOFF2),1) 5972c call output(VLDKBC(KOFF2),1,NVIR(ISYMD),1,NRHF(ISYMK), 5973c * NVIR(ISYMD),NRHF(ISYMK),1,lupri) 5974 CALL DGEMM('N','N',NCKI(ISYAIJ),NRHF(ISYMK), 5975 * NVIR(ISYMD),ONE,T2TP(KOFF1),NTOAIJ, 5976 * VLDKBC(KOFF2),NVIRD,ONE, 5977 * TMAT(KOFF3),NTOAIJ) 5978* write(lupri,*)'TMAT(voo,o) ', 5979* *ddot(NCKI(ISYAIJ)*NRHF(ISYMK),TMAT(KOFF3),1,TMAT(KOFF3),1) 5980c call output(TMAT(KOFF3),1,NCKI(ISYAIJ),1,NRHF(ISYMK), 5981c * NCKI(ISYAIJ),NRHF(ISYMK),1,lupri) 5982C 5983 ENDDO 5984C 5985C CALL CC_GATHER(LENGTH,SMAT,WORK,INDSQ(1,3)) 5986 DO I = 1,LENGTH 5987 WMAT(I) = WMAT(I) + TMAT(INDSQ(I,3)) 5988 ENDDO 5989C 5990 IF (IPRINT .GT. 55) THEN 5991 XWMAT = DDOT(NCKIJ(JSAIKJ),WMAT,1,WMAT,1) 5992 WRITE(LUPRI,*) 'In WBARXBD_TMAT: vir-L1 Norm of WMAT ',XWMAT 5993 ENDIF 5994 5995 5996C------------------------------------------------------------ 5997C First virtual contribution of g term. 5998C 5999C WMAT^BC(aikj) = WMAT^BC(aikj) - T2TP(ajkd)*g(iBd^C) 6000C------------------------------------------------------------ 6001C 6002 ISYMBC = MULD2H(ISYMB,ISYMC) 6003 ISYRES = MULD2H(ISINT2,ISYMT2) 6004 JSAIKJ = MULD2H(ISYMBC,ISYRES) 6005 ISYMDI = MULD2H(ISYMBC,ISINT2) 6006C 6007 LENGTH = NCKIJ(JSAIKJ) 6008C 6009 CALL DZERO(TMAT,LENGTH) 6010C 6011 DO ISYMI = 1,NSYM 6012C 6013 ISYMD = MULD2H(ISYMI,ISYMDI) 6014 ISYAJK = MULD2H(ISYMI,JSAIKJ) 6015C 6016 KOFF1 = IT2SP(ISYAJK,ISYMD) + 1 6017 KOFF2 = ICKATR(ISYMDI,ISYMB) + NT1AM(ISYMDI)*(B - 1) 6018 * + IT1AM(ISYMD,ISYMI) + 1 6019 KOFF3 = ISAIKJ(ISYAJK,ISYMI) + 1 6020C 6021 NTOAJK = MAX(1,NCKI(ISYAJK)) 6022 NVIRD = MAX(NVIR(ISYMD),1) 6023C 6024C Virtual-g 1.0 contribution addWMAT 6025C 6026 CALL DGEMM('N','N',NCKI(ISYAJK),NRHF(ISYMI), 6027 * NVIR(ISYMD),ONE,T2TP(KOFF1),NTOAJK, 6028 * VGDKCB(KOFF2),NVIRD,ONE, 6029 * TMAT(KOFF3),NTOAJK) 6030C 6031 ENDDO 6032C 6033 DO I = 1,LENGTH 6034 WMAT(I) = WMAT(I) - TMAT(INDSQ(I,5)) 6035 ENDDO 6036C 6037 IF (IPRINT .GT. 55) THEN 6038 XWMAT = DDOT(NCKIJ(JSAIKJ),WMAT,1,WMAT,1) 6039 WRITE(LUPRI,*) 'In WBARXBD_TMAT: vir-g1 Norm of WMAT ',XWMAT 6040 ENDIF 6041C 6042C------------------------------------------------------------ 6043C Second virtual contribution of L term. 6044C 6045C WMAT^BC(aikj) = WMAT^BC(aikj) + T2TP(aikd)*L(d^CjB) 6046C------------------------------------------------------------ 6047C 6048 ISYMBC = MULD2H(ISYMB,ISYMC) 6049 ISYRES = MULD2H(ISINT2,ISYMT2) 6050 JSAIKJ = MULD2H(ISYMBC,ISYRES) 6051 ISYMDJ = MULD2H(ISYMBC,ISINT2) 6052C 6053 LENGTH = NCKIJ(JSAIKJ) 6054C 6055 CALL DZERO(TMAT,LENGTH) 6056C 6057 DO ISYMJ = 1,NSYM 6058C 6059 ISYMD = MULD2H(ISYMJ,ISYMDJ) 6060 ISYAIK = MULD2H(ISYMJ,JSAIKJ) 6061C 6062 KOFF1 = IT2SP(ISYAIK,ISYMD) + 1 6063 KOFF2 = ICKATR(ISYMDJ,ISYMB) + NT1AM(ISYMDJ)*(B - 1) 6064 * + IT1AM(ISYMD,ISYMJ) + 1 6065 KOFF3 = ISAIKJ(ISYAIK,ISYMJ) + 1 6066C 6067 NTOAIK = MAX(1,NCKI(ISYAIK)) 6068 NVIRD = MAX(NVIR(ISYMD),1) 6069C 6070C Virtual-L 2.0 contribution addWMAT 6071C 6072 CALL DGEMM('N','N',NCKI(ISYAIK),NRHF(ISYMJ), 6073 * NVIR(ISYMD),ONE,T2TP(KOFF1),NTOAIK, 6074 * VLDKCB(KOFF2),NVIRD,ONE, 6075 * TMAT(KOFF3),NTOAIK) 6076C 6077 ENDDO 6078C 6079 DO I = 1,LENGTH 6080 WMAT(I) = WMAT(I) + TMAT(I) 6081 ENDDO 6082C 6083 IF (IPRINT .GT. 55) THEN 6084 XWMAT = DDOT(NCKIJ(JSAIKJ),WMAT,1,WMAT,1) 6085 WRITE(LUPRI,*) 'In WBARXBD_TMAT: vir-L2 Norm of WMAT ',XWMAT 6086 ENDIF 6087C 6088C------------------------------------------------------------ 6089C Second virtual contribution of g term. 6090C 6091C WMAT^BC(aikj) = WMAT^BC(aikj) - T2TP(akjd)*g(iCd^B) 6092C------------------------------------------------------------ 6093C 6094 ISYMBC = MULD2H(ISYMB,ISYMC) 6095 ISYRES = MULD2H(ISINT2,ISYMT2) 6096 JSAIKJ = MULD2H(ISYMBC,ISYRES) 6097 ISYMDI = MULD2H(ISYMBC,ISINT2) 6098C 6099 LENGTH = NCKIJ(JSAIKJ) 6100C 6101 CALL DZERO(TMAT,LENGTH) 6102C 6103 DO ISYMI = 1,NSYM 6104C 6105 ISYMD = MULD2H(ISYMI,ISYMDI) 6106 ISYAKJ = MULD2H(ISYMI,JSAIKJ) 6107C 6108 KOFF1 = IT2SP(ISYAKJ,ISYMD) + 1 6109 KOFF2 = ICKATR(ISYMDI,ISYMB) + NT1AM(ISYMDI)*(B - 1) 6110 * + IT1AM(ISYMD,ISYMI) + 1 6111 KOFF3 = ISAIKJ(ISYAKJ,ISYMI) + 1 6112C 6113 NTOAKJ = MAX(1,NCKI(ISYAKJ)) 6114 NVIRD = MAX(NVIR(ISYMD),1) 6115C 6116C Virtual-g 2.0 contribution addWMAT 6117C 6118 CALL DGEMM('N','N',NCKI(ISYAKJ),NRHF(ISYMI), 6119 * NVIR(ISYMD),ONE,T2TP(KOFF1),NTOAKJ, 6120 * VGDKBC(KOFF2),NVIRD,ONE, 6121 * TMAT(KOFF3),NTOAKJ) 6122C 6123 ENDDO 6124C 6125C 6126 DO I = 1,LENGTH 6127 WMAT(I) = WMAT(I) - TMAT(INDSQ(I,2)) 6128 ENDDO 6129C 6130 IF (IPRINT .GT. 55) THEN 6131 XWMAT = DDOT(NCKIJ(JSAIKJ),WMAT,1,WMAT,1) 6132 WRITE(LUPRI,*) 'In WBARXBD_TMAT: vir-g2 Norm of WMAT ',XWMAT 6133 ENDIF 6134C 6135C------------------------------------------- 6136C First occupied L contribution. 6137C 6138C WMAT^BC(aikj) = WMAT^BC(aikj) 6139C + T2TP(ailB)*L(jl^kC) 6140C 6141C TB(ail)*LC(l^kj) = R(aikj) 6142C------------------------------------------- 6143C 6144 ISYMBC = MULD2H(ISYMB,ISYMC) 6145 ISYRES = MULD2H(ISINT2,ISYMT2) 6146 JSAIKJ = MULD2H(ISYMBC,ISYRES) 6147C 6148 ISYAIL = MULD2H(ISYMB,ISYMT2) 6149 ISYLKJ = MULD2H(ISYMC,ISINT2) 6150C 6151 CALL DZERO(TMAT,LENGTH) 6152C 6153 DO ISYMJ = 1,NSYM 6154C 6155 ISYMLK = MULD2H(ISYMJ,ISYLKJ) 6156C 6157 DO J = 1,NRHF(ISYMJ) 6158C 6159 DO ISYMK = 1,NSYM 6160C 6161 ISYML = MULD2H(ISYMK,ISYMLK) 6162 ISYMAI = MULD2H(ISYAIL,ISYML) 6163 ISYAIK = MULD2H(ISYMAI,ISYMK) 6164C 6165 KOFF1 = IT2SP(ISYAIL,ISYMB) 6166 * + NCKI(ISYAIL)*(B - 1) 6167 * + ICKI(ISYMAI,ISYML) + 1 6168 KOFF2 = ISJIKA(ISYLKJ,ISYMC) 6169 * + NMAJIK(ISYLKJ)*(C - 1) 6170 * + ISJIK(ISYMLK,ISYMJ) 6171 * + NMATIJ(ISYMLK)*(J - 1) 6172 * + IMATIJ(ISYML,ISYMK) + 1 6173 KOFF3 = ISAIKJ(ISYAIK,ISYMJ) 6174 * + NCKI(ISYAIK)*(J - 1) 6175 * + ICKI(ISYMAI,ISYMK) + 1 6176C 6177 NTOTAI = MAX(1,NT1AM(ISYMAI)) 6178 NRHFL = MAX(1,NRHF(ISYML)) 6179C 6180C Occupied-L 1.0 contribution addWMAT 6181C 6182 CALL DGEMM('N','N',NT1AM(ISYMAI),NRHF(ISYMK), 6183 * NRHF(ISYML),ONE,T2TP(KOFF1),NTOTAI, 6184 * TROCCL(KOFF2),NRHFL,ONE,TMAT(KOFF3), 6185 * NTOTAI) 6186C 6187 ENDDO 6188 ENDDO 6189 ENDDO 6190C 6191 DO I = 1,NCKIJ(JSAIKJ) 6192 WMAT(I) = WMAT(I) - TMAT(I) 6193 ENDDO 6194 IF (IPRINT .GT. 55) THEN 6195 XWMAT = DDOT(NCKIJ(JSAIKJ),WMAT,1,WMAT,1) 6196 WRITE(LUPRI,*) 'In WBARXBD_TMAT: occ-L1 Norm of WMAT ',XWMAT 6197 ENDIF 6198C 6199C------------------------------------------- 6200C Second occupied L contribution. 6201C 6202C WMAT^BC(aikj) = WMAT^BC(aikj) 6203C + T2TP(ailC)*L(kl^jB) 6204C 6205C TC(ail)*LB(l^jk) = R(aijk) 6206C 6207C------------------------------------------- 6208C 6209 6210 ISYMBC = MULD2H(ISYMB,ISYMC) 6211 ISYRES = MULD2H(ISINT2,ISYMT2) 6212 JSAIKJ = MULD2H(ISYMBC,ISYRES) 6213C 6214 ISYAIL = MULD2H(ISYMC,ISYMT2) 6215 ISYLKJ = MULD2H(ISYMB,ISINT2) 6216C 6217 CALL DZERO(TMAT,LENGTH) 6218C 6219 DO ISYMJ = 1,NSYM 6220C 6221 ISYMLK = MULD2H(ISYMJ,ISYLKJ) 6222C 6223 DO J = 1,NRHF(ISYMJ) 6224C 6225 DO ISYMK = 1,NSYM 6226C 6227 ISYML = MULD2H(ISYMK,ISYMLK) 6228 ISYMAI = MULD2H(ISYAIL,ISYML) 6229 ISYAIK = MULD2H(ISYMAI,ISYMK) 6230C 6231 KOFF1 = IT2SP(ISYAIL,ISYMC) 6232 * + NCKI(ISYAIL)*(C - 1) 6233 * + ICKI(ISYMAI,ISYML) + 1 6234 KOFF2 = ISJIKA(ISYLKJ,ISYMB) 6235 * + NMAJIK(ISYLKJ)*(B - 1) 6236 * + ISJIK(ISYMLK,ISYMJ) 6237 * + NMATIJ(ISYMLK)*(J - 1) 6238 * + IMATIJ(ISYML,ISYMK) + 1 6239 KOFF3 = ISAIKJ(ISYAIK,ISYMJ) 6240 * + NCKI(ISYAIK)*(J - 1) 6241 * + ICKI(ISYMAI,ISYMK) + 1 6242C 6243 NTOTAI = MAX(1,NT1AM(ISYMAI)) 6244 NRHFL = MAX(1,NRHF(ISYML)) 6245C 6246C Occupied-L 2.0 contribution addWMAT 6247C 6248 CALL DGEMM('N','N',NT1AM(ISYMAI),NRHF(ISYMK), 6249 * NRHF(ISYML),ONE,T2TP(KOFF1),NTOTAI, 6250 * TROCCL(KOFF2),NRHFL,ONE,TMAT(KOFF3), 6251 * NTOTAI) 6252C 6253 ENDDO 6254 ENDDO 6255 ENDDO 6256C 6257 DO I = 1,NCKIJ(JSAIKJ) 6258 WMAT(I) = WMAT(I) - TMAT(INDSQ(I,3)) 6259 ENDDO 6260 IF (IPRINT .GT. 55) THEN 6261 XWMAT = DDOT(NCKIJ(JSAIKJ),WMAT,1,WMAT,1) 6262 WRITE(LUPRI,*) 'In WBARXBD_TMAT: occ-L2 Norm of WMAT ',XWMAT 6263 ENDIF 6264 6265C 6266C 6267C------------------------------------------- 6268C First occupied g contribution. 6269C 6270C WMAT^BC(aikj) = WMAT^BC(aikj) 6271C - T2TP(alkB)*g(il^jC) 6272C 6273C TB(akl)*gC(l^ji) = R(akji) 6274C 6275C------------------------------------------- 6276C 6277C 6278 ISYMBC = MULD2H(ISYMB,ISYMC) 6279 ISYRES = MULD2H(ISINT2,ISYMT2) 6280 JSAIKJ = MULD2H(ISYMBC,ISYRES) 6281C 6282 ISYALK = MULD2H(ISYMB,ISYMT2) 6283 ISYLJI = MULD2H(ISYMC,ISINT2) 6284C 6285 KALK = 1 6286 KEND1 = KALK + NCKI(ISYALK) 6287 LWRK1 = LWORK - KEND1 6288C 6289 IF (LWRK1 .LT. 0) THEN 6290 CALL QUIT('Not enough space in WBARXBD_TMAT (1)') 6291 END IF 6292C 6293 CALL DZERO(TMAT,NCKIJ(JSAIKJ)) 6294C 6295C 6296C T2TP(alkB) put in WORK(akl) 6297C 6298 KOFF = IT2SP(ISYALK,ISYMB) + NCKI(ISYALK)*(B - 1) + 1 6299 CALL CC_GATHER(NCKI(ISYALK),WORK(KALK),T2TP(KOFF),INDAJLB) 6300C 6301 DO ISYMI = 1,NSYM 6302C 6303 ISYAKJ = MULD2H(JSAIKJ,ISYMI) 6304 ISYMLJ = MULD2H(ISYLJI,ISYMI) 6305 DO I = 1,NRHF(ISYMI) 6306C 6307 DO ISYML = 1,NSYM 6308C 6309 ISYMAK = MULD2H(ISYALK,ISYML) 6310 ISYMJ = MULD2H(ISYMLJ,ISYML) 6311C 6312 KOFF1 = KALK 6313 * + ICKI(ISYMAK,ISYML) 6314 KOFF2 = ISJIKA(ISYLJI,ISYMC) 6315 * + NMAJIK(ISYLJI)*(C - 1) 6316 * + ISJIK(ISYMLJ,ISYMI) 6317 * + NMATIJ(ISYMLJ)*(I - 1) 6318 * + IMATIJ(ISYML,ISYMJ) + 1 6319 KOFF3 = ISAIKJ(ISYAKJ,ISYMI) 6320 * + NCKI(ISYAKJ)*(I - 1) 6321 * + ICKI(ISYMAK,ISYMJ) + 1 6322C 6323 NTOTAK = MAX(1,NT1AM(ISYMAK)) 6324 NRHFL = MAX(1,NRHF(ISYML)) 6325C 6326C Occupied-g 1.0 contribution addWMAT 6327C 6328 CALL DGEMM('N','N',NT1AM(ISYMAK),NRHF(ISYMJ), 6329 * NRHF(ISYML),ONE,WORK(KOFF1),NTOTAK, 6330 * TROCCG(KOFF2),NRHFL,ONE,TMAT(KOFF3), 6331 * NTOTAK) 6332C 6333 ENDDO 6334 ENDDO 6335 ENDDO 6336C 6337 DO I = 1,NCKIJ(JSAIKJ) 6338 WMAT(I) = WMAT(I) + TMAT(INDSQ(I,2)) 6339 ENDDO 6340C 6341 IF (IPRINT .GT. 55) THEN 6342 XWMAT = DDOT(NCKIJ(JSAIKJ),WMAT,1,WMAT,1) 6343 WRITE(LUPRI,*) 'In WBARXBD_TMAT: occ-g1 Norm of WMAT ',XWMAT 6344 ENDIF 6345C 6346 6347C------------------------------------------- 6348C Second occupied g contribution. 6349C 6350C WMAT^BC(aikj) = WMAT^BC(aikj) 6351C - T2TP(aljC)*g(il^kB) 6352C 6353C TC(ajl)*gB(l^ki) = R(ajki) 6354C------------------------------------------- 6355C 6356 ISYMBC = MULD2H(ISYMB,ISYMC) 6357 ISYRES = MULD2H(ISINT2,ISYMT2) 6358 JSAIKJ = MULD2H(ISYMBC,ISYRES) 6359C 6360 ISYAJL = MULD2H(ISYMC,ISYMT2) 6361 ISYLKI = MULD2H(ISYMB,ISINT2) 6362C 6363 KALJ = 1 6364 KEND1 = KALJ + NCKI(ISYAJL) 6365 LWRK1 = LWORK - KEND1 6366C 6367 IF (LWRK1 .LT. 0) THEN 6368 CALL QUIT('Not enough space in WBARXBD_TMAT (2)') 6369 END IF 6370C 6371 CALL DZERO(TMAT,NCKIJ(JSAIKJ)) 6372C 6373C 6374C T2TP(aljC) put in WORK(ajl) 6375C 6376 KOFF = IT2SP(ISYAJL,ISYMC) + NCKI(ISYAJL)*(C - 1) + 1 6377 CALL CC_GATHER(NCKI(ISYAJL),WORK(KALJ),T2TP(KOFF),INDAJLC) 6378C 6379 DO ISYMI = 1,NSYM 6380C 6381 ISYAJK = MULD2H(JSAIKJ,ISYMI) 6382 ISYMLK = MULD2H(ISYLKI,ISYMI) 6383 DO I = 1,NRHF(ISYMI) 6384C 6385 DO ISYML = 1,NSYM 6386C 6387 ISYMAJ = MULD2H(ISYAJL,ISYML) 6388 ISYMK = MULD2H(ISYMLK,ISYML) 6389C 6390 KOFF1 = KALJ 6391 * + ICKI(ISYMAJ,ISYML) 6392 KOFF2 = ISJIKA(ISYLKI,ISYMB) 6393 * + NMAJIK(ISYLKI)*(B - 1) 6394 * + ISJIK(ISYMLK,ISYMI) 6395 * + NMATIJ(ISYMLK)*(I - 1) 6396 * + IMATIJ(ISYML,ISYMK) + 1 6397 KOFF3 = ISAIKJ(ISYAJK,ISYMI) 6398 * + NCKI(ISYAJK)*(I - 1) 6399 * + ICKI(ISYMAJ,ISYMK) + 1 6400C 6401 NTOTAJ = MAX(1,NT1AM(ISYMAJ)) 6402 NRHFL = MAX(1,NRHF(ISYML)) 6403C 6404C Occupied-g 2.0 contribution addWMAT 6405C 6406 CALL DGEMM('N','N',NT1AM(ISYMAJ),NRHF(ISYMK), 6407 * NRHF(ISYML),ONE,WORK(KOFF1),NTOTAJ, 6408 * TROCCG(KOFF2),NRHFL,ONE,TMAT(KOFF3), 6409 * NTOTAJ) 6410C 6411 ENDDO 6412 ENDDO 6413 ENDDO 6414C 6415 DO I = 1,NCKIJ(JSAIKJ) 6416 WMAT(I) = WMAT(I) + TMAT(INDSQ(I,5)) 6417 ENDDO 6418C 6419 IF (IPRINT .GT. 55) THEN 6420 XWMAT = DDOT(NCKIJ(JSAIKJ),WMAT,1,WMAT,1) 6421 WRITE(LUPRI,*) 'In WBARXBD_TMAT: occ-g2 Norm of WMAT ',XWMAT 6422 ENDIF 6423C 6424 ELSE IF (AIBJCK_PERM .EQ. 3) THEN 6425C 6426C-------------------------------------------------------------------------- 6427C 6428C WMAT^BC(aikj) = WMAT^BC(aikj) + T2TP(CkjB)*F(ia) 6429C - T2TP(CkiB)*F(ja) 6430C + T2TP(Ckia)*F(jB) 6431C - T2TP(Ckja)*F(iB) 6432C 6433C-------------------------------------------------------------------------- 6434C Contribution from both Fock terms: 6435C-------------------------------------------------------------------------- 6436C 6437 CALL DZERO(TMAT,LENGTH) 6438C 6439C WMAT^BC(aikj) = WMAT^BC(aikj) + T2TP(CkjB)*F(ia) 6440C WMAT^BC(aikj) = WMAT^BC(aikj) - T2TP(CkiB)*F(ja) 6441C 6442 ISYMAI = ISYFOCK 6443 ISYCKJ = MULD2H(ISYMT2,ISYMB) 6444 ISYKJ = MULD2H(ISYCKJ,ISYMC) 6445C 6446 DO ISYMJ = 1, NSYM 6447 ISYMK = MULD2H(ISYKJ,ISYMJ) 6448 ISYMCK = MULD2H(ISYMC,ISYMK) 6449 ISYAIK = MULD2H(ISYMAI,ISYMK) 6450 DO ISYMI = 1, NSYM 6451 ISYMA = MULD2H(ISYMAI,ISYMI) 6452C 6453 DO J = 1, NRHF(ISYMJ) 6454C 6455 DO I = 1, NRHF(ISYMI) 6456 DO A = 1, NVIR(ISYMA) 6457C 6458 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I-1) + A 6459C 6460C Index for sorted T2 amplitudes. 6461C 6462 DO K = 1, NRHF(ISYMK) 6463C 6464 NCK = IT1AM(ISYMC,ISYMK) + NVIR(ISYMC)*(K-1) +C 6465 NCKJB = IT2SP(ISYCKJ,ISYMB) 6466 * + NCKI(ISYCKJ)*(B - 1) 6467 * + ICKI(ISYMCK,ISYMJ) 6468 * + NT1AM(ISYMCK)*(J - 1) + NCK 6469C 6470 NAIKJ = ISAIKJ(ISYAIK,ISYMJ) 6471 * + NCKI(ISYAIK)*(J - 1) 6472 * + ICKI(ISYMAI,ISYMK) 6473 * + NT1AM(ISYMAI)*(K-1) 6474 * + NAI 6475 6476C 6477 6478 TMAT(NAIKJ) = T2TP(NCKJB)*FOCK(NAI) 6479C 6480 ENDDO 6481 ENDDO 6482 ENDDO 6483 ENDDO 6484 ENDDO 6485 ENDDO 6486C 6487C------------------------------------------- 6488C Sum the result into WMAT. 6489C------------------------------------------- 6490C 6491 DO I = 1, LENGTH 6492C Fock 1.0 contribution addWMAT 6493C First : WMAT^BC(aikj) = WMAT^BC(aikj) + T2TP(CkjB)*F(ia) 6494 WMAT(I) = WMAT(I) + TMAT(I) 6495C Fock 2.0 contribution addWMAT 6496C Second : WMAT^BC(aikj) = WMAT^BC(aikj) - T2TP(CkiB)*F(ja) 6497 WMAT(I) = WMAT(I) - TMAT(INDSQ(I,5)) 6498 ENDDO 6499C 6500C------------------------------------------ 6501C Third and fourth Fock term 6502C------------------------------------------ 6503C 6504 CALL DZERO(TMAT,LENGTH) 6505C 6506C WMAT^BC(aikj) = WMAT^BC(aikj) + T2TP(Ckia)*F(jB) 6507 !note that T2TP(Ckia) = T2TP(aikC) 6508C WMAT^BC(aikj) = WMAT^BC(aikj) - T2TP(Ckja)*F(iB) 6509C 6510 ISYMJ = MULD2H(ISYFOCK,ISYMB) 6511 ISYAIK = MULD2H(ISYMT2,ISYMC) 6512C 6513 DO ISYMK = 1, NSYM 6514 ISYMAI = MULD2H(ISYAIK,ISYMK) 6515 DO ISYMI = 1, NSYM 6516 ISYMA = MULD2H(ISYMAI,ISYMI) 6517C 6518 DO J = 1, NRHF(ISYMJ) 6519 NBJ = IT1AM(ISYMB,ISYMJ) + NVIR(ISYMB)*(J-1) + B 6520C 6521 DO I = 1, NRHF(ISYMI) 6522 DO A = 1, NVIR(ISYMA) 6523C 6524 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I-1) + A 6525C 6526C Index for sorted T2 amplitudes. 6527C 6528 DO K = 1, NRHF(ISYMK) 6529C 6530 !note that T2TP(Ckia) = T2TP(aikC) 6531 NAIKC = IT2SP(ISYAIK,ISYMC) 6532 * + NCKI(ISYAIK)*(C - 1) 6533 * + ICKI(ISYMAI,ISYMK) 6534 * + NT1AM(ISYMAI)*(K - 1) + NAI 6535C 6536 NAIKJ = ISAIKJ(ISYAIK,ISYMJ) 6537 * + NCKI(ISYAIK)*(J - 1) 6538 * + ICKI(ISYMAI,ISYMK) 6539 * + NT1AM(ISYMAI)*(K-1) 6540 * + NAI 6541 6542C 6543 TMAT(NAIKJ) = T2TP(NAIKC)*FOCK(NBJ) 6544C 6545 ENDDO 6546 ENDDO 6547 ENDDO 6548 ENDDO 6549 ENDDO 6550 ENDDO 6551C 6552C------------------------------------------- 6553C Sum the result into WMAT. 6554C------------------------------------------- 6555C 6556 DO I = 1, LENGTH 6557C Fock 3.0 contribution addWMAT 6558C First : WMAT^BC(aikj) = WMAT^BC(aikj) + T2TP(Ckia)*F(jB) 6559 WMAT(I) = WMAT(I) + TMAT(I) 6560C Fock 4.0 contribution addWMAT 6561C Second : WMAT^BC(aikj) = WMAT^BC(aikj) - T2TP(Ckja)*F(iB) 6562 WMAT(I) = WMAT(I) - TMAT(INDSQ(I,5)) 6563 ENDDO 6564C 6565C-------------------------------------------------------------------------- 6566C Calculate ALL virtual contributions here (in ILOOP = 1,4 loop) 6567C Can be done, because: g(kad^B) = g(d^Bka), etc. 6568C At the end use appropriate INDSQ. 6569C 6570C First virtual contribution of L term. 6571C WMAT^BC(aikj) = WMAT^BC(aikj) + T2TP(Ckjd)*L(d^Bia) (ILOOP = 1) 6572C 6573C First virtual contribution of g term. 6574C WMAT^BC(aikj) = WMAT^BC(aikj) - T2TP(Cjid)*g(kBd^a) (ILOOP = 2) 6575C 6576C Second virtual contribution of L term. 6577C WMAT^BC(aikj) = WMAT^BC(aikj) + T2TP(Ckid)*L(d^ajB) (ILOOP = 3) 6578C 6579C Second virtual contribution of g term. 6580C WMAT^BC(aikj) = WMAT^BC(aikj) - T2TP(Cijd)*g(kad^B) (ILOOP = 4) 6581C 6582C-------------------------------------------------------------------------- 6583C 6584 6585 ISYMBC = MULD2H(ISYMB,ISYMC) 6586 ISYRES = MULD2H(ISINT2,ISYMT2) 6587 JSAIKJ = MULD2H(ISYMBC,ISYRES) 6588C 6589 ISYAID = MULD2H(ISINT2,ISYMB) 6590 ISYDJK = MULD2H(ISYMT2,ISYMC) 6591C 6592 DO ILOOP = 1,4 6593 !sort integrals from VLDKCB(di,a) to KAID(ai,d) 6594 KAID = 1 6595 KEND1 = KAID + NCKATR(ISYAID) 6596 LWRK1 = LWORK - KEND1 6597C 6598 IF (LWRK1 .LT. NCKATR(ISYAID)) THEN 6599 WRITE(LUPRI,*)'Memory available : ', LWRK1 6600 WRITE(LUPRI,*)'Memory needed : ', NCKATR(ISYAID) 6601 IF (ILOOP .EQ. 1) THEN 6602 CALL QUIT('Not enough space in WBARXBD_TMAT (3a)') 6603 ELSE IF (ILOOP .EQ. 2) THEN 6604 CALL QUIT('Not enough space in WBARXBD_TMAT (3b)') 6605 ELSE IF (ILOOP .EQ. 3) THEN 6606 CALL QUIT('Not enough space in WBARXBD_TMAT (3c)') 6607 ELSE IF (ILOOP .EQ. 4) THEN 6608 CALL QUIT('Not enough space in WBARXBD_TMAT (3d)') 6609 END IF 6610 END IF 6611C 6612 IF (ILOOP .EQ. 1) THEN 6613 CALL DCOPY(NCKATR(ISYAID),VLDKCB,1,WORK(KAID),1) 6614 ELSE IF (ILOOP .EQ. 2) THEN 6615 CALL DCOPY(NCKATR(ISYAID),VGDKBC,1,WORK(KAID),1) 6616 ELSE IF (ILOOP .EQ. 3) THEN 6617 CALL DCOPY(NCKATR(ISYAID),VLDKBC,1,WORK(KAID),1) 6618 ELSE IF (ILOOP .EQ. 4) THEN 6619 CALL DCOPY(NCKATR(ISYAID),VGDKCB,1,WORK(KAID),1) 6620 END IF 6621 CALL CCSDT_SRVIR3(WORK(KAID),WORK(KEND1),ISYMB,B,ISINT2) 6622C 6623 LENGTH = NCKIJ(JSAIKJ) 6624C 6625 CALL DZERO(TMAT,LENGTH) 6626C 6627 DO ISYMK = 1,NSYM 6628 ISYDJ = MULD2H(ISYDJK,ISYMK) 6629 DO ISYMJ = 1,NSYM 6630 ISYMD = MULD2H(ISYDJ,ISYMJ) 6631 ISYAI = MULD2H(ISYAID,ISYMD) 6632 ISYAIJ = MULD2H(ISYAI,ISYMJ) 6633 DO K = 1,NRHF(ISYMK) 6634C 6635 KOFF1 = KAID 6636 * + ICKATR(ISYAI,ISYMD) 6637 KOFF2 = IT2SP(ISYDJK,ISYMC) 6638 * + NCKI(ISYDJK)*(C-1) 6639 * + ICKI(ISYDJ,ISYMK) 6640 * + NT1AM(ISYDJ)*(K-1) 6641 * + IT1AM(ISYMD,ISYMJ) 6642 * + 1 6643 KOFF3 = ISAIKJ(ISYAIJ,ISYMK) 6644 * + NCKI(ISYAIJ)*(K-1) 6645 * + ICKI(ISYAI,ISYMJ) 6646 * + 1 6647C 6648 NTOTAI = MAX(1,NT1AM(ISYAI)) 6649 NVIRD = MAX(NVIR(ISYMD),1) 6650C 6651C Virtual-L 1.0 contribution addWMAT 6652C 6653 CALL DGEMM('N','N',NT1AM(ISYAI),NRHF(ISYMJ), 6654 * NVIR(ISYMD),ONE,WORK(KOFF1),NTOTAI, 6655 * T2TP(KOFF2),NVIRD,ONE, 6656 * TMAT(KOFF3),NTOTAI) 6657C 6658 ENDDO 6659 ENDDO 6660 ENDDO 6661C 6662C CALL CC_GATHER(LENGTH,SMAT,WORK,INDSQ(1,3)) 6663 DO I = 1,LENGTH 6664 IF (ILOOP .EQ. 1) THEN 6665 WMAT(I) = WMAT(I) + TMAT(INDSQ(I,3)) 6666 ELSE IF (ILOOP .EQ. 2) THEN 6667 WMAT(I) = WMAT(I) - TMAT(INDSQ(I,1)) 6668 ELSE IF (ILOOP .EQ. 3) THEN 6669 WMAT(I) = WMAT(I) + TMAT(INDSQ(I,4)) 6670 ELSE IF (ILOOP .EQ. 4) THEN 6671 WMAT(I) = WMAT(I) - TMAT(INDSQ(I,2)) 6672 END IF 6673 ENDDO 6674C 6675 IF (IPRINT .GT. 55) THEN 6676 XWMAT = DDOT(NCKIJ(JSAIKJ),WMAT,1,WMAT,1) 6677 IF (ILOOP .EQ. 1) THEN 6678 WRITE(LUPRI,*) 'WBARXBD_TMAT virL1 Norm of WMAT ',XWMAT 6679 ELSE IF (ILOOP .EQ. 2) THEN 6680 WRITE(LUPRI,*) 'WBARXBD_TMAT virg2 Norm of WMAT ',XWMAT 6681 ELSE IF (ILOOP .EQ. 3) THEN 6682 WRITE(LUPRI,*) 'WBARXBD_TMAT virL2 Norm of WMAT ',XWMAT 6683 ELSE IF (ILOOP .EQ. 4) THEN 6684 WRITE(LUPRI,*) 'WBARXBD_TMAT virg2 Norm of WMAT ',XWMAT 6685 END IF 6686 ENDIF 6687C 6688 END DO ! ILOOP 6689C 6690C--------------------------------------------------------------------- 6691C First occupied L contribution. 6692C WMAT^BC(aikj) = WMAT^BC(aikj) - T2TP(CklB)*L(jl^ia) (ILOOP = 1) 6693C 6694C First occupied g contribution. 6695C WMAT^BC(aikj) = WMAT^BC(aikj) + T2TP(BilC)*g(kl^ja) (ILOOP = 2) 6696C 6697C--------------------------------------------------------------------- 6698C 6699 ISYMBC = MULD2H(ISYMB,ISYMC) 6700 ISYRES = MULD2H(ISINT2,ISYMT2) 6701 JSAIKJ = MULD2H(ISYMBC,ISYRES) 6702C 6703 !T2TP(BlkC) = T2TP(CklB) 6704 ISYLK = MULD2H(ISYMT2,ISYMBC) 6705C 6706 DO ILOOP = 1,2 6707C 6708 KLK = 1 6709 KAJIL = KLK + NMATIJ(ISYLK) 6710 KEND1 = KAJIL + NTRAOC(ISINT2) 6711 LWRK1 = LWORK - KEND1 6712C 6713 IF (LWRK1 .LT. 0) THEN 6714 WRITE(LUPRI,*)'Memory available : ', LWORK 6715 WRITE(LUPRI,*)'Memory needed : ', KEND1 6716 IF (ILOOP .EQ. 1) THEN 6717 CALL QUIT('Not enough space in WBARXBD_TMAT (4a)') 6718 ELSE IF (ILOOP .EQ. 2) THEN 6719 CALL QUIT('Not enough space in WBARXBD_TMAT (4b)') 6720 END IF 6721 END IF 6722C 6723 CALL DZERO(TMAT,LENGTH) 6724C 6725 !sort from T2TP(BlkC) to KLK(lk) 6726 IF (ILOOP .EQ. 1) THEN 6727 CALL SORT_T2_IJ(WORK(KLK),ISYMB,B,ISYMC,C,T2TP,ISYMT2) 6728 ELSE IF (ILOOP .EQ. 2) THEN 6729 CALL SORT_T2_IJ(WORK(KLK),ISYMC,C,ISYMB,B,T2TP,ISYMT2) 6730 END IF 6731 !sort from TROCCL(lij,a) to KAJIL(ajil) 6732 IF (ILOOP .EQ. 1) THEN 6733 CALL CCFOP_SORT(TROCCL,WORK(KAJIL),ISINT2,1) 6734 ELSE IF (ILOOP .EQ. 2) THEN 6735 CALL CCFOP_SORT(TROCCG,WORK(KAJIL),ISINT2,1) 6736 END IF 6737C 6738 !multiply KAJIL(aji,l)*KLK(l,k) --> TMAT(aji,k) (ILOOP = 1) 6739 !multiply KAJIL(akj,l)*KLK(l,i) --> TMAT(akj,i) (ILOOP = 2) 6740C 6741 DO ISYML = 1,NSYM 6742 ISYMK = MULD2H(ISYLK,ISYML) 6743 ISYAJI = MULD2H(JSAIKJ,ISYMK) 6744C 6745 KOFF1 = KAJIL 6746 * + ISAIKJ(ISYAJI,ISYML) 6747C 6748 KOFF2 = KLK 6749 * + IMATIJ(ISYML,ISYMK) 6750C 6751 KOFF3 = ISAIKJ(ISYAJI,ISYMK) 6752 * + 1 6753C 6754 NTOTAJI = MAX(1,NCKI(ISYAJI)) 6755 NTOTL = MAX(NRHF(ISYML),1) 6756C 6757 CALL DGEMM('N','N',NCKI(ISYAJI),NRHF(ISYMK), 6758 * NRHF(ISYML),ONE,WORK(KOFF1),NTOTAJI, 6759 * WORK(KOFF2),NTOTL,ONE, 6760 * TMAT(KOFF3),NTOTAJI) 6761C 6762 END DO 6763C 6764 DO I = 1,LENGTH 6765 IF (ILOOP .EQ. 1) THEN 6766 !TMAT(ajik) --> WMAT(aikj) 6767 WMAT(I) = WMAT(I) - TMAT(INDSQ(I,4)) 6768 ELSE IF (ILOOP .EQ. 2) THEN 6769 !TMAT(akji) --> WMAT(aikj) 6770 WMAT(I) = WMAT(I) + TMAT(INDSQ(I,2)) 6771 END IF 6772 END DO 6773C 6774 END DO !ILOOP 6775C 6776C------------------------------------------------------------ 6777C Second occupied L contribution. 6778C WMAT^BC(aikj) = WMAT^BC(aikj) - T2TP(Ckla)*L(il^jB) 6779C 6780C------------------------------------------------------------ 6781C 6782 6783C 6784C------------------------------------------------------------ 6785C Second occupied g contribution. 6786C WMAT^BC(aikj) = WMAT^BC(aikj) + T2TP(ajlC)*g(kl^iB) 6787C 6788C This is part of code is actually strongly based on 6789C the second occupied L contribution in "AIBJCK_PERM = 1" 6790C part; this means that the nomenclature might be a bit 6791C confusing, because: 6792C 6793C i <--> j 6794C 6795C------------------------------------------------------------ 6796C 6797 ISYMBC = MULD2H(ISYMB,ISYMC) 6798 ISYRES = MULD2H(ISINT2,ISYMT2) 6799 JSAIKJ = MULD2H(ISYMBC,ISYRES) 6800C 6801 ISYAIL = MULD2H(ISYMC,ISYMT2) 6802 ISYLKJ = MULD2H(ISYMB,ISINT2) 6803C 6804 CALL DZERO(TMAT,LENGTH) 6805C 6806 DO ISYMJ = 1,NSYM 6807C 6808 ISYMLK = MULD2H(ISYMJ,ISYLKJ) 6809C 6810 DO J = 1,NRHF(ISYMJ) 6811C 6812 DO ISYMK = 1,NSYM 6813C 6814 ISYML = MULD2H(ISYMK,ISYMLK) 6815 ISYMAI = MULD2H(ISYAIL,ISYML) 6816 ISYAIK = MULD2H(ISYMAI,ISYMK) 6817C 6818 KOFF1 = IT2SP(ISYAIL,ISYMC) 6819 * + NCKI(ISYAIL)*(C - 1) 6820 * + ICKI(ISYMAI,ISYML) + 1 6821 KOFF2 = ISJIKA(ISYLKJ,ISYMB) 6822 * + NMAJIK(ISYLKJ)*(B - 1) 6823 * + ISJIK(ISYMLK,ISYMJ) 6824 * + NMATIJ(ISYMLK)*(J - 1) 6825 * + IMATIJ(ISYML,ISYMK) + 1 6826 KOFF3 = ISAIKJ(ISYAIK,ISYMJ) 6827 * + NCKI(ISYAIK)*(J - 1) 6828 * + ICKI(ISYMAI,ISYMK) + 1 6829C 6830 NTOTAI = MAX(1,NT1AM(ISYMAI)) 6831 NRHFL = MAX(1,NRHF(ISYML)) 6832C 6833 CALL DGEMM('N','N',NT1AM(ISYMAI),NRHF(ISYMK), 6834 * NRHF(ISYML),ONE,T2TP(KOFF1),NTOTAI, 6835 * TROCCG(KOFF2),NRHFL,ONE,TMAT(KOFF3), 6836 * NTOTAI) 6837C 6838 ENDDO 6839 ENDDO 6840 ENDDO 6841C 6842 !TMAT(ajik) --> WMAT(aikj) 6843 DO I = 1,NCKIJ(JSAIKJ) 6844 WMAT(I) = WMAT(I) + TMAT(INDSQ(I,4)) 6845 ENDDO 6846C 6847C------------------------------------------------------------ 6848C Second occupied L contribution. 6849C WMAT^BC(aikj) = WMAT^BC(aikj) - T2TP(alkC)*L(il^jB) 6850C 6851C This is part of code is actually strongly based on 6852C the second occupied g contribution in "AIBJCK_PERM = 1" 6853C part; this means that the nomenclature might be a bit 6854C confusing, because: 6855C 6856C j <--> k 6857C 6858C------------------------------------------------------------ 6859C 6860 ISYMBC = MULD2H(ISYMB,ISYMC) 6861 ISYRES = MULD2H(ISINT2,ISYMT2) 6862 JSAIKJ = MULD2H(ISYMBC,ISYRES) 6863C 6864 ISYAJL = MULD2H(ISYMC,ISYMT2) 6865 ISYLKI = MULD2H(ISYMB,ISINT2) 6866C 6867 KALJ = 1 6868 KEND1 = KALJ + NCKI(ISYAJL) 6869 LWRK1 = LWORK - KEND1 6870C 6871 IF (LWRK1 .LT. 0) THEN 6872 CALL QUIT('Not enough space in WBARXBD_TMAT (5)') 6873 END IF 6874C 6875 CALL DZERO(TMAT,NCKIJ(JSAIKJ)) 6876C 6877C 6878C T2TP(aljC) put in WORK(ajl) 6879C 6880 KOFF = IT2SP(ISYAJL,ISYMC) + NCKI(ISYAJL)*(C - 1) + 1 6881 CALL CC_GATHER(NCKI(ISYAJL),WORK(KALJ),T2TP(KOFF),INDAJLC) 6882C 6883 DO ISYMI = 1,NSYM 6884C 6885 ISYAJK = MULD2H(JSAIKJ,ISYMI) 6886 ISYMLK = MULD2H(ISYLKI,ISYMI) 6887 DO I = 1,NRHF(ISYMI) 6888C 6889 DO ISYML = 1,NSYM 6890C 6891 ISYMAJ = MULD2H(ISYAJL,ISYML) 6892 ISYMK = MULD2H(ISYMLK,ISYML) 6893C 6894 KOFF1 = KALJ 6895 * + ICKI(ISYMAJ,ISYML) 6896 KOFF2 = ISJIKA(ISYLKI,ISYMB) 6897 * + NMAJIK(ISYLKI)*(B - 1) 6898 * + ISJIK(ISYMLK,ISYMI) 6899 * + NMATIJ(ISYMLK)*(I - 1) 6900 * + IMATIJ(ISYML,ISYMK) + 1 6901 KOFF3 = ISAIKJ(ISYAJK,ISYMI) 6902 * + NCKI(ISYAJK)*(I - 1) 6903 * + ICKI(ISYMAJ,ISYMK) + 1 6904C 6905 NTOTAJ = MAX(1,NT1AM(ISYMAJ)) 6906 NRHFL = MAX(1,NRHF(ISYML)) 6907C 6908 CALL DGEMM('N','N',NT1AM(ISYMAJ),NRHF(ISYMK), 6909 * NRHF(ISYML),ONE,WORK(KOFF1),NTOTAJ, 6910 * TROCCL(KOFF2),NRHFL,ONE,TMAT(KOFF3), 6911 * NTOTAJ) 6912C 6913 ENDDO 6914 ENDDO 6915 ENDDO 6916C 6917 DO I = 1,NCKIJ(JSAIKJ) 6918 WMAT(I) = WMAT(I) - TMAT(INDSQ(I,2)) 6919 ENDDO 6920C 6921 ELSE 6922 WRITE(LUPRI,*) 'AIBJCK_PERM = ', AIBJCK_PERM 6923 WRITE(LUPRI,*) 'WBARXBD_T2 works for AIBJCK_PERM = 1 or 3' 6924 CALL QUIT('Wrong AIBJCK_PERM option in WBARXBD_TMAT') 6925 END IF 6926 6927C 6928 CALL QEXIT('WBXTMT') 6929C 6930 RETURN 6931 END 6932C /* Deck wx_bd_o */ 6933 SUBROUTINE WX_BD_O(AIBJCK_PERM,LW,LWBAR,TMAT,ISTMAT,FOCKY,ISYFKY, 6934 * WMAT,ISWMAT,WRK,LWRK) 6935* 6936* If (AIBJCK_PERM.eq.1) then (bjdk) permutation symmetry 6937* 6938* WBD(aikj) = WBD(aikj) - t(aBD,ljk) * fock(li) 6939* 6940* tmatBD(alkj) 6941* 6942* else if (AIBJCK_PERM.eq.2) then (aidk) permutation symmetry 6943* 6944* WBD(aikj) = WBD(aikj) - t(aBD,ilk) * fock(lj) 6945* 6946* tmatBD(aikl) 6947* 6948* else if (AIBJCK_PERM.eq.3) then (aibj) permutation symmetry 6949* 6950* WBD(aikj) = WBD(aikj) - t(aBD,ijl) * fock(lk) 6951* 6952* tmatBD(ailj) 6953* 6954* else if (AIBJCK_PERM.eq.4) then calculate all terms 6955* 6956* 6957* Written by P. Jorgensen and F. Pawlowski, Spring 2002. 6958* (modyfied for AIBJCK_PERM flag - spring 2003.) 6959* 6960* Autumn 2003, F. Pawlowski: 6961* 6962* Generalized to treat either the triples amplitudes 6963* (LW = .TRUE., LWBAR = .FALSE.) or 6964* the triplees multipliers (LW = .FALSE., LWBAR = .TRUE.). 6965* 6966 IMPLICIT NONE 6967C 6968#include "priunit.h" 6969#include "dummy.h" 6970#include "iratdef.h" 6971#include "ccsdsym.h" 6972#include "inftap.h" 6973#include "ccinftap.h" 6974#include "ccorb.h" 6975#include "ccsdinp.h" 6976C 6977C 6978 LOGICAL LW,LWBAR 6979C 6980 INTEGER AIBJCK_PERM 6981C 6982 INTEGER LWRK, KFCLI, KEND0, LWRK0, KOFF1, KOFF2 6983 INTEGER NL, KOFFY, KOFFT, KOFFW 6984 INTEGER ISTMAT, ISYFKY, ISWMAT, ISALKJ 6985 INTEGER ISYMA, ISYAI, ISYAIK, ISYALK, ISYAL, NA 6986 INTEGER ISYMJ, ISYMK, ISYMI, ISYML, ISYFI 6987 INTEGER ISYAIL,NAI,NAIK 6988 INTEGER NI,NJ,NK 6989C 6990#if defined (SYS_CRAY) 6991 REAL TMAT(*), FOCKY(*), WMAT(*), WRK(*) 6992 REAL HALF, ONE 6993 REAL XNORMVAL,DDOT 6994#else 6995 DOUBLE PRECISION TMAT(*), FOCKY(*), WMAT(*), WRK(*) 6996 DOUBLE PRECISION HALF, ONE 6997 DOUBLE PRECISION XNORMVAL,DDOT 6998#endif 6999C 7000 PARAMETER (HALF = 0.5D0, ONE = 1.0D0) 7001C 7002 CALL QENTER('WX_BDO') 7003C 7004C--------------------------------------- 7005C Initial test of AIBJCK_PERM option 7006C--------------------------------------- 7007C 7008 IF ( (AIBJCK_PERM .LT. 1) .OR. (AIBJCK_PERM .GT. 4) ) THEN 7009 WRITE(LUPRI,*)'AIBJCK_PERM = ',AIBJCK_PERM 7010 WRITE(LUPRI,*)'should be between 1 and 4 ' 7011 CALL QUIT('Illegal value of AIBJCK_PERM option in WX_BD_O') 7012 END IF 7013C 7014C Initial test of logical flags 7015C 7016 IF (LW .AND. .NOT.LWBAR) THEN 7017 CONTINUE 7018 ELSE IF (.NOT.LW .AND. LWBAR) THEN 7019 CONTINUE 7020 ELSE 7021 WRITE(LUPRI,*) 'LW = ', LW 7022 WRITE(LUPRI,*) 'LWBAR = ', LWBAR 7023 WRITE(LUPRI,*) 'LW and LWBAR flags must have opposite values ' 7024 CALL QUIT('Logic inconsistency in WX_BD_O') 7025 END IF 7026C 7027C RESORT OCC-OCC FOCKY ELEMENTS (L,I) 7028C 7029C 7030 KFCLI = 1 7031 KEND0 = KFCLI + NMATIJ(ISYFKY) 7032 LWRK0 = LWRK - KEND0 7033C 7034 IF (LWRK0 .LT. 0) THEN 7035 WRITE(LUPRI,*) 'Memory available : ',LWRK0 7036 WRITE(LUPRI,*) 'Memory needed : ',KEND0 7037 CALL QUIT('Insufficient space in WX_BD_O') 7038 END IF 7039C 7040 DO ISYMI = 1,NSYM 7041 ISYML = MULD2H(ISYMI,ISYFKY) 7042 DO I = 1,NRHF(ISYMI) 7043 KOFF1 = IFCRHF(ISYML,ISYMI) + NORB(ISYML)*(I - 1) + 1 7044 KOFF2 = KFCLI + IMATIJ(ISYML,ISYMI) + NRHF(ISYML)*(I - 1) 7045 CALL DCOPY(NRHF(ISYML),FOCKY(KOFF1),1,WRK(KOFF2),1) 7046 END DO 7047 END DO 7048C 7049 IF ((AIBJCK_PERM.EQ.1) .OR. (AIBJCK_PERM.EQ.4)) THEN 7050C 7051C CARRY OUT MATRIX MULTIPLICATION 7052C IF (LW) THEN 7053C WBD(a,i,k,j) = WBD(a,i-,k,j) - sum (l) tmatBD(a,l,k,j)*focky(l,i) 7054C ELSE 7055C WBD(a,i,k,j) = WBD(a,i-,k,j) - sum (l) tmatBD(a,l,k,j)*focky(i,l) 7056C 7057 ISALKJ = ISTMAT 7058 DO ISYMJ = 1,NSYM 7059 ISYALK =MULD2H(ISYMJ,ISALKJ) 7060 DO J = 1,NRHF(ISYMJ) 7061 DO ISYMK = 1,NSYM 7062 ISYAL = MULD2H(ISYMK,ISYALK) 7063 DO K = 1,NRHF(ISYMK) 7064 DO ISYML = 1,NSYM 7065 ISYMA = MULD2H(ISYAL,ISYML) 7066 ISYMI = MULD2H(ISYFKY,ISYML) 7067 ISYAIK = MULD2H(ISWMAT,ISYMJ) 7068 ISYAI = MULD2H(ISYAIK,ISYMK) 7069 NA = MAX(1,NVIR(ISYMA)) 7070C 7071 IF (LW) THEN 7072 NL = MAX(1,NRHF(ISYML)) 7073 ELSE 7074 NI = MAX(1,NRHF(ISYMI)) 7075 END IF 7076C 7077 IF (LW) THEN 7078 KOFFY = KFCLI + IMATIJ(ISYML,ISYMI) 7079 ELSE 7080 KOFFY = KFCLI + IMATIJ(ISYMI,ISYML) 7081 END IF 7082C 7083 KOFFT = ISAIKJ(ISYALK,ISYMJ) 7084 * + NCKI(ISYALK)*(J-1) 7085 * + ISAIK(ISYAL,ISYMK) 7086 * + NT1AM(ISYAL)*(K-1) 7087 * + IT1AM(ISYMA,ISYML) + 1 7088 KOFFW = ISAIKJ(ISYAIK,ISYMJ) 7089 * + NCKI(ISYAIK)*(J-1) 7090 * + ISAIK(ISYAI,ISYMK) 7091 * + NT1AM(ISYAI)*(K-1) 7092 * + IT1AM(ISYMA,ISYMI) + 1 7093C 7094C SYMMETRY BETWEEN BJ AND CK INTRODUCE A FACTOR TWO 7095C DENOTE t3 IS CALCULATED WITH NEGATIVE SIGN 7096C 7097 IF (LW) THEN 7098 CALL DGEMM('N','N',NVIR(ISYMA),NRHF(ISYMI), 7099 * NRHF(ISYML),ONE,TMAT(KOFFT),NA, 7100 * WRK(KOFFY),NL,ONE,WMAT(KOFFW),NA) 7101 ELSE 7102 CALL DGEMM('N','T',NVIR(ISYMA),NRHF(ISYMI), 7103 * NRHF(ISYML),ONE,TMAT(KOFFT),NA, 7104 * WRK(KOFFY),NI,ONE,WMAT(KOFFW),NA) 7105 END IF 7106C 7107 END DO 7108 END DO 7109 END DO 7110 END DO 7111 END DO 7112C 7113 END IF 7114 IF ((AIBJCK_PERM.EQ.2) .OR. (AIBJCK_PERM.EQ.4)) THEN 7115C 7116C WBD(aikj) = WBD(aikj) - t(aBD,ilk) * fock(lj) 7117C 7118C tmatBD(aikl) 7119C 7120C IF (LW) THEN 7121C WBD(a,i,k,j) = WBD(a,i,k,j-) - sum (l) tmatBD(a,i,k,l)*focky(l,j) 7122C ELSE 7123C WBD(a,i,k,j) = WBD(a,i,k,j-) - sum (l) tmatBD(a,i,k,l)*focky(j,l) 7124C 7125 DO ISYMJ = 1,NSYM 7126 ISYML = MULD2H(ISYFKY,ISYMJ) 7127 ISYAIK =MULD2H(ISTMAT,ISYML) 7128 NAIK = MAX(1,NCKI(ISYAIK)) 7129C 7130 IF (LW) THEN 7131 NL = MAX(1,NRHF(ISYML)) 7132 ELSE 7133 NJ = MAX(1,NRHF(ISYMJ)) 7134 END IF 7135C 7136 IF (LW) THEN 7137 KOFFY = KFCLI + IMATIJ(ISYML,ISYMJ) 7138 ELSE 7139 KOFFY = KFCLI + IMATIJ(ISYMJ,ISYML) 7140 END IF 7141C 7142 KOFFT = ISAIKJ(ISYAIK,ISYML) 7143 * + 1 7144 KOFFW = ISAIKJ(ISYAIK,ISYMJ) 7145 * + 1 7146C 7147C DENOTE t3 IS CALCULATED WITH NEGATIVE SIGN 7148C 7149 IF (LW) THEN 7150 CALL DGEMM('N','N',NCKI(ISYAIK),NRHF(ISYMJ), 7151 * NRHF(ISYML),ONE,TMAT(KOFFT),NAIK, 7152 * WRK(KOFFY),NL,ONE,WMAT(KOFFW),NAIK) 7153 ELSE 7154 CALL DGEMM('N','T',NCKI(ISYAIK),NRHF(ISYMJ), 7155 * NRHF(ISYML),ONE,TMAT(KOFFT),NAIK, 7156 * WRK(KOFFY),NJ,ONE,WMAT(KOFFW),NAIK) 7157 END IF 7158C 7159 END DO 7160 7161 END IF 7162 IF ((AIBJCK_PERM.EQ.3) .OR. (AIBJCK_PERM.EQ.4)) THEN 7163C 7164C CARRY OUT MATRIX MULTIPLICATION 7165C IF (LW) THEN 7166C WBD(a,i,k,j) = WBD(a,i,k-,j) - sum (l) tmatBD(a,i,l,j)*focky(l,k) 7167C ELSE 7168C WBD(a,i,k,j) = WBD(a,i,k-,j) - sum (l) tmatBD(a,i,l,j)*focky(k,l) 7169C 7170 DO ISYMJ = 1,NSYM 7171 ISYAIL =MULD2H(ISTMAT,ISYMJ) 7172 ISYAIK = MULD2H(ISWMAT,ISYMJ) 7173 DO J = 1,NRHF(ISYMJ) 7174 DO ISYMK = 1,NSYM 7175 ISYAI = MULD2H(ISYAIK,ISYMK) 7176 ISYML = MULD2H(ISYFKY,ISYMK) 7177 NAI = MAX(1,NT1AM(ISYAI)) 7178C 7179 IF (LW) THEN 7180 NL = MAX(1,NRHF(ISYML)) 7181 ELSE 7182 NK = MAX(1,NRHF(ISYMK)) 7183 END IF 7184C 7185 IF (LW) THEN 7186 KOFFY = KFCLI + IMATIJ(ISYML,ISYMK) 7187 ELSE 7188 KOFFY = KFCLI + IMATIJ(ISYMK,ISYML) 7189 END IF 7190 KOFFT = ISAIKJ(ISYAIL,ISYMJ) 7191 * + NCKI(ISYAIL)*(J-1) 7192 * + ISAIK(ISYAI,ISYML) 7193 * + 1 7194 KOFFW = ISAIKJ(ISYAIK,ISYMJ) 7195 * + NCKI(ISYAIK)*(J-1) 7196 * + ISAIK(ISYAI,ISYMK) 7197 * + 1 7198C 7199C DENOTE t3 IS CALCULATED WITH NEGATIVE SIGN 7200C 7201 IF (LW) THEN 7202 CALL DGEMM('N','N',NT1AM(ISYAI),NRHF(ISYMK), 7203 * NRHF(ISYML),ONE,TMAT(KOFFT),NAI, 7204 * WRK(KOFFY),NL,ONE,WMAT(KOFFW),NAI) 7205 ELSE 7206 CALL DGEMM('N','T',NT1AM(ISYAI),NRHF(ISYMK), 7207 * NRHF(ISYML),ONE,TMAT(KOFFT),NAI, 7208 * WRK(KOFFY),NK,ONE,WMAT(KOFFW),NAI) 7209 END IF 7210C 7211 END DO 7212 END DO 7213 END DO 7214C 7215 END IF 7216C 7217 CALL QEXIT('WX_BDO') 7218C 7219 RETURN 7220 END 7221C /* Deck cc3_xi_den_abij_cub */ 7222 SUBROUTINE CC_XI_DEN_ABIJ_CUB(CUBIC,LISTL,LISTRZ,LISTRU, 7223 * DAB,DIJ,DAI,ISYDEN, 7224 * L2L1,ISYML1, 7225 * ISYFCKX,FOCKX, 7226 * ISYFCKY,FOCKY, 7227 * ISYMT3,ISWMAT,ISTHETA, 7228 * LUT3,FNT3,LUWBMAT,FNWBMAT, 7229 * LUTHETA,FNTHETA, 7230 * LUWZU,FNWZU, 7231 * LUWBZU,FNWBZU, 7232 * FOCKD,FREQX,FREQY, 7233 * WORK,LWORK,ISYMD,D) 7234C 7235C========================================================================= 7236C 7237C CUBIC has to be .TRUE. for CUBIC response calculations 7238C========================================================================= 7239C 7240C Dab, Dij and Dai densities for cc3 cubic response ( A{Y} matrix). 7241C 7242C 7243 IMPLICIT NONE 7244C 7245#include "priunit.h" 7246#include "ccsdsym.h" 7247#include "ccorb.h" 7248#include "cc3t3d.h" 7249C 7250 CHARACTER LISTRZ*3,LISTRU*3,LISTL*3 7251C 7252 INTEGER ISYMT3,ISWMAT,LUT3,LUWBMAT,LWORK,ISYMD,ISYDEN 7253 INTEGER ISYML,ISYMDL,ISWMATDL,ISYMT3DL,ISYMN,ISYEMF,ISYMBN,ISYMEM 7254 INTEGER ISYMB,ISYMF,ISYMFI,ISYMI,ISYEMB,ISYMFN 7255 INTEGER KT3,KWMAT,KEND1,LWRK1 7256 INTEGER KOFF1,KOFF2,KOFF3,KBN,KFN 7257 INTEGER NTOTEM,NTOTF,NNEMF 7258 INTEGER IADR 7259C 7260 INTEGER ISTHETA,ISYFCKX,ISYFCKY,LUTHETA,LUWZU,LUWBZU 7261 INTEGER ISTHETADL,ISTHETAFX,ISTHETAFY 7262 INTEGER KTHETA,KTHETAF,KWZU 7263 INTEGER KFI 7264 INTEGER IOPT 7265 INTEGER MAXX1 7266C 7267 INTEGER KWBZU 7268C 7269 INTEGER ISYMJ,ISYMFJ,KFJ 7270 INTEGER ISYMM,ISYME 7271C 7272 INTEGER ISYMDAI,ISYML1 7273C 7274 LOGICAL CUBIC 7275 LOGICAL TRANSPOSEW 7276C 7277 CHARACTER*(*) FNT3,FNWBMAT,FNTHETA,FNWZU,FNWBZU 7278C 7279#if defined (SYS_CRAY) 7280 REAL DAB(*),DIJ(*),DAI(*),WORK(LWORK),ONE,HALF 7281 REAL FOCKX(*),FOCKY(*),L2L1(*),FOCKD(*),FREQX,FREQY 7282 REAL XNORMVAL,DDOT,FREQXY 7283#else 7284 DOUBLE PRECISION DAB(*),DIJ(*),DAI(*),WORK(LWORK),ONE,HALF 7285 DOUBLE PRECISION FOCKX(*),FOCKY(*),L2L1(*),FOCKD(*),FREQX,FREQY 7286 DOUBLE PRECISION XNORMVAL,DDOT,FREQXY 7287#endif 7288C 7289 PARAMETER(ONE = 1.0D0, HALF = 0.5D0) 7290C 7291 CALL QENTER('DENABIJC') 7292C 7293 ISYMDAI = MULD2H(ISTHETA,ISYML1) 7294 !symmetry check 7295 IF (ISYMDAI .NE. ISYDEN) THEN 7296 WRITE(LUPRI,*)'ISYMDAI ', ISYMDAI 7297 WRITE(LUPRI,*)'ISYDEN ', ISYDEN 7298 WRITE(LUPRI,*)'These symmetries should be the same ' 7299 CALL QUIT('Symmetry inconsistency in CC_XI_DEN_ABIJ_CUB') 7300 END IF 7301C 7302 DO ISYML = 1,NSYM 7303C 7304 ISYMDL = MULD2H(ISYMD,ISYML) 7305 ISWMATDL = MULD2H(ISWMAT,ISYMDL) 7306 ISYMT3DL = MULD2H(ISYMT3,ISYMDL) 7307 ISTHETADL = MULD2H(ISTHETA,ISYMDL) 7308 IF (LISTRU(1:3).EQ.'R1 ') THEN 7309 ISTHETAFX = MULD2H(ISYMT3DL,ISYFCKX) 7310 ISTHETAFY = MULD2H(ISYMT3DL,ISYFCKY) 7311 END IF 7312C 7313 KT3 = 1 7314 KWMAT = KT3 + NT2SQ(ISYMT3DL) 7315 KWBZU = KWMAT + NT2SQ(ISWMATDL) 7316 KEND1 = KWBZU + NT2SQ(ISWMATDL) 7317 LWRK1 = LWORK - KEND1 7318C 7319 IF (CUBIC) THEN 7320C 7321 MAXX1 = 0 7322 IF (LISTRU(1:3).EQ.'R1 ') THEN 7323 MAXX1 = MAX(NT2SQ(ISTHETAFX),NT2SQ(ISTHETAFY)) 7324 END IF 7325C 7326 KTHETA = KEND1 7327 KTHETAF = KTHETA + NT2SQ(ISTHETADL) 7328 KEND1 = KTHETAF + MAX(MAXX1,NT2SQ(ISTHETADL)) 7329 LWRK1 = LWORK - KEND1 7330C 7331 KWZU = KEND1 7332 KEND1 = KWZU + NT2SQ(ISTHETADL) 7333 LWRK1 = LWORK - KEND1 7334 END IF 7335C 7336 IF ( LWRK1 .LT. 0 ) THEN 7337 CALL QUIT('Out of memory in CC3_XI_DEN_ABIJ (x)') 7338 ENDIF 7339C 7340 DO L = 1, NRHF(ISYML) 7341C 7342C -------------------------------------------- 7343C Read T3 amplitudes from file: 7344C -------------------------------------------- 7345C 7346 IADR = ISWTL(ISYMT3DL,ISYML) + NT2SQ(ISYMT3DL)*(L-1) + 1 7347 CALL GETWA2(LUT3,FNT3,WORK(KT3),IADR,NT2SQ(ISYMT3DL)) 7348C 7349C ------------------------------------------------ 7350C Read wMAT_bar from file 7351C ------------------------------------------------ 7352C 7353 IADR = ISWTL(ISWMATDL,ISYML) + NT2SQ(ISWMATDL)*(L-1) + 1 7354 CALL GETWA2(LUWBZU,FNWBZU,WORK(KWBZU),IADR, 7355 * NT2SQ(ISWMATDL)) 7356 7357 IF (LISTRU(1:3).EQ.'R1 ') THEN 7358C --------------------------------------------- 7359C 4ht line of Eq. 62 (second cont) 7360C --------------------------------------------- 7361 7362C 7363C KTHETAF(De- f)_(lmi) = KT3 * FOCKX 7364C 7365 ! KTHETAF is recycled here 7366 CALL DZERO(WORK(KTHETAF),NT2SQ(ISTHETAFX)) 7367 IOPT = 3 7368 CALL WXDL_V(IOPT,WORK(KT3),ISYMT3DL,FOCKX,ISYFCKX, 7369 * WORK(KTHETAF),ISTHETAFX,WORK(KEND1),LWRK1) 7370 ! Divide it by orbital energy difference and remove the 7371 ! forbidden elements 7372 CALL W3DL_DIA(WORK(KTHETAF),ISTHETAFX,ISYML,L,ISYMD,D, 7373 * FOCKD,FREQX) 7374 CALL T3_FORBIDDEN_DL(WORK(KTHETAF),ISYFCKX,ISYMD,D, 7375 * ISYML,L) 7376 7377C 7378C KTHETA(De- f-)_(lmi) = KTHETAF(De- f)_(lmi) * FOCKY 7379C 7380 ! KTHETA is recycled here 7381 CALL DZERO(WORK(KTHETA),NT2SQ(ISTHETADL)) 7382 IOPT = 1 7383 CALL WXDL_V(IOPT,WORK(KTHETAF),ISTHETAFX,FOCKY,ISYFCKY, 7384 * WORK(KTHETA),ISTHETADL,WORK(KEND1),LWRK1) 7385 7386C 7387C KTHETAF(Def- )_(lmi) = KT3 * FOCKX 7388C 7389 ! KTHETAF is recycled here 7390 CALL DZERO(WORK(KTHETAF),NT2SQ(ISTHETAFX)) 7391 IOPT = 1 7392 CALL WXDL_V(IOPT,WORK(KT3),ISYMT3DL,FOCKX,ISYFCKX, 7393 * WORK(KTHETAF),ISTHETAFX,WORK(KEND1),LWRK1) 7394 ! Divide it by orbital energy difference and remove the 7395 ! forbidden elements 7396 CALL W3DL_DIA(WORK(KTHETAF),ISTHETAFX,ISYML,L,ISYMD,D, 7397 * FOCKD,FREQX) 7398 CALL T3_FORBIDDEN_DL(WORK(KTHETAF),ISYFCKX,ISYMD,D, 7399 * ISYML,L) 7400 7401C 7402C KTHETA(De- f-)_(lmi) = KTHETAF(Def- )_(lmi) * FOCKY 7403C 7404 IOPT = 3 7405 CALL WXDL_V(IOPT,WORK(KTHETAF),ISTHETAFX,FOCKY,ISYFCKY, 7406 * WORK(KTHETA),ISTHETADL,WORK(KEND1),LWRK1) 7407 7408 7409C 7410C Include P(XY) permutation 7411C 7412C 7413C KTHETAF(De- f)_(lmi) = KT3 * FOCKY 7414C 7415 ! KTHETAF is recycled here 7416 CALL DZERO(WORK(KTHETAF),NT2SQ(ISTHETAFY)) 7417 IOPT = 3 7418 CALL WXDL_V(IOPT,WORK(KT3),ISYMT3DL,FOCKY,ISYFCKY, 7419 * WORK(KTHETAF),ISTHETAFY,WORK(KEND1),LWRK1) 7420 ! Divide it by orbital energy difference and remove the 7421 ! forbidden elements 7422 CALL W3DL_DIA(WORK(KTHETAF),ISTHETAFY,ISYML,L,ISYMD,D, 7423 * FOCKD,FREQY) 7424 CALL T3_FORBIDDEN_DL(WORK(KTHETAF),ISYFCKY,ISYMD,D, 7425 * ISYML,L) 7426 7427C 7428C KTHETA(De- f-)_(lmi) = KTHETAF(De- f)_(lmi) * FOCKX 7429C 7430 IOPT = 1 7431 CALL WXDL_V(IOPT,WORK(KTHETAF),ISTHETAFY,FOCKX,ISYFCKX, 7432 * WORK(KTHETA),ISTHETADL,WORK(KEND1),LWRK1) 7433 7434C 7435C KTHETAF(Def- )_(lmi) = KT3 * FOCKY 7436C 7437 ! KTHETAF is recycled here 7438 CALL DZERO(WORK(KTHETAF),NT2SQ(ISTHETAFY)) 7439 IOPT = 1 7440 CALL WXDL_V(IOPT,WORK(KT3),ISYMT3DL,FOCKY,ISYFCKY, 7441 * WORK(KTHETAF),ISTHETAFY,WORK(KEND1),LWRK1) 7442 ! Divide it by orbital energy difference and remove the 7443 ! forbidden elements 7444 CALL W3DL_DIA(WORK(KTHETAF),ISTHETAFY,ISYML,L,ISYMD,D, 7445 * FOCKD,FREQY) 7446 CALL T3_FORBIDDEN_DL(WORK(KTHETAF),ISYFCKY,ISYMD,D, 7447 * ISYML,L) 7448 7449C 7450C KTHETA(De- f-)_(lmi) = KTHETAF(Def- )_(lmi) * FOCKX 7451C 7452 IOPT = 3 7453 CALL WXDL_V(IOPT,WORK(KTHETAF),ISTHETAFY,FOCKX,ISYFCKX, 7454 * WORK(KTHETA),ISTHETADL,WORK(KEND1),LWRK1) 7455 7456 ! Divide it by orbital energy difference and remove the 7457 ! forbidden elements 7458C 7459 FREQXY = FREQX + FREQY 7460C 7461 CALL W3DL_DIA(WORK(KTHETA),ISTHETADL,ISYML,L,ISYMD,D, 7462 * FOCKD,FREQXY) 7463 CALL T3_FORBIDDEN_DL(WORK(KTHETA),ISTHETA,ISYMD,D, 7464 * ISYML,L) 7465 7466 !4th line in Eq. (62) (Dij) (second cont) 7467 7468 TRANSPOSEW = .TRUE. 7469 CALL DIJ_CONT_CUB(TRANSPOSEW,DIJ,ONE,WORK(KWBZU), 7470 * ISWMATDL, 7471 * WORK(KTHETA),ISTHETADL,WORK(KEND1),LWRK1) 7472 7473 END IF ! LISTRU .EQ. R1 7474C 7475C 7476C --------------------------------------------- 7477C 3rd line of Eq. (62) 7478C --------------------------------------------- 7479 7480C ------------------------------------------------ 7481C Read WMAT_bar from file 7482C ------------------------------------------------ 7483C 7484 IADR = ISWTL(ISWMATDL,ISYML) + NT2SQ(ISWMATDL)*(L-1) + 1 7485 CALL GETWA2(LUWBMAT,FNWBMAT,WORK(KWMAT),IADR, 7486 * NT2SQ(ISWMATDL)) 7487C 7488 IF (LISTRU(1:3).EQ.'R1 ') THEN 7489C 7490C KTHETAF(Def- )_(lmi) = KT3 * FOCKX 7491C 7492 ! KTHETAF is recycled here 7493 CALL DZERO(WORK(KTHETAF),NT2SQ(ISTHETAFX)) 7494 IOPT = 1 7495 CALL WXDL_V(IOPT,WORK(KT3),ISYMT3DL,FOCKX,ISYFCKX, 7496 * WORK(KTHETAF),ISTHETAFX,WORK(KEND1),LWRK1) 7497 ! Divide it by orbital energy difference and remove the 7498 ! forbidden elements 7499 CALL W3DL_DIA(WORK(KTHETAF),ISTHETAFX,ISYML,L,ISYMD,D, 7500 * FOCKD,FREQX) 7501 CALL T3_FORBIDDEN_DL(WORK(KTHETAF),ISYFCKX,ISYMD,D, 7502 * ISYML,L) 7503 7504C 7505C KWZU(Def-- )_(lmi) = KTHETAF(Def- )_(lmi) * FOCKY 7506C 7507 ! KTHETA is recycled here 7508 CALL DZERO(WORK(KWZU),NT2SQ(ISTHETADL)) 7509 IOPT = 1 7510 CALL WXDL_V(IOPT,WORK(KTHETAF),ISTHETAFX,FOCKY,ISYFCKY, 7511 * WORK(KWZU),ISTHETADL,WORK(KEND1),LWRK1) 7512 7513C 7514C Include P(XY) permutation 7515C 7516 7517C 7518C KTHETAF(Def- )_(lmi) = KT3 * FOCKY 7519C 7520 ! KTHETAF is recycled here 7521 CALL DZERO(WORK(KTHETAF),NT2SQ(ISTHETAFY)) 7522 IOPT = 1 7523 CALL WXDL_V(IOPT,WORK(KT3),ISYMT3DL,FOCKY,ISYFCKY, 7524 * WORK(KTHETAF),ISTHETAFY,WORK(KEND1),LWRK1) 7525 ! Divide it by orbital energy difference and remove the 7526 ! forbidden elements 7527 CALL W3DL_DIA(WORK(KTHETAF),ISTHETAFY,ISYML,L,ISYMD,D, 7528 * FOCKD,FREQY) 7529 CALL T3_FORBIDDEN_DL(WORK(KTHETAF),ISYFCKY,ISYMD,D, 7530 * ISYML,L) 7531 7532C 7533C KWZU(Def-- )_(lmi) = KTHETAF(Def- )_(lmi) * FOCKX 7534C 7535 IOPT = 1 7536 CALL WXDL_V(IOPT,WORK(KTHETAF),ISTHETAFY,FOCKX,ISYFCKX, 7537 * WORK(KWZU),ISTHETADL,WORK(KEND1),LWRK1) 7538 7539 7540 ! Divide it by orbital energy difference and remove the 7541 ! forbidden elements 7542C 7543 FREQXY = FREQX + FREQY 7544C 7545 CALL W3DL_DIA(WORK(KWZU),ISTHETADL,ISYML,L,ISYMD,D, 7546 * FOCKD,FREQXY) 7547 CALL T3_FORBIDDEN_DL(WORK(KWZU),ISTHETA,ISYMD,D, 7548 * ISYML,L) 7549 7550 ! add KWZU(Def-- )_(lmi) + KTHETA(De- f-)_(lmi) 7551 CALL DAXPY(NT2SQ(ISTHETADL),ONE,WORK(KWZU),1, 7552 * WORK(KTHETA),1) 7553C 7554C contract... (3rd line of Eq. (62)) 7555C 7556 7557 TRANSPOSEW = .FALSE. 7558 CALL DIJ_CONT_CUB(TRANSPOSEW,DIJ,ONE,WORK(KWMAT), 7559 * ISWMATDL, 7560 * WORK(KTHETA),ISTHETADL,WORK(KEND1),LWRK1) 7561C 7562 END IF ! LISTRU .EQ. R1 7563 7564C 7565C ---------------------------------------------------- 7566C Read THETA(Deb)_(l-- m-- n--) amplitudes from file 7567C and symmetrize them: 7568C ---------------------------------------------------- 7569C 7570 IADR = ISWTL(ISTHETADL,ISYML) + NT2SQ(ISTHETADL)*(L-1) 7571 * + 1 7572 CALL GETWA2(LUTHETA,FNTHETA,WORK(KTHETA),IADR, 7573 * NT2SQ(ISTHETADL)) 7574C 7575 CALL CC_T2MOD(WORK(KTHETA),ISTHETADL,ONE) 7576 7577C ---------------------------------------------------- 7578C Read wZU^{Deb-}_{l- m- n-} from file... 7579C ---------------------------------------------------- 7580C 7581 IADR = ISWTL(ISTHETADL,ISYML) + NT2SQ(ISTHETADL)*(L-1) 7582 * + 1 7583 CALL GETWA2(LUWZU,FNWZU,WORK(KWZU),IADR, 7584 * NT2SQ(ISTHETADL)) 7585 !second contribution to Dab (second line in Eq. (61)) 7586 7587 CALL DAXPY(NT2SQ(ISWMATDL),HALF,WORK(KWMAT),1, 7588 * WORK(KWBZU),1) 7589 TRANSPOSEW = .TRUE. 7590 CALL DAB_CONT_CUB(TRANSPOSEW,DAB,WORK(KWBZU),ISWMATDL, 7591 * WORK(KWZU),ISTHETADL,WORK(KEND1),LWRK1) 7592 7593 !4th line in Eq. (62) (Dij) (first cont) 7594 TRANSPOSEW = .TRUE. 7595 CALL DIJ_CONT_CUB(TRANSPOSEW,DIJ,HALF,WORK(KWMAT),ISWMATDL, 7596 * WORK(KWZU),ISTHETADL,WORK(KEND1),LWRK1) 7597 7598 7599C 7600C --------------------------------------------------------- 7601C DAI(ai) = DAI(ai) + L2L1{emld}*(w{Aed-}_{i-m-l-} - (w{Aed-}_{m-i-l-} 7602C --------------------------------------------------------- 7603C 7604 CALL ADEN_DAI_T2_D_CUB(DAI,ISYMDAI,L2L1,ISYML1, 7605 * WORK(KWZU),ISTHETADL,ISYMD,D, 7606 * ISYML,L,WORK(KEND1),LWRK1) 7607C 7608C ----------------------------------------------------------- 7609C ...and create wZU^{Deb-}_{l- m- n-} + wZU^{Dbe-}_{l- n- m-} 7610C ----------------------------------------------------------- 7611 7612 CALL CC_T2MOD(WORK(KWZU),ISTHETADL,ONE) 7613 7614C --------------------------------------------------------- 7615C Get THETA + wZU^{Deb-}_{l- m- n-} + wZU^{Dbe-}_{l- n- m-} 7616C --------------------------------------------------------- 7617 7618 CALL DAXPY(NT2SQ(ISTHETADL),ONE,WORK(KWZU),1, 7619 * WORK(KTHETA),1) 7620 7621C 7622C----------------------------------------------------------------------- 7623C DAI(ai) = DAI(ai) + L2L1{emLD}*(THETA{Dea}_{Lmi} - THETA{Dea}_{Lim}) 7624C----------------------------------------------------------------------- 7625C 7626C 7627 CALL ADEN_DAI_T2_D(DAI,ISYMDAI,L2L1,ISYML1, 7628 * WORK(KTHETA),ISTHETADL,ISYMD,D, 7629 * ISYML,L,WORK(KEND1),LWRK1) 7630C 7631 7632 !generate WMAT-tilde: 7633 CALL CC_T2MOD(WORK(KWMAT),ISWMATDL,HALF) 7634C 7635C ------------------------------------------------------- 7636C D(fb) <- D(fb)+ sum_em Wtilde_bar^DL(em,fN) T3^DL(em,bN): 7637 ! FOR CUBIC = .TRUE. T3^DL(em,bN) becomes THETA_Z^DL(em,bN) 7638C ------------------------------------------------------- 7639 7640 TRANSPOSEW = .FALSE. 7641 CALL DAB_CONT_CUB(TRANSPOSEW,DAB,WORK(KWMAT),ISWMATDL, 7642 * WORK(KTHETA),ISTHETADL,WORK(KEND1),LWRK1) 7643C 7644C 7645c ------------------------------------------------------- 7646c D(iN) <- D(iN)- sum_emf Wtilde_bar^DL(em,fN) t^DL(em,fi): 7647c ! FOR CUBIC = .TRUE. t^DL(em,fi) becomes THETA_Z^DL(em,fi) 7648c ------------------------------------------------------- 7649 7650 TRANSPOSEW = .FALSE. 7651 CALL DIJ_CONT_CUB(TRANSPOSEW,DIJ,ONE,WORK(KWMAT),ISWMATDL, 7652 * WORK(KTHETA),ISTHETADL,WORK(KEND1),LWRK1) 7653C 7654 ! Calculate the extra contribution to D(ij) density: 7655 ! D(ij) = D(ij) + W^Df(emlj) * [theta^(Def-)_(iml) + theta^(De-f)_(iml)] 7656C 7657C ---------------------------- 7658C Read T3^DL(em,fi) amplitudes 7659C ---------------------------- 7660C 7661 ! KT3 is recycled here 7662 CALL READ_T3_AIBL(LUT3,FNT3,ISYMT3,WORK(KT3), 7663 * ISYMT3DL,L,ISYML,ISYMD) 7664C 7665C ---------------------------------------------- 7666C Contract T3^DL(em,fi) with X operator 7667C to get THDL(em,fi) = [ THETA^DL(em,f-i) + THETA^DL(e-m,fi) ] 7668C ---------------------------------------------- 7669C 7670cNow it becomes the second line of Eq (62) (part of it). 7671c 7672 7673 IF (LISTRU(1:3).EQ.'R1 ') THEN 7674C 7675C (1) KTHETAF(X) = KT3 * FOCKX 7676C 7677 ! KTHETAF is recycled here 7678 CALL DZERO(WORK(KTHETAF),NT2SQ(ISTHETAFX)) 7679 IOPT = 2 7680 CALL WXDL_V(IOPT,WORK(KT3),ISYMT3DL,FOCKX,ISYFCKX, 7681 * WORK(KTHETAF),ISTHETAFX,WORK(KEND1),LWRK1) 7682 ! Divide it by orbital energy difference and remove the 7683 ! forbidden elements 7684 CALL W3DL_DIA(WORK(KTHETAF),ISTHETAFX,ISYML,L,ISYMD,D, 7685 * FOCKD,FREQX) 7686 CALL T3_FORBIDDEN_DL(WORK(KTHETAF),ISYFCKX,ISYMD,D, 7687 * ISYML,L) 7688C 7689C (2) KTHETA = KTHETAF(X) * FOCKY 7690C 7691 !KTHETA is reused here 7692 CALL DZERO(WORK(KTHETA),NT2SQ(ISTHETADL)) 7693C 7694 IOPT = 2 7695 CALL WXDL_V(IOPT,WORK(KTHETAF),ISTHETAFX,FOCKY,ISYFCKY, 7696 * WORK(KTHETA),ISTHETADL,WORK(KEND1),LWRK1) 7697 7698C 7699C Apply P(XY) permutation 7700C 7701 7702C 7703C (3) KTHETAF(Y) = KT3 * FOCKY 7704C 7705 ! KTHETAF is recycled here 7706 CALL DZERO(WORK(KTHETAF),NT2SQ(ISTHETAFY)) 7707 IOPT = 2 7708 CALL WXDL_V(IOPT,WORK(KT3),ISYMT3DL,FOCKY,ISYFCKY, 7709 * WORK(KTHETAF),ISTHETAFY,WORK(KEND1),LWRK1) 7710 ! Divide it by orbital energy difference and remove the 7711 ! forbidden elements 7712 CALL W3DL_DIA(WORK(KTHETAF),ISTHETAFY,ISYML,L,ISYMD,D, 7713 * FOCKD,FREQY) 7714 CALL T3_FORBIDDEN_DL(WORK(KTHETAF),ISYFCKY,ISYMD,D, 7715 * ISYML,L) 7716C 7717C (4) KTHETA = KTHETAF(Y) * FOCKX 7718C 7719 IOPT = 2 7720 CALL WXDL_V(IOPT,WORK(KTHETAF),ISTHETAFY,FOCKX,ISYFCKX, 7721 * WORK(KTHETA),ISTHETADL,WORK(KEND1),LWRK1) 7722 7723 7724 ! Divide it by orbital energy difference and remove the 7725 ! forbidden elements 7726C 7727 FREQXY = FREQX + FREQY 7728C 7729 CALL W3DL_DIA(WORK(KTHETA),ISTHETADL,ISYML,L,ISYMD,D, 7730 * FOCKD,FREQXY) 7731 CALL T3_FORBIDDEN_DL(WORK(KTHETA),ISTHETA,ISYMD,D, 7732 * ISYML,L) 7733C 7734 ELSE IF (LISTRU(1:3).EQ.'RE ') THEN 7735 CALL DZERO(WORK(KTHETA),NT2SQ(ISTHETADL)) 7736 END IF 7737C 7738c Now we construct wXY(Def-)_(i- m- l-) 7739 7740 CALL DZERO(WORK(KWZU),NT2SQ(ISTHETADL)) 7741 CALL DZERO(WORK(KTHETAF),NT2SQ(ISTHETADL)) 7742C 7743 CALL READ_T3_ALBJ(LUWZU,FNWZU,ISTHETA,WORK(KWZU), 7744 * ISTHETADL,L,ISYML,ISYMD) 7745c 7746 !transpose and accumalte 7747 CALL TRANS_AIBJ_BJAI(WORK(KWZU),WORK(KTHETAF),ISTHETADL) 7748 CALL DAXPY(NT2SQ(ISTHETADL),ONE,WORK(KTHETAF),1, 7749 * WORK(KTHETA),1) 7750C 7751C ------------------------------------------------ 7752C Read WBMAT^DL(em,fj) from the file 7753C ------------------------------------------------ 7754C 7755 ! KWBMAT is recycled here 7756 CALL READ_T3_AIBL(LUWBMAT,FNWBMAT,ISWMAT,WORK(KWMAT), 7757 * ISWMATDL,L,ISYML,ISYMD) 7758 7759C 7760C------------------------------------------------ 7761C Contract D(ij) <- WBMAT^DL(em,fj) * THDL(em,fi) 7762C------------------------------------------------ 7763C 7764 DO ISYMJ = 1,NSYM 7765 ISYEMF = MULD2H(ISWMATDL,ISYMJ) 7766 DO J = 1,NRHF(ISYMJ) 7767 DO ISYMEM = 1, NSYM 7768 ISYMFI = MULD2H(ISTHETADL,ISYMEM) 7769 ISYMF = MULD2H(ISYEMF,ISYMEM) 7770 ISYMI = MULD2H(ISYMFI,ISYMF) 7771 ISYMFJ = MULD2H(ISYMF,ISYMJ) 7772 7773C 7774 KOFF1 = KTHETA+ IT2SQ(ISYMEM,ISYMFI) 7775 * + NT1AM(ISYMEM)*IT1AM(ISYMF,ISYMI) 7776 7777 KFJ = IT1AM(ISYMF,ISYMJ)+NVIR(ISYMF)*(J-1)+1 7778 KOFF2 = KWMAT + IT2SQ(ISYMEM,ISYMFJ) 7779 * + NT1AM(ISYMEM)*(KFJ-1) 7780 7781 KOFF3 = IMATIJ(ISYMI,ISYMJ) 7782 * + NRHF(ISYMI)*(J-1) + 1 7783 7784 NNEMF = MAX(NT1AM(ISYMEM)*NVIR(ISYMF),1) 7785C 7786 CALL DGEMV('T',NT1AM(ISYMEM)*NVIR(ISYMF), 7787 * NRHF(ISYMI),-ONE,WORK(KOFF1),NNEMF, 7788 * WORK(KOFF2),1,ONE,DIJ(KOFF3),1) 7789C 7790 7791 END DO ! ISYMEM 7792 7793 END DO ! J 7794 END DO ! ISYMJ 7795C 7796C 7797C 7798 END DO ! L 7799 END DO ! ISYML 7800C 7801 CALL QEXIT('DENABIJC') 7802C 7803 RETURN 7804 END 7805C /* Deck dij_cont_cub */ 7806 SUBROUTINE DIJ_CONT_CUB(TRANSPOSEW,DIJ,FACTOR,WBARDL,ISWMATDL, 7807 * THETADL,ISTHETADL,WORK,LWORK) 7808* 7809********************************************************************** 7810* 7811* Calculate the contribution to the DIJ density (cubic response) of 7812* following type: 7813* 7814* FACTOR*Wbar^{Df}(emjl) * theta^{Def}_{lmi}. 7815* 7816* The multiplication is carried out for fixed DL: 7817* 7818* 7819* IF (.NOT. TRANSPOSEW) THEN 7820* 7821* D(ij) = D(ij) + FACTOR*WBARDL(em,fj) * THETADL(em,fi) 7822* 7823* ELSE 7824* 7825* D(ij) = D(ij) + FACTOR*WBARDL(fj,em) * THETADL(em,fi) 7826* 7827* END IF 7828* 7829* Filip Pawlowski, 11-Sep-2003, Aarhus. 7830********************************************************************** 7831* 7832 IMPLICIT NONE 7833C 7834#include "priunit.h" 7835#include "ccsdsym.h" 7836#include "ccorb.h" 7837C 7838 LOGICAL TRANSPOSEW 7839C 7840 INTEGER ISWMATDL,ISTHETADL,LWORK 7841 INTEGER KWBARTR,KEND1,LWRK1,ISYMJ,ISYEMF,ISYMEM,ISYMFI,ISYMF 7842 INTEGER ISYMI,ISYMFJ,KOFF1,KFJ,KOFF2,KOFF3,NNEMF 7843C 7844#if defined (SYS_CRAY) 7845 REAL DIJ(*),WBARDL(*),THETADL(*) 7846 REAL WORK(LWORK) 7847 REAL ONE, FACTOR 7848#else 7849 DOUBLE PRECISION DIJ(*),WBARDL(*),THETADL(*) 7850 DOUBLE PRECISION WORK(LWORK) 7851 DOUBLE PRECISION ONE, FACTOR 7852#endif 7853C 7854 PARAMETER (ONE = 1.0D0) 7855C 7856 CALL QENTER('DIJCUB') 7857C 7858 7859 IF (TRANSPOSEW) THEN 7860 !transpose Wbar^DL(em,fj) to Wbar^DL(fj,em)) 7861 KWBARTR = 1 7862 KEND1 = KWBARTR + NT2SQ(ISWMATDL) 7863 LWRK1 = LWORK - KEND1 7864C 7865 IF (LWRK1 .LT. 0) THEN 7866 WRITE(LUPRI,*)'Memory available: ', LWORK 7867 WRITE(LUPRI,*)'Memory needed : ', KEND1 7868 CALL QUIT('Insufficient memory in DIJ_CONT_CUB ') 7869 END IF 7870C 7871 CALL TRANS_AIBJ_BJAI(WBARDL,WORK(KWBARTR),ISWMATDL) 7872C 7873 END IF 7874 7875C--------------------------------------------------------------- 7876C Calculate D(ij) = D(ij) - Wtilde_bar^DL(em,fj) t^DL(em,fi) 7877C--------------------------------------------------------------- 7878C 7879C ----------------------------------- 7880C Loop over outermost occupied index: 7881C ----------------------------------- 7882C 7883 DO ISYMJ = 1, NSYM 7884 ISYEMF = MULD2H(ISWMATDL,ISYMJ) 7885C 7886 DO J = 1, NRHF(ISYMJ) 7887 7888C ----------------------------------------------------- 7889C D(ij) <- D(ij)- sum_emf Wbar^DL(em,fj) THETA^DL(em,fi) 7890C ----------------------------------------------------- 7891 DO ISYMEM = 1, NSYM 7892 ISYMFI = MULD2H(ISTHETADL,ISYMEM) 7893 ISYMF = MULD2H(ISYEMF,ISYMEM) 7894 ISYMI = MULD2H(ISYMFI,ISYMF) 7895 ISYMFJ = MULD2H(ISYMF,ISYMJ) 7896 7897C 7898 KOFF1 = 1 + IT2SQ(ISYMEM,ISYMFI) 7899 * + NT1AM(ISYMEM)*IT1AM(ISYMF,ISYMI) 7900C 7901 KFJ = IT1AM(ISYMF,ISYMJ)+NVIR(ISYMF)*(J-1)+1 7902C 7903 IF (.NOT.TRANSPOSEW) THEN 7904 KOFF2 = 1 + IT2SQ(ISYMEM,ISYMFJ) 7905 * + NT1AM(ISYMEM)*(KFJ-1) 7906 ELSE 7907 KOFF2 = KWBARTR + IT2SQ(ISYMEM,ISYMFJ) 7908 * + NT1AM(ISYMEM)*(KFJ-1) 7909 END IF 7910C 7911 KOFF3 = IMATIJ(ISYMI,ISYMJ) 7912 * + NRHF(ISYMI)*(J-1) + 1 7913 7914 NNEMF = MAX(NT1AM(ISYMEM)*NVIR(ISYMF),1) 7915C 7916 IF (.NOT.TRANSPOSEW) THEN 7917 CALL DGEMV('T',NT1AM(ISYMEM)*NVIR(ISYMF), 7918 * NRHF(ISYMI),-FACTOR,THETADL(KOFF1),NNEMF, 7919 * WBARDL(KOFF2),1,ONE,DIJ(KOFF3),1) 7920 ELSE 7921 CALL DGEMV('T',NT1AM(ISYMEM)*NVIR(ISYMF), 7922 * NRHF(ISYMI),-FACTOR,THETADL(KOFF1),NNEMF, 7923 * WORK(KOFF2),1,ONE,DIJ(KOFF3),1) 7924 END IF 7925C 7926 END DO ! ISYMFI 7927 7928 END DO ! J 7929 END DO ! ISYMJ 7930C 7931 CALL QEXIT('DIJCUB') 7932C 7933 RETURN 7934 END 7935C /* Deck dab_cont_cub */ 7936 SUBROUTINE DAB_CONT_CUB(TRANSPOSEW,DAB,WBARDL,ISWMATDL,THETADL, 7937 * ISTHETADL,WORK,LWORK) 7938* 7939********************************************************************** 7940* 7941* Calculate the contribution to the DAB density (cubic response) of 7942* following type: 7943* 7944* Wbar^{Da}(emnl) * theta^{Deb}_{lmn}. 7945* 7946* The multiplication is carried out for fixed DL: 7947* 7948* 7949* IF (.NOT. TRANSPOSEW) THEN 7950* 7951* D(ab) = D(ab) + WBARDL(em,aN) * THETADL(em,bN) 7952* 7953* ELSE 7954* 7955* D(ab) = D(ab) + WBARDL(aN,em) * THETADL(em,bN) 7956* 7957* END IF 7958* 7959* Filip Pawlowski, 05-Sep-2003, Aarhus. 7960********************************************************************** 7961* 7962 IMPLICIT NONE 7963C 7964#include "priunit.h" 7965#include "ccsdsym.h" 7966#include "ccorb.h" 7967C 7968 LOGICAL TRANSPOSEW 7969C 7970 INTEGER ISWMATDL,ISTHETADL 7971 INTEGER LWORK 7972 INTEGER ISYMN,ISYEMA,ISYEMB,ISYMEM,ISYMB,ISYMA,ISYMAN,ISYMBN 7973 INTEGER KAN,KOFF1,KBN,KOFF2,KOFF3,NTOTEM,NTOTA 7974 INTEGER ISYMM,ISYANE,ISYBNE,ISYME,KEM,NTOTB 7975 INTEGER NTOTAN 7976 INTEGER KWBARTR,KEND1,LWRK1 7977C 7978#if defined (SYS_CRAY) 7979 REAL DAB(*),WBARDL(*),THETADL(*) 7980 REAL WORK(LWORK) 7981 REAL ONE 7982#else 7983 DOUBLE PRECISION DAB(*),WBARDL(*),THETADL(*) 7984 DOUBLE PRECISION WORK(LWORK) 7985 DOUBLE PRECISION ONE 7986#endif 7987C 7988 PARAMETER (ONE = 1.0D0) 7989C 7990 CALL QENTER('DABCUB') 7991C 7992 7993 IF (TRANSPOSEW) THEN 7994 !transpose Wbar^DL(em,an) to Wbar^DL(an,em) 7995 KWBARTR = 1 7996 KEND1 = KWBARTR + NT2SQ(ISWMATDL) 7997 LWRK1 = LWORK - KEND1 7998C 7999 IF (LWRK1 .LT. 0) THEN 8000 WRITE(LUPRI,*)'Memory available: ', LWORK 8001 WRITE(LUPRI,*)'Memory needed : ', KEND1 8002 CALL QUIT('Insufficient memory in DAB_CONT_CUB ') 8003 END IF 8004C 8005 CALL TRANS_AIBJ_BJAI(WBARDL,WORK(KWBARTR),ISWMATDL) 8006C 8007 END IF 8008 8009C-------------------------------------------------------------- 8010C Calculate D(ab) = D(ab) + WBARDL(em,aN) * THETADL(em,bN) 8011C-------------------------------------------------------------- 8012C 8013C ----------------------------------- 8014C Loop over outermost occupied index: 8015C ----------------------------------- 8016C 8017 DO ISYMN = 1, NSYM 8018 ISYEMA = MULD2H(ISWMATDL,ISYMN) 8019 ISYEMB = MULD2H(ISTHETADL,ISYMN) 8020C 8021 DO N = 1, NRHF(ISYMN) 8022C 8023C ------------------------------------------------------- 8024C D(ab) <- D(ab)+ sum_em Wbar^DL(em,aN) THETA^DL(em,bN): 8025C ------------------------------------------------------- 8026 DO ISYMEM = 1, NSYM 8027 ISYMB = MULD2H(ISYEMB,ISYMEM) 8028 ISYMA = MULD2H(ISYEMA,ISYMEM) 8029 ISYMAN = MULD2H(ISYMA,ISYMN) 8030 ISYMBN = MULD2H(ISYMB,ISYMN) 8031 8032 KAN = IT1AM(ISYMA,ISYMN)+NVIR(ISYMA)*(N-1)+1 8033C 8034 IF (.NOT.TRANSPOSEW) THEN 8035 KOFF1 = 1 + IT2SQ(ISYMEM,ISYMAN) 8036 * + NT1AM(ISYMEM)*(KAN-1) 8037 ELSE 8038 KOFF1 = KWBARTR + IT2SQ(ISYMEM,ISYMAN) 8039 * + NT1AM(ISYMEM)*(KAN-1) 8040 END IF 8041C 8042 KBN = IT1AM(ISYMB,ISYMN)+NVIR(ISYMB)*(N-1)+1 8043 KOFF2 = 1 + IT2SQ(ISYMEM,ISYMBN) 8044 * + NT1AM(ISYMEM)*(KBN-1) 8045C 8046 KOFF3 = IMATAB(ISYMA,ISYMB) + 1 8047C 8048 NTOTEM = MAX(NT1AM(ISYMEM),1) 8049 NTOTA = MAX(NVIR(ISYMA),1) 8050 8051 IF (.NOT.TRANSPOSEW) THEN 8052 CALL DGEMM('T','N',NVIR(ISYMA),NVIR(ISYMB), 8053 * NT1AM(ISYMEM),ONE,WBARDL(KOFF1),NTOTEM, 8054 * THETADL(KOFF2),NTOTEM,ONE,DAB(KOFF3), 8055 * NTOTA) 8056 ELSE 8057 CALL DGEMM('T','N',NVIR(ISYMA),NVIR(ISYMB), 8058 * NT1AM(ISYMEM),ONE,WORK(KOFF1),NTOTEM, 8059 * THETADL(KOFF2),NTOTEM,ONE,DAB(KOFF3), 8060 * NTOTA) 8061 END IF 8062 8063 8064 END DO ! ISYMEM 8065C 8066 END DO ! N 8067 END DO ! ISYMN 8068C 8069 CALL QEXIT('DABCUB') 8070C 8071 RETURN 8072 END 8073C /* Deck read_t3_albj */ 8074 SUBROUTINE READ_T3_ALBJ(LUFILE,FNFILE,ISYMT3,T2SQ,ISYMT2, 8075 * I,ISYMI,ISYMD) 8076 8077 IMPLICIT NONE 8078C 8079#include "priunit.h" 8080#include "ccsdsym.h" 8081#include "cc3t3d.h" 8082#include "ccorb.h" 8083C 8084 CHARACTER*(*) FNFILE 8085C 8086 INTEGER LUFILE,ISYMT3,ISYMT2,ISYMI,ISYMD 8087C 8088 INTEGER ISYMAIBJL,ISYMBJ,ISYMAIL,ISYMAL,ISYML,ISYMAI,ISYMAIBJ 8089 INTEGER ISYMJ,ISYMB,NBJ 8090 INTEGER KOFFT2,IADR 8091 INTEGER ISYMA 8092C 8093#if defined (SYS_CRAY) 8094 REAL T2SQ(*) 8095#else 8096 DOUBLE PRECISION T2SQ(*) 8097#endif 8098C 8099 CALL QENTER('RDALBJ') 8100C 8101 ISYMAIBJL = MULD2H(ISYMT3,ISYMD) 8102 DO ISYMBJ = 1,NSYM 8103 ISYMAIL = MULD2H(ISYMAIBJL,ISYMBJ) 8104 ISYMAL = MULD2H(ISYMAIL,ISYMI) 8105 DO ISYML = 1,NSYM 8106 ISYMAI = MULD2H(ISYMAIL,ISYML) 8107 ISYMA = MULD2H(ISYMAI,ISYMI) 8108 ISYMAIBJ = MULD2H(ISYMAI,ISYMBJ) 8109 DO ISYMJ = 1,NSYM 8110 ISYMB = MULD2H(ISYMBJ,ISYMJ) 8111 DO L = 1,NRHF(ISYML) 8112 DO J = 1,NRHF(ISYMJ) 8113 DO B = 1,NVIR(ISYMB) 8114 8115C 8116 NBJ = IT1AM(ISYMB,ISYMJ)+NVIR(ISYMB)*(J-1)+B 8117C 8118 KOFFT2 = IT2SQ(ISYMAL,ISYMBJ) 8119 * + NT1AM(ISYMAL)*(NBJ-1) 8120 * + IT1AM(ISYMA,ISYML) 8121 * + NVIR(ISYMA)*(L-1) 8122 * + 1 8123C 8124 IADR = ISWTL(ISYMAIBJ,ISYML) 8125 * + NT2SQ(ISYMAIBJ)*(L-1) 8126 * + IT2SQ(ISYMAI,ISYMBJ) 8127 * + NT1AM(ISYMAI)*(NBJ-1) 8128 * + IT1AM(ISYMA,ISYMI) 8129 * + NVIR(ISYMA)*(I-1) 8130 * + 1 8131 8132 CALL GETWA2(LUFILE,FNFILE,T2SQ(KOFFT2), 8133 * IADR,NVIR(ISYMA)) 8134C 8135 END DO 8136 END DO 8137 END DO 8138 END DO 8139 END DO 8140 END DO 8141C 8142C 8143 CALL QEXIT('RDALBJ') 8144C 8145 RETURN 8146 END 8147C /* aden_dai_t2_d_cub */ 8148 SUBROUTINE ADEN_DAI_T2_D_CUB(DAI,ISYMDAI,T2TP,ISYMT2, 8149 * TETA,ISYMTETA,ISYMD,D, 8150 * ISYML,L,WORK,LWORK) 8151* 8152************************************************************************ 8153* 8154* Calculate contribution to the virtual part of Dai density for cubic 8155* response: 8156* 8157* DAI(ai) = DAI(ai) + T2^{de}_{lm} * (w^{Aed-}_{iml} - w^{Aed-}_{mil}). 8158* 8159* w^{Aed-}_{iml} is actually sitting as TETA^AI(em,dl) and, therfore, 8160* the two terms are calculated separetly. 8161* 8162* 8163* 8164* 1) DAI(ai) = DAI(ai) + T2^{de}_{lm} * w^{Aed-}_{iml} is calculated as: 8165* 8166* DAI(AI) = DAI(AI) + KT2AM(em,dl) * TETA^AI(em,dl), which requires 8167* sorting of T2 amplitudes first. 8168* 8169* 2) DAI(ai) = DAI(ai) - T2^{de}_{lm} * w^{Aed-}_{mil} is calculated as: 8170* 8171* DAI(Ai) = DAI(Ai) - TETA^AM(dl,ei) * KT2AM(dl,eM) 8172* 8173************************************************************************ 8174* Written by F. Pawlowski, Fall 2003, Aarhus. 8175************************************************************************ 8176* 8177 IMPLICIT NONE 8178C 8179#include "priunit.h" 8180#include "ccorb.h" 8181#include "ccsdinp.h" 8182#include "ccsdsym.h" 8183C 8184 INTEGER ISYMDAI,ISYMT2,ISYMTETA,ISYMD,ISYML,LWORK 8185 INTEGER KT2AM,KEND1,LWRK1 8186 INTEGER ISYMA,ISYMI,ISYMDL,ISYMEM,KOFF1,KOFF2 8187 INTEGER ISYMM,ISYMEI,ISYME,KEM,KOFF3,NDLE 8188 INTEGER KT2AMTR,KTETATTR 8189 INTEGER ISYMAI 8190C 8191#if defined (SYS_CRAY) 8192 REAL DAI(*),T2TP(*),TETA(*),WORK(LWORK) 8193 REAL DDOT,ONE 8194#else 8195 DOUBLE PRECISION DAI(*),T2TP(*),TETA(*),WORK(LWORK) 8196 DOUBLE PRECISION DDOT,ONE 8197#endif 8198C 8199 PARAMETER (ONE = 1.0D0) 8200C 8201 CALL QENTER('DAIT2C') 8202C 8203C---------------------------------------------------------- 8204C 1) DAI(ai) = DAI(ai) + T2^{de}_{lm} * w^{Aed-}_{iml} 8205C---------------------------------------------------------- 8206C 8207 KT2AM = 1 8208 KEND1 = KT2AM + NT2SQ(ISYMT2) 8209 LWRK1 = LWORK - KEND1 8210C 8211 IF (LWRK1 .LT. 0) THEN 8212 WRITE(LUPRI,*) 'Memory available : ',LWORK 8213 WRITE(LUPRI,*) 'Memory needed : ',KEND1 8214 CALL QUIT('Insufficient space in ADEN_DAI_T2_D_CUB (1)') 8215 END IF 8216 8217 !first sort the T2 amplitudes: 8218 !T2^{de}_{lm} -> KT2AM(em,dl) 8219 CALL SORT_T2_AI_BJ(WORK(KT2AM),T2TP,ISYMT2) 8220C 8221* 1) DAI(ai) = DAI(ai) + T2^{de}_{lm} * w^{Aed-}_{iml} is calculated as: 8222* 8223* DAI(AI) = DAI(AI) + KT2AM(em,dl) * TETA^AI(em,dl), which requires 8224* sorting of T2 amplitudes first. 8225 8226 !multiply KT2AM(em,dl) * TETA^AI(em,dl) 8227 ISYMA = ISYMD 8228 ISYMI = ISYML 8229 A = D 8230 I = L 8231C 8232 ISYMAI = MULD2H(ISYMA,ISYMI) 8233 IF (ISYMAI .EQ. ISYMDAI) THEN 8234C 8235 IF (ISYMT2 .EQ. ISYMTETA) THEN 8236C 8237 KOFF1 = IT1AM(ISYMA,ISYMI) 8238 * + NVIR(ISYMA)*(I-1) 8239 * + A 8240C 8241 DAI(KOFF1) = DAI(KOFF1) + DDOT(NT2SQ(ISYMTETA),TETA,1, 8242 * WORK(KT2AM),1) 8243 END IF 8244 END IF 8245C 8246C 8247C---------------------------------------------------------- 8248C 2) DAI(ai) = DAI(ai) - T2^{de}_{lm} * w^{Aed-}_{mil} 8249C---------------------------------------------------------- 8250C 8251 ISYMA = ISYMD 8252 ISYMM = ISYML 8253 A = D 8254 M = L 8255 DO ISYMDL = 1,NSYM 8256 ISYMEM = MULD2H(ISYMT2,ISYMDL) 8257 ISYMEI = MULD2H(ISYMTETA,ISYMDL) 8258 ISYME = MULD2H(ISYMEM,ISYMM) 8259 ISYMI = MULD2H(ISYMEI,ISYME) 8260 KOFF1 = 1 + IT2SQ(ISYMDL,ISYMEI) 8261 * + NT1AM(ISYMDL)*IT1AM(ISYME,ISYMI) 8262C 8263 KEM = IT1AM(ISYME,ISYMM) + NVIR(ISYME)*(M-1) + 1 8264C 8265 KOFF2 = KT2AM + IT2SQ(ISYMDL,ISYMEM) 8266 * + NT1AM(ISYMDL)*(KEM-1) 8267 KOFF3 = IT1AM(ISYMA,ISYMI) 8268 * + A 8269C 8270 NDLE = MAX(NT1AM(ISYMDL)*NVIR(ISYME),1) 8271C 8272 CALL DGEMV('T',NT1AM(ISYMDL)*NVIR(ISYME), 8273 * NRHF(ISYMI),-ONE,TETA(KOFF1),NDLE, 8274 * WORK(KOFF2),1,ONE,DAI(KOFF3),NVIR(ISYMA)) 8275C 8276 END DO 8277 8278 CALL QEXIT('DAIT2C') 8279C 8280 RETURN 8281 END 8282C /* Deck sort_t2_ai_bj */ 8283 SUBROUTINE SORT_T2_AI_BJ(T2AM,T2TP,ISYMT2) 8284C 8285C Reorder t2 amplitudes as: 8286C 8287C t2am(ai,bj) = t2tp(aijb) 8288C 8289C F. Pawlowski, Fall 2003, Aarhus. 8290C 8291#include "implicit.h" 8292C 8293 DIMENSION T2AM(*),T2TP(*) 8294C 8295#include "priunit.h" 8296#include "ccorb.h" 8297#include "ccsdsym.h" 8298C 8299 CALL QENTER('T2AI_BJ') 8300C 8301 DO 100 ISYMB = 1,NSYM 8302C 8303 ISYAIJ = MULD2H(ISYMB,ISYMT2) 8304C 8305 DO 110 ISYMJ = 1,NSYM 8306C 8307 ISYMBJ = MULD2H(ISYMB,ISYMJ) 8308 ISYMAI = MULD2H(ISYMBJ,ISYMT2) 8309C 8310 DO 120 J = 1,NRHF(ISYMJ) 8311C 8312 DO 130 B = 1,NVIR(ISYMB) 8313C 8314 NBJ = IT1AM(ISYMB,ISYMJ) 8315 * + NVIR(ISYMB)*(J - 1) + B 8316C 8317 KOFF1 = IT2SQ(ISYMAI,ISYMBJ) 8318 * + NT1AM(ISYMAI)*(NBJ - 1) + 1 8319C 8320 KOFF2 = IT2SP(ISYAIJ,ISYMB) 8321 * + NCKI(ISYAIJ)*(B - 1) 8322 * + ISAIK(ISYMAI,ISYMJ) 8323 * + NT1AM(ISYMAI)*(J - 1) + 1 8324C 8325 CALL DCOPY(NT1AM(ISYMAI),T2TP(KOFF2),1,T2AM(KOFF1),1) 8326C 8327 130 CONTINUE 8328 120 CONTINUE 8329 110 CONTINUE 8330 100 CONTINUE 8331C 8332 CALL QEXIT('T2AI_BJ') 8333C 8334 RETURN 8335 END 8336C /* Deck wjk_ground_occ */ 8337 SUBROUTINE WJK_GROUND_OCC(T30JK,ISYT30JK,T2TP, 8338 * ISYMT2, 8339 * T3OG2,ISYINT,ISYMJ,J,ISYMK,K, 8340 * WORK,LWORK) 8341*********************************************************** 8342* 8343* T3OG2 : (ai | kj) sorted as I(a_1^p,j_2^h,k_2^p,i_1^h) 8344* I(a,j,k,i) 8345* T30JK sitting as (bcai) 8346*********************************************************** 8347C 8348C T30^(abc)_(iJK) = 8349C P(ai,bj,ck) (sum_d t^(ad)_(ij) (ck|bd) ) + 8350C - P(ai,bj,ck) (sum_l t^(ab)_(il) (ck|lj) ) 8351C 8352C In this routine we calculate the second (i.e. occupied) contribution: 8353C 8354C T^JK(bcai) = - P(ai,bj,ck) (sum_l t^(ab)_(il) (ck|lj) ) 8355C (1) 8356C = - sum_l t^(ab)_(il) (ck|lj) 8357C (4) 8358C - sum_l t^(ac)_(il) (bj|lk) 8359C 8360C Filip Pawlowski, Aarhus, Winter 2003 8361* 8362* Fixed for memory problems, 29-Oct-2003, Aarhus, FP. 8363C 8364 IMPLICIT NONE 8365#include "ccsdsym.h" 8366#include "ccorb.h" 8367#include "priunit.h" 8368C 8369 INTEGER ISYT30JK,ISYMT2,ISYINT,ISYMJ,ISYMK,LWORK 8370 INTEGER ISYKJ,ISYCL,ISYML,ISYMC,ISYBAI 8371 INTEGER ISYT2BAL,ISYINTLCI,ISYBA,ISYCI 8372 INTEGER ISYT2BCL,ISYBC,ISYAI 8373 INTEGER ISYJK,ISYBL,ISYMB,ISYCAI 8374 INTEGER ISYT2CAL,ISYINTLBI,ISYCA,ISYBI 8375 INTEGER ISYT2CBL,ISYINTLAI,ISYCB 8376 INTEGER KT2LBAI,KINTCL,KCBAI,KEND1,LWRK1 8377 INTEGER KT2BAL,KINTLCI,KBACI 8378 INTEGER KT2BCL 8379 INTEGER KT2LCAI,KINTBL 8380 INTEGER KT2CAL,KINTLBI,KCABI 8381 INTEGER KT2CBL,KINTLAI 8382 INTEGER KOFF1,KOFF2,KOFF3 8383 INTEGER NTOTC,NTOTL,NTOTBA,NTOTBC,NTOTB,NTOTCA,NTOTCB 8384 INTEGER KBCAI 8385 INTEGER KTEMP,KEND2,LWRK2 8386 INTEGER ILOOP 8387C 8388#if defined (SYS_CRAY) 8389 REAL T30JK(*),T2TP(*),T3OG2(*),WORK(LWORK) 8390 REAL ONE 8391 real xnormval,ddot 8392#else 8393 DOUBLE PRECISION T30JK(*),T2TP(*),T3OG2(*),WORK(LWORK) 8394 DOUBLE PRECISION ONE 8395 double precision xnormval,ddot 8396#endif 8397C 8398 PARAMETER (ONE = 1.0D0) 8399C 8400 CALL QENTER('WJKGRO') 8401C 8402C================================================= 8403C Calculate (1) - sum_l t^(ab)_(il) (ck|lj) 8404C 8405C T(lbai) I^KJ(cl) 8406C================================================= 8407C 8408C------------------------------- 8409C Sort T2TP(blia) as T(lbai) 8410C------------------------------- 8411C 8412 ISYKJ = MULD2H(ISYMK,ISYMJ) 8413 ISYCL = MULD2H(ISYINT,ISYKJ) 8414C 8415 KCBAI = 1 8416 KEND1 = KCBAI + NMAAOBCI(ISYT30JK) 8417 LWRK1 = LWORK - KEND1 8418C 8419 IF (LWRK1 .LT. 0) THEN 8420 WRITE(LUPRI,*) 'Memory available : ',LWORK 8421 WRITE(LUPRI,*) 'Memory needed : ',KEND1 8422 CALL QUIT('Insufficient space in WJK_GROUND_OCC (1)') 8423 END IF 8424C 8425 DO ILOOP = 1,2 8426C 8427 KT2LBAI = KEND1 8428 KINTCL = KT2LBAI + NT2SQ(ISYMT2) 8429 KEND2 = KINTCL + NT1AM(ISYCL) 8430 LWRK2 = LWORK - KEND2 8431C 8432 IF (LWRK2 .LT. 0) THEN 8433 WRITE(LUPRI,*) 'Memory available : ',LWORK 8434 WRITE(LUPRI,*) 'Memory needed : ',KEND2 8435 IF (ILOOP .EQ. 1) THEN 8436 CALL QUIT('Insufficient space in WJK_GROUND_OCC (1x)') 8437 ELSE 8438 CALL QUIT('Insufficient space in WJK_GROUND_OCC (1xx)') 8439 END IF 8440 END IF 8441C 8442 CALL DZERO(WORK(KCBAI),NMAAOBCI(ISYT30JK)) 8443C 8444 CALL SORT_T2_I_ABJ(WORK(KT2LBAI),T2TP,ISYMT2) 8445C 8446C----------------------------- 8447C Sort (ck|lj) = T3OG2(c,j,k,l) as I^KJ(cl) 8448C----------------------------- 8449C 8450 IF (ILOOP .EQ. 1) THEN 8451 CALL SORT_INT_AJ_IK(WORK(KINTCL),T3OG2,ISYINT,ISYMK,K,ISYMJ,J) 8452 ELSE 8453 CALL SORT_INT_AJ_IK(WORK(KINTCL),T3OG2,ISYINT,ISYMJ,J,ISYMK,K) 8454 ENDIF 8455C 8456C------------------------------------------ 8457C Multiply I^KJ(cl) T(lbai) = T^JK(cbai) 8458C------------------------------------------ 8459C 8460 DO ISYML = 1, NSYM 8461 ISYMC = MULD2H(ISYCL,ISYML) 8462 ISYBAI = MULD2H(ISYMT2,ISYML) 8463C 8464 KOFF1 = KINTCL 8465 * + IT1AM(ISYMC,ISYML) 8466 KOFF2 = KT2LBAI 8467 * + IMAJBAI(ISYML,ISYBAI) 8468 KOFF3 = KCBAI 8469 * + IMAAOBCI(ISYMC,ISYBAI) 8470C 8471 NTOTC = MAX(NVIR(ISYMC),1) 8472 NTOTL = MAX(NRHF(ISYML),1) 8473C 8474 CALL DGEMM('N','N',NVIR(ISYMC),NMAABI(ISYBAI),NRHF(ISYML), 8475 * -ONE,WORK(KOFF1),NTOTC,WORK(KOFF2),NTOTL, 8476 * ONE,WORK(KOFF3),NTOTC) 8477C 8478 END DO ! ISYML 8479C 8480C T30JK(bcai) = T30JK(bcai) + T^JK(cbai) 8481C 8482C add_occ(1) 8483C 8484 IF (NSYM .GT. 1) THEN 8485C 8486 KTEMP = KEND1 8487 KEND2 = KTEMP + NMAABCI(ISYT30JK) 8488 LWRK2 = LWORK - KEND2 8489C 8490 IF (LWRK2 .LT. 0) THEN 8491 WRITE(LUPRI,*) 'Memory available : ',LWORK 8492 WRITE(LUPRI,*) 'Memory needed : ',KEND2 8493 CALL QUIT('Insufficient space in WJK_GROUND_OCC (1a)') 8494 END IF 8495C 8496 CALL DZERO(WORK(KTEMP),NMAABCI(ISYT30JK)) 8497C 8498 ! Sort from KCBAI(c,bai) to KTEMP(c,b,a,i) 8499 CALL FA_BCI(WORK(KTEMP),WORK(KCBAI),ISYT30JK,1) 8500 CALL DCOPY(NMAAOBCI(ISYT30JK),WORK(KTEMP),1,WORK(KCBAI),1) 8501 END IF 8502 8503 IF (ILOOP .EQ. 1) THEN 8504 !sort W(cbai) as W(bcai) 8505 CALL FBACI(T30JK,WORK(KCBAI),ISYT30JK) 8506 ELSE 8507 !put W(bcai) in the final array 8508 CALL FABCI_COLLECT(T30JK,WORK(KCBAI),ISYT30JK) 8509 ENDIF 8510 8511 ENDDO 8512C 8513 CALL QEXIT('WJKGRO') 8514C 8515 RETURN 8516 END 8517C /* Deck wjk_t2 */ 8518 SUBROUTINE WJK_T2(FAC,J,ISYMJ,K,ISYMK,T2TPX,ISYMT2X,T2TPZ, 8519 * ISYMT2Z, 8520 * FOCKY,ISYFKY, 8521 * WMAT,ISWMAT,WRK,LWRK) 8522C 8523C WJK(bda,i) = WBD(bda,i) - 8524C sum (f,l) focky(l,f)*( t2X(ai,dl)*t2Z(fk,bj) + t2X(ai,bl)*t2Z(fj,dk) ) 8525C 8526C 8527C 8528C Written by F. Pawlowski, Fall 2003. 8529C 8530 IMPLICIT NONE 8531C 8532#include "priunit.h" 8533#include "dummy.h" 8534#include "iratdef.h" 8535#include "ccsdsym.h" 8536#include "inftap.h" 8537#include "ccinftap.h" 8538#include "ccorb.h" 8539#include "ccsdinp.h" 8540C 8541 INTEGER LWRK, KFCLF, KEND0, LWRK0, KOFF1, KOFF2, KTB, KEND1, LWRK1 8542 INTEGER NL, NF, KOFFY, KOFFT2, KOFFT, KOFFW, KTD, KW 8543 INTEGER ISYMB, ISYMD, ISYMT2X, ISYFKY, ISWMAT 8544 INTEGER ISYAIL, ISYAI, ISYAIK, NA, NAI, LENGTH 8545 INTEGER ISYMF, ISYML, ISYFKJ, ISYTB, ISYMJ, ISYFK, ISYMK, ISYLK 8546 INTEGER ISYFJK, ISYTD, ISYLJ, ISYFJ, ISYAIJ 8547 INTEGER ISYMT2Z 8548C 8549 INTEGER ISYMKJ,ISYFB,ISYTJK,KTJK,ISYLB,ISYMBDAI,KWTEMP,ISYDIA 8550 INTEGER ISYMI,ISYMLI,ISYMBDA,ISYMA,ISYMLIA,ISYMBD,ISYMDL 8551 INTEGER ISYMDLI,ND,NB 8552 INTEGER KT2FB 8553 INTEGER ILOOP 8554C 8555#if defined (SYS_CRAY) 8556 REAL T2TPX(*), FOCKY(*), WMAT(*), WRK(*) 8557 REAL HALF, ONE, ZERO 8558 REAL T2TPZ(*) 8559 REAL FAC 8560#else 8561 DOUBLE PRECISION T2TPX(*), FOCKY(*), WMAT(*), WRK(*) 8562 DOUBLE PRECISION HALF, ONE, ZERO 8563 DOUBLE PRECISION T2TPZ(*) 8564 DOUBLE PRECISION FAC 8565#endif 8566C 8567 PARAMETER (HALF = 0.5D0, ONE = 1.0D0, ZERO = 0.0D0) 8568C 8569 CALL QENTER('WJKT2') 8570C 8571C 8572C RESORT VIR-OCC FOCKY ELEMENTS (l,f) 8573C 8574C 8575 KW = 1 8576 KFCLF = KW + NCKIJ(ISWMAT) 8577 KEND0 = KFCLF + NT1AM(ISYFKY) 8578 LWRK0 = LWRK - KEND0 8579 CALL DZERO(WRK(KW),NCKIJ(ISWMAT)) 8580C 8581 IF (LWRK0 .LT. 0) THEN 8582 WRITE(LUPRI,*) 'Memory available : ',LWRK0 8583 WRITE(LUPRI,*) 'Memory needed : ',KEND0 8584 CALL QUIT('Insufficient space in WJK_T2 (1)') 8585 END IF 8586C 8587 DO ISYMF = 1,NSYM 8588 ISYML = MULD2H(ISYMF,ISYFKY) 8589 DO L = 1,NRHF(ISYML) 8590 DO F = 1,NVIR(ISYMF) 8591 KOFF1 = IFCVIR(ISYML,ISYMF) + NORB(ISYML)*(F - 1) + L 8592 KOFF2 = KFCLF + IT1AMT(ISYML,ISYMF) 8593 * + NRHF(ISYML)*(F - 1) + L -1 8594C 8595 WRK(KOFF2) = FOCKY(KOFF1) 8596C 8597 END DO 8598 END DO 8599 END DO 8600C 8601C calculate first t2 contribution to W matrix 8602C 8603C construct tZJK(l,b) = sum (f) focky(l,f)*t2tpZ(f,K,J,b) 8604C 8605C calculated as: 8606C tZJK(l,b) = sum (f) focky(l,f)*t2tpZJK(f,b) 8607C 8608 DO ILOOP = 1,2 8609C 8610 ISYMKJ = MULD2H(ISYMK,ISYMJ) 8611 ISYFB = MULD2H(ISYMT2Z,ISYMKJ) 8612 ISYTJK = MULD2H(ISYFKY,ISYFB) 8613C 8614 KTJK = KEND0 8615 KEND1 = KTJK + NT1AM(ISYTJK) 8616 LWRK1 = LWRK - KEND1 8617C 8618 KT2FB = KEND1 8619 KEND1 = KT2FB + NMATAB(ISYFB) 8620 LWRK1 = LWRK - KEND1 8621C 8622 IF (LWRK1 .LT. 0) THEN 8623 WRITE(LUPRI,*) 'Memory available : ',LWRK 8624 WRITE(LUPRI,*) 'Memory needed : ',KEND1 8625 CALL QUIT('Insufficient space in WJK_T2 (2)') 8626 END IF 8627C 8628 CALL DZERO(WRK(KTJK),NT1AM(ISYTJK)) 8629C 8630 IF (ILOOP .EQ. 1) THEn 8631 !sort t2tpZ(f,K,J,b) to KT2FB(f,b) 8632 CALL SORT_T2_AB(WRK(KT2FB),ISYMK,K,ISYMJ,J,T2TPZ,ISYMT2Z) 8633 ELSE 8634 !sort t2tpZ(f,J,K,b) to KT2FB(f,b) 8635 CALL SORT_T2_AB(WRK(KT2FB),ISYMJ,J,ISYMK,K,T2TPZ,ISYMT2Z) 8636 ENDIF 8637C 8638 !tZJK(l,b) = sum (f) focky(l,f)*t2tpZJK(f,b) 8639 DO ISYMF = 1,NSYM 8640 ISYML = MULD2H(ISYFKY,ISYMF) 8641 ISYMB = MULD2H(ISYFB,ISYMF) 8642C 8643 KOFFY = KFCLF + IT1AMT(ISYML,ISYMF) 8644 KOFFT2 = KT2FB +IMATAB(ISYMF,ISYMB) 8645 KOFFT = KTJK + IT1AMT(ISYML,ISYMB) 8646C 8647 NL = MAX(NRHF(ISYML),1) 8648 NF = MAX(NVIR(ISYMF),1) 8649C 8650 CALL DGEMM('N','N',NRHF(ISYML),NVIR(ISYMB), 8651 * NVIR(ISYMF),ONE,WRK(KOFFY),NL, 8652 * WRK(KOFFT2),NF,ONE,WRK(KOFFT),NL) 8653 8654C 8655 END DO !ISYMF 8656 8657C 8658C WJK(bda,i) = WBD(bda,i) - 8659C sum (f,l) focky(l,f)*t2X(ai,dl)*t2Z(fk,bj) 8660C = WBD(bda,i) - 8661C sum (l) t2tpX(a,i,l,d) * tZJK(l,b) 8662C 8663 8664C Multiply as tZJK(l,b) * t2tpX(d,l,i,a) --> WJK(bda,i) 8665 8666C 8667 8668 ISYMBDAI = MULD2H(ISYMT2X,ISYTJK) 8669C 8670 !symmmetry check 8671 IF (ISYMBDAI .NE. ISWMAT) THEN 8672 WRITE(LUPRI,*) 'ISYMBDAI = ', ISYMBDAI 8673 WRITE(LUPRI,*) 'ISWMAT = ', ISWMAT 8674 WRITE(LUPRI,*) 'These symmetries should be EQUAL!' 8675 CALL QUIT('Symmetry inconsistency in WJK_T2') 8676 END IF 8677C 8678 KWTEMP = KEND1 8679 KEND1 = KWTEMP + NMAABCI(ISYMBDAI) 8680 LWRK1 = LWRK - KEND1 8681C 8682 IF (LWRK1 .LT. 0) THEN 8683 WRITE(LUPRI,*) 'Memory available : ',LWRK 8684 WRITE(LUPRI,*) 'Memory needed : ',KEND1 8685 CALL QUIT('Insufficient space in WJK_T2 (3)') 8686 END IF 8687C 8688 CALL DZERO(WRK(KWTEMP),NMAABCI(ISYMBDAI)) 8689C 8690 !Multiply as tZJK(l,b) * t2tpX(d,l,i,a) --> WJK(bda,i) 8691 DO ISYML = 1,NSYM 8692 ISYDIA = MULD2H(ISYMT2X,ISYML) 8693 ISYMB = MULD2H(ISYTJK,ISYML) 8694 DO ISYMI = 1,NSYM 8695 ISYMLI = MULD2H(ISYML,ISYMI) 8696 ISYMBDA = MULD2H(ISYMBDAI,ISYMI) 8697 DO ISYMA = 1,NSYM 8698 ISYMLIA = MULD2H(ISYMLI,ISYMA) 8699 ISYMBD = MULD2H(ISYMBDA,ISYMA) 8700 ISYMD = MULD2H(ISYMT2X,ISYMLIA) 8701 ISYMDL = MULD2H(ISYMD,ISYML) 8702 ISYMDLI = MULD2H(ISYMD,ISYMLI) 8703 DO I = 1,NRHF(ISYMI) 8704 DO A = 1,NVIR(ISYMA) 8705C 8706 KOFFT = KTJK + IT1AMT(ISYML,ISYMB) 8707 KOFFT2 = IT2SP(ISYMDLI,ISYMA) + NCKI(ISYMDLI)*(A-1) 8708 * + ISAIK(ISYMDL,ISYMI) + NT1AM(ISYMDL)*(I-1) 8709 * + IT1AM(ISYMD,ISYML) + 1 8710 KOFFW = KWTEMP + IMAABCI(ISYMBDA,ISYMI) 8711 * + NMAABC(ISYMBDA)*(I-1) 8712 * + IMAABC(ISYMBD,ISYMA) + NMATAB(ISYMBD)*(A-1) 8713 * + IMATAB(ISYMB,ISYMD) 8714C 8715 NL = MAX(NRHF(ISYML),1) 8716 ND = MAX(NVIR(ISYMD),1) 8717 NB = MAX(NVIR(ISYMB),1) 8718C 8719 CALL DGEMM('T','T',NVIR(ISYMB),NVIR(ISYMD), 8720 * NRHF(ISYML),-FAC,WRK(KOFFT),NL, 8721 * T2TPX(KOFFT2),ND,ONE,WRK(KOFFW),NB) 8722 8723C 8724 END DO 8725 END DO 8726 END DO 8727 END DO 8728 END DO 8729C 8730 IF (ILOOP .EQ. 1) THEn 8731 !First contribution 8732 CALL FABCI_COLLECT(WMAT,WRK(KWTEMP),ISYMBDAI) 8733 ELSE 8734 !Second contribution( (bj) <-> (dk) permutation) 8735 CALL FBACI(WMAT,WRK(KWTEMP),ISYMBDAI) 8736 ENDIF 8737 8738 ENDDO 8739C 8740 CALL QEXIT('WJKT2') 8741C 8742 RETURN 8743 END 8744C /* Deck fabci */ 8745 SUBROUTINE FABCI_COLLECT(TABCI,TABCITMP,ISYMT) 8746C 8747C TABCI = TABCI + TABCITMP 8748C 8749C F. Pawlowski, Aarhus, Fall 2003 8750C 8751 IMPLICIT NONE 8752#include "ccsdsym.h" 8753#include "ccorb.h" 8754#include "priunit.h" 8755C 8756 INTEGER ISYMT,ISYMI,ISYABC,ISYBAC,ISYMC,ISYAB,ISYBA,ISYMB,ISYMA 8757 INTEGER KOFF1,KOFF2 8758C 8759#if defined (SYS_CRAY) 8760 REAL TABCI(*),TABCITMP(*) 8761#else 8762 DOUBLE PRECISION TABCI(*),TABCITMP(*) 8763#endif 8764C 8765 CALL QENTER('FABCICLL') 8766C 8767 DO ISYMI = 1,NSYM 8768 ISYABC = MULD2H(ISYMT,ISYMI) 8769 ISYBAC = ISYABC 8770 DO ISYMC = 1,NSYM 8771 ISYAB = MULD2H(ISYABC,ISYMC) 8772 ISYBA = MULD2H(ISYBAC,ISYMC) 8773 DO ISYMB = 1,NSYM 8774 ISYMA = MULD2H(ISYAB,ISYMB) 8775 DO I = 1,NRHF(ISYMI) 8776 DO C = 1,NVIR(ISYMC) 8777 DO B = 1,NVIR(ISYMB) 8778 DO A = 1,NVIR(ISYMA) 8779 KOFF1 = IMAABCI(ISYABC,ISYMI) 8780 * + NMAABC(ISYABC)*(I-1) 8781 * + IMAABC(ISYAB,ISYMC) 8782 * + NMATAB(ISYAB)*(C-1) 8783 * + IMATAB(ISYMA,ISYMB) 8784 * + NVIR(ISYMA)*(B-1) 8785 * + A 8786C 8787 TABCI(KOFF1) = TABCI(KOFF1) + TABCITMP(KOFF1) 8788C 8789 END DO 8790 END DO 8791 END DO 8792 END DO 8793 END DO 8794 END DO 8795 END DO 8796C 8797 CALL QEXIT('FABCICLL') 8798C 8799 RETURN 8800 END 8801C /* Deck wxbd_t2_cub */ 8802 SUBROUTINE WXBD_T2_CUB(T2XNET2Z,AIBJCK_PERM,B,ISYMB,D,ISYMD, 8803 * T2TPX,ISYMT2X, 8804 * T2TPZ,ISYMT2Z,FOCKY, 8805 * ISYFKY,INDSQ,LENSQ,WMAT,ISWMAT,WRK,LWRK) 8806 8807 IMPLICIT NONE 8808 8809#include "priunit.h" 8810#include "ccsdsym.h" 8811 8812 LOGICAL T2XNET2Z 8813 8814 INTEGER AIBJCK_PERM 8815 8816 INTEGER LENSQ, INDSQ(LENSQ,6), LWRK 8817 INTEGER ISYMB, ISYMD, ISYMT2X, ISYFKY, ISWMAT, ISYMT2Z 8818 8819#if defined (SYS_CRAY) 8820 REAL T2TPX(*), FOCKY(*), WMAT(*), WRK(*), T2TPZ(*) 8821#else 8822 DOUBLE PRECISION T2TPX(*), FOCKY(*), WMAT(*), WRK(*), T2TPZ(*) 8823#endif 8824 8825 CALL QENTER('WXBDT2C') 8826 8827 CALL WXBD_T2_1(AIBJCK_PERM,B,ISYMB,D,ISYMD,T2TPX,ISYMT2X, 8828 * T2TPZ,ISYMT2Z,FOCKY, 8829 * ISYFKY,INDSQ,LENSQ,WMAT,ISWMAT,WRK,LWRK) 8830 8831 IF (T2XNET2Z) THEN 8832C 8833 CALL WXBD_T2_1(AIBJCK_PERM,B,ISYMB,D,ISYMD,T2TPZ,ISYMT2Z, 8834 * T2TPX,ISYMT2X,FOCKY, 8835 * ISYFKY,INDSQ,LENSQ,WMAT,ISWMAT,WRK,LWRK) 8836 8837 END IF 8838 8839 CALL QEXIT('WXBDT2C') 8840 8841 RETURN 8842 END 8843 8844 8845C /* Deck wxbd_t2_1 */ 8846 SUBROUTINE WXBD_T2_1(AIBJCK_PERM,B,ISYMB,D,ISYMD,T2TPX,ISYMT2X, 8847 * T2TPZ,ISYMT2Z,FOCKY, 8848 * ISYFKY,INDSQ,LENSQ,WMAT,ISWMAT,WRK,LWRK) 8849 8850 8851C 8852C 8853C If (AIBJCK_PERM.eq.1) then (aibjdk) + (aidkbj) permutation 8854C 8855C WBD(aikj) = WBD(aikj) - focky(l,f)* t2(ai,dl)*t2(fk,bj) 8856C 8857C - focky(l,f)*t2(ai,bl)*t2(fj,dk) 8858C 8859C else (AIBJCK_PERM.eq.2) then (bjdkai) + (bjaidk) permutation 8860C 8861C WBD(aikj) = WBD(aikj) - focky(l,f)* t2(bj,al)*t2(fi,dk) 8862C 8863C - focky(l,f)* t2(bj,dl)*t2(fk,ai) 8864C 8865 8866C else (AIBJCK_PERM.eq.3) then (dkbjai) + (dkaibj) permutation 8867C 8868C WBD(aikj) = WBD(aikj) - focky(l,f)* t2(dk,al)*t2(fi,bj) 8869C 8870C - focky(l,f)* t2(dk,bl)*t2(fj,ai) 8871C 8872C else if (AIBJCK_PERM.eq.4) then calculate all terms 8873C 8874C Written by F. Pawlowski, Spring 2003. 8875C 8876 8877 IMPLICIT NONE 8878C 8879 INTEGER AIBJCK_PERM 8880C 8881 INTEGER LENSQ 8882 INTEGER INDSQ(LENSQ,6) 8883 INTEGER LWRK,KFCLF, KEND0, LWRK0, KTB, KEND1, LWRK1 8884 INTEGER NL, NF, KOFFY, KOFFT2, KOFFT, KOFFW, KTD, KW 8885 INTEGER ISYMB, ISYMD, ISYMT2X, ISYMT2Z, ISYFKY, ISWMAT 8886 INTEGER ISYAIL, ISYAI, ISYAIK, NA, NAI, LENGTH 8887 INTEGER ISYFIJ,ISYLIJ,ISYAKL,ISYMJ,ISYFI,ISYMI,ISYMF,ISYML 8888 INTEGER ISYFKJ,ISYTB,ISYMK,ISYFJK,ISYTD,ISYFJ,ISYLJ 8889 INTEGER ISYAK,ISYAKI,NAK 8890 INTEGER ISYBD,ISYLK,ISYFK,ISYAIJ,NAIJ,ISYLI 8891 INTEGER KLIJ,KAKL,KLK,KFK 8892 INTEGER ISYFIK,ISYLIK,ISYAJL,KLIK,KAJL 8893 INTEGER ISYAJ,ISYAJI,NAJ 8894 INTEGER KLJ,KFJ,NAIK 8895C 8896 INTEGER KOFF1,KOFF2,KOFF3 8897C 8898#if defined (SYS_CRAY) 8899 REAL T2TPX(*), T2TPZ(*), FOCKY(*), WMAT(*), WRK(*) 8900 REAL HALF, ONE, ZERO 8901#else 8902 DOUBLE PRECISION T2TPX(*), T2TPZ(*), FOCKY(*), WMAT(*), WRK(*) 8903 DOUBLE PRECISION HALF, ONE, ZERO 8904#endif 8905C 8906#include "priunit.h" 8907#include "dummy.h" 8908#include "iratdef.h" 8909#include "ccsdsym.h" 8910#include "inftap.h" 8911#include "ccinftap.h" 8912#include "ccorb.h" 8913#include "ccsdinp.h" 8914C 8915 PARAMETER (HALF = 0.5D0, ONE = 1.0D0, ZERO = 0.0D0) 8916C 8917 CALL QENTER('WXBDT21') 8918C 8919C--------------------------------------- 8920C Initial test of AIBJCK_PERM option 8921C--------------------------------------- 8922C 8923 IF ( (AIBJCK_PERM .LT. 1) .OR. (AIBJCK_PERM .GT. 4) ) THEN 8924 WRITE(LUPRI,*)'AIBJCK_PERM = ',AIBJCK_PERM 8925 WRITE(LUPRI,*)'should be between 1 and 4 ' 8926 CALL QUIT('Illegal value of AIBJCK_PERM option in WXBD_T2_1') 8927 END IF 8928C 8929C 8930C RESORT VIR-OCC FOCKY ELEMENTS (l,f) 8931C 8932C 8933 KW = 1 8934 KFCLF = KW + NCKIJ(ISWMAT) 8935 KEND0 = KFCLF + NT1AM(ISYFKY) 8936 LWRK0 = LWRK - KEND0 8937 CALL DZERO(WRK(KW),NCKIJ(ISWMAT)) 8938C 8939 IF (LWRK0 .LT. 0) THEN 8940 WRITE(LUPRI,*) 'Memory available : ',LWRK 8941 WRITE(LUPRI,*) 'Memory needed : ',KEND0 8942 CALL QUIT('Insufficient space in WXBD_T2_1 (1)') 8943 END IF 8944C 8945 DO ISYMF = 1,NSYM 8946 ISYML = MULD2H(ISYMF,ISYFKY) 8947 DO L = 1,NRHF(ISYML) 8948 DO F = 1,NVIR(ISYMF) 8949 KOFF1 = IFCVIR(ISYML,ISYMF) + NORB(ISYML)*(F - 1) + L 8950 KOFF2 = KFCLF + IT1AMT(ISYML,ISYMF) 8951 * + NRHF(ISYML)*(F - 1) + L -1 8952C 8953 WRK(KOFF2) = FOCKY(KOFF1) 8954C 8955 END DO 8956 END DO 8957 END DO 8958C 8959 IF ((AIBJCK_PERM.EQ.1) .OR. (AIBJCK_PERM.EQ.4)) THEN 8960C 8961C calculate first t2 contribution to W matrix 8962C 8963C construct tZB(l,k,j) = sum (f) focky(l,f)*t2tpZ(f,k,j,B) 8964C 8965 ISYFKJ = MULD2H(ISYMT2Z,ISYMB) 8966 ISYTB = MULD2H(ISYFKY,ISYFKJ) 8967 KTB = KEND0 8968 KEND1 = KTB + NMAIJK(ISYTB) 8969 LWRK1 = LWRK - KEND1 8970C 8971 CALL DZERO(WRK(KTB),NMAIJK(ISYTB)) 8972C 8973 IF (LWRK1 .LT. 0) THEN 8974 WRITE(LUPRI,*) 'Memory available : ',LWRK 8975 WRITE(LUPRI,*) 'Memory needed : ',KEND1 8976 CALL QUIT('Insufficient space in WXBD_T2_1 (2)') 8977 END IF 8978C 8979 DO ISYMJ = 1,NSYM 8980 ISYFK = MULD2H(ISYFKJ,ISYMJ) 8981 DO J = 1,NRHF(ISYMJ) 8982 DO ISYMK = 1,NSYM 8983 ISYMF = MULD2H(ISYFK,ISYMK) 8984 ISYML = MULD2H(ISYFKY,ISYMF) 8985 ISYLK = MULD2H(ISYML,ISYMK) 8986 NL = MAX(1,NRHF(ISYML)) 8987 NF = MAX(1,NVIR(ISYMF)) 8988 KOFFY = KFCLF + IT1AMT(ISYML,ISYMF) 8989 KOFFT2 = IT2SP(ISYFKJ,ISYMB) + NCKI(ISYFKJ)*(B-1) 8990 * + ISAIK(ISYFK,ISYMJ) + NT1AM(ISYFK)*(J-1) 8991 * + IT1AM(ISYMF,ISYMK) + 1 8992 KOFFT = KTB + IMAIJK(ISYLK,ISYMJ) 8993 * + NMATIJ(ISYLK)*(J-1) 8994 * + IMATIJ(ISYML,ISYMK) 8995C 8996 CALL DGEMM('N','N',NRHF(ISYML),NRHF(ISYMK), 8997 * NVIR(ISYMF),ONE,WRK(KOFFY),NL, 8998 * T2TPZ(KOFFT2),NF,ONE,WRK(KOFFT),NL) 8999C 9000 END DO 9001 END DO 9002 END DO 9003C 9004C WBD(a,i,k,j) = WBD(a,i,k,j) - 9005C sum (f,l) focky(l,f)* t2X(ai,Dl)*t2Z(fk,Bj) 9006C = WBD(a,i,k,j) - 9007C sum(l) t2tpX(a,i,l,D) * tZB(l,k,j) 9008C 9009 ISYAIL = MULD2H(ISYMT2X,ISYMD) 9010 DO ISYMJ = 1,NSYM 9011 ISYLK = MULD2H(ISYTB,ISYMJ) 9012 DO J = 1,NRHF(ISYMJ) 9013 DO ISYMK = 1,NSYM 9014 ISYML = MULD2H(ISYLK,ISYMK) 9015 ISYAI = MULD2H(ISYAIL,ISYML) 9016 ISYAIK = MULD2H(ISYAI,ISYMK) 9017 NAI = MAX(1,NT1AM(ISYAI)) 9018 NL = MAX(1,NRHF(ISYML)) 9019 KOFFT2 = IT2SP(ISYAIL,ISYMD) + NCKI(ISYAIL)*(D-1) 9020 * + ISAIK(ISYAI,ISYML) + 1 9021 KOFFT = KTB + IMAIJK(ISYLK,ISYMJ) 9022 * + NMATIJ(ISYLK)*(J-1) 9023 * + IMATIJ(ISYML,ISYMK) 9024 KOFFW = ISAIKJ(ISYAIK,ISYMJ) + NCKI(ISYAIK)*(J-1) 9025 * + ISAIK(ISYAI,ISYMK) + 1 9026 CALL DGEMM('N','N',NT1AM(ISYAI),NRHF(ISYMK), 9027 * NRHF(ISYML),-ONE,T2TPX(KOFFT2),NAI, 9028 * WRK(KOFFT),NL,ONE,WMAT(KOFFW),NAI) 9029 9030C 9031 END DO 9032 END DO 9033 END DO 9034C 9035C calculate second t2 contribution to W matrix 9036C 9037C 9038C construct tD(l,j,k) = sum (f) focky(l,f)*t2tpZ(f,j,k,D) 9039C 9040 ISYFJK = MULD2H(ISYMT2Z,ISYMD) 9041 ISYTD = MULD2H(ISYFKY,ISYFJK) 9042 KTD = KEND0 9043 KEND1 = KTD + NMAIJK(ISYTD) 9044 LWRK1 = LWRK - KEND1 9045C 9046 CALL DZERO(WRK(KTD),NMAIJK(ISYTD)) 9047C 9048 IF (LWRK1 .LT. 0) THEN 9049 WRITE(LUPRI,*) 'Memory available : ',LWRK 9050 WRITE(LUPRI,*) 'Memory needed : ',KEND1 9051 CALL QUIT('Insufficient space in WXBD_T2_1 (3)') 9052 END IF 9053C 9054 9055 DO ISYMK = 1,NSYM 9056 ISYFJ = MULD2H(ISYFJK,ISYMK) 9057 DO K = 1,NRHF(ISYMK) 9058 DO ISYMJ = 1,NSYM 9059 ISYMF = MULD2H(ISYFJ,ISYMJ) 9060 ISYML = MULD2H(ISYFKY,ISYMF) 9061 ISYLJ = MULD2H(ISYML,ISYMJ) 9062 NL = MAX(1,NRHF(ISYML)) 9063 NF = MAX(1,NVIR(ISYMF)) 9064 KOFFY = KFCLF + IT1AMT(ISYML,ISYMF) 9065 KOFFT2 = IT2SP(ISYFJK,ISYMD) + NCKI(ISYFJK)*(D-1) 9066 * + ISAIK(ISYFJ,ISYMK) + NT1AM(ISYFJ)*(K-1) 9067 * + IT1AM(ISYMF,ISYMJ) + 1 9068 KOFFT = KTD + IMAIJK(ISYLJ,ISYMK) 9069 * + NMATIJ(ISYLJ)*(K-1) 9070 * + IMATIJ(ISYML,ISYMJ) 9071 CALL DGEMM('N','N',NRHF(ISYML),NRHF(ISYMJ), 9072 * NVIR(ISYMF),ONE,WRK(KOFFY),NL, 9073 * T2TPZ(KOFFT2),NF,ONE,WRK(KOFFT),NL) 9074C 9075 END DO 9076 END DO 9077 END DO 9078C 9079C WBD(a,i,k,j) = WBD(a,i,k,j) - 9080C sum (f,l) focky(l,f)*t2X(ai,Bl)*t2Z(fj,Dk) ) 9081C = WBD(a,i,k,j) - 9082C sum(l) t2tpX(a,i,l,B) * tZD(l,j,k) 9083C 9084 ISYAIL = MULD2H(ISYMT2X,ISYMB) 9085 DO ISYMK = 1,NSYM 9086 ISYLJ = MULD2H(ISYTD,ISYMK) 9087 DO K = 1,NRHF(ISYMK) 9088 DO ISYMJ = 1,NSYM 9089 ISYML = MULD2H(ISYLJ,ISYMJ) 9090 ISYAI = MULD2H(ISYAIL,ISYML) 9091 ISYAIJ = MULD2H(ISYAI,ISYMJ) 9092 NAI = MAX(1,NT1AM(ISYAI)) 9093 NL = MAX(1,NRHF(ISYML)) 9094 KOFFT2 = IT2SP(ISYAIL,ISYMB) + NCKI(ISYAIL)*(B-1) 9095 * + ISAIK(ISYAI,ISYML) + 1 9096 KOFFT = KTD + IMAIJK(ISYLJ,ISYMK) 9097 * + NMATIJ(ISYLJ)*(K-1) 9098 * + IMATIJ(ISYML,ISYMJ) 9099 KOFFW = KW + ISAIKJ(ISYAIJ,ISYMK) 9100 * + NCKI(ISYAIJ)*(K-1) 9101 * + ISAIK(ISYAI,ISYMJ) 9102 CALL DGEMM('N','N',NT1AM(ISYAI),NRHF(ISYMJ), 9103 * NRHF(ISYML),-ONE,T2TPX(KOFFT2),NAI, 9104 * WRK(KOFFT),NL,ONE,WRK(KOFFW),NAI) 9105 9106C 9107 END DO 9108 END DO 9109 END DO 9110C 9111C change order aijk to aikj 9112C 9113 DO I = 1,NCKIJ(ISWMAT) 9114 WMAT(I) = WMAT(I) + WRK(INDSQ(I,3)) 9115 END DO 9116C 9117C 9118 END IF 9119 IF ((AIBJCK_PERM.EQ.2) .OR. (AIBJCK_PERM.EQ.4)) THEN 9120C 9121C 9122C WBD(aikj) = WBD(aikj) - focky(l,f)* t2X(bj,al)*t2Z(fi,dk) 9123C 9124C TX^B(ajl) tZ(fikD) 9125C 9126C work(lik) = focky(lf) * tZ(fikD) 9127C 9128C work(ajik) = TX^B(ajl) * work(lik) 9129 9130C 9131C work(lik) = focky(lf) * tZ(fikD) 9132C 9133 ISYFIK = MULD2H(ISYMT2Z,ISYMD) 9134 ISYLIK = MULD2H(ISYFKY,ISYFIK) 9135 ISYAJL = MULD2H(ISYMT2X,ISYMB) 9136 KLIK = KEND0 9137 KAJL = KLIK + NMAIJK(ISYLIK) 9138 KEND1 = KAJL + NCKI(ISYAJL) 9139 LWRK1 = LWRK - KEND1 9140C 9141 CALL DZERO(WRK(KLIK),NMAIJK(ISYLIK)) 9142C 9143 CALL DZERO(WRK(KW),NCKIJ(ISWMAT)) 9144C 9145 IF (LWRK1 .LT. 0) THEN 9146 WRITE(LUPRI,*) 'Memory available : ',LWRK 9147 WRITE(LUPRI,*) 'Memory needed : ',KEND1 9148 CALL QUIT('Insufficient space in WXBD_T2_1 (4)') 9149 END IF 9150C 9151C 9152 9153 DO ISYMK = 1,NSYM 9154 ISYFI = MULD2H(ISYFIK,ISYMK) 9155 DO K = 1,NRHF(ISYMK) 9156 DO ISYMI = 1,NSYM 9157 ISYMF = MULD2H(ISYFI,ISYMI) 9158 ISYML = MULD2H(ISYFKY,ISYMF) 9159 ISYLI = MULD2H(ISYMI,ISYML) 9160 NL = MAX(1,NRHF(ISYML)) 9161 NF = MAX(1,NVIR(ISYMF)) 9162 KOFF1 = KFCLF + IT1AMT(ISYML,ISYMF) 9163 KOFF2 = IT2SP(ISYFIK,ISYMD) + NCKI(ISYFIK)*(D-1) 9164 * + ISAIK(ISYFI,ISYMK) + NT1AM(ISYFI)*(K-1) 9165 * + IT1AM(ISYMF,ISYMI) + 1 9166 KOFF3 = KLIK + IMAIJK(ISYLI,ISYMK) 9167 * + NMATIJ(ISYLI)*(K-1) 9168 * + IMATIJ(ISYML,ISYMI) 9169C 9170C work(lik) = focky(lf) * t(fikD) 9171C 9172 CALL DGEMM('N','N',NRHF(ISYML),NRHF(ISYMI), 9173 * NVIR(ISYMF),ONE,WRK(KOFF1),NL, 9174 * T2TPZ(KOFF2),NF,ONE,WRK(KOFF3),NL) 9175C 9176 END DO 9177 END DO 9178 END DO 9179C 9180C TX^B(ajl) = t2X(bj,al) 9181C 9182 CALL SORT_T2_AJI(WRK(KAJL),ISYMB,B,T2TPX,ISYMT2X) 9183C 9184C 9185 DO ISYMK = 1,NSYM 9186 ISYLI = MULD2H(ISYLIK,ISYMK) 9187 DO K = 1,NRHF(ISYMK) 9188 DO ISYMI = 1,NSYM 9189 ISYML = MULD2H(ISYLI,ISYMI) 9190 ISYAJ = MULD2H(ISYAJL,ISYML) 9191 ISYAJI = MULD2H(ISYAJ,ISYMI) 9192 NAJ = MAX(1,NT1AM(ISYAJ)) 9193 NL = MAX(1,NRHF(ISYML)) 9194 KOFF1 = KAJL + ISAIK(ISYAJ,ISYML) 9195 KOFF2 = KLIK + IMAIJK(ISYLI,ISYMK) 9196 * + NMATIJ(ISYLI)*(K-1) 9197 * + IMATIJ(ISYML,ISYMI) 9198 KOFF3 = KW + ISAIKJ(ISYAJI,ISYMK) 9199 * + NCKI(ISYAJI)*(K-1) 9200 * + ISAIK(ISYAJ,ISYMI) 9201C 9202C work(ajik) = TX^B(ajl) * work(lik) 9203C 9204 CALL DGEMM('N','N',NT1AM(ISYAJ),NRHF(ISYMI), 9205 * NRHF(ISYML),-ONE,WRK(KOFF1),NAJ, 9206 * WRK(KOFF2),NL,ONE,WRK(KOFF3),NAJ) 9207 9208C 9209 END DO 9210 END DO 9211 END DO 9212C 9213C change order ajik to aikj 9214C 9215 DO I = 1,NCKIJ(ISWMAT) 9216 WMAT(I) = WMAT(I) + WRK(INDSQ(I,4)) 9217 END DO 9218C 9219C WBD(aikj) = WBD(aikj) - focky(l,f)* t2X(bj,dl)*t2Z(fk,ai) 9220C 9221C TX^DB(lj) tZ(aikf) 9222C 9223C work(fj) = focky(l,f) * TX^DB(lj) 9224C 9225C WMAT(aikj) = WMAT(aikj) - tZ(aikf) * work(fj) 9226C 9227 ISYBD = MULD2H(ISYMB,ISYMD) 9228 ISYLJ = MULD2H(ISYBD,ISYMT2X) 9229 ISYFJ = MULD2H(ISYFKY,ISYLJ) 9230C 9231 KLJ = KEND0 9232 KFJ = KLJ + NMATIJ(ISYLJ) 9233 KEND1 = KFJ + NT1AM(ISYFJ) 9234 LWRK1 = LWRK - KEND1 9235C 9236 CALL DZERO(WRK(KFJ),NT1AM(ISYFJ)) 9237C 9238 IF (LWRK1 .LT. 0) THEN 9239 WRITE(LUPRI,*) 'Memory available : ',LWRK 9240 WRITE(LUPRI,*) 'Memory needed : ',KEND1 9241 CALL QUIT('Insufficient space in WXBD_T2_1 (5)') 9242 END IF 9243C 9244C 9245 CALL SORT_T2_IJ(WRK(KLJ),ISYMD,D,ISYMB,B,T2TPX,ISYMT2X) 9246C 9247C work(fj) = focky(l,f) * TX^DB(lj) 9248C 9249 DO ISYMJ = 1,NSYM 9250 ISYML = MULD2H(ISYMJ,ISYLJ) 9251 ISYMF = MULD2H(ISYFKY,ISYML) 9252C 9253 KOFF1 = KFCLF + IT1AMT(ISYML,ISYMF) 9254 KOFF2 = KLJ + IMATIJ(ISYML,ISYMJ) 9255 KOFF3 = KFJ + IT1AM(ISYMF,ISYMJ) 9256C 9257 NF = MAX(1,NVIR(ISYMF)) 9258 NL = MAX(1,NRHF(ISYML)) 9259C 9260 CALL DGEMM('T','N',NVIR(ISYMF),NRHF(ISYMJ), 9261 * NRHF(ISYML),ONE,WRK(KOFF1),NL, 9262 * WRK(KOFF2),NL,ONE,WRK(KOFF3),NF) 9263C 9264 END DO 9265C 9266C WMAT(aikj) = WMAT(aikj) - tZ(aikf) * work(fj) 9267C 9268 DO ISYMJ = 1,NSYM 9269 ISYMF = MULD2H(ISYMJ,ISYFJ) 9270 ISYAIK = MULD2H(ISYMT2Z,ISYMF) 9271C 9272 KOFF1 = IT2SP(ISYAIK,ISYMF) + 1 9273 KOFF2 = KFJ + IT1AM(ISYMF,ISYMJ) 9274 KOFF3 = ISAIKJ(ISYAIK,ISYMJ) + 1 9275C 9276 NAIK = MAX(1,NCKI(ISYAIK)) 9277 NF = MAX(1,NVIR(ISYMF)) 9278 9279 CALL DGEMM('N','N',NCKI(ISYAIK),NRHF(ISYMJ), 9280 * NVIR(ISYMF),-ONE,T2TPZ(KOFF1),NAIK, 9281 * WRK(KOFF2),NF,ONE,WMAT(KOFF3),NAIK) 9282C 9283 END DO 9284C 9285 END IF 9286 IF ((AIBJCK_PERM.EQ.3) .OR. (AIBJCK_PERM.EQ.4)) THEN 9287C 9288C WBD(aikj) = WBD(aikj) - focky(l,f)* t2X(dk,al)*t2Z(fi,bj) 9289C 9290C IX^D(alk) TZ^B(fij) 9291C 9292C work(lij) = focky(lf) * TZ^B(fij) 9293C 9294C work(akij) = TX^D(akl) * work(lij) 9295C 9296C WBD(aikj) = WBD(aikj) - work(akij) 9297C 9298C 9299C work(lij) = focky(lf) * TZ^B(fij) 9300C 9301 ISYFIJ = MULD2H(ISYMT2Z,ISYMB) 9302 ISYLIJ = MULD2H(ISYFKY,ISYFIJ) 9303 ISYAKL = MULD2H(ISYMT2X,ISYMD) 9304 KLIJ = KEND0 9305 KAKL = KLIJ + NMAIJK(ISYLIJ) 9306 KEND1 = KAKL + NCKI(ISYAKL) 9307 LWRK1 = LWRK - KEND1 9308C 9309 CALL DZERO(WRK(KLIJ),NMAIJK(ISYLIJ)) 9310C 9311 CALL DZERO(WRK(KW),NCKIJ(ISWMAT)) 9312C 9313 IF (LWRK1 .LT. 0) THEN 9314 WRITE(LUPRI,*) 'Memory available : ',LWRK 9315 WRITE(LUPRI,*) 'Memory needed : ',KEND1 9316 CALL QUIT('Insufficient space in WXBD_T2_1 (6)') 9317 END IF 9318C 9319 9320 DO ISYMJ = 1,NSYM 9321 ISYFI = MULD2H(ISYFIJ,ISYMJ) 9322 DO J = 1,NRHF(ISYMJ) 9323 DO ISYMI = 1,NSYM 9324 ISYMF = MULD2H(ISYFI,ISYMI) 9325 ISYML = MULD2H(ISYFKY,ISYMF) 9326 ISYLI = MULD2H(ISYMI,ISYML) 9327 NL = MAX(1,NRHF(ISYML)) 9328 NF = MAX(1,NVIR(ISYMF)) 9329 KOFF1 = KFCLF + IT1AMT(ISYML,ISYMF) 9330 KOFF2 = IT2SP(ISYFIJ,ISYMB) + NCKI(ISYFIJ)*(B-1) 9331 * + ISAIK(ISYFI,ISYMJ) + NT1AM(ISYFI)*(J-1) 9332 * + IT1AM(ISYMF,ISYMI) + 1 9333 KOFF3 = KLIJ + IMAIJK(ISYLI,ISYMJ) 9334 * + NMATIJ(ISYLI)*(J-1) 9335 * + IMATIJ(ISYML,ISYMI) 9336 CALL DGEMM('N','N',NRHF(ISYML),NRHF(ISYMI), 9337 * NVIR(ISYMF),ONE,WRK(KOFF1),NL, 9338 * T2TPZ(KOFF2),NF,ONE,WRK(KOFF3),NL) 9339C 9340 END DO 9341 END DO 9342 END DO 9343C 9344C work(akij) = TX^D(akl) * work(lij) 9345C 9346 CALL SORT_T2_AJI(WRK(KAKL),ISYMD,D,T2TPX,ISYMT2X) 9347C 9348C 9349 DO ISYMJ = 1,NSYM 9350 ISYLI = MULD2H(ISYLIJ,ISYMJ) 9351 DO J = 1,NRHF(ISYMJ) 9352 DO ISYMI = 1,NSYM 9353 ISYML = MULD2H(ISYLI,ISYMI) 9354 ISYAK = MULD2H(ISYAKL,ISYML) 9355 ISYAKI = MULD2H(ISYAK,ISYMI) 9356 NAK = MAX(1,NT1AM(ISYAK)) 9357 NL = MAX(1,NRHF(ISYML)) 9358 KOFF1 = KAKL + ISAIK(ISYAK,ISYML) 9359 KOFF2 = KLIJ + IMAIJK(ISYLI,ISYMJ) 9360 * + NMATIJ(ISYLI)*(J-1) 9361 * + IMATIJ(ISYML,ISYMI) 9362 KOFF3 = KW + ISAIKJ(ISYAKI,ISYMJ) 9363 * + NCKI(ISYAKI)*(J-1) 9364 * + ISAIK(ISYAK,ISYMI) 9365 CALL DGEMM('N','N',NT1AM(ISYAK),NRHF(ISYMI), 9366 * NRHF(ISYML),-ONE,WRK(KOFF1),NAK, 9367 * WRK(KOFF2),NL,ONE,WRK(KOFF3),NAK) 9368 9369C 9370 END DO 9371 END DO 9372 END DO 9373C 9374C change order akij to aikj 9375C 9376 DO I = 1,NCKIJ(ISWMAT) 9377 WMAT(I) = WMAT(I) + WRK(INDSQ(I,1)) 9378 END DO 9379C 9380C WBD(aikj) = WBD(aikj) - focky(l,f)* t2X(dk,bl)*t2Z(fj,ai) 9381C 9382C IX^BD(lk) IZ(aijf) 9383C 9384C work(fk) = focky(lf) * IX^BD(lk) 9385C 9386C work(aijk) = IZ(aijf) * work(fk) 9387C 9388C WBD(aikj) = WBD(aikj) - work(aijk) 9389C 9390 ISYBD = MULD2H(ISYMB,ISYMD) 9391 ISYLK = MULD2H(ISYBD,ISYMT2X) 9392 ISYFK = MULD2H(ISYFKY,ISYLK) 9393C 9394 KLK = KEND0 9395 KFK = KLK + NMATIJ(ISYLK) 9396 KEND1 = KFK + NT1AM(ISYFK) 9397 LWRK1 = LWRK - KEND1 9398C 9399 CALL DZERO(WRK(KFK),NT1AM(ISYFK)) 9400 CALL DZERO(WRK(KW),NCKIJ(ISWMAT)) 9401C 9402 IF (LWRK1 .LT. 0) THEN 9403 WRITE(LUPRI,*) 'Memory available : ',LWRK 9404 WRITE(LUPRI,*) 'Memory needed : ',KEND1 9405 CALL QUIT('Insufficient space in WXBD_T2_1 (7)') 9406 END IF 9407C 9408 CALL SORT_T2_IJ(WRK(KLK),ISYMB,B,ISYMD,D,T2TPX,ISYMT2X) 9409C 9410C work(fk) = focky(lf) * IX^BD(lk) 9411 9412 DO ISYMK = 1,NSYM 9413 ISYML = MULD2H(ISYMK,ISYLK) 9414 ISYMF = MULD2H(ISYFKY,ISYML) 9415C 9416 KOFF1 = KFCLF + IT1AMT(ISYML,ISYMF) 9417 KOFF2 = KLK + IMATIJ(ISYML,ISYMK) 9418 KOFF3 = KFK + IT1AM(ISYMF,ISYMK) 9419C 9420 NF = MAX(1,NVIR(ISYMF)) 9421 NL = MAX(1,NRHF(ISYML)) 9422C 9423 CALL DGEMM('T','N',NVIR(ISYMF),NRHF(ISYMK), 9424 * NRHF(ISYML),ONE,WRK(KOFF1),NL, 9425 * WRK(KOFF2),NL,ONE,WRK(KOFF3),NF) 9426C 9427 END DO 9428C 9429C work(aijk) = IZ(aijf) * work(fk) 9430C 9431 DO ISYMK = 1,NSYM 9432 ISYMF = MULD2H(ISYMK,ISYFK) 9433 ISYAIJ = MULD2H(ISYMT2Z,ISYMF) 9434C 9435 KOFF1 = IT2SP(ISYAIJ,ISYMF) + 1 9436 KOFF2 = KFK + IT1AM(ISYMF,ISYMK) 9437 KOFF3 = KW + ISAIKJ(ISYAIJ,ISYMK) 9438C 9439 NAIJ = MAX(1,NCKI(ISYAIJ)) 9440 NF = MAX(1,NVIR(ISYMF)) 9441 9442 CALL DGEMM('N','N',NCKI(ISYAIJ),NRHF(ISYMK), 9443 * NVIR(ISYMF),-ONE,T2TPZ(KOFF1),NAIJ, 9444 * WRK(KOFF2),NF,ONE,WRK(KOFF3),NAIJ) 9445C 9446 END DO 9447C 9448C change order aijk to aikj 9449C 9450 DO I = 1,NCKIJ(ISWMAT) 9451 WMAT(I) = WMAT(I) + WRK(INDSQ(I,3)) 9452 END DO 9453C 9454 END IF 9455C 9456 9457 CALL QEXIT('WXBDT21') 9458C 9459 RETURN 9460 END 9461C /* Deck intvir_t3x_jk */ 9462 SUBROUTINE INTVIR_T3X_JK(XGBCDK,ISYINT, 9463 * LUFIL,FNFIL, 9464 * WORK,LWORK) 9465********************************************************** 9466* 9467* Construct the integrals used for t3x^JK calculation 9468* 9469* Read virtual integrals (Ck|bd) stored as I^C(dk,b) 9470* Final sort (Ck|bd) as I(bcd,k) 9471* 9472* OUTPUT (XGBCDK) : g(ckbd) = (ck|bd) sorted as I(bcd,k) 9473* 9474* F. Pawlowski, 02-10-2003, Aarhus. 9475********************************************************** 9476C 9477 IMPLICIT NONE 9478#include "ccsdsym.h" 9479#include "ccorb.h" 9480#include "priunit.h" 9481C 9482 INTEGER ISYINT, LUFIL, LWORK 9483 INTEGER ISYMD, ISYCKA, KINTVI, KEND1, LWRK1, IOFF 9484C 9485 CHARACTER*(*) FNFIL 9486C 9487#if defined (SYS_CRAY) 9488 REAL XGBCDK(*), WORK(LWORK) 9489#else 9490 DOUBLE PRECISION XGBCDK(*), WORK(LWORK) 9491#endif 9492C 9493 CALL QENTER('INTV3XJK') 9494C 9495C***********************************************************' 9496C Get (XGBDCK) : g(ckbd) = (ck|bd) sorted as I(bcd,k) 9497C***********************************************************' 9498C 9499 DO ISYMD = 1, NSYM 9500 ISYCKA = MULD2H(ISYINT,ISYMD) 9501C 9502 KINTVI = 1 9503 KEND1 = KINTVI + NCKATR(ISYCKA) 9504 LWRK1 = LWORK - KEND1 9505C 9506 IF (LWRK1 .LT. 0) THEN 9507 CALL QUIT('Insufficient space in INTVIR_T3X_JK ') 9508 ENDIF 9509C 9510 DO D = 1, NVIR(ISYMD) 9511C 9512C Read virtual integrals (ck|bd) sorted as I^C(dk,b) 9513C 9514 IOFF = ICKBD(ISYCKA,ISYMD) + NCKATR(ISYCKA)*(D - 1) + 1 9515 IF (NCKATR(ISYCKA) .GT. 0) THEN 9516 CALL GETWA2(LUFIL,FNFIL,WORK(KINTVI),IOFF, 9517 & NCKATR(ISYCKA)) 9518 ENDIF 9519C 9520C Final sort (ck|bd) as I(bcd,k) 9521C 9522 CALL SORT_INTVIR_T3B0(XGBCDK,WORK(KINTVI), 9523 * D,ISYMD,ISYCKA,WORK(KEND1),LWRK1) 9524 END DO ! D 9525 END DO ! ISYMD 9526C 9527 CALL QEXIT('INTV3XJK') 9528C 9529 RETURN 9530 END 9531