C 11 APR 08 - JI  - FCHCX1S,FCHXYS,FCHC01S,FCHC0YS,MASDM2: FIXES
C  7 DEC 07 - MWS - ORDET: OPTION TO SKIP INPUT IF CI IS TO BE HARDWIRED
C 25 JUN 07 - TN  - CHANGES FOR CEEIS
C 24 MAR 07 - AA  - ORDET,FCHCX1S,FCHCXYS,FCHC01S,FCHC0YS: REP.MEM.PAR.
C 22 DEC 06 - MWS - ADJUST WAVEFUNCTION COMMON BLOCK
C  7 SEP 06 - TJD - ORDET: SET C1 SYMMETRY FOR ANALYTIC HESSIAN
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  5 JUL 05 - MWS - TIGHT CI CONVERGENCE IF MRPT/STRAIGHT CI/GRADIENT
C 27 JUN 05 - JI  - IMPLEMENT DIRECT OPTION (FINALLY)
C  1 JUN 05 - MWS - DETINP: SA-MC DERIV. TRAP ALLOWS NUM. DIFFERENCING
C  5 FEB 05 - JI  - DAFCCI: FIX SPIN PURIFICATION ON 1ST ITERATION
C  7 SEP 04 - MWS - PAD COMMON BLOCK INTFIL
C  9 JUN 04 - MWS - IMPLEMENT CLOBBR, PURIFY CI VECS BEFORE ITERS
C  7 APR 04 - JI  - ADD DAVIDSON + Q CORRECTION FOR MR-CISD TYPE ORMAS.
C  9 DEC 03 - MWS - SYNCH COMMON BLOCK RUNOPT
C  4 NOV 03 - MWS - ENABLE PARALLEL SOSCF RUNS
C 16 JUN 03 - JAB - DAFCCI: WORK AROUND CRAY READ ERRORS
C 15 MAY 03 - MWS - PRINT VECTORS IF RIGHT SPINS NOT FOUND
C 26 MAR 03 - JI  - ADJUST H*C CALCULATION TO FIX FOR CRAZY OCCUPATIONS
C 14 JAN 03 - JI  - ADD NEW DIRECT DETERMINANT ORMAS-CI CODE TO GAMESS
C
C  ORMAS STANDS FOR OCCUPATION RESTRICTED MULTIPLE ACTIVE SPACE.
C  I ORIGINALLY CALLED THIS FULL CLASS CI, WHICH EXPLAINS WHY
C  SOME THINGS ARE LABELLED FC---.
C
C*MODULE ORMAS1  *DECK ORDET
C     -----------------------------
      SUBROUTINE ORDET(NRNFG,NPFLG)
C     -----------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION NRNFG(10),NPFLG(10)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,DOEXCH,DDITRF,CLABEL,
     *        FDIRCT,QCORR,RDINP,
     *        DOOOOO,DOVOOO,DOVVOO,DOVOVO,DOVVVO,DOVVVV,DOCORE
C
      PARAMETER (MXRT=100)
C
      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 /FCCWFN/ NSPACE,MSTA(51),MNUM(51),MINI(51),MAXI(51),
     *                IAMI(51),IAMA(51),IBMI(51),IBMA(51),IDIM(51),
     *                LBST(51),NREF0,FDIRCT,QCORR,C0SQ
      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
      COMMON /VVOPAR/ IVVOS,NVVOS,BNDDEN
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
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 CIDET /8HCIDET   /
      DATA ORMAS /8HORMAS   /
      DATA RNONE /8HNONE    /
      DATA BNDANA/8HBONDANAL/
C
C        DRIVER FOR FULL CLASS CI CALCULATIONS...
C
C        ----- READ INPUT DEFINING THE FULL CLASS CI DIMENSIONS -----
C     ASSUMING THAT -DETWFN- AND -FCCWFN- HAVE BEEN FILLED PROPERLY,
C     WE CAN SKIP READING THE INPUT DEFINING THE CI CALCULATION.
C
      RDINP = .TRUE.
      IF(RUNTYP.EQ.BNDANA) THEN
         RDINP=.FALSE.
         IF(BNDDEN.EQ.ORMAS) RDINP=.TRUE.
      ENDIF
      IF(RDINP) CALL FCINPUT(NPFLG(1),CIDET,ORMAS)
C
C        ----- INTEGRAL TRANSFORMATION -----
C
      DDITRF=GOPARR
      DOOOOO=.TRUE.
      DOVOOO=.FALSE.
      DOVVOO=.FALSE.
      DOVOVO=.FALSE.
      DOVVVO=.FALSE.
      DOVVVV=.FALSE.
      DOCORE=.TRUE.
      DOEXCH=SCFTYP.EQ.RNONE
      CALL TRFMCX(NPFLG(2),NCOR,NORB,NORB,.FALSE.,DOEXCH,
     *            DDITRF,DOOOOO,DOVOOO,DOVVOO,DOVOVO,
     *            DOVVVO,DOVVVV,DOCORE)
C
C        ----- DIRECT ORMAS CI CALCULATION -----
C
                 CLABEL=.FALSE.
      IF(GOPARR) CLABEL=.TRUE.
      CALL DEFCCI(NPFLG(3),CLABEL,DDITRF,
     *            NRNFG(5),NRNFG(6),NPFLG(5),NPFLG(6))
C
      NSTATE=K
      IF (QCORR  .AND.  NSTATE.EQ.1) THEN
C
         EMRCISD = ETOT
         IF(MASWRK) WRITE(IW,9010)
         IF(MASWRK) WRITE(IW,9020) EMRCISD
         IF(MASWRK) WRITE(IW,9025) C0SQ
C
         NSPACE = NSPACE - 1
         IF (NSPACE.GT.1) THEN
            MINI(NSPACE) = MINI(NSPACE) + 2
            MAXI(NSPACE) = MAXI(NSPACE) - 2
         ENDIF
         MINI(1)      = MINI(1) + 2
         MAXI(1)      = MINI(1)
C
         IF(MASWRK) WRITE(IW,9030)
         IF(MASWRK) WRITE(IW,9040) NSPACE,(MSTA(I),I=1,NSPACE)
         IF(MASWRK) WRITE(IW,9050) (MNUM(I),I=1,NSPACE)
         IF(MASWRK) WRITE(IW,9060) (MINI(I),I=1,NSPACE)
         IF(MASWRK) WRITE(IW,9070) (MAXI(I),I=1,NSPACE)
C
         CALL FCCHECK(IW,.FALSE.,NSPACE,MNUM,MINI,MAXI,
     *                IAMI,IAMA,IBMI,IBMA,NA,NB)
C
         CALL DEFCCI(-5,CLABEL,DDITRF,0,0,NPFLG(5),NPFLG(6))
C
         EREF0 = ETOT
         IF(MASWRK) WRITE(IW,9080) EREF0
         IF(MASWRK) WRITE(IW,9090)
C
         ELOW = EREF0 - EMRCISD
         EQ   = ELOW*(1.0D+00 - C0SQ)/C0SQ
         ESDQ = EMRCISD - EQ
         IF(MASWRK) WRITE(IW,9100) ESDQ
         IF(MASWRK) WRITE(IW,9110)
         IF(MASWRK) WRITE(IW,9120)
C
         ETOT = EMRCISD
      ENDIF
C
      IF(DDITRF  .AND.  RUNTYP.NE.BNDANA) THEN
         IF(MASWRK) WRITE(IW,9140) D_OOOO
         CALL DDI_DESTROY(D_OOOO)
      END IF
      RETURN
C
 9010 FORMAT(/3X,44(1H-)/
     *   3X,'  DETERMINATION OF DAVIDSON + Q CORRECTION'/
     *   3X,44(1H-))
 9020 FORMAT(/1X,'E(MR-CISD) =    ',F20.10)
 9025 FORMAT(/1X,'REF WEIGHT =    ',F20.10)
 9030 FORMAT(/1X,'*** CALCULATION OF REFERENCE ENERGY     ***')
 9040 FORMAT(/1X,'THE NUMBER OF SPACES             =',I4/
     *        1X,'EACH SPACE STARTS AT ORBITAL     =',50I4)
 9050 FORMAT(1X,'NO OF ORBITALS IN EACH SPACE     =',50I4)
 9060 FORMAT(1X,'MIN NO OF ELECS IN EACH SPACE    =',50I4)
 9070 FORMAT(1X,'MAX NO OF ELECS IN EACH SPACE    =',50I4)
 9080 FORMAT(/1X,'E(REF)      =   ',F20.10)
 9090 FORMAT(/1X,'*** END OF REFERENCE ENERGY CALCULATION ***')
 9100 FORMAT(/1X,'E(MRCISD + Q) = ',F20.10)
 9110 FORMAT(/3X,'  END OF DAVIDSON + Q CORRECTION CALC ')
 9120 FORMAT(3X,44(1H-))
 9140 FORMAT(1X,'DESTROYING DDI ARRAY [',I2,'] OF [OO|OO] INTEGRALS')
C
      END
C
C*MODULE ORMAS1  *DECK FCINPUT
C     -----------------------------------------
      SUBROUTINE FCINPUT(NPRINT,GPNAME,GPNAME2)
C     -----------------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL SOME,PURES,GOPARR,DSKWRK,MASWRK,ABEL,WTSOK,ANALYS,
     *        FDIRCT,QCORR,CLOBBR
C
      PARAMETER (MXATM=2000, MXRT=100, MXAO=8192, MXSH=5000)
C
      COMMON /CEEIS0/ ICEEIS
      COMMON /DETPAR/ ICLBBR,ANALYS
      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 /FCCWFN/ NSPACE,MSTA(51),MNUM(51),MINI(51),MAXI(51),
     *                IAMI(51),IAMA(51),IBMI(51),IBMA(51),IDIM(51),
     *                LBST(51),NREF0,FDIRCT,QCORR,C0SQ
      COMMON /FMCOM / X(1)
      COMMON /FMOINF/ NFG,NLAYER,NATFMO,NBDFG,NAOTYP,NBODY
      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 /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /SYMMOL/ GROUP,COMPLEX,IGROUP,NAXIS,ILABMO,ABEL
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(432),INVT(48),NT
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00)
C
      PARAMETER (NNAM=20)
      PARAMETER (NNAM2=6)
C
      DIMENSION QNAM(NNAM),KQNAM(NNAM)
      DIMENSION QNAM2(NNAM2),KQNAM2(NNAM2)
      DIMENSION FANT(8),LFANT(8),GANT(27),LGANT(8)
C
      DATA QNAM/8HGROUP   ,8HISTSYM  ,
     *          8HNCORE   ,8HNACT    ,8HNELS    ,8HSZ      ,
     *          8HNSTATE  ,8HNSTGSS  ,8HNHGSS   ,8HMXXPAN  ,
     *          8HITERMX  ,8HCVGTOL  ,8HPRTTOL  ,
     *          8HIROOT   ,8HNFLGDM  ,8HPURES   ,8HWSTATE  ,
     *          8HWTSOK   ,8HANALYS  ,8HCLOBBR  /
      DATA KQNAM/5,1,   1,1,1,3,  1,1,1,1,   1,3,3,  1,-1,0,-3,   0,0,0/
C
      DATA QNAM2/8HNSPACE  ,8HMSTART  ,8HMINE    ,8HMAXE    ,
     *           8HFDIRCT  ,8HQCORR   /
      DATA KQNAM2/1,511,511,511,0,0/
C
      DATA DET,CIDET/8HDET     ,8HCIDET   /
      DATA HESS/8HHESSIAN /
      DATA RNONE/8HNONE    /
      DATA FANT/8HC1      ,8HCI      ,8HCS      ,8HC2      ,
     *          8HD2      ,8HC2V     ,8HC2H     ,8HD2H     /
      DATA LFANT/1,1,1,1,2,2,2,3/
      DATA GANT/8HA       ,8HAG      ,8HAU      ,8HA'      ,
     *          8HA"      ,8HA       ,8HB       ,8HA       ,
     *          8HB1      ,8HB2      ,8HB3      ,8HA1      ,
     *          8HA2      ,8HB1      ,8HB2      ,8HAG      ,
     *          8HBG      ,8HBU      ,8HAU      ,8HAG      ,
     *          8HB1G     ,8HB2G     ,8HB3G     ,8HAU      ,
     *          8HB1U     ,8HB2U     ,8HB3U     /
      DATA LGANT/0,1,3,5,7,11,15,19/
C
      SOME = MASWRK  .AND.  NPRINT.NE.-5  .AND.  NPRINT.NE.-23
C
      IF(SOME) WRITE(IW,9000)
C
C          SET UP INPUT TO SPECIFY THE CI SPACE
C          SELECT POINT GROUP AND ELECTRON/ORBITAL COUNTS
C
      GRPDET = FANT(1)
      IF(IGROUP.EQ.1)                GRPDET = FANT(1)
      IF(IGROUP.EQ.3)                GRPDET = FANT(2)
      IF(IGROUP.EQ.2)                GRPDET = FANT(3)
      IF(IGROUP.EQ.4.AND.NAXIS.EQ.2) GRPDET = FANT(4)
      IF(IGROUP.EQ.8.AND.NAXIS.EQ.2) GRPDET = FANT(5)
      IF(IGROUP.EQ.7.AND.NAXIS.EQ.2) GRPDET = FANT(6)
      IF(IGROUP.EQ.6.AND.NAXIS.EQ.2) GRPDET = FANT(7)
      IF(IGROUP.EQ.9.AND.NAXIS.EQ.2) GRPDET = FANT(8)
      IF(NT.EQ.1) GRPDET=FANT(1)
      IF(RUNTYP.EQ.HESS  .AND.  NHLEVL.GT.0) GRPDET=FANT(1)
      KSTSYM = 1
C
      NCORE  = 0
      NACT   = 0
      NELS   = 0
      SZ     = (MUL-1)/TWO
C
C          SET UP INPUT TO CONTROL THE DIAGONALIZATION
C
      NSTATE = 1
      NSTGSS = 1
      NHGSS  = 300
      MXXPAN = 10
      ITERMX = 100
      CVGTOL = 1.0D-05
      CALL DERCHK(NDER)
      IF(NDER.GT.0)      CVGTOL=1.0D-06
      IF(MPLEVL.GT.0)    CVGTOL=1.0D-06
      IF(CITYP.NE.RNONE) CVGTOL=1.0D-06
      IF(NFG.NE.0)       CVGTOL=1.0D-06
      PRTTOL = 0.05D+00
C
C          SET UP INPUT TO CONTROL THE FIRST ORDER DENSITY COMPUTATION
C
      IROOT=1
      KQNAM(15)=MXRT*10 + 1
      DO 5 I=1,MXRT
         NFLGDM(I) = 0
    5 CONTINUE
      NFLGDM(1)=1
C
C          SET UP INPUT TO CONTROL THE SECOND ORDER DENSITY COMPUTATION
C
      PURES = .TRUE.
      KQNAM(17)=MXRT*10 + 3
      CALL VCLR(WSTATE,1,MXRT)
      WSTATE(1) = ONE
      WTSOK = .FALSE.
C
C         NOT SURE IF THE CORRELATION ANALYSIS IS EVEN SENSIBLE...
C
      ANALYS = .FALSE.
      CLOBBR = .FALSE.
C
      CALL NAMEIO(IR,JRET,GPNAME,NNAM,QNAM,KQNAM,
     *            GRPDET,KSTSYM,NCORE,NACT,NELS,SZ,NSTATE,NSTGSS,
     *            NHGSS,MXXPAN,ITERMX,CVGTOL,PRTTOL,IROOT,NFLGDM,
     *            PURES,WSTATE,WTSOK,ANALYS,CLOBBR,
     *            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(JRET.EQ.2) THEN
         IF(MASWRK) WRITE(IW,9010) GPNAME
         CALL ABRT
         STOP
      END IF
C
      IGPDET = -1
C
C        ALL HESSIANS FOR MCSCF ARE NUMERICAL RIGHT NOW...
C
      IF ((RUNTYP.EQ.HESS .AND. NHLEVL.GT.0)  .OR.  NT.EQ.1) THEN
         GRPDET=FANT(1)
         KSTSYM=1
      END IF
C
C          SET UP DEFAULT ORMAS INPUT TO DO FCI FOR THE NACT SPACE
C
      NSPACE = 1
      MSTA(1) = NCORE+1
      MSTA(2) = NACT+NCORE+1
      MNUM(1) = NACT
      MINI(1) = NELS
      MAXI(1) = NELS
C
C         SET UP DEFAULTS FOR FDIRCT, QCORR.
C
      IF (GPNAME.EQ.CIDET) FDIRCT=.TRUE.
      IF (GPNAME.EQ.DET)   FDIRCT=.FALSE.
C
      QCORR =.TRUE.
C
      CALL NAMEIO(IR,JRET,GPNAME2,NNAM2,QNAM2,KQNAM2,
     *            NSPACE,MSTA,MINI,MAXI,FDIRCT,QCORR,
     *    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,0,0)
C
      IF (GPNAME.EQ.DET) QCORR = .FALSE.
C        DAVIDSON CORRECTION IS NOT NEEDED FOR CEEIS
      IF (ICEEIS.EQ.1)   QCORR = .FALSE.
C
      IF(JRET.EQ.2) THEN
         IF(MASWRK) WRITE(6,9005) GPNAME2
         CALL ABRT
      END IF
C
C        THE INPUT FOR C2H IS SUPPOSED TO BE IDENTICAL TO THE GUGA
C        ORDER, NAMELY 1,2,3,4=AG,BU,BG,AU, BUT THE CI CODE WANTS
C        THE ORDER OF  1,2,3,4=AG,BG,BU,AU.  SEE ALSO GAJASW ROUTINE.
C
      IF (GRPDET.EQ.FANT(7)) THEN
         MODI = KSTSYM
         IF(KSTSYM.EQ.2) MODI=3
         IF(KSTSYM.EQ.3) MODI=2
         KSTSYM=MODI
      END IF
      DO I=1,8
         IF (GRPDET.EQ.FANT(I)) THEN
            IGPDET=LFANT(I)
            STSYM = GANT(LGANT(I)+KSTSYM)
         ENDIF
      END DO
      IF (IGPDET.EQ.-1) THEN
         IF(MASWRK) WRITE(IW,*) '$DET POINT GROUP IS UNRECOGNIZED!'
         CALL ABRT
         STOP
      ENDIF
      IF (GRPDET.EQ.FANT(1).AND.KSTSYM.GT.1) THEN
         IF(MASWRK) WRITE(IW,*) '$DET STATE SYMM IS NOT CORRECT IRREP'
         CALL ABRT
         STOP
      ENDIF
      IF (KSTSYM.GT.(2**IGPDET)) THEN
         IF(MASWRK) WRITE(IW,*)
     *       '$DET STATE SYMMETRY IS TOO LARGE FOR THIS GROUP'
         CALL ABRT
         STOP
      ENDIF
C
C READ MO SYMMETRIES AND WRITE TO DIRECT ACCESS FILE,
C BUT DON'T DO IF THIS IF WE ARE PEEKING AT THE $DET INPUT
C AT THE MOST EARLY STAGES OF AN INITIAL MCSCF RUN.
C
      IF (NPRINT.EQ.-23) GO TO 1314
C
      L0 = NQMT
      L1 = NUM
      L2 = (L1*L1+L1)/2
      L3 =  L1*L1
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
      NEEDD   = LAST - LOADFM - 1
      CALL GETFM(NEEDD)
C
      IF(GRPDET.EQ.FANT(1)) THEN
         CALL C1DET(X(LMOIRP),X(LMOLAB),L0)
      ELSE
         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)
      END IF
C
C  CHANGE ORBITAL SYMMETRY LABELS FROM GAMESS TO JAKAL VALUES
C
      CALL GAJASW(X(LMOIRP),NUM,GRPDET)
C
      CALL DAWRIT(IDAF,IODA,X(LMOIRP),L1,262,1)
C
C     1.  SET NCORSV,NCOR,NACT,NORB,NA,NB FOR DETERMINANT SPECIFICATION
C         CHECK INPUT, AND COPY INTO INTERNALLY USED VARIABLE NAMES.
C         NCOR WILL BE SET TO ZERO TO DROP CORES, SO NCORSV SAVES THIS.
C
 1314 CONTINUE
      IF(NPRINT.NE.-23  .AND.
     *       (NCORE.LT.0  .OR.  NACT.LE.0  .OR.  NELS.LE.0)) THEN
         IF(MASWRK) WRITE(IW,9020) GPNAME,NCORE,NACT,NELS
         CALL ABRT
         STOP
      END IF
      NCORSV = NCORE
      NCOR   = NCORE
      NORB   = NCORE + NACT
      NHIGH = INT(SZ+SZ+0.0001D+00)
      NB = (NELS-NHIGH)/2
      NA = NB+NHIGH
      MA = NA+NCORSV
      MB = NB+NCORSV
      NELTOT = 2*NCOR+NA+NB
      NERR=0
      IF(NELTOT.NE.NE)  NERR=1
      IF(NELS.NE.NA+NB) NERR=1
      IF(NA.LT.NB)      NERR=1
      IF(NA.LE.0)       NERR=1
      IF(NB.LT.0)       NERR=1
      IF(NPRINT.NE.-23  .AND.  NERR.GT.0) THEN
         IF(MASWRK) WRITE(IW,9030) NCORE,NELS,SZ,ICH,MUL
         CALL ABRT
         STOP
      END IF
      S = (MUL-1)/TWO
C
C        2. SET K,KST,MAXW1,NITER,MAXP,CRIT,PRTTOL FOR DIAGONALIZATION
C
      K     = NSTATE
      KST   = MAX(NSTGSS,K)
      MAXP  = MAX(MXXPAN,2*KST)
      MAXW1 = NHGSS
      NITER = ITERMX
      CRIT  = CVGTOL
      IF(NPRINT.NE.-23  .AND.  K.GT.MXRT) THEN
         IF(MASWRK) WRITE(IW,9035) K,MXRT
         CALL ABRT
         STOP
      END IF
                 ICLBBR=0
      IF(CLOBBR) ICLBBR=1
C
C        3. SETUP FOR 1ST ORDER DENSITY COMPUTATION
C
      IF(IROOT.GT.NSTATE) THEN
         IF(MASWRK) WRITE(IW,9036) IROOT,NSTATE
         CALL ABRT
         STOP
      END IF
      IF(IROOT.GT.MXRT) THEN
         IF(MASWRK) WRITE(IW,9037) IROOT,MXRT
         CALL ABRT
         STOP
      END IF
      IF(NFLGDM(IROOT).EQ.0) NFLGDM(IROOT)=1
C
C        4. SETUP FOR STATE-AVERAGING 1ST AND 2ND ORDER DENSITIES.
C        -IWTS- INDEXES THE NON-ZERO ELEMENTS OF -WSTATE-
C
      IPURES=0
      IF(PURES) IPURES=1
      MXSTAT=0
      WSUM = ZERO
      DO 15 I=1,MXRT
         IF(WSTATE(I).GT.ZERO) THEN
            IF(I.LE.NSTATE) THEN
               WSUM = WSUM + WSTATE(I)
               MXSTAT = MXSTAT+1
               IWTS(MXSTAT) = I
            ELSE
               IF(MASWRK) WRITE(IW,9040) NSTATE
               CALL ABRT
               STOP
            END IF
         END IF
         IF(WSTATE(I).LT.ZERO) THEN
            IF(MASWRK) WRITE(IW,9050)
            CALL ABRT
            STOP
         END IF
   15 CONTINUE
      SCALE = ONE/WSUM
      CALL DSCAL(MXRT,SCALE,WSTATE,1)
C
C        5. CHECK IF DETERMINATION OF DAVIDSON CORRECTION IS MEANINGFUL
C
      IF (QCORR) THEN
         IF (NSPACE.GT.3.OR.NSPACE.LT.2) GO TO 2000
         IF (MAXI(NSPACE).NE.2) GO TO 2000
         IF (MINI(NSPACE).NE.0) GO TO 2000
         IF (MAXI(1)-MINI(1).NE.2) GO TO 2000
         GO TO 3000
 2000    QCORR=.FALSE.
         WRITE(IW,9055)
 3000    CONTINUE
      ENDIF
C
C        IF RUNNING SILENTLY, RETURN WITHOUT PRINTING ANYTHING
C
      IF(NPRINT.EQ.-23) RETURN
C
C     THE COMPUTATION OF THE ENERGY GRADIENT REQUIRES A SYMMETRIC
C     LAGRANGIAN (SINCE GAMESS DOES NOT AT PRESENT DO THE CPHF
C     PROBLEM TO OBTAIN ORBITAL PERTURBATIONS).  ALTHOUGH A STATE
C     AVERAGED MCSCF RUN RESULTS IN A SYMMETRIC "AVERAGE LAGRANGIAN",
C     THE LAGRANGIAN FOR ANY SINGLE STATE USING THE AVERAGED ORBITALS
C     WILL *NOT* BE SYMMETRIC.  HENCE ANY JOB THAT ATTEMPTS TO STATE
C     AVERAGE AND ALSO DO A NUCLEAR GRADIENT SHOULD BE FLUSHED.
C     THERE IS A SECRET INPUT KEYWORD TO AVOID BEING FLUSHED, WHICH
C     MAY BE REASONABLE IF THE STATES BEING AVERAGED ARE DEGENERATE.
C
      CALL DERCHK(MAXDER)
      IF(MXSTAT.GT.1  .AND.  MAXDER.GT.0) THEN
         IF(MAXDER.EQ.1  .AND.  NGLEVL.NE.1) THEN
            IF(WTSOK) THEN
               IF (SOME) WRITE(IW,9061) RUNTYP,MXSTAT
            ELSE
               IF (SOME) WRITE(IW,9062) RUNTYP,MXSTAT
               CALL ABRT
            END IF
         END IF
         IF(MAXDER.EQ.2  .AND.  NHLEVL.NE.2) THEN
            IF (SOME) WRITE(IW,9063) RUNTYP,MXSTAT
            CALL ABRT
         END IF
         IF(IROOT.EQ.0   .AND.  NGLEVL+NHLEVL.GT.0) THEN
            IF(SOME) WRITE(IW,9064)
            CALL ABRT
         END IF
      END IF
C
      IF(SOME) THEN
         WRITE(IW,9100) GRPDET,STSYM,NCOR,NACT,
     *                  NA+NCOR,NA,NB+NCOR,NB,NORB
C
         WRITE(IW,9110) K,KST,MAXP,MAXW1,NITER,CRIT
         IF(GPNAME.EQ.CIDET) THEN
            WRITE(IW,9120) IROOT
            WRITE(IW,9130) (NFLGDM(II),II=1,K)
         END IF
         IF(GPNAME.EQ.DET) THEN
            WRITE(IW,9140) PURES
            WRITE(IW,9150) (IWTS(II),WSTATE(IWTS(II)),II=1,MXSTAT)
            IF(MXSTAT.GT.1) WRITE(IW,9159) IROOT
         END IF
      END IF
C
      IF (SOME) THEN
         WRITE(IW,9155) ANALYS
      ENDIF
C
      IF (SOME) THEN
         WRITE(IW,9157) FDIRCT
         WRITE(IW,9158) QCORR
      ENDIF
C
      IF(SOME) THEN
         WRITE(IW,9160) NCOR,NACT
         CALL MOSYPR(X(LMOLAB),NCOR,NACT)
      ENDIF
C
C    DETERMINE AND WRITE OUT THE ORMAS INFORMATION
C
      MSTA(NSPACE+1) = NACT+NCORE+1
      DO II=1,NSPACE
         MNUM(II) = MSTA(II+1) - MSTA(II)
      ENDDO
C
      IF(SOME) THEN
         WRITE(IW,9170) NSPACE,(MSTA(I),I=1,NSPACE)
         WRITE(IW,9180) (MNUM(I),I=1,NSPACE)
         WRITE(IW,9190) (MINI(I),I=1,NSPACE)
         WRITE(IW,9195) (MAXI(I),I=1,NSPACE)
      ENDIF
C
C     SEND ORMAS INFORMATION FOR CHECKING AND DETERMINATION OF
C     OTHER IMPORTANT INFORMATION.
C
      CALL FCCHECK(IW,SOME,
     *             NSPACE,MNUM,MINI,MAXI,IAMI,IAMA,IBMI,IBMA,
     *             NA,NB)
C
      CALL RETFM(NEEDD)
      RETURN
C
C
 9000 FORMAT(/5X,60(1H-)/
     *   5X,'  DIRECT DETERMINANT ORMAS-CI INPUT SORTER'/
     *   5X,'  PROGRAM WRITTEN BY JOE IVANIC AND MIKE SCHMIDT'/
     *   5X,'  ORMAS = OCCUPATION RESTRICTED MULTIPLE ACTIVE SPACE'/
     *   5X,60(1H-))
 9005 FORMAT(1X,'ERROR READING ',A8,' INPUT GROUP, PLEASE FIX IT.')
 9010 FORMAT(/1X,'**** ERROR, THIS RUN REQUIRES INPUT OF A $',A8,
     *          ' GROUP')
 9020 FORMAT(/1X,'**** ERROR, THIS RUN DOES NOT CORRECTLY SPECIFY',
     *          ' THE FULL CI SPACE'/
     *     1X,'CHECK $',A8,' INPUT: NCORE=',I4,' NACT=',I4,' NELS=',I4)
 9030 FORMAT(/1X,'**** ERROR, $ALDET INPUT NCORE=',I4,' NELS=',I4,
     *          ' SZ=',F6.3/
     *       1X,' IS INCONSISTENT WITH $CONTRL INPUT ICH=',I4,
     *          ' MULT=',I4)
 9035 FORMAT(/1X,'***** ERROR, REQUESTED NUMBER OF CI ROOTS=',I5/
     *        1X,'EXCEEDS THE DIMENSION LIMIT FOR NUMBER OF STATES',I5)
 9036 FORMAT(/1X,'**** ERROR, YOUR STATE SELECTED FOR PROPERTIES=',I5/
     *        1X,'EXCEEDS THE NUMBER OF ROOTS YOU REQUESTED=',I5)
 9037 FORMAT(/1X,'**** ERROR, YOUR STATE SELECTED FOR PROPERTIES=',I5/
     *        1X,'EXCEEDS THE DIMENSION LIMIT FOR NUMBER OF STATES',I5)
 9040 FORMAT(/1X,'**** ERROR, WEIGHTS ASSIGNED TO STATES HIGHER',
     *          ' THAN NSTATE=',I5)
 9050 FORMAT(/1X,'**** ERROR, NEGATIVE VALUE FOR -WSTATE- ???')
 9055 FORMAT(/1X,'**** DAVIDSON + Q CORRECTION MEANINGLESS FOR ',
     *           'CURRENT ORMAS PARITIONING.')
 9061 FORMAT(/1X,'**** WARNING ****'/
     *        1X,'RUNTYP=',A8,' INVOLVING A NUCLEAR GRADIENT'/
     *        1X,'HAS BEEN REQUESTED FOR A RUN AVERAGING OVER',I4,
     *           ' STATES.'/
     *        1X,'THIS MAKES SENSE ONLY IF THE STATES ARE DEGENERATE.'/
     *        1X,'THE RUN IS ALLOWED TO PROCEED BECAUSE USER INPUT'/
     *        1X,'REQUESTS THIS.  PLEASE CHECK THAT THE STATES ARE IN'/
     *        1X,'FACT DEGENERATE, AFTER THEY ARE COMPUTED BELOW.'//)
 9062 FORMAT(/1X,'**** ERROR, RUNTYP=',A8,' REQUIRES NUCLEAR GRADIENT.'/
     *        1X,'THIS IS IMPOSSIBLE WHILE STATE AVERAGING. NAVG=',I5/
     *        1X,'A POSSIBLE RECOURSE, FOR VERY SMALL MOLECULES, IS',
     *           ' TO SELECT'/
     *        1X,'A SPECIFIC STATE ENERGY TO BE NUMERICALLY',
     *           ' DIFFERENTIATED:'/
     *        1X,' $DET    IROOT=NNN'/
     *        1X,' $CONTRL NUMGRD=.TRUE.'//)
 9063 FORMAT(/1X,'**** ERROR, RUNTYP=',A8,' REQUIRES NUCLEAR HESSIAN.'/
     *        1X,'THIS IS IMPOSSIBLE WHILE STATE AVERAGING. NAVG=',I5/
     *        1X,'A POSSIBLE RECOURSE, FOR VERY SMALL MOLECULES, IS',
     *           ' TO SELECT'/
     *        1X,'A SPECIFIC STATE ENERGY TO BE NUMERICALLY',
     *           ' DIFFERENTIATED:'/
     *        1X,' $DET  IROOT=NNN'/
     *        1X,' $HESS METHOD=FULLNUM'//)
 9064 FORMAT(/1X,'**** ERROR, YOUR SA-MCSCF REQUESTS ENERGY',
     *           ' DERIVATIVES, BUT YOU DID'/
     *        1X,'NOT SPECIFY BY -IROOT- WHICH SPECIFIC STATE YOU',
     *           ' WANT.')
C
 9100 FORMAT(/1X,'THE POINT GROUP                  =',3X,A8/
     *       1X,'THE STATE SYMMETRY               =',3X,A8/
     *       1X,'NUMBER OF CORE ORBITALS          =',I5/
     *       1X,'NUMBER OF ACTIVE ORBITALS        =',I5/
     *       1X,'NUMBER OF ALPHA ELECTRONS        =',I5,
     *          ' (',I4,' ACTIVE)'/
     *       1X,'NUMBER OF BETA ELECTRONS         =',I5,
     *          ' (',I4,' ACTIVE)'/
     *       1X,'NUMBER OF OCCUPIED ORBITALS      =',I5)
 9110 FORMAT(/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)
C
 9120 FORMAT(1X,'CI PROPERTIES WILL BE FOUND FOR ROOT NUMBER',I4)
 9130 FORMAT(1X,'1E- DENSITY MATRIX OPTIONS ARE',20I2)
 9140 FORMAT(1X,'PURE SPIN STATE AVERAGED 1E- AND 2E- DENSITY MATRIX',
     *          ' OPTION=.',L1,'.')
 9150 FORMAT(2(1X,'STATE=',I4,' DM2 WEIGHT=',F10.5,4X,:))
 9155 FORMAT(/1X,'CORRELATION ENERGY ANALYSIS      =',L5)
 9157 FORMAT(/1X,'FULLY DIRECT OPTION              =',L5)
 9158 FORMAT(/1X,'CALC. OF DAVIDSON Q CORRECTION   =',L5)
 9159 FORMAT(1X,'STATE-AVERAGED MCSCF USING IROOT=',I3,
     *          ' AS ITS STATE-SPECIFIC E')
C
 9160 FORMAT(/1X,'SYMMETRIES FOR THE',I4,' CORE,',I4,' ACTIVE ARE')
C
 9170 FORMAT(/1X,'THE NUMBER OF SPACES             =',I4/
     *        1X,'EACH SPACE STARTS AT ORBITAL     =',50I4)
 9180 FORMAT(1X,'NO OF ORBITALS IN EACH SPACE     =',50I4)
 9190 FORMAT(1X,'MIN NO OF ELECS IN EACH SPACE    =',50I4)
 9195 FORMAT(1X,'MAX NO OF ELECS IN EACH SPACE    =',50I4)
C
      END
C
C*MODULE ORMAS1  *DECK FCCHECK
C     -------------------------------------------------------------
      SUBROUTINE FCCHECK(IW,SOME,
     *             NSPACE,MNUM,MINI,MAXI,IAMI,IAMA,IBMI,IBMA,
     *             NA,NB)
C     -------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL SOME
      DIMENSION MNUM(NSPACE),MINI(NSPACE),MAXI(NSPACE)
      DIMENSION IAMI(NSPACE),IAMA(NSPACE)
      DIMENSION IBMI(NSPACE),IBMA(NSPACE)
C
      NTOT = NA + NB
C
C   PRELIMINARY CHECKS:  ABORT IF SPECIFICATIONS DO NOT PASS.
C
C  1/ CHECK TO SEE NUMBER OF ORBITALS IN EACH SPACE > 0
C
      DO II=1,NSPACE
         IF (MNUM(II).LE.0) THEN
            IF (SOME) WRITE(IW,9000) (MNUM(I),I=1,NSPACE)
            CALL ABRT
            STOP
         ENDIF
      ENDDO
C
C  2/ CHECK TO SEE THAT MINIMUM NUMBER OF ELECTRONS IN EACH SPACE I NOT
C     GREATER THAN 2*MNUM(I)
C
      DO II=1,NSPACE
         IF (MINI(II).GT.2*MNUM(II)) THEN
            IF (SOME) WRITE(IW,9010) II,MINI(II),MNUM(II)
            CALL ABRT
            STOP
         ENDIF
      ENDDO
C
C  3A/ CHECK TO SEE THAT SUM OF MINIMUM NUMBER OF ELECTRONS IN EACH
C  SPACE IS LESS THAN OR EQUAL TO NTOT.
C
C  3B/ ALSO CHECK TO SEE THAT SUM OF MAXIMUM NUMBER OF ELECTRONS IN
C  EACH SPACE IS GREATER THAN OR EQUAL TO NTOT.
C
      ISUM = 0
      ISUM2 = 0
      DO II=1,NSPACE
         ISUM = ISUM + MINI(II)
         ISUM2 = ISUM2 + MAXI(II)
      ENDDO
      IF (ISUM.GT.NTOT) THEN
         IF (SOME) WRITE(IW,9020) ISUM,NTOT
         CALL ABRT
         STOP
      ENDIF
      IF (ISUM2.LT.NTOT) THEN
         IF (SOME) WRITE(IW,9030) ISUM2,NTOT
         CALL ABRT
         STOP
      ENDIF
C
C  4A/ CHECK TO SEE THAT MAXIMUM NUMBER OF ELECTRONS IN EACH SPACE I
C     IS NOT GREATER THAN CAPACITY OF THAT SPACE.
C
      DO II=1,NSPACE
         IF (MAXI(II).GT.2*MNUM(II)) THEN
            IF (SOME) WRITE(IW,9040) II,MAXI(II),MNUM(II)
            CALL ABRT
            STOP
         ENDIF
      ENDDO
C
C  4B/ CHECK TO SEE THAT MAXIMUM NUMBER OF ELECTRONS IN EACH SPACE I
C      IS NOT GREATER THAN NTOT
C
      DO II=1,NSPACE
         IF (MAXI(II).GT.NTOT) THEN
            IF (SOME) WRITE(IW,9050) II,MAXI(II),NTOT
            CALL ABRT
            STOP
         ENDIF
      ENDDO
C
C  5/ CHECK TO SEE THAT ALL MAXI(I).GE.MINI(I).
C
      DO II=1,NSPACE
         IF (MAXI(II).LT.MINI(II)) THEN
            IF (SOME) WRITE(IW,9060) II,MAXI(II),MINI(II)
            CALL ABRT
            STOP
         ENDIF
      ENDDO
C
C  PRELIMINARY CHECKS PASSED.
C
      IF (SOME) WRITE(IW,9070)
C
C  NOW FOR REDUNCANCY CHECKS.
C
C  6A/ CHECK TO SEE THAT MAXIMUMS ARE NOT IMPOSSIBLE, IF
C     SO ADJUST ACCORDINGLY.
C
      ISTAT = 0
C
      NR = NTOT
      DO II=1,NSPACE
         NR = NR - MINI(II)
      ENDDO
C
      DO II=1,NSPACE
         ITEMP = MAXI(II) - MINI(II)
         IMAX = MIN(ITEMP,NR) + MINI(II)
         IF (IMAX.NE.MAXI(II)) THEN
            MAXI(II) = IMAX
            ISTAT=1
         ENDIF
      ENDDO
C
C  6B/ CHECK TO SEE THAT MINIMUMS ARE NOT REDUNDANT, IF
C      SO ADJUST ACCORDINGLY.
C
      DO II=1,NSPACE
         IT1 = NTOT
         IM1 = MINI(II)
         DO 50 KK=1,NSPACE
            IF (KK.EQ.II) GO TO 50
            IT1 = IT1 - MAXI(KK)
   50    CONTINUE
         IM2 = MAX(IT1,IM1)
         IF (IM2.NE.MINI(II)) THEN
            MINI(II) = IM2
            ISTAT=1
         ENDIF
      ENDDO
C
      IF (ISTAT.EQ.1) THEN
         IF (SOME) WRITE(IW,9080) (MAXI(I),I=1,NSPACE)
         IF (SOME) WRITE(IW,9085) (MINI(I),I=1,NSPACE)
      ENDIF
C
C  NOW TO DETERMINE THE MINIMUM AND MAXIMUM ALPHA AND BETA PARTS.
C
      DO II=1,NSPACE
         IT1 = MIN(MNUM(II),MAXI(II))
         IAMA(II) = MIN(IT1,NA)
         IBMA(II) = MIN(IT1,NB)
      ENDDO
C
      DO II=1,NSPACE
         ITA1 = MAX(0,MINI(II)-IBMA(II))
         ITB1 = MAX(0,MINI(II)-IAMA(II))
         ITA2 = NA
         ITB2 = NB
         DO 100 KK=1,NSPACE
            IF (KK.EQ.II) GO TO 100
            ITA2 = ITA2 - IAMA(KK)
            ITB2 = ITB2 - IBMA(KK)
  100    CONTINUE
         IAMI(II) = MAX(ITA1,ITA2)
         IBMI(II) = MAX(ITB1,ITB2)
      ENDDO
C
      IF (SOME) THEN
      WRITE(IW,9090) (IAMI(I),I=1,NSPACE)
      WRITE(IW,9100) (IAMA(I),I=1,NSPACE)
      WRITE(IW,9110) (IBMI(I),I=1,NSPACE)
      WRITE(IW,9120) (IBMA(I),I=1,NSPACE)
      ENDIF
C
      RETURN
C
 9000 FORMAT(/1X,'NO. ORBITALS IN EACH SPACE MUST BE BIGGER THAN ZERO'/
     *        1X,'THESE WERE INPUT AS :',50I4)
 9010 FORMAT(/1X,'MINIMUM NO OF ELECTRONS IN SPACE ',I4/
     *        1X,'IS LARGER THAN CAPACITY OF THIS SPACE'/
     *        1X,'INPUT MINIMUM        = ',I4/
     *        1X,'INPUT NO OF ORBITALS = ',I4)
 9020 FORMAT(/1X,'TOTAL NUMBER OF MINIMUM ELECTRONS IS LARGER THAN',
     *        1X,'NUMBER OF ACTIVE ELECTRONS'/
     *        1X,'TOTAL NUMBER OF MINIMUM ELECTRONS = ',I4/
     *        1X,'TOTAL NUMBER OF ACTIVE  ELECTRONS = ',I4)
 9030 FORMAT(/1X,'TOTAL NUMBER OF MAXIMUM ELECTRONS IS LESS THAN',
     *        1X,'NUMBER OF ACTIVE ELECTRONS'/
     *        1X,'TOTAL NUMBER OF MAXIMUM ELECTRONS = ',I4/
     *        1X,'TOTAL NUMBER OF ACTIVE  ELECTRONS = ',I4)
 9040 FORMAT(/1X,'MAXIMUM NO OF ELECTONS IN SPACE ',I4/
     *        1X,'IS LARGER THAN CAPACITY OF THIS SPACE'/
     *        1X,'INPUT MAXIMUM        = ',I4/
     *        1X,'INPUT NO OF ORBITALS = ',I4)
 9050 FORMAT(/1X,'MAXIMUM NO OF ELECTRONS IN SPACE ',I4/
     *        1X,'IS LARGER THAN NUMBER OF ACTIVE ELECTRONS'/
     *        1X,'INPUT MAXIMUM                    = ',I4/
     *        1X,'TOTAL NUMBER OF ACTIVE ELECTRONS = ',I4)
 9060 FORMAT(/1X,'ERROR IN SPECIFICATION FOR SPACE ',I4/
     *        1X,'MAXIMUM NUMBER OF ELECTRONS IS LESS THAN',
     *        1X,'MINIMUM NUMBER.'/
     *        1X,'MAXI = ',I4/
     *        1X,'MINI = ',I4)
 9070 FORMAT(/1X,'SPACE SPECIFICATIONS HAVE PASSED PRELIMINARY CHECKS')
 9080 FORMAT(/1X,'REDUNCANCIES FOUND, MAXIMUM/MINIMUM NUMBERS OF',
     *        1X,'ELECTRONS HAVE BEEN ADJUSTED.'//
     *        1X,'MAX NO OF ELECS IN EACH SPACE    = ',50I4)
 9085 FORMAT(1X, 'MIN NO OF ELECS IN EACH SPACE    = ',50I4)
 9090 FORMAT(/1X,'ALL VALID DETERMINANTS WILL BE EXPRESSED',
     *        1X,'AS PAIRS OF ALPHA AND BETA STRINGS.'//
     *        1X,'MIN NO OF ALPHA ELECS = ',50I4)
 9100 FORMAT(1X,'MAX NO OF ALPHA ELECS = ',50I4)
 9110 FORMAT(/1X,'MIN NO OF BETA  ELECS = ',50I4)
 9120 FORMAT(1X,'MAX NO OF BETA  ELECS = ',50I4)
C
      END
C
C*MODULE ORMAS1  *DECK DEFCCI
      SUBROUTINE DEFCCI(NPRINT,CLABEL,DDITRF,NDM1,NDM2,NPRI5,NPRI6)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL CLABEL,DDITRF,SOME,PACK2E,GOPARR,DSKWRK,MASWRK,FDIRCT,
     *        QCORR,JACOBI,CEECHK
C
      PARAMETER (MXRT=100, MXATM=2000)
C
      COMMON /CEEIS3/ NEEDCI, CEECHK
      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 /FCCWFN/ NSPACE,MSTA(51),MNUM(51),MINI(51),MAXI(51),
     *                IAMI(51),IAMA(51),IBMI(51),IBMA(51),IDIM(51),
     *                LBST(51),NREF0,FDIRCT,QCORR,C0SQ
      COMMON /FMCOM / X(1)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,MA,MB,
     *                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 /JACOBI/ JACOBI,NJAOR,ELAST,ISTAT
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00)
C
      DATA AMCSCF/8HMCSCF   /
      DATA CHECK/8HCHECK   /
C
C     ----- DRIVER FOR FULL CLASS CI COMPUTATION -----
C
      SOME = MASWRK  .AND.  NPRINT.NE.-5
C
C                TURNING ON THE NEXT BIT WILL LET YOU SEE MORE
C                OR LESS EVERYTHING LOADED INTO THE TWO COMMONS
C                THAT DEFINE THE ORMAS COMPUTATION.
C
C---      WRITE(6,8001) WSTATE(1),CRIT,PRTTOL,SZ
C--- 8001 FORMAT(1X,'CONTENTS OF /DETWFN/ ARE'/
C---     *       1X,'WSTATE(1)=',F10.3,' CRIT,PRTTOL=',1P,2E12.3,0P,
C---     *           ' SZ=',F10.3)
C---      WRITE(6,8002) GRPDET,STSYM
C--- 8002 FORMAT(1X,'GRPDET=',A8,' STSYM=',A8)
C---      WRITE(6,8003) NFLGDM(1),IWTS(1),NCORSV,NCOR,NACT,NORB,
C---     *              NA,NB,K,KST,IROOT,IPURES
C--- 8003 FORMAT(1X,'NFLGDM(1)=',I2,' IWTS(1)=',I3,' NCORSV,NCOR=',2I4,
C---     *          ' NACT,NORB=',2I4/
C---     *       1X,'NA,NB=',2I4,' K,KST=',2I4,' IROOT=',I3,
C--      *          ' IPURES=',I2)
C---      WRITE(6,8004) MAXW1,NITER,MAXP,IGPDET,KSTSYM
C--- 8004 FORMAT(1X,'MAXW1=',I6,' NITER=',I4,' MAXP=',I4,' IGPDET=',I4,
C---     *          ' KSTSYM=',I4)
C---C
C---      WRITE(6,8011) NSPACE
C--- 8011 FORMAT(1X,'CONTENTS OF /FCCWFN/ ARE NSPACE=',I3,' AND...')
C---      WRITE(6,8012) 'MSTA=',(MSTA(III),III=1,NSPACE+1)
C---      WRITE(6,8012) 'MNUM=',(MNUM(III),III=1,NSPACE)
C---      WRITE(6,8012) 'MINI=',(MINI(III),III=1,NSPACE)
C---      WRITE(6,8012) 'MAXI=',(MAXI(III),III=1,NSPACE)
C---      WRITE(6,8012) 'IAMI=',(IAMI(III),III=1,NSPACE)
C---      WRITE(6,8012) 'IAMA=',(IAMA(III),III=1,NSPACE)
C---      WRITE(6,8012) 'IBMI=',(IBMI(III),III=1,NSPACE)
C---      WRITE(6,8012) 'IBMA=',(IBMA(III),III=1,NSPACE)
C---      WRITE(6,8012) 'IDIM=',(IDIM(III),III=1,NSPACE)
C---      WRITE(6,8012) 'LBST=',(LBST(III),III=1,NSPACE)
C--- 8012 FORMAT(1X,A4,50I4)
C
C        CORE CONTRIBUTION TO THE ENERGY IS OBTAINED FROM -ECORE-,
C        AND FROM MODIFICATIONS TO THE TRANSFORMED 1E- INTEGRALS.
C        THIS EFFECTIVELY REMOVES CORE ORBITALS FROM THE COMPUTATION.
C
      ECONST = ECORE + ENUCR
      NTOT = NACT + NCORSV
      NTCO = NCORSV
      NORB = NACT
      NCOR = 0
      NSYM = 2**IGPDET
C
C  MODIFY MSTA TO GET RID OF CORE.
C
      DO II=1,NSPACE+1
         MSTA(II) = MSTA(II) - NCORSV
      ENDDO
C
C        COMPUTE THE TOTAL NUMBER OF DETERMINANTS IN THIS FULL CLASS CI.
C        DECIDE NECESSARY DOUBLE/INTEGER WORKING STORAGE -IDS- AND -IIS-
C
C     FIRST NEED TO STORE NSPACE SETS OF BINOMIAL COEFFICIENTS FOR EACH
C     SUB-SPACE.  THERE IS REASON BEHIND THIS, TRUST ME.  JUST ASK ME.
C     LBST(I) WILL STORE WHERE IN X BINOMIAL ARRAYS FOR SPACE I START.
C     IDIM(I) WILL STORE THE MAXIMUM NUMBER OF ALPHA OR BETA ELECTRONS.
C
C
      CALL VALFM(LOADFM)
      LBST(1)  = LOADFM + 1
      DO II=2,NSPACE
         IDIM(II-1) = MAX(IAMA(II-1),IBMA(II-1))
         LBST(II) = LBST(II-1)+((MNUM(II-1)+1)*(IDIM(II-1)+1))
      ENDDO
      IDIM(NSPACE) = MAX(IAMA(NSPACE),IBMA(NSPACE))
      LAST = LBST(NSPACE)+((MNUM(NSPACE)+1)*(IDIM(NSPACE)+1))
      NEED1 = LAST - LOADFM - 1
      IF (SOME) WRITE(IW,9000) NEED1
      CALL GETFM(NEED1)
C
      DO II=1,NSPACE
         CALL BINOM8(X(LBST(II)),MNUM(II),IDIM(II))
      ENDDO
C
C     NOW TO MAKE TABLES FOR THE ORMAS PROBLEM.
C     MAKE MEMORY AVAILABLE FOR TABLE INFO AND
C     TABLES THEMSELVES.
C
      CALL VALFM(LOADFM)
      LBOX1 = LOADFM + 1
      LBOX2 = LBOX1 + NSPACE/NWDVAR + 1
      LBOX3 = LBOX2 + NSPACE/NWDVAR + 1
      LBOX4 = LBOX3 + NSPACE/NWDVAR + 1
      LBOX5 = LBOX4 + NSPACE/NWDVAR + 1
      LIBO = LBOX5 + NSPACE/NWDVAR + 1
      LAST = LIBO + NTOT/NWDVAR + 1
      NEED2 = LAST - LOADFM - 1
      CALL GETFM(NEED2)
C
C    READ ORBITALS LABELS AND GET RID OF THE CORE PART.
C
      CALL DAREAD(IDAF,IODA,X(LIBO),NTOT,262,1)
      CALL CORTRA(X(LIBO),NTOT,NTCO)
C
C    WORK OUT HOW MANY ALPHA AND BETA GROUPS THERE ARE.
C
      CALL TOTALCO(X(LBOX1),NSPACE,NA,IAMA,IAMI,X(LBOX2),ITGA)
      CALL TOTALCO(X(LBOX1),NSPACE,NB,IBMA,IBMI,X(LBOX2),ITGB)
C
      IF (SOME) WRITE(IW,9010) ITGA,ITGB
C
C    DETERMINE THE TOTAL NUMBER OF ALPHA AND BETA STRINGS.
C
      CALL RESETCO(X(LBOX1),NSPACE,NA,IAMA,IAMI,X(LBOX2))
      IAST = 0
      DO II=1,ITGA
      CALL TOTDETG(X(LBOX1),NSPACE,LBST,X(LBST(1)),NEED1,
     *    MNUM,IDIM,ITOT)
      IAST = IAST + ITOT
      CALL PUSHCO(X(LBOX1),NSPACE,NA,IAMA,IAMI,X(LBOX2),IEND)
      ENDDO
C
      CALL RESETCO(X(LBOX1),NSPACE,NB,IBMA,IBMI,X(LBOX2))
      IBST = 0
      DO II=1,ITGB
      CALL TOTDETG(X(LBOX1),NSPACE,LBST,X(LBST(1)),NEED1,
     *    MNUM,IDIM,ITOT)
      IBST = IBST + ITOT
      CALL PUSHCO(X(LBOX1),NSPACE,NB,IBMA,IBMI,X(LBOX2),IEND)
      ENDDO
C
      IF (SOME) WRITE(IW,9020) IAST,IBST
C
C    MAKE STORAGE TO HOLD SYMMETRY INFORMATION OF STRINGS.
C    THE LABELS BELOW APPEAR THE SAME IN ROUTINE MAKTABS
C    AND THIS ROUTINE ALSO EXPLAINS WHAT THEY ARE USED FOR.
C
      CALL VALFM(LOADFM)
      LWRK   = LOADFM + 1
      LCOA   = LWRK   + 43/NWDVAR + 1
      LCOB   = LCOA   + (NSYM*ITGA)/NWDVAR + 1
      LGMUL  = LCOB   + (NSYM*ITGB)/NWDVAR + 1
      LKTAB  = LGMUL  + (NSYM*NSYM)/NWDVAR + 1
      LCON   = LKTAB  + NSYM/NWDVAR + 1
      LCON1  = LCON   + NA/NWDVAR + 1
      LCON2  = LCON1  + NA/NWDVAR + 1
      LCON3  = LCON2  + NA/NWDVAR + 1
      LANDET = LCON3  + NA/NWDVAR + 1
      LBNDET = LANDET + (ITGA*NSPACE)/NWDVAR + 1
      NAST   = LBNDET + (ITGB*NSPACE)/NWDVAR + 1
      NBST   = NAST   + (ITGA+1)/NWDVAR + 1
      LSYMA  = NBST   + (ITGB+1)/NWDVAR + 1
      LSYMB  = LSYMA  + IAST/NWDVAR + 1
      LGCOM  = LSYMB  + IBST/NWDVAR + 1
      LSPA   = LGCOM  + (ITGA*ITGB)/NWDVAR + 1
      LSPB   = LSPA   + IAST/NWDVAR + 1
      LDISB  = LSPB   + IBST/NWDVAR + 1
      LSAS   = LDISB  + (NSYM*ITGB*ITGA)/NWDVAR + 1
      LSBS   = LSAS   + ((NSYM+1)*ITGA)/NWDVAR + 1
      LSAC   = LSBS   + ((NSYM+1)*ITGB)/NWDVAR + 1
      LSBC   = LSAC   + IAST/NWDVAR + 1
      LAST   = LSBC   + IBST/NWDVAR + 1
      NEED3 = LAST - LOADFM - 1
      IF (SOME) WRITE(IW,9030) NEED2 + NEED3
      CALL GETFM(NEED3)
C
C    MAKE INTEGER TABLES FOR ORMAS. GET NUMBER OF DETS, ETC.
C
      IF (SOME) CALL TSECND(E0)
C
      CALL MAKTABS(IW,SOME,X(LBOX1),X(LBOX2),X(LBOX3),NSPACE,
     *             NA,NB,LBST,X(LBST(1)),NEED1,
     *             IAMA,IAMI,IBMA,IBMI,MNUM,IDIM,MSTA,
     *             X(LIBO),IGPDET,KSTSYM,NSYM,
     *             NACT,X(LWRK),X(LKTAB),X(LGMUL),
     *             X(LCON),X(LCOA),X(LCOB),X(LANDET),X(LBNDET),
     *             X(NAST),X(NBST),X(LSYMA),X(LSYMB),X(LGCOM),
     *             MINI,MAXI,X(LSPA),X(LSPB),X(LDISB),
     *             X(LSAS),X(LSBS),X(LSAC),X(LSBC),
     *             ITGA,ITGB,IAST,IBST,NCI,NA1EX,NB1EX,FDIRCT)
C
      IF(SOME) THEN
         CALL TSECND(E1)
         ELAP = E1 - E0
         E0 = E1
         WRITE(IW,9107) ELAP
      ENDIF
C
      IF(SOME) THEN
         WRITE(IW,9110) STSYM,GRPDET,SZ,NCI
      END IF
C
C   END OF INTEGER TABLES.  NOW TO DETERMINE THE EXTRA MEMORY
C   REQUIREMENTS, DOUBLE PRECISION AND INTEGER.
C   USED TO DO THIS BY CALLING MEMCI OR SOMETHING SIMILAR, I AM
C   JUST GOING TO DO IT HERE.
C
      M1 = NACT
      M2 = (M1*M1+M1)/2
      M4 = (M2*M2+M2)/2
      L1 = NUM
      L2 = (L1*L1+L1)/2
      L3 = L1*L1
C
C   INTEGRAL STORAGE REQUIREMENTS FIRST.
C
      CALL VALFM(LOADFM)
      LSINT1 = LOADFM  + 1
      LSINT2 = LSINT1  + M2
      LIA    = LSINT2  + M4
      LXX    = LIA     + M2/NWDVAR + 1
      LIXX   = LXX     + NINTMX
C
C   ORMAS DOUBLE PRECISION NEXT.
C
      KCOEFF = LIXX   + NINTMX
      KAB    = KCOEFF + MAXP*NCI
      KQ     = KAB    + MAXP*NCI
      KB     = KQ     + NCI
      KEF    = KB     + 8*MAXW1
      KF     = KEF    + MAXW1*MAXW1
      KEC    = KF     + (MAXW1*(MAXW1+1))/2
      KGR    = KEC    + MAXP*MAXP
      KEL    = KGR    + MAXP
      KSP    = KEL    + MAXW1
      LAST   = KSP    + MAXW1
C
C   ORMAS INTEGER STORAGE IS LAST.
C
      IPOSA  = LAST
      IPERA  = IPOSA  + (NA*(NACT-NA)*NSYM)/NWDVAR + 1
      IIND1  = IPERA  + (NA*(NACT-NA)*NSYM)/NWDVAR + 1
      IGROA  = IIND1  + (NA*(NACT-NA)*NSYM)/NWDVAR + 1
      IWRK1  = IGROA  + (NA*(NACT-NA)*NSYM)/NWDVAR + 1
      IWRK2  = IWRK1  + (2*MAXW1)/NWDVAR + 1
      ISD    = IWRK2  + MAXW1/NWDVAR + 1
      ISO    = ISD    + (NA+NB)/NWDVAR + 1
      INDEX  = ISO    + NA/NWDVAR + 1
      IMMC   = INDEX  + ((NACT*(NACT+1))/2+1)/NWDVAR + 1
      IHMCON = IMMC + NSYM
C
C  LEAVE SPACE FOR THE SINGLE EXCITED STORAGE.
C  NOTE, IF FDIRCT = .TRUE. THEN NB1EX = ITGA.
C
      JB1GR = IHMCON + K
      JB1PE = JB1GR + NB1EX/NWDVAR + 1
      JB1IN = JB1PE + NB1EX/NWDVAR + 1
      JB1PO = JB1IN + NB1EX/NWDVAR + 1
      JB1SY = JB1PO + NB1EX/NWDVAR + 1
      JB1ST = JB1SY + (NB*(NACT-NB))/NWDVAR + 1
C
      IF (.NOT.FDIRCT) THEN
         LAST   = JB1ST + ((IBST+1)*(NSYM+1))/NWDVAR + 1
         IBST2 = (IBST+1)*(NSYM+1)
      ELSE
         LAST = JB1ST + 1
         NB1EX = ITGA
         IBST2 =  1
      ENDIF
C
      NEED4  = LAST - LOADFM - 1
      NEEDCI = NEED1 + NEED2 + NEED3 + NEED4
      IF (SOME) THEN
          WRITE(IW,9120) KCOEFF-LOADFM-1,
     *          NEED4-(KCOEFF-LOADFM-1),MAXP,NEEDCI
          IFDM = ((NB1EX/NWDVAR) + 1)*4 +
     *    (((IBST+1)*(NSYM+1))/NWDVAR)+1 + (NB*(NACT-NB))/NWDVAR + 1
          IF (.NOT.FDIRCT) WRITE(IW,9125) NEEDCI-IFDM+6
      ENDIF
C
      IF (CEECHK) THEN
        CALL RETFM(NEED3)
        CALL RETFM(NEED2)
        CALL RETFM(NEED1)
        DO II=1,NSPACE+1
          MSTA(II) = MSTA(II) + NCORSV
        ENDDO
        RETURN
      ENDIF
C
      CALL GETFM(NEED4)
C
      IF(EXETYP.EQ.CHECK) THEN
         DO IST=1,MIN(K,MXRT)
            SPINS(IST) = S
            ESTATE(IST) = ZERO
         ENDDO
         LCIVEC = KCOEFF
         CALL VCLR(X(KCOEFF),1,K*NCI)
         GO TO 450
      END IF
C
C     -- OBTAIN 1 AND 2 E- TRANSFORMED INTEGRALS OVER ACTIVE ORBITALS --
C     CALLING ARGUMENT -CLABEL- GOVERNS WHETHER TRANSFORMED INTEGRALS
C     ON FILE -IJKT- INCLUDE THE CORE ORBITALS OR NOT.  IT IS ASSUMED
C     THAT NO CORE INTEGRALS ARE IN -IJKT-, SO THIS VARIABLE TELLS IF
C     THE ACTIVE ORBITALS START FROM 1,2,3... OR NCORSV+1,NCORSV+2,...
C
      NCORE = 0
      IF(CLABEL) NCORE=NCORSV
      CALL RDCI12(DDITRF,IJKT,X(LSINT1),X(LSINT2),NCORE,M1,M2,M4,X(LIA),
     *            X(LXX),X(LIXX),NINTMX)
C
C        ----- COMPUTE FULL CLASS CI WAVEFUNCTION -----
C
      CALL DAFCCI(IW,SOME,ECONST,ISTAT,
     *           X(LSINT1),X(LSINT2),M2,M4,NACT,NCI,NA,NB,
     *           K,KST,MAXP,MAXW1,NITER,CRIT,X(LBST(1)),NEED1,
     *           X(KSP),X(KEL),NSYM,X(LIBO),
     *           X(LBOX1),X(LBOX2),X(LBOX3),X(LBOX4),X(LBOX5),
     *           X(KCOEFF),X(KAB),X(KQ),X(KB),X(KEF),X(KF),
     *           X(KEC),X(KGR),
     *           X(IPOSA),X(IPERA),X(IIND1),X(IGROA),
     *           X(IWRK1),X(IWRK2),
     *           X(ISD),X(ISO),
     *           X(INDEX),X(IMMC),X(IHMCON),
     *           X(LGMUL),X(LKTAB),
     *           X(LCON),X(LCON1),X(LCON2),X(LCON3),
     *           X(LANDET),X(LBNDET),X(NAST),X(NBST),
     *           X(LSYMA),X(LSYMB),X(LGCOM),X(LSPA),X(LSPB),
     *           X(LDISB),X(LSAS),X(LSBS),X(LSAC),X(LSBC),
     *           ITGA,ITGB,IAST,IBST,
     *           NB1EX,IBST2,
     *           X(JB1GR),X(JB1PE),X(JB1IN),X(JB1PO),X(JB1ST),
     *           X(JB1SY))
C
      DO I=1,MIN(K,MXRT)
         ESTATE(I) = X(KEL-1+I)+ECONST
         SPINS(I)  = X(KSP-1+I)
      ENDDO
C
C        SAVE ENERGY QUANTITIES
C
  450 CONTINUE
      ETOT = ESTATE(IROOT)
      EELCT = ETOT - ENUCR
      STOT = SPINS(IROOT)
      SSQUAR = STOT*(STOT+ONE)
      STATN = K
C
      IF (NDM1.EQ.0.AND.NDM2.EQ.0) THEN
          CALL RETFM(NEED4)
          CALL RETFM(NEED3)
          CALL RETFM(NEED2)
          CALL RETFM(NEED1)
          RETURN
      ENDIF
C
C        SAVE EIGENVECTORS TO DISK
C
      CALL SEQOPN(NFT12,'CIVECTR','UNKNOWN',.FALSE.,'UNFORMATTED')
      CALL SEQREW(NFT12)
      IF(MASWRK) WRITE(NFT12) K,NCI
      DO 420 IST=1,K
         LCIVEC = KCOEFF + (IST-1)*NCI
         CALL STFASE(X(LCIVEC),NCI,NCI,1)
         CALL SQWRIT(NFT12,X(LCIVEC),NCI)
  420 CONTINUE
      CALL SEQREW(NFT12)
C
C  IF ASKED FOR A DAVIDSON + Q CORRECTION, THEN NEED TO DETERMINE
C  WEIGHT OF THE REFERENCE IN THE TOTAL MR-CISD WAVEFUNCTION
C
      IF(QCORR) THEN
         IF(MASWRK) WRITE(IW,9250)
         CALL REFWE(X(KCOEFF),X(NAST),ITGA,ITGB,X(LSYMA),
     *              IAST,X(LGCOM),X(LSBS),NSYM,X(LKTAB))
      ENDIF
C
C  COPY CI VECTORS TO AB AS THE ONES IN KCOEFF ARE DESTROYED
C  DURING PRINTING.
C
      CALL CICOPY(X(KCOEFF),X(KAB),NCI*K)
C
C  PRINT RESULTS OF THE CI CALCULATION
C
      CALL MASPRT(IW,SOME,
     *       X(KAB),X(NAST),ITGA,ITGB,X(LSYMA),
     *       IAST,IBST,X(LGCOM),X(LSBS),NSYM,X(LSBC),
     *       X(LBOX1),X(LBOX2),X(LBOX3),X(LCON1),X(LCON2),
     *       X(LKTAB))
C
      IF(SOME) WRITE(IW,9140)
      IF(SOME) CALL TIMIT(1)
C
C  DETERMINE 1ST ORDER DENSITY MATRIX IF REQUESTED (AT -LSINT1-)
C
      IF (NDM1.GT.0) THEN
         CALL MASDM1(IW,NPRI5,
     *           X(LSINT1),M2,NACT,NCI,NA,NB,IROOT,
     *           X(LBST(1)),NEED1,X(KCOEFF+(NCI*(IROOT-1))),
     *           X(INDEX),NSYM,X(LIBO),
     *           X(LBOX1),X(LBOX2),X(LBOX4),X(LBOX5),
     *           X(LKTAB),X(LCON),X(LCON1),X(LCON2),X(LCON3),
     *           X(LANDET),X(LBNDET),X(NAST),X(NBST),
     *           X(LSYMA),X(LSYMB),X(LGCOM),X(LSPA),X(LSPB),
     *           X(LDISB),X(LSAS),X(LSBS),X(LSAC),
     *           ITGA,ITGB,IAST,IBST)
         IF(SOME  .AND.  NFLGDM(IST).EQ.2) THEN
            WRITE(IW,9230)
            CALL PRTRI(X(LSINT1),NORB)
         END IF
         CALL VALFM(LOADFM)
         LDAO = LOADFM + 1
         LVAO   = LDAO   + L2
         LVNO   = LVAO   + L3
         LOCCNO = LVNO   + L3
         LIWRK  = LOCCNO + L1
         LWRK   = LIWRK  + M1
         LSCR   = LWRK   + 8*M1
         LAST = LSCR + M1
         NEED5 = LAST - LOADFM - 1
         CALL GETFM(NEED5)
         CALL DETNO(SOME,X(LSINT1),X(LDAO),X(LVAO),X(LVNO),
     *              X(LOCCNO),X(LIWRK),X(LWRK),X(LSCR),ESTATE,
     *              IROOT,IROOT,NCORSV,NACT,M1,M2,L1,L2)
         CALL RETFM(NEED5)
         IF (SOME) WRITE(IW,9240)
         IF (SOME) CALL TIMIT(1)
      ENDIF
C
C  DETERMINE IF STATE AVERAGED 1E- AND 2E- DENSITY MATRICES REQUESTED
C
      IF (NDM2.GT.0) THEN
         IF (.NOT.FDIRCT) THEN
            IDIM1 = NSYM+1
            IDIM2 = IBST+1
         ELSE
            IDIM1 = 1
            IDIM2 = 1
         ENDIF
C
         CALL MASDM2(IW,NPRI6,IWTS,WSTATE,SPINS,IPURES,S,K,GRPDET,
     *           NCORSV,
     *           X(LSINT1),X(LSINT2),M2,M4,NACT,NCI,NA,NB,
     *           X(KCOEFF),X(KAB),
     *           X(LBST(1)),NEED1,
     *           X(INDEX),NSYM,X(LIBO),
     *           X(LBOX1),X(LBOX2),X(LBOX3),X(LBOX4),X(LBOX5),
     *           X(LGMUL),X(LKTAB),
     *           X(LCON),X(LCON1),X(LCON2),X(LCON3),
     *           X(LANDET),X(LBNDET),X(NAST),X(NBST),
     *           X(LSYMA),X(LSYMB),X(LGCOM),X(LSPA),X(LSPB),
     *           X(LDISB),X(LSAS),X(LSBS),X(LSAC),X(LSBC),
     *           ITGA,ITGB,IAST,IBST,
     *           X(IPOSA),X(IPERA),X(IIND1),X(IGROA),X(IMMC),
     *           NB1EX,
     *           X(JB1GR),X(JB1PE),X(JB1IN),X(JB1PO),X(JB1ST),
     *           IDIM1,IDIM2)
      ENDIF
C
      CALL RETFM(NEED4)
      CALL RETFM(NEED3)
      CALL RETFM(NEED2)
      CALL RETFM(NEED1)
C
C  GOOD REASON FOR THIS SMALL PART, DONT WORRY
C
      DO II=1,NSPACE+1
         MSTA(II) = MSTA(II) + NCORSV
      ENDDO
C
      IF(EXETYP.NE.CHECK  .AND.  ISTAT.NE.0 .AND. SCFTYP.NE.AMCSCF) THEN
         IF(MASWRK) WRITE(IW,9150)
         CALL ABRT
         STOP
      END IF
C
      RETURN
C
 9000 FORMAT(/5X,50(1H-)/
     *       5X,'            DIRECT DETERMINANT ORMAS-CI '/
     *       5X,'           PROGRAM WRITTEN BY JOE IVANIC'/
     *       5X,50(1H-)//
     *       1X,'STORAGE OF BINOMIAL COEFFICIENTS REQUIRES',
     *       I12,' WORDS')
 9010 FORMAT(/1X,'TOTAL NUMBER OF ALPHA GROUPS  = ',I12/
     *        1X,'TOTAL NUMBER OF BETA  GROUPS  = ',I12)
 9020 FORMAT(/1X,'TOTAL NUMBER OF ALPHA STRINGS = ',I12/
     *        1X,'TOTAL NUMBER OF BETA  STRINGS = ',I12)
 9030 FORMAT(/1X,'STORAGE OF TABLES REQUIRES              ',
     *       I12,' WORDS')
 9107 FORMAT(/1X,'TIME FOR SETTING UP TABLE SET 1 :',F13.1)
 9110 FORMAT(/1X,'THE NUMBER OF DETERMINANTS HAVING SPACE SYMMETRY ',A3/
     *        1X,'IN POINT GROUP ',A4,' WITH SZ=',F5.1,' IS',I15)
 9120 FORMAT(/1X,'INTEGRAL STORAGE REQUIRES        ',I12,' WORDS'/
     *        1X,'EXTRA ORMAS STORAGE REQUIRES     ',I12,' WORDS'/
     * 1X,'(EXTRA ORMAS STORAGE INCLUDES THAT FOR MXXPAN =',I3,')'/
     *        1X,'TOTAL ORMAS CALCULATION REQUIRES ',I12,' WORDS')
 9125 FORMAT(/1X,'FULLY DIRECT WOULD REQUIRE       ',I12,' WORDS')
 9140 FORMAT(/1X,'..... DONE WITH ORMAS-CI COMPUTATION .....')
 9150 FORMAT(1X,'CI COMPUTATION DID NOT CONVERGE, JOB CANNOT CONTINUE')
 9230 FORMAT(/1X,'1-PARTICLE DENSITY MATRIX IN MO BASIS')
 9240 FORMAT(1X,'..... DONE WITH ONE PARTICLE DENSITY MATRIX .....')
 9250 FORMAT(1X,'DETERMINING REFERENCE WEIGHT FOR ',
     *          'DAVIDSON + Q CORRECTION')
C
      END
C
C*MODULE ORMAS1  *DECK RESET
C     ---------------------------------------------
      SUBROUTINE RESET(IBOX,NBOX,NR,MB)
C     ---------------------------------------------
      IMPLICIT INTEGER(A-Z)
      DIMENSION IBOX(NBOX),MB(NBOX)
C
C     IBOX(I),I=1,NBOX STORES NUMBER OF PARTICLES
C                          IN EACH BOX I.
C     NBOX = TOTAL NUMBER OF BOXES.
C     NR   = TOTAL NUMBER OF PARTICLES.
C     MB(I) = MAXIMUM CAPACITY OF BOX I.
C
C     SUBROUTINE MAKES FIRST GROUP IN THE FULL LIST,
C     ASSUMING THAT MINIMUM(I) = 0
C
      NT = NR
      DO I=1,NBOX
         IBOX(I) = MIN(MB(I),NT)
         NT = NT - IBOX(I)
      ENDDO
C
      RETURN
      END
C
C*MODULE ORMAS1  *DECK PUSH
C     ---------------------------------------------
      SUBROUTINE PUSH(IBOX,NBOX,NR,MB,IEND)
C     ---------------------------------------------
      IMPLICIT INTEGER(A-Z)
      DIMENSION IBOX(NBOX),MB(NBOX)
C
C     IBOX(I),I=1,NBOX STORES NUMBER OF PARTICLES
C                          IN EACH BOX I.
C     NBOX = TOTAL NUMBER OF BOXES.
C     NR   = TOTAL NUMBER OF PARTICLES.
C     MB(I) = MAXIMUM CAPACITY OF BOX I.
C
C     SUBROUTINE RETURNS NEXT GROUP IN THE FULL LIST.
C     IF (IEND.EQ.0) THEN LAST GROUP WAS INPUT IN IBOX.
C     IF (IEND.EQ.1) THEN PUSH WAS SUCCESSFUL.
C
      IEND = 0
      NU = NR
      DO 100 K=NBOX-1,1,-1
         IF (IBOX(K).GT.0) THEN
         DO 200 M=K+1,NBOX
            IF (IBOX(M).LT.MB(M)) THEN
               IBOX(K) = IBOX(K)-1
               DO 300 II=1,M-1
                  NU = NU - IBOX(II)
  300          CONTINUE
               CALL RESET(IBOX(M),NBOX-M+1,NU,MB(M))
               IEND = 1
               RETURN
            ENDIF
  200    CONTINUE
         ENDIF
  100 CONTINUE
C
      RETURN
      END
C
C*MODULE ORMAS1  *DECK TOTAL
C     ---------------------------------------------
      SUBROUTINE TOTAL(IBOX,NBOX,NR,MB,ITOT)
C     ---------------------------------------------
      IMPLICIT INTEGER(A-Z)
      DIMENSION IBOX(NBOX),MB(NBOX)
C
C     IBOX(I),I=1,NBOX STORES NUMBER OF PARTICLES
C                          IN EACH BOX I.  SCRATCH.
C     NBOX = TOTAL NUMBER OF BOXES.
C     NR   = TOTAL NUMBER OF PARTICLES.
C     MB(I) = MAXIMUM CAPACITY OF BOX I.
C
C     RETURNED -----
C
C     ITOT = NUMBER OF GROUPS.
C
      IY = 0
      DO II=1,NBOX
         IY = IY + MB(II)
      ENDDO
      IF (IY.LT.NR) THEN
         ITOT = 0
         RETURN
      ENDIF
C
      ITOT = 0
      CALL RESET(IBOX,NBOX,NR,MB)
C
  100 CONTINUE
      ITOT = ITOT + 1
      CALL PUSH(IBOX,NBOX,NR,MB,IEND)
      IF (IEND.EQ.1) GO TO 100
C
      RETURN
      END
C
C*MODULE ORMAS1  *DECK GETBOX
C     ---------------------------------------------
      SUBROUTINE GETBOX(IBOX,ICON,NR,MSTA,NBOX)
C     ---------------------------------------------
      IMPLICIT INTEGER(A-Z)
      DIMENSION IBOX(NBOX),ICON(NR),MSTA(NBOX+1)
C
      ISTA=1
      DO II=1,NBOX
         IBOX(II)=0
      ENDDO
      DO 10 II=1,NR
         IA=ICON(II)
         DO JJ=ISTA,NBOX
            IF (MSTA(JJ+1).GT.IA) THEN
               IBOX(JJ)=IBOX(JJ)+1
               ISTA=JJ
               GO TO 10
            ENDIF
         ENDDO
   10 CONTINUE
C
      RETURN
      END
C
C*MODULE ORMAS1  *DECK POSIT
C     ---------------------------------------------
      SUBROUTINE POSIT(IBOX,NBOX,NR,MB,JBOX,IPOS)
C     ---------------------------------------------
      IMPLICIT INTEGER(A-Z)
      DIMENSION IBOX(NBOX),MB(NBOX),JBOX(NBOX)
C
C     IBOX(I),I=1,NBOX STORES NUMBER OF PARTICLES
C                          IN EACH BOX I.  SCRATCH.
C     NBOX = TOTAL NUMBER OF BOXES.
C     NR   = TOTAL NUMBER OF PARTICLES.
C     MB(I) = MAXIMUM CAPACITY OF BOX I.
C     JBOX = GROUP TO HAVE IT POSITION DETERMINED
C
C     RETURNED -----
C
C     IPOS = POSITION OF JBOX IN FULL SET.
C
      IPOS=0
      CALL RESET(IBOX,NBOX,NR,MB)
  100 CONTINUE
      IPOS = IPOS + 1
      IF (ICOMPA(IBOX,JBOX,NBOX).EQ.0) RETURN
      CALL PUSH(IBOX,NBOX,NR,MB,IEND)
      IF (IEND.NE.1) THEN
         IPOS=0
         RETURN
      ENDIF
      GO TO 100
C
      END
C
C*MODULE ORMAS1  *DECK ICOMPA
C     ---------------------------------------------
      INTEGER FUNCTION ICOMPA(IA,IB,N)
C     ---------------------------------------------
      IMPLICIT INTEGER(A-Z)
      DIMENSION IA(N),IB(N)
C
C     IF IA = IB, ICOMPA=0, =1 OTHERWISE.
C
      ICOMPA=1
      DO I=1,N
         IF (IA(I).NE.IB(I)) RETURN
      ENDDO
      ICOMPA=0
C
      RETURN
      END
C
C*MODULE ORMAS1  *DECK RESETCO
C     ---------------------------------------------
      SUBROUTINE RESETCO(IBOX,NBOX,NR,MAB,MIB,ISC)
C     ---------------------------------------------
      IMPLICIT INTEGER(A-Z)
      DIMENSION IBOX(NBOX),MAB(NBOX),MIB(NBOX),ISC(NBOX)
C
C     IBOX(I),I=1,NBOX STORES NUMBER OF PARTICLES
C                          IN EACH BOX I.
C     NBOX = TOTAL NUMBER OF BOXES.
C     NR   = TOTAL NUMBER OF PARTICLES.
C     MAB(I) = MAXIMUM CAPACITY OF BOX I.
C     MIB(I) = MINIMUM CAPACITY OF BOX I.
C     ISC(I) = SCRATCH ARRAY
C
C     SUBROUTINE MAKES FIRST GROUP IN THE FULL LIST,
C     ASSUMING THAT MIB(I).NE.0
C
      NP = NR
      DO I=1,NBOX
         ISC(I) = MAB(I) - MIB(I)
         NP = NP - MIB(I)
      ENDDO
      CALL RESET(IBOX,NBOX,NP,ISC)
      DO I=1,NBOX
         IBOX(I) = IBOX(I) + MIB(I)
      ENDDO
C
      RETURN
      END
C
C*MODULE ORMAS1  *DECK PUSHCO
C     ------------------------------------------------
      SUBROUTINE PUSHCO(IBOX,NBOX,NR,MAB,MIB,ISC,IEND)
C     ------------------------------------------------
      IMPLICIT INTEGER(A-Z)
      DIMENSION IBOX(NBOX),MAB(NBOX),MIB(NBOX),ISC(NBOX)
C
C     IBOX(I),I=1,NBOX STORES NUMBER OF PARTICLES
C                          IN EACH BOX I.
C     NBOX = TOTAL NUMBER OF BOXES.
C     NR   = TOTAL NUMBER OF PARTICLES.
C     MAB(I) = MAXIMUM CAPACITY OF BOX I.
C     MIB(I) = MINIMUM CAPACITY OF BOX I.
C     ISC(I) = SCRATCH ARRAY
C
C     SUBROUTINE RETURNS NEXT GROUP IN THE FULL LIST.
C     IF (IEND.EQ.0) THEN LAST GROUP WAS INPUT IN IBOX.
C     IF (IEND.EQ.1) THEN PUSH WAS SUCCESSFUL.
C
      NP = NR
      DO I=1,NBOX
         ISC(I) = MAB(I) - MIB(I)
         IBOX(I) = IBOX(I) - MIB(I)
         NP = NP - MIB(I)
      ENDDO
      CALL PUSH(IBOX,NBOX,NP,ISC,IEND)
      DO I=1,NBOX
         IBOX(I) = IBOX(I) + MIB(I)
      ENDDO
C
      RETURN
      END
C
C*MODULE ORMAS1  *DECK TOTALCO
C     -------------------------------------------------
      SUBROUTINE TOTALCO(IBOX,NBOX,NR,MAB,MIB,ISC,ITOT)
C     -------------------------------------------------
      IMPLICIT INTEGER(A-Z)
      DIMENSION IBOX(NBOX),MAB(NBOX),MIB(NBOX),ISC(NBOX)
C
C     IBOX(I),I=1,NBOX STORES NUMBER OF PARTICLES
C                          IN EACH BOX I.  SCRATCH.
C     NBOX = TOTAL NUMBER OF BOXES.
C     NR   = TOTAL NUMBER OF PARTICLES.
C     MAB(I) = MAXIMUM CAPACITY OF BOX I.
C     MIB(I) = MINIMUM CAPACITY OF BOX I.
C     ISC(I) = SCRATCH ARRAY
C
C     RETURNED -----
C
C     ITOT = NUMBER OF GROUPS.
C
      NP = NR
      DO I=1,NBOX
         ISC(I) = MAB(I) - MIB(I)
         NP = NP - MIB(I)
      ENDDO
      CALL TOTAL(IBOX,NBOX,NP,ISC,ITOT)
C
      RETURN
      END
C
C*MODULE ORMAS1  *DECK POSITCO
C     ------------------------------------------------------
      SUBROUTINE POSITCO(IBOX,NBOX,NR,MAB,MIB,ISC,JBOX,IPOS)
C     ------------------------------------------------------
      IMPLICIT INTEGER(A-Z)
      DIMENSION IBOX(NBOX),MAB(NBOX),JBOX(NBOX)
      DIMENSION MIB(NBOX),ISC(NBOX)
C
C     IBOX(I),I=1,NBOX STORES NUMBER OF PARTICLES
C                          IN EACH BOX I.  SCRATCH.
C     NBOX = TOTAL NUMBER OF BOXES.
C     NR   = TOTAL NUMBER OF PARTICLES.
C     MAB(I) = MAXIMUM CAPACITY OF BOX I.
C     MIB(I) = MINIMUM CAPACITY OF BOX I.
C     ISC(I) = SCRATCH ARRAY.
C     JBOX = GROUP TO HAVE IT POSITION DETERMINED
C
C     RETURNED -----
C
C     IPOS = POSITION OF JBOX IN FULL SET.
C
      NP = NR
      DO I=1,NBOX
         ISC(I) = MAB(I) - MIB(I)
         JBOX(I) = JBOX(I) - MIB(I)
         NP = NP - MIB(I)
      ENDDO
      CALL POSIT(IBOX,NBOX,NP,ISC,JBOX,IPOS)
      DO I=1,NBOX
         JBOX(I) = JBOX(I) + MIB(I)
      ENDDO
C
      RETURN
      END
C
C*MODULE ORMAS1  *DECK BINOM8
C     --------------------------
      SUBROUTINE BINOM8(IFA,N,M)
C     --------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      INTEGER IFA(0:N,0:M)
C
C     RETURNS ALL BINOMIAL NUMBERS (I,J) FOR I=0,N AND J=0,MIN(I,M)
C     IN IFA. THE BINOMIAL NUMBER (I,J) IS STORED IN IFA(I,J).
C
      DO 11 II=0,N
         DO 12 JJ=0,M
            IFA(II,JJ) = 0
   12    CONTINUE
   11 CONTINUE
C
      DO 13 II=0,N
         IFA(II,0)  = 1
   13 CONTINUE
C
      DO 14 II=0,M
         IFA(II,II) = 1
   14 CONTINUE
C
      DO 113 IY = 2, N
         IZ = MIN(IY-1,M)
         DO 114 IX = 1, IZ
            IFA(IY,IX) = IFA(IY-1,IX-1) + IFA(IY-1,IX)
  114    CONTINUE
  113 CONTINUE
C
C      DO II=0,N
C         WRITE(6,'(100I12)') (IFA(II,JJ),JJ=0,M)
C      ENDDO
C
      RETURN
      END
C
C*MODULE ORMAS1  *DECK TOTDETG
C     --------------------------------------------------------
      SUBROUTINE TOTDETG(IBOX,NBOX,LBST,X,NX,MNUM,IDIM,ITOT)
C     --------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION IBOX(NBOX),LBST(NBOX)
      DIMENSION X(NX)
      DIMENSION MNUM(NBOX),IDIM(NBOX)
C
C     IBOX(I),I=1,NBOX STORES NUMBER OF PARTICLES
C                          IN EACH BOX I.
C     NBOX = TOTAL NUMBER OF BOXES.
C     NR   = TOTAL NUMBER OF PARTICLES.
C     LBST(I) = WHERE BINOMIAL COEFFICIENT FOR SPACE I
C     START IN X.
C     NX IS THE SIZE OF X.  THIS IS VERY SPECIFIC.
C     MNUM(I) = NUMBER OF ORBITALS IN SPACE I
C     IDIM(I) = ROW DIMENSION OF BINOMIAL COEFFICIENTS FOR SPACE I.
C
C     RETURNED -----
C
C     ITOT = TOTAL NUMBER OF DETERMINANTS IN GROUP IBOX.
C
      ITOT = 1
      ISTA1 = LBST(1)
      DO II=1,NBOX
         ISTA2 = LBST(II) - ISTA1 + 1
         ITOT = ITOT *
     *   ISPADET(X(ISTA2),MNUM(II),IDIM(II),IBOX(II))
      ENDDO
C
      RETURN
      END
C
C*MODULE ORMAS1  *DECK ISPADET
C     --------------------------------------------
      INTEGER FUNCTION ISPADET(IFA,NORB,NDIM,NELE)
C     --------------------------------------------
      IMPLICIT INTEGER(A-Z)
      DIMENSION IFA(0:NORB,0:NDIM)
C
      ISPADET = IFA(NORB,NELE)
      RETURN
      END
C
C*MODULE ORMAS1  *DECK MOVEUP
C     ---------------------------------------------
      SUBROUTINE MOVEUP(CON,NELE,NORB)
C     ---------------------------------------------
      IMPLICIT INTEGER(A-Z)
      DIMENSION CON(NELE)
C
      IF (NELE.LT.1) RETURN
C
      IF (CON(NELE).NE.NORB) THEN
         CON(NELE) = CON(NELE)+1
         RETURN
      ELSE
         DO 50 I=NELE-1,1,-1
            IF (CON(I+1)-CON(I).NE.1) THEN
               CON(I) = CON(I) + 1
               DO 40 J=I+1,NELE
                  CON(J) = CON(J-1) + 1
   40          CONTINUE
               RETURN
            ENDIF
   50    CONTINUE
C
      ENDIF
      RETURN
      END
C
C*MODULE ORMAS1  *DECK RESETDE
C     ---------------------------------------------
      SUBROUTINE RESETDE(IBOX,NBOX,NR,MSTA,ICON)
C     ---------------------------------------------
      IMPLICIT INTEGER(A-Z)
      DIMENSION IBOX(NBOX),MSTA(NBOX)
      DIMENSION ICON(NR)
C
C     IBOX(I),I=1,NBOX STORES NUMBER OF PARTICLES
C                          IN EACH BOX I.
C     MSTA(I) = WHERE ORBITAL SPACE I STARTS.
C     NBOX = TOTAL NUMBER OF BOXES.
C     NR   = TOTAL NUMBER OF PARTICLES.
C
C  ---------------
C  RETURNED
C
C     ICON = RETURNED RESET STRING.
C
      ISTE = 0
      DO II=1,NBOX
         ISTO = MSTA(II)-1
         INUM = IBOX(II)
         DO JJ=1,INUM
            ICON(JJ+ISTE) = JJ+ISTO
         ENDDO
         ISTE = ISTE + INUM
      ENDDO
C
      RETURN
      END
C
C*MODULE ORMAS1  *DECK MOVEUP2
C     ----------------------------------------------------
      SUBROUTINE MOVEUP2(IBOX,NBOX,NR,MSTA,ICON)
C     ----------------------------------------------------
      IMPLICIT INTEGER(A-Z)
      DIMENSION IBOX(NBOX),MSTA(NBOX+1)
      DIMENSION ICON(NR)
C
C     IBOX(I),I=1,NBOX STORES NUMBER OF PARTICLES
C                          IN EACH BOX I.
C     MSTA(I) = WHERE ORBITAL SPACE I STARTS.
C     NBOX = TOTAL NUMBER OF BOXES.
C     NR   = TOTAL NUMBER OF PARTICLES.
C
C   ---------------------
C   RETURNED
C
C     ICON = ADVANCED TOTAL STRING.
C
      NC = NR
      DO II=NBOX,1,-1
         IELE=IBOX(II)
         IF (IELE.NE.0) THEN
            NB = NC-IELE+1
            IMST=MSTA(II+1)
            IEND = IMST-IELE
            IF (ICON(NB).NE.IEND) THEN
            CALL MOVEUP(ICON(NB),IELE,IMST-1)
            IF (II.NE.NBOX)
     *   CALL RESETDE(IBOX(II+1),NBOX-II,NR-NC,MSTA(II+1),ICON(NC+1))
            RETURN
            ENDIF
         ENDIF
         NC = NC - IELE
      ENDDO
C
      RETURN
      END
C
C*MODULE ORMAS1  *DECK IDPOS1
C     -----------------------------------------------
      INTEGER FUNCTION IDPOS1(NACT,NOEL,CON,IFA,NDIM)
C     -----------------------------------------------
      IMPLICIT INTEGER(A-Z)
      DIMENSION CON(NOEL)
      DIMENSION IFA(0:NACT,0:NDIM)
C
C     NACT   = NO. OF ORBITALS.
C     NOEL   = NO. OF ELECTRONS.
C     CON(I) = ORBITAL OCCUPIED BY ELECTRON I.
C     IFA    = BINOMIAL COEFFICIENTS.
C     NDIM   = ROW DIMENSION OF THE BINOMIAL COEFFICIENTS.
C
C     RETURNS POSITION OF STRING CON IN FULL STRING LIST.
C
      IPOS1 = 0
      IDPOS1 = 1
      DO 33 I=1,NOEL
         DO 55 J=IPOS1+1,CON(I)-1
            IDPOS1 = IDPOS1 + IFA(NACT-J,NOEL-I)
   55    CONTINUE
         IPOS1 = CON(I)
   33 CONTINUE
C
      RETURN
      END
C
C*MODULE ORMAS1  *DECK IDPOST
C     --------------------------------------------------------
      SUBROUTINE IDPOST(ICON,NA,IBOX,NBOX,MSTA,IDIM,X,NX,LBST,
     *                  LNUM,JCON,IPOS)
C     --------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION ICON(NA),IBOX(NBOX),MSTA(NBOX)
      DIMENSION IDIM(NBOX),LBST(NBOX)
      DIMENSION X(NX)
      DIMENSION LNUM(NBOX),JCON(NA)
C
C     ICON(I) = ORBITAL OCCUPIED BY ELECTRON I.
C     NA      = NO. OF ELECTRONS.
C     IBOX(I),I=1,NBOX STORES NUMBER OF ELECTRONS
C                          IN EACH BOX I.
C     NBOX = TOTAL NUMBER OF BOXES.
C     MSTA(I) = WHERE ORBITAL SPACE I STARTS.
C     IDIM(I) = ROW DIMENSION OF BINOMIAL COEFFICIENTS FOR SPACE I.
C     LBST(I) = WHERE BINOMIAL COEFFICIENT FOR SPACE I
C     START IN X.
C     NX IS THE SIZE OF X.  THIS IS VERY SPECIFIC.
C     LNUM(I) = TOTAL NUMBER OF STRINGS FOR SPACE I.
C     JCON = SCRATCH ARRAY.
C
C     RETURNS POSITION OF STRING ICON IN GROUP STRING LIST.
C
      IPOS = 1
      ISTA1 = LBST(1)
      IELES = 0
      DO II=1,NBOX
         NE = IBOX(II)
         ISTA2 = LBST(II) - ISTA1 + 1
         NACT = MSTA(II+1) - MSTA(II)
         DO JJ=1,NE
            JCON(JJ) = ICON(JJ+IELES)-MSTA(II)+1
         ENDDO
         IPOS1 = IDPOS1(NACT,NE,JCON,X(ISTA2),IDIM(II)) - 1
         DO JJ=II+1,NBOX
            IPOS1 = IPOS1 * LNUM(JJ)
         ENDDO
         IPOS = IPOS + IPOS1
         IELES = IELES + NE
      ENDDO
C
      RETURN
      END
C
C*MODULE ORMAS1  *DECK MAKTABS
C     ------------------------------------------------------------------
      SUBROUTINE MAKTABS(IW,SOME,LBOX1,LBOX2,LBOX3,NSPACE,NA,NB,
     *            LBST,X,
     *            NX,IAMA,IAMI,IBMA,IBMI,MNUM,IDIM,MSTA,IBO,
     *            IDSYM,ISYM1,NSYM,
     *            NACT,LWRK,KTAB,LGMUL,
     *            LCON,LCOA,LCOB,
     *            LANDET,LBNDET,NAST,NBST,LSYMA,LSYMB,LGCOM,
     *            MINI,MAXI,LSPA,LSPB,LDISB,
     *            LSAS,LSBS,LSAC,LSBC,
     *            ITGA,ITGB,IAST,IBST,NCI,NA1EX,NB1EX,FDIRCT)
C     ------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      LOGICAL SOME
      DIMENSION LBOX1(NSPACE),LBOX2(NSPACE),LBOX3(NSPACE),LBST(NSPACE)
      DIMENSION X(NX)
      DIMENSION IAMA(NSPACE),IAMI(NSPACE),IBMA(NSPACE),IBMI(NSPACE)
      DIMENSION MNUM(NSPACE),IDIM(NSPACE),MSTA(NSPACE+1),IBO(NACT)
      DIMENSION LWRK(43),KTAB(NSYM),LGMUL(NSYM,NSYM)
      DIMENSION LCON(NA)
      DIMENSION LCOA(NSYM,ITGA),LCOB(NSYM,ITGB)
      DIMENSION LANDET(NSPACE,ITGA),LBNDET(NSPACE,ITGB)
      DIMENSION NAST(ITGA+1),NBST(ITGB+1)
      DIMENSION LSYMA(IAST),LSYMB(IBST)
      DIMENSION LGCOM(ITGB,ITGA)
      DIMENSION MINI(NSPACE),MAXI(NSPACE)
      DIMENSION LSPA(IAST),LSPB(IBST)
      DIMENSION LDISB(NSYM,ITGB,ITGA)
      DIMENSION LSAS(NSYM+1,ITGA),LSBS(NSYM+1,ITGB)
      DIMENSION LSAC(IAST),LSBC(IBST)
C
      LOGICAL FDIRCT
C
C 1/
C   MAKE SYMMETRY TABLES
C
      IF (IDSYM.GT.0) THEN
      CALL GTAB(IDSYM,ISYM1,KTAB,LWRK(1),LWRK(4),LWRK(7),LWRK(10))
      CALL GMUL(IDSYM,LGMUL,LWRK(1),LWRK(4),LWRK(7),LWRK(10))
      ELSE
      CALL GTAB(1,1,KTAB,LWRK(1),LWRK(4),LWRK(7),LWRK(10))
      CALL GMUL(1,LGMUL,LWRK(1),LWRK(4),LWRK(7),LWRK(10))
      ENDIF
C
      DO II=1,ITGA
         DO JJ=1,NSYM
            LCOA(JJ,II) = 0
         ENDDO
      ENDDO
C
      DO II=1,ITGB
         DO JJ=1,NSYM
            LCOB(JJ,II) = 0
         ENDDO
      ENDDO
C
C  2/
C    MAKE LANDET, LBNDET.  LANDET(I,J) SAYS HOW MANY ALPHA STRINGS
C    THERE ARE FOR GROUP J, SPACE I.  ANALOGOUS FOR LBNDET(I,J).
C
C    LOOP THROUGH ALL ALPHA GROUPS:
C
      ISTA1 = LBST(1)
      CALL RESETCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX2)
      DO II=1,ITGA
         DO JJ=1,NSPACE
            ISTA2 = LBST(JJ) - ISTA1 + 1
            LANDET(JJ,II)=ISPADET(X(ISTA2),MNUM(JJ),IDIM(JJ),LBOX1(JJ))
         ENDDO
      CALL PUSHCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX2,IEND)
      ENDDO
C
C    LOOP THROUGH ALL BETA GROUPS, DO SAME AS ABOVE ESSENTIALLY.
C
      CALL RESETCO(LBOX1,NSPACE,NB,IBMA,IBMI,LBOX2)
      DO II=1,ITGB
         DO JJ=1,NSPACE
            ISTA2 = LBST(JJ) - ISTA1 + 1
            LBNDET(JJ,II)=ISPADET(X(ISTA2),MNUM(JJ),IDIM(JJ),LBOX1(JJ))
         ENDDO
      CALL PUSHCO(LBOX1,NSPACE,NB,IBMA,IBMI,LBOX2,IEND)
      ENDDO
C
C  3/
C    MAKE NAST, NBST.  NAST(I) SAYS WHERE ALPHA STRINGS OF GROUP I
C    START IN FULL STRING LIST - 1.  ANALOGOUS FOR NBST.
C
      NAST(1) = 0
      NBST(1) = 0
      DO II=1,ITGA
         ITOT = 1
         DO JJ=1,NSPACE
            ITOT = ITOT * LANDET(JJ,II)
         ENDDO
         NAST(II+1) = NAST(II) + ITOT
      ENDDO
C
      DO II=1,ITGB
         ITOT = 1
         DO JJ=1,NSPACE
            ITOT = ITOT * LBNDET(JJ,II)
         ENDDO
         NBST(II+1) = NBST(II) + ITOT
      ENDDO
C
C  4/
C       MAKE LGCOM.  IF LGCOM(I,J).NE.0 THEN BETA GROUP I
C       AND ALPHA GROUP J ARE COMPATIBLE.
C
      ICOMP = 0
      CALL RESETCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX3)
      DO JJ=1,ITGA
         CALL RESETCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3)
         DO II=1,ITGB
            LGCOM(II,JJ) = 0
            DO KK=1,NSPACE
               IOC = LBOX1(KK) + LBOX2(KK)
               IF (IOC.GT.MAXI(KK).OR.IOC.LT.MINI(KK)) GO TO 100
            ENDDO
C
            LGCOM(II,JJ) = 1
            ICOMP = ICOMP + 1
  100       CALL PUSHCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3,IEND)
         ENDDO
         CALL PUSHCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX3,IEND)
      ENDDO
C
      IF (SOME) WRITE(IW,9000) ITGA*ITGB,ICOMP
C
C  5/
C    A) MAKE LSYMB.  LSYMB(I) IS SYMMETRY OF BETA STRING I.
C       MAKE LCOB.  LCOB(I,J) IS NUMBER OF DETERMINANTS
C       OF SYMMETRY I IN GROUP J.
C       MAKE LSPB.  LSPB(I) IS BETA STRING I'S SYMMETRY POSITION IN
C       IT'S OWN GROUP.
C
      CALL RESETCO(LBOX1,NSPACE,NB,IBMA,IBMI,LBOX2)
C
C    LOOP THROUGH GROUPS.
C
      ICOUNT = 0
      DO II=1,ITGB
C
C    LOOP THROUGH ALL STRINGS IN GROUP II.
C
         CALL RESETDE(LBOX1,NSPACE,NB,MSTA,LCON)
C
         ITOT = 1
         DO JJ=1,NSPACE
            ITOT = ITOT * LBNDET(JJ,II)
         ENDDO
C
         DO KK=1,ITOT
            ICOUNT = ICOUNT + 1
            CALL GETSYM1(IW,LCON,NACT,NB,IBO,IDSYM,ISYM,
     *      LWRK(1),LWRK(4),LWRK(7),LWRK(10))
            LSYMB(ICOUNT) = ISYM
            LCOB(ISYM,II) = LCOB(ISYM,II) + 1
            LSPB(ICOUNT) = LCOB(ISYM,II)
C
            CALL MOVEUP2(LBOX1,NSPACE,NB,MSTA,LCON)
         ENDDO
C
         CALL PUSHCO(LBOX1,NSPACE,NB,IBMA,IBMI,LBOX2,IEND)
      ENDDO
C
C    B) - MAKE LSYMA.  LSYMA(I) IS SYMMETRY OF ALPHA STRING I.
C       - MAKE LCOA.  LCOA(I,J) IS NUMBER OF DETERMINANTS
C         OF SYMMETRY I IN GROUP J.
C       - MAKE LSPA.  LSPA(I) IS WHERE ALPHA STRING I STARTS IN
C         THE FULL LIST OF DETERMINANTS.  EACH ALPHA STRING IS COUPLED
C         WITH RELEVANT BETA STRINGS (IN BETA GROUP AND SYMMETRY ORDER).
C       - MAKE LDISB.  LDISB(ISYM,I,J) SAYS WHERE BETA GROUP I, AND
C         SYMMETRY ISYM STARTS WHEN COUPLED TO ALPHA GROUP J.
C
      CALL RESETCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX2)
C
C    LOOP THROUGH GROUPS.
C
      ICOUNT = 0
      NCI = 0
      DO II=1,ITGA
C
C    LOOP THROUGH ALL STRINGS IN GROUP II.
C
         CALL RESETDE(LBOX1,NSPACE,NA,MSTA,LCON)
         ITOT = 1
         DO JJ=1,NSPACE
            ITOT = ITOT * LANDET(JJ,II)
         ENDDO
C
         DO KK=1,ITOT
            ICOUNT = ICOUNT + 1
            CALL GETSYM1(IW,LCON,NACT,NA,IBO,IDSYM,ISYM,
     *      LWRK(1),LWRK(4),LWRK(7),LWRK(10))
            LSYMA(ICOUNT) = ISYM
            LCOA(ISYM,II) = LCOA(ISYM,II) + 1
C
            LSPA(ICOUNT) = NCI
            JSYM = KTAB(ISYM)
            DO 200 LL=1,ITGB
               IF (LGCOM(LL,II).EQ.0) GO TO 200
               NCI = NCI + LCOB(JSYM,LL)
  200       CONTINUE
C
            CALL MOVEUP2(LBOX1,NSPACE,NA,MSTA,LCON)
         ENDDO
C
         DO KK=1,NSYM
            LWRK(KK) = 0
         ENDDO
         DO 300 JJ=1,ITGB
            DO KK=1,NSYM
               LDISB(KK,JJ,II) = 0
            ENDDO
            IF (LGCOM(JJ,II).EQ.0) GO TO 300
            DO KK=1,NSYM
               LDISB(KK,JJ,II) = LWRK(KK)
               LWRK(KK) = LWRK(KK) + LCOB(KK,JJ)
            ENDDO
  300    CONTINUE
C
         CALL PUSHCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX2,IEND)
      ENDDO
C
C  6/
C    A) MAKE LSAS,LSBS,AND LSAC, LSBC.
C       LSAS(I,J) SAYS WHERE ALPHA STRINGS
C       OF GROUP J AND SYMMETRY I, START IN LSAC.
C       ANALOGOUS FOR LSBS AND LSBC.
C
      IPLA = 1
      DO II=1,ITGA
         DO JJ=1,NSYM
            LSAS(JJ,II) = IPLA
            IPLA = IPLA + LCOA(JJ,II)
         ENDDO
         LSAS(NSYM+1,II) = IPLA
      ENDDO
C
      IPLB = 1
      DO II=1,ITGB
         DO JJ=1,NSYM
            LSBS(JJ,II) = IPLB
            IPLB = IPLB + LCOB(JJ,II)
         ENDDO
         LSBS(NSYM+1,II) = IPLB
      ENDDO
C
      DO II=1,ITGA
         ITOT = 1
         DO JJ=1,NSYM
            LWRK(JJ) = 0
         ENDDO
         DO JJ=1,NSPACE
            ITOT = ITOT * LANDET(JJ,II)
         ENDDO
         IDISA = NAST(II)
         DO KK=1,ITOT
            JSYM = LSYMA(IDISA+KK)
            LWRK(JSYM) = LWRK(JSYM)+1
            LSAC(LSAS(JSYM,II)+LWRK(JSYM)-1) = KK
         ENDDO
      ENDDO
C
      DO II=1,ITGB
         ITOT = 1
         DO JJ=1,NSYM
            LWRK(JJ) = 0
         ENDDO
         DO JJ=1,NSPACE
            ITOT = ITOT * LBNDET(JJ,II)
         ENDDO
         IDISB = NBST(II)
         DO KK=1,ITOT
            JSYM = LSYMB(IDISB+KK)
            LWRK(JSYM) = LWRK(JSYM)+1
            LSBC(LSBS(JSYM,II)+LWRK(JSYM)-1) = KK
         ENDDO
      ENDDO
C
CC *******************************************
CC  TEST OF STRING ORDERING SYSTEM.
CC  DO NOT DELETE THIS CODE AS IT IS EXCELLENT
CC  FOR POSSIBLE DEBUGS.  JOE
CC *******************************************
CC
C      WRITE(6,*) '***',NCI
C      CALL RESETCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX3)
CC
CC    LOOP THROUGH GROUPS.
CC
C      ICOUNT = 0
C      DO II=1,ITGA
CC
CC    LOOP THROUGH ALL STRINGS IN GROUP II.
CC
C         CALL RESETDE(LBOX1,NSPACE,NA,MSTA,LCON)
CC
C         DO KK=NAST(II)+1,NAST(II+1)
C            JASYM = LSYMA(KK)
C            KSYM = KTAB(JASYM)
CC
CC    LOOP THROUGH ALL APPLICABLE BETA GROUPS
CC
C         CALL RESETCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3)
CC
C         DO IIB = 1,ITGB
C            IF (LGCOM(IIB,II).EQ.0) GO TO 600
CC
C            CALL RESETDE(LBOX2,NSPACE,NB,MSTA,LCON1)
C            ISTA = 1
C            DO KKB=LSBS(KSYM,IIB),LSBS(KSYM+1,IIB)-1
C               IBST = LSBC(KKB)
C               DO IIZ=ISTA,IBST-1
C                  CALL MOVEUP2(LBOX2,NSPACE,NB,MSTA,LCON1)
C               ENDDO
C               ISTA = IBST
C               ICOUNT = ICOUNT + 1
CC
C         CALL POSITCO(LWRK,NSPACE,NA,IAMA,IAMI,LBOX3,LBOX1,IGA)
C         CALL POSITCO(LWRK,NSPACE,NB,IBMA,IBMI,LBOX3,LBOX2,IGB)
C
C            CALL IDPOST(LCON,NA,LBOX1,NSPACE,MSTA,IDIM,X,NX,LBST,
C     *      LANDET(1,IGA),LCON3,IPOSA)
C            CALL IDPOST(LCON1,NB,LBOX2,NSPACE,MSTA,IDIM,X,NX,LBST,
C     *      LBNDET(1,IGB),LCON3,IPOSB)
C            IPOSA = IPOSA + NAST(IGA)
C            IPOSB = IPOSB + NBST(IGB)
C            IBSYM = LSYMB(IPOSB)
CC
CC HERE IS THE POSITION FORMULA.  COMPLICATED YES BUT I DON'T KNOW A
CC BETTER WAY YET.
CC
C            ITOTP = LSPA(IPOSA)+LDISB(IBSYM,IGB,IGA)+LSPB(IPOSB)
CC
C            WRITE(6,*) ITOTP,ICOUNT
C            IF (ICOUNT.NE.ITOTP) THEN
C                STOP
C            ENDIF
CC
C            ENDDO
CC
C  600       CALL PUSHCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3,IEND)
C         ENDDO
CC
C            CALL MOVEUP2(LBOX1,NSPACE,NA,MSTA,LCON)
C         ENDDO
CC
C         CALL PUSHCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX3,IEND)
C      ENDDO
CC
CC ********************************
CC END OF TEST CODE.
CC ********************************
C
      NA1EX = 0
      NB1EX = ITGA
      IF (FDIRCT) RETURN
      NB1EX = 0
C
C ****************************************
C   DETERMINE TOTAL NUMBER OF SINGLE BETA EXCITATIONS
C   WHERE B' > B.
C ****************************************
C
C    LOOP THROUGH ALL BETA GROUPS
C
      CALL RESETCO(LBOX1,NSPACE,NB,IBMA,IBMI,LBOX3)
C
      DO 1000 IIB = 1,ITGB
C
         CALL RESETDE(LBOX1,NSPACE,NB,MSTA,LCON)
C
         DO 900 KKB=NBST(IIB)+1,NBST(IIB+1)
            DO II=1,NSPACE
               LBOX2(II) = LBOX1(II)
            ENDDO
C
C  LOOP OVER ALL SINGLE EXCITATIONS, CHECKING TO SEE
C  IF IT IS VALID.
C
C  LOOP SPACES TO EXCITE ELECTRONS FROM.
C
            IEBS = NB+1
            DO 890 ISPB1=NSPACE,1,-1
               IOC1 = LBOX1(ISPB1)
               IEBE = IEBS - 1
               IEBS = IEBS - IOC1
               IF (IOC1.EQ.0) GO TO 890
               LBOX2(ISPB1) = LBOX2(ISPB1)-1
C
C  LOOP ELECTRONS IN SPACE ISPB1
C  IEBS, IEBE ARE THE ELECTRONS IN SPACE ISPB1
C
               DO 885 IB1=IEBE,IEBS,-1
                  IO1 = LCON(IB1)
C
                  IGBE = IEBE - LBOX1(ISPB1)
C
C  LOOP OVER POSSIBLE SPACES TO EXCITE INTO.
C
               DO 880 ISPB2=ISPB1,NSPACE
C
C  IGBS,IGBE ARE ELECTRONS SPECIFYING ISPB2 SPACE ELECTRON LIMITS.
C
                  IGBS = IGBE + 1
                  IGBE = IGBE + LBOX1(ISPB2)
C
                  LBOX2(ISPB2) = LBOX2(ISPB2) + 1
                  IF (LBOX2(ISPB1).LT.IBMI(ISPB1)) GO TO 870
                  IF (LBOX2(ISPB2).GT.IBMA(ISPB2)) GO TO 870
C
C  MAKE GAP INFORMATION HERE.
C
                  IGBA = MAX(IB1+1,IGBS)
                  IF (LBOX1(ISPB2).EQ.0) THEN
                     ISTA = MSTA(ISPB2)
                     IEND = MSTA(ISPB2+1)-1
                  ELSEIF (ISPB2.EQ.ISPB1) THEN
                     ISTA = IO1+1
                     IEND = LCON(IGBA)-1
                     IF (IB1.EQ.IEBE) IEND=MSTA(ISPB1+1)-1
                  ELSE
                     ISTA = MSTA(ISPB2)
                     IEND = LCON(IGBA)-1
                  ENDIF
C
C  LOOP OVER GAPS
C
                  DO 860 IGAP=IGBA,IGBE+1
C
                     DO 850 JJ=ISTA,IEND
C
                     NB1EX = NB1EX + 1
C
C  ****** ALL THE WORK HAS TO BE DONE IN HERE. *******
C
  850             CONTINUE
C
                  ISTA = LCON(IGAP)+1
                  IEND = LCON(IGAP+1)-1
                  IF (IGAP.EQ.IGBE) IEND=MSTA(ISPB2+1)-1
  860             CONTINUE
C
  870             LBOX2(ISPB2) = LBOX2(ISPB2) - 1
  880          CONTINUE
C
  885          CONTINUE
C
               LBOX2(ISPB1) = LBOX2(ISPB1) + 1
  890       CONTINUE
C
            CALL MOVEUP2(LBOX1,NSPACE,NB,MSTA,LCON)
  900    CONTINUE
C
         CALL PUSHCO(LBOX1,NSPACE,NB,IBMA,IBMI,LBOX3,IEND)
C
 1000 CONTINUE
C
      IF (SOME) WRITE(IW,9010) NB1EX
      RETURN
C
 9000 FORMAT(/1X,'TOTAL NUMBER OF ALPHA-BETA GROUP ',
     *           'COMBINATIONS = ',I12
     *       /1X,'OF THESE THE ALLOWED NUMBER OF ',
     *           'COMBINATIONS   = ',I12)
C
 9010 FORMAT(/1X,'TOTAL NUMBER OF (B -> B`) WHERE  (B` > B)  = ',I12)
C
      END
C
C
C*MODULE ORMAS1  *DECK GETQFCC
C     -----------------------------------------------------
      SUBROUTINE GETQFCC(SI1,SI2,NACT,NCI,NA,NB,
     *           IACON1,IBCON1,INDEX,Q,LBOX1,LBOX2,LBOX3,
     *           NAST,NBST,LSYMA,LSYMB,NSYM,LSPA,LSPB,
     *           LGCOM,LSAS,LSBS,KTAB,LSAC,LSBC,LDISB,
     *           ITGA,ITGB,IAST,IBST)
C     -----------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL FDIRCT,QCORR
C
      COMMON /FCCWFN/ NSPACE,MSTA(51),MNUM(51),MINI(51),MAXI(51),
     *                IAMI(51),IAMA(51),IBMI(51),IBMA(51),IDIM(51),
     *                LBST(51),NREF0,FDIRCT,QCORR,C0SQ
C
      DIMENSION SI1(*),SI2(*)
      DIMENSION IACON1(NA),IBCON1(NA)
      DIMENSION INDEX((NACT*(NACT+1))/2+1),Q(NCI)
      DIMENSION LBOX1(NSPACE),LBOX2(NSPACE),LBOX3(NSPACE)
      DIMENSION NAST(NSYM+1),NBST(NSYM+1),LSYMA(IAST),LSYMB(IBST)
      DIMENSION LSPA(IAST),LSPB(IBST)
      DIMENSION LGCOM(ITGB,ITGA)
      DIMENSION LSAS(NSYM+1,ITGA),LSBS(NSYM+1,ITGB)
      DIMENSION KTAB(NSYM)
      DIMENSION LSAC(IAST),LSBC(IBST),LDISB(NSYM,ITGB,ITGA)
C
      DO II=1,NCI
         Q(II)=0.0D+00
      ENDDO
C
C   BIG LOOP OVER ALPHA
C
      ICOUNT=0
      CALL RESETCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX3)
      DO 1000 IGA=1,ITGA
C
C   LOOP OVER ALL STRINGS ISA, IN GROUP IGA
C
         CALL RESETDE(LBOX1,NSPACE,NA,MSTA,IACON1)
         DO 990 ISA=NAST(IGA)+1,NAST(IGA+1)
            JASYM=LSYMA(ISA)
            KSYM=KTAB(JASYM)
C
C  MAKE ALPHA PART OF DIAGONAL ENERGY.
C
            C=0.0D+00
            DO II=1,NA
               I1=IACON1(II)
               IND1=INDEX(I1+1)
               C=C+SI1(IND1)
               DO JJ=1,II-1
                  I2=IACON1(JJ)
                  IND2=INDEX(I2+1)
                  INDM=INDEX(I1)+I2
                  J1=INDEX(IND1)+IND2
                  J2=INDEX(INDM+1)
                  C=C+SI2(J1)-SI2(J2)
               ENDDO
            ENDDO
C
C  LOOP OVER RELEVANT BETA
C
         CALL RESETCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3)
         DO 800 IGB=1,ITGB
            IF (LGCOM(IGB,IGA).NE.1) GO TO 750
            CALL RESETDE(LBOX2,NSPACE,NB,MSTA,IBCON1)
            ISTAB=1
            DO 700 ISB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
               ICOUNT=ICOUNT+1
C
               IENDB=LSBC(ISB)
               DO KK=ISTAB,IENDB-1
                  CALL MOVEUP2(LBOX2,NSPACE,NB,MSTA,IBCON1)
               ENDDO
               ISTAB=IENDB
C
               D=0.0D+00
               DO JJ=1,NB
                  I2=IBCON1(JJ)
                  IND2=INDEX(I2+1)
                  DO KK=1,NA
                     I1=IACON1(KK)
                     IND1=INDEX(I1+1)
                  IMA = MAX(IND1,IND2)
                  IMI = MIN(IND1,IND2)
                     J2=INDEX(IMA) + IMI
                     D=D+SI2(J2)
                  ENDDO
               ENDDO
               T = C+D
               Q(ICOUNT)=Q(ICOUNT)+T
C
  700       CONTINUE
  750       CALL PUSHCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3,IEND)
  800    CONTINUE
C
            IF (NB.EQ.0) Q(ISA)=Q(ISA)+C
            CALL MOVEUP2(LBOX1,NSPACE,NA,MSTA,IACON1)
  990    CONTINUE
         CALL PUSHCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX3,IEND)
 1000 CONTINUE
C
C  NOW BIG LOOP OVER BETA
C
      CALL RESETCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3)
      DO 2000 IGB=1,ITGB
C
C  LOOP OVER ALL STRINGS ISB, IN GROUP IGB
C
         CALL RESETDE(LBOX2,NSPACE,NB,MSTA,IBCON1)
         DO 1990 ISB=NBST(IGB)+1,NBST(IGB+1)
            JBSYM=LSYMB(ISB)
            KSYM=KTAB(JBSYM)
            IPB1=LSPB(ISB)
C
            C=0.0D+00
            DO II=1,NB
               I1=IBCON1(II)
               IND1=INDEX(I1+1)
               C=C+SI1(IND1)
               DO JJ=1,II-1
                  I2=IBCON1(JJ)
                  IND2=INDEX(I2+1)
                  INDM=INDEX(I1)+I2
                  J1=INDEX(IND1)+IND2
                  J2=INDEX(INDM+1)
                  C=C+SI2(J1)-SI2(J2)
               ENDDO
            ENDDO
C
            DO 1800 IGA=1,ITGA
               IF (LGCOM(IGB,IGA).EQ.0) GO TO 1800
               IPB2=LDISB(JBSYM,IGB,IGA)+IPB1
               IPA2=NAST(IGA)
               DO ISA=LSAS(KSYM,IGA),LSAS(KSYM+1,IGA)-1
                  IPA=LSAC(ISA)+IPA2
                  IPO=LSPA(IPA)
                  ICIT=IPO+IPB2
                  Q(ICIT)=Q(ICIT)+C
               ENDDO
 1800       CONTINUE
C
            CALL MOVEUP2(LBOX2,NSPACE,NB,MSTA,IBCON1)
 1990    CONTINUE
         CALL PUSHCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3,IEND)
 2000 CONTINUE
C
      RETURN
      END
C
C*MODULE ORMAS1  *DECK FCCISRT
C     ----------------------------------------------------
      SUBROUTINE FCCISRT(IPICA,IPICB,CI2,NPIC)
C     ----------------------------------------------------
      IMPLICIT INTEGER(A-Z)
      DIMENSION IPICA(NPIC),IPICB(NPIC)
      DIMENSION CI2(NPIC)
C
C    CODE TO SORT FCCI DETERMINANTS.
C
C    IPICA,IPICB CONTAIN A LIST OF DETERMINANTS, ALPHA AND
C    BETA STRINGS DESIRED FOR A FULL CLASS CI.
C    CI2 CONTAINS THE ACTUAL POSITION OF THE DETERMINANTS.
C
C    IPICA,IPICB WILL CONTAIN THE LIST OF DETERMINANTS ORDERED
C    FIRST ACCORDING TO ALPHA AND THEN BETA.
C    CI2 WILL CONTAIN THE ACTUAL POSITION OF THE DETERMINANTS
C    WHICH WILL NOW BE IN ASCENDING ORDER.
C
      N = NPIC
      L=N/2+1
      IR=N
C
   10 CONTINUE
         IF (L.GT.1) THEN
            L=L-1
            RRA=CI2(L)
            IRRB=IPICA(L)
            IRRC=IPICB(L)
         ELSE
            RRA=CI2(IR)
            IRRB=IPICA(IR)
            IRRC=IPICB(IR)
            CI2(IR)=CI2(1)
            IPICA(IR)=IPICA(1)
            IPICB(IR)=IPICB(1)
C
            IR=IR-1
            IF (IR.EQ.1) THEN
               CI2(1)=RRA
               IPICA(1)=IRRB
               IPICB(1)=IRRC
C
               GO TO 122
            ENDIF
         ENDIF
         I=L
         J=L+L
   20    IF (J.LE.IR) THEN
            IF (J.LT.IR) THEN
                   IF (CI2(J).LT.CI2(J+1)) J=J+1
            ENDIF
            IF (RRA.LT.CI2(J)) THEN
               CI2(I)=CI2(J)
               IPICA(I)=IPICA(J)
               IPICB(I)=IPICB(J)
               I=J
               J=J+J
            ELSE
               J=IR+1
            ENDIF
         GO TO 20
         ENDIF
         CI2(I)=RRA
         IPICA(I)=IRRB
         IPICB(I)=IRRC
      GO TO 10
C
  122 CONTINUE
C
      RETURN
      END
C
C*MODULE ORMAS1  *DECK FCCIHE
C     --------------------------------------------------------
      SUBROUTINE FCCIHE(SINT1,SINT2,NORB,NAELE,NBELE,
     *       IACON1,IBCON1,IACON2,IBCON2,IJ,JI,INDEX,ELEM)
C     --------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION IACON1(NAELE),IBCON1(NBELE)
      DIMENSION IACON2(NAELE),IBCON2(NBELE)
      DIMENSION SINT1(*),SINT2(*)
      DIMENSION INDEX(NORB*(NORB+1)/2+1)
      INTEGER DIFF1(2),DIFF2(2),IPOS1(2),IPOS2(2)
C
C     RETURNS THE MATRIX ELEMENT < K | H | L > WHERE K, L ARE
C     DETERMINANTS.  ALPHA AND BETA OCCUPATIONS ARE STORED IN
C     IACON1, IBCON1 FOR K AND IACON2, IBCON2 FOR L.
C
      ELEM = 0.0D+00
C
C    IF DETERMINANTS ARE SAME
C
      IF (IJ.EQ.JI) THEN
         DO 200 I=1,NAELE
            IA = IACON1(I)
            I1 = INDEX(IA+1)
            ELEM = ELEM + SINT1(I1)
            DO 197 J=I+1,NAELE
               IA1 = IACON1(J)
               I2 = INDEX(IA1+1)
               IT = INDEX(I2)+I1
               ELEM = ELEM + SINT2(IT)
               IC = INDEX(IA1)+IA
               IT = INDEX(IC+1)
               ELEM = ELEM - SINT2(IT)
C
  197       CONTINUE
            DO 198 J=1,NBELE
               IB1 = IBCON1(J)
               I2 = INDEX(IB1+1)
               IMA = MAX(I1,I2)
               IMI = MIN(I1,I2)
               IT = INDEX(IMA) + IMI
               ELEM = ELEM + SINT2(IT)
  198       CONTINUE
  200    CONTINUE
C
         DO 210 I=1,NBELE
            IB = IBCON1(I)
            I1 = INDEX(IB+1)
            ELEM = ELEM + SINT1(I1)
            DO 204 J=I+1,NBELE
               IB1 = IBCON1(J)
               I2 = INDEX(IB1+1)
               IT = INDEX(I2)+I1
               ELEM = ELEM + SINT2(IT)
               IC = INDEX(IB1)+IB
               IT = INDEX(IC+1)
               ELEM = ELEM - SINT2(IT)
  204       CONTINUE
  210    CONTINUE
      RETURN
      ENDIF
C
      IDEA=0
      IDEB=0
C
C     DIFFERENT ORBITALS IN FIRST DETERINANT
C
      DO 20 I=1,NAELE
         DO 15 J=1,NAELE
            IF (IACON1(I).EQ.IACON2(J)) GO TO 20
   15    CONTINUE
         IDEA = IDEA + 1
         IF (IDEA.GT.2) RETURN
         DIFF1(IDEA) = IACON1(I)
         IPOS1(IDEA) = I
   20 CONTINUE
C
      DO 30 I=1,NBELE
         DO 25 J=1,NBELE
            IF (IBCON1(I).EQ.IBCON2(J)) GO TO 30
   25    CONTINUE
         IDEB = IDEB + 1
         IF (IDEA+IDEB.GT.2) RETURN
         DIFF1(IDEA+IDEB) = IBCON1(I)
         IPOS1(IDEA+IDEB) = I
   30 CONTINUE
C
C
C    TO FIND THE DIFFERENT ORBITALS IN SECOND DETERMINANT
C
      IST = 1
      DO 63 II=1,IDEA
            DO 50 I=IST,NAELE
               DO 45 J=1,NAELE
                  IF (IACON2(I).EQ.IACON1(J)) GO TO 50
   45          CONTINUE
               GO TO 60
   50       CONTINUE
C
   60       DIFF2(II) = IACON2(I)
            IPOS2(II) = I
            IST = I+1
   63 CONTINUE
C
      IST = 1
      DO 163 II=1,IDEB
            DO 150 I=IST,NBELE
               DO 145 J=1,NBELE
                  IF (IBCON2(I).EQ.IBCON1(J)) GO TO 150
  145          CONTINUE
               GO TO 160
  150       CONTINUE
  160       DIFF2(II+IDEA) = IBCON2(I)
            IPOS2(II+IDEA) = I
            IST = I+1
  163 CONTINUE
C
C    IF DETERMINANTS DIFFER BY ONE ORBITAL
C
       IF (IDEA+IDEB.EQ.1) THEN
C
C   ONE PARTICLE DENSITY CONTRIBUTION
C
          ID1 = DIFF1(1)
          ID2 = DIFF2(1)
          IDA = MAX(ID1,ID2)
          IDI = MIN(ID1,ID2)
          IND1 = INDEX(IDA) + IDI
          IPERM = (-1)**(IPOS1(1)-IPOS2(1))
          ELEM = ELEM + IPERM*SINT1(IND1)
C
C    TWO PARTICLE DENSITY CONTRIBUTION
C
C    IF DIFFERENT ORBITALS ARE ALPHA SPIN ORBS
C
         IF (IDEA.EQ.1) THEN
           DO 673 K=1,NAELE
              NK = IACON1(K)
              IF (NK.EQ.ID1) GO TO 673
              IND2 = INDEX(NK+1)
              IMA = MAX(IND1,IND2)
              IMI = MIN(IND1,IND2)
              INDX = INDEX(IMA) + IMI
              ELEM = ELEM + SINT2(INDX)*IPERM
              IMA = MAX(ID1,NK)
              IMI = MIN(ID1,NK)
              I1 = INDEX(IMA) + IMI
              IMA = MAX(ID2,NK)
              IMI = MIN(ID2,NK)
              I2 = INDEX(IMA) + IMI
              IMA = MAX(I1,I2)
              IMI = MIN(I1,I2)
              INX = INDEX(IMA) + IMI
              ELEM = ELEM - IPERM*SINT2(INX)
  673     CONTINUE
C
           DO 678 K=1,NBELE
              NK = IBCON1(K)
              IND2 = INDEX(NK+1)
              IMA = MAX(IND1,IND2)
              IMI = MIN(IND1,IND2)
              INDX = INDEX(IMA) + IMI
              ELEM = ELEM + IPERM*SINT2(INDX)
  678     CONTINUE
C
        ELSE
C
C     DIFFERENT ORBITALS ARE BETA SPIN ORBS
C
           DO 732 K=1,NAELE
              NK = IACON1(K)
              IND2 = INDEX(NK+1)
              IMA = MAX(IND1,IND2)
              IMI = MIN(IND1,IND2)
              INDX = INDEX(IMA) + IMI
              ELEM = ELEM + IPERM*SINT2(INDX)
  732      CONTINUE
C
           DO 752 K=1,NBELE
              NK = IBCON1(K)
              IF (NK.EQ.ID1) GO TO 752
              IND2 = INDEX(NK+1)
              IMA = MAX(IND1,IND2)
              IMI = MIN(IND1,IND2)
              INDX = INDEX(IMA) + IMI
              ELEM = ELEM + IPERM*SINT2(INDX)
              IMA = MAX(ID1,NK)
              IMI = MIN(ID1,NK)
              I1 = INDEX(IMA) + IMI
              IMA = MAX(ID2,NK)
              IMI = MIN(ID2,NK)
              I2 = INDEX(IMA) + IMI
              IMA = MAX(I1,I2)
              IMI = MIN(I1,I2)
              INX = INDEX(IMA) + IMI
              ELEM = ELEM - IPERM*SINT2(INX)
  752      CONTINUE
C
          ENDIF
          RETURN
C
      ELSE
C
C     TWO ORBITALS ARE DIFFERENT
C     CONTRIBUTION ONLY TO 2-PARTICLE DENSITY MATRIX.
C     DIFFERING ORBITALS IN DIFF1(1),DIFF1(2) FOR CON1 AND
C     DIFF2(1),DIFF2(2) FOR CON2.  POSITION STORED IN
C     IPOS1(1),IPOS1(2) AND IPOS2(1),IPOS2(2).
C
         IPERM = (-1)**(IPOS1(1)-IPOS2(1)+IPOS1(2)-IPOS2(2))
         I11 = DIFF1(1)
         I12 = DIFF2(1)
         I21 = DIFF1(2)
         I22 = DIFF2(2)
         IMA = MAX(I11,I12)
         IMI = MIN(I11,I12)
         I1 = INDEX(IMA) + IMI
         IMA = MAX(I21,I22)
         IMI = MIN(I21,I22)
         I2 = INDEX(IMA) + IMI
         IMA = MAX(I1,I2)
         IMI = MIN(I1,I2)
         INX = INDEX(IMA) + IMI
         ELEM = ELEM + IPERM*SINT2(INX)
C
C     IF ALL DIFFERING ORBITALS ARE OR SAME SPIN THEN
C     HAVE EXTRA MATRIX ELEMENTS.
C
         IF (IDEA.EQ.2.OR.IDEB.EQ.2) THEN
            IMA = MAX(I11,I22)
            IMI = MIN(I11,I22)
            I1 = INDEX(IMA) + IMI
            IMA = MAX(I12,I21)
            IMI = MIN(I12,I21)
            I2 = INDEX(IMA) + IMI
            IMA = MAX(I1,I2)
            IMI = MIN(I1,I2)
            INX = INDEX(IMA) + IMI
            ELEM = ELEM - IPERM*SINT2(INX)
         ENDIF
      ENDIF
C
      RETURN
      END
C
C*MODULE ORMAS1  *DECK INITFCC
C     -----------------------------------------------------
      SUBROUTINE INITFCC(IW,SOME,B,NCI,NA,NB,NACT,IACON1,IBCON1,
     *           IACON2,IBCON2,ISD,IDO,CI,IWRK1,MAXWX,KST,
     *           INDEX,F,EL,EF,SI1,SI2,IWRK2,IMARK,AB,
     *           LGCOM,NAST,NBST,LSYMA,LSYMB,
     *           LSBS,LSBC,LSPA,LSPB,LDISB,
     *           LBOX1,LBOX2,LBOX3,LBOX4,LBOX5,
     *           X,NX,LANDET,LBNDET,
     *           ITGA,ITGB,IAST,IBST,KTAB,NSYM)
C     -----------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL FDIRCT,QCORR
C
      COMMON /FCCWFN/ NSPACE,MSTA(51),MNUM(51),MINI(51),MAXI(51),
     *                IAMI(51),IAMA(51),IBMI(51),IBMA(51),IDIM(51),
     *                LBST(51),NREF0,FDIRCT,QCORR,C0SQ
C
      LOGICAL SOME
      DIMENSION SI1(*),SI2(*),IWRK2(MAXWX),AB(NCI,KST)
      DIMENSION LANDET(NSPACE,ITGA),LBNDET(NSPACE,ITGB)
      DIMENSION IACON1(NA),IBCON1(NA),IACON2(NA),IBCON2(NA)
      DIMENSION CI(NCI,KST),IWRK1(MAXWX,2)
      DIMENSION INDEX((NACT*(NACT+1))/2+1)
      DIMENSION ISD(NA+NB),IDO(NA)
      DIMENSION F((MAXWX*(MAXWX+1))/2),EF(MAXWX,MAXWX),EL(MAXWX)
      DIMENSION LGCOM(ITGB,ITGA),NAST(ITGA+1),NBST(ITGB+1)
      DIMENSION LSYMA(IAST),LSYMB(IBST)
      DIMENSION LSBS(NSYM+1,ITGB)
      DIMENSION LSBC(IBST)
      DIMENSION LSPA(IAST),LSPB(IBST),LDISB(NSYM,ITGB,ITGA)
      DIMENSION LBOX1(NSPACE),LBOX2(NSPACE),LBOX3(NSPACE)
      DIMENSION LBOX4(NSPACE),LBOX5(NSPACE)
      DIMENSION KTAB(NSYM)
C
      MAXW1=MAXWX
      IBG=1
      IMARK=0
      IF (NCI.LE.MAXW1) THEN
         MAXW1=NCI
         IMARK=1
         IF(SOME) WRITE(IW,*)
     *        'SMALL CI MATRIX, JUST USING INCORE DIAGONALIZATION...'
      ELSE
         IF(NB.EQ.0) THEN
            WRITE(IW,9020) NCI,MAXW1,NCI
            CALL ABRT
            STOP
         END IF
      ENDIF
      IF (KST.GT.NCI) THEN
         IF(SOME) WRITE(IW,9010) KST,NCI
         CALL ABRT
         STOP
      ENDIF
C
C   SORT OF A LOOP STRUCTURE HERE, KEEP COMING
C   BACK TO 999 UNTIL ALL INITIAL DETERMINANT SPACE <=MAXW1
C   ARE FOUND.
C
  999 CONTINUE
      IF (IBG.GT.MAXW1) GO TO 9999
      PMIN = 100.0D+00
      IND = 0
      DO II=1,NCI
         IF (CI(II,1).LT.PMIN) THEN
            IND = II
            PMIN = CI(IND,1)
         ENDIF
      ENDDO
C
C FOR NB=0
C
      IF (NB.EQ.0) THEN
         IWRK1(IBG,1) = IND
         IWRK1(IBG,2) = 1
         IWRK2(IBG) = IND
         CI(IND,1) = 101.0D+00
         IBG = IBG + 1
         GO TO 999
      ENDIF
C
C  STORE THE ALPHA AND BETA INDICES.
C
      ICI=0
      DO 100 IGA=1,ITGA
         DO 80 ISA=NAST(IGA)+1,NAST(IGA+1)
            JASYM=LSYMA(ISA)
            KSYM=KTAB(JASYM)
            DO 60 IGB=1,ITGB
               IF (LGCOM(IGB,IGA).NE.1) GO TO 60
               DO 40 ISB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                  ICI=ICI+1
                  IF (ICI.NE.IND) GO TO 40
                  NEND=LSBC(ISB)+NBST(IGB)
                  GO TO 200
   40          CONTINUE
   60       CONTINUE
   80    CONTINUE
  100 CONTINUE
C
  200 CONTINUE
C
      ISB = NEND
C
C  MAKE THE ALPHA AND BETA PARTS.
C
      IDEA = ISA - NAST(IGA)
      CALL RESETCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX3)
      DO II=1,IGA-1
         CALL PUSHCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX3,ISE)
      ENDDO
      CALL RESETDE(LBOX1,NSPACE,NA,MSTA,IACON1)
      DO II=1,IDEA-1
         CALL MOVEUP2(LBOX1,NSPACE,NA,MSTA,IACON1)
      ENDDO
C
      IDEB = ISB - NBST(IGB)
      CALL RESETCO(LBOX1,NSPACE,NB,IBMA,IBMI,LBOX3)
      DO II=1,IGB-1
         CALL PUSHCO(LBOX1,NSPACE,NB,IBMA,IBMI,LBOX3,ISE)
      ENDDO
      CALL RESETDE(LBOX1,NSPACE,NB,MSTA,IBCON1)
      DO II=1,IDEB-1
         CALL MOVEUP2(LBOX1,NSPACE,NB,MSTA,IBCON1)
      ENDDO
C
C  FIND DOUBLY OCCUPIED ORBITALS, PUT IN BEGINNING OF ISD.
C
      NSS = 0
      NSD = 0
      DO II=1,NA
         IA = IACON1(II)
         DO JJ=1,NB
            IF (IA.EQ.IBCON1(JJ)) THEN
               NSD = NSD + 1
               ISD(NSD) = IA
            ENDIF
         ENDDO
      ENDDO
C
C   CHECK TO SEE IF ALL BETA ORBITALS ARE PAIRED.
C
      IF (NSD.EQ.NB) THEN
         IWRK1(IBG,1) = ISA
         IWRK1(IBG,2) = ISB
         IWRK2(IBG) = IND
         CI(IND,1) = 101.0D+00
         IBG = IBG + 1
         IF (IBG.LE.MAXW1) GO TO 999
         GO TO 9999
      ENDIF
C
C      FIND SINGLY OCCUPIED ORBS NOW, PUT IN END OF ISD, BETA FIRST
C      THEN ALPHA.
C
      DO 20 II=1,NB
         IB = IBCON1(II)
         DO 24 JJ=1,NSD
            IF (IB.EQ.ISD(JJ)) GO TO 20
   24    CONTINUE
         NSS = NSS + 1
         ISD(NSS+NSD) = IB
   20 CONTINUE
C
      DO 30 II=1,NA
         IA = IACON1(II)
         DO 34 JJ=1,NSD
            IF (IA.EQ.ISD(JJ)) GO TO 30
   34    CONTINUE
         NSS = NSS + 1
         ISD(NSS+NSD) = IA
   30 CONTINUE
C
C       REORDER THE THINGS.
C
      DO II=1,NSS-1
         DO JJ=II+1,NSS
            IF (ISD(JJ+NSD).LT.ISD(II+NSD)) THEN
               KK=ISD(II+NSD)
               ISD(II+NSD) = ISD(JJ+NSD)
               ISD(JJ+NSD) = KK
            ENDIF
         ENDDO
      ENDDO
C
C  DETERMINE HOW MANY DETERMINANTS THERE ARE WITH THE
C  SAME SPACE FUNCTION.
C
      NSPA=NA-NSD
      NTOP=1
      NBOT=1
      DO II=NSPA+1,NSS
         NTOP=NTOP*II
      ENDDO
      DO II=1,NSS-NSPA
         NBOT=NBOT*II
      ENDDO
      NODE = NTOP/NBOT
C
      IF (NODE+IBG-1.GT.MAXW1) GO TO 9999
      DO II=1,NSPA
         IDO(II) = II
      ENDDO
C
C     NOW TO STORE POSITIONS OF ALL POSSIBLE DETERMINANTS WITH
C     SAME SPACE FUNCTION.  ALPHA FIRST.
C
      DO 3000 IJK=1,NODE
         DO II=1,NSD
            IACON1(II) = ISD(II)
         ENDDO
         DO II=1,NSPA
            IACON1(II+NSD) = ISD(NSD+IDO(II))
         ENDDO
C
C   MUST REORDER HERE.
C
         DO II=1,NA-1
            DO JJ=II+1,NA
               IF (IACON1(JJ).LT.IACON1(II)) THEN
                  KK=IACON1(II)
                  IACON1(II) = IACON1(JJ)
                  IACON1(JJ) = KK
               ENDIF
            ENDDO
         ENDDO
C
C  DETERMINE THE POSITION OF THE ALPHA STRING
C
         CALL GETBOX(LBOX1,IACON1,NA,MSTA,NSPACE)
         CALL POSITCO(LBOX2,NSPACE,NA,IAMA,IAMI,LBOX3,LBOX1,IGA)
         CALL IDPOST(IACON1,NA,LBOX1,NSPACE,MSTA,IDIM,X,NX,LBST,
     *        LANDET(1,IGA),IBCON1,IPOSA)
C
         IWRK1(IJK+IBG-1,1) = IPOSA+NAST(IGA)
C
         CALL ADVANC(IDO,NSPA,NSS)
 3000 CONTINUE
C
C  NOW FOR THE BETA
C
      NSPB=NB-NSD
      DO II=1,NSPB
         IDO(II)=II
      ENDDO
C
      DO 4000 IJK=1,NODE
         DO II=1,NSD
            IBCON1(II) = ISD(II)
         ENDDO
         DO II=1,NSPB
            IBCON1(II+NSD) = ISD(NSD+IDO(II))
         ENDDO
C
C  MUST REORDER HERE
C
         DO II=1,NB-1
            DO JJ=II+1,NB
               IF (IBCON1(JJ).LT.IBCON1(II)) THEN
                  KK=IBCON1(II)
                  IBCON1(II) = IBCON1(JJ)
                  IBCON1(JJ) = KK
               ENDIF
            ENDDO
         ENDDO
C
C  DETERMINE THE POSITION OF THE BETA STRING.
C
         CALL GETBOX(LBOX1,IBCON1,NB,MSTA,NSPACE)
         CALL POSITCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3,LBOX1,IGB)
         CALL IDPOST(IBCON1,NB,LBOX1,NSPACE,MSTA,IDIM,X,NX,LBST,
     *        LBNDET(1,IGB),IACON1,IPOSB)
C
         IWRK1(IBG+NODE-IJK,2) = IPOSB+NBST(IGB)
C
         CALL ADVANC(IDO,NSPB,NSS)
 4000 CONTINUE
C
C  ZERO ALL DIAGONAL ELEMENTS JUST FOUND.
C
      DO II=1,NODE
         INA=IWRK1(II+IBG-1,1)
         DO 110 IGA=1,ITGA
            IF (NAST(IGA+1).GE.INA) GO TO 120
  110    CONTINUE
  120    CONTINUE
         INB=IWRK1(II+IBG-1,2)
         DO 130 IGB=1,ITGB
            IF (NBST(IGB+1).GE.INB) GO TO 140
  130    CONTINUE
  140    CONTINUE
         ISYMB = LSYMB(INB)
         IND = LSPA(INA)+LDISB(ISYMB,IGB,IGA)+LSPB(INB)
         IWRK2(II+IBG-1) = IND
         CI(IND,1) = 101.0D+00
      ENDDO
C
      IBG = IBG + NODE
      GO TO 999
C
 9999 CONTINUE
      NSIZE = IBG - 1
C
C  NOW TO REORDER ACCORDING TO POSITION OF DETERMINANTS.
C
      IF (NSIZE.GT.1) CALL FCCISRT(IWRK1,IWRK1(1,2),IWRK2,NSIZE)
C
C  NOW TO FORM THE HAMILTONIAN.
C
      IXI=0
      IGAS=1
      INAS=1
      CALL RESETCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX3)
      CALL RESETDE(LBOX1,NSPACE,NA,MSTA,IACON1)
      IGBS=1
      INBS=1
      CALL RESETCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3)
      CALL RESETDE(LBOX2,NSPACE,NB,MSTA,IBCON1)
C
      DO 6000 IJK=1,NSIZE
C A
         INAE=IWRK1(IJK,1)
         DO II=IGAS,ITGA
            IF (NAST(II+1).GE.INAE) GO TO 150
         ENDDO
  150    CONTINUE
         IF (II.GT.IGAS) THEN
            DO JJ=IGAS,II-1
               CALL PUSHCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX3,ISE)
            ENDDO
            CALL RESETDE(LBOX1,NSPACE,NA,MSTA,IACON1)
            IGAS=II
            INAS=1
         ENDIF
         INAE = INAE - NAST(IGAS)
         DO KK=INAS,INAE-1
            CALL MOVEUP2(LBOX1,NSPACE,NA,MSTA,IACON1)
         ENDDO
         INAS = INAE
C B
         INBE=IWRK1(IJK,2)
         DO II=1,ITGB
            IF (NBST(II+1).GE.INBE) GO TO 160
         ENDDO
  160    CONTINUE
         IF (II.LT.IGBS) THEN
            CALL RESETCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3)
            DO JJ=1,II-1
               CALL PUSHCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3,ISE)
            ENDDO
            CALL RESETDE(LBOX2,NSPACE,NB,MSTA,IBCON1)
            IGBS=II
            INBS=1
         ELSEIF (II.GT.IGBS) THEN
            DO JJ=IGBS,II-1
               CALL PUSHCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3,ISE)
            ENDDO
            CALL RESETDE(LBOX2,NSPACE,NB,MSTA,IBCON1)
            IGBS=II
            INBS=1
         ENDIF
         INBE = INBE - NBST(IGBS)
         IF (INBS.GT.INBE) THEN
            CALL RESETDE(LBOX2,NSPACE,NB,MSTA,IBCON1)
            INBS=1
         ENDIF
         DO KK=INBS,INBE-1
            CALL MOVEUP2(LBOX2,NSPACE,NB,MSTA,IBCON1)
         ENDDO
         INBS = INBE
C
      IGAS2=1
      INAS2=1
      CALL RESETCO(LBOX4,NSPACE,NA,IAMA,IAMI,LBOX3)
      CALL RESETDE(LBOX4,NSPACE,NA,MSTA,IACON2)
      IGBS2=1
      INBS2=1
      CALL RESETCO(LBOX5,NSPACE,NB,IBMA,IBMI,LBOX3)
      CALL RESETDE(LBOX5,NSPACE,NB,MSTA,IBCON2)
C
      DO 5000 KJI=1,IJK
         IXI=IXI+1
C A
         INAE2=IWRK1(KJI,1)
         DO II=IGAS2,ITGA
            IF (NAST(II+1).GE.INAE2) GO TO 250
         ENDDO
  250    CONTINUE
         IF (II.GT.IGAS2) THEN
            DO JJ=IGAS2,II-1
               CALL PUSHCO(LBOX4,NSPACE,NA,IAMA,IAMI,LBOX3,ISE)
            ENDDO
            CALL RESETDE(LBOX4,NSPACE,NA,MSTA,IACON2)
            IGAS2=II
            INAS2=1
         ENDIF
         INAE2 = INAE2 - NAST(IGAS2)
         DO KK=INAS2,INAE2-1
            CALL MOVEUP2(LBOX4,NSPACE,NA,MSTA,IACON2)
         ENDDO
         INAS2 = INAE2
C B
         INBE2=IWRK1(KJI,2)
         DO II=1,ITGB
            IF (NBST(II+1).GE.INBE2) GO TO 260
         ENDDO
  260    CONTINUE
         IF (II.LT.IGBS2) THEN
            CALL RESETCO(LBOX5,NSPACE,NB,IBMA,IBMI,LBOX3)
            DO JJ=1,II-1
               CALL PUSHCO(LBOX5,NSPACE,NB,IBMA,IBMI,LBOX3,ISE)
            ENDDO
            CALL RESETDE(LBOX5,NSPACE,NB,MSTA,IBCON2)
            IGBS2=II
            INBS2=1
         ELSEIF (II.GT.IGBS2) THEN
            DO JJ=IGBS2,II-1
               CALL PUSHCO(LBOX5,NSPACE,NB,IBMA,IBMI,LBOX3,ISE)
            ENDDO
            CALL RESETDE(LBOX5,NSPACE,NB,MSTA,IBCON2)
            IGBS2=II
            INBS2=1
         ENDIF
         INBE2 = INBE2 - NBST(IGBS2)
         IF (INBS2.GT.INBE2) THEN
            CALL RESETDE(LBOX5,NSPACE,NB,MSTA,IBCON2)
            INBS2=1
         ENDIF
         DO KK=INBS2,INBE2-1
            CALL MOVEUP2(LBOX5,NSPACE,NB,MSTA,IBCON2)
         ENDDO
         INBS2=INBE2
C
         CALL FCCIHE(SI1,SI2,NACT,NA,NB,IACON1,IBCON1,
     *             IACON2,IBCON2,IJK,KJI,INDEX,ELEM)
C
         F(IXI) = ELEM
C
 5000 CONTINUE
 6000 CONTINUE
C
      CALL EVVRSP(-1,NSIZE,NSIZE,(NSIZE*(NSIZE+1))/2,MAXWX,
     *              F,B,IWRK1,EL,EF,0,IERR)
      IF (IERR.NE.0) THEN
         IF(SOME) WRITE(IW,*) 'ERROR IN SMALL DIAGONALIZATION'
         IF(SOME) WRITE(IW,*) 'IERR = ',IERR
         RETURN
      ENDIF
C
      DO 347 II=1,NCI
         DO 450 JJ=1,KST
         CI(II,JJ) = 0.0D+00
         AB(II,JJ) = 0.0D+00
  450    CONTINUE
  347 CONTINUE
C
      DO 799 IJK=1,KST
         DO 899 II=1,NSIZE
            KI = IWRK2(II)
            CI(KI,IJK) = EF(II,IJK)
  899    CONTINUE
  799 CONTINUE
C
      RETURN
C
 9010 FORMAT(/1X,'***** ERROR *****'/
     *       1X,'INPUT NSTATE=',I4,' EXCEEDS HAMILTONIAN DIMENSION',I5)
 9020 FORMAT(/1X,'***** ERROR *****'/
     *   1X,'THIS JOB HAS NO BETA ELECTRONS, AND MORE DETERMINANTS=',I8/
     *   1X,'THAN THE INITIAL HAMILTONIAN MATRIX GUESS SIZE=',I8,'.'/
     *   1X,'PLEASE INCREASE -NHGSS- IN $DET TO ',I8,' AND RERUN.')
C
      END
C
C*MODULE ORMAS1  *DECK FCCSPIN
C     ----------------------------------------------------------
      SUBROUTINE FCCSPIN(NA,NB,IACON1,IACON2,IBCON1,IBCON2,
     *           ISD,IDO,CI,AB,NV,NCI,SPIN,IWRK1,IWRK2,MAXW1,
     *           LGCOM,NAST,NBST,LSYMA,LSYMB,
     *           LSBS,LSBC,LSPA,LSPB,LDISB,
     *           LBOX1,LBOX2,LBOX3,LBOX4,LBOX5,
     *           X,NX,LANDET,LBNDET,
     *           ITGA,ITGB,IAST,IBST,KTAB,NSYM)
C     ----------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL FDIRCT,QCORR
C
      COMMON /FCCWFN/ NSPACE,MSTA(51),MNUM(51),MINI(51),MAXI(51),
     *                IAMI(51),IAMA(51),IBMI(51),IBMA(51),IDIM(51),
     *                LBST(51),NREF0,FDIRCT,QCORR,C0SQ
C
      DIMENSION CI(NCI,NV),AB(NCI,NV)
      DIMENSION IACON1(NA),IBCON1(NB)
      DIMENSION IACON2(NA),IBCON2(NB)
      DIMENSION ISD(NA+NB),IDO(NA)
      DIMENSION IWRK1(MAXW1,2),IWRK2(MAXW1)
      DIMENSION SPIN(NV)
      DIMENSION X(NX),LANDET(NSPACE,ITGA),LBNDET(NSPACE,ITGB)
      DIMENSION LGCOM(ITGB,ITGA),NAST(ITGA+1),NBST(ITGB+1)
      DIMENSION LSYMA(IAST),LSYMB(IBST)
      DIMENSION LSBS(NSYM+1,ITGB)
      DIMENSION LSBC(IBST)
      DIMENSION LSPA(IAST),LSPB(IBST),LDISB(NSYM,ITGB,ITGA)
      DIMENSION LBOX1(NSPACE),LBOX2(NSPACE),LBOX3(NSPACE)
      DIMENSION LBOX4(NSPACE),LBOX5(NSPACE)
      DIMENSION KTAB(NSYM)
C
C     RETURNS SPIN OF CI VECTOR I IN SPIN(I) FOR FULL SPACE
C     DETERMINANTAL WAVEFUNCTION.
C     NBIG IS THE NUMBER OF HIGHEST CI COEFFICIENTS TO TAKE.
C
      CRIT = 1.0D-10
      NBIG=MIN(5,NCI)
C
      DO II=1,NV
         SPIN(II) = 0.0D+00
      ENDDO
C
      DO II=1,NV
         DO JJ=1,NCI
            AB(JJ,II) = CI(JJ,II)
         ENDDO
      ENDDO
C
C  LOOP OVER STATES
C
      DO 9000 JJJ=1,NV
         ZNORM = 0.0D+0
C
C  LOOP OVER NBIG
C
         DO 8000 III=1,NBIG
            NDONE=0
C
C  FIND THE LARGEST CI COEFFICIENT.
C
            IND = 1
            PMIN = 0.0D+00
            DO II=1,NCI
               IF (ABS(AB(II,JJJ)).GT.PMIN) THEN
                  PMIN = ABS(AB(II,JJJ))
                  IND = II
               ENDIF
            ENDDO
            AB(IND,JJJ) = 0.0D+00
            IF (PMIN.LT.CRIT) GO TO 8050
C
C  STORE THE ALPHA AND BETA INDICES.
C
      ICI=0
      DO 100 IGA=1,ITGA
         DO 80 ISA=NAST(IGA)+1,NAST(IGA+1)
            JASYM=LSYMA(ISA)
            KSYM=KTAB(JASYM)
            DO 62 IGB=1,ITGB
               IF (LGCOM(IGB,IGA).NE.1) GO TO 62
               DO 40 ISB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                  ICI=ICI+1
                  IF (ICI.NE.IND) GO TO 40
                  NEND=LSBC(ISB)+NBST(IGB)
                  GO TO 200
   40          CONTINUE
   62       CONTINUE
   80    CONTINUE
  100 CONTINUE
C
  200 CONTINUE
C
      ISB = NEND
C
C  MAKE THE ALPHA AND BETA PARTS.
C
      IDEA = ISA - NAST(IGA)
      CALL RESETCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX3)
      DO II=1,IGA-1
         CALL PUSHCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX3,ISE)
      ENDDO
      CALL RESETDE(LBOX1,NSPACE,NA,MSTA,IACON1)
      DO II=1,IDEA-1
         CALL MOVEUP2(LBOX1,NSPACE,NA,MSTA,IACON1)
      ENDDO
C
      IDEB = ISB - NBST(IGB)
      CALL RESETCO(LBOX1,NSPACE,NB,IBMA,IBMI,LBOX3)
      DO II=1,IGB-1
         CALL PUSHCO(LBOX1,NSPACE,NB,IBMA,IBMI,LBOX3,ISE)
      ENDDO
      CALL RESETDE(LBOX1,NSPACE,NB,MSTA,IBCON1)
      DO II=1,IDEB-1
         CALL MOVEUP2(LBOX1,NSPACE,NB,MSTA,IBCON1)
      ENDDO
C
C
C  FIND DOUBLY OCCUPIED ORBITALS, PUT IN BEGINNING OF ISD.
C
      NSS = 0
      NSD = 0
      DO II=1,NA
         IA = IACON1(II)
         DO JJ=1,NB
            IF (IA.EQ.IBCON1(JJ)) THEN
               NSD = NSD + 1
               ISD(NSD) = IA
            ENDIF
         ENDDO
      ENDDO
C
C  NSD IS HOW MANY DOUBLY OCCUPIED ORBITALS THERE ARE.
C  ISD CONTAINS A LIST OF THE DOUBLY OCCUPPIED ORBITALS
C
C      FIND SINGLY OCCUPIED ORBS NOW, PUT IN END OF ISD, BETA FIRST
C      THEN ALPHA.
C
            DO 320 II=1,NB
                  IB = IBCON1(II)
               DO 324 JJ=1,NSD
                  IF (IB.EQ.ISD(JJ)) GO TO 320
  324          CONTINUE
               NSS = NSS + 1
               ISD(NSS+NSD) = IB
  320       CONTINUE
C
             DO 330 II=1,NA
                 IA = IACON1(II)
                 DO 334 JJ=1,NSD
                  IF (IA.EQ.ISD(JJ)) GO TO 330
  334          CONTINUE
                NSS = NSS + 1
                 ISD(NSS+NSD) = IA
  330       CONTINUE
C
C       REORDER THE THINGS.
C
            DO 340 II=1,NSS-1
                 DO 342 JJ=II+1,NSS
               IF (ISD(JJ+NSD).LT.ISD(II+NSD)) THEN
                  KK=ISD(II+NSD)
                  ISD(II+NSD) = ISD(JJ+NSD)
                  ISD(JJ+NSD) = KK
               ENDIF
  342          CONTINUE
  340       CONTINUE
C
C  DETERMINE HOW MANY DETERMINANTS THERE ARE WITH THE
C  SAME SPACE FUNCTION.
C
      NSPA=NA-NSD
      NTOP=1
      NBOT=1
      DO II=NSPA+1,NSS
         NTOP=NTOP*II
      ENDDO
      DO II=1,NSS-NSPA
         NBOT=NBOT*II
      ENDDO
      NODE = NTOP/NBOT
C
      DO II=1,NSPA
         IDO(II) = II
      ENDDO
C
C     NOW TO STORE POSITIONS OF ALL POSSIBLE DETERMINANTS WITH
C     SAME SPACE FUNCTION.  ALPHA FIRST.
C
      DO 3000 IJK=1,NODE
         DO II=1,NSD
            IACON1(II) = ISD(II)
         ENDDO
         DO II=1,NSPA
            IACON1(II+NSD) = ISD(NSD+IDO(II))
         ENDDO
C
C   MUST REORDER HERE.
C
         DO II=1,NA-1
            DO JJ=II+1,NA
               IF (IACON1(JJ).LT.IACON1(II)) THEN
                  KK=IACON1(II)
                  IACON1(II) = IACON1(JJ)
                  IACON1(JJ) = KK
               ENDIF
            ENDDO
         ENDDO
C
C  DETERMINE THE POSITION OF THE ALPHA STRING
C
         CALL GETBOX(LBOX1,IACON1,NA,MSTA,NSPACE)
         CALL POSITCO(LBOX2,NSPACE,NA,IAMA,IAMI,LBOX3,LBOX1,IGA)
         CALL IDPOST(IACON1,NA,LBOX1,NSPACE,MSTA,IDIM,X,NX,LBST,
     *        LANDET(1,IGA),IBCON1,IPOSA)
C
         IWRK1(IJK,1) = IPOSA+NAST(IGA)
C
         CALL ADVANC(IDO,NSPA,NSS)
 3000 CONTINUE
C
C  NOW FOR THE BETA
C
      NSPB=NB-NSD
      DO II=1,NSPB
         IDO(II)=II
      ENDDO
C
      DO 4000 IJK=1,NODE
         DO II=1,NSD
            IBCON1(II) = ISD(II)
         ENDDO
         DO II=1,NSPB
            IBCON1(II+NSD) = ISD(NSD+IDO(II))
         ENDDO
C
C  MUST REORDER HERE
C
         DO II=1,NB-1
            DO JJ=II+1,NB
               IF (IBCON1(JJ).LT.IBCON1(II)) THEN
                  KK=IBCON1(II)
                  IBCON1(II) = IBCON1(JJ)
                  IBCON1(JJ) = KK
               ENDIF
            ENDDO
         ENDDO
C
C  DETERMINE THE POSITION OF THE BETA STRING.
C
         CALL GETBOX(LBOX1,IBCON1,NB,MSTA,NSPACE)
         CALL POSITCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3,LBOX1,IGB)
         CALL IDPOST(IBCON1,NB,LBOX1,NSPACE,MSTA,IDIM,X,NX,LBST,
     *        LBNDET(1,IGB),IACON1,IPOSB)
C
         IWRK1(NODE-IJK+1,2) = IPOSB+NBST(IGB)
C
         CALL ADVANC(IDO,NSPB,NSS)
 4000 CONTINUE
C
C  ZERO ALL DIAGONAL ELEMENTS JUST FOUND.
C
      DO II=1,NODE
         INA=IWRK1(II,1)
         DO 110 IGA=1,ITGA
            IF (NAST(IGA+1).GE.INA) GO TO 120
  110    CONTINUE
  120    CONTINUE
         INB=IWRK1(II,2)
         DO 130 IGB=1,ITGB
            IF (NBST(IGB+1).GE.INB) GO TO 140
  130    CONTINUE
  140    CONTINUE
         ISYMB = LSYMB(INB)
         IND = LSPA(INA)+LDISB(ISYMB,IGB,IGA)+LSPB(INB)
         IWRK2(II) = IND
         AB(IND,JJJ) = 0.0D+00
      ENDDO
C
C  NOW TO REORDER ACCORDING TO POSITION OF DETERMINANTS.
C
      IF (NODE.GT.1) CALL FCCISRT(IWRK1,IWRK1(1,2),IWRK2,NODE)
C
C  NOW TO INCLUDE THESE DETERMINANTS CONTRIBUTION TO THE SPIN.
C
      IGAS=1
      INAS=1
      CALL RESETCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX3)
      CALL RESETDE(LBOX1,NSPACE,NA,MSTA,IACON1)
      IGBS=1
      INBS=1
      CALL RESETCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3)
      CALL RESETDE(LBOX2,NSPACE,NB,MSTA,IBCON1)
C
      DO 6000 IJK=1,NODE
         ZNORM = ZNORM + CI(IWRK2(IJK),JJJ)**2.0D+00
C A
         INAE=IWRK1(IJK,1)
         DO II=IGAS,ITGA
            IF (NAST(II+1).GE.INAE) GO TO 150
         ENDDO
  150    CONTINUE
         IF (II.GT.IGAS) THEN
            DO JJ=IGAS,II-1
               CALL PUSHCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX3,ISE)
            ENDDO
            CALL RESETDE(LBOX1,NSPACE,NA,MSTA,IACON1)
            IGAS=II
            INAS=1
         ENDIF
         INAE = INAE - NAST(IGAS)
         DO KK=INAS,INAE-1
            CALL MOVEUP2(LBOX1,NSPACE,NA,MSTA,IACON1)
         ENDDO
         INAS = INAE
C B
         INBE=IWRK1(IJK,2)
         DO II=1,ITGB
            IF (NBST(II+1).GE.INBE) GO TO 160
         ENDDO
  160    CONTINUE
         IF (II.LT.IGBS) THEN
            CALL RESETCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3)
            DO JJ=1,II-1
               CALL PUSHCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3,ISE)
            ENDDO
            CALL RESETDE(LBOX2,NSPACE,NB,MSTA,IBCON1)
            IGBS=II
            INBS=1
         ELSEIF (II.GT.IGBS) THEN
            DO JJ=IGBS,II-1
               CALL PUSHCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3,ISE)
            ENDDO
            CALL RESETDE(LBOX2,NSPACE,NB,MSTA,IBCON1)
            IGBS=II
            INBS=1
         ENDIF
         INBE = INBE - NBST(IGBS)
         IF (INBS.GT.INBE) THEN
            CALL RESETDE(LBOX2,NSPACE,NB,MSTA,IBCON1)
            INBS=1
         ENDIF
         DO KK=INBS,INBE-1
            CALL MOVEUP2(LBOX2,NSPACE,NB,MSTA,IBCON1)
         ENDDO
         INBS = INBE
C
      IGAS2=1
      INAS2=1
      CALL RESETCO(LBOX4,NSPACE,NA,IAMA,IAMI,LBOX3)
      CALL RESETDE(LBOX4,NSPACE,NA,MSTA,IACON2)
      IGBS2=1
      INBS2=1
      CALL RESETCO(LBOX5,NSPACE,NB,IBMA,IBMI,LBOX3)
      CALL RESETDE(LBOX5,NSPACE,NB,MSTA,IBCON2)
C
C  LOOP OVER LEFT SIDE OF THE OPERATOR,IE DETERMINANTS I=1,NODE
C
      DO 5000 KJI=1,NODE
         IF (KJI.EQ.IJK) GO TO 5000
C A
         INAE2=IWRK1(KJI,1)
         DO II=IGAS2,ITGA
            IF (NAST(II+1).GE.INAE2) GO TO 250
         ENDDO
  250    CONTINUE
         IF (II.GT.IGAS2) THEN
            DO JJ=IGAS2,II-1
               CALL PUSHCO(LBOX4,NSPACE,NA,IAMA,IAMI,LBOX3,ISE)
            ENDDO
            CALL RESETDE(LBOX4,NSPACE,NA,MSTA,IACON2)
            IGAS2=II
            INAS2=1
         ENDIF
         INAE2 = INAE2 - NAST(IGAS2)
         DO KK=INAS2,INAE2-1
            CALL MOVEUP2(LBOX4,NSPACE,NA,MSTA,IACON2)
         ENDDO
         INAS2 = INAE2
C B
         INBE2=IWRK1(KJI,2)
         DO II=1,ITGB
            IF (NBST(II+1).GE.INBE2) GO TO 260
         ENDDO
  260    CONTINUE
         IF (II.LT.IGBS2) THEN
            CALL RESETCO(LBOX5,NSPACE,NB,IBMA,IBMI,LBOX3)
            DO JJ=1,II-1
               CALL PUSHCO(LBOX5,NSPACE,NB,IBMA,IBMI,LBOX3,ISE)
            ENDDO
            CALL RESETDE(LBOX5,NSPACE,NB,MSTA,IBCON2)
            IGBS2=II
            INBS2=1
         ELSEIF (II.GT.IGBS2) THEN
            DO JJ=IGBS2,II-1
               CALL PUSHCO(LBOX5,NSPACE,NB,IBMA,IBMI,LBOX3,ISE)
            ENDDO
            CALL RESETDE(LBOX5,NSPACE,NB,MSTA,IBCON2)
            IGBS2=II
            INBS2=1
         ENDIF
         INBE2 = INBE2 - NBST(IGBS2)
         IF (INBS2.GT.INBE2) THEN
            CALL RESETDE(LBOX5,NSPACE,NB,MSTA,IBCON2)
            INBS2=1
         ENDIF
         DO KK=INBS2,INBE2-1
            CALL MOVEUP2(LBOX5,NSPACE,NB,MSTA,IBCON2)
         ENDDO
         INBS2=INBE2
C
C  NOW HAVE THE TWO DETERMINANTS.  HAVE TO FIND OUT WHETHER
C  THEY DIFFER BY ONLY TWO ORBITALS, ONE IN ALPHA AND ONE IN
C  BETA.  IF DIFFER BY MORE THAN NO CONTRIBUTION TO SPIN.
C
         ID1=0
         DO 167 IX=1,NA
            IA1=IACON1(IX)
            DO 169 IY=1,NA
               IA2=IACON2(IY)
               IF (IA1.EQ.IA2) GO TO 167
  169       CONTINUE
            ID1=ID1+1
            IF (ID1.GT.1) GO TO 5000
            JA1 = IX
  167    CONTINUE
         IF (ID1.NE.1) GO TO 5000
C
         ID1=0
         DO 171 IX=1,NA
            IA1=IACON2(IX)
            DO 172 IY=1,NA
               IA2=IACON1(IY)
               IF (IA1.EQ.IA2) GO TO 171
  172       CONTINUE
            ID1=ID1+1
            IF(ID1.GT.1) GO TO 5000
            JA2 = IX
  171    CONTINUE
         IF (ID1.NE.1) GO TO 5000
C
         ID1=0
         DO 175 IX=1,NB
            IB1=IBCON1(IX)
            DO 177 IY=1,NB
               IB2=IBCON2(IY)
               IF (IB1.EQ.IB2) GO TO 175
  177       CONTINUE
            ID1=ID1+1
            IF (ID1.GT.1) GO TO 5000
            JB1 = IX
  175    CONTINUE
         IF (ID1.NE.1) GO TO 5000
C
         ID1=0
         DO 178 IX=1,NB
            IB1=IBCON2(IX)
            DO 179 IY=1,NB
               IB2=IBCON1(IY)
               IF (IB1.EQ.IB2) GO TO 178
  179       CONTINUE
            ID1=ID1+1
            IF (ID1.GT.1) GO TO 5000
            JB2=IX
  178    CONTINUE
         IF (ID1.NE.1) GO TO 5000
C
         IF (IACON1(JA1).NE.IBCON2(JB2)) GO TO 5000
         IF (IACON2(JA2).NE.IBCON1(JB1)) GO TO 5000
C
         IPT = ABS(JA1-JA2) + ABS(JB1-JB2) + 1
         IPER = (-1)**IPT
C
      SPIN(JJJ)=SPIN(JJJ)+
     *      CI(IWRK2(IJK),JJJ)*CI(IWRK2(KJI),JJJ)*IPER
C
 5000 CONTINUE
C
      SPIN(JJJ)=SPIN(JJJ)-
     *  (CI(IWRK2(IJK),JJJ)*CI(IWRK2(IJK),JJJ))*NSD
C
 6000 CONTINUE
C
      NDONE = NDONE + NODE
      IF (NDONE.GE.NCI) GO TO 8050
 8000 CONTINUE
C
 8050 CONTINUE
      SPIN(JJJ)=SPIN(JJJ)/ZNORM
C
 9000 CONTINUE
C
      DO II=1,NV
         SPIN(II)=SPIN(II)+((NA-NB)/2.0D+00)**2.0D+00 + (NA+NB)/2.0D+00
      ENDDO
      DO II=1,NV
         SRT = SQRT(4.0D+00*ABS(SPIN(II)) + 1.0D+00)
         SPIN(II) = (SRT-1.0D+00)/2.0D+00
      ENDDO
C
      RETURN
      END
C
C*MODULE ORMAS1  *DECK FCCSUP
C     ------------------------------------------------------------------
      SUBROUTINE FCCSUP(IW,NA,NB,NACT,IACON1,IBCON1,IBCON2,
     *           INDEX,NBST,LSPB,
     *           LBOX1,LBOX2,LBOX3,LBOX4,
     *           X,NX,LBNDET,LSYMB,NSYM,ITGB,IBST,
     *           NB1EX,JB1GR,JB1PE,JB1IN,JB1PO,JB1ST,JB1SY)
C     ------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL FDIRCT,QCORR
C
      COMMON /FCCWFN/ NSPACE,MSTA(51),MNUM(51),MINI(51),MAXI(51),
     *                IAMI(51),IAMA(51),IBMI(51),IBMA(51),IDIM(51),
     *                LBST(51),NREF0,FDIRCT,QCORR,C0SQ
C
      DIMENSION IACON1(NA),IBCON1(NB),IBCON2(NB)
      DIMENSION INDEX((NACT*(NACT+1))/2+1)
      DIMENSION LBOX1(NSPACE),LBOX2(NSPACE),LBOX3(NSPACE)
      DIMENSION LBOX4(NSPACE)
      DIMENSION NBST(ITGB+1),LSPB(IBST)
      DIMENSION X(NX)
      DIMENSION LBNDET(NSPACE,ITGB),LSYMB(IBST)
      DIMENSION JB1GR(NB1EX),JB1PE(NB1EX),JB1IN(NB1EX),JB1PO(NB1EX)
      DIMENSION JB1ST(NSYM+1,IBST+1),JB1SY(NB*(NACT-NB))
C
C  MAKE AND STORE ALL B -> B' DATA, WHERE B' > B.
C
      NB1CH = 0
      INB = 0
C
C  LOOP THROUGH ALL BETA GROUPS
C
      CALL RESETCO(LBOX1,NSPACE,NB,IBMA,IBMI,LBOX3)
C
      DO 1000 IIB = 1,ITGB
C
         CALL RESETDE(LBOX1,NSPACE,NB,MSTA,IBCON1)
C
         DO 900 KKB=NBST(IIB)+1,NBST(IIB+1)
            INB = INB + 1
            DO II=1,NSPACE
               LBOX2(II) = LBOX1(II)
            ENDDO
            JB1ST(1,INB) = NB1CH+1
            KBST = NB1CH+1
C
C  LOOP OVER ALL SINGLE EXCITATIONS, CHECKING TO SEE IF IT IS VALID.
C
C  LOOP OVER SPACES TO EXCITE ELECTRON FROM.
C
            IEBS = NB+1
            DO 890 ISPB1=NSPACE,1,-1
               IOC1 = LBOX1(ISPB1)
               IEBE = IEBS - 1
               IEBS = IEBS - IOC1
               IF (IOC1.EQ.0) GO TO 890
               LBOX2(ISPB1) = LBOX2(ISPB1)-1
C
C  LOOP ELECTRONS IN SPACE ISPB1
C  IEBS, IEBE ARE THE ELECTRONS IN SPACE ISPB1
C
               DO 885 IB1 = IEBE,IEBS,-1
                  IO1 = IBCON1(IB1)
                  IGBE = IEBE - LBOX1(ISPB1)
C
C  LOOP OVER POSSIBLE SPACES TO EXCITE INTO.
C
               DO 880 ISPB2=ISPB1,NSPACE
C
C  IGBS,IGBE ARE ELECTRONS SPECIFYING ISPB2 SPACE ELECTRON LIMITS.
C
                  IGBS = IGBE + 1
                  IGBE = IGBE + LBOX1(ISPB2)
C
                  LBOX2(ISPB2) = LBOX2(ISPB2) + 1
                  IF (LBOX2(ISPB1).LT.IBMI(ISPB1)) GO TO 870
                  IF (LBOX2(ISPB2).GT.IBMA(ISPB2)) GO TO 870
C
C  GET GROUP NUMBER
C
          CALL POSITCO(LBOX4,NSPACE,NB,IBMA,IBMI,LBOX3,LBOX2,IGB)
          NIAS = NBST(IGB)
C
C  MAKE GAP INFORMATION HERE.
C
                  IGBA = MAX(IB1+1,IGBS)
                  IF (LBOX1(ISPB2).EQ.0) THEN
                     ISTA = MSTA(ISPB2)
                     IEND = MSTA(ISPB2+1)-1
                  ELSEIF (ISPB2.EQ.ISPB1) THEN
                     ISTA = IO1+1
                     IEND = IBCON1(IGBA)-1
                     IF (IB1.EQ.IEBE) IEND=MSTA(ISPB1+1)-1
                  ELSE
                     ISTA = MSTA(ISPB2)
                     IEND = IBCON1(IGBA)-1
                  ENDIF
C
C  LOOP OVER GAPS
C
                  DO 860 IGAP=IGBA,IGBE+1
C
                     DO 850 JJ=ISTA,IEND
C
                        NB1CH = NB1CH + 1
                        JB1GR(NB1CH) = IGB
                        JB1IN(NB1CH) = INDEX(JJ)+IO1
C
            CALL REDE00(IBCON1,IBCON2,NB,IB1,IGAP-1,JJ,IPER)
            CALL IDPOST(IBCON2,NB,LBOX2,NSPACE,MSTA,IDIM,X,NX,LBST,
     *                  LBNDET(1,IGB),IACON1,IPOSB)
C
                        JB1PE(NB1CH) = (-1)**IPER
                        JB1PO(NB1CH) = LSPB(IPOSB+NIAS)
                        JB1SY(NB1CH-KBST+1) = LSYMB(IPOSB+NIAS)
C
  850                CONTINUE
C
                  ISTA = IBCON1(IGAP)+1
                  IEND = IBCON1(IGAP+1)-1
                  IF (IGAP.EQ.IGBE) IEND=MSTA(ISPB2+1)-1
  860             CONTINUE
C
  870             LBOX2(ISPB2) = LBOX2(ISPB2) - 1
  880          CONTINUE
C
  885          CONTINUE
C
               LBOX2(ISPB1) = LBOX2(ISPB1) + 1
  890       CONTINUE
C
C  ORDER THESE EXCITATIONS FOR BETA INB ACCORDING TO SYMMETRY.
C
            KNUM = NB1CH - KBST + 1
            CALL FCCSRT2(JB1GR(KBST),JB1PE(KBST),JB1IN(KBST),
     *                   JB1PO(KBST),JB1SY,KNUM)
C
C  MAKE THE SYMMETRY STARTING POINTS
C ----
            IST=1
            DO 100 II=1,NSYM
               DO 200 JJ=IST,KNUM
                  IF (JB1SY(JJ).NE.II) GO TO 180
  200          CONTINUE
  180          JB1ST(II+1,INB) = JJ+KBST-1
               IST = JJ
  100       CONTINUE
C ----
C
C  REORDER WITHIN EACH SYMMETRY BY POSITION.
C
            IJST=JB1ST(1,INB)
            DO 300 II=1,NSYM
               JSTA=JB1ST(II,INB)
               JEND=JB1ST(II+1,INB)
               JNUM=JEND-JSTA
               IF (JNUM.LE.1) GO TO 300
               CALL FCCSRT2(JB1GR(JSTA),JB1PE(JSTA),JB1IN(JSTA),
     *                      JB1SY(JSTA-IJST+1),JB1PO(JSTA),JNUM)
  300       CONTINUE
C
            CALL MOVEUP2(LBOX1,NSPACE,NB,MSTA,IBCON1)
  900    CONTINUE
C
         CALL PUSHCO(LBOX1,NSPACE,NB,IBMA,IBMI,LBOX3,IEND)
C
 1000 CONTINUE
C
      IF (NB1CH.NE.NB1EX) THEN
         WRITE(IW,9000)
         CALL ABRT
         STOP
      ENDIF
      JB1ST(1,IBST+1) = NB1CH+1
C
      RETURN
C
 9000 FORMAT(/1X,'ERROR IN CALCULATION OF SINGLE BETA EXCITES !!! ',
     *           'PANIC !!!!!!'/1X,'CALL JOE AND TELL HIM OFF.')
C
      END
C
C*MODULE ORMAS1  *DECK FCCSRT2
C     ------------------------------------------------------
      SUBROUTINE FCCSRT2(JB1GR,JB1PE,JB1IN,JB1PO,JB1SY,N)
C     ------------------------------------------------------
      IMPLICIT INTEGER(A-Z)
      DIMENSION JB1GR(N),JB1PE(N),JB1IN(N),JB1PO(N),JB1SY(N)
C
C    SORTING GARBAGE.
C
      IF (N.LT.2) RETURN
      L=N/2+1
      IR=N
C
   10 CONTINUE
         IF (L.GT.1) THEN
            L=L-1
            IRRA=JB1SY(L)
            IRRB=JB1GR(L)
            IRRC=JB1PE(L)
            IRRD=JB1IN(L)
            IRRE=JB1PO(L)
         ELSE
            IRRA=JB1SY(IR)
            IRRB=JB1GR(IR)
            IRRC=JB1PE(IR)
            IRRD=JB1IN(IR)
            IRRE=JB1PO(IR)
            JB1SY(IR)=JB1SY(1)
            JB1GR(IR)=JB1GR(1)
            JB1PE(IR)=JB1PE(1)
            JB1IN(IR)=JB1IN(1)
            JB1PO(IR)=JB1PO(1)
C
            IR=IR-1
            IF (IR.EQ.1) THEN
               JB1SY(1)=IRRA
               JB1GR(1)=IRRB
               JB1PE(1)=IRRC
               JB1IN(1)=IRRD
               JB1PO(1)=IRRE
C
               GO TO 122
            ENDIF
         ENDIF
         I=L
         J=L+L
   20    IF (J.LE.IR) THEN
            IF (J.LT.IR) THEN
                   IF (JB1SY(J).LT.JB1SY(J+1)) J=J+1
            ENDIF
            IF (IRRA.LT.JB1SY(J)) THEN
               JB1SY(I)=JB1SY(J)
               JB1GR(I)=JB1GR(J)
               JB1PE(I)=JB1PE(J)
               JB1IN(I)=JB1IN(J)
               JB1PO(I)=JB1PO(J)
               I=J
               J=J+J
            ELSE
               J=IR+1
            ENDIF
         GO TO 20
         ENDIF
         JB1SY(I)=IRRA
         JB1GR(I)=IRRB
         JB1PE(I)=IRRC
         JB1IN(I)=IRRD
         JB1PO(I)=IRRE
      GO TO 10
C
  122 CONTINUE
C
      RETURN
      END
C
C*MODULE ORMAS1  *DECK FCCSRT3
C     ------------------------------------------------------
      SUBROUTINE FCCSRT3(JB1GR,JB1PE,JB1IN,JB1SY,N)
C     ------------------------------------------------------
      IMPLICIT INTEGER(A-Z)
      DIMENSION JB1GR(N),JB1PE(N),JB1IN(N),JB1SY(N)
C
C    SORTING GARBAGE.
C
      IF (N.LT.2) RETURN
      L=N/2+1
      IR=N
C
   10 CONTINUE
         IF (L.GT.1) THEN
            L=L-1
            IRRA=JB1SY(L)
            IRRB=JB1GR(L)
            IRRC=JB1PE(L)
            IRRD=JB1IN(L)
         ELSE
            IRRA=JB1SY(IR)
            IRRB=JB1GR(IR)
            IRRC=JB1PE(IR)
            IRRD=JB1IN(IR)
            JB1SY(IR)=JB1SY(1)
            JB1GR(IR)=JB1GR(1)
            JB1PE(IR)=JB1PE(1)
            JB1IN(IR)=JB1IN(1)
C
            IR=IR-1
            IF (IR.EQ.1) THEN
               JB1SY(1)=IRRA
               JB1GR(1)=IRRB
               JB1PE(1)=IRRC
               JB1IN(1)=IRRD
C
               GO TO 122
            ENDIF
         ENDIF
         I=L
         J=L+L
   20    IF (J.LE.IR) THEN
            IF (J.LT.IR) THEN
                   IF (JB1SY(J).LT.JB1SY(J+1)) J=J+1
            ENDIF
            IF (IRRA.LT.JB1SY(J)) THEN
               JB1SY(I)=JB1SY(J)
               JB1GR(I)=JB1GR(J)
               JB1PE(I)=JB1PE(J)
               JB1IN(I)=JB1IN(J)
               I=J
               J=J+J
            ELSE
               J=IR+1
            ENDIF
         GO TO 20
         ENDIF
         JB1SY(I)=IRRA
         JB1GR(I)=IRRB
         JB1PE(I)=IRRC
         JB1IN(I)=IRRD
      GO TO 10
C
  122 CONTINUE
C
      RETURN
      END
C
C*MODULE ORMAS1  *DECK DAFCCI
C     ------------------------------------------------------------------
      SUBROUTINE DAFCCI(IW,SOME,ECONST,ISTAT,
     *           SI1,SI2,M2,M4,NACT,NCI,NA,NB,K,KST,MAXP,MAXW1,
     *           NITER,CRIT,
     *           X,NX,
     *           SPIN,EL,NSYM,IOB,
     *           LBOX1,LBOX2,LBOX3,LBOX4,LBOX5,
     *           CI,AB,Q,B,EF,F,EC,GR,
     *           IPOSA,IPERA,IIND1,IGROA,IWRK1,IWRK2,
     *           ISD,IDO,INDEX,IMMC,IHMCON,
     *           LGMUL,KTAB,IACON1,IACON2,IBCON1,IBCON2,
     *           LANDET,LBNDET,NAST,NBST,LSYMA,LSYMB,LGCOM,
     *           LSPA,LSPB,LDISB,LSAS,LSBS,LSAC,LSBC,
     *           ITGA,ITGB,IAST,IBST,
     *           NB1EX,IBST2,
     *           JB1GR,JB1PE,JB1IN,JB1PO,JB1ST,JB1SY)
C     ------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL SOME,GOPARR,DSKWRK,MASWRK,DSKSAV,FDIRCT,QCORR,ANALYS
C
      COMMON /CIFILS/ NFT11,NFT12,NFT13,NFT14,NFT15,NFT16,IDAF20,NEMEMX
      COMMON /DETPAR/ ICLBBR,ANALYS
      COMMON /FCCWFN/ NSPACE,MSTA(51),MNUM(51),MINI(51),MAXI(51),
     *                IAMI(51),IAMA(51),IBMI(51),IBMA(51),IDIM(51),
     *                LBST(51),NREF0,FDIRCT,QCORR,C0SQ
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      DIMENSION SI1(M2),SI2(M4),X(NX),SPIN(KST),EL(MAXW1)
      DIMENSION IOB(NACT),LBOX1(NSPACE),LBOX2(NSPACE),LBOX3(NSPACE)
      DIMENSION LBOX4(NSPACE),LBOX5(NSPACE)
      DIMENSION CI(NCI,MAXP),AB(NCI,MAXP),Q(NCI),B(8*MAXW1)
      DIMENSION EF(MAXW1,MAXW1),F((MAXW1*(MAXW1+1))/2)
      DIMENSION EC(MAXP,MAXP),GR(MAXP)
      DIMENSION IPOSA(NA*(NACT-NA)*NSYM)
      DIMENSION IPERA(NA*(NACT-NA)*NSYM)
      DIMENSION IIND1(NA*(NACT-NA)*NSYM)
      DIMENSION IGROA(NA*(NACT-NA)*NSYM)
      DIMENSION IWRK1(2*MAXW1),IWRK2(MAXW1),ISD(NA+NB),IDO(NA)
      DIMENSION INDEX((NACT*(NACT+1))/2+1)
      DIMENSION IMMC(NSYM),IHMCON(K)
      DIMENSION LGMUL(NSYM,NSYM),KTAB(NSYM)
      DIMENSION IACON1(NA),IACON2(NA),IBCON1(NA),IBCON2(NA)
      DIMENSION LANDET(NSPACE,ITGA),LBNDET(NSPACE,ITGB)
      DIMENSION NAST(ITGA+1),NBST(ITGB+1)
      DIMENSION LSYMA(IAST),LSYMB(IBST),LGCOM(ITGB,ITGA)
      DIMENSION LSPA(IAST),LSPB(IBST),LDISB(NSYM,ITGB,ITGA)
      DIMENSION LSAS(NSYM+1,ITGA),LSBS(NSYM+1,ITGB)
      DIMENSION LSAC(IAST),LSBC(IBST)
      DIMENSION JB1GR(NB1EX),JB1PE(NB1EX),JB1IN(NB1EX),JB1ST(IBST2)
      DIMENSION JB1PO(NB1EX),JB1SY(NB*(NACT-NB))
C
      IF (.NOT.FDIRCT) THEN
         IDIM1 = NSYM+1
         IDIM2 = IBST+1
      ELSE
         IDIM1 = 1
         IDIM2 = 1
      ENDIF
C
      IF (SOME) CALL TSECND(E0)
      ISTAT=0
C
      DO 7 I=1,(NACT*(NACT+1))/2 + 1
         INDEX(I) = (I*(I-1))/2
    7 CONTINUE
C
      DO 20 II=1,KST
         DO 30 JJ=1,NCI
            CI(JJ,II) = 0.0D+00
            AB(JJ,II) = 0.0D+00
   30    CONTINUE
   20 CONTINUE
C
C   INITITAL SETUP, WORK OUT DIAGONAL ELEMENTS.
C
      CALL GETQFCC(SI1,SI2,NACT,NCI,NA,NB,IACON1,IBCON1,
     *     INDEX,Q,LBOX1,LBOX2,LBOX3,
     *     NAST,NBST,LSYMA,LSYMB,NSYM,LSPA,LSPB,
     *     LGCOM,LSAS,LSBS,KTAB,LSAC,LSBC,LDISB,
     *     ITGA,ITGB,IAST,IBST)
C
C     ----- SEE IF WE HAVE USABLE CI VECTORS ON DISK ALREADY -----
C     1) SKIP IF THE ENTIRE PROBLEM IS BEING FIT INTO INITIAL GUESS
C     2) SKIP IF THE USER CHOSE OPTION TO ALWAYS FORCE INITIAL GUESS
C
      DSKSAV = DSKWRK
      DSKWRK = .FALSE.
      CRITSV = CRIT
      IF(NCI.LE.MAXW1) GO TO 2345
      IF(ICLBBR.EQ.1)  GO TO 2345
C
C   SEE IF WE HAVE INITIAL GUESS VECTORS ON DISK.
C
      NSTATE=0
      NVECS =0
C
      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, WE MUST MAKE AN INITIAL GUESS
C
      IF (NSTATE+NVECS.EQ.0) GO TO 2345
C
C         IF INCONSISTENCY WITH THE DISK FILE, WE MUST TERMINATE
C
      IF (NVECS.NE.NCI) THEN
         IF (SOME) WRITE(IW,9005) NVECS,NCI
         CALL ABRT
      ENDIF
C
C     WE WILL TIGHTEN THE CONVERGENCE CRITERION, SO THAT AT LEAST A
C     LITTLE IMPROVEMENT IS MADE TO WHAT IS FOUND ON THE DISK.  THE
C     CONVERGENCE CRITERION ON ENTRY WILL BE RESTORED AFTER 3 CYCLES.
C
      CRIT = 1.0D-03 * CRIT
C
C        READ PREVIOUS CI EIGENVECTORS AS THE INITIAL GUESS
C
      IF (SOME) WRITE(IW,9007)
      DO 100 ISTATE = 1,NSTATE
         CALL SQREAD(NFT12,CI(1,ISTATE),NVECS)
         IF(NVECS.EQ.0) THEN
            IF (SOME) WRITE(IW,*)
     *         'UNEXPECTED END OF FILE ON UNIT',NFT12
            CALL ABRT
            STOP
         END IF
  100 CONTINUE
C
C        CAN'T INCLUDE EXTRA STATES IF THE VECTORS COME FROM DISK FILE
C
      IF(KST.GT.NSTATE) KST=NSTATE
      DSKWRK = DSKSAV
      GO TO 3333
C
 2345 CONTINUE
      DSKWRK = DSKSAV
      NVECS = 0
C
C  DETERMINE THE INITIAL GUESS VECTORS.
C
      DO II=1,NCI
         CI(II,1) = Q(II)
      ENDDO
C
      IF(SOME) CALL TSECND(E0)
C
      CALL INITFCC(IW,SOME,B,NCI,NA,NB,NACT,IACON1,IBCON1,
     *     IACON2,IBCON2,ISD,IDO,CI,IWRK1,MAXW1,KST,
     *     INDEX,F,EL,EF,SI1,SI2,IWRK2,IMARK,AB,
     *     LGCOM,NAST,NBST,LSYMA,LSYMB,
     *     LSBS,LSBC,LSPA,LSPB,LDISB,
     *     LBOX1,LBOX2,LBOX3,LBOX4,LBOX5,
     *     X,NX,LANDET,LBNDET,
     *     ITGA,ITGB,IAST,IBST,
     *     KTAB,NSYM)
C
      IF(SOME) THEN
         CALL TSECND(E1)
         ELAP = E1 - E0
         E0 = E1
         IF (NVECS.EQ.0) WRITE(IW,9010) ELAP
      END IF
C
C   CHECK IF WE HAVE FINISHED THE CI BY DOING THE FIRST
C   DIAGONALIZATION.
C
      IF (IMARK.EQ.1) THEN
         CALL  FCCSPIN(NA,NB,IACON1,IACON2,IBCON1,IBCON2,
     *      ISD,IDO,CI,AB,K,NCI,SPIN,IWRK1,IWRK2,MAXW1,
     *           LGCOM,NAST,NBST,LSYMA,LSYMB,
     *           LSBS,LSBC,LSPA,LSPB,LDISB,
     *           LBOX1,LBOX2,LBOX3,LBOX4,LBOX5,
     *           X,NX,LANDET,LBNDET,
     *           ITGA,ITGB,IAST,IBST,KTAB,NSYM)
C
         IF (.NOT.FDIRCT) THEN
         CALL FCCSUP(IW,NA,NB,NACT,IACON1,IBCON1,IBCON2,
     *           INDEX,NBST,LSPB,
     *           LBOX1,LBOX2,LBOX3,LBOX4,
     *           X,NX,LBNDET,LSYMB,NSYM,
     *           ITGB,IBST,
     *           NB1EX,JB1GR,JB1PE,JB1IN,JB1PO,JB1ST,JB1SY)
         ENDIF
         RETURN
      ENDIF
C
 3333 CONTINUE
C
C
C   IF NOT FULLY DIRECT, CALL SETUP FOR STORAGE OF B -> B' DATA.
C   THIS IS NEEDED FOR DENSITY MATRIX DETERMINATION IF NOT HERE
C   IN THE CI
C
      IF (.NOT.FDIRCT) THEN
         CALL FCCSUP(IW,NA,NB,NACT,IACON1,IBCON1,IBCON2,
     *           INDEX,NBST,LSPB,
     *           LBOX1,LBOX2,LBOX3,LBOX4,
     *           X,NX,LBNDET,LSYMB,NSYM,
     *           ITGB,IBST,
     *           NB1EX,JB1GR,JB1PE,JB1IN,JB1PO,JB1ST,JB1SY)
C
         IF(SOME) THEN
            CALL TSECND(E1)
            ELAP = E1 - E0
            E0 = E1
            WRITE(IW,9015) ELAP
         ENDIF
      ENDIF
C
      IF (NA.EQ.NB) THEN
         CALL  FCCSPIN(NA,NB,IACON1,IACON2,IBCON1,IBCON2,
     *      ISD,IDO,CI,AB,KST,NCI,SPIN,IWRK1,IWRK2,MAXW1,
     *           LGCOM,NAST,NBST,LSYMA,LSYMB,
     *           LSBS,LSBC,LSPA,LSPB,LDISB,
     *           LBOX1,LBOX2,LBOX3,LBOX4,LBOX5,
     *           X,NX,LANDET,LBNDET,
     *           ITGA,ITGB,IAST,IBST,KTAB,NSYM)
C
         DO I=1,KST
            IWRK1(I)=INT(SPIN(I) + 0.3D+00)
            IWRK2(I)=I
         ENDDO
C
         IF(SOME) THEN
            CALL TSECND(E1)
            ELAP = E1 - E0
            E0 = E1
            WRITE(IW,9013) ELAP
         ENDIF
      ENDIF
C
C  IF MS=0, IMPOSE RESTRICTION ON THE INITIAL CI COEFFICIENTS.
C
      IF (NA.EQ.NB) THEN
      IP = KST
      NTCON = K
      DO 5511 IGA=1,ITGA
         DO 5522 KKA=NAST(IGA)+1,NAST(IGA+1)
            JPZA1 = LSPA(KKA)
            JASYM = LSYMA(KKA)
            KSYM=KTAB(JASYM)
C
            DO 5533 IGB=1,IGA
            IF (LGCOM(IGB,IGA).NE.1) GOTO 5533
            ICC1 = JPZA1 + LDISB(KSYM,IGB,IGA)
            ICC2 = LDISB(JASYM,IGA,IGB) + LSPB(KKA)
            NIBS=NBST(IGB)
            DO 5544 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
               IBPOS = LSBC(KKB) + NIBS
               IF (IBPOS.GT.KKA) GOTO 5522
               ICI1 = ICC1+LSPB(IBPOS)
               IF (IBPOS.EQ.KKA) THEN
                  DO 5532 KJ=1,NTCON
                  IPS = (IWRK1(KJ)/2)
                  IF ((IPS+IPS).NE.IWRK1(KJ)) CI(ICI1,KJ+IP) = 0.0D+00
 5532             CONTINUE
                  GOTO 5522
               ENDIF
               ICI2 = LSPA(IBPOS) + ICC2
               DO 5531 KJ=1,NTCON
               IS = (-1)**IWRK1(KJ)
               CI(ICI2,KJ+IP) = IS*CI(ICI1,KJ+IP)
 5531          CONTINUE
 5544       CONTINUE
 5533       CONTINUE
 5522    CONTINUE
 5511 CONTINUE
      END IF
C
C  THE ROUTINE NAMES HAVE MEANING.  FCHC IS COMMON TO ALL OF THEM.
C  THE 5TH CHARACTER CAN BE A 0 OR X.  0 MEANS MS=0, X MEANS OTHERWISE.
C  THE 6TH CHARACTER CAN BE A 1 OR Y.  1 MEANS A SINGLE HC VECTOR IS
C  DETERMINED, Y MEANS MORE THAN ONE IS DETERMINED.
C  THE 7TH AND FINAL CHARACTER CAN BE A D OR S.  D MEANS FULLY DIRECT
C  AND S MEANS SEMI-DIRECT.  D IS YET TO BE IMPLEMENTED, I WILL
C  SEE IF THERE IS A NEED FOR IT FIRST.
C
      IF (NA.EQ.NB) THEN
      IF (KST.GT.1) THEN
      CALL FCHC0YS(SI1,SI2,INDEX,NACT,NA,NB,CI,AB,KST,Q,NCI,X,NX,
     *           IACON1,IACON2,IBCON1,IBCON2,
     *           LBOX1,LBOX2,LBOX3,LBOX4,LBOX5,
     *           NSYM,IOB,LGMUL,KTAB,
     *           LANDET,LBNDET,NAST,NBST,LSYMA,LGCOM,
     *           LSPA,LSPB,LDISB,LSBS,LSBC,
     *           ITGA,ITGB,IAST,IBST,
     *           IPOSA,IPERA,IIND1,IGROA,IMMC,
     *           NB1EX,JB1GR,JB1PE,JB1IN,JB1PO,JB1ST,
     *           IWRK1,IWRK2)
      ELSE
      CALL FCHC01S(SI1,SI2,INDEX,NACT,NA,NB,CI,AB,Q,NCI,X,NX,
     *           IACON1,IACON2,IBCON1,IBCON2,
     *           LBOX1,LBOX2,LBOX3,LBOX4,LBOX5,
     *           NSYM,IOB,LGMUL,KTAB,
     *           LANDET,LBNDET,NAST,NBST,LSYMA,LGCOM,
     *           LSPA,LSPB,LDISB,LSBS,LSBC,
     *           ITGA,ITGB,IAST,IBST,
     *           IPOSA,IPERA,IIND1,IGROA,IMMC,
     *           NB1EX,JB1GR,JB1PE,JB1IN,JB1PO,JB1ST,IDIM1,IDIM2,
     *           IWRK1,IWRK2)
      ENDIF
      ELSE
      IF (KST.GT.1) THEN
      CALL FCHCXYS(SI1,SI2,INDEX,NACT,NA,NB,CI,AB,KST,Q,NCI,X,NX,
     *           IACON1,IACON2,IBCON1,IBCON2,
     *           LBOX1,LBOX2,LBOX3,LBOX4,LBOX5,
     *           NSYM,IOB,LGMUL,KTAB,
     *           LANDET,LBNDET,NAST,NBST,LSYMA,LSYMB,LGCOM,
     *           LSPA,LSPB,LDISB,LSAS,LSBS,LSAC,LSBC,
     *           ITGA,ITGB,IAST,IBST,
     *           IPOSA,IPERA,IIND1,IGROA,IMMC,
     *           NB1EX,JB1GR,JB1PE,JB1IN,JB1PO,JB1ST)
      ELSE
      CALL FCHCX1S(SI1,SI2,INDEX,NACT,NA,NB,CI,AB,Q,NCI,X,NX,
     *           IACON1,IACON2,IBCON1,IBCON2,
     *           LBOX1,LBOX2,LBOX3,LBOX4,LBOX5,
     *           NSYM,IOB,LGMUL,KTAB,
     *           LANDET,LBNDET,NAST,NBST,LSYMA,LSYMB,LGCOM,
     *           LSPA,LSPB,LDISB,LSAS,LSBS,LSAC,LSBC,
     *           ITGA,ITGB,IAST,IBST,
     *           IPOSA,IPERA,IIND1,IGROA,IMMC,
     *           NB1EX,JB1GR,JB1PE,JB1IN,JB1PO,JB1ST)
      ENDIF
      ENDIF
C
      IF(SOME) THEN
         CALL TSECND(E1)
         ELAP = E1 - E0
         E0 = E1
         WRITE(IW,9020) ELAP
      ENDIF
C
      DO 13 II=1,KST
         EL(II) = 0.0D+00
         DO 15 KK=1,NCI
            EL(II) = EL(II) + CI(KK,II)*AB(KK,II)
   15    CONTINUE
   13 CONTINUE
      DO 555 II=1,MAXP
         DO 677 JJ=1,II-1
            EC(II,JJ) = 0.0D+00
            EF(II,JJ) = 0.0D+00
            EC(JJ,II) = 0.0D+00
            EF(JJ,II) = 0.0D+00
  677    CONTINUE
         EC(II,II) = 1.0D+00
         EF(II,II) = 1.0D+00
  555 CONTINUE
C
C     NOW TO GET INTO THE LOOP, SET SOME LOOP CONSTANTS HERE
C     IP IS THE CURRENT NUMBER OF CI VECTORS BEING DEALT WITH.
C     IL IS THE CURRENT ROOT BEING OPTIMIZED.
C
      IPXT = -1
      IP = KST
      IL = 1
      NTCON = K
      DO 4599 KL = 1,K
      IHMCON(KL) = KL
      IWRK2(KL) = KL
 4599 CONTINUE
C
C     LOOP OVER NUMBER OF ROOTS, ITERATIONS FOR EACH ROOT.
C
      IF(SOME) WRITE(IW,9040)
  333 CONTINUE
C
      DO 1315 ITER=0,NITER
C
      IPXT = IPXT + 1
      IF(IPXT.EQ.3) CRIT = CRITSV
C
C     CHECK TO SEE IF IP = MAXP, IF
C     SO THEN TRANSFORM THE FIRST KST VECTORS IN CI AND AB
C     AND START OVER WITH IP = K
C
      IF (IP+NTCON.GT.MAXP) THEN
         CALL TRAN(CI,NCI,MAXW1,EF,IP,EC,KST)
         CALL TRAN(AB,NCI,MAXW1,EF,IP,EC,KST)
         IP = KST
         DO 1396 II=1,MAXP
            EC(II,II) = 1.0D+00
            EF(II,II) = 1.0D+00
            DO 1398 JJ=1,II-1
               EC(II,JJ) = 0.0D+00
               EF(II,JJ) = 0.0D+00
               EC(JJ,II) = 0.0D+00
               EF(JJ,II) = 0.0D+00
 1398       CONTINUE
 1396    CONTINUE
      ENDIF
C
C   MAKE GRADIENT VECTORS, PUT IN CI(IP+1) -> CI(IP+NTCON)
C
      DO 4588 KK=1,NTCON
      IL = IHMCON(KK)
      GR(KK) = 0.0D+00
      DO 80 II=1,NCI
         CI(II,IP+KK) = 0.0D+00
         DO 70 JJ=1,IP
      CI(II,IP+KK) = CI(II,IP+KK) +
     *     EF(JJ,IL)*(AB(II,JJ)-EL(IL)*CI(II,JJ))
   70    CONTINUE
         GR(KK) = GR(KK) + (CI(II,IP+KK)*CI(II,IP+KK))
   80 CONTINUE
      GR(KK) = SQRT(GR(KK))
      IF(SOME) THEN
         WRITE(IW,9050) ITER,EL(IL)+ECONST,GR(KK)
         CALL FLSHBF(IW)
      END IF
 4588 CONTINUE
C
      IF (SOME.AND.NTCON.GT.1) WRITE(IW,*)
      IF (ITER.EQ.NITER) THEN
         CALL TRAN(CI,NCI,MAXW1,EF,IP,EC,KST)
         GOTO 9890
      ENDIF
C
C     CHECK FOR CONVERGENCE OF ANY STATE, IF CONVERGED, TRANSFORM
C     ALL IP VECTORS IN CI AND AB, MODIFY IHMCON AND NTCON.
C     START WITH  IP = KST AGAIN.
C
      NUMC = 0
      DO 4255 II=1,NTCON
         IWRK2(II) = IHMCON(II)
 4255 CONTINUE
      DO 4522 KK=1,NTCON
      IL = IHMCON(KK)
      IF (GR(KK).LE.CRIT) THEN
         IF(SOME) WRITE(IW,9060) IL,EL(IL)+ECONST,IPXT
         DO 3233 II=KK-NUMC,NTCON-NUMC
         IWRK2(II) = IWRK2(II+1)
 3233    CONTINUE
         NUMC = NUMC + 1
      ENDIF
 4522 CONTINUE
C
      IF (NUMC.GT.0) THEN
         CALL TRAN(CI,NCI,MAXW1,EF,IP,EC,KST)
         CALL TRAN(AB,NCI,MAXW1,EF,IP,EC,KST)
         NTCON = NTCON - NUMC
         DO II=1,NTCON
            IHMCON(II) = IWRK2(II)
         ENDDO
         DO 74 II=1,MAXP
            DO 75 JJ=1,MAXP
               EF(II,JJ) = 0.0D+00
               EC(II,JJ) = 0.0D+00
   75       CONTINUE
            EF(II,II) = 1.0D+00
            EC(II,II) = 1.0D+00
   74    CONTINUE
         IP = KST
         IF (NTCON.NE.0) GOTO 333
         IF(SOME) WRITE(IW,*) 'ALL STATES CONVERGED.'
C
         CALL  FCCSPIN(NA,NB,IACON1,IACON2,IBCON1,IBCON2,
     *      ISD,IDO,CI,AB,K,NCI,SPIN,IWRK1,IWRK2,MAXW1,
     *           LGCOM,NAST,NBST,LSYMA,LSYMB,
     *           LSBS,LSBC,LSPA,LSPB,LDISB,
     *           LBOX1,LBOX2,LBOX3,LBOX4,LBOX5,
     *           X,NX,LANDET,LBNDET,
     *           ITGA,ITGB,IAST,IBST,KTAB,NSYM)
C
         RETURN
      ENDIF
C
      DO 68 JJ=IP+1,IP+NTCON
         IL = IHMCON(JJ-IP)
         DO 63 II=1,NCI
            CI(II,JJ) = CI(II,JJ)/(EL(IL) - Q(II))
   63    CONTINUE
   68 CONTINUE
C
C  IF MS=0, IMPOSE RESTRICTION ON THE CI COEFFICIENTS.
C
      IF (NA.EQ.NB) THEN
      DO 1111 IGA=1,ITGA
         DO 1122 KKA=NAST(IGA)+1,NAST(IGA+1)
            JPZA1 = LSPA(KKA)
            JASYM = LSYMA(KKA)
            KSYM=KTAB(JASYM)
C
            DO 1133 IGB=1,IGA
            IF (LGCOM(IGB,IGA).NE.1) GOTO 1133
            ICC1 = JPZA1 + LDISB(KSYM,IGB,IGA)
            ICC2 = LDISB(JASYM,IGA,IGB) + LSPB(KKA)
            NIBS=NBST(IGB)
            DO 1144 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
               IBPOS = LSBC(KKB) + NIBS
               IF (IBPOS.GT.KKA) GOTO 1122
               ICI1 = ICC1+LSPB(IBPOS)
               IF (IBPOS.EQ.KKA) THEN
                  DO 3232 KJ=1,NTCON
                  NV=IHMCON(KJ)
                  IPS = (IWRK1(NV)/2)
                  IF ((IPS+IPS).NE.IWRK1(NV)) CI(ICI1,KJ+IP) = 0.0D+00
 3232             CONTINUE
                  GOTO 1122
               ENDIF
               ICI2 = LSPA(IBPOS) + ICC2
               DO 3331 KJ=1,NTCON
               NV = IHMCON(KJ)
               IS = (-1)**IWRK1(NV)
               CI(ICI2,KJ+IP) = IS*CI(ICI1,KJ+IP)
 3331          CONTINUE
 1144       CONTINUE
 1133       CONTINUE
 1122    CONTINUE
 1111 CONTINUE
      ENDIF
C
C   MAKE THE NEW VECTORS (IP+1 -> IP+NTCON).
C
C    ASSUME THE NEW VECTORS ARE BI, HAVE TO ORTHOGONALIZE
C    THESE VECTORS TO ALL OTHERS AND THEN RENORMALIZE.
C
      DO 97 KK=IP+1,IP+NTCON
         SPIN(KK) = SPIN(IHMCON(KK-IP))
         DO 86 II=1,KK-1
            ROV = 0.0D+00
            DO 81 JJ=1,NCI
               ROV = ROV + CI(JJ,KK)*CI(JJ,II)
   81       CONTINUE
            DO 90 JJ=1,NCI
              CI(JJ,KK) = CI(JJ,KK) - ROV*CI(JJ,II)
   90       CONTINUE
   86    CONTINUE
C
         RNOR = 0.0D+00
         DO 40 II=1,NCI
            RNOR = RNOR + CI(II,KK)*CI(II,KK)
   40    CONTINUE
         RNOR = SQRT(RNOR)
         DO 42 II=1,NCI
            CI(II,KK) = CI(II,KK)/RNOR
   42    CONTINUE
   97 CONTINUE
C
      IP = IP + 1
C
C     NOW TO RETURN THE NEW PART OF AB
C
      IF (NA.EQ.NB) THEN
      IF (KST.GT.1) THEN
      CALL FCHC0YS(SI1,SI2,INDEX,NACT,NA,NB,CI(1,IP),AB(1,IP),
     *           NTCON,Q,NCI,X,NX,
     *           IACON1,IACON2,IBCON1,IBCON2,
     *           LBOX1,LBOX2,LBOX3,LBOX4,LBOX5,
     *           NSYM,IOB,LGMUL,KTAB,
     *           LANDET,LBNDET,NAST,NBST,LSYMA,LGCOM,
     *           LSPA,LSPB,LDISB,LSBS,LSBC,
     *           ITGA,ITGB,IAST,IBST,
     *           IPOSA,IPERA,IIND1,IGROA,IMMC,
     *           NB1EX,JB1GR,JB1PE,JB1IN,JB1PO,JB1ST,
     *           IWRK1,IWRK2)
      ELSE
      CALL FCHC01S(SI1,SI2,INDEX,NACT,NA,NB,CI(1,IP),AB(1,IP),
     *           Q,NCI,X,NX,
     *           IACON1,IACON2,IBCON1,IBCON2,
     *           LBOX1,LBOX2,LBOX3,LBOX4,LBOX5,
     *           NSYM,IOB,LGMUL,KTAB,
     *           LANDET,LBNDET,NAST,NBST,LSYMA,LGCOM,
     *           LSPA,LSPB,LDISB,LSBS,LSBC,
     *           ITGA,ITGB,IAST,IBST,
     *           IPOSA,IPERA,IIND1,IGROA,IMMC,
     *           NB1EX,JB1GR,JB1PE,JB1IN,JB1PO,JB1ST,IDIM1,IDIM2,
     *           IWRK1,IWRK2)
      ENDIF
C
      ELSE
C
      IF (KST.GT.1) THEN
      CALL FCHCXYS(SI1,SI2,INDEX,NACT,NA,NB,CI(1,IP),AB(1,IP),
     *           NTCON,Q,NCI,X,NX,
     *           IACON1,IACON2,IBCON1,IBCON2,
     *           LBOX1,LBOX2,LBOX3,LBOX4,LBOX5,
     *           NSYM,IOB,LGMUL,KTAB,
     *           LANDET,LBNDET,NAST,NBST,LSYMA,LSYMB,LGCOM,
     *           LSPA,LSPB,LDISB,LSAS,LSBS,LSAC,LSBC,
     *           ITGA,ITGB,IAST,IBST,
     *           IPOSA,IPERA,IIND1,IGROA,IMMC,
     *           NB1EX,JB1GR,JB1PE,JB1IN,JB1PO,JB1ST)
      ELSE
      CALL FCHCX1S(SI1,SI2,INDEX,NACT,NA,NB,CI(1,IP),AB(1,IP),
     *           Q,NCI,X,NX,
     *           IACON1,IACON2,IBCON1,IBCON2,
     *           LBOX1,LBOX2,LBOX3,LBOX4,LBOX5,
     *           NSYM,IOB,LGMUL,KTAB,
     *           LANDET,LBNDET,NAST,NBST,LSYMA,LSYMB,LGCOM,
     *           LSPA,LSPB,LDISB,LSAS,LSBS,LSAC,LSBC,
     *           ITGA,ITGB,IAST,IBST,
     *           IPOSA,IPERA,IIND1,IGROA,IMMC,
     *           NB1EX,JB1GR,JB1PE,JB1IN,JB1PO,JB1ST)
      ENDIF
      ENDIF
C
      IP = IP + NTCON - 1
C
C  MAKE THE NEW MATRIX ELEMENTS BETWEEN THE CI VECTORS.
C
      IX = 0
      DO 103 II=1,IP
          DO 102 JJ=1,II
          IX = IX + 1
            F(IX) = 0.0D+00
            DO 115 KK=1,NCI
               F(IX) = F(IX) + CI(KK,II)*AB(KK,JJ)
  115       CONTINUE
  102    CONTINUE
  103 CONTINUE
C
C  DIAGONALIZE SMALL MATRIX
C
      CALL EVVRSP(-1,IP,IP,(IP*(IP+1))/2,MAXW1
     *              ,F,B,IWRK2,EL,EF,0,IERR)
      IF (IERR.NE.0) THEN
         WRITE(IW,*) 'ERROR IN SMALL DIAGONALIZATION'
         WRITE(IW,*) IERR
         RETURN
      ENDIF
C
C   CHECK TO SEE IF ANY STATES HAVE SKIPPED IN
C
      DO 700 IJK=1,KST
         DO 705 II=1,NTCON
            IF (IJK.EQ.IHMCON(II)) GOTO 700
  705    CONTINUE
         IDXC = 0
         POV = 0.0D+00
         DO 713 JJ=1,KST
            UIT = 0.0D+00
            DO 715 KK=1,IP
               UIT = UIT + EF(KK,JJ)*EC(KK,IJK)
  715       CONTINUE
            POV = ABS(UIT)
            IDXC = JJ
  713    CONTINUE
         DO 720 II=1,NTCON
            IF (JJ.EQ.IHMCON(II)) THEN
               IHMCON(II) = IJK
               GOTO 700
            ENDIF
  720    CONTINUE
  700 CONTINUE
C
C  CHECK TO SEE WHERE THE SPINS OCCUR NOW
C
      IF (NA.EQ.NB) THEN
C
      DO 800 II=1,IP
         POV = 0.0D+00
         DO 813 JJ=1,IP
            UIT = 0.0D+00
            DO 823 KK=1,IP
               UIT = UIT + EF(KK,II)*EC(KK,JJ)
  823       CONTINUE
            IF (ABS(UIT).GT.POV) THEN
               POV = ABS(UIT)
               IDXC = JJ
            ENDIF
  813    CONTINUE
         IF (IDXC.NE.II) THEN
            GR(II) = SPIN(IDXC)
         ELSE
            GR(II) = SPIN(II)
         ENDIF
800   CONTINUE
C
      DO 786 KK=1,IP
         SPIN(KK) = GR(KK)
  786 CONTINUE
C
      ENDIF
C
C  CHECK TO SEE WHERE THE CONVERGED STATES ARE NOW.
C
      NCON = 0
      DO 805 II=1,K
         DO 850 JJ=1,NTCON
            IF (II.EQ.IHMCON(JJ)) GOTO 805
  850    CONTINUE
         DO 852 JJ=1,IP
            UIT = 0.0D+00
            DO 853 KK=1,IP
               UIT = UIT + EF(KK,JJ)*EC(KK,II)
  853       CONTINUE
            IF (ABS(UIT).GT.0.6D+00) THEN
               NCON = NCON + 1
               IWRK1(NCON) = JJ
               GOTO 805
            ENDIF
  852    CONTINUE
C
  805 CONTINUE
C
      NTCON1 = 0
      DO 860 II=1,K
         DO 864 JJ=1,NCON
            IF (II.EQ.IWRK1(JJ)) GOTO 860
  864    CONTINUE
         NTCON1 = NTCON1 + 1
         IHMCON(NTCON1) = II
  860 CONTINUE
C
      IF (NTCON1.NE.NTCON) THEN
         WRITE(6,*)
         WRITE(6,*) 'CONVERGED STATES HAVE SKIPPED OUT'
         WRITE(6,*) 'NUMBER OF UNCONVERGED STATES NOW = ',NTCON1
         NTCON = NTCON1
      ENDIF
C
C   END OF CHECK
C
      DO 543 II=1,KST
         IWRK1(II) = INT(SPIN(II) + 0.3D+00)
  543 CONTINUE
C
      DO 55 II=1,IP
         DO 66  JJ=1,IP
            EC(II,JJ) = EF(II,JJ)
   66    CONTINUE
   55 CONTINUE
C
 1315 CONTINUE
C
 9890 CONTINUE
C
      IF (MASWRK) WRITE(IW,9080) IL-1
C
      CALL  FCCSPIN(NA,NB,IACON1,IACON2,IBCON1,IBCON2,
     *   ISD,IDO,CI,AB,KST,NCI,SPIN,IWRK1,IWRK2,MAXW1,
     *        LGCOM,NAST,NBST,LSYMA,LSYMB,
     *        LSBS,LSBC,LSPA,LSPB,LDISB,
     *        LBOX1,LBOX2,LBOX3,LBOX4,LBOX5,
     *        X,NX,LANDET,LBNDET,
     *        ITGA,ITGB,IAST,IBST,KTAB,NSYM)
      ISTAT=1
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 ORMAS VECTORS READ FROM DISK')
 9010 FORMAT(/1X,'INITIAL ORMAS VECTOR GUESS TIME :',F13.1)
 9013 FORMAT(1X,'ORMAS SPIN CALCULATION TIME     :',F13.1)
 9015 FORMAT(1X,'SETTING UP CALCULATION TIME     :',F13.1)
 9020 FORMAT(1X,'INITIAL ORMAS CI ITERATION TIME :',F13.1)
 9040 FORMAT(/1X,'ITERATION',6X,'ENERGY',11X,'GRADIENT')
 9050 FORMAT(1X,I5,F20.10,F15.8)
 9060 FORMAT(/1X,'CONVERGED STATE',I5,' ENERGY=',F20.10,' IN',
     *           I5,' ITERS'/)
 9080 FORMAT(1X,'DETERMINANT ORMAS CI CONVERGED ONLY',I4,' ROOTS.')
      END
C
C*MODULE ORMAS1  *DECK FCHCX1S
C     ------------------------------------------------------------------
      SUBROUTINE FCHCX1S(SI1,SI2,INDEX,NACT,NA,NB,CI,AB,Q,NCI,X,NX,
     *           IACON1,IACON2,IBCON1,IBCON2,
     *           LBOX1,LBOX2,LBOX3,LBOX4,LBOX5,
     *           NSYM,IOB,LGMUL,KTAB,
     *           LANDET,LBNDET,NAST,NBST,LSYMA,LSYMB,LGCOM,
     *           LSPA,LSPB,LDISB,LSAS,LSBS,LSAC,LSBC,
     *           ITGA,ITGB,IAST,IBST,
     *           IPOSA,IPERA,IIND1,IGROA,IMMC,
     *           NB1EX,JB1GR,JB1PE,JB1IN,JB1PO,JB1ST)
C     ------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL FDIRCT,QCORR
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      COMMON /FCCWFN/ NSPACE,MSTA(51),MNUM(51),MINI(51),MAXI(51),
     *                IAMI(51),IAMA(51),IBMI(51),IBMA(51),IDIM(51),
     *                LBST(51),NREF0,FDIRCT,QCORR,C0SQ
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      DIMENSION SI1(*),SI2(*)
      DIMENSION INDEX((NACT*(NACT+1))/2+1)
      DIMENSION CI(NCI),AB(NCI),Q(NCI),X(NX)
      DIMENSION IACON1(NA),IACON2(NA),IBCON1(NA),IBCON2(NA)
      DIMENSION LBOX1(NSPACE),LBOX2(NSPACE),LBOX3(NSPACE)
      DIMENSION LBOX4(NSPACE),LBOX5(NSPACE)
      DIMENSION IOB(NACT),LGMUL(NSYM,NSYM),KTAB(NSYM)
      DIMENSION LANDET(NSPACE,ITGA),LBNDET(NSPACE,ITGB)
      DIMENSION NAST(ITGA+1),NBST(ITGB+1)
      DIMENSION LSYMA(IAST),LSYMB(IBST),LGCOM(ITGB,ITGA)
      DIMENSION LSPA(IAST),LSPB(IBST),LDISB(NSYM,ITGB,ITGA)
      DIMENSION LSAS(NSYM+1,ITGA),LSBS(NSYM+1,ITGB)
      DIMENSION LSAC(IAST),LSBC(IBST)
      DIMENSION IPOSA(NA*(NACT-NA),NSYM)
      DIMENSION IPERA(NA*(NACT-NA),NSYM)
      DIMENSION IIND1(NA*(NACT-NA),NSYM)
      DIMENSION IGROA(NA*(NACT-NA),NSYM)
      DIMENSION IMMC(NSYM)
      DIMENSION JB1GR(NB1EX),JB1PE(NB1EX),JB1IN(NB1EX),JB1PO(NB1EX)
      DIMENSION JB1ST(NSYM+1,IBST+1)
C
      DO II=1,NCI
          AB(II) = 0.0D+00
      ENDDO
C
C  --- BIG LOOP OVER ALL ALPHA STRINGS. ---
C
      IF (GOPARR) THEN
         CALL DDI_DLBRESET()
         CALL DDI_DLBNEXT(MY_TASK)
      ENDIF
C
      CALL RESETCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX5)
C
      DO 5000 IGA=1,ITGA
C
         CALL RESETDE(LBOX1,NSPACE,NA,MSTA,IACON1)
C
C  KKA GIVES THE ACTUAL POSITION OF THE ALPHA STRING IACON1 IN
C  THE FULL ALPHA STRING LIST.
C
         DO 4900 KKA=NAST(IGA)+1,NAST(IGA+1)
            IF (GOPARR.AND.KKA-1.NE.MY_TASK) GOTO 4899
            JPZA1 = LSPA(KKA)
            JASYM = LSYMA(KKA)
            KSYM=KTAB(JASYM)
            DO II=1,NSYM
               IMMC(II)=0
            ENDDO
C
            DO II=1,NSPACE
               LBOX2(II) = LBOX1(II)
            ENDDO
C
C  LOOP OVER SPACES TO EXCITE ELECTRON FROM.
C
            IEAS = NA+1
            DO 4890 ISPA1=NSPACE,1,-1
               IOC1 = LBOX1(ISPA1)
               IEAE = IEAS - 1
               IEAS = IEAS - IOC1
               IF (IOC1.EQ.0) GOTO 4890
               LBOX2(ISPA1) = LBOX2(ISPA1)-1
C
C  LOOP ELECTRONS IN SPACE ISPA1.
C  IEAS, IEAE ARE THE ELECTRONS IN SPACE ISPA1.
C
               DO 4885 IA1=IEAE,IEAS,-1
                  IO1 = IACON1(IA1)
                  IGAE = IEAE - LBOX1(ISPA1)
                  IS1 = IOB(IO1)
C
C  LOOP OVER POSSIBLE SPACES TO EXCITE INTO.
C
               DO 4880 ISPA2=ISPA1,NSPACE
C
C  IGAS, IGAE ARE ELECTRONS SPECIFYING ISPA2 SPACE ELECTRON LIMITS.
C
                  IGAS = IGAE + 1
                  IGAE = IGAE + LBOX1(ISPA2)
C
                  LBOX2(ISPA2) = LBOX2(ISPA2) + 1
                  IF (LBOX2(ISPA1).LT.IAMI(ISPA1)) GOTO 4870
C
C  MAKE GAP INFORMATION HERE.
C
                  IGAA = MAX(IA1+1,IGAS)
                  IF (LBOX1(ISPA2).EQ.0) THEN
                     ISTA = MSTA(ISPA2)
                     IEND = MSTA(ISPA2+1)-1
                  ELSEIF (ISPA2.EQ.ISPA1) THEN
                     ISTA = IO1+1
                     IEND = IACON1(IGAA)-1
                     IF (IA1.EQ.IEAE) IEND=MSTA(ISPA1+1)-1
                  ELSE
                     ISTA = MSTA(ISPA2)
                     IEND = IACON1(IGAA)-1
                  ENDIF
C
C  LOOP OVER GAPS
C
                  DO 4860 IGAP=IGAA,IGAE+1
C
                     DO 4850 JJ=ISTA,IEND
                        IS2 = IOB(JJ)
                        IP1 = LGMUL(IS1,IS2)
C
                     IND = INDEX(JJ) + IO1
C
              CALL REDE00(IACON1,IACON2,NA,IA1,IGAP-1,JJ,JPERA)
              IF (LBOX2(ISPA2).GT.IAMA(ISPA2)) GOTO 4800
C
C  GET GROUP NUMBER
C
           CALL POSITCO(LBOX5,NSPACE,NA,IAMA,IAMI,LBOX4,LBOX2,IGA2)
           NIAS = NAST(IGA2)
C
              CALL IDPOST(IACON2,NA,LBOX2,NSPACE,MSTA,IDIM,X,NX,LBST,
     *                  LANDET(1,IGA2),IBCON1,JPOSA)
              KAPOS = JPOSA + NIAS
              JPZA2 = LSPA(KAPOS)
              KASYM = LSYMA(KAPOS)
              KPER1 = (-1)**JPERA
              IMMC(KASYM) = IMMC(KASYM) + 1
              JSPO = IMMC(KASYM)
              IPOSA(JSPO,KASYM) = JPZA2
              IPERA(JSPO,KASYM) = KPER1
              IIND1(JSPO,KASYM) = IND
              IGROA(JSPO,KASYM) = IGA2
C
C   IF DEOCCUPIED AND NEWLY OCCUPIED ORBITALS ARE OF DIFFERENT SYMMETRY,
C   SKIP TO DOUBLES.
C
              IF (IS1.NE.IS2) GOTO 4800
C
C   DETERMINE THE ALPHA STRING CONTRIBUTION TO THE MATRIX ELEMENT.
C
              C = SI1(IND)
C
              DO 4712 IK=1,NA
                 IF (IK.EQ.IA1) GOTO 4712
                 ION = IACON1(IK)
                 J1 = INDEX(ION+1)
                 JMA = MAX(J1,IND)
                 JMI = MIN(J1,IND)
                 JJ1 = INDEX(JMA) + JMI
                 JMA = MAX(ION,JJ)
                 JMI = MIN(ION,JJ)
                 J1 = INDEX(JMA)+JMI
                 JMA = MAX(IO1,ION)
                 JMI = MIN(IO1,ION)
                 J2 = INDEX(JMA)+JMI
                 JMA = MAX(J1,J2)
                 JMI = MIN(J1,J2)
                 INX = INDEX(JMA)+JMI
                 C = C + SI2(JJ1) - SI2(INX)
 4712         CONTINUE
C
C  LOOP OVER BETA DETS OF THE RIGHT GROUP AND SYMMETRY.
C
              CALL RESETCO(LBOX3,NSPACE,NB,IBMA,IBMI,LBOX4)
C
              DO 4700 IGB=1,ITGB
              IF (LGCOM(IGB,IGA).NE.1.OR.LGCOM(IGB,IGA2).NE.1) GOTO 4690
              JCI1 = JPZA1 + LDISB(KSYM,IGB,IGA)
              JCI2 = JPZA2 + LDISB(KSYM,IGB,IGA2)
C
              CALL RESETDE(LBOX3,NSPACE,NB,MSTA,IBCON1)
              ISTB = 1
              DO 4680 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                 IENB = LSBC(KKB)
                 DO IIZ=ISTB,IENB-1
                    CALL MOVEUP2(LBOX3,NSPACE,NB,MSTA,IBCON1)
                 ENDDO
                 ISTB = IENB
                 JCI1 = JCI1 + 1
                 JCI2 = JCI2 + 1
C
C MATRIX ELEMENT ADDITION
C
                 D = C
                 DO 4670 IK=1,NB
                    ION = IBCON1(IK)
                    J1 = INDEX(ION+1)
                    JMA = MAX(J1,IND)
                    JMI = MIN(J1,IND)
                    JJ1 = INDEX(JMA) + JMI
                    D = D + SI2(JJ1)
 4670            CONTINUE
C
                 T = D*KPER1
                 AB(JCI1) = AB(JCI1) + T*CI(JCI2)
                 AB(JCI2) = AB(JCI2) + T*CI(JCI1)
 4680         CONTINUE
C
 4690         CALL PUSHCO(LBOX3,NSPACE,NB,IBMA,IBMI,LBOX4,IEND)
 4700         CONTINUE
C
C --  DOUBLE ALPHA EXCITATIONS START HERE  ---
C
 4800         CONTINUE
C
            IF (IA1.EQ.NA) GOTO 4850
            IF (JJ.EQ.NACT) GOTO 4850
C
            DO II=1,NSPACE
               LBOX3(II) = LBOX2(II)
            ENDDO
            IAES3 = 1
            DO KK=1,ISPA1-1
               IAES3 = IAES3 + LBOX2(KK)
            ENDDO
C
C  LOOP OVER SPACES TO EXCITE ELECTRONS FROM, MUST BE GE THAN
C  SPACE OF FIRST EXCITATION, ISPA1.
C
            DO 3890 ISPA3 = ISPA1,NSPACE
               IF (LBOX1(ISPA3).EQ.0) GOTO 3887
               IF (ISPA3.EQ.ISPA1.AND.IA1.EQ.IEAE) GOTO 3887
               IOC3 = LBOX2(ISPA3)
               IF (IOC3.EQ.0) GOTO 3887
C
               IAEE3 = IAES3 + LBOX2(ISPA3)-1
               LBOX3(ISPA3) = LBOX3(ISPA3)-1
C
C  LOOP OVER ELECTRONS IN ISPA3, WHICH ARE LARGER THAN IA1,
C  MAKING SURE IT ISN'T THE ALREADY EXCITED ELECTRON.
C
               JSTA3 = IAES3
               IF (ISPA3.EQ.ISPA1) THEN
                  JSTA3=IA1
                  IF (IGAP-1.EQ.IA1) JSTA3=JSTA3+1
               ENDIF
C
               DO 3880 IA3=JSTA3,IAEE3
                  IF (IA3.EQ.IGAP-1) GOTO 3880
                  IO3 = IACON2(IA3)
                  IS3 = IOB(IO3)
C
C  LOOP OVER SPACES TO EXCITE ELECTRON INTO.  MUST BE GE THAN
C  SPACE FIRST ELECTRON WAS EXCITED INTO.
C
                  IGAE3 = 0
                  DO JIK=1,ISPA2-1
                     IGAE3 = IGAE3 + LBOX2(JIK)
                  ENDDO
                  DO 3850 ISPA4=ISPA2,NSPACE
C
C  IGAS3, IGAE3 ARE ELECTRONS SPECIFYING ISPA4 SPACE ELECTRON LIMITS.
C
                  LBOX3(ISPA4) = LBOX3(ISPA4) + 1
                  IGAS3 = IGAE3 + 1
                  IGAE3 = IGAE3 + LBOX2(ISPA4)
                  IF (LBOX3(ISPA3).LT.IAMI(ISPA3)) GOTO 3840
                  IF (LBOX3(ISPA4).GT.IAMA(ISPA4)) GOTO 3840
                  IF (LBOX3(ISPA2).LT.IAMI(ISPA2)) GOTO 3840
                  IF (LBOX3(ISPA2).GT.IAMA(ISPA2)) GOTO 3840
             IF (ISPA4.EQ.ISPA2.AND.JJ.EQ.MSTA(ISPA2+1)-1) GOTO 3840
C
C  GET GROUP NUMBER
C
               CALL POSITCO(LBOX5,NSPACE,NA,IAMA,IAMI,LBOX4,LBOX3,IGA3)
               NIAS3 = NAST(IGA3)
C
C  MAKE GAP INFORMATION HERE.
C
                  IGAA3 = MAX(IGAS3,IGAP)
C
                  IF (LBOX2(ISPA4).EQ.0) THEN
                     ISTA3 = MSTA(ISPA4)
                     IEND3 = MSTA(ISPA4+1)-1
                  ELSEIF (ISPA4.EQ.ISPA2) THEN
                     ISTA3 = JJ+1
                     IEND3 = IACON2(IGAA3)-1
C
C  I AM SUSPECT ABOUT THIS NEXT LINE, WE'LL SEE WHAT HAPPENS.......
C
                     IF (IGAP-1.EQ.IGAE3) IEND3=MSTA(ISPA2+1)-1
C
                  ELSE
                     ISTA3 = MSTA(ISPA4)
                     IEND3 = IACON2(IGAA3)-1
                  ENDIF
C
C  LOOP OVER GAPS
C
                  DO 3830 IGAP3=IGAA3,IGAE3+1
C
                     DO 3820 JJ3=ISTA3,IEND3
                        IS4 = IOB(JJ3)
                        IP2 = LGMUL(IS3,IS4)
                        IF (IP1.NE.IP2) GOTO 3820
C
              CALL REDE00(IACON2,IBCON1,NA,IA3,IGAP3-1,JJ3,JPERA3)
              CALL IDPOST(IBCON1,NA,LBOX3,NSPACE,MSTA,IDIM,X,NX,LBST,
     *                  LANDET(1,IGA3),IBCON2,JPOSA3)
              IPER3 = (-1)**(JPERA3+JPERA)
              KAPOS3 = JPOSA3 + NIAS3
              JPZA3 = LSPA(KAPOS3)
                 JMA=MAX(JJ3,IO3)
                 JMI=MIN(JJ3,IO3)
                 I2 = INDEX(JMA) + JMI
                 INX = INDEX(I2) + IND
                 II1 = INDEX(JJ3) + IO1
                 JMA=MAX(IO3,JJ)
                 JMI=MIN(IO3,JJ)
                 II2 = INDEX(JMA) + JMI
                 JMA=MAX(II1,II2)
                 JMI=MIN(II1,II2)
                 INX2 = INDEX(JMA) + JMI
                 C = SI2(INX) - SI2(INX2)
                 T = C*IPER3
C
C  LOOP OVER BETA STRINGS OF RIGHT SYMMETRY AND GROUP.
C
              DO 3700 IGB=1,ITGB
              IF (LGCOM(IGB,IGA).NE.1.OR.LGCOM(IGB,IGA3).NE.1) GOTO 3700
              JCI1 = JPZA1 + LDISB(KSYM,IGB,IGA)
              JCI3 = JPZA3 + LDISB(KSYM,IGB,IGA3)
C
              DO 3680 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                 JCI1 = JCI1 + 1
                 JCI3 = JCI3 + 1
                 AB(JCI1) = AB(JCI1) + T*CI(JCI3)
                 AB(JCI3) = AB(JCI3) + T*CI(JCI1)
 3680         CONTINUE
C
 3700         CONTINUE
C
 3820                CONTINUE
C
                     ISTA3 = IACON2(IGAP3)+1
                     IEND3 = IACON2(IGAP3+1)-1
                     IF (IGAP3.EQ.IGAE3) IEND3=MSTA(ISPA4+1)-1
 3830             CONTINUE
C
 3840             LBOX3(ISPA4) = LBOX3(ISPA4) - 1
 3850             CONTINUE
C
 3880          CONTINUE
C
               LBOX3(ISPA3) = LBOX3(ISPA3)+1
 3887          IAES3 = IAES3 + LBOX3(ISPA3)
 3890       CONTINUE
C
 4850                CONTINUE
C
                  ISTA = IACON1(IGAP)+1
                  IEND = IACON1(IGAP+1)-1
                  IF (IGAP.EQ.IGAE) IEND=MSTA(ISPA2+1)-1
 4860             CONTINUE
C
 4870             LBOX2(ISPA2) = LBOX2(ISPA2) - 1
 4880          CONTINUE
C
 4885          CONTINUE
C
               LBOX2(ISPA1) = LBOX2(ISPA1)+1
 4890       CONTINUE
C
C
C  --- END OF LOOP OVER SINGLE ALPHA EXCITATIONS. ---
C      NOW TO SORT THEM BY POSITIONS WITHIN SYMMETRIES.
C
            DO II=1,NSYM
               CALL FCCSRT3(IGROA(1,II),IPERA(1,II),IIND1(1,II),
     *                   IPOSA(1,II),IMMC(II))
            ENDDO
C
C  --- END OF LOOP OVER PURE ALPHA EXCITATIONS.
C  NOW TO LOOP OVER ALL SIMULTANEOUS AB -> A'B' EXCITATIONS.
C
      IF (NSPACE.EQ.1) GOTO 3400
C
C  ***** GENERAL CASE OF MORE THAN ONE SPACE !!!!! *******
C
C
      IF (.NOT.FDIRCT) THEN
C
C  LOOP OVER SINGLE ALPHA EXCITES WITHIN EACH SYMMETRY.
C
      DO 3000 ISAE=1,NSYM
         KBSYM=KTAB(ISAE)
         DO 2900 JSAE=1,IMMC(ISAE)
            JPOSAE=IPOSA(JSAE,ISAE)
            JPERAE=IPERA(JSAE,ISAE)
            JINDAE=IIND1(JSAE,ISAE)
            JGROAE=IGROA(JSAE,ISAE)
C
C
C  IF ISAE.EQ.JASYM THEN SPECIAL CASE.
C
       IF (ISAE.EQ.JASYM.AND.IGA.EQ.JGROAE) THEN
C
C  LOOP OVER ALL RELEVANT BETAS
C
            LABPOS = JPZA1
            LABPOS2 = JPOSAE
            DO 2813 IGB=1,ITGB
               IF (LGCOM(IGB,IGA).NE.1) GOTO 2813
               NIBS = NBST(IGB)
               DO 2763 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                  LABPOS = LABPOS + 1
                  LABPOS2 = LABPOS2 + 1
                  IBPOS = NIBS + LSBC(KKB)
C
C  LOOP OVER SINGLE BETA EXCITES FROM IBPOS
C
               DO 2613 JBINDX=JB1ST(KBSYM,IBPOS),JB1ST(KBSYM+1,IBPOS)-1
                  IGB2=JB1GR(JBINDX)
                  IF (LGCOM(IGB2,JGROAE).NE.1) GOTO 2613
C
                  JMA=MAX(JINDAE,JB1IN(JBINDX))
                  JMI=MIN(JINDAE,JB1IN(JBINDX))
                  IX=INDEX(JMA)+JMI
                  C = SI2(IX)*JPERAE*JB1PE(JBINDX)
                  JCIB=JPOSAE+LDISB(KBSYM,IGB2,JGROAE)+JB1PO(JBINDX)
                  JCIB2=JPZA1+LDISB(KBSYM,IGB2,JGROAE)+JB1PO(JBINDX)
C
                  AB(LABPOS) = AB(LABPOS) + C*CI(JCIB)
                  AB(JCIB) = AB(JCIB) + C*CI(LABPOS)
                  AB(LABPOS2) = AB(LABPOS2) + C*CI(JCIB2)
                  AB(JCIB2) = AB(JCIB2) + C*CI(LABPOS2)
C
 2613          CONTINUE
C
 2763          CONTINUE
 2813       CONTINUE
C
       ELSE
C
C  LOOP OVER ALL RELEVANT (A-)BETA DETS.
C
            LABPOS = JPZA1
            DO 2800 IGB=1,ITGB
               IF (LGCOM(IGB,IGA).NE.1) GOTO 2800
               NIBS = NBST(IGB)
               DO 2750 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                  LABPOS = LABPOS + 1
                  IBPOS = NIBS + LSBC(KKB)
C
C  LOOP OVER SINGLE BETA EXCITES FROM IBPOS
C
               DO 2600 JBINDX=JB1ST(KBSYM,IBPOS),JB1ST(KBSYM+1,IBPOS)-1
                  IGB2=JB1GR(JBINDX)
                  IF (LGCOM(IGB2,JGROAE).NE.1) GOTO 2600
C
                  JMA=MAX(JINDAE,JB1IN(JBINDX))
                  JMI=MIN(JINDAE,JB1IN(JBINDX))
                  IX=INDEX(JMA)+JMI
                  C = SI2(IX)*JPERAE*JB1PE(JBINDX)
                  JCIB=JPOSAE+LDISB(KBSYM,IGB2,JGROAE)+JB1PO(JBINDX)
C
                  AB(LABPOS) = AB(LABPOS) + C*CI(JCIB)
                  AB(JCIB) = AB(JCIB) + C*CI(LABPOS)
C
 2600          CONTINUE
C
 2750          CONTINUE
 2800       CONTINUE
C
C
C  LOOP OVER ALL RELEVANT (A'-)BETA DETS.
C
            LABPOS = JPOSAE
            DO 2803 IGB=1,ITGB
               IF (LGCOM(IGB,JGROAE).NE.1) GOTO 2803
               NIBS = NBST(IGB)
               DO 2753 KKB=LSBS(KBSYM,IGB),LSBS(KBSYM+1,IGB)-1
                  LABPOS = LABPOS + 1
                  IBPOS = NIBS + LSBC(KKB)
C
C  LOOP OVER SINGLE BETA EXCITES FROM IBPOS
C
               DO 2603 JBINDX=JB1ST(KSYM,IBPOS),JB1ST(KSYM+1,IBPOS)-1
                  IGB2=JB1GR(JBINDX)
                  IF (LGCOM(IGB2,IGA).NE.1) GOTO 2603
C
                  JMA=MAX(JINDAE,JB1IN(JBINDX))
                  JMI=MIN(JINDAE,JB1IN(JBINDX))
                  IX=INDEX(JMA)+JMI
                  C = SI2(IX)*JPERAE*JB1PE(JBINDX)
                  JCIB=JPZA1+LDISB(KSYM,IGB2,IGA)+JB1PO(JBINDX)
C
                  AB(LABPOS) = AB(LABPOS) + C*CI(JCIB)
                  AB(JCIB) = AB(JCIB) + C*CI(LABPOS)
C
 2603          CONTINUE
C
 2753          CONTINUE
 2803       CONTINUE
C
      ENDIF
C
 2900    CONTINUE
 3000 CONTINUE
C
      ELSE
C
C  ***** DIRECT METHOD BELOW *****
C
      DO 4000 ISAE=1,NSYM
         KBSYM = KTAB(ISAE)
C
C  ANALYSE EXCITED A' GROUPS FOR COMPATIBILITY WITH B.
C
      NGRPS = 0
      DO 1976 II=1,IMMC(ISAE)
         ICGR = IGROA(II,ISAE)
         DO JJ=1,NGRPS
            IF (JB1GR(JJ).EQ.ICGR) GOTO 1976
         ENDDO
         NGRPS = NGRPS + 1
         JB1GR(NGRPS) = ICGR
 1976 CONTINUE
C
C FIRST TYPE OF BETAS, KSYM -> KBSYM
C
          CALL RESETCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3)
          DO 7400 IGB=1,ITGB
             IF (LGCOM(IGB,IGA).NE.1) GOTO 7399
             LAB1 = JPZA1 + LDISB(KSYM,IGB,IGA)
C
             CALL RESETDE(LBOX2,NSPACE,NB,MSTA,IBCON1)
             NIBS = NBST(IGB)
             ISTB = 1
             DO 7300 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                IENB = LSBC(KKB)
                DO IIZ=ISTB,IENB-1
                   CALL MOVEUP2(LBOX2,NSPACE,NB,MSTA,IBCON1)
                ENDDO
                ISTB = IENB
C
                IBPOS = NIBS + LSBC(KKB)
                LABPOS = LAB1 + LSPB(IBPOS)
C
C LOOP OVER SINGLE BETA EXCITES FROM IBPOS WHICH ARE OF SYMMETRY KBSYM
C
                MESYM1 = LGMUL(KSYM,KBSYM)
                DO II=1,NSPACE
                   LBOX3(II) = LBOX2(II)
                ENDDO
                IEBS = NB + 1
                DO 7290 ISPB1=NSPACE,1,-1
                   IOC1 = LBOX2(ISPB1)
                   IEBE = IEBS - 1
                   IEBS = IEBS - IOC1
                   IF (IOC1.EQ.0) GO TO 7290
                   LBOX3(ISPB1) = LBOX3(ISPB1)-1
C
C  LOOP ELECTRONS IN SPACE ISPB1
C  IEBS, IEBE ARE THE ELECTRONS IN SPACE ISPB1
C
                DO 7285 IB1 = IEBE,IEBS,-1
                   IO1 = IBCON1(IB1)
                   MESYM2 = LGMUL(MESYM1,IOB(IO1))
                   IGBE = IEBE - LBOX2(ISPB1)
C
C  LOOP OVER POSSIBLE SPACES TO EXCITE INTO.
C
                DO 7280 ISPB2=ISPB1,NSPACE
C
C  IGBS,IGBE ARE ELECTRONS SPECIFYING ISPB2 SPACE ELECTRON LIMITS.
C
                   IGBS = IGBE + 1
                   IGBE = IGBE + LBOX2(ISPB2)
C
                   LBOX3(ISPB2) = LBOX3(ISPB2) + 1
                   IF (LBOX3(ISPB1).LT.IBMI(ISPB1)) GO TO 7270
                   IF (LBOX3(ISPB2).GT.IBMA(ISPB2)) GO TO 7270
C
C  GET GROUP NUMBER
C
          CALL POSITCO(LBOX5,NSPACE,NB,IBMA,IBMI,LBOX4,LBOX3,IGB2)
          NIAS = NBST(IGB2)
C
C CHECK FOR A' GROUP COMPATIBILITY
C
             DO II=1,NGRPS
                IAGRP = JB1GR(II)
                IF (LGCOM(IGB2,IAGRP).EQ.1) GOTO 7555
             ENDDO
             GOTO 7270
 7555        CONTINUE
C
C  MAKE GAP INFORMATION HERE.
C
                  IGBA = MAX(IB1+1,IGBS)
                  IF (LBOX2(ISPB2).EQ.0) THEN
                     ISTA = MSTA(ISPB2)
                     IEND = MSTA(ISPB2+1)-1
                  ELSEIF (ISPB2.EQ.ISPB1) THEN
                     ISTA = IO1+1
                     IEND = IBCON1(IGBA)-1
                     IF (IB1.EQ.IEBE) IEND=MSTA(ISPB1+1)-1
                  ELSE
                     ISTA = MSTA(ISPB2)
                     IEND = IBCON1(IGBA)-1
                  ENDIF
C
C  LOOP OVER GAPS
C
                  DO 7260 IGAP=IGBA,IGBE+1
C
                     DO 7250 JJ=ISTA,IEND
C
C CHECK TO SEE IF EXCITED BETA IS OF RIGHT SYMMETRY (KBSYM)
C
            IF (IOB(JJ).NE.MESYM2) GOTO 7250
C
            IND1 = INDEX(JJ) + IO1
            CALL REDE00(IBCON1,IBCON2,NB,IB1,IGAP-1,JJ,IPER)
            CALL IDPOST(IBCON2,NB,LBOX3,NSPACE,MSTA,IDIM,X,NX,LBST,
     *                  LBNDET(1,IGB2),IACON2,IPOSB)
            QJPER = ((-1)**IPER)
            JB1P = LSPB(IPOSB + NIAS)
C
            DO 3900 JSAE=1,IMMC(ISAE)
               JGROAE=IGROA(JSAE,ISAE)
               IF (LGCOM(IGB2,JGROAE).NE.1) GOTO 3900
C
               JPOSAE=IPOSA(JSAE,ISAE)
               JCIB = JB1P + JPOSAE + LDISB(KBSYM,IGB2,JGROAE)
C
               JINDAE=IIND1(JSAE,ISAE)
               JMA=MAX(JINDAE,IND1)
               JMI=MIN(JINDAE,IND1)
               IX=INDEX(JMA)+JMI
C
               JPERAE=IPERA(JSAE,ISAE)
               C = SI2(IX)*QJPER*JPERAE
C
            AB(LABPOS) = AB(LABPOS) + C*CI(JCIB)
            AB(JCIB) = AB(JCIB) + C*CI(LABPOS)
C
 3900       CONTINUE
C
 7250                CONTINUE
C
                  ISTA = IBCON1(IGAP)+1
                  IEND = IBCON1(IGAP+1)-1
                  IF (IGAP.EQ.IGBE) IEND=MSTA(ISPB2+1)-1
 7260             CONTINUE
C
 7270              LBOX3(ISPB2) = LBOX3(ISPB2) - 1
 7280           CONTINUE
C
 7285           CONTINUE
C
                   LBOX3(ISPB1) = LBOX3(ISPB1) + 1
 7290           CONTINUE
C
 7300        CONTINUE
C
 7399        CALL PUSHCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3,IEND)
 7400     CONTINUE
C
C
C SECOND TYPE OF BETAS, KBSYM -> KSYM
C
          CALL RESETCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3)
          DO 7801 IGB=1,ITGB
C
C CHECK FOR A' GROUP COMPATIBILITY
C
             DO II=1,NGRPS
                IAGRP = JB1GR(II)
                IF (LGCOM(IGB,IAGRP).EQ.1) GOTO 7655
             ENDDO
             GOTO 7799
 7655        CONTINUE
C
             CALL RESETDE(LBOX2,NSPACE,NB,MSTA,IBCON1)
             NIBS = NBST(IGB)
             ISTB = 1
C
             DO 7701 KKB=LSBS(KBSYM,IGB),LSBS(KBSYM+1,IGB)-1
                IENB = LSBC(KKB)
                DO IIZ=ISTB,IENB-1
                   CALL MOVEUP2(LBOX2,NSPACE,NB,MSTA,IBCON1)
                ENDDO
                ISTB = IENB
C
                IBPOS = NIBS + LSBC(KKB)
                LAB1 = LSPB(IBPOS)
C
C LOOP OVER SINGLE BETA EXCITES FROM IBPOS WHICH ARE OF SYMMETRY KSYM
C
                MESYM1 = LGMUL(KSYM,KBSYM)
                DO II=1,NSPACE
                   LBOX3(II) = LBOX2(II)
                ENDDO
                IEBS = NB + 1
                DO 7691 ISPB1=NSPACE,1,-1
                   IOC1 = LBOX2(ISPB1)
                   IEBE = IEBS - 1
                   IEBS = IEBS - IOC1
                   IF (IOC1.EQ.0) GO TO 7691
                   LBOX3(ISPB1) = LBOX3(ISPB1)-1
C
C  LOOP ELECTRONS IN SPACE ISPB1
C  IEBS, IEBE ARE THE ELECTRONS IN SPACE ISPB1
C
                DO 7685 IB1 = IEBE,IEBS,-1
                   IO1 = IBCON1(IB1)
                   MESYM2 = LGMUL(MESYM1,IOB(IO1))
                   IGBE = IEBE - LBOX2(ISPB1)
C
C  LOOP OVER POSSIBLE SPACES TO EXCITE INTO.
C
                DO 7681 ISPB2=ISPB1,NSPACE
C
C  IGBS,IGBE ARE ELECTRONS SPECIFYING ISPB2 SPACE ELECTRON LIMITS.
C
                   IGBS = IGBE + 1
                   IGBE = IGBE + LBOX2(ISPB2)
C
                   LBOX3(ISPB2) = LBOX3(ISPB2) + 1
                   IF (LBOX3(ISPB1).LT.IBMI(ISPB1)) GO TO 7671
                   IF (LBOX3(ISPB2).GT.IBMA(ISPB2)) GO TO 7671
C
          CALL POSITCO(LBOX5,NSPACE,NB,IBMA,IBMI,LBOX4,LBOX3,IGB2)
          IF (LGCOM(IGB2,IGA).NE.1) GOTO 7671
          JCIBS = JPZA1 + LDISB(KSYM,IGB2,IGA)
          NIAS = NBST(IGB2)
C
C  MAKE GAP INFORMATION HERE.
C
                  IGBA = MAX(IB1+1,IGBS)
                  IF (LBOX2(ISPB2).EQ.0) THEN
                     ISTA = MSTA(ISPB2)
                     IEND = MSTA(ISPB2+1)-1
                  ELSEIF (ISPB2.EQ.ISPB1) THEN
                     ISTA = IO1+1
                     IEND = IBCON1(IGBA)-1
                     IF (IB1.EQ.IEBE) IEND=MSTA(ISPB1+1)-1
                  ELSE
                     ISTA = MSTA(ISPB2)
                     IEND = IBCON1(IGBA)-1
                  ENDIF
C
C  LOOP OVER GAPS
C
                  DO 7660 IGAP=IGBA,IGBE+1
C
                     DO 7650 JJ=ISTA,IEND
C
C CHECK TO SEE IF EXCITED BETA IS OF RIGHT SYMMETRY (KBSYM)
C
            IF (IOB(JJ).NE.MESYM2) GOTO 7650
C
            IND1 = INDEX(JJ) + IO1
            CALL REDE00(IBCON1,IBCON2,NB,IB1,IGAP-1,JJ,IPER)
            CALL IDPOST(IBCON2,NB,LBOX3,NSPACE,MSTA,IDIM,X,NX,LBST,
     *                  LBNDET(1,IGB2),IACON2,IPOSB)
            QJPER = ((-1)**IPER)
            JCIB= JCIBS + LSPB(IPOSB + NIAS)
C
            DO 4300 JSAE=1,IMMC(ISAE)
               JGROAE=IGROA(JSAE,ISAE)
               IF (LGCOM(IGB,JGROAE).NE.1) GOTO 4300
C
               JPOSAE=IPOSA(JSAE,ISAE)
               LABPOS = LAB1 + JPOSAE + LDISB(KBSYM,IGB,JGROAE)
C
               JINDAE=IIND1(JSAE,ISAE)
               JMA=MAX(JINDAE,IND1)
               JMI=MIN(JINDAE,IND1)
               IX=INDEX(JMA)+JMI
C
               JPERAE=IPERA(JSAE,ISAE)
               C = SI2(IX)*QJPER*JPERAE
C
            AB(LABPOS) = AB(LABPOS) + C*CI(JCIB)
            AB(JCIB) = AB(JCIB) + C*CI(LABPOS)
C
 4300       CONTINUE
C
 7650                CONTINUE
C
                  ISTA = IBCON1(IGAP)+1
                  IEND = IBCON1(IGAP+1)-1
                  IF (IGAP.EQ.IGBE) IEND=MSTA(ISPB2+1)-1
 7660             CONTINUE
C
 7671              LBOX3(ISPB2) = LBOX3(ISPB2) - 1
 7681           CONTINUE
C
 7685           CONTINUE
C
                   LBOX3(ISPB1) = LBOX3(ISPB1) + 1
 7691           CONTINUE
C
 7701        CONTINUE
C
 7799        CALL PUSHCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3,IEND)
 7801     CONTINUE
C
 4000 CONTINUE
C
      ENDIF
C
C  ***** END OF DIRECT OPTION ******
C
C  **** END OF GENERAL CASE OF MORE THAN ONE SPACE ******
C
      GOTO 4898
C
 3400 CONTINUE
C
C ***** SPECIAL CASE OF ONE SPACE !!!!! ******
C
C  LOOP OVER SINGLE ALPHA EXCITES WITHIN EACH SYMMETRY.
C
       DO 2901 ISAE=1,NSYM
          KBSYM=KTAB(ISAE)
          DO 2801 JSAE=1,IMMC(ISAE)
                JPOSAE=IPOSA(JSAE,ISAE)
                JPERAE=IPERA(JSAE,ISAE)
                JINDAE=IIND1(JSAE,ISAE)
                JGROAE=IGROA(JSAE,ISAE)
C
C  IF ISAE.EQ.JASYM THEN SPECIAL CASE.
C
       IF (ISAE.EQ.JASYM) THEN
C
C  LOOP OVER ALL RELEVANT BETAS
C
             LABPOS=JPZA1
             LABPOS2=JPOSAE
                DO 2721 KKB=LSBS(KSYM,1),LSBS(KSYM+1,1)-1
                    LABPOS = LABPOS + 1
                    LABPOS2 = LABPOS2 + 1
                    IBPOS =  LSBC(KKB)
C
C  LOOP OVER SINGLE BETA EXCITES FROM IBPOS
C
               DO 2621 JBINDX=JB1ST(KSYM,IBPOS),JB1ST(KSYM+1,IBPOS)-1
                  JMA=MAX(JINDAE,JB1IN(JBINDX))
                  JMI=MIN(JINDAE,JB1IN(JBINDX))
                  IX=INDEX(JMA)+JMI
                  C = SI2(IX)*JPERAE*JB1PE(JBINDX)
                  JCIB = JPOSAE+JB1PO(JBINDX)
                  JCIB2 = JPZA1+JB1PO(JBINDX)
C
                  AB(LABPOS) = AB(LABPOS) + C*CI(JCIB)
                  AB(JCIB) = AB(JCIB) + C*CI(LABPOS)
                  AB(LABPOS2) = AB(LABPOS2) + C*CI(JCIB2)
                  AB(JCIB2) = AB(JCIB2) + C*CI(LABPOS2)
C
 2621          CONTINUE
C
 2721          CONTINUE
C
      ELSE
C
C  LOOP OVER ALL RELEVANT (A-)BETA DETS.
C
                LABPOS = JPZA1
                DO 2751 KKB=LSBS(KSYM,1),LSBS(KSYM+1,1)-1
                    LABPOS = LABPOS + 1
                    IBPOS =  LSBC(KKB)
C
C  LOOP OVER SINGLE BETA EXCITES FROM IBPOS
C
               DO 2601 JBINDX=JB1ST(KBSYM,IBPOS),JB1ST(KBSYM+1,IBPOS)-1
C
                  JMA=MAX(JINDAE,JB1IN(JBINDX))
                  JMI=MIN(JINDAE,JB1IN(JBINDX))
                  IX=INDEX(JMA)+JMI
                  C = SI2(IX)*JPERAE*JB1PE(JBINDX)
                  JCIB=JPOSAE+JB1PO(JBINDX)
C
                  AB(LABPOS) = AB(LABPOS) + C*CI(JCIB)
                  AB(JCIB) = AB(JCIB) + C*CI(LABPOS)
C
 2601          CONTINUE
C
 2751          CONTINUE
C
C  LOOP OVER ALL RELEVANT (A'-)BETA DETS.
C
               LABPOS = JPOSAE
               DO 2761 KKB=LSBS(KBSYM,1),LSBS(KBSYM+1,1)-1
                  LABPOS = LABPOS + 1
                  IBPOS = LSBC(KKB)
C
C  LOOP OVER SINGLE BETA EXCITES FROM IBPOS
C
               DO 2611 JBINDX=JB1ST(KSYM,IBPOS),JB1ST(KSYM+1,IBPOS)-1
C
                  JMA=MAX(JINDAE,JB1IN(JBINDX))
                  JMI=MIN(JINDAE,JB1IN(JBINDX))
                  IX=INDEX(JMA)+JMI
                  C = SI2(IX)*JPERAE*JB1PE(JBINDX)
                  JCIB=JPZA1+JB1PO(JBINDX)
C
                  AB(LABPOS) = AB(LABPOS) + C*CI(JCIB)
                  AB(JCIB) = AB(JCIB) + C*CI(LABPOS)
C
 2611          CONTINUE
C
 2761          CONTINUE
C
      ENDIF
C
 2801       CONTINUE
 2901   CONTINUE
C
C  **** END OF SPECIAL CASE OF ONE SPACE *******
C
 4898       CONTINUE
            IF (GOPARR) CALL DDI_DLBNEXT(MY_TASK)
 4899       CONTINUE
            CALL MOVEUP2(LBOX1,NSPACE,NA,MSTA,IACON1)
 4900    CONTINUE
C
         CALL PUSHCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX5,IEND)
 5000 CONTINUE
C
C  --- END OF LOOP OVER ALPHA STRINGS. ---
C
C     RESET COUNTERS AND SUM UP AB
C
      IF (GOPARR) THEN
         CALL DDI_DLBRESET()
         CALL DDI_GSUMF(2900,AB,NCI)
      ENDIF
C
C **
C  --- LOOP OVER ALL PURE BETA EXCITATIONS.
C
      CALL RESETCO(LBOX1,NSPACE,NB,IBMA,IBMI,LBOX5)
C
      DO 8000 IGB=1,ITGB
C
         CALL RESETDE(LBOX1,NSPACE,NB,MSTA,IBCON1)
C
C  KKB GIVES THE ACTUAL POSITION OF THE BETA STRING IBCON1 IN
C  THE FULL BETA STRING LIST.
C
         DO 7900 KKB=NBST(IGB)+1,NBST(IGB+1)
            JPZB1 = LSPB(KKB)
            KBSYM = LSYMB(KKB)
            KSYM=KTAB(KBSYM)
C
            DO II=1,NSPACE
               LBOX2(II) = LBOX1(II)
            ENDDO
C
C  LOOP OVER SPACES TO EXCITE ELECTRON FROM.
C
            IEBS = NB+1
            DO 7890 ISPB1=NSPACE,1,-1
               IOC1 = LBOX1(ISPB1)
               IEBE = IEBS - 1
               IEBS = IEBS - IOC1
               IF (IOC1.EQ.0) GOTO 7890
               LBOX2(ISPB1) = LBOX2(ISPB1)-1
C
C  LOOP ELECTRONS IN SPACE ISPB1.
C  IEBS, IEBE ARE THE ELECTRONS IN SPACE ISPB1.
C
               DO 7885 IB1=IEBE,IEBS,-1
                  IO1 = IBCON1(IB1)
                  IGBE = IEBE - LBOX1(ISPB1)
                  IS1 = IOB(IO1)
C
C  LOOP OVER POSSIBLE SPACES TO EXCITE INTO.
C
               DO 7880 ISPB2=ISPB1,NSPACE
C
C  IGBS, IGBE ARE ELECTRONS SPECIFYING ISPB2 SPACE ELECTRON LIMITS.
C
                  IGBS = IGBE + 1
                  IGBE = IGBE + LBOX1(ISPB2)
C
                  LBOX2(ISPB2) = LBOX2(ISPB2) + 1
                  IF (LBOX2(ISPB1).LT.IBMI(ISPB1)) GOTO 7870
C
C  MAKE GAP INFORMATION HERE.
C
                  IGBB = MAX(IB1+1,IGBS)
                  IF (LBOX1(ISPB2).EQ.0) THEN
                     ISTA = MSTA(ISPB2)
                     IEND = MSTA(ISPB2+1)-1
                  ELSEIF (ISPB2.EQ.ISPB1) THEN
                     ISTA = IO1+1
                     IEND = IBCON1(IGBB)-1
                     IF (IB1.EQ.IEBE) IEND=MSTA(ISPB1+1)-1
                  ELSE
                     ISTA = MSTA(ISPB2)
                     IEND = IBCON1(IGBB)-1
                  ENDIF
C
C  LOOP OVER GAPS
C
                  DO 7860 IGAP=IGBB,IGBE+1
C
                     DO 7850 JJ=ISTA,IEND
                        IS2 = IOB(JJ)
                        IP1 = LGMUL(IS1,IS2)
                        IND = INDEX(JJ) + IO1
C
              CALL REDE00(IBCON1,IBCON2,NB,IB1,IGAP-1,JJ,JPERB)
                  IF (LBOX2(ISPB2).GT.IBMA(ISPB2)) GOTO 7800
C
C   IF DEOCCUPIED AND NEWLY OCCUPIED ORBITALS ARE OF DIFFERENT SYMMETRY,
C   SKIP TO DOUBLES.
C
              IF (IS1.NE.IS2) GOTO 7800
C
C  GET GROUP NUMBER
C
           CALL POSITCO(LBOX5,NSPACE,NB,IBMA,IBMI,LBOX4,LBOX2,IGB2)
           NIBS = NBST(IGB2)
C
              CALL IDPOST(IBCON2,NB,LBOX2,NSPACE,MSTA,IDIM,X,NX,LBST,
     *                  LBNDET(1,IGB2),IACON1,JPOSB)
              KBPOS = JPOSB + NIBS
              JPZB2 = LSPB(KBPOS)
              KPER1 = (-1)**JPERB
C
C   DETERMINE THE BETA STRING CONTRIBUTION TO THE MATRIX ELEMENT.
C
              C = SI1(IND)
C
              DO 7712 IK=1,NB
                 IF (IK.EQ.IB1) GOTO 7712
                 ION = IBCON1(IK)
                 J1 = INDEX(ION+1)
                 JMA = MAX(J1,IND)
                 JMI = MIN(J1,IND)
                 JJ1 = INDEX(JMA) + JMI
                 JMA = MAX(ION,JJ)
                 JMI = MIN(ION,JJ)
                 J1 = INDEX(JMA)+JMI
                 JMA = MAX(IO1,ION)
                 JMI = MIN(IO1,ION)
                 J2 = INDEX(JMA)+JMI
                 JMA = MAX(J1,J2)
                 JMI = MIN(J1,J2)
                 INX = INDEX(JMA)+JMI
                 C = C + SI2(JJ1) - SI2(INX)
 7712         CONTINUE
C
C  LOOP OVER ALPHA STRINGS OF THE RIGHT GROUP AND SYMMETRY.
C
              CALL RESETCO(LBOX3,NSPACE,NA,IAMA,IAMI,LBOX4)
C
              DO 7700 IGA=1,ITGA
              IF (LGCOM(IGB,IGA).NE.1.OR.LGCOM(IGB2,IGA).NE.1) GOTO 7690
                 JCIB1 = LDISB(KBSYM,IGB,IGA) + JPZB1
                 JCIB2 = LDISB(KBSYM,IGB2,IGA) + JPZB2
                 NIAS = NAST(IGA)
C
              CALL RESETDE(LBOX3,NSPACE,NA,MSTA,IACON1)
              ISTA1 = 1
              DO 7680 KKA=LSAS(KSYM,IGA),LSAS(KSYM+1,IGA)-1
                 IENA1 = LSAC(KKA)
                 DO IIZ=ISTA1,IENA1-1
                    CALL MOVEUP2(LBOX3,NSPACE,NA,MSTA,IACON1)
                 ENDDO
                 ISTA1 = IENA1
                 JCIA = LSPA(NIAS+IENA1)
                 JCI1 = JCIA + JCIB1
                 JCI2 = JCIA + JCIB2
C
C MATRIX ELEMENT ADDITION
C
                 D = C
                 DO 7670 IK=1,NA
                    ION = IACON1(IK)
                    J1 = INDEX(ION+1)
                    JMA = MAX(J1,IND)
                    JMI = MIN(J1,IND)
                    JJ1 = INDEX(JMA) + JMI
                    D = D + SI2(JJ1)
 7670            CONTINUE
C
                 T = D*KPER1
                 AB(JCI1) = AB(JCI1) + T*CI(JCI2)
                 AB(JCI2) = AB(JCI2) + T*CI(JCI1)
 7680         CONTINUE
C
 7690         CALL PUSHCO(LBOX3,NSPACE,NA,IAMA,IAMI,LBOX4,IEND)
 7700         CONTINUE
C
C  --- DOUBLE EXCITATIONS START HERE
C
 7800         CONTINUE
C
           IF (IB1.EQ.NB) GOTO 7850
           IF (JJ.EQ.NACT) GOTO 7850
C
            DO II=1,NSPACE
               LBOX3(II) = LBOX2(II)
            ENDDO
            IBES3 = 1
            DO KK=1,ISPB1-1
               IBES3 = IBES3 + LBOX2(KK)
            ENDDO
C
C  LOOP OVER SPACES TO EXCITE ELECTRONS FROM, MUST BE GE THAN
C  SPACE OF FIRST EXCITATION, ISPB1.
C
            DO 6890 ISPB3 = ISPB1,NSPACE
               IF (LBOX1(ISPB3).EQ.0) GOTO 6887
               IF (ISPB3.EQ.ISPB1.AND.IB1.EQ.IEBE) GOTO 6887
               IOC3 = LBOX2(ISPB3)
               IF (IOC3.EQ.0) GOTO 6887
C
               IBEE3 = IBES3 + LBOX2(ISPB3)-1
               LBOX3(ISPB3) = LBOX3(ISPB3)-1
C
C  LOOP OVER ELECTRONS IN ISPB3, WHICH ARE LARGER THAN IB1,
C  MAKING SURE IT ISN'T THE ALREADY EXCITED ELECTRON.
C
               JSTB3 = IBES3
               IF (ISPB3.EQ.ISPB1) THEN
                  JSTB3=IB1
                  IF (IGAP-1.EQ.IB1) JSTB3=JSTB3+1
               ENDIF
C
               DO 6880 IB3=JSTB3,IBEE3
                  IF (IB3.EQ.IGAP-1) GOTO 6880
                  IO3 = IBCON2(IB3)
                  IS3 = IOB(IO3)
C
C  LOOP OVER SPACES TO EXCITE ELECTRON INTO.  MUST BE GE THAN
C  SPACE FIRST ELECTRON WAS EXCITED INTO.
C
                  IGBE3 = 0
                  DO JIK=1,ISPB2-1
                     IGBE3 = IGBE3 + LBOX2(JIK)
                  ENDDO
                  DO 6850 ISPB4=ISPB2,NSPACE
C
C  IGBS3, IGBE3 ARE ELECTRONS SPECIFYING ISPB4 SPACE ELECTRON LIMITS.
C
                  LBOX3(ISPB4) = LBOX3(ISPB4) + 1
                  IGBS3 = IGBE3 + 1
                  IGBE3 = IGBE3 + LBOX2(ISPB4)
                  IF (LBOX3(ISPB3).LT.IBMI(ISPB3)) GOTO 6840
                  IF (LBOX3(ISPB4).GT.IBMA(ISPB4)) GOTO 6840
                  IF (LBOX3(ISPB2).LT.IBMI(ISPB2)) GOTO 6840
                  IF (LBOX3(ISPB2).GT.IBMA(ISPB2)) GOTO 6840
             IF (ISPB4.EQ.ISPB2.AND.JJ.EQ.MSTA(ISPB2+1)-1) GOTO 6840
C
C  GET GROUP NUMBER
C
               CALL POSITCO(LBOX5,NSPACE,NB,IBMA,IBMI,LBOX4,LBOX3,IGB3)
               NIBS3 = NBST(IGB3)
C
C  MAKE GAP INFORMATION HERE.
C
                  IGBB3 = MAX(IGBS3,IGAP)
C
                  IF (LBOX2(ISPB4).EQ.0) THEN
                     ISTA3 = MSTA(ISPB4)
                     IEND3 = MSTA(ISPB4+1)-1
                  ELSEIF (ISPB4.EQ.ISPB2) THEN
                     ISTA3 = JJ+1
                     IEND3 = IBCON2(IGBB3)-1
C
C  I AM SUSPECT ABOUT THIS NEXT LINE, WE'LL SEE WHAT HAPPENS.......
C
                     IF (IGAP-1.EQ.IGBE3) IEND3=MSTA(ISPB2+1)-1
C
                  ELSE
                     ISTA3 = MSTA(ISPB4)
                     IEND3 = IBCON2(IGBB3)-1
                  ENDIF
C
C  LOOP OVER GAPS
C
                  DO 6830 IGAP3=IGBB3,IGBE3+1
C
                     DO 6820 JJ3=ISTA3,IEND3
                        IS4 = IOB(JJ3)
                        IP2 = LGMUL(IS3,IS4)
                        IF (IP1.NE.IP2) GOTO 6820
C
              CALL REDE00(IBCON2,IACON1,NB,IB3,IGAP3-1,JJ3,JPERB3)
              CALL IDPOST(IACON1,NB,LBOX3,NSPACE,MSTA,IDIM,X,NX,LBST,
     *                  LBNDET(1,IGB3),IACON2,JPOSB3)
              IPER3 = (-1)**(JPERB3+JPERB)
              KBPOS3 = JPOSB3 + NIBS3
              JPZB3 = LSPB(KBPOS3)
C
                 JMA=MAX(JJ3,IO3)
                 JMI=MIN(JJ3,IO3)
                 I2 = INDEX(JMA) + JMI
                 INX = INDEX(I2) + IND
                 II1 = INDEX(JJ3) + IO1
                 JMA=MAX(IO3,JJ)
                 JMI=MIN(IO3,JJ)
                 II2 = INDEX(JMA) + JMI
                 JMA=MAX(II1,II2)
                 JMI=MIN(II1,II2)
                 INX2 = INDEX(JMA) + JMI
                 C = SI2(INX) - SI2(INX2)
                 T = C*IPER3
C
C  LOOP OVER ALPHA STRINGS OF RIGHT SYMMETRY AND GROUP.
C
              DO 6700 IGA=1,ITGA
              IF (LGCOM(IGB,IGA).NE.1.OR.LGCOM(IGB3,IGA).NE.1) GOTO 6700
              JCIB1 = JPZB1 + LDISB(KBSYM,IGB,IGA)
              JCIB3 = JPZB3 + LDISB(KBSYM,IGB3,IGA)
              NIAS = NAST(IGA)
C
              DO 6680 KKA=LSAS(KSYM,IGA),LSAS(KSYM+1,IGA)-1
                 IENA3 = LSAC(KKA)
                 JCIA = LSPA(NIAS+IENA3)
                 JCI1 = JCIA + JCIB1
                 JCI3 = JCIA + JCIB3
C
                 AB(JCI1) = AB(JCI1) + T*CI(JCI3)
                 AB(JCI3) = AB(JCI3) + T*CI(JCI1)
 6680         CONTINUE
C
 6700         CONTINUE
C
 6820                CONTINUE
C
                     ISTA3 = IBCON2(IGAP3)+1
                     IEND3 = IBCON2(IGAP3+1)-1
                     IF (IGAP3.EQ.IGBE3) IEND3=MSTA(ISPB4+1)-1
 6830             CONTINUE
C
 6840             LBOX3(ISPB4) = LBOX3(ISPB4) - 1
 6850             CONTINUE
C
 6880          CONTINUE
C
               LBOX3(ISPB3) = LBOX3(ISPB3)+1
 6887          IBES3 = IBES3 + LBOX3(ISPB3)
 6890       CONTINUE
C
C  --- END OF LOOP OVER DOUBLE BETA EXCITATIONS.
C
 7850                CONTINUE
C
                  ISTA = IBCON1(IGAP)+1
                  IEND = IBCON1(IGAP+1)-1
                  IF (IGAP.EQ.IGBE) IEND=MSTA(ISPB2+1)-1
 7860             CONTINUE
C
 7870             LBOX2(ISPB2) = LBOX2(ISPB2) - 1
 7880          CONTINUE
C
 7885          CONTINUE
C
               LBOX2(ISPB1) = LBOX2(ISPB1)+1
 7890       CONTINUE
C
            CALL MOVEUP2(LBOX1,NSPACE,NB,MSTA,IBCON1)
 7900    CONTINUE
C
         CALL PUSHCO(LBOX1,NSPACE,NB,IBMA,IBMI,LBOX5,IEND)
 8000 CONTINUE
C
C  --- END OF LOOP OVER BETA STRINGS. ---
C
C   NOW FOR THE DIAGONAL CONTRIBUTIONS
C
      DO 119 IJK=1,NCI
         AB(IJK) = AB(IJK) + Q(IJK)*CI(IJK)
  119 CONTINUE
C
C  ALL DONE, RETURN
C
      RETURN
      END
C
C*MODULE ORMAS1  *DECK FCHCXYS
C     ------------------------------------------------------------------
      SUBROUTINE FCHCXYS(SI1,SI2,INDEX,NACT,NA,NB,CI,AB,NV,Q,NCI,X,NX,
     *           IACON1,IACON2,IBCON1,IBCON2,
     *           LBOX1,LBOX2,LBOX3,LBOX4,LBOX5,
     *           NSYM,IOB,LGMUL,KTAB,
     *           LANDET,LBNDET,NAST,NBST,LSYMA,LSYMB,LGCOM,
     *           LSPA,LSPB,LDISB,LSAS,LSBS,LSAC,LSBC,
     *           ITGA,ITGB,IAST,IBST,
     *           IPOSA,IPERA,IIND1,IGROA,IMMC,
     *           NB1EX,JB1GR,JB1PE,JB1IN,JB1PO,JB1ST)
C     ------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL FDIRCT,QCORR
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      COMMON /FCCWFN/ NSPACE,MSTA(51),MNUM(51),MINI(51),MAXI(51),
     *                IAMI(51),IAMA(51),IBMI(51),IBMA(51),IDIM(51),
     *                LBST(51),NREF0,FDIRCT,QCORR,C0SQ
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      DIMENSION SI1(*),SI2(*)
      DIMENSION INDEX((NACT*(NACT+1))/2+1)
      DIMENSION CI(NCI,NV),AB(NCI,NV),Q(NCI),X(NX)
      DIMENSION IACON1(NA),IACON2(NA),IBCON1(NA),IBCON2(NA)
      DIMENSION LBOX1(NSPACE),LBOX2(NSPACE),LBOX3(NSPACE)
      DIMENSION LBOX4(NSPACE),LBOX5(NSPACE)
      DIMENSION IOB(NACT),LGMUL(NSYM,NSYM),KTAB(NSYM)
      DIMENSION LANDET(NSPACE,ITGA),LBNDET(NSPACE,ITGB)
      DIMENSION NAST(ITGA+1),NBST(ITGB+1)
      DIMENSION LSYMA(IAST),LSYMB(IBST),LGCOM(ITGB,ITGA)
      DIMENSION LSPA(IAST),LSPB(IBST),LDISB(NSYM,ITGB,ITGA)
      DIMENSION LSAS(NSYM+1,ITGA),LSBS(NSYM+1,ITGB)
      DIMENSION LSAC(IAST),LSBC(IBST)
      DIMENSION IPOSA(NA*(NACT-NA),NSYM)
      DIMENSION IPERA(NA*(NACT-NA),NSYM)
      DIMENSION IIND1(NA*(NACT-NA),NSYM)
      DIMENSION IGROA(NA*(NACT-NA),NSYM)
      DIMENSION IMMC(NSYM)
      DIMENSION JB1GR(NB1EX),JB1PE(NB1EX),JB1IN(NB1EX),JB1PO(NB1EX)
      DIMENSION JB1ST(NSYM+1,IBST+1)
C
      DO II=1,NCI
         DO JJ=1,NV
            AB(II,JJ) = 0.0D+00
         ENDDO
      ENDDO
C
C  --- BIG LOOP OVER ALL ALPHA STRINGS. ---
C
      IF (GOPARR) THEN
         CALL DDI_DLBRESET()
         CALL DDI_DLBNEXT(MY_TASK)
      ENDIF
C
      CALL RESETCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX5)
C
      DO 5000 IGA=1,ITGA
C
         CALL RESETDE(LBOX1,NSPACE,NA,MSTA,IACON1)
C
C  KKA GIVES THE ACTUAL POSITION OF THE ALPHA STRING IACON1 IN
C  THE FULL ALPHA STRING LIST.
C
         DO 4900 KKA=NAST(IGA)+1,NAST(IGA+1)
            IF (GOPARR.AND.KKA-1.NE.MY_TASK) GOTO 4899
            JPZA1 = LSPA(KKA)
            JASYM = LSYMA(KKA)
            KSYM=KTAB(JASYM)
            DO II=1,NSYM
               IMMC(II)=0
            ENDDO
C
            DO II=1,NSPACE
               LBOX2(II) = LBOX1(II)
            ENDDO
C
C  LOOP OVER SPACES TO EXCITE ELECTRON FROM.
C
            IEAS = NA+1
            DO 4890 ISPA1=NSPACE,1,-1
               IOC1 = LBOX1(ISPA1)
               IEAE = IEAS - 1
               IEAS = IEAS - IOC1
               IF (IOC1.EQ.0) GOTO 4890
               LBOX2(ISPA1) = LBOX2(ISPA1)-1
C
C  LOOP ELECTRONS IN SPACE ISPA1.
C  IEAS, IEAE ARE THE ELECTRONS IN SPACE ISPA1.
C
               DO 4885 IA1=IEAE,IEAS,-1
                  IO1 = IACON1(IA1)
                  IGAE = IEAE - LBOX1(ISPA1)
                  IS1 = IOB(IO1)
C
C  LOOP OVER POSSIBLE SPACES TO EXCITE INTO.
C
               DO 4880 ISPA2=ISPA1,NSPACE
C
C  IGAS, IGAE ARE ELECTRONS SPECIFYING ISPA2 SPACE ELECTRON LIMITS.
C
                  IGAS = IGAE + 1
                  IGAE = IGAE + LBOX1(ISPA2)
C
                  LBOX2(ISPA2) = LBOX2(ISPA2) + 1
                  IF (LBOX2(ISPA1).LT.IAMI(ISPA1)) GOTO 4870
C
C  MAKE GAP INFORMATION HERE.
C
                  IGAA = MAX(IA1+1,IGAS)
                  IF (LBOX1(ISPA2).EQ.0) THEN
                     ISTA = MSTA(ISPA2)
                     IEND = MSTA(ISPA2+1)-1
                  ELSEIF (ISPA2.EQ.ISPA1) THEN
                     ISTA = IO1+1
                     IEND = IACON1(IGAA)-1
                     IF (IA1.EQ.IEAE) IEND=MSTA(ISPA1+1)-1
                  ELSE
                     ISTA = MSTA(ISPA2)
                     IEND = IACON1(IGAA)-1
                  ENDIF
C
C  LOOP OVER GAPS
C
                  DO 4860 IGAP=IGAA,IGAE+1
C
                     DO 4850 JJ=ISTA,IEND
                        IS2 = IOB(JJ)
                        IP1 = LGMUL(IS1,IS2)
C
                     IND = INDEX(JJ) + IO1
C
              CALL REDE00(IACON1,IACON2,NA,IA1,IGAP-1,JJ,JPERA)
                  IF (LBOX2(ISPA2).GT.IAMA(ISPA2)) GOTO 4800
C
C  GET GROUP NUMBER
C
           CALL POSITCO(LBOX5,NSPACE,NA,IAMA,IAMI,LBOX4,LBOX2,IGA2)
           NIAS = NAST(IGA2)
C
              CALL IDPOST(IACON2,NA,LBOX2,NSPACE,MSTA,IDIM,X,NX,LBST,
     *                  LANDET(1,IGA2),IBCON1,JPOSA)
              KAPOS = JPOSA + NIAS
              JPZA2 = LSPA(KAPOS)
              KASYM = LSYMA(KAPOS)
              KPER1 = (-1)**JPERA
              IMMC(KASYM) = IMMC(KASYM) + 1
              JSPO = IMMC(KASYM)
              IPOSA(JSPO,KASYM) = JPZA2
              IPERA(JSPO,KASYM) = KPER1
              IIND1(JSPO,KASYM) = IND
              IGROA(JSPO,KASYM) = IGA2
C
C   IF DEOCCUPIED AND NEWLY OCCUPIED ORBITALS ARE OF DIFFERENT SYMMETRY,
C   SKIP TO DOUBLES.
C
              IF (IS1.NE.IS2) GOTO 4800
C
C   DETERMINE THE ALPHA STRING CONTRIBUTION TO THE MATRIX ELEMENT.
C
              C = SI1(IND)
C
              DO 4712 IK=1,NA
                 IF (IK.EQ.IA1) GOTO 4712
                 ION = IACON1(IK)
                 J1 = INDEX(ION+1)
                 JMA = MAX(J1,IND)
                 JMI = MIN(J1,IND)
                 JJ1 = INDEX(JMA) + JMI
                 JMA = MAX(ION,JJ)
                 JMI = MIN(ION,JJ)
                 J1 = INDEX(JMA)+JMI
                 JMA = MAX(IO1,ION)
                 JMI = MIN(IO1,ION)
                 J2 = INDEX(JMA)+JMI
                 JMA = MAX(J1,J2)
                 JMI = MIN(J1,J2)
                 INX = INDEX(JMA)+JMI
                 C = C + SI2(JJ1) - SI2(INX)
 4712         CONTINUE
C
C  LOOP OVER BETA DETS OF THE RIGHT GROUP AND SYMMETRY.
C
              CALL RESETCO(LBOX3,NSPACE,NB,IBMA,IBMI,LBOX4)
C
              DO 4700 IGB=1,ITGB
              IF (LGCOM(IGB,IGA).NE.1.OR.LGCOM(IGB,IGA2).NE.1) GOTO 4690
              JCI1 = JPZA1 + LDISB(KSYM,IGB,IGA)
              JCI2 = JPZA2 + LDISB(KSYM,IGB,IGA2)
C
              CALL RESETDE(LBOX3,NSPACE,NB,MSTA,IBCON1)
              ISTB = 1
              DO 4680 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                 IENB = LSBC(KKB)
                 DO IIZ=ISTB,IENB-1
                    CALL MOVEUP2(LBOX3,NSPACE,NB,MSTA,IBCON1)
                 ENDDO
                 ISTB = IENB
                 JCI1 = JCI1 + 1
                 JCI2 = JCI2 + 1
C
C MATRIX ELEMENT ADDITION
C
                 D = C
                 DO 4670 IK=1,NB
                    ION = IBCON1(IK)
                    J1 = INDEX(ION+1)
                    JMA = MAX(J1,IND)
                    JMI = MIN(J1,IND)
                    JJ1 = INDEX(JMA) + JMI
                    D = D + SI2(JJ1)
 4670            CONTINUE
C
                 T = D*KPER1
C
                 DO 44 KJ=1,NV
                 AB(JCI1,KJ) = AB(JCI1,KJ) + T*CI(JCI2,KJ)
                 AB(JCI2,KJ) = AB(JCI2,KJ) + T*CI(JCI1,KJ)
   44            CONTINUE
C
 4680         CONTINUE
C
 4690         CALL PUSHCO(LBOX3,NSPACE,NB,IBMA,IBMI,LBOX4,IEND)
 4700         CONTINUE
C
C --  DOUBLE ALPHA EXCITATIONS START HERE  ---
C
 4800         CONTINUE
C
            IF (IA1.EQ.NA) GOTO 4850
            IF (JJ.EQ.NACT) GOTO 4850
C
            DO II=1,NSPACE
               LBOX3(II) = LBOX2(II)
            ENDDO
            IAES3 = 1
            DO KK=1,ISPA1-1
               IAES3 = IAES3 + LBOX2(KK)
            ENDDO
C
C  LOOP OVER SPACES TO EXCITE ELECTRONS FROM, MUST BE GE THAN
C  SPACE OF FIRST EXCITATION, ISPA1.
C
            DO 3890 ISPA3 = ISPA1,NSPACE
               IF (LBOX1(ISPA3).EQ.0) GOTO 3887
               IF (ISPA3.EQ.ISPA1.AND.IA1.EQ.IEAE) GOTO 3887
               IOC3 = LBOX2(ISPA3)
               IF (IOC3.EQ.0) GOTO 3887
C
               IAEE3 = IAES3 + LBOX2(ISPA3)-1
               LBOX3(ISPA3) = LBOX3(ISPA3)-1
C
C  LOOP OVER ELECTRONS IN ISPA3, WHICH ARE LARGER THAN IA1,
C  MAKING SURE IT ISN'T THE ALREADY EXCITED ELECTRON.
C
               JSTA3 = IAES3
               IF (ISPA3.EQ.ISPA1) THEN
                  JSTA3=IA1
                  IF (IGAP-1.EQ.IA1) JSTA3=JSTA3+1
               ENDIF
C
               DO 3880 IA3=JSTA3,IAEE3
                  IF (IA3.EQ.IGAP-1) GOTO 3880
                  IO3 = IACON2(IA3)
                  IS3 = IOB(IO3)
C
C  LOOP OVER SPACES TO EXCITE ELECTRON INTO.  MUST BE GE THAN
C  SPACE FIRST ELECTRON WAS EXCITED INTO.
C
                  IGAE3 = 0
                  DO JIK=1,ISPA2-1
                     IGAE3 = IGAE3 + LBOX2(JIK)
                  ENDDO
                  DO 3850 ISPA4=ISPA2,NSPACE
C
C  IGAS3, IGAE3 ARE ELECTRONS SPECIFYING ISPA4 SPACE ELECTRON LIMITS.
C
                  LBOX3(ISPA4) = LBOX3(ISPA4) + 1
                  IGAS3 = IGAE3 + 1
                  IGAE3 = IGAE3 + LBOX2(ISPA4)
                  IF (LBOX3(ISPA3).LT.IAMI(ISPA3)) GOTO 3840
                  IF (LBOX3(ISPA4).GT.IAMA(ISPA4)) GOTO 3840
                  IF (LBOX3(ISPA2).LT.IAMI(ISPA2)) GOTO 3840
                  IF (LBOX3(ISPA2).GT.IAMA(ISPA2)) GOTO 3840
C
             IF (ISPA4.EQ.ISPA2.AND.JJ.EQ.MSTA(ISPA2+1)-1) GOTO 3840
C
C  GET GROUP NUMBER
C
               CALL POSITCO(LBOX5,NSPACE,NA,IAMA,IAMI,LBOX4,LBOX3,IGA3)
               NIAS3 = NAST(IGA3)
C
C  MAKE GAP INFORMATION HERE.
C
                  IGAA3 = MAX(IGAS3,IGAP)
C
                  IF (LBOX2(ISPA4).EQ.0) THEN
                     ISTA3 = MSTA(ISPA4)
                     IEND3 = MSTA(ISPA4+1)-1
                  ELSEIF (ISPA4.EQ.ISPA2) THEN
                     ISTA3 = JJ+1
                     IEND3 = IACON2(IGAA3)-1
C
C  I AM SUSPECT ABOUT THIS NEXT LINE, WE'LL SEE WHAT HAPPENS.......
C
                     IF (IGAP-1.EQ.IGAE3) IEND3=MSTA(ISPA2+1)-1
C
                  ELSE
                     ISTA3 = MSTA(ISPA4)
                     IEND3 = IACON2(IGAA3)-1
                  ENDIF
C
C  LOOP OVER GAPS
C
                  DO 3830 IGAP3=IGAA3,IGAE3+1
C
                     DO 3820 JJ3=ISTA3,IEND3
                        IS4 = IOB(JJ3)
                        IP2 = LGMUL(IS3,IS4)
                        IF (IP1.NE.IP2) GOTO 3820
C
              CALL REDE00(IACON2,IBCON1,NA,IA3,IGAP3-1,JJ3,JPERA3)
              CALL IDPOST(IBCON1,NA,LBOX3,NSPACE,MSTA,IDIM,X,NX,LBST,
     *                  LANDET(1,IGA3),IBCON2,JPOSA3)
              IPER3 = (-1)**(JPERA3+JPERA)
              KAPOS3 = JPOSA3 + NIAS3
              JPZA3 = LSPA(KAPOS3)
                 JMA=MAX(JJ3,IO3)
                 JMI=MIN(JJ3,IO3)
                 I2 = INDEX(JMA) + JMI
                 INX = INDEX(I2) + IND
                 II1 = INDEX(JJ3) + IO1
                 JMA=MAX(IO3,JJ)
                 JMI=MIN(IO3,JJ)
                 II2 = INDEX(JMA) + JMI
                 JMA=MAX(II1,II2)
                 JMI=MIN(II1,II2)
                 INX2 = INDEX(JMA) + JMI
                 C = SI2(INX) - SI2(INX2)
                 T = C*IPER3
C
C  LOOP OVER BETA STRINGS OF RIGHT SYMMETRY AND GROUP.
C
              DO 3700 IGB=1,ITGB
              IF (LGCOM(IGB,IGA).NE.1.OR.LGCOM(IGB,IGA3).NE.1) GOTO 3700
              JCI1 = JPZA1 + LDISB(KSYM,IGB,IGA)
              JCI3 = JPZA3 + LDISB(KSYM,IGB,IGA3)
C
              DO 3680 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                 JCI1 = JCI1 + 1
                 JCI3 = JCI3 + 1
C
                 DO 55 KJ=1,NV
                 AB(JCI1,KJ) = AB(JCI1,KJ) + T*CI(JCI3,KJ)
                 AB(JCI3,KJ) = AB(JCI3,KJ) + T*CI(JCI1,KJ)
   55            CONTINUE
C
 3680         CONTINUE
C
 3700         CONTINUE
C
 3820                CONTINUE
C
                     ISTA3 = IACON2(IGAP3)+1
                     IEND3 = IACON2(IGAP3+1)-1
                     IF (IGAP3.EQ.IGAE3) IEND3=MSTA(ISPA4+1)-1
 3830             CONTINUE
C
 3840             LBOX3(ISPA4) = LBOX3(ISPA4) - 1
 3850             CONTINUE
C
 3880          CONTINUE
C
               LBOX3(ISPA3) = LBOX3(ISPA3)+1
 3887          IAES3 = IAES3 + LBOX3(ISPA3)
 3890       CONTINUE
C
 4850                CONTINUE
C
                  ISTA = IACON1(IGAP)+1
                  IEND = IACON1(IGAP+1)-1
                  IF (IGAP.EQ.IGAE) IEND=MSTA(ISPA2+1)-1
 4860             CONTINUE
C
 4870             LBOX2(ISPA2) = LBOX2(ISPA2) - 1
 4880          CONTINUE
C
 4885          CONTINUE
C
               LBOX2(ISPA1) = LBOX2(ISPA1)+1
 4890       CONTINUE
C
C
C  --- END OF LOOP OVER SINGLE ALPHA EXCITATIONS. ---
C      NOW TO SORT THEM BY POSITIONS WITHIN SYMMETRIES.
C
            DO II=1,NSYM
               CALL FCCSRT3(IGROA(1,II),IPERA(1,II),IIND1(1,II),
     *                   IPOSA(1,II),IMMC(II))
            ENDDO
C
C  --- END OF LOOP OVER PURE ALPHA EXCITATIONS.
C  NOW TO LOOP OVER ALL SIMULTANEOUS AB -> A'B' EXCITATIONS.
C
      IF (NSPACE.EQ.1) GOTO 3400
C
C  ***** GENERAL CASE OF MORE THAN ONE SPACE !!!!! *******
C
      IF (.NOT.FDIRCT) THEN
C
C  LOOP OVER SINGLE ALPHA EXCITES WITHIN EACH SYMMETRY.
C
      DO 3000 ISAE=1,NSYM
         KBSYM=KTAB(ISAE)
         DO 2900 JSAE=1,IMMC(ISAE)
            JPOSAE=IPOSA(JSAE,ISAE)
            JPERAE=IPERA(JSAE,ISAE)
            JINDAE=IIND1(JSAE,ISAE)
            JGROAE=IGROA(JSAE,ISAE)
C
C
C  IF ISAE.EQ.JASYM THEN SPECIAL CASE.
C
       IF (ISAE.EQ.JASYM.AND.IGA.EQ.JGROAE) THEN
C
C  LOOP OVER ALL RELEVANT BETAS
C
            LABPOS = JPZA1
            LABPOS2 = JPOSAE
            DO 2813 IGB=1,ITGB
               IF (LGCOM(IGB,IGA).NE.1) GOTO 2813
               NIBS = NBST(IGB)
               DO 2763 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                  LABPOS = LABPOS + 1
                  LABPOS2 = LABPOS2 + 1
                  IBPOS = NIBS + LSBC(KKB)
C
C  LOOP OVER SINGLE BETA EXCITES FROM IBPOS
C
               DO 2613 JBINDX=JB1ST(KBSYM,IBPOS),JB1ST(KBSYM+1,IBPOS)-1
                  IGB2=JB1GR(JBINDX)
                  IF (LGCOM(IGB2,JGROAE).NE.1) GOTO 2613
C
                  JMA=MAX(JINDAE,JB1IN(JBINDX))
                  JMI=MIN(JINDAE,JB1IN(JBINDX))
                  IX=INDEX(JMA)+JMI
                  C = SI2(IX)*JPERAE*JB1PE(JBINDX)
                  JCIB=JPOSAE+LDISB(KBSYM,IGB2,JGROAE)+JB1PO(JBINDX)
                  JCIB2=JPZA1+LDISB(KBSYM,IGB2,JGROAE)+JB1PO(JBINDX)
C
                  DO 66 KJ=1,NV
                  AB(LABPOS,KJ) = AB(LABPOS,KJ) + C*CI(JCIB,KJ)
                  AB(JCIB,KJ) = AB(JCIB,KJ) + C*CI(LABPOS,KJ)
                  AB(LABPOS2,KJ) = AB(LABPOS2,KJ) + C*CI(JCIB2,KJ)
                  AB(JCIB2,KJ) = AB(JCIB2,KJ) + C*CI(LABPOS2,KJ)
   66             CONTINUE
C
 2613          CONTINUE
C
 2763          CONTINUE
 2813       CONTINUE
C
       ELSE
C
C  LOOP OVER ALL RELEVANT (A-)BETA DETS.
C
            LABPOS = JPZA1
            DO 2800 IGB=1,ITGB
               IF (LGCOM(IGB,IGA).NE.1) GOTO 2800
               NIBS = NBST(IGB)
               DO 2750 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                  LABPOS = LABPOS + 1
                  IBPOS = NIBS + LSBC(KKB)
C
C  LOOP OVER SINGLE BETA EXCITES FROM IBPOS
C
               DO 2600 JBINDX=JB1ST(KBSYM,IBPOS),JB1ST(KBSYM+1,IBPOS)-1
                  IGB2=JB1GR(JBINDX)
                  IF (LGCOM(IGB2,JGROAE).NE.1) GOTO 2600
C
                  JMA=MAX(JINDAE,JB1IN(JBINDX))
                  JMI=MIN(JINDAE,JB1IN(JBINDX))
                  IX=INDEX(JMA)+JMI
                  C = SI2(IX)*JPERAE*JB1PE(JBINDX)
                  JCIB=JPOSAE+LDISB(KBSYM,IGB2,JGROAE)+JB1PO(JBINDX)
C
                  DO 77 KJ=1,NV
                  AB(LABPOS,KJ) = AB(LABPOS,KJ) + C*CI(JCIB,KJ)
                  AB(JCIB,KJ) = AB(JCIB,KJ) + C*CI(LABPOS,KJ)
   77             CONTINUE
C
 2600          CONTINUE
C
 2750          CONTINUE
 2800       CONTINUE
C
C
C  LOOP OVER ALL RELEVANT (A'-)BETA DETS.
C
            LABPOS = JPOSAE
            DO 2803 IGB=1,ITGB
               IF (LGCOM(IGB,JGROAE).NE.1) GOTO 2803
               NIBS = NBST(IGB)
               DO 2753 KKB=LSBS(KBSYM,IGB),LSBS(KBSYM+1,IGB)-1
                  LABPOS = LABPOS + 1
                  IBPOS = NIBS + LSBC(KKB)
C
C  LOOP OVER SINGLE BETA EXCITES FROM IBPOS
C
               DO 2603 JBINDX=JB1ST(KSYM,IBPOS),JB1ST(KSYM+1,IBPOS)-1
                  IGB2=JB1GR(JBINDX)
                  IF (LGCOM(IGB2,IGA).NE.1) GOTO 2603
C
                  JMA=MAX(JINDAE,JB1IN(JBINDX))
                  JMI=MIN(JINDAE,JB1IN(JBINDX))
                  IX=INDEX(JMA)+JMI
                  C = SI2(IX)*JPERAE*JB1PE(JBINDX)
                  JCIB=JPZA1+LDISB(KSYM,IGB2,IGA)+JB1PO(JBINDX)
C
                  DO 88 KJ=1,NV
                  AB(LABPOS,KJ) = AB(LABPOS,KJ) + C*CI(JCIB,KJ)
                  AB(JCIB,KJ) = AB(JCIB,KJ) + C*CI(LABPOS,KJ)
   88             CONTINUE
C
 2603          CONTINUE
C
 2753          CONTINUE
 2803       CONTINUE
C
      ENDIF
C
 2900    CONTINUE
 3000 CONTINUE
C
      ELSE
C
C  ***** DIRECT METHOD BELOW *****
C
      DO 4000 ISAE=1,NSYM
         KBSYM = KTAB(ISAE)
C
C  ANALYSE EXCITED A' GROUPS FOR COMPATIBILITY WITH B.
C
      NGRPS = 0
      DO 1976 II=1,IMMC(ISAE)
         ICGR = IGROA(II,ISAE)
         DO JJ=1,NGRPS
            IF (JB1GR(JJ).EQ.ICGR) GOTO 1976
         ENDDO
         NGRPS = NGRPS + 1
         JB1GR(NGRPS) = ICGR
 1976 CONTINUE
C
C FIRST TYPE OF BETAS, KSYM -> KBSYM
C
          CALL RESETCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3)
          DO 7400 IGB=1,ITGB
             IF (LGCOM(IGB,IGA).NE.1) GOTO 7399
             LAB1 = JPZA1 + LDISB(KSYM,IGB,IGA)
C
             CALL RESETDE(LBOX2,NSPACE,NB,MSTA,IBCON1)
             NIBS = NBST(IGB)
             ISTB = 1
             DO 7300 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                IENB = LSBC(KKB)
                DO IIZ=ISTB,IENB-1
                   CALL MOVEUP2(LBOX2,NSPACE,NB,MSTA,IBCON1)
                ENDDO
                ISTB = IENB
C
                IBPOS = NIBS + LSBC(KKB)
                LABPOS = LAB1 + LSPB(IBPOS)
C
C LOOP OVER SINGLE BETA EXCITES FROM IBPOS WHICH ARE OF SYMMETRY KBSYM
C
                MESYM1 = LGMUL(KSYM,KBSYM)
                DO II=1,NSPACE
                   LBOX3(II) = LBOX2(II)
                ENDDO
                IEBS = NB + 1
                DO 7290 ISPB1=NSPACE,1,-1
                   IOC1 = LBOX2(ISPB1)
                   IEBE = IEBS - 1
                   IEBS = IEBS - IOC1
                   IF (IOC1.EQ.0) GO TO 7290
                   LBOX3(ISPB1) = LBOX3(ISPB1)-1
C
C  LOOP ELECTRONS IN SPACE ISPB1
C  IEBS, IEBE ARE THE ELECTRONS IN SPACE ISPB1
C
                DO 7285 IB1 = IEBE,IEBS,-1
                   IO1 = IBCON1(IB1)
                   MESYM2 = LGMUL(MESYM1,IOB(IO1))
                   IGBE = IEBE - LBOX2(ISPB1)
C
C  LOOP OVER POSSIBLE SPACES TO EXCITE INTO.
C
                DO 7280 ISPB2=ISPB1,NSPACE
C
C  IGBS,IGBE ARE ELECTRONS SPECIFYING ISPB2 SPACE ELECTRON LIMITS.
C
                   IGBS = IGBE + 1
                   IGBE = IGBE + LBOX2(ISPB2)
C
                   LBOX3(ISPB2) = LBOX3(ISPB2) + 1
                   IF (LBOX3(ISPB1).LT.IBMI(ISPB1)) GO TO 7270
                   IF (LBOX3(ISPB2).GT.IBMA(ISPB2)) GO TO 7270
C
C  GET GROUP NUMBER
C
          CALL POSITCO(LBOX5,NSPACE,NB,IBMA,IBMI,LBOX4,LBOX3,IGB2)
          NIAS = NBST(IGB2)
C
C CHECK FOR A' GROUP COMPATIBILITY
C
             DO II=1,NGRPS
                IAGRP = JB1GR(II)
                IF (LGCOM(IGB2,IAGRP).EQ.1) GOTO 7555
             ENDDO
             GOTO 7270
 7555        CONTINUE
C
C  MAKE GAP INFORMATION HERE.
C
                  IGBA = MAX(IB1+1,IGBS)
                  IF (LBOX2(ISPB2).EQ.0) THEN
                     ISTA = MSTA(ISPB2)
                     IEND = MSTA(ISPB2+1)-1
                  ELSEIF (ISPB2.EQ.ISPB1) THEN
                     ISTA = IO1+1
                     IEND = IBCON1(IGBA)-1
                     IF (IB1.EQ.IEBE) IEND=MSTA(ISPB1+1)-1
                  ELSE
                     ISTA = MSTA(ISPB2)
                     IEND = IBCON1(IGBA)-1
                  ENDIF
C
C  LOOP OVER GAPS
C
                  DO 7260 IGAP=IGBA,IGBE+1
C
                     DO 7250 JJ=ISTA,IEND
C
C CHECK TO SEE IF EXCITED BETA IS OF RIGHT SYMMETRY (KBSYM)
C
            IF (IOB(JJ).NE.MESYM2) GOTO 7250
C
            IND1 = INDEX(JJ) + IO1
            CALL REDE00(IBCON1,IBCON2,NB,IB1,IGAP-1,JJ,IPER)
            CALL IDPOST(IBCON2,NB,LBOX3,NSPACE,MSTA,IDIM,X,NX,LBST,
     *                  LBNDET(1,IGB2),IACON2,IPOSB)
            QJPER = ((-1)**IPER)
            JB1P = LSPB(IPOSB + NIAS)
C
            DO 3900 JSAE=1,IMMC(ISAE)
               JGROAE=IGROA(JSAE,ISAE)
               IF (LGCOM(IGB2,JGROAE).NE.1) GOTO 3900
C
               JPOSAE=IPOSA(JSAE,ISAE)
               JCIB = JB1P + JPOSAE + LDISB(KBSYM,IGB2,JGROAE)
C
               JINDAE=IIND1(JSAE,ISAE)
               JMA=MAX(JINDAE,IND1)
               JMI=MIN(JINDAE,IND1)
               IX=INDEX(JMA)+JMI
C
               JPERAE=IPERA(JSAE,ISAE)
               C = SI2(IX)*QJPER*JPERAE
C
         DO KJ=1,NV
            AB(LABPOS,KJ) = AB(LABPOS,KJ) + C*CI(JCIB,KJ)
            AB(JCIB,KJ) = AB(JCIB,KJ) + C*CI(LABPOS,KJ)
         ENDDO
C
 3900       CONTINUE
C
 7250                CONTINUE
C
                  ISTA = IBCON1(IGAP)+1
                  IEND = IBCON1(IGAP+1)-1
                  IF (IGAP.EQ.IGBE) IEND=MSTA(ISPB2+1)-1
 7260             CONTINUE
C
 7270              LBOX3(ISPB2) = LBOX3(ISPB2) - 1
 7280           CONTINUE
C
 7285           CONTINUE
C
                   LBOX3(ISPB1) = LBOX3(ISPB1) + 1
 7290           CONTINUE
C
 7300        CONTINUE
C
 7399        CALL PUSHCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3,IEND)
 7400     CONTINUE
C
C
C SECOND TYPE OF BETAS, KBSYM -> KSYM
C
          CALL RESETCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3)
          DO 7801 IGB=1,ITGB
C
C CHECK FOR A' GROUP COMPATIBILITY
C
             DO II=1,NGRPS
                IAGRP = JB1GR(II)
                IF (LGCOM(IGB,IAGRP).EQ.1) GOTO 7655
             ENDDO
             GOTO 7799
 7655        CONTINUE
C
             CALL RESETDE(LBOX2,NSPACE,NB,MSTA,IBCON1)
             NIBS = NBST(IGB)
             ISTB = 1
C
             DO 7701 KKB=LSBS(KBSYM,IGB),LSBS(KBSYM+1,IGB)-1
                IENB = LSBC(KKB)
                DO IIZ=ISTB,IENB-1
                   CALL MOVEUP2(LBOX2,NSPACE,NB,MSTA,IBCON1)
                ENDDO
                ISTB = IENB
C
                IBPOS = NIBS + LSBC(KKB)
                LAB1 = LSPB(IBPOS)
C
C LOOP OVER SINGLE BETA EXCITES FROM IBPOS WHICH ARE OF SYMMETRY KSYM
C
                MESYM1 = LGMUL(KSYM,KBSYM)
                DO II=1,NSPACE
                   LBOX3(II) = LBOX2(II)
                ENDDO
                IEBS = NB + 1
                DO 7691 ISPB1=NSPACE,1,-1
                   IOC1 = LBOX2(ISPB1)
                   IEBE = IEBS - 1
                   IEBS = IEBS - IOC1
                   IF (IOC1.EQ.0) GO TO 7691
                   LBOX3(ISPB1) = LBOX3(ISPB1)-1
C
C  LOOP ELECTRONS IN SPACE ISPB1
C  IEBS, IEBE ARE THE ELECTRONS IN SPACE ISPB1
C
                DO 7685 IB1 = IEBE,IEBS,-1
                   IO1 = IBCON1(IB1)
                   MESYM2 = LGMUL(MESYM1,IOB(IO1))
                   IGBE = IEBE - LBOX2(ISPB1)
C
C  LOOP OVER POSSIBLE SPACES TO EXCITE INTO.
C
                DO 7681 ISPB2=ISPB1,NSPACE
C
C  IGBS,IGBE ARE ELECTRONS SPECIFYING ISPB2 SPACE ELECTRON LIMITS.
C
                   IGBS = IGBE + 1
                   IGBE = IGBE + LBOX2(ISPB2)
C
                   LBOX3(ISPB2) = LBOX3(ISPB2) + 1
                   IF (LBOX3(ISPB1).LT.IBMI(ISPB1)) GO TO 7671
                   IF (LBOX3(ISPB2).GT.IBMA(ISPB2)) GO TO 7671
C
          CALL POSITCO(LBOX5,NSPACE,NB,IBMA,IBMI,LBOX4,LBOX3,IGB2)
          IF (LGCOM(IGB2,IGA).NE.1) GOTO 7671
          JCIBS = JPZA1 + LDISB(KSYM,IGB2,IGA)
          NIAS = NBST(IGB2)
C
C  MAKE GAP INFORMATION HERE.
C
                  IGBA = MAX(IB1+1,IGBS)
                  IF (LBOX2(ISPB2).EQ.0) THEN
                     ISTA = MSTA(ISPB2)
                     IEND = MSTA(ISPB2+1)-1
                  ELSEIF (ISPB2.EQ.ISPB1) THEN
                     ISTA = IO1+1
                     IEND = IBCON1(IGBA)-1
                     IF (IB1.EQ.IEBE) IEND=MSTA(ISPB1+1)-1
                  ELSE
                     ISTA = MSTA(ISPB2)
                     IEND = IBCON1(IGBA)-1
                  ENDIF
C
C  LOOP OVER GAPS
C
                  DO 7660 IGAP=IGBA,IGBE+1
C
                     DO 7650 JJ=ISTA,IEND
C
C CHECK TO SEE IF EXCITED BETA IS OF RIGHT SYMMETRY (KBSYM)
C
            IF (IOB(JJ).NE.MESYM2) GOTO 7650
C
            IND1 = INDEX(JJ) + IO1
            CALL REDE00(IBCON1,IBCON2,NB,IB1,IGAP-1,JJ,IPER)
            CALL IDPOST(IBCON2,NB,LBOX3,NSPACE,MSTA,IDIM,X,NX,LBST,
     *                  LBNDET(1,IGB2),IACON2,IPOSB)
            QJPER = ((-1)**IPER)
            JCIB= JCIBS + LSPB(IPOSB + NIAS)
C
            DO 4300 JSAE=1,IMMC(ISAE)
               JGROAE=IGROA(JSAE,ISAE)
               IF (LGCOM(IGB,JGROAE).NE.1) GOTO 4300
C
               JPOSAE=IPOSA(JSAE,ISAE)
               LABPOS = LAB1 + JPOSAE + LDISB(KBSYM,IGB,JGROAE)
C
               JINDAE=IIND1(JSAE,ISAE)
               JMA=MAX(JINDAE,IND1)
               JMI=MIN(JINDAE,IND1)
               IX=INDEX(JMA)+JMI
C
               JPERAE=IPERA(JSAE,ISAE)
               C = SI2(IX)*QJPER*JPERAE
C
         DO KJ=1,NV
            AB(LABPOS,KJ) = AB(LABPOS,KJ) + C*CI(JCIB,KJ)
            AB(JCIB,KJ) = AB(JCIB,KJ) + C*CI(LABPOS,KJ)
         ENDDO
C
 4300       CONTINUE
C
 7650                CONTINUE
C
                  ISTA = IBCON1(IGAP)+1
                  IEND = IBCON1(IGAP+1)-1
                  IF (IGAP.EQ.IGBE) IEND=MSTA(ISPB2+1)-1
 7660             CONTINUE
C
 7671              LBOX3(ISPB2) = LBOX3(ISPB2) - 1
 7681           CONTINUE
C
 7685           CONTINUE
C
                   LBOX3(ISPB1) = LBOX3(ISPB1) + 1
 7691           CONTINUE
C
 7701        CONTINUE
C
 7799        CALL PUSHCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3,IEND)
 7801     CONTINUE
C
 4000 CONTINUE
C
      ENDIF
C
C  ***** END OF DIRECT OPTION ******
C
C  **** END OF GENERAL CASE OF MORE THAN ONE SPACE ******
C
      GOTO 4898
C
 3400 CONTINUE
C
C ***** SPECIAL CASE OF ONE SPACE !!!!! ******
C
C  LOOP OVER SINGLE ALPHA EXCITES WITHIN EACH SYMMETRY.
C
       DO 2901 ISAE=1,NSYM
          KBSYM=KTAB(ISAE)
          DO 2801 JSAE=1,IMMC(ISAE)
                JPOSAE=IPOSA(JSAE,ISAE)
                JPERAE=IPERA(JSAE,ISAE)
                JINDAE=IIND1(JSAE,ISAE)
                JGROAE=IGROA(JSAE,ISAE)
C
C  IF ISAE.EQ.JASYM THEN SPECIAL CASE.
C
       IF (ISAE.EQ.JASYM) THEN
C
C  LOOP OVER ALL RELEVANT BETAS
C
             LABPOS=JPZA1
             LABPOS2=JPOSAE
                DO 2721 KKB=LSBS(KSYM,1),LSBS(KSYM+1,1)-1
                    LABPOS = LABPOS + 1
                    LABPOS2 = LABPOS2 + 1
                    IBPOS =  LSBC(KKB)
C
C  LOOP OVER SINGLE BETA EXCITES FROM IBPOS
C
               DO 2621 JBINDX=JB1ST(KSYM,IBPOS),JB1ST(KSYM+1,IBPOS)-1
                  JMA=MAX(JINDAE,JB1IN(JBINDX))
                  JMI=MIN(JINDAE,JB1IN(JBINDX))
                  IX=INDEX(JMA)+JMI
                  C = SI2(IX)*JPERAE*JB1PE(JBINDX)
                  JCIB = JPOSAE+JB1PO(JBINDX)
                  JCIB2 = JPZA1+JB1PO(JBINDX)
C
                  DO 56 KJ=1,NV
                  AB(LABPOS,KJ) = AB(LABPOS,KJ) + C*CI(JCIB,KJ)
                  AB(JCIB,KJ) = AB(JCIB,KJ) + C*CI(LABPOS,KJ)
                  AB(LABPOS2,KJ) = AB(LABPOS2,KJ) + C*CI(JCIB2,KJ)
                  AB(JCIB2,KJ) = AB(JCIB2,KJ) + C*CI(LABPOS2,KJ)
   56             CONTINUE
C
 2621          CONTINUE
C
 2721          CONTINUE
C
      ELSE
C
C  LOOP OVER ALL RELEVANT (A-)BETA DETS.
C
                LABPOS = JPZA1
                DO 2751 KKB=LSBS(KSYM,1),LSBS(KSYM+1,1)-1
                    LABPOS = LABPOS + 1
                    IBPOS =  LSBC(KKB)
C
C  LOOP OVER SINGLE BETA EXCITES FROM IBPOS
C
               DO 2601 JBINDX=JB1ST(KBSYM,IBPOS),JB1ST(KBSYM+1,IBPOS)-1
C
                  JMA=MAX(JINDAE,JB1IN(JBINDX))
                  JMI=MIN(JINDAE,JB1IN(JBINDX))
                  IX=INDEX(JMA)+JMI
                  C = SI2(IX)*JPERAE*JB1PE(JBINDX)
                  JCIB=JPOSAE+JB1PO(JBINDX)
C
                  DO 67 KJ=1,NV
                  AB(LABPOS,KJ) = AB(LABPOS,KJ) + C*CI(JCIB,KJ)
                  AB(JCIB,KJ) = AB(JCIB,KJ) + C*CI(LABPOS,KJ)
   67             CONTINUE
C
 2601          CONTINUE
C
 2751          CONTINUE
C
C  LOOP OVER ALL RELEVANT (A'-)BETA DETS.
C
               LABPOS = JPOSAE
               DO 2761 KKB=LSBS(KBSYM,1),LSBS(KBSYM+1,1)-1
                  LABPOS = LABPOS + 1
                  IBPOS = LSBC(KKB)
C
C  LOOP OVER SINGLE BETA EXCITES FROM IBPOS
C
               DO 2611 JBINDX=JB1ST(KSYM,IBPOS),JB1ST(KSYM+1,IBPOS)-1
C
                  JMA=MAX(JINDAE,JB1IN(JBINDX))
                  JMI=MIN(JINDAE,JB1IN(JBINDX))
                  IX=INDEX(JMA)+JMI
                  C = SI2(IX)*JPERAE*JB1PE(JBINDX)
                  JCIB=JPZA1+JB1PO(JBINDX)
C
                  DO 78 KJ=1,NV
                  AB(LABPOS,KJ) = AB(LABPOS,KJ) + C*CI(JCIB,KJ)
                  AB(JCIB,KJ) = AB(JCIB,KJ) + C*CI(LABPOS,KJ)
   78             CONTINUE
C
 2611          CONTINUE
C
 2761          CONTINUE
C
      ENDIF
C
 2801       CONTINUE
 2901   CONTINUE
C
C  **** END OF SPECIAL CASE OF ONE SPACE *******
C
 4898       CONTINUE
            IF (GOPARR) CALL DDI_DLBNEXT(MY_TASK)
 4899       CONTINUE
            CALL MOVEUP2(LBOX1,NSPACE,NA,MSTA,IACON1)
 4900    CONTINUE
C
         CALL PUSHCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX5,IEND)
 5000 CONTINUE
C
C  --- END OF LOOP OVER ALPHA STRINGS. ---
C
C     RESET COUNTERS AND SUM UP AB
C
      IF (GOPARR) THEN
         CALL DDI_DLBRESET()
         CALL DDI_GSUMF(2900,AB,NCI*NV)
      ENDIF
C
C  --- LOOP OVER ALL PURE BETA EXCITATIONS.
C
      CALL RESETCO(LBOX1,NSPACE,NB,IBMA,IBMI,LBOX5)
C
      DO 8000 IGB=1,ITGB
C
         CALL RESETDE(LBOX1,NSPACE,NB,MSTA,IBCON1)
C
C  KKB GIVES THE ACTUAL POSITION OF THE BETA STRING IBCON1 IN
C  THE FULL BETA STRING LIST.
C
         DO 7900 KKB=NBST(IGB)+1,NBST(IGB+1)
            JPZB1 = LSPB(KKB)
            KBSYM = LSYMB(KKB)
            KSYM=KTAB(KBSYM)
C
            DO II=1,NSPACE
               LBOX2(II) = LBOX1(II)
            ENDDO
C
C  LOOP OVER SPACES TO EXCITE ELECTRON FROM.
C
            IEBS = NB+1
            DO 7890 ISPB1=NSPACE,1,-1
               IOC1 = LBOX1(ISPB1)
               IEBE = IEBS - 1
               IEBS = IEBS - IOC1
               IF (IOC1.EQ.0) GOTO 7890
               LBOX2(ISPB1) = LBOX2(ISPB1)-1
C
C  LOOP ELECTRONS IN SPACE ISPB1.
C  IEBS, IEBE ARE THE ELECTRONS IN SPACE ISPB1.
C
               DO 7885 IB1=IEBE,IEBS,-1
                  IO1 = IBCON1(IB1)
                  IGBE = IEBE - LBOX1(ISPB1)
                  IS1 = IOB(IO1)
C
C  LOOP OVER POSSIBLE SPACES TO EXCITE INTO.
C
               DO 7880 ISPB2=ISPB1,NSPACE
C
C  IGBS, IGBE ARE ELECTRONS SPECIFYING ISPB2 SPACE ELECTRON LIMITS.
C
                  IGBS = IGBE + 1
                  IGBE = IGBE + LBOX1(ISPB2)
C
                  LBOX2(ISPB2) = LBOX2(ISPB2) + 1
                  IF (LBOX2(ISPB1).LT.IBMI(ISPB1)) GOTO 7870
C
C  MAKE GAP INFORMATION HERE.
C
                  IGBB = MAX(IB1+1,IGBS)
                  IF (LBOX1(ISPB2).EQ.0) THEN
                     ISTA = MSTA(ISPB2)
                     IEND = MSTA(ISPB2+1)-1
                  ELSEIF (ISPB2.EQ.ISPB1) THEN
                     ISTA = IO1+1
                     IEND = IBCON1(IGBB)-1
                     IF (IB1.EQ.IEBE) IEND=MSTA(ISPB1+1)-1
                  ELSE
                     ISTA = MSTA(ISPB2)
                     IEND = IBCON1(IGBB)-1
                  ENDIF
C
C  LOOP OVER GAPS
C
                  DO 7860 IGAP=IGBB,IGBE+1
C
                     DO 7850 JJ=ISTA,IEND
                        IS2 = IOB(JJ)
                        IP1 = LGMUL(IS1,IS2)
                        IND = INDEX(JJ) + IO1
C
              CALL REDE00(IBCON1,IBCON2,NB,IB1,IGAP-1,JJ,JPERB)
                  IF (LBOX2(ISPB2).GT.IBMA(ISPB2)) GOTO 7800
C
C   IF DEOCCUPIED AND NEWLY OCCUPIED ORBITALS ARE OF DIFFERENT SYMMETRY,
C   SKIP TO DOUBLES.
C
              IF (IS1.NE.IS2) GOTO 7800
C
C  GET GROUP NUMBER
C
           CALL POSITCO(LBOX5,NSPACE,NB,IBMA,IBMI,LBOX4,LBOX2,IGB2)
           NIBS = NBST(IGB2)
C
              CALL IDPOST(IBCON2,NB,LBOX2,NSPACE,MSTA,IDIM,X,NX,LBST,
     *                  LBNDET(1,IGB2),IACON1,JPOSB)
              KBPOS = JPOSB + NIBS
              JPZB2 = LSPB(KBPOS)
              KPER1 = (-1)**JPERB
C
C   DETERMINE THE BETA STRING CONTRIBUTION TO THE MATRIX ELEMENT.
C
              C = SI1(IND)
C
              DO 7712 IK=1,NB
                 IF (IK.EQ.IB1) GOTO 7712
                 ION = IBCON1(IK)
                 J1 = INDEX(ION+1)
                 JMA = MAX(J1,IND)
                 JMI = MIN(J1,IND)
                 JJ1 = INDEX(JMA) + JMI
                 JMA = MAX(ION,JJ)
                 JMI = MIN(ION,JJ)
                 J1 = INDEX(JMA)+JMI
                 JMA = MAX(IO1,ION)
                 JMI = MIN(IO1,ION)
                 J2 = INDEX(JMA)+JMI
                 JMA = MAX(J1,J2)
                 JMI = MIN(J1,J2)
                 INX = INDEX(JMA)+JMI
                 C = C + SI2(JJ1) - SI2(INX)
 7712         CONTINUE
C
C  LOOP OVER ALPHA STRINGS OF THE RIGHT GROUP AND SYMMETRY.
C
              CALL RESETCO(LBOX3,NSPACE,NA,IAMA,IAMI,LBOX4)
C
              DO 7700 IGA=1,ITGA
              IF (LGCOM(IGB,IGA).NE.1.OR.LGCOM(IGB2,IGA).NE.1) GOTO 7690
                 JCIB1 = LDISB(KBSYM,IGB,IGA) + JPZB1
                 JCIB2 = LDISB(KBSYM,IGB2,IGA) + JPZB2
                 NIAS = NAST(IGA)
C
              CALL RESETDE(LBOX3,NSPACE,NA,MSTA,IACON1)
              ISTA1 = 1
              DO 7680 KKA=LSAS(KSYM,IGA),LSAS(KSYM+1,IGA)-1
                 IENA1 = LSAC(KKA)
                 DO IIZ=ISTA1,IENA1-1
                    CALL MOVEUP2(LBOX3,NSPACE,NA,MSTA,IACON1)
                 ENDDO
                 ISTA1 = IENA1
                 JCIA = LSPA(NIAS+IENA1)
                 JCI1 = JCIA + JCIB1
                 JCI2 = JCIA + JCIB2
C
C MATRIX ELEMENT ADDITION
C
                 D = C
                 DO 7670 IK=1,NA
                    ION = IACON1(IK)
                    J1 = INDEX(ION+1)
                    JMA = MAX(J1,IND)
                    JMI = MIN(J1,IND)
                    JJ1 = INDEX(JMA) + JMI
                    D = D + SI2(JJ1)
 7670            CONTINUE
C
                 T = D*KPER1
C
                 DO 87 KJ=1,NV
                 AB(JCI1,KJ) = AB(JCI1,KJ) + T*CI(JCI2,KJ)
                 AB(JCI2,KJ) = AB(JCI2,KJ) + T*CI(JCI1,KJ)
   87            CONTINUE
C
 7680         CONTINUE
C
 7690         CALL PUSHCO(LBOX3,NSPACE,NA,IAMA,IAMI,LBOX4,IEND)
 7700         CONTINUE
C
C  --- DOUBLE EXCITATIONS START HERE
C
 7800         CONTINUE
C
           IF (IB1.EQ.NB) GOTO 7850
           IF (JJ.EQ.NACT) GOTO 7850
C
            DO II=1,NSPACE
               LBOX3(II) = LBOX2(II)
            ENDDO
            IBES3 = 1
            DO KK=1,ISPB1-1
               IBES3 = IBES3 + LBOX2(KK)
            ENDDO
C
C  LOOP OVER SPACES TO EXCITE ELECTRONS FROM, MUST BE GE THAN
C  SPACE OF FIRST EXCITATION, ISPB1.
C
            DO 6890 ISPB3 = ISPB1,NSPACE
               IF (LBOX1(ISPB3).EQ.0) GOTO 6887
               IF (ISPB3.EQ.ISPB1.AND.IB1.EQ.IEBE) GOTO 6887
               IOC3 = LBOX2(ISPB3)
               IF (IOC3.EQ.0) GOTO 6887
C
               IBEE3 = IBES3 + LBOX2(ISPB3)-1
               LBOX3(ISPB3) = LBOX3(ISPB3)-1
C
C  LOOP OVER ELECTRONS IN ISPB3, WHICH ARE LARGER THAN IB1,
C  MAKING SURE IT ISN'T THE ALREADY EXCITED ELECTRON.
C
               JSTB3 = IBES3
               IF (ISPB3.EQ.ISPB1) THEN
                  JSTB3=IB1
                  IF (IGAP-1.EQ.IB1) JSTB3=JSTB3+1
               ENDIF
C
               DO 6880 IB3=JSTB3,IBEE3
                  IF (IB3.EQ.IGAP-1) GOTO 6880
                  IO3 = IBCON2(IB3)
                  IS3 = IOB(IO3)
C
C  LOOP OVER SPACES TO EXCITE ELECTRON INTO.  MUST BE GE THAN
C  SPACE FIRST ELECTRON WAS EXCITED INTO.
C
                  IGBE3 = 0
                  DO JIK=1,ISPB2-1
                     IGBE3 = IGBE3 + LBOX2(JIK)
                  ENDDO
                  DO 6850 ISPB4=ISPB2,NSPACE
C
C  IGBS3, IGBE3 ARE ELECTRONS SPECIFYING ISPB4 SPACE ELECTRON LIMITS.
C
                  LBOX3(ISPB4) = LBOX3(ISPB4) + 1
                  IGBS3 = IGBE3 + 1
                  IGBE3 = IGBE3 + LBOX2(ISPB4)
                  IF (LBOX3(ISPB3).LT.IBMI(ISPB3)) GOTO 6840
                  IF (LBOX3(ISPB4).GT.IBMA(ISPB4)) GOTO 6840
                  IF (LBOX3(ISPB2).LT.IBMI(ISPB2)) GOTO 6840
                  IF (LBOX3(ISPB2).GT.IBMA(ISPB2)) GOTO 6840
C
             IF (ISPB4.EQ.ISPB2.AND.JJ.EQ.MSTA(ISPB2+1)-1) GOTO 6840
C
C  GET GROUP NUMBER
C
               CALL POSITCO(LBOX5,NSPACE,NB,IBMA,IBMI,LBOX4,LBOX3,IGB3)
               NIBS3 = NBST(IGB3)
C
C  MAKE GAP INFORMATION HERE.
C
                  IGBB3 = MAX(IGBS3,IGAP)
C
                  IF (LBOX2(ISPB4).EQ.0) THEN
                     ISTA3 = MSTA(ISPB4)
                     IEND3 = MSTA(ISPB4+1)-1
                  ELSEIF (ISPB4.EQ.ISPB2) THEN
                     ISTA3 = JJ+1
                     IEND3 = IBCON2(IGBB3)-1
C
C  I AM SUSPECT ABOUT THIS NEXT LINE, WE'LL SEE WHAT HAPPENS.......
C
                     IF (IGAP-1.EQ.IGBE3) IEND3=MSTA(ISPB2+1)-1
C
                  ELSE
                     ISTA3 = MSTA(ISPB4)
                     IEND3 = IBCON2(IGBB3)-1
                  ENDIF
C
C  LOOP OVER GAPS
C
                  DO 6830 IGAP3=IGBB3,IGBE3+1
C
                     DO 6820 JJ3=ISTA3,IEND3
                        IS4 = IOB(JJ3)
                        IP2 = LGMUL(IS3,IS4)
                        IF (IP1.NE.IP2) GOTO 6820
C
              CALL REDE00(IBCON2,IACON1,NB,IB3,IGAP3-1,JJ3,JPERB3)
              CALL IDPOST(IACON1,NB,LBOX3,NSPACE,MSTA,IDIM,X,NX,LBST,
     *                  LBNDET(1,IGB3),IACON2,JPOSB3)
              IPER3 = (-1)**(JPERB3+JPERB)
              KBPOS3 = JPOSB3 + NIBS3
              JPZB3 = LSPB(KBPOS3)
C
                 JMA=MAX(JJ3,IO3)
                 JMI=MIN(JJ3,IO3)
                 I2 = INDEX(JMA) + JMI
                 INX = INDEX(I2) + IND
                 II1 = INDEX(JJ3) + IO1
                 JMA=MAX(IO3,JJ)
                 JMI=MIN(IO3,JJ)
                 II2 = INDEX(JMA) + JMI
                 JMA=MAX(II1,II2)
                 JMI=MIN(II1,II2)
                 INX2 = INDEX(JMA) + JMI
                 C = SI2(INX) - SI2(INX2)
                 T = C*IPER3
C
C  LOOP OVER ALPHA STRINGS OF RIGHT SYMMETRY AND GROUP.
C
              DO 6700 IGA=1,ITGA
              IF (LGCOM(IGB,IGA).NE.1.OR.LGCOM(IGB3,IGA).NE.1) GOTO 6700
              JCIB1 = JPZB1 + LDISB(KBSYM,IGB,IGA)
              JCIB3 = JPZB3 + LDISB(KBSYM,IGB3,IGA)
              NIAS = NAST(IGA)
C
              DO 6680 KKA=LSAS(KSYM,IGA),LSAS(KSYM+1,IGA)-1
                 IENA3 = LSAC(KKA)
                 JCIA = LSPA(NIAS+IENA3)
                 JCI1 = JCIA + JCIB1
                 JCI3 = JCIA + JCIB3
C
                 DO 85 KJ=1,NV
                 AB(JCI1,KJ) = AB(JCI1,KJ) + T*CI(JCI3,KJ)
                 AB(JCI3,KJ) = AB(JCI3,KJ) + T*CI(JCI1,KJ)
   85            CONTINUE
C
 6680         CONTINUE
C
 6700         CONTINUE
C
 6820                CONTINUE
C
                     ISTA3 = IBCON2(IGAP3)+1
                     IEND3 = IBCON2(IGAP3+1)-1
                     IF (IGAP3.EQ.IGBE3) IEND3=MSTA(ISPB4+1)-1
 6830             CONTINUE
C
 6840             LBOX3(ISPB4) = LBOX3(ISPB4) - 1
 6850             CONTINUE
C
 6880          CONTINUE
C
               LBOX3(ISPB3) = LBOX3(ISPB3)+1
 6887          IBES3 = IBES3 + LBOX3(ISPB3)
 6890       CONTINUE
C
C  --- END OF LOOP OVER DOUBLE BETA EXCITATIONS.
C
 7850                CONTINUE
C
                  ISTA = IBCON1(IGAP)+1
                  IEND = IBCON1(IGAP+1)-1
                  IF (IGAP.EQ.IGBE) IEND=MSTA(ISPB2+1)-1
 7860             CONTINUE
C
 7870             LBOX2(ISPB2) = LBOX2(ISPB2) - 1
 7880          CONTINUE
C
 7885          CONTINUE
C
               LBOX2(ISPB1) = LBOX2(ISPB1)+1
 7890       CONTINUE
C
            CALL MOVEUP2(LBOX1,NSPACE,NB,MSTA,IBCON1)
 7900    CONTINUE
C
         CALL PUSHCO(LBOX1,NSPACE,NB,IBMA,IBMI,LBOX5,IEND)
 8000 CONTINUE
C
C  --- END OF LOOP OVER BETA STRINGS. ---
C
C
C   NOW FOR THE DIAGONAL CONTRIBUTIONS
C
      DO 119 IJK=1,NCI
         DO 118 KJ=1,NV
           AB(IJK,KJ) = AB(IJK,KJ) + Q(IJK)*CI(IJK,KJ)
  118    CONTINUE
  119 CONTINUE
C
C  ALL DONE, RETURN
C
      RETURN
      END
C
C*MODULE ORMAS1  *DECK FCHC01S
C     ------------------------------------------------------------------
      SUBROUTINE FCHC01S(SI1,SI2,INDEX,NACT,NA,NB,CI,AB,Q,NCI,X,NX,
     *           IACON1,IACON2,IBCON1,IBCON2,
     *           LBOX1,LBOX2,LBOX3,LBOX4,LBOX5,
     *           NSYM,IOB,LGMUL,KTAB,
     *           LANDET,LBNDET,NAST,NBST,LSYMA,LGCOM,
     *           LSPA,LSPB,LDISB,LSBS,LSBC,
     *           ITGA,ITGB,IAST,IBST,
     *           IPOSA,IPERA,IIND1,IGROA,IMMC,
     *           NB1EX,JB1GR,JB1PE,JB1IN,JB1PO,JB1ST,IDIM1,IDIM2,
     *           ISPIN,IHMCON)
C     ------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL FDIRCT,QCORR
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      COMMON /FCCWFN/ NSPACE,MSTA(51),MNUM(51),MINI(51),MAXI(51),
     *                IAMI(51),IAMA(51),IBMI(51),IBMA(51),IDIM(51),
     *                LBST(51),NREF0,FDIRCT,QCORR,C0SQ
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      DIMENSION SI1(*),SI2(*)
      DIMENSION INDEX((NACT*(NACT+1))/2+1)
      DIMENSION CI(NCI),AB(NCI),Q(NCI),X(NX)
      DIMENSION IACON1(NA),IACON2(NA),IBCON1(NA),IBCON2(NA)
      DIMENSION LBOX1(NSPACE),LBOX2(NSPACE),LBOX3(NSPACE)
      DIMENSION LBOX4(NSPACE),LBOX5(NSPACE)
      DIMENSION IOB(NACT),LGMUL(NSYM,NSYM),KTAB(NSYM)
      DIMENSION LANDET(NSPACE,ITGA),LBNDET(NSPACE,ITGB)
      DIMENSION NAST(ITGA+1),NBST(ITGB+1)
      DIMENSION LSYMA(IAST),LGCOM(ITGB,ITGA)
      DIMENSION LSPA(IAST),LSPB(IBST),LDISB(NSYM,ITGB,ITGA)
      DIMENSION LSBS(NSYM+1,ITGB)
      DIMENSION LSBC(IBST)
      DIMENSION IPOSA(NA*(NACT-NA),NSYM)
      DIMENSION IPERA(NA*(NACT-NA),NSYM)
      DIMENSION IIND1(NA*(NACT-NA),NSYM)
      DIMENSION IGROA(NA*(NACT-NA),NSYM)
      DIMENSION IMMC(NSYM)
      DIMENSION JB1GR(NB1EX),JB1PE(NB1EX),JB1IN(NB1EX),JB1PO(NB1EX)
      DIMENSION JB1ST(IDIM1,IDIM2)
      DIMENSION ISPIN(*),IHMCON(1)
C
      DO II=1,NCI
          AB(II) = 0.0D+00
      ENDDO
C
C  --- BIG LOOP OVER ALL ALPHA STRINGS. ---
C
      IF (GOPARR) THEN
         CALL DDI_DLBRESET()
         CALL DDI_DLBNEXT(MY_TASK)
      ENDIF
C
      CALL RESETCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX5)
C
      DO 5000 IGA=1,ITGA
C
         CALL RESETDE(LBOX1,NSPACE,NA,MSTA,IACON1)
C
C  KKA GIVES THE ACTUAL POSITION OF THE ALPHA STRING IACON1 IN
C  THE FULL ALPHA STRING LIST.
C
         DO 4900 KKA=NAST(IGA)+1,NAST(IGA+1)
            IF (GOPARR.AND.KKA-1.NE.MY_TASK) GOTO 4899
            ILIMA = KKA-NAST(IGA)
            JPZA1 = LSPA(KKA)
            JASYM = LSYMA(KKA)
            KSYM=KTAB(JASYM)
            DO II=1,NSYM
               IMMC(II)=0
            ENDDO
C
            DO II=1,NSPACE
               LBOX2(II) = LBOX1(II)
            ENDDO
C
C  LOOP OVER SPACES TO EXCITE ELECTRON FROM.
C
            IEAS = NA+1
            DO 4890 ISPA1=NSPACE,1,-1
               IOC1 = LBOX1(ISPA1)
               IEAE = IEAS - 1
               IEAS = IEAS - IOC1
               IF (IOC1.EQ.0) GOTO 4890
               LBOX2(ISPA1) = LBOX2(ISPA1)-1
C
C  LOOP ELECTRONS IN SPACE ISPA1.
C  IEAS, IEAE ARE THE ELECTRONS IN SPACE ISPA1.
C
               DO 4885 IA1=IEAE,IEAS,-1
                  IO1 = IACON1(IA1)
                  IGAE = IEAE - LBOX1(ISPA1)
                  IS1 = IOB(IO1)
C
C  LOOP OVER POSSIBLE SPACES TO EXCITE INTO.
C
               DO 4880 ISPA2=ISPA1,NSPACE
C
C  IGAS, IGAE ARE ELECTRONS SPECIFYING ISPA2 SPACE ELECTRON LIMITS.
C
                  IGAS = IGAE + 1
                  IGAE = IGAE + LBOX1(ISPA2)
C
                  LBOX2(ISPA2) = LBOX2(ISPA2) + 1
                  IF (LBOX2(ISPA1).LT.IAMI(ISPA1)) GOTO 4870
C
C  MAKE GAP INFORMATION HERE.
C
                  IGAA = MAX(IA1+1,IGAS)
                  IF (LBOX1(ISPA2).EQ.0) THEN
                     ISTA = MSTA(ISPA2)
                     IEND = MSTA(ISPA2+1)-1
                  ELSEIF (ISPA2.EQ.ISPA1) THEN
                     ISTA = IO1+1
                     IEND = IACON1(IGAA)-1
                     IF (IA1.EQ.IEAE) IEND=MSTA(ISPA1+1)-1
                  ELSE
                     ISTA = MSTA(ISPA2)
                     IEND = IACON1(IGAA)-1
                  ENDIF
C
C  LOOP OVER GAPS
C
                  DO 4860 IGAP=IGAA,IGAE+1
C
                     DO 4850 JJ=ISTA,IEND
                        IS2 = IOB(JJ)
                        IP1 = LGMUL(IS1,IS2)
C
                     IND = INDEX(JJ) + IO1
C
              CALL REDE00(IACON1,IACON2,NA,IA1,IGAP-1,JJ,JPERA)
                  IF (LBOX2(ISPA2).GT.IAMA(ISPA2)) GOTO 4800
C
C  GET GROUP NUMBER
C
               CALL POSITCO(LBOX5,NSPACE,NA,IAMA,IAMI,LBOX4,LBOX2,IGA2)
               NIAS = NAST(IGA2)
C
              CALL IDPOST(IACON2,NA,LBOX2,NSPACE,MSTA,IDIM,X,NX,LBST,
     *                  LANDET(1,IGA2),IBCON1,JPOSA)
              KAPOS = JPOSA + NIAS
              JPZA2 = LSPA(KAPOS)
              KASYM = LSYMA(KAPOS)
              KPER1 = (-1)**JPERA
              IMMC(KASYM) = IMMC(KASYM) + 1
              JSPO = IMMC(KASYM)
              IPOSA(JSPO,KASYM) = JPZA2
              IPERA(JSPO,KASYM) = KPER1
              IIND1(JSPO,KASYM) = IND
              IGROA(JSPO,KASYM) = IGA2
C
C   IF DEOCCUPIED AND NEWLY OCCUPIED ORBITALS ARE OF DIFFERENT SYMMETRY,
C   SKIP TO DOUBLES.
C
              IF (IS1.NE.IS2) GOTO 4800
C
C   DETERMINE THE ALPHA STRING CONTRIBUTION TO THE MATRIX ELEMENT.
C
              C = SI1(IND)
C
              DO 4712 IK=1,NA
                 IF (IK.EQ.IA1) GOTO 4712
                 ION = IACON1(IK)
                 J1 = INDEX(ION+1)
                 JMA = MAX(J1,IND)
                 JMI = MIN(J1,IND)
                 JJ1 = INDEX(JMA) + JMI
                 JMA = MAX(ION,JJ)
                 JMI = MIN(ION,JJ)
                 J1 = INDEX(JMA)+JMI
                 JMA = MAX(IO1,ION)
                 JMI = MIN(IO1,ION)
                 J2 = INDEX(JMA)+JMI
                 JMA = MAX(J1,J2)
                 JMI = MIN(J1,J2)
                 INX = INDEX(JMA)+JMI
                 C = C + SI2(JJ1) - SI2(INX)
 4712         CONTINUE
C
C  LOOP OVER BETA DETS OF THE RIGHT GROUP AND SYMMETRY.
C
              CALL RESETCO(LBOX3,NSPACE,NB,IBMA,IBMI,LBOX4)
C
              DO 4700 IGB=1,ITGB
              IF (LGCOM(IGB,IGA).NE.1.OR.LGCOM(IGB,IGA2).NE.1) GOTO 4690
              JCI1 = JPZA1 + LDISB(KSYM,IGB,IGA)
              JCI2 = JPZA2 + LDISB(KSYM,IGB,IGA2)
C
              CALL RESETDE(LBOX3,NSPACE,NB,MSTA,IBCON1)
              ISTB = 1
              DO 4680 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                 IENB = LSBC(KKB)
                 DO IIZ=ISTB,IENB-1
                    CALL MOVEUP2(LBOX3,NSPACE,NB,MSTA,IBCON1)
                 ENDDO
                 ISTB = IENB
                 JCI1 = JCI1 + 1
                 JCI2 = JCI2 + 1
C
C MATRIX ELEMENT ADDITION
C
                 D = C
                 DO 4670 IK=1,NB
                    ION = IBCON1(IK)
                    J1 = INDEX(ION+1)
                    JMA = MAX(J1,IND)
                    JMI = MIN(J1,IND)
                    JJ1 = INDEX(JMA) + JMI
                    D = D + SI2(JJ1)
 4670            CONTINUE
C
                 T = D*KPER1
                 AB(JCI1) = AB(JCI1) + T*CI(JCI2)
                 AB(JCI2) = AB(JCI2) + T*CI(JCI1)
 4680         CONTINUE
C
 4690         CALL PUSHCO(LBOX3,NSPACE,NB,IBMA,IBMI,LBOX4,IEND)
 4700         CONTINUE
C
C --  DOUBLE ALPHA EXCITATIONS START HERE  ---
C
 4800         CONTINUE
C
            IF (IA1.EQ.NA) GOTO 4850
            IF (JJ.EQ.NACT) GOTO 4850
C
            DO II=1,NSPACE
               LBOX3(II) = LBOX2(II)
            ENDDO
            IAES3 = 1
            DO KK=1,ISPA1-1
               IAES3 = IAES3 + LBOX2(KK)
            ENDDO
C
C  LOOP OVER SPACES TO EXCITE ELECTRONS FROM, MUST BE GE THAN
C  SPACE OF FIRST EXCITATION, ISPA1.
C
            DO 3890 ISPA3 = ISPA1,NSPACE
               IF (LBOX1(ISPA3).EQ.0) GOTO 3887
               IF (ISPA3.EQ.ISPA1.AND.IA1.EQ.IEAE) GOTO 3887
               IOC3 = LBOX2(ISPA3)
               IF (IOC3.EQ.0) GOTO 3887
C
               IAEE3 = IAES3 + LBOX2(ISPA3)-1
               LBOX3(ISPA3) = LBOX3(ISPA3)-1
C
C  LOOP OVER ELECTRONS IN ISPA3, WHICH ARE LARGER THAN IA1,
C  MAKING SURE IT ISN'T THE ALREADY EXCITED ELECTRON.
C
               JSTA3 = IAES3
               IF (ISPA3.EQ.ISPA1) THEN
                  JSTA3=IA1
                  IF (IGAP-1.EQ.IA1) JSTA3=JSTA3+1
               ENDIF
C
               DO 3880 IA3=JSTA3,IAEE3
                  IF (IA3.EQ.IGAP-1) GOTO 3880
                  IO3 = IACON2(IA3)
                  IS3 = IOB(IO3)
C
C  LOOP OVER SPACES TO EXCITE ELECTRON INTO.  MUST BE GE THAN
C  SPACE FIRST ELECTRON WAS EXCITED INTO.
C
                  IGAE3 = 0
                  DO JIK=1,ISPA2-1
                     IGAE3 = IGAE3 + LBOX2(JIK)
                  ENDDO
                  DO 3850 ISPA4=ISPA2,NSPACE
C
C  IGAS3, IGAE3 ARE ELECTRONS SPECIFYING ISPA4 SPACE ELECTRON LIMITS.
C
                  LBOX3(ISPA4) = LBOX3(ISPA4) + 1
                  IGAS3 = IGAE3 + 1
                  IGAE3 = IGAE3 + LBOX2(ISPA4)
                  IF (LBOX3(ISPA3).LT.IAMI(ISPA3)) GOTO 3840
                  IF (LBOX3(ISPA4).GT.IAMA(ISPA4)) GOTO 3840
                  IF (LBOX3(ISPA2).LT.IAMI(ISPA2)) GOTO 3840
                  IF (LBOX3(ISPA2).GT.IAMA(ISPA2)) GOTO 3840
C
             IF (ISPA4.EQ.ISPA2.AND.JJ.EQ.MSTA(ISPA2+1)-1) GOTO 3840
C
C  GET GROUP NUMBER
C
               CALL POSITCO(LBOX5,NSPACE,NA,IAMA,IAMI,LBOX4,LBOX3,IGA3)
               NIAS3 = NAST(IGA3)
C
C  MAKE GAP INFORMATION HERE.
C
                  IGAA3 = MAX(IGAS3,IGAP)
C
                  IF (LBOX2(ISPA4).EQ.0) THEN
                     ISTA3 = MSTA(ISPA4)
                     IEND3 = MSTA(ISPA4+1)-1
                  ELSEIF (ISPA4.EQ.ISPA2) THEN
                     ISTA3 = JJ+1
                     IEND3 = IACON2(IGAA3)-1
C
C  I AM SUSPECT ABOUT THIS NEXT LINE, WE'LL SEE WHAT HAPPENS.......
C
                     IF (IGAP-1.EQ.IGAE3) IEND3=MSTA(ISPA2+1)-1
C
                  ELSE
                     ISTA3 = MSTA(ISPA4)
                     IEND3 = IACON2(IGAA3)-1
                  ENDIF
C
C  LOOP OVER GAPS
C
                  DO 3830 IGAP3=IGAA3,IGAE3+1
C
                     DO 3820 JJ3=ISTA3,IEND3
                        IS4 = IOB(JJ3)
                        IP2 = LGMUL(IS3,IS4)
                        IF (IP1.NE.IP2) GOTO 3820
C
              CALL REDE00(IACON2,IBCON1,NA,IA3,IGAP3-1,JJ3,JPERA3)
              CALL IDPOST(IBCON1,NA,LBOX3,NSPACE,MSTA,IDIM,X,NX,LBST,
     *                  LANDET(1,IGA3),IBCON2,JPOSA3)
              IPER3 = (-1)**(JPERA3+JPERA)
              KAPOS3 = JPOSA3 + NIAS3
              JPZA3 = LSPA(KAPOS3)
                 JMA=MAX(JJ3,IO3)
                 JMI=MIN(JJ3,IO3)
                 I2 = INDEX(JMA) + JMI
                 INX = INDEX(I2) + IND
                 II1 = INDEX(JJ3) + IO1
                 JMA=MAX(IO3,JJ)
                 JMI=MIN(IO3,JJ)
                 II2 = INDEX(JMA) + JMI
                 JMA=MAX(II1,II2)
                 JMI=MIN(II1,II2)
                 INX2 = INDEX(JMA) + JMI
                 C = SI2(INX) - SI2(INX2)
                 T = C*IPER3
C
C  LOOP OVER BETA STRINGS OF RIGHT SYMMETRY AND GROUP.
C
              DO 3700 IGB=1,ITGB
              IF (LGCOM(IGB,IGA).NE.1.OR.LGCOM(IGB,IGA3).NE.1) GOTO 3700
              JCI1 = JPZA1 + LDISB(KSYM,IGB,IGA)
              JCI3 = JPZA3 + LDISB(KSYM,IGB,IGA3)
C
              DO 3680 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                 JCI1 = JCI1 + 1
                 JCI3 = JCI3 + 1
                 AB(JCI1) = AB(JCI1) + T*CI(JCI3)
                 AB(JCI3) = AB(JCI3) + T*CI(JCI1)
 3680         CONTINUE
C
 3700         CONTINUE
C
 3820                CONTINUE
C
                     ISTA3 = IACON2(IGAP3)+1
                     IEND3 = IACON2(IGAP3+1)-1
                     IF (IGAP3.EQ.IGAE3) IEND3=MSTA(ISPA4+1)-1
 3830             CONTINUE
C
 3840             LBOX3(ISPA4) = LBOX3(ISPA4) - 1
 3850             CONTINUE
C
 3880          CONTINUE
C
               LBOX3(ISPA3) = LBOX3(ISPA3)+1
 3887          IAES3 = IAES3 + LBOX3(ISPA3)
 3890       CONTINUE
C
 4850                CONTINUE
C
                  ISTA = IACON1(IGAP)+1
                  IEND = IACON1(IGAP+1)-1
                  IF (IGAP.EQ.IGAE) IEND=MSTA(ISPA2+1)-1
 4860             CONTINUE
C
 4870             LBOX2(ISPA2) = LBOX2(ISPA2) - 1
 4880          CONTINUE
C
 4885          CONTINUE
C
               LBOX2(ISPA1) = LBOX2(ISPA1)+1
 4890       CONTINUE
C
C
C  --- END OF LOOP OVER SINGLE ALPHA EXCITATIONS. ---
C      NOW TO SORT THEM BY POSITIONS WITHIN SYMMETRIES.
C
            DO II=1,NSYM
               CALL FCCSRT3(IGROA(1,II),IPERA(1,II),IIND1(1,II),
     *                   IPOSA(1,II),IMMC(II))
            ENDDO
C
C  --- END OF LOOP OVER PURE ALPHA EXCITATIONS.
C  NOW TO LOOP OVER ALL SIMULTANEOUS AB -> A'B' EXCITATIONS.
C
      IF (NSPACE.EQ.1) GOTO 3400
C
C  ***** GENERAL CASE OF MORE THAN ONE SPACE !!!!! *******
C
      IF (.NOT.FDIRCT) THEN
C
C  LOOP OVER SINGLE ALPHA EXCITES WITHIN EACH SYMMETRY.
C
      DO 3000 ISAE=1,NSYM
         KBSYM=KTAB(ISAE)
C
         DO 2900 JSAE=1,IMMC(ISAE)
            JPOSAE=IPOSA(JSAE,ISAE)
            JPERAE=IPERA(JSAE,ISAE)
            JINDAE=IIND1(JSAE,ISAE)
            JGROAE=IGROA(JSAE,ISAE)
C
C  IF ISAE.EQ.JASYM THEN SPECIAL CASE.
C
       IF (ISAE.EQ.JASYM.AND.IGA.EQ.JGROAE) THEN
C
C  LOOP OVER ALL RELEVANT BETAS
C
            DO 2813 IGB=IGA,ITGB
               IF (LGCOM(IGB,IGA).NE.1) GOTO 2813
               LAB1 = JPZA1 + LDISB(KSYM,IGB,IGA)
               LAB2 = JPOSAE + LDISB(KSYM,IGB,IGA)
               NIBS = NBST(IGB)
               DO 2763 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                  IBPOS = NIBS + LSBC(KKB)
                  IF (IBPOS.LT.KKA) GOTO 2763
                  LABPOS = LAB1 + LSPB(IBPOS)
                  LABPOS2 = LAB2 + LSPB(IBPOS)
                  QJMODA=JPERAE
                  IF (IBPOS.EQ.KKA) QJMODA=JPERAE/2.0D+00
C
C  LOOP OVER SINGLE BETA EXCITES FROM IBPOS
C
               DO 2613 JBINDX=JB1ST(KBSYM,IBPOS),JB1ST(KBSYM+1,IBPOS)-1
                  IGB2=JB1GR(JBINDX)
                  IF (LGCOM(IGB2,JGROAE).NE.1) GOTO 2613
C
                  JMA=MAX(JINDAE,JB1IN(JBINDX))
                  JMI=MIN(JINDAE,JB1IN(JBINDX))
                  IX=INDEX(JMA)+JMI
                  C = SI2(IX)*QJMODA*JB1PE(JBINDX)
                  JCIB=JPOSAE+LDISB(KBSYM,IGB2,JGROAE)+JB1PO(JBINDX)
                  JCIB2=JPZA1+LDISB(KBSYM,IGB2,JGROAE)+JB1PO(JBINDX)
C
                  AB(LABPOS) = AB(LABPOS) + C*CI(JCIB)
                  AB(JCIB) = AB(JCIB) + C*CI(LABPOS)
                  AB(LABPOS2) = AB(LABPOS2) + C*CI(JCIB2)
                  AB(JCIB2) = AB(JCIB2) + C*CI(LABPOS2)
C
 2613          CONTINUE
C
 2763          CONTINUE
 2813       CONTINUE
C
       ELSE
C
C  LOOP OVER ALL RELEVANT (A-)BETA DETS.
C
            DO 2800 IGB=IGA,ITGB
               IF (LGCOM(IGB,IGA).NE.1) GOTO 2800
               LAB1 = JPZA1 + LDISB(KSYM,IGB,IGA)
               NIBS = NBST(IGB)
               DO 2750 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                  IBPOS = NIBS + LSBC(KKB)
                  IF (IBPOS.LT.KKA) GOTO 2750
                  LABPOS = LAB1 + LSPB(IBPOS)
                  QJMODA = JPERAE
                  IF (IBPOS.EQ.KKA) QJMODA=JPERAE/2.0D+00
C
C  LOOP OVER SINGLE BETA EXCITES FROM IBPOS
C
               DO 2600 JBINDX=JB1ST(KBSYM,IBPOS),JB1ST(KBSYM+1,IBPOS)-1
                  IGB2=JB1GR(JBINDX)
                  IF (LGCOM(IGB2,JGROAE).NE.1) GOTO 2600
C
                  JMA=MAX(JINDAE,JB1IN(JBINDX))
                  JMI=MIN(JINDAE,JB1IN(JBINDX))
                  IX=INDEX(JMA)+JMI
                  C = SI2(IX)*QJMODA*JB1PE(JBINDX)
                  JCIB=JPOSAE+LDISB(KBSYM,IGB2,JGROAE)+JB1PO(JBINDX)
C
                  AB(LABPOS) = AB(LABPOS) + C*CI(JCIB)
                  AB(JCIB) = AB(JCIB) + C*CI(LABPOS)
C
 2600          CONTINUE
C
 2750          CONTINUE
 2800       CONTINUE
C
C  LOOP OVER ALL RELEVANT (A'-)BETA DETS.
C
            DO 2803 IGB=IGA,ITGB
               IF (LGCOM(IGB,JGROAE).NE.1) GOTO 2803
               LAB1 = JPOSAE + LDISB(KBSYM,IGB,JGROAE)
               NIBS = NBST(IGB)
               DO 2753 KKB=LSBS(KBSYM,IGB),LSBS(KBSYM+1,IGB)-1
                  IBPOS = NIBS + LSBC(KKB)
                  IF (IBPOS.LT.KKA) GOTO 2753
                  LABPOS = LAB1 + LSPB(IBPOS)
                  QJMODA = JPERAE
                  IF (IBPOS.EQ.KKA) QJMODA=JPERAE/2.0D+00
C
C  LOOP OVER SINGLE BETA EXCITES FROM IBPOS
C
               DO 2603 JBINDX=JB1ST(KSYM,IBPOS),JB1ST(KSYM+1,IBPOS)-1
                  IGB2=JB1GR(JBINDX)
                  IF (LGCOM(IGB2,IGA).NE.1) GOTO 2603
C
                  JMA=MAX(JINDAE,JB1IN(JBINDX))
                  JMI=MIN(JINDAE,JB1IN(JBINDX))
                  IX=INDEX(JMA)+JMI
                  C = SI2(IX)*QJMODA*JB1PE(JBINDX)
                  JCIB=JPZA1+LDISB(KSYM,IGB2,IGA)+JB1PO(JBINDX)
C
                  AB(LABPOS) = AB(LABPOS) + C*CI(JCIB)
                  AB(JCIB) = AB(JCIB) + C*CI(LABPOS)
C
 2603          CONTINUE
C
 2753          CONTINUE
 2803       CONTINUE
C
      ENDIF
C
 2900    CONTINUE
 3000 CONTINUE
C
      ELSE
C
C   ***** DIRECT METHOD BELOW *****
C
      DO 4000 ISAE=1,NSYM
         KBSYM = KTAB(ISAE)
C
C  ANALYSE EXCITED A' GROUPS FOR COMPATIBILITY WITH B.
C
      NGRPS = 0
      DO 1976 II=1,IMMC(ISAE)
         ICGR = IGROA(II,ISAE)
         DO JJ=1,NGRPS
            IF (JB1GR(JJ).EQ.ICGR) GOTO 1976
         ENDDO
         NGRPS = NGRPS + 1
         JB1GR(NGRPS) = ICGR
 1976 CONTINUE
C
C FIRST TYPE OF BETAS, KSYM -> KBSYM
C
          CALL RESETCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3)
          DO 7400 IGB=1,ITGB
             IF (IGB.LT.IGA) GOTO 7399
             IF (LGCOM(IGB,IGA).NE.1) GOTO 7399
             LAB1 = JPZA1 + LDISB(KSYM,IGB,IGA)
C
             CALL RESETDE(LBOX2,NSPACE,NB,MSTA,IBCON1)
             NIBS = NBST(IGB)
             ISTB = 1
             DO 7300 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                IENB = LSBC(KKB)
                DO IIZ=ISTB,IENB-1
                   CALL MOVEUP2(LBOX2,NSPACE,NB,MSTA,IBCON1)
                ENDDO
                ISTB = IENB
C
                IBPOS = NIBS + LSBC(KKB)
                IF (IBPOS.LT.KKA) GOTO 7300
                LABPOS = LAB1 + LSPB(IBPOS)
                QJMODA=1.0D+00
                IF (IBPOS.EQ.KKA) QJMODA=0.5D+00
C
C LOOP OVER SINGLE BETA EXCITES FROM IBPOS WHICH ARE OF SYMMETRY KBSYM
C
                MESYM1 = LGMUL(KSYM,KBSYM)
                DO II=1,NSPACE
                   LBOX3(II) = LBOX2(II)
                ENDDO
                IEBS = NB + 1
                DO 7290 ISPB1=NSPACE,1,-1
                   IOC1 = LBOX2(ISPB1)
                   IEBE = IEBS - 1
                   IEBS = IEBS - IOC1
                   IF (IOC1.EQ.0) GO TO 7290
                   LBOX3(ISPB1) = LBOX3(ISPB1)-1
C
C  LOOP ELECTRONS IN SPACE ISPB1
C  IEBS, IEBE ARE THE ELECTRONS IN SPACE ISPB1
C
                DO 7285 IB1 = IEBE,IEBS,-1
                   IO1 = IBCON1(IB1)
                   MESYM2 = LGMUL(MESYM1,IOB(IO1))
                   IGBE = IEBE - LBOX2(ISPB1)
C
C  LOOP OVER POSSIBLE SPACES TO EXCITE INTO.
C
                DO 7280 ISPB2=ISPB1,NSPACE
C
C  IGBS,IGBE ARE ELECTRONS SPECIFYING ISPB2 SPACE ELECTRON LIMITS.
C
                   IGBS = IGBE + 1
                   IGBE = IGBE + LBOX2(ISPB2)
C
                   LBOX3(ISPB2) = LBOX3(ISPB2) + 1
                   IF (LBOX3(ISPB1).LT.IBMI(ISPB1)) GO TO 7270
                   IF (LBOX3(ISPB2).GT.IBMA(ISPB2)) GO TO 7270
C
C  GET GROUP NUMBER
C
          CALL POSITCO(LBOX5,NSPACE,NB,IBMA,IBMI,LBOX4,LBOX3,IGB2)
          NIAS = NBST(IGB2)
C
C CHECK FOR A' GROUP COMPATIBILITY
C
             DO II=1,NGRPS
                IAGRP = JB1GR(II)
                IF (LGCOM(IGB2,IAGRP).EQ.1) GOTO 7555
             ENDDO
             GOTO 7270
 7555        CONTINUE
C
C  MAKE GAP INFORMATION HERE.
C
                  IGBA = MAX(IB1+1,IGBS)
                  IF (LBOX2(ISPB2).EQ.0) THEN
                     ISTA = MSTA(ISPB2)
                     IEND = MSTA(ISPB2+1)-1
                  ELSEIF (ISPB2.EQ.ISPB1) THEN
                     ISTA = IO1+1
                     IEND = IBCON1(IGBA)-1
                     IF (IB1.EQ.IEBE) IEND=MSTA(ISPB1+1)-1
                  ELSE
                     ISTA = MSTA(ISPB2)
                     IEND = IBCON1(IGBA)-1
                  ENDIF
C
C  LOOP OVER GAPS
C
                  DO 7260 IGAP=IGBA,IGBE+1
C
                     DO 7250 JJ=ISTA,IEND
C
C CHECK TO SEE IF EXCITED BETA IS OF RIGHT SYMMETRY (KBSYM)
C
            IF (IOB(JJ).NE.MESYM2) GOTO 7250
C
            IND1 = INDEX(JJ) + IO1
            CALL REDE00(IBCON1,IBCON2,NB,IB1,IGAP-1,JJ,IPER)
            CALL IDPOST(IBCON2,NB,LBOX3,NSPACE,MSTA,IDIM,X,NX,LBST,
     *                  LBNDET(1,IGB2),IACON2,IPOSB)
            QJPER = ((-1)**IPER)*QJMODA
            JB1P = LSPB(IPOSB + NIAS)
C
            DO 3900 JSAE=1,IMMC(ISAE)
               JGROAE=IGROA(JSAE,ISAE)
               IF (LGCOM(IGB2,JGROAE).NE.1) GOTO 3900
C
               JPOSAE=IPOSA(JSAE,ISAE)
               JCIB = JB1P + JPOSAE + LDISB(KBSYM,IGB2,JGROAE)
C
               JINDAE=IIND1(JSAE,ISAE)
               JMA=MAX(JINDAE,IND1)
               JMI=MIN(JINDAE,IND1)
               IX=INDEX(JMA)+JMI
C
               JPERAE=IPERA(JSAE,ISAE)
               C = SI2(IX)*QJPER*JPERAE
C
            AB(LABPOS) = AB(LABPOS) + C*CI(JCIB)
            AB(JCIB) = AB(JCIB) + C*CI(LABPOS)
C
 3900       CONTINUE
C
 7250                CONTINUE
C
                  ISTA = IBCON1(IGAP)+1
                  IEND = IBCON1(IGAP+1)-1
                  IF (IGAP.EQ.IGBE) IEND=MSTA(ISPB2+1)-1
 7260             CONTINUE
C
 7270              LBOX3(ISPB2) = LBOX3(ISPB2) - 1
 7280           CONTINUE
C
 7285           CONTINUE
C
                   LBOX3(ISPB1) = LBOX3(ISPB1) + 1
 7290           CONTINUE
C
 7300        CONTINUE
C
 7399        CALL PUSHCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3,IEND)
 7400     CONTINUE
C
C
C SECOND TYPE OF BETAS, KBSYM -> KSYM
C
          CALL RESETCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3)
          DO 7800 IGB=1,ITGB
             IF (IGB.LT.IGA) GOTO 7799
C
C CHECK FOR A' GROUP COMPATIBILITY
C
             DO II=1,NGRPS
                IAGRP = JB1GR(II)
                IF (LGCOM(IGB,IAGRP).EQ.1) GOTO 7655
             ENDDO
             GOTO 7799
 7655        CONTINUE
C
C INSERT CHECK FOR A'B GROUP COMPATIBILITY.
C
             CALL RESETDE(LBOX2,NSPACE,NB,MSTA,IBCON1)
             NIBS = NBST(IGB)
             ISTB = 1
C
             DO 7700 KKB=LSBS(KBSYM,IGB),LSBS(KBSYM+1,IGB)-1
                IENB = LSBC(KKB)
                DO IIZ=ISTB,IENB-1
                   CALL MOVEUP2(LBOX2,NSPACE,NB,MSTA,IBCON1)
                ENDDO
                ISTB = IENB
C
                IBPOS = NIBS + LSBC(KKB)
                IF (IBPOS.LT.KKA) GOTO 7700
                LAB1 = LSPB(IBPOS)
                QJMODA=1.0D+00
                IF (IBPOS.EQ.KKA) QJMODA=0.5D+00
C
C
C LOOP OVER SINGLE BETA EXCITES FROM IBPOS WHICH ARE OF SYMMETRY KSYM
C
                MESYM1 = LGMUL(KSYM,KBSYM)
                DO II=1,NSPACE
                   LBOX3(II) = LBOX2(II)
                ENDDO
                IEBS = NB + 1
                DO 7690 ISPB1=NSPACE,1,-1
                   IOC1 = LBOX2(ISPB1)
                   IEBE = IEBS - 1
                   IEBS = IEBS - IOC1
                   IF (IOC1.EQ.0) GO TO 7690
                   LBOX3(ISPB1) = LBOX3(ISPB1)-1
C
C  LOOP ELECTRONS IN SPACE ISPB1
C  IEBS, IEBE ARE THE ELECTRONS IN SPACE ISPB1
C
                DO 7685 IB1 = IEBE,IEBS,-1
                   IO1 = IBCON1(IB1)
                   MESYM2 = LGMUL(MESYM1,IOB(IO1))
                   IGBE = IEBE - LBOX2(ISPB1)
C
C  LOOP OVER POSSIBLE SPACES TO EXCITE INTO.
C
                DO 7680 ISPB2=ISPB1,NSPACE
C
C  IGBS,IGBE ARE ELECTRONS SPECIFYING ISPB2 SPACE ELECTRON LIMITS.
C
                   IGBS = IGBE + 1
                   IGBE = IGBE + LBOX2(ISPB2)
C
                   LBOX3(ISPB2) = LBOX3(ISPB2) + 1
                   IF (LBOX3(ISPB1).LT.IBMI(ISPB1)) GO TO 7670
                   IF (LBOX3(ISPB2).GT.IBMA(ISPB2)) GO TO 7670
C
          CALL POSITCO(LBOX5,NSPACE,NB,IBMA,IBMI,LBOX4,LBOX3,IGB2)
          IF (LGCOM(IGB2,IGA).NE.1) GOTO 7670
          JCIBS = JPZA1 + LDISB(KSYM,IGB2,IGA)
          NIAS = NBST(IGB2)
C
C  MAKE GAP INFORMATION HERE.
C
                  IGBA = MAX(IB1+1,IGBS)
                  IF (LBOX2(ISPB2).EQ.0) THEN
                     ISTA = MSTA(ISPB2)
                     IEND = MSTA(ISPB2+1)-1
                  ELSEIF (ISPB2.EQ.ISPB1) THEN
                     ISTA = IO1+1
                     IEND = IBCON1(IGBA)-1
                     IF (IB1.EQ.IEBE) IEND=MSTA(ISPB1+1)-1
                  ELSE
                     ISTA = MSTA(ISPB2)
                     IEND = IBCON1(IGBA)-1
                  ENDIF
C
C  LOOP OVER GAPS
C
                  DO 7660 IGAP=IGBA,IGBE+1
C
                     DO 7650 JJ=ISTA,IEND
C
C CHECK TO SEE IF EXCITED BETA IS OF RIGHT SYMMETRY (KBSYM)
C
            IF (IOB(JJ).NE.MESYM2) GOTO 7650
C
            IND1 = INDEX(JJ) + IO1
            CALL REDE00(IBCON1,IBCON2,NB,IB1,IGAP-1,JJ,IPER)
            CALL IDPOST(IBCON2,NB,LBOX3,NSPACE,MSTA,IDIM,X,NX,LBST,
     *                  LBNDET(1,IGB2),IACON2,IPOSB)
            QJPER = ((-1)**IPER)*QJMODA
            JCIB= JCIBS + LSPB(IPOSB + NIAS)
C
            DO 4300 JSAE=1,IMMC(ISAE)
               JGROAE=IGROA(JSAE,ISAE)
               IF (LGCOM(IGB,JGROAE).NE.1) GOTO 4300
C
               JPOSAE=IPOSA(JSAE,ISAE)
               LABPOS = LAB1 + JPOSAE + LDISB(KBSYM,IGB,JGROAE)
C
               JINDAE=IIND1(JSAE,ISAE)
               JMA=MAX(JINDAE,IND1)
               JMI=MIN(JINDAE,IND1)
               IX=INDEX(JMA)+JMI
C
               JPERAE=IPERA(JSAE,ISAE)
               C = SI2(IX)*QJPER*JPERAE
C
            AB(LABPOS) = AB(LABPOS) + C*CI(JCIB)
            AB(JCIB) = AB(JCIB) + C*CI(LABPOS)
C
 4300       CONTINUE
C
 7650                CONTINUE
C
                  ISTA = IBCON1(IGAP)+1
                  IEND = IBCON1(IGAP+1)-1
                  IF (IGAP.EQ.IGBE) IEND=MSTA(ISPB2+1)-1
 7660             CONTINUE
C
 7670              LBOX3(ISPB2) = LBOX3(ISPB2) - 1
 7680           CONTINUE
C
 7685           CONTINUE
C
                   LBOX3(ISPB1) = LBOX3(ISPB1) + 1
 7690           CONTINUE
C
 7700        CONTINUE
C
 7799        CALL PUSHCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3,IEND)
 7800     CONTINUE
C
 4000 CONTINUE
C
      ENDIF
C
C ****** END OF DIRECT METHOD *******
C
C  **** END OF GENERAL CASE OF MORE THAN ONE SPACE ******
C
      GOTO 4898
C
 3400 CONTINUE
C
C ***** SPECIAL CASE OF ONE SPACE !!!!! ******
C
C  LOOP OVER SINGLE ALPHA EXCITES WITHIN EACH SYMMETRY.
C
       DO 2901 ISAE=1,NSYM
          KBSYM=KTAB(ISAE)
          DO 2801 JSAE=1,IMMC(ISAE)
                JPOSAE=IPOSA(JSAE,ISAE)
                JPERAE=IPERA(JSAE,ISAE)
                JINDAE=IIND1(JSAE,ISAE)
                JGROAE=IGROA(JSAE,ISAE)
C
C  IF ISAE.EQ.JASYM THEN SPECIAL CASE.
C
       IF (ISAE.EQ.JASYM) THEN
C
C  LOOP OVER ALL RELEVANT BETAS
C
             LABPOS=JPZA1
             LABPOS2=JPOSAE
                DO 2721 KKB=LSBS(KSYM,1),LSBS(KSYM+1,1)-1
                    LABPOS = LABPOS + 1
                    LABPOS2 = LABPOS2 + 1
                    IBPOS =  LSBC(KKB)
                    IF (IBPOS.LT.ILIMA) GOTO 2721
                    QJMODA=JPERAE
                    IF (IBPOS.EQ.ILIMA) QJMODA=JPERAE/2.0D+00
C
C  LOOP OVER SINGLE BETA EXCITES FROM IBPOS
C
               DO 2621 JBINDX=JB1ST(KSYM,IBPOS),JB1ST(KSYM+1,IBPOS)-1
                  JMA=MAX(JINDAE,JB1IN(JBINDX))
                  JMI=MIN(JINDAE,JB1IN(JBINDX))
                  IX=INDEX(JMA)+JMI
                  C = SI2(IX)*QJMODA*JB1PE(JBINDX)
                  JCIB = JPOSAE+JB1PO(JBINDX)
                  JCIB2 = JPZA1+JB1PO(JBINDX)
C
                  AB(LABPOS) = AB(LABPOS) + C*CI(JCIB)
                  AB(JCIB) = AB(JCIB) + C*CI(LABPOS)
                  AB(LABPOS2) = AB(LABPOS2) + C*CI(JCIB2)
                  AB(JCIB2) = AB(JCIB2) + C*CI(LABPOS2)
C
 2621          CONTINUE
               QJMODA=JPERAE
C
 2721          CONTINUE
C
      ELSE
C
C  LOOP OVER ALL RELEVANT (A-)BETA DETS.
C
                LABPOS = JPZA1
                DO 2751 KKB=LSBS(KSYM,1),LSBS(KSYM+1,1)-1
                    LABPOS = LABPOS + 1
                    IBPOS =  LSBC(KKB)
                    IF (IBPOS.LT.ILIMA) GOTO 2751
                    QJMODA=JPERAE
                    IF (IBPOS.EQ.ILIMA) QJMODA=JPERAE/2.0D+00
C
C  LOOP OVER SINGLE BETA EXCITES FROM IBPOS
C
               DO 2601 JBINDX=JB1ST(KBSYM,IBPOS),JB1ST(KBSYM+1,IBPOS)-1
C
                  JMA=MAX(JINDAE,JB1IN(JBINDX))
                  JMI=MIN(JINDAE,JB1IN(JBINDX))
                  IX=INDEX(JMA)+JMI
                  C = SI2(IX)*QJMODA*JB1PE(JBINDX)
                  JCIB=JPOSAE+JB1PO(JBINDX)
C
                  AB(LABPOS) = AB(LABPOS) + C*CI(JCIB)
                  AB(JCIB) = AB(JCIB) + C*CI(LABPOS)
C
 2601          CONTINUE
               QJMODA=JPERAE
C
 2751          CONTINUE
C
C  LOOP OVER ALL RELEVANT (A'-)BETA DETS.
C
               LABPOS = JPOSAE
               DO 2761 KKB=LSBS(KBSYM,1),LSBS(KBSYM+1,1)-1
                  LABPOS = LABPOS + 1
                  IBPOS = LSBC(KKB)
                  IF (IBPOS.LT.ILIMA) GOTO 2761
                  QJMODA=JPERAE
                  IF (IBPOS.EQ.ILIMA) QJMODA=JPERAE/2.0D+00
C
C  LOOP OVER SINGLE BETA EXCITES FROM IBPOS
C
               DO 2611 JBINDX=JB1ST(KSYM,IBPOS),JB1ST(KSYM+1,IBPOS)-1
C
                  JMA=MAX(JINDAE,JB1IN(JBINDX))
                  JMI=MIN(JINDAE,JB1IN(JBINDX))
                  IX=INDEX(JMA)+JMI
                  C = SI2(IX)*QJMODA*JB1PE(JBINDX)
                  JCIB=JPZA1+JB1PO(JBINDX)
C
                  AB(LABPOS) = AB(LABPOS) + C*CI(JCIB)
                  AB(JCIB) = AB(JCIB) + C*CI(LABPOS)
C
 2611          CONTINUE
               QJMODA=JPERAE
C
 2761          CONTINUE
C
      ENDIF
C
 2801       CONTINUE
 2901   CONTINUE
C
C  **** END OF SPECIAL CASE OF ONE SPACE *******
C
 4898       CONTINUE
            IF (GOPARR) CALL DDI_DLBNEXT(MY_TASK)
 4899       CONTINUE
            CALL MOVEUP2(LBOX1,NSPACE,NA,MSTA,IACON1)
 4900    CONTINUE
C
         CALL PUSHCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX5,IEND)
 5000 CONTINUE
C
C  --- END OF LOOP OVER ALPHA STRINGS. ---
C
      IF (GOPARR) THEN
         CALL DDI_DLBRESET()
         CALL DDI_GSUMF(2900,AB,NCI)
      ENDIF
C
C **
C
      IS = (-1)**ISPIN(IHMCON(1))
      DO 1111 IGA=1,ITGA
         DO 1122 KKA=NAST(IGA)+1,NAST(IGA+1)
            JPZA1 = LSPA(KKA)
            JASYM = LSYMA(KKA)
            KSYM=KTAB(JASYM)
            ILIMA = KKA-NAST(IGA)
C
            DO 1133 IGB=1,IGA
            IF (LGCOM(IGB,IGA).NE.1) GOTO 1133
            ICC1 = JPZA1 + LDISB(KSYM,IGB,IGA)
            ICC2 = LDISB(JASYM,IGA,IGB) + LSPB(KKA)
            NIBS=NBST(IGB)
            DO 1144 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
               IBPOS = LSBC(KKB) + NIBS
               IF (IBPOS.GT.KKA) GOTO 1122
               ICI2 = LSPA(IBPOS) + ICC2
               IF (IBPOS.EQ.KKA) THEN
                  AB(ICI2) = AB(ICI2) + IS*AB(ICI2)
                  GOTO 1122
               ENDIF
               ICI1 = ICC1+LSPB(IBPOS)
               QT = AB(ICI1)
               AB(ICI1) = AB(ICI1) + IS*AB(ICI2)
               AB(ICI2) = AB(ICI2) + IS*QT
 1144       CONTINUE
 1133       CONTINUE
 1122    CONTINUE
 1111 CONTINUE
C
C   NOW FOR THE DIAGONAL CONTRIBUTIONS
C
      DO 119 IJK=1,NCI
         AB(IJK) = AB(IJK) + Q(IJK)*CI(IJK)
  119 CONTINUE
C
C  ALL DONE, RETURN
C
      RETURN
      END
C
C*MODULE ORMAS1  *DECK FCHC0YS
C     ------------------------------------------------------------------
      SUBROUTINE FCHC0YS(SI1,SI2,INDEX,NACT,NA,NB,CI,AB,NV,Q,NCI,X,NX,
     *           IACON1,IACON2,IBCON1,IBCON2,
     *           LBOX1,LBOX2,LBOX3,LBOX4,LBOX5,
     *           NSYM,IOB,LGMUL,KTAB,
     *           LANDET,LBNDET,NAST,NBST,LSYMA,LGCOM,
     *           LSPA,LSPB,LDISB,LSBS,LSBC,
     *           ITGA,ITGB,IAST,IBST,
     *           IPOSA,IPERA,IIND1,IGROA,IMMC,
     *           NB1EX,JB1GR,JB1PE,JB1IN,JB1PO,JB1ST,
     *           ISPIN,IHMCON)
C     ------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL FDIRCT,QCORR
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      COMMON /FCCWFN/ NSPACE,MSTA(51),MNUM(51),MINI(51),MAXI(51),
     *                IAMI(51),IAMA(51),IBMI(51),IBMA(51),IDIM(51),
     *                LBST(51),NREF0,FDIRCT,QCORR,C0SQ
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      DIMENSION SI1(*),SI2(*)
      DIMENSION INDEX((NACT*(NACT+1))/2+1)
      DIMENSION CI(NCI,NV),AB(NCI,NV),Q(NCI),X(NX)
      DIMENSION IACON1(NA),IACON2(NA),IBCON1(NA),IBCON2(NA)
      DIMENSION LBOX1(NSPACE),LBOX2(NSPACE),LBOX3(NSPACE)
      DIMENSION LBOX4(NSPACE),LBOX5(NSPACE)
      DIMENSION IOB(NACT),LGMUL(NSYM,NSYM),KTAB(NSYM)
      DIMENSION LANDET(NSPACE,ITGA),LBNDET(NSPACE,ITGB)
      DIMENSION NAST(ITGA+1),NBST(ITGB+1)
      DIMENSION LSYMA(IAST),LGCOM(ITGB,ITGA)
      DIMENSION LSPA(IAST),LSPB(IBST),LDISB(NSYM,ITGB,ITGA)
      DIMENSION LSBS(NSYM+1,ITGB)
      DIMENSION LSBC(IBST)
      DIMENSION IPOSA(NA*(NACT-NA),NSYM)
      DIMENSION IPERA(NA*(NACT-NA),NSYM)
      DIMENSION IIND1(NA*(NACT-NA),NSYM)
      DIMENSION IGROA(NA*(NACT-NA),NSYM)
      DIMENSION IMMC(NSYM)
      DIMENSION JB1GR(NB1EX),JB1PE(NB1EX),JB1IN(NB1EX),JB1PO(NB1EX)
      DIMENSION JB1ST(NSYM+1,IBST+1)
      DIMENSION ISPIN(*),IHMCON(1)
C
      DO II=1,NCI
         DO JJ=1,NV
           AB(II,JJ) = 0.0D+00
         ENDDO
      ENDDO
C
C  --- BIG LOOP OVER ALL ALPHA STRINGS. ---
C
      IF (GOPARR) THEN
         CALL DDI_DLBRESET()
         CALL DDI_DLBNEXT(MY_TASK)
      ENDIF
C
      CALL RESETCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX5)
C
      DO 5000 IGA=1,ITGA
C
         CALL RESETDE(LBOX1,NSPACE,NA,MSTA,IACON1)
C
C  KKA GIVES THE ACTUAL POSITION OF THE ALPHA STRING IACON1 IN
C  THE FULL ALPHA STRING LIST.
C
         DO 4900 KKA=NAST(IGA)+1,NAST(IGA+1)
            IF (GOPARR.AND.KKA-1.NE.MY_TASK) GOTO 4899
            ILIMA = KKA-NAST(IGA)
            JPZA1 = LSPA(KKA)
            JASYM = LSYMA(KKA)
            KSYM=KTAB(JASYM)
            DO II=1,NSYM
               IMMC(II)=0
            ENDDO
C
            DO II=1,NSPACE
               LBOX2(II) = LBOX1(II)
            ENDDO
C
C  LOOP OVER SPACES TO EXCITE ELECTRON FROM.
C
            IEAS = NA+1
            DO 4890 ISPA1=NSPACE,1,-1
               IOC1 = LBOX1(ISPA1)
               IEAE = IEAS - 1
               IEAS = IEAS - IOC1
               IF (IOC1.EQ.0) GOTO 4890
               LBOX2(ISPA1) = LBOX2(ISPA1)-1
C
C  LOOP ELECTRONS IN SPACE ISPA1.
C  IEAS, IEAE ARE THE ELECTRONS IN SPACE ISPA1.
C
               DO 4885 IA1=IEAE,IEAS,-1
                  IO1 = IACON1(IA1)
                  IGAE = IEAE - LBOX1(ISPA1)
                  IS1 = IOB(IO1)
C
C  LOOP OVER POSSIBLE SPACES TO EXCITE INTO.
C
               DO 4880 ISPA2=ISPA1,NSPACE
C
C  IGAS, IGAE ARE ELECTRONS SPECIFYING ISPA2 SPACE ELECTRON LIMITS.
C
                  IGAS = IGAE + 1
                  IGAE = IGAE + LBOX1(ISPA2)
C
                  LBOX2(ISPA2) = LBOX2(ISPA2) + 1
                  IF (LBOX2(ISPA1).LT.IAMI(ISPA1)) GOTO 4870
C
C  MAKE GAP INFORMATION HERE.
C
                  IGAA = MAX(IA1+1,IGAS)
                  IF (LBOX1(ISPA2).EQ.0) THEN
                     ISTA = MSTA(ISPA2)
                     IEND = MSTA(ISPA2+1)-1
                  ELSEIF (ISPA2.EQ.ISPA1) THEN
                     ISTA = IO1+1
                     IEND = IACON1(IGAA)-1
                     IF (IA1.EQ.IEAE) IEND=MSTA(ISPA1+1)-1
                  ELSE
                     ISTA = MSTA(ISPA2)
                     IEND = IACON1(IGAA)-1
                  ENDIF
C
C  LOOP OVER GAPS
C
                  DO 4860 IGAP=IGAA,IGAE+1
C
                     DO 4850 JJ=ISTA,IEND
                        IS2 = IOB(JJ)
                        IP1 = LGMUL(IS1,IS2)
C
                     IND = INDEX(JJ) + IO1
C
              CALL REDE00(IACON1,IACON2,NA,IA1,IGAP-1,JJ,JPERA)
              IF (LBOX2(ISPA2).GT.IAMA(ISPA2)) GOTO 4800
C
C  GET GROUP NUMBER
C
           CALL POSITCO(LBOX5,NSPACE,NA,IAMA,IAMI,LBOX4,LBOX2,IGA2)
           NIAS = NAST(IGA2)
C
              CALL IDPOST(IACON2,NA,LBOX2,NSPACE,MSTA,IDIM,X,NX,LBST,
     *                  LANDET(1,IGA2),IBCON1,JPOSA)
              KAPOS = JPOSA + NIAS
              JPZA2 = LSPA(KAPOS)
              KASYM = LSYMA(KAPOS)
              KPER1 = (-1)**JPERA
              IMMC(KASYM) = IMMC(KASYM) + 1
              JSPO = IMMC(KASYM)
              IPOSA(JSPO,KASYM) = JPZA2
              IPERA(JSPO,KASYM) = KPER1
              IIND1(JSPO,KASYM) = IND
              IGROA(JSPO,KASYM) = IGA2
C
C   IF DEOCCUPIED AND NEWLY OCCUPIED ORBITALS ARE OF DIFFERENT SYMMETRY,
C   SKIP TO DOUBLES.
C
              IF (IS1.NE.IS2) GOTO 4800
C
C   DETERMINE THE ALPHA STRING CONTRIBUTION TO THE MATRIX ELEMENT.
C
              C = SI1(IND)
C
              DO 4712 IK=1,NA
                 IF (IK.EQ.IA1) GOTO 4712
                 ION = IACON1(IK)
                 J1 = INDEX(ION+1)
                 JMA = MAX(J1,IND)
                 JMI = MIN(J1,IND)
                 JJ1 = INDEX(JMA) + JMI
                 JMA = MAX(ION,JJ)
                 JMI = MIN(ION,JJ)
                 J1 = INDEX(JMA)+JMI
                 JMA = MAX(IO1,ION)
                 JMI = MIN(IO1,ION)
                 J2 = INDEX(JMA)+JMI
                 JMA = MAX(J1,J2)
                 JMI = MIN(J1,J2)
                 INX = INDEX(JMA)+JMI
                 C = C + SI2(JJ1) - SI2(INX)
 4712         CONTINUE
C
C  LOOP OVER BETA DETS OF THE RIGHT GROUP AND SYMMETRY.
C
              CALL RESETCO(LBOX3,NSPACE,NB,IBMA,IBMI,LBOX4)
C
              DO 4700 IGB=1,ITGB
              IF (LGCOM(IGB,IGA).NE.1.OR.LGCOM(IGB,IGA2).NE.1) GOTO 4690
              JCI1 = JPZA1 + LDISB(KSYM,IGB,IGA)
              JCI2 = JPZA2 + LDISB(KSYM,IGB,IGA2)
C
              CALL RESETDE(LBOX3,NSPACE,NB,MSTA,IBCON1)
              ISTB = 1
              DO 4680 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                 IENB = LSBC(KKB)
                 DO IIZ=ISTB,IENB-1
                    CALL MOVEUP2(LBOX3,NSPACE,NB,MSTA,IBCON1)
                 ENDDO
                 ISTB = IENB
                 JCI1 = JCI1 + 1
                 JCI2 = JCI2 + 1
C
C MATRIX ELEMENT ADDITION
C
                 D = C
                 DO 4670 IK=1,NB
                    ION = IBCON1(IK)
                    J1 = INDEX(ION+1)
                    JMA = MAX(J1,IND)
                    JMI = MIN(J1,IND)
                    JJ1 = INDEX(JMA) + JMI
                    D = D + SI2(JJ1)
 4670            CONTINUE
C
                 T = D*KPER1
C
                 DO 44 KJ=1,NV
                 AB(JCI1,KJ) = AB(JCI1,KJ) + T*CI(JCI2,KJ)
                 AB(JCI2,KJ) = AB(JCI2,KJ) + T*CI(JCI1,KJ)
   44            CONTINUE
C
 4680         CONTINUE
C
 4690         CALL PUSHCO(LBOX3,NSPACE,NB,IBMA,IBMI,LBOX4,IEND)
 4700         CONTINUE
C
C --  DOUBLE ALPHA EXCITATIONS START HERE  ---
C
 4800         CONTINUE
C
            IF (IA1.EQ.NA) GOTO 4850
            IF (JJ.EQ.NACT) GOTO 4850
C
            DO II=1,NSPACE
               LBOX3(II) = LBOX2(II)
            ENDDO
            IAES3 = 1
            DO KK=1,ISPA1-1
               IAES3 = IAES3 + LBOX2(KK)
            ENDDO
C
C  LOOP OVER SPACES TO EXCITE ELECTRONS FROM, MUST BE GE THAN
C  SPACE OF FIRST EXCITATION, ISPA1.
C
            DO 3890 ISPA3 = ISPA1,NSPACE
               IF (LBOX1(ISPA3).EQ.0) GOTO 3887
               IF (ISPA3.EQ.ISPA1.AND.IA1.EQ.IEAE) GOTO 3887
               IOC3 = LBOX2(ISPA3)
               IF (IOC3.EQ.0) GOTO 3887
C
               IAEE3 = IAES3 + LBOX2(ISPA3)-1
               LBOX3(ISPA3) = LBOX3(ISPA3)-1
C
C  LOOP OVER ELECTRONS IN ISPA3, WHICH ARE LARGER THAN IA1,
C  MAKING SURE IT ISN'T THE ALREADY EXCITED ELECTRON.
C
               JSTA3 = IAES3
               IF (ISPA3.EQ.ISPA1) THEN
                  JSTA3=IA1
                  IF (IGAP-1.EQ.IA1) JSTA3=JSTA3+1
               ENDIF
C
               DO 3880 IA3=JSTA3,IAEE3
                  IF (IA3.EQ.IGAP-1) GOTO 3880
                  IO3 = IACON2(IA3)
                  IS3 = IOB(IO3)
C
C  LOOP OVER SPACES TO EXCITE ELECTRON INTO.  MUST BE GE THAN
C  SPACE FIRST ELECTRON WAS EXCITED INTO.
C
                  IGAE3 = 0
                  DO JIK=1,ISPA2-1
                     IGAE3 = IGAE3 + LBOX2(JIK)
                  ENDDO
                  DO 3850 ISPA4=ISPA2,NSPACE
C
C  IGAS3, IGAE3 ARE ELECTRONS SPECIFYING ISPA4 SPACE ELECTRON LIMITS.
C
                  LBOX3(ISPA4) = LBOX3(ISPA4) + 1
                  IGAS3 = IGAE3 + 1
                  IGAE3 = IGAE3 + LBOX2(ISPA4)
                  IF (LBOX3(ISPA3).LT.IAMI(ISPA3)) GOTO 3840
                  IF (LBOX3(ISPA4).GT.IAMA(ISPA4)) GOTO 3840
                  IF (LBOX3(ISPA2).LT.IAMI(ISPA2)) GOTO 3840
                  IF (LBOX3(ISPA2).GT.IAMA(ISPA2)) GOTO 3840
C
             IF (ISPA4.EQ.ISPA2.AND.JJ.EQ.MSTA(ISPA2+1)-1) GOTO 3840
C
C  GET GROUP NUMBER
C
               CALL POSITCO(LBOX5,NSPACE,NA,IAMA,IAMI,LBOX4,LBOX3,IGA3)
               NIAS3 = NAST(IGA3)
C
C  MAKE GAP INFORMATION HERE.
C
                  IGAA3 = MAX(IGAS3,IGAP)
C
                  IF (LBOX2(ISPA4).EQ.0) THEN
                     ISTA3 = MSTA(ISPA4)
                     IEND3 = MSTA(ISPA4+1)-1
                  ELSEIF (ISPA4.EQ.ISPA2) THEN
                     ISTA3 = JJ+1
                     IEND3 = IACON2(IGAA3)-1
C
C  I AM SUSPECT ABOUT THIS NEXT LINE, WE'LL SEE WHAT HAPPENS.......
C
                     IF (IGAP-1.EQ.IGAE3) IEND3=MSTA(ISPA2+1)-1
C
                  ELSE
                     ISTA3 = MSTA(ISPA4)
                     IEND3 = IACON2(IGAA3)-1
                  ENDIF
C
C  LOOP OVER GAPS
C
                  DO 3830 IGAP3=IGAA3,IGAE3+1
C
                     DO 3820 JJ3=ISTA3,IEND3
                        IS4 = IOB(JJ3)
                        IP2 = LGMUL(IS3,IS4)
                        IF (IP1.NE.IP2) GOTO 3820
C
              CALL REDE00(IACON2,IBCON1,NA,IA3,IGAP3-1,JJ3,JPERA3)
              CALL IDPOST(IBCON1,NA,LBOX3,NSPACE,MSTA,IDIM,X,NX,LBST,
     *                  LANDET(1,IGA3),IBCON2,JPOSA3)
              IPER3 = (-1)**(JPERA3+JPERA)
              KAPOS3 = JPOSA3 + NIAS3
              JPZA3 = LSPA(KAPOS3)
                 JMA=MAX(JJ3,IO3)
                 JMI=MIN(JJ3,IO3)
                 I2 = INDEX(JMA) + JMI
                 INX = INDEX(I2) + IND
                 II1 = INDEX(JJ3) + IO1
                 JMA=MAX(IO3,JJ)
                 JMI=MIN(IO3,JJ)
                 II2 = INDEX(JMA) + JMI
                 JMA=MAX(II1,II2)
                 JMI=MIN(II1,II2)
                 INX2 = INDEX(JMA) + JMI
                 C = SI2(INX) - SI2(INX2)
                 T = C*IPER3
C
C  LOOP OVER BETA STRINGS OF RIGHT SYMMETRY AND GROUP.
C
              DO 3700 IGB=1,ITGB
              IF (LGCOM(IGB,IGA).NE.1.OR.LGCOM(IGB,IGA3).NE.1) GOTO 3700
              JCI1 = JPZA1 + LDISB(KSYM,IGB,IGA)
              JCI3 = JPZA3 + LDISB(KSYM,IGB,IGA3)
C
              DO 3680 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                 JCI1 = JCI1 + 1
                 JCI3 = JCI3 + 1
C
                 DO 55 KJ=1,NV
                 AB(JCI1,KJ) = AB(JCI1,KJ) + T*CI(JCI3,KJ)
                 AB(JCI3,KJ) = AB(JCI3,KJ) + T*CI(JCI1,KJ)
   55            CONTINUE
C
 3680         CONTINUE
C
 3700         CONTINUE
C
 3820                CONTINUE
C
                     ISTA3 = IACON2(IGAP3)+1
                     IEND3 = IACON2(IGAP3+1)-1
                     IF (IGAP3.EQ.IGAE3) IEND3=MSTA(ISPA4+1)-1
 3830             CONTINUE
C
 3840             LBOX3(ISPA4) = LBOX3(ISPA4) - 1
 3850             CONTINUE
C
 3880          CONTINUE
C
               LBOX3(ISPA3) = LBOX3(ISPA3)+1
 3887          IAES3 = IAES3 + LBOX3(ISPA3)
 3890       CONTINUE
C
 4850                CONTINUE
C
                  ISTA = IACON1(IGAP)+1
                  IEND = IACON1(IGAP+1)-1
                  IF (IGAP.EQ.IGAE) IEND=MSTA(ISPA2+1)-1
 4860             CONTINUE
C
 4870             LBOX2(ISPA2) = LBOX2(ISPA2) - 1
 4880          CONTINUE
C
 4885          CONTINUE
C
               LBOX2(ISPA1) = LBOX2(ISPA1)+1
 4890       CONTINUE
C
C
C  --- END OF LOOP OVER SINGLE ALPHA EXCITATIONS. ---
C      NOW TO SORT THEM BY POSITIONS WITHIN SYMMETRIES.
C
            DO II=1,NSYM
               CALL FCCSRT3(IGROA(1,II),IPERA(1,II),IIND1(1,II),
     *                   IPOSA(1,II),IMMC(II))
            ENDDO
C
C  --- END OF LOOP OVER PURE ALPHA EXCITATIONS.
C  NOW TO LOOP OVER ALL SIMULTANEOUS AB -> A'B' EXCITATIONS.
C
      IF (NSPACE.EQ.1) GOTO 3400
C
C  ***** GENERAL CASE OF MORE THAN ONE SPACE !!!!! *******
C
      IF (.NOT.FDIRCT) THEN
C
C  LOOP OVER SINGLE ALPHA EXCITES WITHIN EACH SYMMETRY.
C
      DO 3000 ISAE=1,NSYM
         KBSYM=KTAB(ISAE)
         DO 2900 JSAE=1,IMMC(ISAE)
            JPOSAE=IPOSA(JSAE,ISAE)
            JPERAE=IPERA(JSAE,ISAE)
            JINDAE=IIND1(JSAE,ISAE)
            JGROAE=IGROA(JSAE,ISAE)
C
C  IF ISAE.EQ.JASYM THEN SPECIAL CASE.
C
       IF (ISAE.EQ.JASYM.AND.IGA.EQ.JGROAE) THEN
C
C  LOOP OVER ALL RELEVANT BETAS
C
            DO 2813 IGB=IGA,ITGB
               IF (LGCOM(IGB,IGA).NE.1) GOTO 2813
               LAB1 = JPZA1 + LDISB(KSYM,IGB,IGA)
               LAB2 = JPOSAE + LDISB(KSYM,IGB,IGA)
               NIBS = NBST(IGB)
               DO 2763 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                  IBPOS = NIBS + LSBC(KKB)
                  IF (IBPOS.LT.KKA) GOTO 2763
                  LABPOS = LAB1 + LSPB(IBPOS)
                  LABPOS2 = LAB2 + LSPB(IBPOS)
                  QJMODA=JPERAE
                  IF (IBPOS.EQ.KKA) QJMODA=JPERAE/2.0D+00
C
C  LOOP OVER SINGLE BETA EXCITES FROM IBPOS
C
               DO 2613 JBINDX=JB1ST(KBSYM,IBPOS),JB1ST(KBSYM+1,IBPOS)-1
                  IGB2=JB1GR(JBINDX)
                  IF (LGCOM(IGB2,JGROAE).NE.1) GOTO 2613
C
                  JMA=MAX(JINDAE,JB1IN(JBINDX))
                  JMI=MIN(JINDAE,JB1IN(JBINDX))
                  IX=INDEX(JMA)+JMI
                  C = SI2(IX)*QJMODA*JB1PE(JBINDX)
                  JCIB=JPOSAE+LDISB(KBSYM,IGB2,JGROAE)+JB1PO(JBINDX)
                  JCIB2=JPZA1+LDISB(KBSYM,IGB2,JGROAE)+JB1PO(JBINDX)
C
                  DO 66 KJ=1,NV
                  AB(LABPOS,KJ) = AB(LABPOS,KJ) + C*CI(JCIB,KJ)
                  AB(JCIB,KJ) = AB(JCIB,KJ) + C*CI(LABPOS,KJ)
                  AB(LABPOS2,KJ) = AB(LABPOS2,KJ) + C*CI(JCIB2,KJ)
                  AB(JCIB2,KJ) = AB(JCIB2,KJ) + C*CI(LABPOS2,KJ)
   66             CONTINUE
C
 2613          CONTINUE
C
 2763          CONTINUE
 2813       CONTINUE
C
       ELSE
C
C  LOOP OVER ALL RELEVANT (A-)BETA DETS.
C
            DO 2800 IGB=IGA,ITGB
               IF (LGCOM(IGB,IGA).NE.1) GOTO 2800
               LAB1 = JPZA1 + LDISB(KSYM,IGB,IGA)
               NIBS = NBST(IGB)
               DO 2750 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                  IBPOS = NIBS + LSBC(KKB)
                  IF (IBPOS.LT.KKA) GOTO 2750
                  LABPOS = LAB1 + LSPB(IBPOS)
                  QJMODA = JPERAE
                  IF (IBPOS.EQ.KKA) QJMODA=JPERAE/2.0D+00
C
C  LOOP OVER SINGLE BETA EXCITES FROM IBPOS
C
               DO 2600 JBINDX=JB1ST(KBSYM,IBPOS),JB1ST(KBSYM+1,IBPOS)-1
                  IGB2=JB1GR(JBINDX)
                  IF (LGCOM(IGB2,JGROAE).NE.1) GOTO 2600
C
                  JMA=MAX(JINDAE,JB1IN(JBINDX))
                  JMI=MIN(JINDAE,JB1IN(JBINDX))
                  IX=INDEX(JMA)+JMI
                  C = SI2(IX)*QJMODA*JB1PE(JBINDX)
                  JCIB=JPOSAE+LDISB(KBSYM,IGB2,JGROAE)+JB1PO(JBINDX)
C
                  DO 77 KJ=1,NV
                  AB(LABPOS,KJ) = AB(LABPOS,KJ) + C*CI(JCIB,KJ)
                  AB(JCIB,KJ) = AB(JCIB,KJ) + C*CI(LABPOS,KJ)
   77             CONTINUE
C
 2600          CONTINUE
C
 2750          CONTINUE
 2800       CONTINUE
C
C
C  LOOP OVER ALL RELEVANT (A'-)BETA DETS.
C
            DO 2803 IGB=IGA,ITGB
               IF (LGCOM(IGB,JGROAE).NE.1) GOTO 2803
               LAB1 = JPOSAE + LDISB(KBSYM,IGB,JGROAE)
               NIBS = NBST(IGB)
               DO 2753 KKB=LSBS(KBSYM,IGB),LSBS(KBSYM+1,IGB)-1
                  IBPOS = NIBS + LSBC(KKB)
                  IF (IBPOS.LT.KKA) GOTO 2753
                  LABPOS = LAB1 + LSPB(IBPOS)
                  QJMODA = JPERAE
                  IF (IBPOS.EQ.KKA) QJMODA=JPERAE/2.0D+00
C
C  LOOP OVER SINGLE BETA EXCITES FROM IBPOS
C
               DO 2603 JBINDX=JB1ST(KSYM,IBPOS),JB1ST(KSYM+1,IBPOS)-1
                  IGB2=JB1GR(JBINDX)
                  IF (LGCOM(IGB2,IGA).NE.1) GOTO 2603
C
                  JMA=MAX(JINDAE,JB1IN(JBINDX))
                  JMI=MIN(JINDAE,JB1IN(JBINDX))
                  IX=INDEX(JMA)+JMI
                  C = SI2(IX)*QJMODA*JB1PE(JBINDX)
                  JCIB=JPZA1+LDISB(KSYM,IGB2,IGA)+JB1PO(JBINDX)
C
                  DO 88 KJ=1,NV
                  AB(LABPOS,KJ) = AB(LABPOS,KJ) + C*CI(JCIB,KJ)
                  AB(JCIB,KJ) = AB(JCIB,KJ) + C*CI(LABPOS,KJ)
   88             CONTINUE
C
 2603          CONTINUE
C
 2753          CONTINUE
 2803       CONTINUE
C
      ENDIF
C
 2900    CONTINUE
 3000 CONTINUE
C
      ELSE
C
C  ***** DIRECT METHOD BELOW *****
C
      DO 4000 ISAE=1,NSYM
         KBSYM = KTAB(ISAE)
C
C  ANALYSE EXCITED A' GROUPS FOR COMPATIBILITY WITH B.
C
      NGRPS = 0
      DO 1976 II=1,IMMC(ISAE)
         ICGR = IGROA(II,ISAE)
         DO JJ=1,NGRPS
            IF (JB1GR(JJ).EQ.ICGR) GOTO 1976
         ENDDO
         NGRPS = NGRPS + 1
         JB1GR(NGRPS) = ICGR
 1976 CONTINUE
C
C FIRST TYPE OF BETAS, KSYM -> KBSYM
C
          CALL RESETCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3)
          DO 7400 IGB=1,ITGB
             IF (IGB.LT.IGA) GOTO 7399
             IF (LGCOM(IGB,IGA).NE.1) GOTO 7399
             LAB1 = JPZA1 + LDISB(KSYM,IGB,IGA)
C
             CALL RESETDE(LBOX2,NSPACE,NB,MSTA,IBCON1)
             NIBS = NBST(IGB)
             ISTB = 1
             DO 7300 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                IENB = LSBC(KKB)
                DO IIZ=ISTB,IENB-1
                   CALL MOVEUP2(LBOX2,NSPACE,NB,MSTA,IBCON1)
                ENDDO
                ISTB = IENB
C
                IBPOS = NIBS + LSBC(KKB)
                IF (IBPOS.LT.KKA) GOTO 7300
                LABPOS = LAB1 + LSPB(IBPOS)
                QJMODA=1.0D+00
                IF (IBPOS.EQ.KKA) QJMODA=0.5D+00
C
C LOOP OVER SINGLE BETA EXCITES FROM IBPOS WHICH ARE OF SYMMETRY KBSYM
C
                MESYM1 = LGMUL(KSYM,KBSYM)
                DO II=1,NSPACE
                   LBOX3(II) = LBOX2(II)
                ENDDO
                IEBS = NB + 1
                DO 7290 ISPB1=NSPACE,1,-1
                   IOC1 = LBOX2(ISPB1)
                   IEBE = IEBS - 1
                   IEBS = IEBS - IOC1
                   IF (IOC1.EQ.0) GO TO 7290
                   LBOX3(ISPB1) = LBOX3(ISPB1)-1
C
C  LOOP ELECTRONS IN SPACE ISPB1
C  IEBS, IEBE ARE THE ELECTRONS IN SPACE ISPB1
C
                DO 7285 IB1 = IEBE,IEBS,-1
                   IO1 = IBCON1(IB1)
                   MESYM2 = LGMUL(MESYM1,IOB(IO1))
                   IGBE = IEBE - LBOX2(ISPB1)
C
C  LOOP OVER POSSIBLE SPACES TO EXCITE INTO.
C
                DO 7280 ISPB2=ISPB1,NSPACE
C
C  IGBS,IGBE ARE ELECTRONS SPECIFYING ISPB2 SPACE ELECTRON LIMITS.
C
                   IGBS = IGBE + 1
                   IGBE = IGBE + LBOX2(ISPB2)
C
                   LBOX3(ISPB2) = LBOX3(ISPB2) + 1
                   IF (LBOX3(ISPB1).LT.IBMI(ISPB1)) GO TO 7270
                   IF (LBOX3(ISPB2).GT.IBMA(ISPB2)) GO TO 7270
C
C  GET GROUP NUMBER
C
          CALL POSITCO(LBOX5,NSPACE,NB,IBMA,IBMI,LBOX4,LBOX3,IGB2)
          NIAS = NBST(IGB2)
C
C CHECK FOR A' GROUP COMPATIBILITY
C
             DO II=1,NGRPS
                IAGRP = JB1GR(II)
                IF (LGCOM(IGB2,IAGRP).EQ.1) GOTO 7555
             ENDDO
             GOTO 7270
 7555        CONTINUE
C
C  MAKE GAP INFORMATION HERE.
C
                  IGBA = MAX(IB1+1,IGBS)
                  IF (LBOX2(ISPB2).EQ.0) THEN
                     ISTA = MSTA(ISPB2)
                     IEND = MSTA(ISPB2+1)-1
                  ELSEIF (ISPB2.EQ.ISPB1) THEN
                     ISTA = IO1+1
                     IEND = IBCON1(IGBA)-1
                     IF (IB1.EQ.IEBE) IEND=MSTA(ISPB1+1)-1
                  ELSE
                     ISTA = MSTA(ISPB2)
                     IEND = IBCON1(IGBA)-1
                  ENDIF
C
C  LOOP OVER GAPS
C
                  DO 7260 IGAP=IGBA,IGBE+1
C
                     DO 7250 JJ=ISTA,IEND
C
C CHECK TO SEE IF EXCITED BETA IS OF RIGHT SYMMETRY (KBSYM)
C
            IF (IOB(JJ).NE.MESYM2) GOTO 7250
C
            IND1 = INDEX(JJ) + IO1
            CALL REDE00(IBCON1,IBCON2,NB,IB1,IGAP-1,JJ,IPER)
            CALL IDPOST(IBCON2,NB,LBOX3,NSPACE,MSTA,IDIM,X,NX,LBST,
     *                  LBNDET(1,IGB2),IACON2,IPOSB)
            QJPER = ((-1)**IPER)*QJMODA
            JB1P = LSPB(IPOSB + NIAS)
C
            DO 3900 JSAE=1,IMMC(ISAE)
               JGROAE=IGROA(JSAE,ISAE)
               IF (LGCOM(IGB2,JGROAE).NE.1) GOTO 3900
C
               JPOSAE=IPOSA(JSAE,ISAE)
               JCIB = JB1P + JPOSAE + LDISB(KBSYM,IGB2,JGROAE)
C
               JINDAE=IIND1(JSAE,ISAE)
               JMA=MAX(JINDAE,IND1)
               JMI=MIN(JINDAE,IND1)
               IX=INDEX(JMA)+JMI
C
               JPERAE=IPERA(JSAE,ISAE)
               C = SI2(IX)*QJPER*JPERAE
C
         DO KJ=1,NV
            AB(LABPOS,KJ) = AB(LABPOS,KJ) + C*CI(JCIB,KJ)
            AB(JCIB,KJ) = AB(JCIB,KJ) + C*CI(LABPOS,KJ)
         ENDDO
C
 3900       CONTINUE
C
 7250                CONTINUE
C
                  ISTA = IBCON1(IGAP)+1
                  IEND = IBCON1(IGAP+1)-1
                  IF (IGAP.EQ.IGBE) IEND=MSTA(ISPB2+1)-1
 7260             CONTINUE
C
 7270              LBOX3(ISPB2) = LBOX3(ISPB2) - 1
 7280           CONTINUE
C
 7285           CONTINUE
C
                   LBOX3(ISPB1) = LBOX3(ISPB1) + 1
 7290           CONTINUE
C
 7300        CONTINUE
C
 7399        CALL PUSHCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3,IEND)
 7400     CONTINUE
C
C SECOND TYPE OF BETAS, KBSYM -> KSYM
C
          CALL RESETCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3)
          DO 7800 IGB=1,ITGB
             IF (IGB.LT.IGA) GOTO 7799
C
C CHECK FOR A' GROUP COMPATIBILITY
C
             DO II=1,NGRPS
                IAGRP = JB1GR(II)
                IF (LGCOM(IGB,IAGRP).EQ.1) GOTO 7655
             ENDDO
             GOTO 7799
 7655        CONTINUE
C
C INSERT CHECK FOR A'B GROUP COMPATIBILITY.
C
             CALL RESETDE(LBOX2,NSPACE,NB,MSTA,IBCON1)
             NIBS = NBST(IGB)
             ISTB = 1
C
             DO 7700 KKB=LSBS(KBSYM,IGB),LSBS(KBSYM+1,IGB)-1
                IENB = LSBC(KKB)
                DO IIZ=ISTB,IENB-1
                   CALL MOVEUP2(LBOX2,NSPACE,NB,MSTA,IBCON1)
                ENDDO
                ISTB = IENB
C
                IBPOS = NIBS + LSBC(KKB)
                IF (IBPOS.LT.KKA) GOTO 7700
                LAB1 = LSPB(IBPOS)
                QJMODA=1.0D+00
                IF (IBPOS.EQ.KKA) QJMODA=0.5D+00
C
C
C LOOP OVER SINGLE BETA EXCITES FROM IBPOS WHICH ARE OF SYMMETRY KSYM
C
                MESYM1 = LGMUL(KSYM,KBSYM)
                DO II=1,NSPACE
                   LBOX3(II) = LBOX2(II)
                ENDDO
                IEBS = NB + 1
                DO 7690 ISPB1=NSPACE,1,-1
                   IOC1 = LBOX2(ISPB1)
                   IEBE = IEBS - 1
                   IEBS = IEBS - IOC1
                   IF (IOC1.EQ.0) GO TO 7690
                   LBOX3(ISPB1) = LBOX3(ISPB1)-1
C
C  LOOP ELECTRONS IN SPACE ISPB1
C  IEBS, IEBE ARE THE ELECTRONS IN SPACE ISPB1
C
                DO 7685 IB1 = IEBE,IEBS,-1
                   IO1 = IBCON1(IB1)
                   MESYM2 = LGMUL(MESYM1,IOB(IO1))
                   IGBE = IEBE - LBOX2(ISPB1)
C
C  LOOP OVER POSSIBLE SPACES TO EXCITE INTO.
C
                DO 7680 ISPB2=ISPB1,NSPACE
C
C  IGBS,IGBE ARE ELECTRONS SPECIFYING ISPB2 SPACE ELECTRON LIMITS.
C
                   IGBS = IGBE + 1
                   IGBE = IGBE + LBOX2(ISPB2)
C
                   LBOX3(ISPB2) = LBOX3(ISPB2) + 1
                   IF (LBOX3(ISPB1).LT.IBMI(ISPB1)) GO TO 7670
                   IF (LBOX3(ISPB2).GT.IBMA(ISPB2)) GO TO 7670
C
          CALL POSITCO(LBOX5,NSPACE,NB,IBMA,IBMI,LBOX4,LBOX3,IGB2)
          IF (LGCOM(IGB2,IGA).NE.1) GOTO 7670
          JCIBS = JPZA1 + LDISB(KSYM,IGB2,IGA)
          NIAS = NBST(IGB2)
C
C  MAKE GAP INFORMATION HERE.
C
                  IGBA = MAX(IB1+1,IGBS)
                  IF (LBOX2(ISPB2).EQ.0) THEN
                     ISTA = MSTA(ISPB2)
                     IEND = MSTA(ISPB2+1)-1
                  ELSEIF (ISPB2.EQ.ISPB1) THEN
                     ISTA = IO1+1
                     IEND = IBCON1(IGBA)-1
                     IF (IB1.EQ.IEBE) IEND=MSTA(ISPB1+1)-1
                  ELSE
                     ISTA = MSTA(ISPB2)
                     IEND = IBCON1(IGBA)-1
                  ENDIF
C
C  LOOP OVER GAPS
C
                  DO 7660 IGAP=IGBA,IGBE+1
C
                     DO 7650 JJ=ISTA,IEND
C
C CHECK TO SEE IF EXCITED BETA IS OF RIGHT SYMMETRY (KBSYM)
C
            IF (IOB(JJ).NE.MESYM2) GOTO 7650
C
            IND1 = INDEX(JJ) + IO1
            CALL REDE00(IBCON1,IBCON2,NB,IB1,IGAP-1,JJ,IPER)
            CALL IDPOST(IBCON2,NB,LBOX3,NSPACE,MSTA,IDIM,X,NX,LBST,
     *                  LBNDET(1,IGB2),IACON2,IPOSB)
            QJPER = ((-1)**IPER)*QJMODA
            JCIB= JCIBS + LSPB(IPOSB + NIAS)
C
            DO 4300 JSAE=1,IMMC(ISAE)
               JGROAE=IGROA(JSAE,ISAE)
               IF (LGCOM(IGB,JGROAE).NE.1) GOTO 4300
C
               JPOSAE=IPOSA(JSAE,ISAE)
               LABPOS = LAB1 + JPOSAE + LDISB(KBSYM,IGB,JGROAE)
C
               JINDAE=IIND1(JSAE,ISAE)
               JMA=MAX(JINDAE,IND1)
               JMI=MIN(JINDAE,IND1)
               IX=INDEX(JMA)+JMI
C
               JPERAE=IPERA(JSAE,ISAE)
               C = SI2(IX)*QJPER*JPERAE
C
         DO KJ=1,NV
            AB(LABPOS,KJ) = AB(LABPOS,KJ) + C*CI(JCIB,KJ)
            AB(JCIB,KJ) = AB(JCIB,KJ) + C*CI(LABPOS,KJ)
         ENDDO
C
 4300       CONTINUE
C
 7650                CONTINUE
C
                  ISTA = IBCON1(IGAP)+1
                  IEND = IBCON1(IGAP+1)-1
                  IF (IGAP.EQ.IGBE) IEND=MSTA(ISPB2+1)-1
 7660             CONTINUE
C
 7670              LBOX3(ISPB2) = LBOX3(ISPB2) - 1
 7680           CONTINUE
C
 7685           CONTINUE
C
                   LBOX3(ISPB1) = LBOX3(ISPB1) + 1
 7690           CONTINUE
C
 7700        CONTINUE
C
 7799        CALL PUSHCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3,IEND)
 7800     CONTINUE
C
 4000 CONTINUE
C
      ENDIF
C
C ****** END OF DIRECT METHOD *******
C
C  **** END OF GENERAL CASE OF MORE THAN ONE SPACE ******
C
      GOTO 4898
C
 3400 CONTINUE
C
C ***** SPECIAL CASE OF ONE SPACE !!!!! ******
C
C  LOOP OVER SINGLE ALPHA EXCITES WITHIN EACH SYMMETRY.
C
       DO 2901 ISAE=1,NSYM
          KBSYM=KTAB(ISAE)
          DO 2801 JSAE=1,IMMC(ISAE)
                JPOSAE=IPOSA(JSAE,ISAE)
                JPERAE=IPERA(JSAE,ISAE)
                JINDAE=IIND1(JSAE,ISAE)
                JGROAE=IGROA(JSAE,ISAE)
C
C  IF ISAE.EQ.JASYM THEN SPECIAL CASE.
C
       IF (ISAE.EQ.JASYM) THEN
C
C  LOOP OVER ALL RELEVANT BETAS
C
             LABPOS=JPZA1
             LABPOS2=JPOSAE
                DO 2721 KKB=LSBS(KSYM,1),LSBS(KSYM+1,1)-1
                    LABPOS = LABPOS + 1
                    LABPOS2 = LABPOS2 + 1
                    IBPOS =  LSBC(KKB)
                    IF (IBPOS.LT.ILIMA) GOTO 2721
                    QJMODA=JPERAE
                    IF (IBPOS.EQ.ILIMA) QJMODA=JPERAE/2.0D+00
C
C  LOOP OVER SINGLE BETA EXCITES FROM IBPOS
C
               DO 2621 JBINDX=JB1ST(KSYM,IBPOS),JB1ST(KSYM+1,IBPOS)-1
                  JMA=MAX(JINDAE,JB1IN(JBINDX))
                  JMI=MIN(JINDAE,JB1IN(JBINDX))
                  IX=INDEX(JMA)+JMI
                  C = SI2(IX)*QJMODA*JB1PE(JBINDX)
                  JCIB = JPOSAE+JB1PO(JBINDX)
                  JCIB2 = JPZA1+JB1PO(JBINDX)
C
                  DO 56 KJ=1,NV
                  AB(LABPOS,KJ) = AB(LABPOS,KJ) + C*CI(JCIB,KJ)
                  AB(JCIB,KJ) = AB(JCIB,KJ) + C*CI(LABPOS,KJ)
                  AB(LABPOS2,KJ) = AB(LABPOS2,KJ) + C*CI(JCIB2,KJ)
                  AB(JCIB2,KJ) = AB(JCIB2,KJ) + C*CI(LABPOS2,KJ)
   56             CONTINUE
C
 2621          CONTINUE
               QJMODA=JPERAE
C
 2721          CONTINUE
C
      ELSE
C
C  LOOP OVER ALL RELEVANT (A-)BETA DETS.
C
                LABPOS = JPZA1
                DO 2751 KKB=LSBS(KSYM,1),LSBS(KSYM+1,1)-1
                    LABPOS = LABPOS + 1
                    IBPOS =  LSBC(KKB)
                    IF (IBPOS.LT.ILIMA) GOTO 2751
                    QJMODA=JPERAE
                    IF (IBPOS.EQ.ILIMA) QJMODA=JPERAE/2.0D+00
C
C  LOOP OVER SINGLE BETA EXCITES FROM IBPOS
C
               DO 2601 JBINDX=JB1ST(KBSYM,IBPOS),JB1ST(KBSYM+1,IBPOS)-1
C
                  JMA=MAX(JINDAE,JB1IN(JBINDX))
                  JMI=MIN(JINDAE,JB1IN(JBINDX))
                  IX=INDEX(JMA)+JMI
                  C = SI2(IX)*QJMODA*JB1PE(JBINDX)
                  JCIB=JPOSAE+JB1PO(JBINDX)
C
                  DO 67 KJ=1,NV
                  AB(LABPOS,KJ) = AB(LABPOS,KJ) + C*CI(JCIB,KJ)
                  AB(JCIB,KJ) = AB(JCIB,KJ) + C*CI(LABPOS,KJ)
   67             CONTINUE
C
 2601          CONTINUE
               QJMODA=JPERAE
C
 2751          CONTINUE
C
C  LOOP OVER ALL RELEVANT (A'-)BETA DETS.
C
               LABPOS = JPOSAE
               DO 2761 KKB=LSBS(KBSYM,1),LSBS(KBSYM+1,1)-1
                  LABPOS = LABPOS + 1
                  IBPOS = LSBC(KKB)
                  IF (IBPOS.LT.ILIMA) GOTO 2761
                  QJMODA=JPERAE
                  IF (IBPOS.EQ.ILIMA) QJMODA=JPERAE/2.0D+00
C
C  LOOP OVER SINGLE BETA EXCITES FROM IBPOS
C
               DO 2611 JBINDX=JB1ST(KSYM,IBPOS),JB1ST(KSYM+1,IBPOS)-1
C
                  JMA=MAX(JINDAE,JB1IN(JBINDX))
                  JMI=MIN(JINDAE,JB1IN(JBINDX))
                  IX=INDEX(JMA)+JMI
                  C = SI2(IX)*QJMODA*JB1PE(JBINDX)
                  JCIB=JPZA1+JB1PO(JBINDX)
C
                  DO 78 KJ=1,NV
                  AB(LABPOS,KJ) = AB(LABPOS,KJ) + C*CI(JCIB,KJ)
                  AB(JCIB,KJ) = AB(JCIB,KJ) + C*CI(LABPOS,KJ)
   78             CONTINUE
C
 2611          CONTINUE
               QJMODA=JPERAE
C
 2761          CONTINUE
C
      ENDIF
C
 2801       CONTINUE
 2901   CONTINUE
C
C  **** END OF SPECIAL CASE OF ONE SPACE *******
C
 4898       CONTINUE
            IF (GOPARR) CALL DDI_DLBNEXT(MY_TASK)
 4899       CONTINUE
            CALL MOVEUP2(LBOX1,NSPACE,NA,MSTA,IACON1)
 4900    CONTINUE
C
         CALL PUSHCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX5,IEND)
 5000 CONTINUE
C
C  --- END OF LOOP OVER ALPHA STRINGS. ---
C
      IF (GOPARR) THEN
         CALL DDI_DLBRESET()
         CALL DDI_GSUMF(2900,AB,NCI*NV)
      ENDIF
C
C **
C
      DO 1111 IGA=1,ITGA
         DO 1122 KKA=NAST(IGA)+1,NAST(IGA+1)
            JPZA1 = LSPA(KKA)
            JASYM = LSYMA(KKA)
            KSYM=KTAB(JASYM)
            ILIMA = KKA-NAST(IGA)
C
            DO 1133 IGB=1,IGA
            IF (LGCOM(IGB,IGA).NE.1) GOTO 1133
            ICC1 = JPZA1 + LDISB(KSYM,IGB,IGA)
            ICC2 = LDISB(JASYM,IGA,IGB) + LSPB(KKA)
            NIBS=NBST(IGB)
            DO 1144 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
               IBPOS = LSBC(KKB) + NIBS
               IF (IBPOS.GT.KKA) GOTO 1122
               ICI2 = LSPA(IBPOS) + ICC2
               IF (IBPOS.EQ.KKA) THEN
                  DO 4444 KJ=1,NV
                  IS = (-1)**ISPIN(IHMCON(KJ))
                  AB(ICI2,KJ) = AB(ICI2,KJ) + IS*AB(ICI2,KJ)
 4444             CONTINUE
                  GOTO 1122
               ENDIF
               ICI1 = ICC1+LSPB(IBPOS)
               DO 3333 KJ=1,NV
               IS = (-1)**ISPIN(IHMCON(KJ))
               QT = AB(ICI1,KJ)
               AB(ICI1,KJ) = AB(ICI1,KJ) + IS*AB(ICI2,KJ)
               AB(ICI2,KJ) = AB(ICI2,KJ) + IS*QT
 3333          CONTINUE
 1144       CONTINUE
 1133       CONTINUE
 1122    CONTINUE
 1111 CONTINUE
C
C   NOW FOR THE DIAGONAL CONTRIBUTIONS
C
      DO 119 IJK=1,NCI
         DO 118 KJ=1,NV
            AB(IJK,KJ) = AB(IJK,KJ) + Q(IJK)*CI(IJK,KJ)
  118    CONTINUE
  119 CONTINUE
C
C  ALL DONE, RETURN
C
      RETURN
      END
C
C*MODULE ORMAS1  *DECK MASPRT
      SUBROUTINE MASPRT(IW,SOME,VEC,NAST,ITGA,ITGB,
     *             LSYMA,IAST,IBST,LGCOM,LSBS,NSYM,LSBC,
     *             LBOX1,LBOX2,LBOX3,IACON1,IBCON1,KTAB)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL SOME,GOPARR,DSKWRK,MASWRK,SVDSKW,FDIRCT,QCORR
C
      PARAMETER (MXRT=100)
C
      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 /FCCWFN/ NSPACE,MSTA(51),MNUM(51),MINI(51),MAXI(51),
     *                IAMI(51),IAMA(51),IBMI(51),IBMA(51),IDIM(51),
     *                LBST(51),NREF0,FDIRCT,QCORR,C0SQ
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      DIMENSION VEC(NCI,K)
      DIMENSION NAST(ITGA),LSYMA(IAST)
      DIMENSION LGCOM(ITGB,ITGA),LSBS(NSYM+1,ITGB),LSBC(IBST)
      DIMENSION LBOX1(NSPACE),LBOX2(NSPACE),LBOX3(NSPACE)
      DIMENSION IACON1(NA),IBCON1(NB),KTAB(NSYM)
C
      DATA CHECK/8HCHECK   /
C
C     ----- PRINT THE DETERMINANT BASED CI EIGENVECTOR -----
C
      SVDSKW = DSKWRK
      DSKWRK=.FALSE.
C
      NSYM = 2**IGPDET
C
      IF(SOME) WRITE(IW,9140) GRPDET
C
C        ----- PRINT CI ENERGIES AND EIGENVECTORS -----
C        NOTE THAT PRTDET DESTROYS THE EIGENVECTORS.
C
      IF(NCI.LE.20) THEN
         IOP=1
         NUMPRT=NCI
         IF(SOME) WRITE(IW,9150)
      ELSE
         IOP=2
         NUMPRT=0
         IF(SOME) WRITE(IW,9160) PRTTOL
      END IF
C
      DO 430 I=1,K
         IF(SOME) THEN
            WRITE(IW,9170) I,ESTATE(I),SPINS(I),SZ,STSYM
            IF(EXETYP.NE.CHECK) CALL MASPRI(IW,IOP,NUMPRT,
     *      VEC(1,I),NAST,ITGA,ITGB,LSYMA,IAST,IBST,LGCOM,
     *      LSBS,NSYM,LSBC,LBOX1,LBOX2,LBOX3,IACON1,IBCON1,KTAB)
C
         END IF
  430 CONTINUE
CC
      DSKWRK=SVDSKW
      RETURN
C
 9140 FORMAT(/1X,'CI EIGENVECTORS WILL BE LABELED IN GROUP=',A8)
 9150 FORMAT(1X,'PRINTING ALL NON-ZERO CI COEFFICIENTS')
 9160 FORMAT(1X,'PRINTING CI COEFFICIENTS LARGER THAN',F10.6)
 9170 FORMAT(/1X,'STATE',I4,'  ENERGY= ',F20.10,'  S=',F6.2,
     *           '  SZ=',F6.2,:,'  SPACE SYM=',A4/)
      END
C
C*MODULE ORMAS1  *DECK MASPRI
C     -----------------------------------------------------------
      SUBROUTINE MASPRI(IW,IOP,NUM,
     *               CI,NAST,ITGA,ITGB,LSYMA,
     *               IAST,IBST,LGCOM,LSBS,NSYM,LSBC,
     *               LBOX1,LBOX2,LBOX3,IACON1,IBCON1,KTAB)
C     -----------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXRT=100)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,FDIRCT,QCORR
C
      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 /FCCWFN/ NSPACE,MSTA(51),MNUM(51),MINI(51),MAXI(51),
     *                IAMI(51),IAMA(51),IBMI(51),IBMA(51),IDIM(51),
     *                LBST(51),NREF0,FDIRCT,QCORR,C0SQ
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      CHARACTER*500 CONA,CONB
      DIMENSION CI(NCI)
      DIMENSION NAST(ITGA+1),LSYMA(IAST)
      DIMENSION LGCOM(ITGB,ITGA),LSBS(NSYM+1,ITGB),LSBC(IBST)
      DIMENSION LBOX1(NSPACE),LBOX2(NSPACE),LBOX3(NSPACE)
      DIMENSION IACON1(NA),IBCON1(NB),KTAB(NSYM)
C
      DO II=1,500
         CONA(II:II) = ' '
         CONB(II:II) = ' '
      ENDDO
C
C  SET UP THE TABLE
C
      ISIZA = 0
      ISIZB = 0
      DO II=1,NSPACE
         ISIZA = ISIZA+(3*IAMA(II))
         ISIZB = ISIZB+(3*IBMA(II))
      ENDDO
C
      IF(ISIZA+1.GT.500  .OR.  ISIZB+1.GT.500) THEN
         WRITE(IW,*) 'TOO MANY ORBITALS TO PRINT ORMAS CI VECTOR'
         RETURN
      END IF
C
      IAPL = ISIZA/2 - 2
      IBPL = ISIZB/2 - 1
      CONA(IAPL:IAPL+4) = 'ALPHA'
      CONB(IBPL:IBPL+4) = 'BETA '
      IF(MASWRK) WRITE(IW,'(4A)') CONA(1:ISIZA+1),'|',
     *                            CONB(1:ISIZB+1),'| COEFFICIENT'
C
      DO II=1,ISIZA+1
         CONA(II:II) = ' '
      ENDDO
      DO II=1,ISIZB+1
         CONB(II:II) = ' '
      ENDDO
      IAPL = 1
      IBPL = 1
      DO II=1,NSPACE
         IF (II.LT.10) WRITE(CONA(IAPL+1:IAPL+1),'(I1)') II
         IF (II.LT.10) WRITE(CONB(IBPL+1:IBPL+1),'(I1)') II
         IF (II.GT.10) WRITE(CONA(IAPL+1:IAPL+2),'(I2)') II
         IF (II.GT.10) WRITE(CONB(IBPL+1:IBPL+2),'(I2)') II
         IAPL = IAPL + IAMA(II)*3
         IBPL = IBPL + IBMA(II)*3
      ENDDO
      IF (MASWRK) WRITE(IW,'(4A)') CONA(1:ISIZA+1),'|',
     *                  CONB(1:ISIZB+1),'|'
      DO II=1,ISIZA+1
         CONA(II:II) = '-'
      ENDDO
      DO II=1,ISIZB+1
         CONB(II:II) = '-'
      ENDDO
      IF(MASWRK) WRITE(IW,'(4A)') CONA(1:ISIZA+1),'|',
     *                 CONB(1:ISIZB+1),'|------------'
C
      IF (IOP.EQ.1) THEN
C
      DO 3000 KJK=1,NUM
C
         ICI = 0
         IPOS = -1
         PMAX = 0.0D+00
C
         DO 400 IGA=1,ITGA
            DO 410 KKA=NAST(IGA)+1,NAST(IGA+1)
               JASYM=LSYMA(KKA)
               KSYM=KTAB(JASYM)
               DO 500 IGB=1,ITGB
                  IF (LGCOM(IGB,IGA).NE.1) GO TO 500
                  DO 510 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                     NEND = LSBC(KKB)
                     ICI=ICI+1
                     IF (ABS(CI(ICI)).GT.PMAX) THEN
                        IZA = IGA
                        IZB = IGB
                        IKA = KKA - NAST(IGA)
                        IKB = NEND
                        IPOS = ICI
                        PMAX = ABS(CI(ICI))
                     ENDIF
  510             CONTINUE
  500          CONTINUE
  410       CONTINUE
  400    CONTINUE
         IF (IPOS.EQ.-1) GO TO 3000
C
C  MAKE THE DETERMINANT
C
         CALL RESETCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX3)
         DO II=1,IZA-1
            CALL PUSHCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX3,ISE)
         ENDDO
         CALL RESETDE(LBOX1,NSPACE,NA,MSTA,IACON1)
         DO II=1,IKA-1
            CALL MOVEUP2(LBOX1,NSPACE,NA,MSTA,IACON1)
         ENDDO
C
         CALL RESETCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3)
         DO II=1,IZB-1
            CALL PUSHCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3,ISE)
         ENDDO
         CALL RESETDE(LBOX2,NSPACE,NB,MSTA,IBCON1)
         DO II=1,IKB-1
            CALL MOVEUP2(LBOX2,NSPACE,NB,MSTA,IBCON1)
         ENDDO
C
C   NOW TO PRINT OUT THE DETERMINANT
C
         DO II=1,500
            CONA(II:II) = ' '
            CONB(II:II) = ' '
         ENDDO
         ISPA = 1
         ISPB = 1
         IPLA = 1
         IPLB = 1
         IELA = 1
         IELB = 1
         DO II=1,NSPACE
            IPLA = ISPA
            DO JJ=1,LBOX1(II)
               WRITE(CONA(IPLA:IPLA+2),'(I3)') IACON1(IELA)
               IPLA = IPLA+3
               IELA = IELA+1
            ENDDO
            ISPA = ISPA + 3*IAMA(II)
         ENDDO
         DO II=1,NSPACE
            IPLB = ISPB
            DO JJ=1,LBOX2(II)
               WRITE(CONB(IPLB:IPLB+2),'(I3)') IBCON1(IELB)
               IPLB = IPLB+3
               IELB = IELB + 1
            ENDDO
            ISPB = ISPB + 3*IBMA(II)
         ENDDO
         IF (MASWRK) WRITE(IW,'(4A,F10.7)') CONA(1:ISIZA+1),'|',
     *                  CONB(1:ISIZB+1),'|  ',CI(IPOS)
         CI(IPOS) = 0.0D+00
C
 3000 CONTINUE
C
      ELSE
C
      DO 4000 KJK=1,NCI
C
         ICI = 0
         IPOS = -1
         PMAX = 0.0D+00
C
         DO 700 IGA=1,ITGA
            DO 710 KKA=NAST(IGA)+1,NAST(IGA+1)
               JASYM=LSYMA(KKA)
               KSYM=KTAB(JASYM)
               DO 800 IGB=1,ITGB
                  IF (LGCOM(IGB,IGA).NE.1) GO TO 800
                  DO 810 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                     NEND = LSBC(KKB)
                     ICI=ICI+1
                     IF (ABS(CI(ICI)).GT.PMAX) THEN
                        IZA = IGA
                        IZB = IGB
                        IKA = KKA - NAST(IGA)
                        IKB = NEND
                        IPOS = ICI
                        PMAX = ABS(CI(ICI))
                     ENDIF
  810             CONTINUE
  800          CONTINUE
  710       CONTINUE
  700    CONTINUE
C
C  CHECK IF IS BIGGER THAN CRIT
C
         IF (ABS(CI(IPOS)).LT.PRTTOL) RETURN
C
C  MAKE THE DETERMINANT
C
         CALL RESETCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX3)
         DO II=1,IZA-1
            CALL PUSHCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX3,ISE)
         ENDDO
         CALL RESETDE(LBOX1,NSPACE,NA,MSTA,IACON1)
         DO II=1,IKA-1
            CALL MOVEUP2(LBOX1,NSPACE,NA,MSTA,IACON1)
         ENDDO
C
         CALL RESETCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3)
         DO II=1,IZB-1
            CALL PUSHCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3,ISE)
         ENDDO
         CALL RESETDE(LBOX2,NSPACE,NB,MSTA,IBCON1)
         DO II=1,IKB-1
            CALL MOVEUP2(LBOX2,NSPACE,NB,MSTA,IBCON1)
         ENDDO
C
C   NOW TO PRINT OUT THE DETERMINANT
C
         DO II=1,500
            CONA(II:II) = ' '
            CONB(II:II) = ' '
         ENDDO
         ISPA = 1
         ISPB = 1
         IPLA = 1
         IPLB = 1
         IELA = 1
         IELB = 1
         DO II=1,NSPACE
            IPLA = ISPA
            DO JJ=1,LBOX1(II)
               WRITE(CONA(IPLA:IPLA+2),'(I3)') IACON1(IELA)
               IPLA = IPLA+3
               IELA = IELA+1
            ENDDO
            ISPA = ISPA + 3*IAMA(II)
         ENDDO
         DO II=1,NSPACE
            IPLB = ISPB
            DO JJ=1,LBOX2(II)
               WRITE(CONB(IPLB:IPLB+2),'(I3)') IBCON1(IELB)
               IPLB = IPLB+3
               IELB = IELB + 1
            ENDDO
            ISPB = ISPB + 3*IBMA(II)
         ENDDO
         IF (MASWRK) WRITE(IW,'(4A,F10.7)') CONA(1:ISIZA+1),'|',
     *                  CONB(1:ISIZB+1),'|  ',CI(IPOS)
         CI(IPOS) = 0.0D+00
C
 4000 CONTINUE
C
      ENDIF
C
      RETURN
      END
C
C*MODULE ORMAS1  *DECK CICOPY
C     -----------------------------------------------------------
      SUBROUTINE CICOPY(CI,AB,NTOT)
C     -----------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION CI(NTOT),AB(NTOT)
      DO II=1,NTOT
         AB(II) = CI(II)
      ENDDO
      RETURN
      END
C
C*MODULE ORMAS1  *DECK MASDM1
C     ------------------------------------------------------------------
      SUBROUTINE MASDM1(IW,NPRINT,
     *           DM1,M2,NACT,NCI,NA,NB,IROOT,X,NX,CI,
     *           INDEX,NSYM,IOB,
     *           LBOX1,LBOX2,LBOX4,LBOX5,
     *           KTAB,IACON1,IACON2,IBCON1,IBCON2,
     *           LANDET,LBNDET,NAST,NBST,LSYMA,LSYMB,LGCOM,
     *           LSPA,LSPB,LDISB,LSAS,LSBS,LSAC,
     *           ITGA,ITGB,IAST,IBST)
C     ------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL SOME,GOPARR,DSKWRK,MASWRK,FDIRCT,QCORR
C
      PARAMETER (MXRT=100)
C
      COMMON /ENRGYS/ ENUCR,EELCT,ETOT,STOT,SSQUAR,ECORE,ESCF,EERD,
     *                E1,E2,VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /FCCWFN/ NSPACE,MSTA(51),MNUM(51),MINI(51),MAXI(51),
     *                IAMI(51),IAMA(51),IBMI(51),IBMA(51),IDIM(51),
     *                LBST(51),NREF0,FDIRCT,QCORR,C0SQ
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      DIMENSION DM1(M2),X(NX),CI(NCI)
      DIMENSION INDEX((NACT*(NACT+1))/2+1),IOB(NACT)
      DIMENSION LBOX1(NSPACE),LBOX2(NSPACE)
      DIMENSION LBOX4(NSPACE),LBOX5(NSPACE)
      DIMENSION KTAB(NSYM)
      DIMENSION IACON1(NA),IACON2(NA),IBCON1(NA),IBCON2(NA)
      DIMENSION LANDET(NSPACE,ITGA),LBNDET(NSPACE,ITGB)
      DIMENSION NAST(ITGA+1),NBST(ITGB+1)
      DIMENSION LSYMA(IAST),LSYMB(IBST),LGCOM(ITGB,ITGA)
      DIMENSION LSPA(IAST),LSPB(IBST),LDISB(NSYM,ITGB,ITGA)
      DIMENSION LSAS(NSYM+1,ITGA),LSBS(NSYM+1,ITGB)
      DIMENSION LSAC(IAST)
C
      DATA CHECK/8HCHECK   /
C
      SOME = MASWRK  .AND.  NPRINT.NE.-5
C
      IF (SOME) WRITE(IW,9000) IROOT
      IF (SOME) WRITE(IW,9010) IROOT,ESTATE(IROOT)
C
C  GENERATE THE ONE PARTICLE DENSITY MATRIX FOR EACH STATE.
C
      DO 13 I=1,M2
         DM1(I) = 0.0D+00
   13 CONTINUE
C
      IF(EXETYP.EQ.CHECK) RETURN
C
C ---  BIG LOOP OVER ALL ALPHA DETERMINANTS ---
C
      CALL RESETCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX5)
C
      DO 5000 IGA=1,ITGA
C
         CALL RESETDE(LBOX1,NSPACE,NA,MSTA,IACON1)
C
C  KKA GIVES THE ACTUAL POSITION OF THE ALPHA STRING IACON1 IN
C  THE FULL ALPHA STRING LIST.
C
         DO 4900 KKA=NAST(IGA)+1,NAST(IGA+1)
            JPZA1 = LSPA(KKA)
            JASYM = LSYMA(KKA)
            KSYM=KTAB(JASYM)
C
            DO II=1,NSPACE
               LBOX2(II) = LBOX1(II)
            ENDDO
C
C  LOOP OVER SPACES TO EXCITE ELECTRON FROM.
C
            IEAS = NA+1
            DO 4890 ISPA1=NSPACE,1,-1
               IOC1 = LBOX1(ISPA1)
               IEAE = IEAS - 1
               IEAS = IEAS - IOC1
               IF (IOC1.EQ.0) GO TO 4890
               LBOX2(ISPA1) = LBOX2(ISPA1)-1
C
C  LOOP ELECTRONS IN SPACE ISPA1.
C  IEAS, IEAE ARE THE ELECTRONS IN SPACE ISPA1.
C
               DO 4885 IA1=IEAE,IEAS,-1
                  IO1 = IACON1(IA1)
                  IGAE = IEAE - LBOX1(ISPA1)
                  IS1 = IOB(IO1)
C
C  LOOP OVER POSSIBLE SPACES TO EXCITE INTO.
C
               DO 4880 ISPA2=ISPA1,NSPACE
C
C  IGAS, IGAE ARE ELECTRONS SPECIFYING ISPA2 SPACE ELECTRON LIMITS.
C
                  IGAS = IGAE + 1
                  IGAE = IGAE + LBOX1(ISPA2)
C
                  LBOX2(ISPA2) = LBOX2(ISPA2) + 1
                  IF (LBOX2(ISPA1).LT.IAMI(ISPA1)) GO TO 4870
                  IF (LBOX2(ISPA2).GT.IAMA(ISPA2)) GO TO 4870
C
C  GET GROUP NUMBER
C
           CALL POSITCO(LBOX5,NSPACE,NA,IAMA,IAMI,LBOX4,LBOX2,IGA2)
           NIAS = NAST(IGA2)
C
C  MAKE GAP INFORMATION HERE.
C
                  IGAA = MAX(IA1+1,IGAS)
                  IF (LBOX1(ISPA2).EQ.0) THEN
                     ISTA = MSTA(ISPA2)
                     IEND = MSTA(ISPA2+1)-1
                  ELSEIF (ISPA2.EQ.ISPA1) THEN
                     ISTA = IO1+1
                     IEND = IACON1(IGAA)-1
                     IF (IA1.EQ.IEAE) IEND=MSTA(ISPA1+1)-1
                  ELSE
                     ISTA = MSTA(ISPA2)
                     IEND = IACON1(IGAA)-1
                  ENDIF
C
C  LOOP OVER GAPS
C
                  DO 4860 IGAP=IGAA,IGAE+1
C
                     DO 4850 JJ=ISTA,IEND
                        IS2 = IOB(JJ)
C
C   IF DEOCCUPIED AND NEWLY OCCUPIED ORBITALS ARE OF DIFFERENT SYMMETRY,
C   SKIP.
C
              IF (IS1.NE.IS2) GO TO 4850
C
              IND = INDEX(JJ) + IO1
C
              CALL REDE00(IACON1,IACON2,NA,IA1,IGAP-1,JJ,JPERA)
              CALL IDPOST(IACON2,NA,LBOX2,NSPACE,MSTA,IDIM,X,NX,LBST,
     *                  LANDET(1,IGA2),IBCON1,JPOSA)
              KAPOS = JPOSA + NIAS
              JPZA2 = LSPA(KAPOS)
              KPER1 = (-1)**JPERA
C
C  LOOP OVER BETA STRINGS OF RIGHT SYMMETRY AND GROUP
C
              DO 4700 IGB=1,ITGB
              IF (LGCOM(IGB,IGA).NE.1.OR.LGCOM(IGB,IGA2).NE.1) GOTO 4700
              JCI1 = JPZA1 + LDISB(KSYM,IGB,IGA)
              JCI2 = JPZA2 + LDISB(KSYM,IGB,IGA2)
C
              DO 4680 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                 JCI1 = JCI1 + 1
                 JCI2 = JCI2 + 1
                 FC = CI(JCI1)*CI(JCI2)*KPER1
                 DM1(IND) = DM1(IND) + FC
 4680         CONTINUE
C
 4700         CONTINUE
C
 4850          CONTINUE
C
                  ISTA = IACON1(IGAP)+1
                  IEND = IACON1(IGAP+1)-1
                  IF (IGAP.EQ.IGAE) IEND=MSTA(ISPA2+1)-1
 4860             CONTINUE
C
 4870             LBOX2(ISPA2) = LBOX2(ISPA2) - 1
 4880          CONTINUE
C
 4885          CONTINUE
C
               LBOX2(ISPA1) = LBOX2(ISPA1)+1
 4890       CONTINUE
C
C   DIAGONAL CONTRIBUTIONS HERE.
C
            DO 67 II=1,NA
               I1 = IACON1(II)
               IND1 = INDEX(I1+1)
C
               DO 53 IGB=1,ITGB
                  IF (LGCOM(IGB,IGA).NE.1) GO TO 53
                  JCI1 = JPZA1 + LDISB(KSYM,IGB,IGA)
                  DO 58 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                     JCI1 = JCI1 + 1
                     FC = CI(JCI1)*CI(JCI1)
                     DM1(IND1) = DM1(IND1) + FC
   58             CONTINUE
   53          CONTINUE
C
   67       CONTINUE
C
            CALL MOVEUP2(LBOX1,NSPACE,NA,MSTA,IACON1)
 4900    CONTINUE
C
         CALL PUSHCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX5,IEND)
 5000 CONTINUE
C
C  --- END OF LOOP OVER ALPHA STRINGS ----
C
C  --- BIG LOOP OVER BETA -----
C
      CALL RESETCO(LBOX1,NSPACE,NB,IBMA,IBMI,LBOX5)
C
      DO 8000 IGB=1,ITGB
C
         CALL RESETDE(LBOX1,NSPACE,NB,MSTA,IBCON1)
C
C  KKB GIVES THE ACTUAL POSITION OF THE BETA STRING IBCON1 IN
C  THE FULL BETA STRING LIST.
C
         DO 7900 KKB=NBST(IGB)+1,NBST(IGB+1)
            JPZB1 = LSPB(KKB)
            KBSYM = LSYMB(KKB)
            KSYM=KTAB(KBSYM)
C
            DO II=1,NSPACE
               LBOX2(II) = LBOX1(II)
            ENDDO
C
C  LOOP OVER SPACES TO EXCITE ELECTRON FROM.
C
            IEBS = NB+1
            DO 7890 ISPB1=NSPACE,1,-1
               IOC1 = LBOX1(ISPB1)
               IEBE = IEBS - 1
               IEBS = IEBS - IOC1
               IF (IOC1.EQ.0) GO TO 7890
               LBOX2(ISPB1) = LBOX2(ISPB1)-1
C
C  LOOP ELECTRONS IN SPACE ISPB1.
C  IEBS, IEBE ARE THE ELECTRONS IN SPACE ISPB1.
C
               DO 7885 IB1=IEBE,IEBS,-1
                  IO1 = IBCON1(IB1)
                  IGBE = IEBE - LBOX1(ISPB1)
                  IS1 = IOB(IO1)
C
C  LOOP OVER POSSIBLE SPACES TO EXCITE INTO.
C
               DO 7880 ISPB2=ISPB1,NSPACE
C
C  IGBS, IGBE ARE ELECTRONS SPECIFYING ISPB2 SPACE ELECTRON LIMITS.
C
                  IGBS = IGBE + 1
                  IGBE = IGBE + LBOX1(ISPB2)
C
                  LBOX2(ISPB2) = LBOX2(ISPB2) + 1
                  IF (LBOX2(ISPB1).LT.IBMI(ISPB1)) GO TO 7870
                  IF (LBOX2(ISPB2).GT.IBMA(ISPB2)) GO TO 7870
C
C  GET GROUP NUMBER
C
           CALL POSITCO(LBOX5,NSPACE,NB,IBMA,IBMI,LBOX4,LBOX2,IGB2)
           NIBS = NBST(IGB2)
C
C  MAKE GAP INFORMATION HERE.
C
                  IGBB = MAX(IB1+1,IGBS)
                  IF (LBOX1(ISPB2).EQ.0) THEN
                     ISTA = MSTA(ISPB2)
                     IEND = MSTA(ISPB2+1)-1
                  ELSEIF (ISPB2.EQ.ISPB1) THEN
                     ISTA = IO1+1
                     IEND = IBCON1(IGBB)-1
                     IF (IB1.EQ.IEBE) IEND=MSTA(ISPB1+1)-1
                  ELSE
                     ISTA = MSTA(ISPB2)
                     IEND = IBCON1(IGBB)-1
                  ENDIF
C
C  LOOP OVER GAPS
C
                  DO 7860 IGAP=IGBB,IGBE+1
C
                     DO 7850 JJ=ISTA,IEND
                        IS2 = IOB(JJ)
                        IND = INDEX(JJ) + IO1
C
C   IF DEOCCUPIED AND NEWLY OCCUPIED ORBITALS ARE OF DIFFERENT SYMMETRY,
C   SKIP TO DOUBLES.
C
                        IF (IS1.NE.IS2) GO TO 7850
C
              CALL REDE00(IBCON1,IBCON2,NB,IB1,IGAP-1,JJ,JPERB)
C
              CALL IDPOST(IBCON2,NB,LBOX2,NSPACE,MSTA,IDIM,X,NX,LBST,
     *                  LBNDET(1,IGB2),IACON1,JPOSB)
              KBPOS = JPOSB + NIBS
              JPZB2 = LSPB(KBPOS)
              KPER1 = (-1)**JPERB
C
C  LOOP OVER ALPHA STRINGS OF THE RIGHT GROUP AND SYMMETRY.
C
              DO 7700 IGA=1,ITGA
              IF (LGCOM(IGB,IGA).NE.1.OR.LGCOM(IGB2,IGA).NE.1) GOTO 7700
                 JCIB1 = LDISB(KBSYM,IGB,IGA) + JPZB1
                 JCIB2 = LDISB(KBSYM,IGB2,IGA) + JPZB2
                 NIAS = NAST(IGA)
C
              DO 7680 KKA=LSAS(KSYM,IGA),LSAS(KSYM+1,IGA)-1
                 IENA1 = LSAC(KKA)
                 JCIA = LSPA(NIAS+IENA1)
                 JCI1 = JCIA + JCIB1
                 JCI2 = JCIA + JCIB2
C
                 FC = CI(JCI1)*CI(JCI2)*KPER1
                 DM1(IND) = DM1(IND) + FC
C
 7680         CONTINUE
 7700         CONTINUE
C
 7850                CONTINUE
C
                  ISTA = IBCON1(IGAP)+1
                  IEND = IBCON1(IGAP+1)-1
                  IF (IGAP.EQ.IGBE) IEND=MSTA(ISPB2+1)-1
 7860             CONTINUE
C
 7870             LBOX2(ISPB2) = LBOX2(ISPB2) - 1
 7880          CONTINUE
C
 7885          CONTINUE
C
               LBOX2(ISPB1) = LBOX2(ISPB1)+1
 7890       CONTINUE
C
C  REMAINING PART OF DIAGONAL CONTRIBUTIONS.
C
            DO 69 II=1,NB
               I1 = IBCON1(II)
               IND1 = INDEX(I1+1)
C
              DO 76 IGA=1,ITGA
              IF (LGCOM(IGB,IGA).NE.1) GO TO 76
                 JCIB1 = LDISB(KBSYM,IGB,IGA) + JPZB1
                 NIAS = NAST(IGA)
C
              DO 78 KKA=LSAS(KSYM,IGA),LSAS(KSYM+1,IGA)-1
                 IENA1 = LSAC(KKA)
                 JCIA = LSPA(NIAS+IENA1)
                 JCI1 = JCIA + JCIB1
C
                 FC = CI(JCI1)*CI(JCI1)
                 DM1(IND1) = DM1(IND1) + FC
C
   78         CONTINUE
   76         CONTINUE
C
   69       CONTINUE
C
            CALL MOVEUP2(LBOX1,NSPACE,NB,MSTA,IBCON1)
 7900    CONTINUE
C
         CALL PUSHCO(LBOX1,NSPACE,NB,IBMA,IBMI,LBOX5,IEND)
 8000 CONTINUE
C
      RETURN
C
 9000 FORMAT(/5X,27(1H-)/5X,'ONE PARTICLE DENSITY MATRIX'/5X,27(1H-)//
     *  1X,'DENSITY MATRIX WILL BE SAVED FOR PROPERTIES OF STATE',I4)
 9010 FORMAT(/1X,'CI EIGENSTATE',I4,' TOTAL ENERGY =',F20.10)
C
      END
C
C*MODULE ORMAS1  *DECK MASDM2
C     ----------------------------------------------------------------
      SUBROUTINE MASDM2(IW,NPRINT,IWTS,WSTATE,SPINS,IPURES,S,K,GRPDET,
     *     NCORSV,
     *     DM1,DM2,M2,M4,NACT,NCI,NA,NB,CI,AB,
     *     Y,NX,INDEX,NSYM,IOB,
     *     LBOX1,LBOX2,LBOX3,LBOX4,LBOX5,
     *     LGMUL,KTAB,IACON1,IACON2,IBCON1,IBCON2,
     *     LANDET,LBNDET,NAST,NBST,LSYMA,LSYMB,LGCOM,
     *     LSPA,LSPB,LDISB,LSAS,LSBS,LSAC,LSBC,
     *     ITGA,ITGB,IAST,IBST,
     *     IPOSA,IPERA,IIND1,IGROA,IMMC,
     *     NB1EX,JB1GR,JB1PE,JB1IN,JB1PO,JB1ST,IDIM1,IDIM2)
C     ----------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL SOME,GOPARR,DSKWRK,MASWRK,FDIRCT,QCORR,PACK2E
C
      PARAMETER (MXRT=100, MXATM=2000)
      PARAMETER (ZERO=0.0D+00)
C
      COMMON /CIFILS/ NFT11,NFT12,NFT13,NFT14,NFT15,NFT16,IDAF20,NEMEMX
      COMMON /ENRGYS/ ENUCR,EELCT,ETOT,STOT,SSQUAR,ECORE,ESCF,EERD,
     *                E1,E2,VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /FCCWFN/ NSPACE,MSTA(51),MNUM(51),MINI(51),MAXI(51),
     *                IAMI(51),IAMA(51),IBMI(51),IBMA(51),IDIM(51),
     *                LBST(51),NREF0,FDIRCT,QCORR,C0SQ
      COMMON /FUNCT / E,EGRAD(3,MXATM)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,MA,MB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /FMCOM / X(1)
      COMMON /OUTPUT/ NPRINTX,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCKLAB/ LABSIZ
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      DIMENSION IWTS(MXRT),WSTATE(MXRT),SPINS(MXRT)
      DIMENSION DM1(M2),DM2(M4)
      DIMENSION CI(NCI,K),AB(NCI,K),Y(NX)
      DIMENSION INDEX((NACT*(NACT+1))/2+1),IOB(NACT)
      DIMENSION LBOX1(NSPACE),LBOX2(NSPACE),LBOX3(NSPACE)
      DIMENSION LBOX4(NSPACE),LBOX5(NSPACE)
      DIMENSION LGMUL(NSYM,NSYM),KTAB(NSYM)
      DIMENSION IACON1(NA),IACON2(NA),IBCON1(NA),IBCON2(NA)
      DIMENSION LANDET(NSPACE,ITGA),LBNDET(NSPACE,ITGB)
      DIMENSION NAST(ITGA+1),NBST(ITGB+1)
      DIMENSION LSYMA(IAST),LSYMB(IBST),LGCOM(ITGB,ITGA)
      DIMENSION LSPA(IAST),LSPB(IBST),LDISB(NSYM,ITGB,ITGA)
      DIMENSION LSAS(NSYM+1,ITGA),LSBS(NSYM+1,ITGB)
      DIMENSION LSAC(IAST),LSBC(IBST)
      DIMENSION IPOSA(NA*(NACT-NA),NSYM)
      DIMENSION IPERA(NA*(NACT-NA),NSYM)
      DIMENSION IIND1(NA*(NACT-NA),NSYM)
      DIMENSION IGROA(NA*(NACT-NA),NSYM)
      DIMENSION IMMC(NSYM)
      DIMENSION JB1GR(NB1EX),JB1PE(NB1EX),JB1IN(NB1EX),JB1PO(NB1EX)
      DIMENSION JB1ST(IDIM1,IDIM2)
C
C  ----  STATE-AVERAGED 1E- AND 2E- DENSITY MATRIX  ----
C
      L1 = NUM
      M1 = NACT
      NOCC1 = NCORSV + NACT
      NOCC2 = (NOCC1*NOCC1+NOCC1)/2
      SOME = MASWRK  .AND.  NPRINT.NE.-5
      IF(SOME) WRITE(IW,9310)
C
      MXSTAT=0
      MXNZW=0
C
      DO 100 I=MXRT,1,-1
         IF(WSTATE(I).GT.ZERO) THEN
            IF(MXSTAT.EQ.0) MXSTAT=I
            MXNZW=MXNZW+1
         END IF
  100 CONTINUE
C
      IF(MXSTAT.EQ.0) THEN
         WRITE(IW,*) 'OOPS, IN -MASDM2-, SOMETHING HAPPENED TO WSTATE'
         CALL ABRT
      END IF
C
      IF (SOME) WRITE(IW,9320) MXNZW
C
C        SET STATE AVERAGED ENERGY, PRINT ROOT INFORMATION
C
      E = ZERO
      NXTR=0
      DO 310 IST=1,K
         IF(IPURES.EQ.1  .AND.  ABS(SPINS(IST)-S).GT.0.03D+00) GO TO 310
         NXTR=NXTR+1
         IF(WSTATE(NXTR).GT.ZERO) THEN
            E = E + WSTATE(NXTR) * ESTATE(IST)
            IF(SOME) WRITE(IW,9340) IST,ESTATE(IST),
     *                              WSTATE(NXTR),SPINS(IST)
         END IF
         IF(NXTR.GT.MXSTAT) GO TO 320
  310 CONTINUE
C
C        CROAK THE JOB IF WE DIDN'T CALCULATE ENOUGH ROOTS WITH THE
C        DESIRED SPIN MULTIPLICITY DURING THE CI DIAGONALIZATION.
C        IF THIS HAPPENS ON THE 1ST MCSCF ITER, WE'VE ALREADY GOT
C        THE CI EXPANSIONS PRINTED OUT, AND SHOULD NOT REPEAT IT.
C
      IF(NXTR.LT.MXSTAT) THEN
         IF(MASWRK) WRITE(IW,9350) NXTR,S,MXSTAT
         IF(MASWRK  .AND.  .NOT.SOME) CALL DETPRT(IW,NFT12,MASWRK)
         CALL ABRT
      END IF
C
  320 CONTINUE
C
C  COPY CI COEFFICIENTS FOR ALL STATES WITH NON-ZERO WEIGHTS INTO AB
C
      NXTW=1
      NXTR=0
      DO 620 IST=1,K
         IF (IPURES.EQ.1) THEN
            IF (ABS(SPINS(IST)-S).GT.0.03D+00) GO TO 620
            NXTR=NXTR+1
         ELSE
            NXTR=IST
         ENDIF
C
         IF (NXTR.EQ.IWTS(NXTW)) THEN
            CALL CICOPY(CI(1,IST),AB(1,NXTW),NCI)
            NXTW = NXTW + 1
         ENDIF
  620 CONTINUE
C
      DO II=1,M2
         DM1(II) = 0.0D+00
      ENDDO
      DO II=1,M4
         DM2(II) = 0.0D+00
      ENDDO
C
      NXTW = NXTW - 1
C
C  ---------  NOW TO DETERMINE STATE AVERAGED DENSITY MATRICES ---------
C
C
C  --- BIG LOOP OVER ALL ALPHA STRINGS. ---
C
      CALL RESETCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX5)
C
      DO 5000 IGA=1,ITGA
C
         CALL RESETDE(LBOX1,NSPACE,NA,MSTA,IACON1)
C
C  KKA GIVES THE ACTUAL POSITION OF THE ALPHA STRING IACON1 IN
C  THE FULL ALPHA STRING LIST.
C
         DO 4900 KKA=NAST(IGA)+1,NAST(IGA+1)
            JPZA1 = LSPA(KKA)
            JASYM = LSYMA(KKA)
            KSYM=KTAB(JASYM)
            DO II=1,NSYM
               IMMC(II)=0
            ENDDO
C
            DO II=1,NSPACE
               LBOX2(II) = LBOX1(II)
            ENDDO
C
C  LOOP OVER SPACES TO EXCITE ELECTRON FROM.
C
            IEAS = NA+1
            DO 4890 ISPA1=NSPACE,1,-1
               IOC1 = LBOX1(ISPA1)
               IEAE = IEAS - 1
               IEAS = IEAS - IOC1
               IF (IOC1.EQ.0) GO TO 4890
               LBOX2(ISPA1) = LBOX2(ISPA1)-1
C
C  LOOP ELECTRONS IN SPACE ISPA1.
C  IEAS, IEAE ARE THE ELECTRONS IN SPACE ISPA1.
C
               DO 4885 IA1=IEAE,IEAS,-1
                  IO1 = IACON1(IA1)
                  IGAE = IEAE - LBOX1(ISPA1)
                  IS1 = IOB(IO1)
C
C  LOOP OVER POSSIBLE SPACES TO EXCITE INTO.
C
               DO 4880 ISPA2=ISPA1,NSPACE
C
C  IGAS, IGAE ARE ELECTRONS SPECIFYING ISPA2 SPACE ELECTRON LIMITS.
C
                  IGAS = IGAE + 1
                  IGAE = IGAE + LBOX1(ISPA2)
C
                  LBOX2(ISPA2) = LBOX2(ISPA2) + 1
                  IF (LBOX2(ISPA1).LT.IAMI(ISPA1)) GO TO 4870
C
C  MAKE GAP INFORMATION HERE.
C
                  IGAA = MAX(IA1+1,IGAS)
                  IF (LBOX1(ISPA2).EQ.0) THEN
                     ISTA = MSTA(ISPA2)
                     IEND = MSTA(ISPA2+1)-1
                  ELSEIF (ISPA2.EQ.ISPA1) THEN
                     ISTA = IO1+1
                     IEND = IACON1(IGAA)-1
                     IF (IA1.EQ.IEAE) IEND=MSTA(ISPA1+1)-1
                  ELSE
                     ISTA = MSTA(ISPA2)
                     IEND = IACON1(IGAA)-1
                  ENDIF
C
C  LOOP OVER GAPS
C
                  DO 4860 IGAP=IGAA,IGAE+1
C
                     DO 4850 JJ=ISTA,IEND
                        IS2 = IOB(JJ)
                        IP1 = LGMUL(IS1,IS2)
C
                     IND = INDEX(JJ) + IO1
C
              CALL REDE00(IACON1,IACON2,NA,IA1,IGAP-1,JJ,JPERA)
              IF (LBOX2(ISPA2).GT.IAMA(ISPA2)) GO TO 4800
C
C  GET GROUP NUMBER
C
           CALL POSITCO(LBOX5,NSPACE,NA,IAMA,IAMI,LBOX4,LBOX2,IGA2)
           NIAS = NAST(IGA2)
C
              CALL IDPOST(IACON2,NA,LBOX2,NSPACE,MSTA,IDIM,Y,NX,LBST,
     *                  LANDET(1,IGA2),IBCON1,JPOSA)
              KAPOS = JPOSA + NIAS
              JPZA2 = LSPA(KAPOS)
              KASYM = LSYMA(KAPOS)
              KPER1 = ((-1)**JPERA)*2
              IMMC(KASYM) = IMMC(KASYM) + 1
              JSPO = IMMC(KASYM)
              IPOSA(JSPO,KASYM) = JPZA2
              IPERA(JSPO,KASYM) = KPER1
              IIND1(JSPO,KASYM) = IND
              IGROA(JSPO,KASYM) = IGA2
C
C   IF DEOCCUPIED AND NEWLY OCCUPIED ORBITALS ARE OF DIFFERENT SYMMETRY,
C   SKIP TO DOUBLES.
C
              IF (IS1.NE.IS2) GO TO 4800
C
C  LOOP OVER APPROPRIATE BETA DETS AND UPDATE THE 1E DM1
C
              DO 1700 IGB=1,ITGB
              IF (LGCOM(IGB,IGA).NE.1.OR.LGCOM(IGB,IGA2).NE.1) GOTO 1700
              JCI1 = JPZA1 + LDISB(KSYM,IGB,IGA)
              JCI2 = JPZA2 + LDISB(KSYM,IGB,IGA2)
C
              DO 1680 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                 JCI1 = JCI1 + 1
                 JCI2 = JCI2 + 1
                 FC = 0.0D+00
                 DO KKI=1,NXTW
              FC = FC + WSTATE(IWTS(KKI))*AB(JCI1,KKI)*AB(JCI2,KKI)
                 ENDDO
                 FC = FC*KPER1
                 DM1(IND) = DM1(IND) + FC
 1680         CONTINUE
C
 1700         CONTINUE
C
C   DETERMINE THE ALPHA STRING CONTRIBUTION TO THE MATRIX ELEMENT.
C
              DO 4712 IK=1,NA
                 IF (IK.EQ.IA1) GO TO 4712
                 ION = IACON1(IK)
                 J1 = INDEX(ION+1)
                 JMA = MAX(J1,IND)
                 JMI = MIN(J1,IND)
                 JJ1 = INDEX(JMA) + JMI
                 JMA = MAX(ION,JJ)
                 JMI = MIN(ION,JJ)
                 J1 = INDEX(JMA)+JMI
                 JMA = MAX(IO1,ION)
                 JMI = MIN(IO1,ION)
                 J2 = INDEX(JMA)+JMI
                 JMA = MAX(J1,J2)
                 JMI = MIN(J1,J2)
                 INX = INDEX(JMA)+JMI
C
C  LOOP OVER APPROPRIATE BETA DETS AND UPDATE THE 1E DM2
C
              DO 1705 IGB=1,ITGB
              IF (LGCOM(IGB,IGA).NE.1.OR.LGCOM(IGB,IGA2).NE.1) GOTO 1705
              JCI1 = JPZA1 + LDISB(KSYM,IGB,IGA)
              JCI2 = JPZA2 + LDISB(KSYM,IGB,IGA2)
C
              DO 1685 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                 JCI1 = JCI1 + 1
                 JCI2 = JCI2 + 1
                 FC = 0.0D+00
                 DO KKI=1,NXTW
              FC = FC + WSTATE(IWTS(KKI))*AB(JCI1,KKI)*AB(JCI2,KKI)
                 ENDDO
                 FC = FC*KPER1
                 DM2(JJ1) = DM2(JJ1) + FC
                 DM2(INX) = DM2(INX) - FC
 1685         CONTINUE
C
 1705         CONTINUE
C
 4712         CONTINUE
C
C  LOOP OVER BETA DETS OF THE RIGHT GROUP AND SYMMETRY.
C
              CALL RESETCO(LBOX3,NSPACE,NB,IBMA,IBMI,LBOX4)
C
              DO 4700 IGB=1,ITGB
              IF (LGCOM(IGB,IGA).NE.1.OR.LGCOM(IGB,IGA2).NE.1) GOTO 4690
              JCI1 = JPZA1 + LDISB(KSYM,IGB,IGA)
              JCI2 = JPZA2 + LDISB(KSYM,IGB,IGA2)
C
              CALL RESETDE(LBOX3,NSPACE,NB,MSTA,IBCON1)
              ISTB = 1
              DO 4680 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                 IENB = LSBC(KKB)
                 DO IIZ=ISTB,IENB-1
                    CALL MOVEUP2(LBOX3,NSPACE,NB,MSTA,IBCON1)
                 ENDDO
                 ISTB = IENB
                 JCI1 = JCI1 + 1
                 JCI2 = JCI2 + 1
C
                 FC = 0.0D+00
                 DO KKI=1,NXTW
              FC = FC + WSTATE(IWTS(KKI))*AB(JCI1,KKI)*AB(JCI2,KKI)
                 ENDDO
                 FC = FC*KPER1
C
                 DO 4670 IK=1,NB
                    ION = IBCON1(IK)
                    J1 = INDEX(ION+1)
                    JMA = MAX(J1,IND)
                    JMI = MIN(J1,IND)
                    JJ1 = INDEX(JMA) + JMI
                    DM2(JJ1) = DM2(JJ1) + FC
 4670            CONTINUE
C
 4680         CONTINUE
C
 4690         CALL PUSHCO(LBOX3,NSPACE,NB,IBMA,IBMI,LBOX4,IEND)
 4700         CONTINUE
C
C --  DOUBLE ALPHA EXCITATIONS START HERE  ---
C
 4800         CONTINUE
C
            IF (IA1.EQ.NA) GOTO 4850
            IF (JJ.EQ.NACT) GOTO 4850
C
            DO II=1,NSPACE
               LBOX3(II) = LBOX2(II)
            ENDDO
            IAES3 = 1
            DO KK=1,ISPA1-1
               IAES3 = IAES3 + LBOX2(KK)
            ENDDO
C
C  LOOP OVER SPACES TO EXCITE ELECTRONS FROM, MUST BE GE THAN
C  SPACE OF FIRST EXCITATION, ISPA1.
C
            DO 3890 ISPA3 = ISPA1,NSPACE
               IF (LBOX1(ISPA3).EQ.0) GOTO 3887
               IF (ISPA3.EQ.ISPA1.AND.IA1.EQ.IEAE) GOTO 3887
               IOC3 = LBOX2(ISPA3)
               IF (IOC3.EQ.0) GOTO 3887
C
               IAEE3 = IAES3 + LBOX2(ISPA3)-1
               LBOX3(ISPA3) = LBOX3(ISPA3)-1
C
C  LOOP OVER ELECTRONS IN ISPA3, WHICH ARE LARGER THAN IA1,
C  MAKING SURE IT ISN'T THE ALREADY EXCITED ELECTRON.
C
               JSTA3 = IAES3
               IF (ISPA3.EQ.ISPA1) THEN
                  JSTA3=IA1
                  IF (IGAP-1.EQ.IA1) JSTA3=JSTA3+1
               ENDIF
C
               DO 3880 IA3=JSTA3,IAEE3
                  IF (IA3.EQ.IGAP-1) GOTO 3880
                  IO3 = IACON2(IA3)
                  IS3 = IOB(IO3)
C
C  LOOP OVER SPACES TO EXCITE ELECTRON INTO.  MUST BE GE THAN
C  SPACE FIRST ELECTRON WAS EXCITED INTO.
C
                  IGAE3 = 0
                  DO JIK=1,ISPA2-1
                     IGAE3 = IGAE3 + LBOX2(JIK)
                  ENDDO
                  DO 3850 ISPA4=ISPA2,NSPACE
C
C  IGAS3, IGAE3 ARE ELECTRONS SPECIFYING ISPA4 SPACE ELECTRON LIMITS.
C
                  LBOX3(ISPA4) = LBOX3(ISPA4) + 1
                  IGAS3 = IGAE3 + 1
                  IGAE3 = IGAE3 + LBOX2(ISPA4)
                  IF (LBOX3(ISPA3).LT.IAMI(ISPA3)) GOTO 3840
                  IF (LBOX3(ISPA4).GT.IAMA(ISPA4)) GOTO 3840
                  IF (LBOX3(ISPA2).LT.IAMI(ISPA2)) GOTO 3840
                  IF (LBOX3(ISPA2).GT.IAMA(ISPA2)) GOTO 3840
C
             IF (ISPA4.EQ.ISPA2.AND.JJ.EQ.MSTA(ISPA2+1)-1) GOTO 3840
C
C  GET GROUP NUMBER
C
               CALL POSITCO(LBOX5,NSPACE,NA,IAMA,IAMI,LBOX4,LBOX3,IGA3)
               NIAS3 = NAST(IGA3)
C
C  MAKE GAP INFORMATION HERE.
C
                  IGAA3 = MAX(IGAS3,IGAP)
C
                  IF (LBOX2(ISPA4).EQ.0) THEN
                     ISTA3 = MSTA(ISPA4)
                     IEND3 = MSTA(ISPA4+1)-1
                  ELSEIF (ISPA4.EQ.ISPA2) THEN
                     ISTA3 = JJ+1
                     IEND3 = IACON2(IGAA3)-1
C
C  I AM SUSPECT ABOUT THIS NEXT LINE, WE'LL SEE WHAT HAPPENS.......
C
                     IF (IGAP-1.EQ.IGAE3) IEND3=MSTA(ISPA2+1)-1
C
                  ELSE
                     ISTA3 = MSTA(ISPA4)
                     IEND3 = IACON2(IGAA3)-1
                  ENDIF
C
C  LOOP OVER GAPS
C
                  DO 3830 IGAP3=IGAA3,IGAE3+1
C
                     DO 3820 JJ3=ISTA3,IEND3
                        IS4 = IOB(JJ3)
                        IP2 = LGMUL(IS3,IS4)
                        IF (IP1.NE.IP2) GOTO 3820
C
              CALL REDE00(IACON2,IBCON1,NA,IA3,IGAP3-1,JJ3,JPERA3)
              CALL IDPOST(IBCON1,NA,LBOX3,NSPACE,MSTA,IDIM,Y,NX,LBST,
     *                  LANDET(1,IGA3),IBCON2,JPOSA3)
              IPER3 = ((-1)**(JPERA3+JPERA))*2
              KAPOS3 = JPOSA3 + NIAS3
              JPZA3 = LSPA(KAPOS3)
                 JMA=MAX(JJ3,IO3)
                 JMI=MIN(JJ3,IO3)
                 I2 = INDEX(JMA) + JMI
                 INX = INDEX(I2) + IND
                 II1 = INDEX(JJ3) + IO1
                 JMA=MAX(IO3,JJ)
                 JMI=MIN(IO3,JJ)
                 II2 = INDEX(JMA) + JMI
                 JMA=MAX(II1,II2)
                 JMI=MIN(II1,II2)
                 INX2 = INDEX(JMA) + JMI
C
C  LOOP OVER BETA STRINGS OF RIGHT SYMMETRY AND GROUP.
C
              DO 3700 IGB=1,ITGB
              IF (LGCOM(IGB,IGA).NE.1.OR.LGCOM(IGB,IGA3).NE.1) GOTO 3700
              JCI1 = JPZA1 + LDISB(KSYM,IGB,IGA)
              JCI3 = JPZA3 + LDISB(KSYM,IGB,IGA3)
C
              DO 3680 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                 JCI1 = JCI1 + 1
                 JCI3 = JCI3 + 1
C
                 FC = 0.0D+00
                 DO KKI=1,NXTW
              FC = FC + WSTATE(IWTS(KKI))*AB(JCI1,KKI)*AB(JCI3,KKI)
                 ENDDO
                 FC = FC*IPER3
                 DM2(INX) = DM2(INX) + FC
                 DM2(INX2) = DM2(INX2) - FC
 3680         CONTINUE
C
 3700         CONTINUE
C
 3820                CONTINUE
C
                     ISTA3 = IACON2(IGAP3)+1
                     IEND3 = IACON2(IGAP3+1)-1
                     IF (IGAP3.EQ.IGAE3) IEND3=MSTA(ISPA4+1)-1
 3830             CONTINUE
C
 3840             LBOX3(ISPA4) = LBOX3(ISPA4) - 1
 3850             CONTINUE
C
 3880          CONTINUE
C
               LBOX3(ISPA3) = LBOX3(ISPA3)+1
 3887          IAES3 = IAES3 + LBOX3(ISPA3)
 3890       CONTINUE
C
 4850                CONTINUE
C
                  ISTA = IACON1(IGAP)+1
                  IEND = IACON1(IGAP+1)-1
                  IF (IGAP.EQ.IGAE) IEND=MSTA(ISPA2+1)-1
 4860             CONTINUE
C
 4870             LBOX2(ISPA2) = LBOX2(ISPA2) - 1
 4880          CONTINUE
C
 4885          CONTINUE
C
               LBOX2(ISPA1) = LBOX2(ISPA1)+1
 4890       CONTINUE
C
C  DIAGONAL ELEMENTS HERE
C
            DO 67 II=1,NA
               I1 = IACON1(II)
               IND1 = INDEX(I1+1)
C
C  LOOP OVER BETA STRINGS OF RIGHT SYMMETRY AND GROUP.
C
              DO 3705 IGB=1,ITGB
              IF (LGCOM(IGB,IGA).NE.1) GOTO 3705
              JCI1 = JPZA1 + LDISB(KSYM,IGB,IGA)
C
              DO 3685 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                 JCI1 = JCI1 + 1
C
                 FC = 0.0D+00
                 DO KKI=1,NXTW
              FC = FC + WSTATE(IWTS(KKI))*AB(JCI1,KKI)*AB(JCI1,KKI)
                 ENDDO
                 DM1(IND1) = DM1(IND1) + FC
 3685         CONTINUE
C
 3705         CONTINUE
C
              DO 64 JJ=II+1,NA
                 I2 = IACON1(JJ)
                 IND2 = INDEX(I2+1)
                 INDM = IND2 - I2 + I1
                 J1 = INDEX(INDM+1)
                 J2 = INDEX(IND2) + IND1
C
              DO 3710 IGB=1,ITGB
              IF (LGCOM(IGB,IGA).NE.1) GOTO 3710
              JCI1 = JPZA1 + LDISB(KSYM,IGB,IGA)
C
              DO 3690 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                 JCI1 = JCI1 + 1
C
                 FC = 0.0D+00
                 DO KKI=1,NXTW
              FC = FC + WSTATE(IWTS(KKI))*AB(JCI1,KKI)*AB(JCI1,KKI)
                 ENDDO
                 DM2(J1) = DM2(J1) - FC
                 DM2(J2) = DM2(J2) + FC
 3690         CONTINUE
C
 3710         CONTINUE
C
   64         CONTINUE
C
C  LOOP OVER BETA DETS OF THE RIGHT GROUP AND SYMMETRY.
C
              CALL RESETCO(LBOX3,NSPACE,NB,IBMA,IBMI,LBOX4)
C
              DO 4709 IGB=1,ITGB
              IF (LGCOM(IGB,IGA).NE.1) GOTO 4699
              JCI1 = JPZA1 + LDISB(KSYM,IGB,IGA)
C
              CALL RESETDE(LBOX3,NSPACE,NB,MSTA,IBCON1)
              ISTB = 1
              DO 4689 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                 IENB = LSBC(KKB)
                 DO IIZ=ISTB,IENB-1
                    CALL MOVEUP2(LBOX3,NSPACE,NB,MSTA,IBCON1)
                 ENDDO
                 ISTB = IENB
                 JCI1 = JCI1 + 1
C
                 FC = 0.0D+00
                 DO KKI=1,NXTW
              FC = FC + WSTATE(IWTS(KKI))*AB(JCI1,KKI)*AB(JCI1,KKI)
                 ENDDO
C
                 DO 4679 IK=1,NB
                    I2 = IBCON1(IK)
                    IND2 = INDEX(I2+1)
                    JMI = MIN(IND1,IND2)
                    JMA = MAX(IND1,IND2)
                    J2 = INDEX(JMA) + JMI
                    DM2(J2) = DM2(J2) + FC
 4679            CONTINUE
C
 4689         CONTINUE
C
 4699         CALL PUSHCO(LBOX3,NSPACE,NB,IBMA,IBMI,LBOX4,IEND)
 4709         CONTINUE
C
   67       CONTINUE
C
C  --- END OF LOOP OVER SINGLE ALPHA EXCITATIONS. ---
C      NOW TO SORT THEM BY POSITIONS WITHIN SYMMETRIES.
C
            DO II=1,NSYM
               CALL FCCSRT3(IGROA(1,II),IPERA(1,II),IIND1(1,II),
     *                   IPOSA(1,II),IMMC(II))
            ENDDO
C
C  --- END OF LOOP OVER PURE ALPHA EXCITATIONS.
C  NOW TO LOOP OVER ALL SIMULTANEOUS AB -> A'B' EXCITATIONS.
C
      IF (NSPACE.EQ.1) GOTO 3400
C
C  ***** GENERAL CASE OF MORE THAN ONE SPACE !!!!! *******
C
      IF (.NOT.FDIRCT) THEN
C
C  LOOP OVER SINGLE ALPHA EXCITES WITHIN EACH SYMMETRY.
C
      DO 3000 ISAE=1,NSYM
         KBSYM=KTAB(ISAE)
         DO 2900 JSAE=1,IMMC(ISAE)
            JPOSAE=IPOSA(JSAE,ISAE)
            JPERAE=IPERA(JSAE,ISAE)
            JINDAE=IIND1(JSAE,ISAE)
            JGROAE=IGROA(JSAE,ISAE)
C
C  IF ISAE.EQ.JASYM THEN SPECIAL CASE.
C
       IF (ISAE.EQ.JASYM.AND.IGA.EQ.JGROAE) THEN
C
C  LOOP OVER ALL RELEVANT BETAS
C
            LABPOS = JPZA1
            LABPOS2 = JPOSAE
            DO 2813 IGB=1,ITGB
               IF (LGCOM(IGB,IGA).NE.1) GOTO 2813
               NIBS = NBST(IGB)
               DO 2763 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                  LABPOS = LABPOS + 1
                  LABPOS2 = LABPOS2 + 1
                  IBPOS = NIBS + LSBC(KKB)
C
C  LOOP OVER SINGLE BETA EXCITES FROM IBPOS
C
               DO 2613 JBINDX=JB1ST(KBSYM,IBPOS),JB1ST(KBSYM+1,IBPOS)-1
                  IGB2=JB1GR(JBINDX)
                  IF (LGCOM(IGB2,JGROAE).NE.1) GOTO 2613
C
                  JMA=MAX(JINDAE,JB1IN(JBINDX))
                  JMI=MIN(JINDAE,JB1IN(JBINDX))
                  IX=INDEX(JMA)+JMI
                  JCIB=JPOSAE+LDISB(KBSYM,IGB2,JGROAE)+JB1PO(JBINDX)
                  JCIB2=JPZA1+LDISB(KBSYM,IGB2,JGROAE)+JB1PO(JBINDX)
                  FC = 0.0D+00
                  FC1 = 0.0D+00
                 DO KKI=1,NXTW
           FC = FC + WSTATE(IWTS(KKI))*AB(LABPOS,KKI)*AB(JCIB,KKI)
           FC1 = FC1 + WSTATE(IWTS(KKI))*AB(LABPOS2,KKI)*AB(JCIB2,KKI)
                 ENDDO
                  FC = FC*JPERAE*JB1PE(JBINDX)
                  FC1 = FC1*JPERAE*JB1PE(JBINDX)
                  DM2(IX) = DM2(IX) + FC + FC1
C
 2613          CONTINUE
C
 2763          CONTINUE
 2813       CONTINUE
C
       ELSE
C
C  LOOP OVER ALL RELEVANT (A-)BETA DETS.
C
            LABPOS = JPZA1
            DO 2800 IGB=1,ITGB
               IF (LGCOM(IGB,IGA).NE.1) GOTO 2800
               NIBS = NBST(IGB)
               DO 2750 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                  LABPOS = LABPOS + 1
                  IBPOS = NIBS + LSBC(KKB)
C
C  LOOP OVER SINGLE BETA EXCITES FROM IBPOS
C
               DO 2600 JBINDX=JB1ST(KBSYM,IBPOS),JB1ST(KBSYM+1,IBPOS)-1
                  IGB2=JB1GR(JBINDX)
                  IF (LGCOM(IGB2,JGROAE).NE.1) GOTO 2600
C
                  JMA=MAX(JINDAE,JB1IN(JBINDX))
                  JMI=MIN(JINDAE,JB1IN(JBINDX))
                  IX=INDEX(JMA)+JMI
                  JCIB=JPOSAE+LDISB(KBSYM,IGB2,JGROAE)+JB1PO(JBINDX)
                  FC = 0.0D+00
                 DO KKI=1,NXTW
              FC = FC + WSTATE(IWTS(KKI))*AB(LABPOS,KKI)*AB(JCIB,KKI)
                 ENDDO
                  FC = FC*JPERAE*JB1PE(JBINDX)
                  DM2(IX) = DM2(IX) + FC
C
 2600          CONTINUE
C
 2750          CONTINUE
 2800       CONTINUE
C
C  LOOP OVER ALL RELEVANT (A'-)BETA DETS.
C
            LABPOS = JPOSAE
            DO 2803 IGB=1,ITGB
               IF (LGCOM(IGB,JGROAE).NE.1) GOTO 2803
               NIBS = NBST(IGB)
               DO 2753 KKB=LSBS(KBSYM,IGB),LSBS(KBSYM+1,IGB)-1
                  LABPOS = LABPOS + 1
                  IBPOS = NIBS + LSBC(KKB)
C
C  LOOP OVER SINGLE BETA EXCITES FROM IBPOS
C
               DO 2603 JBINDX=JB1ST(KSYM,IBPOS),JB1ST(KSYM+1,IBPOS)-1
                  IGB2=JB1GR(JBINDX)
                  IF (LGCOM(IGB2,IGA).NE.1) GOTO 2603
C
                  JMA=MAX(JINDAE,JB1IN(JBINDX))
                  JMI=MIN(JINDAE,JB1IN(JBINDX))
                  IX=INDEX(JMA)+JMI
                  JCIB=JPZA1+LDISB(KSYM,IGB2,IGA)+JB1PO(JBINDX)
                  FC = 0.0D+00
                 DO KKI=1,NXTW
              FC = FC + WSTATE(IWTS(KKI))*AB(LABPOS,KKI)*AB(JCIB,KKI)
                 ENDDO
                  FC = FC*JPERAE*JB1PE(JBINDX)
                  DM2(IX) = DM2(IX) + FC
C
 2603          CONTINUE
C
 2753          CONTINUE
 2803       CONTINUE
C
      ENDIF
C
 2900    CONTINUE
 3000 CONTINUE
C
      ELSE
C
C  ***** DIRECT METHOD BELOW *****
C
      DO 4000 ISAE=1,NSYM
         KBSYM = KTAB(ISAE)
C
C  ANALYSE EXCITED A' GROUPS FOR COMPATIBILITY WITH B.
C
      NGRPS = 0
      DO 1976 II=1,IMMC(ISAE)
         ICGR = IGROA(II,ISAE)
         DO JJ=1,NGRPS
            IF (JB1GR(JJ).EQ.ICGR) GOTO 1976
         ENDDO
         NGRPS = NGRPS + 1
         JB1GR(NGRPS) = ICGR
 1976 CONTINUE
C
C FIRST TYPE OF BETAS, KSYM -> KBSYM
C
          CALL RESETCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3)
          DO 7400 IGB=1,ITGB
             IF (LGCOM(IGB,IGA).NE.1) GOTO 7399
             LAB1 = JPZA1 + LDISB(KSYM,IGB,IGA)
C
             CALL RESETDE(LBOX2,NSPACE,NB,MSTA,IBCON1)
             NIBS = NBST(IGB)
             ISTB = 1
             DO 7300 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
                IENB = LSBC(KKB)
                DO IIZ=ISTB,IENB-1
                   CALL MOVEUP2(LBOX2,NSPACE,NB,MSTA,IBCON1)
                ENDDO
                ISTB = IENB
C
                IBPOS = NIBS + LSBC(KKB)
                LABPOS = LAB1 + LSPB(IBPOS)
C
C LOOP OVER SINGLE BETA EXCITES FROM IBPOS WHICH ARE OF SYMMETRY KBSYM
C
                MESYM1 = LGMUL(KSYM,KBSYM)
                DO II=1,NSPACE
                   LBOX3(II) = LBOX2(II)
                ENDDO
                IEBS = NB + 1
                DO 7290 ISPB1=NSPACE,1,-1
                   IOC1 = LBOX2(ISPB1)
                   IEBE = IEBS - 1
                   IEBS = IEBS - IOC1
                   IF (IOC1.EQ.0) GO TO 7290
                   LBOX3(ISPB1) = LBOX3(ISPB1)-1
C
C  LOOP ELECTRONS IN SPACE ISPB1
C  IEBS, IEBE ARE THE ELECTRONS IN SPACE ISPB1
C
                DO 7285 IB1 = IEBE,IEBS,-1
                   IO1 = IBCON1(IB1)
                   MESYM2 = LGMUL(MESYM1,IOB(IO1))
                   IGBE = IEBE - LBOX2(ISPB1)
C
C  LOOP OVER POSSIBLE SPACES TO EXCITE INTO.
C
                DO 7280 ISPB2=ISPB1,NSPACE
C
C  IGBS,IGBE ARE ELECTRONS SPECIFYING ISPB2 SPACE ELECTRON LIMITS.
C
                   IGBS = IGBE + 1
                   IGBE = IGBE + LBOX2(ISPB2)
C
                   LBOX3(ISPB2) = LBOX3(ISPB2) + 1
                   IF (LBOX3(ISPB1).LT.IBMI(ISPB1)) GO TO 7270
                   IF (LBOX3(ISPB2).GT.IBMA(ISPB2)) GO TO 7270
C
C  GET GROUP NUMBER
C
          CALL POSITCO(LBOX5,NSPACE,NB,IBMA,IBMI,LBOX4,LBOX3,IGB2)
          NIAS = NBST(IGB2)
C
C CHECK FOR A' GROUP COMPATIBILITY
C
             DO II=1,NGRPS
                IAGRP = JB1GR(II)
                IF (LGCOM(IGB2,IAGRP).EQ.1) GOTO 7555
             ENDDO
             GOTO 7270
 7555        CONTINUE
C
C  MAKE GAP INFORMATION HERE.
C
                  IGBA = MAX(IB1+1,IGBS)
                  IF (LBOX2(ISPB2).EQ.0) THEN
                     ISTA = MSTA(ISPB2)
                     IEND = MSTA(ISPB2+1)-1
                  ELSEIF (ISPB2.EQ.ISPB1) THEN
                     ISTA = IO1+1
                     IEND = IBCON1(IGBA)-1
                     IF (IB1.EQ.IEBE) IEND=MSTA(ISPB1+1)-1
                  ELSE
                     ISTA = MSTA(ISPB2)
                     IEND = IBCON1(IGBA)-1
                  ENDIF
C
C  LOOP OVER GAPS
C
                  DO 7260 IGAP=IGBA,IGBE+1
C
                     DO 7250 JJ=ISTA,IEND
C
C CHECK TO SEE IF EXCITED BETA IS OF RIGHT SYMMETRY (KBSYM)
C
            IF (IOB(JJ).NE.MESYM2) GOTO 7250
C
            IND1 = INDEX(JJ) + IO1
            CALL REDE00(IBCON1,IBCON2,NB,IB1,IGAP-1,JJ,IPER)
            CALL IDPOST(IBCON2,NB,LBOX3,NSPACE,MSTA,IDIM,Y,NX,LBST,
     *                  LBNDET(1,IGB2),IACON2,IPOSB)
            QJPER = ((-1)**IPER)
            JB1P = LSPB(IPOSB + NIAS)
C
            DO 3900 JSAE=1,IMMC(ISAE)
               JGROAE=IGROA(JSAE,ISAE)
               IF (LGCOM(IGB2,JGROAE).NE.1) GOTO 3900
C
               JPOSAE=IPOSA(JSAE,ISAE)
               JCIB = JB1P + JPOSAE + LDISB(KBSYM,IGB2,JGROAE)
C
               JINDAE=IIND1(JSAE,ISAE)
               JMA=MAX(JINDAE,IND1)
               JMI=MIN(JINDAE,IND1)
               IX=INDEX(JMA)+JMI
C
               JPERAE=IPERA(JSAE,ISAE)
C
             FC=0.0D+00
             DO KKI=1,NXTW
            FC = FC + WSTATE(IWTS(KKI))*AB(LABPOS,KKI)*AB(JCIB,KKI)
             ENDDO
             FC = FC*JPERAE*QJPER
             DM2(IX) = DM2(IX) + FC
C
 3900       CONTINUE
C
 7250                CONTINUE
C
                  ISTA = IBCON1(IGAP)+1
                  IEND = IBCON1(IGAP+1)-1
                  IF (IGAP.EQ.IGBE) IEND=MSTA(ISPB2+1)-1
 7260             CONTINUE
C
 7270              LBOX3(ISPB2) = LBOX3(ISPB2) - 1
 7280           CONTINUE
C
 7285           CONTINUE
C
                   LBOX3(ISPB1) = LBOX3(ISPB1) + 1
 7290           CONTINUE
C
 7300        CONTINUE
C
 7399        CALL PUSHCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3,IEND)
 7400     CONTINUE
C
C
C SECOND TYPE OF BETAS, KBSYM -> KSYM
C
          CALL RESETCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3)
          DO 7801 IGB=1,ITGB
C
C CHECK FOR A' GROUP COMPATIBILITY
C
             DO II=1,NGRPS
                IAGRP = JB1GR(II)
                IF (LGCOM(IGB,IAGRP).EQ.1) GOTO 7655
             ENDDO
             GOTO 7799
 7655        CONTINUE
C
             CALL RESETDE(LBOX2,NSPACE,NB,MSTA,IBCON1)
             NIBS = NBST(IGB)
             ISTB = 1
C
             DO 7701 KKB=LSBS(KBSYM,IGB),LSBS(KBSYM+1,IGB)-1
                IENB = LSBC(KKB)
                DO IIZ=ISTB,IENB-1
                   CALL MOVEUP2(LBOX2,NSPACE,NB,MSTA,IBCON1)
                ENDDO
                ISTB = IENB
C
                IBPOS = NIBS + LSBC(KKB)
                LAB1 = LSPB(IBPOS)
C
C LOOP OVER SINGLE BETA EXCITES FROM IBPOS WHICH ARE OF SYMMETRY KSYM
C
                MESYM1 = LGMUL(KSYM,KBSYM)
                DO II=1,NSPACE
                   LBOX3(II) = LBOX2(II)
                ENDDO
                IEBS = NB + 1
                DO 7691 ISPB1=NSPACE,1,-1
                   IOC1 = LBOX2(ISPB1)
                   IEBE = IEBS - 1
                   IEBS = IEBS - IOC1
                   IF (IOC1.EQ.0) GO TO 7691
                   LBOX3(ISPB1) = LBOX3(ISPB1)-1
C
C  LOOP ELECTRONS IN SPACE ISPB1
C  IEBS, IEBE ARE THE ELECTRONS IN SPACE ISPB1
C
                DO 7686 IB1 = IEBE,IEBS,-1
                   IO1 = IBCON1(IB1)
                   MESYM2 = LGMUL(MESYM1,IOB(IO1))
                   IGBE = IEBE - LBOX2(ISPB1)
C
C  LOOP OVER POSSIBLE SPACES TO EXCITE INTO.
C
                DO 7681 ISPB2=ISPB1,NSPACE
C
C  IGBS,IGBE ARE ELECTRONS SPECIFYING ISPB2 SPACE ELECTRON LIMITS.
C
                   IGBS = IGBE + 1
                   IGBE = IGBE + LBOX2(ISPB2)
C
                   LBOX3(ISPB2) = LBOX3(ISPB2) + 1
                   IF (LBOX3(ISPB1).LT.IBMI(ISPB1)) GO TO 7671
                   IF (LBOX3(ISPB2).GT.IBMA(ISPB2)) GO TO 7671
C
          CALL POSITCO(LBOX5,NSPACE,NB,IBMA,IBMI,LBOX4,LBOX3,IGB2)
          IF (LGCOM(IGB2,IGA).NE.1) GOTO 7671
          JCIBS = JPZA1 + LDISB(KSYM,IGB2,IGA)
          NIAS = NBST(IGB2)
C
C  MAKE GAP INFORMATION HERE.
C
                  IGBA = MAX(IB1+1,IGBS)
                  IF (LBOX2(ISPB2).EQ.0) THEN
                     ISTA = MSTA(ISPB2)
                     IEND = MSTA(ISPB2+1)-1
                  ELSEIF (ISPB2.EQ.ISPB1) THEN
                     ISTA = IO1+1
                     IEND = IBCON1(IGBA)-1
                     IF (IB1.EQ.IEBE) IEND=MSTA(ISPB1+1)-1
                  ELSE
                     ISTA = MSTA(ISPB2)
                     IEND = IBCON1(IGBA)-1
                  ENDIF
C
C  LOOP OVER GAPS
C
                  DO 7660 IGAP=IGBA,IGBE+1
C
                     DO 7650 JJ=ISTA,IEND
C
C CHECK TO SEE IF EXCITED BETA IS OF RIGHT SYMMETRY (KBSYM)
C
            IF (IOB(JJ).NE.MESYM2) GOTO 7650
C
            IND1 = INDEX(JJ) + IO1
            CALL REDE00(IBCON1,IBCON2,NB,IB1,IGAP-1,JJ,IPER)
            CALL IDPOST(IBCON2,NB,LBOX3,NSPACE,MSTA,IDIM,Y,NX,LBST,
     *                  LBNDET(1,IGB2),IACON2,IPOSB)
            QJPER = ((-1)**IPER)
            JCIB= JCIBS + LSPB(IPOSB + NIAS)
C
            DO 4300 JSAE=1,IMMC(ISAE)
               JGROAE=IGROA(JSAE,ISAE)
               IF (LGCOM(IGB,JGROAE).NE.1) GOTO 4300
C
               JPOSAE=IPOSA(JSAE,ISAE)
               LABPOS = LAB1 + JPOSAE + LDISB(KBSYM,IGB,JGROAE)
C
               JINDAE=IIND1(JSAE,ISAE)
               JMA=MAX(JINDAE,IND1)
               JMI=MIN(JINDAE,IND1)
               IX=INDEX(JMA)+JMI
C
               JPERAE=IPERA(JSAE,ISAE)
               FC = 0.0D+00
               DO KKI=1,NXTW
            FC = FC + WSTATE(IWTS(KKI))*AB(LABPOS,KKI)*AB(JCIB,KKI)
               ENDDO
               FC = FC*JPERAE*QJPER
               DM2(IX) = DM2(IX) + FC
C
 4300       CONTINUE
C
 7650                CONTINUE
C
                  ISTA = IBCON1(IGAP)+1
                  IEND = IBCON1(IGAP+1)-1
                  IF (IGAP.EQ.IGBE) IEND=MSTA(ISPB2+1)-1
 7660             CONTINUE
C
 7671              LBOX3(ISPB2) = LBOX3(ISPB2) - 1
 7681           CONTINUE
C
 7686           CONTINUE
C
                   LBOX3(ISPB1) = LBOX3(ISPB1) + 1
 7691           CONTINUE
C
 7701        CONTINUE
C
 7799        CALL PUSHCO(LBOX2,NSPACE,NB,IBMA,IBMI,LBOX3,IEND)
 7801     CONTINUE
C
 4000 CONTINUE
C
      ENDIF
C
C  ***** END OF DIRECT OPTION *****
C
C  **** END OF GENERAL CASE OF MORE THAN ONE SPACE ******
C
      GOTO 4899
C
 3400 CONTINUE
C
C ***** SPECIAL CASE OF ONE SPACE !!!!! ******
C
C  LOOP OVER SINGLE ALPHA EXCITES WITHIN EACH SYMMETRY.
C
       DO 2901 ISAE=1,NSYM
          KBSYM=KTAB(ISAE)
          DO 2801 JSAE=1,IMMC(ISAE)
                JPOSAE=IPOSA(JSAE,ISAE)
                JPERAE=IPERA(JSAE,ISAE)
                JINDAE=IIND1(JSAE,ISAE)
                JGROAE=IGROA(JSAE,ISAE)
C
C  IF ISAE.EQ.JASYM THEN SPECIAL CASE.
C
       IF (ISAE.EQ.JASYM) THEN
C
C  LOOP OVER ALL RELEVANT BETAS
C
             LABPOS=JPZA1
             LABPOS2=JPOSAE
                DO 2721 KKB=LSBS(KSYM,1),LSBS(KSYM+1,1)-1
                    LABPOS = LABPOS + 1
                    LABPOS2 = LABPOS2 + 1
                    IBPOS =  LSBC(KKB)
C
C  LOOP OVER SINGLE BETA EXCITES FROM IBPOS
C
               DO 2621 JBINDX=JB1ST(KSYM,IBPOS),JB1ST(KSYM+1,IBPOS)-1
                  JMA=MAX(JINDAE,JB1IN(JBINDX))
                  JMI=MIN(JINDAE,JB1IN(JBINDX))
                  IX=INDEX(JMA)+JMI
                  JCIB = JPOSAE+JB1PO(JBINDX)
                  JCIB2 = JPZA1+JB1PO(JBINDX)
                  FC = 0.0D+00
                  FC1 = 0.0D+00
                 DO KKI=1,NXTW
          FC = FC + WSTATE(IWTS(KKI))*AB(LABPOS,KKI)*AB(JCIB,KKI)
          FC1 = FC1 + WSTATE(IWTS(KKI))*AB(LABPOS2,KKI)*AB(JCIB2,KKI)
                 ENDDO
                  FC = FC*JPERAE*JB1PE(JBINDX)
                  FC1 = FC1*JPERAE*JB1PE(JBINDX)
                  DM2(IX) = DM2(IX) + FC + FC1
C
 2621          CONTINUE
C
 2721          CONTINUE
C
      ELSE
C
C  LOOP OVER ALL RELEVANT (A-)BETA DETS.
C
                LABPOS = JPZA1
                DO 2751 KKB=LSBS(KSYM,1),LSBS(KSYM+1,1)-1
                    LABPOS = LABPOS + 1
                    IBPOS =  LSBC(KKB)
C
C  LOOP OVER SINGLE BETA EXCITES FROM IBPOS
C
               DO 2601 JBINDX=JB1ST(KBSYM,IBPOS),JB1ST(KBSYM+1,IBPOS)-1
C
                  JMA=MAX(JINDAE,JB1IN(JBINDX))
                  JMI=MIN(JINDAE,JB1IN(JBINDX))
                  IX=INDEX(JMA)+JMI
                  JCIB=JPOSAE+JB1PO(JBINDX)
                  FC = 0.0D+00
                 DO KKI=1,NXTW
              FC = FC + WSTATE(IWTS(KKI))*AB(LABPOS,KKI)*AB(JCIB,KKI)
                 ENDDO
                  FC = FC*JPERAE*JB1PE(JBINDX)
                  DM2(IX) = DM2(IX) + FC
C
 2601          CONTINUE
C
 2751          CONTINUE
C
C  LOOP OVER ALL RELEVANT (A'-)BETA DETS.
C
               LABPOS = JPOSAE
               DO 2761 KKB=LSBS(KBSYM,1),LSBS(KBSYM+1,1)-1
                  LABPOS = LABPOS + 1
                  IBPOS = LSBC(KKB)
C
C  LOOP OVER SINGLE BETA EXCITES FROM IBPOS
C
               DO 2611 JBINDX=JB1ST(KSYM,IBPOS),JB1ST(KSYM+1,IBPOS)-1
C
                  JMA=MAX(JINDAE,JB1IN(JBINDX))
                  JMI=MIN(JINDAE,JB1IN(JBINDX))
                  IX=INDEX(JMA)+JMI
                  JCIB=JPZA1+JB1PO(JBINDX)
                  FC = 0.0D+00
                 DO KKI=1,NXTW
              FC = FC + WSTATE(IWTS(KKI))*AB(LABPOS,KKI)*AB(JCIB,KKI)
                 ENDDO
                  FC = FC*JPERAE*JB1PE(JBINDX)
                  DM2(IX) = DM2(IX) + FC
C
 2611          CONTINUE
C
 2761          CONTINUE
C
      ENDIF
C
 2801       CONTINUE
 2901   CONTINUE
C
C  **** END OF SPECIAL CASE OF ONE SPACE *******
C
 4899       CALL MOVEUP2(LBOX1,NSPACE,NA,MSTA,IACON1)
 4900    CONTINUE
C
         CALL PUSHCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX5,IEND)
 5000 CONTINUE
C
C  --- END OF LOOP OVER ALPHA STRINGS. ---
C **
C  --- LOOP OVER ALL PURE BETA EXCITATIONS.
C
      CALL RESETCO(LBOX1,NSPACE,NB,IBMA,IBMI,LBOX5)
C
      DO 8000 IGB=1,ITGB
C
         CALL RESETDE(LBOX1,NSPACE,NB,MSTA,IBCON1)
C
C  KKB GIVES THE ACTUAL POSITION OF THE BETA STRING IBCON1 IN
C  THE FULL BETA STRING LIST.
C
         DO 7900 KKB=NBST(IGB)+1,NBST(IGB+1)
            JPZB1 = LSPB(KKB)
            KBSYM = LSYMB(KKB)
            KSYM=KTAB(KBSYM)
C
            DO II=1,NSPACE
               LBOX2(II) = LBOX1(II)
            ENDDO
C
C  LOOP OVER SPACES TO EXCITE ELECTRON FROM.
C
            IEBS = NB+1
            DO 7890 ISPB1=NSPACE,1,-1
               IOC1 = LBOX1(ISPB1)
               IEBE = IEBS - 1
               IEBS = IEBS - IOC1
               IF (IOC1.EQ.0) GOTO 7890
               LBOX2(ISPB1) = LBOX2(ISPB1)-1
C
C  LOOP ELECTRONS IN SPACE ISPB1.
C  IEBS, IEBE ARE THE ELECTRONS IN SPACE ISPB1.
C
               DO 7885 IB1=IEBE,IEBS,-1
                  IO1 = IBCON1(IB1)
                  IGBE = IEBE - LBOX1(ISPB1)
                  IS1 = IOB(IO1)
C
C  LOOP OVER POSSIBLE SPACES TO EXCITE INTO.
C
               DO 7880 ISPB2=ISPB1,NSPACE
C
C  IGBS, IGBE ARE ELECTRONS SPECIFYING ISPB2 SPACE ELECTRON LIMITS.
C
                  IGBS = IGBE + 1
                  IGBE = IGBE + LBOX1(ISPB2)
C
                  LBOX2(ISPB2) = LBOX2(ISPB2) + 1
                  IF (LBOX2(ISPB1).LT.IBMI(ISPB1)) GOTO 7870
C
C  MAKE GAP INFORMATION HERE.
C
                  IGBB = MAX(IB1+1,IGBS)
                  IF (LBOX1(ISPB2).EQ.0) THEN
                     ISTA = MSTA(ISPB2)
                     IEND = MSTA(ISPB2+1)-1
                  ELSEIF (ISPB2.EQ.ISPB1) THEN
                     ISTA = IO1+1
                     IEND = IBCON1(IGBB)-1
                     IF (IB1.EQ.IEBE) IEND=MSTA(ISPB1+1)-1
                  ELSE
                     ISTA = MSTA(ISPB2)
                     IEND = IBCON1(IGBB)-1
                  ENDIF
C
C  LOOP OVER GAPS
C
                  DO 7860 IGAP=IGBB,IGBE+1
C
                     DO 7850 JJ=ISTA,IEND
                        IS2 = IOB(JJ)
                        IP1 = LGMUL(IS1,IS2)
                        IND = INDEX(JJ) + IO1
C
              CALL REDE00(IBCON1,IBCON2,NB,IB1,IGAP-1,JJ,JPERB)
                  IF (LBOX2(ISPB2).GT.IBMA(ISPB2)) GOTO 7800
C
C   IF DEOCCUPIED AND NEWLY OCCUPIED ORBITALS ARE OF DIFFERENT SYMMETRY,
C   SKIP TO DOUBLES.
C
              IF (IS1.NE.IS2) GOTO 7800
C
C  GET GROUP NUMBER
C
           CALL POSITCO(LBOX5,NSPACE,NB,IBMA,IBMI,LBOX4,LBOX2,IGB2)
           NIBS = NBST(IGB2)
C
              CALL IDPOST(IBCON2,NB,LBOX2,NSPACE,MSTA,IDIM,Y,NX,LBST,
     *                  LBNDET(1,IGB2),IACON1,JPOSB)
              KBPOS = JPOSB + NIBS
              JPZB2 = LSPB(KBPOS)
              KPER1 = ((-1)**JPERB)*2
C
C  LOOP OVER ALPHA AND UPDATE DM
C
              DO 7705 IGA=1,ITGA
              IF (LGCOM(IGB,IGA).NE.1.OR.LGCOM(IGB2,IGA).NE.1) GOTO 7705
                 JCIB1 = LDISB(KBSYM,IGB,IGA) + JPZB1
                 JCIB2 = LDISB(KBSYM,IGB2,IGA) + JPZB2
                 NIAS = NAST(IGA)
C
              DO 7685 KKA=LSAS(KSYM,IGA),LSAS(KSYM+1,IGA)-1
                 IENA1 = LSAC(KKA)
                 JCIA = LSPA(NIAS+IENA1)
                 JCI1 = JCIA + JCIB1
                 JCI2 = JCIA + JCIB2
                 FC = 0.0D+00
                 DO KKI=1,NXTW
              FC = FC + WSTATE(IWTS(KKI))*AB(JCI1,KKI)*AB(JCI2,KKI)
                 ENDDO
                 FC = FC*KPER1
                 DM1(IND) = DM1(IND) + FC
 7685         CONTINUE
C
 7705         CONTINUE
C
              DO 7712 IK=1,NB
                 IF (IK.EQ.IB1) GOTO 7712
                 ION = IBCON1(IK)
                 J1 = INDEX(ION+1)
                 JMA = MAX(J1,IND)
                 JMI = MIN(J1,IND)
                 JJ1 = INDEX(JMA) + JMI
                 JMA = MAX(ION,JJ)
                 JMI = MIN(ION,JJ)
                 J1 = INDEX(JMA)+JMI
                 JMA = MAX(IO1,ION)
                 JMI = MIN(IO1,ION)
                 J2 = INDEX(JMA)+JMI
                 JMA = MAX(J1,J2)
                 JMI = MIN(J1,J2)
                 INX = INDEX(JMA)+JMI
C
              DO 7710 IGA=1,ITGA
              IF (LGCOM(IGB,IGA).NE.1.OR.LGCOM(IGB2,IGA).NE.1) GOTO 7710
                 JCIB1 = LDISB(KBSYM,IGB,IGA) + JPZB1
                 JCIB2 = LDISB(KBSYM,IGB2,IGA) + JPZB2
                 NIAS = NAST(IGA)
C
              DO 7695 KKA=LSAS(KSYM,IGA),LSAS(KSYM+1,IGA)-1
                 IENA1 = LSAC(KKA)
                 JCIA = LSPA(NIAS+IENA1)
                 JCI1 = JCIA + JCIB1
                 JCI2 = JCIA + JCIB2
                 FC = 0.0D+00
                 DO KKI=1,NXTW
              FC = FC + WSTATE(IWTS(KKI))*AB(JCI1,KKI)*AB(JCI2,KKI)
                 ENDDO
                 FC = FC*KPER1
                 DM2(JJ1) = DM2(JJ1) + FC
                 DM2(INX) = DM2(INX) - FC
 7695         CONTINUE
C
 7710         CONTINUE
C
 7712         CONTINUE
C
C  LOOP OVER ALPHA STRINGS OF THE RIGHT GROUP AND SYMMETRY.
C
              CALL RESETCO(LBOX3,NSPACE,NA,IAMA,IAMI,LBOX4)
C
              DO 7700 IGA=1,ITGA
              IF (LGCOM(IGB,IGA).NE.1.OR.LGCOM(IGB2,IGA).NE.1) GOTO 7690
                 JCIB1 = LDISB(KBSYM,IGB,IGA) + JPZB1
                 JCIB2 = LDISB(KBSYM,IGB2,IGA) + JPZB2
                 NIAS = NAST(IGA)
C
              CALL RESETDE(LBOX3,NSPACE,NA,MSTA,IACON1)
              ISTA1 = 1
              DO 7680 KKA=LSAS(KSYM,IGA),LSAS(KSYM+1,IGA)-1
                 IENA1 = LSAC(KKA)
                 DO IIZ=ISTA1,IENA1-1
                    CALL MOVEUP2(LBOX3,NSPACE,NA,MSTA,IACON1)
                 ENDDO
                 ISTA1 = IENA1
                 JCIA = LSPA(NIAS+IENA1)
                 JCI1 = JCIA + JCIB1
                 JCI2 = JCIA + JCIB2
                 FC = 0.0D+00
                 DO KKI=1,NXTW
              FC = FC + WSTATE(IWTS(KKI))*AB(JCI1,KKI)*AB(JCI2,KKI)
                 ENDDO
                 FC = FC*KPER1
C
                 DO 7670 IK=1,NA
                    ION = IACON1(IK)
                    J1 = INDEX(ION+1)
                    JMA = MAX(J1,IND)
                    JMI = MIN(J1,IND)
                    JJ1 = INDEX(JMA) + JMI
                    DM2(JJ1) = DM2(JJ1) + FC
 7670            CONTINUE
C
 7680         CONTINUE
C
 7690         CALL PUSHCO(LBOX3,NSPACE,NA,IAMA,IAMI,LBOX4,IEND)
 7700         CONTINUE
C
C  --- DOUBLE EXCITATIONS START HERE
C
 7800         CONTINUE
C
           IF (IB1.EQ.NB) GOTO 7850
           IF (JJ.EQ.NACT) GOTO 7850
C
            DO II=1,NSPACE
               LBOX3(II) = LBOX2(II)
            ENDDO
            IBES3 = 1
            DO KK=1,ISPB1-1
               IBES3 = IBES3 + LBOX2(KK)
            ENDDO
C
C  LOOP OVER SPACES TO EXCITE ELECTRONS FROM, MUST BE GE THAN
C  SPACE OF FIRST EXCITATION, ISPB1.
C
            DO 6890 ISPB3 = ISPB1,NSPACE
               IF (LBOX1(ISPB3).EQ.0) GOTO 6887
               IF (ISPB3.EQ.ISPB1.AND.IB1.EQ.IEBE) GOTO 6887
               IOC3 = LBOX2(ISPB3)
               IF (IOC3.EQ.0) GOTO 6887
C
               IBEE3 = IBES3 + LBOX2(ISPB3)-1
               LBOX3(ISPB3) = LBOX3(ISPB3)-1
C
C  LOOP OVER ELECTRONS IN ISPB3, WHICH ARE LARGER THAN IB1,
C  MAKING SURE IT ISN'T THE ALREADY EXCITED ELECTRON.
C
               JSTB3 = IBES3
               IF (ISPB3.EQ.ISPB1) THEN
                  JSTB3=IB1
                  IF (IGAP-1.EQ.IB1) JSTB3=JSTB3+1
               ENDIF
C
               DO 6880 IB3=JSTB3,IBEE3
                  IF (IB3.EQ.IGAP-1) GOTO 6880
                  IO3 = IBCON2(IB3)
                  IS3 = IOB(IO3)
C
C  LOOP OVER SPACES TO EXCITE ELECTRON INTO.  MUST BE GE THAN
C  SPACE FIRST ELECTRON WAS EXCITED INTO.
C
                  IGBE3 = 0
                  DO JIK=1,ISPB2-1
                     IGBE3 = IGBE3 + LBOX2(JIK)
                  ENDDO
                  DO 6850 ISPB4=ISPB2,NSPACE
C
C  IGBS3, IGBE3 ARE ELECTRONS SPECIFYING ISPB4 SPACE ELECTRON LIMITS.
C
                  LBOX3(ISPB4) = LBOX3(ISPB4) + 1
                  IGBS3 = IGBE3 + 1
                  IGBE3 = IGBE3 + LBOX2(ISPB4)
                  IF (LBOX3(ISPB3).LT.IBMI(ISPB3)) GOTO 6840
                  IF (LBOX3(ISPB4).GT.IBMA(ISPB4)) GOTO 6840
                  IF (LBOX3(ISPB2).LT.IBMI(ISPB2)) GOTO 6840
                  IF (LBOX3(ISPB2).GT.IBMA(ISPB2)) GOTO 6840
C
             IF (ISPB4.EQ.ISPB2.AND.JJ.EQ.MSTA(ISPB2+1)-1) GOTO 6840
C
C  GET GROUP NUMBER
C
               CALL POSITCO(LBOX5,NSPACE,NB,IBMA,IBMI,LBOX4,LBOX3,IGB3)
               NIBS3 = NBST(IGB3)
C
C  MAKE GAP INFORMATION HERE.
C
                  IGBB3 = MAX(IGBS3,IGAP)
C
                  IF (LBOX2(ISPB4).EQ.0) THEN
                     ISTA3 = MSTA(ISPB4)
                     IEND3 = MSTA(ISPB4+1)-1
                  ELSEIF (ISPB4.EQ.ISPB2) THEN
                     ISTA3 = JJ+1
                     IEND3 = IBCON2(IGBB3)-1
C
C  I AM SUSPECT ABOUT THIS NEXT LINE, WE'LL SEE WHAT HAPPENS.......
C
                     IF (IGAP-1.EQ.IGBE3) IEND3=MSTA(ISPB2+1)-1
C
                  ELSE
                     ISTA3 = MSTA(ISPB4)
                     IEND3 = IBCON2(IGBB3)-1
                  ENDIF
C
C  LOOP OVER GAPS
C
                  DO 6830 IGAP3=IGBB3,IGBE3+1
C
                     DO 6820 JJ3=ISTA3,IEND3
                        IS4 = IOB(JJ3)
                        IP2 = LGMUL(IS3,IS4)
                        IF (IP1.NE.IP2) GOTO 6820
C
              CALL REDE00(IBCON2,IACON1,NB,IB3,IGAP3-1,JJ3,JPERB3)
              CALL IDPOST(IACON1,NB,LBOX3,NSPACE,MSTA,IDIM,Y,NX,LBST,
     *                  LBNDET(1,IGB3),IACON2,JPOSB3)
              IPER3 = ((-1)**(JPERB3+JPERB))*2
              KBPOS3 = JPOSB3 + NIBS3
              JPZB3 = LSPB(KBPOS3)
C
                 JMA=MAX(JJ3,IO3)
                 JMI=MIN(JJ3,IO3)
                 I2 = INDEX(JMA) + JMI
                 INX = INDEX(I2) + IND
                 II1 = INDEX(JJ3) + IO1
                 JMA=MAX(IO3,JJ)
                 JMI=MIN(IO3,JJ)
                 II2 = INDEX(JMA) + JMI
                 JMA=MAX(II1,II2)
                 JMI=MIN(II1,II2)
                 INX2 = INDEX(JMA) + JMI
C
C  LOOP OVER ALPHA STRINGS OF RIGHT SYMMETRY AND GROUP.
C
              DO 6700 IGA=1,ITGA
              IF (LGCOM(IGB,IGA).NE.1.OR.LGCOM(IGB3,IGA).NE.1) GOTO 6700
              JCIB1 = JPZB1 + LDISB(KBSYM,IGB,IGA)
              JCIB3 = JPZB3 + LDISB(KBSYM,IGB3,IGA)
              NIAS = NAST(IGA)
C
              DO 6680 KKA=LSAS(KSYM,IGA),LSAS(KSYM+1,IGA)-1
                 IENA3 = LSAC(KKA)
                 JCIA = LSPA(NIAS+IENA3)
                 JCI1 = JCIA + JCIB1
                 JCI3 = JCIA + JCIB3
                 FC = 0.0D+00
                 DO KKI=1,NXTW
              FC = FC + WSTATE(IWTS(KKI))*AB(JCI1,KKI)*AB(JCI3,KKI)
                 ENDDO
                 FC = FC*IPER3
                 DM2(INX) = DM2(INX) + FC
                 DM2(INX2) = DM2(INX2) - FC
 6680         CONTINUE
C
 6700         CONTINUE
C
 6820                CONTINUE
C
                     ISTA3 = IBCON2(IGAP3)+1
                     IEND3 = IBCON2(IGAP3+1)-1
                     IF (IGAP3.EQ.IGBE3) IEND3=MSTA(ISPB4+1)-1
 6830             CONTINUE
C
 6840             LBOX3(ISPB4) = LBOX3(ISPB4) - 1
 6850             CONTINUE
C
 6880          CONTINUE
C
               LBOX3(ISPB3) = LBOX3(ISPB3)+1
 6887          IBES3 = IBES3 + LBOX3(ISPB3)
 6890       CONTINUE
C
C  --- END OF LOOP OVER DOUBLE BETA EXCITATIONS.
C
 7850                CONTINUE
C
                  ISTA = IBCON1(IGAP)+1
                  IEND = IBCON1(IGAP+1)-1
                  IF (IGAP.EQ.IGBE) IEND=MSTA(ISPB2+1)-1
 7860             CONTINUE
C
 7870             LBOX2(ISPB2) = LBOX2(ISPB2) - 1
 7880          CONTINUE
C
 7885          CONTINUE
C
               LBOX2(ISPB1) = LBOX2(ISPB1)+1
 7890       CONTINUE
C
C REMAINING DIAGONAL CONTRIBUTIONS HERE
C
            DO 69 II=1,NB
               I1 = IBCON1(II)
               IND1 = INDEX(I1+1)
C
              DO 6705 IGA=1,ITGA
              IF (LGCOM(IGB,IGA).NE.1) GOTO 6705
              JCIB1 = JPZB1 + LDISB(KBSYM,IGB,IGA)
              NIAS = NAST(IGA)
C
              DO 6685 KKA=LSAS(KSYM,IGA),LSAS(KSYM+1,IGA)-1
                 IENA3 = LSAC(KKA)
                 JCIA = LSPA(NIAS+IENA3)
                 JCI1 = JCIA + JCIB1
                 FC = 0.0D+00
                 DO KKI=1,NXTW
              FC = FC + WSTATE(IWTS(KKI))*AB(JCI1,KKI)*AB(JCI1,KKI)
                 ENDDO
                 DM1(IND1) = DM1(IND1) + FC
 6685         CONTINUE
C
 6705         CONTINUE
C
              DO 74 JJ=II+1,NB
                 I2 = IBCON1(JJ)
                 IND2 = INDEX(I2+1)
                 INDM = IND2 - I2 + I1
                 J1 = INDEX(INDM+1)
                 JMI = MIN(IND1,IND2)
                 JMA = MAX(IND1,IND2)
                 J2 = INDEX(JMA) + JMI
C
              DO 6710 IGA=1,ITGA
              IF (LGCOM(IGB,IGA).NE.1) GOTO 6710
              JCIB1 = JPZB1 + LDISB(KBSYM,IGB,IGA)
              NIAS = NAST(IGA)
C
              DO 6690 KKA=LSAS(KSYM,IGA),LSAS(KSYM+1,IGA)-1
                 IENA3 = LSAC(KKA)
                 JCIA = LSPA(NIAS+IENA3)
                 JCI1 = JCIA + JCIB1
                 FC = 0.0D+00
                 DO KKI=1,NXTW
              FC = FC + WSTATE(IWTS(KKI))*AB(JCI1,KKI)*AB(JCI1,KKI)
                 ENDDO
                 DM2(J1) = DM2(J1) - FC
                 DM2(J2) = DM2(J2) +  FC
 6690         CONTINUE
C
 6710         CONTINUE
C
   74         CONTINUE
C
   69         CONTINUE
C
            CALL MOVEUP2(LBOX1,NSPACE,NB,MSTA,IBCON1)
 7900    CONTINUE
C
         CALL PUSHCO(LBOX1,NSPACE,NB,IBMA,IBMI,LBOX5,IEND)
 8000 CONTINUE
C
C  --- END OF LOOP OVER BETA STRINGS. ---
C
C ----    END OF DENSITY MATRIX GENERATION ----------
C
      CALL VALFM(LOADFM)
      LXX    = LOADFM + 1
      LIXX   = LXX    + NINTMX
      LWRK   = LIXX   + NINTMX
      LLABMO = LWRK  + NOCC2
      LLBABL = LLABMO + L1
      LLBIRP = LLBABL + M1
      LSYIRP = LLBIRP + 12
      LAST   = LSYIRP + 12
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
      CALL DETGRP(GRPDET,X(LLABMO),X(LLBABL),PTGRP,X(LLBIRP),
     *            X(LSYIRP),NSYM,NIRRP,L1,NACT,NCORSV)
C
      CUTOFF = MAX(1.0D-11,10.0D+00**(-ICUT))
      IF(SOME) WRITE(IW,9370) X(LSYIRP),PTGRP
C
      CALL SEQOPN(NFT15,'WORK15','UNKNOWN',.FALSE.,'UNFORMATTED')
      CALL SEQREW(NFT15)
      CALL WTDM12(EXETYP,DM1,DM2,X(LLBABL),X(LXX),X(LIXX),
     *            NINTMX,LABSIZ,M1,M2,M4,
     *            X(LWRK),NOCC2,NCORSV,CUTOFF,NFT15,NRECO,NDM2O)
      CALL SEQREW(NFT15)
C
      IF(SOME) WRITE(IW,9380) NDM2O,NRECO,NFT15
      CALL RETFM(NEED)
C
      IF(SOME) WRITE(IW,9390)
      IF(SOME) CALL TIMIT(1)
C
      RETURN
C
 9310 FORMAT(/5X,55(1H-)/
     *   5X,' ONE AND TWO PARTICLE ORMAS DENSITY MATRIX COMPUTATION'/
     *   18X,'PROGRAM WRITTEN BY JOE IVANIC'/
     *   5X,55(1H-))
 9320 FORMAT(/1X,'THE DENSITIES ARE STATE AVERAGED OVER',I4,' ROOT(S)')
 9340 FORMAT(1X,'STATE=',I4,'   ENERGY=',F20.10,'   WEIGHT=',F8.5,
     *           '   S=',F6.2)
 9350 FORMAT(/1X,'***** ERROR *****'/
     *       1X,'THIS RUN FOUND',I5,' CI EIGENVECTORS WITH S=',F5.2,','/
     *       1X,'BUT YOU REQUESTED STATE AVERAGING OF',I5,' ROOTS.'/
     *       1X,'PLEASE EXAMINE YOUR CHOICE OF -NSTATE- INPUT DATA.'/)
 9370 FORMAT(1X,'SIEVING THE ',A4,
     *          ' SYMMETRY NONZERO DENSITY ELEMENTS IN GROUP ',A8)
 9380 FORMAT(1X,I10,' NONZERO DM2 ELEMENTS WRITTEN IN',I8,
     *          ' RECORDS TO FILE',I3)
 9390 FORMAT(1X,'..... DONE WITH 1 AND 2 PARTICLE DENSITY MATRIX .....')
C
      END
C
C
C*MODULE ORMAS1  *DECK REFWE
C     ----------------------------------------------------------------
      SUBROUTINE REFWE(VEC,NAST,ITGA,ITGB,
     *                 LSYMA,IAST,LGCOM,LSBS,NSYM,KTAB)
C     ----------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXRT=100)
C
      LOGICAL FDIRCT,QCORR
C
      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 /FCCWFN/ NSPACE,MSTA(51),MNUM(51),MINI(51),MAXI(51),
     *                IAMI(51),IAMA(51),IBMI(51),IBMA(51),IDIM(51),
     *                LBST(51),NREF0,FDIRCT,QCORR,C0SQ
C
      DIMENSION VEC(NCI)
      DIMENSION NAST(ITGA),LSYMA(IAST)
      DIMENSION LGCOM(ITGB,ITGA),LSBS(NSYM+1,ITGB),KTAB(NSYM)
C
      C0SQ = 0.0D+00
      ICI = 0
      ICOUNT = 0
C
      IGA = 1
      DO 410 KKA=NAST(IGA)+1,NAST(IGA+1)
         JASYM=LSYMA(KKA)
         KSYM=KTAB(JASYM)
         DO 500 IGB=1,ITGB
            IF (LGCOM(IGB,IGA).NE.1) GOTO 500
            DO 510 KKB=LSBS(KSYM,IGB),LSBS(KSYM+1,IGB)-1
               ICI=ICI+1
               IF (IGB.EQ.1) THEN
                  C0SQ = C0SQ + VEC(ICI)**2.0D+00
                  ICOUNT = ICOUNT + 1
               ENDIF
  510       CONTINUE
  500    CONTINUE
  410 CONTINUE
C
      RETURN
      END
