*Deck D2ESP
      SUBROUTINE D2ESP(CORE)
      Implicit Real*8(A-H,O-Z)
C
C     CONTROL ROUTINE FOR THE 'IN-CORE' CALCULATION OF THE
C     TWO-ELECTRON CONTRIBUTIONS TO THE HARTREE-FOCK FIRST
C     DERIVATIVES.
C
C     ******************************************************************
C     IOP(  )  ... OPTIONS:
C     ******************************************************************
C
C     IOP(18) ... PROGRAM ACCURACY OPTION (LIKE IN L311).
C     0 ... COMPUTE DERIVATIVE CONTRIBUTIONS WITH 10**(-8)
C           ACCURACY.
C     1 ... 'TEST' OPTION ... DO AS ACCURATELY AS POSSIBLE.
C     2 ... USE THE ORIGINAL 'BERNY' VALUES.
C
C     IOP(27) ... FILE INITIALIZATION CONTROL.
C     1 ... READ IN PREVIOUS DERIVATIVE CONTRIBUTIONS
C           FROM FILE IRWFX BEFORE COMPUTING ANYTHING.
C
C     IOP(28) ... SKIP OPTION TO DEFER INTEGRAL EVALUATION
C                 TO L703.
C     0 ... COMPUTE AS NORMAL.
C     1 ... DO ALL GRADIENT INTEGRALS IN L703.
C
C     IOP(34) ... DUMP OPTION.
C     0 ... NO DUMPING.
C     1 ... USUAL SYSTEM STUFF.
C     2 ... DUMP DERIVATIVE CONTRIBUTIONS FROM WITHIN SHELL LOOPS.
C
C     THIS ROUTINE SERVES TWO MAJOR PURPOSES:
C     1.  PERFORM INITIALIZATION CHORES, LIKE RECOVERING PERTINENT
C         COMMON BLOCKS FROM THE RW-FILES.
C     2.  ALLOCATE MEMORY.  CERTAIN ARRAYS DEPEND ON THE NUMBER
C         OF BASIS FUNCTIONS AND NUMBER OF ATOMS.
C         SPACE FOR THESE THINGS IS ALLOCATED FROM THE SINGLE ARRAY
C         'CORE'.
C
      INTEGER SHELLA,SHELLN,SHELLT,SHELLC,AOS,AON
      LOGICAL USESYM
      COMMON /IOP/    IOP(50)
      COMMON /MOL/    NATOMS,ICHARG,MULTIP,NAE,NBE,NE,NBASIS,
     $                ian(401),atmchg(400),c(1200)
      COMMON/B/EXX(1200),C1(1200),C2(1200),C3(1200),
     $         X(400),Y(400),Z(400),JAN(400),SHELLA(400),SHELLN(400),
     $         SHELLT(400),SHELLC(400),AOS(400),AON(400),NSHELL,MAXTYP
      DIMENSION C4(400),SHLADF(400)
      EQUIVALENCE(C4(1),C3(401)),(SHLADF(1),C3(801))
      COMMON/IO/IN,IOUT,IPUNCH
      COMMON/GRSYM/NOP1,NOP2,JTRANS(3,8)
      DIMENSION CORE(1)
      Common/HamSav/NOrb,NHam
      DATA IRWB,IRWPT,IRWPA,IRWPB,IRWPTI,IRWF1,IRWSYM
     $    / 506, 532 , 528 , 530 , 533 ,  584 , 579   /
      DATA IRWSY1/551/, MaxShl/400/, IRwHam/568/, IRwMOA/524/,
     $     Two/2.0d0/, IONDDO/566/
 1000 Format(' F=',5D13.6)
 1010 Format(' AJ:')
 1020 Format(' AK:')
 2002 FORMAT(39H NO CODE YET FOR COMPLEX UHF ... SORRY.)
C
C     INITIALIZE THIS LINK.
C
C***      CALL DRUM
C***      Call TrakIO(6hD2ESP ,1)
      LenB = 15*MaxShl+INTOWP(2+7*MaxShl)
      LRWSY1 = InToWP(26)
C
C     FILL LOCAL OPTIONS.
      ICRIT=Mod(IOP(18),10)
      INITF=IOP(27)
      IACC=IOP(28)
      ISYMGR=IOP(30)
      IPrint=IOp(33)
      IDUMP=IOP(34)
      ICheck = IOp(40)
      INDDO = IOp(41)
      If(INDDO.ne.0.and.ICheck.eq.0) ICheck = 3
      NTT=(NBASIS*(NBASIS+1))/2
      NAT3=3*NATOMS
C***      CALL GETNOP(NOP1,NOP2)
      NOP1=1
C
C     DEFER EXECUTION OF THIS LINK IF POSSIBLE.
      IF(IACC.GT.0)GO TO 100
      CALL ILSW(2,24,IFRC)
      IF(IFRC.EQ.1)GO TO 100
C
C     FETCH /B/ FROM THE RW-FILES.
C***      CALL TREAD(IRWB,EXX(1),LenB,1,LenB,1,0)
C***
C
C     DETERMINE TYPE OF SCF.
C     DEFINITION OF ISCF:
C        ISCF = 0 ... RRHF
C               1 ... RUHF/ROHF
C               2 ... CRHF
C               3 ... CUHF
C               4 ... GVB
C
      NDEN=1
      CALL ILSW(2,1,ISCF)
      Call ILSW(2,22,IRest)
      If(ISCF.eq.0.and.IRest.eq.1) ISCF = 1
      If(ISCF.eq.0.and.IRest.eq.2) ISCF = 4
      If(ISCF.ne.0.and.ISCF.ne.4) NDen=2
      ISCFP=ISCF+1
      NOrb = 0
      NHam = 0
      NonC1 = 1
C***      If(ISCF.eq.4) Call FileIO(2,-IRwHam,InToWP(2),NOrb,0)
C
C     ALLOCATE STORAGE IN 'CORE'.
C           CORE(1)=VEE
      IVEE=1
C           FXYZ(3*NATOMS)
      IFXYZ=IVEE+1
C           Work array for adding in one-electron forces.
      JFxyz=IFXYZ+3*NATOMS
C           ALLOCATE NDEN DENSITY MATRICES.
      IDM=JFXYZ+3*NATOMS
      IDN=IDM
      IF(NDEN.EQ.2)IDN=IDM+NTT
C           CHECK FOR OVER-RUN.
      INEQ=IDN+NTT
      IFroze=INEQ+INTOWP(NATOMS*NOP1)
      INConf=IFroze+InToWP(NAtoms)
      IFHam=INConf+InToWP(NOrb)
      IAJ=IFHam+NHam
      IAK=IAJ+NHam*NHam
      LenHam=IAK+NHam*NHam-INConf
      IMO=INConf+LenHam
      LenMO = 0
      If(ISCF.eq.4) LenMO = NBasis*NBasis
      IFlags = IMO + LenMO
      IScVEN = IFlags + 1
      IScVEE = IScVEN + 1
      IScVNN = IScVEE + 1
      IHDiag = IScVNN + 1
      IBeta = IHDiag + NBasis
      IFirst = IBeta + NBasis
      IShlBf = IFirst + InToWP(NBasis)
      IEnd = IShlBf + InToWP(NBasis) - 1
      LenNDO = IEnd + 1 - IFlags
C
C     GET MEMORY.
C***      CALL GETSCM(IEND,CORE(1),JJJMEM,6HD2ESP1,0)
      Call LClear(NBasis,Core(IFirst))
C***      If(INDDO.ne.0) Call FileIO(2,-IONDDO,LenNDO,Core(IFlags),0)
      If(INDDO.eq.0) Core(IScVEE) = DFloat(1)
C***      Call FrzAt1(NAtoms,Core(IFroze))
      CALL LCLEAR(NATOMS,CORE(IFROZE))
C
C     READ IN DENSITY MATRICES FROM RW-FILES.
      DO 9988 I=1,NTT
 9988 CORE(IDM-1+I)=0.2D0
C***      GO TO(30,40,50,60,70),ISCFP
C
C     REAL-RHF.
C***   30 CALL TREAD(IRWPT,CORE(IDM),NTT,1,NTT,1,0)
C***      GO TO 80
C
C     REAL-UHF.
C***   40 CALL TREAD(IRWPA,CORE(IDM),NTT,1,NTT,1,0)
C***      CALL TREAD(IRWPB,CORE(IDN),NTT,1,NTT,1,0)
C***      GO TO 80
C
C     COMPLEX RHF.
C***   50 CALL TREAD(IRWPT ,CORE(IDM),NTT,1,NTT,1,0)
C***      CALL TREAD(IRWPTI,CORE(IDN),NTT,1,NTT,1,0)
C***      GO TO 80
C
C     COMPLEX UHF ... NO CODE YET.
C***   60 WRITE(IOUT,2002)
C***      CALL LNK1E
C
C     GVB and general wavefunctions of the fH + aJ + bK type.
C***   70 Call FileIO(2,IRwHam,LenHam,Core(INConf),0)
C***      ISt = IFHam
C***      IEn = IFHam + NHam - 1
C***      If(IDump.ne.0) Write(6,1000) (Core(I),I=ISt,IEn)
C***      If(IDump.ne.0) Write(6,1010)
C***      If(IDump.ne.0) Call MatOut(Core(IAJ),NHam,NHam,NHam,NHam)
C***      If(IDump.ne.0) Write(6,1020)
C***      If(IDump.ne.0) Call MatOut(Core(IAK),NHam,NHam,NHam,NHam)
C***      Call FileIO(2,-IRwMOA,NBasis**2,Core(IMO),0)
C***      Call OCount(NOrb,Core(INConf),NonCor)
C***      NonC1 = Max0(NonCor,1)
C***      IF1 = IEnd + 1
C***      IAJ1 = IF1 + NonC1
C***      IAK1 = IAJ1 + NonC1*NonC1
C***      NGet = IAK1 + NonC1*NonC1 - IF1
C***      Call GetSCM(NGet,Core(IF1),jjjmem,6hGVBGrd,0)
C***      Call NewFJK(NOrb,NHam,NBasis,NBasis,NonCor,NonC1,Core(INConf),
C***     $    Core(IFHam),Core(IAJ),Core(IAK),Core(IMO),Core(IDM),
C***     $    Core(IF1),Core(IAJ1),Core(IAK1))
C***      If(NonCor.eq.0) Call AScale(NTT,Two,Core(IDM),Core(IDM))
C***      If(NonCor.eq.0) ISCF = 0
C***      If(NonCor.eq.0) ISCFP = 1
C
C     IF SYMMETRY IS AVAILABLE, RECOVER THE INFORMATION
C     FROM THE RW-FILES, AND PREPARE TO USE IT.
   80 CALL ILSW(2,26,NOSYM)
      USESYM=(NOSYM.EQ.0).AND.(ISYMGR.EQ.0).AND.(NOP1.GT.1)
      IF(.NOT.USESYM)GO TO 90
C     READ IN SYMMETRY INFORMATION.
C***      CALL TREAD(IRWSY1,NOP1,LRWSY1,1,LRWSY1,1,0)
C***      LEN=INTOWP(NATOMS*NOP1)
C***      CALL TREAD(IRWSYM,Core(INEQ),LEN,1,LEN,1,0)
   90 CONTINUE
C
C     Clear out accumulation array.
      CALL ACLEAR(NAT3,Core(IFXYZ))
C
C     CALCULATE 2-ELECTRON CONTRIBUTION TO HARTREE-FOCK FORCES.
C     ROUTINE RETURNS WITH VEE, AND FORCE CONTRIBUTIONS IN
C     FXYZ.
C
      CALL TWLDRV(ISCF,Core(IDM),Core(IDN),ICRIT,USESYM,NOP1,JTRANS,
     $    Core(INEQ),NATOMS,C,Core(IVEE),Core(IFXYZ),IDUMP,Core(IFroze),
     $    NonCor,NonC1,Core(IF1),Core(IAJ1),Core(IAK1),Core(IMO),NBasis,
     $    INDDO,AtmChg,Core(IFirst),ICheck)
C
C     Recover previous information (if requested) and add in  this 
C     Link's contributions.
C***      call aclear(Nat3,Core(JFxyz))
C***      IF(INITF.EQ.1) Call FileIO(2,-IRwF1,NAt3,Core(JFXYZ),0)
C***      if(iprint.ge.2)
C***     $   call dmpfrc(iout,8hl702inpt,8,natoms,core(jfxyz))
C***      if(iprint.ge.2)
C***     $   call dmpfrc(iout,8h2-e part,8,natoms,core(ifxyz))
C***      call aadd(Nat3,Core(IFxyz),Core(JFxyz),Core(JFxyz))
C***      if(iprint.ge.1)
C***     $   call dmpfrc(iout,8hl702 out,8,natoms,core(jfxyz))
C***      CALL TWRITE(IRWF1,Core(JFXYZ),NAT3,1,NAT3,1,0)
  100 CONTINUE
C***      Call TrakIO(6hD2ESP ,2)
C***      CALL CHAINX(0)
      Return
      END
