      SUBROUTINE DHC (P,PA,PB,XI,NAT,IF,IM,IL,JF,JM,JL,
     1NORBS,DENER,MODE)
      implicit double precision (A-H,O-Z)
      include 'MOP6FILE'
      dimension P(*), PA(*), PB(*)
      dimension XI(3,*),NFIRST(2),NMIDLE(2),NLAST(2),NAT(*)
C***********************************************************************
C
C  DHC CALCULATES THE ENERGY CONTRIBUTIONS FROM THOSE PAIRS OF ATOMS
C         THAT HAVE BEEN MOVED BY SUBROUTINE DERIV.
C
C***********************************************************************
      common /KEYWRD/ KEYWRD
     1       /ONELEC/ USS(107),UPP(107),UDD(107)
      common /EULER / TVEC(3,3), ID
      common /NUMCAL/ NUMCAL
      character*241 KEYWRD
      logical UHF, CUTOFF
      dimension H(171), SHMAT(9,9), F(171),
     1          WJ(100), E1B(10), E2A(10), WK(100), W(100),
     2          WJS(100), WKS(100)
      double precision WJS, WKS
      save ICALCN, WLIM, UHF
      data ICALCN /0/
      if (ICALCN.NE.NUMCAL) then
         ICALCN=NUMCAL
         WLIM=4.D0
         if (ID.EQ.0) WLIM=0.D0
         UHF=(INDEX(KEYWRD,'UHF') .NE. 0)
      end if
      NFIRST(1)=1
      NMIDLE(1)=IM-IF+1
      NLAST(1)=IL-IF+1
      NFIRST(2)=NLAST(1)+1
      NMIDLE(2)=NFIRST(2)+JM-JF
      NLAST(2)=NFIRST(2)+JL-JF
      LINEAR=(NLAST(2)*(NLAST(2)+1))/2
      do 10 I=1,LINEAR
         F(I)=0.D0
   10 H(I)=0.0D00
      do 20 I=1,LINEAR
   20 F(I)=H(I)
      JA=NFIRST(2)
      JB=NLAST(2)
      JC=NMIDLE(2)
      IA=NFIRST(1)
      IB=NLAST(1)
      IC=NMIDLE(1)
      JT=JB*(JB+1)/2
      J=2
      I=1
      NJ=NAT(2)
      NI=NAT(1)
      call H1ELEC(NI,NJ,XI(1,1),XI(1,2),SHMAT)
      if (NAT(1).EQ.102.OR.NAT(2).EQ.102) then
         K=(JB*(JB+1))/2
         do 30 J=1,K
   30    H(J)=0.D0
      else
         J1=0
         do 40 J=JA,JB
            JJ=J*(J-1)/2
            J1=J1+1
            I1=0
            do 40 I=IA,IB
               JJ=JJ+1
               I1=I1+1
               H(JJ)=SHMAT(I1,J1)
               F(JJ)=SHMAT(I1,J1)
   40    continue
      end if
      KR=1
      if (ID.EQ.0) then
         call ROTATE (NJ,NI,XI(1,2),XI(1,1),W(KR),KR,E2A,E1B,ENUCLR,100.
     1D0)
      else
         call SOLROT (NJ,NI,XI(1,2),XI(1,1),WJ,WK,KR,E2A,E1B,ENUCLR,100.
     1D0)
      if (MODE.EQ.1)CUTOFF=(WJ(1).LT.WLIM)
         if (CUTOFF) then
            do 50 I=1,KR-1
   50       WK(I)=0.D0
         end if
         do 60 I=1,KR-1
            WJS(I)=WJ(I)
            WKS(I)=WK(I)
   60    continue
      end if
C
C    * ENUCLR IS SUMMED OVER CORE-CORE REPULSION INTEGRALS.
C
      I2=0
      do 70 I1=IA,IC
         II=I1*(I1-1)/2+IA-1
         do 70 J1=IA,I1
            II=II+1
            I2=I2+1
            H(II)=H(II)+E1B(I2)
   70 F(II)=F(II)+E1B(I2)
      do  80 I1=IC+1,IB
         II=(I1*(I1+1))/2
         F(II)=F(II)+E1B(1)
   80 H(II)=H(II)+E1B(1)
      I2=0
      do 90 I1=JA,JC
         II=I1*(I1-1)/2+JA-1
         do 90 J1=JA,I1
            II=II+1
            I2=I2+1
            H(II)=H(II)+E2A(I2)
   90 F(II)=F(II)+E2A(I2)
      do 100 I1=JC+1,JB
         II=(I1*(I1+1))/2
         F(II)=F(II)+E2A(1)
  100 H(II)=H(II)+E2A(1)
      call FOCK2(F,P,PA,W, WJS, WKS,2,NFIRST,NMIDLE,NLAST)
      EE=HELECT(NLAST(2),PA,H,F)
      if ( UHF ) then
         do 110 I=1,LINEAR
  110    F(I)=H(I)
         call FOCK2(F,P,PB,W, WJS, WKS,2,NFIRST,NMIDLE,NLAST)
         EE=EE+HELECT(NLAST(2),PB,H,F)
      else
         EE=EE*2.D0
      end if
      DENER=EE+ENUCLR
      return
C
      end
