C 08 AUG 07 - JHS - ADD PBFLAB TO COMMON BLOCK NUCMON
C 08 AUG 07 - JHS - REPLACE BFLAB LABEL FOR PROTONS WITH PBFLAB
C 25 OCT 06 - SPW - CHANGES FOR NEO VERSION 2
C 25 MAR 06 - CWS - NEW MODULE FOR NEO SYMMETRY
C
C*MODULE NEOSYM  *DECK NEOSYM
      SUBROUTINE NEOSYM(GAM,CHARR,TRACEP,TRACED,TRACEF,TRACEG)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL SOME,DBG,MASWRK,GOPARR,DSKWRK
C
      DIMENSION CHARR(48,14),TRACEP(48),TRACED(48),TRACEF(48),
     *          TRACEG(48),IDEG(5)
C
      PARAMETER (MXATM=2000, MXSH=5000, MXGTOT=20000)
C
      COMMON /FMCOM / X(1)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /NEOSHL/ NGAUSS,NGAUSE,NGAUSN,NTSHEL,NNUCSH
      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 /NUCMOI/ NUNIQN,IUNIQN(20),IUNIQT(20),NQMNUC,IQMNUC(20),
     *                IQNTYP(20),NUMNB,NUCST,NAUXNB,IAUXNB(20),NUMULT,
     *                NNA,NNB,NTAUXB
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(432),INVT(48),NT
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      DATA IDEG/1,3,6,10,15/
      DATA SALC   /8HSALC    /
C
      DBG  = MASWRK  .AND.  (NPRINT.EQ.1  .OR.  EXETYP.EQ.SALC)
      SOME = MASWRK
C
C     ---- DRIVER WHICH CALLS SUBROUTINES TO CALCULATE SALCS ----
C          FOR NUCLEAR ORBITALS
C
C        MEMORY ALLOCATIONS
C        THIS FORMULA FOR -MXCIPA- IS HOPEFULLY A OVERESTIMATE
C
      NSHLSV = NSHELL
      NSHELL = NTSHEL
      CALL BASCHK(LMAX)
      NSHELL = NSHLSV
      MXCIPA = MAX(2*NUMNB*NT*IDEG(LMAX+1),2000)
      NSH = NNUCSH
      L1 = NUMNB
      L3 = L1*L1
C
      CALL VALFM(LOADFM)
      LP     = LOADFM + 1
      LPI    = LP     + 45*45
      LPNORM = LPI    + 45*45
      LAST   = LPNORM + 45
C
      LGAMI  = LAST
      LGAMJ  = LGAMI  + 48*3*3*2
      LGAMK  = LGAMJ  + 48*3*3*2
      LCLB   = LGAMK  + 48*3*3*2
      LREPC  = LCLB   + 2*9*9*14*14
      LAST1  = LREPC  + 45*3*3*3*3*2
C
      LPR    = LAST
      LISGRP = LPR    + 45*45
      LCA    = LISGRP + NAT*6
      LSAO   = LCA    + NAT*45
      LISB   = LSAO   + L3
      LIPB   = LISB   + NSH*14
      LCCHAR = LIPB   + NSH*14
      LCC    = LCCHAR + 5*48
      LLAB   = LCC    + MXCIPA
      LLOC1  = LLAB   + MXCIPA*4
      LLOC2  = LLOC1  + NAT*5
      LIWRK1 = LLOC2  + NAT*5
      LIWRK2 = LIWRK1 + NAT
      LKLASS = LIWRK2 + NAT
      LIRPBS = LKLASS + NAT
      LAST2  = LIRPBS + L1*3
C
      LAST = MAX(LAST1,LAST2)
      NEED   = LAST - LOADFM -1
      CALL GETFM(NEED)
C
C     ----- GET -SALC- COEFFICIENTS -----
C
      CALL NUCIPA(X(LP),X(LPR),X(LPI),X(LPNORM),X(LISGRP),
     *          X(LCA),X(LSAO),
     *          X(LISB),X(LIPB),X(LCCHAR),X(LCC),X(LLAB),
     *          X(LLOC1),X(LLOC2),X(LIWRK1),X(LIWRK2),X(LKLASS),
     *          X(LIRPBS),GAM,CHARR,TRACEP,
     *          TRACED,TRACEF,TRACEG,
     *          NAT,L1,L3,NSH,MXCIPA,DBG,SOME)
      CALL RETFM(NEED)
      RETURN
      END
C
C*MODULE NEOSYM  *DECK NUCIPA
      SUBROUTINE NUCIPA(P,PR,PI,PNORM,ISGRP,CA,SAO,ISB,IPB,CCHAR,CC,LAB,
     *                LOC1,LOC2,IWRK1,IWRK2,KLASS,IRPBAS,
     *                GAM,CHARR,TRACEP,TRACED,TRACEF,
     *                TRACEG,NATM,L1,L3,NSH,MXCIPA,DBG,SOME)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL SKIP,DBG,SOME,ABEL
C
      INTEGER TOTCEN
C
      PARAMETER (MXATM=2000, MXSH=5000, MXGTOT=20000)
C
      DIMENSION P(45,45),PR(45,45),PI(45,45),PNORM(45),
     *          ISGRP(NATM,6),CA(NATM,45),SAO(L3),
     *          ISB(NSH,14),IPB(NSH,14),CCHAR(5,48),CC(MXCIPA),
     *          LAB(MXCIPA,4),LOC1(NATM,5),LOC2(NATM,5),
     *          IWRK1(NATM),IWRK2(NATM),IRPBAS(*),
     *          GAM(48,48),CHARR(48,14),
     *          TRACEP(48),TRACED(48),TRACEF(48),TRACEG(48),
     *          KLASS(NATM)
      DIMENSION ISG(6),KBB(5),SKIP(5),MP(5),MF(5),MIRP(5,14)
C
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /NEOSHL/ NGAUSS,NGAUSE,NGAUSN,NTSHEL,NNUCSH
      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 /NUCMOI/ NUNIQN,IUNIQN(20),IUNIQT(20),NQMNUC,IQMNUC(20),
     *                IQNTYP(20),NUMNB,NUCST,NAUXNB,IAUXNB(20),NUMULT,
     *                NNA,NNB,NTAUXB
      COMMON /SYMBLK/ NIRRED,NSALC,NSALC2,NSALC3,NSAFMO
      COMMON /SYMMOL/ GROUP,COMPLX,IGROUP,NAXIS,ILABMO,ABEL
      COMMON /SYMREP/ IRPNAM(14),IPA(14),LAMBDA(14),LAMBD0(14),
     *                IADDR1(14),IADDR2(14),IADDR3(14)
      COMMON /SYMSPD/ PTR(3,144),DTR(6,288),FTR(10,480),GTR(15,720)
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(432),INVT(48),NT
C
      COMMON /NSMBLK/ NUSLC,NUSLC2,NUSLC3
      COMMON /NSMREP/ IPANU(14)
C
      DATA CMPLX    /8HCOMPLEX /
      DATA MXSALC   /45/
      DATA MF       /0,1,4,10,20/
      DATA MP       /1,3,6,10,15/
      DATA TOL      /1.0D-10/
      DATA ZERO,HALF,ONE /0.0D+00,0.5D+00,1.0D+00/
C
C
C     ----- CIPA GENERATES COEFFICIENTS OF -----
C        SYMMETRY ADAPTED LINEAR COMBINATIONS
C
C     -----------------------------------------------
C     ----- BEWARE THAT THE -CIPA- COEFFICIENTS -----
C     ----- REFER TO THE SPHERICAL HARMONICS    -----
C     ----- BASIS, NOT TO THE CARTESIAN BASIS.  -----
C     -----------------------------------------------
C
CSPW  TOTCEN = NTAUXB + NUMULT - 1
      TOTCEN = NTAUXB + NQMNUC
      IF(DBG) THEN
         WRITE(6,*)' IN NUCIPA TOTCEN =',TOTCEN
C     -- NOW CHECK THAT WE ARE USING THE CORRECT NUCLEAR CENTERS --
         DO 1 III=1,TOTCEN
               II=IQMNUC(III)
               WRITE(6,*)'CENTER= IQMNUC=',III,II
    1 CONTINUE
      END IF
      DO 5 IRP=1,NIRRED
      DO 5 ISH=NSHELL+1,NTSHEL
      ISB(ISH,IRP)=0
    5 IPB(ISH,IRP)=0
      DO 10 I=1,5
      DO 10 IIAT=1,TOTCEN
             IAT=IQMNUC(IIAT)
      LOC1(IAT,I)=-1
   10 LOC2(IAT,I)=-1
C
C     ----- READ -PTR, DTR, FTR, GTR- MATRICES -----
C
      CALL DAREAD(IDAF,IODA,PTR,  432, 7,0)
      CALL DAREAD(IDAF,IODA,DTR, 1728, 8,0)
      CALL DAREAD(IDAF,IODA,FTR, 4800, 9,0)
      CALL DAREAD(IDAF,IODA,GTR,10800,10,0)
C
C     ----- GET TRACE OF -PTR, DTR, FTR, GTR- FOR EACH OPERATION -----
C
      DO 15 IT=1,NT
      N= 3*(IT-1)
      TRACEP(IT)=PTR(1,N+1)+PTR(2,N+2)+PTR(3,N+3)
      N= 6*(IT-1)
      TRACED(IT)=DTR(1,N+1)+DTR(2,N+2)+DTR(3,N+3)+
     1           DTR(4,N+4)+DTR(5,N+5)+DTR(6,N+6)
      N=10*(IT-1)
      TRACEF(IT)=FTR(1,N+1)+FTR(2,N+2)+FTR(3,N+3)+
     1           FTR(4,N+4)+FTR(5,N+5)+FTR(6,N+6)+
     1           FTR(7,N+7)+FTR(8,N+8)+FTR(9,N+9)+
     1           FTR(10,N+10)
      N=15*(IT-1)
      TRACEG(IT)=GTR(1,N+1)+GTR(2,N+2)+GTR(3,N+3)+
     1           GTR(4,N+4)+GTR(5,N+5)+GTR(6,N+6)+
     1           GTR(7,N+7)+GTR(8,N+8)+GTR(9,N+9)+
     1           GTR(10,N+10)+GTR(11,N+11)+GTR(12,N+12)+
     1           GTR(13,N+13)+GTR(14,N+14)+GTR(15,N+15)
   15 CONTINUE
C
C     ---- FOR EACH CENTER FIND SUBGROUP WHICH MAPS IT INTO ITSELF ----
C
      DO 66 IIAT=1,TOTCEN
            IAT=IQMNUC(IIAT)
C
      K1=1
      K2=1
      K3=1
      K4=1
      K5=1
      K6=1
      J1=0
      J2=0
      J3=0
      J4=0
      J5=0
      J6=0
      DO 64 IT=1,NT
C
C     ----- BUILD FIRST WORD -----
C
      IF(IT-24) 32,32,36
   32 IF(MAPCTR(IAT,IT).NE.IAT) GO TO 34
      J1=J1+K1
   34 K1=K1+K1
      GO TO 64
C
C     ----- BUILD SECOND WORD IF NEEDED -----
C
   36 IF(IT-48) 38,38,42
   38 IF(MAPCTR(IAT,IT).NE.IAT) GO TO 40
      J2=J2+K2
   40 K2=K2+K2
      GO TO 64
C
C     ----- BUILD THIRD WORD IF NEEDED -----
C
   42 IF(IT-72) 44,44,48
   44 IF(MAPCTR(IAT,IT).NE.IAT) GO TO 46
      J3=J3+K3
   46 K3=K3+K3
      GO TO 64
C
C     ----- BUILD FOURTH WORD IF NEEDED -----
C
   48 IF(IT-96) 50,50,54
   50 IF(MAPCTR(IAT,IT).NE.IAT) GO TO 52
      J4=J4+K4
   52 K4=K4+K4
      GO TO 64
C
C     ----- BUILD FIFTH WORD IF NEEDED -----
C
   54 IF(IT-120) 56,56,60
   56 IF(MAPCTR(IAT,IT).NE.IAT) GO TO 58
      J5=J5+K5
   58 K5=K5+K5
      GO TO 64
C
C     ----- BUILD SIXTH WORD IF NEEDED -----
C
   60 CONTINUE
      IF(MAPCTR(IAT,IT).NE.IAT) GO TO 62
      J6=J6+K6
   62 K6=K6+K6
C
   64 CONTINUE
C
C     ----- THESE SIX WORDS DESCRIBE THE ATOM CLASSES -----
C
      ISGRP(IAT,1)=J1
      ISGRP(IAT,2)=J2
      ISGRP(IAT,3)=J3
      ISGRP(IAT,4)=J4
      ISGRP(IAT,5)=J5
      ISGRP(IAT,6)=J6
   66 CONTINUE
C
      IC=0
      ICLASS=0
      DO 70 IAT=1,NAT
   70 KLASS(IAT)=0
      DO 80 IRP=1,NIRRED
   80 IPANU(IRP)=0
      DO 1000 IIAT=1,TOTCEN
              IAT=IQMNUC(IIAT)
C
      DO 110 IT=1,NT
      IF(MAPCTR(IAT,IT).GT.IAT) GO TO 1000
  110 CONTINUE
      IF(KLASS(IAT).NE.0) GO TO 1000
      ICLASS=ICLASS+1
      KLASS(IAT)=ICLASS
      DO 120 NQ=1,6
  120 ISG(NQ)=ISGRP(IAT,NQ)
C
C     ----- DETERMINE OTHER -P1- CENTERS IN SAME CLASS -----
C
      MINN=IIAT+1
      IF(MINN.GT.TOTCEN) GO TO 240
      DO 230 JJAT=MINN,TOTCEN
              JAT=IQMNUC(JJAT)
      DO 210 NQ=1,6
      IF(ISGRP(JAT,NQ).NE.ISG(NQ)) GO TO 230
  210 CONTINUE
      DO 220 IT=1,NT
      IF(MAPCTR(JAT,IT).GT.JAT) GO TO 230
  220 CONTINUE
      KLASS(JAT)=ICLASS
  230 CONTINUE
  240 CONTINUE
C
C     ----- CHECK WHICH ANGULAR MOMENTA ARE PRESENT ON THAT CENTER -----
C
      DO 250 KT=1,5
  250 SKIP(KT)=.TRUE.
      DO 260 ISH=NSHELL+1,NTSHEL
      JAT=KATOM(ISH)
      IF(KLASS(JAT).NE.ICLASS) GO TO 260
      KT=KTYPE(ISH)
      SKIP(KT)=.FALSE.
      IF(KMIN(ISH).EQ.1) SKIP(1)=.FALSE.
  260 CONTINUE
C
C     ----- FIND CHARACTERS OF REDUCIBLE REPRESENTATION.     -----
C     ----- EQUIVALENT CENTER IATOM WILL CONTRIBUTE ONLY TO  -----
C           CHARACTER OF OPERATIONS WHICH MAP IT INTO ITSELF.
C
      DO 310 IT=1,NT
      DO 310 KT=1,5
  310 CCHAR(KT,IT)=ZERO
C
      DO 350 JIAT=1,TOTCEN
             JAT=IQMNUC(JIAT)
      DO 320 IT=1,NT
      IF(MAPCTR(IAT,IT).EQ.JAT) GO TO 330
  320 CONTINUE
      GO TO 350
  330 CONTINUE
      DO 340 IT=1,NT
      IF(MAPCTR(JAT,IT).NE.JAT) GO TO 340
      CCHAR(1,IT)=CCHAR(1,IT)+ONE
      CCHAR(2,IT)=CCHAR(2,IT)+TRACEP(IT)
      CCHAR(3,IT)=CCHAR(3,IT)+TRACED(IT)
      CCHAR(4,IT)=CCHAR(4,IT)+TRACEF(IT)
      CCHAR(5,IT)=CCHAR(5,IT)+TRACEG(IT)
  340 CONTINUE
  350 CONTINUE
C
C     ----- DECOMPOSE REDUCIBLE REPRESENTATION -----
C           INTO IRREDUCIBLE REPRESENTATIONS.
C
C      -LOC1(ICLASS,ITYP)- = FIRST ADDRESS OF COEFFICIENTS FOR
C                            -ICLASS- AND -S,P,D,F,G- FUNCTIONS .
C      -LOC2(ICLASS,ITYP)- =  LAST ADDRESS OF COEFFICIENTS FOR
C                            -ICLASS- AND -S,P,D,F,G- FUNCTIONS .
C
C     ----- LOOP OVER ANGULAR MOMENTA -----
C
      DO 800 KT=1,5
      IF(SKIP(KT)) GO TO 800
      NF=MF(KT)
      NP=MP(KT)
      LOC1(ICLASS,KT)=IC
C
C     ----- LOOP OVER IRREPS. -----
C
      IRP0=0
      DO 750 IRP=1,NIRRED
      LL=LAMBDA(IRP)
      MIRP(KT,IRP)=0
C
      DUM=ZERO
      DO 570 IT=1,NT
  570 DUM=DUM+CCHAR(KT,IT)*CHARR(IT,IRP)
      DUM=DUM/NT
      IF(DUM.LT.TOL) GO TO 750
      NIRP=NINT(DUM)
      IF(COMPLX.EQ.CMPLX.AND.LL.EQ.2) NIRP=NIRP/2
      MIRP(KT,IRP)=NIRP
C
C     ----- IRREDUCIBLE REPRESENTATION IRP OCCURS -NIRP- TIMES. -----
C     ----- FORM PROJECTION MATRICES -P-                        -----
C
      DO 580 J=1,NP*LL
      DO 580 I=1,NP*LL
  580 P(I,J)=ZERO
C
      DO 610 IT=1,NT
      IF(MAPCTR(IAT,IT).NE.IAT) GO TO 610
      DO 600 LL1=1,LL
      DO 600 LL2=1,LL
      GM=(LL*GAM(IT,LL2+LL*(LL1-1)+IRP0))/NT
      DO 590 J=1,NP
      DO 590 I=1,NP
      IF(KT.EQ.1) DUM=GM
      IF(KT.EQ.2) DUM=GM*PTR(I,J+NP*(IT-1))
      IF(KT.EQ.3) DUM=GM*DTR(I,J+NP*(IT-1))
      IF(KT.EQ.4) DUM=GM*FTR(I,J+NP*(IT-1))
      IF(KT.EQ.5) DUM=GM*GTR(I,J+NP*(IT-1))
  590 P(I+NP*(LL1-1),J+NP*(LL2-1))=P(I+NP*(LL1-1),J+NP*(LL2-1))+DUM
  600 CONTINUE
  610 CONTINUE
C
C     ----- ORTHOGONALIZE COLUMNS OF -P- -----
C
      IF(COMPLX.EQ.CMPLX.AND.LL.EQ.2) THEN
         DO 620 J=1,NP
         DO 620 I=1,NP
            PR(I   ,J   )= P(I   ,J   )
            PI(I   ,J   )=-P(I+NP,J   )
            PR(I+NP,J   )= ZERO
            PI(I+NP,J   )= ZERO
            PR(I+NP,J+NP)= P(I+NP,J+NP)
            PI(I+NP,J+NP)=-P(I   ,J+NP)
            PR(I   ,J+NP)=ZERO
            PI(I   ,J+NP)=ZERO
  620       CONTINUE
                 CALL SYMSMC(PR,PI,PNORM,NP*LL,MXSALC)
         DO 630 J=1,NP
         DO 630 I=1,NP
            P(I   ,J   )= HALF * ( PR(I   ,J   ) + PR(I+NP,J+NP))
            P(I+NP,J   )= HALF * (-PI(I   ,J   ) + PI(I+NP,J+NP))
            P(I   ,J+NP)=ZERO
  630       P(I+NP,J+NP)=ZERO
      ELSE
                 CALL SYMSMD(P ,PNORM,NP*LL,MXSALC)
      END IF
C
C     ----- EXTRACT -NIRP- SYMMETRY ADAPTED VECTOR COMPONENTS -----
C
      IPA0=0
      DO 690 J=1,NP*LL
      IF(PNORM(J).LT.TOL.OR.IPA0.GE.NIRP) GO TO 690
      IPA0    =IPA0    +1
      IPANU(IRP)=IPANU(IRP)+1
C
C     ----- LOOP OVER PARTNERS IN -IRREP- -----
C
      DO 680 L=1,LL
C
C     ----- PACK AND STORE COMPONENTS -----
C
      DO 670 I=1,NP
      IC=IC+1
      IF(IC.GT.MXCIPA) THEN
         IF(SOME) WRITE(IW,9986) MXCIPA
         CALL ABRT
         STOP
      END IF
C
C     -I1- SERIAL NUMBER OF FUNCTION WITHIN SHELL WHICH HAS THIS COEF.
C     -I2- SERIAL NUMBER OF -REP- WITHIN -IRREP- SET
C     -I3- -IRREP-
C     -I4- PARTNER IN -IRREP-
C     NOTE THAT -I2- CAN EXCEED 8 BITS WITH LARGE BASIS SETS
C
      I1=NF+I
      I2=IPANU(IRP)
      I3=IRP
      I4=L
      LAB(IC,1)=I1
      LAB(IC,2)=I2
      LAB(IC,3)=I3
      LAB(IC,4)=I4
C
      DUM=P(I+NP*(L-1),J)
      IF( ABS(DUM).LT.TOL) DUM=ZERO
      CC(IC)=DUM
  670 CONTINUE
  680 CONTINUE
C
  690 CONTINUE
C
C     ----- ACCOUNT FOR OTHER SHELLS WHICH HAVE -----
C           THE EXACT SAME CONTRIBUTIONS.
C
      NIPA= NIRP
      NIPB=-NIPA
      DO 740 ISH=NSHELL+1,NTSHEL
      IF(KLASS(KATOM(ISH)).NE.KLASS(IAT)               ) GO TO 740
      IF(KTYPE(ISH).EQ.KT                              ) GO TO 700
      IF(KTYPE(ISH).EQ.2.AND.KMIN(ISH).EQ.1.AND.KT.EQ.1) GO TO 720
      GO TO 740
  700 NIPB=NIPB+NIPA
      IPB(ISH,IRP)=NIPB
      DO 710 IT=1,NT
      JSH=MAPSHL(ISH,IT)
  710 IPB(JSH,IRP)=NIPB
      GO TO 740
  720 NIPB=NIPB+NIPA
      ISB(ISH,IRP)=NIPB
      DO 730 IT=1,NT
      JSH=MAPSHL(ISH,IT)
  730 ISB(JSH,IRP)=NIPB
  740 CONTINUE
C
      IPANU(IRP)=IPANU(IRP)+NIPB
C
C     ----- END LOOP OVER IRREPS -----
C
  750 IRP0=IRP0+LL*LL
      LOC2(ICLASS,KT)=IC
C
C     ----- END OF LOOP OVER ANGULAR MOMENTUM TYPES -----
C
  800 CONTINUE
C
      DO 810 KT=1,5
  810 KBB(KT)=LOC1(ICLASS,KT)
      JCLASS=ICLASS
C
C     ----- ROTATE COEFFICIENTS ONTO EQUIVALENT CENTERS -----
C
      DO 950 IT=1,NT
C
C     ----- FIND EQUIVALENT CENTER -----
C
      JAT=MAPCTR(IAT,IT)
      IF(KLASS(JAT).NE.0) GO TO 950
      ICLASS=ICLASS+1
      KLASS(JAT)=ICLASS
C
C     ----- FIND OTHER CENTERS IN SAME CLASS -----
C
      DO 820 II=1,TOTCEN
              I=IQMNUC(II)
      IF(KLASS(I).NE.JCLASS) GO TO 820
      J=MAPCTR(I,IT)
      KLASS(J)=ICLASS
  820 CONTINUE
C
      DO 900 KT=1,5
      IF(SKIP(KT)) GO TO 900
      NP=MP(KT)
      LOC1(ICLASS,KT)=IC
      KB=KBB(KT)
C
      IRP0=0
      DO 890 IRP=1,NIRRED
      LL=LAMBDA(IRP)
      NIRP=MIRP(KT,IRP)
      IF(NIRP.EQ.0) GO TO 890
      DO 880 J=1,NIRP
C
      DO 870 L=1,LL
      DO 860 I=1,NP
C
      IC=IC+1
      IF(IC.GT.MXCIPA) THEN
         WRITE(IW,9986) MXCIPA
         CALL ABRT
         STOP
      END IF
C
      DUM=ZERO
      D=ZERO
      DO 850 M=1,LL
      DO 850 K=1,NP
      IF(KT.EQ.1) D=ONE
      IF(KT.EQ.2) D=PTR(I,K+NP*(IT-1))
      IF(KT.EQ.3) D=DTR(I,K+NP*(IT-1))
      IF(KT.EQ.4) D=FTR(I,K+NP*(IT-1))
      IF(KT.EQ.5) D=GTR(I,K+NP*(IT-1))
      DUM=DUM+D*CC(K+NP*(M-1)+KB)*GAM(IT,M+LL*(L-1)+IRP0)
  850 CONTINUE
      IF( ABS(DUM).LT.TOL) DUM=ZERO
C
      CC(IC)=DUM
      LAB(IC,1)=LAB(I+NP*(L-1)+KB,1)
      LAB(IC,2)=LAB(I+NP*(L-1)+KB,2)
      LAB(IC,3)=LAB(I+NP*(L-1)+KB,3)
      LAB(IC,4)=LAB(I+NP*(L-1)+KB,4)
  860 CONTINUE
  870 CONTINUE
C
      KB=KB+NP*LL
  880 CONTINUE
C
  890 IRP0=IRP0+LL*LL
C
      LOC2(ICLASS,KT)=IC
C
C     ----- END LOOP OVER ANGULAR MOMENTA -----
C
  900 CONTINUE
C
C     ----- END LOOP OVER EQUIVALENT CENTERS -----
C
  950 CONTINUE
C
C     ----- END OF LOOP OVER UNIQUE CENTERS -----
C
 1000 CONTINUE
      NCC=IC
C
      DO 1040 I=NSHELL+1,NTSHEL
      DO 1040 J=1,NIRRED
      ISB(I,J)=ISB(I,J)+1
 1040 IPB(I,J)=IPB(I,J)+1
C
C     ----- GENERATE INITIAL ADDRESS OF SYMMETRY BLOCKS -----
C          ( THIS MAY GET MODIFIED IN -SALCAO- )
C
      J=0
      K=0
      L=0
      DO 1050 I=1,NIRRED
      LL=LAMBDA(I)
      N =IPANU(I)*LL
      IADDR1(I)=J
      J=J+N
      K=K+N*(N+1)/2
      L=L+N*N
 1050 CONTINUE
      NUSLC =J
C
C     ----- PRINT -SALC- BASIS FUNCTIONS -----
C
      CALL NSLCPR(CA,CC,LAB,LOC1,LOC2,IWRK1,KLASS,
     *            NATM,NCC,MXCIPA,DBG,TOTCEN)
C
C     ----- SET UP -SALC- MATRIX -----
C
      CALL SALCNO(CA,SAO,ISB,IPB,CC,LAB,LOC1,LOC2,IWRK1,IWRK2,
     *            KLASS,IRPBAS,NATM,L1,L3,NSH,NCC,MXCIPA,DBG,TOTCEN)
C
      RETURN
 9986 FORMAT(23H TOO MANY CIPAS. MAX = ,I5)
      END
C*MODULE NEOSYM  *DECK SALCNO
      SUBROUTINE SALCNO(CA,SAO,ISB,IPB,CC,LAB,LOC1,LOC2,MAPC,MAPS,
     *                  KLASS,IRPBAS,NATM,L1,L3,NSH,NCC,MXCIPA,
     *                  DBG,TOTCEN)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL DBG,ABEL
C
      INTEGER TOTCEN
C
      PARAMETER (MXATM=2000, MXSH=5000, MXGTOT=20000)
C
      DIMENSION CA(NATM,45),SAO(L3),ISB(NSH,14),IPB(NSH,14),
     *          CC(MXCIPA),LAB(MXCIPA,4),LOC1(NATM,5),LOC2(NATM,5),
     *          MAPC(NATM),MAPS(NATM),KLASS(NATM),IRPBAS(L1,3)
      DIMENSION MP(5)
C
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /NEOSHL/ NGAUSS,NGAUSE,NGAUSN,NTSHEL,NNUCSH
      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 /NUCMOI/ NUNIQN,IUNIQN(20),IUNIQT(20),NQMNUC,IQMNUC(20),
     *                IQNTYP(20),NUMNB,NUCST,NAUXNB,IAUXNB(20),NUMULT,
     *                NNA,NNB,NTAUXB
      COMMON /SYMBLK/ NIRRED,NSALC,NSALC2,NSALC3,NSAFMO
      COMMON /SYMMOL/ GROUP,COMPLX,IGROUP,NAXIS,ILABMO,ABEL
      COMMON /SYMREP/ IRPNAM(14),IPP(14),LAMBDA(14),LAMBD0(14),
     *                IADDR1(14),IADDR2(14),IADDR3(14)
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(432),INVT(48),NT
C
      COMMON /NSMBLK/ NUSLC,NUSLC2,NUSLC3
      COMMON /NSMREP/ IPANU(14)
C
      DATA CMPLX /8HCOMPLEX /
      DATA ZERO  /0.0D+00/
      DATA MP    /1,3,6,10,15/
C
C     ----- ROUTINE SETS UP MATRIX OF -SALC- NUCLEAR ORBITALS -----
C
      DO 10 I=1,NUMNB*NUMNB
   10 SAO(I)=ZERO
      IPA0=0
C
C     ----- LOOP OVER -P1- CENTERS -----
C
      DO 210 IIAT=1,TOTCEN
             IAT=IQMNUC(IIAT)
      DO 20 IT=1,NT
      IF(MAPCTR(IAT,IT).GT.IAT) GO TO 210
   20 CONTINUE
C
      DO 30 JJAT=1,TOTCEN
             JAT=IQMNUC(JJAT)
   30 MAPC(JAT)=0
      DO 40 IT=1,NT
      JAT=MAPCTR(IAT,IT)
   40 MAPC(JAT)=1
      ICLASS=KLASS(IAT)
C
C     ----- LOOP OVER SHELL TYPES ON -P1- CENTER -----
C
      DO 200 KT=1,5
      NP=MP(KT)
C
      ISH=NSHELL
   50 ISH=ISH+1
      IF(ISH.GT.NTSHEL) GO TO 200
      IF(KATOM(ISH).NE.IAT) GO TO 50
      IF(KTYPE(ISH).EQ.KT ) GO TO 60
      IF(KT.EQ.1.AND.KTYPE(ISH).EQ.2.AND.KMIN(ISH).EQ.1) GO TO 60
      GO TO 50
C
   60 CONTINUE
      DO 70 IT=1,NT
      JSH=MAPSHL(ISH,IT)
      JAT=KATOM(JSH)
   70 MAPS(JAT)=JSH
C
      KA=LOC1(ICLASS,KT)
      KAA=KA
      KB=LOC2(ICLASS,KT)
  100 CONTINUE
C
      I1=LAB(KA+1,1)
      I2=LAB(KA+1,2)
      I3=LAB(KA+1,3)
      I4=LAB(KA+1,4)
C
      IRP=I3
      IF(            KTYPE(ISH).EQ.KT                   )
     1 IPA0=IPB(ISH,IRP)
      IF(KT.EQ.1.AND.KTYPE(ISH).EQ. 2.AND.KMIN(ISH).EQ.1)
     1 IPA0=ISB(ISH,IRP)
      IPA=I2+IPA0-1
      LL=LAMBDA(IRP)
C
C     ----- GET -SALC- FOR SHELL ON -P1- CENTER -----
C
      MAX=NP*LL
      DO 110 I=1,MAX
  110 CA(IAT,I)=CC(KA+I)
      LOCI=KLOC(ISH)
      IF(KT.EQ.2.AND.KTYPE(ISH).EQ.2.AND.KMIN(ISH).EQ.1) LOCI=LOCI+1
      IC=0
      DO 115 L=1,LL
      DO 115 I=1,NP
      IC=IC+1
      IROW=(LOCI+I-1)
      LCOL=(IADDR1(IRP)+IPANU(IRP)*(L-1)+IPA-1)
      IL=IROW+NUMNB*LCOL
      DUM=CC(KA+IC)
  115 SAO(IL)=DUM
C
C     ----- NOW GET -SALC- FOR EQUIVALENT SHELLS AND CENTERS -----
C
      DO 130 JJAT=1,TOTCEN
              JAT=IQMNUC(JJAT)
      IF(MAPC(JAT).EQ.0) GO TO 130
      IF(JAT.EQ.IAT) GO TO 130
      JCLASS=KLASS(JAT)
      KC=LOC1(JCLASS,KT)+KA-KAA
      MAX=NP*LL
      DO 120 I=1,MAX
  120 CA(JAT,I)=CC(KC+I)
      JSH=MAPS(JAT)
      LOCJ=KLOC(JSH)
      IF(KT.EQ.2.AND.KTYPE(JSH).EQ.2.AND.KMIN(JSH).EQ.1) LOCJ=LOCJ+1
      JC=0
      DO 125 L=1,LL
      DO 125 J=1,NP
      JC=JC+1
      JROW=(LOCJ+J-1)
      LCOL=(IADDR1(IRP)+IPANU(IRP)*(L-1)+IPA-1)
      JL=JROW+NUMNB*LCOL
      DUM=CC(KC+JC)
  125 SAO(JL)=DUM
  130 CONTINUE
C
C     ----- CREATE SYMMETRY LABEL OF THE -SALC- BASIS FUNCTIONS -----
C
      DO 135 L=1,LL
         IRDEX=IADDR1(IRP)+IPANU(IRP)*(L-1)+IPA
         IRPBAS(IRDEX,1)=IRP
         IRPBAS(IRDEX,2)=LL
         IRPBAS(IRDEX,3)=L
  135 CONTINUE
C
C     ----- NOW PRINT -SALC- COMBINATIONS -----
C
C
      KA=KA+MAX
      IF(KA.LT.KB) GO TO 100
C
      GO TO 50
C
C     ----- END LOOP OVER SHELL TYPES ON -P1- CENTER -----
C     ----- END LOOP OVER -P1- CENTERS -----
C
  200 CONTINUE
  210 CONTINUE
C
C     ----- AT THIS POINT THE -SALC- COEFFICIENTS MAY BE -----
C            EXPRESSED IN THE SPHERICAL HARMONICS BASIS.
C            BACKTRANSFORM TO CARTESIAN GAUSSIAN BASIS.
C
C     ----- SAVE -SALC- MATRIX ON DAF -----
C
      NDUM=NUMNB*NUMNB
      CALL DAWRIT(IDAF,IODA,SAO,NDUM,452,0)
C
C     -----      SAVE TRUE -IRREP- DEGENERACY     -----
C           -LAMBDA- MAY BE CHANGED ( SEE BELOW )
C
      DO 225 IRP=1,NIRRED
  225 LAMBD0(IRP)=LAMBDA(IRP)
C
C     ----- SPECIAL CODE FOR COMPLEX REPRESENTATIONS:     -----
C           COMPLEX -E- (2D) OF DIMENSION - N- IS TREATED
C           AS REAL -E- (1D) OF DIMENSION -2N- .
C
      IF(COMPLX.NE.CMPLX) GO TO 300
C
      DO 230 IC=1,NCC
C
      I1=LAB(IC,1)
      I2=LAB(IC,2)
      I3=LAB(IC,3)
      I4=LAB(IC,4)
C
      IRP=I3
      IF(LAMBDA(IRP).NE.2.OR.I4.NE.2) GO TO 230
      I2=I2+IPANU(IRP)
      I4=1
C
      LAB(IC,1)=I1
      LAB(IC,2)=I2
      LAB(IC,3)=I3
      LAB(IC,4)=I4
  230 CONTINUE
C
      DO 240 IRP=1,NIRRED
         IF(LAMBDA(IRP).NE.2) GO TO 240
         LAMBDA(IRP)=1
         IPANU(IRP)=IPANU(IRP)*2
  240 CONTINUE
C
      IF(DBG) WRITE(IW,9990)
      IF(DBG) WRITE(6,*)'SYMMETRY SUBSPACES FOR SANMOS'
      IF(DBG) WRITE(IW,9996) (IRPNAM(I),IPANU(I),I=1,NIRRED)
C
C     ----- DETERMINE INITIAL ADDRESS OF SYMMETRY BLOCKS -----
C
  300 CONTINUE
      J=0
      K=0
      L=0
      DO 400 I=1,NIRRED
         LL=LAMBDA(I)
         N =IPANU(I)*LL
         IADDR1(I)=J
         J=J+N
         K=K+N*(N+1)/2
         L=L+N*N
  400 CONTINUE
      NUSLC =J
      RETURN
 9996 FORMAT(/,5X,'DIMENSIONS OF THE NUCLEAR SYMMETRY SUBSPACES ARE',
     1       /,8(1X,A4,I4),/,6(1X,A4,I4))
 9990 FORMAT(' FOR GROUPS WITH COMPLEX REPRESENTATIONS',
     1       ' THE -E- REPRESENTATIONS ARE NOW TREATED',/,
     2       ' AS -1D- REPRESENTATIONS WITH DOUBLED DIMENSION')
      END
C
C*MODULE NEOSYM  *DECK NSLCPR
      SUBROUTINE NSLCPR(CA,CC,LAB,LOC1,LOC2,MAPC,KLASS,
     *                  NATM,NCC,MXCIPA,DBG,TOTCEN)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL DBG
C
      INTEGER TOTCEN
C
      PARAMETER (MXATM=2000, MXSH=5000, MXGTOT=20000)
C
      DIMENSION CA(NATM,45),CC(NCC),
     *          LAB(MXCIPA,4),LOC1(NATM,5),LOC2(NATM,5),MAPC(NATM),
     *          KLASS(NATM)
      DIMENSION MP(5)
C
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /NEOSHL/ NGAUSS,NGAUSE,NGAUSN,NTSHEL,NNUCSH
      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 /NUCMOI/ NUNIQN,IUNIQN(20),IUNIQT(20),NQMNUC,IQMNUC(20),
     *                IQNTYP(20),NUMNB,NUCST,NAUXNB,IAUXNB(20),NUMULT,
     *                NNA,NNB,NTAUXB
      COMMON /SYMREP/ IRPNAM(14),IPP(14),LAMBDA(14),LAMBD0(14),
     *                IADDR1(14),IADDR2(14),IADDR3(14)
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(432),INVT(48),NT
C
      DATA MP  /1,3,6,10,15/
C
C     ----- ROUTINE PRINTS SYMMETRY ADAPTED LINEAR COMBINATIONS -----
C
      IF(DBG) WRITE(IW,9999)
C
C     ----- LOOP OVER -P1- CENTERS -----
C
      DO 210 IIAT=1,TOTCEN
             IAT=IQMNUC(IIAT)
      DO 10 IT=1,NT
      IF(MAPCTR(IAT,IT).GT.IAT) GO TO 210
   10 CONTINUE
C
      DO 20 JJAT=1,TOTCEN
            JAT=IQMNUC(JJAT)
   20 MAPC(JAT)=0
      DO 30 IT=1,NT
      JAT=MAPCTR(IAT,IT)
   30 MAPC(JAT)=1
      ICLASS=KLASS(IAT)
C
C     ----- LOOP OVER SHELL TYPES ON -P1- CENTER -----
C
      DO 200 KT=1,5
      NP=MP(KT)
C
      ISH=NSHELL
   40 ISH=ISH+1
      IF(ISH.EQ.NTSHEL) GO TO 200
      IF(KATOM(ISH).NE.IAT) GO TO 40
      IF(KTYPE(ISH).EQ.KT ) GO TO 50
      IF(KT.EQ.1.AND.KTYPE(ISH).EQ.2.AND.KMIN(ISH).EQ.1) GO TO 50
      GO TO 40
C
   50 CONTINUE
C
      KA=LOC1(ICLASS,KT)
      KAA=KA
      KB=LOC2(ICLASS,KT)
  100 CONTINUE
C
      I3=LAB(KA+1,3)
C
      IRP=I3
      LL=LAMBDA(IRP)
C
C     ----- GET -SALC- FOR SHELL ON -P1- CENTER -----
C
      MAX=NP*LL
      DO 110 I=1,MAX
  110 CA(IAT,I)=CC(KA+I)
C
C     ----- NOW GET -SALC- FOR EQUIVALENT SHELLS AND CENTERS -----
C
      DO 130 JJAT=1,TOTCEN
             JAT=IQMNUC(JJAT)
      IF(MAPC(JAT).EQ.0) GO TO 130
      IF(JAT.EQ.IAT) GO TO 130
      JCLASS=KLASS(JAT)
      KC=LOC1(JCLASS,KT)+KA-KAA
      MAX=NP*LL
      DO 120 I=1,MAX
  120 CA(JAT,I)=CC(KC+I)
  130 CONTINUE
C
C     ----- NOW PRINT -SALC- COMBINATION -----
C
      KA=KA+MAX
      IF(KA.LT.KB) GO TO 100
C
C     ----- END LOOP OVER SHELL TYPES ON -P1- CENTER -----
C
  200 CONTINUE
C
C     ----- END LOOP OVER -P1- CENTERS -----
C
  210 CONTINUE
      RETURN
C
 9999 FORMAT(/43H -- SYMMETRY ADAPTED LINEAR COMBINATIONS --/)
      END
C*MODULE NEOSYM  *DECK NUQSYM
      SUBROUTINE NUQSYM(S,WRK,Q,E,SCR,IWRK,L0,L1,L2,L3,DBG)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL DBG,GOPARR,DSKWRK,MASWRK,NXT,ABEL
      LOGICAL SYMNUC
C
      DIMENSION S(L2),WRK(L3),Q(L1,L1),E(L1),SCR(L1,8),IWRK(L1)
      DIMENSION NUCIA(2047)
C
C
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /SOOPT / NOSO
      COMMON /SYMBLK/ NIRRED,NSALC,NSALC2,NSALC3,NSAFMO
      COMMON /SYMMOL/ GROUP,COMPLX,IGROUP,NAXIS,ILABMO,ABEL
      COMMON /SYMREP/ IRPNAM(14),IPA(14),LAMBDA(14),LAMBD0(14),
     *                IADDR1(14),IADDR2(14),IADDR3(14)
C
      COMMON /INFON / NNQMT
      COMMON /NSMQMT/ NIRPLB(14),NIRPNM(14),NIRPDM(14),NIRPDG(14)
      COMMON /NSMBLK/ NUSLC,NUSLC2,NUSLC3
      COMMON /NSMREP/ IPANU(14)
      COMMON /NUCMOI/ NUNIQN,IUNIQN(20),IUNIQT(20),NQMNUC,IQMNUC(20),
     *                IQNTYP(20),NUMNB,NUCST,NAUXNB,IAUXNB(20),NUMULT,
     *                NNA,NNB,NTAUXB
      COMMON /SYMNEO/ QMTOLN,SYMNUC
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TENM5=1.0D-05,
     *           TEN9=1.0D+09)
C
      DATA CMPLX /8HCOMPLEX /
      TOL = QMTOLN
C
C     ----- GENERATE A SET OF SYMMETRY ADAPTED ORTHONORMAL ORBITALS ----
C     ON ENTRY, S MUST BE THE OVERLAP, AND IT WILL BE DESTROYED ON EXIT.
C     ON EXIT, Q WILL BE THE DESIRED ORTHONORMALIZING TRANSFORMATION.
C     ALL OTHER ARRAYS ARE JUST WORK ARRAYS TO THIS CODE.
C     NOTE: -WRK- IS USED AS BOTH SYMMETRIC -L2- AND SQUARE -L3-
C
      IF(NOSO.NE.0) THEN
         CALL NUQMATRX(S,Q,E,SCR,IWRK,L0,L1,L1,DBG)
         RETURN
      END IF
C
C     ----- READ -SALC- MATRIX AND TRANSFORM -S- -----
C
      CALL DAREAD(IDAF,IODA,Q,L3,452,0)
      CALL TFTRI(WRK,S,Q,SCR,NUSLC,L1,L1)
C
C     ----- DIAGONALIZE -S- IN THE -SALC- SPACE -----
C
      CALL VCLR(Q,1,L3)
      CALL VCLR(E,1,L1)
C
      DO 10 I = 1,NUMNB
        NUCIA(I) = I*(I-1)/2
  10  CONTINUE
C
      DO 20 IRP=1,NIRRED
         NIRPLB(IRP)=IRPNAM(IRP)
         NIRPNM(IRP)=IPANU(IRP)
         NIRPDM(IRP)=LAMBDA(IRP)
         NIRPDG(IRP)=LAMBD0(IRP)
   20 CONTINUE
C
C     ----- DIAGONALIZE UNIQUE BLOCKS -----
C
      NEXT = -1
      ILOOP = -1
      IPCOUNT = ME -1
      NXT = IBTYP.EQ.1
C
      IADD=0
      DO 110 IRP=1,NIRRED
         IDIM=NIRPDM(IRP)
         INUM=NIRPNM(IRP)
         IF (GOPARR) THEN
            IF (NXT) THEN
               ILOOP = ILOOP + 1
               IF (ILOOP.GT.NEXT) CALL DDI_DLBNEXT(NEXT)
               IF (NEXT.NE.ILOOP) GO TO 106
            ELSE
               IPCOUNT = IPCOUNT + 1
               IF (MOD(IPCOUNT,NPROC).NE.0) GO TO 106
            END IF
         END IF
         IF(INUM.EQ.0) GO TO 110
         DO 105 I=1,INUM
            DO 100 J=1,I
            WRK(NUCIA(I)+J)=WRK(NUCIA(I+IADD)+(J+IADD))
  100       CONTINUE
  105    CONTINUE
         CALL GLDIAG(L1,INUM,INUM,WRK,SCR,E(1+IADD),
     *               Q(1,1+IADD),IERR,IWRK)
         IF(IERR.NE.0) THEN
            IF(MASWRK) WRITE(IW,*) 'FAILURE IN -QMTSYM-, IRP=',IRP
            CALL ABRT
            STOP
         END IF
  106    CONTINUE
         IADD=IADD+INUM*IDIM
  110 CONTINUE
C
      IF(GOPARR) THEN
         CALL DDI_GSUMF(825,Q,L3)
         CALL DDI_GSUMF(826,E,L1)
         IF (NXT) CALL DDI_DLBRESET
      END IF
C
C     ----- FIX UP DEGENERATE BLOCKS -----
C
      IF(COMPLX.NE.CMPLX) THEN
C
C     -----        REAL IRREDUCIBLE REPRESENTATIONS ONLY        -----
C     ----- BLOCK FOR -Y- PARTNER IS CREATED FROM THE -X- BLOCK -----
C
         IADD=0
         DO 230 IRP=1,NIRRED
            IDIM=NIRPDM(IRP)
            INUM=NIRPNM(IRP)
            IF(INUM.EQ.0) GO TO 230
            IF(IDIM.GT.1) THEN
               DO 220 ILAM=1,IDIM
                  DO 210 J=1,INUM
                     E(J+IADD+INUM*(ILAM-1))=E(J+IADD)
                     DO 210 I=1,INUM
                        Q(I,J+IADD+INUM*(ILAM-1))=Q(I,J+IADD)
  210             CONTINUE
  220          CONTINUE
            END IF
            IADD=IADD+INUM*IDIM
  230    CONTINUE
      ELSE
C
C     -----      2D-IRREDUCIBLE REPRESENTATIONS ARE COMPLEX        -----
C     ----- IN THE -Q- MATRIX, -X- AND -Y- PARTNERS ARE INTERMIXED -----
C     -----     THE OTHER IRREDUCIBLE REPRESENTATIONS ARE REAL     -----
C     -----   BLOCK FOR -Y- PARTNER IS CREATED FROM THE -X- BLOCK  -----
C
         IADD=0
         DO 280 IRP=1,NIRRED
            IDIM=NIRPDM(IRP)
            IDEG=NIRPDG(IRP)
            INUM=NIRPNM(IRP)
            IF(INUM.EQ.0) GO TO 280
            IF(IDEG.EQ.2) THEN
               IMOD=INUM/2
               DO 250 J=1,INUM,2
                  DO 240 I=1,IMOD
                     Q(I+IMOD,J+1+IADD)= Q(I     ,J+IADD)
  240                Q(I     ,J+1+IADD)=-Q(I+IMOD,J+IADD)
  250          CONTINUE
            ELSE
               IF(IDIM.GT.1) THEN
                  DO 270 ILAM=1,IDIM
                     DO 260 J=1,INUM
                        E(J+IADD+INUM*(ILAM-1))=E(J+IADD)
                        DO 260 I=1,INUM
                           Q(I,J+IADD+INUM*(ILAM-1))=Q(I,J+IADD)
  260                CONTINUE
  270             CONTINUE
               END IF
            END IF
            IADD=IADD+INUM*IDIM
  280    CONTINUE
      END IF
C
C     ----- SET EIGENVECTOR MATRIX -----
C
      IADD=0
      DO 330 IRP=1,NIRRED
         IDIM=NIRPDM(IRP)
         INUM=NIRPNM(IRP)
         IF(INUM.EQ.0) GO TO 330
         DO 320 ILAM=1,IDIM
            IF(IADD.EQ.0) GO TO 320
            DO 310 J=1,INUM
            DO 310 I=1,INUM
               Q(INUM-I+1+IADD,J+IADD)=Q(INUM-I+1,J+IADD)
  310          Q(INUM-I+1     ,J+IADD)=ZERO
  320    IADD=IADD+INUM
  330 CONTINUE
C
C     ----- SIFT THE EIGENVALUES FOR SMALL VALUES -----
C
      IADD=0
      DO 420 IRP=1,NIRRED
         IDIM=NIRPDM(IRP)
         INUM=NIRPNM(IRP)
         IF(INUM.EQ.0) GO TO 420
         IRPZER=0
         DO 410 ISALC=1,INUM
            IF(E(ISALC+IADD).LT.TOL) THEN
               IRPZER=IRPZER+1
            END IF
  410    CONTINUE
         NIRPNM(IRP)=NIRPNM(IRP)-IRPZER
         IADD=IADD+INUM*IDIM
  420 CONTINUE
C
C     ----- ELIMINATE EIGENVECTORS FOR WHICH EIGENVALUE IS SMALL -----
C
      ESMALL= TEN9
      NSMALL= 0
      NWARN = 0
      EWARN = TENM5
      JSALC =0
      DO 520 ISALC=1,NUSLC
         IF(E(ISALC).LT.ESMALL) ESMALL=E(ISALC)
         IF(E(ISALC).LT.EWARN ) NWARN = NWARN+1
         IF(E(ISALC).GE.TOL   ) THEN
            JSALC=JSALC+1
            E(JSALC)=ONE/ SQRT(E(ISALC))
            DO 510 I=1,NUSLC
               Q(I,JSALC)=Q(I,ISALC)
  510       CONTINUE
         ELSE
            NSMALL=NSMALL+1
         END IF
  520 CONTINUE
C
      L0=NUSLC-NSMALL
      NNQMT=L0
      NWARN=NWARN-NSMALL
C
      IF(MASWRK  .AND.  NPRINT.NE.-5) THEN
         IF(L0.LT.L1)    WRITE(IW,9000) L1,L1-NUSLC,NSMALL,L0
         IF(NSMALL.GT.0) WRITE(IW,9010) ESMALL,NSMALL,TOL
         IF(NSMALL.GT.0) WRITE(IW,9020)
CCWS - SILENCE THIS STATEMENT FOR NOW
C        IF(NWARN .GT.0) WRITE(IW,9030) TOL,NWARN,EWARN
      END IF
C
C     ----- FORM CANONICAL ORTHONORMAL ORBITALS -----
C
C     DO 530 J=1,NSALC
C     DO 530 I=1,NSALC
      DO 530 J=1,NUSLC
      DO 530 I=1,NUSLC
        IF (J.GT.L0) Q(I,J)=ZERO
  530    Q(I,J)=Q(I,J)*E(J)
C
C     ----- BACK-TRANSFORM FROM -SALC- SPACE TO -AO- SPACE -----
C
      CALL DAREAD(IDAF,IODA,WRK,L3,452,0)
      CALL TFSQB(Q,WRK,SCR,NUSLC,L1,L1)
      RETURN
C
 9000 FORMAT(/1X,'STATISTICS FOR GENERATION OF SYMMETRY ORBITAL',
     *           ' -Q- MATRIX'/
     *       1X,'NUMBER OF CARTESIAN ATOMIC ORBITALS=     ',I6/
     *       1X,'NUMBER OF SPHERICAL CONTAMINANTS DROPPED=',I6/
     *       1X,'NUMBER OF LINEARLY DEPENDENT MOS DROPPED=',I6/
     *       1X,'TOTAL NUMBER OF MOS IN VARIATION SPACE=  ',I6)
 9010 FORMAT(/
     * 1X,'THE INPUT BASIS SET CONTAINS APPROXIMATE LINEAR DEPENDENCE.'/
     * 1X,'THE SMALLEST EIGENVALUE OF THE OVERLAP MATRIX IS',1P,E15.6/
     * 1X,'THERE ARE',I5,' EIGENVALUES LESS THAN QMTTOL=',1P,E10.2/
     * 1X,'EIGENVECTORS BELOW -QMTTOL- ARE DROPPED FROM THE MO SPACE,'/
     * 1X,'IN ORDER TO ELIMINATE THE APPROXIMATE LINEAR DEPENDENCE.')
 9020 FORMAT(/1X,'THIS WILL MOST LIKELY CHANGE THE ENERGY ON THE',
     *          ' ORDER OF TENS OF MICROHARTREES,'/
     *       1X,'DEPENDING ON THE NUMBER OF ORBITALS REMOVED.  THE',
     *          ' VALUE OF QMTTOL CAN BE '/
     *       1X,'CHANGED IN $CONTRL: JOBS WITH EIGENVALUES BELOW 1.0',
     *          'E-07 PROBABLY WON''T'/
     *       1X,'CONVERGE.  EIGENVALUES BETWEEN 1.0E-07 AND 1.0E-06',
     *          ' MAY REQUIRE LOOSENING OF'/
     *       1X,'THE -NCONV- DENSITY CRITERION IN $SCF, MORE ACCURATE',
     *          ' INTEGRAL EVALUATION'/
     *       1X,'(INTTYP=HONDO, ICUT=11, ITOL=30 IN $CONTRL), MORE',
     *          ' ACCURATE DIRECT SCF FOCK'/
     *       1X,'MATRIX FORMATION (FDIFF=.FALSE. IN $SCF), OR',
     *          ' CHANGING CONVERGERS'/
     *       1X,'(DIIS=.TRUE. SOSCF=.FALSE. IN $SCF).')
CCWS 9030 FORMAT(/20X,'* * * * * WARNING * * * * *'/
CCWS *     1X,'POSSIBLE LINEAR DEPENDENCE PROBLEMS DETECTED,',
CCWS *     1X,'INPUT QMTOLN=',1P,E8.1,','/1X,'WITH',I6,' OVERLAP',
CCWS *        ' EIGENVALUES LYING BETWEEN',1P,E8.1,' AND QMTOLN.'/
CCWS *     1X,'IF YOU EXPERIENCE SCF CONVERGENCE DIFFICULTIES WITH THE',
CCWS *        ' DENSITY ALMOST BUT'/1X,'NOT QUITE CONVERGED, YOU',
CCWS *        ' MAY NEED TO LOOSEN -QMTOLN- BY A FACTOR 5 TO 10.')
      END
C*MODULE NEOSYM  *DECK NUQMATRX
      SUBROUTINE NUQMATRX(S,Q,EIG,SCR,IWRK,L0,L1,LDQ,DBG)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION S(*),Q(LDQ,L1),EIG(L1),SCR(L1,8),IWRK(L1)
C
      LOGICAL DBG,GOPARR,DSKWRK,MASWRK
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (ONE=1.0D+00, TOL=1.0D-10,
     *           ZERO=0.0D+00, SMALL=1.0D-11)
C
C     ----- FIND CANONICAL ORTHONORMAL MO-S ------
C     THE "Q-MATRIX" SATISFIES Q-DAGGER * S * Q = I ON EXIT.
C     THE OVERLAP MATRIX -S- IS DESTROYED IN THE DIAGONALIZATION.
C     THE NUMBER OF LINEARLY INDEPENDENT EIGENVECTORS OF -S- IS
C     RETURNED BY -L0-, NOTE THAT THIS ROUTINE WILL KILL THE JOB
C     IN THE CASE THAT -L0- IS NOT EQUAL TO THE INPUT -L1-.
C     THE ARGUMENT -L3- IS UNUSED BY THIS ROUTINE.
C
C        DIAGONALIZE OVERLAP MATRIX
C
      IGERR = 0
      CALL GLDIAG(L1,L1,LDQ,S,SCR,EIG,Q,IGERR,IWRK)
      IF (IGERR .NE. 0) CALL ABRT
C
      IF(DBG) THEN
         WRITE(IW,9000)
         CALL PREVNL(Q,EIG,L1,L1,LDQ)
      END IF
C
C     ----- ELIMINATE EIGENVECTORS WITH SMALL EIGENVALUES -----
C
      DUM = EIG(1)
      J = 0
      K = 0
      DO 180 I = 1,L1
         IF (EIG(I) .LT. TOL) GO TO 160
            J = J+1
            EIG(J) = ONE/SQRT(EIG(I))
            CALL DCOPY(L1,Q(1,I),1,Q(1,J),1)
            GO TO 180
  160    K = K+1
  180 CONTINUE
C
      L0 = L1-K
C
      IF(K.NE.0) THEN
         IF (MASWRK) WRITE(IW,9010) DUM,K,TOL,L0
         CALL ABRT
      END IF
C
C     ----- FORM CANONICAL ORTHONORMAL ORBITALS -----
C
      DO 410 J=1,L0
         EJ = EIG(J)
         DO 400 I=1,L1
            QIJ=Q(I,J)
            QIJ=QIJ*EJ
            IF(ABS(QIJ).LT.SMALL) QIJ=ZERO
            Q(I,J)=QIJ
  400    CONTINUE
  410 CONTINUE
C
      IF(DBG) THEN
         WRITE(IW,9020)
         CALL PREVNL(Q,EIG,L0,L1,LDQ)
      END IF
      RETURN
C
 9000 FORMAT(/5X,17(1H-)/5X,'EIGENVECTORS OF S'/5X,17(1H-))
 9010 FORMAT(20H ..... WARNING ...../
     +     50H THE SMALLEST EIGENVALUE OF THE OVERLAP MATRIX IS ,F15.8/
     +     15H THERE IS(ARE) ,I5,25H EIGENVALUE(S) LESS THAN ,1P,E10.2/
     +     42H THE NUMBER OF CANONICAL ORBITALS KEPT IS ,I5)
 9020 FORMAT(/5X,30(1H-)/5X,'CANONICAL ORTHONORMAL ORBITALS'/5X,30(1H-))
      END
C*MODULE NEOSYM  *DECK NUSYMDIA
      SUBROUTINE NUSYMDIA(A,VEC,EIG,SCR,IWRK,L1,L2,LDV)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,NXT,ABEL
C
      DIMENSION A(L2),VEC(LDV,L1),EIG(L1),SCR(L1,8),IWRK(L1)
C
      PARAMETER (MXAO=8192)
C
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /SOOPT / NOSO
      COMMON /SYMBLK/ NIRRED,NSALC,NSALC2,NSALC3,NSAFMO
      COMMON /SYMMOL/ GROUP,COMPLX,IGROUP,NAXIS,ILABMO,ABEL
      COMMON /NSMQMT/ NIRPLB(14),NIRPNM(14),NIRPDM(14),NIRPDG(14)
C
      PARAMETER (ZERO=0.0D+00)
C
      DATA CMPLX /8HCOMPLEX /
C
C     ----- DIAGONALIZE -H- IN THE -SALC- SPACE -----
C     ON ENTRY, -A- IS ASSUMED TO HAVE BEEN TRANSFORMED WITH
C     THE -Q- MATRIX, SO THAT IT IS ALREADY BLOCK DIAGONAL.
C
      IF(NOSO.NE.0) THEN
         CALL GLDIAG(LDV,L1,L1,A,SCR,EIG,VEC,IERR,IWRK)
         RETURN
      END IF
C
      CALL VCLR(VEC,1,LDV*L1)
      CALL VCLR(EIG,1,L1)
C
C     ----- DIAGONALIZE UNIQUE BLOCKS -----
C     IN PARALLEL MODE, HAND DIFFERENT BLOCKS OFF TO EACH CPU
C
      NEXT = -1
      ILOOP = -1
      NXT = IBTYP.EQ.1
      IPCOUNT = ME - 1
C
      IADD=0
      DO 30 IRP=1,NIRRED
         IDIM=NIRPDM(IRP)
         INUM=NIRPNM(IRP)
         IF (GOPARR) THEN
            IF (NXT) THEN
               ILOOP = ILOOP + 1
               IF (ILOOP.GT.NEXT) CALL DDI_DLBNEXT(NEXT)
               IF (NEXT.NE.ILOOP) GO TO 26
            ELSE
               IPCOUNT = IPCOUNT + 1
               IF (MOD(IPCOUNT,NPROC).NE.0) GO TO 26
            END IF
         END IF
         IF(INUM.EQ.0) GO TO 30
         DO 25 I=1,INUM
            DO 20 J=1,I
               A(IA(I)+J)=A(IA(I+IADD)+(J+IADD))
   20       CONTINUE
   25    CONTINUE
         CALL GLDIAG(LDV,INUM,INUM,A,SCR,EIG(1+IADD),
     *               VEC(1,1+IADD),IERR,IWRK)
         IF(IERR.NE.0) THEN
            IF(MASWRK) WRITE(IW,*) 'FAILURE IN -SYMDIA-, IRP=',IRP
            CALL ABRT
            STOP
         END IF
   26    CONTINUE
         IADD=IADD+INUM*IDIM
   30 CONTINUE
C
      IF(GOPARR) THEN
         CALL DDI_GSUMF(800,VEC,LDV*L1)
         CALL DDI_GSUMF(801,EIG,    L1)
         IF (NXT) CALL DDI_DLBRESET
      END IF
C
      IF(NIRRED.GT.1) THEN
C
C     ----- FIX UP DEGENERATE BLOCKS -----
C
         IF(COMPLX.NE.CMPLX) THEN
C
C     -----        REAL IRREDUCIBLE REPRESENTATIONS ONLY        -----
C     ----- BLOCK FOR -Y- PARTNER IS CREATED FROM THE -X- BLOCK -----
C
            IADD=0
            DO 60 IRP=1,NIRRED
               IDIM=NIRPDM(IRP)
               INUM=NIRPNM(IRP)
               IF(INUM.EQ.0) GO TO 60
               IF(IDIM.GT.1) THEN
                  DO 50 ILAM=1,IDIM
                     DO 40 J=1,INUM
                         EIG(J+IADD+INUM*(ILAM-1))=EIG(J+IADD)
                         DO 40 I=1,INUM
                            VEC(I,J+IADD+INUM*(ILAM-1))=VEC(I,J+IADD)
   40                 CONTINUE
   50             CONTINUE
               END IF
               IADD=IADD+INUM*IDIM
   60       CONTINUE
         ELSE
C
C     -----      2D-IRREDUCIBLE REPRESENTATIONS ARE COMPLEX        -----
C     ----- IN THE -Q- MATRIX, -X- AND -Y- PARTNERS ARE INTERMIXED -----
C     -----     THE OTHER IRREDUCIBLE REPRESENTATIONS ARE REAL     -----
C     -----   BLOCK FOR -Y- PARTNER IS CREATED FROM THE -X- BLOCK  -----
C
            IADD=0
            DO 110 IRP=1,NIRRED
               IDIM=NIRPDM(IRP)
               IDEG=NIRPDG(IRP)
               INUM=NIRPNM(IRP)
               IF(INUM.EQ.0) GO TO 110
               IF(IDEG.EQ.2) THEN
                  DO 80 J=1,INUM,2
                     DO 70 I=1,INUM,2
                        VEC(I+1,J+1+IADD)= VEC(I  ,J+IADD)
   70                   VEC(I  ,J+1+IADD)=-VEC(I+1,J+IADD)
   80             CONTINUE
               ELSE
                  IF(IDIM.GT.1) THEN
                     DO 100 ILAM=1,IDIM
                        DO 90 J=1,INUM
                           EIG(J+IADD+INUM*(ILAM-1))=EIG(J+IADD)
                           DO 90 I=1,INUM
                              VEC(I,J+IADD+INUM*(ILAM-1))=VEC(I,J+IADD)
   90                   CONTINUE
  100                CONTINUE
                  END IF
               END IF
               IADD=IADD+INUM*IDIM
  110       CONTINUE
         END IF
C
C     ----- SET EIGENVECTOR MATRIX -----
C
         IADD=0
         DO 140 IRP=1,NIRRED
            IDIM=NIRPDM(IRP)
            INUM=NIRPNM(IRP)
            IF(INUM.EQ.0) GO TO 140
            DO 130 ILAM=1,IDIM
               IF(IADD.EQ.0) GO TO 130
               DO 120 J=1,INUM
               DO 120 I=1,INUM
                  VEC(INUM-I+1+IADD,J+IADD)=VEC(INUM-I+1,J+IADD)
  120             VEC(INUM-I+1     ,J+IADD)=ZERO
  130       IADD=IADD+INUM
  140    CONTINUE
C
C     --- REORDER EIGENVALUES FROM LARGE NEGATIVE TO LARGE POSITIVE ---
C
         DO 160 I=1,L1
         DO 160 J=I,L1
            IF(EIG(I).LE.EIG(J)) GO TO 160
            DUM   =EIG(I)
            EIG(I)=EIG(J)
            EIG(J)=DUM
            DO 150 K=1,L1
               DUM     =VEC(K,I)
               VEC(K,I)=VEC(K,J)
  150          VEC(K,J)=DUM
  160    CONTINUE
C
      END IF
C
      RETURN
      END
C*MODULE NEOSYM  *DECK NUSYMMOS
      SUBROUTINE NUSYMMOS(LABMO,Q,S,V,WRK,NQO,NAO,NMO,LDQV)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION Q(LDQV,NQO),S(*),V(LDQV,NMO),WRK(*),LABMO(*)
C
      CHARACTER*4 STRING
C
      LOGICAL MASWRK,GOPARR,DSKWRK,ABEL
C
      PARAMETER (MXSH=5000, MXATM=2000, MXAO=8192)
C
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /SOOPT / NOSO
      COMMON /SYMBLK/ NIRRED,NSALC,NSALC2,NSALC3,NSAFMO
      COMMON /SYMMOL/ GROUP,COMPLX,IGROUP,NAXIS,ILABMO,ABEL
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(432),INVT(48),NT
      COMMON /TRNMOM/ OPERR,SYMTOL,NOCC,NUMCI,NFZC,NUMVEC,ICI,MXRT,NSTAT
C
      COMMON /NSMQMT/ NIRPLB(14),NIRPNM(14),NIRPDM(14),NIRPDG(14)
C
      PARAMETER (ZERO=0.0D+00)
      DATA IQMARK,LETA,TRANST/4H????,4HA   ,8HTRANSITN/
C
C     ----- DETERMINE SYMMETRY LABELS FOR THE -V- MOS -----
C     THERE ARE -NMO- ORBITALS -V-, EXPANDED IN TERMS OF -NAO- AOS.
C     THERE ARE -NQO- CANONICAL VECTORS -Q-
C
C     FIRST, ASSIGN A STANDARD PHASE TO EACH ORBITAL
C
      CALL STFASE(V,LDQV,NAO,NMO)
C
      IF(NT.EQ.1) THEN
         DO 40 I=1,NMO
            LABMO(I) = LETA
  40     CONTINUE
         RETURN
      END IF
C
      IF(NOSO.NE.0  .OR.  ILABMO.EQ.0) THEN
         DO 50 I=1,NMO
            LABMO(I) = IQMARK
  50     CONTINUE
         RETURN
      END IF
C
      SMALL=1.0D-10
      IF(RUNTYP.EQ.TRANST) SMALL=SYMTOL*1.0D-04
C
C     CALCULATE Q-DAGGER*S*V , OVERWRITING -Q- IN THE PROCESS.
C
      DO 140 I=1,NQO
         DO 120 J=1,NAO
            DUM=ZERO
            DO 110 K=1,NAO
               KJ=IA(MAX(K,J))+MIN(K,J)
               DUM=DUM+Q(K,I)*S(KJ)
  110       CONTINUE
            WRK(J)=DUM
  120    CONTINUE
         DO 130 J=1,NAO
            Q(J,I)=WRK(J)
  130    CONTINUE
  140 CONTINUE
C
      DO 240 I=1,NQO
         DO 220 J=1,NMO
            DUM=ZERO
            DO 210 K=1,NAO
               DUM=DUM+Q(K,I)*V(K,J)
  210       CONTINUE
            WRK(J)=DUM
  220    CONTINUE
         DO 230 J=1,NMO
            Q(J,I)=WRK(J)
  230    CONTINUE
  240 CONTINUE
C
C     ----- ASSIGN SYMMETRY TO -V- ORBITALS ----
C     -Q- NOW HOLDS OVERLAP BETWEEN -V- AND -Q- ORBITAL SETS,
C     IF THE OVERLAP IS NONZERO, THE SYMMETRY TYPES ARE THE SAME.
C     IF AN ORBITAL IN V OVERLAPS WITH ORBITALS OF MORE THAN ONE
C     IRREP, IT HAS NO SYMMETRY, AND IS LABELED ACCORDING TO ITS
C     MAXIMUM OVERLAP WITH ANY Q VECTOR, WITH A ? PREPENDED.
C
      DO 350 I=1,NMO
         IQ=0
         LABMO(I)=0
         SMAX = ZERO
         DO 340 IRP=1,NIRRED
            DO 330 ID=1,NIRPDM(IRP)
               IF(NIRPNM(IRP).EQ.0) GO TO 330
               DO 320 IN=1,NIRPNM(IRP)
                  IQ=IQ+1
                  SVAL = ABS(Q(I,IQ))
                  IF(SVAL.GT.SMALL) THEN
                     IF(SVAL.GT.SMAX) THEN
                        SMAX = SVAL
                        IRPMX= IRP
                     END IF
                     IF(LABMO(I).EQ.0) THEN
                        LABMO(I)=NIRPLB(IRP)
                     ELSE
                        IF(LABMO(I).NE.NIRPLB(IRP)) LABMO(I)=IQMARK
                     END IF
                  END IF
  320          CONTINUE
  330       CONTINUE
  340    CONTINUE
         IF (LABMO(I).EQ.0) THEN
            IF(MASWRK) WRITE(IW,9999) I
            CALL ABRT
         END IF
C
C     TAKE BEST GUESS AT ANY ORBITAL WITH AMBIGOUS SYMMETRY.
C     IRREP NAMES ARE AT MOST THREE CHARACTERS LONG, SEE -SYMBOL-
C
         IF(LABMO(I).EQ.IQMARK) THEN
C           TELL SOC ABOUT THE MESS
            WRITE(UNIT=STRING,FMT='(''?'',A3)') NIRPLB(IRPMX)
            READ (UNIT=STRING,FMT='(A4)'      ) LABMO(I)
         END IF
  350 CONTINUE
      RETURN
 9999 FORMAT(/1X,'ERROR - MO ',I3,' WAS NOT ASSIGNED A SYMMETRY.'/
     *        1X,'MOST LIKELY CAUSE IS NULL ORBITAL VECTOR.')
      END
C*MODULE NEOSYM  *DECK PREVNUS
      SUBROUTINE PREVNUS(V,E,M,LDV,ISTART,IEND)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION V(LDV,M),E(M)
C
      COMMON /FMCOM / X(1)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /NUCMOI/ NUNIQN,IUNIQN(20),IUNIQT(20),NQMNUC,IQMNUC(20),
     *                IQNTYP(20),NUMNB,NUCST,NAUXNB,IAUXNB(20),NUMULT,
     *                NNA,NNB,NTAUXB
      COMMON /INFON / NNQMT
C
C     ----- PRINT OUT EIGENDATA WITH NUCLEAR-MO SYMMETRY LABELS -----
C     THE ROWS WILL BE LABELED WITH THE BASIS FUNCTION TAGS.
C     -V- IS N X M, WITH TRUE LEADING DIMENSION -LDV-
C
C     FIRST GRAB SOME MEMORY
C
      N0 = NNQMT
      N1 = NUMNB
      N2 = (N1*N1+N1)/2
      N3 = N1*N1
C
      CALL VALFM(LOADFM)
      LQ     = LOADFM + 1
      LS     = LQ + N3
      LWRK   = LS + N2
      LSCR   = LWRK + N1
      LAST   = LSCR + N1*8
      NEED   = LAST - LOADFM - 1
      CALL GETFM(NEED)
C
C     NOW READ IN S AND Q AND CALL NUSYMMOS TO GET LABELS
C     FOR NUCLEAR MO'S - SYMMETRY LABELS ARE STORED IN LWRK
C
      CALL DAREAD(IDAF,IODA,X(LQ),N3,443,0)
      CALL DAREAD(IDAF,IODA,X(LS),N2,441,0)
C
      CALL NUSYMMOS(X(LWRK),X(LQ),X(LS),V,X(LSCR),N0,N1,N0,N1)
      CALL NUSYMVEC(V,E,M,LDV,ISTART,IEND,X(LWRK))
C
      CALL RETFM(NEED)
      RETURN
      END
C*MODULE NEOSYM  *DECK NUSYMVEC
      SUBROUTINE NUSYMVEC(V,E,M,LDV,ISTART,IEND,NUCLAB)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      CHARACTER*8 QNUN,QNN
      CHARACTER*10 PBFLAB
C
      DIMENSION V(LDV,M),E(M),NUCLAB(M)
C
      PARAMETER (MXAO=8192)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /NUCMON/ QNUN(20),QNN(20),PBFLAB(MXAO)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C     ----- PRINT OUT EIGENDATA WITH NUCLEAR-MO SYMMETRY LABELS -----
C     THE ROWS WILL BE LABELED WITH THE BASIS FUNCTION TAGS.
C     -V- IS N X M, WITH TRUE LEADING DIMENSION -LDV-
C
      IF (MASWRK) THEN
      MAX = 5
      IF (NPRINT .EQ. 6) MAX = 10
      IMAX = 0
C
  100 IMIN = IMAX+1
      IMAX = IMAX+MAX
      IF (IMAX .GT. M) IMAX = M
      WRITE (IW,9008)
      WRITE (IW,9028) (I,I = IMIN,IMAX)
      WRITE (IW,9068) (E(I),I = IMIN,IMAX)
      WRITE (IW,9078) (NUCLAB(I),I=IMIN,IMAX)
      J = 0
      DO 120 IDX = ISTART,IEND
         J = J + 1
         WRITE (IW,9048) J,PBFLAB(IDX),(V(J,I),I = IMIN,IMAX)
  120 CONTINUE
      IF (IMAX .LT. M) GO TO 100
      ENDIF
      RETURN
C
 9008 FORMAT(1X)
 9028 FORMAT(17X,10(4X,I4,3X))
 9048 FORMAT(I5,2X,A10,10F11.6)
 9068 FORMAT(17X,10F11.4)
 9078 FORMAT(18X,10(5X,A4,2X))
      END
