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