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_1IDXTRAN(AMAT,ISYMA,BMAT,ISYMB,CMAT,ISYMC) 21*---------------------------------------------------------------------* 22* 23* Purpose: evaluate the 1-index transformation 24* 25* C = A B + B A^T 26* 27* Christof Haettig 7-2-1999 28* 29*---------------------------------------------------------------------* 30 IMPLICIT NONE 31#include "ccorb.h" 32#include "ccsdsym.h" 33#include "priunit.h" 34 35 LOGICAL LOCDBG 36 PARAMETER (LOCDBG = .FALSE.) 37 38 INTEGER ISYMA, ISYMB, ISYMC 39 40#if defined (SYS_CRAY) 41 REAL AMAT(*), BMAT(*), CMAT(*), ONE 42#else 43 DOUBLE PRECISION AMAT(*), BMAT(*), CMAT(*), ONE 44#endif 45 PARAMETER( ONE = 1.0D0 ) 46 47 INTEGER ISYMP,ISYMQ,ISYMR,NBASP,NBASQ,NBASR,KOFF1,KOFF2,KOFF3 48 49*---------------------------------------------------------------------* 50* check symmetries and initialize output matrix: 51*---------------------------------------------------------------------* 52 IF (ISYMC .NE. MULD2H(ISYMA,ISYMB)) THEN 53 CALL QUIT('Symmetry mismatch in CC_1IDXTRAN.') 54 END IF 55 56 CALL DZERO(CMAT,N2BST(ISYMC)) 57 58*---------------------------------------------------------------------* 59* Calculate A x B and add to output matrix: 60*---------------------------------------------------------------------* 61 DO ISYMP = 1, NSYM 62 63 ISYMQ = MULD2H(ISYMP,ISYMA) 64 ISYMR = MULD2H(ISYMQ,ISYMB) 65 66 KOFF1 = IAODIS(ISYMP,ISYMQ) + 1 67 KOFF2 = IAODIS(ISYMQ,ISYMR) + 1 68 KOFF3 = IAODIS(ISYMP,ISYMR) + 1 69 70 NBASP = MAX(1,NBAS(ISYMP)) 71 NBASQ = MAX(1,NBAS(ISYMQ)) 72 73 CALL DGEMM('N','N',NBAS(ISYMP),NBAS(ISYMR),NBAS(ISYMQ), 74 * ONE,AMAT(KOFF1),NBASP,BMAT(KOFF2),NBASQ, 75 * ONE,CMAT(KOFF3),NBASP) 76 END DO 77 78 79*---------------------------------------------------------------------* 80* Calculate B x A^T and add to output matrix: 81*---------------------------------------------------------------------* 82 DO ISYMP = 1, NSYM 83 84 ISYMQ = MULD2H(ISYMP,ISYMB) 85 ISYMR = MULD2H(ISYMQ,ISYMA) 86 87 KOFF1 = IAODIS(ISYMP,ISYMQ) + 1 88 KOFF2 = IAODIS(ISYMR,ISYMQ) + 1 89 KOFF3 = IAODIS(ISYMP,ISYMR) + 1 90 91 NBASP = MAX(1,NBAS(ISYMP)) 92 NBASR = MAX(1,NBAS(ISYMR)) 93 94 CALL DGEMM('N','T',NBAS(ISYMP),NBAS(ISYMR),NBAS(ISYMQ), 95 * ONE,BMAT(KOFF1),NBASP,AMAT(KOFF2),NBASR, 96 * ONE,CMAT(KOFF3),NBASP) 97 END DO 98 99 100*---------------------------------------------------------------------* 101* print to output & return: 102*---------------------------------------------------------------------* 103 IF (LOCDBG) THEN 104 WRITE (LUPRI,*) 'CC_1IDXTRAN> result of one-index '// 105 & 'transformation:' 106 CALL CC_PRONELAO(CMAT,ISYMC) 107 END IF 108 109 RETURN 110 END 111*======================================================================* 112