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_QAOS(QAOS,RMAT,XKAPPA,IREAL,ISYMQ,SAO,WORK,LWORK)
21*---------------------------------------------------------------------*
22*
23*     Purpose: calculate the product of Q^{p,ao} matrix with the
24*              AO overlap matrix:
25*
26*         QAOS   -- result matrix: CMO Q^p CMO^T S^AO
27*         RMAT   -- orbital connection matrix in AO basis
28*         XKAPPA -- orbital relaxation vector in MO basis
29*         IREAL  -- flag for real/imaginary R and kappa
30*         ISYMQ  -- symmetry of XKAPPA, RMAT, and QAOS
31*         SAO    -- overlap matrix
32*
33*     Christof Haettig, March 1999
34*
35*     N.B.: not yet fully adapted non-antisymmetric kappa
36*           and/or non-symmetric R !!!
37*
38*=====================================================================*
39#if defined (IMPLICIT_NONE)
40      IMPLICIT NONE
41#else
42#  include "implicit.h"
43#endif
44#include "priunit.h"
45#include "dummy.h"
46#include "ccorb.h"
47#include "ccsdsym.h"
48
49      LOGICAL LOCDBG
50      PARAMETER (LOCDBG = .FALSE.)
51      INTEGER ISYM0
52      PARAMETER (ISYM0 = 1)
53
54      INTEGER IREAL, ISYMQ, LWORK
55
56#if defined (SYS_CRAY)
57      REAL QAOS(*), RMAT(*), XKAPPA(*), SAO(*), WORK(LWORK)
58      REAL ONE, ZERO
59#else
60      DOUBLE PRECISION QAOS(*), RMAT(*), XKAPPA(*), SAO(*), WORK(LWORK)
61      DOUBLE PRECISION ONE, ZERO
62#endif
63      PARAMETER(ONE=1.0D0, ZERO=0.0D0)
64
65      LOGICAL NOKAPPA
66      INTEGER ISYALP, ISYBET, ISYGAM, ISYMP, NBASA, NBASB
67      INTEGER KQMOP, KQMOH, KCMOQ
68      INTEGER KCMO, KQAO, KEND1, LWRK1, KOFF1, KOFF2, KOFF3, NORBSA
69      INTEGER NCMO(8), ICMO(8,8), ISYM, ICOUNT, ISYM2, ISYM1
70
71*---------------------------------------------------------------------*
72*     set ICMO & NCMO arrays:
73*---------------------------------------------------------------------*
74      DO ISYM = 1, NSYM
75         ICOUNT = 0
76         DO ISYM2 = 1, NSYM
77            ISYM1 = MULD2H(ISYM,ISYM2)
78            ICMO(ISYM1,ISYM2) = ICOUNT
79            ICOUNT = ICOUNT + NBAS(ISYM1)*NORBS(ISYM2)
80         END DO
81         NCMO(ISYM) = ICOUNT
82      END DO
83
84*---------------------------------------------------------------------*
85*     memory allocation:
86*---------------------------------------------------------------------*
87      KCMO  = 1
88      KCMOQ = KCMO  + NLAMDS
89      KQMOP = KCMOQ + NCMO(ISYMQ)
90      KQMOH = KQMOP + N2BST(ISYMQ)
91      KQAO  = KQMOH + N2BST(ISYMQ)
92      KEND1 = KQAO  + N2BST(ISYMQ)
93      LWRK1 = LWORK - KEND1
94
95      IF (LWRK1 .LT. 0) THEN
96         CALL QUIT('Insufficient work space in CC_QAOS.')
97      END IF
98
99*---------------------------------------------------------------------*
100*     read (undifferentiated) MO coefficients from file:
101*---------------------------------------------------------------------*
102      CALL CC_GET_CMO(WORK(KCMO))
103
104*---------------------------------------------------------------------*
105*     build Q matrix in MO representation:
106*---------------------------------------------------------------------*
107      NOKAPPA = .FALSE.
108      CALL CC_QMAT(WORK(KQMOP),WORK(KQMOH),RMAT,XKAPPA,
109     &             IREAL,ISYMQ,NOKAPPA,WORK(KCMO),WORK(KEND1),LWRK1)
110
111*---------------------------------------------------------------------*
112*     transform to leading index to contravariant AO basis:
113*             CMOQ = CMO x Q
114*---------------------------------------------------------------------*
115      DO ISYALP = 1, NSYM
116         ISYBET = MULD2H(ISYALP,ISYMQ)
117
118         NBASA  = MAX(NBAS(ISYALP),1)
119         NORBSA = MAX(NORBS(ISYALP),1)
120
121         KOFF1 = KCMO  + ICMO(ISYALP,ISYALP)
122         KOFF2 = KQMOP + IAODIS(ISYALP,ISYBET)
123         KOFF3 = KCMOQ + ICMO(ISYALP,ISYBET)
124
125         CALL DGEMM('N','N',NBAS(ISYALP),NORBS(ISYBET),NORBS(ISYALP),
126     &              ONE,WORK(KOFF1),NBASA,WORK(KOFF2),NORBSA,
127     &              ZERO,WORK(KOFF3),NBASA)
128
129      END DO
130
131*---------------------------------------------------------------------*
132*     transform to second index to contravariant AO basis:
133*             Q^ao = CMOQ x CMO^T
134*---------------------------------------------------------------------*
135      CALL DZERO(WORK(KQAO),N2BST(ISYMQ))
136
137      DO ISYALP = 1, NSYM
138
139         ISYBET = MULD2H(ISYALP,ISYMQ)
140         ISYMP  = ISYBET
141
142         NBASA = MAX(NBAS(ISYALP),1)
143         NBASB = MAX(NBAS(ISYBET),1)
144
145         KOFF1 = KCMOQ + ICMO(ISYALP,ISYMP)
146         KOFF2 = KCMO  + ICMO(ISYBET,ISYMP)
147         KOFF3 = KQAO  + IAODIS(ISYALP,ISYBET)
148
149         CALL DGEMM('N','T',NBAS(ISYALP),NBAS(ISYBET),NORBS(ISYMP),
150     &              ONE,WORK(KOFF1),NBASA,WORK(KOFF2),NBASB,
151     &              ZERO,WORK(KOFF3),NBASA)
152
153      END DO
154
155*---------------------------------------------------------------------*
156*     multiply with the overlap matrix:
157*---------------------------------------------------------------------*
158      CALL CC_MAOMAO('N','N',ONE,WORK(KQAO),ISYMQ,SAO,ISYM0,
159     &               ZERO,QAOS,ISYMQ)
160
161      RETURN
162      END
163*=====================================================================*
164