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_e21con */
21      SUBROUTINE CC_E21CON(XJILK,ISYJILK,XIJKD0,ISYIJKD0,
22     &                     LUIJKD1,FNIJKD1,ISYIJKD1,
23     &                     XLAMDA0,ISYLAM0,XLAMDA1,ISYLAM1,LRELAX,
24     &                     ITRAN, WORK,LWORK)
25*---------------------------------------------------------------------*
26*
27*     Purpose:  lead calculation of E2' contribution to FBTA
28*               transformed vector
29*
30*     ISYIJK0 = symmetry of I_{ijk;delta}
31*     ISYIJK1 = symmetry of I^(1)_{ijk;delta}
32*
33*     Sonia Coriani, 14/09-1999
34*
35* Read derivative/relaxed integrals from file
36* call transformation to 4 occupied
37* resort to BF ordering
38* add to gammaQ(rho^BFQ)
39*---------------------------------------------------------------------*
40#if defined (IMPLICIT_NONE)
41      IMPLICIT NONE
42#else
43#  include "implicit.h"
44#endif
45#include "priunit.h"
46#include "ccorb.h"
47#include "maxorb.h"
48#include "ccsdsym.h"
49
50      LOGICAL LOCDBG
51      PARAMETER (LOCDBG = .FALSE.)
52      LOGICAL LSKIP4O
53      PARAMETER (LSKIP4O = .FALSE.)
54
55      INTEGER ISYIJKD0,ISYIJKD1,ISYLAM0,ISYLAM1,ITRAN,LWORK,IOPT
56      INTEGER LUIJKD1, ISYJILK, KOFFIJKL
57      LOGICAL LRELAX
58      CHARACTER*8 FNIJKD1
59
60#if defined (SYS_CRAY)
61      REAL XJILK(*), XIJKD0(*), XLAMDA0(*), XLAMDA1(*)
62      REAL ZERO, ONE, HALF, DNRM2, XNORM, WORK(LWORK)
63#else
64      DOUBLE PRECISION XJILK(*), XIJKD0(*), XLAMDA0(*), XLAMDA1(*)
65      DOUBLE PRECISION ZERO, ONE, HALF, DNRM2, XNORM, WORK(LWORK)
66#endif
67      PARAMETER(ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0)
68*
69      INTEGER ISYMD, ISYIJKL, NTOT, LWRK1, IOFF, N3ODMX,ISYM
70      INTEGER KXIJKL, KEND1, ISYML0, ISYML1
71      INTEGER KXIJK0, ISYIJK0, LENIJK0
72      INTEGER KXIJK1, ISYIJK1
73
74      IF (LOCDBG) THEN
75        WRITE (LUPRI,*) 'I am inside CC_E21CON: LRELAX = ', LRELAX
76        CALL CC_PRLAM(XLAMDA0,XLAMDA0,ISYLAM0)
77        CALL CC_PRLAM(XLAMDA1,XLAMDA1,ISYLAM1)
78        CALL FLSHFO(LUPRI)
79      END IF
80*---------------------------------------------------------------------*
81* precalculate some stuff
82*---------------------------------------------------------------------*
83      N3ODMX = 0
84      DO ISYM  = 1, NSYM
85        N3ODMX = MAX(N3ODMX,N3ODEL(ISYM))
86      END DO
87*     --------------------------------------
88*     Begin
89*     --------------------------------------
90*
91      ISYIJKL = MULD2H(ISYIJKD0,ISYLAM0)
92      IF (LRELAX) THEN
93          ISYIJKL = MULD2H(ISYIJKD0,ISYLAM1)
94          IF (ISYIJKL .NE. MULD2H(ISYIJKD1,ISYLAM0))
95     &       CALL QUIT('Symmetry mismatch in CC_INT4O (i)')
96          IF (ISYIJKL.NE.ISYJILK)
97     &       CALL QUIT('Symmetry mismatch in CC_INT4O (ii)')
98      END IF
99*     ------------------------------------------------------
100*     Work space allocation for intermediate ijkl output
101*     ------------------------------------------------------
102
103      KXIJKL = 1
104      KEND1  = KXIJKL + N3ORHF(ISYIJKL)
105      LWRK1  = LWORK - KEND1
106*
107      CALL DZERO(WORK(KXIJKL),N3ORHF(ISYIJKL))
108*
109      IF (LSKIP4O) THEN
110         WRITE (LUPRI,*)
111     &        ' CC_E21CON> I am skipping the g_ijkl integrals..'
112         GO TO 200
113      END IF
114*     ------------------------------------------------------
115*     Loop over symmetry of delta
116*     ------------------------------------------------------
117      KXIJK0 = 1
118      DO 100 ISYMD = 1, NSYM
119
120         IF (NBAS(ISYMD) .EQ. 0) GOTO 100
121
122         ISYML0  = MULD2H(ISYLAM0,ISYMD)
123         IF (LRELAX) THEN
124            ISYML1 = MULD2H(ISYLAM1,ISYMD)
125         END IF
126
127         ISYIJK1 = MULD2H(ISYIJKD1,ISYMD)
128         ISYIJK0 = MULD2H(ISYIJKD0,ISYMD)
129         LENIJK0 = NMAIJK(ISYIJK0)*NBAS(ISYMD)
130C---------------------------------------------------------------------
131C        Work space allocation for derivative/relaxed
132C        3occ integral distribution (if LRELAX) to be read from file.
133C---------------------------------------------------------------------
134         IF (LRELAX) THEN
135            KXIJK1 = KEND1
136            KEND1  = KXIJK1 + NMAIJK(ISYIJK1)*NBAS(ISYMD)
137         ELSE
138            KXIJK1 = KEND1
139         END IF
140         LWRK1  = LWORK - KEND1
141C--------------------------------------------------------------------
142C        Read all integrals (ij|kdel)(1) from disc for given ISYMD.
143C--------------------------------------------------------------------
144         IF (LRELAX) THEN
145            NTOT = NMAIJK(ISYIJK1)*NBAS(ISYMD)
146            IOFF = N3ODMX*(ITRAN-1) + I3ODEL(ISYIJK1,ISYMD) + 1
147            CALL GETWA2(LUIJKD1,FNIJKD1,WORK(KXIJK1),IOFF,NTOT)
148         END IF
149C---------------------------------------------------------------
150C        Transform AO integral index delta to occupied space
151C        thru a call to CC_INT4O --> return result in   XIJKL
152C--------------------------------------------------------------
153         IF (LOCDBG) THEN
154           XNORM = DNRM2(LENIJK0,XIJKD0(KXIJK0),1)
155           WRITE (LUPRI,*)
156     &        'CC_E21CON>For ISYMD:',ISYMD,' Norm IJK0:',XNORM
157         END IF
158C
159         IF (LRELAX) THEN
160            IOPT = 2
161         ELSE
162            IOPT = 1
163         END IF
164         CALL CC_INT4O(XIJKD0(KXIJK0),ISYIJK0,WORK(KXIJK1),ISYIJK1,
165     &                 XLAMDA0,ISYLAM0,XLAMDA1,ISYLAM1, ISYMD,
166     &                 WORK(KXIJKL),LRELAX,WORK(KEND1),LWRK1,IOPT)
167
168         KXIJK0 = KXIJK0 + LENIJK0
169
170 100  CONTINUE
171 200  CONTINUE
172
173      IF (LOCDBG) THEN
174         XNORM = DNRM2(N3ORHF(ISYIJKL),WORK(KXIJKL),1)
175         WRITE (LUPRI,*) 'CC_E21CON> Norm I_ijkl before sorting: ',XNORM
176      END IF
177
178*-----------------------------------------------------
179*     Resort result integrals IJKL to M intermediate ordering
180*     JILK --> added to GAMMAQ intermediate (IOPT = 2)
181*--------------------------------------------------------
182      IOPT = 2
183      CALL CC_SORT4O(WORK(KXIJKL),ISYIJKL,XJILK,IOPT)
184      IF (LOCDBG) THEN
185        CALL AROUND('The IJKL integrals (+M) resorted JIL,K')
186        XNORM = DNRM2(N3ORHF(ISYIJKL),XJILK,1)
187        WRITE (LUPRI,*) 'Norm: ',  XNORM
188      END IF
189
190*----------------------------------
191*     Close the file.
192*----------------------------------
193
194      RETURN
195      END
196*=====================================================================*
197