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_e22con */
21      SUBROUTINE CC_E22CON(CTR2,ISYCTR,TAMP1,ISYTAM,QGAMMA,ISYGAM,
22     &                     RHO1,ISYRHO,WORK,LWORK)
23
24*---------------------------------------------------------------------*
25*
26*     Purpose:  lead calculation of E2' contribution to FBTA
27*               transformed vector (second part)
28*
29*     Sonia Coriani, 14/09-1999
30*
31*  Transform ZA2_bj,ai to ZA2_kj,ai with TA1_bk
32*  Resort ZA2_kj,ai to ZA2_jki,a
33*  Compute final result sum_jki ZA2_jki,a * Gamma_jki,i
34*---------------------------------------------------------------------*
35#if defined (IMPLICIT_NONE)
36      IMPLICIT NONE
37#else
38#  include "implicit.h"
39#endif
40#include "ccorb.h"
41#include "maxorb.h"
42#include "ccsdsym.h"
43
44      INTEGER ISYCTR,ISYTAM,ISYGAM,ISYRHO,LWORK
45      LOGICAL LRELAX
46
47#if defined (SYS_CRAY)
48      REAL CTR2(*), TAMP1(*), QGAMMA(*), RHO1(*), WORK(LWORK)
49      REAL ZERO, ONE, HALF, DDOT, XNORM
50#else
51      DOUBLE PRECISION CTR2(*),TAMP1(*),QGAMMA(*),RHO1(*),WORK(LWORK)
52      DOUBLE PRECISION ZERO, ONE, HALF, DDOT, XNORM
53#endif
54      PARAMETER(ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0)
55*
56      INTEGER ISYMI, ISYJKM, ISYMA,ISYRES,ISYMAI,ISYZTA
57      INTEGER KOFFZ,KOFFG,KOFFR,KEND1,KZKJAM,KZJKMA
58      INTEGER NVIRA,NTOJKM,LWRK1,IOPT
59*
60* Symmetry checks
61*
62      ISYZTA = MULD2H(ISYCTR,ISYTAM)
63      ISYRES = MULD2H(ISYZTA,ISYGAM)
64      IF (ISYRES.NE.ISYRHO) CALL QUIT('Symmetry mismatch in E2 2nd')
65*
66* allocate room for transformed Zeta's
67*
68      KZKJAM = 1
69      KZJKMA = KZKJAM + N3OVIR(ISYZTA)
70      KEND1  = KZJKMA + N3OVIR(ISYZTA)
71      LWRK1  = LWORK - KEND1
72*
73* transform ZA2_bj,am to ZA2_kj,am with TA1_bk
74*
75      CALL CC_ZKJAM(CTR2,ISYCTR,TAMP1,ISYTAM,WORK(KZKJAM))
76*
77* resort to ZA2_jkm,a
78*
79      IOPT = 1
80      CALL CC_SORTZ2(WORK(KZKJAM),WORK(KZJKMA),ISYZTA,IOPT)
81*
82* contract  sum_{jkm} ZA2_jkm,a GammaQ_jkm,i = rho_ai
83*
84      DO ISYMI = 1, NSYM
85         ISYJKM = MULD2H(ISYGAM,ISYMI)
86         ISYMA  = MULD2H(ISYJKM,ISYZTA)
87* check
88         ISYMAI = MULD2H(ISYMA,ISYMI)
89         IF (ISYMAI.NE.ISYRHO)
90     *        CALL QUIT('Symmetry mismatch 2 in E2 2nd')
91
92         KOFFZ  = I3OVIR(ISYJKM,ISYMA) + KZJKMA
93         KOFFG  = I3ORHF(ISYJKM,ISYMI) + 1
94         KOFFR  = IT1AM(ISYMA,ISYMI)   + 1
95
96         NVIRA   = MAX(NVIR(ISYMA),1)
97         NTOJKM  = MAX(NMAIJK(ISYJKM),1)
98
99         CALL DGEMM('T','N',NVIR(ISYMA),NRHF(ISYMI),NMAIJK(ISYJKM),
100     &              ONE,WORK(KOFFZ),NTOJKM,QGAMMA(KOFFG),NTOJKM,
101     &              ONE,RHO1(KOFFR),NVIRA)
102
103      END DO
104
105      RETURN
106      END
107*=====================================================================*
108