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 19*=====================================================================* 20c /* deck ccfbtaao1 */ 21*=====================================================================* 22 SUBROUTINE CCFBTAAO1(X0INT,ISY0DIS,X1INT,ISY1DIS, 23 & BF0RHF,BF1RHF, 24 & DENS0,DPCK0,FOCK0, 25 & DENSQ,DPCKQ,FOCKQ, 26 & DENSA,DPCKA,FOCKA, 27 & DENSQA,DPCKQA,FOCKQA, 28 & XLAMD0P,XLAMD0H,XLAMDQP,XLAMDQH, 29 & XLAMDAP,XLAMDAH,XLAMDQAP,XLAMDQAH, 30 & RHOBFA,RHOBFQA, 31 & LUBFDA,FNBFDA,IADRBFA, 32 & LUBFDQA,FNBFDQA,IADRBFQA, 33 & LU0IAJB,FN0IAJB, 34 & LU1IAJB,FN1IAJB, 35 & IT2DEL0,IADR0,IT2DELB,IADRB, 36 & LU0IJCB,LU0CJIB, 37 & FN0IJCB,FN0CJIB, 38 & LU1IJCB,LU1CJIB, 39 & FN1IJCB,FN1CJIB, 40 & IT2DEL0A,IADR0A, 41 & IT2DELBA,IADRBA, 42 & IDEL,LZERO,LNEWTA, 43 & LRELAX,LTWOEL,LX1ISQ,IREAL, 44 & ISYHOP,ISYMTA,WORK, LWORK) 45* 46*---------------------------------------------------------------------* 47* 48* Purpose: calculate intermediates for FbTa vector which depend on 49* the AO integrals and at most TA and IOPER (No Zeta) 50* 51* contrib. depending on X1INT/D1SRHF are only computed for LTWOEL ? 52* contrib. depending on X0INT/D0SRHF are only computed for LRELAX ? 53* 54* (only exception: the (ia|jb), (ij|cb), (cj|ib) integrals) 55* zeroth-order MO integrals are only computed for LZERO 56* 57* Written by Sonia Coriani, February 1999 58* Version: 08/10-1999 59*---------------------------------------------------------------------* 60#if defined (IMPLICIT_NONE) 61 IMPLICIT NONE 62#else 63# include "implicit.h" 64#endif 65#include "priunit.h" 66#include "ccorb.h" 67#include "ccsdsym.h" 68#include "ccsdinp.h" 69#include "maxorb.h" 70#include "ccisao.h" 71 72 INTEGER ISYM0 73 PARAMETER (ISYM0 = 1) 74 LOGICAL LOCDBG 75 PARAMETER (LOCDBG = .FALSE.) 76 77* variables: 78 LOGICAL LZERO, LNEWTA, LRELAX, LTWOEL, LX1ISQ 79 CHARACTER*(*) FNBFDA, FNBFDQA 80 CHARACTER*(*) FN0IAJB,FN1IAJB 81 CHARACTER*(*) FN0IJCB,FN0CJIB,FN1IJCB,FN1CJIB 82 INTEGER ISY0DIS, ISY1DIS, IDEL, ISYHOP, IREAL 83 INTEGER LU0IAJB, LU1IAJB 84 INTEGER LU0IJCB, LU0CJIB, LU1IJCB, LU1CJIB 85 INTEGER LUBFDA, LUBFDQA, LWORK 86 INTEGER IADRBFA(*), IADRBFQA(*) 87 INTEGER IT2DEL0(*), IT2DELB(*) 88 INTEGER IT2DEL0A(*), IT2DELBA(*) 89 INTEGER KDUM, IDUMMY 90 PARAMETER (KDUM = +99 999 999) ! dummy address 91 92 93#if defined (SYS_CRAY) 94 REAL X0INT(*), X1INT(*), BF0RHF(*), BF1RHF(*) 95 REAL XLAMD0P(*), XLAMD0H(*), XLAMDQP(*), XLAMDQH(*) 96 REAL XLAMDAP(*), XLAMDAH(*), XLAMDQAP(*), XLAMDQAH(*) 97 REAL DENS0(*), DPCK0(*), FOCK0(*) 98 REAL DENSQ(*), DPCKQ(*), FOCKQ(*) 99 REAL DENSA(*), DPCKA(*), FOCKA(*) 100 REAL DENSQA(*), DPCKQA(*), FOCKQA(*) 101 REAL RHOBFA(*),RHOBFQA(*) 102 REAL WORK(LWORK) 103 REAL ONE, ZERO, TWO, XNORM, DDOT, DNRM2 104#else 105 DOUBLE PRECISION X0INT(*), X1INT(*), BF0RHF(*), BF1RHF(*) 106 DOUBLE PRECISION XLAMD0P(*), XLAMD0H(*), XLAMDQP(*), XLAMDQH(*) 107 DOUBLE PRECISION XLAMDAP(*), XLAMDAH(*), XLAMDQAP(*), XLAMDQAH(*) 108 DOUBLE PRECISION DENS0(*), DPCK0(*),FOCK0(*) 109 DOUBLE PRECISION DENSQ(*), DPCKQ(*), FOCKQ(*) 110 DOUBLE PRECISION DENSA(*), DPCKA(*), FOCKA(*) 111 DOUBLE PRECISION DENSQA(*), DPCKQA(*), FOCKQA(*) 112 DOUBLE PRECISION RHOBFA(*),RHOBFQA(*) 113 DOUBLE PRECISION WORK(LWORK) 114 DOUBLE PRECISION ONE, ZERO, TWO, XNORM, DDOT, DNRM2 115#endif 116 PARAMETER (ONE = 1.0d0, ZERO = 0.0d0, TWO = 2.0d0) 117 118 INTEGER ISYDEL, ISYMM1, ISYMM2, NMGD, KEND4, LWRK4, IADR, KMGD 119 INTEGER KSCRCM2, KSCRCM1, KDSRHF 120 INTEGER KX1IAJB, KX0IAJB, KXA1IJCB, KXA1CJIB, KXA0IJCB, KXA0CJIB 121 INTEGER LEN0, LEN1, LEN0A, LEN1A, ISYGAM, ISY0ALBE, ISY1ALBE 122 INTEGER JGAM, KOFF0, KOFF1, ISYSRH1, KEND5, LWRK5, IOPT, ISYM 123 INTEGER ISYMM0, ISYBF0, ISYBF1, ISYMTA 124 INTEGER IADR0, IADRB, IADR0A, IADRBA 125 INTEGER ISY0IAJ, ISY1IAJ, ISYA0IJC, ISYA1IJC,ISYHTA 126 127*---------------------------------------------------------------------* 128* begin: 129*---------------------------------------------------------------------* 130 ISYDEL = ISAO(IDEL) 131 D = IDEL - IBAS(ISYDEL) 132 133 ISYHTA = MULD2H(ISYHOP,ISYMTA) 134 135*---------------------------------------------------------------------* 136* add 2-electr. contribution to AO Fock matrix Fbar (FOCKQ): 137* For CCS add the 2 electron part to FOCK0 too!!!!!!!! 138*---------------------------------------------------------------------* 139 140 IF (LRELAX) THEN 141 CALL CC_AOFOCK2(X0INT,DENSQ,DPCKQ,FOCKQ,WORK,LWORK, 142 & IDEL,ISY0DIS,ISYDEL,ISYHOP,.FALSE.) 143 CALL CC_AOFOCK2(X0INT,DENSA,DPCKA,FOCKA,WORK,LWORK, 144 & IDEL,ISY0DIS,ISYDEL,ISYMTA,.FALSE.) 145 CALL CC_AOFOCK2(X0INT,DENSQA,DPCKQA,FOCKQA,WORK,LWORK, 146 & IDEL,ISY0DIS,ISYDEL,ISYHTA,.FALSE.) 147 IF (CCS.AND.LZERO) THEN 148 CALL CC_AOFOCK2(X0INT,DENS0,DPCK0,FOCK0,WORK,LWORK, 149 & IDEL,ISY0DIS,ISYDEL,ISYM0,.FALSE.) 150 END IF 151 END IF 152 153 IF (LTWOEL) THEN 154 CALL CC_AOFOCK2(X1INT,DENS0,DPCK0,FOCKQ,WORK,LWORK, 155 & IDEL,ISY1DIS,ISYDEL,ISYM0,LX1ISQ) 156 CALL CC_AOFOCK2(X1INT,DENSA,DPCKA,FOCKQA,WORK,LWORK, 157 & IDEL,ISY1DIS,ISYDEL,ISYMTA,LX1ISQ) 158 END IF 159 160*---------------------------------------------------------------------* 161* for CCS we are done ... 162*---------------------------------------------------------------------* 163 IF (CCS) RETURN 164 165*---------------------------------------------------------------------* 166* for CCSD calculate the first-order BF intermediates 167* the BF(A) intermediate only depends on TA 168* the BF(QA) intermediate depends on TA and IOPER 169* 170* for CC2 the F term and the G intermediate (skip) 171*---------------------------------------------------------------------* 172 ISYMM0 = MULD2H(ISYDEL,ISYM0) 173 ISYMM1 = MULD2H(ISYDEL,ISYMTA) 174 ISYMM2 = MULD2H(ISYDEL,ISYHTA) 175 ISYBF0 = ISYMM0 176 ISYBF1 = MULD2H(ISYDEL,ISYHOP) 177 178* ------------------------------------------- 179* CCSD contributions: the BF intermediates... 180* ------------------------------------------- 181 IF (.NOT. CC2) THEN 182 183* -------------------------------------------------------- 184* allocate an array for the different effective densities: 185* -------------------------------------------------------- 186 NMGD = 0 187 DO ISYM = 1, NSYM 188 NMGD = MAX(NMGD,NT2BGD(ISYM)) !max length 189 END DO 190 191 KMGD = 1 192 KEND4 = KMGD + NMGD 193 LWRK4 = LWORK - KEND4 194 195 IF (LWRK4 .LT. 0) THEN 196 CALL QUIT('Insufficient work space in CCFBTAAO. (4)') 197 END IF 198* 199* ------------------------------------------------------- 200* read in the BF(A) effective density and contract: 201* with the PRESORTED g(1)(al-m,gam;del) --> result in RHOBFQA 202* 203* with the PRESORTED g(0)(al-m,gam;del) --> result in RHOBFA 204* (only for a new T^A) 205* LTWOEL/LRELAX not carried thru 206* The BF intermediates are written on file OUTSIDE 207* ------------------------------------------------------- 208 209* read delta batch of the effective density DeltaA for BF(A) and BF(QA): 210 211 IADR = IADRBFA(IDEL) 212 NMGD = NT2BGD(ISYMM1) 213 CALL GETWA2(LUBFDA,FNBFDA,WORK(KMGD),IADR,NMGD) 214 215* update BF(A) intermediate (RHOBFA_al i,kj, sym ISYMD*ISYMM): 216 217 CALL CC_BFIB(RHOBFA,BF0RHF,ISYBF0,WORK(KMGD),ISYMM1, 218 * WORK(KEND4),LWRK4) 219 220* update BF(QA) intermediate: 221 222 CALL CC_BFIB(RHOBFQA,BF1RHF,ISYBF1,WORK(KMGD),ISYMM1, 223 * WORK(KEND4),LWRK4) 224 225* read idelta batch of the effective density DeltaQA for BF(QA): 226 227 IADR = IADRBFQA(IDEL) 228 NMGD = NT2BGD(ISYMM2) 229 CALL GETWA2(LUBFDQA,FNBFDQA,WORK(KMGD),IADR,NMGD) 230 231* update BF(QA) intermediate (add to previous contribution): 232* (added inside) 233 234 CALL CC_BFIB(RHOBFQA,BF0RHF,ISYBF0,WORK(KMGD),ISYMM2, 235 * WORK(KEND4),LWRK4) 236 237 END IF 238* ELSE 239* --------------------------------------------------------- 240* CC2 contributions: the F term and the G intermediate... 241* (the G term is here calculated in a certainly very clumsy 242* way using the one-index backtransformed amplitudes ...) 243* CC2 NOT YET IMPLEMENTED 244* --------------------------------------------------------- 245C 246C KSCRCM1 = 1 247C KEND4 = KSCRCM1 + NT2BCD(ISYMM1) 248C LWRK4 = LWORK - KEND4 249C 250C IF (LWRK4 .LT. 0) THEN 251C CALL QUIT('Insufficient work space in CCXIINTAO. (4)') 252C END IF 253C 254* calculate one-index backtransformed amplitudes: 255* scrm1 - backtransformed with XLAMDH0 matrix 256C IOPT = 1 257C CALL CC_T2AO(T2AMP0,XLAMDH0,ISYM0, 258C & WORK(KSCRCM1), WORK(KEND4),LWRK4, 259C & IDEL, ISYDEL, ISYM0, IOPT ) 260C 261C IF (LTWOEL) THEN 262C 263* ------------------------------------------ 264* for CC2 the F term and the G intermediate: 265* ------------------------------------------ 266C IOPT = 0 267C CALL CC_MOFCON2(X1INT,RHO2,XLAMDP0,XLAMDH0, 268C & XLAMDP0,XLAMDH0,XLAMDP0,XLAMDH0, 269C & ISYM0,ISYM0,ISYM0,ISYM0, 270C & WORK(KEND4),LWRK4,IDEL, 271C & ISYDEL,ISYHOP,ISYHOP,IOPT) 272C 273C CALL CC_GIM(D1SRHF,ISY1DIS,WORK(KSCRCM1),ISYMM1, 274C & XLAMDH0,ISYM0,GBIM,WORK(KEND4),LWRK4) 275C 276C END IF 277C 278C IF (LRELAX) THEN 279C 280* ----------------------------------------------------- 281* add the contributions from the relax. Lambda matrices 282* ----------------------------------------------------- 283C KSCRCM2 = KEND4 284C KEND4 = KSCRCM2 + NT2BCD(ISYMM2) 285C LWRK4 = LWORK - KEND4 286C 287C IF (LWRK4 .LT. 0) THEN 288C CALL QUIT('Insufficient work space in CCXIINTAO. (4b)') 289C END IF 290C 291* calculate one-index backtransformed amplitudes: 292* scrm2 - backtransformed with XLAMDQH matrix 293C IOPT = 1 294C CALL CC_T2AO(T2AMP0,XLAMDQH,ISYHOP, 295C & WORK(KSCRCM2), WORK(KEND4),LWRK4, 296C & IDEL, ISYDEL, ISYM0, IOPT ) 297C 298* ------------------------------------------ 299* for CC2 the F term and the G intermediate: 300* ------------------------------------------ 301C IOPT = 0 302C CALL CC_MOFCON2(X0INT,RHO2,XLAMDQP,XLAMDQH, 303C & XLAMDP0,XLAMDH0,XLAMDP0,XLAMDH0, 304C & ISYHOP,ISYM0,ISYM0,ISYM0, 305C & WORK(KEND4),LWRK4,IDEL, 306C & ISYDEL,ISYHOP,ISYM0,IOPT) 307C 308C IF (LZERO) THEN 309* ...without relaxation... 310C CALL CC_GIM(D0SRHF,ISY0DIS,WORK(KSCRCM1),ISYMM1, 311C & XLAMDH0,ISYM0,G0IM,WORK(KEND4),LWRK4) 312C END IF 313C 314* ...relaxation of the XLAMDH used inside of CC_GIM... 315C CALL CC_GIM(D0SRHF,ISY0DIS,WORK(KSCRCM1),ISYMM1, 316C & XLAMDQH,ISYHOP,GBIM,WORK(KEND4),LWRK4) 317C 318* ...relaxation of the XLAMDH used for T2 backtransf.... 319C CALL CC_GIM(D0SRHF,ISY0DIS,WORK(KSCRCM2),ISYMM2, 320C & XLAMDH0,ISYM0,GBIM,WORK(KEND4),LWRK4) 321C 322C 323C ISYSRH1 = MULD2H(ISY0DIS,ISYHOP) 324C KDSRHF = KEND4 325C KEND5 = KDSRHF + NDSRHF(ISYSRH1) 326C LWRK5 = LWORK - KEND5 327C 328C IF (LWRK5 .LT. 0) THEN 329C CALL QUIT('Insufficient work space in CCXIINTAO. (5)') 330C END IF 331C 332* ...relaxation of the XLAMDP used in CCTRBT.... 333C CALL CCTRBT(X0INT,WORK(KDSRHF),XLAMDQP, 334C & ISYHOP,WORK(KEND5),LWRK5,ISY0DIS) 335C 336C CALL CC_GIM(WORK(KDSRHF),ISYSRH1,WORK(KSCRCM1),ISYMM1, 337C & XLAMDH0,ISYM0,GBIM,WORK(KEND5),LWRK5) 338C 339C END IF 340C 341C END IF 342*---------------------------------------------------------------------* 343* calculate 3-index transformed integrals: 344* (ia|j del), (ia|j del)-bar, 345*---------------------------------------------------------------------* 346 347 ISY0IAJ = MULD2H(ISY0DIS,ISYM0) !ISY0DIS * 3Lambda0 348 ISY1IAJ = MULD2H(ISY0DIS,ISYHOP) !ISY0DIS*2Lamda0*1LamdaQ=ISY1DIS*3Lamda0 349 350C ------------------------------------- 351C allocate memory for integral batches: 352C ------------------------------------- 353 KX1IAJB = 1 354 KEND4 = KX1IAJB + NT2BCD(ISY1IAJ) 355* 356 IF (LZERO) THEN 357 KX0IAJB = KEND4 358 KEND4 = KX0IAJB + NT2BCD(ISY0IAJ) 359 END IF 360* 361 LWRK4 = LWORK - KEND4 362* 363 IF (LWRK4 .LT. 0) THEN 364 CALL QUIT('Insufficient work space in CCFBTAAO1. (4b)') 365 END IF 366* 367 IF (LZERO) THEN 368 CALL DZERO(WORK(KX0IAJB),NT2BCD(ISY0IAJ)) 369 END IF 370* 371 CALL DZERO(WORK(KX1IAJB),NT2BCD(ISY1IAJ)) 372* 373C --------------------------------------------------- 374C do the 3-index transformation in a loop over gamma: 375C --------------------------------------------------- 376 DO ISYGAM = 1, NSYM 377 378 ISY0ALBE = MULD2H(ISY0DIS,ISYGAM) 379 ISY1ALBE = MULD2H(ISY1DIS,ISYGAM) 380 381 DO G = 1, NBAS(ISYGAM) 382 JGAM = G + IBAS(ISYGAM) !absolute index for gamma as IDEL 383 384 KOFF0 = IDSAOG(ISYGAM,ISY0DIS)+NNBST(ISY0ALBE)*(G-1)+1 385 IF (LX1ISQ) THEN 386 KOFF1 = IDSAOGSQ(ISYGAM,ISY1DIS)+N2BST(ISY1ALBE)*(G-1)+1 387 ELSE 388 KOFF1 = IDSAOG(ISYGAM,ISY1DIS)+NNBST(ISY1ALBE)*(G-1)+1 389 END IF 390 391 IOPT = 0 392 CALL CC_IAJB(X0INT(KOFF0),ISY0ALBE, 393 & X1INT(KOFF1),ISY1ALBE, 394 & IDEL,JGAM,.FALSE.,IDUMMY, 395 & WORK(KX0IAJB),WORK(KDUM),WORK(KDUM), 396 & WORK(KX1IAJB),WORK(KDUM),WORK(KDUM), 397 & XLAMD0P,XLAMD0H,ISYM0,XLAMDQP,XLAMDQH,ISYHOP, 398 & XLAMD0P,XLAMD0H,ISYM0,XLAMDQP,XLAMDQH,ISYHOP, 399 & WORK(KEND4),LWRK4,IOPT,LTWOEL,LRELAX,LZERO, 400 & .TRUE.,LX1ISQ,IREAL) 401 402 END DO 403 404 END DO 405 406* -------------------------------------------- 407* write 3-index transformed integrals to disk: 408* -------------------------------------------- 409 IF (LZERO) THEN 410 LEN0 = NT2BCD(ISY0IAJ) 411 412 CALL PUTWA2(LU0IAJB, FN0IAJB, WORK(KX0IAJB), IADR0, LEN0) 413 414 IT2DEL0(IDEL) = IADR0 415 IADR0 = IADR0 + LEN0 416 END IF 417* 418 LEN1 = NT2BCD(ISY1IAJ) 419 420 CALL PUTWA2(LU1IAJB, FN1IAJB, WORK(KX1IAJB), IADRB, LEN1) 421 422 IT2DELB(IDEL) = IADRB 423 IADRB = IADRB + LEN1 424 425*---------------------------------------------------------------------* 426* calculate 3-index transformed integrals: 427* (ij^|cb) + (ij|c^b), (ij^|cb) + (ij|c^b)-bar 428* (cj^|ib) + (c^j|ib), (cj^|ib) + (c^j|ib)-bar 429* for the C and D intermediates 430*---------------------------------------------------------------------* 431* 432 ISYA0IJC = MULD2H(ISY0DIS,ISYMTA) 433 ISYA1IJC = MULD2H(ISY0DIS,MULD2H(ISYM0,ISYHTA)) 434 435C ------------------------------------- 436C allocate memory for integral batches: 437C ------------------------------------- 438 KXA1IJCB = 1 439 KXA1CJIB = KXA1IJCB + NT2BCD(ISYA1IJC) 440 KEND5 = KXA1CJIB + NT2BCD(ISYA1IJC) 441* 442 IF (LNEWTA) THEN 443 KXA0IJCB = KEND5 444 KXA0CJIB = KXA0IJCB + NT2BCD(ISYA0IJC) 445 KEND5 = KXA0CJIB + NT2BCD(ISYA0IJC) 446 END IF 447* 448 LWRK5 = LWORK - KEND5 449* 450 IF (LWRK5 .LT. 0) THEN 451 CALL QUIT('Insufficient work space in CCFBTAAO. (4b)') 452 END IF 453 454* Initialize memory areas 455 456 IF (LZERO.OR.LNEWTA) THEN 457 CALL DZERO(WORK(KXA0IJCB),NT2BCD(ISYA0IJC)) 458 CALL DZERO(WORK(KXA0CJIB),NT2BCD(ISYA0IJC)) 459 END IF 460 CALL DZERO(WORK(KXA1IJCB),NT2BCD(ISYA1IJC)) 461 CALL DZERO(WORK(KXA1CJIB),NT2BCD(ISYA1IJC)) 462 463C --------------------------------------------------- 464C do the 3-index transformation in a loop over gamma: 465C --------------------------------------------------- 466 DO ISYGAM = 1, NSYM 467 468 ISY0ALBE = MULD2H(ISY0DIS,ISYGAM) 469 ISY1ALBE = MULD2H(ISY1DIS,ISYGAM) 470 471 DO G = 1, NBAS(ISYGAM) 472 JGAM = G + IBAS(ISYGAM) 473 474 KOFF0 = IDSAOG(ISYGAM,ISY0DIS)+NNBST(ISY0ALBE)*(G-1)+1 475 476 IF (LX1ISQ) THEN 477 KOFF1 = IDSAOGSQ(ISYGAM,ISY1DIS)+ 478 & N2BST(ISY1ALBE)*(G-1)+1 479 ELSE 480 KOFF1 = IDSAOG(ISYGAM,ISY1DIS)+NNBST(ISY1ALBE)*(G-1)+1 481 END IF 482 483 IOPT = 1 484 CALL CC_IJCB(X0INT(KOFF0),ISY0ALBE,X1INT(KOFF1),ISY1ALBE, 485 & IDEL,JGAM, 486 & WORK(KXA0IJCB), 487 & WORK(KXA0CJIB), 488 & WORK(KXA1IJCB), 489 & WORK(KXA1CJIB), 490 & XLAMD0P,XLAMD0H,ISYM0,XLAMDQP,XLAMDQH,ISYHOP, 491 & XLAMDAP,XLAMDAH,ISYMTA,XLAMDQAP,XLAMDQAH,ISYHTA, 492 & WORK(KEND5),LWRK5, 493 & IOPT,LTWOEL,LRELAX,LZERO,LNEWTA,LX1ISQ) 494 495 END DO 496 497 END DO 498 499C ------------------------------------ 500C transform (cj|i del) to L(cj|i del): 501C ------------------------------------ 502 IF (LNEWTA) THEN 503 CALL DSCAL(NT2BCD(ISYA0IJC),TWO,WORK(KXA0CJIB),1) 504 CALL DAXPY(NT2BCD(ISYA0IJC),-ONE,WORK(KXA0IJCB),1, 505 & WORK(KXA0CJIB),1) 506 END IF 507 508 CALL DSCAL(NT2BCD(ISYA1IJC),TWO,WORK(KXA1CJIB),1) 509 CALL DAXPY(NT2BCD(ISYA1IJC),-ONE,WORK(KXA1IJCB),1, 510 & WORK(KXA1CJIB),1) 511 512 513C -------------------------------------------- 514C write 3-index transformed integrals to disk: 515C -------------------------------------------- 516 IF (LOCDBG) THEN 517 XNORM = DNRM2(NT2BCD(ISYA0IJC),WORK(KXA0IJCB),1) 518 WRITE(LUPRI,*)'CCFBTAAO1> IDEL: ', idel 519 WRITE(LUPRI,*)'Norm special integrals (0A):', XNORM 520 XNORM = DNRM2(NT2BCD(ISYA1IJC),WORK(KXA1IJCB),1) 521 WRITE(LUPRI,*)'Norm special integrals (BA):', XNORM 522 END IF 523 524 IF (LNEWTA) THEN 525 LEN0A = NT2BCD(ISYA0IJC) 526 527 CALL PUTWA2(LU0IJCB, FN0IJCB, WORK(KXA0IJCB), IADR0A, LEN0A) 528 CALL PUTWA2(LU0CJIB, FN0CJIB, WORK(KXA0CJIB), IADR0A, LEN0A) 529 530 IT2DEL0A(IDEL) = IADR0A 531 IADR0A = IADR0A + LEN0A 532* else? 533 END IF 534 535 536 LEN1A = NT2BCD(ISYA1IJC) 537 538 CALL PUTWA2(LU1IJCB, FN1IJCB, WORK(KXA1IJCB), IADRBA, LEN1A) 539 CALL PUTWA2(LU1CJIB, FN1CJIB, WORK(KXA1CJIB), IADRBA, LEN1A) 540 541 IT2DELBA(IDEL) = IADRBA 542 IADRBA = IADRBA + LEN1A 543 544*---------------------------------------------------------------------* 545* that's it; return: 546*---------------------------------------------------------------------* 547 RETURN 548 END 549*=====================================================================* 550* END OF SUBROUTINE CCFBTAAO1 * 551*=====================================================================* 552