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