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 erifck */ 20 SUBROUTINE ERIFCK(FMAT,DMAT,NDMT,ISYMDM,IFCTYP,IPRFCK, 21 * CCFBT,INDXBT,FCKTMP,WORK,LWORK) 22#include "implicit.h" 23#include "iratdef.h" 24#include "priunit.h" 25#include "mxcent.h" 26#include "aovec.h" 27#include "dummy.h" 28#include "maxaqn.h" 29#include "maxorb.h" 30 PARAMETER (D1 = 1.0D0, D2 = 2.0D0) 31C 32C I don't know if IFCTYP and ISYMDM is used properly in this 33C routine at the current stage, K.Ruud-jan96 34C 35#include "ccom.h" 36#include "cbieri.h" 37#include "ericom.h" 38#include "erithr.h" 39#include "erimem.h" 40#include "aobtch.h" 41#include "veclen.h" 42#include "odbtch.h" 43#include "symmet.h" 44#include "infpar.h" 45 DIMENSION FMAT(*), DMAT(*), WORK(LWORK), 46 & IFCTYP(NDMT), ISYMDM(NDMT), CCFBT(*), INDXBT(*), 47 & FCKTMP(*) 48C 49 CALL QENTER('ERIFCK') 50C 51 IF (SLAVE) THEN 52 IPRINT = IPRFCK 53 ELSE 54 CALL TIMER('START ',TIMSTR,TIMEND) 55C 56C Initialization in ER2INI 57C 58 CALL ER2INI 59C 60 IPRINT = MAX(IPRERI,IPRFCK) 61 END IF 62C 63 THRSH = MAX(THRS,1.00D-15) 64 NDMAT = NDMT 65C 66C Memory 67C 68 MEMOK = .TRUE. 69 MEMADD = 0 70 MODAB = 0 71 MODCD = 0 72C 73 WRTINT = .FALSE. 74 FCKINT = .TRUE. 75C 76C AO batches 77C ========== 78C 79 CALL SETAOB(CCFBT,INDXBT,WORK,LWORK,IPRINT) 80C 81C Density matrix (not needed yet) 82C =============================== 83C 84C KDAO = 1 85C KLAST = KDAO + N2BASX*NDMAT 86C IF(KLAST.GT.LWORK) CALL STOPIT('ERIFCK','DSOTAO',KLAST,LWORK) 87C LWRK = LWORK - KLAST + 1 88C DO IMAT = 1,NDMAT 89C JDAO = KDAO + (IMAT-1)*N2BASX 90C CALL DSOTAO(DMAT(1,IMAT),WORK(JDAO),NBAST,ISYMDM,IPRINT) 91C END DO 92C 93C OD batches 94C ========== 95C 96C This subroutine returns several arrays for each electron 97C starting at addresses K????1 and K????2. These are to be 98C transferred to ODCDRV. 99C 100 CALL ODBCHS(KODCL1,KODCL2, 101 & KODBC1,KODBC2,KRDBC1,KRDBC2, 102 & KODPP1,KODPP2,KRDPP1,KRDPP2, 103 & KFREE,LFREE,CCFBT,WORK, 104 & LWORK,IPRINT) 105C 106 IF (IPRINT .GT. 2) THEN 107 WRITE (LUPRI,'(2(/,2X,A,I10))') 108 & ' Memory requirements for ODBCHS:',LWORK - LFREE, 109 & ' Memory left for ODCDRV: ',LFREE 110 END IF 111C 112 ICALL = 0 113 CALL GETDST(ICALL,ICALL,IPRINT) 114C 115C Select integrals to be calculated 116C ================================= 117C 118 CALL PICKAO(IPRINT) 119C 120C Information about distributions 121C =============================== 122C 123 CALL ERIDSI(INDXBT,IPRINT) 124#if defined (VAR_VECTOR) 125 ICHUNK = MAX(IVECLN/NDMT,1) 126 CALL DZERO(FCKTMP,ICHUNK*NDMT*(NBASE + NODD)*NBASE) 127#endif 128C 129 KLAST = KFREE 130 LWRK = LFREE 131C 132C Calculate integrals 133C =================== 134C 135 IF (SLAVE) THEN 136#if defined (VAR_VECTOR) 137 CALL ODCDRV(WORK(KODCL1),WORK(KODCL2), 138 & WORK(KODBC1),WORK(KODBC2), 139 & WORK(KRDBC1),WORK(KRDBC2), 140 & WORK(KODPP1),WORK(KODPP2), 141 & WORK(KRDPP1),WORK(KRDPP2), 142 & FCKTMP,DMAT,NDMT,IFCTYP,DUMMY,IDUMMY,CCFBT, 143 & INDXBT,WORK(KLAST),LWRK,IPRINT) 144#else 145 CALL ODCDRV(WORK(KODCL1),WORK(KODCL2), 146 & WORK(KODBC1),WORK(KODBC2), 147 & WORK(KRDBC1),WORK(KRDBC2), 148 & WORK(KODPP1),WORK(KODPP2), 149 & WORK(KRDPP1),WORK(KRDPP2), 150 & FMAT,DMAT,NDMT,IFCTYP,DUMMY,IDUMMY,CCFBT, 151 & INDXBT,WORK(KLAST),LWRK,IPRINT) 152#endif 153 ELSE 154 IF (.NOT.INTSKP) THEN 155#if defined (VAR_VECTOR) 156 CALL ODCDRV(WORK(KODCL1),WORK(KODCL2), 157 & WORK(KODBC1),WORK(KODBC2), 158 & WORK(KRDBC1),WORK(KRDBC2), 159 & WORK(KODPP1),WORK(KODPP2), 160 & WORK(KRDPP1),WORK(KRDPP2), 161 & FCKTMP,DMAT,NDMT,IFCTYP,DUMMY,IDUMMY,CCFBT, 162 & INDXBT,WORK(KLAST),LWRK,IPRINT) 163#else 164 CALL ODCDRV(WORK(KODCL1),WORK(KODCL2), 165 & WORK(KODBC1),WORK(KODBC2), 166 & WORK(KRDBC1),WORK(KRDBC2), 167 & WORK(KODPP1),WORK(KODPP2), 168 & WORK(KRDPP1),WORK(KRDPP2), 169 & FMAT,DMAT,NDMT,IFCTYP,DUMMY,IDUMMY,CCFBT, 170 & INDXBT,WORK(KLAST),LWRK,IPRINT) 171#endif 172C 173C Error message in case of insufficient memory 174C 175 IF (.NOT.MEMOK) THEN 176 WRITE (LUPRI,'(//A,3(/A,I12))') 177 & ' Not enough memory for this run of ERIFCK.', 178 & ' Available memory in ERIFCK:',LWORK, 179 & ' Required memory for ERIFCK:',LWORK + MEMADD, 180 & ' Increase memory (LWORK) by:',MEMADD 181 WRITE (LUPRI,'(/A,2I5)') 182 & ' Memory requirements largest for OD classes :', 183 & MODAB,MODCD 184 CALL QUIT('Insufficient memory in ERIFCK.') 185 END IF 186 END IF 187#if defined (VAR_VECTOR) 188 IOFF = 0 189 DO I = 1, ICHUNK 190 DO J = 1, NDMT 191 DO L = 1, NBASE 192 DO K = 1, NBASE 193C FMAT(K,L,J) = FMAT(K,L,J) + FCKTMP(IOFF + K) 194 FMAT(K+(L-1)*NBASE+(J-1)*NBASE*NBASE) = 195 & FMAT(K+(L-1)*NBASE+(J-1)*NBASE*NBASE) + 196 & FCKTMP(IOFF + K) 197 END DO 198 IOFF = IOFF + NBASE+NODD 199 END DO 200 END DO 201 END DO 202#endif 203C 204C Symmetrize Fock matrix (Not needed!) 205C ==================================== 206C 207C NECgh980314 Kenneth found on 98/03/14 that this is the IFCTYP=3 bug. 208C NECgh980314 Now, we scale with 2.0 instead of symmetrizing. 209C NECgh980314 CALL ERISFK(FMAT,NBASE,NDMT) 210C NECgh980505 Instead of doing this call, we adjust the FAC in the FCKCON call. 211C NECgh980505 call dscal(nbase*nbase*ndmt,2.0d0,fmat,1) 212C 213C Print densities and Fock matrix 214C =============================== 215C 216 IF (IPRINT.GT.4) THEN 217 CALL HEADER('Density and Fock matrices in ERIFCK',-1) 218 KSTR = 1 219 DO I = 1, NDMT 220 WRITE (LUPRI,'(//,1X,A,I3)') ' Density matrix No.',I 221 CALL OUTPUT(DMAT(KSTR),1,NBASE,1,NBASE,NBASE, 222 & NBASE,1,LUPRI) 223 WRITE (LUPRI,'(//,1X,A,I3)') ' Fock matrix No.',I 224 CALL OUTPUT(FMAT(KSTR),1,NBASE,1,NBASE,NBASE, 225 & NBASE,1,LUPRI) 226 KSTR = KSTR + NBASE*NBASE 227 END DO 228 END IF 229C 230 CALL TIMER('ERIFCK',TIMSTR,TIMEND) 231 CALL FLSHFO(LUPRI) 232 END IF 233C 234 CALL QEXIT('ERIFCK') 235 RETURN 236 END 237C /* Deck erifok */ 238 SUBROUTINE ERIFOK(SO,IPNTCR,IODDCC,IPNTUV,FMAT,DMAT,NDMT, 239 & IFCTYP,CCFBT,INDXBT,WORK,LWORK,IPRINT) 240#include "implicit.h" 241#include "priunit.h" 242#include "iratdef.h" 243#include "maxaqn.h" 244#include "mxcent.h" 245#include "maxorb.h" 246#include "aovec.h" 247#include "eridst.h" 248 DIMENSION SO(*), IPNTCR(MAXBCH,4), CCFBT(*), INDXBT(*), 249 & IPNTUV(KC2MAX,0:NRDER,2), WORK(LWORK), IODDCC(NRTOP), 250 & FMAT(NBASE,NBASE), DMAT(NBASE,NBASE), IFCTYP(NDMT) 251#include "cbieri.h" 252#include "aobtch.h" 253#include "ericom.h" 254#include "eribuf.h" 255#include "symmet.h" 256#include "hertop.h" 257C 258C Allocation for ERIFOK 259C 260 LBIN = NCCT*KHKTA*KHKTB*KHKTC*KHKTD 261 KBIN = 1 262 KIBIN = KBIN + LBIN 263 KINDEX = KIBIN + (4*LBIN - 1)/IRAT + 1 264 KLAST = KINDEX + (4*LBIN - 1)/IRAT + 1 265 IF (KLAST .GT. LWORK) CALL STOPIT('ERIFOK',' ',KLAST,LWORK) 266 CALL ERIFO1(SO,WORK(KINDEX),IPNTCR,IODDCC,IPNTUV, 267 & WORK(KBIN),WORK(KIBIN),LBIN,FMAT,DMAT,NDMT, 268 & IFCTYP,CCFBT,INDXBT,IPRINT) 269C 270 RETURN 271 END 272C /* Deck erifo1 */ 273 SUBROUTINE ERIFO1(SO,INDEX,IPNTCR,IODDCC,IPNTUV, 274 & BIN,IBIN,LBIN,FMAT,DMAT,NDMT,IFCTYP, 275 & CCFBT,INDXBT,IPRINT) 276#include "implicit.h" 277#include "priunit.h" 278#include "iratdef.h" 279#include "maxaqn.h" 280#include "mxcent.h" 281#include "maxorb.h" 282#include "aovec.h" 283C 284#include "eridst.h" 285 DIMENSION SO(*), INDEX(LBIN,4), CCFBT(*), INDXBT(*), 286 & IPNTCR(MAXBCH,4), 287 & IODDCC(NRTOP), IPNTUV(KC2MAX,0:NRDER,2), 288 & BIN(LBIN), IBIN(LBIN,4), 289 & FMAT(NBASE,NBASE,NDMT), DMAT(NBASE,NBASE,NDMT), 290 & IFCTYP(NDMT) 291#include "cbieri.h" 292#include "ericom.h" 293#include "eribuf.h" 294#include "aobtch.h" 295#include "hertop.h" 296C 297 IF (IPRINT .GT. 6) CALL HEADER('Subroutine ERIFO1',-1) 298C 299C Collect (non-zero) integrals and attach indices 300C =============================================== 301C 302 CALL ERINDF(SO,INDEX,IPNTCR,IODDCC,IPNTUV, 303 & BIN,IBIN,LBIN,CCFBT,INDXBT,INT,IPRINT) 304C 305C Construct Fock matrix contribution 306C ================================== 307C 308 CALL FOKDI1(FMAT,DMAT,NDMT,IFCTYP,BIN,IBIN,LBIN,INT, 309 & ABS(IFITDM),IPRINT) 310C 311 RETURN 312 END 313C /* Deck erindf */ 314 SUBROUTINE ERINDF(SO,INDEX,IPNTCR,IODDCC,IPNTUV, 315 & BIN,IBIN,LBIN,CCFBT,INDXBT,INT,IPRINT) 316#include "implicit.h" 317#include "priunit.h" 318#include "iratdef.h" 319#include "maxaqn.h" 320#include "mxcent.h" 321#include "maxorb.h" 322#include "aovec.h" 323 PARAMETER (D1 = 1.0D0, DP5=0.50D0) 324 INTEGER A, B, C, D, AB, CD, R, S, T 325 LOGICAL DOREP(0:7,4), CTRIAB, CTRICD, CTRIAC, CTRIBD, CTRIPQ, 326 & AEQB, CEQD, PEQQ 327 DIMENSION SO(NCCS,MLTPR,MLTPS,MLTPT,KHKTAB,KHKTCD), 328 & INDEX(NCCS,4), CCFBT(MXPRIM*MXCONT), 329 & IPNTCR(MAXBCH,4), INDXBT(MXSHEL*MXCONT,0:7), 330 & IODDCC(NRTOP), IPNTUV(KC2MAX,0:NRDER,2), 331 & BIN(LBIN), IBIN(LBIN,4), 332 & IPNRST(0:7,3), 333 & IADCMP(MXAQN,MXAQN,2) 334#include "cbieri.h" 335#include "ericom.h" 336#include "erithr.h" 337#include "aobtch.h" 338#include "hertop.h" 339#include "symmet.h" 340C 341 342 IBTEST(I,J,K,L) = IAND(I,IEOR(J,ISYMAO(K,L))) 343C 344 IF (IPRINT .GT. 6) CALL HEADER('Subroutine ERINDF',-1) 345C 346 CALL PRPREP(DOREP(0,1),NHKTA,KHKTA,ISTBLA) 347 CALL PRPREP(DOREP(0,2),NHKTB,KHKTB,ISTBLB) 348 CALL PRPREP(DOREP(0,3),NHKTC,KHKTC,ISTBLC) 349 CALL PRPREP(DOREP(0,4),NHKTD,KHKTD,ISTBLD) 350C 351 CALL CMPADR(IADCMP(1,1,1),KHKTA,KHKTB,TKMPAB) 352 CALL CMPADR(IADCMP(1,1,2),KHKTC,KHKTD,TKMPCD) 353C 354 CALL GETRST(IPNRST(0,1),ISTBLR) 355 CALL GETRST(IPNRST(0,2),ISTBLS) 356 CALL GETRST(IPNRST(0,3),ISTBLT) 357C 358 IF (IPRINT .GT. 10) THEN 359 WRITE (LUPRI,'(/,2X,A,8L2)')'DOREP A ',(DOREP(I,1),I=0,MAXREP) 360 WRITE (LUPRI,'(2X,A,8L2)') 'DOREP B ',(DOREP(I,2),I=0,MAXREP) 361 WRITE (LUPRI,'(2X,A,8L2)') 'DOREP C ',(DOREP(I,3),I=0,MAXREP) 362 WRITE (LUPRI,'(2X,A,8L2)') 'DOREP D ',(DOREP(I,4),I=0,MAXREP) 363 END IF 364C 365 NCCS1 = (NPQBCS - NPPBCS)*NCTFAB*NCTFCD 366 NCCS2 = NPPBCS*NCTFAB*NCTFCD 367C 368 INT = 0 369C 370 DO A = 0, MAXREP 371 IF (DOREP(A,1)) THEN 372 DO B = 0, MAXREP 373 IF (DOREP(B,2)) THEN 374 DO C = 0, MAXREP 375 IF (DOREP(C,3) .AND. DOREP(IEOR(IEOR(A,B),C),4)) THEN 376 D = IEOR(IEOR(A,B),C) 377 CD = IEOR(C,D) 378C 379 IF (DIAGAB .AND. B.GT.A) GO TO 100 380 IF (DIAGCD .AND. D.GT.C) GO TO 100 381C 382 CTRIAB = DIAGAB .AND. A.EQ.B 383 CTRICD = DIAGCD .AND. C.EQ.D 384 CTRIAC = A.EQ.C 385 CTRIBD = B.EQ.D 386 CTRIPQ = A.EQ.C .AND. B.EQ.D 387C 388 R = IPNRST(B,1) 389 S = IPNRST(D,2) 390 T = IPNRST(CD,3) 391C 392 CALL ERIPNT(INDEX,A,B,C,D,IPNTCR,INDXBT,1) 393C 394 IF (NCCS1 .GT. 0) THEN 395C 396 IA = -1 397 MAXB = KHKTB 398 MAXD = KHKTD 399 DO ICMPA = 1, KHKTA 400 IVARA = IBTEST(ISTBLA,A,NHKTA,ICMPA) 401 IF (IVARA.EQ.0) THEN 402 IA = IA + 1 403 IB = -1 404 IF (CTRIAB) MAXB = ICMPA 405 DO ICMPB = 1, MAXB 406 IVARB = IBTEST(ISTBLB,B,NHKTB,ICMPB) 407 IF (IVARB.EQ.0) THEN 408 IB = IB + 1 409 IC = -1 410 ICMPAB = IADCMP(ICMPA,ICMPB,1) 411 IODDAB = IODDCC(IPNTUV(ICMPAB,0,1)) 412 AEQB = CTRIAB .AND. ICMPA.EQ.ICMPB 413 DO ICMPC = 1, KHKTC 414 IVARC = IBTEST(ISTBLC,C,NHKTC,ICMPC) 415 IF (IVARC.EQ.0) THEN 416 IC = IC + 1 417 ID = -1 418 IF (CTRICD) MAXD = ICMPC 419 DO ICMPD = 1, MAXD 420 IVARD = IBTEST(ISTBLD,D,NHKTD,ICMPD) 421 IF (IVARD.EQ.0) THEN 422 ID = ID + 1 423 ICMPCD = IADCMP(ICMPC,ICMPD,2) 424 IODDCD = IODDCC(IPNTUV(ICMPCD,0,2)) 425 IF (IODDAB .EQ. IODDCD) THEN 426 CEQD = CTRICD .AND. ICMPC.EQ.ICMPD 427 FAC = D1 428 IF (AEQB) FAC = DP5*FAC 429 IF (CEQD) FAC = DP5*FAC 430 DO I = 1, NCCS1 431 SOABCD = SO(I,R,S,T,ICMPAB,ICMPCD) 432 IF (ABS(SOABCD) .GT. THRSH) THEN 433 INT = INT + 1 434 BIN(INT) = FAC*SOABCD 435 IBIN(INT,1) = INDEX(I,1) + IA 436 IBIN(INT,2) = INDEX(I,2) + IB 437 IBIN(INT,3) = INDEX(I,3) + IC 438 IBIN(INT,4) = INDEX(I,4) + ID 439 END IF 440 END DO 441 END IF 442 END IF 443 END DO 444 END IF 445 END DO 446 END IF 447 END DO 448 END IF 449 END DO 450 END IF 451C 452 IF (NCCS2 .GT. 0) THEN 453C 454 IF (C.GT.A .OR. (C.EQ.A .AND. D.GT.B)) GO TO 200 455C 456 MAXB = KHKTB 457 MAXC = KHKTC 458 MAXD = KHKTD 459C 460 IA = -1 461 DO ICMPA = 1, KHKTA 462 IVARA = IBTEST(ISTBLA,A,NHKTA,ICMPA) 463 IF (IVARA.EQ.0) THEN 464 IA = IA + 1 465 IB = -1 466 IF (CTRIAB) MAXB = ICMPA 467 DO ICMPB = 1, MAXB 468 IVARB = IBTEST(ISTBLB,B,NHKTB,ICMPB) 469 IF (IVARB.EQ.0) THEN 470 IB = IB + 1 471 IC = -1 472 ICMPAB = IADCMP(ICMPA,ICMPB,1) 473 IODDAB = IODDCC(IPNTUV(ICMPAB,0,1)) 474 AEQB = CTRIAB .AND. ICMPA.EQ.ICMPB 475 IF (CTRIAC) MAXC = ICMPA 476 DO ICMPC = 1, MAXC 477 IVARC = IBTEST(ISTBLC,C,NHKTC,ICMPC) 478 IF (IVARC.EQ.0) THEN 479 IC = IC + 1 480 ID = -1 481 IF (CTRIPQ .AND. ICMPA.EQ.ICMPC) THEN 482 MAXD = ICMPB 483 ELSE 484 MAXD = KHKTD 485 IF (CTRICD) MAXD = ICMPC 486 END IF 487 DO ICMPD = 1, MAXD 488 IVARD = IBTEST(ISTBLD,D,NHKTD,ICMPD) 489 IF (IVARD.EQ.0) THEN 490 ID = ID + 1 491 ICMPCD = IADCMP(ICMPC,ICMPD,2) 492 IODDCD = IODDCC(IPNTUV(ICMPCD,0,2)) 493 IF (IODDAB .EQ. IODDCD) THEN 494 CEQD = CTRICD .AND. ICMPC.EQ.ICMPD 495 PEQQ = CTRIPQ .AND. ICMPA.EQ.ICMPC 496 & .AND. ICMPB.EQ.ICMPD 497 FAC = D1 498 IF (AEQB) FAC = DP5*FAC 499 IF (CEQD) FAC = DP5*FAC 500 IF (PEQQ) FAC = DP5*FAC 501 DO I = NCCS1 + 1, NCCS 502 SOABCD = SO(I,R,S,T,ICMPAB,ICMPCD) 503 IF (ABS(SOABCD) .GT. THRSH) THEN 504 INT = INT + 1 505 BIN(INT) = FAC*SOABCD 506 IBIN(INT,1) = INDEX(I,1) + IA 507 IBIN(INT,2) = INDEX(I,2) + IB 508 IBIN(INT,3) = INDEX(I,3) + IC 509 IBIN(INT,4) = INDEX(I,4) + ID 510 END IF 511 END DO 512 END IF 513 END IF 514 END DO 515 END IF 516 END DO 517 END IF 518 END DO 519 END IF 520 END DO 521 200 CONTINUE 522 END IF 523 100 CONTINUE 524 END IF 525 END DO 526 END IF 527 END DO 528 END IF 529 END DO 530 RETURN 531 END 532C /* Deck fokdi1 */ 533 SUBROUTINE FOKDI1(FMAT,DMAT,NDMT,IFCTYP,BUF,IBUF, 534 & LBIN,LENGTH,IFIT_DMAT,IPRINT) 535C 536C Henrik Koch and Trygve Helgaker 18-NOV-1991. 537C 538C This subroutine adds derivative two-electron integrals to 539C Fock matrices. The Fock matrices are assumed 540C to be square matrices in full dimension without symmetry reduction 541C in size. Remember to zero out the fock matrices before starting 542C to accumulate. 543C 544#include "implicit.h" 545 PARAMETER (D4 = 4.0D0, D1 = 1.0D0, DP5 = 0.5D0) 546 INTEGER P, Q, R, S 547#include "priunit.h" 548#include "inforb.h" 549 DIMENSION FMAT(NBAST,NBAST,NDMT), DMAT(NBAST,NBAST,NDMT), 550 & BUF(LBIN), IBUF(LBIN,4), IFCTYP(NDMT) 551C 552 DO I = 1, NDMT 553 IX = IFCTYP(I) / 10 554 IY = MOD (IFCTYP(I),10) 555C FAC account for the different integrals in eri and twoint. 556C twoint are 4times larger, but FAC seems only to be 2(?), at least for 557C IFCTYP = 13 558 IF (IFCTYP(I).EQ.13) THEN 559C NECgh980505 We adjust the FAC, since we do not symmetrize/scal anymore. 560C NECgh980505 FAC = D2 561 FAC = D4 562 ELSE IF (IFCTYP(I).EQ.3) THEN 563C NECgh980505 FAC = DP5 564 FAC = D1 565 ELSE 566 FAC = D1 567 WRITE(LUPRI,*) '*** WARNING!!! This value for IFCTYP is '// 568 & 'probably not correctly implemented! ***' 569 END IF 570 IF (IFIT_DMAT.EQ.0) THEN 571C...........Ordinary Fock matrix with exact density 572 CALL FCKCON(FMAT(1,1,I),DMAT(1,1,I),I,BUF,IBUF,LBIN, 573 & LBIN,LENGTH,IX,IY,FAC) 574 ELSE 575C...........Construction of special Fock matrix for density fitting 576C...........The multiplication factor should be one in this case. 577 FAC = D1 578 CALL DF_FCKCON (FMAT,DMAT,FMAT,DMAT,NDMT,I,BUF,IBUF,LBIN, 579 & LBIN,LENGTH,IX,IY,FAC,IFIT_DMAT) 580 ENDIF 581 END DO 582 RETURN 583 END 584C /* Deck erisfk */ 585 SUBROUTINE ERISFK(FMAT,NBASE,NDMT) 586#include "implicit.h" 587#include "priunit.h" 588 DIMENSION FMAT(NBASE,NBASE,NDMT) 589 DO IDM = 1, NDMT 590 DO I = 1, NBASE 591 DO J = 1, I 592 FMT = FMAT(I,J,IDM) + FMAT(J,I,IDM) 593 FMAT(I,J,IDM) = FMT 594 FMAT(J,I,IDM) = FMT 595 END DO 596 END DO 597 END DO 598 RETURN 599 END 600