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