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!
18      SUBROUTINE CCSD_ASYMSQ(DISTAB,ISYMAB,SCR,ISYMG,ISYMD)
19C
20C     Antisymmetric Squareup of the integral distribution,
21C     for orbit-orbit Breit-Pauli correction
22C     S. Coriani, April 2003. Based on CCSD_SYMSQO.
23C     Modified for [T1+T2,r12]-Integrals (Elena Vollmer, September 2003)
24#include "implicit.h"
25      DIMENSION DISTAB(*), SCR(*)
26      PARAMETER (ONE = 1.0D0)
27#include "priunit.h"
28#include "ccorb.h"
29#include "ccsdsym.h"
30C
31      CALL QENTER('CCSD_ASYMSQ')
32C
33      IF (ISYMAB .EQ. 1) THEN
34C
35         KOFF1 = 1
36         KOFF2 = 1
37         DO 100 ISYMB = 1,NSYM
38            CALL ASQMATR(NBAS(ISYMB),DISTAB(KOFF1),SCR(KOFF2),ISYMG)
39            KOFF1 = KOFF1 + NBAS(ISYMB)*(NBAS(ISYMB)+1)/2
40            KOFF2 = KOFF2 + NBAS(ISYMB)*NBAS(ISYMB)
41  100    CONTINUE
42C
43      ELSE
44         KOFF1 = 1
45         KOFF2 = 1
46         DO 200 ISYMB = 1,NSYM
47C
48            ISYMA = MULD2H(ISYMB,ISYMAB)
49
50            IF (ISYMB .GT. ISYMA) THEN
51C
52               NTOT  = NBAS(ISYMA)*NBAS(ISYMB)
53C
54               KOFF2 = KOFF1
55               KOFF3 = IAODIS(ISYMB,ISYMA) + 1
56               DO 210 B = 1,NBAS(ISYMB)
57                 IF (ISYMG .EQ. 0) THEN
58                  CALL DCOPY(NBAS(ISYMA),DISTAB(KOFF2),1,SCR(KOFF3),
59     *                       NBAS(ISYMB))
60                 ELSE
61                 CALL DSCAL(NBAS(ISYMA),-ONE,SCR(KOFF3),NBAS(ISYMB))
62                 CALL DAXPY(NBAS(ISYMA),ONE,DISTAB(KOFF2),1,SCR(KOFF3),
63     *                      NBAS(ISYMB))
64                 END IF
65                  KOFF2 = KOFF2 + NBAS(ISYMA)
66                  KOFF3 = KOFF3 + 1
67  210          CONTINUE
68C
69               KOFF4 = IAODIS(ISYMA,ISYMB) + 1
70               IF (ISYMG .EQ. 0) THEN
71                CALL DCOPY(NTOT,DISTAB(KOFF1),1,SCR(KOFF4),1)
72                CALL DSCAL(NTOT,-ONE,SCR(KOFF4),1)
73               ELSE
74                CALL DSCAL(NTOT,-ONE,SCR(KOFF4),1)
75                CALL DAXPY(NTOT,-ONE,DISTAB(KOFF1),1,SCR(KOFF4),1)
76               END IF
77C
78               KOFF1 = KOFF1 + NTOT
79C
80            ENDIF
81C
82  200    CONTINUE
83C
84      ENDIF
85C
86      CALL QEXIT('CCSD_ASYMSQ')
87C
88      RETURN
89      END
90C  /* Deck asqmatr */
91      SUBROUTINE ASQMATR(NDIM,PKMAT,SQMAT,ISYMG)
92C
93C     PURPOSE:
94C      Antisymmetric Square up packed matrix.
95C
96      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
97      DIMENSION PKMAT(*),SQMAT(NDIM,NDIM)
98
99C
100      IF (ISYMG .EQ. 0) THEN
101
102       IJ = 0
103       DO  I = 1,NDIM
104          DO  J = 1,I
105C
106             IJ = IJ + 1
107             SQMAT(I,J) =   PKMAT(IJ)
108             SQMAT(J,I) = - PKMAT(IJ)
109          ENDDO
110       ENDDO
111
112      ELSE
113      IJ = 0
114      DO 100 I = 1,NDIM
115          DO 110 J = 1,I
116           IJ = IJ + 1
117           IF (I.EQ.J) THEN
118             SQMAT(J,I) =  - PKMAT(IJ)  -  SQMAT(J,I)
119           ELSE
120             SQMAT(I,J) =    PKMAT(IJ)  -  SQMAT(I,J)
121             SQMAT(J,I) =  - PKMAT(IJ)  -  SQMAT(J,I)
122           END IF
123  110     CONTINUE
124  100 CONTINUE
125      ENDIF
126
127      RETURN
128      END
129