C 14 NOV 05 - DGF - SYNCH ARGS TO PREVS
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 - ADD GUESS=FMO, SYNCHRONISE SYMBLK COMMON BLOCK
C 13 FEB 05 - MWS - PAD COMMON BLOCK NSHEL, ROOT, EDCMP
C  5 FEB 05 - MWS - GUESMO: ZERO SWOFF OPTION IF MOREAD IS CHOSEN
C 19 MAY 04 - DGF - CHANGES TO ADD THE FMO METHOD
C 16 JAN 04 - MWS - HUCKLP: START ON MCP CORE COUNT PROBLEMS (IN)
C  9 DEC 03 - MWS - SYNCH COMMON BLOCK RUNOPT
C  4 NOV 03 - MWS - INIDEN: PRTMO SHOULD PRINT ONLY ON MASTER NODE
C 15 MAY 03 - MWS - READMO: FIX THE OBSCURE CASE OF NORB>L0 GIVEN
C 14 JAN 03 - MWS - INIDEN: CORRECT NOC ARGUMENT FOR RHF DMTX CALL
C 12 DEC 02 - DGF - GUESMO: FIX PARALLEL BUG WITH PRTMO
C 22 MAY 02 - KRG - GENERATE VARIATIONAL DENSITY FOR SYMDEN OPTION
C 24 JAN 02 - MWS - USE NEW CORE COUNTING FUNCTION
C  8 OCT 01 - HL  - NEW GUESS=RDMINI OPTION
C  6 SEP 01 - MWS - ADD DUMMY ARGUMENTS TO NAMEIO CALL
C  1 AUG 01 - JI  - TWEAKS FOR GENERAL CI
C 25 JUN 01 - MWS - ALTER COMMON BLOCK WFNOPT
C 13 JUN 01 - VK,HL - ADZERO,HUKMIX: CORRECTED FOR PARALLEL EXECUTION
C 19 NOV 00 - MWS - PAD OUT EDCMP COMMON BLOCK
C 26 OCT 00 - MWS - USE VARIABLES IN ALL BCAST CALLS
C 11 OCT 00 - MWS - UPDATE THE DETWFN COMMON
C 28 JUL 00 - MWS - OPTION TO PUNCH STARTING ORBS, ORTHOG AFTER ORBPUR
C 10 APR 00 - MWS - REMOVE STATIC MEMORY FROM COSMO COMMONS
C 25 MAR 00 - KKB/LNB - INCLUDE CHARGED SPARKLES FROM COSMO SURFACE
C 16 FEB 00 - VK,RMM - FRZLMX,FRZLMO: RESET NOUTA IF MO-S ARE FROZEN,
C                   GUESMO & READMO: MO FREEZING, NEW INSORB KEYWORD,
C                   HUKMIX & ADZERO: NEW ROUTINES FOR MIXED GUESS
C 18 JAN 00 - MWS - FIX ORBITAL PURIFICATION FOR UHF/ROHF
C 21 DEC 99 - DGF - ORBITAL PURIFICATION ADDED
C  9 APR 99 - MWS - HUCKLM,HUCKLP: CORRECT FOR FULL CORE HW IF ZN,CD,HG
C 13 MAR 99 - MWS - GUESMO,INIDEN: CONVERT SYMDEN INTO INPUT VARIABLE
C 13 FEB 99 - MWS - INIDEN: FIX CALLS TO SYMMOS
C 12 NOV 98 - MAF - COPROJ,HCORE,READMO: ALLOW USE OF SPHER. HARMONICS
C 13 APR 98 - MWS - INIDEN: SAVE ORBITAL SYMMETRY LABELS TO DAF
C 26 MAR 98 - MWS - INIDEN: ONLY SYMMETRIZE DENSITY FOR HUCKEL/HCORE
C 20 NOV 97 - KRG - INIDEN: RHF/UHF/ROHF SYMMETRIZE INITIAL DENSITY
C 28 SEP 97 - MWS - CONVERT PARALLEL CALLS FROM TCGMSG TO DDI
C  8 JAN 97 - KRG - HUCKLM: INCLUDE G COEFS IN COOVLP CALL
C 30 OCT 96 - JAB - GESMEM: DAWRIT AFTER CLENMO TO SAVE CLEANLINESS
C 13 JUN 96 - VAG - INTRODUCE CI TYPE VARIABLE
C  5 MAR 96 - MWS - CHANGE SHELL SYMMETRY PACKING COMMONS
C  9 JAN 95 - WC  - ALLOW READING MONOMER ORBITALS DURING MOROKUMA RUNS
C 14 SEP 95 - MWS - PAD OUT EDCMP COMMON BLOCK
C 26 JUL 95 - MWS - INIDEN: PRINT H-II ELEMENTS FOR UHF/ROHF
C 31 MAY 95 - MWS - HUCKLP: FIX LA VALENCE DEGENERACY
C 24 MAY 95 - MWS - HUCKEL,COOVLP: TWO DIFFERENT BUG FIXES
C 15 MAY 95 - MWS - HUCKEL: FIX FOR DUMMY ATOMS
C 21 APR 95 - MWS - HUCKEL,HUCKLB,HUCKLP: ADAPT TO HW SEMI-CORE TYPE
C 19 APR 95 - JHJ - READMO: IF ZDO SKIP ORTHONORMALIZATION
C  4 MAR 95 - MWS - INIDEN: DON'T DESTROY ANY PREVIOUS EIGENVALUES
C  1 FEB 95 - WC  - USE HCORE FOR EACH MONOMOR OF MOROKUMA ANALYSIS
C 12 NOV 94 - MWS - REMOVE FTNCHEK WARNINGS
C 10 AUG 94 - MWS - INCREASE NUMBER OF DAF RECORDS
C 21 JUN 94 - JHJ - GUESMO: PUT NORDER,IORDER, ETC IN COMMON BLOCK
C 31 MAR 94 - MWS - ADD A VARIABLE TO END OF MACHSW COMMON
C 30 NOV 93 - MWS - HUCKLM: DON'T USE JACOBI DIAG FOR C1 CASES
C  5 AUG 93 - MWS - HUCKEL: USE CORRECT LNEG TABLE FOR LU
C 26 JUN 93 - HS,MWS - HUCKEL: SHIFT ECP CORES TO HIGH POSITIVE ENERGY
C  2 MAY 93 - MWS - READMO: ERR= BRANCH ADDED
C  1 NOV 92 - MWS - HCORE: USE SYMDIA
C  8 SEP 92 - MWS - INIDEN: CHANGE NUMCOR FOR LU AND LR
C 22 JUN 92 - MWS - GUESMO: RETURN TYPE OF GUESS GENERATED TO CALLER
C  7 MAY 92 - MWS - HUCKLM: USE ORTHO TO GENERATE VIRTUAL SPACE
C 23 APR 92 - MWS - REDUCE MEMORY USED BY HUCKEL GUESS
C 12 MAR 92 - MWS - REDIMENSION TO 500 ATOMS
C  2 MAR 92 - JHJ - READMO,GESMEM: HUCKEL AND SKIP ORTHO FOR MPC WFN.
C  1 MAR 92 - MWS - GENERATE SYM -Q- FOR FIRST GUESS OR NEW GEOMETRIES,
C                   CHANGES IN ORBITAL REORDERING (REMOVED FROM HUCKLM)
C 18 JAN 92 - TLW - READMO: ADD BROADCAST CALLS AND FNDGRP CALL
C 14 FEB 92 - JHJ - INIDEN: SKIP CORE CALCULATION.
C 12 FEB 92 - JHJ - HUCKLM: IF MPC WFN CALL MPCHCK.
C 11 JAN 92 - TLW - READMO: MAKE READS PARALLEL
C 10 JAN 92 - TLW - CHANGE REWIND TO CALL SEQREW
C  6 JAN 92 - TLW - MAKE WRITES PARALLEL;ADD COMMON PAR
C  9 DEC 91 - MWS - TO SAVE TIME, CHECK RUNS DO HCORE INSTEAD OF HUCKEL
C 22 SEP 91 - MWS - HUCKLP: DIVIDE TM1 AND ACT2 INITIALIZATIONS UP.
C  1 SEP 91 - MWS - COQMAT: DON'T PROJECT ONTO G FUNCTION SPACE
C                   TSPHAR: CHANGE TRANSFORMATION TO PURE F FUNCTIONS.
C 20 AUG 91 - MWS - GUESS=HUCKEL REPLACES MIN/EXTGUESS
C 11 JUN 91 - TRC - HUCKLP: ADD ORBITAL ENERGIES FOR 6TH AND 7TH ROWS.
C  7 MAY 91 - MWS - CHANGE REMOVAL OF CARTESIAN GAUSSIAN CONTAMINANTS
C 17 APR 91 - MWS - COUNT CORE ORBITALS CORRECTLY IN INIDEN
C  7 NOV 90 - JHJ - GUESMO:IF $BASIS PRESENT, DETERMINE APPROP. GUESS
C  7 AUG 90 - TLW - ADD CF AND CG TO COMMON NSHEL
C 21 DEC 89 - STE - CHANGE INITIALIZATIONS IN HUCKLP
C 16 DEC 89 - MWS - INIDEN: ASSIGN MO SYMMETRIES FOR ALL GUESS TYPES.
C  1 DEC 89 - MWS - HUCKEL,INIDEN: ECP RUNS DO NOT HAVE CORE ORBITALS
C  7 JUL 89 - MWS - CORRECT INIDEN FOR CASE OF NO BETA ELECTRONS.
C 20 MAR 89 - STE - FIX CLENMO CALL IN READMO.
C  9 MAR 89 - STE - REMOVE ORBSET FOR I/O LIST OF 9026 IN INIDEN
C 18 FEB 89 - MWS - SCALE, RATHER THAN ZERO OFF DIAG IN HUCKEL.
C  7 FEB 89 - MWS - FIX BUG WITH REORDERING ROHF ORBITALS, ADD ICOPY,
C                   PRINT MO SYMMETRIES FOR MINGUESS,EXTGUESS,HCORE,
C                   CLENMO BEFORE (AS WELL AS AFTER) ORTHOG. FOR MOREAD.
C 10 AUG 88 - MWS - MXSH,MXGSH,MXGTOT FROM 120,10,440 TO 1000,30,5000
C 30 MAY 88 - MWS - USE PARAMETERS TO DIMENSION COMMON
C 11 MAY 88 - JAM - ADDED HOMO/LUMO MIXING
C 22 APR 88 - MWS - CLENMO CALLED AFTER INITIAL ORBS, INPUT TOLZ,TOLE,
C                   USE /GVBWFN/, INIDEN USES UHF CODE FOR ROHF TYPE.
C 20 MAY 87 - MWS - ALLOW FOR NAKED NUCLEI IN HUCKEL
C  4 MAY 87 - STE - INIDEN: NO REFERENCE TO IA, SCR(L1,8)
C 23 APR 87 - STE - CHANGES TO HCORE,HUCKEL,MOFILE,READMO,TRN5D FOR IA
C  3 NOV 86 - STE - READMO: IMPROVE ERROR HANDLING; PARAMETERS, NO NAV
C 15 AUG 86 - MWS - HALVE TM2 INITIALIZATION TO KEEP IBM HAPPY
C  7 JUL 86 - JAB - SANITIZE FLOATING POINT CONSTANTS
C 17 JUN 86 - MWS - ABORT JOB ON ERROR IN $GUESS INPUT
C  7 NOV 85 - LAM - MAKE ALLOWANCE FOR MORE THAN 100 MOS IN READMO
C 10 OCT 85 - LAM - NAMELIST $GUESS OPTIONAL
C 14 OCT 85 - STE - MOFILE: NB,IPASS UNDEFINED--USE NSAV FOR IPASS
C                   GESMEM: PUT NB IN CALL LIST FOR MOFILE
C                   GUESMO: ALLOW GUESS=MODAF FOR COMPATABILITY
C                   REORDR: USE DSWAP  (INITIALIZE VARIABLES)
C 10 AUG 85 - MWS - COMPLETELY REVISED GUESS SECTION IMPLEMENTED.
C                   GUESS=COSET,NOGEN OPTIONS ELIMINATED.
C                   DYNAMIC MEMORY ALLOCATION ROUTINE ADDED,
C                   ALL GUESS TYPES ALLOW REORDERING AND
C                   INITIAL DENSITY, ROHF DENSITY COMPUTED,
C                   EXTENDED HUCKEL CALCULATION REVAMPED -
C                   NO CORE-CORE OR CORE-VALENCE INTERACTIONS,
C                   ORTHOGONALIZE AFTER DIAGONALIZATION, SPLIT
C                   VALENCE ENERGIES 2/3 AND 1/3 FOR INNER/OUTER,
C                   PARAMETERIZATION EXTENDED TO Z=54.
C*MODULE GUESS   *DECK COOVLP
      SUBROUTINE COOVLP(MODE,SMAT,SMATCO,L1,L1CO,L2,NATM,
     *                  NGAU,NSHL,EX,CS,CP,CD,CF,CG,
     *                  KSTART,KATOM,KTYPE,KNG,KLOC,KMIN,KMAX,
     *                  NGAUCO,NSHLCO,EXCO,CSCO,CPCO,CDCO,CFCO,CGCO,
     *                  KSTRCO,KATMCO,KTYPCO,KNGCO,KLOCCO,KMINCO,
     *                  KMAXCO,C,CCO)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL IANDJ,NORM,DOUBLE
C
      DIMENSION EX(NGAU),CS(NGAU),CP(NGAU),CD(NGAU),
     *          CF(NGAU),CG(NGAU),KSTART(NSHL),KATOM(NSHL),
     *          KTYPE(NSHL),KNG(NSHL),KLOC(NSHL),KMIN(NSHL),KMAX(NSHL),
     *          EXCO(NGAUCO),CSCO(NGAUCO),CPCO(NGAUCO),CDCO(NGAUCO),
     *          CFCO(NGAUCO),CGCO(NGAUCO),KSTRCO(NSHLCO),KATMCO(NSHLCO),
     *          KTYPCO(NSHLCO),KNGCO(NSHLCO),KLOCCO(NSHLCO),
     *          KMINCO(NSHLCO),KMAXCO(NSHLCO),SMAT(L2),SMATCO(L1CO,L1),
     *          C(3,NATM),CCO(3,NATM)
      DIMENSION DIJ(225),XIN(125),YIN(125),ZIN(125),
     *          IX(35),IY(35),IZ(35),JX(35),JY(35),JZ(35),
     *          S(225),IJX(225),IJY(225),IJZ(225)
C
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /ROOT  / XX,U(13),W(13),NROOTS
      COMMON /STV   / XINT,YINT,ZINT,T,X0,Y0,Z0,XI,YI,ZI,XJ,YJ,ZJ,NI,NJ
      COMMON /SYMIND/ TOL,II,JJ,LIT,LJT,MINI,MINJ,MAXI,MAXJ,IANDJ
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00,
     *           SQRT3=1.73205080756888D+00,
     *           SQRT5=2.23606797749979D+00, SQRT7=2.64575131106459D+00,
     *           RLN10=2.30258D+00)
C
      DATA JX / 0, 1, 0, 0, 2, 0, 0, 1, 1, 0,
     *          3, 0, 0, 2, 2, 1, 0, 1, 0, 1,
     *          4, 0, 0, 3, 3, 1, 0, 1, 0, 2,
     *          2, 0, 2, 1, 1/
      DATA IX / 1, 6, 1, 1,11, 1, 1, 6, 6, 1,
     *         16, 1, 1,11,11, 6, 1, 6, 1, 6,
     *         21, 1, 1,16,16, 6, 1, 6, 1,11,
     *         11, 1,11, 6, 6/
      DATA JY / 0, 0, 1, 0, 0, 2, 0, 1, 0, 1,
     *          0, 3, 0, 1, 0, 2, 2, 0, 1, 1,
     *          0, 4, 0, 1, 0, 3, 3, 0, 1, 2,
     *          0, 2, 1, 2, 1/
      DATA IY / 1, 1, 6, 1, 1,11, 1, 6, 1, 6,
     *          1,16, 1, 6, 1,11,11, 1, 6, 6,
     *          1,21, 1, 6, 1,16,16, 1, 6,11,
     *          1,11, 6,11, 6/
      DATA JZ / 0, 0, 0, 1, 0, 0, 2, 0, 1, 1,
     *          0, 0, 3, 0, 1, 0, 1, 2, 2, 1,
     *          0, 0, 4, 0, 1, 0, 1, 3, 3, 0,
     *          2, 2, 1, 1, 2/
      DATA IZ / 1, 1, 1, 6, 1, 1,11, 1, 6, 6,
     *          1, 1,16, 1, 6, 1, 6,11,11, 6,
     *          1, 1,21, 1, 6, 1, 6,16,16, 1,
     *         11,11, 6, 6,11/
C
C     ----- CALCULATE OVERLAP INTEGRALS -----
C     MODE=0 - SYMMETRIC OVERLAP MATRIX FOR ONE BASIS SET, USING
C              THE DATA IN NSHL,EX,...  ALL OF THE CALLING
C              ARGUMENTS NAMED *CO ARE UNUSED IN THIS CASE.
C     MODE=1 - RECTANGULAR OVERLAP MATRIX BETWEEN TWO BASIS SETS.
C              ONLY INTER-BASIS OVERLAPS ARE COMPUTED, FOR THE
C              TWO BASES GIVEN BY NSHL,EX,... AND NSHLCO,EXCO,...
C
      TOL = RLN10*ITOL
      NORM = NORMF.NE.1 .OR. NORMP.NE.1
      CSI = ZERO
      CPI = ZERO
      CDI = ZERO
      CFI = ZERO
      CGI = ZERO
      CSJ = ZERO
      CPJ = ZERO
      CDJ = ZERO
      CFJ = ZERO
      CGJ = ZERO
C
C     ----- I SHELL
C
      IF(MODE.EQ.0) THEN
         IIMAX = NSHL
      ELSE
         IIMAX = NSHLCO
      END IF
C
      DO 720 II = 1,IIMAX
         IF(MODE.EQ.0) THEN
            I = KATOM(II)
            XI = C(1,I)
            YI = C(2,I)
            ZI = C(3,I)
            I1 = KSTART(II)
            I2 = I1+KNG(II)-1
            LIT = KTYPE(II)
            MINI = KMIN(II)
            MAXI = KMAX(II)
            LOCI = KLOC(II)-MINI
         ELSE
            I = KATMCO(II)
            XI = CCO(1,I)
            YI = CCO(2,I)
            ZI = CCO(3,I)
            I1 = KSTRCO(II)
            I2 = I1+KNGCO(II)-1
            LIT = KTYPCO(II)
            MINI = KMINCO(II)
            MAXI = KMAXCO(II)
            LOCI = KLOCCO(II)-MINI
         END IF
C
C     ----- J SHELL
C
         IF(MODE.EQ.0) THEN
            JJMAX = II
         ELSE
            JJMAX = NSHL
         END IF
C
         DO 700 JJ = 1,JJMAX
            J = KATOM(JJ)
            XJ = C(1,J)
            YJ = C(2,J)
            ZJ = C(3,J)
            J1 = KSTART(JJ)
            J2 = J1+KNG(JJ)-1
            LJT = KTYPE(JJ)
            MINJ = KMIN(JJ)
            MAXJ = KMAX(JJ)
            LOCJ = KLOC(JJ)-MINJ
            NROOTS = (LIT+LJT-2)/2+1
            RR = (XI-XJ)**2+(YI-YJ)**2+(ZI-ZJ)**2
            IF(MODE.EQ.0) THEN
               IANDJ = II.EQ.JJ
            ELSE
               IANDJ = .FALSE.
            END IF
C
C     ----- PREPARE INDICES FOR PAIRS OF (I,J) FUNCTIONS
C
            IJ = 0
            MAX = MAXJ
            DO 160 I = MINI,MAXI
               NX = IX(I)
               NY = IY(I)
               NZ = IZ(I)
               IF (IANDJ) MAX = I
               DO 140 J = MINJ,MAX
                  IJ = IJ+1
                  IJX(IJ) = NX+JX(J)
                  IJY(IJ) = NY+JY(J)
                  IJZ(IJ) = NZ+JZ(J)
  140          CONTINUE
  160       CONTINUE
            DO 180 I = 1,IJ
               S(I) = ZERO
  180       CONTINUE
C
C     ----- I PRIMITIVE
C
            JGMAX = J2
            DO 520 IG = I1,I2
               IF(MODE.EQ.0) THEN
                  IF(LIT.LE.2) CSI = CS(IG)
                  IF(LIT.LE.2) CPI = CP(IG)
                  IF(LIT.EQ.3) CDI = CD(IG)
                  IF(LIT.EQ.4) CFI = CF(IG)
                  IF(LIT.EQ.5) CGI = CG(IG)
                  AI = EX(IG)
               ELSE
                  IF(LIT.LE.2) CSI = CSCO(IG)
                  IF(LIT.LE.2) CPI = CPCO(IG)
                  IF(LIT.EQ.3) CDI = CDCO(IG)
                  IF(LIT.EQ.4) CFI = CFCO(IG)
                  IF(LIT.EQ.5) CGI = CGCO(IG)
                  AI = EXCO(IG)
               END IF
               ARRI = AI*RR
               AXI = AI*XI
               AYI = AI*YI
               AZI = AI*ZI
C
C     ----- J PRIMITIVE
C
               IF (IANDJ) JGMAX = IG
               DO 500 JG = J1,JGMAX
                  AJ = EX(JG)
                  AA = AI+AJ
                  AA1 = ONE/AA
                  DUM = AJ*ARRI*AA1
                  IF (DUM .GT. TOL) GO TO 500
                  FAC = EXP(-DUM)
                  IF(LJT.LE.2) CSJ = CS(JG)
                  IF(LJT.LE.2) CPJ = CP(JG)
                  IF(LJT.EQ.3) CDJ = CD(JG)
                  IF(LJT.EQ.4) CFJ = CF(JG)
                  IF(LJT.EQ.5) CGJ = CG(JG)
                  AX = (AXI+AJ*XJ)*AA1
                  AY = (AYI+AJ*YJ)*AA1
                  AZ = (AZI+AJ*ZJ)*AA1
C
C     ----- DENSITY FACTOR
C
                  DOUBLE=IANDJ.AND.IG.NE.JG
                  MAX = MAXJ
                  NN = 0
                  DUM1 = ZERO
                  DUM2 = ZERO
                  DO 220 I = MINI,MAXI
                     IF (I.EQ.1) DUM1=CSI*FAC
                     IF (I.EQ.2) DUM1=CPI*FAC
                     IF (I.EQ.5) DUM1=CDI*FAC
                     IF ((I.EQ.8).AND.NORM) DUM1=DUM1*SQRT3
                     IF (I.EQ.11) DUM1=CFI*FAC
                     IF ((I.EQ.14).AND.NORM) DUM1=DUM1*SQRT5
                     IF ((I.EQ.20).AND.NORM) DUM1=DUM1*SQRT3
                     IF (I.EQ.21) DUM1=CGI*FAC
                     IF ((I.EQ.24).AND.NORM) DUM1=DUM1*SQRT7
                     IF ((I.EQ.30).AND.NORM) DUM1=DUM1*SQRT5/SQRT3
                     IF ((I.EQ.33).AND.NORM) DUM1=DUM1*SQRT3
                     IF (IANDJ) MAX = I
                     DO 200 J = MINJ,MAX
                        IF (J.EQ.1) THEN
                           DUM2=DUM1*CSJ
                           IF (DOUBLE) THEN
                              IF (I.LE.1) THEN
                                 DUM2=DUM2+DUM2
                              ELSE
                                 DUM2=DUM2+CSI*CPJ*FAC
                              END IF
                           END IF
                        ELSE IF (J.EQ.2) THEN
                           DUM2=DUM1*CPJ
                           IF (DOUBLE) DUM2=DUM2+DUM2
                        ELSE IF (J.EQ.5) THEN
                           DUM2=DUM1*CDJ
                           IF (DOUBLE) DUM2=DUM2+DUM2
                        ELSE IF ((J.EQ.8).AND.NORM) THEN
                           DUM2=DUM2*SQRT3
                        ELSE IF (J.EQ.11) THEN
                           DUM2=DUM1*CFJ
                           IF (DOUBLE) DUM2=DUM2+DUM2
                        ELSE IF ((J.EQ.14).AND.NORM) THEN
                           DUM2=DUM2*SQRT5
                        ELSE IF ((J.EQ.20).AND.NORM) THEN
                           DUM2=DUM2*SQRT3
                        ELSE IF (J.EQ.21) THEN
                           DUM2=DUM1*CGJ
                           IF (DOUBLE) DUM2=DUM2+DUM2
                        ELSE IF ((J.EQ.24).AND.NORM) THEN
                           DUM2=DUM2*SQRT7
                        ELSE IF ((J.EQ.30).AND.NORM) THEN
                           DUM2=DUM2*SQRT5/SQRT3
                        ELSE IF ((J.EQ.33).AND.NORM) THEN
                           DUM2=DUM2*SQRT3
                        END IF
                        NN = NN+1
                        DIJ(NN) = DUM2
  200                CONTINUE
  220             CONTINUE
C
C      ----- DO OVERLAP INTEGRAL -----
C
                  T = SQRT(AA1)
                  X0 = AX
                  Y0 = AY
                  Z0 = AZ
                  IN = -5
                  DO 320 I = 1,LIT
                     IN = IN+5
                     NI = I
                     DO 300 J = 1,LJT
                        JN = IN+J
                        NJ = J
                        CALL STVINT
                        XIN(JN) = XINT*T
                        YIN(JN) = YINT*T
                        ZIN(JN) = ZINT*T
  300                CONTINUE
  320             CONTINUE
                  DO 340 I = 1,IJ
                     NX = IJX(I)
                     NY = IJY(I)
                     NZ = IJZ(I)
                     S(I) = S(I)+DIJ(I)*XIN(NX)*YIN(NY)*ZIN(NZ)
  340             CONTINUE
C
C     ----- END PRIMITIVES -----
C
  500          CONTINUE
  520       CONTINUE
C
C     ----- STORE THE OVERLAPS FOR THESE SHELLS -----
C
            MAX = MAXJ
            NN = 0
            DO 620 I = MINI,MAXI
               LI = LOCI+I
               IN = (LI*LI-LI)/2
               IF (IANDJ) MAX = I
               DO 600 J = MINJ,MAX
                  NN = NN+1
                  IF(MODE.EQ.0) THEN
                     JN = IN+LOCJ+J
                     SMAT(JN) = S(NN)
                  ELSE
                     LJ = LOCJ + J
                     SMATCO(LI,LJ) = S(NN)
                  END IF
  600          CONTINUE
  620       CONTINUE
C
C     ----- END SHELLS -----
C
  700    CONTINUE
  720 CONTINUE
      RETURN
      END
C*MODULE GUESS   *DECK COPROJ
      SUBROUTINE COPROJ(VB,SBA,VA,VACO,WRK,D,S,SCR,EIG,IWRK,
     *                  NDOC,NACT,NPROJ,L1,L1CO,L1M,L2,IW,DBG)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL DBG,GOPARR,DSKWRK,MASWRK
C
      DIMENSION VB(L1CO,NPROJ),SBA(L1CO,L1),VA(L1,L1),VACO(L1,L1),
     *          WRK(L1,L1),D(NPROJ,L1M),S(L2),SCR(L1,8),EIG(L1),
     *          IWRK(L1)
C
      PARAMETER (ZERO=0.0D+00)
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C     ----- CORRESPONDING ORBITAL PROJECTION -----
C     -NPROJ- ORBITALS FROM -VB- WILL BE PROJECTED ONTO THE FIRST
C     -L1M- ORBITALS WITHIN THE -VA- ORBITAL SPACE.
C     -VA- AND -VB- CONTAIN THE -A- AND -B- ORBITALS ON ENTRY,
C     -SBA- CONTAINS THE OVERLAP INTEGRALS BETWEEN THE TWO BASES,
C     -VB-, AND -SBA- WILL BE UNCHANGED ON EXIT, -VA- IS REPLACED
C     BY THE CORRESPONDING ORBITALS.  THE CORRESPONDING ORBITALS
C     IN THE -B- BASIS ARE NOT GENERATED.
C
C     H.F.KING, R.E.STANTON, H.KIM, R.E.WYATT, R.G.PARR
C     J.CHEM.PHYS. 47, 1936-1941 (1967)
C
      IF(DBG) THEN
         WRITE(IW,*) 'ENTERED COPROJ'
         WRITE(IW,*) 'THE -B- ORBITALS ARE'
         CALL PRSQ(VB,NPROJ,L1CO,L1CO)
         WRITE(IW,*) 'THE -SBA- MATRIX IS'
         CALL PRSQ(SBA,L1,L1CO,L1CO)
      END IF
C
C        VB-DAGGER * SBA
C
      DO 230 J=1,L1
         DO 220 I=1,NPROJ
            DUM = ZERO
            DO 210 K=1,L1CO
               DUM = DUM + VB(K,I)*SBA(K,J)
  210       CONTINUE
            WRK(I,J) = DUM
  220    CONTINUE
  230 CONTINUE
C
C     ----- PROJECT CORE, ACTIVE, AND VIRTUAL SPACES SEPARATELY -----
C
      DO 700 IPASS=1,3
C
C        DETERMINE RANGE OF MOS TO BE PROJECTED
C
         MINMO=1
         MAXMO=NDOC
         IF(IPASS.EQ.2) THEN
            MINMO=NDOC+1
            MAXMO=NDOC+NACT
         END IF
         IF(IPASS.EQ.3) THEN
            MINMO=NDOC+NACT+1
            MAXMO=NPROJ
         END IF
C
C        PROJECT ONTO THE REMAINING ORBITAL SPACE ONLY
C
         NREST= L1M-MINMO+1
         NMO  = MAXMO-MINMO+1
         IF(NREST.LE.0) GO TO 700
         IF(NMO.EQ.0) GO TO 700
C
         IF(DBG) THEN
            WRITE(IW,9010) NDOC,NACT,NPROJ,
     *                     IPASS,MINMO,MAXMO,NMO,NREST
            WRITE(IW,*) 'THE -A- ORBITALS ARE'
            CALL PRSQ(VA,L1M,L1,L1)
         END IF
C
C        D = (VB-DAGGER*SAB) * VA
C
         DO 290 I=MINMO,MAXMO
            DO 270 J=MINMO,L1M
               DUM = ZERO
               DO 260 K=1,L1
                  DUM = DUM + WRK(I,K)*VA(K,J)
  260          CONTINUE
               D(I+1-MINMO,J+1-MINMO) = DUM
  270       CONTINUE
  290    CONTINUE
C
         IF(DBG) THEN
            WRITE(IW,*) 'OVERLAP BETWEEN THE -B- AND -A- ORBITALS IS'
            CALL PRSQ(D,NREST,NMO,NPROJ)
         END IF
C
C        D-DAGGER * D
C
         IJ = 0
         DO 330 I=1,NREST
            DO 320 J=1,I
               IJ = IJ + 1
               DUM = ZERO
               DO 310 K=1,NMO
                  DUM = DUM + D(K,I)*D(K,J)
  310          CONTINUE
               S(IJ) = DUM
  320       CONTINUE
  330    CONTINUE
C
         IF(DBG) THEN
            WRITE(6,*) 'D-DAGGER*D IS'
            CALL PRTRI(S,NREST)
         END IF
C
C        DIAGONALIZE D-DAGGER * D
C
         CALL GLDIAG(L1,NREST,NREST,S,SCR,EIG,VACO,IERR,IWRK)
         IF(IERR.NE.0) THEN
            IF (MASWRK) WRITE(IW,*)
     *            'UNABLE TO DIAGONALIZE IN COPROJ'
            CALL ABRT
            STOP
         END IF
C
C        EIGENVALUES RUN 0 TO 1, WE WANT THE HIGHEST ONES FIRST.
C
         DO 400 I=1,NREST
            IWRK(I) = NREST+1-I
  400    CONTINUE
         CALL REORDR(VACO,IWRK,NREST,L1)
C
         DO 410 I=1,NREST
            IWRK(I) = NREST+1-I
  410    CONTINUE
         CALL REORDR(EIG,IWRK,NREST,1)
C
C        THE NEAR ZERO OVERLAP PART OF THE SPACE GETS SCRAMBLED
C        IN THE ABOVE DIAGONALIZATION, WE CAN GET A SYMMETRY
C        ADAPTED SPACE BY GRAM-SCHMIDT INSTEAD.
C
         CALL SCHMD(VACO,NMO,NREST,L1)
         IF(DBG) THEN
            WRITE(6,*) 'ORTHOGONALIZED CORR. ORB. TRANSFORMATION'
            CALL PREVNL(VACO,EIG,NREST,NREST,L1)
         END IF
C
C        ROTATE VA TO CORRESPONDING ORBITAL SET, A'=A*V,
C
         CALL TFSQB(VACO,VA(1,MINMO),EIG,NREST,L1,L1)
C
C        GET OVERLAP BETWEEN -B- AND THE -A'- CORRESPONDING SET,
C        D = (VB-DAGGER*SAB) * VACO
C
         DO 590 I=MINMO,MAXMO
            DO 570 J=1,NMO
               DUM = ZERO
               DO 560 K=1,L1
                  DUM = DUM + WRK(I,K)*VACO(K,J)
  560          CONTINUE
               EIG(J) = DUM
  570       CONTINUE
            DO 580 J=1,NMO
               WRK(I,J) = EIG(J)
  580       CONTINUE
  590    CONTINUE
C
C        PERMUTE -A'- SET TO MAXIMUM OVERLAP WITH -B- SET
C
         DO 640 I=1,NMO
            SMAX = ZERO
            IWRK(I) = 0
            II=I+MINMO-1
            DO 630 J=1,NMO
               DO 610 K=1,I
                  IF(IWRK(K).EQ.J) GO TO 630
  610          CONTINUE
               SS = ABS(WRK(II,J))
               IF(SS.GT.SMAX) THEN
                  SMAX = SS
                  IWRK(I) = J
               END IF
  630       CONTINUE
  640    CONTINUE
         CALL REORDR(VACO,IWRK,NMO,L1)
C
C        COPY PROJECTED ORBITALS BACK TO END OF VA
C
         CALL DCOPY(NREST*L1,VACO,1,VA(1,MINMO),1)
  700 CONTINUE
      RETURN
C
 9010 FORMAT(1X,'PROJECTING WITH NDOC,NACT,NPROJ=',3I5/
     *       1X,'ON PASS',I4,' MINMO,MAXMO,NMO,NREST=',4I5)
      END
C*MODULE GUESS   *DECK COQMAT
      SUBROUTINE COQMAT(Q,TSH,WRK,H,S,SCR,EIG,IWRK,L1M,L1,L2,L3)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL NOTSP
C
      DIMENSION Q(L1,L1),TSH(L1,L1),WRK(L1,L1),H(L2),S(L2),
     *          SCR(L1,8),EIG(L1),IWRK(L1)
C
      PARAMETER (MXGTOT=20000, MXSH=5000)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
C
      PARAMETER (ZERO=0.0D+00)
C
C     ----- GET ORTHONORMAL ORBITAL SPACE -----
C     ON EXIT, THE FIRST -L1M- FUNCTIONS IN -Q- WILL CONTAIN
C     NO CONTAMINANT FUNCTIONS, THE REMAINING ORBITALS IN -Q-
C     WILL BE THE XX+YY+ZZ... FUNCTION SPACE.
C     FOR A SP BASIS, THIS IS A CONVENTIONAL Q-MATRIX CALCULATION.
C
C        GET TRANSFORMATION TO SPHERICAL HARMONICS.
C
      CALL TSPHAR(TSH,L1,L1M,NOTSP,KTYPE,KLOC,NSHELL)
C
C        MOVE CONTAMINANT AOS TO HIGH END OF -TSH-
C
      IF(NOTSP) THEN
         IAO =1
         ILOW=1
         ITOP=L1
         DO 130 N=1,NSHELL
            IMIN=KMIN(N)
            IMAX=KMAX(N)
C                       MOVE S CONTAMINANT IN D SHELL
            IF(KTYPE(N).EQ.3) THEN
               IMIN=IMIN+1
               IWRK(ITOP)=IAO
               IAO = IAO+1
               ITOP=ITOP-1
            END IF
C                       MOVE P CONTAMINANT IN F SHELL
            IF(KTYPE(N).EQ.4) THEN
               IMIN=IMIN+3
               IWRK(ITOP  )=IAO+2
               IWRK(ITOP-1)=IAO+1
               IWRK(ITOP-2)=IAO
               IAO = IAO+3
               ITOP=ITOP-3
            END IF
C                       MOVE ALL OF A G SHELL
            IF(KTYPE(N).EQ.5) THEN
               IMIN=IMIN+15
               DO 110 KK=1,15
                  IWRK(ITOP+1-KK) = IAO+15-KK
  110          CONTINUE
               IAO = IAO+15
               ITOP=ITOP-15
            END IF
            DO 120 II=IMIN,IMAX
               IWRK(ILOW)=IAO
               IAO=IAO+1
               ILOW=ILOW+1
  120       CONTINUE
  130    CONTINUE
         CALL REORDR(TSH,IWRK,L1,L1)
      END IF
C
C        ----- GENERATE SYMMETRY ADAPTED CANONICAL ORBITALS -----
C        THIS IS DONE IN -WRK, AS HERE -Q- IS USED AS SCRATCH STORAGE
C
      CALL DAREAD(IDAF,IODA,S,L2,12,0)
      CALL QMTSYM(S,Q,WRK,EIG,SCR,IWRK,L0,L1,L2,L3,.FALSE.)
      CALL DAWRIT(IDAF,IODA,WRK,L3,45,0)
C
      IF(NOTSP) THEN
         CALL DAREAD(IDAF,IODA,S,L2,12,0)
         CALL TFTRI(H,S,TSH,SCR,L1,L1,L1)
         L1MP=L1M+1
         DO 230 I=L1MP,L1
            II = (I*I+I)/2
            H(II) = 100.0D+00
            DO 220 J=1,L1M
               IJ = (I*I-I)/2 + J
               H(IJ) = ZERO
  220       CONTINUE
  230    CONTINUE
         CALL TRPOSQ(TSH,L1)
         CALL TFTRI(S,H,TSH,SCR,L1,L1,L1)
         CALL GLDIAG(L1,L1,L1,S,SCR,EIG,Q,IERR,IWRK)
         CALL DAREAD(IDAF,IODA,S,L2,12,0)
         CALL ORTHO(WRK,S,Q,SCR,L0,L0,L1,L2,L1)
         CALL TFSQB(Q,WRK,SCR,L0,L1,L1)
      ELSE
         CALL DCOPY(L3,WRK,1,Q,1)
      END IF
      RETURN
      END
C*MODULE GUESS   *DECK GESMEM
      SUBROUTINE GESMEM(NORB,GUESS,NORDER,IORDER,JORDER,
     *                  TOLZ,TOLE,MIX,PRTMO,PUNMO,SYMDEN,PURIFY,INSORB)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL DBG,MIX,PRTMO,PUNMO,SYMDEN,PURIFY,QUICK,
     *        GOPARR,DSKWRK,MASWRK,READ
      DOUBLE PRECISION MOROKM
C
      DIMENSION IORDER(*),JORDER(*)
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 /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,CITYP,DFTYPE,CCTYP,MPLEVL,MPCTYP
C
      DATA UHF/8HUHF     /, MOROKM/8HMOROKUMA/
      DATA CORE/8HHCORE   /, GHCK/8HHUCKEL  /,FRAGMO/8HFMO     /
      DATA RDMO/8HMOREAD  /, SVMO/8HMOSAVED /, RDMINI/8HRDMINI  /
      DATA DBUG/8HDEBUG   /, DBUGME/8HGUESS   /
      DATA CHECK/8HCHECK   /
      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=NUM
      L3=NUM*NUM
      L2=(L3+NUM)/2
C
C     SETUP FOR MOROKUMA ANALYSIS
C
      NA1 = NA
      LL1=L1
      LL2=L2
      LL3=L3
C
C     IF RUNTYP = MOROKM, SOME PARAMETERS NEED TO BE OVERWRITTEN
C
      IF (RUNTYP.EQ.MOROKM) CALL STGUSS(NA1,L1,L2,L3,GUESS,NORDER)
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
      LIWRK  = LOCC  + L1
      LAST  = LIWRK + L1
C
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
C
C        ----- GENERATE THE INITIAL GUESS ORBITALS -----
C
      QUICK = EXETYP.EQ.CHECK .AND. GUESS.EQ.GHCK
     *        .AND. .NOT.PRTMO  .AND.  .NOT.PUNMO
      QUICK = QUICK .AND. MPCTYP.NE.NONE
C
      READ = .FALSE.
      IF(GUESS.EQ.RDMINI) READ = .TRUE.
C
      IF(GUESS.EQ.GHCK .OR. GUESS.EQ.RDMINI)
     *       CALL HUCKLM(X(LLLIM),X(LIULM),
     *            X(LEIG),X(LH),X(LS),X(LVEC),X(LQ),X(LSCR),
     *            X(LIWRK),NAT,L1,L2,L3,DBG,QUICK,NEED,READ)
      IF(GUESS.EQ.GHCK .AND. INSORB.NE.0)
     *       CALL HUKMIX(INSORB,X(LIWRK),X(LSMO),X(LEIG),X(LSCR),
     *            X(LH),X(LQ),X(LVEC),X(LVEC2),L1,L2,L3,LL2,LL3,
     *            DBG,TOLZ,TOLE)
      IF(GUESS.EQ.CORE  .OR.  QUICK)
     *       CALL HCORE(SCFTYP,X(LIWRK),X(LEIG),X(LH),X(LS),
     *            X(LVEC),X(LQ),X(LSCR),L1,L2,L3,LL2,LL3,DBG)
      IF(GUESS.EQ.RDMO)
     *       CALL READMO(NORB,X(LIWRK),X(LEIG),X(LSCR),
     *            X(LH),X(LQ),X(LVEC),L1,L2,L3,LL2,LL3,MIX,
     *            DBG,TOLZ,TOLE)
      IF(GUESS.EQ.SVMO)
     *       CALL MOFILE(SCFTYP,X(LIWRK),X(LEIG),X(LSCR),
     *            X(LH),X(LQ),X(LVEC),L1,L2,L3,DBG,NB)
      IF(GUESS.EQ.FRAGMO) THEN
             CALL MOFRG(SCFTYP,X(LIWRK),X(LEIG),X(LSCR),
     *            X(LH),X(LQ),X(LVEC),L1,L2,L3,DBG,NB)
             GOTO 1000
      ENDIF
C
C        ----- GENERATE "CLEAN" MOLECULAR ORBITALS -----
C
      CALL DAREAD(IDAF,IODA,X(LVEC),LL3,15,0)
      CALL CLENMO(X(LVEC),L1,L1,TOLZ,TOLE,IW,DBG)
      CALL DAWRIT(IDAF,IODA,X(LVEC),LL3,15,0)
      IF(SCFTYP.EQ.UHF) THEN
         CALL DAREAD(IDAF,IODA,X(LVEC),LL3,19,0)
         CALL CLENMO(X(LVEC),L1,L1,TOLZ,TOLE,IW,DBG)
         CALL DAWRIT(IDAF,IODA,X(LVEC),LL3,19,0)
      END IF
C
C        ----- HOMO/LUMO MIXING -----
C
      IF (MIX) THEN
         CALL MIXORB(SCFTYP,X(LVEC),L1)
         IF (MASWRK) WRITE(IW,9001)
      END IF
C
C        ----- GENERATE INITIAL DENSITY MATRIX -----
C
      LDA = LH
      LDB = LS
      CALL INIDEN(GUESS,X(LVEC),X(LDA),X(LDB),X(LEIG),
     *            X(LOCC),X(LLABMO),X(LIWRK),X(LQ),X(LSCR),X(LS),
     *            NORDER,IORDER,JORDER,L1,L2,L3,DBG,PRTMO,PUNMO,
     *            SYMDEN,PURIFY,NA1,1,LL1,LL2,LL3)
 1000 CONTINUE
      CALL RETFM(NEED)
C
      RETURN
C
 9000 FORMAT(/1X,'INITIAL GUESS ORBITALS GENERATED BY ',A8,' ROUTINE.')
 9001 FORMAT(' HOMO AND LUMO MIXED TO BREAK ALPHA-BETA SYMMETRY')
      END
C*MODULE GUESS   *DECK GUESMO
      SUBROUTINE GUESMO(GUESVL)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL VALID,MIX,PRTMO,PUNMO,SYMDEN,PURIFY,MFRZ,
     *        GOPARR,DSKWRK,MASWRK
C
      PARAMETER (MXATM=2000, MXAO=8192)
C
      COMMON /DFGRID/ DFTTHR,DFTGTHR,SWOFF,SW0,NDFTFG,
     *                NRAD,NTHE,NPHI,NRAD0,NTHE0,NPHI0
      COMMON /GSSORD/ IORDER(MXAO),JORDER(MXAO),NORDER
      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 /MFRPAR/ MFRZ,NUMFRZ,IFRZ(MXAO)
      COMMON /OPTLOC/ CVGLOC,MAXLOC,IPRTLO,ISYMLO,IFCORE,NOUTA,NOUTB,
     *                MOOUTA(MXAO),MOOUTB(MXAO)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PRPOPT/ ILOCAL
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /WFNOPT/ SCFTYP,CITYP,DFTYPE,CCTYP,MPLEVL,MPCTYP
C
      PARAMETER (NNAM=13)
      DIMENSION QNAM(NNAM),KQNAM(NNAM)
      DATA SGUESS/8HGUESS   /
      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    /,
     *      RDMINI/8HRDMINI  /,FRAGMO/8HFMO     /
C
C        ----- SELECT INITIAL ORBITAL GUESS -----
C
      GUESS = HCKL
      IF(IREST.GT.0) GUESS=SVMO
      NORB = 0
      NORDER = 0
      DO 210 I = 1,NUM
         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,SGUESS,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.RDMINI .OR. GUESS.EQ.FRAGMO
      IF(.NOT.VALID) THEN
         IF (MASWRK) WRITE(IW,930) GUESS
         CALL ABRT
         STOP
      END IF
C
C         NO NEED FOR PRELIMINARY HF ITERATIONS AT FIRST DFT GEOMETRY
C         IF WE ARE BEING GIVEN DECENT ORBITALS ALREADY.
      IF(GUESS.EQ.RDMO  .OR.  GUESS.EQ.DAFMO  .OR.
     *   GUESS.EQ.SVMO) SWOFF=0.0D+00
C
      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
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
C     READ THE $MOFRZ GROUP
C
      CALL MFRZIN
      IF(MFRZ .AND. GUESS.NE.RDMO .AND. INSORB.EQ.0) THEN
         IF(MASWRK) WRITE(IW,*)'MFRZ REQUIRES GUESS=MOREAD'
         CALL ABRT
         STOP
      END IF
C
      IF(GUESS.EQ.SKIP)  RETURN
      IF(GUESS.EQ.DAFMO) RETURN
      CALL GESMEM(NORB,GUESS,NORDER,IORDER,JORDER,
     *            TOLZ,TOLE,MIX,PRTMO,PUNMO,SYMDEN,PURIFY,INSORB)
C
C   IF SOME ORBITALS ARE FROZEN, THE NOUTA (LMO PARAMETER) HAVE TO BE
C   MODIFIED SINCE THE FROZEN ORBITALS GO FIRST, AS WELL AS CORES.
C   IT WAS IMPOSSIBLE TO DO THAT DURING LMOINP BECAUSE THE FROZEN
C   ORBITALS WERE UNKNOWN TO THE PROGRAM AT THAT TIME.
C   ALSO, FRZLMX IS CALLED ONLY WHEN THERE IS NO EXPLICIT
C   INPUT OF MOOUTA ARRAY IN $LOCAL. IF MOOUTA IS THERE IN $LOCAL,
C   USER APPARENTLY TOOK PAINS OF DETERMINING IT HIMSELF/HERSELF.
C
      IF(MFRZ .AND. ILOCAL.NE.0 .AND. (IFCORE.NE.0 .OR. NOUTA.EQ.0))
     *       CALL FRZLMX
      IF (MASWRK) WRITE(IW,920)
      CALL TIMIT(1)
      RETURN
C
  900 FORMAT(39H ERROR IN $GUESS NAMELIST INPUT - STOP )
  910 FORMAT(/10X,13(1H-)/10X,13HGUESS OPTIONS/10X,13(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 ORBITAL SELECTION ......')
  930 FORMAT(/40H ERROR IN INITIAL GUESS OPTION, GUESS = ,A8)
      END
C*MODULE GUESS   *DECK HCORE
      SUBROUTINE HCORE(SCFTYP,IWRK,EIG,H,H0,VEC,Q,SCR,L1,L2,L3,
     *                 LL2,LL3,DBG)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL DBG
C
      DIMENSION IWRK(L1),EIG(L1),H(L2),H0(LL2),VEC(LL3),Q(LL3),SCR(L1,8)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
C
      DATA UHF/8HUHF      /
C
C     ----- OBTAIN INITIAL ORBITALS BY DIAGONALIZATION OF THE
C           ONE ELECTRON HAMILTONIAN MATRIX -----
C
C
C           OBTAIN TRANSFORMATION -Q- TO ORTHONORMAL, SYMMETRY
C           ADAPTED ORBITALS BY DIAGONALIZING THE OVERLAP MATRIX.
C
      CALL DAREAD(IDAF,IODA,H0,LL2,12,0)
      CALL QMTSYM(H0,VEC,Q,EIG,SCR,IWRK,L0,L1,L2,L3,DBG)
      CALL DAWRIT(IDAF,IODA,Q,LL3,45,0)
C
C           READ IN BARE NUCLEUS HAMILTONIAN MATRIX H0
C           FOCK TRANSFORMATION H=Q*H0*Q
C           DIAGONALIZE THE BLOCK DIAGONAL H MATRIX
C           BACK TRANSFORM THE EIGENVECTORS
C
      CALL DAREAD(IDAF,IODA,H0,LL2,11,0)
      CALL TFTRI(H,H0,Q,SCR,L0,L1,L1)
      CALL SYMDIA(H,VEC,EIG,SCR,IWRK,L0,L2,L1)
      CALL TFSQB(VEC,Q,SCR,L0,L1,L1)
C
C           SAVE VECTORS ON THE DAF
C
      CALL DAWRIT(IDAF,IODA,VEC,LL3,15,0)
      IF(SCFTYP.EQ.UHF) CALL DAWRIT(IDAF,IODA,VEC,LL3,19,0)
      RETURN
      END
C*MODULE GUESS   *DECK HUCKEL
      SUBROUTINE HUCKEL(LLIM,IULIM,IA,EIG,H,S,WRK,VEC,TSH,Q,SCR,
     *                  IWRK,DBG,MXGAU,MXSHL,EX,CS,CP,CD,CF,
     *                  KSTART,KATOM,KTYPE,KNG,KLOC,KMIN,KMAX,
     *                  L1CO,L2CO,L3CO,NGAUCO,NSHLCO,L1MCO,NATM,
     *                  NCELHW)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL DBG,NOTSP,NOTECP,GOPARR,DSKWRK,MASWRK
C
      DIMENSION IA(L1CO),EIG(L1CO),TSH(L3CO),H(L2CO),S(L2CO),
     *          WRK(L2CO),VEC(L3CO),Q(L3CO),SCR(L1CO,8),IWRK(L1CO),
     *          EX(MXGAU),CS(MXGAU),CP(MXGAU),CD(MXGAU),CF(MXGAU),
     *          KSTART(MXSHL),KATOM(MXSHL),KTYPE(MXSHL),KNG(MXSHL),
     *          KLOC(MXSHL),KMIN(MXSHL),KMAX(MXSHL),
     *          LLIM(NATM),IULIM(NATM),NCELHW(104)
      DIMENSION ENEG(18),LNEG(66,6),NDVAL(4)
C
      PARAMETER (MXATM=2000)
C
C     COSMO CHANGES
C
      COMMON /ECP2  / CLP(400),ZLP(400),NLP(400),KFIRST(MXATM,6),
     *                KLAST(MXATM,6),LMAX(MXATM),LPSKIP(MXATM),
     *                IZCORE(MXATM)
      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
C
C     COSMO CHANGES
C
      LOGICAL ISEPS, USEPS
      COMMON /ISEPS/ ISEPS, USEPS
C
      PARAMETER (ZERO=0.0D+00, TWO=2.0D+00, ONEPT5=1.5D+00,
     *           BITSY=0.05D+00)
C
C               ORDER OF BASIS FUNCTIONS MUST BE EXACTLY
C        1S,2S,2P,3S,3P,3D,4S,4P,4D, 5S,5P,5D,6S,6P    FOR  H-LA
C        1S,2S,2P,3S,3P,3D,4S,4P,4D, 5S,5P,4F,5D,6S    FOR CE-YB
C        1S,2S,2P,3S,3P,3D,4S,4P,4D, 4F,5S,5P,5D,6S,6P FOR LU-RN
C        .........................4F,5S,5P,5D,6S,6P,7S FOR FR-RA
C        ......................4F,5S,5P,5D,6S,6P,6D,7S FOR AC-TH
C        ...................4F,5S,5P,5D,6S,6P,5F,6D,7S FOR PA-LR
C
      DATA LNEG/1,  2,3*3,  4,3*5,6*6,  7,3*8,6*9,  10,3*11,6*12,
     *              13,3*14,  27*0,
     *          1,  2,3*3,  4,3*5,6*6,  7,3*8,6*9,
     *              10,3*11,10*12,6*13,  14, 20*0,
     *          1,  2,3*3,  4,3*5,6*6,  7,3*8,6*9,
     *              10*10,11,3*12,6*13,  14,3*15, 17*0,
     *          1,  2,3*3,  4,3*5,6*6,  7,3*8,6*9,10*10,
     *             11,3*12,6*13, 14,3*15, 16, 16*0,
     *          1,  2,3*3,  4,3*5,6*6,  7,3*8,6*9,10*10,
     *             11,3*12,6*13, 14,3*15, 6*16, 17, 10*0,
     *          1,  2,3*3,  4,3*5,6*6,  7,3*8,6*9,10*10,
     *             11,3*12,6*13, 14,3*15, 10*16,  6*17, 18 /
C
C     ----- CARRY OUT AN EXTENDED HUCKEL CALCULATION -----
C     ROUTINE WRITTEN BY MIKE SCHMIDT AT NDSU, AUG. 2, 1985.
C     MODIFIED IN JULY 1991 TO COMPUTE THE GUESS IN A MINIMAL
C     HUZINAGA BASIS SET, WHICH SHOULD BE PROJECTED ONTO THE
C     CURRENT BASIS SET.
C
      NCORE = 0
      NVAL = 0
C
C           COMPUTE THE MINIMAL BASIS SET OVERLAP MATRIX
C
      CALL COOVLP(0,S,DUMMY,L1CO,L1CO,L2CO,NATM,NGAUCO,NSHLCO,
     *            EX,CS,CP,CD,CF,DUMMY,KSTART,KATOM,KTYPE,KNG,
     *            KLOC,KMIN,KMAX,1,1,DUMMY,DUMMY,DUMMY,DUMMY,
     *            DUMMY,DUMMY,DUMMY,DUMMY,DUMMY,DUMMY,DUMMY,
     *            DUMMY,DUMMY,C,C)
C
C           OBTAIN CANONICAL ORTHONORMAL MO-S
C
      CALL DCOPY(L2CO,S,1,H,1)
      CALL QMATRX(H,Q,EIG,SCR,IA,L0,L1CO,L1CO,DBG)
C
      DO 180 I=1,L1CO
         IA(I)=(I*I-I)/2
  180 CONTINUE
C
C           SET LOWER AND UPPER BASIS FUNCTIONS ON EACH ATOM
C
      IAT=0
      DO 210 I=1,NSHLCO
         KAT = KATOM(I)
         IF(KAT.GT.IAT) THEN
            IAT=IAT+1
            DO 200 J=IAT,KAT
               LLIM(J) = KLOC(I)
               IF(J.GT.1) IULIM(J-1) = LLIM(J) - 1
  200       CONTINUE
            IAT=KAT
         END IF
  210 CONTINUE
      IULIM(IAT) = L1CO
C              HANDLE ANY BASISLESS DUMMY ATOMS AT THE END
      IAT=IAT+1
      DO 220 I=IAT,NAT
C
C     COSMO CHANGES - KIM, PUT IN BY VOLKER OCT.1998
C
         IF(ISEPS) GOTO 220
C
         IF(ZAN(I).NE.ZERO) THEN
            IF (MASWRK) WRITE(IW,*)
     *                  'DUMMY ATOM',I,' HAS NONZERO CHARGE!'
            IF (MASWRK) WRITE(IW,9010)
     *                  (II,LLIM(II),IULIM(II),II=1,NAT)
            CALL ABRT
            STOP
         END IF
         LLIM(I) = IULIM(I-1)+1
         IULIM(I) = L1CO
  220 CONTINUE
      IF(DBG) WRITE(IW,9010) (I,LLIM(I),IULIM(I),I=1,NAT)
C
C        TRANSFORM THE OVERLAP MATRIX TO SPHERICAL HARMONICS.
C
      CALL TSPHAR(TSH,L1CO,L1MCO,NOTSP,KTYPE,KLOC,NSHLCO)
      IF(NOTSP) THEN
         CALL TFTRI(H,S,TSH,SCR,L1CO,L1CO,L1CO)
      ELSE
         CALL DCOPY(L2CO,S,1,H,1)
      END IF
C
C        CONSTRUCT HUCKEL MATRIX -H-, ON TOP OF THE OVERLAP MATRIX
C
      DO 390 N=1,NAT
         NUCZ = INT(ZAN(N)) + IZCORE(N)
         IF(NUCZ.EQ.0) GO TO 390
         NOTECP = IZCORE(N).NE.NCELHW(NUCZ)
         CALL HUCKLP(IW,NUCZ,ENEG,NCORE,NVAL,NDVAL,NOTECP,NCECP)
C
         KIND = 1
         IF(NUCZ.GE.58  .AND.  NUCZ.LE.71)  KIND=2
         IF(NUCZ.GE.72  .AND.  NUCZ.LE.86)  KIND=3
         IF(NUCZ.GE.87  .AND.  NUCZ.LE.88)  KIND=4
         IF(NUCZ.GE.89  .AND.  NUCZ.LE.90)  KIND=5
         IF(NUCZ.GE.91  .AND.  NUCZ.LE.103) KIND=6
C
C                 SET CORE ORBITAL ENERGIES.
C
         I0=LLIM(N) - 1
         IF(NCORE.EQ.0) GO TO 340
C
C        COUNT ANY CORE ORBITALS REMOVED BY ECP, ADDING APPROPRIATE
C        NUMBER OF EXTRA FUNCTIONS DUE TO USE OF 6D AND 10F FUNCTIONS
C
         IC = IZCORE(N)/2 - NCECP
         IF(NOTECP) THEN
            NEXTRA = 0
            IF(IC.GT.50) NEXTRA = NEXTRA + 3
            IF(IC.GT.34) NEXTRA = NEXTRA + 1
            IF(IC.GT.23) NEXTRA = NEXTRA + 3
            IF(IC.GT.18) NEXTRA = NEXTRA + 1
            IF(IC.GT. 9) NEXTRA = NEXTRA + 1
         ELSE
            NEXTRA = 0
         END IF
         IC = IC+NEXTRA
C
C        IF A CORE ORBITAL IS BEING REMOVED BY USE OF A ECP,
C        THAT ORBITAL IS ASSIGNED A POSITIVE ENERGY INSTEAD
C
         DO 320 I=1,NCORE
            IROW=I0+I
            II=IA(IROW)+IROW
            ECORE=ENEG(LNEG(I+NCECP,KIND))
            IF(I.LE.IC) THEN
               H(II) = -ECORE
            ELSE
               H(II) =  ECORE
            END IF
            IWRK(IROW)=1
  320    CONTINUE
C
C                 SET VALENCE ORBITAL ENERGIES.
C
  340    CONTINUE
         I0 = LLIM(N)+NCORE-1
         J0 = 0
         DO 360 J=1,NVAL
            IVAL = NDVAL(J)
            DO 350 I=1,IVAL
               IROW=I0+I
               II=IA(IROW)+IROW
               EVAL =ENEG(LNEG(NCORE+NCECP+J0+I,KIND))
               H(II)=EVAL
               IWRK(IROW) = 2
  350       CONTINUE
            I0 = I0+IVAL
            J0 = J0+IVAL
  360    CONTINUE
C
         NEXTRA=IULIM(N)-I0
C
C     COSMO CHANGES - KIM, PUT IN BY VOLKER OCT.1998
C
         IF(ISEPS) GOTO 390
C
         IF(NEXTRA.NE.0) THEN
            IF(MASWRK) THEN
               WRITE(IW,9030) N,NUCZ,KIND,NCORE,NVAL,(NDVAL(M),M=1,NVAL)
               WRITE(IW,9040) NCECP,NOTECP,LLIM(N),IULIM(N),NEXTRA
            END IF
            CALL ABRT
            STOP
         END IF
  390 CONTINUE
C
C        LEVEL SHIFT ANY S CONTAMINANT IN D SHELLS AWAY
C        LEVEL SHIFT ANY P CONTAMINANT IN F SHELLS AWAY
C
      DO 430 N=1,NSHLCO
         IAT  = KATOM(N)
         NUCZ = INT(ZAN(IAT)) + IZCORE(IAT)
         IF(KTYPE(N).EQ.3) THEN
            I3S = KLOC(N)
            II3S = IA(I3S) + I3S
            H(II3S) = 50.0D+00 + NUCZ
            IWRK(I3S) = 3
         END IF
         IF(KTYPE(N).EQ.4) THEN
            DO 410 I=1,3
               I4P = KLOC(N) + I - 1
               II4P = IA(I4P) + I4P
               H(II4P) = 50.0D+00 + NUCZ
               IWRK(I4P) = 3
  410       CONTINUE
         END IF
  430 CONTINUE
C
C        IF WE HAVE TWO SETS OF D'S ON THE SAME ATOM, WE NEED
C        TO INCREASE THE XX-YY/XX-YY AND XX+YY-2ZZ/XX+YY-2ZZ
C        OVERLAP BY 3/2 TO MAKE THEM EQUAL TO THE XY/XY TYPE
C        OVERLAP, AND THEREFORE PRESERVE 5-FOLD DEGENERACY.
C
      DO 530 M=1,NSHLCO
         IF(KTYPE(M).EQ.3) THEN
            IAT = KATOM(M)
            ILOC = KLOC(M)
            NMAX = M-1
            DO 510 N=1,NMAX
               IF(KATOM(N).NE.IAT) GO TO 510
               IF(KTYPE(N).NE.3  ) GO TO 510
               JLOC = KLOC(N)
               ID1 = IA(ILOC+1)+JLOC+1
               ID2 = IA(ILOC+2)+JLOC+2
               H(ID1) = ONEPT5*H(ID1)
               H(ID2) = ONEPT5*H(ID2)
  510       CONTINUE
         END IF
C
C                 THE FACTORS IN HERE ARE PROBABLY NOT CORRECT.
C                 THIS MATTERS FOR ACTINIDES ONLY (2 OCC F'S).
C
C--         IF(KTYPE(M).EQ.4) THEN
C--            IAT = KATOM(M)
C--            ILOC = KLOC(M)
C--            NMAX = M-1
C--            DO 520 N=1,NMAX
C--               IF(KATOM(N).NE.IAT) GO TO 520
C--               IF(KTYPE(N).EQ.4) THEN
C--                  JLOC = KLOC(N)
C--                  ID1 = IA(ILOC+3)+JLOC+3
C--                  ID2 = IA(ILOC+4)+JLOC+4
C--                  ID3 = IA(ILOC+5)+JLOC+5
C--                  H(ID1) = 1.2741D+00*H(ID1)
C--                  H(ID2) = 1.2741D+00*H(ID2)
C--                  H(ID3) = 1.2741D+00*H(ID3)
C--                  ID1 = IA(ILOC+6)+JLOC+6
C--                  ID2 = IA(ILOC+7)+JLOC+7
C--                  ID3 = IA(ILOC+8)+JLOC+8
C--                  H(ID1) = ONEPT5*H(ID1)
C--                  H(ID2) = ONEPT5*H(ID2)
C--                  H(ID3) = ONEPT5*H(ID3)
C--               END IF
C--  520       CONTINUE
C--         END IF
  530 CONTINUE
C
C        SCALE DOWN ALL OFF-DIAGONAL AND CORE-CORE OVERLAPS TO
C        REDUCE THE AMOUNT OF MIXING OF THESE FUNCTIONS.
C        IWRK=1,2,3 MEANS CORE,VALENCE,CONTAMINANT FUNCTIONS.
C
      LOC=0
      DO 630 I=1,L1CO
         II = IWRK(I)
         DO 620 J=1,I
            LOC=LOC+1
            IF(I.EQ.J) GO TO 620
            JJ = IWRK(J)
            IF(II.NE.JJ .OR. (II.EQ.1.AND.JJ.EQ.1)) H(LOC)=BITSY*H(LOC)
            IF(II.EQ.3 .OR. JJ.EQ.3) THEN
               IF(II.NE.JJ) H(LOC)=ZERO
               IF(II.EQ.JJ) H(LOC)=BITSY*BITSY*H(LOC)
            END IF
  620    CONTINUE
  630 CONTINUE
C
C           FINISH UP THE OFF-DIAGONAL OF THE HUCKEL OPERATOR
C
      FUDGE = 1.75D+00/TWO
      II = 1
      IJ = 1
      DO 720 I=2,L1CO
         II = II + I
         HII=H(II)
         JJ = 0
         DO 710 J=1,I-1
            JJ = JJ + J
            IJ = IJ + 1
            SIJ = H(IJ)
            H(IJ)=FUDGE*SIJ*(HII+H(JJ))
  710    CONTINUE
         IJ = IJ + 1
  720 CONTINUE
C
      IF(DBG) THEN
         WRITE(IW,9020)
         CALL PRTRI(H,L1CO)
      END IF
C
C           BACKTRANSFORM HUCKEL MATRIX TO CARTESIAN GAUSSIANS
C
      IF(NOTSP) THEN
         CALL TRPOSQ(TSH,L1CO)
         CALL TFTRI(WRK,H,TSH,SCR,L1CO,L1CO,L1CO)
         CALL DCOPY(L2CO,WRK,1,H,1)
         IF(DBG) THEN
            WRITE(IW,*) 'HUCKEL OPERATOR IN CARTESIAN SPACE'
            CALL PRTRI(H,L1CO)
         END IF
      END IF
C
C           DIAGONALIZE THE HUCKEL OPERATOR
C
      IERR = 0
      CALL GLDIAG(L1CO,L1CO,L1CO,H,SCR,EIG,VEC,IERR,IA)
      IF(IERR.NE.0) THEN
         IF (MASWRK) WRITE(IW,*)
     *               'UNABLE TO DIAGONALIZE HUCKEL MATRIX'
         CALL ABRT
         STOP
      END IF
C
C         ORTHONORMALIZE, AND BACKTRANSFORM TO THE AO BASIS
C
      CALL ORTHO(Q,S,VEC,SCR,L1CO,L1CO,L1CO,L2CO,L1CO)
      CALL TFSQB(VEC,Q,SCR,L1CO,L1CO,L1CO)
      CALL CLENMO(VEC,L1CO,L1CO,1.0D-06,1.0D-05,IW,.FALSE.)
      IF(DBG) THEN
         WRITE(IW,*) 'EXTENDED HUCKEL ORBITALS (IN MINI BASIS) ARE'
         CALL PREVNL(VEC,EIG,L1CO,L1CO,L1CO)
      END IF
      RETURN
C
 9010 FORMAT(1X,'ATOM',I5,'  HAS LLIM=',I5,'  IULIM=',I5)
 9020 FORMAT(/1X,'EXTENDED HUCKEL MATRIX')
 9030 FORMAT(//1X,'CONFUSION IN -HUCKEL- WITH ATOM=',I4,
     *       1X,'NUCZ=',I4,' KIND=',I2/
     *       1X,'NCORE,NVAL=',2I4,' NDVAL=',4I4)
 9040 FORMAT(1X,'NCECP=',I4,' NOTECP=',L2/
     *       1X,'LLIM,IULIM=',2I4,' NEXTRA=',I4,' NEXTRA SHOULD BE 0'//)
      END
C*MODULE GUESS   *DECK HUCKLB
      SUBROUTINE HUCKLB(KSTART,KATOM,KTYPE,KNG,KLOC,KMIN,KMAX,
     *                  EX,CS,CP,CD,CF,CSINP,CPINP,CDINP,CFINP,
     *                  NS,INTYP,MXGAU,MXSHL,NATM,
     *                  L1CO,L2CO,L3CO,NGAUCO,NSHLCO,NCELHW)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,ISEPS,USEPS
C
      DIMENSION INTYP(NATM),NS(NATM),EX(MXGAU),
     *          CS(MXGAU),CP(MXGAU),CD(MXGAU),CF(MXGAU),
     *          CSINP(MXGAU),CPINP(MXGAU),CDINP(MXGAU),CFINP(MXGAU),
     *          KSTART(MXSHL),KATOM(MXSHL),KTYPE(MXSHL),KNG(MXSHL),
     *          KLOC(MXSHL),KMIN(MXSHL),KMAX(MXSHL),NCELHW(104)
      DIMENSION NBFS(4),MINF(4),MAXF(4),NANGM(4),SCFAC(4)
C
      PARAMETER (MXATM=2000)
C
      COMMON /ECP2  / CLP(400),ZLP(400),NLP(400),KFIRST(MXATM,6),
     *                KLAST(MXATM,6),LMAX(MXATM),LPSKIP(MXATM),
     *                IZCORE(MXATM)
      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 /ISEPS/ ISEPS, USEPS
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C     COSMO INFORMATION
C
      PARAMETER (NPPA=1082)
      COMMON /COSMO1/ SE2,SECORR,ETOTS,CDUM,QVCOSMO,
     *                CSPOT(NPPA),ICORR,ITRIPO,ITRIP2,ITRIP3,ITRIP4,
     *                NATCOS,NQS,ITERC
C
      DATA NBFS/ 1, 3, 6,10/
      DATA MINF/ 1, 2, 5,11/
      DATA MAXF/ 1, 4,10,20/
      DATA NANGM/1, 2, 3, 4/
      DATA SCFAC/4*0.0D+00/
C
C     ----- SET UP A HUZINAGA MINI BASIS SET ON THE FLY -----
C     IF POSSIBLE, USE A MBS ECP BASIS FOR EVERY ECP ATOM.
C     BESIDES SETTING UP THE DETAILS IN EX, CS, AND SO ON, AND THE
C     DIMENSIONALITY IS RETURNED IN L1CO,L2CO,L3CO,NGAUCO,NSHLCO
C
      IERR1  = 0
      IERR2  = 0
      L1CO   = 0
      NSHLCO = 0
      NGAUCO = 0
C
C     COSMO SUBTRACTS -NQS- FOR UNKNOWN REASONS (TO MWS, ANYWAY)
C
      NATSV = NAT
      IF(ISEPS  .AND.  NQS.GT.0) NATSV = NAT - NQS
C
      DO 120 N=1,NATSV
         NAT  = N
         NUCZ = INT(ZAN(N)) + IZCORE(N)
         IF(NUCZ.LE.0) GO TO 120
         IF(IZCORE(N).NE.NCELHW(NUCZ)) THEN
            CALL BASHUZ(NUCZ,.FALSE.,CSINP,CPINP,CDINP,CFINP,
     *                  SCFAC,IERR1,IERR2,INTYP,NANGM,NBFS,MINF,MAXF,
     *                  L1CO,NGAUCO,NS,EX,CS,CP,CD,CF,KSTART,KATOM,
     *                  KTYPE,KNG,KLOC,KMIN,KMAX,NSHLCO,MXGAU,MXSHL)
         ELSE
            CALL HWBAS(1,NUCZ,CSINP,CPINP,CDINP,IERR1,IERR2,
     *                 INTYP,NANGM,NBFS,MINF,MAXF,L1CO,NGAUCO,NS,
     *                 EX,CS,CP,CD,KSTART,KATOM,KTYPE,KNG,KLOC,
     *                 KMIN,KMAX,NSHLCO,MXGAU,MXSHL)
         END IF
         IF(IERR1.NE.0) THEN
            IF (MASWRK) WRITE(IW,*)
     *                  'TOO MANY SHELLS IN HUCKEL BASIS'
            CALL ABRT
            STOP
         END IF
         IF(IERR2.NE.0) THEN
            IF (MASWRK) WRITE(IW,*)
     *                  'TOO MANY GAUSSIANS IN HUCKEL BASIS'
            CALL ABRT
            STOP
         END IF
  120 CONTINUE
C
      NAT = NATSV
      L2CO = (L1CO*L1CO+L1CO)/2
      L3CO = L1CO*L1CO
      RETURN
      END
C*MODULE GUESS   *DECK HUCKLM
      SUBROUTINE HUCKLM(LLIM,IULIM,EIG,H,S,VEC,Q,SCR,
     *                  IWRK,NATM,L1,L2,L3,DBG,QUICK,NEED1,READ)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DOUBLE PRECISION METHOD
C
      LOGICAL DBG,QUICK,GOPARR,DSKWRK,MASWRK
      LOGICAL CANONC,FCORE,FORS,NOCI,EKT,LINSER,READ
C
      PARAMETER (MXGTOT=20000, MXSH=5000, MXATM=2000, MXRT=100,
     *           MXAO=8192, MXNORO=250)
C
      DIMENSION LLIM(NATM),IULIM(NATM),IWRK(L1),EIG(L1),H(L2),S(L2),
     *          VEC(L3),Q(L3),SCR(L1,8)
      DIMENSION NCELHW(104)
C
      COMMON /DETWFN/ WSTATE(MXRT),SPINS(MXRT),CRIT,PRTTOL,SDET,SZDET,
     *                GRPDET,STSYM,GLIST,
     *                NFLGDM(MXRT),IWTS(MXRT),NCORSV,NCOR,NACTDT,NORBDT,
     *                NADET,NBDET,KDET,KSTDET,IROOT,IPURES,MAXW1,NITDET,
     *                MAXP,NCIDET,IGPDET,KSTSYM,NFTGCI
      COMMON /ECP2  / CLP(400),ZLP(400),NLP(400),KFIRST(MXATM,6),
     *                KLAST(MXATM,6),LMAX(MXATM),LPSKIP(MXATM),
     *                IZCORE(MXATM)
      COMMON /FMCOM / X(1)
      COMMON /FMODIM/ MAXBND,MAXKND,MAXCBS,MAXCAO,MAXVEC,MAXL1,
     *                MAXNAT,MAXABD,MAXBAS
      COMMON /FMOINF/ NFG,NLAYER,NATFMO,NBDFG,NAOTYP,NBODY
      COMMON /FMOOPT/ ESPSCA(9),RESPAP(2),RESPPC(2),RESDIM,RESTRI(4),
     *                RCORSD,CONVFG,CNVDMP,COROFF,IXESP,MXITFG,NGUESS,
     *                NBSSE,MODORB,MODPAR,IRSTSTP,IRSTLAY,NPRFMO,
     *                NFMOPAL,MODPRP,MAXL1C
      COMMON /FMOPNT/ LICHFG,LMULFG,LIDMREC,LFRGNAM,LLAYFRG,LINDAT,
     *                LNCBS,LFMOZAN,LFMOC,LIZBAS,LIAGLOB,LIBDGH,LIABDFG,
     *                LJABDFG,LNCAO,LIDXCAO,LIAPRJO,LJAPRJO,LCOREAO,
     *                LOCCCOR,LSHIFTB,LIODFMO,LFMODA,LFMODB,LFMOESPA,
     *                LFMOESPB,LLOCFMO,LSCFFRG,LRIJ,LPOPMUL,LPOPMAT,
     *                LIALOC,LINDBD,LIATFRG,LINDFRG,LINDGFRG,LNATFRG,
     *                LNAT0FRG,LIANFRG,LZANFRG,LCFRG,LLIBISH,LLIBNSH,
     *                LLIBNG,LINDATG,LFMOBUF(2),LFMODE,LNUMFRG,LLOCTAT,
     *                LIAOGLOB,LLOADM,LFMOGE,LDGRID,LIODCFMO
      COMMON /GUGWFN/ NFZC,NMCC,NMCDOC,NAOS,NBOS,NALP,NVAL,NEXT,NFZV,
     *                IFORS,IEXCIT,ICICI,NOIRR
      COMMON /GVBWFN/ CICOEF(2,12),F(25),ALPHA(325),BETA(325),NO(10),
     *                NCO,NSETO,NOPEN,NPAIR,NORB,NCONF(MXAO),NHAM
      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 /MACHSW/ KDIAG,ICORFL,IXDR
      COMMON /MCINP / METHOD,CISTEP,ACURCY,ENGTOL,DAMP,MICIT,NWORD,
     *                NORBMC,NOROT(2,MXNORO),MOFRZ(15),NPFLG(10),
     *                NOFO,MCFMO,CANONC,FCORE,FORS,NOCI,EKT,LINSER
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(432),INVT(48),NT
      COMMON /WFNOPT/ SCFTYP,CITYP,DFTYPE,CCTYP,MPLEVL,MPCTYP
C
C         THE NUMBER OF CORE ELECTRONS REMOVED BY HW BASIS
C         FIRST NINE TM'S ARE SEMI-CORE, THESE DON'T EXIST ZN,CD,HG
C         ALL OTHER ELEMENTS ARE FULL CORE
C
      DATA NCELHW/  -1,                   -1,
     *            2*-1,                 6*-1,
     *            2*10,                 6*10,
     *            2*18,         9*10,-1,6*28,
     *            2*36,         9*28,-1,6*46,
     *            2*54,46,14*-1,8*60,-1,3*78,21*-1/
C
      DATA RHF,UHF,ROHF/8HRHF     ,8HUHF     ,8HROHF    /
      DATA GVB,RMC /8HGVB     ,8HMCSCF   /
      DATA ALDET,GUGA,GENCI/8HALDET   ,8HGUGA    ,8HGENCI   /
      DATA NONE/4HNONE/
C
C     ----- MEMORY DRIVER FOR HUCKEL INITIAL GUESS -----
C
C     ----- WE USE A SPECIAL ROUTINE FOR MOPAC WFN -----
C
      IF(MPCTYP.NE.NONE) THEN
         CALL DAREAD(IDAF,IODA,S,L2,12,0)
         CALL QMTSYM(S,VEC,Q,EIG,SCR,IWRK,L0,L1,L2,L3,DBG)
         CALL DAWRIT(IDAF,IODA,Q,L3,45,0)
         CALL MPCHCK(H,EIG,SCR,VEC,SCFTYP,DBG,IWRK,L1,L2)
         RETURN
      END IF
C
C     USE JACOBI DIAGONALIZATION, IT AVOIDS SCRAMBLING
C     ORBITAL SYMMETRIES DURING MINI AND 3-21G RUNS.
C
      KDSAVE = KDIAG
      IF(NT.GT.1) KDIAG = 3
C
      NCORE = 0
      DO 100 N=1,NAT
         NUCZ = INT(ZAN(N)) + IZCORE(N)
         IF(NCELHW(NUCZ).NE.IZCORE(N)) NCORE = NCORE + IZCORE(N)
  100 CONTINUE
      NCORE = NCORE/2
C
C     ----- SET UP THE HUZINAGA MINIMAL BASIS SET -----
C     LR (Z=103) HAS 18 OCCUPIED SHELLS, AND MOST OF THE TIME
C     A MINI BASIS HAS 3 GAUSSIANS PER SHELL.
C
      NATM  = NAT
      MXSHL = NAT*18
      MXGAU = MXSHL*3
C
      CALL VALFM(LOADFM)
      LEX    = LOADFM + 1
      LCS    = LEX    + MXGAU
      LCP    = LCS    + MXGAU
      LCD    = LCP    + MXGAU
      LCF    = LCD    + MXGAU
      LCSINP = LCF    + MXGAU
      LCPINP = LCSINP + MXGAU
      LCDINP = LCPINP + MXGAU
      LCFINP = LCDINP + MXGAU
      LKSTAR = LCFINP + MXGAU
      LKATOM = LKSTAR + MXSHL
      LKTYPE = LKATOM + MXSHL
      LKNG   = LKTYPE + MXSHL
      LKLOC  = LKNG   + MXSHL
      LKMIN  = LKLOC  + MXSHL
      LKMAX  = LKMIN  + MXSHL
      LNS    = LKMAX  + MXSHL
      LINTYP = LNS    + NATM
      LAST   = LINTYP + NATM
      NEED2  = LAST - LOADFM - 1
      CALL GETFM(NEED2)
C
      CALL HUCKLB(X(LKSTAR),X(LKATOM),X(LKTYPE),X(LKNG),X(LKLOC),
     *            X(LKMIN),X(LKMAX),X(LEX),X(LCS),X(LCP),X(LCD),X(LCF),
     *            X(LCSINP),X(LCPINP),X(LCDINP),X(LCFINP),
     *            X(LNS),X(LINTYP),MXGAU,MXSHL,NATM,
     *            L1CO,L2CO,L3CO,NGAUCO,NSHLCO,NCELHW)
C
      CALL VALFM(LOADFM)
      LIA    = LOADFM + 1
      LEIG   = LIA    + L1CO
      LIWRK  = LEIG   + L1CO
      LSCR   = LIWRK  + L1CO
      LH     = LSCR   + L1CO*8
      LS     = LH     + L2CO
      LVEC   = LS     + L2CO
      LWRK1  = LVEC   + L3CO
      LWRK2  = LWRK1  + MAX(L3CO,L3)
      LWRK3  = LWRK2  + MAX(L3CO,L3)
      LSCO   = LWRK3  + L3CO
      LAST   = LSCO   + L1CO*L1
C
      LDD    = LAST
      LROTLCAO= LAST
      IF(NFG.NE.0.AND.NBDFG.NE.0) THEN
        LDD    = LAST
        LROTLCAO= LDD+(MAXCBS*MAXCBS+MAXCBS)/2
        LAST=LROTLCAO+MAXCBS*MAXCAO
      ENDIF
C
      NEED3 = LAST-LOADFM-1
C
      NEEDT = NEED1 + NEED2 + NEED3
      IF (MASWRK) WRITE(IW,9020) NEEDT
C
      CALL GETFM(NEED3)
      IF(QUICK) THEN
         IF (MASWRK) WRITE(IW,9010)
         GO TO 800
      END IF
C
C        EXTENDED HUCKEL CALCULATION IN MINI BASIS SET
C
      CALL HUCKEL(LLIM,IULIM,X(LIA),X(LEIG),X(LH),X(LS),X(LWRK1),
     *            X(LVEC),X(LWRK2),X(LWRK3),X(LSCR),X(LIWRK),
     *            DBG,MXGAU,MXSHL,X(LEX),X(LCS),X(LCP),
     *            X(LCD),X(LCF),X(LKSTAR),X(LKATOM),
     *            X(LKTYPE),X(LKNG),X(LKLOC),X(LKMIN),X(LKMAX),
     *            L1CO,L2CO,L3CO,NGAUCO,NSHLCO,L1MCO,NATM,NCELHW)
C
C        READ IN VEC
C
      IF(READ) CALL RDMIMO(X(LVEC),L1CO)
C
C
C        GET OVERLAP BETWEEN THE MINI AND INPUT BASIS SETS
C
      CALL COOVLP(1,DUMMY,X(LSCO),L1,L1CO,L2,NATM,MXGTOT,NSHELL,
     *            EX,CS,CP,CD,CF,CG,KSTART,KATOM,KTYPE,KNG,
     *            KLOC,KMIN,KMAX,NGAUCO,NSHLCO,X(LEX),X(LCS),X(LCP),
     *            X(LCD),X(LCF),DUMMY,X(LKSTAR),X(LKATOM),X(LKTYPE),
     *            X(LKNG),X(LKLOC),X(LKMIN),X(LKMAX),C,C)
C
C        GET "PURE" CANONICAL ORBITALS IN INPUT BASIS SPACE
C
      CALL COQMAT(Q,X(LWRK2),X(LWRK1),H,S,SCR,EIG,IWRK,L1M,L1,L2,L3)
C
C        DETERMINE WHICH ORBITALS SHOULD BE PROJECTED
C
      NDOC=0
      NACT=0
      IF(SCFTYP.EQ.RHF) THEN
         NDOC=NA
         NACT=0
      END IF
      IF(SCFTYP.EQ.UHF  .OR.  SCFTYP.EQ.ROHF) THEN
         NDOC=NB
         NACT=NA-NB
      END IF
      IF(SCFTYP.EQ.GVB) THEN
         NDOC=NCO
         NACT=NORB-NCO
      END IF
      IF(SCFTYP.EQ.RMC) THEN
         IF(CISTEP.EQ.ALDET  .OR.  CISTEP.EQ.GENCI) THEN
            NDOC=NCORSV
            NACT=NACTDT
         END IF
         IF(CISTEP.EQ.GUGA) THEN
            NDOC=NMCC
            NACT=NMCDOC+NALP+NAOS+NBOS+NVAL
         END IF
         IF (MASWRK) WRITE(IW,9000) SCFTYP
      END IF
C
C                  DO AT MOST 5 VIRTUALS FROM THE HUCKEL
      NPROJ=MIN(L1MCO-NCORE,NDOC+NACT+5)
C
C        PROJECT MINI GUESS ONTO THE INPUT CANONICAL ORBITALS
C        THIS RETURNS THE PROJECTED ORBITALS IN -Q- ARRAY
C
      CALL COPROJ(X(LVEC),X(LSCO),Q,X(LWRK1),X(LWRK2),
     *            X(LWRK3),S,SCR,EIG,IWRK,NDOC,NACT,NPROJ,
     *            L1,L1CO,L1M,L2,IW,DBG)
C
C        GENERATE THE REMAINING VIRTUALS BY ORTHOGONALIZATION
C
      CALL DCOPY(L1*NPROJ,Q,1,VEC,1)
      CALL DAREAD(IDAF,IODA,S,L2,12,0)
      CALL DAREAD(IDAF,IODA,Q,L3,45,0)
      CALL ORTHO(Q,S,VEC,SCR,NPROJ,L1,L1,L2,L1)
      CALL TFSQB(VEC,Q,SCR,L1,L1,L1)
C
C     PROJECT OUT BOND HMO FOR FMO
C
      IF(NFG.NE.0.AND.NBDFG.NE.0.AND.MOD(NGUESS/4,2).EQ.1) THEN
C        WRITE(6,*) 'VECS BEFORE',L1
C        CALL PRSQ(VEC,L1,L1,L1)
C        SINCE SAVEH IS FALSE, Q IS NOT USED AND MAY BE DUMMY
C        IWRK1 IS USED AS REAL, NOT INTEGER BUFFER OF L1 IN FMOHOP.
         CALL FMOHOP(L1,L2,VEC,S,X(LWRK1),Q,X(LDD),SCR,X(LWRK2),IWRK1,
     *               X(LIABDFG),X(LJABDFG),X(LIDXCAO),X(LIAGLOB),
     *               X(LNCBS),X(LNCAO),X(LIAPRJO),X(LJAPRJO),X(LSHIFTB),
     *               X(LCOREAO),X(LFMOC),X(LROTLCAO),X(LLOCFMO),NSHELL,
     *               KATOM,KTYPE,KLOC,KMIN,.FALSE.)
C        WRITE(6,*) 'VECS AFTER',NPROJ
C        CALL PRSQ(VEC,L1,L1,L1)
C        PROJECTION CREATES SOME LINEARLY DEPENDENT VIRTUAL ORBITALS
C        SO WE REGENERATE VIRTUAL SPACE.
         CALL ORTHO(Q,S,VEC,SCR,NPROJ,L1,L1,L2,L1)
         CALL TFSQB(VEC,Q,SCR,L1,L1,L1)
C        CALL PRSQ(VEC,L1,L1,L1)
      ENDIF
C
      CALL DAWRIT(IDAF,IODA,VEC,L3,15,0)
      IF(SCFTYP.EQ.UHF) CALL DAWRIT(IDAF,IODA,VEC,L3,19,0)
C
  800 CONTINUE
      CALL RETFM(NEED3)
      CALL RETFM(NEED2)
      KDIAG = KDSAVE
      RETURN
C
 9000 FORMAT(/1X,'GUESS=HUCKEL IS USUALLY A VERY BAD IDEA FOR SCFTYP=',
     *     A8/1X,'YOU PROBABLY SHOULD USE GUESS=MOREAD FOR THIS RUN!')
 9010 FORMAT(/1X,'THIS CHECK RUN SHOWS THERE IS SUFFICIENT MEMORY FOR ',
     *           'GUESS=HUCKEL.'//
     *        1X,'SINCE THIS IS A CHECK RUN WITH BOTH GUESS=HUCKEL ',
     *           'AND PRTMO=.FALSE.,'/
     *        1X,'THE ORBITALS WILL BE MADE BY GUESS=HCORE, ',
     *           'IN THE INTEREST OF SPEED.'/
     *        1X,'IF YOU REALLY NEED TO SEE THE HUCKEL ORBITAL ',
     *           'SYMMETRIES,'/
     *        1X,'YOU MUST SET PRTMO=.TRUE. DURING A CHECK RUN.')
 9020 FORMAT(1X,'HUCKEL GUESS REQUIRES',I10,' WORDS.')
      END
C*MODULE GUESS   *DECK HUCKLP
      SUBROUTINE HUCKLP(IW,NUCZ,ENEG,NCORE,NVAL,NDVAL,NOTECP,NCECP)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL NOTECP,GOPARR,DSKWRK,MASWRK
C
      DIMENSION ENEG(18),NDVAL(4)
      DIMENSION ROW1(2),ROW2(3,8),ROW3(5,8),ROW4(8,8),ROW5(11,8),
     *          ROW6(15,8),TM1(8,10),TM2(11,10),TM3(14,10),
     *          ROW7(16,2),ACT1(17,2),ACT2(18,13)
      DOUBLE PRECISION LANTH(13,14)
C
      COMMON /INTOPT/ ISCHWZ,IECP,NECP,IEXTFLD
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (HALF=0.5D+00)
C
C     -ENEG- RETURNS A LIST OF ORBITAL ENERGIES FOR INPUT ATOM -NUCZ-.
C     -NCORE- AND -NVAL- RETURN THE NUMBER OF CORE *ORBITALS* AND
C     VALENCE *SHELLS*, RESPECTIVELY.  -NDVAL- TELLS HOW MANY FUNCTIONS
C     ARE IN EACH VALENCE SHELL.  NOTE: -NCORE- AND -NDVAL- COUNT D
C     AND F ORBITALS AS CONTAINING 6 AND 10 FUNCTIONS, RESPECTIVELY.
C
C     ORBITAL ENERGIES FOR H-XE ARE TAKEN FROM
C     E.CLEMENTI,C.ROETTI   AT.NUC.DATA TABLES, VOL 14.
C     TRANSITION METAL ENERGIES ARE FROM S**1 D**N CONFIGURATIONS,
C     EXCEPT FOR SC,TI,ZN, AND Y,ZR,CD.
C
C     ORBITAL ENERGIES FOR CS-RN ARE TAKEN FROM
C     J.B.MANN - LOS ALAMOS REPORT NUMBERS LA-3690 AND LA-3691
C     NOTE THAT MANN'S ENERGIES ARE IN RYDBERG UNITS!
C
C     ASSUMPTIONS:       H,HE HAVE VALENCE S
C                     ALKALIS HAVE VALENCE S
C            RIGHT MAIN GROUP HAVE VALENCE S,P
C           TRANSITION METALS HAVE VALENCE D,S
C                 LANTHANIDES HAVE VALENCE F,S
C
C     THE ORDER OF THE ENERGIES IS
C        1S,2S,2P,3S,3P,3D,4S,4P,4D,5S,5P,5D,6S,6P    FOR  H-BA,
C            USING 0.0 FOR HIGHEST D AND P FOR ALKALIS, AND
C        1S,2S,2P,3S,3P,3D,4S,4P,4D,5S,5P,4F,6S,      FOR LA-YB,
C        1S,2S,2P,3S,3P,3D,4S,4P,4D,4F,5S,5P,5D,6S,6P FOR LU-RN
C                             ...4F,5S,5P,5D,6S,6P,7S FOR FR-RA
C                          ...4F,5S,5P,5D,6S,6P,6D,7S FOR AC-TH
C                       ...4F,5S,5P,5D,6S,6P,5F,6D,7S FOR PA-LR
C
C     DATA FOR ROW 7 ELEMENTS WILL REQUIRE MORE THINKING LATER!
C
      DATA ROW1/0.500D+00,0.918D+00/
      DATA ROW2/ 2.48D+00,0.196D+00,0.0D+00,
     *           4.73D+00,0.309D+00,0.0D+00,
     *           7.70D+00,0.495D+00,0.310D+00,
     *           11.3D+00,0.706D+00,0.433D+00,
     *           15.6D+00,0.945D+00,0.568D+00,
     *           20.7D+00,1.244D+00,0.632D+00,
     *           26.4D+00,1.573D+00,0.730D+00,
     *           32.8D+00,1.93D+00,0.850D+00/
      DATA ROW3/ 40.5D+00, 2.80D+00,1.52D+00,0.182D+00,0.0D+00,
     *           49.0D+00, 3.77D+00,2.28D+00,0.253D+00,0.0D+00,
     *           58.5D+00, 4.91D+00,3.22D+00,0.393D+00,0.210D+00,
     *           68.8D+00, 6.16D+00,4.26D+00,0.540D+00,0.297D+00,
     *           80.0D+00, 7.51D+00,5.40D+00,0.696D+00,0.392D+00,
     *           92.0D+00, 9.00D+00,6.68D+00,0.880D+00,0.437D+00,
     *          104.0D+00,10.60D+00,8.07D+00,1.073D+00,0.506D+00,
     *          118.6D+00,12.30D+00,9.57D+00,1.278D+00,0.591D+00/
      DATA ROW4/133.5D+00,14.5D+00,11.5D+00,1.75D+00,0.95D+00,
     *          0.000D+00,0.147D+00,0.000D+00,
     *          149.4D+00,16.8D+00,13.6D+00,2.24D+00,1.34D+00,
     *          0.000D+00,0.196D+00,0.000D+00,
     *          378.8D+00,48.2D+00,42.5D+00,6.40D+00,4.48D+00,
     *          1.193D+00,0.424D+00,0.208D+00,
     *          405.2D+00,52.1D+00,46.2D+00,7.19D+00,5.17D+00,
     *          1.635D+00,0.553D+00,0.287D+00,
     *          432.6D+00,56.3D+00,50.2D+00,8.03D+00,5.88D+00,
     *          2.113D+00,0.686D+00,0.369D+00,
     *          460.9D+00,60.7D+00,54.3D+00,8.93D+00,6.66D+00,
     *          2.650D+00,0.838D+00,0.403D+00,
     *          490.1D+00,65.2D+00,58.6D+00,9.87D+00,7.48D+00,
     *          3.220D+00,0.993D+00,0.457D+00,
     *          520.2D+00,69.9D+00,63.0D+00,10.8D+00,8.33D+00,
     *          3.825D+00,1.153D+00,0.524D+00/
C                      VALENCE P ENERGY SET TO 0.10
      DATA ((TM1(I,NUC),I=1,8),NUC=1,5) /
     *         165.9D+00,19.08D+00,15.67D+00,2.57D+00,1.575D+00,
     *          0.343D+00,0.210D+00,0.10D+00,
     *         183.3D+00,21.42D+00,17.79D+00,2.874D+00,1.795D+00,
     *          0.441D+00,0.220D+00,0.10D+00,
     *         201.3D+00,23.7D+00,19.8D+00,2.99D+00,1.84D+00,
     *         0.321D+00,0.214D+00,0.10D+00,
     *         220.4D+00,26.2D+00,22.1D+00,3.29D+00,2.05D+00,
     *         0.373D+00,0.222D+00,0.10D+00,
     *         240.4D+00,28.9D+00,24.6D+00,3.62D+00,2.30D+00,
     *         0.383D+00,0.227D+00,0.10D+00/
      DATA ((TM1(I,NUC),I=1,8),NUC=6,10) /
     *         261.2D+00,31.7D+00,27.2D+00,3.96D+00,2.55D+00,
     *         0.406D+00,0.230D+00,0.10D+00,
     *         282.9D+00,34.6D+00,29.9D+00,4.30D+00,2.80D+00,
     *         0.434D+00,0.233D+00,0.10D+00,
     *         305.4D+00,37.7D+00,32.7D+00,4.65D+00,3.06D+00,
     *         0.457D+00,0.236D+00,0.10D+00,
     *         328.8D+00,40.8D+00,35.6D+00,5.01D+00,3.32D+00,
     *         0.491D+00,0.238D+00,0.10D+00,
     *         353.3D+00,44.4D+00,38.9D+00,5.63D+00,3.84D+00,
     *         0.783D+00,0.293D+00,0.10D+00/
C
      DATA ROW5/
     *  551.0D+00, 75.0D+00, 67.9D+00,12.1D+00, 9.5D+00, 4.7D+00,
     *  1.52D+00,0.81D+00,0.000D+00,0.138D+00,0.000D+00,
     *  583.7D+00, 80.4D+00, 73.0D+00,13.5D+00,10.7D+00, 5.7D+00,
     *  1.90D+00,1.10D+00,0.000D+00,0.178D+00,0.000D+00,
     *  997.8D+00,149.4D+00,139.2D+00,29.6D+00,25.4D+00,17.6D+00,
     *  4.98D+00,3.51D+00,1.063D+00,0.372D+00,0.197D+00,
     * 1041.2D+00,157.0D+00,146.5D+00,31.6D+00,27.2D+00,19.2D+00,
     *  5.51D+00,3.97D+00,1.369D+00,0.476D+00,0.265D+00,
     * 1085.6D+00,164.8D+00,154.0D+00,33.6D+00,19.2D+00,20.8D+00,
     *  6.06D+00,4.45D+00,1.688D+00,0.582D+00,0.335D+00,
     * 1130.9D+00,172.8D+00,161.7D+00,35.8D+00,31.1D+00,22.5D+00,
     *  6.65D+00,4.95D+00,2.038D+00,0.701D+00,0.360D+00,
     * 1177.2D+00,180.9D+00,169.7D+00,37.9D+00,33.1D+00,24.3D+00,
     *  7.24D+00,5.47D+00,2.401D+00,0.821D+00,0.403D+00,
     * 1224.4D+00,189.3D+00,177.8D+00,40.2D+00,35.2D+00,26.1D+00,
     *  7.86D+00,6.01D+00,2.778D+00,0.944D+00,0.457D+00/
C                       VALENCE P IS ASSUMED TO HAVE E=0.10
      DATA ((TM2(I,NUC),I=1,11),NUC=1,5) /
     *  616.8D+00,85.81D+00,78.16D+00,14.76D+00,11.85D+00,6.599D+00,
     *   2.168D+00,1.300D+00,0.2499D+00,0.1958D+00,0.10D+00,
     *  650.7D+00,91.38D+00,83.48D+00,16.06D+00,13.02D+00,7.515D+00,
     *   2.418D+00,1.487D+00,0.3365D+00,0.207D+00,0.10D+00,
     *  685.4D+00, 97.0D+00, 88.8D+00,17.2D+00,14.0D+00, 8.3D+00,
     *  2.53D+00,1.55D+00,0.299D+00,0.214D+00,0.10D+00,
     *  721.2D+00,102.9D+00, 94.5D+00,18.6D+00,15.3D+00, 9.3D+00,
     *  2.76D+00,1.72D+00,0.357D+00,0.222D+00,0.10D+00,
     *  757.9D+00,108.9D+00,100.2D+00,20.0D+00,16.6D+00,10.3D+00,
     *  3.00D+00,1.91D+00,0.377D+00,0.222D+00,0.10D+00/
      DATA ((TM2(I,NUC),I=1,11),NUC=6,10)/
     *  795.5D+00,115.2D+00,106.2D+00,21.4D+00,17.8D+00,11.3D+00,
     *  3.26D+00,2.10D+00,0.412D+00,0.222D+00,0.10D+00,
     *  834.0D+00,121.6D+00,112.4D+00,22.9D+00,19.2D+00,12.4D+00,
     *  3.50D+00,2.29D+00,0.451D+00,0.220D+00,0.10D+00,
     *  873.5D+00,128.1D+00,118.7D+00,24.4D+00,20.5D+00,13.5D+00,
     *  3.75D+00,2.48D+00,0.488D+00,0.220D+00,0.10D+00,
     *  913.8D+00,134.9D+00,125.2D+00,25.9D+00,21.9D+00,14.7D+00,
     *  4.00D+00,2.68D+00,0.537D+00,0.220D+00,0.10D+00,
     *  955.4D+00,142.1D+00,132.1D+00,27.7D+00,23.6D+00,16.1D+00,
     *  4.45D+00,3.05D+00,0.763D+00,0.265D+00,0.10D+00/
C
      DATA ((ROW6(I,NUC),I=1,15),NUC=1,4) /
     *  2545.5D+00,396.3D+00,372.6D+00,85.39D+00,75.19D+00,56.45D+00,
     *   17.39D+00,13.54D+00,6.759D+00,2.463D+00,1.367D+00,0.0D+00,
     *   0.2473D+00,0.0D+00,  0.0D+00,
     *  2644.2D+00,414.3D+00,390.1D+00,90.56D+00,80.08D+00,60.80D+00,
     *   19.11D+00,15.10D+00,8.003D+00,3.025D+00,1.808D+00,0.0D+00,
     *   0.3150D+00,0.0D+00,  0.0D+00,
     *  5703.0D+00,969.1D+00,931.5D+00,234.3D+00,216.4D+00,183.4D+00,
     *   53.77D+00,45.84D+00,31.31D+00,11.57D+00,9.237D+00,6.463D+00,
     *   1.937D+00,0.7222D+00,0.3848D+00,
     *  5850.7D+00,997.2D+00,959.0D+00,242.5D+00,224.3D+00,190.7D+00,
     *   56.45D+00,48.33D+00,33.45D+00,13.17D+00,10.12D+00,7.229D+00,
     *   2.449D+00,0.9177D+00,0.4797D+00/
      DATA ((ROW6(I,NUC),I=1,15),NUC=5,8) /
     * 6000.2D+00,1025.7D+00,986.9D+00,250.8D+00,232.3D+00,198.1D+00,
     *   59.20D+00,50.90D+00,35.66D+00,14.84D+00,11.02D+00,8.010D+00,
     *   2.975D+00,1.116D+00,0.5724D+00,
     * 6151.7D+00,1054.6D+00,1015.3D+00,259.3D+00,240.5D+00,205.7D+00,
     *   62.01D+00,53.53D+00,37.93D+00,16.57D+00,11.93D+00,8.806D+00,
     *   3.517D+00,1.320D+00,0.6654D+00,
     * 6305.2D+00,1084.0D+00,1044.1D+00,268.0D+00,248.8D+00,213.5D+00,
     *   64.89D+00,56.22D+00,40.26D+00,18.36D+00,12.86D+00,9.620D+00,
     *   4.076D+00,1.531D+00,0.7597D+00,
     * 6460.5D+00,1113.8D+00,1073.4D+00,276.8D+00,257.3D+00,221.4D+00,
     *   67.84D+00,58.98D+00,42.66D+00,20.22D+00,13.81D+00,10.45D+00,
     *   4.653D+00,1.748D+00,0.8560D+00/
C                         THIRD TRANSITION SERIES IS LU-HG
C           NOTE THAT FOR LU, ORDER IS ACTUALLY 5S,5P,4F,5D,6S
      DATA ((TM3(I,NUC),I=1,14),NUC=1,5) /
     *  4335.4D+00,715.1D+00,682.9790D+00,164.5363D+00,149.7203D+00,
     *   122.5D+00,33.88D+00,27.68985D+00,16.52961D+00,4.634D+00,
     *   2.752D+00,2.154D+00,0.4867D+00,0.3977D+00,
     *  4463.6D+00,738.7D+00,706.0D+00,170.8D+00,155.7D+00,127.9D+00,
     *   35.61D+00,29.26D+00,17.77D+00,2.872D+00,5.050D+00,3.074D+00,
     *   0.5983D+00,0.4208D+00,
     *  4593.7D+00,762.6D+00,729.4D+00,177.3D+00,161.9D+00,133.5D+00,
     *   37.39D+00,30.87D+00,19.06D+00,3.630D+00,5.459D+00,3.393D+00,
     *   0.7033D+00,0.4395D+00,
     *  4725.6D+00,786.9D+00,753.1D+00,183.9D+00,168.1D+00,139.2D+00,
     *   39.22D+00,32.53D+00,20.39D+00,4.429D+00,5.868D+00,3.713D+00,
     *   0.8058D+00,0.4554D+00,
     *  4859.5D+00,811.7D+00,777.3D+00,190.6D+00,174.6D+00,145.1D+00,
     *   41.10D+00,34.24D+00,21.77D+00,5.267D+00,6.277D+00,4.034D+00,
     *   0.9076D+00,0.4693D+00/
      DATA ((TM3(I,NUC),I=1,14),NUC=6,10)/
     *  4995.3D+00,836.8D+00,801.9D+00,197.4D+00,181.1D+00,151.0D+00,
     *   43.03D+00,35.99D+00,23.18D+00,6.143D+00,6.688D+00,4.359D+00,
     *   1.0096D+00,0.48183D+00,
     *  5132.9D+00,862.4D+00,826.9D+00,204.5D+00,187.8D+00,157.2D+00,
     *   44.99D+00,37.78D+00,24.63D+00,7.058D+00,7.102D+00,4.688D+00,
     *   1.1124D+00,0.49317D+00,
     *  5272.1D+00,888.0D+00,852.0D+00,211.3D+00,194.3D+00,163.1D+00,
     *   46.68D+00,39.29D+00,25.80D+00,7.687D+00,7.213D+00,4.747D+00,
     *   0.9529D+00,0.4359D+00,
     *  5413.6D+00,914.4D+00,877.8D+00,218.5D+00,201.2D+00,169.4D+00,
     *   48.71D+00,41.14D+00,27.31D+00,8.657D+00,7.618D+00,5.069D+00,
     *   1.0420D+00,0.44155D+00,
     *  5557.3D+00,941.5D+00,904.4D+00,226.3D+00,208.7D+00,176.3D+00,
     *   51.15D+00,43.40D+00,29.22D+00,10.02D+00,8.364D+00,5.702D+00,
     *   1.4284D+00,0.52209D+00/
C               LANTHANIDES ARE LA-YB
C                  4F ENERGY FOR LA,CE,GD,TB IS FROM THE GREEN BOOK
      DATA ((LANTH(I,NUC),I=1,13),NUC=1,5)/
     *  2744.5D+00,432.6D+00,407.8D+00,95.69D+00,84.92D+00,65.11D+00,
     *   20.69D+00,16.52D+00,9.107D+00,3.409D+00,2.099D+00,
     *   0.718D+00,0.3408D+00,
     *  2846.2D+00,450.5D+00,425.2D+00,100.2D+00,89.10D+00,68.77D+00,
     *   21.62D+00,17.31D+00,9.636D+00,3.508D+00,2.156D+00,
     *    0.893D+00,0.34525D+00,
     *  2949.1D+00,468.2D+00,442.4141D+00,104.0040D+00,92.67145D+00,
     *   71.83D+00,21.93D+00,17.49167D+00,9.604272D+00,3.323620D+00,
     *   1.975944D+00,0.9510403D+00,0.3282479D+00,
     *  3054.5D+00,486.8D+00,460.5085D+00,108.5902D+00,96.97287D+00,
     *   75.608D+00,22.842D+00,18.2660D+00,10.11668D+00,3.410863D+00,
     *   2.022551D+00,1.027701D+00,0.3320609D+00,
     *  3161.6D+00,505.8D+00,478.9426D+00,113.2412D+00,101.3382D+00,
     *   79.449D+00,23.755D+00,19.03836D+00,10.62651D+00,3.495160D+00,
     *   2.0667D+00,1.0952D+00,0.3357256D+00/
      DATA ((LANTH(I,NUC),I=1,13),NUC=6,10)/
     *  3270.6D+00,525.1D+00,497.7187D+00,117.9602D+00,105.7708D+00,
     *   83.355D+00,24.669D+00,19.81125D+00,11.13601D+00,3.577292D+00,
     *   2.109111D+00,1.155315D+00,0.3392701D+00,
     *  3381.4D+00,544.7D+00,516.8387D+00,122.7500D+00,110.2732D+00,
     *   87.329D+00,25.587D+00,20.586D+00,11.64667D+00,3.657775D+00,
     *   2.150008D+00,1.209181D+00,0.3427156D+00,
     *  3494.7D+00,565.3725D+00,536.9240D+00,128.3149D+00,115.5450D+00,
     *   92.059D+00,27.151D+00,21.995D+00,12.75000D+00,4.045143D+00,
     *   2.448888D+00,1.217D+00,0.3699395D+00,
     *  3609.3D+00,585.72D+00,556.7439D+00,133.2584D+00,120.1992D+00,
     *   96.182D+00,28.088D+00,22.7874D+00,1.899959D+00,4.130250D+00,
     *   2.493615D+00,1.201D+00,0.3739158D+00,
     *  3725.1D+00,605.8D+00,576.2748D+00,137.5605D+00,124.2158D+00,
     *   99.678D+00,28.371D+00,22.939D+00,13.19563D+00,3.892656D+00,
     *   2.266318D+00,1.341072D+00,0.3525770D+00/
      DATA ((LANTH(I,NUC),I=1,13),NUC=11,14)/
     *  3843.3D+00,626.81D+00,596.7816D+00,142.6485D+00,129.0125D+00,
     *   103.94D+00,29.313D+00,23.736D+00,13.71982D+00,3.969502D+00,
     *   2.303501D+00,1.376891D+00,0.3557413D+00,
     *  3963.4D+00,648.2D+00,617.6366D+00,147.8136D+00,133.8852D+00,
     *   108.3D+00,30.3D+00,24.53857D+00,14.24883D+00,4.045856D+00,
     *   2.340056D+00,1.409256D+00,0.3588454D+00,
     *  4085.4D+00,669.9D+00,638.8408D+00,153.0565D+00,138.8354D+00,
     *   112.6D+00,31.22D+00,25.34902D+00,14.78302D+00,4.121855D+00,
     *   2.376093D+00,1.438472D+00,0.3619072D+00,
     *  4209.2D+00,692.0D+00,660.3940D+00,158.3777D+00,143.8621D+00,
     *   117.2D+00,32.19D+00,26.16724D+00,15.32266D+00,4.197588D+00,
     *   2.411661D+00,1.464763D+00,0.3649246D+00/
C
C                ALKALI METAL AND ALKALINE EARTH ONLY
C                FR AND RA (NO 6D AND 5F) => [RN] 7S
      DATA ((ROW7(I,NUC),I=1,16),NUC=1,2)/
     * 6618.192D+00,1144.438D+00,1103.401D+00,286.2123D+00,
     *  266.3896D+00 ,
     *  229.8506D+00,71.22978D+00,62.18136D+00,45.49809D+00,
     *  22.50728D+00,15.15141D+00,11.66833D+00,5.616434D+00,
     *  2.254577D+00,1.257037D+00,0.2358225D+00,
     * 6777.783D+00,1175.485D+00,1133.883D+00,295.7426D+00,
     *  275.5966D+00,
     *  238.4569D+00,74.68289D+00,65.44379D+00,48.39543D+00,
     *  24.86087D+00,16.50628D+00,12.89970D+00,6.593665D+00,
     *  2.741366D+00,1.639641D+00,0.2975396D+00/
C                 AC AND TH (NO 5F) => [RN] 6D 7S
      DATA ((ACT1(I,NUC),I=1,17),NUC=1,2)/
     * 6939.151D+00,1206.812D+00,1164.643D+00,305.2806D+00,
     *  284.8106D+00,
     *  247.0689D+00,78.04747D+00,65.61753D+00,51.20395D+00,
     *  27.12505D+00,17.72467D+00,13.99604D+00,7.437851D+00,
     *  3.071238D+00,
     *  1.891963D+00,0.5029767D+00,0.3220241D+00,
     * 7102.431D+00,1238.553D+00,1195.817D+00,314.9615D+00,
     *  294.1664D+00,
     *  255.8211D+00,81.45898D+00,71.83745D+00,54.05768D+00,
     *  29.43401D+00,18.94330D+00,15.09246D+00,8.283414D+00,
     *  3.386279D+00,
     *  2.135172D+00,0.5916698D+00,0.3415490D+00/
C                PA TO LR => [RN] 5F 6D 7S (NOTE: NOT 6D 7D 5F!)
      DATA((ACT2(I,NUC),I=1,18),NUC=1,3)/
     * 7266.822D+00,1269.850D+00,1226.558D+00,323.8753D+00,
     *  302.7579D+00,
     *  263.8155D+00,84.02711D+00,74.21401D+00,56.06804D+00,
     *  30.90748D+00,19.33846D+00,15.39150D+00,8.413868D+00,
     *  3.275320D+00,
     *  2.018012D+00,1.141923D+00,0.5259439D+00,0.3299046D+00,
     * 7433.478D+00,1301.940D+00,1258.085D+00,333.3312D+00,
     *  311.8888D+00,
     *  272.3442D+00,87.03783D+00,77.03203D+00,58.51813D+00,
     *  32.81643D+00,20.11943D+00,16.06539D+00,8.884312D+00,
     *  3.364734D+00,
     *  2.071534D+00,1.268872D+00,0.5330760D+00,0.3334427D+00,
     * 7602.020D+00,1334.415D+00,1289.998D+00,342.8990D+00,
     *  321.1309D+00,
     *  280.9825D+00,90.06890D+00,79.86967D+00,60.98666D+00,
     *  37.74340D+00,20.88972D+00,16.72959D+00,9.348123D+00,
     *  3.448519D+00,
     *  2.120837D+00,1.391233D+00,0.5382740D+00,0.3368222D+00/
      DATA((ACT2(I,NUC),I=1,18),NUC=4,6)/
     * 7772.035D+00,1366.838D+00,1321.863D+00,352.1187D+00,
     *  330.0257D+00,
     *  289.2756D+00,92.66615D+00,82.27316D+00,63.02062D+00,
     *  36.23848D+00,21.22016D+00,16.96589D+00,9.421055D+00,
     *  3.289756D+00,
     *  1.964737D+00,1.160888D+00,0.54D+00,0.3204514D+00,
     * 7944.340D+00,1400.076D+00,1354.539D+00,361.9024D+00,
     *  339.4820D+00,
     *  298.1252D+00,95.73039D+00,85.14255D+00,65.51856D+00,
     *  38.19355D+00,21.96345D+00,17.60479D+00,9.864354D+00,
     *  3.358333D+00,
     *  2.001848D+00,1.262594D+00,0.54D+00,0.3233138D+00,
     * 8118.982D+00,1434.176D+00,1388.073D+00,372.2980D+00,
     *  349.5479D+00 ,
     *  307.5791D+00,99.30925D+00,88.52546D+00,68.52807D+00,
     *  40.65626D+00,23.16198D+00,18.68797D+00,10.71842D+00,
     *  3.676197D+00,
     *  2.250873D+00,1.739940D+00,0.5456425D+00,0.3463305D+00/
      DATA((ACT2(I,NUC),I=1,18),NUC=7,9)/
     * 8295.087D+00,1468.214D+00,1421.548D+00,382.3345D+00,
     *  359.2557D+00 ,
     *  316.6771D+00,102.4438D+00,91.46380D+00,71.09269D+00,
     *  42.67636D+00,23.91215D+00,19.33451D+00,11.17211D+00,
     *  3.746338D+00,
     *  2.289867D+00,1.851929D+00,0.5460765D+00,0.3493624D+00,
     * 8473.083D+00,1502.645D+00,1455.415D+00,392.4909D+00,
     *  369.0824D+00,
     *  325.8924D+00,105.6073D+00,94.43035D+00,73.68424D+00,
     *  44.72240D+00,24.66042D+00,19.97946D+00,11.62538D+00,
     *  3.814223D+00,
     *  2.327129D+00,1.962242D+00,0.5456852D+00,0.3523197D+00,
     * 8652.974D+00,1537.470D+00,1489.677D+00,402.7683D+00,
     *  379.0292D+00,
     *  335.2262D+00,108.8007D+00,97.42619D+00,76.30389D+00,
     *  46.79545D+00,25.40778D+00,20.62380D+00,12.07897D+00,
     *  3.880233D+00,
     *  2.362956D+00,2.071234D+00,0.5446147D+00,0.3552401D+00/
      DATA((ACT2(I,NUC),I=1,18),NUC=10,12)/
     * 8834.758D+00,1572.690D+00,1524.333D+00,413.0967D+00,
     *  389.0967D+00,
     *  344.6792D+00,112.4519D+00,100.4519D+00,78.95225D+00,
     *  48.89609D+00,26.15491D+00,21.26809D+00,12.53331D+00,
     *  3.944604D+00,
     *  2.397518D+00,2.179081D+00,0.5429407D+0,0.3581284D+00,
     * 9018.437D+00,1608.305D+00,1559.384D+00,423.6878D+00,
     *  399.2850D+00,
     *  354.2515D+00,115.2798D+00,103.5080D+00,81.62975D+00,
     *  51.02466D+00,26.90228D+00,21.91277D+00,12.98866D+00,
     *  4.007485D+00,
     *  2.430922D+00,2.285858D+00,0.5407026D+0,0.3609751D+00,
     * 9204.011D+00,1644.314D+00,1594.829D+00,434.3307D+00,
     *  409.5949D+00,
     *  363.9438D+00,118.5665D+00,106.5951D+00,84.33698D+00,
     *  53.18169D+00,27.65044D+00,22.55832D+00,13.44540D+00,
     *  4.069076D+00,
     *  2.463315D+00,2.391757D+00,0.5379694D+0,0.3637940D+00/
      DATA (ACT2(I,13),I=1,18)/
     * 9391.479D+00,1680.720D+00,1630.670D+00,445.0960D+00,
     *  420.0264D+00,
     *  373.7562D+00,121.8851D+00,109.7134D+00,87.07427D+00,
     *  55.36756D+00,28.39971D+00,23.20510D+00,13.90376D+00,
     *  4.129517D+00,
     *  2.494798D+00,2.496697D+00,0.5347909D+00,0.3665888D+00/
C
C     ----- HUCKEL PARAMETERIZATION -----
C
      DO 10 I=1,4
         NDVAL(I) = 0
   10 CONTINUE
      DO 20 I=1,18
         ENEG(I) = 0.0D+00
   20 CONTINUE
C
C        NUMBER OF CORE ORBITALS REMOVED BY ECP BASIS SETS
C
      NCECP = 0
C
C           BOND FUNCTIONS
C
      IF(NUCZ.LE.0) THEN
         NCORE=0
         NVAL=0
         RETURN
      END IF
C---------------------FIRST ROW-------------
C            H-HE      VALENCE 1S
      IF(NUCZ.GE.1  .AND.  NUCZ.LE.2) THEN
         NCORE=0
         NVAL =1
         NDVAL(1)=1
         ENEG(1)=-ROW1(NUCZ)
         RETURN
      END IF
C--------------------SECOND ROW-------------
C           LI-BE      VALENCE 2S
      IF(NUCZ.GE.3  .AND.  NUCZ.LE.4) THEN
         NCORE=1
         NVAL =1
         NDVAL(1)=1
         NUC=NUCZ-2
         ENEG(1)=-ROW2(1,NUC)
         ENEG(2)=-ROW2(2,NUC)
         RETURN
      END IF
C            B-NE      VALENCE 2S,2P
      IF(NUCZ.GE.5  .AND.  NUCZ.LE.10) THEN
         NCORE=1
         NVAL =2
         NDVAL(1)=1
         NDVAL(2)=3
         NUC=NUCZ-2
         ENEG(1)=-ROW2(1,NUC)
         ENEG(2)=-ROW2(2,NUC)
         ENEG(3)=-ROW2(3,NUC)
         RETURN
      END IF
C---------------------THIRD ROW-------------
C           NA-MG       VALENCE 3S
      IF(NUCZ.GE.11  .AND.  NUCZ.LE.12) THEN
         IF(NOTECP) THEN
            NCORE=5
         ELSE
            NCORE=0
            NCECP=5
         END IF
         NVAL =1
         NDVAL(1)=1
         NUC=NUCZ-10
         DO 310 I=1,4
            ENEG(I)=-ROW3(I,NUC)
  310    CONTINUE
         RETURN
      END IF
C           AL-AR       VALENCE 3S,3P
      IF(NUCZ.GE.13  .AND.  NUCZ.LE.18) THEN
         IF(NOTECP) THEN
            NCORE=5
         ELSE
            NCORE=0
            NCECP=5
         END IF
         NVAL =2
         NDVAL(1)=1
         NDVAL(2)=3
         NUC=NUCZ-10
         DO 320 I=1,5
            ENEG(I)=-ROW3(I,NUC)
  320    CONTINUE
         RETURN
      END IF
C--------------------FOURTH ROW-------------
C            K-CA       VALENCE 3S
      IF(NUCZ.GE.19  .AND.  NUCZ.LE.20) THEN
         IF(NOTECP) THEN
            NCORE=9
         ELSE
            NCORE=0
            NCECP=9
         END IF
         NVAL =1
         NDVAL(1)=1
         NUC=NUCZ-18
         DO 410 I=1,5
            ENEG(I)=-ROW4(I,NUC)
  410    CONTINUE
         ENEG(6)=-ROW4(7,NUC)
         RETURN
      END IF
C           SC-ZN       VALENCE 3D,4S SHELLS
      IF(NUCZ.GE.21  .AND.  NUCZ.LE.30) THEN
         IF(NOTECP) THEN
            NCORE=9
         ELSE
            IF(NUCZ.EQ.30) THEN
               NCORE=0
               NCECP=9
            ELSE
               NCORE=4
               NCECP=5
            END IF
         END IF
         NVAL =2
         NDVAL(1)=6
         NDVAL(2)=1
         NUC=NUCZ-20
         DO 420 I=1,7
            ENEG(I)=-TM1(I,NUC)
  420    CONTINUE
         RETURN
      END IF
C           GA-KR       VALENCE 4S,4P
      IF(NUCZ.GE.31  .AND.  NUCZ.LE.36) THEN
         IF(NOTECP) THEN
            NCORE=15
         ELSE
            IF(NUCZ.EQ.31) THEN
               NCORE=10
               NCECP=5
            ELSE
               NCORE=0
               NCECP=15
            END IF
         END IF
         NVAL =2
         NDVAL(1)=1
         NDVAL(2)=3
         NUC=NUCZ-28
         DO 430 I=1,8
            ENEG(I)=-ROW4(I,NUC)
  430    CONTINUE
         RETURN
      END IF
C---------------------FIFTH ROW-------------
C           RB-SR       VALENCE 5S
      IF(NUCZ.GE.37  .AND.  NUCZ.LE.38) THEN
         IF(NOTECP) THEN
            NCORE=19
         ELSE
            NCORE=0
            NCECP=19
         END IF
         NVAL =1
         NDVAL(1)=1
         NUC=NUCZ-36
         DO 510 I=1,8
            ENEG(I)=-ROW5(I,NUC)
  510    CONTINUE
         ENEG(9)=-ROW5(10,NUC)
         RETURN
      END IF
C            Y-CD       VALENCE 4D,5S
      IF(NUCZ.GE.39  .AND.  NUCZ.LE.48) THEN
         IF(NOTECP) THEN
            NCORE=19
         ELSE
            IF(NUCZ.EQ.48) THEN
               NCORE=0
               NCECP=19
            ELSE
               NCORE=4
               NCECP=15
            END IF
         END IF
         NVAL =2
         NDVAL(1)=6
         NDVAL(2)=1
         NUC=NUCZ-38
         DO 520 I=1,10
            ENEG(I)=-TM2(I,NUC)
  520    CONTINUE
         RETURN
      END IF
C           IN-XE       VALENCE 5S,5P
      IF(NUCZ.GE.49  .AND.  NUCZ.LE.54) THEN
         IF(NOTECP) THEN
            NCORE=25
         ELSE
C              MOST ECP'S ARE SEMI-CORE FOR INDIUM, BUT NOT MCP'S
            IF(NUCZ.EQ.49) THEN
               IF(IECP.NE.5) THEN
                  NCORE=10
                  NCECP=15
               ELSE
                  NCORE=0
                  NCECP=25
               END IF
            ELSE
               NCORE=0
               NCECP=25
            END IF
         END IF
         NVAL =2
         NDVAL(1)=1
         NDVAL(2)=3
         NUC=NUCZ-46
         DO 530 I=1,11
            ENEG(I)=-ROW5(I,NUC)
  530    CONTINUE
         RETURN
      END IF
C---------------------SIXTH ROW-------------
C           CS-BA       VALENCE 6S
      IF(NUCZ.GE.55  .AND.  NUCZ.LE.56) THEN
         IF(NOTECP) THEN
            NCORE=29
         ELSE
            NCORE=0
            NCECP=29
         END IF
         NVAL =1
         NDVAL(1)=1
         NUC=NUCZ-54
         DO 610 I=1,11
            ENEG(I)=-HALF*ROW6(I,NUC)
  610    CONTINUE
         ENEG(12)=-HALF*ROW6(13,NUC)
         RETURN
      END IF
C           LA-YB       VALENCE IS 4F,6S (EXCEPT 5D,6S FOR LA)
      IF(NUCZ.GE.57  .AND.  NUCZ.LE.70) THEN
         IF(NOTECP) THEN
            NCORE=29
         ELSE
            NCORE=4
            NCECP=25
         END IF
         NVAL =2
         NDVAL(1)=10
         IF(NUCZ.EQ.57) NDVAL(1)=6
         NDVAL(2)=1
         NUC=NUCZ-56
         DO 630 I=1,13
            ENEG(I)=-HALF*LANTH(I,NUC)
  630    CONTINUE
         RETURN
      END IF
C           LU-HG      VALENCE IS 5D,6S
      IF(NUCZ.GE.71 .AND.  NUCZ.LE.80) THEN
         IF(NOTECP) THEN
            NCORE=39
         ELSE
            IF(NUCZ.EQ.80) THEN
               NCORE=0
               NCECP=39
            ELSE
               NCORE=4
               NCECP=35
            END IF
         END IF
         NVAL =2
         NDVAL(1)=6
         NDVAL(2)=1
         NUC=NUCZ-70
         DO 640 I=1,14
            ENEG(I)=-HALF*TM3(I,NUC)
  640    CONTINUE
C               WE ARBITRARILY MOVE 4F BELOW 5S.
C               THIS IS MAINLY A BANDAID FOR THE SBK BASIS,
C               WHERE 4F IS IN THE ECP, AND 5S,5P ARE SEMICORE.
         IF(NUCZ.GE.72  .AND.  NUCZ.LE.77) ENEG(10) = ENEG(11) - 1.0D+00
         RETURN
      END IF
C           TL-RN       VALENCE IS 6S,6P
      IF(NUCZ.GE.81  .AND.  NUCZ.LE.86) THEN
         IF(NOTECP) THEN
            NCORE=45
         ELSE
            IF(NUCZ.EQ.81) THEN
               NCORE=10
               NCECP=35
            ELSE
               NCORE=0
               NCECP=45
            END IF
         END IF
         NVAL=2
         NDVAL(1)=1
         NDVAL(2)=3
         NUC=NUCZ-78
         DO 650 I=1,15
            ENEG(I)=-HALF*ROW6(I,NUC)
  650    CONTINUE
         RETURN
      END IF
C-------------------SEVENTH ROW-------------
C           FR-RA       VALENCE 7S
      IF (NUCZ.GE.87 .AND. NUCZ.LE.88) THEN
         NCORE=49
         NVAL =1
         NDVAL(1)=1
         NUC=NUCZ-86
         DO 660 I=1,16
            ENEG(I)=-HALF*ROW7(I,NUC)
  660    CONTINUE
         RETURN
      END IF
C           AC-TH       VALENCE 6P,6D,7S
      IF (NUCZ.GE.89 .AND. NUCZ.LE.90) THEN
         NCORE=46
         NVAL =3
         NDVAL(1)=3
         NDVAL(2)=6
         NDVAL(3)=1
         NUC=NUCZ-88
         DO 670 I=1,17
            ENEG(I)=-HALF*ACT1(I,NUC)
  670    CONTINUE
         RETURN
      END IF
C           PA-LR       VALENCE 6P,5F,6D,7S
      IF (NUCZ.GE.91 .AND. NUCZ.LE.103) THEN
         NCORE=46
         NVAL =4
         NDVAL(1)=3
         NDVAL(2)=10
         NDVAL(3)=6
         NDVAL(4)=1
         NUC=NUCZ-90
         DO 680 I=1,18
            ENEG(I)=-HALF*ACT2(I,NUC)
  680    CONTINUE
         RETURN
      END IF
C                HIGHER THAN Z=103 BOMBS THE JOB
      IF (MASWRK) WRITE(IW,900) NUCZ
      CALL ABRT
      STOP
C
  900 FORMAT(1X,'ERROR!  THIS ATOM HAS NUCZ=',I5/
     *       1X,'HUCKEL PARAMETERS ARE UNAVAILABLE PAST ELEMENT LR')
      END
C*MODULE GUESS   *DECK ICOPY
      SUBROUTINE ICOPY(N,IX,INCX,IY,INCY)
      DIMENSION IX(INCX,N),IY(INCY,N)
C
C     AN INTEGER CLONE OF BLAS ROUTINE DCOPY.
C
      DO 100 I=1,N
         IY(1,I) = IX(1,I)
  100 CONTINUE
      RETURN
      END
C*MODULE GUESS   *DECK INIDEN
      SUBROUTINE INIDEN(GUESS,V,DA,DB,E,OCCNO,LABMO,IWRK,
     *                  Q,SCR,S,NORDER,IORDER,JORDER,L1,L2,L3,DBG,
     *                  PRTMO,PUNMO,SYMDEN,PURIFY,NA1,NST,LL1,LL2,LL3)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL SYMDEN,PURIFY,DBG,PRTMO,PUNMO,FRSTMO,
     *        GOPARR,DSKWRK,MASWRK
C
      PARAMETER (MXATM=2000, MXAO=8192)
C
      CHARACTER*5 ORBSET
C
      DIMENSION V(L1,*),DA(LL2),DB(L2),E(LL1),LABMO(L1),IWRK(L1),
     *          Q(LL3),SCR(L1),S(LL2),OCCNO(L1),IORDER(L1),JORDER(L1)
C
      COMMON /GVBWFN/ CICOEF(2,12),F(25),ALPHA(325),BETA(325),NO(10),
     *                NCO,NSETO,NOPEN,NPAIR,NMOGVB,NCONF(MXAO),NHAM
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /WFNOPT/ SCFTYP,CITYP,DFTYPE,CCTYP,MPLEVL,MPCTYP
C
      PARAMETER (ONE=1.0D+00, TWO=2.0D+00)
C
      DATA HCORE/8HHCORE   /, HUCKEL/8HHUCKEL  /, SAVDMO/8HMOSAVED /
      DATA RNONE/8HNONE    /
      DATA UHF/8HUHF     /
      DATA ROHF,GVB,AMCSCF/8HROHF    ,8HGVB     ,8HMCSCF   /
      DATA NONE/4HNONE/
C
C     ON ENTRANCE- E MUST CONTAIN EIGENVALUES, IF THE GUESS TYPE
C                  WAS HCORE OR HUCKEL. THE VECTORS MUST EXIST ON
C                  THE DICTIONARY FILE.
C     ON EXIT- V,DA,E WILL BE ON THE DICTIONARY FILE.
C              FOR ROHF OR UHF, THE BETA V,DB,E WILL BE THERE.
C
      FRSTMO = GUESS.EQ.HCORE  .OR.  GUESS.EQ.HUCKEL
      L0 = NQMT
C
C     ----- SET UP OCCUPATION NUMBERS -----
C     ----- SELECT (REORDER) MO-S     -----
C     ----- CALCULATE DENSITY MATRICES -----
C     ----- SAVE DENSITY + ORBITAL ENERGIES (OR OCCNO-S) -----
C
      IF(NA1.GT.L1) THEN
         IF(MASWRK) WRITE(IW,9060) NA1,L1
         CALL ABRT
         STOP
      END IF
C
C     COUNT CHEMICAL CORE ORBITALS, MOPAC SHOULD HAVE NONE
C
      NCORE = NUMCOR()
      IF(MPCTYP.NE.NONE) NCORE=0
C
      NOC=NA1
      CALL VCLR(OCCNO,1,L1)
      IF(SCFTYP.EQ.UHF)    GO TO 600
      IF(SCFTYP.EQ.ROHF)   GO TO 600
      IF(SCFTYP.EQ.GVB)    GO TO 430
      IF(SCFTYP.EQ.AMCSCF) GO TO 500
      IF(SCFTYP.EQ.RNONE)  GO TO 500
C                                      RHF OCCUPANCIES
      DO 420 I=NST,NOC+NST-1
         OCCNO(I) = TWO
  420 CONTINUE
      GO TO 500
C                                      GVB OCCUPANCIES
  430 CONTINUE
      NOC = NCO + NOPEN + 2*NPAIR
      IF(NCO.GT.0) THEN
         DO 440 I=1,NCO
            OCCNO(I) = TWO
  440    CONTINUE
      END IF
      IF(NOPEN.GT.0) THEN
         IOFF=NCO
         DO 460 I=1,NOPEN
            OCCNO(I+IOFF) = ONE
  460    CONTINUE
      END IF
      IF(NPAIR.EQ.0) GO TO 500
C GENERAL GVB CASE WOULD TAKE REORDERING TO MAKE PAIRS
      IF( FRSTMO  .AND. NPAIR.GT.1  .AND.  NORDER.EQ.0) THEN
         IF(MASWRK) WRITE(IW,*) ' ERROR: GVB ORBITALS MUST BE ORDERED'
         CALL ABRT
      END IF
      DO 470 I=1,NPAIR
         OCCNO(NCO+NOPEN+2*I-1) = TWO * CICOEF(1,I) * CICOEF(1,I)
         OCCNO(NCO+NOPEN+2*I  ) = TWO * CICOEF(2,I) * CICOEF(2,I)
  470 CONTINUE
C
C        ----- RHF, GVB, MCSCF, NONE CASES ----
C        SELECT THE MO-S, AND PRINT THEM
C
  500 CONTINUE
      NSAV=15
      CALL DAREAD(IDAF,IODA,V,LL3,NSAV,0)
      IF(GUESS.EQ.SAVDMO) GO TO 510
C
      IF(NORDER.EQ.1) THEN
         CALL ICOPY(L1,IORDER,1,IWRK,1)
         CALL REORDR(V,IORDER,L1,L1)
         CALL ICOPY(L1,IWRK,1,IORDER,1)
         CALL REORDR(E,IWRK,L1,1)
      END IF
C
C        --- IF PRINTING, GENERATE A "ENERGY" FROM CORE HAMILTONIAN ---
C              ONLY HCORE HAS "SENSIBLE" ENERGIES AT THIS POINT
C              HUCKEL GUESS HAS ALREADY PERMUTED ORBITALS
C        LOAD -H- INTO -S-, USE -Q- AS SCRATCH STORAGE
C
      IF((DBG .OR. PRTMO)  .AND.  GUESS.NE.HCORE) THEN
         CALL DAREAD(IDAF,IODA,S,LL2,11,0)
         CALL TFDIAG(S,V,E,Q,L1,L2,L1,L1)
         IF(MASWRK) WRITE(IW,*)
     *         'EIGENVALUES ARE DIAGONAL OF 1E- H IN MO BASIS'
      ELSE
         CALL VCLR(E,1,L1)
      END IF
C
C     OPTIONAL ORBITAL SYMMETRY CLEANUP
C
      IF(PURIFY) THEN
         IF(MASWRK) WRITE(IW,9015)
         CALL DAREAD(IDAF,IODA,S,LL2,12,0)
         CALL DAREAD(IDAF,IODA,Q,LL3,45,0)
         CALL SYMMOS(LABMO,Q,S,V,SCR,L0,L1,L0,L1)
         CALL ORBPUR(S,V,L1,NQMT,.TRUE.)
         CALL DAREAD(IDAF,IODA,Q,LL3,45,0)
         CALL ORTHO(Q,S,V,SCR,L0,L0,L1,L2,L1)
         CALL TFSQB(V,Q,SCR,L0,L1,L1)
C---     IF(MASWRK) THEN
C---        WRITE(IP,*) 'PURIFIED ORBITALS'
C---        WRITE(IP,*) '$VEC'
C---        CALL PUSQL(V,L1,L1,L1)
C---        WRITE(IP,*) '$END'
C---        CALL PREVS(V,E,LABMO,L1,L1,L1,1)
C---     END IF
      END IF
C
C     ASSIGN THE ORBITALS A SYMMETRY LABEL
C
      CALL DAREAD(IDAF,IODA,S,LL2,12,0)
      CALL DAREAD(IDAF,IODA,Q,LL3,45,0)
      CALL SYMMOS(LABMO,Q,S,V,SCR,L0,L1,L0,L1)
      CALL DAWRIT(IDAF,IODA,LABMO,LL1,255,1)
C
      ORBSET=' BOTH'
      IF (MASWRK) WRITE(IW,9020) ORBSET,NOC,NCORE
      IF(FRSTMO) THEN
         MINI=NCORE+1
         MAXI=MIN(NOC+10,L1,L0)
      ELSE
         MINI=1
         MAXI=MIN(L1,L0)
      END IF
      IF (MASWRK) WRITE(IW,9022) (I,LABMO(I),I=MINI,MAXI)
C
      IF(MASWRK  .AND.  (DBG  .OR.  PRTMO)) THEN
         WRITE (IW,9026)
         IF(FRSTMO) WRITE(IW,9046)
         IF(FRSTMO) WRITE(IW,9048) (OCCNO(I),I = 1,L1)
         CALL PREVS(V,E,LABMO,L1,L1,L1,1)
      END IF
      IF(MASWRK  .AND.  PUNMO) THEN
         WRITE(IP,8000) GUESS
         CALL PUSQL(V,L0,L1,L1)
         WRITE(IP,*) ' $END'
      END IF
C
  510 CONTINUE
      IF(NEVALS.GT.0) CALL DAREAD(IDAF,IODA,E,LL1,17,0)
      IF(SCFTYP.EQ.AMCSCF) GO TO 520
      IF(SCFTYP.EQ.RNONE)  GO TO 520
      IF(SCFTYP.EQ.GVB) GO TO 530
C                                              RHF DENSITY
      CALL DMTX(DA,V,OCCNO,NOC,L1,L1)
      IF(SYMDEN) THEN
        CALL SYMDNS(V,DA,LABMO,IWRK,Q,SCR,S,OCCNO,IA,L0,L1,L2,L3,LL1,1)
      END IF
      CALL SAVEMO(V,DA,E,LL1,LL2,LL3,NSAV)
      RETURN
C
C               CI AND MCSCF DENSITY CANNOT BE COMPUTED AT THIS POINT
C
  520 CONTINUE
      CALL VCLR(DA,1,L2)
      CALL SAVEMO(V,DA,E,L1,L2,L3,NSAV)
      RETURN
C                                               GVB DENSITY
  530 CONTINUE
      CALL REDDEN(V,DA,DB,L1,L2)
      CALL DAWRIT(IDAF,IODA,V,L3,15,0)
      CALL DAWRIT(IDAF,IODA,V,L3,19,0)
      CALL DAWRIT(IDAF,IODA,E,L1,17,0)
      CALL DAWRIT(IDAF,IODA,E,L1,21,0)
      RETURN
C
C     ----- UHF AND ROHF CASES -----
C     FIRST DO THE ALPHA SET OF ORBITALS
C
  600 CONTINUE
      NOC = NA
      NSAV = 15
      NVEC = 15
      ORBSET='ALPHA'
      IF(SCFTYP.EQ.UHF) CALL DCOPY(L1,E,1,DB,1)
C
      NPASS=0
  610 CONTINUE
      NPASS=NPASS+1
      CALL VCLR(OCCNO,1,L1)
      DO 620 I=1,NOC
         OCCNO(I) = ONE
  620 CONTINUE
      CALL DAREAD(IDAF,IODA,V,L3,NVEC,0)
      IF(GUESS.EQ.SAVDMO) GO TO 630
C
      IF((DBG .OR. PRTMO)  .AND.  GUESS.NE.HCORE) THEN
         CALL DAREAD(IDAF,IODA,S,LL2,11,0)
         CALL TFDIAG(S,V,E,Q,L1,L2,L1,L1)
         IF(MASWRK) WRITE(IW,*)
     *        'EIGENVALUES ARE DIAGONAL OF 1E- H IN MO BASIS'
      ELSE
         CALL VCLR(E,1,L1)
      END IF
C
      IF(NORDER.EQ.1) THEN
         IF(NPASS.EQ.1) THEN
            CALL ICOPY(L1,IORDER,1,IWRK,1)
            CALL REORDR(V,IORDER,L1,L1)
            CALL ICOPY(L1,IWRK,1,IORDER,1)
            CALL REORDR(E,IWRK,L1,1)
         END IF
         IF(NPASS.EQ.2  .AND.  SCFTYP.EQ.UHF) THEN
            CALL ICOPY(L1,JORDER,1,IWRK,1)
            CALL REORDR(V,JORDER,L1,L1)
            CALL ICOPY(L1,IWRK,1,JORDER,1)
            CALL REORDR(E,IWRK,L1,1)
         END IF
      END IF
C
C          OPTIONAL ORBITAL PURIFICATION
C
      IF(PURIFY) THEN
         IF(MASWRK) WRITE(IW,9015)
         CALL DAREAD(IDAF,IODA,S,L2,12,0)
         CALL DAREAD(IDAF,IODA,Q,L3,45,0)
         CALL SYMMOS(LABMO,Q,S,V,SCR,L0,L1,L0,L1)
         CALL ORBPUR(S,V,L1,NQMT,.TRUE.)
         CALL DAREAD(IDAF,IODA,Q,L3,45,0)
         CALL ORTHO(Q,S,V,SCR,L0,L0,L1,L2,L1)
         CALL TFSQB(V,Q,SCR,L0,L1,L1)
      END IF
C
C     ATTEMPT TO ASSIGN THE ORBITALS A SYMMETRY LABEL
C
      CALL DAREAD(IDAF,IODA,S,L2,12,0)
      CALL DAREAD(IDAF,IODA,Q,L3,45,0)
      CALL SYMMOS(LABMO,Q,S,V,SCR,L0,L1,L0,L1)
      IF(NPASS.EQ.1) CALL DAWRIT(IDAF,IODA,LABMO,LL1,255,1)
      IF(NPASS.EQ.2) CALL DAWRIT(IDAF,IODA,LABMO,LL1,256,1)
C
      IF (MASWRK) WRITE(IW,9020) ORBSET,NOC,NCORE
      MINI=NCORE+1
      MAXI=MIN(NOC+10,L0)
      IF (MASWRK) WRITE(IW,9022) (I,LABMO(I),I=MINI,MAXI)
C
      IF(MASWRK  .AND.  (DBG  .OR.  PRTMO)) THEN
         WRITE (IW,9026)
         IF(FRSTMO) WRITE(IW,9046)
         IF(FRSTMO) WRITE(IW,9048) (OCCNO(I),I = 1,L1)
         CALL PREVS(V,E,LABMO,L1,L1,L1,1)
      END IF
      IF(MASWRK  .AND.  PUNMO) THEN
         WRITE(IP,8000) GUESS
         CALL PUSQL(V,L0,L1,L1)
         IF(NPASS.EQ.2) WRITE(IP,*) ' $END'
      END IF
C
  630 CONTINUE
      IF(NPASS.EQ.1) THEN
         CALL DMTX(DA,V,OCCNO,NOC,L1,L1)
         IF(SYMDEN) THEN
         CALL SYMDNS(V,DA,LABMO,IWRK,Q,SCR,S,OCCNO,IA,L0,L1,L2,L3,LL1,1)
         END IF
         IF(NEVALS.GT.0) CALL DAREAD(IDAF,IODA,E,LL1,17,0)
         CALL SAVEMO(V,DA,E,L1,L2,L3,NSAV)
      ELSE
         CALL DMTX(DB,V,OCCNO,NOC,L1,L1)
         IF(SYMDEN)THEN
         CALL SYMDNS(V,DB,LABMO,IWRK,Q,SCR,S,OCCNO,IA,L0,L1,L2,L3,LL1,2)
         END IF
         IF(NEVALS.GT.0) CALL DAREAD(IDAF,IODA,E,LL1,21,0)
         CALL SAVEMO(V,DB,E,L1,L2,L3,NSAV)
      END IF
C                 GET READY TO DO THE BETA ORBITALS.
      NOC = NB
      NSAV = 19
      NVEC = 19
      IF(SCFTYP.EQ.ROHF) NVEC=15
      ORBSET=' BETA'
      IF(SCFTYP.EQ.UHF) CALL DCOPY(L1,DB,1,E,1)
C
C         THE UNLIKELY CASE OF NO BETA ELECTRONS HAPPENS SOMETIMES!
C
      IF (NB .EQ. 0) THEN
         CALL ZEROD(V,DB,E,L1,L2,L3)
         CALL SAVEMO(V,DB,E,L1,L2,L3,NSAV)
         RETURN
      END IF
      IF(NPASS.EQ.1) GO TO 610
      RETURN
C
 8000 FORMAT('STARTING ORBITALS FROM GUESS=',A8/' $VEC')
 9015 FORMAT(1X,'ORBITAL PURIFICATION WILL OCCUR')
 9020 FORMAT(/1X,'SYMMETRIES FOR INITIAL GUESS ORBITALS FOLLOW. ',
     *        1X,A5,' SET(S).'/
     *        1X,I5,' ORBITALS ARE OCCUPIED (',I5,' CORE ORBITALS).')
 9022 FORMAT(7(1X,I5,'=',A4))
 9026 FORMAT(/30X,22(1H-)/30X,'INITIAL GUESS ORBITALS'/
     *        30X,22(1H-))
 9046 FORMAT(/30X,'ASSIGNED OCCUPANCIES'/)
 9048 FORMAT(15X,5F11.6)
 9060 FORMAT(1X,'*** FATAL ERROR ***'/
     *       1X,'YOUR JOB HAS ENOUGH ELECTRONS TO OCCUPY',I5,' MO-S,'/
     *       1X,'BUT THE ATOMIC BASIS SET INCLUDES ONLY',I5,' AO-S.')
      END
C*MODULE GUESS   *DECK MIXORB
      SUBROUTINE MIXORB(SCFTYP,V,NORB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION V(NORB,*)
C
      PARAMETER (MXATM=2000)
C
      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)
C
      PARAMETER (ONE=1.0D+00, TWO=2.0D+00)
C
      DATA UHF/8HUHF     /
C
C        IN THE CASE OF SINGLET UHF,
C        MIX HOMO AND LUMO TO GENERATE INEQUIVALENT STARTING ORBITALS
C
      IF(SCFTYP.EQ.UHF  .AND.  NA.EQ.NB) THEN
         L3 = NORB*NORB
         CS = ONE/SQRT(TWO)
         SN = ONE/SQRT(TWO)
         NSAV = 15
         CALL DAREAD(IDAF,IODA,V,L3,NSAV,0)
         CALL ROT2X2(V(1,NA),V(1,NA+1),CS,SN,NORB)
         CALL DAWRIT(IDAF,IODA,V,L3,NSAV,0)
         SN = -SN
         NSAV = 19
         CALL DAREAD(IDAF,IODA,V,L3,NSAV,0)
         CALL ROT2X2(V(1,NB),V(1,NB+1),CS,SN,NORB)
         CALL DAWRIT(IDAF,IODA,V,L3,NSAV,0)
      END IF
      RETURN
      END
C*MODULE GUESS   *DECK MOFILE
      SUBROUTINE MOFILE(SCFTYP,IWRK,EIG,SCR,S,Q,VEC,L1,L2,L3,DBG,NB)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL DBG
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)
C
      DATA UHF/8HUHF     /
C
C     ----- READ THE INITIAL ORBITALS FROM THE DAF -----
C
C            GET CANONICAL ORBITALS
C
      CALL DAREAD(IDAF,IODA,S,L2,12,0)
      CALL QMTSYM(S,VEC,Q,EIG,SCR,IWRK,L0,L1,L2,L3,DBG)
      CALL DAWRIT(IDAF,IODA,Q,L3,45,0)
C
C            ORTHONORMALIZE THE ORBITALS FOUND ON THE DAF
C
      CALL DAREAD(IDAF,IODA,S,L2,12,0)
      NSAV=15
  200 CONTINUE
      CALL DAREAD(IDAF,IODA,VEC,L1*L0,NSAV,0)
      CALL ORTHO(Q,S,VEC,SCR,L0,L0,L1,L2,L1)
      CALL TFSQB(VEC,Q,SCR,L0,L1,L1)
      CALL DAWRIT(IDAF,IODA,VEC,L3,NSAV,0)
C
      IF(SCFTYP.NE.UHF) RETURN
      IF(NB.EQ.0) RETURN
      IF(NSAV.EQ.19) RETURN
C
C            GO BACK AND GET BETA ORBITALS FOR UHF
C
      NSAV = 19
      GO TO 200
      END
C
C*MODULE GUESS   *DECK MOFRG
      SUBROUTINE MOFRG(SCFTYP,IWRK,EIG,SCR,S,Q,VEC,L1,L2,L3,DBG,NB)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL DBG
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)
C
      DATA UHF/8HUHF     /
C
C     ----- ZERO OUT THE INITIAL ORBITALS AND ORBITAL ENERGIES -----
C       DENSITY WILL BE USED.
C       THIS SHOULD WORK FOR: (RHF,ROHF,UHF)+(MPN(N=0,2),CIN).
C       IT WILL NOT WORK FOR DFT,MCSCF OR GVB.
C
C            GET CANONICAL ORBITALS
C
      CALL DAREAD(IDAF,IODA,S,L2,12,0)
      CALL QMTSYM(S,VEC,Q,EIG,SCR,IWRK,L0,L1,L2,L3,DBG)
      CALL DAWRIT(IDAF,IODA,Q,L3,45,0)
C
      CALL VCLR(VEC,1,L3)
C
      NSAV=15
  200 CONTINUE
      CALL DAWRIT(IDAF,IODA,VEC,L3,NSAV,0)
      CALL DAWRIT(IDAF,IODA,VEC,L1,NSAV+2,0)
C
      IF(SCFTYP.NE.UHF) RETURN
      IF(NB.EQ.0) RETURN
      IF(NSAV.EQ.19) RETURN
C
C            GO BACK AND GET BETA ORBITALS FOR UHF
C
      NSAV = 19
      GO TO 200
      END
C*MODULE GUESS   *DECK ORBPUR
      SUBROUTINE ORBPUR(S,V,L1,NMO,PROOF)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,RUNTRM,PROOF,BAIL,ABELPT
C
      PARAMETER (MXSH=5000, MAXL=3, MXATM=2000, MXGRP=48, MXAO=8192)
      PARAMETER (ONE=1.0D+00,TINY=1.0D-06)
C
      DIMENSION V(L1,L1),S(*)
C
      COMMON /FMCOM / X(1)
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      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 /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /SOSYM / EULANG(4,MXGRP),GAM(MXGRP,48),IRMON(MXAO)
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(432),INVT(48),NT
      COMMON /SYMBLK/ NIRRED,NSALC,NSALC2,NSALC3,NSAFMO
      COMMON /TRNMOM/ OPERR,SYMTOL,NOCC,NUMCI,MFZC,NUMVEC,ICI,MXRT,NSTAT
C
      DATA TRANST/8HTRANSITN/
C
C     PREPARE A SET OF SYMMETRY PURIFIED ORBITALS.
C     PROOF STANDS FOR "IDIOT PROOF" OR IN OTHER WORDS FULLY AUTOMATIC
C     MODE CORRECTING FOR SYMMOS ERRORS.  (E.G., IN ATOMS, A COUPLE OF
C     DEGENERATE ORBITALS MAY GET THE SAME LABEL)
C     AT PRESENT, PROOF OPTION DOES NOT SUPPORT NON-ABELIAAN GROUPS.
C     IT IS NOT DIFFICULT TO ADD THEM, CHANGE 1 IN SEREP CALL ETC.
C     SOME FIDDLING WILL, HOWEVER, BE NEEDED, IF FOR EXAMPLE, THERE IS
C     DIRT OF SAY A1 SYMMETRY IN AN E MO, THEN ONE HAS TO HANDLE REDUCED
C     DIMENSIONS.
C
      RUNTRM=RUNTYP.EQ.TRANST
      NCORE=0
      CALL VALFM(LOADFM)
      LCHARR  = LOADFM  + 1
      LIRRID  = LCHARR  + NT*NIRRED
      LIRROW  = LIRRID  + (NMO-1)/NWDVAR+1
      LNATOMAO= LIRROW  + (NMO-1)/NWDVAR+1
      LWORK1  = LNATOMAO+ (NAT-1)/NWDVAR+1
      LFUNSYM = LWORK1  + L1
      LPROJ   = LFUNSYM + L1*MAXL
      LAST    = LPROJ   + L1*MAXL*MAXL
      IF(PROOF) THEN
         LV   = LAST
         LWORK2=LV      + L1*NMO
         LWORKV=LWORK2  + L1
         LAST  =LWORKV  + L1
      ENDIF
      NEED    = LAST-LCHARR-1
      CALL GETFM(NEED)
C
      IF(RUNTRM) THEN
         SMALL=SYMTOL
      ELSE
         SMALL=1.0D-04
      ENDIF
C
      IF(PROOF) CALL DCOPY(L1*NMO,V,1,X(LV),1)
      BAIL=.TRUE.
      CALL SEREP(NMO,NCORE,X,X(LCHARR),X(LIRRID),X(LIRROW),V,S,
     *           X(LWORK1),X(LFUNSYM),X(LPROJ),SMALL,.TRUE.,BAIL)
C
C     NOW, SYMMOS SOMETIMES INCORRECTLY ASSIGNS SYMMETRY, E.G., IT CAN
C     ASSIGN B1?,B1? FOR PX+PY,PX-PY IN C2V. IN THIS CASE SEREP WILL
C     GENERATE B1,B1 ORBITALS (THAT IS, SAME PX ORBITAL). THEN, WE NEED
C     TO GO BACK TO THE ORIGINAL ORBITALS AND TRY ALL IRREDUCIBLE
C     REPRESENATIONS ON THE SECOND ORBITAL, THAT IS, PX-PY AND HAPPILY
C     FIND B2 (PY) IN IT.  COUNTER EXAMPLE WHEN EVEN THIS TECHNIQUE
C     FAILS: PZ+PX, PZ, PY. IN THIS CASE SYMMOS GENERATES A1? A1? B2?
C     AND FIRST CALL TO SEREP GENERATES PZ,PZ,PY. THEN THE CODE BELOW
C     WILL TRY TO FIX IT AND GET: PZ, PZ, PY.
C     THE REAL SOLUTION TO THIS MESS IS (NOT IMPLEMENTED):
C     1. GENERATE A GUESS OF HOW MANY MOS OF EACH SYMMETRY THERE SHOULD
C        BE (THIS CAN BE DONE FROM THE AO ANALYSIS ALREADY DONE MINUS
C        THE SPHERICAL CONTAMINANTS). THIS IS NOT NEEDED BUT IS USEFUL
C        AS A CHECK.
C     2. LOOP I OVER IRREPS
C        APPLY I-TH PROJECTOR TO EACH MO AND STORE ALL LINEARLY
C        INDEPENDENT FUNCTIONS THAT BELONG TO IRREP "I". GRAMM-SCHMIDT
C        THEM AT THE END.  CHECK IF THE NUMBER MATCHES THE ONE IN (1.)
C     WHY THIS IS NOT IMPLEMENTED: GAMESS ASSUMES A CERTAIN ORDER OF THE
C     ORBITALS (E.G., NFZC CORE, NACT ACTIVE ETC IN CAS). AFTER BEING
C     PURIFIED, THE ORBS WILL HAVE TO BE REARRANGED WITHIN EACH GROUP.
C     PURIFIED ORBITALS CARRY NO EXPLICIT INFORMATION FROM WHICH GROUP
C     THEY ARE.  ANOTHER COMPLICATION: IN SOME METHODS IT IS NOT ALLOWED
C     TO MIX ORBITALS WITHIN GROUPS (I.E. THEY HAVE TO BE GRAMM-SCHMIDT
C     ORTHOGONALISED SEPARATELY AND IF THEY ARE NOT ORTHOGONAL THEN
C     PURIFICATION FAILS).
C     THIS SOLUTION IS NOT IMPOSSIBLE BUT REQUIRES A LITTLE BRAIN WORK.
C
      IF(PROOF.AND.ABELPT()) THEN
        DO I=1,NMO
          CALL MTARBR(S,L1,V(1,I),1,X(LWORK2),L1,1)
          LINDEP=0
          DO J=1,I-1
            D=DDOT(L1,X(LWORK2),1,V(1,J),1)
            IF(ABS(D-ONE).LT.TINY) THEN
              IF(MASWRK) WRITE(IW,9010) I,J
              LINDEP=1
              GOTO 1000
            ENDIF
          ENDDO
 1000     CONTINUE
          IF(LINDEP.NE.0) THEN
            ISAVE=IRMON(I)
            LVI=LV+(I-1)*L1
C
C        TRY ALL IRREDUCIBLE REPRESENTATIONS ON THE DUPLICATE ORBITALS
C
            DO 2000 IG=1,NIRRED
              IF(IG.EQ.IRMON(I)) GOTO 2000
              IRMON(I)=IG
              BAIL=.FALSE.
              CALL DCOPY(L1,X(LVI),1,X(LWORKV),1)
              CALL SEREP(1,I-1,X,X(LCHARR),X(LIRRID),X(LIRROW),X(LV),S,
     *                  X(LWORK1),X(LFUNSYM),X(LPROJ),SMALL,.TRUE.,BAIL)
              IF(.NOT.BAIL) THEN
                IF(MASWRK) WRITE(IW,*) 'FOUND A GOOD CANDIDATE!',IG
C
C         CHECK IF THE FOUND MO IS NOT ONE OF THE PREVIOUSLY FOUND.
C
                CALL MTARBR(S,L1,X(LVI),1,X(LWORK2),L1,1)
                DO J=1,I-1
                  D=DDOT(L1,X(LWORK2),1,V(1,J),1)
                  IF(ABS(D-ONE).LT.TINY) THEN
                    IF(MASWRK) WRITE(IW,9020) J
                    GOTO 2000
                  ENDIF
                ENDDO
C               FOUND A NEW FUNCTION!
                IF(MASWRK) WRITE(IW,*) 'FOUND A GOOD FUNCTION!',IG
                CALL DCOPY(L1,X(LVI),1,V(1,I),1)
                GOTO 3000
              ENDIF
              CALL DCOPY(L1,X(LWORKV),1,X(LVI),1)
              IRMON(I)=ISAVE
 2000       CONTINUE
C
C           WE SHOULD NEVER DROP TO HERE. PURIFICATION FAILS.
C           AN MO WAS NOT CLEAN AND YET NO DIAMOND WAS IN THE DIRT?
C
            IF(MASWRK) WRITE(IW,9030)
            CALL ABRT
 3000       CONTINUE
          ENDIF
        ENDDO
      ENDIF
C
      CALL RETFM(NEED)
      RETURN
 9010 FORMAT(1X,'DETECTED SYMMOS ERRONEOUS SYMMETRY ASSIGNMENT',2I4)
 9020 FORMAT(1X,'DETECTED IDENTICAL ORBITAL, SKIPPING IT...',I4)
 9030 FORMAT(1X,'PURIFICATION FAILED. SYMMOS GUESS TOO BAD?')
      END
C*MODULE GUESS   *DECK READMO
      SUBROUTINE READMO(NORB,IWRK,EIG,SCR,S,Q,VEC,L1,L2,
     *                  L3,LL2,LL3,MIX,DBG,TOLZ,TOLE)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXAO=8192)
C
      LOGICAL DBG,MIX,GOPARR,DSKWRK,MASWRK,MFRZ,MOIDON,EDCOMP,
     *        DIPDCM,DEPRNT,QADDCM,ZDO,POLDCM,POLANG,POLAPP,
     *        KMIDPT,POLDYN
      CHARACTER*8 STVEC
      DOUBLE PRECISION MOROKM
C
      DIMENSION IWRK(L1),EIG(L1),SCR(L1,8),S(L2),Q(L3),VEC(L1,L1)
C
      PARAMETER (MXATM=2000, NMO=500)
C
      COMMON /EDCMP / ZIJ(NMO),ZMO(5,NMO),OCCUP(NMO),DPFREQ(50),
     *                MOIDNO(5,NMO),IJMO(2,NMO),MOIJ(NMO),NMOIJ(NMO),
     *                NMOAT(NMO),NDPFREQ,IPROT(5),NPROT,
     *                MOIDON,EDCOMP,DIPDCM,DEPRNT,QADDCM,ZDO,POLDCM,
     *                POLANG,POLAPP,KMIDPT,POLDYN
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /MFRPAR/ MFRZ,NUMFRZ,IFRZ(MXAO)
      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 /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /WFNOPT/ SCFTYP,CITYP,DFTYPE,CCTYP,MPLEVL,MPCTYP
C
      DATA UHF/8HUHF     /,GVB/8HGVB     /
      DATA GUGA/8HGUGA    /, RMC/8HMCSCF   /
      DATA MOROKM /8HMOROKUMA/
      DATA NONE/4HNONE/
C
 9020 FORMAT(28H NO $VEC 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,12,0)
      CALL QMTSYM(S,VEC,Q,EIG,SCR,IWRK,L0,L1,L2,L3,DBG)
      CALL DAWRIT(IDAF,IODA,Q,LL3,45,0)
C
C            DEFAULT FOR NMOS IS THE NUMBER OF OCCUPIED ORBITALS
C            OR WHAT THE USER INPUT (NORB)
C
      IPASS = 1
      NSAV = 15
      NMOS = NA
      STVEC = ' $VEC   '
      NSTM=0
      NUM1=NUM
      IF(CITYP.EQ.GUGA  .OR.  SCFTYP.EQ.RMC) NMOS=0
      IF(SCFTYP.EQ.GVB) NMOS = NMOGVB
      IF(NORB.GT.0) NMOS = NORB
C
C     OVERWRITE NMOS AND STVEC IF RUNTYP = MOROKM
C
      IF (RUNTYP.EQ.MOROKM) CALL STRDMO(NMOS,STVEC,VEC,NSTM,NUM1,L3)
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               $VEC CARD NOT FOUND, KILL JOB
C
      IF (MASWRK) WRITE(IW,9020)
      CALL ABRT
      STOP
C
C               $VEC CARD FOUND, READ THE ORBITALS
C
  200 CONTINUE
      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
C SLAVE WORK
C
      ELSE
         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
C            BACK-TRANSFORM THE MO'S
C
      IF(MPCTYP.EQ.NONE  .AND.  .NOT.ZDO  .AND.  RUNTYP.NE.MOROKM) THEN
         CALL CLENMO(VEC,L1,NMOS,TOLZ,TOLE,IW,DBG)
C
C     IF MFRZ, REARRANGE THE VECTORS BEFORE TRANSFORMING THEM
C
         IF(MFRZ) CALL RAFR(L1,L1,VEC,IWRK)
         CALL ORTHO(Q,S,VEC,SCR,MIN(NMOS,L0),L0,L1,L2,L1)
         CALL TFSQB(VEC,Q,SCR,L0,L1,L1)
      END IF
      CALL DAWRIT(IDAF,IODA,VEC,LL3,NSAV,0)
C
C     INITIAL GUESS ORBITALS SAVED TWO TIMES FOR EFP BUFFER/FROZEN MOS
C
      CALL DAWRIT(IDAF,IODA,VEC,LL3,265,0)
      IF(MFRZ) CALL DAWRIT(IDAF,IODA,VEC,LL3,318,0)
C
C            GO BACK AND GET BETA MO S FOR UHF
C
      IF(SCFTYP.NE.UHF) RETURN
      IF(NB.EQ.0) RETURN
      IF(IPASS.EQ.2) RETURN
      IPASS = 2
      NMOS = NB
      IF(NORB.GT.0) NMOS = NORB
      NSAV = 19
      IF (MIX) THEN
         CALL DAWRIT(IDAF,IODA,VEC,LL3,NSAV,0)
         RETURN
      END IF
      GO TO 200
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*MODULE GUESS   *DECK REORDR
      SUBROUTINE REORDR(V,IORDER,NCOL,LDV)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION V(LDV,NCOL),IORDER(NCOL)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C     ----- REORDER A SET OF MOLECULAR ORBITALS -----
C     IORDER = REORDERING INSTRUCTIONS. THE I'TH NEW MO IS THE ONE
C              CURRENTLY STORED IN THE IORDER(I) POSITION.
C
      DO 110 I=1,NCOL
         DO 100 J=1,NCOL
            IF(IORDER(J).EQ.I) GO TO 110
  100    CONTINUE
         IF (MASWRK) WRITE(IW,9000) I
         IF (MASWRK) WRITE(IW,9010) (IORDER(J),J=1,NCOL)
         IF (MASWRK) WRITE(IW,9020)
         CALL ABRT
         STOP
  110 CONTINUE
C
      DO 240 I = 1,NCOL
         J = IORDER(I)
         CALL DSWAP(LDV,V(1,I),1,V(1,J),1)
         IP1 = I+1
         DO 220 K = IP1,NCOL
            IF(IORDER(K).EQ.I) IORDER(K) = J
  220    CONTINUE
  240 CONTINUE
      RETURN
C
 9000 FORMAT(1X,'**** ERROR, ORBITAL',I4,' IS MISSING FROM',
     *          ' REORDERING INSTRUCTIONS')
 9010 FORMAT(1X,25I4)
 9020 FORMAT(1X,'SOMETIMES THE ABOVE ERROR IS CASED BY AN INABILITY TO'/
     *       1X,'PROJECT THE HUCKEL GUESS ONTO THE CURRENT BASIS SET,'/
     *       1X,'E.G. WHEN THE 1S HUCKEL ORBITAL OF A H ATOM CANNOT'/
     *       1X,'BE PROJECTED ONTO A PURELY P BASIS SET BECAUSE YOU'/
     *       1X,'ARE TRYING TO DO EXCITED STATE H ATOMS.  IN SUCH A'/
     *       1X,'CASE, PLEASE USE GUESS=HCORE OR GUESS=MOREAD INSTEAD.')
      END
C*MODULE GUESS   *DECK ROT2X2
      SUBROUTINE ROT2X2(A,B,CS,SN,NORB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION A(NORB),B(NORB)
C
C     ROTATE ORBITALS A AND B
C     CS = COS(ANGLE), SN = SIN(ANGLE)
C
      DO 10 I = 1,NORB
         TMP = A(I)
         A(I) = CS*TMP + SN*B(I)
         B(I) = CS*TMP - SN*B(I)
   10 CONTINUE
      RETURN
      END
C*MODULE GUESS   *DECK SAVEMO
      SUBROUTINE SAVEMO(V,D,E,L1,L2,L3,NSAV)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION V(L3),D(L2),E(L1)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
C
      CALL DAWRIT(IDAF,IODA,V,L3,NSAV  ,0)
      CALL DAWRIT(IDAF,IODA,D,L2,NSAV+1,0)
      CALL DAWRIT(IDAF,IODA,E,L1,NSAV+2,0)
C
      RETURN
      END
C*MODULE GUESS   *DECK TSPHAR
      SUBROUTINE TSPHAR(T,L1,L1M,NOTSP,KTYPE,KLOC,NSHELL)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL NOTSP
C
      DIMENSION T(L1,L1),KTYPE(NSHELL),KLOC(NSHELL)
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00, THREE=3.0D+00,
     *           SIX=6.0D+00)
C
C     ----- GENERATE TRANSFORMATION TO SPHERICAL HARMONIC BASIS -----
C     NOTE THAT THE TRANSFORMATION WHICH IS RETURNED IS ORTHOGONAL,
C     AND CAN THUS BE INVERTED BY TRANSPOSING IT.  HOWEVER, THIS
C     MEANS THAT IT DOES NOT PRODUCE NORMALIZED SPHERICAL HARMONIC
C     AOS, FOR EXAMPLE XX-YY IS NORMALIZED TO 2/3 ONLY, OR IN OTHER
C     WORDS, T-DAGGER * S * T IS NOT ALWAYS 1 ON THE DIAGONAL.
C
C     -L1M- RETURNS THE NUMBER OF PURE SPHERICAL HARMONIC AO-S IN USE.
C
      RRT2 = ONE/SQRT(TWO)
      RRT3 = ONE/SQRT(THREE)
      RRT6 = ONE/SQRT(SIX)
      RT0203= SQRT(TWO/THREE)
      RT0519= SQRT( 5.0D+00/19.0D+00)
      RT0919= SQRT( 9.0D+00/19.0D+00)
      RT0938= SQRT( 9.0D+00/38.0D+00)
      RT2038= SQRT(20.0D+00/38.0D+00)
C
      CALL VCLR(T,1,L1*L1)
      DO 100 I=1,L1
         T(I,I)=ONE
  100 CONTINUE
C
      NCONT=0
      NOTSP = .FALSE.
      DO 200 N=1,NSHELL
         IF(KTYPE(N).LE.2) GO TO 200
         NOTSP=.TRUE.
         IF(KTYPE(N).EQ.3) THEN
            I = KLOC(N)
C                          S CONTAMINANT FIRST
            T(I  ,I  ) =  RRT3
            T(I+1,I  ) =  RRT3
            T(I+2,I  ) =  RRT3
C                          TRUE D ORBITALS
            T(I  ,I+1) =  RRT2
            T(I+1,I+1) = -RRT2
            T(I  ,I+2) =  RRT6
            T(I+1,I+2) =  RRT6
            T(I+2,I+2) = -RT0203
            NCONT = NCONT+1
         END IF
         IF(KTYPE(N).EQ.4) THEN
            I = KLOC(N)
            T(I+3,I+3) =  ZERO
            T(I+4,I+4) =  ZERO
            T(I+5,I+5) =  ZERO
            T(I+6,I+6) =  ZERO
            T(I+7,I+7) =  ZERO
            T(I+8,I+8) =  ZERO
C                          P-LIKE CONTAMINANT FIRST
            T(I  ,I  ) =  RT0919
            T(I+5,I  ) =  RT0519
            T(I+7,I  ) =  RT0519
            T(I+1,I+1) =  RT0919
            T(I+3,I+1) =  RT0519
            T(I+8,I+1) =  RT0519
            T(I+2,I+2) =  RT0919
            T(I+4,I+2) =  RT0519
            T(I+6,I+2) =  RT0519
C                          T1U (IN OH) COMBINATIONS
            T(I  ,I+3) =  RT2038
            T(I+5,I+3) = -RT0938
            T(I+7,I+3) = -RT0938
            T(I+1,I+4) =  RT2038
            T(I+3,I+4) = -RT0938
            T(I+8,I+4) = -RT0938
            T(I+2,I+5) =  RT2038
            T(I+4,I+5) = -RT0938
            T(I+6,I+5) = -RT0938
C                          T2U (IN OH) COMBINATIONS
            T(I+5,I+6) =  RRT2
            T(I+7,I+6) = -RRT2
            T(I+3,I+7) =  RRT2
            T(I+8,I+7) = -RRT2
            T(I+4,I+8) =  RRT2
            T(I+6,I+8) = -RRT2
C                          A2U (IN OH) COMBINATION
            T(I+9,I+9) =  ONE
            NCONT = NCONT+3
         END IF
         IF(KTYPE(N).EQ.5) THEN
            NCONT = NCONT+15
         END IF
  200 CONTINUE
C
      L1M = L1 - NCONT
      RETURN
      END
C*MODULE GUESS   *DECK HUKMIX
      SUBROUTINE HUKMIX(NORB,IWRK,SMO,EIG,SCR,S,Q,VEC,VEC2,L1,L2,
     *                  L3,LL2,LL3,DBG,TOLZ,TOLE)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXAO=8192)
C
      LOGICAL DBG,GOPARR,DSKWRK,MASWRK,MFRZ,MOIDON,EDCOMP,
     *        DIPDCM,DEPRNT,QADDCM,ZDO,POLDCM,POLANG,POLAPP,
     *        KMIDPT,POLDYN
      CHARACTER*8 STVEC
      DOUBLE PRECISION MOROKM
C
      DIMENSION IWRK(L1),EIG(L1),SCR(L1*8),S(L2),Q(L3),VEC(L1,L1),
     *          VEC2(L1,L1),SMO(L1,L1)
C
      PARAMETER (MXATM=2000, NMO=500)
C
      COMMON /EDCMP / ZIJ(NMO),ZMO(5,NMO),OCCUP(NMO),DPFREQ(50),
     *                MOIDNO(5,NMO),IJMO(2,NMO),MOIJ(NMO),NMOIJ(NMO),
     *                NMOAT(NMO),NDPFREQ,IPROT(5),NPROT,
     *                MOIDON,EDCOMP,DIPDCM,DEPRNT,QADDCM,ZDO,POLDCM,
     *                POLANG,POLAPP,KMIDPT,POLDYN
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /MFRPAR/ MFRZ,NUMFRZ,IFRZ(MXAO)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /OPTLOC/ CVGLOC,MAXLOC,IPRTLO,ISYMLO,IFCORE,NOUTA,NOUTB,
     *                MOOUTA(MXAO),MOOUTB(MXAO)
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /WFNOPT/ SCFTYP,CITYP,DFTYPE,CCTYP,MPLEVL,MPCTYP
C
      PARAMETER (ZERO=0.0D+00)
C
      DATA MOROKM /8HMOROKUMA/
      DATA NONE/4HNONE/
C
 9020 FORMAT(28H NO $VEC INPUT FOUND - STOP )
 9040 FORMAT(I2,I3,5E15.8)
 9060 FORMAT(' *** ERROR READING THE MO COEFFICIENTS AT',2I4/
     *       '     THE INPUT VALUES WERE',2I4)
 9100 FORMAT(' *** ERROR: PREMATURE END OF ORBITAL INPUT ENCOUNTERED'/
     *       '            LOOKING FOR ORBITAL',I4,' ELEMENT',I4)
 9200 FORMAT(/1X,'THE MIXED HUCKEL/MOREAD GUESS WILL BE PERFORMED,',
     *       ' INSORB=',I3/)
C
C     TO BE ABLE TO READ IN VECTORS FROM A $VEC GROUP AND MIX THEM
C     WITH THE APPROPRIATE HUCKEL GUESS VECTORS BY REPLACING THE MOST
C     CLOSELY CORRESPONDING HUCKEL VECTORS.  VECTORS READ IN SHOULD BE
C     LOCALIZED BUT NEED NOT CONTAIN THE SAME NO. OF AOS AS THE SYSTEM
C     THEY ARE BEING READ INTO AS THE CODE WILL JUST ADD THE APPROPRIATE
C     NUMBER OF ZEROES AT THE END OF EACH VECTOR IN THIS CASE.
C                                RYAN M. MINIKIS, U. OF IOWA  --  1999
C
      IZERO = 0
      IONE  = 1
      ITWO  = 2
      IF (MASWRK) WRITE(IW,9200) NORB
C
C     ----- READ THE INITIAL ORBITALS FROM THE INPUT FILE -----
C
C            GET CANONICAL ORBITALS
C
      L0=L1
      CALL DAREAD(IDAF,IODA,S,LL2,12,0)
      CALL QMTSYM(S,VEC,Q,EIG,SCR,IWRK,L0,L1,L2,L3,DBG)
      CALL DAWRIT(IDAF,IODA,Q,LL3,45,0)
C
C            DEFAULT FOR NMOS IS WHAT THE USER INPUT (NORB)
C
      NSAV = 15
      NMOS = NORB
      STVEC = ' $VEC   '
      NSTM=0
      NUM1=NUM
C
C  TESTING ADZERO SUBROUTING
C
      CALL ADZERO(NMOS,NAOS,NOZERO,VEC2,L1)
      IF (GOPARR) THEN
        CALL DDI_BCAST(352,'I',NMOS,1,MASTER)
        CALL DDI_BCAST(353,'I',NAOS,1,MASTER)
        CALL DDI_BCAST(354,'I',NOZERO,1,MASTER)
      END IF
      IF (NMOS.NE.NORB) THEN
         IF (MASWRK) THEN
         WRITE(IW,*)'ERROR: THE NUMBER OF ORBITALS SPECIFIED IN THE'
         WRITE(IW,*)' INPUT FILE (NORB) DOES NOT EQUAL THE NUMBER OF'
         WRITE(IW,*)' ORBITALS DETECTED - STOP'
         END IF
         CALL ABRT
         STOP
      END IF
C      IF THE PROGRAM ADDED ZEROS, THE READ ORBITALS SECTION IS SKIPPED
C        BECAUSE IT WAS ALREADY DONE IN SUBROUTINE ADZERO
      IF (NOZERO.EQ.1) GO TO 300
C
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               $VEC CARD NOT FOUND, KILL JOB
C
      IF (MASWRK) WRITE(IW,9020)
      CALL ABRT
      STOP
C
C               $VEC CARD FOUND, READ THE ORBITALS
C
  200 CONTINUE
      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=500,ERR=500) JJ,ICC,(VEC2(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
C SLAVE WORK
C
      ELSE
         IF (GOPARR) CALL DDI_BCAST(350,'I',IEND,1,MASTER)
         IF (IEND.EQ.IONE) GO TO 500
         IF (IEND.EQ.ITWO) CALL ABRT
      END IF
C
C  GIVE VECTORS TO ALL PROCESSES
C
      IF (GOPARR) CALL DDI_BCAST(351,'F',VEC2,NMOS*L1,MASTER)
C
C  LOCALIZE AND READ IN HUCKEL GUESS ORBITALS (FROM HUCKLM SUBROUTINE)
C
 300  CONTINUE
      CALL DIPINT(ZERO,ZERO,ZERO,.FALSE.)
C
C   BACKUP LOCALIZATION PARAMETERS WHICH MIGHT HAVE BEEN READ IN BEFORE
C
      CVGLBK=CVGLOC
      MAXLBK=MAXLOC
      IPRTBK=IPRTLO
      ISYMBK=ISYMLO
      IFCOBK=IFCORE
      NOUTAB=NOUTA
      NOUTBB=NOUTB
      CALL ICOPY(L1,MOOUTA,1,IWRK,1)
C
C   LOOSEN ORBITAL CONVERGENCE CRITERION (FROM 1E-6) -V.K.
C
      CVGLOC= 2.0D-04
      MAXLOC= 250
      IPRTLO=0
      ISYMLO=0
      IFCORE=1
      NOUTA=0
      NOUTB=0
C
C  CORE ORBITAL COUNT
C
      MCORE = NUMCOR()
      NOUTA = MCORE
      DO I=1,MCORE
         MOOUTA(I) = I
      ENDDO
      NPR=NPRINT
      NPRINT=-23
      CALL LMOLOC(1)
      NPRINT=NPR
C
C   RESTORE THE LOCALIZATION PARAMETERS
C
      CVGLOC=CVGLBK
      MAXLOC=MAXLBK
      IPRTLO=IPRTBK
      ISYMLO=ISYMBK
      IFCORE=IFCOBK
      NOUTA=NOUTAB
      NOUTB=NOUTBB
      CALL ICOPY(L1,IWRK,1,MOOUTA,1)
C    PRETEND RECORD 73 WAS NEVER WRITTEN TO PREVENT BOMBING OUT
C    DURING A LOCALIZATION LATER IN THE PROGRAM -V.K.
      IODA(73)=0
C
C
      CALL DAREAD(IDAF,IODA,VEC,LL3,71,0)
C
C        ----- CALCULATE OVERLAP BETWEEN THE TWO ORBITAL SETS -----
C        SMO = VEC2-DAGGER * S * VEC
C
      CALL DAREAD(IDAF,IODA,S,LL2,12,0)
      CALL VCLR(SMO,1,L3)
      CALL MTARBR(S,L1,VEC,L1,SMO,L1,1)
      CALL MRTRBR(VEC2,L1,L1,L1,SMO,L1,L1,VEC,L1)
      CALL DCOPY(L3,VEC,1,SMO,1)
      CALL DAREAD(IDAF,IODA,VEC,LL3,71,0)
C
C        ----- OBTAIN PERMUTATION TO MAXIMUM COINCIDENCE -----
C        THE -GVB- CODE LIKES PHASES TO BE CONSISTENT AS WELL
C
      DO 290 I=1,NORB
         SMAX = ZERO
         IWRK(I) = 0
         DO 230 J=1,L1
            DO 210 K=1,I
               IF(IWRK(K).EQ.J) GO TO 230
  210       CONTINUE
            SS = ABS(SMO(I,J))
            IF(SS.GT.SMAX) THEN
               SMAX = SS
               IWRK(I) = J
            END IF
  230    CONTINUE
         IF(SMO(I,IWRK(I)).LT.ZERO) THEN
            DO 270 J=1,L1
               VEC(J,IWRK(I)) = -VEC(J,IWRK(I))
  270       CONTINUE
         END IF
  290 CONTINUE
C
C  FILL IN IWRK WITH THE ORDER THE ORBITALS NEED TO BE ARRANGED IN
C
      DO 490 I=NORB+1,L1
         IWRK(I) = 0
         DO 480 J=1,L1
            DO 410 K=1,I
               IF (IWRK(K).EQ.J) GO TO 480
  410       CONTINUE
            IWRK(I) = J
            GO TO 490
  480    CONTINUE
  490 CONTINUE
C
C        ----- AND APPLY THAT PERMUTATION -----
C
      CALL REORDR(VEC,IWRK,L1,L1)
C
C  WRITE THE READ IN MOS OVER THE CORRESPONDING HUCKEL MOS
C
      CALL DCOPY(NORB*L1,VEC2(1,1),1,VEC(1,1),1)
C
C     ORTHONORMALIZE THE ORBITALS/BACK TRANSFORM THE MO'S
C
      IF(MPCTYP.EQ.NONE  .AND.  .NOT.ZDO  .AND.  RUNTYP.NE.MOROKM) THEN
         CALL CLENMO(VEC,L1,L1,TOLZ,TOLE,IW,DBG)
         CALL ORTHO(Q,S,VEC,SCR,L1,L0,L1,L2,L1)
         CALL TFSQB(VEC,Q,SCR,L0,L1,L1)
      END IF
C
C  WRITE MIXED HUCKEL AND FROZEN MOS TO DICTIONARY FILE
C
      CALL DAWRIT(IDAF,IODA,VEC,LL3,NSAV,0)
C
C     INITIAL GUESS ORBITALS SAVED TWO TIMES FOR EFP BUFFER/FROZEN MOS
C
      CALL DAWRIT(IDAF,IODA,VEC,LL3,265,0)
      IF(MFRZ) CALL DAWRIT(IDAF,IODA,VEC,LL3,318,0)
      RETURN
C
C        PREMATURE END OF $VEC INPUT ENCOUNTERED
C
  500 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*MODULE GUESS   *DECK ADZERO
      SUBROUTINE ADZERO(NMOS,NAOS,NOZERO,VEC,L1)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      CHARACTER*8 STVEC
      CHARACTER CSTRNG*80
C
      DIMENSION VEC(L1,L1)
C
      PARAMETER (MXATM=2000)
      PARAMETER (ZERO=0.0D+00)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
9040  FORMAT(I2,I3,5E15.8)
9060  FORMAT(' *** ERROR READING THE MO COEFFICIENTS AT',2I4/
     *       '     THE INPUT VALUES WERE',2I4)
9100  FORMAT(A80)
9300  FORMAT(' *** ERROR: PREMATURE END OF ORBITAL INPUT ENCOUNTERED'/
     *       '            LOOKING FOR ORBITAL',I4,' ELEMENT',I4)
C
      STVEC = ' $VEC   '
      NMOS=0
      NUMLV=0
      LINE=0
      IAPREV=1
      NLDONE=0
      NFDONE=0
      NLEFT=5
      NOZERO=0
      NUM1=NUM
      IZERO = 0
      IONE  = 1
      ITWO  = 2
C
C  POSITION THE INPUT FILE (IR) TO $VEC
C
      CALL SEQREW(IR)
      CALL FNDGRP(IR,STVEC,IEOF)
      IF (IEOF.EQ.0) GO TO 100
C
C   $VEC CARD NOT FOUND-KILL JOB
C
      IF (MASWRK) WRITE(IW,*) 'NO $VEC CARD FOUND - STOP'
      CALL ABRT
      STOP
C
 100  CONTINUE
 130  READ (IR,9100,END = 1400) CSTRNG
      LINE = LINE + 1
C SINCE LEN_TRIM IS NON STANDARD FORTRAN77 FUNCTION, WE'LL DO WITHOUT IT
      DO 140 I=80,1,-1
         IF(CSTRNG(I:I) .NE. ' ') GO TO 150
 140  CONTINUE
 150  LENTRM=I
C
      IF(NFDONE.EQ.0 .AND. LENTRM.GT.10 .AND. LENTRM.LT.80) THEN
          NLEFT=(LENTRM-5)/15
          NFDONE=1
      END IF
C
      IF(LENTRM.LT.10) THEN
C  END OF VECTORS REACHED
         LINEM1=LINE-1
         IF(MOD(LINEM1,NUMLV) .NE. 0) THEN
           IF (MASWRK) THEN
           WRITE(IW,*)' ERROR: VEC FILE IS IRREGULAR:'
           WRITE(IW,*)' THE TOTAL NUMBER OF LINES CANNOT BE DIVIDED BY '
           WRITE(IW,*)' NUMBER OF LINES PER VECTOR WITHOUT REMAINDER '
           END IF
           CALL ABRT
           STOP
         END IF
         NMOS=LINEM1/NUMLV
         GO TO 1100
      END IF
C
      IF(NLDONE.GT.0) GO TO 130
C   CHECK OUT THE FIRST INTEGER IN CSTRNG
      READ(UNIT=CSTRNG,FMT='(I2,I3,5E15.8)') IA
      IF(IAPREV.NE.IA)THEN
          NUMLV=LINE-1
          NLDONE=1
          NAOS=(NUMLV-1)*5+NLEFT
      END IF
      IAPREV=IA
      GO TO 130
C
C
CC1100  WRITE(IW,*)' THE PROGRAM FOUND ',NMOS,' NMOS, ',NAOS,' NAOS'
CC      WRITE(IW,*)' IN THE $VEC GROUP'
 1100 CONTINUE
C
C   IF NAOS = NUM THEN NO ZEROS ARE NEEDED AND RETURN TO HUKMIX
C
      IF (NAOS.EQ.NUM1) RETURN
      IF (NAOS.NE.NUM1) THEN
         NOZERO=1
      END IF
C
C    NOW READ IN VECTORS AND ADD ZEROS UP TO THE NO. OF BASIS FUNCTIONS
C    AT THE END OF THE VECTORS
C
C  POSITION THE INPUT FILE (IR) TO $VEC
C
      IF (MASWRK) THEN
      WRITE(IW,*)' THE PROGRAM WILL APPEND THE NECESSARY NUMBER OF'
      WRITE(IW,*)' ZEROES TO THE END OF THE READ IN VECTORS'
      END IF
      CALL SEQREW(IR)
      CALL FNDGRP(IR,STVEC,IEOF)
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. NAOS) IMAX = NAOS
            READ(IR,9040,END=500,ERR=500) JJ,ICC,(VEC(I,J),I=IMIN,IMAX)
            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. NAOS) GO TO 240
  280 CONTINUE
      DO 380 J = 1,NMOS
         DO 370 I = NAOS+1,NUM1
            VEC(I,J)=ZERO
  370    CONTINUE
  380 CONTINUE
C
      IF (GOPARR) CALL DDI_BCAST(350,'I',IZERO,1,MASTER)
C
C SLAVE WORK
C
      ELSE
         IF (GOPARR) CALL DDI_BCAST(350,'I',IEND,1,MASTER)
         IF (IEND.EQ.IONE) GO TO 500
         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)
      RETURN
C
C        PREMATURE END OF $VEC INPUT ENCOUNTERED
C
 500  CONTINUE
      IF (MASWRK) THEN
         IF (GOPARR) CALL DDI_BCAST(350,'I',IONE,1,MASTER)
         WRITE(IW,9300) J,IC
      END IF
      CALL ABRT
      STOP
1400  IF(MASWRK) WRITE(IW,*)' EOF FILE ENCOUNTERED'
      RETURN
      END
C*MODULE GUESS   *DECK FRZLMX
      SUBROUTINE FRZLMX
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL MFRZ,DBUG
C
      PARAMETER (MXATM=2000, MXAO=8192)
      PARAMETER (ZERO=0.0D+00)
C
      COMMON /FMCOM / X(1)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /MFRPAR/ MFRZ,NUMFRZ,IFRZ(MXAO)
C
C  MEMORY HANDLING FOR FRZLMO SUBROUTINE WHICH
C  AUTOMATICALLY MODIFIES NOUTA IF SOME MOS ARE FROZEN
C
      L1 = NUM
      L2 = (L1*L1+L1)/2
C
      CALL VALFM (LOADFM)
      LDIPX   = LOADFM + 1
      LDIPY   = LDIPX     + L2
      LDIPZ   = LDIPY     + L2
      LV  = LDIPZ     + L2
      LDIP = LV    + L1*NUMFRZ
      LAST = LDIP    + 3*NUMFRZ
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
C
      DBUG=.FALSE.
      CALL DIPINT(ZERO,ZERO,ZERO,DBUG)
      CALL FRZLMO(X(LDIPX),X(LDIPY),X(LDIPZ),X(LV),X(LDIP),L1,L2,NUMFRZ)
C
      CALL RETFM(NEED)
      RETURN
C
      END
C*MODULE GUESS   *DECK FRZLMO
      SUBROUTINE FRZLMO(DIPX,DIPY,DIPZ,V,DIP,L1,L2,LNA)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      PARAMETER (MXATM=2000, MXAO=8192)
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00, THRESH=1.0D-01)
C
      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 /OPTLOC/ CVGLOC,MAXLOC,IPRTLO,ISYMLO,IFCORE,NOUTA,NOUTB,
     *                MOOUTA(MXAO),MOOUTB(MXAO)
      COMMON /XYZPRP/ XP,YP,ZP
     *               ,DMX,DMY,DMZ
     *               ,QXX,QYY,QZZ,QXY,QXZ,QYZ
     *               ,QMXX,QMYY,QMZZ,QMXY,QMXZ,QMYZ
     *               ,OXXX,OXXY,OXXZ,OXYY,OYYY,OYYZ
     *               ,OXZZ,OYZZ,OZZZ,OXYZ
     *               ,OMXXX,OMXXY,OMXXZ,OMXYY,OMYYY
     *               ,OMYYZ,OMXZZ,OMYZZ,OMZZZ,OMXYZ
C
      DIMENSION DIPX(L2), DIPY(L2), DIPZ(L2), V(L1,LNA), DIP(3,LNA)
C
C  THIS SUBROUTINE CALCULATES THE CENTROIDS OF CHARGE OF THE
C  FROZEN ORBITALS AND HOPEFULLY CORRECTLY DETERMINES THE NUMBER OF
C  CORES AMONG THEM. THE 1ST PART OF THE PROGRAM IS COPIED FROM DIPLMO.
C
      CALL DAREAD(IDAF,IODA,DIPX,L2,95,0)
      CALL DAREAD(IDAF,IODA,DIPY,L2,96,0)
      CALL DAREAD(IDAF,IODA,DIPZ,L2,97,0)
      CALL DAREAD(IDAF,IODA,V,L1*LNA,15,0)
      DO 500 K = 1,LNA
         SUMX = ZERO
         SUMY = ZERO
         SUMZ = ZERO
         IJ = 0
         DO 400 I = 1,L1
            DO 300 J =1,I
               IJ = IJ + 1
               ONETWO = TWO
               IF(I.EQ.J) ONETWO = ONE
               SUMX = SUMX + DIPX(IJ)*V(I,K)*V(J,K)*ONETWO
               SUMY = SUMY + DIPY(IJ)*V(I,K)*V(J,K)*ONETWO
               SUMZ = SUMZ + DIPZ(IJ)*V(I,K)*V(J,K)*ONETWO
  300       CONTINUE
  400    CONTINUE
         SUMX = SUMX + XP
         SUMY = SUMY + YP
         SUMZ = SUMZ + ZP
         DIP(1,K) = SUMX
         DIP(2,K) = SUMY
         DIP(3,K) = SUMZ
  500 CONTINUE
      NUMC=0
      DO 600 K=1,LNA
        DO 700 I=1,NAT
          DISTSQ=(DIP(1,K)-C(1,I))*(DIP(1,K)-C(1,I))+
     *           (DIP(2,K)-C(2,I))*(DIP(2,K)-C(2,I))+
     *           (DIP(3,K)-C(3,I))*(DIP(3,K)-C(3,I))
          DIST=SQRT(DISTSQ)
          IF(DIST.LT.THRESH)NUMC=NUMC+1
  700   CONTINUE
  600 CONTINUE
      IF (MASWRK) WRITE(IW,9020)NUMC
      IF(IFCORE.EQ.1)THEN
C
C  LET'S NOT DOUBLECOUNT THE CORES.
C  ALSO, IFCORE IS TO BE SET TO 0.
C
        NOUTA=NOUTA+LNA-NUMC
        DO 800 I=1,NOUTA
           MOOUTA(I)=I
  800   CONTINUE
        IFCORE=0
      ELSE
C
C  CORES ARE NOT SKIPPED BY LOCALIZATION,
C  BUT THE FROZEN MO-S ARE
C
        NOUTA=LNA
        DO 810 I=1,NOUTA
           MOOUTA(I)=I
  810   CONTINUE
        IFCORE=0
      END IF
      IF (MASWRK) WRITE(IW,9030)NOUTA,(MOOUTA(I),I=1,NOUTA)
      RETURN
C
 9020 FORMAT(/1X,'GAMESS COUNTED ',I3,' CORES AMONG YOUR FROZEN MOS.'/
     * 1X,'IF THIS NUMBER IS TOO LOW (HIGH) PLEASE DECREASE (INCREASE)'/
     * 1X,'NOUTA AND CORRESPONDINGLY MODIFY MOOUTA IN $LOCAL')
 9030 FORMAT(/1X,'THE FORMAL ADJUSTED LOCALIZATION PARAMETERS ARE:'/
     * 1X,'FCORE=.F. NOUTA=',I3,' MOOUTA =',(10I4),/)
      END
C*MODULE GUESS   *DECK RDMIMO
      SUBROUTINE RDMIMO(VEC,L1)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      CHARACTER*8 STVEC
C
      DIMENSION VEC(L1,L1)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
 9020 FORMAT(28H NO $VEC INPUT FOUND - STOP )
 9040 FORMAT(I2,I3,5E15.8)
 9060 FORMAT(' *** ERROR READING THE MO COEFFICIENTS AT',2I4/
     *       '     THE INPUT VALUES WERE',2I4)
 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            DEFAULT FOR NMOS IS L1
C
      NMOS = L1
      STVEC = ' $VEC   '
      NSTM=0
      NUM1= L1
C
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               $VEC CARD NOT FOUND, KILL JOB
C
      IF (MASWRK) WRITE(IW,9020)
      CALL ABRT
      STOP
C
C               $VEC CARD FOUND, READ THE ORBITALS
C
  200 CONTINUE
      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
C SLAVE WORK
C
      ELSE
         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
      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*MODULE GUESS   *DECK SYMDNS
      SUBROUTINE SYMDNS(V,DA,LABMO,IWRK,Q,SCR,S,OCCNO,IA,
     *                  L0,L1,L2,L3,LL1,NPASS)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION V(L1,L1),DA(L2),LABMO(L1),IWRK(L1),
     *          Q(L3),SCR(L1),S(L2),OCCNO(L1),IA(L2)
C
      PARAMETER (MXSH=5000, MXATM=2000)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      COMMON /FMCOM / XX(1)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                TT(432),INVT(48),NT
C
      IF (NT .EQ. 1) RETURN
C     SYMMETRIZE DENSITY
      CALL SYMH(DA,Q,IA)
C     DON'T WANT TO THINK ABOUT MOROKUMA OPTION
      IF(LL1 .NE. L1) RETURN
C     GET SCRATCH SPACE MEMORY
      CALL VALFM(LOADFM)
      ISYMDEN1 = LOADFM + 1
      ISYMDEN2 = ISYMDEN1 + L3
      LAST = ISYMDEN2 + 8*L1
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
C     READ IN Q AND S
      CALL DAREAD(IDAF,IODA,Q,L3,45,0)
      CALL DAREAD(IDAF,IODA,S,L2,12,0)
      CALL EXPND(S,XX(ISYMDEN1),L1,0)
C
C     V=SQ=S-DAGGER*Q
C
      CALL MRTRBR(XX(ISYMDEN1),L1,L1,L1,Q,L1,L1,V,L1)  ! V=SQ=S-DAGGER*Q
C
C     TRANSFORM DENSITY TO Q BASIS BY RHO(QBASIS) = (SQ)-DAGGER RHO (SQ)
C     DIAGONALIZE DENSITY (WHICH IS IN Q BASIS), TO GET ORBITALS
C
      CALL TFTRI(XX(ISYMDEN1),DA,V,SCR,L1,L1,L1)
      CALL SYMDIA(XX(ISYMDEN1),V,SCR,XX(ISYMDEN2),IWRK,L1,L2,L1)
C
C     REVERSE MO ORDER TO BE CORRECT (2,...,2,1,...,1,0,...,0)
C     NOTE THAT WITHIN 2,2,2 BLOCK, THE ORBITALS ARE IN RANDOM ORDER
C     THEY ARE NOT IN ANY SORT OF ENERGY ORDERING.
C
      DO I=1,INT(L1/2)
        DO J=1,L1
          DUMMY=V(J,I)
          V(J,I)=V(J,L1-I)
          V(J,L1-I)=DUMMY
        END DO
      END DO
C     BACK TRANSFORM VECTORS TO AO BASIS
      CALL TFSQB(V,Q,SCR,L1,L1,L1)
C     ASSIGN SYMMETRY LABELS
      CALL DAREAD(IDAF,IODA,S,L2,12,0)
      CALL SYMMOS(LABMO,Q,S,V,SCR,L0,L1,L0,L1)
      IF(NPASS.EQ.1) CALL DAWRIT(IDAF,IODA,LABMO,L1,255,1)
      IF(NPASS.EQ.2) CALL DAWRIT(IDAF,IODA,LABMO,L1,256,1)
C     REMAKE DENSITY
      CALL DMTX(DA,V,OCCNO,L1,L1,L1)
C     PRINT OUT NEW ORBITALS
      IF (MASWRK .AND. NPASS.EQ.1) WRITE(IW,9020)
      IF (MASWRK .AND. NPASS.EQ.2) WRITE(IW,*) ' BETA '
      IF (MASWRK) WRITE(IW,9022) (I,LABMO(I),I=1,L1)
C     RETURN MEMORY
      CALL RETFM(NEED)
 9020 FORMAT(/1X,'SYMMETRIES FOR ALL SYMMETRIZED ORBITALS FOLLOW.')
 9022 FORMAT(7(1X,I5,'=',A4))
      RETURN
      END
