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_sort4o */
21      SUBROUTINE CC_SORT4O(XKJIL,ISYM4O,XJKLI,IOPT)
22*---------------------------------------------------------------------*
23*     Purpose: resort I(kj,i;l) to I(jk,l;i)
24*
25*     IOPT = 1 : XJKLI area is initialized here
26*     IOPT = 2 : XJKLI is added to gamma intermediate
27*                       already stored as I(jk,l;i)
28*
29*     Sonia Coriani, 14/09-1999
30*---------------------------------------------------------------------*
31#if defined (IMPLICIT_NONE)
32      IMPLICIT NONE
33#else
34#  include "implicit.h"
35#endif
36#include "ccorb.h"
37#include "maxorb.h"
38#include "ccsdsym.h"
39      INTEGER ISYM4O, IOPT
40#if defined (SYS_CRAY)
41      REAL XKJIL(*), XJKLI(*)
42      REAL ZERO, ONE, HALF, DDOT, XNORM, FAC
43#else
44      DOUBLE PRECISION XKJIL(*), XJKLI(*)
45      DOUBLE PRECISION ZERO, ONE, HALF, DDOT, XNORM, FAC
46#endif
47      PARAMETER(ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0)
48*
49      INTEGER ISYML, ISYKJI, ISYMI, ISYMKJ, ISYJKL, ISYMJK
50      INTEGER ISYMK, ISYMJ,  KJIL,  JKLI
51*
52*     --------------------------------------
53*     Initialize result area with zero's or add to previous
54*     --------------------------------------
55      IF (IOPT.EQ.1) THEN
56        FAC = ZERO
57      ELSE
58        FAC = ONE
59      END IF
60*     --------------------------------------
61*     Reorder thru loops on all 4 indices
62*     --------------------------------------
63      DO ISYML = 1,NSYM
64         ISYKJI = MULD2H(ISYM4O,ISYML)
65         DO L = 1, NRHF(ISYML)
66            DO ISYMI = 1, NSYM
67               ISYMKJ = MULD2H(ISYKJI,ISYMI)
68               ISYJKL = MULD2H(ISYM4O,ISYMI)
69               ISYMJK = MULD2H(ISYJKL,ISYML)
70               DO I = 1, NRHF(ISYMI)
71                  DO ISYMK = 1, NSYM
72                     ISYMJ = MULD2H(ISYMJK,ISYMK)
73                     DO K = 1, NRHF(ISYMK)
74                     DO J = 1, NRHF(ISYMJ)
75
76                KJIL = I3ORHF(ISYKJI,ISYML) + NMAIJK(ISYKJI)*(L-1)+
77     &                 IMAIJK(ISYMKJ,ISYMI) + NMATIJ(ISYMKJ)*(I-1)+
78     &                 IMATIJ(ISYMK,ISYMJ)  + NRHF(ISYMK)*(J-1) + K
79
80                JKLI = I3ORHF(ISYJKL,ISYMI) + NMAIJK(ISYJKL)*(I-1)+
81     &                 IMAIJK(ISYMJK,ISYML) + NMATIJ(ISYMJK)*(L-1)+
82     &                 IMATIJ(ISYMJ,ISYMK)  + NRHF(ISYMJ)*(K-1) + J
83
84               XJKLI(JKLI) = FAC*XJKLI(JKLI) + XKJIL(KJIL)
85
86                     END DO         !J
87                     END DO         !K
88                  END DO            !ISYMK
89               END DO               !I
90            END DO                  !ISYMI
91         END DO                     !L
92      END DO                        !ISYML
93*     ---------------------------------------
94*     Finished, return
95*     ---------------------------------------
96      RETURN
97      END
98*=====================================================================*
99C
100*=====================================================================*
101C  /* Deck cc_sort4o2 */
102      SUBROUTINE CC_SORT4O2(XMINT,ISYM4O,XGAMSQ,IOPT,LINV)
103*---------------------------------------------------------------------*
104*     Purpose: resort I(kj,i;l) to I(jl;ki)
105*
106*     based on CC_SORT4O
107*
108*     IOPT = 1 : Initialize result with zero
109*
110*     LINV =.T.: Do inverse operation
111*
112*     Christian Neiss, 20/10-2005
113*---------------------------------------------------------------------*
114#if defined (IMPLICIT_NONE)
115      IMPLICIT NONE
116#else
117#  include "implicit.h"
118#endif
119#include "ccorb.h"
120#include "maxorb.h"
121#include "ccsdsym.h"
122      LOGICAL LINV
123      INTEGER ISYM4O, IOPT
124#if defined (SYS_CRAY)
125      REAL XMINT(*), XGAMSQ(*)
126      REAL ZERO, ONE, HALF, DDOT, XNORM, FAC
127#else
128      DOUBLE PRECISION XMINT(*), XGAMSQ(*)
129      DOUBLE PRECISION ZERO, ONE, HALF, DDOT, XNORM, FAC
130#endif
131      PARAMETER(ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0)
132*
133      INTEGER ISYML, ISYKJI, ISYMI, ISYMKJ, ISYJKL, ISYMJK
134      INTEGER ISYMK, ISYMJ,  KJIL,  JLKI, IDXKI, ISYMJL, ISYMKI
135*
136*     --------------------------------------
137*     Initialize result area with zero's or add to previous
138*     --------------------------------------
139      IF (IOPT.EQ.1) THEN
140        FAC = ZERO
141      ELSE
142        FAC = ONE
143      END IF
144*     --------------------------------------
145*     Reorder thru loops on all 4 indices
146*     --------------------------------------
147      DO ISYML = 1,NSYM
148         ISYKJI = MULD2H(ISYM4O,ISYML)
149         DO L = 1, NRHF(ISYML)
150            DO ISYMI = 1, NSYM
151               ISYMKJ = MULD2H(ISYKJI,ISYMI)
152               ISYJKL = MULD2H(ISYM4O,ISYMI)
153               ISYMJK = MULD2H(ISYJKL,ISYML)
154               IF (ISYMKJ.NE.ISYMJK) CALL QUIT('Error in CC_SORT4O2')
155               DO I = 1, NRHF(ISYMI)
156                  DO ISYMK = 1, NSYM
157                     ISYMJ = MULD2H(ISYMJK,ISYMK)
158                     ISYMJL = MULD2H(ISYMJ,ISYML)
159                     ISYMKI = MULD2H(ISYMK,ISYMI)
160                     DO K = 1, NRHF(ISYMK)
161                     DO J = 1, NRHF(ISYMJ)
162
163                KJIL = I3ORHF(ISYKJI,ISYML) + NMAIJK(ISYKJI)*(L-1)+
164     &                 IMAIJK(ISYMKJ,ISYMI) + NMATIJ(ISYMKJ)*(I-1)+
165     &                 IMATIJ(ISYMK,ISYMJ)  + NRHF(ISYMK)*(J-1) + K
166
167                IDXKI = IMATIJ(ISYMK,ISYMI) + NRHF(ISYMK)*(I-1) + K
168
169                JLKI = IGAMSQ(ISYMJL,ISYMKI) +
170     &                 NMATIJ(ISYMJL)*(IDXKI-1) +
171     &                 IMATIJ(ISYMJ,ISYML) + NRHF(ISYMJ)*(L-1) + J
172
173                IF (LINV) THEN
174                  XMINT(KJIL)  = FAC*XMINT(KJIL) + XGAMSQ(JLKI)
175                ELSE
176                  XGAMSQ(JLKI) = FAC*XGAMSQ(JLKI) + XMINT(KJIL)
177                END IF
178
179                     END DO         !J
180                     END DO         !K
181                  END DO            !ISYMK
182               END DO               !I
183            END DO                  !ISYMI
184         END DO                     !L
185      END DO                        !ISYML
186*     ---------------------------------------
187*     Finished, return
188*     ---------------------------------------
189      RETURN
190      END
191*=====================================================================*
192