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