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_int4o */ 21 SUBROUTINE CC_INT4O(XIJK0,ISYIJK0,XIJK1,ISYIJK1, 22 & XLAMDA0,ISYLAM0, 23 & XLAMDA1,ISYLAM1, ISYMD, 24 & XIJKL,LRELAX,WORK,LWORK,IOPT) 25*---------------------------------------------------------------------* 26* 27* Purpose: transform the del index of (jk|ldel) to occupied L. 28* 29* IOPT = 1 --> XIJKdel0 * XLAMDA0 (LRELAX = .FALSE.) 30* IOPT = 2 --> XIJKdel0 * XLAMDA1 + XIJKdel1 * XLAMDA0 31* XIJKL assumed initialized OUTSIDE 32* 33* Sonia Coriani, 10/09-1999 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 ISYIJK0,ISYIJK1,ISYLAM0,ISYLAM1,IOPT, ISYMD,LWORK 45 LOGICAL LRELAX 46 47#if defined (SYS_CRAY) 48 REAL XIJK0(*), XIJK1(*), XIJKL(*) 49 REAL XLAMDA0(*), XLAMDA1(*), WORK(LWORK) 50 REAL ZERO, ONE, HALF, DDOT, XNORM 51#else 52 DOUBLE PRECISION XIJK0(*), XIJK1(*), XIJKL(*) 53 DOUBLE PRECISION XLAMDA0(*), XLAMDA1(*), WORK(LWORK) 54 DOUBLE PRECISION ZERO, ONE, HALF, DDOT, XNORM 55#endif 56 PARAMETER(ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0) 57 INTEGER KOFF1, KOFF2, KOFF3 58 INTEGER ISYIJKL, ISYML, NBASD, NTOIJK 59 INTEGER ISYIJKDE 60* 61* -------------------------------------- 62* Begin: symmetry of result IJKL integrals 63* -------------------------------------- 64* 65 IF (IOPT.EQ.1) THEN 66 ISYIJKDE = MULD2H(ISYIJK0,ISYMD) 67 ISYIJKL = MULD2H(ISYIJKDE,ISYLAM0) 68 ELSE 69 ISYIJKDE = MULD2H(ISYIJK1,ISYMD) 70 ISYIJKL = MULD2H(ISYIJKDE,ISYLAM0) 71 IF (ISYIJKL .NE. MULD2H(ISYLAM1,MULD2H(ISYIJK0,ISYMD))) 72 & CALL QUIT('Symmetry mismatch in CC_INT4O' ) 73 END IF 74* 75* -------------------------------------------------------* 76* Transform AO integral index to occupied space. (L) 77* -------------------------------------------------------* 78* 79 IF (IOPT.EQ.1) THEN 80 ISYML = MULD2H(ISYLAM0,ISYMD) 81 KOFF1 = 1 82 KOFF2 = IGLMRH(ISYMD,ISYML) + 1 83 KOFF3 = I3ORHF(ISYIJK0,ISYMD) + 1 84 85 NBASD = MAX(NBAS(ISYMD),1) 86 NTOIJK = MAX(NMAIJK(ISYIJK0),1) 87 88 CALL DGEMM('N','N',NMAIJK(ISYIJK0),NRHF(ISYML),NBAS(ISYMD), 89 & ONE,XIJK0(KOFF1),NTOIJK,XLAMDA0(KOFF2),NBASD, 90 & ONE,XIJKL(KOFF3),NTOIJK) 91 ELSE 92 93 ISYML = MULD2H(ISYLAM0,ISYMD) 94 KOFF1 = 1 95 KOFF2 = IGLMRH(ISYMD,ISYML) + 1 96 KOFF3 = I3ORHF(ISYIJK1,ISYML) + 1 97 NTOIJK = MAX(NMAIJK(ISYIJK1),1) 98 NBASD = MAX(NBAS(ISYMD),1) 99 100 CALL DGEMM('N','N',NMAIJK(ISYIJK1),NRHF(ISYML),NBAS(ISYMD), 101 & ONE,XIJK1(KOFF1),NTOIJK,XLAMDA0(KOFF2),NBASD, 102 & ONE,XIJKL(KOFF3),NTOIJK) 103c 104 ISYML = MULD2H(ISYLAM1,ISYMD) 105 KOFF1 = 1 106 KOFF2 = IGLMRH(ISYMD,ISYML) + 1 107 KOFF3 = I3ORHF(ISYIJK0,ISYML) + 1 108 NTOIJK = MAX(NMAIJK(ISYIJK0),1) 109 NBASD = MAX(NBAS(ISYMD),1) 110 111 CALL DGEMM('N','N',NMAIJK(ISYIJK0),NRHF(ISYML),NBAS(ISYMD), 112 & ONE,XIJK0(KOFF1),NTOIJK,XLAMDA1(KOFF2),NBASD, 113 & ONE,XIJKL(KOFF3),NTOIJK) 114 115 END IF 116 RETURN 117 END 118*=====================================================================* 119