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
19C=================================================================*
20C  /* Deck cc_lamtr */
21      SUBROUTINE CC_LAMTRA(XLAMDP,ISYMLP,XLAMDPR,ISYMLPR,
22     *                     XLAMDH,ISYMLH,XLAMDHR,ISYMLHR,
23     *                     R1AM,ISYMR1)
24C=================================================================*
25C
26C     PURPOSE:
27C             transform general symmetry lambda matrices
28C             with a general symmetry R(c j) vector (R1AM)
29C             occupied in XLAMDP transformed to virtual
30C             virtual in XLAMDH transformed to occupied
31C
32C     Sonia Coriani 25-11-1998
33C     Based on Ove's CCLR_LAMTRA
34C     Debugged 9.8.99
35C
36C     XLAMDP XLAMDH   = Lambda^p(alp,k) and Lambda^h(alp,c)
37C     XLAMDPR XLAMDHR = Lambda^{R,p}(alp,c) and Lambda^{R,h}(alp,k)
38C                       transformed
39C==================================================================*
40#include "implicit.h"
41#include "iratdef.h"
42      PARAMETER(ZERO = 0.0D0, ONE = 1.0D0, XMONE= -1.0D00)
43      DIMENSION R1AM(*),XLAMDP(*),XLAMDH(*),XLAMDPR(*),XLAMDHR(*)
44#include "ccorb.h"
45#include "ccsdsym.h"
46#include "ccsdinp.h"
47C
48      IF (IPRINT .GT.25) THEN
49         CALL AROUND('IN CC_LAMTR  ')
50      ENDIF
51      IF (MULD2H(ISYMLH,ISYMR1).NE.ISYMLHR) THEN
52         CALL QUIT('Symmetry mismatch for ISYMLHR in CC_LAMTRA.')
53      END IF
54      IF (MULD2H(ISYMLP,ISYMR1).NE.ISYMLPR) THEN
55         CALL QUIT('Symmetry mismatch for ISYMLPR in CC_LAMTRA.')
56      END IF
57C
58C-----------------------------------------
59C     Transform general lambda particle matrix.
60C     LaP~(al,a) = -sum(k)[ LaH(al,k)*R(a,k)]
61C NB!! note the minus sign.
62C Note that transformed LambdaP is always (alpha,VIRTUAL)
63C     the (alpha,OCCUPIED) block is = ZERO
64C-----------------------------------------
65C
66      CALL DZERO(XLAMDPR,NGLMDT(ISYMLPR))
67C
68      DO 100 ISYMA = 1,NSYM
69C
70         ISYMK  = MULD2H(ISYMR1,ISYMA)
71         ISYALF = MULD2H(ISYMK,ISYMLP)
72C
73         NBASALF = MAX(NBAS(ISYALF),1)
74         NBASA   = MAX(NVIR(ISYMA),1)
75C
76         KOFF1  = IGLMRH(ISYALF,ISYMK) + 1
77         KOFF2  = IT1AM(ISYMA,ISYMK)   + 1
78         KOFF3  = IGLMVI(ISYALF,ISYMA) + 1
79C
80         CALL DGEMM('N','T',NBAS(ISYALF),NVIR(ISYMA),NRHF(ISYMK),
81     *              XMONE,XLAMDP(KOFF1),NBASALF,R1AM(KOFF2),NBASA,
82     *              ZERO,XLAMDPR(KOFF3),NBASALF)
83C
84  100 CONTINUE
85C
86C-----------------------------------------
87C     Transform Lambda hole matrix.
88C     LaH~(al,i) = + sum(c)[ LaH(al,c)*C(c,i)]
89C     Note that transformed LambdaH is always (alpha,OCC.)
90C     the (alpha,VIRTUAL) block is = ZERO
91C-----------------------------------------
92C
93      CALL DZERO(XLAMDHR,NGLMDT(ISYMLHR))
94C
95      DO 200 ISYMI = 1,NSYM
96C
97         ISYMC  = MULD2H(ISYMR1,ISYMI)
98         ISYALF = MULD2H(ISYMC,ISYMLH)
99C
100         NBASALF = MAX(NBAS(ISYALF),1)
101         NBASC   = MAX(NVIR(ISYMC),1)
102C
103         KOFF1  = IGLMVI(ISYALF,ISYMC) + 1
104         KOFF2  = IT1AM(ISYMC,ISYMI) + 1
105         KOFF3  = IGLMRH(ISYALF,ISYMI) + 1
106C
107         CALL DGEMM('N','N',NBAS(ISYALF),NRHF(ISYMI),NVIR(ISYMC),
108     *              ONE,XLAMDH(KOFF1),NBASALF,R1AM(KOFF2),NBASC,
109     *              ZERO,XLAMDHR(KOFF3),NBASALF)
110C
111  200 CONTINUE
112C
113      RETURN
114      END
115*=================================================================*
116C  /* Deck cclt_z1a */
117      SUBROUTINE CCLT_Z1A(CTR1,ISYCTR,TA1,ISYMTA1,ISYMZA,ZAKJ)
118*-----------------------------------------------------------------*
119C
120C     Purpose: To calculate the Zeta1^A intermediate:
121C
122C     ZetaA(k j)  = - sum_c CTR1(c j) t^A(c k)
123C
124C     or in general
125C
126C     Result(k j) = - sum_c Left(c j) Right(c k)
127C
128C     Sonia Coriani, November 1998
129C     Debug 16.08.1999 OK
130*-----------------------------------------------------------------*
131#include "implicit.h"
132#include "ccorb.h"
133#include "ccsdsym.h"
134#include "cclr.h"
135C
136      PARAMETER(ZERO = 0.0D0, ONE = 1.0D0)
137      DIMENSION CTR1(*),TA1(*),ZAKJ(*)
138
139
140      ISYMCJ = ISYCTR           ! symmetry of Left vector
141      ISYMCK = ISYMTA1          ! symmetry of Right vector
142      ISYRES = MULD2H(ISYCTR,ISYMTA1)
143c      IF (ISYRES.NE.ISYMZA)
144
145      DO ISYMK = 1, NSYM
146         ISYMC = MULD2H(ISYMK,ISYMCK)
147         ISYMJ = MULD2H(ISYMC,ISYMCJ)
148
149         KOFF1 = 1 + IT1AM(ISYMC,ISYMK)    ! for right vector
150         KOFF2 = 1 + IT1AM(ISYMC,ISYMJ)    ! for left vector
151         KOFF3 = 1 + IMATIJ(ISYMK,ISYMJ)   ! for result (occ,occ)
152
153         NRHFK = MAX(NRHF(ISYMK),1)        ! total # occupied K
154         NVIRC = MAX(NVIR(ISYMC),1)        ! total # virtual C
155
156         CALL DGEMM('T','N',NRHF(ISYMK),NRHF(ISYMJ),NVIR(ISYMC),
157     *                -ONE,TA1(KOFF1),NVIRC,CTR1(KOFF2),NVIRC,
158     *                ZERO,ZAKJ(KOFF3),NRHFK)
159
160      END DO
161      RETURN
162      END
163C-------------------------------------------------------------------C
164