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_e21con */ 21 SUBROUTINE CC_E21CON(XJILK,ISYJILK,XIJKD0,ISYIJKD0, 22 & LUIJKD1,FNIJKD1,ISYIJKD1, 23 & XLAMDA0,ISYLAM0,XLAMDA1,ISYLAM1,LRELAX, 24 & ITRAN, WORK,LWORK) 25*---------------------------------------------------------------------* 26* 27* Purpose: lead calculation of E2' contribution to FBTA 28* transformed vector 29* 30* ISYIJK0 = symmetry of I_{ijk;delta} 31* ISYIJK1 = symmetry of I^(1)_{ijk;delta} 32* 33* Sonia Coriani, 14/09-1999 34* 35* Read derivative/relaxed integrals from file 36* call transformation to 4 occupied 37* resort to BF ordering 38* add to gammaQ(rho^BFQ) 39*---------------------------------------------------------------------* 40#if defined (IMPLICIT_NONE) 41 IMPLICIT NONE 42#else 43# include "implicit.h" 44#endif 45#include "priunit.h" 46#include "ccorb.h" 47#include "maxorb.h" 48#include "ccsdsym.h" 49 50 LOGICAL LOCDBG 51 PARAMETER (LOCDBG = .FALSE.) 52 LOGICAL LSKIP4O 53 PARAMETER (LSKIP4O = .FALSE.) 54 55 INTEGER ISYIJKD0,ISYIJKD1,ISYLAM0,ISYLAM1,ITRAN,LWORK,IOPT 56 INTEGER LUIJKD1, ISYJILK, KOFFIJKL 57 LOGICAL LRELAX 58 CHARACTER*8 FNIJKD1 59 60#if defined (SYS_CRAY) 61 REAL XJILK(*), XIJKD0(*), XLAMDA0(*), XLAMDA1(*) 62 REAL ZERO, ONE, HALF, DNRM2, XNORM, WORK(LWORK) 63#else 64 DOUBLE PRECISION XJILK(*), XIJKD0(*), XLAMDA0(*), XLAMDA1(*) 65 DOUBLE PRECISION ZERO, ONE, HALF, DNRM2, XNORM, WORK(LWORK) 66#endif 67 PARAMETER(ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0) 68* 69 INTEGER ISYMD, ISYIJKL, NTOT, LWRK1, IOFF, N3ODMX,ISYM 70 INTEGER KXIJKL, KEND1, ISYML0, ISYML1 71 INTEGER KXIJK0, ISYIJK0, LENIJK0 72 INTEGER KXIJK1, ISYIJK1 73 74 IF (LOCDBG) THEN 75 WRITE (LUPRI,*) 'I am inside CC_E21CON: LRELAX = ', LRELAX 76 CALL CC_PRLAM(XLAMDA0,XLAMDA0,ISYLAM0) 77 CALL CC_PRLAM(XLAMDA1,XLAMDA1,ISYLAM1) 78 CALL FLSHFO(LUPRI) 79 END IF 80*---------------------------------------------------------------------* 81* precalculate some stuff 82*---------------------------------------------------------------------* 83 N3ODMX = 0 84 DO ISYM = 1, NSYM 85 N3ODMX = MAX(N3ODMX,N3ODEL(ISYM)) 86 END DO 87* -------------------------------------- 88* Begin 89* -------------------------------------- 90* 91 ISYIJKL = MULD2H(ISYIJKD0,ISYLAM0) 92 IF (LRELAX) THEN 93 ISYIJKL = MULD2H(ISYIJKD0,ISYLAM1) 94 IF (ISYIJKL .NE. MULD2H(ISYIJKD1,ISYLAM0)) 95 & CALL QUIT('Symmetry mismatch in CC_INT4O (i)') 96 IF (ISYIJKL.NE.ISYJILK) 97 & CALL QUIT('Symmetry mismatch in CC_INT4O (ii)') 98 END IF 99* ------------------------------------------------------ 100* Work space allocation for intermediate ijkl output 101* ------------------------------------------------------ 102 103 KXIJKL = 1 104 KEND1 = KXIJKL + N3ORHF(ISYIJKL) 105 LWRK1 = LWORK - KEND1 106* 107 CALL DZERO(WORK(KXIJKL),N3ORHF(ISYIJKL)) 108* 109 IF (LSKIP4O) THEN 110 WRITE (LUPRI,*) 111 & ' CC_E21CON> I am skipping the g_ijkl integrals..' 112 GO TO 200 113 END IF 114* ------------------------------------------------------ 115* Loop over symmetry of delta 116* ------------------------------------------------------ 117 KXIJK0 = 1 118 DO 100 ISYMD = 1, NSYM 119 120 IF (NBAS(ISYMD) .EQ. 0) GOTO 100 121 122 ISYML0 = MULD2H(ISYLAM0,ISYMD) 123 IF (LRELAX) THEN 124 ISYML1 = MULD2H(ISYLAM1,ISYMD) 125 END IF 126 127 ISYIJK1 = MULD2H(ISYIJKD1,ISYMD) 128 ISYIJK0 = MULD2H(ISYIJKD0,ISYMD) 129 LENIJK0 = NMAIJK(ISYIJK0)*NBAS(ISYMD) 130C--------------------------------------------------------------------- 131C Work space allocation for derivative/relaxed 132C 3occ integral distribution (if LRELAX) to be read from file. 133C--------------------------------------------------------------------- 134 IF (LRELAX) THEN 135 KXIJK1 = KEND1 136 KEND1 = KXIJK1 + NMAIJK(ISYIJK1)*NBAS(ISYMD) 137 ELSE 138 KXIJK1 = KEND1 139 END IF 140 LWRK1 = LWORK - KEND1 141C-------------------------------------------------------------------- 142C Read all integrals (ij|kdel)(1) from disc for given ISYMD. 143C-------------------------------------------------------------------- 144 IF (LRELAX) THEN 145 NTOT = NMAIJK(ISYIJK1)*NBAS(ISYMD) 146 IOFF = N3ODMX*(ITRAN-1) + I3ODEL(ISYIJK1,ISYMD) + 1 147 CALL GETWA2(LUIJKD1,FNIJKD1,WORK(KXIJK1),IOFF,NTOT) 148 END IF 149C--------------------------------------------------------------- 150C Transform AO integral index delta to occupied space 151C thru a call to CC_INT4O --> return result in XIJKL 152C-------------------------------------------------------------- 153 IF (LOCDBG) THEN 154 XNORM = DNRM2(LENIJK0,XIJKD0(KXIJK0),1) 155 WRITE (LUPRI,*) 156 & 'CC_E21CON>For ISYMD:',ISYMD,' Norm IJK0:',XNORM 157 END IF 158C 159 IF (LRELAX) THEN 160 IOPT = 2 161 ELSE 162 IOPT = 1 163 END IF 164 CALL CC_INT4O(XIJKD0(KXIJK0),ISYIJK0,WORK(KXIJK1),ISYIJK1, 165 & XLAMDA0,ISYLAM0,XLAMDA1,ISYLAM1, ISYMD, 166 & WORK(KXIJKL),LRELAX,WORK(KEND1),LWRK1,IOPT) 167 168 KXIJK0 = KXIJK0 + LENIJK0 169 170 100 CONTINUE 171 200 CONTINUE 172 173 IF (LOCDBG) THEN 174 XNORM = DNRM2(N3ORHF(ISYIJKL),WORK(KXIJKL),1) 175 WRITE (LUPRI,*) 'CC_E21CON> Norm I_ijkl before sorting: ',XNORM 176 END IF 177 178*----------------------------------------------------- 179* Resort result integrals IJKL to M intermediate ordering 180* JILK --> added to GAMMAQ intermediate (IOPT = 2) 181*-------------------------------------------------------- 182 IOPT = 2 183 CALL CC_SORT4O(WORK(KXIJKL),ISYIJKL,XJILK,IOPT) 184 IF (LOCDBG) THEN 185 CALL AROUND('The IJKL integrals (+M) resorted JIL,K') 186 XNORM = DNRM2(N3ORHF(ISYIJKL),XJILK,1) 187 WRITE (LUPRI,*) 'Norm: ', XNORM 188 END IF 189 190*---------------------------------- 191* Close the file. 192*---------------------------------- 193 194 RETURN 195 END 196*=====================================================================* 197