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 cc_int4o */
21      SUBROUTINE CC_INT4O(XIJK0,ISYIJK0,XIJK1,ISYIJK1,
22     &                    XLAMDA0,ISYLAM0,
23     &                    XLAMDA1,ISYLAM1, ISYMD,
24     &                    XIJKL,LRELAX,WORK,LWORK,IOPT)
25*---------------------------------------------------------------------*
26*
27*     Purpose: transform the del index of (jk|ldel) to occupied L.
28*
29*     IOPT = 1 --> XIJKdel0 * XLAMDA0                (LRELAX = .FALSE.)
30*     IOPT = 2 --> XIJKdel0 * XLAMDA1 + XIJKdel1 * XLAMDA0
31*     XIJKL assumed initialized OUTSIDE
32*
33*     Sonia Coriani, 10/09-1999
34*---------------------------------------------------------------------*
35#if defined (IMPLICIT_NONE)
36      IMPLICIT NONE
37#else
38#  include "implicit.h"
39#endif
40#include "ccorb.h"
41#include "maxorb.h"
42#include "ccsdsym.h"
43
44      INTEGER ISYIJK0,ISYIJK1,ISYLAM0,ISYLAM1,IOPT, ISYMD,LWORK
45      LOGICAL LRELAX
46
47#if defined (SYS_CRAY)
48      REAL XIJK0(*), XIJK1(*), XIJKL(*)
49      REAL XLAMDA0(*), XLAMDA1(*), WORK(LWORK)
50      REAL ZERO, ONE, HALF, DDOT, XNORM
51#else
52      DOUBLE PRECISION XIJK0(*), XIJK1(*), XIJKL(*)
53      DOUBLE PRECISION XLAMDA0(*), XLAMDA1(*), WORK(LWORK)
54      DOUBLE PRECISION ZERO, ONE, HALF, DDOT, XNORM
55#endif
56      PARAMETER(ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0)
57      INTEGER KOFF1, KOFF2, KOFF3
58      INTEGER ISYIJKL, ISYML, NBASD, NTOIJK
59      INTEGER ISYIJKDE
60*
61*     --------------------------------------
62*     Begin: symmetry of result IJKL integrals
63*     --------------------------------------
64*
65      IF (IOPT.EQ.1) THEN
66         ISYIJKDE = MULD2H(ISYIJK0,ISYMD)
67         ISYIJKL  = MULD2H(ISYIJKDE,ISYLAM0)
68      ELSE
69         ISYIJKDE = MULD2H(ISYIJK1,ISYMD)
70         ISYIJKL  = MULD2H(ISYIJKDE,ISYLAM0)
71         IF (ISYIJKL .NE. MULD2H(ISYLAM1,MULD2H(ISYIJK0,ISYMD)))
72     &       CALL QUIT('Symmetry mismatch in CC_INT4O' )
73      END IF
74*
75*     -------------------------------------------------------*
76*        Transform AO integral index to occupied space. (L)
77*     -------------------------------------------------------*
78*
79      IF (IOPT.EQ.1) THEN
80         ISYML = MULD2H(ISYLAM0,ISYMD)
81         KOFF1 = 1
82         KOFF2 = IGLMRH(ISYMD,ISYML) + 1
83         KOFF3 = I3ORHF(ISYIJK0,ISYMD) + 1
84
85         NBASD   = MAX(NBAS(ISYMD),1)
86         NTOIJK  = MAX(NMAIJK(ISYIJK0),1)
87
88         CALL DGEMM('N','N',NMAIJK(ISYIJK0),NRHF(ISYML),NBAS(ISYMD),
89     &              ONE,XIJK0(KOFF1),NTOIJK,XLAMDA0(KOFF2),NBASD,
90     &              ONE,XIJKL(KOFF3),NTOIJK)
91       ELSE
92
93         ISYML  = MULD2H(ISYLAM0,ISYMD)
94         KOFF1  = 1
95         KOFF2  = IGLMRH(ISYMD,ISYML) + 1
96         KOFF3  = I3ORHF(ISYIJK1,ISYML) + 1
97         NTOIJK = MAX(NMAIJK(ISYIJK1),1)
98         NBASD  = MAX(NBAS(ISYMD),1)
99
100         CALL DGEMM('N','N',NMAIJK(ISYIJK1),NRHF(ISYML),NBAS(ISYMD),
101     &              ONE,XIJK1(KOFF1),NTOIJK,XLAMDA0(KOFF2),NBASD,
102     &              ONE,XIJKL(KOFF3),NTOIJK)
103c
104         ISYML  = MULD2H(ISYLAM1,ISYMD)
105         KOFF1  = 1
106         KOFF2  = IGLMRH(ISYMD,ISYML) + 1
107         KOFF3  = I3ORHF(ISYIJK0,ISYML) + 1
108         NTOIJK = MAX(NMAIJK(ISYIJK0),1)
109         NBASD  = MAX(NBAS(ISYMD),1)
110
111         CALL DGEMM('N','N',NMAIJK(ISYIJK0),NRHF(ISYML),NBAS(ISYMD),
112     &              ONE,XIJK0(KOFF1),NTOIJK,XLAMDA1(KOFF2),NBASD,
113     &              ONE,XIJKL(KOFF3),NTOIJK)
114
115      END IF
116      RETURN
117      END
118*=====================================================================*
119