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!  /* Deck cc_bf3 */
20      SUBROUTINE CC_BF3(XINT,OMEGA2,XLAMD1,ISYML1,XLAMD2,
21     *                  ISYML2,XLAMD3,ISYML3,
22     *                  SCRM,ISYMM1,SCRM2,ISYMM2,WORK,LWORK,
23     *                  IDEL,ISYMD,IOPT)
24!
25!     Written by Henrik Koch 3-Jan-1994
26!     Symmetry by Henrik Koch and Alfredo Sanchez. 18-July-1994
27!     Generalized by Asger Halkier and Henrik Koch 19/9 - 1995
28!     to handle left-hand-side transformation contribution as well.
29!     Righthand generalizations and debugging Ove Christiansen 23-9-1995
30!
31!     Ove Christiansen 24-9-1996: Generalization for calculating
32!           terms similar to B and F-terms in the transformation
33!           of vectors with the F-matrix.
34!
35!     Kasper Hald and Christof Haettig 22-2-1999
36!     Generalized to calculate the BF-term for the triplet case.
37!
38!     Purpose: Calculate B-term and F-term in the orthonormal basis.
39!
40!     IOPT equals one for energy-calculations and two or three for
41!     response calculations (2 for left trans. and 3 for right trans.)
42!     IOPT eq. 4 for F*vector contributions.
43!     IOPT equals 5  (Tilde)rhoBF(-)
44!
45!
46!     XLAMD1 is always a true lamda matrix whereas XLAMD2
47!     is an AO transformed trialvector in the case af a
48!     response calculation.
49!
50!
51!     24-9-1996:
52!
53!
54!     IF (IOPT .EQ. 2/3)
55!                       scrm is left/right vector transformed
56!                       to tci,j(delta): vector general symmetry
57!                       lambda particle/hole matrix is tot.sym.
58!                       XLAMD1 is ordinary lambda particle/hole matrix.
59!                       XLAMD2 is transformed (barred)
60!                       lambda particle/hole matrix.
61!                       (XLAMD1(gam,i)*XLAMD2(del,j)
62!                       +XLAMD2(gam,i)*XLAMD1(del,j))
63!
64!   IF (IOPT .EQ. 5)
65!                     Triplet minus-intermediate.
66!                     SCRM is right vector transformed
67!                     to t(ci,j)(delta)
68!                     Lambda particle/hole matrix is tot. sym.
69!                     XLAMD1 is ordinary lambda particle/hole matr.
70!                     XLAMD2 is the transformed lambda part./hole matr.
71!                      XLAMD1(gam,i)*XLAMD2(del,j)
72!                     +XLAMD2(gam,i)*XLAMD1(del,j)
73!
74!   IF (IOPT .EQ. 6)
75!                     Same as IOPT .EQ. 3 except for the fact
76!                     that the product of PLUS and PLUS
77!                     (See the routine) is zero. (The T-amplitudes
78!                     for the (+)triplet case are antisymmetric
79!                     with respect to the interchange of i and j )
80!
81!     The symmetry input to this routine is somewhat redundant but
82!     hopefully logical and flexible:
83!     Isymm1 is symmetry of SCRM
84!     Isymm2 is symmetry of SCRM2
85!     Isyml1 is symmetry of XLAMD1
86!     Isyml2 is symmetry of XLAMD2
87!     Isyml3 is symmetry of XLAMD3
88!
89      IMPLICIT NONE
90!
91      INTEGER LWORK, ISYMGD, ISYMM1, ISYML1, ISYML2
92      INTEGER KMGD, KMGD2, KEND1, LWRK1, IDEL, ISYMD
93      INTEGER ISYMJ, ISYMCI, ISYMI, ISYMC, ISYMG, ISYMGI, ISYMGJ, ISYMM2
94      INTEGER NVIRC, NBASG, NTOTD, NTOTGI, NTOTG
95      INTEGER KOFF1, KOFF2, KOFF3, IOPT, ISYML3
96!
97#if defined (SYS_CRAY)
98      REAL ZERO, HALF, ONE, TWO, THREEH
99      REAL XINT(*), OMEGA2(*), XLAMD1(*), XLAMD2(*), XLAMD3(*)
100      REAL SCRM(*), SCRM2(*), WORK(LWORK)
101#else
102      DOUBLE PRECISION ZERO, HALF, ONE, TWO, THREEH, FACT
103      DOUBLE PRECISION XINT(*), OMEGA2(*), XLAMD1(*), XLAMD2(*)
104      DOUBLE PRECISION XLAMD3(*), SCRM(*), SCRM2(*), WORK(LWORK)
105#endif
106!
107      PARAMETER(ZERO= 0.0D00, HALF= 0.5D00, ONE= 1.0D00, TWO= 2.0D00,
108     &          THREEH = 1.5D0*HALF)
109      DOUBLE PRECISION :: FACT2, FACT3
110!
111#include "priunit.h"
112#include "ccorb.h"
113#include "ccsdsym.h"
114!
115      CALL QENTER('CC_BF3')
116
117      FACT2 = 2.0D0
118      FACT3 =-1.0D0
119!
120!------------------------
121!     Dynamic allocation.
122!------------------------
123!
124      ISYMGD = MULD2H(ISYMM1,ISYML1)
125!
126      KMGD   = 1
127      KEND1  = KMGD   + NT2BGD(ISYMGD)
128      LWRK1  = LWORK  - KEND1
129
130      IF (IOPT .EQ. 2) THEN
131         KMGD2 = KEND1
132         KEND1 = KMGD2 + NT2BGD(ISYMGD)
133         LWRK1 = LWORK - KEND1
134      END IF
135!
136      IF (LWRK1 .LT. 0) THEN
137         WRITE(LUPRI,*) 'Need : ',KEND1,'Available : ',LWORK
138         CALL QUIT('Insufficient space in CC_BF3')
139      ENDIF
140!
141      D = IDEL - IBAS(ISYMD)
142      NTOTD = MAX(1,NBAS(ISYMD))
143!
144!-----------------------------
145!     Prepare the data arrays.
146!-----------------------------
147!
148      DO 100 ISYMJ = 1,NSYM
149!
150         ISYMCI = MULD2H(ISYMJ,ISYMM1)
151!
152         DO 110 ISYMI = 1,NSYM
153!
154            ISYMC  = MULD2H(ISYMI,ISYMCI)
155            ISYMG  = MULD2H(ISYMC,ISYML1)
156            ISYMGI = MULD2H(ISYMG,ISYMI)
157!
158            NVIRC = MAX(NVIR(ISYMC),1)
159            NBASG = MAX(NBAS(ISYMG),1)
160!
161            KOFF1 = IGLMVI(ISYMG,ISYMC) + 1
162!
163            DO 120 J = 1,NRHF(ISYMJ)
164!
165               KOFF2 = IT2BCD(ISYMCI,ISYMJ) + IT1AM(ISYMC,ISYMI)
166     *               + NT1AM(ISYMCI)*(J - 1) + 1
167               KOFF3 = IT2BGD(ISYMGI,ISYMJ) + IT1AO(ISYMG,ISYMI)
168     *               + NT1AO(ISYMGI)*(J - 1) + 1
169!
170               CALL DGEMM('N','N',NBAS(ISYMG),NRHF(ISYMI),NVIR(ISYMC),
171     *                    ONE,XLAMD1(KOFF1),NBASG,SCRM(KOFF2),NVIRC,
172     *                    ZERO,WORK(KOFF3),NBASG)
173!
174  120       CONTINUE
175!
176  110    CONTINUE
177
178         ISYMGI = MULD2H(ISYMCI,ISYML1)
179C        L(gamma,i)*C(delta,j)
180         IF ((IOPT .EQ.2) .AND. (ISYMGI .EQ. ISYML2)) THEN
181            KOFF1 = 1
182            KOFF2 = IGLMRH(ISYMD,ISYMJ) + D
183            KOFF3 = IT2BGD(ISYMGI,ISYMJ) + 1
184            NTOTGI = MAX(1,NT1AO(ISYMGI))
185            CALL DGER(NT1AO(ISYMGI),NRHF(ISYMJ),FACT2,
186     &                XLAMD2,1,XLAMD1(KOFF2),NTOTD,
187     &                WORK(KOFF3),NTOTGI)
188         END IF
189C
190         IF (IOPT.EQ.2) THEN
191C           C(gamma,j)*L(delta,i)
192            ISYMI = MULD2H(ISYML2,ISYMD)
193            ISYMG = MULD2H(ISYMGI,ISYMI)
194            NTOTG = MAX(1,NBAS(ISYMG))
195            DO J = 1, NRHF(ISYMJ)
196               KOFF1 = IGLMRH(ISYMG,ISYMJ)
197     &               + NBAS(ISYMG)*(J-1) + 1
198               KOFF2 = IGLMRH(ISYMD,ISYMI) + D
199               KOFF3 = IT2BGD(ISYMGI,ISYMJ)
200     &               + NT1AO(ISYMGI)*(J-1)
201     &               + IT1AO(ISYMG,ISYMI) + 1
202               CALL DGER(NBAS(ISYMG),NRHF(ISYMI),FACT3,
203     &                   XLAMD1(KOFF1),1,XLAMD2(KOFF2),NTOTD,
204     &                   WORK(KOFF3),NTOTG)
205            END DO
206C
207C           L(gamma,j)*C(delta,i)
208            ISYMI = MULD2H(ISYML1,ISYMD)
209            ISYMG = MULD2H(ISYMGI,ISYMI)
210            NTOTG = MAX(1,NBAS(ISYMG))
211            DO J = 1, NRHF(ISYMJ)
212               KOFF1 = IGLMRH(ISYMG,ISYMJ)
213     &               + NBAS(ISYMG)*(J-1) + 1
214               KOFF2 = IGLMRH(ISYMD,ISYMI) + D
215               KOFF3 = IT2BGD(ISYMGI,ISYMJ)
216     &               + NT1AO(ISYMGI)*(J-1)
217     &               + IT1AO(ISYMG,ISYMI) + 1
218               CALL DGER(NBAS(ISYMG),NRHF(ISYMI),FACT3,
219     &                   XLAMD2(KOFF1),1,XLAMD1(KOFF2),NTOTD,
220     &                   WORK(KOFF3),NTOTG)
221            END DO
222C
223         END IF
224!
225  100 CONTINUE
226!
227      IF (IOPT .EQ. 2) THEN
228!
229         DO ISYMJ = 1,NSYM
230!
231            ISYMCI = MULD2H(ISYMJ,ISYMM1)
232!
233            DO ISYMI = 1,NSYM
234!
235               ISYMC  = MULD2H(ISYMI,ISYMCI)
236               ISYMG  = MULD2H(ISYMC,ISYML1)
237               ISYMGI = MULD2H(ISYMG,ISYMI)
238!
239               NVIRC = MAX(NVIR(ISYMC),1)
240               NBASG = MAX(NBAS(ISYMG),1)
241!
242               KOFF1 = IGLMVI(ISYMG,ISYMC) + 1
243!
244               DO J = 1,NRHF(ISYMJ)
245!
246                  KOFF2 = IT2BCD(ISYMCI,ISYMJ) + IT1AM(ISYMC,ISYMI)
247     *                  + NT1AM(ISYMCI)*(J - 1) + 1
248                  KOFF3 = IT2BGD(ISYMGI,ISYMJ) + IT1AO(ISYMG,ISYMI)
249     *                  + NT1AO(ISYMGI)*(J - 1) + KMGD2
250!
251                  CALL DGEMM('N','N',NBAS(ISYMG),NRHF(ISYMI),
252     &                       NVIR(ISYMC),
253     *                       ONE,XLAMD1(KOFF1),NBASG,SCRM2(KOFF2),NVIRC,
254     *                       ZERO,WORK(KOFF3),NBASG)
255               END DO
256C
257            END DO
258            ISYMGI = MULD2H(ISYMCI,ISYML1)
259C           C(gamma,i)*L(delta,j)
260            IF ((IOPT .EQ.2) .AND. (ISYMGI .EQ. ISYML1)) THEN
261               KOFF1 = 1
262               KOFF2 = IGLMRH(ISYMD,ISYMJ) + D
263               KOFF3 = IT2BGD(ISYMGI,ISYMJ) + KMGD2
264               NTOTGI = MAX(1,NT1AO(ISYMGI))
265               CALL DGER(NT1AO(ISYMGI),NRHF(ISYMJ),FACT2,
266     &                   XLAMD1,1,XLAMD2(KOFF2),NTOTD,
267     &                   WORK(KOFF3),NTOTGI)
268            END IF
269C
270            IF (IOPT.EQ.2) THEN
271C              C(gamma,j)*L(delta,i)
272               ISYMI = MULD2H(ISYML2,ISYMD)
273               ISYMG = MULD2H(ISYMGI,ISYMI)
274               NTOTG = MAX(1,NBAS(ISYMG))
275               DO J = 1, NRHF(ISYMJ)
276                  KOFF1 = IGLMRH(ISYMG,ISYMJ)
277     &                  + NBAS(ISYMG)*(J-1) + 1
278                  KOFF2 = IGLMRH(ISYMD,ISYMI) + D
279                  KOFF3 = IT2BGD(ISYMGI,ISYMJ)
280     &                  + NT1AO(ISYMGI)*(J-1)
281     &                  + IT1AO(ISYMG,ISYMI) + KMGD2
282                  CALL DGER(NBAS(ISYMG),NRHF(ISYMI),FACT3,
283     &                      XLAMD1(KOFF1),1,XLAMD2(KOFF2),NTOTD,
284     &                      WORK(KOFF3),NTOTG)
285               END DO
286C
287C              L(gamma,j)*C(delta,i)
288               ISYMI = MULD2H(ISYML1,ISYMD)
289               ISYMG = MULD2H(ISYMGI,ISYMI)
290               NTOTG = MAX(1,NBAS(ISYMG))
291               DO J = 1, NRHF(ISYMJ)
292                  KOFF1 = IGLMRH(ISYMG,ISYMJ)
293     &                  + NBAS(ISYMG)*(J-1) + 1
294                  KOFF2 = IGLMRH(ISYMD,ISYMI) + D
295                  KOFF3 = IT2BGD(ISYMGI,ISYMJ)
296     &                  + NT1AO(ISYMGI)*(J-1)
297     &                  + IT1AO(ISYMG,ISYMI) + KMGD2
298                  CALL DGER(NBAS(ISYMG),NRHF(ISYMI),FACT3,
299     &                      XLAMD2(KOFF1),1,XLAMD1(KOFF2),NTOTD,
300     &                      WORK(KOFF3),NTOTG)
301C
302               END DO
303            END IF
304!
305         END DO !ISYMJ
306      END IF
307!
308!---------------------------------------------------------
309!     Calculate extra contribution to T2 double AO transf.
310!     if F-matrix transformation.
311!---------------------------------------------------------
312!
313      IF (IOPT .EQ. 4) THEN
314!
315         IF (MULD2H(ISYML3,ISYMM2).NE.ISYMGD) THEN
316            CALL QUIT('CC_BF: Symmetry mismatch')
317         ENDIF
318         DO 200 ISYMJ = 1,NSYM
319!
320            ISYMCI = MULD2H(ISYMJ,ISYMM2)
321!
322            DO 210 ISYMI = 1,NSYM
323!
324               ISYMC  = MULD2H(ISYMI,ISYMCI)
325               ISYMG  = MULD2H(ISYMC,ISYML3)
326               ISYMGI = MULD2H(ISYMG,ISYMI)
327!
328               NVIRC = MAX(NVIR(ISYMC),1)
329               NBASG = MAX(NBAS(ISYMG),1)
330!
331               KOFF1 = IGLMVI(ISYMG,ISYMC) + 1
332!
333                  DO 220 J = 1,NRHF(ISYMJ)
334!
335                  KOFF2 = IT2BCD(ISYMCI,ISYMJ) + IT1AM(ISYMC,ISYMI)
336     *                  + NT1AM(ISYMCI)*(J - 1) + 1
337                  KOFF3 = IT2BGD(ISYMGI,ISYMJ) + IT1AO(ISYMG,ISYMI)
338     *                  + NT1AO(ISYMGI)*(J - 1) + 1
339!
340                  CALL DGEMM('N','N',NBAS(ISYMG),NRHF(ISYMI),NVIR(ISYMC)
341     *                      ,ONE,XLAMD3(KOFF1),NBASG,SCRM2(KOFF2),NVIRC,
342     *                       ONE,WORK(KOFF3),NBASG)
343!
344  220          CONTINUE
345!
346  210       CONTINUE
347!
348  200    CONTINUE
349!
350      ENDIF
351!
352!--------------------------------
353!     Calculate the contribution.
354!--------------------------------
355!
356      CALL CC_BF31(XINT,OMEGA2,WORK(KMGD),WORK(KMGD2),ISYMGD,
357     *             XLAMD1,ISYML1,
358     *             XLAMD2,ISYML2,WORK(KEND1),LWRK1,
359     *             IDEL,ISYMD,IOPT)
360!
361      CALL QEXIT('CC_BF3')
362!
363      RETURN
364      END
365C  /* Deck cc_bf3_1 */
366      SUBROUTINE CC_BF31(XINT,OMEGA2,XMGD,XMGD2,ISYMGD,XLAMD1,ISYML1,
367     *                   XLAMD2,ISYML2,WORK,LWORK,
368     *                   IDEL,ISYMD,IOPT)
369!
370!     Written by Henrik Koch 3-Jan-1994
371!
372!     Purpose: Calculate B-term.
373!
374!     See CC_BF for more info.
375!
376      IMPLICIT NONE
377!
378#include "priunit.h"
379#include "iratdef.h"
380#include "ccorb.h"
381#include "ccsdsym.h"
382#include "ccsdinp.h"
383!
384      INTEGER LWORK, INDEX, ISYDIS, ISYMD, ISYRES, ISYMGD, ISYCH
385      INTEGER ISYML2, ISYML1, ISYMIJ, ISYMAB, ISYMG, IDEL, KSCRAB
386      INTEGER KINDV1, KINDV2, KEND1, LWRK1, NSIZE, IMAXG, NMAXG
387      INTEGER NBATCH, IBATCH, NUMG, IG1, IG2, KINTP, KINTM
388      INTEGER KT2MP, KT2MM, KEND2, LWRK2
389      INTEGER IOPT, ISHELP, KOFF, KOFF1, KOFF2, NUMGM, NTOTAB
390      INTEGER LT2MM
391!
392#if defined (SYS_CRAY)
393      REAL ZERO, HALF, ONE, FOURTH, TWO, THREE
394      REAL XTWO, XHALF, XONE, FACT
395      REAL XINT(*), OMEGA2(*), XMGD(*), XMGD2(*),XLAMD1(*), XLAMD2(*)
396      REAL WORK(LWORK)
397#else
398      DOUBLE PRECISION ZERO, HALF, ONE, FOURTH, TWO
399      DOUBLE PRECISION THREE, XTWO, XHALF, XONE, FACT
400      DOUBLE PRECISION XINT(*), OMEGA2(*), XMGD(*), XMGD2(*),XLAMD1(*)
401      DOUBLE PRECISION XLAMD2(*), WORK(LWORK)
402#endif
403      PARAMETER(ZERO = 0.0D00, HALF = 0.5D00, ONE = 1.0D00)
404      PARAMETER(FOURTH = 0.25D00, TWO = 2.0D00, THREE = 3.0D00)
405      PARAMETER(XTWO = -2.0D00, XHALF= -0.5D00, XONE= -1.0D00)
406!
407      INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J
408!
409      CALL QENTER('CC_BF31')
410!
411      ISYDIS = MULD2H(ISYMOP,ISYMD)
412      ISYRES = MULD2H(ISYDIS,ISYMGD)
413      ISYCH  = MULD2H(ISYML2,ISYMD)
414!
415      IF (ISYML1 .NE. 1)
416     &     CALL QUIT('CC_BF3: Symmetry of XLAMD1 must be 1')
417      IF (ISYML2 .NE. MULD2H(ISYMGD,ISYMD))
418     *            CALL QUIT('Symmetry mismatch in CC_BF3_1')
419!
420!================================
421!     Calculate the contribution.
422!================================
423!
424      DO 100 ISYMIJ = 1 , NSYM
425C
426         ISYMAB = MULD2H(ISYMIJ,ISYRES)
427         ISYMG  = MULD2H(ISYMAB,ISYDIS)
428         D      = IDEL - IBAS(ISYMD)
429C
430         KSCRAB = 1
431         KINDV1 = KSCRAB + N2BST(ISYMAB)
432         KINDV2 = KINDV1 + (NNBST(ISYMAB) - 1)/IRAT + 1
433         KEND1  = KINDV2 + (NNBST(ISYMAB) - 1)/IRAT + 1
434         LWRK1  = LWORK  - KEND1
435C
436         IF (LWRK1 .LT. 0) THEN
437            CALL QUIT('Insufficient space in CC_BF3_1')
438         ENDIF
439C
440C--------------------------------
441C        Calculate index vectors.
442C--------------------------------
443C
444         CALL CCSD_INDEX(WORK(KINDV1),WORK(KINDV2),ISYMAB)
445C
446C------------------------------
447C        Work space allocation.
448C------------------------------
449C
450         IF (IOPT.EQ.2) THEN
451            NSIZE = 2*NNBST(ISYMAB) + NMIJP(ISYMIJ) + NMATIJ(ISYMIJ)
452         ELSE
453            NSIZE = 2*(NNBST(ISYMAB) + NMIJP(ISYMIJ))
454         END IF
455C
456         IF ((NNBST(ISYMAB) .EQ. 0) .OR.
457     *       (NMIJP(ISYMIJ) .EQ. 0)) GOTO 100
458C
459         IF (ISYMG .EQ. ISYMD) THEN
460            IMAXG = D
461         ELSE IF (ISYMG .LT. ISYMD) THEN
462            IMAXG = NBAS(ISYMG)
463         ELSE
464            GOTO 100
465         ENDIF
466C
467         IF (IMAXG.EQ.0) GOTO 100
468C
469         IF (LWRK1.LT.NSIZE) THEN
470           CALL QUIT('Insufficient memory in CC_BF1.')
471         END IF
472C
473         NMAXG  = MIN(IMAXG,LWRK1/NSIZE)
474         NBATCH = (IMAXG - 1)/NMAXG + 1
475C
476         DO 110 IBATCH = 1 , NBATCH
477C
478            NUMG = NMAXG
479            IF (IBATCH .EQ. NBATCH) THEN
480               NUMG = IMAXG - NMAXG*(NBATCH - 1)
481            ENDIF
482C
483            IG1 = NMAXG*(IBATCH - 1) + 1
484            IG2 = NMAXG*(IBATCH - 1) + NUMG
485C
486            IF (IOPT.EQ.2) THEN
487               LT2MM = NUMG*NMATIJ(ISYMIJ)
488            ELSE
489               LT2MM = NUMG*NMIJP(ISYMIJ)
490            END IF
491C
492            KINTP = KEND1
493            KINTM = KINTP + NNBST(ISYMAB)*NUMG
494            KT2MP = KINTM + NNBST(ISYMAB)*NUMG
495            KT2MM = KT2MP + NUMG*NMIJP(ISYMIJ)
496            KEND2 = KT2MM + LT2MM
497            LWRK2 = LWORK - KEND2
498C
499            IF (LWRK2 .LT. 0) THEN
500               CALL QUIT('Insufficient space in CC_BF31')
501            ENDIF
502C
503C-----------------------------------
504C           Construct T2MP and T2MM.
505C-----------------------------------
506C
507            IF (IOPT.NE.2) THEN
508                CALL CC_T2MP_T2MM()
509            ELSE
510                CALL CC_T2MP_T2MM3(XMGD,XMGD2,WORK(KT2MP),WORK(KT2MM),
511     &                             ISYMIJ,ISYMG,NUMG,IG1)
512            ENDIF
513
514C
515C-----------------------------------
516C           Construct INTP and INTM.
517C-----------------------------------
518C
519            CALL CCRHS_IPM(XINT,WORK(KINTP),WORK(KINTM),WORK(KSCRAB),
520     *                     WORK(KINDV1),WORK(KINDV2),ISYMAB,ISYMG,
521     *                     NUMG,IG1,IG2)
522C
523C-------------------------------
524C           Scale the diagonals.
525C-------------------------------
526C
527            IF ((ISYMG .EQ. ISYMD) .AND. (IBATCH .EQ. NBATCH)) THEN
528               KOFF = KINTP + NNBST(ISYMAB)*(NUMG - 1)
529               CALL DSCAL(NNBST(ISYMAB),HALF,WORK(KOFF),1)
530            ENDIF
531C
532C----------------------------------------
533C           Add the B-term contributions.
534C----------------------------------------
535C
536            NUMGM  = MAX(NUMG,1)
537            NTOTAB = MAX(NNBST(ISYMAB),1)
538C
539            IF (IOPT.EQ.2) THEN
540               KOFF1 = IT2ORT(ISYMAB,ISYMIJ) + 1
541               KOFF2 = NT2ORT(ISYRES) + IT2ORT3(ISYMAB,ISYMIJ) + 1
542
543               CALL DGEMM('N','N',NNBST(ISYMAB),NMIJP(ISYMIJ),NUMG,
544     *                    ONE,WORK(KINTP),NTOTAB,WORK(KT2MP),NUMGM,
545     *                    ONE,OMEGA2(KOFF1),NTOTAB)
546
547               CALL DGEMM('N','N',NNBST(ISYMAB),NMATIJ(ISYMIJ),NUMG,
548     *                    ONE,WORK(KINTM),NTOTAB,WORK(KT2MM),NUMGM,
549     *                    ONE,OMEGA2(KOFF2),NTOTAB)
550
551            ELSE IF (.NOT. (IOPT .EQ. 5)) THEN
552!
553               KOFF = IT2ORT(ISYMAB,ISYMIJ) + 1
554!
555               CALL DGEMM('N','N',NNBST(ISYMAB),NMIJP(ISYMIJ),NUMG,
556     *                    ONE,WORK(KINTM),NTOTAB,WORK(KT2MM),NUMGM,
557     *                    ONE,OMEGA2(KOFF),NTOTAB)
558!
559            ELSE
560               KOFF1 = IT2ORT(ISYMAB,ISYMIJ) + 1
561!
562               CALL DGEMM('N','N',NNBST(ISYMAB),NMIJP(ISYMIJ),NUMG,
563     *                    ONE,WORK(KINTM),NTOTAB,WORK(KT2MP),NUMGM,
564     *                    ONE,OMEGA2(KOFF1),NTOTAB)
565!
566               KOFF2 = NT2ORT(ISYRES) + IT2ORT(ISYMAB,ISYMIJ) + 1
567!
568               CALL DGEMM('N','N',NNBST(ISYMAB),NMIJP(ISYMIJ),NUMG,
569     *                    ONE,WORK(KINTP),NTOTAB,WORK(KT2MM),NUMGM,
570     *                    ONE,OMEGA2(KOFF2),NTOTAB)
571!
572            END IF
573  110    CONTINUE
574!
575  100 CONTINUE
576!
577      CALL QEXIT('CC_BF31')
578!
579      RETURN
580      CONTAINS
581         SUBROUTINE CC_T2MP_T2MM()
582C-------------------------------------------------------
583C           Creates the plus and minus versions of
584C           the back transformed plus and minus vectors
585C-------------------------------------------------------
586
587            INTEGER :: NGIJ, NGJI, NTOTI, NIJ, NGIJPM
588            INTEGER :: KOFFP, KOFFM, KOFF1, KOFF2, ISHELP
589            INTEGER :: ISYMI, ISYMJ, ISYMGI, ISYMGJ
590            INTEGER :: I,J
591            DOUBLE PRECISION :: FACT
592
593            DO 200 ISYMJ = 1 , NSYM
594C
595               ISYMI  = MULD2H(ISYMJ,ISYMIJ)
596               ISYMGI = MULD2H(ISYMI,ISYMG)
597               ISYMGJ = MULD2H(ISYMJ,ISYMG)
598C
599               IF (ISYMI .GT. ISYMJ) GOTO 200
600C
601               NTOTI = NRHF(ISYMI)
602C
603               DO 210 J = 1 , NRHF(ISYMJ)
604C
605                  IF (ISYMI .EQ. ISYMJ) NTOTI = J
606C
607                  DO 220 I = 1,NTOTI
608C
609                     NGIJ = IT2BGD(ISYMGI,ISYMJ)
610     *                    + NT1AO(ISYMGI)*(J - 1)
611     *                    + IT1AO(ISYMG,ISYMI)
612     *                    + NBAS(ISYMG)*(I - 1) + IG1
613C
614                     NGJI = IT2BGD(ISYMGJ,ISYMI)
615     *                    + NT1AO(ISYMGJ)*(I - 1)
616     *                    + IT1AO(ISYMG,ISYMJ)
617     *                    + NBAS(ISYMG)*(J - 1) + IG1
618C
619                     IF (ISYMI .EQ. ISYMJ) THEN
620                        NIJ = IMIJP(ISYMI,ISYMJ) + INDEX(I,J)
621                     ELSE
622                        NIJ = IMIJP(ISYMI,ISYMJ)
623     *                      + NRHF(ISYMI)*(J - 1) + I
624                     ENDIF
625C
626                     NGIJPM = NUMG*(NIJ - 1)
627C
628                     KOFFP = KT2MP + NGIJPM
629                     KOFFM = KT2MM + NGIJPM
630C
631C
632                        IF (IOPT .NE. 6) THEN
633                           CALL DCOPY(NUMG,XMGD(NGIJ),1,WORK(KOFFP),1)
634                        ENDIF
635!
636                        CALL DCOPY(NUMG,XMGD(NGIJ),1,WORK(KOFFM),1)
637C
638                        IF (IOPT .NE. 6) THEN
639                         CALL DAXPY(NUMG,ONE,XMGD(NGJI),1,WORK(KOFFP),1)
640                        ENDIF
641!
642                        CALL DAXPY(NUMG,-ONE,XMGD(NGJI),1,WORK(KOFFM),1)
643!
644C
645C-------------------------------------------------
646C                    Add the F-term contributions.
647C-------------------------------------------------
648C
649                     FACT = ONE
650C
651                     IF ((IOPT .EQ. 2) .OR. (IOPT .EQ. 4)) THEN
652                        FACT = THREE
653                     ENDIF
654C
655                     IF ((ISYMJ .EQ. ISYCH).AND.(ISYMI .EQ. ISYMG)) THEN
656C
657                        KOFF1 = IGLMRH(ISYMD,ISYMJ)
658     &                        + NBAS(ISYMD)*(J - 1) + D
659                        KOFF2 = ILMRHF(ISYMI) + NBAS(ISYMG)*(I - 1) +IG1
660C
661                        IF (IOPT .EQ. 5) THEN
662!
663                           CALL DAXPY(NUMG,XHALF*XLAMD2(KOFF1),
664     *                                XLAMD1(KOFF2),1,WORK(KOFFP),1)
665                           CALL DAXPY(NUMG,XHALF*XLAMD2(KOFF1),
666     &                                XLAMD1(KOFF2),1,WORK(KOFFM),1)
667                        ELSE
668!
669                           IF (IOPT .NE. 6) THEN
670                            CALL DAXPY(NUMG,XLAMD2(KOFF1),XLAMD1(KOFF2),
671     &                                 1,WORK(KOFFP),1)
672                           ENDIF
673!
674                           CALL DAXPY(NUMG,FACT*XLAMD2(KOFF1),
675     &                                XLAMD1(KOFF2),1,WORK(KOFFM),1)
676!
677                        ENDIF
678C
679                     ENDIF
680C
681                     IF ((ISYMI .EQ. ISYCH).AND.(ISYMJ .EQ. ISYMG)) THEN
682C
683                        KOFF1 = IGLMRH(ISYMD,ISYMI)
684     &                        + NBAS(ISYMD)*(I - 1) + D
685                        KOFF2 = ILMRHF(ISYMJ) + NBAS(ISYMG)*(J - 1) +IG1
686C
687                        IF (IOPT .EQ. 5) THEN
688!
689                           CALL DAXPY(NUMG,XHALF*XLAMD2(KOFF1),
690     *                                XLAMD1(KOFF2),1,WORK(KOFFP),1)
691                           CALL DAXPY(NUMG,HALF*XLAMD2(KOFF1),
692     *                                XLAMD1(KOFF2),1,WORK(KOFFM),1)
693!
694                        ELSE
695!
696                           IF (IOPT .NE. 6) THEN
697                            CALL DAXPY(NUMG,XLAMD2(KOFF1),XLAMD1(KOFF2),
698     *                                 1,WORK(KOFFP),1)
699                           ENDIF
700!
701                           CALL DAXPY(NUMG,-FACT*XLAMD2(KOFF1),
702     *                                XLAMD1(KOFF2),1,WORK(KOFFM),1)
703C
704                        ENDIF
705!
706                     ENDIF
707C
708C---------------------------------------------------------------------
709C                    For response calculation add permuted terms.
710C---------------------------------------------------------------------
711C
712                     IF (IOPT .GE. 2) THEN
713C
714                        ISHELP = MULD2H(ISYMG,ISYML2)
715C
716                        IF ((IOPT .EQ. 2) .OR. (IOPT .EQ. 4)) THEN
717                           FACT = THREE
718                        ENDIF
719C
720                        IF ((ISYMJ .EQ. ISYMD) .AND.
721     &                      (ISYMI .EQ. ISHELP)) THEN
722C
723                           KOFF1 = ILMRHF(ISYMJ)
724     &                           + NBAS(ISYMD)*(J - 1) + D
725                           KOFF2 = IGLMRH(ISYMG,ISYMI)
726     &                           + NBAS(ISYMG)*(I - 1) +IG1
727C
728                           IF (IOPT .EQ. 5) THEN
729C
730                              CALL DAXPY(NUMG,HALF*XLAMD1(KOFF1),
731     &                                XLAMD2(KOFF2),1,WORK(KOFFP),1)
732                              CALL DAXPY(NUMG,HALF*XLAMD1(KOFF1),
733     &                                XLAMD2(KOFF2),1,WORK(KOFFM),1)
734C
735                           ELSE
736C
737                              IF (IOPT .NE. 6) THEN
738                                 CALL DAXPY(NUMG,XLAMD1(KOFF1),
739     &                                   XLAMD2(KOFF2),1,WORK(KOFFP),1)
740                              ENDIF
741!
742                              CALL DAXPY(NUMG,FACT*XLAMD1(KOFF1),
743     &                                XLAMD2(KOFF2),1,WORK(KOFFM),1)
744C
745                           ENDIF
746C
747                        ENDIF
748C
749                        IF ((ISYMI .EQ. ISYMD) .AND.
750     &                      (ISYMJ .EQ. ISHELP)) THEN
751C
752                           KOFF1 = ILMRHF(ISYMI)
753     &                           + NBAS(ISYMD)*(I - 1) + D
754                           KOFF2 = IGLMRH(ISYMG,ISYMJ)
755     &                           + NBAS(ISYMG)*(J - 1) + IG1
756C
757                           IF (IOPT .EQ. 5) THEN
758C
759                              CALL DAXPY(NUMG,HALF*XLAMD1(KOFF1),
760     &                                XLAMD2(KOFF2),1,WORK(KOFFP),1)
761                              CALL DAXPY(NUMG,XHALF*XLAMD1(KOFF1),
762     &                                XLAMD2(KOFF2),1,WORK(KOFFM),1)
763C
764                           ELSE
765C
766                              IF (IOPT .NE. 6) THEN
767                                 CALL DAXPY(NUMG,XLAMD1(KOFF1),
768     &                                   XLAMD2(KOFF2),1,WORK(KOFFP),1)
769                              ENDIF
770!
771                              CALL DAXPY(NUMG,-FACT*XLAMD1(KOFF1),
772     &                                XLAMD2(KOFF2),1,WORK(KOFFM),1)
773C
774                           ENDIF
775C
776                        ENDIF
777C
778                     ENDIF
779C
780  220             CONTINUE
781C
782  210          CONTINUE
783C
784  200       CONTINUE
785         END SUBROUTINE
786
787         SUBROUTINE CC_T2MP_T2MM3(XMGD,XMGD2,T2P,T2M,
788     &                            ISYMIJ,ISYMG,NUMG,IG1)
789C-------------------------------------------------------
790C           Creates the plus and minus versions of
791C           the back transformed plus and minus vectors
792C           In the case that + and - triplets are treated
793C           simultaniously.
794C-------------------------------------------------------
795
796            DOUBLE PRECISION, INTENT(IN) :: XMGD(*), XMGD2(*)
797            DOUBLE PRECISION, INTENT(OUT):: T2P(*), T2M(*)
798            INTEGER, INTENT(IN) :: ISYMG, ISYMIJ, NUMG, IG1
799
800            INTEGER :: IGIJ, IGJI
801            INTEGER :: NGIJ, NGJI, NTOTI
802            INTEGER :: NIJT, NIJS, NJIS, NG
803            INTEGER :: KOFFP, KOFFM1, KOFFM2, ISHELP
804            INTEGER :: ISYMI, ISYMJ, ISYMGI, ISYMGJ
805            INTEGER :: I, J
806C
807            DOUBLE PRECISION :: FACT1, FACT2
808
809            DO 200 ISYMJ = 1 , NSYM
810C
811               ISYMI  = MULD2H(ISYMJ,ISYMIJ)
812               ISYMGI = MULD2H(ISYMI,ISYMG)
813               ISYMGJ = MULD2H(ISYMJ,ISYMG)
814C
815               IF (ISYMI .GT. ISYMJ) GOTO 200
816C
817               NTOTI = NRHF(ISYMI)
818C
819               DO 210 J = 1 , NRHF(ISYMJ)
820C
821                  IF (ISYMI .EQ. ISYMJ) NTOTI = J
822C
823                  DO 220 I = 1, NTOTI
824C
825                     IGIJ = IT2BGD(ISYMGI,ISYMJ)
826     *                    + NT1AO(ISYMGI)*(J - 1)
827     *                    + IT1AO(ISYMG,ISYMI)
828     *                    + NBAS(ISYMG)*(I - 1) + IG1 - 1
829C
830                     IGJI = IT2BGD(ISYMGJ,ISYMI)
831     *                    + NT1AO(ISYMGJ)*(I - 1)
832     *                    + IT1AO(ISYMG,ISYMJ)
833     *                    + NBAS(ISYMG)*(J - 1) + IG1 - 1
834C
835                     IF (ISYMI .EQ. ISYMJ) THEN
836                        NIJT = IMIJP(ISYMI,ISYMJ) + J*(J-1)/2 + I
837                     ELSE
838                        NIJT = IMIJP(ISYMI,ISYMJ)
839     *                       + NRHF(ISYMI)*(J - 1) + I
840                     ENDIF
841
842                     NIJS = IMATIJ(ISYMI,ISYMJ) + NRHF(ISYMI)*(J-1) + I
843                     NJIS = IMATIJ(ISYMJ,ISYMI) + NRHF(ISYMJ)*(I-1) + J
844C
845                     KOFFP  = NUMG*(NIJT-1)
846                     KOFFM1 = NUMG*(NIJS-1)
847                     KOFFM2 = NUMG*(NJIS-1)
848C
849                     DO NG = 1, NUMG
850                        NGIJ = IGIJ + NG
851                        NGJI = IGJI + NG
852                        T2P(KOFFP+NG)  = XMGD(NGIJ) + XMGD2(NGJI)
853                        T2M(KOFFM1+NG) = XMGD(NGIJ) - XMGD2(NGJI)
854                     END DO
855C
856                     IF ( IGIJ .NE. IGJI ) THEN
857                        DO NG = 1, NUMG
858                           NGIJ = IGIJ + NG
859                           NGJI = IGJI + NG
860                           T2M(KOFFM2+NG) = XMGD(NGJI) - XMGD2(NGIJ)
861                        END DO
862                     END IF
863C
864C
865  220             CONTINUE
866C
867  210          CONTINUE
868C
869  200       CONTINUE
870         END SUBROUTINE
871
872      END
873C  /* Deck ccrhs_d3 */
874      SUBROUTINE CCRHS_D3(XINT,DSRHF,OMEGA2,T2AM,ISYMT2,
875     *                    XLAMDP,XLAMIP,XLAMDH,
876     *                    XLAMPC,ISYMPC,XLAMHC,ISYMHC,
877     *                    SCRM,WORK,LWORK,IDEL,ISYMD,FACTD,ICON,
878     *                    LUD,DFIL,IV)
879!
880!     Written by Henrik Koch 9-Jan-1994
881!
882!     Generalisation for CCLR by Ove Christiansen august-september 1995
883!     (right transformation) and september 1996 (F-matrix).
884!
885!     Generalisation to calculate the D-intermediates for the
886!     triplet case by Kasper Hald 17-2-1999
887!
888!     Purpose: Calculate D-term.
889!
890      IMPLICIT NONE
891!
892      INTEGER LWORK, ISYDIS, ISYAIK, ISYMPC, ISYMT2, KSCR1, KSCR2
893      INTEGER KSCR3, KEND1, LWRK1, ISYMD, INDEX, ISYMHC, LUD, IV
894      INTEGER KOFF1, ISYML, ISYMA, ISYMG
895      INTEGER NBASA, NBASG, NVIRD, KSCR11, KEND2, LWRK2, KOFF2
896      INTEGER KOFF3, KOFF5, KOFF6, NRHFK, ISYMAI, NTOTDL
897      INTEGER IOFF, IDEL, IERR, ICON
898!
899#if defined (SYS_CRAY)
900      REAL ONE, TWO, FACTD
901      REAL XINT(*), DSRHF(*), OMEGA2(*), WORK(LWORK)
902      REAL XLAMDP(*), XLAMIP(*), XLAMDH(*), SCRM(*)
903      REAL XLAMPC(*), XLAMHC(*), T2AM(*)
904#else
905      DOUBLE PRECISION ONE, TWO, FACTD
906      DOUBLE PRECISION XINT(*), DSRHF(*), OMEGA2(*), WORK(LWORK)
907      DOUBLE PRECISION XLAMDP(*), XLAMIP(*), XLAMDH(*), SCRM(*)
908      DOUBLE PRECISION XLAMPC(*), XLAMHC(*), T2AM(*)
909#endif
910!
911      PARAMETER (ONE = 1.0D00, TWO = 2.0D00)
912      CHARACTER DFIL*(*)
913!
914#include "priunit.h"
915#include "ccorb.h"
916#include "ccsdsym.h"
917#include "ccsdinp.h"
918!
919      CALL QENTER('CCRHS_D3')
920!
921      ISYDIS = MULD2H(ISYMD,ISYMOP)
922      ISYAIK = MULD2H(ISYDIS,ISYMPC)
923      IF (ISYMT2 .NE. ISYMPC) CALL QUIT('Symmetry Mismatch in CCRHS_D3')
924C
925C------------------------
926C     Dynamic allocation.
927C------------------------
928C
929      KSCR1  = 1
930      KSCR2  = KSCR1  + MAX(NT2BCD(ISYAIK),NT2BCD(ISYDIS))
931      KSCR3  = KSCR2  + NT2BGD(ISYDIS)
932      IF (ICON .EQ. 2) THEN
933         KEND1  = KSCR3  + NT2BGD(ISYMD)
934      ELSE IF (ICON .EQ.5) THEN
935         KEND1  = KSCR3 + MAX(NT2BGD(ISYMD),NT2BCD(ISYAIK),
936     *                        NT2BCD(ISYDIS))
937      ELSE
938         KEND1  = KSCR3  + NT2BGD(ISYAIK)
939      ENDIF
940      LWRK1  = LWORK  - KEND1
941C
942      IF (LWRK1 .LT. 0) THEN
943         WRITE(LUPRI,*) 'Need : ',KEND1,'Available : ',LWORK
944         CALL QUIT('Insufficient space in CCRHS_D3')
945      ENDIF
946C
947C--------------------------------
948C     Calculate the contribution.
949C--------------------------------
950C
951      CALL CCRHS_D31(XINT,DSRHF,OMEGA2,T2AM,ISYMT2,
952     *                SCRM,WORK(KSCR1),WORK(KSCR2),
953     *                WORK(KSCR3),XLAMDP,XLAMIP,
954     *                XLAMDH,XLAMPC,ISYMPC,XLAMHC,ISYMHC,
955     *                WORK(KEND1),LWRK1,ISYDIS,IDEL,
956     *                ISYMD,FACTD,ICON,LUD,DFIL,IV)
957C
958      CALL QEXIT('CCRHS_D3')
959C
960      RETURN
961      END
962      SUBROUTINE CCRHS_D31(XINT,DSRHF,OMEGA2,T2AM,ISYMT2,
963     *                      SCRM,SCR1,SCR2,SCR3,
964     *                      XLAMDP,XLAMIP,XLAMDH,XLAMPC,ISYMPC,XLAMHC,
965     *                      ISYMHC,WORK,LWORK,ISYDIS,IDEL,ISYDEL,FACTD,
966     *                      ICON,LUD,DFIL,IV)
967C
968C     Written by Henrik Koch 3-Jan-1994
969C
970C     Modification by Ove Christiansen 25-7-1995 to allow for a
971C     general factor (FACTD). NB: Assumes DUMCD.
972C     - calculate intermediates for CCLR.
973C
974C     29-9-1995 (17-9-1996 F-matrix.) Ove Christiansen:
975C
976C                 1. If Icon = 2 both contributions are calculated,
977C                    for total sym. case. Otherwise
978C                    a.ICON = 1 only the integral Laikc(del)
979C                               = La-bar,i,k,c + La,i-bar,k,c
980C                      for Jacobian right transformation
981C                    b.ICON = 3
982C                          La-bar,i,k,c + La,i-bar,k,c + Tx*Int
983C                      for F-matrix times vector.
984C
985C                 2. Allow for general transformation matrix for
986C                    alpha to a(XLAMPC) and for i (XLAMHC).
987C                    (the extra i transformation introduces new
988C                     blocks which is only entered when icon = 1 or 3)
989C
990C                 3. If icon diff. from 2 (we have linear response)
991C                    The D intermediate is stored according to
992C                    the number of simultaneous trial vector
993C                    given by IV. This is ensured using IT2DLR.
994C
995!     17-2-1999 Kasper Hald:
996!
997!     IF ICON = 4 then the triplet intermediate:
998!
999!     g(a-bar,i,l,c) + g(a,i-bar,l,c) is calculated
1000!
1001!     IF ICON = 5 then the triplet intermediate:
1002!
1003!     g(aikc) + sum(dl)t(ai,dl)L(kcld) - sum(dl)t(di,al)g(ldkc)
1004!
1005!     ICON 6: g(a-bar,i,l,c) - g(a,i-bar,l,c)
1006!
1007!     ICON 4, ICON 5 and ICON 6 assumes DUMPCD
1008!
1009!     Purpose: Calculate D-term.
1010!
1011      IMPLICIT NONE
1012!
1013#include "priunit.h"
1014#include "maxorb.h"
1015#include "ccorb.h"
1016#include "symsq.h"
1017#include "ccsdsym.h"
1018#include "ccsdio.h"
1019!
1020      INTEGER LWORK, ICON, ISYMK, ISYMAG, ISYMDL, KSCR10, KEND1
1021      INTEGER LWRK1, KOFF1, ISYML, ISYMD, ISYMA, ISYMG
1022      INTEGER NBASA, NBASG, NVIRD, KSCR11, KEND2, LWRK2, KOFF2
1023      INTEGER KOFF3, KOFF5, KOFF6, INDEX, ISYAIK, ISYDIS, ISYMPC
1024      INTEGER NRHFK, ISYMAI, NTOTDL, IOFF, IERR, ISYMBG
1025      INTEGER ISYMI, ISYMB, NBASB, KSCR12, NAI, KOFF7, KOFF8
1026      INTEGER ISYMHC, ISALIK, ISYALG, ISYALI, NT1AOM, ISYMAL
1027      INTEGER NBASAL, KOFF4, MAI, ISYMBJ, ISYDEL, ISYMJ, NVIRB
1028      INTEGER NTOTBJ, NBJ, NAIBJ, MALI, IV, IDEL, ISYM5, IOPT5
1029      INTEGER ISYMT2, LUD
1030!
1031#if defined (SYS_CRAY)
1032      REAL ZERO, ONE, HALF, XMHALF, TWO, XMONE, FACTD
1033      REAL XINT(*), OMEGA2(*), T2AM(*), DSRHF(*), SCRM(*)
1034      REAL SCR1(*), SCR2(*), SCR3(*), XLAMDP(*), XLAMIP(*), XLAMDH(*)
1035      REAL XLAMPC(*), XLAMHC(*), WORK(LWORK)
1036#else
1037      DOUBLE PRECISION ZERO, ONE, HALF, XMHALF, TWO, XMONE, FACTD
1038      DOUBLE PRECISION XINT(*), OMEGA2(*), T2AM(*), DSRHF(*), SCRM(*)
1039      DOUBLE PRECISION SCR1(*), SCR2(*), SCR3(*), XLAMDP(*), XLAMIP(*)
1040      DOUBLE PRECISION XLAMDH(*), XLAMPC(*), XLAMHC(*), WORK(LWORK)
1041#endif
1042      PARAMETER(ZERO=0.0D00,ONE=1.0D00,HALF=0.5D00,XMHALF=-0.5D00)
1043      PARAMETER(TWO=2.0D00, XMONE=-1.0D00)
1044      CHARACTER DFIL*(*)
1045C
1046      INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J
1047C
1048      CALL QENTER('CCRHS_D31')
1049C
1050      ISYAIK = MULD2H(ISYDIS,ISYMPC)
1051C
1052C-------------------------------------------------------
1053C     Calculate the integrals K(k,dl) = (k d | l delta).
1054C-------------------------------------------------------
1055C
1056      IF ((ICON .EQ. 2) .OR. (ICON .EQ. 3) .OR. (ICON .EQ. 5)) THEN
1057C
1058         DO 100 ISYMK = 1,NSYM
1059C
1060            ISYMAG = MULD2H(ISYMK,ISYDIS)
1061C
1062            DO 110 K = 1,NRHF(ISYMK)
1063C
1064               ISYMDL = MULD2H(ISYMK,ISYDIS)
1065C
1066               KSCR10 = 1
1067               KEND1  = KSCR10 + N2BST(ISYMAG)
1068               LWRK1  = LWORK  - KEND1
1069C
1070               IF (LWRK1 .LT. 0) THEN
1071                  CALL QUIT('Not enough space for '//
1072     &                 'allocation in CCRHS_D31(1)')
1073               END IF
1074C
1075               KOFF1 = IDSRHF(ISYMAG,ISYMK) + NNBST(ISYMAG)*(K-1) + 1
1076               CALL CCSD_SYMSQ(DSRHF(KOFF1),ISYMAG,WORK(KSCR10))
1077C
1078               DO 120 ISYML = 1,NSYM
1079C
1080                  ISYMD = MULD2H(ISYML,ISYMDL)
1081                  ISYMA = ISYML
1082                  ISYMG = ISYMD
1083C
1084                  NBASA = MAX(NBAS(ISYMA),1)
1085                  NBASG = MAX(NBAS(ISYMG),1)
1086                  NVIRD = MAX(NVIR(ISYMD),1)
1087C
1088                  KSCR11 = KEND1
1089                  KEND2  = KSCR11 + NBAS(ISYMG)*NRHF(ISYML)
1090                  LWRK2  = LWORK  - KEND2
1091C
1092                  IF (LWRK2 .LT. 0) THEN
1093                     CALL QUIT('Not enough space for '//
1094     &                    'allocation in CCRHS_D31')
1095                  END IF
1096C
1097                  KOFF2 = KSCR10 + IAODIS(ISYMA,ISYMG)
1098                  KOFF3 = ILMRHF(ISYML) + 1
1099C
1100                  CALL DGEMM('T','N',NBAS(ISYMG),NRHF(ISYML),
1101     *                       NBAS(ISYMA),ONE,WORK(KOFF2),NBASA,
1102     *                       XLAMDP(KOFF3),NBASA,
1103     *                       ZERO,WORK(KSCR11),NBASG)
1104C
1105                  KOFF5 = ILMVIR(ISYMD) + 1
1106                  KOFF6 = IT2BCD(ISYMDL,ISYMK) + NT1AM(ISYMDL)*(K - 1)
1107     *                  + IT1AM(ISYMD,ISYML) + 1
1108C
1109                  CALL DGEMM('T','N',NVIR(ISYMD),NRHF(ISYML),
1110     *                       NBAS(ISYMG),ONE,XLAMDH(KOFF5),NBASG,
1111     *                       WORK(KSCR11),NBASG,
1112     *                       ZERO,SCR1(KOFF6),NVIRD)
1113C
1114  120          CONTINUE
1115C
1116  110       CONTINUE
1117C
1118  100    CONTINUE
1119!
1120!----------------------------------------------------
1121!      For ICON = 5 calculate the last part
1122!      of the intermediate. (t2(di,al)*g(ldkc))
1123!----------------------------------------------------
1124!
1125         IF (ICON .EQ. 5) THEN
1126!
1127!---------------------------
1128!      Transpose T2.
1129!---------------------------
1130!
1131           ISYM5 = ISYMT2
1132           CALL CCSD_T2TP(T2AM,WORK,LWORK,ISYM5)
1133!
1134           IF (LWORK .LT. NT2BCD(ISYDIS)) THEN
1135              CALL QUIT('Not enough space in CCRHS_D3 (IOPT = 5)')
1136           ENDIF
1137!
1138!-----------------------------
1139!      Calculate the cont.
1140!-----------------------------
1141!
1142           DO 123 ISYMK = 1,NSYM
1143!
1144              ISYMDL = MULD2H(ISYMK,ISYDIS)
1145!
1146              NRHFK = MAX(NRHF(ISYMK),1)
1147!
1148              DO 126 K = 1,NRHF(ISYMK)
1149!
1150                 KOFF1 = IT2BCD(ISYMDL,ISYMK)+NT1AM(ISYMDL)*(K-1)+1
1151                 KOFF2 = IT2BCT(ISYMK,ISYMDL) + K
1152!
1153                 CALL DCOPY(NT1AM(ISYMDL),SCR1(KOFF1),1,WORK(KOFF2),
1154     *                      NRHFK)
1155!
1156  126         CONTINUE
1157!
1158  123      CONTINUE
1159!
1160           CALL DCOPY(NT2BCD(ISYDIS),WORK,1,SCR3,1)
1161!
1162           IF (LWORK .LT. NT2BCD(ISYAIK)) THEN
1163              CALL QUIT('Insufficient work space in CCRHS_D31')
1164           ENDIF
1165!
1166           DO ISYMK = 1,NSYM
1167!
1168              ISYMDL = MULD2H(ISYMK,ISYDIS)
1169              ISYMAI = MULD2H(ISYAIK,ISYMK)
1170!
1171              NRHFK  = MAX(NRHF(ISYMK),1)
1172              NTOTDL = MAX(NT1AM(ISYMDL),1)
1173!
1174              KOFF1  = IT2BCT(ISYMK,ISYMDL) + 1
1175              KOFF2  = IT2SQ(ISYMDL,ISYMAI) + 1
1176              KOFF3  = IT2BCT(ISYMK,ISYMAI) + 1
1177!
1178           CALL DGEMM('N','N',NRHF(ISYMK),NT1AM(ISYMAI),NT1AM(ISYMDL),
1179     *                ONE,SCR3(KOFF1),NRHFK,T2AM(KOFF2),NTOTDL,ZERO,
1180     *                WORK(KOFF3),NRHFK)
1181!
1182           ENDDO
1183!
1184           CALL DCOPY(NT2BCD(ISYAIK),WORK,1,SCR3,1)
1185!
1186!----------------------------------------
1187!     Transpose T2 (back).
1188!----------------------------------------
1189!
1190           ISYM5 = ISYMT2
1191           CALL CCSD_T2TP(T2AM,WORK,LWORK,ISYM5)
1192!
1193         ENDIF
1194!
1195!--------------------------------------------
1196!        Transpose integral array.
1197!--------------------------------------------
1198!
1199         CALL CC_MTCME(SCR1,WORK,LWORK,ISYDIS,1)
1200C
1201         IF (LWORK .LT. NT2BCD(ISYDIS)) THEN
1202            CALL QUIT('Not enough space for allocation in CCRHS_D31(3)')
1203         END IF
1204C
1205         DO 130 ISYMK = 1,NSYM
1206C
1207            ISYMDL = MULD2H(ISYMK,ISYDIS)
1208C
1209            NRHFK = MAX(NRHF(ISYMK),1)
1210C
1211            DO 140 K = 1,NRHF(ISYMK)
1212C
1213               KOFF1 = IT2BCD(ISYMDL,ISYMK) + NT1AM(ISYMDL)*(K - 1) + 1
1214               KOFF2 = IT2BCT(ISYMK,ISYMDL) + K
1215C
1216               CALL DCOPY(NT1AM(ISYMDL),SCR1(KOFF1),1,WORK(KOFF2),NRHFK)
1217C
1218  140       CONTINUE
1219C
1220  130    CONTINUE
1221C
1222         CALL DCOPY(NT2BCD(ISYDIS),WORK,1,SCR1,1)
1223C
1224C-----------------------------------------
1225C        Calculate the first contribution.
1226C        sum(2*t(ai,dl)-t(di,al))*L(ldkc)
1227C-----------------------------------------
1228C
1229         IF (LWORK .LT. NT2BCD(ISYAIK)) THEN
1230            CALL QUIT('Insufficient work space in CCRHS_D31')
1231         ENDIF
1232C
1233         DO 200 ISYMK = 1,NSYM
1234C
1235            ISYMDL = MULD2H(ISYMK,ISYDIS)
1236            ISYMAI = MULD2H(ISYAIK,ISYMK)
1237C
1238            NRHFK  = MAX(NRHF(ISYMK),1)
1239            NTOTDL = MAX(NT1AM(ISYMDL),1)
1240C
1241            KOFF1  = IT2BCT(ISYMK,ISYMDL) + 1
1242            KOFF2  = IT2SQ(ISYMDL,ISYMAI) + 1
1243            KOFF3  = IT2BCT(ISYMK,ISYMAI) + 1
1244C
1245            CALL DGEMM('N','N',NRHF(ISYMK),NT1AM(ISYMAI),NT1AM(ISYMDL),
1246     *                 ONE,SCR1(KOFF1),NRHFK,T2AM(KOFF2),NTOTDL,ZERO,
1247     *                 WORK(KOFF3),NRHFK)
1248C
1249  200    CONTINUE
1250C
1251         CALL DCOPY(NT2BCD(ISYAIK),WORK,1,SCR1,1)
1252!
1253      ENDIF
1254!
1255      IF (ICON .EQ. 5) THEN
1256!
1257         CALL DAXPY(NT2BCD(ISYAIK),XMONE,SCR3,1,SCR1,1)
1258!
1259      ENDIF
1260!
1261C----------------------------------------------------------
1262C     Calculate the integrals K(k,ai) = (k i | alfa delta).
1263C----------------------------------------------------------
1264C
1265      DO 300 ISYMA = 1,NSYM
1266C
1267         ISYMBG = MULD2H(ISYMA,ISYDIS)
1268C
1269         KSCR10 = 1
1270         KEND1  = KSCR10 + N2BST(ISYMBG)
1271         LWRK1  = LWORK  - KEND1
1272         IF (LWRK1 .LT. 0) THEN
1273            CALL QUIT('Not enough space for allocation in CCRHS_D31')
1274         END IF
1275C
1276         DO 310 A = 1,NBAS(ISYMA)
1277C
1278            KOFF1 = IDSAOG(ISYMA,ISYDIS) + NNBST(ISYMBG)*(A - 1) + 1
1279            CALL CCSD_SYMSQ(XINT(KOFF1),ISYMBG,WORK(KSCR10))
1280C
1281            DO 320 ISYMG = 1,NSYM
1282C
1283               ISYMI  = ISYMG
1284               ISYMB  = MULD2H(ISYMG,ISYMBG)
1285               ISYMK  = ISYMB
1286               ISYMAI = MULD2H(ISYMA,ISYMI)
1287C
1288               NBASB = MAX(NBAS(ISYMB),1)
1289               NBASG = MAX(NBAS(ISYMG),1)
1290               NRHFK = MAX(NRHF(ISYMK),1)
1291C
1292               KSCR11 = KEND1
1293               KSCR12 = KSCR11 + NRHF(ISYMK)*NBAS(ISYMG)
1294               KEND2  = KSCR12 + NRHF(ISYMK)*NRHF(ISYMI)
1295               LWRK2  = LWORK  - KEND2
1296               IF (LWRK2 .LT. 0) THEN
1297                  CALL QUIT('Not enough space for '//
1298     &                 'allocation in CCRHS_D1')
1299               END IF
1300C
1301               KOFF2 = ILMRHF(ISYMK) + 1
1302               KOFF3 = KSCR10 + IAODIS(ISYMB,ISYMG)
1303C
1304               CALL DGEMM('T','N',NRHF(ISYMK),NBAS(ISYMG),NBAS(ISYMB),
1305     *                    ONE,XLAMDP(KOFF2),NBASB,WORK(KOFF3),NBASB,
1306     *                    ZERO,WORK(KSCR11),NRHFK)
1307C
1308               KOFF5 = ILMRHF(ISYMI) + 1
1309C
1310               CALL DGEMM('N','N',NRHF(ISYMK),NRHF(ISYMI),NBAS(ISYMG),
1311     *                    ONE,WORK(KSCR11),NRHFK,XLAMDH(KOFF5),NBASG,
1312     *                    ZERO,WORK(KSCR12),NRHFK)
1313C
1314               DO 330 I = 1,NRHF(ISYMI)
1315C
1316                  NAI = IT1AO(ISYMA,ISYMI) + NBAS(ISYMA)*(I-1) + A
1317C
1318                  KOFF8 = IT2BGT(ISYMK,ISYMAI)
1319     *                  + NRHF(ISYMK)*(NAI - 1) + 1
1320                  KOFF7 = KSCR12 + NRHF(ISYMK)*(I - 1)
1321C
1322                  CALL DCOPY(NRHF(ISYMK),WORK(KOFF7),1,SCR2(KOFF8),1)
1323C
1324  330          CONTINUE
1325C
1326C-------------------------------------------------------
1327C              In 2C1 linear transformation extra  cont.
1328C-------------------------------------------------------
1329C
1330               IF ((ICON .EQ. 1) .OR. (ICON.EQ.3)) THEN
1331C
1332                  ISYMI  = MULD2H(ISYMG,ISYMHC)
1333                  ISYMAI = MULD2H(ISYMA,ISYMI)
1334C
1335                  KEND2  = KSCR12 + NRHF(ISYMK)*NRHF(ISYMI)
1336                  LWRK2  = LWORK  - KEND2
1337                  IF (LWRK2 .LT. 0) THEN
1338                     CALL QUIT('Not enough space for '//
1339     &                    'allocation in CCRHS_D1')
1340                  END IF
1341C
1342                  KOFF5 = IGLMRH(ISYMG,ISYMI) + 1
1343C
1344                  CALL DGEMM('N','N',NRHF(ISYMK),NRHF(ISYMI),
1345     *                       NBAS(ISYMG),ONE,WORK(KSCR11),NRHFK,
1346     *                       XLAMHC(KOFF5),NBASG,
1347     *                       ZERO,WORK(KSCR12),NRHFK)
1348C
1349                  DO 331 I = 1,NRHF(ISYMI)
1350C
1351                     NAI = IT1AO(ISYMA,ISYMI) + NBAS(ISYMA)*(I-1) + A
1352C
1353                     KOFF8 = IT2BGT(ISYMK,ISYMAI)
1354     *                     + NRHF(ISYMK)*(NAI - 1) + 1
1355                     KOFF7 = KSCR12 + NRHF(ISYMK)*(I - 1)
1356C
1357                     CALL DCOPY(NRHF(ISYMK),WORK(KOFF7),1,SCR3(KOFF8),1)
1358C
1359  331             CONTINUE
1360C
1361               ENDIF
1362C
1363  320       CONTINUE
1364C
1365  310    CONTINUE
1366C
1367  300 CONTINUE
1368C
1369      IF ((ICON .EQ. 4) .OR. (ICON .EQ. 5) .OR. (ICON .EQ. 6)) THEN
1370!
1371         CALL DSCAL(NT2BGD(ISYDIS),ZERO,SCR2,1)
1372C
1373         ISALIK = MULD2H(ISYDIS,ISYMHC)
1374C
1375         CALL DSCAL(NT2BGD(ISALIK),ZERO,SCR3,1)
1376!
1377      ELSE
1378!
1379         CALL DSCAL(NT2BGD(ISYDIS),-ONE,SCR2,1)
1380C
1381         ISALIK = MULD2H(ISYDIS,ISYMHC)
1382C
1383         CALL DSCAL(NT2BGD(ISALIK),-ONE,SCR3,1)
1384C
1385      ENDIF
1386!
1387!---------------------------------------------------------------
1388!     For ICON = 4 and ICON = 6 the real calculations begins here
1389!---------------------------------------------------------------
1390!
1391      DO 340 ISYMK = 1,NSYM
1392C
1393         ISYALG = MULD2H(ISYMK,ISYDIS)
1394         ISYALI = MULD2H(ISYMHC,ISYALG)
1395         NT1AOM = MAX(NT1AO(ISYALG),NT1AO(ISYALI))
1396C
1397         KSCR10 = 1
1398         KSCR11 = KSCR10 + N2BST(ISYALG)
1399         KEND1  = KSCR11 + NT1AOM
1400         LWRK1  = LWORK  - KEND1
1401         IF (LWRK1 .LT. 0) THEN
1402            CALL QUIT('Insufficient space for allocation in CCRHS_D31')
1403         END IF
1404C
1405         DO 350 K = 1,NRHF(ISYMK)
1406C
1407            KOFF1 = IDSRHF(ISYALG,ISYMK) + NNBST(ISYALG)*(K - 1) + 1
1408            CALL CCSD_SYMSQ(DSRHF(KOFF1),ISYALG,WORK(KSCR10))
1409C
1410            ISYALI = ISYALG
1411            CALL DZERO(WORK(KSCR11),NT1AO(ISYALI))
1412C
1413C------------------------------
1414C           Usual contribution.
1415C------------------------------
1416C
1417            DO 360 ISYMI = 1,NSYM
1418C
1419               ISYMAL = MULD2H(ISYMI,ISYALI)
1420               ISYMG  = ISYMI
1421C
1422               NBASAL = MAX(NBAS(ISYMAL),1)
1423               NBASG = MAX(NBAS(ISYMG),1)
1424C
1425               KOFF2 = KSCR10 + IAODIS(ISYMAL,ISYMG)
1426               KOFF3 = ILMRHF(ISYMI) + 1
1427               KOFF4 = KSCR11 + IT1AO(ISYMAL,ISYMI)
1428C
1429               CALL DGEMM('N','N',NBAS(ISYMAL),NRHF(ISYMI),NBAS(ISYMG),
1430     *                    ONE,WORK(KOFF2),NBASAL,XLAMDH(KOFF3),NBASG,
1431     *                    ZERO,WORK(KOFF4),NBASAL)
1432C
1433  360       CONTINUE
1434C
1435            NRHFK = MAX(NRHF(ISYMK),1)
1436            KOFF5 = IT2BGT(ISYMK,ISYALI) + K
1437C
1438            IF ((ICON .EQ. 4) .OR. (ICON .EQ. 5) .OR. (ICON .EQ. 6)
1439     *                                         ) THEN
1440               CALL DAXPY(NT1AO(ISYALI),ONE,WORK(KSCR11),1,SCR2(KOFF5),
1441     *                    NRHFK)
1442!
1443            ELSE
1444               CALL DAXPY(NT1AO(ISYALI),TWO,WORK(KSCR11),1,SCR2(KOFF5),
1445     *                    NRHFK)
1446            ENDIF
1447C
1448C----------------------------------------------------
1449C           In 2C1 linear tronsformation extra  cont.
1450C----------------------------------------------------
1451C
1452            IF ((ICON .EQ. 3) .OR. (ICON .EQ. 1)
1453     &           .OR. (ICON .EQ. 4) .OR. (ICON .EQ. 6)) THEN
1454C
1455               ISYALI = MULD2H(ISYALG,ISYMHC)
1456C
1457               CALL DZERO(WORK(KSCR11),NT1AO(ISYALI))
1458C
1459               DO 361 ISYMI = 1,NSYM
1460C
1461                  ISYMAL = MULD2H(ISYMI,ISYALI)
1462                  ISYMG  = MULD2H(ISYMI,ISYMHC)
1463C
1464                  NBASAL = MAX(NBAS(ISYMAL),1)
1465                  NBASG  = MAX(NBAS(ISYMG),1)
1466C
1467                  KOFF2 = KSCR10 + IAODIS(ISYMAL,ISYMG)
1468                  KOFF3 = IGLMRH(ISYMG,ISYMI) + 1
1469                  KOFF4 = KSCR11 + IT1AO(ISYMAL,ISYMI)
1470C
1471                  CALL DGEMM('N','N',NBAS(ISYMAL),NRHF(ISYMI),
1472     &                       NBAS(ISYMG),ONE,WORK(KOFF2),NBASAL,
1473     &                       XLAMHC(KOFF3),NBASG,
1474     &                       ZERO,WORK(KOFF4),NBASAL)
1475C
1476  361          CONTINUE
1477C
1478               NRHFK = MAX(NRHF(ISYMK),1)
1479               KOFF5 = IT2BGT(ISYMK,ISYALI) + K
1480C
1481               IF (ICON .EQ. 4 ) THEN
1482               CALL DAXPY(NT1AO(ISYALI),ONE,WORK(KSCR11),1,
1483     &                    SCR3(KOFF5),NRHFK)
1484               ELSE IF (ICON .EQ. 6) THEN
1485               CALL DAXPY(NT1AO(ISYALI),XMONE,WORK(KSCR11),1,
1486     &                    SCR3(KOFF5),NRHFK)
1487               ELSE
1488               CALL DAXPY(NT1AO(ISYALI),TWO,WORK(KSCR11),1,
1489     &                    SCR3(KOFF5),NRHFK)
1490               ENDIF
1491C
1492            ENDIF
1493C
1494  350    CONTINUE
1495C
1496  340 CONTINUE
1497C
1498      IF (.NOT. DUMPCD) THEN
1499C
1500C-----------------------------------------
1501C     Back transformation to the AO basis.
1502C-----------------------------------------
1503C
1504      DO 400 ISYMAI = 1,NSYM
1505C
1506         ISYMK = MULD2H(ISYMAI,ISYDIS)
1507C
1508         NRHFK = MAX(NRHF(ISYMK),1)
1509C
1510         DO 410 ISYMI = 1,NSYM
1511C
1512            ISYMA = MULD2H(ISYMI,ISYMAI)
1513C
1514            NBASA = MAX(NBAS(ISYMA),1)
1515C
1516            DO 420 I = 1,NRHF(ISYMI)
1517C
1518               NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + 1
1519               MAI = IT1AO(ISYMA,ISYMI) + NBAS(ISYMA)*(I - 1) + 1
1520C
1521               KOFF1 = IT2BCT(ISYMK,ISYMAI) + NRHF(ISYMK)*(NAI - 1) + 1
1522               KOFF2 = ILMVIR(ISYMA) + 1
1523               KOFF3 = IT2BGT(ISYMK,ISYMAI) + NRHF(ISYMK)*(MAI - 1) + 1
1524C
1525               CALL DGEMM('N','T',NRHF(ISYMK),NBAS(ISYMA),NVIR(ISYMA),
1526     *                    HALF,SCR1(KOFF1),NRHFK,XLAMIP(KOFF2),NBASA,
1527     *                    ONE,SCR2(KOFF3),NRHFK)
1528C
1529  420       CONTINUE
1530C
1531  410    CONTINUE
1532C
1533  400 CONTINUE
1534C
1535C
1536      DO 500 ISYMK = 1,NSYM
1537C
1538         ISYMBJ = MULD2H(ISYMK,ISYDEL)
1539C
1540         DO 510 K = 1,NRHF(ISYMK)
1541C
1542            DO 520 ISYMJ = 1,NSYM
1543C
1544               ISYMB = MULD2H(ISYMJ,ISYMBJ)
1545C
1546               NBASB = MAX(NBAS(ISYMB),1)
1547               NVIRB = MAX(NVIR(ISYMB),1)
1548C
1549               KOFF1 = ILMVIR(ISYMB) + 1
1550               KOFF2 = IT2BCD(ISYMBJ,ISYMK) + NT1AM(ISYMBJ)*(K - 1)
1551     *               + IT1AM(ISYMB,ISYMJ) + 1
1552               KOFF3 = IT2BGD(ISYMBJ,ISYMK) + NT1AO(ISYMBJ)*(K - 1)
1553     *               + IT1AO(ISYMB,ISYMJ) + 1
1554C
1555               CALL DGEMM('N','N',NBAS(ISYMB),NRHF(ISYMJ),NVIR(ISYMB),
1556     *                    ONE,XLAMIP(KOFF1),NBASB,SCRM(KOFF2),NVIRB,
1557     *                    ZERO,SCR3(KOFF3),NBASB)
1558C
1559  520       CONTINUE
1560C
1561  510    CONTINUE
1562C
1563  500 CONTINUE
1564C
1565C---------------------------------------
1566C     Calculate the second contribution.
1567C---------------------------------------
1568C
1569      DO 600 ISYMAI = 1,NSYM
1570C
1571         ISYMK  = MULD2H(ISYMAI,ISYDIS)
1572         ISYMBJ = MULD2H(ISYMK,ISYDEL)
1573C
1574         IF (NRHF(ISYMK) .EQ. 0) GOTO 600
1575C
1576         IF (LWORK .LT. NT1AO(ISYMBJ)) THEN
1577            CALL QUIT('Insufficient work space in CCRHS_D31')
1578         ENDIF
1579C
1580         NTOTBJ = MAX(NT1AO(ISYMBJ),1)
1581         NRHFK  = MAX(NRHF(ISYMK),1)
1582C
1583         IF (.NOT. OMEGSQ) THEN
1584C
1585            DO 610 NAI = 1,NT1AO(ISYMAI)
1586C
1587               KOFF1 = IT2BGD(ISYMBJ,ISYMK) + 1
1588               KOFF2 = IT2BGT(ISYMK,ISYMAI)
1589     *               + NRHF(ISYMK)*(NAI - 1) + 1
1590C
1591               CALL DGEMV('N',NT1AO(ISYMBJ),NRHF(ISYMK),ONE,
1592     *                    SCR3(KOFF1),NTOTBJ,SCR2(KOFF2),1,
1593     *                    ZERO,WORK,1)
1594C
1595               IF (ISYMAI .EQ. ISYMBJ) THEN
1596                  WORK(NAI) = TWO*WORK(NAI)
1597               ENDIF
1598C
1599               DO 620 NBJ = 1,NT1AO(ISYMBJ)
1600                  NAIBJ = IT2AO(ISYMAI,ISYMBJ) + INDEX(NAI,NBJ)
1601                  OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + HALF*WORK(NBJ)
1602  620          CONTINUE
1603C
1604  610       CONTINUE
1605C
1606         ELSE
1607C
1608            KOFF1 = IT2BGD(ISYMBJ,ISYMK)  + 1
1609            KOFF2 = IT2BGT(ISYMK,ISYMAI)  + 1
1610            KOFF3 = IT2AOS(ISYMBJ,ISYMAI) + 1
1611C
1612            CALL DGEMM('N','N',NT1AO(ISYMBJ),NT1AO(ISYMAI),NRHF(ISYMK),
1613     *                 HALF,SCR3(KOFF1),NTOTBJ,SCR2(KOFF2),NRHFK,
1614     *                 ONE,OMEGA2(KOFF3),NT1AO(ISYMBJ))
1615C
1616         ENDIF
1617C
1618  600 CONTINUE
1619C
1620      GOTO 999
1621C
1622C-------------------
1623C     I/O algorithm.
1624C-------------------
1625C
1626      ENDIF
1627C
1628C----------------------------------------------------------------------
1629C  Transform the alpha index of K(k,ai) to a.
1630C  for 2C1 transformation this means lamdpc is a C1 transformed lambda
1631C----------------------------------------------------------------------
1632C
1633      ISYAIK = MULD2H(ISYDIS,ISYMPC)
1634C
1635      DO 710 ISYMAI = 1,NSYM
1636C
1637         ISYMK = MULD2H(ISYMAI,ISYAIK)
1638         NRHFK = MAX(NRHF(ISYMK),1)
1639C
1640         DO 720 ISYMI = 1,NSYM
1641C
1642            ISYMA  = MULD2H(ISYMI,ISYMAI)
1643            ISYMAL = MULD2H(ISYMPC,ISYMA)
1644            ISYALI = MULD2H(ISYMAL,ISYMI)
1645            NBASAL = MAX(NBAS(ISYMAL),1)
1646C
1647            DO 730 I = 1,NRHF(ISYMI)
1648C
1649               NAI   = IT1AM(ISYMA,ISYMI)   + NVIR(ISYMA)*(I - 1) + 1
1650               MALI  = IT1AO(ISYMAL,ISYMI)  + NBAS(ISYMAL)*(I - 1) + 1
1651C
1652               KOFF1 = IT2BGT(ISYMK,ISYALI) + NRHF(ISYMK)*(MALI - 1) + 1
1653               KOFF2 = IGLMVI(ISYMAL,ISYMA) + 1
1654               KOFF3 = IT2BCT(ISYMK,ISYMAI) + NRHF(ISYMK)*(NAI - 1) + 1
1655C
1656               CALL DGEMM('N','N',NRHF(ISYMK),NVIR(ISYMA),NBAS(ISYMAL),
1657     *                    ONE,SCR2(KOFF1),NRHFK,XLAMPC(KOFF2),NBASAL,
1658     *                    FACTD ,SCR1(KOFF3),NRHFK)
1659!
1660  730       CONTINUE
1661  720    CONTINUE
1662  710 CONTINUE
1663!
1664!-----------------------------------------------
1665!     Transform the alpha index of K(k,ai) to a.
1666!     I is C1 transformed.
1667!-----------------------------------------------
1668!
1669      IF ((ICON .EQ. 3) .OR. (ICON .EQ. 1)
1670     *    .OR. (ICON .EQ. 4) .OR. (ICON .EQ. 6)) THEN
1671C
1672         ISYAIK = MULD2H(ISYDIS,ISYMHC)
1673C
1674         DO 750 ISYMAI = 1,NSYM
1675C
1676            ISYMK = MULD2H(ISYMAI,ISYAIK)
1677            NRHFK = MAX(NRHF(ISYMK),1)
1678C
1679            DO 760 ISYMI = 1,NSYM
1680C
1681               ISYMA = MULD2H(ISYMI,ISYMAI)
1682               ISYMAL= ISYMA
1683               ISYALI= MULD2H(ISYMAL,ISYMI)
1684               NBASAL = MAX(NBAS(ISYMAL),1)
1685C
1686               DO 770 I = 1,NRHF(ISYMI)
1687C
1688                  NAI = IT1AM(ISYMA,ISYMI)
1689     *                + NVIR(ISYMA)*(I - 1) + 1
1690                  MALI = IT1AO(ISYMAL,ISYMI)
1691     *                 + NBAS(ISYMAL)*(I - 1) + 1
1692C
1693                  KOFF1 = IT2BGT(ISYMK,ISYALI)
1694     *                  + NRHF(ISYMK)*(MALI - 1) + 1
1695                  KOFF2 = ILMVIR(ISYMA) + 1
1696                  KOFF3 = IT2BCT(ISYMK,ISYMAI)
1697     *                  + NRHF(ISYMK)*(NAI - 1) + 1
1698C
1699                  CALL DGEMM('N','N',NRHF(ISYMK),NVIR(ISYMA),
1700     *                       NBAS(ISYMAL),ONE,SCR3(KOFF1),NRHFK,
1701     *                       XLAMDP(KOFF2),NBASAL,
1702     *                       ONE,SCR1(KOFF3),NRHFK)
1703C
1704  770          CONTINUE
1705  760       CONTINUE
1706  750    CONTINUE
1707C
1708      ENDIF
1709C
1710C---------------------------------------
1711C     Dump to disk the new contribution.
1712C---------------------------------------
1713C
1714C
1715      IF ((ICON .EQ. 2 ) .OR. (ICON .EQ. 5)) THEN
1716         IOFF = IT2DEL(IDEL) + 1
1717      ELSE
1718         IOFF = IT2DLR(IDEL,IV) + 1
1719      ENDIF
1720C
1721      IF (NT2BCD(ISYAIK) .GT. 0) THEN
1722         CALL PUTWA2(LUD,DFIL,SCR1,IOFF,NT2BCD(ISYAIK))
1723      ENDIF
1724C
1725  999 CONTINUE
1726C
1727      CALL QEXIT('CCRHS_D31')
1728C
1729      RETURN
1730      END
1731C  /* Deck ccrhs_e */
1732      SUBROUTINE CCRHS_E3(OMEGA2,OM2CONT,T2AM,EMAT1,EMAT2,WORK,LWORK,
1733     *                    ISYMTR,ISYMIM,OMEGA22,ANTISYM)
1734C
1735C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
1736C     Written by Henrik Koch & Ove Christiansen 20-Jan-1994
1737C     Symmetry 3-aug
1738C     Contraction of EI intermediates with double excitaion amplitudes.
1739C     It is assumed that the fock matrix is included. OC 13-1-1995
1740C
1741!     Generalized to the triplet case by Kasper Hald. march-1999
1742!     IF OM2CONT = .TRUE. => Symmetric permutation of (ai,bj)
1743!     is calculated in OMEGA2. IF ANTISYM = .TRUE. =>
1744!     antisymmetric prem. of (ai,bj) is calculated in OMEGA22.
1745!
1746C     Purpose: Calculate E-terms
1747C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
1748C
1749      IMPLICIT NONE
1750!
1751#include "priunit.h"
1752#include "ccorb.h"
1753#include "ccsdsym.h"
1754#include "ccsdinp.h"
1755!
1756      INTEGER LWORK, INDEX, ISYAIBJ, ISYMTR, ISYMIM, ISYMAI, ISYMCJ
1757      INTEGER ISYMBJ, NAI, ISYMJ, ISYMC, ISYMB, NVIRB, NVIRC
1758      INTEGER KOFF1, KOFF2, KOFF3, NBJ, NAIBJ, ISYMBK, ISYMK, NRHFK
1759!
1760#if defined (SYS_CRAY)
1761      REAL ZERO, ONE, TWO
1762      REAL EMAT1(*), EMAT2(*), T2AM(*), OMEGA2(*), OMEGA22(*)
1763      REAL WORK(LWORK)
1764#else
1765      DOUBLE PRECISION ZERO, ONE, TWO
1766      DOUBLE PRECISION EMAT1(*), EMAT2(*), T2AM(*), OMEGA2(*)
1767      DOUBLE PRECISION OMEGA22(*), WORK(LWORK)
1768#endif
1769!
1770      LOGICAL ANTISYM, OM2CONT
1771!
1772      PARAMETER(ZERO=0.0D00,ONE=1.0D00,TWO=2.0D00)
1773C
1774      INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J
1775C
1776      CALL QENTER('CCRHS_E3')
1777C
1778C--------------------------------------------------------------
1779C     Contract and accumulate the first intermediate in OMEGA2.
1780C--------------------------------------------------------------
1781C
1782      ISYAIBJ = MULD2H(ISYMTR,ISYMIM)
1783C
1784      DO 300 ISYMAI = 1,NSYM
1785C
1786         ISYMCJ = MULD2H(ISYMAI,ISYMTR)
1787         ISYMBJ = MULD2H(ISYMAI,ISYAIBJ)
1788C
1789         IF (LWORK .LT. NT1AM(ISYMBJ)) THEN
1790            CALL QUIT('Insufficient space for allocation in CCRHS_E1')
1791         END IF
1792C
1793         DO 310 NAI = 1,NT1AM(ISYMAI)
1794C
1795            CALL DZERO(WORK,NT1AM(ISYMBJ))
1796C
1797            DO 320 ISYMJ = 1,NSYM
1798C
1799               ISYMC  = MULD2H(ISYMJ,ISYMCJ)
1800               ISYMB  = MULD2H(ISYMJ,ISYMBJ)
1801C
1802               NVIRB = MAX(NVIR(ISYMB),1)
1803               NVIRC = MAX(NVIR(ISYMC),1)
1804C
1805               KOFF1 = IMATAB(ISYMB,ISYMC) + 1
1806               KOFF2 = IT2SQ(ISYMCJ,ISYMAI) + NT1AM(ISYMCJ)*(NAI - 1)
1807     *                  + IT1AM(ISYMC,ISYMJ) + 1
1808               KOFF3 = IT1AM(ISYMB,ISYMJ) + 1
1809C
1810               CALL DGEMM('N','N',NVIR(ISYMB),NRHF(ISYMJ),
1811     *                    NVIR(ISYMC),ONE,EMAT1(KOFF1),NVIRB,
1812     *                    T2AM(KOFF2),NVIRC,
1813     *                    ONE,WORK(KOFF3),NVIRB)
1814  320          CONTINUE
1815C
1816            IF (OM2CONT) THEN
1817               IF (ISYMAI .EQ. ISYMBJ ) THEN
1818C
1819                 WORK(NAI) = TWO*WORK(NAI)
1820                 DO 330 NBJ = 1,NT1AM(ISYMBJ)
1821                    NAIBJ = IT2AM(ISYMAI,ISYMBJ) + INDEX(NAI,NBJ)
1822                    OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + WORK(NBJ)
1823  330          CONTINUE
1824C
1825               ENDIF
1826C
1827               IF (ISYMAI .LT. ISYMBJ) THEN
1828C
1829                  DO 340 NBJ = 1,NT1AM(ISYMBJ)
1830                    NAIBJ = IT2AM(ISYMAI,ISYMBJ)
1831     *                     + NT1AM(ISYMAI)*(NBJ - 1) + NAI
1832                     OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + WORK(NBJ)
1833  340             CONTINUE
1834C
1835               ENDIF
1836C
1837               IF (ISYMBJ .LT. ISYMAI) THEN
1838C
1839                  DO 350 NBJ = 1,NT1AM(ISYMBJ)
1840                     NAIBJ = IT2AM(ISYMAI,ISYMBJ)
1841     *                     + NT1AM(ISYMBJ)*(NAI - 1) + NBJ
1842                     OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + WORK(NBJ)
1843  350             CONTINUE
1844C
1845               ENDIF
1846!
1847           ENDIF
1848           IF (ANTISYM) THEN
1849               IF (ISYMAI .EQ. ISYMBJ) THEN
1850!
1851                IF (NAI .GE. NT1AM(ISYMBJ)) THEN
1852!
1853                  DO NBJ = 1, NT1AM(ISYMBJ)
1854                      NAIBJ = IT2AM(ISYMAI, ISYMBJ) + INDEX(NAI,NBJ)
1855                     OMEGA22(NAIBJ) = OMEGA22(NAIBJ) + WORK(NBJ)
1856                  ENDDO
1857                ELSE
1858!
1859                  DO NBJ = 1, NAI - 1
1860                     NAIBJ = IT2AM(ISYMAI, ISYMBJ) + INDEX(NAI,NBJ)
1861                     OMEGA22(NAIBJ) = OMEGA22(NAIBJ) + WORK(NBJ)
1862                  ENDDO
1863                  DO NBJ = NAI + 1, NT1AM(ISYMBJ)
1864                     NAIBJ = IT2AM(ISYMAI, ISYMBJ) + INDEX(NAI,NBJ)
1865                     OMEGA22(NAIBJ) = OMEGA22(NAIBJ) - WORK(NBJ)
1866                  ENDDO
1867                ENDIF
1868               ENDIF
1869!
1870               IF (ISYMAI .LT. ISYMBJ) THEN
1871                  DO NBJ = 1, NT1AM(ISYMBJ)
1872                     NAIBJ = IT2AM(ISYMAI, ISYMBJ)
1873     *                     + NT1AM(ISYMAI)*(NBJ - 1) + NAI
1874                     OMEGA22(NAIBJ) = OMEGA22(NAIBJ) - WORK(NBJ)
1875                  ENDDO
1876               ENDIF
1877!
1878               IF (ISYMAI .GT. ISYMBJ) THEN
1879                  DO NBJ = 1, NT1AM(ISYMBJ)
1880                     NAIBJ = IT2AM(ISYMAI, ISYMBJ)
1881     *                     + NT1AM(ISYMBJ)*(NAI - 1) + NBJ
1882                     OMEGA22(NAIBJ) = OMEGA22(NAIBJ) + WORK(NBJ)
1883                  ENDDO
1884               ENDIF
1885           ENDIF
1886  310    CONTINUE
1887  300 CONTINUE
1888C
1889C-----------------------------------------------------
1890C     Contract and accumulate the second intermediate.
1891C-----------------------------------------------------
1892C
1893C
1894      DO 400 ISYMAI = 1,NSYM
1895C
1896         ISYMBK = MULD2H(ISYMAI,ISYMTR)
1897         ISYMBJ = MULD2H(ISYMAI,ISYAIBJ)
1898C
1899         IF (LWORK .LT. NT1AM(ISYMBJ)) THEN
1900            CALL QUIT('Insufficient space for allocation in CCRHS_E1')
1901         END IF
1902C
1903         DO 410 NAI = 1,NT1AM(ISYMAI)
1904C
1905            CALL DZERO(WORK,NT1AM(ISYMBJ))
1906C
1907            DO 420 ISYMB = 1,NSYM
1908C
1909               ISYMJ  = MULD2H(ISYMB,ISYMBJ)
1910               ISYMK  = MULD2H(ISYMJ,ISYMIM)
1911C
1912               NVIRB = MAX(NVIR(ISYMB),1)
1913               NRHFK = MAX(NRHF(ISYMK),1)
1914C
1915               KOFF1 = IT2SQ(ISYMBK,ISYMAI) + NT1AM(ISYMBK)*(NAI - 1)
1916     *               + IT1AM(ISYMB,ISYMK) + 1
1917               KOFF2 = IMATIJ(ISYMK,ISYMJ) + 1
1918               KOFF3 = IT1AM(ISYMB,ISYMJ) + 1
1919C
1920               CALL DGEMM('N','N',NVIR(ISYMB),NRHF(ISYMJ),
1921     *                    NRHF(ISYMK),ONE,T2AM(KOFF1),NVIRB,
1922     *                    EMAT2(KOFF2),NRHFK,
1923     *                    ONE,WORK(KOFF3),NVIRB)
1924  420       CONTINUE
1925C
1926C
1927            IF (OM2CONT) THEN
1928               IF (ISYMAI .EQ. ISYMBJ ) THEN
1929C
1930                  WORK(NAI) = TWO*WORK(NAI)
1931C
1932                  DO 430 NBJ = 1,NT1AM(ISYMBJ)
1933                     NAIBJ = IT2AM(ISYMAI,ISYMBJ) + INDEX(NAI,NBJ)
1934                     OMEGA2(NAIBJ) = OMEGA2(NAIBJ) - WORK(NBJ)
1935  430             CONTINUE
1936C
1937               ENDIF
1938C
1939               IF (ISYMAI .LT. ISYMBJ) THEN
1940C
1941                  DO 440 NBJ = 1,NT1AM(ISYMBJ)
1942                    NAIBJ = IT2AM(ISYMAI,ISYMBJ)
1943     *                     + NT1AM(ISYMAI)*(NBJ - 1) + NAI
1944                     OMEGA2(NAIBJ) = OMEGA2(NAIBJ) - WORK(NBJ)
1945  440             CONTINUE
1946C
1947               ENDIF
1948C
1949               IF (ISYMBJ .LT. ISYMAI) THEN
1950C
1951                  DO 450 NBJ = 1,NT1AM(ISYMBJ)
1952                     NAIBJ = IT2AM(ISYMAI,ISYMBJ)
1953     *                     + NT1AM(ISYMBJ)*(NAI - 1) + NBJ
1954                     OMEGA2(NAIBJ) = OMEGA2(NAIBJ) - WORK(NBJ)
1955  450             CONTINUE
1956C
1957               ENDIF
1958            ENDIF
1959            IF (ANTISYM) THEN
1960!
1961               IF (ISYMAI .EQ. ISYMBJ) THEN
1962!
1963                  DO NBJ = 1, NAI - 1
1964                     NAIBJ = IT2AM(ISYMAI, ISYMBJ) + INDEX(NAI,NBJ)
1965                     OMEGA22(NAIBJ) = OMEGA22(NAIBJ) - WORK(NBJ)
1966                  ENDDO
1967                  DO NBJ = NAI + 1, NT1AM(ISYMBJ)
1968                     NAIBJ = IT2AM(ISYMAI,ISYMBJ) + INDEX(NAI,NBJ)
1969                     OMEGA22(NAIBJ) = OMEGA22(NAIBJ) + WORK(NBJ)
1970                  ENDDO
1971                ENDIF
1972!
1973                IF (ISYMAI .LT. ISYMBJ) THEN
1974                   DO NBJ = 1, NT1AM(ISYMBJ)
1975                      NAIBJ = IT2AM(ISYMAI,ISYMBJ)
1976     *                      + NT1AM(ISYMAI)*(NBJ - 1) + NAI
1977                      OMEGA22(NAIBJ) = OMEGA22(NAIBJ) + WORK(NBJ)
1978                   ENDDO
1979                ENDIF
1980!
1981                IF (ISYMAI .GT. ISYMBJ) THEN
1982                   DO NBJ = 1, NT1AM(ISYMBJ)
1983                      NAIBJ = IT2AM(ISYMAI, ISYMBJ)
1984     *                      + NT1AM(ISYMBJ)*(NAI - 1) + NBJ
1985                      OMEGA22(NAIBJ) = OMEGA22(NAIBJ) - WORK(NBJ)
1986                   ENDDO
1987                ENDIF
1988            ENDIF
1989  410    CONTINUE
1990  400 CONTINUE
1991C
1992      CALL QEXIT('CCRHS_E3')
1993C
1994      RETURN
1995      END
1996      SUBROUTINE CCRHS_C3(XINT,DSRHF,OMEGA2,T2AM,ISYMT2,
1997     *                    XLAMDP,XLAMIP,XLAMDH,
1998     *                    XLAMPC,ISYMPC,XLAMHC,ISYMHC,SCRM,WORK,LWORK,
1999     *                    IDEL,ISYMD,FACTC,ICON,LUC,CFIL,IV)
2000C
2001C     Written by Henrik Koch 3-Jan-1994
2002C     Symmetry by Henrik Koch and Alfredo Sanchez. 27-July-1994
2003C     Generalisation for CCLR by Ove Christiansen august-september 1995
2004C     (right transformation) and september 1996 (F-matrix).
2005!     Generalisation to the CCLR triplet case by Kasper Hald
2006!     11-march-1999.
2007C
2008C     Purpose: Calculate C-term.
2009C
2010      IMPLICIT NONE
2011#include "priunit.h"
2012#include "maxorb.h"
2013#include "ccorb.h"
2014#include "symsq.h"
2015#include "ccsdsym.h"
2016#include "ccsdio.h"
2017#include "ccsdinp.h"
2018!
2019      INTEGER LWORK, ISYDIS, ISYMD, ISYAIK, ISYMPC, KSCR1, KSCR2
2020      INTEGER KSCR3, ICON, KEND1, LWRK1, ISYMT2, ISYMHC, IDEL, LUC
2021      INTEGER IV
2022!
2023#if defined (SYS_CRAY)
2024      REAL FACTC
2025      REAL XINT(*), DSRHF(*), OMEGA2(*), XLAMDH(*), WORK(LWORK)
2026      REAL XLAMDP(*), XLAMIP(*), SCRM(*), XLAMPC(*), XLAMHC(*)
2027      REAL T2AM(*)
2028#else
2029      DOUBLE PRECISION FACTC
2030      DOUBLE PRECISION XINT(*), DSRHF(*), OMEGA2(*), XLAMDH(*)
2031      DOUBLE PRECISION WORK(LWORK), XLAMDP(*), XLAMIP(*), SCRM(*)
2032      DOUBLE PRECISION XLAMPC(*), XLAMHC(*), T2AM(*)
2033#endif
2034C
2035      CHARACTER CFIL*(*)
2036C
2037      CALL QENTER('CCRHS_C3')
2038C
2039      ISYDIS = MULD2H(ISYMD,ISYMOP)
2040      ISYAIK = MULD2H(ISYDIS,ISYMPC)
2041C
2042C--------------------------------------
2043C     Dynamic allocation of work space.
2044C--------------------------------------
2045C
2046      KSCR1 = 1
2047      KSCR2 = KSCR1 + MAX(NT2BCD(ISYAIK),NT2BCD(ISYDIS))
2048      KSCR3 = KSCR2 + NT2BGD(ISYDIS)
2049      IF ((ICON .EQ. 2) .OR. (ICON .EQ. 5)) THEN
2050         KEND1  = KSCR3  + NT2BGD(ISYMD)
2051      ELSE
2052         KEND1  = KSCR3  + NT2BGD(ISYAIK)
2053      ENDIF
2054      LWRK1 = LWORK - KEND1
2055      IF (LWRK1 .LT. 0) THEN
2056         CALL QUIT('Insufficient space for allocation in CCRHS_C3')
2057      END IF
2058C
2059C--------------------------------------
2060C     Transpose the cluster amplitudes.
2061C--------------------------------------
2062C
2063      IF ((ICON .EQ. 2) .OR. (ICON .EQ. 3)) THEN
2064         IF (.NOT. T2TCOR) THEN
2065            CALL CCSD_T2TP(T2AM,WORK(KEND1),LWRK1,ISYMT2)
2066         ENDIF
2067         IF (.NOT. DUMPCD) CALL CCSD_T2MTP(SCRM,WORK(KEND1),LWRK1,ISYMD)
2068      ENDIF
2069C
2070C--------------------------------
2071C     Calculate the contribution.
2072C--------------------------------
2073C
2074         CALL CCRHS_C31(XINT,DSRHF,OMEGA2,T2AM,ISYMT2,SCRM,
2075     *                   WORK(KSCR1),WORK(KSCR2),WORK(KSCR3),XLAMDP,
2076     *                   XLAMIP,XLAMDH,XLAMPC,ISYMPC,XLAMHC,ISYMHC,
2077     *                   WORK(KEND1),LWRK1,
2078     *                   ISYDIS,IDEL,ISYMD,FACTC,ICON,LUC,CFIL,IV)
2079C
2080C--------------------------------------
2081C     Transpose the cluster amplitudes.
2082C--------------------------------------
2083C
2084      IF ((ICON .EQ. 2) .OR. (ICON .EQ. 3)) THEN
2085         IF (.NOT. T2TCOR) THEN
2086            CALL CCSD_T2TP(T2AM,WORK(KEND1),LWRK1,ISYMT2)
2087         ENDIF
2088         IF (.NOT. DUMPCD) CALL CCSD_T2MTP(SCRM,WORK(KEND1),LWRK1,ISYMD)
2089      ENDIF
2090C
2091      CALL QEXIT('CCRHS_C3')
2092C
2093      RETURN
2094      END
2095      SUBROUTINE CCRHS_C31(XINT,DSRHF,OMEGA2,T2AM,ISYMT2,SCRM,SCR1,
2096     *                      SCR2,SCR3,XLAMDP,XLAMIP,XLAMDH,
2097     *                      XLAMPC,ISYMPC,XLAMHC,ISYMHC,WORK,
2098     *                      LWORK,ISYDIS,IDEL,ISYDEL,FACTC,ICON,LUC,
2099     *                      CFIL,IV)
2100C
2101C     Written by Henrik Koch 3-Jan-1994
2102C     Symmetry by Henrik Koch and Alfredo Sanchez. 27-July-1994
2103C
2104C     modification by Ove Christiansen 25-7-1995 to allow for a
2105C     general factor (FACTC) ( assumes DUMCD )
2106C     and - calculate intermediates for CCLR.
2107C
2108C     modification by Ove Christiansen 17-9-1996 for calculating
2109C     local C-intermediate for F-matrix transformation.
2110!
2111!     Modification by Kasper Hald 15-2-1999 for calculating the
2112!     local C-intermediate for triplet energy calculations.
2113!
2114C     Thus:
2115C
2116C     Modification to calculate terms in 2C1 right transformation in
2117C     CCLR :
2118C
2119C                     1. if icon = 2 both contributions are calculated,
2120C                        otherwise if ICON =1:only the integral
2121C                                       TILDE[(ki | ac)]
2122C                              = (k i-bar | a c) + (k i | a-bar c)
2123C
2124C                         3: (k i-bar | a c) + (k i | a-bar c)
2125C                              + FACTC*Sum(xT*int)
2126!                                where xT may be non total symmetric.
2127!
2128!                         4: (k i-bar | a c) - (k i | a-bar c)
2129!
2130C                      2. Allow for general transformation matrix for
2131C                            alpha to a(XLAMPC) and for i (XLAMHC).
2132C                            (the extra i transformation introduces new
2133C                             blocks which is only entered when
2134C                             icon =1 or 3)
2135C
2136C                      3. If icon diff. from 2 (we have linear response)
2137C                            The C intermediate is stored according to
2138C                            the number of simultaneous trial vector
2139C                            given by IV. This is ensured using IT2DLR.
2140C
2141!                      4. ICON = 4 is used for the triplet case.
2142!
2143!
2144C     Thus in energy calc: icon = 2,fact = 1/2
2145C     For right transformation:
2146C         icon=1,fact=anything, iv = current vector being transformed
2147C     For F-matrix transformation:
2148C         icon=3,fact=1.0, NB - not implemented several vectors yet.
2149!     For Triplet calculation:
2150!         icon=4,fact=anything, iv = current vector being transformed
2151!
2152C     Purpose: Calculate C-term intermediate.
2153C
2154      IMPLICIT NONE
2155#include "priunit.h"
2156#include "maxorb.h"
2157#include "ccorb.h"
2158#include "symsq.h"
2159#include "ccsdsym.h"
2160#include "ccsdio.h"
2161!
2162      INTEGER LWORK, ISYMHC, INDEX, ISYAIK, ISYDIS, ISYMPC, ISAIK2
2163      INTEGER ISYMT2, ICON, ISYML, ISYMAG, KSCR10, KEND1, LWRK1
2164      INTEGER KOFF1, ISYMDL, ISYMD, ISYMK, ISYMA, ISYMG, NBASA
2165      INTEGER NBASG, NRHFK, KSCR11, KEND2, LWRK2, KOFF2, NDL, KOFF3
2166      INTEGER KOFF5, KOFF6, ISYMAI, NTOTDL, IOFF, IDEL, IERR
2167      INTEGER KOFF7, KOFF8, ISYMBG, ISYMI, ISYMB, NBASB, KSCR12
2168      INTEGER NAI, MAI, ISYMBJ, ISYDEL, ISYMJ, NVIRB, NTOTBJ
2169      INTEGER ISYMAJ, ISYMBI, NAJ, NBI, NBJ, NAIBJ, NAJBI, KOFF
2170      INTEGER NBIAJ, ISYMAL, ISYALI, NBASAL, MALI, IV, LUC
2171!
2172#if defined (SYS_CRAY)
2173      REAL ZERO, ONE, HALF, XMHALF, TWO, XMONE, FACTC
2174      REAL XINT(*), OMEGA2(*), T2AM(*), DSRHF(*), SCRM(*)
2175      REAL SCR1(*), SCR2(*), SCR3(*), XLAMDP(*), XLAMIP(*), XLAMDH(*)
2176      REAL XLAMPC(*), XLAMHC(ISYMHC), WORK(LWORK)
2177      REAL FACTOR1
2178#else
2179      DOUBLE PRECISION ZERO, ONE, HALF, XMHALF, TWO, XMONE, FACTC
2180      DOUBLE PRECISION XINT(*), OMEGA2(*), T2AM(*), DSRHF(*), SCRM(*)
2181      DOUBLE PRECISION SCR1(*), SCR2(*), SCR3(*), XLAMDP(*), XLAMIP(*)
2182      DOUBLE PRECISION XLAMDH(*), XLAMPC(*), XLAMHC(ISYMHC)
2183      DOUBLE PRECISION WORK(LWORK), FACTOR1
2184#endif
2185!
2186      PARAMETER (ZERO=0.0D00,ONE=1.0D00,HALF=0.5D00,XMHALF=-0.5D00)
2187      PARAMETER (TWO=2.0D00,XMONE= -1.0D00)
2188      CHARACTER CFIL*(*)
2189C
2190      INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J
2191C
2192      CALL QENTER('CCRHS_C31')
2193C
2194      ISYAIK = MULD2H(ISYDIS,ISYMPC)
2195      ISAIK2 = MULD2H(ISYDIS,ISYMT2)
2196      IF (ISYAIK .NE. ISAIK2) THEN
2197          CALL QUIT('Symmetry mismatch in CCRHS_C3')
2198      ENDIF
2199C
2200C-------------------------------------------------------
2201C     Calculate the integrals K(k,dl) = (k d | l delta).
2202C-------------------------------------------------------
2203C
2204      IF ((ICON .EQ. 2) .OR. (ICON .EQ. 3)) THEN
2205C
2206         DO 100 ISYML = 1,NSYM
2207C
2208            ISYMAG = MULD2H(ISYML,ISYDIS)
2209C
2210            DO 110 L = 1,NRHF(ISYML)
2211C
2212               KSCR10 = 1
2213               KEND1  = KSCR10 + N2BST(ISYMAG)
2214               LWRK1  = LWORK  - KEND1
2215               IF (LWRK1 .LT. 0) THEN
2216                  CALL QUIT('Not enough space for '//
2217     &                 'allocation in CCRHS_C31(1)')
2218               END IF
2219C
2220               KOFF1 = IDSRHF(ISYMAG,ISYML) + NNBST(ISYMAG)*(L-1) + 1
2221               CALL CCSD_SYMSQ(DSRHF(KOFF1),ISYMAG,WORK(KSCR10))
2222C
2223               DO 120 ISYMDL = 1,NSYM
2224C
2225                  ISYMD = MULD2H(ISYML,ISYMDL)
2226                  ISYMK = MULD2H(ISYMDL,ISYDIS)
2227                  ISYMA = ISYMK
2228                  ISYMG = ISYMD
2229C
2230                  NBASA = MAX(NBAS(ISYMA),1)
2231                  NBASG = MAX(NBAS(ISYMG),1)
2232                  NRHFK = MAX(NRHF(ISYMK),1)
2233C
2234                  KSCR11 = KEND1
2235                  KEND2  = KSCR11 + NRHF(ISYMK)*NBAS(ISYMG)
2236                  LWRK2  = LWORK  - KEND2
2237                  IF (LWRK2 .LT. 0) THEN
2238                     CALL QUIT('Not enough space for '//
2239     *                      'allocation in CCRHS_C31 (2)')
2240                  END IF
2241C
2242                  KOFF2 = ILMRHF(ISYMK) + 1
2243                  KOFF3 = IAODIS(ISYMA,ISYMG) + 1
2244C
2245                  CALL DGEMM('T','N',NRHF(ISYMK),NBAS(ISYMG),
2246     *                       NBAS(ISYMA),ONE,XLAMDP(KOFF2),NBASA,
2247     *                       WORK(KOFF3),NBASA,
2248     *                       ZERO,WORK(KSCR11),NRHFK)
2249C
2250                  NDL   = IT1AM(ISYMD,ISYML)
2251     *                  + NVIR(ISYMD)*(L - 1) + 1
2252                  KOFF5 = ILMVIR(ISYMD) + 1
2253                  KOFF6 = IT2BCT(ISYMK,ISYMDL)
2254     *                  + NRHF(ISYMK)*(NDL - 1) + 1
2255C
2256                  CALL DGEMM('N','N',NRHF(ISYMK),NVIR(ISYMD),
2257     *                       NBAS(ISYMG),ONE,WORK(KSCR11),NRHFK,
2258     *                       XLAMDH(KOFF5),NBASG,
2259     *                       ZERO,SCR1(KOFF6),NRHFK)
2260C
2261  120          CONTINUE
2262C
2263  110       CONTINUE
2264C
2265  100    CONTINUE
2266C
2267C-----------------------------------------
2268C        Calculate the first contribution.
2269C        Sum(dl)T(al,di)*I(lckd)
2270C-----------------------------------------
2271C
2272         IF (LWORK .LT. NT2BCD(ISYAIK)) THEN
2273            CALL QUIT('Insufficient work space in CCRHS_C31 (3)')
2274         ENDIF
2275C
2276         DO 200 ISYMK  = 1,NSYM
2277C
2278            ISYMAI = MULD2H(ISYAIK,ISYMK)
2279            ISYMDL = MULD2H(ISYDIS,ISYMK)
2280C
2281            NRHFK  = MAX(NRHF(ISYMK),1)
2282            NTOTDL = MAX(NT1AM(ISYMDL),1)
2283C
2284            KOFF1 = IT2BCT(ISYMK,ISYMDL) + 1
2285            KOFF2 = IT2SQ(ISYMDL,ISYMAI) + 1
2286            KOFF3 = IT2BCT(ISYMK,ISYMAI) + 1
2287C
2288            CALL DGEMM('N','N',NRHF(ISYMK),NT1AM(ISYMAI),NT1AM(ISYMDL),
2289     *                 ONE,SCR1(KOFF1),NRHFK,T2AM(KOFF2),NTOTDL,ZERO,
2290     *                 WORK(KOFF3),NRHFK)
2291C
2292  200    CONTINUE
2293!
2294            CALL DCOPY(NT2BCD(ISYAIK),WORK,1,SCR1,1)
2295!
2296      ENDIF
2297!
2298C----------------------------------------------------------
2299C     Calculate the integrals K(k,ai) = (k i | alfa delta).
2300C----------------------------------------------------------
2301C
2302      DO 300 ISYMA = 1,NSYM
2303C
2304         ISYMBG = MULD2H(ISYMA,ISYDIS)
2305C
2306         KSCR10 = 1
2307         KEND1  = KSCR10 + N2BST(ISYMBG)
2308         LWRK1  = LWORK  - KEND1
2309         IF (LWRK1 .LT. 0) THEN
2310            CALL QUIT(
2311     *           'Not enough space for allocation in CCRHS_C31 (4)')
2312         END IF
2313C
2314         DO 310 A = 1,NBAS(ISYMA)
2315C
2316            KOFF1 = IDSAOG(ISYMA,ISYDIS) + NNBST(ISYMBG)*(A - 1) + 1
2317            CALL CCSD_SYMSQ(XINT(KOFF1),ISYMBG,WORK(KSCR10))
2318C
2319            DO 320 ISYMG = 1,NSYM
2320C
2321               ISYMI  = ISYMG
2322               ISYMB  = MULD2H(ISYMG,ISYMBG)
2323               ISYMK  = ISYMB
2324               ISYMAI = MULD2H(ISYMA,ISYMI)
2325C
2326               NBASB = MAX(NBAS(ISYMB),1)
2327               NBASG = MAX(NBAS(ISYMG),1)
2328               NRHFK = MAX(NRHF(ISYMK),1)
2329C
2330               KSCR11 = KEND1
2331               KSCR12 = KSCR11 + NRHF(ISYMK)*NBAS(ISYMG)
2332               KEND2  = KSCR12 + NRHF(ISYMK)*NRHF(ISYMI)
2333               LWRK2  = LWORK  - KEND2
2334               IF (LWRK2 .LT. 0) THEN
2335                  CALL QUIT('Not enough space for '//
2336     &                 'allocation in CCRHS_C31(5)')
2337               END IF
2338C
2339               KOFF2 = ILMRHF(ISYMK) + 1
2340               KOFF3 = KSCR10 + IAODIS(ISYMB,ISYMG)
2341C
2342               CALL DGEMM('T','N',NRHF(ISYMK),NBAS(ISYMG),NBAS(ISYMB),
2343     *                    ONE,XLAMDP(KOFF2),NBASB,WORK(KOFF3),NBASB,
2344     *                    ZERO,WORK(KSCR11),NRHFK)
2345C
2346               KOFF5 = ILMRHF(ISYMI) + 1
2347C
2348                   CALL DGEMM('N','N',NRHF(ISYMK),NRHF(ISYMI),
2349     &                        NBAS(ISYMG),ONE,WORK(KSCR11),NRHFK,
2350     &                        XLAMDH(KOFF5),NBASG,
2351     &                        ZERO,WORK(KSCR12),NRHFK)
2352C
2353               DO 330 I = 1,NRHF(ISYMI)
2354C
2355                  NAI = IT1AO(ISYMA,ISYMI) + NBAS(ISYMA)*(I-1) + A
2356C
2357                  KOFF8 = IT2BGT(ISYMK,ISYMAI)
2358     *                  + NRHF(ISYMK)*(NAI - 1) + 1
2359                  KOFF7 = KSCR12 + NRHF(ISYMK)*(I - 1)
2360C
2361                  CALL DCOPY(NRHF(ISYMK),WORK(KOFF7),1,SCR2(KOFF8),1)
2362C
2363  330          CONTINUE
2364C
2365C
2366C-------------------------------------------------------
2367C              In 2C1 linear transformation extra  cont.
2368C-------------------------------------------------------
2369C
2370               IF ((ICON .EQ. 3) .OR. (ICON .EQ. 1) .OR.
2371     &              (ICON .EQ. 4)) THEN
2372C
2373                  ISYMI  = MULD2H(ISYMG,ISYMHC)
2374                  ISYMAI = MULD2H(ISYMA,ISYMI)
2375C
2376                  KEND2  = KSCR12 + NRHF(ISYMK)*NRHF(ISYMI)
2377                  LWRK2  = LWORK  - KEND2
2378                  IF (LWRK2 .LT. 0) THEN
2379                     CALL QUIT('Not enough space for '//
2380     &                    'allocation in CCRHS_C31')
2381                  END IF
2382C
2383                  KOFF5 = IGLMRH(ISYMG,ISYMI) + 1
2384C
2385                  IF (ICON .EQ. 4) THEN
2386                     FACTOR1 = XMONE
2387                  ELSE
2388                     FACTOR1 = ONE
2389                  ENDIF
2390!
2391                  CALL DGEMM('N','N',NRHF(ISYMK),NRHF(ISYMI),
2392     *                       NBAS(ISYMG),FACTOR1,WORK(KSCR11),NRHFK,
2393     *                       XLAMHC(KOFF5),NBASG,
2394     *                       ZERO,WORK(KSCR12),NRHFK)
2395C
2396                  DO 331 I = 1,NRHF(ISYMI)
2397C
2398                     NAI = IT1AO(ISYMA,ISYMI) + NBAS(ISYMA)*(I-1) + A
2399C
2400                     KOFF8 = IT2BGT(ISYMK,ISYMAI)
2401     *                     + NRHF(ISYMK)*(NAI - 1) + 1
2402                     KOFF7 = KSCR12 + NRHF(ISYMK)*(I - 1)
2403C
2404                     CALL DCOPY(NRHF(ISYMK),WORK(KOFF7),1,SCR3(KOFF8),1)
2405C
2406  331             CONTINUE
2407C
2408               ENDIF
2409C
2410  320       CONTINUE
2411C
2412  310    CONTINUE
2413C
2414  300 CONTINUE
2415
2416C
2417      IF (.NOT. DUMPCD) THEN
2418C
2419C-----------------------------------------
2420C     Back transformation to the AO basis.
2421C-----------------------------------------
2422C
2423      DO 400 ISYMAI = 1,NSYM
2424C
2425         ISYMK = MULD2H(ISYMAI,ISYDIS)
2426C
2427         NRHFK = MAX(NRHF(ISYMK),1)
2428C
2429         DO 410 ISYMI = 1,NSYM
2430C
2431            ISYMA = MULD2H(ISYMI,ISYMAI)
2432C
2433            NBASA = MAX(NBAS(ISYMA),1)
2434C
2435            DO 420 I = 1,NRHF(ISYMI)
2436C
2437               NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + 1
2438               MAI = IT1AO(ISYMA,ISYMI) + NBAS(ISYMA)*(I - 1) + 1
2439C
2440               KOFF1 = IT2BCT(ISYMK,ISYMAI) + NRHF(ISYMK)*(NAI - 1) + 1
2441               KOFF2 = ILMVIR(ISYMA) + 1
2442               KOFF3 = IT2BGT(ISYMK,ISYMAI) + NRHF(ISYMK)*(MAI - 1) + 1
2443C
2444               CALL DGEMM('N','T',NRHF(ISYMK),NBAS(ISYMA),NVIR(ISYMA),
2445     *                    XMHALF,SCR1(KOFF1),NRHFK,XLAMIP(KOFF2),NBASA,
2446     *                    ONE,SCR2(KOFF3),NRHFK)
2447C
2448  420       CONTINUE
2449C
2450  410    CONTINUE
2451C
2452  400 CONTINUE
2453C
2454C
2455      DO 500 ISYMK = 1,NSYM
2456C
2457         ISYMBJ = MULD2H(ISYMK,ISYDEL)
2458C
2459         DO 510 K = 1,NRHF(ISYMK)
2460C
2461            DO 520 ISYMJ = 1,NSYM
2462C
2463               ISYMB = MULD2H(ISYMJ,ISYMBJ)
2464C
2465               NBASB = MAX(NBAS(ISYMB),1)
2466               NVIRB = MAX(NVIR(ISYMB),1)
2467C
2468               KOFF1 = ILMVIR(ISYMB) + 1
2469               KOFF2 = IT2BCD(ISYMBJ,ISYMK) + NT1AM(ISYMBJ)*(K - 1)
2470     *               + IT1AM(ISYMB,ISYMJ) + 1
2471               KOFF3 = IT2BGD(ISYMBJ,ISYMK) + NT1AO(ISYMBJ)*(K - 1)
2472     *               + IT1AO(ISYMB,ISYMJ) + 1
2473C
2474               CALL DGEMM('N','N',NBAS(ISYMB),NRHF(ISYMJ),NVIR(ISYMB),
2475     *                    ONE,XLAMIP(KOFF1),NBASB,SCRM(KOFF2),NVIRB,
2476     *                    ZERO,SCR3(KOFF3),NBASB)
2477C
2478  520       CONTINUE
2479C
2480  510    CONTINUE
2481C
2482  500 CONTINUE
2483C
2484C---------------------------------------
2485C     Calculate the second contribution.
2486C
2487C     Alfredo will introduce the batching over ai before the
2488C     end of august 1994.
2489C---------------------------------------
2490C
2491      DO 600 ISYMAI = 1,NSYM
2492C
2493         ISYMK  = MULD2H(ISYMAI,ISYDIS)
2494         ISYMBJ = MULD2H(ISYMK,ISYDEL)
2495C
2496         IF (NRHF(ISYMK) .EQ. 0) GOTO 600
2497C
2498         IF (LWORK .LT. NT1AO(ISYMBJ)) THEN
2499            CALL QUIT('Insufficient work space in CCRHS_C1')
2500         ENDIF
2501C
2502         NTOTBJ = MAX(NT1AO(ISYMBJ),1)
2503C
2504         DO 610 ISYMI = 1,NSYM
2505C
2506            ISYMA = MULD2H(ISYMI,ISYMAI)
2507C
2508            DO 620 I = 1,NRHF(ISYMI)
2509C
2510               DO 630 A = 1,NBAS(ISYMA)
2511C
2512                  NAI = IT1AO(ISYMA,ISYMI) + NBAS(ISYMA)*(I-1) + A
2513C
2514                  KOFF1 = IT2BGD(ISYMBJ,ISYMK) + 1
2515                  KOFF2 = IT2BGT(ISYMK,ISYMAI)
2516     *                  + NRHF(ISYMK)*(NAI - 1) + 1
2517C
2518                  CALL DGEMV('N',NT1AO(ISYMBJ),NRHF(ISYMK),ONE,
2519     *                       SCR3(KOFF1),NTOTBJ,SCR2(KOFF2),1,
2520     *                       ZERO,WORK,1)
2521C
2522                  IF (.NOT. OMEGSQ) THEN
2523C
2524C
2525                  IF (ISYMAI .EQ. ISYMBJ) THEN
2526                     WORK(NAI) = TWO*WORK(NAI)
2527                  ENDIF
2528C
2529                  DO 640 ISYMJ = 1,NSYM
2530C
2531                     ISYMB  = MULD2H(ISYMJ,ISYMBJ)
2532                     ISYMAJ = MULD2H(ISYMA,ISYMJ)
2533                     ISYMBI = MULD2H(ISYMB,ISYMI)
2534C
2535                     DO 650 J = 1,NRHF(ISYMJ)
2536C
2537                        NAJ = IT1AO(ISYMA,ISYMJ) + NBAS(ISYMA)*(J-1) + A
2538C
2539                        DO 660 B = 1,NBAS(ISYMB)
2540C
2541                           NBI = IT1AO(ISYMB,ISYMI)
2542     *                         + NBAS(ISYMB)*(I-1) + B
2543                           NBJ = IT1AO(ISYMB,ISYMJ)
2544     *                         + NBAS(ISYMB)*(J-1) + B
2545C
2546                           NAIBJ = IT2AO(ISYMAI,ISYMBJ) + INDEX(NAI,NBJ)
2547                           NAJBI = IT2AO(ISYMAJ,ISYMBI) + INDEX(NAJ,NBI)
2548C
2549                           OMEGA2(NAIBJ) = OMEGA2(NAIBJ)-HALF*WORK(NBJ)
2550                           OMEGA2(NAJBI) = OMEGA2(NAJBI)-WORK(NBJ)
2551C
2552  660                   CONTINUE
2553  650                CONTINUE
2554  640             CONTINUE
2555C
2556C
2557                  ELSE
2558C
2559C
2560                  KOFF = IT2AOS(ISYMBJ,ISYMAI)
2561     *                 + NT1AO(ISYMBJ)*(NAI - 1) + 1
2562                  CALL DAXPY(NT1AO(ISYMBJ),-HALF,WORK,1,OMEGA2(KOFF),1)
2563C
2564                  DO 740 ISYMJ = 1,NSYM
2565C
2566                     ISYMB  = MULD2H(ISYMJ,ISYMBJ)
2567                     ISYMAJ = MULD2H(ISYMA,ISYMJ)
2568                     ISYMBI = MULD2H(ISYMB,ISYMI)
2569C
2570                     NBI = IT1AO(ISYMB,ISYMI) + NBAS(ISYMB)*(I-1) + 1
2571C
2572                     DO 750 J = 1,NRHF(ISYMJ)
2573C
2574                        NAJ = IT1AO(ISYMA,ISYMJ) + NBAS(ISYMA)*(J-1) + A
2575                        NBJ = IT1AO(ISYMB,ISYMJ) + NBAS(ISYMB)*(J-1) + 1
2576C
2577                        NBIAJ = IT2AOS(ISYMBI,ISYMAJ)
2578     *                        + NT1AO(ISYMBI)*(NAJ - 1) + NBI
2579C
2580                        CALL DAXPY(NBAS(ISYMB),-ONE,WORK(NBJ),1,
2581     *                             OMEGA2(NBIAJ),1)
2582C
2583  750                CONTINUE
2584  740             CONTINUE
2585C
2586                  ENDIF
2587C
2588  630          CONTINUE
2589  620       CONTINUE
2590C
2591  610    CONTINUE
2592  600 CONTINUE
2593C
2594      GOTO 999
2595C
2596C-------------------
2597C     I/O algorithm.
2598C-------------------
2599C
2600      ENDIF
2601C
2602C-----------------------------------------------
2603C     Transform the alpha index of K(k,ai) to a.
2604C-----------------------------------------------
2605C
2606      ISYAIK = MULD2H(ISYDIS,ISYMPC)
2607C
2608      IF ((ICON .EQ. 1) .OR. (ICON .EQ. 4)) THEN
2609          CALL DZERO(SCR1,NT2BCD(ISYAIK))
2610      ENDIF
2611C
2612      DO 810 ISYMAI = 1,NSYM
2613C
2614         ISYMK = MULD2H(ISYMAI,ISYAIK)
2615         NRHFK = MAX(NRHF(ISYMK),1)
2616C
2617         DO 820 ISYMI = 1,NSYM
2618C
2619            ISYMA = MULD2H(ISYMI,ISYMAI)
2620            ISYMAL= MULD2H(ISYMPC,ISYMA)
2621            ISYALI= MULD2H(ISYMAL,ISYMI)
2622            NBASAL = MAX(NBAS(ISYMAL),1)
2623C
2624            DO 830 I = 1,NRHF(ISYMI)
2625C
2626               NAI  = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + 1
2627               MALI = IT1AO(ISYMAL,ISYMI) + NBAS(ISYMAL)*(I - 1) + 1
2628C
2629               KOFF1 = IT2BGT(ISYMK,ISYALI) + NRHF(ISYMK)*(MALI- 1) + 1
2630               KOFF2 = IGLMVI(ISYMAL,ISYMA) + 1
2631               KOFF3 = IT2BCT(ISYMK,ISYMAI) + NRHF(ISYMK)*(NAI - 1) + 1
2632C
2633               CALL DGEMM('N','N',NRHF(ISYMK),NVIR(ISYMA),NBAS(ISYMAL),
2634     *                    ONE,SCR2(KOFF1),NRHFK,XLAMPC(KOFF2),NBASAL,
2635     *                    FACTC,SCR1(KOFF3),NRHFK)
2636C
2637  830       CONTINUE
2638  820    CONTINUE
2639  810 CONTINUE
2640C
2641C-----------------------------------------------
2642C     Transform the alpha index of K(k,ai) to a.
2643C     I is C1 transformed.
2644C-----------------------------------------------
2645C
2646      IF ((ICON .EQ. 3) .OR. (ICON .EQ. 1) .OR. (ICON .EQ. 4)) THEN
2647C
2648         ISYAIK = MULD2H(ISYDIS,ISYMHC)
2649C
2650         DO 850 ISYMAI = 1,NSYM
2651C
2652            ISYMK = MULD2H(ISYMAI,ISYAIK)
2653            NRHFK = MAX(NRHF(ISYMK),1)
2654C
2655            DO 860 ISYMI = 1,NSYM
2656C
2657               ISYMA = MULD2H(ISYMI,ISYMAI)
2658               ISYMAL= ISYMA
2659               ISYALI= MULD2H(ISYMAL,ISYMI)
2660               NBASAL = MAX(NBAS(ISYMAL),1)
2661C
2662               DO 870 I = 1,NRHF(ISYMI)
2663C
2664                  NAI = IT1AM(ISYMA,ISYMI)
2665     *                + NVIR(ISYMA)*(I - 1) + 1
2666                  MALI = IT1AO(ISYMAL,ISYMI)
2667     *                 + NBAS(ISYMAL)*(I - 1) + 1
2668C
2669                  KOFF1 = IT2BGT(ISYMK,ISYALI)
2670     *                  + NRHF(ISYMK)*(MALI - 1) + 1
2671                  KOFF2 = ILMVIR(ISYMA) + 1
2672                  KOFF3 = IT2BCT(ISYMK,ISYMAI)
2673     *                  + NRHF(ISYMK)*(NAI - 1) + 1
2674C
2675                  CALL DGEMM('N','N',NRHF(ISYMK),NVIR(ISYMA),
2676     *                       NBAS(ISYMAL),ONE,SCR3(KOFF1),NRHFK,
2677     *                       XLAMDP(KOFF2),NBASAL,
2678     *                       ONE,SCR1(KOFF3),NRHFK)
2679C
2680  870          CONTINUE
2681  860       CONTINUE
2682  850    CONTINUE
2683C
2684      ENDIF
2685C
2686C---------------------------------------------------------
2687C     Dump to disk the new contribution.
2688C---------------------------------------------------------
2689C
2690      IF ( ICON .EQ. 2 ) THEN
2691C
2692         IOFF = IT2DEL(IDEL) + 1
2693C
2694      ELSE
2695C
2696         IOFF = IT2DLR(IDEL,IV) + 1
2697C
2698      ENDIF
2699C
2700      IF (NT2BCD(ISYAIK) .GT. 0) THEN
2701         CALL PUTWA2(LUC,CFIL,SCR1,IOFF,NT2BCD(ISYAIK))
2702      ENDIF
2703C
2704  999 CONTINUE
2705C
2706      CALL QEXIT('CCRHS_C31')
2707C
2708      RETURN
2709      END
2710C  /* Deck ccrhs_t2tr */
2711      SUBROUTINE CCRHS3_T2TR(T2AM,WORK,LWORK,ISYM,IOPT)
2712C
2713C     Alfredo Sanchez and Henrik Koch 30-July 1994
2714C
2715!     19-03-99: Kasper Hald
2716!     Generalized to calculate only the last term i.e.
2717!     only exchange (IOPT = 2)
2718!
2719!     IOPT = 1 : The normal 2T2 - T2
2720!     IOPT = 2 : Only exchange
2721!
2722C     PURPOSE:
2723C             Calculate two coulomb minus exchange of t2 amplitudes,
2724C             Calculate only minus the exchange term.
2725C             The amplitudes are assumed to be a square matrix.
2726C
2727      IMPLICIT NONE
2728#include "priunit.h"
2729#include "ccorb.h"
2730#include "ccsdsym.h"
2731!
2732      INTEGER LWORK, ISYMJ, ISYMB, ISYMBJ, ISYMAI, ISYM, NBJ, ISYMI
2733      INTEGER ISYMA, ISYMAJ, ISYMBI, KSCR1, KSCR2, KEND1, LWRK1
2734      INTEGER NRHFI, NBI, NAIBJ, NAJBI, IOPT, KOFF
2735!
2736#if defined (SYS_CRAY)
2737      REAL ONE, TWO, ZERO, XMONE
2738      REAL T2AM(*), WORK(LWORK)
2739#else
2740      DOUBLE PRECISION ONE, TWO, ZERO, XMONE
2741      DOUBLE PRECISION T2AM(*), WORK(LWORK)
2742#endif
2743      PARAMETER (ONE = 1.0D00, TWO = 2.0D00, ZERO = 0.0D00)
2744      PARAMETER (XMONE = -1.0D00)
2745C
2746      CALL QENTER('CCRHS3_T2TR')
2747C
2748C----------------------------------------------------------
2749C     Calculate two coulomb minus exchange of t2-amplitude,
2750C     or minus exchange.
2751C----------------------------------------------------------
2752C
2753      DO 100 ISYMJ = 1,NSYM
2754C
2755         DO 110 J = 1,NRHF(ISYMJ)
2756C
2757            DO 120 ISYMB = 1,NSYM
2758C
2759               ISYMBJ = MULD2H(ISYMB,ISYMJ)
2760               ISYMAI = MULD2H(ISYMBJ,ISYM)
2761C
2762               DO 130 B = 1,NVIR(ISYMB)
2763C
2764                  NBJ = IT1AM(ISYMB,ISYMJ)+NVIR(ISYMB)*(J-1)+B
2765C
2766                  DO 140 ISYMI = 1,ISYMJ
2767C
2768                     ISYMA  = MULD2H(ISYMI,ISYMAI)
2769                     ISYMAJ = MULD2H(ISYMA,ISYMJ)
2770                     ISYMBI = MULD2H(ISYMB,ISYMI)
2771C
2772                     KSCR1 = 1
2773                     KSCR2 = KSCR1 + NVIR(ISYMA)
2774                     KEND1 = KSCR2 + NVIR(ISYMA)
2775                     LWRK1 = LWORK - KEND1
2776                     IF (LWRK1 .LT. 0) THEN
2777                        CALL QUIT('Insufficient space in CCRHS3_T2TR')
2778                     ENDIF
2779C
2780                     IF (ISYMI .EQ. ISYMJ) THEN
2781                        NRHFI = J - 1
2782                     ELSE
2783                        NRHFI = NRHF(ISYMI)
2784                     END IF
2785C
2786                     DO 150 I = 1,NRHFI
2787C
2788                        NBI = IT1AM(ISYMB,ISYMI)+NVIR(ISYMB)*(I-1)+B
2789C
2790                        NAIBJ = IT2SQ(ISYMAI,ISYMBJ)
2791     *                        + NT1AM(ISYMAI)*(NBJ-1)
2792     *                        + IT1AM(ISYMA,ISYMI)+NVIR(ISYMA)*(I-1)+1
2793C
2794                        NAJBI = IT2SQ(ISYMAJ,ISYMBI)
2795     *                        + NT1AM(ISYMAJ)*(NBI-1)
2796     *                        + IT1AM(ISYMA,ISYMJ)+NVIR(ISYMA)*(J-1)+1
2797C
2798!
2799                           CALL DCOPY(NVIR(ISYMA),T2AM(NAIBJ),1,
2800     *                                WORK(KSCR1),1)
2801                           CALL DCOPY(NVIR(ISYMA),T2AM(NAJBI),1,
2802     *                                WORK(KSCR2),1)
2803C
2804                        IF (IOPT .EQ. 1) THEN
2805                           CALL DSCAL(NVIR(ISYMA),TWO,T2AM(NAIBJ),1)
2806                           CALL DSCAL(NVIR(ISYMA),TWO,T2AM(NAJBI),1)
2807                        ELSE IF (IOPT .EQ. 2) THEN
2808                           CALL DSCAL(NVIR(ISYMA),ZERO,T2AM(NAIBJ),1)
2809                           CALL DSCAL(NVIR(ISYMA),ZERO,T2AM(NAJBI),1)
2810                        ELSE
2811                           CALL QUIT('IOPT Mismatch in CCRHS3_T2TR ')
2812                        ENDIF
2813!
2814                        CALL DAXPY(NVIR(ISYMA),-ONE,WORK(KSCR2),1,
2815     *                             T2AM(NAIBJ),1)
2816                        CALL DAXPY(NVIR(ISYMA),-ONE,WORK(KSCR1),1,
2817     *                             T2AM(NAJBI),1)
2818C
2819  150               CONTINUE
2820C
2821  140             CONTINUE
2822C
2823  130          CONTINUE
2824C
2825  120       CONTINUE
2826C
2827  110    CONTINUE
2828C
2829  100 CONTINUE
2830C
2831      IF (IPRCC .GT. 20) THEN
2832         IF (IOPT .EQ. 1) THEN
2833            CALL AROUND('Two coulomb minus exchamge of t2am')
2834         ELSE IF (IOPT .EQ. 2) THEN
2835            CALL AROUND('The minus exchange of the T2AM')
2836         ENDIF
2837         DO 200 ISYMBJ = 1,NSYM
2838            ISYMAI = MULD2H(ISYMBJ,ISYM)
2839            KOFF = IT2SQ(ISYMAI,ISYMBJ) + 1
2840            WRITE(LUPRI,*)
2841            WRITE(LUPRI,*) 'Symmetry block:',ISYMBJ
2842            CALL OUTPUT(T2AM(KOFF),1,NT1AM(ISYMAI),1,NT1AM(ISYMBJ),
2843     *                  NT1AM(ISYMAI),NT1AM(ISYMBJ),1,LUPRI)
2844  200    CONTINUE
2845      END IF
2846C
2847      CALL QEXIT('CCRHS3_T2TR')
2848C
2849      RETURN
2850      END
2851C  /* Deck ccrhs_cio */
2852      SUBROUTINE CCRHS3_CIO(OMEGA2,T2AM,XLAMDH,WORK,LWORK,
2853     *                      ISYVEC,ISYCIM,LUC,CFIL,IV,IOPT,FACCN,
2854     *                      NORMALCONT,FACCP,PIJCONT,ANTISYM)
2855!
2856!     asm 17-aug-1994
2857!
2858!     Ove Christiansen 30-7-1995: modified to account for general
2859!                                 non. total symmetric vectors (ISYVEC)
2860!                                 and
2861!                                 intermediates (ISYCIM). LUC and CFIL
2862!                                 is used to control from which file
2863!                                 the intermediate is obtained.
2864!
2865!                                 if iopt = 1 the C intermediate is
2866!                                 assumed to be as in energy clac.
2867!
2868!                                 if iopt ne. 1 we use the intermediate
2869!                                    on luc with address given according
2870!                                    to
2871!                                    transformed vector nr iv (iv is not
2872!                                    1 if several vectros are trans.
2873!                                    simultaneously.)
2874!
2875!
2876!     Kasper Hald 22-3-1999       Modified to calculate the triplet
2877!                                 contributions. Use ANTISYM and FACCN,
2878!                                 NORMALCONT, FACCP, PIJCONT
2879!
2880!                                 in energy calc: iv=1,iopt=1
2881!                                 FACCN = -HALF and FACCP = -1
2882!                                 NORMALCONT = .TRUE.
2883!                                 PIJCONT = .TRUE.
2884!
2885!     PURPOSE:
2886!             Calculate the C-term making I/O
2887!
2888!     N.B. The diagonal is set to zero since the diagonal elements
2889!          are identical zero in the triplet case.
2890!
2891      IMPLICIT NONE
2892!
2893#include "priunit.h"
2894#include "ccorb.h"
2895#include "ccsdsym.h"
2896#include "maxorb.h"
2897#include "ccsdio.h"
2898!
2899      INTEGER LWORK, INDEX, ISAIBJ, ISYVEC, ISYCIM, ISYMAI, ISYMBJ
2900      INTEGER ISYMCK, ISYMDK, NT1AI, LENAI, LENMIN, NDISAI, NBATAI
2901      INTEGER ILSTAI, IBATAI, IFSTAI, KSCR1, KSCR2, KEND, LWRK1
2902      INTEGER KOFF1, ISYDEL, ISYMK, IDELTA, ID, IOPT, IOFF, IV
2903      INTEGER LEN, IERR, NAI, KAI, KOFF2, KOFF3, KOFF4, KOFF5, KOFF6
2904      INTEGER ISYMC, NBASD, NVIRC, NT1BJ, NT1CK, KOFF7, KOFF8
2905      INTEGER ISYMI, ISYMA, ISYMJ, ISYMB, ISYMAJ, ISYMBI, NAJ
2906      INTEGER CCRHSCOUNT, LUC
2907!
2908#if defined (SYS_CRAY)
2909      REAL ZERO, HALF, ONE, TWO, FACCN, FACCP
2910      REAL OMEGA2(*), T2AM(*), XLAMDH(*), WORK(LWORK)
2911#else
2912      DOUBLE PRECISION ZERO, HALF, ONE, TWO, FACCN, FACCP
2913      DOUBLE PRECISION OMEGA2(*), T2AM(*), XLAMDH(*), WORK(LWORK)
2914#endif
2915!
2916      PARAMETER (ZERO= 0.0D00, HALF= 0.5D00, ONE= 1.0D00, TWO= 2.0D00)
2917      CHARACTER CFIL*(*)
2918      LOGICAL ANTISYM, NORMALCONT, PIJCONT
2919!
2920C      INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J
2921!
2922      CALL QENTER('CCRHS3_CIO')
2923!
2924      IF (OMEGSQ) THEN
2925         WRITE(LUPRI,*) 'I/O in C-term not implemented for '//
2926     &        'square Omega2'
2927         CALL QUIT('OMEGSQ = .TRUE.  in CCRHS3_CIO')
2928      END IF
2929!
2930      ISAIBJ = MULD2H(ISYVEC,ISYCIM)
2931!
2932      DO 100 ISYMAI = 1,NSYM
2933!
2934         IF (NT1AM(ISYMAI) .EQ. 0) GOTO 100
2935!
2936         ISYMBJ = MULD2H(ISYMAI,ISAIBJ)
2937         ISYMCK = MULD2H(ISYVEC,ISYMBJ)
2938         ISYMDK = MULD2H(ISYCIM,ISYMAI)
2939!
2940!------------------------
2941!        Batch structure.
2942!------------------------
2943!
2944         NT1AI = NT1AM(ISYMAI)
2945!
2946         LENAI  = NT1AO(ISYMDK)
2947         LENMIN = 2*LENAI
2948         IF (LENMIN .EQ. 0) GOTO 100
2949!
2950         NDISAI = LWORK / LENMIN
2951         IF (NDISAI .LT. 1) THEN
2952            CALL QUIT('Insufficient space for '//
2953     &           'allocation in CCRHS3_CIO-1')
2954         END IF
2955         NDISAI = MIN(NDISAI,NT1AI)
2956!
2957         NBATAI = (NT1AI - 1) / NDISAI + 1
2958!
2959!--------------------------
2960!        Loop over batches.
2961!--------------------------
2962!
2963         ILSTAI = 0
2964         DO 110 IBATAI = 1,NBATAI
2965!
2966            IFSTAI = ILSTAI + 1
2967            ILSTAI = ILSTAI + NDISAI
2968            IF (ILSTAI .GT. NT1AI) THEN
2969               ILSTAI = NT1AI
2970               NDISAI = ILSTAI - IFSTAI + 1
2971            END IF
2972!
2973!-----------------------------
2974!           Memory allocation.
2975!-----------------------------
2976!
2977            KSCR1 = 1
2978            KSCR2 = KSCR1 + NDISAI*NT1AO(ISYMDK)
2979            KEND  = KSCR2 + NDISAI*NT1AO(ISYMDK)
2980            LWRK1 = LWORK - KEND
2981!
2982            IF (LWRK1 .LT. 0) THEN
2983               CALL QUIT('Insufficient space for '//
2984     &              'allocation in CCRHS3_CIO-2')
2985            END IF
2986!
2987!----------------------------------
2988!           Construct P(del k,#ai).
2989!----------------------------------
2990!
2991            KOFF1 = KSCR1
2992            DO 120 ISYDEL = 1,NSYM
2993!
2994               ISYMK = MULD2H(ISYDEL,ISYMDK)
2995!
2996               DO 130 IDELTA = 1,NBAS(ISYDEL)
2997!
2998                  ID = IDELTA + IBAS(ISYDEL)
2999!
3000                  IF (IOPT .EQ. 1 ) THEN
3001                     IOFF = IT2DEL(ID) + IT2BCT(ISYMK,ISYMAI)
3002     *                    + NRHF(ISYMK)*(IFSTAI - 1) + 1
3003                  ELSE
3004                     IOFF = IT2DLR(ID,IV) + IT2BCT(ISYMK,ISYMAI)
3005     *                    + NRHF(ISYMK)*(IFSTAI - 1) + 1
3006                  ENDIF
3007!
3008                  LEN  = NDISAI*NRHF(ISYMK)
3009!
3010                  IF (LEN .GT. 0) THEN
3011                     CALL GETWA2(LUC,CFIL,WORK(KOFF1),IOFF,LEN)
3012                  ENDIF
3013!
3014                  DO 140 NAI = IFSTAI,ILSTAI
3015!
3016                     KAI = NAI - IFSTAI + 1
3017!
3018                     KOFF2 = KOFF1 + NRHF(ISYMK)*(KAI - 1)
3019                     KOFF3 = KSCR2 + NT1AO(ISYMDK)*(KAI - 1)
3020     *                     + IT1AO(ISYDEL,ISYMK) + IDELTA - 1
3021!
3022                     CALL DCOPY(NRHF(ISYMK),WORK(KOFF2),1,WORK(KOFF3),
3023     *                          NBAS(ISYDEL))
3024!
3025  140             CONTINUE
3026!
3027                  KOFF1 = KOFF1 + LEN
3028!
3029  130          CONTINUE
3030  120       CONTINUE
3031!
3032!-----------------------------------------
3033!              Transform delta index to c.
3034!-----------------------------------------
3035!
3036            DO 150 NAI = IFSTAI,ILSTAI
3037!
3038               KAI = NAI - IFSTAI + 1
3039!
3040               DO 160 ISYMC = 1,NSYM
3041!
3042                  ISYDEL = ISYMC
3043                  ISYMK  = MULD2H(ISYMC,ISYMCK)
3044!
3045                  NBASD = MAX(NBAS(ISYDEL),1)
3046                  NVIRC = MAX(NVIR(ISYMC),1)
3047!
3048                  KOFF4 = ILMVIR(ISYDEL) + 1
3049                  KOFF5 = KSCR2 + NT1AO(ISYMDK)*(KAI - 1)
3050     *                  + IT1AO(ISYDEL,ISYMK)
3051                  KOFF6 = KSCR1 + NT1AM(ISYMCK)*(KAI - 1)
3052     *                  + IT1AM(ISYMC,ISYMK)
3053!
3054                  CALL DGEMM('T','N',NVIR(ISYMC),NRHF(ISYMK),
3055     *                       NBAS(ISYDEL),ONE,XLAMDH(KOFF4),NBASD,
3056     *                       WORK(KOFF5),NBASD,ZERO,WORK(KOFF6),
3057     *                       NVIRC)
3058!
3059  160          CONTINUE
3060  150       CONTINUE
3061!
3062!--------------------------------------------
3063!           Contract P(ck,#ai) with T(bj,ck).
3064!--------------------------------------------
3065!
3066            NT1BJ = MAX(NT1AM(ISYMBJ),1)
3067            NT1CK = MAX(NT1AM(ISYMCK),1)
3068!
3069            KOFF7 = IT2SQ(ISYMBJ,ISYMCK) + 1
3070!
3071            CALL DGEMM('N','N',NT1AM(ISYMBJ),NDISAI,NT1AM(ISYMCK),
3072     *                 ONE,T2AM(KOFF7),NT1BJ,WORK(KSCR1),NT1CK,
3073     *                 ZERO,WORK(KSCR2),NT1BJ)
3074!
3075!--------------------------------------------------
3076!           Scale the diagonal with zero if antisym
3077!           since the diagonal is then identical zero
3078!           If not antisym scale the diagonal with
3079!           two.
3080!--------------------------------------------------
3081!
3082               IF (ISYMBJ .EQ. ISYMAI) THEN
3083!
3084                  DO 170 NAI = IFSTAI,ILSTAI
3085                    KOFF8 = KSCR2 + NT1AM(ISYMBJ)*(NAI-IFSTAI) + NAI - 1
3086                    IF (ANTISYM) THEN
3087                    WORK(KOFF8) = ZERO * WORK(KOFF8)
3088                    ELSE
3089                    WORK(KOFF8) = TWO * WORK(KOFF8)
3090                    ENDIF
3091  170             CONTINUE
3092!
3093               END IF
3094!
3095!-----------------------------------------------
3096!           Add the result to the packed omega2.
3097!-----------------------------------------------
3098!
3099            DO 180 ISYMI = 1,NSYM
3100!
3101               ISYMA = MULD2H(ISYMI,ISYMAI)
3102!
3103               DO 190 I = 1,NRHF(ISYMI)
3104!
3105                  DO 200 A = 1,NVIR(ISYMA)
3106!
3107                     NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + A
3108                     IF ((NAI .LT. IFSTAI) .OR. (NAI .GT. ILSTAI))
3109     *                  GOTO 200
3110!
3111                     DO 210 ISYMJ = 1,NSYM
3112!
3113                        ISYMB  = MULD2H(ISYMJ,ISYMBJ)
3114                        ISYMAJ = MULD2H(ISYMA,ISYMJ)
3115                        ISYMBI = MULD2H(ISYMB,ISYMI)
3116!
3117                        DO 220 J = 1,NRHF(ISYMJ)
3118!
3119                           NAJ = IT1AM(ISYMA,ISYMJ)
3120     *                         + NVIR(ISYMA)*(J-1) + A
3121!
3122                           CALL CC_PUTC3(WORK(KSCR2),OMEGA2,ISYMAI,
3123     *                                  ISYMAJ,ISYMBI,ISYMBJ,ISYMB,
3124     *                                  ISYMI,ISYMJ,NAI,NAJ,I,J,
3125     *                                  IFSTAI,FACCN,NORMALCONT,
3126     *                                  FACCP,PIJCONT,ANTISYM)
3127!
3128  220                   CONTINUE
3129  210                CONTINUE
3130  200             CONTINUE
3131  190          CONTINUE
3132  180       CONTINUE
3133!
3134  110    CONTINUE
3135  100 CONTINUE
3136!
3137      CALL QEXIT('CCRHS3_CIO')
3138!
3139      RETURN
3140      END
3141!  /* Deck cc_putc */
3142      SUBROUTINE CC_PUTC3(SCR2,OMEGA2,ISYMAI,ISYMAJ,ISYMBI,ISYMBJ,
3143     *                   ISYMB,ISYMI,ISYMJ,NAI,NAJ,I,J,IFSTAI,FACCN,
3144     *                   NORMALCONT,FACCP,PIJCONT,ANTISYM)
3145!
3146!     Ove Christiansen 30-10-1995: Put in C contribution in omega vector
3147!                                  avoid troble on cray with optimizatio
3148!
3149!     Kasper Hald Spring 1999 : Generalized to triplet excitation
3150!                               energies
3151!.
3152!
3153      IMPLICIT NONE
3154!
3155#include "priunit.h"
3156#include "ccorb.h"
3157#include "ccsdsym.h"
3158#include "maxorb.h"
3159#include "ccsdio.h"
3160!
3161      INTEGER INDEX, ISYMAI, ISYMBJ, ISYMB, NBJ, ISYMJ, KOFF9, NAI
3162      INTEGER IFSTAI, NAIBJ, ISYMAJ, ISYMBI, NBI, NAJBI, ISYMI, NAJ
3163!
3164#if defined (SYS_CRAY)
3165      REAL ZERO, HALF, ONE, TWO, FACCN, FACCP
3166      REAL SCR2(*), OMEGA2(*)
3167#else
3168      DOUBLE PRECISION ZERO, HALF, ONE, TWO, FACCN, FACCP
3169      DOUBLE PRECISION SCR2(*), OMEGA2(*)
3170#endif
3171!
3172      LOGICAL NORMALCONT, PIJCONT, ANTISYM
3173      PARAMETER (ZERO= 0.0D00, HALF= 0.5D00, ONE= 1.0D00, TWO= 2.0D00)
3174!
3175      INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J
3176!
3177      CALL QENTER('CC_PUTC3')
3178!
3179!------------------------------
3180!     Symmetric cont.
3181!------------------------------
3182!
3183      IF (.NOT. ANTISYM) THEN
3184!
3185        IF (NORMALCONT) THEN
3186!
3187          IF ( ISYMAI .EQ. ISYMBJ ) THEN
3188!
3189            DO B = 1,NVIR(ISYMB)
3190!
3191               NBJ = IT1AM(ISYMB,ISYMJ)
3192     *             + NVIR(ISYMB)*(J-1) + B
3193               KOFF9 = NT1AM(ISYMBJ)*(NAI - IFSTAI) + NBJ
3194               NAIBJ = IT2AM(ISYMAI,ISYMBJ)
3195     *               + INDEX(NAI,NBJ)
3196               OMEGA2(NAIBJ) = OMEGA2(NAIBJ)
3197     *                    + FACCN * SCR2(KOFF9)
3198C
3199            ENDDO
3200C
3201           ENDIF
3202C
3203           IF ( ISYMAI .LT. ISYMBJ ) THEN
3204C
3205            DO B = 1,NVIR(ISYMB)
3206C
3207               NBJ = IT1AM(ISYMB,ISYMJ)
3208     *             + NVIR(ISYMB)*(J-1) + B
3209               KOFF9 = NT1AM(ISYMBJ)*(NAI - IFSTAI) + NBJ
3210               NAIBJ = IT2AM(ISYMAI,ISYMBJ)
3211     *               + NT1AM(ISYMAI)*(NBJ - 1) + NAI
3212               OMEGA2(NAIBJ) = OMEGA2(NAIBJ)
3213     *                    + FACCN * SCR2(KOFF9)
3214C
3215            ENDDO
3216C
3217           ENDIF
3218C
3219           IF ( ISYMBJ .LT. ISYMAI ) THEN
3220C
3221            DO B = 1,NVIR(ISYMB)
3222C
3223               NBJ = IT1AM(ISYMB,ISYMJ)
3224     *             + NVIR(ISYMB)*(J-1) + B
3225               KOFF9 = NT1AM(ISYMBJ)*(NAI - IFSTAI) + NBJ
3226               NAIBJ = IT2AM(ISYMAI,ISYMBJ)
3227     *               + NT1AM(ISYMBJ)*(NAI - 1) + NBJ
3228               OMEGA2(NAIBJ) = OMEGA2(NAIBJ)
3229     *                    + FACCN * SCR2(KOFF9)
3230C
3231            ENDDO
3232C
3233           ENDIF
3234!
3235      ENDIF
3236C
3237      IF (PIJCONT) THEN
3238!
3239         IF (ISYMAJ .EQ. ISYMBI) THEN
3240C
3241            DO B = 1,NVIR(ISYMB)
3242C
3243               NBI = IT1AM(ISYMB,ISYMI)
3244     *             + NVIR(ISYMB)*(I-1) + B
3245               NBJ = IT1AM(ISYMB,ISYMJ)
3246     *             + NVIR(ISYMB)*(J-1) + B
3247               KOFF9 = NT1AM(ISYMBJ)*(NAI - IFSTAI) + NBJ
3248               NAJBI = IT2AM(ISYMAJ,ISYMBI)
3249     *               + INDEX(NAJ,NBI)
3250               OMEGA2(NAJBI) = OMEGA2(NAJBI) + FACCP*SCR2(KOFF9)
3251C
3252            ENDDO
3253C
3254          ENDIF
3255C
3256        IF (ISYMAJ .LT. ISYMBI) THEN
3257C
3258           DO B = 1,NVIR(ISYMB)
3259C
3260              NBI = IT1AM(ISYMB,ISYMI)
3261     *            + NVIR(ISYMB)*(I-1) + B
3262              NBJ = IT1AM(ISYMB,ISYMJ)
3263     *            + NVIR(ISYMB)*(J-1) + B
3264              KOFF9 = NT1AM(ISYMBJ)*(NAI - IFSTAI) + NBJ
3265              NAJBI = IT2AM(ISYMAJ,ISYMBI)
3266     *              + NT1AM(ISYMAJ)*(NBI - 1)
3267     *              + NAJ
3268              OMEGA2(NAJBI) = OMEGA2(NAJBI) + FACCP*SCR2(KOFF9)
3269C
3270           ENDDO
3271C
3272         ENDIF
3273C
3274        IF (ISYMBI .LT. ISYMAJ) THEN
3275C
3276           DO B = 1,NVIR(ISYMB)
3277C
3278              NBI = IT1AM(ISYMB,ISYMI)
3279     *            + NVIR(ISYMB)*(I-1) + B
3280              NBJ = IT1AM(ISYMB,ISYMJ)
3281     *            + NVIR(ISYMB)*(J-1) + B
3282              KOFF9 = NT1AM(ISYMBJ)*(NAI - IFSTAI) + NBJ
3283              NAJBI = IT2AM(ISYMAJ,ISYMBI)
3284     *              + NT1AM(ISYMBI)*(NAJ - 1)
3285     *              + NBI
3286              OMEGA2(NAJBI) = OMEGA2(NAJBI) + FACCP*SCR2(KOFF9)
3287C
3288           ENDDO
3289C
3290         ENDIF
3291C
3292        ENDIF
3293!
3294!-------------------------
3295!     ANTISYM cont.
3296!-------------------------
3297!
3298      ELSE
3299!
3300      IF (NORMALCONT) THEN
3301!
3302          IF ( ISYMAI .EQ. ISYMBJ ) THEN
3303!
3304            DO B = 1,NVIR(ISYMB)
3305!
3306               NBI = IT1AM(ISYMB,ISYMI)
3307     *             + NVIR(ISYMB)*(I-1) + B
3308               NBJ = IT1AM(ISYMB,ISYMJ)
3309     *             + NVIR(ISYMB)*(J-1) + B
3310               KOFF9 = NT1AM(ISYMBJ)*(NAI - IFSTAI) + NBJ
3311               NAIBJ = IT2AM(ISYMAI,ISYMBJ)
3312     *               + INDEX(NAI,NBJ)
3313               IF (NAI .GT. NBJ) THEN
3314                  OMEGA2(NAIBJ) = OMEGA2(NAIBJ)
3315     *                       + FACCN * SCR2(KOFF9)
3316               ELSE IF (NAI .LT. NBJ) THEN
3317                  OMEGA2(NAIBJ) = OMEGA2(NAIBJ)
3318     *                       - FACCN * SCR2(KOFF9)
3319               ENDIF
3320!
3321            ENDDO
3322!
3323         ENDIF
3324!
3325         IF ( ISYMAI .LT. ISYMBJ ) THEN
3326C
3327            DO B = 1,NVIR(ISYMB)
3328C
3329               NBJ = IT1AM(ISYMB,ISYMJ)
3330     *             + NVIR(ISYMB)*(J-1) + B
3331               KOFF9 = NT1AM(ISYMBJ)*(NAI - IFSTAI) + NBJ
3332               NAIBJ = IT2AM(ISYMAI,ISYMBJ)
3333     *               + NT1AM(ISYMAI)*(NBJ - 1) + NAI
3334               OMEGA2(NAIBJ) = OMEGA2(NAIBJ)
3335     *                    - FACCN * SCR2(KOFF9)
3336C
3337            ENDDO
3338C
3339           ENDIF
3340C
3341           IF ( ISYMAI .GT. ISYMBJ ) THEN
3342C
3343            DO B = 1,NVIR(ISYMB)
3344C
3345               NBJ = IT1AM(ISYMB,ISYMJ)
3346     *             + NVIR(ISYMB)*(J-1) + B
3347               KOFF9 = NT1AM(ISYMBJ)*(NAI - IFSTAI) + NBJ
3348               NAIBJ = IT2AM(ISYMAI,ISYMBJ)
3349     *               + NT1AM(ISYMBJ)*(NAI - 1) + NBJ
3350               OMEGA2(NAIBJ) = OMEGA2(NAIBJ)
3351     *                    + FACCN * SCR2(KOFF9)
3352C
3353            ENDDO
3354C
3355           ENDIF
3356!
3357        ENDIF
3358!
3359        IF (PIJCONT) THEN
3360!
3361          IF (ISYMAJ .EQ. ISYMBI) THEN
3362C
3363            DO B = 1,NVIR(ISYMB)
3364C
3365               NBI = IT1AM(ISYMB,ISYMI)
3366     *             + NVIR(ISYMB)*(I-1) + B
3367               NBJ = IT1AM(ISYMB,ISYMJ)
3368     *             + NVIR(ISYMB)*(J-1) + B
3369               KOFF9 = NT1AM(ISYMBJ)*(NAI - IFSTAI) + NBJ
3370               NAJBI = IT2AM(ISYMAJ,ISYMBI)
3371     *               + INDEX(NAJ,NBI)
3372!
3373               IF (NAJ .GT. NBI) THEN
3374                  OMEGA2(NAJBI) = OMEGA2(NAJBI) + FACCP*SCR2(KOFF9)
3375               ELSE IF (NAJ .LT. NBI) THEN
3376                  OMEGA2(NAJBI) = OMEGA2(NAJBI) - FACCP*SCR2(KOFF9)
3377               ENDIF
3378!
3379            ENDDO
3380!
3381          ENDIF
3382C
3383          IF (ISYMAJ .GT. ISYMBI) THEN
3384C
3385             DO B = 1,NVIR(ISYMB)
3386C
3387                NBI = IT1AM(ISYMB,ISYMI)
3388     *              + NVIR(ISYMB)*(I-1) + B
3389                NBJ = IT1AM(ISYMB,ISYMJ)
3390     *              + NVIR(ISYMB)*(J-1) + B
3391                KOFF9 = NT1AM(ISYMBJ)*(NAI - IFSTAI) + NBJ
3392                NAJBI = IT2AM(ISYMAJ,ISYMBI)
3393     *                + NT1AM(ISYMBI)*(NAJ - 1)
3394     *                + NBI
3395!
3396                OMEGA2(NAJBI) = OMEGA2(NAJBI) + FACCP*SCR2(KOFF9)
3397C
3398             ENDDO
3399C
3400          ENDIF
3401C
3402          IF (ISYMAJ .LT. ISYMBI) THEN
3403C
3404             DO B = 1,NVIR(ISYMB)
3405C
3406                NBI = IT1AM(ISYMB,ISYMI)
3407     *              + NVIR(ISYMB)*(I-1) + B
3408                NBJ = IT1AM(ISYMB,ISYMJ)
3409     *              + NVIR(ISYMB)*(J-1) + B
3410                KOFF9 = NT1AM(ISYMBJ)*(NAI - IFSTAI) + NBJ
3411                NAJBI = IT2AM(ISYMAJ,ISYMBI)
3412     *                + NT1AM(ISYMAJ)*(NBI - 1)
3413     *                + NAJ
3414!
3415               OMEGA2(NAJBI) = OMEGA2(NAJBI) - FACCP*SCR2(KOFF9)
3416C
3417             ENDDO
3418C
3419          ENDIF
3420C
3421        ENDIF
3422!
3423      ENDIF
3424!
3425      CALL QEXIT('CC_PUTC3')
3426!
3427      RETURN
3428      END
3429C  /* Deck ccrhs_dio */
3430      SUBROUTINE CCRHS3_DIO(OMEGA2,OM2CONT,T2AM,XLAMDH,WORK,LWORK,
3431     *                      ISYVEC,ISYDIM,LUD,DFIL,IV,IOPT,FACD,
3432     *                      ANTISYM,OMEGA22,FACD2)
3433C
3434C     asm 20-aug-1994
3435C
3436C     Ove Christiansen 30-7-1995: Modified to account for general
3437C                                 non. total symmetric vectors (ISYVEC)
3438C                                 and intermediates (ISYDIM).
3439C                                 LUD and DFIL is
3440C                                 used to control from which file the
3441C                                 intermediate is obtained.
3442C
3443C                                 if iopt = 1 the D intermediate
3444C                                    is assumed
3445C                                    to be as in energy calc.
3446C
3447C                                 if iopt ne. 1 we use the intermediate
3448C                                    on luc with address given
3449C                                    according to transformed
3450C                                    vector nr iv (iv is not 1
3451C                                    if several vectors are transformed
3452C                                    simultaneously.)
3453C
3454C                                 in energy calc: iv=1,iopt=1
3455C
3456!     Kasper Hald 22-3-1999: Generalized to the triplet case and for a
3457!                            general factor FACD. Have also introduced
3458!                            the inputvar. OMEGA22, OM2CONT and
3459!                            FACD2 so can calculate both
3460!                            the symmetric and antisymmetric of a
3461!                            given D-term.
3462C     PURPOSE:
3463C             Calculate the D-term making I/O
3464C
3465      IMPLICIT NONE
3466#include "priunit.h"
3467#include "ccorb.h"
3468#include "ccsdsym.h"
3469#include "maxorb.h"
3470#include "ccsdio.h"
3471!
3472      INTEGER LWORK, INDEX, ISYVEC, ISAIBJ, ISYMAI, ISYMBJ, ISYMCK
3473      INTEGER ISYMDK, NT1AI, LENAI, LENMIN, NDISAI, NBATAI
3474      INTEGER ILSTAI, IBATAI, IFSTAI, KSCR1, KSCR2, KEND, LWRK1, KOFF1
3475      INTEGER ISYDEL, ISYMK, IDELTA, ID, IOPT, IOFF, IV, LEN, IERR
3476      INTEGER NAI, KAI, KOFF2, KOFF3, ISYDIM, ISYMC, NBASD, NVIRC
3477      INTEGER KOFF4, KOFF5, KOFF6, NT1BJ, NT1CK, KOFF7, KOFF8, LUD
3478!
3479#if defined (SYS_CRAY)
3480      REAL ZERO, HALF, ONE, TWO, FACD, FACD2
3481      REAL OMEGA2(*), T2AM(*), XLAMDH(*), WORK(LWORK), OMEGA22(*)
3482#else
3483      DOUBLE PRECISION ZERO, HALF, ONE, TWO, FACD, FACD2
3484      DOUBLE PRECISION OMEGA2(*), T2AM(*), XLAMDH(*), WORK(LWORK)
3485      DOUBLE PRECISION OMEGA22(*)
3486#endif
3487!
3488      PARAMETER (ZERO= 0.0D00, HALF= 0.5D00, ONE= 1.0D00, TWO= 2.0D00)
3489      CHARACTER DFIL*(*)
3490!
3491      LOGICAL ANTISYM, OM2CONT, LOGIC1
3492C
3493C      INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J
3494C
3495      CALL QENTER('CCRHS3_DIO')
3496C
3497      IF (OMEGSQ) THEN
3498         WRITE(LUPRI,*) 'I/O in D-term not implemented '//
3499     &        'for square Omega2'
3500         CALL QUIT('OMEGSQ = .TRUE.  in CCRHS3_DIO')
3501      END IF
3502C
3503      ISAIBJ = MULD2H(ISYVEC,ISYDIM)
3504C
3505      DO 100 ISYMAI = 1,NSYM
3506C
3507         IF (NT1AM(ISYMAI) .EQ. 0) GOTO 100
3508C
3509C
3510         ISYMBJ = MULD2H(ISYMAI,ISAIBJ)
3511         ISYMCK = MULD2H(ISYVEC,ISYMBJ)
3512         ISYMDK = MULD2H(ISYDIM,ISYMAI)
3513C
3514C------------------------
3515C        Batch structure.
3516C------------------------
3517C
3518         NT1AI = NT1AM(ISYMAI)
3519C
3520         LENAI  = NT1AO(ISYMDK)
3521         LENMIN = 2*LENAI
3522         IF (LENMIN .EQ. 0) GOTO 100
3523C
3524         NDISAI = LWORK / LENMIN
3525         IF (NDISAI .LT. 1) THEN
3526            CALL QUIT('Insufficient space for allocation in CCRHS3_DIO')
3527         END IF
3528         NDISAI = MIN(NDISAI,NT1AI)
3529C
3530         NBATAI = (NT1AI - 1) / NDISAI + 1
3531C
3532C--------------------------
3533C        Loop over batches.
3534C--------------------------
3535C
3536         ILSTAI = 0
3537         DO 110 IBATAI = 1,NBATAI
3538C
3539            IFSTAI = ILSTAI + 1
3540            ILSTAI = ILSTAI + NDISAI
3541            IF (ILSTAI .GT. NT1AI) THEN
3542               ILSTAI = NT1AI
3543               NDISAI = ILSTAI - IFSTAI + 1
3544            END IF
3545C
3546C-----------------------------
3547C           Memory allocation.
3548C-----------------------------
3549C
3550            KSCR1 = 1
3551            KSCR2 = KSCR1 + NDISAI*NT1AO(ISYMDK)
3552            KEND  = KSCR2 + NDISAI*NT1AO(ISYMDK)
3553            LWRK1 = LWORK - KEND
3554C
3555            IF (LWRK1 .LT. 0) THEN
3556               CALL QUIT('Insufficient space for '//
3557     &              'allocation in CCRHS_DIO')
3558            END IF
3559C
3560C----------------------------------
3561C           Construct P(del k,#ai).
3562C----------------------------------
3563C
3564            KOFF1 = KSCR1
3565            DO 120 ISYDEL = 1,NSYM
3566C
3567               ISYMK = MULD2H(ISYDEL,ISYMDK)
3568C
3569               DO 130 IDELTA = 1,NBAS(ISYDEL)
3570C
3571                  ID = IDELTA + IBAS(ISYDEL)
3572C
3573!------------------------------------
3574!           IOPT part.
3575!------------------------------------
3576!
3577                  IF (IOPT .EQ. 1 ) THEN
3578                     IOFF = IT2DEL(ID) + IT2BCT(ISYMK,ISYMAI)
3579     *                    + NRHF(ISYMK)*(IFSTAI - 1) + 1
3580                  ELSE
3581                     IOFF = IT2DLR(ID,IV) + IT2BCT(ISYMK,ISYMAI)
3582     *                    + NRHF(ISYMK)*(IFSTAI - 1) + 1
3583                  ENDIF
3584C
3585                  LEN  = NDISAI*NRHF(ISYMK)
3586C
3587                  IF (LEN .GT. 0) THEN
3588                     CALL GETWA2(LUD,DFIL,WORK(KOFF1),IOFF,LEN)
3589                  ENDIF
3590C
3591                  DO 140 NAI = IFSTAI,ILSTAI
3592C
3593                     KAI = NAI - IFSTAI + 1
3594C
3595                     KOFF2 = KOFF1 + NRHF(ISYMK)*(KAI - 1)
3596                     KOFF3 = KSCR2 + NT1AO(ISYMDK)*(KAI - 1)
3597     *                     + IT1AO(ISYDEL,ISYMK) + IDELTA - 1
3598C
3599                     CALL DCOPY(NRHF(ISYMK),WORK(KOFF2),1,WORK(KOFF3),
3600     *                          NBAS(ISYDEL))
3601C
3602  140             CONTINUE
3603C
3604                  KOFF1 = KOFF1 + LEN
3605C
3606  130          CONTINUE
3607  120       CONTINUE
3608C
3609C--------------------------------------
3610C           Transform delta index to c.
3611C--------------------------------------
3612C
3613            DO 150 NAI = IFSTAI,ILSTAI
3614C
3615               KAI = NAI - IFSTAI + 1
3616C
3617               DO 160 ISYMC = 1,NSYM
3618C
3619                  ISYDEL = ISYMC
3620                  ISYMK  = MULD2H(ISYMC,ISYMCK)
3621C
3622                  NBASD = MAX(NBAS(ISYDEL),1)
3623                  NVIRC = MAX(NVIR(ISYMC),1)
3624C
3625                  KOFF4 = ILMVIR(ISYDEL) + 1
3626                  KOFF5 = KSCR2 + NT1AO(ISYMDK)*(KAI - 1)
3627     *                  + IT1AO(ISYDEL,ISYMK)
3628                  KOFF6 = KSCR1 + NT1AM(ISYMCK)*(KAI - 1)
3629     *                  + IT1AM(ISYMC,ISYMK)
3630C
3631                  CALL DGEMM('T','N',NVIR(ISYMC),NRHF(ISYMK),
3632     *                       NBAS(ISYDEL),ONE,XLAMDH(KOFF4),NBASD,
3633     *                       WORK(KOFF5),NBASD,ZERO,WORK(KOFF6),
3634     *                       NVIRC)
3635C
3636  160          CONTINUE
3637  150       CONTINUE
3638C
3639C--------------------------------------------
3640C           Contract P(ck,#ai) with T(bj,ck).
3641C--------------------------------------------
3642C
3643            NT1BJ = MAX(NT1AM(ISYMBJ),1)
3644            NT1CK = MAX(NT1AM(ISYMCK),1)
3645C
3646            KOFF7 = IT2SQ(ISYMBJ,ISYMCK) + 1
3647C
3648            CALL DGEMM('N','N',NT1AM(ISYMBJ),NDISAI,NT1AM(ISYMCK),
3649     *                 ONE,T2AM(KOFF7),NT1BJ,WORK(KSCR1),NT1CK,
3650     *                 ZERO,WORK(KSCR2),NT1BJ)
3651C
3652C------------------------------
3653C           Scale the diagonal.
3654C------------------------------
3655C
3656            IF (OM2CONT) THEN
3657!
3658              IF (ISYMBJ .EQ. ISYMAI) THEN
3659C
3660                 DO NAI = IFSTAI,ILSTAI
3661                    KOFF8 = KSCR2 + NT1AM(ISYMBJ)*(NAI-IFSTAI) + NAI - 1
3662                    WORK(KOFF8) = TWO * WORK(KOFF8)
3663                 ENDDO
3664C
3665              END IF
3666C
3667C-----------------------------------------------
3668C           Add the result to the packed omega2.
3669!           This term is SYMMETRIC in (ai,bj)
3670C-----------------------------------------------
3671!
3672              LOGIC1 = .FALSE.
3673!
3674              DO 180 NAI = IFSTAI,ILSTAI
3675!
3676                 CALL CC_PUTD3(WORK(KSCR2),OMEGA2,ISYMAI,ISYMBJ,NAI,
3677     *                         IFSTAI,FACD,LOGIC1)
3678  180         CONTINUE
3679!
3680            ENDIF
3681!
3682!------------------------------------
3683!           Zero the diagonal
3684!------------------------------------
3685!
3686            IF (ANTISYM) THEN
3687!
3688              IF (ISYMBJ .EQ. ISYMAI) THEN
3689C
3690                 DO 190 NAI = IFSTAI,ILSTAI
3691                    KOFF8 = KSCR2 + NT1AM(ISYMBJ)*(NAI-IFSTAI) + NAI - 1
3692                    WORK(KOFF8) = ZERO
3693  190            CONTINUE
3694C
3695              END IF
3696C
3697C--------------------------------------------------
3698C           Add the result to the packed omega2.
3699!           This term is ANTISYMMETRIC in (ai,bj)
3700C--------------------------------------------------
3701!
3702              LOGIC1 = .TRUE.
3703!
3704              DO NAI = IFSTAI,ILSTAI
3705!
3706                 CALL CC_PUTD3(WORK(KSCR2),OMEGA22,ISYMAI,ISYMBJ,NAI,
3707     *                         IFSTAI,FACD2,LOGIC1)
3708              ENDDO
3709!
3710            ENDIF
3711!
3712  110    CONTINUE
3713  100 CONTINUE
3714C
3715      CALL QEXIT('CCRHS3_DIO')
3716C
3717      RETURN
3718      END
3719C  /* Deck cc_putd3 */
3720      SUBROUTINE CC_PUTD3(SCR2,OMEGA2,ISYMAI,ISYMBJ,NAI,IFSTAI,FACD,
3721     *                    ANTISYM)
3722C
3723C     Ove Christiansen 30-10-1995: Put in D contribution in omega vector
3724C                                  avoid troble on cray
3725C                                  with optimization.
3726C
3727!     Kasper Hald 22-3-1999: Generalized to the triplet case with
3728!                            ANTISYM and FACD.
3729      IMPLICIT NONE
3730!
3731#include "priunit.h"
3732#include "ccorb.h"
3733#include "ccsdsym.h"
3734#include "maxorb.h"
3735#include "ccsdio.h"
3736!
3737      INTEGER INDEX, ISYMAI, ISYMBJ, NBJ, KOFF9, NAI, IFSTAI, NAIBJ
3738!
3739#if defined (SYS_CRAY)
3740      REAL ZERO, HALF, ONE, TWO, FACD
3741      REAL SCR2(*), OMEGA2(*)
3742#else
3743      DOUBLE PRECISION ZERO, HALF, ONE, TWO, FACD
3744      DOUBLE PRECISION SCR2(*), OMEGA2(*)
3745#endif
3746      PARAMETER (ZERO= 0.0D00, HALF= 0.5D00, ONE= 1.0D00, TWO= 2.0D00)
3747      LOGICAL ANTISYM
3748!
3749      INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J
3750!
3751      CALL QENTER('CC_PUTD3')
3752!
3753      IF (.NOT. ANTISYM) THEN
3754!
3755         IF ( ISYMAI .EQ. ISYMBJ) THEN
3756            DO 190 NBJ = 1,NT1AM(ISYMBJ)
3757!
3758               KOFF9 = NT1AM(ISYMBJ)*(NAI-IFSTAI)+ NBJ
3759               NAIBJ = IT2AM(ISYMAI,ISYMBJ)
3760     *               + INDEX(NAI,NBJ)
3761!
3762               OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + FACD*SCR2(KOFF9)
3763!
3764  190    CONTINUE
3765!
3766         ENDIF
3767!
3768         IF ( ISYMAI .LT. ISYMBJ) THEN
3769            DO 200 NBJ = 1,NT1AM(ISYMBJ)
3770!
3771               KOFF9 = NT1AM(ISYMBJ)*(NAI-IFSTAI)+ NBJ
3772               NAIBJ = IT2AM(ISYMAI,ISYMBJ)
3773     *               + NT1AM(ISYMAI)*(NBJ - 1) + NAI
3774               OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + FACD*SCR2(KOFF9)
3775!
3776  200    CONTINUE
3777!
3778         ENDIF
3779!
3780         IF (ISYMBJ .LT. ISYMAI) THEN
3781            DO 210 NBJ = 1,NT1AM(ISYMBJ)
3782!
3783               KOFF9 = NT1AM(ISYMBJ)*(NAI-IFSTAI)+ NBJ
3784               NAIBJ = IT2AM(ISYMAI,ISYMBJ)
3785     *               + NT1AM(ISYMBJ)*(NAI - 1) + NBJ
3786               OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + FACD*SCR2(KOFF9)
3787!
3788  210    CONTINUE
3789!
3790         ENDIF
3791!
3792!-----------------------
3793!     ANTISYM Cont.
3794!-----------------------
3795!
3796      ELSE
3797!
3798         IF ( ISYMAI .EQ. ISYMBJ) THEN
3799!
3800             DO NBJ  = 1,NT1AM(ISYMBJ)
3801               KOFF9 = NT1AM(ISYMBJ)*(NAI-IFSTAI)+ NBJ
3802               NAIBJ = IT2AM(ISYMAI,ISYMBJ)
3803     *               + INDEX(NAI,NBJ)
3804!
3805               IF (NAI .LT. NBJ) THEN
3806                  OMEGA2(NAIBJ) = OMEGA2(NAIBJ) - FACD*SCR2(KOFF9)
3807               ELSE IF (NAI .GT. NBJ) THEN
3808                  OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + FACD*SCR2(KOFF9)
3809               ENDIF
3810!
3811             ENDDO
3812!
3813         ENDIF
3814!
3815      IF ( ISYMAI .LT. ISYMBJ) THEN
3816!
3817         DO NBJ = 1,NT1AM(ISYMBJ)
3818!
3819            KOFF9 = NT1AM(ISYMBJ)*(NAI-IFSTAI)+ NBJ
3820            NAIBJ = IT2AM(ISYMAI,ISYMBJ)
3821     *            + NT1AM(ISYMAI)*(NBJ - 1) + NAI
3822            OMEGA2(NAIBJ) = OMEGA2(NAIBJ) - FACD*SCR2(KOFF9)
3823!
3824         ENDDO
3825!
3826      ENDIF
3827!
3828      IF (ISYMBJ .LT. ISYMAI) THEN
3829         DO NBJ = 1,NT1AM(ISYMBJ)
3830!
3831            KOFF9 = NT1AM(ISYMBJ)*(NAI-IFSTAI)+ NBJ
3832            NAIBJ = IT2AM(ISYMAI,ISYMBJ)
3833     *            + NT1AM(ISYMBJ)*(NAI - 1) + NBJ
3834            OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + FACD*SCR2(KOFF9)
3835!
3836         ENDDO
3837!
3838      ENDIF
3839!
3840      ENDIF
3841!
3842      CALL QEXIT('CC_PUTD3')
3843!
3844      RETURN
3845      END
3846C  /* Deck ccrhs_h3 */
3847      SUBROUTINE CCRHS_H3(DSRHF,OMEGA1,XLAMDP,XLAMDH,SCRM,
3848     *                   WORK,LWORK,ISYDIS,ISYDEL,ISYMTR,FACH)
3849C
3850C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
3851C     Written by Henrik Koch & Ove Christiansen 19-Jan-1994
3852C     Generalized to do linear transformation parts by
3853C     OC 30-1-1995
3854!     Generalized to a general factor FACH
3855!     Kasper Hald 25-3-99
3856!
3857C     Purpose: Calculate H-term.
3858C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
3859C
3860      IMPLICIT NONE
3861!
3862#include "priunit.h"
3863#include "ccorb.h"
3864#include "ccsdsym.h"
3865!
3866      INTEGER LWORK, ISYDIS, ISYDEL, ISYMTR
3867!
3868#if defined (SYS_CRAY)
3869      REAL FACH
3870      REAL DSRHF(*), OMEGA1(*), XLAMDH(*), WORK(LWORK)
3871      REAL XLAMDP(*), SCRM(*)
3872#else
3873      DOUBLE PRECISION FACH
3874      DOUBLE PRECISION DSRHF(*), OMEGA1(*), XLAMDH(*), WORK(LWORK)
3875      DOUBLE PRECISION XLAMDP(*), SCRM(*)
3876#endif
3877C
3878      CALL QENTER('CCRHS_H3')
3879C
3880C--------------------------------
3881C     Calculate the contribution.
3882C--------------------------------
3883C
3884      CALL CCRHS_H31(DSRHF,OMEGA1,SCRM,XLAMDP,XLAMDH,WORK,LWORK,
3885     *              ISYDIS,ISYDEL,ISYMTR,FACH)
3886C
3887      CALL QEXIT('CCRHS_H3')
3888C
3889      RETURN
3890      END
3891      SUBROUTINE CCRHS_H31(DSRHF,OMEGA1,SCRM,XLAMDP,XLAMDH,WORK,LWORK,
3892     *                    ISYDIS,ISYDEL,ISYMTR,FACH)
3893C
3894C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
3895C     Written by Henrik Koch & Ove Christiansen 19-Jan-1994
3896C     Generalized to do linear transformation parts by
3897C     OC 30-1-1995
3898C
3899C     Purpose: Calculate H-term.
3900C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
3901C
3902      IMPLICIT NONE
3903!
3904#include "priunit.h"
3905#include "ccorb.h"
3906#include "ccsdsym.h"
3907!
3908      INTEGER LWORK, INDEX, ISYAKL, ISYMTR, ISYDEL, ISYML, ISYMGB
3909      INTEGER ISYMAK, ISYMKI, KSCR1, KEND1, LWRK1, KOFF1, ISYMI
3910      INTEGER ISYMB, ISYMG, ISYMK, ISYMA, KSCR2, KSCR3, KEND2
3911      INTEGER LWRK2, NBASG, NBASB, NRHFK, NVIRA, KOFF2, KOFF3
3912      INTEGER KOFF4, KOFF5, KOFF6, ISYDIS
3913!
3914#if defined (SYS_CRAY)
3915      REAL ZERO, ONE, FACH
3916      REAL DSRHF(*),OMEGA1(*),SCRM(*)
3917      REAL XLAMDP(*),XLAMDH(*),WORK(LWORK)
3918#else
3919      DOUBLE PRECISION ZERO, ONE, FACH
3920      DOUBLE PRECISION DSRHF(*),OMEGA1(*),SCRM(*)
3921      DOUBLE PRECISION XLAMDP(*),XLAMDH(*),WORK(LWORK)
3922#endif
3923      PARAMETER(ZERO=0.0D00,ONE=1.0D00)
3924C
3925C      INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J
3926C
3927      CALL QENTER('CCRHS_H31')
3928C
3929C--------------------------------------
3930C     Calculate contribution.
3931C--------------------------------------
3932C
3933      ISYAKL = MULD2H(ISYMTR,ISYDEL)
3934C
3935      DO 100 ISYML = 1,NSYM
3936C
3937         ISYMGB = MULD2H(ISYML,ISYDIS)
3938         ISYMAK = MULD2H(ISYML,ISYAKL)
3939         ISYMKI = ISYMGB
3940C
3941         KSCR1 = 1
3942         KEND1 = KSCR1 + N2BST(ISYMGB)
3943         LWRK1 = LWORK - KEND1
3944C
3945         IF (LWRK1 .LT. 0) THEN
3946            WRITE(LUPRI,*) 'Need : ',KEND1,'Available : ',LWORK
3947            CALL QUIT('Insufficient space in CCRHS_H1')
3948         ENDIF
3949         DO 110 L = 1,NRHF(ISYML)
3950C
3951            KOFF1 = IDSRHF(ISYMGB,ISYML) + NNBST(ISYMGB)*(L - 1) + 1
3952            CALL CCSD_SYMSQ(DSRHF(KOFF1),ISYMGB,WORK(KSCR1))
3953C
3954            DO 120 ISYMI = 1,NSYM
3955C
3956               ISYMB = ISYMI
3957               ISYMG = MULD2H(ISYMB,ISYMGB)
3958               ISYMK = ISYMG
3959               ISYMA = MULD2H(ISYMK,ISYMAK)
3960C
3961               KSCR2 = KEND1
3962               KSCR3 = KSCR2 + NBAS(ISYMG)*NRHF(ISYMI)
3963               KEND2 = KSCR3 + NRHF(ISYMK)*NRHF(ISYMI)
3964               LWRK2 = LWORK - KEND2
3965C
3966               IF (LWRK2 .LT. 0) THEN
3967                  WRITE(LUPRI,*) 'Need : ',KEND2,'Available : ',LWORK
3968                  CALL QUIT('Insufficient space in CCRHS_H1')
3969               ENDIF
3970C
3971               NBASG = MAX(NBAS(ISYMG),1)
3972               NBASB = MAX(NBAS(ISYMB),1)
3973               NRHFK = MAX(NRHF(ISYMK),1)
3974               NVIRA = MAX(NVIR(ISYMA),1)
3975C
3976               KOFF2 = KSCR1 + IAODIS(ISYMG,ISYMB)
3977               KOFF3 = ILMRHF(ISYMI) + 1
3978C
3979               CALL DGEMM('N','N',NBAS(ISYMG),NRHF(ISYMI),NBAS(ISYMB),
3980     *                    ONE,WORK(KOFF2),NBASG,XLAMDH(KOFF3),NBASB,
3981     *                    ZERO,WORK(KSCR2),NBASG)
3982C
3983               KOFF4 = ILMRHF(ISYMK) + 1
3984C
3985               CALL DGEMM('T','N',NRHF(ISYMK),NRHF(ISYMI),NBAS(ISYMG),
3986     *                    ONE,XLAMDP(KOFF4),NBASG,WORK(KSCR2),NBASG,
3987     *                    ZERO,WORK(KSCR3),NRHFK)
3988C
3989               KOFF5 = IT2BCD(ISYMAK,ISYML) + NT1AM(ISYMAK)*(L - 1)
3990     *               + IT1AM(ISYMA,ISYMK) + 1
3991               KOFF6 = IT1AM(ISYMA,ISYMI) + 1
3992C
3993               CALL DGEMM('N','N',NVIR(ISYMA),NRHF(ISYMI),NRHF(ISYMK),
3994     *                    -FACH,SCRM(KOFF5),NVIRA,WORK(KSCR3),NRHFK,
3995     *                    ONE,OMEGA1(KOFF6),NVIRA)
3996C
3997  120       CONTINUE
3998C
3999  110    CONTINUE
4000C
4001  100 CONTINUE
4002C
4003      CALL QEXIT('CCRHS_H31')
4004C
4005      RETURN
4006      END
4007C  /* Deck ccrhs_g */
4008      SUBROUTINE CCRHS_G3(DSRHF,OMEGA1,XLAMP1,ISYMP1,XLAMH1,ISYMH1,SCRM,
4009     *                   WORK,LWORK,ISYDIS,ISYDEL,ISYMTR,FACG)
4010C
4011C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
4012C     Written by Henrik Koch & Ove Christiansen 19-Jan-1994
4013C     Generalized to calculated term of linear transformation
4014C     and handle different transformations on integral indices by
4015C     OC 30-1-1995
4016C
4017C     G(a,i) = sum(cdk)[t(ci,dk)*Lackd]
4018C     G(a,i)for fixed del = sum(ck)[M(ci,k)*L(alfa gamma k]
4019C
4020C     XLAMP1 is the transformation matrix for a ; XLAMP or a oneindex
4021C     transformed
4022C     XLAMH1 is the transformation matrix for c ; XLAMH or a oneindex
4023C     transformed.
4024C     DSRHF is the (alfa gamma | k) array for a given delta.
4025C
4026C     not implemented yet with DSRHF and SCRM index transformed.
4027C
4028C     tested for energy with symmetry: ordinary XLAM matrices
4029C     - OC 10-2-1995
4030C     tested for linear transformation without symmetry.
4031C     - OC spring 95
4032C
4033C     Kasper Hald 25-3-1999 : Generalized to a general factor FACG
4034C
4035C     Purpose: Calculate G-term.
4036C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
4037!
4038      IMPLICIT NONE
4039!
4040#include "priunit.h"
4041#include "ccorb.h"
4042#include "ccsdsym.h"
4043!
4044      INTEGER LWORK, ISYINT, ISYMH1, ISYALI, KSCR1, KEND1
4045      INTEGER LWRK1, ISYMTR, ISYMP1, ISYDIS, ISYDEL
4046!
4047#if defined (SYS_CRAY)
4048      REAL FACG
4049      REAL DSRHF(*), OMEGA1(*), XLAMP1(*)
4050      REAL WORK(LWORK), XLAMH1(*), SCRM(*)
4051#else
4052      DOUBLE PRECISION FACG
4053      DOUBLE PRECISION DSRHF(*), OMEGA1(*), XLAMP1(*)
4054      DOUBLE PRECISION WORK(LWORK), XLAMH1(*), SCRM(*)
4055#endif
4056C
4057      CALL QENTER('CCRHS_G3')
4058C
4059C------------------------
4060C     Dynamic allocation.
4061C------------------------
4062C
4063      ISYINT = MULD2H(ISYMH1,ISYMOP)
4064      ISYALI = MULD2H(ISYINT,ISYMTR)
4065C
4066      KSCR1  = 1
4067      KEND1  = KSCR1  + NT1AO(ISYALI)
4068      LWRK1  = LWORK  - KEND1
4069C
4070      IF (LWRK1 .LT. 0) THEN
4071         WRITE(LUPRI,*) 'Need : ',KEND1,'Available : ',LWORK
4072         CALL QUIT('Insufficient space in CCRHS_G')
4073      ENDIF
4074C
4075C--------------------------------
4076C     Calculate the contribution.
4077C--------------------------------
4078C
4079      CALL CCRHS_G31(DSRHF,OMEGA1,SCRM,XLAMP1,ISYMP1,XLAMH1,ISYMH1,
4080     *              WORK(KSCR1),WORK(KEND1),LWRK1,ISYDIS,ISYDEL,ISYMTR,
4081     *              FACG)
4082C
4083C
4084      CALL QEXIT('CCRHS_G3')
4085C
4086      RETURN
4087      END
4088      SUBROUTINE CCRHS_G31(DSRHF,OMEGA1,SCRM,XLAMP1,ISYMP1,XLAMH1,
4089     *             ISYMH1,SCR1,WORK,LWORK,ISYDIS,ISYDEL,ISYMTR,FACG)
4090C
4091C
4092C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
4093C     Written by Henrik Koch & Ove Christiansen 19-Jan-1994
4094C     Generalized to calculated term of linear transformation
4095C     by OC 30-1-1995
4096!     FACG by KH 25-3-99
4097!
4098C     Purpose: Calculate G-term.
4099C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
4100C
4101      IMPLICIT NONE
4102!
4103#include "priunit.h"
4104#include "ccorb.h"
4105#include "ccsdsym.h"
4106!
4107      INTEGER LWORK, INDEX, ISYINT, ISYMH1, ISYALI, ISYMTR, ISYMAI
4108      INTEGER ISYMP1, ISYDEL, ISYCIK, ISYMK, ISYDIS, ISYMAG
4109      INTEGER ISYMCI, ISYMGI, KSCR10, KEND1, LWRK1, KOFF1, ISYMI
4110      INTEGER ISYMG, ISYMA, ISYMC, NBASG, NBASA, NVIRC, KSCR11
4111      INTEGER KEND2, LWRK2, KOFF2, KOFF3, KOFF4, KOFF6, ISYMAL, NVIRA
4112!
4113#if defined (SYS_CRAY)
4114      REAL ZERO, ONE, TWO, FACG
4115      REAL DSRHF(*), OMEGA1(*), SCRM(*), SCR1(*)
4116      REAL XLAMP1(*), XLAMH1(*), WORK(LWORK)
4117#else
4118      DOUBLE PRECISION ZERO, ONE, TWO, FACG
4119      DOUBLE PRECISION DSRHF(*), OMEGA1(*), SCRM(*), SCR1(*)
4120      DOUBLE PRECISION XLAMP1(*), XLAMH1(*), WORK(LWORK)
4121#endif
4122!
4123      PARAMETER(ZERO=0.0D00,ONE=1.0D00)
4124      PARAMETER(TWO=2.0D00)
4125C
4126C      INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J
4127C
4128      CALL QENTER('CCRHS_G31')
4129C
4130      ISYINT = MULD2H(ISYMH1,ISYMOP)
4131      ISYALI = MULD2H(ISYINT,ISYMTR)
4132      ISYMAI = MULD2H(ISYALI,ISYMP1)
4133      ISYCIK = MULD2H(ISYMTR,ISYDEL)
4134C
4135      CALL DZERO(SCR1,NT1AO(ISYMAI))
4136C
4137      DO 100 ISYMK = 1,NSYM
4138C
4139         ISYMAG = MULD2H(ISYMK,ISYDIS)
4140         ISYMCI = MULD2H(ISYMK,ISYCIK)
4141         ISYMGI = MULD2H(ISYALI,ISYMAG)
4142C
4143         KSCR10 = 1
4144         KEND1  = KSCR10 + N2BST(ISYMAG)
4145         LWRK1  = LWORK  - KEND1
4146C
4147         IF (LWRK1 .LT. 0) THEN
4148            WRITE(LUPRI,*) 'Need : ',KEND1,'Available : ',LWORK
4149            CALL QUIT('Insufficient space in CCRHS_G1')
4150         ENDIF
4151C
4152         DO 110 K = 1,NRHF(ISYMK)
4153C
4154            KOFF1 = IDSRHF(ISYMAG,ISYMK) + NNBST(ISYMAG)*(K - 1) + 1
4155            CALL CCSD_SYMSQ(DSRHF(KOFF1),ISYMAG,WORK(KSCR10))
4156C
4157            DO 120 ISYMI = 1,NSYM
4158C
4159               ISYMG = MULD2H(ISYMI,ISYMGI)
4160               ISYMA = MULD2H(ISYMG,ISYMAG)
4161               ISYMC = ISYMG
4162C
4163               NBASG = MAX(NBAS(ISYMG),1)
4164               NBASA = MAX(NBAS(ISYMA),1)
4165               NVIRC = MAX(NVIR(ISYMC),1)
4166C
4167               KSCR11 = KEND1
4168               KEND2  = KSCR11 + NBAS(ISYMG)*NRHF(ISYMI)
4169               LWRK2  = LWORK  - KEND2
4170C
4171               IF (LWRK2 .LT. 0) THEN
4172                  WRITE(LUPRI,*) 'Need : ',KEND2,'Available : ',LWORK
4173                  CALL QUIT('Insufficient space in CCRHS_G1')
4174               ENDIF
4175C
4176               KOFF2 = IGLMVI(ISYMG,ISYMC) + 1
4177               KOFF3 = IT2BCD(ISYMCI,ISYMK) + NT1AM(ISYMCI)*(K - 1)
4178     *               + IT1AM(ISYMC,ISYMI) + 1
4179C
4180               CALL DGEMM('N','N',NBAS(ISYMG),NRHF(ISYMI),NVIR(ISYMC),
4181     *                    ONE,XLAMH1(KOFF2),NBASG,SCRM(KOFF3),NVIRC,
4182     *                    ZERO,WORK(KSCR11),NBASG)
4183C
4184               KOFF4 = KSCR10 + IAODIS(ISYMA,ISYMG)
4185               KOFF6 = IT1AO(ISYMA,ISYMI) + 1
4186C
4187               CALL DGEMM('N','N',NBAS(ISYMA),NRHF(ISYMI),NBAS(ISYMG),
4188     *                    ONE,WORK(KOFF4),NBASA,WORK(KSCR11),NBASG,
4189     *                    ONE,SCR1(KOFF6),NBASA)
4190C
4191  120       CONTINUE
4192C
4193  110    CONTINUE
4194C
4195  100 CONTINUE
4196C
4197C----------------------------------------------
4198C     Accumulation into OMEGA1 in the MO basis.
4199C----------------------------------------------
4200C
4201      DO 200 ISYMI = 1,NSYM
4202C
4203         ISYMA = MULD2H(ISYMI,ISYMAI)
4204         ISYMAL= MULD2H(ISYMI,ISYALI)
4205C
4206         NBASA = MAX(NBAS(ISYMA),1)
4207         NVIRA = MAX(NVIR(ISYMA),1)
4208C
4209         KOFF1 = IGLMVI(ISYMAL,ISYMA) + 1
4210         KOFF2 = IT1AO(ISYMA,ISYMI) + 1
4211         KOFF3 = IT1AM(ISYMA,ISYMI) + 1
4212C
4213         CALL DGEMM('T','N',NVIR(ISYMA),NRHF(ISYMI),NBAS(ISYMA),FACG,
4214     *              XLAMP1(KOFF1),NBASA,SCR1(KOFF2),NBASA,ONE,
4215     *              OMEGA1(KOFF3),NVIRA)
4216C
4217  200 CONTINUE
4218C
4219      CALL QEXIT('CCRHS_G31')
4220C
4221      RETURN
4222      END
4223C  /* Deck cc_rvec3 */
4224      SUBROUTINE CC_RVEC3(LU,FIL,LLEN,LEN,NR,IDISP,VEC)
4225!
4226!     Kasper Hald : April 1. 1999 (And that's not even a joke)
4227!
4228!     The routine reads LEN elements from the file FIL with
4229!     logical unit number LU. The address is given by the length
4230!     of each file multiplied with (NR - 1). In the triplet
4231!     case we store different length files so a displacement IDISP
4232!     can be given.
4233!
4234      IMPLICIT NONE
4235#if defined (SYS_CRAY)
4236      REAL VEC(*)
4237#else
4238      DOUBLE PRECISION VEC(*)
4239#endif
4240      CHARACTER FIL*(*)
4241      INTEGER LU, LLEN, LEN, NR, IDISP, IOFF, IERR
4242!
4243      CALL QENTER('CC_RVEC3')
4244!
4245      IOFF = 1 + LLEN*(NR-1) + IDISP
4246!
4247      IF (LEN .GT. 0) THEN
4248         CALL GETWA2(LU,FIL,VEC,IOFF,LEN)
4249      ENDIF
4250!
4251      CALL QEXIT('CC_RVEC3')
4252!
4253      RETURN
4254      END
4255C  /* Deck cc_wvec3 */
4256      SUBROUTINE CC_WVEC3(LU,FIL,LLEN,LEN,NR,IDISP,VEC)
4257!
4258!     Kasper Hald April 1. 1999 (And that's not even a joke)
4259!
4260!     Writes the vector VEC to the file FIL with logical unit number
4261!     LU. The address is calculated from LLEN, NR and the displacement
4262!     IDISP.
4263!
4264      IMPLICIT NONE
4265!
4266#if defined (SYS_CRAY)
4267      REAL VEC(*)
4268#else
4269      DOUBLE PRECISION VEC(*)
4270#endif
4271      CHARACTER FIL*(*)
4272      INTEGER LU, LLEN, LEN, NR, IDISP, IOFF, IERR
4273!
4274      CALL QENTER('CC_WVEC3')
4275!
4276      IOFF = 1 + LLEN*(NR-1) + IDISP
4277!
4278      IF (LEN .GT. 0) THEN
4279         CALL PUTWA2(LU,FIL,VEC,IOFF,LEN)
4280      ENDIF
4281!
4282      CALL QEXIT('CC_WVEC3')
4283!
4284      RETURN
4285      END
4286C  /* Deck ccrhs_t2bt */
4287      SUBROUTINE CCRHS3_T2BT(T2AM,WORK,LWORK,ISYM,IOPT)
4288C
4289C     Alfredo Sanchez and Henrik Koch 30-July 1994
4290C
4291C     Kasper Hald 17-may 1999
4292C
4293C     Backtransform -exchange
4294C
4295C     PURPOSE:
4296C             Back transform t2 amplitudes.
4297C             The amplitudes are assumed to be a square matrix.
4298C
4299C             IOPT = 1 : 2T2 - T2 -> T2
4300C             IOPT = 2 : 0   - T2  (Pure exchange) -> T2
4301C
4302      IMPLICIT NONE
4303C
4304      INTEGER LWORK, ISYMJ, ISYMB, ISYMBJ, ISYMAI, NBJ, ISYMI, ISYMA
4305      INTEGER ISYMBI, KSCR1, ISYM, ISYMAJ, KSCR2, KEND1, LWRK1
4306      INTEGER NRHFI, NBI, NAIBJ, NAJBI, IOPT, KOFF
4307C
4308#if defined (SYS_CRAY)
4309      REAL ONETHD, TWOTHD, ONEMINUS
4310      REAL T2AM(*), WORK(LWORK)
4311#else
4312      DOUBLE PRECISION ONETHD, TWOTHD, ONEMINUS
4313      DOUBLE PRECISION T2AM(*), WORK(LWORK)
4314#endif
4315      PARAMETER(ONETHD = 1.0D00/3.0D00,TWOTHD = 2.0D00/3.0D00)
4316      PARAMETER(ONEMINUS = -1.0D00)
4317#include "priunit.h"
4318#include "ccorb.h"
4319#include "ccsdsym.h"
4320C
4321      CALL QENTER('CCRHS3_T2BT')
4322C
4323C----------------------------------
4324C     Back transform t2-amplitudes.
4325C----------------------------------
4326C
4327      DO 100 ISYMJ = 1,NSYM
4328C
4329         DO 110 J = 1,NRHF(ISYMJ)
4330C
4331            DO 120 ISYMB = 1,NSYM
4332C
4333               ISYMBJ = MULD2H(ISYMB,ISYMJ)
4334               ISYMAI = MULD2H(ISYMBJ,ISYM)
4335C
4336               DO 130 B = 1,NVIR(ISYMB)
4337C
4338                  NBJ = IT1AM(ISYMB,ISYMJ)+NVIR(ISYMB)*(J-1)+B
4339C
4340                  DO 140 ISYMI = 1,ISYMJ
4341C
4342                     ISYMA  = MULD2H(ISYMI,ISYMAI)
4343                     ISYMAJ = MULD2H(ISYMA,ISYMJ)
4344                     ISYMBI = MULD2H(ISYMB,ISYMI)
4345C
4346                     KSCR1 = 1
4347                     IF (IOPT .EQ. 1) THEN
4348                        KSCR2 = KSCR1 + NVIR(ISYMA)
4349                        KEND1 = KSCR2 + NVIR(ISYMA)
4350                     ELSE IF (IOPT .EQ. 2) THEN
4351                        KEND1 = KSCR1 + NVIR(ISYMA)
4352                     ENDIF
4353                     LWRK1 = LWORK - KEND1
4354                     IF (LWRK1 .LT. 0) THEN
4355                        CALL QUIT('Insufficient space in CCRHS3_T2TR')
4356                     ENDIF
4357C
4358                     IF (ISYMI .EQ. ISYMJ) THEN
4359                        NRHFI = J - 1
4360                     ELSE
4361                        NRHFI = NRHF(ISYMI)
4362                     END IF
4363C
4364                     DO 150 I = 1,NRHFI
4365C
4366                        NBI = IT1AM(ISYMB,ISYMI)+NVIR(ISYMB)*(I-1)+B
4367C
4368                        NAIBJ = IT2SQ(ISYMAI,ISYMBJ)
4369     *                        + NT1AM(ISYMAI)*(NBJ-1)
4370     *                        + IT1AM(ISYMA,ISYMI)+NVIR(ISYMA)*(I-1)+1
4371C
4372                        NAJBI = IT2SQ(ISYMAJ,ISYMBI)
4373     *                        + NT1AM(ISYMAJ)*(NBI-1)
4374     *                        + IT1AM(ISYMA,ISYMJ)+NVIR(ISYMA)*(J-1)+1
4375C
4376                        IF (IOPT .EQ. 1) THEN
4377!
4378                        CALL DCOPY(NVIR(ISYMA),T2AM(NAIBJ),1,
4379     *                             WORK(KSCR1),1)
4380                        CALL DCOPY(NVIR(ISYMA),T2AM(NAJBI),1,
4381     *                             WORK(KSCR2),1)
4382C
4383                        CALL DSCAL(NVIR(ISYMA),TWOTHD,T2AM(NAIBJ),1)
4384                        CALL DSCAL(NVIR(ISYMA),TWOTHD,T2AM(NAJBI),1)
4385C
4386                        CALL DAXPY(NVIR(ISYMA),ONETHD,WORK(KSCR2),1,
4387     *                             T2AM(NAIBJ),1)
4388                        CALL DAXPY(NVIR(ISYMA),ONETHD,WORK(KSCR1),1,
4389     *                             T2AM(NAJBI),1)
4390C
4391                        ELSE IF (IOPT .EQ. 2) THEN
4392C
4393                        CALL DSCAL(NVIR(ISYMA),ONEMINUS,T2AM(NAIBJ),1)
4394                        CALL DSCAL(NVIR(ISYMA),ONEMINUS,T2AM(NAJBI),1)
4395C
4396                        CALL DCOPY(NVIR(ISYMA),T2AM(NAIBJ),1,
4397     *                             WORK(KSCR1),1)
4398                        CALL DCOPY(NVIR(ISYMA),T2AM(NAJBI),1,
4399     *                             T2AM(NAIBJ),1)
4400                        CALL DCOPY(NVIR(ISYMA),WORK(KSCR1),1,
4401     *                             T2AM(NAJBI),1)
4402C
4403                        ELSE
4404                           CALL QUIT('IOPT mismatch in CCRHS3_T2BT')
4405                        ENDIF
4406C
4407  150               CONTINUE
4408C
4409  140             CONTINUE
4410C
4411  130          CONTINUE
4412C
4413  120       CONTINUE
4414C
4415  110    CONTINUE
4416C
4417  100 CONTINUE
4418C
4419      IF (IPRCC .GT. 20) THEN
4420         CALL AROUND('Back-transformed t2am')
4421         DO 200 ISYMBJ = 1,NSYM
4422            ISYMAI = MULD2H(ISYMBJ,ISYM)
4423            KOFF = IT2SQ(ISYMAI,ISYMBJ) + 1
4424            WRITE(LUPRI,*)
4425            WRITE(LUPRI,*) 'Symmetry block:',ISYMBJ
4426            CALL OUTPUT(T2AM(KOFF),1,NT1AM(ISYMAI),1,NT1AM(ISYMBJ),
4427     *                  NT1AM(ISYMAI),NT1AM(ISYMBJ),1,LUPRI)
4428  200    CONTINUE
4429      END IF
4430C
4431      CALL QEXIT('CCRHS3_T2BT')
4432C
4433      RETURN
4434      END
4435C  /* Deck ccrhs3_cd */
4436      SUBROUTINE CCRHS3_CD(LUD,DFIL,LUC,CFIL,IDEL,WORK,LWORK,
4437     *                     LUCD,CDFIL,ISYMD,ISYMPC)
4438!
4439!     Written by Kasper Hald.
4440!
4441!
4442!     Purpose : Calculate (3)D - (1)C and write to disk.
4443!
4444!
4445      IMPLICIT NONE
4446!
4447#include "priunit.h"
4448#include "ccsdsym.h"
4449#include "maxorb.h"
4450#include "ccorb.h"
4451#include "ccsdio.h"
4452!
4453      INTEGER LWORK,LUC,LUCD,LUD,IDEL,ISYMTR,ISYMD, ISYMPC
4454      INTEGER IERRCD, IERRC, IERRD, KSCR1, KSCR2, KEND1, LWRK1
4455      INTEGER ISYAIK, ISYDIS, IOFF
4456!
4457#if defined (SYS_CRAY)
4458      REAL XMONE, WORK(LWORK)
4459#else
4460      DOUBLE PRECISION XMONE, WORK(LWORK)
4461#endif
4462!
4463      PARAMETER(XMONE= -1.0D00)
4464!
4465      CHARACTER*8 CFIL,DFIL,CDFIL
4466!
4467      CALL QENTER('CCRHS3_CD')
4468!
4469      ISYDIS = MULD2H(ISYMD,ISYMOP)
4470      ISYAIK = MULD2H(ISYDIS,ISYMPC)
4471!
4472!--------------------------
4473!     Allocation.
4474!--------------------------
4475!
4476      KSCR1 = 1
4477      KSCR2 = KSCR1 + NT2BCD(ISYAIK)
4478      KEND1 = KSCR2 + NT2BCD(ISYAIK)
4479      LWRK1 = LWORK - KEND1
4480!
4481      IF (LWRK1 .LE. 0 ) THEN
4482         CALL QUIT('Too little workspace in CCRHS3_CD ')
4483      ENDIF
4484!
4485      IOFF = IT2DEL(IDEL) + 1
4486!
4487      IF (NT2BCD(ISYAIK) .GT. 0) THEN
4488         CALL GETWA2(LUD,DFIL,WORK(KSCR1),IOFF,NT2BCD(ISYAIK))
4489         CALL GETWA2(LUC,CFIL,WORK(KSCR2),IOFF,NT2BCD(ISYAIK))
4490      ENDIF
4491!
4492!-------------------------------------
4493!     Calculate the contribution.
4494!-------------------------------------
4495!
4496         CALL DAXPY(NT2BCD(ISYAIK),XMONE,WORK(KSCR2),1,WORK(KSCR1),1)
4497!
4498!--------------------------------------
4499!     Save the new intermediate.
4500!--------------------------------------
4501!
4502      IF (NT2BCD(ISYAIK) .GT. 0) THEN
4503         CALL PUTWA2(LUCD,CDFIL,WORK(KSCR1),IOFF,NT2BCD(ISYAIK))
4504      ENDIF
4505!
4506      CALL QEXIT('CCRHS3_CD')
4507!
4508      RETURN
4509      END
4510C  /* Deck ccrhs3_prcd */
4511      SUBROUTINE CCRHS3_PRCD(LUD,DFIL,IDEL,WORK,LWORK,ISYMD,ISYMPC)
4512!
4513!     Written by Kasper Hald
4514!
4515!     Purpose : Prints the different elements of the
4516!               C or D intermediates.
4517!
4518!
4519      IMPLICIT NONE
4520!
4521#include "priunit.h"
4522#include "ccsdsym.h"
4523#include "maxorb.h"
4524#include "ccorb.h"
4525#include "ccsdio.h"
4526!
4527      INTEGER LWORK, LUD, IOFF, KSCR1, KEND1, LWRK1, ISYMPC
4528      INTEGER ISYMD, ISYDIS, ISYAIK, IDEL, IERRD
4529!
4530#if defined (SYS_CRAY)
4531      REAL WORK(LWORK)
4532#else
4533      DOUBLE PRECISION WORK(LWORK)
4534#endif
4535!
4536      CHARACTER*8 DFIL
4537!
4538      CALL QENTER('CCRHS3_PRCD')
4539!
4540      ISYDIS = MULD2H(ISYMD,ISYMOP)
4541      ISYAIK = MULD2H(ISYDIS,ISYMPC)
4542!
4543!--------------------------------
4544!     Allocation.
4545!--------------------------------
4546!
4547      KSCR1 = 1
4548      KEND1 = KSCR1 +NT2BCD(ISYAIK)
4549      LWRK1 = LWORK - KEND1
4550!
4551      IF (LWRK1 .LE. 0) THEN
4552          CALL QUIT('Too little workspace in CCRHS3_PRCD ')
4553      ENDIF
4554!
4555      IOFF = IT2DEL(IDEL) + 1
4556!
4557      IF (NT2BCD(ISYAIK) .GT. 0) THEN
4558         CALL GETWA2(LUD,DFIL,WORK(KSCR1),IOFF,NT2BCD(ISYAIK))
4559      ENDIF
4560!
4561!---------------------------------------
4562!     Print the C/D intermediate.
4563!---------------------------------------
4564!
4565      IF (NT2BCD(ISYAIK) .GT. 0) THEN
4566         WRITE(LUPRI,*) ' The elements of ',DFIL
4567!
4568         DO I=1,NT2BCD(ISYAIK)
4569!
4570            WRITE(LUPRI,*) 'Element : ',WORK(KSCR1+I-1)
4571!
4572         ENDDO
4573!
4574      ENDIF
4575!
4576      CALL QEXIT('CCRHS3_PRCD')
4577!
4578      RETURN
4579      END
4580C  /* Deck ccrhs3_ei */
4581      SUBROUTINE CCRHS3_EI(DSRHF,EMAT1,EMAT2,T2AM,SCRM,XLAMDP,
4582     *                     XLAMDH,WORK,LWORK,IDEL,ISYMD,ISYDIS,
4583     *                     ISYMTR,FACE1,FACE2)
4584C
4585C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
4586C     Written by Henrik Koch 12-Jan-1994
4587C     Symmetry 2-aug
4588C     Modified slightly by Ove Christiansen 31-1-95 for
4589C     construction of linear transformation intermediates.
4590C     ISYMTR = SYM OF T2-VEC
4591!     Kasper Hald : General factor for E1 and E2 (FACE1 and FACE2)
4592C
4593C     Purpose: Calculate E-intermediates.
4594C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
4595C
4596      IMPLICIT NONE
4597!
4598      INTEGER LWORK, KSCR1, KSCR2, KSCR3, KEND1, LWRK1, ISYDIS
4599      INTEGER IDEL, ISYMTR, ISYMD
4600!
4601#if defined (SYS_CRAY)
4602      REAL ONE, TWO, FACE1, FACE2
4603      REAL WORK(LWORK), XLAMDP(*), XLAMDH(*)
4604      REAL EMAT1(*), EMAT2(*), DSRHF(*), T2AM(*), SCRM(*)
4605#else
4606      DOUBLE PRECISION ONE, TWO,FACE1, FACE2
4607      DOUBLE PRECISION WORK(LWORK), XLAMDP(*), XLAMDH(*)
4608      DOUBLE PRECISION EMAT1(*), EMAT2(*), DSRHF(*), T2AM(*)
4609      DOUBLE PRECISION SCRM(*)
4610#endif
4611!
4612      PARAMETER (ONE = 1.0D00, TWO = 2.0D00)
4613#include "priunit.h"
4614#include "ccorb.h"
4615#include "ccsdsym.h"
4616!
4617      CALL QENTER('CCRHS3_EI')
4618!
4619!------------------------
4620!     Dynamic allocation.
4621!------------------------
4622!
4623      KSCR1  = 1
4624      KSCR2  = KSCR1  + NT2BCD(ISYDIS)
4625      KSCR3  = KSCR2  + NT2BGD(ISYDIS)
4626      KEND1  = KSCR3  + NT2BGD(ISYDIS)
4627      LWRK1  = LWORK  - KEND1
4628!
4629      IF (LWRK1 .LT. 0) THEN
4630         WRITE(LUPRI,*) 'Need : ',KEND1,'Available : ',LWORK
4631         CALL QUIT('Insufficient space in CCRHS3_EI')
4632      ENDIF
4633!
4634!--------------------------------
4635!     Calculate the contribution.
4636!--------------------------------
4637!
4638      CALL CCRHS3_EI1(DSRHF,EMAT1,EMAT2,T2AM,SCRM,
4639     *               WORK(KSCR1),WORK(KSCR2),WORK(KSCR3),
4640     *               XLAMDP,XLAMDH,WORK(KEND1),LWRK1,IDEL,
4641     *               ISYMD,ISYDIS,ISYMTR,FACE1,FACE2)
4642!
4643      CALL QEXIT('CCRHS3_EI')
4644!
4645      RETURN
4646      END
4647      SUBROUTINE CCRHS3_EI1(DSRHF,EMAT1,EMAT2,T2AM,SCRM,SCR1,SCR2,
4648     *                     SCR3,XLAMDP,XLAMDH,WORK,LWORK,IDEL,
4649     *                     ISYMD,ISYDIS,ISYMTR,FACE1,FACE2)
4650!
4651C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
4652C     Written by Henrik Koch 12-Jan-1994
4653C     Symmetry 2-aug
4654C     Modified slightly by Ove Christiansen 31-1-95 for
4655C     construction of linear transformation intermediates.
4656C     ISYMTR = SYM OF T2-VEC
4657!     Kasper Hald : General factor for E1 and E2  (FACE1 and FACE2)
4658C
4659C     Purpose: Calculate E-intermediates.
4660C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
4661C
4662      IMPLICIT NONE
4663#include "priunit.h"
4664#include "ccorb.h"
4665#include "ccsdsym.h"
4666!
4667      INTEGER LWORK, IDEL, ISYMD, ISYDIS, ISYMTR, KBM
4668      INTEGER ISYMJ, ISYMDJ, ISYMEM, ISYMGM, ISYME, NVIRE
4669      INTEGER ISYMK, NT1GM, NRHFK, KOFF1, KOFF2, KOFF3, KOFF4
4670      INTEGER KOFF5, KOFF6, ISYMBM, ISYMB, NT1DL, ISYMM, ISYMAG
4671      INTEGER ISYMDL, ISYMGL, KSCR1, KEND1, LWRK1, ISYML
4672      INTEGER ISYMD1, ISYMA, ISYMG, NBASA, NBASG, NVIRD, INDEX
4673
4674!
4675#if defined (SYS_CRAY)
4676      REAL ZERO, HALF, ONE, TWO, FACE1, FACE2
4677      REAL WORK(LWORK), XLAMDP(*),XLAMDH(*), DSRHF(*)
4678      REAL EMAT1(*), EMAT2(*), T2AM(*), SCRM(*), SCR1(*)
4679      REAL SCR2(*), SCR3(*)
4680#else
4681      DOUBLE PRECISION ZERO, HALF, ONE, TWO, FACE1, FACE2
4682      DOUBLE PRECISION WORK(LWORK), XLAMDP(*), XLAMDH(*)
4683      DOUBLE PRECISION DSRHF(*), EMAT1(*), EMAT2(*), T2AM(*)
4684      DOUBLE PRECISION SCRM(*), SCR1(*), SCR2(*), SCR3(*)
4685#endif
4686!
4687      PARAMETER(ZERO=0.0D00,HALF=0.5D00,ONE=1.0D00,TWO=2.0D00)
4688!
4689C      INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J
4690!
4691      CALL QENTER('CCRHS3_EI1')
4692!
4693!===================================
4694!     First intermediate I(b,delta).
4695!===================================
4696!
4697!-------------------------------------------------------
4698!     Construct the integrals I(dl,m) = (l d | m delta).
4699!-------------------------------------------------------
4700!
4701      DO 100 ISYMM = 1,NSYM
4702!
4703         ISYMAG = MULD2H(ISYMM,ISYDIS)
4704         ISYMDL = ISYMAG
4705         ISYMGL = ISYMAG
4706!
4707         DO 110 M = 1,NRHF(ISYMM)
4708!
4709            KSCR1 = 1
4710            KEND1 = KSCR1 + N2BST(ISYMAG)
4711            LWRK1 = LWORK - KEND1
4712            IF (LWRK1. LT. 0) THEN
4713               CALL QUIT('Insufficient core in CCRHS_EI1')
4714            END IF
4715!
4716            KOFF1 = IDSRHF(ISYMAG,ISYMM)+NNBST(ISYMAG)*(M-1)+1
4717            CALL CCSD_SYMSQ(DSRHF(KOFF1),ISYMAG,WORK(KSCR1))
4718!
4719            DO 120 ISYML = 1,NSYM
4720!
4721               ISYMD1 = MULD2H(ISYML,ISYMDL)
4722               ISYMA  = ISYML
4723               ISYMG  = ISYMD1
4724!
4725               NBASA = MAX(NBAS(ISYMA),1)
4726               NBASG = MAX(NBAS(ISYMG),1)
4727               NVIRD = MAX(NVIR(ISYMD1),1)
4728!
4729               KOFF2 = KSCR1 + IAODIS(ISYMA,ISYMG)
4730               KOFF3 = ILMRHF(ISYML) + 1
4731               KOFF4 = IT2BGD(ISYMGL,ISYMM) + NT1AO(ISYMGL)*(M - 1)
4732     *               + IT1AO(ISYMG,ISYML) + 1
4733!
4734               CALL DGEMM('T','N',NBAS(ISYMG),NRHF(ISYML),
4735     *                    NBAS(ISYMA),ONE,WORK(KOFF2),NBASA,
4736     *                    XLAMDP(KOFF3),NBASA,ZERO,SCR2(KOFF4),
4737     *                    NBASG)
4738!
4739               KOFF5 = ILMVIR(ISYMD1) + 1
4740               KOFF6 = IT2BCD(ISYMDL,ISYMM) + NT1AM(ISYMDL)*(M - 1)
4741     *               + IT1AM(ISYMD1,ISYML) + 1
4742!
4743               CALL DGEMM('T','N',NVIR(ISYMD1),NRHF(ISYML),
4744     *                    NBAS(ISYMG),ONE,XLAMDH(KOFF5),NBASG,
4745     *                    SCR2(KOFF4),NBASG,ZERO,SCR1(KOFF6),NVIRD)
4746!
4747  120       CONTINUE
4748!
4749  110    CONTINUE
4750!
4751  100 CONTINUE
4752!
4753!-------------------------------------------------------
4754!     Contract the integrals in SCR1 with t2 amplitudes.
4755!-------------------------------------------------------
4756!
4757      DO 200 ISYMM = 1,NSYM
4758!
4759         ISYMDL = MULD2H(ISYMM,ISYDIS)
4760         ISYMBM = MULD2H(ISYMDL,ISYMTR)
4761         ISYMB  = MULD2H(ISYMBM,ISYMM)
4762!
4763         DO 210 M = 1,NRHF(ISYMM)
4764!
4765            NT1DL = MAX(NT1AM(ISYMDL),1)
4766!
4767            KBM   = IT1AM(ISYMB,ISYMM) + NVIR(ISYMB)*(M - 1) + 1
4768            KOFF1 = IT2SQ(ISYMDL,ISYMBM)
4769     *            + NT1AM(ISYMDL)*(KBM - 1) + 1
4770            KOFF2 = IT2BCD(ISYMDL,ISYMM)
4771     *            + NT1AM(ISYMDL)*(M - 1) + 1
4772            KOFF3 = IEMAT1(ISYMB,ISYMD)
4773     *            + (IDEL - IBAS(ISYMD) - 1)*NVIR(ISYMB) + 1
4774!
4775            CALL DGEMV('T',NT1AM(ISYMDL),NVIR(ISYMB),FACE1,
4776     *                 T2AM(KOFF1),NT1DL,SCR1(KOFF2),1,ONE,
4777     *                 EMAT1(KOFF3),1)
4778!
4779  210    CONTINUE
4780!
4781  200 CONTINUE
4782!
4783!================================
4784!     Second intermediate I(k,j).
4785!================================
4786!
4787!-------------------------------------------
4788!     Transform the SCRM amplitudes to SCR3.
4789!-------------------------------------------
4790!
4791      DO 300 ISYMJ = 1,NSYM
4792!
4793         ISYMDJ = MULD2H(ISYMD,ISYMJ)
4794         ISYMEM = MULD2H(ISYMDJ,ISYMTR)
4795         ISYMGM = ISYMEM
4796!
4797         DO 310 J = 1,NRHF(ISYMJ)
4798!
4799            DO 320 ISYMM = 1,NSYM
4800!
4801               ISYME = MULD2H(ISYMM,ISYMEM)
4802               ISYMG = ISYME
4803!
4804               NVIRE = MAX(NVIR(ISYME),1)
4805               NBASG = MAX(NBAS(ISYMG),1)
4806!
4807               KOFF1 = ILMVIR(ISYME) + 1
4808               KOFF2 = IT2BCD(ISYMEM,ISYMJ) + NT1AM(ISYMEM)*(J - 1)
4809     *               + IT1AM(ISYME,ISYMM) + 1
4810               KOFF3 = IT2BGD(ISYMGM,ISYMJ) + NT1AO(ISYMGM)*(J - 1)
4811     *               + IT1AO(ISYMG,ISYMM) + 1
4812!
4813               CALL DGEMM('N','N',NBAS(ISYMG),NRHF(ISYMM),
4814     *                    NVIR(ISYME),ONE,XLAMDH(KOFF1),
4815     *                    NBASG,SCRM(KOFF2),NVIRE,ZERO,
4816     *                    SCR3(KOFF3),NBASG)
4817!
4818  320       CONTINUE
4819  310    CONTINUE
4820  300 CONTINUE
4821!
4822!----------------------------------------------------------------
4823!     Contract the integrals in SCR2 with the amplitudes in SCR3.
4824!----------------------------------------------------------------
4825!
4826      DO 400 ISYMJ = 1,NSYM
4827!
4828         ISYMDJ = MULD2H(ISYMD,ISYMJ)
4829         ISYMEM = MULD2H(ISYMDJ,ISYMTR)
4830         ISYMGM = ISYMEM
4831         ISYMK  = MULD2H(ISYMGM,ISYDIS)
4832!
4833         NT1GM = MAX(NT1AO(ISYMGM),1)
4834         NRHFK = MAX(NRHF(ISYMK),1)
4835!
4836         KOFF1 = IT2BGD(ISYMGM,ISYMK) + 1
4837         KOFF2 = IT2BGD(ISYMGM,ISYMJ) + 1
4838         KOFF3 = IMATIJ(ISYMK,ISYMJ) + 1
4839!
4840         CALL DGEMM('T','N',NRHF(ISYMK),NRHF(ISYMJ),NT1AO(ISYMGM),
4841     *              FACE2,SCR2(KOFF1),NT1GM,SCR3(KOFF2),NT1GM,
4842     *              ONE,EMAT2(KOFF3),NRHFK)
4843!
4844  400 CONTINUE
4845!
4846      CALL QEXIT('CCRHS3_EI1')
4847!
4848      RETURN
4849      END
4850C  /* Deck cc_aofock3 */
4851      SUBROUTINE CC_AOFOCK3(XINT,DENSIT,FOCK,WORK,LWORK,IDEL,
4852     *                      ISYMD,ISYDEN)
4853C
4854C     Written by Asger Halkier and Henrik Koch 27-4-95.
4855C
4856C     Debugged Ove Christiansen august 1995
4857C
4858C     Purpose: Calculate the two electron contribution to the
4859C              AO-fock matrix using matrix vector routines.
4860C
4861C     Obs: It can be done as F(g>=d) = G(a>=b) I(a>=b,g,d) where
4862C          G(a>=b) = D(a,b) + D(b,a), the diagonal properly scaled
4863C
4864      IMPLICIT NONE
4865      INTEGER ISYDIS, ISYMD, ISYMG, ISYMAB, NDISTG, NBATCH
4866      INTEGER IBATCH, NUMG, IG1, IG2, KOFF2, IG, KOFF1, ISYMA
4867      INTEGER ISYDEN, ISYMB, KAD, IDEL, KGB, NTOTA, NTOTG, LWORK
4868#include "priunit.h"
4869#include "maxorb.h"
4870#if defined (SYS_CRAY)
4871      REAL ZERO, ONE, TWO
4872      REAL XINT(*), DENSIT(*), FOCK(*), WORK(LWORK)
4873#else
4874      DOUBLE PRECISION ZERO, ONE, TWO
4875      DOUBLE PRECISION XINT(*), DENSIT(*), FOCK(*), WORK(LWORK)
4876#endif
4877      PARAMETER(ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0)
4878#include "ccorb.h"
4879#include "symsq.h"
4880#include "ccsdsym.h"
4881C
4882      CALL QENTER('CC_AOFOCK3')
4883C
4884      ISYDIS = MULD2H(ISYMD,ISYMOP)
4885C
4886      DO 100 ISYMG = 1,NSYM
4887C
4888         IF (NBAS(ISYMG) .EQ. 0) GOTO 100
4889C
4890         ISYMAB = MULD2H(ISYMG,ISYDIS)
4891C
4892         NDISTG = MIN(LWORK/N2BST(ISYMAB),NBAS(ISYMG))
4893C
4894         IF (NDISTG .LT. 1) THEN
4895            CALL QUIT('Insufficient work space in CC_AOFOCK1')
4896         ENDIF
4897C
4898         NBATCH = (NBAS(ISYMG) - 1)/NDISTG + 1
4899C
4900C-------------------------------------
4901C        Start the loops over batches.
4902C-------------------------------------
4903C
4904         DO 110 IBATCH = 1,NBATCH
4905C
4906            NUMG = NDISTG
4907            IF (IBATCH .EQ. NBATCH) THEN
4908               NUMG = NBAS(ISYMG) - NDISTG*(NBATCH - 1)
4909            ENDIF
4910C
4911            IG1 = NDISTG*(IBATCH - 1) + 1
4912            IG2 = NDISTG*(IBATCH - 1) + NUMG
4913C
4914            KOFF2 = 1
4915            DO 120 IG = IG1,IG2
4916C
4917               KOFF1 = IDSAOG(ISYMG,ISYDIS)
4918     *               + (IG - 1)*NNBST(ISYMAB) + 1
4919C
4920               CALL CCSD_SYMSQ(XINT(KOFF1),ISYMAB,WORK(KOFF2))
4921C
4922               KOFF2 = KOFF2 + N2BST(ISYMAB)
4923C
4924  120       CONTINUE
4925C
4926            ISYMA = MULD2H(ISYMD,ISYDEN)
4927            ISYMB = MULD2H(ISYMA,ISYMAB)
4928C
4929            KAD = IAODIS(ISYMA,ISYMD)
4930     *          + NBAS(ISYMA)*(IDEL - IBAS(ISYMD) - 1) + 1
4931C
4932            DO 130 IG = IG1,IG2
4933C
4934               KOFF1 = (IG - IG1)*N2BST(ISYMAB)
4935     *               + IAODIS(ISYMA,ISYMB) + 1
4936               KGB   = IAODIS(ISYMG,ISYMB) + IG
4937C
4938               NTOTA = MAX(NBAS(ISYMA),1)
4939               NTOTG = MAX(NBAS(ISYMG),1)
4940C
4941               CALL DGEMV('T',NBAS(ISYMA),NBAS(ISYMB),-ONE,WORK(KOFF1),
4942     *                    NTOTA,DENSIT(KAD),1,ONE,FOCK(KGB),NTOTG)
4943C
4944  130       CONTINUE
4945C
4946  110    CONTINUE
4947  100 CONTINUE
4948C
4949      CALL QEXIT('CC_AOFOCK3')
4950C
4951      RETURN
4952      END
4953C  /* Deck cc_mofcon3 */
4954      SUBROUTINE CC_MOFCON3(XINT,OMEGA2,XLAMDP,XLAMDH,XLAMPC,XLAMHC,
4955     *                      WORK,LWORK,IDEL,ISYMD,ISYMTR,IOPT,
4956     *                      ANTISYM)
4957C
4958C     Written by Asger Halkier and Henrik Koch 3-5-95.
4959C     Debugged By Ove Christiansen 25-7-1995
4960C     ANTISYM flag introduced K. Hald & C. Haettig August 99
4961C
4962C     Purpose: To calculate the F-term's contribution to the
4963C              vector function using matrix vector routines.
4964C              Special version adapted for triplet case.
4965C
4966C     N.B. This routine assumes AO-symmetric integrals, and can therefor
4967C          not be used directly for calculations with London-orbitals!!!
4968C
4969#include "implicit.h"
4970#include "priunit.h"
4971#include "maxorb.h"
4972      PARAMETER(ZERO = 0.0D0,ONE = 1.0D0,XMONE=-1.0D0,TWO = 2.0D0)
4973      DIMENSION XINT(*),OMEGA2(*)
4974      DIMENSION XLAMPC(*),XLAMHC(*),XLAMDH(*),XLAMDP(*)
4975      DIMENSION WORK(LWORK)
4976      LOGICAL ANTISYM
4977#include "ccorb.h"
4978#include "symsq.h"
4979#include "ccsdsym.h"
4980C
4981      INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J
4982C
4983      CALL QENTER('CC_MOFCON3')
4984C
4985      ISYDIS = MULD2H(ISYMD,ISYMOP)
4986C
4987      DO 100 ISYMG = 1,NSYM
4988C
4989         IF (NBAS(ISYMG) .EQ. 0) GOTO 100
4990C
4991         ISALBE = MULD2H(ISYMG,ISYDIS)
4992         ISYMAI = MULD2H(ISALBE,ISYMTR)
4993         ISYMJ  = ISYMG
4994C
4995C-----------------------------------------
4996C        Dynamic allocation of work space.
4997C-----------------------------------------
4998C
4999         KSCR1 = 1
5000         KSCR2 = KSCR1 + NNBST(ISALBE)*NRHF(ISYMJ)
5001         KSCR3 = KSCR2 + N2BST(ISALBE)
5002         KSCR4 = KSCR3 + NT1AM(ISYMAI)
5003         KEND1 = KSCR4 + NT1AM(ISYMAI)
5004         LWRK1 = LWORK - KEND1
5005C
5006         IF (LWRK1 .LT. 0) THEN
5007            WRITE(LUPRI,*) 'Lwrk1 = ',LWRK1
5008            CALL QUIT('Insufficient work space area in CC_MOFCON')
5009         ENDIF
5010C
5011C--------------------------------
5012C        Do first transformation.
5013C--------------------------------
5014C
5015         KOFF1 = IDSAOG(ISYMG,ISYDIS) + 1
5016         KOFF2 = ILMRHF(ISYMJ) + 1
5017C
5018         NTALBE = MAX(NNBST(ISALBE),1)
5019         NTOTG  = MAX(NBAS(ISYMG),1)
5020C
5021         CALL DGEMM('N','N',NNBST(ISALBE),NRHF(ISYMJ),NBAS(ISYMG),
5022     *              ONE,XINT(KOFF1),NTALBE,XLAMDH(KOFF2),NTOTG,
5023     *              ZERO,WORK(KSCR1),NTALBE)
5024C
5025C-----------------------------------
5026C        Last index transformations.
5027C-----------------------------------
5028C
5029         DO 110 J = 1,NRHF(ISYMJ)
5030C
5031            KOFF1 = KSCR1 + NNBST(ISALBE)*(J - 1)
5032C
5033            CALL CCSD_SYMSQ(WORK(KOFF1),ISALBE,WORK(KSCR2))
5034C
5035            DO 120 ISYMI = 1,NSYM
5036C
5037               ISYMBE = ISYMI
5038               ISYMAL = MULD2H(ISYMBE,ISALBE)
5039               ISYMA  = MULD2H(ISYMAL,ISYMTR)
5040C
5041               IF (LWRK1 .LT. NBAS(ISYMAL)*NRHF(ISYMI)) THEN
5042                  CALL QUIT('Insufficient space for '//
5043     &                 '2. trf. in CC_MOFCON')
5044               ENDIF
5045C
5046               KOFF2 = KSCR2 + IAODIS(ISYMAL,ISYMBE)
5047               KOFF3 = ILMRHF(ISYMI) + 1
5048               KOFF4 = IGLMVI(ISYMAL,ISYMA) + 1
5049               KOFF5 = KSCR3 + IT1AM(ISYMA,ISYMI)
5050C
5051               NTOTAL = MAX(NBAS(ISYMAL),1)
5052               NTOTBE = MAX(NBAS(ISYMBE),1)
5053               NTOTA  = MAX(NVIR(ISYMA),1)
5054C
5055               CALL DGEMM('N','N',NBAS(ISYMAL),NRHF(ISYMI),NBAS(ISYMBE),
5056     *                    ONE,WORK(KOFF2),NTOTAL,XLAMDH(KOFF3),NTOTBE,
5057     *                    ZERO,WORK(KEND1),NTOTAL)
5058C
5059               CALL DGEMM('T','N',NVIR(ISYMA),NRHF(ISYMI),NBAS(ISYMAL),
5060     *                    ONE,XLAMPC(KOFF4),NTOTAL,WORK(KEND1),NTOTAL,
5061     *                    ZERO,WORK(KOFF5),NTOTA)
5062C
5063               IF (IOPT .EQ. 2) THEN
5064C
5065                  ISYMBE = MULD2H(ISYMI,ISYMTR)
5066                  ISYMAL = MULD2H(ISYMBE,ISALBE)
5067                  ISYMA  = ISYMAL
5068C
5069                  IF (LWRK1 .LT. NBAS(ISYMAL)*NRHF(ISYMI)) THEN
5070                     CALL QUIT('Insufficient space for '//
5071     &                    '2. trf. in CC_MOFCON')
5072                  ENDIF
5073C
5074                  KOFF2 = KSCR2 + IAODIS(ISYMAL,ISYMBE)
5075                  KOFF3 = IGLMRH(ISYMBE,ISYMI) + 1
5076                  KOFF4 = ILMVIR(ISYMA) + 1
5077                  KOFF5 = KSCR3 + IT1AM(ISYMA,ISYMI)
5078C
5079                  NTOTAL = MAX(NBAS(ISYMAL),1)
5080                  NTOTBE = MAX(NBAS(ISYMBE),1)
5081                  NTOTA  = MAX(NVIR(ISYMA),1)
5082C
5083                  CALL DGEMM('N','N',NBAS(ISYMAL),NRHF(ISYMI),
5084     *                       NBAS(ISYMBE),ONE,WORK(KOFF2),NTOTAL,
5085     *                       XLAMHC(KOFF3),NTOTBE,ZERO,WORK(KEND1),
5086     *                       NTOTAL)
5087C
5088                  CALL DGEMM('T','N',NVIR(ISYMA),NRHF(ISYMI),
5089     *                       NBAS(ISYMAL),ONE,XLAMDP(KOFF4),NTOTAL,
5090     *                       WORK(KEND1),NTOTAL,ONE,WORK(KOFF5),NTOTA)
5091C
5092               ENDIF
5093C
5094
5095  120       CONTINUE
5096C
5097C--------------------------------------------------
5098C           Storing the result in the omega2-array.
5099C--------------------------------------------------
5100C
5101            ISYMB  = ISYMD
5102            ISYMBJ = MULD2H(ISYMB,ISYMJ)
5103C
5104            DO 130 B = 1,NVIR(ISYMB)
5105C
5106               NBJ = IT1AM(ISYMB,ISYMJ) + NVIR(ISYMB)*(J - 1) + B
5107               NDB = ILMVIR(ISYMB) + NBAS(ISYMD)*(B - 1)
5108     *             + IDEL - IBAS(ISYMD)
5109C
5110               CALL DZERO(WORK(KSCR4),NT1AM(ISYMAI))
5111C
5112               XLB  = XLAMDP(NDB)
5113C
5114               CALL DAXPY(NT1AM(ISYMAI),XLB,WORK(KSCR3),1,WORK(KSCR4),1)
5115C
5116               IF (ISYMBJ .EQ. ISYMAI) THEN
5117C
5118                  NTOTAI = NBJ
5119C
5120                  IF (.NOT. ANTISYM) THEN
5121!
5122                  IF (IOPT .EQ. 2) THEN
5123                     NTOTAI = NT1AM(ISYMAI)
5124                     WORK(KSCR4+NBJ-1) = TWO*WORK(KSCR4+NBJ-1)
5125                  ENDIF
5126C
5127                  DO 140 NAI = 1,NTOTAI
5128C
5129                     NAIBJ = IT2AM(ISYMAI,ISYMBJ) + INDEX(NAI,NBJ)
5130C
5131                     OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + WORK(KSCR4+NAI-1)
5132C
5133  140             CONTINUE
5134                  ELSE
5135                  IF (IOPT .EQ. 1) CALL QUIT(
5136     *               'IOPT .EQ. 1 .AND. ANTISYM in MOFCON3 not legal')
5137!
5138                  DO NAI = 1,NBJ-1
5139                     NAIBJ = IT2AM(ISYMAI,ISYMBJ) + INDEX(NAI,NBJ)
5140                     OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + WORK(KSCR4+NAI-1)
5141                  ENDDO
5142C
5143                  DO NAI = NBJ+1,NT1AM(ISYMAI)
5144                     NAIBJ = IT2AM(ISYMAI,ISYMBJ) + INDEX(NAI,NBJ)
5145                     OMEGA2(NAIBJ) = OMEGA2(NAIBJ) - WORK(KSCR4+NAI-1)
5146                  ENDDO
5147!
5148                  ENDIF
5149C
5150               ENDIF
5151C
5152               IF (ISYMAI .LT. ISYMBJ) THEN
5153C
5154                 IF (.NOT. ANTISYM) THEN
5155                  DO NAI = 1,NT1AM(ISYMAI)
5156                     NAIBJ = IT2AM(ISYMAI,ISYMBJ)
5157     *                     + NT1AM(ISYMAI)*(NBJ - 1) + NAI
5158                     OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + WORK(KSCR4+NAI-1)
5159                  END DO
5160                 ELSE
5161                  DO NAI = 1,NT1AM(ISYMAI)
5162                     NAIBJ = IT2AM(ISYMAI,ISYMBJ)
5163     *                     + NT1AM(ISYMAI)*(NBJ - 1) + NAI
5164                     OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + WORK(KSCR4+NAI-1)
5165                  END DO
5166                 END IF
5167C
5168               ENDIF
5169C
5170               IF ((ISYMBJ .LT. ISYMAI) .AND. (IOPT .EQ. 2)) THEN
5171C
5172                 IF (.NOT.ANTISYM) THEN
5173                  DO NAI = 1,NT1AM(ISYMAI)
5174                     NAIBJ = IT2AM(ISYMAI,ISYMBJ)
5175     *                     + NT1AM(ISYMBJ)*(NAI - 1) + NBJ
5176                     OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + WORK(KSCR4+NAI-1)
5177                  END DO
5178                 ELSE
5179                  DO NAI = 1,NT1AM(ISYMAI)
5180                     NAIBJ = IT2AM(ISYMAI,ISYMBJ)
5181     *                     + NT1AM(ISYMBJ)*(NAI - 1) + NBJ
5182                     OMEGA2(NAIBJ) = OMEGA2(NAIBJ) - WORK(KSCR4+NAI-1)
5183                  END DO
5184                 END IF
5185C
5186               ENDIF
5187C
5188  130       CONTINUE
5189C
5190  110    CONTINUE
5191C
5192  100 CONTINUE
5193C
5194      CALL QEXIT('CC_MOFCON3')
5195C
5196      RETURN
5197      END
5198C  /* Deck cc_pram3 */
5199      SUBROUTINE CC_PRAM3(CAM1,CAMP,CAMM,PT1,PTP,PTM,ISYMTR,LGRS)
5200C
5201C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
5202C     30-5-1995 Ove Christiansen
5203C     05-8-1999 Kasper Hald & Christof Haettig : adapted for triplet
5204C
5205C     Purpose: Writes out vector:
5206C              %T1 and %T2 and ||T1||/||T2||
5207C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
5208C
5209#include "implicit.h"
5210C
5211      PARAMETER (TWO = 2.0D0, THPRT = 1.0D-9)
5212C
5213#include "priunit.h"
5214#include "ccorb.h"
5215#include "ccsdsym.h"
5216#include "ccsdinp.h"
5217C
5218C
5219      LOGICAL LGRS
5220      DIMENSION CAM1(*), CAMP(*), CAMM(*)
5221C
5222      INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J
5223C
5224      CALL QENTER('CC_PRAM3')
5225C
5226C------------------------
5227C     Add up the vectors.
5228C------------------------
5229C
5230      C1NOSQ = DDOT(NT1AM(ISYMTR),CAM1,1,CAM1,1)
5231      IF (.NOT. CCS) THEN
5232        C2PNOSQ = DDOT(NT2AM(ISYMTR),CAMP,1,CAMP,1)
5233        C2MNOSQ = DDOT(NT2AM(ISYMTR),CAMM,1,CAMM,1)
5234      ELSE
5235        C2PNOSQ = 0.0D0
5236        C2MNOSQ = 0.0D0
5237      END IF
5238C
5239      CNOSQ  = C1NOSQ + C2PNOSQ + C2MNOSQ
5240C
5241C
5242      IF (CNOSQ .EQ. 0.0D0) THEN
5243         PT1 = 0.0D0
5244         PTP = 0.0D0
5245         PTM = 0.0D0
5246      ELSE
5247         PT1 = (C1NOSQ /CNOSQ)*100.0D0
5248         PTP = (C2PNOSQ/CNOSQ)*100.0D0
5249         PTM = (C2MNOSQ/CNOSQ)*100.0D0
5250      END IF
5251C
5252      IF (.NOT. CCS .AND. CNOSQ .NE. 0.0D0) THEN
5253        WRITE(LUPRI,'(//5X,A)')
5254     *     'CC_PRAM:Overall Contribution of the Different Components'
5255        WRITE(LUPRI,'(5X,A//)')
5256     *     '--------------------------------------------------------'
5257        WRITE(LUPRI,'(/5X,A,5X,F10.4,A)')
5258     *     'Single Excitation Contribution      : ', PT1,' %'
5259        WRITE(LUPRI,'(/5X,A,5X,F10.4,A,F10.4,A)')
5260     *     'Double Excitation Contribution (+/-): ',
5261     *     PTP,' %    /',PTM,' % '
5262        WRITE(LUPRI,'(/5X,A,5X,F10.4)')
5263     *     '||T1||/||T2||                       : ',
5264     *      SQRT(C1NOSQ/(C2PNOSQ+C2MNOSQ))
5265        IF (LGRS) WRITE(LUPRI,'(/5X,A,5X,F10.4)')
5266     *     'Tau1 diagnostic                     : ',
5267     *      SQRT(C1NOSQ/(TWO*DFLOAT(NRHFT)))
5268      END IF
5269C
5270      WRITE(LUPRI,'(/5X,A,5X,F10.4)')
5271     *  'Norm of Total Amplitude Vector : ',SQRT(CNOSQ)
5272C
5273      CALL FLSHFO(LUPRI)
5274C
5275C----------------------------------------------
5276C     Initialize threshold etc from Printlevel.
5277C----------------------------------------------
5278C
5279      NL = MAX(1,2*IPRINT)
5280      CNOSQ = MAX(CNOSQ,THPRT)
5281      THR1 = SQRT(C1NOSQ/CNOSQ)/NL
5282      THR2 = SQRT((C2PNOSQ+C2MNOSQ)/CNOSQ)/NL
5283      THR1 = MAX(THR1,1.0D-03)
5284      THR2 = MAX(THR2,1.0D-03)
5285      SUMOFP = 0.0D00
5286C
5287C---------------------------------------
5288C     Loop through single excitation part.
5289C---------------------------------------
5290C
5291      WRITE(LUPRI,'(//A)')
5292     *     ' +=============================================='
5293     *    //'===============================+'
5294      WRITE(LUPRI,'(1X,A)')
5295     *     '| symmetry|  orbital index  |   Excitation Numbers'
5296     *     //'             |   Amplitude  |'
5297      WRITE(LUPRI,'(1X,A)')
5298     *     '|  Index  |   a   b   i   j |      NAI      NBJ |'
5299     *     //'     NAIBJ    |              |'
5300      WRITE(LUPRI,'(A)')
5301     *     ' +=============================================='
5302     *    //'===============================+'
5303C
5304      ISYMAI = MULD2H(ISYMTR,ISYMOP)
5305C
5306  1   CONTINUE
5307      N1 = 0
5308C
5309      DO 100 ISYMA = 1,NSYM
5310C
5311         ISYMI = MULD2H(ISYMAI,ISYMA)
5312C
5313         DO 110 I = 1,NRHF(ISYMI)
5314C
5315            MI = IORB(ISYMI) + I
5316C
5317            DO 120 A=1,NVIR(ISYMA)
5318C
5319               NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I-1) + A
5320C
5321               MA = IORB(ISYMA) + NRHF(ISYMA) +  A
5322C
5323               IF (ABS(CAM1(NAI)) .GT. THR1 ) THEN
5324C
5325                  WRITE(LUPRI,9990) ISYMA,ISYMI,A,I,NAI,CAM1(NAI)
5326C
5327                  N1 = N1 + 1
5328                  SUMOFP = SUMOFP + CAM1(NAI)*CAM1(NAI)
5329C
5330               ENDIF
5331C
5332  120       CONTINUE
5333  110    CONTINUE
5334  100 CONTINUE
5335C
5336      IF ((N1.LT.1).AND.(SQRT(C1NOSQ/CNOSQ).GT.1.0D-3)) THEN
5337         THR1 = THR1/5.0D0
5338         GOTO 1
5339      ENDIF
5340C
5341      CALL FLSHFO(LUPRI)
5342C
5343C--------------------------------------------
5344C     Loop through Doublee excitation vector.
5345C     If not ccs or ccp2
5346C--------------------------------------------
5347C
5348      IF (.NOT. ( CCS .OR. CCP2 )) THEN
5349C
5350      WRITE(LUPRI,'(A)')
5351     *     ' +----------------------------------------------'
5352     *    //'-------------------------------+'
5353C
5354
5355 2    CONTINUE
5356      N2 = 0
5357C
5358      DO 200 ISYMAI = 1,NSYM
5359C
5360         ISYMBJ = MULD2H(ISYMAI,ISYMTR)
5361C
5362         DO 210 ISYMJ = 1,NSYM
5363C
5364            ISYMB = MULD2H(ISYMJ,ISYMBJ)
5365C
5366            DO 220 ISYMI = 1,NSYM
5367C
5368               ISYMA = MULD2H(ISYMI,ISYMAI)
5369C
5370               DO 230 J = 1,NRHF(ISYMJ)
5371C
5372                  MJ = IORB(ISYMJ) + J
5373C
5374                  DO 240 B = 1,NVIR(ISYMB)
5375C
5376                     NBJ = IT1AM(ISYMB,ISYMJ)
5377     *                   + NVIR(ISYMB)*(J - 1) + B
5378C
5379                     MB = IORB(ISYMB) + NRHF(ISYMB) + B
5380C
5381                     DO 250 I = 1,NRHF(ISYMI)
5382C
5383                        MI = IORB(ISYMI) + I
5384C
5385                        DO 260 A = 1,NVIR(ISYMA)
5386C
5387                           NAI = IT1AM(ISYMA,ISYMI)
5388     *                         + NVIR(ISYMA)*(I - 1) + A
5389C
5390                           MA = IORB(ISYMA) + NRHF(ISYMA) +  A
5391C
5392                           IF (((ISYMAI.EQ.ISYMBJ).AND.
5393     *                         (NAI .LT. NBJ)).OR.(ISYMAI.LT.ISYMBJ))
5394     *                          GOTO 260
5395C
5396                           IF (ISYMAI.EQ.ISYMBJ) THEN
5397                              NAIBJ = IT2AM(ISYMAI,ISYMBJ)
5398     *                             + INDEX(NAI,NBJ)
5399                           ELSE
5400                              NAIBJ = IT2AM(ISYMAI,ISYMBJ)
5401     *                            + NT1AM(ISYMAI)*(NBJ-1) + NAI
5402                           ENDIF
5403C
5404                           IF (ABS(CAMP(NAIBJ)) .GT. THR2 ) THEN
5405                              WRITE(LUPRI,9991) ISYMA,ISYMB,ISYMI,ISYMJ,
5406     *                                      A,B,I,J,NAI,NBJ,NAIBJ,
5407     *                                      CAMP(NAIBJ)
5408                              N2 = N2 + 1
5409                              SUMOFP = SUMOFP + CAMP(NAIBJ)*CAMP(NAIBJ)
5410                           ENDIF
5411C
5412                           IF (ABS(CAMM(NAIBJ)) .GT. THR2 ) THEN
5413                              WRITE(LUPRI,9992) ISYMA,ISYMB,ISYMI,ISYMJ,
5414     *                                      A,B,I,J,NAI,NBJ,NAIBJ,
5415     *                                      CAMM(NAIBJ)
5416                              N2 = N2 + 1
5417                              SUMOFP = SUMOFP + CAMM(NAIBJ)*CAMM(NAIBJ)
5418                           ENDIF
5419C
5420  260                   CONTINUE
5421  250                CONTINUE
5422  240             CONTINUE
5423  230          CONTINUE
5424  220       CONTINUE
5425  210    CONTINUE
5426  200 CONTINUE
5427C
5428      IF ((N2.LT.1).AND.(SQRT((C2PNOSQ+C2MNOSQ)/CNOSQ).GT.1.0D-3)) THEN
5429         THR2 = THR2/5D00
5430         GOTO 2
5431      ENDIF
5432C
5433      ENDIF
5434C
5435      WRITE(LUPRI,'(A)')
5436     *     ' +=============================================='
5437     *    //'===============================+'
5438C
5439      WRITE(LUPRI,'(//10X,A,8X,F10.4)')
5440     *     'Norm of Printed Amplitude Vector : ',SQRT(SUMOFP)
5441      WRITE(LUPRI,'(//10X,A43,1X,F9.6)')
5442     *     'Printed all single excitations greater than',THR1
5443      IF (.NOT. (CCS.OR.CCP2)) THEN
5444         WRITE(LUPRI,'(//10X,A43,1X,F9.6)')
5445     *     'Printed all double excitations greater than',THR2
5446      ENDIF
5447C
5448 9990 FORMAT(1X,'| ',I1,3X,I1,2X,' | ',I3,5X,I3,4X,' | ',I8,9x,
5449     *       ' | ',12x,' | ',1x, F10.6,'  |')
5450 9991 FORMAT(1X,'| ',I1,1X,I1,1X,I1,1X,I1,' | ',
5451     *       I3,1X,I3,1X,I3,1X,I3,' | ',
5452     *       I8,1x,I8,' | (+)',I9,' | ',1x,F10.6,'  |')
5453 9992 FORMAT(1X,'| ',I1,1X,I1,1X,I1,1X,I1,' | ',
5454     *       I3,1X,I3,1X,I3,1X,I3,' | ',
5455     *       I8,1x,I8,' | (-)',I9,' | ',1x,F10.6,'  |')
5456C
5457      CALL QEXIT('CC_PRAM3')
5458C
5459      RETURN
5460      END
5461C  /* Deck ccrhs3_ij */
5462      SUBROUTINE CCRHS3_IJ(OMEGA2,WORK,LWORK,ISYVEC)
5463!
5464!     Written by Kasper Hald and Poul Joergensen
5465!     Spring 1999.
5466!
5467!     Purpose : Calculate Omega(aibj) - Omega(ajbi)
5468!
5469!     N.B. It is assumed that omega will be in packed form.
5470!
5471!
5472      IMPLICIT NONE
5473!
5474#include "priunit.h"
5475#include "maxorb.h"
5476#include "ccorb.h"
5477#include "symsq.h"
5478#include "ccsdsym.h"
5479#include "cclr.h"
5480#include "ccsdio.h"
5481!
5482      INTEGER LWORK, LWRK1, KEND1, KSCR1, ISYMJ, ISYMI, ISYMA
5483      INTEGER ISYMB, ISYMAI, ISYMAJ, ISYMBI, ISYMBJ
5484      INTEGER NAI, NAJ, NBI, NBJ, NAIBJ, NAJBI, NTOTA,ISYVEC
5485      INTEGER INDEX
5486      INTEGER MA, MB, MI, MJ
5487!
5488#if defined (SYS_CRAY)
5489      REAL WORK(LWORK), OMEGA2(*)
5490      REAL ZERO
5491#else
5492      DOUBLE PRECISION WORK(LWORK), OMEGA2(*)
5493      DOUBLE PRECISION ZERO
5494#endif
5495!
5496      PARAMETER(ZERO = 0.0D00)
5497!
5498      INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J
5499!
5500      CALL QENTER('CCRHS3_IJ')
5501!
5502!-----------------------------------
5503!     Allocation of workspace.
5504!-----------------------------------
5505!
5506      KSCR1 = 1
5507      KEND1 = KSCR1 + NT2AM(ISYVEC)
5508      LWRK1 = LWORK - KEND1
5509!
5510      IF (LWRK1 .LE. 0) THEN
5511         CALL QUIT('Too little workspace in CCRHS3_IJ ')
5512      ENDIF
5513!
5514!------------------------------------------
5515!     Copy OMEGA to workspace.
5516!------------------------------------------
5517!
5518C      CALL DCOPY(NT2AM(ISYVEC),OMEGA2,1,WORK(KSCR1),1)
5519!
5520!------------------------------------------
5521!     Calculate the contribution.
5522!------------------------------------------
5523!
5524      DO 100 ISYMBJ = 1,NSYM
5525         ISYMAI = MULD2H(ISYMBJ,ISYVEC)
5526!
5527         IF (ISYMAI .LE. ISYMBJ) THEN
5528!
5529         DO 110 ISYMI = 1,NSYM
5530!
5531            ISYMA = MULD2H(ISYMAI,ISYMI)
5532!
5533            DO 120 ISYMJ = 1,NSYM
5534!
5535               ISYMB  = MULD2H(ISYMBJ,ISYMJ)
5536               ISYMBI = MULD2H(ISYMB,ISYMI)
5537               ISYMAJ = MULD2H(ISYMA,ISYMJ)
5538!
5539               DO 130 I = 1,NRHF(ISYMI)
5540               MI = IORB(ISYMI) + I
5541                  DO 140 J = 1,NRHF(ISYMJ)
5542                  MJ = IORB(ISYMJ) + J
5543!
5544                        DO 150 A = 1,NVIR(ISYMA)
5545                        MA = IORB(ISYMA) + NRHF(ISYMA) + A
5546                           NAJ   = IT1AM(ISYMA,ISYMJ)
5547     *                           + NVIR(ISYMA)*(J-1) + A
5548                           NAI   = IT1AM(ISYMA,ISYMI)
5549     *                           + NVIR(ISYMA)*(I-1) + A
5550!
5551                           DO 160 B = 1,NVIR(ISYMB)
5552                           MB = IORB(ISYMB) + NRHF(ISYMB) + B
5553!
5554                              NBI   = IT1AM(ISYMB,ISYMI)
5555     *                              + NVIR(ISYMB)*(I-1) + B
5556                              NBJ   = IT1AM(ISYMB,ISYMJ)
5557     *                              + NVIR(ISYMB)*(J-1) + B
5558!
5559                                 IF (ISYMAI .EQ. ISYMBJ) THEN
5560!
5561                                  IF ((NAI .LE. NBJ) .AND.
5562     *                                (MA .LE. MB)) THEN
5563!
5564                                    NAIBJ = IT2AM(ISYMAI,ISYMBJ)
5565     *                                    + INDEX(NAI,NBJ)
5566!
5567                                    IF (ISYMAJ .EQ. ISYMBI) THEN
5568                                       NAJBI = IT2AM(ISYMAJ,ISYMBI)
5569     *                                       + INDEX(NAJ,NBI)
5570                                    ELSEIF (ISYMAJ .LT. ISYMBI) THEN
5571                                       NAJBI = IT2AM(ISYMAJ,ISYMBI)
5572     *                                     + NT1AM(ISYMAJ)*(NBI-1)+NAJ
5573                                    ELSEIF (ISYMAJ .GT. ISYMBI) THEN
5574                                       NAJBI = IT2AM(ISYMBI,ISYMAJ)
5575     *                                     + NT1AM(ISYMBI)*(NAJ-1)+NBI
5576                                    ENDIF
5577!
5578                                       OMEGA2(NAIBJ) = OMEGA2(NAIBJ)
5579     *                                               - OMEGA2(NAJBI)
5580                                       OMEGA2(NAJBI) = ZERO
5581!
5582                                  ENDIF
5583!
5584                                 ELSEIF (ISYMAI .LT. ISYMBJ) THEN
5585!
5586                                   IF (((MA .LE. MB) .AND.
5587     *                                  (MI .LE. MJ)) .OR.
5588     *                                 ((MA .GE. MB) .AND.
5589     *                                  (MI .GE. MJ))) THEN
5590!
5591                                     NAIBJ = IT2AM(ISYMAI,ISYMBJ)
5592     *                               + NT1AM(ISYMAI)*(NBJ-1)+NAI
5593!
5594                                     IF (ISYMAJ .EQ. ISYMBI) THEN
5595                                        NAJBI = IT2AM(ISYMAJ,ISYMBI)
5596     *                                        + INDEX(NAJ,NBI)
5597                                     ELSEIF (ISYMAJ .LT. ISYMBI) THEN
5598                                        NAJBI = IT2AM(ISYMAJ,ISYMBI)
5599     *                                  + NT1AM(ISYMAJ)*(NBI-1)+NAJ
5600                                     ELSEIF (ISYMAJ .GT. ISYMBI) THEN
5601                                        NAJBI = IT2AM(ISYMBI,ISYMAJ)
5602     *                                  + NT1AM(ISYMBI)*(NAJ-1)+NBI
5603                                     ENDIF
5604!
5605                                        OMEGA2(NAIBJ) = OMEGA2(NAIBJ)
5606     *                                                - OMEGA2(NAJBI)
5607                                        OMEGA2(NAJBI) = ZERO
5608!
5609                                   ENDIF
5610!
5611                                 ENDIF
5612!
5613  160                      CONTINUE
5614  150                   CONTINUE
5615  140                CONTINUE
5616  130             CONTINUE
5617  120          CONTINUE
5618  110    CONTINUE
5619         ENDIF
5620  100 CONTINUE
5621!
5622      CALL QEXIT('CCRHS3_IJ')
5623!
5624      RETURN
5625      END
5626C  /* Deck ccrhs3_r2ij */
5627      SUBROUTINE CCRHS3_R2IJ(C2AM,WORK,LWORK,ISYVEC)
5628!
5629!     Written by Kasper Hald.
5630!     Spring 1999.
5631!
5632!     Purpose : Take the (+)R(ab,ij) vector
5633!               for ai<bj AND i<j and "square" it up
5634!               to include all terms ai<bj i.e.
5635!               a lower triangular matrix.
5636!
5637!     N.B. It is assumed that omega will be in packed form.
5638!
5639!
5640      IMPLICIT NONE
5641!
5642#include "priunit.h"
5643#include "maxorb.h"
5644#include "ccorb.h"
5645#include "symsq.h"
5646#include "ccsdsym.h"
5647#include "cclr.h"
5648#include "ccsdio.h"
5649!
5650      INTEGER LWORK, LWRK1, KEND1, KSCR1, ISYMJ, ISYMI, ISYMA
5651      INTEGER ISYMB, ISYMAI, ISYMAJ, ISYMBI, ISYMBJ, ISYVEC
5652      INTEGER NAI, NAJ, NBI, NBJ, NAIBJ, NAJBI, NTOTA
5653      INTEGER INDEX
5654      INTEGER MA, MB, MI, MJ
5655!
5656#if defined (SYS_CRAY)
5657      REAL WORK(LWORK), C2AM(*)
5658      REAL ZERO
5659#else
5660      DOUBLE PRECISION WORK(LWORK), C2AM(*)
5661      DOUBLE PRECISION ZERO
5662#endif
5663!
5664      PARAMETER(ZERO = 0.0D00)
5665!
5666      INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J
5667!
5668      CALL QENTER('CCRHS3_R2IJ')
5669!
5670!-----------------------------------
5671!     Allocation of workspace.
5672!-----------------------------------
5673!
5674      KSCR1 = 1
5675      KEND1 = KSCR1 + NT2AM(ISYVEC)
5676      LWRK1 = LWORK - KEND1
5677!
5678      IF (LWRK1 .LE. 0) THEN
5679         CALL QUIT('Too little workspace in CCRHS3_R2IJ ')
5680      ENDIF
5681!
5682!------------------------------------------
5683!     Copy OMEGA to workspace.
5684!------------------------------------------
5685!
5686      CALL DCOPY(NT2AM(ISYVEC),C2AM,1,WORK(KSCR1),1)
5687      CALL DZERO(C2AM,NT2AM(ISYVEC))
5688!
5689!------------------------------------------
5690!     Calculate the contribution.
5691!------------------------------------------
5692!
5693      DO 100 ISYMBJ = 1,NSYM
5694         ISYMAI = MULD2H(ISYMBJ,ISYVEC)
5695!
5696         IF (ISYMAI .LE. ISYMBJ) THEN
5697!
5698            DO 110 ISYMI = 1,NSYM
5699!
5700               ISYMA = MULD2H(ISYMAI,ISYMI)
5701!
5702               DO 120 ISYMJ = 1,NSYM
5703!
5704                  ISYMB  = MULD2H(ISYMBJ,ISYMJ)
5705                  ISYMAJ = MULD2H(ISYMA,ISYMJ)
5706                  ISYMBI = MULD2H(ISYMB,ISYMI)
5707!
5708                  DO 130 I = 1,NRHF(ISYMI)
5709                  MI = IORB(ISYMI) + I
5710                     DO 140 J = 1,NRHF(ISYMJ)
5711                     MJ = IORB(ISYMJ) + J
5712!
5713                     IF (MI .NE. MJ) THEN
5714                        DO 150 A = 1,NVIR(ISYMA)
5715                        MA = IORB(ISYMA) + NRHF(ISYMA) + A
5716                           NAJ   = IT1AM(ISYMA,ISYMJ)
5717     *                           + NVIR(ISYMA)*(J-1) + A
5718                           NAI   = IT1AM(ISYMA,ISYMI)
5719     *                           + NVIR(ISYMA)*(I-1) + A
5720!
5721                           DO 160 B = 1,NVIR(ISYMB)
5722                           MB = IORB(ISYMB) + NRHF(ISYMB) + B
5723!
5724                           IF (MA .NE. MB) THEN
5725!
5726                              NBI   = IT1AM(ISYMB,ISYMI)
5727     *                              + NVIR(ISYMB)*(I-1) + B
5728                              NBJ   = IT1AM(ISYMB,ISYMJ)
5729     *                              + NVIR(ISYMB)*(J-1) + B
5730!
5731                                 IF (ISYMAI .EQ. ISYMBJ) THEN
5732!
5733                                  IF ((NAI .LT. NBJ) .AND.
5734     *                                (MA .LT. MB)) THEN
5735!
5736                                    NAIBJ = IT2AM(ISYMAI,ISYMBJ)
5737     *                                    + INDEX(NAI,NBJ)
5738!
5739                                    IF (ISYMAJ .EQ. ISYMBI) THEN
5740                                       NAJBI = IT2AM(ISYMAJ,ISYMBI)
5741     *                                       + INDEX(NAJ,NBI)
5742                                    ELSEIF (ISYMAJ .LT. ISYMBI) THEN
5743                                       NAJBI = IT2AM(ISYMAJ,ISYMBI)
5744     *                                     + NT1AM(ISYMAJ)*(NBI-1)+NAJ
5745                                    ELSEIF (ISYMAJ .GT. ISYMBI) THEN
5746                                       NAJBI = IT2AM(ISYMBI,ISYMAJ)
5747     *                                     + NT1AM(ISYMBI)*(NAJ-1)+NBI
5748                                    ENDIF
5749!
5750                                    C2AM(NAJBI) = - WORK(NAIBJ)
5751                                    C2AM(NAIBJ) =   WORK(NAIBJ)
5752!
5753                                  ENDIF
5754!
5755                                 ELSEIF (ISYMAI .LT. ISYMBJ) THEN
5756!
5757                                   IF (((MA .LT. MB) .AND.
5758     *                                  (MI .LT. MJ)) .OR.
5759     *                                 ((MA .GT. MB) .AND.
5760     *                                  (MI .GT. MJ))) THEN
5761!
5762                                          NAIBJ = IT2AM(ISYMAI,ISYMBJ)
5763     *                                  + NT1AM(ISYMAI)*(NBJ-1) + NAI
5764!
5765                                       IF (ISYMAJ .EQ. ISYMBI) THEN
5766                                          NAJBI = IT2AM(ISYMAJ,ISYMBI)
5767     *                                          + INDEX(NAJ,NBI)
5768                                       ELSEIF (ISYMAJ .LT. ISYMBI) THEN
5769                                          NAJBI = IT2AM(ISYMAJ,ISYMBI)
5770     *                                    + NT1AM(ISYMAJ)*(NBI-1)+NAJ
5771                                       ELSEIF (ISYMAJ .GT. ISYMBI) THEN
5772                                          NAJBI = IT2AM(ISYMBI,ISYMAJ)
5773     *                                    + NT1AM(ISYMBI)*(NAJ-1)+NBI
5774                                       ENDIF
5775!
5776                                       C2AM(NAJBI) = - WORK(NAIBJ)
5777                                       C2AM(NAIBJ) =   WORK(NAIBJ)
5778!
5779                                   ENDIF
5780!
5781                                 ENDIF
5782!
5783                           ENDIF
5784  160                      CONTINUE
5785  150                   CONTINUE
5786                     ENDIF
5787  140                CONTINUE
5788  130             CONTINUE
5789  120          CONTINUE
5790  110    CONTINUE
5791       ENDIF
5792  100 CONTINUE
5793!
5794      CALL QEXIT('CCRHS3_R2IJ')
5795!
5796      RETURN
5797      END
5798      SUBROUTINE CCRHS_A3(OMEGA2,T2AM,GAMMA,WORK,LWORK,ISYGAM,ISYVEC,
5799     *                    IOPT,ANTISYM)
5800C
5801C     Written by Henrik Koch & Ove Christiansen 20-Jan-1994
5802C
5803C     Generalised to non. total sym gamma (isygam) og non. tot. sym
5804C     double excitation vector (isyvec) Ove Christiansen 29-7-1995
5805C
5806C     Generalised to handle left hand side contribution (IOPT 2) as
5807C     well as usual contributions (IOPT 1) by Asger Halkier 22/11-95.
5808C
5809C     Introduced the ANTISYM logical to calculate either the
5810C     symmetric or the antisymmetric square up of GAMMA
5811C
5812C     Purpose: Calculate A-term.
5813C
5814      IMPLICIT NONE
5815#include "priunit.h"
5816#include "ccorb.h"
5817#include "ccsdsym.h"
5818!
5819      INTEGER LWORK, ISYGAM, ISYVEC, IOPT
5820      INTEGER ISAIBJ, ISYMLJ, ISYMKI, KSCR1, KEND1, LWRK1
5821      INTEGER ISYML, ISYMJ, NLJ, ISYMK, ISYMI, NKI, NKILJ
5822      INTEGER NSTO, ISYMB
5823      INTEGER KOFF1, KOFF2, KOFF3, NVIRA, ISYMA, NBL, NAI, NAIBJ
5824      INTEGER NTOT, ISYMBJ, ISYMAI, ISYMBL, ISYMAK, KSCR2, KEND2
5825      INTEGER LWRK2, NBJ, NRHFK
5826      INTEGER INDEX
5827!
5828#if defined (SYS_CRAY)
5829      REAL OMEGA2(*), GAMMA(*), T2AM(*), WORK(LWORK)
5830      REAL ZERO, ONE, XMONE, FACT
5831#else
5832      DOUBLE PRECISION OMEGA2(*), GAMMA(*), T2AM(*), WORK(LWORK)
5833      DOUBLE PRECISION ZERO, ONE, XMONE, FACT
5834#endif
5835      PARAMETER(ZERO=0.0D00, ONE=1.0D00, XMONE = -1.0D00)
5836      LOGICAL ANTISYM
5837C
5838      INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J
5839C
5840      CALL QENTER('CCRHS_A3')
5841C
5842C----------------------------
5843C     Calculate contribution.
5844C----------------------------
5845C
5846      ISAIBJ = MULD2H(ISYGAM,ISYVEC)
5847C
5848      DO 100 ISYMLJ = 1,NSYM
5849C
5850         ISYMKI = MULD2H(ISYMLJ,ISYGAM)
5851C
5852         KSCR1 = 1
5853         KEND1 = KSCR1 + NMATIJ(ISYMKI)
5854         LWRK1 = LWORK - KEND1
5855C
5856         IF (LWRK1 .LT. 0) THEN
5857            CALL QUIT('Insufficient space for allocation in CCRHS_A3')
5858         END IF
5859C
5860         DO 110 ISYMJ = 1,NSYM
5861C
5862            ISYML = MULD2H(ISYMJ,ISYMLJ)
5863C
5864            DO 120 J = 1,NRHF(ISYMJ)
5865C
5866               DO 130 L = 1,NRHF(ISYML)
5867C
5868                  IF (IOPT .EQ. 1) THEN
5869C
5870                     NLJ = IMATIJ(ISYML,ISYMJ)
5871     *                   + NRHF(ISYML)*(J - 1) + L
5872C
5873                  ELSE IF (IOPT .EQ. 2) THEN
5874C
5875                     NLJ = IMATIJ(ISYMJ,ISYML)
5876     *                   + NRHF(ISYMJ)*(L - 1) + J
5877C
5878                  ENDIF
5879C
5880                  DO 140 ISYMK = 1,NSYM
5881C
5882                     ISYMI = MULD2H(ISYMK,ISYMKI)
5883C
5884                     DO 150 I = 1,NRHF(ISYMI)
5885C
5886                        DO 160 K = 1,NRHF(ISYMK)
5887C
5888                           IF (IOPT .EQ. 1) THEN
5889C
5890                              NKI = IMATIJ(ISYMK,ISYMI)
5891     *                            + NRHF(ISYMK)*(I - 1) + K
5892C
5893                           ELSE IF (IOPT .EQ. 2) THEN
5894C
5895                              NKI = IMATIJ(ISYMI,ISYMK)
5896     *                            + NRHF(ISYMI)*(K - 1) + I
5897C
5898                           ENDIF
5899C
5900                           IF (ISYMKI .EQ. ISYMLJ) THEN
5901                              NKILJ = IGAMMA(ISYMKI,ISYMLJ)
5902     *                              + INDEX(NKI,NLJ)
5903                              FACT = ONE
5904                              IF (NKI .EQ. NLJ) FACT = ZERO
5905                              IF (NKI .LT. NLJ) FACT = XMONE
5906                           ELSE
5907                              IF (ISYMKI .LT. ISYMLJ) THEN
5908                                 NKILJ = IGAMMA(ISYMKI,ISYMLJ)
5909     *                                 + NMATIJ(ISYMKI)*(NLJ - 1) + NKI
5910                                 FACT  = XMONE
5911                              ELSE
5912                                 NKILJ = IGAMMA(ISYMLJ,ISYMKI)
5913     *                                 + NMATIJ(ISYMLJ)*(NKI - 1) + NLJ
5914                                 FACT  = ONE
5915                              ENDIF
5916                           ENDIF
5917C
5918                           IF (.NOT. ANTISYM) FACT = ONE
5919!
5920                           NSTO = IMATIJ(ISYMK,ISYMI)
5921     *                          + NRHF(ISYMK)*(I - 1) + K
5922C
5923                           WORK(KSCR1 + NSTO - 1) = FACT * GAMMA(NKILJ)
5924C
5925  160                   CONTINUE
5926  150                CONTINUE
5927  140             CONTINUE
5928C
5929                  DO 170 ISYMB = 1,NSYM
5930C
5931                     ISYMBJ = MULD2H(ISYMB,ISYMJ)
5932                     ISYMAI = MULD2H(ISYMBJ,ISAIBJ)
5933                     ISYMBL = MULD2H(ISYMB,ISYML)
5934                     ISYMAK = MULD2H(ISYVEC,ISYMBL)
5935C
5936                     KSCR2 = KEND1
5937                     KEND2 = KSCR2 + NT1AM(ISYMAI)
5938                     LWRK2 = LWORK - KEND2
5939C
5940                     IF (LWRK2 .LT. 0) THEN
5941                        CALL QUIT('Insufficient space in CCRHS_A3')
5942                     END IF
5943C
5944                     IF (ISYMAI .GT. ISYMBJ) GOTO 170
5945C
5946                     DO 180 B = 1,NVIR(ISYMB)
5947C
5948                        NBJ = IT1AM(ISYMB,ISYMJ)
5949     *                      + NVIR(ISYMB)*(J - 1) + B
5950                        NBL = IT1AM(ISYMB,ISYML)
5951     *                      + NVIR(ISYMB)*(L - 1) + B
5952C
5953                        CALL DZERO(WORK(KSCR2),NT1AM(ISYMAI))
5954C
5955                        DO 190 ISYMI = 1,NSYM
5956C
5957                           ISYMK = MULD2H(ISYMI,ISYMKI)
5958                           ISYMA = MULD2H(ISYMK,ISYMAK)
5959C
5960                           NVIRA = MAX(NVIR(ISYMA),1)
5961                           NRHFK = MAX(NRHF(ISYMK),1)
5962C
5963                           KOFF1 = IT2SQ(ISYMAK,ISYMBL)
5964     *                           + NT1AM(ISYMAK)*(NBL - 1)
5965     *                           + IT1AM(ISYMA,ISYMK) + 1
5966                           KOFF2 = KSCR1 + IMATIJ(ISYMK,ISYMI)
5967                           KOFF3 = KSCR2 + IT1AM(ISYMA,ISYMI)
5968C
5969                           CALL DGEMM('N','N',NVIR(ISYMA),NRHF(ISYMI),
5970     *                                NRHF(ISYMK),ONE,T2AM(KOFF1),
5971     *                                NVIRA,WORK(KOFF2),NRHFK,ZERO,
5972     *                                WORK(KOFF3),NVIRA)
5973C
5974  190                   CONTINUE
5975C
5976                        IF (ISYMAI .EQ. ISYMBJ) THEN
5977                           NTOT = NBJ
5978                        ELSE
5979                           NTOT = NT1AM(ISYMAI)
5980                        ENDIF
5981C
5982                        DO 200 NAI = 1,NTOT
5983C
5984                           IF (ISYMAI .EQ. ISYMBJ) THEN
5985                              NAIBJ = IT2AM(ISYMAI,ISYMBJ)
5986     *                              + INDEX(NAI,NBJ)
5987                           ELSE
5988                              NAIBJ = IT2AM(ISYMAI,ISYMBJ)
5989     *                              + NT1AM(ISYMAI)*(NBJ - 1) + NAI
5990                           ENDIF
5991C
5992                           OMEGA2(NAIBJ) = OMEGA2(NAIBJ)
5993     *                                   + WORK(KSCR2 + NAI - 1)
5994C
5995  200                   CONTINUE
5996C
5997  180                CONTINUE
5998  170             CONTINUE
5999C
6000  130          CONTINUE
6001  120       CONTINUE
6002  110    CONTINUE
6003  100 CONTINUE
6004C
6005      CALL QEXIT('CCRHS_A3')
6006C
6007      RETURN
6008      END
6009C  /* Deck cc_t2sq3 */
6010      SUBROUTINE CC_T2SQ3(T2AM,T2SQ,ISYM)
6011!
6012!--------------------------------------------------------
6013!     Kasper Hald 8/3-1999 to squareup a
6014!     antisymmetric matrix as in the triplet case.
6015!
6016!     Based on CC_T2SQ by Henrik Koch, Alfredo Sanchez
6017!     and Ove Christiansen.
6018!--------------------------------------------------------
6019!
6020      IMPLICIT NONE
6021#if defined (SYS_CRAY)
6022      REAL T2AM(*), T2SQ(*)
6023#else
6024      DOUBLE PRECISION T2AM(*), T2SQ(*)
6025#endif
6026      INTEGER ISYM, KOFF1, KOFF2, ISYMBJ, KOFF, ISYMAI, NAMP, NAI
6027      INTEGER NBJ
6028#include "priunit.h"
6029#include "ccorb.h"
6030#include "ccsdsym.h"
6031!
6032      CALL QENTER('CC_T2SQ3')
6033!
6034      IF (ISYM.EQ.1) THEN
6035         KOFF1 = 1
6036         KOFF2 = 1
6037         DO 100 ISYMBJ = 1,NSYM
6038            IF (NT1AM(ISYMBJ) .GT. 0) THEN
6039               CALL SQMATR3(NT1AM(ISYMBJ),T2AM(KOFF1),T2SQ(KOFF2))
6040               KOFF1 = KOFF1 + NT1AM(ISYMBJ)*(NT1AM(ISYMBJ)+1)/2
6041               KOFF2 = KOFF2 + NT1AM(ISYMBJ)*NT1AM(ISYMBJ)
6042            ENDIF
6043  100    CONTINUE
6044!
6045      ELSE
6046!
6047         KOFF = 1
6048         DO 200 ISYMBJ = 1,NSYM
6049            ISYMAI = MULD2H(ISYM,ISYMBJ)
6050!
6051            IF (ISYMBJ.GT.ISYMAI) THEN
6052!
6053               NAMP = NT1AM(ISYMAI)*NT1AM(ISYMBJ)
6054!
6055               IF (NAMP .GT. 0) THEN
6056                  KOFF1 = IT2SQ(ISYMAI,ISYMBJ) + 1
6057                  CALL DCOPY(NAMP,T2AM(KOFF),1,T2SQ(KOFF1),1)
6058                  NAI = MAX(NT1AM(ISYMAI),1)
6059                  NBJ = MAX(NT1AM(ISYMBJ),1)
6060                  KOFF2 = IT2SQ(ISYMBJ,ISYMAI) + 1
6061                  CALL TRM3(T2AM(KOFF),NAI,NT1AM(ISYMAI),NT1AM(ISYMBJ),
6062     *                        T2SQ(KOFF2),NBJ)
6063                  KOFF = KOFF + NAMP
6064!
6065               ENDIF
6066!
6067            ENDIF
6068!
6069  200    CONTINUE
6070!
6071      ENDIF
6072!
6073      CALL QEXIT('CC_T2SQ3')
6074!
6075      RETURN
6076      END
6077!  /* Deck trm3 */
6078      SUBROUTINE TRM3(A,LDA,M,N,B,LDB)
6079!
6080!---------------------------------------------------------------
6081!
6082!     Transpose a matrix A with dimension m,n
6083!     in array with logical dim. lda.
6084!     and put minus the result into B with logical dim. ldb.
6085!
6086!     Kasper Hald 8/3 - 1999
6087!
6088!     Based on TRM by Ove Christiansen.
6089!---------------------------------------------------------------
6090!
6091      IMPLICIT NONE
6092#include "priunit.h"
6093!
6094      INTEGER LDA, LDB, M, N, I
6095#if defined (SYS_CRAY)
6096      REAL A(LDA,*), B(LDB,*)
6097      REAL XMONE
6098#else
6099      DOUBLE PRECISION A(LDA,*), B(LDB,*)
6100      DOUBLE PRECISION XMONE
6101#endif
6102      PARAMETER(XMONE = -1.0D00)
6103!
6104      CALL QENTER('TRM3')
6105!
6106      DO 100 I = 1, N
6107!
6108         CALL DSCAL(M,XMONE,A(1,I),1)
6109         CALL DCOPY(M,A(1,I),1,B(I,1),LDB)
6110         CALL DSCAL(M,XMONE,A(1,I),1)
6111!
6112 100  CONTINUE
6113!
6114      CALL QEXIT('TRM3')
6115!
6116      RETURN
6117      END
6118C  /* Deck sqmatr3 */
6119      SUBROUTINE SQMATR3(NDIM,PKMAT,SQMAT)
6120!
6121!-----------------------------------------------------
6122!     Written by Kasper Hald 8/3-1999
6123!
6124!     This subroutine squares up the packed
6125!     triplet matrix for the totalsymmetric case.
6126!
6127!     Based on SQMATR by Henrik Koch.
6128!-----------------------------------------------------
6129!
6130      IMPLICIT NONE
6131#include "priunit.h"
6132      INTEGER I, J, NDIM, IJ
6133#if defined (SYS_CRAY)
6134      REAL PKMAT(*), SQMAT(NDIM,NDIM)
6135      REAL ZERO,XMONE
6136#else
6137      DOUBLE PRECISION PKMAT(*), SQMAT(NDIM,NDIM)
6138      DOUBLE PRECISION ZERO,XMONE
6139#endif
6140!
6141      PARAMETER(XMONE = -1.0D00)
6142!
6143      CALL QENTER('SQMATR3')
6144!
6145      DO 100 I = 1,NDIM
6146         DO 110 J = 1,I
6147!
6148               IJ = I*(I-1)/2 + J
6149               SQMAT(I,J) = XMONE * PKMAT(IJ)
6150               SQMAT(J,I) = PKMAT(IJ)
6151!
6152  110    CONTINUE
6153  100 CONTINUE
6154!
6155      CALL QEXIT('SQMATR3')
6156!
6157      RETURN
6158      END
6159C  /* Deck cc_t2motrip */
6160      SUBROUTINE CC_T2MOTRIP(RHO1,CTR2,ISYMC2,OMEGA2,RHO2,GAMMA,
6161     *                       XLAMDP,XLAMPC,ISYMPC,WORK,LWORK,ISYMBF,
6162     *                       ICON,RHO22,RHO22CONT,ANTISYM)
6163C
6164C     Henrik Koch and Alfredo Sanchez.       15-July-1994
6165C
6166C     Transform the Omega2 vector from the AO basis to the MO
6167C     basis.
6168C
6169C     Ove Christiansen 4-8-1995:
6170C
6171C     Generalizations for CC response.
6172C
6173C        1.ISYMBF is the symmetry of the BF (ali,bej) vector.
6174C        2.Transform with a non total symmetric lambda matrix.
6175C          (one with sym 1 and one with sym isympc)
6176C
6177C        note that if newgam is true gamma is the gamma vector on return
6178C        with the same symmetry as the input BF.
6179C        (transformed with xlamdp)
6180C
6181C        if newgam is false the gamma intermediate is not returned.
6182C
6183C        ICON is 2 for response to calculat a-tild,ibj and ai,b-tilde,j
6184C
6185C        NB these changes are only carried through completely and
6186C        tested for omegor
6187C
6188C     Asger Halkier 2/11-1995:
6189C
6190C        For ICON equal to 3 the contraction of the (ali,bej) vector with
6191C        the trialvector CTR2 (i.e the LT21BF-term) is calculated and
6192C        stored in RHO1!
6193C
6194C     Ove Christiansen 4-10-1996:
6195C
6196C        For use in F-matrix generalize ICON .EQ. 3 section
6197C
6198!     Kasper Hald and Christof Haettig. 12-3-1999
6199!
6200!        If ANTISYM then rho is calculated as
6201!        INTP*KT2MM + INTM*KT2MP
6202!
6203!        For ICON .EQ. 1 AND antisym then we will get
6204!        Lambda(al a) * Lambda(be b) * rho(ANTISYM)
6205!
6206!        To ONLY calculate the new GAMMA ICON=4
6207!        The calculated gamma will be added to the excisting gamma
6208!
6209!        For ICON .EQ. 5 we calculate
6210!       (Lambda(bar)(be b)Lambda(al a) - Lambda(bar)(al a)Lambda(be b))
6211!       * rho(symmetric) and store it in RHO2.
6212!       (Lambda(bar)(be b)Lambda(al a) + Lambda(bar)(al a)Lambda(be b))
6213!       * rho(symmetric) and store it in RHO22.
6214!
6215!        For ICON .EQ. 6 : Here KT2MP is identical to zero (C2+ in the
6216!        triplet case) so we only calculate INTM*KT2MM
6217!
6218C     NOTE: Linear response options only valid and debugged for OMEGOR!
6219C
6220      IMPLICIT NONE
6221#include "priunit.h"
6222#include "maxorb.h"
6223#include "ccorb.h"
6224#include "ccsdsym.h"
6225#include "symsq.h"
6226#include "cclr.h"
6227!
6228      INTEGER INDEX, ISYMBF, ISYMPC, ISYMO1, ISYMO2, ISYMC2, ICON
6229      INTEGER ISYMJ, ISYMI, ISYMIJ, ISALBE, ISYMAB, ISYBE, ISYAL
6230      INTEGER ISYALI, ISYBEJ, ISYMA, NVA, NRA, ISYMB, NVB, NRB
6231      INTEGER KSCR1, KSCR2, KSCR3, KSCR4, KSCR5, KEND1, LWRK1
6232      INTEGER LWORK, NAI, NBJ, NAB, NAIBJ, NBJAI, NIJ, NABP
6233      INTEGER NABIJP, NABIJM, ISYMAI, ISYMBJ, NBASA, NBASB
6234      INTEGER NVIRA, KOFF1, KOFF2, ISYMK, ISYMC, ISYMD, ISYDI
6235      INTEGER ISYCJ, LENGTH, NTOTAL, NTOTBE, NTOTK, NCJ
6236      INTEGER NDICJ, NCK, NRHFA1, ISYML, ISYMKI, ISYMLJ, NLJ
6237      INTEGER NKL, NKI, NKILJ
6238!
6239#if defined (SYS_CRAY)
6240      REAL ZERO, HALF, ONE, TWO, FAC, FAC1, FAC2, FACT
6241      REAL RHO1(*), CTR2(*), OMEGA2(*), RHO2(*), GAMMA(*)
6242      REAL GAMMA(*), XLAMDP(*), WORK(*), XLAMPC(*), RHO22(*)
6243#else
6244      DOUBLE PRECISION ZERO, HALF, ONE, TWO, FAC, FAC1, FAC2, FACT
6245      DOUBLE PRECISION RHO1(*), CTR2(*), OMEGA2(*), RHO2(*), GAMMA(*)
6246      DOUBLE PRECISION XLAMDP(*), WORK(*), XLAMPC(*), RHO22(*)
6247#endif
6248      PARAMETER (ZERO= 0.0D00, HALF= 0.5D00, ONE= 1.0D00, TWO= 2.0D00)
6249!
6250      LOGICAL ANTISYM, RHO22CONT
6251C
6252      INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J
6253C
6254      CALL QENTER('CC_T2MOTRIP')
6255C
6256      ISYMO2 = MULD2H(ISYMBF,ISYMPC)
6257      ISYMO1 = MULD2H(ISYMO2,ISYMC2)
6258C
6259      IF (ICON .NE. 3) THEN
6260         CALL DZERO(RHO2,NT2AM(ISYMO2))
6261      ENDIF
6262C
6263      DO 100 ISYMJ = 1,NSYM
6264         DO 110 ISYMI = 1,NSYM
6265C
6266            ISYMIJ = MULD2H(ISYMI,ISYMJ)
6267            ISALBE = MULD2H(ISYMIJ,ISYMBF)
6268            ISYMAB = MULD2H(ISYMIJ,ISYMO2)
6269C
6270            DO 120 ISYBE = 1,NSYM
6271C
6272               ISYAL  = MULD2H(ISYBE,ISALBE)
6273               ISYALI = MULD2H(ISYAL,ISYMI)
6274               ISYBEJ = MULD2H(ISYBE,ISYMJ)
6275C
6276C-----------------------------------------------
6277C              Dynamic allocation of work space.
6278C-----------------------------------------------
6279C
6280               ISYMA = MULD2H(ISYAL,ISYMPC)
6281               NVA = MAX(NVIR(ISYMA),NVIR(ISYAL))
6282               NRA = MAX(NRHF(ISYMA),NRHF(ISYAL))
6283               ISYMB = MULD2H(ISYBE,ISYMPC)
6284               NVB = MAX(NVIR(ISYMB),NVIR(ISYBE),NRHF(ISYBE))
6285               NRB = MAX(NRHF(ISYMB),NRHF(ISYBE))
6286C
6287               KSCR1 = 1
6288               KSCR2 = KSCR1 + NBAS(ISYAL)*NBAS(ISYBE)
6289               KSCR3 = KSCR2 + NBAS(ISYAL)*NVB
6290               IF (NEWGAM) THEN
6291                  KSCR4 = KSCR3 + NVA*NVB
6292                  KSCR5 = KSCR4 + NBAS(ISYAL)*NRB
6293                  KEND1 = KSCR5 + NRA*NRB
6294               ELSE
6295                  KEND1 = KSCR3 + NVA*NVB
6296               END IF
6297               LWRK1 = LWORK - KEND1
6298C
6299               IF (LWRK1 .LT. 0) THEN
6300                  CALL QUIT('Not enough space in CC_T2MOTRIP')
6301               END IF
6302C
6303               DO 130 J = 1,NRHF(ISYMJ)
6304                  DO 140 I = 1,NRHF(ISYMI)
6305C
6306C------------------------------------------
6307C                    Squareup the AB block.
6308C------------------------------------------
6309C
6310                     IF ((.NOT. OMEGSQ) .AND. (.NOT. OMEGOR)) THEN
6311C
6312                     DO 150 B = 1,NBAS(ISYBE)
6313                        NBJ   = IT1AO(ISYBE,ISYMJ)
6314     *                        + NBAS(ISYBE)*(J-1) + B
6315                        DO 155 A = 1,NBAS(ISYAL)
6316C
6317                           NAI   = IT1AO(ISYAL,ISYMI)
6318     *                           + NBAS(ISYAL)*(I-1) + A
6319                           NAB   = KSCR1 + NBAS(ISYAL)*(B - 1) + A - 1
6320C
6321                           IF (ISYMO2 .EQ. 1) THEN
6322                              NAIBJ = IT2AO(ISYALI,ISYBEJ)
6323     *                              + INDEX(NAI,NBJ)
6324                           ELSEIF (ISYALI .LT. ISYBEJ) THEN
6325                              NAIBJ = IT2AO(ISYALI,ISYBEJ)
6326     *                              + NT1AO(ISYALI)*(NBJ - 1) + NAI
6327                           ELSEIF (ISYALI .GT. ISYBEJ) THEN
6328                              NAIBJ = IT2AO(ISYALI,ISYBEJ)
6329     *                              + NT1AO(ISYBEJ)*(NAI - 1) + NBJ
6330                           ENDIF
6331C
6332                           WORK(NAB) = OMEGA2(NAIBJ)
6333C
6334  155                   CONTINUE
6335  150                CONTINUE
6336C
6337                     ENDIF
6338C
6339                     IF (OMEGSQ) THEN
6340C
6341                     DO 160 B = 1,NBAS(ISYBE)
6342                        NBJ   = IT1AO(ISYBE,ISYMJ)
6343     *                        + NBAS(ISYBE)*(J-1) + B
6344                        DO 165 A = 1,NBAS(ISYAL)
6345C
6346                           NAI   = IT1AO(ISYAL,ISYMI)
6347     *                           + NBAS(ISYAL)*(I-1) + A
6348                           NAB   = KSCR1 + NBAS(ISYAL)*(B - 1) + A - 1
6349C
6350                           NAIBJ = IT2AOS(ISYALI,ISYBEJ)
6351     *                           + NT1AO(ISYALI)*(NBJ - 1) + NAI
6352                           NBJAI = IT2AOS(ISYBEJ,ISYALI)
6353     *                           + NT1AO(ISYBEJ)*(NAI - 1) + NBJ
6354C
6355                           WORK(NAB) = OMEGA2(NAIBJ) + OMEGA2(NBJAI)
6356C
6357  165                   CONTINUE
6358  160                CONTINUE
6359C
6360                     ENDIF
6361C
6362                     IF (OMEGOR) THEN
6363!
6364                     IF (.NOT. ANTISYM) THEN
6365!
6366                     IF (ISYMI .EQ. ISYMJ) THEN
6367                        NIJ = IMIJP(ISYMI,ISYMJ) + INDEX(I,J)
6368                        FAC1 = ONE
6369                        IF (I .GT. J) FAC1 = -ONE
6370                     ELSE IF (ISYMI .LT. ISYMJ) THEN
6371                        NIJ = IMIJP(ISYMI,ISYMJ)
6372     *                      + NRHF(ISYMI)*(J - 1) + I
6373                        FAC1 = ONE
6374                     ELSE
6375                        NIJ = IMIJP(ISYMI,ISYMJ)
6376     *                      + NRHF(ISYMJ)*(I - 1) + J
6377                        FAC1 = -ONE
6378                     ENDIF
6379C
6380                     DO 166 B = 1,NBAS(ISYBE)
6381                        DO 167 A = 1,NBAS(ISYAL)
6382C
6383                           IF (ISYAL .EQ. ISYBE) THEN
6384                              NABP = IAODPK(ISYAL,ISYBE)
6385     *                             + INDEX(A,B)
6386                              FAC2 = ONE
6387                              IF (A .GT. B) FAC2 = -ONE
6388                           ELSE IF (ISYAL .LT. ISYBE) THEN
6389                              NABP = IAODPK(ISYAL,ISYBE)
6390     *                             + NBAS(ISYAL)*(B - 1) + A
6391                              FAC2 = ONE
6392                           ELSE
6393                              NABP = IAODPK(ISYAL,ISYBE)
6394     *                             + NBAS(ISYBE)*(A - 1) + B
6395                              FAC2 = -ONE
6396                           ENDIF
6397C
6398                           IF (ICON .NE. 6) THEN
6399                           NABIJP = IT2ORT(ISALBE,ISYMIJ)
6400     *                            + NNBST(ISALBE)*(NIJ - 1) + NABP
6401C
6402                           NABIJM = NT2ORT(ISYMBF)
6403     *                            + IT2ORT(ISALBE,ISYMIJ)
6404     *                            + NNBST(ISALBE)*(NIJ - 1) + NABP
6405!
6406                           ELSE
6407                           NABIJM = IT2ORT(ISALBE,ISYMIJ)
6408     *                            + NNBST(ISALBE)*(NIJ - 1) + NABP
6409!
6410                           ENDIF
6411C
6412                           NAB   = KSCR1 + NBAS(ISYAL)*(B - 1) + A - 1
6413C
6414                           FAC = FAC1*FAC2
6415C
6416                           IF (ICON .NE. 6) THEN
6417                           WORK(NAB) =
6418     *                       HALF*(OMEGA2(NABIJP) + FAC*OMEGA2(NABIJM))
6419                           ELSE
6420                           WORK(NAB) = HALF*FAC*OMEGA2(NABIJM)
6421                           ENDIF
6422C
6423  167                   CONTINUE
6424  166                CONTINUE
6425C
6426                     ELSE
6427!
6428                        IF (ISYMI .EQ. ISYMJ) THEN
6429                           NIJ = IMIJP(ISYMI,ISYMJ) + INDEX(I,J)
6430                           FAC1 = ONE
6431                           IF (I .GT. J) FAC1 = -ONE
6432!
6433                        ELSE IF (ISYMI .LT. ISYMJ) THEN
6434                           NIJ = IMIJP(ISYMI,ISYMJ)
6435     *                         + NRHF(ISYMI)*(J - 1) + I
6436                           FAC1 = ONE
6437                        ELSE
6438                           NIJ = IMIJP(ISYMI,ISYMJ)
6439     *                         + NRHF(ISYMJ)*(I - 1) + J
6440                           FAC1 = -ONE
6441                        ENDIF
6442!
6443                     DO 168 B = 1,NBAS(ISYBE)
6444                        DO 169 A = 1,NBAS(ISYAL)
6445!
6446                           IF (ISYAL .EQ. ISYBE) THEN
6447                              NABP = IAODPK(ISYAL,ISYBE)
6448     *                             + INDEX(A,B)
6449                              FAC2 = ONE
6450                              IF (A .GT. B) FAC2 = -ONE
6451                           ELSE IF (ISYAL .LT. ISYBE) THEN
6452                              NABP = IAODPK(ISYAL,ISYBE)
6453     *                             + NBAS(ISYAL)*(B - 1) + A
6454                              FAC2 = ONE
6455                           ELSE
6456                              NABP = IAODPK(ISYAL,ISYBE)
6457     *                             + NBAS(ISYBE)*(A - 1) + B
6458                              FAC2 = -ONE
6459                           ENDIF
6460!
6461                           NABIJP = IT2ORT(ISALBE,ISYMIJ)
6462     *                            + NNBST(ISALBE)*(NIJ - 1) + NABP
6463!
6464                           NABIJM = NT2ORT(ISYMBF)
6465     *                            + IT2ORT(ISALBE,ISYMIJ)
6466     *                            + NNBST(ISALBE)*(NIJ - 1) + NABP
6467!
6468                           NAB   = KSCR1 + NBAS(ISYAL)*(B - 1) + A - 1
6469!
6470!
6471                           IF ((ISYAL .EQ. ISYBE) .AND.
6472     *                         (ISYMI. EQ. ISYMJ) .AND. (A .EQ. B)
6473     *                         .AND. (I .EQ. J)) THEN
6474!
6475                               WORK(NAB) = ZERO
6476!
6477                           ELSE
6478!
6479                              WORK(NAB) =
6480     *                          HALF*(OMEGA2(NABIJP)*FAC2
6481     *                              + FAC1*OMEGA2(NABIJM))
6482                           ENDIF
6483!
6484  169                   CONTINUE
6485  168                CONTINUE
6486!
6487                     ENDIF
6488C
6489C------------------------------------------------------------
6490C                    Transform the AB block to virtual space.
6491C------------------------------------------------------------
6492C
6493!                 IF (.NOT. (ICON .EQ. 4)) THEN
6494!
6495                  IF (ICON .NE. 3) THEN
6496C
6497                     ISYMA = MULD2H(ISYAL,ISYMPC)
6498                     ISYMB = ISYBE
6499                     ISYMAI = MULD2H(ISYMA,ISYMI)
6500                     ISYMBJ = MULD2H(ISYMB,ISYMJ)
6501C
6502                     NBASA = MAX(NBAS(ISYAL),1)
6503                     NBASB = MAX(NBAS(ISYBE),1)
6504                     NVIRA = MAX(NVIR(ISYMA),1)
6505C
6506                     KOFF1 = ILMVIR(ISYBE) + 1
6507C
6508                     CALL DGEMM('N','N',NBAS(ISYAL),NVIR(ISYMB),
6509     *                          NBAS(ISYBE),ONE,WORK(KSCR1),NBASA,
6510     *                          XLAMDP(KOFF1),NBASB,ZERO,WORK(KSCR2),
6511     *                          NBASA)
6512C
6513                     KOFF2 = IGLMVI(ISYAL,ISYMA) + 1
6514C
6515                     CALL DGEMM('T','N',NVIR(ISYMA),NVIR(ISYMB),
6516     *                          NBAS(ISYAL),ONE,XLAMPC(KOFF2),NBASA,
6517     *                          WORK(KSCR2),NBASA,ZERO,WORK(KSCR3),
6518     *                          NVIRA)
6519C
6520C--------------------------------------------
6521C                    Store the omega2 vector.
6522C--------------------------------------------
6523C
6524                     DO 170 B = 1,NVIR(ISYMB)
6525                        NBJ   = IT1AM(ISYMB,ISYMJ)
6526     *                        + NVIR(ISYMB)*(J-1) + B
6527                        DO 180 A = 1,NVIR(ISYMA)
6528C
6529                           NAI   = IT1AM(ISYMA,ISYMI)
6530     *                           + NVIR(ISYMA)*(I-1) + A
6531                           NAB   = KSCR3 + NVIR(ISYMA)*(B - 1) + A - 1
6532C
6533                           IF (ISYMAI .EQ. ISYMBJ) THEN
6534C
6535                              IF (NAI .GT. NBJ) GOTO 180
6536C
6537                              NAIBJ = IT2AM(ISYMAI,ISYMBJ)
6538     *                              + INDEX(NAI,NBJ)
6539                           ELSEIF (ISYMAI .LT. ISYMBJ) THEN
6540                              NAIBJ = IT2AM(ISYMAI,ISYMBJ)
6541     *                              + NT1AM(ISYMAI)*(NBJ - 1) + NAI
6542                           ELSEIF (ISYMAI .GT. ISYMBJ) THEN
6543                              GOTO 180
6544c                             NAIBJ = IT2AM(ISYMAI,ISYMBJ)
6545c    *                              + NT1AM(ISYMBJ)*(NAI - 1) + NBJ
6546                           ENDIF
6547C
6548                           RHO2(NAIBJ) = RHO2(NAIBJ) + WORK(NAB)
6549!
6550                           IF ((ICON .EQ.5) .AND. (RHO22CONT)) THEN
6551                              RHO22(NAIBJ) = RHO22(NAIBJ) + WORK(NAB)
6552                           ENDIF
6553C
6554  180                   CONTINUE
6555  170                CONTINUE
6556C
6557                  ENDIF
6558C
6559C--------------------------------------
6560C                    CCLR contribution.
6561C--------------------------------------
6562C
6563                     IF ((ICON .EQ. 2) .OR. (ICON .EQ. 5)) THEN
6564C
6565                        CALL DZERO(WORK(KSCR2),NVA*NVB)
6566                        ISYMA = ISYAL
6567                        ISYMB = MULD2H(ISYBE,ISYMPC)
6568                        ISYMAI = MULD2H(ISYMA,ISYMI)
6569                        ISYMBJ = MULD2H(ISYMB,ISYMJ)
6570C
6571                        NBASA = MAX(NBAS(ISYAL),1)
6572                        NBASB = MAX(NBAS(ISYBE),1)
6573                        NVIRA = MAX(NVIR(ISYMA),1)
6574C
6575                        IF ((ICON .EQ. 5)) THEN
6576                            FACT = -ONE
6577                        ELSE
6578                            FACT = ONE
6579                        ENDIF
6580C
6581                        KOFF1 = IGLMVI(ISYBE,ISYMB) + 1
6582C
6583                        CALL DGEMM('N','N',NBAS(ISYAL),NVIR(ISYMB),
6584     *                             NBAS(ISYBE),FACT,WORK(KSCR1),NBASA,
6585     *                             XLAMPC(KOFF1),NBASB,ZERO,WORK(KSCR2),
6586     *                             NBASA)
6587C
6588                        KOFF2 = ILMVIR(ISYAL) + 1
6589C
6590                        CALL DGEMM('T','N',NVIR(ISYMA),NVIR(ISYMB),
6591     *                             NBAS(ISYAL),ONE,XLAMDP(KOFF2),NBASA,
6592     *                             WORK(KSCR2),NBASA,ZERO,WORK(KSCR3),
6593     *                             NVIRA)
6594C
6595C--------------------------------------------
6596C                    Store the omega2 vector.
6597C--------------------------------------------
6598C
6599                     DO 181 B = 1,NVIR(ISYMB)
6600                        NBJ   = IT1AM(ISYMB,ISYMJ)
6601     *                        + NVIR(ISYMB)*(J-1) + B
6602                        DO 182 A = 1,NVIR(ISYMA)
6603C
6604                           NAI   = IT1AM(ISYMA,ISYMI)
6605     *                           + NVIR(ISYMA)*(I-1) + A
6606C
6607                           IF (ISYMAI .EQ. ISYMBJ) THEN
6608                              IF (NAI .GT. NBJ ) GOTO 182
6609                              NAIBJ = IT2AM(ISYALI,ISYBEJ)
6610     *                              + INDEX(NAI,NBJ)
6611                           ELSEIF (ISYMAI .LT. ISYMBJ) THEN
6612                              NAIBJ = IT2AM(ISYMAI,ISYMBJ)
6613     *                              + NT1AM(ISYMAI)*(NBJ - 1) + NAI
6614                           ELSEIF (ISYMAI .GT. ISYMBJ) THEN
6615                              GOTO 182
6616c                             NAIBJ = IT2AM(ISYMAI,ISYMBJ)
6617c    *                              + NT1AM(ISYMBJ)*(NAI - 1) + NBJ
6618                           ENDIF
6619C
6620                           NAB  = KSCR3+ NVIR(ISYMA)*(B - 1) + A - 1
6621                           RHO2(NAIBJ) = RHO2(NAIBJ) + WORK(NAB)
6622!
6623                           IF ((ICON .EQ. 5) .AND. (RHO22CONT)) THEN
6624                             RHO22(NAIBJ) = RHO22(NAIBJ) - WORK(NAB)
6625                           ENDIF
6626C
6627  182                   CONTINUE
6628  181                CONTINUE
6629C
6630                     ENDIF
6631C
6632C============================================================
6633C                    Section for calculating the LT21BF-term.
6634C============================================================
6635C
6636                     IF (ICON .EQ. 3) THEN
6637C
6638                        ISYMK = ISYBE
6639                        ISYMD = MULD2H(ISYAL,ISYMPC)
6640                        ISYMC = MULD2H(ISYMK,ISYMO1)
6641                        ISYDI = MULD2H(ISYMD,ISYMI)
6642                        ISYCJ = MULD2H(ISYMC,ISYMJ)
6643C
6644                        LENGTH = NBAS(ISYAL)*NRHF(ISYMK)
6645C
6646                        CALL DZERO(WORK(KSCR2),LENGTH)
6647C
6648C----------------------------------------------------------
6649C                       Transform the AO-block to MO-basis.
6650C----------------------------------------------------------
6651C
6652                        KOFF1  = ILMRHF(ISYMK) + 1
6653C
6654                        NTOTAL = MAX(NBAS(ISYAL),1)
6655                        NTOTBE = MAX(NBAS(ISYBE),1)
6656C
6657                        CALL DGEMM('N','N',NBAS(ISYAL),NRHF(ISYMK),
6658     *                             NBAS(ISYBE),ONE,WORK(KSCR1),NTOTAL,
6659     *                             XLAMDP(KOFF1),NTOTBE,ZERO,
6660     *                             WORK(KSCR2),NTOTAL)
6661C
6662                        KOFF2  = IGLMVI(ISYAL,ISYMD) + 1
6663C
6664                        NTOTAL = MAX(NBAS(ISYAL),1)
6665                        NTOTK  = MAX(NRHF(ISYMK),1)
6666C
6667                        CALL DGEMM('T','N',NRHF(ISYMK),NVIR(ISYMD),
6668     *                             NBAS(ISYAL),ONE,WORK(KSCR2),NTOTAL,
6669     *                             XLAMPC(KOFF2),NTOTAL,ZERO,
6670     *                             WORK(KSCR3),NTOTK)
6671C
6672C-----------------------------------------------------------------
6673C                       Contraction with CTR2 & storage in result.
6674C-----------------------------------------------------------------
6675C
6676                        DO 47 C = 1,NVIR(ISYMC)
6677C
6678                           NCJ   = IT1AM(ISYMC,ISYMJ)
6679     *                           + NVIR(ISYMC)*(J - 1) + C
6680                           NDICJ = IT2SQ(ISYDI,ISYCJ)
6681     *                           + NT1AM(ISYDI)*(NCJ - 1)
6682     *                           + IT1AM(ISYMD,ISYMI)
6683     *                           + NVIR(ISYMD)*(I - 1) + 1
6684                           NCK   = IT1AM(ISYMC,ISYMK) + C
6685C
6686                           CALL DGEMV('N',NRHF(ISYMK),NVIR(ISYMD),
6687     *                                -ONE,WORK(KSCR3),NTOTK,
6688     *                                CTR2(NDICJ),1,ONE,RHO1(NCK),
6689     *                                NVIR(ISYMC))
6690C
6691  47                    CONTINUE
6692C
6693                     ENDIF
6694C
6695                  ENDIF
6696!
6697C-------------------------------------------------------------
6698C                    Transform the AB block to occupied space.
6699C-------------------------------------------------------------
6700C
6701                     IF (.NOT. NEWGAM) GOTO 999
6702C
6703                     NBASA = MAX(NBAS(ISYAL),1)
6704                     NBASB = MAX(NBAS(ISYBE),1)
6705                     NRHFA1 = MAX(NRHF(ISYAL),1)
6706C
6707                     KOFF1 = ILMRHF(ISYBE) + 1
6708C
6709                     CALL DGEMM('N','N',NBAS(ISYAL),NRHF(ISYBE),
6710     *                          NBAS(ISYBE),ONE,WORK(KSCR1),NBASA,
6711     *                          XLAMDP(KOFF1),NBASB,ZERO,WORK(KSCR4),
6712     *                          NBASA)
6713C
6714                     KOFF2 = ILMRHF(ISYAL) + 1
6715C
6716                     CALL DGEMM('T','N',NRHF(ISYAL),NRHF(ISYBE),
6717     *                          NBAS(ISYAL),ONE,XLAMDP(KOFF2),NBASA,
6718     *                          WORK(KSCR4),NBASA,ZERO,WORK(KSCR5),
6719     *                          NRHFA1)
6720C
6721C-------------------------------------------
6722C                    Store the gamma matrix.
6723C-------------------------------------------
6724C
6725                     ISYMK = ISYAL
6726                     ISYML = ISYBE
6727C
6728                     ISYMKI = MULD2H(ISYMK,ISYMI)
6729                     ISYMLJ = MULD2H(ISYML,ISYMJ)
6730C
6731                     DO 190 L = 1,NRHF(ISYML)
6732C
6733                        NLJ = IMATIJ(ISYML,ISYMJ)
6734     *                      + NRHF(ISYML)*(J - 1) + L
6735C
6736                        DO 200 K = 1,NRHF(ISYMK)
6737C
6738                           NKL = KSCR5 + NRHF(ISYMK)*(L - 1) + K - 1
6739C
6740                           NKI = IMATIJ(ISYMK,ISYMI)
6741     *                         + NRHF(ISYMK)*(I - 1) + K
6742C
6743                           IF (ISYMKI .EQ. ISYMLJ) THEN
6744                              NKILJ = IGAMMA(ISYMKI,ISYMLJ)
6745     *                              + INDEX(NKI,NLJ)
6746                              IF (NKI .LE. NLJ) THEN
6747                                 GAMMA(NKILJ) = GAMMA(NKILJ)
6748     *                                        + WORK(NKL)
6749                              ENDIF
6750                           ELSE IF (ISYMKI .LT. ISYMLJ) THEN
6751                              NKILJ = IGAMMA(ISYMKI,ISYMLJ)
6752     *                              + NMATIJ(ISYMKI)*(NLJ - 1) + NKI
6753                              GAMMA(NKILJ) = GAMMA(NKILJ) + WORK(NKL)
6754                           ENDIF
6755C
6756  200                   CONTINUE
6757  190                CONTINUE
6758  999                CONTINUE
6759  140             CONTINUE
6760  130          CONTINUE
6761  120       CONTINUE
6762  110    CONTINUE
6763  100 CONTINUE
6764C
6765      CALL QEXIT('CC_T2MOTRIP')
6766C
6767      RETURN
6768      END
6769C  /* Deck hescompa */
6770      SUBROUTINE HESCOMPA(REDHES1,REDHES2,NREDH,NCOMPO,COMTHRES)
6771!
6772!     Written by Kasper Hald 3/2-2000
6773!
6774!     Compares 2 Hessian matrices.
6775!     This routine is only meant to be used for
6776!     comparisons of "small" arrays, since it scales
6777!     as N^8
6778!
6779!     REDHES1 and REDHES2 are the 2 Hessians (Surprise?)
6780!     NREDH are the number of vectors/components that are
6781!     important.
6782!     NCOMPO are the no. of components per vector (greater or equal
6783!     to NREDH)
6784!     COMTHRES is the threshold that you compare against
6785!
6786      IMPLICIT NONE
6787!
6788#include "priunit.h"
6789!
6790      INTEGER NREDH, NCOMPO, I, J, K, L, KOFF1, KOFF2
6791!
6792#if defined (SYS_CRAY)
6793      REAL REDHES1(*), REDHES2(*), COMTHRES
6794      REAL DIFF1, DIFF2
6795#else
6796      DOUBLE PRECISION REDHES1(*), REDHES2(*), COMTHRES
6797      DOUBLE PRECISION DIFF1, DIFF2
6798#endif
6799!
6800      CALL QENTER('HESCOMPA')
6801!
6802      WRITE(LUPRI,*)'                         '
6803      WRITE(LUPRI,*)'THRESHOLD FOR HESCOMPA = ',COMTHRES
6804      WRITE(LUPRI,*)'                         '
6805!
6806      DO I=1,NREDH
6807!
6808        DO J=1,NREDH
6809!
6810          KOFF1 = (I-1)*NCOMPO + J
6811          KOFF2 = (J-1)*NCOMPO + I
6812!
6813C         IF ((ABS(REDHES1(KOFF1)) .LT. COMTHRES) .AND.
6814C    *        (ABS(REDHES2(KOFF1)) .GT. COMTHRES)) THEN
6815C             WRITE(LUPRI,*)'Diff.1 for (J,I) = ',J,I
6816C             WRITE(LUPRI,*)'REDHES1(KOFF1) = ',REDHES1(KOFF1)
6817C             WRITE(LUPRI,*)'REDHES2(KOFF1) = ',REDHES2(KOFF1)
6818C         ENDIF
6819          IF ((ABS(REDHES1(KOFF1)) .GT. COMTHRES) .AND.
6820     *        (ABS(REDHES2(KOFF1)) .LT. COMTHRES)) THEN
6821              WRITE(LUPRI,*)'Diff.2 for (J,I) =',J,I
6822              WRITE(LUPRI,*)'REDHES1(KOFF1) = ',REDHES1(KOFF1)
6823              WRITE(LUPRI,*)'REDHES2(KOFF1) = ',REDHES2(KOFF1)
6824              WRITE(LUPRI,*)'REDHES1(KOFF2) = ',REDHES1(KOFF2)
6825              WRITE(LUPRI,*)'REDHES2(KOFF2) = ',REDHES2(KOFF2)
6826          ENDIF
6827!
6828        ENDDO
6829!
6830      ENDDO
6831!
6832!     DO I=1,NREDH
6833!
6834!       DO J=1,NCOMPO
6835!
6836!         DO K=1, NREDH
6837!
6838!           DO L=1, NCOMPO
6839!
6840!              KOFF1 = (I-1)*NCOMPO + J
6841!              KOFF2 = (K-1)*NCOMPO + L
6842!              DIFF1 = REDHES1(KOFF1) - REDHES1(KOFF2)
6843!              DIFF2 = REDHES2(KOFF1) - REDHES2(KOFF2)
6844!
6845!              IF ((DIFF1 .LT. COMTHRES) .AND.
6846!    *             (DIFF2 .GT. COMTHRES)) THEN
6847!                 WRITE(LUPRI,*)'COMPARISON ERROR FOR ELEMENTS NO. (',
6848!    *                      I,',',J,') and NO. (',K,',',L,') '
6849!                 WRITE(LUPRI,*)'Difference for Array1 = ',DIFF1
6850!                 WRITE(LUPRI,*)'Difference for Array2 = ',DIFF2
6851!              ENDIF
6852!              IF ((DIFF1 .GT. COMTHRES) .AND.
6853!    *             (DIFF2 .LT. COMTHRES)) THEN
6854!                 WRITE(LUPRI,*)'COMPARISON ERROR FOR ELEMENTS NO. (',
6855!    *                      I,',',J,') and NO. (',K,',',L,') '
6856!                 WRITE(LUPRI,*)'Difference for Array1 = ',DIFF1
6857!                 WRITE(LUPRI,*)'Difference for Array2 = ',DIFF2
6858!              ENDIF
6859!
6860!           ENDDO
6861!
6862!         ENDDO
6863!
6864!       ENDDO
6865!
6866!     ENDDO
6867!
6868      CALL QEXIT('HESCOMPA')
6869!
6870      RETURN
6871      END
6872