1!
2!  Dalton, a molecular electronic structure program
3!  Copyright (C) by the authors of Dalton.
4!
5!  This program is free software; you can redistribute it and/or
6!  modify it under the terms of the GNU Lesser General Public
7!  License version 2.1 as published by the Free Software Foundation.
8!
9!  This program is distributed in the hope that it will be useful,
10!  but WITHOUT ANY WARRANTY; without even the implied warranty of
11!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
12!  Lesser General Public License for more details.
13!
14!  If a copy of the GNU LGPL v2.1 was not distributed with this
15!  code, you can obtain one at https://www.gnu.org/licenses/old-licenses/lgpl-2.1.en.html.
16!
17!
18C
19*=====================================================================*
20C /* Deck cctrbt2 */
21      SUBROUTINE CCTRBT2(XINT,DSRHF,XLAMDP,ISYMLP,WORK,LWORK,
22     &                        ISYDIS,IOPT,LSQRINT,LSQRUP,SGNINT)
23*---------------------------------------------------------------------*
24*
25*     Purpose: Transform gamma index of integral batch
26*              I_{al be, gamma}^del to occupied.
27*
28*     XLAMDP,ISYMLP = lambda matrix and its symmetry
29*     XINT, ISYDIS  = I_{al be, gamma} batch and its symmetry
30*     Options:
31*       if IOPT = 0 overwrite result matrix
32*       if IOPT = 1 add to previous
33*       LSQRINT = TRUE, (alpha beta|* *) is full matrix (not packed)
34*       LSQRUP  = TRUE, square up (a b| after transformation of gamma
35*                       to k
36*       SGNINT  = sign of integral distribution
37*
38*   Written by Sonia Coriani 19-11-99, based on CCTRBT
39*
40*=====================================================================*
41#include "implicit.h"
42      PARAMETER(ZERO = 0.0D0, ONE = 1.0D0)
43*
44      DIMENSION XINT(*),DSRHF(*),XLAMDP(*),WORK(LWORK)
45      LOGICAL LSQRUP,LSQRINT
46*
47#include "ccorb.h"
48#include "ccsdsym.h"
49*
50      IF (IOPT.EQ.0) THEN
51         FAC = ZERO
52      ELSE IF (IOPT.EQ.1) THEN
53         FAC = ONE
54      ELSE
55        CALL QUIT('Unknown option in CCTRBT2')
56      ENDIF
57*
58* memory check when squaring
59*
60      IF (LSQRUP) THEN
61         DO ISYMJ = 1, NSYM
62            ISYMG    = MULD2H(ISYMLP,ISYMJ)
63            ISYMAB   = MULD2H(ISYMG,ISYDIS)
64            ISYDSRHF = MULD2H(ISYMAB,ISYMJ)
65            IF (LWORK.LT.NDSRHF(ISYDSRHF)) THEN
66              CALL QUIT('Insufficient memory in CCTRBT2')
67            END IF
68         END DO
69      END IF
70*
71* Calculate (al be|j)^del = sum_gam I^del_{al be, gam} Lambda_{gam j}
72*
73      DO ISYMJ = 1,NSYM
74*
75         ISYMG  = MULD2H(ISYMLP,ISYMJ)
76         ISYMAB = MULD2H(ISYMG,ISYDIS)
77         NBASG  = MAX(NBAS(ISYMG),1)
78
79         KOFF2  = 1 + IGLMRH(ISYMG,ISYMJ)
80
81         IF (LSQRINT) THEN
82            KOFF1  = 1 + IDSAOGSQ(ISYMG,ISYDIS)
83            KOFF3  = 1 + IDSRHFSQ(ISYMAB,ISYMJ)
84            NDIMAB = N2BST(ISYMAB)
85         ELSE
86            KOFF1  = 1 + IDSAOG(ISYMG,ISYDIS)
87            KOFF3  = 1 + IDSRHF(ISYMAB,ISYMJ)
88            NDIMAB = NNBST(ISYMAB)
89         END IF
90
91         NALBEM = MAX(NDIMAB,1)
92
93         IF (LSQRUP) THEN
94
95            CALL DGEMM('N','N',NDIMAB,NRHF(ISYMJ),NBAS(ISYMG),
96     *                 ONE,XINT(KOFF1),NALBEM,XLAMDP(KOFF2),NBASG,
97     *                 ZERO,WORK,NALBEM)
98
99            ! Resort (al>=be, k) to (al be| k)
100            ! Put in DSRHF which is dimensioned full (a b| from input
101            DO J = 1, NRHF(ISYMJ)
102              KOFF4 = NNBST(ISYMAB)*(J-1) + 1
103              KOFF5 = IDSRHFSQ(ISYMAB,ISYMJ) + N2BST(ISYMAB)*(J-1) + 1
104              CALL CCSD_SYMSQ(WORK(KOFF4),ISYMAB,DSRHF(KOFF5))
105            END DO
106
107         ELSE
108            CALL DGEMM('N','N',NDIMAB,NRHF(ISYMJ),NBAS(ISYMG),
109     *              SGNINT,XINT(KOFF1),NALBEM,XLAMDP(KOFF2),NBASG,
110     *                 FAC,DSRHF(KOFF3),NALBEM)
111         END IF
112
113      END DO
114
115      RETURN
116      END
117*---------------------------------------------------------------------*
118