1C 2C /* Deck so_ediag2 */ 3 SUBROUTINE SO_EDIAG2(DIAG2,LDIAG2,FOCKD,LFOCKD,ISYRES,WORK,LWORK) 4C 5C This routine is part of the atomic integral direct SOPPA program. 6C 7C Keld Bak, April 1996 8C Stephan P. A. Sauer, November 2003: merge with DALTON 2.0 9C 10C PURPOSE: Calculate diagonale two-particle part of the 11C SOPPA E[2] matrix. That is the D matrix. 12C 13#include "implicit.h" 14#include "priunit.h" 15C 16 PARAMETER (ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, TWO = 2.0D0) 17C 18 DIMENSION DIAG2(LDIAG2), FOCKD(LFOCKD), WORK(LWORK) 19 20C 21#include "ccorb.h" 22#include "ccsdinp.h" 23#include "ccsdsym.h" 24#include "soppinf.h" 25C 26C------------------------------ 27C Statement function INDEX. 28C------------------------------ 29C 30 INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 31C 32C------------------ 33C Add to trace. 34C------------------ 35C 36 CALL QENTER('SO_EDIAG2') 37C 38C------------------------------------------------ 39C Loop over the combined symmetry of B and J. 40C------------------------------------------------ 41C 42 DO 100 ISYMBJ = 1,NSYM 43C 44 ISYMAI = MULD2H(ISYMBJ,ISYRES) 45C 46C--------------------------------- 47C Allocation of work space. 48C--------------------------------- 49C 50 LFBJ = NT1AM(ISYMBJ) 51 LFAI = NT1AM(ISYMAI) 52C 53 KFBJ = 1 54 KFAI = KFBJ + LFBJ 55 KEND = KFAI + LFAI 56 LWORK1 = LWORK - KEND 57C 58 CALL SO_MEMMAX ('SO_EDIAG2',LWORK1) 59 IF (LWORK1 .LT. 0) CALL STOPIT('SO_EDIAG2',' ',KEND,LWORK) 60C 61C---------------------------------------------------------------- 62C Make difference of fock-diagonals B and J in WORK(KFBJ). 63C---------------------------------------------------------------- 64C 65 DO 201 ISYMJ = 1,NSYM 66C 67 ISYMB = MULD2H(ISYMJ,ISYMBJ) 68C 69 DO 202 J = 1,NRHF(ISYMJ) 70C 71 KOFFJ = IRHF(ISYMJ) + J 72C 73 DO 203 B = 1,NVIR(ISYMB) 74C 75 NBJ = IT1AM(ISYMB,ISYMJ) + NVIR(ISYMB)*(J - 1) + B-1 76C 77 KOFFB = IVIR(ISYMB) + B 78C 79 WORK(KFBJ+NBJ) = FOCKD(KOFFB) - FOCKD(KOFFJ) 80C 81 203 CONTINUE 82C 83 202 CONTINUE 84C 85 201 CONTINUE 86C 87C---------------------------------------------------------------- 88C Make difference of fock-diagonals A and I in WORK(KFAI). 89C---------------------------------------------------------------- 90C 91 DO 301 ISYMI = 1,NSYM 92C 93 ISYMA = MULD2H(ISYMI,ISYMAI) 94C 95 DO 302 I = 1,NRHF(ISYMI) 96C 97 KOFFI = IRHF(ISYMI) + I 98C 99 DO 303 A = 1,NVIR(ISYMA) 100C 101 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + A-1 102C 103 KOFFA = IVIR(ISYMA) + A 104C 105 WORK(KFAI+NAI) = FOCKD(KOFFA) - FOCKD(KOFFI) 106C 107 303 CONTINUE 108C 109 302 CONTINUE 110C 111 301 CONTINUE 112C 113C--------------------------------------------------------------- 114C Multiply energy-differences EAIBJ and 2p2h trialvectors 115C to obtain the D-matrix contribution to the 2p2h result- 116C vectors. 117C--------------------------------------------------------------- 118C 119 IF ( ISYMAI .EQ. ISYMBJ) THEN 120C 121 DO 401 NBJ = 1,NT1AM(ISYMBJ) 122C 123 DO 402 NAI = 1,NBJ 124C 125 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 126 & + INDEX(NAI,NBJ) 127C 128 DIAG2(NAIBJ) = WORK(KFAI-1+NAI) + WORK(KFBJ-1+NBJ) 129C 130 402 CONTINUE 131C 132 401 CONTINUE 133C 134 ELSE IF ( ISYMAI .LT. ISYMBJ) THEN 135C 136 DO 501 NBJ = 1,NT1AM(ISYMBJ) 137C 138 DO 502 NAI = 1,NT1AM(ISYMAI) 139C 140 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 141 & + NT1AM(ISYMAI)*(NBJ - 1) + NAI 142C 143 DIAG2(NAIBJ) = WORK(KFAI-1+NAI) + WORK(KFBJ-1+NBJ) 144C 145 502 CONTINUE 146C 147 501 CONTINUE 148C 149 END IF 150C 151 100 CONTINUE 152C 153C----------------------- 154C Remove from trace. 155C----------------------- 156C 157 CALL QEXIT('SO_EDIAG2') 158C 159 RETURN 160 END 161