C 13 MAR 06 - MWS - ORDORB: ALLOW MEX JOBS TO READ $DRT1/$DRT2
C 19 SEP 05 - MWS - ADD TRUE NUCLEAR CHARGE ARRAY TO INFOA COMMON
C  5 JUL 05 - MWS - SELECT NEW ATOM,BASIS,EFP,PCM,DAF DIMENSIONS
C 30 APR 05 - DGF - ADJUST THE NUMBER OF ORBITALS FOR FMO, SYNCH SYMBLK
C  5 FEB 05 - MWS - PAD COMMON FMORUN
C  7 SEP 04 - MWS - PAD COMMON BLOCK INTFIL
C 19 MAY 04 - DGF - CHANGES TO ADD THE FMO METHOD
C  9 DEC 03 - MWS - ORBGEN: RETURN IF ERROR DURING NPRINT=-23
C 12 DEC 02 - CHC - PALDUS: IMPROVE AN ERROR MESSAGE
C 22 MAY 02 - MWS - REVERSE 16 FEB CHANGE TO /SYMMOL/
C 16 FEB 02 - MWS - FIX TYPO IN /SYMMOL/, CALL TO SYMMOS FOR TRANS MOMS
C 25 OCT 01 - MWS - ORDORB: HESSIANS FORCE STATE SYMMETRY TO A
C  8 OCT 01 - MWS - ORDORB: GENERATE SYMMETRY INFO FOR JACOBI CONVERGER
C 19 SEP 01 - MWS - CONVERT MXAOCI PARAMTER TO MXAO
C  6 SEP 01 - MWS - ADD DUMMY ARGUMENTS TO NAMEIO CALL
C 25 JUN 01 - MWS - ALTER COMMON BLOCK WFNOPT
C 19 NOV 00 - MWS - FIX DIMENSION IN SOSYM COMMON
C 11 OCT 00 - DGF - ORDORB: FORCE GROUP=C1 FOR NOSYM=1 JOBS
C 11 JUN 00 - DGF - DRTIND: ADJUST MXSPIN FOR SINGLE REFERENCE CI
C 10 JAN 00 - MWS - FIX CALLS TO SYMMOS
C 21 DEC 99 - DGF - SPACE SYMMETRY DETERMINATION OF CI STATES, REMOVE
C                   MXSPIN+MXPRM, DYSTAUTOGRAMMATISE SPNFNC.
C                   ROUTINES PRINTCSF,DETREOR,IRRDET,IFINDET ADDED
C 12 NOV 98 - MAF - ORDORB: ALLOW FOR USE OF SPHERICAL HARMONICS
C 13 APR 98 - MWS - ORDORB: READ SYMMETRY LABELS FROM DAF
C 27 FEB 98 - KRG - ORDORB: FIX DIMENSION ERROR MESSAGE
C  6 JAN 98 - DGF - CHANGE CSF DATA ORDER TO ALLOW FOR 64 BIT MACHINES
C 14 OCT 97 - DGF - ORDORB: ALLOW MORE THAN 2 CIDRT GROUPS FOR SPINORBIT
C                   GETSOB,SOGINI, SAVGSO: ADD ROUTINES FOR CSF DECOMP
C 17 SEP 97 - DGF - DRTIND,DRTGEN: GET MEMORY/SAVE CSF STRUCTURE FOR SOC
C 17 SEP 97 - DGF,TRF - ADD ROUTINE KOADD
C 17 SEP 97 - SK  - PRTCSF: ADD A ROUTINE CSFDET AND CSFDETC
C  3 FEB 97 - MWS - ORDORB: ENSURE IXCIT NOT CHOSEN WITH FORS/FOCI/SOCI
C  8 JAN 97 - GMC - ORDORB: CHANGES FOR DROPPING MCSCF CORES
C 18 DEC 96 - MWS - ORDORB: BOMB CI GRADIENT JOBS IF NVAL IS INCORRECT
C 26 NOV 96 - VAG - INCREASE CI AO'S TO 768
C 19 NOV 96 - SPW - ORDORB: STORE FROZEN CORE INFO FOR CI GRADIENTS
C 29 SEP 96 - KRG - ADDED SOME ERROR MESSAGES BEFORE ABRT CALLS
C 13 JUN 96 - VAG - ADD VARIABLE FOR CI TYPE TO SCFOPT COMMON
C 18 APR 96 - GMC - ORDORB: CHANGE CORE DEFINITIONS FOR FOCAS FUNCTION
C 26 MAR 96 - MWS - PALDUS: ACTIVE SPACE CHECK INCLUDES MULTIPLICITY
C 25 MAR 96 - MWS - RDDRT: NEW ROUTINE TO READ DRT HEADER CONSISTENTLY
C 17 FEB 96 - SK  - SPNFNC: CHANGE PARAMETERS, MXSPIN AND MXPRM.
C 29 DEC 94 - SK  - DRTIND,PRTSCF: MODIFY SOME FORMATS
C 10 NOV 94 - MWS - REMOVE FTNCHEK WARNINGS
C 25 OCT 94 - MWS - ORDORB: INCREASE MXNINT AND MXNEME
C 10 SEP 94 - MWS - ORDORB: ENABLE USE OF D2 LABELS
C 10 AUG 94 - MWS - INCREASE NUMBER OF DAF RECORDS
C  3 AUG 94 - MWS - ORDORB: STOP JOB IF TOO MANY AOS
C 13 DEC 93 - TLW - ALL NODES SHOULD GENERATE DRT FILE
C  4 NOV 93 - MWS - ORDORB: BOMB MISMATCH OF DATA/DRT GROUPS
C  1 JUL 93 - MWS - PALDUS: ALL -ABRT- CALLS PRODUCE A DIAGNOSTIC
C  7 NOV 92 - MWS - ORDORB: B1,B2 IN D4,C4V SHOULD MAP TO A1,A2
C  7 OCT 92 - MWS - ORDORB: INTERCHANGE EGX AND EGY IN D4H GROUP
C 17 MAR 92 - MWS - ORDORB: DEFAULT FOR MXNINT CHANGED TO 10,000
C 12 MAR 92 - MWS - REDIMENSION TO 500 ATOMS
C  5 MAR 92 - MWS - ORDORB: USE SYMMOS
C 10 JAN 92 - TLW - PARALLEL I/O CHANGES
C 31 DEC 91 - MWS - INCREMENT INMAX BY 20 (THE "CAVE BUG")
C  6 NOV 91 - MWS - PALDUS: REDIMENSION IRED FROM 200 TO 500
C 10 AUG 91 - MWS - DRTGEN: NPRINT=-23 READS $DRT, DOES NOTHING ELSE
C 30 MAR 91 - MWS - ORDORB: INITIALIZE GUGWFN COMMON
C  8 DEC 90 - MKS - DRTIND: DIRECTIVES TO FIX UNICOS 6 VECTOR BUG
C 24 OCT 90 - TLW - CHANGE GROUP TO C1 IF RUNNING AN MCSCF HESSIAN
C  1 JUN 90 - MWS - REWIND DRTFILE BEFORE (OVER)WRITING IT.
C 23 FEB 90 - MWS - ORDORB: FIX COMPUTATION OF MOLECULAR CHARGE
C 23 JAN 90 - MWS - ORDORB: $DRT'S ICH,MUL MUST MATCH WITH $CONTRL'S
C 13 JAN 90 - MWS - ORDORB: CLEANED UP, WITH FREE FORMAT $DRT
C 26 SEP 89 - MWS - ADD NFT13,NFT14 TO /CIFILS/
C 20 FEB 89 - STE - IMPROVED ERROR MESSAGES IN DRTWRT.
C  7 OCT 88 - MWS - INCREASE AO NUMBER FROM 128 TO 256
C  5 OCT 88 - MWS - ADD NCORBS TO /ORBSET/ AND TO NFT11 HEADER RECORD
C 26 JUL 88 - SK  - CHANGES IN SPIN FUNCTIONS: MAKDET, PRTCSF, SPNFNC
C 18 MAY 88 - MWS - IPRIM(10) (NOT 1024) IN MAKDET
C  1 MAR 88 - STE - CLARIFY VARIABLE USAGE IN NEW CODE
C 23 FEB 88 - MWS - ADD SHIRO'S PRTCSF,SPNFNC,MAKDET FOR CSF PRINTOUT
C 14 FEB 88 - MWS - MAKE NAME OF $DRTINP GROUP A CALLING PARAMETER.
C 19 NOV 87 - STE - CHANGE LREC12 TO HOLD SORTED INTEGRALS NEED FOR CI
C  3 NOV 86 - STE - PALDUS: UNROLL LOOPS 620,740
C  7 JUL 86 - MWS - SANITIZE FLOATING POINT CONSTANTS
C 23 OCT 85 - STE - DRTGEN: USE /CIFILS/, DEFINE FILES IN OPENCI
C 10 JUL 85 - MWS - DECLARE PACK2E LOGICAL
C 10 MAR 85 - MWS - CALL OPENCI TO OPEN DRT, CI FILES
C 26 MAR 84 - STE - FPS OPEN PARAMETERS AT RUN-TIME OPTION IN DRTGEN
C 26 FEB 84 - STE - POSTPONE CREATION OF DRT FILE 11 TO END OF DRTGEN
C 23 FEB 84 - STE - CLARIFY MEMORY ALLOCATION IN DRTGEN, INSERT ABRTS
C  1 FEB 84 - STE - TAKE NEED = MIN(NGOT,NWORD) IN DRTGEN
C  5 JAN 83 - STE - CHANGE STATUS=NEW TO STATUS=UNKNOWN
C  8 DEC 83 - STE - OPEN NFT11,NFT12,NFT15,NFT16 IN DRTGEN
C 18 NOV 83 - STE - CHANGE IBLANK TO BLANK IN ORDORB
C  1 OCT 82 - MWS - CONVERT TO IBM
C
C*MODULE GUGDRT  *DECK DRTGEN
      SUBROUTINE DRTGEN(NPRINT,DRTINP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL SOME,DEBUG,PACK2E,GOPARR,DSKWRK,MASWRK,TDSKWK
C
      DIMENSION TITLE(10)
C
      PARAMETER (MXATM=2000, MXAO=8192)
C
      COMMON /CIFILS/ NFT11,NFT12,NFT13,NFT14,NFT15,NFT16,IDAF20,NEMEMX
      COMMON /FMCOM / H(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,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /ORBSET/ NORBMX,NORBS,NCORBS,NLEVS,NA,NB,NC,NSYM,MSYM,
     *                IDOCC,IVAL,IMCC,ISYM(MXAO),ICODE(MXAO),
     *                NLCS(MXAO),LEVPT(MXAO),LEVNR(MXAO),
     *                IOUT(MXAO),NREFS,IEXCT,NFOCI,INTACT
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      SOME  = NPRINT.NE.-5  .AND.  NPRINT.NE.-23 .AND. MASWRK
      DEBUG = NPRINT.GT.0 .AND. MASWRK
      IF (SOME) WRITE (IW,9008)
C
C     ----- READ INFORMATION NEEDED TO GENERATE THE DRT -----
C
      MXORB = MXAO
      L1 = NUM
      L2 = (L1*L1+L1)/2
      L3 = L1*L1
C
      CALL VALFM(LOADFM)
      LORBTP = 1 + LOADFM
      LISMTP = LORBTP  + MXORB*12
      LORBCD = LISMTP  + MXORB
      LQ     = LORBCD  + L1
      LS     = LQ      + L3
      LVEC   = LS      + L2
      LWRK   = LVEC    + L3
      LLABMO = LWRK    + L1
      LMOIRP = LLABMO  + L1
      LMODEG = LMOIRP  + L1
      LAST   = LMODEG  + L1
      NEED = LAST - LOADFM -1
      CALL GETFM(NEED)
C
      LEVFRM=0
      MXNINT=0
      NEMEMX=0
      NPFLG=0
      CALL ORDORB(DRTINP,TITLE,LEVFRM,MXNINT,NEMEMX,
     *            NPRINT,NPFLG,SOME,H(LORBTP),H(LISMTP),MXORB,
     *            H(LORBCD),H(LQ),H(LS),H(LVEC),H(LWRK),H(LLABMO),
     *            H(LMOIRP),H(LMODEG),L1,L2,L3)
      CALL RETFM(NEED)
C
      IF(NPRINT.EQ.-23) RETURN
C
C     ----- GENERATE THE DISTINCT ROW TABLE -----
C     NOTE THAT WE DO NOT DO A GETFM AT THIS PRELIMINARY STAGE.
C     THIS IS VERY DIRTY CODING PRACTICE!  AFTER PALDUS IS DONE
C     WE WILL KNOW NROWS AND NWKS AND SO ON TO DO IT RIGHT.
C
      CALL VALFM(LOADFM)
      CALL GOTFM(NGOT)
      NROWSO = NGOT/9 - 2
      NROWSF = 4 * NROWSO
      IH1A = 1 + LOADFM
      IH1B = IH1A + NROWSO
      IH1S = IH1B + NROWSO
      IH1T = IH1S + NROWSO
      IH2A = IH1T + NROWSO
      IH3A = IH2A + NROWSF
      IF (DEBUG) WRITE (IW,9028)
      NROWS = NROWSO
      NWKS = 0
      CALL PALDUS(NROWS,NWKS,H(IH1A),H(IH1B),H(IH1S),H(IH1T),H(IH2A),
     *            H(IH3A),NROWSF)
      NROWS4 = 4 * NROWS
      NORBS = NA+NB+NC
      NKL = NSYM*NORBS
      NIJ = (NORBS*(NORBS+1))/2
C
C           ----- ALLOCATE MEMORY -----
C
C        IH1 = NABCA (NROWS)
C        IH2 = NABCB (NROWS)            IH12 = IJADD  (NIJ)
C        IH3 = NABCS (NROWS)            IH13 = IJGRP  (NIJ)
C        IH4 = NABCT (NROWS)            IH14 = KADD   (NKL)
C        IH5 = IARC  (NROWS,4)          IH15 = LADD   (NKL)
C        IH6 = NLWKS (NROWS)            IH16 = INEXT  (200)
C        IH7 = NUWKS (NROWS)            IH17 = JMNNXT (200)
C        IH8 = PUWK  (NROWS)            IH18 = JMXNXT (200)
C        IH9 = NWGHT (NROWS,4)          IH19 = IJNINT (NIJ)
C        IH10= INDX  (NWKS)             IH20 = NINGRP (200)
C
      IH1  = 1 + LOADFM
      IH2  = IH1 + (NROWS -1)/NWDVAR + 1
      IH3  = IH2 + (NROWS -1)/NWDVAR + 1
      IH4  = IH3 + (NROWS -1)/NWDVAR + 1
      IH5  = IH4 + (NROWS -1)/NWDVAR + 1
      IH6  = IH5 + (NROWS4-1)/NWDVAR + 1
      IH7  = IH6 + (NROWS -1)/NWDVAR + 1
      IH8  = IH7 + (NROWS -1)/NWDVAR + 1
      IH9  = IH8 + (NROWS -1)/NWDVAR + 1
      IH10 = IH9 + (NROWS4-1)/NWDVAR + 1
      IH12 = IH10+ (NWKS  -1)/NWDVAR + 1
      IH13 = IH12+ (NIJ   -1)/NWDVAR + 1
      IH14 = IH13+ (NIJ   -1)/NWDVAR + 1
      IH15 = IH14+ (NKL   -1)/NWDVAR + 1
      IH16 = IH15+ (NKL   -1)/NWDVAR + 1
      IH17 = IH16+ (200   -1)/NWDVAR + 1
      IH18 = IH17+ (200   -1)/NWDVAR + 1
      IH19 = IH18+ (200   -1)/NWDVAR + 1
      IH20 = IH19+ (NIJ   -1)/NWDVAR + 1
      LAST = IH20+ 200/NWDVAR
C
C     DO VOUCHSAFE TO BE CAREFUL WHEN USING MEMORY ALLOCATED IN THE
C     NEXT CALL TO GETFM. DO NOT USE *ANY* (!!) OF THESE POINTERS BEFORE
C     THE CONTENT OF IH1A ETC IN THE ABOVE SILENT CALL TO GETFM GETS
C     COPIED INTO APPROPRIATE ARRAYS IH* IN DRTIND.
C
      NEED = LAST-LOADFM-1
      NIPGRP = NGOT - NEED
C
C     ----- CONSTRUCT INDEXING ARRAY -----
C
      IF (DEBUG) WRITE (IW,9048)
      CALL GETFM(NEED)
      CALL DRTIND(NROWS,NWKS,H(IH1A),H(IH1B),H(IH1S),H(IH1T),H(IH2A),
     *            H(IH3A),H(IH2),H(IH3),H(IH4),H(IH5),H(IH6),H(IH7),
     *            H(IH8),H(IH10),NROWSO,H(IH9),NROWS4,NROWSF,NPFLG,SOME,
     *            DEBUG)
C
C     ----- CONSTRUCT INTEGRAL ADDRESSING ARRAY -----
C
      IF (DEBUG) WRITE (IW,9068)
      NGRPS=0
      NEXT=0
      IJAD=0
      CALL DRTSYM(H(IH12),H(IH13),H(IH14),H(IH15),H(IH16),H(IH17),
     *            H(IH18),H(IH19),H(IH20),NIPGRP,MXNINT,NIJ,NKL,
     *            SOME,DEBUG,NGRPS,NEXT,IJAD)
C
C        ----- OPEN FILES NEEDED FOR MCSCF/CI -----
C
C---      LREC11 = MAX(200,NROWS4,NWKS,NREFS,NIJ,NKL,NIPGRP+2)
C---      LREC12 = MAX(MXNINT+2,NWKS,22)
      IF (GOPARR) THEN
         TDSKWK = DSKWRK
         DSKWRK = .TRUE.
      END IF
      LREC11 = MAX(200,NROWS4,NWKS,NREFS,NIJ,NKL)
      LREC12 = MAX(NWKS,22)
      LREC15 = MAX(2*NEMEMX+1, NIPGRP, NIJ, 2*NINTMX+1, NWKS)
      LREC16 = MAX(3*NEMEMX+1, NIPGRP, NIJ, 2*NINTMX+1)
      CALL SEQOPN(NFT11,'DRTFILE','UNKNOWN',.FALSE.,'UNFORMATTED')
      CALL SEQOPN(NFT12,'CIVECTR','UNKNOWN',.FALSE.,'UNFORMATTED')
      CALL SEQOPN(NFT14,'CIINTS', 'UNKNOWN',.FALSE.,'UNFORMATTED')
      CALL SEQOPN(NFT15,'WORK15', 'UNKNOWN',.FALSE.,'UNFORMATTED')
      CALL SEQOPN(NFT16,'WORK16', 'UNKNOWN',.FALSE.,'UNFORMATTED')
      IF(SOME) WRITE(IW,9128) LREC11,NFT11,LREC12,NFT12,
     *                        LREC15,NFT15,LREC16,NFT16
C
C        ----- CREATE DRT FILE -----
C
      CALL SEQREW(NFT11)
      IF (MASWRK.OR.DSKWRK) THEN
         WRITE (NFT11) NORBMX,NORBS,NSYM,NROWS,NWKS,LEVFRM,NEMEMX,NREFS,
     *                 IEXCT,NFOCI,INTACT,NCORBS
         WRITE (NFT11) TITLE
      END IF
      CALL DRTWRT(NFT11,NROWS,NROWS4,NKL,NIJ,H(IH1),H(IH2),H(IH3),
     *            H(IH5),H(IH6),H(IH7),H(IH8),H(IH10),H(IH9),
     *            H(IH12),H(IH13),H(IH14),H(IH15),H(IH16),
     *            H(IH17),H(IH18),NWKS,NEXT,NGRPS,MXNINT,IJAD)
      IF (GOPARR) DSKWRK = TDSKWK
C
C     ----- RESET FAST MEMORY -----
C
      CALL RETFM(NEED)
      IF (SOME) WRITE (IW,9088)
      IF (SOME) CALL TEXIT(2,2)
      RETURN
C
 9008 FORMAT(/10X,23(1H-),5X,28(1H-)/
     *        10X,'GUGA DISTINCT ROW TABLE',5X,
     *            'WRITTEN BY B.R.BROOKS,P.SAXE'/
     *        10X,23(1H-),5X,28(1H-))
 9028 FORMAT(//,24X,34HCONSTRUCT BASIC DISTINCT ROW TABLE)
 9048 FORMAT(//,24X,47HCONSTRUCT INDEXING ARRAY AND OTHER -DRT- ARRAYS)
 9068 FORMAT(//,24X,36HCONSTRUCT INTEGRAL ADDRESSING ARRAYS)
 9088 FORMAT(39H ...... END OF -DRT- GENERATION ...... )
 9128 FORMAT(1X,'MAXIMUM RECORD SIZES ARE',2(I8,' FOR UNIT',I3)/
     *       25X,2(I8,' FOR UNIT',I3))
      END
C*MODULE GUGDRT  *DECK DRTIND
      SUBROUTINE DRTIND(NROWS,NWKS,NABCA,NABCBO,NABCSO,NABCTO,IARCO,
     *                  NLWKSO,NABCB,NABCS,NABCT,IARC,NLWKS,NUWKS,PUWK,
     *                  INDX,NROWSO,NWGHT,NROWSF,NROWS4,NPFLG,SOME,
     *                  DEBUG)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL SOME,DEBUG,GOPARR,DSKWRK,MASWRK,RUNPB,RUNTRM,OUT,OUT1,
     *        ABELPT,NONABEL,SVDSKW
C
      INTEGER PUWK
C
      PARAMETER (MXAO=8192,MAXCP=4096,MXATM=2000)
C
      DIMENSION IARCO(NROWS4),NLWKSO(NROWSO),IARC(NROWSF),NLWKS(NROWS),
     *          NUWKS(NROWS),PUWK(NROWS),INDX(NWKS),NABCA(NROWS),
     *          NABCB(NROWS),NABCS(NROWS),NABCT(NROWS),NABCBO(NROWSO),
     *          NABCSO(NROWSO),NABCTO(NROWSO)
      DIMENSION IWGHT(MXAO),ITEST(MXAO),LWGHT(MXAO),LEVIR(MXAO)
      DIMENSION ISHIFT(4),JARCS(4)
      DIMENSION ISHFTO(4)
      DIMENSION NWGHT(NROWSF)
      DIMENSION CODNAM(2,12)
C
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON /ORBSET/ NORBMX,NORBS,NCORBS,NLEVS,NA,NB,NC,NSYM,MSYM,
     *                IDOCC,IVAL,IMCC,ISYM(MXAO),ICODE(MXAO),
     *                NLCS(MXAO),LEVPT(MXAO),LEVNR(MXAO),
     *                IOUT(MXAO),NREFS,IEXCT,NFOCI,INTACT
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /SOGUG/  CP(MAXCP),NUNIQ,LIOBP,ISODAF,NSODA,LSTREC,JSODAF,
     *                JSODA,NRECJ
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,MA,MB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /GUGWFN/ NFZC,NMCC,NDOC,NAOS,NBOS,NALP,NVAL,NEXT,NFZV,
     *                IFORS,IEXCIT,ICICI,NOIRR
      COMMON /TRNMOM/ OPERR,SYMTOL,NOCC,NUMCI,MFZC,NUMVEC,ICI,MXRT,NSTAT
      COMMON /FMCOM / X(1)
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
C
      DATA CODNAM /8HDOUBLY O,8HCCUPIED ,8HUNOCCUPI,8HED      ,
     + 8HFROZEN C,8HORE     ,8HFROZEN V,8HIRTUAL  ,8HALPHA OC,
     + 8HCUPATION,8HALPHA OF,8H O.S.S. ,8HBETA OF ,8HO.S.S.  ,
     + 8HFIRST OF,8H GVB    ,8HSECOND O,8HF GVB   ,8H        ,
     + 8H        ,8HVALENCE ,8H        ,8H    -MC-,8H CORE   /,
     * BREIT/8HHSO2FF  /,DEBUGG/8HDEBUG   /,TRANST/8HTRANSITN/,
     * CHECK/8HCHECK   /
C
C     ----- INITIALIZATION OF CORE SPACE -----
C
      DO 100 I = 1,NROWS
  100 NABCB(I) = NABCBO(I)
      DO 120 I = 1,NROWS
  120 NABCS(I) = NABCSO(I)
      DO 140 I = 1,NROWS
  140 NABCT(I) = NABCTO(I)
      DO 160 K = 1,4
      ISHIFT(K) = (K-1)*NROWS
      ISHFTO(K) = (K-1)*NROWSO
  160 CONTINUE
      DO 180 K = 1,4
      DO 180 I = 1,NROWS
      IARPT = I+ISHIFT(K)
      IARPTO = I+ISHFTO(K)
      IARC(IARPT) = IARCO(IARPTO)
  180 CONTINUE
      DO 200 I = 1,NROWS
  200 NLWKS(I) = NLWKSO(I)
      DO 220 I = 1,NWKS
  220 INDX(I) = 0
      DO 240 I = 1,NROWS
      NUWKS(I) = 0
      PUWK(I) = 0
  240 CONTINUE
C
      RUNTRM=RUNTYP.EQ.TRANST
      RUNPB= RUNTRM.AND.OPERR.EQ.BREIT
      IF(RUNPB) NSTAT=NSTAT*NWKS
C
C     ----- GENERATE NUMBER OF UPPER WALKS ARRAY (NUWKS)
C           GENERATE PRIMARY UPPER WALK ARRA     (PUWK ) -----
C
      LEVM = NLEVS
      NUWKS(1) = 1
      PUWK(1) = 1
  260 LEV = LEVM
      LEVM = LEV-1
      IF (LEVM .EQ. 0) GO TO 380
      NR = LEVNR(LEV)
      NRM = LEVNR(LEVM)
      NPTMX = LEVPT(LEVM)
      DO 280 I = 1,NR
  280 IWGHT(I) = 0
      DO 360 K = 1,4
      NPTM = LEVPT(LEVM)
      DO 300 I = 1,NRM
      NPTM = NPTM+1
      ITEST(I) = 0
      IF (PUWK(NPTM) .GT. 0) ITEST(I) = -1
  300 CONTINUE
      NPT = LEVPT(LEV)
      DO 340 I = 1,NR
      NPT = NPT+1
      IARPT = NPT+ISHIFT(K)
      JARC = IARC(IARPT)
      IF (JARC .EQ. 0) GO TO 340
      IPT = JARC+NPTMX
      NUWKS(IPT) = NUWKS(IPT)+NUWKS(NPT)
      IF (ITEST(JARC) .LT. 0) GO TO 320
      ITEST(JARC) = 1
      PUWK(IPT) = PUWK(NPT)+IWGHT(I)
  320 IWGHT(I) = IWGHT(I)+NLWKS(IPT)
  340 CONTINUE
  360 CONTINUE
      GO TO 260
  380 CONTINUE
C
      IF (DEBUG) WRITE (IW,9028)
      IF (DEBUG) WRITE (IW,9048)
      LEVM = NLEVS-1
  400 CONTINUE
      NR = LEVNR(LEVM+1)
      NPT = LEVPT(LEVM+1)
      DO 440 I = 1,NR
      NPT = NPT+1
      DO 420 K = 1,4
      IARPT = NPT+ISHIFT(K)
      JARCS(K) = IARC(IARPT)
  420 CONTINUE
      IA = NABCA(NPT)
      IB = NABCB(NPT)
      IC = LEVM - IA - IB
      ITP = NABCT(NPT)
      ISM = NABCS(NPT)
      IF(DEBUG) WRITE (IW,9068) LEVM,I,IA,IB,IC,ISM,ITP,JARCS,
     *                          NLWKS(NPT),NUWKS(NPT),PUWK(NPT)
  440 CONTINUE
C
      IF (DEBUG .AND.  LEVM.EQ.0) WRITE (IW,9208)
      IF (LEVM .EQ. 0) GO TO 480
      IORB = 0
      DO 460 I = 1,NORBMX
      IF (IOUT(I) .EQ. LEVM) IORB = I
  460 CONTINUE
      ICD = ICODE(LEVM)
      IF(DEBUG) WRITE (IW,9088) IORB,ISYM(LEVM),
     *                          CODNAM(1,ICD),CODNAM(2,ICD)
  480 CONTINUE
C
      LEVM = LEVM-1
      IF (LEVM .GE. 0) GO TO 400
      IF (SOME) WRITE (IW,9008) NROWS,NWKS
CDIR$ NOVECTOR
C
C     ----- GENERATE THE INDEXING ARRAY (INDX) -----
C
      LEV = 1
      IWK = 0
      LEVM = 1
      IR0 = 1
      LWGHT(1) = 0
      IW0 = 1
  500 CONTINUE
      LWGHT(LEV) = LWGHT(LEVM)+IW0
      IF (LEV .EQ. NLEVS) GO TO 580
      LEVIR(LEV) = IR0
      LEVM = LEV
      LEV = LEVM+1
      LEVIR(LEV) = LEVNR(LEV)+1
  520 CONTINUE
      IR0 = LEVIR(LEV)
      NPTX = LEVPT(LEV)
      NPTMX = LEVPT(LEVM)
      IRM = LEVIR(LEVM)
  540 CONTINUE
      IR0 = IR0-1
      IF (IR0 .EQ. 0) GO TO 600
      NPT = IR0+NPTX
      IW0 = 0
      DO 560 K = 1,4
      IARPT = NPT+ISHIFT(K)
      JARC = IARC(IARPT)
      IF (JARC .EQ. 0) GO TO 560
      IF (IRM .EQ. JARC) GO TO 500
      IPT = JARC+NPTMX
      IW0 = IW0+NLWKS(IPT)
  560 CONTINUE
      GO TO 540
  580 CONTINUE
      IWK = IWK+1
      IW0 = LWGHT(NLEVS)
      INDX(IW0) = IWK
  600 CONTINUE
      LEV = LEVM
      LEVM = LEV-1
      IF (LEVM .GT. 0) GO TO 520
CDIR$ VECTOR
C
      IF (DEBUG) THEN
         WRITE (IW,9108)
         IPTI = 1
  620    CONTINUE
            IPTF = IPTI+9
            IF (IPTF .GT. NWKS) IPTF = NWKS
            IF (IPTF .LT. IPTI) GO TO 640
            WRITE (IW,9128) (IPT,INDX(IPT),IPT = IPTI,IPTF)
            IPTI = IPTF+1
            IF (IPTF .LT. NWKS) GO TO 620
  640    CONTINUE
      END IF
C
      DO 660 K = 1,4
      DO 660 I = 1,NROWS
      IARPT = I+ISHIFT(K)
      NWGHT(IARPT) = 0
  660 CONTINUE
      DO 740 LEV = 2,NLEVS
      LEVM = LEV-1
      NR = LEVNR(LEV)
      NPT = LEVPT(LEV)
      NPTM = LEVPT(LEVM)
      DO 720 I = 1,NR
      NPT = NPT+1
      DO 700 K = 1,4
      IARPT = NPT+ISHIFT(K)
      J = IARC(IARPT)
      IARPTX = IARPT+NROWS
      IF (J .GT. 0) GO TO 680
      IF (K .EQ. 4) GO TO 700
      NWGHT(IARPTX) = NWGHT(IARPT)
      GO TO 700
  680 CONTINUE
      IPTM = J+NPTM
      IARC(IARPT) = IPTM
      IF (K .EQ. 4) GO TO 700
      NWGHT(IARPTX) = NWGHT(IARPT) + NLWKS(IPTM)
  700 CONTINUE
  720 CONTINUE
  740 CONTINUE
C
C     ----- POSSIBLY PRINT ELECTRONIC CONFIGURATIONS -----
C
      IF(.NOT.RUNTRM.AND.NPFLG.LT.2) RETURN
      NAO = NDOC + NAOS + NBOS + NALP + NVAL
      NAEL= NDOC*2 + NAOS + NBOS + NALP
      MXSPIN=MIN(NAO+NFOCI,NAEL)
C     SINGLE REFERENCE CI
      IF(IFORS.EQ.0.AND.NFOCI.EQ.0) MXSPIN=NAOS+NBOS+NALP+IEXCIT*2
      IF(MXSPIN.GE.64/NWDVAR) THEN
         WRITE(IW,*) 'MXSPIN ',MXSPIN,'.GE.',64/NWDVAR
         CALL ABRT
      ENDIF
      MXPRM=2**MXSPIN
      NONABEL=.NOT.ABELPT()
      CALL VALFM(LOADFM)
      LPK     = 1      + LOADFM
      LIPRIM  = LPK    + MXSPIN*MXPRM
      LIPRMSM = LIPRIM + (MXSPIN*MXPRM-1)/NWDVAR+1
      LCGCOEF = LIPRMSM+ (MXSPIN*MXPRM-1)/NWDVAR+1
      LCGCSM  = LCGCOEF+ MXPRM
      LBK     = LCGCSM + MXPRM
      LNTRAP  = LBK    + MXSPIN
      LIICAS  = LNTRAP + (MXSPIN-1)/NWDVAR+1
      LCSFIR  = LIICAS + (MXSPIN-1)/NWDVAR+1
      LAST    = LCSFIR + (NWKS-1)/NWDVAR+1
      NEED=LAST-LOADFM-1
      CALL GETFM(NEED)
      IF(EXETYP.EQ.CHECK) GO TO 850
C
      OUT=EXETYP.EQ.DEBUGG.AND.MASWRK
      IF(OUT) WRITE(IW,9400) NEED
      SVDSKW=DSKWRK
      IF(RUNPB) CALL GETSOB(NAO,NWKS,OUT,LIBUFS,LNOCCU,NEEDSO,MAXIBF)
      DO 800 MS=0,1
         IF(MUL-1.LT.MS.OR..NOT.RUNTRM.AND.NPFLG.LT.MS+2)
     *      GO TO 800
         OUT1=MASWRK
         IF(NPFLG.LT.MS+2) OUT1=.FALSE.
         MSX=MS
         CALL PRINTCSF(ISHIFT,IARC,MXSPIN,X(LPK),X(LIPRIM),X(LCGCOEF),
     *                 X(LIPRMSM),X(LCGCSM),X(LBK),X(LNTRAP),X(LIICAS),
     *                 MSX,NPFLG,X(LNOCCU),X(LIBUFS),MAXIBF,X(LCSFIR),
     *                 RUNPB,RUNTRM,NONABEL,OUT1)
         DSKWRK=.TRUE.
         IF(RUNPB) CALL SAVGSO(NWKS,X(JSODA),X(LNOCCU),X(LIBUFS),
     *                         X(LIOBP),MS,OUT)
         IF(MS.EQ.0.AND.RUNTRM) THEN
            CALL RAWRIT(JSODAF,X(JSODA),X(LCSFIR),(NWKS-1)/NWDVAR+1,
     *                        (ICI-1)*NRECJ+5,1)
         END IF
         DSKWRK=SVDSKW
  800 CONTINUE
      IF(RUNPB) CALL RETFM(NEEDSO)
C
  850 CONTINUE
      CALL RETFM(NEED)
      RETURN
 9008 FORMAT(/1X,'THE DISTINCT ROW TABLE HAS',I10,' ROWS.'/
     *        1X,' THE WAVEFUNCTION CONTAINS',I10,' WALKS (CSF-S).')
 9028 FORMAT(/,2X,49(1H-),24H THE DISTINCT ROW TABLE ,49(1H-),/)
 9048 FORMAT(49X,50H I   J      A  B  C   SYM T      K0 K1 K2 K3      ,
     +     23HNLWKS    NUWKS     PUWK,/,49X,75(1H-))
 9068 FORMAT(47X,2I4,4X,3I3,3X,I2,1X,I2,5X,4I3,2X,3I9)
 9088 FORMAT(10X,9H  ORBITAL,I3,6H  SYM ,I2,4X,2A8)
 9108 FORMAT(/,1X,58(1H-),16H INDEXING ARRAY ,/,59(1H-),/)
 9128 FORMAT(1X,10(1H(,I5,1H,,I5,1H)))
 9208 FORMAT(/)
 9400 FORMAT(/,'CSF PRINT-OUT AND SYMMETRY ANALYSIS TOOK',I10,
     *         ' WORDS',/)
      END
C*MODULE GUGDRT  *DECK DRTSYM
      SUBROUTINE DRTSYM(IJADD,IJGRP,KADD,LADD,INEXT,JMNNXT,JMXNXT,
     *                  IJNINT,NINGRP,NIPGRP,MXNINT,NIJ,NKL,
     *                  SOME,DEBUG,NGRPS,NEXT,IJAD)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL SOME,DEBUG,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (MXAO=8192)
C
      DIMENSION IJADD(NIJ),IJGRP(NIJ),KADD(NKL),LADD(NKL),IJNINT(NIJ),
     *          INEXT(200),JMNNXT(200),JMXNXT(200),NINGRP(200)
      DIMENSION ININT(MXAO),ISMOFF(8),MULT8(8),LKUPSM(64)
      DIMENSION BSYM(2),ASYM(1)
C
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON /ORBSET/ NORBMX,NORBS,NCORBS,NLEVS,NA,NB,NC,NSYM,MSYM,
     *                IDOCC,IVAL,IMCC,ISYM(MXAO),ICODE(MXAO),
     *                NLCS(MXAO),LEVPT(MXAO),LEVNR(MXAO),
     *                IOUT(MXAO),NREFS,IEXCT,NFOCI,INTACT
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      DATA MULT8/0,8,16,24,32,40,48,56/
      DATA LKUPSM/1,2,3,4,5,6,7,8,2,1,4,3,6,5,8,7,3,4,1,2,7,8,5,6,4,3,
     + 2,1,8,7,6,5,5,6,7,8,1,2,3,4,6,5,8,7,2,1,4,3,7,8,5,6,3,4,1,2,
     + 8,7,6,5,4,3,2,1/
      DATA BSYM/6H  KADD,6H  LADD/
      DATA ASYM/6H  SYM /
      DATA NGRPMX,NEXTMX /200,200/
C
C     SET UP INDEXING SCHEME FOR GUGA CODE
C     THIS CONTROLS GUGSRT.SRC AND GUGEM.SRC
C
      DO 130 ISM = 1,NSYM
         ISMOFF(ISM) = (ISM-1)*NORBS
         DO 120 I = 1,NORBS
            ISMPT = ISMOFF(ISM)+I
            KADD(ISMPT) = 0
            LADD(ISMPT) = 0
  120    CONTINUE
  130 CONTINUE
C
C     ----- COUNT THE INTEGRALS -----
C
      IJ = 0
      INMAX = 0
      IJAD = 0
      DO 180 I = 1,NORBS
         JSM = ISYM(I)
         JAD = 0
         DO 170 J = 1,I
            IJ = IJ+1
            LKUP = MULT8(JSM) + ISYM(J)
            KSM = LKUPSM(LKUP)
            KAD = 0
            DO 160 K = 1,J
               KSMPT = K + ISMOFF(KSM)
               IF(KADD(KSMPT).NE.0 .AND. KADD(KSMPT).NE.KAD) GO TO 500
               KADD(KSMPT) = KAD
               LKUP = MULT8(KSM) + ISYM(K)
               LSM = LKUPSM(LKUP)
               LAD = 0
               DO 150 L = 1,K
                  LSMPT = L + ISMOFF(LSM)
                  IF(LADD(LSMPT).NE.0 .AND.
     *               LADD(LSMPT).NE.LAD) GO TO 520
                  LADD(LSMPT) = LAD
                  IF (LSM.NE.ISYM(L)) GO TO 150
                  IF (L.EQ.J .AND. L.LT.I) GO TO 150
                  LAD = LAD+3
                  IF (K.EQ.L) LAD = LAD-1
  150          CONTINUE
               KAD = KAD+LAD
  160       CONTINUE
            JAD = JAD+KAD
            IJNINT(IJ) = KAD
            IF (KAD.GT.NIPGRP) GO TO 580
  170    CONTINUE
         IJAD = IJAD+JAD
         ININT(I) = JAD
         IF (JAD .GT. INMAX) INMAX = JAD
  180 CONTINUE
C
C     ----- CHANGE NIPGRP IF IT IS TOO LARGE -----
C
      INMAX = INMAX + 20
      IF (INMAX  .GT. MXNINT) MXNINT = INMAX
      IF (MXNINT .GT. NIPGRP) GO TO 600
      IF (MXNINT .LT. NIPGRP) NIPGRP = MXNINT
C
C     ----- GENERATE THE ADDRESSING ARRAYS (IJADD,IJGRP) -----
C
      NGRPS = 0
      I = NORBS
      JMIN = 1
  200 CONTINUE
      K = 0
      MLEFT = NIPGRP
      IF (NGRPS .LT. 1) GO TO 240
      DO 220 IGRP = 1,NGRPS
         NLEFT = NIPGRP-NINGRP(IGRP)-ININT(I)
         IF (NLEFT .LT. 0) GO TO 220
         IF (NLEFT .GT. MLEFT) GO TO 220
         MLEFT = NLEFT
         K = IGRP
  220 CONTINUE
C
  240 CONTINUE
      IF (K .GT. 0) GO TO 260
      NGRPS = NGRPS+1
      IF (NGRPS .GT. NGRPMX) GO TO 560
      K = NGRPS
      NINGRP(K) = 0
C
  260 CONTINUE
      IJ = (I*(I-1))/2+JMIN
      DO 280 J = JMIN,I
         IF ((NINGRP(K)+IJNINT(IJ)) .GT. NIPGRP) GO TO 300
         IJGRP(IJ) = K
         IJADD(IJ) = NINGRP(K)
         NINGRP(K) = NINGRP(K)+IJNINT(IJ)
         IJ = IJ+1
  280 CONTINUE
      I = I-1
      JMIN = 1
      IF (I .EQ. 0) GO TO 320
      GO TO 200
C
  300 CONTINUE
      JMIN = J
      ININT(I) = ININT(I)-NINGRP(K)
      GO TO 200
C
C     ----- -INEXT- AND -JNEXT- ARRAYS FOR FORMULA GENERATION -----
C
  320 CONTINUE
      NEXT = 0
      DO 400 IGRP = 1,NGRPS
      I = NORBS
  340 CONTINUE
      ITEST = 0
      IJ = (I*(I-1))/2
      DO 380 J = 1,I
      IJ = IJ+1
      IF (ITEST .NE. 0) GO TO 360
      IF (IJGRP(IJ) .NE. IGRP) GO TO 380
      ITEST = 1
      NEXT = NEXT+1
      IF (NEXT .GT. NEXTMX) GO TO 540
      INEXT(NEXT) = I
      JMNNXT(NEXT) = J
      JMXNXT(NEXT) = I
      GO TO 380
  360 CONTINUE
      IF (IJGRP(IJ) .EQ. IGRP) GO TO 380
      JMXNXT(NEXT) = J-1
      ITEST = 0
  380 CONTINUE
      I = I-1
      IF (I .GT. 0) GO TO 340
  400 CONTINUE
C
C     ----- IF THERE IS ONLY ONE GROUP, RESET NIPGRP TO ITS SIZE -----
C
      IF (NGRPS .EQ. 1) NIPGRP = IJAD
      IF (SOME) WRITE (IW,9128) IJAD,NIPGRP,NGRPS
C
C          RUNS WITH LARGE NUMBERS OF INTEGRAL GROUPS WILL OCCUR
C          IN CASES WITH HIGHER SYMMETRY (4 OR MORE IRREPS PROBABLY)
C          AND WITH MANY OCCUPIED ORBITALS.  ABOUT THE ONLY KIND
C          OF RUN MEETING THIS CHARACTERISTIC IS CI-SD, FOCI, SOCI.
C          THE NUMBER OF GROUPS AT WHICH THE PROBLEM OCCURS IN
C          THE CI SORTING STEP IS A BIT OF A GUESS, TEN OR MORE IS
C          CERTAINLY LIKELY TO GIVE INCORRECT CI ENERGIES.
C
      IF(NGRPS.GT.5) THEN
         I = (NGRPS-1)/5 + 1
         IF(MASWRK) WRITE(IW,9129) I*MXNINT
         CALL ABRT
      END IF
      IF (.NOT.DEBUG) RETURN
C                     ******
C
      WRITE (IW,9148)
      WRITE (IW,9168)
      DO 440 K = 1,NEXT
      I = INEXT(K)
      JMIN = JMNNXT(K)
      JMAX = JMXNXT(K)
      IJ = (I*(I-1))/2+JMIN
      LAD = IJADD(IJ)
      IGRP = IJGRP(IJ)
      JAD = 0
      DO 420 L = JMIN,JMAX
      JAD = JAD+IJNINT(IJ)
      IJ = IJ+1
  420 CONTINUE
      WRITE (IW,9188) K,IGRP,I,JMIN,JMAX,JAD,LAD
  440 CONTINUE
      WRITE (IW,9208) (ASYM,K,K = 1,NSYM)
      WRITE (IW,9228) (BSYM,K = 1,NSYM)
      NOUT = NSYM*NORBS
      DO 460 K = 1,NORBS
      WRITE (IW,9248) K,(KADD(L),LADD(L),L = K,NOUT,NORBS)
  460 CONTINUE
      RETURN
C
  500 CONTINUE
      IF (MASWRK) WRITE(IW,9008) NORBS,I,J,K,KSMPT,KADD(KSMPT),
     *                           KAD,KSM,ISMOFF(KSM)
      CALL ABRT
C
  520 CONTINUE
      IF (MASWRK) WRITE(IW,9028) NORBS,I,J,K,L,LSMPT,LADD(LSMPT),
     *                           LAD,LSM,ISMOFF(LSM)
      CALL ABRT
C
  540 CONTINUE
      IF (MASWRK) WRITE(IW,9048) NEXT,NEXTMX,J,I,IGRP,NGRPS
      CALL ABRT
C
  560 CONTINUE
      IF (MASWRK) WRITE(IW,9068) NGRPS,NGRPMX,I,JMIN,NORBS
      CALL ABRT
C
  580 CONTINUE
      IF (MASWRK) WRITE(IW,9088)  KAD,NIPGRP,NORBS,I,J,K
      CALL ABRT
C
  600 CONTINUE
      IF (MASWRK) WRITE(IW,9108) NIPGRP,MXNINT
      CALL ABRT
C
 9008 FORMAT(25H SYMMETRY PROBLEMS WITH K,10I10)
 9028 FORMAT(25H SYMMETRY PROBLEMS WITH L,10I10)
 9048 FORMAT(18H NEXT IS TOO LARGE,6I10)
 9068 FORMAT(35H THERE ARE TOO MANY INTEGRAL BLOCKS,6I10)
 9088 FORMAT(20H NIPGRP IS TOO SMALL,6I10)
 9108 FORMAT(1X,'NOT ENOUGH MEMORY FOR INTEGRAL GROUP BUFFER.'/
     *       1X,'NIPGRP AND MXNINT =',2I10)
 9128 FORMAT(/,29H TOTAL NUMBER OF INTEGRALS = ,I10,/,
     +     29H NUMBER OF INTEGRALS/GROUP = ,I10,/,
     +     29H NUMBER OF INTEGRAL GROUPS = ,I10)
 9129 FORMAT(1X,'**** THERE ARE TOO MANY INTEGRAL GROUPS ****'/
     *       1X,'PLEASE ENTER MXNINT=',I7,' IN $DRT TO REDUCE THE'/
     *       1X,'NUMBER OF INTEGRAL GROUPS TO FIVE OR LESS.')
 9148 FORMAT(/,1X,51(1H-),29H INTEGRAL GROUPING BREAKDOWN ,52(1H-),/)
 9168 FORMAT(51H   NEXT GROUP    I   JMIN  JMAX     NINTS     IJADD,/)
 9188 FORMAT(5I6,4I10)
 9208 FORMAT(/,7X,8(A6,I2,7X))
 9228 FORMAT(6H  IORB,8(2A6,3X))
 9248 FORMAT(I5,8(2I6,3X))
      END
C*MODULE GUGDRT  *DECK DRTWRT
      SUBROUTINE DRTWRT(NFT11,NROWS,NROWS4,NKL,NIJ,NABCA,NABCB,NABCS,
     +                  IARC,NLWKS,NUWKS,PUWK,INDX,IWGHT,IJADD,IJGRP,
     *                  KADD,LADD,INEXT,JMNNXT,JMXNXT,NWKS,
     *                  NEXT,NGRPS,MXNINT,IJAD)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INTEGER   PUWK
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      PARAMETER (MXAO=8192)
C
      DIMENSION NABCA(NROWS),NABCB(NROWS),NABCS(NROWS)
      DIMENSION IARC(NROWS4),NLWKS(NROWS),NUWKS(NROWS),PUWK(NROWS)
      DIMENSION INDX(NWKS),IWGHT(NROWS4),IJADD(NIJ),IJGRP(NIJ)
      DIMENSION KADD(NKL),LADD(NKL),INEXT(200),JMNNXT(200),JMXNXT(200)
C
      COMMON /ORBSET/ NORBMX,NORBS,NCORBS,NLEVS,NA,NB,NC,NSYM,MSYM,
     *                IDOCC,IVAL,IMCC,ISYM(MXAO),ICODE(MXAO),
     *                NLCS(MXAO),LEVPT(MXAO),LEVNR(MXAO),
     *                IOUT(MXAO),NREFS,IEXCT,NFOCI,INTACT
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      IF (MASWRK.OR.DSKWRK) THEN
         WRITE(NFT11) IOUT
         WRITE(NFT11) ISYM
         WRITE(NFT11) LEVNR
         WRITE(NFT11) LEVPT
         WRITE(NFT11) NABCA
         WRITE(NFT11) NABCB
         WRITE(NFT11) NABCS
         WRITE(NFT11) NLWKS
         WRITE(NFT11) NUWKS
         WRITE(NFT11) PUWK
         WRITE(NFT11) INDX
         WRITE(NFT11) IARC
         WRITE(NFT11) IWGHT
         WRITE(NFT11) NGRPS,NEXT,MXNINT,IJAD
         WRITE(NFT11) IJADD
         WRITE(NFT11) IJGRP
         WRITE(NFT11) KADD
         WRITE(NFT11) LADD
         WRITE(NFT11) INEXT
         WRITE(NFT11) JMNNXT
         WRITE(NFT11) JMXNXT
      END IF
      RETURN
      END
C*MODULE GUGDRT  *DECK MAKDET
      SUBROUTINE MAKDET(MO,ICASE,IPRIM,IORDER,ICSF,NSORB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION ICASE(MO),IPRIM(*),ICSF(MO),IORDER(MO)
C
C ... MAKE SLATER DETERMINANTS: ALPHA(+), BETA(-)
C     ORDERING IS THE SAME AS CASE VECTORS.
C
      NSORB=0
      IOPEN=0
      DO 20 I=1,MO
        ICAS=ICASE(I)
        GO TO (20,22,22,24),ICAS
C
   22   IOPEN =IOPEN+1
        NSORB =NSORB+1
        IF(IPRIM(IOPEN).EQ.1) THEN
          ICSF(NSORB) = IORDER(I)
        ELSE
          ICSF(NSORB) =-IORDER(I)
        END IF
        GO TO 20
C
C ... THE ORDERING OF SPIN FUNCITONS IS (BETA, ALPHA).
C                                        ****  *****
   24   NSORB =NSORB+1
        ICSF(NSORB) = IORDER(I)
        NSORB =NSORB+1
        ICSF(NSORB) =-IORDER(I)
   20   CONTINUE
      RETURN
      END
C
C*MODULE GUGDRT  *DECK ORDORB
      SUBROUTINE ORDORB(DRTINP,TITLE,LEVFRM,MXNINT,NEMEMX,
     *                  NPRINT,NPFLG,SOME,IORBTP,ISMTP,MXORB,IORBCD,
     *                  Q,S,VEC,WRK,LABMO,LMOIRP,LMODEG,L1,L2,L3)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL SOME,FORS,FOCI,SOCI,INTAC,GOPARR,DSKWRK,MASWRK,
     *        FOCAS,SOSCF,DROPC,ABEL
C
      PARAMETER (MXATM=2000, MXSH=5000, MXAO=8192, MXGRPS=13, MXIRR=14)
C
      INTEGER ORBLAB(12),SYMREP(12,MXGRPS),SYMB,SPACE
C
      DIMENSION TITLE(10)
      DIMENSION IORBTP(12,MXORB),ISMTP(MXORB),IORBCD(L1),
     *          Q(L3),S(L2),VEC(L3),WRK(L1),
     *          LABMO(L1),LMOIRP(L1),LMODEG(L1)
      DIMENSION NORBTP(12),NSYMTP(12,8),MULT8(8),ISYMTR(8),LKUPSM(64),
     *          GROUPS(MXGRPS),NSYMS(MXGRPS),NIRRPS(MXGRPS),
     *          ISYMRP(12,MXGRPS)
C
      COMMON /CASOPT/ CASHFT,CASDII,NRMCAS,FOCAS,SOSCF,DROPC
      COMMON /GUGWFN/ NFZC,NMCC,NDOC,NAOS,NBOS,NALP,NVAL,NEXT,NFZV,
     *                IFORS,IEXCIT,ICICI,NOIRR
      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,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON /ORBSET/ NORBMX,NORBS,NCORBS,NLEVS,NA,NB,NC,NSYM,MSYM,
     *                IDOCC,IVAL,IMCC,ISYM(MXAO),JCODE(MXAO),
     *                NLCS(MXAO),LEVPT(MXAO),LEVNR(MXAO),
     *                IOUT(MXAO),NREFS,IEXCT,NFOCI,INTACT
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /SOSYM/  EULANG(4,48),GAM(48,48),IRMON(MXAO)
      COMMON /SYMBLK/ NIRRED,NSALC,NSALC2,NSALC3,NSAFMO
      COMMON /SYMQMT/ IRPLAB(MXIRR),IRPNUM(MXIRR),IRPDIM(MXIRR),
     *                IRPDEG(MXIRR)
      COMMON /SYMMOL/ DATGRP,COMPLX,IGROUP,NAXIS,ILABMO,ABEL
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(432),INVT(48),NT
      COMMON /WFNOPT/ SCFTYP,CITYP,DFTYPE,CCTYP,MPLEVL,MPCTYP
      COMMON /FMOINF/ NFG,NLAYER,NATFMO,NBDFG,NAOTYP,NBODY
      COMMON /FMORUN/ ESPSCF,IDAFMO,ICURLAY,ICURFG,JCURFG,KCURFG,NCURSH,
     *                NGAU,ICURPOP,IFMOSTP,MONCOR,NAT1E,NEEDR,MODRST,
     *                NORBPROJ
C
C        NAMELIST NAME MAY BE $DRT OR $CIDRT OR $DRT1 OR ...
C
      PARAMETER (NNAM=20)
      DIMENSION QNAM(NNAM),KQNAM(NNAM)
      DATA QNAM/8HGROUP   ,8HMXNINT  ,8HMXNEME  ,8HNPRT    ,
     *          8HIEXCIT  ,8HFORS    ,8HFOCI    ,8HSOCI    ,
     *          8HINTACT  ,8HNFZC    ,8HNMCC    ,8HNDOC    ,
     *          8HNALP    ,8HNAOS    ,8HNBOS    ,8HNVAL    ,
     *          8HNEXT    ,8HNFZV    ,8HNOIRR   ,8HISTSYM  /
      DATA KQNAM /5,1,1,1, 1,0,0,0, 0,1,1,1, 1,1,1,1, 1,1,1,1/
C
      DATA MULT8/0,8,16,24,32,40,48,56/
      DATA LKUPSM/1,2,3,4,5,6,7,8,
     *            2,1,4,3,6,5,8,7,
     *            3,4,1,2,7,8,5,6,
     *            4,3,2,1,8,7,6,5,
     *            5,6,7,8,1,2,3,4,
     *            6,5,8,7,2,1,4,3,
     *            7,8,5,6,3,4,1,2,
     *            8,7,6,5,4,3,2,1/
C
      DATA GROUPS/8HC1      ,8HCI      ,8HCS      ,8HC2      ,
     *            8HC2V     ,8HC2H     ,8HD2      ,8HD2H     ,
     *            8HCINFV   ,8HDINFH   ,8HD4H     ,8HD4      ,
     *            8HC4V     /
      DATA NIRRPS/1,2,2,2,4,4,4,8,5,10,12,6,6/
      DATA NSYMS /1,2,2,2,4,4,4,8,4, 8, 8,4,4/
C                        C1
      DATA  SYMREP(1,1)       /4HA   /
      DATA  ISYMRP(1,1)       /1/
C                        CI
      DATA (SYMREP(I,2),I=1,2)/4HAG  ,4HAU  /
      DATA (ISYMRP(I,2),I=1,2)/1,2/
C                        CS
      DATA (SYMREP(I,3),I=1,2)/4HA'  ,4HA'' /
      DATA (ISYMRP(I,3),I=1,2)/1,2/
C                        C2
      DATA (SYMREP(I,4),I=1,2)/4HA   ,4HB   /
      DATA (ISYMRP(I,4),I=1,2)/1,2/
C                        C2V
      DATA (SYMREP(I,5),I=1,4)/4HA1  ,4HA2  ,4HB1  ,4HB2  /
      DATA (ISYMRP(I,5),I=1,4)/1,2,3,4/
C                        C2H
      DATA (SYMREP(I,6),I=1,4)/4HAG  ,4HBU  ,4HBG  ,4HAU  /
      DATA (ISYMRP(I,6),I=1,4)/1,2,3,4/
C                        D2
      DATA (SYMREP(I,7),I=1,4)/4HA   ,4HB1  ,4HB2  ,4HB3  /
      DATA (ISYMRP(I,7),I=1,4)/1,2,3,4/
C                        D2H
      DATA (SYMREP(I,8),I=1,8)/4HAG  ,4HB1G ,4HB2G ,4HB3G ,
     *                         4HAU  ,4HB1U ,4HB2U ,4HB3U /
      DATA (ISYMRP(I,8),I=1,8)/1,2,3,4,5,6,7,8/
C
C           NOTE THAT CINFV AND DINFH DON'T WORK NOW
C
C                        CINFV
      DATA (SYMREP(I,9),I=1,5)/4HSIG ,4HPIX ,4HPIY ,4HDELX,4HDELY/
      DATA (ISYMRP(I,9),I=1,5)/1,3,4,1,2/
C                        DINFH
      DATA (SYMREP(I,10),I=1,10)/4HSIGG,4HSIGU,4HPIUX,4HPIUY,4HPIGX,
     *                           4HPIGY,4H DGX,4H DGY,4H DUX,4H DUY/
      DATA (ISYMRP(I,10),I=1,10)/1,6,8,7,3,4,1,2,6,5/
C                        D4H
C         MICHEL'S SYMMETRY CODE GENERATE EGY BEFORE EGX
      DATA (SYMREP(I,11),I=1,12)/4HA1G ,4HA2G ,4HB1G ,4HB2G ,
     *                           4HA1U ,4HA2U ,4HB1U ,4HB2U ,
     *                           4HEG  ,4HEG  ,4HEU  ,4HEU  /
      DATA (ISYMRP(I,11),I=1,12)/1,2,1,2, 5,6,5,6, 4,3,8,7/
C                        D4
      DATA (SYMREP(I,12),I=1,6) /4HA1  ,4HA2  ,4HB1  ,4HB2  ,
     *                           4HE   ,4HE   /
      DATA (ISYMRP(I,12),I=1,6) /1,2,1,2, 4,3/
C                        C4V
      DATA (SYMREP(I,13),I=1,6) /4HA1  ,4HA2  ,4HB1  ,4HB2  ,
     *                           4HE   ,4HE   /
      DATA (ISYMRP(I,13),I=1,6) /1,2,1,2, 3,4/
C
      DATA C1G/8HC1      /
      DATA ORBLAB/4HDOC ,4HEXT ,4HFZC ,4HFZV ,4HALP ,4HAOS ,4HBOS ,
     *            4HGVA ,4HGVB ,4H    ,4HVAL ,4HMCC /
C
      DATA RMC/8HMCSCF   /
      DATA DRT,CIDRT/8HDRT     ,8HCIDRT   /
      DATA TRANST/8HTRANSITN/
      DATA HESS/8HHESSIAN /
      DATA AMEX/8HMEX     /
      DATA BLANK/8H         /
C
C     ----- READ THE DISTINCT ROW TABLE INPUT -----
C     ----- REORDER THE ORBITALS BY TYPE AND SYMMETRY -----
C     THE GUGA CODE EXPECTS THE ORDER
C         FZC,EXT,MCC,VAL,DOC,FZV,ALP,AOS,BOS,GVA,GVB
C     AND WITHIN EACH TYPE THE ORBITALS ARE SORTED BY IRREP.
C
C     ----- ABELIAN GROUPS -----
C  IGRP=     8    7    6   5    4    3    2    1
C GROUP=    D2H   D2  C2H  C2V  C2   CS   CI   C1
C IRREP= 1  AG    A   AG   A1   A    A'   AG   A1
C        2  B1G   B1  BU   A2   B    A"   AU
C        3  B2G   B2  BG   B1
C        4  B3G   B3  AU   B2
C        5  AU
C        6  B1U
C        7  B2U
C        8  B3U
C
C     ----- NON-ABELIAN -----
C    THESE GROUPS ARE DEALT WITH AS THE HIGHEST ABELIAN SUBGROUP.
C    THE IRREP NUMBER MUST BE 1 OF THE IRREPS IN THE SUBGROUP USED.
C
C  IGRP=      9        10          11      12      13
C GROUP=    CINFV     DINFH       D4H      D2H     C4V
C SUBGRP=    C2V       D2H        D2H      D2      C2V
C IRREP= 1 SIG,DELX  SIGG,DGX   A1G,B1G    A1      A1
C        2   DELY      DGY      A2G,B2G    A2      A2
C        3   PIX       PIGX       EGX     B1,EY   B1,EX
C        4   PIY       PIGY       EGY     B2,EX   B2,EY
C        5             DUY      A1U,B1U
C        6           SIGU,DUX   A2U,B2U
C        7             PIUY       EUY
C        8             PIUX       EUX
C
C     ----- ARE WE RUNNING MCSCF OR CI AT THE MOMENT? -----
C     THIS IS SAVED IN COMMON TO TEST LATER, AS BOTH TYPES OF
C     WAVEFUNCTIONS MAY BE COMPUTED IN THE SAME JOB STREAM.
C
                           ICICI= -1
      IF(DRTINP.EQ.DRT)    ICICI=0
      IF(DRTINP.EQ.CIDRT)  ICICI=1
      IF(RUNTYP.EQ.TRANST) ICICI=1
      IF(RUNTYP.EQ.AMEX)   ICICI=0
C
      IF(ICICI.EQ.-1) THEN
         IF(MASWRK) WRITE(IW,9000) DRTINP
         CALL ABRT
      END IF
C
C     SET GOLDEN OLDIE VARIABLES (UNUSED NOW)
C     NOTE THAT ORBITAL TYPES -GVA- AND -GVB- ARE IMPOSSIBLE NOW.
C
      DO 100 I=1,10
         TITLE(I)=BLANK
  100 CONTINUE
      TITLE(1)=DRTINP
      CALL TMDATE(TITLE(2))
      NREFS=1
C
C     ----- READ THE DRT INPUT -----
C
      GROUP=BLANK
      MXNINT=50000
      NEMEMX=10000
      NPFLG=0
      IEXCT=0
      FORS=.FALSE.
      FOCI=.FALSE.
      SOCI=.FALSE.
      INTAC=.FALSE.
      NFZC=0
      NMCC=0
      NDOC=0
      NAOS=0
      NBOS=0
      NALP=0
      NVAL=0
      NEXT=0
      NFZV=0
      NOIRR=1
      IF(RUNTYP.EQ.TRANST) NOIRR=0
      IRRCI=0
C
      JRET = 0
      CALL NAMEIO(IR,JRET,DRTINP,NNAM,QNAM,KQNAM,
     *            GROUP,MXNINT,NEMEMX,NPFLG,IEXCT,FORS,FOCI,SOCI,INTAC,
     *            NFZC,NMCC,NDOC,NALP,NAOS,NBOS,NVAL,NEXT,NFZV,
     *            NOIRR,IRRCI,
     *            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)
      IF(JRET .EQ. 1) THEN
         IF(NPRINT.EQ.-23) THEN
            RETURN
         ELSE
            IF (MASWRK) WRITE(IW,9010) DRTINP
            CALL ABRT
         END IF
      END IF
C
C     ADD SECOND RHF MONOMER AS CORE FOR FMO RUNS OF MCSCF DIMERS.
C     EMULATE ROHF WITH AN APPROPRIATE MCSCF IF MONCOR IS NEGATIVE.
C
      IF(NFG.NE.0) THEN
         IF(MONCOR.GE.0) THEN
            IF(IFMOSTP.GE.3) THEN
               IF(SCFTYP.EQ.RMC) THEN
                  NMCC=NMCC+MONCOR
               ELSE
                  NFZC=NFZC+MONCOR
               ENDIF
            ENDIF
         ELSE
            NALP=MUL-1
            NVAL=0
            NDOC=0
            NAOS=0
            NBOS=0
            IF(SCFTYP.EQ.RMC) THEN
               NMCC=(NE-NALP)/2
            ELSE
               NFZC=(NE-NALP)/2
            ENDIF
C           WRITE(6,*) 'FMO-ROHF RESET CAS SPACE TO',NALP,NMCC,NFZC
C           CALL ABRT
         ENDIF
      ENDIF
C
C     SET DEFAULT VALUES (THAT CANNOT BE OVERWRITTEN WITH INPUT) FOR
C     FMO-CISD. INPUT MUST HAVE NACT EQUAL TO 0 FOR FMO-CISD.
C
      IF(NFG.NE.0.AND.NDOC+NAOS+NBOS+NALP+NVAL.EQ.0) THEN
         NFZC=NUMCOR()
         NALP=MUL-1
         NDOC=(NE-NALP)/2-NFZC
         NVAL=NQMT-NFZC-NDOC-NALP
         IF(MASWRK) WRITE(6,*) 'DEFAULTS',NFZC,NMCC,NDOC,NALP,NAOS,NBOS,
     *                                    NVAL,NEXT,NFZV
      ENDIF
C
      NCORE = NFZC + NMCC
      NACT  = NDOC + NAOS + NBOS + NALP + NVAL
      NOCC  = NCORE + NACT
      IF(IEXCT.GT.0 .AND. NOCC.GT.NQMT) THEN
         NVAL = NVAL - NUM + NQMT
         NACT = NDOC + NAOS + NBOS + NALP + NVAL
         NOCC = NCORE + NACT
      END IF
      IF(FOCI  .OR.  SOCI) THEN
         IF(NEXT.LT.0) NEXT = NQMT-NOCC-NFZV
         NORB = NOCC + NEXT
      ELSE
         NEXT = 0
         NORB = NOCC
      END IF
      NORBMX = NORB
      NORBS  = NORB
      NCORBS = NCORE
C
C        SPECIAL OPTION TO JUST READ NMCC, ETC, AND THEN RETURN
C
C     THE NUMBER OF A+B ELECTRONS IS NOW JUST SET TO THE
C     NUMBER OF OCCUPIED ORBITALS, SO THESE ARE NOW INCORRECT.
C
      MA = NORBS
      MB = NORBS
C
      IF(NPRINT.EQ.-23) RETURN
C
C      CHANGE GROUP TO C1 FOR MCSCF HESSIANS, OR IF SYMMETRY NOT USED.
C
      IF (RUNTYP.EQ.HESS  .OR.  NT.EQ.1) THEN
         IRRCI = 1
         GROUP = C1G
      END IF
C
      IF(SOME) WRITE(IW,9020) GROUP,NPFLG, FORS,INTAC,
     *                        FOCI,MXNINT, SOCI,NEMEMX,  IEXCT,
     *                        NFZC,NDOC,NEXT, NMCC,NAOS,NFZV,
     *                        NBOS, NALP, NVAL
C
      NERR=0
C
      IGRP = 0
      NSYM = 0
      NIRRP= 0
      DO 110 I=1,MXGRPS
         IF(GROUP.EQ.GROUPS(I)) THEN
            IGRP = I
            NSYM = NSYMS(I)
            NIRRP= NIRRPS(I)
         END IF
  110 CONTINUE
      IF(GROUP.EQ.GROUPS(9)  .OR.  GROUP.EQ.GROUPS(10)) THEN
         IF(MASWRK) WRITE(IW,*) 'CINFV AND DINFH NO LONGER WORK,'
         IF(MASWRK) WRITE(IW,*) 'SO USE C4V AND D4H, RESPECTIVELY.'
         NERR=NERR+1
      END IF
      IF(IGRP.EQ.0) THEN
         IF (MASWRK) WRITE(IW,9030) GROUP
         NERR=NERR+1
      END IF
C
      IFORS = 0
      IF(FORS) IFORS=1
      IF(IEXCT.LE.0  .AND.  .NOT.(FORS.OR.FOCI.OR.SOCI)) THEN
         IF (MASWRK) WRITE(IW,*)
     *      'IEXCIT IS A REQUIRED ENTRY IN DRT/CIDRT INPUT,'
         IF (MASWRK) WRITE(IW,*)
     *      'UNLESS YOU CHOOSE ONE OF -FORS,FOCI,SOCI-.'
         NERR=NERR+1
      END IF
C
      INTACT=0
      IF(INTAC) INTACT=1
C
      NFOCI=0
      IF(FOCI) NFOCI=1
      IF(SOCI) NFOCI=2
      IF((FORS.AND.FOCI).OR.(FORS.AND.SOCI).OR.(FOCI.AND.SOCI)) THEN
         IF (MASWRK) WRITE(IW,*)
     *      'ONLY ONE OF -FORS,FOCI,SOCI- SHOULD BE CHOSEN.'
         NERR=NERR+1
      END IF
      IF(IEXCT.GT.0  .AND.  (FORS.OR.FOCI.OR.SOCI)) THEN
         IF (MASWRK) WRITE(IW,*)
     *      'IEXCIT MAY NOT BE GIVEN AT THE SAME TIME AS FORS/FOCI/SOCI'
         NERR=NERR+1
      END IF
C
      IF(NPFLG.LT.0  .OR.  NPFLG.GT.4) NPFLG=0
C
C        CI GRADIENT PERMITS FROZEN CORES, BUT NOT FROZEN VIRTUALS
C
      CALL DERCHK(NDER)
      IF(ICICI.EQ.1  .AND.  NDER.EQ.1) THEN
         IF(NORBS.NE.NQMT) THEN
            WRITE(IW,9170) NORBS,NQMT,NFZC,NDOC,NAOS,NBOS,NALP,NVAL
            CALL ABRT
         END IF
         IF(FOCI  .OR.  SOCI  .OR.  NEXT.GT.0) THEN
            WRITE(IW,9180) IEXCIT,FOCI,SOCI,NFZC,NDOC,
     *                     NAOS,NBOS,NALP,NVAL,NEXT
            CALL ABRT
         END IF
      END IF
C
      NACTE = 2*NDOC + NAOS + NBOS + NALP
      NHOLE = NAOS + NBOS + NALP + 2*NVAL
      IF(FORS) IEXCT = MIN(NACTE,NHOLE  )
      IF(FOCI) IEXCT = MIN(NACTE,NHOLE+1)
      IF(SOCI) IEXCT = MIN(NACTE,NHOLE+2)
      IEXCIT = IEXCT
      IF(SOME) WRITE(IW,9040) IEXCT
C
      IF(ICICI.EQ.1  .AND.  NMCC.GT.0) THEN
         IF (MASWRK) WRITE(IW,*)
     *      'ERROR...$CIDRT MUST USE -FZC- FOR -CI- WAVEFUNCTIONS.'
         NERR=NERR+1
      END IF
      IF(ICICI.EQ.0  .AND.  NFZC.GT.0) THEN
         IF (MASWRK) WRITE(IW,*)
     *      'ERROR...$DRT MUST USE -MCC- FOR -MCSCF- WAVEFUNCTIONS.'
         NERR=NERR+1
      END IF
      IF(NACT.EQ.0) THEN
         IF (MASWRK) WRITE(IW,*)
     *      'ERROR...YOUR DRT INPUT DEFINES NO ACTIVE ORBITALS.'
         NERR=NERR+1
      END IF
      IF(NAOS.NE.NBOS) THEN
         IF (MASWRK) WRITE(IW,*)
     *      'NAOS.NE.NBOS IN DRT INPUT DOES NOT MAKE SENSE.'
         NERR=NERR+1
      END IF
      IF(NORB.GT.NUM) THEN
         IF (MASWRK) WRITE(IW,*)
     *      'YOUR DRT HAS MORE MO-S=',NORB,' THAN AO-S=',NUM
         NERR=NERR+1
      END IF
      IF(NORB.GT.MXORB) THEN
         IF (MASWRK) WRITE(IW,*)
     *      'DRT DEFINES MORE MO-S=',NORB,' THAN MXORB=',MXORB
         NERR=NERR+1
      END IF
      IF(NUM.GT.MXORB-1) THEN
         IF(MASWRK) WRITE(IW,*)
     *      'CI/MCSCF PROGRAM IS DIMENSION LIMITED TO',MXORB,' AOS'
         NERR=NERR+1
      END IF
C
      IF(JRET.GT.0  .OR.  NERR.GT.0) CALL ABRT
C
      K=0
      DO 210 I=1,NMCC
         IORBCD(K+I) = ORBLAB(12)
  210 CONTINUE
      K = K + NMCC
      DO 220 I=1,NFZC
         IORBCD(K+I) = ORBLAB(3)
  220 CONTINUE
      K = K + NFZC
      DO 230 I=1,NDOC
         IORBCD(K+I) = ORBLAB(1)
  230 CONTINUE
      K = K + NDOC
      DO 240 I=1,NAOS
         IORBCD(K+2*I-1) = ORBLAB(6)
         IORBCD(K+2*I  ) = ORBLAB(7)
  240 CONTINUE
      K = K + 2*NAOS
      DO 250 I=1,NALP
         IORBCD(K+I) = ORBLAB(5)
  250 CONTINUE
      K = K + NALP
      DO 260 I=1,NVAL
         IORBCD(K+I) = ORBLAB(11)
  260 CONTINUE
      K = K + NVAL
      DO 270 I=1,NEXT
         IORBCD(K+I) = ORBLAB(2)
  270 CONTINUE
      K = K + NEXT
      IF(K.NE.NORB) THEN
         IF (MASWRK) WRITE(IW,*) 'MISMATCH, K,NORB=',K,NORB
         CALL ABRT
      END IF
      DO 280 I=1,NFZV
         IORBCD(K+I) = ORBLAB(4)
  280 CONTINUE
C
C     ----- OBTAIN SYMMETRY OF MO-S IN THE $DATA GROUP -----
C
      IF(IGRP.EQ.1) THEN
C
C            IF TRUE GROUP IS HIGHER THAN C1, IT IS USEFUL TO PRINT
C            ORBITAL SYMMETRIES IN THAT GROUP, AND TO GET -IRMON- SET
C            PROPERLY IN SYMMOS FOR LATER USE IN CI WFN LABELING.
C
         IF(IGROUP.NE.1) THEN
            CALL DAREAD(IDAF,IODA,S  ,L2,12,0)
            CALL DAREAD(IDAF,IODA,VEC,L3,15,0)
            CALL DAREAD(IDAF,IODA,Q  ,L3,45,0)
            CALL TRFSYM(LABMO,LMOIRP,LMODEG,Q,S,VEC,WRK,IA,
     *                  NQMT,L1,NQMT,L1)
C
C              SAVE ORBITAL SYMMETRY INFO TRANSLATED TO JAKAL VALUES,
C              IN CASE THE JACOBI CONVERGER WILL BE USED LATER.
C
            CALL GAJASW(LMOIRP,L1,GROUP)
            CALL DAWRIT(IDAF,IODA,LMOIRP,L1,262,1)
C                SET -IRMON- FOR SPIN-ORBIT JOBS
            IF(RUNTYP.EQ.TRANST) THEN
               CALL DAREAD(IDAF,IODA,S  ,L2,12,0)
               CALL DAREAD(IDAF,IODA,VEC,L3,15,0)
               CALL DAREAD(IDAF,IODA,Q  ,L3,45,0)
               CALL SYMMOS(LABMO,Q,S,VEC,WRK,L1,L1,NQMT,L1)
            END IF
            IF(SOME) THEN
               WRITE(IW,9200)
               WRITE(IW,9060) NCORE,NACT,NEXT
               IF(NCORE.GT.0) WRITE(IW,9070) (LABMO(I),I=1,NCORE)
               IMAX = NCORE
  300          CONTINUE
                  IMIN = IMAX+1
                  IMAX = MIN(IMAX+10,NCORE+NACT)
                  WRITE(IW,9080) ( LABMO(I),I=IMIN,IMAX)
                  WRITE(IW,9090) (IORBCD(I),I=IMIN,IMAX)
               IF(IMAX.LT.NCORE+NACT) GO TO 300
               IF(NEXT.GT.0) WRITE(IW,9100) (LABMO(NCORE+NACT+I),
     *                                         I=1,NEXT)
               WRITE(IW,9210)
            END IF
            DO I=1,NORB
               LABMO(I) = SYMREP(1,1)
               ISMTP(I) = 1
            END DO
         ELSE
            DO I=1,NORB
               LABMO(I) = SYMREP(1,1)
               LMOIRP(I)= 1
               LMODEG(I)= 1
               ISMTP(I) = 1
               IRMON(I) = 1
            END DO
            CALL DAWRIT(IDAF,IODA,LMOIRP,L1,262,1)
         END IF
         GO TO 380
      ELSE
         CALL DAREAD(IDAF,IODA,S  ,L2,12,0)
         CALL DAREAD(IDAF,IODA,VEC,L3,15,0)
         CALL DAREAD(IDAF,IODA,Q  ,L3,45,0)
         CALL TRFSYM(LABMO,LMOIRP,LMODEG,Q,S,VEC,WRK,IA,NQMT,L1,NQMT,L1)
         CALL GAJASW(LMOIRP,L1,GROUP)
         CALL DAWRIT(IDAF,IODA,LMOIRP,L1,262,1)
C            SET -IRMON- FOR SPIN-ORBIT JOBS
         IF(RUNTYP.EQ.TRANST) THEN
            CALL DAREAD(IDAF,IODA,S  ,L2,12,0)
            CALL DAREAD(IDAF,IODA,VEC,L3,15,0)
            CALL DAREAD(IDAF,IODA,Q  ,L3,45,0)
            CALL SYMMOS(LABMO,Q,S,VEC,WRK,L1,L1,NQMT,L1)
         END IF
      END IF
C
C     ----- OBTAIN SYMMETRY OF MO-S (IN HIGHEST ABELIAN SUBGROUP) -----
C
      NERR=0
      NERR2=0
      IPART=0
      IRREP=0
      ISM=0
      DO 360 K=1,NORB
         SYMB=LABMO(K)
         DO 310 IRP=1,NIRRED
            IF(SYMB.EQ.IRPLAB(IRP)) THEN
               IRREP = IRP
               GO TO 320
            END IF
  310    CONTINUE
C
         NERR=NERR+1
         ISMTP(K)=0
         IF(MASWRK) WRITE(IW,9050) K,SYMB
         GO TO 360
C
  320    CONTINUE
         IDIM = IRPDIM(IRREP)
         IF(IDIM.GT.1) THEN
            IPART=IPART+1
            IOFF =IPART-1
         ELSE
            IOFF=0
         END IF
         DO 340 I=1,NIRRP
            IF(SYMB.EQ.SYMREP(I,IGRP)) THEN
               ISMTP(K)=ISYMRP(I+IOFF,IGRP)
               IF(IPART.EQ.IDIM) IPART=0
               GO TO 360
            END IF
  340    CONTINUE
C
         NERR2=NERR2+1
         IF(MASWRK) WRITE(IW,9055) K,SYMB,GROUP
         ISMTP(K)=0
C
  360 CONTINUE
      IF(NERR.GT.0) CALL ABRT
      IF(NERR2.GT.0) THEN
         IF(MASWRK) WRITE(IW,*) '$DRT GROUP MUST MATCH $DATA GROUP'
         CALL ABRT
      END IF
C
  380 CONTINUE
      IF(SOME) WRITE(IW,9060) NCORE,NACT,NEXT
      K=0
      IF(SOME .AND. NCORE.GT.0) WRITE(IW,9070) (LABMO(K+I),I=1,NCORE)
      K=K+NCORE
      IF(SOME .AND. NACT.GT.0) THEN
         IMAX = 0
  390    CONTINUE
            IMIN = IMAX+1
            IMAX = MIN(IMAX+10,NACT)
            IF (MASWRK) THEN
               WRITE(IW,9080) (LABMO(K+I),I=IMIN,IMAX)
               WRITE(IW,9090) (IORBCD(K+I),I=IMIN,IMAX)
            END IF
         IF(IMAX.LT.NACT) GO TO 390
      END IF
      K=NCORE+NACT
      IF(SOME .AND. NEXT.GT.0) WRITE(IW,9100) (LABMO(K+I),I=1,NEXT)
C
      NTPS = 12
      DO 420 I = 1,NTPS
         DO 400 J = 1,8
            NSYMTP(I,J) = 0
  400    CONTINUE
         DO 410 J=1,NORB
            IORBTP(I,J) = 0
  410    CONTINUE
         NORBTP(I) = 0
  420 CONTINUE
C
      DO 530 K=1,NORB
         DO 510 ICODE = 1,NTPS
            IF (ORBLAB(ICODE) .EQ. IORBCD(K)) GO TO 520
  510    CONTINUE
         IF(MASWRK)WRITE(IW,*)' ERROR IN ORDORB'
         CALL ABRT
  520    CONTINUE
         ISM = ISMTP(K)
         NTP = NORBTP(ICODE)+1
         NORBTP(ICODE) = NTP
         IORBTP(ICODE,NTP) = K
         NSYMTP(ICODE,ISM) = NSYMTP(ICODE,ISM)+1
  530 CONTINUE
C
      DO 570 ISM = 1,NSYM
         ISUM=NSYMTP(1,ISM)
         DO 560 ICODE = 5,NTPS
            ISUM = ISUM + NSYMTP(ICODE,ISM) * MXORB
  560    CONTINUE
         NSYMTP(1,ISM) = ISUM
  570 CONTINUE
C
C     ----- FROZEN CORE ORBITALS -----
C
      ICODE = 3
      NFZC = NORBTP(ICODE)
      IF (NFZC .LT. 1 .OR. NDER.GT.0) GO TO 640
      DO 620 J = 1,NFZC
         K = IORBTP(ICODE,J)
         IOUT(K) = -1
  620 CONTINUE
C
  640 CONTINUE
      MSYM = 1
      IORB = 0
      NELECT = 2*NFZC
      MA = NFZC
      MB = NFZC
      NA = 0
      NB = 0
      NC = 0
      NELE = 0
      IACT = 0
      IDOCC = 0
      IVAL = 0
      IMCC = 0
C
      IF(NFZC.LT.1 .OR. NDER.EQ.0) GO TO 700
      CALL RDRSYM(ICODE,NSYMTP,MULT8,LKUPSM,ISYMTR,NSYM)
C
      DO 650 IISM = 1,NSYM
         IIISM = NSYM-IISM+1
         ISM = ISYMTR(IIISM)
         DO 660 J = 1,NFZC
            K = IORBTP(ICODE,J)
            IF (ISM .NE. ISMTP(K)) GO TO 660
            IVAL = IVAL+1
            IDOCC = IDOCC+1
            IORB = IORB+1
            IOUT(K) = IORB
            IACT = IACT+1
            NA = NA+1
            NLCS(IORB) = NELE
            NELE = NELE+2
            ISYM(IORB) = ISMTP(K)
            JCODE(IORB) = ICODE
  660    CONTINUE
  650 CONTINUE
C
  700 CONTINUE
C
C     ----- EXTERNAL (UNOCCUPIED EXCEPT IN FOCI,SOCI) ORBITALS -----
C
      ICODE = 2
      NEXT = NORBTP(ICODE)
      CALL RDRSYM(ICODE,NSYMTP,MULT8,LKUPSM,ISYMTR,NSYM)
      IF (NEXT .LT. 1) GO TO 800
C
      DO 720 IISM = 1,NSYM
         ISM = ISYMTR(IISM)
         DO 710 J = 1,NEXT
            K = IORBTP(ICODE,J)
            IF (ISM .NE. ISMTP(K)) GO TO 710
            IORB = IORB+1
            IOUT(K) = IORB
            IMCC = IMCC+1
            IVAL = IVAL+1
            IDOCC = IDOCC+1
            IACT = IACT+1
            NC = NC+1
            NLCS(IORB) = NELE
            ISYM(IORB) = ISMTP(K)
            JCODE(IORB) = ICODE
  710    CONTINUE
  720 CONTINUE
C
C     ----- -MC- CORE ORBITALS -----
C
  800 CONTINUE
      LEVFRM = IORB + 1
      ICODE = 12
      NMCC = NORBTP(ICODE)
      CALL RDRSYM(ICODE,NSYMTP,MULT8,LKUPSM,ISYMTR,NSYM)
      IF(NMCC.LT.1) GO TO 900
C
C     THE FOCAS AND SOSCF MCSCF METHODS TREAT CORES VIA FOCK MATRICES.
C
      IF(ICICI.EQ.0  .AND.  DROPC) THEN
         DO 805 J=1,NMCC
            K=IORBTP(ICODE,J)
            IOUT(K)=-1
  805    CONTINUE
         NELECT=NELECT+2*NMCC
         MA=MA+NMCC
         MB=MB+NMCC
      ELSE
C
         DO 820 IISM = 1,NSYM
            ISM = ISYMTR(IISM)
            DO 810 J = 1,NMCC
               K = IORBTP(ICODE,J)
               IF (ISM .NE. ISMTP(K)) GO TO 810
               IORB = IORB+1
               IOUT(K) = IORB
               IVAL = IVAL+1
               IDOCC = IDOCC+1
               IACT = IACT+1
               NA = NA+1
               NLCS(IORB) = NELE
               NELE = NELE+2
               NELECT = NELECT+2
               MA = MA+1
               MB = MB+1
               ISYM(IORB) = ISMTP(K)
               JCODE(IORB) = ICODE
  810       CONTINUE
  820    CONTINUE
      END IF
C
C     ----- UNOCCUPIED VALENCE ORBITALS -----
C
  900 CONTINUE
      ICODE = 11
      NVAL = NORBTP(ICODE)
      CALL RDRSYM(ICODE,NSYMTP,MULT8,LKUPSM,ISYMTR,NSYM)
      IF (NVAL .LT. 1) GO TO 1000
C
      DO 920 IISM = 1,NSYM
         ISM = ISYMTR(IISM)
         DO 910 J = 1,NVAL
            K = IORBTP(ICODE,J)
            IF (ISM .NE. ISMTP(K)) GO TO 910
            IORB = IORB+1
            IOUT(K) = IORB
            IDOCC = IDOCC+1
            IACT = IACT+1
            NC = NC+1
            NLCS(IORB) = NELE
            ISYM(IORB) = ISMTP(K)
            JCODE(IORB) = ICODE
  910    CONTINUE
  920 CONTINUE
C
C     ----- DOUBLY OCCUPIED ORBITALS -----
C
 1000 CONTINUE
      ICODE = 1
      NDOC = NORBTP(ICODE)
      CALL RDRSYM(ICODE,NSYMTP,MULT8,LKUPSM,ISYMTR,NSYM)
      IF (NDOC .LT. 1) GO TO 1100
C
      DO 1020 IISM = 1,NSYM
         IIISM = NSYM-IISM+1
         ISM = ISYMTR(IIISM)
         DO 1010 JJ = 1,NDOC
            J = NDOC-JJ+1
            K = IORBTP(ICODE,J)
            IF (ISM .NE. ISMTP(K)) GO TO 1010
            IORB = IORB+1
            IOUT(K) = IORB
            IACT = IACT+1
            NA = NA+1
            NLCS(IORB) = NELE
            NELE = NELE+2
            NELECT = NELECT+2
            MA = MA+1
            MB = MB+1
            ISYM(IORB) = ISMTP(K)
            JCODE(IORB) = ICODE
 1010    CONTINUE
 1020 CONTINUE
C
C     ----- FROZEN VIRTUAL ORBITALS -----
C
 1100 CONTINUE
      ICODE = 4
      NFZV = NORBTP(ICODE)
      IF (NFZV .LT. 1) GO TO 1200
      DO 1110 J = 1,NFZV
         K = IORBTP(ICODE,J)
         IOUT(K) = 0
 1110 CONTINUE
C
C     ----- VALENCE ORBITALS -ALP-, -AOS-, -BOS-, -GVA-, -GVB- -----
C
 1200 CONTINUE
      ISPIN=0
      DO 1290 ICODE = 5,9
         IJMP = ICODE-4
         NTP = NORBTP(ICODE)
         CALL RDRSYM(ICODE,NSYMTP,MULT8,LKUPSM,ISYMTR,NSYM)
         IF (NTP .LT. 1) GO TO 1290
         DO 1280 IISM = 1,NSYM
            IIISM = NSYM-IISM+1
            ISM = ISYMTR(IIISM)
            DO 1270 JJ = 1,NTP
               J = NTP-JJ+1
               K = IORBTP(ICODE,J)
               IF (ISM .NE. ISMTP(K)) GO TO 1270
               IORB = IORB+1
               IOUT(K) = IORB
               NLCS(IORB) = NELE
               ISYM(IORB) = ISMTP(K)
               JCODE(IORB) = ICODE
               GO TO (1210,1220,1230,1240,1250), IJMP
C                                    ALP
 1210          CONTINUE
               NB = NB+1
               NELE = NELE+1
               NELECT = NELECT+1
               MA = MA+1
               LKUP = MULT8(MSYM) + ISYM(IORB)
               MSYM = LKUPSM(LKUP)
               ISPIN = ISPIN+1
               GO TO 1270
C                                    AOS
 1220          CONTINUE
               NC = NC+1
               IF (J .NE. NTP) GO TO 1270
               LKUP = MULT8(MSYM) + ISYM(IORB)
               MSYM = LKUPSM(LKUP)
               GO TO 1270
C                                    BOS
 1230          CONTINUE
               NELE = NELE+2
               NELECT = NELECT+2
               MA = MA+1
               MB = MB+1
               NA = NA+1
               LKUP = MULT8(MSYM) + ISYM(IORB)
               MSYM = LKUPSM(LKUP)
               GO TO 1270
C                                    GVA
 1240          CONTINUE
               NELE = NELE+1
               NELECT = NELECT+1
               MA = MA+1
               MB = MB+1
               NC = NC+1
               GO TO 1270
C                                    GVB
 1250          CONTINUE
               NELE = NELE+1
               NELECT = NELECT+1
               MA = MA+1
               MB = MB+1
               NA = NA+1
 1270       CONTINUE
 1280    CONTINUE
 1290 CONTINUE
C
      IF (IORB .NE. NA+NB+NC) THEN
         IF (MASWRK) WRITE (IW,9110) IORB,NA,NB,NC
         CALL ABRT
         STOP
      END IF
      IDOCC = IDOCC + IACT * MXAO
      NLEVS = NA+NB+NC+1
C
C     ----- PRINT CHARGE AND ELECTRONIC STATE -----
C
      ICHARG = (NE+ICH)-NELECT
      MULTIP = ISPIN+1
      IF (SOME) WRITE (IW,9120) ICHARG,MA,MB
C
      IF(IRRCI.NE.0) MSYM=IRRCI
C
C     THE NONABELIAN GROUPS MAY HAVE MORE THAN ONE IRREP MAPPING
C     ONTO THE IRREP -MSYM- IN THE ABELIAN SUBGROUP BEING USED.
C
      MATCH=0
      SPACE=0
      IF (MASWRK) WRITE(IW,9125)
      DO 1310 I=1,NIRRP
         IF(ISYMRP(I,IGRP).EQ.MSYM) THEN
            MATCH = MATCH+1
            SPACE = SYMREP(I,IGRP)
            IF(SOME) WRITE(IW,9130) MULTIP,SPACE
         END IF
 1310 CONTINUE
      IF(SOME  .AND.  MATCH.GT.1) WRITE (IW,9140)
C
      IF(RUNTYP.EQ.TRANST) THEN
         MUL = MULTIP
         ICH = ICHARG
      ELSE
         IF(MUL.NE.MULTIP  .OR.  ICH.NE.ICHARG) THEN
            IF (MASWRK) WRITE(IW,9160) ICH,MUL,ICHARG,MULTIP
            CALL ABRT
            STOP
         END IF
      END IF
      RETURN
C
 9000 FORMAT(1X,'CONFUSION IN -ORDORB-, WHY IS DRTINP=',A8,'?')
 9010 FORMAT(1X,'THIS -CI- OR -MCSCF- RUN REQUIRES A FREE FORMAT $',
     *       A8,' INPUT GROUP.')
 9020 FORMAT(/5X,' GROUP=',A8,3X,'  NPRT=',I8/
     *        5X,'  FORS=',L8,3X,'INTACT=',L8/
     *        5X,'  FOCI=',L8,3X,'MXNINT=',I8/
     *        5X,'  SOCI=',L8,3X,'MXNEME=',I8/
     *        5X,'IEXCIT=',I8//
     *        5X,1X,'-CORE-',4X,'-INTERNAL-',2X,'-EXTERNAL-'/
     *        5X,'NFZC=',I4,3X,'NDOC=',I4,3X,'NEXT=',I4/
     *        5X,'NMCC=',I4,3X,'NAOS=',I4,3X,'NFZV=',I4/
     *        5X,          12X,'NBOS=',I4/
     *        5X,          12X,'NALP=',I4/
     *        5X,          12X,'NVAL=',I4)
 9030 FORMAT(1X,'POINT GROUP=',A8,' IS UNKNOWN TO THE DRT CODE.')
 9040 FORMAT(/1X,'THE MAXIMUM ELECTRON EXCITATION WILL BE',I4)
 9050 FORMAT(1X,'MO=',I5,' HAS ILLEGAL SYMMETRY LABEL ',A4)
 9055 FORMAT(1X,'MO=',I5,' HAS A SYMMETRY LABEL ',A4,
     *          ' UNKNOWN IN GROUP ',A8)
 9060 FORMAT(/1X,'SYMMETRIES FOR THE',I4,' CORE,',I4,' ACTIVE,',
     *       I4,' EXTERNAL MO-S ARE')
 9070 FORMAT(1X,'    CORE=',10(1X,A4,1X)/(10X,10(1X,A4,1X)))
 9080 FORMAT(1X,'  ACTIVE=',10(1X,A4,1X))
 9090 FORMAT(10X           ,10(1X,A4,1X))
 9100 FORMAT(1X,'EXTERNAL=',10(1X,A4,1X)/(10X,10(1X,A4,1X)))
 9110 FORMAT(1X,'FATAL ERROR IN DRT CODE...ORBITALS DONT MATCH'/
     *       1X,'NORB=',I6,' NA,NB,NC=',3I6)
 9120 FORMAT(/1X,'MOLECULAR CHARGE          =',I5/
     *        1X,'NUMBER OF ALPHA ELECTRONS =',I5/
     *        1X,'NUMBER OF  BETA ELECTRONS =',I5)
 9125 FORMAT(1X)
 9130 FORMAT(1X,'THE ELECTRONIC STATE IS',I3,'-',A4)
 9140 FORMAT(/1X,'UNABLE TO MAKE AN UNAMBIGUOUS DETERMINATION OF THE '/
     *        1X,'SPATIAL SYMMETRY IN THIS NONABELIAN GROUP.')
 9160 FORMAT(/1X,'*** ERROR *** INCONSISTENT CHARGE/MULTIPLICITY'/
     *        1X,'$CONTRL GAVE ICHARG=',I4,' MULT=',I4/
     *        1X,'$DRT IMPLIES ICHARG=',I4,' MULT=',I4)
 9170 FORMAT(//1X,'CI GRADIENT REQUIRES ALL ORBITALS TO BE OCCUPIED.'/
     *       1X,'YOUR DRT INPUT HAS',I5,' OCCUPIED, OUT OF',I5,' MO-S.'/
     *       1X,'NFZC=',I5,' NDOC=',I5,' NAOS=',I5,' NBOS=',I5,
     *       1X,'NALP=',I5,' NVAL=',I5)
 9180 FORMAT(//1X,'CI GRADIENT REQUIRES USE OF -IEXCIT- AND -NVAL-'/
     *       1X,'        RATHER THAN -FOCI- OR -SOCI- AND -NEXT-'/
     *       1X,'IEXCIT=',I2,' FOCI=',L2,' SOCI=',L2/
     *       1X,'NFZC=',I5,' NDOC=',I5,' NAOS=',I5,' NBOS=',I5/
     *       1X,'NALP=',I5,' NVAL=',I5,' NEXT=',I5)
 9200 FORMAT (/1X,'THE FOLLOWING ANALYSIS IS BASED UPON THE',
     *            ' $DATA POINT GROUP:')
 9210 FORMAT (/1X,'THE FOLLOWING ANALYSIS IS BASED UPON THE',
     *            ' $DRT POINT GROUP:')
      END
C*MODULE GUGDRT  *DECK PALDUS
      SUBROUTINE PALDUS(NROWS,NWKS,NABCA,NABCB,NABCS,NABCT,IARC,
     *                  NLWKS,NROWS4)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION NABCA(NROWS),NABCB(NROWS),NABCS(NROWS),NABCT(NROWS),
     *          IARC(NROWS4),NLWKS(NROWS)
      DIMENSION MULT8(8),LKUPSM(64),ISHIFT(4),IRED(500)
C
      PARAMETER (MXATM=2000, MXAO=8192)
C
      COMMON /INFOA / NAT,ICH,MULT,NUM,NQMT,NE,MA,MB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON /ORBSET/ NORBMX,NORBS,NCORBS,NLEVS,NA,NB,NC,NSYM,MSYM,
     *                IDOCC,IVAL,IMCC,ISYM(MXAO),ICODE(MXAO),
     *                NLCS(MXAO),LEVPT(MXAO),LEVNR(MXAO),
     *                IOUT(MXAO),NREFS,IEXCT,NFOCI,INTACT
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      DATA MULT8/0,8,16,24,32,40,48,56/
      DATA LKUPSM/1,2,3,4,5,6,7,8,2,1,4,3,6,5,8,7,3,4,1,2,7,8,5,6,4,3,
     + 2,1,8,7,6,5,5,6,7,8,1,2,3,4,6,5,8,7,2,1,4,3,7,8,5,6,3,4,1,2,
     + 8,7,6,5,4,3,2,1/
C
C     ----- INITIALIZE THE ARRAYS -----
C
      NECOR = (IVAL-IMCC)*2
      IACT = IDOCC / MXAO
      IDOCC = IDOCC - IACT * MXAO
      NBMAX = NB+IEXCT+2
      MAXNB = 16+MULT-1
      IF(NBMAX.GT.MAXNB) THEN
         IF(MASWRK) WRITE(IW,*) 'NBMAX CANNOT EXCEED',MAXNB
         IF(MASWRK) WRITE(IW,*) 'NB,IEXCT,NBMAX=',NB,IEXCT,NBMAX
         IF(MASWRK) WRITE(IW,*) 'ACTIVE SPACE IS PROBABLY TOO LARGE'
         CALL ABRT
      END IF
      IF(NB.GT.14) THEN
         IF(MASWRK) WRITE(IW,*) 'NB CANNOT EXCEED 14, NB=',NB
         IF(MASWRK) WRITE(IW,*) 'ACTIVE SPACE IS PROBABLY TOO LARGE'
         CALL ABRT
      END IF
      DO 100 K = 1,4
      ISHIFT(K) = (K-1)*NROWS
  100 CONTINUE
      DO 120 I = 1,NROWS
      NLWKS(I) = 0
      NABCA(I) = 0
      NABCB(I) = 0
      NABCS(I) = 0
      NABCT(I) = 0
      DO 120 K = 1,4
      IARPT = I+ISHIFT(K)
      IARC(IARPT) = 0
  120 CONTINUE
C
C     ----- GENERATE THE PALDUS ARRAY (NABC) -----
C
      LEVM = NLEVS
      LEVPT(LEVM) = 0
      LEVNR(LEVM) = 1
      NABCA(1) = NA
      NABCB(1) = NB
      NABCS(1) = MSYM
  140 LEV = LEVM
      LEVM = LEV-1
      IF (LEVM .EQ. 0) GO TO 580
      NR = LEVNR(LEV)
      NPT = LEVPT(LEV)
      LEVPT(LEVM) = NPT+NR
      NRM = 0
      ICD = ICODE(LEVM)
      IBM = NBMAX + 1
      IAM = NA + 1
      DO 560 IAS = 1,IAM
      IA = NA - IAS + 1
      DO 560 IBS = 1,IBM
      IB = NBMAX - IBS + 1
      NPT = LEVPT(LEV)
      DO 540 I = 1,NR
      NPT = NPT+1
      DO 540 K = 1,4
C
C     ----- -MC- CORE ORBITALS MUST BE CLOSED. CASE NUMBER 4 ONLY -----
C
      IF (LEVM .LT. IVAL+1 .AND. LEVM .GE. IMCC+1 .AND. K .NE. 4) GO TO
     +     540
C
      IABCA = NABCA(NPT)
      IABCB = NABCB(NPT)
      IABCS = NABCS(NPT)
      IABCT = NABCT(NPT)
      GO TO (160,180,200,220),K
  160 IABCC = LEVM - IABCA - IABCB
      IF (IABCC .LT. 0) GO TO 540
      IF (IA .NE. IABCA) GO TO 540
      IF (IB .NE. IABCB) GO TO 540
      GO TO 260
  180 IABCB = IABCB - 1
      IF (IABCB .LT. 0) GO TO 540
      IF (IA .NE. IABCA) GO TO 540
      IF (IB .NE. IABCB) GO TO 540
      GO TO 240
  200 IABCA = IABCA - 1
      IABCB = IABCB + 1
      IABCC = LEVM - IABCA - IABCB
      IF ((IABCA .LT. 0) .OR. (IABCC .LT. 0) .OR. (IABCB .GT. NBMAX))
     +     GO TO 540
      IF (IA .NE. IABCA) GO TO 540
      IF (IB .NE. IABCB) GO TO 540
      GO TO 240
  220 IABCA = IABCA - 1
      IF (IABCA .LT. 0) GO TO 540
      IF (IA .NE. IABCA) GO TO 540
      IF (IB .NE. IABCB) GO TO 540
      GO TO 260
  240 LKUP = MULT8(IABCS) + ISYM(LEVM)
      IABCS = LKUPSM(LKUP)
  260 NELE = IB + IA + IA
      IFUT = 0
      IT = IABCT
      IF (IT .GE. 8) GO TO 280
      IFUT = IT
      GO TO 300
  280 IT = IT - 10
      IFUT = IT + 1
  300 CONTINUE
      IPAST = IT
C
C     ----- FIRST-, SECOND-ORDER OR POL-CI -----
C
      IF (NFOCI .EQ. 0 .AND. (NELE-NLCS(LEVM)) .GT. (IEXCT-IT)) GO TO
     +     540
      IF (NFOCI .NE. 0 .AND. LEVM .EQ. (IVAL+1) .AND. NELE .GT. (NECOR+
     +     NFOCI)) GO TO 540
C
C     ----- INTERACTING SPACE OPTION -----
C
      IF (INTACT .EQ. 0) GO TO 480
      GO TO (480,480,480,480,320,380,440,360,340,480,480,480),ICD
  320 CONTINUE
C
C     ----- ALPHA ORBITAL UNCOUPLED -----
C
      IF (K .GT. 2) IT = IT+1
      GO TO 460
  340 CONTINUE
C
C     ----- FIRST OF GVB PAIR -----
C
      IF (K .EQ. 4) IT = IT+1
      IF (K .GT. 1) IT = IT+1
      GO TO 460
  360 CONTINUE
C
C     ----- SECOND OF GVB PAIR -----
C
      IF (K .EQ. 1) IT = IT-1
      IF (K .LT. 4) IT = IT-1
      IF (IB .EQ. 2 .AND. K .EQ. 3) IT = IT+1
      IFUT = 0
      IF ((IB .EQ. 0) .AND. (K .EQ. 2) .AND. (NREFS .LE. 2)) IT = IT + 1
      IF (IT .LT. 0) IT = 0
      GO TO 460
  380 CONTINUE
C
C     ----- ALPHA ORBITAL TO BE SINGLET COUPLED -----
C
      IT = IFUT
      IF (K .LT. 4) GO TO 400
      IPAST = IPAST+1
      IT = IT+1
      IFUT = IFUT+1
  400 IF (K .LE. 1) GO TO 420
      IPAST = IPAST+1
      IFUT = IFUT+1
  420 CONTINUE
      IF (K .EQ. 3 .AND. (IB-1-IT) .GT. NB) IT = IT+1
      IF (IPAST .LT. IT) IT = IPAST
      GO TO 460
  440 CONTINUE
C
C     ----- SINGLET COUPLED BETA ORBITAL -----
C
      IF (K .EQ. 4) IT = IT+1
      IF (K .EQ. 2) IT = IT+1
      IFUT = IT
  460 CONTINUE
      IF (IT .GT. IEXCT) GO TO 540
      IABCT = IT
      IFUT = IFUT-IT
      IF (IFUT .LT. 0) IFUT = 0
      IF (IFUT .GT. 1) THEN
           IF(MASWRK)WRITE(IW,*)' ERROR IN PALDUS'
           CALL ABRT
      END IF
      IF ((IFUT .EQ. 1) .AND. (IABCT .LT. 8)) IABCT = IABCT + 10
  480 CONTINUE
      IF (LEVM .EQ. (IDOCC + 1) .AND. (IABCT .LT. 8)) IABCT = 0
      IF (LEVM .EQ. (IDOCC + 1) .AND. (IABCT .GE. 8)) IABCT = 10
      IF (LEVM .EQ. (IACT+1) .AND. (IABCT .GE. 8)) IABCT = IABCT - 10
      NPTM = LEVPT(LEVM)
      DO 500 KRM = 1,NRM
      NPTM = NPTM+1
      IF ((IABCA .EQ. NABCA(NPTM)) .AND. (IABCB .EQ. NABCB(NPTM)) .AND.
     +     (IABCS .EQ. NABCS(NPTM)) .AND. (IABCT .EQ. NABCT(NPTM))) GO
     +     TO 520
  500 CONTINUE
      NRM = NRM+1
      IF (NRM .GT. 500) GO TO 780
      NPTM = NRM+LEVPT(LEVM)
      IF (NPTM .GT. NROWS) GO TO 800
      NABCA(NPTM) = IABCA
      NABCB(NPTM) = IABCB
      NABCS(NPTM) = IABCS
      NABCT(NPTM) = IABCT
      IF (IABCT .GE. 8) NABCT(NPTM) = IABCT - 1
      KRM = NRM
  520 CONTINUE
      IARPT = NPT+ISHIFT(K)
      IF (IARC(IARPT) .NE. 0) GO TO 880
      IARC(IARPT) = KRM
  540 CONTINUE
  560 CONTINUE
      LEVNR(LEVM) = NRM
      GO TO 140
  580 CONTINUE
C
C     ----- SET WEIGHT OF ARRAY BOTTOM TO UNITY
C           LET ALL OTHER BOTTOMS EQUAL ZERO    -----
C
      ITEST = 0
      NPT = LEVPT(1)
      NR = LEVNR(1)
      NROWS = NR+NPT
      DO 600 I = 1,NR
      NPT = NPT+1
      IF ((NABCA(NPT) .NE. 0) .OR. (NABCB(NPT) .NE. 0) .OR. (NABCS(NPT)
     +     .NE. 1) .OR. (NABCT(NPT) .NE. 0)) GO TO 600
      IF (ITEST .NE. 0) GO TO 820
      ITEST = 1
      NLWKS(NPT) = 1
  600 CONTINUE
      IF (ITEST .EQ. 0) GO TO 840
C
C     ----- GENERATE WEIGTHS OF EACH ROW (NLWKS)
C           REMOVE ALL ROWS WITH ZERO WEIGHT     -----
C
      DO 700 LEV = 2,NLEVS
         LEVM = LEV-1
         NRM = LEVNR(LEVM)
         NPTM = LEVPT(LEVM)
         NRMX = 0
         DO 640 I = 1,NRM
            NPTM = NPTM+1
            IRED(I) = 0
            IF (NLWKS(NPTM) .EQ. 0) GO TO 640
               NRMX = NRMX+1
               IRED(I) = NRMX
               NPTX = NRMX+LEVPT(LEVM)
               NLWKS(NPTX) = NLWKS(NPTM)
               NABCA(NPTX) = NABCA(NPTM)
               NABCB(NPTX) = NABCB(NPTM)
               NABCS(NPTX) = NABCS(NPTM)
               NABCT(NPTX) = NABCT(NPTM)
               IARC(NPTX+ISHIFT(1)) = IARC(NPTM+ISHIFT(1))
               IARC(NPTX+ISHIFT(2)) = IARC(NPTM+ISHIFT(2))
               IARC(NPTX+ISHIFT(3)) = IARC(NPTM+ISHIFT(3))
               IARC(NPTX+ISHIFT(4)) = IARC(NPTM+ISHIFT(4))
  640    CONTINUE
         LEVNR(LEVM) = NRMX
         NPT = LEVPT(LEV)
         NR = LEVNR(LEV)
         NPTM = LEVPT(LEVM)
         DO 680 I = 1,NR
            NPT = NPT+1
            DO 660 K = 1,4
               IARPT = NPT+ISHIFT(K)
               J = IARC(IARPT)
               IF (J .EQ. 0) GO TO 660
                  J = IRED(J)
                  IARC(IARPT) = J
                  IF (J .EQ. 0) GO TO 660
                     IPTM = J+NPTM
                     NLWKS(NPT) = NLWKS(NPT)+NLWKS(IPTM)
  660       CONTINUE
  680    CONTINUE
  700 CONTINUE
C
C     ----- CONTRACT THE PALDUS AND WEIGHT ARRAYS -----
C
      IPT = 0
      DO 760 LEV = NLEVS, 1, -1
         NR = LEVNR(LEV)
         NPT = LEVPT(LEV)
         LEVPT(LEV) = IPT
C            NO DEPENDENCY IN THIS LOOP; SAFE TO VECTORIZE
         DO 740 I = 1,NR
            IPT = IPT+1
            NPT = NPT+1
            NABCA(IPT) = NABCA(NPT)
            NABCB(IPT) = NABCB(NPT)
            NABCS(IPT) = NABCS(NPT)
            NABCT(IPT) = NABCT(NPT)
            NLWKS(IPT) = NLWKS(NPT)
            IARC(IPT+ISHIFT(1)) = IARC(NPT+ISHIFT(1))
            IARC(IPT+ISHIFT(2)) = IARC(NPT+ISHIFT(2))
            IARC(IPT+ISHIFT(3)) = IARC(NPT+ISHIFT(3))
            IARC(IPT+ISHIFT(4)) = IARC(NPT+ISHIFT(4))
  740    CONTINUE
  760 CONTINUE
      NROWS = IPT
      NWKS = NLWKS(1)
      RETURN
C
  780 CONTINUE
      IF (MASWRK) WRITE (IW,9008) LEVM
      CALL ABRT
      STOP
C
  800 CONTINUE
      IF (MASWRK) WRITE (IW,9028) NROWS
      CALL ABRT
      STOP
C
  820 CONTINUE
      IF (MASWRK) WRITE (IW,9048)
      CALL ABRT
      STOP
C
  840 CONTINUE
      IF (MASWRK) WRITE (IW,9068) NR
      NPT = LEVPT(1)
      DO 860 I = 1,NR
         NPT = NPT+1
         IF (MASWRK) WRITE (IW,9088)
     *      NABCA(NPT),NABCB(NPT),NABCS(NPT),NABCT(NPT)
  860 CONTINUE
C
  880 CONTINUE
      IF(MASWRK) WRITE(IW,9200)
      CALL ABRT
      STOP
C
 9008 FORMAT(24H  TOO MANY ROWS AT LEVEL,I5,' (MAX IS 500)')
 9028 FORMAT(28H  TOO MANY ROWS.  MAXIMUM IS,I8)
 9048 FORMAT(23H  DUPLICATE GRAPH TAILS)
 9068 FORMAT(27H  NO VALID TAIL.  LEVNR(1)=,I5)
 9088 FORMAT(3X,7H NABC =/1H ,4I15)
 9200 FORMAT(1X,'-PALDUS- HAS DECIDED TO GO TO 880'/
     *       1X,'THIS MAY MEAN IT IS IMPOSSIBLE TO MAKE CONFIGURATIONS'/
     *       1X,'OF THE DESIRED TOTAL SYMMETRY FROM THE SYMMETRY OF'/
     *       1X,'YOUR ACTIVE ORBITALS')
      END
C
C*MODULE GUGDRT  *DECK PRINTCSF
      SUBROUTINE PRINTCSF(ISHIFT,IARC,MXSPIN,PK,IPRIM,CGCOEF,IPRMSM,
     *                    CGCSM,BK,NTRAP,IICAS,MS,NPFLG,NOCCUP,IBUFII,
     *                    MAXIBF,IRRCSF,RUNPB,RUNTRM,NONABEL,OUT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MXAO=8192,MAXCP=4096)
      LOGICAL GOPARR,DSKWRK,MASWRK,RUNPB,RUNTRM,NONABEL,OUT
C
      COMMON /FMCOM / X(1)
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON /ORBSET/ NORBMX,NORBS,NCORBS,NLEVS,NA,NB,NC,NSYM,MSYM,
     *                IDOCC,IVAL,IMCC,ISYM(MXAO),ICODE(MXAO),
     *                NLCS(MXAO),LEVPT(MXAO),LEVNR(MXAO),
     *                IOUT(MXAO),NREFS,IEXCT,NFOCI,INTACT
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /SOGUG/  CP(MAXCP),NUNIQ,LIOBP,ISODAF,NSODA,LSTREC,JSODAF,
     *                JSODA,NRECJ
      COMMON /WFNOPT/ SCFTYP,CITYP,DFTYPE,CCTYP,MPLEVL,MPCTYP
C
      DIMENSION PK(MXSPIN,*),IPRIM(MXSPIN,*),CGCOEF(*),IPRMSM(MXSPIN,*),
     *          CGCSM(*),ISHIFT(4),IARC(*),ICASE(MXAO),IECONF(MXAO),
     *          IORDER(MXAO),LEVIR(MXAO),NOCCUP(*),IBUFII(*),
     *          IRRCSF(*),BK(MXSPIN),IICAS(MXSPIN),NTRAP(MXSPIN)
      DATA GUGA,RMC/8HGUGA    ,8HMCSCF   /
C
C    THIS VERSION IS MODIFIED BY SHIRO KOSEKI
C    IN ORDER TO INTERFACE WITH TOM FURLANI'S CODE.
C    --- SEP. 17, 1997 ---
C
      IF((NPFLG.EQ.1).AND. MASWRK) WRITE (IW,9148)
      IF((NPFLG.GT.1).AND. MASWRK) WRITE (IW,9158)
      NPART = 0
      IF(CITYP.EQ.GUGA)  NPART=NORBS
      IF(SCFTYP.EQ.RMC) NPART=NORBS-NCORBS
C
      DO 770 I=1,NORBS
         DO 765 J=1,NORBMX
            IF(IOUT(J).EQ.I) IORDER(I)=J
  765    CONTINUE
  770 CONTINUE
C
      IWKS = 0
      LEV = 1
      LEVM = 1
      IR0 = 1
  780 CONTINUE
      IF (LEV .EQ. NLEVS) GO TO 860
      LEVIR(LEV) = IR0
      LEVM = LEV
      LEV = LEVM+1
      LEVIR(LEV) = LEVNR(LEV)+1
  800 CONTINUE
      IR0 = LEVIR(LEV)
      NPTX = LEVPT(LEV)
      NPTM = LEVPT(LEVM)
      IRM = LEVIR(LEVM)
  820 CONTINUE
      IR0 = IR0-1
      IF (IR0 .EQ. 0) GO TO 1000
      NPT = IR0+NPTX
      DO 840 K = 1,4
      IARPT = NPT+ISHIFT(K)
      JARC = IARC(IARPT)
      IF (JARC .EQ. 0) GO TO 840
      JARC = JARC-NPTM
      ICASE(LEVM) = K
      IF (IRM .EQ. JARC) GO TO 780
  840 CONTINUE
      GO TO 820
C
  860 CONTINUE
C
      DO 980 ILEV = 1,NORBS
      ICAS = ICASE(ILEV)
      GO TO (880,900,900,920), ICAS
  880 IOCC = 0
      GO TO 940
C
  900 IOCC = 1
      GO TO 940
C
  920 IOCC = 2
  940 CONTINUE
      IORB=-2**20
      DO 960 I = 1,NORBMX
      IF (IOUT(I) .EQ. ILEV) IORB = I
  960 CONTINUE
      IECONF(IORB) = IOCC
  980 CONTINUE
C
      IWKS = IWKS+1
      IF (OUT) WRITE (IW,9168) IWKS,(ICASE(ILEV),ILEV = 1,NORBS)
      IF ((NPFLG.EQ.1) .AND. MASWRK)
     *   WRITE(IW,9188) IWKS,(IECONF(NCORBS+IORB),IORB=1,NPART)
C     WRITE(IW,*) 'NORBSS',NORBS
      IF (NPFLG.GE.2.OR.RUNTRM)
     *   CALL PRTCSF(IWKS,NORBS,ICASE,IORDER,MXSPIN,PK,IPRIM,CGCOEF,
     *               IPRMSM,CGCSM,BK,NTRAP,IICAS,NPFLG,NCORBS,NOCCUP,
     *               IBUFII,X(LIOBP),MAXIBF,IRRCSF,MS,RUNPB,RUNTRM,
     *               NONABEL,OUT)
 1000 CONTINUE
      LEV = LEVM
      LEVM = LEV -1
      IF (LEVM .GT. 0) GO TO 800
      RETURN
C
 9148 FORMAT(/10X,'ORBITAL OCCUPANCIES (IGNORING CORE)'/
     *        10X,35(1H-))
 9158 FORMAT(
     *      //10X,'DETERMINANT CONTRIBUTION TO CSF''S (BETA IS MINUS)',
     *       /10X,49(1H-))
 9168 FORMAT(15H CASE VECTOR = ,I7,/(1X,128I1/))
 9188 FORMAT(I7,1X,124I1,/,8X,124I1)
      END
C*MODULE GUGDRT  *DECK PRTCSF
      SUBROUTINE PRTCSF(NCSF,NORB,ICASE,IORDER,MXSPIN,PK,IPRIM,CGCOEF,
     *   IPRMSM,CGCSM,BK,NTRAP,IICAS,NPFLG,NCORBS,NOCCUP,
     *  IBUFII,IOBP,MAXIBF,IRRCSF,MS,RUNPB,RUNTRM,NONABEL,OUT)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL RUNPB,RUNTRM,NONABEL,OUT,DEBUG,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (MXAO=8192,MXATM=2000,MXIRR=14)
      PARAMETER (ONE=1.0D+00)
C
      DIMENSION ICASE(MXAO),IORDER(MXAO),PK(MXSPIN,*),CGCOEF(*),
     *          IPRIM(MXSPIN,*),IPRMSM(MXSPIN,*),CGCSM(*),ICSF(MXAO),
     *          IICAS(MXSPIN),N1234(4),NOCCUP(*),IBUFII(*),IOBP(2,*),
     *          IOCC(2,MXAO),NTRAP(MXSPIN),IRRCSF(*),BK(MXSPIN)
C
      COMMON /INFOA / NAT,ICH,MULT,NUM,NQMT,NE,MA,MB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /SYMREP/ IRPNAM(MXIRR),IPA(MXIRR),LAMBDA(MXIRR),
     *                LAMBD0(MXIRR),IADDR1(MXIRR),IADDR2(MXIRR),
     *                IADDR3(MXIRR)
      COMMON /TRNMOM/ OPERR,SYMTOL,NOCC,NUMCI,NFZC,NUMVEC,ICI,MXRT,NSTAT
C
      DATA N1234/ 0, 1, -1, 0 /,IQUEST/4H????/,DEBUGG/8HDEBUG   /,
     *     DBGME/8HSALC    /
C
C     ----- PRINT OUT DETERMINANTS FORMING EACH CSF -----
C
      DEBUG=(EXETYP.EQ.DEBUGG.OR.EXETYP.EQ.DBGME).AND.MASWRK
      NOPEN=0
      IB = 0
      NPHASE = 1
      DO 100 I=1,NORB
         IB = IB + N1234(ICASE(I))
         GO TO (100,102,102,104), ICASE(I)
C
  102    CONTINUE
         NOPEN=NOPEN+1
         IICAS(NOPEN)=ICASE(I)
         GO TO 100
C
  104    CONTINUE
         ICHK = IB/2
         ICHK = IB - 2*ICHK
         IF(ICHK.EQ.1) NPHASE =-NPHASE
  100 CONTINUE
C
      NSORB = 0
C
C     GENERATE THE SPIN FUNCTION FOR NOPEN UNPAIRED ELECTRONS
C
      CALL SPNFNC(NOPEN,MULT,IICAS,MXSPIN,IPRIM,CGCOEF,NPRIM,PK,NTRAP,
     *            BK)
      IF(MS.EQ.1) THEN
         CALL SMINUS(IW,NOPEN,IPRIM,CGCOEF,NPRIM,IPRMSM,CGCSM,NPRMSM,
     *               NTRAP,MXSPIN,2**MXSPIN,OUT)
         IF(NPHASE.LT.0) CALL DSCAL(NPRMSM,-ONE,CGCSM,1)
      END IF
      IF(NPHASE.LT.0) CALL DSCAL(NPRIM,-ONE,CGCOEF,1)
C
C     PRINT OUT THE DETERMINANT(S)
C
      IF(NPRIM.GE.2**MXSPIN) THEN
         IF(OUT) WRITE(IW,9020)
         CALL ABRT
      END IF
      IF(OUT) WRITE(IW,9030) MS
      IF(MS.EQ.0) THEN
         DO 200 IPR=1,NPRIM
            CALL MAKDET(NORB,ICASE,IPRIM(1,IPR),IORDER,ICSF,NSORB)
            IF(RUNPB) CALL CSFDET(NSORB,ICSF,NORB,IOCC,NPHASE,NCORBS,
     *      IPR,CGCOEF,NCSF,NPRIM,ISCHEM,IBUFII,IOBP(1,ICI),MAXIBF,OUT)
            IF(OUT) THEN
               IF(IPR.EQ.1) THEN
                 WRITE(IW,9000) NCSF,IPR,CGCOEF(IPR),(ICSF(I),I=1,NSORB)
               ELSE
                 WRITE(IW,9010)      IPR,CGCOEF(IPR),(ICSF(I),I=1,NSORB)
               END IF
            END IF
            IF(RUNTRM) THEN
C
C              DETERMINE SPACE SYMMETRY FOR MS=S
C
               IF(IPR.EQ.1.AND..NOT.NONABEL) THEN
C              THIS ASSUMES THAT ALL DETS IN A CSF BELONG TO THE SAME G
C              THIS IS ALWAYS TRUE BECAUSE ALL DETERMINANTS IN A CSF
C              AT PRESENT WITH THE ABELIAN-RESTRICTED GUGA HAVE THE SAME
C              ORBITAL PART, FIXING THE IRREP.
                  IRREP=IRRDET(ICSF,NSORB)
                  IRRCSF(NCSF)=IRREP
                  IF(IRREP.EQ.0) THEN
                     IF(DEBUG) WRITE(IW,9999) NCSF,IQUEST
                  ELSE
                     IF(DEBUG) WRITE(IW,9999) NCSF,IRPNAM(IRREP)
                  END IF
               END IF
            END IF
  200    CONTINUE
         IF(RUNPB) NOCCUP(NCSF)=ISCHEM
         RETURN
      END IF
      IF(.NOT.RUNPB.AND.NPFLG.LT.3) RETURN
C
C     PRINT OUT DETERMINANTS WITH S-MINUS APPLIED TO THE SPIN PART.
C
C     SINCE CSFDET CHANGES CGCSM, HAVE TO CALL SMINUS NOW
C     IF(MS.EQ.2) CALL SMINUS(IW,NOPEN,IPRMSM,CGCSM,NPRMSM,IPRIM,CGCOEF,
C    *                        NTRAP,MXSPIN,2**MXSPIN,NPRIM,OUT)
      IF(MS.EQ.1) THEN
         DO 300 IPR=1,NPRMSM
            CALL MAKDET(NORB,ICASE,IPRMSM(1,IPR),IORDER,ICSF,NSORB)
            IF(RUNPB) CALL CSFDET(NSORB,ICSF,NORB,IOCC,NPHASE,NCORBS,
     *       IPR,CGCSM,NCSF,NPRMSM,ISCHE1,IBUFII,IOBP(2,ICI),MAXIBF,OUT)
            IF(NPFLG.GE.3.AND.OUT) THEN
               IF(IPR.EQ.1) THEN
                 WRITE(IW,9000) NCSF,IPR,CGCSM(IPR),(ICSF(I),I=1,NSORB)
               ELSE
                 WRITE(IW,9010)      IPR,CGCSM(IPR),(ICSF(I),I=1,NSORB)
               END IF
            END IF
  300    CONTINUE
         RETURN
      END IF
      RETURN
C
 9000 FORMAT(1X,'CSF',I7,': C(',I3,')=',F9.6,' :',2X,32I3/
     *       32X,32I3/32X,32I3/32X,32I3)
 9010 FORMAT(11X,        '  C(',I3,')=',F9.6,' :',2X,32I3/
     *       32X,32I3/32X,32I3/32X,32I3)
 9020 FORMAT(1X,'THE NUMBER OF SLATER DETS WILL NOT FIT INTO 12 BITS')
 9030 FORMAT(/1X,'FOR MS=S-',I1)
 9999 FORMAT(1X,'CSF ',I7,' BELONGS TO ',A4)
      END
C
C*MODULE GUGDRT  *DECK CSFDET
      SUBROUTINE CSFDET(NSORB,ICSF,NORB,IOCC,NPHASE,NCORBS,IPR,CGCOEF,
     *                  NCSF,NPRIM,ISCHEM,IBUFII,IOBP,MAXIBF,OUT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MXAO=8192,MASK1=1,MASK3=3)
      DIMENSION CGCOEF(*),ICSF(MXAO),IOCC(2,MXAO),IBUFII(*)
      LOGICAL OUT
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
C
C     ----- PRINT OUT DETERMINANTS FORMING EACH CSF -----
C
C        INTERFACE WITH FURLANI'S CODE.
      CALL CSFDETC(NSORB,ICSF,NORB,IOCC,NPHASE,NCORBS)
      IF(NPHASE.LT.0) CGCOEF(IPR)=-CGCOEF(IPR)
C
C        CREATE ORBITAL OCCUPATION SCHEME:
      IF(IPR.EQ.1) THEN
         ISCHEM= 0
         DO 240 I=1,NORB
            IF((IOCC(1,I).EQ.1).AND.(IOCC(2,I).EQ.1)) THEN
C              DOUBLY OCCUPIED ORBITALS.
               ISCHEM = LOGOR(ISCHEM,LOGSHF(MASK3,2*(NORB-I)))
C
            ELSE IF((IOCC(1,I).EQ.1).OR.(IOCC(2,I).EQ.1)) THEN
C                   SINGLY OCCUPIED ORBITALS.
                    ISCHEM = LOGOR(ISCHEM,LOGSHF(MASK1,2*(NORB-I)))
C
            END IF
  240    CONTINUE
C
         IF(OUT) WRITE(IW,9240) ISCHEM
         IOBP=IOBP+1
         IBUFII(IOBP)=LOGOR(LOGSHF(ISCHEM,12),NPRIM)
         IOBP=IOBP+1
         NEXTSC=IOBP+NPRIM
C        IBUFII(1) IS THE # OF CSFS FOR THE CURRENT SPIN STATE
         IF(NCSF.EQ.IBUFII(1)) NEXTSC=0
         IBUFII(IOBP)=NEXTSC
      END IF
C
C        CREATE BINARY DATA.
         IDET = 0
         DO 220 I=1,NORB
C           CREATE BETA SPIN PART OF SLATER DETERMINANT.
            IF(IOCC(2,I).EQ.1) THEN
               IDET = LOGOR(IDET,LOGSHF(MASK1,NORB-I))
               END IF
C
C           CREATE ALPHA SPIN PART OF SLATER DETERMINANT.
            IF(IOCC(1,I).EQ.1) THEN
               IDET = LOGOR(IDET,LOGSHF(MASK1,2*NORB-I))
               END IF
  220       CONTINUE
C
         IF(OUT) WRITE(IW,9222) IDET
C
C        GET LABEL OF CG COEFFICIENT.
        CALL KOADD(IRET,CGCOEF(IPR))
        LABEL = IRET
C        --------------------------
        IF(IOBP.GT.MAXIBF) THEN
           IF(OUT) WRITE(IW,*) 'IOBP EXCEEDS MXIBF',MAXIBF
           CALL ABRT
        END IF
        IOBP=IOBP+1
        IBUFII(IOBP)=LOGOR(LABEL,LOGSHF(IDET,12))
      RETURN
 9240 FORMAT(10X,'ISCHEME =',O22)
 9222 FORMAT(/13X,'IDET =',O22)
      END
C
C*MODULE GUGDRT  *DECK DETREOR
      SUBROUTINE DETREOR(NSORB,ICSF,NPHASE)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION ICSF(*)
C
      NPHASE=1
C
      DO 100 I=1,(NSORB-1)
         DO 100 J=1,(NSORB-1)
C
            IF((ICSF(J).GT.0).AND.(ICSF(J+1).GT.0)) THEN
CASE            +/+: (J) .LT. (J+1)
               IF(ICSF(J).LT.ICSF(J+1)) GO TO 100
               GO TO 102
               END IF
C
CASE        -/-: ABS(J) .LT. ABS(J+1)
CASE                (J) .GT. (J+1)
CASE        +/-:    (J) .GT. (J+1)
            IF(ICSF(J).GT.ICSF(J+1)) GO TO 100
C
C           NEED TO REORDER:
  102       CONTINUE
            NPHASE = -NPHASE
            ISAVE = ICSF(J)
            ICSF(J) = ICSF(J+1)
            ICSF(J+1) = ISAVE
C
  100       CONTINUE
      RETURN
      END
C*MODULE GUGDRT  *DECK CSFDETC
      SUBROUTINE CSFDETC(NSORB,ICSF,NORB,IOCC,NPHASE,NCORBS)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION ICSF(*), IOCC(2,*)
C
      CALL DETREOR(NSORB,ICSF,NPHASE)
C
      DO 120 I=1,NORB
         DO 120 J=1,2
         IOCC(J,I) = 0
  120    CONTINUE
C
      DO 140 I=1,NSORB
         I0 = ABS(ICSF(I)) -NCORBS
         IF(ICSF(I).LT.0) THEN
            IOCC(2,I0) = 1
            ELSE
            IOCC(1,I0) = 1
            END IF
  140    CONTINUE
      RETURN
      END
C
C*MODULE GUGDRT  *DECK RDDRT
      SUBROUTINE RDDRT(NORBMX,NORBS,NSYM,NROWS,NWKS,LEVFRM,NEMEMX,NREFS,
     *                 IEXCT,NFOCI,INTACT,NCORBS)
      COMMON /CIFILS/ NFT11,NFT12,NFT13,NFT14,NFT15,NFT16,IDAF20,NEMMX
C
C        READ DRT HEADER INFO (ON ALL NODES)
C
      READ (NFT11) NORBMX,NORBS,NSYM,NROWS,NWKS,LEVFRM,NEMEMX,NREFS,
     *             IEXCT,NFOCI,INTACT,NCORBS
      RETURN
      END
C*MODULE GUGDRT  *DECK RDRSYM
      SUBROUTINE RDRSYM(ICD,NSYMTP,MULT8,LKUPSM,NTR,NSYM)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION NSYMTP(12,8),MULT8(8),LKUPSM(64),NTR(8)
      DIMENSION NTP(8)
C
      DO 100 I = 1,NSYM
         NTP(I) = NSYMTP(ICD,I)
  100 CONTINUE
      NTR(1) = 1
      NTP(1) = 0
      DO 180 ITR = 2,NSYM
         IF (ITR .EQ. 4) GO TO 140
            IIN = 1
            IMAX = 0
            DO 120 I = 2,NSYM
               IF (NTP(I) .LT. IMAX) GO TO 120
                  IIN = I
                  IMAX = NTP(I)
  120       CONTINUE
            GO TO 160
C
  140    CONTINUE
         LKUPA = NTR(2)
         LKUP = MULT8(LKUPA) + NTR(3)
         IIN = LKUPSM(LKUP)
  160    CONTINUE
         NTR(ITR) = IIN
         NTP(IIN) = -1
  180 CONTINUE
      RETURN
      END
C*MODULE GUGDRT  *DECK SPNFNC
      SUBROUTINE SPNFNC(NELEC,MULT,MCASE,MXSPIN,IPRIM,CGCOEF,NPRIM,
     *                  KP,ICASE,KB)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (SMALL=1.0D-12, ZERO=0.0D+00, ONE=1.0D+00)
      LOGICAL DEBUG,GOPARR,DSKWRK,MASWRK
      DIMENSION MCASE(MXSPIN),IPRIM(MXSPIN,*),CGCOEF(*),KP(MXSPIN,*),
     *          ICASE(*),KB(*)
C
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      DATA DBGME/8HSPNFNC  /
C
C     NELEC = NUMBER OF SINGLY OCCUPIED ORBITALS
C     MULT  = MULTIPLICITY
C
C     PK AND BK ARRAYS ARE MADE INTEGER.
C     PREVIOUSLY THEY WERE SEMI-INTEGER OR INTEGER
C     CORRESPONDINGLY, THE FINAL ANSWER HAS A FACTOR OF TWO WHERE NEDED.
C
      DEBUG=EXETYP.EQ.DBGME
      IF(NELEC.GT.MXSPIN) THEN
         IF (MASWRK) WRITE(IW,98) NELEC,MXSPIN
         CALL ABRT
      END IF
C
C ... CLOSED SHELL: IPRIM() WILL NOT BE USED.
      IF(NELEC.EQ.0) THEN
         NPRIM=1
         CGCOEF(1)=ONE
         RETURN
         END IF
      MAXPRM=2**MXSPIN
C
C     NUMBER OF BETA ELECTRONS  = (NELEC-MULT+1)/2
C     NUMBER OF ALPHA ELECTRONS = NELEC-NBETA
C
      IF(DEBUG) WRITE(IW,602)
      NTOTP=2**NELEC
      DO 31 NE=1,NELEC
       NALTER= 2**(NELEC-NE)
       MAX   = NTOTP/(2*NALTER)
       NPRIM = 0
       DO 31 NAB=1,NALTER
          IF(NPRIM+MAX*2.GT.MAXPRM) THEN
            IF(MASWRK) WRITE(IW,*) 'NEED TO INCREASE MXPRM'
            CALL ABRT
          END IF
          DO 32 NA=1,MAX
             IPRIM(NE,NPRIM+NA)=1
             IPRIM(NE,NPRIM+NA+MAX)=2
   32     CONTINUE
          NPRIM=NPRIM+MAX*2
   31  CONTINUE
C
      NP=1
      DO 1 I=1,NPRIM
       KP(1,NP)=1
       IF(IPRIM(1,I).EQ.2) KP(1,NP)=-1
       DO 100 J=2,NELEC
C       JM=J-1
C       IF(IPRIM(J,I).EQ.2) THEN
C         KP(J,I)=KP(JM,I)-1
C       ELSE
C         KP(J,I)=KP(JM,I)+1
C       END IF
C       THE ABOVE COMMENTED PART BE RETAINED FOR CLARITY
        KP(J,NP)=KP(J-1,NP)-2*IPRIM(J,I)+3
  100  CONTINUE
       IF(KP(NELEC,NP)+1.EQ.MULT) THEN
         IF(I.NE.NP) CALL ICOPY(NELEC,IPRIM(1,I),1,IPRIM(1,NP),1)
         NP=NP+1
       END IF
    1   CONTINUE
C
      NPRIM=NP-1
      IF(DEBUG) THEN
         DO 35 NP=1,NPRIM
         WRITE(IW,34) NP,(IPRIM(K,NP),K=1,NELEC)
   35    WRITE(IW,36) (KP(K,NP),K=1,NELEC)
         END IF
C
C ... CALCULATION CLEBSCH-GORDAN COEFFICIENTS.
      IF(DEBUG) WRITE(IW,605)
      KB(1)=1
      IF(MCASE(1).EQ.3) KB(1)=-1
      ICASE(1)=MCASE(1)-1
      DO 11 K=2,NELEC
       KB(K)=KB(K-1)+1
       IF(MCASE(K).EQ.3) KB(K)=KB(K-1)-1
   11  ICASE(K)=MCASE(K)-1
      IF(DEBUG) THEN
         WRITE(IW,620) (ICASE(K),K=1,NELEC)
         WRITE(IW,621)    (KB(L),L=1,NELEC)
         END IF
C
      CHKNRM=ZERO
      NP=0
      DO 20 IPP=1,NPRIM
        COEF = ONE
        XSIGN=ONE
        DO 22 K=1,NELEC
          IF(KB(K).LT.ABS(KP(K,IPP))) GO TO 20
C
          IF(ICASE(K).EQ.1) THEN
            IF(IPRIM(K,IPP).EQ.1) THEN
              COEF = COEF*(KB(K)+KP(K,IPP))
            ELSE
              COEF = COEF*(KB(K)-KP(K,IPP))
            END IF
            COEF = COEF/(KB(K)*2)
          ELSE IF(ICASE(K).EQ.2) THEN
C           IBKK = INT(BK(K))
C           BKKI = IBKK
            KPAR = MOD(KB(K),2)
C
            IF(IPRIM(K,IPP).EQ.1) THEN
              COEF = COEF*(KB(K)-KP(K,IPP)+2)
C             IF(BKKI.EQ.BK(K)) XSIGN=-XSIGN
              IF(KPAR.EQ.0) XSIGN=-XSIGN
            ELSE IF(IPRIM(K,IPP).EQ.2) THEN
              COEF = COEF*(KB(K)+KP(K,IPP)+2)
C             IF(BKKI.NE.BK(K)) XSIGN=-XSIGN
              IF(KPAR.NE.0) XSIGN=-XSIGN
            END IF
            COEF = COEF/((KB(K)+2)*2)
          END IF
   22   CONTINUE
        IF(DEBUG) THEN
          WRITE(IW,622) IPP,(IPRIM(M,IPP),M=1,NELEC)
          WRITE(IW,623)    (KP(N,IPP),N=1,NELEC)
          WRITE(IW,624)    COEF
        END IF
        IF(ABS(COEF).GT.SMALL) THEN
          NP=NP+1
          CALL ICOPY(NELEC,IPRIM(1,IPP),1,IPRIM(1,NP),1)
          CGCOEF(NP) = XSIGN*SQRT(COEF)
          CHKNRM = CHKNRM +COEF
        END IF
   20 CONTINUE
C
      IF(ABS(CHKNRM-ONE).GT.SMALL) THEN
        IF (MASWRK) THEN
          WRITE(IW,628) (CGCOEF(ICG),ICG=1,NPRIM)
          WRITE(IW,629) CHKNRM
        END IF
        CALL ABRT
      END IF
      NPRIM=NP
      RETURN
   34 FORMAT(1X,I4,2X,10I1)
   36 FORMAT(1H+,20X,10I2)
   98 FORMAT(/1X,'MODULE GUGDRT MUST BE MODIFIED.',
     *       /1X,'     NUMBER OF OPEN SHELLS (',I2,') SHOULD BE',
     *           ' SMALLER THAN ',I3,'.')
  602 FORMAT(1X,'PRIMITIVE SPIN FUNCTIONS:')
  605 FORMAT(/1X,'CLEBSCH-GORDAN COEFFICIENTS.')
  620 FORMAT(1X,I4,2X,10I1)
  621 FORMAT(1H+,20X,10I2)
  622 FORMAT(10X,I4,2X,10I1)
  623 FORMAT(1H+,30X,10I2)
  624 FORMAT(1H+,30X,F20.10)
  628 FORMAT(1X,5F15.8)
  629 FORMAT(1X,' CHECK OF NORMALIZATION=',F15.8)
      END
C
C*MODULE GUGDRT  *DECK KOADD
      SUBROUTINE KOADD(KOADDE,COENEW)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MAXCP=4096)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /SOGUG/  CP(MAXCP),NUNIQ,LIOBP,ISODAF,NSODA,LSTREC,JSODAF,
     *                JSODA,NRECJ
      COMMON /TRNMOM/ OPERR,SYMTOL,NOCC,NUMCI,NFZC,NUMVEC,ICI,MXRT,NSTAT
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C     TOL=1.0D-10
      SMALL=SYMTOL*SYMTOL
      DO 100 L=1,NUNIQ
         IF(ABS(CP(L)-COENEW).LE.SMALL) THEN
            KOADDE=L
            RETURN
         END IF
 100  CONTINUE
      NUNIQ=NUNIQ+1
      KOADDE=NUNIQ
      IF(NUNIQ.GT.MAXCP) THEN
         IF(MASWRK) WRITE(IW,*) 'NUNIQ EXCEEDS MAXCP IN KOADD ',MAXCP
         CALL ABRT
      END IF
      CP(NUNIQ)=COENEW
      RETURN
      END
C
C*MODULE GUGDRT  *DECK GETSOB
      SUBROUTINE GETSOB(NAO,NWKS,DEBUG,LIBUFS,LNOCCU,NEEDSO,MAXIBF)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL DEBUG
      PARAMETER (MAXCP=4096)
      COMMON /FMCOM / X(1)
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /TRNMOM/ OPERR,SYMTOL,NOCC,NUMCI,NFZC,NUMVEC,ICI,MXRT,NSTAT
      COMMON /SOGUG/  CP(MAXCP),NUNIQ,LIOBP,ISODAF,NSODA,LSTREC,JSODAF,
     *                JSODA,NRECJ
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
C
      CALL VALFM(LOADFM)
      MAXIBF=NAO*4*NWKS
C     HOPEFULLY SUFFICENT, THIS IS THE SIZE OF THE BUFFER FOR CSF INFO
      IF(ICI.EQ.1) NUNIQ=0
      LIBUFS = 1 + LOADFM
      LNOCCU = LIBUFS + (MAXIBF+NWDVAR-1)/NWDVAR
      LAST   = LNOCCU + (NWKS+NWDVAR-1)/NWDVAR
      NEEDSO = LAST - LOADFM -1
      CALL GETFM(NEEDSO)
      IF(DEBUG) WRITE(IW,*) 'ALLOCATING ',NEEDSO,'WORDS FOR ICI=',ICI
C
C     ARRAY CP CONTAINS UNIQUE COEFFICIENTS IN FRONT OF DETERMINANTS
C     FOR THE DECOMPOSITION OF CSFS INTO DETERMINANTS
C     THE SAME ARRAY IS USED FOR ALL SPIN STATES.
C     MAXIBF IS REALLY A (HOPEFULLY) OVERESTIMATE. EMPIRICALLY IT IS
C     444121 FOR 10X10, SO SET TO 600000 ROUGHLY.
C     IBUFS WILL BE USED FOR STORING CSF INFO FOR THE SOC CODE (MS=S)
C     IBUFS1 IS THE SAME BUT MS=S-1,
C     NOTE THAT MAXCP CANNOT BE INCREASED WITHOUT CHANGING THE PROGRAM
C     (NAMELY THE BINARY FORMAT BELOW). ALSO IN TWO PLACES 4096 IS USED
C     EXPLICITLY INSTEAD OF MXPRM TO SIGNIFY THAT ONLY 12 BITS ARE
C     DEVOTED TO STORING THIS NUMBER. MXPRM HOWEVER IS USED FOR PURPOSES
C     OTHER THAN PB SOC.
C
C     THE STRUCTURE OF CSF BUFFERS (IBUFII,IBUFJJ) IS AS FOLLOWS:
C     WORD #  <------------BITS 64-13------------><------BITS 12-1----->
C          1                      TOTAL # OF CSFS FOR GIVEN S,MS
C          2  ORBITAL OCCUPATION SCHEME FOR CSF #1|   # SD IN CSF #1
C          3   LOCATION OF THE NEXT OCCUPATION SCHEME(OS) (0 IF NO MORE)
C          4   SLATER DETERMINANT(SD) #1 (CSF #1) | COEF LABEL OF DET #1
C          5   SLATER DETERMINANT     #2 (CSF #1) | COEF LABEL OF DET #2
C                          ....
C          W  ORBITAL OCCUPATION SCHEME FOR CSF #2|   # SD IN CSF #2
C              LOCATION OF THE NEXT OCCUPATION SCHEME(OS) (0 IF NO MORE)
C              SLATER DETERMINANT     #1 (CSF #2) | COEF LABEL OF DET #1
C              SLATER DETERMINANT     #2 (CSF #2) | COEF LABEL OF DET #2
C                          ....
C                          ....
C     LOCATION OF THE NEXT OS IS ABSOLUTE, IT IS EQUAL TO W IN THE ABOVE
C     (THIS IS TRUE FOR ALL POINTERS TO THE LOCATION OF THE NEXT WORD
C      EXCEPT FOR THE FIRST ONE, WHICH IS W-1)
C
C     OCCUPATION SCHEME STRUCTURE:
C     < 2N 2N-1 | ....BITS ........ | 4 3 | 2 1 >
C       ORBN                          ORB2 ORB1
C     EACH ORB1...N IS: 0 IF UNOCCUPIED,
C                       1 IF SINGLY OCCUPIED,
C                       3 IF DOUBLY OCCUPIED
C     SLATER DET STRUCTURE: (FOR N EQUAL TO THE NUMBER OF ACTIVE ORB.)
C     <   2*N 2*N-1 ... N+1 | N ... 3  2    1 >
C       ORBN       ORB2 ORB1|ORBN    ORB2 ORB1
C           ALPHA SPINS     |    BETA SPINS
C     EACH ORB1...10 IS 1 IF THE CORRESPONDING SPIN-ORBITAL IS OCCUPIED
C
      CALL VCLR(X(LIBUFS),1,(MAXIBF+NWDVAR-1)/NWDVAR)
C     IBUFS HOLDS CSFS DECOMPOSITION INTO DETERMINANTS FOR MS=S (S=0,1)
      CALL SOGINI(X(LIBUFS),X(LIOBP),NWKS)
C     LIBUFS IS A LIST OF CSF, SLATER DETERMINANT INFO FOR USE
C     BY SOC FORM FACTOR PROGRAM
C
      RETURN
      END
C
C*MODULE GUGDRT  *DECK SOGINI
      SUBROUTINE SOGINI(IBUFS,IOBP,NWKS)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION IBUFS(*),IOBP(2,*)
      COMMON /TRNMOM/ OPERR,SYMTOL,NOCC,NUMCI,NFZC,NUMVEC,ICI,MXRT,NSTAT
C
      IBUFS(1)=NWKS
      IOBP(1,ICI)=1
      IOBP(2,ICI)=1
C     IOBP(3,ICI)=1
      RETURN
      END
C
C*MODULE GUGDRT  *DECK SAVGSO
      SUBROUTINE SAVGSO(NWKS,JSOD,NOCCUP,IBUFII,IOBP,MS,DEBUG)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL DEBUG
      PARAMETER (MAXCP=4096)
      COMMON /SOGUG/  CP(MAXCP),NUNIQ,LIOBP,ISODAF,NSODA,LSTREC,JSODAF,
     *                JSODA,NRECJ
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON /TRNMOM/ OPERR,SYMTOL,NOCC,NUMCI,NFZC,NUMVEC,ICI,MXRT,NSTAT
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      DIMENSION NOCCUP(*),IBUFII(*),IOBP(2,*),JSOD(*)
C
      CALL RAWRIT(JSODAF,JSOD,IBUFII,(IOBP(MS+1,ICI)-1)/NWDVAR+1,
     *            (ICI-1)*NRECJ+MS+1,1)
      IF(MS.EQ.0) CALL RAWRIT(JSODAF,JSOD,NOCCUP,(NWKS-1)/NWDVAR+1,
     *                        (ICI-1)*NRECJ+4,1)
      IF(DEBUG) THEN
         WRITE(IW,*) 'CSF INFO FOR MS=S-',MS,' SIZE ',IOBP(MS+1,ICI)
         WRITE(IW,9000) (I,IBUFII(I),I=1,IOBP(MS+1,ICI))
         IF(MS.EQ.0) THEN
            WRITE(IW,*) 'NOCCUP SIZE',NWKS
            WRITE(IW,9000) (I,NOCCUP(I),I=1,NWKS)
         END IF
         IF(ICI.EQ.NUMCI.AND.MS.EQ.1) THEN
            WRITE(IW,*) 'DISTINCT COEFS IN FRONT OF DETS, SIZE ',NUNIQ
            WRITE(IW,9001) (I,CP(I),I=1,NUNIQ)
         END IF
      END IF
C     DSKWRK=SAVDSK
      RETURN
 9000 FORMAT(I8,'.',O22)
 9001 FORMAT(I4,F15.7)
      END
C*MODULE GUGDRT  *DECK IRRDET
      INTEGER FUNCTION IRRDET(ICSF,NSORB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXAO=8192, MXIRR=14)
C
      LOGICAL ABELPT,GOPARR,DSKWRK,MASWRK
C
      DIMENSION ICSF(*)
C
      COMMON /SOSYM/  EULANG(4,48),GAM(48,48),IRMON(MXAO)
      COMMON /SYMMUL/ NIJREP(MXIRR,MXIRR),IJREP(2,MXIRR,MXIRR,MXIRR)
      COMMON /SYMREP/ IRPNAM(MXIRR),IPA(MXIRR),LAMBDA(MXIRR),
     *                LAMBD0(MXIRR),IADDR1(MXIRR),IADDR2(MXIRR),
     *                IADDR3(MXIRR)
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      IF(.NOT.ABELPT()) THEN
         IRRDET=0
         RETURN
      END IF
      IRRDET=1
C        FIND DIRECT PRODUCT OF IRREDUCIBLE REPRESENTATIONS FOR ALL
C        ORBITALS IN A DETERMINANT
      DO 210 I=1,NSORB
         IGAM=IRMON(ABS(ICSF(I)))
         IF(LAMBD0(IGAM).EQ.1) THEN
            IRRDET=IJREP(2,1,IRRDET,IGAM)
         ELSE
C           THIS SHOULD NOT HAPPEN, ALTHOUGH
C           IT IS TECHNICALLY A BUG THAT IT SHOULD NOT
C           BECAUSE SN AND CN ARE ABELIAN BUT GAMESS
C           THINKS THEY ARE NOT, DOUBLE BUG IS NO BUG
            IF(MASWRK) WRITE(IW,*) 'ABELIAN GROUP FLOOD?'
            IRRDET=0
            RETURN
         END IF
  210 CONTINUE
      RETURN
      END
C*MODULE GUGDRT  *DECK IFINDET
      SUBROUTINE IFINDET(IFINDETT,ICSF,IGCSF,MAXDET,NGCSF,NAEL)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL GOPARR,DSKWRK,MASWRK
      DIMENSION ICSF(NAEL),IGCSF(NAEL,MAXDET)
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      DO 200 I=1,NGCSF
         DO 100 J=1,NAEL
            IF(ICSF(J).NE.IGCSF(J,I)) GO TO 200
  100    CONTINUE
         IFINDETT=I
         RETURN
  200 CONTINUE
      NGCSF=NGCSF+1
      IF(NGCSF.GT.MAXDET) THEN
         IF(MASWRK) WRITE(IW,*) 'MAXDET OVERWFLOWS',MAXDET
         CALL ABRT
      END IF
      CALL ICOPY(NAEL,ICSF,1,IGCSF(1,NGCSF),1)
      IFINDETT=NGCSF
      RETURN
      END
