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*=====================================================================* 20 SUBROUTINE CC_E1AIM(E1AMAT,RAIM,RBIM,FOCK, 21 * XLAMDHA,ISYMLA,XLAMDHB,ISYMLB, 22 * FCKCON,RTRAN,LRELAX,IOPT,ISYE1A) 23*---------------------------------------------------------------------* 24* 25* Transforms delta index of R intermediates to virtual and 26* calculate the E1A intermediates in the MO basis 27* 28* IOPT = 1: EMAT1 = FOCK - XLAMDHA * RAIM 29* 30* RBIM,XLAMDHB,ISYMB is dummy input 31* 32* IOPT = 2: EMAT1 = FOCK - XLAMDHA * RBIM - XLAMDHB * RAIM 33* 34* RTRAN = FALSE : skip R intermediate contributions 35* FCKCON = FALSE : skip FOCK matrix contribution 36* LRELAX = FALSE : skip contributions form XLAMDHB/XLAMDPB 37* 38* Symmetries: ISYE1A -- E1AMAT, FOCK(MO), ONEHAM(MO) 39* ISYMLA -- XLAMDHA 40* ISYMLB -- XLAMDHB 41* 42* Based on Christof's CC_EIM 43* Sonia Coriani 06/09-1999 44* 45*---------------------------------------------------------------------* 46#include "implicit.h" 47 PARAMETER(ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) 48 DIMENSION E1AMAT(*),FOCK(*) 49 DIMENSION RAIM(*),RBIM(*) 50 DIMENSION XLAMDHA(*),XLAMDHB(*) 51#include "priunit.h" 52#include "ccorb.h" 53#include "ccsdsym.h" 54#include "ccsdinp.h" 55C 56 LOGICAL LOCDBG 57 PARAMETER (LOCDBG = .FALSE.) 58C 59 LOGICAL FCKCON, RTRAN, LRELAX 60 INTEGER IOPT 61C 62 ISYRAIM = MULD2H(ISYMLA,ISYE1A) 63 ISYRBIM = 0 64 IF (IOPT.EQ.2) THEN 65 ISYRAIM = MULD2H(ISYMLB,ISYE1A) 66 ISYRBIM = MULD2H(ISYMLA,ISYE1A) 67 END IF 68C 69C--------------------------------------------------------- 70C Transform the delta index of R intermediate(s) to c. 71C store result in E1AMAT (R_bc) 72C--------------------------------------------------------- 73C 74 CALL DZERO(E1AMAT,NMATAB(ISYE1A)) 75 76 IF ( RTRAN ) THEN 77C 78 IF (LOCDBG) THEN 79 WRITE (LUPRI,*) 'CC_E1AIM> norm^2 of RAIM:', 80 & DDOT(NEMAT1(ISYRAIM),RAIM,1,RAIM,1) 81 IF (IOPT.EQ.2) 82 & WRITE (LUPRI,*) 'CC_E1AIM> norm^2 of RBIM:', 83 & DDOT(NEMAT1(ISYRBIM),RBIM,1,RBIM,1) 84 CALL FLSHFO(LUPRI) 85 END IF 86C 87 DO ISYMD = 1,NSYM 88C 89 ISYMC = MULD2H(ISYMD,ISYMLA) 90 ISYMB = MULD2H(ISYMC,ISYE1A) 91C 92 NVIRB = MAX(NVIR(ISYMB),1) 93 NBASD = MAX(NBAS(ISYMD),1) 94C 95 KOFF1 = IEMAT1(ISYMB,ISYMD) + 1 96 KOFF2 = IGLMVI(ISYMD,ISYMC) + 1 97 KOFF3 = IMATAB(ISYMB,ISYMC) + 1 98C 99 IF ( IOPT .EQ. 1) THEN 100 101 CALL DGEMM('N','N',NVIR(ISYMB),NVIR(ISYMC),NBAS(ISYMD), 102 * -ONE,RAIM(KOFF1),NVIRB,XLAMDHA(KOFF2),NBASD, 103 * ONE,E1AMAT(KOFF3),NVIRB) 104 105 ELSE 106 107 CALL DGEMM('N','N',NVIR(ISYMB),NVIR(ISYMC),NBAS(ISYMD), 108 * -ONE,RBIM(KOFF1),NVIRB,XLAMDHA(KOFF2),NBASD, 109 * ONE,E1AMAT(KOFF3),NVIRB) 110 111 IF (LRELAX) THEN 112 113 ISYMC = MULD2H(ISYMD,ISYMLB) 114 ISYMB = MULD2H(ISYMC,ISYE1A) 115 116 NVIRB = MAX(NVIR(ISYMB),1) 117 NBASD = MAX(NBAS(ISYMD),1) 118C 119 KOFF1 = IEMAT1(ISYMB,ISYMD) + 1 120 KOFF2 = IGLMVI(ISYMD,ISYMC) + 1 121 KOFF3 = IMATAB(ISYMB,ISYMC) + 1 122C 123 CALL DGEMM('N','N',NVIR(ISYMB),NVIR(ISYMC),NBAS(ISYMD), 124 * -ONE,RAIM(KOFF1),NVIRB,XLAMDHB(KOFF2),NBASD, 125 * ONE,E1AMAT(KOFF3),NVIRB) 126 END IF 127 128 END IF 129C 130 END DO 131C 132 ELSE 133C 134 CALL DZERO(E1AMAT,NMATAB(ISYE1A)) 135C 136 END IF 137C 138C--------------------------------------------------------- 139C Add the Fock matrix contribution: 140C--------------------------------------------------------- 141C 142 IF (FCKCON) THEN 143 144 DO ISYMC = 1,NSYM 145 146 ISYMB = MULD2H(ISYMC,ISYE1A) 147 148 DO C = 1,NVIR(ISYMC) 149 150 KOFF1 = IFCVIR(ISYMB,ISYMC) + NORB(ISYMB)*(C - 1) 151 * + NRHF(ISYMB) + 1 152 KOFF2 = IMATAB(ISYMB,ISYMC) + NVIR(ISYMB)*(C - 1) + 1 153 154 CALL DAXPY(NVIR(ISYMB),ONE,FOCK(KOFF1),1,E1AMAT(KOFF2),1) 155 156 END DO 157 END DO 158 159 ENDIF 160 161 RETURN 162 END 163*=====================================================================* 164