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_sort4o */ 21 SUBROUTINE CC_SORT4O(XKJIL,ISYM4O,XJKLI,IOPT) 22*---------------------------------------------------------------------* 23* Purpose: resort I(kj,i;l) to I(jk,l;i) 24* 25* IOPT = 1 : XJKLI area is initialized here 26* IOPT = 2 : XJKLI is added to gamma intermediate 27* already stored as I(jk,l;i) 28* 29* Sonia Coriani, 14/09-1999 30*---------------------------------------------------------------------* 31#if defined (IMPLICIT_NONE) 32 IMPLICIT NONE 33#else 34# include "implicit.h" 35#endif 36#include "ccorb.h" 37#include "maxorb.h" 38#include "ccsdsym.h" 39 INTEGER ISYM4O, IOPT 40#if defined (SYS_CRAY) 41 REAL XKJIL(*), XJKLI(*) 42 REAL ZERO, ONE, HALF, DDOT, XNORM, FAC 43#else 44 DOUBLE PRECISION XKJIL(*), XJKLI(*) 45 DOUBLE PRECISION ZERO, ONE, HALF, DDOT, XNORM, FAC 46#endif 47 PARAMETER(ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0) 48* 49 INTEGER ISYML, ISYKJI, ISYMI, ISYMKJ, ISYJKL, ISYMJK 50 INTEGER ISYMK, ISYMJ, KJIL, JKLI 51* 52* -------------------------------------- 53* Initialize result area with zero's or add to previous 54* -------------------------------------- 55 IF (IOPT.EQ.1) THEN 56 FAC = ZERO 57 ELSE 58 FAC = ONE 59 END IF 60* -------------------------------------- 61* Reorder thru loops on all 4 indices 62* -------------------------------------- 63 DO ISYML = 1,NSYM 64 ISYKJI = MULD2H(ISYM4O,ISYML) 65 DO L = 1, NRHF(ISYML) 66 DO ISYMI = 1, NSYM 67 ISYMKJ = MULD2H(ISYKJI,ISYMI) 68 ISYJKL = MULD2H(ISYM4O,ISYMI) 69 ISYMJK = MULD2H(ISYJKL,ISYML) 70 DO I = 1, NRHF(ISYMI) 71 DO ISYMK = 1, NSYM 72 ISYMJ = MULD2H(ISYMJK,ISYMK) 73 DO K = 1, NRHF(ISYMK) 74 DO J = 1, NRHF(ISYMJ) 75 76 KJIL = I3ORHF(ISYKJI,ISYML) + NMAIJK(ISYKJI)*(L-1)+ 77 & IMAIJK(ISYMKJ,ISYMI) + NMATIJ(ISYMKJ)*(I-1)+ 78 & IMATIJ(ISYMK,ISYMJ) + NRHF(ISYMK)*(J-1) + K 79 80 JKLI = I3ORHF(ISYJKL,ISYMI) + NMAIJK(ISYJKL)*(I-1)+ 81 & IMAIJK(ISYMJK,ISYML) + NMATIJ(ISYMJK)*(L-1)+ 82 & IMATIJ(ISYMJ,ISYMK) + NRHF(ISYMJ)*(K-1) + J 83 84 XJKLI(JKLI) = FAC*XJKLI(JKLI) + XKJIL(KJIL) 85 86 END DO !J 87 END DO !K 88 END DO !ISYMK 89 END DO !I 90 END DO !ISYMI 91 END DO !L 92 END DO !ISYML 93* --------------------------------------- 94* Finished, return 95* --------------------------------------- 96 RETURN 97 END 98*=====================================================================* 99C 100*=====================================================================* 101C /* Deck cc_sort4o2 */ 102 SUBROUTINE CC_SORT4O2(XMINT,ISYM4O,XGAMSQ,IOPT,LINV) 103*---------------------------------------------------------------------* 104* Purpose: resort I(kj,i;l) to I(jl;ki) 105* 106* based on CC_SORT4O 107* 108* IOPT = 1 : Initialize result with zero 109* 110* LINV =.T.: Do inverse operation 111* 112* Christian Neiss, 20/10-2005 113*---------------------------------------------------------------------* 114#if defined (IMPLICIT_NONE) 115 IMPLICIT NONE 116#else 117# include "implicit.h" 118#endif 119#include "ccorb.h" 120#include "maxorb.h" 121#include "ccsdsym.h" 122 LOGICAL LINV 123 INTEGER ISYM4O, IOPT 124#if defined (SYS_CRAY) 125 REAL XMINT(*), XGAMSQ(*) 126 REAL ZERO, ONE, HALF, DDOT, XNORM, FAC 127#else 128 DOUBLE PRECISION XMINT(*), XGAMSQ(*) 129 DOUBLE PRECISION ZERO, ONE, HALF, DDOT, XNORM, FAC 130#endif 131 PARAMETER(ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0) 132* 133 INTEGER ISYML, ISYKJI, ISYMI, ISYMKJ, ISYJKL, ISYMJK 134 INTEGER ISYMK, ISYMJ, KJIL, JLKI, IDXKI, ISYMJL, ISYMKI 135* 136* -------------------------------------- 137* Initialize result area with zero's or add to previous 138* -------------------------------------- 139 IF (IOPT.EQ.1) THEN 140 FAC = ZERO 141 ELSE 142 FAC = ONE 143 END IF 144* -------------------------------------- 145* Reorder thru loops on all 4 indices 146* -------------------------------------- 147 DO ISYML = 1,NSYM 148 ISYKJI = MULD2H(ISYM4O,ISYML) 149 DO L = 1, NRHF(ISYML) 150 DO ISYMI = 1, NSYM 151 ISYMKJ = MULD2H(ISYKJI,ISYMI) 152 ISYJKL = MULD2H(ISYM4O,ISYMI) 153 ISYMJK = MULD2H(ISYJKL,ISYML) 154 IF (ISYMKJ.NE.ISYMJK) CALL QUIT('Error in CC_SORT4O2') 155 DO I = 1, NRHF(ISYMI) 156 DO ISYMK = 1, NSYM 157 ISYMJ = MULD2H(ISYMJK,ISYMK) 158 ISYMJL = MULD2H(ISYMJ,ISYML) 159 ISYMKI = MULD2H(ISYMK,ISYMI) 160 DO K = 1, NRHF(ISYMK) 161 DO J = 1, NRHF(ISYMJ) 162 163 KJIL = I3ORHF(ISYKJI,ISYML) + NMAIJK(ISYKJI)*(L-1)+ 164 & IMAIJK(ISYMKJ,ISYMI) + NMATIJ(ISYMKJ)*(I-1)+ 165 & IMATIJ(ISYMK,ISYMJ) + NRHF(ISYMK)*(J-1) + K 166 167 IDXKI = IMATIJ(ISYMK,ISYMI) + NRHF(ISYMK)*(I-1) + K 168 169 JLKI = IGAMSQ(ISYMJL,ISYMKI) + 170 & NMATIJ(ISYMJL)*(IDXKI-1) + 171 & IMATIJ(ISYMJ,ISYML) + NRHF(ISYMJ)*(L-1) + J 172 173 IF (LINV) THEN 174 XMINT(KJIL) = FAC*XMINT(KJIL) + XGAMSQ(JLKI) 175 ELSE 176 XGAMSQ(JLKI) = FAC*XGAMSQ(JLKI) + XMINT(KJIL) 177 END IF 178 179 END DO !J 180 END DO !K 181 END DO !ISYMK 182 END DO !I 183 END DO !ISYMI 184 END DO !L 185 END DO !ISYML 186* --------------------------------------- 187* Finished, return 188* --------------------------------------- 189 RETURN 190 END 191*=====================================================================* 192