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 CCFBINT2(ITRAN,   LABELH, TA2AMP,
21     &                    DENSPKQ, ONEHQ,   FOCKQ, DENSQ,
22     &                    DENSA,   DENSPKA, FOCKA,
23     &                    DENSQA,  DENPKQA, FOCKQA,
24     &                    XLAMDH,  ISYM0,
25     &                    XLAMDHQ, ISYHOP,
26     &                    XLAMDHA, ISYMTA,
27     &                    XLAMHQA, ISYHTA,
28     &                    FNBFDA,  LUBFDA, IADRBFA,  IADBFA,
29     &                    FNBFDQA, LUBFDQA, IADRBFQA, IADBFQA,
30     &                    LRELAX,  LTWOEL,  LNEWTA,   LNEWOP,
31     &                    WORK,    LWORK)
32*---------------------------------------------------------------------*
33* Purpose:
34*
35*     Precalculate some intermediates for F^BT^A vector depending
36*     on T^A and/or IOPER (No Zeta vectors required):
37*     -- one electron part of B operator AO integrals (ONEHQ)
38*     -- AO-FOCKQ (initialized with ONEHQ)
39*     --
40*     -- The packed densities for FOCK(Q,A,QA) intermediates
41*     -- The effective density of the rho^BFA intermediate (FNBFDA)
42*     -- The effective density of the rho^BFQA intermediate (FNBFDA)
43*
44*     BFA density only computed for LNEWTA and if
45*     LTWOEL or LRELAX are set
46*
47*     BFQA density computed for LNEWTA or LNEWOP and LRELAX
48*     (to be checked)
49*
50*     Fock, OneHam & density intermediates computed always
51*
52*     Sonia Coriani, February 1999. Based on CCXIINT1
53*
54* The actual calculation of the Fock densities could be moved inside here!
55* (OBS: the routine is not called for CCS!!!)
56*---------------------------------------------------------------------*
57      IMPLICIT NONE
58#include "priunit.h"
59#include "ccsdinp.h"
60#include "ccsdsym.h"
61#include "maxorb.h"
62#include "ccorb.h"
63#include "ccfield.h"
64
65      LOGICAL LOCDBG
66      PARAMETER (LOCDBG = .FALSE.)
67
68      LOGICAL LRELAX, LTWOEL, LZERO, LNEWTA, LNEWOP
69      CHARACTER*(*) FNBFDA, FNBFDQA
70      CHARACTER*(8) LABELH,LABTEST
71      INTEGER ITRAN, ISYM0, ISYMTA,ISYHOP, ISYHTA,LWORK
72      INTEGER LUBFDA,  IADBFA,  IADRBFA(MXCORB_CC,*)
73      INTEGER LUBFDQA, IADBFQA, IADRBFQA(MXCORB_CC,*)
74
75#if defined (SYS_CRAY)
76      REAL DENSPKQ(*), ONEHQ(*), FOCKQ(*)
77      REAL FOCKA(*), FOCKQA(*)
78      REAL XLAMDH(*), XLAMDHQ(*)
79      REAL XLAMDHA(*), XLAMHQA(*)
80      REAL DENSQ(*), TA2AMP(*), WORK(*)
81      REAL DENSA(*), DENSPKA(*)
82      REAL DENSQA(*), DENPKQA(*)
83      REAL ZERO, THREE, DUMMY
84#else
85      DOUBLE PRECISION DENSPKQ(*), ONEHQ(*), FOCKQ(*)
86      DOUBLE PRECISION FOCKA(*), FOCKQA(*)
87      DOUBLE PRECISION XLAMDH(*), XLAMDHQ(*)
88      DOUBLE PRECISION XLAMDHA(*), XLAMHQA(*)
89      DOUBLE PRECISION DENSQ(*), TA2AMP(*), WORK(*)
90      DOUBLE PRECISION DENSA(*), DENSPKA(*)
91      DOUBLE PRECISION DENSQA(*), DENPKQA(*)
92      DOUBLE PRECISION ZERO, THREE, DUMMY
93#endif
94      PARAMETER (ZERO = 0.0D0, THREE = 3.0D0)
95
96      CHARACTER MODEL*(10)
97      INTEGER IOPT, IDEL, IDUMMY, IFIELD, IRREP, ISYM, IERR
98      INTEGER LFOCKQMO
99
100*---------------------------------------------------------------------*
101* generate lower triangular packed density matrices for Fock densities:
102*---------------------------------------------------------------------*
103      CALL CC_DNSPK(DENSQ,DENSPKQ,ISYHOP)
104c
105      IF (LNEWTA) THEN
106         CALL CC_DNSPK(DENSA,DENSPKA,ISYMTA)
107      END IF
108c
109      CALL CC_DNSPK(DENSQA,DENPKQA,ISYHTA)
110
111*---------------------------------------------------------------------*
112* get AO one-electron integrals h^X (in ONEHQ)
113*---------------------------------------------------------------------*
114      IF ( LABELH(1:8) .EQ. 'HAM0    ' ) THEN
115
116        CALL CCRHS_ONEAO(ONEHQ,WORK,LWORK)
117*       for zeroth-order Hamiltonian add finite fields:
118        DO IFIELD = 1, NFIELD
119          CALL CC_ONEP(ONEHQ,WORK,LWORK,
120     &                 EFIELD(IFIELD),ISYHOP,LFIELD(IFIELD)  )
121        END DO
122
123C       --------------------------------------------
124C       scale the one-electron integrals with three:
125C       --------------------------------------------
126        IF (LRELAX) THEN
127           CALL DSCAL(N2BST(ISYHOP),THREE,ONEHQ,1)
128           WRITE (LUPRI,*) 'Warning: multiply ONEHQ with 3 ...'
129        END IF
130
131      ELSE IF ( LABELH(1:8) .EQ. 'DUMMYOP ' ) THEN
132        CALL DZERO(ONEHQ,N2BST(ISYHOP))
133      ELSE
134* check what ISYM is
135        CALL CCPRPAO(LABELH,.TRUE.,ONEHQ,IRREP,ISYM,IERR,WORK,LWORK)
136        IF (IERR.NE.0 .OR. IRREP.NE.ISYHOP) THEN
137          CALL QUIT('CCFBINT2: error while reading operator '//LABELH)
138        END IF
139
140      END IF
141
142*---------------------------------------------------------------------*
143* initialize derivative AO Fock matrix with h^x integrals (FOCKQ)
144* and the others FOCKA and FOCKQA with zero's
145*---------------------------------------------------------------------*
146c FOCKB reused in ccfbtaf, clean up possible exceeding space!!!
147c
148      LFOCKQMO = MAX(N2BST(ISYHOP),N2BST(ISYHTA))
149      CALL DZERO(FOCKQ,LFOCKQMO)
150      CALL DCOPY(N2BST(ISYHOP),ONEHQ,1,FOCKQ,1)
151c
152      CALL DZERO(FOCKA,N2BST(ISYMTA))
153      CALL DZERO(FOCKQA,N2BST(ISYHTA))
154
155*---------------------------------------------------------------------*
156* calculate effective density matrices for the rho^BFA, rho^BFA inter-
157* mediates:
158*---------------------------------------------------------------------*
159      IF (CCSD) THEN
160
161* a) BFA-density: for every NEW T^A, written on file inside called routine
162
163         IF (LNEWTA .AND. (LRELAX.OR.LTWOEL) ) THEN
164            IOPT = 3
165            CALL CC_BFDEN(TA2AMP, ISYMTA, DUMMY,  IDUMMY,
166     *                    XLAMDH, ISYM0,  XLAMDH, ISYM0,
167     *                    XLAMDHA, ISYMTA, DUMMY,  IDUMMY,
168     *                    FNBFDA,LUBFDA,IADRBFA, IADBFA,
169     *                    ITRAN, IOPT, .FALSE., WORK, LWORK)
170         ELSE IF (LRELAX) THEN
171            DO IDEL = 1, NBAST
172              IADRBFA(IDEL,ITRAN) = IADRBFA(IDEL,ITRAN-1)
173            END DO
174c         ELSE
175c            DO IDEL = 1, NBAST
176c              !rho^BFA non calculated if NOT relaxed/twoel case
177c              IADRBFA(IDEL,ITRAN) = -999999
178c            END DO
179         END IF
180
181
182* b) BFQA-density: for every new T^A or IOPER
183
184         IF ((LNEWTA .OR. LNEWOP).AND.LRELAX) THEN
185            IOPT = 7
186            CALL CC_BFDEN(TA2AMP, ISYMTA, DUMMY,   IDUMMY,
187     *                    XLAMDHQ,ISYHOP, XLAMDH,  ISYM0,
188     *                    XLAMDHA,ISYMTA, XLAMHQA, ISYHTA,
189     *                    FNBFDQA,LUBFDQA,IADRBFQA, IADBFQA,
190     *                    ITRAN, IOPT, .FALSE., WORK, LWORK)
191         ELSE IF (LRELAX) THEN
192            DO IDEL = 1, NBAST
193              IADRBFQA(IDEL,ITRAN) = IADRBFQA(IDEL,ITRAN-1)
194            END DO
195c         ELSE
196c            DO IDEL = 1, NBAST
197c              IADRBFQA(IDEL,ITRAN) = -999999
198c            END DO
199          END IF
200c
201      END IF
202
203*---------------------------------------------------------------------*
204* that's it; return:
205*---------------------------------------------------------------------*
206      RETURN
207
208      END
209*=====================================================================*
210