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