C 17 Jan 06 - MWS - update args to TRFMCX
C 14 Nov 05 - DGF - pad common block ENRGYS
C 19 Sep 05 - MWS - add true nuclear charge array to INFOA common
C 13 Jul 05 - MWS - additional changes related to canonicalizing
C  5 Jul 05 - MWS - DPTCAN: new routine to allow canonicalization
C 27 Jun 05 - MWS - fix parallel check runs
C  1 Jun 05 - JI  - new module for determinant based MRPT/MCQDPT
C
C ----------------------------------------------------
C PROGRAMMED BY JOE IVANIC AT
C ADVANCED BIOMEDICAL COMPUTING CENTER
C SAIC-FREDERICK
C NATIONAL CANCER INSTITUTE AT FREDICK
C
C DIRECT DETERMINANT MULTI-REFERENCE PERTURBATION THEORY
C THIS USES A DIAGONAL H0 IN THE SAME FLAVOUR AS:
C
C P. M. KOZLOWSKI AND E.R. DAVIDSON, J.CHEM. PHYS. 3672, 100, 1994
C                                   (DETERMINANT BASED)
C AND
C
C K. HIRAO, CHEM. PHYS. LETT. 59, 201, 1993 (CSF BASED)
C
C MULTISTATE TREATMENT IS THE SAME FLAVOUR AS MCQDPT:
C
C H. NAKANO, J. CHEM. PHYS. 7983, 99, 1993 (CSF BASED)
C ----------------------------------------------------
C
C*MODULE DEMRPT  *DECK MRPT
C     ---------------
      SUBROUTINE MRPT
C     ---------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DOUBLE PRECISION METHOD
C
      LOGICAL GOPARR,DSKWRK,MASWRK
      LOGICAL DDITRF,DOOOOO,DOVOOO,DOVVOO,DOVOVO,DOVVVO,DOVVVV,DOCORE
      LOGICAL NOS,CLABEL,IVANIC,SOME,MCWTS,MCCAN,CANONC,
     *        FCORE,FORS,NOCI,EKT,LINSER
C
      PARAMETER (MXATM=2000, MXRT=100, MXAO=8192, MXNORO=250)
C
      COMMON /DETMRP/ EBAR0,EPT0(MXRT),EPT1(MXRT),WPTST(MXRT),
     *                IPTST(MXRT),NPTST,NVAL,NEXT,IFORB,NOS,IVANIC
      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 /FMCOM / X(1)
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,MA,MB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IJKT,IDAF,NAV,IODA(950)
      COMMON /MCINP / METHOD,CISTEP,ACURCY,ENGTOL,DAMP,MICIT,NWORD,
     *                NORBMC,NOROT(2,MXNORO),MOFRZ(15),NPFLG(10),
     *                NOFO,MCFMO,CANONC,FCORE,FORS,NOCI,EKT,LINSER
      COMMON /MRPTIN/ TYPMRMP,INORBMC
      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
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
      DATA CHECK/8HCHECK   /
C
C        Driver for determinant based MRPT
C
C  ----- Read input defining the MRMP2 dimensions -----
C  this should not really be necessary, but the number of core orbitals
C  may be incorrect unless we repeat the -detinp- call
C
      DATA DET/8HDET     /
      DATA DETPT/8HDETPT   /
      CALL DETINP(NPRINT,DET)
      CALL DMRINP(NPRINT,DETPT)
C
      SOME = MASWRK  .AND.  NPRINT.NE.-5
C
      L0 = NQMT
      L1 = NUM
      L2 = (L1*L1+L1)/2
      L3 =  L1*L1
C
C  If using natural orbitals for pt then we must exchange these with
C  canonical mos
C
      IF (NOS) THEN
         L1 = NUM
         L3 = L1*L1
         CALL VALFM(LOADFM)
         LNOS = LOADFM + 1
         LMOS = LNOS   + L3
         LAST = LMOS   + L3
         NEED = LAST - LOADFM - 1
         CALL GETFM(NEED)
         CALL DAREAD(IDAF,IODA,X(LMOS),L3,15,0)
         CALL DAREAD(IDAF,IODA,X(LNOS),L3,19,0)
         CALL DAWRIT(IDAF,IODA,X(LMOS),L3,19,0)
         CALL DAWRIT(IDAF,IODA,X(LNOS),L3,15,0)
         CALL RETFM(NEED)
      ENDIF
C
C ----- Print out symmetries of all orbitals -----
C
      CALL VALFM(LOADFM)
      LMOLAB = LOADFM + 1
      LMOIRP = LMOLAB + L1
      LVEC   = LMOIRP + L1
      LS     = LVEC   + L3
      LQ     = LS     + L2
      LWRK   = LQ     + L3
      LMODEG = LWRK   + L1
      LAST   = LMODEG + L1
      NEED   = LAST - LOADFM - 1
      CALL GETFM(NEED)
C
      CALL DAREAD(IDAF,IODA,X(LVEC),L3,15,0)
      CALL DAREAD(IDAF,IODA,X(LS),L2,12,0)
      CALL DAREAD(IDAF,IODA,X(LQ),L3,45,0)
      CALL TRFSYM(X(LMOLAB),X(LMOIRP),X(LMODEG),X(LQ),X(LS),X(LVEC),
     *               X(LWRK),IA,L0,L1,L0,L1)
      IF (SOME) THEN
         WRITE(IW,9000) NCOR-NVAL,NVAL,NACT,NEXT
         CALL MOSYPR2(X(LMOLAB),NCOR-NVAL,NVAL,NACT,NEXT)
      ENDIF
C
      CALL RETFM(NEED)
C
C ----- Integral transformation for FCI in NACT orbitals -----
C core orbital count gets changed somewhere, probably in the CI,
C so be sure to save a copy of the orbital spaces involved here.
C
      IF (MASWRK) WRITE(IW,9010)
      DDITRF=GOPARR
      DOOOOO=.TRUE.
      DOVOOO=.FALSE.
      DOVVOO=.FALSE.
      DOVOVO=.FALSE.
      DOVVVO=.FALSE.
      DOVVVV=.FALSE.
      DOCORE=.TRUE.
      NPRTTF = 0
      IF(NPRINT.EQ.-5) NPRTTF=-5
      NCORTF = NCOR
      NORBTF = NORB
      IF(SOME) WRITE(IW,9011)
      CALL TRFMCX(NPRTTF,NCORTF,NORBTF,NORBTF,.FALSE.,.FALSE.,
     *            DDITRF,DOOOOO,DOVOOO,DOVVOO,DOVOVO,
     *            DOVVVO,DOVVVV,DOCORE)
C
C ----- Direct full CI calculation within NACT orbitals -----
C       Make sure any CI vector file from before MCSCF orbital
C       canonicalization will not be used as a starting guess.
C       Canonicalization may have made a huge rotation in the
C       active space, so it is safer to start off clean here.
C
      CALL ERASCI
      CLABEL = .FALSE.
      IF (GOPARR) CLABEL = .TRUE.
      CALL DETFCI(NPRINT,CLABEL,DDITRF)
C
C ----- Set up which states to include in the MRPT
C
C DEFAULT SETUP FOR NPTST AND IPTST
C USE MCSCF NON-ZERO STATE WEIGHTS TO DECIDE WHICH STATES TO INCLUDE.
C WE ASSUME HERE THAT PURES=.TRUE. FOR WSTATE, THAT IS, WSTATE ONLY
C APPLIES TO STATES WITH S = MS AND ALL K CI VECTORS ARE ON DISK.
C
      IF (NPTST.EQ.0) THEN
         ICURST = 0
         DO 977 II=1,K
            IF (ABS(SPINS(II)-S).GT.0.03D+00) GOTO 977
            ICURST = ICURST + 1
            IF (WSTATE(ICURST).GT.1.0D-06) THEN
               NPTST = NPTST + 1
               IPTST(NPTST) = II
               WPTST(NPTST) = WSTATE(ICURST)
            ENDIF
  977    CONTINUE
         MCWTS=.TRUE.
      ELSE
         MCWTS=.FALSE.
      END IF
C
C ----- Now to generate the 1st order densities for Fock energies -----
C
      CALL DEMRDM1(NPRINT,NPTST,IPTST)
C
C   form state averaged 1e- density
C
      CALL RESHAP(NPTST,WPTST)
C
C   possible orbital canonicalization, or at least Fock energies
C
      CALL FOCKE(SOME)
C
C       Canonicalization in core,active,external space should have
C       been done by the MCSCF program if the input permitted it,
C       and if we are not using -RDVECS- at some initial geometry.
C       Use of different state weights means the MCSCF canonicalization
C       cannot be accepted.
C
C       If there was a new orbital canonicalization, we must transform
C       over the new orbitals, regenerate the CI reference states,
C       and regenerate the state-averaged one electron density matrix.
C
      MCCAN = CANONC  .AND.  INORBMC.EQ.0
      IF(IFORB.EQ.1  .AND.  (.NOT.MCCAN  .OR.  .NOT.MCWTS)) THEN
         IF(MASWRK) WRITE(IW,9015)
         IF(SOME) WRITE(IW,9011)
         IF (GOPARR  .AND.  EXETYP.NE.CHECK) CALL DDI_DESTROY(D_OOOO)
         CALL TRFMCX(NPRTTF,NCORTF,NORBTF,NORBTF,.FALSE.,.FALSE.,
     *               DDITRF,DOOOOO,DOVOOO,DOVVOO,DOVOVO,
     *               DOVVVO,DOVVVV,DOCORE)
         CALL ERASCI
         CALL DETFCI(NPRINT,CLABEL,DDITRF)
         CALL DEMRDM1(NPRINT,NPTST,IPTST)
         CALL RESHAP(NPTST,WPTST)
      END IF
C
C     ----- Now we are ready to do the perturbation theory -----
C
      IF (NPTST.EQ.1) THEN
         IF (MASWRK) WRITE(IW,9020) IPTST(1)
      ELSE
         IF (MASWRK) WRITE(IW,9022)
         IF (MASWRK) WRITE(IW,9024) (IPTST(I),WPTST(I),I=1,NPTST)
      ENDIF
C
C     ----- Integral transformation for PT part -----
C
      IF (GOPARR  .AND.  EXETYP.NE.CHECK) CALL DDI_DESTROY(D_OOOO)
C
      IF(SOME) WRITE(IW,9040)
      NC = NCORSV-NVAL
      NO = NCORSV+NACT
      NT = NCORSV+NACT+NEXT
      DDITRF=GOPARR
      DOOOOO=.TRUE.
      DOVOOO=.TRUE.
      DOVVOO=.TRUE.
      DOVOVO=.TRUE.
      CALL TRFMCX(NPRTTF,NC,NO,NT,.FALSE.,.FALSE.,
     *            DDITRF,DOOOOO,DOVOOO,DOVVOO,DOVOVO,
     *            DOVVVO,DOVVVV,DOCORE)
C
C ----- Direct MRPT calculation within NVAL, NACT -> NEXT orbitals -----
C
      CALL DPT0TH(SOME,NCORSV,NACT)
      CALL MRPTDET(NPRINT,DDITRF)
C
      RETURN
C
C ***** END OF DETERMINANT MRPT *****
C
 9000 FORMAT(/1X,'SYMMETRIES FOR THE',I4,' CORE,',I4,' VALENCE,',
     *      I4,' ACTIVE,',I4,' EXTERNAL ARE')
 9010 FORMAT(/5X,41(1H=)/
     *        5X,'EXECUTING INITIAL CI FOR REFERENCE STATES'/
     *        5X,41(1H=))
 9011 FORMAT(5X,'TRANSFORMING INTEGRALS OVER ONLY THE ACTIVE SPACE',
     *          ' FOR THE CI...')
 9015 FORMAT(/5X,64(1H=)/
     *        5X,'EXECUTING CI FOR REFERENCE STATES IN THE CANONICAL',
     *           ' ORBITAL BASIS'/
     *        5X,64(1H=))
 9020 FORMAT(/5X,31(1H=)/
     *        5X,'EXECUTING SINGLE STATE DET-MRPT'/
     *        5X,31(1H=)/
     *        5X,'DETERMINING PT CORRECTION FOR CI STATE',I5)
 9022 FORMAT(/5X,29(1H=)/
     *        5X,'EXECUTING MULTISTATE DET-MRPT'/
     *        5X,29(1H=),5X/
     *        5X,'DETERMINING PT CORRECTION FOR CI STATES/WEIGHTS:')
 9024 FORMAT(5X,5(I5,'=',F7.4))
 9040 FORMAT(5X,'PARTIAL INTEGRAL TRANSFORMATION OVER ALL ORBITALS',
     *          ' FOR THE PT...')
      END
C
C*MODULE DEMRPT  *DECK DMRINP
C     ------------------------------
      SUBROUTINE DMRINP(NPRINT,GPNAME)
C     ------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
      LOGICAL NOS,SOME,IVANIC,CANON
C
      PARAMETER (MXATM=2000, MXRT=100)
C
      COMMON /DETMRP/ EBAR0,EPT0(MXRT),EPT1(MXRT),WPTST(MXRT),
     *                IPTST(MXRT),NPTST,NVAL,NEXT,IFORB,NOS,IVANIC
      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 /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,MA,MB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IJKT,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      PARAMETER (NNAM=8)
      DIMENSION QNAM(NNAM),KQNAM(NNAM)
      DATA QNAM/8HNVAL    ,8HNEXT    ,8HNOS     ,8HNPTST   ,8HIPTST   ,
     *          8HWPTST   ,8HIVANIC  ,8HCANON   /
      DATA KQNAM/1,1,0,1,-1,-3,0,0/
C
      SOME = MASWRK .AND. NPRINT.NE.-5
C
      IF (SOME) WRITE(IW,9000)
C
C Set up the defaults
C
      NMOFZC = NUMCOR()
      NVAL =  NCORSV-NMOFZC
C
      NEXT = -1
      NOS  = .FALSE.
      NPTST = 0
      DO I=1,MXRT
         IPTST(I) = 0
         WPTST(I) = 1.0D+00
      ENDDO
      KQNAM(5)=MXRT*10 + 1
      KQNAM(6)=MXRT*10 + 3
      IVANIC = .FALSE.
      CANON = .TRUE.
C
      CALL NAMEIO(IR,JRET,GPNAME,NNAM,QNAM,KQNAM,
     *            NVAL,NEXT,NOS,NPTST,IPTST,WPTST,IVANIC,CANON,
     *           0,   0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     *   0,0,0,0,0,   0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     *   0,0,0,0,0,   0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0)
C
      IF (NEXT.EQ.-1) NEXT=NQMT-NCOR-NACT
C
C Print out details of calculation before checking for ridiculousness
C
      IF (SOME) WRITE(IW,9010) GRPDET,STSYM,NCOR-NVAL,NVAL,NACT,NEXT,
     *                         NA+NCOR,NVAL,NA,NB+NCOR,NVAL,NB
C
      IF (NPTST.EQ.0) THEN
         NST = 0
         MST = 0
         DO 977 II=1,K
            IF (ABS(SPINS(II)-S).GT.0.03D+00) GOTO 977
            NST = NST + 1
            IF (WSTATE(NST).GT.1.0D-06) THEN
               MST=MST+1
               IWTS(MST) = II
            ENDIF
  977    CONTINUE
         IF (SOME) THEN
            WRITE(IW,9015) S,MST
            WRITE(IW,9016) (IWTS(I),I=1,MST)
         END IF
      ELSE
         SUM = 0.0D+00
         DO I=1,NPTST
            SUM = SUM + WPTST(I)
         ENDDO
         FACT = 1.0D+00/SUM
         DO I=1,NPTST
            WPTST(I) = FACT * WPTST(I)
         ENDDO
         IF (SOME) THEN
            WRITE(IW,9017) NPTST
            WRITE(IW,9018) (IPTST(I),I=1,NPTST)
            WRITE(IW,9019) (WPTST(I),I=1,NPTST)
         END IF
      ENDIF
C
C        The correct input for this would probably be IROOT in $DET/$DRT
C        Note that the end of -DETMRPT- just punts on putting the MCQDPT
C        energies back into the ESTATE array, because the mapping is
C        probably complicated (inverse of just above).
C
      IF(NGLEVL+NHLEVL.GT.0  .AND.  (NPTST.GT.1  .OR.  MST.GT.1)) THEN
         IF(MASWRK) WRITE(IW,9080)
         CALL ABRT
      END IF
 9080 FORMAT(1X,'THERE IS NO MECHANISM TO PICK A SPECIFIC STATE''S',
     *          ' MCQDPT ENERGY'/
     *       1X,'FOR USE IN A NUMERICAL DIFFERENTIATION.'/
     *       1X,'PLEASE PROVIDE ADDITIONAL PROGRAMMING IF YOU WANT',
     *          ' TO DO THIS')
C
      IF(SOME) THEN
         IF (IVANIC) THEN
            WRITE(IW,9020)
         ELSE
            WRITE(IW,9022)
         ENDIF
C
         IF (NOS) THEN
            WRITE(IW,9030)
         ELSE IF(.NOT.CANON) THEN
            WRITE(IW,9031)
         ELSE
            WRITE(IW,9032)
         ENDIF
         WRITE(IW,9040) K,KST,MAXP,MAXW1,NITER,CRIT
      END IF
C
                     IFORB=1
      IF(NOS)        IFORB=2
      IF(.NOT.CANON) IFORB=0
C
C Look for ridiculous specifications
C
      IF (NVAL.LT.0) THEN
         IF (MASWRK) WRITE(IW,9100) NVAL
         CALL ABRT
      ENDIF
      IF (NVAL.GT.NCOR) THEN
         IF (MASWRK) WRITE(IW,9110) NVAL,NCOR
         CALL ABRT
      ENDIF
C
      IF (NEXT.LT.-1) THEN
         IF (MASWRK) WRITE(IW,9120) NEXT
         CALL ABRT
      ENDIF
      IF (NEXT.GT.NQMT-NCOR-NACT) THEN
         IF (MASWRK) WRITE(IW,9130) NEXT,NQMT-NCOR-NACT
         CALL ABRT
      ENDIF
C
      IF (NVAL.EQ.0.AND.NEXT.EQ.0) THEN
         IF (MASWRK) WRITE(IW,9140) NVAL,NEXT
         CALL ABRT
      ENDIF
C
      RETURN
C
 9000 FORMAT(/1X,66(1H=)/
     *1X,'DETERMINANTAL MULTIREFERENCE 2ND ORDER ',
     *   'PERTURBATION THEORY (MRPT2)'/
     *18X,'PROGRAM WRITTEN BY JOE IVANIC'/
     *9X,'ADVANCED BIOMEDICAL COMPUTING CENTER, NCI-FREDERICK'/
     *1X,66(1H=))
 9010 FORMAT(/1X,'THE POINT GROUP                  =',3X,A8/
     *        1X,'THE STATE SYMMETRY               =',3X,A8/
     *        1X,'NUMBER OF CORE     ORBITALS      =',I5/
     *        1X,'NUMBER OF VALENCE  ORBITALS      =',I5/
     *        1X,'NUMBER OF ACTIVE   ORBITALS      =',I5/
     *        1X,'NUMBER OF EXTERNAL ORBITALS      =',I5/
     *        1X,'NUMBER OF ALPHA ELECTRONS        =',I5,
     *        ' (',I4,' VALENCE) (',I4,' ACTIVE)'/
     *        1X,'NUMBER OF BETA ELECTRONS         =',I5,
     *        ' (',I4,' VALENCE) (',I4,' ACTIVE)')
 9015 FORMAT(/1X,
     *      'DEFAULTING TO MCSCF INPUT TO DETERMINE STATES IN MRPT:-',
     * //1X,'INPUT NO. OF STATES OF SPIN ',F4.1,' =',I5)
 9016 FORMAT(1X,'THESE WOULD SEEM TO BE CI STATES =',(/10I5))
 9017 FORMAT(/1X,
     * 'READING IN WHICH STATES TO INCLUDE IN MRPT:-',//
     * 1X,'*** WARNING!!! YOU ARE RESPONSIBLE FOR MAKING SURE YOU  ***'/
     * 1X,'*** HAVE THE RIGHT STATES. YOU SHOULD HAVE CHECKED THIS ***'/
     * 1X,'*** WITH A PREVIOUS CI CALCULATION USING THE SAME ORBS  ***'/
     * 1X,'*** AS SPECIFIED IN THIS MRPT CALCULATION.              ***'/
     * /1X,'INPUT NO. OF STATES =',I5)
 9018 FORMAT(1X,'THESE ARE CI STATES =',(/10I5))
 9019 FORMAT(1X,'USING STATE WEIGHTS =',(/10F7.4))
 9020 FORMAT(/1X,'PERTURBATION THEORY OPTIONS:-'//
     *        1X,'H0 = IVANIC VIRTUAL FOCK ENERGIES')
 9022 FORMAT(/1X,'PERTURBATION THEORY OPTIONS:-'//
     *       1X,'H0 = ',
     *      'DIAGONAL ELEMENTS OF FOCK ENERGY MATRIX')
 9030 FORMAT(1X,'NATURAL ORBITALS USED IN ACTIVE SPACE'/
     *       1X,'VALENCE, EXTERNAL ORBITALS FROM BLOCK DIAGONALIZED ',
     *      'FOCK MATRICES')
 9031 FORMAT(1X,'CORE, ACTIVE AND EXTERNAL ORBITALS WILL NOT BE',
     *      ' CANONICALIZED!')
 9032 FORMAT(1X,'CANONICAL FOCK ORBITALS USED IN ACTIVE SPACE'/
     *       1X,'VALENCE, EXTERNAL ORBITALS FROM BLOCK DIAGONALIZED ',
     *      'FOCK MATRICES')
 9040 FORMAT(/1X,'REFERENCE CI PARAMETERS:-'//
     *       1X,'NUMBER OF CI STATES REQUESTED    =',I5/
     *       1X,'NUMBER OF CI STARTING VECTORS    =',I5/
     *       1X,'MAX. NO. OF CI EXPANSION VECTORS =',I5/
     *       1X,'SIZE OF INITIAL CI GUESS MATRIX  =',I5/
     *       1X,'MAX. NO. OF CI ITERS/STATE       =',I5/
     *       1X,'CI DIAGONALIZATION CRITERION     =',1P,E9.2)
 9100 FORMAT(/1X,'**** ERROR, $DETPT INPUT NVAL =',I4,
     *       1X,' IS LESS THAN ZERO'/)
 9110 FORMAT(/1X,'**** ERROR, $DETPT INPUT NVAL =',I4,
     *       1X,' IS GREATER THAN NCOR=',I4/)
 9120 FORMAT(/1X,'**** ERROR, $DETPT INPUT NEXT =',I4,
     *       1X,' IS LESS THAN ZERO'/)
 9130 FORMAT(/1X,'**** ERROR, $DETPT INPUT NEXT =',I4,
     *       1X,' IS TOO BIG. TOTAL NO. OF EXTERNALS =',I4/)
 9140 FORMAT(/1X,'**** ERROR, $DETPT INPUT NVAL =',I4,
     *       ' NEXT =',I4,' IMPLIES NO PT TREATMENT')
C
      END
C
C*MODULE DEMRPT  *DECK MOSYPR2
C     ----------------------------------------------
      SUBROUTINE MOSYPR2(LMOLAB,NCOR,NVAL,NACT,NEXT)
C     ----------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION LMOLAB(NCOR+NVAL+NACT+NEXT)
      COMMON /IOFILE/ IR,IW,IP,IS,IJKT,IDAF,NAV,IODA(950)
C
      WRITE(IW,9070) (LMOLAB(I),I=1,NCOR)
      WRITE(IW,9080) (LMOLAB(I+NCOR),I=1,NVAL)
      WRITE(IW,9090) (LMOLAB(I+NCOR+NVAL),I=1,NACT)
      WRITE(IW,9100) (LMOLAB(I+NCOR+NVAL+NACT),I=1,NEXT)
C
 9070 FORMAT(/1X,'    CORE=',10(1X,A4,1X)/(10X,10(1X,A4,1X)))
 9080 FORMAT(/1X,' VALENCE=',10(1X,A4,1X)/(10X,10(1X,A4,1X)))
 9090 FORMAT(/1X,'  ACTIVE=',10(1X,A4,1X)/(10X,10(1X,A4,1X)))
 9100 FORMAT(/1X,'EXTERNAL=',10(1X,A4,1X)/(10X,10(1X,A4,1X)))
C
      RETURN
      END
C
C*MODULE DEMRPT  *DECK RESHAP
C     ------------------------------
      SUBROUTINE RESHAP(NPTST,WPTST)
C     ------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXRT=100, MXATM=2000)
C
      DIMENSION WPTST(NPTST)
C
      COMMON /CIFILS/ NFT11,NFT12,NFT13,NFT14,NFT15,NFT16,IDAF20,NEMEMX
      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 /FMCOM / X(1)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NATO,NBTO,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IJKT,IDAF,NAV,IODA(950)
C
      PARAMETER (TWO=2.0D+00)
C
      K1 = NACT
      K2 = (K1*(K1+1))/2
C
      M1 = NCORSV + NACT
      M2 = (M1*(M1+1))/2
C
      L1 = NUM
      L2 = (L1*L1+L1)/2
      L3 = L1*L1
C
      CALL VALFM(LOADFM)
      LDM1  = LOADFM + 1
      LWRK  = LDM1 + K2*NPTST
      LOCC  = LWRK + M2
      LDMAO = LOCC + NACT
      LVEC  = LDMAO+ L2
      LAST  = LVEC + L3
      NEED1 = LAST - LOADFM - 1
      CALL GETFM(NEED1)
C
      CALL SEQOPN(NFT15,'WORK15','UNKNOWN',.FALSE.,'UNFORMATTED')
      CALL SEQREW(NFT15)
      IDMI = LDM1
      DO II=1,NPTST
         CALL SQREAD(NFT15,X(IDMI),K2)
         IDMI = IDMI + K2
      ENDDO
      CALL SEQREW(NFT15)
C
C If more than one state, average the density matrices
C
      IF(NPTST.GT.1) THEN
         CALL DSCAL(K2,WPTST(1),X(LDM1),1)
         IDMI = LDM1
         DO II=2,NPTST
            IDMI = IDMI + K2
            CALL DAXPY(K2,WPTST(II),X(IDMI),1,X(LDM1),1)
         ENDDO
      END IF
C
      CALL VCLR(X(LWRK),1,M2)
      II=0
      DO I=1,NCORSV
         II=II+I
         X(LWRK+II-1) = TWO
      ENDDO
      DO I=1,K1
         IV = (I*(I-1))/2
         IC = ((I+NCORSV)*(I+NCORSV-1))/2
         X(LOCC+I-1) = X(LDM1+IV+I-1)
         DO J=1,I
            IJV = IV + J
            IJC = IC + J + NCORSV
            X(LWRK+IJC-1) = X(LDM1+IJV-1)
         ENDDO
      ENDDO
C
C        save (state averaged) density in MO basis
C        transform this to AO basis, saved inside that routine
C
      CALL DAWRIT(IDAF,IODA,X(LWRK),M2,68,0)
      CALL MCAODEN(X(LVEC),X(LDMAO),X(LWRK),L1,M1)
      CALL RETFM(NEED1)
C
      RETURN
      END
C
C*MODULE DEMRPT  *DECK FOCKE
      SUBROUTINE FOCKE(SOME)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (MXRT=100, MXATM=2000)
C
      LOGICAL SOME
      LOGICAL PACK2E,NOS,IVANIC,GOPARR,DSKWRK,MASWRK,
     *        DIRSAV,DIRSCF,FDIFF
C
      COMMON /DETMRP/ EBAR0,EPT0(MXRT),EPT1(MXRT),WPTST(MXRT),
     *                IPTST(MXRT),NPTST,NVAL,NEXT,IFORB,NOS,IVANIC
      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 /FMCOM / X(1)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NATO,NBTO,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /IOFILE/ IR,IW,IP,IS,IJKT,IDAF,NAV,IODA(950)
      COMMON /OPTSCF/ DIRSCF,FDIFF
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      DATA CHECK/8HCHECK   /
C
      IF (GOPARR) THEN
         DIRSAV=DIRSCF
         DIRSCF=.TRUE.
      END IF
C
      L1 = NCORSV + NACT
      L2 = (L1*(L1+1))/2
C
      N0 = NQMT
      N1 = NUM
      N2 = (N1*(N1+1))/2
      N3 = N1*N1
C
      CALL VALFM(LOADFM)
      LDM1  = LOADFM + 1
      LVEC  = LDM1  + L2
      LDM2  = LVEC  + N3
      LWRK  = LDM2  + N2
      LBUF  = LWRK  + N2
      LIBF  = LBUF  + NINTMX
      LSCR  = LIBF  + NINTMX
      LQ    = LSCR  + 8*N1
      LS    = LQ    + N3
      LFAO  = LS    + N2
      LWRK1 = LFAO  + N2
      LWRK2 = LWRK1 + N3
      LIWRK = LWRK2 + N3
      LEIG  = LIWRK + N1
      LAST  = LEIG  + N1
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
C
      IF(EXETYP.EQ.CHECK) THEN
         CALL VCLR(X(LWRK),1,L1)
         GO TO 500
      END IF
C
      CALL DAREAD(IDAF,IODA,X(LVEC),N3,15,0)
      CALL DAREAD(IDAF,IODA,X(LDM1),L2,68,0)
C
C Tranform the density matrix to the ao basis
C
      CALL TRPOSQ(X(LVEC),N1)
      CALL TFTRI(X(LDM2),X(LDM1),X(LVEC),X(LWRK),N1,L1,N1)
C
C Calculate fock matrix in ao basis
C
      CALL VCLR(X(LWRK),1,N2)
      CALL FLMAT(X(LDM2),X(LVEC),X(LWRK),X(LBUF),X(LIBF),N1)
      CALL DAREAD(IDAF,IODA,X(LDM2),N2,11,0)
      CALL VADD(X(LWRK),1,X(LDM2),1,X(LWRK),1,N2)
C
C Tranform the fock matrix to the mo basis
C
      CALL DAREAD(IDAF,IODA,X(LVEC),N3,15,0)
      CALL TFTRI(X(LDM2),X(LWRK),X(LVEC),X(LSCR),N0,N1,N1)
C
      IF(NOS) THEN
         IF(SOME) WRITE(IW,*) 'USING NO-S, SKIPPING CANONICALIZATION'
      ELSE IF(IFORB.EQ.0) THEN
         IF(SOME) WRITE(IW,*) 'BY REQUEST, SKIPPING CANONICALIZATION'
      ELSE
         NCORPT=NCORSV-NVAL
         CALL DPTCAN(SOME,X(LVEC),X(LQ),X(LS),X(LFAO),X(LDM2),
     *               X(LWRK1),X(LWRK2),X(LIWRK),X(LEIG),X(LSCR),
     *               N0,N1,N2,N3,NACT,NCORSV,NCORPT)
      END IF
C
C  And dump to record 284
C
      IPOS = 0
      DO II=1,N1
         IPOS = IPOS + II
         IF(II.LE.N0) THEN
            X(LWRK+II-1) = X(LDM2+IPOS-1)
         ELSE
            X(LWRK+II-1) = 0.0D+0
         END IF
      ENDDO
C
  500 CONTINUE
      CALL DAWRIT(IDAF,IODA,X(LWRK),N1,284,0)
      CALL RETFM(NEED)
      CALL FLSHBF(IW)
      IF (GOPARR) DIRSCF=DIRSAV
      RETURN
      END
C*MODULE DEMRPT   *DECK DPT0TH
      SUBROUTINE DPT0TH(SOME,NCORSV,NACT)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXRT=100)
C
      LOGICAL SOME
      LOGICAL NOS,IVANIC
C
      COMMON /IOFILE/ IR,IW,IP,IS,IJKT,IDAF,NAV,IODA(950)
      COMMON /CIFILS/ NFT11,NFT12,NFT13,NFT14,NFT15,NFT16,IDAF20,NEMEMX
      COMMON /DETMRP/ EBAR0,EPT0(MXRT),EPT1(MXRT),WPTST(MXRT),
     *                IPTST(MXRT),NPTST,NVAL,NEXT,IFORB,NOS,IVANIC
      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 /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      DATA CHECK/8HCHECK   /
C
C        0th and 1st order energies
C
      K1 = NACT
      K2 = (K1*K1+K1)/2
      L1 = NCORSV+NACT+NEXT
      NCORPT = NCORSV - NVAL
C
      CALL VALFM(LOADFM)
      LDM1  = LOADFM + 1
      LEIG  = LDM1  + K2
      LAST  = LEIG  + L1
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
C
      IF(EXETYP.EQ.CHECK) THEN
         H0COR = 0.0D+00
         H0VAL = 0.0D+00
         DO KK=1,NPTST
            EPT0(KK) = H0VAL
            EPT1(KK) = H0VAL
         ENDDO
         GO TO 500
      END IF
C
      CALL DAREAD(IDAF,IODA,X(LEIG),L1,284,0)
C
C Now to print out the diagonal values over nval,nact,next orbs
C  I.E. LEAVE OUT NCOR OF MRPT WHICH MAY .NE. NCORSV
C
      H0COR = 0.0D+00
      H0VAL = 0.0D+00
      DO II=1,NCORPT
         H0COR = H0COR + 2.0D+00*X(LEIG+II-1)
      ENDDO
      DO II=NCORPT+1,NCORSV
         H0VAL = H0VAL + 2.0D+00*X(LEIG+II-1)
      ENDDO
C
C  Work out E(0)'s using diagonal H(0) operator,
C  this is what Davidson calls the barycentric E(0)'s.
C
      IF (SOME) WRITE(IW,'(/A,F15.9)')
     *  ' CORE    ELECTRONIC BARYCENTRIC 0TH ORDER ENERGY  = ',H0COR
C
      DO KK=1,NPTST
         CALL SQREAD(NFT15,X(LDM1),K2)
         EBAR0 = 0.0D+00
         EPT0(KK) = H0VAL
         IPO = 0
         DO II=1,K1
            IPO = IPO + II
            EPT0(KK) = EPT0(KK) + X(LDM1+IPO-1)*X(LEIG+II+NCORSV-1)
         ENDDO
         EBAR0 = EPT0(KK) + H0COR
         EPT1(KK) = ESTATE(IPTST(KK)) - ENUCR - EBAR0
      ENDDO
      CALL SEQREW(NFT15)
C
  500 CONTINUE
      CALL RETFM(NEED)
      IF(.NOT.SOME) RETURN
C
      DO KK=1,NPTST
         WRITE(IW,'(/A,I4,A)') ' *** CI STATE',IPTST(KK),' ***'
         WRITE(IW,'(/A,F15.9)')
     *     ' VAL/ACT ELECTRONIC BARYCENTRIC 0TH ORDER ENERGY  = ',
     *      EPT0(KK)
         WRITE(IW,'(A,F15.9)')
     *     ' TOTAL   ELECTRONIC BARYCENTRIC 0TH ORDER ENERGY  = ',
     *      EBAR0
         WRITE(IW,'(/A,F15.9)')
     *     ' TOTAL   ELECTRONIC       0TH + 1ST ORDER ENERGY  = ',
     *      ESTATE(IPTST(KK)) - ENUCR
         WRITE(IW,'(A,F15.9)')
     *     ' TOTAL   (MCSCF)          0TH + 1ST ORDER ENERGY  = ',
     *      ESTATE(IPTST(KK))
      ENDDO
      RETURN
      END
C
C*MODULE DEMPRT   *DECK DPTCAN
      SUBROUTINE DPTCAN(SOME,V,Q,S,F,FMO,VOLD,U,IWRK,EIG,SCR,
     *                  L0,L1,L2,L3,NACT,NCORBS,NCORPT)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION V(L1,L0),Q(L1,L1),S(L2),F(L2),FMO(L2),VOLD(L1,L1),
     *          U(L1,L0),IWRK(L1),EIG(L1),SCR(*)
      LOGICAL SOME
      COMMON /IOFILE/ IR,IW,IP,IS,IJKT,IDAF,NAV,IODA(950)
      PARAMETER (ZERO=0.0D+00)
C
C     Canonicalize orbitals for DETPT...core/active/virtual space
C     Note: this is just always done, if called, because if the
C           MCSCF has canonicalized, this processes diagonal blocks,
C           and thus does not change anything at all.
C
      NORB = L0
      NVIRT= NORB-NCORBS-NACT
      IF(SOME) WRITE(IW,9000) NCORBS,NACT,NVIRT
C
C     ----- ZERO BLOCKS CONNECTING CORE, ACTIVE, EXTERNAL SPACES -----
C     THIS WILL PREVENT ANY SUBSEQUENT MIXING OF THESE ORBITAL SPACES
C
      DO I=NCORBS+1,NCORBS+NACT
         IROW = (I*I-I)/2
         DO J=1,NCORBS
            IJ = IROW+J
            FMO(IJ) = ZERO
         ENDDO
      ENDDO
      DO I=NCORBS+NACT+1,NORB
         IROW = (I*I-I)/2
         DO J=1,NCORBS+NACT
            IJ = IROW+J
            FMO(IJ) = ZERO
         ENDDO
      ENDDO
C
C     ----- TRANSFORM BLOCKED FOCK MATRIX BACK TO AO SPACE -----
C
      CALL DAREAD(IDAF,IODA,S,L2,12,0)
      CALL TFTRIB(F,FMO,S,V,U,SCR,L0,L1,L2,L3)
C
C     ----- DIAGONALIZE IN THE -Q- MATRIX SPACE -----
C
      CALL DAREAD(IDAF,IODA,Q,L3,45,0)
      CALL TFTRI(FMO,F,Q,SCR,L0,L1,L1)
      CALL SYMDIA(FMO,V,EIG,SCR,IWRK,L0,L2,L1)
C
C        transform density and orbitals
C
      CALL TFSQB(V,Q,SCR,L0,L1,L1)
C
C        MAKE SURE WE PRESERVE ORIGINAL CORE/ACTIVE/EXTERNAL ORDERING.
C        THEN WITHIN EACH ORBITAL SPACE, WE SORT BY EIGENVALUE.
C
      CALL DAREAD(IDAF,IODA,VOLD,L3,15,0)
      CALL OVLSEL(V,EIG,VOLD,S,U,SCR,IWRK,SCR,L0,L1,L2)
C
      DO K=1,NCORBS-1
         KMIN=K
         RMIN=EIG(K)
         DO I=K+1,NCORBS
            IF(EIG(I).LT.RMIN) THEN
               KMIN=I
               RMIN=EIG(I)
            END IF
         END DO
         IF(KMIN.NE.K) THEN
            CALL DSWAP( 1,EIG(K),1,EIG(KMIN),1)
            CALL DSWAP(L1,V(1,K),1,V(1,KMIN),1)
         END IF
      ENDDO
C
      NORBS = NCORBS+NACT
      DO K=NCORBS+1,NORBS-1
         KMIN=K
         RMIN=EIG(K)
         DO I=K+1,NORBS
            IF(EIG(I).LT.RMIN) THEN
               KMIN=I
               RMIN=EIG(I)
            END IF
         END DO
         IF(KMIN.NE.K) THEN
            CALL DSWAP( 1,EIG(K),1,EIG(KMIN),1)
            CALL DSWAP(L1,V(1,K),1,V(1,KMIN),1)
         END IF
      END DO
C
      DO K=NORBS+1,NORBS+NVIRT-1
         KMIN=K
         RMIN=EIG(K)
         DO I=K+1,NORBS+NVIRT
            IF(EIG(I).LT.RMIN) THEN
               KMIN=I
               RMIN=EIG(I)
            END IF
         END DO
         IF(KMIN.NE.K) THEN
            CALL DSWAP( 1,EIG(K),1,EIG(KMIN),1)
            CALL DSWAP(L1,V(1,K),1,V(1,KMIN),1)
         END IF
      END DO
C
C           --- save results of canonicalization ---
C        the calling routine picks the desired orbital energies
C        from the diagonal of -fmo-, and then saves to the disk.
C
      CALL DAWRIT(IDAF,IODA,V,L3,15,0)
C
      IF(SOME) THEN
         WRITE(IW,9010) NCORPT
         WRITE(IW,9040) (EIG(I),I=1,NCORBS)
         WRITE(IW,9020)
         WRITE(IW,9040) (EIG(I),I=NCORBS+1,NCORBS+NACT)
         WRITE(IW,9030)
         WRITE(IW,9040) (EIG(I),I=NCORBS+NACT+1,NCORBS+NACT+NVIRT)
      END IF
      II = 0
      DO I=1,NCORBS+NACT+NVIRT
         II = II + I
         FMO(II) = EIG(I)
      ENDDO
      RETURN
C
 9000 FORMAT(/1X,'GENERATING DIAGONAL FOCK ENERGIES FOR EACH ORBITAL'/
     *        1X,'THERE ARE',I5,' FILLED,',I5,' ACTIVE, AND',I5,
     *           ' VIRTUAL ORBITALS')
 9010 FORMAT(1X,'ORBITAL ENERGIES FOR FILLED ORBITAL SPACE (',I5,
     *          ' ARE FROZEN CORES)')
 9020 FORMAT(1X,'ORBITAL ENERGIES FOR ACTIVE ORBITAL SPACE')
 9030 FORMAT(1X,'ORBITAL ENERGIES FOR EXTERNAL ORBITAL SPACE')
 9040 FORMAT(1X,5F11.6)
      END
C*MODULE DEMRPT  *DECK MRPTDET
      SUBROUTINE MRPTDET(NPRINT,DDITRF)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL SOME,PACK2E,GOPARR,DSKWRK,MASWRK,JACOBI,
     *        DDITRF,NOS,IVANIC
C
      PARAMETER (MXRT=100)
C
      COMMON /DETMRP/ EBAR0,EPT0(MXRT),EPT1(MXRT),WPTST(MXRT),
     *                IPTST(MXRT),NPTST,NVAL,NEXT,IFORB,NOS,IVANIC
      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 /ENRGMP/ EMP2,EMP3,EMP4
      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 /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /IOFILE/ IR,IW,IP,IS,IJKT,IDAF,NAV,IODA(950)
      COMMON /JACOBI/ JACOBI,NJAOR,ELAST,ISTAT
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /ORDOPT/ IDUM(6),NOSQUR
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
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
C     ----- driver for MRPT2 Determinantal computation -----
C
      SOME = MASWRK  .AND.  NPRINT.NE.-5
C
C        Core contribution to the CAS energy is obtained from -ecore-,
C        and from modifications to the transformed 1e- integrals.
C        this effectively removes core orbs from the CAS computation.
C
      NTOT = NCORSV + NACT + NEXT
      NTCO = NCORSV
      NORB = NACT
      NCOR = 0
      NCORPT = NCORSV - NVAL
      NTOTPT = NVAL + NACT + NEXT
      NSYM = 2**IGPDET
C
C  Compute the total number of determinants in the reference full CI.
C  Decide necessary double/integer working storage -IDS- and -IIS-
C
      CALL VALFM(LOADFM)
      LIFA  = LOADFM + 1
      LAST  = LIFA   + ((NACT+1)*(NACT+1))/NWDVAR + 1
      NEED1 = LAST - LOADFM - 1
      CALL GETFM(NEED1)
C
      CALL BINOM6(X(LIFA),NACT)
C
      CALL VALFM(LOADFM)
      IBO = LOADFM + 1
      ICON = IBO + NTOT
      ICA  = ICON + NA
      ICB  = ICA + NSYM
      KTAB = ICB + NSYM
      IWRK = KTAB + NSYM
      LAST = IWRK + 43
      NEEDT = LAST - LOADFM - 1
      CALL GETFM(NEEDT)
C
      CALL DAREAD(IDAF,IODA,X(IBO),NTOT,262,1)
      CALL CORTRA(X(IBO),NTOT,NTCO)
      CALL MEMPT(IW,NORB,NCOR,NA,NB,K,MAXP,MAXW1,X(LIFA),
     *           NCI,IDS,IIS,NALP,NBLP,IGPDET,KSTSYM,NSYM,
     *           X(IBO),X(ICON),X(ICA),X(ICB),X(KTAB),X(IWRK),
     *           NPTST)
      CALL RETFM(NEEDT)
C
      MP1 = NACT + NVAL
      MP2 = (MP1*(MP1+1))/2
      MP4 = (MP2*(MP2+1))/2
C
      L1 = NVAL + NACT + NEXT
      L2 = (L1*(L1+1))/2
C
      NVO = MP1*NEXT
      NVOOO = MP2*NVO
      NVOVO = (NVO*(NVO+1))/2
C
      NIA = MAX(NVO,MP2)
C
      IVAR1 = NVAL*NVAL*NEXT
      IVAR2 = NVAL*NEXT*NEXT
      NTMPSZ = MAX(IVAR1,IVAR2)
      IF (NVAL.EQ.0) NTMPSZ=NEXT*NEXT
      IF (NEXT.EQ.0) NTMPSZ=NVAL*NVAL
C
C Integral buffers for distributed/disk file transformed ints
C
      IF(DDITRF) THEN
        NOCC  = NTOT
        NOTR  = (NOCC*NOCC+NOCC)/2
        NVTR  = NEXT*NEXT
        LENXX = MAX(NOTR,NVTR)
        LENIXX= 0
      ELSE
        LENXX = NINTMX
        LENIXX= NINTMX
      END IF
C
C Allocate memory for PT step
C
      CALL VALFM(LOADFM)
      LDWRK  = LOADFM + 1
      LIWRK  = LDWRK  + IDS
      LSINT1 = LIWRK  + IIS/NWDVAR + 1
      LSINT2 = LSINT1 + L2
      LSVOOO = LSINT2 + MP4
      LSVOVO = LSVOOO + NVOOO
      LIA    = LSVOVO + NVOVO
      LXX    = LIA    + NIA
      LIXX   = LXX    + LENXX
      LEL    = LIXX   + LENIXX
      IBO    = LEL    + MAXW1
      LEFCK  = IBO    + NTOT
      LINPT  = LEFCK  + NTOT
      LTMP1  = LINPT + L2
      LTMP2  = LTMP1 + NTMPSZ*NPTST
      LTMP3  = LTMP2 + NTMPSZ*NPTST
      LTMP4  = LTMP3 + NTMPSZ*NPTST
      LAST   = LTMP4 + NTMPSZ*NPTST
C
      NEED2  = LAST - LOADFM - 1
      NEEDCI = NEED1 + NEED2
      IF(SOME) WRITE(IW,9130) NEEDCI
      CALL GETFM(NEED2)
C
      IF(EXETYP.EQ.CHECK) THEN
         IF(MASWRK) WRITE(IW,*) 'CHECK RUN SETS E(MP2)=0.0'
         DO IST=1,MIN(K,MXRT)
            SPINS(IST) = S
            ESTATE(IST) = ZERO
         ENDDO
         EMP2 = ZERO
         GO TO 400
      END IF
C
C  Read symmetries for active orbitals, these are used to generate
C  reference determinantal symmetry data in detmrpt
C
      CALL DAREAD(IDAF,IODA,X(IBO),NTOT,262,1)
      CALL CORTRA(X(IBO),NTOT,NCORSV)
C
C  Now to read the diagonal elements of the fock matrix from 284
C  indexing in this routine wants to skip core space, but these
C  eigenvalues are also in the disk record.  So push the pointer.
C
      CALL DAREAD(IDAF,IODA,X(LEFCK),NTOT,284,0)
      LEFCK = LEFCK + NCORPT
C
C  Read 1-e integrals from disk
C
      CALL SEQREW(IJKT)
      CALL SQREAD(IJKT,X(LSINT1),L2)
C
      IF (.NOT.GOPARR) THEN
C
C  Serial code, get 2-e integrals from disk
C
C  Read pt oooo integrals for nval+nact number of orbitals
C
      CALL M1EGHR(IJKT,X(LSINT2),X(LXX),X(LIXX),X(LIA),NINTMX,
     *            MP1,NOSQUR)
C
C  Read pt vooo integrals for o=nval+nact, v=next
C
      CALL SEQREW(IJKT)
      READ(IJKT)
      CALL M1LGRR(IJKT,X(LSVOOO),X(LXX),X(LIXX),X(LIA),NINTMX,
     *            MP1,NEXT,MP2,NOSQUR)
C
C  Read pt vovo integrals for o=nval+nact, v=next
C
      CALL SEQREW(IJKT)
      READ(IJKT)
      CALL M1EXCR(IJKT,X(LSVOVO),X(LXX),X(LIXX),X(LIA),NINTMX,
     *            MP1,NVO,NOSQUR)
C
      ELSE
C
C Parallel code, get 2-e integrals from global array
C
C Read pt oooo for o=nval+nact
C
      CALL RDOOOO(X(LSINT2),NCORPT,MP1,MP4,X(LXX))
C
C Read pt vooo for o=nval+nact, v=vir
C
      CALL RDVOOO(X(LSVOOO),NCORPT,MP1,NEXT,X(LXX))
C
C Read pv vovo for o=nval+nact, v=vir
C
      CALL RDVOVO(X(LSVOVO),NCORPT,MP1,NEXT,X(LXX))
C
      IF (MASWRK) WRITE(IW,*) 'PARALLEL EXECUTION IN PROGRESS'
C
      ENDIF
C
C ----- compute MRPT2 wavefunction(s) -----
C
      CALL DETMRPT(IW,SOME,
     *     X(LSINT1),X(LSINT2),NORB,NCOR,NCI,NA,NB,
     *     MAXP,MAXW1,X(LIFA),X(LEL),
     *     X(LDWRK),IDS,X(LIWRK),IIS,
     *     IGPDET,KSTSYM,NSYM,X(IBO),NALP,NBLP,ISTAT,
     *     X(LSVOOO),X(LSVOVO),X(LEFCK),EPT0,
     *     NCORPT,NVAL,NEXT,NTOTPT,
     *     X(LINPT),X(LTMP1),X(LTMP2),X(LTMP3),X(LTMP4),NTMPSZ,
     *     NPTST,IPTST)
C
  400 CONTINUE
      CALL RETFM(NEED2)
      CALL RETFM(NEED1)
C
C Destroy Global arrays
C
      IF (GOPARR  .AND.  EXETYP.NE.CHECK) THEN
         CALL DDI_DESTROY(D_VVOO)
         CALL DDI_DESTROY(D_OOOO)
         CALL DDI_DESTROY(D_VOOO)
         CALL DDI_DESTROY(D_VOVO)
      ENDIF
C
      RETURN
C
 9130 FORMAT(/1X,'THE DETERMINANT MRPT REQUIRES',I12,' WORDS')
      END
C
C*MODULE DEMRPT  *DECK MEMPT
C     --------------------------------------------------------
      SUBROUTINE MEMPT(IW,NORB,NCOR,NA,NB,
     *                 K,MAXP,MAXW1,IFA,NCI,IDS,IIS,
     *                 NALP,NBLP,
     *                 IDSYM,ISYM1,NSYM,
     *                 IBO,ICON,ICA,ICB,KTAB,IWRK,NPTST)
C     --------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION IFA(0:NORB-NCOR,0:NORB-NCOR)
      DIMENSION ICON(NA),ICA(NSYM),ICB(NSYM),KTAB(NSYM)
      DIMENSION IBO(NORB-NCOR),IWRK(43)
C
C     Code to return memory requirement for DET-MRPT calculation.
C
C   norb,ncor : total no. of orbitals and no. of core orbs respectively
C   na, nb    : number of active alpha and beta electrons respectively
C   k         : Number of states required.
C   maxp      : Maximum number of vectors before transforming and
C               starting at kst.
C   maxw1     : Size of diagonalization for initial guess vectors.
C   idsym     : Which point group, see gtab, gmul or getsym1 in symwrk.f
C               for convention.
C   isym1     : Which irreducible representation, see gtab etc for info.
C   nsym      : nsym = 2**(idsym)
C   ibo       : ibo(i) contains symmetry of active orbital i, see gtab
C
C  RETURNED
C
C   ifa       : ifa will be a list of binomial coefficients which
C               are required for the CI calculation and also to
C               decide how much memory is required.
C   nci       : Returned with the no. of determinants for required CI.
C   ids       : Required space for double precision arrays, not
C               including for arrays spin and EL.
C   iis       : Required space for integer arrays, not including ifa.
C   nalp      : Number of alpha space functions.
C   nblp      : Number of beta space functions.
C   isst      : This is where the symmetry stuff starts in the huge
C               integer work array of size iis.
C
C  SCRATCH    : iwrk,icon,ica,icb,ktab, these are so small that they
C               don't need to be prepared for, ie be a part of the
C               calling statement.
C
      NACT = NORB-NCOR
      NCI = 0
      CALL BINOM6(IFA,NACT)
C
      NALP = IFA(NACT,NA)
      NBLP = IFA(NACT,NB)
C
      DO 45 II=1,NSYM
         ICA(II) = 0
         ICB(II) = 0
   45 CONTINUE
C
      IF (IDSYM.GT.0) THEN
      CALL GTAB(IDSYM,ISYM1,KTAB,
     *      IWRK(1),IWRK(4),IWRK(7),IWRK(10))
      ELSE
      CALL GTAB(1,1,KTAB,
     *      IWRK(1),IWRK(4),IWRK(7),IWRK(10))
      ENDIF
C
      DO 23 II=1,NA
         ICON(II) = II
   23 CONTINUE
C
      DO 53 IA=1,NALP
         IF (IDSYM.GT.0) THEN
         CALL GETSYM1(IW,ICON,NACT,NA,IBO,IDSYM,ISYM,
     *   IWRK(1),IWRK(4),IWRK(7),IWRK(10))
         ELSE
         CALL GETSYM1(IW,ICON,NACT,NA,IBO,1,ISYM,
     *   IWRK(1),IWRK(4),IWRK(7),IWRK(10))
         ENDIF
         ICA(ISYM) = ICA(ISYM) + 1
         CALL ADVANC(ICON,NA,NACT)
   53 CONTINUE
C
      DO 33 II=1,NB
         ICON(II) = II
   33 CONTINUE
C
      DO 43 IB=1,NBLP
         IF (IDSYM.GT.0) THEN
         CALL GETSYM1(IW,ICON,NACT,NB,IBO,IDSYM,ISYM,
     *   IWRK(1),IWRK(4),IWRK(7),IWRK(10))
         ELSE
         CALL GETSYM1(IW,ICON,NACT,NB,IBO,1,ISYM,
     *   IWRK(1),IWRK(4),IWRK(7),IWRK(10))
         ENDIF
         ICB(ISYM) = ICB(ISYM) + 1
         CALL ADVANC(ICON,NB,NACT)
   43 CONTINUE
C
      DO 67 II=1,NSYM
         NCI = NCI + ICA(II)*ICB(KTAB(II))
   67 CONTINUE
C
C  Now for the extra memory requirements.
C
      IDS = NPTST*NCI + MAXW1*(8+MAXW1)+(MAXW1*(MAXW1+1))/2+
     * (MAXP*MAXP) + K
C
      IIS = 5*NA + 4*NCOR + MAXW1 +
     *      NALP*3 + NBLP*3 + NSYM*NSYM + 3*NSYM + 2*(NSYM+1) + K
     *     + 8
C
      RETURN
      END
C
C
C*MODULE DEMRPT  *DECK DETMRPT
C     --------------------------------------------------------
      SUBROUTINE DETMRPT(IW,SOME,SI1,SI2,
     *         NORB,NCOR,NCI,NA,NB,MAXP,MAXW1,
     *         IFA,EL,CI,IDS,IWRK,IIS,
     *         IDSYM,ISYM1,NSYM,IOB,NALP,NBLP,ISTAT,
     *         SVOOO,SVOVO,EFCK,EPT0,
     *         NCORPT,NVAL,NEXT,NTOTPT,
     *         INPT,TMP1,TMP2,TMP3,TMP4,NTMPSZ,
     *         NPTST,IPTST)
C     --------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      LOGICAL SOME
C
      DIMENSION SI1(*)
      DIMENSION SI2(*)
      DIMENSION EL(MAXW1)
      DIMENSION IFA(0:NORB-NCOR,0:NORB-NCOR)
      DIMENSION CI(IDS),IWRK(IIS)
      DIMENSION IOB(NTOTPT)
      DIMENSION SVOOO(*),SVOVO(*),EFCK(NTOTPT)
      DIMENSION INPT(*)
      DIMENSION TMP1(*),TMP2(*),TMP3(*),TMP4(*)
      DIMENSION IPTST(NPTST)
      DIMENSION EPT0(NPTST)
C
C   Code to set up reference CI symmetry data and then call DAVMRPT
C   which  determines the MRPT energy.
C
      NACT = NORB - NCOR
      KCOEF = 1
      KB = KCOEF + NPTST*NCI
      KEF = KB + 8*MAXW1
      KF = KEF + MAXW1*MAXW1
      KEC = KF + (MAXW1*(MAXW1+1))/2
      KCITOT = KEC + MAXP*MAXP
C
C    Now for integer iwrk array
C
      IWRK2 = 1
      IACON1 = IWRK2 + MAXW1
      IBCON1 = IACON1 + NA + 2
      IACON2 = IBCON1 + NA + 2
      IBCON2 = IACON2 + NA + 2
      ISYMA = IBCON2 + NA + 2
      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
      ITOT = ISBC + NBLP
C
      IF (KCITOT.GT.IDS+1.OR.ITOT.GT.IIS+1) THEN
         IF (SOME) THEN
            WRITE(IW,*) 'NOT ENOUGH MEMORY SPECIFIED FOR MRPT'
            WRITE(IW,*) 'ASKED FOR ',IDS,' AND ',IIS,' DOUBLE '
            WRITE(IW,*) 'PRECISION AND INTEGER, ACTUALLY NEED'
            WRITE(IW,*) KCITOT-1,' AND ',ITOT-1
         ENDIF
         CALL ABRT
      ENDIF
C
C  Set up the symmetry data here
C
      CALL SYMWRK(IW,IOB,NACT,NA,NB,IDSYM,ISYM1,NSYM,NALP,NBLP,IWRK,
     *     IWRK(ISYMA),IWRK(ISYMB),IWRK(ICOA),IWRK(ICOB),IWRK(ITAB),
     *     IWRK(IMUL),IWRK(ISPA),IWRK(ISPB),IWRK(ISAS),IWRK(ISBS),
     *     IWRK(ISAC),IWRK(ISBC))
C
C
      CALL DAVMRPT(SOME,SI1,SI2,NACT,0,NCI,NA,NB,
     *     CI(KCOEF),EL,MAXP,MAXW1,
     *     CI(KB),CI(KEF),CI(KF),IWRK(IWRK2),CI(KEC),
     *     IWRK(IACON1),IWRK(IBCON1),IWRK(IACON2),IWRK(IBCON2),
     *     IFA,IWRK(ISYMA),IWRK(ISYMB),IWRK(ITAB),IWRK(IMUL),
     *     IWRK(ISPA),IWRK(ISPB),
     *     NSYM,IOB,NALP,NBLP,
     *     ISTAT,SVOOO,SVOVO,EFCK,EPT0,
     *     NCORPT,NVAL,NEXT,NTOTPT,
     *     INPT,TMP1,TMP2,TMP3,TMP4,NTMPSZ,
     *     NPTST,IPTST)
C
      RETURN
      END
C
C*MODULE DEMRPT  *DECK DAVMRPT
C     ----------------------------------------------------------
      SUBROUTINE DAVMRPT(SOME,SI1,SI2,NORB,NCOR,NCI,NA,NB,
     *    CI,EL,MAXP,MAXW1,
     *    B,EF,F,IWRK2,EC,IACON1,IBCON1,IACON2,IBCON2,
     *    IFA,ISYMA,ISYMB,ITAB,IMUL,ISPA,ISPB,
     *    NSYM,IOB,NALP,NBLP,ISTAT,SVOOO,SVOVO,EFCK,EPT0,
     *    NCORPT,NVAL,NEXT,NTOTPT,
     *    INPT,TMP1,TMP2,TMP3,TMP4,NTMPSZ,
     *    NPTST,IPTST)
C     --------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      LOGICAL SOME,GOPARR,DSKWRK,MASWRK,DSKSAV
      PARAMETER (MXRT=100, MXATM=2000)
C
      COMMON /CIFILS/ NFT11,NFT12,NFT13,NFT14,NFT15,NFT16,IDAF20,NEMEMX
      COMMON /ENRGMP/ EMP2,EMP3,EMP4
      COMMON /ENRGYS/ ENUCR,EELCT,ETOT,STOT,SSQUAR,ECORE,ESCF,EERD,
     *                E1,E2,VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /FUNCT / E,EGRAD(3,MXATM)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IJKT,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      DIMENSION SI1(*), SI2(*), CI(NCI,NPTST)
      DIMENSION F((MAXW1*(MAXW1+1))/2),EF(MAXW1*MAXW1),EL(MAXW1)
      DIMENSION EC(MAXP*MAXP),IWRK2(MAXW1),B(8*MAXW1)
      DIMENSION IFA(0:NORB-NCOR,0:NORB-NCOR)
      DIMENSION IACON1(NA+NCOR+2),IBCON1(NA+NCOR+2)
      DIMENSION IACON2(NA+NCOR+2),IBCON2(NA+NCOR+2)
      DIMENSION ISYMA(NALP),ISYMB(NBLP)
      DIMENSION ITAB(NSYM),ISPA(NALP),ISPB(NBLP)
      DIMENSION IMUL(NSYM,NSYM)
      DIMENSION IOB(NTOTPT)
C
      DIMENSION SVOOO(*),SVOVO(*),EFCK(NTOTPT)
      DIMENSION INPT((NTOTPT*(NTOTPT+1))/2)
      DIMENSION TMP1(NPTST*NTMPSZ),TMP2(NPTST*NTMPSZ)
      DIMENSION TMP3(NPTST*NTMPSZ),TMP4(NPTST*NTMPSZ)
      DIMENSION IPTST(NPTST)
      DIMENSION EPT0(NPTST)
C
C   Code to do a MRPT almost completely directly.  Written by
C   J. Ivanic 2004.  This code makes use of symmetry.
C
      ISTAT=0
      NACT = NORB-NCOR
      NTOT = NCORPT + NVAL + NORB + NEXT
      L1 = NVAL+NORB+NEXT
      L2 = (L1*(L1+1))/2
C
      IF (NB+NCOR.EQ.0) NBLP = 1
C
C Set up indexing arrays for PT
C
      DO I=1,L2
         INPT(I) = (I*(I-1))/2
      ENDDO
C
C Read symmetries for non-core pt orbitals
C
      CALL DAREAD(IDAF,IODA,IOB,NTOT,262,1)
      CALL CORTRA(IOB,NTOT,NCORPT)
C
C ----- We must have usable CI vectors on disk already -----
C
      DSKSAV = DSKWRK
      DSKWRK = .FALSE.
      NSTATE = 0
      NVECS  = 0
      CALL SEQOPN(NFT12,'CIVECTR','UNKNOWN',.FALSE.,'UNFORMATTED')
      CALL SEQREW(NFT12)
      IF(MASWRK) READ(NFT12,ERR=2343,END=2343) NSTATE,NVECS
      GO TO 2344
C
 2343 CONTINUE
      NSTATE=0
      NVECS =0
C
C Let other nodes know if anything was read
C
 2344 CONTINUE
      IF (GOPARR) CALL DDI_BCAST(2507,'I',NSTATE,1,MASTER)
      IF (GOPARR) CALL DDI_BCAST(2508,'I',NVECS ,1,MASTER)
C
C If nothing read, there is a serious problem somewhere.
C
      IF (NVECS.NE.NCI) THEN
         IF (SOME) WRITE(IW,9005) NVECS,NCI
         CALL ABRT
      ENDIF
C
C Read previous reference CI eigenvectors for states
C      IPTST(i),i=1,NPTST
C
      IF (SOME) WRITE(IW,*)
      IF (SOME) WRITE(IW,9007) (IPTST(I),I=1,NPTST)
C
      MST = 1
      DO 100 ISTATE = 1,NSTATE
         IF (ISTATE.NE.IPTST(MST)) THEN
            CALL SEQADV(NFT12)
            GOTO 100
         ELSE
            CALL SQREAD(NFT12,CI(1,MST),NVECS)
            MST = MST + 1
            IF (MST.GT.NPTST) GOTO 109
         ENDIF
  100 CONTINUE
  109 CONTINUE
C
      CALL SEQREW(NFT12)
      DSKWRK = DSKSAV
C
C  ----------------------------------------------------
C  NOW TO WORK OUT THE COMPLETE MRPT ENERGY/HAMILTONIAN
C  ----------------------------------------------------
C
      DO I=1,NTMPSZ*NPTST
         TMP1(I) = 0.0D+00
         TMP2(I) = 0.0D+00
         TMP3(I) = 0.0D+00
         TMP4(I) = 1.0D+00
      ENDDO
C
      IF (NPTST.GT.1) GOTO 5555
C
C  **** BELOW IS ONLY FOR SINGLE STATE MRPT *****
C
C INITIALIZE CONTRIBUTIONS FROM ALL POSSIBLE CLASSES OF EXCITED DETS
C
C 1E- INTERNALLY EXCITED DETERMINANTS
C
      EVA = 0.0D+00
C
C 2E- INTERNALLY EXCITED DETERMINANTS
C
      EVVAA = 0.0D+00
C
C 1E- EXTERNALLY EXCITED DETERMINANTS
C
      EVE = 0.0D+00
      EAE = 0.0D+00
C
C 2E- INTERNALLY-EXTERNALLY EXCITED DETERMINANTS
C
      EVVAE = 0.0D+00
      EVAAE = 0.0D+00
C
C 2E- EXTERNALLY EXCITED DETERMINANTS
C
      EVVEE = 0.0D+00
      EVAEE = 0.0D+00
      EAAEE = 0.0D+00
C
      CALL TSECND(ET0)
      IF (NA.EQ.NB) THEN
C
      CALL HMRPT0(SI1,SI2,SVOOO,SVOVO,EFCK,EPT0(1),CI,
     *             NVAL,NACT,NEXT,NCI,NA,NB,IACON1,IBCON1,
     *             IACON2,IBCON2,
     *             NALP,NBLP,ISYMA,ISYMB,ISPA,ISPB,
     *             NSYM,IMUL,ITAB,IOB,INPT,IFA,
     *             TMP1,TMP2,TMP3,TMP4,NTMPSZ,
     *             EVA,EVVAA,EVE,EAE,EVVAE,EVAAE,EVVEE,EVAEE,EAAEE)
C
      ELSE
C
      CALL HMRPT(SI1,SI2,SVOOO,SVOVO,EFCK,EPT0(1),CI,
     *             NVAL,NACT,NEXT,NCI,NA,NB,IACON1,IBCON1,
     *             IACON2,IBCON2,
     *             NALP,NBLP,ISYMA,ISYMB,ISPA,ISPB,
     *             NSYM,IMUL,ITAB,IOB,INPT,IFA,
     *             TMP1,TMP2,TMP3,TMP4,NTMPSZ,
     *             EVA,EVVAA,EVE,EAE,EVVAE,EVAAE,EVVEE,EVAEE,EAAEE)
C
      ENDIF
C
      CALL TSECND(ET1)
      ELAP = ET1 - ET0
      IF (SOME) WRITE(IW,9010) ELAP
C
      CALL DDI_GSUMF(2504,EVA,1)
      CALL DDI_GSUMF(2504,EVVAA,1)
      CALL DDI_GSUMF(2504,EVE,1)
      CALL DDI_GSUMF(2504,EAE,1)
      CALL DDI_GSUMF(2504,EVVAE,1)
      CALL DDI_GSUMF(2504,EVAAE,1)
      CALL DDI_GSUMF(2504,EVVEE,1)
      CALL DDI_GSUMF(2504,EVAEE,1)
      CALL DDI_GSUMF(2504,EAAEE,1)
C
      EMRPT=EVA+EVVAA+EVE+EAE+EVVAE+EVAAE+EVVEE+EVAEE+EAAEE
      ETMRP=ESTATE(IPTST(1))+EMRPT
C
      IF (MASWRK) WRITE(IW,9015) EMRPT,ETMRP
C
C Print breakdown according to excited determinant class
C
      IF (SOME) THEN
         WRITE(IW,9020)
         WRITE(IW,9030)
     *   EVA,EVE,EAE,EVVAA,EVVAE,EVAAE,EVVEE,EVAEE,EAAEE,EMRPT
      ENDIF
C
C Set up the right E for possible numerical geometry optimzation
C
      E = ESTATE(IPTST(1)) + EMRPT
      EMP2 = ESTATE(IPTST(1)) + EMRPT
C
      RETURN
C
C *** END OF SINGLE STATE MRPT ***
C
 5555 CONTINUE
C
C  **** MULTISTATE MRPT ****
C
      CALL TSECND(ET0)
      IF (NA.EQ.NB) THEN
C
      CALL MMRPT0(SI1,SI2,SVOOO,SVOVO,EFCK,EPT0,CI,
     *             NVAL,NACT,NEXT,NCI,NA,NB,IACON1,IBCON1,
     *             IACON2,IBCON2,
     *             NALP,NBLP,ISYMA,ISYMB,ISPA,ISPB,
     *             NSYM,IMUL,ITAB,IOB,INPT,IFA,
     *             TMP1,TMP2,TMP3,TMP4,NTMPSZ,NPTST,
     *             EF,EL,EC)
C
      ELSE
C
      CALL MMRPT(SI1,SI2,SVOOO,SVOVO,EFCK,EPT0,CI,
     *             NVAL,NACT,NEXT,NCI,NA,NB,IACON1,IBCON1,
     *             IACON2,IBCON2,
     *             NALP,NBLP,ISYMA,ISYMB,ISPA,ISPB,
     *             NSYM,IMUL,ITAB,IOB,INPT,IFA,
     *             TMP1,TMP2,TMP3,TMP4,NTMPSZ,NPTST,
     *             EF,EL,EC)
C
      ENDIF
C
      CALL TSECND(ET1)
      ELAP = ET1 - ET0
      IF(SOME) WRITE(IW,9012) ELAP
C
C PRINT OUT SECOND-ORDER HAMILTONIAN BETWEEN STATES
C
      NSEF = NPTST*NPTST
      CALL DDI_GSUMF(2504,EF,NSEF)
C
      IF (SOME) WRITE(IW,9040)
      DO II=1,NPTST
      DO JJ=1,II-1
      EF((JJ-1)*NPTST+II)=(EF((JJ-1)*NPTST+II)+
     *                     EF((II-1)*NPTST+JJ))/2.0D+00
      ENDDO
      IF (SOME) WRITE(IW,9050) (EF((KK-1)*NPTST+II),KK=1,II)
      ENDDO
C
C PRINT OUT HAMILTONIAN BETWEEN STATES UP TO SECOND-ORDER
C
      IF (SOME) WRITE(IW,9060)
      DO II=1,NPTST
         EF((II-1)*NPTST+II)=EF((II-1)*NPTST+II)+ESTATE(IPTST(II))
      IF (SOME) WRITE(IW,9050) (EF((KK-1)*NPTST+II),KK=1,II)
      ENDDO
C
C DIAGONALIZE HAMILTONIAN TO OBTAIN MCQDPT ENERGIES AND PRINT RESULTS
C
      IX = 0
      DO II=1,NPTST
         DO JJ=1,II
            IX = IX + 1
            F(IX) = EF((JJ-1)*NPTST+II)
         ENDDO
      ENDDO
      CALL EVVRSP(-1,NPTST,NPTST,(NPTST*(NPTST+1))/2,NPTST,
     *            F,B,IWRK2,EL,EF,0,IERR)
C
C        --- Print results for all states ----
C        Note that there isn't a mechanism in place to name a specific
C        state's MP2 energy, so return a value anyone trying numerical
C        gradients on should recognize as daft.
C
      IF (SOME) THEN
         WRITE(IW,9065)
         DO II=1,NPTST
            WRITE(IW,9070) IPTST(II),EL(II)
         ENDDO
         WRITE(IW,*)
      END IF
      EMP2 = 0.0D+00
C
C AND THAT'S ALL FOLKS !!!!!!!!
C
      RETURN
C
 9005 FORMAT(/1X,'ERROR, NUMBER OF VECTORS STORED=',I5,
     *           ' NOT EQUAL TO NCI=',I5/
     *        1X,'(THIS MAY BE DUE TO A GARBAGE -CIVECTR- FILE',
     *           ' LEFT OVER FROM AN EARLIER RUN.)')
 9007 FORMAT(1X,'INITIAL CI VECTORS READ FROM DISK, STATES =',10I4)
 9010 FORMAT(/1X,'TIME FOR 2ND ORDER ENERGY E(2) CALCULATION :',F11.1)
 9012 FORMAT(/1X,'TIME FOR 2ND ORDER HAMILTONIAN CALCULATION :',F11.1)
 9015 FORMAT(/1X,
     *   '                    2ND ORDER ENERGY CORRECTION  = ',F20.10/
     *1X,'TOTAL MRPT2, E(MP2) 0TH + 1ST + 2ND ORDER ENERGY = ',F20.10)
 9020 FORMAT(/1X,
     * 'BREAKDOWN OF E(2) ACCORDING TO CLASS OF EXCITED DETERMINANT'//
     * 1X,' **** NOTE **** THIS MEANS THAT THE E(2) ENERGY IS SORTED',
     *    ' ACCORDING TO'/
     * 1X,'CONTRIBUTIONS FROM EXCITED DETERMINANTS, NOT ACCORDING TO',
     *    ' EXCITATION TYPES:'/
     * 5X,'V = VALENCE, A = ACTIVE, E = EXTERNAL'//
     * 18X,' EXTERNAL DETERMINANT CREATED BY:',8X,'E(2)')
 9030 FORMAT(/45X,'V -> A ',F15.9/
     *     45X,'V -> E ',F15.9/
     *     45X,'A -> E ',F15.9/
     *     44X,'VV -> AA',F15.9/
     *     44X,'VV -> AE',F15.9/
     *     11X,'(2 ELECTRONS ARE DIFFERENT SPIN) VA -> AE',F15.9/
     *     44X,'VV -> EE',F15.9/
     *     44X,'VA -> EE',F15.9/
     *     44X,'AA -> EE',F15.9/
     *     44X,'------------------------'/
     *     46X,'TOTAL ',F15.9//)
 9040 FORMAT(/1X,'*** 2ND ORDER HAMILTONIAN BETWEEN STATES       ***'/)
 9050 FORMAT(1X,10F16.9)
 9060 FORMAT(/1X,'*** HAMILTONIAN BETWEEN STATES UP TO 2ND ORDER ***'
     *       /1X,'*** DIAGONAL ELEMENTS EQUAL MRPT2 ENERGIES     ***'/)
 9065 FORMAT(/1X,'*** AFTER DIAGONALIZATION, MCQDPT ENERGIES ARE ***'/)
 9070 FORMAT(1X,
     *   '    CI STATE ',I4,'                MCQDPT E(MP2) = ',F20.10)
C
      END
C
C*MODULE DEMRPT  *DECK DEMRDM1
C     -------------------------------
      SUBROUTINE DEMRDM1(NPRINT,NST,IST)
C     -------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL SOME,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (MXRT=100, MXATM=2000)
C
      COMMON /CIFILS/ NFT11,NFT12,NFT13,NFT14,NFT15,NFT16,IDAF20,NEMEMX
      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 /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 /FUNCT / E,EGRAD(3,MXATM)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,MA,MB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IJKT,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      DATA CHECK/8HCHECK   /
C
      DIMENSION IST(NST)
C
      SOME = MASWRK  .AND.  NPRINT.NE.-5
C
C        allocate memory for one particle density matrix.
C
      M1 = NACT
      M2 = (M1*M1+M1)/2
      L1 = NUM
      L2 = (L1*L1+L1)/2
      L3 = L1*L1
      NSYM = 2**IGPDET
      NTOT = NACT + NCORSV
C
      CALL VALFM(LOADFM)
      LCI    = LOADFM + 1
      LDM1   = LCI    + NCI
C
      LIBO = LDM1 + M2
      LDAO = LIBO + NTOT
      LVAO   = LDAO   + L2
      LVNO   = LVAO   + L3
      LOCCNO = LVNO   + L3
      LIWRK  = LOCCNO + L1
      LWRK   = LIWRK  + M1
      LSCR   = LWRK   + 8*M1
      LIFA   = LSCR   + M1
      LAST   = LIFA   + (NACT+1)*(NACT+1)
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
C
      IF(EXETYP.EQ.CHECK) THEN
         CALL VCLR(X(LDAO)  ,1,L2)
         CALL VCLR(X(LVNO)  ,1,L3)
         CALL VCLR(X(LOCCNO),1,L1)
         CALL DAWRIT(IDAF,IODA,X(LDAO)  ,L2,16,0)
         CALL DAWRIT(IDAF,IODA,X(LVNO)  ,L3,19,0)
         CALL DAWRIT(IDAF,IODA,X(LOCCNO),L1,21,0)
      END IF
C
      CALL BINOM6(X(LIFA),NACT)
      CALL MATME1(NORB,NCOR,NA,NB,X(LIFA),NSYM,IIS)
      CALL DAREAD(IDAF,IODA,X(LIBO),NTOT,262,1)
      CALL CORTRA(X(LIBO),NTOT,NCORSV)
      CALL VALFM(LOADFM)
      LIWRK1 = LOADFM + 1
      LAST  = LIWRK1 + IIS
      NEED1 = LAST - LOADFM - 1
      CALL GETFM(NEED1)
      IF(EXETYP.EQ.CHECK) GO TO 580
C
C        set the energy to the root whose properties will be computed
C
      E = ESTATE(NST)
C
C        generate one particle density matrix for each state
C
      CALL SEQREW(NFT12)
      IF(MASWRK) READ(NFT12) NSTATS,NDETS
      IF (GOPARR) CALL DDI_BCAST(2503,'I',NSTATS,1,MASTER)
      IF (GOPARR) CALL DDI_BCAST(2504,'I',NDETS ,1,MASTER)
C
      IF(NSTATS.NE.K  .OR.  NDETS.NE.NCI) THEN
         IF(MASWRK) WRITE(IW,9250) NSTATS,NDETS,K,NCI
         CALL ABRT
      END IF
C
      CALL SEQOPN(NFT15,'WORK15','UNKNOWN',.FALSE.,'UNFORMATTED')
      CALL SEQREW(NFT15)
C
      MST = 1
      DO 550 JST=1,K
         IF(JST.NE.IST(MST)) THEN
            CALL SEQADV(NFT12)
            GO TO 550
         END IF
C
         CALL SQREAD(NFT12,X(LCI),NCI)
C
         IF(SOME) WRITE(IW,9210) JST
         IF(SOME) WRITE(IW,9220) JST,ESTATE(JST)
C
         CALL MATRD1(IW,X(LDM1),M2,NORB,NCOR,NA,NB,X(LCI),NCI,
     *               X(LIFA),X(LIWRK1),IIS,X(LIBO),IGPDET,KSTSYM,NSYM)
C
         IF(SOME) THEN
            WRITE(IW,9230)
            CALL PRTRI(X(LDM1),NORB)
         END IF
C
C DUMP ONTO NFT15 THE ONE-ELECTRON DENSITY MATRIX
C
         CALL SQWRIT(NFT15,X(LDM1),(NORB*(NORB+1))/2)
C
         MST = MST + 1
         IF (MST.GT.NST) GOTO 555
C
  550 CONTINUE
C
  555 CONTINUE
      CALL SEQREW(NFT15)
      CALL SEQREW(NFT12)
C
  580 CONTINUE
      CALL RETFM(NEED1)
      CALL RETFM(NEED)
      IF(SOME) WRITE(IW,9240)
      IF(SOME) CALL TIMIT(1)
      RETURN
C
 9210 FORMAT(/5X,27(1H-)/5X,'ONE PARTICLE DENSITY MATRIX'/5X,27(1H-)//
     *  1X,'DENSITY MATRIX WILL BE SAVED FOR PROPERTIES OF STATE',I4)
 9220 FORMAT(/1X,'CI EIGENSTATE',I4,' TOTAL ENERGY =',F20.10)
 9230 FORMAT(/1X,'1-PARTICLE DENSITY MATRIX IN MO BASIS')
 9240 FORMAT(1X,'..... DONE WITH ONE PARTICLE DENSITY MATRIX .....')
 9250 FORMAT(/1X,'***** ERROR IN -DETDM1- ROUTINE *****'/
     *       1X,'CI EIGENVECTOR FILE HAS DATA FOR NSTATE,NDETS=',I3,I10/
     *       1X,'BUT THE PRESENT CALCULATION HAS NSTATE,NDETS=',I3,I10)
      END
C
C*MODULE DEMRPT  *DECK HMRPT
C     ----------------------------------------------------------
      SUBROUTINE HMRPT(SI1,SI2,SVOOO,SVOVO,EFCK,EPT0,CI,
     *             NVAL,NACT,NEXT,NCI,NA,NB,IACON1,IBCON1,
     *             IACON2,IBCON2,
     *             NALP,NBLP,ISYMA,ISYMB,ISPA,ISPB,
     *             NSYM,IMUL,ITAB,IOB,INPT,IFA,
     *             TMP1,TMP2,TMP3,TMP4,NTMPSZ,
     *             EVA,EVVAA,EVE,EAE,EVVAE,EVAAE,EVVEE,EVAEE,EAAEE)
C     ----------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      INTEGER POSDET
      DIMENSION SI1(*),SI2(*),SVOOO(NEXT,*)
      DIMENSION SVOVO(*)
      DIMENSION EFCK(*),CI(NCI)
      DIMENSION IACON1(NA+2),IBCON1(NA+2)
      DIMENSION IACON2(NA+2),IBCON2(NA+2)
      DIMENSION ISYMA(NALP),ISYMB(NBLP),ISPA(NALP),ISPB(NBLP)
      DIMENSION IMUL(NSYM,NSYM),ITAB(NSYM),IOB(*)
      DIMENSION INPT(*)
      DIMENSION IFA(0:NACT,0:NACT)
      DIMENSION TMP1(NTMPSZ),TMP2(NTMPSZ),TMP3(NTMPSZ),TMP4(NTMPSZ)
C
      ICOUNT = 0
      M1 = NVAL+NACT
      M2 = (M1*(M1+1))/2
      NQS = M1 + 1
      NQQ = M1 + NEXT
C
      IF (NA.LT.NACT) THEN
         N1A =  IFA(NACT,NA+1)
      ELSE
         N1A = 0
      ENDIF
      IF (NB.LT.NACT) THEN
         N1B =  IFA(NACT,NB+1)
      ELSE
         N1B = 0
      ENDIF
C
      IF (NA.LT.NACT-1) THEN
         N2A = IFA(NACT,NA+2)
      ELSE
         N2A = 0
      ENDIF
      IF (NB.LT.NACT-1) THEN
         N2B = IFA(NACT,NB+2)
      ELSE
         N2B = 0
      ENDIF
C
      IF (NA.GE.2) THEN
         ND1A = IFA(NACT,NA-1)
      ELSEIF (NA.EQ.1) THEN
         ND1A = 1
      ELSEIF (NA.EQ.0) THEN
         ND1A = 0
      ENDIF
C
      IF (NB.GE.2) THEN
         ND1B = IFA(NACT,NB-1)
      ELSEIF (NB.EQ.1) THEN
         ND1B = 1
      ELSEIF (NB.EQ.0) THEN
         ND1B = 0
      ENDIF
C
      IF (NA.GE.3) THEN
         ND2A = IFA(NACT,NA-2)
      ELSEIF (NA.EQ.2) THEN
         ND2A = 1
      ELSEIF (NA.LE.1) THEN
         ND2A = 0
      ENDIF
C
      IF (NB.GE.3) THEN
         ND2B = IFA(NACT,NB-2)
      ELSEIF(NB.EQ.2) THEN
         ND2B = 1
      ELSEIF(NB.LE.1) THEN
         ND2B = 0
      ENDIF
C
      E0V = 0.0D+00
      ISYV = 1
      DO II=1,NVAL
         E0V = E0V + EFCK(II)
         ISYV = IMUL(ISYV,IOB(II))
      ENDDO
C
C  LOOP OVER ALL POSSIBLE EXCITED DETERMINANTS, LOTS OF DIFFERENT TYPES
C
C ------------------------------------------------------------------
C  FIRST LOOP OVER ZEROTH ORDER ALPHAS, ORBITALS NUMBERED AS ACTIVE,
C  1,2,etc
C ------------------------------------------------------------------
C
      DO II=1,NA
         IACON1(II) = II
      ENDDO
C
      E0AV = E0V
      ISYAV = ISYV
C
      CALL DDI_DLBNEXT(MY_TASK)
C
      DO 2000 IJK=1,NALP
C
        IF (IJK-1.EQ.MY_TASK) THEN
C
         ICAT = ISPA(IJK)
         ISA1 = IMUL(ISYMA(IJK),ISYAV)
         ITAS = ITAB(ISA1)
         E0A0 = E0AV
         DO II=1,NA
            E0A0 = E0A0 + EFCK(IACON1(II)+NVAL)
         ENDDO
         E0AD = EPT0 - E0A0 - E0V
C
C  LOOP OVER 1ST AND 2ND ORDER BETAS
C
         IF (NVAL.EQ.0) GOTO 2901
C
C -------------------------------------------
C RELOOP OVER 1ST ORDER BETA VAL -> ACTIVE
C -------------------------------------------
C
C LOOP OVER 1 UP BETAS
C
      DO II=1,NB+1
         IBCON1(II) = II
      ENDDO
      DO 2900 IJB=1,N1B
         ISYB = ISYV
         E0B0 = E0AD
         DO II=1,NB+1
            E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
            ISYB = IMUL(ISYB,IOB(IBCON1(II)+NVAL))
         ENDDO
         ISYL = IMUL(ITAS,ISYB)
C
C LOOP OVER SINGLE DEXCITATIONS OUT OF ACTIVE
C
         DO 2910 IEL=1,NB+1
            IA = IBCON1(IEL) + NVAL
            IS1 = IOB(IA)
            IF (IS1.NE.ISYL) GOTO 2910
C
C DETERMINE 0TH ORDER BETA, POS/PERM
C
          CALL STR0VA(IBCON1,IBCON2,NB+1,IEL,NVAL,NVAL,IPER)
          IPB0 = POSDET(NACT,NB,IBCON2,IFA)
          ITP0 = ICAT + ISPB(IPB0)
          COEFF = CI(ITP0)*IPER
C
C LOOP OVER BETA VALENCE
C
          DO 2920 IV=1,NVAL
             IS2 = IOB(IV)
             IF (IS1.NE.IS2) GOTO 2920
             TMP4(IV) = E0B0 + EFCK(IV)
C
C MATRIX ELEMENT
C
       CALL ME0VA1B(IV,IA,IBCON2,NB,IACON1,NA,NVAL,INPT,SI1,SI2,T)
       TMP3(IV) = TMP3(IV) + T*COEFF
C
 2920     CONTINUE
C
C END OF LOOP OVER BETA VALENCE
C
 2910    CONTINUE
C
C END OF PURE SINGLE BETA DEXCITATIONS OUT OF ACTIVE
C
C NOW FOR DOUBLE DEXCITATIONS
C  DOUBLE DEXCITATIONS MUST !!!!! INCLUDE THE SINGLES ABOVE !!!!!
C  START WITH THIS TYPE FIRST, IE BETA IA(?) -> IV
C
      DO 2930 IEL=1,NB+1
         IA = IBCON1(IEL)+NVAL
         JA = IA - NVAL
         IS1 = IOB(IA)
         CALL STR0VA(IBCON1,IBCON2,NB+1,IEL,NVAL,NVAL,IPER)
         IPB0 = POSDET(NACT,NB,IBCON2,IFA)
         ICAB = ISPB(IPB0)
C
C  2ND EXCITATION: BETA ACT (IA2 > IA) -> ACT (JJA)
C  TOTAL = BETA ( IA < IA2 -> IV,JJA)
C
         DO 2940 IEL2=IEL,NB
            IA2 = IBCON2(IEL2)+NVAL
            IS2 = IOB(IA2)
            IP1 = IMUL(IS1,IS2)
C
         IST = 1
         IEN = IBCON2(1)-1
         DO 2950 KKJ=1,NB+1
            DO 2952 JJ=IST,IEN
               IF (JJ.EQ.JA) GOTO 2952
               JJA = JJ + NVAL
               IS3 = IOB(JJA)
               IPT = IMUL(IS3,IP1)
               IF (IPT.NE.ISYL) GOTO 2952
C
               MA = MAX(IA2,JJA)
               MI = MIN(IA2,JJA)
               IA3A2 = INPT(MA) + MI
               MA = MAX(IA,JJA)
               MI = MIN(IA,JJA)
               IA3A = INPT(MA) + MI
C
C DETERMINE NEW 0TH ORDER BETA, POS/PERM AND MATRIX ELEMENT
C
          CALL RET1DET(IBCON2,IACON2,NB,IEL2,JJ,0,KKJ,ISWAP2)
          IPER2 = (-1)**ISWAP2
          IPERT = IPER*IPER2
          IPB2 = POSDET(NACT,NB,IACON2,IFA)
          ITP0 = ICAT + ISPB(IPB2)
          COEFF = CI(ITP0)*IPERT
C
C LOOP OVER BETA VALENCE
C
          DO 2960 IV=1,NVAL
             IS4 = IOB(IV)
             IP2 = IMUL(IS4,IS3)
             IF (IP1.NE.IP2) GOTO 2960
             TMP4(IV) = E0B0 + EFCK(IV)
C
C MATRIX ELEMENT
C
         IAV = INPT(IA) + IV
         IA2V = INPT(IA2) + IV
         INT1 = INPT(IA3A2) + IAV
         MA = MAX(IA3A,IA2V)
         MI = MIN(IA3A,IA2V)
         INT2 = INPT(MA) + MI
         T = (SI2(INT1) - SI2(INT2))*COEFF
         TMP3(IV) = TMP3(IV) + T
C
 2960     CONTINUE
C
C END OF LOOP OVER BETA VALENCE
C
 2952       CONTINUE
            IST = IBCON2(KKJ)+1
            IEN = IBCON2(KKJ+1)-1
            IF (KKJ.EQ.NB) IEN=NACT
 2950    CONTINUE
C
 2940    CONTINUE
C
C END OF 2ND DEXCITATIONS
C
C  NOW FOR 2ND EXCITATION: ALPHA ACT (IA2) -> ACT (JJA)
C  TOTAL = ( IA(B),IA2(A) -> IV(B),JJA(A) )
C
      DO 2970 IEL2=1,NA
         IA2 = IACON1(IEL2)+NVAL
         IS2 = IOB(IA2)
         IP1 = IMUL(IS1,IS2)
C
         IST = 1
         IEN = IACON1(1)-1
         DO 2980 KKJ=1,NA+1
            DO 2982 JJ=IST,IEN
               JJA = JJ + NVAL
               IS3 = IOB(JJA)
               IPT = IMUL(IP1,IS3)
               IF (IPT.NE.ISYL) GOTO 2982
C
          MA = MAX(IA2,JJA)
          MI = MIN(IA2,JJA)
          IA3A2 = INPT(MA) + MI
C
C DETERMINE NEW 0TH ORDER ALPHA, POS/PERM AND MATRIX ELEMENT
C
          CALL RET1DET(IACON1,IACON2,NA,IEL2,JJ,0,KKJ,ISWAP2)
          IPER2 = (-1)**ISWAP2
          IPERT = IPER*IPER2
          IPA2 = POSDET(NACT,NA,IACON2,IFA)
          ITP0 = ISPA(IPA2) + ICAB
          COEFF = CI(ITP0)*IPERT
C
C LOOP OVER BETA VALENCE
C
          DO 2990 IV=1,NVAL
             IS4 = IOB(IV)
             IP2 = IMUL(IS4,IS3)
             IF (IP1.NE.IP2) GOTO 2990
             TMP4(IV) = E0B0 + EFCK(IV)
C
C MATRIX ELEMENT
C
         IAV = INPT(IA) + IV
         MA = MAX(IA3A2,IAV)
         MI = MIN(IA3A2,IAV)
         INT = INPT(MA) + MI
         T = SI2(INT)*COEFF
         TMP3(IV) = TMP3(IV) + T
C
 2990     CONTINUE
C
C END OF LOOP OVER BETA VALENCE
C
 2982       CONTINUE
            IST = IACON1(KKJ)+1
            IEN = IACON1(KKJ+1)-1
            IF (KKJ.EQ.NA) IEN=NACT
 2980    CONTINUE
C
 2970 CONTINUE
C
C END OF 2ND EXCITATION: ALPHA ACT (IA2) -> ACT (JJA)
C
 2930 CONTINUE
C
C END OF SINGLE DEXCITES IA -> IV
C
         DO II=1,NVAL
            EVA = EVA + (TMP3(II)*TMP3(II))/TMP4(II)
            TMP3(II) = 0.0D+00
            TMP4(II) = 1.0D+00
         ENDDO
C
         CALL ADVANC(IBCON1,NB+1,NACT)
 2900 CONTINUE
 2901 CONTINUE
C
C END OF LOOP OVER 1 UP BETAS
C
C -------------------------------------------
C END OF RELOOP OVER 1ST ORDER BETA VAL -> ACTIVE
C -------------------------------------------
C
C --------------------------------------------
C 1ST ORDER BETA ACT -> EXTERNAL (IA(?) -> IE)
C --------------------------------------------
C
C  LOOP OVER DOWN 1 BETAS FIRST
C
            DO II=1,NB-1
               IBCON1(II) = II
            ENDDO
            DO 2230 IJB=1,ND1B
              ISYB1 = ISYV
              E0B0 = E0AD
              DO II=1,NB-1
                 ISYB1 = IMUL(ISYB1,IOB(IBCON1(II)+NVAL))
                 E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
              ENDDO
              ISYL = IMUL(ISYB1,ITAS)
C
C SINGLE DEXCITATIONS, BETA IE -> IA (?)
C
              IST = 1
              IEN = IBCON1(1)-1
              IF (NB.EQ.1) IEN=NACT
              DO 2240 KKJ=1,NB
              DO 2242 JJ=IST,IEN
                 JJE = JJ + NVAL
                 IS2 = IOB(JJE)
                 IF (IS2.NE.ISYL) GOTO 2242
C
C DETERMINE 0TH ORDER BETA STRING, POSITION/PERM AND MATRIX ELEMENT
C
          CALL STR0AE(IBCON1,IBCON2,NB,KKJ,JJ,IPER)
          IPB0 = POSDET(NACT,NB,IBCON2,IFA)
          ITP0 = ICAT + ISPB(IPB0)
          COEFF = CI(ITP0)*IPER
C
C LOOP OVER EXTERNAL ORBS
C
         DO 2215 IE=1,NEXT
            JE = IE + M1
            IS1 = IOB(JE)
            IF (IS1.NE.IS2) GOTO 2215
            TMP4(IE) = E0B0 - EFCK(JE)
C
          CALL ME0AE1B(JJE,IE,IBCON1,NB,IACON1,NA,NVAL,NACT,NEXT,
     *    INPT,SI1,SVOOO,M2,T)
C
          TMP3(IE) = TMP3(IE) + COEFF*T
C
 2215    CONTINUE
C
 2242         CONTINUE
              IST = IBCON1(KKJ)+1
              IEN = IBCON1(KKJ+1)-1
              IF (KKJ.EQ.NB-1) IEN=NACT
 2240         CONTINUE
C
C NOW FOR DOUBLE DEXCITATIONS
C  DOUBLE DEXCITATIONS MUST !!!!! INCLUDE THE SINGLES ABOVE !!!!!
C  START WITH THIS TYPE FIRST, IE BETA IE -> IA(?)
C
              IST = 1
              IEN = IBCON1(1)-1
              IF (NB.EQ.1) IEN=NACT
              DO 2250 KKJ=1,NB
              DO 2252 JJ=IST,IEN
                 IA = JJ + NVAL
                 IS1 = IOB(IA)
                 CALL STR0AE(IBCON1,IBCON2,NB,KKJ,JJ,IPER)
                 IPB0 = POSDET(NACT,NB,IBCON2,IFA)
                 ICAB = ISPB(IPB0)
C
C 2ND EXCITATION: BETA ACT (IA2.NE.IA) -> ACT (JJA > IA)
C  TOTAL = BETA (IE,IA2 -> IA < JJA )
C
                 DO 2255 IEL=1,NB
                    IF (IEL.EQ.KKJ) GOTO 2255
                    IA2 = IBCON2(IEL)+NVAL
                    IS2 = IOB(IA2)
                    IP1 = IMUL(IS1,IS2)
C
C  HAVE ENSURED THAT IA2.NE.IA, NOW TO ENSURE THAT JJA > IA
C
                 IST2=JJ+1
                 IEN2=IEN
                 DO 2258 KKJ2=KKJ+1,NB+1
                 DO 2257 JJ2=IST2,IEN2
                    JJA = JJ2 + NVAL
                    IS3 = IOB(JJA)
                    IPT = IMUL(IP1,IS3)
                    IF (IPT.NE.ISYL) GOTO 2257
C
C  DETERMINE NEW 0TH ORDER BETA, POS/PERM AND MATRIX ELEMENT
C
              CALL RET1DET(IBCON2,IACON2,NB,IEL,JJ2,0,KKJ2,ISWAP2)
              IPER2 = (-1)**ISWAP2
              IPERT = IPER*IPER2
              IPB2 = POSDET(NACT,NB,IACON2,IFA)
              ITP0 = ICAT + ISPB(IPB2)
              COEFF = CI(ITP0)*IPERT
C
              MA = MAX(IA,IA2)
              MI = MIN(IA,IA2)
              IAA2 = INPT(MA) + MI
              MA = MAX(IA2,JJA)
              MI = MIN(IA2,JJA)
              IA2A3 = INPT(MA) + MI
              IAA2A3 = (IA-1)*M2 + IA2A3
              IA3AA2 = (JJA-1)*M2 + IAA2
C
      DO 2217 IE=1,NEXT
         JE = IE + M1
         IS4 = IOB(JE)
         IP2 = IMUL(IS4,IS3)
         IF (IP1.NE.IP2) GOTO 2217
         TMP4(IE) = E0B0 - EFCK(JE)
C
C  ME = [IE,IA | IA2,JJA] - [IE,JJA | IA2,IA]
C
              T = SVOOO(IE,IAA2A3) - SVOOO(IE,IA3AA2)
              TMP3(IE) = TMP3(IE) + COEFF*T
C
 2217 CONTINUE
C
 2257            CONTINUE
                 IST2 = IBCON2(KKJ2)+1
                 IEN2 = IBCON2(KKJ2+1)-1
                 IF (KKJ2.EQ.NB) IEN2=NACT
 2258            CONTINUE
C
 2255            CONTINUE
C
C END OF 2ND EXCITATION: BETA ACT (IA2 -> JJA)
C
C 2ND EXCITATION: ALPHA ACT (IA2 -> JJA)
C  TOTAL = ( IE(B),IA2(A) -> IA(B),JJA(A) )
C
                 DO 2260 IEL2=1,NA
                    IA2 = IACON1(IEL2)+NVAL
                    IS2 = IOB(IA2)
                    IP1 = IMUL(IS1,IS2)
C
                 IST2 = 1
                 IEN2 = IACON1(1)-1
                 DO 2268 KKJ2=1,NA+1
                    DO 2267 JJ2=IST2,IEN2
                       JJA = JJ2 + NVAL
                       IS3 = IOB(JJA)
                       IPT = IMUL(IP1,IS3)
                       IF (IPT.NE.ISYL) GOTO 2267
C
C DETERMINE NEW 0TH ORDER ALPHA, POS/PERM AND MATRIX ELEMENT
C
            CALL RET1DET(IACON1,IACON2,NA,IEL2,JJ2,0,KKJ2,ISWAP2)
            IPER2 = (-1)**ISWAP2
            IPERT = IPER*IPER2
            IPA2 = POSDET(NACT,NA,IACON2,IFA)
            ITP0 = ISPA(IPA2) + ICAB
            COEFF = CI(ITP0)*IPERT
C
            MA = MAX(IA2,JJA)
            MI = MIN(IA2,JJA)
            IA2A3 = INPT(MA) + MI
            IAA2A3 = (IA-1)*M2 + IA2A3
C
      DO 2219 IE=1,NEXT
         JE = IE+M1
         IS4 = IOB(JE)
         IP2 = IMUL(IS4,IS3)
         IF (IP1.NE.IP2) GOTO 2219
         TMP4(IE) = E0B0 - EFCK(JE)
C
C ME = [IE,IA | IA2,JJA]
C
            T = SVOOO(IE,IAA2A3)
            TMP3(IE) = TMP3(IE) + COEFF*T
C
 2219 CONTINUE
C
 2267               CONTINUE
                    IST2 = IACON1(KKJ2)+1
                    IEN2 = IACON1(KKJ2+1)-1
                    IF (KKJ2.EQ.NA) IEN2=NACT
 2268            CONTINUE
C
 2260            CONTINUE
C
C END OF 2ND EXCITATION: ALPHA ACT (IA2 -> JJA)
C
 2252         CONTINUE
              IST = IBCON1(KKJ)+1
              IEN = IBCON1(KKJ+1)-1
              IF (KKJ.EQ.NB-1) IEN=NACT
 2250         CONTINUE
C
C END OF 1ST EXCITATION BETA IE -> IA(?)
C
         DO II=1,NEXT
            EAE = EAE + (TMP3(II)**2.0D+00)/TMP4(II)
            TMP3(II) = 0.0D+00
            TMP4(II) = 1.0D+00
         ENDDO
C
              CALL ADVANC(IBCON1,NB-1,NACT)
 2230      CONTINUE
C
C -----------------------------------------
C  END OF 1ST ORDER BETA ACT -> EXTERNAL
C -----------------------------------------
C
           IF (NVAL.EQ.0) GOTO 2101
C
C ----------------------------------------------------
C RELOOP LOOP OVER 2ND ORDER BETAS, IV1,IV2 -> IA1,IA2
C ----------------------------------------------------
C
C LOOP OVER 2 UP BETAS
C
      DO II=1,NB+2
         IBCON1(II) = II
      ENDDO
      DO 2100 IJB=1,N2B
         ISYB = ISYV
         E0B0 = E0AD
         DO II=1,NB+2
            ISYB = IMUL(ISYB,IOB(IBCON1(II)+NVAL))
            E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
         ENDDO
         ISYL = IMUL(ISYB,ITAS)
C
C LOOP OVER DEXCITATIONS FROM BETA ACTIVE IA1 < IA2
C
         DO 2110 IEL1=1,NB+2
            IA1 = IBCON1(IEL1)+NVAL
            IS1 = IOB(IA1)
            IA1T = INPT(IA1)
C
         DO 2120 IEL2=IEL1+1,NB+2
            IA2 = IBCON1(IEL2)+NVAL
            IS2 = IOB(IA2)
            IP1 = IMUL(IS1,IS2)
            IF (IP1.NE.ISYL) GOTO 2120
            IA2T = INPT(IA2)
C
      CALL STR0VVAA(IBCON1,IBCON2,NB+2,IEL1,IEL2,NVAL,
     *     NVAL,NVAL,IPER)
      IPB0 = POSDET(NACT,NB,IBCON2,IFA)
      ITP0 = ICAT + ISPB(IPB0)
      COEFF = CI(ITP0)*IPER
C
C LOOP OVER BETA VALENCE IV1 < IV2
C
         ICOUNT = 0
         DO 2130 IV1=1,NVAL
            IS3 = IOB(IV1)
            E0B0V = E0B0 + EFCK(IV1)
            IA1V1 = INPT(IA1) + IV1
            IA2V1 = INPT(IA2) + IV1
            IA2V1T = INPT(IA2V1)
C
         DO 2140 IV2=1,IV1-1
            ICOUNT = ICOUNT + 1
            IS4 = IOB(IV2)
            IP2 = IMUL(IS4,IS3)
            IF (IP1.NE.IP2) GOTO 2140
            TMP4(ICOUNT) = E0B0V + EFCK(IV2)
C
C MATRIX ELEMENT
C
            IA1V2 = IA1T + IV2
            IA2V2 = IA2T + IV2
            INT1 = INPT(IA2V2) + IA1V1
            INT2 = IA2V1T + IA1V2
            T = (SI2(INT1) - SI2(INT2))*COEFF
            TMP3(ICOUNT) = TMP3(ICOUNT) + T
C
 2140    CONTINUE
 2130    CONTINUE
C
C END OF LOOP OVER BETA VALENCE IV1 < IV2
C
 2120    CONTINUE
 2110    CONTINUE
C
C END OF DOUBLE BETA DEXCITATIONS FROM ACTIVE IA1 < IA2
C
         DO II=1,ICOUNT
            EVVAA = EVVAA + (TMP3(II)*TMP3(II))/TMP4(II)
            TMP3(II) = 0.0D+00
            TMP4(II) = 1.0D+00
         ENDDO
         ICOUNT = 0
C
         CALL ADVANC(IBCON1,NB+2,NACT)
 2100 CONTINUE
C
C END OF LOOP OVER 2 UP BETAS
C
C ----------------------------------------------------
C END RELOOP LOOP OVER 2ND ORDER BETAS, IV1,IV2 -> IA1,IA2
C ----------------------------------------------------
C
C ----------------------------------------------------
C RELOOP OVER 2ND ORDER BETAS, IV1,IV2 -> IA2,IE
C ----------------------------------------------------
C THESE INCLUDE ALSO IV1(A)<IV2(B) -> IA2(B),IE(A)
C                    IV1(A)=IV2(B) -> IA2(B),IE(A)
C                    IV1(A)>IV2(B) -> IA2(B),IE(A)
C ***
C
C LOOP OVER 1 UP BETAS
C
         DO II=1,NB+1
            IBCON1(II) = II
         ENDDO
         DO 2810 IJB=1,N1B
            ISYB=ISYV
            E0B0 = E0AD
            DO II=1,NB+1
               E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
               ISYB = IMUL(ISYB,IOB(IBCON1(II)+NVAL))
            ENDDO
            ISYL = IMUL(ITAS,ISYB)
C
C DOUBLE EXCITATIONS MUST INCLUDE ALPHA IE -> IV SPECIFIED ABOVE
C SECOND EXCITATION BETA (IA2 -> IV2)
C TOTAL = ( IE(A),IA2(B) -> IV(A),IV2(B) )
C
            DO 2820 IEL=1,NB+1
               IA2 = IBCON1(IEL)+NVAL
               IS1 = IOB(IA2)
               IF (IS1.NE.ISYL) GOTO 2820
C
C DETERMINE NEW 0TH ORDER BETA, POS/PERM
C
        CALL STR0VA(IBCON1,IBCON2,NB+1,IEL,NVAL,NVAL,IPER)
        IPB0 = POSDET(NACT,NB,IBCON2,IFA)
        ITP0 = ICAT + ISPB(IPB0)
        COEFF = CI(ITP0)*IPER
C
C LOOP OVER BETA VALENCE
C
        ICOUNT = 0
        DO 2830 IV1=1,NVAL
           IS2 = IOB(IV1)
           IP1 = IMUL(IS1,IS2)
           E0BV = E0B0 + EFCK(IV1)
           IA2V1 = INPT(IA2) + IV1
C
C LOOP OVER ALPHA VALENCE AND EXTERNAL
C
        DO 2840 IV2=1,IV1-1
           IS3 = IOB(IV2)
           E0BVV = E0BV + EFCK(IV2)
           IA2V2 = INPT(IA2) + IV2
           IV2A2V1 = (IV2-1)*M2 + IA2V1
           IV1A2V2 = (IV1-1)*M2 + IA2V2
C
        DO 2850 IE=1,NEXT
           JE = IE + M1
           IS4 = IOB(JE)
           IP2 = IMUL(IS4,IS3)
           IF (IP1.NE.IP2) GOTO 2850
           ICOUNT = ICOUNT + 1
           TMP4(ICOUNT) = E0BVV - EFCK(JE)
C
       T1 = SVOOO(IE,IV2A2V1)*COEFF
       T2 = SVOOO(IE,IV1A2V2)*COEFF
       TMP3(ICOUNT) = TMP3(ICOUNT) + T1
       TMP1(ICOUNT) = TMP1(ICOUNT) + T2
       TMP2(ICOUNT) = TMP2(ICOUNT) + (T1-T2)
C
 2850   CONTINUE
 2840   CONTINUE
C
C FOR IV2.EQ.IV1
C
           IS3 = IOB(IV1)
           E0BVV = E0BV + EFCK(IV1)
           IV2A2V1 = (IV1-1)*M2 + IA2V1
           DO 2870 IE=1,NEXT
              JE = IE + M1
              IS4 = IOB(JE)
              IP2 = IMUL(IS4,IS3)
              IF (IP1.NE.IP2) GOTO 2870
              ICOUNT = ICOUNT + 1
              TMP4(ICOUNT) = E0BVV - EFCK(JE)
C
       T1 = SVOOO(IE,IV2A2V1)*COEFF
       TMP3(ICOUNT) = TMP3(ICOUNT) + T1
C
 2870 CONTINUE
C
C END OF IV2.GE.IV1
C
 2830   CONTINUE
C
 2820       CONTINUE
C
C END OF DOUBLE DEXCITATIONS
C
         DO II=1,ICOUNT
            EVVAE = EVVAE + (TMP3(II)*TMP3(II)+
     *  TMP1(II)*TMP1(II)+
     *  TMP2(II)*TMP2(II))/TMP4(II)
            TMP3(II) = 0.0D+00
            TMP2(II) = 0.0D+00
            TMP1(II) = 0.0D+00
            TMP4(II) = 1.0D+00
         ENDDO
         ICOUNT = 0
C
            CALL ADVANC(IBCON1,NB+1,NACT)
 2810    CONTINUE
C
C ----------------------------------------------------
C END RELOOP OVER 2ND ORDER BETAS, IV1,IV2 -> IA1,IE
C ----------------------------------------------------
C
C ----------------------------------------------------
C LOOP OVER 2ND ORDER BETAS ( IV,IA -> IE1<IE2 )
C ----------------------------------------------------
C THESE EXCITATIONS ALSO INCLUDE IV(A),IA(B) -> IE1(A)<IE2(B)
C AND                            IV(A),IA(B) -> IE1(B)<IE2(A)
C AND                            IV(A),IA(B) -> IE1(A),IE1(B)
C
C LOOP OVER 1 DOWN BETAS
C
         IF (NVAL.EQ.0) GOTO 2531
         DO II=1,NB-1
            IBCON1(II) = II
         ENDDO
         DO 2530 IJB=1,ND1B
            ISYB0 = ISYV
            E0B0 = E0V
            DO II=1,NB-1
               E0B0 = E0B0 + EFCK(IBCON1(II)+NVAL)
               ISYB0 = IMUL(ISYB0,IOB(IBCON1(II)+NVAL))
            ENDDO
            IMS = IMUL(ISYB0,ITAS)
            E0B1 = EPT0-E0B0-E0A0
C
C LOOP OVER DEXCITATIONS INTO ACTIVE (IE2 -> IA)
C
            IST = 1
            IEN = IBCON1(1)-1
            IF (NB.EQ.1) IEN=NACT
            DO 2540 KKJ=1,NB
               DO 2542 JJ=IST,IEN
                  IA = JJ + NVAL
                  IS3 = IOB(IA)
                  IF (IS3.NE.IMS) GOTO 2542
C
C DETERMINE 0TH ORDER BETA STRING, POS/PERM
C
       CALL STR0AE(IBCON1,IBCON2,NB,KKJ,JJ,IPER2)
       IPB0 = POSDET(NACT,NB,IBCON2,IFA)
       ITP0 = ICAT + ISPB(IPB0)
       COEFF = CI(ITP0)*IPER2
C
C LOOP OVER DOUBLE BETA DEXCITATIONS ( IE1<IE2 -> IV,IA )
C
         ICOUNT = 0
         JDV = 0
         JDA = -M1 + IA
         DO 2500 JE1=NQS,NQQ
            IS1 = IOB(JE1)
            IP2 = IMUL(IS3,IS1)
            E0BE = E0B1 - EFCK(JE1)
            JDA = JDA + M1
            JDAV = (JDA*(JDA-1))/2
            JDAT = JDAV
            JDVT = (JDV*(JDV-1))/2 + IA
C
         DO 2510 IV=1,NVAL
            IS2 = IOB(IV)
            IPT = IMUL(IS2,IP2)
            E0BEV = E0BE + EFCK(IV)
            JDAT = JDAT + 1
            JDV = JDV + 1
            JDVT = JDVT + JDV - 1
C
         INT1 = -M1 + JDVT
         INT2 = -M1 + JDAT
         DO 2520 JE2=NQS,JE1-1
            INT1 = INT1 + M1
            INT2 = INT2 + M1
            IF (IOB(JE2).NE.IPT) GOTO 2520
C
            ICOUNT = ICOUNT + 1
            TMP4(ICOUNT) = E0BEV-EFCK(JE2)
C
C DETERMINE MATRIX ELEMENT
C
C ME = [IE1,IV | IE2,IA] - [IE1,IA | IE2,IV]
C
       T1 = SVOVO(INT1)*COEFF
       T2 = SVOVO(INT2)*COEFF
       TT = T1 - T2
C
       TMP1(ICOUNT) = TMP1(ICOUNT) + T1
       TMP2(ICOUNT) = TMP2(ICOUNT) + T2
       TMP3(ICOUNT) = TMP3(ICOUNT) + TT
C
 2520    CONTINUE
C
C IE1 = IE2
C
         IF (IS3.NE.IS2) GOTO 2510
         ICOUNT = ICOUNT + 1
         TMP4(ICOUNT) = E0BEV-EFCK(JE1)
         INT2 = INT2 + M1
         T1 = SVOVO(INT2)*COEFF
         TMP1(ICOUNT) = TMP1(ICOUNT) + T1
C
 2510    CONTINUE
         JDV = JDV + NACT
 2500    CONTINUE
C
C END OF DOUBLE BETA DEXCITATIONS ( IE1<IE2 -> IV,IA )
C
 2542          CONTINUE
               IST = IBCON1(KKJ)+1
               IEN = IBCON1(KKJ+1)-1
               IF (KKJ.EQ.NB-1) IEN=NACT
 2540       CONTINUE
C
C END OF EXCITATION INTO BETA ACTIVE
C
CFORNOW
       DO II=1,ICOUNT
          EVAEE = EVAEE +
     *    (TMP1(II)*TMP1(II)+TMP2(II)*TMP2(II)+TMP3(II)*TMP3(II))
     *    /TMP4(II)
          TMP1(II) = 0.0D+00
          TMP2(II) = 0.0D+00
          TMP3(II) = 0.0D+00
          TMP4(II) = 1.0D+00
       ENDDO
       ICOUNT = 0
C
            CALL ADVANC(IBCON1,NB-1,NACT)
 2530    CONTINUE
 2531    CONTINUE
C
C END OF 1 DOWN BETAS
C
C ------------------------------------------------
C END OF LOOP OVER 2ND ORDER BETAS (IV,IA -> IE1,IE2)
C ------------------------------------------------
C
 2101 CONTINUE
C
C ------------------------------------------------
C LOOP OVER 2ND ORDER BETAS (IA1<IA2 -> IE1<IE2)
C ------------------------------------------------
C
         DO II=1,NB-2
            IBCON1(II) = II
         ENDDO
         DO 2620 IJB=1,ND2B
            E0B0 = EPT0-E0V-E0A0
            ISB0 = ISYV
            DO II=1,NB-2
               E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
               ISB0 = IMUL(ISB0,IOB(IBCON1(II)+NVAL))
            ENDDO
C
C LOOP OVER DOUBLE BETA DEXCITATIONS ( IE1<IE2 -> IA1<IA2 )
C
            IST = 1
            IEN = IBCON1(1)-1
            IF (NB.EQ.2) IEN=NACT
            DO 2630 KKJ=1,NB-1
               DO 2632 JJ=IST,IEN
                  IA1 = JJ + NVAL
                  IS3 = IOB(IA1)
                  ISYBE1 = IMUL(ISB0,IS3)
                  CALL STR0AE(IBCON1,IBCON2,NB-1,KKJ,JJ,IPER)
C
            IST2 = JJ+1
            IEN2 = IEN
            DO 2640 KKJ2=KKJ+1,NB
               DO 2642 JJ2=IST2,IEN2
                  IA2 = JJ2 + NVAL
                  IS4 = IOB(IA2)
                  ISYBE2 = IMUL(ISYBE1,IS4)
                  IF (ISYBE2.NE.ITAS) GOTO 2642
                  IP2 = IMUL(IS4,IS3)
C
C DETERMINE NEW 0TH ORDER BETA, POS/PERM AND MATRIX ELEMENT
C
         CALL STR0AE(IBCON2,IACON2,NB,KKJ2,JJ2,IPER2)
         IPERT = IPER*IPER2
         IPB0 = POSDET(NACT,NB,IACON2,IFA)
         ITP0 = ICAT + ISPB(IPB0)
         COEFF = CI(ITP0)*IPERT
C
C LOOP OVER EXTERNAL ORBITALS
C
         ICOUNT = 0
         DO 2600 JE1=NQS,NQQ
            IS1 = IOB(JE1)
            E0BE1 = E0B0 - EFCK(JE1)
            IE1A1 = (JE1-M1-1)*M1 + IA1
            IE1A2 = IE1A1 - IA1 + IA2
            IE1A1T = INPT(IE1A1)
            IE1A2T = INPT(IE1A2)
C
         DO 2610 JE2=NQS,JE1-1
            ICOUNT = ICOUNT + 1
            IS2 = IOB(JE2)
            IP1 = IMUL(IS1,IS2)
            IF (IP1.NE.IP2) GOTO 2610
            TMP4(ICOUNT) = E0BE1 - EFCK(JE2)
C
C ME = [IE2,IA2 | IE1,IA1] - [IE2,IA1 | IE1,IA2]
C
         IE2A1 = (JE2-M1-1)*M1 + IA1
         IE2A2 = IE2A1 - IA1 + IA2
         INT1 = IE1A1T + IE2A2
         INT2 = IE1A2T + IE2A1
         T = SVOVO(INT1) - SVOVO(INT2)
         TMP3(ICOUNT) = TMP3(ICOUNT) + COEFF*T
C
 2610    CONTINUE
 2600    CONTINUE
C
 2642          CONTINUE
               IST2 = IBCON2(KKJ2)+1
               IEN2 = IBCON2(KKJ2+1)-1
               IF (KKJ2.EQ.NB-1) IEN2=NACT
 2640       CONTINUE
C
 2632          CONTINUE
               IST = IBCON1(KKJ)+1
               IEN = IBCON1(KKJ+1)-1
               IF (KKJ.EQ.NB-2) IEN=NACT
 2630       CONTINUE
C
CFORNOW
         DO II=1,ICOUNT
            EAAEE = EAAEE + (TMP3(II)*TMP3(II))/TMP4(II)
            TMP3(II) = 0.0D+00
            TMP4(II) = 1.0D+00
         ENDDO
         ICOUNT = 0
C
C END OF DOUBLE BETA DEXCITATIONS ( IE1<IE2 -> IA1<IA2 )
C
            CALL ADVANC(IBCON1,NB-2,NACT)
 2620    CONTINUE
C
C ******
C END OF LOOP OVER 2ND ORDER BETAS (IA1<IA2 -> IE1<IE2)
C ******
C
         IF (NVAL.EQ.0) GOTO 2701
C
C ---------------------------------------------------------
C LOOP OVER 1ST ORDER ALPHAS, VAL(IV1) -> EXT(IE1)
C THIS LOOP INCLUDES A LOOP OVER 0TH ORDER ALPHAS, SO WE'LL
C TRY TO PUT IT IN THE MAIN 0TH ORDER ALPHA LOOP, IE, HERE
C ---------------------------------------------------------
C
C I BELIVE THE BELOW INCLUDE VAL(B) -> EXT(B) ALSO...
C
C *****
C LOOP OVER 0TH ORDER BETA STRINGS
C *****
C
        DO II=1,NB
           IBCON1(II) = II
        ENDDO
        DO 2700 IJB=1,NBLP
           ICAB = ISPB(IJB)
           ISYB = IMUL(ISYV,ISYMB(IJB))
           E0B0 = E0AD
           DO II=1,NB
              E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
           ENDDO
           IF (ISYB.NE.ITAS) GOTO 2698
C
           ITP0 = ICAT + ICAB
           COEFF = CI(ITP0)
C
C SINGLE DEXCITATIONS, ALPHA IE -> IV
C
           ICOUNT = 0
           DO 2710 IV=1,NVAL
              IS1 = IOB(IV)
              E0B0V = E0B0 + EFCK(IV)
C
           DO 2720 IE=1,NEXT
              ICOUNT = ICOUNT + 1
              JE = IE + M1
              IS2 = IOB(JE)
              IF (IS1.NE.IS2) GOTO 2720
              TMP4(ICOUNT) = E0B0V - EFCK(JE)
C
C MATRIX ELEMENT
C
          CALL ME0VE1B(IV,IE,IACON1,NA,IBCON1,NB,NVAL,
     *    NACT,NEXT,INPT,SI1,SVOOO,M2,T)
          TMP3(ICOUNT) = TMP3(ICOUNT) + T*COEFF
C
          CALL ME0VE1B(IV,IE,IBCON1,NB,IACON1,NA,NVAL,
     *    NACT,NEXT,INPT,SI1,SVOOO,M2,T)
          TMP2(ICOUNT) = TMP2(ICOUNT) + T*COEFF
C
 2720      CONTINUE
C
 2710      CONTINUE
C
C END OF SINGLE DEXCITATIONS
C
 2698 CONTINUE
C
C NOW FOR DOUBLE DEXCITATIONS
C DOUBLES MUST INCLUDE THE SINGLE ABOVE
C
C 2ND EXCITATION: ALPHA ACT(IA2 -> JJA)
C TOTAL = ALPHA (IE,IA2 -> IV,JJA)
C
           ISYT = ITAB(ISYB)
           ISYL = IMUL(ISYT,ISA1)
C
           DO 2730 IEL2=1,NA
              IA2 = IACON1(IEL2) + NVAL
              IS1 = IOB(IA2)
C
       IST = 1
       IEN = IACON1(1)-1
       DO 2740 KKJ=1,NA+1
          DO 2742 JJ=IST,IEN
             JJA = JJ + NVAL
             IS2 = IOB(JJA)
             IP1 = IMUL(IS1,IS2)
             IF (IP1.NE.ISYL) GOTO 2742
             MA = MAX(IA2,JJA)
             MI = MIN(IA2,JJA)
             IA2A3 = INPT(MA) + MI
C
           CALL RET1DET(IACON1,IACON2,NA,IEL2,JJ,0,KKJ,ISWAP2)
           IPER2 = (-1)**ISWAP2
           IPA2 = POSDET(NACT,NA,IACON2,IFA)
           ITP0 = ISPA(IPA2) + ICAB
           COEFF = CI(ITP0)*IPER2
C
           ICOUNT = 0
           DO 2750 IV=1,NVAL
              IS3 = IOB(IV)
              E0B0V = E0B0 + EFCK(IV)
              IA2V = INPT(IA2) + IV
              IVA2A3 = (IV-1)*M2 + IA2A3
              IA3A2V = (JJA-1)*M2 + IA2V
C
           DO 2760 IE=1,NEXT
              ICOUNT = ICOUNT + 1
              JE = IE + M1
              IS4 = IOB(JE)
              IP2 = IMUL(IS4,IS3)
              IF (IP1.NE.IP2) GOTO 2760
              TMP4(ICOUNT) = E0B0V - EFCK(JE)
C
C MATRIX ELEMENT
C
         T1 = SVOOO(IE,IVA2A3)*COEFF
         T2 = SVOOO(IE,IA3A2V)*COEFF
         TMP3(ICOUNT) = TMP3(ICOUNT) + (T1-T2)
         TMP2(ICOUNT) = TMP2(ICOUNT) + T1
C
 2760      CONTINUE
 2750      CONTINUE
C
 2742     CONTINUE
          IST = IACON1(KKJ)+1
          IEN = IACON1(KKJ+1)-1
          IF (KKJ.EQ.NA) IEN=NACT
 2740  CONTINUE
C
 2730      CONTINUE
C
C END OF ALPHA ACT (IA2 -> JJA) DEXCITE
C
C 2ND EXCITATION: BETA ACT (IA2 -> JJA)
C TOTAL = ( IE(A),IA2(B) -> IV(A),JJA(B) )
C
           ISYL = IMUL(ITAS,ISYB)
           DO 2770 IEL2=1,NB
              IA2 = IBCON1(IEL2)+NVAL
              IS1 = IOB(IA2)
C
           IST = 1
           IEN = IBCON1(1)-1
           DO 2780 KKJ=1,NB+1
              DO 2782 JJ=IST,IEN
                 JJA = JJ + NVAL
                 IS2 = IOB(JJA)
                 IP1 = IMUL(IS1,IS2)
                 IF (IP1.NE.ISYL) GOTO 2782
C
                 MA = MAX(IA2,JJA)
                 MI = MIN(IA2,JJA)
                 IA2A3 = INPT(MA) + MI
C
          CALL RET1DET(IBCON1,IBCON2,NB,IEL2,JJ,0,KKJ,ISWAP2)
          IPER2 = (-1)**ISWAP2
          IPB2 = POSDET(NACT,NB,IBCON2,IFA)
          ITP0 = ICAT + ISPB(IPB2)
          COEFF = CI(ITP0)*IPER2
C
          ICOUNT = 0
          DO 2785 IV=1,NVAL
             IS3 = IOB(IV)
             E0B0V = E0B0 + EFCK(IV)
              IA2V = INPT(IA2) + IV
              IVA2A3 = (IV-1)*M2 + IA2A3
              IA3A2V = (JJA-1)*M2 + IA2V
C
          DO 2790 IE=1,NEXT
             ICOUNT = ICOUNT + 1
             JE = IE + M1
             IS4 = IOB(JE)
             IP2 = IMUL(IS4,IS3)
             IF (IP1.NE.IP2) GOTO 2790
             TMP4(ICOUNT) = E0B0V - EFCK(JE)
C
C  MATRIX ELEMENT
C
         T1 = SVOOO(IE,IVA2A3)*COEFF
         T2 = SVOOO(IE,IA3A2V)*COEFF
         TMP3(ICOUNT) = TMP3(ICOUNT) + T1
         TMP2(ICOUNT) = TMP2(ICOUNT) + (T1-T2)
C
 2790     CONTINUE
 2785     CONTINUE
C
 2782         CONTINUE
              IST = IBCON1(KKJ)+1
              IEN = IBCON1(KKJ+1)-1
              IF (KKJ.EQ.NB) IEN=NACT
 2780      CONTINUE
C
 2770      CONTINUE
C
C END OF 2ND EXCITATION BETA (IA2 -> JJ)
C
         DO II=1,ICOUNT
            EVE = EVE +
     *  (TMP3(II)*TMP3(II)+TMP2(II)*TMP2(II))/TMP4(II)
            TMP3(II) = 0.0D+00
            TMP2(II) = 0.0D+00
            TMP4(II) = 1.0D+00
         ENDDO
         ICOUNT = 0
C
           CALL ADVANC(IBCON1,NB,NACT)
 2700   CONTINUE
 2701 CONTINUE
C
C *****
C END OF LOOP OVER 0TH ORDER BETA STRINGS
C *****
C
        CALL DDI_DLBNEXT(MY_TASK)
      END IF     ! MY TASK
C
         CALL ADVANC(IACON1,NA,NACT)
 2000 CONTINUE
C
C END LOOP OVER ZEROTH ORDER ALPHAS
C
C -------------------------------------------
C *******************************************
C -------------------------------------------
C
C LOOP OVER 1ST ORDER ALPHAS, ORBITALS NUMBERED AS ACTIVE, 1,2,etc
C
C --------------------------------------------------
C **************************************************
C --------------------------------------------------
C
      NBUFF=N1A
      IF (NVAL.EQ.0) THEN
         NBUFF=0
         GOTO 3401
      ENDIF
C
C LOOP OVER 1ST ORDER ALPHAS (IV -> IA)
C
C OUTER LOOP OVER 1 UP ALPHAS
C
      DO II=1,NA+1
         IACON1(II) = II
      ENDDO
      E0A0 = EPT0 - 2*E0V
      ISA0 = ISYV
C
      DO 3400 IJK2=1,N1A
C
        IF (IJK2+NALP-1.EQ.MY_TASK) THEN
C
         ISA1 = ISA0
         E0AD1 = E0A0
         DO II=1,NA+1
            E0AD1 = E0AD1 - EFCK(IACON1(II)+NVAL)
            ISA1 = IMUL(ISA1,IOB(IACON1(II)+NVAL))
         ENDDO
C
C LOOP OVER 0TH ORDER BETAS
C
         DO II=1,NB
            IBCON1(II) = II
         ENDDO
         DO 3410 IJB=1,NBLP
            ICAB = ISPB(IJB)
            ISYB = IMUL(ISYV,ISYMB(IJB))
            E0B0 = E0AD1
            DO II=1,NB
               E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
            ENDDO
            ITAM = ITAB(ISYB)
            ITAL = IMUL(ITAM,ISA1)
C
C LOOP OVER PURE SINGLE DEXCITATIONS ALPHA IA -> IV
C
            DO 3420 IEL=1,NA+1
               IA = IACON1(IEL)+NVAL
               IS1 = IOB(IA)
               IF (IS1.NE.ITAL) GOTO 3420
C
C DETERMINE 0TH ORDER ALPHA, POS/PERM
C
        CALL STR0VA(IACON1,IACON2,NA+1,IEL,NVAL,NVAL,IPER)
        IPA0 = POSDET(NACT,NA,IACON2,IFA)
        ITP0 = ISPA(IPA0) + ICAB
        COEFF = CI(ITP0)*IPER
C
C LOOP OVER VALENCE ORBITALS, WORK OUT MATRIX ELEMENT
C
        DO 3430 IV=1,NVAL
        IS2 = IOB(IV)
        IF (IS1.NE.IS2) GOTO 3430
        TMP4(IV) = E0B0 + EFCK(IV)
        CALL ME0VA1B(IV,IA,IACON2,NA,IBCON1,NB,NVAL,INPT,SI1,SI2,T)
C
        TMP3(IV) = TMP3(IV) + COEFF*T
C
 3430   CONTINUE
C
C END OF LOOP OVER VALENCE ORBITALS
C
 3420       CONTINUE
C
C END OF PURE SINGLE DEXCITATIONS ALPHA IA -> IV
C
C DOUBLE DEXCITATIONS: ( IA(A) < IA2(A) -> IV,JJA )
C
          DO 3435 IEL=1,NA+1
          JA = IACON1(IEL)
          IA = JA + NVAL
          IS1 = IOB(IA)
          CALL STR0VA(IACON1,IACON2,NA+1,IEL,NVAL,NVAL,IPER)
          IPA0 = POSDET(NACT,NA,IACON2,IFA)
          ICAT = ISPA(IPA0)
C
          DO 3440 IEL2=IEL,NA
             IA2 = IACON2(IEL2)+NVAL
             IS2 = IOB(IA2)
             IP1 = IMUL(IS1,IS2)
C
          IST = 1
          IEN = IACON2(1)-1
          DO 3450 KKJ=1,NA+1
             DO 3447 JJ=IST,IEN
                IF (JJ.EQ.JA) GOTO 3447
                JJA = JJ + NVAL
                IS3 = IOB(JJA)
                IP1A = IMUL(IP1,IS3)
                IF (IP1A.NE.ITAL) GOTO 3447
C
          MA = MAX(IA2,JJA)
          MI = MIN(IA2,JJA)
          IA3A2 = INPT(MA) + MI
          MA = MAX(IA,JJA)
          MI = MIN(IA,JJA)
          IA3A = INPT(MA) + MI
C
C DETERMINE 0TH ORDER ALPHA, POS/PERM
C
          CALL RET1DET(IACON2,IBCON2,NA,IEL2,JJ,0,KKJ,ISWAP2)
          IPER2 = (-1)**ISWAP2
          IPERT = IPER*IPER2
          IPA2 = POSDET(NACT,NA,IBCON2,IFA)
          ITP0 = ISPA(IPA2) + ICAB
          COEFF = CI(ITP0)*IPERT
C
C LOOP OVER VALENCE AND MAKE MATRIX ELEMENT
C
          DO 3460 IV=1,NVAL
             IS4 = IOB(IV)
             IF (IS4.NE.IP1A) GOTO 3460
             TMP4(IV) = E0B0 + EFCK(IV)
C
             IAV = INPT(IA) + IV
             INT1 = INPT(IA3A2) + IAV
             IA2V = INPT(IA2) + IV
             MA = MAX(IA3A,IA2V)
             MI = MIN(IA3A,IA2V)
             INT2 = INPT(MA) + MI
             T = (SI2(INT1) - SI2(INT2))*COEFF
             TMP3(IV) = TMP3(IV) + T
C
 3460     CONTINUE
C
C END OF LOOP OVER VALENCE
C
 3447        CONTINUE
             IST = IACON2(KKJ)+1
             IEN = IACON2(KKJ+1)-1
             IF (KKJ.EQ.NA) IEN=NACT
 3450     CONTINUE
C
 3440     CONTINUE
C
C END OF 2ND PART OF DOUBLE EXCITE, IA2 -> JJA
C
C NOW FOR DOUBLE EXCITES ( IA(A),IA2(B) -> IV(A),JJA(B) )
C
          DO 3465 IEL2=1,NB
             IA2 = IBCON1(IEL2)+NVAL
             IS2 = IOB(IA2)
             IP1 = IMUL(IS1,IS2)
C
          IST = 1
          IEN = IBCON1(1)-1
          DO 3470 KKJ=1,NB+1
             DO 3472 JJ=IST,IEN
                JJA = JJ + NVAL
                IS3 = IOB(JJA)
                IP1A = IMUL(IP1,IS3)
                IF(IP1A.NE.ITAL) GOTO 3472
C
          MA = MAX(IA2,JJA)
          MI = MIN(IA2,JJA)
          IA3A2 = INPT(MA) + MI
C
C DETERMINE NEW 0TH ORDER BETA, POS/PERM
C
          CALL RET1DET(IBCON1,IBCON2,NB,IEL2,JJ,0,KKJ,ISWAP2)
          IPER2 = (-1)**ISWAP2
          IPERT = IPER*IPER2
          IPB2 = POSDET(NACT,NB,IBCON2,IFA)
          ITP0 = ICAT + ISPB(IPB2)
          COEFF = CI(ITP0)*IPERT
C
          DO 3480 IV=1,NVAL
             IS4 = IOB(IV)
             IF (IS4.NE.IP1A) GOTO 3480
             TMP4(IV) = E0B0 + EFCK(IV)
C
             IAV = INPT(IA) + IV
             MA = MAX(IA3A2,IAV)
             MI = MIN(IA3A2,IAV)
             INT = INPT(MA) + MI
             T = SI2(INT)*COEFF
             TMP3(IV) = TMP3(IV) + T
C
 3480     CONTINUE
C
C END OF LOOP OVER VALENCE
C
 3472        CONTINUE
             IST = IBCON1(KKJ) + 1
             IEN = IBCON1(KKJ+1)-1
             IF (KKJ.EQ.NB) IEN=NACT
 3470     CONTINUE
C
 3465     CONTINUE
C
C END OF 2ND EXCITE BETA ( IA2(B) -> JJA(B) )
C
 3435     CONTINUE
C
C END OF FIRST PART OF DOUBLE EXCITE, IA -> IV
C
          DO II=1,NVAL
             EVA = EVA + (TMP3(II)*TMP3(II))/TMP4(II)
             TMP3(II) = 0.0D+00
             TMP4(II) = 1.0D+00
          ENDDO
C
C --------------------------------------------------------------
C END OF PURE SINGLE EXCITED DETERMINANTS IV(A) -> IA(A)
C --------------------------------------------------------------
C
C WITHIN LOOP OVER ALPHA(1), BETA(0), LOWER MATRIX ElEMENTS CAN
C BE ALSO DETERMINED
C --------------------------------------------------------------
C RELOOP OVER 2ND ORDER ALPHAS, (IV1,IV2 -> IA1,IE)
C THIS INCLUDES                ( IV1(B),IV2(A) -> IA1(A),IE(B) )
C --------------------------------------------------------------
C
         ITAZ = ITAB(ISA1)
         ISYZ = IMUL(ITAZ,ISYB)
C
C LOOP OVER DEXCITAIONS FROM ALPHA, IA1
C
            DO 7120 IEL1=1,NA+1
               IA1 = IACON1(IEL1)+NVAL
               IS1 = IOB(IA1)
               IF (IS1.NE.ISYZ) GOTO 7120
C
C DETERMINE 0TH ORDER ALPHA, POS/PERM
C
         CALL STR0VA(IACON1,IACON2,NA+1,IEL1,NVAL,NVAL,IPER)
         IPA0 = POSDET(NACT,NA,IACON2,IFA)
         ITP0 = ISPA(IPA0) + ICAB
         COEFF = CI(ITP0)*IPER
C
C LOOP OVER ALPHA VALENCE, IV1 < IV2
C
         ICOUNT = 0
         DO 7130 IV1=1,NVAL
            IS2 = IOB(IV1)
            IP1 = IMUL(IS1,IS2)
            E0B0V = E0B0 + EFCK(IV1)
            IA1V1 = INPT(IA1) + IV1
C
         DO 7140 IV2=1,IV1-1
            IS3 = IOB(IV2)
            IPT = IMUL(IS3,IP1)
            E0B0VV = E0B0V + EFCK(IV2)
            IA1V2 = INPT(IA1) + IV2
            IV2A1V1 = (IV2-1)*M2 + IA1V1
            IV1A1V2 = (IV1-1)*M2 + IA1V2
C
C LOOP OVER ALPHA EXTERNAL, IE
C
         DO 7150 IE=1,NEXT
            JE = IE + M1
            IS4 = IOB(JE)
            IF (IS4.NE.IPT) GOTO 7150
            ICOUNT = ICOUNT + 1
            TMP4(ICOUNT) = E0B0VV - EFCK(JE)
C
C MATRIX ELEMENT
C
        T1 = SVOOO(IE,IV2A1V1)*COEFF
        T2 = SVOOO(IE,IV1A1V2)*COEFF
        TMP3(ICOUNT) = TMP3(ICOUNT) + T1
        TMP1(ICOUNT) = TMP1(ICOUNT) + T2
        TMP2(ICOUNT) = TMP2(ICOUNT) + (T1-T2)
C
 7150    CONTINUE
C
C END OF LOOP OVER ALPHA EXTERNAL
C
 7140    CONTINUE
C
C IV1 = IV2
C
            IPT = IMUL(IS2,IP1)
            E0B0VV = E0B0V + EFCK(IV1)
            IV2A1V1 = (IV1-1)*M2 + IA1V1
            DO 7135 IE=1,NEXT
               JE = IE + M1
               IS4 = IOB(JE)
               IF (IS4.NE.IPT) GOTO 7135
               ICOUNT = ICOUNT + 1
               TMP4(ICOUNT) = E0B0VV - EFCK(JE)
C
         T = SVOOO(IE,IV2A1V1)*COEFF
         TMP3(ICOUNT) = TMP3(ICOUNT) + T
C
 7135       CONTINUE
C
C END OF IV1=IV2
C
 7130    CONTINUE
C
C END OF EXCITATIONS INTO VALENCE IV1 < IV2
C
 7120       CONTINUE
C
C END OF DEXCITATIONS FROM ALPHA, IA
C
          DO II=1,ICOUNT
             EVVAE = EVVAE + (TMP3(II)*TMP3(II)+
     *      TMP1(II)*TMP1(II)+TMP2(II)*TMP2(II))/TMP4(II)
             TMP3(II) = 0.0D+00
             TMP1(II) = 0.0D+00
             TMP2(II) = 0.0D+00
             TMP4(II) = 1.0D+00
          ENDDO
          ICOUNT = 0
C
C --------------------------------------------------------------
C END OF RELOOP OVER 2ND ORDER ALPHAS, (IV1,IV2 -> IA1,IE)
C WHICH INCLUDED                ( IV1(B),IV2(A) -> IA1(A),IE(B) )
C --------------------------------------------------------------
C
            CALL ADVANC(IBCON1,NB,NACT)
 3410    CONTINUE
C
C END OF LOOP OVER 0TH ORDER BETAS
C
C ----------------------------------------------
C NOW TO LOOP OVER 1ST ORDER BETAS IV2 -> IA2
C ----------------------------------------------
C
C LOOP OVER 1 UP BETAS
C
         DO II=1,NB+1
            IBCON1(II) = II
         ENDDO
         DO 3500 IJB=1,N1B
            ISYB = ISYV
            E0B0 = E0AD1
            DO II=1,NB+1
               E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
               ISYB = IMUL(ISYB,IOB(IBCON1(II)+NVAL))
            ENDDO
            ISYT = IMUL(ISYB,ISA1)
            ITAL = ITAB(ISYT)
C
C LOOP OVER ALPHA EXCITE (IA1 -> IV)
C
            DO 3510 IEL1=1,NA+1
               IA1 = IACON1(IEL1) + NVAL
               IS1 = IOB(IA1)
            CALL STR0VA(IACON1,IACON2,NA+1,IEL1,NVAL,NVAL,IPER)
            IPA0 = POSDET(NACT,NA,IACON2,IFA)
            ICAT = ISPA(IPA0)
C
C LOOP OVER BETA EXCITE (IA2 -> IV2)
C
            DO 3520 IEL2=1,NB+1
               IA2 = IBCON1(IEL2) + NVAL
               IS2 = IOB(IA2)
               IP1 = IMUL(IS1,IS2)
               IF (IP1.NE.ITAL) GOTO 3520
            CALL STR0VA(IBCON1,IBCON2,NB+1,IEL2,NVAL,NVAL,IPER2)
            IPERT = IPER*IPER2
            IPB0 = POSDET(NACT,NB,IBCON2,IFA)
            ITP0 = ICAT + ISPB(IPB0)
            COEFF = CI(ITP0)*IPERT
C
C NOW TO LOOP OVER VALENCE ORBITALS
C
            IA1T = INPT(IA1)
            IA2T = INPT(IA2)
            ICOUNT = 0
            DO 3530 IV1=1,NVAL
               IS3 = IOB(IV1)
               IPT = IMUL(IS3,IP1)
               E0BV1 = E0B0 + EFCK(IV1)
               IA1V1 = IA1T + IV1
C
            DO 3540 IV2=1,NVAL
               ICOUNT = ICOUNT + 1
               IS4 = IOB(IV2)
               IF (IS4.NE.IPT) GOTO 3540
               TMP4(ICOUNT) = E0BV1 + EFCK(IV2)
C
           IA2V2 = IA2T + IV2
           MA = MAX(IA1V1,IA2V2)
           MI = MIN(IA1V1,IA2V2)
           INT1 = INPT(MA) + MI
           T1 = SI2(INT1)*COEFF
           TMP3(ICOUNT) = TMP3(ICOUNT) + T1
C
 3540       CONTINUE
C
 3530       CONTINUE
C
CEND OF LOOP OVER VALENCE ORBITALS
C
 3520       CONTINUE
C
C END OF BETA EXCITE (IA2 -> IV2)
C
 3510       CONTINUE
C
C END OF ALPHA EXCITE (IA1 -> IV)
C
         DO II=1,ICOUNT
            EVVAA = EVVAA + (TMP3(II)*TMP3(II))/TMP4(II)
            TMP3(II) = 0.0D+00
            TMP4(II) = 1.0D+00
         ENDDO
         ICOUNT = 0
C
            CALL ADVANC(IBCON1,NB+1,NACT)
 3500    CONTINUE
C
C -----------------------------------
C END OF LOOP OVER 1 UP BETAS
C END LOOP OVER 1ST ORDER BETAS IV2 -> IA2
C -----------------------------------
C
C ------------------------------------------
C NOW TO LOOP OVER 1ST ORDER BETAS IA2 -> IE
C ------------------------------------------
C
C LOOP OVER 1 DOWN BETAS
C
         DO II=1,NB-1
            IBCON1(II) = II
         ENDDO
         DO 3700 IJB=1,ND1B
            ISYB = ISYV
            E0BD1 = E0AD1
            DO II=1,NB-1
               E0BD1 = E0BD1 - EFCK(IBCON1(II)+NVAL)
               ISYB = IMUL(ISYB,IOB(IBCON1(II)+NVAL))
            ENDDO
            ISYT = IMUL(ISYB,ISA1)
            ITAL = ITAB(ISYT)
C
C LOOP OVER DEXCITATIONS FROM IA1(A)
C
         DO 3710 IEL=1,NA+1
            IA1 = IACON1(IEL) + NVAL
            IS1 = IOB(IA1)
            CALL STR0VA(IACON1,IACON2,NA+1,IEL,NVAL,NVAL,IPER)
            IPA0 = POSDET(NACT,NA,IACON2,IFA)
            ICAT = ISPA(IPA0)
C
C LOOP OVER EXCITATIONS INTO IA2(B)
C
         IST = 1
         IEN = IBCON1(1)-1
         IF (NB.EQ.1) IEN=NACT
         DO 3720 KKJ=1,NB
            DO 3722 JJ=IST,IEN
               IA2 = JJ + NVAL
               IS2 = IOB(IA2)
               IP1 = IMUL(IS1,IS2)
               IF (IP1.NE.ITAL) GOTO 3722
C
C 0TH ORDER BETA POS/PERM
C
         CALL STR0AE(IBCON1,IBCON2,NB,KKJ,JJ,IPER2)
         IPERT = IPER*IPER2
         IPB0 = POSDET(NACT,NB,IBCON2,IFA)
         ITP0 = ICAT + ISPB(IPB0)
         COEFF = CI(ITP0)*IPERT
C
C LOOP OVER ALPHA VALENCE
C
         ICOUNT = 0
         DO 3730 IV=1,NVAL
            IS3 = IOB(IV)
            IPT = IMUL(IP1,IS3)
            E0BD1V = E0BD1 + EFCK(IV)
            IA1V = INPT(IA1) + IV
            IA2A1V = (IA2-1)*M2 + IA1V
C
C LOOP OVER BETA EXTERNAL
C
         DO 3740 IE=1,NEXT
            ICOUNT = ICOUNT + 1
            JE = IE + M1
            IS4 = IOB(JE)
            IF (IS4.NE.IPT) GOTO 3740
            TMP4(ICOUNT) = E0BD1V - EFCK(JE)
C
            T1 = SVOOO(IE,IA2A1V)*COEFF
            TMP3(ICOUNT) = TMP3(ICOUNT) + T1
C
 3740    CONTINUE
C
 3730    CONTINUE
C
C END OF ALPHA VALENCE
C
 3722       CONTINUE
            IST = IBCON1(KKJ)+1
            IEN = IBCON1(KKJ+1)-1
            IF (KKJ.EQ.NB-1) IEN=NACT
 3720    CONTINUE
C
C END OF EXCITATIONS INTO EA2(B)
C
 3710    CONTINUE
C
C END OF DEXCITATIONS OUT OF IA1(A), IA2(B)
C
         DO II=1,ICOUNT
            EVAAE = EVAAE +
     *      (TMP3(II)*TMP3(II))/TMP4(II)
            TMP3(II) = 0.0D+00
            TMP4(II) = 1.0D+00
         ENDDO
         ICOUNT = 0
C
            CALL ADVANC(IBCON1,NB-1,NACT)
 3700    CONTINUE
C
C END OF LOOP OVER 1 DOWN BETAS
C
C ------------------------------------------
C END OF LOOP OVER 1ST ORDER BETAS IA2 -> IE
C ------------------------------------------
C
        CALL DDI_DLBNEXT(MY_TASK)
      END IF     ! MY TASK
C
         CALL ADVANC(IACON1,NA+1,NACT)
 3400 CONTINUE
C
 3401 CONTINUE
C
C END OF RELOOP OVER 1ST ORDER ALPHAS, VAL (IV) -> ACTIVE
C
C --------------------------------------------------
C **************************************************
C --------------------------------------------------
C
C -------------------------------------------
C *******************************************
C -------------------------------------------
C
C EXPERIMENT, RELOOP OVER ALPHA ACT (IA?)  -> EXTERNAL (IE)
C
         DO II=1,NA-1
            IACON1(II) = II
         ENDDO
C
         DO 5805 IJK3=1,ND1A
C
        IF (IJK3+NALP+NBUFF-1.EQ.MY_TASK) THEN
C
C DETERMINE SYMMETRY OF ALPHA STRING
C
            ISA0 = ISYV
            E0A0 = E0V
            DO II=1,NA-1
               E0A0 = E0A0 + EFCK(IACON1(II)+NVAL)
               ISA0 = IMUL(ISA0,IOB(IACON1(II)+NVAL))
            ENDDO
C
C LOOP OVER 0TH ORDER BETAS
C
            E0AD = EPT0 - E0A0 - E0V
            ISYBV = ISYV
            DO II=1,NB
               IBCON1(II) = II
            ENDDO
            DO 5700 IJB=1,NBLP
               ICAB = ISPB(IJB)
               ISYB = IMUL(ISYMB(IJB),ISYBV)
               E0B0 = E0AD
               DO II=1,NB
                  E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
               ENDDO
               ITBS = ITAB(ISYB)
               ISYL = IMUL(ISA0,ITBS)
C
C SINGLE DEXCITATIONS, ALPHA IE -> IA(?)
C
        IST = 1
        IEN = IACON1(1)-1
        IF (NA.EQ.1) IEN=NACT
        DO 5710 KKJ=1,NA
           DO 5712 JJ=IST,IEN
              JJE = JJ + NVAL
              IS2 = IOB(JJE)
              IF (IS2.NE.ISYL) GOTO 5712
C
C DETERMINE 0TH ORDER ALPHA STRING, POS/PERM AND MATRIX ELEMENT
C
           CALL STR0AE(IACON1,IACON2,NA,KKJ,JJ,IPER)
           IPA0 = POSDET(NACT,NA,IACON2,IFA)
           ITP0 = ISPA(IPA0) + ICAB
           COEFF = CI(ITP0)*IPER
C
C LOOP OVER EXTERNAL ORBS
C
           DO 5715 IE=1,NEXT
              JE = IE + M1
              IS1 = IOB(JE)
              IF (IS1.NE.IS2) GOTO 5715
              TMP4(IE) = E0B0 - EFCK(JE)
C
        CALL ME0AE1B(JJE,IE,IACON1,NA,IBCON1,NB,NVAL,NACT,NEXT,
     *  INPT,SI1,SVOOO,M2,T)
C
        TMP3(IE) = TMP3(IE) + COEFF*T
C
 5715      CONTINUE
C
 5712      CONTINUE
           IST = IACON1(KKJ)+1
           IEN = IACON1(KKJ+1)-1
           IF (KKJ.EQ.NA-1) IEN=NACT
 5710  CONTINUE
C
C END OF SINGLE DEXCITATIONS, ALPHA IE -> IA(?)
C
C NOW FOR DOUBLE DEXCITATIONS
C DOUBLE DEXCITATIONS MUST !!!!! INCLUDE THE SINGLES ABOVE !!!!!
C START WITH THIS TYPE FIRST, IE ALPHA IE -> IA
C
       IST = 1
       IEN = IACON1(1)-1
       IF (NA.EQ.1) IEN=NACT
       DO 5720 KKJ=1,NA
          DO 5722 JJ=IST,IEN
             IA = JJ + NVAL
             IS1 = IOB(IA)
             CALL STR0AE(IACON1,IACON2,NA,KKJ,JJ,IPER)
             IPA0 = POSDET(NACT,NA,IACON2,IFA)
             ICAT = ISPA(IPA0)
C
C SECOND EXCITATION: ALPHA ACT (IA2.NE.IA) -> ACT (JJA > IA)
C TOTAL = ALPHA (IE,IA2 -> IA < JJA )
C
             DO 5730 IEL=1,NA
                IF (IEL.EQ.KKJ) GOTO 5730
                IA2 = IACON2(IEL)+NVAL
                IS2 = IOB(IA2)
                IP1 = IMUL(IS1,IS2)
C
C HAVE ENSURED THAT IA2.NE.IA, NOW TO ENSURE THAT JJA > IA
C
             IST2=JJ+1
             IEN2=IEN
             DO 5738 KKJ2=KKJ+1,NA+1
             DO 5737 JJ2=IST2,IEN2
                JJA = JJ2 + NVAL
                IS3 = IOB(JJA)
                IPT = IMUL(IP1,IS3)
                IF (IPT.NE.ISYL) GOTO 5737
C
C DETERMINE NEW 0TH ORDER ALPHA, POS/PERM AND MATRIX ELEMENT
C
         CALL RET1DET(IACON2,IBCON2,NA,IEL,JJ2,0,KKJ2,ISWAP2)
         IPER2 = (-1)**ISWAP2
         IPERT = IPER*IPER2
         IPA2 = POSDET(NACT,NA,IBCON2,IFA)
         ITP0 = ISPA(IPA2) + ICAB
         COEFF = CI(ITP0)*IPERT
C
         MA = MAX(IA,IA2)
         MI = MIN(IA,IA2)
         IAA2 = INPT(MA) + MI
         MA = MAX(IA2,JJA)
         MI = MIN(IA2,JJA)
         IA2A3 = INPT(MA) + MI
         IAA2A3 = (IA-1)*M2 + IA2A3
         IA3AA2 = (JJA-1)*M2 + IAA2
C
      DO 5740 IE=1,NEXT
         JE = IE + M1
         IS4 = IOB(JE)
         IP2 = IMUL(IS4,IS3)
         IF (IP1.NE.IP2) GOTO 5740
         TMP4(IE) = E0B0 - EFCK(JE)
C
C  ME = [IE,IA | IA2,JJA] - [IE,JJA | IA2,IA]
C
C
         T = SVOOO(IE,IAA2A3) - SVOOO(IE,IA3AA2)
         TMP3(IE) = TMP3(IE) + COEFF*T
C
 5740 CONTINUE
C
 5737        CONTINUE
             IST2 = IACON2(KKJ2)+1
             IEN2 = IACON2(KKJ2+1)-1
             IF (KKJ2.EQ.NA) IEN2=NACT
 5738        CONTINUE
C
 5730        CONTINUE
C
C END OF 2ND EXCITATION: ALPHA ACT (IA2 -> JJA)
C
C 2ND EXCITATION: BETA ACT (IA2 -> JJA)
C TOTAL = ( IE(A),IA2(B) -> IA(A),JJA(B) )
C
             DO 5750 IEL2=1,NB
                IA2 = IBCON1(IEL2)+NVAL
                IS2 = IOB(IA2)
                IP1 = IMUL(IS1,IS2)
C
             IST2 = 1
             IEN2 = IBCON1(1)-1
             DO 5760 KKJ2=1,NB+1
                DO 5762 JJ2=IST2,IEN2
                   JJA = JJ2 + NVAL
                   IS3 = IOB(JJA)
                   IPT = IMUL(IP1,IS3)
                   IF (IPT.NE.ISYL) GOTO 5762
C
C DETERMINE NEW 0TH ORDER BETA, POS/PERM AND MATRIX ELEMENT
C
           CALL RET1DET(IBCON1,IBCON2,NB,IEL2,JJ2,0,KKJ2,ISWAP2)
           IPER2 = (-1)**ISWAP2
           IPERT = IPER*IPER2
           IPB2 = POSDET(NACT,NB,IBCON2,IFA)
           ITP0 = ICAT + ISPB(IPB2)
           COEFF = CI(ITP0)*IPERT
C
           MA = MAX(IA2,JJA)
           MI = MIN(IA2,JJA)
           IA2A3 = INPT(MA) + MI
           IAA2A3 = (IA-1)*M2 + IA2A3
C
      DO 5770 IE=1,NEXT
         JE = IE + M1
         IS4 = IOB(JE)
         IP2 = IMUL(IS4,IS3)
         IF (IP1.NE.IP2) GOTO 5770
         TMP4(IE) = E0B0 - EFCK(JE)
C
C ME = [IE,IA | IA2,JJA]
C
            T = SVOOO(IE,IAA2A3)
            TMP3(IE) = TMP3(IE) + COEFF*T
C
 5770 CONTINUE
C
 5762           CONTINUE
                IST2 = IBCON1(KKJ2)+1
                IEN2 = IBCON1(KKJ2+1)-1
                IF (KKJ2.EQ.NB) IEN2=NACT
 5760        CONTINUE
C
 5750        CONTINUE
C
C END OF 2ND EXCITATION: BETA ACT (IA2 -> JJA)
C
 5722     CONTINUE
          IST = IACON1(KKJ)+1
          IEN = IACON1(KKJ+1)-1
          IF (KKJ.EQ.NA-1) IEN=NACT
 5720  CONTINUE
C
C END OF 1ST EXCITATION ALPHA IE -> IA(?)
C
         DO II=1,NEXT
            EAE = EAE + (TMP3(II)**2.0D+00)/TMP4(II)
            TMP3(II) = 0.0D+00
            TMP4(II) = 1.0D+00
         ENDDO
C
               CALL ADVANC(IBCON1,NB,NACT)
 5700       CONTINUE
C
C ---------------
C END OF 0TH ORDER BETAS
C ---------------
C
C ---------------
C NOW TO LOOP OVER 1ST ORDER OVER BETA (IA2) -> (IE2)
C ---------------
C
          DO II=1,NB-1
             IBCON1(II) = II
          ENDDO
          DO 5810 IJB=1,ND1B
             ISYB0 = ISYV
             E0B0 = EPT0-E0V-E0A0
             DO II=1,NB-1
                E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
                ISYB0 = IMUL(ISYB0,IOB(IBCON1(II)+NVAL))
             ENDDO
C
C NOW TO LOOP OVER ALPHA DEXCITATIONS (IE -> IA)
C
             IST = 1
             IEN = IACON1(1)-1
             IF (NA.EQ.1) IEN=NACT
             DO 5820 KKJ=1,NA
                DO 5822 JJ=IST,IEN
                   IA = JJ + NVAL
                   IS3 = IOB(IA)
                   ISA1 = IMUL(ISA0,IS3)
                   ITAS = ITAB(ISA1)
C
                   CALL STR0AE(IACON1,IACON2,NA,KKJ,JJ,IPER)
                   IPA0 = POSDET(NACT,NA,IACON2,IFA)
                   ICAT = ISPA(IPA0)
C
C NOW TO LOOP OVER BETA DEXCITATIONS (IE2 -> IA2)
C
             IST2 = 1
             IEN2 = IBCON1(1)-1
             IF (NB.EQ.1) IEN2=NACT
             DO 5830 KKJ2=1,NB
                DO 5832 JJ2=IST2,IEN2
                   IA2 = JJ2 + NVAL
                   IS4 = IOB(IA2)
                   ISYB = IMUL(ISYB0,IS4)
                   IF (ISYB.NE.ITAS) GOTO 5832
                   IP2 = IMUL(IS4,IS3)
C
        CALL STR0AE(IBCON1,IBCON2,NB,KKJ2,JJ2,IPER2)
        IPB0 = POSDET(NACT,NB,IBCON2,IFA)
        ITP0 = ICAT + ISPB(IPB0)
        IPERT = IPER*IPER2
        COEFF = CI(ITP0)*IPERT
C
      ICOUNT = 0
      DO 5800 JE=NQS,NQQ
         IS1 = IOB(JE)
         E0A1 = E0B0 - EFCK(JE)
         IEA = (JE-M1-1)*M1 + IA
         IEA2 = IEA - IA + IA2
         IEAT = INPT(IEA)
         IEA2T = INPT(IEA2)
C
         DO 5807 JE2=NQS,JE-1
             ICOUNT = ICOUNT + 1
             IS2 = IOB(JE2)
             IP1 = IMUL(IS1,IS2)
             IF (IP1.NE.IP2) GOTO 5807
             TMP4(ICOUNT) = E0A1 - EFCK(JE2)
C
C DETERMINE MATRIX ELEMENT
C
C ME = [IE,IA | IE2,IA2]
C
        IE2A2 = (JE2-M1-1)*M1 + IA2
        IE2A1 = IE2A2 - IA2 + IA
        INT1 = IEAT + IE2A2
        INT2 = IEA2T + IE2A1
        T1 = SVOVO(INT1)*COEFF
        T2 = SVOVO(INT2)*COEFF
        TMP1(ICOUNT) = TMP1(ICOUNT) + T1
        TMP3(ICOUNT) = TMP3(ICOUNT) + T2
C
 5807 CONTINUE
C
C JE2=JE
C
      ICOUNT = ICOUNT + 1
      IF (IP2.NE.1) GOTO 5800
      TMP4(ICOUNT) = E0A1 - EFCK(JE)
      MA = MAX(IEA,IEA2)
      MI = MIN(IEA,IEA2)
      INT1 = INPT(MA) + MI
      T1 = SVOVO(INT1)*COEFF
      TMP1(ICOUNT) = TMP1(ICOUNT) + T1
C
C END LOOP OVER IE(A),IE2(B)
C
 5800 CONTINUE
C
 5832           CONTINUE
                IST2 = IBCON1(KKJ2)+1
                IEN2 = IBCON1(KKJ2+1)-1
                IF (KKJ2.EQ.NB-1) IEN2=NACT
 5830        CONTINUE
C
C END OF BETA DEXCITATION IE2 -> IA2
C
 5822           CONTINUE
                IST = IACON1(KKJ)+1
                IEN = IACON1(KKJ+1)-1
                IF (KKJ.EQ.NA-1) IEN=NACT
 5820        CONTINUE
C
C END OF ALPHA DEXCITATION IE -> IA
C
       DO II=1,ICOUNT
          EAAEE = EAAEE +
     *   (TMP1(II)*TMP1(II)+TMP3(II)*TMP3(II))/TMP4(II)
          TMP1(II) = 0.0D+00
          TMP3(II) = 0.0D+00
          TMP4(II) = 1.0D+00
       ENDDO
       ICOUNT = 0
C
             CALL ADVANC(IBCON1,NB-1,NACT)
 5810     CONTINUE
C
C ------
C END OF LOOP OVER 1-DOWN BETA
C ------
C
          IF (NVAL.EQ.0) GOTO 5901
C
C ------
C LOOP OVER 1ST ORDER BETAS IV -> IA1
C ------
C
            E0AD = EPT0 - E0A0 - E0V
C
C LOOP OVER 1 UP BETAS
C
            DO II=1,NB+1
               IBCON1(II) = II
            ENDDO
            DO 5900 IJB = 1,N1B
               ISYB = ISYV
               E0B1 = E0AD
               DO II=1,NB+1
                  ISYB = IMUL(ISYB,IOB(IBCON1(II)+NVAL))
                  E0B1 = E0B1 - EFCK(IBCON1(II)+NVAL)
               ENDDO
               ISYL = IMUL(ISA0,ISYB)
               ISYT = ITAB(ISYL)
C
C
C LOOP OVER BETA DEXCITES FROM ACTIVE SET IA1
C
           DO 5920 IEL1=1,NB+1
              IA1 = IBCON1(IEL1)+NVAL
              IS2 = IOB(IA1)
C
              CALL STR0VA(IBCON1,IBCON2,NB+1,IEL1,NVAL,NVAL,IPER2)
              IPB0 = POSDET(NACT,NB,IBCON2,IFA)
              ICAB = ISPB(IPB0)
C
C
C LOOP OVER ALPHA DEXCITES INTO ACTIVE IA2
C
           IST = 1
           IEN = IACON1(1)-1
           IF (NA.EQ.1) IEN=NACT
           DO 5910 KKJ=1,NA
              DO 5912 JJ=IST,IEN
                 IA2 = JJ + NVAL
                 IS1 = IOB(IA2)
                 IP1 = IMUL(IS1,IS2)
                 IF (IP1.NE.ISYT) GOTO 5912
C
           CALL STR0AE(IACON1,IACON2,NA,KKJ,JJ,IPER)
           IPERT = IPER*IPER2
           IPA0 = POSDET(NACT,NA,IACON2,IFA)
           ITP0 = ISPA(IPA0) + ICAB
           COEFF = CI(ITP0)*IPERT
C
C
C LOOP OVER BETA VALENCE AND THEN ALPHA EXTERNAL
C
          ICOUNT = 0
          DO 5930 IV=1,NVAL
             IS3 = IOB(IV)
             E0B1V = E0B1 + EFCK(IV)
             IA1V = INPT(IA1) + IV
             IA2A1V = (IA2-1)*M2 + IA1V
C
          DO 5940 IE=1,NEXT
             ICOUNT = ICOUNT + 1
             JE = IE + M1
             IS4 = IOB(JE)
             IP2 = IMUL(IS4,IS3)
             IF (IP1.NE.IP2) GOTO 5940
             TMP4(ICOUNT) = E0B1V - EFCK(JE)
C
C MATRIX ELEMENT
C
         T = SVOOO(IE,IA2A1V)*COEFF
         TMP3(ICOUNT) = TMP3(ICOUNT) + T
C
 5940     CONTINUE
 5930     CONTINUE
C
C END OF BETA DEXCITES FROM ACTIVE SET IA1
C
 5912         CONTINUE
              IST = IACON1(KKJ)+1
              IEN = IACON1(KKJ+1)-1
              IF (KKJ.EQ.NA-1) IEN=NACT
 5910      CONTINUE
C
 5920      CONTINUE
C
C END OF ALPHA DEXCITES INTO ACTIVE IA2
C
       DO II=1,ICOUNT
          EVAAE = EVAAE +(TMP3(II)*TMP3(II))/TMP4(II)
          TMP3(II) = 0.0D+00
          TMP4(II) = 1.0D+00
       ENDDO
       ICOUNT = 0
C
               CALL ADVANC(IBCON1,NB+1,NACT)
 5900       CONTINUE
 5901 CONTINUE
C
C ------
C END OF LOOP OVER 1ST ORDER BETAS IV -> IA1
C ------
C
        CALL DDI_DLBNEXT(MY_TASK)
      END IF     ! MY TASK
C
            CALL ADVANC(IACON1,NA-1,NACT)
 5805    CONTINUE
C
C END OF LOOP OVER 1-DOWN ALPHA
C
C END OF EXPERIMENT
C
C -------------------------------------------
C *******************************************
C -------------------------------------------
C
C LOOP OVER ALL 2ND ORDER ALPHA EXCITATIONS
C -------------------------------------------
C *******************************************
C -------------------------------------------
C
      DO II=1,NB
         IBCON1(II) = II
      ENDDO
C
      DO 6200 IJB=1,NBLP
C
        IF (IJB+NALP+NBUFF+ND1A-1.EQ.MY_TASK) THEN
C
         ICAB = ISPB(IJB)
         ISYB = IMUL(ISYMB(IJB),ISYV)
         E0B0 = EPT0 - E0V - E0V
         DO II=1,NB
            E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
         ENDDO
C
         IF (NVAL.EQ.0) GOTO 6101
C
C RELOOP OVER 2ND ORDER ALPHAS, (IV1,IV2 -> IA1,IA2)
C
C LOOP OVER 2 UP ALPHAS
C
      DO II=1,NA+2
         IACON1(II) = II
      ENDDO
      DO 6100 IJK=1,N2A
         ISA2 = ISYV
         E0A2 = E0B0
         DO II=1,NA+2
            E0A2 = E0A2 - EFCK(IACON1(II)+NVAL)
            ISA2 = IMUL(ISA2,IOB(IACON1(II)+NVAL))
         ENDDO
         ITAS = ITAB(ISA2)
         ISYL = IMUL(ITAS,ISYB)
C
C LOOP OVER DEXCITATIONS FROM ALPHA (IA1<IA2)
C
       DO 6120 IEL1=1,NA+2
          IA1 = IACON1(IEL1)+NVAL
          IS1 = IOB(IA1)
          IA1T = INPT(IA1)
C
       DO 6130 IEL2=IEL1+1,NA+2
          IA2 = IACON1(IEL2)+NVAL
          IS2 = IOB(IA2)
          IP1 = IMUL(IS1,IS2)
          IF (IP1.NE.ISYL) GOTO 6130
          IA2T = INPT(IA2)
C
C DETERMINE 0TH ORDER ALPHA, POS/PERM
C
      CALL STR0VVAA(IACON1,IACON2,NA+2,IEL1,IEL2,NVAL,NVAL,NVAL,IPER)
      IPA0 = POSDET(NACT,NA,IACON2,IFA)
      ITP0 = ISPA(IPA0) + ICAB
      COEFF = CI(ITP0)*IPER
C
C NOW TO LOOP OVER ALPHA VALENCE, IV1<IV2
C
      ICOUNT = 0
      DO 6140 IV1=1,NVAL
         IS3 = IOB(IV1)
         E0BV = E0A2 + EFCK(IV1)
         IA1V1 = IA1T + IV1
         IA2V1 = IA2T + IV1
         IA2V1T = INPT(IA2V1)
C
      DO 6150 IV2=1,IV1-1
         ICOUNT = ICOUNT + 1
         IS4 = IOB(IV2)
         IP2 = IMUL(IS4,IS3)
         IF (IP1.NE.IP2) GOTO 6150
         TMP4(ICOUNT) = E0BV + EFCK(IV2)
C
C MATRIX ELEMENT
C
      IA1V2 = IA1T + IV2
      IA2V2 = IA2T + IV2
      INT1 = INPT(IA2V2) + IA1V1
      INT2 = IA2V1T + IA1V2
      T = (SI2(INT1) - SI2(INT2))*COEFF
      TMP3(ICOUNT) = TMP3(ICOUNT) + T
C
 6150 CONTINUE
 6140 CONTINUE
C
C END OF LOOP OVER VALENCE IV1<IV2
C
 6130 CONTINUE
 6120 CONTINUE
C
C END OF LOOP OVER DEXCITATIONS FROM ALPHA (IA1<IA2)
C
       DO II=1,ICOUNT
          EVVAA = EVVAA +(TMP3(II)*TMP3(II))/TMP4(II)
          TMP3(II) = 0.0D+00
          TMP4(II) = 1.0D+00
       ENDDO
       ICOUNT = 0
C
         CALL ADVANC(IACON1,NA+2,NACT)
 6100 CONTINUE
C
C END OF LOOP OVER 2 UP ALPHAS
C
C END RELOOP OVER 2ND ORDER ALPHAS, (IV1,IV2 -> IA1,IA2)
C
C -------------------------------------------
C *******************************************
C -------------------------------------------
C
C -----------------------------------------------
C LOOP OVER 2ND ORDER ALPHA EXCITES, (IV,IA -> IE1,IE2)
C THESE GO WITH 0TH ORDER BETAS
C -----------------------------------------------
C THESE EXCITATIONS ALSO INCLUDE IV(B),IA(A) -> IE1(B)<IE2(A)
C AND                            IV(B),IA(A) -> IE1(A)<IE2(B)
C AND                            IV(B),IA(A) -> IE1(B),IE1(A)
C
         ITAS = ITAB(ISYB)
C
C LOOP OVER 1 DOWN ALPHAS
C
      DO II=1,NA-1
         IACON1(II) = II
      ENDDO
      DO 8030 IJK=1,ND1A
         ISYA0 = ISYV
         E0A0 = E0B0
         DO II=1,NA-1
            E0A0 = E0A0 - EFCK(IACON1(II)+NVAL)
            ISYA0 = IMUL(ISYA0,IOB(IACON1(II)+NVAL))
         ENDDO
         IMS = IMUL(ISYA0,ITAS)
C
C LOOP OVER DEXCITATIONS INTO ACTIVE (IE2 -> IA)
C
         IST = 1
         IEN = IACON1(1)-1
         IF (NA.EQ.1) IEN=NACT
         DO 8050 KKJ=1,NA
            DO 8052 JJ=IST,IEN
               IA = JJ + NVAL
               IS3 = IOB(IA)
               IF (IS3.NE.IMS) GOTO 8052
C
C DETERMINE 0TH ORDER ALPHA STRING, POS/PERM AND MATRIX ELEMENT
C
        CALL STR0AE(IACON1,IACON2,NA,KKJ,JJ,IPER2)
        IPA0 = POSDET(NACT,NA,IACON2,IFA)
        ITP0 = ICAB + ISPA(IPA0)
        COEFF = CI(ITP0)*IPER2
C
C LOOP OVER DOUBLE ALPHA DEXCITATIONS (IE1<IE2 -> IV,IA)
C
      ICOUNT = 0
C
      DO 8000 JE1=NQS,NQQ
         IS1 = IOB(JE1)
         IP1 = IMUL(IS3,IS1)
         E0A0E = E0A0 - EFCK(JE1)
         JDA = (JE1-M1-1)*M1 + IA
         JDAT = INPT(JDA)
C
      DO 8010 IV=1,NVAL
         IS2 = IOB(IV)
         IPT = IMUL(IS2,IP1)
         E0A0EV = E0A0E + EFCK(IV)
         JDV = JDA - IA + IV
         JDVT = INPT(JDV)
C
      DO 8020 JE2=NQS,JE1-1
         IS4 = IOB(JE2)
         IF (IS4.NE.IPT) GOTO 8020
         ICOUNT = ICOUNT + 1
         TMP4(ICOUNT)= E0A0EV-EFCK(JE2)
C
C DETERMINE MATRIX ELEMENT
C
C ME = [IE1,IV | IE2,IA] - [IE1,IA | IE2,IV]
C
       IDV = (JE2-M1-1)*M1 + IV
       IDA = IDV - IV + IA
       INT1 = JDVT + IDA
       INT2 = JDAT + IDV
       T1 = SVOVO(INT1)*COEFF
       T2 = SVOVO(INT2)*COEFF
       TT = T1 - T2
C
       TMP1(ICOUNT) = TMP1(ICOUNT) + T1
       TMP2(ICOUNT) = TMP2(ICOUNT) + T2
       TMP3(ICOUNT) = TMP3(ICOUNT) + TT
C
 8020 CONTINUE
C
C IE1 = IE2
C
       IF (IS3.NE.IS2) GOTO 8010
       ICOUNT = ICOUNT + 1
       TMP4(ICOUNT) = E0A0EV - EFCK(JE1)
       INT1 = JDAT + JDV
       T1 = SVOVO(INT1)*COEFF
       TMP1(ICOUNT) = TMP1(ICOUNT) + T1
C
 8010 CONTINUE
C
 8000 CONTINUE
C
C END OF DOUBLE ALPHA DEXCITATIONS ( IE1<IE2 -> IV,IA)
C
 8052          CONTINUE
               IST = IACON1(KKJ)+1
               IEN = IACON1(KKJ+1)-1
               IF (KKJ.EQ.NA-1) IEN=NACT
 8050       CONTINUE
C
C END OF ALPHA DEXCITATIONS (IE2 -> IA)
C
CFORNOW
       DO II=1,ICOUNT
          EVAEE = EVAEE +
     *    (TMP1(II)*TMP1(II)+TMP2(II)*TMP2(II)+TMP3(II)*TMP3(II))
     *    /TMP4(II)
          TMP1(II) = 0.0D+00
          TMP2(II) = 0.0D+00
          TMP3(II) = 0.0D+00
          TMP4(II) = 1.0D+00
       ENDDO
       ICOUNT = 0
C
         CALL ADVANC(IACON1,NA-1,NACT)
 8030 CONTINUE
 6101 CONTINUE
C
C END OF LOOP OVER DOWN 1 ALPHAS
C
C --------------------------------------------------
C END LOOP OVER 2ND ORDER ALPHA EXCITES (IV,IA -> IE1,IE2)
C THEY GO WITH 0TH ORDER BETAS
C --------------------------------------------------
C
C --------------------------------------------------
C **************************************************
C --------------------------------------------------
C
C LOOP OVER 2ND ORDER ALPHAS, (IA1,IA2 -> IE1,IE2)
C
      DO II=1,NA-2
         IACON1(II) = II
      ENDDO
      DO 9020 IJK=1,ND2A
         E0A0 = E0B0
         ISA0 = ISYV
         DO II=1,NA-2
            E0A0 = E0A0 - EFCK(IACON1(II)+NVAL)
            ISA0 = IMUL(ISA0,IOB(IACON1(II)+NVAL))
         ENDDO
C
C LOOP OVER DOUBLE ALPHA DEXCITATIONS ( IE1<IE2 -> IA1<IA2 )
C
            IST = 1
            IEN = IACON1(1)-1
            IF (NA.EQ.2) IEN=NACT
            DO 9040 KKJ=1,NA-1
               DO 9042 JJ=IST,IEN
                  IA1 = JJ + NVAL
                  IS3 = IOB(IA1)
                  ISYAE1 = IMUL(ISA0,IS3)
                  CALL STR0AE(IACON1,IACON2,NA-1,KKJ,JJ,IPER)
C
            IST2 = JJ+1
            IEN2 = IEN
            DO 9050 KKJ2=KKJ+1,NA
               DO 9052 JJ2=IST2,IEN2
                  IA2 = JJ2 + NVAL
                  IS4 = IOB(IA2)
                  ISYAE2 = IMUL(ISYAE1,IS4)
                  ITAS = ITAB(ISYAE2)
                  IF (ISYB.NE.ITAS) GOTO 9052
                  IP2 = IMUL(IS4,IS3)
C
C DETERMINE NEW 0TH ORDER ALPHA, POS/PERM AND MATRIX ELEMENT
C
         CALL STR0AE(IACON2,IBCON2,NA,KKJ2,JJ2,IPER2)
         IPERT = IPER*IPER2
         IPA0 = POSDET(NACT,NA,IBCON2,IFA)
         ITP0 = ISPA(IPA0) + ICAB
         COEFF = CI(ITP0)*IPERT
C
      ICOUNT = 0
      DO 9000 JE1=NQS,NQQ
         IS1 = IOB(JE1)
         E0AE1 = E0A0 - EFCK(JE1)
         IE1A1 = (JE1-M1-1)*M1 + IA1
         IE1A2 = IE1A1 - IA1 + IA2
         IE1A1T = INPT(IE1A1)
         IE1A2T = INPT(IE1A2)
C
      DO 9010 JE2=NQS,JE1-1
         ICOUNT = ICOUNT + 1
         IS2 = IOB(JE2)
         IP1 = IMUL(IS1,IS2)
C
         IF (IP1.NE.IP2) GOTO 9010
         TMP4(ICOUNT) = E0AE1 - EFCK(JE2)
C
C ME = [IE2,IA2 | IE1,IA1] - [IE2,IA1 | IE1,IA2]
C
         IE2A1 = (JE2-M1-1)*M1 + IA1
         IE2A2 = IE2A1 - IA1 + IA2
         INT1 = IE1A1T + IE2A2
         INT2 = IE1A2T + IE2A1
         T = SVOVO(INT1) - SVOVO(INT2)
         TMP3(ICOUNT) = TMP3(ICOUNT) + COEFF*T
C
 9010 CONTINUE
 9000 CONTINUE
C
 9052          CONTINUE
               IST2 = IACON2(KKJ2)+1
               IEN2 = IACON2(KKJ2+1)-1
               IF (KKJ2.EQ.NA-1) IEN2=NACT
 9050       CONTINUE
C
 9042          CONTINUE
               IST = IACON1(KKJ)+1
               IEN = IACON1(KKJ+1)-1
               IF (KKJ.EQ.NA-2) IEN=NACT
 9040       CONTINUE
C
CFORNOW
         DO II=1,ICOUNT
            EAAEE = EAAEE + (TMP3(II)**2.0D+00)/TMP4(II)
            TMP3(II) = 0.0D+00
            TMP4(II) = 1.0D+00
         ENDDO
         ICOUNT = 0
C
C END OF LOOP OVER DOUBLE ALPHA DEXCITATIONS ( IE1<IE2 -> IA1<IA2 )
C
         CALL ADVANC(IACON1,NA-2,NACT)
 9020 CONTINUE
C
C END OF LOOP OVER DOWN 1 ORDER ALPHAS
C
C END LOOP OVER 2ND ORDER ALPHAS, (IA1,IA2 -> IE1,IE2)
C
        CALL DDI_DLBNEXT(MY_TASK)
      END IF     ! MY TASK
C
            CALL ADVANC(IBCON1,NB,NACT)
 6200    CONTINUE
C
         IF (NVAL.EQ.0) THEN
            CALL DDI_DLBRESET
            RETURN
         END IF
C
C ------------------------------------------------------------
C NOW FOR THE FINAL CONTRIBUTION, WHICH IS IV1,IV2 -> IE1,IE2
C AS DAVIDSON ET AL POINTED OUT (J. CHEM. PHYS. 1994,100,3672)
C FOR EACH EXCITATION, THERE IS ONLY ONE VIRTUAL DETERMINANT
C WHICH SIMPLIFIES THINGS INCREDIBLY !!!!!!!!!!!!!!!!!!!!!!!!
C ------------------------------------------------------------
C
C LOOP OVER 0TH ORDER ALPHAS FIRST
C
      DO II=1,NA
         IACON1(II) = II
      ENDDO
      E0A0 = EPT0 - E0V - E0V
C
      DO 9500 IJK4=1,NALP
C
        IF (IJK4+NALP+NBUFF+ND1A+NBLP-1.EQ.MY_TASK) THEN
C
         ICIT = ISPA(IJK4)
         ISA0 = ISYMA(IJK4)
         ITAS = ITAB(ISA0)
         E0A2 = E0A0
         DO II=1,NA
            E0A2 = E0A2 - EFCK(IACON1(II)+NVAL)
         ENDDO
C
C LOOP OVER CORRECT 0TH ORDER BETAS
C
         DO II=1,NB
            IBCON1(II)=II
         ENDDO
         DO 9510 INB1 = 1,NBLP
            IF (ISYMB(INB1).NE.ITAS) GOTO 9509
            E0B0 = E0A2
            DO II=1,NB
               E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
            ENDDO
            ICIT = ICIT + 1
            COEFF = 2.0D+00*CI(ICIT)*CI(ICIT)
            EINT = 0.0D+00
C
C LOOP OVER ALL POSSIBLE EXCITATIONS
C
            IE1T = -M1
            DO 9542 JE1=NQS,NQQ
               IS1 = IOB(JE1)
               E0B0E = E0B0 - EFCK(JE1)
               IE1T = IE1T + M1
            DO 9544 IV1=1,NVAL
               IS2 = IOB(IV1)
               IP1 = IMUL(IS1,IS2)
               E0B0EV = E0B0E + EFCK(IV1)
               IE1V1 = IE1T + IV1
C
            IE2T = -M1
            DO 9552 JE2=NQS,JE1-1
               IS3 = IOB(JE2)
               IPT  = IMUL(IS3,IP1)
               E0B0EVE = E0B0EV - EFCK(JE2)
               IE2T = IE2T + M1
               IE2V1 = IE2T + IV1
               INT1T = INPT(IE1V1) + IE2T
            DO 9553 IV2 = 1,IV1-1
               IS4 = IOB(IV2)
               IF (IS4.NE.IPT) GOTO 9553
               E0B0EVEV = E0B0EVE + EFCK(IV2)
               IE1V2 = IE1T + IV2
C
               INT1 = INT1T + IV2
               INT2 = INPT(IE1V2) + IE2V1
               T1 = SVOVO(INT1)
               T2 = SVOVO(INT2)
               TT = T1 - T2
        EINT = EINT + (T1*T1 + T2*T2 + TT*TT)/E0B0EVEV
C
 9553       CONTINUE
C
C IV2 = IV1, JE1>JE2
C
            IF (IS2.NE.IPT) GOTO 9552
            E0B0EVEV = E0B0EVE + EFCK(IV1)
            INT1 = INPT(IE1V1) + IE2V1
            T1 = SVOVO(INT1)
            EINT = EINT + (T1*T1)/E0B0EVEV
C
 9552       CONTINUE
C
C NOW FOR JE1=JE2, IV1>IV2
C
            IPT = IMUL(IS1,IP1)
            E0B0EVE = E0B0EV - EFCK(JE1)
            DO 9554 IV2 = 1,IV1-1
               IS4 = IOB(IV2)
               IF (IS4.NE.IPT) GOTO 9554
               E0B0EVEV = E0B0EVE + EFCK(IV2)
               IE1V2 = IE1T + IV2
               INT1 = INPT(IE1V1) + IE1V2
               T1 = SVOVO(INT1)
               EINT = EINT + (T1*T1)/E0B0EVEV
C
 9554       CONTINUE
C
C NOW FOR JE1=JE2,IV1=IV2
C
             E0B0EVEV = E0B0EV + EFCK(IV1) - EFCK(JE1)
             INT1 = INPT(IE1V1+1)
             T1 = SVOVO(INT1)
             EINT = EINT + 0.5D+00*(T1*T1)/E0B0EVEV
C
 9544       CONTINUE
 9542       CONTINUE
C
         EVVEE = EVVEE + COEFF*EINT
C
C
 9509      CALL ADVANC(IBCON1,NB,NACT)
 9510    CONTINUE
C
C END OF CORRECT 0TH ORDER BETAS
C
        CALL DDI_DLBNEXT(MY_TASK)
      END IF     ! MY TASK
C
         CALL ADVANC(IACON1,NA,NACT)
 9500 CONTINUE
C
C END OF LOOP OVER 0TH ORDER ALPHAS
C
      CALL DDI_DLBRESET   ! HMRPT
      RETURN
      END
C
C
C*MODULE DEMRPT  *DECK STR0VA
C     ----------------------------------------------------------
      SUBROUTINE STR0VA(ICON1,ICON2,NE,IE,IV,NVAL,IPER)
C     ----------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION ICON1(NE),ICON2(NE-1)
C
      DO II=1,IE-1
         ICON2(II) = ICON1(II)
      ENDDO
      DO II=IE+1,NE
         ICON2(II-1) = ICON1(II)
      ENDDO
C
      ISWAP = (IE-1) + (NVAL-IV)
      IPER = ((-1)**ISWAP)
C
      RETURN
      END
C
C*MODULE DEMRPT  *DECK STR0AE
C     ----------------------------------------------------------
      SUBROUTINE STR0AE(ICON1,ICON2,NE,KKJ,JJ,IPER)
C     ----------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION ICON1(NE-1),ICON2(NE)
C
      DO II=1,KKJ-1
         ICON2(II) = ICON1(II)
      ENDDO
      ICON2(KKJ) = JJ
      DO II=KKJ+1,NE
         ICON2(II) = ICON1(II-1)
      ENDDO
C
      ISWAP = (NE-KKJ)
      IPER = ((-1)**ISWAP)
C
      RETURN
      END
C
C*MODULE DEMRPT  *DECK STR0VVAA
C     ----------------------------------------------------------
      SUBROUTINE STR0VVAA(ICON1,ICON2,NE,IE1,IE2,
     *                    IV1,IV2,NVAL,IPER)
C     ----------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION ICON1(NE),ICON2(NE-2)
C
      DO II=1,IE1-1
         ICON2(II) = ICON1(II)
      ENDDO
      DO II=IE1+1,IE2-1
         ICON2(II-1) = ICON1(II)
      ENDDO
      DO II=IE2+1,NE
         ICON2(II-2) = ICON1(II)
      ENDDO
C
      ISWAP = (IE1-1)+(NVAL-IV1-1)+(IE2-2)+(NVAL-IV2)
      IPER = (-1)**ISWAP
C
      RETURN
      END
C
C*MODULE DEMRPT  *DECK ME0VA1B
C     ----------------------------------------------------------
      SUBROUTINE ME0VA1B(IV,IA,IBCON1,NB,IACON1,NA,NVAL,
     *                   INPT,SI1,SI2,T)
C     ----------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION IBCON1(NB),IACON1(NA),INPT(*)
      DIMENSION SI1(*),SI2(*)
C
C DETERMINE MATRIX ELEMENT FOR IV -> IA EXCITATION
C
      IJ = INPT(IA) + IV
      T = SI1(IJ)
C
      DO 100 K=1,NVAL
         IF (K.EQ.IV) GOTO 100
         KK = INPT(K) + K
         IJKK = INPT(IJ) + KK
         MA = MAX(IV,K)
         MI = MIN(IV,K)
         KV = INPT(MA) + MI
         KA = INPT(IA) + K
         KAKV = INPT(KA) + KV
         T = T + 2*SI2(IJKK) - SI2(KAKV)
  100 CONTINUE
C
      KK = INPT(IV) + IV
      IJKK = INPT(IJ) + KK
      T = T + SI2(IJKK)
C
      DO IK=1,NB
         K = IBCON1(IK) + NVAL
         KK = INPT(K) + K
         MA = MAX(IJ,KK)
         MI = MIN(IJ,KK)
         IJKK = INPT(MA) + MI
         KV = INPT(K) + IV
         MA = MAX(IA,K)
         MI = MIN(IA,K)
         KA = INPT(MA) + MI
         KAKV = INPT(KA) + KV
         T = T + SI2(IJKK) - SI2(KAKV)
      ENDDO
C
      DO IK=1,NA
         K = IACON1(IK) + NVAL
         KK = INPT(K) + K
         MA = MAX(IJ,KK)
         MI = MIN(IJ,KK)
         IJKK = INPT(MA) + MI
         T = T + SI2(IJKK)
      ENDDO
C
      RETURN
      END
C
C*MODULE DEMRPT  *DECK ME0VE1B
C     ----------------------------------------------------------
      SUBROUTINE ME0VE1B(IV,IE,IBCON1,NB,IACON1,NA,NVAL,NACT,
     *                   NEXT,INPT,SI1,SVOOO,M2,T)
C     ----------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION IBCON1(NB+2),IACON1(NA+2),INPT(*)
      DIMENSION SI1(*),SVOOO(NEXT,*)
C
C DETERMINE MATRIX ELEMENT FOR IV -> IE EXCITATION
C
      IJ = INPT(IE+NVAL+NACT) + IV
      T = SI1(IJ)
C
      DO 100 K=1,NVAL
         IF (K.EQ.IV) GOTO 100
         KK = INPT(K) + K
         IKK = (IV-1)*M2 + KK
         MA = MAX(IV,K)
         MI = MIN(IV,K)
         KV = INPT(MA) + MI
         KKV = (K-1)*M2 + KV
         T = T + 2*SVOOO(IE,IKK) - SVOOO(IE,KKV)
  100 CONTINUE
C
      KK = INPT(IV) + IV
      IKK = (IV-1)*M2 + KK
      T = T + SVOOO(IE,IKK)
C
      DO IK=1,NB
         K = IBCON1(IK) + NVAL
         KK = INPT(K) + K
         IKK = (IV-1)*M2 + KK
         KV = INPT(K) + IV
         KKV = (K-1)*M2 + KV
         T = T + SVOOO(IE,IKK) - SVOOO(IE,KKV)
      ENDDO
C
      DO IK=1,NA
         K = IACON1(IK) + NVAL
         KK = INPT(K) + K
         IKK = (IV-1)*M2 + KK
         T = T + SVOOO(IE,IKK)
      ENDDO
C
      RETURN
      END
C
C*MODULE DEMRPT  *DECK ME0AE1B
C     ----------------------------------------------------------
      SUBROUTINE ME0AE1B(IA,IE,IBCON1,NB,IACON1,NA,NVAL,NACT,
     *     NEXT,INPT,SI1,SVOOO,M2,T)
C     ----------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION IBCON1(NB+2),IACON1(NA+2),INPT(*)
      DIMENSION SI1(*),SVOOO(NEXT,*)
C
C DETERMINE MATRIX ELEMENT FOR IA -> IE EXCITATION
C
      IJ = INPT(IE+NVAL+NACT) + IA
      T = SI1(IJ)
C
      DO K=1,NVAL
         KK = INPT(K) + K
         IKK = (IA-1)*M2 + KK
         KA = INPT(IA) + K
         KKA = (K-1)*M2 + KA
         T = T + 2*SVOOO(IE,IKK) - SVOOO(IE,KKA)
      ENDDO
C
      DO IK=1,NB-1
         K = IBCON1(IK) + NVAL
         KK = INPT(K) + K
         IKK = (IA-1)*M2 + KK
         MA = MAX(K,IA)
         MI = MIN(K,IA)
         KA = INPT(MA) + MI
         KKA = (K-1)*M2 + KA
         T = T + SVOOO(IE,IKK) - SVOOO(IE,KKA)
      ENDDO
C
      DO IK=1,NA
         K = IACON1(IK) + NVAL
         KK = INPT(K) + K
         IKK = (IA-1)*M2 + KK
         T = T + SVOOO(IE,IKK)
      ENDDO
C
      RETURN
      END
C
C*MODULE DEMRPT  *DECK HMRPT0
C     ----------------------------------------------------------
      SUBROUTINE HMRPT0(SI1,SI2,SVOOO,SVOVO,EFCK,EPT0,CI,
     *             NVAL,NACT,NEXT,NCI,NA,NB,IACON1,IBCON1,
     *             IACON2,IBCON2,
     *             NALP,NBLP,ISYMA,ISYMB,ISPA,ISPB,
     *             NSYM,IMUL,ITAB,IOB,INPT,IFA,
     *             TMP1,TMP2,TMP3,TMP4,NTMPSZ,
     *             EVA,EVVAA,EVE,EAE,EVVAE,EVAAE,EVVEE,EVAEE,EAAEE)
C     ----------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      INTEGER POSDET
      DIMENSION SI1(*),SI2(*),SVOOO(NEXT,*),SVOVO(*)
      DIMENSION EFCK(*)
      DIMENSION CI(NCI)
      DIMENSION IACON1(NA+2),IBCON1(NA+2)
      DIMENSION IACON2(NA+2),IBCON2(NA+2)
      DIMENSION ISYMA(NALP),ISYMB(NBLP),ISPA(NALP),ISPB(NBLP)
      DIMENSION IMUL(NSYM,NSYM),ITAB(NSYM),IOB(*)
      DIMENSION INPT(*)
      DIMENSION IFA(0:NACT,0:NACT)
      DIMENSION TMP1(NTMPSZ),TMP2(NTMPSZ),TMP3(NTMPSZ),TMP4(NTMPSZ)
C
      ICOUNT = 0
      M1 = NVAL+NACT
      M2 = (M1*(M1+1))/2
      NQS = M1 + 1
      NQQ = M1 + NEXT
C
      IF (NA.LT.NACT) THEN
         N1A =  IFA(NACT,NA+1)
      ELSE
         N1A = 0
      ENDIF
      IF (NB.LT.NACT) THEN
         N1B =  IFA(NACT,NB+1)
      ELSE
         N1B = 0
      ENDIF
C
C--   IF (NA.LT.NACT-1) THEN
C--      N2A = IFA(NACT,NA+2)
C--   ELSE
C--      N2A = 0
C--   ENDIF
C
      IF (NB.LT.NACT-1) THEN
         N2B = IFA(NACT,NB+2)
      ELSE
         N2B = 0
      ENDIF
C
      IF (NA.GE.2) THEN
         ND1A = IFA(NACT,NA-1)
      ELSEIF (NA.EQ.1) THEN
         ND1A = 1
      ELSEIF (NA.EQ.0) THEN
         ND1A = 0
      ENDIF
C
      IF (NB.GE.2) THEN
         ND1B = IFA(NACT,NB-1)
      ELSEIF (NB.EQ.1) THEN
         ND1B = 1
      ELSEIF (NB.EQ.0) THEN
         ND1B = 0
      ENDIF
C
C--   IF (NA.GE.3) THEN
C--      ND2A = IFA(NACT,NA-2)
C--   ELSEIF (NA.EQ.2) THEN
C--      ND2A = 1
C--   ELSEIF (NA.LE.1) THEN
C--      ND2A = 0
C--   ENDIF
C
      IF (NB.GE.3) THEN
         ND2B = IFA(NACT,NB-2)
      ELSEIF(NB.EQ.2) THEN
         ND2B = 1
      ELSEIF(NB.LE.1) THEN
         ND2B = 0
      ENDIF
C
      E0V = 0.0D+00
      ISYV = 1
      DO II=1,NVAL
         E0V = E0V + EFCK(II)
         ISYV = IMUL(ISYV,IOB(II))
      ENDDO
C
C  LOOP OVER ALL POSSIBLE EXCITED DETERMINANTS, LOTS OF DIFFERENT TYPES
C
C ------------------------------------------------------------------
C  FIRST LOOP OVER ZEROTH ORDER ALPHAS, ORBITALS NUMBERED AS ACTIVE,
C  1,2,etc
C ------------------------------------------------------------------
C
      DO II=1,NA
         IACON1(II) = II
      ENDDO
C
      E0AV = E0V
      ISYAV = ISYV
C
      CALL DDI_DLBNEXT(MY_TASK)
C
      DO 2000 IJK=1,NALP
C
        IF (IJK-1.EQ.MY_TASK) THEN
C
         ICAT = ISPA(IJK)
         ISA1 = IMUL(ISYMA(IJK),ISYAV)
         ITAS = ITAB(ISA1)
         E0A0 = E0AV
         DO II=1,NA
            E0A0 = E0A0 + EFCK(IACON1(II)+NVAL)
         ENDDO
         E0AD = EPT0 - E0A0 - E0V
C
C  LOOP OVER 1ST AND 2ND ORDER BETAS
C
         IF (NVAL.EQ.0) GOTO 2901
C
C -------------------------------------------
C RELOOP OVER 1ST ORDER BETA VAL -> ACTIVE
C -------------------------------------------
C
C LOOP OVER 1 UP BETAS
C
      DO II=1,NB+1
         IBCON1(II) = II
      ENDDO
      DO 2900 IJB=1,N1B
         ISYB = ISYV
         E0B0 = E0AD
         DO II=1,NB+1
            E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
            ISYB = IMUL(ISYB,IOB(IBCON1(II)+NVAL))
         ENDDO
         ISYL = IMUL(ITAS,ISYB)
C
C LOOP OVER SINGLE DEXCITATIONS OUT OF ACTIVE
C
         DO 2910 IEL=1,NB+1
            IA = IBCON1(IEL) + NVAL
            IS1 = IOB(IA)
            IF (IS1.NE.ISYL) GOTO 2910
C
C DETERMINE 0TH ORDER BETA, POS/PERM
C
          CALL STR0VA(IBCON1,IBCON2,NB+1,IEL,NVAL,NVAL,IPER)
          IPB0 = POSDET(NACT,NB,IBCON2,IFA)
          ITP0 = ICAT + ISPB(IPB0)
          COEFF = CI(ITP0)*IPER
C
C LOOP OVER BETA VALENCE
C
          DO 2920 IV=1,NVAL
             IS2 = IOB(IV)
             IF (IS1.NE.IS2) GOTO 2920
             TMP4(IV) = E0B0 + EFCK(IV)
C
C MATRIX ELEMENT
C
       CALL ME0VA1B(IV,IA,IBCON2,NB,IACON1,NA,NVAL,INPT,SI1,SI2,T)
       TMP3(IV) = TMP3(IV) + T*COEFF
C
 2920     CONTINUE
C
C END OF LOOP OVER BETA VALENCE
C
 2910    CONTINUE
C
C END OF PURE SINGLE BETA DEXCITATIONS OUT OF ACTIVE
C
C NOW FOR DOUBLE DEXCITATIONS
C  DOUBLE DEXCITATIONS MUST !!!!! INCLUDE THE SINGLES ABOVE !!!!!
C  START WITH THIS TYPE FIRST, IE BETA IA(?) -> IV
C
      DO 2930 IEL=1,NB+1
         IA = IBCON1(IEL)+NVAL
         JA = IA - NVAL
         IS1 = IOB(IA)
         CALL STR0VA(IBCON1,IBCON2,NB+1,IEL,NVAL,NVAL,IPER)
         IPB0 = POSDET(NACT,NB,IBCON2,IFA)
         ICAB = ISPB(IPB0)
C
C  2ND EXCITATION: BETA ACT (IA2 > IA) -> ACT (JJA)
C  TOTAL = BETA ( IA < IA2 -> IV,JJA)
C
         DO 2940 IEL2=IEL,NB
            IA2 = IBCON2(IEL2)+NVAL
            IS2 = IOB(IA2)
            IP1 = IMUL(IS1,IS2)
C
         IST = 1
         IEN = IBCON2(1)-1
         DO 2950 KKJ=1,NB+1
            DO 2952 JJ=IST,IEN
               IF (JJ.EQ.JA) GOTO 2952
               JJA = JJ + NVAL
               IS3 = IOB(JJA)
               IPT = IMUL(IS3,IP1)
               IF (IPT.NE.ISYL) GOTO 2952
C
               MA = MAX(IA2,JJA)
               MI = MIN(IA2,JJA)
               IA3A2 = INPT(MA) + MI
               MA = MAX(IA,JJA)
               MI = MIN(IA,JJA)
               IA3A = INPT(MA) + MI
C
C DETERMINE NEW 0TH ORDER BETA, POS/PERM AND MATRIX ELEMENT
C
          CALL RET1DET(IBCON2,IACON2,NB,IEL2,JJ,0,KKJ,ISWAP2)
          IPER2 = (-1)**ISWAP2
          IPERT = IPER*IPER2
          IPB2 = POSDET(NACT,NB,IACON2,IFA)
          ITP0 = ICAT + ISPB(IPB2)
          COEFF = CI(ITP0)*IPERT
C
C LOOP OVER BETA VALENCE
C
          DO 2960 IV=1,NVAL
             IS4 = IOB(IV)
             IP2 = IMUL(IS4,IS3)
             IF (IP1.NE.IP2) GOTO 2960
             TMP4(IV) = E0B0 + EFCK(IV)
C
C MATRIX ELEMENT
C
         IAV = INPT(IA) + IV
         IA2V = INPT(IA2) + IV
         INT1 = INPT(IA3A2) + IAV
         MA = MAX(IA3A,IA2V)
         MI = MIN(IA3A,IA2V)
         INT2 = INPT(MA) + MI
         T = (SI2(INT1) - SI2(INT2))*COEFF
         TMP3(IV) = TMP3(IV) + T
C
 2960     CONTINUE
C
C END OF LOOP OVER BETA VALENCE
C
 2952       CONTINUE
            IST = IBCON2(KKJ)+1
            IEN = IBCON2(KKJ+1)-1
            IF (KKJ.EQ.NB) IEN=NACT
 2950    CONTINUE
C
 2940    CONTINUE
C
C END OF 2ND DEXCITATIONS
C
C  NOW FOR 2ND EXCITATION: ALPHA ACT (IA2) -> ACT (JJA)
C  TOTAL = ( IA(B),IA2(A) -> IV(B),JJA(A) )
C
      DO 2970 IEL2=1,NA
         IA2 = IACON1(IEL2)+NVAL
         IS2 = IOB(IA2)
         IP1 = IMUL(IS1,IS2)
C
         IST = 1
         IEN = IACON1(1)-1
         DO 2980 KKJ=1,NA+1
            DO 2982 JJ=IST,IEN
               JJA = JJ + NVAL
               IS3 = IOB(JJA)
               IPT = IMUL(IP1,IS3)
               IF (IPT.NE.ISYL) GOTO 2982
C
          MA = MAX(IA2,JJA)
          MI = MIN(IA2,JJA)
          IA3A2 = INPT(MA) + MI
C
C DETERMINE NEW 0TH ORDER ALPHA, POS/PERM AND MATRIX ELEMENT
C
          CALL RET1DET(IACON1,IACON2,NA,IEL2,JJ,0,KKJ,ISWAP2)
          IPER2 = (-1)**ISWAP2
          IPERT = IPER*IPER2
          IPA2 = POSDET(NACT,NA,IACON2,IFA)
          ITP0 = ISPA(IPA2) + ICAB
          COEFF = CI(ITP0)*IPERT
C
C LOOP OVER BETA VALENCE
C
          DO 2990 IV=1,NVAL
             IS4 = IOB(IV)
             IP2 = IMUL(IS4,IS3)
             IF (IP1.NE.IP2) GOTO 2990
             TMP4(IV) = E0B0 + EFCK(IV)
C
C MATRIX ELEMENT
C
         IAV = INPT(IA) + IV
         MA = MAX(IA3A2,IAV)
         MI = MIN(IA3A2,IAV)
         INT = INPT(MA) + MI
         T = SI2(INT)*COEFF
         TMP3(IV) = TMP3(IV) + T
C
 2990     CONTINUE
C
C END OF LOOP OVER BETA VALENCE
C
 2982       CONTINUE
            IST = IACON1(KKJ)+1
            IEN = IACON1(KKJ+1)-1
            IF (KKJ.EQ.NA) IEN=NACT
 2980    CONTINUE
C
 2970 CONTINUE
C
C END OF 2ND EXCITATION: ALPHA ACT (IA2) -> ACT (JJA)
C
 2930 CONTINUE
C
C END OF SINGLE DEXCITES IA -> IV
C
         EINT = 0.0D+00
         DO II=1,NVAL
            EINT = EINT + (TMP3(II)*TMP3(II))/TMP4(II)
            TMP3(II) = 0.0D+00
            TMP4(II) = 1.0D+00
         ENDDO
C
         EVA = EVA + 2.0D+00*EINT
C
         CALL ADVANC(IBCON1,NB+1,NACT)
 2900 CONTINUE
 2901 CONTINUE
C
C END OF LOOP OVER 1 UP BETAS
C
C -------------------------------------------
C END OF RELOOP OVER 1ST ORDER BETA VAL -> ACTIVE
C -------------------------------------------
C
C --------------------------------------------
C 1ST ORDER BETA ACT -> EXTERNAL (IA(?) -> IE)
C --------------------------------------------
C
C LOOP OVER DOWN 1 BETAS FIRST
C
            DO II=1,NB-1
               IBCON1(II) = II
            ENDDO
            DO 2230 IJB=1,ND1B
              ISYB1 = ISYV
              E0B0 = E0AD
              DO II=1,NB-1
                 ISYB1 = IMUL(ISYB1,IOB(IBCON1(II)+NVAL))
                 E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
              ENDDO
              ISYL = IMUL(ISYB1,ITAS)
C
C SINGLE DEXCITATIONS, BETA IE -> IA (?)
C
              IST = 1
              IEN = IBCON1(1)-1
              IF (NB.EQ.1) IEN=NACT
              DO 2240 KKJ=1,NB
              DO 2242 JJ=IST,IEN
                 JJE = JJ + NVAL
                 IS2 = IOB(JJE)
                 IF (IS2.NE.ISYL) GOTO 2242
C
C DETERMINE 0TH ORDER BETA STRING, POSITION/PERM AND MATRIX ELEMENT
C
          CALL STR0AE(IBCON1,IBCON2,NB,KKJ,JJ,IPER)
          IPB0 = POSDET(NACT,NB,IBCON2,IFA)
          ITP0 = ICAT + ISPB(IPB0)
          COEFF = CI(ITP0)*IPER
C
C LOOP OVER EXTERNAL ORBS
C
         DO 2215 IE=1,NEXT
            JE = IE + M1
            IS1 = IOB(JE)
            IF (IS1.NE.IS2) GOTO 2215
            TMP4(IE) = E0B0 - EFCK(JE)
C
          CALL ME0AE1B(JJE,IE,IBCON1,NB,IACON1,NA,NVAL,NACT,NEXT,
     *    INPT,SI1,SVOOO,M2,T)
C
          TMP3(IE) = TMP3(IE) + COEFF*T
C
 2215    CONTINUE
C
 2242         CONTINUE
              IST = IBCON1(KKJ)+1
              IEN = IBCON1(KKJ+1)-1
              IF (KKJ.EQ.NB-1) IEN=NACT
 2240         CONTINUE
C
C NOW FOR DOUBLE DEXCITATIONS
C DOUBLE DEXCITATIONS MUST !!!!! INCLUDE THE SINGLES ABOVE !!!!!
C START WITH THIS TYPE FIRST, IE BETA IE -> IA(?)
C
              IST = 1
              IEN = IBCON1(1)-1
              IF (NB.EQ.1) IEN=NACT
              DO 2250 KKJ=1,NB
              DO 2252 JJ=IST,IEN
                 IA = JJ + NVAL
                 IS1 = IOB(IA)
                 CALL STR0AE(IBCON1,IBCON2,NB,KKJ,JJ,IPER)
                 IPB0 = POSDET(NACT,NB,IBCON2,IFA)
                 ICAB = ISPB(IPB0)
C
C 2ND EXCITATION: BETA ACT (IA2.NE.IA) -> ACT (JJA > IA)
C TOTAL = BETA (IE,IA2 -> IA < JJA )
C
                 DO 2255 IEL=1,NB
                    IF (IEL.EQ.KKJ) GOTO 2255
                    IA2 = IBCON2(IEL)+NVAL
                    IS2 = IOB(IA2)
                    IP1 = IMUL(IS1,IS2)
C
C  HAVE ENSURED THAT IA2.NE.IA, NOW TO ENSURE THAT JJA > IA
C
                 IST2=JJ+1
                 IEN2=IEN
                 DO 2258 KKJ2=KKJ+1,NB+1
                 DO 2257 JJ2=IST2,IEN2
                    JJA = JJ2 + NVAL
                    IS3 = IOB(JJA)
                    IPT = IMUL(IP1,IS3)
                    IF (IPT.NE.ISYL) GOTO 2257
C
C  DETERMINE NEW 0TH ORDER BETA, POS/PERM AND MATRIX ELEMENT
C
              CALL RET1DET(IBCON2,IACON2,NB,IEL,JJ2,0,KKJ2,ISWAP2)
              IPER2 = (-1)**ISWAP2
              IPERT = IPER*IPER2
              IPB2 = POSDET(NACT,NB,IACON2,IFA)
              ITP0 = ICAT + ISPB(IPB2)
              COEFF = CI(ITP0)*IPERT
C
              MA = MAX(IA,IA2)
              MI = MIN(IA,IA2)
              IAA2 = INPT(MA) + MI
              MA = MAX(IA2,JJA)
              MI = MIN(IA2,JJA)
              IA2A3 = INPT(MA) + MI
              IAA2A3 = (IA-1)*M2 + IA2A3
              IA3AA2 = (JJA-1)*M2 + IAA2
C
      DO 2217 IE=1,NEXT
         JE = IE + M1
         IS4 = IOB(JE)
         IP2 = IMUL(IS4,IS3)
         IF (IP1.NE.IP2) GOTO 2217
         TMP4(IE) = E0B0 - EFCK(JE)
C
C  ME = [IE,IA | IA2,JJA] - [IE,JJA | IA2,IA]
C
              T = SVOOO(IE,IAA2A3) - SVOOO(IE,IA3AA2)
C
              TMP3(IE) = TMP3(IE) + COEFF*T
C
 2217 CONTINUE
C
 2257            CONTINUE
                 IST2 = IBCON2(KKJ2)+1
                 IEN2 = IBCON2(KKJ2+1)-1
                 IF (KKJ2.EQ.NB) IEN2=NACT
 2258            CONTINUE
C
 2255            CONTINUE
C
C END OF 2ND EXCITATION: BETA ACT (IA2 -> JJA)
C
C 2ND EXCITATION: ALPHA ACT (IA2 -> JJA)
C  TOTAL = ( IE(B),IA2(A) -> IA(B),JJA(A) )
C
                 DO 2260 IEL2=1,NA
                    IA2 = IACON1(IEL2)+NVAL
                    IS2 = IOB(IA2)
                    IP1 = IMUL(IS1,IS2)
C
                 IST2 = 1
                 IEN2 = IACON1(1)-1
                 DO 2268 KKJ2=1,NA+1
                    DO 2267 JJ2=IST2,IEN2
                       JJA = JJ2 + NVAL
                       IS3 = IOB(JJA)
                       IPT = IMUL(IP1,IS3)
                       IF (IPT.NE.ISYL) GOTO 2267
C
C DETERMINE NEW 0TH ORDER ALPHA, POS/PERM AND MATRIX ELEMENT
C
            CALL RET1DET(IACON1,IACON2,NA,IEL2,JJ2,0,KKJ2,ISWAP2)
            IPER2 = (-1)**ISWAP2
            IPERT = IPER*IPER2
            IPA2 = POSDET(NACT,NA,IACON2,IFA)
            ITP0 = ISPA(IPA2) + ICAB
            COEFF = CI(ITP0)*IPERT
C
            MA = MAX(IA2,JJA)
            MI = MIN(IA2,JJA)
            IA2A3 = INPT(MA) + MI
            IAA2A3 = (IA-1)*M2 + IA2A3
C
      DO 2219 IE=1,NEXT
         JE = IE+M1
         IS4 = IOB(JE)
         IP2 = IMUL(IS4,IS3)
         IF (IP1.NE.IP2) GOTO 2219
         TMP4(IE) = E0B0 - EFCK(JE)
C
C ME = [IE,IA | IA2,JJA]
C
            T = SVOOO(IE,IAA2A3)
            TMP3(IE) = TMP3(IE) + COEFF*T
C
 2219 CONTINUE
C
 2267               CONTINUE
                    IST2 = IACON1(KKJ2)+1
                    IEN2 = IACON1(KKJ2+1)-1
                    IF (KKJ2.EQ.NA) IEN2=NACT
 2268            CONTINUE
C
 2260            CONTINUE
C
C END OF 2ND EXCITATION: ALPHA ACT (IA2 -> JJA)
C
 2252         CONTINUE
              IST = IBCON1(KKJ)+1
              IEN = IBCON1(KKJ+1)-1
              IF (KKJ.EQ.NB-1) IEN=NACT
 2250         CONTINUE
C
C END OF 1ST EXCITATION BETA IE -> IA(?)
C
         EINT = 0.0D+00
         DO II=1,NEXT
            EINT = EINT + (TMP3(II)*TMP3(II))/TMP4(II)
            TMP3(II) = 0.0D+00
            TMP4(II) = 1.0D+00
         ENDDO
C
         EAE = EAE + 2.0D+00*EINT
C
              CALL ADVANC(IBCON1,NB-1,NACT)
 2230      CONTINUE
C
C -----------------------------------------
C  END OF 1ST ORDER BETA ACT -> EXTERNAL
C -----------------------------------------
C
           IF (NVAL.EQ.0) GOTO 2101
C
C ----------------------------------------------------
C RELOOP LOOP OVER 2ND ORDER BETAS, IV1,IV2 -> IA1,IA2
C ----------------------------------------------------
C
C LOOP OVER 2 UP BETAS
C
      DO II=1,NB+2
         IBCON1(II) = II
      ENDDO
      DO 2100 IJB=1,N2B
         ISYB = ISYV
         E0B0 = E0AD
         DO II=1,NB+2
            ISYB = IMUL(ISYB,IOB(IBCON1(II)+NVAL))
            E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
         ENDDO
         ISYL = IMUL(ISYB,ITAS)
C
C LOOP OVER DEXCITATIONS FROM BETA ACTIVE IA1 < IA2
C
         DO 2110 IEL1=1,NB+2
            IA1 = IBCON1(IEL1)+NVAL
            IS1 = IOB(IA1)
            IA1T = INPT(IA1)
C
         DO 2120 IEL2=IEL1+1,NB+2
            IA2 = IBCON1(IEL2)+NVAL
            IS2 = IOB(IA2)
            IP1 = IMUL(IS1,IS2)
            IF (IP1.NE.ISYL) GOTO 2120
            IA2T = INPT(IA2)
C
      CALL STR0VVAA(IBCON1,IBCON2,NB+2,IEL1,IEL2,NVAL,
     *     NVAL,NVAL,IPER)
      IPB0 = POSDET(NACT,NB,IBCON2,IFA)
      ITP0 = ICAT + ISPB(IPB0)
      COEFF = CI(ITP0)*IPER
C
C LOOP OVER BETA VALENCE IV1 < IV2
C
         ICOUNT = 0
         DO 2130 IV1=1,NVAL
            IS3 = IOB(IV1)
            E0B0V = E0B0 + EFCK(IV1)
            IA1V1 = IA1T + IV1
            IA2V1 = IA2T + IV1
            IA2V1T = INPT(IA2V1)
C
         DO 2140 IV2=1,IV1-1
            ICOUNT = ICOUNT + 1
            IS4 = IOB(IV2)
            IP2 = IMUL(IS4,IS3)
            IF (IP1.NE.IP2) GOTO 2140
            TMP4(ICOUNT) = E0B0V + EFCK(IV2)
C
C MATRIX ELEMENT
C
            IA1V2 = IA1T + IV2
            IA2V2 = IA2T + IV2
            INT1 = INPT(IA2V2) + IA1V1
            INT2 = IA2V1T + IA1V2
            T = (SI2(INT1) - SI2(INT2))*COEFF
            TMP3(ICOUNT) = TMP3(ICOUNT) + T
C
 2140    CONTINUE
 2130    CONTINUE
C
C END OF LOOP OVER BETA VALENCE IV1 < IV2
C
 2120    CONTINUE
 2110    CONTINUE
C
C END OF DOUBLE BETA DEXCITATIONS FROM ACTIVE IA1 < IA2
C
         EINT = 0.0D+00
         DO II=1,ICOUNT
            EINT = EINT + (TMP3(II)*TMP3(II))/TMP4(II)
            TMP3(II) = 0.0D+00
            TMP4(II) = 1.0D+00
         ENDDO
C
         EVVAA = EVVAA + 2.0D+00*EINT
         ICOUNT = 0
C
         CALL ADVANC(IBCON1,NB+2,NACT)
 2100 CONTINUE
C
C END OF LOOP OVER 2 UP BETAS
C
C ----------------------------------------------------
C END RELOOP LOOP OVER 2ND ORDER BETAS, IV1,IV2 -> IA1,IA2
C ----------------------------------------------------
C
C ----------------------------------------------------
C RELOOP OVER 2ND ORDER BETAS, IV1,IV2 -> IA2,IE
C ----------------------------------------------------
C THESE INCLUDE ALSO IV1(A)<IV2(B) -> IA2(B),IE(A)
C                    IV1(A)=IV2(B) -> IA2(B),IE(A)
C                    IV1(A)>IV2(B) -> IA2(B),IE(A)
C ***
C
C LOOP OVER 1 UP BETAS
C
         DO II=1,NB+1
            IBCON1(II) = II
         ENDDO
         DO 2810 IJB=1,N1B
            ISYB=ISYV
            E0B0 = E0AD
            DO II=1,NB+1
               E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
               ISYB = IMUL(ISYB,IOB(IBCON1(II)+NVAL))
            ENDDO
            ISYL = IMUL(ITAS,ISYB)
C
C DOUBLE EXCITATIONS MUST INCLUDE ALPHA IE -> IV SPECIFIED ABOVE
C SECOND EXCITATION BETA (IA2 -> IV2)
C TOTAL = ( IE(A),IA2(B) -> IV(A),IV2(B) )
C
            DO 2820 IEL=1,NB+1
               IA2 = IBCON1(IEL)+NVAL
               IS1 = IOB(IA2)
               IF (IS1.NE.ISYL) GOTO 2820
C
C DETERMINE NEW 0TH ORDER BETA, POS/PERM
C
        CALL STR0VA(IBCON1,IBCON2,NB+1,IEL,NVAL,NVAL,IPER)
        IPB0 = POSDET(NACT,NB,IBCON2,IFA)
        ITP0 = ICAT + ISPB(IPB0)
        COEFF = CI(ITP0)*IPER
C
C LOOP OVER BETA VALENCE
C
        ICOUNT = 0
        DO 2830 IV1=1,NVAL
           IS2 = IOB(IV1)
           IP1 = IMUL(IS1,IS2)
           E0BV = E0B0 + EFCK(IV1)
           IA2V1 = INPT(IA2) + IV1
C
C LOOP OVER ALPHA VALENCE AND EXTERNAL
C
        DO 2840 IV2=1,IV1-1
           IS3 = IOB(IV2)
           IPT = IMUL(IS3,IP1)
           E0BVV = E0BV + EFCK(IV2)
           IA2V2 = INPT(IA2) + IV2
           IV2A2V1 = (IV2-1)*M2 + IA2V1
           IV1A2V2 = (IV1-1)*M2 + IA2V2
C
        DO 2850 IE=1,NEXT
           JE = IE + M1
           IF (IOB(JE).NE.IPT) GOTO 2850
           ICOUNT = ICOUNT + 1
           TMP4(ICOUNT) = E0BVV - EFCK(JE)
C
       T1 = SVOOO(IE,IV2A2V1)*COEFF
       T2 = SVOOO(IE,IV1A2V2)*COEFF
       TMP3(ICOUNT) = TMP3(ICOUNT) + T1
       TMP1(ICOUNT) = TMP1(ICOUNT) + T2
       TMP2(ICOUNT) = TMP2(ICOUNT) + (T1-T2)
C
 2850   CONTINUE
 2840   CONTINUE
C
C FOR IV2.EQ.IV1
C
           IS3 = IOB(IV1)
           IPT = IMUL(IS3,IP1)
           E0BVV = E0BV + EFCK(IV1)
           IV2A2V1 = (IV1-1)*M2 + IA2V1
           DO 2870 IE=1,NEXT
              JE = IE + M1
              IF (IOB(JE).NE.IPT) GOTO 2870
              ICOUNT = ICOUNT + 1
              TMP4(ICOUNT) = E0BVV - EFCK(JE)
C
       T1 = SVOOO(IE,IV2A2V1)*COEFF
       TMP3(ICOUNT) = TMP3(ICOUNT) + T1
C
 2870 CONTINUE
C
C END OF IV2.GE.IV1
C
 2830   CONTINUE
C
 2820       CONTINUE
C
C END OF DOUBLE DEXCITATIONS
C
         EINT = 0.0D+00
         DO II=1,ICOUNT
            EINT = EINT + (TMP3(II)*TMP3(II)+
     *  TMP1(II)*TMP1(II)+
     *  TMP2(II)*TMP2(II))/TMP4(II)
            TMP1(II) = 0.0D+00
            TMP2(II) = 0.0D+00
            TMP3(II) = 0.0D+00
            TMP4(II) = 1.0D+00
         ENDDO
C
         EVVAE = EVVAE + 2.0D+00*EINT
         ICOUNT = 0
C
            CALL ADVANC(IBCON1,NB+1,NACT)
 2810    CONTINUE
C
C ----------------------------------------------------
C END RELOOP OVER 2ND ORDER BETAS, IV1,IV2 -> IA1,IE
C ----------------------------------------------------
C
C ----------------------------------------------------
C LOOP OVER 2ND ORDER BETAS ( IV,IA -> IE1<IE2 )
C ----------------------------------------------------
C THESE EXCITATIONS ALSO INCLUDE IV(A),IA(B) -> IE1(A)<IE2(B)
C AND                            IV(A),IA(B) -> IE1(B)<IE2(A)
C AND                            IV(A),IA(B) -> IE1(A),IE1(B)
C
C LOOP OVER 1 DOWN BETAS
C
         DO II=1,NB-1
            IBCON1(II) = II
         ENDDO
         DO 2530 IJB=1,ND1B
            ISYB0 = ISYV
            E0B0 = E0V
            DO II=1,NB-1
               E0B0 = E0B0 + EFCK(IBCON1(II)+NVAL)
               ISYB0 = IMUL(ISYB0,IOB(IBCON1(II)+NVAL))
            ENDDO
            IMS = IMUL(ISYB0,ITAS)
            E0B1 = EPT0-E0B0-E0A0
C
C LOOP OVER DEXCITATIONS INTO ACTIVE (IE2 -> IA)
C
            IST = 1
            IEN = IBCON1(1)-1
            IF (NB.EQ.1) IEN=NACT
            DO 2540 KKJ=1,NB
               DO 2542 JJ=IST,IEN
                  IA = JJ + NVAL
                  IS3 = IOB(IA)
                  IF (IS3.NE.IMS) GOTO 2542
C
C DETERMINE 0TH ORDER BETA STRING, POS/PERM
C
       CALL STR0AE(IBCON1,IBCON2,NB,KKJ,JJ,IPER2)
       IPB0 = POSDET(NACT,NB,IBCON2,IFA)
       ITP0 = ICAT + ISPB(IPB0)
       COEFF = CI(ITP0)*IPER2
C
C LOOP OVER DOUBLE BETA DEXCITATIONS ( IE1<IE2 -> IV,IA )
C
         ICOUNT = 0
         JDV = 0
         JDA = -M1 + IA
         DO 2500 JE1=NQS,NQQ
            IS1 = IOB(JE1)
            IP2 = IMUL(IS3,IS1)
            E0BE = E0B1 - EFCK(JE1)
            JDA = JDA + M1
            JDAV = (JDA*(JDA-1))/2
            JDAT = JDAV
            JDVT = (JDV*(JDV-1))/2 + IA
C
         DO 2510 IV=1,NVAL
            IS2 = IOB(IV)
            IPT = IMUL(IS2,IP2)
            E0BEV = E0BE + EFCK(IV)
            JDAT = JDAT + 1
            JDV = JDV + 1
            JDVT = JDVT + JDV - 1
C
         INT1 = -M1 + JDVT
         INT2 = -M1 + JDAT
         DO 2520 JE2=NQS,JE1-1
            INT1 = INT1 + M1
            INT2 = INT2 + M1
            IF (IOB(JE2).NE.IPT) GOTO 2520
C
            ICOUNT = ICOUNT + 1
            TMP4(ICOUNT) = E0BEV-EFCK(JE2)
C
C DETERMINE MATRIX ELEMENT
C
C ME = [IE1,IV | IE2,IA] - [IE1,IA | IE2,IV]
C
       T1 = SVOVO(INT1)*COEFF
       T2 = SVOVO(INT2)*COEFF
       TT = T1 - T2
C
       TMP1(ICOUNT) = TMP1(ICOUNT) + T1
       TMP2(ICOUNT) = TMP2(ICOUNT) + T2
       TMP3(ICOUNT) = TMP3(ICOUNT) + TT
C
 2520    CONTINUE
C
C IE1 = IE2
C
         IF (IS3.NE.IS2) GOTO 2510
         ICOUNT = ICOUNT + 1
         TMP4(ICOUNT) = E0BEV-EFCK(JE1)
         INT2 = INT2 + M1
         T1 = SVOVO(INT2)*COEFF
         TMP1(ICOUNT) = TMP1(ICOUNT) + T1
C
 2510    CONTINUE
         JDV = JDV + NACT
 2500    CONTINUE
C
C END OF DOUBLE BETA DEXCITATIONS ( IE1<IE2 -> IV,IA )
C
 2542          CONTINUE
               IST = IBCON1(KKJ)+1
               IEN = IBCON1(KKJ+1)-1
               IF (KKJ.EQ.NB-1) IEN=NACT
 2540       CONTINUE
C
C END OF EXCITATION INTO BETA ACTIVE
C
       EINT = 0.0D+00
       DO II=1,ICOUNT
          EINT = EINT +
     *    (TMP1(II)*TMP1(II)+TMP2(II)*TMP2(II)+TMP3(II)*TMP3(II))
     *    /TMP4(II)
          TMP1(II) = 0.0D+00
          TMP2(II) = 0.0D+00
          TMP3(II) = 0.0D+00
          TMP4(II) = 1.0D+00
       ENDDO
C
       EVAEE = EVAEE + 2.0D+00*EINT
       ICOUNT = 0
C
            CALL ADVANC(IBCON1,NB-1,NACT)
 2530    CONTINUE
C
C END OF 1 DOWN BETAS
C
C ------------------------------------------------
C END OF LOOP OVER 2ND ORDER BETAS (IV,IA -> IE1,IE2)
C ------------------------------------------------
C
 2101 CONTINUE
C
C ------------------------------------------------
C LOOP OVER 2ND ORDER BETAS (IA1<IA2 -> IE1<IE2)
C ------------------------------------------------
C
         DO II=1,NB-2
            IBCON1(II) = II
         ENDDO
         DO 2620 IJB=1,ND2B
            E0B0 = EPT0-E0V-E0A0
            ISB0 = ISYV
            DO II=1,NB-2
               E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
               ISB0 = IMUL(ISB0,IOB(IBCON1(II)+NVAL))
            ENDDO
C
C LOOP OVER DOUBLE BETA DEXCITATIONS ( IE1<IE2 -> IA1<IA2 )
C
            IST = 1
            IEN = IBCON1(1)-1
            IF (NB.EQ.2) IEN=NACT
            DO 2630 KKJ=1,NB-1
               DO 2632 JJ=IST,IEN
                  IA1 = JJ + NVAL
                  IS3 = IOB(IA1)
                  ISYBE1 = IMUL(ISB0,IS3)
                  CALL STR0AE(IBCON1,IBCON2,NB-1,KKJ,JJ,IPER)
C
            IST2 = JJ+1
            IEN2 = IEN
            DO 2640 KKJ2=KKJ+1,NB
               DO 2642 JJ2=IST2,IEN2
                  IA2 = JJ2 + NVAL
                  IS4 = IOB(IA2)
                  ISYBE2 = IMUL(ISYBE1,IS4)
                  IF (ISYBE2.NE.ITAS) GOTO 2642
                  IP2 = IMUL(IS4,IS3)
C
C DETERMINE NEW 0TH ORDER BETA, POS/PERM AND MATRIX ELEMENT
C
         CALL STR0AE(IBCON2,IACON2,NB,KKJ2,JJ2,IPER2)
         IPERT = IPER*IPER2
         IPB0 = POSDET(NACT,NB,IACON2,IFA)
         ITP0 = ICAT + ISPB(IPB0)
         COEFF = CI(ITP0)*IPERT
C
C LOOP OVER EXTERNAL ORBITALS
C
         ICOUNT = 0
         DO 2600 JE1=NQS,NQQ
            IS1 = IOB(JE1)
            IPT = IMUL(IS1,IP2)
            E0BE1 = E0B0 - EFCK(JE1)
            IE1A1 = (JE1-M1-1)*M1 + IA1
            IE1A2 = IE1A1 - IA1 + IA2
            IE1A1T = INPT(IE1A1)
            IE1A2T = INPT(IE1A2)
C
         INT1 = IE1A1T + IA2 - M1
         INT2 = IE1A2T + IA1 - M1
         DO 2610 JE2=NQS,JE1-1
            INT1 = INT1 + M1
            INT2 = INT2 + M1
            ICOUNT = ICOUNT + 1
            IF (IOB(JE2).NE.IPT) GOTO 2610
            TMP4(ICOUNT) = E0BE1 - EFCK(JE2)
C
C ME = [IE2,IA2 | IE1,IA1] - [IE2,IA1 | IE1,IA2]
C
         T = SVOVO(INT1) - SVOVO(INT2)
         TMP3(ICOUNT) = TMP3(ICOUNT) + COEFF*T
C
 2610    CONTINUE
 2600    CONTINUE
C
 2642          CONTINUE
               IST2 = IBCON2(KKJ2)+1
               IEN2 = IBCON2(KKJ2+1)-1
               IF (KKJ2.EQ.NB-1) IEN2=NACT
 2640       CONTINUE
C
 2632          CONTINUE
               IST = IBCON1(KKJ)+1
               IEN = IBCON1(KKJ+1)-1
               IF (KKJ.EQ.NB-2) IEN=NACT
 2630       CONTINUE
C
CFORNOW
         EINT = 0.0D+00
         DO II=1,ICOUNT
            EINT = EINT + (TMP3(II)*TMP3(II))/TMP4(II)
            TMP3(II) = 0.0D+00
            TMP4(II) = 1.0D+00
         ENDDO
C
         EAAEE = EAAEE + 2.0D+00*EINT
         ICOUNT = 0
C
C END OF DOUBLE BETA DEXCITATIONS ( IE1<IE2 -> IA1<IA2 )
C
            CALL ADVANC(IBCON1,NB-2,NACT)
 2620    CONTINUE
C
C ******
C END OF LOOP OVER 2ND ORDER BETAS (IA1<IA2 -> IE1<IE2)
C ******
C
         IF (NVAL.EQ.0) GOTO 2701
C ---------------------------------------------------------
C LOOP OVER 1ST ORDER ALPHAS, VAL(IV1) -> EXT(IE1)
C THIS LOOP INCLUDES A LOOP OVER 0TH ORDER ALPHAS, SO WE'LL
C TRY TO PUT IT IN THE MAIN 0TH ORDER ALPHA LOOP, IE, HERE
C ---------------------------------------------------------
C
C I BELIEVE THE BELOW INCLUDES VAL(B) -> EXT(B) ALSO....
C
C *****
C LOOP OVER 0TH ORDER BETA STRINGS
C *****
C
        DO II=1,NB
           IBCON1(II) = II
        ENDDO
        DO 2700 IJB=1,NBLP
           ICAB = ISPB(IJB)
           ISYB = IMUL(ISYV,ISYMB(IJB))
           E0B0 = E0AD
           DO II=1,NB
              E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
           ENDDO
           IF (ISYB.NE.ITAS) GOTO 2698
C
           ITP0 = ICAT + ICAB
           COEFF = CI(ITP0)
C
C SINGLE DEXCITATIONS, ALPHA IE -> IV
C
           ICOUNT = 0
           DO 2710 IV=1,NVAL
              IS1 = IOB(IV)
              E0B0V = E0B0 + EFCK(IV)
C
           DO 2720 IE=1,NEXT
              ICOUNT = ICOUNT + 1
              JE = IE + M1
              IS2 = IOB(JE)
              IF (IS1.NE.IS2) GOTO 2720
              TMP4(ICOUNT) = E0B0V - EFCK(JE)
C
C MATRIX ELEMENT
C
          CALL ME0VE1B(IV,IE,IACON1,NA,IBCON1,NB,NVAL,
     *    NACT,NEXT,INPT,SI1,SVOOO,M2,T)
          TMP3(ICOUNT) = TMP3(ICOUNT) + T*COEFF
C
 2720      CONTINUE
C
 2710      CONTINUE
C
C END OF SINGLE DEXCITATIONS
C
 2698 CONTINUE
C
C NOW FOR DOUBLE DEXCITATIONS
C DOUBLES MUST INCLUDE THE SINGLE ABOVE
C
C 2ND EXCITATION: ALPHA ACT(IA2 -> JJA)
C TOTAL = ALPHA (IE,IA2 -> IV,JJA)
C
           ISYT = ITAB(ISYB)
           ISYL = IMUL(ISYT,ISA1)
C
           DO 2730 IEL2=1,NA
              IA2 = IACON1(IEL2) + NVAL
              IS1 = IOB(IA2)
C
       IST = 1
       IEN = IACON1(1)-1
       DO 2740 KKJ=1,NA+1
          DO 2742 JJ=IST,IEN
             JJA = JJ + NVAL
             IS2 = IOB(JJA)
             IP1 = IMUL(IS1,IS2)
             IF (IP1.NE.ISYL) GOTO 2742
             MA = MAX(IA2,JJA)
             MI = MIN(IA2,JJA)
             IA2A3 = INPT(MA) + MI
C
           CALL RET1DET(IACON1,IACON2,NA,IEL2,JJ,0,KKJ,ISWAP2)
           IPER2 = (-1)**ISWAP2
           IPA2 = POSDET(NACT,NA,IACON2,IFA)
           ITP0 = ISPA(IPA2) + ICAB
           COEFF = CI(ITP0)*IPER2
C
           ICOUNT = 0
           DO 2750 IV=1,NVAL
              IS3 = IOB(IV)
              E0B0V = E0B0 + EFCK(IV)
              IA2V = INPT(IA2) + IV
              IVA2A3 = (IV-1)*M2 + IA2A3
              IA3A2V = (JJA-1)*M2 + IA2V
C
           DO 2760 IE=1,NEXT
              ICOUNT = ICOUNT + 1
              JE = IE + M1
              IS4 = IOB(JE)
              IP2 = IMUL(IS4,IS3)
              IF (IP1.NE.IP2) GOTO 2760
              TMP4(ICOUNT) = E0B0V - EFCK(JE)
C
C MATRIX ELEMENT
C
         T1 = SVOOO(IE,IVA2A3)*COEFF
         T2 = SVOOO(IE,IA3A2V)*COEFF
         TMP3(ICOUNT) = TMP3(ICOUNT) + (T1-T2)
C
 2760      CONTINUE
 2750      CONTINUE
C
 2742     CONTINUE
          IST = IACON1(KKJ)+1
          IEN = IACON1(KKJ+1)-1
          IF (KKJ.EQ.NA) IEN=NACT
 2740  CONTINUE
C
 2730      CONTINUE
C
C END OF ALPHA ACT (IA2 -> JJA) DEXCITE
C
C 2ND EXCITATION: BETA ACT (IA2 -> JJA)
C TOTAL = ( IE(A),IA2(B) -> IV(A),JJA(B) )
C
           ISYL = IMUL(ITAS,ISYB)
           DO 2770 IEL2=1,NB
              IA2 = IBCON1(IEL2)+NVAL
              IS1 = IOB(IA2)
C
           IST = 1
           IEN = IBCON1(1)-1
           DO 2780 KKJ=1,NB+1
              DO 2782 JJ=IST,IEN
                 JJA = JJ + NVAL
                 IS2 = IOB(JJA)
                 IP1 = IMUL(IS1,IS2)
                 IF (IP1.NE.ISYL) GOTO 2782
C
                 MA = MAX(IA2,JJA)
                 MI = MIN(IA2,JJA)
                 IA2A3 = INPT(MA) + MI
C
          CALL RET1DET(IBCON1,IBCON2,NB,IEL2,JJ,0,KKJ,ISWAP2)
          IPER2 = (-1)**ISWAP2
          IPB2 = POSDET(NACT,NB,IBCON2,IFA)
          ITP0 = ICAT + ISPB(IPB2)
          COEFF = CI(ITP0)*IPER2
C
          ICOUNT = 0
          DO 2785 IV=1,NVAL
             IS3 = IOB(IV)
             IPT = IMUL(IS3,IP1)
             E0B0V = E0B0 + EFCK(IV)
             IA2V = INPT(IA2) + IV
             IVA2A3 = (IV-1)*M2 + IA2A3
C
          DO 2790 IE=1,NEXT
             ICOUNT = ICOUNT + 1
             JE = IE + M1
             IF (IOB(JE).NE.IPT) GOTO 2790
             TMP4(ICOUNT) = E0B0V - EFCK(JE)
C
C  MATRIX ELEMENT
C
         T1 = SVOOO(IE,IVA2A3)*COEFF
         TMP3(ICOUNT) = TMP3(ICOUNT) + T1
C
 2790     CONTINUE
 2785     CONTINUE
C
 2782         CONTINUE
              IST = IBCON1(KKJ)+1
              IEN = IBCON1(KKJ+1)-1
              IF (KKJ.EQ.NB) IEN=NACT
 2780      CONTINUE
C
 2770      CONTINUE
C
C END OF 2ND EXCITATION BETA (IA2 -> JJ)
C
         EINT = 0.0D+00
         DO II=1,ICOUNT
            EINT = EINT + (TMP3(II)*TMP3(II))/TMP4(II)
            TMP3(II) = 0.0D+00
            TMP4(II) = 1.0D+00
         ENDDO
C
         EVE = EVE + 2.0D+00*EINT
         ICOUNT = 0
C
           CALL ADVANC(IBCON1,NB,NACT)
 2700   CONTINUE
 2701 CONTINUE
C
C *****
C END OF LOOP OVER 0TH ORDER BETA STRINGS
C *****
C
        CALL DDI_DLBNEXT(MY_TASK)
      END IF     ! MY TASK
C
         CALL ADVANC(IACON1,NA,NACT)
 2000 CONTINUE
C
C END LOOP OVER ZEROTH ORDER ALPHAS
C
C -------------------------------------------
C *******************************************
C -------------------------------------------
C
C LOOP OVER 1ST ORDER ALPHAS, ORBITALS NUMBERED AS ACTIVE, 1,2,etc
C
C --------------------------------------------------
C **************************************************
C --------------------------------------------------
C
      NBUFF=N1A
      IF (NVAL.EQ.0) THEN
         NBUFF=0
         GOTO 3401
      ENDIF
C
C LOOP OVER 1ST ORDER ALPHAS (IV -> IA)
C
C OUTER LOOP OVER 1 UP ALPHAS
C
      DO II=1,NA+1
         IACON1(II) = II
      ENDDO
      E0A0 = EPT0 - 2*E0V
      ISA0 = ISYV
C
      DO 3400 IJK2=1,N1A
C
        IF (IJK2+NALP-1.EQ.MY_TASK) THEN
C
         ISA1 = ISA0
         E0AD1 = E0A0
         DO II=1,NA+1
            E0AD1 = E0AD1 - EFCK(IACON1(II)+NVAL)
            ISA1 = IMUL(ISA1,IOB(IACON1(II)+NVAL))
         ENDDO
C
C ----------------------------------------------
C NOW TO LOOP OVER 1ST ORDER BETAS IV2 -> IA2
C ----------------------------------------------
C
C LOOP OVER 1 UP BETAS
C
         DO II=1,NB+1
            IBCON1(II) = II
         ENDDO
         DO 3500 IJB=1,N1B
            ISYB = ISYV
            E0B0 = E0AD1
            DO II=1,NB+1
               E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
               ISYB = IMUL(ISYB,IOB(IBCON1(II)+NVAL))
            ENDDO
            ISYT = IMUL(ISYB,ISA1)
            ITAL = ITAB(ISYT)
C
C LOOP OVER ALPHA EXCITE (IA1 -> IV)
C
            DO 3510 IEL1=1,NA+1
               IA1 = IACON1(IEL1) + NVAL
               IS1 = IOB(IA1)
            CALL STR0VA(IACON1,IACON2,NA+1,IEL1,NVAL,NVAL,IPER)
            IPA0 = POSDET(NACT,NA,IACON2,IFA)
            ICAT = ISPA(IPA0)
C
C LOOP OVER BETA EXCITE (IA2 -> IV2)
C
            DO 3520 IEL2=1,NB+1
               IA2 = IBCON1(IEL2) + NVAL
               IS2 = IOB(IA2)
               IP1 = IMUL(IS1,IS2)
               IF (IP1.NE.ITAL) GOTO 3520
            CALL STR0VA(IBCON1,IBCON2,NB+1,IEL2,NVAL,NVAL,IPER2)
            IPERT = IPER*IPER2
            IPB0 = POSDET(NACT,NB,IBCON2,IFA)
            ITP0 = ICAT + ISPB(IPB0)
            COEFF = CI(ITP0)*IPERT
C
C NOW TO LOOP OVER VALENCE ORBITALS
C
            IA1V1 = INPT(IA1)
            IA2VT = INPT(IA2)
            ICOUNT = 0
            DO 3530 IV1=1,NVAL
               IS3 = IOB(IV1)
               IPT = IMUL(IS3,IP1)
               E0BV1 = E0B0 + EFCK(IV1)
               IA1V1 = IA1V1 + 1
               IA2V2 = IA2VT
C
            DO 3540 IV2=1,NVAL
               ICOUNT = ICOUNT + 1
               IA2V2 = IA2V2 + 1
               IF (IOB(IV2).NE.IPT) GOTO 3540
               TMP4(ICOUNT) = E0BV1 + EFCK(IV2)
C
           MA = MAX(IA1V1,IA2V2)
           MI = MIN(IA1V1,IA2V2)
           INT1 = (MA*(MA-1))/2 + MI
           T1 = SI2(INT1)*COEFF
           TMP3(ICOUNT) = TMP3(ICOUNT) + T1
C
 3540       CONTINUE
C
 3530       CONTINUE
C
CEND OF LOOP OVER VALENCE ORBITALS
C
 3520       CONTINUE
C
C END OF BETA EXCITE (IA2 -> IV2)
C
 3510       CONTINUE
C
C END OF ALPHA EXCITE (IA1 -> IV)
C
         DO II=1,ICOUNT
            EVVAA = EVVAA + (TMP3(II)*TMP3(II))/TMP4(II)
            TMP3(II) = 0.0D+00
            TMP4(II) = 1.0D+00
         ENDDO
         ICOUNT = 0
C
            CALL ADVANC(IBCON1,NB+1,NACT)
 3500    CONTINUE
C
C -----------------------------------
C END OF LOOP OVER 1 UP BETAS
C END LOOP OVER 1ST ORDER BETAS IV2 -> IA2
C -----------------------------------
C
C ------------------------------------------
C NOW TO LOOP OVER 1ST ORDER BETAS IA2 -> IE
C ------------------------------------------
C
C LOOP OVER 1 DOWN BETAS
C
         DO II=1,NB-1
            IBCON1(II) = II
         ENDDO
         DO 3700 IJB=1,ND1B
            ISYB = ISYV
            E0BD1 = E0AD1
            DO II=1,NB-1
               E0BD1 = E0BD1 - EFCK(IBCON1(II)+NVAL)
               ISYB = IMUL(ISYB,IOB(IBCON1(II)+NVAL))
            ENDDO
            ISYT = IMUL(ISYB,ISA1)
            ITAL = ITAB(ISYT)
C
C LOOP OVER DEXCITATIONS FROM IA1(A)
C
         DO 3710 IEL=1,NA+1
            IA1 = IACON1(IEL) + NVAL
            IS1 = IOB(IA1)
            CALL STR0VA(IACON1,IACON2,NA+1,IEL,NVAL,NVAL,IPER)
            IPA0 = POSDET(NACT,NA,IACON2,IFA)
            ICAT = ISPA(IPA0)
C
C LOOP OVER EXCITATIONS INTO IA2(B)
C
         IST = 1
         IEN = IBCON1(1)-1
         IF (NB.EQ.1) IEN=NACT
         DO 3720 KKJ=1,NB
            DO 3722 JJ=IST,IEN
               IA2 = JJ + NVAL
               IS2 = IOB(IA2)
               IP1 = IMUL(IS1,IS2)
               IF (IP1.NE.ITAL) GOTO 3722
C
C 0TH ORDER BETA POS/PERM
C
         CALL STR0AE(IBCON1,IBCON2,NB,KKJ,JJ,IPER2)
         IPERT = IPER*IPER2
         IPB0 = POSDET(NACT,NB,IBCON2,IFA)
         ITP0 = ICAT + ISPB(IPB0)
         COEFF = CI(ITP0)*IPERT
C
C LOOP OVER ALPHA VALENCE
C
         ICOUNT = 0
         DO 3730 IV=1,NVAL
            IS3 = IOB(IV)
            IPT = IMUL(IS3,IP1)
            E0BD1V = E0BD1 + EFCK(IV)
            IA1V = INPT(IA1) + IV
            IA2A1V = (IA2-1)*M2 + IA1V
C
C LOOP OVER BETA EXTERNAL
C
         DO 3740 IE=1,NEXT
            ICOUNT = ICOUNT + 1
            JE = IE + M1
            IF (IOB(JE).NE.IPT) GOTO 3740
            TMP4(ICOUNT) = E0BD1V - EFCK(JE)
C
            T1 = SVOOO(IE,IA2A1V)*COEFF
            TMP3(ICOUNT) = TMP3(ICOUNT) + T1
C
 3740    CONTINUE
C
 3730    CONTINUE
C
C END OF ALPHA VALENCE
C
 3722       CONTINUE
            IST = IBCON1(KKJ)+1
            IEN = IBCON1(KKJ+1)-1
            IF (KKJ.EQ.NB-1) IEN=NACT
 3720    CONTINUE
C
C END OF EXCITATIONS INTO EA2(B)
C
 3710    CONTINUE
C
C END OF DEXCITATIONS OUT OF IA1(A), IA2(B)
C
         EINT = 0.0D+00
         DO II=1,ICOUNT
            EINT = EINT +(TMP3(II)*TMP3(II))/TMP4(II)
            TMP3(II) = 0.0D+00
            TMP4(II) = 1.0D+00
         ENDDO
C
         EVAAE = EVAAE + 2.0D+00*EINT
         ICOUNT = 0
C
            CALL ADVANC(IBCON1,NB-1,NACT)
 3700    CONTINUE
C
C END OF LOOP OVER 1 DOWN BETAS
C
C ------------------------------------------
C END OF LOOP OVER 1ST ORDER BETAS IA2 -> IE
C ------------------------------------------
C
C
        CALL DDI_DLBNEXT(MY_TASK)
      END IF     ! MY TASK
C
         CALL ADVANC(IACON1,NA+1,NACT)
 3400 CONTINUE
 3401 CONTINUE
C
C
C END OF RELOOP OVER 1ST ORDER ALPHAS, VAL (IV) -> ACTIVE
C
C --------------------------------------------------
C **************************************************
C --------------------------------------------------
C
C -------------------------------------------
C *******************************************
C -------------------------------------------
C
C EXPERIMENT, RELOOP OVER ALPHA ACT (IA?)  -> EXTERNAL (IE)
C
         DO II=1,NA-1
            IACON1(II) = II
         ENDDO
C
         DO 5805 IJK3=1,ND1A
C
        IF (IJK3+NALP+NBUFF-1.EQ.MY_TASK) THEN
C
C DETERMINE SYMMETRY OF ALPHA STRING
C
            ISA0 = ISYV
            E0A0 = E0V
            DO II=1,NA-1
               E0A0 = E0A0 + EFCK(IACON1(II)+NVAL)
               ISA0 = IMUL(ISA0,IOB(IACON1(II)+NVAL))
            ENDDO
C
C ---------------
C NOW TO LOOP OVER 1ST ORDER OVER BETA (IA2) -> (IE2)
C ---------------
C
          DO II=1,NB-1
             IBCON1(II) = II
          ENDDO
          DO 5810 IJB=1,IJK3
             ISYB0 = ISYV
             E0B0 = EPT0-E0V-E0A0
             DO II=1,NB-1
                E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
                ISYB0 = IMUL(ISYB0,IOB(IBCON1(II)+NVAL))
             ENDDO
C
C NOW TO LOOP OVER ALPHA DEXCITATIONS (IE -> IA)
C
             IST = 1
             IEN = IACON1(1)-1
             IF (NA.EQ.1) IEN=NACT
             DO 5820 KKJ=1,NA
                DO 5822 JJ=IST,IEN
                   IA = JJ + NVAL
                   IS3 = IOB(IA)
                   ISA1 = IMUL(ISA0,IS3)
                   ITAS = ITAB(ISA1)
C
                   CALL STR0AE(IACON1,IACON2,NA,KKJ,JJ,IPER)
                   IPA0 = POSDET(NACT,NA,IACON2,IFA)
                   ICAT = ISPA(IPA0)
C
C NOW TO LOOP OVER BETA DEXCITATIONS (IE2 -> IA2)
C
             IST2 = 1
             IEN2 = IBCON1(1)-1
             IF (NB.EQ.1) IEN2=NACT
             DO 5830 KKJ2=1,NB
                DO 5832 JJ2=IST2,IEN2
                   IA2 = JJ2 + NVAL
                   IS4 = IOB(IA2)
                   ISYB = IMUL(ISYB0,IS4)
                   IF (ISYB.NE.ITAS) GOTO 5832
                   IP2 = IMUL(IS4,IS3)
C
        CALL STR0AE(IBCON1,IBCON2,NB,KKJ2,JJ2,IPER2)
        IPB0 = POSDET(NACT,NB,IBCON2,IFA)
        ITP0 = ICAT + ISPB(IPB0)
        IPERT = IPER*IPER2
        COEFF = CI(ITP0)*IPERT
C
      ICOUNT = 0
      DO 5800 JE=NQS,NQQ
         IS1 = IOB(JE)
         IPT = IMUL(IS1,IP2)
         E0A1 = E0B0 - EFCK(JE)
         IEA = (JE-M1-1)*M1 + IA
         IEAT = INPT(IEA)
         IEA2 = IEA - IA + IA2
         IEA2T = INPT(IEA2)
C
         INT1 = IEAT + IA2 - M1
         INT2 = IEA2T + IA - M1
         DO 5807 JE2=NQS,JE-1
             ICOUNT = ICOUNT + 1
             INT1 = INT1 + M1
             INT2 = INT2 + M1
             IF (IOB(JE2).NE.IPT) GOTO 5807
             TMP4(ICOUNT) = E0A1 - EFCK(JE2)
C
C DETERMINE MATRIX ELEMENT
C
C ME = [IE,IA | IE2,IA2], [IE,IA2 | IE2,IA]
C
        T1 = SVOVO(INT1)*COEFF
        T2 = SVOVO(INT2)*COEFF
        TMP1(ICOUNT) = TMP1(ICOUNT) + T1
        TMP3(ICOUNT) = TMP3(ICOUNT) + T2
C
 5807 CONTINUE
C
C JE2=JE
C
      ICOUNT = ICOUNT + 1
      IF (IP2.NE.1) GOTO 5800
      TMP4(ICOUNT) = E0A1 - EFCK(JE)
      MA = MAX(IEA,IEA2)
      MI = MIN(IEA,IEA2)
      INT1 = INPT(MA) + MI
      T1 = SVOVO(INT1)*COEFF
      TMP1(ICOUNT) = TMP1(ICOUNT) + T1
C
C END LOOP OVER IE(A),IE2(B)
C
 5800 CONTINUE
C
 5832           CONTINUE
                IST2 = IBCON1(KKJ2)+1
                IEN2 = IBCON1(KKJ2+1)-1
                IF (KKJ2.EQ.NB-1) IEN2=NACT
 5830        CONTINUE
C
C END OF BETA DEXCITATION IE2 -> IA2
C
 5822           CONTINUE
                IST = IACON1(KKJ)+1
                IEN = IACON1(KKJ+1)-1
                IF (KKJ.EQ.NA-1) IEN=NACT
 5820        CONTINUE
C
C END OF ALPHA DEXCITATION IE -> IA
C
       EINT = 0.0D+00
       DO II=1,ICOUNT
          EINT = EINT +
     *   (TMP1(II)*TMP1(II)+TMP3(II)*TMP3(II))/TMP4(II)
         TMP1(II) = 0.0D+00
         TMP3(II) = 0.0D+00
         TMP4(II) = 1.0D+00
       ENDDO
C
       ZCOEF=2.0D+00
       IF (IJB.EQ.IJK3) ZCOEF=1.0D+00
       EAAEE = EAAEE + ZCOEF*EINT
       ICOUNT = 0
C
             CALL ADVANC(IBCON1,NB-1,NACT)
 5810     CONTINUE
C
C ------
C END OF LOOP OVER 1-DOWN BETA
C ------
C
        CALL DDI_DLBNEXT(MY_TASK)
      END IF     ! MY TASK
C
            CALL ADVANC(IACON1,NA-1,NACT)
 5805    CONTINUE
C
C END OF LOOP OVER 1-DOWN ALPHA
C
C END OF EXPERIMENT
C
C -------------------------------------------
C *******************************************
C -------------------------------------------
C
         IF (NVAL.EQ.0) THEN
            CALL DDI_DLBRESET
            RETURN
         END IF
C
C ------------------------------------------------------------
C NOW FOR THE FINAL CONTRIBUTION, WHICH IS IV1,IV2 -> IE1,IE2
C AS DAVIDSON ET AL POINTED OUT (J. CHEM. PHYS. 1994,100,3672)
C FOR EACH EXCITATION, THERE IS ONLY ONE VIRTUAL DETERMINANT
C WHICH SIMPLIFIES THINGS INCREDIBLY !!!!!!!!!!!!!!!!!!!!!!!!
C ------------------------------------------------------------
C
C LOOP OVER 0TH ORDER ALPHAS FIRST
C
      DO II=1,NA
         IACON1(II) = II
      ENDDO
      E0A0 = EPT0 - E0V - E0V
C
      DO 9500 IJK4=1,NALP
C
        IF (IJK4+NALP+NBUFF+ND1A-1.EQ.MY_TASK) THEN
C
         ICIT = ISPA(IJK4)
         ISA0 = ISYMA(IJK4)
         ITAS = ITAB(ISA0)
         E0A2 = E0A0
         DO II=1,NA
            E0A2 = E0A2 - EFCK(IACON1(II)+NVAL)
         ENDDO
C
C LOOP OVER CORRECT 0TH ORDER BETAS
C
         DO II=1,NB
            IBCON1(II)=II
         ENDDO
         ZCOEF = 4.0D+00
         DO 9510 INB1 = 1,IJK4
            IF (ISYMB(INB1).NE.ITAS) GOTO 9509
            IF(INB1.EQ.IJK4) ZCOEF=2.0D+00
C
            E0B0 = E0A2
            DO II=1,NB
               E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
            ENDDO
            ICIT = ICIT + 1
            COEFF = ZCOEF*CI(ICIT)*CI(ICIT)
            EINT = 0.0D+00
C
C LOOP OVER ALL POSSIBLE EXCITATIONS
C
            IE1T = -M1
            DO 9542 JE1=NQS,NQQ
               IS1 = IOB(JE1)
               E0B0E = E0B0 - EFCK(JE1)
               IE1T = IE1T + M1
            DO 9544 IV1=1,NVAL
               IS2 = IOB(IV1)
               IP1 = IMUL(IS1,IS2)
               E0B0EV = E0B0E + EFCK(IV1)
               IE1V1 = IE1T + IV1
C
            IE2T = -M1
            DO 9552 JE2=NQS,JE1-1
               IS3 = IOB(JE2)
               IPT  = IMUL(IS3,IP1)
               E0B0EVE = E0B0EV - EFCK(JE2)
               IE2T = IE2T + M1
               IE2V1 = IE2T + IV1
               INT1T = INPT(IE1V1) + IE2T
            DO 9553 IV2 = 1,IV1-1
               IS4 = IOB(IV2)
               IF (IS4.NE.IPT) GOTO 9553
               E0B0EVEV = E0B0EVE + EFCK(IV2)
               IE1V2 = IE1T + IV2
C
               INT1 = INT1T + IV2
               INT2 = INPT(IE1V2) + IE2V1
               T1 = SVOVO(INT1)
               T2 = SVOVO(INT2)
               TT = T1 - T2
        EINT = EINT + (T1*T1 + T2*T2 + TT*TT)/E0B0EVEV
C
 9553       CONTINUE
C
C IV2 = IV1, JE1>JE2
C
            IF (IS2.NE.IPT) GOTO 9552
            E0B0EVEV = E0B0EVE + EFCK(IV1)
            INT1 = INPT(IE1V1) + IE2V1
            T1 = SVOVO(INT1)
            EINT = EINT + (T1*T1)/E0B0EVEV
C
 9552       CONTINUE
C
C NOW FOR JE1=JE2, IV1>IV2
C
            IPT = IMUL(IS1,IP1)
            E0B0EVE = E0B0EV - EFCK(JE1)
            DO 9554 IV2 = 1,IV1-1
               IS4 = IOB(IV2)
               IF (IS4.NE.IPT) GOTO 9554
               E0B0EVEV = E0B0EVE + EFCK(IV2)
               IE1V2 = IE1T + IV2
               INT1 = INPT(IE1V1) + IE1V2
               T1 = SVOVO(INT1)
               EINT = EINT + (T1*T1)/E0B0EVEV
C
 9554       CONTINUE
C
C NOW FOR JE1=JE2,IV1=IV2
C
             E0B0EVEV = E0B0EV + EFCK(IV1) - EFCK(JE1)
             INT1 = INPT(IE1V1+1)
             T1 = SVOVO(INT1)
             EINT = EINT + 0.5D+00*(T1*T1)/E0B0EVEV
C
 9544       CONTINUE
 9542       CONTINUE
C
         EVVEE = EVVEE + COEFF*EINT
C
 9509       CALL ADVANC(IBCON1,NB,NACT)
 9510    CONTINUE
C
C END OF CORRECT 0TH ORDER BETAS
C
        CALL DDI_DLBNEXT(MY_TASK)
      END IF     ! MY TASK
C
         CALL ADVANC(IACON1,NA,NACT)
 9500 CONTINUE
C
C END OF LOOP OVER 0TH ORDER ALPHAS
C
C ----------------------------------------
C END OF ALL VV -> EE EXCITATIONS
C ----------------------------------------
C
      CALL DDI_DLBRESET   ! HMRPT0
      RETURN
      END
C
C*MODULE DEMRPT  *DECK MMRPT0
C     ----------------------------------------------------------
      SUBROUTINE MMRPT0(SI1,SI2,SVOOO,SVOVO,EFCK,EPT0,CI,
     *             NVAL,NACT,NEXT,NCI,NA,NB,IACON1,IBCON1,
     *             IACON2,IBCON2,
     *             NALP,NBLP,ISYMA,ISYMB,ISPA,ISPB,
     *             NSYM,IMUL,ITAB,IOB,INPT,IFA,
     *             TMP1,TMP2,TMP3,TMP4,NTMPSZ,NPTST,HPT,COEFF,HINT)
C     ----------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      INTEGER POSDET
      DIMENSION SI1(*),SI2(*),SVOOO(NEXT,*),SVOVO(*)
      DIMENSION EFCK(*)
      DIMENSION CI(NCI,NPTST)
      DIMENSION IACON1(NA+2),IBCON1(NA+2)
      DIMENSION IACON2(NA+2),IBCON2(NA+2)
      DIMENSION ISYMA(NALP),ISYMB(NBLP),ISPA(NALP),ISPB(NBLP)
      DIMENSION IMUL(NSYM,NSYM),ITAB(NSYM),IOB(*)
      DIMENSION INPT(*)
      DIMENSION IFA(0:NACT,0:NACT)
      DIMENSION TMP1(NTMPSZ,NPTST),TMP2(NTMPSZ,NPTST)
      DIMENSION TMP3(NTMPSZ,NPTST),TMP4(NTMPSZ,NPTST)
      DIMENSION EPT0(NPTST),HPT(NPTST,NPTST),COEFF(NPTST)
      DIMENSION HINT(NPTST,NPTST)
C
      ICOUNT = 0
      M1 = NVAL+NACT
      M2 = (M1*(M1+1))/2
      NQS = M1 + 1
      NQQ = M1 + NEXT
      DO II=1,NPTST
         DO JJ=1,NPTST
            HPT(II,JJ) = 0.0D+00
         ENDDO
      ENDDO
C
      IF (NA.LT.NACT) THEN
         N1A =  IFA(NACT,NA+1)
      ELSE
         N1A = 0
      ENDIF
      IF (NB.LT.NACT) THEN
         N1B =  IFA(NACT,NB+1)
      ELSE
         N1B = 0
      ENDIF
C
C--   IF (NA.LT.NACT-1) THEN
C--      N2A = IFA(NACT,NA+2)
C--   ELSE
C--      N2A = 0
C--   ENDIF
C
      IF (NB.LT.NACT-1) THEN
         N2B = IFA(NACT,NB+2)
      ELSE
         N2B = 0
      ENDIF
C
      IF (NA.GE.2) THEN
         ND1A = IFA(NACT,NA-1)
      ELSEIF (NA.EQ.1) THEN
         ND1A = 1
      ELSEIF (NA.EQ.0) THEN
         ND1A = 0
      ENDIF
C
      IF (NB.GE.2) THEN
         ND1B = IFA(NACT,NB-1)
      ELSEIF (NB.EQ.1) THEN
         ND1B = 1
      ELSEIF (NB.EQ.0) THEN
         ND1B = 0
      ENDIF
C
C--   IF (NA.GE.3) THEN
C--      ND2A = IFA(NACT,NA-2)
C--   ELSEIF (NA.EQ.2) THEN
C--      ND2A = 1
C--   ELSEIF (NA.LE.1) THEN
C--      ND2A = 0
C--   ENDIF
C
      IF (NB.GE.3) THEN
         ND2B = IFA(NACT,NB-2)
      ELSEIF(NB.EQ.2) THEN
         ND2B = 1
      ELSEIF(NB.LE.1) THEN
         ND2B = 0
      ENDIF
C
      E0V = 0.0D+00
      ISYV = 1
      DO II=1,NVAL
         E0V = E0V + EFCK(II)
         ISYV = IMUL(ISYV,IOB(II))
      ENDDO
C
C  LOOP OVER ALL POSSIBLE EXCITED DETERMINANTS, LOTS OF DIFFERENT TYPES
C
C ------------------------------------------------------------------
C  FIRST LOOP OVER ZEROTH ORDER ALPHAS, ORBITALS NUMBERED AS ACTIVE,
C  1,2,etc
C ------------------------------------------------------------------
C
      DO II=1,NA
         IACON1(II) = II
      ENDDO
C
      E0AV = E0V
      ISYAV = ISYV
C
      CALL DDI_DLBNEXT(MY_TASK)
C
      DO 2000 IJK=1,NALP
C
        IF (IJK-1.EQ.MY_TASK) THEN
C
         ICAT = ISPA(IJK)
         ISA1 = IMUL(ISYMA(IJK),ISYAV)
         ITAS = ITAB(ISA1)
         E0A0 = E0AV
         DO II=1,NA
            E0A0 = E0A0 + EFCK(IACON1(II)+NVAL)
         ENDDO
         E0AD = -E0A0 - E0V
C
C  LOOP OVER 1ST AND 2ND ORDER BETAS
C
         IF (NVAL.EQ.0) GOTO 2901
C
C -------------------------------------------
C RELOOP OVER 1ST ORDER BETA VAL -> ACTIVE
C -------------------------------------------
C
C LOOP OVER 1 UP BETAS
C
      DO II=1,NB+1
         IBCON1(II) = II
      ENDDO
      DO 2900 IJB=1,N1B
         ISYB = ISYV
         E0B0 = E0AD
         DO II=1,NB+1
            E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
            ISYB = IMUL(ISYB,IOB(IBCON1(II)+NVAL))
         ENDDO
         ISYL = IMUL(ITAS,ISYB)
C
C LOOP OVER SINGLE DEXCITATIONS OUT OF ACTIVE
C
         DO 2910 IEL=1,NB+1
            IA = IBCON1(IEL) + NVAL
            IS1 = IOB(IA)
            IF (IS1.NE.ISYL) GOTO 2910
C
C DETERMINE 0TH ORDER BETA, POS/PERM
C
          CALL STR0VA(IBCON1,IBCON2,NB+1,IEL,NVAL,NVAL,IPER)
          IPB0 = POSDET(NACT,NB,IBCON2,IFA)
          ITP0 = ICAT + ISPB(IPB0)
          DO III=1,NPTST
             COEFF(III) = CI(ITP0,III)*IPER
          ENDDO
C
C LOOP OVER BETA VALENCE
C
          DO 2920 IV=1,NVAL
             IS2 = IOB(IV)
             IF (IS1.NE.IS2) GOTO 2920
C
C MATRIX ELEMENT
C
       CALL ME0VA1B(IV,IA,IBCON2,NB,IACON1,NA,NVAL,INPT,SI1,SI2,T)
C
             DO III=1,NPTST
                TMP3(IV,III) = TMP3(IV,III) + T*COEFF(III)
                TMP4(IV,III) = E0B0 + EFCK(IV) + EPT0(III)
             ENDDO
C
 2920     CONTINUE
C
C END OF LOOP OVER BETA VALENCE
C
 2910    CONTINUE
C
C END OF PURE SINGLE BETA DEXCITATIONS OUT OF ACTIVE
C
C NOW FOR DOUBLE DEXCITATIONS
C  DOUBLE DEXCITATIONS MUST !!!!! INCLUDE THE SINGLES ABOVE !!!!!
C  START WITH THIS TYPE FIRST, IE BETA IA(?) -> IV
C
      DO 2930 IEL=1,NB+1
         IA = IBCON1(IEL)+NVAL
         JA = IA - NVAL
         IS1 = IOB(IA)
         CALL STR0VA(IBCON1,IBCON2,NB+1,IEL,NVAL,NVAL,IPER)
         IPB0 = POSDET(NACT,NB,IBCON2,IFA)
         ICAB = ISPB(IPB0)
C
C  2ND EXCITATION: BETA ACT (IA2 > IA) -> ACT (JJA)
C  TOTAL = BETA ( IA < IA2 -> IV,JJA)
C
         DO 2940 IEL2=IEL,NB
            IA2 = IBCON2(IEL2)+NVAL
            IS2 = IOB(IA2)
            IP1 = IMUL(IS1,IS2)
C
         IST = 1
         IEN = IBCON2(1)-1
         DO 2950 KKJ=1,NB+1
            DO 2952 JJ=IST,IEN
               IF (JJ.EQ.JA) GOTO 2952
               JJA = JJ + NVAL
               IS3 = IOB(JJA)
               IPT = IMUL(IS3,IP1)
               IF (IPT.NE.ISYL) GOTO 2952
C
               MA = MAX(IA2,JJA)
               MI = MIN(IA2,JJA)
               IA3A2 = INPT(MA) + MI
               MA = MAX(IA,JJA)
               MI = MIN(IA,JJA)
               IA3A = INPT(MA) + MI
C
C DETERMINE NEW 0TH ORDER BETA, POS/PERM AND MATRIX ELEMENT
C
          CALL RET1DET(IBCON2,IACON2,NB,IEL2,JJ,0,KKJ,ISWAP2)
          IPER2 = (-1)**ISWAP2
          IPERT = IPER*IPER2
          IPB2 = POSDET(NACT,NB,IACON2,IFA)
          ITP0 = ICAT + ISPB(IPB2)
          DO III=1,NPTST
             COEFF(III) = CI(ITP0,III)*IPERT
          ENDDO
C
C LOOP OVER BETA VALENCE
C
          DO 2960 IV=1,NVAL
             IS4 = IOB(IV)
             IP2 = IMUL(IS4,IS3)
             IF (IP1.NE.IP2) GOTO 2960
C
C MATRIX ELEMENT
C
         IAV = INPT(IA) + IV
         IA2V = INPT(IA2) + IV
         INT1 = INPT(IA3A2) + IAV
         MA = MAX(IA3A,IA2V)
         MI = MIN(IA3A,IA2V)
         INT2 = INPT(MA) + MI
         T = SI2(INT1) - SI2(INT2)
         DO III=1,NPTST
            TMP3(IV,III) = TMP3(IV,III) + T*COEFF(III)
            TMP4(IV,III) = E0B0 + EFCK(IV) + EPT0(III)
         ENDDO
C
 2960     CONTINUE
C
C END OF LOOP OVER BETA VALENCE
C
 2952       CONTINUE
            IST = IBCON2(KKJ)+1
            IEN = IBCON2(KKJ+1)-1
            IF (KKJ.EQ.NB) IEN=NACT
 2950    CONTINUE
C
 2940    CONTINUE
C
C END OF 2ND DEXCITATIONS
C
C  NOW FOR 2ND EXCITATION: ALPHA ACT (IA2) -> ACT (JJA)
C  TOTAL = ( IA(B),IA2(A) -> IV(B),JJA(A) )
C
      DO 2970 IEL2=1,NA
         IA2 = IACON1(IEL2)+NVAL
         IS2 = IOB(IA2)
         IP1 = IMUL(IS1,IS2)
C
         IST = 1
         IEN = IACON1(1)-1
         DO 2980 KKJ=1,NA+1
            DO 2982 JJ=IST,IEN
               JJA = JJ + NVAL
               IS3 = IOB(JJA)
               IPT = IMUL(IP1,IS3)
               IF (IPT.NE.ISYL) GOTO 2982
C
          MA = MAX(IA2,JJA)
          MI = MIN(IA2,JJA)
          IA3A2 = INPT(MA) + MI
C
C DETERMINE NEW 0TH ORDER ALPHA, POS/PERM AND MATRIX ELEMENT
C
          CALL RET1DET(IACON1,IACON2,NA,IEL2,JJ,0,KKJ,ISWAP2)
          IPER2 = (-1)**ISWAP2
          IPERT = IPER*IPER2
          IPA2 = POSDET(NACT,NA,IACON2,IFA)
          ITP0 = ISPA(IPA2) + ICAB
          DO III=1,NPTST
             COEFF(III) = CI(ITP0,III)*IPERT
          ENDDO
C
C LOOP OVER BETA VALENCE
C
          DO 2990 IV=1,NVAL
             IS4 = IOB(IV)
             IP2 = IMUL(IS4,IS3)
             IF (IP1.NE.IP2) GOTO 2990
C
C MATRIX ELEMENT
C
         IAV = INPT(IA) + IV
         MA = MAX(IA3A2,IAV)
         MI = MIN(IA3A2,IAV)
         INT = INPT(MA) + MI
         T = SI2(INT)
         DO III=1,NPTST
            TMP3(IV,III) = TMP3(IV,III) + T*COEFF(III)
            TMP4(IV,III) = E0B0 + EFCK(IV) + EPT0(III)
         ENDDO
C
 2990     CONTINUE
C
C END OF LOOP OVER BETA VALENCE
C
 2982       CONTINUE
            IST = IACON1(KKJ)+1
            IEN = IACON1(KKJ+1)-1
            IF (KKJ.EQ.NA) IEN=NACT
 2980    CONTINUE
C
 2970 CONTINUE
C
C END OF 2ND EXCITATION: ALPHA ACT (IA2) -> ACT (JJA)
C
 2930 CONTINUE
C
C END OF SINGLE DEXCITES IA -> IV
C
         DO JJ=1,NPTST
         DO KK=1,NPTST
         HINT(JJ,KK) = 0.0D+00
         DO II=1,NVAL
         HINT(JJ,KK)=HINT(JJ,KK) + (TMP3(II,JJ)*TMP3(II,KK))/TMP4(II,JJ)
         ENDDO
         ENDDO
         ENDDO
C
         DO JJ=1,NPTST
            DO II=1,NVAL
               TMP3(II,JJ) = 0.0D+00
               TMP4(II,JJ) = 1.0D+00
            ENDDO
         ENDDO
C
         DO JJ=1,NPTST
            DO KK=1,NPTST
               HPT(JJ,KK) = HPT(JJ,KK) + 2.0D+00*HINT(JJ,KK)
            ENDDO
         ENDDO
C
         CALL ADVANC(IBCON1,NB+1,NACT)
 2900 CONTINUE
 2901 CONTINUE
C
C END OF LOOP OVER 1 UP BETAS
C
C -------------------------------------------
C END OF RELOOP OVER 1ST ORDER BETA VAL -> ACTIVE
C -------------------------------------------
C
C --------------------------------------------
C 1ST ORDER BETA ACT -> EXTERNAL (IA(?) -> IE)
C --------------------------------------------
C
C LOOP OVER DOWN 1 BETAS FIRST
C
            DO II=1,NB-1
               IBCON1(II) = II
            ENDDO
            DO 2230 IJB=1,ND1B
              ISYB1 = ISYV
              E0B0 = E0AD
              DO II=1,NB-1
                 ISYB1 = IMUL(ISYB1,IOB(IBCON1(II)+NVAL))
                 E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
              ENDDO
              ISYL = IMUL(ISYB1,ITAS)
C
C SINGLE DEXCITATIONS, BETA IE -> IA (?)
C
              IST = 1
              IEN = IBCON1(1)-1
              IF (NB.EQ.1) IEN=NACT
              DO 2240 KKJ=1,NB
              DO 2242 JJ=IST,IEN
                 JJE = JJ + NVAL
                 IS2 = IOB(JJE)
                 IF (IS2.NE.ISYL) GOTO 2242
C
C DETERMINE 0TH ORDER BETA STRING, POSITION/PERM AND MATRIX ELEMENT
C
          CALL STR0AE(IBCON1,IBCON2,NB,KKJ,JJ,IPER)
          IPB0 = POSDET(NACT,NB,IBCON2,IFA)
          ITP0 = ICAT + ISPB(IPB0)
          DO III=1,NPTST
             COEFF(III) = CI(ITP0,III)*IPER
          ENDDO
C
C LOOP OVER EXTERNAL ORBS
C
         DO 2215 IE=1,NEXT
            JE = IE + M1
            IS1 = IOB(JE)
            IF (IS1.NE.IS2) GOTO 2215
C
          CALL ME0AE1B(JJE,IE,IBCON1,NB,IACON1,NA,NVAL,NACT,NEXT,
     *    INPT,SI1,SVOOO,M2,T)
C
          DO III=1,NPTST
             TMP3(IE,III) = TMP3(IE,III) + COEFF(III)*T
             TMP4(IE,III) = E0B0 - EFCK(JE) + EPT0(III)
          ENDDO
C
 2215    CONTINUE
C
 2242         CONTINUE
              IST = IBCON1(KKJ)+1
              IEN = IBCON1(KKJ+1)-1
              IF (KKJ.EQ.NB-1) IEN=NACT
 2240         CONTINUE
C
C NOW FOR DOUBLE DEXCITATIONS
C DOUBLE DEXCITATIONS MUST !!!!! INCLUDE THE SINGLES ABOVE !!!!!
C START WITH THIS TYPE FIRST, IE BETA IE -> IA(?)
C
              IST = 1
              IEN = IBCON1(1)-1
              IF (NB.EQ.1) IEN=NACT
              DO 2250 KKJ=1,NB
              DO 2252 JJ=IST,IEN
                 IA = JJ + NVAL
                 IS1 = IOB(IA)
                 CALL STR0AE(IBCON1,IBCON2,NB,KKJ,JJ,IPER)
                 IPB0 = POSDET(NACT,NB,IBCON2,IFA)
                 ICAB = ISPB(IPB0)
C
C 2ND EXCITATION: BETA ACT (IA2.NE.IA) -> ACT (JJA > IA)
C TOTAL = BETA (IE,IA2 -> IA < JJA )
C
                 DO 2255 IEL=1,NB
                    IF (IEL.EQ.KKJ) GOTO 2255
                    IA2 = IBCON2(IEL)+NVAL
                    IS2 = IOB(IA2)
                    IP1 = IMUL(IS1,IS2)
C
C  HAVE ENSURED THAT IA2.NE.IA, NOW TO ENSURE THAT JJA > IA
C
                 IST2=JJ+1
                 IEN2=IEN
                 DO 2258 KKJ2=KKJ+1,NB+1
                 DO 2257 JJ2=IST2,IEN2
                    JJA = JJ2 + NVAL
                    IS3 = IOB(JJA)
                    IPT = IMUL(IP1,IS3)
                    IF (IPT.NE.ISYL) GOTO 2257
C
C  DETERMINE NEW 0TH ORDER BETA, POS/PERM AND MATRIX ELEMENT
C
              CALL RET1DET(IBCON2,IACON2,NB,IEL,JJ2,0,KKJ2,ISWAP2)
              IPER2 = (-1)**ISWAP2
              IPERT = IPER*IPER2
              IPB2 = POSDET(NACT,NB,IACON2,IFA)
              ITP0 = ICAT + ISPB(IPB2)
              DO III=1,NPTST
                 COEFF(III) = CI(ITP0,III)*IPERT
              ENDDO
C
              MA = MAX(IA,IA2)
              MI = MIN(IA,IA2)
              IAA2 = INPT(MA) + MI
              MA = MAX(IA2,JJA)
              MI = MIN(IA2,JJA)
              IA2A3 = INPT(MA) + MI
              IAA2A3 = (IA-1)*M2 + IA2A3
              IA3AA2 = (JJA-1)*M2 + IAA2
C
      DO 2217 IE=1,NEXT
         JE = IE + M1
         IS4 = IOB(JE)
         IP2 = IMUL(IS4,IS3)
         IF (IP1.NE.IP2) GOTO 2217
C
C  ME = [IE,IA | IA2,JJA] - [IE,JJA | IA2,IA]
C
              T = SVOOO(IE,IAA2A3) - SVOOO(IE,IA3AA2)
C
              DO III=1,NPTST
                 TMP3(IE,III) = TMP3(IE,III) + COEFF(III)*T
                 TMP4(IE,III) = E0B0 - EFCK(JE) + EPT0(III)
              ENDDO
C
 2217 CONTINUE
C
 2257            CONTINUE
                 IST2 = IBCON2(KKJ2)+1
                 IEN2 = IBCON2(KKJ2+1)-1
                 IF (KKJ2.EQ.NB) IEN2=NACT
 2258            CONTINUE
C
 2255            CONTINUE
C
C END OF 2ND EXCITATION: BETA ACT (IA2 -> JJA)
C
C 2ND EXCITATION: ALPHA ACT (IA2 -> JJA)
C  TOTAL = ( IE(B),IA2(A) -> IA(B),JJA(A) )
C
                 DO 2260 IEL2=1,NA
                    IA2 = IACON1(IEL2)+NVAL
                    IS2 = IOB(IA2)
                    IP1 = IMUL(IS1,IS2)
C
                 IST2 = 1
                 IEN2 = IACON1(1)-1
                 DO 2268 KKJ2=1,NA+1
                    DO 2267 JJ2=IST2,IEN2
                       JJA = JJ2 + NVAL
                       IS3 = IOB(JJA)
                       IPT = IMUL(IP1,IS3)
                       IF (IPT.NE.ISYL) GOTO 2267
C
C DETERMINE NEW 0TH ORDER ALPHA, POS/PERM AND MATRIX ELEMENT
C
            CALL RET1DET(IACON1,IACON2,NA,IEL2,JJ2,0,KKJ2,ISWAP2)
            IPER2 = (-1)**ISWAP2
            IPERT = IPER*IPER2
            IPA2 = POSDET(NACT,NA,IACON2,IFA)
            ITP0 = ISPA(IPA2) + ICAB
            DO III=1,NPTST
               COEFF(III) = CI(ITP0,III)*IPERT
            ENDDO
C
            MA = MAX(IA2,JJA)
            MI = MIN(IA2,JJA)
            IA2A3 = INPT(MA) + MI
            IAA2A3 = (IA-1)*M2 + IA2A3
C
      DO 2219 IE=1,NEXT
         JE = IE+M1
         IS4 = IOB(JE)
         IP2 = IMUL(IS4,IS3)
         IF (IP1.NE.IP2) GOTO 2219
C
C ME = [IE,IA | IA2,JJA]
C
            T = SVOOO(IE,IAA2A3)
            DO III=1,NPTST
               TMP3(IE,III) = TMP3(IE,III) + COEFF(III)*T
               TMP4(IE,III) = E0B0 - EFCK(JE) + EPT0(III)
            ENDDO
C
 2219 CONTINUE
C
 2267               CONTINUE
                    IST2 = IACON1(KKJ2)+1
                    IEN2 = IACON1(KKJ2+1)-1
                    IF (KKJ2.EQ.NA) IEN2=NACT
 2268            CONTINUE
C
 2260            CONTINUE
C
C END OF 2ND EXCITATION: ALPHA ACT (IA2 -> JJA)
C
 2252         CONTINUE
              IST = IBCON1(KKJ)+1
              IEN = IBCON1(KKJ+1)-1
              IF (KKJ.EQ.NB-1) IEN=NACT
 2250         CONTINUE
C
C END OF 1ST EXCITATION BETA IE -> IA(?)
C
         DO JJ=1,NPTST
         DO KK=1,NPTST
         HINT(JJ,KK) = 0.0D+00
         DO II=1,NEXT
         HINT(JJ,KK)=HINT(JJ,KK) + (TMP3(II,JJ)*TMP3(II,KK))/TMP4(II,JJ)
         ENDDO
         ENDDO
         ENDDO
C
         DO JJ=1,NPTST
            DO II=1,NEXT
               TMP3(II,JJ) = 0.0D+00
               TMP4(II,JJ) = 1.0D+00
            ENDDO
         ENDDO
C
         DO JJ=1,NPTST
            DO KK=1,NPTST
               HPT(JJ,KK) = HPT(JJ,KK) + 2.0D+00*HINT(JJ,KK)
            ENDDO
         ENDDO
C
              CALL ADVANC(IBCON1,NB-1,NACT)
 2230      CONTINUE
C
C -----------------------------------------
C  END OF 1ST ORDER BETA ACT -> EXTERNAL
C -----------------------------------------
C
           IF (NVAL.EQ.0) GOTO 2101
C
C ----------------------------------------------------
C RELOOP LOOP OVER 2ND ORDER BETAS, IV1,IV2 -> IA1,IA2
C ----------------------------------------------------
C
C LOOP OVER 2 UP BETAS
C
      DO II=1,NB+2
         IBCON1(II) = II
      ENDDO
      DO 2100 IJB=1,N2B
         ISYB = ISYV
         E0B0 = E0AD
         DO II=1,NB+2
            ISYB = IMUL(ISYB,IOB(IBCON1(II)+NVAL))
            E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
         ENDDO
         ISYL = IMUL(ISYB,ITAS)
C
C LOOP OVER DEXCITATIONS FROM BETA ACTIVE IA1 < IA2
C
         DO 2110 IEL1=1,NB+2
            IA1 = IBCON1(IEL1)+NVAL
            IS1 = IOB(IA1)
            IA1T = INPT(IA1)
C
         DO 2120 IEL2=IEL1+1,NB+2
            IA2 = IBCON1(IEL2)+NVAL
            IS2 = IOB(IA2)
            IP1 = IMUL(IS1,IS2)
            IF (IP1.NE.ISYL) GOTO 2120
            IA2T = INPT(IA2)
C
      CALL STR0VVAA(IBCON1,IBCON2,NB+2,IEL1,IEL2,NVAL,
     *     NVAL,NVAL,IPER)
      IPB0 = POSDET(NACT,NB,IBCON2,IFA)
      ITP0 = ICAT + ISPB(IPB0)
      DO III=1,NPTST
         COEFF(III) = CI(ITP0,III)*IPER
      ENDDO
C
C LOOP OVER BETA VALENCE IV1 < IV2
C
         ICOUNT = 0
         DO 2130 IV1=1,NVAL
            IS3 = IOB(IV1)
            E0B0V = E0B0 + EFCK(IV1)
            IA1V1 = IA1T + IV1
            IA2V1 = IA2T + IV1
            IA2V1T = INPT(IA2V1)
C
         DO 2140 IV2=1,IV1-1
            ICOUNT = ICOUNT + 1
            IS4 = IOB(IV2)
            IP2 = IMUL(IS4,IS3)
            IF (IP1.NE.IP2) GOTO 2140
C
C MATRIX ELEMENT
C
            IA1V2 = IA1T + IV2
            IA2V2 = IA2T + IV2
            INT1 = INPT(IA2V2) + IA1V1
            INT2 = IA2V1T + IA1V2
            T = SI2(INT1) - SI2(INT2)
            DO III=1,NPTST
               TMP3(ICOUNT,III) = TMP3(ICOUNT,III) + T*COEFF(III)
               TMP4(ICOUNT,III) = E0B0V + EFCK(IV2) + EPT0(III)
            ENDDO
C
 2140    CONTINUE
 2130    CONTINUE
C
C END OF LOOP OVER BETA VALENCE IV1 < IV2
C
 2120    CONTINUE
 2110    CONTINUE
C
C END OF DOUBLE BETA DEXCITATIONS FROM ACTIVE IA1 < IA2
C
         DO JJ=1,NPTST
         DO KK=1,NPTST
         HINT(JJ,KK) = 0.0D+00
         DO II=1,ICOUNT
         HINT(JJ,KK)=HINT(JJ,KK) + (TMP3(II,JJ)*TMP3(II,KK))/TMP4(II,JJ)
         ENDDO
         ENDDO
         ENDDO
C
         DO JJ=1,NPTST
            DO II=1,ICOUNT
               TMP3(II,JJ) = 0.0D+00
               TMP4(II,JJ) = 1.0D+00
            ENDDO
         ENDDO
C
         DO JJ=1,NPTST
            DO KK=1,NPTST
               HPT(JJ,KK) = HPT(JJ,KK) + HINT(JJ,KK)*2.0D+00
            ENDDO
         ENDDO
C
         ICOUNT = 0
C
         CALL ADVANC(IBCON1,NB+2,NACT)
 2100 CONTINUE
C
C END OF LOOP OVER 2 UP BETAS
C
C ----------------------------------------------------
C END RELOOP LOOP OVER 2ND ORDER BETAS, IV1,IV2 -> IA1,IA2
C ----------------------------------------------------
C
C ----------------------------------------------------
C RELOOP OVER 2ND ORDER BETAS, IV1,IV2 -> IA2,IE
C ----------------------------------------------------
C THESE INCLUDE ALSO IV1(A)<IV2(B) -> IA2(B),IE(A)
C                    IV1(A)=IV2(B) -> IA2(B),IE(A)
C                    IV1(A)>IV2(B) -> IA2(B),IE(A)
C ***
C
C LOOP OVER 1 UP BETAS
C
         DO II=1,NB+1
            IBCON1(II) = II
         ENDDO
         DO 2810 IJB=1,N1B
            ISYB=ISYV
            E0B0 = E0AD
            DO II=1,NB+1
               E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
               ISYB = IMUL(ISYB,IOB(IBCON1(II)+NVAL))
            ENDDO
            ISYL = IMUL(ITAS,ISYB)
C
C DOUBLE EXCITATIONS MUST INCLUDE ALPHA IE -> IV SPECIFIED ABOVE
C SECOND EXCITATION BETA (IA2 -> IV2)
C TOTAL = ( IE(A),IA2(B) -> IV(A),IV2(B) )
C
            DO 2820 IEL=1,NB+1
               IA2 = IBCON1(IEL)+NVAL
               IS1 = IOB(IA2)
               IF (IS1.NE.ISYL) GOTO 2820
C
C DETERMINE NEW 0TH ORDER BETA, POS/PERM
C
        CALL STR0VA(IBCON1,IBCON2,NB+1,IEL,NVAL,NVAL,IPER)
        IPB0 = POSDET(NACT,NB,IBCON2,IFA)
        ITP0 = ICAT + ISPB(IPB0)
        DO III=1,NPTST
           COEFF(III) = CI(ITP0,III)*IPER
        ENDDO
C
C LOOP OVER BETA VALENCE
C
        ICOUNT = 0
        DO 2830 IV1=1,NVAL
           IS2 = IOB(IV1)
           IP1 = IMUL(IS1,IS2)
           E0BV = E0B0 + EFCK(IV1)
           IA2V1 = INPT(IA2) + IV1
C
C LOOP OVER ALPHA VALENCE AND EXTERNAL
C
        DO 2840 IV2=1,IV1-1
           IS3 = IOB(IV2)
           IPT = IMUL(IS3,IP1)
           E0BVV = E0BV + EFCK(IV2)
           IA2V2 = INPT(IA2) + IV2
           IV2A2V1 = (IV2-1)*M2 + IA2V1
           IV1A2V2 = (IV1-1)*M2 + IA2V2
C
        DO 2850 IE=1,NEXT
           JE = IE + M1
           IF (IOB(JE).NE.IPT) GOTO 2850
           ICOUNT = ICOUNT + 1
C
       T1 = SVOOO(IE,IV2A2V1)
       T2 = SVOOO(IE,IV1A2V2)
       TT = T1 - T2
       DO III=1,NPTST
          TMP3(ICOUNT,III) = TMP3(ICOUNT,III) + T1*COEFF(III)
          TMP1(ICOUNT,III) = TMP1(ICOUNT,III) + T2*COEFF(III)
          TMP2(ICOUNT,III) = TMP2(ICOUNT,III) + TT*COEFF(III)
          TMP4(ICOUNT,III) = E0BVV - EFCK(JE) + EPT0(III)
       ENDDO
C
 2850   CONTINUE
 2840   CONTINUE
C
C FOR IV2.EQ.IV1
C
           IS3 = IOB(IV1)
           IPT = IMUL(IS3,IP1)
           E0BVV = E0BV + EFCK(IV1)
           IV2A2V1 = (IV1-1)*M2 + IA2V1
           DO 2870 IE=1,NEXT
              JE = IE + M1
              IF (IOB(JE).NE.IPT) GOTO 2870
              ICOUNT = ICOUNT + 1
C
       T1 = SVOOO(IE,IV2A2V1)
       DO III=1,NPTST
          TMP3(ICOUNT,III) = TMP3(ICOUNT,III) + T1*COEFF(III)
          TMP4(ICOUNT,III) = E0BVV - EFCK(JE) + EPT0(III)
       ENDDO
C
 2870 CONTINUE
C
C END OF IV2.GE.IV1
C
 2830   CONTINUE
C
 2820       CONTINUE
C
C END OF DOUBLE DEXCITATIONS
C
         DO JJ=1,NPTST
         DO KK=1,NPTST
         HINT(JJ,KK) = 0.0D+00
         DO II=1,ICOUNT
            HINT(JJ,KK) = HINT(JJ,KK) + (TMP3(II,JJ)*TMP3(II,KK)+
     *  TMP1(II,JJ)*TMP1(II,KK)+
     *  TMP2(II,JJ)*TMP2(II,KK))/TMP4(II,JJ)
         ENDDO
         ENDDO
         ENDDO
C
         DO JJ=1,NPTST
            DO II=1,ICOUNT
               TMP1(II,JJ) = 0.0D+00
               TMP2(II,JJ) = 0.0D+00
               TMP3(II,JJ) = 0.0D+00
               TMP4(II,JJ) = 1.0D+00
            ENDDO
         ENDDO
C
         DO JJ=1,NPTST
            DO KK=1,NPTST
               HPT(JJ,KK) = HPT(JJ,KK) + 2.0D+00*HINT(JJ,KK)
            ENDDO
         ENDDO
C
         ICOUNT = 0
C
            CALL ADVANC(IBCON1,NB+1,NACT)
 2810    CONTINUE
C
C ----------------------------------------------------
C END RELOOP OVER 2ND ORDER BETAS, IV1,IV2 -> IA1,IE
C ----------------------------------------------------
C
C ----------------------------------------------------
C LOOP OVER 2ND ORDER BETAS ( IV,IA -> IE1<IE2 )
C ----------------------------------------------------
C THESE EXCITATIONS ALSO INCLUDE IV(A),IA(B) -> IE1(A)<IE2(B)
C AND                            IV(A),IA(B) -> IE1(B)<IE2(A)
C AND                            IV(A),IA(B) -> IE1(A),IE1(B)
C
C LOOP OVER 1 DOWN BETAS
C
         DO II=1,NB-1
            IBCON1(II) = II
         ENDDO
         DO 2530 IJB=1,ND1B
            ISYB0 = ISYV
            E0B0 = E0V
            DO II=1,NB-1
               E0B0 = E0B0 + EFCK(IBCON1(II)+NVAL)
               ISYB0 = IMUL(ISYB0,IOB(IBCON1(II)+NVAL))
            ENDDO
            IMS = IMUL(ISYB0,ITAS)
            E0B1 = -E0B0-E0A0
C
C LOOP OVER DEXCITATIONS INTO ACTIVE (IE2 -> IA)
C
            IST = 1
            IEN = IBCON1(1)-1
            IF (NB.EQ.1) IEN=NACT
            DO 2540 KKJ=1,NB
               DO 2542 JJ=IST,IEN
                  IA = JJ + NVAL
                  IS3 = IOB(IA)
                  IF (IS3.NE.IMS) GOTO 2542
C
C DETERMINE 0TH ORDER BETA STRING, POS/PERM
C
       CALL STR0AE(IBCON1,IBCON2,NB,KKJ,JJ,IPER2)
       IPB0 = POSDET(NACT,NB,IBCON2,IFA)
       ITP0 = ICAT + ISPB(IPB0)
       DO III=1,NPTST
          COEFF(III) = CI(ITP0,III)*IPER2
       ENDDO
C
C LOOP OVER DOUBLE BETA DEXCITATIONS ( IE1<IE2 -> IV,IA )
C
         ICOUNT = 0
         JDV = 0
         JDA = -M1 + IA
         DO 2500 JE1=NQS,NQQ
            IS1 = IOB(JE1)
            IP2 = IMUL(IS3,IS1)
            E0BE = E0B1 - EFCK(JE1)
            JDA = JDA + M1
            JDAV = (JDA*(JDA-1))/2
            JDAT = JDAV
            JDVT = (JDV*(JDV-1))/2 + IA
C
         DO 2510 IV=1,NVAL
            IS2 = IOB(IV)
            IPT = IMUL(IS2,IP2)
            E0BEV = E0BE + EFCK(IV)
            JDAT = JDAT + 1
            JDV = JDV + 1
            JDVT = JDVT + JDV - 1
C
         INT1 = -M1 + JDVT
         INT2 = -M1 + JDAT
         DO 2520 JE2=NQS,JE1-1
            INT1 = INT1 + M1
            INT2 = INT2 + M1
            IF (IOB(JE2).NE.IPT) GOTO 2520
C
            ICOUNT = ICOUNT + 1
C
C DETERMINE MATRIX ELEMENT
C
C ME = [IE1,IV | IE2,IA] - [IE1,IA | IE2,IV]
C
       T1 = SVOVO(INT1)
       T2 = SVOVO(INT2)
       TT = T1 - T2
C
       DO III=1,NPTST
          TMP1(ICOUNT,III) = TMP1(ICOUNT,III) + T1*COEFF(III)
          TMP2(ICOUNT,III) = TMP2(ICOUNT,III) + T2*COEFF(III)
          TMP3(ICOUNT,III) = TMP3(ICOUNT,III) + TT*COEFF(III)
          TMP4(ICOUNT,III) = E0BEV-EFCK(JE2) + EPT0(III)
       ENDDO
C
 2520    CONTINUE
C
C IE1 = IE2
C
         IF (IS3.NE.IS2) GOTO 2510
         ICOUNT = ICOUNT + 1
         INT2 = INT2 + M1
         T1 = SVOVO(INT2)
         DO III=1,NPTST
            TMP1(ICOUNT,III) = TMP1(ICOUNT,III) + T1*COEFF(III)
            TMP4(ICOUNT,III) = E0BEV-EFCK(JE1)+EPT0(III)
         ENDDO
C
 2510    CONTINUE
         JDV = JDV + NACT
 2500    CONTINUE
C
C END OF DOUBLE BETA DEXCITATIONS ( IE1<IE2 -> IV,IA )
C
 2542          CONTINUE
               IST = IBCON1(KKJ)+1
               IEN = IBCON1(KKJ+1)-1
               IF (KKJ.EQ.NB-1) IEN=NACT
 2540       CONTINUE
C
C END OF EXCITATION INTO BETA ACTIVE
C
       DO JJ=1,NPTST
       DO KK=1,NPTST
       HINT(JJ,KK) = 0.0D+00
       DO II=1,ICOUNT
          HINT(JJ,KK) = HINT(JJ,KK) +
     *    (TMP1(II,JJ)*TMP1(II,KK)+
     *     TMP2(II,JJ)*TMP2(II,KK)+
     *     TMP3(II,JJ)*TMP3(II,KK))/TMP4(II,JJ)
       ENDDO
       ENDDO
       ENDDO
C
       DO JJ=1,NPTST
          DO II=1,ICOUNT
             TMP1(II,JJ) = 0.0D+00
             TMP2(II,JJ) = 0.0D+00
             TMP3(II,JJ) = 0.0D+00
             TMP4(II,JJ) = 1.0D+00
          ENDDO
       ENDDO
C
       DO JJ=1,NPTST
          DO KK=1,NPTST
             HPT(JJ,KK) = HPT(JJ,KK) + 2.0D+00*HINT(JJ,KK)
          ENDDO
       ENDDO
C
       ICOUNT = 0
C
            CALL ADVANC(IBCON1,NB-1,NACT)
 2530    CONTINUE
C
C END OF 1 DOWN BETAS
C
C ------------------------------------------------
C END OF LOOP OVER 2ND ORDER BETAS (IV,IA -> IE1,IE2)
C ------------------------------------------------
C
 2101 CONTINUE
C
C ------------------------------------------------
C LOOP OVER 2ND ORDER BETAS (IA1<IA2 -> IE1<IE2)
C ------------------------------------------------
C
         DO II=1,NB-2
            IBCON1(II) = II
         ENDDO
         DO 2620 IJB=1,ND2B
            E0B0 = -E0V-E0A0
            ISB0 = ISYV
            DO II=1,NB-2
               E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
               ISB0 = IMUL(ISB0,IOB(IBCON1(II)+NVAL))
            ENDDO
C
C LOOP OVER DOUBLE BETA DEXCITATIONS ( IE1<IE2 -> IA1<IA2 )
C
            IST = 1
            IEN = IBCON1(1)-1
            IF (NB.EQ.2) IEN=NACT
            DO 2630 KKJ=1,NB-1
               DO 2632 JJ=IST,IEN
                  IA1 = JJ + NVAL
                  IS3 = IOB(IA1)
                  ISYBE1 = IMUL(ISB0,IS3)
                  CALL STR0AE(IBCON1,IBCON2,NB-1,KKJ,JJ,IPER)
C
            IST2 = JJ+1
            IEN2 = IEN
            DO 2640 KKJ2=KKJ+1,NB
               DO 2642 JJ2=IST2,IEN2
                  IA2 = JJ2 + NVAL
                  IS4 = IOB(IA2)
                  ISYBE2 = IMUL(ISYBE1,IS4)
                  IF (ISYBE2.NE.ITAS) GOTO 2642
                  IP2 = IMUL(IS4,IS3)
C
C DETERMINE NEW 0TH ORDER BETA, POS/PERM AND MATRIX ELEMENT
C
         CALL STR0AE(IBCON2,IACON2,NB,KKJ2,JJ2,IPER2)
         IPERT = IPER*IPER2
         IPB0 = POSDET(NACT,NB,IACON2,IFA)
         ITP0 = ICAT + ISPB(IPB0)
         DO III=1,NPTST
            COEFF(III) = CI(ITP0,III)*IPERT
         ENDDO
C
C LOOP OVER EXTERNAL ORBITALS
C
         ICOUNT = 0
         DO 2600 JE1=NQS,NQQ
            IS1 = IOB(JE1)
            IPT = IMUL(IS1,IP2)
            E0BE1 = E0B0 - EFCK(JE1)
            IE1A1 = (JE1-M1-1)*M1 + IA1
            IE1A2 = IE1A1 - IA1 + IA2
            IE1A1T = INPT(IE1A1)
            IE1A2T = INPT(IE1A2)
C
         INT1 = IE1A1T + IA2 - M1
         INT2 = IE1A2T + IA1 - M1
         DO 2610 JE2=NQS,JE1-1
            INT1 = INT1 + M1
            INT2 = INT2 + M1
            ICOUNT = ICOUNT + 1
            IF (IOB(JE2).NE.IPT) GOTO 2610
C
C ME = [IE2,IA2 | IE1,IA1] - [IE2,IA1 | IE1,IA2]
C
         T = SVOVO(INT1) - SVOVO(INT2)
         DO III=1,NPTST
            TMP3(ICOUNT,III) = TMP3(ICOUNT,III) + COEFF(III)*T
            TMP4(ICOUNT,III) = E0BE1 - EFCK(JE2) + EPT0(III)
         ENDDO
C
 2610    CONTINUE
 2600    CONTINUE
C
 2642          CONTINUE
               IST2 = IBCON2(KKJ2)+1
               IEN2 = IBCON2(KKJ2+1)-1
               IF (KKJ2.EQ.NB-1) IEN2=NACT
 2640       CONTINUE
C
 2632          CONTINUE
               IST = IBCON1(KKJ)+1
               IEN = IBCON1(KKJ+1)-1
               IF (KKJ.EQ.NB-2) IEN=NACT
 2630       CONTINUE
C
CFORNOW
         DO JJ=1,NPTST
         DO KK=1,NPTST
         HINT(JJ,KK) = 0.0D+00
         DO II=1,ICOUNT
         HINT(JJ,KK)=HINT(JJ,KK)+(TMP3(II,JJ)*TMP3(II,KK))/TMP4(II,JJ)
         ENDDO
         ENDDO
         ENDDO
C
         DO JJ=1,NPTST
            DO II=1,ICOUNT
               TMP3(II,JJ) = 0.0D+00
               TMP4(II,JJ) = 1.0D+00
            ENDDO
         ENDDO
C
         DO JJ=1,NPTST
            DO KK=1,NPTST
               HPT(JJ,KK) = HPT(JJ,KK) + 2.0D+00*HINT(JJ,KK)
            ENDDO
         ENDDO
C
         ICOUNT = 0
C
C END OF DOUBLE BETA DEXCITATIONS ( IE1<IE2 -> IA1<IA2 )
C
            CALL ADVANC(IBCON1,NB-2,NACT)
 2620    CONTINUE
C
C ******
C END OF LOOP OVER 2ND ORDER BETAS (IA1<IA2 -> IE1<IE2)
C ******
C
         IF (NVAL.EQ.0) GOTO 2701
C ---------------------------------------------------------
C LOOP OVER 1ST ORDER ALPHAS, VAL(IV1) -> EXT(IE1)
C THIS LOOP INCLUDES A LOOP OVER 0TH ORDER ALPHAS, SO WE'LL
C TRY TO PUT IT IN THE MAIN 0TH ORDER ALPHA LOOP, IE, HERE
C ---------------------------------------------------------
C
C I BELIEVE THE BELOW INCLUDES VAL(B) -> EXT(B) ALSO....
C
C *****
C LOOP OVER 0TH ORDER BETA STRINGS
C *****
C
        DO II=1,NB
           IBCON1(II) = II
        ENDDO
        DO 2700 IJB=1,NBLP
           ICAB = ISPB(IJB)
           ISYB = IMUL(ISYV,ISYMB(IJB))
           E0B0 = E0AD
           DO II=1,NB
              E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
           ENDDO
           IF (ISYB.NE.ITAS) GOTO 2698
C
           ITP0 = ICAT + ICAB
           DO III=1,NPTST
              COEFF(III) = CI(ITP0,III)
           ENDDO
C
C SINGLE DEXCITATIONS, ALPHA IE -> IV
C
           ICOUNT = 0
           DO 2710 IV=1,NVAL
              IS1 = IOB(IV)
              E0B0V = E0B0 + EFCK(IV)
C
           DO 2720 IE=1,NEXT
              ICOUNT = ICOUNT + 1
              JE = IE + M1
              IS2 = IOB(JE)
              IF (IS1.NE.IS2) GOTO 2720
C
C MATRIX ELEMENT
C
          CALL ME0VE1B(IV,IE,IACON1,NA,IBCON1,NB,NVAL,
     *    NACT,NEXT,INPT,SI1,SVOOO,M2,T)
          DO III=1,NPTST
             TMP3(ICOUNT,III) = TMP3(ICOUNT,III) + T*COEFF(III)
             TMP4(ICOUNT,III) = E0B0V - EFCK(JE) + EPT0(III)
          ENDDO
C
 2720      CONTINUE
C
 2710      CONTINUE
C
C END OF SINGLE DEXCITATIONS
C
 2698 CONTINUE
C
C NOW FOR DOUBLE DEXCITATIONS
C DOUBLES MUST INCLUDE THE SINGLE ABOVE
C
C 2ND EXCITATION: ALPHA ACT(IA2 -> JJA)
C TOTAL = ALPHA (IE,IA2 -> IV,JJA)
C
           ISYT = ITAB(ISYB)
           ISYL = IMUL(ISYT,ISA1)
C
           DO 2730 IEL2=1,NA
              IA2 = IACON1(IEL2) + NVAL
              IS1 = IOB(IA2)
C
       IST = 1
       IEN = IACON1(1)-1
       DO 2740 KKJ=1,NA+1
          DO 2742 JJ=IST,IEN
             JJA = JJ + NVAL
             IS2 = IOB(JJA)
             IP1 = IMUL(IS1,IS2)
             IF (IP1.NE.ISYL) GOTO 2742
             MA = MAX(IA2,JJA)
             MI = MIN(IA2,JJA)
             IA2A3 = INPT(MA) + MI
C
           CALL RET1DET(IACON1,IACON2,NA,IEL2,JJ,0,KKJ,ISWAP2)
           IPER2 = (-1)**ISWAP2
           IPA2 = POSDET(NACT,NA,IACON2,IFA)
           ITP0 = ISPA(IPA2) + ICAB
           DO III=1,NPTST
              COEFF(III) = CI(ITP0,III)*IPER2
           ENDDO
C
           ICOUNT = 0
           DO 2750 IV=1,NVAL
              IS3 = IOB(IV)
              E0B0V = E0B0 + EFCK(IV)
              IA2V = INPT(IA2) + IV
              IVA2A3 = (IV-1)*M2 + IA2A3
              IA3A2V = (JJA-1)*M2 + IA2V
C
           DO 2760 IE=1,NEXT
              ICOUNT = ICOUNT + 1
              JE = IE + M1
              IS4 = IOB(JE)
              IP2 = IMUL(IS4,IS3)
              IF (IP1.NE.IP2) GOTO 2760
C
C MATRIX ELEMENT
C
         T1 = SVOOO(IE,IVA2A3)
         T2 = SVOOO(IE,IA3A2V)
         TT = T1 - T2
         DO III=1,NPTST
            TMP3(ICOUNT,III) = TMP3(ICOUNT,III) + TT*COEFF(III)
            TMP4(ICOUNT,III) = E0B0V - EFCK(JE) + EPT0(III)
         ENDDO
C
 2760      CONTINUE
 2750      CONTINUE
C
 2742     CONTINUE
          IST = IACON1(KKJ)+1
          IEN = IACON1(KKJ+1)-1
          IF (KKJ.EQ.NA) IEN=NACT
 2740  CONTINUE
C
 2730      CONTINUE
C
C END OF ALPHA ACT (IA2 -> JJA) DEXCITE
C
C 2ND EXCITATION: BETA ACT (IA2 -> JJA)
C TOTAL = ( IE(A),IA2(B) -> IV(A),JJA(B) )
C
           ISYL = IMUL(ITAS,ISYB)
           DO 2770 IEL2=1,NB
              IA2 = IBCON1(IEL2)+NVAL
              IS1 = IOB(IA2)
C
           IST = 1
           IEN = IBCON1(1)-1
           DO 2780 KKJ=1,NB+1
              DO 2782 JJ=IST,IEN
                 JJA = JJ + NVAL
                 IS2 = IOB(JJA)
                 IP1 = IMUL(IS1,IS2)
                 IF (IP1.NE.ISYL) GOTO 2782
C
                 MA = MAX(IA2,JJA)
                 MI = MIN(IA2,JJA)
                 IA2A3 = INPT(MA) + MI
C
          CALL RET1DET(IBCON1,IBCON2,NB,IEL2,JJ,0,KKJ,ISWAP2)
          IPER2 = (-1)**ISWAP2
          IPB2 = POSDET(NACT,NB,IBCON2,IFA)
          ITP0 = ICAT + ISPB(IPB2)
          DO III=1,NPTST
             COEFF(III) = CI(ITP0,III)*IPER2
          ENDDO
C
          ICOUNT = 0
          DO 2785 IV=1,NVAL
             IS3 = IOB(IV)
             IPT = IMUL(IS3,IP1)
             E0B0V = E0B0 + EFCK(IV)
             IA2V = INPT(IA2) + IV
             IVA2A3 = (IV-1)*M2 + IA2A3
C
          DO 2790 IE=1,NEXT
             ICOUNT = ICOUNT + 1
             JE = IE + M1
             IF (IOB(JE).NE.IPT) GOTO 2790
C
C  MATRIX ELEMENT
C
         T1 = SVOOO(IE,IVA2A3)
         DO III=1,NPTST
            TMP3(ICOUNT,III) = TMP3(ICOUNT,III) + T1*COEFF(III)
            TMP4(ICOUNT,III) = E0B0V - EFCK(JE) + EPT0(III)
         ENDDO
C
 2790     CONTINUE
 2785     CONTINUE
C
 2782         CONTINUE
              IST = IBCON1(KKJ)+1
              IEN = IBCON1(KKJ+1)-1
              IF (KKJ.EQ.NB) IEN=NACT
 2780      CONTINUE
C
 2770      CONTINUE
C
C END OF 2ND EXCITATION BETA (IA2 -> JJ)
C
         DO JJ=1,NPTST
         DO KK=1,NPTST
         HINT(JJ,KK) = 0.0D+00
         DO II=1,ICOUNT
         HINT(JJ,KK)=HINT(JJ,KK)+(TMP3(II,JJ)*TMP3(II,KK))/TMP4(II,JJ)
         ENDDO
         ENDDO
         ENDDO
C
         DO JJ=1,NPTST
            DO II=1,ICOUNT
               TMP3(II,JJ) = 0.0D+00
               TMP4(II,JJ) = 1.0D+00
            ENDDO
         ENDDO
C
         DO JJ=1,NPTST
            DO KK=1,NPTST
               HPT(JJ,KK) = HPT(JJ,KK) + 2.0D+00*HINT(JJ,KK)
            ENDDO
         ENDDO
C
         ICOUNT = 0
C
           CALL ADVANC(IBCON1,NB,NACT)
 2700   CONTINUE
 2701 CONTINUE
C
C *****
C END OF LOOP OVER 0TH ORDER BETA STRINGS
C *****
C
C
        CALL DDI_DLBNEXT(MY_TASK)
      END IF     ! MY TASK
C
         CALL ADVANC(IACON1,NA,NACT)
 2000 CONTINUE
C
C END LOOP OVER ZEROTH ORDER ALPHAS
C
C -------------------------------------------
C *******************************************
C -------------------------------------------
C
C LOOP OVER 1ST ORDER ALPHAS, ORBITALS NUMBERED AS ACTIVE, 1,2,etc
C
C --------------------------------------------------
C **************************************************
C --------------------------------------------------
C
      NBUFF=N1A
      IF (NVAL.EQ.0) THEN
         NBUFF=0
         GOTO 3401
      ENDIF
C
C LOOP OVER 1ST ORDER ALPHAS (IV -> IA)
C
C OUTER LOOP OVER 1 UP ALPHAS
C
      DO II=1,NA+1
         IACON1(II) = II
      ENDDO
      E0A0 =  -2*E0V
      ISA0 = ISYV
C
      DO 3400 IJK2=1,N1A
C
        IF (IJK2+NALP-1.EQ.MY_TASK) THEN
C
         ISA1 = ISA0
         E0AD1 = E0A0
         DO II=1,NA+1
            E0AD1 = E0AD1 - EFCK(IACON1(II)+NVAL)
            ISA1 = IMUL(ISA1,IOB(IACON1(II)+NVAL))
         ENDDO
C
C ----------------------------------------------
C NOW TO LOOP OVER 1ST ORDER BETAS IV2 -> IA2
C ----------------------------------------------
C
C LOOP OVER 1 UP BETAS
C
         DO II=1,NB+1
            IBCON1(II) = II
         ENDDO
         DO 3500 IJB=1,N1B
            ISYB = ISYV
            E0B0 = E0AD1
            DO II=1,NB+1
               E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
               ISYB = IMUL(ISYB,IOB(IBCON1(II)+NVAL))
            ENDDO
            ISYT = IMUL(ISYB,ISA1)
            ITAL = ITAB(ISYT)
C
C LOOP OVER ALPHA EXCITE (IA1 -> IV)
C
            DO 3510 IEL1=1,NA+1
               IA1 = IACON1(IEL1) + NVAL
               IS1 = IOB(IA1)
            CALL STR0VA(IACON1,IACON2,NA+1,IEL1,NVAL,NVAL,IPER)
            IPA0 = POSDET(NACT,NA,IACON2,IFA)
            ICAT = ISPA(IPA0)
C
C LOOP OVER BETA EXCITE (IA2 -> IV2)
C
            DO 3520 IEL2=1,NB+1
               IA2 = IBCON1(IEL2) + NVAL
               IS2 = IOB(IA2)
               IP1 = IMUL(IS1,IS2)
               IF (IP1.NE.ITAL) GOTO 3520
            CALL STR0VA(IBCON1,IBCON2,NB+1,IEL2,NVAL,NVAL,IPER2)
            IPERT = IPER*IPER2
            IPB0 = POSDET(NACT,NB,IBCON2,IFA)
            ITP0 = ICAT + ISPB(IPB0)
            DO III=1,NPTST
               COEFF(III) = CI(ITP0,III)*IPERT
            ENDDO
C
C NOW TO LOOP OVER VALENCE ORBITALS
C
            IA1V1 = INPT(IA1)
            IA2VT = INPT(IA2)
            ICOUNT = 0
            DO 3530 IV1=1,NVAL
               IS3 = IOB(IV1)
               IPT = IMUL(IS3,IP1)
               E0BV1 = E0B0 + EFCK(IV1)
               IA1V1 = IA1V1 + 1
               IA2V2 = IA2VT
C
            DO 3540 IV2=1,NVAL
               ICOUNT = ICOUNT + 1
               IA2V2 = IA2V2 + 1
               IF (IOB(IV2).NE.IPT) GOTO 3540
C
           MA = MAX(IA1V1,IA2V2)
           MI = MIN(IA1V1,IA2V2)
           INT1 = (MA*(MA-1))/2 + MI
           T1 = SI2(INT1)
           DO III=1,NPTST
              TMP3(ICOUNT,III) = TMP3(ICOUNT,III) + T1*COEFF(III)
              TMP4(ICOUNT,III) = E0BV1 + EFCK(IV2) + EPT0(III)
           ENDDO
C
 3540       CONTINUE
C
 3530       CONTINUE
C
CEND OF LOOP OVER VALENCE ORBITALS
C
 3520       CONTINUE
C
C END OF BETA EXCITE (IA2 -> IV2)
C
 3510       CONTINUE
C
C END OF ALPHA EXCITE (IA1 -> IV)
C
         DO JJ=1,NPTST
         DO KK=1,NPTST
         HINT(JJ,KK) = 0.0D+00
         DO II=1,ICOUNT
         HINT(JJ,KK)=HINT(JJ,KK)+(TMP3(II,JJ)*TMP3(II,KK))/TMP4(II,JJ)
         ENDDO
         ENDDO
         ENDDO
C
         DO JJ=1,NPTST
            DO II=1,ICOUNT
               TMP3(II,JJ) = 0.0D+00
               TMP4(II,JJ) = 1.0D+00
            ENDDO
         ENDDO
C
         DO JJ=1,NPTST
            DO KK=1,NPTST
               HPT(JJ,KK) = HPT(JJ,KK) + HINT(JJ,KK)
            ENDDO
         ENDDO
C
         ICOUNT = 0
C
            CALL ADVANC(IBCON1,NB+1,NACT)
 3500    CONTINUE
C
C -----------------------------------
C END OF LOOP OVER 1 UP BETAS
C END LOOP OVER 1ST ORDER BETAS IV2 -> IA2
C -----------------------------------
C
C ------------------------------------------
C NOW TO LOOP OVER 1ST ORDER BETAS IA2 -> IE
C ------------------------------------------
C
C LOOP OVER 1 DOWN BETAS
C
         DO II=1,NB-1
            IBCON1(II) = II
         ENDDO
         DO 3700 IJB=1,ND1B
            ISYB = ISYV
            E0BD1 = E0AD1
            DO II=1,NB-1
               E0BD1 = E0BD1 - EFCK(IBCON1(II)+NVAL)
               ISYB = IMUL(ISYB,IOB(IBCON1(II)+NVAL))
            ENDDO
            ISYT = IMUL(ISYB,ISA1)
            ITAL = ITAB(ISYT)
C
C LOOP OVER DEXCITATIONS FROM IA1(A)
C
         DO 3710 IEL=1,NA+1
            IA1 = IACON1(IEL) + NVAL
            IS1 = IOB(IA1)
            CALL STR0VA(IACON1,IACON2,NA+1,IEL,NVAL,NVAL,IPER)
            IPA0 = POSDET(NACT,NA,IACON2,IFA)
            ICAT = ISPA(IPA0)
C
C LOOP OVER EXCITATIONS INTO IA2(B)
C
         IST = 1
         IEN = IBCON1(1)-1
         IF (NB.EQ.1) IEN=NACT
         DO 3720 KKJ=1,NB
            DO 3722 JJ=IST,IEN
               IA2 = JJ + NVAL
               IS2 = IOB(IA2)
               IP1 = IMUL(IS1,IS2)
               IF (IP1.NE.ITAL) GOTO 3722
C
C 0TH ORDER BETA POS/PERM
C
         CALL STR0AE(IBCON1,IBCON2,NB,KKJ,JJ,IPER2)
         IPERT = IPER*IPER2
         IPB0 = POSDET(NACT,NB,IBCON2,IFA)
         ITP0 = ICAT + ISPB(IPB0)
         DO III=1,NPTST
            COEFF(III) = CI(ITP0,III)*IPERT
         ENDDO
C
C LOOP OVER ALPHA VALENCE
C
         ICOUNT = 0
         DO 3730 IV=1,NVAL
            IS3 = IOB(IV)
            IPT = IMUL(IS3,IP1)
            E0BD1V = E0BD1 + EFCK(IV)
            IA1V = INPT(IA1) + IV
            IA2A1V = (IA2-1)*M2 + IA1V
C
C LOOP OVER BETA EXTERNAL
C
         DO 3740 IE=1,NEXT
            ICOUNT = ICOUNT + 1
            JE = IE + M1
            IF (IOB(JE).NE.IPT) GOTO 3740
C
            T1 = SVOOO(IE,IA2A1V)
            DO III=1,NPTST
               TMP3(ICOUNT,III) = TMP3(ICOUNT,III) + T1*COEFF(III)
               TMP4(ICOUNT,III) = E0BD1V - EFCK(JE) + EPT0(III)
            ENDDO
C
 3740    CONTINUE
C
 3730    CONTINUE
C
C END OF ALPHA VALENCE
C
 3722       CONTINUE
            IST = IBCON1(KKJ)+1
            IEN = IBCON1(KKJ+1)-1
            IF (KKJ.EQ.NB-1) IEN=NACT
 3720    CONTINUE
C
C END OF EXCITATIONS INTO EA2(B)
C
 3710    CONTINUE
C
C END OF DEXCITATIONS OUT OF IA1(A), IA2(B)
C
         DO JJ=1,NPTST
         DO KK=1,NPTST
         HINT(JJ,KK) = 0.0D+00
         DO II=1,ICOUNT
         HINT(JJ,KK)=HINT(JJ,KK)+(TMP3(II,JJ)*TMP3(II,KK))/TMP4(II,JJ)
         ENDDO
         ENDDO
         ENDDO
C
         DO JJ=1,NPTST
            DO II=1,ICOUNT
               TMP3(II,JJ) = 0.0D+00
               TMP4(II,JJ) = 1.0D+00
            ENDDO
         ENDDO
C
         DO JJ=1,NPTST
            DO KK=1,NPTST
               HPT(JJ,KK) = HPT(JJ,KK) + 2.0D+00*HINT(JJ,KK)
            ENDDO
         ENDDO
C
         ICOUNT = 0
C
            CALL ADVANC(IBCON1,NB-1,NACT)
 3700    CONTINUE
C
C END OF LOOP OVER 1 DOWN BETAS
C
C ------------------------------------------
C END OF LOOP OVER 1ST ORDER BETAS IA2 -> IE
C ------------------------------------------
C
        CALL DDI_DLBNEXT(MY_TASK)
      END IF     ! MY TASK
C
         CALL ADVANC(IACON1,NA+1,NACT)
 3400 CONTINUE
 3401 CONTINUE
C
C END OF RELOOP OVER 1ST ORDER ALPHAS, VAL (IV) -> ACTIVE
C
C --------------------------------------------------
C **************************************************
C --------------------------------------------------
C
C -------------------------------------------
C *******************************************
C -------------------------------------------
C
C EXPERIMENT, RELOOP OVER ALPHA ACT (IA?)  -> EXTERNAL (IE)
C
         DO II=1,NA-1
            IACON1(II) = II
         ENDDO
C
         DO 5805 IJK3=1,ND1A
C
        IF (IJK3+NALP+NBUFF-1.EQ.MY_TASK) THEN
C
C DETERMINE SYMMETRY OF ALPHA STRING
C
            ISA0 = ISYV
            E0A0 = E0V
            DO II=1,NA-1
               E0A0 = E0A0 + EFCK(IACON1(II)+NVAL)
               ISA0 = IMUL(ISA0,IOB(IACON1(II)+NVAL))
            ENDDO
C
C ---------------
C NOW TO LOOP OVER 1ST ORDER OVER BETA (IA2) -> (IE2)
C ---------------
C
          DO II=1,NB-1
             IBCON1(II) = II
          ENDDO
          DO 5810 IJB=1,IJK3
             ISYB0 = ISYV
             E0B0 = -E0V-E0A0
             DO II=1,NB-1
                E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
                ISYB0 = IMUL(ISYB0,IOB(IBCON1(II)+NVAL))
             ENDDO
C
C NOW TO LOOP OVER ALPHA DEXCITATIONS (IE -> IA)
C
             IST = 1
             IEN = IACON1(1)-1
             IF (NA.EQ.1) IEN=NACT
             DO 5820 KKJ=1,NA
                DO 5822 JJ=IST,IEN
                   IA = JJ + NVAL
                   IS3 = IOB(IA)
                   ISA1 = IMUL(ISA0,IS3)
                   ITAS = ITAB(ISA1)
C
                   CALL STR0AE(IACON1,IACON2,NA,KKJ,JJ,IPER)
                   IPA0 = POSDET(NACT,NA,IACON2,IFA)
                   ICAT = ISPA(IPA0)
C
C NOW TO LOOP OVER BETA DEXCITATIONS (IE2 -> IA2)
C
             IST2 = 1
             IEN2 = IBCON1(1)-1
             IF (NB.EQ.1) IEN2=NACT
             DO 5830 KKJ2=1,NB
                DO 5832 JJ2=IST2,IEN2
                   IA2 = JJ2 + NVAL
                   IS4 = IOB(IA2)
                   ISYB = IMUL(ISYB0,IS4)
                   IF (ISYB.NE.ITAS) GOTO 5832
                   IP2 = IMUL(IS4,IS3)
C
        CALL STR0AE(IBCON1,IBCON2,NB,KKJ2,JJ2,IPER2)
        IPB0 = POSDET(NACT,NB,IBCON2,IFA)
        ITP0 = ICAT + ISPB(IPB0)
        IPERT = IPER*IPER2
        DO III=1,NPTST
           COEFF(III) = CI(ITP0,III)*IPERT
        ENDDO
C
      ICOUNT = 0
      DO 5800 JE=NQS,NQQ
         IS1 = IOB(JE)
         IPT = IMUL(IS1,IP2)
         E0A1 = E0B0 - EFCK(JE)
         IEA = (JE-M1-1)*M1 + IA
         IEAT = INPT(IEA)
         IEA2 = IEA - IA + IA2
         IEA2T = INPT(IEA2)
C
         INT1 = IEAT + IA2 - M1
         INT2 = IEA2T + IA - M1
         DO 5807 JE2=NQS,JE-1
             ICOUNT = ICOUNT + 1
             INT1 = INT1 + M1
             INT2 = INT2 + M1
             IF (IOB(JE2).NE.IPT) GOTO 5807
C
C DETERMINE MATRIX ELEMENT
C
C ME = [IE,IA | IE2,IA2], [IE,IA2 | IE2,IA]
C
        T1 = SVOVO(INT1)
        T2 = SVOVO(INT2)
        DO III=1,NPTST
           TMP1(ICOUNT,III) = TMP1(ICOUNT,III) + T1*COEFF(III)
           TMP3(ICOUNT,III) = TMP3(ICOUNT,III) + T2*COEFF(III)
           TMP4(ICOUNT,III) = E0A1 - EFCK(JE2) + EPT0(III)
        ENDDO
C
 5807 CONTINUE
C
C JE2=JE
C
      ICOUNT = ICOUNT + 1
      IF (IP2.NE.1) GOTO 5800
      MA = MAX(IEA,IEA2)
      MI = MIN(IEA,IEA2)
      INT1 = INPT(MA) + MI
      T1 = SVOVO(INT1)
      DO III=1,NPTST
         TMP1(ICOUNT,III) = TMP1(ICOUNT,III) + T1*COEFF(III)
         TMP4(ICOUNT,III) = E0A1 - EFCK(JE) + EPT0(III)
      ENDDO
C
C END LOOP OVER IE(A),IE2(B)
C
 5800 CONTINUE
C
 5832           CONTINUE
                IST2 = IBCON1(KKJ2)+1
                IEN2 = IBCON1(KKJ2+1)-1
                IF (KKJ2.EQ.NB-1) IEN2=NACT
 5830        CONTINUE
C
C END OF BETA DEXCITATION IE2 -> IA2
C
 5822           CONTINUE
                IST = IACON1(KKJ)+1
                IEN = IACON1(KKJ+1)-1
                IF (KKJ.EQ.NA-1) IEN=NACT
 5820        CONTINUE
C
C END OF ALPHA DEXCITATION IE -> IA
C
       DO JJ=1,NPTST
       DO KK=1,NPTST
       HINT(JJ,KK) = 0.0D+00
       DO II=1,ICOUNT
          HINT(JJ,KK) = HINT(JJ,KK) +
     *   (TMP1(II,JJ)*TMP1(II,KK)+
     *    TMP3(II,JJ)*TMP3(II,KK))/TMP4(II,JJ)
       ENDDO
       ENDDO
       ENDDO
C
       DO JJ=1,NPTST
          DO II=1,ICOUNT
             TMP1(II,JJ) = 0.0D+00
             TMP3(II,JJ) = 0.0D+00
             TMP4(II,JJ) = 1.0D+00
          ENDDO
       ENDDO
C
       ZCOEF=2.0D+00
       IF (IJB.EQ.IJK3) ZCOEF=1.0D+00
       DO JJ=1,NPTST
          DO KK=1,NPTST
             HPT(JJ,KK) = HPT(JJ,KK) + ZCOEF*HINT(JJ,KK)
          ENDDO
       ENDDO
C
       ICOUNT = 0
C
             CALL ADVANC(IBCON1,NB-1,NACT)
 5810     CONTINUE
C
C ------
C END OF LOOP OVER 1-DOWN BETA
C ------
C
        CALL DDI_DLBNEXT(MY_TASK)
      END IF     ! MY TASK
C
            CALL ADVANC(IACON1,NA-1,NACT)
 5805    CONTINUE
C
C END OF LOOP OVER 1-DOWN ALPHA
C
C END OF EXPERIMENT
C
C -------------------------------------------
C *******************************************
C -------------------------------------------
C
         IF (NVAL.EQ.0) THEN
            CALL DDI_DLBRESET
            RETURN
         END IF
C
C ------------------------------------------------------------
C NOW FOR THE FINAL CONTRIBUTION, WHICH IS IV1,IV2 -> IE1,IE2
C AS DAVIDSON ET AL POINTED OUT (J. CHEM. PHYS. 1994,100,3672)
C FOR EACH EXCITATION, THERE IS ONLY ONE VIRTUAL DETERMINANT
C WHICH SIMPLIFIES THINGS INCREDIBLY !!!!!!!!!!!!!!!!!!!!!!!!
C ------------------------------------------------------------
C
C LOOP OVER 0TH ORDER ALPHAS FIRST
C
      DO II=1,NA
         IACON1(II) = II
      ENDDO
      E0A0 = -E0V - E0V
C
      DO 9500 IJK4=1,NALP
C
        IF (IJK4+NALP+NBUFF+ND1A-1.EQ.MY_TASK) THEN
C
         ICIT = ISPA(IJK4)
         ISA0 = ISYMA(IJK4)
         ITAS = ITAB(ISA0)
         E0A2 = E0A0
         DO II=1,NA
            E0A2 = E0A2 - EFCK(IACON1(II)+NVAL)
         ENDDO
C
C LOOP OVER CORRECT 0TH ORDER BETAS
C
         DO II=1,NB
            IBCON1(II)=II
         ENDDO
         ZCOEF = 4.0D+00
         DO 9510 INB1 = 1,IJK4
            IF (ISYMB(INB1).NE.ITAS) GOTO 9509
            IF(INB1.EQ.IJK4) ZCOEF=2.0D+00
C
            E0B0 = E0A2
            DO II=1,NB
               E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
            ENDDO
            ICIT = ICIT + 1
            DO JJ=1,NPTST
               DO KK=1,NPTST
                  TMP1(JJ,KK) = ZCOEF*CI(ICIT,JJ)*CI(ICIT,KK)
                  HINT(JJ,KK) = 0.0D+00
               ENDDO
            ENDDO
C
C LOOP OVER ALL POSSIBLE EXCITATIONS
C
            IE1T = -M1
            DO 9542 JE1=NQS,NQQ
               IS1 = IOB(JE1)
               E0B0E = E0B0 - EFCK(JE1)
               IE1T = IE1T + M1
            DO 9544 IV1=1,NVAL
               IS2 = IOB(IV1)
               IP1 = IMUL(IS1,IS2)
               E0B0EV = E0B0E + EFCK(IV1)
               IE1V1 = IE1T + IV1
C
            IE2T = -M1
            DO 9552 JE2=NQS,JE1-1
               IS3 = IOB(JE2)
               IPT  = IMUL(IS3,IP1)
               E0B0EVE = E0B0EV - EFCK(JE2)
               IE2T = IE2T + M1
               IE2V1 = IE2T + IV1
               INT1T = INPT(IE1V1) + IE2T
            DO 9553 IV2 = 1,IV1-1
               IS4 = IOB(IV2)
               IF (IS4.NE.IPT) GOTO 9553
               E0B0EVEV = E0B0EVE + EFCK(IV2)
               IE1V2 = IE1T + IV2
C
               INT1 = INT1T + IV2
               INT2 = INPT(IE1V2) + IE2V1
               T1 = SVOVO(INT1)
               T2 = SVOVO(INT2)
               TT = T1 - T2
        DO JJ=1,NPTST
        DO KK=1,NPTST
           HINT(JJ,KK)=HINT(JJ,KK) +
     *   (T1*T1 + T2*T2 + TT*TT)/(E0B0EVEV+EPT0(JJ))
        ENDDO
        ENDDO
C
 9553       CONTINUE
C
C IV2 = IV1, JE1>JE2
C
            IF (IS2.NE.IPT) GOTO 9552
            E0B0EVEV = E0B0EVE + EFCK(IV1)
            INT1 = INPT(IE1V1) + IE2V1
            T1 = SVOVO(INT1)
            DO JJ=1,NPTST
            DO KK=1,NPTST
            HINT(JJ,KK)=HINT(JJ,KK) + (T1*T1)/(E0B0EVEV+EPT0(JJ))
            ENDDO
            ENDDO
C
 9552       CONTINUE
C
C NOW FOR JE1=JE2, IV1>IV2
C
            IPT = IMUL(IS1,IP1)
            E0B0EVE = E0B0EV - EFCK(JE1)
            DO 9554 IV2 = 1,IV1-1
               IS4 = IOB(IV2)
               IF (IS4.NE.IPT) GOTO 9554
               E0B0EVEV = E0B0EVE + EFCK(IV2)
               IE1V2 = IE1T + IV2
               INT1 = INPT(IE1V1) + IE1V2
               T1 = SVOVO(INT1)
               DO JJ=1,NPTST
               DO KK=1,NPTST
               HINT(JJ,KK)=HINT(JJ,KK) + (T1*T1)/(E0B0EVEV+EPT0(JJ))
               ENDDO
               ENDDO
C
 9554       CONTINUE
C
C NOW FOR JE1=JE2,IV1=IV2
C
             E0B0EVEV = E0B0EV + EFCK(IV1) - EFCK(JE1)
             INT1 = INPT(IE1V1+1)
             T1 = SVOVO(INT1)
             DO JJ=1,NPTST
             DO KK=1,NPTST
             HINT(JJ,KK)=HINT(JJ,KK) +
     *       0.5D+00*(T1*T1)/(E0B0EVEV+EPT0(JJ))
             ENDDO
             ENDDO
C
 9544       CONTINUE
 9542       CONTINUE
C
         DO JJ=1,NPTST
         DO KK=1,NPTST
            HPT(JJ,KK) = HPT(JJ,KK) + TMP1(JJ,KK)*HINT(JJ,KK)
         ENDDO
         ENDDO
C
C
 9509       CALL ADVANC(IBCON1,NB,NACT)
 9510    CONTINUE
C
C END OF CORRECT 0TH ORDER BETAS
C
        CALL DDI_DLBNEXT(MY_TASK)
      END IF     ! MY TASK
C
         CALL ADVANC(IACON1,NA,NACT)
 9500 CONTINUE
C
C END OF LOOP OVER 0TH ORDER ALPHAS
C
C ----------------------------------------
C END OF ALL VV -> EE EXCITATIONS
C ----------------------------------------
C
      CALL DDI_DLBRESET   ! MMRPT0
      RETURN
      END
C
C*MODULE DEMRPT  *DECK MMRPT
C     ----------------------------------------------------------
      SUBROUTINE MMRPT(SI1,SI2,SVOOO,SVOVO,EFCK,EPT0,CI,
     *             NVAL,NACT,NEXT,NCI,NA,NB,IACON1,IBCON1,
     *             IACON2,IBCON2,
     *             NALP,NBLP,ISYMA,ISYMB,ISPA,ISPB,
     *             NSYM,IMUL,ITAB,IOB,INPT,IFA,
     *             TMP1,TMP2,TMP3,TMP4,NTMPSZ,NPTST,HPT,COEFF,HINT)
C     ----------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      INTEGER POSDET
      DIMENSION SI1(*),SI2(*),SVOOO(NEXT,*),SVOVO(*)
      DIMENSION EFCK(*)
      DIMENSION CI(NCI,NPTST)
      DIMENSION IACON1(NA+2),IBCON1(NA+2)
      DIMENSION IACON2(NA+2),IBCON2(NA+2)
      DIMENSION ISYMA(NALP),ISYMB(NBLP),ISPA(NALP),ISPB(NBLP)
      DIMENSION IMUL(NSYM,NSYM),ITAB(NSYM),IOB(*)
      DIMENSION INPT(*)
      DIMENSION IFA(0:NACT,0:NACT)
      DIMENSION TMP1(NTMPSZ,NPTST),TMP2(NTMPSZ,NPTST)
      DIMENSION TMP3(NTMPSZ,NPTST),TMP4(NTMPSZ,NPTST)
      DIMENSION EPT0(NPTST),HPT(NPTST,NPTST),COEFF(NPTST)
      DIMENSION HINT(NPTST,NPTST)
C
      ICOUNT = 0
      M1 = NVAL+NACT
      M2 = (M1*(M1+1))/2
      NQS = M1 + 1
      NQQ = M1 + NEXT
      DO II=1,NPTST
         DO JJ=1,NPTST
            HPT(II,JJ) = 0.0D+00
         ENDDO
      ENDDO
C
      IF (NA.LT.NACT) THEN
         N1A =  IFA(NACT,NA+1)
      ELSE
         N1A = 0
      ENDIF
      IF (NB.LT.NACT) THEN
         N1B =  IFA(NACT,NB+1)
      ELSE
         N1B = 0
      ENDIF
C
      IF (NA.LT.NACT-1) THEN
         N2A = IFA(NACT,NA+2)
      ELSE
         N2A = 0
      ENDIF
      IF (NB.LT.NACT-1) THEN
         N2B = IFA(NACT,NB+2)
      ELSE
         N2B = 0
      ENDIF
C
      IF (NA.GE.2) THEN
         ND1A = IFA(NACT,NA-1)
      ELSEIF (NA.EQ.1) THEN
         ND1A = 1
      ELSEIF (NA.EQ.0) THEN
         ND1A = 0
      ENDIF
C
      IF (NB.GE.2) THEN
         ND1B = IFA(NACT,NB-1)
      ELSEIF (NB.EQ.1) THEN
         ND1B = 1
      ELSEIF (NB.EQ.0) THEN
         ND1B = 0
      ENDIF
C
      IF (NA.GE.3) THEN
         ND2A = IFA(NACT,NA-2)
      ELSEIF (NA.EQ.2) THEN
         ND2A = 1
      ELSEIF (NA.LE.1) THEN
         ND2A = 0
      ENDIF
C
      IF (NB.GE.3) THEN
         ND2B = IFA(NACT,NB-2)
      ELSEIF(NB.EQ.2) THEN
         ND2B = 1
      ELSEIF(NB.LE.1) THEN
         ND2B = 0
      ENDIF
C
      E0V = 0.0D+00
      ISYV = 1
      DO II=1,NVAL
         E0V = E0V + EFCK(II)
         ISYV = IMUL(ISYV,IOB(II))
      ENDDO
C
C  LOOP OVER ALL POSSIBLE EXCITED DETERMINANTS, LOTS OF DIFFERENT TYPES
C
C ------------------------------------------------------------------
C  FIRST LOOP OVER ZEROTH ORDER ALPHAS, ORBITALS NUMBERED AS ACTIVE,
C  1,2,etc
C ------------------------------------------------------------------
C
      DO II=1,NA
         IACON1(II) = II
      ENDDO
C
      E0AV = E0V
      ISYAV = ISYV
C
      CALL DDI_DLBNEXT(MY_TASK)
C
      DO 2000 IJK=1,NALP
C
        IF (IJK-1.EQ.MY_TASK) THEN
C
         ICAT = ISPA(IJK)
         ISA1 = IMUL(ISYMA(IJK),ISYAV)
         ITAS = ITAB(ISA1)
         E0A0 = E0AV
         DO II=1,NA
            E0A0 = E0A0 + EFCK(IACON1(II)+NVAL)
         ENDDO
         E0AD = -E0A0 - E0V
C
C  LOOP OVER 1ST AND 2ND ORDER BETAS
C
         IF (NVAL.EQ.0) GOTO 2901
C
C -------------------------------------------
C RELOOP OVER 1ST ORDER BETA VAL -> ACTIVE
C -------------------------------------------
C
C LOOP OVER 1 UP BETAS
C
      DO II=1,NB+1
         IBCON1(II) = II
      ENDDO
      DO 2900 IJB=1,N1B
         ISYB = ISYV
         E0B0 = E0AD
         DO II=1,NB+1
            E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
            ISYB = IMUL(ISYB,IOB(IBCON1(II)+NVAL))
         ENDDO
         ISYL = IMUL(ITAS,ISYB)
C
C LOOP OVER SINGLE DEXCITATIONS OUT OF ACTIVE
C
         DO 2910 IEL=1,NB+1
            IA = IBCON1(IEL) + NVAL
            IS1 = IOB(IA)
            IF (IS1.NE.ISYL) GOTO 2910
C
C DETERMINE 0TH ORDER BETA, POS/PERM
C
          CALL STR0VA(IBCON1,IBCON2,NB+1,IEL,NVAL,NVAL,IPER)
          IPB0 = POSDET(NACT,NB,IBCON2,IFA)
          ITP0 = ICAT + ISPB(IPB0)
          DO III=1,NPTST
             COEFF(III) = CI(ITP0,III)*IPER
          ENDDO
C
C LOOP OVER BETA VALENCE
C
          DO 2920 IV=1,NVAL
             IS2 = IOB(IV)
             IF (IS1.NE.IS2) GOTO 2920
C
C MATRIX ELEMENT
C
       CALL ME0VA1B(IV,IA,IBCON2,NB,IACON1,NA,NVAL,INPT,SI1,SI2,T)
C
             DO III=1,NPTST
                TMP3(IV,III) = TMP3(IV,III) + T*COEFF(III)
                TMP4(IV,III) = E0B0 + EFCK(IV) + EPT0(III)
             ENDDO
C
 2920     CONTINUE
C
C END OF LOOP OVER BETA VALENCE
C
 2910    CONTINUE
C
C END OF PURE SINGLE BETA DEXCITATIONS OUT OF ACTIVE
C
C NOW FOR DOUBLE DEXCITATIONS
C  DOUBLE DEXCITATIONS MUST !!!!! INCLUDE THE SINGLES ABOVE !!!!!
C  START WITH THIS TYPE FIRST, IE BETA IA(?) -> IV
C
      DO 2930 IEL=1,NB+1
         IA = IBCON1(IEL)+NVAL
         JA = IA - NVAL
         IS1 = IOB(IA)
         CALL STR0VA(IBCON1,IBCON2,NB+1,IEL,NVAL,NVAL,IPER)
         IPB0 = POSDET(NACT,NB,IBCON2,IFA)
         ICAB = ISPB(IPB0)
C
C  2ND EXCITATION: BETA ACT (IA2 > IA) -> ACT (JJA)
C  TOTAL = BETA ( IA < IA2 -> IV,JJA)
C
         DO 2940 IEL2=IEL,NB
            IA2 = IBCON2(IEL2)+NVAL
            IS2 = IOB(IA2)
            IP1 = IMUL(IS1,IS2)
C
         IST = 1
         IEN = IBCON2(1)-1
         DO 2950 KKJ=1,NB+1
            DO 2952 JJ=IST,IEN
               IF (JJ.EQ.JA) GOTO 2952
               JJA = JJ + NVAL
               IS3 = IOB(JJA)
               IPT = IMUL(IS3,IP1)
               IF (IPT.NE.ISYL) GOTO 2952
C
               MA = MAX(IA2,JJA)
               MI = MIN(IA2,JJA)
               IA3A2 = INPT(MA) + MI
               MA = MAX(IA,JJA)
               MI = MIN(IA,JJA)
               IA3A = INPT(MA) + MI
C
C DETERMINE NEW 0TH ORDER BETA, POS/PERM AND MATRIX ELEMENT
C
          CALL RET1DET(IBCON2,IACON2,NB,IEL2,JJ,0,KKJ,ISWAP2)
          IPER2 = (-1)**ISWAP2
          IPERT = IPER*IPER2
          IPB2 = POSDET(NACT,NB,IACON2,IFA)
          ITP0 = ICAT + ISPB(IPB2)
          DO III=1,NPTST
             COEFF(III) = CI(ITP0,III)*IPERT
          ENDDO
C
C LOOP OVER BETA VALENCE
C
          DO 2960 IV=1,NVAL
             IS4 = IOB(IV)
             IP2 = IMUL(IS4,IS3)
             IF (IP1.NE.IP2) GOTO 2960
             DO III=1,NPTST
                TMP4(IV,III) = E0B0 + EFCK(IV) + EPT0(III)
             ENDDO
C
C MATRIX ELEMENT
C
         IAV = INPT(IA) + IV
         IA2V = INPT(IA2) + IV
         INT1 = INPT(IA3A2) + IAV
         MA = MAX(IA3A,IA2V)
         MI = MIN(IA3A,IA2V)
         INT2 = INPT(MA) + MI
         T = SI2(INT1) - SI2(INT2)
         DO III=1,NPTST
            TMP3(IV,III) = TMP3(IV,III) + T*COEFF(III)
         ENDDO
C
 2960     CONTINUE
C
C END OF LOOP OVER BETA VALENCE
C
 2952       CONTINUE
            IST = IBCON2(KKJ)+1
            IEN = IBCON2(KKJ+1)-1
            IF (KKJ.EQ.NB) IEN=NACT
 2950    CONTINUE
C
 2940    CONTINUE
C
C END OF 2ND DEXCITATIONS
C
C  NOW FOR 2ND EXCITATION: ALPHA ACT (IA2) -> ACT (JJA)
C  TOTAL = ( IA(B),IA2(A) -> IV(B),JJA(A) )
C
      DO 2970 IEL2=1,NA
         IA2 = IACON1(IEL2)+NVAL
         IS2 = IOB(IA2)
         IP1 = IMUL(IS1,IS2)
C
         IST = 1
         IEN = IACON1(1)-1
         DO 2980 KKJ=1,NA+1
            DO 2982 JJ=IST,IEN
               JJA = JJ + NVAL
               IS3 = IOB(JJA)
               IPT = IMUL(IP1,IS3)
               IF (IPT.NE.ISYL) GOTO 2982
C
          MA = MAX(IA2,JJA)
          MI = MIN(IA2,JJA)
          IA3A2 = INPT(MA) + MI
C
C DETERMINE NEW 0TH ORDER ALPHA, POS/PERM AND MATRIX ELEMENT
C
          CALL RET1DET(IACON1,IACON2,NA,IEL2,JJ,0,KKJ,ISWAP2)
          IPER2 = (-1)**ISWAP2
          IPERT = IPER*IPER2
          IPA2 = POSDET(NACT,NA,IACON2,IFA)
          ITP0 = ISPA(IPA2) + ICAB
          DO III=1,NPTST
             COEFF(III) = CI(ITP0,III)*IPERT
          ENDDO
C
C LOOP OVER BETA VALENCE
C
          DO 2990 IV=1,NVAL
             IS4 = IOB(IV)
             IP2 = IMUL(IS4,IS3)
             IF (IP1.NE.IP2) GOTO 2990
             DO III=1,NPTST
                TMP4(IV,III) = E0B0 + EFCK(IV) + EPT0(III)
             ENDDO
C
C MATRIX ELEMENT
C
         IAV = INPT(IA) + IV
         MA = MAX(IA3A2,IAV)
         MI = MIN(IA3A2,IAV)
         INT = INPT(MA) + MI
         T = SI2(INT)
         DO III=1,NPTST
            TMP3(IV,III) = TMP3(IV,III) + T*COEFF(III)
         ENDDO
C
 2990     CONTINUE
C
C END OF LOOP OVER BETA VALENCE
C
 2982       CONTINUE
            IST = IACON1(KKJ)+1
            IEN = IACON1(KKJ+1)-1
            IF (KKJ.EQ.NA) IEN=NACT
 2980    CONTINUE
C
 2970 CONTINUE
C
C END OF 2ND EXCITATION: ALPHA ACT (IA2) -> ACT (JJA)
C
 2930 CONTINUE
C
C END OF SINGLE DEXCITES IA -> IV
C
       DO JJ=1,NPTST
       DO KK=1,NPTST
       DO II=1,NVAL
       HPT(JJ,KK)=HPT(JJ,KK)+(TMP3(II,JJ)*TMP3(II,KK))/TMP4(II,JJ)
       ENDDO
       ENDDO
       ENDDO
C
       DO JJ=1,NPTST
          DO II=1,NVAL
             TMP3(II,JJ) = 0.0D+00
             TMP4(II,JJ) = 1.0D+00
          ENDDO
       ENDDO
C
         CALL ADVANC(IBCON1,NB+1,NACT)
 2900 CONTINUE
 2901 CONTINUE
C
C END OF LOOP OVER 1 UP BETAS
C
C -------------------------------------------
C END OF RELOOP OVER 1ST ORDER BETA VAL -> ACTIVE
C -------------------------------------------
C
C --------------------------------------------
C 1ST ORDER BETA ACT -> EXTERNAL (IA(?) -> IE)
C --------------------------------------------
C
C  LOOP OVER DOWN 1 BETAS FIRST
C
            DO II=1,NB-1
               IBCON1(II) = II
            ENDDO
            DO 2230 IJB=1,ND1B
              ISYB1 = ISYV
              E0B0 = E0AD
              DO II=1,NB-1
                 ISYB1 = IMUL(ISYB1,IOB(IBCON1(II)+NVAL))
                 E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
              ENDDO
              ISYL = IMUL(ISYB1,ITAS)
C
C SINGLE DEXCITATIONS, BETA IE -> IA (?)
C
              IST = 1
              IEN = IBCON1(1)-1
              IF (NB.EQ.1) IEN=NACT
              DO 2240 KKJ=1,NB
              DO 2242 JJ=IST,IEN
                 JJE = JJ + NVAL
                 IS2 = IOB(JJE)
                 IF (IS2.NE.ISYL) GOTO 2242
C
C DETERMINE 0TH ORDER BETA STRING, POSITION/PERM AND MATRIX ELEMENT
C
          CALL STR0AE(IBCON1,IBCON2,NB,KKJ,JJ,IPER)
          IPB0 = POSDET(NACT,NB,IBCON2,IFA)
          ITP0 = ICAT + ISPB(IPB0)
          DO III=1,NPTST
             COEFF(III) = CI(ITP0,III)*IPER
          ENDDO
C
C LOOP OVER EXTERNAL ORBS
C
         DO 2215 IE=1,NEXT
            JE = IE + M1
            IS1 = IOB(JE)
            IF (IS1.NE.IS2) GOTO 2215
            DO III=1,NPTST
               TMP4(IE,III) = E0B0 - EFCK(JE) + EPT0(III)
            ENDDO
C
          CALL ME0AE1B(JJE,IE,IBCON1,NB,IACON1,NA,NVAL,NACT,NEXT,
     *    INPT,SI1,SVOOO,M2,T)
C
          DO III=1,NPTST
             TMP3(IE,III) = TMP3(IE,III) + COEFF(III)*T
          ENDDO
C
 2215    CONTINUE
C
 2242         CONTINUE
              IST = IBCON1(KKJ)+1
              IEN = IBCON1(KKJ+1)-1
              IF (KKJ.EQ.NB-1) IEN=NACT
 2240         CONTINUE
C
C NOW FOR DOUBLE DEXCITATIONS
C  DOUBLE DEXCITATIONS MUST !!!!! INCLUDE THE SINGLES ABOVE !!!!!
C  START WITH THIS TYPE FIRST, IE BETA IE -> IA(?)
C
              IST = 1
              IEN = IBCON1(1)-1
              IF (NB.EQ.1) IEN=NACT
              DO 2250 KKJ=1,NB
              DO 2252 JJ=IST,IEN
                 IA = JJ + NVAL
                 IS1 = IOB(IA)
                 CALL STR0AE(IBCON1,IBCON2,NB,KKJ,JJ,IPER)
                 IPB0 = POSDET(NACT,NB,IBCON2,IFA)
                 ICAB = ISPB(IPB0)
C
C 2ND EXCITATION: BETA ACT (IA2.NE.IA) -> ACT (JJA > IA)
C  TOTAL = BETA (IE,IA2 -> IA < JJA )
C
                 DO 2255 IEL=1,NB
                    IF (IEL.EQ.KKJ) GOTO 2255
                    IA2 = IBCON2(IEL)+NVAL
                    IS2 = IOB(IA2)
                    IP1 = IMUL(IS1,IS2)
C
C  HAVE ENSURED THAT IA2.NE.IA, NOW TO ENSURE THAT JJA > IA
C
                 IST2=JJ+1
                 IEN2=IEN
                 DO 2258 KKJ2=KKJ+1,NB+1
                 DO 2257 JJ2=IST2,IEN2
                    JJA = JJ2 + NVAL
                    IS3 = IOB(JJA)
                    IPT = IMUL(IP1,IS3)
                    IF (IPT.NE.ISYL) GOTO 2257
C
C  DETERMINE NEW 0TH ORDER BETA, POS/PERM AND MATRIX ELEMENT
C
              CALL RET1DET(IBCON2,IACON2,NB,IEL,JJ2,0,KKJ2,ISWAP2)
              IPER2 = (-1)**ISWAP2
              IPERT = IPER*IPER2
              IPB2 = POSDET(NACT,NB,IACON2,IFA)
              ITP0 = ICAT + ISPB(IPB2)
              DO III=1,NPTST
                 COEFF(III) = CI(ITP0,III)*IPERT
              ENDDO
C
              MA = MAX(IA,IA2)
              MI = MIN(IA,IA2)
              IAA2 = INPT(MA) + MI
              MA = MAX(IA2,JJA)
              MI = MIN(IA2,JJA)
              IA2A3 = INPT(MA) + MI
              IAA2A3 = (IA-1)*M2 + IA2A3
              IA3AA2 = (JJA-1)*M2 + IAA2
C
      DO 2217 IE=1,NEXT
         JE = IE + M1
         IS4 = IOB(JE)
         IP2 = IMUL(IS4,IS3)
         IF (IP1.NE.IP2) GOTO 2217
         DO III=1,NPTST
            TMP4(IE,III) = E0B0 - EFCK(JE) + EPT0(III)
         ENDDO
C
C  ME = [IE,IA | IA2,JJA] - [IE,JJA | IA2,IA]
C
              T = SVOOO(IE,IAA2A3) - SVOOO(IE,IA3AA2)
C
              DO III=1,NPTST
                 TMP3(IE,III) = TMP3(IE,III) + COEFF(III)*T
              ENDDO
C
 2217 CONTINUE
C
 2257            CONTINUE
                 IST2 = IBCON2(KKJ2)+1
                 IEN2 = IBCON2(KKJ2+1)-1
                 IF (KKJ2.EQ.NB) IEN2=NACT
 2258            CONTINUE
C
 2255            CONTINUE
C
C END OF 2ND EXCITATION: BETA ACT (IA2 -> JJA)
C
C 2ND EXCITATION: ALPHA ACT (IA2 -> JJA)
C  TOTAL = ( IE(B),IA2(A) -> IA(B),JJA(A) )
C
                 DO 2260 IEL2=1,NA
                    IA2 = IACON1(IEL2)+NVAL
                    IS2 = IOB(IA2)
                    IP1 = IMUL(IS1,IS2)
C
                 IST2 = 1
                 IEN2 = IACON1(1)-1
                 DO 2268 KKJ2=1,NA+1
                    DO 2267 JJ2=IST2,IEN2
                       JJA = JJ2 + NVAL
                       IS3 = IOB(JJA)
                       IPT = IMUL(IP1,IS3)
                       IF (IPT.NE.ISYL) GOTO 2267
C
C DETERMINE NEW 0TH ORDER ALPHA, POS/PERM AND MATRIX ELEMENT
C
            CALL RET1DET(IACON1,IACON2,NA,IEL2,JJ2,0,KKJ2,ISWAP2)
            IPER2 = (-1)**ISWAP2
            IPERT = IPER*IPER2
            IPA2 = POSDET(NACT,NA,IACON2,IFA)
            ITP0 = ISPA(IPA2) + ICAB
            DO III=1,NPTST
               COEFF(III) = CI(ITP0,III)*IPERT
            ENDDO
C
            MA = MAX(IA2,JJA)
            MI = MIN(IA2,JJA)
            IA2A3 = INPT(MA) + MI
            IAA2A3 = (IA-1)*M2 + IA2A3
C
      DO 2219 IE=1,NEXT
         JE = IE+M1
         IS4 = IOB(JE)
         IP2 = IMUL(IS4,IS3)
         IF (IP1.NE.IP2) GOTO 2219
         DO III=1,NPTST
            TMP4(IE,III) = E0B0 - EFCK(JE) + EPT0(III)
         ENDDO
C
C ME = [IE,IA | IA2,JJA]
C
            T = SVOOO(IE,IAA2A3)
            DO III=1,NPTST
               TMP3(IE,III) = TMP3(IE,III) + COEFF(III)*T
            ENDDO
C
 2219 CONTINUE
C
 2267               CONTINUE
                    IST2 = IACON1(KKJ2)+1
                    IEN2 = IACON1(KKJ2+1)-1
                    IF (KKJ2.EQ.NA) IEN2=NACT
 2268            CONTINUE
C
 2260            CONTINUE
C
C END OF 2ND EXCITATION: ALPHA ACT (IA2 -> JJA)
C
 2252         CONTINUE
              IST = IBCON1(KKJ)+1
              IEN = IBCON1(KKJ+1)-1
              IF (KKJ.EQ.NB-1) IEN=NACT
 2250         CONTINUE
C
C END OF 1ST EXCITATION BETA IE -> IA(?)
C
       DO JJ=1,NPTST
       DO KK=1,NPTST
       DO II=1,NEXT
       HPT(JJ,KK)=HPT(JJ,KK)+(TMP3(II,JJ)*TMP3(II,KK))/TMP4(II,JJ)
       ENDDO
       ENDDO
       ENDDO
C
       DO JJ=1,NPTST
          DO II=1,NEXT
             TMP3(II,JJ) = 0.0D+00
             TMP4(II,JJ) = 1.0D+00
          ENDDO
       ENDDO
C
              CALL ADVANC(IBCON1,NB-1,NACT)
 2230      CONTINUE
C
C -----------------------------------------
C  END OF 1ST ORDER BETA ACT -> EXTERNAL
C -----------------------------------------
C
           IF (NVAL.EQ.0) GOTO 2101
C
C ----------------------------------------------------
C RELOOP LOOP OVER 2ND ORDER BETAS, IV1,IV2 -> IA1,IA2
C ----------------------------------------------------
C
C LOOP OVER 2 UP BETAS
C
      DO II=1,NB+2
         IBCON1(II) = II
      ENDDO
      DO 2100 IJB=1,N2B
         ISYB = ISYV
         E0B0 = E0AD
         DO II=1,NB+2
            ISYB = IMUL(ISYB,IOB(IBCON1(II)+NVAL))
            E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
         ENDDO
         ISYL = IMUL(ISYB,ITAS)
C
C LOOP OVER DEXCITATIONS FROM BETA ACTIVE IA1 < IA2
C
         DO 2110 IEL1=1,NB+2
            IA1 = IBCON1(IEL1)+NVAL
            IS1 = IOB(IA1)
            IA1T = INPT(IA1)
C
         DO 2120 IEL2=IEL1+1,NB+2
            IA2 = IBCON1(IEL2)+NVAL
            IS2 = IOB(IA2)
            IP1 = IMUL(IS1,IS2)
            IF (IP1.NE.ISYL) GOTO 2120
            IA2T = INPT(IA2)
C
      CALL STR0VVAA(IBCON1,IBCON2,NB+2,IEL1,IEL2,NVAL,
     *     NVAL,NVAL,IPER)
      IPB0 = POSDET(NACT,NB,IBCON2,IFA)
      ITP0 = ICAT + ISPB(IPB0)
      DO III=1,NPTST
         COEFF(III) = CI(ITP0,III)*IPER
      ENDDO
C
C LOOP OVER BETA VALENCE IV1 < IV2
C
         ICOUNT = 0
         DO 2130 IV1=1,NVAL
            IS3 = IOB(IV1)
            E0B0V = E0B0 + EFCK(IV1)
            IA1V1 = INPT(IA1) + IV1
            IA2V1 = INPT(IA2) + IV1
            IA2V1T = INPT(IA2V1)
C
         DO 2140 IV2=1,IV1-1
            ICOUNT = ICOUNT + 1
            IS4 = IOB(IV2)
            IP2 = IMUL(IS4,IS3)
            IF (IP1.NE.IP2) GOTO 2140
            DO III=1,NPTST
               TMP4(ICOUNT,III) = E0B0V + EFCK(IV2) + EPT0(III)
            ENDDO
C
C MATRIX ELEMENT
C
            IA1V2 = IA1T + IV2
            IA2V2 = IA2T + IV2
            INT1 = INPT(IA2V2) + IA1V1
            INT2 = IA2V1T + IA1V2
            T = SI2(INT1) - SI2(INT2)
            DO III=1,NPTST
               TMP3(ICOUNT,III) = TMP3(ICOUNT,III) + T*COEFF(III)
            ENDDO
C
 2140    CONTINUE
 2130    CONTINUE
C
C END OF LOOP OVER BETA VALENCE IV1 < IV2
C
 2120    CONTINUE
 2110    CONTINUE
C
C END OF DOUBLE BETA DEXCITATIONS FROM ACTIVE IA1 < IA2
C
       DO JJ=1,NPTST
       DO KK=1,NPTST
       DO II=1,ICOUNT
       HPT(JJ,KK)=HPT(JJ,KK)+(TMP3(II,JJ)*TMP3(II,KK))/TMP4(II,JJ)
       ENDDO
       ENDDO
       ENDDO
C
       DO JJ=1,NPTST
          DO II=1,ICOUNT
             TMP3(II,JJ) = 0.0D+00
             TMP4(II,JJ) = 1.0D+00
          ENDDO
       ENDDO
C
         ICOUNT = 0
C
         CALL ADVANC(IBCON1,NB+2,NACT)
 2100 CONTINUE
C
C END OF LOOP OVER 2 UP BETAS
C
C ----------------------------------------------------
C END RELOOP LOOP OVER 2ND ORDER BETAS, IV1,IV2 -> IA1,IA2
C ----------------------------------------------------
C
C ----------------------------------------------------
C RELOOP OVER 2ND ORDER BETAS, IV1,IV2 -> IA2,IE
C ----------------------------------------------------
C THESE INCLUDE ALSO IV1(A)<IV2(B) -> IA2(B),IE(A)
C                    IV1(A)=IV2(B) -> IA2(B),IE(A)
C                    IV1(A)>IV2(B) -> IA2(B),IE(A)
C ***
C
C LOOP OVER 1 UP BETAS
C
         DO II=1,NB+1
            IBCON1(II) = II
         ENDDO
         DO 2810 IJB=1,N1B
            ISYB=ISYV
            E0B0 = E0AD
            DO II=1,NB+1
               E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
               ISYB = IMUL(ISYB,IOB(IBCON1(II)+NVAL))
            ENDDO
            ISYL = IMUL(ITAS,ISYB)
C
C DOUBLE EXCITATIONS MUST INCLUDE ALPHA IE -> IV SPECIFIED ABOVE
C SECOND EXCITATION BETA (IA2 -> IV2)
C TOTAL = ( IE(A),IA2(B) -> IV(A),IV2(B) )
C
            DO 2820 IEL=1,NB+1
               IA2 = IBCON1(IEL)+NVAL
               IS1 = IOB(IA2)
               IF (IS1.NE.ISYL) GOTO 2820
C
C DETERMINE NEW 0TH ORDER BETA, POS/PERM
C
        CALL STR0VA(IBCON1,IBCON2,NB+1,IEL,NVAL,NVAL,IPER)
        IPB0 = POSDET(NACT,NB,IBCON2,IFA)
        ITP0 = ICAT + ISPB(IPB0)
        DO III=1,NPTST
           COEFF(III) = CI(ITP0,III)*IPER
        ENDDO
C
C LOOP OVER BETA VALENCE
C
        ICOUNT = 0
        DO 2830 IV1=1,NVAL
           IS2 = IOB(IV1)
           IP1 = IMUL(IS1,IS2)
           E0BV = E0B0 + EFCK(IV1)
           IA2V1 = INPT(IA2) + IV1
C
C LOOP OVER ALPHA VALENCE AND EXTERNAL
C
        DO 2840 IV2=1,IV1-1
           IS3 = IOB(IV2)
           E0BVV = E0BV + EFCK(IV2)
           IA2V2 = INPT(IA2) + IV2
           IV2A2V1 = (IV2-1)*M2 + IA2V1
           IV1A2V2 = (IV1-1)*M2 + IA2V2
C
        DO 2850 IE=1,NEXT
           JE = IE + M1
           IS4 = IOB(JE)
           IP2 = IMUL(IS4,IS3)
           IF (IP1.NE.IP2) GOTO 2850
           ICOUNT = ICOUNT + 1
           DO III=1,NPTST
              TMP4(ICOUNT,III) = E0BVV - EFCK(JE) + EPT0(III)
           ENDDO
C
       T1 = SVOOO(IE,IV2A2V1)
       T2 = SVOOO(IE,IV1A2V2)
       TT = T1 - T2
       DO III=1,NPTST
          TMP3(ICOUNT,III) = TMP3(ICOUNT,III) + T1*COEFF(III)
          TMP1(ICOUNT,III) = TMP1(ICOUNT,III) + T2*COEFF(III)
          TMP2(ICOUNT,III) = TMP2(ICOUNT,III) + TT*COEFF(III)
       ENDDO
C
 2850   CONTINUE
 2840   CONTINUE
C
C FOR IV2.EQ.IV1
C
           IS3 = IOB(IV1)
           E0BVV = E0BV + EFCK(IV1)
           IV2A2V1 = (IV1-1)*M2 + IA2V1
           DO 2870 IE=1,NEXT
              JE = IE + M1
              IS4 = IOB(JE)
              IP2 = IMUL(IS4,IS3)
              IF (IP1.NE.IP2) GOTO 2870
              ICOUNT = ICOUNT + 1
              DO III=1,NPTST
                 TMP4(ICOUNT,III) = E0BVV - EFCK(JE) + EPT0(III)
              ENDDO
C
       T1 = SVOOO(IE,IV2A2V1)
       DO III=1,NPTST
          TMP3(ICOUNT,III) = TMP3(ICOUNT,III) + T1*COEFF(III)
       ENDDO
C
 2870 CONTINUE
C
C END OF IV2.GE.IV1
C
 2830   CONTINUE
C
 2820       CONTINUE
C
C END OF DOUBLE DEXCITATIONS
C
         DO JJ=1,NPTST
         DO KK=1,NPTST
         DO II=1,ICOUNT
            HPT(JJ,KK) = HPT(JJ,KK) + (TMP3(II,JJ)*TMP3(II,KK)+
     *  TMP1(II,JJ)*TMP1(II,KK)+
     *  TMP2(II,JJ)*TMP2(II,KK))/TMP4(II,JJ)
         ENDDO
         ENDDO
         ENDDO
C
         DO JJ=1,NPTST
            DO II=1,ICOUNT
               TMP1(II,JJ) = 0.0D+00
               TMP2(II,JJ) = 0.0D+00
               TMP3(II,JJ) = 0.0D+00
               TMP4(II,JJ) = 1.0D+00
            ENDDO
         ENDDO
C
         ICOUNT = 0
C
            CALL ADVANC(IBCON1,NB+1,NACT)
 2810    CONTINUE
C
C ----------------------------------------------------
C END RELOOP OVER 2ND ORDER BETAS, IV1,IV2 -> IA1,IE
C ----------------------------------------------------
C
C ----------------------------------------------------
C LOOP OVER 2ND ORDER BETAS ( IV,IA -> IE1<IE2 )
C ----------------------------------------------------
C THESE EXCITATIONS ALSO INCLUDE IV(A),IA(B) -> IE1(A)<IE2(B)
C AND                            IV(A),IA(B) -> IE1(B)<IE2(A)
C AND                            IV(A),IA(B) -> IE1(A),IE1(B)
C
C LOOP OVER 1 DOWN BETAS
C
         IF (NVAL.EQ.0) GOTO 2531
         DO II=1,NB-1
            IBCON1(II) = II
         ENDDO
         DO 2530 IJB=1,ND1B
            ISYB0 = ISYV
            E0B0 = E0V
            DO II=1,NB-1
               E0B0 = E0B0 + EFCK(IBCON1(II)+NVAL)
               ISYB0 = IMUL(ISYB0,IOB(IBCON1(II)+NVAL))
            ENDDO
            IMS = IMUL(ISYB0,ITAS)
            E0B1 = -E0B0-E0A0
C
C LOOP OVER DEXCITATIONS INTO ACTIVE (IE2 -> IA)
C
            IST = 1
            IEN = IBCON1(1)-1
            IF (NB.EQ.1) IEN=NACT
            DO 2540 KKJ=1,NB
               DO 2542 JJ=IST,IEN
                  IA = JJ + NVAL
                  IS3 = IOB(IA)
                  IF (IS3.NE.IMS) GOTO 2542
C
C DETERMINE 0TH ORDER BETA STRING, POS/PERM
C
       CALL STR0AE(IBCON1,IBCON2,NB,KKJ,JJ,IPER2)
       IPB0 = POSDET(NACT,NB,IBCON2,IFA)
       ITP0 = ICAT + ISPB(IPB0)
       DO III=1,NPTST
          COEFF(III) = CI(ITP0,III)*IPER2
       ENDDO
C
C LOOP OVER DOUBLE BETA DEXCITATIONS ( IE1<IE2 -> IV,IA )
C
         ICOUNT = 0
         JDV = 0
         JDA = -M1 + IA
         DO 2500 JE1=NQS,NQQ
            IS1 = IOB(JE1)
            IP2 = IMUL(IS3,IS1)
            E0BE = E0B1 - EFCK(JE1)
            JDA = JDA + M1
            JDAV = (JDA*(JDA-1))/2
            JDAT = JDAV
            JDVT = (JDV*(JDV-1))/2 + IA
C
         DO 2510 IV=1,NVAL
            IS2 = IOB(IV)
            IPT = IMUL(IS2,IP2)
            E0BEV = E0BE + EFCK(IV)
            JDAT = JDAT + 1
            JDV = JDV + 1
            JDVT = JDVT + JDV - 1
C
         INT1 = -M1 + JDVT
         INT2 = -M1 + JDAT
         DO 2520 JE2=NQS,JE1-1
            INT1 = INT1 + M1
            INT2 = INT2 + M1
            IF (IOB(JE2).NE.IPT) GOTO 2520
C
            ICOUNT = ICOUNT + 1
            DO III=1,NPTST
               TMP4(ICOUNT,III) = E0BEV-EFCK(JE2) + EPT0(III)
            ENDDO
C
C DETERMINE MATRIX ELEMENT
C
C ME = [IE1,IV | IE2,IA] - [IE1,IA | IE2,IV]
C
       T1 = SVOVO(INT1)
       T2 = SVOVO(INT2)
       TT = T1 - T2
C
       DO III=1,NPTST
          TMP1(ICOUNT,III) = TMP1(ICOUNT,III) + T1*COEFF(III)
          TMP2(ICOUNT,III) = TMP2(ICOUNT,III) + T2*COEFF(III)
          TMP3(ICOUNT,III) = TMP3(ICOUNT,III) + TT*COEFF(III)
       ENDDO
C
 2520    CONTINUE
C
C IE1 = IE2
C
         IF (IS3.NE.IS2) GOTO 2510
         ICOUNT = ICOUNT + 1
         DO III=1,NPTST
            TMP4(ICOUNT,III) = E0BEV-EFCK(JE1)+EPT0(III)
         ENDDO
         INT2 = INT2 + M1
         T1 = SVOVO(INT2)
         DO III=1,NPTST
            TMP1(ICOUNT,III) = TMP1(ICOUNT,III) + T1*COEFF(III)
         ENDDO
C
 2510    CONTINUE
         JDV = JDV + NACT
 2500    CONTINUE
C
C END OF DOUBLE BETA DEXCITATIONS ( IE1<IE2 -> IV,IA )
C
 2542          CONTINUE
               IST = IBCON1(KKJ)+1
               IEN = IBCON1(KKJ+1)-1
               IF (KKJ.EQ.NB-1) IEN=NACT
 2540       CONTINUE
C
C END OF EXCITATION INTO BETA ACTIVE
C
CFORNOW
C
       DO JJ=1,NPTST
       DO KK=1,NPTST
       DO II=1,ICOUNT
          HPT(JJ,KK) = HPT(JJ,KK) +
     *    (TMP1(II,JJ)*TMP1(II,KK)+
     *     TMP2(II,JJ)*TMP2(II,KK)+
     *     TMP3(II,JJ)*TMP3(II,KK))/TMP4(II,JJ)
       ENDDO
       ENDDO
       ENDDO
C
       DO JJ=1,NPTST
          DO II=1,ICOUNT
             TMP1(II,JJ) = 0.0D+00
             TMP2(II,JJ) = 0.0D+00
             TMP3(II,JJ) = 0.0D+00
             TMP4(II,JJ) = 1.0D+00
          ENDDO
       ENDDO
C
       ICOUNT = 0
C
            CALL ADVANC(IBCON1,NB-1,NACT)
 2530    CONTINUE
 2531    CONTINUE
C
C END OF 1 DOWN BETAS
C
C ------------------------------------------------
C END OF LOOP OVER 2ND ORDER BETAS (IV,IA -> IE1,IE2)
C ------------------------------------------------
C
 2101 CONTINUE
C
C ------------------------------------------------
C LOOP OVER 2ND ORDER BETAS (IA1<IA2 -> IE1<IE2)
C ------------------------------------------------
C
         DO II=1,NB-2
            IBCON1(II) = II
         ENDDO
         DO 2620 IJB=1,ND2B
            E0B0 = -E0V-E0A0
            ISB0 = ISYV
            DO II=1,NB-2
               E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
               ISB0 = IMUL(ISB0,IOB(IBCON1(II)+NVAL))
            ENDDO
C
C LOOP OVER DOUBLE BETA DEXCITATIONS ( IE1<IE2 -> IA1<IA2 )
C
            IST = 1
            IEN = IBCON1(1)-1
            IF (NB.EQ.2) IEN=NACT
            DO 2630 KKJ=1,NB-1
               DO 2632 JJ=IST,IEN
                  IA1 = JJ + NVAL
                  IS3 = IOB(IA1)
                  ISYBE1 = IMUL(ISB0,IS3)
                  CALL STR0AE(IBCON1,IBCON2,NB-1,KKJ,JJ,IPER)
C
            IST2 = JJ+1
            IEN2 = IEN
            DO 2640 KKJ2=KKJ+1,NB
               DO 2642 JJ2=IST2,IEN2
                  IA2 = JJ2 + NVAL
                  IS4 = IOB(IA2)
                  ISYBE2 = IMUL(ISYBE1,IS4)
                  IF (ISYBE2.NE.ITAS) GOTO 2642
                  IP2 = IMUL(IS4,IS3)
C
C DETERMINE NEW 0TH ORDER BETA, POS/PERM AND MATRIX ELEMENT
C
         CALL STR0AE(IBCON2,IACON2,NB,KKJ2,JJ2,IPER2)
         IPERT = IPER*IPER2
         IPB0 = POSDET(NACT,NB,IACON2,IFA)
         ITP0 = ICAT + ISPB(IPB0)
         DO III=1,NPTST
            COEFF(III) = CI(ITP0,III)*IPERT
         ENDDO
C
C LOOP OVER EXTERNAL ORBITALS
C
         ICOUNT = 0
         DO 2600 JE1=NQS,NQQ
            IS1 = IOB(JE1)
            E0BE1 = E0B0 - EFCK(JE1)
            IE1A1 = (JE1-M1-1)*M1 + IA1
            IE1A2 = IE1A1 - IA1 + IA2
            IE1A1T = INPT(IE1A1)
            IE1A2T = INPT(IE1A2)
C
         DO 2610 JE2=NQS,JE1-1
            ICOUNT = ICOUNT + 1
            IS2 = IOB(JE2)
            IP1 = IMUL(IS1,IS2)
            IF (IP1.NE.IP2) GOTO 2610
            DO III=1,NPTST
               TMP4(ICOUNT,III) = E0BE1 - EFCK(JE2) + EPT0(III)
            ENDDO
C
C ME = [IE2,IA2 | IE1,IA1] - [IE2,IA1 | IE1,IA2]
C
         IE2A1 = (JE2-M1-1)*M1 + IA1
         IE2A2 = IE2A1 - IA1 + IA2
         INT1 = IE1A1T + IE2A2
         INT2 = IE1A2T + IE2A1
         T = SVOVO(INT1) - SVOVO(INT2)
         DO III=1,NPTST
            TMP3(ICOUNT,III) = TMP3(ICOUNT,III) + COEFF(III)*T
         ENDDO
C
 2610    CONTINUE
 2600    CONTINUE
C
 2642          CONTINUE
               IST2 = IBCON2(KKJ2)+1
               IEN2 = IBCON2(KKJ2+1)-1
               IF (KKJ2.EQ.NB-1) IEN2=NACT
 2640       CONTINUE
C
 2632          CONTINUE
               IST = IBCON1(KKJ)+1
               IEN = IBCON1(KKJ+1)-1
               IF (KKJ.EQ.NB-2) IEN=NACT
 2630       CONTINUE
C
CFORNOW
         DO JJ=1,NPTST
         DO KK=1,NPTST
         DO II=1,ICOUNT
         HPT(JJ,KK)=HPT(JJ,KK)+(TMP3(II,JJ)*TMP3(II,KK))/TMP4(II,JJ)
         ENDDO
         ENDDO
         ENDDO
C
         DO JJ=1,NPTST
            DO II=1,ICOUNT
               TMP3(II,JJ) = 0.0D+00
               TMP4(II,JJ) = 1.0D+00
            ENDDO
         ENDDO
C
         ICOUNT = 0
C
C END OF DOUBLE BETA DEXCITATIONS ( IE1<IE2 -> IA1<IA2 )
C
            CALL ADVANC(IBCON1,NB-2,NACT)
 2620    CONTINUE
C
C ******
C END OF LOOP OVER 2ND ORDER BETAS (IA1<IA2 -> IE1<IE2)
C ******
C
         IF (NVAL.EQ.0) GOTO 2701
C
C ---------------------------------------------------------
C LOOP OVER 1ST ORDER ALPHAS, VAL(IV1) -> EXT(IE1)
C THIS LOOP INCLUDES A LOOP OVER 0TH ORDER ALPHAS, SO WE'LL
C TRY TO PUT IT IN THE MAIN 0TH ORDER ALPHA LOOP, IE, HERE
C ---------------------------------------------------------
C
C I BELIVE THE BELOW INCLUDE VAL(B) -> EXT(B) ALSO...
C
C *****
C LOOP OVER 0TH ORDER BETA STRINGS
C *****
C
        DO II=1,NB
           IBCON1(II) = II
        ENDDO
        DO 2700 IJB=1,NBLP
           ICAB = ISPB(IJB)
           ISYB = IMUL(ISYV,ISYMB(IJB))
           E0B0 = E0AD
           DO II=1,NB
              E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
           ENDDO
           IF (ISYB.NE.ITAS) GOTO 2698
C
           ITP0 = ICAT + ICAB
           DO III=1,NPTST
              COEFF(III) = CI(ITP0,III)
           ENDDO
C
C SINGLE DEXCITATIONS, ALPHA IE -> IV
C
           ICOUNT = 0
           DO 2710 IV=1,NVAL
              IS1 = IOB(IV)
              E0B0V = E0B0 + EFCK(IV)
C
           DO 2720 IE=1,NEXT
              ICOUNT = ICOUNT + 1
              JE = IE + M1
              IS2 = IOB(JE)
              IF (IS1.NE.IS2) GOTO 2720
              DO III=1,NPTST
                 TMP4(ICOUNT,III) = E0B0V - EFCK(JE) + EPT0(III)
              ENDDO
C
C MATRIX ELEMENT
C
          CALL ME0VE1B(IV,IE,IACON1,NA,IBCON1,NB,NVAL,
     *    NACT,NEXT,INPT,SI1,SVOOO,M2,T)
          DO III=1,NPTST
             TMP3(ICOUNT,III) = TMP3(ICOUNT,III) + T*COEFF(III)
          ENDDO
C
          CALL ME0VE1B(IV,IE,IBCON1,NB,IACON1,NA,NVAL,
     *    NACT,NEXT,INPT,SI1,SVOOO,M2,T)
          DO III=1,NPTST
             TMP2(ICOUNT,III) = TMP2(ICOUNT,III) + T*COEFF(III)
          ENDDO
C
 2720      CONTINUE
C
 2710      CONTINUE
C
C END OF SINGLE DEXCITATIONS
C
 2698 CONTINUE
C
C NOW FOR DOUBLE DEXCITATIONS
C DOUBLES MUST INCLUDE THE SINGLE ABOVE
C
C 2ND EXCITATION: ALPHA ACT(IA2 -> JJA)
C TOTAL = ALPHA (IE,IA2 -> IV,JJA)
C
           ISYT = ITAB(ISYB)
           ISYL = IMUL(ISYT,ISA1)
C
           DO 2730 IEL2=1,NA
              IA2 = IACON1(IEL2) + NVAL
              IS1 = IOB(IA2)
C
       IST = 1
       IEN = IACON1(1)-1
       DO 2740 KKJ=1,NA+1
          DO 2742 JJ=IST,IEN
             JJA = JJ + NVAL
             IS2 = IOB(JJA)
             IP1 = IMUL(IS1,IS2)
             IF (IP1.NE.ISYL) GOTO 2742
             MA = MAX(IA2,JJA)
             MI = MIN(IA2,JJA)
             IA2A3 = INPT(MA) + MI
C
           CALL RET1DET(IACON1,IACON2,NA,IEL2,JJ,0,KKJ,ISWAP2)
           IPER2 = (-1)**ISWAP2
           IPA2 = POSDET(NACT,NA,IACON2,IFA)
           ITP0 = ISPA(IPA2) + ICAB
           DO III=1,NPTST
              COEFF(III) = CI(ITP0,III)*IPER2
           ENDDO
C
           ICOUNT = 0
           DO 2750 IV=1,NVAL
              IS3 = IOB(IV)
              E0B0V = E0B0 + EFCK(IV)
              IA2V = INPT(IA2) + IV
              IVA2A3 = (IV-1)*M2 + IA2A3
              IA3A2V = (JJA-1)*M2 + IA2V
C
           DO 2760 IE=1,NEXT
              ICOUNT = ICOUNT + 1
              JE = IE + M1
              IS4 = IOB(JE)
              IP2 = IMUL(IS4,IS3)
              IF (IP1.NE.IP2) GOTO 2760
              DO III=1,NPTST
                 TMP4(ICOUNT,III) = E0B0V - EFCK(JE) + EPT0(III)
              ENDDO
C
C MATRIX ELEMENT
C
         T1 = SVOOO(IE,IVA2A3)
         T2 = SVOOO(IE,IA3A2V)
         TT = T1 - T2
         DO III=1,NPTST
            TMP3(ICOUNT,III) = TMP3(ICOUNT,III) + TT*COEFF(III)
            TMP2(ICOUNT,III) = TMP2(ICOUNT,III) + T1*COEFF(III)
         ENDDO
C
 2760      CONTINUE
 2750      CONTINUE
C
 2742     CONTINUE
          IST = IACON1(KKJ)+1
          IEN = IACON1(KKJ+1)-1
          IF (KKJ.EQ.NA) IEN=NACT
 2740  CONTINUE
C
 2730      CONTINUE
C
C END OF ALPHA ACT (IA2 -> JJA) DEXCITE
C
C 2ND EXCITATION: BETA ACT (IA2 -> JJA)
C TOTAL = ( IE(A),IA2(B) -> IV(A),JJA(B) )
C
           ISYL = IMUL(ITAS,ISYB)
           DO 2770 IEL2=1,NB
              IA2 = IBCON1(IEL2)+NVAL
              IS1 = IOB(IA2)
C
           IST = 1
           IEN = IBCON1(1)-1
           DO 2780 KKJ=1,NB+1
              DO 2782 JJ=IST,IEN
                 JJA = JJ + NVAL
                 IS2 = IOB(JJA)
                 IP1 = IMUL(IS1,IS2)
                 IF (IP1.NE.ISYL) GOTO 2782
C
                 MA = MAX(IA2,JJA)
                 MI = MIN(IA2,JJA)
                 IA2A3 = INPT(MA) + MI
C
          CALL RET1DET(IBCON1,IBCON2,NB,IEL2,JJ,0,KKJ,ISWAP2)
          IPER2 = (-1)**ISWAP2
          IPB2 = POSDET(NACT,NB,IBCON2,IFA)
          ITP0 = ICAT + ISPB(IPB2)
          DO III=1,NPTST
             COEFF(III) = CI(ITP0,III)*IPER2
          ENDDO
C
          ICOUNT = 0
          DO 2785 IV=1,NVAL
             IS3 = IOB(IV)
             E0B0V = E0B0 + EFCK(IV)
              IA2V = INPT(IA2) + IV
              IVA2A3 = (IV-1)*M2 + IA2A3
              IA3A2V = (JJA-1)*M2 + IA2V
C
          DO 2790 IE=1,NEXT
             ICOUNT = ICOUNT + 1
             JE = IE + M1
             IS4 = IOB(JE)
             IP2 = IMUL(IS4,IS3)
             IF (IP1.NE.IP2) GOTO 2790
             DO III=1,NPTST
                TMP4(ICOUNT,III) = E0B0V - EFCK(JE) + EPT0(III)
             ENDDO
C
C  MATRIX ELEMENT
C
         T1 = SVOOO(IE,IVA2A3)
         T2 = SVOOO(IE,IA3A2V)
         TT = T1 - T2
         DO III=1,NPTST
            TMP3(ICOUNT,III) = TMP3(ICOUNT,III) + T1*COEFF(III)
            TMP2(ICOUNT,III) = TMP2(ICOUNT,III) + TT*COEFF(III)
         ENDDO
C
 2790     CONTINUE
 2785     CONTINUE
C
 2782         CONTINUE
              IST = IBCON1(KKJ)+1
              IEN = IBCON1(KKJ+1)-1
              IF (KKJ.EQ.NB) IEN=NACT
 2780      CONTINUE
C
 2770      CONTINUE
C
C END OF 2ND EXCITATION BETA (IA2 -> JJ)
C
         DO JJ=1,NPTST
         DO KK=1,NPTST
         DO II=1,ICOUNT
            HPT(JJ,KK) = HPT(JJ,KK) +
     *  (TMP3(II,JJ)*TMP3(II,KK)+
     *   TMP2(II,JJ)*TMP2(II,KK))/TMP4(II,JJ)
         ENDDO
         ENDDO
         ENDDO
C
         DO JJ=1,NPTST
            DO II=1,ICOUNT
               TMP3(II,JJ) = 0.0D+00
               TMP2(II,JJ) = 0.0D+00
               TMP4(II,JJ) = 1.0D+00
            ENDDO
         ENDDO
C
         ICOUNT = 0
C
           CALL ADVANC(IBCON1,NB,NACT)
 2700   CONTINUE
 2701 CONTINUE
C
C *****
C END OF LOOP OVER 0TH ORDER BETA STRINGS
C *****
C
        CALL DDI_DLBNEXT(MY_TASK)
      END IF     ! MY TASK
C
         CALL ADVANC(IACON1,NA,NACT)
 2000 CONTINUE
C
C END LOOP OVER ZEROTH ORDER ALPHAS
C
C -------------------------------------------
C *******************************************
C -------------------------------------------
C
C LOOP OVER 1ST ORDER ALPHAS, ORBITALS NUMBERED AS ACTIVE, 1,2,etc
C
C --------------------------------------------------
C **************************************************
C --------------------------------------------------
C
      NBUFF=N1A
      IF (NVAL.EQ.0) THEN
         NBUFF=0
         GOTO 3401
      ENDIF
C
C LOOP OVER 1ST ORDER ALPHAS (IV -> IA)
C
C OUTER LOOP OVER 1 UP ALPHAS
C
      DO II=1,NA+1
         IACON1(II) = II
      ENDDO
      E0A0 = -2*E0V
      ISA0 = ISYV
      DO 3400 IJK2=1,N1A
C
        IF (IJK2+NALP-1.EQ.MY_TASK) THEN
C
         ISA1 = ISA0
         E0AD1 = E0A0
         DO II=1,NA+1
            E0AD1 = E0AD1 - EFCK(IACON1(II)+NVAL)
            ISA1 = IMUL(ISA1,IOB(IACON1(II)+NVAL))
         ENDDO
C
C LOOP OVER 0TH ORDER BETAS
C
         DO II=1,NB
            IBCON1(II) = II
         ENDDO
         DO 3410 IJB=1,NBLP
            ICAB = ISPB(IJB)
            ISYB = IMUL(ISYV,ISYMB(IJB))
            E0B0 = E0AD1
            DO II=1,NB
               E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
            ENDDO
            ITAM = ITAB(ISYB)
            ITAL = IMUL(ITAM,ISA1)
C
C LOOP OVER PURE SINGLE DEXCITATIONS ALPHA IA -> IV
C
            DO 3420 IEL=1,NA+1
               IA = IACON1(IEL)+NVAL
               IS1 = IOB(IA)
               IF (IS1.NE.ITAL) GOTO 3420
C
C DETERMINE 0TH ORDER ALPHA, POS/PERM
C
        CALL STR0VA(IACON1,IACON2,NA+1,IEL,NVAL,NVAL,IPER)
        IPA0 = POSDET(NACT,NA,IACON2,IFA)
        ITP0 = ISPA(IPA0) + ICAB
        DO III=1,NPTST
           COEFF(III) = CI(ITP0,III)*IPER
        ENDDO
C
C LOOP OVER VALENCE ORBITALS, WORK OUT MATRIX ELEMENT
C
        DO 3430 IV=1,NVAL
        IS2 = IOB(IV)
        IF (IS1.NE.IS2) GOTO 3430
        DO III=1,NPTST
           TMP4(IV,III) = E0B0 + EFCK(IV) + EPT0(III)
        ENDDO
        CALL ME0VA1B(IV,IA,IACON2,NA,IBCON1,NB,NVAL,INPT,SI1,SI2,T)
C
        DO III=1,NPTST
           TMP3(IV,III) = TMP3(IV,III) + COEFF(III)*T
        ENDDO
C
 3430   CONTINUE
C
C END OF LOOP OVER VALENCE ORBITALS
C
 3420       CONTINUE
C
C END OF PURE SINGLE DEXCITATIONS ALPHA IA -> IV
C
C DOUBLE DEXCITATIONS: ( IA(A) < IA2(A) -> IV,JJA )
C
          DO 3435 IEL=1,NA+1
          JA = IACON1(IEL)
          IA = JA + NVAL
          IS1 = IOB(IA)
          CALL STR0VA(IACON1,IACON2,NA+1,IEL,NVAL,NVAL,IPER)
          IPA0 = POSDET(NACT,NA,IACON2,IFA)
          ICAT = ISPA(IPA0)
C
          DO 3440 IEL2=IEL,NA
             IA2 = IACON2(IEL2)+NVAL
             IS2 = IOB(IA2)
             IP1 = IMUL(IS1,IS2)
C
          IST = 1
          IEN = IACON2(1)-1
          DO 3450 KKJ=1,NA+1
             DO 3447 JJ=IST,IEN
                IF (JJ.EQ.JA) GOTO 3447
                JJA = JJ + NVAL
                IS3 = IOB(JJA)
                IP1A = IMUL(IP1,IS3)
                IF (IP1A.NE.ITAL) GOTO 3447
C
          MA = MAX(IA2,JJA)
          MI = MIN(IA2,JJA)
          IA3A2 = INPT(MA) + MI
          MA = MAX(IA,JJA)
          MI = MIN(IA,JJA)
          IA3A = INPT(MA) + MI
C
C DETERMINE 0TH ORDER ALPHA, POS/PERM
C
          CALL RET1DET(IACON2,IBCON2,NA,IEL2,JJ,0,KKJ,ISWAP2)
          IPER2 = (-1)**ISWAP2
          IPERT = IPER*IPER2
          IPA2 = POSDET(NACT,NA,IBCON2,IFA)
          ITP0 = ISPA(IPA2) + ICAB
          DO III=1,NPTST
             COEFF(III) = CI(ITP0,III)*IPERT
          ENDDO
C
C LOOP OVER VALENCE AND MAKE MATRIX ELEMENT
C
          DO 3460 IV=1,NVAL
             IS4 = IOB(IV)
             IF (IS4.NE.IP1A) GOTO 3460
             DO III=1,NPTST
                TMP4(IV,III) = E0B0 + EFCK(IV) + EPT0(III)
             ENDDO
C
             IAV = INPT(IA) + IV
             INT1 = INPT(IA3A2) + IAV
             IA2V = INPT(IA2) + IV
             MA = MAX(IA3A,IA2V)
             MI = MIN(IA3A,IA2V)
             INT2 = INPT(MA) + MI
             T = SI2(INT1) - SI2(INT2)
             DO III=1,NPTST
                TMP3(IV,III) = TMP3(IV,III) + T*COEFF(III)
             ENDDO
C
 3460     CONTINUE
C
C END OF LOOP OVER VALENCE
C
 3447        CONTINUE
             IST = IACON2(KKJ)+1
             IEN = IACON2(KKJ+1)-1
             IF (KKJ.EQ.NA) IEN=NACT
 3450     CONTINUE
C
 3440     CONTINUE
C
C END OF 2ND PART OF DOUBLE EXCITE, IA2 -> JJA
C
C NOW FOR DOUBLE EXCITES ( IA(A),IA2(B) -> IV(A),JJA(B) )
C
          DO 3465 IEL2=1,NB
             IA2 = IBCON1(IEL2)+NVAL
             IS2 = IOB(IA2)
             IP1 = IMUL(IS1,IS2)
C
          IST = 1
          IEN = IBCON1(1)-1
          DO 3470 KKJ=1,NB+1
             DO 3472 JJ=IST,IEN
                JJA = JJ + NVAL
                IS3 = IOB(JJA)
                IP1A = IMUL(IP1,IS3)
                IF(IP1A.NE.ITAL) GOTO 3472
C
          MA = MAX(IA2,JJA)
          MI = MIN(IA2,JJA)
          IA3A2 = INPT(MA) + MI
C
C DETERMINE NEW 0TH ORDER BETA, POS/PERM
C
          CALL RET1DET(IBCON1,IBCON2,NB,IEL2,JJ,0,KKJ,ISWAP2)
          IPER2 = (-1)**ISWAP2
          IPERT = IPER*IPER2
          IPB2 = POSDET(NACT,NB,IBCON2,IFA)
          ITP0 = ICAT + ISPB(IPB2)
          DO III=1,NPTST
             COEFF(III) = CI(ITP0,III)*IPERT
          ENDDO
C
          DO 3480 IV=1,NVAL
             IS4 = IOB(IV)
             IF (IS4.NE.IP1A) GOTO 3480
             DO III=1,NPTST
                TMP4(IV,III) = E0B0 + EFCK(IV) + EPT0(III)
             ENDDO
C
             IAV = INPT(IA) + IV
             MA = MAX(IA3A2,IAV)
             MI = MIN(IA3A2,IAV)
             INT = INPT(MA) + MI
             T = SI2(INT)
             DO III=1,NPTST
                TMP3(IV,III) = TMP3(IV,III) + T*COEFF(III)
             ENDDO
C
 3480     CONTINUE
C
C END OF LOOP OVER VALENCE
C
 3472        CONTINUE
             IST = IBCON1(KKJ) + 1
             IEN = IBCON1(KKJ+1)-1
             IF (KKJ.EQ.NB) IEN=NACT
 3470     CONTINUE
C
 3465     CONTINUE
C
C END OF 2ND EXCITE BETA ( IA2(B) -> JJA(B) )
C
 3435     CONTINUE
C
C END OF FIRST PART OF DOUBLE EXCITE, IA -> IV
C
        DO JJ=1,NPTST
        DO KK=1,NPTST
        DO II=1,NVAL
        HPT(JJ,KK)=HPT(JJ,KK)+(TMP3(II,JJ)*TMP3(II,KK))/TMP4(II,JJ)
        ENDDO
        ENDDO
        ENDDO
C
         DO JJ=1,NPTST
            DO II=1,NVAL
               TMP3(II,JJ) = 0.0D+00
               TMP4(II,JJ) = 1.0D+00
            ENDDO
         ENDDO
C
C --------------------------------------------------------------
C END OF PURE SINGLE EXCITED DETERMINANTS IV(A) -> IA(A)
C --------------------------------------------------------------
C
C WITHIN LOOP OVER ALPHA(1), BETA(0), LOWER MATRIX ElEMENTS CAN
C BE ALSO DETERMINED
C --------------------------------------------------------------
C RELOOP OVER 2ND ORDER ALPHAS, (IV1,IV2 -> IA1,IE)
C THIS INCLUDES                ( IV1(B),IV2(A) -> IA1(A),IE(B) )
C --------------------------------------------------------------
C
         ITAZ = ITAB(ISA1)
         ISYZ = IMUL(ITAZ,ISYB)
C
C LOOP OVER DEXCITAIONS FROM ALPHA, IA1
C
            DO 7120 IEL1=1,NA+1
               IA1 = IACON1(IEL1)+NVAL
               IS1 = IOB(IA1)
               IF (IS1.NE.ISYZ) GOTO 7120
C
C DETERMINE 0TH ORDER ALPHA, POS/PERM
C
         CALL STR0VA(IACON1,IACON2,NA+1,IEL1,NVAL,NVAL,IPER)
         IPA0 = POSDET(NACT,NA,IACON2,IFA)
         ITP0 = ISPA(IPA0) + ICAB
         DO III=1,NPTST
            COEFF(III) = CI(ITP0,III)*IPER
         ENDDO
C
C LOOP OVER ALPHA VALENCE, IV1 < IV2
C
         ICOUNT = 0
         DO 7130 IV1=1,NVAL
            IS2 = IOB(IV1)
            IP1 = IMUL(IS1,IS2)
            E0B0V = E0B0 + EFCK(IV1)
            IA1V1 = INPT(IA1) + IV1
C
         DO 7140 IV2=1,IV1-1
            IS3 = IOB(IV2)
            IPT = IMUL(IS3,IP1)
            E0B0VV = E0B0V + EFCK(IV2)
            IA1V2 = INPT(IA1) + IV2
            IV2A1V1 = (IV2-1)*M2 + IA1V1
            IV1A1V2 = (IV1-1)*M2 + IA1V2
C
C LOOP OVER ALPHA EXTERNAL, IE
C
         DO 7150 IE=1,NEXT
            JE = IE + M1
            IS4 = IOB(JE)
            IF (IS4.NE.IPT) GOTO 7150
            ICOUNT = ICOUNT + 1
            DO III=1,NPTST
               TMP4(ICOUNT,III) = E0B0VV - EFCK(JE) + EPT0(III)
            ENDDO
C
C MATRIX ELEMENT
C
        T1 = SVOOO(IE,IV2A1V1)
        T2 = SVOOO(IE,IV1A1V2)
        TT = T1 - T2
        DO III=1,NPTST
           TMP3(ICOUNT,III) = TMP3(ICOUNT,III) + T1*COEFF(III)
           TMP1(ICOUNT,III) = TMP1(ICOUNT,III) + T2*COEFF(III)
           TMP2(ICOUNT,III) = TMP2(ICOUNT,III) + TT*COEFF(III)
        ENDDO
C
 7150    CONTINUE
C
C END OF LOOP OVER ALPHA EXTERNAL
C
 7140    CONTINUE
C
C IV1 = IV2
C
            IPT = IMUL(IS2,IP1)
            E0B0VV = E0B0V + EFCK(IV1)
            IV2A1V1 = (IV1-1)*M2 + IA1V1
            DO 7135 IE=1,NEXT
               JE = IE + M1
               IS4 = IOB(JE)
               IF (IS4.NE.IPT) GOTO 7135
               ICOUNT = ICOUNT + 1
               DO III=1,NPTST
                  TMP4(ICOUNT,III) = E0B0VV - EFCK(JE) + EPT0(III)
               ENDDO
C
         T = SVOOO(IE,IV2A1V1)
         DO III=1,NPTST
            TMP3(ICOUNT,III) = TMP3(ICOUNT,III) + T*COEFF(III)
         ENDDO
C
 7135       CONTINUE
C
C END OF IV1=IV2
C
 7130    CONTINUE
C
C END OF EXCITATIONS INTO VALENCE IV1 < IV2
C
 7120       CONTINUE
C
C END OF DEXCITATIONS FROM ALPHA, IA
C
          DO JJ=1,NPTST
          DO KK=1,NPTST
          DO II=1,ICOUNT
             HPT(JJ,KK) = HPT(JJ,KK) +
     *     (TMP3(II,JJ)*TMP3(II,KK)+
     *      TMP1(II,JJ)*TMP1(II,KK)+
     *      TMP2(II,JJ)*TMP2(II,KK))/TMP4(II,JJ)
          ENDDO
          ENDDO
          ENDDO
C
         DO JJ=1,NPTST
            DO II=1,ICOUNT
               TMP3(II,JJ) = 0.0D+00
               TMP2(II,JJ) = 0.0D+00
               TMP1(II,JJ) = 0.0D+00
               TMP4(II,JJ) = 1.0D+00
            ENDDO
         ENDDO
C
         ICOUNT = 0
C
C --------------------------------------------------------------
C END OF RELOOP OVER 2ND ORDER ALPHAS, (IV1,IV2 -> IA1,IE)
C WHICH INCLUDED                ( IV1(B),IV2(A) -> IA1(A),IE(B) )
C --------------------------------------------------------------
C
            CALL ADVANC(IBCON1,NB,NACT)
 3410    CONTINUE
C
C END OF LOOP OVER 0TH ORDER BETAS
C
C ----------------------------------------------
C NOW TO LOOP OVER 1ST ORDER BETAS IV2 -> IA2
C ----------------------------------------------
C
C LOOP OVER 1 UP BETAS
C
         DO II=1,NB+1
            IBCON1(II) = II
         ENDDO
         DO 3500 IJB=1,N1B
            ISYB = ISYV
            E0B0 = E0AD1
            DO II=1,NB+1
               E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
               ISYB = IMUL(ISYB,IOB(IBCON1(II)+NVAL))
            ENDDO
            ISYT = IMUL(ISYB,ISA1)
            ITAL = ITAB(ISYT)
C
C LOOP OVER ALPHA EXCITE (IA1 -> IV)
C
            DO 3510 IEL1=1,NA+1
               IA1 = IACON1(IEL1) + NVAL
               IS1 = IOB(IA1)
            CALL STR0VA(IACON1,IACON2,NA+1,IEL1,NVAL,NVAL,IPER)
            IPA0 = POSDET(NACT,NA,IACON2,IFA)
            ICAT = ISPA(IPA0)
C
C LOOP OVER BETA EXCITE (IA2 -> IV2)
C
            DO 3520 IEL2=1,NB+1
               IA2 = IBCON1(IEL2) + NVAL
               IS2 = IOB(IA2)
               IP1 = IMUL(IS1,IS2)
               IF (IP1.NE.ITAL) GOTO 3520
            CALL STR0VA(IBCON1,IBCON2,NB+1,IEL2,NVAL,NVAL,IPER2)
            IPERT = IPER*IPER2
            IPB0 = POSDET(NACT,NB,IBCON2,IFA)
            ITP0 = ICAT + ISPB(IPB0)
            DO III=1,NPTST
               COEFF(III) = CI(ITP0,III)*IPERT
            ENDDO
C
C NOW TO LOOP OVER VALENCE ORBITALS
C
            IA1T = INPT(IA1)
            IA2T = INPT(IA2)
            ICOUNT = 0
            DO 3530 IV1=1,NVAL
               IS3 = IOB(IV1)
               IPT = IMUL(IS3,IP1)
               E0BV1 = E0B0 + EFCK(IV1)
               IA1V1 = IA1T + IV1
C
            DO 3540 IV2=1,NVAL
               ICOUNT = ICOUNT + 1
               IS4 = IOB(IV2)
               IF (IS4.NE.IPT) GOTO 3540
               DO III=1,NPTST
                  TMP4(ICOUNT,III) = E0BV1 + EFCK(IV2) + EPT0(III)
               ENDDO
C
           IA2V2 = IA2T + IV2
           MA = MAX(IA1V1,IA2V2)
           MI = MIN(IA1V1,IA2V2)
           INT1 = INPT(MA) + MI
           T1 = SI2(INT1)
           DO III=1,NPTST
              TMP3(ICOUNT,III) = TMP3(ICOUNT,III) + T1*COEFF(III)
           ENDDO
C
 3540       CONTINUE
C
 3530       CONTINUE
C
CEND OF LOOP OVER VALENCE ORBITALS
C
 3520       CONTINUE
C
C END OF BETA EXCITE (IA2 -> IV2)
C
 3510       CONTINUE
C
C END OF ALPHA EXCITE (IA1 -> IV)
C
         DO JJ=1,NPTST
         DO KK=1,NPTST
         DO II=1,ICOUNT
         HPT(JJ,KK)=HPT(JJ,KK)+(TMP3(II,JJ)*TMP3(II,KK))/TMP4(II,JJ)
         ENDDO
         ENDDO
         ENDDO
C
         DO JJ=1,NPTST
            DO II=1,ICOUNT
               TMP3(II,JJ) = 0.0D+00
               TMP4(II,JJ) = 1.0D+00
            ENDDO
         ENDDO
C
         ICOUNT = 0
C
            CALL ADVANC(IBCON1,NB+1,NACT)
 3500    CONTINUE
C
C -----------------------------------
C END OF LOOP OVER 1 UP BETAS
C END LOOP OVER 1ST ORDER BETAS IV2 -> IA2
C -----------------------------------
C
C ------------------------------------------
C NOW TO LOOP OVER 1ST ORDER BETAS IA2 -> IE
C ------------------------------------------
C
C LOOP OVER 1 DOWN BETAS
C
         DO II=1,NB-1
            IBCON1(II) = II
         ENDDO
         DO 3700 IJB=1,ND1B
            ISYB = ISYV
            E0BD1 = E0AD1
            DO II=1,NB-1
               E0BD1 = E0BD1 - EFCK(IBCON1(II)+NVAL)
               ISYB = IMUL(ISYB,IOB(IBCON1(II)+NVAL))
            ENDDO
            ISYT = IMUL(ISYB,ISA1)
            ITAL = ITAB(ISYT)
C
C LOOP OVER DEXCITATIONS FROM IA1(A)
C
         DO 3710 IEL=1,NA+1
            IA1 = IACON1(IEL) + NVAL
            IS1 = IOB(IA1)
            CALL STR0VA(IACON1,IACON2,NA+1,IEL,NVAL,NVAL,IPER)
            IPA0 = POSDET(NACT,NA,IACON2,IFA)
            ICAT = ISPA(IPA0)
C
C LOOP OVER EXCITATIONS INTO IA2(B)
C
         IST = 1
         IEN = IBCON1(1)-1
         IF (NB.EQ.1) IEN=NACT
         DO 3720 KKJ=1,NB
            DO 3722 JJ=IST,IEN
               IA2 = JJ + NVAL
               IS2 = IOB(IA2)
               IP1 = IMUL(IS1,IS2)
               IF (IP1.NE.ITAL) GOTO 3722
C
C 0TH ORDER BETA POS/PERM
C
         CALL STR0AE(IBCON1,IBCON2,NB,KKJ,JJ,IPER2)
         IPERT = IPER*IPER2
         IPB0 = POSDET(NACT,NB,IBCON2,IFA)
         ITP0 = ICAT + ISPB(IPB0)
         DO III=1,NPTST
            COEFF(III) = CI(ITP0,III)*IPERT
         ENDDO
C
C LOOP OVER ALPHA VALENCE
C
         ICOUNT = 0
         DO 3730 IV=1,NVAL
            IS3 = IOB(IV)
            IPT = IMUL(IP1,IS3)
            E0BD1V = E0BD1 + EFCK(IV)
            IA1V = INPT(IA1) + IV
            IA2A1V = (IA2-1)*M2 + IA1V
C
C LOOP OVER BETA EXTERNAL
C
         DO 3740 IE=1,NEXT
            ICOUNT = ICOUNT + 1
            JE = IE + M1
            IS4 = IOB(JE)
            IF (IS4.NE.IPT) GOTO 3740
            DO III=1,NPTST
               TMP4(ICOUNT,III) = E0BD1V - EFCK(JE) + EPT0(III)
            ENDDO
C
            T1 = SVOOO(IE,IA2A1V)
            DO III=1,NPTST
               TMP3(ICOUNT,III) = TMP3(ICOUNT,III) + T1*COEFF(III)
            ENDDO
C
 3740    CONTINUE
C
 3730    CONTINUE
C
C END OF ALPHA VALENCE
C
 3722       CONTINUE
            IST = IBCON1(KKJ)+1
            IEN = IBCON1(KKJ+1)-1
            IF (KKJ.EQ.NB-1) IEN=NACT
 3720    CONTINUE
C
C END OF EXCITATIONS INTO EA2(B)
C
 3710    CONTINUE
C
C END OF DEXCITATIONS OUT OF IA1(A), IA2(B)
C
         DO JJ=1,NPTST
         DO KK=1,NPTST
         DO II=1,ICOUNT
         HPT(JJ,KK)=HPT(JJ,KK)+(TMP3(II,JJ)*TMP3(II,KK))/TMP4(II,JJ)
         ENDDO
         ENDDO
         ENDDO
C
         DO JJ=1,NPTST
            DO II=1,ICOUNT
               TMP3(II,JJ) = 0.0D+00
               TMP4(II,JJ) = 1.0D+00
            ENDDO
         ENDDO
C
         ICOUNT = 0
C
            CALL ADVANC(IBCON1,NB-1,NACT)
 3700    CONTINUE
C
C END OF LOOP OVER 1 DOWN BETAS
C
C ------------------------------------------
C END OF LOOP OVER 1ST ORDER BETAS IA2 -> IE
C ------------------------------------------
C
        CALL DDI_DLBNEXT(MY_TASK)
      END IF     ! MY TASK
C
         CALL ADVANC(IACON1,NA+1,NACT)
 3400 CONTINUE
 3401 CONTINUE
C
C END OF RELOOP OVER 1ST ORDER ALPHAS, VAL (IV) -> ACTIVE
C
C --------------------------------------------------
C **************************************************
C --------------------------------------------------
C
C -------------------------------------------
C *******************************************
C -------------------------------------------
C
C EXPERIMENT, RELOOP OVER ALPHA ACT (IA?)  -> EXTERNAL (IE)
C
         DO II=1,NA-1
            IACON1(II) = II
         ENDDO
         DO 5805 IJK3=1,ND1A
C
        IF (IJK3+NALP+NBUFF-1.EQ.MY_TASK) THEN
C
C DETERMINE SYMMETRY OF ALPHA STRING
C
            ISA0 = ISYV
            E0A0 = E0V
            DO II=1,NA-1
               E0A0 = E0A0 + EFCK(IACON1(II)+NVAL)
               ISA0 = IMUL(ISA0,IOB(IACON1(II)+NVAL))
            ENDDO
C
C LOOP OVER 0TH ORDER BETAS
C
            E0AD = -E0A0 - E0V
            ISYBV = ISYV
            DO II=1,NB
               IBCON1(II) = II
            ENDDO
            DO 5700 IJB=1,NBLP
               ICAB = ISPB(IJB)
               ISYB = IMUL(ISYMB(IJB),ISYBV)
               E0B0 = E0AD
               DO II=1,NB
                  E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
               ENDDO
               ITBS = ITAB(ISYB)
               ISYL = IMUL(ISA0,ITBS)
C
C SINGLE DEXCITATIONS, ALPHA IE -> IA(?)
C
        IST = 1
        IEN = IACON1(1)-1
        IF (NA.EQ.1) IEN=NACT
        DO 5710 KKJ=1,NA
           DO 5712 JJ=IST,IEN
              JJE = JJ + NVAL
              IS2 = IOB(JJE)
              IF (IS2.NE.ISYL) GOTO 5712
C
C DETERMINE 0TH ORDER ALPHA STRING, POS/PERM AND MATRIX ELEMENT
C
           CALL STR0AE(IACON1,IACON2,NA,KKJ,JJ,IPER)
           IPA0 = POSDET(NACT,NA,IACON2,IFA)
           ITP0 = ISPA(IPA0) + ICAB
           DO III=1,NPTST
              COEFF(III) = CI(ITP0,III)*IPER
           ENDDO
C
C LOOP OVER EXTERNAL ORBS
C
           DO 5715 IE=1,NEXT
              JE = IE + M1
              IS1 = IOB(JE)
              IF (IS1.NE.IS2) GOTO 5715
              DO III=1,NPTST
                 TMP4(IE,III) = E0B0 - EFCK(JE) + EPT0(III)
              ENDDO
C
        CALL ME0AE1B(JJE,IE,IACON1,NA,IBCON1,NB,NVAL,NACT,NEXT,
     *  INPT,SI1,SVOOO,M2,T)
C
        DO III=1,NPTST
           TMP3(IE,III) = TMP3(IE,III) + COEFF(III)*T
        ENDDO
C
 5715      CONTINUE
C
 5712      CONTINUE
           IST = IACON1(KKJ)+1
           IEN = IACON1(KKJ+1)-1
           IF (KKJ.EQ.NA-1) IEN=NACT
 5710  CONTINUE
C
C END OF SINGLE DEXCITATIONS, ALPHA IE -> IA(?)
C
C NOW FOR DOUBLE DEXCITATIONS
C DOUBLE DEXCITATIONS MUST !!!!! INCLUDE THE SINGLES ABOVE !!!!!
C START WITH THIS TYPE FIRST, IE ALPHA IE -> IA
C
       IST = 1
       IEN = IACON1(1)-1
       IF (NA.EQ.1) IEN=NACT
       DO 5720 KKJ=1,NA
          DO 5722 JJ=IST,IEN
             IA = JJ + NVAL
             IS1 = IOB(IA)
             CALL STR0AE(IACON1,IACON2,NA,KKJ,JJ,IPER)
             IPA0 = POSDET(NACT,NA,IACON2,IFA)
             ICAT = ISPA(IPA0)
C
C SECOND EXCITATION: ALPHA ACT (IA2.NE.IA) -> ACT (JJA > IA)
C TOTAL = ALPHA (IE,IA2 -> IA < JJA )
C
             DO 5730 IEL=1,NA
                IF (IEL.EQ.KKJ) GOTO 5730
                IA2 = IACON2(IEL)+NVAL
                IS2 = IOB(IA2)
                IP1 = IMUL(IS1,IS2)
C
C HAVE ENSURED THAT IA2.NE.IA, NOW TO ENSURE THAT JJA > IA
C
             IST2=JJ+1
             IEN2=IEN
             DO 5738 KKJ2=KKJ+1,NA+1
             DO 5737 JJ2=IST2,IEN2
                JJA = JJ2 + NVAL
                IS3 = IOB(JJA)
                IPT = IMUL(IP1,IS3)
                IF (IPT.NE.ISYL) GOTO 5737
C
C DETERMINE NEW 0TH ORDER ALPHA, POS/PERM AND MATRIX ELEMENT
C
         CALL RET1DET(IACON2,IBCON2,NA,IEL,JJ2,0,KKJ2,ISWAP2)
         IPER2 = (-1)**ISWAP2
         IPERT = IPER*IPER2
         IPA2 = POSDET(NACT,NA,IBCON2,IFA)
         ITP0 = ISPA(IPA2) + ICAB
         DO III=1,NPTST
            COEFF(III) = CI(ITP0,III)*IPERT
         ENDDO
C
         MA = MAX(IA,IA2)
         MI = MIN(IA,IA2)
         IAA2 = INPT(MA) + MI
         MA = MAX(IA2,JJA)
         MI = MIN(IA2,JJA)
         IA2A3 = INPT(MA) + MI
         IAA2A3 = (IA-1)*M2 + IA2A3
         IA3AA2 = (JJA-1)*M2 + IAA2
C
      DO 5740 IE=1,NEXT
         JE = IE + M1
         IS4 = IOB(JE)
         IP2 = IMUL(IS4,IS3)
         IF (IP1.NE.IP2) GOTO 5740
         DO III=1,NPTST
            TMP4(IE,III) = E0B0 - EFCK(JE) + EPT0(III)
         ENDDO
C
C  ME = [IE,IA | IA2,JJA] - [IE,JJA | IA2,IA]
C
         T = SVOOO(IE,IAA2A3) - SVOOO(IE,IA3AA2)
         DO III=1,NPTST
            TMP3(IE,III) = TMP3(IE,III) + COEFF(III)*T
         ENDDO
C
 5740 CONTINUE
C
 5737        CONTINUE
             IST2 = IACON2(KKJ2)+1
             IEN2 = IACON2(KKJ2+1)-1
             IF (KKJ2.EQ.NA) IEN2=NACT
 5738        CONTINUE
C
 5730        CONTINUE
C
C END OF 2ND EXCITATION: ALPHA ACT (IA2 -> JJA)
C
C 2ND EXCITATION: BETA ACT (IA2 -> JJA)
C TOTAL = ( IE(A),IA2(B) -> IA(A),JJA(B) )
C
             DO 5750 IEL2=1,NB
                IA2 = IBCON1(IEL2)+NVAL
                IS2 = IOB(IA2)
                IP1 = IMUL(IS1,IS2)
C
             IST2 = 1
             IEN2 = IBCON1(1)-1
             DO 5760 KKJ2=1,NB+1
                DO 5762 JJ2=IST2,IEN2
                   JJA = JJ2 + NVAL
                   IS3 = IOB(JJA)
                   IPT = IMUL(IP1,IS3)
                   IF (IPT.NE.ISYL) GOTO 5762
C
C DETERMINE NEW 0TH ORDER BETA, POS/PERM AND MATRIX ELEMENT
C
           CALL RET1DET(IBCON1,IBCON2,NB,IEL2,JJ2,0,KKJ2,ISWAP2)
           IPER2 = (-1)**ISWAP2
           IPERT = IPER*IPER2
           IPB2 = POSDET(NACT,NB,IBCON2,IFA)
           ITP0 = ICAT + ISPB(IPB2)
           DO III=1,NPTST
              COEFF(III) = CI(ITP0,III)*IPERT
           ENDDO
C
           MA = MAX(IA2,JJA)
           MI = MIN(IA2,JJA)
           IA2A3 = INPT(MA) + MI
           IAA2A3 = (IA-1)*M2 + IA2A3
C
      DO 5770 IE=1,NEXT
         JE = IE + M1
         IS4 = IOB(JE)
         IP2 = IMUL(IS4,IS3)
         IF (IP1.NE.IP2) GOTO 5770
         DO III=1,NPTST
            TMP4(IE,III) = E0B0 - EFCK(JE) + EPT0(III)
         ENDDO
C
C ME = [IE,IA | IA2,JJA]
C
            T = SVOOO(IE,IAA2A3)
            DO III=1,NPTST
               TMP3(IE,III) = TMP3(IE,III) + COEFF(III)*T
            ENDDO
C
 5770 CONTINUE
C
 5762           CONTINUE
                IST2 = IBCON1(KKJ2)+1
                IEN2 = IBCON1(KKJ2+1)-1
                IF (KKJ2.EQ.NB) IEN2=NACT
 5760        CONTINUE
C
 5750        CONTINUE
C
C END OF 2ND EXCITATION: BETA ACT (IA2 -> JJA)
C
 5722     CONTINUE
          IST = IACON1(KKJ)+1
          IEN = IACON1(KKJ+1)-1
          IF (KKJ.EQ.NA-1) IEN=NACT
 5720  CONTINUE
C
C END OF 1ST EXCITATION ALPHA IE -> IA(?)
C
         DO JJ=1,NPTST
         DO KK=1,NPTST
         DO II=1,NEXT
         HPT(JJ,KK)=HPT(JJ,KK)+(TMP3(II,JJ)*TMP3(II,KK))/TMP4(II,JJ)
         ENDDO
         ENDDO
         ENDDO
C
       DO JJ=1,NPTST
          DO II=1,NEXT
             TMP3(II,JJ) = 0.0D+00
             TMP4(II,JJ) = 1.0D+00
          ENDDO
       ENDDO
C
               CALL ADVANC(IBCON1,NB,NACT)
 5700       CONTINUE
C
C ---------------
C END OF 0TH ORDER BETAS
C ---------------
C
C ---------------
C NOW TO LOOP OVER 1ST ORDER OVER BETA (IA2) -> (IE2)
C ---------------
C
          DO II=1,NB-1
             IBCON1(II) = II
          ENDDO
          DO 5810 IJB=1,ND1B
             ISYB0 = ISYV
             E0B0 = -E0V-E0A0
             DO II=1,NB-1
                E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
                ISYB0 = IMUL(ISYB0,IOB(IBCON1(II)+NVAL))
             ENDDO
C
C NOW TO LOOP OVER ALPHA DEXCITATIONS (IE -> IA)
C
             IST = 1
             IEN = IACON1(1)-1
             IF (NA.EQ.1) IEN=NACT
             DO 5820 KKJ=1,NA
                DO 5822 JJ=IST,IEN
                   IA = JJ + NVAL
                   IS3 = IOB(IA)
                   ISA1 = IMUL(ISA0,IS3)
                   ITAS = ITAB(ISA1)
C
                   CALL STR0AE(IACON1,IACON2,NA,KKJ,JJ,IPER)
                   IPA0 = POSDET(NACT,NA,IACON2,IFA)
                   ICAT = ISPA(IPA0)
C
C NOW TO LOOP OVER BETA DEXCITATIONS (IE2 -> IA2)
C
             IST2 = 1
             IEN2 = IBCON1(1)-1
             IF (NB.EQ.1) IEN2=NACT
             DO 5830 KKJ2=1,NB
                DO 5832 JJ2=IST2,IEN2
                   IA2 = JJ2 + NVAL
                   IS4 = IOB(IA2)
                   ISYB = IMUL(ISYB0,IS4)
                   IF (ISYB.NE.ITAS) GOTO 5832
                   IP2 = IMUL(IS4,IS3)
C
        CALL STR0AE(IBCON1,IBCON2,NB,KKJ2,JJ2,IPER2)
        IPB0 = POSDET(NACT,NB,IBCON2,IFA)
        ITP0 = ICAT + ISPB(IPB0)
        IPERT = IPER*IPER2
        DO III=1,NPTST
           COEFF(III) = CI(ITP0,III)*IPERT
        ENDDO
C
      ICOUNT = 0
      DO 5800 JE=NQS,NQQ
         IS1 = IOB(JE)
         E0A1 = E0B0 - EFCK(JE)
         IEA = (JE-M1-1)*M1 + IA
         IEA2 = IEA - IA + IA2
         IEAT = INPT(IEA)
         IEA2T = INPT(IEA2)
C
         DO 5807 JE2=NQS,JE-1
             ICOUNT = ICOUNT + 1
             IS2 = IOB(JE2)
             IP1 = IMUL(IS1,IS2)
             IF (IP1.NE.IP2) GOTO 5807
             DO III=1,NPTST
                TMP4(ICOUNT,III) = E0A1 - EFCK(JE2) + EPT0(III)
             ENDDO
C
C DETERMINE MATRIX ELEMENT
C
C ME = [IE,IA | IE2,IA2]
C
        IE2A2 = (JE2-M1-1)*M1 + IA2
        IE2A1 = IE2A2 - IA2 + IA
        INT1 = IEAT + IE2A2
        INT2 = IEA2T + IE2A1
        T1 = SVOVO(INT1)
        T2 = SVOVO(INT2)
        DO III=1,NPTST
           TMP1(ICOUNT,III) = TMP1(ICOUNT,III) + T1*COEFF(III)
           TMP3(ICOUNT,III) = TMP3(ICOUNT,III) + T2*COEFF(III)
        ENDDO
C
 5807 CONTINUE
C
C JE2=JE
C
      ICOUNT = ICOUNT + 1
      IF (IP2.NE.1) GOTO 5800
      DO III=1,NPTST
         TMP4(ICOUNT,III) = E0A1 - EFCK(JE) + EPT0(III)
      ENDDO
      MA = MAX(IEA,IEA2)
      MI = MIN(IEA,IEA2)
      INT1 = INPT(MA) + MI
      T1 = SVOVO(INT1)
      DO III=1,NPTST
         TMP1(ICOUNT,III) = TMP1(ICOUNT,III) + T1*COEFF(III)
      ENDDO
C
C END LOOP OVER IE(A),IE2(B)
C
 5800 CONTINUE
C
 5832           CONTINUE
                IST2 = IBCON1(KKJ2)+1
                IEN2 = IBCON1(KKJ2+1)-1
                IF (KKJ2.EQ.NB-1) IEN2=NACT
 5830        CONTINUE
C
C END OF BETA DEXCITATION IE2 -> IA2
C
 5822           CONTINUE
                IST = IACON1(KKJ)+1
                IEN = IACON1(KKJ+1)-1
                IF (KKJ.EQ.NA-1) IEN=NACT
 5820        CONTINUE
C
C END OF ALPHA DEXCITATION IE -> IA
C
       DO JJ=1,NPTST
       DO KK=1,NPTST
       DO II=1,ICOUNT
          HPT(JJ,KK) = HPT(JJ,KK) +
     *   (TMP1(II,JJ)*TMP1(II,KK)+
     *    TMP3(II,JJ)*TMP3(II,KK))/TMP4(II,JJ)
       ENDDO
       ENDDO
       ENDDO
C
       DO JJ=1,NPTST
          DO II=1,ICOUNT
             TMP1(II,JJ) = 0.0D+00
             TMP3(II,JJ) = 0.0D+00
             TMP4(II,JJ) = 1.0D+00
          ENDDO
       ENDDO
C
       ICOUNT = 0
C
             CALL ADVANC(IBCON1,NB-1,NACT)
 5810     CONTINUE
C
C ------
C END OF LOOP OVER 1-DOWN BETA
C ------
C
          IF (NVAL.EQ.0) GOTO 5901
C
C ------
C LOOP OVER 1ST ORDER BETAS IV -> IA1
C ------
C
            E0AD = -E0A0 - E0V
C
C LOOP OVER 1 UP BETAS
C
            DO II=1,NB+1
               IBCON1(II) = II
            ENDDO
            DO 5900 IJB = 1,N1B
               ISYB = ISYV
               E0B1 = E0AD
               DO II=1,NB+1
                  ISYB = IMUL(ISYB,IOB(IBCON1(II)+NVAL))
                  E0B1 = E0B1 - EFCK(IBCON1(II)+NVAL)
               ENDDO
               ISYL = IMUL(ISA0,ISYB)
               ISYT = ITAB(ISYL)
C
C
C LOOP OVER BETA DEXCITES FROM ACTIVE SET IA1
C
           DO 5920 IEL1=1,NB+1
              IA1 = IBCON1(IEL1)+NVAL
              IS2 = IOB(IA1)
C
              CALL STR0VA(IBCON1,IBCON2,NB+1,IEL1,NVAL,NVAL,IPER2)
              IPB0 = POSDET(NACT,NB,IBCON2,IFA)
              ICAB = ISPB(IPB0)
C
C
C LOOP OVER ALPHA DEXCITES INTO ACTIVE IA2
C
           IST = 1
           IEN = IACON1(1)-1
           IF (NA.EQ.1) IEN=NACT
           DO 5910 KKJ=1,NA
              DO 5912 JJ=IST,IEN
                 IA2 = JJ + NVAL
                 IS1 = IOB(IA2)
                 IP1 = IMUL(IS1,IS2)
                 IF (IP1.NE.ISYT) GOTO 5912
C
           CALL STR0AE(IACON1,IACON2,NA,KKJ,JJ,IPER)
           IPERT = IPER*IPER2
           IPA0 = POSDET(NACT,NA,IACON2,IFA)
           ITP0 = ISPA(IPA0) + ICAB
           DO III=1,NPTST
              COEFF(III) = CI(ITP0,III)*IPERT
           ENDDO
C
C LOOP OVER BETA VALENCE AND THEN ALPHA EXTERNAL
C
          ICOUNT = 0
          DO 5930 IV=1,NVAL
             IS3 = IOB(IV)
             E0B1V = E0B1 + EFCK(IV)
             IA1V = INPT(IA1) + IV
             IA2A1V = (IA2-1)*M2 + IA1V
C
          DO 5940 IE=1,NEXT
             ICOUNT = ICOUNT + 1
             JE = IE + M1
             IS4 = IOB(JE)
             IP2 = IMUL(IS4,IS3)
             IF (IP1.NE.IP2) GOTO 5940
             DO III=1,NPTST
                TMP4(ICOUNT,III) = E0B1V - EFCK(JE) + EPT0(III)
             ENDDO
C
C MATRIX ELEMENT
C
         T = SVOOO(IE,IA2A1V)
         DO III=1,NPTST
            TMP3(ICOUNT,III) = TMP3(ICOUNT,III) + T*COEFF(III)
         ENDDO
C
 5940     CONTINUE
 5930     CONTINUE
C
C END OF BETA DEXCITES FROM ACTIVE SET IA1
C
 5912         CONTINUE
              IST = IACON1(KKJ)+1
              IEN = IACON1(KKJ+1)-1
              IF (KKJ.EQ.NA-1) IEN=NACT
 5910      CONTINUE
C
 5920      CONTINUE
C
C END OF ALPHA DEXCITES INTO ACTIVE IA2
C
       DO JJ=1,NPTST
       DO KK=1,NPTST
       DO II=1,ICOUNT
       HPT(JJ,KK)=HPT(JJ,KK) + (TMP3(II,JJ)*TMP3(II,KK))/TMP4(II,JJ)
       ENDDO
       ENDDO
       ENDDO
C
       DO JJ=1,NPTST
          DO II=1,ICOUNT
             TMP3(II,JJ) = 0.0D+00
             TMP4(II,JJ) = 1.0D+00
          ENDDO
       ENDDO
C
       ICOUNT = 0
C
               CALL ADVANC(IBCON1,NB+1,NACT)
 5900       CONTINUE
 5901 CONTINUE
C
C ------
C END OF LOOP OVER 1ST ORDER BETAS IV -> IA1
C ------
C
        CALL DDI_DLBNEXT(MY_TASK)
      END IF     ! MY TASK
C
            CALL ADVANC(IACON1,NA-1,NACT)
 5805    CONTINUE
C
C END OF LOOP OVER 1-DOWN ALPHA
C
C END OF EXPERIMENT
C
C -------------------------------------------
C *******************************************
C -------------------------------------------
C
C LOOP OVER ALL 2ND ORDER ALPHA EXCITATIONS
C -------------------------------------------
C *******************************************
C -------------------------------------------
C
      DO II=1,NB
         IBCON1(II) = II
      ENDDO
      DO 6200 IJB=1,NBLP
C
        IF (IJB+NALP+NBUFF+ND1A-1.EQ.MY_TASK) THEN
C
         ICAB = ISPB(IJB)
         ISYB = IMUL(ISYMB(IJB),ISYV)
         E0B0 = -E0V - E0V
         DO II=1,NB
            E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
         ENDDO
C
         IF (NVAL.EQ.0) GOTO 6101
C
C RELOOP OVER 2ND ORDER ALPHAS, (IV1,IV2 -> IA1,IA2)
C
C LOOP OVER 2 UP ALPHAS
C
      DO II=1,NA+2
         IACON1(II) = II
      ENDDO
      DO 6100 IJK=1,N2A
         ISA2 = ISYV
         E0A2 = E0B0
         DO II=1,NA+2
            E0A2 = E0A2 - EFCK(IACON1(II)+NVAL)
            ISA2 = IMUL(ISA2,IOB(IACON1(II)+NVAL))
         ENDDO
         ITAS = ITAB(ISA2)
         ISYL = IMUL(ITAS,ISYB)
C
C LOOP OVER DEXCITATIONS FROM ALPHA (IA1<IA2)
C
       DO 6120 IEL1=1,NA+2
          IA1 = IACON1(IEL1)+NVAL
          IS1 = IOB(IA1)
          IA1T = INPT(IA1)
C
       DO 6130 IEL2=IEL1+1,NA+2
          IA2 = IACON1(IEL2)+NVAL
          IS2 = IOB(IA2)
          IP1 = IMUL(IS1,IS2)
          IF (IP1.NE.ISYL) GOTO 6130
          IA2T = INPT(IA2)
C
C DETERMINE 0TH ORDER ALPHA, POS/PERM
C
      CALL STR0VVAA(IACON1,IACON2,NA+2,IEL1,IEL2,NVAL,NVAL,NVAL,IPER)
      IPA0 = POSDET(NACT,NA,IACON2,IFA)
      ITP0 = ISPA(IPA0) + ICAB
      DO III=1,NPTST
         COEFF(III) = CI(ITP0,III)*IPER
      ENDDO
C
C NOW TO LOOP OVER ALPHA VALENCE, IV1<IV2
C
      ICOUNT = 0
      DO 6140 IV1=1,NVAL
         IS3 = IOB(IV1)
         E0BV = E0A2 + EFCK(IV1)
         IA1V1 = IA1T + IV1
         IA2V1 = IA2T + IV1
         IA2V1T = INPT(IA2V1)
C
      DO 6150 IV2=1,IV1-1
         ICOUNT = ICOUNT + 1
         IS4 = IOB(IV2)
         IP2 = IMUL(IS4,IS3)
         IF (IP1.NE.IP2) GOTO 6150
         DO III=1,NPTST
            TMP4(ICOUNT,III) = E0BV + EFCK(IV2) + EPT0(III)
         ENDDO
C
C MATRIX ELEMENT
C
      IA1V2 = IA1T + IV2
      IA2V2 = IA2T + IV2
      INT1 = INPT(IA2V2) + IA1V1
      INT2 = IA2V1T + IA1V2
      T = SI2(INT1) - SI2(INT2)
      DO III=1,NPTST
         TMP3(ICOUNT,III) = TMP3(ICOUNT,III) + T*COEFF(III)
      ENDDO
C
 6150 CONTINUE
 6140 CONTINUE
C
C END OF LOOP OVER VALENCE IV1<IV2
C
 6130 CONTINUE
 6120 CONTINUE
C
C END OF LOOP OVER DEXCITATIONS FROM ALPHA (IA1<IA2)
C
       DO JJ=1,NPTST
       DO KK=1,NPTST
       DO II=1,ICOUNT
       HPT(JJ,KK)=HPT(JJ,KK) +(TMP3(II,JJ)*TMP3(II,KK))/TMP4(II,JJ)
       ENDDO
       ENDDO
       ENDDO
C
       DO JJ=1,NPTST
          DO II=1,ICOUNT
             TMP3(II,JJ) = 0.0D+00
             TMP4(II,JJ) = 1.0D+00
          ENDDO
       ENDDO
C
       ICOUNT = 0
C
         CALL ADVANC(IACON1,NA+2,NACT)
 6100 CONTINUE
C
C END OF LOOP OVER 2 UP ALPHAS
C
C END RELOOP OVER 2ND ORDER ALPHAS, (IV1,IV2 -> IA1,IA2)
C
C -------------------------------------------
C *******************************************
C -------------------------------------------
C
C -----------------------------------------------
C LOOP OVER 2ND ORDER ALPHA EXCITES, (IV,IA -> IE1,IE2)
C THESE GO WITH 0TH ORDER BETAS
C -----------------------------------------------
C THESE EXCITATIONS ALSO INCLUDE IV(B),IA(A) -> IE1(B)<IE2(A)
C AND                            IV(B),IA(A) -> IE1(A)<IE2(B)
C AND                            IV(B),IA(A) -> IE1(B),IE1(A)
C
         ITAS = ITAB(ISYB)
C
C LOOP OVER 1 DOWN ALPHAS
C
      DO II=1,NA-1
         IACON1(II) = II
      ENDDO
      DO 8030 IJK=1,ND1A
         ISYA0 = ISYV
         E0A0 = E0B0
         DO II=1,NA-1
            E0A0 = E0A0 - EFCK(IACON1(II)+NVAL)
            ISYA0 = IMUL(ISYA0,IOB(IACON1(II)+NVAL))
         ENDDO
         IMS = IMUL(ISYA0,ITAS)
C
C LOOP OVER DEXCITATIONS INTO ACTIVE (IE2 -> IA)
C
         IST = 1
         IEN = IACON1(1)-1
         IF (NA.EQ.1) IEN=NACT
         DO 8050 KKJ=1,NA
            DO 8052 JJ=IST,IEN
               IA = JJ + NVAL
               IS3 = IOB(IA)
               IF (IS3.NE.IMS) GOTO 8052
C
C DETERMINE 0TH ORDER ALPHA STRING, POS/PERM AND MATRIX ELEMENT
C
        CALL STR0AE(IACON1,IACON2,NA,KKJ,JJ,IPER2)
        IPA0 = POSDET(NACT,NA,IACON2,IFA)
        ITP0 = ICAB + ISPA(IPA0)
        DO III=1,NPTST
           COEFF(III) = CI(ITP0,III)*IPER2
        ENDDO
C
C LOOP OVER DOUBLE ALPHA DEXCITATIONS (IE1<IE2 -> IV,IA)
C
      ICOUNT = 0
C
      DO 8000 JE1=NQS,NQQ
         IS1 = IOB(JE1)
         IP1 = IMUL(IS3,IS1)
         E0A0E = E0A0 - EFCK(JE1)
         JDA = (JE1-M1-1)*M1 + IA
         JDAT = INPT(JDA)
C
      DO 8010 IV=1,NVAL
         IS2 = IOB(IV)
         IPT = IMUL(IS2,IP1)
         E0A0EV = E0A0E + EFCK(IV)
         JDV = JDA - IA + IV
         JDVT = INPT(JDV)
C
      DO 8020 JE2=NQS,JE1-1
         IS4 = IOB(JE2)
         IF (IS4.NE.IPT) GOTO 8020
         ICOUNT = ICOUNT + 1
         DO III=1,NPTST
            TMP4(ICOUNT,III)= E0A0EV-EFCK(JE2) + EPT0(III)
         ENDDO
C
C DETERMINE MATRIX ELEMENT
C
C ME = [IE1,IV | IE2,IA] - [IE1,IA | IE2,IV]
C
       IDV = (JE2-M1-1)*M1 + IV
       IDA = IDV - IV + IA
       INT1 = JDVT + IDA
       INT2 = JDAT + IDV
       T1 = SVOVO(INT1)
       T2 = SVOVO(INT2)
       TT = T1 - T2
C
       DO III=1,NPTST
          TMP1(ICOUNT,III) = TMP1(ICOUNT,III) + T1*COEFF(III)
          TMP2(ICOUNT,III) = TMP2(ICOUNT,III) + T2*COEFF(III)
          TMP3(ICOUNT,III) = TMP3(ICOUNT,III) + TT*COEFF(III)
       ENDDO
C
 8020 CONTINUE
C
C IE1 = IE2
C
       IF (IS3.NE.IS2) GOTO 8010
       ICOUNT = ICOUNT + 1
       DO III=1,NPTST
          TMP4(ICOUNT,III) = E0A0EV - EFCK(JE1) + EPT0(III)
       ENDDO
       INT1 = JDAT + JDV
       T1 = SVOVO(INT1)
       DO III=1,NPTST
          TMP1(ICOUNT,III) = TMP1(ICOUNT,III) + T1*COEFF(III)
       ENDDO
C
 8010 CONTINUE
C
 8000 CONTINUE
C
C END OF DOUBLE ALPHA DEXCITATIONS ( IE1<IE2 -> IV,IA)
C
 8052          CONTINUE
               IST = IACON1(KKJ)+1
               IEN = IACON1(KKJ+1)-1
               IF (KKJ.EQ.NA-1) IEN=NACT
 8050       CONTINUE
C
C END OF ALPHA DEXCITATIONS (IE2 -> IA)
C
CFORNOW
C
       DO JJ=1,NPTST
       DO KK=1,NPTST
       DO II=1,ICOUNT
          HPT(JJ,KK) = HPT(JJ,KK) +
     *    (TMP1(II,JJ)*TMP1(II,KK)+
     *     TMP2(II,JJ)*TMP2(II,KK)+
     *     TMP3(II,JJ)*TMP3(II,KK))
     *    /TMP4(II,JJ)
       ENDDO
       ENDDO
       ENDDO
C
       DO JJ=1,NPTST
          DO II=1,ICOUNT
             TMP1(II,JJ) = 0.0D+00
             TMP2(II,JJ) = 0.0D+00
             TMP3(II,JJ) = 0.0D+00
             TMP4(II,JJ) = 1.0D+00
          ENDDO
       ENDDO
C
       ICOUNT = 0
C
         CALL ADVANC(IACON1,NA-1,NACT)
 8030 CONTINUE
 6101 CONTINUE
C
C END OF LOOP OVER DOWN 1 ALPHAS
C
C --------------------------------------------------
C END LOOP OVER 2ND ORDER ALPHA EXCITES (IV,IA -> IE1,IE2)
C THEY GO WITH 0TH ORDER BETAS
C --------------------------------------------------
C
C --------------------------------------------------
C **************************************************
C --------------------------------------------------
C
C LOOP OVER 2ND ORDER ALPHAS, (IA1,IA2 -> IE1,IE2)
C
      DO II=1,NA-2
         IACON1(II) = II
      ENDDO
      DO 9020 IJK=1,ND2A
         E0A0 = E0B0
         ISA0 = ISYV
         DO II=1,NA-2
            E0A0 = E0A0 - EFCK(IACON1(II)+NVAL)
            ISA0 = IMUL(ISA0,IOB(IACON1(II)+NVAL))
         ENDDO
C
C LOOP OVER DOUBLE ALPHA DEXCITATIONS ( IE1<IE2 -> IA1<IA2 )
C
            IST = 1
            IEN = IACON1(1)-1
            IF (NA.EQ.2) IEN=NACT
            DO 9040 KKJ=1,NA-1
               DO 9042 JJ=IST,IEN
                  IA1 = JJ + NVAL
                  IS3 = IOB(IA1)
                  ISYAE1 = IMUL(ISA0,IS3)
                  CALL STR0AE(IACON1,IACON2,NA-1,KKJ,JJ,IPER)
C
            IST2 = JJ+1
            IEN2 = IEN
            DO 9050 KKJ2=KKJ+1,NA
               DO 9052 JJ2=IST2,IEN2
                  IA2 = JJ2 + NVAL
                  IS4 = IOB(IA2)
                  ISYAE2 = IMUL(ISYAE1,IS4)
                  ITAS = ITAB(ISYAE2)
                  IF (ISYB.NE.ITAS) GOTO 9052
                  IP2 = IMUL(IS4,IS3)
C
C DETERMINE NEW 0TH ORDER ALPHA, POS/PERM AND MATRIX ELEMENT
C
         CALL STR0AE(IACON2,IBCON2,NA,KKJ2,JJ2,IPER2)
         IPERT = IPER*IPER2
         IPA0 = POSDET(NACT,NA,IBCON2,IFA)
         ITP0 = ISPA(IPA0) + ICAB
         DO III=1,NPTST
            COEFF(III) = CI(ITP0,III)*IPERT
         ENDDO
C
      ICOUNT = 0
      DO 9000 JE1=NQS,NQQ
         IS1 = IOB(JE1)
         E0AE1 = E0A0 - EFCK(JE1)
         IE1A1 = (JE1-M1-1)*M1 + IA1
         IE1A2 = IE1A1 - IA1 + IA2
         IE1A1T = INPT(IE1A1)
         IE1A2T = INPT(IE1A2)
C
      DO 9010 JE2=NQS,JE1-1
         ICOUNT = ICOUNT + 1
         IS2 = IOB(JE2)
         IP1 = IMUL(IS1,IS2)
C
         IF (IP1.NE.IP2) GOTO 9010
         DO III=1,NPTST
            TMP4(ICOUNT,III) = E0AE1 - EFCK(JE2) + EPT0(III)
         ENDDO
C
C ME = [IE2,IA2 | IE1,IA1] - [IE2,IA1 | IE1,IA2]
C
         IE2A1 = (JE2-M1-1)*M1 + IA1
         IE2A2 = IE2A1 - IA1 + IA2
         INT1 = IE1A1T + IE2A2
         INT2 = IE1A2T + IE2A1
         T = SVOVO(INT1) - SVOVO(INT2)
         DO III=1,NPTST
            TMP3(ICOUNT,III) = TMP3(ICOUNT,III) + COEFF(III)*T
         ENDDO
C
 9010 CONTINUE
 9000 CONTINUE
C
 9052          CONTINUE
               IST2 = IACON2(KKJ2)+1
               IEN2 = IACON2(KKJ2+1)-1
               IF (KKJ2.EQ.NA-1) IEN2=NACT
 9050       CONTINUE
C
 9042          CONTINUE
               IST = IACON1(KKJ)+1
               IEN = IACON1(KKJ+1)-1
               IF (KKJ.EQ.NA-2) IEN=NACT
 9040       CONTINUE
C
CFORNOW
C
         DO JJ=1,NPTST
         DO KK=1,NPTST
         DO II=1,ICOUNT
         HPT(JJ,KK)=HPT(JJ,KK)+(TMP3(II,JJ)*TMP3(II,KK))/TMP4(II,JJ)
         ENDDO
         ENDDO
         ENDDO
C
         DO JJ=1,NPTST
            DO II=1,ICOUNT
               TMP3(II,JJ) = 0.0D+00
               TMP4(II,JJ) = 1.0D+00
            ENDDO
         ENDDO
C
         ICOUNT = 0
C
C END OF LOOP OVER DOUBLE ALPHA DEXCITATIONS ( IE1<IE2 -> IA1<IA2 )
C
         CALL ADVANC(IACON1,NA-2,NACT)
 9020 CONTINUE
C
C END OF LOOP OVER DOWN 1 ORDER ALPHAS
C
C END LOOP OVER 2ND ORDER ALPHAS, (IA1,IA2 -> IE1,IE2)
C
        CALL DDI_DLBNEXT(MY_TASK)
      END IF     ! MY TASK
C
            CALL ADVANC(IBCON1,NB,NACT)
 6200    CONTINUE
C
         IF (NVAL.EQ.0) THEN
            CALL DDI_DLBRESET
            RETURN
         END IF
C
C ------------------------------------------------------------
C NOW FOR THE FINAL CONTRIBUTION, WHICH IS IV1,IV2 -> IE1,IE2
C AS DAVIDSON ET AL POINTED OUT (J. CHEM. PHYS. 1994,100,3672)
C FOR EACH EXCITATION, THERE IS ONLY ONE VIRTUAL DETERMINANT
C WHICH SIMPLIFIES THINGS INCREDIBLY !!!!!!!!!!!!!!!!!!!!!!!!
C ------------------------------------------------------------
C
C LOOP OVER 0TH ORDER ALPHAS FIRST
C
      DO II=1,NA
         IACON1(II) = II
      ENDDO
      ICIT = 0
      E0A0 = -E0V - E0V
      DO 9500 IJK4=1,NALP
C
        IF (IJK4+NALP+NBUFF+ND1A+NBLP-1.EQ.MY_TASK) THEN
C
         ICIT = ISPA(IJK4)
         ISA0 = ISYMA(IJK4)
         ITAS = ITAB(ISA0)
         E0A2 = E0A0
         DO II=1,NA
            E0A2 = E0A2 - EFCK(IACON1(II)+NVAL)
         ENDDO
C
C LOOP OVER CORRECT 0TH ORDER BETAS
C
         DO II=1,NB
            IBCON1(II)=II
         ENDDO
         DO 9510 INB1 = 1,NBLP
            IF (ISYMB(INB1).NE.ITAS) GOTO 9509
            E0B0 = E0A2
            DO II=1,NB
               E0B0 = E0B0 - EFCK(IBCON1(II)+NVAL)
            ENDDO
            ICIT = ICIT + 1
            DO JJ=1,NPTST
               DO KK=1,NPTST
                  TMP1(JJ,KK) = 2.0D+00*CI(ICIT,JJ)*CI(ICIT,KK)
                  HINT(JJ,KK) = 0.0D+00
               ENDDO
            ENDDO
C
C LOOP OVER ALL POSSIBLE EXCITATIONS
C
            IE1T = -M1
            DO 9542 JE1=NQS,NQQ
               IS1 = IOB(JE1)
               E0B0E = E0B0 - EFCK(JE1)
               IE1T = IE1T + M1
            DO 9544 IV1=1,NVAL
               IS2 = IOB(IV1)
               IP1 = IMUL(IS1,IS2)
               E0B0EV = E0B0E + EFCK(IV1)
               IE1V1 = IE1T + IV1
C
            IE2T = -M1
            DO 9552 JE2=NQS,JE1-1
               IS3 = IOB(JE2)
               IPT  = IMUL(IS3,IP1)
               E0B0EVE = E0B0EV - EFCK(JE2)
               IE2T = IE2T + M1
               IE2V1 = IE2T + IV1
               INT1T = INPT(IE1V1) + IE2T
            DO 9553 IV2 = 1,IV1-1
               IS4 = IOB(IV2)
               IF (IS4.NE.IPT) GOTO 9553
               E0B0EVEV = E0B0EVE + EFCK(IV2)
               IE1V2 = IE1T + IV2
C
               INT1 = INT1T + IV2
               INT2 = INPT(IE1V2) + IE2V1
               T1 = SVOVO(INT1)
               T2 = SVOVO(INT2)
               TT = T1 - T2
        DO JJ=1,NPTST
        DO KK=1,NPTST
           HINT(JJ,KK)=HINT(JJ,KK) +
     *   (T1*T1 + T2*T2 + TT*TT)/(E0B0EVEV+EPT0(JJ))
        ENDDO
        ENDDO
C
 9553       CONTINUE
C
C IV2 = IV1, JE1>JE2
C
            IF (IS2.NE.IPT) GOTO 9552
            E0B0EVEV = E0B0EVE + EFCK(IV1)
            INT1 = INPT(IE1V1) + IE2V1
            T1 = SVOVO(INT1)
            DO JJ=1,NPTST
            DO KK=1,NPTST
            HINT(JJ,KK)=HINT(JJ,KK) + (T1*T1)/(E0B0EVEV+EPT0(JJ))
            ENDDO
            ENDDO
C
 9552       CONTINUE
C
C NOW FOR JE1=JE2, IV1>IV2
C
            IPT = IMUL(IS1,IP1)
            E0B0EVE = E0B0EV - EFCK(JE1)
            DO 9554 IV2 = 1,IV1-1
               IS4 = IOB(IV2)
               IF (IS4.NE.IPT) GOTO 9554
               E0B0EVEV = E0B0EVE + EFCK(IV2)
               IE1V2 = IE1T + IV2
               INT1 = INPT(IE1V1) + IE1V2
               T1 = SVOVO(INT1)
               DO JJ=1,NPTST
               DO KK=1,NPTST
               HINT(JJ,KK)=HINT(JJ,KK) + (T1*T1)/(E0B0EVEV+EPT0(JJ))
               ENDDO
               ENDDO
C
 9554       CONTINUE
C
C NOW FOR JE1=JE2,IV1=IV2
C
             E0B0EVEV = E0B0EV + EFCK(IV1) - EFCK(JE1)
             INT1 = INPT(IE1V1+1)
             T1 = SVOVO(INT1)
             DO JJ=1,NPTST
             DO KK=1,NPTST
             HINT(JJ,KK)=HINT(JJ,KK) +
     *       0.5D+00*(T1*T1)/(E0B0EVEV+EPT0(JJ))
             ENDDO
             ENDDO
C
 9544       CONTINUE
 9542       CONTINUE
C
         DO JJ=1,NPTST
         DO KK=1,NPTST
            HPT(JJ,KK) = HPT(JJ,KK) + TMP1(JJ,KK)*HINT(JJ,KK)
         ENDDO
         ENDDO
C
C
 9509      CALL ADVANC(IBCON1,NB,NACT)
 9510    CONTINUE
C
C END OF CORRECT 0TH ORDER BETAS
C
        CALL DDI_DLBNEXT(MY_TASK)
      END IF     ! MY TASK
C
         CALL ADVANC(IACON1,NA,NACT)
 9500 CONTINUE
C
C END OF LOOP OVER 0TH ORDER ALPHAS
C
      CALL DDI_DLBRESET   ! MMRPT
      RETURN
      END
C
C*MODULE DEMRPT  *DECK RDOOOO
C     ------------------------------------
      SUBROUTINE RDOOOO(X2,NCORE,M1,M4,XX)
C     ------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION X2(M4),XX(*)
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C  DDI ARRAY HANDLES
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
C     -- Read 2 e- transformed integrals oooo into replicated memory --
C     Only integrals in the val+act space, between NCORE and NCORE+M1
C     are returned in the X2 array.  The 2e- integrals are
C     in distributed memory.
C
      CALL VCLR(X2,1,M4)
C
      CALL DDI_DISTRIB(D_OOOO,ME,ILO,IHI,JLO,JHI)
C
      NACT = M1
      NOCC = NACT + NCORE
      NOTR = (NOCC*NOCC+NOCC)/2
      DO I = 1, NACT
        IN = I + NCORE
        DO J = 1, I
          JN = J + NCORE
          IJ = (I*I-I)/2 + J
          IJN = (IN*IN-IN)/2 + JN
          IF ((IJN.GE.JLO).AND.(IJN.LE.JHI)) THEN
            CALL DDI_GET(D_OOOO,1,NOTR,IJN,IJN,XX)
            DO K = 1, NACT
              KN = K + NCORE
              DO L = 1, K
               LN = L + NCORE
                KL = (K*K-K)/2 + L
                IF (IJ.GE.KL) THEN
                  KLN = (KN*KN-KN)/2 + LN
                  IJKL = (IJ*IJ-IJ)/2 + KL
                  X2(IJKL) = XX(KLN)
                END IF
              END DO
            END DO
          END IF ! LOCAL STRIPE
        END DO ! J
      END DO ! I
C
      CALL DDI_GSUMF(2500,X2,M4)
C
      RETURN
      END
C
C*MODULE DEMRPT  *DECK RDVOOO
C     ----------------------------------------------------------
      SUBROUTINE RDVOOO(X2,NCORE,M1,NEXT,XX)
C     ----------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION X2(NEXT,*),XX(NEXT)
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C  DDI ARRAY HANDLES
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
C     -- Read 2 e- transformed integrals vooo into replicated memory --
C     o = m1 (includes nval, but not ncore), v = next.
C     The 2e- integrals are in distributed memory.
C
C Size of X2
C
      M2 = (M1*(M1+1))/2
      NOOO = M2*M1
      NVOOO = NOOO*NEXT
      NOCC = M1 + NCORE
C
      DO II=1,NOOO
         CALL VCLR(X2(1,II),1,NEXT)
      ENDDO
C
      CALL DDI_DISTRIB(D_VOOO,ME,ILO,IHI,JLO,JHI)
C
      DO I=1,M1
         IIND = (I*(I-1))/2
         NI = I + NCORE
         NIND = (NI*(NI-1))/2
         DO J=1,I
            IJ = IIND + J
            NJ = J + NCORE
            IJCOL = (NIND + NJ - 1)*NOCC
            DO K=1,M1
               NK = K + NCORE
               IJKCOL = IJCOL + NK
               IF ((IJKCOL.GE.JLO).AND.(IJKCOL.LE.JHI)) THEN
                  CALL DDI_GET(D_VOOO,1,NEXT,IJKCOL,IJKCOL,XX)
                  KIJ = (K-1)*M2 + IJ
                  DO IE=1,NEXT
                     X2(IE,KIJ) = XX(IE)
                  ENDDO
               ENDIF
            ENDDO ! K
         ENDDO ! J
      ENDDO ! I
C
      CALL DDI_GSUMF(2500,X2,NVOOO)
C
      RETURN
      END
C
C*MODULE DEMRPT  *DECK RDVOVO
C     ----------------------------------------------------------
      SUBROUTINE RDVOVO(X2,NCORE,M1,NEXT,XX)
C     ----------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION X2(*),XX(NEXT*NEXT)
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C  DDI ARRAY HANDLES
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
C     -- Read 2 e- transformed integrals vovo into replicated memory --
C     o = m1 (includes nval, but not ncore), v = next.
C     The 2e- integrals are in distributed memory.
C
C Size of X2
C
      NVTR = NEXT*NEXT
      NVO = M1*NEXT
      NVOVO = (NVO*(NVO+1))/2
C
      CALL VCLR(X2,1,NVOVO)
C
      CALL DDI_DISTRIB(D_VOVO,ME,ILO,IHI,JLO,JHI)
C
      DO I=1,M1
         NI = I + NCORE
         NIND = (NI*(NI-1))/2
         DO J=1,I
            NJ = J + NCORE
            IJCOL = NIND + NJ
            IF ((IJCOL.GE.JLO).AND.(IJCOL.LE.JHI)) THEN
               CALL DDI_GET(D_VOVO,1,NVTR,IJCOL,IJCOL,XX)
               DO JV=1,NEXT
                  JVJ = (JV-1)*M1 + J
                  JVJND1 = (JVJ*(JVJ-1))/2
                  JVIND2 = (JV-1)*NEXT
                  DO IV=1,JV-1
                     IVI = (IV-1)*M1 + I
                     INT1 = JVJND1 + IVI
                     NIVJV = JVIND2 + IV
                     X2(INT1) = XX(NIVJV)
                  ENDDO
                  IVI = (JV-1)*M1 + I
                  INT1 = (IVI*(IVI-1))/2 + JVJ
                  NIVJV = JVIND2 + JV
                  X2(INT1) = XX(NIVJV)
                  IF (I.NE.J) THEN
                     DO IV=JV+1,NEXT
                        IVI = (IV-1)*M1 + I
                        INT1 = (IVI*(IVI-1))/2 + JVJ
                        NIVJV = JVIND2 + IV
                        X2(INT1) = XX(NIVJV)
                     ENDDO
                  ENDIF
               ENDDO
            ENDIF
         ENDDO  ! J
      ENDDO ! I.GE.J
C
      CALL DDI_GSUMF(2500,X2,NVOVO)
C
      RETURN
      END
