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 cctrbt2 */ 21 SUBROUTINE CCTRBT2(XINT,DSRHF,XLAMDP,ISYMLP,WORK,LWORK, 22 & ISYDIS,IOPT,LSQRINT,LSQRUP,SGNINT) 23*---------------------------------------------------------------------* 24* 25* Purpose: Transform gamma index of integral batch 26* I_{al be, gamma}^del to occupied. 27* 28* XLAMDP,ISYMLP = lambda matrix and its symmetry 29* XINT, ISYDIS = I_{al be, gamma} batch and its symmetry 30* Options: 31* if IOPT = 0 overwrite result matrix 32* if IOPT = 1 add to previous 33* LSQRINT = TRUE, (alpha beta|* *) is full matrix (not packed) 34* LSQRUP = TRUE, square up (a b| after transformation of gamma 35* to k 36* SGNINT = sign of integral distribution 37* 38* Written by Sonia Coriani 19-11-99, based on CCTRBT 39* 40*=====================================================================* 41#include "implicit.h" 42 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0) 43* 44 DIMENSION XINT(*),DSRHF(*),XLAMDP(*),WORK(LWORK) 45 LOGICAL LSQRUP,LSQRINT 46* 47#include "ccorb.h" 48#include "ccsdsym.h" 49* 50 IF (IOPT.EQ.0) THEN 51 FAC = ZERO 52 ELSE IF (IOPT.EQ.1) THEN 53 FAC = ONE 54 ELSE 55 CALL QUIT('Unknown option in CCTRBT2') 56 ENDIF 57* 58* memory check when squaring 59* 60 IF (LSQRUP) THEN 61 DO ISYMJ = 1, NSYM 62 ISYMG = MULD2H(ISYMLP,ISYMJ) 63 ISYMAB = MULD2H(ISYMG,ISYDIS) 64 ISYDSRHF = MULD2H(ISYMAB,ISYMJ) 65 IF (LWORK.LT.NDSRHF(ISYDSRHF)) THEN 66 CALL QUIT('Insufficient memory in CCTRBT2') 67 END IF 68 END DO 69 END IF 70* 71* Calculate (al be|j)^del = sum_gam I^del_{al be, gam} Lambda_{gam j} 72* 73 DO ISYMJ = 1,NSYM 74* 75 ISYMG = MULD2H(ISYMLP,ISYMJ) 76 ISYMAB = MULD2H(ISYMG,ISYDIS) 77 NBASG = MAX(NBAS(ISYMG),1) 78 79 KOFF2 = 1 + IGLMRH(ISYMG,ISYMJ) 80 81 IF (LSQRINT) THEN 82 KOFF1 = 1 + IDSAOGSQ(ISYMG,ISYDIS) 83 KOFF3 = 1 + IDSRHFSQ(ISYMAB,ISYMJ) 84 NDIMAB = N2BST(ISYMAB) 85 ELSE 86 KOFF1 = 1 + IDSAOG(ISYMG,ISYDIS) 87 KOFF3 = 1 + IDSRHF(ISYMAB,ISYMJ) 88 NDIMAB = NNBST(ISYMAB) 89 END IF 90 91 NALBEM = MAX(NDIMAB,1) 92 93 IF (LSQRUP) THEN 94 95 CALL DGEMM('N','N',NDIMAB,NRHF(ISYMJ),NBAS(ISYMG), 96 * ONE,XINT(KOFF1),NALBEM,XLAMDP(KOFF2),NBASG, 97 * ZERO,WORK,NALBEM) 98 99 ! Resort (al>=be, k) to (al be| k) 100 ! Put in DSRHF which is dimensioned full (a b| from input 101 DO J = 1, NRHF(ISYMJ) 102 KOFF4 = NNBST(ISYMAB)*(J-1) + 1 103 KOFF5 = IDSRHFSQ(ISYMAB,ISYMJ) + N2BST(ISYMAB)*(J-1) + 1 104 CALL CCSD_SYMSQ(WORK(KOFF4),ISYMAB,DSRHF(KOFF5)) 105 END DO 106 107 ELSE 108 CALL DGEMM('N','N',NDIMAB,NRHF(ISYMJ),NBAS(ISYMG), 109 * SGNINT,XINT(KOFF1),NALBEM,XLAMDP(KOFF2),NBASG, 110 * FAC,DSRHF(KOFF3),NALBEM) 111 END IF 112 113 END DO 114 115 RETURN 116 END 117*---------------------------------------------------------------------* 118