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 19C /* Deck rspfxd */ 20 SUBROUTINE RSPFXD (FI,FA,QA,QB,H2AX, 21 * IDAX,INTSYM, ISYMDN,DEN1,DEN2, 22 * PVDEN,H2,H2X,WRK,KFREE,LFREE, 23 * LCON,LORB,IPRFX,IGRSPI,ISPIN1,ISPIN2,ISPIN3, 24 * IKLVL,ZYMAT1,ISYM1,ZYMAT2,ISYM2,ZYMAT3,ISYM3) 25C 26C 27C 15-Nov-1991 hjaaj (pulled out of RSP2GR) 28C 29C This routine computes the FX matrices, that is, the Fock 30C type matrices FI, FA, QA, and QB with transformed ("X") 31C integrals. In addition, If LCON true then the H2AX matrix 32C with transformed integrals is extracted for the CI routines. 33C 34#include "implicit.h" 35C 36 PARAMETER ( D0 = 0.0D0, DH = 0.50D0 ) 37C 38C Used from common blocks: 39C ? 40C 41#include "maxorb.h" 42#include "maxash.h" 43#include "priunit.h" 44#include "infinp.h" 45#include "inforb.h" 46#include "infind.h" 47#include "infdim.h" 48#include "infrsp.h" 49#include "infpri.h" 50#include "orbtypdef.h" 51#include "rspprp.h" 52#include "infhyp.h" 53#include "infspi.h" 54#include "cbgetdis.h" 55#include "infdis.h" 56C 57 58 DIMENSION FI(NORBT,NORBT),FA(NORBT,NORBT) 59 DIMENSION QA(NORBT,NASHDI),QB(NORBT,NASHDI) 60 DIMENSION H2(NORBT,NORBT), H2X(NORBT,NORBT) 61 DIMENSION H2AX(N2ASHX*N2ASHX,*) 62 DIMENSION DEN1(NASHDI,NASHDI), DEN2(*) 63 DIMENSION PVDEN(NASHDI,NASHDI) 64 DIMENSION ZYMAT1(NORBT,NORBT),ZYMAT2(NORBT,NORBT) 65 DIMENSION ZYMAT3(NORBT,NORBT) 66 DIMENSION WRK(*) 67 DIMENSION NEEDED(-4:6) 68C 69 LOGICAL LCON, LORB 70C 71C Put up the structure for reading the (transformed) integrals: 72C IEND < 0 flags the completeness of the distributions 73C 74 CALL QENTER('RSPFXD') 75 IF (DOHFSRDFT .OR. DOMCSRDFT) THEN 76 CALL QUIT('srDFT not implemented yet in RSPFXD') 77 END IF 78 KWRK = KFREE 79 LWRK = LFREE 80 ID1 = 1 81 ID2 = N2ASHX*N2ASHX + 1 82 CALL DZERO(H2,N2ORBX) 83 NEEDED(-4:6) = 0 84 NEEDED( 1:5) = 1 85 IF (IKLVL.GE.2) NEEDED(6) = 1 86 IF (IPRFX.GT.200) THEN 87 WRITE(LUPRI,'(/A)') '------ ENTERING RSPFXD ------' 88 WRITE(LUPRI,'(A,I5)') 'IDAX =',IDAX 89 WRITE(LUPRI,'(A,I5)') 'INTSYM =',INTSYM 90 WRITE(LUPRI,'(A,I5)') 'ISYMDN =',ISYMDN 91 WRITE(LUPRI,'(A,L1)') 'LCON =',LCON 92 WRITE(LUPRI,'(A,L2)') 'LORB =',LORB 93 WRITE(LUPRI,'(A,I5)') 'IPRFX =',IPRFX 94 WRITE(LUPRI,'(A,I5)') 'IGRSPI =',IGRSPI 95 WRITE(LUPRI,'(A,I5)') 'ISPIN1 =',ISPIN1 96 WRITE(LUPRI,'(A,I5)') 'ISPIN2 =',ISPIN2 97 WRITE(LUPRI,'(A,I5)') 'ISPIN3 =',ISPIN3 98 WRITE(LUPRI,'(A,I5)') 'IKLVL =',IKLVL 99 WRITE(LUPRI,'(A,I5)') 'ISYM1 =',ISYM1 100 WRITE(LUPRI,'(A,I5)') 'ISYM2 =',ISYM2 101 WRITE(LUPRI,'(A,I5)') 'ISYM3 =',ISYM3 102 WRITE(LUPRI,'(/A)') 'One-electron FI' 103 CALL OUTPUT(FI,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 104 WRITE(LUPRI,'(/A)') 'One-electron density' 105 CALL OUTPUT(DEN1,1,NASHT,1,NASHT,NASHT,NASHT,1,LUPRI) 106 WRITE(LUPRI,'(/A)') 'Two-electron density' 107 CALL PRIAC2(DEN2,NASHT,LUPRI) 108 IF (TRPFLG) THEN 109 WRITE(LUPRI,'(/A)') 'Two-electron density, triplet' 110 CALL PRIAC2(DEN2(ID2),NASHT,LUPRI) 111 END IF 112 END IF 113 IDIST = 0 114 IPERCD = 1 115C 116 CALL MEMGET('REAL',KFIRST,1,WRK,KWRK,LWRK) 117 IF (IKLVL.EQ.0) THEN 118 CALL MEMGET('REAL',KFI,N2ORBX,WRK,KWRK,LWRK) 119 CALL DZERO(WRK(KFI),N2ORBX) 120 ELSE 121 CALL MEMGET('REAL',KFI,0 ,WRK,KWRK,LWRK) 122 END IF 123 IF (IKLVL.EQ.3) THEN 124 CALL MEMGET('REAL',KH2,N2ORBX,WRK,KWRK,LWRK) 125 ELSE 126 CALL MEMGET('REAL',KH2,0 ,WRK,KWRK,LWRK) 127 END IF 128 LSCR = 0 129 IF (NASHT.GT.0) THEN 130 CALL MEMGET('REAL',KH2XAC,N2ASHX,WRK,KWRK,LWRK) 131 CALL DZERO(WRK(KH2XAC),N2ASHX) 132 IF (LORB) LSCR = MAX(NORBT,N2ASHX) 133 ELSE 134 CALL MEMGET('REAL',KH2XAC,0,WRK,KWRK,LWRK) 135 END IF 136 CALL MEMGET('REAL',KSCR,LSCR,WRK,KWRK,LWRK) 137C 1381000 CALL NXTH2M(IC,ID,H2,NEEDED,WRK,KWRK,LWRK,IDIST) 139 IF ( IDIST .LT. 0) GO TO 2000 140C 141C 142C Determine type of distribution 143C 144 ICTYP = IOBTYP(IC) 145 IDTYP = IOBTYP(ID) 146 ICDTYP = IDBTYP(ICTYP,IDTYP) 147C 148C Determine symmetry of distribution 149C 150 ICSYM = ISMO( IC ) 151 IDSYM = ISMO( ID ) 152 ICDSYM = MULD2H(ICSYM,IDSYM) 153C 154C 155C 156 IF ( IPRFX .GT. 300) THEN 157 WRITE(LUPRI,'(//A)') 'Characteristics of distribution:' 158 WRITE(LUPRI,'(A)') '================================' 159 WRITE(LUPRI,'(A,2I5)')'IC ID = ', IC,ID 160 WRITE(LUPRI,'(3A)') 'TYP = ', COBTYP(ICTYP),COBTYP(IDTYP) 161 WRITE(LUPRI,'(A,2I5)')'Symmetry= ', ICSYM, IDSYM 162 WRITE(LUPRI,'(A)') '================================' 163C 164 CALL HEADER('Two-electron integrals from this distribution',3) 165 CALL OUTPUT(H2,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 166 END IF 167C 168 IF (IDAX .EQ. 0) THEN 169C 170C Regular MO-integrals 171C 172 IF (IKLVL.EQ.0) THEN 173 IPDA = IPDENS(IGRSPI,0) 174 IPDB = IPDENS(0,IGRSPI) 175 CALL GETAC1(H2,WRK(KH2XAC)) 176 CALL FQDIS1(INTSYM,IC,ID,ICDTYP,ICDSYM,ICSYM,IDSYM, 177 * WRK(KFI),FA,QA,QB,H2,WRK(KH2XAC),H2AX, 178 * DEN1,DEN2(IPDA),DEN2(IPDB),ISYMDN,PVDEN, 179 * LORB,LCON, 180 * IGRSPI,ISPIN1,ISPIN2,IPERCD) 181 ELSE IF (IKLVL.EQ.1) THEN 182 IH2SYM = MULD2H(ICDSYM,INTSYM) 183C 184C Transform left (~| ) 185C 186 CALL DZERO(H2X,N2ORBX) 187 CALL OITH1(ISYM1,ZYMAT1,H2,H2X,IH2SYM) 188 INTSY1 = MULD2H(INTSYM,ISYM1) 189 IF (IPRFX.GT.300) THEN 190 WRITE(LUPRI,'(/A,I5)')'Left transform H2 of symmetry', 191 * IH2SYM 192 CALL OUTPUT(H2,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 193 WRITE(LUPRI,'(/A,I5)') 'with ZYMAT1 of symmetry',ISYM1 194 CALL OUTPUT(ZYMAT1,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 195 WRITE(LUPRI,'(/A)') 'to H2X ' 196 CALL OUTPUT(H2X,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 197 END IF 198 IPDA = IPDENS(MULSP(IGRSPI,ISPIN1),ISPIN2) 199 IPDB = IPDENS(ISPIN1,MULSP(IGRSPI,ISPIN2)) 200 CALL GETAC1(H2X,WRK(KH2XAC)) 201 CALL FQDIS1(INTSY1,IC,ID,ICDTYP,ICDSYM,ICSYM,IDSYM, 202 * FI,FA,QA,QB,H2X,WRK(KH2XAC),H2AX, 203 * DEN1,DEN2(IPDA),DEN2(IPDB),ISYMDN,PVDEN, 204 * LORB,LCON, 205 * IGRSPI,ISPIN1,ISPIN2,IPERCD) 206 ELSE IF (IKLVL.EQ.2) THEN 207 IH2SYM = MULD2H(ICDSYM,INTSYM) 208C 209C Transform left (~| ) 210C 211 CALL DZERO(H2X,N2ORBX) 212 CALL OITH1(ISYM1,ZYMAT1,H2,H2X,IH2SYM) 213 INTSY1 = MULD2H(INTSYM,ISYM1) 214 IF (IPRFX.GT.300) THEN 215 WRITE(LUPRI,'(/A,I5)')'Left transform H2 of symmetry', 216 * IH2SYM 217 CALL OUTPUT(H2,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 218 WRITE(LUPRI,'(/A,I5)') 'with ZYMAT1 of symmetry',ISYM1 219 CALL OUTPUT(ZYMAT1,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 220 WRITE(LUPRI,'(/A)') 'to H2X ' 221 CALL OUTPUT(H2X,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 222 END IF 223C 224C Transform left (~~| ) 225C 226 IH2SY1 = MULD2H(ICDSYM,INTSY1) 227 INTSY2 = MULD2H(INTSY1,ISYM2) 228 IF (ICDTYP.NE.JTSESE) THEN 229 CALL DZERO(H2,N2ORBX) 230 CALL OITH1(ISYM2,ZYMAT2,H2X,H2,IH2SY1) 231 IF (IPRFX.GT.300) THEN 232 WRITE(LUPRI,'(/A,I5)') 233 * 'Left transform H2X of symmetry',IH2SY1 234 CALL OUTPUT(H2X,1,NORBT,1,NORBT, 235 * NORBT,NORBT,1,LUPRI) 236 WRITE(LUPRI,'(/A,I5)') 237 * 'with ZYMAT2 of symmetry',ISYM2 238 CALL OUTPUT(ZYMAT2,1,NORBT,1,NORBT, 239 * NORBT,NORBT,1,LUPRI) 240 WRITE(LUPRI,'(/A)') 'to H2' 241 CALL OUTPUT(H2,1,NORBT,1,NORBT,NORBT,NORBT,1, 242 & LUPRI) 243 END IF 244 ISP12=MULSP(ISPIN1,ISPIN2) 245 IF (ISP12.NE.IGRSPI) CALL QUIT('RSPFXD:SPIN ERROR') 246 IPDA = IPDENS(MULSP(IGRSPI,ISP12),0) 247 IPDB = IPDENS(ISP12,IGRSPI) 248 CALL GETAC1(H2,WRK(KH2XAC)) 249 CALL FQDIS1(INTSY2,IC,ID,ICDTYP,ICDSYM,ICSYM,IDSYM, 250 * FI,FA,QA,QB,H2,WRK(KH2XAC),H2AX, 251 * DEN1,DEN2(IPDA),DEN2(IPDB),ISYMDN,PVDEN, 252 * LORB,LCON, 253 * IGRSPI,ISP12,0,IPERCD) 254 END IF 255C 256C Transform right (~|~) 257C 258 IPDA = IPDENS(MULSP(IGRSPI,ISPIN1),ISPIN2) 259 IPDB = IPDENS(ISPIN1,MULSP(IGRSPI,ISPIN2)) 260 CALL GETAC1(H2X,WRK(KH2XAC)) 261 CALL FQDIS2(INTSY1,IC,ID,ICDTYP,ICDSYM,ICSYM,IDSYM, 262 * FI,FA,QA,QB,H2X,WRK(KH2XAC),H2AX(1,2), 263 * ZYMAT2,ISYM2, 264 * DEN1,DEN2(IPDA),DEN2(IPDB),ISYMDN,PVDEN, 265 * LORB,LCON, 266 * IGRSPI,ISPIN1,ISPIN2,IPERCD,WRK(KSCR)) 267 ELSE IF (IKLVL.EQ.3) THEN 268C 269C Transform left (~~| ) with k1,k2 270C 271 IH2SYM = MULD2H(ICDSYM,INTSYM) 272C 273C Transform left (~| ) with k1 274C 275 CALL DZERO(WRK(KH2),N2ORBX) 276 CALL OITH1(ISYM1,ZYMAT1,H2,WRK(KH2),IH2SYM) 277 INTSY1 = MULD2H(INTSYM,ISYM1) 278 IF (IPRFX.GT.300) THEN 279 WRITE(LUPRI,'(/A,I5)')'Left transform H2 of symmetry', 280 * IH2SYM 281 CALL OUTPUT(H2,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 282 WRITE(LUPRI,'(/A,I5)') 'with ZYMAT1 of symmetry',ISYM1 283 CALL OUTPUT(ZYMAT1,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 284 WRITE(LUPRI,'(/A)') 'to H2~ ' 285 CALL OUTPUT(WRK(KH2),1,NORBT,1,NORBT,NORBT,NORBT,1, 286 & LUPRI) 287 END IF 288 IH2SY1 = MULD2H(ICDSYM,INTSY1) 289C 290C Transform left (~~| ) with k2 291C 292 CALL DZERO(H2X,N2ORBX) 293 CALL OITH1(ISYM2,ZYMAT2,WRK(KH2),H2X,IH2SY1) 294 INTSY2 = MULD2H(INTSY1,ISYM2) 295 IF (IPRFX.GT.300) THEN 296 WRITE(LUPRI,'(/A,I5)') 297 * 'Left transform H2~ of symmetry',IH2SY1 298 CALL OUTPUT(WRK(KH2),1,NORBT,1,NORBT, 299 * NORBT,NORBT,1,LUPRI) 300 WRITE(LUPRI,'(/A,I5)') 301 * 'with ZYMAT2 of symmetry',ISYM2 302 CALL OUTPUT(ZYMAT2,1,NORBT,1,NORBT, 303 * NORBT,NORBT,1,LUPRI) 304 WRITE(LUPRI,'(/A)') 'to H2X' 305 CALL OUTPUT(H2X,1,NORBT,1,NORBT,NORBT,NORBT, 306 * 1,LUPRI) 307 END IF 308C 309C Transform left (~~~| ) with k3 310C 311 IF (ICDTYP.NE.JTSESE) THEN 312 IH2SY2 = MULD2H(ICDSYM,INTSY2) 313 CALL DZERO(WRK(KH2),N2ORBX) 314 CALL OITH1(ISYM3,ZYMAT3,H2X,WRK(KH2),IH2SY2) 315 INTSY3=MULD2H(INTSY2,ISYM3) 316 IF (IPRFX.GT.300) THEN 317 WRITE(LUPRI,'(/A,I5)') 318 * 'Left transform H2~~ of symmetry',IH2SY2 319 CALL OUTPUT(WRK(KH2),1,NORBT,1,NORBT, 320 * NORBT,NORBT,1,LUPRI) 321 WRITE(LUPRI,'(/A,I5)') 322 * 'with ZYMAT3 of symmetry',ISYM3 323 CALL OUTPUT(ZYMAT2,1,NORBT,1,NORBT, 324 * NORBT,NORBT,1,LUPRI) 325 WRITE(LUPRI,'(/A)') 'to H2~~~' 326 CALL OUTPUT(WRK(KH2),1,NORBT,1,NORBT,NORBT,NORBT, 327 * 1,LUPRI) 328 END IF 329 ISP12=MULSP(ISPIN1,ISPIN2) 330 ISP123=MULSP(ISP12,ISPIN3) 331 IF (ISP123.NE.IGRSPI) CALL QUIT('RSPFXD:SPIN ERROR') 332 IPDA = IPDENS(MULSP(IGRSPI,ISP123),0) 333 IPDB = IPDENS(ISP123,IGRSPI) 334 CALL GETAC1(WRK(KH2),WRK(KH2XAC)) 335 CALL FQDIS1(INTSY3,IC,ID,ICDTYP,ICDSYM,ICSYM,IDSYM, 336 * FI,FA,QA,QB,WRK(KH2),WRK(KH2XAC),H2AX, 337 * DEN1,DEN2(IPDA),DEN2(IPDB),ISYMDN,PVDEN, 338 * LORB,LCON, 339 * IGRSPI,ISP123,0,IPERCD) 340 END IF 341C 342C Transform right (~~|~) k1k2,k3 343C 344 ISP12=MULSP(ISPIN1,ISPIN2) 345 IPDA = IPDENS(MULSP(IGRSPI,ISP12),ISPIN3) 346 IPDB = IPDENS(ISP12,MULSP(IGRSPI,ISPIN3)) 347 CALL GETAC1(H2X,WRK(KH2XAC)) 348 CALL FQDIS2(INTSY2,IC,ID,ICDTYP,ICDSYM,ICSYM,IDSYM, 349 * FI,FA,QA,QB,H2X,WRK(KH2XAC),H2AX(1,2), 350 * ZYMAT3,ISYM3, 351 * DEN1,DEN2(IPDA),DEN2(IPDB),ISYMDN,PVDEN, 352 * LORB,LCON, 353 * IGRSPI,ISP12 ,ISPIN3,IPERCD,WRK(KSCR)) 354C 355C Transform (~~|~) k1k3,k2 356C 357C 358C Transform left (~| ) with k1 359C 360 CALL DZERO(WRK(KH2),N2ORBX) 361 CALL OITH1(ISYM1,ZYMAT1,H2,WRK(KH2),IH2SYM) 362 INTSY1 = MULD2H(INTSYM,ISYM1) 363 IF (IPRFX.GT.300) THEN 364 WRITE(LUPRI,'(/A,I5)')'Left transform H2 of symmetry', 365 * IH2SYM 366 CALL OUTPUT(H2,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 367 WRITE(LUPRI,'(/A,I5)') 'with ZYMAT1 of symmetry',ISYM1 368 CALL OUTPUT(ZYMAT1,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 369 WRITE(LUPRI,'(/A)') 'to H2~ ' 370 CALL OUTPUT(WRK(KH2),1,NORBT,1,NORBT,NORBT,NORBT,1, 371 & LUPRI) 372 END IF 373 IH2SY1 = MULD2H(ICDSYM,INTSY1) 374C 375C Transform left (~~| ) with k3 376C 377 CALL DZERO(H2X,N2ORBX) 378 CALL OITH1(ISYM3,ZYMAT3,WRK(KH2),H2X,IH2SY1) 379 INTSY2 = MULD2H(INTSY1,ISYM3) 380 IF (IPRFX.GT.300) THEN 381 WRITE(LUPRI,'(/A,I5)') 382 * 'Left transform H2~ of symmetry',IH2SY1 383 CALL OUTPUT(WRK(KH2),1,NORBT,1,NORBT, 384 * NORBT,NORBT,1,LUPRI) 385 WRITE(LUPRI,'(/A,I5)') 386 * 'with ZYMAT3 of symmetry',ISYM3 387 CALL OUTPUT(ZYMAT3,1,NORBT,1,NORBT, 388 * NORBT,NORBT,1,LUPRI) 389 WRITE(LUPRI,'(/A)') 'to H2X' 390 CALL OUTPUT(H2X,1,NORBT,1,NORBT,NORBT,NORBT, 391 * 1,LUPRI) 392 END IF 393C 394C Transform right (~~|~) k2 395C 396 ISP13=MULSP(ISPIN1,ISPIN3) 397 IPDA = IPDENS(MULSP(IGRSPI,ISP13),ISPIN2) 398 IPDB = IPDENS(ISP13,MULSP(IGRSPI,ISPIN2)) 399 CALL GETAC1(H2X,WRK(KH2XAC)) 400 CALL FQDIS2(INTSY2,IC,ID,ICDTYP,ICDSYM,ICSYM,IDSYM, 401 * FI,FA,QA,QB,H2X,WRK(KH2XAC),H2AX(1,3), 402 * ZYMAT2,ISYM2, 403 * DEN1,DEN2(IPDA),DEN2(IPDB),ISYMDN,PVDEN, 404 * LORB,LCON, 405 * IGRSPI,ISP13 ,ISPIN2,IPERCD,WRK(KSCR)) 406C 407C Transform (~~|~) k2k3,k1 408C 409C 410C Transform left (~| ) with k2 411C 412 CALL DZERO(WRK(KH2),N2ORBX) 413 CALL OITH1(ISYM2,ZYMAT2,H2,WRK(KH2),IH2SYM) 414 INTSY1 = MULD2H(INTSYM,ISYM2) 415 IF (IPRFX.GT.300) THEN 416 WRITE(LUPRI,'(/A,I5)')'Left transform H2 of symmetry', 417 * IH2SYM 418 CALL OUTPUT(H2,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 419 WRITE(LUPRI,'(/A,I5)') 'with ZYMAT2 of symmetry',ISYM2 420 CALL OUTPUT(ZYMAT2,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 421 WRITE(LUPRI,'(/A)') 'to H2~ ' 422 CALL OUTPUT(WRK(KH2),1,NORBT,1,NORBT,NORBT,NORBT,1, 423 & LUPRI) 424 END IF 425 IH2SY1 = MULD2H(ICDSYM,INTSY1) 426C 427C Transform left (~~| ) with k3 428C 429 CALL DZERO(H2X,N2ORBX) 430 CALL OITH1(ISYM3,ZYMAT3,WRK(KH2),H2X,IH2SY1) 431 INTSY2 = MULD2H(INTSY1,ISYM3) 432 IF (IPRFX.GT.300) THEN 433 WRITE(LUPRI,'(/A,I5)') 434 * 'Left transform H2~ of symmetry',IH2SY1 435 CALL OUTPUT(WRK(KH2),1,NORBT,1,NORBT, 436 * NORBT,NORBT,1,LUPRI) 437 WRITE(LUPRI,'(/A,I5)') 438 * 'with ZYMAT3 of symmetry',ISYM3 439 CALL OUTPUT(ZYMAT3,1,NORBT,1,NORBT, 440 * NORBT,NORBT,1,LUPRI) 441 WRITE(LUPRI,'(/A)') 'to H2X' 442 CALL OUTPUT(H2X,1,NORBT,1,NORBT,NORBT,NORBT, 443 * 1,LUPRI) 444 END IF 445C 446C Transform right (~~|~) k1 447C 448 ISP23=MULSP(ISPIN2,ISPIN3) 449 IPDA = IPDENS(MULSP(IGRSPI,ISP23),ISPIN1) 450 IPDB = IPDENS(ISP23,MULSP(IGRSPI,ISPIN1)) 451 CALL GETAC1(H2X,WRK(KH2XAC)) 452 CALL FQDIS2(INTSY2,IC,ID,ICDTYP,ICDSYM,ICSYM,IDSYM, 453 * FI,FA,QA,QB,H2X,WRK(KH2XAC),H2AX(1,4), 454 * ZYMAT1,ISYM1, 455 * DEN1,DEN2(IPDA),DEN2(IPDB),ISYMDN,PVDEN, 456 * LORB,LCON, 457 * IGRSPI,ISP23 ,ISPIN1,IPERCD,WRK(KSCR)) 458C END IF 459 ELSE 460 WRITE(LUPRI,'(/A)') ' WRONG VALUE OF IKLVL IN RSPFXD' 461 WRITE(LUPRI,'(/A,I5)') ' IKLVL =',IKLVL 462 CALL QUIT(' WRONG VALUE OF IKLVL IN RSPFXD') 463 END IF 464 ELSE 465 CALL QUIT( 466 & 'RSPFXD not implemented for pre-transformed integrals') 467 END IF 468C 469C all for now 470C 471C 472 IF( IPRFX .GT. 300 ) THEN 473 WRITE(LUPRI,'(/A)') ' PARTIAL MATRICES IN RSPFXD' 474 WRITE(LUPRI,'(A)') ' ===========================' 475 WRITE(LUPRI,'(//A)') ' Inactive fock matrix' 476 CALL OUTPUT(FI,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 477 WRITE(LUPRI,'(//A)') ' Active fock matrix' 478 CALL OUTPUT(FA,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 479 WRITE(LUPRI,'(//A)') ' Qa matrix' 480 CALL OUTPUT(QA,1,NORBT,1,NASHT,NORBT,NASHT,1,LUPRI) 481 WRITE(LUPRI,'(//A)') ' Qb matrix' 482 CALL OUTPUT(QB,1,NORBT,1,NASHT,NORBT,NASHT,1,LUPRI) 483 WRITE(LUPRI,'(/A)') ' Active two-electron integrals' 484 CALL PRIAC2(H2AX,NASHT,LUPRI) 485 IF (IKLVL.EQ.2) THEN 486 WRITE(LUPRI,'(/A)') ' Active two-electron integrals' 487 CALL PRIAC2(H2AX(1,2),NASHT,LUPRI) 488 END IF 489 END IF 490C 491C 492C We have now completed processing this load, so get the next 493C 494 GO TO 1000 4952000 CONTINUE 496C 497C Account for 1/2 in definition of two-electron integrals 498C 499C and for the fact that we calculated 2 times FA 500C 501 IF (IKLVL.EQ.0) THEN 502 CALL DAXPY(N2ORBX,DH,WRK(KFI),1,FI,1) 503 IF (NASHT.GT.0) CALL DSCAL(N2ORBX,DH*DH,FA,1) 504 CALL DSCAL(NORBT*NASHT,DH,QA,1) 505 CALL DSCAL(NORBT*NASHT,DH,QB,1) 506 ELSE 507 IF (NASHT.GT.0) CALL DSCAL(NORBT*NORBT,DH,FA,1) 508 END IF 509C 510C Set DISTYP for the cases we may have ci-gradients 511C 512 IF (IKLVL.EQ.0) THEN 513 INFDIS(1) = 9 514 INFDIS(2) = 10 515 END IF 516 IF (IKLVL.EQ.1) THEN 517 INFDIS(1) = 15 518 INFDIS(2) = 16 519 END IF 520 IF (IKLVL.EQ.2) THEN 521 INFDIS(1) = 11 522 INFDIS(2) = 12 523 END IF 524 IF (IKLVL.EQ.3) THEN 525 INFDIS(1) = 27 526 INFDIS(2) = 28 527 END IF 528 IF (IPRFX.GT.200) THEN 529 WRITE(LUPRI,'(/A)') ' Completed matrices in RSPFXD' 530 WRITE(LUPRI,'(/A)') ' Inactive Fock matrix' 531 CALL OUTPUT(FI,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 532 WRITE(LUPRI,'(/A)') ' Active Fock matrix' 533 CALL OUTPUT(FA,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 534 WRITE(LUPRI,'(/A)') ' QA matrix' 535 CALL OUTPUT(QA,1,NORBT,1,NASHT,NORBT,NASHT,1,LUPRI) 536 WRITE(LUPRI,'(/A)') ' QB matrix' 537 CALL OUTPUT(QB,1,NORBT,1,NASHT,NORBT,NASHT,1,LUPRI) 538 WRITE(LUPRI,'(/A)') ' Active two-electron integrals' 539 CALL PRIAC2(H2AX,NASHT,LUPRI) 540 IF (IKLVL.EQ.2) THEN 541 WRITE(LUPRI,'(/A)') ' Active two-electron integrals' 542 CALL PRIAC2(H2AX(1,2),NASHT,LUPRI) 543 END IF 544 END IF 545c 546 CALL MEMREL('RSPFXD',WRK,KFIRST,KFIRST,KWRK,LWRK) 547 CALL QEXIT('RSPFXD') 548 RETURN 549 END 550C /* Deck fqdis1 */ 551 SUBROUTINE FQDIS1(INTSYM,IC,ID,ICDTYP,ICDSYM,ICSYM,IDSYM, 552 * FI,FA,QA,QB,H2X,H2XAC,H2ACAC, 553 * DEN1,DEN2A,DEN2B,ISYMDN,PVDEN, 554 * LORB,LCON, 555 * IGRSPI,ISPIN1,ISPIN2,IPERCD) 556C 557C Olav Vahtras 558C Dec 9 1991 559C 560#include "implicit.h" 561#include "maxorb.h" 562#include "maxash.h" 563#include "priunit.h" 564#include "inforb.h" 565#include "infind.h" 566#include "infdim.h" 567#include "infrsp.h" 568#include "infpri.h" 569#include "orbtypdef.h" 570#include "rspprp.h" 571#include "infhyp.h" 572#include "infspi.h" 573 LOGICAL LORB,LCON 574 DIMENSION FI(*),FA(*),QA(*),QB(*),H2X(*),H2XAC(*),H2ACAC(*) 575 DIMENSION DEN1(*),DEN2A(*),DEN2B(*),PVDEN(*) 576C 577 PARAMETER(DM1 = -1.0D0) 578C 579 CALL QENTER('FQDIS1') 580 CALL FIXAD1(INTSYM,IC,ID,ICDTYP,ICDSYM,ICSYM,IDSYM, 581 * FI,H2X,ISPIN1,ISPIN2) 582 IF (NASHT.GT.0 .AND. LORB) THEN 583 CALL FAXAD1(INTSYM,IC,ID,ICDTYP,ICDSYM,ICSYM,IDSYM, 584 * DEN1,ISYMDN,FA,H2X,IGRSPI,ISPIN1,ISPIN2,H2XAC) 585 CALL QXAD1(INTSYM,IC,ID,ICDTYP, 586 * ICDSYM,ICSYM,IDSYM,QA,QB, H2X, 587 * DEN2A,DEN2B,ISYMDN,PVDEN,H2XAC) 588 END IF 589 IF (LCON) THEN 590 CALL DISAC1(IC,ID,H2XAC,H2ACAC) 591 END IF 592 IF (IC.NE.ID .AND. IPERCD.NE.0) THEN 593 IF (IPERCD.EQ.1) THEN 594C nothing 595 ELSEIF (IPERCD.EQ.-1) THEN 596 CALL DSCAL(N2ORBX,DM1,H2X,1) 597 CALL DSCAL(N2ASHX,DM1,H2XAC,1) 598 ELSE 599 WRITE(LUPRI,'(/A)') ' FQDIS1: WRONG VALUE OF IPERCD',IPERCD 600 WRITE(LUPRI,'(/A)') ' ALLOWED IPERCD = 1 0 -1' 601 CALL QUIT('FQDIS1: WRONG VALUE OF IPERCD') 602 END IF 603 CALL FIXAD1(INTSYM,ID,IC,ICDTYP,ICDSYM,IDSYM,ICSYM, 604 * FI,H2X,ISPIN1,ISPIN2) 605 IF (NASHT.GT.0 .AND. LORB) THEN 606 CALL FAXAD1(INTSYM,ID,IC,ICDTYP,ICDSYM,IDSYM,ICSYM, 607 * DEN1,ISYMDN,FA,H2X,IGRSPI,ISPIN1,ISPIN2, 608 * H2XAC) 609 CALL QXAD1(INTSYM,ID,IC,ICDTYP, 610 * ICDSYM,IDSYM,ICSYM,QA,QB, H2X, 611 * DEN2A,DEN2B,ISYMDN,PVDEN,H2XAC) 612 END IF 613 IF (LCON) THEN 614 CALL DISAC1(ID,IC,H2XAC,H2ACAC) 615 END IF 616 IF (IPERCD.EQ.-1) THEN 617 CALL DSCAL(N2ORBX,DM1,H2X,1) 618 CALL DSCAL(N2ASHX,DM1,H2XAC,1) 619 END IF 620 END IF 621 CALL QEXIT('FQDIS1') 622 RETURN 623 END 624C /* Deck fqdis2 */ 625 SUBROUTINE FQDIS2(INTSYM,IC,ID,ICDTYP,ICDSYM,ICSYM,IDSYM, 626 * FI,FA,QA,QB,H2X,H2XAC,H2ACAC, 627 * ZYMAT,IZYSYM, 628 * DEN1,DEN2A,DEN2B,ISYMDN,PVDEN, 629 * LORB,LCON, 630 * IGRSPI,ISPIN1,ISPIN2,IPERCD,SCR) 631C 632C Olav Vahtras 633C Dec 9 1991 634C 635#include "implicit.h" 636#include "maxorb.h" 637#include "maxash.h" 638#include "priunit.h" 639#include "inforb.h" 640#include "infind.h" 641#include "infdim.h" 642#include "infrsp.h" 643#include "infpri.h" 644#include "orbtypdef.h" 645#include "rspprp.h" 646#include "infhyp.h" 647#include "infspi.h" 648 LOGICAL LORB,LCON 649 DIMENSION FI(*),FA(*),QA(*),QB(*) 650 DIMENSION H2X(*),H2XAC(*),H2ACAC(*),ZYMAT(*) 651 DIMENSION DEN1(*),DEN2A(*),DEN2B(*),PVDEN(*) 652 DIMENSION SCR(*) 653C 654 PARAMETER(DM1 = -1.0D0) 655C 656 CALL QENTER('FQDIS2') 657 ICTYP = IOBTYP(IC) 658 IDTYP = IOBTYP(ID) 659 CALL FIXAD2(INTSYM,IC,ID,ICDTYP,ICTYP,IDTYP, 660 * ICDSYM,ICSYM,IDSYM, 661 * FI,H2X,ISPIN1,ISPIN2,ZYMAT,IZYSYM) 662 IF (NASHT.GT.0 .AND. LORB) THEN 663 CALL FAXAD2(INTSYM,IC,ID,ICDTYP,ICTYP,IDTYP, 664 * ICDSYM,ICSYM,IDSYM, 665 * DEN1,ISYMDN,FA,H2X,IGRSPI,ISPIN1,ISPIN2, 666 * ZYMAT,IZYSYM, 667 * H2XAC,SCR) 668 CALL QXAD2(INTSYM,IC,ID,ICDTYP, 669 * ICDSYM,ICSYM,IDSYM,QA,QB, H2X,DEN2A,DEN2B, 670 * ISYMDN,PVDEN, 671 * H2XAC,SCR,ZYMAT,IZYSYM) 672 END IF 673 IF (LCON) THEN 674 CALL DISAC2(IC,ID,H2XAC,H2ACAC,ZYMAT,IZYSYM) 675 END IF 676 IF (IC.NE.ID .AND. IPERCD.NE.0) THEN 677 IF (IPERCD.EQ.1) THEN 678C nothing 679 ELSEIF (IPERCD.EQ.-1) THEN 680 CALL DSCAL(N2ORBX,DM1,H2X,1) 681 CALL DSCAL(N2ASHX,DM1,H2XAC,1) 682 ELSE 683 WRITE(LUPRI,'(/A)') ' FQDIS2: WRONG VALUE OF IPERCD',IPERCD 684 WRITE(LUPRI,'(/A)') ' ALLOWED IPERCD = 1 0 -1' 685 CALL QUIT('FQDIS2: WRONG VALUE OF IPERCD') 686 END IF 687 CALL FIXAD2(INTSYM,ID,IC,ICDTYP,IDTYP,ICTYP, 688 * ICDSYM,IDSYM,ICSYM, 689 * FI,H2X,ISPIN1,ISPIN2,ZYMAT,IZYSYM) 690 IF (NASHT.GT.0 .AND. LORB) THEN 691 CALL FAXAD2(INTSYM,ID,IC,ICDTYP,IDTYP,ICTYP, 692 * ICDSYM,IDSYM,ICSYM, 693 * DEN1,ISYMDN,FA,H2X,IGRSPI,ISPIN1,ISPIN2, 694 * ZYMAT,IZYSYM, 695 * H2XAC,SCR) 696 CALL QXAD2(INTSYM,ID,IC,ICDTYP, 697 * ICDSYM,IDSYM,ICSYM,QA,QB, H2X,DEN2A,DEN2B, 698 * ISYMDN,PVDEN, 699 * H2XAC,SCR,ZYMAT,IZYSYM) 700 END IF 701 IF (LCON) THEN 702 CALL DISAC2(ID,IC,H2XAC,H2ACAC,ZYMAT,IZYSYM) 703 END IF 704 IF (IPERCD.EQ.-1) THEN 705 CALL DSCAL(N2ORBX,DM1,H2X,1) 706 CALL DSCAL(N2ASHX,DM1,H2XAC,1) 707 END IF 708 END IF 709 CALL QEXIT('FQDIS2') 710 RETURN 711 END 712C /* Deck fixad1 */ 713 SUBROUTINE FIXAD1(INTSYM,IC,ID,ICDTYP,ICDSYM,ICSYM,IDSYM, 714 * FI,H2X,ISPIN1,ISPIN2) 715C 716C 717C Olav Vahtras 718C 719C Add contribution presently in H2X to the inactive Fock matrix. 720C 721C F(p,q) = (1+S1)(kk|pq) + (1+S2)(pq|kk) + (pk|kq) + (kq|pq) 722C 723C Convention used in this routine: Distribution CD is the matrix 724C HCD(A,B)=(AB|CD) 725C 726C Case 1a) 727C F(p,q) = F(p,q) + (1+S1) (j j|p q) 728C F(C,D) = F(C,D) + (1+S1) (j j|C D) 729C 730C Case 1b) 731C F(p,q) = F(p,q) + (1+S2) (p q|j j) C=D=inactive 732C F(p,q) = F(p,q) + (1+S2) (p q|C D) 733C 734C Case 2) 735C F(p,q) = F(p,q) - (pj|jq) C inactive 736C F(p,D) = F(p,D) - (pC|CD) 737C 738C Case 3) 739C F(p,q) = F(p,q) - (j q|p j) D inactive 740C F(C,q) = F(C,q) - (D q|C D) 741C 742#include "implicit.h" 743C 744 PARAMETER ( D0 = 0.0D0, D2= 2.0D0, DM1 = -1.0D0 ) 745C 746#include "dftcom.h" 747#include "maxorb.h" 748#include "maxash.h" 749#include "priunit.h" 750#include "wrkrsp.h" 751#include "infrsp.h" 752#include "rspprp.h" 753#include "infhyp.h" 754#include "infdim.h" 755#include "infind.h" 756#include "inforb.h" 757#include "infpri.h" 758#include "infspi.h" 759C 760 DIMENSION FI(NORBT,NORBT), H2X(NORBT,NORBT) 761 CALL QENTER('FIXAD1') 762 IF (ICDTYP.EQ.JTSESE) GOTO 999 763C 764 IF (IPRRSP.GT.300) THEN 765 WRITE(LUPRI,'(/A)') 'ENTRE FIXAD1' 766 WRITE(LUPRI,'(A,I5)') 'INTSYM =',INTSYM 767 WRITE(LUPRI,'(A,2I5)') 'IC ID =',IC,ID 768 WRITE(LUPRI,'(A,I5)') 'ICDTYP =',ICDTYP 769 WRITE(LUPRI,'(A,I5)') 'ICDSYM =',ICDSYM 770 WRITE(LUPRI,'(A,I5)') 'ICSYM =',ICSYM 771 WRITE(LUPRI,'(A,I5)') 'IDSYM =',IDSYM 772 WRITE(LUPRI,'(A,I5)') 'ISPIN1 =',ISPIN1 773 WRITE(LUPRI,'(A,I5)') 'ISPIN2 =',ISPIN2 774 WRITE(LUPRI,'(A)') 'FI' 775 CALL OUTPUT(FI,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 776 WRITE(LUPRI,'(A)') 'H2X' 777 CALL OUTPUT(H2X,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 778 END IF 779 ICTYP = IOBTYP(IC) 780 IDTYP = IOBTYP(ID) 781C 782C 783C Process case 1a) : all distributions 784C 785C F(p,q) = F(p,q) + (1+S1) (j j|p q) 786C F(C,D) = F(C,D) + (1+S1) (j j|C D) 787C 788 IF (ISPIN1.NE.1) THEN 789 DO 10 I=1,NISHT 790 IX=ISX(I) 791 FI(IC,ID) = FI(IC,ID) + D2*H2X(IX,IX) 79210 CONTINUE 793 IF (IPRRSP.GT.300) THEN 794 WRITE(LUPRI,'(/A)') 'FIXAD1: FI after case 1b)' 795 CALL OUTPUT(FI,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 796 END IF 797 END IF 798C 799C Process case 1b) inactive - inactive distributions coulomb part 800C 801C F(p,q) = F(p,q) + (1+S2) (p q|j j) 802C F(p,q) = F(p,q) + (1+S2) (p q|C D) 803C 804 IF (( IC .EQ. ID) .AND. (ICDTYP .EQ. JTININ) .AND. (ISPIN2.NE.1)) 805 *THEN 806 CALL DAXPY(NORBT*NORBT,D2,H2X,1,FI,1) 807 IF (IPRRSP.GT.300) THEN 808 WRITE(LUPRI,'(/A)') 'FIXAD1: FI after case 1a)' 809 CALL OUTPUT(FI,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 810 END IF 811 END IF 812C 813C Now process all exchange contributions 814C 815C Process case 2) : inactive - general distribution 816C 817C F(p,q) = F(p,q) - (pj|jq) 818C F(p,D) = F(p,D) - (pC|CD) 819C 820 IF (ICTYP.EQ.JTINAC .AND. HFXFAC.NE.D0) THEN 821 IPSYM = MULD2H(IDSYM,INTSYM) 822 IF (IDTYP.EQ.JTSEC) THEN 823 NORBP = NOCC(IPSYM) 824 ELSE 825 NORBP = NORB(IPSYM) 826 END IF 827 IPST = IORB(IPSYM) + 1 828 IF(NORBP .GT. 0) THEN 829 CALL DAXPY(NORBP,-HFXFAC,H2X(IPST,IC),1, 830 * FI(IPST,ID),1) 831 IF (IPRRSP.GT.300) THEN 832 WRITE(LUPRI,'(/A)') 'FIXAD1: FI after case 3)' 833 CALL OUTPUT(FI,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 834 END IF 835 END IF 836 END IF 837C 838C Process case 3) : general - inactive distribution 839C 840C F(p,q) = F(p,q) - (j q|p j) 841C F(C,q) = F(C,q) - (D q|C D) 842C 843 IF (IDTYP.EQ.JTINAC .AND. HFXFAC.NE.D0) THEN 844 IQSYM = MULD2H(ICSYM,INTSYM) 845 IF (ICTYP.EQ.JTSEC) THEN 846 NORBQ = NOCC(IQSYM) 847 ELSE 848 NORBQ = NORB(IQSYM) 849 END IF 850 IQST = IORB(IQSYM) + 1 851 IF( NORBQ .GT. 0) THEN 852 CALL DAXPY(NORBQ,-HFXFAC,H2X(ID,IQST),NORBT, 853 * FI(IC,IQST),NORBT) 854 IF (IPRRSP.GT.300) THEN 855 WRITE(LUPRI,'(/A)') 'FIXAD1: FI after case 2)' 856 CALL OUTPUT(FI,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 857 END IF 858 END IF 859 END IF 860999 CALL QEXIT('FIXAD1') 861 RETURN 862 END 863C /* Deck fixad2 */ 864 SUBROUTINE FIXAD2(INTSYM,IC,ID,ICDTYP,ICTYP,IDTYP, 865 * ICDSYM,ICSYM,IDSYM, 866 * FI,H2X,ISPIN1,ISPIN2,ZYMAT,IZYSYM) 867C 868C Olav Vahtras 869C Nov 22 1991 870C 871C Purpose: One-index transform the right-hand side of (AB|CD) 872C i.e. (AB|CD) -> (AB|C~D) 873C and distribute in the inactive Fock matrix 874C Convention used in this routine: Distribution CD is the matrix 875C HCD(A,B)=(AB|CD) 876C 877C Expression: 878C 879C F(p,q) = (1+S1)(kk|p~q) + (1+S2)(pq|k~k) - (pk|k~q) - (kq|p~k) 880C 881C 1) (kk|p~q) = ZYMAT(p,r)(kk|rq) - (kk|pr)ZYMAT(r,q) 882C 883C Conditions: S1 = +, ICDSYM = INTSYM 884C 885C 1a) - 2(kk|pr)ZYMAT(r,q) -> F(p,q) 886C - 2(kk|CD)ZYMAT(D,q) -> F(C,q) 887C 888C Restrictions: IQSYM=IFCKSY X ICSYM 889C 890C 1b) 2*ZYMAT(p,r)(kk|rq) -> F(p,q) 891C 2*ZYMAT(p,C)(kk|CD) -> F(p,D) 892C 893C Restrictions: IPSYM=IFCKSY X IDSYM 894C 895C 2) (pq|k~k) = ZYMAT(k,r)(pq|rk) - (pq|rk)ZYMAT(k,r) 896C 897C Conditions: S2 = + 898C ICDTYP not inactive-inactive or secondary-secondary 899C 900C 2a) 2*ZYMAT(k,r)(pq|rk) -> F(p,q) 901C 2*ZYMAT(D,C)(pq|CD) -> F(p,q) D Inactive 902C 903C 2b) -2*(pq|rk)ZYMAT(k,r) -> F(p,q) 904C -2*(pq|CD)ZYMAT(D,C) -> F(p,q) C Inactive 905C 906C 3) -(pk|k~q) = (pk|kr)ZYMAT(r,q) - ZYMAT(k,r)(pk|rq) 907C 908C 3a) (pk|kr)ZYMAT(r,q) -> F(p,q) 909C (pC|CD)ZYMAT(D,q) -> F(p,q) C Inactive 910C 911C Restrictions: IPSYM=IDSYM X INTSYM 912C IQSYM=IDSYM X IZYSYM 913C 914C 3b) -ZYMAT(k,r)(pk|rq) -> F(p,q) 915C -ZYMAT(k,C)(pk|CD) -> F(p,D) C not inactive 916C 917C Restrictions: IPSYM=IDSYM X IFCKSY 918C IKSYM=ICSYM X IZYSYM 919C 920C 4) -(kq|p~k) = (kq|pr)ZYMAT(r,k) - ZYMAT(p,r)(kq|rk) 921C 922C 4a) (kq|pr)ZYMAT(r,k) -> F(p,q) 923C (kq|CD)ZYMAT(D,k) -> F(C,q) D not inactive 924C 925C Restrictions: IQSYM = ICSYM X IFCKSY 926C IKSYM = IDSYM X IZYSYM 927C 928C 4b) -ZYMAT(p,r)(kq|rk) -> F(p,q) 929C -ZYMAT(p,C)(Dq|CD) -> F(p,q) D inactive 930C 931C Restrictions: IPSYM = ICSYM X IZYSYM 932C IQSYM = ICSYM X INTSYM 933C 934C 935#include "implicit.h" 936C 937 PARAMETER ( D0 = 0.0D0, D2 = 2.0D0, DM1 = -1.0D0 ) 938C 939#include "maxorb.h" 940#include "maxash.h" 941#include "priunit.h" 942#include "wrkrsp.h" 943#include "infrsp.h" 944#include "rspprp.h" 945#include "infhyp.h" 946#include "infdim.h" 947#include "infind.h" 948#include "inforb.h" 949#include "infpri.h" 950#include "infspi.h" 951#include "dftcom.h" 952C 953 DIMENSION FI(NORBT,NORBT), H2X(NORBT,NORBT) 954 DIMENSION ZYMAT(NORBT,NORBT) 955 CALL QENTER('FIXAD2') 956C 957 IFCKSY = MULD2H(INTSYM,IZYSYM) 958 IF (IPRRSP.GT.300) THEN 959 WRITE(LUPRI,'(/A)') 'ENTRE FIXAD2' 960 WRITE(LUPRI,'(A,I5)') 'INTSYM =',INTSYM 961 WRITE(LUPRI,'(A,2I5)') 'IC ID =',IC,ID 962 WRITE(LUPRI,'(A,I5)') 'ICDTYP =',ICDTYP 963 WRITE(LUPRI,'(A,I5)') 'ICDSYM =',ICDSYM 964 WRITE(LUPRI,'(A,I5)') 'ICSYM =',ICSYM 965 WRITE(LUPRI,'(A,I5)') 'IDSYM =',IDSYM 966 WRITE(LUPRI,'(A,I5)') 'ISPIN1 =',ISPIN1 967 WRITE(LUPRI,'(A,I5)') 'ISPIN2 =',ISPIN2 968 WRITE(LUPRI,'(A,I5)') 'IZYSYM =',IZYSYM 969 WRITE(LUPRI,'(A)') 'FI' 970 CALL OUTPUT(FI,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 971 WRITE(LUPRI,'(A)') 'H2X' 972 CALL OUTPUT(H2X,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 973 WRITE(LUPRI,'(A)') 'ZYMAT' 974 CALL OUTPUT(ZYMAT,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 975 END IF 976C 977C Case 1) 978C 979 IF (ISPIN1.EQ.0 .AND. ICDSYM.EQ.INTSYM) THEN 980C 981C Evaluate inactive trace 982C 983 DTRACE = D0 984 DO 10 I=1,NISHT 985 IX=ISX(I) 986 DTRACE = DTRACE + H2X(IX,IX) 98710 CONTINUE 988 DTRACE = D2*DTRACE 989C 990C Case 1a) 991C 1a) - 2(kk|pr)ZYMAT(r,q) -> F(p,q) 992C - 2(kk|CD)ZYMAT(D,q) -> F(C,q) 993C 994 IQSYM = MULD2H(IFCKSY,ICSYM) 995 NORBQ = NORB(IQSYM) 996 IF (NORBQ .GT. 0) THEN 997 IQST = IORB(IQSYM) + 1 998 CALL DAXPY(NORBQ,-DTRACE,ZYMAT(ID,IQST),NORBT, 999 * FI(IC,IQST),NORBT) 1000 IF (IPRRSP.GT.300) THEN 1001 WRITE(LUPRI,'(/A)') 'FIXAD2:FI after case 1a' 1002 CALL OUTPUT (FI,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 1003 END IF 1004 END IF 1005C 1006C Case 1b) 1007C 2*ZYMAT(p,r)(kk|rq) -> F(p,q) 1008C 2*ZYMAT(p,C)(kk|CD) -> F(p,D) 1009C 1010 IPSYM=MULD2H(IFCKSY,IDSYM) 1011 NORBP=NORB(IPSYM) 1012 IF (NORBP .GT. 0) THEN 1013 IPST=IORB(IPSYM)+1 1014 CALL DAXPY(NORBP,DTRACE,ZYMAT(IPST,IC),1,FI(IPST,ID),1) 1015 IF (IPRRSP.GT.300) THEN 1016 WRITE(LUPRI,'(/A)') 'FIXAD2:FI after case 1b' 1017 CALL OUTPUT (FI,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 1018 END IF 1019 END IF 1020 END IF 1021C 1022C Case 2) 1023C 1024 IF (ISPIN2.EQ.0 .AND. ICDSYM.EQ.IZYSYM 1025 * .AND. ICDTYP.NE.JTININ .AND. ICDTYP.NE.JTSESE) THEN 1026C 1027C Case 2a) 1028C 2*ZYMAT(k,r)(pq|rk) -> F(p,q) 1029C 2*ZYMAT(D,C)(pq|CD) -> F(p,q) D Inactive 1030C 1031 ZYDC=2*ZYMAT(ID,IC) 1032 IF (IDTYP.EQ.JTINAC) THEN 1033 CALL DAXPY(N2ORBX,ZYDC,H2X,1,FI,1) 1034 IF (IPRRSP.GT.300) THEN 1035 WRITE(LUPRI,'(/A)') 'FIXAD2:FI after case 2a' 1036 CALL OUTPUT (FI,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 1037 END IF 1038 END IF 1039C 1040C Case 2b) 1041C -2*(pq|rk)ZYMAT(k,r) -> F(p,q) 1042C -2*(pq|CD)ZYMAT(D,C) -> F(p,q) C Inactive 1043C 1044 IF (ICTYP.EQ.JTINAC) THEN 1045 CALL DAXPY(N2ORBX,-ZYDC,H2X,1,FI,1) 1046 IF (IPRRSP.GT.300) THEN 1047 WRITE(LUPRI,'(/A)') 'FIXAD2:FI after case 2b' 1048 CALL OUTPUT (FI,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 1049 END IF 1050 END IF 1051 END IF 1052C 1053C Case 3) 1054C 1055 IF (HFXFAC.NE.D0) THEN 1056 IF (ICTYP.EQ.JTINAC) THEN 1057C 1058C Case 3a) 1059C (pk|kr)ZYMAT(r,q) -> F(p,q) 1060C (pC|CD)ZYMAT(D,q) -> F(p,q) C Inactive 1061C 1062 IPSYM=MULD2H(INTSYM,IDSYM) 1063 IQSYM=MULD2H(IZYSYM,IDSYM) 1064 NORBP=NORB(IPSYM) 1065 NORBQ=NORB(IQSYM) 1066 IF (NORBP .GT. 0 .AND. NORBQ .GT. 0) THEN 1067 IPST=IORB(IPSYM)+1 1068 IQST=IORB(IQSYM)+1 1069 CALL DGEMM('N','N',NORBP,NORBQ,1,HFXFAC, 1070 & H2X(IPST,IC),NORBT, 1071 & ZYMAT(ID,IQST),NORBT,1.D0, 1072 & FI(IPST,IQST),NORBT) 1073 IF (IPRRSP.GT.300) THEN 1074 WRITE(LUPRI,'(/A)') 'FIXAD2:FI after case 3a' 1075 CALL OUTPUT (FI,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 1076 END IF 1077 END IF 1078 ELSE 1079C 1080C Case 3b) 1081C -ZYMAT(k,r)(pk|rq) -> F(p,q) 1082C -ZYMAT(k,C)(pk|CD) -> F(p,D) C not inactive 1083C 1084 IPSYM=MULD2H(IFCKSY,IDSYM) 1085 IKSYM=MULD2H(IZYSYM,ICSYM) 1086 NORBP=NORB(IPSYM) 1087 NISHK=NISH(IKSYM) 1088 IF (NORBP .GT. 0 .AND. NISHK .GT. 0) THEN 1089 IPST=IORB(IPSYM)+1 1090 IKST=IORB(IKSYM)+1 1091 CALL DGEMM('N','N',NORBP,1,NISHK,-HFXFAC, 1092 & H2X(IPST,IKST),NORBT, 1093 & ZYMAT(IKST,IC),NORBT,1.D0, 1094 & FI(IPST,ID),NORBT) 1095 IF (IPRRSP.GT.300) THEN 1096 WRITE(LUPRI,'(/A)') 'FIXAD2:FI after case 3b' 1097 CALL OUTPUT (FI,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 1098 END IF 1099 END IF 1100 END IF 1101C 1102C Case 4) 1103C 1104 IF (IDTYP.EQ.JTINAC) THEN 1105C 1106C Case 4b) 1107C -ZYMAT(p,r)(kq|rk) -> F(p,q) 1108C -ZYMAT(p,C)(Dq|CD) -> F(p,q) D inactive 1109C 1110 IPSYM=MULD2H(IZYSYM,ICSYM) 1111 IQSYM=MULD2H(INTSYM,ICSYM) 1112 NORBP=NORB(IPSYM) 1113 NORBQ=NORB(IQSYM) 1114 IF (NORBP .GT. 0 .AND. NORBQ .GT. 0) THEN 1115 IPST=IORB(IPSYM)+1 1116 IQST=IORB(IQSYM)+1 1117 CALL DGEMM('N','N',NORBP,NORBQ,1,-HFXFAC, 1118 & ZYMAT(IPST,IC),NORBT, 1119 & H2X(ID,IQST),NORBT,1.D0, 1120 & FI(IPST,IQST),NORBT) 1121 IF (IPRRSP.GT.300) THEN 1122 WRITE(LUPRI,'(/A)') 'FIXAD2:FI after case 4b' 1123 CALL OUTPUT (FI,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 1124 END IF 1125 END IF 1126C 1127C Case 4a) 1128C (kq|pr)ZYMAT(r,k) -> F(p,q) 1129C (kq|CD)ZYMAT(D,k) -> F(C,q) D not inactive 1130C 1131 ELSE 1132 IKSYM=MULD2H(IZYSYM,IDSYM) 1133 IQSYM=MULD2H(IFCKSY,ICSYM) 1134 NISHK=NISH(IKSYM) 1135 NORBQ=NORB(IQSYM) 1136 IF (NISHK .GT. 0 .AND. NORBQ .GT. 0) THEN 1137 IKST=IORB(IKSYM)+1 1138 IQST=IORB(IQSYM)+1 1139 CALL DGEMM('N','N',1,NORBQ,NISHK,HFXFAC, 1140 & ZYMAT(ID,IKST),NORBT, 1141 & H2X(IKST,IQST),NORBT,1.D0, 1142 & FI(IC,IQST),NORBT) 1143 IF (IPRRSP.GT.300) THEN 1144 WRITE(LUPRI,'(/A)') 'FIXAD2:FI after case 4a' 1145 CALL OUTPUT (FI,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 1146 END IF 1147 END IF 1148 END IF 1149 END IF ! if (hfxfac.ne.0.0d0) 1150 CALL QEXIT('FIXAD2') 1151 RETURN 1152 END 1153C /* Deck faxad1 */ 1154 SUBROUTINE FAXAD1(INTSYM,IC,ID,ICDTYP,ICDSYM,ICSYM,IDSYM, 1155 * DEN1,IDENSY,FA,H2X,IGRSPI,ISPIN1,ISPIN2,H2XAC) 1156C 1157C Add contribution presently in H2X to the active Fock matrix. 1158C 1159C 1160C F(p,q) = [(1+S1Sa)(pq|xy) + (1+S2Sa)(xy|pq) - (py|xq) - (xq|py)]D(x,y) 1161C 1162C Convention used in this routine: Distribution CD is the matrix 1163C HCD(A,B)=(AB|CD) 1164C Case 1a) 1165C F(p,q) = F(p,q) + (1+S1Sa) (p q|x y) D(x,y) C,D active 1166C F(p,q) = F(p,q) + (1+S1Sa) (p q|C D) D(C,D) 1167C 1168C Case 1b) 1169C F(p,q) = F(p,q) + (1+S2Sa) (x y|p q) D(x,y) 1170C F(C,D) = F(C,D) + (1+S2Sa) (x y|C D) D(x,y) 1171C 1172C Case 2) 1173C F(p,q) = F(p,q) - (py|xq) D(x,y) C active 1174C F(p,D) = F(p,D) - (py|CD) D(C,y) 1175C 1176C Case 3) 1177C F(p,q) = F(p,q) - (x q|p y) D(x,y) D active 1178C F(C,q) = F(C,q) - (x q|C D) D(x,D) 1179C 1180#include "implicit.h" 1181C 1182 PARAMETER ( D0 = 0.0D0, D2= 2.0D0, DM1 = -1.0D0 , DMH = -.5D0) 1183C 1184#include "maxorb.h" 1185#include "maxash.h" 1186#include "priunit.h" 1187#include "wrkrsp.h" 1188#include "infrsp.h" 1189#include "rspprp.h" 1190#include "infhyp.h" 1191#include "infdim.h" 1192#include "infind.h" 1193#include "inforb.h" 1194#include "infpri.h" 1195#include "infspi.h" 1196C 1197 DIMENSION DEN1(NASHT,NASHT),FA(NORBT,NORBT), H2X(NORBT,NORBT) 1198 DIMENSION H2XAC(NASHT,NASHT) 1199C LOGICAL NATORB 1200C 1201 IF (ICDTYP.EQ.JTSESE) RETURN 1202 CALL QENTER('FAXAD1') 1203 IFCKSY = MULD2H(INTSYM,IDENSY) 1204 ICTYP = IOBTYP(IC) 1205 IDTYP = IOBTYP(ID) 1206 ICW = ISW( IC ) 1207 IDW = ISW( ID ) 1208 NCW = ICW - NISHT 1209 NDW = IDW - NISHT 1210 ISP1A = MULSP(ISPIN1,IGRSPI) 1211 ISP2A = MULSP(ISPIN2,IGRSPI) 1212 IF (IPRRSP.GT.300) THEN 1213 WRITE(LUPRI,'(/A)') 'ENTRE FAXAD1' 1214 WRITE(LUPRI,'(A,I5)') 'INTSYM =',INTSYM 1215 WRITE(LUPRI,'(A,I5)') 'IDENSY =',IDENSY 1216 WRITE(LUPRI,'(A,2I5)') 'IC ID =',IC,ID 1217 WRITE(LUPRI,'(A,I5)') 'ICDTYP =',ICDTYP 1218 WRITE(LUPRI,'(A,I5)') 'ICDSYM =',ICDSYM 1219 WRITE(LUPRI,'(A,I5)') 'ICSYM =',ICSYM 1220 WRITE(LUPRI,'(A,I5)') 'IDSYM =',IDSYM 1221 WRITE(LUPRI,'(A,I5)') 'IGRSPI =',IGRSPI 1222 WRITE(LUPRI,'(A,I5)') 'ISPIN1 =',ISPIN1 1223 WRITE(LUPRI,'(A,I5)') 'ISPIN2 =',ISPIN2 1224C WRITE(LUPRI,'(A,L5)') 'NATORB =',NATORB 1225 WRITE(LUPRI,'(A)') 'FA' 1226 CALL OUTPUT(FA,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 1227 WRITE(LUPRI,'(A)') 'DEN1' 1228 CALL OUTPUT(DEN1,1,NASHT,1,NASHT,NASHT,NASHT,1,LUPRI) 1229 WRITE(LUPRI,'(A)') 'H2X' 1230 CALL OUTPUT(H2X,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 1231 WRITE(LUPRI,'(A)') 'H2XAC' 1232 CALL OUTPUT(H2XAC,1,NASHT,1,NASHT,NASHT,NASHT,1,LUPRI) 1233 END IF 1234C 1235C Process case 1) active - active distributions coulomb part 1236C 1237C Case 1a) 1238C F(p,q) = F(p,q) + (1+S1Sa) (p q|x y) D(x,y) C,D active 1239C F(p,q) = F(p,q) + (1+S1Sa) (p q|C D) D(C,D) 1240C 1241 IF ((ICDTYP .EQ. JTACAC) .AND. (ISP1A.NE.1)) THEN 1242 DENFAC = D2*DEN1(NCW,NDW) 1243 IF (DENFAC .NE. D0) THEN 1244 CALL DAXPY(NORBT*NORBT,DENFAC,H2X,1,FA,1) 1245 END IF 1246 IF (IPRRSP.GT.300) THEN 1247 WRITE(LUPRI,'(/A)') 'FAXAD1: FA after case 1a)' 1248 CALL OUTPUT(FA,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 1249 END IF 1250 END IF 1251C 1252C Case 1b) 1253C F(p,q) = F(p,q) + (1+S2Sa) (x y|p q) D(x,y) 1254C F(C,D) = F(C,D) + (1+S2Sa) (x y|C D) D(x,y) 1255C 1256 IF (ISP2A.NE.1 .AND. ICDSYM.EQ.IFCKSY .AND.ICDTYP.NE.JTININ) THEN 1257 FA(IC,ID) = FA(IC,ID) + D2*DDOT(N2ASHX,H2XAC,1,DEN1,1) 1258 IF (IPRRSP.GT.300) THEN 1259 WRITE(LUPRI,'(/A)') 'FAXAD1: FA after case 1b)' 1260 CALL OUTPUT(FA,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 1261 END IF 1262 END IF 1263 1264C 1265C Now process all exchange contributions 1266C 1267C Case 2) 1268C F(p,q) = F(p,q) - (py|xq) D(x,y) C active 1269C F(p,D) = F(p,D) - (py|CD) D(C,y) 1270C 1271C 1272 IF (ICTYP.EQ.JTACT) THEN 1273 IPSYM = MULD2H(IDSYM,IFCKSY) 1274 IYSYM = MULD2H(ICSYM,IDENSY) 1275 IF (IDTYP.EQ.JTSEC) THEN 1276 NORBP = NOCC(IPSYM) 1277 ELSE 1278 NORBP = NORB(IPSYM) 1279 END IF 1280 NASHY = NASH(IYSYM) 1281 IF(NORBP.GT.0 .AND. NASHY.GT.0) THEN 1282 IPST = IORB(IPSYM) + 1 1283 IYST = IORB(IYSYM) + NISH(IYSYM) + 1 1284 NYW = IASH(IYSYM) + 1 1285 CALL DGEMM('N','T',NORBP,1,NASHY,-1.D0, 1286 & H2X(IPST,IYST),NORBT, 1287 & DEN1(NCW,NYW),NASHT,1.D0, 1288 & FA(IPST,ID),NORBT) 1289 IF (IPRRSP.GT.300) THEN 1290 WRITE(LUPRI,'(/A)') 'FAXAD1: FA after case 2)' 1291 CALL OUTPUT(FA,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 1292 END IF 1293 END IF 1294 END IF 1295C 1296C Case 3) 1297C F(p,q) = F(p,q) - (x q|p y) D(x,y) D active 1298C F(C,q) = F(C,q) - (x q|C D) D(x,D) 1299C 1300 IF (IDTYP.EQ.JTACT) THEN 1301 IQSYM = MULD2H(ICSYM,IFCKSY) 1302 IXSYM = MULD2H(IDSYM,IDENSY) 1303 IF (ICTYP.EQ.JTSEC) THEN 1304 NORBQ = NOCC(IQSYM) 1305 ELSE 1306 NORBQ = NORB(IQSYM) 1307 END IF 1308 NASHX = NASH(IXSYM) 1309 IF (NORBQ.GT.0 .AND. NASHX.GT.0) THEN 1310 IQST = IORB(IQSYM) + 1 1311 IXST = IORB(IXSYM) + NISH(IXSYM) + 1 1312 NXW = IASH(IXSYM) + 1 1313 CALL DGEMM('T','N',1,NORBQ,NASHX,-1.D0, 1314 & DEN1(NXW,NDW),NASHT, 1315 & H2X(IXST,IQST),NORBT,1.D0, 1316 & FA(IC,IQST),NORBT) 1317 IF (IPRRSP.GT.300) THEN 1318 WRITE(LUPRI,'(/A)') 'FAXAD1: FA after case 3)' 1319 CALL OUTPUT(FA,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 1320 END IF 1321 END IF 1322 END IF 1323 CALL QEXIT('FAXAD1') 1324 RETURN 1325 END 1326C /* Deck faxad2 */ 1327 SUBROUTINE FAXAD2(INTSYM,IC,ID,ICDTYP,ICTYP,IDTYP, 1328 * ICDSYM,ICSYM,IDSYM, 1329 * DEN1,IDENSY,FA,H2X,IGRSPI,ISPIN1,ISPIN2, 1330 * ZYMAT,IZYSYM, H2XAC,WRK) 1331C 1332C Olav Vahtras 1333C 1334C Purpose: One-index transform the right-hand side of (AB|CD) 1335C i.e. (AB|CD) -> (AB|C~D) 1336C and distribute in the inactive Fock matrix 1337C Convention used in this routine: Distribution CD is the matrix 1338C HCD(A,B)=(AB|CD) 1339C 1340C Expression: 1341C 1342C F(p,q) = [(1+S2Sa)(xy|p~q)+(1+S1Sa)(pq|x~y)-(px|y~q)-(xq|p~y)] D(x,y) 1343C 1344C 1) (xy|p~q) = ZYMAT(p,r)(xy|rq) - (xy|pr)ZYMAT(r,q) 1345C 1346C Conditions: S2Sa = +, ICDSYM = 1347C 1348C 1a) 2*ZYMAT(p,r)(xy|rq)D(x,y) -> F(p,q) 1349C 2*ZYMAT(p,C)(xy|CD)D(x,y) -> F(p,D) 1350C 1351C Restrictions: IPSYM=IFCKSY X IDSYM 1352C 1353C 1b) - 2(xy|pr)ZYMAT(r,q) D(x,y) -> F(p,q) 1354C - 2(xy|CD)ZYMAT(D,q) D(x,y) -> F(C,q) 1355C 1356C Restrictions: IQSYM=IFCKSY X ICSYM 1357C 1358C 2) (pq|x~y) = ZYMAT(x,r)(pq|ry) - (pq|xr)ZYMAT(r,y) 1359C 1360C Conditions: S1Sa = + 1361C ICDTYP active-general 1362C 1363C 2a) 2*ZYMAT(x,r)(pq|ry) D(x,y) -> F(p,q) 1364C 2*ZYMAT(x,C)(pq|CD) D(x,D) -> F(p,q) D Active 1365C 1366C 2b) -2*(pq|xr)ZYMAT(r,y) D(x,y) -> F(p,q) 1367C -2*(pq|CD)ZYMAT(D,y) D(C,y) -> F(p,q) C Active 1368C 1369C 3) -(py|x~q) = (py|xr)ZYMAT(r,q) - ZYMAT(x,r)(py|rq) 1370C 1371C 3a) (py|xr)ZYMAT(r,q) D(x,y) -> F(p,q) 1372C (py|CD)ZYMAT(D,q) D(C,y) -> F(p,q) C Active 1373C 1374C Restrictions: IPSYM=IDENSY X IDSYM X INTSYM 1375C IQSYM=IDSYM X IZYSYM 1376C 1377C 3b) -ZYMAT(x,r)(py|rq) D(x,y) -> F(p,q) 1378C -ZYMAT(x,C)(py|CD) D(x,y) -> F(p,D) 1379C 1380C Restrictions: IPSYM=IDSYM X IFCKSY 1381C IXSYM=ICSYM X IZYSYM 1382C 1383C 4) -(xq|p~y) = (xq|pr)ZYMAT(r,y) - ZYMAT(p,r)(xq|ry) 1384C 1385C 4a) (xq|pr)ZYMAT(r,y) D(x,y) -> F(p,q) 1386C (xq|CD)ZYMAT(D,y) D(x,y) -> F(C,q) 1387C 1388C Restrictions: IQSYM = ICSYM X IFCKSY 1389C IYSYM = IDSYM X IZYSYM 1390C 1391C 4b) -ZYMAT(p,r)(xq|ry) D(x,y) -> F(p,q) 1392C -ZYMAT(p,C)(xq|CD) D(x,D) -> F(p,q) D active 1393C 1394C Restrictions: IPSYM = ICSYM X IZYSYM 1395C IQSYM = ICSYM X INTSYM 1396C 1397C 1398#include "implicit.h" 1399C 1400 PARAMETER ( D2= 2.0D0, DM1 = -1.0D0 ) 1401C 1402#include "maxorb.h" 1403#include "maxash.h" 1404#include "priunit.h" 1405#include "wrkrsp.h" 1406#include "rspprp.h" 1407#include "infhyp.h" 1408#include "infrsp.h" 1409#include "infdim.h" 1410#include "infind.h" 1411#include "inforb.h" 1412#include "infpri.h" 1413#include "infspi.h" 1414C 1415 DIMENSION FA(NORBT,NORBT), H2X(NORBT,NORBT) 1416 DIMENSION ZYMAT(NORBT,NORBT) 1417 DIMENSION DEN1(NASHT,NASHT) 1418 DIMENSION H2XAC(NASHT,NASHT) 1419 DIMENSION WRK(*) 1420 CALL QENTER('FAXAD2') 1421C 1422 IF (IPRRSP.GT.300) THEN 1423 WRITE(LUPRI,'(/A)') 'ENTRE FAXAD2' 1424 WRITE(LUPRI,'(A,I5)') 'INTSYM =',INTSYM 1425 WRITE(LUPRI,'(A,2I5)') 'IC ID =',IC,ID 1426 WRITE(LUPRI,'(A,I5)') 'ICDTYP =',ICDTYP 1427 WRITE(LUPRI,'(A,I5)') 'ICDSYM =',ICDSYM 1428 WRITE(LUPRI,'(A,I5)') 'ICSYM =',ICSYM 1429 WRITE(LUPRI,'(A,I5)') 'IDSYM =',IDSYM 1430 WRITE(LUPRI,'(A,I5)') 'IGRSPI =',IGRSPI 1431 WRITE(LUPRI,'(A,I5)') 'ISPIN1 =',ISPIN1 1432 WRITE(LUPRI,'(A,I5)') 'ISPIN2 =',ISPIN2 1433 WRITE(LUPRI,'(A,I5)') 'IZYSYM =',IZYSYM 1434 WRITE(LUPRI,'(A)') 'FA' 1435 CALL OUTPUT(FA,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 1436 WRITE(LUPRI,'(A)') 'H2X' 1437 CALL OUTPUT(H2X,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 1438 WRITE(LUPRI,'(A)') 'ZYMAT' 1439 CALL OUTPUT(ZYMAT,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 1440 WRITE(LUPRI,'(A)') 'DEN1' 1441 CALL OUTPUT(DEN1,1,NASHT,1,NASHT,NASHT,NASHT,1,LUPRI) 1442 END IF 1443 IDZY = MULD2H(IDENSY,IZYSYM) 1444 IFCKSY=MULD2H(INTSYM,IDZY) 1445 ISP1A = MULSP(ISPIN1,IGRSPI) 1446 ISP2A = MULSP(ISPIN2,IGRSPI) 1447 ICW = ISW( IC ) 1448 IDW = ISW( ID ) 1449 NCW = ICW - NISHT 1450 NDW = IDW - NISHT 1451C 1452C Case 1) 1453C (xy|p~q) = ZYMAT(p,r)(xy|rq) - (xy|pr)ZYMAT(r,q) 1454C 1455C 1456C Case 1a) 1457C 2*ZYMAT(p,r)(xy|rq)D(x,y) -> F(p,q) 1458C 2*ZYMAT(p,C)(xy|CD)D(x,y) -> F(p,D) 1459C 1460 IF (ISP2A.EQ.0 .AND. ICDSYM.EQ.MULD2H(IZYSYM,IFCKSY) )THEN 1461 DTRACE=D2*DDOT(N2ASHX,H2XAC,1,DEN1,1) 1462 IPSYM=MULD2H(IFCKSY,IDSYM) 1463 IF (ICTYP.EQ.JTSEC .OR. IDTYP.EQ.JTSEC) THEN 1464 NORBP=NOCC(IPSYM) 1465 ELSE 1466 NORBP=NORB(IPSYM) 1467 END IF 1468 IF (NORBP.GT.0) THEN 1469 IPST=IORB(IPSYM)+1 1470 CALL DAXPY(NORBP,DTRACE,ZYMAT(IPST,IC),1,FA(IPST,ID),1) 1471 IF (IPRRSP.GT.300) THEN 1472 WRITE(LUPRI,'(/A)') 'FAXAD2:FA after case 1a' 1473 CALL OUTPUT (FA,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 1474 END IF 1475 END IF 1476C 1477C Case 1b 1478C - 2(xy|pr)ZYMAT(r,q) D(x,y) -> F(p,q) 1479C - 2(xy|CD)ZYMAT(D,q) D(x,y) -> F(C,q) 1480C 1481C 1482 IQSYM = MULD2H(IFCKSY,ICSYM) 1483 IF (ICTYP.EQ.JTSEC .OR. IDTYP.EQ.JTSEC) THEN 1484 NORBQ = NOCC(IQSYM) 1485 ELSE 1486 NORBQ = NORB(IQSYM) 1487 END IF 1488 IF (NORBQ.GT.0) THEN 1489 IQST = IORB(IQSYM) + 1 1490 CALL DAXPY(NORBQ,-DTRACE,ZYMAT(ID,IQST),NORBT, 1491 * FA(IC,IQST),NORBT) 1492 IF (IPRRSP.GT.300) THEN 1493 WRITE(LUPRI,'(/A)') 'FAXAD2:FA after case 1b' 1494 CALL OUTPUT (FA,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 1495 END IF 1496 END IF 1497 END IF 1498C 1499C Case 2) 1500C 1501 IF (ISP1A.EQ.0 .AND. ICDSYM.EQ.MULD2H(IFCKSY,INTSYM)) THEN 1502C 1503C Case 2a) 1504C 2a) 2*ZYMAT(x,r)(pq|ry) D(x,y) -> F(p,q) 1505C 2*ZYMAT(x,C)(pq|CD) D(x,D) -> F(p,q) D Active 1506C 1507 IF (IDTYP.EQ.JTACT ) THEN 1508 IXSYM=MULD2H(IZYSYM,ICSYM) 1509 NASHX=NASH(IXSYM) 1510 IF (NASHX.GT.0) THEN 1511 IXST = IORB(IXSYM) + NISH(IXSYM) + 1 1512 NXW = IASH(IXSYM) + 1 1513 ZYDEN = D2*DDOT(NASHX,ZYMAT(IXST,IC),1,DEN1(NXW,NDW),1) 1514 CALL DAXPY(N2ORBX,ZYDEN,H2X,1,FA,1) 1515 IF (IPRRSP.GT.300) THEN 1516 WRITE(LUPRI,'(/A)') 'FAXAD2:FA after case 2a' 1517 CALL OUTPUT (FA,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 1518 END IF 1519 END IF 1520 END IF 1521C 1522C Case 2b) 1523C 2b) -2*(pq|xr)ZYMAT(r,y) D(x,y) -> F(p,q) 1524C -2*(pq|CD)ZYMAT(D,y) D(C,y) -> F(p,q) C Active 1525C 1526 IF (ICTYP.EQ.JTACT) THEN 1527 IYSYM = MULD2H(IZYSYM,IDSYM) 1528 NASHY = NASH(IYSYM) 1529 IF (NASHY.GT.0) THEN 1530 IYST = IORB(IYSYM) + NISH(IYSYM) + 1 1531 NYW = IASH(IYSYM) + 1 1532 ZYDEN = D2*DDOT(NASHY,ZYMAT(ID,IYST),NORBT, 1533 * DEN1(NCW,NYW),NASHT) 1534 CALL DAXPY(N2ORBX,-ZYDEN,H2X,1,FA,1) 1535 IF (IPRRSP.GT.300) THEN 1536 WRITE(LUPRI,'(/A)') 'FAXAD2:FA after case 2b' 1537 CALL OUTPUT (FA,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 1538 END IF 1539 END IF 1540 END IF 1541 END IF 1542C 1543C Case 3) 1544C -(py|x~q) = (py|xr)ZYMAT(r,q) - ZYMAT(x,r)(py|rq) 1545C 1546C 3a) (py|xr)ZYMAT(r,q) D(x,y) -> F(p,q) 1547C (py|CD)ZYMAT(D,q) D(C,y) -> F(p,q) C Active 1548C 1549C 1550 IF (ICTYP.EQ.JTACT) THEN 1551 IQSYM=MULD2H(IZYSYM,IDSYM) 1552 IPSYM=MULD2H(IFCKSY,IQSYM) 1553 IYSYM=MULD2H(IDENSY,ICSYM) 1554 NORBP=NORB(IPSYM) 1555 IF (IDTYP.EQ.JTSEC) THEN 1556 NORBQ=NOCC(IQSYM) 1557 ELSE 1558 NORBQ=NORB(IQSYM) 1559 END IF 1560 NASHY=NASH(IYSYM) 1561 IF (NORBP.GT.0 .AND. NORBQ.GT.0 .AND.NASHY.GT.0) THEN 1562 IPST=IORB(IPSYM)+1 1563 IQST=IORB(IQSYM)+1 1564 IYST=IORB(IYSYM)+NISH(IYSYM)+1 1565 NYW = IASH(IYSYM)+1 1566 CALL DGEMM('N','T',NORBP,1,NASHY,1.D0, 1567 & H2X(IPST,IYST),NORBT, 1568 & DEN1(NCW,NYW),NASHT,0.D0, 1569 & WRK,NORBP) 1570 CALL DGEMM('N','N',NORBP,NORBQ,1,1.D0, 1571 & WRK,NORBP, 1572 & ZYMAT(ID,IQST),NORBT,1.D0, 1573 & FA(IPST,IQST),NORBT) 1574 IF (IPRRSP.GT.300) THEN 1575 WRITE(LUPRI,'(/A)') 'FAXAD2:FA after case 3a' 1576 CALL OUTPUT (FA,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 1577 END IF 1578 END IF 1579 END IF 1580C 1581C Case 3b) 1582C -ZYMAT(x,r)(py|rq) D(x,y) -> F(p,q) 1583C -ZYMAT(x,C)(py|CD) D(x,y) -> F(p,D) 1584C 1585C 1586 IPSYM=MULD2H(IFCKSY,IDSYM) 1587 IXSYM=MULD2H(IZYSYM,ICSYM) 1588 IYSYM=MULD2H(IDENSY,IXSYM) 1589 IF (IDTYP.EQ.JTSEC) THEN 1590 NORBP=NOCC(IPSYM) 1591 ELSE 1592 NORBP=NORB(IPSYM) 1593 END IF 1594 NASHX=NASH(IXSYM) 1595 NASHY=NASH(IYSYM) 1596 IF (NORBP.GT.0 .AND. NASHX.GT.0 .AND. NASHY.GT.0) THEN 1597 IPST = IORB(IPSYM) + 1 1598 IXST = IORB(IXSYM) + NISH(IXSYM) + 1 1599 IYST = IORB(IYSYM) + NISH(IYSYM) + 1 1600 NXW = IASH(IXSYM) + 1 1601 NYW = IASH(IYSYM) + 1 1602 CALL DGEMM('T','N',1,NASHY,NASHX,1.D0, 1603 & ZYMAT(IXST,IC),NORBT, 1604 & DEN1(NXW,NYW),NASHT,0.D0, 1605 & WRK,1) 1606 CALL DGEMM('N','N',NORBP,1,NASHY,-1.D0, 1607 & H2X(IPST,IYST),NORBT, 1608 & WRK,NASHY,1.D0, 1609 & FA(IPST,ID),NORBT) 1610 IF (IPRRSP.GT.300) THEN 1611 WRITE(LUPRI,'(/A)') 'FAXAD2:FA after case 3b' 1612 CALL OUTPUT (FA,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 1613 END IF 1614 END IF 1615C 1616C Case 4) 1617C 1618C 1619C Case 4b) 1620C -ZYMAT(p,r)(xq|ry) D(x,y) -> F(p,q) 1621C -ZYMAT(p,C)(xq|CD) D(x,D) -> F(p,q) D active 1622C 1623 IF (IDTYP.EQ.JTACT) THEN 1624 IPSYM=MULD2H(IZYSYM,ICSYM) 1625 IQSYM=MULD2H(IFCKSY,IPSYM) 1626 IXSYM=MULD2H(IDENSY,IDSYM) 1627 IF (ICTYP.EQ.JTSEC) THEN 1628 NORBP=NOCC(IPSYM) 1629 ELSE 1630 NORBP=NORB(IPSYM) 1631 END IF 1632 NORBQ=NORB(IQSYM) 1633 NASHX=NASH(IXSYM) 1634 IF (NORBP.GT.0 .AND. NORBQ.GT.0 .AND. NASHX.GT.0) THEN 1635 IPST = IORB(IPSYM) + 1 1636 IQST = IORB(IQSYM) + 1 1637 IXST = IORB(IXSYM) + NISH(IXSYM) + 1 1638 NXW = IASH(IXSYM) + 1 1639 CALL DGEMM('T','N',1,NORBQ,NASHX,1.D0, 1640 & DEN1(NXW,NDW),NASHT, 1641 & H2X(IXST,IQST),NORBT,0.D0, 1642 & WRK,1) 1643 CALL DGEMM('N','N',NORBP,NORBQ,1,-1.D0, 1644 & ZYMAT(IPST,IC),NORBT, 1645 & WRK,1,1.D0, 1646 & FA(IPST,IQST),NORBT) 1647 IF (IPRRSP.GT.300) THEN 1648 WRITE(LUPRI,'(/A)') 'FAXAD2:FA after case 4b' 1649 CALL OUTPUT (FA,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 1650 END IF 1651 END IF 1652 END IF 1653C 1654C Case 4a) 1655C (xq|pr)ZYMAT(r,y) D(x,y) -> F(p,q) 1656C (xq|CD)ZYMAT(D,y) D(x,y) -> F(C,q) 1657C 1658 IYSYM=MULD2H(IZYSYM,IDSYM) 1659 IXSYM=MULD2H(IDENSY,IYSYM) 1660 IQSYM=MULD2H(IFCKSY,ICSYM) 1661 NASHX=NASH(IXSYM) 1662 NASHY=NASH(IYSYM) 1663 IF (ICTYP.EQ.JTSEC) THEN 1664 NORBQ=NOCC(IQSYM) 1665 ELSE 1666 NORBQ=NORB(IQSYM) 1667 END IF 1668 IF (NORBQ.GT.0 .AND. NASHX.GT.0 .AND. NASHY.GT.0) THEN 1669 IXST=IORB(IXSYM)+NISH(IXSYM)+1 1670 IYST=IORB(IYSYM)+NISH(IYSYM)+1 1671 NXW=IASH(IXSYM)+1 1672 NYW=IASH(IYSYM)+1 1673 IQST=IORB(IQSYM)+1 1674 CALL DGEMM('N','T',1,NASHX,NASHY,1.D0, 1675 & ZYMAT(ID,IYST),NORBT, 1676 & DEN1(NXW,NYW),NASHT,0.D0, 1677 & WRK,1) 1678 CALL DGEMM('N','N',1,NORBQ,NASHX,1.D0, 1679 & WRK,1, 1680 & H2X(IXST,IQST),NORBT,1.D0, 1681 & FA(IC,IQST),NORBT) 1682 IF (IPRRSP.GT.300) THEN 1683 WRITE(LUPRI,'(/A)') 'FAXAD2:FA after case 4a' 1684 CALL OUTPUT (FA,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 1685 END IF 1686 END IF 1687 CALL QEXIT('FAXAD2') 1688 RETURN 1689 END 1690C /* Deck qxad1 */ 1691 SUBROUTINE QXAD1(INTSYM,IC,ID,ICDTYP, 1692 * ICDSYM,ICSYM,IDSYM,QA,QB, H2X, 1693 * DEN2A,DEN2B,IDENSY,PVDEN,H2XAC) 1694C 1695C 1696C Olav Vahtras 1697C Dec 9 1991 1698C 1699C Process contributions from the Q matrices. Formulas: 1700C 1701C QA(p,q) = QA(p,q) 1702C + (xp|yz)d2a(xq;yz) + (xy|zp)d2b(xy;zq) 1703C 1704C QB(p,q) = QB(p,q) 1705C + (px|yz)d2a(qx;yz) + (xy|pz)d2b(xy;qz) 1706C 1707C where d2a=<e(SA*S1,S2> and d2b = <e(S1,SA*S2)> 1708C The sum over x and v is taken by reading in all active contribu- 1709C tions. 1710C 1711#include "implicit.h" 1712#include "maxorb.h" 1713#include "maxash.h" 1714#include "priunit.h" 1715#include "infrsp.h" 1716#include "inforb.h" 1717#include "infdim.h" 1718#include "infind.h" 1719#include "wrkrsp.h" 1720#include "infpri.h" 1721#include "rspprp.h" 1722#include "infhyp.h" 1723C 1724 DIMENSION QA(NORBT,NASHDI),QB(NORBT,NASHDI) 1725 DIMENSION DEN2A(NASHT,NASHT,NASHT,NASHT) 1726 DIMENSION DEN2B(NASHT,NASHT,NASHT,NASHT) 1727 DIMENSION PVDEN(NASHDI,NASHDI) 1728 DIMENSION H2X(NORBT,NORBT), H2XAC(NASHT,NASHT) 1729C 1730 IF (ICDTYP.EQ.JTSESE .OR. NASHT.LE.1) RETURN 1731C 1732 CALL QENTER('QXAD1') 1733 IFCKSY = MULD2H(INTSYM,IDENSY) 1734 ICTYP = IOBTYP(IC) 1735 IDTYP = IOBTYP(ID) 1736 IF (IPRRSP.GT.300) THEN 1737 WRITE(LUPRI,'(/A)') 'ENTER QXAD1' 1738 WRITE(LUPRI,'(A,I5)') 'INTSYM =',INTSYM 1739 WRITE(LUPRI,'(A,2I5)') 'IC ID =',IC,ID 1740 WRITE(LUPRI,'(A,I5)') 'ICDTYP =',ICDTYP 1741 WRITE(LUPRI,'(A,I5)') 'ICDSYM =',ICDSYM 1742 WRITE(LUPRI,'(A,I5)') 'ICSYM =',ICSYM 1743 WRITE(LUPRI,'(A,I5)') 'IDSYM =',IDSYM 1744 WRITE(LUPRI,'(A)') 'QA' 1745 CALL OUTPUT(QA,1,NORBT,1,NASHT,NORBT,NASHT,1,LUPRI) 1746 WRITE(LUPRI,'(A)') 'QB' 1747 CALL OUTPUT(QB,1,NORBT,1,NASHT,NORBT,NASHT,1,LUPRI) 1748 WRITE(LUPRI,'(A)') 'DEN2A' 1749 CALL OUTPUT(DEN2A,1,N2ASHX,1,N2ASHX,N2ASHX,N2ASHX,1,LUPRI) 1750 WRITE(LUPRI,'(A)') 'DEN2B' 1751 CALL OUTPUT(DEN2B,1,N2ASHX,1,N2ASHX,N2ASHX,N2ASHX,1,LUPRI) 1752 WRITE(LUPRI,'(A,I5)') 'IDENSY =',IDENSY 1753 WRITE(LUPRI,'(/A)') 'H2X' 1754 CALL OUTPUT(H2X,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 1755 WRITE(LUPRI,'(/A)') 'H2XAC' 1756 CALL OUTPUT(H2XAC,1,NASHT,1,NASHT,NASHT,NASHT,1,LUPRI) 1757 END IF 1758C 1759C Case 1) 1760C 1761C (xp|yz)d2a(xq;yz) -> QA(p,q) 1762C (xp|CD)d2a(xq;CD) -> QA(p,q) 1763C 1764C 1765C 1766 ICW = ISW( IC ) 1767 IDW = ISW( ID ) 1768 NCW = ICW - NISHT 1769 NDW = IDW - NISHT 1770 IF (ICDTYP.EQ.JTACAC) THEN 1771C 1772 DO 2000 IPSYM = 1,NSYM 1773 IQSYM = MULD2H(IFCKSY,IPSYM) 1774 IABSYM = MULD2H(INTSYM,ICDSYM) 1775 IXSYM = MULD2H(IPSYM,IABSYM) 1776 NORBP = NORB(IPSYM) 1777 NASHQ = NASH(IQSYM) 1778 NASHX = NASH(IXSYM) 1779 IF (NORBP.GT.0 .AND. NASHQ.GT.0 .AND. NASHX.GT.0) THEN 1780 IPST = IORB(IPSYM) + 1 1781 NQW = IASH(IQSYM) + 1 1782 NXW = IASH(IXSYM) + 1 1783 IXST = ISX(NXW + NISHT) 1784C 1785C (xp|yz)d2a(xq;yz) -> QA(p,q) 1786C (xp|CD)d2a(xq;CD) -> QA(p,q) 1787C 1788 CALL DGEMM('T','N',NORBP,NASHQ,NASHX,1.D0, 1789 & H2X(IXST,IPST),NORBT, 1790 & DEN2A(NXW,NQW,NCW,NDW),NASHT,1.D0, 1791 & QA(IPST,NQW),NORBT) 1792 IF (IPRRSP.GT.300) THEN 1793 WRITE(LUPRI,'(/A,I2)') 1794 * ' QXAD1: QA after Case 1: IPSYM =', IPSYM 1795 CALL OUTPUT(QA,1,NORBT,1,NASHT,NORBT,NASHT,1,LUPRI) 1796 END IF 1797C 1798C Case 2) 1799C (px|yz)d2a(qx;yz) -> QB(p,q) 1800C (px|CD)d2a(qx;CD) -> QB(p,q) 1801C 1802 CALL DGEMM('N','T',NORBP,NASHQ,NASHX,1.D0, 1803 & H2X(IPST,IXST),NORBT, 1804 & DEN2A(NQW,NXW,NCW,NDW),NASHT,1.D0, 1805 & QB(IPST,NQW),NORBT) 1806 IF (IPRRSP.GT.300) THEN 1807 WRITE(LUPRI,'(/A,I2)') 1808 * ' QXAD1: QB after Case 2: IPSYM =', IPSYM 1809 CALL OUTPUT(QB,1,NORBT,1,NASHT,NORBT,NASHT,1,LUPRI) 1810 END IF 1811 END IF 18122000 CONTINUE 1813 END IF 1814C 1815C 1816C Case 3) 1817C (xy|zp)d2b(xy;zq) -> QA(p,q) 1818C (xy|CD)d2b(xy;Cq) -> QA(D,q) 1819C 1820 IF (ICTYP.EQ.JTACT) THEN 1821 IQSYM=MULD2H(IFCKSY,IDSYM) 1822 NASHQ = NASH(IQSYM) 1823 IF (NASHQ.GT.0) THEN 1824 NQW = IASH(IQSYM) + 1 1825 CALL DGEMM('N','N',1,NASHQ,N2ASHX,1.D0, 1826 & H2XAC,1, 1827 & DEN2B(1,1,NCW,NQW),NASHT*N2ASHX,1.D0, 1828 & QA(ID,NQW),NORBT) 1829 IF (IPRRSP.GT.300) THEN 1830 WRITE(LUPRI,'(/A)') 1831 * ' QXAD1: QA after Case 3' 1832 CALL OUTPUT(QA,1,NORBT,1,NASHT,NORBT,NASHT,1,LUPRI) 1833 END IF 1834 END IF 1835 END IF 1836C 1837C Case 4) 1838C (xy|pz)d2b(xy;qz) -> QB(p,q) 1839C (xy|CD)d2b(xy;qD) -> QB(C,q) 1840C 1841 IF (IDTYP.EQ.JTACT) THEN 1842 IQSYM=MULD2H(IFCKSY,ICSYM) 1843 NASHQ=NASH(IQSYM) 1844 IF (NASHQ.GT.0) THEN 1845 NQW = IASH(IQSYM) + 1 1846 CALL DGEMM('N','N',1,NASHQ,N2ASHX,1.D0, 1847 & H2XAC,1, 1848 & DEN2B(1,1,NQW,NDW),N2ASHX,1.D0, 1849 & QB(IC,NQW),NORBT) 1850 IF (IPRRSP.GT.300) THEN 1851 WRITE(LUPRI,'(/A)') 1852 * ' QXAD1: QB after Case 4' 1853 CALL OUTPUT(QB,1,NORBT,1,NASHT,NORBT,NASHT,1,LUPRI) 1854 END IF 1855 END IF 1856 END IF 1857 CALL QEXIT('QXAD1') 1858 RETURN 1859 END 1860C /* Deck qxad2 */ 1861 SUBROUTINE QXAD2(INTSYM,IC,ID,ICDTYP, 1862 * ICDSYM,ICSYM,IDSYM,QA,QB, H2X,DEN2A,DEN2B, 1863 * IDENSY,PVDEN, H2XAC,SCR,ZYMAT,IZYSYM) 1864C 1865C 1866C Olav Vahtras 1867C Dec 9 1991 1868C 1869C Process contributions from the Q matrices. Formulas: 1870C 1871C QA(p,q) = QA(p,q) 1872C + (xp|y~z)d2a(xq;yz) + (xy|z~p)d2b(xy;zq) 1873C 1874C QB(p,q) = QB(p,q) 1875C + (px|y~z)d2a(qx;yz) + (xy|p~z)d2b(xy;qz) 1876C 1877C Case 1) 1878C (xp|y~z) = ZYMAT(y,r)(xp|rz) - (xp|yr)ZYMAT(r,z) 1879C 1880C 1a) ZYMAT(y,r)(xp|rz)d2a(xq;yz) -> QA(p,q) 1881C ZYMAT(y,C)(xp|CD)d2a(xq;yD) -> QA(p,q) D active 1882C 1883C 1b) -(xp|yr)ZYMAT(r,z)d2a(xq;yz) -> QA(p,q) 1884C -(xp|CD)ZYMAT(D,z)d2a(xq;Cz) -> QA(p,q) C active 1885C 1886C 1887C Case 2) 1888C (px|y~z) = ZYMAT(y,r)(px|rz) - (px|yr)ZYMAT(r,z) 1889C 1890C 2a) ZYMAT(y,r)(px|rz)d2a(qx;yz) -> QB(p,q) 1891C ZYMAT(y,C)(px|CD)d2a(qx;yD) -> QB(p,q) D active 1892C 1893C 2b) -(px|yr)ZYMAT(r,z)d2a(qx;yz) -> QB(p,q) 1894C -(px|CD)ZYMAT(D,z)d2a(qx;Cz) -> QB(p,q) C active 1895C 1896C Case 3) 1897C (xy|z~p) = ZYMAT(z,r)(xy|rp) - (xy|zr)ZYMAT(r,p) 1898C 1899C 3a) ZYMAT(z,r)(xy|rp)d2b(xy;zq) -> QA(p,q) 1900C ZYMAT(z,C)(xy|CD)d2b(xy;zq) -> QA(D,q) 1901C 1902C 3b) -(xy|zr)ZYMAT(r,p)d2b(xy;zq) -> QA(p,q) 1903C -(xy|CD)ZYMAT(D,p)d2b(xy;Cq) -> QA(p,q) C active 1904C 1905C Case 4) 1906C (xy|p~z) = ZYMAT(p,r)(xy|rz) - (xy|pr) ZYMAT(r,z) 1907C 1908C 4a) ZYMAT(p,r)(xy|rz)d2b(xy;qz) -> QB(p,q) 1909C ZYMAT(p,C)(xy|CD)d2b(xy;qD) -> QB(p,q) D active 1910C 1911C 4b) -(xy|pr)ZYMAT(r,z)d2b(xy;qz) -> QB(p,q) 1912C -(xy|CD)ZYMAT(D,z)d2b(xy;qz) -> QB(C,q) 1913C 1914C where d2a=<e(SA*S1,S2> and d2 = <e(S1,SA*S2)> 1915C The sum over x and v is taken by reading in all active contribu- 1916C tions. 1917C 1918#include "implicit.h" 1919#include "maxorb.h" 1920#include "maxash.h" 1921#include "priunit.h" 1922#include "infrsp.h" 1923#include "inforb.h" 1924#include "infdim.h" 1925#include "infind.h" 1926#include "wrkrsp.h" 1927#include "infpri.h" 1928#include "rspprp.h" 1929#include "infhyp.h" 1930C 1931 DIMENSION QA(NORBT,NASHDI),QB(NORBT,NASHDI) 1932 DIMENSION DEN2A(NASHT,NASHT,NASHT,NASHT) 1933 DIMENSION DEN2B(NASHT,NASHT,NASHT,NASHT) 1934 DIMENSION PVDEN(NASHDI,NASHDI) 1935 DIMENSION H2X(NORBT,NORBT), H2XAC(NASHT,NASHT) 1936C Allocated for temporary space max(n2ashx,norbt) 1937 DIMENSION SCR(*) 1938 DIMENSION ZYMAT(NORBT,NORBT) 1939C 1940 IF (NASHT.LE.1) RETURN 1941C 1942 CALL QENTER('QXAD2') 1943 ICTYP = IOBTYP(IC) 1944 IDTYP = IOBTYP(ID) 1945 IF (IPRRSP.GT.300) THEN 1946 WRITE(LUPRI,'(/A)') 'ENTER QXAD2' 1947 WRITE(LUPRI,'(A,I5)') 'INTSYM =',INTSYM 1948 WRITE(LUPRI,'(A,I5)') 'IZYSYM =',IZYSYM 1949 WRITE(LUPRI,'(A,2I5)') 'IC ID =',IC,ID 1950 WRITE(LUPRI,'(A,I5)') 'ICDTYP =',ICDTYP 1951 WRITE(LUPRI,'(A,I5)') 'ICDSYM =',ICDSYM 1952 WRITE(LUPRI,'(A,I5)') 'ICSYM =',ICSYM 1953 WRITE(LUPRI,'(A,I5)') 'IDSYM =',IDSYM 1954 WRITE(LUPRI,'(A,I5)') 'IDENSY =',IDENSY 1955 WRITE(LUPRI,'(/A)') 'QA' 1956 CALL OUTPUT(QA,1,NORBT,1,NASHT,NORBT,NASHT,1,LUPRI) 1957 WRITE(LUPRI,'(/A)') 'QB' 1958 CALL OUTPUT(QB,1,NORBT,1,NASHT,NORBT,NASHT,1,LUPRI) 1959 WRITE(LUPRI,'(A)') 'DEN2A' 1960 CALL OUTPUT(DEN2A,1,N2ASHX,1,N2ASHX,N2ASHX,N2ASHX,1,LUPRI) 1961 WRITE(LUPRI,'(A)') 'DEN2B' 1962 CALL OUTPUT(DEN2B,1,N2ASHX,1,N2ASHX,N2ASHX,N2ASHX,1,LUPRI) 1963 WRITE(LUPRI,'(/A)') 'ZYMAT' 1964 CALL OUTPUT(ZYMAT,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 1965 WRITE(LUPRI,'(/A)') 'H2X' 1966 CALL OUTPUT(H2X,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 1967 WRITE(LUPRI,'(/A)') 'H2XAC' 1968 CALL OUTPUT(H2XAC,1,NASHT,1,NASHT,NASHT,NASHT,1,LUPRI) 1969 END IF 1970 ICW = ISW( IC ) 1971 IDW = ISW( ID ) 1972 NCW = ICW - NISHT 1973 NDW = IDW - NISHT 1974 IFCKSY = MULD2H(INTSYM,MULD2H(IDENSY,IZYSYM)) 1975C 1976C 1977C 1a) ZYMAT(y,r)(xp|rz)d2a(xq;yz) -> QA(p,q) 1978C ZYMAT(y,C)(xp|CD)d2a(xq;yD) -> QA(p,q) D active 1979C 1980C 2a) ZYMAT(y,r)(px|rz)d2a(qx;yz) -> QB(p,q) 1981C ZYMAT(y,C)(px|CD)d2a(qx;yD) -> QB(p,q) D active 1982C 1983C 1984 IF (IDTYP.EQ.JTACT) THEN 1985 DO 1000 IPSYM = 1,NSYM 1986 IQSYM = MULD2H(IFCKSY,IPSYM) 1987 IXSYM = MULD2H(IPSYM,MULD2H(INTSYM,ICDSYM)) 1988 IYSYM = MULD2H(IZYSYM,ICSYM) 1989 NORBP = NORB(IPSYM) 1990 NASHQ = NASH(IQSYM) 1991 NASHX = NASH(IXSYM) 1992 NASHY = NASH(IYSYM) 1993 IF (NORBP.GT.0 .AND. NASHQ.GT.0 .AND. 1994 * NASHX.GT.0 .AND. NASHY.GT.0) THEN 1995 IPST = IORB(IPSYM) + 1 1996 NQW = IASH(IQSYM) + 1 1997 NXW = IASH(IXSYM) + 1 1998 IXST = ISX(NXW+NISHT) 1999 DO 1500 IYW = 1,NASHY 2000 NYW = IASH(IYSYM) + IYW 2001 IY = ISX(NYW + NISHT) 2002 ZYYC = ZYMAT(IY,IC) 2003C 2004C 1a) ZYMAT(y,r)(xp|rz)d2a(xq;yz) -> QA(p,q) 2005C ZYMAT(y,C)(xp|CD)d2a(xq;yD) -> QA(p,q) D active 2006C 2007 CALL DGEMM('T','N',NORBP,NASHQ,NASHX,ZYYC, 2008 & H2X(IXST,IPST),NORBT, 2009 & DEN2A(NXW,NQW,NYW,NDW),NASHT,1.D0, 2010 & QA(IPST,NQW),NORBT) 2011 IF (IPRRSP.GT.300) THEN 2012 WRITE(LUPRI,'(/A,I2,A,I2,A,I2)') 2013 * ' QXAD2: QA after Case 1a, IYW =', IYW, 2014 * '(',NASHY,') ;IPSYM = ',IPSYM 2015 CALL OUTPUT(QA,1,NORBT,1,NASHT,NORBT,NASHT,1,LUPRI) 2016 END IF 2017C 2018C 2a) ZYMAT(y,r)(px|rz)d2a(qx;yz) -> QB(p,q) 2019C ZYMAT(y,C)(px|CD)d2a(qx;yD) -> QB(p,q) D active 2020C 2021 CALL DGEMM('N','T',NORBP,NASHQ,NASHX,ZYYC, 2022 & H2X(IPST,IXST),NORBT, 2023 & DEN2A(NQW,NXW,NYW,NDW),NASHT,1.D0, 2024 & QB(IPST,NQW),NORBT) 2025 IF (IPRRSP.GT.300) THEN 2026 WRITE(LUPRI,'(/A,I2,A,I2,A,I2)') 2027 * ' QXAD2: QB after Case 2a, IYW =',IYW, 2028 * '(',NASHY,'); IPSYM = ',IPSYM 2029 CALL OUTPUT(QB,1,NORBT,1,NASHT,NORBT,NASHT,1,LUPRI) 2030 END IF 20311500 CONTINUE 2032 END IF 20331000 CONTINUE 2034 END IF 2035 2036 2037C 2038C 1b) -(xp|yr)ZYMAT(r,z)d2a(xq;yz) -> QA(p,q) 2039C -(xp|CD)ZYMAT(D,z)d2a(xq;Cz) -> QA(p,q) C active 2040C 2041C 2b) -(px|yr)ZYMAT(r,z)d2a(qx;yz) -> QB(p,q) 2042C -(px|CD)ZYMAT(D,z)d2a(qx;Cz) -> QB(p,q) C active 2043C 2044 IF (ICTYP.EQ.JTACT) THEN 2045 DO 2000 IPSYM=1,NSYM 2046 IQSYM = MULD2H(IFCKSY,IPSYM) 2047 IZSYM = MULD2H(IZYSYM,IDSYM) 2048 IXSYM = MULD2H(IPSYM,MULD2H(INTSYM,ICDSYM)) 2049 NORBP = NORB(IPSYM) 2050 NASHQ = NASH(IQSYM) 2051 NASHX = NASH(IXSYM) 2052 NASHZ = NASH(IZSYM) 2053 IF (NORBP.GT.0 .AND. NASHQ.GT.0 .AND. 2054 * NASHX.GT.0 .AND. NASHZ.GT.0) THEN 2055 IPST = IORB(IPSYM) + 1 2056 NQW = IASH(IQSYM) + 1 2057 NXW = IASH(IXSYM) + 1 2058 IXST = ISX(NXW+NISHT) 2059 DO 2500 IZW = 1,NASHZ 2060 NZW = IZW + IASH(IZSYM) 2061 IZ = ISX(NZW + NISHT) 2062 ZYDZ = ZYMAT(ID,IZ) 2063C 2064C 1b) -(xp|yr)ZYMAT(r,z)d2a(xq;yz) -> QA(p,q) 2065C -(xp|CD)ZYMAT(D,z)d2a(xq;Cz) -> QA(p,q) C active 2066C 2067 CALL DGEMM('T','N',NORBP,NASHQ,NASHX,-ZYDZ, 2068 & H2X(IXST,IPST),NORBT, 2069 & DEN2A(NXW,NQW,NCW,NZW),NASHT,1.D0, 2070 & QA(IPST,NQW),NORBT) 2071 IF (IPRRSP.GT.300) THEN 2072 WRITE(LUPRI,'(/A,I2)') 2073 * ' QXAD2: QA after Case 1b: IZW =',IZW 2074 CALL OUTPUT(QA,1,NORBT,1,NASHT,NORBT,NASHT,1,LUPRI) 2075 END IF 2076C 2077C 2b) -(px|yr)ZYMAT(r,z)d2a(qx;yz) -> QB(p,q) 2078C -(px|CD)ZYMAT(D,z)d2a(qx;Cz) -> QB(p,q) C active 2079C 2080 CALL DGEMM('N','T',NORBP,NASHQ,NASHX,-ZYDZ, 2081 & H2X(IPST,IXST),NORBT, 2082 & DEN2A(NQW,NXW,NCW,NZW),NASHT,1.D0, 2083 & QB(IPST,NQW),NORBT) 2084 IF (IPRRSP.GT.300) THEN 2085 WRITE(LUPRI,'(/A,I2)') 2086 * ' QXAD2: QB after Case 2b: IZW =',IZW 2087 CALL OUTPUT(QB,1,NORBT,1,NASHT,NORBT,NASHT,1,LUPRI) 2088 END IF 20892500 CONTINUE 2090 END IF 20912000 CONTINUE 2092 END IF 2093 2094C 2095C 2096C 3a) ZYMAT(z,r)(xy|rp)d2b(xy;zq) -> QA(p,q) 2097C ZYMAT(z,C)(xy|CD)d2b(xy;zq) -> QA(D,q) 2098C 2099 IZSYM = MULD2H(IZYSYM,ICSYM) 2100 IQSYM = MULD2H(IFCKSY,IDSYM) 2101 NASHZ = NASH(IZSYM) 2102 NASHQ = NASH(IQSYM) 2103 IF (NASHZ.GT.0 .AND. NASHQ.GT.0) THEN 2104 NZW = IASH(IZSYM) + 1 2105 IZ = ISX(NZW + NISHT) 2106 DO 3000 IQW = 1,NASHQ 2107 NQW = IQW + IASH(IQSYM) 2108 CALL DGEMM('N','N',1,NASHZ,N2ASHX,1.D0, 2109 & H2XAC,1, 2110 & DEN2B(1,1,NZW,NQW),N2ASHX,0.D0, 2111 & SCR,1) 2112 CALL DGEMM('N','N',1,1,NASHZ,1.D0, 2113 & SCR,1, 2114 & ZYMAT(IZ,IC),NORBT,1.D0, 2115 & QA(ID,NQW),NORBT) 2116 IF (IPRRSP.GT.300) THEN 2117 WRITE(LUPRI,'(/A,I2,A,I1,A)') 2118 * ' QXAD2: QA after Case 3a: IQW =',IQW,' (',NASHQ,')' 2119 CALL OUTPUT(QA,1,NORBT,1,NASHT,NORBT,NASHT,1,LUPRI) 2120 END IF 21213000 CONTINUE 2122 END IF 2123C 2124C 4b) -(xy|pr)ZYMAT(r,z)d2b(xy;qz) -> QB(p,q) 2125C -(xy|CD)ZYMAT(D,z)d2b(xy;qz) -> QB(C,q) 2126C 2127 IZSYM = MULD2H(IZYSYM,IDSYM) 2128 IQSYM = MULD2H(IFCKSY,ICSYM) 2129 NASHZ = NASH(IZSYM) 2130 NASHQ = NASH(IQSYM) 2131 IF (NASHZ.GT.0 .AND. NASHQ.GT.0) THEN 2132 NQW = IASH(IQSYM) + 1 2133 DO 4000 IZW = 1,NASHZ 2134 NZW = IASH(IZSYM) + IZW 2135 IZ = ISX(NZW + NISHT) 2136 ZYDZ = ZYMAT(ID,IZ) 2137 CALL DGEMM('N','N',1,NASHQ,N2ASHX,1.D0, 2138 & H2XAC,1, 2139 & DEN2B(1,1,NQW,NZW),N2ASHX,0.D0, 2140 & SCR,1) 2141 CALL DAXPY(NASHQ,-ZYDZ,SCR,1,QB(IC,NQW),NORBT) 2142 IF (IPRRSP.GT.300) THEN 2143 WRITE(LUPRI,'(/A,I2,A,I1,A)') 2144 * ' QXAD2: QB after Case 4b: IZW =',IZW,'(',NASHZ,')' 2145 CALL OUTPUT(QB,1,NORBT,1,NASHT,NORBT,NASHT,1,LUPRI) 2146 END IF 21474000 CONTINUE 2148 END IF 2149C 2150C 3b) -(xy|zr)ZYMAT(r,p)d2b(xy;zq) -> QA(p,q) 2151C -(xy|CD)ZYMAT(D,p)d2b(xy;Cq) -> QA(p,q) C active 2152C 2153 IF (ICTYP.EQ.JTACT) THEN 2154 IPSYM = MULD2H(IZYSYM,IDSYM) 2155 IQSYM = MULD2H(IFCKSY,IPSYM) 2156 IF (IDTYP.EQ.JTSEC) THEN 2157 NORBP = NOCC(IPSYM) 2158 ELSE 2159 NORBP = NORB(IPSYM) 2160 END IF 2161 NASHQ = NASH(IQSYM) 2162 IF (NORBP.GT.0 .AND. NASHQ.GT.0) THEN 2163 IPST = IORB(IPSYM) + 1 2164 NQW = IASH(IQSYM) + 1 2165 CALL DGEMM('N','N',1,NASHQ,N2ASHX,1.D0, 2166 & H2XAC,1, 2167 & DEN2B(1,1,NCW,NQW),N2ASHX*NASHT,0.D0, 2168 & SCR,1) 2169 CALL DGEMM('T','N',NORBP,NASHQ,1,-1.D0, 2170 & ZYMAT(ID,IPST),NORBT, 2171 & SCR,1,1.D0, 2172 & QA(IPST,NQW),NORBT) 2173 IF (IPRRSP.GT.300) THEN 2174 WRITE(LUPRI,'(/A)') ' QXAD2: QA after Case 3b' 2175 CALL OUTPUT(QA,1,NORBT,1,NASHT,NORBT,NASHT,1,LUPRI) 2176 END IF 2177 END IF 2178 END IF 2179C 2180C 4a) ZYMAT(p,r)(xy|rz)d2b(xy;qz) -> QB(p,q) 2181C ZYMAT(p,C)(xy|CD)d2b(xy;qD) -> QB(p,q) D active 2182C 2183 IF (IDTYP.EQ.JTACT) THEN 2184 IPSYM = MULD2H(IZYSYM,ICSYM) 2185 IQSYM = MULD2H(IFCKSY,IPSYM) 2186 IF (ICTYP.EQ.JTSEC) THEN 2187 NORBP = NOCC(IPSYM) 2188 ELSE 2189 NORBP = NORB(IPSYM) 2190 END IF 2191 NASHQ = NASH(IQSYM) 2192 IF (NORBP.GT.0 .AND. NASHQ.GT.0) THEN 2193 IPST = IORB(IPSYM) + 1 2194 NQW = IASH(IQSYM) + 1 2195 CALL DGEMM('N','N',1,NASHQ,N2ASHX,1.D0, 2196 & H2XAC,1, 2197 & DEN2B(1,1,NQW,NDW),N2ASHX,0.D0, 2198 & SCR,1) 2199 CALL DGEMM('N','N',NORBP,NASHQ,1,1.D0, 2200 & ZYMAT(IPST,IC),NORBT, 2201 & SCR,1,1.D0, 2202 & QB(IPST,NQW),NORBT) 2203 IF (IPRRSP.GT.300) THEN 2204 WRITE(LUPRI,'(/A)') ' QXAD2: QB after Case 4a' 2205 CALL OUTPUT(QB,1,NORBT,1,NASHT,NORBT,NASHT,1,LUPRI) 2206 END IF 2207 END IF 2208 END IF 2209 CALL QEXIT('QXAD2') 2210 RETURN 2211 END 2212C /* Deck disac1 */ 2213 SUBROUTINE DISAC1(IC,ID,H2XAC,H2ACAC) 2214#include "implicit.h" 2215#include "maxorb.h" 2216#include "maxash.h" 2217#include "inforb.h" 2218#include "infind.h" 2219 DIMENSION H2XAC(N2ASHX) 2220 DIMENSION H2ACAC(N2ASHX,NASHT,NASHT) 2221 PARAMETER (D1 = 1.0D0) 2222 IF (IOBTYP(IC).NE.JTACT .OR. IOBTYP(ID).NE.JTACT) RETURN 2223 NCW = ISW(IC) - NISHT 2224 NDW = ISW(ID) - NISHT 2225 CALL DAXPY(N2ASHX,D1,H2XAC,1,H2ACAC(1,NCW,NDW),1) 2226 RETURN 2227 END 2228C /* Deck disac2 */ 2229 SUBROUTINE DISAC2(IC,ID,H2XAC,H2ACAC,ZYMAT,IZYSYM) 2230#include "implicit.h" 2231#include "maxorb.h" 2232#include "maxash.h" 2233#include "priunit.h" 2234#include "inforb.h" 2235#include "infrsp.h" 2236#include "infind.h" 2237#include "rspprp.h" 2238#include "infhyp.h" 2239#include "infpri.h" 2240 DIMENSION H2XAC(N2ASHX) 2241 DIMENSION H2ACAC(N2ASHX,NASHT,NASHT) 2242 DIMENSION ZYMAT(NORBT,NORBT) 2243 ICTYP = IOBTYP(IC) 2244 IDTYP = IOBTYP(ID) 2245 ICSYM = ISMO(IC) 2246 IDSYM = ISMO(ID) 2247 IF (ICTYP.NE.JTACT .AND. IDTYP.NE.JTACT) RETURN 2248 IF (IPRRSP.GT.300) THEN 2249 WRITE(LUPRI,'(/A)') 'ENTER DISAC2' 2250 WRITE(LUPRI,'(A,2I3)') 'IC ID',IC,ID 2251 WRITE(LUPRI,'(/A)') ' H2XAC' 2252 CALL OUTPUT(H2XAC,1,NASHT,1,NASHT,NASHT,NASHT,1,LUPRI) 2253 WRITE(LUPRI,'(/A)') ' H2ACAC' 2254 CALL OUTPUT(H2ACAC,1,N2ASHX,1,N2ASHX,N2ASHX,N2ASHX,1,LUPRI) 2255 WRITE(LUPRI,'(/A)') 'ZYMAT' 2256 CALL OUTPUT(ZYMAT,1,NORBT,1,NORBT,NORBT,NORBT,1,LUPRI) 2257 WRITE(LUPRI,'(/A,I3)') 'IZYSYM',IZYSYM 2258 END IF 2259 NCW = ISW(IC) - NISHT 2260 NDW = ISW(ID) - NISHT 2261C 2262C (xy|z~w) = ZYMAT(z,r)(xy|rw) - (xy|zr)ZYMAT(r,w) 2263C 2264C Case 1) ZYMAT(z,C)(xy|CD) -> (xy|z~D) D active 2265C 2266C Case 2) - (xy|CD)ZYMAT(D,w) -> (xy|C~w) C active 2267C 2268C 2269C 2270C Case 1) ZYMAT(z,C)(xy|CD) -> (xy|z~D) D active 2271C 2272 IF (IDTYP.EQ.JTACT) THEN 2273 IZSYM = MULD2H(IZYSYM,ICSYM) 2274 NASHZ = NASH(IZSYM) 2275 IF (NASHZ.GT.0) THEN 2276 NZW = IASH(IZSYM) + 1 2277 IZ = ISX(NZW + NISHT) 2278 CALL DGEMM('N','N',N2ASHX,NASHZ,1,1.D0, 2279 & H2XAC,N2ASHX, 2280 & ZYMAT(IZ,IC),1,1.D0, 2281 & H2ACAC(1,NZW,NDW),N2ASHX) 2282 IF (IPRRSP.GT.300) THEN 2283 WRITE(LUPRI,'(/A)') ' H2ACAC after case 1' 2284 CALL OUTPUT(H2ACAC,1,N2ASHX,1,N2ASHX,N2ASHX,N2ASHX,1, 2285 & LUPRI) 2286 END IF 2287 END IF 2288 END IF 2289C 2290C Case 2) - (xy|CD)ZYMAT(D,w) -> (xy|C~w) C active 2291C 2292 IF (ICTYP.EQ.JTACT) THEN 2293 IWSYM = MULD2H(IDSYM,IZYSYM) 2294 NASHW = NASH(IWSYM) 2295 IF (NASHW.GT.0) THEN 2296 NWW = IASH(IWSYM) + 1 2297 IW = ISX(NWW + NISHT) 2298 CALL DGEMM('N','N',N2ASHX,NASHW,1,-1.D0, 2299 & H2XAC,N2ASHX, 2300 & ZYMAT(ID,IW),NORBT,1.D0, 2301 & H2ACAC(1,NCW,NWW),N2ASHX*NASHT) 2302 IF (IPRRSP.GT.300) THEN 2303 WRITE(LUPRI,'(/A)') ' H2ACAC after case 2' 2304 CALL OUTPUT(H2ACAC,1,N2ASHX,1,N2ASHX,N2ASHX,N2ASHX,1, 2305 & LUPRI) 2306 END IF 2307 END IF 2308 END IF 2309 RETURN 2310 END 2311C /* Deck priac2 */ 2312 SUBROUTINE PRIAC2(AC2,N,LU) 2313#include "implicit.h" 2314 DIMENSION AC2(N*N,N,N) 2315 DO 10 I=1,N 2316 DO 20 J=1,I 2317 WRITE(LU,'(/A,2I3,A)') ' Distribution (* *,',I,J,')' 2318 CALL OUTPUT(AC2(1,I,J),1,N,1,N,N,N,1,LU) 2319 IF (I.NE.J) THEN 2320 WRITE(LU,'(/A,2I3,A)') ' Distribution (* *,',J,I,')' 2321 CALL OUTPUT(AC2(1,J,I),1,N,1,N,N,N,1,LU) 2322 END IF 232320 CONTINUE 232410 CONTINUE 2325 RETURN 2326 END 2327