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_FCKRLX1(FOCK1,FOCK0,ISYFCK1,ISYFCK0,
21     &                     XLAMDP0,XLAMDH0,ISYMP0,ISYMH0,
22     &                     XLAMDP1,XLAMDH1,ISYMP1,ISYMH1,
23     &                     LRELAX,WORK,LWORK)
24*----------------------------------------------------------------------
25*
26*     Purpose: transform derivative AO fock matrix to MO basis and
27*              add relaxation contributions coming from the
28*              derivatives of the transformation matrices
29*
30*              if LRELAX, add relaxation contributions
31*
32*              FOCK1 : derivative fock matrix, replaced on output
33*              FOCK0 : zeroth-order fock matrix, unchanged on output
34*
35*   WARNING: Symmetry of result is NOT necessarily ISYFCK1!!!
36*
37*     Christof Haettig, July 1998
38*
39*     Generalized for pairs of XLAMDH and XLAMDP of different symmetry
40*     Symmetry of FOCK1, FOCK0 in input must be specified outside
41*     Sonia Coriani, September 1999
42*     (symmetry tests to be added)
43*======================================================================
44#if defined (IMPLICIT_NONE)
45      IMPLICIT NONE
46#else
47#  include "implicit.h"
48#endif
49#include "priunit.h"
50#include "ccorb.h"
51#include "ccsdsym.h"
52
53      LOGICAL LOCDBG
54      PARAMETER (LOCDBG = .FALSE.)
55
56      LOGICAL LRELAX
57      INTEGER ISYMP0, ISYMP1, ISYMH0, ISYMH1, ISYPH0, ISYPH1
58      INTEGER ISYFCK1,ISYFCK0
59      INTEGER LWORK, ISYRES, KEND1, KSCR, LWRK1
60
61#if defined (SYS_CRAY)
62      REAL FOCK1(*), FOCK0(*), WORK(*)
63      REAL XLAMDP0(*), XLAMDH0(*), XLAMDP1(*), XLAMDH1(*)
64      REAL ONE, XNORM, DDOT, DNRM2
65#else
66      DOUBLE PRECISION FOCK1(*), FOCK0(*), WORK(*)
67      DOUBLE PRECISION XLAMDP0(*), XLAMDH0(*), XLAMDP1(*), XLAMDH1(*)
68      DOUBLE PRECISION ONE, XNORM, DDOT, DNRM2
69#endif
70      PARAMETER(ONE=1.0D0)
71
72
73*---------------------------------------------------------------------*
74*       if debug flag set, print input matrices in AO:
75*---------------------------------------------------------------------*
76        IF (LOCDBG) THEN
77          WRITE (LUPRI,*) 'CC_FCKRLX1> FOCK1 in AO:'
78          CALL CC_PRFCKAO(FOCK1,ISYFCK1)
79          XNORM = DNRM2(N2BST(ISYFCK1),FOCK1,1)
80          WRITE (LUPRI,*) 'Norm of AO FOCK1 matrix:', XNORM
81          WRITE (LUPRI,*) 'CC_FCKRLX1> FOCK0 in AO:'
82          CALL CC_PRFCKAO(FOCK0,ISYFCK0)
83          XNORM = DNRM2(N2BST(ISYFCK0),FOCK0,1)
84          WRITE (LUPRI,*) 'Norm of AO FOCK0 matrix:', XNORM
85          CALL FLSHFO(LUPRI)
86        END IF
87
88*---------------------------------------------------------------------*
89*       transform derivative AO Fock matrix to MO using XLAMDP0/XLAMDH0
90*---------------------------------------------------------------------*
91        ISYPH0 = MULD2H(ISYMP0,ISYMH0)
92        ISYPH1 = MULD2H(ISYMP1,ISYMH1)
93        ISYRES = MULD2H(ISYFCK1,ISYPH0)
94
95        IF (ISYRES.NE.ISYFCK1) THEN
96          WRITE (LUPRI,*)
97     *        'Warning:ISYRES.NE.ISYFCK1. Replace FOCK1 in output?'
98        END IF
99
100*  FOCK1 must be allocated outside as MAX(N2BST(ISYFCK1),N2BST(ISYRES))!!
101
102        CALL CC_FCKMO(FOCK1,XLAMDP0,XLAMDH0,
103     *                WORK,LWORK,ISYFCK1,ISYMP0,ISYMH0)
104
105*---------------------------------------------------------------------*
106*       transform zero AO Fock matrix to MO using XLAMDP0/XLAMDH1
107*                                                 XLAMDP1/XLAMDH0
108*---------------------------------------------------------------------*
109        IF (LRELAX) THEN
110          KSCR  = 1                                         !contains Fock_MO
111          KEND1 = KSCR + MAX(N2BST(ISYFCK0),N2BST(ISYRES))
112          LWRK1 = LWORK - KEND1
113
114          IF ( LWRK1 .LT. 0 ) THEN
115            CALL QUIT('Insufficient work space in CC_FCKRLX.')
116          END IF
117
118*         duplicate zeroth-order AO Fock matrix in WORK:
119          CALL DCOPY(N2BST(ISYFCK0),FOCK0,1,WORK(KSCR),1)
120
121*         transform zeroth-order AO FOCK with XLAMDP1 and XLAMDH0,
122*         and add to transformed derivative Fock matrix:
123          CALL CC_FCKMO(WORK(KSCR),XLAMDP1,XLAMDH0,
124     &                  WORK(KEND1),LWRK1,ISYFCK0,ISYMP1,ISYMH0)
125
126          CALL DAXPY(N2BST(ISYRES),ONE,WORK(KSCR),1,FOCK1,1)
127
128*         duplicate zeroth-order AO Fock matrix in WORK:
129          CALL DCOPY(N2BST(ISYFCK0),FOCK0,1,WORK(KSCR),1)
130
131*         transform zeroth-order AO FOCK with XLAMDP0 and XLAMDH1,
132*         and add to transformed derivative Fock matrix:
133          CALL CC_FCKMO(WORK(KSCR),XLAMDP0,XLAMDH1,
134     &                  WORK(KEND1),LWRK1,ISYFCK0,ISYMP0,ISYMH1)
135
136          CALL DAXPY(N2BST(ISYRES),ONE,WORK(KSCR),1,FOCK1,1)
137
138        END IF
139
140*---------------------------------------------------------------------*
141*       print debug output and return:
142*---------------------------------------------------------------------*
143
144        IF (LOCDBG) THEN
145          WRITE (LUPRI,*) 'CC_FCKRLX1> FOCK1 in MO:'
146c          CALL CC_PRFCKMO(FOCK1,ISYRES)
147          XNORM = DDOT(N2BST(ISYRES),FOCK1,1,FOCK1,1)
148          WRITE (LUPRI,*) 'Norm of MO FOCK1 matrix:', XNORM
149          CALL FLSHFO(LUPRI)
150        END IF
151
152      RETURN
153
154      END
155
156*======================================================================
157