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  /* Deck cclt_yps1 */
20      SUBROUTINE CCLT_YPS1(CTR1,ISYCTR,YI,ISYMYI,XLAMDH1,
21     &                     ISYLM1,XLAMDH2,ISYLM2,YPS)
22C
23C     Purpose: To calculate the Ypsilon-type intermediates:
24C
25C     Yps(alpha a)  =   sum_k XLAMDH(alpha k) CTR1(a k)
26C                     + sum_f XLAMDH(alpha f)   YI(f a)
27C
28C     ISYCTR : symmetry of CTR1, YI               (Zeta_1)
29C     ISYLAM : symmetry of XLAMDH
30C
31C     Christof Haettig, October 1998
32C
33C     Generalized for FbTa transformation:
34C
35C     YpsA(alpha a)  =   sum_k XLAMDH1(alpha k) CTR1(a k)
36C                      + sum_f XLAMDH2(alpha f)   YI(f a)
37C     All vectors and matrices can have general symmetry
38C     but the two contributions to YpsA must in total have
39C     the same symmetry.
40C     If ISYYPS is given in input, ISYLM1 and ISYLM2 not needed
41C
42C     Sonia Coriani, February 1999
43C
44#include "implicit.h"
45#include "ccorb.h"
46#include "ccsdsym.h"
47#include "cclr.h"
48C
49      PARAMETER(ZERO = 0.0D0, ONE = 1.0D0)
50      DIMENSION CTR1(*),XLAMDH1(*),XLAMDH2(*),YPS(*),YI(*)
51C
52C---------------------------------------------------
53C     Half-transformation to AO-basis of CTR1 and YI
54C---------------------------------------------------
55C
56      ISYMAO1 = MULD2H(ISYCTR,ISYLM1)
57      ISYMAO2 = MULD2H(ISYMYI,ISYLM2)
58      IF (ISYMAO1.NE.ISYMAO2) CALL QUIT('Symmetry mismatch in CCLT_YPS')
59      ISYYPS  = ISYMAO1
60C
61      CALL DZERO(YPS,NGLMDT(ISYYPS))
62C
63      DO ISYMAL = 1,NSYM                   !alpha
64C
65         ISYMA = MULD2H(ISYMAL,ISYYPS)
66         ISYMK = MULD2H(ISYMA,ISYCTR)
67         ISYMF = MULD2H(ISYMA,ISYMYI)
68C
69         KOFF1 = IGLMRH(ISYMAL,ISYMK) + 1    !offset LambdaH1_al,k
70         KOFF2 = IT1AM(ISYMA,ISYMK)   + 1    !offset Zeta1_ak
71         KOFF3 = IGLMVI(ISYMAL,ISYMA) + 1    !offset Yps_al,a
72C
73         NTOTBA = MAX(NBAS(ISYMAL),1)
74         NTOTVI = MAX(NVIR(ISYMA),1)
75C
76C backtransformation of Zeta1 --> Zeta_al,a
77C
78         CALL DGEMM('N','T',NBAS(ISYMAL),NVIR(ISYMA),NRHF(ISYMK),
79     *               ONE,XLAMDH1(KOFF1),NTOTBA,CTR1(KOFF2),NTOTVI,
80     *               ONE,YPS(KOFF3),NTOTBA)
81C
82         KOFF4 = IMATAB(ISYMF,ISYMA)  + 1    !offset YI_fa
83         KOFF5 = IGLMVI(ISYMAL,ISYMF) + 1    !offset LambdaH2_al,f
84C
85         NTOTVI = MAX(NVIR(ISYMF),1)
86C
87C backtranformation of YI  --> YI_al,a
88C
89         CALL DGEMM('N','N',NBAS(ISYMAL),NVIR(ISYMA),NVIR(ISYMF),
90     *               ONE,XLAMDH2(KOFF5),NTOTBA,YI(KOFF4),NTOTVI,
91     *               ONE,YPS(KOFF3),NTOTBA)
92C
93      END DO
94C
95      RETURN
96      END
97