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