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 ccsdpt_eta */ 20 SUBROUTINE CCSDPT_ETA(OMEGA1,OMEGA2,T1AM,ISYMT1,T2TP, 21 * ISYMT2,MODEL,WORK,LWORK, 22 * LUTOC,FNTOC,LU3VI,FN3VI,LU3VI2,FN3VI2, 23 * LU3FOP,FN3FOP,LU3FOP2,FN3FOP2) 24C 25C Written by K. Hald, Fall 2001. 26C 27C Add the triples contribution to the eta vector for solving 28C for the zero order single and double amplitude multipliers. 29C 30C ISYMT2 is symmetry of T2TP 31C ISYMT1 is symmetry of T1AM 32C 33C Isyres = isymt1*isymt2*isymop 34C 35 IMPLICIT NONE 36C 37#include "priunit.h" 38#include "dummy.h" 39#include "iratdef.h" 40#include "ccsdsym.h" 41#include "inftap.h" 42#include "ccinftap.h" 43#include "ccorb.h" 44#include "ccsdinp.h" 45#include "second.h" 46C 47 INTEGER ISYMT1, ISYMT2, LWORK 48 INTEGER ISYMTR, ISYRES, ISINT1, ISINT2, ISYMIM, KFOCKD, KOMG1 49 INTEGER KOMG22, KCMO, KEND0, LWRK0, KTROC, KTROC1, KTROC2 50 INTEGER KTROC0, KXIAJB, KEND1, LWRK1, KINTOC, KEND2, LWRK2 51 INTEGER LENGTH, ISYOPE, IOPTTCME, IOFF, ISYMD, ISAIJ1, ISYCKB 52 INTEGER ISCKB1, ISCKB2, KTRVI, KTRVI1, KTRVI2, KRMAT1, KTRVI0 53 INTEGER KTRVI3, KEND3, LWRK3, KINTVI, KEND4, LWRK4, ISYMB 54 INTEGER ISYALJ, ISAIJ2, ISYMBD, ISCKIJ, KSMAT2, KSMAT, KQMAT 55 INTEGER KDIAG, ISYMC, ISYMK, KOFF1, KOFF2 56 INTEGER KINDSQ, KINDEX, KTMAT, KRMAT2, KRMAT4, LENSQ 57 INTEGER LUFCK, KFCKBA, KT2TCME, IOPTT2, KTRVI4, KTRVI5 58 INTEGER KTRVI6, KQMAT2, KRMAT3 59 INTEGER LUTOC, LU3VI, LU3VI2, LU3FOP, LU3FOP2 60C 61#if defined (SYS_CRAY) 62 REAL OMEGA1(*), OMEGA2(*), T1AM(*), T2TP(*) 63 REAL WORK(LWORK), ONE 64 REAL TITRAN, TISORT, TISMAT, TIQMAT, TIOME1 65 REAL TICONV, TICONO, RHO1N, RHO2N 66 REAL XT2TP, DDOT, XIAJB, XINT, XTROC, XTROC1, XTROC0 67 REAL XTRVI0, XTRVI2, XTRVI3, XTRVI, XTRVI1, XDIA 68 REAL XSMAT, XTMAT, XQMAT, XRMAT, TWO, ZERO, HALF 69 REAL DTIME 70#else 71 DOUBLE PRECISION OMEGA1(*), OMEGA2(*), T1AM(*), T2TP(*) 72 DOUBLE PRECISION WORK(LWORK), ONE 73 DOUBLE PRECISION TITRAN, TISORT, TISMAT, TIQMAT, TIOME1 74 DOUBLE PRECISION TICONV, TICONO, RHO1N, RHO2N 75 DOUBLE PRECISION XT2TP, DDOT, XIAJB, XINT, XTROC, XTROC1, XTROC0 76 DOUBLE PRECISION XTRVI0, XTRVI2, XTRVI3, XTRVI, XTRVI1, XDIA 77 DOUBLE PRECISION XSMAT, XTMAT, XQMAT, XRMAT, TWO, ZERO, HALF 78 DOUBLE PRECISION DTIME 79#endif 80C 81 LOGICAL C3LRSV, CC1ASV, CC1BSV 82 CHARACTER*10 MODEL 83 CHARACTER*(*) FNTOC, FN3VI, FN3VI2, FN3FOP, FN3FOP2 84C 85 PARAMETER (HALF = 0.5D0, ONE = 1.0D0, TWO = 2.0D0, ZERO = 0.0D0) 86C 87 CALL QENTER('CCSDPT_ETA') 88C 89C-------------------------- 90C Save and set flags. 91C-------------------------- 92C 93 C3LRSV = CC3LR 94 CC1ASV = CC1A 95 CC1BSV = CC1B 96 CC3LR = .FALSE. 97 CC1A = .TRUE. 98 CC1B = .TRUE. 99C 100C------------------------------------------------------------- 101C Set symmetry flags. 102C 103C omega = int1*T2*int2 104C isymres is symmetry of result(omega) 105C isint1 is symmetry of integrals in contraction.(int1) 106C isint2 is symmetry of integrals in the triples equation.(int2) 107C isymim is symmetry of S and Q intermediates.(t2*int2) 108C (sym is for all index of S and Q (cbd,klj) 109C thus cklj=b*d*isymim) 110C------------------------------------------------------------- 111C 112 IPRCC = IPRINT 113 ISYMTR = MULD2H(ISYMT1,ISYMT2) 114 ISYRES = MULD2H(ISYMTR,ISYMOP) 115 ISINT1 = ISYMOP 116 ISINT2 = MULD2H(ISYMT1,ISYMOP) 117 ISYMIM = MULD2H(ISYMTR,ISYMOP) 118C 119C-------------------- 120C Time variables. 121C-------------------- 122C 123 TITRAN = 0.0D0 124 TISORT = 0.0D0 125 TISMAT = 0.0D0 126 TIQMAT = 0.0D0 127 TICONO = 0.0D0 128 TICONV = 0.0D0 129 TIOME1 = 0.0D0 130C 131C-------------------------------------- 132C Reorder the t2-amplitudes i T2TP. 133C-------------------------------------- 134C 135 IF (LWORK .LT. NT2SQ(ISYMT2)) THEN 136 CALL QUIT('Not enough memory to construct T2TP in CC3_OMEG') 137 ENDIF 138C 139 CALL DCOPY(NT2SQ(ISYMT2),T2TP,1,WORK,1) 140 CALL CC3_T2TP(T2TP,WORK,ISYMT2) 141C 142 IF (IPRINT .GT. 55) THEN 143 XT2TP = DDOT(NT2SQ(ISYMT2),T2TP,1,T2TP,1) 144 WRITE(LUPRI,*) 'Norm of T2TP ',XT2TP 145 ENDIF 146C 147C--------------------------------------------------------- 148C Read canonical orbital energies and MO coefficients. 149C--------------------------------------------------------- 150C 151 KFOCKD = 1 152 KOMG1 = KFOCKD + NORBTS 153 KOMG22 = KOMG1 + NT1AM(ISYRES) 154 KCMO = KOMG22 + NT2AM(ISYRES) 155 KFCKBA = KCMO + NLAMDS 156 KEND0 = KFCKBA + N2BST(ISYMOP) 157 LWRK0 = LWORK - KEND0 158C 159 CALL DZERO(WORK(KOMG1),NT1AM(ISYRES)) 160 CALL DZERO(WORK(KOMG22),NT2AM(ISYRES)) 161C 162 IF (LWRK0 .LT. 0) THEN 163 WRITE(LUPRI,*) 'Memory available : ',LWORK 164 WRITE(LUPRI,*) 'Memory needed > ',KEND0 165 CALL QUIT('Insufficient space in CCSDT_OMEG') 166 END IF 167C 168 CALL GPOPEN(LUSIFC,'SIRIFC','OLD',' ','UNFORMATTED',IDUMMY, 169 & .FALSE.) 170 REWIND LUSIFC 171C 172 CALL MOLLAB('TRCCINT ',LUSIFC,LUPRI) 173 READ (LUSIFC) 174 READ (LUSIFC) (WORK(KFOCKD+I-1), I=1,NORBTS) 175 READ (LUSIFC) (WORK(KCMO+I-1), I=1,NLAMDS) 176C 177 CALL GPCLOSE(LUSIFC,'KEEP') 178C 179 CALL CMO_REORDER(WORK(KCMO),WORK(KEND0),LWRK0) 180C 181C--------------------------------------------- 182C Delete frozen orbitals in Fock diagonal. 183C--------------------------------------------- 184C 185 IF (FROIMP .OR. FROEXP) 186 * CALL CCSD_DELFRO(WORK(KFOCKD),WORK(KEND0),LWRK0) 187C 188C----------------------------------------------------- 189C Construct the CMO transformed Fock matrix 190C----------------------------------------------------- 191C 192 LUFCK = -1 193C This AO Fock matrix is constructed from the T1 transformed density 194C CALL GPOPEN(LUFCK,'CC_FCKH','UNKNOWN',' ','UNFORMATTED', 195C * IDUMMY,.FALSE.) 196C This AO Fock matrix is constructed from the CMO transformed density 197 CALL GPOPEN(LUFCK,'CC_FCKREF','UNKNOWN',' ','UNFORMATTED', 198 * IDUMMY,.FALSE.) 199 REWIND(LUFCK) 200 READ(LUFCK)(WORK(KFCKBA + I-1),I = 1,N2BST(ISYMOP)) 201 CALL GPCLOSE(LUFCK,'KEEP' ) 202C 203 IF (IPRINT .GT. 140) THEN 204 CALL AROUND( 'Usual Fock AO matrix' ) 205 CALL CC_PRFCKAO(WORK(KFCKBA),ISYMOP) 206 ENDIF 207C 208 ! SCF Fock matrix in transformed using CMO vector 209 CALL CC_FCKMO(WORK(KFCKBA),WORK(KCMO),WORK(KCMO), 210 * WORK(KEND0),LWRK0,1,1,1) 211C 212 IF (IPRINT .GT. 50) THEN 213 CALL AROUND( 'In CC_ETA: Triples Fock MO matrix' ) 214 CALL CC_PRFCKMO(WORK(KFCKBA),ISYMOP) 215 ENDIF 216C 217C Sort the fock matrix 218C 219C 220 CALL DCOPY(N2BST(ISINT1),WORK(KFCKBA),1,WORK(KEND0),1) 221C 222 DO ISYMC = 1,NSYM 223C 224 ISYMK = MULD2H(ISYMC,ISINT1) 225C 226 DO K = 1,NRHF(ISYMK) 227C 228 DO C = 1,NVIR(ISYMC) 229C 230 KOFF1 = KEND0 + IFCVIR(ISYMK,ISYMC) + 231 * NORB(ISYMK)*(C - 1) + K - 1 232 KOFF2 = KFCKBA + IT1AM(ISYMC,ISYMK) 233 * + NVIR(ISYMC)*(K - 1) + C - 1 234C 235 WORK(KOFF2) = WORK(KOFF1) 236C 237 ENDDO 238 ENDDO 239 ENDDO 240C 241 IF (IPRINT .GT. 50) THEN 242 CALL AROUND( 'In CC_ETA: Triples Fock MO matrix (sort)' ) 243 CALL CC_PRFCKMO(WORK(KFCKBA),ISYMOP) 244 ENDIF 245C 246C------------------------------------------------------------------ 247C Read in another T2 amplitude, and transform it to 2*C-E 248C Square up to full matrix and reorder the indexing 249C------------------------------------------------------------------ 250C 251 KT2TCME = KEND0 252 KEND0 = KT2TCME + NT2SQ(ISYMT2) 253 LWRK0 = LWORK - KEND0 254C 255 IF (LWRK0 .LT. NT2SQ(1)) 256 * CALL QUIT('Too litlle workspace CCSDPT_ETA T2') 257C 258 IOPTT2 = 2 259 CALL CC_RDRSP('R0',0,1,IOPTT2,MODEL,DUMMY,WORK(KEND0)) 260C 261 ISYOPE = ISYMT2 262 IOPTT2 = 1 263 CALL CCSD_TCMEPK(WORK(KEND0),1.0D0,ISYOPE,IOPTT2) 264C 265 CALL CC_T2SQ(WORK(KEND0),WORK(KT2TCME),ISYMT2) 266C 267 CALL DCOPY(NT2SQ(ISYMT2),WORK(KT2TCME),1,WORK(KEND0),1) 268 CALL CC3_T2TP(WORK(KT2TCME),WORK(KEND0),1) 269C 270 IF (IPRINT .GT. 55) THEN 271 XT2TP = DDOT(NT2SQ(ISYMT2),WORK(KT2TCME),1,WORK(KT2TCME),1) 272 WRITE(LUPRI,*) 'Norm of 2*C-E T2 amplitudes after resort ', 273 * XT2TP 274 ENDIF 275C 276C----------------------------- 277C Read occupied integrals. 278C----------------------------- 279C 280C Memory allocation. 281C 282 KTROC = KEND0 283 KTROC1 = KTROC + NTRAOC(ISINT1) 284 KTROC0 = KTROC1 + NTRAOC(ISINT1) 285 KTROC2 = KTROC0 + NTRAOC(ISINT2) 286 KXIAJB = KTROC2 + NTRAOC(ISINT2) 287 KEND1 = KXIAJB + NT2AM(ISYMOP) 288 LWRK1 = LWORK - KEND1 289C 290 KINTOC = KEND1 291 KEND2 = KINTOC + MAX(NTOTOC(ISYMOP),NTOTOC(ISINT2)) 292 LWRK2 = LWORK - KEND2 293C 294 IF (LWRK2 .LT. 0) THEN 295 WRITE(LUPRI,*) 'Memory available : ',LWORK 296 WRITE(LUPRI,*) 'Memory needed > ',KEND2 297 CALL QUIT('Insufficient space in CCSDT_OMEG') 298 END IF 299C 300C------------------------ 301C Construct L(ia,jb). 302C------------------------ 303C 304 LENGTH = IRAT*NT2AM(ISYMOP) 305C 306 REWIND(LUIAJB) 307 CALL READI(LUIAJB,LENGTH,WORK(KXIAJB)) 308C 309 ISYOPE = ISYMOP 310 IOPTTCME = 1 311 CALL CCSD_TCMEPK(WORK(KXIAJB),1.0D0,ISYOPE,IOPTTCME) 312C 313 IF ( IPRINT .GT. 55) THEN 314 XIAJB = DDOT(NT2AM(ISYMOP),WORK(KXIAJB),1, 315 * WORK(KXIAJB),1) 316 WRITE(LUPRI,*) 'Norm of IAJB ',XIAJB 317 ENDIF 318C 319C------------------------ 320C Occupied integrals. 321C------------------------ 322C 323 DTIME = SECOND() 324 IOFF = 1 325 IF (NTOTOC(ISYMOP) .GT. 0) THEN 326 CALL GETWA2(LUTOC,FNTOC,WORK(KINTOC),IOFF,NTOTOC(ISYMOP)) 327 ENDIF 328C 329C---------------------------------- 330C Write out norms of Integrals. 331C---------------------------------- 332C 333 IF (IPRINT .GT. 55) THEN 334 XINT = DDOT(NTOTOC(ISYMOP),WORK(KINTOC),1, 335 * WORK(KINTOC),1) 336 WRITE(LUPRI,*) 'Norm of CCSDT_OC-INT ',XINT 337 ENDIF 338C 339C---------------------------------------------------------------------- 340C Transform (ia|j delta) integrals to (ia|j k) and sort as (ij,k,a) 341C---------------------------------------------------------------------- 342C 343 DTIME = SECOND() - DTIME 344C 345 CALL CCSDT_TROCC(WORK(KINTOC),WORK(KTROC),WORK(KCMO), 346 * WORK(KEND2),LWRK2) 347C 348C---------------------------------------------------------------------- 349C Transform (ia|j delta) integrals to (ia|j k) and sort as (ij,k,a) 350C---------------------------------------------------------------------- 351C 352 DTIME = SECOND() 353 CALL CCSDT_TROCC(WORK(KINTOC),WORK(KTROC0),WORK(KCMO), 354 * WORK(KEND2),LWRK2) 355C 356 DTIME = SECOND() - DTIME 357 TITRAN = TITRAN + DTIME 358 359C 360 DTIME = SECOND() 361C 362 CALL CCSDT_SRTOC2(WORK(KTROC),WORK(KTROC1),ISINT1, 363 * WORK(KEND2),LWRK2) 364C 365 DTIME = SECOND() - DTIME 366 TISORT = TISORT + DTIME 367C 368C----------------------------------------------------------- 369C Construct 2*C-E for the occupied integrals. 370C----------------------------------------------------------- 371C 372 CALL CCSDT_TCMEOCC(WORK(KTROC0),WORK(KTROC2),ISINT2) 373C 374C------------------------------- 375C Write out norms of arrays. 376C------------------------------- 377C 378 IF (IPRINT .GT. 55) THEN 379 XTROC = DDOT(NTRAOC(ISINT1),WORK(KTROC),1, 380 * WORK(KTROC),1) 381 WRITE(LUPRI,*) 'Norm of TROC ',XTROC 382 ENDIF 383C 384 IF (IPRINT .GT. 55) THEN 385 XINT = DDOT(NTOTOC(ISINT2),WORK(KINTOC),1, 386 * WORK(KINTOC),1) 387 WRITE(LUPRI,*) 'Norm of CKJDEL-INT ',XINT 388 ENDIF 389C 390 IF (IPRINT .GT. 55) THEN 391 XTROC1 = DDOT(NTRAOC(ISINT1),WORK(KTROC1),1, 392 * WORK(KTROC1),1) 393 WRITE(LUPRI,*) 'Norm of TROC1 ',XTROC1 394 ENDIF 395C 396 IF (IPRINT .GT. 55) THEN 397 XTROC0 = DDOT(NTRAOC(ISINT2),WORK(KTROC0),1, 398 * WORK(KTROC0),1) 399 WRITE(LUPRI,*) 'Norm of TROC0 ',XTROC0 400 ENDIF 401C 402 IF (IPRINT .GT. 55) THEN 403 XTROC0 = DDOT(NTRAOC(ISINT2),WORK(KTROC2),1, 404 * WORK(KTROC2),1) 405 WRITE(LUPRI,*) 'Norm of TROC2 ',XTROC0 406 ENDIF 407C 408C---------------------------- 409C General loop structure. 410C---------------------------- 411C 412 DO ISYMD = 1,NSYM 413C 414 ISAIJ1 = MULD2H(ISYMD,ISYRES) 415 ISYCKB = MULD2H(ISYMD,ISYMOP) 416 ISCKB1 = MULD2H(ISINT1,ISYMD) 417 ISCKB2 = MULD2H(ISINT2,ISYMD) 418C 419 IF (IPRINT .GT. 55) THEN 420C 421 WRITE(LUPRI,*) 'In CCSDPT_ETA: ISAIJ1:',ISAIJ1 422 WRITE(LUPRI,*) 'In CCSDPT_ETA: ISYCKB:',ISYCKB 423 WRITE(LUPRI,*) 'In CCSDPT_ETA: ISCKB1:',ISCKB1 424 WRITE(LUPRI,*) 'In CCSDPT_ETA: ISCKB2:',ISCKB2 425C 426 ENDIF 427C 428C-------------------------- 429C Memory allocation. 430C-------------------------- 431C 432 KTRVI = KEND1 433 KTRVI1 = KTRVI + NCKATR(ISCKB1) 434 KTRVI2 = KTRVI1 + NCKATR(ISCKB1) 435 KRMAT1 = KTRVI2 + NCKATR(ISCKB2) 436 KRMAT3 = KRMAT1 + NCKI(ISAIJ1) 437 KEND2 = KRMAT3 + NCKI(ISAIJ1) 438 LWRK2 = LWORK - KEND2 439C 440 KTRVI0 = KEND2 441 KTRVI3 = KTRVI0 + NCKATR(ISCKB2) 442 KTRVI4 = KTRVI3 + NCKATR(ISCKB2) 443 KTRVI5 = KTRVI4 + NCKATR(ISCKB2) 444 KTRVI6 = KTRVI5 + NCKATR(ISCKB2) 445 KEND3 = KTRVI6 + NCKATR(ISCKB2) 446 LWRK3 = LWORK - KEND3 447C 448 KINTVI = KEND3 449 KEND4 = KINTVI + MAX(NCKA(ISYCKB),NCKA(ISYMD),NCKA(ISCKB2)) 450 LWRK4 = LWORK - KEND4 451C 452 IF (LWRK4 .LT. 0) THEN 453 WRITE(LUPRI,*) 'Memory available : ',LWORK 454 WRITE(LUPRI,*) 'Memory needed > ',KEND4 455 CALL QUIT('Insufficient space in CCSDT_OMEG') 456 END IF 457C 458 DO D = 1,NVIR(ISYMD) 459C 460C------------------------------------ 461C Initialize the R1 matrix. 462C------------------------------------ 463C 464 CALL DZERO(WORK(KRMAT1),NCKI(ISAIJ1)) 465 CALL DZERO(WORK(KRMAT3),NCKI(ISAIJ1)) 466C 467C------------------------------------------------------------ 468C Read and transform integrals used in contraction. 469C------------------------------------------------------------ 470C 471 IOFF = ICKAD(ISYCKB,ISYMD) + NCKA(ISYCKB)*(D - 1) + 1 472 IF (NCKA(ISYCKB) .GT. 0) THEN 473 CALL GETWA2(LU3VI2,FN3VI2,WORK(KINTVI),IOFF, 474 & NCKA(ISYCKB)) 475 ENDIF 476C 477 CALL CCSDT_TRVIR(WORK(KINTVI),WORK(KTRVI),WORK(KCMO), 478 * ISYMD,D,ISYMOP,WORK(KEND4),LWRK4) 479C 480C------------------------------------------------------- 481C Calculate virtual integrals used in s3am. 482C------------------------------------------------------- 483C 484 CALL CCSDT_TRVIR(WORK(KINTVI),WORK(KTRVI0),WORK(KCMO), 485 * ISYMD,D,ISYMOP,WORK(KEND4),LWRK4) 486C 487C------------------------------------------------------ 488C Read 2*C-E of integral used for t3-bar 489C------------------------------------------------------ 490C 491 IOFF = ICKAD(ISYCKB,ISYMD) + NCKA(ISYCKB)*(D - 1) + 1 492 IF (NCKA(ISYCKB) .GT. 0) THEN 493 CALL GETWA2(LU3FOP2,FN3FOP2,WORK(KINTVI),IOFF, 494 & NCKA(ISYCKB)) 495 ENDIF 496C 497 CALL CCSDT_TRVIR(WORK(KINTVI),WORK(KTRVI4),WORK(KCMO), 498 * ISYMD,D,ISYMOP,WORK(KEND4),LWRK4) 499C 500C----------------------------------------------------------- 501C Sort the integrals for s3am and for t3-bar 502C----------------------------------------------------------- 503C 504 DTIME = SECOND() 505 CALL CCSDT_SRTVIR(WORK(KTRVI0),WORK(KTRVI2),WORK(KEND4), 506 * LWRK4,ISYMD,ISINT2) 507C 508 CALL CCSDT_SRTVIR(WORK(KTRVI4),WORK(KTRVI5),WORK(KEND4), 509 * LWRK4,ISYMD,ISINT2) 510C 511 DTIME = SECOND() - DTIME 512 TISORT = TISORT + DTIME 513C 514 IF (IPRINT .GT. 55) THEN 515 XTRVI0= DDOT(NCKATR(ISCKB2),WORK(KTRVI0),1, 516 * WORK(KTRVI0),1) 517 WRITE(LUPRI,*) 'Norm of TRVI0 ',XTRVI0 518 ENDIF 519C 520 IF (IPRINT .GT. 55) THEN 521 XTRVI2= DDOT(NCKATR(ISCKB2),WORK(KTRVI2),1, 522 * WORK(KTRVI2),1) 523 WRITE(LUPRI,*) 'Norm of TRVI2 ',XTRVI2 524 ENDIF 525C 526 IF (IPRINT .GT. 55) THEN 527 XTRVI0= DDOT(NCKATR(ISCKB2),WORK(KTRVI4),1, 528 * WORK(KTRVI4),1) 529 WRITE(LUPRI,*) 'Norm of TRVI4 ',XTRVI0 530 ENDIF 531C 532 IF (IPRINT .GT. 55) THEN 533 XTRVI2= DDOT(NCKATR(ISCKB2),WORK(KTRVI5),1, 534 * WORK(KTRVI5),1) 535 WRITE(LUPRI,*) 'Norm of TRVI5 ',XTRVI2 536 ENDIF 537C 538C------------------------------------------------------ 539C Read virtual integrals used in contraction. 540C------------------------------------------------------ 541C 542 IOFF = ICKAD(ISYCKB,ISYMD) + NCKA(ISYCKB)*(D - 1) + 1 543 IF (NCKA(ISYCKB) .GT. 0) THEN 544 CALL GETWA2(LU3VI,FN3VI,WORK(KINTVI),IOFF, 545 & NCKA(ISYCKB)) 546 ENDIF 547C 548 CALL CCSDT_TRVIR(WORK(KINTVI),WORK(KTRVI1),WORK(KCMO), 549 * ISYMD,D,ISYMOP,WORK(KEND4),LWRK4) 550C 551C-------------------------------------------------------- 552C Calculate virtual integrals used in q3am. 553C-------------------------------------------------------- 554C 555C 556 CALL CCSDT_TRVIR(WORK(KINTVI),WORK(KTRVI3),WORK(KCMO), 557 * ISYMD,D,ISYMOP,WORK(KEND4),LWRK4) 558C 559 IF (LWRK3 .LT. NCKATR(ISYCKB)) THEN 560 CALL QUIT('Insufficient space for allocation in '// 561 & 'CCSDPT_ETA (1)') 562 END IF 563C 564C Can use kend3 since dont need the integrals anymore 565 DTIME = SECOND() 566 CALL CCSDT_SRVIR3(WORK(KTRVI3),WORK(KEND3),ISYMD,D,ISINT2) 567C 568 DTIME = SECOND() - DTIME 569 TISORT = TISORT + DTIME 570C 571 IF (IPRINT .GT. 55) THEN 572 XTRVI3= DDOT(NCKATR(ISCKB2),WORK(KTRVI3),1, 573 * WORK(KTRVI3),1) 574 WRITE(LUPRI,*) 'Norm of TRVI3 ',XTRVI3 575 ENDIF 576C 577C--------------------------------------------------------------- 578C Read virtual integrals used in q3am for t3-bar. 579C--------------------------------------------------------------- 580C 581 IOFF = ICKAD(ISYCKB,ISYMD) + NCKA(ISYCKB)*(D - 1) + 1 582 IF (NCKA(ISYCKB) .GT. 0) THEN 583 CALL GETWA2(LU3FOP,FN3FOP,WORK(KINTVI),IOFF, 584 & NCKA(ISYCKB)) 585 ENDIF 586C 587 CALL CCSDT_TRVIR(WORK(KINTVI),WORK(KTRVI6),WORK(KCMO), 588 * ISYMD,D,ISYMOP,WORK(KEND4),LWRK4) 589C 590 IF (LWRK3 .LT. NCKATR(ISYCKB)) THEN 591 CALL QUIT('Insufficient space for allocation in '// 592 & 'CCSDPT_ETA (2)') 593 END IF 594C 595C Can use kend3 since dont need the integrals anymore 596 DTIME = SECOND() 597 CALL CCSDT_SRVIR3(WORK(KTRVI6),WORK(KEND4),ISYMD,D,ISINT2) 598C 599 DTIME = SECOND() - DTIME 600 TISORT = TISORT + DTIME 601C 602 IF (IPRINT .GT. 55) THEN 603 XTRVI3= DDOT(NCKATR(ISCKB2),WORK(KTRVI6),1, 604 * WORK(KTRVI6),1) 605 WRITE(LUPRI,*) 'Norm of TRVI6 ',XTRVI3 606 ENDIF 607C 608C--------------------------------------------- 609C Construct integrals used in CC3LR. 610C--------------------------------------------- 611C 612 IF (IPRINT .GT. 55) THEN 613 XTRVI= DDOT(NCKATR(ISCKB1),WORK(KTRVI),1, 614 * WORK(KTRVI),1) 615 WRITE(LUPRI,*) 'Norm of TRVI ',XTRVI 616 ENDIF 617C 618 IF (IPRINT .GT. 55) THEN 619 XTRVI1= DDOT(NCKATR(ISCKB1),WORK(KTRVI1),1, 620 * WORK(KTRVI1),1) 621 WRITE(LUPRI,*) 'Norm of TRVI1 ',XTRVI1 622 ENDIF 623C 624C--------------------- 625C Calculate. 626C--------------------- 627C 628 DO ISYMB = 1,NSYM 629C 630 ISYALJ = MULD2H(ISYMB,ISYMT2) 631 ISAIJ2 = MULD2H(ISYMB,ISYRES) 632 ISYMBD = MULD2H(ISYMB,ISYMD) 633 ISCKIJ = MULD2H(ISYMBD,ISYMIM) 634C 635 IF (IPRINT .GT. 55) THEN 636C 637 WRITE(LUPRI,*) 'In CC3_OMEG: ISYMD :',ISYMD 638 WRITE(LUPRI,*) 'In CC3_OMEG: ISYMB :',ISYMB 639 WRITE(LUPRI,*) 'In CC3_OMEG: ISYALJ:',ISYALJ 640 WRITE(LUPRI,*) 'In CC3_OMEG: ISAIJ2:',ISAIJ2 641 WRITE(LUPRI,*) 'In CC3_OMEG: ISYMBD:',ISYMBD 642 WRITE(LUPRI,*) 'In CC3_OMEG: ISCKIJ:',ISCKIJ 643C 644 ENDIF 645C 646 KSMAT = KEND3 647 KQMAT = KSMAT + NCKIJ(ISCKIJ) 648 KSMAT2 = KQMAT + NCKIJ(ISCKIJ) 649 KQMAT2 = KSMAT2 + NCKIJ(ISCKIJ) 650 KDIAG = KQMAT2 + NCKIJ(ISCKIJ) 651 KINDSQ = KDIAG + NCKIJ(ISCKIJ) 652 KINDEX = KINDSQ + (6*NCKIJ(ISCKIJ) - 1)/IRAT + 1 653 KTMAT = KINDEX + (NCKI(ISYALJ) - 1)/IRAT + 1 654 KRMAT2 = KTMAT + NCKIJ(ISCKIJ) 655 KRMAT4 = KRMAT2 + NCKI(ISAIJ2) 656 KEND4 = KRMAT4 + NCKI(ISAIJ2) 657 LWRK4 = LWORK - KEND4 658C 659 IF (LWRK4 .LT. 0) THEN 660 WRITE(LUPRI,*) 'Memory available : ',LWORK 661 WRITE(LUPRI,*) 'Memory needed > ',KEND4 662 CALL QUIT('Insufficient space in CCSDT_OMEG') 663 END IF 664C 665C--------------------------------------------- 666C Construct part of the diagonal. 667C--------------------------------------------- 668C 669 CALL CC3_DIAG(WORK(KDIAG),WORK(KFOCKD),ISCKIJ) 670C 671 IF (IPRINT .GT. 55) THEN 672 XDIA = DDOT(NCKIJ(ISCKIJ),WORK(KDIAG),1, 673 * WORK(KDIAG),1) 674 WRITE(LUPRI,*) 'Norm of DIA ',XDIA 675 ENDIF 676 677C 678C------------------------------------- 679C Construct index arrays. 680C------------------------------------- 681C 682 LENSQ = NCKIJ(ISCKIJ) 683 CALL CC3_INDSQ(WORK(KINDSQ),LENSQ,ISCKIJ) 684 CALL CC3_INDEX(WORK(KINDEX),ISYALJ) 685C 686 DO B = 1,NVIR(ISYMB) 687C 688C----------------------------------------- 689C Initialize the R2 matrix. 690C----------------------------------------- 691C 692 CALL DZERO(WORK(KRMAT2),NCKI(ISAIJ2)) 693 CALL DZERO(WORK(KRMAT4),NCKI(ISAIJ2)) 694C 695C------------------------------------------------------------- 696C Calculate the S(ci,bk,dj) matrix for T3. 697C------------------------------------------------------------- 698C 699 DTIME = SECOND() 700 CALL CC3_SMAT(0.0D0,T2TP,ISYMT2,WORK(KTMAT), 701 * WORK(KTRVI0), 702 * WORK(KTRVI2),WORK(KTROC0),ISINT2, 703 * WORK(KFOCKD),WORK(KDIAG), 704 * WORK(KSMAT),WORK(KEND4),LWRK4, 705 * WORK(KINDEX),WORK(KINDSQ),LENSQ, 706 * ISYMB,B,ISYMD,D) 707C 708 DTIME = SECOND() - DTIME 709 TISMAT = TISMAT + DTIME 710C 711 IF (IPRINT .GT. 55) THEN 712 XSMAT = DDOT(NCKIJ(ISCKIJ),WORK(KSMAT),1, 713 * WORK(KSMAT),1) 714 WRITE(LUPRI,*) 'Norm of SMAT ',XSMAT 715 ENDIF 716C 717 IF (IPRINT .GT. 55) THEN 718 XTMAT = DDOT(NCKIJ(ISCKIJ),WORK(KTMAT),1, 719 * WORK(KTMAT),1) 720 WRITE(LUPRI,*) 'Norm of TMAT ',XTMAT 721 ENDIF 722C 723C--------------------------------------------------------------- 724C Calculate the S(ci,bk,dj) matrix for T3-BAR. 725C--------------------------------------------------------------- 726C 727 DTIME = SECOND() 728C 729 CALL DZERO(WORK(KSMAT2),NCKIJ(ISCKIJ)) 730C 731 CALL CCFOP_SMAT(0.0D0,T1AM,ISYMT1,WORK(KT2TCME), 732 * ISYMT2,WORK(KTMAT), 733 * WORK(KFCKBA),WORK(KXIAJB),ISINT1, 734 * WORK(KTRVI0),WORK(KTRVI2), 735 * WORK(KTRVI4),WORK(KTRVI5), 736 * WORK(KTROC0),WORK(KTROC2), 737 * ISINT2,WORK(KFOCKD), 738 * WORK(KDIAG),WORK(KSMAT2),WORK(KEND4), 739 * LWRK4,WORK(KINDEX),WORK(KINDSQ),LENSQ, 740 * ISYMB,B,ISYMD,D) 741C 742 DTIME = SECOND() - DTIME 743 TISMAT = TISMAT + DTIME 744C 745 IF (IPRINT .GT. 55) THEN 746 XSMAT = DDOT(NCKIJ(ISCKIJ),WORK(KSMAT2),1, 747 * WORK(KSMAT2),1) 748 WRITE(LUPRI,*) 'Norm of SMAT2 ',XSMAT 749 ENDIF 750C 751 IF (IPRINT .GT. 55) THEN 752 XTMAT = DDOT(NCKIJ(ISCKIJ),WORK(KTMAT),1, 753 * WORK(KTMAT),1) 754 WRITE(LUPRI,*) 'Norm of TMAT ',XTMAT 755 ENDIF 756C 757C-------------------------------------------------- 758C Calculate Q(ci,jk) for fixed b,d. 759C-------------------------------------------------- 760C 761 DTIME = SECOND() 762 CALL CC3_QMAT(0.0D0,T2TP,ISYMT2,WORK(KTRVI3), 763 * WORK(KTROC0),ISINT2,WORK(KFOCKD), 764 * WORK(KDIAG),WORK(KQMAT), 765 * WORK(KEND4),LWRK4,WORK(KINDSQ),LENSQ, 766 * ISYMB,B,ISYMD,D) 767C 768 DTIME = SECOND() - DTIME 769 TIQMAT = TIQMAT + DTIME 770C 771 IF (IPRINT .GT. 55) THEN 772 XQMAT = DDOT(NCKIJ(ISCKIJ),WORK(KQMAT),1, 773 * WORK(KQMAT),1) 774 WRITE(LUPRI,*) 'Norm of QMAT ',XQMAT 775 ENDIF 776C 777C------------------------------------------------------------------- 778C Calculate Q(ci,jk) for fixed b,d for t3-bar. 779C------------------------------------------------------------------- 780C 781 DTIME = SECOND() 782C 783 CALL DZERO(WORK(KQMAT2),NCKIJ(ISCKIJ)) 784C 785 CALL CCFOP_QMAT(0.0D0,T1AM,ISYMT1,WORK(KT2TCME), 786 * ISYMT2,WORK(KTMAT),WORK(KFCKBA), 787 * WORK(KXIAJB),ISINT1,WORK(KTRVI3), 788 * WORK(KTRVI6),WORK(KTROC0), 789 * WORK(KTROC2),ISINT2,WORK(KFOCKD), 790 * WORK(KDIAG),WORK(KQMAT2), 791 * WORK(KEND4),LWRK4,WORK(KINDSQ), 792 * LENSQ,ISYMB,B,ISYMD,D) 793C 794 DTIME = SECOND() - DTIME 795 TIQMAT = TIQMAT + DTIME 796C 797 IF (IPRINT .GT. 55) THEN 798 XQMAT = DDOT(NCKIJ(ISCKIJ),WORK(KQMAT),1, 799 * WORK(KQMAT),1) 800 WRITE(LUPRI,*) 'Norm of QMAT ',XQMAT 801 ENDIF 802C 803C----------------------------------------- 804C Contract with integrals. 805C----------------------------------------- 806C 807 DTIME = SECOND() 808 CALL CC3_CONVIR(WORK(KRMAT2),WORK(KSMAT), 809 * WORK(KQMAT),WORK(KTMAT),ISYMIM, 810 * WORK(KTRVI),WORK(KTRVI1),ISINT1, 811 * WORK(KEND4),LWRK4, 812 * WORK(KINDSQ),LENSQ,ISYMB,B,ISYMD,D) 813 IF (IPRINT .GT. 55) THEN 814 XRMAT = DDOT(NCKI(ISAIJ2),WORK(KRMAT2),1, 815 * WORK(KRMAT2),1) 816 WRITE(LUPRI,*) 'Norm RMAT2 - CC3_CONVIR',XRMAT 817 ENDIF 818C 819 CALL CCFOP_CONVIR(WORK(KRMAT4),WORK(KSMAT2), 820 * WORK(KQMAT2),WORK(KTMAT),ISYMIM, 821 * WORK(KTRVI),WORK(KTRVI1),ISINT1, 822 * WORK(KEND4),LWRK4,WORK(KINDSQ), 823 * LENSQ,ISYMB,B,ISYMD,D) 824C 825 IF (IPRINT .GT. 55) THEN 826 XRMAT = DDOT(NCKI(ISAIJ2),WORK(KRMAT4),1, 827 * WORK(KRMAT4),1) 828 WRITE(LUPRI,*) 'Norm RMAT4 - CCFOP_CONVIR ',XRMAT 829 ENDIF 830C 831 DTIME = SECOND() - DTIME 832 TICONV = TICONV + DTIME 833C 834 DTIME = SECOND() 835 CALL CC3_CONOCC(WORK(KOMG22),WORK(KRMAT1),WORK(KRMAT2) 836 * ,WORK(KSMAT),WORK(KTMAT),ISYMIM, 837 * WORK(KTROC),WORK(KTROC1),ISINT1, 838 * WORK(KEND4),LWRK4, 839 * WORK(KINDSQ),LENSQ,ISYMB,B,ISYMD,D) 840C 841 IF (IPRINT .GT. 55) THEN 842 XRMAT = DDOT(NCKI(ISAIJ1),WORK(KRMAT1),1, 843 * WORK(KRMAT1),1) 844 WRITE(LUPRI,*) 'Norm of RMAT1 - CC3_CONOCC ',XRMAT 845 XRMAT = DDOT(NCKI(ISAIJ2),WORK(KRMAT2),1, 846 * WORK(KRMAT2),1) 847 WRITE(LUPRI,*) 'Norm of RMAT2 - CC3_CONOCC',XRMAT 848 RHO2N = DDOT(NT2AM(ISYRES),WORK(KOMG22),1, 849 * WORK(KOMG22),1) 850 WRITE(LUPRI,*) 'Norm of Rho2 -after CC3_CONOCC', 851 * RHO2N 852 ENDIF 853C 854 IF (IPRINT .GT. 220) THEN 855 CALL AROUND('After CC3_CONOCC: ') 856 CALL CC_PRP(OMEGA1,WORK(KOMG22),ISYRES,0,1) 857 ENDIF 858C 859 DTIME = SECOND() 860 CALL CCFOP_CONOCC(OMEGA2,WORK(KRMAT3), 861 * WORK(KRMAT4),WORK(KSMAT2), 862 * WORK(KTMAT),ISYMIM, 863 * WORK(KTROC),WORK(KTROC1),ISINT1, 864 * WORK(KEND4),LWRK4,WORK(KINDSQ), 865 * LENSQ,ISYMB,B,ISYMD,D) 866C 867 IF (IPRINT .GT. 55) THEN 868 XRMAT = DDOT(NCKI(ISAIJ1),WORK(KRMAT3),1, 869 * WORK(KRMAT3),1) 870 WRITE(LUPRI,*) 'Norm RMAT3 - CCFOP_CONOCC ',XRMAT 871 XRMAT = DDOT(NCKI(ISAIJ2),WORK(KRMAT4),1, 872 * WORK(KRMAT4),1) 873 WRITE(LUPRI,*) 'Norm RMAT4 - CCFOP_CONOCC',XRMAT 874 RHO2N = DDOT(NT2AM(ISYRES),WORK(KOMG22),1, 875 * WORK(KOMG22),1) 876 WRITE(LUPRI,*) 'Norm of Rho2 -after CCFOP_CONOCC', 877 * RHO2N 878 ENDIF 879C 880 IF (IPRINT .GT. 220) THEN 881 CALL AROUND('After CCFOP_CONOCC: ') 882 CALL CC_PRP(OMEGA1,OMEGA2,ISYRES,0,1) 883 ENDIF 884C 885 DTIME = SECOND() - DTIME 886 TICONO = TICONO + DTIME 887C 888C---------------------------------- 889C Calculate Omega1. 890C---------------------------------- 891C 892 DTIME = SECOND() 893C 894 CALL CC3_ONEL(WORK(KOMG1),WORK(KOMG22),WORK(KRMAT1), 895 * WORK(KRMAT2),WORK(KFCKBA),WORK(KSMAT), 896 * WORK(KTMAT),ISYMIM,WORK(KXIAJB),ISINT1, 897 * WORK(KINDSQ),LENSQ,WORK(KEND4),LWRK4, 898 * ISYMB,B,ISYMD,D) 899C 900 IF (IPRINT .GT. 55) THEN 901 RHO1N = DDOT(NT1AM(ISYRES),OMEGA1,1,OMEGA1,1) 902 RHO2N = DDOT(NT2AM(ISYRES),WORK(KOMG22),1, 903 * WORK(KOMG22),1) 904 WRITE(LUPRI,*) 'Norm of Rho1 -after CC3_ONEL',RHO1N 905 WRITE(LUPRI,*) 'Norm of Rho2 -after CC3_ONEL',RHO2N 906 ENDIF 907C 908 IF (IPRINT .GT. 220) THEN 909 CALL AROUND('After CC3_ONEL: ') 910 CALL CC_PRP(OMEGA1,WORK(KOMG22),ISYRES,1,1) 911 ENDIF 912C 913 IF (IPRINT .GT. 55) THEN 914 XRMAT = DDOT(NCKI(ISAIJ1),WORK(KRMAT1),1, 915 * WORK(KRMAT1),1) 916 WRITE(LUPRI,*) 'Norm of RMAT1 -after ONEL',XRMAT 917 XRMAT = DDOT(NCKI(ISAIJ2),WORK(KRMAT2),1, 918 * WORK(KRMAT2),1) 919 WRITE(LUPRI,*) 'Norm of RMAT2 -after ONEL',XRMAT 920 ENDIF 921C 922C 923 DTIME = SECOND() - DTIME 924 TIOME1 = TIOME1 + DTIME 925C 926C--------------------------------------------------------- 927C Accumulate the R2 matrix in Omg22 and 928C R4 in OMEGA2. 929C--------------------------------------------------------- 930C 931 CALL CC3_RACC(WORK(KOMG22),WORK(KRMAT2),ISYMB,B, 932 * ISYRES) 933 CALL CC3_RACC(OMEGA2,WORK(KRMAT4),ISYMB,B, 934 * ISYRES) 935C 936 IF (IPRINT .GT. 55) THEN 937 RHO1N = DDOT(NT1AM(ISYRES),OMEGA1,1,OMEGA1,1) 938 RHO2N = DDOT(NT2AM(ISYRES),OMEGA2,1,OMEGA2,1) 939 WRITE(LUPRI,*) 'Norm of Rho1 -after CC3_RACC',RHO1N 940 WRITE(LUPRI,*) 'Norm of Rho2 -after CC3_RACC',RHO2N 941 RHO2N = DDOT(NT2AM(ISYRES),WORK(KOMG22),1, 942 * WORK(KOMG22),1) 943 WRITE(LUPRI,*) 'Norm of Rho22-after CC3_RACC',RHO2N 944 ENDIF 945C 946 IF (IPRINT .GT. 220) THEN 947 CALL AROUND('After CC3_RACC: ') 948 CALL CC_PRP(OMEGA1,WORK(KOMG22),ISYRES,1,1) 949 ENDIF 950C 951 ENDDO ! B 952 ENDDO ! ISYMB 953C 954C--------------------------------------------------- 955C Accumulate the R1 matrix in Omega22 and 956C R3 in Omega2. 957C--------------------------------------------------- 958C 959 CALL CC3_RACC(WORK(KOMG22),WORK(KRMAT1),ISYMD,D,ISYRES) 960 CALL CC3_RACC(OMEGA2,WORK(KRMAT3),ISYMD,D,ISYRES) 961C 962 IF (IPRINT .GT. 55) THEN 963 RHO1N = DDOT(NT1AM(ISYRES),OMEGA1,1,OMEGA1,1) 964 RHO2N = DDOT(NT2AM(ISYRES),OMEGA2,1,OMEGA2,1) 965 WRITE(LUPRI,*) 'Norm of Rho1 -after CC3_RACC-2',RHO1N 966 WRITE(LUPRI,*) 'Norm of Rho2 -after CC3_RACC-2',RHO2N 967 RHO2N = DDOT(NT2AM(ISYRES),WORK(KOMG22),1,WORK(KOMG22),1) 968 WRITE(LUPRI,*) 'Norm of Rho22-after CC3_RACC-2',RHO2N 969 ENDIF 970C 971 IF (IPRINT .GT. 220) THEN 972 CALL AROUND('After CC3_RACC-2: ') 973 CALL CC_PRP(OMEGA1,WORK(KOMG22),ISYRES,1,1) 974 ENDIF 975C 976 ENDDO ! D 977 ENDDO ! ISYMD 978C 979C----------------------------------------------- 980C Scale the one-electron result vector with 981C two since t1* = 2 t1 and add to real 982C result vector. 983C----------------------------------------------- 984C 985 CALL DAXPY(NT1AM(ISYRES),TWO,WORK(KOMG1),1,OMEGA1,1) 986C 987C---------------------------------------------------------------- 988C Take two times (two coulomb minus exchange) in 989C the double result vector from the normal T3 amplitudes 990C and sum up in Omega2 991C---------------------------------------------------------------- 992C 993 CALL DSCAL(NT2AM(ISYRES),TWO,WORK(KOMG22),1) 994C 995 IOPTTCME = 1 996 ISYOPE = ISYRES 997 CALL CCSD_TCMEPK(WORK(KOMG22),1.0D0,ISYOPE,IOPTTCME) 998C 999 CALL DAXPY(NT2AM(ISYRES),ONE,WORK(KOMG22),1,OMEGA2,1) 1000C 1001 IF (IPRINT .GT. 110) THEN 1002 CALL AROUND('Omega1 and Omega2 at the end of CCSDPT_ETA') 1003 CALL CC_PRP(OMEGA1,OMEGA2,ISYRES,1,1) 1004 ENDIF 1005C 1006C----------------------- 1007C Restore flags. 1008C----------------------- 1009C 1010 CC3LR = C3LRSV 1011 CC1A = CC1ASV 1012 CC1B = CC1BSV 1013C 1014C------------------- 1015C Print timings. 1016C------------------- 1017C 1018 IF (IPRINT .GT. 9) THEN 1019COMMENT COMMENT 1020COMMENT COMMENT Have a look at the timings in this routine. 1021COMMENT COMMENT 1022 WRITE(LUPRI,*) 1023 WRITE(LUPRI,*) 1024 WRITE(LUPRI,1) 'CC3_TRAN : ',TITRAN 1025 WRITE(LUPRI,1) 'CC3_SORT : ',TISORT 1026 WRITE(LUPRI,1) 'CC3_SMAT : ',TISMAT 1027 WRITE(LUPRI,1) 'CC3_QMAT : ',TIQMAT 1028 WRITE(LUPRI,1) 'CC3_CONV : ',TICONV 1029 WRITE(LUPRI,1) 'CC3_CONO : ',TICONO 1030 WRITE(LUPRI,1) 'CC3_OME1 : ',TIOME1 1031 WRITE(LUPRI,*) 1032 END IF 1033C 1034C------------- 1035C End 1036C------------- 1037C 1038 CALL QEXIT('CCSDPT_ETA') 1039C 1040 RETURN 1041C 1042 1 FORMAT(7X,'Time used in',2X,A12,F12.2,' seconds') 1043C 1044 END 1045C /* Deck ccfop_smat */ 1046 SUBROUTINE CCFOP_SMAT(ECURR,T1AM,ISYMT1,T2TCME,ISYMT2,TMAT,FOCK, 1047 * XIAJB, 1048 * ISINT1,TRVIR,TRVIR2,TRVIR4,TRVIR5,TROCC, 1049 * TROCC2,ISINT2,FOCKD,DIAG,SMAT,WORK,LWORK, 1050 * INDAJL,INDSQ,LENSQ,ISYMB,B,ISYMC,C) 1051C 1052C Written by Kasper Hald, Fall 2001. 1053C 1054C Calculate the S matrix for the t3-bar coefficients 1055C in the CCSD(T) model. 1056C 1057C S is stored as S(ai,k,j) for fixed b and c 1058C (kc|bd) is stored as I(dk,b,c) 1059C 1060C T2TCME is two times coulomb minus exchange of the T2 ampl. 1061C IN TRVIR, TRVIR2 and TROCC are the normal integrals 1062C IN TRVIR4, TRVIR5 and TROCC2 are the integrals transformed to 2*C-E 1063C 1064C General symmetry: ISINT1 / ISINT2 is symmetry of integrals 1065C ISYMT1 / ISYMT2 is symmetry of T1AM / (T2TP,T2TCME). 1066C 1067 IMPLICIT NONE 1068C 1069#include "priunit.h" 1070#include "ccorb.h" 1071#include "ccsdinp.h" 1072#include "ccsdsym.h" 1073C 1074 INTEGER ISYMT1, ISYMT2, ISINT1, LWORK, LENSQ, ISYMB, ISYMC 1075 INTEGER ISINT2, ISYMBC, ISYRES, JSAIKJ, ISYMDK, LENGTH, ISYMK 1076 INTEGER ISYMD, ISYAIJ, KOFF1, KOFF2, KOFF3, NTOAIJ, NVIRD, ISYAKD 1077 INTEGER ISYDIJ, ISYMJ, ISYMDI, ISYMI, ISYMAK, ISYAKI, NTOTAK 1078 INTEGER ISYAIL, ISYLKJ, ISYMLK, ISYML, ISYMAI, ISYAIK, NTOTAI 1079 INTEGER NRHFL, ISYAJL, ISYLKI, KOFF, ISYMAJ, ISYAJK, NTOTAJ 1080 INTEGER NB, NC, ISYMA, ISYRES2 1081 INTEGER ISYMJK, ISYMCK, NBJ, NKJ, NCK, NCKBJ, ISYMBJ 1082 INTEGER NAI, NAIKJ, NAIK, NAICK, NAIBJ, NCKTEMP, NAIKJTEMP 1083 INTEGER ISYMBI, NBI, NAJ, NAJBI 1084 INTEGER INDEX, INDAJL, INDSQ(LENSQ,6) 1085C 1086#if defined (SYS_CRAY) 1087 REAL T1AM(*), TMAT(*), XIAJB(*), FOCK(*) 1088 REAL TRVIR(*), TRVIR2(*), TROCC(*), FOCKD(*), DIAG(*) 1089 REAL SMAT(*), WORK(LWORK), XSMAT, EPSIBC, T2TCME(*) 1090 REAL TROCC2(*), TRVIR4(*), TRVIR5(*) 1091 REAL ZERO, ONE, TWO, FOUR, ECURR 1092 REAL DDOT 1093#else 1094 DOUBLE PRECISION T1AM(*), TMAT(*), XIAJB(*), FOCK(*) 1095 DOUBLE PRECISION TRVIR(*), TRVIR2(*), TROCC(*), FOCKD(*), DIAG(*) 1096 DOUBLE PRECISION SMAT(*), WORK(LWORK), XSMAT, EPSIBC, T2TCME(*) 1097 DOUBLE PRECISION TROCC2(*), TRVIR4(*), TRVIR5(*) 1098 DOUBLE PRECISION ZERO, ONE, TWO, FOUR, ECURR 1099 DOUBLE PRECISION DDOT 1100#endif 1101C 1102 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, FOUR = 4.0D0) 1103C 1104 INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 1105C 1106 CALL QENTER('CCFOP_SMAT') 1107C 1108 ISYRES = MULD2H(ISYMT1,ISINT1) 1109 ISYRES2 = MULD2H(ISYMT2,ISINT2) 1110C 1111 IF (ISYRES .NE. ISYRES2) 1112 * CALL QUIT('Symmetry mismatch in CCFOP_SMAT') 1113C 1114 ISYMBC = MULD2H(ISYMB,ISYMC) 1115 JSAIKJ = MULD2H(ISYRES,ISYMBC) 1116 LENGTH = NCKIJ(JSAIKJ) 1117C 1118C-------------------------------------------- 1119C First contribution from both T1 terms 1120C-------------------------------------------- 1121C 1122 ISYMJK = MULD2H(ISYMBC,ISINT1) 1123C 1124 if (.true.) then 1125C---------------------------------------------- 1126C Sort integrals for constant B and C 1127C---------------------------------------------- 1128C 1129 IF (LWORK .LT. NMATIJ(ISYMJK)) THEN 1130 CALL QUIT('Too little workspace in CCFOP_SMAT') 1131 ENDIF 1132C 1133 DO ISYMJ = 1, NSYM 1134C 1135 ISYMK = MULD2H(ISYMJK,ISYMJ) 1136 ISYMCK = MULD2H(ISYMC,ISYMK) 1137 ISYMBJ = MULD2H(ISYMB,ISYMJ) 1138C 1139 DO J = 1, NRHF(ISYMJ) 1140C 1141 NBJ = IT1AM(ISYMB,ISYMJ) + NVIR(ISYMB)*(J-1) + B 1142C 1143 DO K = 1, NRHF(ISYMK) 1144C 1145 NKJ = IMATIJ(ISYMK,ISYMJ)+ NRHF(ISYMK)*(J - 1) + K 1146 NCK = IT1AM(ISYMC,ISYMK) + NVIR(ISYMC)*(K - 1) + C 1147C 1148 NCKBJ = IT2AM(ISYMCK,ISYMBJ) + INDEX(NCK,NBJ) 1149C 1150 WORK(NKJ) = XIAJB(NCKBJ) 1151C 1152 ENDDO ! K 1153 ENDDO ! J 1154 ENDDO ! ISYMJ 1155C 1156C--------------------------------------- 1157C Contract the integrals with T1. 1158C--------------------------------------- 1159C 1160 CALL DZERO(TMAT,LENGTH) 1161C 1162 ISYMAI = ISYMT1 1163 DO ISYMJ = 1, NSYM 1164 ISYMK = MULD2H(ISYMJK,ISYMJ) 1165 ISYAIK = MULD2H(ISYMK,ISYMAI) 1166C 1167 DO J = 1, NRHF(ISYMJ) 1168 DO K = 1, NRHF(ISYMK) 1169C 1170 NKJ = IMATIJ(ISYMK,ISYMJ)+ NRHF(ISYMK)*(J - 1) + K 1171C 1172 DO NAI = 1, NT1AM(ISYMAI) 1173C 1174 NAIKJ = ISAIKJ(ISYAIK,ISYMJ) 1175 * + NCKI(ISYAIK)*(J - 1) 1176 * + ICKI(ISYMAI,ISYMK) 1177 * + NT1AM(ISYMAI)*(K-1) + NAI 1178C 1179 TMAT(NAIKJ) = TWO*T1AM(NAI)*WORK(NKJ) 1180C 1181 ENDDO 1182 ENDDO 1183 ENDDO 1184C 1185 ENDDO 1186C 1187C---------------------------------------- 1188C Sum the result into SMAT. 1189C---------------------------------------- 1190C 1191 JSAIKJ = MULD2H(ISYMAI,ISYMJK) 1192 DO I = 1, NCKIJ(JSAIKJ) 1193C First : 1194 SMAT(I) = SMAT(I) + TMAT(I) 1195C Second : 1196 SMAT(I) = SMAT(I) - TMAT(INDSQ(I,1)) 1197 ENDDO 1198C 1199C----------------------------------------------- 1200C Second contribution from both T1 terms 1201C----------------------------------------------- 1202C 1203 ISYAIK = MULD2H(ISINT1,ISYMC) 1204C 1205C------------------------------------ 1206C Sort integrals for constant C 1207C------------------------------------ 1208C 1209 IF (LWORK .LT. NCKI(ISYAIK)) THEN 1210 CALL QUIT('Too little workspace in CCFOP_SMAT (2)') 1211 ENDIF 1212C 1213 DO ISYMK = 1, NSYM 1214 ISYMAI = MULD2H(ISYAIK,ISYMK) 1215 ISYMCK = MULD2H(ISYMC,ISYMK) 1216 DO K = 1, NRHF(ISYMK) 1217 NCK = IT1AM(ISYMC,ISYMK) + NVIR(ISYMC)*(K - 1) + C 1218 DO NAI = 1, NT1AM(ISYMAI) 1219C 1220 NAIK = ICKI(ISYMAI,ISYMK)+NT1AM(ISYMAI)*(K - 1)+NAI 1221 NAICK = IT2AM(ISYMAI,ISYMCK) + INDEX(NAI,NCK) 1222C 1223 WORK(NAIK) = XIAJB(NAICK) 1224C 1225 ENDDO 1226 ENDDO 1227 ENDDO 1228C 1229C---------------------------------- 1230C Contract integrals with T1. 1231C---------------------------------- 1232C 1233 CALL DZERO(TMAT,LENGTH) 1234C 1235 ISYMJ = MULD2H(ISYMT1,ISYMB) 1236C 1237 DO ISYMK = 1, NSYM 1238 ISYMAI = MULD2H(ISYAIK,ISYMK) 1239 ISYMCK = MULD2H(ISYMC,ISYMK) 1240C 1241 DO K = 1, NRHF(ISYMK) 1242 NCK = IT1AM(ISYMC,ISYMK) + NVIR(ISYMC)*(K - 1) + C 1243 DO J = 1, NRHF(ISYMJ) 1244C 1245 NBJ = IT1AM(ISYMB,ISYMJ) + NVIR(ISYMB)*(J - 1) + B 1246C 1247 DO NAI = 1, NT1AM(ISYMAI) 1248C 1249 NAIKJ = ISAIKJ(ISYAIK,ISYMJ) 1250 * + NCKI(ISYAIK)*(J - 1) 1251 * + ICKI(ISYMAI,ISYMK) 1252 * + NT1AM(ISYMAI)*(K-1) + NAI 1253C 1254 NAIK = ICKI(ISYMAI,ISYMK)+ NT1AM(ISYMAI)*(K - 1)+ NAI 1255C 1256 TMAT(NAIKJ) = TWO*T1AM(NBJ)*WORK(NAIK) 1257C 1258 ENDDO 1259 ENDDO 1260 ENDDO 1261 ENDDO 1262C 1263C-------------------------------------- 1264C Sum the result into SMAT. 1265C-------------------------------------- 1266C 1267 JSAIKJ = MULD2H(ISYAIK,ISYMJ) 1268 DO I = 1, NCKIJ(JSAIKJ) 1269C First : 1270 SMAT(I) = SMAT(I) + TMAT(I) 1271C Second : 1272 SMAT(I) = SMAT(I) - TMAT(INDSQ(I,3)) 1273 ENDDO 1274C 1275 endif ! The end of the if (if .false.) then 1276C 1277C----------------------------------------------------------------------- 1278C Contribution from both Fock terms 1279C----------------------------------------------------------------------- 1280C 1281 if (.true.) then 1282C 1283 CALL DZERO(TMAT,LENGTH) 1284C 1285 ISYMK = MULD2H(ISINT2,ISYMC) 1286 ISYAIJ = MULD2H(ISYMT2,ISYMB) 1287 NCKTEMP = IT1AM(ISYMC,ISYMK) + C 1288C 1289 DO ISYMJ = 1, NSYM 1290 ISYMAI = MULD2H(ISYAIJ,ISYMJ) 1291 ISYMBJ = MULD2H(ISYMB,ISYMJ) 1292 ISYAIK = MULD2H(ISYMK,ISYMAI) 1293 DO ISYMI = 1, NSYM 1294 ISYMA = MULD2H(ISYMAI,ISYMI) 1295 ISYMAJ = MULD2H(ISYMA,ISYMJ) 1296 ISYMBI = MULD2H(ISYMB,ISYMI) 1297C 1298 DO J = 1, NRHF(ISYMJ) 1299 NBJ = IT1AM(ISYMB,ISYMJ) + NVIR(ISYMB)*(J-1) + B 1300C 1301 DO I = 1, NRHF(ISYMI) 1302 DO A = 1, NVIR(ISYMA) 1303C 1304 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I-1) + A 1305C 1306C Index for sorted T2 amplitudes. 1307C 1308 NAIBJ = IT2SP(ISYAIJ,ISYMB) 1309 * + NCKI(ISYAIJ)*(B - 1) 1310 * + ICKI(ISYMAI,ISYMJ) 1311 * + NT1AM(ISYMAI)*(J - 1) + NAI 1312C 1313 NAIKJTEMP = ISAIKJ(ISYAIK,ISYMJ) 1314 * + NCKI(ISYAIK)*(J - 1) 1315 * + ICKI(ISYMAI,ISYMK) 1316 * + NAI 1317C 1318 DO K = 1, NRHF(ISYMK) 1319C 1320 NCK = NCKTEMP + NVIR(ISYMC)*(K-1) 1321 NAIKJ = NAIKJTEMP 1322 * + NT1AM(ISYMAI)*(K-1) 1323C 1324 TMAT(NAIKJ) = TWO*T2TCME(NAIBJ)*FOCK(NCK) 1325C 1326 ENDDO 1327 ENDDO 1328 ENDDO 1329 ENDDO 1330 ENDDO 1331 ENDDO 1332C 1333C------------------------------------ 1334C Sum the result into SMAT. 1335C------------------------------------ 1336C 1337 ISYMBC = MULD2H(ISYMB,ISYMC) 1338 ISYRES = MULD2H(ISINT2,ISYMT2) 1339 JSAIKJ = MULD2H(ISYMBC,ISYRES) 1340C 1341 DO I = 1, NCKIJ(JSAIKJ) 1342 ! First term 1343 SMAT(I) = SMAT(I) + TWO*TMAT(I) 1344 ! Second term 1345 SMAT(I) = SMAT(I) - TMAT(INDSQ(I,3)) 1346 SMAT(I) = SMAT(I) - TMAT(INDSQ(I,1)) 1347 ENDDO 1348C 1349 endif 1350C 1351C---------------------------------------------- 1352C First virtual contribution of L term. 1353C---------------------------------------------- 1354C 1355 ISYMBC = MULD2H(ISYMB,ISYMC) 1356 ISYRES = MULD2H(ISINT2,ISYMT2) 1357 JSAIKJ = MULD2H(ISYMBC,ISYRES) 1358 ISYMDK = MULD2H(ISYMBC,ISINT2) 1359C 1360 LENGTH = NCKIJ(JSAIKJ) 1361C 1362 IF (LWORK .LT. LENGTH) THEN 1363 CALL QUIT('Insufficient core in CCFOP_SMAT') 1364 ENDIF 1365C 1366 if (.true.) then 1367C 1368 DO ISYMK = 1,NSYM 1369C 1370 ISYMD = MULD2H(ISYMK,ISYMDK) 1371 ISYAIJ = MULD2H(ISYMK,JSAIKJ) 1372C 1373 KOFF1 = IT2SP(ISYAIJ,ISYMD) + 1 1374 KOFF2 = ICKATR(ISYMDK,ISYMB) + NT1AM(ISYMDK)*(B - 1) 1375 * + IT1AM(ISYMD,ISYMK) + 1 1376 KOFF3 = ISAIKJ(ISYAIJ,ISYMK) + 1 1377C 1378 NTOAIJ = MAX(1,NCKI(ISYAIJ)) 1379 NVIRD = MAX(NVIR(ISYMD),1) 1380C 1381 CALL DGEMM('N','N',NCKI(ISYAIJ),NRHF(ISYMK), 1382 * NVIR(ISYMD),ONE,T2TCME(KOFF1),NTOAIJ, 1383 * TRVIR5(KOFF2),NVIRD,ZERO, 1384 * WORK(KOFF3),NTOAIJ) 1385C 1386 ENDDO 1387C 1388C CALL CC_GATHER(LENGTH,SMAT,WORK,INDSQ(1,3)) 1389 DO I = 1,LENGTH 1390 SMAT(I) = SMAT(I) + TWO*WORK(INDSQ(I,3)) 1391 ENDDO 1392C 1393 IF (IPRINT .GT. 55) THEN 1394 XSMAT = DDOT(NCKIJ(JSAIKJ),SMAT,1,SMAT,1) 1395 WRITE(LUPRI,*) 'In CCFOP_SMAT: 1. Norm of SMAT ',XSMAT 1396 ENDIF 1397C 1398C------------------------------------------------- 1399C Second virtual contribution of L term. 1400C------------------------------------------------- 1401C 1402 ISYAKD = MULD2H(ISYMC,ISINT2) 1403 ISYDIJ = MULD2H(ISYMB,ISYMT2) 1404C 1405 DO ISYMJ = 1,NSYM 1406C 1407 ISYMDI = MULD2H(ISYMJ,ISYDIJ) 1408C 1409 DO J = 1,NRHF(ISYMJ) 1410C 1411 DO ISYMI = 1,NSYM 1412C 1413 ISYMD = MULD2H(ISYMDI,ISYMI) 1414 ISYMAK = MULD2H(ISYMD,ISYAKD) 1415 ISYAKI = MULD2H(ISYMAK,ISYMI) 1416C 1417 KOFF1 = ICKATR(ISYMAK,ISYMD) + 1 1418C 1419 KOFF2 = IT2SP(ISYDIJ,ISYMB) 1420 * + NCKI(ISYDIJ)*(B - 1) 1421 * + ISAIK(ISYMDI,ISYMJ) 1422 * + NT1AM(ISYMDI)*(J - 1) 1423 * + IT1AM(ISYMD,ISYMI) + 1 1424C 1425 KOFF3 = ISAIKJ(ISYAKI,ISYMJ) 1426 * + NCKI(ISYAKI)*(J - 1) 1427 * + ISAIK(ISYMAK,ISYMI) + 1 1428C 1429 NVIRD = MAX(NVIR(ISYMD),1) 1430 NTOTAK = MAX(NT1AM(ISYMAK),1) 1431C 1432 CALL DGEMM('N','N',NT1AM(ISYMAK),NRHF(ISYMI), 1433 * NVIR(ISYMD),ONE,TRVIR4(KOFF1),NTOTAK, 1434 * T2TCME(KOFF2),NVIRD,ZERO,TMAT(KOFF3), 1435 * NTOTAK) 1436C 1437 ENDDO 1438 ENDDO 1439 ENDDO 1440C 1441c CALL CC_GATHER(LENGTH,WORK,TMAT,INDSQ(1,1)) 1442c CALL DAXPY(LENGTH,ONE,WORK,1,SMAT,1) 1443C 1444 DO I = 1,LENGTH 1445 SMAT(I) = SMAT(I) + TWO*TMAT(INDSQ(I,1)) 1446 ENDDO 1447C 1448 IF (IPRINT .GT. 55) THEN 1449 XSMAT = DDOT(NCKIJ(JSAIKJ),SMAT,1,SMAT,1) 1450 WRITE(LUPRI,*) 'In CCFOP_SMAT: 2. Norm of SMAT ',XSMAT 1451 ENDIF 1452C 1453 endif 1454C 1455C------------------------------------------------ 1456C First virtual contribution of g term. 1457C------------------------------------------------ 1458C 1459 ISYMBC = MULD2H(ISYMB,ISYMC) 1460 ISYRES = MULD2H(ISINT2,ISYMT2) 1461 JSAIKJ = MULD2H(ISYMBC,ISYRES) 1462 ISYMDK = MULD2H(ISYMBC,ISINT2) 1463C 1464 LENGTH = NCKIJ(JSAIKJ) 1465C 1466 IF (LWORK .LT. LENGTH) THEN 1467 CALL QUIT('Insufficient core in CCSDT_SMAT') 1468 ENDIF 1469C 1470 if (.true.) then 1471C 1472 DO ISYMK = 1,NSYM 1473C 1474 ISYMD = MULD2H(ISYMK,ISYMDK) 1475 ISYAIJ = MULD2H(ISYMK,JSAIKJ) 1476C 1477 KOFF1 = IT2SP(ISYAIJ,ISYMD) + 1 1478 KOFF2 = ICKATR(ISYMDK,ISYMB) + NT1AM(ISYMDK)*(B - 1) 1479 * + IT1AM(ISYMD,ISYMK) + 1 1480 KOFF3 = ISAIKJ(ISYAIJ,ISYMK) + 1 1481C 1482 NTOAIJ = MAX(1,NCKI(ISYAIJ)) 1483 NVIRD = MAX(NVIR(ISYMD),1) 1484C 1485 CALL DGEMM('N','N',NCKI(ISYAIJ),NRHF(ISYMK), 1486 * NVIR(ISYMD),ONE,T2TCME(KOFF1),NTOAIJ, 1487 * TRVIR(KOFF2),NVIRD,ZERO, 1488 * WORK(KOFF3),NTOAIJ) 1489C 1490 ENDDO 1491C 1492 DO I = 1,LENGTH 1493 SMAT(I) = SMAT(I) - TWO*WORK(INDSQ(I,2)) 1494 ENDDO 1495C 1496 IF (IPRINT .GT. 55) THEN 1497 XSMAT = DDOT(NCKIJ(JSAIKJ),SMAT,1,SMAT,1) 1498 WRITE(LUPRI,*) 'In CCFOP_SMAT: 3. Norm of SMAT ',XSMAT 1499 ENDIF 1500C 1501C------------------------------------------------- 1502C Second virtual contribution of g term. 1503C------------------------------------------------- 1504C 1505 ISYAKD = MULD2H(ISYMC,ISINT2) 1506 ISYDIJ = MULD2H(ISYMB,ISYMT2) 1507C 1508 DO ISYMJ = 1,NSYM 1509C 1510 ISYMDI = MULD2H(ISYMJ,ISYDIJ) 1511C 1512 DO J = 1,NRHF(ISYMJ) 1513C 1514 DO ISYMI = 1,NSYM 1515C 1516 ISYMD = MULD2H(ISYMDI,ISYMI) 1517 ISYMAK = MULD2H(ISYMD,ISYAKD) 1518 ISYAKI = MULD2H(ISYMAK,ISYMI) 1519C 1520 KOFF1 = ICKATR(ISYMAK,ISYMD) + 1 1521C 1522 KOFF2 = IT2SP(ISYDIJ,ISYMB) 1523 * + NCKI(ISYDIJ)*(B - 1) 1524 * + ISAIK(ISYMDI,ISYMJ) 1525 * + NT1AM(ISYMDI)*(J - 1) 1526 * + IT1AM(ISYMD,ISYMI) + 1 1527C 1528 KOFF3 = ISAIKJ(ISYAKI,ISYMJ) 1529 * + NCKI(ISYAKI)*(J - 1) 1530 * + ISAIK(ISYMAK,ISYMI) + 1 1531C 1532 NVIRD = MAX(NVIR(ISYMD),1) 1533 NTOTAK = MAX(NT1AM(ISYMAK),1) 1534C 1535 CALL DGEMM('N','N',NT1AM(ISYMAK),NRHF(ISYMI), 1536 * NVIR(ISYMD),ONE,TRVIR2(KOFF1),NTOTAK, 1537 * T2TCME(KOFF2),NVIRD,ZERO,TMAT(KOFF3), 1538 * NTOTAK) 1539C 1540 ENDDO 1541 ENDDO 1542 ENDDO 1543C 1544 DO I = 1,LENGTH 1545 SMAT(I) = SMAT(I) - TWO*TMAT(INDSQ(I,4)) 1546 ENDDO 1547C 1548 IF (IPRINT .GT. 55) THEN 1549 XSMAT = DDOT(NCKIJ(JSAIKJ),SMAT,1,SMAT,1) 1550 WRITE(LUPRI,*) 'In CCFOP_SMAT: 4. Norm of SMAT ',XSMAT 1551 ENDIF 1552C 1553 endif 1554C 1555C---------------------------------------- 1556C First occupied L contribution. 1557C---------------------------------------- 1558C 1559 ISYAIL = MULD2H(ISYMB,ISYMT2) 1560 ISYLKJ = MULD2H(ISYMC,ISINT2) 1561C 1562 if (.true.) then 1563C 1564 DO ISYMJ = 1,NSYM 1565C 1566 ISYMLK = MULD2H(ISYMJ,ISYLKJ) 1567C 1568 DO J = 1,NRHF(ISYMJ) 1569C 1570 DO ISYMK = 1,NSYM 1571C 1572 ISYML = MULD2H(ISYMK,ISYMLK) 1573 ISYMAI = MULD2H(ISYAIL,ISYML) 1574 ISYAIK = MULD2H(ISYMAI,ISYMK) 1575C 1576 KOFF1 = IT2SP(ISYAIL,ISYMB) 1577 * + NCKI(ISYAIL)*(B - 1) 1578 * + ICKI(ISYMAI,ISYML) + 1 1579 KOFF2 = ISJIKA(ISYLKJ,ISYMC) 1580 * + NMAJIK(ISYLKJ)*(C - 1) 1581 * + ISJIK(ISYMLK,ISYMJ) 1582 * + NMATIJ(ISYMLK)*(J - 1) 1583 * + IMATIJ(ISYML,ISYMK) + 1 1584 KOFF3 = ISAIKJ(ISYAIK,ISYMJ) 1585 * + NCKI(ISYAIK)*(J - 1) 1586 * + ICKI(ISYMAI,ISYMK) + 1 1587C 1588 NTOTAI = MAX(1,NT1AM(ISYMAI)) 1589 NRHFL = MAX(1,NRHF(ISYML)) 1590C 1591 CALL DGEMM('N','N',NT1AM(ISYMAI),NRHF(ISYMK), 1592 * NRHF(ISYML),-TWO,T2TCME(KOFF1),NTOTAI, 1593 * TROCC2(KOFF2),NRHFL,ONE,SMAT(KOFF3), 1594 * NTOTAI) 1595C 1596 ENDDO 1597 ENDDO 1598 ENDDO 1599C 1600 IF (IPRINT .GT. 55) THEN 1601 XSMAT = DDOT(NCKIJ(JSAIKJ),SMAT,1,SMAT,1) 1602 WRITE(LUPRI,*) 'In CC3_SMAT: 3. Norm of SMAT ',XSMAT 1603 ENDIF 1604C 1605C---------------------------------------- 1606C Second occupied L contribution. 1607C---------------------------------------- 1608C 1609 ISYAJL = MULD2H(ISYMB,ISYMT2) 1610 ISYLKI = MULD2H(ISYMC,ISINT2) 1611C 1612 IF (LWORK .LT. NCKI(ISYAJL)) THEN 1613 CALL QUIT('Not enough space in CCSDT_SMAT') 1614 END IF 1615C 1616 KOFF = IT2SP(ISYAJL,ISYMB) + NCKI(ISYAJL)*(B - 1) + 1 1617 CALL CC_GATHER(NCKI(ISYAJL),WORK,T2TCME(KOFF),INDAJL) 1618C 1619 DO ISYMI = 1,NSYM 1620C 1621 ISYMLK = MULD2H(ISYMI,ISYLKI) 1622C 1623 DO I = 1,NRHF(ISYMI) 1624C 1625 DO ISYMK = 1,NSYM 1626C 1627 ISYML = MULD2H(ISYMK,ISYMLK) 1628 ISYMAJ = MULD2H(ISYAJL,ISYML) 1629 ISYAJK = MULD2H(ISYMAJ,ISYMK) 1630C 1631 KOFF1 = ICKI(ISYMAJ,ISYML) + 1 1632C 1633 KOFF2 = ISJIKA(ISYLKI,ISYMC) 1634 * + NMAJIK(ISYLKI)*(C - 1) 1635 * + ISJIK(ISYMLK,ISYMI) 1636 * + NMATIJ(ISYMLK)*(I - 1) 1637 * + IMATIJ(ISYML,ISYMK) + 1 1638C 1639 KOFF3 = ISAIKJ(ISYAJK,ISYMI) 1640 * + NCKI(ISYAJK)*(I - 1) 1641 * + ICKI(ISYMAJ,ISYMK) + 1 1642C 1643 NTOTAJ = MAX(1,NT1AM(ISYMAJ)) 1644 NRHFL = MAX(1,NRHF(ISYML)) 1645C 1646 CALL DGEMM('N','N',NT1AM(ISYMAJ),NRHF(ISYMK), 1647 * NRHF(ISYML),TWO,WORK(KOFF1),NTOTAJ, 1648 * TROCC2(KOFF2),NRHFL,ZERO,TMAT(KOFF3), 1649 * NTOTAJ) 1650C 1651 ENDDO 1652 ENDDO 1653 ENDDO 1654C 1655c CALL CC_GATHER(NCKIJ(JSAIKJ),WORK,TMAT,INDSQ(1,5)) 1656c CALL DAXPY(NCKIJ(JSAIKJ),-ONE,WORK,1,SMAT,1) 1657C 1658 DO I = 1,NCKIJ(JSAIKJ) 1659 SMAT(I) = SMAT(I) - TMAT(INDSQ(I,5)) 1660 ENDDO 1661C 1662 IF (IPRINT .GT. 55) THEN 1663 XSMAT = DDOT(NCKIJ(JSAIKJ),SMAT,1,SMAT,1) 1664 WRITE(LUPRI,*) 'In CC3_SMAT: 4. Norm of SMAT ',XSMAT 1665 ENDIF 1666C 1667 endif 1668C 1669C--------------------------------------- 1670C First occupied g contribution. 1671C--------------------------------------- 1672C 1673 ISYAIL = MULD2H(ISYMB,ISYMT2) 1674 ISYLKJ = MULD2H(ISYMC,ISINT2) 1675C 1676 if (.true.) then 1677C 1678 DO ISYMJ = 1,NSYM 1679C 1680 ISYMLK = MULD2H(ISYMJ,ISYLKJ) 1681C 1682 DO J = 1,NRHF(ISYMJ) 1683C 1684 DO ISYMK = 1,NSYM 1685C 1686 ISYML = MULD2H(ISYMK,ISYMLK) 1687 ISYMAI = MULD2H(ISYAIL,ISYML) 1688 ISYAIK = MULD2H(ISYMAI,ISYMK) 1689C 1690 KOFF1 = IT2SP(ISYAIL,ISYMB) 1691 * + NCKI(ISYAIL)*(B - 1) 1692 * + ICKI(ISYMAI,ISYML) + 1 1693 KOFF2 = ISJIKA(ISYLKJ,ISYMC) 1694 * + NMAJIK(ISYLKJ)*(C - 1) 1695 * + ISJIK(ISYMLK,ISYMJ) 1696 * + NMATIJ(ISYMLK)*(J - 1) 1697 * + IMATIJ(ISYML,ISYMK) + 1 1698 KOFF3 = ISAIKJ(ISYAIK,ISYMJ) 1699 * + NCKI(ISYAIK)*(J - 1) 1700 * + ICKI(ISYMAI,ISYMK) + 1 1701C 1702 NTOTAI = MAX(1,NT1AM(ISYMAI)) 1703 NRHFL = MAX(1,NRHF(ISYML)) 1704C 1705 CALL DGEMM('N','N',NT1AM(ISYMAI),NRHF(ISYMK), 1706 * NRHF(ISYML),-TWO,T2TCME(KOFF1),NTOTAI, 1707 * TROCC(KOFF2),NRHFL,ZERO,TMAT(KOFF3), 1708 * NTOTAI) 1709C 1710 ENDDO 1711 ENDDO 1712 ENDDO 1713C 1714 DO I = 1,NCKIJ(JSAIKJ) 1715 SMAT(I) = SMAT(I) - TMAT(INDSQ(I,1)) 1716 ENDDO 1717C 1718 IF (IPRINT .GT. 55) THEN 1719 XSMAT = DDOT(NCKIJ(JSAIKJ),SMAT,1,SMAT,1) 1720 WRITE(LUPRI,*) 'In CC3_SMAT: 3. Norm of SMAT ',XSMAT 1721 ENDIF 1722C 1723C---------------------------------------- 1724C Second occupied g contribution. 1725C---------------------------------------- 1726C 1727 ISYAJL = MULD2H(ISYMB,ISYMT2) 1728 ISYLKI = MULD2H(ISYMC,ISINT2) 1729C 1730 IF (LWORK .LT. NCKI(ISYAJL)) THEN 1731 CALL QUIT('Not enough space in CCSDT_SMAT') 1732 END IF 1733C 1734 KOFF = IT2SP(ISYAJL,ISYMB) + NCKI(ISYAJL)*(B - 1) + 1 1735 CALL CC_GATHER(NCKI(ISYAJL),WORK,T2TCME(KOFF),INDAJL) 1736C 1737 DO ISYMI = 1,NSYM 1738C 1739 ISYMLK = MULD2H(ISYMI,ISYLKI) 1740C 1741 DO I = 1,NRHF(ISYMI) 1742C 1743 DO ISYMK = 1,NSYM 1744C 1745 ISYML = MULD2H(ISYMK,ISYMLK) 1746 ISYMAJ = MULD2H(ISYAJL,ISYML) 1747 ISYAJK = MULD2H(ISYMAJ,ISYMK) 1748C 1749 KOFF1 = ICKI(ISYMAJ,ISYML) + 1 1750C 1751 KOFF2 = ISJIKA(ISYLKI,ISYMC) 1752 * + NMAJIK(ISYLKI)*(C - 1) 1753 * + ISJIK(ISYMLK,ISYMI) 1754 * + NMATIJ(ISYMLK)*(I - 1) 1755 * + IMATIJ(ISYML,ISYMK) + 1 1756C 1757 KOFF3 = ISAIKJ(ISYAJK,ISYMI) 1758 * + NCKI(ISYAJK)*(I - 1) 1759 * + ICKI(ISYMAJ,ISYMK) + 1 1760C 1761 NTOTAJ = MAX(1,NT1AM(ISYMAJ)) 1762 NRHFL = MAX(1,NRHF(ISYML)) 1763C 1764 CALL DGEMM('N','N',NT1AM(ISYMAJ),NRHF(ISYMK), 1765 * NRHF(ISYML),TWO,WORK(KOFF1),NTOTAJ, 1766 * TROCC(KOFF2),NRHFL,ZERO,TMAT(KOFF3), 1767 * NTOTAJ) 1768C 1769 ENDDO 1770 ENDDO 1771 ENDDO 1772C 1773c CALL CC_GATHER(NCKIJ(JSAIKJ),WORK,TMAT,INDSQ(1,5)) 1774c CALL DAXPY(NCKIJ(JSAIKJ),-ONE,WORK,1,SMAT,1) 1775C 1776 DO I = 1,NCKIJ(JSAIKJ) 1777 SMAT(I) = SMAT(I) + TMAT(INDSQ(I,2)) 1778 ENDDO 1779C 1780 IF (IPRINT .GT. 55) THEN 1781 XSMAT = DDOT(NCKIJ(JSAIKJ),SMAT,1,SMAT,1) 1782 WRITE(LUPRI,*) 'In CC3_SMAT: 4. Norm of SMAT ',XSMAT 1783 ENDIF 1784C 1785 endif 1786C 1787C----------------------------------------- 1788C Divide by the Fock matrix diagonals. 1789C----------------------------------------- 1790C 1791 NB = IORB(ISYMB) + NRHF(ISYMB) + B 1792 NC = IORB(ISYMC) + NRHF(ISYMC) + C 1793C 1794 EPSIBC = FOCKD(NB) + FOCKD(NC) - ECURR 1795C 1796 DO L = 1,NCKIJ(JSAIKJ) 1797 SMAT(L) = SMAT(L)/(DIAG(L) + EPSIBC) 1798 ENDDO 1799C 1800 IF (IPRINT .GT. 55) THEN 1801 XSMAT = DDOT(NCKIJ(JSAIKJ),SMAT,1,SMAT,1) 1802 WRITE(LUPRI,*) 'In CC3_SMAT: 5. Norm of SMAT ',XSMAT 1803 ENDIF 1804C 1805C---------------------- 1806C Print if desired. 1807C---------------------- 1808C 1809 IF (IPRCC .GT. 75) THEN 1810C 1811 CALL AROUND('The S matrix') 1812 WRITE(LUPRI,*) 1813 WRITE(LUPRI,'(2X,A,I4)') 'JSAIKJ ', JSAIKJ 1814 WRITE(LUPRI,'(2X,A,4I4)') 'isymb,b,isymc,c',ISYMB,B,ISYMC,C 1815 WRITE(LUPRI,*) 1816C 1817 DO ISYMJ = 1,NSYM 1818C 1819 ISYAIK = MULD2H(JSAIKJ,ISYMJ) 1820C 1821 DO J = 1,NRHF(ISYMJ) 1822C 1823 WRITE(LUPRI,'(5X,A,2I4)') 'isymj,j',ISYMJ,J 1824 WRITE(LUPRI,*) 1825C 1826 DO ISYMK = 1,NSYM 1827C 1828 ISYMAI = MULD2H(ISYAIK,ISYMK) 1829C 1830 DO K = 1,NRHF(ISYMK) 1831C 1832 WRITE(LUPRI,'(8X,A,2I4)') 'isymk,k',ISYMK,K 1833 WRITE(LUPRI,*) 1834C 1835 DO ISYMI = 1,NSYM 1836C 1837 ISYMA = MULD2H(ISYMAI,ISYMI) 1838C 1839 KOFF = ISAIKJ(ISYAIK,ISYMJ) 1840 * + NCKI(ISYAIK)*(J - 1) 1841 * + ICKI(ISYMAI,ISYMK) 1842 * + NT1AM(ISYMAI)*(K - 1) 1843 * + IT1AM(ISYMA,ISYMI) + 1 1844C 1845 CALL OUTPUT(SMAT(KOFF),1,NVIR(ISYMA),1, 1846 * NRHF(ISYMI),NVIR(ISYMA), 1847 * NRHF(ISYMI),1,LUPRI) 1848C 1849 ENDDO 1850 ENDDO 1851 ENDDO 1852 ENDDO 1853 ENDDO 1854C 1855 END IF 1856C 1857 CALL QEXIT('CCFOP_SMAT') 1858C 1859 RETURN 1860 END 1861C /* Deck ccsdt_tcmeocc */ 1862 SUBROUTINE CCSDT_TCMEOCC(TRINP,TROUT,ISYINT) 1863C 1864C Kasper Hald, Fall 2001 1865C 1866C Calculate 2*C-E from the occupied integrals 1867C 1868 IMPLICIT NONE 1869C 1870#include "priunit.h" 1871#include "ccorb.h" 1872#include "ccsdsym.h" 1873C 1874 INTEGER ISYINT 1875 INTEGER ISYMA, ISYJIK, ISYMK, ISYMJI, ISYMJ, ISYMI, KOFF1, KOFF2 1876 integer isymjk 1877C 1878#if defined (SYS_CRAY) 1879 REAL TRINP(*), TROUT(*), TWO 1880#else 1881 DOUBLE PRECISION TRINP(*), TROUT(*), TWO 1882#endif 1883C 1884 PARAMETER(TWO = 2.0D0) 1885C 1886 CALL QENTER('CCSDT_TCMEOCC') 1887C 1888 DO ISYMA = 1, NSYM 1889C 1890 ISYJIK = MULD2H(ISYINT,ISYMA) 1891C 1892 DO ISYMK = 1, NSYM 1893 ISYMJI = MULD2H(ISYJIK,ISYMK) 1894 DO ISYMJ = 1, NSYM 1895 ISYMI = MULD2H(ISYMJI,ISYMJ) 1896 ISYMJK = MULD2H(ISYMJ,ISYMK) 1897 DO K = 1, NRHF(ISYMK) 1898 DO A = 1, NVIR(ISYMA) 1899 DO J = 1, NRHF(ISYMJ) 1900 DO I = 1, NRHF(ISYMI) 1901C 1902 KOFF1 = ISJIKA(ISYJIK,ISYMA) 1903 * + NMAJIK(ISYJIK)*(A-1) 1904 * + ISJIK(ISYMJI,ISYMK) 1905 * + NMATIJ(ISYMJI)*(K - 1) 1906 * + IMATIJ(ISYMJ,ISYMI) 1907 * + NRHF(ISYMJ)*(I - 1) + J 1908C 1909C First : 1910C KOFF2 = ISJIKA(ISYJIK,ISYMA) 1911C * + NMAJIK(ISYJIK)*(A-1) 1912C * + ISJIK(ISYMJI,ISYMK) 1913C * + NMATIJ(ISYMJI)*(K - 1) 1914C * + IMATIJ(ISYMI,ISYMJ) 1915C * + NRHF(ISYMI)*(J - 1) + I 1916C 1917 KOFF2 = ISJIKA(ISYJIK,ISYMA) 1918 * + NMAJIK(ISYJIK)*(A-1) 1919 * + ISJIK(ISYMJK,ISYMI) 1920 * + NMATIJ(ISYMJK)*(I - 1) 1921 * + IMATIJ(ISYMJ,ISYMK) 1922 * + NRHF(ISYMJ)*(K - 1) + J 1923C 1924C 1925 TROUT(KOFF1) = TWO*TRINP(KOFF1) - TRINP(KOFF2) 1926C 1927 ENDDO ! I 1928 ENDDO ! J 1929 ENDDO ! A 1930 ENDDO ! K 1931 ENDDO ! ISYMA 1932 ENDDO ! ISYMJ 1933 ENDDO ! ISYMK 1934C 1935 CALL QEXIT('CCSDT_TCMEOCC') 1936C 1937 RETURN 1938 END 1939C /* Deck ccfop_qmat */ 1940 SUBROUTINE CCFOP_QMAT(ECURR,T1AM,ISYMT1,T2TCME,ISYMT2,TMAT,FOCK, 1941 * XIAJB,ISINT1,TRVIR3,TRVIR6,TROCC,TROCC2, 1942 * ISINT2,FOCKD,DIAG,QMAT,WORK,LWORK, 1943 * INDSQ,LENSQ,ISYMB,B,ISYMD,D) 1944C 1945C Written by K. Hald, Fall 2001. 1946C 1947C Calculate QMAT for t3-bar. 1948C 1949 IMPLICIT NONE 1950C 1951#include "priunit.h" 1952#include "ccorb.h" 1953#include "ccsdinp.h" 1954#include "ccsdsym.h" 1955C 1956 INTEGER ISYMT1, ISYMT2, ISINT1, ISINT2, LWORK, LENSQ 1957 INTEGER ISYMB, ISYMD 1958 INTEGER INDSQ(LENSQ,6), INDEX 1959 INTEGER ISYMBD, ISYMJK, ISYMJ, ISYMK, ISYMBK, ISYMDJ, NDJ, NKJ 1960 INTEGER NBK, NBKDJ, ISYMAI, ISYAIK, ISYMA, ISYMI, NAI, NAIKJ 1961 INTEGER JSAIKJ, ISYAIJ, NBKTEMP, ISYMAJ, ISYMDI 1962 INTEGER NAIDJ, NAIKJTEMP, ISYRES, ISYMFK, ISYMF, NVIRF 1963 INTEGER LENGTH, KOFF1, KOFF2, KOFF3, NTOAIJ, ISYAIL, ISYLKJ 1964 INTEGER ISYMLK, ISYML, NTOTAI, NRHFL, NB, ND, NAIK, NAIBK 1965C 1966#if defined (SYS_CRAY) 1967 REAL T1AM(*), T2TCME(*), FOCK(*), XIAJB(*), TRVIR3(*) 1968 REAL TRVIR6(*), TROCC(*), TROCC2(*), FOCKD(*), DIAG(*) 1969 REAL TMAT(*), QMAT(*), WORK(LWORK), EPSIBD, ECURR 1970 REAL ZERO, ONE, TWO, FOUR, XQMAT, DDOT 1971#else 1972 DOUBLE PRECISION T1AM(*), T2TCME(*), FOCK(*), XIAJB(*), TRVIR3(*) 1973 DOUBLE PRECISION TRVIR6(*), TROCC(*), TROCC2(*), FOCKD(*),DIAG(*) 1974 DOUBLE PRECISION TMAT(*), QMAT(*), WORK(LWORK), EPSIBD, ECURR 1975 DOUBLE PRECISION ZERO, ONE, TWO, FOUR, XQMAT, DDOT 1976#endif 1977C 1978 PARAMETER (ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, FOUR = 4.0D0) 1979C 1980 INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 1981C 1982 CALL QENTER('CCFOP_QMAT') 1983C 1984C------------------------------------------ 1985C Contribution from the two T1 terms. 1986C------------------------------------------ 1987 if (.true.) then 1988C 1989 ISYAIK = MULD2H(ISINT1,ISYMB) 1990 ISYMJ = MULD2H(ISYMT1,ISYMD) 1991 JSAIKJ = MULD2H(ISYAIK,ISYMJ) 1992C 1993 CALL DZERO(TMAT,NCKIJ(JSAIKJ)) 1994C 1995C------------------------------------ 1996C Sort integrals for constant B 1997C------------------------------------ 1998C 1999 IF (LWORK .LT. NCKI(ISYAIK)) THEN 2000 CALL QUIT('Too little workspace in CCFOP_QMAT (1)') 2001 ENDIF 2002C 2003 DO ISYMK = 1, NSYM 2004 ISYMAI = MULD2H(ISYAIK,ISYMK) 2005 ISYMBK = MULD2H(ISYMB,ISYMK) 2006 DO K = 1, NRHF(ISYMK) 2007 NBK = IT1AM(ISYMB,ISYMK) + NVIR(ISYMB)*(K - 1) + B 2008 DO NAI = 1, NT1AM(ISYMAI) 2009C 2010 NAIK = ICKI(ISYMAI,ISYMK)+NT1AM(ISYMAI)*(K - 1)+NAI 2011 NAIBK = IT2AM(ISYMAI,ISYMBK) + INDEX(NAI,NBK) 2012C 2013 WORK(NAIK) = XIAJB(NAIBK) 2014C 2015 ENDDO 2016 ENDDO 2017 ENDDO 2018C 2019C---------------------------------- 2020C Contract integrals with T1. 2021C---------------------------------- 2022C 2023 DO ISYMK = 1, NSYM 2024 ISYMAI = MULD2H(ISYAIK,ISYMK) 2025C 2026 DO K = 1, NRHF(ISYMK) 2027 DO J = 1, NRHF(ISYMJ) 2028C 2029 NDJ = IT1AM(ISYMD,ISYMJ) + NVIR(ISYMD)*(J - 1) + D 2030C 2031 DO NAI = 1, NT1AM(ISYMAI) 2032C 2033 NAIKJ = ISAIKJ(ISYAIK,ISYMJ) 2034 * + NCKI(ISYAIK)*(J - 1) 2035 * + ICKI(ISYMAI,ISYMK) 2036 * + NT1AM(ISYMAI)*(K-1) + NAI 2037C 2038 NAIK = ICKI(ISYMAI,ISYMK)+ NT1AM(ISYMAI)*(K - 1)+ NAI 2039C 2040 TMAT(NAIKJ) = TWO*T1AM(NDJ)*WORK(NAIK) 2041C 2042 ENDDO 2043 ENDDO 2044 ENDDO 2045 ENDDO 2046C 2047C-------------------------------------- 2048C Sum the result into SMAT. 2049C-------------------------------------- 2050C 2051 DO I = 1, NCKIJ(JSAIKJ) 2052C First : 2053 QMAT(I) = QMAT(I) + TMAT(I) 2054C Second : 2055 QMAT(I) = QMAT(I) - TMAT(INDSQ(I,3)) 2056 ENDDO 2057C 2058 endif 2059C 2060C----------------------------------------------------------------------- 2061C Contribution from both Fock terms 2062C----------------------------------------------------------------------- 2063C 2064 if (.true.) then 2065C 2066 ISYMK = MULD2H(ISINT2,ISYMB) 2067 ISYAIJ = MULD2H(ISYMT2,ISYMD) 2068 NBKTEMP = IT1AM(ISYMB,ISYMK) + B 2069 JSAIKJ = MULD2H(ISYMK,ISYAIJ) 2070C 2071 CALL DZERO(TMAT,NCKIJ(JSAIKJ)) 2072C 2073 DO ISYMJ = 1, NSYM 2074 ISYMAI = MULD2H(ISYAIJ,ISYMJ) 2075 ISYMDJ = MULD2H(ISYMD,ISYMJ) 2076 ISYAIK = MULD2H(ISYMK,ISYMAI) 2077 DO ISYMI = 1, NSYM 2078 ISYMA = MULD2H(ISYMAI,ISYMI) 2079 ISYMAJ = MULD2H(ISYMA,ISYMJ) 2080 ISYMDI = MULD2H(ISYMD,ISYMI) 2081C 2082 DO J = 1, NRHF(ISYMJ) 2083 NDJ = IT1AM(ISYMD,ISYMJ) + NVIR(ISYMD)*(J-1) + D 2084C 2085 DO I = 1, NRHF(ISYMI) 2086 DO A = 1, NVIR(ISYMA) 2087C 2088 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I-1) + A 2089C 2090C Index for sorted T2 amplitudes. 2091C 2092 NAIDJ = IT2SP(ISYAIJ,ISYMD) 2093 * + NCKI(ISYAIJ)*(D - 1) 2094 * + ICKI(ISYMAI,ISYMJ) 2095 * + NT1AM(ISYMAI)*(J - 1) + NAI 2096C 2097 NAIKJTEMP = ISAIKJ(ISYAIK,ISYMJ) 2098 * + NCKI(ISYAIK)*(J - 1) 2099 * + ICKI(ISYMAI,ISYMK) 2100 * + NAI 2101C 2102 DO K = 1, NRHF(ISYMK) 2103C 2104 NBK = NBKTEMP + NVIR(ISYMB)*(K-1) 2105 NAIKJ = NAIKJTEMP 2106 * + NT1AM(ISYMAI)*(K-1) 2107C 2108 TMAT(NAIKJ) = TWO*T2TCME(NAIDJ)*FOCK(NBK) 2109C 2110 ENDDO 2111 ENDDO 2112 ENDDO 2113 ENDDO 2114 ENDDO 2115 ENDDO 2116C 2117C------------------------------------ 2118C Sum the result into SMAT. 2119C------------------------------------ 2120C 2121 DO I = 1, NCKIJ(JSAIKJ) 2122 ! First term 2123 QMAT(I) = QMAT(I) + TMAT(I) 2124 ! Second term 2125 QMAT(I) = QMAT(I) - TMAT(INDSQ(I,3)) 2126 ENDDO 2127C 2128 endif 2129C---------------------------------------------- 2130C Virtual contribution of L term. 2131C---------------------------------------------- 2132C 2133 ISYMBD = MULD2H(ISYMB,ISYMD) 2134 ISYRES = MULD2H(ISINT2,ISYMT2) 2135 JSAIKJ = MULD2H(ISYMBD,ISYRES) 2136 ISYMFK = MULD2H(ISYMBD,ISINT2) 2137C 2138 LENGTH = NCKIJ(JSAIKJ) 2139C 2140 IF (LWORK .LT. LENGTH) THEN 2141 CALL QUIT('Insufficient core in CCSDT_SMAT') 2142 ENDIF 2143C 2144 if (.true.) then 2145C 2146 DO ISYMK = 1,NSYM 2147C 2148 ISYMF = MULD2H(ISYMK,ISYMFK) 2149 ISYAIJ = MULD2H(ISYMK,JSAIKJ) 2150C 2151 KOFF1 = IT2SP(ISYAIJ,ISYMF) + 1 2152 KOFF2 = ICKATR(ISYMFK,ISYMB) + NT1AM(ISYMFK)*(B - 1) 2153 * + IT1AM(ISYMF,ISYMK) + 1 2154 KOFF3 = ISAIKJ(ISYAIJ,ISYMK) + 1 2155C 2156 NTOAIJ = MAX(1,NCKI(ISYAIJ)) 2157 NVIRF = MAX(NVIR(ISYMF),1) 2158C 2159 CALL DGEMM('N','N',NCKI(ISYAIJ),NRHF(ISYMK), 2160 * NVIR(ISYMF),ONE,T2TCME(KOFF1),NTOAIJ, 2161 * TRVIR6(KOFF2),NVIRF,ZERO, 2162 * WORK(KOFF3),NTOAIJ) 2163C 2164 ENDDO 2165C 2166C CALL CC_GATHER(LENGTH,SMAT,WORK,INDSQ(1,3)) 2167 DO I = 1,LENGTH 2168 QMAT(I) = QMAT(I) + TWO*WORK(INDSQ(I,3)) 2169 ENDDO 2170C 2171 IF (IPRINT .GT. 55) THEN 2172 XQMAT = DDOT(NCKIJ(JSAIKJ),QMAT,1,QMAT,1) 2173 WRITE(LUPRI,*) 'In CCFOP_QMAT: 1. Norm of QMAT ',XQMAT 2174 ENDIF 2175C 2176 endif 2177C 2178C---------------------------------------------- 2179C Virtual contribution of g term. 2180C---------------------------------------------- 2181C 2182 ISYMBD = MULD2H(ISYMB,ISYMD) 2183 ISYRES = MULD2H(ISINT2,ISYMT2) 2184 JSAIKJ = MULD2H(ISYMBD,ISYRES) 2185 ISYMFK = MULD2H(ISYMBD,ISINT2) 2186C 2187 LENGTH = NCKIJ(JSAIKJ) 2188C 2189 IF (LWORK .LT. LENGTH) THEN 2190 CALL QUIT('Insufficient core in CCSDT_SMAT') 2191 ENDIF 2192C 2193 if (.true.) then 2194C 2195 DO ISYMK = 1,NSYM 2196C 2197 ISYMF = MULD2H(ISYMK,ISYMFK) 2198 ISYAIJ = MULD2H(ISYMK,JSAIKJ) 2199C 2200 KOFF1 = IT2SP(ISYAIJ,ISYMF) + 1 2201 KOFF2 = ICKATR(ISYMFK,ISYMB) + NT1AM(ISYMFK)*(B - 1) 2202 * + IT1AM(ISYMF,ISYMK) + 1 2203 KOFF3 = ISAIKJ(ISYAIJ,ISYMK) + 1 2204C 2205 NTOAIJ = MAX(1,NCKI(ISYAIJ)) 2206 NVIRF = MAX(NVIR(ISYMF),1) 2207C 2208 CALL DGEMM('N','N',NCKI(ISYAIJ),NRHF(ISYMK), 2209 * NVIR(ISYMF),ONE,T2TCME(KOFF1),NTOAIJ, 2210 * TRVIR3(KOFF2),NVIRF,ZERO, 2211 * WORK(KOFF3),NTOAIJ) 2212C 2213 ENDDO 2214C 2215 DO I = 1,LENGTH 2216 QMAT(I) = QMAT(I) - TWO*WORK(INDSQ(I,2)) 2217 ENDDO 2218C 2219 IF (IPRINT .GT. 55) THEN 2220 XQMAT = DDOT(NCKIJ(JSAIKJ),QMAT,1,QMAT,1) 2221 WRITE(LUPRI,*) 'In CCFOP_QMAT: 2. Norm of QMAT ',XQMAT 2222 ENDIF 2223C 2224C 2225 endif 2226C 2227C---------------------------------------- 2228C Occupied L contribution. 2229C---------------------------------------- 2230C 2231 ISYAIL = MULD2H(ISYMD,ISYMT2) 2232 ISYLKJ = MULD2H(ISYMB,ISINT2) 2233C 2234 if (.true.) then 2235C 2236 DO ISYMJ = 1,NSYM 2237C 2238 ISYMLK = MULD2H(ISYMJ,ISYLKJ) 2239C 2240 DO J = 1,NRHF(ISYMJ) 2241C 2242 DO ISYMK = 1,NSYM 2243C 2244 ISYML = MULD2H(ISYMK,ISYMLK) 2245 ISYMAI = MULD2H(ISYAIL,ISYML) 2246 ISYAIK = MULD2H(ISYMAI,ISYMK) 2247C 2248 KOFF1 = IT2SP(ISYAIL,ISYMD) 2249 * + NCKI(ISYAIL)*(D - 1) 2250 * + ICKI(ISYMAI,ISYML) + 1 2251 KOFF2 = ISJIKA(ISYLKJ,ISYMB) 2252 * + NMAJIK(ISYLKJ)*(B - 1) 2253 * + ISJIK(ISYMLK,ISYMJ) 2254 * + NMATIJ(ISYMLK)*(J - 1) 2255 * + IMATIJ(ISYML,ISYMK) + 1 2256 KOFF3 = ISAIKJ(ISYAIK,ISYMJ) 2257 * + NCKI(ISYAIK)*(J - 1) 2258 * + ICKI(ISYMAI,ISYMK) + 1 2259C 2260 NTOTAI = MAX(1,NT1AM(ISYMAI)) 2261 NRHFL = MAX(1,NRHF(ISYML)) 2262C 2263 CALL DGEMM('N','N',NT1AM(ISYMAI),NRHF(ISYMK), 2264 * NRHF(ISYML),-TWO,T2TCME(KOFF1),NTOTAI, 2265 * TROCC2(KOFF2),NRHFL,ONE,QMAT(KOFF3), 2266 * NTOTAI) 2267C 2268 ENDDO 2269 ENDDO 2270 ENDDO 2271C 2272 IF (IPRINT .GT. 55) THEN 2273 XQMAT = DDOT(NCKIJ(JSAIKJ),QMAT,1,QMAT,1) 2274 WRITE(LUPRI,*) 'In CCFOP_QMAT: 3. Norm of QMAT ',XQMAT 2275 ENDIF 2276C 2277 endif 2278C--------------------------------------- 2279C Occupied g contribution. 2280C--------------------------------------- 2281C 2282 ISYAIL = MULD2H(ISYMD,ISYMT2) 2283 ISYLKJ = MULD2H(ISYMB,ISINT2) 2284C 2285 if (.true.) then 2286C 2287 DO ISYMJ = 1,NSYM 2288C 2289 ISYMLK = MULD2H(ISYMJ,ISYLKJ) 2290C 2291 DO J = 1,NRHF(ISYMJ) 2292C 2293 DO ISYMK = 1,NSYM 2294C 2295 ISYML = MULD2H(ISYMK,ISYMLK) 2296 ISYMAI = MULD2H(ISYAIL,ISYML) 2297 ISYAIK = MULD2H(ISYMAI,ISYMK) 2298C 2299 KOFF1 = IT2SP(ISYAIL,ISYMD) 2300 * + NCKI(ISYAIL)*(D - 1) 2301 * + ICKI(ISYMAI,ISYML) + 1 2302 KOFF2 = ISJIKA(ISYLKJ,ISYMB) 2303 * + NMAJIK(ISYLKJ)*(B - 1) 2304 * + ISJIK(ISYMLK,ISYMJ) 2305 * + NMATIJ(ISYMLK)*(J - 1) 2306 * + IMATIJ(ISYML,ISYMK) + 1 2307 KOFF3 = ISAIKJ(ISYAIK,ISYMJ) 2308 * + NCKI(ISYAIK)*(J - 1) 2309 * + ICKI(ISYMAI,ISYMK) + 1 2310C 2311 NTOTAI = MAX(1,NT1AM(ISYMAI)) 2312 NRHFL = MAX(1,NRHF(ISYML)) 2313C 2314 CALL DGEMM('N','N',NT1AM(ISYMAI),NRHF(ISYMK), 2315 * NRHF(ISYML),-TWO,T2TCME(KOFF1),NTOTAI, 2316 * TROCC(KOFF2),NRHFL,ZERO,TMAT(KOFF3), 2317 * NTOTAI) 2318C 2319 ENDDO 2320 ENDDO 2321 ENDDO 2322C 2323 DO I = 1,NCKIJ(JSAIKJ) 2324 QMAT(I) = QMAT(I) - TMAT(INDSQ(I,1)) 2325 ENDDO 2326C 2327 IF (IPRINT .GT. 55) THEN 2328 XQMAT = DDOT(NCKIJ(JSAIKJ),QMAT,1,QMAT,1) 2329 WRITE(LUPRI,*) 'In CCFOP_QMAT: 4. Norm of QMAT ',XQMAT 2330 ENDIF 2331C 2332 endif 2333C 2334C----------------------------------------- 2335C Divide by the Fock matrix diagonals. 2336C----------------------------------------- 2337C 2338 NB = IORB(ISYMB) + NRHF(ISYMB) + B 2339 ND = IORB(ISYMD) + NRHF(ISYMD) + D 2340C 2341 EPSIBD = FOCKD(NB) + FOCKD(ND) - ECURR 2342C 2343 DO L = 1,NCKIJ(JSAIKJ) 2344 QMAT(L) = QMAT(L)/(DIAG(L) + EPSIBD) 2345 ENDDO 2346C 2347 IF (IPRINT .GT. 55) THEN 2348 XQMAT = DDOT(NCKIJ(JSAIKJ),QMAT,1,QMAT,1) 2349 WRITE(LUPRI,*) 'In CCFOP_SMAT: 5. Norm of QMAT ',XQMAT 2350 ENDIF 2351C 2352C---------------------- 2353C Print if desired. 2354C---------------------- 2355CC 2356C IF (IPRCC .GT. 75) THEN 2357CC 2358C CALL AROUND('The S matrix') 2359C WRITE(LUPRI,*) 2360C WRITE(LUPRI,'(2X,A,I4)') 'JSAIKJ ', JSAIKJ 2361C WRITE(LUPRI,'(2X,A,4I4)') 'isymb,b,isymd,d',ISYMB,B,ISYMD,D 2362C WRITE(LUPRI,*) 2363CC 2364C DO ISYMJ = 1,NSYM 2365CC 2366C ISYAIK = MULD2H(JSAIKJ,ISYMJ) 2367CC 2368C DO J = 1,NRHF(ISYMJ) 2369CC 2370C WRITE(LUPRI,'(5X,A,2I4)') 'isymj,j',ISYMJ,J 2371C WRITE(LUPRI,*) 2372CC 2373C DO ISYMK = 1,NSYM 2374CC 2375C ISYMAI = MULD2H(ISYAIK,ISYMK) 2376CC 2377C DO K = 1,NRHF(ISYMK) 2378CC 2379C WRITE(LUPRI,'(8X,A,2I4)') 'isymk,k',ISYMK,K 2380C WRITE(LUPRI,*) 2381CC 2382C DO ISYMI = 1,NSYM 2383CC 2384C ISYMA = MULD2H(ISYMAI,ISYMI) 2385CC 2386C KOFF1 = ISAIKJ(ISYAIK,ISYMJ) 2387C * + NCKI(ISYAIK)*(J - 1) 2388C * + ICKI(ISYMAI,ISYMK) 2389C * + NT1AM(ISYMAI)*(K - 1) 2390C * + IT1AM(ISYMA,ISYMI) + 1 2391CC 2392C CALL OUTPUT(QMAT(KOFF1),1,NVIR(ISYMA),1, 2393C * NRHF(ISYMI),NVIR(ISYMA), 2394C * NRHF(ISYMI),1,LUPRI) 2395CC 2396C ENDDO 2397C ENDDO 2398C ENDDO 2399C ENDDO 2400C ENDDO 2401CC 2402C END IF 2403CC 2404C--------------------------------- 2405C Finish 2406C--------------------------------- 2407C 2408 CALL QEXIT('CCFOP_QMAT') 2409C 2410 RETURN 2411 END 2412C /* Deck ccfop_convir */ 2413 SUBROUTINE CCFOP_CONVIR(RMAT,SMAT,QMAT,TMAT,ISYMIM,TRVIR, 2414 * TRVIR1,ISYINT,WORK,LWORK,INDSQ,LENSQ, 2415 * ISYMB,B,ISYMD,D) 2416C 2417C K. Hald, Fall 2001, Nearly identical with cc3_convir. 2418C Need only one of the amplidudes. 2419C 2420C General symmetry: ISYMIM is the symmetry of the SMAT, QMAT 2421C and TMAT intermdiates. 2422C ISYINT is symmetry of FOCKAK and XIAJB 2423C ISYRES = ISYMIM*ISYINT 2424C 2425#include "implicit.h" 2426C 2427#include "priunit.h" 2428#include "ccorb.h" 2429#include "ccsdinp.h" 2430#include "ccsdsym.h" 2431C 2432 PARAMETER (ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0) 2433C 2434 DIMENSION RMAT(*),SMAT(*),QMAT(*) 2435 DIMENSION TMAT(*),TRVIR(*),TRVIR1(*) 2436 DIMENSION WORK(LWORK),INDSQ(LENSQ,6) 2437C 2438C INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 2439C 2440 CALL QENTER('CCFOP_CONVIR') 2441C 2442 ISYRES = MULD2H(ISYMIM,ISYINT) 2443C 2444 ISYMBD = MULD2H(ISYMB,ISYMD) 2445 ISCKIJ = MULD2H(ISYMBD,ISYMIM) 2446C 2447 LENGTH = NCKIJ(ISCKIJ) 2448C 2449C------------------------ 2450C First virtual term. 2451C------------------------ 2452C 2453 IF (LWORK .LT. NCKIJ(ISCKIJ)) THEN 2454 CALL QUIT('Insufficient core in CCSDT_CONVIR') 2455 ENDIF 2456C 2457C 2458 DO I = 1,LENGTH 2459C 2460 TMAT(I) = - SMAT(INDSQ(I,1)) 2461 * - QMAT(INDSQ(I,2)) 2462C 2463 ENDDO 2464C 2465C--------------------------- 2466C Contract with (ac|kd). 2467C--------------------------- 2468C 2469 DO ISYMJ = 1,NSYM 2470C 2471 ISYMBJ = MULD2H(ISYMB,ISYMJ) 2472 ISYMAI = MULD2H(ISYMBJ,ISYRES) 2473 ISYCKI = MULD2H(ISCKIJ,ISYMJ) 2474C 2475 KSCR1 = 1 2476 KEND1 = KSCR1 + NT1AM(ISYMAI) 2477 LWRK1 = LWORK - KEND1 2478C 2479 IF (LWRK1 .LT. 0) THEN 2480 CALL QUIT('Insufficient work space in CCSDT_CONVIR') 2481 ENDIF 2482C 2483 DO J = 1,NRHF(ISYMJ) 2484C 2485 DO ISYMI = 1,NSYM 2486C 2487 ISYMCK = MULD2H(ISYCKI,ISYMI) 2488 ISYMA = MULD2H(ISYMAI,ISYMI) 2489C 2490 NTOTCK = MAX(NT1AM(ISYMCK),1) 2491 NVIRA = MAX(NVIR(ISYMA),1) 2492C 2493 KOFF1 = ICKATR(ISYMCK,ISYMA) + 1 2494 KOFF2 = ISAIKJ(ISYCKI,ISYMJ) 2495 * + NCKI(ISYCKI)*(J - 1) 2496 * + ISAIK(ISYMCK,ISYMI) + 1 2497 KOFF3 = ISAIK(ISYMAI,ISYMJ) 2498 * + NT1AM(ISYMAI)*(J - 1) 2499 * + IT1AM(ISYMA,ISYMI) + 1 2500C 2501 CALL DGEMM('T','N',NVIR(ISYMA),NRHF(ISYMI),NT1AM(ISYMCK), 2502 * ONE,TRVIR(KOFF1),NTOTCK,TMAT(KOFF2),NTOTCK, 2503 * ONE,RMAT(KOFF3),NVIRA) 2504C 2505 ENDDO 2506 ENDDO 2507 ENDDO 2508C 2509C------------------------- 2510C Second virtual term. 2511C------------------------- 2512C 2513C 2514 DO I = 1,LENGTH 2515C 2516 TMAT(I) = - SMAT(I) 2517 * - QMAT(INDSQ(I,3)) 2518C 2519 ENDDO 2520C 2521C--------------------------- 2522C Contract with (ad|kc). 2523C--------------------------- 2524C 2525 DO ISYMJ = 1,NSYM 2526C 2527 ISYMBJ = MULD2H(ISYMB,ISYMJ) 2528 ISYMAI = MULD2H(ISYMBJ,ISYRES) 2529 ISYCKI = MULD2H(ISCKIJ,ISYMJ) 2530C 2531 KSCR1 = 1 2532 KEND1 = KSCR1 + NT1AM(ISYMAI) 2533 LWRK1 = LWORK - KEND1 2534C 2535 IF (LWRK1 .LT. 0) THEN 2536 CALL QUIT('Insufficient work space in CCSDT_CONVIR') 2537 ENDIF 2538C 2539 DO J = 1,NRHF(ISYMJ) 2540C 2541 DO ISYMI = 1,NSYM 2542C 2543 ISYMCK = MULD2H(ISYCKI,ISYMI) 2544 ISYMA = MULD2H(ISYMAI,ISYMI) 2545C 2546 NTOTCK = MAX(NT1AM(ISYMCK),1) 2547 NVIRA = MAX(NVIR(ISYMA),1) 2548C 2549 KOFF1 = ICKATR(ISYMCK,ISYMA) + 1 2550 KOFF2 = ISAIKJ(ISYCKI,ISYMJ) 2551 * + NCKI(ISYCKI)*(J - 1) 2552 * + ISAIK(ISYMCK,ISYMI) + 1 2553 KOFF3 = ISAIK(ISYMAI,ISYMJ) 2554 * + NT1AM(ISYMAI)*(J - 1) 2555 * + IT1AM(ISYMA,ISYMI) + 1 2556C 2557 CALL DGEMM('T','N',NVIR(ISYMA),NRHF(ISYMI),NT1AM(ISYMCK), 2558 * ONE,TRVIR1(KOFF1),NTOTCK,TMAT(KOFF2),NTOTCK, 2559 * ONE,RMAT(KOFF3),NVIRA) 2560C 2561 ENDDO 2562 ENDDO 2563 ENDDO 2564C 2565 CALL QEXIT('CCFOP_CONVIR') 2566C 2567 RETURN 2568 END 2569C /* Deck ccfop_conocc */ 2570 SUBROUTINE CCFOP_CONOCC(OMEGA2,RMAT1,RMAT2,SMAT,TMAT,ISYMIM, 2571 * TROCC,TROCC1,ISYINT,WORK,LWORK,INDSQ, 2572 * LENSQ,ISYMIB,IB,ISYMID,ID) 2573C 2574C Kasper Hald, Fall 2001. 2575C Nearly identical to cc3_conocc by 2576C Henrik Koch and Alfredo Sanchez. Dec 1994 2577C Ove Christiansen 9-1-1996 2578C 2579C Set up combinations of S's and contract with integrals. 2580C 2581C General symmetry: ISYMIM is symmetry of SMAT and TMAT intermediates. 2582C (including isymib*isymid) 2583C ISYINT is symmetry of integrals in TROCC and TROCC1. 2584C ISYRES = ISYMIM*ISYINT 2585C 2586#include "implicit.h" 2587C 2588#include "priunit.h" 2589#include "ccorb.h" 2590#include "ccsdinp.h" 2591#include "ccsdsym.h" 2592C 2593 PARAMETER (ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0) 2594C 2595 DIMENSION OMEGA2(*),RMAT1(*),RMAT2(*),SMAT(*),TMAT(*) 2596 DIMENSION TROCC(*),TROCC1(*),WORK(LWORK),INDSQ(LENSQ,6) 2597C 2598 INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 2599C 2600 CALL QENTER('CCFOP_CONOCC') 2601C 2602 IF (LWORK .LT. LENSQ) THEN 2603 CALL QUIT('Insufficient core in CONOCC') 2604 ENDIF 2605C 2606 ISYRES = MULD2H(ISYMIM,ISYINT) 2607C 2608C------------------------- 2609C First occupied term. 2610C------------------------- 2611C 2612 C = ID 2613 B = IB 2614C 2615 ISYMC = ISYMID 2616 ISYMB = ISYMIB 2617C 2618 ISYMBC = MULD2H(ISYMB,ISYMC) 2619 JSAIKL = MULD2H(ISYMBC,ISYMIM) 2620C 2621 LENGTH = NCKIJ(JSAIKL) 2622C 2623C---------------------------------- 2624C Setup combinations of smat's. 2625C---------------------------------- 2626C 2627 DO I = 1,LENGTH 2628C 2629C TMAT(I) = SMAT(I) 2630C * - TWO*SMAT(INDSQ(I,3)) 2631C * + SMAT(INDSQ(I,4)) 2632C 2633 TMAT(I) = - SMAT(INDSQ(I,3)) 2634C 2635 ENDDO 2636C 2637C---------------------------------- 2638C Symmetry sorting if symmetry. 2639C---------------------------------- 2640C 2641 IF (NSYM .GT. 1) THEN 2642 CALL CC_GATHER(LENGTH,WORK,TMAT,INDSQ(1,6)) 2643 CALL DCOPY(LENGTH,WORK,1,TMAT,1) 2644 ENDIF 2645C 2646 IF (IPRINT .GT. 55) THEN 2647 XTMAT = DDOT(NCKIJ(JSAIKL),TMAT,1,TMAT,1) 2648 WRITE(LUPRI,*) 'In CC3_CONOCC: 1. Norm of TMAT = ',XTMAT 2649 ENDIF 2650C 2651C----------------------- 2652C First contraction. 2653C----------------------- 2654C 2655 DO ISYMJ = 1,NSYM 2656C 2657 ISYMBJ = MULD2H(ISYMB,ISYMJ) 2658 ISYMAI = MULD2H(ISYMBJ,ISYRES) 2659 ISYMKL = MULD2H(JSAIKL,ISYMAI) 2660 ISYKLJ = MULD2H(ISYMKL,ISYMJ) 2661C 2662 NTOTAI = MAX(NT1AM(ISYMAI),1) 2663 NTOTKL = MAX(NMATIJ(ISYMKL),1) 2664C 2665 KOFF1 = ISAIKL(ISYMAI,ISYMKL) + 1 2666 KOFF2 = ISJIKA(ISYKLJ,ISYMC) 2667 * + NMAJIK(ISYKLJ)*(C - 1) 2668 * + ISJIK(ISYMKL,ISYMJ) + 1 2669 KOFF3 = ISAIK(ISYMAI,ISYMJ) + 1 2670C 2671 CALL DGEMM('N','N',NT1AM(ISYMAI),NRHF(ISYMJ),NMATIJ(ISYMKL), 2672 * -ONE,TMAT(KOFF1),NTOTAI,TROCC(KOFF2),NTOTKL, 2673 * ONE,RMAT2(KOFF3),NTOTAI) 2674C 2675 ENDDO 2676C 2677 IF (IPRINT .GT. 55) THEN 2678 XRMAT = DDOT(NCKI(ISYRES),RMAT2,1,RMAT2,1) 2679 WRITE(LUPRI,*) 'In CC3_CONOCC: Norm of RMAT2 = ',XRMAT 2680 ENDIF 2681C 2682C-------------------------- 2683C Second occupied term. 2684C-------------------------- 2685C 2686 B = ID 2687 C = IB 2688C 2689 ISYMB = ISYMID 2690 ISYMC = ISYMIB 2691C 2692 ISYMBC = MULD2H(ISYMB,ISYMC) 2693 JSAIKL = MULD2H(ISYMBC,ISYMIM) 2694C 2695 LENGTH = NCKIJ(JSAIKL) 2696C 2697C---------------------------------- 2698C Setup combinations of smat's. 2699C---------------------------------- 2700C 2701 DO I = 1,LENGTH 2702C 2703C TMAT(I) = - TWO*SMAT(I) 2704C * + SMAT(INDSQ(I,3)) 2705C * + SMAT(INDSQ(I,5)) 2706C 2707 TMAT(I) = - SMAT(I) 2708C 2709 ENDDO 2710C 2711C---------------------------------- 2712C Symmetry sorting if symmetry. 2713C---------------------------------- 2714C 2715 IF (NSYM .GT. 1) THEN 2716 CALL CC_GATHER(LENGTH,WORK,TMAT,INDSQ(1,6)) 2717 CALL DCOPY(LENGTH,WORK,1,TMAT,1) 2718 ENDIF 2719C 2720 IF (IPRINT .GT. 55) THEN 2721 XTMAT = DDOT(NCKIJ(JSAIKL),TMAT,1,TMAT,1) 2722 WRITE(LUPRI,*) 'In CC3_CONOCC: 2. Norm of TMAT = ',XTMAT 2723 ENDIF 2724C 2725C------------------------ 2726C Second contraction. 2727C------------------------ 2728C 2729 DO ISYMJ = 1,NSYM 2730C 2731 ISYMBJ = MULD2H(ISYMB,ISYMJ) 2732 ISYMAI = MULD2H(ISYMBJ,ISYRES) 2733 ISYMKL = MULD2H(JSAIKL,ISYMAI) 2734 ISYKLJ = MULD2H(ISYMKL,ISYMJ) 2735C 2736 NTOTAI = MAX(NT1AM(ISYMAI),1) 2737 NTOTKL = MAX(NMATIJ(ISYMKL),1) 2738C 2739 KOFF1 = ISAIKL(ISYMAI,ISYMKL) + 1 2740 KOFF2 = ISJIKA(ISYKLJ,ISYMC) 2741 * + NMAJIK(ISYKLJ)*(C - 1) 2742 * + ISJIK(ISYMKL,ISYMJ) + 1 2743 KOFF3 = ISAIK(ISYMAI,ISYMJ) + 1 2744C 2745 CALL DGEMM('N','N',NT1AM(ISYMAI),NRHF(ISYMJ),NMATIJ(ISYMKL), 2746 * -ONE,TMAT(KOFF1),NTOTAI,TROCC(KOFF2),NTOTKL, 2747 * ONE,RMAT1(KOFF3),NTOTAI) 2748C 2749 ENDDO 2750C 2751 IF (IPRINT .GT. 55) THEN 2752 XRMAT = DDOT(NCKI(ISYRES),RMAT1,1,RMAT1,1) 2753 WRITE(LUPRI,*) 'In CC3_CONOCC: Norm of RMAT1 = ',XRMAT 2754 ENDIF 2755C 2756C------------------------- 2757C Third occupied term. 2758C------------------------- 2759C 2760 A = ID 2761 B = IB 2762C 2763 ISYMA = ISYMID 2764 ISYMB = ISYMIB 2765C 2766 ISYMAB = MULD2H(ISYMA,ISYMB) 2767 JSCKLI = MULD2H(ISYMAB,ISYMIM) 2768C 2769 LENGTH = NCKIJ(JSCKLI) 2770C 2771C---------------------------------- 2772C Setup combinations of smat's. 2773C---------------------------------- 2774C 2775 DO I = 1,LENGTH 2776C 2777C TMAT(I) = SMAT(INDSQ(I,5)) 2778C * - TWO*SMAT(INDSQ(I,2)) 2779C * + SMAT(INDSQ(I,3)) 2780C 2781 TMAT(I) = - SMAT(INDSQ(I,2)) 2782C 2783 ENDDO 2784C 2785 IF (IPRINT .GT. 55) THEN 2786 XTMAT = DDOT(NCKIJ(JSAIKL),TMAT,1,TMAT,1) 2787 WRITE(LUPRI,*) 'In CC3_CONOCC: 3. Norm of TMAT = ',XTMAT 2788 ENDIF 2789C 2790C----------------------- 2791C Third contraction. 2792C----------------------- 2793C 2794 DO ISYMJ = 1,NSYM 2795C 2796 ISYMBJ = MULD2H(ISYMB,ISYMJ) 2797 ISYMAI = MULD2H(ISYMBJ,ISYRES) 2798 ISYMI = MULD2H(ISYMAI,ISYMA) 2799 ISYCKL = MULD2H(ISYMI,JSCKLI) 2800C 2801 IF (LWORK .LT. NRHF(ISYMI)*NRHF(ISYMJ)) THEN 2802 CALL QUIT('Insufficient memory in CCSDT_CONOCC') 2803 END IF 2804C 2805 NTOCKL = MAX(NCKI(ISYCKL),1) 2806 NRHFI = MAX(NRHF(ISYMI),1) 2807C 2808 KOFF1 = ISAIKJ(ISYCKL,ISYMI) + 1 2809 KOFF2 = ISAIKJ(ISYCKL,ISYMJ) + 1 2810 KOFF3 = 1 2811C 2812 CALL DGEMM('T','N',NRHF(ISYMI),NRHF(ISYMJ),NCKI(ISYCKL), 2813 * ONE,TMAT(KOFF1),NTOCKL,TROCC1(KOFF2),NTOCKL, 2814 * ZERO,WORK(KOFF3),NRHFI) 2815C 2816 DO J = 1,NRHF(ISYMJ) 2817C 2818 NBJ = IT1AM(ISYMB,ISYMJ) + NVIR(ISYMB)*(J - 1) + B 2819C 2820 IF (ISYMAI.EQ.ISYMBJ) THEN 2821C 2822 DO I = 1,NRHF(ISYMI) 2823C 2824 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + A 2825C 2826 KOFF5 = IT2AM(ISYMAI,ISYMBJ) 2827 * + INDEX(NAI,NBJ) 2828C 2829 KOFF6 = NRHF(ISYMI)*(J - 1) + I 2830C 2831 IF (NAI .EQ. NBJ) WORK(KOFF6) = TWO*WORK(KOFF6) 2832C 2833 OMEGA2(KOFF5) = OMEGA2(KOFF5) - WORK(KOFF6) 2834C 2835 ENDDO 2836C 2837 ELSE IF (ISYMAI .LT. ISYMBJ) THEN 2838C 2839 DO I = 1,NRHF(ISYMI) 2840C 2841 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + A 2842C 2843 KOFF5 = IT2AM(ISYMAI,ISYMBJ) 2844 * + NT1AM(ISYMAI)*(NBJ-1) + NAI 2845C 2846 KOFF6 = NRHF(ISYMI)*(J - 1) + I 2847 OMEGA2(KOFF5) = OMEGA2(KOFF5) - WORK(KOFF6) 2848C 2849 ENDDO 2850C 2851 ELSE IF (ISYMBJ .LT. ISYMAI) THEN 2852C 2853 DO I = 1,NRHF(ISYMI) 2854C 2855 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + A 2856C 2857 KOFF5 = IT2AM(ISYMAI,ISYMBJ) 2858 * + NT1AM(ISYMBJ)*(NAI-1) + NBJ 2859C 2860 KOFF6 = NRHF(ISYMI)*(J - 1) + I 2861 OMEGA2(KOFF5) = OMEGA2(KOFF5) - WORK(KOFF6) 2862C 2863 ENDDO 2864C 2865 ENDIF 2866C 2867 ENDDO 2868C 2869 ENDDO 2870C 2871 CALL QEXIT('CCFOP_CONOCC') 2872C 2873 RETURN 2874 END 2875C------------------------------------------------------------------------- Sonia 2876C /* Deck ccsdpt_dens2 */ 2877 SUBROUTINE CCSDPT_DENS2(T1AM,ISYMT1,T2TP,ISYMT2,MODEL, 2878 * L1AM,ISYML1,L2TP,ISYML2,WORK,LWORK, 2879 * LUDELD,FNDELD,LUCKJD,FNCKJD,LUDKBC,FNDKBC, 2880 * LUTOC,FNTOC,LU3VI,FN3VI,LUDKBC3,FNDKBC3, 2881 * LU3FOP,FN3FOP,LU3FOP2,FN3FOP2, 2882 * LU3FOPX,FN3FOPX,LU3FOP2X,FN3FOP2X) 2883C 2884C Written by K. Hald, Fall 2001. 2885C 2886C Calculate the triples contribution to the electronic densities 2887C in the MO basis and store them on file. 2888C Calculate also the diagonal kappabar multipliers if (RELORB). 2889C 2890C ISYMT2 is symmetry of T2TP 2891C ISYMT1 is symmetry of T1AM 2892C Isyres = isymt1*isymt2*isymop 2893C 2894C For CCSD(T) LUDKBC3, FNDKBC3 is actually LU3VI2, FN3VI2 2895C For CCSD(T) we do not use LUDELD,FNDELD,LUCKJD,FNCKJD,LUDKBC,FNDKBC 2896C 2897 IMPLICIT NONE 2898C 2899#include "priunit.h" 2900#include "dummy.h" 2901#include "iratdef.h" 2902#include "ccsdsym.h" 2903#include "inftap.h" 2904#include "ccinftap.h" 2905#include "ccorb.h" 2906#include "ccsdinp.h" 2907#include "ccfop.h" 2908#include "second.h" 2909C 2910 INTEGER ISYMTR, ISYMT1, ISYMT2, ISYML1, ISYML2, LWORK 2911 INTEGER ISYRES, ISINT1, ISINT2, ISYMIM, KFOCKD 2912 INTEGER KOMG22, KCMO, KEND0, LWRK0, KTROC2 2913 INTEGER KTROC0, KXIAJB, KEND1, LWRK1, KINTOC, KEND2, LWRK2 2914 INTEGER LENGTH, ISYOPE, IOPTTCME, IOFF, ISYMD, ISAIJ1, ISYCKB 2915 INTEGER ISCKB1, ISCKB2, KTRVI1, KTRVI2, KRMAT1, KTRVI0 2916 INTEGER KTRVI3, KEND3, LWRK3, KINTVI, KEND4, LWRK4, ISYMB 2917 INTEGER ISYALJ, ISAIJ2, ISYMBD, ISCKIJ, KSMAT2, KSMAT, KQMAT 2918 INTEGER KDIAG, ISYMC, ISYMK, KOFF1, KOFF2, KOFF3 2919 INTEGER KINDSQ, KINDEX, KTMAT, KRMAT2, LENSQ 2920 INTEGER LUFCK, KFCKBA, KT2TCME, IOPTT2, KTRVI4, KTRVI5 2921 INTEGER KTRVI6, KQMAT2, KVIR1, KVIR2, KVIR3, KVIR4, LUPTIA 2922 INTEGER LUPTIAJB, LUABI1, LUABI2, LUABI3, LUABI4, ISYAIB 2923 INTEGER ISYMAI, ISYAID, KOCC1, KOCC2, KOMG1, KUMAT, KUMAT2 2924 INTEGER LUAIJK, LUIAJK, LUPTAB, LUPTIJ, LUPTIA2 2925 INTEGER KTROC02, KTROC22, KTRVI7, KTRVI8, KTRVI9, KTRVI10 2926 INTEGER KTRVI11, KTRVI12, KTRVI13, KDENSAB, KDENSIJ 2927 INTEGER ISYCKD, ISCKD2, KSMAT3, KUMAT3, KEND5, LWRK5 2928 INTEGER KKAPAA, KKAPII, LUKAPAB, LUKAPIJ, ISYALJ2, KINDEX2 2929 INTEGER KSMAT4, KUMAT4, KOMG12, KLAMDP, KLAMDH 2930 INTEGER KTRVI14, KTRVI15, KTRVI16, KTRVI17, KTRVI18, KTRVI19 2931 INTEGER KTRVI20, ISYTMP, KTROC01, KTROC21, KTROC03, KTROC23 2932 INTEGER LUDELD, LUCKJD, LUDKBC, LUTOC, LU3VI, LUDKBC3, LU3FOP 2933 INTEGER LU3FOP2, LU3FOPX, LU3FOP2X 2934C 2935#if defined (SYS_CRAY) 2936 REAL T1AM(*), T2TP(*) 2937 REAL L1AM(*), L2TP(*) 2938 REAL WORK(LWORK), ONE 2939 REAL TITRAN, TISORT, TISMAT, TIQMAT, TIOME1 2940 REAL TICONV, TICONO, RHO1N, RHO2N 2941 REAL XT2TP, DDOT, XIAJB, XINT, XTROC, XTROC1, XTROC0 2942 REAL XTRVI0, XTRVI2, XTRVI3, XTRVI, XTRVI1, XDIA 2943 REAL XSMAT, XTMAT, XQMAT, XRMAT, ZERO, TWO, HALF 2944 REAL DTIME 2945#else 2946 DOUBLE PRECISION T1AM(*), T2TP(*) 2947 DOUBLE PRECISION L1AM(*), L2TP(*) 2948 DOUBLE PRECISION WORK(LWORK), ONE 2949 DOUBLE PRECISION TITRAN, TISORT, TISMAT, TIQMAT, TIOME1 2950 DOUBLE PRECISION TICONV, TICONO, RHO1N, RHO2N 2951 DOUBLE PRECISION XT2TP, DDOT, XIAJB, XINT, XTROC, XTROC1, XTROC0 2952 DOUBLE PRECISION XTRVI0, XTRVI2, XTRVI3, XTRVI, XTRVI1, XDIA 2953 DOUBLE PRECISION XSMAT, XTMAT, XQMAT, XRMAT, ZERO, TWO, HALF 2954 DOUBLE PRECISION DTIME 2955#endif 2956C 2957 LOGICAL C3LRSV, CC1ASV, CC1BSV, LDEBUG 2958 CHARACTER*(*) FNDELD, FNCKJD, FNDKBC, FNTOC, FN3VI, FNDKBC3 2959 CHARACTER*(*) FN3FOP, FN3FOP2 2960 CHARACTER*(*) FN3FOPX, FN3FOP2X 2961 CHARACTER*5 FNDPTIA, FNDPTAB, FNDPTIJ, FNKAPAB, FNKAPIJ 2962 CHARACTER*6 FNDPTIA2 2963 CHARACTER*7 FNDIAJB, FNDAIJK, FNDIAJK 2964 CHARACTER*8 FNDABI1, FNDABI2, FNDABI3, FNDABI4 2965 CHARACTER*10 MODEL 2966C 2967 PARAMETER (ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, TWO = 2.0D0) 2968 PARAMETER (LDEBUG = .FALSE.) 2969C 2970 CALL QENTER('CCSDPT_DENS2') 2971C 2972C------------------------------------------------------------- 2973C Set symmetry flags. 2974C 2975C omega = int1*T2*int2 2976C isymres is symmetry of result(omega) 2977C isint1 is symmetry of integrals in contraction.(int1) 2978C isint2 is symmetry of integrals in the triples equation.(int2) 2979C isymim is symmetry of S and Q intermediates.(t2*int2) 2980C (sym is for all index of S and Q (cbd,klj) 2981C thus cklj=b*d*isymim) 2982C------------------------------------------------------------- 2983C 2984 IPRCC = IPRINT 2985 ISYMTR = MULD2H(ISYMT1,ISYMT2) 2986 ISYRES = MULD2H(ISYMTR,ISYMOP) 2987 ISINT1 = ISYMOP 2988 ISINT2 = MULD2H(ISYMT1,ISYMOP) 2989 ISYMIM = MULD2H(ISYMTR,ISYMOP) 2990C 2991C-------------------- 2992C Time variables. 2993C-------------------- 2994C 2995 TITRAN = 0.0D0 2996 TISORT = 0.0D0 2997 TISMAT = 0.0D0 2998 TIQMAT = 0.0D0 2999 TICONO = 0.0D0 3000 TICONV = 0.0D0 3001 TIOME1 = 0.0D0 3002C 3003C-------------------------------------- 3004C Reorder the t2-amplitudes i T2TP. 3005C-------------------------------------- 3006C 3007 IF (LWORK .LT. NT2SQ(ISYMT2)) THEN 3008 CALL QUIT('Not enough memory to construct T2TP (CCSDPT_DENS2)') 3009 ENDIF 3010C 3011 CALL DCOPY(NT2SQ(ISYMT2),T2TP,1,WORK,1) 3012 CALL CC3_T2TP(T2TP,WORK,ISYMT2) 3013C 3014 IF (IPRINT .GT. 55) THEN 3015 XT2TP = DDOT(NT2SQ(ISYMT2),T2TP,1,T2TP,1) 3016 WRITE(LUPRI,*) 'Norm of T2TP ',XT2TP 3017 ENDIF 3018C 3019C----------------------------------------------- 3020C Reorder the l2-amplitudes i L2TP if CC3. 3021C----------------------------------------------- 3022C 3023 IF (CC3) THEN 3024C 3025 IF (LWORK .LT. NT2SQ(ISYML2)) THEN 3026 CALL QUIT('Not enough memory to construct L2TP') 3027 ENDIF 3028C 3029 CALL DCOPY(NT2SQ(ISYML2),L2TP,1,WORK,1) 3030 CALL CC3_T2TP(L2TP,WORK,ISYML2) 3031C 3032 IF (IPRINT .GT. 55) THEN 3033 XT2TP = DDOT(NT2SQ(ISYML2),L2TP,1,L2TP,1) 3034 WRITE(LUPRI,*) 'Norm of L2TP ',XT2TP 3035 ENDIF 3036C 3037 ENDIF 3038C 3039C--------------------------------------------------------- 3040C Read canonical orbital energies and MO coefficients. 3041C--------------------------------------------------------- 3042C 3043 KFOCKD = 1 3044 KOMG1 = KFOCKD + NORBTS 3045 KOMG22 = KOMG1 + NT1AM(ISYMOP) 3046 KFCKBA = KOMG22 + NT2AM(ISYMOP) 3047 KEND0 = KFCKBA + N2BST(ISYMOP) 3048C 3049 IF (CC3) THEN 3050 KLAMDP = KEND0 3051 KLAMDH = KLAMDP + NLAMDT 3052 KEND0 = KLAMDH + NLAMDT 3053 ELSE 3054 KCMO = KEND0 3055 KEND0 = KCMO + NLAMDS 3056 ENDIF 3057C 3058 LWRK0 = LWORK - KEND0 3059C 3060 IF (LWRK0 .LT. 0) THEN 3061 WRITE(LUPRI,*) 'Memory available : ',LWORK 3062 WRITE(LUPRI,*) 'Memory needed : ',KEND0 3063 CALL QUIT('Insufficient space in CCSDPT_DENS2') 3064 END IF 3065C 3066 CALL DZERO(WORK(KOMG1),NT1AM(ISYMOP)) 3067 CALL DZERO(WORK(KOMG22),NT2AM(ISYMOP)) 3068C 3069 CALL GPOPEN(LUSIFC,'SIRIFC','OLD',' ','UNFORMATTED',IDUMMY, 3070 & .FALSE.) 3071 REWIND LUSIFC 3072C 3073 CALL MOLLAB('TRCCINT ',LUSIFC,LUPRI) 3074 READ (LUSIFC) 3075 READ (LUSIFC) (WORK(KFOCKD+I-1), I=1,NORBTS) 3076C 3077 IF (.NOT. CC3) THEN 3078 READ (LUSIFC) (WORK(KCMO+I-1), I=1,NLAMDS) 3079 CALL CMO_REORDER(WORK(KCMO),WORK(KEND0),LWRK0) 3080 ENDIF 3081C 3082 CALL GPCLOSE(LUSIFC,'KEEP') 3083C 3084C--------------------------------------------- 3085C Delete frozen orbitals in Fock diagonal. 3086C--------------------------------------------- 3087C 3088 IF (FROIMP .OR. FROEXP) 3089 * CALL CCSD_DELFRO(WORK(KFOCKD),WORK(KEND0),LWRK0) 3090C 3091C---------------------------------------------- 3092C Calculate the lamda matrices for cc3 3093C---------------------------------------------- 3094C 3095 IF (CC3) THEN 3096 CALL LAMMAT(WORK(KLAMDP),WORK(KLAMDH),T1AM, 3097 * WORK(KEND0),LWRK0) 3098C 3099 IF (IPRINT .GT.100) THEN 3100 CALL AROUND('Usual Lambda matrices ') 3101 CALL CC_PRLAM(WORK(KLAMDP),WORK(KLAMDH),1) 3102 ENDIF 3103 ENDIF 3104C 3105C----------------------------------------------------- 3106C Construct the transformed Fock matrix 3107C----------------------------------------------------- 3108C 3109 LUFCK = -1 3110C 3111 IF (CC3) THEN 3112C This AO Fock matrix is constructed from the T1 transformed density 3113 CALL GPOPEN(LUFCK,'CC_FCKH','UNKNOWN',' ','UNFORMATTED', 3114 * IDUMMY,.FALSE.) 3115 ELSE 3116C This AO Fock matrix is constructed from the CMO transformed density 3117 CALL GPOPEN(LUFCK,'CC_FCKREF','UNKNOWN',' ','UNFORMATTED', 3118 * IDUMMY,.FALSE.) 3119 ENDIF 3120C 3121 REWIND(LUFCK) 3122 READ(LUFCK)(WORK(KFCKBA + I-1),I = 1,N2BST(ISYMOP)) 3123 CALL GPCLOSE(LUFCK,'KEEP' ) 3124C 3125 IF (IPRINT .GT. 140) THEN 3126 CALL AROUND( 'Usual Fock AO matrix' ) 3127 CALL CC_PRFCKAO(WORK(KFCKBA),ISYMOP) 3128 ENDIF 3129C 3130 ! SCF Fock matrix in transformed using CMO vector 3131 IF (CC3) THEN 3132 CALL CC_FCKMO(WORK(KFCKBA),WORK(KLAMDP),WORK(KLAMDH), 3133 * WORK(KEND0),LWRK0,1,1,1) 3134 ELSE 3135 CALL CC_FCKMO(WORK(KFCKBA),WORK(KCMO),WORK(KCMO), 3136 * WORK(KEND0),LWRK0,1,1,1) 3137 ENDIF 3138C 3139 IF (IPRINT .GT. 50) THEN 3140 CALL AROUND( 'In CC_ETA: Triples Fock MO matrix' ) 3141 CALL CC_PRFCKMO(WORK(KFCKBA),ISYMOP) 3142 ENDIF 3143C 3144C Sort the fock matrix 3145C 3146C 3147 CALL DCOPY(N2BST(ISINT1),WORK(KFCKBA),1,WORK(KEND0),1) 3148C 3149 DO ISYMC = 1,NSYM 3150C 3151 ISYMK = MULD2H(ISYMC,ISINT1) 3152C 3153 DO K = 1,NRHF(ISYMK) 3154C 3155 DO C = 1,NVIR(ISYMC) 3156C 3157 KOFF1 = KEND0 + IFCVIR(ISYMK,ISYMC) + 3158 * NORB(ISYMK)*(C - 1) + K - 1 3159 KOFF2 = KFCKBA + IT1AM(ISYMC,ISYMK) 3160 * + NVIR(ISYMC)*(K - 1) + C - 1 3161C 3162 WORK(KOFF2) = WORK(KOFF1) 3163C 3164 ENDDO 3165 ENDDO 3166 ENDDO 3167C 3168 IF (IPRINT .GT. 50) THEN 3169 CALL AROUND('In CCSDPT_DENS2: Triples Fock MO matrix (sort)') 3170 CALL CC_PRFCKMO(WORK(KFCKBA),ISYMOP) 3171 ENDIF 3172C 3173C------------------------------------------------------------------ 3174C Read in another T2 amplitude, and transform it to 2*C-E 3175C Square up to full matrix and reorder the index 3176C------------------------------------------------------------------ 3177C 3178 IF (.NOT. CC3) THEN 3179 KT2TCME = KEND0 3180 KEND0 = KT2TCME + NT2SQ(1) 3181 LWRK0 = LWORK - KEND0 3182C 3183 IF (LWRK0 .LT. NT2SQ(1)) 3184 * CALL QUIT('Too litlle workspace CCSDPT_DENS2 T2TCME') 3185C 3186 IOPTT2 = 2 3187 CALL CC_RDRSP('R0',0,1,IOPTT2,MODEL,DUMMY,WORK(KEND0)) 3188C 3189 ISYOPE = ISYMOP 3190 IOPTT2 = 1 3191 CALL CCSD_TCMEPK(WORK(KEND0),1.0D0,ISYOPE,IOPTT2) 3192C 3193 CALL CC_T2SQ(WORK(KEND0),WORK(KT2TCME),1) 3194C 3195 CALL DCOPY(NT2SQ(1),WORK(KT2TCME),1,WORK(KEND0),1) 3196 CALL CC3_T2TP(WORK(KT2TCME),WORK(KEND0),1) 3197C 3198 IF (IPRINT .GT. 55) THEN 3199 XT2TP = DDOT(NT2SQ(1),WORK(KT2TCME),1,WORK(KT2TCME),1) 3200 WRITE(LUPRI,*) 'Norm of 2*C-E T2 amplitudes after resort ', 3201 * XT2TP 3202 ENDIF 3203 ENDIF 3204C 3205C----------------------------- 3206C Read occupied integrals. 3207C----------------------------- 3208C 3209C Memory allocation. 3210C 3211 KTROC0 = KEND0 3212 KTROC02= KTROC0 + NTRAOC(ISINT2) 3213 KTROC2 = KTROC02+ NTRAOC(ISINT2) 3214 KTROC22= KTROC2 + NTRAOC(ISINT2) 3215 KXIAJB = KTROC22+ NTRAOC(ISINT2) 3216 KOCC1 = KXIAJB + NT2AM(ISYMOP) 3217 KOCC2 = KOCC1 + NCKIJ(ISYRES) 3218 KKAPAA = KOCC2 + NCKIJ(ISYRES) 3219 KKAPII = KKAPAA + NVIRT 3220 KEND1 = KKAPII + NRHFT 3221 LWRK1 = LWORK - KEND1 3222C 3223 IF (CC3) THEN 3224 KTROC01 = KEND1 3225 KTROC21 = KTROC01 + NTRAOC(ISINT2) 3226 KTROC03 = KTROC21 + NTRAOC(ISINT2) 3227 KTROC23 = KTROC03 + NTRAOC(ISINT2) 3228 KEND1 = KTROC23 + NTRAOC(ISINT2) 3229 LWRK1 = LWORK - KEND1 3230 ENDIF 3231C 3232 IF (.NOT. RELORB) THEN 3233 KOMG12 = KEND1 3234 KDENSAB = KOMG12 + NT1AM(ISYRES) 3235 KDENSIJ = KDENSAB + NMATAB(ISYRES) 3236 KEND1 = KDENSIJ + NMATIJ(ISYRES) 3237 LWRK1 = LWORK - KEND1 3238C 3239 CALL DZERO(WORK(KOMG12),NT1AM(ISYRES)) 3240 CALL DZERO(WORK(KDENSAB),NMATAB(ISYRES)) 3241 CALL DZERO(WORK(KDENSIJ),NMATIJ(ISYRES)) 3242 ENDIF 3243C 3244 KINTOC = KEND1 3245 KEND2 = KINTOC + MAX(NTOTOC(ISYMOP),NTOTOC(ISINT2)) 3246 LWRK2 = LWORK - KEND2 3247C 3248 IF (LWRK2 .LT. 0) THEN 3249 WRITE(LUPRI,*) 'Memory available : ',LWORK 3250 WRITE(LUPRI,*) 'Memory needed : ',KEND2 3251 CALL QUIT('Insufficient space in CCSDPT_DENS2') 3252 END IF 3253C 3254C 3255C---------------------------------- 3256C Initialize result vectors 3257C---------------------------------- 3258C 3259 CALL DZERO(WORK(KOCC1),NCKIJ(ISYRES)) 3260 CALL DZERO(WORK(KOCC2),NCKIJ(ISYRES)) 3261 CALL DZERO(WORK(KKAPAA),NVIRT) 3262 CALL DZERO(WORK(KKAPII),NRHFT) 3263C 3264C------------------------ 3265C Construct L(ia,jb). 3266C------------------------ 3267C 3268 LENGTH = IRAT*NT2AM(ISYMOP) 3269C 3270 REWIND(LUIAJB) 3271 CALL READI(LUIAJB,LENGTH,WORK(KXIAJB)) 3272C 3273 ISYOPE = ISYMOP 3274 IOPTTCME = 1 3275 CALL CCSD_TCMEPK(WORK(KXIAJB),1.0D0,ISYOPE,IOPTTCME) 3276C 3277 IF ( IPRINT .GT. 55) THEN 3278 XIAJB = DDOT(NT2AM(ISYMOP),WORK(KXIAJB),1, 3279 * WORK(KXIAJB),1) 3280 WRITE(LUPRI,*) 'Norm of IAJB ',XIAJB 3281 ENDIF 3282C 3283C------------------------ 3284C Occupied integrals. 3285C------------------------ 3286C 3287 IF (CC3) THEN 3288 IOFF = 1 3289 IF (NTOTOC(ISYMOP) .GT. 0) THEN 3290 CALL GETWA2(LUCKJD,FNCKJD,WORK(KINTOC),IOFF,NTOTOC(ISYMOP)) 3291 ENDIF 3292 ELSE 3293 IOFF = 1 3294 IF (NTOTOC(ISYMOP) .GT. 0) THEN 3295 CALL GETWA2(LUTOC,FNTOC,WORK(KINTOC),IOFF,NTOTOC(ISYMOP)) 3296 ENDIF 3297 ENDIF 3298C 3299C---------------------------------- 3300C Write out norms of Integrals. 3301C---------------------------------- 3302C 3303 IF (IPRINT .GT. 55) THEN 3304 XINT = DDOT(NTOTOC(ISYMOP),WORK(KINTOC),1, 3305 * WORK(KINTOC),1) 3306 WRITE(LUPRI,*) 'Norm of OCC-INT ',XINT 3307 ENDIF 3308C 3309C---------------------------------------------------------------------- 3310C Transform (ia|j delta) integrals to (ia|j k) and sort as (ij,k,a) 3311C---------------------------------------------------------------------- 3312C 3313 DTIME = SECOND() 3314 IF (CC3) THEN 3315 CALL CC3_TROCC(WORK(KINTOC),WORK(KTROC0),WORK(KLAMDP), 3316 * WORK(KEND2),LWRK2,ISINT2) 3317 ELSE 3318 CALL CCSDT_TROCC(WORK(KINTOC),WORK(KTROC0),WORK(KCMO), 3319 * WORK(KEND2),LWRK2) 3320 ENDIF 3321C 3322 DTIME = SECOND() - DTIME 3323 TITRAN = TITRAN + DTIME 3324 3325C 3326 DTIME = SECOND() 3327C 3328 DTIME = SECOND() - DTIME 3329 TISORT = TISORT + DTIME 3330C 3331C----------------------------------------------------------- 3332C Construct 2*C-E of the integrals. 3333C Have integral for both (ij,k,a) and (a,k,j,i) 3334C----------------------------------------------------------- 3335C 3336 CALL CCSDT_TCMEOCC(WORK(KTROC0),WORK(KTROC2),ISINT2) 3337C 3338 IF (CC3) THEN 3339 IOFF = 1 3340 IF (NTOTOC(ISINT2) .GT. 0) THEN 3341 CALL GETWA2(LUTOC,FNTOC,WORK(KINTOC),IOFF,NTOTOC(ISINT2)) 3342 ENDIF 3343C 3344 CALL CC3_TROCC(WORK(KINTOC),WORK(KTROC01),WORK(KLAMDH), 3345 * WORK(KEND2),LWRK2,ISINT2) 3346C 3347 CALL CCSDT_TCMEOCC(WORK(KTROC01),WORK(KTROC21),ISINT2) 3348C 3349 CALL CCFOP_SORT(WORK(KTROC01),WORK(KTROC03),ISINT2,1) 3350C 3351 CALL CCFOP_SORT(WORK(KTROC21),WORK(KTROC23),ISINT2,1) 3352 ENDIF 3353C 3354 CALL CCFOP_SORT(WORK(KTROC0),WORK(KTROC02),ISINT2,1) 3355C 3356 CALL CCFOP_SORT(WORK(KTROC2),WORK(KTROC22),ISINT2,1) 3357C 3358C------------------------------- 3359C Write out norms of arrays. 3360C------------------------------- 3361C 3362 IF (IPRINT .GT. 55) THEN 3363 XINT = DDOT(NTOTOC(ISINT2),WORK(KINTOC),1, 3364 * WORK(KINTOC),1) 3365 WRITE(LUPRI,*) 'Norm of CKJDEL-INT ',XINT 3366 ENDIF 3367C 3368 IF (IPRINT .GT. 55) THEN 3369 XTROC0 = DDOT(NTRAOC(ISINT2),WORK(KTROC0),1, 3370 * WORK(KTROC0),1) 3371 WRITE(LUPRI,*) 'Norm of TROC0 ',XTROC0 3372 ENDIF 3373C 3374 IF (IPRINT .GT. 55) THEN 3375 XTROC0 = DDOT(NTRAOC(ISINT2),WORK(KTROC2),1, 3376 * WORK(KTROC2),1) 3377 WRITE(LUPRI,*) 'Norm of TROC2 ',XTROC0 3378 ENDIF 3379C 3380C-------------------------------------------------------- 3381C Open files to the one and two electron densities. 3382C-------------------------------------------------------- 3383C 3384 LUPTIA = -1 3385 FNDPTIA = 'DPTIA' 3386C d_{ia} 3387 CALL WOPEN2(LUPTIA,FNDPTIA,64,0) 3388C 3389 IF ((.NOT. CC3) .AND. (RELORB)) THEN 3390 LUPTIAJB = -1 3391 LUABI1 = -1 3392 LUABI2 = -1 3393 LUABI3 = -1 3394 LUABI4 = -1 3395 LUAIJK = -1 3396 LUIAJK = -1 3397 FNDIAJB = 'DPTIAJB' 3398 FNDABI1 = 'DPTABIC1' 3399 FNDABI2 = 'DPTABIC2' 3400 FNDABI3 = 'DPTABCI1' 3401 FNDABI4 = 'DPTABCI2' 3402 FNDAIJK = 'DPTAIJK' 3403 FNDIAJK = 'DPTIAJK' 3404C 3405C d_{iajb} 3406 CALL WOPEN2(LUPTIAJB,FNDIAJB,64,0) 3407C d_{abic_1} 3408 CALL WOPEN2(LUABI1,FNDABI1,64,0) 3409C d_{abic_2} 3410 CALL WOPEN2(LUABI2,FNDABI2,64,0) 3411C d_{abci_1} 3412 CALL WOPEN2(LUABI3,FNDABI3,64,0) 3413C d_{abci_2} 3414 CALL WOPEN2(LUABI4,FNDABI4,64,0) 3415C d_{aijk} 3416 CALL WOPEN2(LUAIJK,FNDAIJK,64,0) 3417C d_{iajk} 3418 CALL WOPEN2(LUIAJK,FNDIAJK,64,0) 3419 ELSE 3420 LUPTIA2 = -1 3421 LUPTAB = -1 3422 LUPTIJ = -1 3423 FNDPTIA2 = 'DPTIA2' 3424 FNDPTAB = 'DPTAB' 3425 FNDPTIJ = 'DPTIJ' 3426C d_{ia} 3427 CALL WOPEN2(LUPTIA2,FNDPTIA2,64,0) 3428C d_{ab} 3429 CALL WOPEN2(LUPTAB,FNDPTAB,64,0) 3430C d_{ij} 3431 CALL WOPEN2(LUPTIJ,FNDPTIJ,64,0) 3432 ENDIF 3433C 3434C---------------------------- 3435C General loop structure. 3436C---------------------------- 3437C 3438 DO ISYMD = 1,NSYM 3439C 3440 ISAIJ1 = MULD2H(ISYMD,ISYRES) 3441 ISYCKB = MULD2H(ISYMD,ISYMOP) 3442 ISCKB1 = MULD2H(ISINT1,ISYMD) 3443 ISCKB2 = MULD2H(ISINT2,ISYMD) 3444C 3445 IF (IPRINT .GT. 55) THEN 3446C 3447 WRITE(LUPRI,*) 'In CCSDPT_DENS2: ISAIJ1 :',ISAIJ1 3448 WRITE(LUPRI,*) 'In CCSDPT_DENS2: ISYCKB :',ISYCKB 3449 WRITE(LUPRI,*) 'In CCSDPT_DENS2: ISCKB1 :',ISCKB1 3450 WRITE(LUPRI,*) 'In CCSDPT_DENS2: ISCKB2 :',ISCKB2 3451C 3452 ENDIF 3453C 3454C-------------------------- 3455C Memory allocation. 3456C-------------------------- 3457C 3458 KTRVI1 = KEND1 3459 KTRVI2 = KTRVI1 + NCKATR(ISCKB2) 3460 KRMAT1 = KTRVI2 + NCKATR(ISCKB2) 3461 KEND2 = KRMAT1 + NCKI(ISAIJ1) 3462 LWRK2 = LWORK - KEND2 3463C 3464 KTRVI0 = KEND2 3465 KTRVI3 = KTRVI0 + NCKATR(ISCKB2) 3466 KTRVI4 = KTRVI3 + NCKATR(ISCKB2) 3467 KTRVI5 = KTRVI4 + NCKATR(ISCKB2) 3468 KTRVI6 = KTRVI5 + NCKATR(ISCKB2) 3469 KTRVI7 = KTRVI6 + NCKATR(ISCKB2) 3470 KVIR1 = KTRVI7 + NCKATR(ISCKB2) 3471 KVIR2 = KVIR1 + NCKATR(ISAIJ1) 3472 KVIR3 = KVIR2 + NCKATR(ISAIJ1) 3473 KVIR4 = KVIR3 + NCKATR(ISAIJ1) 3474 KEND3 = KVIR4 + NCKATR(ISAIJ1) 3475 LWRK3 = LWORK - KEND3 3476C 3477 IF (CC3) THEN 3478 KTRVI14 = KEND3 3479 KTRVI15 = KTRVI14 + NCKATR(ISCKB2) 3480 KTRVI18 = KTRVI15 + NCKATR(ISCKB2) 3481 KTRVI19 = KTRVI18 + NCKATR(ISCKB2) 3482 KEND3 = KTRVI19 + NCKATR(ISCKB2) 3483 LWRK3 = LWORK - KEND3 3484 ENDIF 3485C 3486 KINTVI = KEND3 3487 KEND4 = KINTVI + MAX(NCKA(ISYMD),NCKA(ISCKB2)) 3488 LWRK4 = LWORK - KEND4 3489C 3490 IF (LWRK4 .LT. 0) THEN 3491 WRITE(LUPRI,*) 'Memory available : ',LWORK 3492 WRITE(LUPRI,*) 'Memory needed : ',KEND4 3493 CALL QUIT('Insufficient space in CCSDPT_DENS2') 3494 END IF 3495C 3496C--------------------- 3497C Sum over D 3498C--------------------- 3499C 3500 DO D = 1,NVIR(ISYMD) 3501C 3502C------------------------------------ 3503C Initialize the R1 matrix. 3504C------------------------------------ 3505C 3506 CALL DZERO(WORK(KRMAT1),NCKI(ISAIJ1)) 3507 CALL DZERO(WORK(KVIR1),NCKATR(ISAIJ1)) 3508 CALL DZERO(WORK(KVIR2),NCKATR(ISAIJ1)) 3509 CALL DZERO(WORK(KVIR3),NCKATR(ISAIJ1)) 3510 CALL DZERO(WORK(KVIR4),NCKATR(ISAIJ1)) 3511C 3512C----------------------------------------------- 3513C Integrals used in s3am. 3514C----------------------------------------------- 3515C 3516 IF (CC3) THEN 3517 IOFF = ICKBD(ISCKB2,ISYMD) + NCKATR(ISCKB2)*(D - 1) + 1 3518 IF (NCKATR(ISCKB2) .GT. 0) THEN 3519 CALL GETWA2(LUDKBC,FNDKBC,WORK(KTRVI0),IOFF, 3520 & NCKATR(ISCKB2)) 3521 ENDIF 3522 ELSE 3523 IOFF = ICKAD(ISYCKB,ISYMD) + NCKA(ISYCKB)*(D - 1) + 1 3524 IF (NCKA(ISYCKB) .GT. 0) THEN 3525 CALL GETWA2(LUDKBC3,FNDKBC3,WORK(KINTVI),IOFF, 3526 & NCKA(ISYCKB)) 3527 ENDIF 3528C 3529 CALL CCSDT_TRVIR(WORK(KINTVI),WORK(KTRVI0),WORK(KCMO), 3530 * ISYMD,D,ISINT2,WORK(KEND4),LWRK4) 3531 ENDIF 3532C 3533C------------------------------------------------------ 3534C Read 2*C-E of integral used for t3-bar 3535C------------------------------------------------------ 3536C 3537 IF (CC3) THEN 3538 IOFF = ICKBD(ISCKB2,ISYMD) + NCKATR(ISCKB2)*(D - 1) + 1 3539 IF (NCKATR(ISCKB2) .GT. 0) THEN 3540 CALL GETWA2(LU3FOP2X,FN3FOP2X,WORK(KTRVI4),IOFF, 3541 & NCKATR(ISCKB2)) 3542 ENDIF 3543 ELSE 3544 IOFF = ICKAD(ISYCKB,ISYMD) + NCKA(ISYCKB)*(D - 1) + 1 3545 IF (NCKA(ISYCKB) .GT. 0) THEN 3546 CALL GETWA2(LU3FOP2,FN3FOP2,WORK(KINTVI),IOFF, 3547 * NCKA(ISYCKB)) 3548 ENDIF 3549C 3550 CALL CCSDT_TRVIR(WORK(KINTVI),WORK(KTRVI4),WORK(KCMO), 3551 * ISYMD,D,ISYMOP,WORK(KEND4),LWRK4) 3552 ENDIF 3553C 3554C------------------------------------------------------------ 3555C Integrals used for t3-bar for cc3 3556C------------------------------------------------------------ 3557C 3558 IF (CC3) THEN 3559 IOFF = ICKBD(ISCKB2,ISYMD) + NCKATR(ISCKB2)*(D - 1) + 1 3560 IF (NCKATR(ISCKB2) .GT. 0) THEN 3561 CALL GETWA2(LUDKBC3,FNDKBC3,WORK(KTRVI14),IOFF, 3562 & NCKATR(ISCKB2)) 3563 ENDIF 3564 CALL CCSDT_SRVIR3(WORK(KTRVI14),WORK(KEND4), 3565 * ISYMD,D,ISINT2) 3566 CALL CCSDT_SRTVIR(WORK(KTRVI14),WORK(KTRVI15),WORK(KEND4) 3567 * ,LWRK4,ISYMD,ISINT2) 3568 ENDIF 3569C 3570C----------------------------------------------------------- 3571C Sort the integrals for s3am and for t3-bar 3572C----------------------------------------------------------- 3573C 3574 DTIME = SECOND() 3575 CALL CCSDT_SRTVIR(WORK(KTRVI0),WORK(KTRVI2),WORK(KEND4), 3576 * LWRK4,ISYMD,ISINT2) 3577C 3578 CALL CCSDT_SRTVIR(WORK(KTRVI4),WORK(KTRVI5),WORK(KEND4), 3579 * LWRK4,ISYMD,ISINT2) 3580C 3581 DTIME = SECOND() - DTIME 3582 TISORT = TISORT + DTIME 3583C 3584 IF (IPRINT .GT. 55) THEN 3585 XTRVI0= DDOT(NCKATR(ISCKB2),WORK(KTRVI0),1, 3586 * WORK(KTRVI0),1) 3587 WRITE(LUPRI,*) 'Norm of TRVI0 ',XTRVI0 3588 ENDIF 3589C 3590 IF (IPRINT .GT. 55) THEN 3591 XTRVI2= DDOT(NCKATR(ISCKB2),WORK(KTRVI2),1, 3592 * WORK(KTRVI2),1) 3593 WRITE(LUPRI,*) 'Norm of TRVI2 ',XTRVI2 3594 ENDIF 3595C 3596 IF (IPRINT .GT. 55) THEN 3597 XTRVI0= DDOT(NCKATR(ISCKB2),WORK(KTRVI4),1, 3598 * WORK(KTRVI4),1) 3599 WRITE(LUPRI,*) 'Norm of TRVI4 ',XTRVI0 3600 ENDIF 3601C 3602 IF (IPRINT .GT. 55) THEN 3603 XTRVI2= DDOT(NCKATR(ISCKB2),WORK(KTRVI5),1, 3604 * WORK(KTRVI5),1) 3605 WRITE(LUPRI,*) 'Norm of TRVI5 ',XTRVI2 3606 ENDIF 3607C 3608C------------------------------------------------------ 3609C Read virtual integrals used in contraction. 3610C------------------------------------------------------ 3611C 3612 IF (CC3) THEN 3613 IOFF = ICKAD(ISCKB2,ISYMD) + NCKA(ISCKB2)*(D - 1) + 1 3614 IF (NCKA(ISCKB2) .GT. 0) THEN 3615 CALL GETWA2(LUDELD,FNDELD,WORK(KINTVI),IOFF, 3616 * NCKA(ISCKB2)) 3617 ENDIF 3618C 3619 CALL CCSDT_TRVIR(WORK(KINTVI),WORK(KTRVI1),WORK(KLAMDH), 3620 * ISYMD,D,ISINT2,WORK(KEND4),LWRK4) 3621C 3622 ELSE 3623 IOFF = ICKAD(ISYCKB,ISYMD) + NCKA(ISYCKB)*(D - 1) + 1 3624 IF (NCKA(ISYCKB) .GT. 0) THEN 3625 CALL GETWA2(LU3VI,FN3VI,WORK(KINTVI),IOFF, 3626 & NCKA(ISYCKB)) 3627 ENDIF 3628C 3629 CALL CCSDT_TRVIR(WORK(KINTVI),WORK(KTRVI1),WORK(KCMO), 3630 * ISYMD,D,ISINT2,WORK(KEND4),LWRK4) 3631 ENDIF 3632C 3633C-------------------------------------------------------- 3634C Calculate virtual integrals used in q3am. 3635C-------------------------------------------------------- 3636C 3637 CALL DCOPY(NCKATR(ISCKB2),WORK(KTRVI1),1,WORK(KTRVI3),1) 3638C 3639 IF (LWRK3 .LT. NCKATR(ISYCKB)) THEN 3640 CALL QUIT('Insufficient space for allocation in '// 3641 & 'CCSDPT_DENS2 (1)') 3642 END IF 3643C 3644 DTIME = SECOND() 3645 CALL CCSDT_SRVIR3(WORK(KTRVI3),WORK(KEND4),ISYMD,D,ISINT2) 3646C 3647 DTIME = SECOND() - DTIME 3648 TISORT = TISORT + DTIME 3649C 3650 IF (IPRINT .GT. 55) THEN 3651 XTRVI3= DDOT(NCKATR(ISCKB2),WORK(KTRVI3),1, 3652 * WORK(KTRVI3),1) 3653 WRITE(LUPRI,*) 'Norm of TRVI3 ',XTRVI3 3654 ENDIF 3655C 3656C--------------------------------------------------------------- 3657C Read virtual integrals used in q3am/u3am for t3-bar. 3658C--------------------------------------------------------------- 3659C 3660 IF (CC3) THEN 3661 IOFF = ICKAD(ISYCKB,ISYMD) + NCKA(ISYCKB)*(D - 1) + 1 3662 IF (NCKA(ISYCKB) .GT. 0) THEN 3663 CALL GETWA2(LU3VI,FN3VI,WORK(KINTVI),IOFF, 3664 * NCKA(ISYCKB)) 3665 ENDIF 3666C 3667 CALL CCSDT_TRVIR(WORK(KINTVI),WORK(KTRVI19),WORK(KLAMDP), 3668 * ISYMD,D,ISYMOP,WORK(KEND4),LWRK4) 3669C 3670 IF (LWRK4 .LT. NCKATR(ISYCKB)) THEN 3671 CALL QUIT('Insufficient space for allocation in '// 3672 * 'CCSDPT_DENS2 (CC3 TRVI)') 3673 END IF 3674C 3675 CALL CCSDT_SRTVIR(WORK(KTRVI19),WORK(KTRVI18),WORK(KEND4) 3676 * ,LWRK4,ISYMD,ISINT2) 3677 ENDIF 3678C 3679 IF (CC3) THEN 3680 IOFF = ICKBD(ISYCKB,ISYMD) + NCKATR(ISYCKB)*(D - 1) + 1 3681 IF (NCKATR(ISYCKB) .GT. 0) THEN 3682 CALL GETWA2(LU3FOPX,FN3FOPX,WORK(KTRVI6),IOFF, 3683 * NCKATR(ISYCKB)) 3684 ENDIF 3685 ELSE 3686 IOFF = ICKAD(ISYCKB,ISYMD) + NCKA(ISYCKB)*(D - 1) + 1 3687 IF (NCKA(ISYCKB) .GT. 0) THEN 3688 CALL GETWA2(LU3FOP,FN3FOP,WORK(KINTVI),IOFF, 3689 * NCKA(ISYCKB)) 3690 ENDIF 3691C 3692 CALL CCSDT_TRVIR(WORK(KINTVI),WORK(KTRVI6),WORK(KCMO), 3693 * ISYMD,D,ISINT2,WORK(KEND4),LWRK4) 3694 ENDIF 3695C 3696 IF (LWRK3 .LT. NCKATR(ISYCKB)) THEN 3697 CALL QUIT('Insufficient space for allocation in '// 3698 & 'CCSDPT_DENS2 (2)') 3699 END IF 3700C 3701 CALL DCOPY(NCKATR(ISCKB2),WORK(KTRVI6),1,WORK(KTRVI7),1) 3702C 3703 DTIME = SECOND() 3704 CALL CCSDT_SRVIR3(WORK(KTRVI6),WORK(KEND4),ISYMD,D,ISINT2) 3705C 3706 DTIME = SECOND() - DTIME 3707 TISORT = TISORT + DTIME 3708C 3709 IF (IPRINT .GT. 55) THEN 3710 XTRVI3= DDOT(NCKATR(ISCKB2),WORK(KTRVI6),1, 3711 * WORK(KTRVI6),1) 3712 WRITE(LUPRI,*) 'Norm of TRVI6 ',XTRVI3 3713 XTRVI3= DDOT(NCKATR(ISCKB2),WORK(KTRVI7),1, 3714 * WORK(KTRVI7),1) 3715 WRITE(LUPRI,*) 'Norm of TRVI7 ',XTRVI3 3716 ENDIF 3717C 3718 IF (IPRINT .GT. 55) THEN 3719 XTRVI1= DDOT(NCKATR(ISCKB2),WORK(KTRVI1),1, 3720 * WORK(KTRVI1),1) 3721 WRITE(LUPRI,*) 'Norm of TRVI1 ',XTRVI1 3722 ENDIF 3723C 3724C--------------------- 3725C Calculate. 3726C--------------------- 3727C 3728 DO ISYMB = 1,NSYM 3729C 3730 ISYALJ = MULD2H(ISYMB,ISYMT2) 3731 ISYALJ2 = MULD2H(ISYMD,ISYMT2) 3732 ISAIJ2 = MULD2H(ISYMB,ISYRES) 3733 ISYMBD = MULD2H(ISYMB,ISYMD) 3734 ISCKIJ = MULD2H(ISYMBD,ISYMIM) 3735 ISYCKD = MULD2H(ISYMOP,ISYMB) 3736 ISCKD2 = MULD2H(ISINT2,ISYMB) 3737C 3738 IF ((IPRINT .GT. 55)) THEN 3739C 3740 WRITE(LUPRI,*) 'In CCSDPT_DENS2: ISYMD :',ISYMD 3741 WRITE(LUPRI,*) 'In CCSDPT_DENS2: ISYMB :',ISYMB 3742 WRITE(LUPRI,*) 'In CCSDPT_DENS2: ISYALJ:',ISYALJ 3743 WRITE(LUPRI,*) 'In CCSDPT_DENS2: ISAIJ2:',ISAIJ2 3744 WRITE(LUPRI,*) 'In CCSDPT_DENS2: ISYMBD:',ISYMBD 3745 WRITE(LUPRI,*) 'In CCSDPT_DENS2: ISCKIJ:',ISCKIJ 3746C 3747 ENDIF 3748C 3749C Can use kend3 since we do not need the integrals anymore. 3750 KSMAT = KEND3 3751 KQMAT = KSMAT + NCKIJ(ISCKIJ) 3752 KSMAT2 = KQMAT + NCKIJ(ISCKIJ) 3753 KSMAT3 = KSMAT2 + NCKIJ(ISCKIJ) 3754 KQMAT2 = KSMAT3 + NCKIJ(ISCKIJ) 3755 KUMAT = KQMAT2 + NCKIJ(ISCKIJ) 3756 KUMAT2 = KUMAT + NCKIJ(ISCKIJ) 3757 KUMAT3 = KUMAT2 + NCKIJ(ISCKIJ) 3758 KDIAG = KUMAT3 + NCKIJ(ISCKIJ) 3759 KINDSQ = KDIAG + NCKIJ(ISCKIJ) 3760 KINDEX = KINDSQ + (6*NCKIJ(ISCKIJ) - 1)/IRAT + 1 3761 KINDEX2 = KINDEX + (NCKI(ISYALJ) - 1)/IRAT + 1 3762 KTMAT = KINDEX2 + (NCKI(ISYALJ2) - 1)/IRAT + 1 3763 KRMAT2 = KTMAT + NCKIJ(ISCKIJ) 3764 KTRVI8 = KRMAT2 + NCKI(ISAIJ2) 3765 KTRVI9 = KTRVI8 + NCKATR(ISCKD2) 3766 KTRVI10 = KTRVI9 + NCKATR(ISCKD2) 3767 KEND4 = KTRVI10 + NCKATR(ISCKD2) 3768 LWRK4 = LWORK - KEND4 3769C 3770 IF (CC3) THEN 3771 KTRVI16 = KEND4 3772 KTRVI17 = KTRVI16 + NCKATR(ISCKD2) 3773 KTRVI20 = KTRVI17 + NCKATR(ISCKD2) 3774 KEND4 = KTRVI20 + NCKATR(ISCKD2) 3775 LWRK4 = LWORK - KEND4 3776 ENDIF 3777C 3778 IF (.NOT. RELORB) THEN 3779 KSMAT4 = KEND4 3780 KUMAT4 = KSMAT4 + NCKIJ(ISCKIJ) 3781 KTRVI11 = KUMAT4 + NCKIJ(ISCKIJ) 3782 KTRVI12 = KTRVI11 + NCKATR(ISCKD2) 3783 KTRVI13 = KTRVI12 + NCKATR(ISCKD2) 3784 KEND4 = KTRVI13 + NCKATR(ISCKD2) 3785 LWRK4 = LWORK-KEND4 3786 ENDIF 3787C 3788 KINTVI = KEND4 3789COMMENT COMMENT 3790C KEND5 = KINTVI + NCKA(ISCKD2) 3791 KEND5 = KINTVI + MAX(NCKA(ISYMB),NCKA(ISCKD2)) 3792COMMENT COMMENT 3793 LWRK5 = LWORK - KEND5 3794C 3795 IF (LWRK5 .LT. 0) THEN 3796 WRITE(LUPRI,*) 'Memory available : ',LWORK 3797 WRITE(LUPRI,*) 'Memory needed : ',KEND5 3798 CALL QUIT('Insufficient space in CCSDPT_DENS2') 3799 END IF 3800C 3801C--------------------------------------------- 3802C Construct part of the diagonal. 3803C--------------------------------------------- 3804C 3805 CALL CC3_DIAG(WORK(KDIAG),WORK(KFOCKD),ISCKIJ) 3806C 3807 IF ((IPRINT .GT. 55)) THEN 3808 XDIA = DDOT(NCKIJ(ISCKIJ),WORK(KDIAG),1, 3809 * WORK(KDIAG),1) 3810 WRITE(LUPRI,*) 'Norm of DIA ',XDIA 3811 ENDIF 3812 3813C 3814C------------------------------------- 3815C Construct index arrays. 3816C------------------------------------- 3817C 3818 LENSQ = NCKIJ(ISCKIJ) 3819 CALL CC3_INDSQ(WORK(KINDSQ),LENSQ,ISCKIJ) 3820 CALL CC3_INDEX(WORK(KINDEX),ISYALJ) 3821 CALL CC3_INDEX(WORK(KINDEX2),ISYALJ2) 3822C 3823 DO B = 1,NVIR(ISYMB) 3824C 3825C----------------------------------------- 3826C Initialize the R2 matrix. 3827C----------------------------------------- 3828C 3829 CALL DZERO(WORK(KRMAT2),NCKI(ISAIJ2)) 3830C 3831C------------------------------------------------------------- 3832C Read and transform integrals used in second S 3833C------------------------------------------------------------- 3834C 3835 IF (CC3) THEN 3836 IOFF = ICKBD(ISYCKD,ISYMB) 3837 * + NCKATR(ISYCKD)*(B - 1) + 1 3838 IF (NCKATR(ISYCKD) .GT. 0) THEN 3839 CALL GETWA2(LUDKBC,FNDKBC,WORK(KTRVI8),IOFF, 3840 * NCKATR(ISYCKD)) 3841 ENDIF 3842 ELSE 3843C 3844 IOFF = ICKAD(ISYCKD,ISYMB) 3845 * + NCKA(ISYCKD)*(B - 1) + 1 3846 IF (NCKA(ISYCKD) .GT. 0) THEN 3847 CALL GETWA2(LUDKBC3,FNDKBC3,WORK(KINTVI),IOFF, 3848 * NCKA(ISYCKD)) 3849 ENDIF 3850C 3851 CALL CCSDT_TRVIR(WORK(KINTVI),WORK(KTRVI8), 3852 * WORK(KCMO),ISYMB,B,ISINT2, 3853 * WORK(KEND5),LWRK5) 3854 ENDIF 3855C 3856 CALL CCSDT_SRTVIR(WORK(KTRVI8),WORK(KTRVI9), 3857 * WORK(KEND4),LWRK4,ISYMB,ISINT2) 3858C 3859 IF (CC3) THEN 3860 IOFF = ICKBD(ISYCKD,ISYMB) 3861 * + NCKATR(ISYCKD)*(B - 1) + 1 3862 IF (NCKATR(ISYCKD) .GT. 0) THEN 3863 CALL GETWA2(LUDKBC3,FNDKBC3,WORK(KTRVI16),IOFF, 3864 * NCKATR(ISYCKD)) 3865 ENDIF 3866 CALL CCSDT_SRVIR3(WORK(KTRVI16),WORK(KEND5), 3867 * ISYMB,B,ISINT2) 3868 CALL CCSDT_SRTVIR(WORK(KTRVI16),WORK(KTRVI17), 3869 * WORK(KEND4),LWRK4,ISYMB,ISINT2) 3870 ENDIF 3871C 3872C---------------------------------------------------------- 3873C Read virtual integrals used in second U 3874C---------------------------------------------------------- 3875C 3876C 3877 IF (CC3) THEN 3878 IOFF = ICKAD(ISCKD2,ISYMB) 3879 * + NCKA(ISCKD2)*(B - 1) + 1 3880 IF (NCKA(ISYCKD) .GT. 0) THEN 3881 CALL GETWA2(LUDELD,FNDELD,WORK(KINTVI),IOFF, 3882 * NCKA(ISCKD2)) 3883 ENDIF 3884C 3885 CALL CCSDT_TRVIR(WORK(KINTVI),WORK(KTRVI10), 3886 * WORK(KLAMDH),ISYMB,B,ISINT2, 3887 * WORK(KEND5),LWRK5) 3888C 3889 ELSE 3890C 3891 IOFF = ICKAD(ISYCKD,ISYMB) 3892 * + NCKA(ISYCKD)*(B - 1) + 1 3893 IF (NCKA(ISYCKD) .GT. 0) THEN 3894 CALL GETWA2(LU3VI,FN3VI,WORK(KINTVI),IOFF, 3895 * NCKA(ISYCKD)) 3896 ENDIF 3897C 3898 CALL CCSDT_TRVIR(WORK(KINTVI),WORK(KTRVI10), 3899 * WORK(KCMO),ISYMB,B,ISYMOP, 3900 * WORK(KEND5),LWRK5) 3901 ENDIF 3902C 3903C------------------------------------------------------------------------ 3904C Read and transform integrals used in second S-bar and U-bar 3905C NOT used for CC3 3906C------------------------------------------------------------------------ 3907C 3908 IF (.NOT. RELORB) THEN 3909C 3910 IF (CC3) THEN 3911 IOFF = ICKBD(ISYCKD,ISYMB) 3912 * + NCKATR(ISYCKD)*(B-1) + 1 3913 IF (NCKATR(ISYCKD) .GT. 0) THEN 3914 CALL GETWA2(LU3FOP2X,FN3FOP2X,WORK(KTRVI11), 3915 * IOFF,NCKATR(ISYCKD)) 3916 ENDIF 3917 ELSE 3918 IOFF = ICKAD(ISYCKD,ISYMB) 3919 * + NCKA(ISYCKD)*(B-1) + 1 3920 IF (NCKA(ISYCKD) .GT. 0) THEN 3921 CALL GETWA2(LU3FOP2,FN3FOP2,WORK(KINTVI), 3922 * IOFF,NCKA(ISYCKD)) 3923 ENDIF 3924C 3925 CALL CCSDT_TRVIR(WORK(KINTVI),WORK(KTRVI11), 3926 * WORK(KCMO),ISYMB,B,ISYMOP, 3927 * WORK(KEND5),LWRK5) 3928C 3929 ENDIF 3930C 3931 CALL CCSDT_SRTVIR(WORK(KTRVI11),WORK(KTRVI12), 3932 * WORK(KEND5),LWRK5,ISYMB, 3933 * ISINT2) 3934C 3935 IF (CC3) THEN 3936 IOFF = ICKBD(ISYCKD,ISYMB) 3937 * + NCKATR(ISYCKD)*(B - 1) + 1 3938 IF (NCKATR(ISYCKD) .GT. 0) THEN 3939 CALL GETWA2(LU3FOPX,FN3FOPX,WORK(KTRVI13), 3940 * IOFF,NCKATR(ISYCKD)) 3941 ENDIF 3942C 3943 IOFF = ICKAD(ISYCKD,ISYMB) 3944 * + NCKA(ISYCKD)*(B - 1) + 1 3945 IF (NCKA(ISYCKD) .GT. 0) THEN 3946 CALL GETWA2(LU3VI,FN3VI,WORK(KINTVI),IOFF, 3947 * NCKA(ISYCKD)) 3948 ENDIF 3949C 3950 CALL CCSDT_TRVIR(WORK(KINTVI),WORK(KTRVI20), 3951 * WORK(KLAMDP),ISYMB,B,ISYMOP, 3952 * WORK(KEND4),LWRK4) 3953 ELSE 3954 IOFF = ICKAD(ISYCKD,ISYMB) 3955 * + NCKA(ISYCKD)*(B-1) + 1 3956 IF (NCKA(ISYCKD) .GT. 0) THEN 3957 CALL GETWA2(LU3FOP,FN3FOP,WORK(KINTVI),IOFF, 3958 * NCKA(ISYCKD)) 3959 ENDIF 3960C 3961 CALL CCSDT_TRVIR(WORK(KINTVI),WORK(KTRVI13), 3962 * WORK(KCMO),ISYMB,B,ISINT2, 3963 * WORK(KEND5),LWRK5) 3964 ENDIF 3965 ENDIF 3966C 3967C------------------------------------------------------------------- 3968C Calculate the S(ci,bk,dj) matrix for T3 for B,D. 3969C------------------------------------------------------------------- 3970C 3971 DTIME = SECOND() 3972 CALL CC3_SMAT(0.0D0,T2TP,ISYMT2,WORK(KTMAT), 3973 * WORK(KTRVI0), 3974 * WORK(KTRVI2),WORK(KTROC0),ISINT2, 3975 * WORK(KFOCKD),WORK(KDIAG), 3976 * WORK(KSMAT),WORK(KEND4),LWRK4, 3977 * WORK(KINDEX),WORK(KINDSQ),LENSQ, 3978 * ISYMB,B,ISYMD,D) 3979C 3980 CALL T3_FORBIDDEN(WORK(KSMAT),ISYMIM,ISYMB,B,ISYMD,D) 3981C 3982 DTIME = SECOND() - DTIME 3983 TISMAT = TISMAT + DTIME 3984C 3985 IF (IPRINT .GT. 55) THEN 3986 XSMAT = DDOT(NCKIJ(ISCKIJ),WORK(KSMAT),1, 3987 * WORK(KSMAT),1) 3988 WRITE(LUPRI,*) 'Norm of SMAT ',XSMAT 3989 ENDIF 3990C 3991C------------------------------------------------------------------- 3992C Calculate the S(ci,bk,dj) matrix for T3 for D,B. 3993C------------------------------------------------------------------- 3994C 3995 DTIME = SECOND() 3996 CALL CC3_SMAT(0.0D0,T2TP,ISYMT2,WORK(KTMAT), 3997 * WORK(KTRVI8), 3998 * WORK(KTRVI9),WORK(KTROC0),ISINT2, 3999 * WORK(KFOCKD),WORK(KDIAG), 4000 * WORK(KSMAT3),WORK(KEND4),LWRK4, 4001 * WORK(KINDEX2),WORK(KINDSQ),LENSQ, 4002 * ISYMD,D,ISYMB,B) 4003C 4004 CALL T3_FORBIDDEN(WORK(KSMAT3),ISYMIM,ISYMD,D,ISYMB,B) 4005C 4006 DTIME = SECOND() - DTIME 4007 TISMAT = TISMAT + DTIME 4008C 4009 IF (IPRINT .GT. 55) THEN 4010 XSMAT = DDOT(NCKIJ(ISCKIJ),WORK(KSMAT3),1, 4011 * WORK(KSMAT3),1) 4012 WRITE(LUPRI,*) 'Norm of SMAT3 ',XSMAT 4013 ENDIF 4014C 4015C--------------------------------------------------------------------------- 4016C Calculate the S(ci,bk,dj) matrix for for B,D for T3-BAR. 4017C--------------------------------------------------------------------------- 4018C 4019 DTIME = SECOND() 4020C 4021 CALL DZERO(WORK(KSMAT2),NCKIJ(ISCKIJ)) 4022C 4023 IF (CC3) THEN 4024 CALL CCFOP_SMAT(0.0D0,L1AM,ISYML1,L2TP,ISYML2, 4025 * WORK(KTMAT), 4026 * WORK(KFCKBA),WORK(KXIAJB),ISINT1, 4027 * WORK(KTRVI14),WORK(KTRVI15), 4028 * WORK(KTRVI4),WORK(KTRVI5), 4029 * WORK(KTROC01),WORK(KTROC21), 4030 * ISINT2,WORK(KFOCKD),WORK(KDIAG), 4031 * WORK(KSMAT2),WORK(KEND4),LWRK4, 4032 * WORK(KINDEX),WORK(KINDSQ),LENSQ, 4033 * ISYMB,B,ISYMD,D) 4034C 4035 CALL DSCAL(NCKIJ(ISCKIJ),HALF,WORK(KSMAT2),1) 4036C 4037 ELSE 4038C 4039 CALL CCFOP_SMAT(0.0D0,T1AM,ISYMT1,WORK(KT2TCME), 4040 * ISYMT2,WORK(KTMAT), 4041 * WORK(KFCKBA),WORK(KXIAJB),ISINT1, 4042 * WORK(KTRVI0),WORK(KTRVI2), 4043 * WORK(KTRVI4),WORK(KTRVI5), 4044 * WORK(KTROC0),WORK(KTROC2), 4045 * ISINT2,WORK(KFOCKD),WORK(KDIAG), 4046 * WORK(KSMAT2),WORK(KEND4),LWRK4, 4047 * WORK(KINDEX),WORK(KINDSQ),LENSQ, 4048 * ISYMB,B,ISYMD,D) 4049 ENDIF 4050C 4051 CALL T3_FORBIDDEN(WORK(KSMAT2),ISYMIM,ISYMB,B,ISYMD,D) 4052C 4053 DTIME = SECOND() - DTIME 4054 TISMAT = TISMAT + DTIME 4055C 4056 IF (IPRINT .GT. 55) THEN 4057 XSMAT = DDOT(NCKIJ(ISCKIJ),WORK(KSMAT2),1, 4058 * WORK(KSMAT2),1) 4059 WRITE(LUPRI,*) 'Norm of SMAT-BAR-1 ',XSMAT 4060 ENDIF 4061C 4062C----------------------------------------------------------------------------- 4063C Calculate the S(ci,bk,dj) matrix for for D,B for T3-BAR. 4064C----------------------------------------------------------------------------- 4065C 4066 IF (.NOT. RELORB) THEN 4067C 4068 DTIME = SECOND() 4069C 4070 CALL DZERO(WORK(KSMAT4),NCKIJ(ISCKIJ)) 4071C 4072 IF (CC3) THEN 4073 CALL CCFOP_SMAT(0.0D0,L1AM,ISYML1,L2TP, 4074 * ISYML2,WORK(KTMAT),WORK(KFCKBA), 4075 * WORK(KXIAJB),ISINT1, 4076 * WORK(KTRVI16),WORK(KTRVI17), 4077 * WORK(KTRVI11),WORK(KTRVI12), 4078 * WORK(KTROC01),WORK(KTROC21), 4079 * ISINT2,WORK(KFOCKD),WORK(KDIAG), 4080 * WORK(KSMAT4),WORK(KEND4),LWRK4, 4081 * WORK(KINDEX2),WORK(KINDSQ), 4082 * LENSQ,ISYMD,D,ISYMB,B) 4083C 4084 CALL DSCAL(NCKIJ(ISCKIJ),HALF,WORK(KSMAT4),1) 4085C 4086 ELSE 4087C 4088 CALL CCFOP_SMAT(0.0D0,T1AM,ISYMT1,WORK(KT2TCME), 4089 * ISYMT2,WORK(KTMAT),WORK(KFCKBA), 4090 * WORK(KXIAJB),ISINT1, 4091 * WORK(KTRVI8),WORK(KTRVI9), 4092 * WORK(KTRVI11),WORK(KTRVI12), 4093 * WORK(KTROC0),WORK(KTROC2), 4094 * ISINT2,WORK(KFOCKD),WORK(KDIAG), 4095 * WORK(KSMAT4),WORK(KEND4),LWRK4, 4096 * WORK(KINDEX2),WORK(KINDSQ), 4097 * LENSQ,ISYMD,D,ISYMB,B) 4098 ENDIF 4099C 4100 CALL T3_FORBIDDEN(WORK(KSMAT4),ISYMIM, 4101 * ISYMD,D,ISYMB,B) 4102C 4103 DTIME = SECOND() - DTIME 4104 TISMAT = TISMAT + DTIME 4105C 4106 IF (IPRINT .GT. 55) THEN 4107 XSMAT = DDOT(NCKIJ(ISCKIJ),WORK(KSMAT4),1, 4108 * WORK(KSMAT4),1) 4109 WRITE(LUPRI,*) 'Norm of SMAT-BAR-2 ',XSMAT 4110 ENDIF 4111C 4112 ENDIF 4113C 4114C-------------------------------------------------- 4115C Calculate Q(ci,jk) for fixed b,d. 4116C-------------------------------------------------- 4117C 4118 DTIME = SECOND() 4119 CALL CC3_QMAT(0.0D0,T2TP,ISYMT2,WORK(KTRVI3), 4120 * WORK(KTROC0),ISINT2,WORK(KFOCKD), 4121 * WORK(KDIAG),WORK(KQMAT), 4122 * WORK(KEND4),LWRK4,WORK(KINDSQ),LENSQ, 4123 * ISYMB,B,ISYMD,D) 4124C 4125 CALL T3_FORBIDDEN(WORK(KQMAT),ISYMIM,ISYMB,B,ISYMD,D) 4126C 4127 DTIME = SECOND() - DTIME 4128 TIQMAT = TIQMAT + DTIME 4129C 4130 IF (IPRINT .GT. 55) THEN 4131 XQMAT = DDOT(NCKIJ(ISCKIJ),WORK(KQMAT),1, 4132 * WORK(KQMAT),1) 4133 WRITE(LUPRI,*) 'Norm of QMAT ',XQMAT 4134 ENDIF 4135C 4136C------------------------------------------------------------------- 4137C Calculate Q(ci,jk) for fixed b,d for t3-bar. 4138C------------------------------------------------------------------- 4139C 4140 DTIME = SECOND() 4141C 4142 CALL DZERO(WORK(KQMAT2),NCKIJ(ISCKIJ)) 4143C 4144 IF (CC3) THEN 4145 CALL CCFOP_QMAT(0.0D0,L1AM,ISYML1,L2TP,ISYML2, 4146 * WORK(KTMAT),WORK(KFCKBA), 4147 * WORK(KXIAJB),ISINT1,WORK(KTRVI18), 4148 * WORK(KTRVI6),WORK(KTROC01), 4149 * WORK(KTROC21),ISINT2,WORK(KFOCKD), 4150 * WORK(KDIAG),WORK(KQMAT2), 4151 * WORK(KEND4),LWRK4,WORK(KINDSQ), 4152 * LENSQ,ISYMB,B,ISYMD,D) 4153C 4154 CALL DSCAL(NCKIJ(ISCKIJ),HALF,WORK(KQMAT2),1) 4155C 4156 ELSE 4157 CALL CCFOP_QMAT(0.0D0,T1AM,ISYMT1,WORK(KT2TCME), 4158 * ISYMT2,WORK(KTMAT),WORK(KFCKBA), 4159 * WORK(KXIAJB),ISINT1,WORK(KTRVI3), 4160 * WORK(KTRVI6),WORK(KTROC0), 4161 * WORK(KTROC2),ISINT2,WORK(KFOCKD), 4162 * WORK(KDIAG),WORK(KQMAT2), 4163 * WORK(KEND4),LWRK4,WORK(KINDSQ), 4164 * LENSQ,ISYMB,B,ISYMD,D) 4165 ENDIF 4166C 4167 CALL T3_FORBIDDEN(WORK(KQMAT2),ISYMIM,ISYMB,B,ISYMD,D) 4168C 4169 DTIME = SECOND() - DTIME 4170 TIQMAT = TIQMAT + DTIME 4171C 4172 IF (IPRINT .GT. 55) THEN 4173 XQMAT = DDOT(NCKIJ(ISCKIJ),WORK(KQMAT2),1, 4174 * WORK(KQMAT2),1) 4175 WRITE(LUPRI,*) 'Norm of QMAT-BAR ',XQMAT 4176 ENDIF 4177C 4178C-------------------------------------------------- 4179C Calculate U(ci,jk) for fixed b,d. 4180C-------------------------------------------------- 4181C 4182 DTIME = SECOND() 4183 CALL CC3_UMAT(0.0D0,T2TP,ISYMT2,WORK(KTRVI1), 4184 * WORK(KTROC02),ISINT2,WORK(KFOCKD), 4185 * WORK(KDIAG),WORK(KUMAT),WORK(KTMAT), 4186 * WORK(KEND4),LWRK4,WORK(KINDSQ),LENSQ, 4187 * ISYMB,B,ISYMD,D) 4188C 4189 CALL T3_FORBIDDEN(WORK(KUMAT),ISYMIM,ISYMB,B,ISYMD,D) 4190C 4191 DTIME = SECOND() - DTIME 4192 TIQMAT = TIQMAT + DTIME 4193C 4194 IF (IPRINT .GT. 55) THEN 4195 XQMAT = DDOT(NCKIJ(ISCKIJ),WORK(KUMAT),1, 4196 * WORK(KUMAT),1) 4197 WRITE(LUPRI,*) 'Norm of UMAT ',XQMAT 4198 ENDIF 4199C 4200C-------------------------------------------------- 4201C Calculate U(ci,jk) for fixed d,b. 4202C-------------------------------------------------- 4203C 4204 DTIME = SECOND() 4205 CALL CC3_UMAT(0.0D0,T2TP,ISYMT2,WORK(KTRVI10), 4206 * WORK(KTROC02),ISINT2,WORK(KFOCKD), 4207 * WORK(KDIAG),WORK(KUMAT3),WORK(KTMAT), 4208 * WORK(KEND4),LWRK4,WORK(KINDSQ),LENSQ, 4209 * ISYMD,D,ISYMB,B) 4210C 4211 CALL T3_FORBIDDEN(WORK(KUMAT3),ISYMIM,ISYMD,D,ISYMB,B) 4212C 4213 DTIME = SECOND() - DTIME 4214 TIQMAT = TIQMAT + DTIME 4215C 4216 IF (IPRINT .GT. 55) THEN 4217 XQMAT = DDOT(NCKIJ(ISCKIJ),WORK(KUMAT),1, 4218 * WORK(KUMAT),1) 4219 WRITE(LUPRI,*) 'Norm of UMAT3 ',XQMAT 4220 ENDIF 4221C 4222C----------------------------------------------------------------- 4223C Calculate U(ci,jk) for fixed b,d for t3-bar. 4224C----------------------------------------------------------------- 4225C 4226 DTIME = SECOND() 4227C 4228 CALL DZERO(WORK(KUMAT2),NCKIJ(ISCKIJ)) 4229C 4230 IF (CC3) THEN 4231 CALL CCFOP_UMAT(0.0D0,L1AM,ISYML1,L2TP,ISYML2, 4232 * WORK(KXIAJB),ISINT1,WORK(KFCKBA), 4233 * WORK(KTRVI19),WORK(KTRVI7), 4234 * WORK(KTROC03),WORK(KTROC23),ISINT2, 4235 * WORK(KFOCKD),WORK(KDIAG), 4236 * WORK(KUMAT2), 4237 * WORK(KTMAT),WORK(KEND4),LWRK4, 4238 * WORK(KINDSQ),LENSQ,ISYMB,B,ISYMD,D) 4239C 4240 CALL DSCAL(NCKIJ(ISCKIJ),HALF,WORK(KUMAT2),1) 4241C 4242 ELSE 4243 CALL CCFOP_UMAT(0.0D0,T1AM,ISYMT1,WORK(KT2TCME), 4244 * ISYMT2, 4245 * WORK(KXIAJB),ISINT1,WORK(KFCKBA), 4246 * WORK(KTRVI1),WORK(KTRVI7), 4247 * WORK(KTROC02),WORK(KTROC22),ISINT2, 4248 * WORK(KFOCKD),WORK(KDIAG), 4249 * WORK(KUMAT2), 4250 * WORK(KTMAT),WORK(KEND4),LWRK4, 4251 * WORK(KINDSQ),LENSQ,ISYMB,B,ISYMD,D) 4252 ENDIF 4253C 4254 CALL T3_FORBIDDEN(WORK(KUMAT2),ISYMIM,ISYMB,B,ISYMD,D) 4255C 4256 DTIME = SECOND() - DTIME 4257 TIQMAT = TIQMAT + DTIME 4258C 4259 IF (IPRINT .GT. 55) THEN 4260 XQMAT = DDOT(NCKIJ(ISCKIJ),WORK(KUMAT2),1, 4261 * WORK(KUMAT2),1) 4262 WRITE(LUPRI,*) 'Norm of UMAT-BAR-1 ',XQMAT 4263 ENDIF 4264C 4265C----------------------------------------------------------------- 4266C Calculate U(ci,jk) for fixed d,b for t3-bar. 4267C----------------------------------------------------------------- 4268C 4269 IF (.NOT. RELORB) THEN 4270C 4271 DTIME = SECOND() 4272C 4273 CALL DZERO(WORK(KUMAT4),NCKIJ(ISCKIJ)) 4274C 4275 IF (CC3) THEN 4276 CALL CCFOP_UMAT(0.0D0,L1AM,ISYML1,L2TP,ISYML2, 4277 * WORK(KXIAJB),ISINT1, 4278 * WORK(KFCKBA),WORK(KTRVI20), 4279 * WORK(KTRVI13),WORK(KTROC03), 4280 * WORK(KTROC23),ISINT2, 4281 * WORK(KFOCKD),WORK(KDIAG), 4282 * WORK(KUMAT4),WORK(KTMAT), 4283 * WORK(KEND4),LWRK4,WORK(KINDSQ), 4284 * LENSQ,ISYMD,D,ISYMB,B) 4285C 4286 CALL DSCAL(NCKIJ(ISCKIJ),HALF,WORK(KUMAT4),1) 4287C 4288 ELSE 4289 CALL CCFOP_UMAT(0.0D0,T1AM,ISYMT1,WORK(KT2TCME), 4290 * ISYMT2,WORK(KXIAJB),ISINT1, 4291 * WORK(KFCKBA),WORK(KTRVI10), 4292 * WORK(KTRVI13),WORK(KTROC02), 4293 * WORK(KTROC22),ISINT2, 4294 * WORK(KFOCKD),WORK(KDIAG), 4295 * WORK(KUMAT4),WORK(KTMAT), 4296 * WORK(KEND4),LWRK4,WORK(KINDSQ), 4297 * LENSQ,ISYMD,D,ISYMB,B) 4298 ENDIF 4299C 4300 CALL T3_FORBIDDEN(WORK(KUMAT4),ISYMIM, 4301 * ISYMD,D,ISYMB,B) 4302C 4303 DTIME = SECOND() - DTIME 4304 TIQMAT = TIQMAT + DTIME 4305C 4306 IF (IPRINT .GT. 55) THEN 4307 XQMAT = DDOT(NCKIJ(ISCKIJ),WORK(KUMAT4),1, 4308 * WORK(KUMAT4),1) 4309 WRITE(LUPRI,*) 'Norm of UMAT-BAR-2 ',XQMAT 4310 ENDIF 4311C 4312 ENDIF 4313C 4314C----------------------------------------------------------- 4315C Construct Kappabar_{aa} and Kappabar_{ii} 4316C----------------------------------------------------------- 4317C 4318 IF ((.NOT. CC3) .AND. (RELORB)) THEN 4319C 4320 CALL CCSDT_KAPPADIAG(WORK(KKAPAA),WORK(KKAPII), 4321 * WORK(KSMAT2),WORK(KSMAT), 4322 * WORK(KSMAT3),WORK(KUMAT2), 4323 * WORK(KUMAT),WORK(KUMAT3), 4324 * WORK(KTMAT),WORK(KINDSQ), 4325 * LENSQ,ISCKIJ, 4326 * WORK(KEND4),LWRK4) 4327C 4328 ENDIF 4329C 4330C---------------------------------------------------------------- 4331C Calculate the three extra contributions to the 4332C one-electron density if nonrelaxed 4333C---------------------------------------------------------------- 4334C 4335 IF (.NOT. RELORB) THEN 4336 CALL CCFOP_NONREL(WORK(KOMG12),WORK(KDENSAB), 4337 * WORK(KDENSIJ),ISCKIJ, 4338 * WORK(KSMAT),WORK(KSMAT3), 4339 * WORK(KSMAT2),WORK(KSMAT4), 4340 * WORK(KUMAT),WORK(KUMAT3), 4341 * WORK(KUMAT2),WORK(KUMAT4), 4342 * WORK(KTMAT),T2TP,ISYMT2, 4343 * WORK(KINDSQ),LENSQ, 4344 * ISYMB,B,ISYMD,D, 4345 * WORK(KEND4),LWRK4) 4346 ENDIF 4347C 4348C--------------------------------------------- 4349C Contract with integrals. 4350C--------------------------------------------- 4351C 4352 DTIME = SECOND() 4353C 4354 IF ((.NOT. CC3) .AND. (RELORB)) THEN 4355C 4356 CALL CCFOP_DENVIR(WORK(KVIR1),WORK(KVIR2), 4357 * WORK(KSMAT),WORK(KQMAT), 4358 * WORK(KTMAT),ISYMIM, 4359 * WORK(KT2TCME),ISYMT2,WORK(KEND4), 4360 * LWRK4,WORK(KINDSQ),LENSQ, 4361 * ISYMB,B,ISYMD,D,1) 4362C 4363 IF ((IPRINT .GT. 55)) THEN 4364 XRMAT = DDOT(NCKATR(ISAIJ1),WORK(KVIR1),1, 4365 * WORK(KVIR1),1) 4366 WRITE(LUPRI,*) 'Norm DENS1 - CCFOP_DENVIR',XRMAT 4367 XRMAT = DDOT(NCKATR(ISAIJ1),WORK(KVIR2),1, 4368 * WORK(KVIR2),1) 4369 WRITE(LUPRI,*) 'Norm DENS2 - CCFOP_CONVIR',XRMAT 4370 ENDIF 4371C 4372 CALL CCFOP_DENVIR(WORK(KVIR3),WORK(KVIR4), 4373 * WORK(KSMAT2),WORK(KQMAT2), 4374 * WORK(KTMAT),ISYMIM, 4375 * T2TP,ISYMT2,WORK(KEND4), 4376 * LWRK4,WORK(KINDSQ),LENSQ, 4377 * ISYMB,B,ISYMD,D,2) 4378C 4379 IF ((IPRINT .GT. 55)) THEN 4380 XRMAT = DDOT(NCKATR(ISAIJ1),WORK(KVIR1),1, 4381 * WORK(KVIR1),1) 4382 WRITE(LUPRI,*) 'Norm DENS1 - CCFOP_DENVIR',XRMAT 4383 XRMAT = DDOT(NCKATR(ISAIJ1),WORK(KVIR2),1, 4384 * WORK(KVIR2),1) 4385 WRITE(LUPRI,*) 'Norm DENS2 - CCFOP_CONVIR',XRMAT 4386 ENDIF 4387C 4388C 4389 CALL CCFOP_DENOCC(WORK(KOCC1),WORK(KSMAT), 4390 * WORK(KQMAT),WORK(KTMAT),ISYMIM, 4391 * WORK(KT2TCME),ISYMT2,WORK(KEND4), 4392 * LWRK4,WORK(KINDSQ),LENSQ, 4393 * ISYMB,B,ISYMD,D,1) 4394C 4395 CALL CCFOP_DENOCC(WORK(KOCC2),WORK(KSMAT2), 4396 * WORK(KQMAT2),WORK(KTMAT),ISYMIM, 4397 * T2TP,ISYMT2,WORK(KEND4), 4398 * LWRK4,WORK(KINDSQ),LENSQ, 4399 * ISYMB,B,ISYMD,D,2) 4400C 4401C--------------------------------------- 4402C Calculate Omega22. 4403C--------------------------------------- 4404C 4405 DTIME = SECOND() 4406C 4407 CALL CCFOP_ONEL(WORK(KOMG22),WORK(KRMAT1), 4408 * WORK(KRMAT2),T1AM,WORK(KSMAT), 4409 * WORK(KTMAT),ISYMIM,ISINT1, 4410 * WORK(KINDSQ),LENSQ, 4411 * WORK(KEND4),LWRK4,ISYMB,B,ISYMD,D) 4412C 4413 IF ((IPRINT .GT. 55)) THEN 4414 RHO2N = DDOT(NT2AM(ISYRES),WORK(KOMG22),1, 4415 * WORK(KOMG22),1) 4416 WRITE(LUPRI,*) 'Norm of Rho22 after CC3_ONEL', 4417 * RHO2N 4418 ENDIF 4419C 4420 IF (IPRINT .GT. 220) THEN 4421 CALL AROUND('After CC3_ONEL: ') 4422 CALL CC_PRP(DUMMY,WORK(KOMG22),ISYRES,0,1) 4423 ENDIF 4424C 4425 IF (IPRINT .GT. 55) THEN 4426 XRMAT = DDOT(NCKI(ISAIJ1),WORK(KRMAT1),1, 4427 * WORK(KRMAT1),1) 4428 WRITE(LUPRI,*) 'Norm of RMAT1 -after ONEL',XRMAT 4429 XRMAT = DDOT(NCKI(ISAIJ2),WORK(KRMAT2),1, 4430 * WORK(KRMAT2),1) 4431 WRITE(LUPRI,*) 'Norm of RMAT2 -after ONEL',XRMAT 4432 XTMAT = DDOT(NCKIJ(ISCKIJ),WORK(KSMAT),1, 4433 * WORK(KSMAT),1) 4434 WRITE(LUPRI,*) 'Norm of SMAT -after ONEL',XSMAT 4435 XTMAT = DDOT(NCKIJ(ISCKIJ),WORK(KTMAT),1, 4436 * WORK(KTMAT),1) 4437 WRITE(LUPRI,*) 'Norm of TMAT -after ONEL',XTMAT 4438 ENDIF 4439C 4440 ENDIF ! RELORB 4441C 4442C--------------------------------------------------- 4443C Calculate Omega1. 4444C--------------------------------------------------- 4445C 4446 DTIME = SECOND() - DTIME 4447 TIOME1 = TIOME1 + DTIME 4448C 4449 IF (CC3) THEN 4450 CALL CCFOP_ONED(WORK(KOMG1),L2TP,ISYML2, 4451 * WORK(KSMAT),WORK(KTMAT),ISYMIM, 4452 * WORK(KINDSQ),LENSQ, 4453 * WORK(KEND4),LWRK4,ISYMB,B,ISYMD,D) 4454 ELSE 4455 CALL CCFOP_ONED(WORK(KOMG1),WORK(KT2TCME),ISYMT2, 4456 * WORK(KSMAT),WORK(KTMAT),ISYMIM, 4457 * WORK(KINDSQ),LENSQ, 4458 * WORK(KEND4),LWRK4,ISYMB,B,ISYMD,D) 4459 ENDIF 4460C 4461 IF ((IPRINT .GT. 55)) THEN 4462 XT2TP = DDOT(NT1AM(ISYMOP),WORK(KOMG1),1, 4463 * WORK(KOMG1),1) 4464 WRITE(LUPRI,*) 'Norm of 1 e- density : ',XT2TP 4465 ENDIF 4466C 4467 IF (IPRINT .GT. 220) THEN 4468 CALL AROUND('After CCFOP_ONED: ') 4469 CALL CC_PRP(WORK(KOMG1),DUMMY,ISYRES,1,0) 4470 ENDIF 4471C 4472 DTIME = SECOND() - DTIME 4473 TIOME1 = TIOME1 + DTIME 4474C 4475C--------------------------------------------------------- 4476C Accumulate the R2 matrix in Omega22 4477C--------------------------------------------------------- 4478C 4479 IF ((.NOT. CC3) .AND. (RELORB)) THEN 4480C 4481 CALL CC3_RACC(WORK(KOMG22),WORK(KRMAT2),ISYMB,B, 4482 * ISYRES) 4483C 4484 IF ((IPRINT .GT. 55)) THEN 4485 RHO2N = DDOT(NT2AM(ISYRES),WORK(KOMG22),1, 4486 * WORK(KOMG22),1) 4487 WRITE(LUPRI,*) 'Norm of Rho22-after CC3_RACC', 4488 * RHO2N 4489 ENDIF 4490C 4491 IF (IPRINT .GT. 220) THEN 4492 CALL AROUND('After CC3_RACC: ') 4493 CALL CC_PRP(DUMMY,WORK(KOMG22),ISYRES,0,1) 4494 ENDIF 4495C 4496 ENDIF 4497C 4498 ENDDO ! B 4499 ENDDO ! ISYMB 4500C 4501C--------------------------------------------------- 4502C Accumulate the R1 matrix in Omega22. 4503C--------------------------------------------------- 4504C 4505 IF ((.NOT. CC3) .AND. (RELORB)) THEN 4506C 4507 CALL CC3_RACC(WORK(KOMG22),WORK(KRMAT1),ISYMD,D,ISYRES) 4508C 4509 IF (IPRINT .GT. 55) THEN 4510 RHO2N = DDOT(NT2AM(ISYRES),WORK(KOMG22),1, 4511 * WORK(KOMG22),1) 4512 WRITE(LUPRI,*) 'Norm of Rho22-after CC3_RACC-2',RHO2N 4513 ENDIF 4514C 4515 IF (IPRINT .GT. 220) THEN 4516 CALL AROUND('After CC3_RACC-2: ') 4517 CALL CC_PRP(DUMMY,WORK(KOMG22),ISYRES,0,1) 4518 ENDIF 4519C 4520C-------------------------------------------------------------- 4521C Sort the two electron densities from T3 for a constant 4522C d and write them to file. 4523C-------------------------------------------------------------- 4524C 4525 IF (LWRK4 .LT. NCKATR(ISAIJ1)) THEN 4526 CALL QUIT('Exceeded memory in CCSDPT_DENS2 (sort)') 4527 ENDIF 4528C 4529 CALL DEN_AIBSORT(WORK(KVIR1),WORK(KEND4),ISAIJ1) 4530C 4531 CALL DEN_AIBSORT(WORK(KVIR2),WORK(KEND4),ISAIJ1) 4532C 4533 IOFF = ICKBD(ISAIJ1,ISYMD) 4534 * + NCKATR(ISAIJ1)*(D-1) 4535 * + 1 4536 CALL PUTWA2(LUABI2,FNDABI2,WORK(KVIR1),IOFF, 4537 * NCKATR(ISAIJ1)) 4538C 4539 CALL PUTWA2(LUABI1,FNDABI1,WORK(KVIR2),IOFF, 4540 * NCKATR(ISAIJ1)) 4541C 4542 IF (IPRINT .GT. 55) THEN 4543 RHO1N = DDOT(NCKATR(ISAIJ1),WORK(KVIR1),1, 4544 * WORK(KVIR1),1) 4545 WRITE(LUPRI,*) 'Norm of VIR1 : ',RHO1N 4546 RHO1N = DDOT(NCKATR(ISAIJ1),WORK(KVIR2),1, 4547 * WORK(KVIR2),1) 4548 WRITE(LUPRI,*) 'Norm of VIR2 : ',RHO1N 4549 ENDIF 4550C 4551C---------------------------------------------------------------------- 4552C Sort the two electron densities from T3-bar for a constant 4553C d and write them to file. 4554C---------------------------------------------------------------------- 4555C 4556 IF (LWRK4 .LT. NCKATR(ISAIJ1)) THEN 4557 CALL QUIT('Exceeded memory in CCSDPT_DENS2 (sort)') 4558 ENDIF 4559C 4560 CALL DEN_AIBSORT(WORK(KVIR3),WORK(KEND4),ISAIJ1) 4561C 4562 CALL DEN_AIBSORT(WORK(KVIR4),WORK(KEND4),ISAIJ1) 4563C 4564 IOFF = ICKBD(ISAIJ1,ISYMD) 4565 * + NCKATR(ISAIJ1)*(D-1) 4566 * + 1 4567 CALL PUTWA2(LUABI4,FNDABI4,WORK(KVIR3),IOFF, 4568 * NCKATR(ISAIJ1)) 4569C 4570 CALL PUTWA2(LUABI3,FNDABI3,WORK(KVIR4),IOFF, 4571 * NCKATR(ISAIJ1)) 4572C 4573 IF (IPRINT .GT. 55) THEN 4574 RHO1N = DDOT(NCKATR(ISAIJ1),WORK(KVIR3),1, 4575 * WORK(KVIR3),1) 4576 WRITE(LUPRI,*) 'Norm of VIR3 : ',RHO1N 4577 RHO1N = DDOT(NCKATR(ISAIJ1),WORK(KVIR4),1, 4578 * WORK(KVIR4),1) 4579 WRITE(LUPRI,*) 'Norm of VIR4 : ',RHO1N 4580 ENDIF 4581C 4582 ENDIF ! RELORB 4583C 4584 ENDDO ! D 4585 ENDDO ! ISYMD 4586C 4587C--------------------------------------------------------- 4588C Construct 2*C-E of work(komg22) and write to file. 4589C--------------------------------------------------------- 4590C 4591 IF ((.NOT. CC3) .AND. (RELORB)) THEN 4592 IOPTTCME = 1 4593 ISYOPE = ISYRES 4594 CALL CCSD_TCMEPK(WORK(KOMG22),1.0D0,ISYOPE,IOPTTCME) 4595C 4596 IF ((IPRINT .GT. 55)) THEN 4597 RHO2N = DDOT(NT2AM(ISYRES),WORK(KOMG22),1,WORK(KOMG22),1) 4598 WRITE(LUPRI,*) 'Norm of Rho22 at the end ',RHO2N 4599 ENDIF 4600C 4601 IF (IPRINT .GT. 100) THEN 4602 CALL AROUND('TWO ELECTRON DENSITY : D_{IAJB}') 4603 CALL CC_PRP(T1AM,WORK(KOMG22),ISYRES,0,1) 4604 ENDIF 4605C 4606 IF (NT2AM(ISYRES) .GT. 0) THEN 4607 IOFF = 1 4608 CALL PUTWA2(LUPTIAJB,FNDIAJB,WORK(KOMG22),IOFF, 4609 * NT2AM(ISYRES)) 4610 ENDIF 4611C 4612 IF (LDEBUG .AND. (.NOT. CC3)) THEN 4613 LENGTH = IRAT*NT2AM(ISYRES) 4614C 4615 REWIND(LUIAJB) 4616 CALL READI(LUIAJB,LENGTH,WORK(KXIAJB)) 4617 CALL CCLR_DIASCL(WORK(KXIAJB),0.5D0,ISYMop) 4618 CALL DSCAL(NT2AM(ISYMOP),2.0D0,WORK(KOMG22),1) 4619C 4620 XQMAT = DDOT(NT2AM(ISYRES),WORK(KOMG22),1,WORK(KXIAJB),1) 4621 WRITE(LUPRI,*) 'DEBUGGING CCSD(T) : E5 = ',XQMAT 4622 ENDIF 4623C 4624 ENDIF 4625C 4626C--------------------------------------- 4627C Scale and store the 1 e- density : 4628C--------------------------------------- 4629C 4630 IF (CC3) THEN 4631 CALL DSCAL(NT1AM(ISYRES),-ONE,WORK(KOMG1),1) 4632 ELSE 4633 CALL DSCAL(NT1AM(ISYRES),-TWO,WORK(KOMG1),1) 4634 ENDIF 4635C 4636 IF (IPRINT .GT. 55) THEN 4637 RHO1N = DDOT(NT1AM(ISYRES),WORK(KOMG1),1,WORK(KOMG1),1) 4638 WRITE(LUPRI,*) 'Norm of OMEG1 at the end : ',RHO1N 4639 ENDIF 4640C 4641 IF (IPRINT .GT. 100) THEN 4642 CALL AROUND('1 e- in CCSDPT_DENS2 : ') 4643 CALL CC_PRP(WORK(KOMG1),DUMMY,ISYRES,1,0) 4644 ENDIF 4645C 4646 IF (NT1AM(ISYRES) .GT. 0) THEN 4647 IOFF = 1 4648 CALL PUTWA2(LUPTIA,FNDPTIA,WORK(KOMG1),IOFF,NT1AM(ISYRES)) 4649 ENDIF 4650C 4651C---------------------------------------------------------- 4652C Add the 1e- to the d_{iajk} for j=k and for i=k 4653C---------------------------------------------------------- 4654C 4655 IF ((IPRINT .GT. 55)) THEN 4656 RHO1N = DDOT(NCKIJ(ISYRES),WORK(KOCC1),1,WORK(KOCC1),1) 4657 WRITE(LUPRI,*) 'Norm of OCC1 (iajk) (before dens1to2) =',RHO1N 4658 ENDIF 4659C 4660 IF ((.NOT. CC3) .AND. (RELORB)) THEN 4661 CALL DENS1TO2(WORK(KOMG1),WORK(KOCC1),ISYRES) 4662 ENDIF 4663C 4664 IF ((IPRINT .GT. 55)) THEN 4665 RHO1N = DDOT(NCKIJ(ISYRES),WORK(KOCC1),1,WORK(KOCC1),1) 4666 WRITE(LUPRI,*) 'Norm of OCC1 (iajk) (after dens1to2) =',RHO1N 4667 ENDIF 4668C 4669C----------------------------------------------------------- 4670C If nonrel store the three extra terms on disc 4671C----------------------------------------------------------- 4672C 4673 IF (.NOT. RELORB) THEN 4674C 4675 IF (NMATAB(ISYRES) .GT. 0) THEN 4676 IOFF = 1 4677 CALL PUTWA2(LUPTAB,FNDPTAB,WORK(KDENSAB),IOFF,NMATAB(ISYRES)) 4678 ENDIF 4679C 4680 IF (NMATIJ(ISYRES) .GT. 0) THEN 4681 IOFF = 1 4682 CALL PUTWA2(LUPTIJ,FNDPTIJ,WORK(KDENSIJ),IOFF,NMATIJ(ISYRES)) 4683 ENDIF 4684C 4685 CALL DSCAL(NT1AM(ISYRES),-TWO,WORK(KOMG12),1) 4686 IF (NT1AM(ISYRES) .GT. 0) THEN 4687 IOFF = 1 4688 CALL PUTWA2(LUPTIA2,FNDPTIA2,WORK(KOMG12),IOFF,NT1AM(ISYRES)) 4689 ENDIF 4690C 4691 ENDIF 4692C 4693C--------------------------------------------------------------- 4694C Construct the total d(ab,ic) density stored as (ai,b,c) 4695C from the T3 amplitudes. 4696C--------------------------------------------------------------- 4697C 4698 IF ((.NOT. CC3) .AND. (RELORB)) THEN 4699C 4700 CALL DENSTORE(WORK(KVIR2),LUABI1,FNDABI1, 4701 * WORK(KVIR1),LUABI2,FNDABI2,ISYRES) 4702C 4703C 4704C--------------------------------------------------------------- 4705C Construct the total d(ab,ci) density stored as (bi,a,c) 4706C from the T3-bar amplitudes. 4707C--------------------------------------------------------------- 4708C 4709 CALL DENSTORE(WORK(KVIR4),LUABI3,FNDABI3, 4710 * WORK(KVIR3),LUABI4,FNDABI4,ISYRES) 4711C 4712C----------------------------------------- 4713C Store the d_{iajk} as kjia 4714C----------------------------------------- 4715C 4716 IF (NCKIJ(ISYRES) .GT. 0) THEN 4717 IOFF = 1 4718 CALL PUTWA2(LUIAJK,FNDIAJK,WORK(KOCC1),IOFF,NCKIJ(ISYRES)) 4719 ENDIF 4720C 4721C----------------------------------------- 4722C Store the d_{aijk} as jkia 4723C----------------------------------------- 4724C 4725 IF ((IPRINT .GT. 55)) THEN 4726 RHO1N = DDOT(NCKIJ(ISYRES),WORK(KOCC2),1,WORK(KOCC2),1) 4727 WRITE(LUPRI,*) 'Norm of OCC2 (aijk) = ',RHO1N 4728 ENDIF 4729C 4730 IF (NCKIJ(ISYRES) .GT. 0) THEN 4731 IOFF = 1 4732 CALL PUTWA2(LUAIJK,FNDAIJK,WORK(KOCC2),IOFF,NCKIJ(ISYRES)) 4733 ENDIF 4734C 4735C------------------------------------------ 4736C Store kappabar_{aa} and kappabar_{ii} 4737C------------------------------------------ 4738C 4739 IF ((IPRINT .GT. 55)) THEN 4740 RHO1N = DDOT(NRHFT,WORK(KKAPII),1,WORK(KKAPII),1) 4741 WRITE(LUPRI,*) 'Norm of KAPII : ',RHO1N 4742 RHO1N = DDOT(NVIRT,WORK(KKAPAA),1,WORK(KKAPAA),1) 4743 WRITE(LUPRI,*) 'Norm of KAPAA : ',RHO1N 4744 ENDIF 4745C 4746 LUKAPAB = -1 4747 LUKAPIJ = -1 4748 FNKAPAB = 'KAPAB' 4749 FNKAPIJ = 'KAPIJ' 4750 CALL WOPEN2(LUKAPAB,FNKAPAB,64,0) 4751 CALL WOPEN2(LUKAPIJ,FNKAPIJ,64,0) 4752C 4753 IF (NVIRT .GT. 0) THEN 4754 IOFF = 1 4755 CALL PUTWA2(LUKAPAB,FNKAPAB,WORK(KKAPAA),IOFF,NVIRT) 4756 ENDIF 4757C 4758 IF (NRHFT .GT. 0) THEN 4759 IOFF = 1 4760 CALL PUTWA2(LUKAPIJ,FNKAPIJ,WORK(KKAPII),IOFF,NRHFT) 4761 ENDIF 4762C 4763 CALL WCLOSE2(LUKAPAB,FNKAPAB,'KEEP') 4764 CALL WCLOSE2(LUKAPIJ,FNKAPIJ,'KEEP') 4765C 4766 ENDIF ! RELORB 4767C 4768C^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 4769C SONIA: symmetrize/reorder some two-electron densities 4770C before closing, and generate backtransformed ones!!! 4771C Symmetrize the vir.vir.occ.vir and vir.vir.vir.occ 4772C Symmetrize the occ.occ.occ.vir and occ.occ.vir.occ 4773C and backtransform last index to delta 4774C---------------------------------------------------------- 4775C 4776 IF ((.NOT. CC3) .AND. RELORB) THEN 4777 CALL SYMMBACK(MODEL,LUIAJK,FNDIAJK,LUAIJK,FNDAIJK, 4778 * LUABI1,FNDABI1,LUABI3,FNDABI3, 4779 * LUPTIAJB,FNDIAJB, 4780 * ISYRES,WORK(KEND4),LWRK4) 4781 ENDIF 4782C 4783C--------------------------------------- 4784C Close files. 4785C--------------------------------------- 4786C 4787 CALL WCLOSE2(LUPTIA,FNDPTIA,'KEEP') 4788C 4789 IF ((.NOT. CC3) .AND. (RELORB)) THEN 4790 CALL WCLOSE2(LUPTIAJB,FNDIAJB,'KEEP') 4791 CALL WCLOSE2(LUABI1,FNDABI1,'KEEP') 4792 CALL WCLOSE2(LUABI2,FNDABI2,'DELETE') 4793 CALL WCLOSE2(LUABI3,FNDABI3,'KEEP') 4794 CALL WCLOSE2(LUABI4,FNDABI4,'DELETE') 4795 CALL WCLOSE2(LUAIJK,FNDAIJK,'KEEP') 4796 CALL WCLOSE2(LUIAJK,FNDIAJK,'KEEP') 4797 ELSE 4798 CALL WCLOSE2(LUPTIA2,FNDPTIA2,'KEEP') 4799 CALL WCLOSE2(LUPTAB,FNDPTAB,'KEEP') 4800 CALL WCLOSE2(LUPTIJ,FNDPTIJ,'KEEP') 4801 ENDIF 4802C 4803C------------------- 4804C Print timings. 4805C------------------- 4806C 4807 IF (IPRINT .GT. 9) THEN 4808 WRITE(LUPRI,*) 4809 WRITE(LUPRI,*) 4810 WRITE(LUPRI,1) 'CC3_TRAN : ',TITRAN 4811 WRITE(LUPRI,1) 'CC3_SORT : ',TISORT 4812 WRITE(LUPRI,1) 'CC3_SMAT : ',TISMAT 4813 WRITE(LUPRI,1) 'CC3_QMAT : ',TIQMAT 4814 WRITE(LUPRI,1) 'CC3_CONV : ',TICONV 4815 WRITE(LUPRI,1) 'CC3_CONO : ',TICONO 4816 WRITE(LUPRI,1) 'CC3_OME1 : ',TIOME1 4817 WRITE(LUPRI,*) 4818 END IF 4819C 4820C------------- 4821C End 4822C------------- 4823C 4824 CALL QEXIT('CCSDPT_DENS2') 4825C 4826 RETURN 4827C 4828 1 FORMAT(7X,'Time used in',2X,A12,F12.2,' seconds') 4829C 4830 END 4831C /* Deck ccfop_onel */ 4832 SUBROUTINE CCFOP_ONEL(OMEGA2,RMAT1,RMAT2,T1AM,SMAT,TMAT, 4833 * ISYMIM,ISYINT,INDSQ,LENSQ,WORK,LWORK, 4834 * ISYMIB,IB,ISYMID,ID) 4835C 4836C Kasper Hald, Fall 2001. 4837C Based on cc3_onel by 4838C Henrik Koch and Alfredo Sanchez. Dec 1994 4839C Ove Christiansen 9-1-1996: 4840C 4841C Calculate 2 electon density iajb in CCSD(T) 4842C 4843C 4844C General symmetry: ISYMIM is symmetry of SMAT and TMAT 4845C intermdiates.(incl isymd,isymb) 4846C ISYINT is symmetry of T1AM 4847C ISYRES = ISYMIM*ISYINT 4848C 4849 IMPLICIT NONE 4850C 4851#include "priunit.h" 4852#include "ccorb.h" 4853#include "ccsdinp.h" 4854#include "ccsdsym.h" 4855C 4856 INTEGER ISYMIM, ISYINT, LENSQ, LWORK, ISYMIB, IB, ISYMID, ID 4857 INTEGER ISYRES, ISYMB, ISYMC, ISYMK, ISYMBC, JSAIKJ 4858 INTEGER ISYAIJ, ISYMCK, LENGTH, NCK, KOFF1, NTOAIJ 4859 INTEGER NTOTC, ISYMBK, NBK, NTOTB, JSAKIJ, ISYMIJ, ISYMAK 4860 INTEGER NTOTAK, NTOTIJ, ISYMJ, ISYMI, ISYMCI, NBJ, NIJ, NCI, NCIBJ 4861 INTEGER ISYMBJ 4862 INTEGER INDEX, INDSQ(LENSQ,6) 4863C 4864#if defined (SYS_CRAY) 4865 REAL OMEGA2(*), RMAT1(*), RMAT2(*), T1AM(*), SMAT(*) 4866 REAL TMAT(*), WORK(LWORK) 4867 REAL ZERO, ONE, TWO 4868#else 4869 DOUBLE PRECISION OMEGA2(*), RMAT1(*), RMAT2(*), T1AM(*), SMAT(*) 4870 DOUBLE PRECISION TMAT(*), WORK(LWORK) 4871 DOUBLE PRECISION ZERO, ONE, TWO 4872#endif 4873C 4874 PARAMETER (ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0) 4875C 4876 INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 4877C 4878 CALL QENTER('CCFOP_ONEL') 4879C 4880 ISYRES = MULD2H(ISYMIM,ISYINT) 4881C 4882 B = IB 4883 C = ID 4884C 4885 ISYMB = ISYMIB 4886 ISYMC = ISYMID 4887C 4888C---------------------------------- 4889C First contribution to Omega2. 4890C---------------------------------- 4891C 4892 ISYMK = MULD2H(ISYMC,ISYINT) 4893 ISYMBC = MULD2H(ISYMB,ISYMC) 4894 JSAIKJ = MULD2H(ISYMBC,ISYMIM) 4895 ISYAIJ = MULD2H(ISYMK,JSAIKJ) 4896 ISYMCK = MULD2H(ISYMC,ISYMK) 4897C 4898 LENGTH = NCKIJ(JSAIKJ) 4899C 4900 IF (LWORK .LT. LENGTH) THEN 4901 CALL QUIT('Not enough core in CCSDT_ONEL') 4902 END IF 4903C 4904 DO I = 1,LENGTH 4905 TMAT(I) = SMAT(INDSQ(I,4)) 4906 * - SMAT(INDSQ(I,3)) 4907 ENDDO 4908C 4909 NCK = IT1AM(ISYMC,ISYMK) + C 4910C 4911 KOFF1 = ISAIKJ(ISYAIJ,ISYMK) + 1 4912C 4913 NTOAIJ = MAX(NCKI(ISYAIJ),1) 4914 NTOTC = MAX(NVIR(ISYMC),1) 4915C 4916 CALL DGEMV('N',NCKI(ISYAIJ),NRHF(ISYMK),ONE,TMAT(KOFF1),NTOAIJ, 4917 * T1AM(NCK),NTOTC,ONE,RMAT2,1) 4918C 4919C----------------------------------- 4920C Second contribution to Omega2. 4921C----------------------------------- 4922C 4923 ISYMK = MULD2H(ISYMB,ISYINT) 4924 ISYMBC = MULD2H(ISYMB,ISYMC) 4925 JSAIKJ = MULD2H(ISYMBC,ISYMIM) 4926 ISYAIJ = MULD2H(ISYMK,JSAIKJ) 4927 ISYMBK = MULD2H(ISYMB,ISYMK) 4928C 4929 LENGTH = NCKIJ(JSAIKJ) 4930C 4931 IF (LWORK .LT. LENGTH) THEN 4932 CALL QUIT('Not enough core in CCFOP_ONEL') 4933 END IF 4934C 4935 DO I = 1,LENGTH 4936 TMAT(I) = SMAT(INDSQ(I,5)) 4937 * - SMAT(I) 4938 ENDDO 4939C 4940 NBK = IT1AM(ISYMB,ISYMK) + B 4941C 4942 KOFF1 = ISAIKJ(ISYAIJ,ISYMK) + 1 4943C 4944 NTOAIJ = MAX(NCKI(ISYAIJ),1) 4945 NTOTB = MAX(NVIR(ISYMB),1) 4946C 4947 CALL DGEMV('N',NCKI(ISYAIJ),NRHF(ISYMK),ONE,TMAT(KOFF1),NTOAIJ, 4948 * T1AM(NBK),NTOTB,ONE,RMAT1,1) 4949C 4950C---------------------------------- 4951C Third contribution to Omega2. 4952C---------------------------------- 4953C 4954 ISYMBC = MULD2H(ISYMB,ISYMC) 4955 JSAKIJ = MULD2H(ISYMBC,ISYMIM) 4956 ISYMIJ = MULD2H(ISYMBC,ISYRES) 4957 ISYMAK = MULD2H(JSAKIJ,ISYMIJ) 4958C 4959 LENGTH = NCKIJ(JSAKIJ) 4960C 4961 IF (LWORK .LT. LENGTH) THEN 4962 CALL QUIT('Not enough core in CCSDT_ONEL') 4963 END IF 4964C 4965 DO I = 1,LENGTH 4966 TMAT(I) = SMAT(INDSQ(I,1)) 4967 * - SMAT(I) 4968 ENDDO 4969C 4970C Symmetry sorting if symmetry 4971C ---------------------------- 4972C 4973 IF (NSYM .GT. 1) THEN 4974 CALL CC_GATHER(LENGTH,WORK,TMAT,INDSQ(1,6)) 4975 CALL DCOPY(LENGTH,WORK,1,TMAT,1) 4976 ENDIF 4977C 4978 NTOTAK = MAX(NT1AM(ISYMAK),1) 4979 NTOTIJ = MAX(NMATIJ(ISYMIJ),1) 4980C 4981 KOFF1 = ISAIKL(ISYMAK,ISYMIJ) + 1 4982C 4983 CALL DGEMV('T',NT1AM(ISYMAK),NMATIJ(ISYMIJ),ONE,TMAT(KOFF1), 4984 * NTOTAK,T1AM,1,ZERO,WORK,1) 4985C 4986 DO ISYMJ = 1,NSYM 4987C 4988 ISYMI = MULD2H(ISYMIJ,ISYMJ) 4989C 4990 ISYMBJ = MULD2H(ISYMB,ISYMJ) 4991 ISYMCI = MULD2H(ISYMC,ISYMI) 4992C 4993 DO J = 1,NRHF(ISYMJ) 4994C 4995 NBJ = IT1AM(ISYMB,ISYMJ) + NVIR(ISYMB)*(J - 1) + B 4996C 4997 IF (ISYMCI .EQ. ISYMBJ) THEN 4998C 4999 DO I = 1,NRHF(ISYMI) 5000C 5001 NIJ = IMATIJ(ISYMI,ISYMJ) + NRHF(ISYMI)*(J - 1) + I 5002 NCI = IT1AM(ISYMC,ISYMI) + NVIR(ISYMC)*(I - 1) + C 5003C 5004 IF (NCI .EQ. NBJ) WORK(NIJ) = TWO*WORK(NIJ) 5005C 5006 NCIBJ = IT2AM(ISYMCI,ISYMBJ) + INDEX(NCI,NBJ) 5007C 5008 OMEGA2(NCIBJ) = OMEGA2(NCIBJ) + WORK(NIJ) 5009C 5010 ENDDO 5011C 5012 ELSE IF (ISYMCI .LT. ISYMBJ) THEN 5013C 5014 DO I = 1,NRHF(ISYMI) 5015C 5016 NIJ = IMATIJ(ISYMI,ISYMJ) + NRHF(ISYMI)*(J - 1) + I 5017 NCI = IT1AM(ISYMC,ISYMI) + NVIR(ISYMC)*(I - 1) + C 5018C 5019 NCIBJ = IT2AM(ISYMCI,ISYMBJ) 5020 * + NT1AM(ISYMCI)*(NBJ-1) + NCI 5021C 5022 OMEGA2(NCIBJ) = OMEGA2(NCIBJ) + WORK(NIJ) 5023C 5024 ENDDO 5025C 5026 ELSE IF (ISYMBJ .LT. ISYMCI) THEN 5027C 5028 DO I = 1,NRHF(ISYMI) 5029C 5030 NIJ = IMATIJ(ISYMI,ISYMJ) + NRHF(ISYMI)*(J - 1) + I 5031 NCI = IT1AM(ISYMC,ISYMI) + NVIR(ISYMC)*(I - 1) + C 5032C 5033 NCIBJ = IT2AM(ISYMBJ,ISYMCI) 5034 * + NT1AM(ISYMBJ)*(NCI-1) + NBJ 5035C 5036 OMEGA2(NCIBJ) = OMEGA2(NCIBJ) + WORK(NIJ) 5037C 5038 ENDDO 5039C 5040 ENDIF 5041C 5042 ENDDO 5043C 5044 ENDDO 5045C 5046 CALL QEXIT('CCFOP_ONEL') 5047C 5048 RETURN 5049 END 5050C /* Deck ccfop_denvir */ 5051 SUBROUTINE CCFOP_DENVIR(RINTE1,RINTE2,SMAT,QMAT,TMAT,ISYMIM, 5052 * T2TCME,ISYMT2,WORK,LWORK,INDSQ,LENSQ, 5053 * ISYMB,B,ISYMD,D,IOPT) 5054C 5055C Kasper Hald, Fall 2001. 5056C 5057C Calculate the two electron density (abic) for a constant index D, 5058C and add to the density RINTE1 and RINTE2. 5059C 5060C ISYMIM is the symmetry of the SMAT and TMAT intermdiates. 5061C ISYMT2 is the symmetry of the T2 amplitudes. 5062C 5063C IOPT = 1. Calculate the terms from T3AM. 5064C IOPT = 2. Calculate the terms from T3BAR. 5065C 5066 IMPLICIT NONE 5067C 5068#include "priunit.h" 5069#include "ccorb.h" 5070#include "ccsdinp.h" 5071#include "ccsdsym.h" 5072C 5073 INTEGER ISYMIM, ISYMT2, LWORK, LENSQ, ISYMB, ISYMD, IOPT 5074 INTEGER INDSQ(LENSQ,6) 5075 INTEGER INDEX, ISYRES, ISYMBD, ISCKIJ, LENGTH, ISYAIJ, ISYMAI 5076 INTEGER ISYMA, ISYMIJ, ISYMI, ISYMJ, NAI, KOFF1, KOFF2, KOFF3 5077 INTEGER ISYMK, ISYCIJ, ISYMC, ISYMAB, ISYMCK, NTOTCK, NTOTIJ 5078 INTEGER ISYBIJ, ISYMBJ, NTOTA 5079C 5080#if defined (SYS_CRAY) 5081 REAL RINTE1(*), RINTE2(*), SMAT(*), QMAT(*) 5082 REAL TMAT(*), T2TCME(*), WORK(LWORK) 5083 REAL ZERO, ONE, TWO, HALF 5084#else 5085 DOUBLE PRECISION RINTE1(*), RINTE2(*), SMAT(*), QMAT(*) 5086 DOUBLE PRECISION TMAT(*), T2TCME(*), WORK(LWORK) 5087 DOUBLE PRECISION ZERO, ONE, TWO, HALF 5088#endif 5089 PARAMETER (ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, HALF = 0.5D0) 5090C 5091C 5092C INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 5093C 5094 CALL QENTER('CCFOP_DENVIR') 5095C 5096C----------------------------------------------- 5097C Sanity check and symmetry calculation. 5098C----------------------------------------------- 5099C 5100 IF (IOPT .NE. 1 .AND. IOPT .NE. 2) THEN 5101 CALL QUIT('Wrong IOPT in CCFOP_DENVIR') 5102 ENDIF 5103C 5104 ISYRES = MULD2H(ISYMIM,ISYMT2) 5105C 5106 ISYMBD = MULD2H(ISYMB,ISYMD) 5107 ISCKIJ = MULD2H(ISYMBD,ISYMIM) 5108C 5109 LENGTH = NCKIJ(ISCKIJ) 5110C 5111C 5112C---------------------------------------- 5113C Sort the T2 for a constant B 5114C---------------------------------------- 5115C 5116 ISYAIJ = MULD2H(ISYMT2,ISYMB) 5117C 5118 IF (LWORK .LT. NCKATR(ISYAIJ)) THEN 5119 CALL QUIT('Exceeded work memory in CCFOP_DENVIR') 5120 ENDIF 5121C 5122 DO ISYMA = 1, NSYM 5123 ISYMIJ = MULD2H(ISYAIJ,ISYMA) 5124 ISYBIJ = MULD2H(ISYMIJ,ISYMB) 5125 DO ISYMI = 1, NSYM 5126C 5127 ISYMJ = MULD2H(ISYMIJ,ISYMI) 5128 ISYMBJ = MULD2H(ISYMJ,ISYMB) 5129 ISYMAI = MULD2H(ISYMA,ISYMI) 5130C 5131 DO A = 1, NVIR(ISYMA) 5132 DO I = 1, NRHF(ISYMI) 5133C 5134 NAI = IT1AM(ISYMA,ISYMI) 5135 * + NVIR(ISYMA)*(I-1) + A 5136C 5137 KOFF1 = IT2SP(ISYBIJ,ISYMA) 5138 * + NCKI(ISYBIJ)*(A - 1) 5139C * + ISAIK(ISYMBJ,ISYMI) 5140 * + ICKI(ISYMBJ,ISYMI) 5141 * + NT1AM(ISYMBJ)*(I-1) 5142 * + IT1AM(ISYMB,ISYMJ) 5143 * + B 5144C 5145 KOFF2 = ISAIK(ISYMAI,ISYMJ) 5146 * + IT1AM(ISYMA,ISYMI) 5147 * + NVIR(ISYMA)*(I-1) 5148 * + A 5149C 5150 CALL DCOPY(NRHF(ISYMJ),T2TCME(KOFF1),NVIR(ISYMB), 5151 * WORK(KOFF2),NT1AM(ISYMAI)) 5152C 5153 ENDDO ! I 5154 ENDDO ! A 5155 ENDDO ! ISYMI 5156 ENDDO ! ISYMA 5157C 5158C------------------------ 5159C First term. 5160C------------------------ 5161C 5162 DO I = 1,LENGTH 5163C 5164 IF (IOPT .EQ. 1) THEN 5165C 5166 TMAT(I) = TWO*SMAT(I) 5167 * - SMAT(INDSQ(I,1)) 5168 * - SMAT(INDSQ(I,5)) 5169 * + TWO*QMAT(INDSQ(I,3)) 5170 * - QMAT(INDSQ(I,2)) 5171 * - QMAT(INDSQ(I,4)) 5172C 5173 ELSE 5174 TMAT(I) =-HALF*SMAT(I) 5175 * -HALF*QMAT(INDSQ(I,3)) 5176 ENDIF 5177C 5178 ENDDO 5179C------------------------------ 5180C Contract with T2 5181C------------------------------ 5182C 5183 DO ISYMK = 1,NSYM 5184C 5185 ISYCIJ = MULD2H(ISCKIJ,ISYMK) 5186C 5187 DO ISYMC = 1, NSYM 5188C 5189 ISYMIJ = MULD2H(ISYCIJ,ISYMC) 5190 ISYMAB = MULD2H(ISYMT2,ISYMIJ) 5191 ISYMA = MULD2H(ISYMAB,ISYMB) 5192 ISYMCK = MULD2H(ISYMC,ISYMK) 5193C 5194 NTOTCK = MAX(NT1AM(ISYMCK),1) 5195 NTOTIJ = MAX(NMATIJ(ISYMIJ),1) 5196 NTOTA = MAX(NVIR(ISYMA),1) 5197C 5198 KOFF1 = ISAIK(ISYMAI,ISYMJ) + 1 5199 KOFF2 = ISAIKL(ISYMCK,ISYMIJ) + 1 5200 KOFF3 = ICKATR(ISYMCK,ISYMA) + 1 5201C 5202 CALL DGEMM('N','T',NVIR(ISYMA),NT1AM(ISYMCK), 5203 * NMATIJ(ISYMIJ),TWO,WORK(KOFF1),NTOTA, 5204 * TMAT(KOFF2),NTOTCK,ONE,RINTE1(KOFF3), 5205 * NTOTA) 5206C 5207 ENDDO ! ISYMC 5208 ENDDO ! ISYMK 5209C 5210C------------------------- 5211C Second term. 5212C------------------------- 5213C 5214 DO I = 1,LENGTH 5215C 5216 IF (IOPT .EQ. 1) THEN 5217C 5218 TMAT(I) = TWO*SMAT(INDSQ(I,1)) 5219 * - SMAT(I) 5220 * - SMAT(INDSQ(I,2)) 5221 * + TWO*QMAT(INDSQ(I,2)) 5222 * - QMAT(INDSQ(I,3)) 5223 * - QMAT(INDSQ(I,1)) 5224C 5225 ELSE 5226 TMAT(I) =-HALF*SMAT(INDSQ(I,1)) 5227 * -HALF*QMAT(INDSQ(I,2)) 5228 ENDIF 5229 ENDDO 5230C 5231C------------------------------ 5232C Contract with T2 5233C------------------------------ 5234C 5235 DO ISYMK = 1,NSYM 5236C 5237 ISYCIJ = MULD2H(ISCKIJ,ISYMK) 5238C 5239 DO ISYMC = 1, NSYM 5240C 5241 ISYMIJ = MULD2H(ISYCIJ,ISYMC) 5242 ISYMAB = MULD2H(ISYMT2,ISYMIJ) 5243 ISYMA = MULD2H(ISYMAB,ISYMB) 5244 ISYMCK = MULD2H(ISYMC,ISYMK) 5245C 5246 NTOTCK = MAX(NT1AM(ISYMCK),1) 5247 NTOTIJ = MAX(NMATIJ(ISYMIJ),1) 5248 NTOTA = MAX(NVIR(ISYMA),1) 5249C 5250 KOFF1 = ISAIK(ISYMAI,ISYMJ) + 1 5251 KOFF2 = ISAIKL(ISYMCK,ISYMIJ) + 1 5252 KOFF3 = ICKATR(ISYMCK,ISYMA) + 1 5253C 5254 CALL DGEMM('N','T',NVIR(ISYMA),NT1AM(ISYMCK), 5255 * NMATIJ(ISYMIJ),TWO,WORK(KOFF1),NTOTA, 5256 * TMAT(KOFF2),NTOTCK,ONE,RINTE2(KOFF3), 5257 * NTOTA) 5258C 5259 ENDDO ! ISYMC 5260 ENDDO ! ISYMK 5261C 5262C 5263 CALL QEXIT('CCFOP_DENVIR') 5264C 5265 RETURN 5266 END 5267C /* Deck t3_forbidden */ 5268 SUBROUTINE T3_FORBIDDEN(SMAT,ISYMIM,ISYMB,B,ISYMD,D) 5269C 5270C Written by Kasper Hald, Fall 2001. 5271C 5272C Purpose : Remove the forbidden t3/t3-bar amplitudes. 5273C 5274 IMPLICIT NONE 5275C 5276#include "ccsdsym.h" 5277#include "ccorb.h" 5278C 5279 INTEGER ISYMIM, ISYMB, ISYMD, ISYIJK, ISYMK, ISYMIJ 5280 INTEGER ISYBIJ, ISYMJ, ISYMI, ISYMBI, KOFF1, ISYMBD 5281 INTEGER ISYMAI, ISYMA 5282C 5283#if defined (SYS_CRAY) 5284 REAL SMAT(*), ZERO 5285#else 5286 DOUBLE PRECISION SMAT(*), ZERO 5287#endif 5288C 5289 PARAMETER (ZERO = 0.0D0) 5290C 5291 CALL QENTER('T3_FORBIDDEN') 5292C 5293C--------------------------------------------------------- 5294C If B and D are the same remove all amplitudes 5295C having an A which is the same as B and D. 5296C--------------------------------------------------------- 5297C 5298 IF ((ISYMB .EQ. ISYMD) .AND. (B .EQ. D) ) THEN 5299 ISYIJK = MULD2H(ISYMB,ISYMIM) 5300 DO ISYMK = 1, NSYM 5301 ISYMIJ = MULD2H(ISYMK,ISYIJK) 5302 ISYBIJ = MULD2H(ISYMIJ,ISYMB) 5303 DO ISYMJ = 1, NSYM 5304 ISYMI = MULD2H(ISYMJ,ISYMIJ) 5305 ISYMBI = MULD2H(ISYMB,ISYMI) 5306C 5307 DO K = 1, NRHF(ISYMK) 5308 DO J = 1, NRHF(ISYMJ) 5309 DO I = 1, NRHF(ISYMI) 5310 KOFF1 = ISAIKJ(ISYBIJ,ISYMK) 5311 * + NCKI(ISYBIJ)*(K - 1) 5312 * + ISAIK(ISYMBI,ISYMJ) 5313 * + NT1AM(ISYMBI)*(J-1) 5314 * + IT1AM(ISYMB,ISYMI) 5315 * + NVIR(ISYMB)*(I-1) 5316 * + B 5317C 5318 SMAT(KOFF1) = ZERO 5319C 5320 ENDDO 5321 ENDDO 5322 ENDDO 5323 ENDDO 5324 ENDDO 5325 ENDIF 5326C 5327C---------------------------------------------------------- 5328C Remove all amplitudes that has three indentical 5329C occupied indices. 5330C---------------------------------------------------------- 5331C 5332 ISYMBD = MULD2H(ISYMB,ISYMD) 5333 ISYMAI = MULD2H(ISYMIM,ISYMBD) 5334 DO ISYMA = 1, NSYM 5335 ISYMI = MULD2H(ISYMA,ISYMAI) 5336 DO A = 1, NVIR(ISYMA) 5337 DO I = 1, NRHF(ISYMI) 5338 KOFF1 = ISAIKJ(ISYMA,ISYMI) 5339 * + NCKI(ISYMA)*(I - 1) 5340 * + ISAIK(ISYMAI,ISYMI) 5341 * + NT1AM(ISYMAI)*(I-1) 5342 * + IT1AM(ISYMA,ISYMI) 5343 * + NVIR(ISYMA)*(I-1) 5344 * + A 5345C 5346 SMAT(KOFF1) = ZERO 5347C 5348 ENDDO 5349 ENDDO 5350 ENDDO 5351C 5352C----------------------- 5353C End. 5354C----------------------- 5355C 5356 CALL QEXIT('T3_FORBIDDEN') 5357C 5358 RETURN 5359 END 5360C /* Deck den_aibsort */ 5361 SUBROUTINE DEN_AIBSORT(VIRREAL,VIRTMP,ISYVIR) 5362C 5363C Written by Kasper Hald, 2001. 5364C 5365C Purpose : Sort the two electron densities d(abi) -> d(aib) 5366C where the densities have a constant C. 5367C 5368 IMPLICIT NONE 5369C 5370#include "priunit.h" 5371#include "ccsdsym.h" 5372#include "ccorb.h" 5373C 5374 INTEGER ISYVIR, ISYMB, ISYMA, ISYMI, ISYMAI, ISYMBI 5375 INTEGER KOFF1, KOFF2, ISYMAB 5376C 5377#if defined (SYS_CRAY) 5378 REAL VIRREAL(*), VIRTMP(*) 5379#else 5380 DOUBLE PRECISION VIRREAL(*), VIRTMP(*), tmp 5381#endif 5382C 5383 CALL QENTER('DEN_AIBSORT') 5384C 5385C---------------------------------------- 5386C Sort matrix. 5387C---------------------------------------- 5388C 5389 DO ISYMB = 1, NSYM 5390 ISYMAI = MULD2H(ISYMB,ISYVIR) 5391 DO ISYMA = 1, NSYM 5392 ISYMAB = MULD2H(ISYMA,ISYMB) 5393 ISYMI = MULD2H(ISYMAI,ISYMA) 5394 DO B = 1, NVIR(ISYMB) 5395 DO A = 1, NVIR(ISYMA) 5396 DO I = 1, NRHF(ISYMI) 5397 KOFF1 = ICKASR(ISYMAB,ISYMI) 5398 * + NMATAB(ISYMAB)*(I-1) 5399 * + IMATAB(ISYMA,ISYMB) 5400 * + NVIR(ISYMA)*(B-1) 5401 * + 1 5402C 5403 KOFF2 = ICKATR(ISYMAI,ISYMB) 5404 * + NT1AM(ISYMAI)*(B-1) 5405 * + IT1AM(ISYMA,ISYMI) 5406 * + NVIR(ISYMA)*(I-1) 5407 * + 1 5408C 5409 CALL DCOPY(NVIR(ISYMA),VIRREAL(KOFF1),1, 5410 * VIRTMP(KOFF2),1) 5411C 5412 ENDDO 5413 ENDDO 5414 ENDDO 5415 ENDDO 5416 ENDDO 5417C 5418C------------------------------------ 5419C Copy back to original matrix 5420C------------------------------------ 5421C 5422 CALL DCOPY(NCKATR(ISYVIR),VIRTMP(1),1,VIRREAL(1),1) 5423C 5424C----------------------- 5425C End. 5426C----------------------- 5427C 5428 CALL QEXIT('DEN_AIBSORT') 5429C 5430 RETURN 5431 END 5432C /* Deck denpt */ 5433 SUBROUTINE DENSTORE(VIR1,LUVIR1,FNVIR1,VIR2,LUVIR2,FNVIR2,ISYRES) 5434C 5435C Written by K. Hald, Fall 2001. 5436C 5437C Purpose : Get the two different densities from file 5438C and sum them up with correct index. 5439C Store the total density on file. 5440C 5441 IMPLICIT NONE 5442C 5443#include "priunit.h" 5444#include "ccsdsym.h" 5445#include "ccorb.h" 5446C 5447 INTEGER LUVIR1, LUVIR2, ISYRES 5448 INTEGER ISYMD, ISYAIB, ISYMB, ISYMAI, ISYAID, KOFF1, KOFF2 5449C 5450#if defined (SYS_CRAY) 5451 DOUBLE PRECISION VIR1(*), VIR2(*), ONE 5452#else 5453 DOUBLE PRECISION VIR1(*), VIR2(*), ONE 5454#endif 5455C 5456 CHARACTER*(*) FNVIR1, FNVIR2 5457C 5458 PARAMETER (ONE = 1.0D0) 5459C 5460 CALL QENTER('DENSTORE') 5461C 5462 DO ISYMD = 1, NSYM 5463 ISYAIB = MULD2H(ISYMD,ISYRES) 5464 DO ISYMB = 1, NSYM 5465 ISYMAI = MULD2H(ISYAIB,ISYMB) 5466 ISYAID = MULD2H(ISYMAI,ISYMD) 5467 DO D = 1, NVIR(ISYMD) 5468 DO B = 1, NVIR(ISYMB) 5469C 5470 KOFF1 = ICKBD(ISYAIB,ISYMD) 5471 * + NCKATR(ISYAIB)*(D-1) 5472 * + ICKATR(ISYMAI,ISYMB) 5473 * + NT1AM(ISYMAI)*(B-1) 5474 * + 1 5475C 5476 CALL GETWA2(LUVIR2,FNVIR2,VIR2,KOFF1, 5477 * NT1AM(ISYMAI)) 5478C 5479 KOFF2 = ICKBD(ISYAID,ISYMB) 5480 * + NCKATR(ISYAID)*(B-1) 5481 * + ICKATR(ISYMAI,ISYMD) 5482 * + NT1AM(ISYMAI)*(D-1) 5483 * + 1 5484C 5485 CALL GETWA2(LUVIR1,FNVIR1,VIR1, 5486 * KOFF2,NT1AM(ISYMAI)) 5487C 5488 CALL DAXPY(NT1AM(ISYMAI),ONE,VIR2,1, 5489 * VIR1,1) 5490C 5491 CALL PUTWA2(LUVIR1,FNVIR1,VIR1, 5492 * KOFF2,NT1AM(ISYMAI)) 5493C 5494 ENDDO 5495 ENDDO 5496C 5497 ENDDO 5498 ENDDO 5499C 5500C----------------------- 5501C End. 5502C----------------------- 5503C 5504 CALL QEXIT('DENSTORE') 5505C 5506 RETURN 5507 END 5508C /* Deck ccfop_denocc */ 5509 SUBROUTINE CCFOP_DENOCC(OCC,SMAT,QMAT,TMAT,ISYMIM,T2AM,ISYMT2, 5510 * WORK,LWORK,INDSQ,LENSQ,ISYMB,B, 5511 * ISYMD,D,IOPT) 5512C 5513C Written by Kasper Hald, Fall 2001. 5514C 5515C Purpose : Calculate the contributions to the t3 and t3-bar 5516C densities d_{iajk} and d_{aijk} respectively. 5517C 5518 IMPLICIT NONE 5519C 5520#include "priunit.h" 5521#include "ccsdsym.h" 5522#include "ccorb.h" 5523C 5524 INTEGER ISYMIM, ISYMT2, LWORK,LENSQ, ISYMB, ISYMD, IOPT 5525 INTEGER INDSQ(LENSQ,6) 5526 INTEGER ISYMBD, ISELJI, ISYELK, ISYIJK, ISYMK, ISYMEL, ISYMIJ 5527 INTEGER NTOTEL, NTOTK, KOFF1, KOFF2, KOFF3, ISYML, ISYME 5528 INTEGER ISYMEK 5529C 5530#if defined (SYS_CRAY) 5531 REAL OCC(*), SMAT(*), QMAT(*), TMAT(*), T2AM(*) 5532 REAL WORK(LWORK), TWO, ONE, HALF 5533#else 5534 DOUBLE PRECISION OCC(*), SMAT(*), QMAT(*), TMAT(*), T2AM(*) 5535 DOUBLE PRECISION WORK(LWORK), TWO, ONE, HALF 5536#endif 5537C 5538 PARAMETER (ONE = 1.0D0, TWO = 2.0D0, HALF = 0.5D0) 5539C 5540 CALL QENTER('CCFOP_DENOCC') 5541C 5542C-------------------------------------- 5543C Symmetries and sanity check. 5544C-------------------------------------- 5545C 5546 IF (IOPT .NE. 1 .AND. IOPT .NE. 2) THEN 5547 CALL QUIT('Wrong IOPT in CCFOP_DENOCC') 5548 ENDIF 5549C 5550 ISYMBD = MULD2H(ISYMB,ISYMD) 5551 ISELJI = MULD2H(ISYMIM,ISYMBD) 5552 ISYELK = MULD2H(ISYMT2,ISYMD) 5553 ISYIJK = MULD2H(ISYELK,ISELJI) 5554C 5555 IF (LWORK .LT. NCKI(ISYELK)) THEN 5556 CALL QUIT('Not enough memory in CCFOP_DENOCC') 5557 ENDIF 5558C 5559C------------------------------------ 5560C Sort T2 to first term. 5561C------------------------------------ 5562C 5563C DO ISYMK = 1, NSYM 5564C ISYMEL = MULD2H(ISYELK,ISYMK) 5565C DO ISYML = 1, NSYM 5566C ISYME = MULD2H(ISYMEL,ISYML) 5567CC 5568C DO K = 1, NRHF(ISYMK) 5569C DO L = 1, NRHF(ISYML) 5570CC 5571C KOFF1 = IT2SP(ISYELK,ISYMD) 5572C * + NCKI(ISYELK)*(D - 1) 5573C * + ISAIK(ISYMEL,ISYMK) 5574C * + NT1AM(ISYMEL)*(K - 1) 5575C * + IT1AM(ISYME,ISYML) 5576C * + NVIR(ISYME)*(L-1) 5577C * + E 5578CC 5579C KOFF2 = ISAIK(ISYMEL,ISYMK) 5580C * + NT1AM(ISYMEL)*(K - 1) 5581C * + IT1AM(ISYME,ISYML) 5582C * + NVIR(ISYME)*(L-1) 5583C * + E 5584CC 5585C CALL DCOPY(NVIR(ISYME),T2AM(KOFF1),1,WORK(KOFF2),1) 5586CC 5587C ENDDO 5588C ENDDO 5589C ENDDO 5590C ENDDO 5591C 5592C-------------------------------------------- 5593C Contract with S and Q intermediates. 5594C-------------------------------------------- 5595C 5596 DO I = 1, NCKIJ(ISELJI) 5597C 5598 IF (IOPT .EQ. 1) THEN 5599 TMAT(I) = SMAT(INDSQ(I,5)) 5600 * - TWO*SMAT(I) 5601 * + SMAT(INDSQ(I,3)) 5602 * + QMAT(INDSQ(I,4)) 5603 * - TWO*QMAT(INDSQ(I,3)) 5604 * + QMAT(I) 5605 ELSE 5606 TMAT(I) = -HALF*SMAT(I) 5607 * -HALF*QMAT(INDSQ(I,3)) 5608 ENDIF 5609C 5610 ENDDO 5611C 5612 DO ISYMK = 1, NSYM 5613 ISYMEL = MULD2H(ISYELK,ISYMK) 5614 ISYMIJ = MULD2H(ISYIJK,ISYMK) 5615C 5616 NTOTEL = MAX(NT1AM(ISYMEL),1) 5617 NTOTK = MAX(NRHF(ISYMK),1) 5618C 5619 KOFF1 = IT2SP(ISYELK,ISYMD) 5620 * + NCKI(ISYELK)*(D-1) 5621 * + ISAIK(ISYMEL,ISYMK) + 1 5622 KOFF2 = ISAIKL(ISYMEL,ISYMIJ) + 1 5623 KOFF3 = I3OVIR(ISYIJK,ISYMB) 5624 * + NMAIJK(ISYIJK)*(B-1) 5625 * + IMAIJK(ISYMIJ,ISYMK) 5626 * + 1 5627! KOFF3 = I3OVIR(ISYIJK,ISYMB) 5628! * + NMAIJK(ISYIJK)*(B-1) 5629! * + Itestd(ISYMk,ISYMIJ) 5630! * + 1 5631C 5632 CALL DGEMM('T','N',NRHF(ISYMK),NMATIJ(ISYMIJ), 5633 * NT1AM(ISYMEL),TWO,T2AM(KOFF1),NTOTEL, 5634 * TMAT(KOFF2),NTOTEL,ONE,OCC(KOFF3), 5635 * NTOTK) 5636 ENDDO 5637C 5638C------------------------------------ 5639C Sort T2 to second term. 5640C------------------------------------ 5641C 5642 DO ISYMK = 1, NSYM 5643 ISYMEL = MULD2H(ISYELK,ISYMK) 5644 DO ISYML = 1, NSYM 5645 ISYME = MULD2H(ISYMEL,ISYML) 5646 ISYMEK = MULD2H(ISYME,ISYMK) 5647C 5648 DO K = 1, NRHF(ISYMK) 5649 DO L = 1, NRHF(ISYML) 5650C 5651 KOFF1 = IT2SP(ISYELK,ISYMD) 5652 * + NCKI(ISYELK)*(D - 1) 5653 * + ISAIK(ISYMEL,ISYMK) 5654 * + NT1AM(ISYMEL)*(K - 1) 5655 * + IT1AM(ISYME,ISYML) 5656 * + NVIR(ISYME)*(L-1) 5657 * + 1 5658C 5659 KOFF2 = ISAIK(ISYMEK,ISYML) 5660 * + NT1AM(ISYMEK)*(L - 1) 5661 * + IT1AM(ISYME,ISYMK) 5662 * + NVIR(ISYME)*(K-1) 5663 * + 1 5664C 5665 CALL DCOPY(NVIR(ISYME),T2AM(KOFF1),1,WORK(KOFF2),1) 5666C 5667 ENDDO 5668 ENDDO 5669 ENDDO 5670 ENDDO 5671C 5672C-------------------------------------------- 5673C Contract with S and Q intermediates. 5674C-------------------------------------------- 5675C 5676 DO I = 1, NCKIJ(ISELJI) 5677C 5678 IF (IOPT .EQ. 1) THEN 5679 TMAT(I) = SMAT(INDSQ(I,2)) 5680 * - TWO*SMAT(INDSQ(I,1)) 5681 * + SMAT(INDSQ(I,4)) 5682 * + QMAT(INDSQ(I,1)) 5683 * - TWO*QMAT(INDSQ(I,2)) 5684 * + QMAT(INDSQ(I,5)) 5685 ELSE 5686 TMAT(I) = -HALF*SMAT(INDSQ(I,1)) 5687 * -HALF*QMAT(INDSQ(I,2)) 5688 ENDIF 5689C 5690 ENDDO 5691C 5692 DO ISYMK = 1, NSYM 5693 ISYMEL = MULD2H(ISYELK,ISYMK) 5694 ISYMIJ = MULD2H(ISYIJK,ISYMK) 5695C 5696 NTOTEL = MAX(NT1AM(ISYMEL),1) 5697 NTOTK = MAX(NRHF(ISYMK),1) 5698C 5699 KOFF1 = ISAIK(ISYMEL,ISYMK) + 1 5700 KOFF2 = ISAIKL(ISYMEL,ISYMIJ) + 1 5701 KOFF3 = I3OVIR(ISYIJK,ISYMB) 5702 * + NMAIJK(ISYIJK)*(B-1) 5703 * + IMAIJK(ISYMIJ,ISYMK) 5704 * + 1 5705! KOFF3 = I3OVIR(ISYIJK,ISYMB) 5706! * + NMAIJK(ISYIJK)*(B-1) 5707! * + Itestd(ISYMK,ISYMIJ) 5708! * + 1 5709C 5710 CALL DGEMM('T','N',NRHF(ISYMK),NMATIJ(ISYMIJ), 5711 * NT1AM(ISYMEL),TWO,WORK(KOFF1),NTOTEL, 5712 * TMAT(KOFF2),NTOTEL,ONE,OCC(KOFF3), 5713 * NTOTK) 5714 ENDDO 5715C 5716C----------------------- 5717C End. 5718C----------------------- 5719C 5720 CALL QEXIT('CCFOP_DENOCC') 5721C 5722 RETURN 5723 END 5724C /* Deck ccfop_oned */ 5725 SUBROUTINE CCFOP_ONED(OMEGA1,T2AM,ISYMT2,SMAT,TMAT,ISYMIM,INDSQ, 5726 * LENSQ,WORK,LWORK,ISYMIB,IB,ISYMID,ID) 5727C 5728C Written by K. Hald, Fall 2001. 5729C 5730C Based on cc3_onel by 5731C Henrik Koch and Alfredo Sanchez. Dec 1994 5732C Ove Christiansen 9-1-1996: 5733C 5734C Calculate the contributions to Omega1 in CCSD(T) unrelaxed f.o.p. 5735C 5736C omega1(ai) = (t^{dea}_{lmi} - t^{dea}_{lim}) * (t^{* (0)}_{dl,em}) 5737C 5738C 5739 IMPLICIT NONE 5740C 5741#include "priunit.h" 5742#include "ccorb.h" 5743#include "ccsdinp.h" 5744#include "ccsdsym.h" 5745C 5746 INTEGER ISYMT2, ISYMIM, LENSQ, LWORK, ISYMIB, IB, ISYMID, ID 5747 INTEGER ISYRES, ISYMB, ISYMC, ISYMI, ISYAKJ, ISYMJ, ISYMBJ, ISYMAK 5748 INTEGER NBJ, NAK, NAKBJ, NAKJ, NTOTC, NTOAKJ, KOFF1, KOFF2 5749 INTEGER ISYMBC, JSAIKJ, LENGTH, ISYCKJ, ISYMAI, ISYMKJ, ISYMCK 5750 INTEGER NKJ, NCK, NCKBJ, NTOTAI, ISYMK, JSAKIJ 5751 INTEGER INDEX, INDSQ(LENSQ,6) 5752C 5753#if defined (SYS_CRAY) 5754 REAL OMEGA1(*), T2AM(*), SMAT(*), TMAT(*), WORK(LWORK) 5755 REAL ZERO, ONE, TWO 5756#else 5757 DOUBLE PRECISION OMEGA1(*), T2AM(*), SMAT(*), TMAT(*), WORK(LWORK) 5758 DOUBLE PRECISION ZERO, ONE, TWO 5759#endif 5760C 5761 PARAMETER (ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0) 5762C 5763C INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 5764C 5765 CALL QENTER('CCFOP_ONED') 5766C 5767 ISYRES = MULD2H(ISYMIM,ISYMT2) 5768C 5769 B = IB 5770 C = ID 5771C 5772 ISYMB = ISYMIB 5773 ISYMC = ISYMID 5774C 5775C----------------------------------- 5776C First SMAT / TMAT magic. 5777C----------------------------------- 5778C 5779 ISYMBC = MULD2H(ISYMB,ISYMC) 5780 JSAIKJ = MULD2H(ISYMBC,ISYMIM) 5781 LENGTH = NCKIJ(JSAIKJ) 5782C 5783 DO I = 1,LENGTH 5784C 5785 TMAT(I) = SMAT(INDSQ(I,3)) 5786 * - SMAT(INDSQ(I,4)) 5787C 5788 ENDDO 5789C 5790C---------------------------------- 5791C First contribution to Omega1. 5792C---------------------------------- 5793C 5794 ISYMI = MULD2H(ISYMC,ISYRES) 5795 ISYAKJ = MULD2H(ISYMB,ISYMT2) 5796C 5797 IF (NRHF(ISYMI) .NE. 0) THEN 5798C 5799 IF (LWORK .LT. NCKI(ISYAKJ)) THEN 5800 CALL QUIT('Not enough core in CCFOP_ONED') 5801 END IF 5802C 5803C Construct M(ak,j) = T(ak,bj) 5804C --------------------------- 5805C 5806 DO ISYMJ = 1,NSYM 5807C 5808 ISYMAK = MULD2H(ISYMJ,ISYAKJ) 5809C 5810 DO J = 1,NRHF(ISYMJ) 5811C 5812 NAKBJ = IT2SP(ISYAKJ,ISYMB) 5813 * + NCKI(ISYAKJ)*(B-1) 5814 * + ICKI(ISYMAK,ISYMJ) 5815 * + NT1AM(ISYMAK)*(J - 1) 5816 * + 1 5817C 5818 NAKJ = ICKI(ISYMAK,ISYMJ) 5819 * + NT1AM(ISYMAK)*(J - 1) 5820 * + 1 5821C 5822 CALL DCOPY(NT1AM(ISYMAK),T2AM(NAKBJ),1, 5823 * WORK(NAKJ),1) 5824C 5825 ENDDO 5826 ENDDO 5827C 5828 NTOTC = MAX(NVIR(ISYMC),1) 5829 NTOAKJ = MAX(NCKI(ISYAKJ),1) 5830C 5831 KOFF1 = ISAIKJ(ISYAKJ,ISYMI) + 1 5832 KOFF2 = IT1AM(ISYMC,ISYMI) + C 5833C 5834 CALL DGEMV('T',NCKI(ISYAKJ),NRHF(ISYMI),ONE,TMAT(KOFF1), 5835 * NTOAKJ,WORK,1,ONE,OMEGA1(KOFF2),NTOTC) 5836C 5837 ENDIF 5838C 5839C--------------------------------------- 5840C Second contribution to Omega1 5841C--------------------------------------- 5842C 5843 ISYMBC = MULD2H(ISYMB,ISYMC) 5844 JSAIKJ = MULD2H(ISYMBC,ISYMIM) 5845C 5846 LENGTH = NCKIJ(JSAIKJ) 5847C 5848 IF (LWORK .LT. LENGTH) THEN 5849 CALL QUIT('Not enough core in CCFOP_ONED') 5850 END IF 5851C 5852 DO I = 1,LENGTH 5853 TMAT(I) = SMAT(I) 5854 * - SMAT(INDSQ(I,5)) 5855 ENDDO 5856C 5857 IF (NSYM .GT. 1) THEN 5858 CALL CC_GATHER(LENGTH,WORK,TMAT,INDSQ(1,6)) 5859 CALL DCOPY(LENGTH,WORK,1,TMAT,1) 5860 ENDIF 5861C 5862 ISYMKJ = MULD2H(ISYMBC,ISYMT2) 5863 ISYMAI = ISYRES 5864C 5865C Construct M(k,j) = T(ck,bj) 5866C --------------------------- 5867C 5868 DO ISYMJ = 1,NSYM 5869C 5870 ISYMK = MULD2H(ISYMJ,ISYMKJ) 5871 ISYMCK = MULD2H(ISYMC,ISYMK) 5872 ISYCKJ = MULD2H(ISYMCK,ISYMJ) 5873C 5874 DO J = 1,NRHF(ISYMJ) 5875C 5876 NKJ = IMATIJ(ISYMK,ISYMJ) 5877 * + NRHF(ISYMK)*(J - 1) 5878 * + 1 5879C 5880 NCKBJ = IT2SP(ISYCKJ,ISYMB) 5881 * + NCKI(ISYCKJ)*(B-1) 5882 * + ICKI(ISYMCK,ISYMJ) 5883 * + NT1AM(ISYMCK)*(J-1) 5884 * + IT1AM(ISYMC,ISYMK) 5885 * + C 5886C 5887 CALL DCOPY(NRHF(ISYMK),T2AM(NCKBJ),NVIR(ISYMC),WORK(NKJ),1) 5888C 5889 ENDDO 5890 ENDDO 5891C 5892 NTOTAI = MAX(NT1AM(ISYMAI),1) 5893C 5894 KOFF1 = ISAIKL(ISYMAI,ISYMKJ) + 1 5895C 5896 CALL DGEMV('N',NT1AM(ISYMAI),NMATIJ(ISYMKJ),ONE,TMAT(KOFF1), 5897 * NTOTAI,WORK,1,ONE,OMEGA1,1) 5898C 5899C-------------------------------------------- 5900C Third contribution to omega1 5901C-------------------------------------------- 5902C 5903 ISYMBC = MULD2H(ISYMB,ISYMC) 5904 JSAKIJ = MULD2H(ISYMBC,ISYMIM) 5905C 5906 LENGTH = NCKIJ(JSAKIJ) 5907C 5908 IF (LWORK .LT. LENGTH) THEN 5909 CALL QUIT('Not enough core in CCFOP_ONED') 5910 END IF 5911C 5912 DO I = 1,LENGTH 5913 TMAT(I) = SMAT(I) 5914 * - SMAT(INDSQ(I,1)) 5915 ENDDO 5916C 5917C Symmetry sorting if symmetry 5918C ---------------------------- 5919C 5920 IF (NSYM .GT. 1) THEN 5921 CALL CC_GATHER(LENGTH,WORK,TMAT,INDSQ(1,6)) 5922 CALL DCOPY(LENGTH,WORK,1,TMAT,1) 5923 ENDIF 5924C 5925 ISYMKJ = MULD2H(ISYMBC,ISYMT2) 5926 ISYMAI = ISYRES 5927C 5928C Construct M(k,j) = T(ck,bj) 5929C --------------------------- 5930C 5931 DO ISYMJ = 1,NSYM 5932C 5933 ISYMK = MULD2H(ISYMJ,ISYMKJ) 5934 ISYMCK = MULD2H(ISYMC,ISYMK) 5935 ISYCKJ = MULD2H(ISYMCK,ISYMJ) 5936C 5937 DO J = 1,NRHF(ISYMJ) 5938C 5939 NKJ = IMATIJ(ISYMK,ISYMJ) 5940 * + NRHF(ISYMK)*(J - 1) 5941 * + 1 5942C 5943 NCKBJ = IT2SP(ISYCKJ,ISYMB) 5944 * + NCKI(ISYCKJ)*(B-1) 5945 * + ICKI(ISYMCK,ISYMJ) 5946 * + NT1AM(ISYMCK)*(J-1) 5947 * + IT1AM(ISYMC,ISYMK) 5948 * + C 5949C 5950 CALL DCOPY(NRHF(ISYMK),T2AM(NCKBJ),NVIR(ISYMC),WORK(NKJ),1) 5951C 5952 ENDDO 5953 ENDDO 5954C 5955 NTOTAI = MAX(NT1AM(ISYMAI),1) 5956C 5957 KOFF1 = ISAIKL(ISYMAI,ISYMKJ) + 1 5958C 5959 CALL DGEMV('N',NT1AM(ISYMAI),NMATIJ(ISYMKJ),ONE,TMAT(KOFF1), 5960 * NTOTAI,WORK,1,ONE,OMEGA1,1) 5961C 5962C---------------------------------------- 5963C End. 5964C---------------------------------------- 5965C 5966 CALL QEXIT('CCFOP_ONED') 5967C 5968C 5969 RETURN 5970 END 5971 SUBROUTINE CCPT_TEST(AOINT,ISYAO,CMO,MOINT,LOCAMO,ABINT,IJINT, 5972 * WORK,LWORK) 5973C 5974C Written by K. Hald, Fall 2001 5975C 5976C Purpose : Calculate ia block of MO integrals from corresponding AO, 5977C and transpose the matrix to (ai) from (ia) 5978C 5979 IMPLICIT NONE 5980C 5981#include "priunit.h" 5982#include "ccsdsym.h" 5983#include "ccorb.h" 5984C 5985 INTEGER LWORK, ISYAO 5986 INTEGER AL, BE 5987C 5988#if defined (SYS_CRAY) 5989 REAL AOINT(NBAST,NBAST), CMO(NBAST,NORBT) 5990 REAL MOINT(NVIRT,NRHFT) 5991 REAL LOCAMO(NRHFT,NVIRT) 5992 REAL ABINT(NVIRT,NVIRT) 5993 REAL IJINT(NRHFT,NRHFT) 5994 REAL WORK(LWORK), ZERO, ONE, RHO1N, DDOT 5995#else 5996 DOUBLE PRECISION AOINT(NBAST,NBAST), CMO(NBAST,NORBT) 5997 DOUBLE PRECISION MOINT(NVIRT,NRHFT) 5998 DOUBLE PRECISION LOCAMO(NRHFT,NVIRT) 5999 DOUBLE PRECISION ABINT(NVIRT,NVIRT) 6000 DOUBLE PRECISION IJINT(NRHFT,NRHFT) 6001 DOUBLE PRECISION WORK(LWORK), ZERO, ONE, RHO1N, DDOT 6002#endif 6003C 6004 PARAMETER (ZERO = 0.0D0, ONE = 1.0D0) 6005C 6006 CALL QENTER('CCPT_TEST') 6007C 6008 CALL DZERO(MOINT,NVIRT*NRHFT) 6009 CALL DZERO(LOCAMO,NVIRT*NRHFT) 6010 CALL DZERO(ABINT,NVIRT*NVIRT) 6011 CALL DZERO(IJINT,NRHFT*NRHFT) 6012C 6013C------------------------------------------- 6014C Print the integrals in the AO basis 6015C------------------------------------------- 6016C 6017 DO AL = 1, NBAST 6018 DO BE = 1, NBAST 6019 if (abs(aoint(al,be)) .gt. 1.0D-9) then 6020 write(lupri,*) 'X^[ao}_{ia}(',al,',',be,') = ', 6021 * aoint(al,be) 6022 endif 6023 enddo 6024 enddo 6025C 6026C--------------------------------------------------------- 6027C Transform the AO integrals to the MO basis (ia) 6028C The transformed vector is put in (ai) though 6029C it is the (ia) block we calculate. 6030C--------------------------------------------------------- 6031C 6032 DO AL = 1, NBAST 6033 DO BE = 1, NBAST 6034 DO A = 1, NVIRT 6035 DO I = 1, NRHFT 6036 locamo(i,a) = locamo(i,a) 6037 * + aoint(al,be)*CMO(al,i)*CMO(be,nrhft+a) 6038 ENDDO 6039 ENDDO 6040 ENDDO 6041 ENDDO 6042C 6043C------------------------------- 6044C Print integrals. 6045C------------------------------- 6046C 6047 DO AL = 1, NRHFT 6048 DO BE = 1, NVIRT 6049 if (abs(locamo(al,be)) .gt. 1.0D-9) then 6050 write(lupri,*) 'X^{mo}_{ia}(',al,',',be,') = ', 6051 * locamo(al,be) 6052 endif 6053 enddo 6054 enddo 6055C 6056C---------------------------- 6057C Transform integrals 6058C---------------------------- 6059C 6060 DO AL = 1, NRHFT 6061 DO BE = 1, NVIRT 6062 moint(be,al) = locamo(al,be) 6063 enddo 6064 enddo 6065C 6066C---------------------------------------------------- 6067C Transform the AO integrals to MO (ij block) 6068C---------------------------------------------------- 6069C 6070 DO AL = 1, NBAST 6071 DO BE = 1, NBAST 6072 DO I = 1, NRHFT 6073 DO J = 1, NRHFT 6074 ijint(i,j) = ijint(i,j) 6075 * + aoint(al,be)*CMO(al,i)*CMO(be,j) 6076 ENDDO 6077 ENDDO 6078 ENDDO 6079 ENDDO 6080C 6081C------------------------------- 6082C Print integrals. 6083C------------------------------- 6084C 6085 DO AL = 1, NRHFT 6086 DO BE = 1, NRHFT 6087 if (abs(ijint(al,be)) .gt. 1.0D-9) then 6088 write(lupri,*) 'X^{mo}_{ij}(',al,',',be,') = ', 6089 * ijint(al,be) 6090 endif 6091 enddo 6092 enddo 6093C 6094C---------------------------------------------------- 6095C Transform the AO integrals to MO (ab part) 6096C---------------------------------------------------- 6097C 6098 DO AL = 1, NBAST 6099 DO BE = 1, NBAST 6100 DO A = 1, NVIRT 6101 DO B = 1, NVIRT 6102 abint(a,b) = abint(a,b) 6103 * + aoint(al,be)*CMO(al,nrhft+a)*CMO(be,nrhft+b) 6104 ENDDO 6105 ENDDO 6106 ENDDO 6107 ENDDO 6108C 6109C------------------------------- 6110C Print integrals. 6111C------------------------------- 6112C 6113 DO AL = 1, NVIRT 6114 DO BE = 1, NVIRT 6115 if (abs(abint(al,be)) .gt. 1.0D-9) then 6116 write(lupri,*) 'X^{mo}_{ab}(',al,',',be,') = ', 6117 * abint(al,be) 6118 endif 6119 enddo 6120 enddo 6121C 6122C--------------- 6123C END 6124C--------------- 6125C 6126 CALL QEXIT('CCPT_TEST') 6127C 6128 RETURN 6129 END 6130C /* DECK SUM_PT3 */ 6131 SUBROUTINE SUM_PT3(SMAT,ISYMB,B,ISYMD,D,IAIKJ,T3SUM,IOPT) 6132C 6133C Sum up the T3 amplitudes from the S-MAT alone (IOPT = 1). 6134C Sum up the T3 amplitudes from the Q-MAT alone (IOPT = 2). 6135C Sum up the T3 amplitudes from the U-MAT alone (IOPT = 3). 6136C Sum up the T3 amplitudes from the W-MAT alone (IOPT = 4). 6137C Sum up the T3 amplitudes only with aibjck_perm (IOPT = 5). 6138C Sum up the T3 amplitudes only with aibjck_perm + bjaick_perm (IOPT = 6). 6139C 6140C HOWEVER : PLEASE DO NOT REMOVE THIS ROUTINE 6141C 6142C K. Hald, Fall 2001. 6143C 6144 IMPLICIT NONE 6145C 6146#include "priunit.h" 6147#include "ccsdsym.h" 6148#include "ccorb.h" 6149C 6150 INTEGER ISYMB, ISYMD, IAIKJ, IOPT 6151 INTEGER KOFF1, KOFF2, ISYMJ, ISYMK, ISYMA, ISYMI, ISYAIK, ISYMBJ 6152 INTEGER ISYMAI, ISYBJI, KOFF3, KOFF4, KOFF5, KOFF6, KOFF7, ISYAIJ 6153 INTEGER ISYMDJ, ISYMDK, ISYMBK, KH 6154C 6155#if defined (SYS_CRAY) 6156 REAL SMAT(*), FACT 6157 REAL t3sum(nvirt,nvirt,nvirt,nrhft,nrhft,nrhft), HALF 6158#else 6159 DOUBLE PRECISION SMAT(*), FACT 6160 DOUBLE PRECISION t3sum(nvirt,nvirt,nvirt,nrhft,nrhft,nrhft), HALF 6161#endif 6162C 6163 LOGICAL LDEBUG 6164C 6165 PARAMETER (HALF = 0.5D0) 6166 PARAMETER (LDEBUG = .FALSE.) 6167C 6168 CALL QENTER('SUM_PT3') 6169C 6170C 6171C 6172 IF (IOPT .EQ. 1) THEN 6173 FACT = HALF 6174 ELSE IF ((IOPT .EQ. 2) .OR. (IOPT .EQ. 3)) THEN 6175 FACT = 1.0D0 6176 ELSE IF (IOPT .EQ. 4) THEN 6177 FACT = HALF 6178 ELSE IF (IOPT .EQ. 5) THEN 6179 FACT = 1.0D0 6180 ELSE IF (IOPT .EQ. 6) THEN 6181 FACT = 1.0D0 6182 ELSE 6183 CALL QUIT('Wrong IOPT in sum_pt3') 6184 ENDIF 6185C 6186 KOFF2 = 0 6187 DO KH = 1, ISYMB-1 6188 KOFF2 = KOFF2 + NVIR(KH) 6189 ENDDO 6190 KOFF3 = 0 6191 DO KH = 1, ISYMD-1 6192 KOFF3 = KOFF3 + NVIR(KH) 6193 ENDDO 6194C 6195 DO ISYMJ = 1, NSYM 6196 KOFF5 = 0 6197 DO KH = 1, ISYMJ-1 6198 KOFF5 = KOFF5 + NRHF(KH) 6199 ENDDO 6200 ISYAIK = MULD2H(ISYMJ,IAIKJ) 6201 ISYMBJ = MULD2H(ISYMB,ISYMJ) 6202 ISYMDJ = MULD2H(ISYMD,ISYMJ) 6203 DO ISYMK = 1, NSYM 6204 KOFF6 = 0 6205 DO KH = 1, ISYMK-1 6206 KOFF6 = KOFF6 + NRHF(KH) 6207 ENDDO 6208 ISYMAI = MULD2H(ISYAIK,ISYMK) 6209 ISYAIJ = MULD2H(ISYMAI,ISYMJ) 6210 ISYMBK = MULD2H(ISYMB,ISYMK) 6211 ISYMDK = MULD2H(ISYMD,ISYMK) 6212 DO ISYMA = 1, NSYM 6213C 6214 KOFF1 = 0 6215 DO KH = 1, ISYMA-1 6216 KOFF1 = KOFF1 + NVIR(KH) 6217 ENDDO 6218C 6219 ISYMI = MULD2H(ISYMAI,ISYMA) 6220C 6221 KOFF4 = 0 6222 DO KH = 1, ISYMI-1 6223 KOFF4 = KOFF4 + NRHF(KH) 6224 ENDDO 6225 ISYBJI = MULD2H(ISYMBJ,ISYMI) 6226C 6227 DO I = 1, NRHF(ISYMI) 6228 DO J = 1, NRHF(ISYMJ) 6229 DO K = 1, NRHF(ISYMK) 6230 DO A = 1, NVIR(ISYMA) 6231C 6232 IF (IOPT .EQ. 1) THEN 6233 KOFF7 = ISAIKJ(ISYAIK,ISYMJ) 6234 * + NCKI(ISYAIK)*(J - 1) 6235 * + ISAIK(ISYMAI,ISYMK) + NT1AM(ISYMAI)*(K-1) 6236 * + IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I-1) + A 6237 ELSE IF (IOPT .EQ. 2) THEN 6238 KOFF7 = ISAIKJ(ISYAIJ,ISYMK) 6239 * + NCKI(ISYAIJ)*(K - 1) 6240 * + ISAIK(ISYMAI,ISYMJ) + NT1AM(ISYMAI)*(J-1) 6241 * + IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I-1) + A 6242 ELSE IF (IOPT .EQ. 3) THEN 6243 KOFF7 = ISAIKJ(ISYAIK,ISYMJ) 6244 * + NCKI(ISYAIK)*(J - 1) 6245 * + ISAIK(ISYMAI,ISYMK) + NT1AM(ISYMAI)*(K-1) 6246 * + IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I-1) + A 6247 ELSE IF (IOPT .EQ. 4) THEN 6248 KOFF7 = ISAIKJ(ISYAIK,ISYMJ) 6249 * + NCKI(ISYAIK)*(J - 1) 6250 * + ISAIK(ISYMAI,ISYMK) + NT1AM(ISYMAI)*(K-1) 6251 * + IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I-1) + A 6252 ELSE IF (IOPT .EQ. 5) THEN 6253 KOFF7 = ISAIKJ(ISYAIK,ISYMJ) 6254 * + NCKI(ISYAIK)*(J - 1) 6255 * + ISAIK(ISYMAI,ISYMK) + NT1AM(ISYMAI)*(K-1) 6256 * + IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I-1) + A 6257 ELSE IF (IOPT .EQ. 6) THEN 6258 KOFF7 = ISAIKJ(ISYAIK,ISYMJ) 6259 * + NCKI(ISYAIK)*(J - 1) 6260 * + ISAIK(ISYMAI,ISYMK) + NT1AM(ISYMAI)*(K-1) 6261 * + IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I-1) + A 6262 ENDIF 6263C 6264 IF (LDEBUG) THEN 6265 IF (ABS(SMAT(KOFF7)) .GT. 1.0d-12) THEN 6266 IF (IOPT .EQ. 1) THEN 6267 WRITE(LUPRI,*) 'CONTRIBUTION FROM I = ', 6268 * KOFF7,' WITH SMAT = ', 6269 * SMAT(KOFF7) 6270 ELSE IF (IOPT .EQ. 2) THEN 6271 WRITE(LUPRI,*) 'CONTRIBUTION FROM I = ', 6272 * KOFF7,' WITH QMAT = ', 6273 * SMAT(KOFF7) 6274 ELSE IF (IOPT .EQ. 3) THEN 6275 WRITE(LUPRI,*) 'CONTRIBUTION FROM I = ', 6276 * KOFF7,' WITH UMAT = ', 6277 * SMAT(KOFF7) 6278 ELSE IF (IOPT .EQ. 4) THEN 6279 WRITE(LUPRI,*) 'CONTRIBUTION FROM I = ', 6280 * KOFF7,' WITH WMAT = ', 6281 * SMAT(KOFF7) 6282 ELSE IF (IOPT .EQ. 5) THEN 6283 WRITE(LUPRI,*) 'CONTRIBUTION FROM I = ', 6284 * KOFF7,' WITH WMAT = ', 6285 * SMAT(KOFF7) 6286 ELSE IF (IOPT .EQ. 6) THEN 6287 WRITE(LUPRI,*) 'CONTRIBUTION FROM I = ', 6288 * KOFF7,' WITH WMAT = ', 6289 * SMAT(KOFF7) 6290 ENDIF 6291C 6292 WRITE(LUPRI,'(A,6I3)') ' A, B, D, I, J, K : ',A,B,D,I,J,K 6293 WRITE(LUPRI,*) 'KOFF1 = ',KOFF1,' KOFF2 = ', 6294 * KOFF2,'KOFF3 = ',KOFF3 6295 WRITE(LUPRI,*) 'KOFF4 = ',KOFF4,' KOFF5 = ', 6296 * KOFF5,'KOFF6 = ',KOFF6 6297 endif 6298 ENDIF 6299C 6300 T3SUM(A+KOFF1,B+KOFF2,D+KOFF3,I+KOFF4,J+KOFF5,K+KOFF6) = 6301 * T3SUM(A+KOFF1,B+KOFF2,D+KOFF3,I+KOFF4,J+KOFF5,K+KOFF6) + 6302 * FACT*SMAT(KOFF7) 6303C 6304 IF (IOPT .NE. 5) THEN 6305C 6306 T3SUM(B+KOFF2,A+KOFF1,D+KOFF3,J+KOFF5,I+KOFF4,K+KOFF6) = 6307 * T3SUM(B+KOFF2,A+KOFF1,D+KOFF3,J+KOFF5,I+KOFF4,K+KOFF6) + 6308 * FACT*SMAT(KOFF7) 6309C 6310 IF (IOPT .NE. 6) THEN 6311C 6312 T3SUM(A+KOFF1,D+KOFF3,B+KOFF2,I+KOFF4,K+KOFF6,J+KOFF5) = 6313 * T3SUM(A+KOFF1,D+KOFF3,B+KOFF2,I+KOFF4,K+KOFF6,J+KOFF5) + 6314 * FACT*SMAT(KOFF7) 6315C 6316 T3SUM(B+KOFF2,D+KOFF3,A+KOFF1,J+KOFF5,K+KOFF6,I+KOFF4) = 6317 * T3SUM(B+KOFF2,D+KOFF3,A+KOFF1,J+KOFF5,K+KOFF6,I+KOFF4) + 6318 * FACT*SMAT(KOFF7) 6319C 6320 T3SUM(D+KOFF3,A+KOFF1,B+KOFF2,K+KOFF6,I+KOFF4,J+KOFF5) = 6321 * T3SUM(D+KOFF3,A+KOFF1,B+KOFF2,K+KOFF6,I+KOFF4,J+KOFF5) + 6322 * FACT*SMAT(KOFF7) 6323C 6324 T3SUM(D+KOFF3,B+KOFF2,A+KOFF1,K+KOFF6,J+KOFF5,I+KOFF4) = 6325 * T3SUM(D+KOFF3,B+KOFF2,A+KOFF1,K+KOFF6,J+KOFF5,I+KOFF4) + 6326 * FACT*SMAT(KOFF7) 6327C 6328 END IF 6329 END IF 6330C 6331 ENDDO 6332 ENDDO 6333 ENDDO 6334 ENDDO 6335 ENDDO 6336C 6337 ENDDO 6338C 6339 ENDDO 6340C 6341 CALL QEXIT('SUM_PT3') 6342C 6343 1 FORMAT(1X,A8,I3,A1,I3,A1,I3,A1,I3,A1,I3,A1,I3,A4,E20.10) 6344 RETURN 6345 END 6346C /* DECK PRINT_PT3 */ 6347 SUBROUTINE PRINT_PT3(T3SUM,ISYMIM,IOPT) 6348C 6349C Remove the forbidden T3 amplitudes and print. 6350C 6351C HOWEVER : PLEASE DO NOT REMOVE THIS ROUTINE 6352C 6353C K. Hald, Fall 2001. 6354C 6355 IMPLICIT NONE 6356C 6357#include "priunit.h" 6358#include "ccsdsym.h" 6359#include "ccorb.h" 6360C 6361 INTEGER ISYMIM, IOPT, KOFF1, KOFF2, KOFF3, KOFF4, KOFF5, KOFF6 6362 INTEGER ISYMA, ISYMB, ISYMAB, IAIKJ, ISYMC, ISYMI, ISYMJ, ISYMK 6363 INTEGER KH, ISYABC, ISYIJK, ISYMJK, ISYMAI, ISYMBC 6364C 6365#if defined (SYS_CRAY) 6366 REAL t3sum(nvirt,nvirt,nvirt,nrhft,nrhft,nrhft), zero 6367#else 6368 DOUBLE PRECISION t3sum(nvirt,nvirt,nvirt,nrhft,nrhft,nrhft), zero 6369#endif 6370C 6371 LOGICAL LDEBUG 6372 PARAMETER ( LDEBUG = .FALSE. ) 6373C 6374 PARAMETER (ZERO = 0.0D0) 6375C 6376 CALL QENTER('PRINT_PT3') 6377C 6378C 6379C-------------------------------------------------------------- 6380C Remove forbidden elements of the triples amplitudes. 6381C-------------------------------------------------------------- 6382C 6383 DO ISYMA = 1, NSYM 6384 KOFF1 = 0 6385 DO KH = 1, ISYMA-1 6386 KOFF1 = KOFF1 + NVIR(KH) 6387 ENDDO 6388 DO ISYMI = 1, NSYM 6389 KOFF4 = 0 6390 DO KH = 1, ISYMI-1 6391 KOFF4 = KOFF4 + NRHF(KH) 6392 ENDDO 6393C 6394 ISYMAI = MULD2H(ISYMA,ISYMI) 6395 ISYMBC = MULD2H(ISYMAI,ISYMIM) 6396C 6397 DO ISYMB = 1, NSYM 6398 KOFF2 = 0 6399 DO KH = 1, ISYMB-1 6400 KOFF2 = KOFF2 + NVIR(KH) 6401 ENDDO 6402C 6403 ISYMC = MULD2H(ISYMBC,ISYMB) 6404 KOFF3 = 0 6405 DO KH = 1, ISYMC-1 6406 KOFF3 = KOFF3 + NVIR(KH) 6407 ENDDO 6408C 6409 DO A = 1, NVIR(ISYMA) 6410 DO I = 1, NRHF(ISYMI) 6411C 6412 DO B = 1, NVIR(ISYMB) 6413 DO C = 1, NVIR(ISYMC) 6414C 6415 T3SUM(A+KOFF1,B+KOFF2,C+KOFF3,I+KOFF4,I+KOFF4,I+KOFF4) = ZERO 6416 T3SUM(A+KOFF1,C+KOFF3,B+KOFF2,I+KOFF4,I+KOFF4,I+KOFF4) = ZERO 6417 T3SUM(B+KOFF2,A+KOFF1,C+KOFF3,I+KOFF4,I+KOFF4,I+KOFF4) = ZERO 6418 T3SUM(B+KOFF2,C+KOFF3,A+KOFF1,I+KOFF4,I+KOFF4,I+KOFF4) = ZERO 6419 T3SUM(C+KOFF3,A+KOFF1,B+KOFF2,I+KOFF4,I+KOFF4,I+KOFF4) = ZERO 6420 T3SUM(C+KOFF3,B+KOFF2,A+KOFF1,I+KOFF4,I+KOFF4,I+KOFF4) = ZERO 6421C 6422 ENDDO ! C 6423 ENDDO ! B 6424 ENDDO ! I 6425 ENDDO ! A 6426 ENDDO ! ISYMB 6427C 6428 DO ISYMJ = 1, NSYM 6429 KOFF5 = 0 6430 DO KH = 1, ISYMJ-1 6431 KOFF5 = KOFF5 + NRHF(KH) 6432 ENDDO 6433C 6434 ISYMK = MULD2H(ISYMBC,ISYMJ) 6435 KOFF6 = 0 6436 DO KH = 1, ISYMK-1 6437 KOFF6 = KOFF6 + NRHF(KH) 6438 ENDDO 6439C 6440 DO A = 1,NVIR(ISYMA) 6441 DO I = 1,NRHF(ISYMI) 6442 DO J = 1,NRHF(ISYMJ) 6443 DO K = 1,NRHF(ISYMK) 6444C 6445 T3SUM(A+KOFF1,A+KOFF1,A+KOFF1,I+KOFF4,J+KOFF5,K+KOFF6) = ZERO 6446 T3SUM(A+KOFF1,A+KOFF1,A+KOFF1,I+KOFF4,K+KOFF6,J+KOFF5) = ZERO 6447 T3SUM(A+KOFF1,A+KOFF1,A+KOFF1,J+KOFF5,I+KOFF4,K+KOFF6) = ZERO 6448 T3SUM(A+KOFF1,A+KOFF1,A+KOFF1,J+KOFF5,K+KOFF6,I+KOFF4) = ZERO 6449 T3SUM(A+KOFF1,A+KOFF1,A+KOFF1,K+KOFF6,I+KOFF4,J+KOFF5) = ZERO 6450 T3SUM(A+KOFF1,A+KOFF1,A+KOFF1,K+KOFF6,J+KOFF5,I+KOFF4) = ZERO 6451C 6452 ENDDO ! K 6453 ENDDO ! J 6454 ENDDO ! I 6455 ENDDO ! A 6456 ENDDO 6457 ENDDO ! ISYMI 6458 ENDDO ! ISYMA 6459C 6460C---------------------------------------- 6461C Print the triples amplitudes. 6462C---------------------------------------- 6463C 6464 DO ISYMA = 1, NSYM 6465C 6466 KOFF1 = 0 6467 DO KH = 1, ISYMA-1 6468 KOFF1 = KOFF1 + NVIR(KH) 6469 ENDDO 6470C 6471 DO ISYMB = 1, NSYM 6472C 6473 ISYMAB = MULD2H(ISYMA,ISYMB) 6474C 6475 KOFF2 = 0 6476 DO KH = 1, ISYMB-1 6477 KOFF2 = KOFF2 + NVIR(KH) 6478 ENDDO 6479C 6480 DO ISYMC = 1, NSYM 6481C 6482 ISYABC = MULD2H(ISYMAB,ISYMC) 6483 ISYIJK = MULD2H(ISYMIM,ISYABC) 6484C 6485 KOFF3 = 0 6486 DO KH = 1, ISYMC-1 6487 KOFF3 = KOFF3 + NVIR(KH) 6488 ENDDO 6489C 6490 DO ISYMI = 1, NSYM 6491C 6492 KOFF4 = 0 6493 DO KH = 1, ISYMI-1 6494 KOFF4 = KOFF4 + NRHF(KH) 6495 ENDDO 6496C 6497 ISYMJK = MULD2H(ISYIJK,ISYMI) 6498C 6499 DO ISYMJ = 1, NSYM 6500C 6501 KOFF5 = 0 6502 DO KH = 1, ISYMJ-1 6503 KOFF5 = KOFF5 + NRHF(KH) 6504 ENDDO 6505C 6506 ISYMK = MULD2H(ISYMJK,ISYMJ) 6507C 6508 KOFF6 = 0 6509 DO KH = 1, ISYMK-1 6510 KOFF6 = KOFF6 + NRHF(KH) 6511 ENDDO 6512C 6513 DO A = 1, NVIR(ISYMA) 6514 DO B = 1, NVIR(ISYMB) 6515 DO C = 1, NVIR(ISYMC) 6516 DO I = 1, NRHF(ISYMI) 6517 DO J = 1, NRHF(ISYMJ) 6518 DO K = 1, NRHF(ISYMK) 6519C 6520 IF (ABS(T3SUM(A+KOFF1,B+KOFF2,C+KOFF3,I+KOFF4,J+KOFF5,K+KOFF6)) 6521 * .GT. 1.0D-12) THEN 6522 IF (IOPT .EQ. 1) THEN 6523 write(lupri,1) 'T3AM(',a+koff1,',',b+koff2,',', 6524 * c+koff3,',',i+koff4,',', 6525 * j+koff5,',',k+koff6,') = ', 6526 * T3SUM(A+KOFF1,B+KOFF2,C+KOFF3,I+KOFF4,J+KOFF5,K+KOFF6) 6527C 6528 ELSE IF (IOPT .EQ. 2) THEN 6529 write(lupri,1) 'T3-BAR(',a+koff1,',',b+koff2,',', 6530 * c+koff3,',',i+koff4,',', 6531 * j+koff5,',',k+koff6,') = ', 6532 * T3SUM(A+KOFF1,B+KOFF2,C+KOFF3,I+KOFF4,J+KOFF5,K+KOFF6) 6533C 6534 ELSE IF (IOPT .EQ. 3) THEN 6535 write(lupri,1) 'L3AM(',a+koff1,',',b+koff2,',', 6536 * c+koff3,',',i+koff4,',', 6537 * j+koff5,',',k+koff6,') = ', 6538 * T3SUM(A+KOFF1,B+KOFF2,C+KOFF3,I+KOFF4,J+KOFF5,K+KOFF6) 6539C 6540 ELSE IF (IOPT .EQ. 4) THEN 6541 write(lupri,1) 'WMAT(',a+koff1,',',b+koff2,',', 6542 * c+koff3,',',i+koff4,',', 6543 * j+koff5,',',k+koff6,') = ', 6544 * T3SUM(A+KOFF1,B+KOFF2,C+KOFF3,I+KOFF4,J+KOFF5,K+KOFF6) 6545 ELSE IF (IOPT .EQ. 5) THEN 6546 write(lupri,1) 'WBDD(',a+koff1,',',b+koff2,',', 6547 * c+koff3,',',i+koff4,',', 6548 * j+koff5,',',k+koff6,') = ', 6549 * T3SUM(A+KOFF1,B+KOFF2,C+KOFF3,I+KOFF4,J+KOFF5,K+KOFF6) 6550C 6551 ELSE 6552 CALL QUIT('Wrong IOPT in PRINT_PT3') 6553 ENDIF 6554 ENDIF 6555C 6556 ENDDO ! K 6557 ENDDO ! J 6558 ENDDO ! I 6559 ENDDO ! C 6560 ENDDO ! B 6561 ENDDO ! A 6562 ENDDO ! ISYMJ 6563 ENDDO ! ISYMI 6564 ENDDO ! ISYMC 6565 ENDDO ! ISYMB 6566C 6567 ENDDO ! ISYMA 6568C 6569 CALL QEXIT('PRINT_PT3') 6570C 6571 1 FORMAT(1X,A6,I3,A1,I3,A1,I3,A1,I3,A1,I3,A1,I3,A4,E20.10) 6572 RETURN 6573 END 6574C /* deck dens1to2 */ 6575 SUBROUTINE DENS1TO2(DENS1,DENS2,ISYRES) 6576C 6577C Written by K. Hald, Fall 2001 6578C 6579C Purpose : Calculate the contributions to the 2 electron 6580C density which is identical to the 1 electron 6581C density with a delta function. 6582C 6583 IMPLICIT NONE 6584C 6585#include "priunit.h" 6586#include "ccsdsym.h" 6587#include "ccorb.h" 6588C 6589 INTEGER ISYRES, ISYMA, ISYMI, ISYMJ, ISYMIJ, ISYMJJ, KOFF1 6590 INTEGER KOFF2 6591C 6592#if defined (SYS_CRAY) 6593 REAL DENS1(*), DENS2(*), TWO 6594#else 6595 DOUBLE PRECISION DENS1(*), DENS2(*), TWO 6596#endif 6597C 6598 PARAMETER (TWO = 2.0D0) 6599C 6600 CALL QENTER('DENS1TO2') 6601C 6602C-------------------------- 6603C First contribution 6604C-------------------------- 6605C 6606 DO ISYMA = 1, NSYM 6607 ISYMI = MULD2H(ISYMA,ISYRES) 6608 DO ISYMJ = 1, NSYM 6609 ISYMIJ = MULD2H(ISYMI,ISYMJ) 6610 ISYMJJ = MULD2H(ISYMJ,ISYMJ) ! Now that is a tricky one 6611 DO A = 1, NVIR(ISYMA) 6612 DO I = 1, NRHF(ISYMI) 6613 DO J = 1, NRHF(ISYMJ) 6614 KOFF1 = I3OVIR(ISYMI,ISYMA) 6615 * + NMAIJK(ISYMI)*(A-1) 6616 * + IMAIJK(ISYMJJ,ISYMI) 6617 * + NMATIJ(ISYMJJ)*(I-1) 6618 * + IMATIJ(ISYMJ,ISYMJ) 6619 * + NRHF(ISYMJ)*(J-1) 6620 * + J 6621C 6622 KOFF2 = IT1AM(ISYMA,ISYMI) 6623 * + NVIR(ISYMA)*(I-1) 6624 * + A 6625C 6626 DENS2(KOFF1) = DENS2(KOFF1) - TWO*DENS1(KOFF2) 6627C 6628 ENDDO 6629 ENDDO 6630 ENDDO 6631 ENDDO 6632 ENDDO 6633C 6634C-------------------------- 6635C Second contribution 6636C-------------------------- 6637C 6638 DO ISYMA = 1, NSYM 6639 ISYMI = MULD2H(ISYMA,ISYRES) 6640 DO ISYMJ = 1, NSYM 6641 ISYMIJ = MULD2H(ISYMI,ISYMJ) 6642 ISYMJJ = MULD2H(ISYMJ,ISYMJ) ! Now that is a tricky one 6643 DO A = 1, NVIR(ISYMA) 6644 DO I = 1, NRHF(ISYMI) 6645 DO J = 1, NRHF(ISYMJ) 6646 KOFF1 = I3OVIR(ISYMI,ISYMA) 6647 * + NMAIJK(ISYMI)*(A-1) 6648 * + IMAIJK(ISYMIJ,ISYMJ) 6649 * + NMATIJ(ISYMIJ)*(J-1) 6650 * + IMATIJ(ISYMJ,ISYMI) 6651 * + NRHF(ISYMJ)*(I-1) 6652 * + J 6653C 6654 KOFF2 = IT1AM(ISYMA,ISYMI) 6655 * + NVIR(ISYMA)*(I-1) 6656 * + A 6657C 6658 DENS2(KOFF1) = DENS2(KOFF1) + DENS1(KOFF2) 6659C 6660 ENDDO 6661 ENDDO 6662 ENDDO 6663 ENDDO 6664 ENDDO 6665C 6666C-------------------------- 6667C End. 6668C-------------------------- 6669C 6670 CALL QEXIT('DENS1TO2') 6671C 6672 RETURN 6673 END 6674C /* Deck cc3_umat */ 6675 SUBROUTINE CC3_UMAT(ECURR,T2TP,ISYMT2,TRVIR,TROCC,ISYINT,FOCKD, 6676 * DIAG,UMAT,TMAT,WORK,LWORK,INDSQ,LENSQ, 6677 * ISYMB,B,ISYMD,D) 6678C 6679C Written by K. Hald, Fall 2001. 6680C 6681C Purpose : Calculate the U-intermediate which is used in the 6682C multiplication of T3 with T3-BAR. 6683C 6684C U^{bd}(ck,i,j) = t2(bi,cl) (dj|lk) - t2(bi,dk) (dj|cd) 6685C 6686 IMPLICIT NONE 6687C 6688#include "priunit.h" 6689#include "ccsdsym.h" 6690#include "ccorb.h" 6691#include "ccsdinp.h" 6692C 6693 INTEGER ISYMT2, ISYINT, LWORK, LENSQ, ISYMB, ISYMD 6694 INTEGER INDSQ(LENSQ,6) 6695 INTEGER ISYRES, ISYMBD, ISCIKJ, ISYCJF, ISYFIK, LENGTH 6696 INTEGER ISYMF, ISYMCJ, ISYMIK, ISYMC, ISYMJ, ISYMFJ, ISYCIK 6697 INTEGER KOFF1, KOFF2, KOFF3, NVIRF, NTOTCJ, ISYCIL, ISYLKJ 6698 INTEGER ISYMIL, ISYMI, ISYML, ISYMLK, ISYMK, ISYMFK, ISYCJK 6699 INTEGER NTOTCI, NRHFL, NB, ND, ISYMCI, ISYMCL, ISYCIJ, NTOTIK 6700 INTEGER ISYMJL, ISYBJL, ISCIKL, ISYMBJ, NTOCIK 6701C 6702#if defined (SYS_CRAY) 6703 REAL T2TP(*), TRVIR(*), TROCC(*), FOCKD(*), DIAG(*) 6704 REAL UMAT(*), TMAT(*), WORK(LWORK), EPSIBD, XUMAT 6705 DOUBLE PRECISION DDOT, ZERO, ONE,ECURR 6706#else 6707 DOUBLE PRECISION T2TP(*), TRVIR(*), TROCC(*), FOCKD(*), DIAG(*) 6708 DOUBLE PRECISION UMAT(*), TMAT(*), WORK(LWORK), EPSIBD, XUMAT 6709 DOUBLE PRECISION DDOT, ZERO, ONE,ECURR 6710#endif 6711 LOGICAL LDEBUG 6712C 6713 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0) 6714 PARAMETER(LDEBUG = .FALSE.) 6715C 6716 CALL QENTER('CC3_UMAT') 6717C 6718C 6719C------------------------ 6720C Symmetries : 6721C------------------------ 6722C 6723 ISYRES = MULD2H(ISYMT2,ISYINT) 6724 ISYMBD = MULD2H(ISYMB,ISYMD) 6725 ISCIKJ = MULD2H(ISYMBD,ISYRES) 6726 ISYCJF = MULD2H(ISYMD,ISYINT) 6727 ISYFIK = MULD2H(ISYMB,ISYMT2) 6728C 6729C-------------------------- 6730C Virtual contribution. 6731C-------------------------- 6732C 6733 LENGTH = NCKIJ(ISCIKJ) 6734C 6735 IF (LWORK .LT. LENGTH) THEN 6736 CALL QUIT('Insufficient memory in CC3_UMAT') 6737 ENDIF 6738C 6739C-------------------- 6740C Sort the T2. 6741C-------------------- 6742C 6743 DO ISYMF = 1, NSYM 6744 ISYMIK = MULD2H(ISYMF,ISYFIK) 6745 DO ISYMI = 1, NSYM 6746 ISYMK = MULD2H(ISYMIK,ISYMI) 6747 ISYMFK = MULD2H(ISYMK,ISYMF) 6748 DO F = 1, NVIR(ISYMF) 6749 DO I = 1, NRHF(ISYMI) 6750 DO K = 1, NRHF(ISYMK) 6751C 6752 KOFF1 = IT2SP(ISYFIK,ISYMB) 6753 * + NCKI(ISYFIK)*(B-1) 6754 * + ISAIK(ISYMFK,ISYMI) 6755 * + NT1AM(ISYMFK)*(I-1) 6756 * + IT1AM(ISYMF,ISYMK) 6757 * + NVIR(ISYMF)*(K-1) 6758 * + F 6759 KOFF2 = IMAIJA(ISYMIK,ISYMF) 6760 * + NMATIJ(ISYMIK)*(F-1) 6761 * + IMATIJ(ISYMI,ISYMK) 6762 * + NRHF(ISYMI)*(K-1) 6763 * + I 6764C 6765 WORK(KOFF2) = T2TP(KOFF1) 6766C 6767 ENDDO 6768 ENDDO 6769 ENDDO 6770 ENDDO 6771 ENDDO 6772C 6773 DO ISYMF = 1, NSYM 6774 ISYMCJ = MULD2H(ISYMF,ISYCJF) 6775 ISYMIK = MULD2H(ISYFIK,ISYMF) 6776C 6777 KOFF1 = ICKATR(ISYMCJ,ISYMF) 6778 * + 1 6779 KOFF2 = IMAIJA(ISYMIK,ISYMF) 6780 * + 1 6781 KOFF3 = ISAIKL(ISYMCJ,ISYMIK) 6782 * + 1 6783C 6784 NVIRF = MAX(NVIR(ISYMF),1) 6785 NTOTCJ = MAX(NT1AM(ISYMCJ),1) 6786 NTOTIK = MAX(NMATIJ(ISYMIK),1) 6787C 6788 CALL DGEMM('N','T',NT1AM(ISYMCJ),NMATIJ(ISYMIK), 6789 * NVIR(ISYMF),ONE,TRVIR(KOFF1),NTOTCJ, 6790 * WORK(KOFF2),NTOTIK,ZERO, 6791 * TMAT(KOFF3),NTOTCJ) 6792C 6793 ENDDO 6794C 6795C-------------------------------------------- 6796C Sort if symmetry and add to umat. 6797C-------------------------------------------- 6798C 6799 IF (NSYM .GT. 1) THEN 6800 CALL CCSDPT_SYMSORT(TMAT,ISCIKJ,WORK(1),LWORK) 6801 ENDIF 6802C 6803 DO I = 1, LENGTH 6804 UMAT(I) = TMAT(INDSQ(I,3)) 6805 ENDDO 6806C 6807 IF ((IPRINT .GT. 55) .OR. LDEBUG) THEN 6808 XUMAT = DDOT(LENGTH,UMAT,1,UMAT,1) 6809 WRITE(LUPRI,*) 'In CC3_UMAT: 1. Norm of UMAT ',XUMAT 6810 ENDIF 6811C 6812C--------------------------- 6813C Occupied contribution. 6814C--------------------------- 6815C 6816 ISYMJL = MULD2H(ISYMBD,ISYMT2) 6817 ISYBJL = MULD2H(ISYMJL,ISYMB) 6818 ISCIKL = ISYINT 6819C 6820C------------------------- 6821C Sort T2 6822C------------------------- 6823C 6824 IF (LWORK .LT. NCKI(ISYBJL)) 6825 * CALL QUIT('Not enough memory in CC3_UMAT') 6826C 6827 DO ISYMJ = 1, NSYM 6828 ISYML = MULD2H(ISYMJL,ISYMJ) 6829 ISYMBJ = MULD2H(ISYMJ,ISYMB) 6830C 6831 DO J = 1, NRHF(ISYMJ) 6832C 6833 KOFF1 = IT2SP(ISYBJL,ISYMD) 6834 * + NCKI(ISYBJL)*(D - 1) 6835 * + ISAIK(ISYMBJ,ISYML) 6836 * + IT1AM(ISYMB,ISYMJ) 6837 * + NVIR(ISYMB)*(J-1) 6838 * + B 6839 KOFF2 = IMATIJ(ISYML,ISYMJ) 6840 * + NRHF(ISYML)*(J-1) 6841 * + 1 6842C 6843 CALL DCOPY(NRHF(ISYML),T2TP(KOFF1),NT1AM(ISYMBJ), 6844 * WORK(KOFF2),1) 6845 ENDDO 6846 ENDDO 6847C 6848 DO ISYML = 1,NSYM 6849C 6850 ISYMJ = MULD2H(ISYMJL,ISYML) 6851 ISYCIK = MULD2H(ISCIKL,ISYML) 6852C 6853 NTOCIK = MAX(NCKI(ISYCIK),1) 6854 NRHFL = MAX(NRHF(ISYML),1) 6855C 6856 KOFF1 = ISAIKJ(ISYCIK,ISYML) 6857 * + 1 6858 KOFF2 = IMATIJ(ISYML,ISYMJ) 6859 * + 1 6860 KOFF3 = ISAIKJ(ISYCIK,ISYMJ) 6861 * + 1 6862C 6863 CALL DGEMM('N','N',NCKI(ISYCIK),NRHF(ISYMJ),NRHF(ISYML), 6864 * -ONE,TROCC(KOFF1),NTOCIK,WORK(KOFF2),NRHFL, 6865 * ZERO,TMAT(KOFF3),NTOCIK) 6866C 6867 ENDDO 6868C 6869 DO I = 1, LENGTH 6870 UMAT(I) = UMAT(I) + TMAT(INDSQ(I,1)) 6871 ENDDO 6872C 6873 IF ((IPRINT .GT. 55) .OR. LDEBUG) THEN 6874 XUMAT = DDOT(LENGTH,UMAT,1,UMAT,1) 6875 WRITE(LUPRI,*) 'In CC3_UMAT: 2. Norm of UMAT ',XUMAT 6876 ENDIF 6877C 6878C----------------------------------------- 6879C Divide by the Fock matrix diagonals. 6880C----------------------------------------- 6881C 6882 NB = IORB(ISYMB) + NRHF(ISYMB) + B 6883 ND = IORB(ISYMD) + NRHF(ISYMD) + D 6884C 6885 EPSIBD = FOCKD(NB) + FOCKD(ND) - ECURR 6886C 6887 DO L = 1,LENGTH 6888C 6889 UMAT(L) = UMAT(L)/(DIAG(L) + EPSIBD) 6890C 6891 ENDDO 6892C 6893 IF ((IPRINT .GT. 55) .OR. LDEBUG) THEN 6894 XUMAT = DDOT(LENGTH,UMAT,1,UMAT,1) 6895 WRITE(LUPRI,*) 'In CC3_UMAT: 3. Norm of UMAT ',XUMAT 6896 ENDIF 6897C 6898C-------------------------- 6899C End. 6900C-------------------------- 6901C 6902 CALL QEXIT('CC3_UMAT') 6903C 6904 RETURN 6905 END 6906C /* Deck ccfop_umat */ 6907 SUBROUTINE CCFOP_UMAT(ECURR,T1AM,ISYMT1,T2TCME,ISYMT2,XIAJB, 6908 * ISINT1,FOCK,TRVIR,TRVIR7,TROCC,TROCC2, 6909 * ISYINT,FOCKD,DIAG, 6910 * UMAT,TMAT,WORK,LWORK,INDSQ,LENSQ, 6911 * ISYMB,B,ISYMD,D) 6912C 6913C Written by K. Hald, Fall 2001. 6914C 6915C Purpose : Calculate the U-intermediate which is used in the 6916C multiplication of T3-BAR with T3. 6917C 6918C U^{bd}(ck,i,j) = t2(bi,cl) (dj|lk) - t2(bi,dk) (dj|cd) 6919C 6920 IMPLICIT NONE 6921C 6922#include "priunit.h" 6923#include "ccsdsym.h" 6924#include "ccorb.h" 6925#include "ccsdinp.h" 6926C 6927 INTEGER ISYMT1, ISYMT2, ISINT1, ISYINT, LWORK, LENSQ, ISYMB, ISYMD 6928 INTEGER INDSQ(LENSQ,6), INDEX 6929 INTEGER ISYRES, ISYMBD, ISCIKJ, ISYCJF, ISYFIK, LENGTH 6930 INTEGER ISYMF, ISYMCJ, ISYMIK, ISYMC, ISYMJ, ISYMFJ, ISYCIK 6931 INTEGER KOFF1, KOFF2, KOFF3, NVIRF, NTOTCJ, ISYCIL, ISYLKJ 6932 INTEGER ISYMIL, ISYMI, ISYML, ISYMLK, ISYMK, ISYMFK, ISYCJK 6933 INTEGER NTOTCI, NRHFL, NB, ND, ISYMCI, ISYMCL, ISYCIJ, NTOTIK 6934 INTEGER ISYAIK, ISYMAI, ISYMBK, NBK, NAI, NAIK, NAIBK, NDJ, NAIKJ 6935 INTEGER ISYBKJ, ISYMKJ, NBKDJ, NAIKJTEMP, NAISUM, ISYMA 6936 INTEGER ISYBIL, ISYMBI, ISYAJK, ISYMJK, NTOAJK, ISYAFK, ISYFIJ 6937 INTEGER ISYMAK, ISYMIJ, NTOTAK, ISYRES2, ISYMFI, NTOTIJ 6938C 6939#if defined (SYS_CRAY) 6940 REAL T1AM(*), T2TCME(*), XIAJB(*), TRVIR(*), TRVIR7(*) 6941 REAL TROCC(*), TROCC2(*), FOCK(*), FOCKD(*), DIAG(*) 6942 REAL UMAT(*), TMAT(*), WORK(LWORK), EPSIBD, XUMAT, ECURR 6943 REAL DDOT, ZERO, ONE, TWO 6944#else 6945 DOUBLE PRECISION T1AM(*), T2TCME(*), XIAJB(*), TRVIR(*), TRVIR7(*) 6946 DOUBLE PRECISION TROCC(*), TROCC2(*), FOCK(*), FOCKD(*), DIAG(*) 6947 DOUBLE PRECISION UMAT(*), TMAT(*), WORK(LWORK), EPSIBD, XUMAT 6948 DOUBLE PRECISION DDOT, ZERO, ONE, TWO, ECURR 6949#endif 6950C 6951 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0) 6952C 6953 INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 6954C 6955 CALL QENTER('CCFOP_UMAT') 6956C 6957C------------------------ 6958C Symmetries : 6959C------------------------ 6960C 6961 ISYRES = MULD2H(ISYMT2,ISYINT) 6962 ISYRES2 = MULD2H(ISYMT1,ISINT1) 6963C 6964 IF (ISYRES .NE. ISYRES2) 6965 * CALL QUIT('Symmetry mismatch in CCFOP_UMAT') 6966C 6967 ISYMBD = MULD2H(ISYMB,ISYMD) 6968 ISCIKJ = MULD2H(ISYMBD,ISYRES) 6969C 6970 LENGTH = NCKIJ(ISCIKJ) 6971C 6972C------------------------------------------ 6973C Contribution from the two T1 terms. 6974C------------------------------------------ 6975C 6976 if (.true.) then 6977C 6978 ISYAIK = MULD2H(ISINT1,ISYMB) 6979C 6980C------------------------------------ 6981C Sort integrals for constant B 6982C------------------------------------ 6983C 6984 IF (LWORK .LT. NCKI(ISYAIK)) THEN 6985 CALL QUIT('Too little workspace in CCFOP_UMAT (1)') 6986 ENDIF 6987C 6988 DO ISYMK = 1, NSYM 6989 ISYMAI = MULD2H(ISYAIK,ISYMK) 6990 ISYMBK = MULD2H(ISYMB,ISYMK) 6991 DO K = 1, NRHF(ISYMK) 6992 NBK = IT1AM(ISYMB,ISYMK) + NVIR(ISYMB)*(K - 1) + B 6993 DO NAI = 1, NT1AM(ISYMAI) 6994C 6995 NAIK = ICKI(ISYMAI,ISYMK)+NT1AM(ISYMAI)*(K - 1)+NAI 6996 NAIBK = IT2AM(ISYMAI,ISYMBK) + INDEX(NAI,NBK) 6997C 6998 WORK(NAIK) = XIAJB(NAIBK) 6999C 7000 ENDDO 7001 ENDDO 7002 ENDDO 7003C 7004C---------------------------------- 7005C Contract integrals with T1. 7006C---------------------------------- 7007C 7008 CALL DZERO(TMAT,LENGTH) 7009C 7010 ISYMJ = MULD2H(ISYMT1,ISYMD) 7011C 7012 DO ISYMK = 1, NSYM 7013 ISYMAI = MULD2H(ISYAIK,ISYMK) 7014 ISYMBK = MULD2H(ISYMB,ISYMK) 7015C 7016 DO K = 1, NRHF(ISYMK) 7017 NBK = IT1AM(ISYMB,ISYMK) + NVIR(ISYMB)*(K - 1) + B 7018 DO J = 1, NRHF(ISYMJ) 7019C 7020 NDJ = IT1AM(ISYMD,ISYMJ) + NVIR(ISYMD)*(J - 1) + D 7021C 7022 DO NAI = 1, NT1AM(ISYMAI) 7023C 7024 NAIKJ = ISAIKJ(ISYAIK,ISYMJ) 7025 * + NCKI(ISYAIK)*(J - 1) 7026 * + ICKI(ISYMAI,ISYMK) 7027 * + NT1AM(ISYMAI)*(K-1) + NAI 7028C 7029 NAIK = ICKI(ISYMAI,ISYMK)+ NT1AM(ISYMAI)*(K - 1)+ NAI 7030C 7031 TMAT(NAIKJ) = TWO*T1AM(NDJ)*WORK(NAIK) 7032C 7033 ENDDO 7034 ENDDO 7035 ENDDO 7036 ENDDO 7037C 7038C-------------------------------------- 7039C Sum the result into UMAT. 7040C-------------------------------------- 7041C 7042 DO I = 1, LENGTH 7043C First : 7044 UMAT(I) = UMAT(I) + TMAT(INDSQ(I,3)) 7045CCCCCC UMAT(I) = UMAT(I) + TMAT(INDSQ(I,4)) 7046C Second : 7047 UMAT(I) = UMAT(I) - TMAT(INDSQ(I,2)) 7048CCCCCC UMAT(I) = UMAT(I) - TMAT(I) 7049 ENDDO 7050C 7051 IF (IPRINT .GT. 55) THEN 7052 XUMAT = DDOT(LENGTH,UMAT,1,UMAT,1) 7053 WRITE(LUPRI,*) 'In CCFOP_UMAT: 1. Norm of UMAT ',XUMAT 7054 ENDIF 7055C 7056 endif 7057C 7058C----------------------------------------------------------------------- 7059C Contribution from both Fock terms 7060C----------------------------------------------------------------------- 7061C 7062 if (.true.) then 7063C 7064 CALL DZERO(TMAT,LENGTH) 7065C 7066 ISYBKJ = MULD2H(ISYMT2,ISYMD) 7067 ISYMKJ = MULD2H(ISYBKJ,ISYMB) 7068 ISYMAI = ISYINT 7069C 7070 DO ISYMJ = 1, NSYM 7071 ISYMK = MULD2H(ISYMKJ,ISYMJ) 7072 ISYMBK = MULD2H(ISYMB,ISYMK) 7073 ISYAIK = MULD2H(ISYMAI,ISYMK) 7074C 7075 DO ISYMI = 1, NSYM 7076C 7077 ISYMA = MULD2H(ISYMAI,ISYMI) 7078C 7079 DO J = 1, NRHF(ISYMJ) 7080 NDJ = IT1AM(ISYMD,ISYMJ) + NVIR(ISYMD)*(J-1) + D 7081C 7082 DO K = 1, NRHF(ISYMK) 7083C 7084 NBKDJ = IT2SP(ISYBKJ,ISYMD) 7085 * + NCKI(ISYBKJ)*(D - 1) 7086 * + ICKI(ISYMBK,ISYMJ) 7087 * + NT1AM(ISYMBK)*(J - 1) 7088 * + IT1AM(ISYMB,ISYMK) 7089 * + NVIR(ISYMB)*(K-1) 7090 * + B 7091C 7092 NAIKJTEMP = ISAIKJ(ISYAIK,ISYMJ) 7093 * + NCKI(ISYAIK)*(J - 1) 7094 * + ICKI(ISYMAI,ISYMK) 7095 * + NT1AM(ISYMAI)*(K-1) 7096 * + IT1AM(ISYMA,ISYMI) 7097C 7098 DO A = 1, NVIR(ISYMA) 7099 DO I = 1, NRHF(ISYMI) 7100C 7101 NAIKJ = NAIKJTEMP 7102 * + NVIR(ISYMA)*(I-1) 7103 * + A 7104 NAI = IT1AM(ISYMA,ISYMI) 7105 * + NVIR(ISYMA)*(I-1) 7106 * + A 7107C 7108 TMAT(NAIKJ) = TWO*T2TCME(NBKDJ)*FOCK(NAI) 7109C 7110 ENDDO 7111 ENDDO 7112 ENDDO 7113 ENDDO 7114 ENDDO 7115 ENDDO 7116C 7117C------------------------------------ 7118C Sum the result into SMAT. 7119C------------------------------------ 7120C 7121 DO I = 1, LENGTH 7122 ! First term 7123 UMAT(I) = UMAT(I) + TMAT(INDSQ(I,3)) 7124 ! Second term 7125 UMAT(I) = UMAT(I) - TMAT(INDSQ(I,4)) 7126 ENDDO 7127C 7128 IF (IPRINT .GT. 55) THEN 7129 XUMAT = DDOT(LENGTH,UMAT,1,UMAT,1) 7130 WRITE(LUPRI,*) 'In CCFOP_UMAT: 2. Norm of UMAT ',XUMAT 7131 ENDIF 7132C 7133 endif 7134C 7135C---------------------------------------------- 7136C Virtual contribution of L term. 7137C---------------------------------------------- 7138C 7139 ISYAFK = MULD2H(ISYMD,ISYINT) 7140 ISYFIJ = MULD2H(ISYMB,ISYMT2) 7141C 7142 DO ISYMF = 1, NSYM 7143 ISYMIJ = MULD2H(ISYMF,ISYFIJ) 7144 DO ISYMI = 1, NSYM 7145 ISYMFI= MULD2H(ISYMF,ISYMI) 7146 ISYMJ = MULD2H(ISYMIJ,ISYMI) 7147C 7148 DO F = 1, NVIR(ISYMF) 7149 DO J = 1, NRHF(ISYMJ) 7150C 7151 KOFF1 = IT2SP(ISYFIJ,ISYMB) 7152 * + NCKI(ISYFIJ)*(B-1) 7153 * + ICKI(ISYMFI,ISYMJ) 7154 * + NT1AM(ISYMFI)*(J-1) 7155 * + IT1AM(ISYMF,ISYMI) 7156 * + F 7157 KOFF2 = IMAIJA(ISYMIJ,ISYMF) 7158 * + NMATIJ(ISYMIJ)*(F-1) 7159 * + IMATIJ(ISYMI,ISYMJ) 7160 * + NRHF(ISYMI)*(J-1) 7161 * + 1 7162C 7163 CALL DCOPY(NRHF(ISYMI),T2TCME(KOFF1),NVIR(ISYMF), 7164 * WORK(KOFF2),1) 7165C 7166 ENDDO 7167 ENDDO 7168C 7169 ENDDO 7170 ENDDO 7171C 7172 if (.true.) then 7173C 7174 DO ISYMF = 1,NSYM 7175C 7176 ISYMAK = MULD2H(ISYMF,ISYAFK) 7177 ISYMIJ = MULD2H(ISYMF,ISYFIJ) 7178C 7179 KOFF1 = ICKATR(ISYMAK,ISYMF) 7180 * + 1 7181C 7182 KOFF2 = IMAIJA(ISYMIJ,ISYMF) 7183 * + 1 7184 KOFF3 = ISAIKL(ISYMAK,ISYMIJ) + 1 7185C 7186 NTOTAK = MAX(1,NT1AM(ISYMAK)) 7187 NTOTIJ = MAX(1,NMATIJ(ISYMIJ)) 7188C 7189 CALL DGEMM('N','T',NT1AM(ISYMAK),NMATIJ(ISYMIJ), 7190 * NVIR(ISYMF),TWO,TRVIR7(KOFF1),NTOTAK, 7191 * WORK(KOFF2),NTOTIJ,ZERO, 7192 * TMAT(KOFF3),NTOTAK) 7193C 7194 ENDDO 7195C 7196 IF (NSYM .GT. 1) THEN 7197C Do not destroy the sorted T2! 7198 KOFF1 = NCKI(ISYFIJ) + 1 7199 CALL CCSDPT_SYMSORT(TMAT,ISCIKJ,WORK(KOFF1),LWORK) 7200 ENDIF 7201C 7202 DO I = 1,LENGTH 7203 UMAT(I) = UMAT(I) + TMAT(I) 7204 ENDDO 7205C 7206 IF (IPRINT .GT. 55) THEN 7207 XUMAT = DDOT(LENGTH,UMAT,1,UMAT,1) 7208 WRITE(LUPRI,*) 'In CCFOP_UMAT: 3. Norm of UMAT ',XUMAT 7209 ENDIF 7210C 7211 endif 7212C 7213C---------------------------------------------- 7214C Virtual contribution of g term. 7215C---------------------------------------------- 7216C 7217 ISYAFK = MULD2H(ISYMD,ISYINT) 7218 ISYFIJ = MULD2H(ISYMB,ISYMT2) 7219C 7220 if (.true.) then 7221C 7222 DO ISYMF = 1,NSYM 7223C 7224 ISYMAK = MULD2H(ISYMF,ISYAFK) 7225 ISYMIJ = MULD2H(ISYMF,ISYFIJ) 7226C 7227 KOFF1 = ICKATR(ISYMAK,ISYMF) 7228 * + 1 7229 KOFF2 = IMAIJA(ISYMIJ,ISYMF) 7230 * + 1 7231 KOFF3 = ISAIKL(ISYMAK,ISYMIJ) + 1 7232C 7233 NTOTAK = MAX(1,NT1AM(ISYMAK)) 7234 NTOTIJ = MAX(1,NMATIJ(ISYMIJ)) 7235C 7236 CALL DGEMM('N','T',NT1AM(ISYMAK),NMATIJ(ISYMIJ), 7237 * NVIR(ISYMF),TWO,TRVIR(KOFF1),NTOTAK, 7238 * WORK(KOFF2),NTOTIJ,ZERO, 7239 * TMAT(KOFF3),NTOTAK) 7240C 7241 ENDDO 7242C 7243 IF (NSYM .GT. 1) THEN 7244 CALL CCSDPT_SYMSORT(TMAT,ISCIKJ,WORK(1),LWORK) 7245 ENDIF 7246C 7247 DO I = 1,LENGTH 7248 UMAT(I) = UMAT(I) - TMAT(INDSQ(I,5)) 7249 ENDDO 7250C 7251 IF (IPRINT .GT. 55) THEN 7252 XUMAT = DDOT(LENGTH,UMAT,1,UMAT,1) 7253 WRITE(LUPRI,*) 'In CCFOP_UMAT: 4. Norm of UMAT ',XUMAT 7254 ENDIF 7255C 7256 endif 7257C 7258C---------------------------------------- 7259C Occupied L contribution. 7260C---------------------------------------- 7261C 7262 ISYBIL = MULD2H(ISYMD,ISYMT2) 7263 ISYMIL = MULD2H(ISYMB,ISYBIL) 7264C 7265C Sort the T2 amplitudes for given B and D 7266C 7267 DO ISYML = 1, NSYM 7268 ISYMI = MULD2H(ISYMIL,ISYML) 7269 ISYMBI = MULD2H(ISYMI,ISYMB) 7270C 7271 DO I = 1, NRHF(ISYMI) 7272 KOFF1 = IT2SP(ISYBIL,ISYMD) 7273 * + NCKI(ISYBIL)*(D - 1) 7274 * + ICKI(ISYMBI,ISYML) 7275 * + IT1AM(ISYMB,ISYMI) 7276 * + NVIR(ISYMB)*(I-1) 7277 * + B 7278 KOFF2 = IMATIJ(ISYML,ISYMI) 7279 * + NRHF(ISYML)*(I-1) 7280 * + 1 7281C 7282 CALL DCOPY(NRHF(ISYML),T2TCME(KOFF1),NT1AM(ISYMBI), 7283 * WORK(KOFF2),1) 7284 ENDDO 7285 ENDDO 7286C 7287 if (.true.) then 7288C 7289 DO ISYML = 1,NSYM 7290C 7291 ISYMI = MULD2H(ISYML,ISYMIL) 7292 ISYAJK = MULD2H(ISYML,ISYINT) 7293C 7294 KOFF1 = ISAIKJ(ISYAJK,ISYML) 7295 * + 1 7296 KOFF2 = IMATIJ(ISYML,ISYMI) 7297 * + 1 7298 KOFF3 = ISAIKJ(ISYAJK,ISYMI) 7299 * + 1 7300C 7301 NTOAJK = MAX(1,NCKI(ISYAJK)) 7302 NRHFL = MAX(1,NRHF(ISYML)) 7303C 7304 CALL DGEMM('N','N',NCKI(ISYAJK),NRHF(ISYMI), 7305 * NRHF(ISYML),-TWO,TROCC2(KOFF1),NTOAJK, 7306 * WORK(KOFF2),NRHFL,ZERO,TMAT(KOFF3), 7307 * NTOAJK) 7308C 7309 ENDDO 7310C 7311 DO I = 1, NCKIJ(ISCIKJ) 7312 UMAT(I) = UMAT(I) + TMAT(INDSQ(I,1)) 7313 ENDDO 7314C 7315 IF (IPRINT .GT. 55) THEN 7316 XUMAT = DDOT(LENGTH,UMAT,1,UMAT,1) 7317 WRITE(LUPRI,*) 'In CCFOP_UMAT: 5. Norm of UMAT ',XUMAT 7318 ENDIF 7319C 7320 endif 7321C------------------------------------------ 7322C Occupied g contribution ... use the 7323C sorted T2 from occ. L term. 7324C------------------------------------------ 7325C 7326 ISYBIL = MULD2H(ISYMD,ISYMT2) 7327 ISYMIL = MULD2H(ISYMB,ISYBIL) 7328C 7329 if (.true.) then 7330C 7331 DO ISYML = 1,NSYM 7332C 7333 ISYMI = MULD2H(ISYML,ISYMIL) 7334 ISYAJK = MULD2H(ISYML,ISYINT) 7335C 7336 KOFF1 = ISAIKJ(ISYAJK,ISYML) 7337 * + 1 7338 KOFF2 = IMATIJ(ISYML,ISYMI) 7339 * + 1 7340 KOFF3 = ISAIKJ(ISYAJK,ISYMI) 7341 * + 1 7342C 7343 NTOAJK = MAX(1,NCKI(ISYAJK)) 7344 NRHFL = MAX(1,NRHF(ISYML)) 7345C 7346 CALL DGEMM('N','N',NCKI(ISYAJK),NRHF(ISYMI), 7347 * NRHF(ISYML),-TWO,TROCC(KOFF1),NTOAJK, 7348 * WORK(KOFF2),NRHFL,ZERO,TMAT(KOFF3), 7349 * NTOAJK) 7350C 7351 ENDDO 7352C 7353 DO I = 1, LENGTH 7354 UMAT(I) = UMAT(I) - TMAT(INDSQ(I,2)) 7355 ENDDO 7356C 7357 IF (IPRINT .GT. 55) THEN 7358 XUMAT = DDOT(LENGTH,UMAT,1,UMAT,1) 7359 WRITE(LUPRI,*) 'In CCFOP_UMAT: 6. Norm of UMAT ',XUMAT 7360 ENDIF 7361C 7362 endif 7363C----------------------------------------- 7364C Divide by the Fock matrix diagonals. 7365C----------------------------------------- 7366C 7367 NB = IORB(ISYMB) + NRHF(ISYMB) + B 7368 ND = IORB(ISYMD) + NRHF(ISYMD) + D 7369C 7370 EPSIBD = FOCKD(NB) + FOCKD(ND) - ECURR 7371C 7372 DO L = 1,LENGTH 7373C 7374 UMAT(L) = UMAT(L)/(DIAG(L) + EPSIBD) 7375C 7376 ENDDO 7377C 7378 IF (IPRINT .GT. 55) THEN 7379 XUMAT = DDOT(LENGTH,UMAT,1,UMAT,1) 7380 WRITE(LUPRI,*) 'In CCFOP_UMAT: 7. Norm of UMAT ',XUMAT 7381 ENDIF 7382C 7383C-------------------------- 7384C End. 7385C-------------------------- 7386C 7387 CALL QEXIT('CCFOP_UMAT') 7388C 7389 RETURN 7390 END 7391C /* Deck ccfop_sort */ 7392 SUBROUTINE CCFOP_SORT(INT1,INT2,ISYINT,IOPT) 7393C 7394C Written by K. Hald, Fall 2001. 7395C 7396C Sort INT1 and place it in INT2. 7397C IOPT = 1 : Sort FROM ljka TO akjl 7398C IOPT = 2 : Sort FROM akjl TO ljka 7399C 7400 IMPLICIT NONE 7401C 7402#include "priunit.h" 7403#include "ccsdsym.h" 7404#include "ccorb.h" 7405C 7406 INTEGER ISYINT, IOPT, KOFF1, KOFF2 7407 INTEGER ISYMA, ISYLJK, ISYMK, ISYMLJ, ISYMAK, ISYMJ 7408 INTEGER ISYML, ISYAKJ 7409 INTEGER ISYMAL, ISYALJ 7410C 7411#if defined (SYS_CRAY) 7412 REAL INT1(*), INT2(*) 7413#else 7414 DOUBLE PRECISION INT1(*), INT2(*) 7415#endif 7416C 7417 CALL QENTER('CCFOP_SORT') 7418C 7419C-------------------------- 7420C Sort. 7421C-------------------------- 7422C 7423 DO ISYMA = 1, NSYM 7424 ISYLJK = MULD2H(ISYINT,ISYMA) 7425 DO ISYMK = 1, NSYM 7426 ISYMLJ = MULD2H(ISYLJK,ISYMK) 7427 ISYMAK = MULD2H(ISYMA,ISYMK) 7428 DO ISYMJ = 1, NSYM 7429 ISYML = MULD2H(ISYMLJ,ISYMJ) 7430 ISYMAL = MULD2H(ISYMA,ISYML) 7431 ISYAKJ = MULD2H(ISYMAK,ISYMJ) 7432 ISYALJ = MULD2H(ISYMAL,ISYMJ) 7433C 7434 DO A = 1, NVIR(ISYMA) 7435 DO K = 1, NRHF(ISYMK) 7436 DO J = 1, NRHF(ISYMJ) 7437C 7438 KOFF1 = ISJIKA(ISYLJK,ISYMA) 7439 * + NMAJIK(ISYLJK)*(A-1) 7440 * + ISJIK(ISYMLJ,ISYMK) 7441 * + NMATIJ(ISYMLJ)*(K - 1) 7442 * + IMATIJ(ISYML,ISYMJ) 7443 * + NRHF(ISYML)*(J - 1) 7444 * + 1 7445C 7446 KOFF2 = ISAIKJ(ISYAKJ,ISYML) 7447 * + ICKI(ISYMAK,ISYMJ) 7448 * + NT1AM(ISYMAK)*(J-1) 7449 * + IT1AM(ISYMA,ISYMK) 7450 * + NVIR(ISYMA)*(K-1) 7451 * + A 7452C 7453 IF (IOPT .EQ. 1) THEN 7454 CALL DCOPY(NRHF(ISYML),INT1(KOFF1),1, 7455 * INT2(KOFF2),NCKI(ISYAKJ)) 7456 ELSE IF (IOPT .EQ. 2) THEN 7457 CALL DCOPY(NRHF(ISYML),INT1(KOFF2),NCKI(ISYAKJ), 7458 * INT2(KOFF1),1) 7459 ELSE 7460 CALL QUIT('Wrong IOPT in CCFOP_SORT') 7461 ENDIF 7462C 7463 ENDDO 7464 ENDDO 7465 ENDDO 7466C 7467 ENDDO 7468 ENDDO 7469 ENDDO 7470C 7471C-------------------------- 7472C End. 7473C-------------------------- 7474C 7475 CALL QEXIT('CCFOP_SORT') 7476C 7477 RETURN 7478 END 7479C /* Deck ccsdt_kappadiag */ 7480 SUBROUTINE CCSDT_KAPPADIAG(KAPAA,KAPII,SMATBAR,SMAT,SMAT3, 7481 * UMATBAR,UMAT,UMAT3,TMAT,INDSQ, 7482 * LENSQ,ISSMAT,WORK,LWORK) 7483C 7484C Written by K. Hald, Fall 2001. 7485C 7486 IMPLICIT NONE 7487C 7488#include "priunit.h" 7489#include "ccsdsym.h" 7490#include "ccorb.h" 7491C 7492 INTEGER LENSQ, ISSMAT, LWORK 7493 INTEGER INDSQ(LENSQ,6) 7494 INTEGER KTMAT, KEND1, LWRK1 7495 INTEGER LENGTH, ISYMK, ISYAJL, ISYML, ISYMAJ, ISYMA, ISYMJ, KOFF1 7496 INTEGER KOFF2, KOFF3, KHCOUNT 7497C 7498#if defined (SYS_CRAY) 7499 REAL KAPAA(*), KAPII(*), SMATBAR(*), SMAT(*) 7500 REAL SMAT3(*), UMATBAR(*), UMAT(*), UMAT3(*) 7501 REAL TMAT(*), DDOT, WORK(LWORK) 7502#else 7503 DOUBLE PRECISION KAPAA(*), KAPII(*), SMATBAR(*), SMAT(*) 7504 DOUBLE PRECISION SMAT3(*), UMATBAR(*), UMAT(*), UMAT3(*) 7505 DOUBLE PRECISION TMAT(*), DDOT, WORK(LWORK) 7506#endif 7507C 7508 LOGICAL LDEBUG 7509 PARAMETER(LDEBUG = .FALSE.) 7510C 7511 CALL QENTER('CCSDT_KAPPADIAG') 7512C 7513C 7514 LENGTH = NCKIJ(ISSMAT) 7515C 7516 KTMAT = 1 7517 KEND1 = KTMAT + LENGTH 7518 LWRK1 = LWORK - KEND1 7519C 7520 IF (LWRK1 .LT. 0 ) THEN 7521 CALL QUIT('Out of memory in CCSDT_KAPPADIAG') 7522 ENDIF 7523C 7524 DO I = 1, LENGTH 7525 TMAT(I) = 7526 * SMAT(I) 7527 * + UMAT(I) 7528 * + SMAT3(INDSQ(I,3)) 7529 * + UMAT3(INDSQ(I,3)) 7530 ENDDO 7531C 7532C-------------------------------------------------------- 7533C Calculate kappa_{aa} and kappa_{ii} from smatbar 7534C-------------------------------------------------------- 7535C 7536 DO I = 1, LENGTH 7537 WORK(KTMAT-1+I) = 7538 * + SMATBAR(I) 7539 * + UMATBAR(I) 7540 ENDDO 7541C 7542 DO ISYMK = 1, NSYM 7543 ISYAJL = MULD2H(ISSMAT,ISYMK) 7544 DO ISYML = 1, NSYM 7545 ISYMAJ = MULD2H(ISYML,ISYAJL) 7546 DO ISYMJ = 1, NSYM 7547 ISYMA = MULD2H(ISYMJ,ISYMAJ) 7548C Do not use ivir(isyma) since this appears to 7549C be broken. IRHF seems to be fine, but .... 7550 KOFF2 = 0 7551 DO KHCOUNT = 1, ISYMA-1 7552 KOFF2 = KOFF2 + NVIR(KHCOUNT) 7553 ENDDO 7554 KOFF3 = 0 7555 DO KHCOUNT = 1, ISYMJ-1 7556 KOFF3 = KOFF3 + NRHF(KHCOUNT) 7557 ENDDO 7558 DO A = 1, NVIR(ISYMA) 7559 DO K = 1, NRHF(ISYMK) 7560 DO L = 1, NRHF(ISYML) 7561 DO J = 1, NRHF(ISYMJ) 7562C 7563 KOFF1 = ISAIKJ(ISYAJL,ISYMK) 7564 * + NCKI(ISYAJL)*(K-1) 7565 * + ICKI(ISYMAJ,ISYML) 7566 * + NT1AM(ISYMAJ)*(L-1) 7567 * + IT1AM(ISYMA,ISYMJ) 7568 * + NVIR(ISYMA)*(J-1) 7569 * + A 7570C 7571 KAPAA(KOFF2+A) = KAPAA(KOFF2+A) 7572 * + WORK(KTMAT+KOFF1-1)*TMAT(KOFF1) 7573 KAPII(KOFF3+J) = KAPII(KOFF3+J) 7574 * - WORK(KTMAT+KOFF1-1)*TMAT(KOFF1) 7575C 7576 ENDDO 7577 ENDDO 7578 ENDDO 7579 ENDDO 7580 ENDDO 7581 ENDDO 7582 ENDDO 7583C 7584 IF (LDEBUG) THEN 7585 DO A = 1, NVIRT 7586 IF (ABS(KAPAA(A)) .GT. 1.0D-20) THEN 7587 WRITE(LUPRI,*) 'KAPAA(',A,') = ',KAPAA(A) 7588 ENDIF 7589 ENDDO 7590 DO J = 1, NRHFT 7591 IF (ABS(KAPII(J)) .GT. 1.0D-20) THEN 7592 WRITE(LUPRI,*) 'KAPII(',j,') = ',KAPII(J) 7593 ENDIF 7594 ENDDO 7595 ENDIF 7596C 7597C-------------------------- 7598C End. 7599C-------------------------- 7600C 7601 CALL QEXIT('CCSDT_KAPPADIAG') 7602C 7603 RETURN 7604 END 7605C /* Deck ccsdpt_symsort */ 7606 SUBROUTINE CCSDPT_SYMSORT(UMAT,ISSMAT,WORK,LWORK) 7607C 7608C Written by K. Hald, Fall 2001. 7609C 7610 IMPLICIT NONE 7611C 7612#include "priunit.h" 7613#include "ccsdsym.h" 7614#include "ccorb.h" 7615C 7616 INTEGER ISSMAT, LWORK 7617 INTEGER ISYMK, ISYAIJ, ISYMJ, ISYMAI, ISYMJK, NJK 7618 INTEGER KOFF1, KOFF2 7619C 7620#if defined (SYS_CRAY) 7621 REAL UMAT(*), WORK(LWRK) 7622#else 7623 DOUBLE PRECISION UMAT(*), WORK(LWORK) 7624#endif 7625C 7626 CALL QENTER('CCSDPT_SYMSORT') 7627C 7628 IF (LWORK .LT. NCKIJ(ISSMAT)) THEN 7629 CALL QUIT('Exceeded workspace in CCSDPT_SYMSORT') 7630 ENDIF 7631C 7632 CALL DCOPY(NCKIJ(ISSMAT),UMAT,1,WORK,1) 7633C 7634C--------------------- 7635C Sort. 7636C--------------------- 7637C 7638 DO ISYMK = 1, NSYM 7639 ISYAIJ = MULD2H(ISSMAT,ISYMK) 7640 DO ISYMJ = 1, NSYM 7641 ISYMAI = MULD2H(ISYAIJ,ISYMJ) 7642 ISYMJK = MULD2H(ISYMJ,ISYMK) 7643 DO K = 1, NRHF(ISYMK) 7644 DO J = 1, NRHF(ISYMJ) 7645C 7646 NJK = IMATIJ(ISYMJ,ISYMK) 7647 * + NRHF(ISYMJ)*(K - 1) + J 7648 KOFF1 = ISAIKL(ISYMAI,ISYMJK) 7649 * + NT1AM(ISYMAI)*(NJK - 1) 7650 * + 1 7651 KOFF2 = ISAIKJ(ISYAIJ,ISYMK) 7652 * + NCKI(ISYAIJ)*(K - 1) 7653 * + ISAIK(ISYMAI,ISYMJ) 7654 * + NT1AM(ISYMAI)*(J - 1) 7655 * + 1 7656C 7657 CALL DCOPY(NT1AM(ISYMAI),WORK(KOFF1),1, 7658 * UMAT(KOFF2),1) 7659C 7660 ENDDO 7661 ENDDO 7662 ENDDO 7663 ENDDO 7664C 7665C--------------------- 7666C End. 7667C--------------------- 7668C 7669 CALL QEXIT('CCSDPT_SYMSORT') 7670C 7671 RETURN 7672 END 7673C /* Deck ccfop_nonrel */ 7674 SUBROUTINE CCFOP_NONREL(OMEGA1,DENSAB,DENSIJ,ISSMAT,SMAT,SMAT2, 7675 * SMATBAR,SMATBAR2,UMAT,UMAT2, 7676 * UMATBAR,UMATBAR2,TMAT,T2TP,ISYMT2, 7677 * INDSQ,LENSQ,ISYMB,B,ISYMD,D,WORK,LWORK) 7678C 7679C Written by K. Hald, Winter 2001/2002. 7680C 7681 IMPLICIT NONE 7682C 7683#include "priunit.h" 7684#include "ccorb.h" 7685#include "ccsdsym.h" 7686C 7687 INTEGER ISSMAT, ISYMT2, ISYMB, ISYMD, LWORK 7688 INTEGER ISYFIK, ISYANM, ISYRES, KT2SOR, KT2SOR2, KEND1, LWRK1 7689 INTEGER ISYMF, ISYMIK, ISYMI, ISYMK, ISYMFK, ISYMFI 7690 INTEGER KOFF1, KOFF2, KOFF3, ISYMA, ISYMNM, ISYMN, ISYMM 7691 INTEGER ISYMAN, ISYMAM, LENGTH, NTOTFK, NTOTNM, NTOTA 7692 INTEGER KTMAT, ISYMJ, ISYCKL, ISYIJK, ISYMC, ISYMBD 7693 INTEGER LENSQ 7694 INTEGER INDSQ(LENSQ,6) 7695C 7696#if defined (SYS_CRAY) 7697 REAL OMEGA1(*), DENSAB(*), DENSIJ(*) 7698 REAL SMAT(*), SMAT2(*), SMATBAR(*), SMATBAR2(*) 7699 REAL UMAT(*), UMAT2(*), UMATBAR(*), UMATBAR2(*) 7700 REAL TMAT(*), T2TP(*), WORK(LWORK), ONE, ZERO, HALF 7701 REAL DDOT, TEMP 7702#else 7703 DOUBLE PRECISION OMEGA1(*), DENSAB(*), DENSIJ(*) 7704 DOUBLE PRECISION SMAT(*), SMAT2(*), SMATBAR(*), SMATBAR2(*) 7705 DOUBLE PRECISION UMAT(*), UMAT2(*), UMATBAR(*), UMATBAR2(*) 7706 DOUBLE PRECISION TMAT(*), T2TP(*), WORK(LWORK), ONE, ZERO, HALF 7707 DOUBLE PRECISION DDOT, TEMP 7708#endif 7709C 7710 PARAMETER(ONE = 1.0D0, ZERO = 0.0D0, HALF = 0.5D0) 7711C 7712 CALL QENTER('CCFOP_NONREL') 7713C 7714 LENGTH = NCKIJ(ISSMAT) 7715C 7716C------------------------------------------------------------ 7717C Calculate d_{ia} from <\mu_{3}| [[V,T2],T2]|HF > 7718C------------------------------------------------------------ 7719C 7720 if (.true.) then 7721C 7722 ISYFIK = MULD2H(ISYMT2,ISYMB) 7723 ISYANM = MULD2H(ISYMT2,ISYMD) 7724 ISYMBD = MULD2H(ISYMB,ISYMD) 7725 ISYRES = MULD2H(ISSMAT,ISYMBD) ! *isymt2*isymt2 7726C 7727 KT2SOR = 1 7728 KT2SOR2 = KT2SOR + NCKI(ISYFIK) 7729 KEND1 = KT2SOR2 + NCKI(ISYANM) 7730 LWRK1 = LWORK - KEND1 7731C 7732 IF (LWRK1 .LT. 0) THEN 7733 CALL QUIT('No more workspace in CCFOP_NONREL (T2,T2)') 7734 ENDIF 7735C 7736C------------------------------- 7737C Sort T2 ... to two diff. 7738C------------------------------- 7739C 7740 DO ISYMF = 1, NSYM 7741 ISYMIK = MULD2H(ISYFIK,ISYMF) 7742 DO ISYMI = 1, NSYM 7743 ISYMK = MULD2H(ISYMIK,ISYMI) 7744 ISYMFK = MULD2H(ISYMF,ISYMK) 7745 ISYMFI = MULD2H(ISYMF,ISYMI) 7746C 7747 DO K = 1, NRHF(ISYMK) 7748 DO I = 1, NRHF(ISYMI) 7749C 7750 KOFF1 = IT2SP(ISYFIK,ISYMB) 7751 * + NCKI(ISYFIK)*(B-1) 7752 * + ISAIK(ISYMFI,ISYMK) 7753 * + NT1AM(ISYMFI)*(K-1) 7754 * + IT1AM(ISYMF,ISYMI) 7755 * + NVIR(ISYMF)*(I-1) 7756 * + 1 7757 KOFF2 = KT2SOR 7758 * + ISAIK(ISYMFK,ISYMI) 7759 * + NT1AM(ISYMFK)*(I-1) 7760 * + IT1AM(ISYMF,ISYMK) 7761 * + NVIR(ISYMF)*(K-1) 7762C 7763 CALL DCOPY(NVIR(ISYMF),T2TP(KOFF1),1,WORK(KOFF2),1) 7764C 7765 ENDDO 7766 ENDDO 7767 ENDDO 7768 ENDDO 7769C 7770 DO ISYMA = 1, NSYM 7771 ISYMNM = MULD2H(ISYANM,ISYMA) 7772 DO ISYMN = 1, NSYM 7773 ISYMM = MULD2H(ISYMNM,ISYMN) 7774 ISYMAN = MULD2H(ISYMA,ISYMN) 7775 ISYMAM = MULD2H(ISYMA,ISYMM) 7776C 7777 DO N = 1, NRHF(ISYMN) 7778 DO M = 1, NRHF(ISYMM) 7779C 7780 KOFF1 = IT2SP(ISYANM,ISYMD) 7781 * + NCKI(ISYANM)*(D-1) 7782 * + ISAIK(ISYMAN,ISYMM) 7783 * + NT1AM(ISYMAN)*(M-1) 7784 * + IT1AM(ISYMA,ISYMN) 7785 * + NVIR(ISYMA)*(N-1) 7786 * + 1 7787 KOFF2 = KT2SOR2-1 7788 * + IMAIJA(ISYMNM,ISYMA) 7789 * + IMATIJ(ISYMN,ISYMM) 7790 * + NRHF(ISYMN)*(M-1) 7791 * + N 7792C 7793 CALL DCOPY(NVIR(ISYMA),T2TP(KOFF1),1,WORK(KOFF2), 7794 * NMATIJ(ISYMNM)) 7795C 7796 ENDDO 7797 ENDDO 7798 ENDDO 7799 ENDDO 7800C 7801 DO I = 1, LENGTH 7802 TMAT(I) = SMATBAR(INDSQ(I,2)) 7803 * + UMATBAR(INDSQ(I,2)) 7804 * + SMATBAR2(INDSQ(I,1)) 7805 * + UMATBAR2(INDSQ(I,1)) 7806 ENDDO 7807C 7808 IF (NSYM .GT. 1) THEN 7809 CALL CC_GATHER(LENGTH,WORK(KEND1),TMAT,INDSQ(1,6)) 7810 CALL DCOPY(LENGTH,WORK(KEND1),1,TMAT,1) 7811 ENDIF 7812C 7813 DO ISYMA = 1, NSYM 7814 ISYMI = MULD2H(ISYRES,ISYMA) 7815 ISYMFK = MULD2H(ISYFIK,ISYMI) 7816 ISYMNM = MULD2H(ISSMAT,ISYMFK) 7817C 7818 KOFF1 = ISAIKL(ISYMFK,ISYMNM) 7819 * + 1 7820 KOFF2 = KT2SOR 7821 * + ISAIK(ISYMFK,ISYMI) 7822 KOFF3 = KEND1 7823 * + IMAIJK(ISYMNM,ISYMI) 7824C 7825 NTOTFK = MAX(1,NT1AM(ISYMFK)) 7826 NTOTNM = MAX(1,NMATIJ(ISYMNM)) 7827C 7828 CALL DGEMM('T','N',NMATIJ(ISYMNM),NRHF(ISYMI),NT1AM(ISYMFK), 7829 * ONE,TMAT(KOFF1),NTOTFK,WORK(KOFF2),NTOTFK,ZERO, 7830 * WORK(KOFF3),NTOTNM) 7831C 7832 KOFF1 = KT2SOR2 7833 * + IMAIJA(ISYMNM,ISYMA) 7834 KOFF2 = KEND1 7835 * + IMAIJK(ISYMNM,ISYMI) 7836 KOFF3 = IT1AM(ISYMA,ISYMI) 7837 * + 1 7838C 7839 NTOTNM = MAX(1,NMATIJ(ISYMNM)) 7840 NTOTA = MAX(1,NVIR(ISYMA)) 7841C 7842 CALL DGEMM('T','N',NVIR(ISYMA),NRHF(ISYMI),NMATIJ(ISYMNM), 7843 * -HALF,WORK(KOFF1),NTOTNM,WORK(KOFF2),NTOTNM, 7844 * ONE,OMEGA1(KOFF3),NTOTA) 7845C 7846 ENDDO 7847C 7848 endif ! of if (.true.) then 7849C----------------------------------------------------- 7850C Calculate d_{ij} from <\mu_{3}|[V,T3]|HF > 7851C----------------------------------------------------- 7852C 7853 KTMAT = 1 7854 KEND1 = KTMAT + LENGTH 7855 LWRK1 = LWORK - KEND1 7856C 7857 IF (LWRK1 .LT. 0) THEN 7858 CALL QUIT('Out of memory in CCFOP_NONREL (ab-part)') 7859 ENDIF 7860C 7861 if (.true.) then 7862C 7863 DO I = 1, LENGTH 7864 TMAT(I) = 7865 * SMAT(I) 7866 * + UMAT(I) 7867 * + SMAT2(INDSQ(I,3)) 7868 * + UMAT2(INDSQ(I,3)) 7869 ENDDO 7870C 7871 DO I = 1, LENGTH 7872 WORK(KTMAT-1+I) = 7873 * SMATBAR(I) 7874 * + UMATBAR(I) 7875 * + SMATBAR2(INDSQ(I,3)) 7876 * + UMATBAR2(INDSQ(I,3)) 7877 ENDDO 7878C 7879 DO ISYMJ = 1, NSYM 7880 ISYMI = MULD2H(ISYRES,ISYMJ) 7881 ISYCKL = MULD2H(ISSMAT,ISYMI) 7882 DO J = 1, NRHF(ISYMJ) 7883 KOFF1 = KTMAT 7884 * + ISAIKJ(ISYCKL,ISYMJ) 7885 * + NCKI(ISYCKL)*(J-1) 7886 DO I = 1, NRHF(ISYMI) 7887 KOFF2 = ISAIKJ(ISYCKL,ISYMI) 7888 * + NCKI(ISYCKL)*(I-1) 7889 * + 1 7890 KOFF3 = IMATIJ(ISYMI,ISYMJ) 7891 * + NRHF(ISYMI)*(J-1) 7892 * + I 7893C 7894 TEMP = DDOT(NCKI(ISYCKL),WORK(KOFF1),1,TMAT(KOFF2),1) 7895C 7896 DENSIJ(KOFF3) = DENSIJ(KOFF3) - HALF*TEMP 7897 ENDDO 7898 ENDDO 7899 ENDDO 7900C 7901 endif 7902C----------------------------------------------------- 7903C Calculate d_{ab} from <\mu_{3}|[V,T3]|HF > 7904C----------------------------------------------------- 7905C 7906 if (.true.) then 7907C 7908 DO I = 1, LENGTH 7909 TMAT(I) = 7910 * SMAT(I) 7911 * + UMAT(I) 7912 * + SMAT2(INDSQ(I,3)) 7913 * + UMAT2(INDSQ(I,3)) 7914 ENDDO 7915C 7916 DO I = 1, LENGTH 7917 WORK(KTMAT-1+I) = 7918 * SMATBAR(I) 7919 * + UMATBAR(I) 7920 * + SMATBAR2(INDSQ(I,3)) 7921 * + UMATBAR2(INDSQ(I,3)) 7922 ENDDO 7923C 7924 CALL DCOPY(LENGTH,TMAT,1,WORK(KEND1),1) 7925 CALL CCFOP_SORT(WORK(KEND1),TMAT,ISSMAT,2) 7926C 7927 CALL DCOPY(LENGTH,WORK(KTMAT),1,WORK(KEND1),1) 7928 CALL CCFOP_SORT(WORK(KEND1),WORK(KTMAT),ISSMAT,2) 7929C 7930 DO ISYMA = 1, NSYM 7931 ISYMC = MULD2H(ISYRES,ISYMA) 7932 ISYIJK = MULD2H(ISSMAT,ISYMA) 7933 DO A = 1, NVIR(ISYMA) 7934 KOFF1 = KTMAT 7935 * + ISJIKA(ISYIJK,ISYMA) 7936 * + NMAJIK(ISYIJK)*(A-1) 7937 DO C = 1, NVIR(ISYMC) 7938 KOFF2 = ISJIKA(ISYIJK,ISYMC) 7939 * + NMAJIK(ISYIJK)*(C-1) 7940 * + 1 7941 KOFF3 = IMATAB(ISYMA,ISYMC) 7942 * + NVIR(ISYMA)*(C-1) 7943 * + A 7944C 7945 TEMP = DDOT(NMAJIK(ISYIJK),WORK(KOFF1),1,TMAT(KOFF2),1) 7946C 7947 DENSAB(KOFF3) = DENSAB(KOFF3) + HALF*TEMP 7948C 7949 ENDDO 7950 ENDDO 7951 ENDDO 7952C 7953 endif 7954C 7955C--------------------- 7956C End. 7957C--------------------- 7958C 7959 CALL QEXIT('CCFOP_NONREL') 7960C 7961 RETURN 7962 END 7963