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_bfbsort1 */
21      SUBROUTINE CC_BFBSORT1(DSRHF,BSRHF,ISYRHF,LSQRAB)
22*---------------------------------------------------------------------*
23*
24*     Purpose: presort DSRHF integral array for the BF intermediate
25*              calculation in the B matrix transformation
26*
27*     DSRHF  : (alp bet|k delta) integrals for a fixed delta
28*     BSRHF  : integrals sorted as I(alp k;bet)^del
29*     ISYRHF : symmetry of the integral arrays DSRHF,BSRHF
30*
31*     Written by Christof Haettig July/October 1998
32*     Updated by Sonia Coriani November 1999 to handle full (a b|
33*---------------------------------------------------------------------*
34
35      use dyn_iadrpk
36
37#if defined (IMPLICIT_NONE)
38      IMPLICIT NONE
39#else
40#  include "implicit.h"
41#endif
42#include "ccorb.h"
43#include "maxorb.h"
44#include "ccsdsym.h"
45#include "symsq.h"
46
47      LOGICAL LSQRAB
48      INTEGER ISYRHF, ISYM, ISYMAK, ISYBET, ISYMK, ISYMAB, ISYALP
49      INTEGER ICOUNT, NBSRHF(8), IBSRHF(8,8)
50      INTEGER NABK, NAKB, NAK, KOFF1, IJSQ
51
52#if defined (SYS_CRAY)
53      REAL DSRHF(*), BSRHF(*)
54#else
55      DOUBLE PRECISION DSRHF(*), BSRHF(*)
56#endif
57C
58C     --------------------------------------
59C     precalculate symmetry array for BSRHF:
60C     --------------------------------------
61C
62      DO ISYM = 1, NSYM
63        ICOUNT = 0
64        DO ISYMAK = 1, NSYM
65           ISYBET = MULD2H(ISYMAK,ISYM)
66           IBSRHF(ISYMAK,ISYBET) = ICOUNT
67           ICOUNT = ICOUNT + NT1AO(ISYMAK)*NBAS(ISYBET)
68        END DO
69        NBSRHF(ISYM) = ICOUNT
70      END DO
71C
72C     -------------------
73C     sort the integrals:
74C     -------------------
75C
76      DO ISYMAK = 1, NSYM
77      DO ISYMK  = 1, NSYM
78C
79         ISYBET = MULD2H(ISYMAK,ISYRHF)
80         ISYALP = MULD2H(ISYMK,ISYMAK)
81         ISYMAB = MULD2H(ISYALP,ISYBET)
82C
83C        --------------------------------------------------------
84C        get (alp k;bet) blocks out of (alp bet|k del) integrals:
85C        --------------------------------------------------------
86C
87         DO K = 1, NRHF(ISYMK)
88C
89            IF (LSQRAB) THEN
90              KOFF1  = IDSRHFSQ(ISYMAB,ISYMK) + N2BST(ISYMAB)*(K-1)
91            ELSE
92              KOFF1  = IDSRHF(ISYMAB,ISYMK) + NNBST(ISYMAB)*(K-1)
93            END IF
94C
95            DO A = 1, NBAS(ISYALP)
96            DO B = 1, NBAS(ISYBET)
97C
98               IJSQ = IAODIS(ISYALP,ISYBET) + NBAS(ISYALP)*(B-1) + A
99               IF (LSQRAB) THEN
100                 NABK = KOFF1  + IJSQ                        !not quite sure
101               ELSE
102                 NABK = KOFF1  + IADRPK( I2BST(ISYMAB) + IJSQ )
103               END IF
104               NAK  = IT1AO(ISYALP,ISYMK)   + NBAS(ISYALP)*(K-1) + A
105               NAKB = IBSRHF(ISYMAK,ISYBET) +NT1AO(ISYMAK)*(B-1) + NAK
106C
107               BSRHF(NAKB) = DSRHF(NABK)
108C
109            END DO
110            END DO
111C
112         END DO
113C
114      END DO
115      END DO
116C
117      RETURN
118      END
119*=====================================================================*
120