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*=====================================================================*
20      SUBROUTINE CC_E1AIM(E1AMAT,RAIM,RBIM,FOCK,
21     *                  XLAMDHA,ISYMLA,XLAMDHB,ISYMLB,
22     *                  FCKCON,RTRAN,LRELAX,IOPT,ISYE1A)
23*---------------------------------------------------------------------*
24*
25*     Transforms delta index of R intermediates to virtual and
26*     calculate the E1A intermediates in the MO basis
27*
28*     IOPT = 1:     EMAT1 = FOCK   - XLAMDHA * RAIM
29*
30*                   RBIM,XLAMDHB,ISYMB is dummy input
31*
32*     IOPT = 2:     EMAT1 = FOCK   - XLAMDHA * RBIM - XLAMDHB * RAIM
33*
34*     RTRAN  = FALSE : skip R intermediate contributions
35*     FCKCON = FALSE : skip FOCK matrix contribution
36*     LRELAX = FALSE : skip contributions form XLAMDHB/XLAMDPB
37*
38*     Symmetries:    ISYE1A  --  E1AMAT, FOCK(MO), ONEHAM(MO)
39*                    ISYMLA  --  XLAMDHA
40*                    ISYMLB  --  XLAMDHB
41*
42*     Based on Christof's CC_EIM
43*     Sonia Coriani 06/09-1999
44*
45*---------------------------------------------------------------------*
46#include "implicit.h"
47      PARAMETER(ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
48      DIMENSION E1AMAT(*),FOCK(*)
49      DIMENSION RAIM(*),RBIM(*)
50      DIMENSION XLAMDHA(*),XLAMDHB(*)
51#include "priunit.h"
52#include "ccorb.h"
53#include "ccsdsym.h"
54#include "ccsdinp.h"
55C
56      LOGICAL LOCDBG
57      PARAMETER (LOCDBG = .FALSE.)
58C
59      LOGICAL FCKCON, RTRAN, LRELAX
60      INTEGER IOPT
61C
62      ISYRAIM = MULD2H(ISYMLA,ISYE1A)
63      ISYRBIM = 0
64      IF (IOPT.EQ.2) THEN
65        ISYRAIM = MULD2H(ISYMLB,ISYE1A)
66        ISYRBIM = MULD2H(ISYMLA,ISYE1A)
67      END IF
68C
69C---------------------------------------------------------
70C     Transform the delta index of R intermediate(s) to c.
71C     store result in E1AMAT (R_bc)
72C---------------------------------------------------------
73C
74      CALL DZERO(E1AMAT,NMATAB(ISYE1A))
75
76      IF ( RTRAN ) THEN
77C
78         IF (LOCDBG) THEN
79           WRITE (LUPRI,*) 'CC_E1AIM> norm^2 of RAIM:',
80     &       DDOT(NEMAT1(ISYRAIM),RAIM,1,RAIM,1)
81           IF (IOPT.EQ.2)
82     &       WRITE (LUPRI,*) 'CC_E1AIM> norm^2 of RBIM:',
83     &         DDOT(NEMAT1(ISYRBIM),RBIM,1,RBIM,1)
84           CALL FLSHFO(LUPRI)
85         END IF
86C
87         DO ISYMD = 1,NSYM
88C
89            ISYMC = MULD2H(ISYMD,ISYMLA)
90            ISYMB = MULD2H(ISYMC,ISYE1A)
91C
92            NVIRB = MAX(NVIR(ISYMB),1)
93            NBASD = MAX(NBAS(ISYMD),1)
94C
95            KOFF1 = IEMAT1(ISYMB,ISYMD) + 1
96            KOFF2 = IGLMVI(ISYMD,ISYMC) + 1
97            KOFF3 = IMATAB(ISYMB,ISYMC) + 1
98C
99            IF ( IOPT .EQ. 1) THEN
100
101              CALL DGEMM('N','N',NVIR(ISYMB),NVIR(ISYMC),NBAS(ISYMD),
102     *                   -ONE,RAIM(KOFF1),NVIRB,XLAMDHA(KOFF2),NBASD,
103     *                   ONE,E1AMAT(KOFF3),NVIRB)
104
105            ELSE
106
107              CALL DGEMM('N','N',NVIR(ISYMB),NVIR(ISYMC),NBAS(ISYMD),
108     *                   -ONE,RBIM(KOFF1),NVIRB,XLAMDHA(KOFF2),NBASD,
109     *                   ONE,E1AMAT(KOFF3),NVIRB)
110
111              IF (LRELAX) THEN
112
113                ISYMC = MULD2H(ISYMD,ISYMLB)
114                ISYMB = MULD2H(ISYMC,ISYE1A)
115
116                NVIRB = MAX(NVIR(ISYMB),1)
117                NBASD = MAX(NBAS(ISYMD),1)
118C
119                KOFF1 = IEMAT1(ISYMB,ISYMD) + 1
120                KOFF2 = IGLMVI(ISYMD,ISYMC) + 1
121                KOFF3 = IMATAB(ISYMB,ISYMC) + 1
122C
123                CALL DGEMM('N','N',NVIR(ISYMB),NVIR(ISYMC),NBAS(ISYMD),
124     *                     -ONE,RAIM(KOFF1),NVIRB,XLAMDHB(KOFF2),NBASD,
125     *                     ONE,E1AMAT(KOFF3),NVIRB)
126              END IF
127
128            END IF
129C
130         END DO
131C
132      ELSE
133C
134         CALL DZERO(E1AMAT,NMATAB(ISYE1A))
135C
136      END IF
137C
138C---------------------------------------------------------
139C     Add the Fock matrix contribution:
140C---------------------------------------------------------
141C
142      IF (FCKCON) THEN
143
144         DO ISYMC = 1,NSYM
145
146            ISYMB = MULD2H(ISYMC,ISYE1A)
147
148            DO C = 1,NVIR(ISYMC)
149
150               KOFF1 = IFCVIR(ISYMB,ISYMC) + NORB(ISYMB)*(C - 1)
151     *                                     + NRHF(ISYMB) + 1
152               KOFF2 = IMATAB(ISYMB,ISYMC) + NVIR(ISYMB)*(C - 1) + 1
153
154               CALL DAXPY(NVIR(ISYMB),ONE,FOCK(KOFF1),1,E1AMAT(KOFF2),1)
155
156            END DO
157         END DO
158
159      ENDIF
160
161      RETURN
162      END
163*=====================================================================*
164