1*=====================================================================*
2      SUBROUTINE LAMMATS(XLAMDP,XLAMDH,T1AM,ISYMT,NOT1AM,LRES,
3     &                   NGLMDS,IGLMRHS,IGLMVIS,ICMO,WORK,LWORK)
4*=====================================================================*
5C
6C     PURPOSE:
7C             Calculate transformation matrices which include
8C             all (i.e. frozen + active) orbitals
9C             When response calculation (lres) then
10C             calculate Lambda bar
11C
12C             NOT1AM - assume T1 amplitudes are zero
13C                      --> just order CMO into Lambda matrices
14C
15C     C. Haettig, spring 2004
16C     added virtual blocks, Christof Haettig, spring 2005
17*----------------------------------------------------------------------*
18       implicit none
19#include "priunit.h"
20#include "dummy.h"
21#include "inftap.h"
22#include "ccorb.h"
23#include "ccsdinp.h"
24#include "ccsdsym.h"
25#include "r12int.h"
26C
27      LOGICAL LOCDBG, LRES, NOT1AM
28      PARAMETER ( LOCDBG = .FALSE. )
29C
30      INTEGER NGLMDS(8), IGLMRHS(8,8), IGLMVIS(8,8),
31     &        LWORK, KCMO, LWRK1, ISYM, ISYMI, ISYMA, ISYMJ, KOFF6,
32     &        ISYMP, ISYMB, NBASP, NVIRB, ISYMT, NVIRA, KOFF4, KOFF5,
33     &        KOFF1, KOFF2, KOFF3, KEND, ICOUNT, ICOUNT2, ISYM1, ISYM2
34      INTEGER NCMO(8), ICMO(8,8)
35#if defined (SYS_CRAY)
36      REAL XLAMDH(*),XLAMDP(*),WORK(*),T1AM(*),ONE,CMO(NLAMDS)
37#else
38      DOUBLE PRECISION  XLAMDH(*),XLAMDP(*),WORK(*),T1AM(*),ONE,
39     &                  CMO(NLAMDS)
40#endif
41      PARAMETER (ONE = 1.0d0)
42C
43C----------------------------------------------
44C     Read MO-coefficients from interface file.
45C----------------------------------------------
46C
47      CALL GPOPEN(LUSIFC,'SIRIFC','OLD',' ','UNFORMATTED',IDUMMY,
48     &            .FALSE.)
49      REWIND LUSIFC
50C
51      CALL MOLLAB(LABEL,LUSIFC,LUPRI)
52      READ (LUSIFC)
53C
54      READ (LUSIFC)
55      READ (LUSIFC) (CMO(I), I=1,NLAMDS)
56C
57      CALL GPCLOSE(LUSIFC,'KEEP')
58
59      IF (LOCDBG) THEN
60        WRITE(LUPRI,*)'CMOS out of LAMMATS:'
61        DO ISYM = 1, NSYM
62          ISYMI = MULD2H(ISYM,ISYMT)
63          CALL OUTPUT(CMO,1,NBAS(ISYM),1,NRHFS(ISYMI),
64     &                NBAS(ISYM),NRHFS(ISYMI),1,LUPRI)
65        END DO
66      END IF
67C
68C---------------------------------------
69C     Reorder the MO-coefficient matrix.
70C---------------------------------------
71C
72      IF (LRES) THEN
73        CALL DZERO(XLAMDH,NGLMDS(ISYMT))
74        CALL DZERO(XLAMDP,NGLMDS(ISYMT))
75      ELSE
76        DO ISYM = 1,NSYM
77         KOFF1  = ICMO(ISYM,ISYM) + 1
78         KOFF2  = IGLMRHS(ISYM,ISYM) + 1
79         CALL DCOPY(NBAS(ISYM)*NRHFS(ISYM),CMO(KOFF1),1,XLAMDH(KOFF2),1)
80
81         KOFF1  = ICMO(ISYM,ISYM) + NBAS(ISYM)*NRHFS(ISYM) + 1
82         KOFF2  = IGLMVIS(ISYM,ISYM) + 1
83         CALL DCOPY(NBAS(ISYM)*NVIRS(ISYM),CMO(KOFF1),1,XLAMDH(KOFF2),1)
84        END DO
85        CALL DCOPY(NGLMDS(1),XLAMDH,1,XLAMDP,1)
86      END IF
87C
88C-------------------------------------------
89C     Calculate the transformation matrices.
90C-------------------------------------------
91C
92      IF (.NOT. NOT1AM) THEN
93       DO ISYMP = 1,NSYM
94
95         ISYMI = MULD2H(ISYMP,ISYMT)
96         ISYMB = MULD2H(ISYMI,ISYMT)
97
98         NBASP = MAX(NBAS(ISYMP),1)
99         NVIRB = MAX(NVIR(ISYMB),1)
100
101         KOFF1 = ICMO(ISYMP,ISYMB) + NBAS(ISYMP)*NRHFS(ISYMB) + 1
102         KOFF2 = IT1AM(ISYMB,ISYMI) + 1
103         KOFF3 = IGLMRHS(ISYMP,ISYMI) + NBAS(ISYMP)*NRHFFR(ISYMI) + 1
104
105         CALL DGEMM('N','N',NBAS(ISYMP),NRHF(ISYMI),NVIR(ISYMB),
106     *              ONE,CMO(KOFF1),NBASP,T1AM(KOFF2),NVIRB,
107     *              ONE,XLAMDH(KOFF3),NBASP)
108
109         ISYMA = MULD2H(ISYMP,ISYMT)
110         ISYMJ = MULD2H(ISYMA,ISYMT)
111
112         NBASP = MAX(NBAS(ISYMP),1)
113         NVIRA = MAX(NVIR(ISYMA),1)
114
115         KOFF4 = ICMO(ISYMP,ISYMJ) + NBAS(ISYMP)*NRHFFR(ISYMJ) + 1
116         KOFF5 = IT1AM(ISYMA,ISYMJ) + 1
117         KOFF6 = IGLMVIS(ISYMP,ISYMA) + 1
118
119         CALL DGEMM('N','T',NBAS(ISYMP),NVIR(ISYMA),NRHF(ISYMJ),
120     *              -ONE,CMO(KOFF4),NBASP,T1AM(KOFF5),NVIRA,
121     *              ONE,XLAMDP(KOFF6),NBASP)
122       END DO
123      END IF
124C
125C-------------------------------------------
126C     Print the matrices:
127C-------------------------------------------
128C
129      IF (LOCDBG) THEN
130C
131         IF (LRES) THEN
132           CALL AROUND('Lambda Particle bar matrix in LAMMATS')
133         ELSE
134           CALL AROUND('Lambda Particle matrix in LAMMATS')
135         END IF
136
137         DO ISYM = 1,NSYM
138            ISYMI = MULD2H(ISYM,ISYMT)
139            WRITE(LUPRI,1) ISYM,ISYMI
140            WRITE(LUPRI,2)
141            WRITE(LUPRI,3)
142            IF (NRHF(ISYM) .EQ. 0) THEN
143               WRITE(LUPRI,4)
144            ELSE
145              KOFF1 = 1 + IGLMRHS(ISYM,ISYMI)
146              CALL OUTPUT(XLAMDP(KOFF1),1,NBAS(ISYM),1,NRHFS(ISYMI),
147     *                    NBAS(ISYM),NRHFS(ISYMI),1,LUPRI)
148            END IF
149         END DO
150C
151         IF (LRES) THEN
152           CALL AROUND('Lambda Hole bar matrix in LAMMATS')
153         ELSE
154           CALL AROUND('Lambda Hole matrix in LAMMATS')
155         END IF
156
157         DO ISYM = 1,NSYM
158            ISYMI = MULD2H(ISYM,ISYMT)
159            WRITE(LUPRI,1) ISYM, ISYMI
160            WRITE(LUPRI,7)
161            WRITE(LUPRI,8)
162            IF (NRHF(ISYM) .EQ. 0) THEN
163               WRITE(LUPRI,4)
164            ELSE
165              KOFF1 = 1 + IGLMRHS(ISYM,ISYMI)
166              CALL OUTPUT(XLAMDH(KOFF1),1,NBAS(ISYM),1,NRHFS(ISYMI),
167     *                    NBAS(ISYM),NRHFS(ISYMI),1,LUPRI)
168            END IF
169          END DO
170C
171      END IF
172C
173      RETURN
174C
175    1 FORMAT(/,/,7X,'Symmetry number :',2I5)
176    2 FORMAT(/,/,7X,'Lambda particle occupied part')
177    3 FORMAT(7X,'-----------------------------')
178    4 FORMAT(/,/,7X,'This symmetry is empty')
179    5 FORMAT(/,/,7X,'Lambda particle virtual part')
180    6 FORMAT(7X,'----------------------------')
181    7 FORMAT(/,/,7X,'Lambda hole occupied part')
182    8 FORMAT(7X,'-------------------------')
183    9 FORMAT(/,/,7X,'Lambda hole virtual part')
184   10 FORMAT(7X,'------------------------')
185C
186      END
187*======================================================================*
188