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