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_F1INACT(FOCK1,ISYFCK,IREAL,LABEL,CMO,WORK,LWORK)
21*---------------------------------------------------------------------*
22*
23*     Purpose: calculate the SCF F^[1] matrix which is equal to the
24*              inactive Fock matrix calculated from the derivative
25*              integrals multiplied with the density matrix (i.e.
26*              projected to the occupied space)
27*
28*              FOCK1   --  the F^[1] matrix (output)
29*              ISYFCK  --  symmetry of the F^[1] matrix (input)
30*              LABEL   --  operator label for the perturbation (input)
31*              CMO     --  HF orbital coefficients (input)
32*
33*     Christof Haettig 5-2-1999, restructured 24-5-99
34*
35*---------------------------------------------------------------------*
36      IMPLICIT NONE
37#include "priunit.h"
38#include "ccorb.h"
39#include "ccsdsym.h"
40#include "ccexpfck.h"
41
42      LOGICAL LOCDBG
43      PARAMETER (LOCDBG = .FALSE.)
44
45      INTEGER ISYM0, LUFCK
46      PARAMETER( ISYM0 = 1 )
47
48      CHARACTER*(8) LABEL
49      INTEGER ISYFCK, LWORK
50
51#if defined (SYS_CRAY)
52      REAL FOCK1(*), CMO(*), WORK(LWORK)
53      REAL ONE, TWO, ZERO, FTRACE, TEMP, SIGN
54#else
55      DOUBLE PRECISION FOCK1(*), CMO(*), WORK(LWORK)
56      DOUBLE PRECISION HALF, ONE, TWO, ZERO, FTRACE, TEMP, SIGN
57#endif
58      PARAMETER( HALF = 0.5D0, ONE = 1.0D0, TWO = 2.0D0, ZERO = 0.0D0 )
59
60      INTEGER IFOCK, IADRF, IOPT, ISYM, IEXPV, IREAL
61      INTEGER KFOCK1,KOVERLP,KEND1,LWRK1
62      INTEGER INDF, INDE1, INDE2, KOFF1, IORBB, KSAB
63      INTEGER ISYMA, ISYMI, KSAI, KSIA, IOCCI, IORBA, IVIRA, IVIRB
64
65* external functions:
66      INTEGER IEFFFOCK
67      INTEGER IEXPECT
68
69*---------------------------------------------------------------------*
70*     set indeces for SCF eff. Fock matrices and expect. values
71*---------------------------------------------------------------------*
72      INDF  = 2
73      INDE1 = 3
74      INDE2 = 4
75
76*---------------------------------------------------------------------*
77*     allocate memory for effective Fock and a dummy overlap matrix:
78*---------------------------------------------------------------------*
79      KFOCK1  = 1
80      KOVERLP = KFOCK1  + N2BST(ISYFCK)
81      KEND1   = KOVERLP + N2BST(ISYM0)
82      LWRK1   = LWORK   - KEND1
83
84      IF (LWRK1 .LT. NBAST) THEN
85         CALL QUIT('Insufficient work space in CC_F1INACT.')
86      END IF
87
88*---------------------------------------------------------------------*
89*     read first-order effective Fock matrix from file
90*---------------------------------------------------------------------*
91      IFOCK = IEFFFOCK(LABEL,ISYM,1)
92      IADRF = IADRFCK(INDF,IFOCK)
93
94      LUFCK = -1
95      CALL WOPEN2(LUFCK,FILFCKEFF,64,0)
96      CALL GETWA2(LUFCK,FILFCKEFF,WORK(KFOCK1),IADRF,N2BST(ISYFCK))
97      CALL WCLOSE2(LUFCK,FILFCKEFF,'KEEP')
98
99      IF (LOCDBG) THEN
100         FTRACE = ZERO
101         IF (ISYFCK.EQ.1) THEN
102            DO ISYM = 1, NSYM
103               KOFF1 = KFOCK1 + IAODIS(ISYM,ISYM)
104               DO I = 1, NBAS(ISYM)
105                 FTRACE = FTRACE + WORK(KOFF1+NBAS(ISYM)*(I-1)+I-1)
106               END DO
107            END DO
108         END IF
109         IEXPV = IEXPECT(LABEL,ISYM)
110         WRITE (LUPRI,*) 'LABEL:',LABEL
111         WRITE (LUPRI,*) 'ISYFCK,IFOCK,IEXPV:',ISYFCK,IFOCK,IEXPV
112         WRITE (LUPRI,*) 'FTRACE of read matrix:',FTRACE
113         WRITE (LUPRI,*) 'one-electron expect:',EXPVALUE(INDE1,IEXPV)
114         WRITE (LUPRI,*) 'two-electron expect:',EXPVALUE(INDE2,IEXPV)
115         WRITE (LUPRI,*) 'CC_F1INACT> F^[1] matrix in SO basis:'
116         CALL CC_PRONELAO(FOCK1,ISYFCK)
117      END IF
118
119*---------------------------------------------------------------------*
120*     transform to MO using unit overlap matrix:
121*---------------------------------------------------------------------*
122      CALL DZERO(WORK(KOVERLP),N2BST(ISYM0))
123      DO ISYM = 1, NSYM
124         KOFF1 = KOVERLP + IAODIS(ISYM,ISYM)
125         DO I = 1, NBAS(ISYM)
126           WORK(KOFF1+NBAS(ISYM)*(I-1)+I-1) = ONE
127         END DO
128      END DO
129
130      ! transform effective Fock matrix to MO basis
131      CALL CC_EFFCKMO(WORK(KFOCK1),ISYFCK,CMO,WORK(KOVERLP),
132     &                WORK(KEND1),LWRK1)
133
134      IF (LOCDBG) THEN
135         FTRACE = ZERO
136         IF (ISYFCK.EQ.1) THEN
137            DO ISYM = 1, NSYM
138               KOFF1 = KFOCK1 + IAODIS(ISYM,ISYM)
139               DO I = 1, NBAS(ISYM)
140                 FTRACE = FTRACE + WORK(KOFF1+NBAS(ISYM)*(I-1)+I-1)
141               END DO
142            END DO
143         END IF
144         WRITE (LUPRI,*) 'LABEL:',LABEL
145         WRITE (LUPRI,*) 'ISYFCK:',ISYFCK
146         WRITE (LUPRI,*) 'FTRACE of matrix generated in CC_EFCKMO:',
147     &                    FTRACE
148         WRITE (LUPRI,*) 'CC_F1INACT> F^[1] matrix in MO basis:'
149         CALL CC_PRONELAO(FOCK1,ISYFCK)
150      END IF
151
152*---------------------------------------------------------------------*
153*     put into result matrix and project onto occupied space:
154*---------------------------------------------------------------------*
155      ! initialize output vector
156      CALL DZERO(FOCK1,N2BST(ISYFCK))
157
158      ! add 2 times to F^[1] matrix
159      CALL DAXPY(N2BST(ISYFCK),TWO,WORK(KFOCK1),1,FOCK1,1)
160
161      IF (LOCDBG) THEN
162         WRITE (LUPRI,*) 'CC_F1INACT> direct contribution '//
163     &        'to F^[1] matrix:'
164         CALL CC_PRONELAO(FOCK1,ISYFCK)
165      END IF
166
167      ! delete the virtual block of X
168      IF (.FALSE.) THEN
169      DO ISYMA = 1, NSYM
170        ISYMI  = MULD2H(ISYFCK,ISYMA)
171        DO IVIRA = 1, NVIRS(ISYMA)
172        DO IOCCI = 1, NBAS(ISYMI)
173          IORBA = NRHFS(ISYMA) + IVIRA
174          KSAI = IAODIS(ISYMA,ISYMI) + (IOCCI-1)*NORBS(ISYMA) + IORBA
175          KSIA = IAODIS(ISYMI,ISYMA) + (IORBA-1)*NORBS(ISYMI) + IOCCI
176          FOCK1(KSAI) = ZERO
177C
178C         quick hack for imaginary operators and/or natural connection
179C
180          SIGN = DBLE(IREAL)
181          TEMP = HALF * ( FOCK1(KSAI) + SIGN * FOCK1(KSIA) )
182          FOCK1(KSAI) = TEMP
183          FOCK1(KSIA) = TEMP * SIGN
184C
185        END DO
186        DO IVIRB = 1, NBAS(ISYMI)
187          IORBA = NRHFS(ISYMA) + IVIRA
188          IORBB = NRHFS(ISYMI) + IVIRB
189          KSAB = IAODIS(ISYMA,ISYMI) + (IORBB-1)*NORBS(ISYMA) + IORBA
190          FOCK1(KSAB) = ZERO
191        END DO
192        END DO
193      END DO
194      END IF
195
196
197      IF (LOCDBG) THEN
198         WRITE (LUPRI,*) 'CC_F1INACT> final result for F^[1] matrix:',
199     *                    LABEL
200         WRITE (LUPRI,*) 'trace of F^[1] matrix:',FTRACE
201         WRITE (LUPRI,*) IREAL,SIGN
202         CALL CC_PRONELAO(FOCK1,ISYFCK)
203         FTRACE = ZERO
204         DO ISYM = 1, NSYM
205            KOFF1 = IAODIS(ISYM,ISYM)
206            DO I = 1, NBAS(ISYM)
207              FTRACE = FTRACE + FOCK1(KOFF1+NBAS(ISYM)*(I-1)+I)
208            END DO
209         END DO
210      END IF
211
212      RETURN
213      END
214*======================================================================*
215