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 19*=====================================================================* 20C /* Deck cc_e22con */ 21 SUBROUTINE CC_E22CON(CTR2,ISYCTR,TAMP1,ISYTAM,QGAMMA,ISYGAM, 22 & RHO1,ISYRHO,WORK,LWORK) 23 24*---------------------------------------------------------------------* 25* 26* Purpose: lead calculation of E2' contribution to FBTA 27* transformed vector (second part) 28* 29* Sonia Coriani, 14/09-1999 30* 31* Transform ZA2_bj,ai to ZA2_kj,ai with TA1_bk 32* Resort ZA2_kj,ai to ZA2_jki,a 33* Compute final result sum_jki ZA2_jki,a * Gamma_jki,i 34*---------------------------------------------------------------------* 35#if defined (IMPLICIT_NONE) 36 IMPLICIT NONE 37#else 38# include "implicit.h" 39#endif 40#include "ccorb.h" 41#include "maxorb.h" 42#include "ccsdsym.h" 43 44 INTEGER ISYCTR,ISYTAM,ISYGAM,ISYRHO,LWORK 45 LOGICAL LRELAX 46 47#if defined (SYS_CRAY) 48 REAL CTR2(*), TAMP1(*), QGAMMA(*), RHO1(*), WORK(LWORK) 49 REAL ZERO, ONE, HALF, DDOT, XNORM 50#else 51 DOUBLE PRECISION CTR2(*),TAMP1(*),QGAMMA(*),RHO1(*),WORK(LWORK) 52 DOUBLE PRECISION ZERO, ONE, HALF, DDOT, XNORM 53#endif 54 PARAMETER(ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0) 55* 56 INTEGER ISYMI, ISYJKM, ISYMA,ISYRES,ISYMAI,ISYZTA 57 INTEGER KOFFZ,KOFFG,KOFFR,KEND1,KZKJAM,KZJKMA 58 INTEGER NVIRA,NTOJKM,LWRK1,IOPT 59* 60* Symmetry checks 61* 62 ISYZTA = MULD2H(ISYCTR,ISYTAM) 63 ISYRES = MULD2H(ISYZTA,ISYGAM) 64 IF (ISYRES.NE.ISYRHO) CALL QUIT('Symmetry mismatch in E2 2nd') 65* 66* allocate room for transformed Zeta's 67* 68 KZKJAM = 1 69 KZJKMA = KZKJAM + N3OVIR(ISYZTA) 70 KEND1 = KZJKMA + N3OVIR(ISYZTA) 71 LWRK1 = LWORK - KEND1 72* 73* transform ZA2_bj,am to ZA2_kj,am with TA1_bk 74* 75 CALL CC_ZKJAM(CTR2,ISYCTR,TAMP1,ISYTAM,WORK(KZKJAM)) 76* 77* resort to ZA2_jkm,a 78* 79 IOPT = 1 80 CALL CC_SORTZ2(WORK(KZKJAM),WORK(KZJKMA),ISYZTA,IOPT) 81* 82* contract sum_{jkm} ZA2_jkm,a GammaQ_jkm,i = rho_ai 83* 84 DO ISYMI = 1, NSYM 85 ISYJKM = MULD2H(ISYGAM,ISYMI) 86 ISYMA = MULD2H(ISYJKM,ISYZTA) 87* check 88 ISYMAI = MULD2H(ISYMA,ISYMI) 89 IF (ISYMAI.NE.ISYRHO) 90 * CALL QUIT('Symmetry mismatch 2 in E2 2nd') 91 92 KOFFZ = I3OVIR(ISYJKM,ISYMA) + KZJKMA 93 KOFFG = I3ORHF(ISYJKM,ISYMI) + 1 94 KOFFR = IT1AM(ISYMA,ISYMI) + 1 95 96 NVIRA = MAX(NVIR(ISYMA),1) 97 NTOJKM = MAX(NMAIJK(ISYJKM),1) 98 99 CALL DGEMM('T','N',NVIR(ISYMA),NRHF(ISYMI),NMAIJK(ISYJKM), 100 & ONE,WORK(KOFFZ),NTOJKM,QGAMMA(KOFFG),NTOJKM, 101 & ONE,RHO1(KOFFR),NVIRA) 102 103 END DO 104 105 RETURN 106 END 107*=====================================================================* 108