C 13 Mar 06 - TJD - soup up runs with many filled orbitals
C 17 Jan 06 - MWS - use new DDI transf common TRFDMS
C 14 Nov 05 - DGF - pad common block ENRGYS
C 19 Sep 05 - MWS - add true nuclear charge array to INFOA common
C  5 Jul 05 - MWS - SELECT NEW ATOM,BASIS,EFP,PCM,DAF DIMENSIONS
C 13 feb 05 - MWS - pad common block NSHEL
C 07 Sep 04 - MWS - pad common block INTFIL
C 23 Jul 04 - TJD - MCCPCG: carry on if nearly cvgd., or not pos.def.
C 20 Apr 04 - TJD - improve execution speed and parallel scalability
C 19 Feb 04 - TJD - fix right hand sides, and again excited states
C 16 Jan 04 - TJD - fix nact2/norb dimensioning, and excited states
C  9 Dec 03 - TJD - SOLVE CPMCHF EQUATIONS FOR ANALYTIC MCSCF HESSIANS
C
C*MODULE CPMCHF  *DECK ADVNCP
C     ---------------------------------------------
      SUBROUTINE ADVNCP(CON,NELE,NORB)
C     ---------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      INTEGER CON(*)
C
C     This routine is the same as ADVANC in ALDECI
C
      IF (CON(NELE).EQ.NORB) THEN
         DO 50 I=NELE-1,1,-1
            IF (CON(I+1)-CON(I).GT.1) THEN
               CON(I) = CON(I) + 1
               DO 40 J=I+1,NELE
                  CON(J) = CON(J-1) + 1
   40          CONTINUE
               RETURN
            ENDIF
   50    CONTINUE
      ENDIF
C
         CON(NELE) = CON(NELE)+1
C
      RETURN
      END
C*MODULE CPMCHF  *DECK CPDRD2
      SUBROUTINE CPDRD2(WAXCI,PRCNDC,CI,DFC,DERI,FCOR,ERI,INDEX,IACON1,
     *                  IACON2,IMMA,IMMC,ISPA,ISPB,ISYMA,ISYMB,ITAB,IOX,
     *                  IMUL,IPOSA,IPERA,IIND1,IBCON1,ISAS,ISBS,ISAC,
     *                  ISBC,ISTART,ISTRB,ISTRP,IFA,NINDX,NDETLN,NACT,
     *                  NCOR,NA,NB,NALP,NBLP,NSYM,NXYZ,L1,NNACT,JLO,JHI,
     *                  NCI,NSTATS)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INTEGER POSDET
C
      DIMENSION WAXCI(NXYZ,NSTATS*NDETLN),PRCNDC(*),CI(*),DFC(*),
     *          DERI(*),FCOR(*),ERI(L1,NACT,NNACT)
      DIMENSION INDEX(NINDX,NINDX),IACON1(NA),IACON2(NA),
     *          IMMA(NSYM,(NA*(NACT-NA))),IMMC(NSYM),ISPA(NALP),
     *          ISPB(NBLP),ISYMA(NALP),ISYMB(NBLP),ITAB(NSYM),IOX(NACT),
     *          IMUL(NSYM,NSYM),IPOSA(NA*(NACT-NA)),IPERA(NA*(NACT-NA)),
     *          IIND1(NA*(NACT-NA)),IBCON1(NA),ISAS(NSYM+1),
     *          ISBS(NSYM+1),ISAC(NALP),ISBC(NBLP),ISTART(NBLP),
     *          ISTRB((NBLP*(NB*(NACT-NB)))/2),
     *          ISTRP((NBLP*(NB*(NACT-NB)))/2),
     *          IFA(0:NACT,0:NACT)
C
      ICONST = 1
      IZERO = 0
C
      DO 7 I=1,NINDX
         DO 8 J=1,I
            INDEX(I,J) = I*(I-1)/2 + J
            INDEX(J,I) = INDEX(I,J)
    8    CONTINUE
    7 CONTINUE
C
      DO 30 I=1,NA
         IACON1(I) = I
   30 CONTINUE
C
C     ----- Big Loop over all alpha determinants -----
C
      DO 9000 IJK = 1,NALP
C
C          ----- Alpha excitations here -----
C          -----      Single first      -----
C
         IAC = 0
         DO 45 II=1,NSYM
            IMMC(II) = 0
   45    CONTINUE
         ICAT = ISPA(IJK)
         ISA1 = ISYMA(IJK)
         ITAS = ITAB(ISA1)
         DO 7030 IA=1,NA
             IO1 = IACON1(IA)
             IS1 = IOX(IO1)
             IST = IO1 + 1
             IEN = IACON1(IA+1)-1
             IF (IA.EQ.NA) IEN=NACT
             DO 7025 KKJ=IA+1,NA+1
                DO 7020 JJ=IST,IEN
                IS2 = IOX(JJ)
                IP1 = IMUL(IS2,IS1)
C
             IAC = IAC + 1
             CALL RET1DET(IACON1,IACON2,NA,IA,JJ,IZERO,KKJ,IPER1)
C
C          ----- Storage here for later use, well worth it -----
C
             IPET = POSDET(NACT,NA,IACON2,IFA)
             IPOSA(IAC) = ISPA(IPET)
             IMMC(ISYMA(IPET)) = IMMC(ISYMA(IPET)) + 1
             IMMA(ISYMA(IPET),IMMC(ISYMA(IPET))) = IAC
             IPERA(IAC) = ((-1)**IPER1)*ICONST
             IND = INDEX(JJ,IO1)
             IIND1(IAC) = IND
C
             IF(IS1.NE.IS2) GO TO 417
C
         DO 49 I=1,NB
            IBCON1(I) = I
   49    CONTINUE
C
C          ----- Loop over beta dets of the right symmetry -----
C
                   IJ = (IND-1)*NXYZ + 1
                   DO 407 INBB = ISBS(ISA1),ISBS(ISA1+1)-1
                   INB1 = ISBC(INBB)
                   ICIT = ICAT+ISPB(INB1)
                   ICI2 = IPOSA(IAC) + ISPB(INB1)
C
                   IF(ICIT.GE.JLO .AND. ICIT.LE.JHI) THEN
                     DO ISTAT=1,NSTATS
                       NCI2 = (ISTAT-1)*NCI + ICI2
                       FC = CI(NCI2)*IPERA(IAC)
                       IWIT = (ISTAT-1)*NDETLN + ICIT - JLO + 1
                       CALL DAXPY(NXYZ,FC,DFC(IJ),1,WAXCI(1,IWIT),1)
                     ENDDO
                   ENDIF
C
                   IF(ICI2.GE.JLO .AND. ICI2.LE.JHI) THEN
                     DO ISTAT=1,NSTATS
                       NCIT = (ISTAT-1)*NCI + ICIT
                       FC = CI(NCIT)*IPERA(IAC)
                       IWI2 = (ISTAT-1)*NDETLN + ICI2 - JLO + 1
                       CALL DAXPY(NXYZ,FC,DFC(IJ),1,WAXCI(1,IWI2),1)
                     ENDDO
                   ENDIF
  407          CONTINUE
C
                   DO 487 IK=1,NA
                      IF (IK.EQ.IA) GOTO 487
                      ION = IACON1(IK)
                      J1 = INDEX(ION,ION)
                      JJ1 = INDEX(IND,J1)
                      J2 = INDEX(ION,JJ)
                      J3 = INDEX(ION,IO1)
                      INX = INDEX(J2,J3)
C
                      IJKL = (JJ1-1)*NXYZ + 1
                      ILKJ = (INX-1)*NXYZ + 1
                   DO 413 INBB=ISBS(ISA1),ISBS(ISA1+1)-1
                      INB1 = ISBC(INBB)
                      ICIT = ICAT+ISPB(INB1)
                      ICI2 = IPOSA(IAC)+ISPB(INB1)
C
                      IF(ICIT.GE.JLO .AND. ICIT.LE.JHI) THEN
                        DO ISTAT=1,NSTATS
                          NCI2 = (ISTAT-1)*NCI + ICI2
                          FC = CI(NCI2)*IPERA(IAC)
                          IWIT = (ISTAT-1)*NDETLN + ICIT - JLO + 1
                          CALL DAXPY(NXYZ,FC,DERI(IJKL),1,
     *                               WAXCI(1,IWIT),1)
                          CALL DAXPY(NXYZ,-FC,DERI(ILKJ),1,
     *                               WAXCI(1,IWIT),1)
                        ENDDO
                      ENDIF
C
                      IF(ICI2.GE.JLO .AND. ICI2.LE.JHI) THEN
                        DO ISTAT=1,NSTATS
                          NCIT = (ISTAT-1)*NCI + ICIT
                          FC = CI(NCIT)*IPERA(IAC)
                          IWI2 = (ISTAT-1)*NDETLN + ICI2 - JLO + 1
                          CALL DAXPY(NXYZ,FC,DERI(IJKL),1,
     *                               WAXCI(1,IWI2),1)
                          CALL DAXPY(NXYZ,-FC,DERI(ILKJ),1,
     *                               WAXCI(1,IWI2),1)
                        ENDDO
                      ENDIF
  413              CONTINUE
C
  487              CONTINUE
C
                  NST = 1
                  DO 415 INBB = ISBS(ISA1),ISBS(ISA1+1)-1
                  NEND = ISBC(INBB)
                  DO 5510 KK=NST,NEND-1
                     CALL ADVANC(IBCON1,NB,NACT)
 5510             CONTINUE
                  ICIT = ICAT+ISPB(NEND)
                  ICI2 = IPOSA(IAC)+ISPB(NEND)
C
                     DO 790 IK=1,NB
                      ION = IBCON1(IK)
                      J1 = INDEX(ION,ION)
                      JJ1 = INDEX(IND,J1)
C
                      IJKL = (JJ1-1)*NXYZ + 1
C
                      IF(ICIT.GE.JLO .AND. ICIT.LE.JHI) THEN
                        DO ISTAT=1,NSTATS
                          NCI2 = (ISTAT-1)*NCI + ICI2
                          FC = CI(NCI2)*IPERA(IAC)
                          IWIT = (ISTAT-1)*NDETLN + ICIT - JLO + 1
                          CALL DAXPY(NXYZ,FC,DERI(IJKL),1,
     *                               WAXCI(1,IWIT),1)
                        ENDDO
                      ENDIF
C
                      IF(ICI2.GE.JLO .AND. ICI2.LE.JHI) THEN
                        DO ISTAT=1,NSTATS
                          NCIT = (ISTAT-1)*NCI + ICIT
                          FC = CI(NCIT)*IPERA(IAC)
                          IWI2 = (ISTAT-1)*NDETLN + ICI2 - JLO + 1
                          CALL DAXPY(NXYZ,FC,DERI(IJKL),1,
     *                               WAXCI(1,IWI2),1)
                        ENDDO
                      ENDIF
  790              CONTINUE
C
          NST = NEND
  415     CONTINUE
C
  417     CONTINUE
C
C          ----- Double excitations -----
C
          DO 4015 IAA = IA+1,NA
             IPA = IAA
             IIA = IACON1(IAA)
             IS3 = IOX(IIA)
             IF (JJ.GT.IIA) IPA = IPA - 1
             ISTAA = JJ+1
             IENAA = IEN
             DO 4010 KKJAA=KKJ,NA+1
                DO 4005 JJAA=ISTAA,IENAA
                IS4 = IOX(JJAA)
                IP2 = IMUL(IS4,IS3)
                IF (IP1.NE.IP2) GOTO 4005
C
             CALL RET1DET(IACON2,IBCON1,NA,IPA,JJAA,IZERO,KKJAA,IPER2)
             IPET = POSDET(NACT,NA,IBCON1,IFA)
             ICA1 = ISPA(IPET)
             IPERT = IPER1+IPER2
             IPERT = ((-1)**IPERT)*ICONST
                   I2 = INDEX(IACON1(IAA),JJAA)
                   INX = INDEX(I2,IND)
                   II1 = INDEX(JJAA,IO1)
                   II2 = INDEX(IACON1(IAA),JJ)
                   INX2 = INDEX(II1,II2)
C
                   IJKL = (INX-1)*NXYZ + 1
                   ILKJ = (INX2-1)*NXYZ + 1
                DO 786 INB1 = ISBS(ISA1),ISBS(ISA1+1)-1
                   NEND = ISBC(INB1)
                   ICI2 = ICA1 + ISPB(NEND)
                   ICIT = ICAT+ISPB(NEND)
C
                   IF(ICIT.GE.JLO .AND. ICIT.LE.JHI) THEN
                     DO ISTAT=1,NSTATS
                       NCI2 = (ISTAT-1)*NCI + ICI2
                       FC = CI(NCI2)*IPERT
                       IWIT = (ISTAT-1)*NDETLN + ICIT - JLO + 1
                       CALL DAXPY(NXYZ,FC,DERI(IJKL),1,WAXCI(1,IWIT),1)
                       CALL DAXPY(NXYZ,-FC,DERI(ILKJ),1,WAXCI(1,IWIT),1)
                     ENDDO
                   ENDIF
C
                   IF(ICI2.GE.JLO .AND. ICI2.LE.JHI) THEN
                     DO ISTAT=1,NSTATS
                       NCIT = (ISTAT-1)*NCI + ICIT
                       FC = CI(NCIT)*IPERT
                       IWI2 = (ISTAT-1)*NDETLN + ICI2 - JLO + 1
                       CALL DAXPY(NXYZ,FC,DERI(IJKL),1,WAXCI(1,IWI2),1)
                       CALL DAXPY(NXYZ,-FC,DERI(ILKJ),1,WAXCI(1,IWI2),1)
                     ENDDO
                   ENDIF
  786       CONTINUE
C
 4005           CONTINUE
                ISTAA = IACON1(KKJAA)+1
                IENAA = IACON1(KKJAA+1)-1
                IF (KKJAA.EQ.NA) IENAA=NACT
 4010        CONTINUE
 4015 CONTINUE
C
C
 7020           CONTINUE
                IST = IACON1(KKJ)+1
                IEN = IACON1(KKJ+1)-1
                IF (KKJ.EQ.NA) IEN=NACT
 7025        CONTINUE
 7030     CONTINUE
C
C          ----- Diagonal -----
C
            DO 67 II=1,NA
               I1 = IACON1(II)
               IND1 = INDEX(I1,I1)
C
               IJ1 = INDEX(I1+NCOR,I1+NCOR)
               IJ2 = (IND1-1)*NXYZ + 1
              DO 53 INB1 = ISBS(ISA1),ISBS(ISA1+1)-1
              NEND = ISBC(INB1)
              ICIT = ICAT+ISPB(NEND)
C
              IF(ICIT.GE.JLO .AND. ICIT.LE.JHI) THEN
                DO ISTAT=1,NSTATS
                  NCIT = (ISTAT-1)*NCI + ICIT
                  FC = CI(NCIT)
                  IWIT = (ISTAT-1)*NDETLN + ICIT - JLO + 1
                  CALL DAXPY(NXYZ,FC,DFC(IJ2),1,WAXCI(1,IWIT),1)
                  PRCNDC(IWIT) = PRCNDC(IWIT) + FCOR(IJ1)
                ENDDO
              ENDIF
   53         CONTINUE
C
               DO 64 JJ=II+1,NA
                  I2 = IACON1(JJ)
                  IND2 = INDEX(I2,I2)
                  INDM = IND2 - I2 + I1
                  J1 = INDEX(INDM,INDM)
                  J2 = INDEX(IND2,IND1)
C
                  IIKK = (J2-1)*NXYZ + 1
                  IKIK = (J1-1)*NXYZ + 1
               DO 55 INB1 = ISBS(ISA1),ISBS(ISA1+1)-1
                  NEND = ISBC(INB1)
                  ICIT = ICAT+ISPB(NEND)
C
                  IF(ICIT.GE.JLO .AND. ICIT.LE.JHI) THEN
                    DO ISTAT=1,NSTATS
                      NCIT = (ISTAT-1)*NCI + ICIT
                      FC = CI(NCIT)
                      IWIT = (ISTAT-1)*NDETLN + ICIT - JLO + 1
                      CALL DAXPY(NXYZ,FC,DERI(IIKK),1,WAXCI(1,IWIT),1)
                      CALL DAXPY(NXYZ,-FC,DERI(IKIK),1,WAXCI(1,IWIT),1)
                      DVAL = ERI(I1+NCOR,I1,IND2) - ERI(I1+NCOR,I2,INDM)
                      PRCNDC(IWIT) = PRCNDC(IWIT) + DVAL
                    ENDDO
                  ENDIF
   55          CONTINUE
C
   64          CONTINUE
C
         DO 47 I=1,NB
            IBCON1(I) = I
   47    CONTINUE
C
             NST = 1
             DO 56 INB1 = ISBS(ISA1),ISBS(ISA1+1)-1
             NEND = ISBC(INB1)
             DO 7710 KK=NST,NEND-1
                CALL ADVANC(IBCON1,NB,NACT)
 7710        CONTINUE
             ICIT = ICAT+ISPB(NEND)
C
               DO 68 JJ=1,NB
                  I2 = IBCON1(JJ)
                  IND2 = INDEX(I2,I2)
                  J2 = INDEX(IND1,IND2)
C
                  IIKK = (J2-1)*NXYZ + 1
                  FC = CI(ICIT)
                  IF(ICIT.GE.JLO .AND. ICIT.LE.JHI) THEN
                    DO ISTAT=1,NSTATS
                      NCIT = (ISTAT-1)*NCI + ICIT
                      FC = CI(NCIT)
                      IWIT = (ISTAT-1)*NDETLN + ICIT - JLO + 1
                      CALL DAXPY(NXYZ,FC,DERI(IIKK),1,WAXCI(1,IWIT),1)
                      PRCNDC(IWIT) = PRCNDC(IWIT) + ERI(I1+NCOR,I1,IND2)
                    ENDDO
                  ENDIF
   68          CONTINUE
C
            NST = NEND
   56       CONTINUE
C
   67       CONTINUE
C
C          ----- Loop over Beta dets now -----
C
         DO 40 II=1,NB
            IBCON1(II) = II
   40    CONTINUE
         JJZ = 1
C        ELSE
C        DO 41 II=1,NB
C           IBCON1(II) = IACON1(II)
C  41    CONTINUE
C        JJZ = IJK
C        ENDIF
C
         DO 8000 KJI = JJZ,NBLP
         ISTAR = ISTART(KJI)-1
         IPB1 = ISPB(KJI)
         ISB1 = ISYMB(KJI)
         ITBS = ITAB(ISB1)
         IMZZ = IMMC(ITBS)
         M1 = 0
         M2 = 0
         IF (ISB1.EQ.ITAS) M1 = 1
         IF (IMZZ.NE.0) M2 = 1
         IF (M1.EQ.0.AND.M2.EQ.0) GOTO 7998
         QNUM = 1.0D+00
         IC1 = ICAT + IPB1
C
C          ----- Beta first *********************** Single -----
C
          DO 900 IB=1,NB
             IBB = IBCON1(IB)
             IB1 = IOX(IBB)
             IR1 = IMUL(IB1,ISB1)
             IST = IBB+1
             IEN = IBCON1(IB+1)-1
             IF (IB.EQ.NB) IEN = NACT
             DO 895 KKJ=IB+1,NB+1
                DO 890 JJ=IST,IEN
                IB2 = IOX(JJ)
                ISB2 = IMUL(IR1,IB2)
                ITB2 = ITAB(ISB2)
                ISTAR = ISTAR + 1
                IF (ISB2.NE.ITAS.AND.M1.EQ.0) GOTO 890
                IF (M2.EQ.0.AND.IMMC(ITB2).EQ.0) GOTO 890
                IF (ISB2.NE.ITAS.AND.IMMC(ITB2).EQ.0) GOTO 890
C
                   IPB2 = ISTRB(ISTAR)
                   IC2 = ICAT + IPB2
                   ZPERB = ISTRP(ISTAR)/QNUM
                   IOB = INDEX(IBB,JJ)
C
            IF (M2.EQ.0.AND.IMMC(ITB2).NE.0) THEN
               DO 1013 IAT = 1,IMMC(ITB2)
                  IJU = IMMA(ITB2,IAT)
                  IC4 = IPOSA(IJU) + IPB2
                  IND = IIND1(IJU)
                  IX = INDEX(IND,IOB)
C
                  IJKL = (IX-1)*NXYZ + 1
C
                  IF(IC4.GE.JLO .AND. IC4.LE.JHI) THEN
                    DO ISTAT=1,NSTATS
                      NIC1 = (ISTAT-1)*NCI + IC1
                      FC = CI(NIC1)*IPERA(IJU)*ZPERB
                      IW4 = (ISTAT-1)*NDETLN + IC4 - JLO + 1
                      CALL DAXPY(NXYZ,FC,DERI(IJKL),1,WAXCI(1,IW4),1)
                    ENDDO
                  ENDIF
C
                  IF(IC1.GE.JLO .AND. IC1.LE.JHI) THEN
                    DO ISTAT=1,NSTATS
                      NIC4 = (ISTAT-1)*NCI + IC4
                      FC = CI(NIC4)*IPERA(IJU)*ZPERB
                      IW1 = (ISTAT-1)*NDETLN + IC1 - JLO + 1
                      CALL DAXPY(NXYZ,FC,DERI(IJKL),1,WAXCI(1,IW1),1)
                    ENDDO
                  ENDIF
 1013          CONTINUE
               GOTO 890
          ENDIF
C
            IF (M1.EQ.0.AND.ISB2.EQ.ITAS) THEN
               DO 2013 IAT =1,IMMC(ITBS)
                  IJU = IMMA(ITBS,IAT)
                  IC3 = IPOSA(IJU) + IPB1
                  IND = IIND1(IJU)
                  IX = INDEX(IND,IOB)
C
                  IJKL = (IX-1)*NXYZ + 1
C
                  IF(IC3.GE.JLO .AND. IC3.LE.JHI) THEN
                    DO ISTAT=1,NSTATS
                      NIC2 = (ISTAT-1)*NCI + IC2
                      FC = CI(NIC2)*IPERA(IJU)*ZPERB
                      IW3 = (ISTAT-1)*NDETLN + IC3 - JLO + 1
                      CALL DAXPY(NXYZ,FC,DERI(IJKL),1,WAXCI(1,IW3),1)
                    ENDDO
                  ENDIF
C
                  IF(IC2.GE.JLO .AND. IC2.LE.JHI) THEN
                    DO ISTAT=1,NSTATS
                      NIC3 = (ISTAT-1)*NCI + IC3
                      FC = CI(NIC3)*IPERA(IJU)*ZPERB
                      IW2 = (ISTAT-1)*NDETLN + IC2 - JLO + 1
                      CALL DAXPY(NXYZ,FC,DERI(IJKL),1,WAXCI(1,IW2),1)
                    ENDDO
                  ENDIF
 2013          CONTINUE
               GOTO 890
            ENDIF
C
            IF (ISB2.NE.ITAS.AND.IMMC(ITB2).NE.0) THEN
               DO 3013 IAT = 1,IMMC(ITB2)
                  IJU = IMMA(ITB2,IAT)
                  IC4 = IPOSA(IJU) + IPB2
                  IND = IIND1(IJU)
                  IX = INDEX(IND,IOB)
C
                  IJKL = (IX-1)*NXYZ + 1
C
                  IF(IC4.GE.JLO .AND. IC4.LE.JHI) THEN
                    DO ISTAT=1,NSTATS
                      NIC1 = (ISTAT-1)*NCI + IC1
                      FC = CI(NIC1)*IPERA(IJU)*ZPERB
                      IW4 = (ISTAT-1)*NDETLN + IC4 - JLO + 1
                      CALL DAXPY(NXYZ,FC,DERI(IJKL),1,WAXCI(1,IW4),1)
                    ENDDO
                  ENDIF
C
                  IF(IC1.GE.JLO .AND. IC1.LE.JHI) THEN
                    DO ISTAT=1,NSTATS
                      NIC4 = (ISTAT-1)*NCI + IC4
                      FC = CI(NIC4)*IPERA(IJU)*ZPERB
                      IW1 = (ISTAT-1)*NDETLN + IC1 - JLO + 1
                      CALL DAXPY(NXYZ,FC,DERI(IJKL),1,WAXCI(1,IW1),1)
                    ENDDO
                  ENDIF
 3013          CONTINUE
               GOTO 890
            ENDIF
C
            IF (IMMC(ITB2).EQ.0.AND.ISB2.EQ.ITAS) THEN
               DO 4013 IAT =1,IMMC(ITBS)
                  IJU = IMMA(ITBS,IAT)
                  IC3 = IPOSA(IJU) + IPB1
                  IND = IIND1(IJU)
                  IX = INDEX(IND,IOB)
C
                  IJKL = (IX-1)*NXYZ + 1
C
                  IF(IC3.GE.JLO .AND. IC3.LE.JHI) THEN
                    DO ISTAT=1,NSTATS
                      NIC2 = (ISTAT-1)*NCI + IC2
                      FC = CI(NIC2)*IPERA(IJU)*ZPERB
                      IW3 = (ISTAT-1)*NDETLN + IC3 - JLO + 1
                      CALL DAXPY(NXYZ,FC,DERI(IJKL),1,WAXCI(1,IW3),1)
                    ENDDO
                  ENDIF
C
                  IF(IC2.GE.JLO .AND. IC2.LE.JHI) THEN
                    DO ISTAT=1,NSTATS
                      NIC3 = (ISTAT-1)*NCI + IC3
                      FC = CI(NIC3)*IPERA(IJU)*ZPERB
                      IW2 = (ISTAT-1)*NDETLN + IC2 - JLO + 1
                      CALL DAXPY(NXYZ,FC,DERI(IJKL),1,WAXCI(1,IW2),1)
                    ENDDO
                  ENDIF
 4013          CONTINUE
               GOTO 890
            ENDIF
C
            IF (IMMC(ITB2).NE.0.AND.ISB2.EQ.ITAS) THEN
               DO 5013 IAT=1,IMMC(ITB2)
                  IJU = IMMA(ITB2,IAT)
                  IC3 = IPOSA(IJU) + IPB1
                  IC4 = IPOSA(IJU) + IPB2
                  IND = IIND1(IJU)
                  IX = INDEX(IND,IOB)
C
                  IJKL = (IX-1)*NXYZ + 1
C
                  IF(IC4.GE.JLO .AND. IC4.LE.JHI) THEN
                    DO ISTAT=1,NSTATS
                      NIC1 = (ISTAT-1)*NCI + IC1
                      FC = CI(NIC1)*IPERA(IJU)*ZPERB
                      IW4 = (ISTAT-1)*NDETLN + IC4 - JLO + 1
                      CALL DAXPY(NXYZ,FC,DERI(IJKL),1,WAXCI(1,IW4),1)
                    ENDDO
                  ENDIF
C
                  IF(IC1.GE.JLO .AND. IC1.LE.JHI) THEN
                    DO ISTAT=1,NSTATS
                      NIC4 = (ISTAT-1)*NCI + IC4
                      FC = CI(NIC4)*IPERA(IJU)*ZPERB
                      IW1 = (ISTAT-1)*NDETLN + IC1 - JLO + 1
                      CALL DAXPY(NXYZ,FC,DERI(IJKL),1,WAXCI(1,IW1),1)
                    ENDDO
                  ENDIF
C
                  IF(IC3.GE.JLO .AND. IC3.LE.JHI) THEN
                    DO ISTAT=1,NSTATS
                      NIC2 = (ISTAT-1)*NCI + IC2
                      FC = CI(NIC2)*IPERA(IJU)*ZPERB
                      IW3 = (ISTAT-1)*NDETLN + IC3 - JLO + 1
                      CALL DAXPY(NXYZ,FC,DERI(IJKL),1,WAXCI(1,IW3),1)
                    ENDDO
                  ENDIF
C
                  IF(IC2.GE.JLO .AND. IC2.LE.JHI) THEN
                    DO ISTAT=1,NSTATS
                      NIC3 = (ISTAT-1)*NCI + IC3
                      FC = CI(NIC3)*IPERA(IJU)*ZPERB
                      IW2 = (ISTAT-1)*NDETLN + IC2 - JLO + 1
                      CALL DAXPY(NXYZ,FC,DERI(IJKL),1,WAXCI(1,IW2),1)
                    ENDDO
                  ENDIF
 5013          CONTINUE
               GOTO 890
            ENDIF
C
  890           CONTINUE
                IST = IBCON1(KKJ)+1
                IEN = IBCON1(KKJ+1)-1
                IF (KKJ.EQ.NB) IEN=NACT
  895        CONTINUE
  900     CONTINUE
C
 7998     CONTINUE
           CALL ADVANC(IBCON1,NB,NACT)
 8000    CONTINUE
      CALL ADVANC(IACON1,NA,NACT)
 9000 CONTINUE
C
C          ----- Now for the Beta part -----
C
C
      DO 876 JJI=1,NB
         IBCON1(JJI) = JJI
  876 CONTINUE
C
      DO 9999 IJK = 1,NBLP
         ICAB = ISPB(IJK)
         ISB1 = ISYMB(IJK)
C
      DO 6030 IB=1,NB
         IST = IBCON1(IB)+1
         IEN = IBCON1(IB+1)-1
         IF (IB.EQ.NB) IEN=NACT
         IO1 = IBCON1(IB)
         IS1 = IOX(IO1)
         DO 6025 KKJ=IB+1,NB+1
            DO 6020 JJ=IST,IEN
            IS2 = IOX(JJ)
            IP1 = IMUL(IS2,IS1)
C
            CALL RET1DET(IBCON1,IACON2,NB,IB,JJ,IZERO,KKJ,IPER1)
C           IPER = ((-1)**IPER1)*2
            IPER = ((-1)**IPER1)
            IND = INDEX(JJ,IO1)
            IF (IS1.NE.IS2) GOTO 517
            IPB1 = POSDET(NACT,NB,IACON2,IFA)
            IPB1 = ISPB(IPB1)
C
       DO 89 I=1,NA
          IACON1(I) = I
   89 CONTINUE
C
C          ----- Loop over alpha -----
C
             IJ = (IND-1)*NXYZ + 1
          DO 907 INA1 = ISAS(ISB1),ISAS(ISB1+1)-1
             ICIA = ISAC(INA1)
             ICIT = ISPA(ICIA) + ICAB
             ICI2 = ISPA(ICIA) + IPB1
C
             IF(ICIT.GE.JLO .AND. ICIT.LE.JHI) THEN
               DO ISTAT=1,NSTATS
                 NCI2 = (ISTAT-1)*NCI + ICI2
                 FC = CI(NCI2)*IPER
                 IWIT = (ISTAT-1)*NDETLN + ICIT - JLO + 1
                 CALL DAXPY(NXYZ,FC,DFC(IJ),1,WAXCI(1,IWIT),1)
               ENDDO
             ENDIF
C
             IF(ICI2.GE.JLO .AND. ICI2.LE.JHI) THEN
               DO ISTAT=1,NSTATS
                 NCIT = (ISTAT-1)*NCI + ICIT
                 FC = CI(NCIT)*IPER
                 IWI2 = (ISTAT-1)*NDETLN + ICI2 - JLO + 1
                 CALL DAXPY(NXYZ,FC,DFC(IJ),1,WAXCI(1,IWI2),1)
               ENDDO
             ENDIF
  907     CONTINUE
C
             DO 687 IK=1,NB
                IF (IK.EQ.IB) GOTO 687
                ION = IBCON1(IK)
                J1 = INDEX(ION,ION)
                JJ1 = INDEX(IND,J1)
                J1 = INDEX(ION,JJ)
                J2 = INDEX(ION,IO1)
                INX = INDEX(J1,J2)
C
                IJKL = (JJ1-1)*NXYZ + 1
                ILKJ = (INX-1)*NXYZ + 1
           DO 918 INA1 = ISAS(ISB1),ISAS(ISB1+1)-1
               ICIA = ISAC(INA1)
               ICIT = ISPA(ICIA) + ICAB
               ICI2 = ISPA(ICIA) + IPB1
C
               IF(ICIT.GE.JLO .AND. ICIT.LE.JHI) THEN
                 DO ISTAT=1,NSTATS
                   NCI2 = (ISTAT-1)*NCI + ICI2
                   FC = CI(NCI2)*IPER
                   IWIT = (ISTAT-1)*NDETLN + ICIT - JLO + 1
                   CALL DAXPY(NXYZ,FC,DERI(IJKL),1,WAXCI(1,IWIT),1)
                   CALL DAXPY(NXYZ,-FC,DERI(ILKJ),1,WAXCI(1,IWIT),1)
                 ENDDO
               ENDIF
C
               IF(ICI2.GE.JLO .AND. ICI2.LE.JHI) THEN
                 DO ISTAT=1,NSTATS
                   NCIT = (ISTAT-1)*NCI + ICIT
                   FC = CI(NCIT)*IPER
                   IWI2 = (ISTAT-1)*NDETLN + ICI2 - JLO + 1
                   CALL DAXPY(NXYZ,FC,DERI(IJKL),1,WAXCI(1,IWI2),1)
                   CALL DAXPY(NXYZ,-FC,DERI(ILKJ),1,WAXCI(1,IWI2),1)
                 ENDDO
               ENDIF
  918      CONTINUE
C
  687        CONTINUE
C
            NST = 1
            DO 920 INA1 = ISAS(ISB1),ISAS(ISB1+1)-1
            NEND = ISAC(INA1)
            DO 8810 KK=NST,NEND-1
               CALL ADVANC(IACON1,NA,NACT)
 8810       CONTINUE
            ICIA = ISPA(NEND)
            ICIT = ICIA + ICAB
            ICI2 = ICIA  + IPB1
C
             DO 690 IK=1,NA
                ION = IACON1(IK)
                J1 = INDEX(ION,ION)
                JJ1 = INDEX(IND,J1)
C
                IJKK = (JJ1-1)*NXYZ + 1
                IF(ICIT.GE.JLO .AND. ICIT.LE.JHI) THEN
                  DO ISTAT=1,NSTATS
                    NCI2 = (ISTAT-1)*NCI + ICI2
                    FC = CI(NCI2)*IPER
                    IWIT = (ISTAT-1)*NDETLN + ICIT - JLO + 1
                    CALL DAXPY(NXYZ,FC,DERI(IJKK),1,WAXCI(1,IWIT),1)
                  ENDDO
                ENDIF
C
                IF(ICI2.GE.JLO .AND. ICI2.LE.JHI) THEN
                  DO ISTAT=1,NSTATS
                    NCIT = (ISTAT-1)*NCI + ICIT
                    FC = CI(NCIT)*IPER
                    IWI2 = (ISTAT-1)*NDETLN + ICI2 - JLO + 1
                    CALL DAXPY(NXYZ,FC,DERI(IJKK),1,WAXCI(1,IWI2),1)
                  ENDDO
                ENDIF
  690        CONTINUE
             NST = NEND
  920    CONTINUE
C
  517   CONTINUE
C
C          ----- Now for beta doubles -----
C
       DO 6015 IBB = IB+1,NB
               ISTBB = JJ+1
               IENBB = IEN
               JB = IBCON1(IBB)
               IS3 = IOX(JB)
               IPB = IBB
               IF (JJ.GT.JB) IPB = IPB - 1
               DO 6010 KKJBB = KKJ,NB+1
                  DO 6005 JJBB = ISTBB,IENBB
                    IS4 = IOX(JJBB)
                    IP2 = IMUL(IS4,IS3)
                    IF (IP1.NE.IP2) GOTO 6005
C
          CALL RET1DET(IACON2,IACON1,NB,IPB,JJBB,IZERO,KKJBB,IPER2)
          IBP2 = POSDET(NACT,NB,IACON1,IFA)
          IBP2 = ISPB(IBP2)
          IPER = IPER1+IPER2
C         IPER = ((-1)**IPER)*2
          IPER = ((-1)**IPER)
               I2 = INDEX(JB,JJBB)
               INX = INDEX(I2,IND)
               II1 = INDEX(JJBB,IO1)
               II2 = INDEX(JB,JJ)
               INX2 = INDEX(II1,II2)
C
               IJKL = (INX-1)*NXYZ + 1
               ILKJ = (INX2-1)*NXYZ + 1
             DO 686 INA1 = ISAS(ISB1),ISAS(ISB1+1)-1
             NEND = ISAC(INA1)
             ICIA = ISPA(NEND)
             ICIT = ICIA + ICAB
             ICI2 = ICIA + IBP2
C
             IF(ICIT.GE.JLO .AND. ICIT.LE.JHI) THEN
               DO ISTAT=1,NSTATS
                 NCI2 = (ISTAT-1)*NCI + ICI2
                 FC = CI(NCI2)*IPER
                 IWIT = (ISTAT-1)*NDETLN + ICIT - JLO + 1
                 CALL DAXPY(NXYZ,FC,DERI(IJKL),1,WAXCI(1,IWIT),1)
                 CALL DAXPY(NXYZ,-FC,DERI(ILKJ),1,WAXCI(1,IWIT),1)
               ENDDO
             ENDIF
C
             IF(ICI2.GE.JLO .AND. ICI2.LE.JHI) THEN
               DO ISTAT=1,NSTATS
                 NCIT = (ISTAT-1)*NCI + ICIT
                 FC = CI(NCIT)*IPER
                 IWI2 = (ISTAT-1)*NDETLN + ICI2 - JLO + 1
                 CALL DAXPY(NXYZ,FC,DERI(IJKL),1,WAXCI(1,IWI2),1)
                 CALL DAXPY(NXYZ,-FC,DERI(ILKJ),1,WAXCI(1,IWI2),1)
               ENDDO
             ENDIF
  686       CONTINUE
C
 6005          CONTINUE
               ISTBB = IBCON1(KKJBB)+1
               IENBB = IBCON1(KKJBB+1)-1
               IF (KKJBB.EQ.NB) IENBB=NACT
 6010      CONTINUE
 6015 CONTINUE
C
 6020       CONTINUE
            IST = IBCON1(KKJ)+1
            IEN=IBCON1(KKJ+1)-1
            IF (KKJ.EQ.NB) IEN=NACT
 6025     CONTINUE
 6030 CONTINUE
C
C          ----- Remaining part of diagonal contributions -----
C
            DO 69 II=1,NB
               I1 = IBCON1(II)
               IND1 = INDEX(I1,I1)
C
               IJ1 = INDEX(I1+NCOR,I1+NCOR)
               IJ2 = (IND1-1)*NXYZ + 1
            DO 93 INA1 = ISAS(ISB1),ISAS(ISB1+1)-1
              NEND = ISAC(INA1)
              ICIA = ISPA(NEND)
              ICIT = ICIA + ICAB
C
              IF(ICIT.GE.JLO .AND. ICIT.LE.JHI) THEN
                DO ISTAT=1,NSTATS
                  NCIT = (ISTAT-1)*NCI + ICIT
                  FC = CI(NCIT)
                  IWIT = (ISTAT-1)*NDETLN + ICIT - JLO + 1
                  CALL DAXPY(NXYZ,FC,DFC(IJ2),1,WAXCI(1,IWIT),1)
                  PRCNDC(IWIT) = PRCNDC(IWIT) + FCOR(IJ1)
                ENDDO
              ENDIF
   93       CONTINUE
C
               DO 74 JJ=II+1,NB
                  I2 = IBCON1(JJ)
                  IND2 = INDEX(I2,I2)
                  INDM = IND2-I2+I1
                  J1 = INDEX(INDM,INDM)
                  J2 = INDEX(IND2,IND1)
C
                  IIKK = (J2-1)*NXYZ + 1
                  IKIK = (J1-1)*NXYZ + 1
            DO 97 INA1 = ISAS(ISB1),ISAS(ISB1+1)-1
               NEND = ISAC(INA1)
               ICIA = ISPA(NEND)
               ICIT = ICIA + ICAB
C
               IF(ICIT.GE.JLO .AND. ICIT.LE.JHI) THEN
                 DO ISTAT=1,NSTATS
                   NCIT = (ISTAT-1)*NCI + ICIT
                   FC = CI(NCIT)
                   IWIT = (ISTAT-1)*NDETLN + ICIT - JLO + 1
                   CALL DAXPY(NXYZ,FC,DERI(IIKK),1,WAXCI(1,IWIT),1)
                   CALL DAXPY(NXYZ,-FC,DERI(IKIK),1,WAXCI(1,IWIT),1)
                   DVAL = ERI(I1+NCOR,I1,IND2) - ERI(I1+NCOR,I2,INDM)
                   PRCNDC(IWIT) = PRCNDC(IWIT) + DVAL
                 ENDDO
               ENDIF
   97       CONTINUE
C
   74          CONTINUE
C
   69       CONTINUE
           CALL ADVANC(IBCON1,NB,NACT)
 9999 CONTINUE
C
      RETURN
      END
C*MODULE CPMCHF  *DECK CPMCX
      SUBROUTINE CPMCX
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL SVDSWK,MASWRK,GOPARR,DSKWRK,SOME,PACK2E
C
      INTEGER         C_OOOO, C_VOOO, C_VVOO, C_VOVO
C
      PARAMETER (MXRT=100,MXATM=2000,MXSH=5000)
C
      DIMENSION NOCP(3*MXATM)
C
      COMMON /CIFILS/ NFT11,NFT12,NFT13,NFT14,NFT15,NFT16,IDAF20,NEMEMX
      COMMON /DLBTIM/ C_OOOO,C_VOOO,C_VVOO,C_VOVO
      COMMON /DETWFN/ WSTATE(MXRT),SPINS(MXRT),CRIT,PRTTOL,S,SZ,
     *                GRPDET,STSYM,GLIST,
     *                NFLGDM(MXRT),IWTS(MXRT),NCORSV,NCOR,NACT,NORB,
     *                NA,NB,K,KST,IROOT,IPURES,MAXW1,NITER,MAXP,NCI,
     *                IGPDET,KSTSYM,NFTGCI
      COMMON /ECP2  / CLP(400),ZLP(400),NLP(400),KFIRST(MXATM,6),
     *                KLAST(MXATM,6),LMAX(MXATM),LPSKIP(MXATM),
     *                IZCORE(MXATM)
      COMMON /ENRGYS/ ENUCR,EELCT,ETOT,STOT,SSQUAR,ECORE,ESCF,EERD,
     *                E1,E2,VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /FMCOM / X(1)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA2,NB2,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(432),INVT(48),NT
C
      INTEGER         D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB
      LOGICAL         NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /TRFDMS/ D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB,
     *                NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
C
      PARAMETER (ZERO=0.0D+00)
C
      DATA CHECK/8HCHECK   /
C
      L0 = NQMT
      L1 = NUM
      L2 = (L1*L1+L1)/2
      L3 = L1*L1
      N1 = NACT
      N2 = (N1*N1+N1)/2
      N4 = (N2*N2+N2)/2
      M1 = NCORSV+NACT
C
      NSYM = 2**IGPDET
      NXYZ = 3*NAT
      NC3 = NXYZ**2
C
      SOME = NPRINT.NE.-5 .AND. MASWRK
      NFT18 = 18
      NFT19 = 19
C
      IF(GOPARR) THEN
         CALL DDI_PROCDLB_CREATE(C_OOOO)
         CALL DDI_PROCDLB_CREATE(C_VOOO)
         CALL DDI_PROCDLB_CREATE(C_VVOO)
         CALL DDI_PROCDLB_CREATE(C_VOVO)
      END IF
C
      IF(MASWRK) WRITE(IW,9000)
      CALL FLSHBF(IW)
C
C     ----- Get memory required for whole program -----
C
      CALL GOTFM(NGOTMX)
      CALL VALFM(LOADFM)
      LIBO = LOADFM + 1
      LIND = LIBO + L1
      LIFA = LIND + L3
      LV = LIFA + ((N1+1)**2)/NWDVAR + 1
      LWRK = LV + L3
      LIA = LWRK + MAX(2*L3,N4)
      LEG = LIA + L2
      LEH = LEG + NXYZ
      LOINT = LEH + 9*(NAT*NAT+NAT)/2
      LFCOR = LOINT + L2
      LERI = LFCOR + L2
      LAMAT = LERI + L1*N1*N2
      LOPDM = LAMAT + L1*NCORSV*N2
      LEPS = LOPDM + N2
      LTPDM = LEPS + L3
      LX = LTPDM + N4
      LIX = LX + NINTMX
      LFCM = LIX + NINTMX
      LSDER = LFCM + NC3
      LDDM = LSDER + L3*NXYZ
      LSK = LDDM + 3*NXYZ
      LWSTMP = LSK + NAT
      LETMP = LWSTMP + MXRT
      LNG = LETMP + MXRT
      LAST = LNG + NXYZ
      NEED1 = LAST - LOADFM - 1
      CALL GETFM(NEED1)
C
C     ----- Determine independent orbital rotations -----
C
      CALL DERCHK(NDER)
      CALL DAREAD(IDAF,IODA,X(LIBO),L1,255,1)
      CALL FMPAIR(X(LIND),X(LIBO),NCORSV,N1,L1,L0,NROT,NDER)
C
C     ----- Determine unique xyz for which CPMCSCF is needed -----
C
      NUNIQ = 0
      DO IXYZ=1,NXYZ
        NOCP(IXYZ) = 1
      ENDDO
      DO 200 IAT=1,NAT
        NUCZ = INT(ZAN(IAT)+0.01D+00) + IZCORE(IAT)
        IF(NUCZ.EQ.0) GO TO 200
        DO IT=1,NT
          IF(MAPCTR(IAT,IT).GT.IAT) GO TO 200
        ENDDO
        IXYZ=3*(IAT-1)
        NOCP(IXYZ+1) = 0
        NOCP(IXYZ+2) = 0
        NOCP(IXYZ+3) = 0
        NUNIQ = NUNIQ + 3
  200 CONTINUE
C
C     ----- Determine quantities related to generation of -----
C     -----              coupling constants               -----
C
      CALL BINOM6(X(LIFA),N1)
      CALL MATMC2(L1,M1,NCORSV,NA,NB,X(LIFA),NSYM,IIS,NDETMX)
      CALL DAREAD(IDAF,IODA,X(LIBO),L1,262,1)
      CALL CORTRA(X(LIBO),M1,NCORSV)
      IF(NDER.NE.2) NDETMX = NCI
C
C     ----- Get memory for CPMCHF configuration solution -----
C
      NDETLN = NDETMX
      JLO = 1
      JHI = NDETMX
      IF(GOPARR) THEN
        NDETLN = NDETMX/NPROC
        NDTMOD = MOD(NDETMX,NPROC)
        IF(ME.LT.NDTMOD) THEN
          JLO = ME*(NDETLN+1) + 1
          JHI = JLO + NDETLN
        ELSE
          JLO = NDTMOD*(NDETLN+1) + (ME-NDTMOD)*NDETLN + 1
          JHI = JLO + NDETLN - 1
        ENDIF
        IF(NDTMOD.GT.0) NDETLN = NDETLN + 1
      ENDIF
C
C     ----- Determine number of spin states -----
C
      IWST = 0
      NSTATS = 0
      DO 100 IST=1,K
        IF(IPURES.EQ.1) THEN
          IF(ABS(SPINS(IST)-S) .GT. 0.03D+00) GO TO 100
          IWST = IWST + 1
        ELSE
          IWST = IWST + 1
        ENDIF
        IF(WSTATE(IWST).NE.ZERO) THEN
          NSTATS = NSTATS + 1
          X(LWSTMP+NSTATS-1) = WSTATE(IWST)
        ENDIF
  100 CONTINUE
      IF((NSTATS.NE.1) .AND. (NDER.EQ.2)) THEN
        IF(MASWRK) WRITE(IW,9005)
        CALL ABRT
      END IF
C
      NNSTAT = (NSTATS*NSTATS+NSTATS)/2
C
C     ----- Get more memory required for whole program -----
C
      CALL VALFM(LOADFM)
      LCI = LOADFM + 1
      LIWRK = LCI + NSTATS*NDETMX
      LYAO = LIWRK + IIS
      LYAC = LYAO + NUNIQ*NROT
      LYAS = LYAC + NXYZ*NSTATS*NDETLN
      LPRCDO = LYAS + NUNIQ*NNSTAT
      LPRCDC = LPRCDO + NROT
      LPRCDS = LPRCDC + NSTATS*NDETLN
      LEGRAD = LPRCDS + NNSTAT
      LAST = LEGRAD + NXYZ*NNSTAT
      NEED2 = LAST - LOADFM - 1
      CALL GETFM(NEED2)
C
C     ----- Get temporary memory -----
C
      CALL VALFM(LOADFM)
      LDFC = LOADFM + 1
      LDERI = LDFC + L2*NXYZ
      LDLAG = LDERI + N4*NXYZ
      LDSAO = LDLAG + L3*NXYZ
      LDHC = LDSAO + L3
      LTMPWK = LDHC + NXYZ
      LCIOLD = LTMPWK + NSTATS*NDETLN
      LAST = LCIOLD + K*NCI
      NEEDT = LAST - LOADFM - 1
      CALL GETFM(NEEDT)
C
      IF(SOME) WRITE(IW,9010) (NEED1+NEED2+NEEDT),NGOTMX
C
      IF(EXETYP.EQ.CHECK) THEN
         CALL VCLR(X(LEG),1,NXYZ)
         CALL DAWRIT(IDAF,IODA,X(LEG),NXYZ,3,0)
         CALL DAWRIT(IDAF,IODA,X(LEG),NXYZ,29,0)
         NEGH = NXYZ + 9*(NAT*NAT+NAT)/2
         CALL DAREAD(IDAF,IODA,X(LEG),NEGH,67,0)
         CALL CPWAB0(X(LFCM),X(LEH),NAT)
         CALL DAWRIT(IDAF,IODA,X(LFCM),NC3,4,0)
         CALL VCLR(X(LDDM),1,3*NXYZ)
         CALL DAWRIT(IDAF,IODA,X(LDDM),3*NXYZ,34,0)
         GO TO 300
      END IF
C
C     ----- Get CI vectors from file -----
C
      SVDSWK = DSKWRK
      DSKWRK = .FALSE.
      CALL SEQREW(NFT12)
      IF(MASWRK) READ(NFT12) NSTATS,NDETS
      IF(GOPARR) CALL DDI_BCAST(2150,'I',NSTATS,1,MASTER)
      IF(GOPARR) CALL DDI_BCAST(2151,'I',NDETS,1,MASTER)
C
      IF(NSTATS.NE.K .OR. NDETS.NE.NCI) THEN
        IF(MASWRK) WRITE(IW,9360) NSTATS,NDETS,K,NCI
        CALL ABRT
      END IF
C
      IWST = 0
      NSTATS = 0
      CALL DCOPY(MXRT,ESTATE,1,X(LETMP),1)
      DO 150 IST=1,K
        IF(IPURES.EQ.1) THEN
          IF(ABS(SPINS(IST)-S) .GT. 0.03D+00) THEN
            CALL SEQADV(NFT12)
            GO TO 150
          END IF
          IWST = IWST + 1
        ELSE
          IWST = IWST + 1
        ENDIF
        IF(WSTATE(IWST).NE.ZERO) NSTATS = NSTATS + 1
C
        IF(WSTATE(IWST).EQ.ZERO) THEN
          CALL SEQADV(NFT12)
          GO TO 150
        ENDIF
        IF(NDER.EQ.2) THEN
          IF(MASWRK) WRITE(IW,9060) ESTATE(IST),SPINS(IST)
        ENDIF
        LCITMP = LCIOLD + (NSTATS-1)*NCI
        CALL SQREAD(NFT12,X(LCITMP),NCI)
        ESTATE(NSTATS) = X(LETMP+IST-1)
  150 CONTINUE
      CALL SEQREW(NFT12)
      DSKWRK = SVDSWK
C
C     ----- Construct derivative overlap terms -----
C
      IF(NDER.EQ.2) THEN
        NEGH = NXYZ + 9*(NAT*NAT+NAT)/2
        CALL DAREAD(IDAF,IODA,X(LEG),NEGH,67,0)
        CALL CPWAB0(X(LFCM),X(LEH),NAT)
        CALL DAWRIT(IDAF,IODA,X(LEG),NXYZ,3,0)
        CALL DAWRIT(IDAF,IODA,X(LEG),NXYZ,29,0)
      ENDIF
C
      CALL DAREAD(IDAF,IODA,X(LEPS),L3,403,0)
      CALL DAREAD(IDAF,IODA,X(LOPDM),N2,320,0)
      CALL GTTPDM(X(LTPDM),X(LX),X(LIX),N4,NINTMX)
C
      CALL JCPOVR(X(LFCM),X(LSDER),X(LDFC),X(LDERI),X(LDLAG),X(LDHC),
     *            X(LDSAO),X(LV),X(LOINT),X(LFCOR),X(LERI),X(LAMAT),
     *            X(LOPDM),X(LTPDM),X(LPRCDO),X(LEPS),X(LWRK),
     *            X(LWRK+L3),X(LIA),X(LIND),NCORSV,N1,NXYZ,L0,L1,L2,N2,
     *            N4,NROT,NDER,NFT18)
C
C     ----- Construct configuration part of right-hand -----
C     -----          side of CPMCSCF equations         -----
C
      CALL DAREAD(IDAF,IODA,X(LEG),NXYZ,3,0)
      CALL DAREAD(IDAF,IODA,X(LNG),NXYZ,258,0)
      CALL VSUB(X(LNG),1,X(LEG),1,X(LEG),1,NXYZ)
C
      LWAXCI = LYAC
      CALL JCPDET(X(LWAXCI),X(LPRCDC),X(LPRCDS),X(LCI),X(LCIOLD),
     *            X(LDFC),X(LDERI),X(LDHC),X(LFCOR),X(LERI),X(LEGRAD),
     *            X(LOINT),X(LWSTMP),X(LIBO),X(LIFA),X(LIWRK),NDETMX,
     *            NDETLN,NCI,N1,NCORSV,NA,NB,IGPDET,KSTSYM,NSYM,IIS,
     *            IW,NXYZ,L1,JLO,JHI,NSTATS,NNSTAT,NDER)
C
C     ----- Write configuration part of right-hand side of -----
C     -----           CPMCSCF equations to file            -----
C
      SVDSWK = DSKWRK
      DSKWRK = .TRUE.
      CALL SEQOPN(NFT19,'WORK19','UNKNOWN',.FALSE.,'UNFORMATTED')
      CALL SEQREW(NFT19)
      DO IXYZ=1,NXYZ
        LVAL = LWAXCI + IXYZ - 1
        CALL DCOPY(NSTATS*NDETLN,X(LVAL),NXYZ,X(LTMPWK),1)
        CALL SQWRIT(NFT19,X(LTMPWK),NSTATS*NDETLN)
      ENDDO
C
  300 CONTINUE
      CALL RETFM(NEEDT)
      IF(MASWRK) WRITE(IW,9020)
      CALL FLSHBF(IW)
      CALL TIMIT(1)
C
C     ----- Solve CPMCSCF equations using conjugate gradient -----
C
      CALL VALFM(LOADFM)
      LRSIDO = LOADFM + 1
      LRSIDC = LRSIDO + NUNIQ*NROT
      LRSIDS = LRSIDC + NUNIQ*NDETLN*NSTATS
      LZRSO = LRSIDS + NUNIQ*NNSTAT
      LZRSC = LZRSO + NUNIQ*NROT
      LZRSS = LZRSC + NUNIQ*NDETLN*NSTATS
      LPDIRO = LZRSS + NUNIQ*NNSTAT
      LPDIRC = LPDIRO + NUNIQ*NROT
      LPDIRS = LPDIRC + NUNIQ*NDETMX*NSTATS
      LBNORM = LPDIRS + NUNIQ*NNSTAT
      LBKNUM = LBNORM + NUNIQ
      LBKDEN = LBKNUM + NUNIQ
      LTMPWK = LBKDEN + NUNIQ
      LDDEN  = LTMPWK + MAX(L3,NSTATS*NDETLN)
      LSALAG = LDDEN  + MAX(NSTATS*NSTATS*N1*N1,NUNIQ*N2)
      LSAGRD = LSALAG + NSTATS*NSTATS*L3
      LAST = LSAGRD + NSTATS*NSTATS*NXYZ
      NEEDT = LAST - LOADFM - 1
      CALL GETFM(NEEDT)
C
      IF(SOME) THEN
        WRITE(IW,9030) NROT,NDETMX
        WRITE(IW,9040) NUNIQ,0
        WRITE(IW,9045) (NEED1+NEED2+NEEDT),NGOTMX
      ENDIF
C
      DSKWRK = SVDSWK
C
      IF(EXETYP.EQ.CHECK) GO TO 400
C
      CALL MCCPCG(X(LYAO),X(LYAC),X(LYAS),X(LPRCDO),X(LPRCDC),X(LPRCDS),
     *            X(LRSIDO),X(LRSIDC),X(LRSIDS),X(LZRSO),X(LZRSC),
     *            X(LZRSS),X(LPDIRO),X(LPDIRC),X(LPDIRS),X(LBNORM),
     *            X(LBKNUM),X(LBKDEN),X(LOINT),X(LFCOR),X(LAMAT),
     *            X(LERI),X(LEPS),X(LOPDM),X(LTPDM),X(LCI),X(LTMPWK),
     *            X(LIND),X(LIA),X(LIWRK),X(LIFA),X(LIBO),NOCP,
     *            NXYZ,NUNIQ,NROT,NDETLN,NDETMX,IIS,JLO,JHI,NA,NB,NSYM,
     *            NCORSV,N1,L0,L1,L2,NFT18,NFT19,NSTATS,X(LWSTMP),
     *            X(LEGRAD),X(LSALAG))
C
C     ----- Add CPMCHF contributions to force constant matrix -----
C     -----        and symmetrize force constant matrix       -----
C
      IF(NDER.EQ.2) THEN
        CALL VCLR(X(LDDM),1,3*NXYZ)
        LDIAO = LEPS
        LDIMO = LOINT
C
        CALL FMDDEN(X(LDDEN),X(LYAC),X(LCI),X(LIFA),X(LIBO),X(LIWRK),
     *              NACT,N2,NUNIQ,NDETLN,NSYM,NA,NB,IIS,JLO,JHI)
C
        CALL UAFCM(X(LFCM),X(LDDM),X(LYAO),X(LYAC),X(LDDEN),X(LZRSO),
     *             X(LZRSC),X(LSDER),X(LCI),X(LEG),X(LOPDM),X(LV),
     *             X(LDIAO),X(LDIMO),X(LTMPWK),X(LIND),NOCP,X(LIA),L0,
     *             L1,L2,NXYZ,NUNIQ,NROT,NDETLN,NCORSV,NACT,N2,JLO,JHI,
     *             NFT18,NFT19)
C
        CALL CPSYM(X(LFCM),NXYZ)
        CALL DAWRIT(IDAF,IODA,X(LFCM),NC3,4,0)
C
        CALL VCLR(X(LFCM),1,3*NXYZ)
        CALL DAREAD(IDAF,IODA,X(LFCM),3*NXYZ,34,0)
        CALL VADD(X(LDDM),1,X(LFCM),1,X(LDDM),1,3*NXYZ)
        CALL DAWRIT(IDAF,IODA,X(LDDM),3*NXYZ,34,0)
        CALL CPSDDM(X(LDDM),X(LSK),NXYZ)
      ENDIF
C
      IF(NSTATS.GT.1) THEN
        CALL FMNAC(X(LSAGRD),X(LEGRAD),X(LNG),X(LSALAG),X(LYAO),
     *             X(LDDEN),X(LCI),X(LSDER),X(LV),X(LWRK),X(LIA),NOCP,
     *             X(LIND),X(LIFA),X(LIBO),X(LIWRK),L0,L1,NSTATS,NNSTAT,
     *             NXYZ,NUNIQ,NROT,NACT,NCORSV,NDETMX,NSYM,NA,NB,IIS)
      ENDIF
C
      CALL DCOPY(MXRT,X(LETMP),1,ESTATE,1)
C
C     ----- Return memory and counters -----
C
  400 CONTINUE
      CALL RETFM(NEEDT)
      CALL RETFM(NEED2)
      CALL RETFM(NEED1)
C
      IF(GOPARR) THEN
        CALL DDI_PROCDLB_DESTROY(C_VOVO)
        CALL DDI_PROCDLB_DESTROY(C_VVOO)
        CALL DDI_PROCDLB_DESTROY(C_VOOO)
        CALL DDI_PROCDLB_DESTROY(C_OOOO)
        IF(MASWRK) WRITE(IW,9151)
        CALL DDI_DESTROY(D_VVOO)
        IF(MASWRK) WRITE(IW,9152)
        CALL DDI_DESTROY(D_OOOO)
        IF(MASWRK) WRITE(IW,9153)
        CALL DDI_DESTROY(D_VOOO)
        IF(MASWRK) WRITE(IW,9154)
        CALL DDI_DESTROY(D_VOVO)
      ENDIF
C
      IF(MASWRK) WRITE(IW,9100)
      CALL TIMIT(1)
C
 9000 FORMAT(/5X,49(1H-)/
     *        5X,'COUPLED-PERTURBED MULTICONFIGURATION HARTREE-FOCK'/
     *        5X,49(1H-))
 9005 FORMAT(/1X,'CANNOT PERFORM HESSIAN EVALUATION FOR STATE-',
     *           'AVERAGED WAVEFUNCTION.')
 9010 FORMAT(/1X,'SETTING UP RIGHT-HAND SIDE OF CPMCHF EQUATIONS.',
     *       /1X,'# OF WORDS REQUIRED  = ',I10,
     *       /1X,'# OF WORDS AVAILABLE = ',I10)
 9020 FORMAT(/1X,'FINISHED SETTING UP RIGHT-HAND SIDE.')
 9030 FORMAT(/1X,'CALCULATING MCSCF ELECTRONIC HESSIAN ON THE FLY.',
     *       /1X,'# OF ORBITAL ROTATIONS   = ',I10,
     *       /1X,'LENGTH OF DET. EXPANSION = ',I10)
 9040 FORMAT(1X,'SOLVING FOR',I5,' NUCLEAR RESPONSES AND',I2,
     *          ' ELECTRIC FIELD RESPONSES')
 9045 FORMAT(/1X,'SOLVING CPMCHF EQUATIONS USING CG ALGORITHM.',
     *       /1X,'# OF WORDS REQUIRED  = ',I10,
     *       /1X,'# OF WORDS AVAILABLE = ',I10)
 9100 FORMAT(/1X,'...... DONE WITH CPMCHF EQUATIONS ......')
 9151 FORMAT(1X,'FREEING DISTRIBUTED STORAGE FOR',
     *          ' [VIR VIR|OCC OCC] INTEGRALS')
 9152 FORMAT(1X,'FREEING DISTRIBUTED STORAGE FOR',
     *          ' [OCC OCC|OCC OCC] INTEGRALS')
 9153 FORMAT(1X,'FREEING DISTRIBUTED STORAGE FOR',
     *          ' [VIR OCC|OCC OCC] INTEGRALS')
 9154 FORMAT(1X,'FREEING DISTRIBUTED STORAGE FOR',
     *          ' [VIR OCC|VIR OCC] INTEGRALS')
 9060 FORMAT(1X,'COMPUTING HESSIAN OF STATE WITH E=',F20.10,' S=',F5.1)
 9360 FORMAT(/1X,'***** ERROR IN -CPMCX- ROUTINE *****'/
     *       1X,'CI EIGENVECTOR FILE HAS DATA FOR NSTATE,NDETS=',I3,I10/
     *       1X,'BUT THE PRESENT CALCULATION HAS NSTATE,NDETS=',I3,I10)
      RETURN
      END
C*MODULE CPMCHF  *DECK DETCP
      SUBROUTINE DETCP(IW,IBO,NACT,NA,NB,IDSYM,ISYM1,NSYM,NALP,NBLP,
     *                 ICON,ISYMA,ISYMB,ICOA,ICOB,ITAB,IMUL,ISPA,ISPB,
     *                 ISAS,ISBS,ISAC,ISBC,NDER,NSTATS,CI,CIOLD)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION CI(*),CIOLD(*)
      DIMENSION ICON(*)
      DIMENSION ISPA(NALP),ISPB(NBLP),ICOA(NSYM),ICOB(NSYM)
      DIMENSION ISYMA(NALP),ISYMB(NBLP),ITAB(NSYM)
      DIMENSION ISAS(NSYM+1),ISBS(NSYM+1)
      DIMENSION ISAC(NALP),ISBC(NBLP)
      DIMENSION IMUL(NSYM,NSYM)
      DIMENSION IBO(NACT)
C
C     ----- This code is similar to SYMWRK in aldeci.src -----
C
      CALL GTAB(IDSYM,ISYM1,ITAB,ICON(1),ICON(4),ICON(7),ICON(10))
      CALL GMUL(IDSYM,IMUL,ICON(1),ICON(4),ICON(7),ICON(10))
C
      DO 13 II=1,NSYM
         ISAS(II) = 0
         ISBS(II) = 0
         ICOA(II) = 0
         ICOB(II) = 0
   13 CONTINUE
C
      DO 23 II=1,NB
        ICON(II) = II
   23 CONTINUE
C
      DO 43 IB=1,NBLP
        CALL GETSYM1(IW,ICON(1),NACT,NB,IBO,IDSYM,ISYM,
     *               ICON(NA+1),ICON(NA+4),ICON(NA+7),ICON(NA+10))
        ISYMB(IB) = ISYM
        ICOB(ISYM) = ICOB(ISYM) + 1
        ISPB(IB) = ICOB(ISYM)
        CALL ADVANC(ICON,NB,NACT)
   43 CONTINUE
C
      DO 33 II=1,NA
        ICON(II) = II
   33 CONTINUE
C
C     ----- Expand the ci vector over all determinants -----
C     -----     if performing hessian calculation      -----
C
      NCI = 0
      IVAL = 1
      JVAL = 1
      DO 53 IA=1,NALP
        CALL GETSYM1(IW,ICON(1),NACT,NA,IBO,IDSYM,ISYM,
     *               ICON(NA+1),ICON(NA+4),ICON(NA+7),ICON(NA+10))
        ISYMA(IA) = ISYM
        ICOA(ISYM) = ICOA(ISYM) + 1
        ISPA(IA) = NCI
        NCI = NCI + ICOB(ITAB(ISYM))
        CALL ADVANC(ICON,NA,NACT)
        IF(NDER.NE.2) GO TO 53
C
        DO 50 IB=1,NBLP
          JSYM = IMUL(ISYM,ISYMB(IB))
          IF(JSYM.EQ.ISYM1) THEN
            CI(IVAL) = CIOLD(JVAL)
            JVAL = JVAL + 1
          END IF
          IVAL = IVAL + 1
   50   CONTINUE
   53 CONTINUE
C
      IF(NDER.NE.2) THEN
        CALL DCOPY(NSTATS*NCI,CIOLD,1,CI,1)
        ISAS(1) = 1
        ISBS(1) = 1
        ISAS(NSYM+1) = NALP + 1
        ISBS(NSYM+1) = NBLP + 1
C
        DO 63 II=2,NSYM
          ISAS(II) = ISAS(II-1) + ICOA(ITAB(II-1))
          ISBS(II) = ISBS(II-1) + ICOB(ITAB(II-1))
   63   CONTINUE
C
        DO 73 II=1,NSYM
          ICOA(II) = 0
          ICOB(II) = 0
   73   CONTINUE
C
        DO 83 IA=1,NALP
          NSA = ISYMA(IA)
          ICOA(NSA) = ICOA(NSA) + 1
          ISAC(ISAS(ITAB(NSA))+ICOA(NSA)-1) = IA
   83   CONTINUE
C
        DO 93 IB=1,NBLP
          NSA = ISYMB(IB)
          ICOB(NSA) = ICOB(NSA) + 1
          ISBC(ISBS(ITAB(NSA))+ICOB(NSA)-1) = IB
   93   CONTINUE
C
        RETURN
      ENDIF
C
C     ----- Now reset quantities to reflect C1 symmetry -----
C     -----      if performing hessian calculation      -----
C
      DO 103 IB=1,NBLP
        ISYMB(IB) = 1
        ICOB(1) = IB
        ISPB(IB) = ICOB(1)
        ISBC(IB) = IB
  103 CONTINUE
C
      NCI = 0
      DO 113 IA=1,NALP
        ISYMA(IA) = 1
        ICOA(1) = IA
        ISPA(IA) = NCI
        ISAC(IA) = IA
        NCI = NCI + NBLP
  113 CONTINUE
C
      ISAS(1) = 1
      ISBS(1) = 1
      ISAS(2) = NALP + 1
      ISBS(2) = NBLP + 1
C
      DO 123 II=1,NACT
        IBO(II) = 1
  123 CONTINUE
C
      CALL GTAB(1,1,ITAB,ICON(1),ICON(4),ICON(7),ICON(10))
      CALL GMUL(1,IMUL,ICON(1),ICON(4),ICON(7),ICON(10))
C
      RETURN
      END
C*MODULE CPMCHF  *DECK FMDDEN
      SUBROUTINE FMDDEN(DDEN,YAC,CI,IFA,IOX,IWRK,NACT,NNACT,NUNIQ,
     *                  NDETLN,NSYM,NA,NB,IIS,JLO,JHI)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION DDEN(NUNIQ,NNACT),YAC(NUNIQ,NDETLN),CI(*)
      DIMENSION IFA(0:NACT,0:NACT),IOX(NACT),IWRK(IIS)
C
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      NALP = IFA(NACT,NA)
      NBLP = IFA(NACT,NB)
C
      ISYMA = 1
      ISYMB = ISYMA + NALP
      ICOA = ISYMB + NBLP
      ICOB = ICOA + NSYM
      ITAB = ICOB + NSYM
      IMUL = ITAB + NSYM
      ISPA = IMUL + NSYM*NSYM
      ISPB = ISPA + NALP
      ISAS = ISPB + NBLP
      ISBS = ISAS + NSYM+1
      ISAC = ISBS + NSYM+1
      ISBC = ISAC + NALP
C
      IACON1 = ISBC + NBLP
      IBCON1 = IACON1 + NA + 43
      IACON2 = IBCON1 + NA
      IBCON2 = IACON2 + NA
      IPOSA = IBCON2 + NB
      IPERA = IPOSA + (NA*(NACT-NA))
      IIND1 = IPERA + (NA*(NACT-NA))
      INDEX = IIND1 + (NA*(NACT-NA))
      ITOT = INDEX + NACT*NACT - 1
C
      IF (ITOT.GT.IIS) THEN
         IF(MASWRK) THEN
           WRITE(IW,*) 'NOT ENOUGH MEMORY SPECIFIED FOR IWRK'
           WRITE(IW,*) 'ASKED FOR ',IIS,' NEED ',ITOT
         END IF
         CALL ABRT
      ENDIF
C
      CALL MATDD1(DDEN,YAC,CI,NNACT,NUNIQ,NACT,NA,NB,NDETLN,NALP,NBLP,
     *            IFA,IOX,NSYM,IWRK(IACON1),IWRK(IBCON1),IWRK(IACON2),
     *            IWRK(IPOSA),IWRK(IPERA),IWRK(IIND1),IWRK(INDEX),
     *            IWRK(ISYMA),IWRK(ISYMB),IWRK(ISPA),IWRK(ISPB),
     *            IWRK(ISAS),IWRK(ISBS),IWRK(ISAC),IWRK(ISBC),JLO,JHI)
C
      IF(GOPARR) CALL DDI_GSUMF(2188,DDEN,NUNIQ*NNACT)
C
      RETURN
      END
C*MODULE CPMCHF  *DECK FMNAC
      SUBROUTINE FMNAC(SAGRAD,EGRAD,DNUC,SALAG,YAO,TDEN,CIVEC,SDER,V,
     *                 WRK,IA,NOCP,INDEX,IFA,IOX,IWRK,L0,L1,NSTATS,
     *                 NNSTAT,NXYZ,NUNIQ,NROT,NACT,NCOR,NDETMX,NSYM,
     *                 NA,NB,IIS)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION SAGRAD(NXYZ,NSTATS*NSTATS),EGRAD(NXYZ,NNSTAT),
     *          DNUC(NXYZ),SALAG(L1,L1,NSTATS*NSTATS),YAO(NUNIQ,NROT),
     *          TDEN(NACT,NACT,NSTATS*NSTATS),CIVEC(NDETMX,NSTATS),
     *          SDER(NXYZ,L1,L1),V(L1,L1),WRK(*)
      DIMENSION IA(*),NOCP(NXYZ),INDEX(L1,L1),IFA(*),IOX(*),IWRK(IIS)
C
      PARAMETER (MXGTOT=20000,MXSH=5000,MXRT=100)
C
      COMMON /ENRGYS/ ENUCR,EELCT,ETOT,SZ,SZZ,ECORE,ESCF,EERD,E1,E2,
     *                VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
C
      PARAMETER (ZERO=0.0D+00,ONE=1.0D+00,TWO=2.0D+00)
C
      L3 = L1*L1
      NSTAT2 = NSTATS*NSTATS
C
      DO 20 ISTAT=1,NSTATS
        DO 20 JSTAT=1,NSTATS
          IG = MAX(ISTAT,JSTAT)
          JG = MIN(ISTAT,JSTAT)
          IJG = IA(IG) + JG
          IJSTAT = (ISTAT-1)*NSTATS + JSTAT
          CALL DCOPY(NXYZ,EGRAD(1,IJG),1,SAGRAD(1,IJSTAT),1)
          IF(ISTAT.NE.JSTAT) THEN
            EVAL = ESTATE(ISTAT) - ESTATE(JSTAT)
            EVAL = ONE/EVAL
            CALL DSCAL(NXYZ,EVAL,SAGRAD(1,IJSTAT),1)
          ELSE
            CALL VADD(DNUC,1,SAGRAD(1,IJSTAT),1,SAGRAD(1,IJSTAT),1,NXYZ)
          ENDIF
   20 CONTINUE
      CALL PRSQ(SAGRAD,NSTATS*NSTATS,NXYZ,NXYZ)
C
C     ----- Generate CI portion of non-adiabatic coupling -----
C     -----  matrix elements, noting that diagonal terms  -----
C     -----   are state-averaged MCSCF energy gradients   -----
C
      DO 100 I=1,L0
        DO 100 J=1,I
          IPHSE = INDEX(I,J)
          IROT = IABS(IPHSE)
          IF(IROT.EQ.0) GO TO 100
C
          DO 90 ISTAT=1,NSTATS
            DO 90 JSTAT=1,NSTATS
              IJSTAT = (ISTAT-1)*NSTATS + JSTAT
              EVAL = ONE
              IF(ISTAT.NE.JSTAT) EVAL = ESTATE(ISTAT) - ESTATE(JSTAT)
              DVAL = SALAG(I,J,IJSTAT) - SALAG(J,I,IJSTAT)
              DVAL = TWO*DVAL/EVAL
              IUNIQ = 0
              DO 80 IXYZ=1,NXYZ
                IF(NOCP(IXYZ).EQ.1) GO TO 80
                IUNIQ = IUNIQ + 1
                DTMP = YAO(IUNIQ,IROT)*DVAL
                SAGRAD(IXYZ,IJSTAT) = SAGRAD(IXYZ,IJSTAT) + DTMP
   80         CONTINUE
   90     CONTINUE
  100 CONTINUE
      CALL PRSQ(SAGRAD,NSTATS*NSTATS,NXYZ,NXYZ)
C
C     ----- Generate CSF portion of non-adiabatic coupling -----
C     -----                 matrix elements                -----
C
      CALL FMTDEN(TDEN,CIVEC,IFA,IOX,IWRK,NACT,NSTATS,NDETMX,NSYM,
     *            NA,NB,IIS)
C
      DO 200 IXYZ=1,NXYZ
        DO 150 I=1,NACT
          DO 150 J=1,NACT
            SVAL = SDER(IXYZ,I+NCOR,J+NCOR)
            SVAL = SVAL/TWO
            DO 120 ISTAT=1,NSTATS
              DO 120 JSTAT=1,NSTATS
                IF(ISTAT.EQ.JSTAT) GO TO 120
                IJSTAT = (ISTAT-1)*NSTATS + JSTAT
                DVAL = SVAL*TDEN(I,J,IJSTAT)
                SAGRAD(IXYZ,IJSTAT) = SAGRAD(IXYZ,IJSTAT) - DVAL
  120       CONTINUE
  150   CONTINUE
  200 CONTINUE
      CALL PRSQ(SAGRAD,NSTATS*NSTATS,NXYZ,NXYZ)
C
      DO 300 MU=1,L1
        DO 300 NU=1,L1
          DO 250 ISTAT=1,NSTAT2
            DVAL = ZERO
            DO 220 I=1,NACT
              CVAL = V(MU,I+NCOR)
              DO 220 J=1,NACT
                DVAL = DVAL + CVAL*V(NU,J+NCOR)*TDEN(I,J,ISTAT)
  220       CONTINUE
            SALAG(MU,NU,ISTAT) = DVAL
  250     CONTINUE
  300 CONTINUE
C
      DO 400 M=1,3
        IF(M.EQ.1) CALL DAREAD(IDAF,IODA,WRK,L3,63,0)
        IF(M.EQ.2) CALL DAREAD(IDAF,IODA,WRK,L3,64,0)
        IF(M.EQ.3) CALL DAREAD(IDAF,IODA,WRK,L3,65,0)
        DO 360 ISHELL=1,NSHELL
          IAT  = KATOM(ISHELL)
          IXYZ = 3*(IAT-1)
          LOCI = KLOC(ISHELL) - KMIN(ISHELL)
          MINI = KMIN(ISHELL)
          MAXI = KMAX(ISHELL)
          DO 340 ISTAT=1,NSTATS
            DO 340 JSTAT=1,NSTATS
              IF(ISTAT.EQ.JSTAT) GO TO 340
              IJSTAT = (ISTAT-1)*NSTATS + JSTAT
              DVAL = ZERO
C
              DO 320 I=MINI,MAXI
                II = LOCI + I
                DO 320 JJ=1,L1
                  IIJJ = (JJ-1)*L1 + II
                  DVAL = DVAL + SALAG(JJ,II,IJSTAT)*WRK(IIJJ)
  320         CONTINUE
C
              SAGRAD(IXYZ+M,IJSTAT) = SAGRAD(IXYZ+M,IJSTAT) + DVAL
  340     CONTINUE
  360   CONTINUE
  400 CONTINUE
      CALL PRSQ(SAGRAD,NSTATS*NSTATS,NXYZ,NXYZ)
C
C     ----- Since we have a CASSCF wavefunction, we don't need -----
C     ----- to consider the perturbed orbital contribution to  -----
C     -----                      CSF NACME                     -----
C
CTJD      DO ISTAT=1,NSTATS*NSTATS
CTJD        CALL PRSQ(TDEN(1,1,ISTAT),NACT,NACT,NACT)
CTJD      ENDDO
C
      RETURN
      END
C*MODULE CPMCHF  *DECK FMPAIR
      SUBROUTINE FMPAIR(INDEX,IOX,NCOR,NACT,NUM,NQMT,NROT,NDER)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION INDEX(NUM,NUM),IOX(NUM)
C
C     Determine independent orbital rotations for CASSCF
C     wavefunctions
C
      NOCC = NCOR+NACT
      L3 = NUM**2
      CALL VICLR(INDEX,1,L3)
C
C     Active-core
C
      IJ=-1
      DO 100 I=NCOR+1,NOCC
        IS1 = IOX(I)
        DO 80 J=1,NCOR
          IS2 = IOX(J)
          IF((IS1.NE.IS2) .AND. (NDER.NE.2)) GO TO 80
          INDEX(J,I) = IJ
          INDEX(I,J) = IABS(IJ)
          IJ = IJ-1
   80   CONTINUE
  100 CONTINUE
C
C     Virtual-occupied
C
      DO 200 I=NOCC+1,NQMT
        IS1 = IOX(I)
        DO 180 J=1,NOCC
          IS2 = IOX(J)
          IF((IS1.NE.IS2) .AND. (NDER.NE.2)) GO TO 180
          INDEX(J,I) = IJ
          INDEX(I,J) = IABS(IJ)
          IJ = IJ-1
  180   CONTINUE
  200 CONTINUE
C
      NROT = IABS(IJ) - 1
C
      RETURN
      END
C*MODULE CPMCHF  *DECK FMRHS
      SUBROUTINE FMRHS(RHSO,RHSC,RHSS,CI,EGRAD,WSTATE,WRK,INDEX,NOCP,
     *                 NXYZ,NUNIQ,NROT,NDETLN,NOCC,L1,NFT18,NFT19,
     *                 NSTATS,JLO,JHI,NCI,NNSTAT)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,SVDSWK
C
      DIMENSION RHSO(NUNIQ,NROT),RHSC(NUNIQ,NSTATS*NDETLN),
     *          RHSS(NUNIQ,NNSTAT),CI(NCI,NSTATS),EGRAD(NXYZ,NNSTAT),
     *          WSTATE(*),WRK(*)
      DIMENSION INDEX(L1,L1),NOCP(NXYZ)
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (TWO=2.0D+00)
C
      CALL VCLR(RHSO,1,NUNIQ*NROT)
      CALL VCLR(RHSS,1,NUNIQ*NNSTAT)
      L3 = L1*L1
      NDETS = JHI-JLO+1
C
C     ----- Form orbital part of rhs of CPMCSCF equations -----
C
      SVDSWK = DSKWRK
      DSKWRK = .FALSE.
      CALL SEQREW(NFT18)
      IUNIQ = 0
C
      DO 100 IXYZ=1,NXYZ
        CALL SQREAD(NFT18,WRK,L3)
        IF(NOCP(IXYZ).EQ.1) GO TO 100
        IUNIQ=IUNIQ+1
C
        DO 50 J=1,NOCC
          DO 50 I=1,L1
            IJ = (J-1)*L1 + I
            IPHSE = INDEX(I,J)
            IROT = IABS(IPHSE)
            IF(IROT.EQ.0) GO TO 50
            DLT = IROT
            DLT = DLT/IPHSE
            RHSO(IUNIQ,IROT) = RHSO(IUNIQ,IROT) + DLT*WRK(IJ)
   50   CONTINUE
  100 CONTINUE
      CALL DSCAL(NUNIQ*NROT,TWO,RHSO,1)
C
C     ----- Form configuration part of rhs of CPMCSCF equations -----
C
      DSKWRK = .TRUE.
      CALL SEQREW(NFT19)
      IUNIQ = 0
C
      DO 200 IXYZ=1,NXYZ
        IF(NOCP(IXYZ).EQ.1) THEN
          CALL SEQADV(NFT19)
          GO TO 200
        ENDIF
C
        IUNIQ = IUNIQ + 1
        LENDAT = NSTATS*NDETLN
        CALL SQREAD(NFT19,WRK,LENDAT)
        CALL DCOPY(NSTATS*NDETLN,WRK,1,RHSC(IUNIQ,1),NUNIQ)
C
        DO 150 ISTAT=1,NSTATS
          II = (ISTAT-1)*NDETLN + 1
          DO 150 JSTAT=1,NSTATS
            IG = MAX(ISTAT,JSTAT)
            JG = MIN(ISTAT,JSTAT)
            IJ = (IG*IG-IG)/2 + JG
            DVAL = EGRAD(IXYZ,IJ)
            CALL DAXPY(NDETS,-DVAL,CI(JLO,JSTAT),1,RHSC(IUNIQ,II),NUNIQ)
  150   CONTINUE
C
C     ----- Form state-state part of rhs of CPMCSCF equations -----
C
        IJSTAT = 0
        DO 180 ISTAT=1,NSTATS
          DO 180 JSTAT=1,ISTAT-1
            IJSTAT = IJSTAT + 1
            IJ = (ISTAT*ISTAT-ISTAT)/2 + JSTAT
            DVAL = WSTATE(JSTAT)-WSTATE(ISTAT)
            DVAL = TWO*DVAL
            RHSS(IUNIQ,IJSTAT) = DVAL*EGRAD(IXYZ,IJ)
  180   CONTINUE
  200 CONTINUE
C
      DO ISTAT=1,NSTATS
        IVAL = (ISTAT-1)*NDETLN + 1
        DVAL = TWO*WSTATE(ISTAT)
        CALL DSCAL(NUNIQ*NDETLN,DVAL,RHSC(1,IVAL),1)
      ENDDO
C
      DSKWRK = SVDSWK
C
      RETURN
      END
C*MODULE CPMCHF  *DECK FMTDEN
      SUBROUTINE FMTDEN(TDEN,CI,IFA,IOX,IWRK,NACT,NSTATS,NDETMX,NSYM,
     *                  NA,NB,IIS)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION TDEN(NACT,NACT,NSTATS*NSTATS),CI(NDETMX,NSTATS)
      DIMENSION IFA(0:NACT,0:NACT),IOX(NACT),IWRK(IIS)
C
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      NALP = IFA(NACT,NA)
      NBLP = IFA(NACT,NB)
C
      ISYMA = 1
      ISYMB = ISYMA + NALP
      ICOA = ISYMB + NBLP
      ICOB = ICOA + NSYM
      ITAB = ICOB + NSYM
      IMUL = ITAB + NSYM
      ISPA = IMUL + NSYM*NSYM
      ISPB = ISPA + NALP
      ISAS = ISPB + NBLP
      ISBS = ISAS + NSYM+1
      ISAC = ISBS + NSYM+1
      ISBC = ISAC + NALP
C
      IACON1 = ISBC + NBLP
      IBCON1 = IACON1 + NA + 43
      IACON2 = IBCON1 + NA
      IBCON2 = IACON2 + NA
      IPOSA = IBCON2 + NB
      IPERA = IPOSA + (NA*(NACT-NA))
      IIND1 = IPERA + (NA*(NACT-NA))
      INDEX = IIND1 + (NA*(NACT-NA))
      ITOT = INDEX + NACT*NACT - 1
C
      IF (ITOT.GT.IIS) THEN
         IF(MASWRK) THEN
           WRITE(IW,*) 'NOT ENOUGH MEMORY SPECIFIED FOR IWRK'
           WRITE(IW,*) 'ASKED FOR ',IIS,' NEED ',ITOT
         END IF
         CALL ABRT
      ENDIF
C
      CALL MATTD1(TDEN,CI,NSTATS,NACT,NA,NB,NDETMX,NALP,
     *            NBLP, IFA,IOX,NSYM,IWRK(IACON1),IWRK(IBCON1),
     *            IWRK(IACON2),IWRK(IPOSA),IWRK(IPERA),IWRK(IIND1),
     *            IWRK(INDEX),IWRK(ISYMA),IWRK(ISYMB),IWRK(ISPA),
     *            IWRK(ISPB),IWRK(ISAS),IWRK(ISBS),IWRK(ISAC),
     *            IWRK(ISBC))
C
      RETURN
      END
C*MODULE CPMCHF  *DECK GTTPDM
      SUBROUTINE GTTPDM(TPDM,XX,IX,NIJKL,NINTMX)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,DWSAVE
C
      DIMENSION TPDM(NIJKL),XX(*),IX(*)
C
      COMMON /CIFILS/ NFT11,NFT12,NFT13,NFT14,NFT15,NFT16,IDAF20,NEMEMX
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCKLAB/ LABSIZ
C
      CALL VCLR(TPDM,1,NIJKL)
      DWSAVE = DSKWRK
      DSKWRK = .FALSE.
C
      IF(MASWRK) THEN
        CALL SEQREW(NFT15)
 2000   CONTINUE
        CALL PREAD(NFT15,XX,IX,NXX,NINTMX)
        IF(NXX.NE.0) THEN
          MGIJKL=IABS(NXX)
          IF(MGIJKL.GT.NINTMX) CALL ABRT
          DO 2100 MG=1,MGIJKL
             GGIJKL=XX(MG)
C
             NPACK = MG
             IF (LABSIZ .EQ. 2) THEN
*I32              LABEL1 = IX( 2*NPACK - 1 )
*I32              LABEL2 = IX( 2*NPACK     )
*I32              IPACK = ISHFT( LABEL1, -16 )
*I32              JPACK = IAND( LABEL1, 65535 )
*I32              KPACK = ISHFT( LABEL2, -16 )
*I32              LPACK = IAND( LABEL2, 65535 )
*I64              LABEL = IX(NPACK)
*I64              IPACK = ISHFT( LABEL, -48 )
*I64              JPACK = IAND( ISHFT( LABEL, -32 ), 65535 )
*I64              KPACK = IAND( ISHFT( LABEL, -16 ), 65535 )
*I64              LPACK = IAND( LABEL, 65535 )
              ELSE IF (LABSIZ .EQ. 1) THEN
*I32              LABEL = IX(NPACK)
*I32              IPACK = ISHFT( LABEL, -24 )
*I32              JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I32              KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I32              LPACK = IAND( LABEL, 255 )
*I64              IF ( MOD(NPACK,2) .EQ. 0 ) THEN
*I64                LABEL = IX( NPACK/2 )
*I64                IPACK = IAND( ISHFT( LABEL, -24 ), 255 )
*I64                JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I64                KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I64                LPACK = IAND( LABEL, 255 )
*I64            ELSE
*I64                LABEL = IX( (NPACK/2)+1 )
*I64                IPACK = ISHFT( LABEL, -56 )
*I64                JPACK = IAND( ISHFT( LABEL, -48 ), 255 )
*I64                KPACK = IAND( ISHFT( LABEL, -40 ), 255 )
*I64                LPACK = IAND( ISHFT( LABEL, -32 ), 255 )
*I64            END IF
              END IF
              IG = IPACK
              JG = JPACK
              KG = KPACK
              LG = LPACK
C
              II = MAX(IG,JG)
              JJ = MIN(IG,JG)
              IJ = (II*II-II)/2 + JJ
              KK = MAX(KG,LG)
              LL = MIN(KG,LG)
              KL = (KK*KK-KK)/2 + LL
              IJG = MAX(IJ,KL)
              KLG = MIN(IJ,KL)
              IJKL = (IJG*IJG-IJG)/2 + KLG
C
              TPDM(IJKL) = GGIJKL
 2100     CONTINUE
          IF(NXX.GT.0) GO TO 2000
        END IF
C
      ENDIF
C
      IF(GOPARR) CALL DDI_BCAST(2150,'F',TPDM,NIJKL,MASTER)
      DSKWRK = DWSAVE
C
      RETURN
      END
C*MODULE CPMCHF  *DECK HSMLTC
      SUBROUTINE HSMLTC(RHSC,RHSO,RHSS,YAO,YAC,YAS,PRCNDS,SALAG,CI,OINT,
     *                  FCOR,AMAT,ERI,IROT,IWRK,IFA,IOX,NCOR,NACT,NA,NB,
     *                  L1,L2,NSYM,IIS,NDETMX,NDETLN,NROT,NUNIQ,JLO,JHI,
     *                  NSTATS,WSTATE)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION RHSC(NUNIQ,NSTATS*NDETLN),RHSO(NUNIQ,NROT),
     *          RHSS(NUNIQ,*),YAO(NUNIQ,NROT),YAC(NUNIQ,NSTATS*NDETMX),
     *          YAS(NUNIQ,*),PRCNDS(*),SALAG(L1,L1,NSTATS*NSTATS),
     *          CI(NDETMX,NSTATS),OINT(L2),FCOR(L2),AMAT(*),ERI(*),
     *          WSTATE(*)
      DIMENSION IROT(L1,L1),IWRK(IIS),IFA(0:NACT,0:NACT),IOX(NACT)
C
      PARAMETER (MXRT=100)
C
      COMMON /ENRGYS/ ENUCR,EELCT,ETOT,SZ,SZZ,ECORE,ESCF,EERD,E1,E2,
     *                VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (HALF=0.5D+00, FOUR=4.0D+00, TOL=1.0D-09)
C
      NALP = IFA(NACT,NA)
      NBLP = IFA(NACT,NB)
      NINDX = (NACT**2+NACT)/2
      IF(L1.GT.NINDX) NINDX = L1
      NNSTAT = (NSTATS*NSTATS+NSTATS)/2
      L3 = L1*L1
C
      CALL VCLR(RHSC,1,NDETLN*NSTATS*NUNIQ)
      CALL VCLR(RHSS,1,NUNIQ*NNSTAT)
      CALL VCLR(SALAG,1,L3*NSTATS*NSTATS)
C
      ISYMA = 1
      ISYMB = ISYMA + NALP
      ICOA = ISYMB + NBLP
      ICOB = ICOA + NSYM
      ITAB = ICOB + NSYM
      IMUL = ITAB + NSYM
      ISPA = IMUL + NSYM*NSYM
      ISPB = ISPA + NALP
      ISAS = ISPB + NBLP
      ISBS = ISAS + NSYM+1
      ISAC = ISBS + NSYM+1
      ISBC = ISAC + NALP
C
      IACON1 = ISBC + NBLP
      IBCON1 = IACON1 + NA + 43
      IACON2 = IBCON1 + NA
      IBCON2 = IACON2 + NA
      IPOSA = IBCON2 + NB
      IPERA = IPOSA + (NA*(NACT-NA))
      IIND1 = IPERA + (NA*(NACT-NA))
      INDEX = IIND1 + 3*(NA*(NACT-NA))
      IMMA = INDEX + NINDX**2
      IMMC = IMMA + NSYM*(NA*(NACT-NA))
      ISTRB = IMMC + NSYM
      ISTRP = ISTRB + ((NB*(NACT-NB))*NBLP)/2
      ISTAR = ISTRP + ((NB*(NACT-NB))*NBLP)/2
      ITOT = ISTAR + NBLP - 1
C
      IF(ITOT.GT.IIS) THEN
        IF(MASWRK) THEN
          WRITE(IW,*) 'NOT ENOUGH MEMORY SPECIFIED FOR IWRK'
          WRITE(IW,*) 'ASKED FOR ',IIS,' NEED ',ITOT
        END IF
        CALL ABRT
      END IF
C
      CALL SETUP(NACT,0,NA,NB,IWRK(IBCON1),
     *           IWRK(IACON2),IFA,IWRK(INDEX),IWRK(ISPB),NBLP,
     *           IWRK(ISTRB),IWRK(ISTRP),IWRK(ISTAR))
C
C     ----- Calculate terms independent of coupling constants -----
C
      DHCME = ENUCR
      DO I=1,NCOR
        II = (I*I+I)/2
        DHCME = DHCME + OINT(II) + FCOR(II)
      ENDDO
C
      DO 500 M=JLO,JHI
        DO 450 ISTAT=1,NSTATS
          CVAL = CI(M,ISTAT)
          WVAL = WSTATE(ISTAT)
          IWIM = (ISTAT-1)*NDETLN + M - JLO + 1
          IYIM = (ISTAT-1)*NDETMX + M
          IF(ABS(CVAL).LT.TOL) GO TO 250
C
C          ----- Configuation/Orbital Cross Terms -----
C
          DO 200 I=1,L1
            DO 200 J=1,NCOR
              IPHSE = IROT(I,J)
              IF(IPHSE.EQ.0) GO TO 200
              DVAL = FOUR*CVAL
              IF(J.GT.I) GO TO 100
              JI = (I*I-I)/2 + J
              GO TO 150
  100         JI = (J*J-J)/2 + I
  150         DVAL = DVAL*FCOR(JI)
              DO JSTAT=1,NSTATS
                DTMP = DVAL*CI(M,JSTAT)
                IJSTAT = (ISTAT-1)*NSTATS + JSTAT
                SALAG(I,J,IJSTAT) = SALAG(I,J,IJSTAT) + DTMP
              ENDDO
C
              IJ = IABS(IPHSE)
              DVAL = DVAL*IJ/IPHSE
              DVAL = DVAL*WVAL
              IF(ABS(DVAL).LT.TOL) GO TO 200
              CALL DAXPY(NUNIQ,DVAL,YAO(1,IJ),1,RHSC(1,IWIM),1)
              CALL DAXPY(NUNIQ,DVAL,YAC(1,IYIM),1,RHSO(1,IJ),1)
  200     CONTINUE
C
C          ----- Configuration Hessian Terms -----
C
  250     DVAL = WVAL*(DHCME-ESTATE(ISTAT))
          CALL DAXPY(NUNIQ,DVAL,YAC(1,IYIM),1,RHSC(1,IWIM),1)
C
          DO 400 JSTAT=1,NSTATS
            CMVAL = CI(M,JSTAT)
            IF(ABS(CMVAL).LT.TOL) GO TO 400
            DO 300 N=1,NDETMX
              CNVAL = CI(N,JSTAT)
              IF(ABS(CNVAL).LT.TOL) GO TO 300
              IYIN = (ISTAT-1)*NDETMX + N
              DVAL = ESTATE(ISTAT) - ESTATE(JSTAT)
              DVAL = DVAL*WSTATE(ISTAT)
              DVAL = DVAL + HALF
              DVAL = DVAL*CMVAL*CNVAL
              CALL DAXPY(NUNIQ,DVAL,YAC(1,IYIN),1,RHSC(1,IWIM),1)
  300       CONTINUE
  400     CONTINUE
C
  450   CONTINUE
  500 CONTINUE
C
C     ----- Calculate terms dependent on coupling constants -----
C
      CALL HSSCX2(NACT,NCOR,NA,NB,NALP,NBLP,IFA,IOX,NSYM,IWRK(IACON1),
     *            IWRK(IBCON1),IWRK(IACON2),IWRK(IPOSA),IWRK(IPERA),
     *            IWRK(IIND1),IWRK(INDEX),IWRK(IMMA),IWRK(IMMC),
     *            IWRK(ISYMA),IWRK(ISYMB),IWRK(ITAB),IWRK(IMUL),
     *            IWRK(ISPA),IWRK(ISPB),IWRK(ISAS),IWRK(ISBS),
     *            IWRK(ISAC),IWRK(ISBC),IWRK(ISTRB),IWRK(ISTRP),
     *            IWRK(ISTAR),CI,FCOR,AMAT,ERI,L1,L2,NROT,NDETMX,IROT,
     *            RHSC,RHSO,YAO,YAC,NDETLN,NUNIQ,NINDX,JLO,JHI,NSTATS,
     *            WSTATE,SALAG)
C
C     ----- Finish with Lagrangian terms -----
C
      CALL DSCAL(L3*NSTATS*NSTATS,HALF,SALAG,1)
      IF(GOPARR) CALL DDI_GSUMF(2174,SALAG,L3*NSTATS*NSTATS)
C
      DO 700 I=1,L1
        DO 700 J=1,I
          IPHSE = IROT(I,J)
          IF(IPHSE.EQ.0) GO TO 700
          IJ = IABS(IPHSE)
          DO 650 ISTAT=1,NSTATS
C
C          ----- Configuration-orbital contribution -----
C
            DO 550 M=JLO,JHI
              CVAL = CI(M,ISTAT)
              IF(ABS(CVAL).LT.TOL) GO TO 550
              IJVAL = 0
              DO JSTAT=1,NSTATS
                JWIM = (JSTAT-1)*NDETLN + M - JLO + 1
                JYIM = (JSTAT-1)*NDETMX + M
                IJSTAT = (ISTAT-1)*NSTATS + JSTAT
                JISTAT = (JSTAT-1)*NSTATS + ISTAT
                DVAL = SALAG(I,J,IJSTAT) + SALAG(I,J,JISTAT)
                DVAL = DVAL - SALAG(J,I,IJSTAT) - SALAG(J,I,JISTAT)
                DVAL = WSTATE(JSTAT)*CVAL*DVAL
                CALL DAXPY(NUNIQ,-DVAL,YAC(1,JYIM),1,RHSO(1,IJ),1)
                CALL DAXPY(NUNIQ,-DVAL,YAO(1,IJ),1,RHSC(1,JWIM),1)
              ENDDO
  550       CONTINUE
C
C          ----- State-orbital contribution -----
C
            DO 600 JSTAT=1,ISTAT-1
              IJVAL = IJVAL + 1
              IJSTAT = (ISTAT-1)*NSTATS + JSTAT
              JISTAT = (JSTAT-1)*NSTATS + ISTAT
              WVAL = WSTATE(JSTAT) - WSTATE(ISTAT)
              DVAL = SALAG(I,J,IJSTAT) + SALAG(I,J,JISTAT)
              DVAL = DVAL - SALAG(J,I,IJSTAT) - SALAG(J,I,JISTAT)
              DVAL = WVAL*DVAL
              CALL DAXPY(NUNIQ,DVAL,YAO(1,IJ),1,RHSS(1,IJVAL),1)
              IF(MASWRK) THEN
                CALL DAXPY(NUNIQ,DVAL,YAS(1,IJVAL),1,RHSO(1,IJ),1)
              ENDIF
  600       CONTINUE
  650     CONTINUE
  700 CONTINUE
C
C     ----- Add state-state hessian contribution -----
C
      IJSTAT = 0
      DO 1000 ISTAT=1,NSTATS
        DO 1000 JSTAT=1,ISTAT-1
          IJSTAT = IJSTAT + 1
          DVAL = HALF*PRCNDS(IJSTAT)
          CALL DAXPY(NUNIQ,DVAL,YAS(1,IJSTAT),1,RHSS(1,IJSTAT),1)
 1000 CONTINUE
C
      RETURN
      END
C*MODULE CPMCHF  *DECK HSMLTP
      SUBROUTINE HSMLTP(RHSO,YAO,OINT,EPS,OPDM,TPDM,BUFF,INDEX,IA,
     *                  NROT,NUNIQ,NCOR,NACT,L0,L1,L2)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INTEGER         C_OOOO, C_VOOO, C_VVOO, C_VOVO
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION RHSO(NUNIQ,NROT),YAO(NUNIQ,NROT),OINT(L2),EPS(L1,L1),
     *          OPDM(*),TPDM(*),BUFF(*)
      DIMENSION INDEX(L1,L1),IA(*)
C
      COMMON /DLBTIM/ C_OOOO,C_VOOO,C_VVOO,C_VOVO
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      INTEGER         D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB
      LOGICAL         NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /TRFDMS/ D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB,
     *                NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
C
      PARAMETER (ZERO=0.0D+00,ONE=1.0D+00,TWO=2.0D+00,FOUR=4.0D+00)
      PARAMETER (HALF=0.5D+00,TOL=1.0D-09)
C
      NOCC = NACT + NCOR
      NOTR = (NOCC*NOCC+NOCC)/2
      IVAL = (L1-NOCC)*L1
C
      NVIR = L0 - NOCC
C
      NBVIR = L1 - NOCC
      NBTR = (NBVIR*NBVIR+NBVIR)/2
      NBSQ = NBVIR*NBVIR
C
      CALL VCLR(BUFF,1,L2)
      CALL VCLR(EPS(1,NOCC+1),1,IVAL)
      CALL VCLR(RHSO,1,NROT*NUNIQ)
C
C     ----- Construct full one-particle density matrix -----
C
      DO I=1,NCOR
        II = IA(I) + I
        BUFF(II) = TWO
      ENDDO
C
      DO 10 I=NCOR+1,NOCC
        DO 10 J=NCOR+1,I
          IJ = IA(I) + J
          IIJJ = IA(I-NCOR) + J-NCOR
          BUFF(IJ) = OPDM(IIJJ)
   10 CONTINUE
C
C     ----- Construct one-electron contribution to orbital hessian -----
C
      IF(MASWRK) THEN
        DO 30 K=1,L0
          DO 30 L=1,K
            KL = IABS(INDEX(K,L))
            IF(KL.EQ.0) GO TO 30
C
            DO 20 I=1,L0
              IG = MAX(I,K)
              KG = MIN(I,K)
              IK = IA(IG)+KG
              IG = MAX(I,L)
              LG = MIN(I,L)
              IL = IA(IG)+LG
              DO 20 J=1,I
                IJ = IABS(INDEX(I,J))
                IF(IJ.EQ.0) GO TO 20
                JG = MAX(J,K)
                KG = MIN(J,K)
                JK = IA(JG)+KG
                JG = MAX(J,L)
                LG = MIN(J,L)
                JL = IA(JG)+LG
C
                DVAL = ZERO
                DVAL = DVAL + OINT(IK)*BUFF(JL)
                DVAL = DVAL + OINT(JL)*BUFF(IK)
                DVAL = DVAL - OINT(JK)*BUFF(IL)
                DVAL = DVAL - OINT(IL)*BUFF(JK)
                IF((I.EQ.L).AND.(K.LE.NOCC)) DVAL = DVAL + EPS(J,K)
                IF(J.EQ.K) DVAL = DVAL + EPS(I,L)
                IF(I.EQ.K) DVAL = DVAL - EPS(J,L)
                IF((J.EQ.L).AND.(K.LE.NOCC)) DVAL = DVAL - EPS(I,K)
C
                CALL DAXPY(NUNIQ,DVAL,YAO(1,KL),1,RHSO(1,IJ),1)
   20       CONTINUE
   30   CONTINUE
      ENDIF
C
C     ----- Construct two-electron part of orbital hessian -----
C
      IP = 0
      CALL TSECND(T0)
      DO 8000 IP=0,NPROC-1
        IWP = MOD(ME+IP,NPROC)
C
C     ----- Get and use (OO|OO) integrals -----
C
        CALL DDI_DISTRIB(D_OOOO,IWP,ILO,IHI,JLO,JHI)
        MAXWRK = JHI-JLO+1
C
        CALL DDI_PROCDLB_NEXT(C_OOOO,IWP,ICNTR1)
C
        DO WHILE(ICNTR1.LT.MAXWRK)
          IJ = JLO + ICNTR1
C
          DO II=1,NOCC
            DO JJ=1,II
              IJTMP = IA(II) + JJ
              IF(IJTMP.EQ.IJ) THEN
                I = II
                J = JJ
                GO TO 40
              ENDIF
            ENDDO
          ENDDO
C
   40     CALL DDI_GET(D_OOOO,1,NOTR,IJ,IJ,BUFF)
C
C          ----- Coulomb contribution to orbital hessian -----
C          -----       Inner indices are both core       -----
C
          DO 100 N=1,NCOR
            JNG = IABS(INDEX(J,N))
            IF(JNG.EQ.0) GO TO 70
            DO 60 M=1,NCOR
              IMG = IABS(INDEX(I,M))
              IF(IMG.EQ.0) GO TO 60
              MG = MAX(M,N)
              NG = MIN(M,N)
              MN = IA(MG) + NG
C
              DVAL = ZERO
              IF(M.EQ.N) THEN
                DO K=1,NCOR
                  KK = IA(K) + K
                  DVAL = DVAL + BUFF(KK)
                ENDDO
                DVAL = DVAL*TWO
C
                DO 50 K=1,NACT
                  DO 50 L=1,K
                    KL = IA(K+NCOR) + L+NCOR
                    XIJKL = BUFF(KL)
                    IF(K.NE.L) XIJKL = TWO*XIJKL
                    KL = IA(K) + L
                    DVAL = DVAL + OPDM(KL)*XIJKL
   50           CONTINUE
              ENDIF
C
              DVAL = DVAL - BUFF(MN)
              DVAL = DVAL*TWO
              IF(N.GT.J) DVAL = -DVAL
              IF(M.GT.I) DVAL = -DVAL
              CALL DAXPY(NUNIQ,DVAL,YAO(1,JNG),1,RHSO(1,IMG),1)
   60       CONTINUE
C
   70       IF(I.EQ.J) GO TO 100
            ING = IABS(INDEX(I,N))
            IF(ING.EQ.0) GO TO 100
            DO 90 M=1,NCOR
              JMG = IABS(INDEX(J,M))
              IF(JMG.EQ.0) GO TO 90
              MG = MAX(M,N)
              NG = MIN(M,N)
              MN = IA(MG) + NG
C
              DVAL = ZERO
              IF(M.EQ.N) THEN
                DO K=1,NCOR
                  KK = IA(K) + K
                  DVAL = DVAL + BUFF(KK)
                ENDDO
                DVAL = DVAL*TWO
C
                DO 80 K=1,NACT
                  DO 80 L=1,K
                    KL = IA(K+NCOR) + L+NCOR
                    XIJKL = BUFF(KL)
                    IF(K.NE.L) XIJKL = TWO*XIJKL
                    KL = IA(K) + L
                    DVAL = DVAL + OPDM(KL)*XIJKL
   80           CONTINUE
              ENDIF
C
              DVAL = DVAL - BUFF(MN)
              DVAL = TWO*DVAL
              IF(N.GT.I) DVAL = -DVAL
              IF(M.GT.J) DVAL = -DVAL
              CALL DAXPY(NUNIQ,DVAL,YAO(1,ING),1,RHSO(1,JMG),1)
   90       CONTINUE
  100     CONTINUE
C
C          ----- Coulomb contribution to orbital hessian -----
C          -----    One core index, one active index     -----
C
          DO 200 N=1,NCOR
            JNG = IABS(INDEX(J,N))
            IF(JNG.EQ.0) GO TO 150
            DO 120 M=1,NACT
              IMG = IABS(INDEX(I,M+NCOR))
              IF(IMG.EQ.0) GO TO 120
              DO K=1,NACT
                KN = IA(K+NCOR) + N
                XIJKL = BUFF(KN)
                KG = MAX(K,M)
                MG = MIN(K,M)
                KM = IA(KG) + MG
                IF(N.GT.J) XIJKL = -XIJKL
                IF((M+NCOR).GT.I) XIJKL = -XIJKL
                DVAL = XIJKL*OPDM(KM)
                CALL DAXPY(NUNIQ,-DVAL,YAO(1,JNG),1,RHSO(1,IMG),1)
                CALL DAXPY(NUNIQ,-DVAL,YAO(1,IMG),1,RHSO(1,JNG),1)
              ENDDO
  120       CONTINUE
C
  150       ING = IABS(INDEX(I,N))
            IF(ING.EQ.0) GO TO 200
            DO 170 M=1,NACT
              JMG = IABS(INDEX(J,M+NCOR))
              IF(JMG.EQ.0) GO TO 170
              DO K=1,NACT
                KN = IA(K+NCOR) + N
                XIJKL = BUFF(KN)
                KG = MAX(K,M)
                MG = MIN(K,M)
                KM = IA(KG) + MG
                IF(N.GT.I) XIJKL = -XIJKL
                IF((M+NCOR).GT.J) XIJKL = -XIJKL
                DVAL = XIJKL*OPDM(KM)
                CALL DAXPY(NUNIQ,-DVAL,YAO(1,JMG),1,RHSO(1,ING),1)
                CALL DAXPY(NUNIQ,-DVAL,YAO(1,ING),1,RHSO(1,JMG),1)
              ENDDO
  170       CONTINUE
  200     CONTINUE
C
C          ----- Coulomb contribution to orbital hessian -----
C          -----      Inner indices are both active      -----
C
          DO 300 N=1,NACT
            JNG = IABS(INDEX(J,N+NCOR))
            IF(JNG.EQ.0) GO TO 250
            DO 240 M=1,NACT
              IMG = IABS(INDEX(I,M+NCOR))
              IF(IMG.EQ.0) GO TO 240
              MG = MAX(M,N)
              NG = MIN(M,N)
              MN = IA(MG) + NG
C
              DVAL = ZERO
              DO K=1,NCOR
                KK = IA(K) + K
                DVAL = DVAL + BUFF(KK)
              ENDDO
              DVAL = TWO*DVAL
              DVAL = OPDM(MN)*DVAL
C
              DO 220 K=1,NACT
                DO 210 L=1,K
                  KL = IA(K+NCOR) + L+NCOR
                  XIJKL = BUFF(KL)
                  IF(ABS(XIJKL).LT.TOL) GO TO 210
                  IF(K.NE.L) XIJKL = TWO*XIJKL
                  KL = IA(K) + L
                  MNG = MAX(MN,KL)
                  KLG = MIN(MN,KL)
                  MNKL = IA(MNG) + KLG
                  DVAL = DVAL + TPDM(MNKL)*XIJKL
  210           CONTINUE
  220         CONTINUE
C
              IF((N+NCOR).GT.J) DVAL = -DVAL
              IF((M+NCOR).GT.I) DVAL = -DVAL
              CALL DAXPY(NUNIQ,DVAL,YAO(1,JNG),1,RHSO(1,IMG),1)
  240       CONTINUE
C
  250       IF(I.EQ.J) GO TO 300
            ING = IABS(INDEX(I,N+NCOR))
            IF(ING.EQ.0) GO TO 300
            DO 290 M=1,NACT
              JMG = IABS(INDEX(J,M+NCOR))
              IF(JMG.EQ.0) GO TO 290
              MG = MAX(M,N)
              NG = MIN(M,N)
              MN = IA(MG) + NG
C
              DVAL = ZERO
              DO K=1,NCOR
                KK = IA(K) + K
                DVAL = DVAL + BUFF(KK)
              ENDDO
              DVAL = TWO*DVAL
              DVAL = OPDM(MN)*DVAL
C
              DO 270 K=1,NACT
                DO 270 L=1,K
                  KL = IA(K+NCOR) + L+NCOR
                  XIJKL = BUFF(KL)
                  IF(ABS(XIJKL).LT.TOL) GO TO 260
                  IF(K.NE.L) XIJKL = TWO*XIJKL
                  KL = IA(K) + L
                  MNG = MAX(MN,KL)
                  KLG = MIN(MN,KL)
                  MNKL = IA(MNG) + KLG
                  DVAL = DVAL + TPDM(MNKL)*XIJKL
  260           CONTINUE
  270         CONTINUE
C
              IF((N+NCOR).GT.I) DVAL = -DVAL
              IF((M+NCOR).GT.J) DVAL = -DVAL
              CALL DAXPY(NUNIQ,DVAL,YAO(1,ING),1,RHSO(1,JMG),1)
  290       CONTINUE
  300     CONTINUE
C
C          ----- Exchange contribution to orbital hessian -----
C          -----      First summation index over core     -----
C
          IF(J.GT.NCOR) GO TO 610
          DO 500 K=1,NOCC
            DO 450 L=1,NCOR
              KG = MAX(K,L)
              LG = MIN(K,L)
              KL = IA(KG) + LG
              XIJKL = BUFF(KL)
              IF(ABS(XIJKL).LT.TOL) GO TO 450
C
              IMG = IABS(INDEX(I,J))
              KNG = IABS(INDEX(K,L))
              IF((IMG.NE.0) .AND. (KNG.NE.0)) THEN
                DVAL = TWO*FOUR*XIJKL
                IF(J.GT.I) DVAL = -DVAL
                IF(L.GT.K) DVAL = -DVAL
                CALL DAXPY(NUNIQ,DVAL,YAO(1,KNG),1,RHSO(1,IMG),1)
              ENDIF
C
              IMG = IABS(INDEX(I,L))
              KNG = IABS(INDEX(K,J))
              IF((IMG.NE.0) .AND. (KNG.NE.0)) THEN
                DVAL = TWO*XIJKL
                IF(L.GT.I) DVAL = -DVAL
                IF(J.GT.K) DVAL = -DVAL
                CALL DAXPY(NUNIQ,-DVAL,YAO(1,KNG),1,RHSO(1,IMG),1)
              ENDIF
C
              IF(J.EQ.L) THEN
                DO 400 M=1,NCOR
                  IMG = IABS(INDEX(I,M))
                  KMG = IABS(INDEX(K,M))
                  IF((IMG.EQ.0) .OR. (KMG.EQ.0)) GO TO 400
                  DVAL = TWO*XIJKL
                  IF(M.GT.I) DVAL = -DVAL
                  IF(M.GT.K) DVAL = -DVAL
                  CALL DAXPY(NUNIQ,-DVAL,YAO(1,KMG),1,RHSO(1,IMG),1)
  400           CONTINUE
C
                DO 440 M=1,NACT
                  IMG = IABS(INDEX(I,M+NCOR))
                  IF(IMG.EQ.0) GO TO 440
                  DO 430 N=1,NACT
                    KNG = IABS(INDEX(K,N+NCOR))
                    IF(KNG.EQ.0) GO TO 430
                    MG = MAX(M,N)
                    NG = MIN(M,N)
                    MN = IA(MG) + NG
                    DVAL = OPDM(MN)*XIJKL
                    IF((M+NCOR).GT.I) DVAL = -DVAL
                    IF((N+NCOR).GT.K) DVAL = -DVAL
                    CALL DAXPY(NUNIQ,-DVAL,YAO(1,KNG),1,RHSO(1,IMG),1)
  430             CONTINUE
  440           CONTINUE
              ENDIF
  450       CONTINUE
C
            DO 490 L=1,NACT
              KG = MAX(K,L+NCOR)
              LG = MIN(K,L+NCOR)
              KL = IA(KG) + LG
              XIJKL = BUFF(KL)
              IF(ABS(XIJKL).LT.TOL) GO TO 490
C
              IMG = IABS(INDEX(I,J))
              IF(IMG.NE.0) THEN
                DO 460 N=1,NACT
                  KNG = IABS(INDEX(K,N+NCOR))
                  IF(KNG.EQ.0) GO TO 460
                  LG = MAX(L,N)
                  NG = MIN(L,N)
                  LN = IA(LG) + NG
                  DVAL = OPDM(LN)*XIJKL
                  DVAL = FOUR*DVAL
                  IF(J.GT.I) DVAL = -DVAL
                  IF((N+NCOR).GT.K) DVAL = -DVAL
                  CALL DAXPY(NUNIQ,DVAL,YAO(1,KNG),1,RHSO(1,IMG),1)
  460           CONTINUE
              ENDIF
C
              KNG = IABS(INDEX(K,J))
              IF(KNG.NE.0) THEN
                DO 470 M=1,NACT
                  IMG = IABS(INDEX(I,M+NCOR))
                  IF(IMG.EQ.0) GO TO 470
                  LG = MAX(L,M)
                  MG = MIN(L,M)
                  LM = IA(LG) + MG
                  DVAL = OPDM(LM)*XIJKL
                  IF(J.GT.K) DVAL = -DVAL
                  IF((M+NCOR).GT.I) DVAL = -DVAL
                  CALL DAXPY(NUNIQ,-DVAL,YAO(1,KNG),1,RHSO(1,IMG),1)
  470           CONTINUE
              ENDIF
  490       CONTINUE
  500     CONTINUE
C
          IF((I.EQ.J) .OR. (I.GT.NCOR)) GO TO 610
          DO 600 K=1,NOCC
            DO 550 L=1,NCOR
              KG = MAX(K,L)
              LG = MIN(K,L)
              KL = IA(KG) + LG
              XIJKL = BUFF(KL)
              IF(ABS(XIJKL).LT.TOL) GO TO 550
C
              JMG = IABS(INDEX(J,I))
              KNG = IABS(INDEX(K,L))
              IF((JMG.NE.0) .AND. (KNG.NE.0)) THEN
                DVAL = TWO*FOUR*XIJKL
                IF(I.GT.J) DVAL = -DVAL
                IF(L.GT.K) DVAL = -DVAL
                CALL DAXPY(NUNIQ,DVAL,YAO(1,KNG),1,RHSO(1,JMG),1)
              ENDIF
C
              JMG = IABS(INDEX(J,L))
              KNG = IABS(INDEX(K,I))
              IF((JMG.NE.0) .AND. (KNG.NE.0)) THEN
                DVAL = TWO*XIJKL
                IF(L.GT.J) DVAL = -DVAL
                IF(I.GT.K) DVAL = -DVAL
                CALL DAXPY(NUNIQ,-DVAL,YAO(1,KNG),1,RHSO(1,JMG),1)
              ENDIF
C
              IF(I.EQ.L) THEN
                DO 510 M=1,NCOR
                  JMG = IABS(INDEX(J,M))
                  KMG = IABS(INDEX(K,M))
                  IF((JMG.EQ.0) .OR. (KMG.EQ.0)) GO TO 510
                  DVAL = TWO*XIJKL
                  IF(M.GT.J) DVAL = -DVAL
                  IF(M.GT.K) DVAL = -DVAL
                  CALL DAXPY(NUNIQ,-DVAL,YAO(1,KMG),1,RHSO(1,JMG),1)
  510           CONTINUE
C
                DO 540 M=1,NACT
                  JMG = IABS(INDEX(J,M+NCOR))
                  IF(JMG.EQ.0) GO TO 540
                  DO 530 N=1,NACT
                    KNG = IABS(INDEX(K,N+NCOR))
                    IF(KNG.EQ.0) GO TO 530
                    MG = MAX(M,N)
                    NG = MIN(M,N)
                    MN = IA(MG) + NG
                    DVAL = OPDM(MN)*XIJKL
                    IF((M+NCOR).GT.J) DVAL = -DVAL
                    IF((N+NCOR).GT.K) DVAL = -DVAL
                    CALL DAXPY(NUNIQ,-DVAL,YAO(1,KNG),1,RHSO(1,JMG),1)
  530             CONTINUE
  540           CONTINUE
              ENDIF
  550       CONTINUE
C
            DO 590 L=1,NACT
              KG = MAX(K,L+NCOR)
              LG = MIN(K,L+NCOR)
              KL = IA(KG) + LG
              XIJKL = BUFF(KL)
              IF(ABS(XIJKL).LT.TOL) GO TO 590
C
              JMG = IABS(INDEX(J,I))
              IF(JMG.NE.0) THEN
                DO 560 N=1,NACT
                  KNG = IABS(INDEX(K,N+NCOR))
                  IF(KNG.EQ.0) GO TO 560
                  LG = MAX(L,N)
                  NG = MIN(L,N)
                  LN = IA(LG) + NG
                  DVAL = OPDM(LN)*XIJKL
                  DVAL = FOUR*DVAL
                  IF(I.GT.J) DVAL = -DVAL
                  IF((N+NCOR).GT.K) DVAL = -DVAL
                  CALL DAXPY(NUNIQ,DVAL,YAO(1,KNG),1,RHSO(1,JMG),1)
  560           CONTINUE
              ENDIF
C
              KNG = IABS(INDEX(K,I))
              IF(KNG.NE.0) THEN
                DO 570 M=1,NACT
                  JMG = IABS(INDEX(J,M+NCOR))
                  IF(JMG.EQ.0) GO TO 570
                  LG = MAX(L,M)
                  MG = MIN(L,M)
                  LM = IA(LG) + MG
                  DVAL = OPDM(LM)*XIJKL
                  IF(I.GT.K) DVAL = -DVAL
                  IF((M+NCOR).GT.J) DVAL = -DVAL
                  CALL DAXPY(NUNIQ,-DVAL,YAO(1,KNG),1,RHSO(1,JMG),1)
  570           CONTINUE
              ENDIF
  590       CONTINUE
  600     CONTINUE
C
C          ----- Exchange contribution to orbital hessian -----
C          -----    First summation index over valence    -----
C
  610     IF(I.LE.NCOR) GO TO 1000
          DO 800 K=1,NOCC
            DO 700 L=1,NCOR
              KG = MAX(K,L)
              LG = MIN(K,L)
              KL = IA(KG) + LG
              XIJKL = BUFF(KL)
              IF(ABS(XIJKL).LT.TOL) GO TO 700
C
              IF(J.LE.NCOR) GO TO 650
              IMG = IABS(INDEX(I,L))
              IF(IMG.NE.0) THEN
                DO 620 N=1,NACT
                  KNG = IABS(INDEX(K,N+NCOR))
                  IF(KNG.EQ.0) GO TO 620
                  NG = MAX(N,J-NCOR)
                  JG = MIN(N,J-NCOR)
                  NJ = IA(NG) + JG
                  DVAL = OPDM(NJ)*XIJKL
                  IF(L.GT.I) DVAL = -DVAL
                  IF((N+NCOR).GT.K) DVAL = -DVAL
                  CALL DAXPY(NUNIQ,-DVAL,YAO(1,KNG),1,RHSO(1,IMG),1)
  620           CONTINUE
              ENDIF
C
              KNG = IABS(INDEX(K,L))
              IF(KNG.NE.0) THEN
                DO 640 M=1,NACT
                  IMG = IABS(INDEX(I,M+NCOR))
                  IF(IMG.EQ.0) GO TO 640
                  MG = MAX(M,J-NCOR)
                  JG = MIN(M,J-NCOR)
                  MJ = IA(MG) + JG
                  DVAL = OPDM(MJ)*XIJKL
                  DVAL = FOUR*DVAL
                  IF(L.GT.K) DVAL = -DVAL
                  IF((M+NCOR).GT.I) DVAL = -DVAL
                  CALL DAXPY(NUNIQ,DVAL,YAO(1,KNG),1,RHSO(1,IMG),1)
  640           CONTINUE
              ENDIF
C
  650         IF(I.EQ.J) GO TO 700
              JMG = IABS(INDEX(J,L))
              IF(JMG.NE.0) THEN
                DO 670 N=1,NACT
                  KNG = IABS(INDEX(K,N+NCOR))
                  IF(KNG.EQ.0) GO TO 670
                  NG = MAX(N,I-NCOR)
                  IG = MIN(N,I-NCOR)
                  NI = IA(NG) + IG
                  DVAL = OPDM(NI)*XIJKL
                  IF(L.GT.J) DVAL = -DVAL
                  IF((N+NCOR).GT.K) DVAL = -DVAL
                  CALL DAXPY(NUNIQ,-DVAL,YAO(1,KNG),1,RHSO(1,JMG),1)
  670           CONTINUE
              ENDIF
C
              KNG = IABS(INDEX(K,L))
              IF(KNG.NE.0) THEN
                DO 690 M=1,NACT
                  JMG = IABS(INDEX(J,M+NCOR))
                  IF(JMG.EQ.0) GO TO 690
                  MG = MAX(M,I-NCOR)
                  IG = MIN(M,I-NCOR)
                  MI = IA(MG) + IG
                  DVAL = OPDM(MI)*XIJKL
                  DVAL = FOUR*DVAL
                  IF(L.GT.K) DVAL = -DVAL
                  IF((M+NCOR).GT.J) DVAL = -DVAL
                  CALL DAXPY(NUNIQ,DVAL,YAO(1,KNG),1,RHSO(1,JMG),1)
  690           CONTINUE
              ENDIF
  700       CONTINUE
C
            DO 790 L=1,NACT
              KG = MAX(K,L+NCOR)
              LG = MIN(K,L+NCOR)
              KL = IA(KG) + LG
              XIJKL = BUFF(KL)
              IF(ABS(XIJKL).LT.TOL) GO TO 790
C
              IF(J.LE.NCOR) GO TO 750
              JG = MAX(J-NCOR,L)
              LG = MIN(J-NCOR,L)
              JL = IA(JG) + LG
              DO 720 M=1,NCOR
                IMG = IABS(INDEX(I,M))
                KMG = IABS(INDEX(K,M))
                IF((IMG.EQ.0) .OR. (KMG.EQ.0)) GO TO 720
                DVAL = OPDM(JL)*XIJKL
                IF(M.GT.I) DVAL = -DVAL
                IF(M.GT.K) DVAL = -DVAL
                CALL DAXPY(NUNIQ,-DVAL,YAO(1,KMG),1,RHSO(1,IMG),1)
  720         CONTINUE
C
              DO 740 M=1,NACT
                IMG = IABS(INDEX(I,M+NCOR))
                IF(IMG.EQ.0) GO TO 740
                MG = MAX(M,J-NCOR)
                JG = MIN(M,J-NCOR)
                MJ = IA(MG) + JG
                DO 730 N=1,NACT
                  KNG = IABS(INDEX(K,N+NCOR))
                  IF(KNG.EQ.0) GO TO 730
                  NG = MAX(N,L)
                  LG = MIN(N,L)
                  NL = IA(NG) + LG
                  MJG = MAX(MJ,NL)
                  NLG = MIN(MJ,NL)
                  MJNL = IA(MJG) + NLG
                  DVAL = TPDM(MJNL)*XIJKL
                  DVAL = TWO*DVAL
                  IF((M+NCOR).GT.I) DVAL = -DVAL
                  IF((N+NCOR).GT.K) DVAL = -DVAL
                  CALL DAXPY(NUNIQ,DVAL,YAO(1,KNG),1,RHSO(1,IMG),1)
  730           CONTINUE
  740         CONTINUE
C
  750         IF(I.EQ.J) GO TO 790
              IG = MAX(I-NCOR,L)
              LG = MIN(I-NCOR,L)
              IL = IA(IG) + LG
              DO 760 M=1,NCOR
                JMG = IABS(INDEX(J,M))
                KMG = IABS(INDEX(K,M))
                IF((JMG.EQ.0) .OR. (KMG.EQ.0)) GO TO 760
                DVAL = OPDM(IL)*XIJKL
                IF(M.GT.J) DVAL = -DVAL
                IF(M.GT.K) DVAL = -DVAL
                CALL DAXPY(NUNIQ,-DVAL,YAO(1,KMG),1,RHSO(1,JMG),1)
  760         CONTINUE
C
              DO 780 M=1,NACT
                JMG = IABS(INDEX(J,M+NCOR))
                IF(JMG.EQ.0) GO TO 780
                MG = MAX(M,I-NCOR)
                IG = MIN(M,I-NCOR)
                MI = IA(MG) + IG
                DO 770 N=1,NACT
                  KNG = IABS(INDEX(K,N+NCOR))
                  IF(KNG.EQ.0) GO TO 770
                  NG = MAX(N,L)
                  LG = MIN(N,L)
                  NL = IA(NG) + LG
                  MIG = MAX(MI,NL)
                  NLG = MIN(MI,NL)
                  MINL = IA(MIG) + NLG
                  DVAL = TPDM(MINL)*XIJKL
                  DVAL = TWO*DVAL
                  IF((M+NCOR).GT.J) DVAL = -DVAL
                  IF((N+NCOR).GT.K) DVAL = -DVAL
                  CALL DAXPY(NUNIQ,DVAL,YAO(1,KNG),1,RHSO(1,JMG),1)
  770           CONTINUE
  780         CONTINUE
  790       CONTINUE
  800     CONTINUE
C
C          ----- Finished with current integral buffer -----
C
 1000     CALL DDI_PROCDLB_NEXT(C_OOOO,IWP,ICNTR1)
C
        ENDDO
C
C     ----- Get and use (VO|OO) integrals -----
C
        CALL DDI_DISTRIB(D_VOOO,IWP,ILO,IHI,JLO,JHI)
        MAXWRK = JHI-JLO+1
C
        CALL DDI_PROCDLB_NEXT(C_VOOO,IWP,ICNTR2)
C
        DO WHILE(ICNTR2.LT.MAXWRK)
          JKL = JLO + ICNTR2
C
          DO KK=1,NOCC
            DO LL=1,KK
              KL = IA(KK) + LL
              DLT = TWO
              IF(KK.EQ.LL) DLT = ONE
              DO JJ=1,NOCC
                JKLTMP = (KL-1)*NOCC + JJ
                IF(JKL.EQ.JKLTMP) THEN
                  J = JJ
                  K = KK
                  L = LL
                  GO TO 1010
                END IF
              ENDDO
            ENDDO
          ENDDO
C
 1010     CALL DDI_GET(D_VOOO,1,NBVIR,JKL,JKL,BUFF)
C
C          ----- Coulomb contribution to orbital hessian -----
C          -----   Ket integral indicies are both core   -----
C
          IF(K.GT.NCOR) GO TO 1120
          JKG = IABS(INDEX(J,K))
          JLG = IABS(INDEX(J,L))
          DO 1100 I=NOCC+1,L0
            XIJKL = BUFF(I-NOCC)
            IF(ABS(XIJKL).LT.TOL) GO TO 1100
C
            ILG = IABS(INDEX(I,L))
            IF((ILG.EQ.0) .OR. (JKG.EQ.0)) GO TO 1020
            DVAL = DLT*XIJKL
            IF(K.GT.J) DVAL = -DVAL
            CALL DAXPY(NUNIQ,-DVAL,YAO(1,JKG),1,RHSO(1,ILG),1)
            CALL DAXPY(NUNIQ,-DVAL,YAO(1,ILG),1,RHSO(1,JKG),1)
C
 1020       IKG = IABS(INDEX(I,K))
            IF((IKG.EQ.0) .OR. (JLG.EQ.0)) GO TO 1030
            DVAL = DLT*XIJKL
            IF(L.GT.J) DVAL = -DVAL
            CALL DAXPY(NUNIQ,-DVAL,YAO(1,JLG),1,RHSO(1,IKG),1)
            CALL DAXPY(NUNIQ,-DVAL,YAO(1,IKG),1,RHSO(1,JLG),1)
C
 1030       IF(K.NE.L) GO TO 1100
            DO 1050 M=1,NCOR
              IMG = IABS(INDEX(I,M))
              JMG = IABS(INDEX(J,M))
              IF((IMG.EQ.0) .OR. (JMG.EQ.0)) GO TO 1050
              DVAL = FOUR*XIJKL
              IF(M.GT.J) DVAL = -DVAL
              CALL DAXPY(NUNIQ,DVAL,YAO(1,JMG),1,RHSO(1,IMG),1)
              CALL DAXPY(NUNIQ,DVAL,YAO(1,IMG),1,RHSO(1,JMG),1)
 1050       CONTINUE
C
            DO 1070 M=1,NACT
              IMG = IABS(INDEX(I,M+NCOR))
              IF(IMG.EQ.0) GO TO 1070
              DO 1060 N=1,NACT
                JNG = IABS(INDEX(J,N+NCOR))
                IF(JNG.EQ.0) GO TO 1060
                MG = MAX(M,N)
                NG = MIN(M,N)
                MN = IA(MG) + NG
                DVAL = OPDM(MN)*XIJKL
                DVAL = TWO*DVAL
                IF((N+NCOR).GT.J) DVAL = -DVAL
                CALL DAXPY(NUNIQ,DVAL,YAO(1,JNG),1,RHSO(1,IMG),1)
                CALL DAXPY(NUNIQ,DVAL,YAO(1,IMG),1,RHSO(1,JNG),1)
 1060         CONTINUE
 1070       CONTINUE
 1100     CONTINUE
          GO TO 1500
C
C          ----- Coulomb contribution to orbital hessian -----
C          -----     One ket integral index is active    -----
C
 1120     IF(L.GT.NCOR) GO TO 1220
          JLG = IABS(INDEX(J,L))
          DO 1200 I=NOCC+1,L0
            XIJKL = BUFF(I-NOCC)
            IF(ABS(XIJKL).LT.TOL) GO TO 1200
            ILG = IABS(INDEX(I,L))
C
            DO 1140 M=1,NACT
              KG = MAX(K-NCOR,M)
              MG = MIN(K-NCOR,M)
              KM = IA(KG) + MG
C
              IMG = IABS(INDEX(I,M+NCOR))
              IF((IMG.EQ.0) .OR. (JLG.EQ.0)) GO TO 1130
              DVAL = OPDM(KM)*XIJKL
              IF(L.GT.J) DVAL = -DVAL
              CALL DAXPY(NUNIQ,-DVAL,YAO(1,JLG),1,RHSO(1,IMG),1)
              CALL DAXPY(NUNIQ,-DVAL,YAO(1,IMG),1,RHSO(1,JLG),1)
C
 1130         JMG = IABS(INDEX(J,M+NCOR))
              IF((ILG.EQ.0) .OR. (JMG.EQ.0)) GO TO 1140
              DVAL = OPDM(KM)*XIJKL
              IF((M+NCOR).GT.J) DVAL = -DVAL
              CALL DAXPY(NUNIQ,-DVAL,YAO(1,JMG),1,RHSO(1,ILG),1)
              CALL DAXPY(NUNIQ,-DVAL,YAO(1,ILG),1,RHSO(1,JMG),1)
 1140       CONTINUE
 1200     CONTINUE
          GO TO 1500
C
C          ----- Coulomb contribution to orbital hessian -----
C          -----  Ket integral indicies are both active  -----
C
 1220     KKLL = IA(K-NCOR) + L-NCOR
          DO 1300 I=NOCC+1,L0
            XIJKL = BUFF(I-NOCC)
            IF(ABS(XIJKL).LT.TOL) GO TO 1300
C
            DO 1240 M=1,NCOR
              IMG = IABS(INDEX(I,M))
              JMG = IABS(INDEX(J,M))
              IF((IMG.EQ.0) .OR. (JMG.EQ.0)) GO TO 1240
              DVAL = OPDM(KKLL)*XIJKL
              DVAL = TWO*DLT*DVAL
              IF(M.GT.J) DVAL = -DVAL
              CALL DAXPY(NUNIQ,DVAL,YAO(1,JMG),1,RHSO(1,IMG),1)
              CALL DAXPY(NUNIQ,DVAL,YAO(1,IMG),1,RHSO(1,JMG),1)
 1240       CONTINUE
C
            DO 1260 M=1,NACT
              IMG = IABS(INDEX(I,M+NCOR))
              IF(IMG.EQ.0) GO TO 1260
              DO 1250 N=1,NACT
                JNG = IABS(INDEX(J,N+NCOR))
                IF(JNG.EQ.0) GO TO 1250
                MG = MAX(M,N)
                NG = MIN(M,N)
                MN = IA(MG) + NG
                MNG = MAX(MN,KKLL)
                KLG = MIN(MN,KKLL)
                MNKL = IA(MNG) + KLG
                DVAL = TPDM(MNKL)*XIJKL
                DVAL = DLT*DVAL
                IF((N+NCOR).GT.J) DVAL = -DVAL
                CALL DAXPY(NUNIQ,DVAL,YAO(1,JNG),1,RHSO(1,IMG),1)
                CALL DAXPY(NUNIQ,DVAL,YAO(1,IMG),1,RHSO(1,JNG),1)
 1250         CONTINUE
 1260       CONTINUE
 1300     CONTINUE
C
C          ----- Exchange contribution to orbital hessian -----
C          -----              J index is core             -----
C
 1500     IF(J.GT.NCOR) GO TO 1760
          IF(L.GT.NCOR) GO TO 1660
          KLG = IABS(INDEX(K,L))
          KJG = IABS(INDEX(K,J))
          LKG = IABS(INDEX(L,K))
          LJG = IABS(INDEX(L,J))
C
          DO 1650 I=NOCC+1,L0
            XIJKL = BUFF(I-NOCC)
            IF(ABS(XIJKL).LT.TOL) GO TO 1650
C
            IJG = IABS(INDEX(I,J))
            IF((IJG.EQ.0) .OR. (KLG.EQ.0)) GO TO 1510
            DVAL = FOUR*XIJKL
            DVAL = TWO*DVAL
            CALL DAXPY(NUNIQ,DVAL,YAO(1,KLG),1,RHSO(1,IJG),1)
            CALL DAXPY(NUNIQ,DVAL,YAO(1,IJG),1,RHSO(1,KLG),1)
C
 1510       ILG = IABS(INDEX(I,L))
            IF((ILG.EQ.0) .OR. (KJG.EQ.0)) GO TO 1520
            DVAL = TWO*XIJKL
            IF(J.GT.K) DVAL = -DVAL
            CALL DAXPY(NUNIQ,-DVAL,YAO(1,KJG),1,RHSO(1,ILG),1)
            CALL DAXPY(NUNIQ,-DVAL,YAO(1,ILG),1,RHSO(1,KJG),1)
C
 1520       IF(J.NE.L) GO TO 1560
            DO 1530 M=1,NCOR
              IMG = IABS(INDEX(I,M))
              KMG = IABS(INDEX(K,M))
              IF((IMG.EQ.0) .OR. (KMG.EQ.0)) GO TO 1530
              DVAL = TWO*XIJKL
              IF(M.GT.K) DVAL = -DVAL
              CALL DAXPY(NUNIQ,-DVAL,YAO(1,KMG),1,RHSO(1,IMG),1)
              CALL DAXPY(NUNIQ,-DVAL,YAO(1,IMG),1,RHSO(1,KMG),1)
 1530       CONTINUE
C
            DO 1550 M=1,NACT
              IMG = IABS(INDEX(I,M+NCOR))
              IF(IMG.EQ.0) GO TO 1550
              DO 1540 N=1,NACT
                KNG = IABS(INDEX(K,N+NCOR))
                IF(KNG.EQ.0) GO TO 1540
                MG = MAX(M,N)
                NG = MIN(M,N)
                MN = IA(MG) + NG
                DVAL = OPDM(MN)*XIJKL
                IF((N+NCOR).GT.K) DVAL = -DVAL
                CALL DAXPY(NUNIQ,-DVAL,YAO(1,KNG),1,RHSO(1,IMG),1)
                CALL DAXPY(NUNIQ,-DVAL,YAO(1,IMG),1,RHSO(1,KNG),1)
 1540         CONTINUE
 1550       CONTINUE
C
 1560       IF((K.EQ.L) .OR. (K.GT.NCOR)) GO TO 1650
            IF((IJG.EQ.0) .OR. (LKG.EQ.0)) GO TO 1570
            DVAL = FOUR*XIJKL
            DVAL = TWO*DVAL
            IF(K.GT.L) DVAL = -DVAL
            CALL DAXPY(NUNIQ,DVAL,YAO(1,LKG),1,RHSO(1,IJG),1)
            CALL DAXPY(NUNIQ,DVAL,YAO(1,IJG),1,RHSO(1,LKG),1)
C
 1570       IKG = IABS(INDEX(I,K))
            IF((IKG.EQ.0) .OR. (LJG.EQ.0)) GO TO 1580
            DVAL = TWO*XIJKL
            IF(J.GT.L) DVAL = -DVAL
            CALL DAXPY(NUNIQ,-DVAL,YAO(1,LJG),1,RHSO(1,IKG),1)
            CALL DAXPY(NUNIQ,-DVAL,YAO(1,IKG),1,RHSO(1,LJG),1)
C
 1580       IF(J.NE.K) GO TO 1650
            DO 1590 M=1,NCOR
              IMG = IABS(INDEX(I,M))
              LMG = IABS(INDEX(L,M))
              IF((IMG.EQ.0) .OR. (LMG.EQ.0)) GO TO 1590
              DVAL = TWO*XIJKL
              IF(M.GT.L) DVAL = -DVAL
              CALL DAXPY(NUNIQ,-DVAL,YAO(1,LMG),1,RHSO(1,IMG),1)
              CALL DAXPY(NUNIQ,-DVAL,YAO(1,IMG),1,RHSO(1,LMG),1)
 1590       CONTINUE
C
            DO 1610 M=1,NACT
              IMG = IABS(INDEX(I,M+NCOR))
              IF(IMG.EQ.0) GO TO 1610
              DO 1600 N=1,NACT
                LNG = IABS(INDEX(L,N+NCOR))
                IF(LNG.EQ.0) GO TO 1600
                MG = MAX(M,N)
                NG = MIN(M,N)
                MN = IA(MG) + NG
                DVAL = OPDM(MN)*XIJKL
                IF((N+NCOR).GT.L) DVAL = -DVAL
                CALL DAXPY(NUNIQ,-DVAL,YAO(1,LNG),1,RHSO(1,IMG),1)
                CALL DAXPY(NUNIQ,-DVAL,YAO(1,IMG),1,RHSO(1,LNG),1)
 1600         CONTINUE
 1610       CONTINUE
 1650     CONTINUE
C
 1660     IF(K.LE.NCOR) GO TO 1760
          KJG = IABS(INDEX(K,J))
          LJG = IABS(INDEX(L,J))
          DO 1750 I=NOCC+1,L0
            XIJKL = BUFF(I-NOCC)
            IF(ABS(XIJKL).LT.TOL) GO TO 1750
            IJG = IABS(INDEX(I,J))
C
            IF(L.LE.NCOR) GO TO 1700
            DO 1690 M=1,NACT
              MG = MAX(M,L-NCOR)
              LG = MIN(M,L-NCOR)
              ML = IA(MG) + LG
C
              IMG = IABS(INDEX(I,M+NCOR))
              IF((IMG.EQ.0) .OR. (KJG.EQ.0)) GO TO 1680
              DVAL = OPDM(ML)*XIJKL
              IF(J.GT.K) DVAL = -DVAL
              CALL DAXPY(NUNIQ,-DVAL,YAO(1,KJG),1,RHSO(1,IMG),1)
              CALL DAXPY(NUNIQ,-DVAL,YAO(1,IMG),1,RHSO(1,KJG),1)
C
 1680         KMG = IABS(INDEX(K,M+NCOR))
              IF((IJG.EQ.0) .OR. (KMG.EQ.0)) GO TO 1690
              DVAL = OPDM(ML)*XIJKL
              DVAL = FOUR*DVAL
              IF((M+NCOR).GT.K) DVAL = -DVAL
              CALL DAXPY(NUNIQ,DVAL,YAO(1,KMG),1,RHSO(1,IJG),1)
              CALL DAXPY(NUNIQ,DVAL,YAO(1,IJG),1,RHSO(1,KMG),1)
 1690       CONTINUE
C
 1700       IF(K.EQ.L) GO TO 1750
            DO 1740 M=1,NACT
              MG = MAX(M,K-NCOR)
              KG = MIN(M,K-NCOR)
              MK = IA(MG) + KG
C
              IMG = IABS(INDEX(I,M+NCOR))
              IF((IMG.EQ.0) .OR. (LJG.EQ.0)) GO TO 1720
              DVAL = OPDM(MK)*XIJKL
              IF(J.GT.L) DVAL = -DVAL
              CALL DAXPY(NUNIQ,-DVAL,YAO(1,LJG),1,RHSO(1,IMG),1)
              CALL DAXPY(NUNIQ,-DVAL,YAO(1,IMG),1,RHSO(1,LJG),1)
C
 1720         LMG = IABS(INDEX(L,M+NCOR))
              IF((IJG.EQ.0) .OR. (LMG.EQ.0)) GO TO 1740
              DVAL = OPDM(MK)*XIJKL
              DVAL = FOUR*DVAL
              IF((M+NCOR).GT.L) DVAL = -DVAL
              CALL DAXPY(NUNIQ,DVAL,YAO(1,LMG),1,RHSO(1,IJG),1)
              CALL DAXPY(NUNIQ,DVAL,YAO(1,IJG),1,RHSO(1,LMG),1)
 1740       CONTINUE
 1750     CONTINUE
C
C          ----- Exchange contribution to orbital hessian -----
C          -----            J index is active             -----
C
 1760     IF(J.LE.NCOR) GO TO 2000
          IF(L.GT.NCOR) GO TO 1860
          DO 1850 I=NOCC+1,L0
            XIJKL = BUFF(I-NOCC)
            IF(ABS(XIJKL).LT.TOL) GO TO 1850
C
            ILG = IABS(INDEX(I,L))
            KLG = IABS(INDEX(K,L))
            DO 1800 M=1,NACT
              MG = MAX(M,J-NCOR)
              JG = MIN(M,J-NCOR)
              MJ = IA(MG) + JG
C
              IMG = IABS(INDEX(I,M+NCOR))
              IF((IMG.EQ.0) .OR. (KLG.EQ.0)) GO TO 1780
              DVAL = OPDM(MJ)*XIJKL
              DVAL = FOUR*DVAL
              CALL DAXPY(NUNIQ,DVAL,YAO(1,KLG),1,RHSO(1,IMG),1)
              CALL DAXPY(NUNIQ,DVAL,YAO(1,IMG),1,RHSO(1,KLG),1)
C
 1780         KMG = IABS(INDEX(K,M+NCOR))
              IF((ILG.EQ.0) .OR. (KMG.EQ.0)) GO TO 1800
              DVAL = OPDM(MJ)*XIJKL
              IF((M+NCOR).GT.K) DVAL = -DVAL
              CALL DAXPY(NUNIQ,-DVAL,YAO(1,KMG),1,RHSO(1,ILG),1)
              CALL DAXPY(NUNIQ,-DVAL,YAO(1,ILG),1,RHSO(1,KMG),1)
 1800       CONTINUE
C
            IF((K.EQ.L) .OR. (K.GT.NCOR)) GO TO 1850
            IKG = IABS(INDEX(I,K))
            LKG = IABS(INDEX(L,K))
            DO 1840 M=1,NACT
              MG = MAX(M,J-NCOR)
              JG = MIN(M,J-NCOR)
              MJ = IA(MG) + JG
C
              IMG = IABS(INDEX(I,M+NCOR))
              IF((IMG.EQ.0) .OR. (LKG.EQ.0)) GO TO 1820
              DVAL = OPDM(MJ)*XIJKL
              DVAL = FOUR*DVAL
              IF(K.GT.L) DVAL = -DVAL
              CALL DAXPY(NUNIQ,DVAL,YAO(1,LKG),1,RHSO(1,IMG),1)
              CALL DAXPY(NUNIQ,DVAL,YAO(1,IMG),1,RHSO(1,LKG),1)
C
 1820         LMG = IABS(INDEX(L,M+NCOR))
              IF((IKG.EQ.0) .OR. (LMG.EQ.0)) GO TO 1840
              DVAL = OPDM(MJ)*XIJKL
              IF((M+NCOR).GT.L) DVAL = -DVAL
              CALL DAXPY(NUNIQ,-DVAL,YAO(1,LMG),1,RHSO(1,IKG),1)
              CALL DAXPY(NUNIQ,-DVAL,YAO(1,IKG),1,RHSO(1,LMG),1)
 1840       CONTINUE
 1850     CONTINUE
C
 1860     IF(K.LE.NCOR) GO TO 2000
          DO 1950 I=NOCC+1,L0
            XIJKL = BUFF(I-NOCC)
            IF(ABS(XIJKL).LT.TOL) GO TO 1950
C
            IF(L.LE.NCOR) GO TO 1900
            JG = MAX(J-NCOR,L-NCOR)
            LG = MIN(J-NCOR,L-NCOR)
            JL = IA(JG) + LG
            DO 1870 M=1,NCOR
              IMG = IABS(INDEX(I,M))
              KMG = IABS(INDEX(K,M))
              IF((IMG.EQ.0) .OR. (KMG.EQ.0)) GO TO 1870
              DVAL = OPDM(JL)*XIJKL
              IF(M.GT.K) DVAL = -DVAL
              CALL DAXPY(NUNIQ,-DVAL,YAO(1,KMG),1,RHSO(1,IMG),1)
              CALL DAXPY(NUNIQ,-DVAL,YAO(1,IMG),1,RHSO(1,KMG),1)
 1870       CONTINUE
C
            DO 1890 M=1,NACT
              IMG = IABS(INDEX(I,M+NCOR))
              IF(IMG.EQ.0) GO TO 1890
              MG = MAX(M,J-NCOR)
              JG = MIN(M,J-NCOR)
              MJ = IA(MG) + JG
              DO 1880 N=1,NACT
                KNG = IABS(INDEX(K,N+NCOR))
                IF(KNG.EQ.0) GO TO 1880
                NG = MAX(N,L-NCOR)
                LG = MIN(N,L-NCOR)
                NL = IA(NG) + LG
                MJG = MAX(MJ,NL)
                NLG = MIN(MJ,NL)
                MJNL = IA(MJG) + NLG
                DVAL = TPDM(MJNL)*XIJKL
                DVAL = TWO*DVAL
                IF((N+NCOR).GT.K) DVAL = -DVAL
                CALL DAXPY(NUNIQ,DVAL,YAO(1,KNG),1,RHSO(1,IMG),1)
                CALL DAXPY(NUNIQ,DVAL,YAO(1,IMG),1,RHSO(1,KNG),1)
 1880         CONTINUE
 1890       CONTINUE
C
 1900       IF(K.EQ.L) GO TO 1950
            JG = MAX(J-NCOR,K-NCOR)
            KG = MIN(J-NCOR,K-NCOR)
            JK = IA(JG) + KG
            DO 1910 M=1,NCOR
              IMG = IABS(INDEX(I,M))
              LMG = IABS(INDEX(L,M))
              IF((IMG.EQ.0) .OR. (LMG.EQ.0)) GO TO 1910
              DVAL = OPDM(JK)*XIJKL
              IF(M.GT.L) DVAL = -DVAL
              CALL DAXPY(NUNIQ,-DVAL,YAO(1,LMG),1,RHSO(1,IMG),1)
              CALL DAXPY(NUNIQ,-DVAL,YAO(1,IMG),1,RHSO(1,LMG),1)
 1910       CONTINUE
C
            DO 1940 M=1,NACT
              IMG = IABS(INDEX(I,M+NCOR))
              IF(IMG.EQ.0) GO TO 1940
              MG = MAX(M,J-NCOR)
              JG = MIN(M,J-NCOR)
              MJ = IA(MG) + JG
              DO 1930 N=1,NACT
                LNG = IABS(INDEX(L,N+NCOR))
                IF(LNG.EQ.0) GO TO 1930
                NG = MAX(N,K-NCOR)
                KG = MIN(N,K-NCOR)
                NK = IA(NG) + KG
                MJG = MAX(MJ,NK)
                NKG = MIN(MJ,NK)
                MJNK = IA(MJG) + NKG
                DVAL = TPDM(MJNK)*XIJKL
                DVAL = TWO*DVAL
                IF((N+NCOR).GT.L) DVAL = -DVAL
                CALL DAXPY(NUNIQ,DVAL,YAO(1,LNG),1,RHSO(1,IMG),1)
                CALL DAXPY(NUNIQ,DVAL,YAO(1,IMG),1,RHSO(1,LNG),1)
 1930         CONTINUE
 1940       CONTINUE
 1950     CONTINUE
C
C          ----- Finished with current integral buffer -----
C
 2000     CALL DDI_PROCDLB_NEXT(C_VOOO,IWP,ICNTR2)
C
        ENDDO
C
C     ----- Get and use (VV|OO) integrals -----
C
        CALL DDI_DISTRIB(D_VVOO,IWP,ILO,IHI,JLO,JHI)
        MAXWRK = JHI-JLO+1
C
        CALL DDI_PROCDLB_NEXT(C_VVOO,IWP,ICNTR3)
C
        DO WHILE(ICNTR3.LT.MAXWRK)
          KL = JLO + ICNTR3
C
          DO KK=1,NOCC
            DO LL=1,KK
              DLT = TWO
              IF(KK.EQ.LL) DLT = ONE
              KLTMP = IA(KK) + LL
              IF(KL.EQ.KLTMP) THEN
                K = KK
                L = LL
                GO TO 2010
              ENDIF
            ENDDO
          ENDDO
C
 2010     CALL DDI_GET(D_VVOO,1,NBTR,KL,KL,BUFF)
C
C          ----- Coulomb contribution to orbital hessian -----
C          -----      K and L are both core indicies     -----
C
          IF(K.GT.NCOR) GO TO 2150
          DO 2100 I=1,NVIR
            II = I + NOCC
            ILG = IABS(INDEX(II,L))
            IKG = IABS(INDEX(II,K))
            DO 2100 J=1,I
              JJ = J + NOCC
              IJ = IA(I) + J
              XIJKL = BUFF(IJ)
              IF(ABS(XIJKL).LT.TOL) GO TO 2100
C
              JKG = IABS(INDEX(JJ,K))
              IF((ILG.EQ.0) .OR. (JKG.EQ.0)) GO TO 2030
              DVAL = DLT*XIJKL
              CALL DAXPY(NUNIQ,-DVAL,YAO(1,JKG),1,RHSO(1,ILG),1)
              IF(I.EQ.J) GO TO 2030
              CALL DAXPY(NUNIQ,-DVAL,YAO(1,ILG),1,RHSO(1,JKG),1)
C
 2030         JLG = IABS(INDEX(JJ,L))
              IF((IKG.EQ.0) .OR. (JLG.EQ.0)) GO TO 2040
              DVAL = DLT*XIJKL
              CALL DAXPY(NUNIQ,-DVAL,YAO(1,JLG),1,RHSO(1,IKG),1)
              IF(I.EQ.J) GO TO 2040
              CALL DAXPY(NUNIQ,-DVAL,YAO(1,IKG),1,RHSO(1,JLG),1)
C
 2040         IF(K.NE.L) GO TO 2100
              DO 2050 M=1,NCOR
                IMG = IABS(INDEX(II,M))
                JMG = IABS(INDEX(JJ,M))
                IF((IMG.EQ.0) .OR. (JMG.EQ.0)) GO TO 2050
                DVAL = FOUR*XIJKL
                CALL DAXPY(NUNIQ,DVAL,YAO(1,JMG),1,RHSO(1,IMG),1)
                IF(I.EQ.J) GO TO 2050
                CALL DAXPY(NUNIQ,DVAL,YAO(1,IMG),1,RHSO(1,JMG),1)
 2050         CONTINUE
C
              DO 2070 M=1,NACT
                IMG = IABS(INDEX(II,M+NCOR))
                IF(IMG.EQ.0) GO TO 2070
                DO 2060 N=1,NACT
                  JNG = IABS(INDEX(JJ,N+NCOR))
                  IF(JNG.EQ.0) GO TO 2060
                  MG = MAX(M,N)
                  NG = MIN(M,N)
                  MN = IA(MG) + NG
                  DVAL = OPDM(MN)*XIJKL
                  DVAL = TWO*DVAL
                  CALL DAXPY(NUNIQ,DVAL,YAO(1,JNG),1,RHSO(1,IMG),1)
                  IF(I.EQ.J) GO TO 2060
                  CALL DAXPY(NUNIQ,DVAL,YAO(1,IMG),1,RHSO(1,JNG),1)
 2060           CONTINUE
 2070         CONTINUE
 2100     CONTINUE
          GO TO 3000
C
C          ----- Coulomb contribution to orbital hessian -----
C          -----         K is active, L is core          -----
C
 2150     IF(L.GT.NCOR) GO TO 2350
          DO 2300 I=1,NVIR
            II = I + NOCC
            ILG = IABS(INDEX(II,L))
            DO 2300 J=1,I
              JJ = J + NOCC
              IJ = IA(I) + J
              XIJKL = BUFF(IJ)
              IF(ABS(XIJKL).LT.TOL) GO TO 2300
              JLG = IABS(INDEX(JJ,L))
C
              DO 2200 M=1,NACT
                MG = MAX(M,K-NCOR)
                KG = MIN(M,K-NCOR)
                MK = IA(MG) + KG
C
                JMG = IABS(INDEX(JJ,M+NCOR))
                IF((ILG.EQ.0) .OR. (JMG.EQ.0)) GO TO 2170
                DVAL = OPDM(MK)*XIJKL
                DVAL = HALF*DLT*DVAL
                CALL DAXPY(NUNIQ,-DVAL,YAO(1,JMG),1,RHSO(1,ILG),1)
                IF(I.EQ.J) GO TO 2170
                CALL DAXPY(NUNIQ,-DVAL,YAO(1,ILG),1,RHSO(1,JMG),1)
C
 2170           IMG = IABS(INDEX(II,M+NCOR))
                IF((IMG.EQ.0) .OR. (JLG.EQ.0)) GO TO 2200
                DVAL = OPDM(MK)*XIJKL
                DVAL = HALF*DLT*DVAL
                CALL DAXPY(NUNIQ,-DVAL,YAO(1,JLG),1,RHSO(1,IMG),1)
                IF(I.EQ.J) GO TO 2200
                CALL DAXPY(NUNIQ,-DVAL,YAO(1,IMG),1,RHSO(1,JLG),1)
 2200         CONTINUE
 2300     CONTINUE
          GO TO 3000
C
C          ----- Coulomb contribution to orbital hessian -----
C          -----     K and L are both active indicies    -----
C
 2350     KKLL = IA(K-NCOR) + L-NCOR
          DO 2500 I=1,NVIR
            II = I + NOCC
            DO 2500 J=1,I
              JJ = J + NOCC
              IJ = IA(I) + J
              XIJKL = BUFF(IJ)
              IF(ABS(XIJKL).LT.TOL) GO TO 2500
              XIJKL = DLT*XIJKL
C
              DO 2400 M=1,NCOR
                IMG = IABS(INDEX(II,M))
                JMG = IABS(INDEX(JJ,M))
                IF((IMG.EQ.0) .OR. (JMG.EQ.0)) GO TO 2400
                DVAL = OPDM(KKLL)*XIJKL
                DVAL = TWO*DVAL
                CALL DAXPY(NUNIQ,DVAL,YAO(1,JMG),1,RHSO(1,IMG),1)
                IF(I.EQ.J) GO TO 2400
                CALL DAXPY(NUNIQ,DVAL,YAO(1,IMG),1,RHSO(1,JMG),1)
 2400         CONTINUE
C
              DO 2440 M=1,NACT
                IMG = IABS(INDEX(II,M+NCOR))
                IF(IMG.EQ.0) GO TO 2440
                DO 2420 N=1,NACT
                  JNG = IABS(INDEX(JJ,N+NCOR))
                  IF(JNG.EQ.0) GO TO 2420
                  MG = MAX(M,N)
                  NG = MIN(M,N)
                  MN = IA(MG) + NG
                  MNG = MAX(MN,KKLL)
                  KLG = MIN(MN,KKLL)
                  MNKL = IA(MNG) + KLG
                  DVAL = TPDM(MNKL)*XIJKL
                  IF(ABS(DVAL).LT.TOL) GO TO 2420
                  CALL DAXPY(NUNIQ,DVAL,YAO(1,JNG),1,RHSO(1,IMG),1)
                  IF(I.EQ.J) GO TO 2420
                  CALL DAXPY(NUNIQ,DVAL,YAO(1,IMG),1,RHSO(1,JNG),1)
 2420           CONTINUE
 2440         CONTINUE
 2500     CONTINUE
C
C          ----- Finished with current integral buffer -----
C
 3000     CALL DDI_PROCDLB_NEXT(C_VVOO,IWP,ICNTR3)
C
        ENDDO
C
C     ----- Get and use (VO|VO) integrals -----
C
        CALL DDI_DISTRIB(D_VOVO,IWP,ILO,IHI,JLO,JHI)
        MAXWRK = JHI-JLO+1
C
        CALL DDI_PROCDLB_NEXT(C_VOVO,IWP,ICNTR4)
C
        DO WHILE(ICNTR4.LT.MAXWRK)
          JL = JLO + ICNTR4
C
          DO JJ=1,NOCC
            DO LL=1,JJ
              JLTMP = IA(JJ) + LL
              IF(JL.EQ.JLTMP) THEN
                J = JJ
                L = LL
                GO TO 3010
              END IF
            ENDDO
          ENDDO
C
 3010     CALL DDI_GET(D_VOVO,1,NBSQ,JL,JL,BUFF)
C
C          ----- Exchange contribution to orbital hessian -----
C          -----        J and L are core orbitals         -----
C
          IF(J.GT.NCOR) GO TO 3120
          DO 3100 I=1,NVIR
            II = I + NOCC
            IJG = IABS(INDEX(II,J))
            ILG = IABS(INDEX(II,L))
            DO 3100 K=1,NVIR
              KK = K + NOCC
              KJG = IABS(INDEX(KK,J))
              KLG = IABS(INDEX(KK,L))
              IK = (K-1)*NVIR + I
              XIJKL = BUFF(IK)
              IF(ABS(XIJKL).LT.TOL) GO TO 3040
C
              IF((IJG.EQ.0) .OR. (KLG.EQ.0)) GO TO 3030
              DVAL = FOUR*XIJKL
              DVAL = TWO*DVAL
              CALL DAXPY(NUNIQ,DVAL,YAO(1,KLG),1,RHSO(1,IJG),1)
C
 3030         IF((ILG.EQ.0) .OR. (KJG.EQ.0)) GO TO 3040
              DVAL = TWO*XIJKL
              CALL DAXPY(NUNIQ,-DVAL,YAO(1,KJG),1,RHSO(1,ILG),1)
C
 3040         KI = (I-1)*NVIR + K
              XIJKL = BUFF(KI)
              IF(ABS(XIJKL).LT.TOL) GO TO 3100
              IF(J.EQ.L) GO TO 3060
C
              IF((ILG.EQ.0) .OR. (KJG.EQ.0)) GO TO 3050
              DVAL = FOUR*XIJKL
              DVAL = TWO*DVAL
              CALL DAXPY(NUNIQ,DVAL,YAO(1,KJG),1,RHSO(1,ILG),1)
C
 3050         IF((IJG.EQ.0) .OR. (KLG.EQ.0)) GO TO 3060
              DVAL = TWO*XIJKL
              CALL DAXPY(NUNIQ,-DVAL,YAO(1,KLG),1,RHSO(1,IJG),1)
C
 3060         IF(J.NE.L) GO TO 3100
              DO 3070 M=1,NCOR
                IMG = IABS(INDEX(II,M))
                KMG = IABS(INDEX(KK,M))
                IF((IMG.EQ.0) .OR. (KMG.EQ.0)) GO TO 3070
                DVAL = TWO*XIJKL
                CALL DAXPY(NUNIQ,-DVAL,YAO(1,KMG),1,RHSO(1,IMG),1)
 3070         CONTINUE
C
              DO 3090 M=1,NACT
                IMG = IABS(INDEX(II,M+NCOR))
                IF(IMG.EQ.0) GO TO 3090
                DO 3080 N=1,NACT
                  KNG = IABS(INDEX(KK,N+NCOR))
                  IF(KNG.EQ.0) GO TO 3080
                  MG = MAX(M,N)
                  NG = MIN(M,N)
                  MN = IA(MG) + NG
                  DVAL = OPDM(MN)*XIJKL
                  CALL DAXPY(NUNIQ,-DVAL,YAO(1,KNG),1,RHSO(1,IMG),1)
 3080           CONTINUE
 3090         CONTINUE
 3100     CONTINUE
          GO TO 4000
C
C          ----- Exchange contribution to orbital hessian -----
C          -----          J is active, L is core          -----
C
 3120     IF(L.GT.NCOR) GO TO 3220
          DO 3200 I=1,NVIR
            II = I + NOCC
            ILG = IABS(INDEX(II,L))
            DO 3200 K=1,NVIR
              KK = K + NOCC
              IK = (K-1)*NVIR + I
              XIJKL = BUFF(IK)
              IF(ABS(XIJKL).LT.TOL) GO TO 3160
              KLG = IABS(INDEX(KK,L))
C
              DO 3150 M=1,NACT
                MG = MAX(M,J-NCOR)
                JG = MIN(M,J-NCOR)
                MJ = IA(MG) + JG
C
                KMG = IABS(INDEX(KK,M+NCOR))
                IF((ILG.EQ.0) .OR. (KMG.EQ.0)) GO TO 3140
                DVAL = OPDM(MJ)*XIJKL
                CALL DAXPY(NUNIQ,-DVAL,YAO(1,KMG),1,RHSO(1,ILG),1)
C
 3140           IMG = IABS(INDEX(II,M+NCOR))
                IF((IMG.EQ.0) .OR. (KLG.EQ.0)) GO TO 3150
                DVAL = OPDM(MJ)*XIJKL
                DVAL = FOUR*DVAL
                CALL DAXPY(NUNIQ,DVAL,YAO(1,KLG),1,RHSO(1,IMG),1)
 3150         CONTINUE
C
 3160         KI = (I-1)*NVIR + K
              XIJKL = BUFF(KI)
              IF(ABS(XIJKL).LT.TOL) GO TO 3200
C
              DO 3190 M=1,NACT
                MG = MAX(M,J-NCOR)
                JG = MIN(M,J-NCOR)
                MJ = IA(MG) + JG
C
                KMG = IABS(INDEX(KK,M+NCOR))
                IF((ILG.EQ.0) .OR. (KMG.EQ.0)) GO TO 3180
                DVAL = OPDM(MJ)*XIJKL
                DVAL = FOUR*DVAL
                CALL DAXPY(NUNIQ,DVAL,YAO(1,KMG),1,RHSO(1,ILG),1)
C
 3180           IMG = IABS(INDEX(II,M+NCOR))
                IF((IMG.EQ.0) .OR. (KLG.EQ.0)) GO TO 3190
                DVAL = OPDM(MJ)*XIJKL
                CALL DAXPY(NUNIQ,-DVAL,YAO(1,KLG),1,RHSO(1,IMG),1)
 3190         CONTINUE
 3200     CONTINUE
          GO TO 4000
C
C          ----- Exchange contribution to orbital hessian -----
C          -----       J and L are active orbitals        -----
C
 3220     JJLL = IA(J-NCOR) + L-NCOR
          DO 3300 I=1,NVIR
            II = I + NOCC
            DO 3300 K=1,NVIR
              KK = K + NOCC
              IK = (K-1)*NVIR + I
              XIJKL = BUFF(IK)
              IF(ABS(XIJKL).LT.TOL) GO TO 3260
C
              DO 3230 M=1,NCOR
                IMG = IABS(INDEX(II,M))
                KMG = IABS(INDEX(KK,M))
                IF((IMG.EQ.0) .OR. (KMG.EQ.0)) GO TO 3230
                DVAL = OPDM(JJLL)*XIJKL
                CALL DAXPY(NUNIQ,-DVAL,YAO(1,KMG),1,RHSO(1,IMG),1)
 3230         CONTINUE
C
              DO 3250 M=1,NACT
                IMG = IABS(INDEX(II,M+NCOR))
                IF(IMG.EQ.0) GO TO 3250
                MG = MAX(M,J-NCOR)
                JG = MIN(M,J-NCOR)
                MJ = IA(MG) + JG
                DO 3240 N=1,NACT
                  KNG = IABS(INDEX(KK,N+NCOR))
                  IF(KNG.EQ.0) GO TO 3240
                  NG = MAX(N,L-NCOR)
                  LG = MIN(N,L-NCOR)
                  NL = IA(NG) + LG
                  MJG = MAX(MJ,NL)
                  NLG = MIN(MJ,NL)
                  MJNL = IA(MJG) + NLG
                  DVAL = TPDM(MJNL)*XIJKL
                  DVAL = TWO*DVAL
                  CALL DAXPY(NUNIQ,DVAL,YAO(1,KNG),1,RHSO(1,IMG),1)
 3240           CONTINUE
 3250         CONTINUE
C
 3260         IF(J.EQ.L) GO TO 3300
              KI = (I-1)*NVIR + K
              XIJKL = BUFF(KI)
              IF(ABS(XIJKL).LT.TOL) GO TO 3300
C
              DO 3270 M=1,NCOR
                IMG = IABS(INDEX(II,M))
                KMG = IABS(INDEX(KK,M))
                IF((IMG.EQ.0) .OR. (KMG.EQ.0)) GO TO 3270
                DVAL = OPDM(JJLL)*XIJKL
                CALL DAXPY(NUNIQ,-DVAL,YAO(1,KMG),1,RHSO(1,IMG),1)
 3270         CONTINUE
C
              DO 3290 M=1,NACT
                IMG = IABS(INDEX(II,M+NCOR))
                IF(IMG.EQ.0) GO TO 3290
                MG = MAX(M,L-NCOR)
                LG = MIN(M,L-NCOR)
                ML = IA(MG) + LG
                DO 3280 N=1,NACT
                  KNG = IABS(INDEX(KK,N+NCOR))
                  IF(KNG.EQ.0) GO TO 3280
                  NG = MAX(N,J-NCOR)
                  JG = MIN(N,J-NCOR)
                  NJ = IA(NG) + JG
                  MLG = MAX(ML,NJ)
                  NJG = MIN(ML,NJ)
                  MLNJ = IA(MLG) + NJG
                  DVAL = TPDM(MLNJ)*XIJKL
                  DVAL = TWO*DVAL
                  CALL DAXPY(NUNIQ,DVAL,YAO(1,KNG),1,RHSO(1,IMG),1)
 3280           CONTINUE
 3290         CONTINUE
 3300     CONTINUE
C
C          ----- Finished with current integral buffer -----
C
 4000     CALL DDI_PROCDLB_NEXT(C_VOVO,IWP,ICNTR4)
C
        ENDDO
C
 8000 CONTINUE
C
      RETURN
      END
C*MODULE CPMCHF  *DECK HSMLT1
      SUBROUTINE HSMLT1(YAO,YAC,RHSO,RHSC,CI,OINT,AMAT,IROT,
     *                  INDEX,FC,ICIT,ICI2,IND,IO1,JJ,JLO,NSTATS,
     *                  NDETMX,NDETLN,NROT,NINDX,L1,NCOR,N2,NXYZ,
     *                  WSTATE,SALAG)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION YAO(NXYZ,NROT),YAC(NXYZ,NSTATS*NDETMX),RHSO(NXYZ,NROT),
     *          RHSC(NXYZ,NSTATS*NDETLN),CI(NDETMX,NSTATS),OINT(*),
     *          AMAT(L1,NCOR,N2),WSTATE(*),SALAG(L1,L1,NSTATS*NSTATS)
      DIMENSION IROT(L1,L1),INDEX(NINDX,NINDX)
C
      PARAMETER (TOL=1.0D-09)
C
      DO 2000 ISTAT=1,NSTATS
        CVAL = CI(ICI2,ISTAT)
        IWIT = (ISTAT-1)*NDETLN + ICIT - JLO + 1
        FCW = FC*WSTATE(ISTAT)
        IF(ABS(CVAL).LT.TOL) GO TO 1000
        IYIT = (ISTAT-1)*NDETMX + ICIT
C
C     ----- Multiply one-electron part of configuration/orbital -----
C     -----             cross term with trial vector            -----
C
        DO 100 MM=1,L1
          DO 30 NN=1,NCOR
            DLT = AMAT(MM,NN,IND)
            IPHSE = IROT(MM,NN)
            MN = IABS(IPHSE)
            IF((MN.EQ.0) .OR. (ABS(DLT).LT.TOL)) GO TO 30
            DLT = DLT*CVAL
            DO JSTAT=1,NSTATS
              DVAL = DLT*CI(ICIT,JSTAT)
              DVAL = DVAL*FC
              ISVAL = (ISTAT-1)*NSTATS + JSTAT
              SALAG(MM,NN,ISVAL) = SALAG(MM,NN,ISVAL) + DVAL
            ENDDO
C
            DLT = DLT*FCW*MN/IPHSE
            IF(ABS(FCW).LT.TOL) GO TO 30
            CALL DAXPY(NXYZ,DLT,YAO(1,MN),1,RHSC(1,IWIT),1)
            CALL DAXPY(NXYZ,DLT,YAC(1,IYIT),1,RHSO(1,MN),1)
   30     CONTINUE
C
          MI = INDEX(MM,IO1+NCOR)
          DLT = OINT(MI)
          IPHSE = IROT(MM,JJ+NCOR)
          MJ = IABS(IPHSE)
          IF((MJ.EQ.0) .OR. (ABS(DLT).LT.TOL)) GO TO 60
          DLT = DLT*CVAL
          DO JSTAT=1,NSTATS
            DVAL = DLT*CI(ICIT,JSTAT)
            DVAL = DVAL*FC
            ISVAL = (ISTAT-1)*NSTATS + JSTAT
            SALAG(MM,JJ+NCOR,ISVAL) = SALAG(MM,JJ+NCOR,ISVAL) + DVAL
          ENDDO
C
          DLT = DLT*FCW*MJ/IPHSE
          IF(ABS(FCW).LT.TOL) GO TO 60
          CALL DAXPY(NXYZ,DLT,YAO(1,MJ),1,RHSC(1,IWIT),1)
          CALL DAXPY(NXYZ,DLT,YAC(1,IYIT),1,RHSO(1,MJ),1)
C
C          ----- NOTE:  The following term corresponds to -----
C          -----  swapping determinants.  While this is   -----
C          -----   not supposed to be performed for the   -----
C          -----   diagonal term, we do need to double    -----
C          ----- count the diagonal contribution, so this -----
C          -----               step is OK.                -----
C
   60     MJ = INDEX(MM,JJ+NCOR)
          DLT = OINT(MJ)
          IPHSE = IROT(MM,IO1+NCOR)
          MI = IABS(IPHSE)
          IF((MI.EQ.0) .OR. (ABS(DLT).LT.TOL)) GO TO 100
          DLT = DLT*CVAL
          DO JSTAT=1,NSTATS
            DVAL = DLT*CI(ICIT,JSTAT)
            DVAL = DVAL*FC
            ISVAL = (ISTAT-1)*NSTATS + JSTAT
            SALAG(MM,IO1+NCOR,ISVAL) = SALAG(MM,IO1+NCOR,ISVAL) + DVAL
          ENDDO
C
          DLT = DLT*FCW*MI/IPHSE
          IF(ABS(FCW).LT.TOL) GO TO 100
          CALL DAXPY(NXYZ,DLT,YAO(1,MI),1,RHSC(1,IWIT),1)
          CALL DAXPY(NXYZ,DLT,YAC(1,IYIT),1,RHSO(1,MI),1)
  100   CONTINUE
C
C     ----- Multiply one-electron part of configuration hessian -----
C     -----            cross term with trial vector             -----
C
 1000   IF(ABS(FCW).LT.TOL) GO TO 2000
        IJ = INDEX(IO1+NCOR,JJ+NCOR)
        DLT = FCW*OINT(IJ)
        IYI2 = (ISTAT-1)*NDETMX + ICI2
        CALL DAXPY(NXYZ,DLT,YAC(1,IYI2),1,RHSC(1,IWIT),1)
 2000 CONTINUE
C
      RETURN
      END
C*MODULE CPMCHF  *DECK HSMLT2
      SUBROUTINE HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,FC,ICIT,
     *                  ICI2,I,J,K,L,IJ,KL,JLO,NDETMX,NDETLN,NROT,
     *                  NSTATS,L1,NCOR,NACT,N2,NXYZ,WSTATE,SALAG)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION YAO(NXYZ,NROT),YAC(NXYZ,NSTATS*NDETMX),RHSO(NXYZ,NROT),
     *          RHSC(NXYZ,NSTATS*NDETLN),CI(NDETMX,NSTATS),
     *          ERI(L1,NACT,N2),WSTATE(*),SALAG(L1,L1,NSTATS*NSTATS)
      DIMENSION IROT(L1,L1)
C
      PARAMETER (TOL=1.0D-09)
C
      DO 2000 ISTAT=1,NSTATS
        CVAL = CI(ICI2,ISTAT)
        IWIT = (ISTAT-1)*NDETLN + ICIT - JLO + 1
        FCW = FC*WSTATE(ISTAT)
        IF(ABS(CVAL).LT.TOL) GO TO 1000
        IYIT = (ISTAT-1)*NDETMX + ICIT
C
C     ----- Multiply two-electron part of configuration/orbital -----
C     -----            cross term with trial vectors            -----
C
        DO 400 M=1,L1
          DLT = ERI(M,J,KL)
          IPHSE = IROT(M,I+NCOR)
          MI = IABS(IPHSE)
          IF((MI.EQ.0) .OR. (ABS(DLT).LT.TOL)) GO TO 100
          DLT = DLT*CVAL
          DO JSTAT=1,NSTATS
            DVAL = DLT*CI(ICIT,JSTAT)
            DVAL = DVAL*FC
            ISVAL = (ISTAT-1)*NSTATS + JSTAT
            SALAG(M,I+NCOR,ISVAL) = SALAG(M,I+NCOR,ISVAL) + DVAL
          ENDDO
C
          DLT = DLT*FCW*MI/IPHSE
          IF(ABS(FCW).LT.TOL) GO TO 100
          CALL DAXPY(NXYZ,DLT,YAO(1,MI),1,RHSC(1,IWIT),1)
          CALL DAXPY(NXYZ,DLT,YAC(1,IYIT),1,RHSO(1,MI),1)
C
  100     DLT = ERI(M,L,IJ)
          IPHSE = IROT(M,K+NCOR)
          MK = IABS(IPHSE)
          IF((MK.EQ.0) .OR. (ABS(DLT).LT.TOL)) GO TO 200
          DLT = DLT*CVAL
          DO JSTAT=1,NSTATS
            DVAL = DLT*CI(ICIT,JSTAT)
            DVAL = DVAL*FC
            ISVAL = (ISTAT-1)*NSTATS + JSTAT
            SALAG(M,K+NCOR,ISVAL) = SALAG(M,K+NCOR,ISVAL) + DVAL
          ENDDO
C
          DLT = DLT*FCW*MK/IPHSE
          IF(ABS(FCW).LT.TOL) GO TO 200
          CALL DAXPY(NXYZ,DLT,YAO(1,MK),1,RHSC(1,IWIT),1)
          CALL DAXPY(NXYZ,DLT,YAC(1,IYIT),1,RHSO(1,MK),1)
C
C          ----- NOTE:  Again, we are swapping determinants -----
C          -----  and are double counting for the diagonal  -----
C          -----                contribution                -----
C
  200     DLT = ERI(M,I,KL)
          IPHSE = IROT(M,J+NCOR)
          MJ = IABS(IPHSE)
          IF((MJ.EQ.0) .OR. (ABS(DLT).LT.TOL)) GO TO 300
          DLT = DLT*CVAL
          DO JSTAT=1,NSTATS
            DVAL = DLT*CI(ICIT,JSTAT)
            DVAL = DVAL*FC
            ISVAL = (ISTAT-1)*NSTATS + JSTAT
            SALAG(M,J+NCOR,ISVAL) = SALAG(M,J+NCOR,ISVAL) + DVAL
          ENDDO
C
          DLT = DLT*FCW*MJ/IPHSE
          IF(ABS(FCW).LT.TOL) GO TO 300
          CALL DAXPY(NXYZ,DLT,YAO(1,MJ),1,RHSC(1,IWIT),1)
          CALL DAXPY(NXYZ,DLT,YAC(1,IYIT),1,RHSO(1,MJ),1)
C
  300     DLT = ERI(M,K,IJ)
          IPHSE = IROT(M,L+NCOR)
          ML = IABS(IPHSE)
          IF((ML.EQ.0) .OR. (ABS(DLT).LT.TOL)) GO TO 400
          DLT = DLT*CVAL
          DO JSTAT=1,NSTATS
            DVAL = DLT*CI(ICIT,JSTAT)
            DVAL = DVAL*FC
            ISVAL = (ISTAT-1)*NSTATS + JSTAT
            SALAG(M,L+NCOR,ISVAL) = SALAG(M,L+NCOR,ISVAL) + DVAL
          ENDDO
C
          DLT = DLT*FCW*ML/IPHSE
          IF(ABS(FCW).LT.TOL) GO TO 400
          CALL DAXPY(NXYZ,DLT,YAO(1,ML),1,RHSC(1,IWIT),1)
          CALL DAXPY(NXYZ,DLT,YAC(1,IYIT),1,RHSO(1,ML),1)
  400   CONTINUE
C
C     ----- Multiply two-electron part of configuration hessian -----
C     -----                 with trial vectors                  -----
C
 1000   IF(ABS(FCW).LT.TOL) GO TO 2000
        DLT = FCW*ERI(I+NCOR,J,KL)
        IYI2 = (ISTAT-1)*NDETMX + ICI2
        CALL DAXPY(NXYZ,DLT,YAC(1,IYI2),1,RHSC(1,IWIT),1)
 2000 CONTINUE
C
      RETURN
      END
C*MODULE CPMCHF  *DECK HSSCX2
      SUBROUTINE HSSCX2(NACT,NCOR,NA,NB,NALP,NBLP,IFA,IOX,NSYM,IACON1,
     *                  IBCON1,IACON2,IPOSA,IPERA,IIND1,INDEX,IMMA,
     *                  IMMC,ISYMA,ISYMB,ITAB,IMUL,ISPA,ISPB,ISAS,
     *                  ISBS,ISAC,ISBC,ISTRB,ISTRP,ISTART,CI,OINT,
     *                  AMAT,ERI,L1,L2,NROT,NCI,IROT,RHSC,RHSO,YAO,
     *                  YAC,NDETLN,NXYZ,NINDX,JLO,JHI,NSTATS,WSTATE,
     *                  SALAG)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      INTEGER POSCP
C
      DIMENSION RHSC(NXYZ,NSTATS*NDETLN),RHSO(NXYZ,NROT)
      DIMENSION YAO(NXYZ,NROT),CI(NCI,NSTATS),YAC(NXYZ,NSTATS*NCI)
      DIMENSION OINT(L2),ERI(L1,NACT,(NACT**2+NACT)/2)
      DIMENSION AMAT(L1,NCOR,(NACT**2+NACT)/2),IROT(L1,L1)
      DIMENSION WSTATE(*),SALAG(*)
C
      DIMENSION IOX(NACT)
      DIMENSION IFA(0:NACT,0:NACT)
      DIMENSION IACON1(NA),IBCON1(NA)
      DIMENSION IACON2(NA),IPERA(NA*(NACT-NA))
      DIMENSION IIND1(NA*(NACT-NA),3)
      DIMENSION IPOSA(NA*(NACT-NA))
      DIMENSION INDEX(NINDX,NINDX)
      DIMENSION IMMA(NSYM,NA*(NACT-NA)),IMMC(NSYM)
      DIMENSION ISYMA(NALP),ISYMB(NBLP)
      DIMENSION ITAB(NSYM),IMUL(NSYM,NSYM)
      DIMENSION ISPA(NALP),ISPB(NBLP)
      DIMENSION ISAS(NSYM+1),ISBS(NSYM+1),ISAC(NALP),ISBC(NBLP)
      DIMENSION ISTRB((NBLP*NB*(NACT-NB))/2)
      DIMENSION ISTRP((NBLP*NB*(NACT-NB))/2)
      DIMENSION ISTART(NBLP)
C
      PARAMETER (ONE=1.0D+00)
      ICONST = 1
C     IF (NA.EQ.NB) ICONST = 1
C
      DO 7 I=1,NINDX
         DO 8 J=1,I
            INDEX(I,J) = I*(I-1)/2 + J
            INDEX(J,I) = INDEX(I,J)
    8    CONTINUE
    7 CONTINUE
C
      NAT = NA
      NBT = NB
      NNACT = (NACT*NACT+NACT)/2
C
      DO 30 I=1,NAT
         IACON1(I) = I
   30 CONTINUE
C
C   Big Loop over all alpha determinants
C
      DO 9000 IJK = 1,NALP
C
C  Alpha excitations here
C   Single first
C
         IAC = 0
         DO 45 II=1,NSYM
            IMMC(II) = 0
   45    CONTINUE
         ICAT = ISPA(IJK)
         ISA1 = ISYMA(IJK)
         ITAS = ITAB(ISA1)
         DO 7030 IA=1,NAT
             IO1 = IACON1(IA)
             IS1 = IOX(IO1)
             IST = IO1 + 1
             IEN = IACON1(IA+1)-1
             IF (IA.EQ.NAT) IEN=NACT
             DO 7025 KKJ=IA+1,NA+1
                DO 7020 JJ=IST,IEN
                IS2 = IOX(JJ)
                IP1 = IMUL(IS2,IS1)
C
             IAC = IAC + 1
             CALL RET1CP(IACON1,IACON2,NA,IA,JJ,0,KKJ,IPER1)
C
C   Storage here for later use, well worth it
C
             IPET = POSCP(NACT,NA,IACON2,IFA)
             IPOSA(IAC) = ISPA(IPET)
             IMMC(ISYMA(IPET)) = IMMC(ISYMA(IPET)) + 1
             IMMA(ISYMA(IPET),IMMC(ISYMA(IPET))) = IAC
             IPERA(IAC) = ((-1)**IPER1)*ICONST
             IND = INDEX(JJ,IO1)
             IIND1(IAC,1) = IND
             IIND1(IAC,2) = IO1
             IIND1(IAC,3) = JJ
Cc If deoccupied and newly occupied orbitals are of diff symm,
C  skip to doubles
             IF (IS1.NE.IS2) GOTO 417
C
         DO 49 I=1,NBT
            IBCON1(I) = I
   49    CONTINUE
C
C    Loop over beta dets of the right symmetry
C
                   DO 407 INBB = ISBS(ISA1),ISBS(ISA1+1)-1
                   INB1 = ISBC(INBB)
                   ICIT = ICAT+ISPB(INB1)
                   ICI2 = IPOSA(IAC) + ISPB(INB1)
                   FC = IPERA(IAC)
C
                   IF(ICIT.GE.JLO .AND. ICIT.LE.JHI) THEN
                     CALL HSMLT1(YAO,YAC,RHSO,RHSC,CI,OINT,AMAT,IROT,
     *                           INDEX,FC,ICIT,ICI2,IND,IO1,JJ,JLO,
     *                           NSTATS,NCI,NDETLN,NROT,NINDX,L1,NCOR,
     *                           NNACT,NXYZ,WSTATE,SALAG)
                   ENDIF
                   IF(ICI2.GE.JLO .AND. ICI2.LE.JHI) THEN
                     CALL HSMLT1(YAO,YAC,RHSO,RHSC,CI,OINT,AMAT,IROT,
     *                           INDEX,FC,ICI2,ICIT,IND,IO1,JJ,JLO,
     *                           NSTATS,NCI,NDETLN,NROT,NINDX,L1,NCOR,
     *                           NNACT,NXYZ,WSTATE,SALAG)
                   ENDIF
  407          CONTINUE
C
                   DO 487 IK=1,NAT
                      IF (IK.EQ.IA) GOTO 487
                      ION = IACON1(IK)
                      J1 = INDEX(ION,ION)
                      J2 = INDEX(ION,JJ)
                      J3 = INDEX(ION,IO1)
C
                   DO 413 INBB=ISBS(ISA1),ISBS(ISA1+1)-1
                      INB1 = ISBC(INBB)
                      ICIT = ICAT+ISPB(INB1)
                      ICI2 = IPOSA(IAC)+ISPB(INB1)
                      FC = IPERA(IAC)
C
                     IF(ICIT.GE.JLO .AND. ICIT.LE.JHI) THEN
                       CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,FC,
     *                             ICIT,ICI2,IO1,JJ,ION,ION,IND,J1,JLO,
     *                             NCI,NDETLN,NROT,NSTATS,L1,NCOR,NACT,
     *                             NNACT,NXYZ,WSTATE,SALAG)
                       CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,-FC,
     *                             ICIT,ICI2,IO1,ION,ION,JJ,J3,J2,JLO,
     *                             NCI,NDETLN,NROT,NSTATS,L1,NCOR,NACT,
     *                             NNACT,NXYZ,WSTATE,SALAG)
                     ENDIF
                     IF(ICI2.GE.JLO .AND. ICI2.LE.JHI) THEN
                       CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,FC,
     *                             ICI2,ICIT,IO1,JJ,ION,ION,IND,J1,JLO,
     *                             NCI,NDETLN,NROT,NSTATS,L1,NCOR,NACT,
     *                             NNACT,NXYZ,WSTATE,SALAG)
                       CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,-FC,
     *                             ICI2,ICIT,IO1,ION,ION,JJ,J3,J2,JLO,
     *                             NCI,NDETLN,NROT,NSTATS,L1,NCOR,NACT,
     *                             NNACT,NXYZ,WSTATE,SALAG)
                     ENDIF
  413              CONTINUE
C
  487              CONTINUE
C
C                  do 415 inb1=1,nblp
                  NST = 1
                  DO 415 INBB = ISBS(ISA1),ISBS(ISA1+1)-1
                  NEND = ISBC(INBB)
                  DO 5510 KK=NST,NEND-1
                     CALL ADVNCP(IBCON1,NBT,NACT)
 5510             CONTINUE
C
                  ICIT = ICAT+ISPB(NEND)
                  ICI2 = IPOSA(IAC)+ISPB(NEND)
C
                  FC = IPERA(IAC)
C
                     DO 790 IK=1,NBT
                     ION = IBCON1(IK)
                     J1 = INDEX(ION,ION)
C
                     IF(ICIT.GE.JLO .AND. ICIT.LE.JHI) THEN
                       CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,FC,
     *                             ICIT,ICI2,IO1,JJ,ION,ION,IND,J1,JLO,
     *                             NCI,NDETLN,NROT,NSTATS,L1,NCOR,NACT,
     *                             NNACT,NXYZ,WSTATE,SALAG)
                     ENDIF
                     IF(ICI2.GE.JLO .AND. ICI2.LE.JHI) THEN
                       CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,FC,
     *                             ICI2,ICIT,IO1,JJ,ION,ION,IND,J1,JLO,
     *                             NCI,NDETLN,NROT,NSTATS,L1,NCOR,NACT,
     *                             NNACT,NXYZ,WSTATE,SALAG)
                     ENDIF
  790              CONTINUE
C
Cd           call ADVNCP(ibcon1,nbt,norb)
          NST = NEND
  415     CONTINUE
C
  417     CONTINUE
C
C      Double excitations
C
          DO 4015 IAA = IA+1,NAT
             IPA = IAA
             IIA = IACON1(IAA)
             IS3 = IOX(IIA)
             IF (JJ.GT.IIA) IPA = IPA - 1
             ISTAA = JJ+1
             IENAA = IEN
             DO 4010 KKJAA=KKJ,NA+1
                DO 4005 JJAA=ISTAA,IENAA
                IS4 = IOX(JJAA)
                IP2 = IMUL(IS4,IS3)
                IF (IP1.NE.IP2) GOTO 4005
C
             CALL RET1CP(IACON2,IBCON1,NA,IPA,JJAA,0,KKJAA,IPER2)
             IPET = POSCP(NACT,NA,IBCON1,IFA)
             ICA1 = ISPA(IPET)
             IPERT = IPER1+IPER2
             IPERT = ((-1)**IPERT)*ICONST
                   I2 = INDEX(IACON1(IAA),JJAA)
                   II1 = INDEX(JJAA,IO1)
                   II2 = INDEX(IACON1(IAA),JJ)
C
                DO 786 INB1 = ISBS(ISA1),ISBS(ISA1+1)-1
                   NEND = ISBC(INB1)
                   ICI2 = ICA1 + ISPB(NEND)
                   ICIT = ICAT+ISPB(NEND)
                   FC = IPERT
C
                   IF(ICIT.GE.JLO .AND. ICIT.LE.JHI) THEN
                     CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,FC,
     *                           ICIT,ICI2,IO1,JJ,IIA,JJAA,IND,I2,
     *                           JLO,NCI,NDETLN,NROT,NSTATS,L1,NCOR,
     *                           NACT,NNACT,NXYZ,WSTATE,SALAG)
                     CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,-FC,
     *                           ICIT,ICI2,IO1,JJAA,IIA,JJ,II1,II2,
     *                           JLO,NCI,NDETLN,NROT,NSTATS,L1,NCOR,
     *                           NACT,NNACT,NXYZ,WSTATE,SALAG)
                   ENDIF
                   IF(ICI2.GE.JLO .AND. ICI2.LE.JHI) THEN
                     CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,FC,
     *                           ICI2,ICIT,IO1,JJ,IIA,JJAA,IND,I2,
     *                           JLO,NCI,NDETLN,NROT,NSTATS,L1,NCOR,
     *                           NACT,NNACT,NXYZ,WSTATE,SALAG)
                     CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,-FC,
     *                           ICI2,ICIT,IO1,JJAA,IIA,JJ,II1,II2,
     *                           JLO,NCI,NDETLN,NROT,NSTATS,L1,NCOR,
     *                           NACT,NNACT,NXYZ,WSTATE,SALAG)
                   ENDIF
  786       CONTINUE
C
 4005           CONTINUE
                ISTAA = IACON1(KKJAA)+1
                IENAA = IACON1(KKJAA+1)-1
                IF (KKJAA.EQ.NA) IENAA=NACT
 4010        CONTINUE
 4015 CONTINUE
C
C
 7020           CONTINUE
                IST = IACON1(KKJ)+1
                IEN = IACON1(KKJ+1)-1
                IF (KKJ.EQ.NA) IEN=NACT
 7025        CONTINUE
 7030     CONTINUE
C
C  Diagonal
C
            DO 67 II=1,NAT
               I1 = IACON1(II)
               IND1 = INDEX(I1,I1)
C
              DO 53 INB1 = ISBS(ISA1),ISBS(ISA1+1)-1
                NEND = ISBC(INB1)
                ICIT = ICAT+ISPB(NEND)
                FC = ONE
C
                IF(ICIT.GE.JLO .AND. ICIT.LE.JHI) THEN
                  CALL HSMLT1(YAO,YAC,RHSO,RHSC,CI,OINT,AMAT,IROT,
     *                        INDEX,FC,ICIT,ICIT,IND1,I1,I1,JLO,
     *                        NSTATS,NCI,NDETLN,NROT,NINDX,L1,NCOR,
     *                        NNACT,NXYZ,WSTATE,SALAG)
                ENDIF
   53         CONTINUE
C
               DO 64 JJ=II+1,NAT
                  I2 = IACON1(JJ)
                  IND2 = INDEX(I2,I2)
                  INDM = IND2 - I2 + I1
                  J1 = INDEX(INDM,INDM)
                  J2 = INDEX(IND2,IND1)
C
               DO 55 INB1 = ISBS(ISA1),ISBS(ISA1+1)-1
                  NEND = ISBC(INB1)
                  ICIT = ICAT+ISPB(NEND)
                  FC = ONE
C
                  IF(ICIT.GE.JLO .AND. ICIT.LE.JHI) THEN
                    CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,FC,
     *                          ICIT,ICIT,I1,I1,I2,I2,IND1,IND2,
     *                          JLO,NCI,NDETLN,NROT,NSTATS,L1,NCOR,
     *                          NACT,NNACT,NXYZ,WSTATE,SALAG)
                    CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,-FC,
     *                          ICIT,ICIT,I1,I2,I2,I1,INDM,INDM,
     *                          JLO,NCI,NDETLN,NROT,NSTATS,L1,NCOR,
     *                          NACT,NNACT,NXYZ,WSTATE,SALAG)
                  ENDIF
   55          CONTINUE
C
   64          CONTINUE
C
         DO 47 I=1,NBT
            IBCON1(I) = I
   47    CONTINUE
C
             NST = 1
             DO 56 INB1 = ISBS(ISA1),ISBS(ISA1+1)-1
             NEND = ISBC(INB1)
             DO 7710 KK=NST,NEND-1
                CALL ADVNCP(IBCON1,NBT,NACT)
 7710        CONTINUE
             ICIT = ICAT+ISPB(NEND)
C
               DO 68 JJ=1,NBT
                  I2 = IBCON1(JJ)
                  IND2 = INDEX(I2,I2)
                  J2 = INDEX(IND1,IND2)
                  FC = ONE
C
                  IF(ICIT.GE.JLO .AND. ICIT.LE.JHI) THEN
                    CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,FC,
     *                          ICIT,ICIT,I1,I1,I2,I2,IND1,IND2,
     *                          JLO,NCI,NDETLN,NROT,NSTATS,L1,NCOR,
     *                          NACT,NNACT,NXYZ,WSTATE,SALAG)
                  ENDIF
   68          CONTINUE
C
Cc           call ADVNCP(ibcon1,nbt,norb)
            NST = NEND
   56       CONTINUE
C
   67       CONTINUE
C
C   Loop over Beta dets now
C
C        IF (NA.NE.NB) THEN
         DO 40 II=1,NBT
            IBCON1(II) = II
   40    CONTINUE
         JJZ = 1
C        ELSE
C        DO 41 II=1,NBT
C           IBCON1(II) = IACON1(II)
C  41    CONTINUE
C        JJZ = IJK
C        ENDIF
C
         DO 8000 KJI = JJZ,NBLP
         ISTAR = ISTART(KJI)-1
         IPB1 = ISPB(KJI)
         ISB1 = ISYMB(KJI)
         ITBS = ITAB(ISB1)
         IMZZ = IMMC(ITBS)
         M1 = 0
         M2 = 0
         IF (ISB1.EQ.ITAS) M1 = 1
         IF (IMZZ.NE.0) M2 = 1
         IF (M1.EQ.0.AND.M2.EQ.0) GOTO 7998
         QNUM = 1.0D+00
C        IF (NA.EQ.NB.AND.IJK.EQ.KJI) QNUM=2.0D+00
         IC1 = ICAT + IPB1
C
C   Beta first *********************** Single
C
          DO 900 IB=1,NBT
             IBB = IBCON1(IB)
             IB1 = IOX(IBB)
             IR1 = IMUL(IB1,ISB1)
             IST = IBB+1
             IEN = IBCON1(IB+1)-1
             IF (IB.EQ.NBT) IEN = NACT
             DO 895 KKJ=IB+1,NB+1
                DO 890 JJ=IST,IEN
                IB2 = IOX(JJ)
                ISB2 = IMUL(IR1,IB2)
                ITB2 = ITAB(ISB2)
                ISTAR = ISTAR + 1
                IF (ISB2.NE.ITAS.AND.M1.EQ.0) GOTO 890
                IF (M2.EQ.0.AND.IMMC(ITB2).EQ.0) GOTO 890
                IF (ISB2.NE.ITAS.AND.IMMC(ITB2).EQ.0) GOTO 890
C
C               call RET1MC(ibcon1,iacon2,nb,ib,jj,ncor,kkj,iper1)
C                   iposb = POSCP(nact,nb,iacon2,ifa)
C                  ipb2 = ispb(iposb)
                   IPB2 = ISTRB(ISTAR)
                   IC2 = ICAT + IPB2
C           iperb = ((-1)**iper1)
C   iperb1 = ((-1)**iper1)
                   ZPERB = ISTRP(ISTAR)/QNUM
                   IOB = INDEX(IBB,JJ)
C
C           do 1013 iat=1,iac
C                  ici2 = iposa(iat) + iposb
C                  ici3 = iposa(iat) + kji
CcState average here
C               fc = 0.0d+00
C               fc1 = 0.0d+00
C             do 319 kki=1,nstate
C             fc = fc + W(kki)*CI(ici1,iwh(kki))*CI(ici2,iwh(kki))
C             fc1 = fc1+W(kki)*CI(ici3,iwh(kki))*CI(icit,iwh(kki))
C  319          continue
C             fc = fc * ipera(iat)*zperb
C             fc1=fc1 * ipera(iat)*zperb1
C
C                   ind = iind1(iat)
C                    ix = index(ind,iob)
C                   den2(ix) = den2(ix)+fc+fc1
C                   den2(ix) = den2(ix) + fc
C 1013      continue
C
            IF (M2.EQ.0.AND.IMMC(ITB2).NE.0) THEN
               DO 1013 IAT = 1,IMMC(ITB2)
                  IJU = IMMA(ITB2,IAT)
                  IC4 = IPOSA(IJU) + IPB2
                  IND = IIND1(IJU,1)
                  IXI = IIND1(IJU,2)
                  IXJ = IIND1(IJU,3)
                  FC = IPERA(IJU)*ZPERB
C
                  IF(IC1.GE.JLO .AND. IC1.LE.JHI) THEN
                    CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,FC,
     *                          IC1,IC4,IXI,IXJ,IBB,JJ,IND,IOB,
     *                          JLO,NCI,NDETLN,NROT,NSTATS,L1,NCOR,
     *                          NACT,NNACT,NXYZ,WSTATE,SALAG)
                  ENDIF
                  IF(IC4.GE.JLO .AND. IC4.LE.JHI) THEN
                    CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,FC,
     *                          IC4,IC1,IXI,IXJ,IBB,JJ,IND,IOB,
     *                          JLO,NCI,NDETLN,NROT,NSTATS,L1,NCOR,
     *                          NACT,NNACT,NXYZ,WSTATE,SALAG)
                  ENDIF
 1013          CONTINUE
               GOTO 890
          ENDIF
C
            IF (M1.EQ.0.AND.ISB2.EQ.ITAS) THEN
               DO 2013 IAT =1,IMMC(ITBS)
                  IJU = IMMA(ITBS,IAT)
                  IC3 = IPOSA(IJU) + IPB1
                  IND = IIND1(IJU,1)
                  IXI = IIND1(IJU,2)
                  IXJ = IIND1(IJU,3)
                  FC = IPERA(IJU)*ZPERB
C
                  IF(IC2.GE.JLO .AND. IC2.LE.JHI) THEN
                    CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,FC,
     *                          IC2,IC3,IXI,IXJ,IBB,JJ,IND,IOB,
     *                          JLO,NCI,NDETLN,NROT,NSTATS,L1,NCOR,
     *                          NACT,NNACT,NXYZ,WSTATE,SALAG)
                  ENDIF
                  IF(IC3.GE.JLO .AND. IC3.LE.JHI) THEN
                    CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,FC,
     *                          IC3,IC2,IXI,IXJ,IBB,JJ,IND,IOB,
     *                          JLO,NCI,NDETLN,NROT,NSTATS,L1,NCOR,
     *                          NACT,NNACT,NXYZ,WSTATE,SALAG)
                  ENDIF
 2013          CONTINUE
               GOTO 890
            ENDIF
C
            IF (ISB2.NE.ITAS.AND.IMMC(ITB2).NE.0) THEN
               DO 3013 IAT = 1,IMMC(ITB2)
                  IJU = IMMA(ITB2,IAT)
                  IC4 = IPOSA(IJU) + IPB2
                  IND = IIND1(IJU,1)
                  IXI = IIND1(IJU,2)
                  IXJ = IIND1(IJU,3)
                  FC = IPERA(IJU)*ZPERB
C
                  IF(IC1.GE.JLO .AND. IC1.LE.JHI) THEN
                    CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,FC,
     *                          IC1,IC4,IXI,IXJ,IBB,JJ,IND,IOB,
     *                          JLO,NCI,NDETLN,NROT,NSTATS,L1,NCOR,
     *                          NACT,NNACT,NXYZ,WSTATE,SALAG)
                  ENDIF
                  IF(IC4.GE.JLO .AND. IC4.LE.JHI) THEN
                    CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,FC,
     *                          IC4,IC1,IXI,IXJ,IBB,JJ,IND,IOB,
     *                          JLO,NCI,NDETLN,NROT,NSTATS,L1,NCOR,
     *                          NACT,NNACT,NXYZ,WSTATE,SALAG)
                  ENDIF
 3013          CONTINUE
               GOTO 890
            ENDIF
C
            IF (IMMC(ITB2).EQ.0.AND.ISB2.EQ.ITAS) THEN
               DO 4013 IAT =1,IMMC(ITBS)
                  IJU = IMMA(ITBS,IAT)
                  IC3 = IPOSA(IJU) + IPB1
                  IND = IIND1(IJU,1)
                  IXI = IIND1(IJU,2)
                  IXJ = IIND1(IJU,3)
                  FC = IPERA(IJU)*ZPERB
C
                  IF(IC2.GE.JLO .AND. IC2.LE.JHI) THEN
                    CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,FC,
     *                          IC2,IC3,IXI,IXJ,IBB,JJ,IND,IOB,
     *                          JLO,NCI,NDETLN,NROT,NSTATS,L1,NCOR,
     *                          NACT,NNACT,NXYZ,WSTATE,SALAG)
                  ENDIF
                  IF(IC3.GE.JLO .AND. IC3.LE.JHI) THEN
                    CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,FC,
     *                          IC3,IC2,IXI,IXJ,IBB,JJ,IND,IOB,
     *                          JLO,NCI,NDETLN,NROT,NSTATS,L1,NCOR,
     *                          NACT,NNACT,NXYZ,WSTATE,SALAG)
                  ENDIF
 4013          CONTINUE
               GOTO 890
            ENDIF
C
            IF (IMMC(ITB2).NE.0.AND.ISB2.EQ.ITAS) THEN
               DO 5013 IAT=1,IMMC(ITB2)
                  IJU = IMMA(ITB2,IAT)
                  IC3 = IPOSA(IJU) + IPB1
                  IC4 = IPOSA(IJU) + IPB2
                  IND = IIND1(IJU,1)
                  IXI = IIND1(IJU,2)
                  IXJ = IIND1(IJU,3)
                  FC = IPERA(IJU)*ZPERB
C
                  IF(IC2.GE.JLO .AND. IC2.LE.JHI) THEN
                    CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,FC,
     *                          IC2,IC3,IXI,IXJ,IBB,JJ,IND,IOB,
     *                          JLO,NCI,NDETLN,NROT,NSTATS,L1,NCOR,
     *                          NACT,NNACT,NXYZ,WSTATE,SALAG)
                  ENDIF
                  IF(IC3.GE.JLO .AND. IC3.LE.JHI) THEN
                    CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,FC,
     *                          IC3,IC2,IXI,IXJ,IBB,JJ,IND,IOB,
     *                          JLO,NCI,NDETLN,NROT,NSTATS,L1,NCOR,
     *                          NACT,NNACT,NXYZ,WSTATE,SALAG)
                  ENDIF
C
                  IF(IC1.GE.JLO .AND. IC1.LE.JHI) THEN
                    CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,FC,
     *                          IC1,IC4,IXI,IXJ,IBB,JJ,IND,IOB,
     *                          JLO,NCI,NDETLN,NROT,NSTATS,L1,NCOR,
     *                          NACT,NNACT,NXYZ,WSTATE,SALAG)
                  ENDIF
                  IF(IC4.GE.JLO .AND. IC4.LE.JHI) THEN
                    CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,FC,
     *                          IC4,IC1,IXI,IXJ,IBB,JJ,IND,IOB,
     *                          JLO,NCI,NDETLN,NROT,NSTATS,L1,NCOR,
     *                          NACT,NNACT,NXYZ,WSTATE,SALAG)
                  ENDIF
 5013          CONTINUE
               GOTO 890
            ENDIF
C
  890           CONTINUE
                IST = IBCON1(KKJ)+1
                IEN = IBCON1(KKJ+1)-1
                IF (KKJ.EQ.NB) IEN=NACT
  895        CONTINUE
  900     CONTINUE
C
 7998     CONTINUE
           CALL ADVNCP(IBCON1,NBT,NACT)
 8000    CONTINUE
      CALL ADVNCP(IACON1,NAT,NACT)
 9000 CONTINUE
C
C   Now for the Beta part
C
C
      DO 876 JJI=1,NBT
         IBCON1(JJI) = JJI
  876 CONTINUE
C
      DO 9999 IJK = 1,NBLP
         ICAB = ISPB(IJK)
         ISB1 = ISYMB(IJK)
C itb1 = itab(isb1)
C        IF (NA.EQ.NB) GOTO 7999
C
      DO 6030 IB=1,NBT
         IST = IBCON1(IB)+1
         IEN = IBCON1(IB+1)-1
         IF (IB.EQ.NBT) IEN=NACT
         IO1 = IBCON1(IB)
         IS1 = IOX(IO1)
         DO 6025 KKJ=IB+1,NB+1
            DO 6020 JJ=IST,IEN
            IS2 = IOX(JJ)
            IP1 = IMUL(IS2,IS1)
C
            CALL RET1CP(IBCON1,IACON2,NB,IB,JJ,0,KKJ,IPER1)
C           IPER = ((-1)**IPER1)*2
            IPER = ((-1)**IPER1)
            IND = INDEX(JJ,IO1)
Cc If deoccupied and newly occupied are of diff sym,
C   then skip to doubles
            IF (IS1.NE.IS2) GOTO 517
            IPB1 = POSCP(NACT,NB,IACON2,IFA)
            IPB1 = ISPB(IPB1)
       DO 89 I=1,NAT
          IACON1(I) = I
   89 CONTINUE
C
C  Loop over alpha
C
          DO 907 INA1 = ISAS(ISB1),ISAS(ISB1+1)-1
             ICIA = ISAC(INA1)
             ICIT = ISPA(ICIA) + ICAB
             ICI2 = ISPA(ICIA) + IPB1
             FC = IPER
C
             IF(ICIT.GE.JLO .AND. ICIT.LE.JHI) THEN
               CALL HSMLT1(YAO,YAC,RHSO,RHSC,CI,OINT,AMAT,IROT,
     *                     INDEX,FC,ICIT,ICI2,IND,IO1,JJ,JLO,
     *                     NSTATS,NCI,NDETLN,NROT,NINDX,L1,NCOR,
     *                     NNACT,NXYZ,WSTATE,SALAG)
             ENDIF
             IF(ICI2.GE.JLO .AND. ICI2.LE.JHI) THEN
               CALL HSMLT1(YAO,YAC,RHSO,RHSC,CI,OINT,AMAT,IROT,
     *                     INDEX,FC,ICI2,ICIT,IND,IO1,JJ,JLO,
     *                     NSTATS,NCI,NDETLN,NROT,NINDX,L1,NCOR,
     *                     NNACT,NXYZ,WSTATE,SALAG)
             ENDIF
  907     CONTINUE
C
             DO 687 IK=1,NBT
                IF (IK.EQ.IB) GOTO 687
                ION = IBCON1(IK)
                J1 = INDEX(ION,ION)
                J2 = INDEX(ION,JJ)
                J3 = INDEX(ION,IO1)
C
           DO 918 INA1 = ISAS(ISB1),ISAS(ISB1+1)-1
               ICIA = ISAC(INA1)
               ICIT = ISPA(ICIA) + ICAB
               ICI2 = ISPA(ICIA) + IPB1
               FC = IPER
C
               IF(ICIT.GE.JLO .AND. ICIT.LE.JHI) THEN
                 CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,FC,
     *                       ICIT,ICI2,IO1,JJ,ION,ION,IND,J1,
     *                       JLO,NCI,NDETLN,NROT,NSTATS,L1,NCOR,
     *                       NACT,NNACT,NXYZ,WSTATE,SALAG)
                 CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,-FC,
     *                       ICIT,ICI2,IO1,ION,ION,JJ,J3,J2,
     *                       JLO,NCI,NDETLN,NROT,NSTATS,L1,NCOR,
     *                       NACT,NNACT,NXYZ,WSTATE,SALAG)
               ENDIF
               IF(ICI2.GE.JLO .AND. ICI2.LE.JHI) THEN
                 CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,FC,
     *                       ICI2,ICIT,IO1,JJ,ION,ION,IND,J1,
     *                       JLO,NCI,NDETLN,NROT,NSTATS,L1,NCOR,
     *                       NACT,NNACT,NXYZ,WSTATE,SALAG)
                 CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,-FC,
     *                       ICI2,ICIT,IO1,ION,ION,JJ,J3,J2,
     *                       JLO,NCI,NDETLN,NROT,NSTATS,L1,NCOR,
     *                       NACT,NNACT,NXYZ,WSTATE,SALAG)
               ENDIF
  918      CONTINUE
C
  687        CONTINUE
C
            NST = 1
            DO 920 INA1 = ISAS(ISB1),ISAS(ISB1+1)-1
            NEND = ISAC(INA1)
            DO 8810 KK=NST,NEND-1
               CALL ADVNCP(IACON1,NAT,NACT)
 8810       CONTINUE
            ICIA = ISPA(NEND)
            ICIT = ICIA + ICAB
            ICI2 = ICIA  + IPB1
C
             DO 690 IK=1,NAT
                ION = IACON1(IK)
                J1 = INDEX(ION,ION)
                FC = IPER
C
                IF(ICIT.GE.JLO .AND. ICIT.LE.JHI) THEN
                  CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,FC,
     *                        ICIT,ICI2,IO1,JJ,ION,ION,IND,J1,
     *                        JLO,NCI,NDETLN,NROT,NSTATS,L1,NCOR,
     *                        NACT,NNACT,NXYZ,WSTATE,SALAG)
                ENDIF
                IF(ICI2.GE.JLO .AND. ICI2.LE.JHI) THEN
                  CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,FC,
     *                        ICI2,ICIT,IO1,JJ,ION,ION,IND,J1,
     *                        JLO,NCI,NDETLN,NROT,NSTATS,L1,NCOR,
     *                        NACT,NNACT,NXYZ,WSTATE,SALAG)
                ENDIF
  690        CONTINUE
Cdo           call ADVNCP(iacon1,nat,norb)
             NST = NEND
  920    CONTINUE
C
  517   CONTINUE
C
C  Now for beta doubles
C
       DO 6015 IBB = IB+1,NBT
               ISTBB = JJ+1
               IENBB = IEN
               JB = IBCON1(IBB)
               IS3 = IOX(JB)
               IPB = IBB
               IF (JJ.GT.JB) IPB = IPB - 1
               DO 6010 KKJBB = KKJ,NB+1
                  DO 6005 JJBB = ISTBB,IENBB
                    IS4 = IOX(JJBB)
                    IP2 = IMUL(IS4,IS3)
                    IF (IP1.NE.IP2) GOTO 6005
C
          CALL RET1CP(IACON2,IACON1,NB,IPB,JJBB,0,KKJBB,IPER2)
          IBP2 = POSCP(NACT,NB,IACON1,IFA)
          IBP2 = ISPB(IBP2)
          IPER = IPER1+IPER2
C         IPER = ((-1)**IPER)*2
          IPER = ((-1)**IPER)
               I2 = INDEX(JB,JJBB)
               II1 = INDEX(JJBB,IO1)
               II2 = INDEX(JB,JJ)
C
             DO 686 INA1 = ISAS(ISB1),ISAS(ISB1+1)-1
             NEND = ISAC(INA1)
             ICIA = ISPA(NEND)
             ICIT = ICIA + ICAB
             ICI2 = ICIA + IBP2
             FC = IPER
C
               IF(ICIT.GE.JLO .AND. ICIT.LE.JHI) THEN
                  CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,FC,
     *                        ICIT,ICI2,IO1,JJ,JB,JJBB,IND,I2,
     *                        JLO,NCI,NDETLN,NROT,NSTATS,L1,NCOR,
     *                        NACT,NNACT,NXYZ,WSTATE,SALAG)
                  CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,-FC,
     *                        ICIT,ICI2,IO1,JJBB,JB,JJ,II1,II2,
     *                        JLO,NCI,NDETLN,NROT,NSTATS,L1,NCOR,
     *                        NACT,NNACT,NXYZ,WSTATE,SALAG)
               ENDIF
               IF(ICI2.GE.JLO .AND. ICI2.LE.JHI) THEN
                  CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,FC,
     *                        ICI2,ICIT,IO1,JJ,JB,JJBB,IND,I2,
     *                        JLO,NCI,NDETLN,NROT,NSTATS,L1,NCOR,
     *                        NACT,NNACT,NXYZ,WSTATE,SALAG)
                  CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,-FC,
     *                        ICI2,ICIT,IO1,JJBB,JB,JJ,II1,II2,
     *                        JLO,NCI,NDETLN,NROT,NSTATS,L1,NCOR,
     *                        NACT,NNACT,NXYZ,WSTATE,SALAG)
               ENDIF
  686       CONTINUE
C
 6005          CONTINUE
               ISTBB = IBCON1(KKJBB)+1
               IENBB = IBCON1(KKJBB+1)-1
               IF (KKJBB.EQ.NB) IENBB=NACT
 6010      CONTINUE
 6015 CONTINUE
C
 6020       CONTINUE
            IST = IBCON1(KKJ)+1
            IEN=IBCON1(KKJ+1)-1
            IF (KKJ.EQ.NB) IEN=NACT
 6025     CONTINUE
 6030 CONTINUE
C
C    Remaining part of diagonal contributions
C
            DO 69 II=1,NBT
               I1 = IBCON1(II)
               IND1 = INDEX(I1,I1)
C
            DO 93 INA1 = ISAS(ISB1),ISAS(ISB1+1)-1
              NEND = ISAC(INA1)
              ICIA = ISPA(NEND)
              ICIT = ICIA + ICAB
              FC = ONE
C
              IF(ICIT.GE.JLO .AND. ICIT.LE.JHI) THEN
                CALL HSMLT1(YAO,YAC,RHSO,RHSC,CI,OINT,AMAT,IROT,
     *                      INDEX,FC,ICIT,ICIT,IND1,I1,I1,JLO,
     *                      NSTATS,NCI,NDETLN,NROT,NINDX,L1,NCOR,
     *                      NNACT,NXYZ,WSTATE,SALAG)
              ENDIF
   93       CONTINUE
C
               DO 74 JJ=II+1,NBT
                  I2 = IBCON1(JJ)
                  IND2 = INDEX(I2,I2)
                  INDM = IND2-I2+I1
                  J1 = INDEX(INDM,INDM)
                  J2 = INDEX(IND2,IND1)
C
            DO 97 INA1 = ISAS(ISB1),ISAS(ISB1+1)-1
               NEND = ISAC(INA1)
               ICIA = ISPA(NEND)
               ICIT = ICIA + ICAB
               FC = ONE
C
               IF(ICIT.GE.JLO .AND. ICIT.LE.JHI) THEN
                 CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,FC,
     *                       ICIT,ICIT,I1,I1,I2,I2,IND1,IND2,
     *                       JLO,NCI,NDETLN,NROT,NSTATS,L1,NCOR,
     *                       NACT,NNACT,NXYZ,WSTATE,SALAG)
                 CALL HSMLT2(YAO,YAC,RHSO,RHSC,CI,ERI,IROT,-FC,
     *                       ICIT,ICIT,I1,I2,I2,I1,INDM,INDM,
     *                       JLO,NCI,NDETLN,NROT,NSTATS,L1,NCOR,
     *                       NACT,NNACT,NXYZ,WSTATE,SALAG)
               ENDIF
   97       CONTINUE
C
   74          CONTINUE
C
   69       CONTINUE
           CALL ADVNCP(IBCON1,NBT,NACT)
 9999 CONTINUE
C
      RETURN
      END
C*MODULE CPMCHF  *DECK JCPDET
      SUBROUTINE JCPDET(WAXCI,PRCNDC,PRCNDS,CI,CIOLD,DFC,DERI,DHC,FCOR,
     *                  ERI,EG,OINT,WSTATE,IOX,IFA,IWRK,NDETMX,NDETLN,
     *                  NCI,NACT,NCOR,NA,NB,IDSYM,ISYM1,NSYM,IIS,IW,
     *                  NXYZ,L1,JLO,JHI,NSTATS,NNSTAT,NDER)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION WAXCI(NXYZ,NSTATS*NDETLN),PRCNDC(NDETLN,NSTATS),
     *          PRCNDS(*),CI(NDETMX,NSTATS),CIOLD(NCI,NSTATS),DFC(*),
     *          DERI(*),DHC(NXYZ),FCOR(*),ERI(*),EG(NXYZ,NNSTAT),
     *          OINT(*),WSTATE(*)
      DIMENSION IOX(NACT),IFA(0:NACT,0:NACT),IWRK(IIS)
C
      PARAMETER (MXRT=100)
C
      COMMON /ENRGYS/ ENUCR,EELCT,ETOT,SZ,SZZ,ECORE,ESCF,EERD,E1,E2,
     *                VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (HALF=0.5D+00, TOL=1.0D-09)
C
      NORB = NACT+NCOR
      N2 = (NACT*NACT+NACT)/2
      NINDX = N2
      IF(NORB.GT.NINDX) NINDX = NORB
      NALP = IFA(NACT,NA)
      NBLP = IFA(NACT,NB)
C
C     ----- Set starting point for various arrays -----
C
      ISYMA = 1
      ISYMB = ISYMA + NALP
      ICOA = ISYMB + NBLP
      ICOB = ICOA + NSYM
      ITAB = ICOB + NSYM
      IMUL = ITAB + NSYM
      ISPA = IMUL + NSYM*NSYM
      ISPB = ISPA + NALP
      ISAS = ISPB + NBLP
      ISBS = ISAS + NSYM+1
      ISAC = ISBS + NSYM+1
      ISBC = ISAC + NALP
C
      IACON1 = ISBC + NBLP
      IBCON1 = IACON1 + NA + 43
      IACON2 = IBCON1 + NA
      IBCON2 = IACON2 + NA
      IPOSA = IBCON2 + NB
      IPERA = IPOSA + (NA*(NACT-NA))
      IIND1 = IPERA + (NA*(NACT-NA))
      INDEX = IIND1 + (NA*(NACT-NA))
      IMMA = INDEX + NINDX*NINDX
      IMMC = IMMA + NSYM*(NA*(NACT-NA))
      ISTRB = IMMC + NSYM
      ISTRP = ISTRB + ((NB*(NACT-NB))*NBLP)/2
      ISTAR = ISTRP + ((NB*(NACT-NB))*NBLP)/2
      ITOT = ISTAR + NBLP - 1
C
      IF(ITOT.GT.IIS) THEN
        IF(MASWRK) THEN
          WRITE(IW,*) 'NOT ENOUGH MEMORY SPECIFIED FOR IWRK'
          WRITE(IW,*) 'ASKED FOR ',IIS,' NEED ',ITOT
        END IF
        CALL ABRT
      END IF
C
C     ----- Expand CI vector over all symmetry determinants -----
C     -----             and set symmetry to C1              -----
C
        CALL VCLR(CI,1,NSTATS*NDETMX)
        CALL DETCP(IW,IOX,NACT,NA,NB,IDSYM,ISYM1,NSYM,NALP,NBLP,
     *             IWRK(IACON1),IWRK(ISYMA),IWRK(ISYMB),IWRK(ICOA),
     *             IWRK(ICOB),IWRK(ITAB),IWRK(IMUL),IWRK(ISPA),
     *             IWRK(ISPB),IWRK(ISAS),IWRK(ISBS),IWRK(ISAC),
     *             IWRK(ISBC),NDER,NSTATS,CI,CIOLD)
C
      CALL SETUP(NACT,0,NA,NB,IWRK(IBCON1),
     *           IWRK(IACON2),IFA,IWRK(INDEX),IWRK(ISPB),NBLP,
     *           IWRK(ISTRB),IWRK(ISTRP),IWRK(ISTAR))
C
C     ----- Add one- and two-electron coupling constant terms -----
C     -----              to perturbed quantities              -----
C
      CALL VCLR(PRCNDC,1,NSTATS*NDETLN)
      CALL VCLR(PRCNDS,1,NNSTAT)
      CALL VCLR(WAXCI,1,NXYZ*NSTATS*NDETLN)
      CALL CPDRD2(WAXCI,PRCNDC,CI,DFC,DERI,FCOR,ERI,IWRK(INDEX),
     *            IWRK(IACON1),IWRK(IACON2),IWRK(IMMA),IWRK(IMMC),
     *            IWRK(ISPA),IWRK(ISPB),IWRK(ISYMA),IWRK(ISYMB),
     *            IWRK(ITAB),IOX,IWRK(IMUL),IWRK(IPOSA),IWRK(IPERA),
     *            IWRK(IIND1),IWRK(IBCON1),IWRK(ISAS),IWRK(ISBS),
     *            IWRK(ISAC),IWRK(ISBC),IWRK(ISTAR),IWRK(ISTRB),
     *            IWRK(ISTRP),IFA,NINDX,NDETLN,NACT,NCOR,NA,NB,NALP,
     *            NBLP,NSYM,NXYZ,L1,N2,JLO,JHI,NDETMX,NSTATS)
C
C     ----- Finish perturbed configuration gradient -----
C     -----            and preconditioner           -----
C
      DHCME = ENUCR
      DO I=1,NCOR
        II = (I*I+I)/2
        DHCME = DHCME + OINT(II) + FCOR(II)
      ENDDO
C
      IJSTAT = 0
      DO ISTAT=1,NSTATS
        EVAL = DHCME - ESTATE(ISTAT)
        DO 100 I=JLO,JHI
          CVAL = CI(I,ISTAT)
          IVAL = I - JLO + 1
          PRCNDC(IVAL,ISTAT) = PRCNDC(IVAL,ISTAT) + EVAL
          IF(ABS(CVAL).LT.TOL) GO TO 100
          PRCNDC(IVAL,ISTAT) = PRCNDC(IVAL,ISTAT) + HALF*CVAL*CVAL
          IVAL = IVAL + (ISTAT-1)*NDETLN
          CALL DAXPY(NXYZ,CVAL,DHC,1,WAXCI(1,IVAL),1)
  100   CONTINUE
C
        DO 120 JSTAT=1,ISTAT-1
          IJSTAT = IJSTAT + 1
          EVAL = ESTATE(JSTAT) - ESTATE(ISTAT)
          WVAL = WSTATE(ISTAT) - WSTATE(JSTAT)
          PRCNDS(IJSTAT) = EVAL*WVAL
  120   CONTINUE
      ENDDO
C
      CALL VCLR(EG,1,NNSTAT*NXYZ)
C
      DO 200 ISTAT=1,NSTATS
        DO 200 JSTAT=1,ISTAT
          IJ = (ISTAT*ISTAT-ISTAT)/2 + JSTAT
          DO 150 I=JLO,JHI
            CVAL = CI(I,JSTAT)
            IF(ABS(CVAL).LT.TOL) GO TO 150
            IVAL = (ISTAT-1)*NDETLN + I - JLO + 1
            CALL DAXPY(NXYZ,CVAL,WAXCI(1,IVAL),1,EG(1,IJ),1)
  150     CONTINUE
  200 CONTINUE
C
      IF(GOPARR) CALL DDI_GSUMF(2175,EG,NXYZ*NNSTAT)
C
      RETURN
      END
C*MODULE CPMCHF  *DECK JCPOVR
      SUBROUTINE JCPOVR(FCM,SDER,DFC,DERI,DLAG,DHC,DSAO,V,OINT,FCOR,ERI,
     *                  AMAT,DMMO,TPDM,PRCNDO,EPS,WRK,WRK2,IA,INDEX,
     *                  NCOR,NACT,NXYZ,L0,L1,L2,N2,N4,NROT,NDER,NFT18)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,SVDSKW
C
      INTEGER         C_OOOO, C_VOOO, C_VVOO, C_VOVO
C
      DIMENSION FCM(NXYZ,NXYZ),SDER(NXYZ,L1*L1),DFC(NXYZ,L2),
     *          DERI(NXYZ,N4),DLAG(NXYZ,L1,L1),DHC(NXYZ),DSAO(L1*L1),
     *          V(L1,L1),OINT(L2),ERI(L1,NACT,N2),FCOR(L2),
     *          AMAT(L1,NCOR,N2),DMMO(N2),TPDM(N4),PRCNDO(NROT),
     *          EPS(L1,L1),WRK(*),WRK2(*)
      DIMENSION IA(L2),INDEX(L1,L1)
C
      PARAMETER (MXGTOT=20000,MXSH=5000)
C
      COMMON /DLBTIM/ C_OOOO,C_VOOO,C_VVOO,C_VOVO
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (ZERO=0.0D+00,HALF=0.5D+00,ONE=1.0D+00,TWO=2.0D+00)
C
      L3 = L1*L1
      L0TRI = (L0*L0+L0)/2
      NOCC = NACT + NCOR
C
      DO 10 I=1,L2
   10   IA(I) = (I*I-I)/2
C
      CALL VCLR(FCOR,1,L2)
      CALL VCLR(ERI,1,L1*NACT*N2)
      CALL VCLR(AMAT,1,L1*NCOR*N2)
C
      CALL DAREAD(IDAF,IODA,DHC,NXYZ,259,0)
C
      IF(GOPARR) THEN
        CALL DAREAD(IDAF,IODA,OINT,L0TRI,355,0)
      ELSE
        DSKWRK = .TRUE.
        CALL SEQREW(IJKT)
        CALL SQREAD(IJKT,OINT,L0TRI)
      END IF
C
      IF(MASWRK) CALL DCOPY(L2,OINT,1,FCOR,1)
C
C     ----- Read in perturbed integrals from NFT18 -----
C
      SVDSKW = DSKWRK
      DSKWRK = .FALSE.
      CALL SEQREW(NFT18)
      DO IXYZ=1,NXYZ
        CALL SQREAD(NFT18,WRK,L2)
        CALL DCOPY(L2,WRK,1,DFC(IXYZ,1),NXYZ)
        CALL SQREAD(NFT18,WRK,N4)
        CALL DCOPY(N4,WRK,1,DERI(IXYZ,1),NXYZ)
        CALL SQREAD(NFT18,WRK,L3)
        CALL DCOPY(L3,WRK,1,DLAG(IXYZ,1,1),NXYZ)
      ENDDO
      DSKWRK=SVDSKW
C
C     ----- Transform derivative overlap integrals into MO basis -----
C
      CALL VCLR(SDER,1,L3*NXYZ)
      CALL DAREAD(IDAF,IODA,V,L3,15,0)
C
      DO 40 M=1,3
        IF(M.EQ.1) CALL DAREAD(IDAF,IODA,DSAO,L3,63,0)
        IF(M.EQ.2) CALL DAREAD(IDAF,IODA,DSAO,L3,64,0)
        IF(M.EQ.3) CALL DAREAD(IDAF,IODA,DSAO,L3,65,0)
        DO 30 ISHELL=1,NSHELL
          IAT  = KATOM(ISHELL)
          IXYZ = 3*(IAT-1)
          LOCI = KLOC(ISHELL) - KMIN(ISHELL)
          MINI = KMIN(ISHELL)
          MAXI = KMAX(ISHELL)
          DO 20 I=MINI,MAXI
            II = LOCI + I
            DO JJ=1,L1
              IJ = IA(MAX(II,JJ)) + MIN(II,JJ)
              IIJJ = (JJ-1)*L1 + II
              SDER(IXYZ+M,IJ) = SDER(IXYZ+M,IJ) + DSAO(IIJJ)
            ENDDO
   20     CONTINUE
   30   CONTINUE
   40 CONTINUE
C
      DO 70 IXYZ=1,NXYZ
        CALL DCOPY(L3,SDER(IXYZ,1),NXYZ,WRK,1)
        CALL TFTRI(DSAO,WRK,V,WRK2,L0,L1,L1)
        CALL VCLR(SDER(IXYZ,1),NXYZ,L3)
        DO 60 I=1,L0
          DO 60 J=1,I
            IIJJ = IA(I) + J
            DVAL = DSAO(IIJJ)
            IJ = (J-1)*L1 + I
            JI = (I-1)*L1 + J
            SDER(IXYZ,IJ) = DVAL
            SDER(IXYZ,JI) = DVAL
   60   CONTINUE
   70 CONTINUE
C
C     ----- Add derivative overlap contributions to force constant -----
C     -----                         matrix                         -----
C
      IF(NDER.EQ.2) THEN
        DO 100 JXYZ=1,NXYZ
          CALL DCOPY(L3,SDER(JXYZ,1),NXYZ,WRK,1)
          DO 90 J=1,NOCC
            DO 90 I=1,L1
              IJ = (J-1)*L1 + I
              DVAL = ZERO
              DO M=1,L1
                MI = (I-1)*L1 + M
                DVAL = DVAL + WRK(MI)*EPS(M,J)
              ENDDO
              WRK2(IJ) = DVAL
   90     CONTINUE
          CALL DAXPY(L1*NOCC,-ONE,DLAG(JXYZ,1,1),NXYZ,WRK2,1)
C
          DO IXYZ=1,NXYZ
            DVAL = DDOT(L1*NOCC,WRK2,1,SDER(IXYZ,1),NXYZ)
            FCM(IXYZ,JXYZ) = FCM(IXYZ,JXYZ) + DVAL
          ENDDO
  100   CONTINUE
      ENDIF
C
C     ----- Add derivative overlap (two-electron) contributions to -----
C     -----                      various terms                     -----
C
      IF(GOPARR) THEN
        CALL DDI_PROCDLB_RESET(C_OOOO)
        CALL DDI_PROCDLB_RESET(C_VOOO)
        CALL DDI_PROCDLB_RESET(C_VVOO)
        CALL DDI_PROCDLB_RESET(C_VOVO)
C
        CALL DSCAL(L2*NXYZ,ONE/NPROC,DFC,1)
        CALL DSCAL(N4*NXYZ,ONE/NPROC,DERI,1)
        CALL DSCAL(L3*NXYZ,ONE/NPROC,DLAG,1)
C
        CALL PCPSDR(WRK,SDER,DLAG,DFC,DERI,FCOR,ERI,AMAT,DMMO,TPDM,
     *              PRCNDO,IA,INDEX,NCOR,NACT,NXYZ,L0,L1,L2,N2,N4,NROT,
     *              IW)
      ENDIF
C
C     ----- Add derivative overlap (one-electron) contributions to -----
C     -----   the derivative core Fock and Hamiltonian matrices    -----
C
      DO 180 IXYZ=1,NXYZ
C
        DO 160 I=1,L1
          DO 160 J=1,I
            IJ = IA(I) + J
            DVAL = ZERO
            DO M=1,L1
              IG = MAX(I,M)
              MG = MIN(I,M)
              IM = IA(IG) + MG
C
              JG = MAX(J,M)
              MG = MIN(J,M)
              JM = IA(JG) + MG
C
              MI = (I-1)*L1 + M
              MJ = (J-1)*L1 + M
              DVAL = DVAL + SDER(IXYZ,MI)*FCOR(JM)
              DVAL = DVAL + SDER(IXYZ,MJ)*FCOR(IM)
            ENDDO
            DFC(IXYZ,IJ) = DFC(IXYZ,IJ) - HALF*DVAL
  160   CONTINUE
C
        DVAL = ZERO
        DO 170 I=1,NCOR
          II = IA(I) + I
          DVAL = DVAL + DFC(IXYZ,II)
          DO M=1,L1
            IG = MAX(I,M)
            MG = MIN(I,M)
            IM = IA(IG) + MG
            MI = (I-1)*L1 + M
            DVAL = DVAL - SDER(IXYZ,MI)*OINT(IM)
          ENDDO
  170   CONTINUE
C
        DHC(IXYZ) = DHC(IXYZ) + DVAL
  180 CONTINUE
C
C     ----- Add derivative overlap (one-electron) contributions to -----
C     -----               the derivative Lagrangian                -----
C
      DO 300 IXYZ=1,NXYZ
        DO 280 I=1,L1
C
          DO 200 J=1,NCOR
            DVAL = ZERO
            DO N=1,L1
              NG = MAX(N,I)
              IG = MIN(N,I)
              NI = IA(NG) + IG
              NJ = (J-1)*L1 + N
              DVAL = DVAL + SDER(IXYZ,NJ)*OINT(NI)
            ENDDO
            DLAG(IXYZ,I,J) = DLAG(IXYZ,I,J) - DVAL
  200     CONTINUE
C
          DO 240 J=1,NACT
            DVAL = ZERO
            DO 220 M=1,NACT
              MG = MAX(M,J)
              JG = MIN(M,J)
              MJ = IA(MG) + JG
              DMVAL = DMMO(MJ)
              DO 220 N=1,L1
                NG = MAX(N,I)
                IG = MIN(N,I)
                NI = IA(NG) + IG
                NM = (M+NCOR-1)*L1 + N
                DVAL = DVAL + SDER(IXYZ,NM)*DMVAL*OINT(NI)
  220       CONTINUE
            DLAG(IXYZ,I,J+NCOR) = DLAG(IXYZ,I,J+NCOR) - HALF*DVAL
  240     CONTINUE
C
          DO 260 J=1,NOCC
            DVAL = ZERO
            DO M=1,L1
              MI = (I-1)*L1 + M
              DVAL = DVAL + SDER(IXYZ,MI)*EPS(M,J)
            ENDDO
            DLAG(IXYZ,I,J) = DLAG(IXYZ,I,J) - HALF*DVAL
  260     CONTINUE
  280   CONTINUE
  300 CONTINUE
C
C     ----- Write total derivative Lagrangian to file -----
C
      CALL SEQREW(NFT18)
      DO IXYZ=1,NXYZ
        CALL DCOPY(L3,DLAG(IXYZ,1,1),NXYZ,WRK,1)
        CALL SQWRIT(NFT18,WRK,L3)
      ENDDO
C
C     ----- Store derivative core Fock matrices over active -----
C     -----                  orbitals only                  -----
C
      DO 1000 I=1,NACT
        IF(NCOR.EQ.0) GO TO 1000
        II = I + NCOR
        DO J=1,I
          JJ = J + NCOR
          IJ = IA(I) + J
          IIJJ = IA(II) + JJ
          CALL DCOPY(NXYZ,DFC(1,IIJJ),1,DFC(1,IJ),1)
        ENDDO
 1000 CONTINUE
C
C     ----- Add one-electron part to orbital preconditioner -----
C
      DO 1100 I=1,L1
        DMI = ZERO
        IF(I.LE.NCOR) DMI = TWO
        IF(I.GT.NCOR .AND. I.LE.NOCC) THEN
          II = IA(I-NCOR) + I-NCOR
          DMI = DMMO(II)
        ENDIF
C
        DO 1100 J=1,I
          IJ = IABS(INDEX(I,J))
          IF(IJ.EQ.0) GO TO 1100
C
          IF(J.LE.NCOR) DMJ = TWO
          IF(J.GT.NCOR) THEN
            JJ = IA(J-NCOR) + J-NCOR
            DMJ = DMMO(JJ)
          ENDIF
C
          II = IA(I) + I
          JJ = IA(J) + J
          DVAL = DMJ*OINT(II) - EPS(J,J)
          IF(I.LE.NOCC) DVAL = DVAL - EPS(I,I) + DMI*OINT(JJ)
          PRCNDO(IJ) = PRCNDO(IJ) + DVAL
 1100 CONTINUE
C
      RETURN
      END
C*MODULE CPMCHF  *DECK MATDD1
      SUBROUTINE MATDD1(DDEN,DCI,CI,M2,NXYZ,NACT,NA,NB,
     *                  NDETLN,NALP,NBLP,IFA,IOX,NSYM,
     *                  IACON1,IBCON1,IACON2,IPOSA,IPERA,IIND1,
     *                  INDEX,ISYMA,ISYMB,
     *                  ISPA,ISPB,ISAS,ISBS,ISAC,ISBC,JLO,JHI)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      INTEGER POSCP
      DIMENSION IOX(NACT)
      DIMENSION DDEN(NXYZ,M2), CI(*), DCI(NXYZ,NDETLN)
      DIMENSION IFA(0:NACT,0:NACT)
      DIMENSION IACON1(NA),IBCON1(NA)
      DIMENSION IACON2(NA),IPERA(NA*(NACT-NA))
      DIMENSION IIND1(NA*(NACT-NA))
      DIMENSION IPOSA(NA*(NACT-NA))
      DIMENSION INDEX(NACT,NACT)
      DIMENSION ISYMA(NALP),ISYMB(NBLP)
      DIMENSION ISPA(NALP),ISPB(NBLP)
      DIMENSION ISAS(NSYM+1),ISBS(NSYM+1),ISAC(NALP),ISBC(NBLP)
C
      PARAMETER (TWO=2.0D+00)
C
      DO 7 I=1,NACT
         DO 8 J=1,I
            INDEX(I,J) = I*(I-1)/2 + J
            INDEX(J,I) = INDEX(I,J)
    8    CONTINUE
    7 CONTINUE
C
      NAT = NA
      NBT = NB
C
      CALL VCLR(DDEN,1,M2*NXYZ)
C
      DO 30 I=1,NAT
         IACON1(I) = I
   30 CONTINUE
C
C   Big Loop over all alpha determinants
C
      DO 9000 IJK = 1,NALP
C
C  Alpha excitations here
C   Single first
C
         IAC = 0
         ICAT = ISPA(IJK)
         ISA1 = ISYMA(IJK)
C itas = itab(isa1)
         DO 7030 IA=1,NAT
             IO1 = IACON1(IA)
             IS1 = IOX(IO1)
             IST = IO1 + 1
             IEN = IACON1(IA+1)-1
             IF (IA.EQ.NAT) IEN=NACT
             DO 7025 KKJ=IA+1,NA+1
                DO 7020 JJ=IST,IEN
                IS2 = IOX(JJ)
C
             IAC = IAC + 1
             CALL RET1CP(IACON1,IACON2,NA,IA,JJ,0,KKJ,IPER1)
C
C   Storage here for later use, well worth it
C
             IPET = POSCP(NACT,NA,IACON2,IFA)
             IPOSA(IAC) = ISPA(IPET)
             IPERA(IAC) = ((-1)**IPER1)
             IND = INDEX(JJ,IO1)
             IIND1(IAC) = IND
C
         DO 49 I=1,NBT
            IBCON1(I) = I
   49    CONTINUE
C
C
                   DO 407 INBB = ISBS(ISA1),ISBS(ISA1+1)-1
                   INB1 = ISBC(INBB)
                   ICIT = ICAT+ISPB(INB1)
                   ICI2 = IPOSA(IAC) + ISPB(INB1)
C
                   IF(ICIT.GE.JLO .AND. ICIT.LE.JHI) THEN
                     FC = CI(ICI2)*IPERA(IAC)
                     IWIT = ICIT - JLO + 1
                     CALL DAXPY(NXYZ,FC,DCI(1,IWIT),1,DDEN(1,IND),1)
                   ENDIF
C
                   IF(ICI2.GE.JLO .AND. ICI2.LE.JHI) THEN
                     FC = CI(ICIT)*IPERA(IAC)
                     IWI2 = ICI2 - JLO + 1
                     CALL DAXPY(NXYZ,FC,DCI(1,IWI2),1,DDEN(1,IND),1)
                   ENDIF
  407          CONTINUE
C
 7020           CONTINUE
                IST = IACON1(KKJ)+1
                IEN = IACON1(KKJ+1)-1
                IF (KKJ.EQ.NA) IEN=NACT
 7025        CONTINUE
 7030     CONTINUE
C
C  Diagonal
C
            DO 67 II=1,NAT
               I1 = IACON1(II)
               IND1 = INDEX(I1,I1)
C
              DO 53 INB1 = ISBS(ISA1),ISBS(ISA1+1)-1
              NEND = ISBC(INB1)
              ICIT = ICAT+ISPB(NEND)
C
              IF(ICIT.GE.JLO .AND. ICIT.LE.JHI) THEN
                FC = TWO*CI(ICIT)
                IWIT = ICIT - JLO + 1
                CALL DAXPY(NXYZ,FC,DCI(1,IWIT),1,DDEN(1,IND1),1)
              ENDIF
   53         CONTINUE
C
   67       CONTINUE
C
C   Loop over Beta dets now
C
      CALL ADVNCP(IACON1,NAT,NACT)
 9000 CONTINUE
C
C   Now for the Beta part
C
C
      DO 876 JJI=1,NBT
         IBCON1(JJI) = JJI
  876 CONTINUE
C
      DO 9999 IJK = 1,NBLP
         ICAB = ISPB(IJK)
         ISB1 = ISYMB(IJK)
C itb1 = itab(isb1)
C
      DO 6030 IB=1,NBT
         IST = IBCON1(IB)+1
         IEN = IBCON1(IB+1)-1
         IF (IB.EQ.NBT) IEN=NACT
         IO1 = IBCON1(IB)
         IS1 = IOX(IO1)
         DO 6025 KKJ=IB+1,NB+1
            DO 6020 JJ=IST,IEN
            IS2 = IOX(JJ)
C
            CALL RET1CP(IBCON1,IACON2,NB,IB,JJ,0,KKJ,IPER1)
            IPER = ((-1)**IPER1)
            IND = INDEX(JJ,IO1)
Cc If deoccupied and newly occupied are of diff sym, then
C   skip to doubles
            IF (IS1.NE.IS2) GOTO 517
            IPB1 = POSCP(NACT,NB,IACON2,IFA)
            IPB1 = ISPB(IPB1)
C
       DO 89 I=1,NAT
          IACON1(I) = I
   89 CONTINUE
C
C  Loop over alpha
C
          DO 907 INA1 = ISAS(ISB1),ISAS(ISB1+1)-1
             ICIA = ISAC(INA1)
             ICIT = ISPA(ICIA) + ICAB
             ICI2 = ISPA(ICIA) + IPB1
C
             IF(ICIT.GE.JLO .AND. ICIT.LE.JHI) THEN
               FC = CI(ICI2)*IPER
               IWIT = ICIT - JLO + 1
               CALL DAXPY(NXYZ,FC,DCI(1,IWIT),1,DDEN(1,IND),1)
             ENDIF
C
             IF(ICI2.GE.JLO .AND. ICI2.LE.JHI) THEN
               FC = CI(ICIT)*IPER
               IWI2 = ICI2 - JLO + 1
               CALL DAXPY(NXYZ,FC,DCI(1,IWI2),1,DDEN(1,IND),1)
             ENDIF
  907     CONTINUE
C
  517 CONTINUE
 6020      CONTINUE
            IST = IBCON1(KKJ)+1
            IEN=IBCON1(KKJ+1)-1
            IF (KKJ.EQ.NB) IEN=NACT
 6025     CONTINUE
 6030 CONTINUE
C
C    Remaining part of diagonal contributions
C
            DO 69 II=1,NBT
               I1 = IBCON1(II)
               IND1 = INDEX(I1,I1)
            DO 93 INA1 = ISAS(ISB1),ISAS(ISB1+1)-1
              NEND = ISAC(INA1)
              ICIA = ISPA(NEND)
              ICIT = ICIA + ICAB
C
              IF(ICIT.GE.JLO .AND. ICIT.LE.JHI) THEN
                FC = TWO*CI(ICIT)
                IWIT = ICIT - JLO + 1
                CALL DAXPY(NXYZ,FC,DCI(1,IWIT),1,DDEN(1,IND1),1)
              ENDIF
   93       CONTINUE
C
   69       CONTINUE
           CALL ADVNCP(IBCON1,NBT,NACT)
C
 9999 CONTINUE
      RETURN
      END
C*MODULE CPMCHF  *DECK MATMC2
C     ----------------------------------------------------------
      SUBROUTINE MATMC2(NUM,NORB,NCOR,NA,NB,IFA,NSYM,IIS,NDETMX)
C     ----------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION IFA(0:NORB-NCOR,0:NORB-NCOR)
C
      NACT = NORB - NCOR
      NALP = IFA(NACT,NA)
      NBLP = IFA(NACT,NB)
      NDETMX = NALP*NBLP
      NLEN = (NACT**2+NACT)/2
      IF(NUM.GT.NLEN) NLEN = NUM
C
C     Similar to MATME2 in ALDECI
C
      IIS = 3*NA + NB + 5*(NA*(NACT-NA)) +
     *  NLEN**2 + 3*(NALP+NBLP) + 4*NSYM +
     *   2*(NSYM+1) + NSYM*NSYM + NSYM*(NA*(NACT-NA)) +
     *  ((NB*(NORB-NCOR-NB))*NBLP) + NBLP + 43
C
      RETURN
      END
C*MODULE CPMCHF  *DECK MATTD1
      SUBROUTINE MATTD1(TDEN,CI,NSTATS,NACT,NA,NB,
     *                  NDETMX,NALP,NBLP,IFA,IOX,NSYM,
     *                  IACON1,IBCON1,IACON2,IPOSA,IPERA,IIND1,
     *                  INDEX,ISYMA,ISYMB,
     *                  ISPA,ISPB,ISAS,ISBS,ISAC,ISBC)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      INTEGER POSCP
      DIMENSION IOX(NACT)
      DIMENSION TDEN(NACT,NACT,NSTATS*NSTATS), CI(NDETMX,NSTATS)
      DIMENSION IFA(0:NACT,0:NACT)
      DIMENSION IACON1(NA),IBCON1(NA)
      DIMENSION IACON2(NA),IPERA(NA*(NACT-NA))
      DIMENSION IIND1(NA*(NACT-NA))
      DIMENSION IPOSA(NA*(NACT-NA))
      DIMENSION INDEX(NACT,NACT)
      DIMENSION ISYMA(NALP),ISYMB(NBLP)
      DIMENSION ISPA(NALP),ISPB(NBLP)
      DIMENSION ISAS(NSYM+1),ISBS(NSYM+1),ISAC(NALP),ISBC(NBLP)
C
      DO 7 I=1,NACT
         DO 8 J=1,I
            INDEX(I,J) = I*(I-1)/2 + J
            INDEX(J,I) = INDEX(I,J)
    8    CONTINUE
    7 CONTINUE
C
      NAT = NA
      NBT = NB
C
      CALL VCLR(TDEN,1,NACT*NACT*NSTATS*NSTATS)
C
      DO 30 I=1,NAT
         IACON1(I) = I
   30 CONTINUE
C
C   Big Loop over all alpha determinants
C
      DO 9000 IJK = 1,NALP
C
C  Alpha excitations here
C   Single first
C
         IAC = 0
         ICAT = ISPA(IJK)
         ISA1 = ISYMA(IJK)
C itas = itab(isa1)
         DO 7030 IA=1,NAT
             IO1 = IACON1(IA)
             IS1 = IOX(IO1)
             IST = IO1 + 1
             IEN = IACON1(IA+1)-1
             IF (IA.EQ.NAT) IEN=NACT
             DO 7025 KKJ=IA+1,NA+1
                DO 7020 JJ=IST,IEN
                IS2 = IOX(JJ)
C
             IAC = IAC + 1
             CALL RET1CP(IACON1,IACON2,NA,IA,JJ,0,KKJ,IPER1)
C
C   Storage here for later use, well worth it
C
             IPET = POSCP(NACT,NA,IACON2,IFA)
             IPOSA(IAC) = ISPA(IPET)
             IPERA(IAC) = ((-1)**IPER1)
             IND = INDEX(JJ,IO1)
             IIND1(IAC) = IND
             IF (IS1.NE.IS2) GOTO 417
C
         DO 49 I=1,NBT
            IBCON1(I) = I
   49    CONTINUE
C
C
                   DO 407 INBB = ISBS(ISA1),ISBS(ISA1+1)-1
                   INB1 = ISBC(INBB)
                   ICIT = ICAT+ISPB(INB1)
                   ICI2 = IPOSA(IAC) + ISPB(INB1)
C
                   FC = IPERA(IAC)
                   DO 406 ISTAT=1,NSTATS
                     DO 406 JSTAT=1,NSTATS
                       IJSTAT = (ISTAT-1)*NSTATS + JSTAT
                       FCJI = FC*CI(ICIT,JSTAT)*CI(ICI2,ISTAT)
                       TDEN(JJ,IO1,IJSTAT) = TDEN(JJ,IO1,IJSTAT) + FCJI
                       FCJI = FC*CI(ICI2,JSTAT)*CI(ICIT,ISTAT)
                       TDEN(IO1,JJ,IJSTAT) = TDEN(IO1,JJ,IJSTAT) + FCJI
  406              CONTINUE
  407          CONTINUE
C
C
  417     CONTINUE
C
 7020           CONTINUE
                IST = IACON1(KKJ)+1
                IEN = IACON1(KKJ+1)-1
                IF (KKJ.EQ.NA) IEN=NACT
 7025        CONTINUE
 7030     CONTINUE
C
C  Diagonal
C
            DO 67 II=1,NAT
               I1 = IACON1(II)
C
              DO 53 INB1 = ISBS(ISA1),ISBS(ISA1+1)-1
              NEND = ISBC(INB1)
              ICIT = ICAT+ISPB(NEND)
C
               DO 52 ISTAT=1,NSTATS
                 DO 52 JSTAT=1,NSTATS
                   IJSTAT = (ISTAT-1)*NSTATS + JSTAT
                   FCJI = CI(ICIT,JSTAT)*CI(ICIT,ISTAT)
                   TDEN(I1,I1,IJSTAT) = TDEN(I1,I1,IJSTAT) + FCJI
   52          CONTINUE
   53         CONTINUE
C
   67       CONTINUE
C
C   Loop over Beta dets now
C
      CALL ADVNCP(IACON1,NAT,NACT)
 9000 CONTINUE
C
C   Now for the Beta part
C
C
      DO 876 JJI=1,NBT
         IBCON1(JJI) = JJI
  876 CONTINUE
C
      DO 9999 IJK = 1,NBLP
         ICAB = ISPB(IJK)
         ISB1 = ISYMB(IJK)
C itb1 = itab(isb1)
C
      DO 6030 IB=1,NBT
         IST = IBCON1(IB)+1
         IEN = IBCON1(IB+1)-1
         IF (IB.EQ.NBT) IEN=NACT
         IO1 = IBCON1(IB)
         IS1 = IOX(IO1)
         DO 6025 KKJ=IB+1,NB+1
            DO 6020 JJ=IST,IEN
            IS2 = IOX(JJ)
C
            CALL RET1CP(IBCON1,IACON2,NB,IB,JJ,0,KKJ,IPER1)
            IPER = ((-1)**IPER1)
            IND = INDEX(JJ,IO1)
Cc If deoccupied and newly occupied are of diff sym, then
C   skip to doubles
            IF (IS1.NE.IS2) GOTO 517
            IPB1 = POSCP(NACT,NB,IACON2,IFA)
            IPB1 = ISPB(IPB1)
C
       DO 89 I=1,NAT
          IACON1(I) = I
   89 CONTINUE
C
C  Loop over alpha
C
          DO 907 INA1 = ISAS(ISB1),ISAS(ISB1+1)-1
             ICIA = ISAC(INA1)
             ICIT = ISPA(ICIA) + ICAB
             ICI2 = ISPA(ICIA) + IPB1
C
             FC = IPER
             DO 906 ISTAT=1,NSTATS
               DO 906 JSTAT=1,NSTATS
                 IJSTAT = (ISTAT-1)*NSTATS + JSTAT
                 FCJI = FC*CI(ICIT,JSTAT)*CI(ICI2,ISTAT)
                 TDEN(JJ,IO1,IJSTAT) = TDEN(JJ,IO1,IJSTAT) + FCJI
                 FCJI = FC*CI(ICI2,JSTAT)*CI(ICIT,ISTAT)
                 TDEN(IO1,JJ,IJSTAT) = TDEN(IO1,JJ,IJSTAT) + FCJI
  906        CONTINUE
  907     CONTINUE
C
  517 CONTINUE
 6020      CONTINUE
            IST = IBCON1(KKJ)+1
            IEN=IBCON1(KKJ+1)-1
            IF (KKJ.EQ.NB) IEN=NACT
 6025     CONTINUE
 6030 CONTINUE
C
C    Remaining part of diagonal contributions
C
            DO 69 II=1,NBT
               I1 = IBCON1(II)
            DO 93 INA1 = ISAS(ISB1),ISAS(ISB1+1)-1
              NEND = ISAC(INA1)
              ICIA = ISPA(NEND)
              ICIT = ICIA + ICAB
C
              DO 92 ISTAT=1,NSTATS
                DO 92 JSTAT=1,NSTATS
                  IJSTAT = (ISTAT-1)*NSTATS + JSTAT
                  FCJI = CI(ICIT,JSTAT)*CI(ICIT,ISTAT)
                  TDEN(I1,I1,IJSTAT) = TDEN(I1,I1,IJSTAT) + FCJI
   92         CONTINUE
   93       CONTINUE
C
   69       CONTINUE
           CALL ADVNCP(IBCON1,NBT,NACT)
C
 9999 CONTINUE
      RETURN
      END
C*MODULE CPMCHF  *DECK MCCPCG
      SUBROUTINE MCCPCG(YAO,YAC,YAS,PRCNDO,PRCNDC,PRCNDS,RESIDO,RESIDC,
     *                  RESIDS,ZRESO,ZRESC,ZRESS,PDIRO,PDIRC,PDIRS,
     *                  BNORM,BKNUM,BKDEN,OINT,FCOR,AMAT,ERI,EPS,OPDM,
     *                  TPDM,CI,WRK,INDEX,IA,IWRK,IFA,IOX,NOCP,
     *                  NXYZ,NUNIQ,NROT,NDETLN,NDETMX,IIS,JLO,JHI,NA,NB,
     *                  NSYM,NCOR,NACT,L0,L1,L2,NFT18,NFT19,NSTATS,
     *                  WSTATE,EGRAD,SALAG)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INTEGER         C_OOOO, C_VOOO, C_VVOO, C_VOVO
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION YAO(NUNIQ,NROT),YAC(NUNIQ,NSTATS*NDETLN),YAS(NUNIQ,*),
     *          PRCNDO(NROT),PRCNDC(NSTATS*NDETLN),PRCNDS(*),
     *          RESIDO(NUNIQ,NROT),RESIDC(NUNIQ,NSTATS*NDETLN),
     *          RESIDS(NUNIQ,*),ZRESO(NUNIQ,NROT),
     *          ZRESC(NUNIQ,NSTATS*NDETLN),ZRESS(NUNIQ,*),
     *          PDIRO(NUNIQ,NROT),PDIRC(NUNIQ,NSTATS*NDETMX),
     *          PDIRS(NUNIQ,*),BNORM(NUNIQ),BKNUM(NUNIQ),BKDEN(NUNIQ),
     *          OINT(L2),FCOR(L2),AMAT(*),ERI(*),EPS(L1,L1),OPDM(*),
     *          TPDM(*),CI(NDETMX,NSTATS),WRK(*),
     *          WSTATE(*),EGRAD(*),SALAG(L1,L1,NSTATS*NSTATS)
      DIMENSION INDEX(L1,L1),IA(*),IWRK(IIS),IFA(0:NACT,0:NACT),
     *          IOX(NACT),NOCP(NXYZ)
C
      COMMON /DLBTIM/ C_OOOO,C_VOOO,C_VVOO,C_VOVO
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (ZERO=0.0D+00,ONE=1.0D+00,TWO=2.0D+00)
      PARAMETER (THREE=3.0D+00,TOL=1.0D-06)
C
      DATA MAXIT/200/
C
      NOCC = NCOR+NACT
      NNSTAT = (NSTATS*NSTATS+NSTATS)/2
      TOLTMP = TOL
      CALL DSCAL(NROT,TWO,PRCNDO,1)
      CALL DSCAL(NSTATS*NDETLN,TWO,PRCNDC,1)
      CALL DSCAL(NNSTAT,TWO,PRCNDS,1)
C
C     ----- Construct rhs and place in array temporarily -----
C
      CALL FMRHS(ZRESO,ZRESC,ZRESS,CI,EGRAD,WSTATE,WRK,INDEX,NOCP,NXYZ,
     *           NUNIQ,NROT,NDETLN,NOCC,L1,NFT18,NFT19,NSTATS,JLO,JHI,
     *           NDETMX,NNSTAT)
C
      DO IXYZ=1,NUNIQ
        BNORM(IXYZ) = DDOT(NSTATS*NDETLN,ZRESC(IXYZ,1),NUNIQ,
     *                     ZRESC(IXYZ,1),NUNIQ)
      ENDDO
      IF(GOPARR) CALL DDI_GSUMF(2169,BNORM,NUNIQ)
C
      DO IXYZ=1,NUNIQ
        BVAL = DDOT(NROT,ZRESO(IXYZ,1),NUNIQ,ZRESO(IXYZ,1),NUNIQ)
        BNORM(IXYZ) = BNORM(IXYZ) + BVAL
        BVAL = DDOT(NNSTAT,ZRESS(IXYZ,1),NUNIQ,ZRESS(IXYZ,1),NUNIQ)
        BVAL = BVAL + BNORM(IXYZ)
        BNORM(IXYZ) = SQRT(BVAL)
CTJD        IF(MASWRK) WRITE(IW,9720) IXYZ,BNORM(IXYZ)
      ENDDO
C
C     ----- Construct initial guess for solution -----
C
      CALL DCOPY(NUNIQ*NROT,ZRESO,1,YAO,1)
      CALL DCOPY(NUNIQ*NDETLN*NSTATS,ZRESC,1,YAC,1)
      CALL DCOPY(NUNIQ*NNSTAT,ZRESS,1,YAS,1)
C
      DO I=1,NROT
        FACTOR = -ONE/PRCNDO(I)
        CALL DSCAL(NUNIQ,FACTOR,YAO(1,I),1)
      ENDDO
C
      DO 20 ISTAT=1,NSTATS
        IVAL = (ISTAT-1)*NDETLN
        DO I=JLO,JHI
          IVAL = IVAL + 1
          FACTOR = -ONE/PRCNDC(IVAL)
          CALL DSCAL(NUNIQ,FACTOR,YAC(1,IVAL),1)
        ENDDO
   20 CONTINUE
C
      CALL DCOPY(NUNIQ*NROT,YAO,1,PDIRO,1)
      CALL DCOPY(NUNIQ*NNSTAT,YAS,1,PDIRS,1)
      IF(GOPARR) CALL VCLR(PDIRC,1,NUNIQ*NDETMX*NSTATS)
      DO ISTAT=1,NSTATS
        IYVAL = (ISTAT-1)*NDETLN + 1
        IPVAL = (ISTAT-1)*NDETMX + JLO
        CALL DCOPY(NUNIQ*(JHI-JLO+1),YAC(1,IYVAL),1,PDIRC(1,IPVAL),1)
      ENDDO
      IF(GOPARR) CALL DDI_GSUMF(2170,PDIRC,NUNIQ*NDETMX*NSTATS)
C
C     ----- Perform matrix multiplication for first interation -----
C     -----                of CPMCHF equations                 -----
C
      ITER = 1
      CALL TSECND(TIM)
      TIM1 = TIM
      IF(GOPARR) THEN
        CALL DDI_PROCDLB_RESET(C_OOOO)
        CALL DDI_PROCDLB_RESET(C_VOOO)
        CALL DDI_PROCDLB_RESET(C_VVOO)
        CALL DDI_PROCDLB_RESET(C_VOVO)
        CALL HSMLTP(RESIDO,PDIRO,OINT,EPS,OPDM,TPDM,WRK,INDEX,IA,NROT,
     *              NUNIQ,NCOR,NACT,L0,L1,L2)
C
      ENDIF
      CALL TSECND(TIM)
      TIM2 = TIM
      TIMORB = TIM2 - TIM1
C
      CALL HSMLTC(RESIDC,RESIDO,RESIDS,PDIRO,PDIRC,PDIRS,PRCNDS,SALAG,
     *            CI,OINT,FCOR,AMAT,ERI,INDEX,IWRK,IFA,IOX,NCOR,NACT,NA,
     *            NB,L1,L2,NSYM,IIS,NDETMX,NDETLN,NROT,NUNIQ,JLO,JHI,
     *            NSTATS,WSTATE)
      CALL TSECND(TIM)
      TIMCI = TIM - TIM2
C
C     ----- Calculate residual for first iteration -----
C
      IF(GOPARR) CALL DDI_GSUMF(2180,RESIDO,NROT*NUNIQ)
      CALL DSCAL(NROT*NUNIQ,-TWO,RESIDO,1)
      CALL DAXPY(NROT*NUNIQ,-ONE,ZRESO,1,RESIDO,1)
C
      CALL DSCAL(NSTATS*NDETLN*NUNIQ,-TWO,RESIDC,1)
      CALL DAXPY(NSTATS*NDETLN*NUNIQ,-ONE,ZRESC,1,RESIDC,1)
C
      CALL DSCAL(NNSTAT*NUNIQ,-TWO,RESIDS,1)
      CALL DAXPY(NNSTAT*NUNIQ,-ONE,ZRESS,1,RESIDS,1)
C
C     ----- Calculate initial psuedoresidual -----
C
      DO 200 IXYZ=1,NUNIQ
        DO IROT=1,NROT
          ZRESO(IXYZ,IROT) = RESIDO(IXYZ,IROT)/PRCNDO(IROT)
        ENDDO
        DO 100 ISTAT=1,NSTATS
          IVAL = (ISTAT-1)*NDETLN
          DO IDET=JLO,JHI
            IVAL = IVAL + 1
            ZRESC(IXYZ,IVAL) = RESIDC(IXYZ,IVAL)/PRCNDC(IVAL)
          ENDDO
  100   CONTINUE
        DO I=1,NNSTAT
          ZRESS(IXYZ,I) = RESIDS(IXYZ,I)
        ENDDO
  200 CONTINUE
C
C     ----- Check convergence -----
C
      IUNIQ = 0
      ERR = ZERO
      DO 220 IXYZ=1,NXYZ
        IF(NOCP(IXYZ).NE.1) IUNIQ=IUNIQ+1
        IF(NOCP(IXYZ).NE.0) GO TO 220
C
        RNORM = DDOT(NSTATS*NDETLN,RESIDC(IUNIQ,1),NUNIQ,
     *               RESIDC(IUNIQ,1),NUNIQ)
        IF(GOPARR) CALL DDI_GSUMF(2181,RNORM,1)
        RNORM = RNORM +
     *          DDOT(NROT,RESIDO(IUNIQ,1),NUNIQ,RESIDO(IUNIQ,1),NUNIQ)
        RNORM = RNORM +
     *          DDOT(NNSTAT,RESIDS(IUNIQ,1),NUNIQ,RESIDS(IUNIQ,1),NUNIQ)
        TEST = SQRT(RNORM)
        IF(BNORM(IUNIQ).GT.TOL) TEST = TEST/BNORM(IUNIQ)
        IF(TEST.LT.TOL) NOCP(IXYZ) = 2
        ERR = MAX(ERR,TEST)
  220 CONTINUE
C
      IF(MASWRK) THEN
         WRITE(IW,9000) TOL
         WRITE(IW,9030)
         WRITE(IW,9020) ITER,ERR,NUNIQ,TIMORB,TIMCI
         CALL FLSHBF(IW)
      ENDIF
      IF(ERR.LT.TOL) GO TO 800
C
C     ----- The remaining CG interations start now... -----
C
      DO 400 ITER=2,MAXIT
C
C          ----- Calculate coef. BK and direction vector PDIR -----
C
        DO IUNIQ=1,NUNIQ
          BKNUM(IUNIQ) = DDOT(NSTATS*NDETLN,ZRESC(IUNIQ,1),NUNIQ,
     *                        RESIDC(IUNIQ,1),NUNIQ)
        ENDDO
        IF(GOPARR) THEN
          CALL DDI_GSUMF(2182,BKNUM,NUNIQ)
          IF(ITER.EQ.2) THEN
            CALL VCLR(PDIRC,1,NUNIQ*NDETMX*NSTATS)
          ELSE
            CALL DSCAL(NUNIQ*NDETMX*NSTATS,ONE/NPROC,PDIRC,1)
          ENDIF
        ENDIF
C
        IUNIQ = 0
        DO 320 IXYZ=1,NXYZ
          IF(NOCP(IXYZ).NE.1) IUNIQ = IUNIQ + 1
          IF(NOCP(IXYZ).NE.0) GO TO 320
          BVAL = DDOT(NROT,ZRESO(IUNIQ,1),NUNIQ,RESIDO(IUNIQ,1),NUNIQ)
          BVAL = BVAL +
     *           DDOT(NNSTAT,ZRESS(IUNIQ,1),NUNIQ,RESIDS(IUNIQ,1),NUNIQ)
          BKNUM(IUNIQ) = BKNUM(IUNIQ) + BVAL
C
CTJD          IF(BKNUM(IUNIQ).LE.-TOL) THEN
CTJD            IF(MASWRK) WRITE(IW,9040)
CTJD            CALL ABRT
CTJD          ENDIF
CTJD 9040 FORMAT(1X,'***** WARNING! *****',
CTJD     *       ' THE PRECONDITIONER IS NOT POSITIVE DEFINITE.')
C
          IF(ITER.EQ.2) THEN
            CALL DCOPY(NROT,ZRESO(IUNIQ,1),NUNIQ,PDIRO(IUNIQ,1),NUNIQ)
            CALL DCOPY(NNSTAT,ZRESS(IUNIQ,1),NUNIQ,PDIRS(IUNIQ,1),NUNIQ)
            DO ISTAT=1,NSTATS
              IZVAL = (ISTAT-1)*NDETLN + 1
              IPVAL = (ISTAT-1)*NDETMX + JLO
              CALL DCOPY((JHI-JLO+1),ZRESC(IUNIQ,IZVAL),NUNIQ,
     *                   PDIRC(IUNIQ,IPVAL),NUNIQ)
            ENDDO
          ELSE
            BK = BKNUM(IUNIQ)/BKDEN(IUNIQ)
            CALL DSCAL(NROT,BK,PDIRO(IUNIQ,1),NUNIQ)
            CALL DAXPY(NROT,ONE,ZRESO(IUNIQ,1),NUNIQ,PDIRO(IUNIQ,1),
     *                 NUNIQ)
            CALL DSCAL(NNSTAT,BK,PDIRS(IUNIQ,1),NUNIQ)
            CALL DAXPY(NNSTAT,ONE,ZRESS(IUNIQ,1),NUNIQ,PDIRS(IUNIQ,1),
     *                 NUNIQ)
            CALL DSCAL(NSTATS*NDETMX,BK,PDIRC(IUNIQ,1),NUNIQ)
            DO ISTAT=1,NSTATS
              IZVAL = (ISTAT-1)*NDETLN + 1
              IPVAL = (ISTAT-1)*NDETMX + JLO
              CALL DAXPY((JHI-JLO+1),ONE,ZRESC(IUNIQ,IZVAL),NUNIQ,
     *                   PDIRC(IUNIQ,IPVAL),NUNIQ)
            ENDDO
          ENDIF
          BKDEN(IUNIQ) = BKNUM(IUNIQ)
  320   CONTINUE
        IF(GOPARR) CALL DDI_GSUMF(2172,PDIRC,NUNIQ*NDETMX*NSTATS)
C
C     ----- Calculate coefficient AK, new iterate YA, new -----
C     ----- residual RESID, and new pseudo-residual ZRES  -----
C
        CALL TSECND(TIM)
        TIM1 = TIM
C
        IF(GOPARR) THEN
          CALL DDI_PROCDLB_RESET(C_OOOO)
          CALL DDI_PROCDLB_RESET(C_VOOO)
          CALL DDI_PROCDLB_RESET(C_VVOO)
          CALL DDI_PROCDLB_RESET(C_VOVO)
          CALL HSMLTP(ZRESO,PDIRO,OINT,EPS,OPDM,TPDM,WRK,INDEX,IA,NROT,
     *                NUNIQ,NCOR,NACT,L0,L1,L2)
        ENDIF
C
        CALL TSECND(TIM)
        TIM2 = TIM
        TIMORB = TIM2 - TIM1
C
        CALL HSMLTC(ZRESC,ZRESO,ZRESS,PDIRO,PDIRC,PDIRS,PRCNDS,SALAG,
     *              CI,OINT,FCOR,AMAT,ERI,INDEX,IWRK,IFA,IOX,NCOR,NACT,
     *              NA,NB,L1,L2,NSYM,IIS,NDETMX,NDETLN,NROT,NUNIQ,JLO,
     *              JHI,NSTATS,WSTATE)
        CALL TSECND(TIM)
        TIMCI = TIM - TIM2
C
        IF(GOPARR) CALL DDI_GSUMF(2183,ZRESO,NROT*NUNIQ)
        CALL DSCAL(NROT*NUNIQ,TWO,ZRESO,1)
        CALL DSCAL(NNSTAT*NUNIQ,TWO,ZRESS,1)
        CALL DSCAL(NSTATS*NDETLN*NUNIQ,TWO,ZRESC,1)
        NXYZF = 0
        DO IXYZ = 1,NXYZ
          IF (NOCP(IXYZ).EQ.0) NXYZF = NXYZF+1
        END DO
C
        ERR = ZERO
        IUNIQ = 0
        DO 350 IXYZ=1,NXYZ
          IF(NOCP(IXYZ).NE.1) IUNIQ = IUNIQ + 1
          IF(NOCP(IXYZ).NE.0) GO TO 350
C
          AKDEN = ZERO
          DO ISTAT=1,NSTATS
            IZVAL = (ISTAT-1)*NDETLN + 1
            IPVAL = (ISTAT-1)*NDETMX + JLO
            AKDEN = AKDEN + DDOT((JHI-JLO+1),PDIRC(IUNIQ,IPVAL),
     *                           NUNIQ,ZRESC(IUNIQ,IZVAL),NUNIQ)
          ENDDO
          IF(GOPARR) CALL DDI_GSUMF(2184,AKDEN,1)
          AKDEN = AKDEN + DDOT(NROT,PDIRO(IUNIQ,1),NUNIQ,ZRESO(IUNIQ,1),
     *                         NUNIQ)
          AKDEN = AKDEN + DDOT(NNSTAT,PDIRS(IUNIQ,1),NUNIQ,
     *                         ZRESS(IUNIQ,1),NUNIQ)
          AK = BKNUM(IUNIQ)/AKDEN
C
          CALL DAXPY(NROT,AK,PDIRO(IUNIQ,1),NUNIQ,YAO(IUNIQ,1),NUNIQ)
          CALL DAXPY(NROT,-AK,ZRESO(IUNIQ,1),NUNIQ,RESIDO(IUNIQ,1),
     *               NUNIQ)
          CALL DAXPY(NNSTAT,AK,PDIRS(IUNIQ,1),NUNIQ,YAS(IUNIQ,1),NUNIQ)
          CALL DAXPY(NNSTAT,-AK,ZRESS(IUNIQ,1),NUNIQ,RESIDS(IUNIQ,1),
     *               NUNIQ)
          DO ISTAT=1,NSTATS
            IPVAL = (ISTAT-1)*NDETMX + JLO
            IYVAL = (ISTAT-1)*NDETLN + 1
            CALL DAXPY((JHI-JLO+1),AK,PDIRC(IUNIQ,IPVAL),NUNIQ,
     *                 YAC(IUNIQ,IYVAL),NUNIQ)
          ENDDO
          CALL DAXPY(NSTATS*NDETLN,-AK,ZRESC(IUNIQ,1),NUNIQ,
     *               RESIDC(IUNIQ,1),NUNIQ)
C
          DO IROT=1,NROT
            ZRESO(IUNIQ,IROT) = RESIDO(IUNIQ,IROT)/PRCNDO(IROT)
          ENDDO
          DO 340 ISTAT=1,NSTATS
            IVAL = (ISTAT-1)*NDETLN
            DO IDET=JLO,JHI
              IVAL = IVAL + 1
              ZRESC(IUNIQ,IVAL) = RESIDC(IUNIQ,IVAL)/PRCNDC(IVAL)
            ENDDO
  340     CONTINUE
          DO I=1,NNSTAT
            ZRESS(IUNIQ,I) = RESIDS(IUNIQ,I)
          ENDDO
C
C          ----- Check convergence -----
C
          RNORM = DDOT(NSTATS*NDETLN,RESIDC(IUNIQ,1),NUNIQ,
     *                 RESIDC(IUNIQ,1),NUNIQ)
          IF(GOPARR) CALL DDI_GSUMF(2185,RNORM,1)
          RNORM = RNORM +
     *            DDOT(NROT,RESIDO(IUNIQ,1),NUNIQ,RESIDO(IUNIQ,1),NUNIQ)
          RNORM = RNORM + DDOT(NNSTAT,RESIDS(IUNIQ,1),NUNIQ,
     *                         RESIDS(IUNIQ,1),NUNIQ)
          TEST = SQRT(RNORM)
          IF(BNORM(IUNIQ).GT.TOL) TEST = TEST/BNORM(IUNIQ)
          IF(TEST.LT.TOLTMP) NOCP(IXYZ) = 2
          ERR = MAX(ERR,TEST)
  350   CONTINUE
        IF(MASWRK) THEN
           WRITE(IW,9020) ITER,ERR,NXYZF,TIMORB,TIMCI
           CALL FLSHBF(IW)
        END IF
        IF(ERR.LT.TOLTMP) GO TO 800
        IF(MOD(ITER,50).EQ.0) THEN
          TOLTMP = THREE*TOLTMP
          IF(MASWRK) WRITE(IW,9075) TOLTMP
        ENDIF
        IF(ITER.EQ.MAXIT) THEN
CTJD          IF(ERR.LT.TOLTMP) THEN
            GO TO 800
CTJD          END IF
CTJD          GO TO 400
        END IF
  400 CONTINUE
C
C     ----- Calculation did not converge after too many cycles -----
C
      IF(MASWRK) WRITE(IW,9070) MAXIT
      CALL ABRT
      STOP
C
C     ----- Determine whether solution vectors are correct -----
C
C
  800 CALL DCOPY(NUNIQ*NROT,YAO,1,PDIRO,1)
      CALL DCOPY(NUNIQ*NNSTAT,YAS,1,PDIRS,1)
      IF(GOPARR) CALL VCLR(PDIRC,1,NUNIQ*NDETMX*NSTATS)
      DO ISTAT=1,NSTATS
        IPVAL = (ISTAT-1)*NDETMX + JLO
        IYVAL = (ISTAT-1)*NDETLN + 1
        CALL DCOPY(NUNIQ*(JHI-JLO+1),YAC(1,IYVAL),1,PDIRC(1,IPVAL),1)
      ENDDO
      IF(GOPARR) THEN
        CALL DDI_GSUMF(2173,PDIRC,NUNIQ*NDETMX*NSTATS)
C
        CALL DDI_PROCDLB_RESET(C_OOOO)
        CALL DDI_PROCDLB_RESET(C_VOOO)
        CALL DDI_PROCDLB_RESET(C_VVOO)
        CALL DDI_PROCDLB_RESET(C_VOVO)
        CALL HSMLTP(RESIDO,PDIRO,OINT,EPS,OPDM,TPDM,WRK,INDEX,IA,NROT,
     *              NUNIQ,NCOR,NACT,L0,L1,L2)
      ENDIF
C
      CALL HSMLTC(RESIDC,RESIDO,RESIDS,PDIRO,PDIRC,PDIRS,PRCNDS,SALAG,
     *            CI,OINT, FCOR,AMAT,ERI,INDEX,IWRK,IFA,IOX,NCOR,NACT,
     *            NA,NB,L1,L2,NSYM,IIS,NDETMX,NDETLN,NROT,NUNIQ,JLO,JHI,
     *            NSTATS,WSTATE)
C
      IF(GOPARR) CALL DDI_GSUMF(2184,RESIDO,NROT*NUNIQ)
      CALL DSCAL(NROT*NUNIQ,TWO,RESIDO,1)
      CALL DSCAL(NROT*NNSTAT,TWO,RESIDS,1)
      CALL DSCAL(NSTATS*NDETLN*NUNIQ,TWO,RESIDC,1)
C
      CALL FMRHS(ZRESO,ZRESC,ZRESS,CI,EGRAD,WSTATE,WRK,INDEX,NOCP,NXYZ,
     *           NUNIQ,NROT,NDETLN,NOCC,L1,NFT18,NFT19,NSTATS,JLO,JHI,
     *           NDETMX,NNSTAT)
C
      ERR = ZERO
      IUNIQ=0
      DO 860 IXYZ=1,NXYZ
        IF(NOCP(IXYZ).NE.1) IUNIQ=IUNIQ+1
        IF(NOCP(IXYZ).EQ.1) GO TO 860
        CALL DSCAL(NROT,-ONE,RESIDO(IUNIQ,1),NUNIQ)
        CALL DSCAL(NNSTAT,-ONE,RESIDS(IUNIQ,1),NUNIQ)
        CALL DSCAL(NSTATS*NDETLN,-ONE,RESIDC(IUNIQ,1),NUNIQ)
        CALL DAXPY(NROT,-ONE,ZRESO(IUNIQ,1),NUNIQ,RESIDO(IUNIQ,1),NUNIQ)
        CALL DAXPY(NNSTAT,-ONE,ZRESS(IUNIQ,1),NUNIQ,RESIDS(IUNIQ,1),
     *             NUNIQ)
        CALL DAXPY(NSTATS*NDETLN,-ONE,ZRESC(IUNIQ,1),NUNIQ,
     *             RESIDC(IUNIQ,1),NUNIQ)
C
        RNORM = DDOT(NSTATS*NDETLN,RESIDC(IUNIQ,1),NUNIQ,
     *               RESIDC(IUNIQ,1),NUNIQ)
        IF(GOPARR) CALL DDI_GSUMF(2186,RNORM,1)
        RNORM = RNORM +
     *          DDOT(NROT,RESIDO(IUNIQ,1),NUNIQ,RESIDO(IUNIQ,1),NUNIQ)
        RNORM = RNORM + DDOT(NNSTAT,RESIDS(IUNIQ,1),NUNIQ,
     *                       RESIDS(IUNIQ,1),NUNIQ)
        TEST = SQRT(RNORM)
        IF(BNORM(IUNIQ).GT.TOL) TEST = TEST/BNORM(IUNIQ)
        IF(TEST.GT.TOLTMP) THEN
          IF(MASWRK) WRITE(IW,9050) IUNIQ,TEST
        END IF
        ERR = MAX(ERR,TEST)
  860 CONTINUE
      IF(GOPARR) CALL DDI_SYNC(6676)
      IF(ERR.GT.TOLTMP) THEN
         IF(MASWRK) WRITE(IW,9060)
         CALL ABRT
         STOP
      END IF
C
C     ----- Print convergence message and restore original NOCP -----
C
      IF(MASWRK .AND. TOL.EQ.TOLTMP) WRITE(IW,9080) ITER
      IF(MASWRK .AND. TOL.NE.TOLTMP) WRITE(IW,9090) ITER
      DO IXYZ=1,NXYZ
         IF(NOCP(IXYZ).EQ.2) NOCP(IXYZ)=0
      ENDDO
C
 9000 FORMAT(/1X,'PRECONDITIONED CONJUGATE GRADIENT SOLVER',5X,
     *           'CONV. TOLERANCE=',1P,E8.2)
 9020 FORMAT(1X,I3,4X,1P,E13.5,0P,4X,I6,8X,F7.1,4X,F7.1)
 9030 FORMAT(1X,'ITER',3X,'RESPONSE ERROR',4X,'IMPROVED',5X,
     *       'ORB-ORB',4X,' CI-ORB',5X)
 9050 FORMAT(1X,'INCORRECT SOLUTION VECTOR: IUNIQ=',I3,5X,'ERR=',E13.5)
 9060 FORMAT(1X,'CPMCHF SOLUTIONS ARE JUNK...SORRY')
 9070 FORMAT(//1X,'*** TOO MANY ITERATIONS IN MCCPCG *** MAXIT=',I5/
     *       1X,'THIS VALUE CANNOT BE RAISED BY THE INPUT BECAUSE'/
     *       1X,'MORE ITERATIONS ARE UNLIKELY TO HELP.'//)
 9075 FORMAT(1X,'DUE TO SLOW CONVERGENCE, TOLERANCE HAS BEEN',
     *       1X,'LOWERED TO ',1P,E8.2)
 9080 FORMAT(1X,'THE CPMCHF HAS CONVERGED AFTER',I4,' ITERATIONS.')
 9090 FORMAT(1X,'*** CAUTION! *** ',
     *       'VECTORS CONVERGED WITH LOWER TOL. AFTER',I4,
     *       ' ITERATIONS.')
CTJD 9720 FORMAT(/2X,'iuniq=',I3,2X,'bnorm=',F18.15)
CTJD 9721 FORMAT(5X,'i=',I4,2X,'prcnd=',F10.6)
CTJD 9725 FORMAT(/2X,'iter=',I4,2X,'iuniq=',I3,2X,'bknum=',F10.6,
CTJD     *       2X,'akden=',F10.6)
CTJD 9726 FORMAT(2X,'iter=',I4,2X,'iuniq=',I3,2X,'test=',F12.9)
CTJD 9727 FORMAT(5X,'iter=',I4,2X,'iuniq=',I3,2X,'rnorm=',F12.9)
      RETURN
      END
C*MODULE CPMCHF  *DECK PCPSDR
      SUBROUTINE PCPSDR(BUFF,SDER,DLAG,DFC,DERI,FCOR,ERI,AMAT,OPDM,TPDM,
     *                  PRCNDO,IA,INDEX,NCOR,NACT,NXYZ,L0,L1,L2,N2,N4,
     *                  NROT,IW)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INTEGER         C_OOOO, C_VOOO, C_VVOO, C_VOVO
      LOGICAL         GOPARR, DSKWRK, MASWRK
      LOGICAL         IJVAL
C
      DIMENSION BUFF(*),SDER(NXYZ,L1,L1),DLAG(NXYZ,L1,L1),DFC(NXYZ,L2),
     *          DERI(NXYZ,N4),FCOR(L2),ERI(L1,NACT,N2),AMAT(L1,NCOR,N2),
     *          OPDM(*),TPDM(N4),PRCNDO(NROT)
      DIMENSION IA(*),INDEX(L1,L1)
C
      COMMON /DLBTIM/ C_OOOO,C_VOOO,C_VVOO,C_VOVO
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      INTEGER         D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB
      LOGICAL         NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /TRFDMS/ D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB,
     *                NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
C
      PARAMETER (ZERO=0.0D+00,HALF=0.5D+00,ONE=1.0D+00,TWO=2.0D+00)
      PARAMETER (FOUR=4.0D+00,TOL=1.0D-09)
C
      NOCC = NCOR+NACT
      NOTR = (NOCC*NOCC+NOCC)/2
      NVIR = L0 - NOCC
      NBVIR = L1-NOCC
      NBTR = (NBVIR*NBVIR+NBVIR)/2
      NBSQ = NBVIR*NBVIR
      L3 = L1*L1
C
      CALL VCLR(PRCNDO,1,NROT)
C
      IP = 0
      CALL TSECND(T0)
      DO 8000 IP=0,NPROC-1
        IWP = MOD(ME+IP,NPROC)
C
C     ----- Get and use (OO|OO) integrals -----
C
        CALL DDI_DISTRIB(D_OOOO,IWP,ILO,IHI,JLO,JHI)
        MAXWRK = JHI-JLO+1
C
        CALL DDI_PROCDLB_NEXT(C_OOOO,IWP,ICNTR1)
C
        DO WHILE(ICNTR1.LT.MAXWRK)
          IJ = JLO + ICNTR1
C
          DO II=1,NOCC
            DO JJ=1,II
              IJTMP = IA(II) + JJ
              IF(IJTMP.EQ.IJ) THEN
                I = II
                J = JJ
                GO TO 10
              ENDIF
            ENDDO
          ENDDO
C
   10     CALL DDI_GET(D_OOOO,1,NOTR,IJ,IJ,BUFF)
C
C          ----- Derivative core Fock matrices -----
C
          DO 50 M=1,NOCC
            DO 50 IC=1,NCOR
              MG = MAX(M,IC)
              ICG = MIN(M,IC)
              MIC = IA(MG) + ICG
              XIJKL = BUFF(MIC)
              IF(ABS(XIJKL).LT.TOL) GO TO 50
              AVAL = TWO*XIJKL
              CALL DAXPY(NXYZ,-AVAL,SDER(1,M,IC),1,DFC(1,IJ),1)
C
              AVAL = HALF*XIJKL
              IF(M.GT.I) GO TO 20
              IM = IA(I) + M
              CALL DAXPY(NXYZ,AVAL,SDER(1,J,IC),1,DFC(1,IM),1)
C
   20         IF((I.EQ.J).OR.(M.GT.J)) GO TO 30
              JM = IA(J) + M
              CALL DAXPY(NXYZ,AVAL,SDER(1,I,IC),1,DFC(1,JM),1)
C
   30         IF(J.GT.M) GO TO 40
              MJ = IA(M) + J
              CALL DAXPY(NXYZ,AVAL,SDER(1,I,IC),1,DFC(1,MJ),1)
C
   40         IF((I.EQ.J).OR.(I.GT.M)) GO TO 50
              MI = IA(M) + I
              CALL DAXPY(NXYZ,AVAL,SDER(1,J,IC),1,DFC(1,MI),1)
   50     CONTINUE
C
C          ----- Derivative two-electron integrals -----
C
          IF((I.LE.NCOR).OR.(J.LE.NCOR)) GO TO 100
          II = I-NCOR
          JJ = J-NCOR
          IIJJ = IA(II) + JJ
          DO 90 K=NCOR+1,NOCC
            DO 90 L=1,NOCC
              KG = MAX(K,L)
              LG = MIN(K,L)
              KL = IA(KG) + LG
              XIJKL = BUFF(KL)
              IF(ABS(XIJKL).LT.TOL) GO TO 90
              XIJKL = HALF*XIJKL
              DO 80 M=NCOR+1,NOCC
                IF(K.GT.M) GO TO 70
                MK = IA(M-NCOR) + K-NCOR
                IF(IIJJ.LE.MK) THEN
                  MKIJ = IA(MK) + IIJJ
                  CALL DAXPY(NXYZ,-XIJKL,SDER(1,M,L),1,DERI(1,MKIJ),1)
                ENDIF
C
                IF(MK.LE.IIJJ) THEN
                  IJMK = IA(IIJJ) + MK
                  CALL DAXPY(NXYZ,-XIJKL,SDER(1,M,L),1,DERI(1,IJMK),1)
                ENDIF
C
   70           IF(M.GT.K) GO TO 80
C
                KM = IA(K-NCOR) + M-NCOR
                IF(IIJJ.LE.KM) THEN
                  KMIJ = IA(KM) + IIJJ
                  CALL DAXPY(NXYZ,-XIJKL,SDER(1,M,L),1,DERI(1,KMIJ),1)
                ENDIF
C
                IF(KM.LE.IIJJ) THEN
                  IJKM = IA(IIJJ) + KM
                  CALL DAXPY(NXYZ,-XIJKL,SDER(1,M,L),1,DERI(1,IJKM),1)
                ENDIF
   80         CONTINUE
   90     CONTINUE
C
C          ----- Construct core Fock matrix -----
C
  100     DVAL = ZERO
          DO IC=1,NCOR
            ICIC = IA(IC) + IC
            DVAL = DVAL + BUFF(ICIC)
          ENDDO
          FCOR(IJ) = FCOR(IJ) + TWO*DVAL
C
          IF(J.GT.NCOR) GO TO 110
          DO K=1,I
            IK = IA(I) + K
            JG = MAX(J,K)
            KG = MIN(J,K)
            JK = IA(JG) + KG
            FCOR(IK) = FCOR(IK) - BUFF(JK)
          ENDDO
C
  110     IF((I.GT.NCOR) .OR. (I.EQ.J)) GO TO 120
          DO K=1,J
            JK = IA(J) + K
            IG = MAX(I,K)
            KG = MIN(I,K)
            IK = IA(IG) + KG
            FCOR(JK) = FCOR(JK) - BUFF(IK)
          ENDDO
C
C          ----- Construct two-electron integral array -----
C
  120     IF(J.LE.NCOR) GO TO 140
          JJ = J-NCOR
          DO 130 K=1,NACT
            DO 130 L=1,K
              KL = IA(K) + L
              KKLL = IA(K+NCOR) + L+NCOR
              ERI(I,JJ,KL) = BUFF(KKLL)
  130     CONTINUE
C
  140     IF((I.LE.NCOR) .OR. (I.EQ.J)) GO TO 155
          II = I-NCOR
          DO 150 K=1,NACT
            DO 150 L=1,K
              KL = IA(K) + L
              KKLL = IA(K+NCOR) + L+NCOR
              ERI(J,II,KL) = BUFF(KKLL)
  150     CONTINUE
C
C          ----- Construct A matrix -----
C
  155     IF(J.GT.NCOR) GO TO 160
          DO K=1,NACT
            KK = K + NCOR
            DO 157 L=1,K
              LL = L + NCOR
              KL = IA(K) + L
              KKLL = IA(KK) + LL
              DVAL = FOUR*BUFF(KKLL)
              AMAT(I,J,KL) = AMAT(I,J,KL) + DVAL
              IF((I.EQ.J) .OR. (I.GT.NCOR)) GO TO 157
              AMAT(J,I,KL) = AMAT(J,I,KL) + DVAL
  157       CONTINUE
          ENDDO
C
  160     IF(J.LE.NCOR) GO TO 165
          JJ = J - NCOR
          DO 163 K=1,NCOR
            DO L=1,NACT
              LL = L +  NCOR
              KL = IA(LL) + K
              JG = MAX(JJ,L)
              LG = MIN(JJ,L)
              JL = IA(JG) + LG
              IF(JJ.GE.L) AMAT(I,K,JL) = AMAT(I,K,JL) - BUFF(KL)
              IF(L.GE.JJ) AMAT(I,K,JL) = AMAT(I,K,JL) - BUFF(KL)
            ENDDO
  163     CONTINUE
C
  165     IF((I.LE.NCOR) .OR. (I.EQ.J)) GO TO 169
          II = I - NCOR
          DO 167 K=1,NCOR
            DO L=1,NACT
              LL = L + NCOR
              KL = IA(LL) + K
              IG = MAX(II,L)
              LG = MIN(II,L)
              IL = IA(IG) + LG
              IF(II.GE.L) AMAT(J,K,IL) = AMAT(J,K,IL) - BUFF(KL)
              IF(L.GE.II) AMAT(J,K,IL) = AMAT(J,K,IL) - BUFF(KL)
            ENDDO
  167     CONTINUE
C
C          ----- Coulomb contribution to derivative Lagrangian -----
C          -----   Lder(i,m) where m is a core orbital index   -----
C
  169     CONTINUE
          DO 200 M=1,NCOR
C
            DVAL = ZERO
            DO K=1,NCOR
              KK = IA(K) + K
              DVAL = DVAL + BUFF(KK)
            ENDDO
            DVAL = TWO*DVAL
            DO 170 K=1,NACT
              DO 170 L=1,K
                KL = IA(K) + L
                DTMP = OPDM(KL)
                IF(K.NE.L) DTMP = TWO*DTMP
                KL = IA(K+NCOR) + L+NCOR
                DVAL = DVAL + DTMP*BUFF(KL)
  170       CONTINUE
            CALL DAXPY(NXYZ,-DVAL,SDER(1,I,M),1,DLAG(1,J,M),1)
            IF(I.NE.J)
     *        CALL DAXPY(NXYZ,-DVAL,SDER(1,J,M),1,DLAG(1,I,M),1)
C
            DO 180 K=1,NCOR
              MG = MAX(M,K)
              KG = MIN(M,K)
              MK = IA(MG) + KG
              DVAL = BUFF(MK)
              IF(ABS(DVAL).LT.TOL) GO TO 180
              CALL DAXPY(NXYZ,DVAL,SDER(1,I,K),1,DLAG(1,J,M),1)
              IF(I.NE.J)
     *          CALL DAXPY(NXYZ,DVAL,SDER(1,J,K),1,DLAG(1,I,M),1)
  180       CONTINUE
C
            DO 190 K=1,NACT
              KK = K + NCOR
              DVAL = ZERO
              DO L=1,NACT
                KG = MAX(K,L)
                LG = MIN(K,L)
                KL = IA(KG) + LG
                DTMP = OPDM(KL)
                ML = IA(L+NCOR) + M
                DVAL = DVAL + DTMP*BUFF(ML)
              ENDDO
              DVAL = HALF*DVAL
              CALL DAXPY(NXYZ,DVAL,SDER(1,I,KK),1,DLAG(1,J,M),1)
              IF(I.NE.J)
     *          CALL DAXPY(NXYZ,DVAL,SDER(1,J,KK),1,DLAG(1,I,M),1)
  190       CONTINUE
  200     CONTINUE
C
C          ----- Coulomb contribution to derivative Lagrangian -----
C          ----- Lder(i,m) where m is an active orbital index  -----
C
          DO 300 M=1,NACT
            MM = M + NCOR
C
            DO 220 N=1,NCOR
              DVAL = ZERO
              DO K=1,NACT
                MG = MAX(M,K)
                KG = MIN(M,K)
                MK = IA(MG) + KG
                DTMP = OPDM(MK)
                KN = IA(K+NCOR) + N
                DVAL = DVAL + DTMP*BUFF(KN)
              ENDDO
              DVAL = HALF*DVAL
              CALL DAXPY(NXYZ,DVAL,SDER(1,I,N),1,DLAG(1,J,MM),1)
              IF(I.NE.J)
     *          CALL DAXPY(NXYZ,DVAL,SDER(1,J,N),1,DLAG(1,I,MM),1)
  220       CONTINUE
C
            DO 260 N=1,NACT
              DVAL = ZERO
              NG = MAX(N,M)
              MG = MIN(N,M)
              NM = IA(NG) + MG
              DO K=1,NCOR
                KK = IA(K) + K
                DVAL = DVAL + BUFF(KK)
              ENDDO
              DVAL = OPDM(NM)*DVAL
              DVAL = TWO*DVAL
C
              DO 240 K=1,NACT
                DO 240 L=1,K
                  KL = IA(K+NCOR) + L+NCOR
                  DTMP = BUFF(KL)
                  IF(K.NE.L) DTMP = TWO*DTMP
                  KL = IA(K) + L
                  NMG = MAX(NM,KL)
                  KLG = MIN(NM,KL)
                  NMKL = IA(NMG) + KLG
                  DVAL = DVAL + DTMP*TPDM(NMKL)
  240         CONTINUE
              DVAL = HALF*DVAL
              CALL DAXPY(NXYZ,-DVAL,SDER(1,I,N+NCOR),1,DLAG(1,J,MM),1)
              IF(I.NE.J)
     *          CALL DAXPY(NXYZ,-DVAL,SDER(1,J,N+NCOR),1,DLAG(1,I,MM),1)
  260       CONTINUE
  300     CONTINUE
C
C          ----- Exchange contribution to derivative Lagrangian -----
C
          DO 400 M=1,NOCC
            IF(J.GT.NCOR) GO TO 350
            IJVAL = .TRUE.
            IF((I.EQ.J) .OR. (I.GT.NCOR)) IJVAL = .FALSE.
            DO 330 N=1,NCOR
              MG = MAX(M,J)
              JG = MIN(M,J)
              MJ = IA(MG) + JG
              XIJKL = BUFF(MJ)
              CALL DAXPY(NXYZ,XIJKL,SDER(1,I,N),1,DLAG(1,M,N),1)
              IF(IJVAL) THEN
                MG = MAX(M,I)
                IG = MIN(M,I)
                MI = IA(MG) + IG
                XIJKL = BUFF(MI)
                CALL DAXPY(NXYZ,XIJKL,SDER(1,J,N),1,DLAG(1,M,N),1)
              ENDIF
C
              MG = MAX(M,N)
              NG = MIN(M,N)
              MN = IA(MG) + NG
              XIJKL = BUFF(MN)
              DVAL = FOUR*XIJKL
              CALL DAXPY(NXYZ,-DVAL,SDER(1,I,J),1,DLAG(1,M,N),1)
              IF(IJVAL) CALL DAXPY(NXYZ,-DVAL,SDER(1,J,I),1,
     *                             DLAG(1,M,N),1)
C
              IF(N.EQ.J) THEN
                DO K=1,NCOR
                  MG = MAX(M,K)
                  KG = MIN(M,K)
                  MK = IA(MG) + KG
                  XIJKL = BUFF(MK)
                  CALL DAXPY(NXYZ,XIJKL,SDER(1,I,K),1,DLAG(1,M,N),1)
                ENDDO
C
                DO 310 K=1,NACT
                  DO 310 L=1,NACT
                    KG = MAX(K,L)
                    LG = MIN(K,L)
                    KL = IA(KG) + LG
                    MG = MAX(M,L+NCOR)
                    LG = MIN(M,L+NCOR)
                    ML = IA(MG) + LG
                    DVAL = OPDM(KL)*BUFF(ML)
                    DVAL = HALF*DVAL
                    CALL DAXPY(NXYZ,DVAL,SDER(1,I,K+NCOR),1,
     *                         DLAG(1,M,N),1)
  310           CONTINUE
              ENDIF
C
              IF((N.EQ.I) .AND. (I.NE.J)) THEN
                DO K=1,NCOR
                  MG = MAX(M,K)
                  KG = MIN(M,K)
                  MK = IA(MG) + KG
                  XIJKL = BUFF(MK)
                  CALL DAXPY(NXYZ,XIJKL,SDER(1,J,K),1,DLAG(1,M,N),1)
                ENDDO
C
                DO 320 K=1,NACT
                  DO 320 L=1,NACT
                    KG = MAX(K,L)
                    LG = MIN(K,L)
                    KL = IA(KG) + LG
                    MG = MAX(M,L+NCOR)
                    LG = MIN(M,L+NCOR)
                    ML = IA(MG) + LG
                    DVAL = OPDM(KL)*BUFF(ML)
                    DVAL = HALF*DVAL
                    CALL DAXPY(NXYZ,DVAL,SDER(1,J,K+NCOR),1,
     *                         DLAG(1,M,N),1)
  320           CONTINUE
              ENDIF
  330       CONTINUE
C
            MG = MAX(M,J)
            JG = MIN(M,J)
            MJ = IA(MG) + JG
            IF(IJVAL) THEN
              MG = MAX(M,I)
              IG = MIN(M,I)
              MI = IA(MG) + IG
            ENDIF
            DO 340 N=1,NACT
              DO K=1,NACT
                NG = MAX(N,K)
                KG = MIN(N,K)
                NK = IA(NG) + KG
                MG = MAX(M,K+NCOR)
                KG = MIN(M,K+NCOR)
                MK = IA(MG) + KG
                DVAL = OPDM(NK)*BUFF(MK)
                DVAL = TWO*DVAL
                CALL DAXPY(NXYZ,-DVAL,SDER(1,I,J),1,DLAG(1,M,N+NCOR),1)
                IF(IJVAL) CALL DAXPY(NXYZ,-DVAL,SDER(1,J,I),1,
     *                               DLAG(1,M,N+NCOR),1)
C
                DVAL = OPDM(NK)*BUFF(MJ)
                DVAL = HALF*DVAL
                CALL DAXPY(NXYZ,DVAL,SDER(1,I,K+NCOR),1,
     *                     DLAG(1,M,N+NCOR),1)
                IF(IJVAL) THEN
                  DVAL = OPDM(NK)*BUFF(MI)
                  DVAL = HALF*DVAL
                  CALL DAXPY(NXYZ,DVAL,SDER(1,J,K+NCOR),1,
     *                       DLAG(1,M,N+NCOR),1)
                ENDIF
              ENDDO
  340       CONTINUE
C
  350       IF(I.LE.NCOR) GO TO 400
            IJVAL = .TRUE.
            IF((I.EQ.J) .OR. (J.LE.NCOR)) IJVAL = .FALSE.
            DO 360 N=1,NCOR
              MG = MAX(M,N)
              NG = MIN(M,N)
              MN = IA(MG) + NG
              DO K=1,NACT
                KG = MAX(K,I-NCOR)
                IG = MIN(K,I-NCOR)
                KI = IA(KG) + IG
                DVAL = OPDM(KI)*BUFF(MN)
                DVAL = TWO*DVAL
                CALL DAXPY(NXYZ,-DVAL,SDER(1,J,K+NCOR),1,DLAG(1,M,N),1)
                IF(IJVAL) THEN
                  KG = MAX(K,J-NCOR)
                  JG = MIN(K,J-NCOR)
                  KJ = IA(KG) + JG
                  DVAL = OPDM(KJ)*BUFF(MN)
                  DVAL = TWO*DVAL
                  CALL DAXPY(NXYZ,-DVAL,SDER(1,I,K+NCOR),1,
     *                       DLAG(1,M,N),1)
                ENDIF
C
                MG = MAX(M,K+NCOR)
                KG = MIN(M,K+NCOR)
                MK = IA(MG) + KG
                DVAL = OPDM(KI)*BUFF(MK)
                DVAL = HALF*DVAL
                CALL DAXPY(NXYZ,DVAL,SDER(1,J,N),1,DLAG(1,M,N),1)
                IF(IJVAL) THEN
                  DVAL = OPDM(KJ)*BUFF(MK)
                  DVAL = HALF*DVAL
                  CALL DAXPY(NXYZ,DVAL,SDER(1,I,N),1,DLAG(1,M,N),1)
                ENDIF
              ENDDO
  360       CONTINUE
C
            DO 390 N=1,NACT
              IG = MAX(I-NCOR,N)
              NG = MIN(I-NCOR,N)
              IN = IA(IG) + NG
              IF(IJVAL) THEN
                JG = MAX(J-NCOR,N)
                NG = MIN(J-NCOR,N)
                JN = IA(JG) + NG
              ENDIF
              DO K=1,NCOR
                MG = MAX(M,K)
                KG = MIN(M,K)
                MK = IA(MG) + KG
                DVAL = OPDM(IN)*BUFF(MK)
                DVAL = HALF*DVAL
                CALL DAXPY(NXYZ,DVAL,SDER(1,J,K),1,DLAG(1,M,N+NCOR),1)
                IF(IJVAL) THEN
                  DVAL = OPDM(JN)*BUFF(MK)
                  DVAL = HALF*DVAL
                  CALL DAXPY(NXYZ,DVAL,SDER(1,I,K),1,DLAG(1,M,N+NCOR),1)
                ENDIF
              ENDDO
C
              DO 370 K=1,NACT
                KG = MAX(K,I-NCOR)
                IG = MIN(K,I-NCOR)
                KI = IA(KG) + IG
                IF(IJVAL) THEN
                  KG = MAX(K,J-NCOR)
                  JG = MIN(K,J-NCOR)
                  KJ = IA(KG) + JG
                ENDIF
                DO 370 L=1,NACT
                  MG = MAX(M,L+NCOR)
                  LG = MIN(M,L+NCOR)
                  ML = IA(MG) + LG
                  NG = MAX(N,L)
                  LG = MIN(N,L)
                  NL = IA(NG) + LG
                  KIG = MAX(KI,NL)
                  NLG = MIN(KI,NL)
                  KINL = IA(KIG) + NLG
                  DVAL = TPDM(KINL)*BUFF(ML)
                  CALL DAXPY(NXYZ,-DVAL,SDER(1,J,K+NCOR),1,
     *                       DLAG(1,M,N+NCOR),1)
                  IF(IJVAL) THEN
                    KJG = MAX(KJ,NL)
                    NLG = MIN(KJ,NL)
                    KJNL = IA(KJG) + NLG
                    DVAL = TPDM(KJNL)*BUFF(ML)
                    CALL DAXPY(NXYZ,-DVAL,SDER(1,I,K+NCOR),1,
     *                         DLAG(1,M,N+NCOR),1)
                  ENDIF
  370         CONTINUE
  390       CONTINUE
  400     CONTINUE
C
C          ----- Coulomb contribution to preconditioner -----
C          -----      Inner indicies are both core      -----
C
           DO 440 N=1,NCOR
             JNG = IABS(INDEX(J,N))
             IF(JNG.EQ.0) GO TO 440
             DO 430 M=1,NCOR
               IMG = IABS(INDEX(I,M))
               IF(IMG.NE.JNG) GO TO 430
               MG = MAX(M,N)
               NG = MIN(M,N)
               MN = IA(MG) + NG
C
               DVAL = ZERO
               IF(M.EQ.N) THEN
                 DO K=1,NCOR
                   KK = IA(K) + K
                   DVAL = DVAL + BUFF(KK)
                 ENDDO
                 DVAL = TWO*DVAL
C
                 DO 420 K=1,NACT
                   DO 420 L=1,K
                     KL = IA(K+NCOR) + L+NCOR
                     XIJKL = BUFF(KL)
                     IF(K.NE.L) XIJKL = TWO*XIJKL
                     KL = IA(K) + L
                     DVAL = DVAL + OPDM(KL)*XIJKL
  420            CONTINUE
               ENDIF
C
               DVAL = DVAL - BUFF(MN)
               DVAL = TWO*DVAL
               IF(N.GT.J) DVAL = -DVAL
               IF(M.GT.I) DVAL = -DVAL
               PRCNDO(IMG) = PRCNDO(IMG) + DVAL
  430        CONTINUE
  440      CONTINUE
           IF(I.EQ.J) GO TO 480
C
           DO 470 N=1,NCOR
             ING = IABS(INDEX(I,N))
             IF(ING.EQ.0) GO TO 470
             DO 460 M=1,NCOR
               JMG = IABS(INDEX(J,M))
               IF(JMG.NE.ING) GO TO 460
               MG = MAX(M,N)
               NG = MIN(M,N)
               MN = IA(MG) + NG
C
               DVAL = ZERO
               IF(M.EQ.N) THEN
                 DO K=1,NCOR
                   KK = IA(K) + K
                   DVAL = DVAL + BUFF(KK)
                 ENDDO
                 DVAL = TWO*DVAL
C
                 DO 450 K=1,NACT
                   DO 450 L=1,K
                     KL = IA(K+NCOR) + L+NCOR
                     XIJKL = BUFF(KL)
                     IF(K.NE.L) XIJKL = TWO*XIJKL
                     KL = IA(K) + L
                     DVAL = DVAL + OPDM(KL)*XIJKL
  450            CONTINUE
               ENDIF
C
               DVAL = DVAL - BUFF(MN)
               DVAL = TWO*DVAL
               IF(N.GT.I) DVAL = -DVAL
               IF(M.GT.J) DVAL = -DVAL
               PRCNDO(JMG) = PRCNDO(JMG) + DVAL
  460        CONTINUE
  470      CONTINUE
C
C          ----- Coulomb contribution to preconditioner -----
C          -----    One core index, one active index    -----
C
  480      CONTINUE
           DO 540 N=1,NCOR
             JNG = IABS(INDEX(J,N))
             IF(JNG.EQ.0) GO TO 510
             DO 500 M=1,NACT
               IMG = IABS(INDEX(I,M+NCOR))
               IF(IMG.NE.JNG) GO TO 500
               DO K=1,NACT
                 KN = IA(K+NCOR) + N
                 XIJKL = BUFF(KN)
                 KG = MAX(K,M)
                 MG = MIN(K,M)
                 KM = IA(KG) + MG
                 IF(N.GT.J) XIJKL = -XIJKL
                 IF((M+NCOR).GT.I) XIJKL = -XIJKL
                 IF(I.NE.J) XIJKL = TWO*XIJKL
                 PRCNDO(IMG) = PRCNDO(IMG) - OPDM(KM)*XIJKL
               ENDDO
  500        CONTINUE
C
  510        ING = IABS(INDEX(I,N))
             IF(ING.EQ.0) GO TO 540
             DO 520 M=1,NACT
               JMG = IABS(INDEX(J,M+NCOR))
               IF(JMG.NE.ING) GO TO 520
               DO K=1,NACT
                 KN = IA(K+NCOR) + N
                 XIJKL = BUFF(KN)
                 KG = MAX(K,M)
                 MG = MIN(K,M)
                 KM = IA(KG) + MG
                 IF(N.GT.I) XIJKL = -XIJKL
                 IF((M+NCOR).GT.J) XIJKL = -XIJKL
                 IF(I.NE.J) XIJKL = TWO*XIJKL
                 PRCNDO(JMG) = PRCNDO(JMG) - OPDM(KM)*XIJKL
               ENDDO
  520        CONTINUE
  540      CONTINUE
C
C          ----- Coulomb contribution to preconditioner -----
C          -----     Inner indicies are both active     -----
C
           DO 580 N=1,NACT
             JNG = IABS(INDEX(J,N+NCOR))
             IF(JNG.EQ.0) GO TO 580
             DO 570 M=1,NACT
               IMG = IABS(INDEX(I,M+NCOR))
               IF(IMG.NE.JNG) GO TO 570
               MG = MAX(M,N)
               NG = MIN(M,N)
               MN = IA(MG) + NG
C
               DVAL = ZERO
               DO K=1,NCOR
                 KK = IA(K) + K
                 DVAL = DVAL + BUFF(KK)
               ENDDO
               DVAL = TWO*DVAL
               DVAL = OPDM(MN)*DVAL
C
               DO 560 K=1,NACT
                 DO 560 L=1,K
                   KL = IA(K+NCOR) + L+NCOR
                   XIJKL = BUFF(KL)
                   IF(ABS(XIJKL).LT.TOL) GO TO 560
                   IF(K.NE.L) XIJKL = TWO*XIJKL
                   KL = IA(K) + L
                   MNG = MAX(MN,KL)
                   KLG = MIN(MN,KL)
                   MNKL = IA(MNG) + KLG
                   DVAL = DVAL + TPDM(MNKL)*XIJKL
  560          CONTINUE
C
               IF((N+NCOR).GT.J) DVAL = -DVAL
               IF((M+NCOR).GT.I) DVAL = -DVAL
               PRCNDO(IMG) = PRCNDO(IMG) + DVAL
  570        CONTINUE
  580      CONTINUE
           IF(I.EQ.J) GO TO 650
C
           DO 640 N=1,NACT
             ING = IABS(INDEX(I,N+NCOR))
             IF(ING.EQ.0) GO TO 640
             DO 630 M=1,NACT
               JMG = IABS(INDEX(J,M+NCOR))
               IF(JMG.NE.ING) GO TO 630
               MG = MAX(M,N)
               NG = MIN(M,N)
               MN = IA(MG) + NG
C
               DVAL = ZERO
               DO K=1,NCOR
                 KK = IA(K) + K
                 DVAL = DVAL + BUFF(KK)
               ENDDO
               DVAL = TWO*DVAL
               DVAL = OPDM(MN)*DVAL
C
               DO 620 K=1,NACT
                 DO 620 L=1,K
                   KL = IA(K+NCOR) + L+NCOR
                   XIJKL = BUFF(KL)
                   IF(ABS(XIJKL).LT.TOL) GO TO 620
                   IF(K.NE.L) XIJKL = TWO*XIJKL
                   KL = IA(K) + L
                   MNG = MAX(MN,KL)
                   KLG = MIN(MN,KL)
                   MNKL = IA(MNG) + KLG
                   DVAL = DVAL + TPDM(MNKL)*XIJKL
  620          CONTINUE
C
               IF((N+NCOR).GT.I) DVAL = -DVAL
               IF((M+NCOR).GT.J) DVAL = -DVAL
               PRCNDO(JMG) = PRCNDO(JMG) + DVAL
  630        CONTINUE
  640      CONTINUE
C
C          ----- Exchange contribution to preconditioner -----
C          -----           Second index is core          -----
C
  650     IF(J.GT.NCOR) GO TO 850
          DO 740 K=1,NOCC
            DO 690 L=1,NCOR
              KG = MAX(K,L)
              LG = MIN(K,L)
              KL = IA(KG) + LG
              XIJKL = BUFF(KL)
              IF(ABS(XIJKL).LT.TOL) GO TO 690
C
              IMG = IABS(INDEX(I,J))
              KNG = IABS(INDEX(K,L))
              IF((IMG.EQ.KNG) .AND. (IMG.NE.0)) THEN
                DVAL = TWO*XIJKL
                IF(J.GT.I) DVAL = -DVAL
                IF(L.GT.K) DVAL = -DVAL
                PRCNDO(IMG) = PRCNDO(IMG) + FOUR*DVAL
              ENDIF
C
              IMG = IABS(INDEX(I,L))
              KNG = IABS(INDEX(K,J))
              IF((IMG.EQ.KNG) .AND. (IMG.NE.0)) THEN
                DVAL = TWO*XIJKL
                IF(L.GT.I) DVAL = -DVAL
                IF(J.GT.K) DVAL = -DVAL
                PRCNDO(IMG) = PRCNDO(IMG) - DVAL
              ENDIF
C
              IF(J.EQ.L) THEN
                DO 660 M=1,NCOR
                  IMG = IABS(INDEX(I,M))
                  KMG = IABS(INDEX(K,M))
                  IF((IMG.NE.KMG) .OR. (IMG.EQ.0)) GO TO 660
                  DVAL = TWO*XIJKL
                  IF(M.GT.I) DVAL = -DVAL
                  IF(M.GT.K) DVAL = -DVAL
                  PRCNDO(IMG) = PRCNDO(IMG) - DVAL
  660           CONTINUE
C
                DO 680 M=1,NACT
                  IMG = IABS(INDEX(I,M+NCOR))
                  IF(IMG.EQ.0) GO TO 680
                  DO 670 N=1,NACT
                    KNG = IABS(INDEX(K,N+NCOR))
                    IF(IMG.NE.KNG) GO TO 670
                    MG = MAX(M,N)
                    NG = MIN(M,N)
                    MN = IA(MG) + NG
                    DVAL = OPDM(MN)*XIJKL
                    IF((M+NCOR).GT.I) DVAL = -DVAL
                    IF((N+NCOR).GT.K) DVAL = -DVAL
                    PRCNDO(IMG) = PRCNDO(IMG) - DVAL
  670             CONTINUE
  680           CONTINUE
              ENDIF
  690       CONTINUE
C
            DO 730 L=1,NACT
              KG = MAX(K,L+NCOR)
              LG = MIN(K,L+NCOR)
              KL = IA(KG) + LG
              XIJKL = BUFF(KL)
              IF(ABS(XIJKL).LT.TOL) GO TO 730
C
              IMG = IABS(INDEX(I,J))
              IF(IMG.NE.0) THEN
                DO 710 N=1,NACT
                  KNG = IABS(INDEX(K,N+NCOR))
                  IF(IMG.NE.KNG) GO TO 710
                  LG = MAX(L,N)
                  NG = MIN(L,N)
                  LN = IA(LG) + NG
                  DVAL = OPDM(LN)*XIJKL
                  IF(J.GT.I) DVAL = -DVAL
                  IF((N+NCOR).GT.K) DVAL = -DVAL
                  PRCNDO(IMG) = PRCNDO(IMG) + FOUR*DVAL
  710           CONTINUE
              ENDIF
C
              KNG = IABS(INDEX(K,J))
              IF(KNG.NE.0) THEN
                DO 720 M=1,NACT
                  IMG = IABS(INDEX(I,M+NCOR))
                  IF(IMG.NE.KNG) GO TO 720
                  LG = MAX(L,M)
                  MG = MIN(L,M)
                  LM = IA(LG) + MG
                  DVAL = OPDM(LM)*XIJKL
                  IF(J.GT.K) DVAL = -DVAL
                  IF((M+NCOR).GT.I) DVAL = -DVAL
                  PRCNDO(IMG) = PRCNDO(IMG) - DVAL
  720           CONTINUE
              ENDIF
  730       CONTINUE
  740     CONTINUE
C
          IF((I.EQ.J) .OR. (I.GT.NCOR)) GO TO 850
          DO 840 K=1,NOCC
            DO 790 L=1,NCOR
              KG = MAX(K,L)
              LG = MIN(K,L)
              KL = IA(KG) + LG
              XIJKL = BUFF(KL)
              IF(ABS(XIJKL).LT.TOL) GO TO 790
C
              JMG = IABS(INDEX(J,I))
              KNG = IABS(INDEX(K,L))
              IF((JMG.EQ.KNG) .AND. (JMG.NE.0)) THEN
                DVAL = TWO*XIJKL
                IF(I.GT.J) DVAL = -DVAL
                IF(L.GT.K) DVAL = -DVAL
                PRCNDO(JMG) = PRCNDO(JMG) + FOUR*DVAL
              ENDIF
C
              JMG = IABS(INDEX(J,L))
              KNG = IABS(INDEX(K,I))
              IF((JMG.EQ.KNG) .AND. (JMG.NE.0)) THEN
                DVAL = TWO*XIJKL
                IF(L.GT.J) DVAL = -DVAL
                IF(I.GT.K) DVAL = -DVAL
                PRCNDO(JMG) = PRCNDO(JMG) - DVAL
              ENDIF
C
              IF(I.EQ.L) THEN
                DO 760 M=1,NCOR
                  JMG = IABS(INDEX(J,M))
                  KMG = IABS(INDEX(K,M))
                  IF((JMG.NE.KMG) .OR. (JMG.EQ.0)) GO TO 760
                  DVAL = TWO*XIJKL
                  IF(M.GT.J) DVAL = -DVAL
                  IF(M.GT.K) DVAL = -DVAL
                  PRCNDO(JMG) = PRCNDO(JMG) - DVAL
  760           CONTINUE
C
                DO 780 M=1,NACT
                  JMG = IABS(INDEX(J,M+NCOR))
                  IF(JMG.EQ.0) GO TO 780
                  DO 770 N=1,NACT
                    KNG = IABS(INDEX(K,N+NCOR))
                    IF(JMG.NE.KNG) GO TO 770
                    MG = MAX(M,N)
                    NG = MIN(M,N)
                    MN = IA(MG) + NG
                    DVAL = OPDM(MN)*XIJKL
                    IF((M+NCOR).GT.J) DVAL = -DVAL
                    IF((N+NCOR).GT.K) DVAL = -DVAL
                    PRCNDO(JMG) = PRCNDO(JMG) - DVAL
  770             CONTINUE
  780           CONTINUE
              ENDIF
  790       CONTINUE
C
            DO 830 L=1,NACT
              KG = MAX(K,L+NCOR)
              LG = MIN(K,L+NCOR)
              KL = IA(KG) + LG
              XIJKL = BUFF(KL)
              IF(ABS(XIJKL).LT.TOL) GO TO 830
C
              JMG = IABS(INDEX(J,I))
              IF(JMG.NE.0) THEN
                DO 810 N=1,NACT
                  KNG = IABS(INDEX(K,N+NCOR))
                  IF(JMG.NE.KNG) GO TO 810
                  LG = MAX(L,N)
                  NG = MIN(L,N)
                  LN = IA(LG) + NG
                  DVAL = OPDM(LN)*XIJKL
                  IF(I.GT.J) DVAL = -DVAL
                  IF((N+NCOR).GT.K) DVAL = -DVAL
                  PRCNDO(JMG) = PRCNDO(JMG) + FOUR*DVAL
  810           CONTINUE
              ENDIF
C
              KNG = IABS(INDEX(K,I))
              IF(KNG.NE.0) THEN
                DO 820 M=1,NACT
                  JMG = IABS(INDEX(J,M+NCOR))
                  IF(JMG.NE.KNG) GO TO 820
                  LG = MAX(L,M)
                  MG = MIN(L,M)
                  LM = IA(LG) + MG
                  DVAL = OPDM(LM)*XIJKL
                  IF(I.GT.K) DVAL = -DVAL
                  IF((M+NCOR).GT.J) DVAL = -DVAL
                  PRCNDO(JMG) = PRCNDO(JMG) - DVAL
  820           CONTINUE
              ENDIF
  830       CONTINUE
  840     CONTINUE
C
C          ----- Exchange contribution to preconditioner -----
C          -----         Second index is valence         -----
C
  850     IF(I.LE.NCOR) GO TO 1000
          DO 990 K=1,NOCC
            DO 910 L=1,NCOR
              KG = MAX(K,L)
              LG = MIN(K,L)
              KL = IA(KG) + LG
              XIJKL = BUFF(KL)
              IF(ABS(XIJKL).LT.TOL) GO TO 910
C
              IF(J.LE.NCOR) GO TO 880
              IMG = IABS(INDEX(I,L))
              IF(IMG.NE.0) THEN
                DO 860 N=1,NACT
                  KNG = IABS(INDEX(K,N+NCOR))
                  IF(IMG.NE.KNG) GO TO 860
                  NG = MAX(N,J-NCOR)
                  JG = MIN(N,J-NCOR)
                  NJ = IA(NG) + JG
                  DVAL = OPDM(NJ)*XIJKL
                  IF(L.GT.I) DVAL = -DVAL
                  IF((N+NCOR).GT.K) DVAL = -DVAL
                  PRCNDO(IMG) = PRCNDO(IMG) - DVAL
  860           CONTINUE
              ENDIF
C
              KNG = IABS(INDEX(K,L))
              IF(KNG.NE.0) THEN
                DO 870 M=1,NACT
                  IMG = IABS(INDEX(I,M+NCOR))
                  IF(IMG.NE.KNG) GO TO 870
                  MG = MAX(M,J-NCOR)
                  JG = MIN(M,J-NCOR)
                  MJ = IA(MG) + JG
                  DVAL = OPDM(MJ)*XIJKL
                  IF(L.GT.K) DVAL = -DVAL
                  IF((M+NCOR).GT.I) DVAL = -DVAL
                  PRCNDO(IMG) = PRCNDO(IMG) + FOUR*DVAL
  870           CONTINUE
              ENDIF
C
  880         IF(I.EQ.J) GO TO 910
              JMG = IABS(INDEX(J,L))
              IF(JMG.NE.0) THEN
                DO 890 N=1,NACT
                  KNG = IABS(INDEX(K,N+NCOR))
                  IF(JMG.NE.KNG) GO TO 890
                  NG = MAX(N,I-NCOR)
                  IG = MIN(N,I-NCOR)
                  NI = IA(NG) + IG
                  DVAL = OPDM(NI)*XIJKL
                  IF(L.GT.J) DVAL = -DVAL
                  IF((N+NCOR).GT.K) DVAL = -DVAL
                  PRCNDO(JMG) = PRCNDO(JMG) - DVAL
  890           CONTINUE
              ENDIF
C
              KNG = IABS(INDEX(K,L))
              IF(KNG.NE.0) THEN
                DO 900 M=1,NACT
                  JMG = IABS(INDEX(J,M+NCOR))
                  IF(JMG.NE.KNG) GO TO 900
                  MG = MAX(M,I-NCOR)
                  IG = MIN(M,I-NCOR)
                  MI = IA(MG) + IG
                  DVAL = OPDM(MI)*XIJKL
                  IF(L.GT.K) DVAL = -DVAL
                  IF((M+NCOR).GT.J) DVAL = -DVAL
                  PRCNDO(JMG) = PRCNDO(JMG) + FOUR*DVAL
  900           CONTINUE
              ENDIF
  910       CONTINUE
C
            DO 980 L=1,NACT
              KG = MAX(K,L+NCOR)
              LG = MIN(K,L+NCOR)
              KL = IA(KG) + LG
              XIJKL = BUFF(KL)
              IF(ABS(XIJKL).LT.TOL) GO TO 980
C
              IF(J.LE.NCOR) GO TO 945
              JG = MAX(J-NCOR,L)
              LG = MIN(J-NCOR,L)
              JL = IA(JG) + LG
              DO 920 M=1,NCOR
                IMG = IABS(INDEX(I,M))
                KMG = IABS(INDEX(K,M))
                IF((KMG.NE.IMG) .OR. (IMG.EQ.0)) GO TO 920
                DVAL = OPDM(JL)*XIJKL
                IF(M.GT.I) DVAL = -DVAL
                IF(M.GT.K) DVAL = -DVAL
                PRCNDO(IMG) = PRCNDO(IMG) - DVAL
  920         CONTINUE
C
              DO 940 M=1,NACT
                IMG = IABS(INDEX(I,M+NCOR))
                IF(IMG.EQ.0) GO TO 940
                MG = MAX(M,J-NCOR)
                JG = MIN(M,J-NCOR)
                MJ = IA(MG) + JG
                DO 930 N=1,NACT
                  KNG = IABS(INDEX(K,N+NCOR))
                  IF(IMG.NE.KNG) GO TO 930
                  NG = MAX(N,L)
                  LG = MIN(N,L)
                  NL = IA(NG) + LG
                  MJG = MAX(MJ,NL)
                  NLG = MIN(MJ,NL)
                  MJNL = IA(MJG) + NLG
                  DVAL = TPDM(MJNL)*XIJKL
                  IF((M+NCOR).GT.I) DVAL = -DVAL
                  IF((N+NCOR).GT.K) DVAL = -DVAL
                  PRCNDO(IMG) = PRCNDO(IMG) + TWO*DVAL
  930           CONTINUE
  940         CONTINUE
C
  945         IF(I.EQ.J) GO TO 980
              IG = MAX(I-NCOR,L)
              LG = MIN(I-NCOR,L)
              IL = IA(IG) + LG
              DO 950 M=1,NCOR
                JMG = IABS(INDEX(J,M))
                KMG = IABS(INDEX(K,M))
                IF((KMG.NE.JMG) .OR. (JMG.EQ.0)) GO TO 950
                DVAL = OPDM(IL)*XIJKL
                IF(M.GT.J) DVAL = -DVAL
                IF(M.GT.K) DVAL = -DVAL
                PRCNDO(JMG) = PRCNDO(JMG) - DVAL
  950         CONTINUE
C
              DO 970 M=1,NACT
                JMG = IABS(INDEX(J,M+NCOR))
                IF(JMG.EQ.0) GO TO 970
                MG = MAX(M,I-NCOR)
                IG = MIN(M,I-NCOR)
                MI = IA(MG) + IG
                DO 960 N=1,NACT
                  KNG = IABS(INDEX(K,N+NCOR))
                  IF(JMG.NE.KNG) GO TO 960
                  NG = MAX(N,L)
                  LG = MIN(N,L)
                  NL = IA(NG) + LG
                  MIG = MAX(MI,NL)
                  NLG = MIN(MI,NL)
                  MINL = IA(MIG) + NLG
                  DVAL = TPDM(MINL)*XIJKL
                  IF((M+NCOR).GT.J) DVAL = -DVAL
                  IF((N+NCOR).GT.K) DVAL = -DVAL
                  PRCNDO(JMG) = PRCNDO(JMG) + TWO*DVAL
  960           CONTINUE
  970         CONTINUE
  980       CONTINUE
  990     CONTINUE
C
C          ----- Finished with current integral buffer -----
C
 1000     CALL DDI_PROCDLB_NEXT(C_OOOO,IWP,ICNTR1)
C
        ENDDO
        CALL TSECND(T1)
        IF(IWP.EQ.ME  .AND.  MASWRK) WRITE(IW,9000) T1-T0
        CALL FLSHBF(IW)
        T0 = T1
C
C     ----- Get and use (VO|OO) integrals -----
C
        CALL DDI_DISTRIB(D_VOOO,IWP,ILO,IHI,JLO,JHI)
        MAXWRK = JHI-JLO+1
C
        CALL DDI_PROCDLB_NEXT(C_VOOO,IWP,ICNTR2)
C
        DO WHILE(ICNTR2.LT.MAXWRK)
          JKL = JLO + ICNTR2
C
          DO KK=1,NOCC
            DO LL=1,KK
              KL = IA(KK) + LL
              DLT = ONE
              IF(KK.EQ.LL) DLT = HALF
              DO JJ=1,NOCC
                JKLTMP = (KL-1)*NOCC + JJ
                IF(JKL.EQ.JKLTMP) THEN
                  J = JJ
                  K = KK
                  L = LL
                  IF(K.GT.NCOR .AND. L.GT.NCOR) THEN
                    KKLL = IA(K-NCOR) + L-NCOR
                  ENDIF
                  GO TO 1010
                END IF
              ENDDO
            ENDDO
          ENDDO
C
 1010     CALL DDI_GET(D_VOOO,1,NBVIR,JKL,JKL,BUFF)
C
C          ----- Derivative core Fock matrices -----
C
          DO 1060 I=NOCC+1,L0
            XIJKL = BUFF(I-NOCC)
            IF(ABS(XIJKL).LT.TOL) GO TO 1060
            IF(J.GT.NCOR) GO TO 1020
            AVAL = TWO*XIJKL
            CALL DAXPY(NXYZ,-AVAL,SDER(1,I,J),1,DFC(1,KL),1)
C
 1020       IF((K.GT.NCOR).AND.(L.GT.NCOR)) GO TO 1060
            AVAL = HALF*XIJKL
            IF(K.EQ.L) AVAL = HALF*AVAL
            IF((K.GT.J).OR.(L.GT.NCOR)) GO TO 1030
            JK = IA(J) + K
            CALL DAXPY(NXYZ,AVAL,SDER(1,I,L),1,DFC(1,JK),1)
C
 1030       IF((L.GT.J).OR.(K.GT.NCOR)) GO TO 1040
            JL = IA(J) + L
            CALL DAXPY(NXYZ,AVAL,SDER(1,I,K),1,DFC(1,JL),1)
C
 1040       IF((J.GT.K).OR.(L.GT.NCOR)) GO TO 1050
            KJ = IA(K) + J
            CALL DAXPY(NXYZ,AVAL,SDER(1,I,L),1,DFC(1,KJ),1)
C
 1050       IF((J.GT.L).OR.(K.GT.NCOR)) GO TO 1060
            LJ = IA(L) + J
            CALL DAXPY(NXYZ,AVAL,SDER(1,I,K),1,DFC(1,LJ),1)
 1060     CONTINUE
C
C          ----- Derivative two-electron integrals -----
C
          IF((J.LE.NCOR).OR.(K.LE.NCOR).OR.(L.LE.NCOR)) GO TO 1100
          DO 1090 I=NOCC+1,L0
            XIJKL = BUFF(I-NOCC)
            IF(ABS(XIJKL).LT.TOL) GO TO 1090
            XIJKL = HALF*XIJKL
            DO 1080 M=NCOR+1,NOCC
              IF(J.GT.M) GO TO 1070
              MJ = IA(M-NCOR) + J-NCOR
              IF(KKLL.LE.MJ) THEN
                MJKL = IA(MJ) + KKLL
                CALL DAXPY(NXYZ,-XIJKL,SDER(1,M,I),1,DERI(1,MJKL),1)
              ENDIF
C
              IF(MJ.LE.KKLL) THEN
                KLMJ = IA(KKLL) + MJ
                CALL DAXPY(NXYZ,-XIJKL,SDER(1,M,I),1,DERI(1,KLMJ),1)
              ENDIF
C
 1070         IF(M.GT.J) GO TO 1080
C
              JM = IA(J-NCOR) + M-NCOR
              IF(KKLL.LE.JM) THEN
                JMKL = IA(JM) + KKLL
                CALL DAXPY(NXYZ,-XIJKL,SDER(1,M,I),1,DERI(1,JMKL),1)
              ENDIF
C
              IF(JM.LE.KKLL) THEN
                KLJM = IA(KKLL) + JM
                CALL DAXPY(NXYZ,-XIJKL,SDER(1,M,I),1,DERI(1,KLJM),1)
              ENDIF
 1080       CONTINUE
 1090     CONTINUE
C
C          ----- Construct core Fock matrix -----
C
 1100     IF((K.NE.L) .OR. (K.GT.NCOR)) GO TO 1110
          DO I=NOCC+1,L0
            IJ = IA(I) + J
            FCOR(IJ) = FCOR(IJ) + TWO*BUFF(I-NOCC)
          ENDDO
C
 1110     IF(J.GT.NCOR) GO TO 1130
          IF(J.NE.L) GO TO 1120
          DO I=NOCC+1,L0
            IK = IA(I) + K
            FCOR(IK) = FCOR(IK) - BUFF(I-NOCC)
          ENDDO
C
 1120     IF((J.NE.K) .OR. (K.EQ.L)) GO TO 1130
          DO I=NOCC+1,L0
            IL = IA(I) + L
            FCOR(IL) = FCOR(IL) - BUFF(I-NOCC)
          ENDDO
C
C          ----- Coulomb contribution to derivative Lagrangian -----
C
 1130     CONTINUE
          DO 1200 I=NOCC+1,L0
            XIJKL = BUFF(I-NOCC)
            IF(ABS(XIJKL).LT.TOL) GO TO 1200
C
C               ----- Lder(j,m) where m is a core orbital index -----
C
            IF(K.LE.NCOR) THEN
              CALL DAXPY(NXYZ,XIJKL,SDER(1,I,K),1,DLAG(1,J,L),1)
              CALL DAXPY(NXYZ,XIJKL,SDER(1,J,K),1,DLAG(1,I,L),1)
              IF(K.NE.L) THEN
                CALL DAXPY(NXYZ,XIJKL,SDER(1,I,L),1,DLAG(1,J,K),1)
                CALL DAXPY(NXYZ,XIJKL,SDER(1,J,L),1,DLAG(1,I,K),1)
              ENDIF
            ENDIF
C
            DO 1140 M=1,NCOR
              DVAL = ZERO
              IF(L.GT.NCOR) DVAL = TWO*OPDM(KKLL)*XIJKL
              IF(K.EQ.L) THEN
                DVAL = HALF*DVAL
                IF(K.LE.NCOR) DVAL = TWO*XIJKL
              ENDIF
              CALL DAXPY(NXYZ,-DVAL,SDER(1,I,M),1,DLAG(1,J,M),1)
              CALL DAXPY(NXYZ,-DVAL,SDER(1,J,M),1,DLAG(1,I,M),1)
 1140       CONTINUE
C
            DO 1150 M=1,NACT
              IF((K.GT.NCOR) .AND. (L.LE.NCOR)) THEN
                MM = M+NCOR
                MG = MAX(M,K-NCOR)
                KG = MIN(M,K-NCOR)
                MK = IA(MG) + KG
                DVAL = OPDM(MK)*XIJKL
                DVAL = HALF*DVAL
                CALL DAXPY(NXYZ,DVAL,SDER(1,I,MM),1,DLAG(1,J,L),1)
                CALL DAXPY(NXYZ,DVAL,SDER(1,J,MM),1,DLAG(1,I,L),1)
              ENDIF
 1150       CONTINUE
C
C               ----- Lder(j,m) where m is an active orbital index -----
C
             DO 1180 M=1,NACT
               MM = M+NCOR
               IF((K.GT.NCOR) .AND. (L.LE.NCOR)) THEN
                 MG = MAX(M,K-NCOR)
                 KG = MIN(M,K-NCOR)
                 MK = IA(MG) + KG
                 DVAL = OPDM(MK)*XIJKL
                 DVAL = HALF*DVAL
                 CALL DAXPY(NXYZ,DVAL,SDER(1,I,L),1,DLAG(1,J,MM),1)
                 CALL DAXPY(NXYZ,DVAL,SDER(1,J,L),1,DLAG(1,I,MM),1)
               ENDIF
C
               DO 1170 N=1,NACT
                 NN = N+NCOR
                 MG = MAX(M,N)
                 NG = MIN(M,N)
                 MN = IA(MG) + NG
                 IF((K.LE.NCOR) .AND. (K.EQ.L)) THEN
                   DVAL = OPDM(MN)*XIJKL
                   CALL DAXPY(NXYZ,-DVAL,SDER(1,I,NN),1,DLAG(1,J,MM),1)
                   CALL DAXPY(NXYZ,-DVAL,SDER(1,J,NN),1,DLAG(1,I,MM),1)
                 ENDIF
                 IF(L.GT.NCOR) THEN
                   MNG = MAX(MN,KKLL)
                   KLG = MIN(MN,KKLL)
                   MNKL = IA(MNG) + KLG
                   DVAL = TPDM(MNKL)*XIJKL
                   IF(K.EQ.L) DVAL = HALF*DVAL
                   CALL DAXPY(NXYZ,-DVAL,SDER(1,I,NN),1,DLAG(1,J,MM),1)
                   CALL DAXPY(NXYZ,-DVAL,SDER(1,J,NN),1,DLAG(1,I,MM),1)
                 ENDIF
 1170          CONTINUE
 1180        CONTINUE
 1200      CONTINUE
C
C          ----- Exchange contribution to derivative Lagrangian -----
C
          DO 1400 I=NOCC+1,L0
            XIJKL = BUFF(I-NOCC)
            IF(ABS(XIJKL).LT.TOL) GO TO 1400
C
C               ----- Lder(k,m) where j or l is a core orbital -----
C
            IF(J.GT.NCOR) GO TO 1220
            IF(L.LE.NCOR) THEN
              DVAL = FOUR*XIJKL
              CALL DAXPY(NXYZ,-DVAL,SDER(1,I,J),1,DLAG(1,K,L),1)
              CALL DAXPY(NXYZ,XIJKL,SDER(1,I,L),1,DLAG(1,K,J),1)
            ENDIF
            IF((K.LE.NCOR) .AND. (K.NE.L)) THEN
              DVAL = FOUR*XIJKL
              CALL DAXPY(NXYZ,-DVAL,SDER(1,I,J),1,DLAG(1,L,K),1)
              CALL DAXPY(NXYZ,XIJKL,SDER(1,I,K),1,DLAG(1,L,J),1)
            ENDIF
C
            DO M=1,NCOR
              IF(L.EQ.J)
     *          CALL DAXPY(NXYZ,XIJKL,SDER(1,I,M),1,DLAG(1,K,M),1)
              IF((K.EQ.J) .AND. (K.NE.L))
     *          CALL DAXPY(NXYZ,XIJKL,SDER(1,I,M),1,DLAG(1,L,M),1)
            ENDDO
C
            DO 1210 M=1,NACT
              MM = M+NCOR
              IF(L.GT.NCOR) THEN
                MG = MAX(M,L-NCOR)
                LG = MIN(M,L-NCOR)
                ML = IA(MG) + LG
                DVAL = OPDM(ML)*XIJKL
                DVAL = HALF*DVAL
                CALL DAXPY(NXYZ,DVAL,SDER(1,I,MM),1,DLAG(1,K,J),1)
                DVAL = FOUR*DVAL
                CALL DAXPY(NXYZ,-DVAL,SDER(1,I,J),1,DLAG(1,K,MM),1)
              ENDIF
              IF((K.GT.NCOR) .AND. (K.NE.L)) THEN
                MG = MAX(M,K-NCOR)
                KG = MIN(M,K-NCOR)
                MK = IA(MG) + KG
                DVAL = OPDM(MK)*XIJKL
                DVAL = HALF*DVAL
                CALL DAXPY(NXYZ,DVAL,SDER(1,I,MM),1,DLAG(1,L,J),1)
                DVAL = FOUR*DVAL
                CALL DAXPY(NXYZ,-DVAL,SDER(1,I,J),1,DLAG(1,L,MM),1)
              ENDIF
C
              DO 1210 N=1,NACT
                NN = N+NCOR
                MG = MAX(M,N)
                NG = MIN(M,N)
                MN = IA(MG) + NG
                DVAL = OPDM(MN)*XIJKL
                DVAL = HALF*DVAL
                IF(L.EQ.J)
     *            CALL DAXPY(NXYZ,DVAL,SDER(1,I,MM),1,DLAG(1,K,NN),1)
                IF((K.EQ.J) .AND. (K.NE.L))
     *            CALL DAXPY(NXYZ,DVAL,SDER(1,I,MM),1,DLAG(1,L,NN),1)
 1210       CONTINUE
C
 1220       IF(L.GT.NCOR) GO TO 1260
            IF(J.LE.NCOR) THEN
              DVAL = FOUR*XIJKL
              CALL DAXPY(NXYZ,-DVAL,SDER(1,K,L),1,DLAG(1,I,J),1)
              CALL DAXPY(NXYZ,XIJKL,SDER(1,K,J),1,DLAG(1,I,L),1)
            ENDIF
C
            DO M=1,NCOR
              IF(J.EQ.L)
     *          CALL DAXPY(NXYZ,XIJKL,SDER(1,K,M),1,DLAG(1,I,M),1)
            ENDDO
C
            DO 1230 M=1,NACT
              MM = M+NCOR
              IF(J.GT.NCOR) THEN
                MG = MAX(M,J-NCOR)
                JG = MIN(M,J-NCOR)
                MJ = IA(MG) + JG
                DVAL = OPDM(MJ)*XIJKL
                DVAL = HALF*DVAL
                CALL DAXPY(NXYZ,DVAL,SDER(1,K,MM),1,DLAG(1,I,L),1)
                DVAL = FOUR*DVAL
                CALL DAXPY(NXYZ,-DVAL,SDER(1,K,L),1,DLAG(1,I,MM),1)
              ENDIF
C
              DO 1230 N=1,NACT
                NN = N+NCOR
                MG = MAX(M,N)
                NG = MIN(M,N)
                MN = IA(MG) + NG
                DVAL = OPDM(MN)*XIJKL
                DVAL = HALF*DVAL
                IF(J.EQ.L)
     *            CALL DAXPY(NXYZ,DVAL,SDER(1,K,MM),1,DLAG(1,I,NN),1)
 1230       CONTINUE
C
            IF((K.GT.NCOR) .OR. (K.EQ.L)) GO TO 1260
C
            IF(J.LE.NCOR) THEN
              DVAL = FOUR*XIJKL
              CALL DAXPY(NXYZ,-DVAL,SDER(1,L,K),1,DLAG(1,I,J),1)
              CALL DAXPY(NXYZ,XIJKL,SDER(1,L,J),1,DLAG(1,I,K),1)
            ENDIF
C
            DO M=1,NCOR
              IF(J.EQ.K)
     *          CALL DAXPY(NXYZ,XIJKL,SDER(1,L,M),1,DLAG(1,I,M),1)
            ENDDO
C
            DO 1250 M=1,NACT
              MM = M+NCOR
              IF(J.GT.NCOR) THEN
                MG = MAX(M,J-NCOR)
                JG = MIN(M,J-NCOR)
                MJ = IA(MG) + JG
                DVAL = OPDM(MJ)*XIJKL
                DVAL = HALF*DVAL
                CALL DAXPY(NXYZ,DVAL,SDER(1,L,MM),1,DLAG(1,I,K),1)
                DVAL = FOUR*DVAL
                CALL DAXPY(NXYZ,-DVAL,SDER(1,L,K),1,DLAG(1,I,MM),1)
              ENDIF
C
              DO 1250 N=1,NACT
                NN = N+NCOR
                MG = MAX(M,N)
                NG = MIN(M,N)
                MN = IA(MG) + NG
                DVAL = OPDM(MN)*XIJKL
                DVAL = HALF*DVAL
                IF(J.EQ.K)
     *            CALL DAXPY(NXYZ,DVAL,SDER(1,L,MM),1,DLAG(1,I,NN),1)
 1250       CONTINUE
C
C               ----- Lder(k,m) where j or l is an active orbital -----
C
 1260       IF(J.LE.NCOR) GO TO 1280
            DO M=1,NCOR
              IF(L.GT.NCOR) THEN
                JG = MAX(J-NCOR,L-NCOR)
                LG = MIN(J-NCOR,L-NCOR)
                JL = IA(JG) + LG
                DVAL = OPDM(JL)*XIJKL
                DVAL = HALF*DVAL
                CALL DAXPY(NXYZ,DVAL,SDER(1,I,M),1,DLAG(1,K,M),1)
              ENDIF
              IF((K.GT.NCOR) .AND. (K.NE.L)) THEN
                JG = MAX(J-NCOR,K-NCOR)
                KG = MIN(J-NCOR,K-NCOR)
                JK = IA(JG) + KG
                DVAL = OPDM(JK)*XIJKL
                DVAL = HALF*DVAL
                CALL DAXPY(NXYZ,DVAL,SDER(1,I,M),1,DLAG(1,L,M),1)
              ENDIF
            ENDDO
C
            DO 1270 M=1,NACT
              MM = M+NCOR
              JG = MAX(J-NCOR,M)
              MG = MIN(J-NCOR,M)
              JM = IA(JG) + MG
              DVAL = OPDM(JM)*XIJKL
              DVAL = HALF*DVAL
              IF(L.LE.NCOR) THEN
                CALL DAXPY(NXYZ,DVAL,SDER(1,I,L),1,DLAG(1,K,MM),1)
                DLT = FOUR*DVAL
                CALL DAXPY(NXYZ,-DLT,SDER(1,I,MM),1,DLAG(1,K,L),1)
              ENDIF
              IF((K.LE.NCOR) .AND. (K.NE.L)) THEN
                CALL DAXPY(NXYZ,DVAL,SDER(1,I,K),1,DLAG(1,L,MM),1)
                DLT = FOUR*DVAL
                CALL DAXPY(NXYZ,-DLT,SDER(1,I,MM),1,DLAG(1,L,K),1)
              ENDIF
C
              DO N=1,NACT
                NN = N+NCOR
                IF(L.GT.NCOR) THEN
                  NG = MAX(N,L-NCOR)
                  LG = MIN(N,L-NCOR)
                  NL = IA(NG) + LG
                  JMG = MAX(JM,NL)
                  NLG = MIN(JM,NL)
                  JMNL = IA(JMG) + NLG
                  DVAL = TPDM(JMNL)*XIJKL
                  CALL DAXPY(NXYZ,-DVAL,SDER(1,I,MM),1,DLAG(1,K,NN),1)
                ENDIF
                IF((K.GT.NCOR) .AND. (K.NE.L)) THEN
                  NG = MAX(N,K-NCOR)
                  KG = MIN(N,K-NCOR)
                  NK = IA(NG) + KG
                  JMG = MAX(JM,NK)
                  NKG = MIN(JM,NK)
                  JMNK = IA(JMG) + NKG
                  DVAL = TPDM(JMNK)*XIJKL
                  CALL DAXPY(NXYZ,-DVAL,SDER(1,I,MM),1,DLAG(1,L,NN),1)
                ENDIF
              ENDDO
 1270       CONTINUE
C
 1280       IF(L.LE.NCOR) GO TO 1300
            DO M=1,NCOR
              IF(J.GT.NCOR) THEN
                JG = MAX(J-NCOR,L-NCOR)
                LG = MIN(J-NCOR,L-NCOR)
                JL = IA(JG) + LG
                DVAL = OPDM(JL)*XIJKL
                DVAL = HALF*DVAL
                CALL DAXPY(NXYZ,DVAL,SDER(1,K,M),1,DLAG(1,I,M),1)
              ENDIF
            ENDDO
C
            DO 1290 M=1,NACT
              MM = M+NCOR
              LG = MAX(L-NCOR,M)
              MG = MIN(L-NCOR,M)
              LM = IA(LG) + MG
              DVAL = OPDM(LM)*XIJKL
              DVAL = HALF*DVAL
              IF(J.LE.NCOR) THEN
                CALL DAXPY(NXYZ,DVAL,SDER(1,K,J),1,DLAG(1,I,MM),1)
                DVAL = FOUR*DVAL
                CALL DAXPY(NXYZ,-DVAL,SDER(1,K,MM),1,DLAG(1,I,J),1)
              ENDIF
C
              DO N=1,NACT
                NN = N+NCOR
                IF(J.GT.NCOR) THEN
                  NG = MAX(N,J-NCOR)
                  JG = MIN(N,J-NCOR)
                  NJ = IA(NG) + JG
                  LMG = MAX(LM,NJ)
                  NJG = MIN(LM,NJ)
                  LMNJ = IA(LMG) + NJG
                  DVAL = TPDM(LMNJ)*XIJKL
                  CALL DAXPY(NXYZ,-DVAL,SDER(1,K,MM),1,DLAG(1,I,NN),1)
                ENDIF
              ENDDO
 1290       CONTINUE
C
 1300       IF((K.LE.NCOR) .OR. (K.EQ.L)) GO TO 1400
            DO M=1,NCOR
              IF(J.GT.NCOR) THEN
                JG = MAX(J-NCOR,K-NCOR)
                KG = MIN(J-NCOR,K-NCOR)
                JK = IA(JG) + KG
                DVAL = OPDM(JK)*XIJKL
                DVAL = HALF*DVAL
                CALL DAXPY(NXYZ,DVAL,SDER(1,L,M),1,DLAG(1,I,M),1)
              ENDIF
            ENDDO
C
            DO 1310 M=1,NACT
              MM = M+NCOR
              KG = MAX(K-NCOR,M)
              MG = MIN(K-NCOR,M)
              KM = IA(KG) + MG
              DVAL = OPDM(KM)*XIJKL
              DVAL = HALF*DVAL
              IF(J.LE.NCOR) THEN
                CALL DAXPY(NXYZ,DVAL,SDER(1,L,J),1,DLAG(1,I,MM),1)
                DVAL = FOUR*DVAL
                CALL DAXPY(NXYZ,-DVAL,SDER(1,L,MM),1,DLAG(1,I,J),1)
              ENDIF
C
              DO N=1,NACT
                NN = N+NCOR
                IF(J.GT.NCOR) THEN
                  NG = MAX(N,J-NCOR)
                  JG = MIN(N,J-NCOR)
                  NJ = IA(NG) + JG
                  KMG = MAX(KM,NJ)
                  NJG = MIN(KM,NJ)
                  KMNJ = IA(KMG) + NJG
                  DVAL = TPDM(KMNJ)*XIJKL
                  CALL DAXPY(NXYZ,-DVAL,SDER(1,L,MM),1,DLAG(1,I,NN),1)
                ENDIF
              ENDDO
 1310       CONTINUE
 1400     CONTINUE
C
C          ----- Construct two-electron integral array -----
C
          IF(J.LE.NCOR) GO TO 1500
          IF((K.LE.NCOR) .OR. (L.LE.NCOR)) GO TO 1500
          JJ = J-NCOR
          DO I=NOCC+1,L0
            ERI(I,JJ,KKLL) = BUFF(I-NOCC)
          ENDDO
C
C          ----- Construct A matrix -----
C
 1500     IF(J.GT.NCOR) GO TO 1550
          IF((K.LE.NCOR) .OR. (L.LE.NCOR)) GO TO 1550
          DO I=NOCC+1,L0
            AMAT(I,J,KKLL) = AMAT(I,J,KKLL) + FOUR*BUFF(I-NOCC)
          ENDDO
C
 1550     IF(J.LE.NCOR) GO TO 1600
          IF((K.LE.NCOR) .OR. (L.GT.NCOR)) GO TO 1600
          JJ = J-NCOR
          KK = K-NCOR
          JG = MAX(JJ,KK)
          KG = MIN(JJ,KK)
          JK = IA(JG) + KG
          DO I=NOCC+1,L0
            DVAL = BUFF(I-NOCC)
            IF(J.GE.K) AMAT(I,L,JK) = AMAT(I,L,JK) - DVAL
            IF(K.GE.J) AMAT(I,L,JK) = AMAT(I,L,JK) - DVAL
          ENDDO
C
C          ----- Finished with current integral buffer -----
C
 1600     CALL DDI_PROCDLB_NEXT(C_VOOO,IWP,ICNTR2)
C
        ENDDO
        CALL TSECND(T1)
        IF(IWP.EQ.ME  .AND.  MASWRK) WRITE(IW,9010) T1-T0
        CALL FLSHBF(IW)
        T0 = T1
C
C     ----- Get and use (VV|OO) integrals -----
C
        CALL DDI_DISTRIB(D_VVOO,IWP,ILO,IHI,JLO,JHI)
        MAXWRK = JHI-JLO+1
C
        CALL DDI_PROCDLB_NEXT(C_VVOO,IWP,ICNTR3)
C
        DO WHILE(ICNTR3.LT.MAXWRK)
          KL = JLO + ICNTR3
C
          DO KK=1,NOCC
            DO LL=1,KK
              KLTMP = IA(KK) + LL
              IF(KL.EQ.KLTMP) THEN
                K = KK
                L = LL
                GO TO 2010
              END IF
            ENDDO
          ENDDO
C
 2010     CALL DDI_GET(D_VVOO,1,NBTR,KL,KL,BUFF)
C
C          ----- Construct core Fock matrix -----
C
          IF((K.NE.L) .OR. (K.GT.NCOR)) GO TO 2030
          DO 2020 I=1,NVIR
            II = I + NOCC
            DO 2020 J=1,I
              JJ = J + NOCC
              IIJJ = IA(II) + JJ
              IJ = IA(I) + J
              FCOR(IIJJ) = FCOR(IIJJ) + TWO*BUFF(IJ)
 2020     CONTINUE
C
C          ----- Coulomb contribution to derivative Lagrangian -----
C
 2030     IF(L.GT.NCOR) KKLL = IA(K-NCOR) + L-NCOR
          DO 2100 I=1,NVIR
            II = I+NOCC
            DO 2100 J=1,I
              JJ = J+NOCC
              IJ = IA(I) + J
              XIJKL = BUFF(IJ)
              IF(ABS(XIJKL).LT.TOL) GO TO 2100
              IJVAL = .TRUE.
              IF(I.EQ.J) IJVAL = .FALSE.
C
C               ----- K and L are core indices -----
C
              IF(K.LE.NCOR) THEN
                CALL DAXPY(NXYZ,XIJKL,SDER(1,II,K),1,DLAG(1,JJ,L),1)
                IF(IJVAL) CALL DAXPY(NXYZ,XIJKL,SDER(1,JJ,K),1,
     *                               DLAG(1,II,L),1)
C
                IF(K.NE.L) THEN
                  CALL DAXPY(NXYZ,XIJKL,SDER(1,II,L),1,DLAG(1,JJ,K),1)
                  IF(IJVAL) CALL DAXPY(NXYZ,XIJKL,SDER(1,JJ,L),1,
     *                                 DLAG(1,II,K),1)
                ENDIF
C
                IF(K.EQ.L) THEN
                  DVAL = TWO*XIJKL
                  DO M=1,NCOR
                    CALL DAXPY(NXYZ,-DVAL,SDER(1,II,M),1,DLAG(1,JJ,M),1)
                    IF(IJVAL) CALL DAXPY(NXYZ,-DVAL,SDER(1,JJ,M),1,
     *                                   DLAG(1,II,M),1)
                  ENDDO
C
                  DO 2040 M=1,NACT
                    MM = M+NCOR
                    DO 2040 N=1,NACT
                      NN = N+NCOR
                      MG = MAX(M,N)
                      NG = MIN(M,N)
                      MN = IA(MG) + NG
                      DVAL = OPDM(MN)*XIJKL
                      CALL DAXPY(NXYZ,-DVAL,SDER(1,II,MM),1,
     *                           DLAG(1,JJ,NN),1)
                      IF(IJVAL) CALL DAXPY(NXYZ,-DVAL,SDER(1,JJ,MM),1,
     *                                     DLAG(1,II,NN),1)
 2040             CONTINUE
                ENDIF
                GO TO 2100
              ENDIF
C
C               ----- K is active, L is core -----
C
              IF(L.LE.NCOR) THEN
                DO M=1,NACT
                  MM = M+NCOR
                  MG = MAX(M,K-NCOR)
                  KG = MIN(M,K-NCOR)
                  MK = IA(MG) + KG
                  DVAL = OPDM(MK)*XIJKL
                  DVAL = HALF*DVAL
                  CALL DAXPY(NXYZ,DVAL,SDER(1,II,MM),1,DLAG(1,JJ,L),1)
                  IF(IJVAL) CALL DAXPY(NXYZ,DVAL,SDER(1,JJ,MM),1,
     *                                 DLAG(1,II,L),1)
C
                  CALL DAXPY(NXYZ,DVAL,SDER(1,II,L),1,DLAG(1,JJ,MM),1)
                  IF(IJVAL) CALL DAXPY(NXYZ,DVAL,SDER(1,JJ,L),1,
     *                                 DLAG(1,II,MM),1)
                ENDDO
                GO TO 2100
              ENDIF
C
C               ----- K and L are active indicies -----
C
               DVAL = OPDM(KKLL)*XIJKL
               IF(K.NE.L) DVAL = TWO*DVAL
               DO M=1,NCOR
                 CALL DAXPY(NXYZ,-DVAL,SDER(1,II,M),1,DLAG(1,JJ,M),1)
                 IF(IJVAL) CALL DAXPY(NXYZ,-DVAL,SDER(1,JJ,M),1,
     *                                DLAG(1,II,M),1)
               ENDDO
C
               DO 2050 M=1,NACT
                 MM = M+NCOR
                 DO 2050 N=1,NACT
                   NN = N+NCOR
                   MG = MAX(M,N)
                   NG = MIN(M,N)
                   MN = IA(MG) + NG
                   MNG = MAX(MN,KKLL)
                   KLG = MIN(MN,KKLL)
                   MNKL = IA(MNG) + KLG
                   DVAL = TPDM(MNKL)*XIJKL
                   IF(K.EQ.L) DVAL = HALF*DVAL
                   CALL DAXPY(NXYZ,-DVAL,SDER(1,II,MM),1,
     *                        DLAG(1,JJ,NN),1)
                   IF(IJVAL) CALL DAXPY(NXYZ,-DVAL,SDER(1,JJ,MM),1,
     *                                  DLAG(1,II,NN),1)
 2050          CONTINUE
 2100     CONTINUE
C
C          ----- Coulomb contribution to preconditioner -----
C
          DO 2300 I=1,NVIR
            II = I+NOCC
            IJ = IA(I) + I
            XIJKL = BUFF(IJ)
            IF(ABS(XIJKL).LT.TOL) GO TO 2300
C
            IF((K.GT.NCOR) .OR. (K.NE.L)) GO TO 2200
            DO 2120 M=1,NCOR
              IMG = IABS(INDEX(II,M))
              IF(IMG.EQ.0) GO TO 2120
              DVAL = FOUR*XIJKL
              IF(M.EQ.K) DVAL = HALF*DVAL
              PRCNDO(IMG) = PRCNDO(IMG) + DVAL
 2120       CONTINUE
C
            DO 2130 M=1,NACT
              IMG = IABS(INDEX(II,M+NCOR))
              IF(IMG.EQ.0) GO TO 2130
              MM = IA(M) + M
              DVAL = OPDM(MM)*XIJKL
              PRCNDO(IMG) = PRCNDO(IMG) + TWO*DVAL
 2130       CONTINUE
C
 2200       IF(L.LE.NCOR) GO TO 2300
C
            DO 2220 M=1,NCOR
              IMG = IABS(INDEX(II,M))
              IF(IMG.EQ.0) GO TO 2220
              DVAL = OPDM(KKLL)*XIJKL
              IF(K.NE.L) DVAL = TWO*DVAL
              PRCNDO(IMG) = PRCNDO(IMG) + TWO*DVAL
 2220       CONTINUE
C
            DO 2230 M=1,NACT
              IMG = IABS(INDEX(II,M+NCOR))
              IF(IMG.EQ.0) GO TO 2230
              MM = IA(M) + M
              MMG = MAX(MM,KKLL)
              KLG = MIN(MM,KKLL)
              MMKL = IA(MMG) + KLG
              DVAL = TPDM(MMKL)*XIJKL
              IF(K.NE.L) DVAL = TWO*DVAL
              PRCNDO(IMG) = PRCNDO(IMG) + DVAL
 2230       CONTINUE
 2300     CONTINUE
C
C          ----- Finished with current integral buffer -----
C
          CALL DDI_PROCDLB_NEXT(C_VVOO,IWP,ICNTR3)
C
        ENDDO
        CALL TSECND(T1)
        IF(IWP.EQ.ME  .AND.  MASWRK) WRITE(IW,9020) T1-T0
        CALL FLSHBF(IW)
        T0 = T1
C
C     ----- Get and use (VO|VO) integrals -----
C
        CALL DDI_DISTRIB(D_VOVO,IWP,ILO,IHI,JLO,JHI)
        MAXWRK = JHI-JLO+1
C
        CALL DDI_PROCDLB_NEXT(C_VOVO,IWP,ICNTR4)
C
        DO WHILE(ICNTR4.LT.MAXWRK)
          JL = JLO + ICNTR4
C
          DO JJ=1,NOCC
            DO LL=1,JJ
              JLTMP = IA(JJ) + LL
              IF(JL.EQ.JLTMP) THEN
                J = JJ
                L = LL
                GO TO 3010
              END IF
            ENDDO
          ENDDO
C
 3010     CALL DDI_GET(D_VOVO,1,NBSQ,JL,JL,BUFF)
C
C          ----- Construct core Fock matrix -----
C
          IF((J.NE.L) .OR. (J.GT.NCOR)) GO TO 3030
          DO 3020 I=1,NVIR
            II = I + NOCC
            DO 3020 K=1,I
              KK = K + NOCC
              IIKK = IA(II) + KK
              IK = (I-1)*NVIR + K
              FCOR(IIKK) = FCOR(IIKK) - BUFF(IK)
 3020     CONTINUE
C
C          ----- Exchange contribution to derivative Lagrangian -----
C
 3030     IF(J.GT.NCOR) GO TO 3130
          IF(J.EQ.L) THEN
            DO 3050 I=1,NVIR
              II = I+NOCC
              DO 3050 K=1,NVIR
                KK = K+NOCC
                KI = (K-1)*NVIR + I
                XKJIL = BUFF(KI)
                IF(ABS(XKJIL).LT.TOL) GO TO 3050
                DO M=1,NCOR
                  CALL DAXPY(NXYZ,XKJIL,SDER(1,II,M),1,DLAG(1,KK,M),1)
                ENDDO
C
                DO 3040 M=1,NACT
                  MM = M+NCOR
                  DO 3040 N=1,NACT
                   NN = N+NCOR
                   MG = MAX(M,N)
                   NG = MIN(M,N)
                   MN = IA(MG) + NG
                   DVAL = OPDM(MN)*XKJIL
                   DVAL = HALF*DVAL
                   CALL DAXPY(NXYZ,DVAL,SDER(1,II,MM),1,DLAG(1,KK,NN),1)
 3040           CONTINUE
 3050       CONTINUE
          ENDIF
C
          DO 3060 I=1,NVIR
            II = I+NOCC
            DO 3060 K=1,NVIR
              KK = K+NOCC
              IK = (I-1)*NVIR + K
              KI = (K-1)*NVIR + I
              DVAL = BUFF(KI) - FOUR*BUFF(IK)
              CALL DAXPY(NXYZ,DVAL,SDER(1,II,L),1,DLAG(1,KK,J),1)
              IF(J.EQ.L) GO TO 3060
              DVAL = BUFF(IK) - FOUR*BUFF(KI)
              CALL DAXPY(NXYZ,DVAL,SDER(1,II,J),1,DLAG(1,KK,L),1)
 3060     CONTINUE
          GO TO 3400
C
 3130     IF(L.GT.NCOR) GO TO 3230
          DO 3150 I=1,NVIR
            II = I+NOCC
            DO 3150 K=1,NVIR
              KK = K+NOCC
              KI = (K-1)*NVIR + I
              XKJIL = BUFF(KI)
              IF(ABS(XKJIL).LT.TOL) GO TO 3140
              DO M=1,NACT
                MM = M+NCOR
                MG = MAX(M,J-NCOR)
                JG = MIN(M,J-NCOR)
                MJ = IA(MG) + JG
                DVAL = OPDM(MJ)*XKJIL
                DVAL = HALF*DVAL
                CALL DAXPY(NXYZ,DVAL,SDER(1,II,L),1,DLAG(1,KK,MM),1)
                DVAL = FOUR*DVAL
                CALL DAXPY(NXYZ,-DVAL,SDER(1,II,MM),1,DLAG(1,KK,L),1)
              ENDDO
C
 3140         IK = (I-1)*NVIR + K
              XIJKL = BUFF(IK)
              IF(ABS(XIJKL).LT.TOL) GO TO 3150
              DO M=1,NACT
                MM = M+NCOR
                MG = MAX(M,J-NCOR)
                JG = MIN(M,J-NCOR)
                MJ = IA(MG) + JG
                DVAL = OPDM(MJ)*XIJKL
                DVAL = HALF*DVAL
                CALL DAXPY(NXYZ,DVAL,SDER(1,II,MM),1,DLAG(1,KK,L),1)
                DVAL = FOUR*DVAL
                CALL DAXPY(NXYZ,-DVAL,SDER(1,II,L),1,DLAG(1,KK,MM),1)
              ENDDO
 3150     CONTINUE
          GO TO 3400
C
 3230    JL = IA(J-NCOR) + L-NCOR
         DO 3300 I=1,NVIR
           II = I+NOCC
           DO 3300 K=1,NVIR
             KK = K+NOCC
             KI = (K-1)*NVIR + I
             XKJIL = BUFF(KI)
             IF(ABS(XKJIL).LT.TOL) GO TO 3270
             DO M=1,NCOR
               DVAL = OPDM(JL)*XKJIL
               DVAL = HALF*DVAL
               CALL DAXPY(NXYZ,DVAL,SDER(1,II,M),1,DLAG(1,KK,M),1)
             ENDDO
C
             DO 3250 M=1,NACT
               MM = M+NCOR
               MG = MAX(M,J-NCOR)
               JG = MIN(M,J-NCOR)
               MJ = IA(MG) + JG
               DO 3250 N=1,NACT
                 NN = N+NCOR
                 NG = MAX(N,L-NCOR)
                 LG = MIN(N,L-NCOR)
                 NL = IA(NG) + LG
                 MJG = MAX(MJ,NL)
                 NLG = MIN(MJ,NL)
                 MJNL = IA(MJG) + NLG
                 DVAL = TPDM(MJNL)*XKJIL
                 CALL DAXPY(NXYZ,-DVAL,SDER(1,II,MM),1,DLAG(1,KK,NN),1)
 3250        CONTINUE
C
 3270        IF(J.EQ.L) GO TO 3300
             IK = (I-1)*NVIR + K
             XIJKL = BUFF(IK)
             IF(ABS(XIJKL).LT.TOL) GO TO 3300
             DO M=1,NCOR
               DVAL = OPDM(JL)*XIJKL
               DVAL = HALF*DVAL
               CALL DAXPY(NXYZ,DVAL,SDER(1,II,M),1,DLAG(1,KK,M),1)
             ENDDO
C
             DO 3290 M=1,NACT
               MM = M+NCOR
               MG = MAX(M,L-NCOR)
               LG = MIN(M,L-NCOR)
               ML = IA(MG) + LG
               DO 3290 N=1,NACT
                 NN = N+NCOR
                 NG = MAX(N,J-NCOR)
                 JG = MIN(N,J-NCOR)
                 NJ = IA(NG) + JG
                 MLG = MAX(ML,NJ)
                 NJG = MIN(ML,NJ)
                 MLNJ = IA(MLG) + NJG
                 DVAL = TPDM(MLNJ)*XIJKL
                 CALL DAXPY(NXYZ,-DVAL,SDER(1,II,MM),1,DLAG(1,KK,NN),1)
 3290        CONTINUE
 3300    CONTINUE
C
C          ----- Exchange contribution to preconditioner -----
C
 3400    CONTINUE
         DO 3600 I=1,NVIR
           II = I+NOCC
           IK = (I-1)*NVIR + I
           XIJKL = BUFF(IK)
           IF(ABS(XIJKL).LT.TOL) GO TO 3600
C
           IF((J.GT.NCOR) .OR. (J.NE.L)) GO TO 3500
           DO 3420 M=1,NCOR
             IMG = IABS(INDEX(II,M))
             IF(IMG.EQ.0) GO TO 3420
             DVAL = -TWO*XIJKL
             IF(M.EQ.J) DVAL = -TWO*DVAL
             PRCNDO(IMG) = PRCNDO(IMG) + DVAL
 3420      CONTINUE
C
           DO 3430 M=1,NACT
             IMG = IABS(INDEX(II,M+NCOR))
             IF(IMG.EQ.0) GO TO 3430
             MM = IA(M) + M
             PRCNDO(IMG) = PRCNDO(IMG) - OPDM(MM)*XIJKL
 3430      CONTINUE
C
 3500      IF(L.LE.NCOR) GO TO 3600
C
           DO 3520 M=1,NCOR
             IMG = IABS(INDEX(II,M))
             IF(IMG.EQ.0) GO TO 3520
             DVAL = OPDM(JL)*XIJKL
             IF(J.NE.L) DVAL = TWO*DVAL
             PRCNDO(IMG) = PRCNDO(IMG) - DVAL
 3520      CONTINUE
C
           DO 3530 M=1,NACT
             IMG = IABS(INDEX(II,M+NCOR))
             IF(IMG.EQ.0) GO TO 3530
             MG = MAX(M,J-NCOR)
             JG = MIN(M,J-NCOR)
             MJ = IA(MG) + JG
             MG = MAX(M,L-NCOR)
             LG = MIN(M,L-NCOR)
             ML = IA(MG) + LG
             MJG = MAX(MJ,ML)
             MLG = MIN(MJ,ML)
             MJML = IA(MJG) + MLG
             DVAL = TPDM(MJML)*XIJKL
             IF(J.NE.L) DVAL = TWO*DVAL
             PRCNDO(IMG) = PRCNDO(IMG) + TWO*DVAL
 3530      CONTINUE
 3600    CONTINUE
C
C          ----- Finished with current integral buffer -----
C
          CALL DDI_PROCDLB_NEXT(C_VOVO,IWP,ICNTR4)
C
        ENDDO
        CALL TSECND(T1)
        IF(IWP.EQ.ME  .AND.  MASWRK) WRITE(IW,9030) T1-T0
        CALL FLSHBF(IW)
        T0 = T1
C
 8000 CONTINUE
C
      CALL DDI_GSUMF(2160,DFC,L2*NXYZ)
      CALL DDI_GSUMF(2161,DERI,N4*NXYZ)
      CALL DDI_GSUMF(2162,DLAG,L3*NXYZ)
      CALL DDI_GSUMF(2163,FCOR,L2)
      CALL DDI_GSUMF(2164,ERI,L1*N2*NACT)
      CALL DDI_GSUMF(2165,PRCNDO,NROT)
      CALL DDI_GSUMF(2166,AMAT,L1*NCOR*N2)
C
 9000 FORMAT(/1X,'MASTER NODE HAS FINISHED WITH (OO|OO) INTEGRALS,',
     *           ' T=',F7.1)
 9010 FORMAT(1X,'MASTER NODE HAS FINISHED WITH (VO|OO) INTEGRALS,',
     *           ' T=',F7.1)
 9020 FORMAT(1X,'MASTER NODE HAS FINISHED WITH (VV|OO) INTEGRALS,',
     *           ' T=',F7.1)
 9030 FORMAT(1X,'MASTER NODE HAS FINISHED WITH (VO|VO) INTEGRALS,',
     *           ' T=',F7.1)
      RETURN
      END
C*MODULE CPMCHF  *DECK POSCP
C     -------------------------------------------
      INTEGER FUNCTION POSCP(NACT,NOEL,CON,IFA)
C     -------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      INTEGER CON(NOEL),POS1,I,J
      DIMENSION IFA(0:NACT,0:NACT)
C
C     This function is the same as POSDET in ALDECI
C
      POS1 = 0
      POSCP = 1
      DO 33 I=1,NOEL
         DO 55 J=POS1+1,CON(I)-1
            POSCP = POSCP + IFA(NACT-J,NOEL-I)
   55    CONTINUE
         POS1 = CON(I)
   33 CONTINUE
C
      RETURN
      END
C*MODULE CPMCHF  *DECK RET1CP
C     --------------------------------------------------------
      SUBROUTINE RET1CP(IBCON1,IBCON2,NB,IB,JJ,NCOR,KKJ,IPER)
C     --------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION IBCON1(*),IBCON2(*)
C
C     This routine is the same as RET1DET in ALDECI
C
      IF (JJ.LT.IBCON1(IB)) THEN
         DO 870 KI=1,KKJ-1
               IBCON2(KI) = IBCON1(KI+NCOR)-NCOR
  870    CONTINUE
         IBCON2(KKJ) = JJ-NCOR
         IPR = KKJ
         DO 875 KI=KKJ,NB
              IF (KI+NCOR.EQ.IB) GOTO 875
            IPR = IPR+1
            IBCON2(IPR) = IBCON1(KI+NCOR)-NCOR
  875    CONTINUE
         IPER = IB-KKJ-NCOR
      ELSE
         IPR = 0
         DO 880 KI=1,KKJ-1
            IF (KI+NCOR.EQ.IB) GOTO 880
              IPR = IPR + 1
              IBCON2(IPR) = IBCON1(KI+NCOR)-NCOR
  880    CONTINUE
            IBCON2(KKJ-1) = JJ-NCOR
            DO 885 KI=KKJ,NB
                 IBCON2(KI) = IBCON1(KI+NCOR)-NCOR
  885       CONTINUE
            IPER = KKJ-1-IB+NCOR
      ENDIF
C
      RETURN
      END
C*MODULE CPMCHF  *DECK UAFCM
      SUBROUTINE UAFCM(FCM,DDM,YAO,YAC,DDEN,WAXO,WAXC,SDER,CI,EG,OPDM,
     *                 VEC,DIPAO,DIPMO,WRK,INDEX,NOCP,IA,L0,L1,L2,NXYZ,
     *                 NUNIQ,NROT,NDETLN,NCOR,NACT,NNACT,JLO,JHI,NFT18,
     *                 NFT19)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,SVDSKW
C
      DIMENSION FCM(NXYZ,NXYZ),DDM(3*NXYZ),YAO(NUNIQ,NROT),
     *          YAC(NUNIQ,NDETLN),DDEN(NUNIQ,NNACT),WAXO(NROT),
     *          WAXC(NDETLN),SDER(NXYZ,L1,L1),CI(*),EG(NXYZ),
     *          OPDM(*),VEC(L1,L1),DIPAO(*),DIPMO(*),WRK(*)
      DIMENSION INDEX(L1,L1),NOCP(NXYZ),IA(*)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IJKT,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (ZERO=0.0D+00,ONE=1.0D+00,TWO=2.0D+00,FOUR=4.0D+00)
      PARAMETER (TOL=1.0D-09)
C
      L3 = L1*L1
      NOCC = NCOR + NACT
      SVDSKW = DSKWRK
      DSKWRK = .FALSE.
      CALL SEQREW(NFT18)
C
C     ----- Add orbital perturbation to force constant matrix -----
C
      DO 100 IXYZ=1,NXYZ
        CALL SQREAD(NFT18,WRK,L3)
        CALL VCLR(WAXO,1,NROT)
C
        DO 50 J=1,NOCC
          DO 50 I=1,L1
            IJ = (J-1)*L1 + I
            IPHSE = INDEX(I,J)
            IROT = IABS(IPHSE)
            IF(IROT.EQ.0) GO TO 50
            DLT = IROT
            DLT = DLT/IPHSE
            WAXO(IROT) = WAXO(IROT) + DLT*WRK(IJ)
   50   CONTINUE
        CALL DSCAL(NROT,TWO,WAXO,1)
C
        JUNIQ = 0
        DO 80 JXYZ=1,NXYZ
          NJXYZ = NOCP(JXYZ)
          IF(NJXYZ.NE.1) JUNIQ = JUNIQ + 1
C
          DVAL = DDOT(L3,WRK,1,SDER(JXYZ,1,1),NXYZ)
          DVAL = -DVAL
          IF(NJXYZ.EQ.0) THEN
            DVAL = DVAL + DDOT(NROT,YAO(JUNIQ,1),NUNIQ,WAXO,1)
          ENDIF
          FCM(IXYZ,JXYZ) = FCM(IXYZ,JXYZ) + DVAL
   80   CONTINUE
  100 CONTINUE
C
C     ----- Add config. perturbation to force constant matrix -----
C
      IF(GOPARR) CALL DSCAL(NXYZ*NXYZ,ONE/NPROC,FCM,1)
C
      DSKWRK = .TRUE.
      CALL SEQREW(NFT19)
C
      DO 200 IXYZ=1,NXYZ
        CALL SQREAD(NFT19,WAXC,NDETLN)
        CALL DSCAL(NDETLN,TWO,WAXC,1)
C
        JUNIQ = 0
        DO 180 JXYZ=1,NXYZ
          NJXYZ = NOCP(JXYZ)
          IF(NJXYZ.EQ.1) GO TO 180
          JUNIQ = JUNIQ + 1
C
          DO 160 M=JLO,JHI
            MM = M-JLO+1
            YVAL = YAC(JUNIQ,MM)
            IF(ABS(YVAL).LT.TOL) GO TO 160
            CVAL = FOUR*CI(M)
C
            DVAL = YVAL*WAXC(MM)
            DVAL = DVAL - CVAL*YVAL*EG(IXYZ)
            FCM(IXYZ,JXYZ) = FCM(IXYZ,JXYZ) + DVAL
  160     CONTINUE
  180   CONTINUE
  200 CONTINUE
C
      IF(GOPARR) CALL DDI_GSUMF(2187,FCM,NXYZ*NXYZ)
C
      DSKWRK = SVDSKW
C
C     ----- Form complete MO derivative -----
C
      DO 300 I=1,L1
        DO 300 J=1,L1
          IPHSE = INDEX(I,J)
          IJ = IABS(IPHSE)
          IF(IJ.EQ.0) GO TO 300
          DLT = TWO*IJ/IPHSE
          IUNIQ = 0
          DO 250 IXYZ=1,NXYZ
            IF(NOCP(IXYZ).NE.1) IUNIQ = IUNIQ + 1
            IF(NOCP(IXYZ).NE.0) GO TO 250
            SDER(IXYZ,I,J) = SDER(IXYZ,I,J) - DLT*YAO(IUNIQ,IJ)
  250     CONTINUE
  300 CONTINUE
C
C     ----- Add derivative overlap and response terms to -----
C     -----               dipole derivative              -----
C
      DO 1000 IXYZ=1,3
C
C          ----- Transform dipole integrals to MO basis -----
C
        CALL DAREAD(IDAF,IODA,DIPAO,L2,95+IXYZ-1,0)
        CALL TFTRI(DIPMO,DIPAO,VEC,WRK,L0,L1,L1)
        CALL DAWRIT(IDAF,IODA,DIPMO,L2,252+IXYZ-1,0)
C
C          ----- Construct dipole "Lagrangian" -----
C
        CALL VCLR(WRK,1,L3)
        DO 400 I=1,L0
          DO J=1,NCOR
            II = MAX(I,J)
            JJ = MIN(I,J)
            IJ = IA(II)+JJ
            JI = (J-1)*L1 + I
            WRK(JI) = TWO*DIPMO(IJ)
          ENDDO
C
          DO 400 J=1,NACT
            DVAL = ZERO
            DO M=1,NACT
              JJ = MAX(J,M)
              MM = MIN(J,M)
              JM = IA(JJ)+MM
              II = MAX(I,M+NCOR)
              MM = MIN(I,M+NCOR)
              IM = IA(II)+MM
              DVAL = DVAL + DIPMO(IM)*OPDM(JM)
            ENDDO
            JI = (J+NCOR-1)*L1 + I
            WRK(JI) = DVAL
  400   CONTINUE
C
C          ----- Add response contributions to dipole derivative -----
C
        DO JXYZ=1,NXYZ
          IJXYZ = (JXYZ-1)*3 + IXYZ
          DDM(IJXYZ) = DDOT(L3,SDER(JXYZ,1,1),NXYZ,WRK,1)
        ENDDO
C
        DO 500 I=1,NACT
          DO 500 J=1,I
            IJ = IA(I+NCOR) + J+NCOR
            IIJJ = IA(I) + J
            DLT = TWO
            IF(I.EQ.J) DLT = ONE
            DLT = DLT*DIPMO(IJ)
            JUNIQ = 0
            DO 450 JXYZ=1,NXYZ
              NJXYZ = NOCP(JXYZ)
              IF(NJXYZ.NE.1) JUNIQ = JUNIQ + 1
              IF(NJXYZ.NE.0) GO TO 450
              JIXYZ = (JXYZ-1)*3 + IXYZ
              DDM(JIXYZ) = DDM(JIXYZ) - DLT*DDEN(JUNIQ,IIJJ)
  450       CONTINUE
  500   CONTINUE
 1000 CONTINUE
C
      RETURN
      END
