C 08 AUG 07 - JHS - ADD PBFLAB TO COMMON BLOCK NUCMON
C 02 AUG 07 - JHS - CHANGES TO ALLOW PROP RUNTYPE WITH NEO
C 25 JUN 07 - JHS - FIX EXETYP .EQ. CHECK OPTION IN GESMEM_NU
C 18 JUN 07 - JHS - CHANGES TO ADD QUADRUPLE-ZETA BASIS
C 30 APR 07 - SPW - CHANGES TO ADD 1ST-DERIVATIVE BASED RUNS
C 19 NOV 06 - PEA - CHANGES TO ADD POSITRONS
C  6 NOV 06 - MWS - ADJUST WAVEFUNCTION COMMON BLOCK
C 25 OCT 06 - SPW - CHANGES FOR NEO VERSION 2
C 25 MAR 06 - SPW - DRIVER AND SET UP ROUTINES FOR NEO
C
C*MODULE NEO     *DECK NEOCAL
      SUBROUTINE NEOCAL(RUNTYP)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
CSPW  DOUBLE PRECISION MOROKM,MD,MAKEFP,NMR
C
      LOGICAL NUCOPT,CLSTEP,NEOTS
C
      COMMON /NEOOPT/ NUCOPT,CLSTEP,NEOTS
C
      DATA ENERGY /8HENERGY  /
      DATA GRAD   /8HGRADIENT/, HSSIAN /8HHESSIAN /
      DATA OPTMIZ /8HOPTIMIZE/, SADPT  /8HSADPOINT/
      DATA PROP   /8HPROP    /
CSPW  DATA AIRC   /8HIRC     /, DRC    /8HDRC     /
CSPW  DATA MOROKM /8HMOROKUMA/, TRNSTN /8HTRANSITN/
CSPW  DATA TRUDGE /8HTRUDGE  /
CSPW  DATA FFIELD /8HFFIELD  /, TDHF   /8HTDHF    /, XTDHF  /8HTDHFX   /
CSPW  DATA GRDXTR /8HGRADEXTR/, MAKEFP /8HMAKEFP  /, MD     /8HMD      /
CSPW  DATA VSCF   /8HVSCF    /, RAMAN  /8HRAMAN   /, GLOBOP /8HGLOBOP  /
CSPW  DATA PIMC   /8HPIMC    /, NMR    /8HNMR     /, OPTFMO /8HOPTFMO  /
C
C     ----- BRANCH ACCORDING TO RUNTYP TO APPROPRIATE DRIVER -----
C
C     IF RUNTYP.EQ.'ENERGY  ', CALCULATE ENERGY
C     IF RUNTYP.EQ.'GRADIENT', CALCULATE ENERGY+GRADIENT
C     IF RUNTYP.EQ.'HESSIAN ', CALCULATE ENERGY+GRADIENT+HESSIAN
C     IF RUNTYP.EQ.'OPTIMIZE', OPTIMIZE MOLECULAR GEOMETRY
C     IF RUNTYP.EQ.'SADPOINT', LOCATE A SADDLE POINT
C     IF RUNTYP.EQ.'TRUDGE  ', NONGRADIENT GEOMETRY/EXPONENT OPTIM.
C     IF RUNTYP.EQ.'GLOBOP  ', RUN MONTE CARLO GLOBAL OPTIMIZATION
C     IF RUNTYP.EQ.'IRC     ', TRACE REACTION PATH
C     IF RUNTYP.EQ.'DRC     ', FOLLOW DYNAMIC REACTION COORDINATE
C     IF RUNTYP.EQ.'GRADEXTR', FOLLOW A GRADIENT EXTREMAL
C     IF RUNTYP.EQ.'MOROKUMA', PERFORM MOROKUMA ANALYSIS
C     IF RUNTYP.EQ.'SPINORBT', COMPUTE SPIN-ORBIT COUPLING
C     IF RUNTYP.EQ.'TRANSITN', COMPUTE TRANSITION MOMENT
C     IF RUNTYP.EQ.'FFIELD  ', COMPUTE POLARIZABILITY
C     IF RUNTYP.EQ.'TDHF    ', FREQUENCY DEPENDENT OPTICAL PROPERTIES
C     IF RUNTYP.EQ.'TDHFX   ', EXTENDED PACKAGE FOR ADDITIONAL
C                              FREQUENCY DEPENDENT OPTICAL PROPERTIES
C     IF RUNTYP.EQ.'RAMAN   ', COMPUTE RAMAN SPECTRUM INTENSITY
C     IF RUNTYP.EQ.'PROP    ', CALCULATE PROPERTIES ONLY
C     IF RUNTYP.EQ.'MAKEFP  ', MAKE AN EFFECTIVE FRAGMENT POTENTIAL
C
C     THE RUNTYP OF 'SURFACE' IS HANDLED ELSEWHERE.
C
C     --- NEO SINGLE POINT ENERGY HAS OPTION TO MINIMIZE ENERGY
C         WITH REPECT TO NUCLEAR BASIS SET CENTERS (NUCOPT=.TRUE.) ---
C
C
      IF(RUNTYP.EQ.ENERGY) THEN
         IF(NUCOPT) THEN
            CALL NEOSPT
         ELSE
            CALL ENERGX
         END IF
      END IF
C
      IF(RUNTYP.EQ.GRAD) THEN
         IF(NUCOPT) THEN
            CALL NEOSPT
         ELSE
            CALL GRADX
         END IF
      END IF
C
      IF(RUNTYP.EQ.HSSIAN) THEN
         IF(NUCOPT) THEN
            CALL HESSX_NEO(.FALSE.,.FALSE.)
         ELSE
            CALL HESSX(.FALSE.,.FALSE.)
         END IF
      END IF
C
C     --- NEO GEOMETRY OPTIMIZATION (NO SADDLE POINT YET) SEARCH HAS
C         OPTION TO MINIMIZE ENERGY WITH REPECT TO NUCLEAR BASIS SET
C         CENTERS BETWEEN EACH GEOMETRY STEP (NUCOPT=.TRUE.) ---
C
      IF(RUNTYP.EQ.OPTMIZ) THEN
         IF(NUCOPT) THEN
            CALL NEOGOP
         ELSE
            CALL SIGX(.FALSE.)
         END IF
      END IF
C
      IF(RUNTYP.EQ.SADPT ) THEN
         IF(NUCOPT) THEN
            WRITE(6,*)'SET NUCOPT=.FALSE. IN $NEO AND RESUBMIT'
            CALL ABRT
CSPW        CALL NEOSAD
         ELSE
            CALL SIGX(.FALSE.)
         END IF
      END IF
C
C     --- ONLY CALCULATE PROPERTIES ---
C
      IF(RUNTYP.EQ.PROP) THEN
            CALL ONEEI
            CALL ONENI
            CALL GUESMO(GUESS)
            CALL GUESS_NMO(GUESSN)
            CALL NUCIDEN
            CALL PRPNEO('PROP')
      END IF
C
C     --- CHECK TO SEE IF A NEO-NCI CALC IS REQUESTED ---
C
      CALL NEONCI_DRV

C
CSPW  --- REMAINING RUN TYPES NOT YET AVAILABLE WITH NEO ---
CSPW
CSPW  IF(RUNTYP.EQ.TRUDGE) CALL TRUDGX
CSPW  IF(RUNTYP.EQ.GLOBOP) CALL GLOPDR
CSPW  IF(RUNTYP.EQ.PIMC)   CALL PIMCX
CSPW  IF(RUNTYP.EQ.AIRC  ) CALL IRCX
CSPW  IF(RUNTYP.EQ.DRC)    CALL DRCX
CSPW  IF(RUNTYP.EQ.MD)     CALL MDX
CSPW  IF(RUNTYP.EQ.GRDXTR) CALL GRADEX
CSPW  IF(RUNTYP.EQ.VSCF)   CALL VSCFX
CSPW  IF(RUNTYP.EQ.MOROKM) CALL MOROX
CSPW  IF(RUNTYP.EQ.TRNSTN) CALL TRNMOMX
CSPW  IF(RUNTYP.EQ.FFIELD) CALL FFLDX
CSPW  IF(RUNTYP.EQ.TDHF)   CALL TDHFX
CSPW  IF(RUNTYP.EQ.XTDHF)  CALL TDHFXMAIN
CSPW  IF(RUNTYP.EQ.RAMAN)  CALL RAMANX
CSPW  IF(RUNTYP.EQ.NMR)    CALL NMRX
CSPW  IF(RUNTYP.EQ.PROP  ) THEN
CSPW     CALL ONEEI
CSPW     CALL GUESMO(GUESS)
CSPW     CALL HFPROP
CSPW  END IF
CSPW  IF(RUNTYP.EQ.MAKEFP) CALL EFPX
CSPW  IF(RUNTYP.EQ.OPTFMO) CALL OPTFMOX
C
      RETURN
      END
C
C*MODULE NEO     *DECK NEOINP
      SUBROUTINE NEOINP(IRET)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DOUBLE PRECISION NEOSCF,MCSCF,NEO,NEOCI
C
      LOGICAL GOPARR,DSKWRK,MASWRK
      LOGICAL ABEL
      LOGICAL OK,EXCH,VNUCEX,DNUCGS
      LOGICAL NUCOPT,CLSTEP,NEOTS
      LOGICAL NEOHSS
      LOGICAL NEONCI
C
      LOGICAL DIRNUC,NUFOCK,SYMNUC,USRDEX,POSNEO,POSPRP
C
C
      CHARACTER*8 QNUN,QNN
      CHARACTER*10 PBFLAB
C
      PARAMETER (MAXQNT=10, MAXNUP=100)
      PARAMETER (MXSH=5000, MXATM=2000, MXAO=8192)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /NBSEXP/ EXNB(MAXNUP,MAXQNT),CONNB(MAXNUP,MAXQNT),
     *                ICONNB(MAXNUP,MAXQNT),USRDEX
      COMMON /NEOMPN/ NEMPLV
      COMMON /NEOJOB/ NEORUN,NELERM
      COMMON /NEOMTD/ NEOSCF,NEOCI
      COMMON /NEOOPT/ NUCOPT,CLSTEP,NEOTS
      COMMON /NORTHO/ NEONCI,LOCORB
      COMMON /NUCHSS/ HSSINI,HSSUPD,NEOHSS
      COMMON /NUCMOI/ NUNIQN,IUNIQN(20),IUNIQT(20),NQMNUC,IQMNUC(20),
     *                IQNTYP(20),NUMNB,NUCST,NAUXNB,IAUXNB(20),NUMULT,
     *                NNA,NNB,NTAUXB
      COMMON /NUCMOR/ QMNUCM(20)
      COMMON /NUCMOL/ EXCH,VNUCEX,DNUCGS
      COMMON /NUCMOM/ BASNUC
      COMMON /NUCMON/ QNUN(20),QNN(20),PBFLAB(MXAO)
      COMMON /NUCMOP/ DIRNUC,NUFOCK
      COMMON /NUCPOS/ IUNIQA(20),POSNEO,POSPRP
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /SYMMOL/ GROUP,COMPLEX,IGROUP,NAXIS,ILABMO,ABEL
      COMMON /SYMNEO/ QMATLN,SYMNUC
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     &                TSYM(432),INVT(48),NT
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00)
C
C      ----- SET UP NAMELIST $NEO TABLES -----
C
      PARAMETER (NNAM=28)
      DIMENSION QNAM(NNAM),KQNAM(NNAM)
      DATA NEO/8HNEO     /
      DATA QNAM/8HNUNIQN  ,8HIUNIQN  ,8HQMNUCM  ,8HBASNUC  ,
     *          8HNEOSCF  ,8HIUNIQT  ,8HEXCH    ,8HNUMULT  ,
     *          8HNUCST   ,8HNAUXNB  ,8HIAUXNB  ,8HVNUCEX  ,
     *          8HNUCOPT  ,8HNTAUXB  ,8HNEOHSS  ,8HHSSINI  ,
     *          8HHSSUPD  ,8HDIRNUC  ,8HSYMNUC  ,8HQMTOLN  ,
     *          8HEXNB    ,8HNEMPLV  ,8HNEOCI   ,8HPOSNEO  ,
     *          8HPOSPRP  ,8HIUNIQA  ,8HNEONCI  ,8HLOCORB  /
      DATA KQNAM /1,201,203,5,5,201,0,1,1,1,201,0,0,1,0,5,5,0,0,3,
     *            803,1,5,0,0,201,0,1/
C
      DATA BLANK /8H        /
      DATA RNONE/8HNONE    /
      DATA SZSNB,DZSNB,TZSNB,QZSNB/8HSZSNB   ,8HDZSNB   ,8HTZSNB   ,
     *     8HQZSNB   /
      DATA SZSPNB,DZSPNB,TZSPNB,QZSPNB/8HSZSPNB  ,8HDZSPNB  ,8HTZSPNB  ,
     *     8HQZSPNB  /
      DATA SZSPDN,DZSPDN,TZSPDN,QZSPDD/8HSZSPDN  ,8HDZSPDN  ,
     *     8HTZSPDN  ,8HQZSPDD  /
      DATA GENNBS/8HGENNBS  /
      DATA READIN/8HREADIN  /
      DATA DIAGZN,RONHF,FCI/8HDIAGZN  ,8HRONHF   ,8HFCI     /
      DATA MCSCF/8HMCSCF   /
      DATA CALCUP/8HCALCUP  /,POWELLUP/8HPOWELLUP/,SKIPUP/8HSKIPUP  /,
     *     CALCH /8HCALCH   /,READH   /8HREADH   /
      DATA C1/8HC1      /
      DATA ENERGY,HSSIAN/8HENERGY  ,8HHESSIAN /
      DATA SADPT  /8HSADPOINT/
C
      DO 110 J=1,MAXQNT
         DO 100 I=1,MAXNUP
            ICONNB(I,J) = 0
            CONNB(I,J) = ZERO
            EXNB(I,J) = -ONE
  100    CONTINUE
  110 CONTINUE
C
C     ----- INITIALIZE VARIABLES FOR NAMELIST $NEO -----
C
      NEMPLV = 0
      NEORUN = 0
      NUNIQN = 0
      NQMNUC = 0
      NAUXNB = 0
      NTAUXB = 0
      BASNUC = BLANK
      NEOSCF = BLANK
      NEOCI  = BLANK
      DO I = 1,20
         IUNIQT(I) = 1
         IUNIQA(I) = 0
         IQNTYP(I) = 1
         IAUXNB(I) = 0
      END DO
C
CSPW  IGAUSS = 1
      NUCSF = 0
      NUCPF = 0
      NUCDF = 0
      EXCH = .TRUE.
      NUCOPT = .FALSE.
      NEOHSS = .FALSE.
      HSSINI = BLANK
      HSSUPD = BLANK
      NUMULT = 2
      NUCST = 1
      VNUCEX=.FALSE.
      DIRNUC = .FALSE.
      POSNEO = .FALSE.
      POSPRP = .FALSE.
      SYMNUC = .FALSE.
CSPW  SYMNUC = .TRUE.
      QMTOLN = 0.0D+00
      USRDEX = .FALSE.
      NEONCI = .FALSE.
      LOCORB = 0
      IF(RUNTYP.EQ.HSSIAN) NUCOPT = .TRUE.
C
C     ----- READ NAMELIST $SYSTEM -----
C
      JRET = 0
      CALL NAMEIO(IR,JRET,NEO,NNAM,QNAM,KQNAM,
     *     NUNIQN,IUNIQN,QMNUCM,BASNUC,NEOSCF,IUNIQT,EXCH,NUMULT,
     *     NUCST,NAUXNB,IAUXNB,VNUCEX,NUCOPT,NTAUXB,NEOHSS,HSSINI,
     *     HSSUPD,DIRNUC,SYMNUC,QMTOLN,EXNB,NEMPLV,NEOCI,
     *     POSNEO,POSPRP,IUNIQA,NEONCI,LOCORB,
     *     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. 2) THEN
         IF (MASWRK) WRITE (IW,9008)
         CALL ABRT
      END IF
C
      IF(NUNIQN.GT.0) THEN
         NEORUN = 1
         NELERM = NTAUXB
         IF(IRET.NE.1) WRITE(IW,9009)
      END IF
      IF(IRET.EQ.1) RETURN
C
      CLSTEP = .FALSE.
      NEOTS = .FALSE.
C
      QMATLN = QMTOLN
C
C     ---- CHECK SPELLINGS, AND ALSO SET THE OPTION FLAGS ----
C
      NERR = 0
      OK = .FALSE.
      IF(BASNUC.EQ.BLANK)  BASNUC = DZSNB
      IF(BASNUC.EQ.SZSNB)  OK = .TRUE.
      IF(BASNUC.EQ.DZSNB)  OK = .TRUE.
      IF(BASNUC.EQ.TZSNB)  OK = .TRUE.
      IF(BASNUC.EQ.QZSNB)  OK = .TRUE.
      IF(BASNUC.EQ.SZSPNB) OK = .TRUE.
      IF(BASNUC.EQ.DZSPNB) OK = .TRUE.
      IF(BASNUC.EQ.TZSPNB) OK = .TRUE.
      IF(BASNUC.EQ.QZSPNB) OK = .TRUE.
      IF(BASNUC.EQ.SZSPDN) OK = .TRUE.
      IF(BASNUC.EQ.DZSPDN) OK = .TRUE.
      IF(BASNUC.EQ.TZSPDN) OK = .TRUE.
      IF(BASNUC.EQ.QZSPDD) OK = .TRUE.
      IF(BASNUC.EQ.GENNBS) OK = .TRUE.
      IF(BASNUC.EQ.READIN) OK = .TRUE.
      IF(.NOT.OK) THEN
         IF (MASWRK) WRITE(IW,9010) 'BASNUC',BASNUC
         NERR = NERR+1
      END IF
C
      OK = .FALSE.
      IF(NEOSCF.EQ.BLANK) NEOSCF = RNONE
      IF(NEOSCF.EQ.RNONE)  OK = .TRUE.
      IF(NEOSCF.EQ.DIAGZN) OK = .TRUE.
      IF(NEOSCF.EQ.RONHF ) OK = .TRUE.
      IF(NEOSCF.EQ.MCSCF ) OK = .TRUE.
      IF(.NOT.OK) THEN
         IF (MASWRK) WRITE(IW,9010) 'NEOSCF',NEOSCF
         NERR = NERR+1
      END IF
C
      OK = .FALSE.
      IF(NEOCI.EQ.BLANK) NEOCI = RNONE
      IF(NEOCI.EQ.RNONE)  OK = .TRUE.
      IF(NEOCI.EQ.FCI   ) OK = .TRUE.
      IF(.NOT.OK) THEN
         IF (MASWRK) WRITE(IW,9010) 'NEOCI',NEOCI
         NERR = NERR+1
      END IF

C
      OK = .FALSE.
      IF(HSSINI.EQ.BLANK ) HSSINI = READH
      IF(HSSINI.EQ.RNONE ) OK = .TRUE.
      IF(HSSINI.EQ.READH ) OK = .TRUE.
      IF(HSSINI.EQ.CALCH ) OK = .TRUE.
      IF(.NOT.OK) THEN
         IF (MASWRK) WRITE(IW,9010) 'HSSINI',HSSINI
         NERR = NERR+1
      END IF
C
      OK = .FALSE.
      IF(HSSUPD.EQ.BLANK   ) HSSUPD = POWELLUP
      IF(HSSUPD.EQ.RNONE   ) OK = .TRUE.
      IF(HSSUPD.EQ.POWELLUP) OK = .TRUE.
      IF(HSSUPD.EQ.CALCUP  ) OK = .TRUE.
      IF(HSSUPD.EQ.SKIPUP  ) OK = .TRUE.
      IF(.NOT.OK) THEN
         IF (MASWRK) WRITE(IW,9010) 'HSSUPD',HSSUPD
         NERR = NERR+1
      END IF
C
      IF(NERR.GT.0) THEN
         IF (MASWRK) THEN
         WRITE(IW,*) 'YOUR $NEO HAS AT LEAST ONE SPELLING MISTAKE.'
         WRITE(IW,*) 'THE JOB IS STOPPING SO YOU CAN FIX IT.'
         END IF
         CALL ABRT
         STOP
      END IF
C
      IF(BASNUC.EQ.GENNBS) USRDEX=.TRUE.
C
C     --- OVER RIDE NUCOPT FOR SADPOINT RUNS ---
C
      IF(RUNTYP.EQ.SADPT) NUCOPT = .FALSE.
C
      IF (MASWRK) THEN
         WRITE (IW,9048) NUNIQN,BASNUC,NEOSCF,NEOCI,NUMULT,NUCST,
     *                   NAUXNB,VNUCEX,NUCOPT,NTAUXB,NEOHSS,HSSINI,
     *                   HSSUPD,DIRNUC,SYMNUC,QMATLN,USRDEX,POSNEO,
     *                   POSPRP,NEONCI,LOCORB
      END IF
C
C     --- ONLY DOUBLE-ZETA BASIS SETS ARE CURRENTLY BUILT IN - FOR
C     OTHERS NEED USER INPUT OF EXPONENTS OR AN EXTERNAL FILE ---
C
      IF(BASNUC.NE.DZSNB .AND. BASNUC.NE.DZSPNB .AND.
     *   BASNUC.NE.DZSPDN .AND. BASNUC.NE.QZSNB .AND.
     *   BASNUC.NE.QZSPNB .AND. BASNUC.NE.QZSPDD .AND.
     *   BASNUC.NE.GENNBS .AND..NOT.
     *   USRDEX .AND. BASNUC.NE.READIN) THEN
         WRITE(IW,*) 'FOR YOUR CHOSEN BASNUC YOU MUST SET ',
     *               'USRDEX=.TRUE. AND PROVIDE EXPONENTS'
         CALL ABRT
      END IF
C
C     --- IF GENNBS USER MUST PROVIDE BASIS SET DATA ---
C
      IF(BASNUC.EQ.GENNBS) THEN
         NTB = NUCSF + NUCPF + NUCDF
         IF(NTB.EQ.0) THEN
            WRITE(IW,*)'NO NUCLEAR BASIS FUNCTIONS CHOSEN FOR GENBAS'
            CALL ABRT
         END IF
      END IF
C
      IF(USRDEX) THEN
         IF(BASNUC.EQ.SZSNB) NTB = 1
         IF(BASNUC.EQ.DZSNB) NTB = 2
         IF(BASNUC.EQ.TZSNB) NTB = 3
         IF(BASNUC.EQ.SZSPNB) NTB = 2
         IF(BASNUC.EQ.DZSPNB) NTB = 4
         IF(BASNUC.EQ.TZSPNB) NTB = 6
         IF(BASNUC.EQ.SZSPDN) NTB = 3
         IF(BASNUC.EQ.DZSPDN) NTB = 6
         IF(BASNUC.EQ.TZSPDN) NTB = 9
         NN = 0
         DO IEX=1,NTB
            IF(EXNB(IEX,1).GT.ZERO) NN = NN + 1
         END DO
         IF(NN .LT. NTB) THEN
            WRITE(6,*) 'TOO FEW EXPONENTS ENTERED IN EXNB'
            CALL ABRT
         END IF
      END IF
C
C     --- CHECK ONLY QUANTUM PROTONS OR POSITRONS REQUESTED ---
C     1=PROTON, 2=DEUTERIUM NUCLEUS, 3=TRITIUM NUCLEUS
C     IF POSNEO==TRUE THEN
C     1=POSITRON
C
CSPW  DO I=1,NUNIQN+NAUXNB
CSPW     II = IUNIQT(I)
CSPW     IF (II.GT.1) THEN
CSPW        WRITE(IW,*) 'ONLY PROTON MO METHODS AVAILABLE RIGHT NOW'
CSPW        CALL ABRT
CSPW     END IF
CSPW     IF(II.EQ.1) THEN
CSPW        QNUN(I) = 'PROTON'
CSPW     END IF
CSPW  END DO
C
C     --- FOR NOW FORCE PROTONS OR POSITRONS ONLY ---
C
      DO I=1,NUNIQN+NAUXNB
         IUNIQT(I)=1
         II = IUNIQT(I)
         IF(II.EQ.1.AND.POSNEO) THEN
            QNUN(I) = 'PS'
         ELSE IF (II.EQ.1) THEN
            QNUN(I) = 'PROTON'
         END IF
      END DO
C
C     ---- CHECK ONLY NEMPLV=0,2 GIVEN ----
C
      IF(NEMPLV.GT.0.AND.NEMPLV.NE.2) THEN
         WRITE(IW,*) 'CURRENTLY ONLY NEO-MP2 LEVEL AVAILABLE'
         WRITE(IW,*) 'PLEASE FIX NEMPLV IN INPUT'
         CALL ABRT
      END IF
C
C     ---- CHECK NEO-MRCI NOT REQUESTED ----
C
      IF(NEOSCF.EQ.MCSCF .AND. NEOCI.EQ.FCI) THEN
         WRITE(IW,*) 'CURRENTLY NEO-MRCI IS NOT POSSIBLE'
         WRITE(IW,*) 'PLEASE CHOOSE AN MCSCF RUN OR A CI RUN'
         CALL ABRT
      END IF
C
C     --- CHECK IF NEO GRADIENT BASED RUN IS POSSIBLE ---
C
      IF(RUNTYP.NE.ENERGY .OR. (RUNTYP.EQ.ENERGY .AND. NUCOPT)) THEN
         IF(NEOSCF.EQ.MCSCF .OR. NEOCI.EQ.FCI) THEN
            WRITE(IW,*) 'CURRENTLY NEO GRADIENT BASED CALCULATIONS'
            WRITE(IW,*) 'ARE NOT POSSIBLE WITH CI BASED METHODS'
            CALL ABRT
         END IF
         IF(NEMPLV.EQ.2) THEN
            WRITE(IW,*) 'CURRENTLY NEO GRADIENT BASED CALCULATIONS'
            WRITE(IW,*) 'ARE NOT POSSIBLE WITH MP2 METHODS'
            CALL ABRT
         END IF
      END IF
C
C     ---- NEED MASS FOR CALCULATION OF KINETIC ENERGY ----
C
      DO I=1,NUNIQN
         ITYP = IUNIQT(I)
         IF (ITYP.LE.3) THEN
            QMNUCM(I) = 1.836D+03 + DBLE(ITYP-1)*1.839D+03
         END IF
         IF ((ITYP.EQ.1) .AND.POSNEO) THEN
               QMNUCM(I) = ONE
         END IF
         IF ((ITYP.GT.1) .AND.POSNEO) THEN
            WRITE(IW,*) 'ASKED FOR IUNIQT > 1 WITH POSITRON'
            WRITE(IW,*) 'PLEASE FIX'
            CALL ABRT
         END IF
      END DO
C
C     --- SET FLAG FOR INITIAL GUESS OR READ IN INITIAL WFN ---
C
      DNUCGS = .TRUE.
C
C     ---- READ IN NUCLEAR BASIS SETS (PROTON OR DEUTERION) ----
C
      IF(NUNIQN.GT.0) THEN
        CALL NBASX
      END IF
C
C     --- IF NEO-MCSCF CALCULATION TURN OFF SYMMETRY (FOR NOW) ---
C
      IF(NEOSCF.EQ.MCSCF) THEN
         IF(NT.NE.1) THEN
            WRITE (IW,9080)
            GROUP = C1
            IGROUP = 1
            NAXIS = 1
            NT = 1
         END IF
      END IF
C
      RETURN
C
 9008 FORMAT(28H ERROR IN $NEO INPUT - STOP )
 9009 FORMAT(//5X,64(1H-)/14X,'NUCLEAR ELECTRONIC ORBITAL (NEO)',
     *        ' CALCULATION',/5X,64(1H-),/
     *        5X,'NEO METHOD DEVELOPMENT IS CARRIED OUT IN',
     *        ' THE LABORATORY OF      ',/
     *        5X,'SHARON HAMMES-SCHIFFER AT THE PENNSYLVANIA',
     *        ' STATE UNIVERISTY',//
     *        5X,'CONTRIBUTORS TO THE CODE: SIMON P. WEBB,',
     *        ' TZVETELIN IORDANOV,',/
     *        31X,'MIKE PAK, CHET SWALINA, AND',
     *        ' JONATHAN SKONE',/
     *        5X,64(1H-)/)
 9010 FORMAT(1X,'*** ERROR! KEYWORD ',A6,
     *     ' WAS GIVEN AN ILLEGAL VALUE ',A8,'.')
 9048 FORMAT(/5X,'$NEO OPTIONS'/5X,12(1H-)/
     *  5X,7HNUNIQN=,I8,5X,7HBASNUC=,A8,5X,7HNEOSCF=,A8/
     *  5X,7HNEOCI =,A8,5X,7HNUMULT=,I8,5X,7HNUCST =,I8/
     *  5X,7HNAUXNB=,I8,5X,7HVNUCEX=,L8,5X,7HNUCOPT=,L8/
     *  5X,7HNTAUXB=,I8,5X,7HNEOHSS=,L8,5X,7HHSSINI=,A8/
     *  5X,7HHSSUPD=,A8,5X,7HDIRNUC=,L8,5X,7HSYMNUC=,L8/
     *  5X,7HQMTOLN=,1P,E8.1,0P,5X,7HUSRDEX=,L8/
     *  5X,7HPOSNEO=,L8,5X,7HPOSPRP=,L8/
     *  5X,7HNEONCI=,L8,5X,7HLOCORB=,I8)
 9080 FORMAT(/1X,'**** SWITCHING OFF ALL SYMMETRY FOR NEO-MCSCF ****'/)
      END
C
C*MODULE NEO     *DECK NEOSET
      SUBROUTINE NEOSET(DO1NUC,DONGES)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DOUBLE PRECISION NEOSCF,NEOCI
C
      LOGICAL DO1NUC,DONGES,POSNEO,POSPRP
      LOGICAL INIT,NUCNUC,ELENUC,DIRNUC,NUCTRN,ELPOVR
      LOGICAL GOPARR,DSKWRK,MASWRK,SVGPAR
      LOGICAL MIXED,NUFOCK
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /NEOMTD/ NEOSCF,NEOCI
      COMMON /NUCMOI/ NUNIQN,IUNIQN(20),IUNIQT(20),NQMNUC,IQMNUC(20),
     *                IQNTYP(20),NUMNB,NUCST,NAUXNB,IAUXNB(20),NUMULT,
     *                NNA,NNB,NTAUXB
      COMMON /NUCMOP/ DIRNUC,NUFOCK
      COMMON /NUCPOS/ IUNIQA(20),POSNEO,POSPRP
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
C
      DATA DIAGZN,RONHF/8HDIAGZN  ,8HRONHF   /
C
      DIMENSION FAEN(1),FBEN(1),FAN(1),FBN(1)
C
      INIT = .TRUE.
      NUCTRN = .FALSE.
C
C     --- CHECK NUCLEAR MULTIPLICITY CONSISTENT WITH NEOSCF ---
C
      IF(NEOSCF.EQ.DIAGZN) THEN
         N = NNA + NNB
         IF(N.GT.1) THEN
            WRITE(IW,*)'ONLY ONE QM NUCLEUS ALLOWED WITH DIAGZN - ABORT'
            CALL ABRT
         END IF
      END IF
C
      IF(NEOSCF.EQ.RONHF) THEN
         IF(NNB.NE.0) THEN
            WRITE(IW,*)'ONLY ALPHA SPINS ALLOWED WITH RONHF - ABORT'
            CALL ABRT
         END IF
      END IF
C
      MULTHS = NQMNUC + 1
      IF(NEOSCF.EQ.RONHF .AND. NUMULT.NE.MULTHS) THEN
         WRITE(IW,*)'NUCLEAR MULTIPLICITY DOES NOT MAKE SENSE - ABORT'
         CALL ABRT
      END IF
C
      IF(NQMNUC.GT.1 .AND. NUMULT.EQ.2) THEN
         WRITE(IW,*)'NUCLEAR MULTIPLICITY DOES NOT MAKE SENSE - ABORT'
         CALL ABRT
      END IF
C
C     --- 1-NUCLEUS INTERGALS ---
C
      IF(DO1NUC) CALL ONENI
C
C     --- ELECTRON-NUCLEAR COULOMB INTEGRALS ---
C
      ISAV = IS
      IS = 67
      CALL SEQOPN(IS,'ELNUINT','UNKNOWN',.FALSE.,'UNFORMATTED')
      SVGPAR = GOPARR
C
      MIXED = .TRUE.
      NUCNUC = .FALSE.
      ELENUC = .TRUE.
      ELPOVR = .FALSE.
      CALL NJANDK(MIXED,INIT,SCFTYP,DIRNUC,NUCTRN,FAEN,FBEN,
     &            NUCNUC,ELENUC,ELPOVR)
C
      IS = ISAV
      GOPARR = SVGPAR
C
C     --- NUCLEAR-NUCLEAR INTEGRALS ---
C
      IF(NEOSCF.NE.DIAGZN) THEN
         ISAV = IS
         IS = 68
         CALL SEQOPN(IS,'NUNUINT','UNKNOWN',.FALSE.,'UNFORMATTED')
         SVGPAR = GOPARR
C
         MIXED = .FALSE.
         NUCNUC = .TRUE.
         ELENUC = .FALSE.
         ELPOVR = .FALSE.
         CALL NJANDK(MIXED,INIT,SCFTYP,DIRNUC,NUCTRN,FAN,FBN,
     &               NUCNUC,ELENUC,ELPOVR)
C
         GOPARR = SVGPAR
         IS = ISAV
      END IF

C     --- ELECTRON-POSITRON OVERLAP INTEGRALS ---
C
      IF( POSNEO  .AND.  POSPRP ) THEN
         SVGPAR = GOPARR
C
         MIXED = .TRUE.
         NUCNUC = .FALSE.
         ELENUC = .FALSE.
         ELPOVR = .TRUE.
         CALL NJANDK(MIXED,INIT,SCFTYP,DIRNUC,NUCTRN,FAEN,FBEN,
     &            NUCNUC,ELENUC,ELPOVR)
C
         GOPARR = SVGPAR
      END IF
C
C     --- POSIIBLE INITIAL GUESS OF NUCLEAR ORBITALS ---
C
      IF(DONGES) THEN
         CALL GUESS_NMO(GUESSN)
      END IF
C
      RETURN
      END
C
C*MODULE NEO     *DECK NMOOUT
      SUBROUTINE NMOOUT(MPUNCH)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
      LOGICAL SYMNUC
C
      DIMENSION TIMSTR(3)
C
      PARAMETER (MXATM=2000)
      PARAMETER (MXAO=8192)
C
      COMMON /CONV  / DENTOL,EN,ETOT,EHF,EHF0,DIFF,ITER,ICALP,ICBET
      COMMON /FMCOM / X(1)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /NUCMOI/ NUNIQN,IUNIQN(20),IUNIQT(20),NQMNUC,IQMNUC(20),
     *                IQNTYP(20),NUMNB,NUCST,NAUXNB,IAUXNB(20),NUMULT,
     *                NNA,NNB,NTAUXB
      COMMON /RUNLAB/ TITLE(10),ANAM(MXATM),BNAM(MXATM),BFLAB(MXAO)
      COMMON /SYMNEO/ QMTOLN,SYMNUC
C
      NN0 = NUMNB
      N1 = NUMNB
      N3 = N1*N1
C
C     --- SET UP AND GET MEMORY ---
C
      CALL VALFM(LOADFM)
      LNMO  = LOADFM + 1
      LNEV  = LNMO   + N3
      LAST  = LNEV   + N1
      NEED  = LAST   - LOADFM - 1
      CALL GETFM(NEED)
C
C     --- NUCLEAR MOS TO LOG FILE ---
C
      WRITE(IW,9185)
      CALL DAREAD(IDAF,IODA,X(LNMO),N3,444,0)
      CALL DAREAD(IDAF,IODA,X(LNEV),N1,447,0)
C
      IF(SYMNUC) THEN
         CALL PREVNUS(X(LNMO),X(LNEV),N1,N1,NUM+1,NUM+NUMNB)
      ELSE
         CALL PREVNU(X(LNMO),X(LNEV),N1,N1,NUM+1,NUM+NUMNB)
      END IF
C
C     --- PUNCH ANY NUCLEAR ORBITALS TO DAT FILE ---
C
      IF(MPUNCH.GT.0 .AND. MASWRK) THEN
         CALL TMDATE(TIMSTR)
         WRITE(IP,8000) TIMSTR,TITLE,ETOT,EN,ITER
         LPUN = N1
         IF(MPUNCH .EQ. 2) LPUN = NN0
         WRITE(IP, FMT='(8H $VECPRO)')
         CALL PUSQL(X(LNMO),LPUN,N1,N1)
         WRITE(IP, FMT='(5H $END)')
      END IF
C
C     --- RETURN MEMORY ---
C
      CALL RETFM(NEED)
C
      RETURN
 8000 FORMAT('--- NUC-HF ORBITALS --- GENERATED AT ',3A8/10A8/
     *       'E(RHF)=',F20.10,', E(NUC)=',F16.10,',',I5,' ITERS')
 9185 FORMAT(/10X,20(1H-)/10X,20HNUCLEAR EIGENVECTORS/10X,20(1H-))
      END
C
C*MODULE NEO     *DECK PUNNMO
      SUBROUTINE PUNNMO(MPUNCH)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION TIMSTR(3)
C
      PARAMETER (MXATM=2000)
      PARAMETER (MXAO=8192)
C
      COMMON /CONV  / DENTOL,EN,ETOT,EHF,EHF0,DIFF,ITER,ICALP,ICBET
      COMMON /FMCOM / X(1)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /NUCMOI/ NUNIQN,IUNIQN(20),IUNIQT(20),NQMNUC,IQMNUC(20),
     *                IQNTYP(20),NUMNB,NUCST,NAUXNB,IAUXNB(20),NUMULT,
     *                NNA,NNB,NTAUXB
      COMMON /RUNLAB/ TITLE(10),ANAM(MXATM),BNAM(MXATM),BFLAB(MXAO)
C
      NN0 = NUMNB
      N1 = NUMNB
      N3 = N1*N1
C
C     --- SET UP AND GET MEMORY ---
C
      CALL VALFM(LOADFM)
      LNMO  = LOADFM + 1
      LAST  = LNMO   + N3
      NEED  = LAST   - LOADFM - 1
      CALL GETFM(NEED)
C
      CALL DAREAD(IDAF,IODA,X(LNMO),N3,444,0)
C
C     --- PUNCH ANY NUCLEAR ORBITALS TO DAT FILE ---
C
      IF(MPUNCH.GE.-1 .AND. MASWRK) THEN
         CALL TMDATE(TIMSTR)
         WRITE(IP,8000) TIMSTR,TITLE,ETOT,EN,ITER
         LPUN = N1
         IF(MPUNCH .EQ. 2) LPUN = NN0
         WRITE(IP, FMT='(8H $VECPRO)')
         CALL PUSQL(X(LNMO),LPUN,N1,N1)
         WRITE(IP, FMT='(5H $END)')
      END IF
C
C     --- RETURN MEMORY ---
C
      CALL RETFM(NEED)
C
      RETURN
 8000 FORMAT('--- NUC-HF ORBITALS --- GENERATED AT ',3A8/10A8/
     *       'E(RHF)=',F20.10,', E(NUC)=',F16.10,',',I5,' ITERS')
      END
C
C*MODULE NEO     *DECK GESMEM_NU
      SUBROUTINE GESMEM_NU(NORB,GUESS,
     *                  TOLZ,TOLE,MIX,PRTMO,PUNMO,INSORB)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL DBG,MIX,PRTMO,PUNMO,QUICK,
     *        GOPARR,DSKWRK,MASWRK
C
      PARAMETER (MXATM=2000)
C
      COMMON /FMCOM / X(1)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /NUCMOI/ NUNIQN,IUNIQN(20),IUNIQT(20),NQMNUC,IQMNUC(20),
     *                IQNTYP(20),NUMNB,NUCST,NAUXNB,IAUXNB(20),NUMULT,
     *                NNA,NNB,NTAUXB
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
C
      DATA CORE/8HHCORE   /, GHCK/8HHUCKEL  /
      DATA RDMO/8HMOREAD  /, SVMO/8HMOSAVED /
      DATA DBUG/8HDEBUG   /, DBUGME/8HGUESS   /
      DATA CHECK/8HCHECK   /
      DATA GESDEN/8HGESDEN  /
      DATA NONE/4HNONE/
C
C     ----- ALLOCATE MEMORY FOR THE INITIAL ORBITAL ROUTINES -----
C
      DBG = EXETYP.EQ.DBUG  .OR.  EXETYP.EQ.DBUGME  .OR.  NPRINT.EQ.2
     *     .AND. MASWRK
C
      L1 = NUMNB
      L3 = NUMNB*NUMNB
      L2 = (L3+NUMNB)/2
C
C     SETUP FOR MOROKUMA ANALYSIS
C
      LL1=L1
      LL2=L2
      LL3=L3
C
      IF (MASWRK) WRITE(IW,9000) GUESS
C
      CALL VALFM(LOADFM)
      LLLIM = LOADFM+1
      LIULM = LLLIM + NAT
      LIWRK = LIULM + NAT
      LEIG  = LIWRK + L1
      LLABMO= LEIG  + LL1
      LH    = LLABMO+ L1
      LS    = LH    + LL2
      LVEC  = LS    + LL2
      LVEC2 = LVEC  + LL3
      LSMO  = LVEC2 + LL3
      LQ    = LSMO  + LL3
      LSCR  = LQ    + LL3
      LOCC  = LSCR  + 8*L1
      LAST  = LOCC + L1
C
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
C
C     ----- GENERATE THE INITIAL GUESS NUCLEAR ORBITALS -----
C
      QUICK = EXETYP.EQ.CHECK .AND. GUESS.EQ.GHCK
     *        .AND. .NOT.PRTMO  .AND.  .NOT.PUNMO
      QUICK = QUICK .AND. MPCTYP.EQ.NONE
C
      IF(GUESS.EQ.GHCK) CALL ABRT
      IF(GUESS.EQ.GHCK .AND. INSORB.NE.0) CALL ABRT
      IF(GUESS.EQ.CORE  .OR.  QUICK) CALL ABRT
      IF(GUESS.EQ.SVMO) CALL ABRT
C
C     --- READ NUCLEAR MOS FROM INPUT FILE ---
C
      IF(GUESS.EQ.RDMO) THEN
C
         CALL READMO_NU(NORB,X(LIWRK),X(LEIG),X(LSCR),
     *                  X(LH),X(LQ),X(LVEC),L1,L2,L3,LL2,LL3,DBG)
C
C     --- GET INITIAL NUCLEAR MOS BASED ON CRUDE GUESS OF DENSITY ---
C         (FOR ONE QM NUCLEUS MOS EXACT FOR GIVEN ELEC DENSITY)
C
      ELSE IF(GUESS.EQ.GESDEN) THEN
C
         IF(EXETYP.EQ.CHECK) GOTO 500
C
         CALL NWFGSX
C
      END IF
C
C     ----- GENERATE "CLEAN" MOLECULAR ORBITALS -----
C
      CALL DAREAD(IDAF,IODA,X(LVEC),LL3,444,0)
      CALL CLENMO(X(LVEC),L1,L1,TOLZ,TOLE,IW,DBG)
      CALL DAWRIT(IDAF,IODA,X(LVEC),LL3,444,0)
C
C     ----- HOMO/LUMO MIXING -----
C
      IF (MIX) THEN
         CALL MIXORB(SCFTYP,X(LVEC),L1)
         IF (MASWRK) WRITE(IW,9001)
      END IF
C
  500 CONTINUE
      CALL RETFM(NEED)
C
      RETURN
C
 9000 FORMAT(/1X,'INITIAL GUESS NUCLEAR ORBITALS GENERATED',
     *           ' BY ',A8,' ROUTINE.')
 9001 FORMAT(' HOMO AND LUMO MIXED TO BREAK ALPHA-BETA SYMMETRY')
      END
C
C*MODULE NEO     *DECK GUESS_NMO
      SUBROUTINE GUESS_NMO(GUESVL)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL VALID,MIX,PRTMO,PUNMO,SYMDEN,PURIFY,
     *        GOPARR,DSKWRK,MASWRK
C
      PARAMETER (MXAO=8192)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /NUCMOI/ NUNIQN,IUNIQN(20),IUNIQT(20),NQMNUC,IQMNUC(20),
     *                IQNTYP(20),NUMNB,NUCST,NAUXNB,IAUXNB(20),NUMULT,
     *                NNA,NNB,NTAUXB
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /NEOODR/ IORDER(MXAO),JORDER(MXAO),NORDER
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
C
      PARAMETER (NNAM=13)
      DIMENSION QNAM(NNAM),KQNAM(NNAM)
      DATA GESNMO/8HGESNMO  /
      DATA QNAM/8HGUESS   ,8HNORB    ,8HNORDER  ,8HIORDER  ,8HJORDER  ,
     *          8HTOLZ    ,8HTOLE    ,8HMIX     ,8HPRTMO   ,8HPUNMO   ,
     *          8HSYMDEN  ,8HPURIFY  ,8HINSORB  /
      DATA KQNAM/5,1,1,-1,-1,3,3,0,0,0,0,0,1/
C
      DATA  CORE/8HHCORE   /, RDMO/8HMOREAD  /, SVMO/8HMOSAVED /,
     *     DAFMO/8HMODAF   /, SKIP/8HSKIP    /, HCKL/8HHUCKEL  /,
     *      GMIN/8HMINGUESS/, GEXT/8HEXTGUESS/, RNONE/8HNONE    /,
     *      GESDEN/8HGESDEN  /
C
C     ----- SELECT INITIAL ORBITAL GUESS -----
C
      GUESS = GESDEN
      IF(IREST.GT.0) GUESS=SVMO
      NORB = 0
      NORDER = 0
      DO 210 I = 1,NUMNB
         IORDER(I) = I
         JORDER(I) = I
  210 CONTINUE
      TOLZ=1.0D-08
      TOLE=1.0D-05
      MIX  =.FALSE.
      PRTMO=.FALSE.
      PUNMO=.FALSE.
      SYMDEN = .FALSE.
      PURIFY = .FALSE.
      INSORB = 0
C
C     --- READ THE GUESS INPUT ---
C
      KQNAM(4) = MXAO*10 + 1
      KQNAM(5) = MXAO*10 + 1
      JRET = 0
      CALL NAMEIO(IR,JRET,GESNMO,NNAM,QNAM,KQNAM,
     *            GUESS,NORB,NORDER,IORDER,JORDER,TOLZ,TOLE,MIX,
     *            PRTMO,PUNMO,SYMDEN,PURIFY,INSORB,
     *            0,                      0,0,0,0,0,  0,0,0,0,0,
     *            0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     *            0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0)
      IF(JRET.EQ.2) THEN
         IF (MASWRK) WRITE (IW,900)
         CALL ABRT
         STOP
      END IF
C
      IF(GUESS.EQ.GMIN  .OR.  GUESS.EQ.GEXT) GUESS=HCKL
      VALID=GUESS.EQ.CORE  .OR.  GUESS.EQ.HCKL  .OR.  GUESS.EQ.DAFMO
     * .OR. GUESS.EQ.SKIP  .OR.  GUESS.EQ.RDMO  .OR.  GUESS.EQ.SVMO
     * .OR. GUESS.EQ.GESDEN
      IF(.NOT.VALID) THEN
         IF (MASWRK) WRITE(IW,930) GESNMO
         CALL ABRT
         STOP
      END IF
      IF (MASWRK) WRITE (IW,910) GUESS,NORB,NORDER,  MIX,PRTMO,PUNMO,
     *                           TOLZ,TOLE,   SYMDEN,PURIFY
      IF (MASWRK .AND. INSORB.GT.0)  WRITE(IW,915) INSORB
      GUESVL = GUESS
      CALL FLSHBF(IW)
C
      IF(SCFTYP.EQ.RNONE  .AND.  GUESS.NE.RDMO) THEN
         IF(MASWRK) WRITE(IW,*) 'SCFTYP=NONE REQUIRES GUESS=MOREAD'
         CALL ABRT
         STOP
      END IF
C
      IF(GUESS.EQ.SKIP)  RETURN
      IF(GUESS.EQ.DAFMO) RETURN
      IF(.NOT.MASWRK) PRTMO=.FALSE.
      IF(.NOT.MASWRK) PUNMO=.FALSE.
      CALL GESMEM_NU(NORB,GUESS,TOLZ,TOLE,MIX,PRTMO,PUNMO,INSORB)
C
      IF (MASWRK) WRITE(IW,920)
      CALL TIMIT(1)
      RETURN
C
  900 FORMAT(39H ERROR IN $GESNMO NAMELIST INPUT - STOP )
  910 FORMAT(/10X,24(1H-)/10X,24HNUCLEAR MO GUESS OPTIONS/10X,24(1H-)/
     *        10X,'GUESS =',A8,10X,'NORB  =',I8,10X,'NORDER=',I8/
     *        10X,'MIX   =',L8,10X,'PRTMO =',L8,10X,'PUNMO =',L8/
     *     1P,10X,'TOLZ  =',E8.1,10X,'TOLE  =',E8.1/
     *        10X,'SYMDEN=',L8,10X,'PURIFY=',L8)
  915 FORMAT(10X,7HINSORB=,I8)
  920 FORMAT(1X,'.... END OF INITIAL NUCLEAR ORBITAL SELECTION ....')
  930 FORMAT(/40X,'ERROR IN INITIAL NUCLEAR GUESS OPTION, GUESS =',A8)
      END
C
C*MODULE NEO     *DECK READMO_NU
      SUBROUTINE READMO_NU(NORB,IWRK,EIG,SCR,S,Q,VEC,L1,L2,
     *                  L3,LL2,LL3,DBG)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXAO=8192)
C
      LOGICAL DBG,GOPARR,DSKWRK,MASWRK,SYMNUC
C
      CHARACTER*8 STVEC
C
      DIMENSION IWRK(L1),EIG(L1),SCR(L1,8),S(L2),Q(L3),VEC(L1,L1)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /GVBWFN/ CICOEF(2,12),F(25),ALPHA(325),BETA(325),NO(10),
     *                NCO,NSETO,NOPEN,NPAIR,NMOGVB,NCONF(MXAO),NHAM
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /SYMNEO/ QMTOLN,SYMNUC
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
C
      DATA GVB/8HGVB     /
      DATA GUGA/8HGUGA    /, RMC/8HMCSCF   /
C
 9020 FORMAT(31H NO $VECPRO INPUT FOUND - STOP )
 9040 FORMAT(I2,I3,5E15.8)
 9060 FORMAT(' *** ERROR READING THE MO COEFFICIENTS AT',2I4/
     *       '     THE INPUT VALUES WERE',2I4)
 9080 FORMAT(1X,'YOU FORGOT TO GIVE NORB IN $GUESS')
 9100 FORMAT(' *** ERROR: PREMATURE END OF ORBITAL INPUT ENCOUNTERED'/
     *       '            LOOKING FOR ORBITAL',I4,' ELEMENT',I4)
C
C     ----- READ THE INITIAL ORBITALS FROM THE INPUT FILE -----
C
      IZERO = 0
      IONE  = 1
      ITWO  = 2
C
C     --- GET CANONICAL ORBITALS ---
C
      CALL DAREAD(IDAF,IODA,S,LL2,441,0)
      IF(SYMNUC) THEN
         CALL NUQSYM(S,VEC,Q,EIG,SCR,IWRK,L0,L1,L2,L3,DBG)
      ELSE
         CALL QMATRX(S,Q,EIG,SCR,IWRK,L0,L1,L1,DBG)
      ENDIF
      CALL DAWRIT(IDAF,IODA,Q,LL3,443,0)
C
C     --- DEFAULT FOR NMOS IS THE NUMBER OF OCCUPIED ORBITALS ---
C         OR WHAT THE USER INPUT (NORB)
C
      NSAV = 444
      STVEC = ' $VECPRO'
      NSTM=0
      NUM1=L1
      IF(CITYP.EQ.GUGA  .OR.  SCFTYP.EQ.RMC) NMOS=0
      IF(SCFTYP.EQ.GVB) NMOS = NMOGVB
      IF(NORB.GT.0) NMOS = NORB
C
      IF(NMOS.EQ.0.AND.MASWRK) WRITE(IW,9080)
      IF(NMOS.EQ.0) CALL ABRT
C
C     --- POSITION THE INPUT FILE TO $VEC ---
C
      CALL SEQREW(IR)
      JJ = 0
      ICC = 0
      CALL FNDGRP(IR,STVEC,IEOF)
      IF (IEOF.EQ.0) GO TO 200
C
C     --- $VECPRO CARD NOT FOUND, KILL JOB ---
C
      IF (MASWRK) WRITE(IW,9020)
      CALL ABRT
      STOP
C
C     --- $VECPRO CARD FOUND, READ THE ORBITALS ---
C
  200 CONTINUE
C
      IF (MASWRK) THEN
         DO 280 J = 1,NMOS
            IMAX = 0
            IC = 0
  240       CONTINUE
               IMIN = IMAX+1
               IMAX = IMAX+5
               IC = IC+1
               IF(IMAX .GT. NUM1) IMAX = NUM1
               READ(IR,9040,END=300,ERR=300) JJ,ICC,(VEC(I,J),
     *                                  I=IMIN+NSTM,IMAX+NSTM)
               MODJ=MOD(J,100)
               IF(JJ.EQ.MODJ . AND.  ICC.EQ.IC) GO TO 260
                  WRITE(IW,9060) J,IC,JJ,ICC
                  IF (GOPARR) CALL DDI_BCAST(350,'I',ITWO,1,MASTER)
                  CALL ABRT
                  STOP
  260          CONTINUE
            IF(IMAX .LT. NUM1) GO TO 240
  280    CONTINUE
         IF (GOPARR) CALL DDI_BCAST(350,'I',IZERO,1,MASTER)
C
      ELSE
C        --- SLAVE WORK ---
C
         IF (GOPARR) CALL DDI_BCAST(350,'I',IEND,1,MASTER)
         IF (IEND.EQ.IONE) GO TO 300
         IF (IEND.EQ.ITWO) CALL ABRT
      END IF
C
C     --- GIVE VECTORS TO ALL PROCESSES ---
C
      IF (GOPARR) CALL DDI_BCAST(351,'F',VEC,NMOS*L1,MASTER)
C
C     --- ORTHONORMALIZE THE ORBITALS AND BACK-TRANSFORM THE MO'S ---
C     (FOR NOW WE SKIP THIS FOR NUCLEAR ORBITALS)
C
CSPW  CALL CLENMO(VEC,L1,NMOS,TOLZ,TOLE,IW,DBG)
CSPW  CALL ORTHO(Q,S,VEC,SCR,NMOS,L0,L1,L2,L1)
CSPW  CALL TFSQB(VEC,Q,SCR,L0,L1,L1)
C
C     --- POSSIBLE REORDERING ---
C     (REORDERING NOT NEEDED UNTIL NEO-MCSCF HANDLES LESS THAN
C      FULL NUCLEAR SPACES)
C
CSPW  IF(NORDER.EQ.1) THEN
CSPW     CALL ICOPY(L1,IORDER,1,IWRK,1)
CSPW     CALL REORDR(VEC,IORDER,L1,L1)
CSPW     CALL ICOPY(L1,IWRK,1,IORDER,1)
CSPW     CALL REORDR(EIG,IWRK,L1,1)
CSPW  END IF
C
      CALL DAWRIT(IDAF,IODA,VEC,LL3,NSAV,0)
C
      RETURN
C
C     --- PREMATURE END OF $VEC INPUT ENCOUNTERED ---
C
  300 CONTINUE
      IF (MASWRK) THEN
         IF (GOPARR) CALL DDI_BCAST(350,'I',IONE,1,MASTER)
         WRITE(IW,9100) J,IC
      END IF
      CALL ABRT
      STOP
      END
C
C*MODULE NEO     *DECK NEO_SYMH
      SUBROUTINE NEO_SYMH(F,H,IA,ISTART)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL IANDJ
C
      DIMENSION F(*),H(*),IA(*)
      DIMENSION MI(48)
C
      PARAMETER (MXSH=5000, MXGTOT=20000, MXATM=2000)
C
      COMMON /HSYM  / T(35,35),MINI,MAXI,LIT,MINJ,MAXJ,LJT,NTR
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                TT(432),INVT(48),NT
C
      PARAMETER (ONE=1.0D+00)
C
C     ----- SYMMETRIZE THE SKELETON FOCK MATRIX
C
      IF (NT .EQ. 1) RETURN
C
      L2 = (NUM*NUM+NUM)/2
      CALL VCLR(H,1,L2)
C
C     ----- FIND A BLOCK (I,J)
C
      DO 520 II = ISTART,NSHELL
      DO 140 ITR = 1,NT
         ISH = MAPSHL(II,ITR)
         IF (ISH .GT. II) GO TO 520
         MI(ITR) = ISH
  140 CONTINUE
      LIT = KTYPE(II)
      MINI = KMIN(II)
      MAXI = KMAX(II)
      LOCI = KLOC(II)-MINI
      DO 500 JJ = ISTART,II
      DO 200 ITR = 1,NT
      JSH = MAPSHL(JJ,ITR)
      IF (JSH .GT. II) GO TO 500
      ISH = MI(ITR)
      IF (ISH .GE. JSH) GO TO 180
      N = ISH
      ISH = JSH
      JSH = N
  180 IF (ISH .EQ. II .AND. JSH .GT. JJ) GO TO 500
  200 CONTINUE
      LJT = KTYPE(JJ)
      MINJ = KMIN(JJ)
      MAXJ = KMAX(JJ)
      LOCJ = KLOC(JJ)-MINJ
      IANDJ = II .EQ. JJ
      JMAX = MAXJ
C
C     ----- FIND THE EQUIVALENT BLOCKS -----
C     ----- TRANSFER EQUIVALENT BLOCK INTO T-MATRIX
C     ----- COMPUTE (R) T (R)
C     ----- PUT THE RESULT BACK INTO THE (I,J) BLOCK OF THE H-MATRIX
C
      DO 300 ITR = 1,NT
      NTR = ITR
      KK = MI(ITR)
      LL = MAPSHL(JJ,ITR)
      LOCK = KLOC(KK)-KMIN(KK)
      LOCL = KLOC(LL)-KMIN(LL)
      DO 260 K = MINI,MAXI
      LCK = LOCK+K
      IF (IANDJ) JMAX = K
      DO 260 L = MINJ,JMAX
      IF (LL .GT. KK) GO TO 220
      KL = IA(LCK)+LOCL+L
      GO TO 240
C
  220 KL = IA(LOCL+L)+LCK
  240 T(K,L) = F(KL)
      IF (IANDJ) T(L,K) = F(KL)
  260 CONTINUE
      CALL RHR
      DO 280 I = MINI,MAXI
      LCI = IA(LOCI+I)+LOCJ
      IF (IANDJ) JMAX = I
      DO 280 J = MINJ,JMAX
      IJ = LCI+J
  280 H(IJ) = H(IJ)+T(I,J)
  300 CONTINUE
C
C     ----- FOR EACH BLOCK (K,L) EQUIVALENT TO (I,J)
C     ----- FIND THE TRANSFORMATION THAT MAPS (K,L) INTO (I,J)
C     ----- COMPUTE (R) T (R)
C     ----- PUT THE RESULT BACK INTO THE (K,L) BLOCK OF THE H-MATRIX
C
      DO 480 ITR = 1,NT
      IF (ITR .EQ. 1) GO TO 480
      KK = MI(ITR)
      LL = MAPSHL(JJ,ITR)
      IF (KK .GE. LL) GO TO 320
      K = LL
      L = KK
      GO TO 340
C
  320 K = KK
      L = LL
  340 IF (K .EQ. II .AND. L .EQ. JJ) GO TO 480
      NTR = ITR+1
      IF (NTR .GT. NT) GO TO 400
      DO 380 IT = NTR,NT
      I = MI(IT)
      J = MAPSHL(JJ,IT)
      IF (I .GE. J) GO TO 360
      IJ = I
      I = J
      J = IJ
  360 IF (I .EQ. K .AND. J .EQ. L) GO TO 480
  380 CONTINUE
  400 CONTINUE
      NTR = INVT(ITR)
      DO 420 I = MINI,MAXI
      LCI = IA(LOCI+I)+LOCJ
      IF (IANDJ) JMAX = I
      DO 420 J = MINJ,JMAX
      T(I,J) = H(LCI+J)
      IF (IANDJ) T(J,I) = H(LCI+J)
  420 CONTINUE
      CALL RHR
      LOCK = KLOC(KK)-KMIN(KK)
      LOCL = KLOC(LL)-KMIN(LL)
      DO 460 K = MINI,MAXI
      LCK = LOCK+K
      IF (IANDJ) JMAX = K
      DO 460 L = MINJ,JMAX
      IF (LL .GT. KK) GO TO 440
      KL = IA(LCK)+LOCL+L
      GO TO 460
C
  440 KL = IA(LOCL+L)+LCK
  460 H(KL) = T(K,L)
  480 CONTINUE
  500 CONTINUE
  520 CONTINUE
      DUM = ONE/NT
      DO 540 I = 1,L2
  540 F(I) = H(I)*DUM
      RETURN
      END
