C 20 AUG 07 - DGF - SYNCHRONISE FMOOPT, FMORUN
C 24 MAR 07 - MWS - SYMOFF: RESET IRPXXX DATA TO C1 VALUES
C 22 NOV 06 - DGF - SYNCHRONISE FMOOPT AND FMORUN
C 19 NOV 06 - SHY - SYMOR2: CORRECT THE DIMENSION FOR REPC
C 19 SEP 05 - SPW - SYMOR2: ADD NEO HOOKS
C  5 JUL 05 - MWS - SELECT NEW ATOM,BASIS,EFP,PCM,DAF DIMENSIONS
C 30 APR 05 - DGF - MODIFY Q-MATRIX IN FMO, SYNCHRONISE SYMBLK
C 13 FEB 05 - MWS - PAD COMMON BLOCK NSHEL
C  5 FEB 05 - MWS - QMTSYM: CHANGE WORDING OF INTEGRAL ADVICE
C  9 DEC 03 - MWS - SYNCH COMMON BLOCK RUNOPT
C  7 AUG 02 - MWS - SYMOFF,SYMON: RESTORE IRREP DIMENSIONS/NAMES
C 24 JAN 02 - DGF - PROVIDE MORE STORAGE FOR CIPA CALL
C 25 OCT 01 - BTA - PROVIDE IRREP NAMES FOR NAXIS=7 AND 8 GROUPS
C 19 NOV 00 - MWS - FIX DIMENSION IN SOSYM COMMON
C 26 OCT 00 - MWS - INTRODUCE MXAO PARAMETER
C 16 FEB 00 - MWS - SYMDIA: ELIMINATE IVIB CUTOUT KLUDGE
C 21 DEC 99 - DGF - SYMBOL,DSYMBL: NAME UGLY DUCKLING GROUPS IRREPS,
C                   GENERATE IRREP INFORMATON FOR DOUBLE GROUPS,
C                   SYMMOS: SAVE SYM INFO FOR SOC
C 13 MAR 99 - MWS - SYMOFF: ENSURE NIRP1 IS INITIALIZED IF C1 GROUP
C 13 FEB 99 - MAF - ADD ROUTINES SYMOFF AND SYMON
C 11 JAN 98 - MAF - QMTSYM: CHANGE WARNING MESSAGE'S TEXT
C 12 NOV 98 - MAF - QMTSYM; SYMOR2: ACTIVATE MICHEL'S SPHERICAL HARMONIC
C                   CODE, REMOVE L0<L1 ERROR MESSAGES, FIX CIPA CALL
C 22 APR 98 - MWS - SYMMOS: C1 SHOULD LABEL W/O ANY MATRIX MULTIPLY
C 13 MAR 98 - MWS - SYMMOS: RETURN Q-MARKS IF GROUP IS NOT SUPPORTED
C 20 NOV 97 - MWS - QMTSYM: ADD ADDITIONAL HINTS TO WARNING MESSAGE
C 28 SEP 97 - MWS - CONVERT PARALLEL CALLS FROM TCGMSG TO DDI
C 14 AUG 97 - MWS - SYMOR2: PASS ADDITIONAL MEMORY TO CIPA
C 29 JUL 97 - MWS - QMTSYM: CHANGE WARNING MESSAGE TO INCLUDE HINTS
C 18 DEC 96 - DGF - SYMBOL: FIX IRREP NAMES FOR D4D AND D5D
C 17 OCT 96 - MWS - SYMBOL,SYMMOS: MAKE GUESS AT "IRREP" OF ASYMM. MOS
C  5 MAR 96 - MWS - CHANGE SHELL SYMMETRY PACKING COMMONS
C 11 NOV 94 - MWS - REMOVE FTNCHEK WARNINGS
C 10 AUG 94 - MWS - INCREASE NUMBER OF DAF RECORDS
C 30 NOV 93 - MWS - STFASE: WORKAROUND FOR AIX'S IDAMAX BUG
C 16 JUL 93 - GJA - SYMMOS: ASSIGN ?? TO INDETERMINATE SYMMETRY MOS
C 14 MAY 93 - MWS - QMTSYM: IMPROVE LINEAR DEPENDENCE ERROR MSG.
C  5 NOV 92 - MWS - SYMOR2: PASS EXTRA STORAGE TO CIPA
C 16 SEP 92 - MWS - QMTSYM,SYMDIA,SYMMOS: INSERT WORKAROUND FOR WHAT
C                   SEEMS TO BE A BUG INVOLVING COMPLEX IRREPS
C 20 MAR 92 - MWS,TLW - NEW CODE FROM MICHEL, WITH PARALLEL BLOCK DIAG
C
C*MODULE SYMORB  *DECK ABELPT
      LOGICAL FUNCTION ABELPT()
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXSH=5000, MXATM=2000)
C
      LOGICAL ABEL
C
      COMMON /SYMMOL/ GROUP,COMPLEX,IGROUP,NAXIS,ILABMO,ABEL
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(432),INVT(48),NT
C
C        RETURN -TRUE- FOR ABELIAN POINT GROUPS
C        THERE IS NO CALLING ARGUMENT.
C
      IF(NT.EQ.1) GO TO 1
C
      IF(IGROUP.LE.3) GO TO 1
      IF(IGROUP.EQ.5) GO TO 2
      IF(IGROUP.LE.9) GO TO 3
      ABELPT=.FALSE.
      RETURN
C
C       C1, CS, OR CI
C
    1 CONTINUE
      ABELPT = .TRUE.
      RETURN
C
C        S2N IS CI FOR N=1
C
    2 CONTINUE
      IF(NAXIS.LE.1) THEN
         ABELPT=.TRUE.
      ELSE
         ABELPT=.FALSE.
      END IF
      RETURN
C
C        CN, CNH, CNV, DN, OR DNH
C
    3 CONTINUE
      IF(NAXIS.LE.2) THEN
         ABELPT=.TRUE.
      ELSE
         ABELPT=.FALSE.
      END IF
      RETURN
      END
C*MODULE SYMORB  *DECK ICOSYM
      SUBROUTINE ICOSYM(SOME)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL SOME
C
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
C
      IF(SOME) WRITE(IW,9999)
      CALL ABRT
      STOP
C
 9999 FORMAT(' THE -ICOS- GROUP IS NOT INCLUDED.',/,
     1 ' NOTE THAT UP TO NOW THE LARGEST IRREP. DIMENSION IS = 3 .',/,
     2 ' THE PROGRAM MAY HAVE DIFFICULTIES HANDLING -G- AND -H- ',
     3 ' IRREPS,',/,' ESPECIALLY FOR THE MULTIPLICATION TABLE ')
      END
C*MODULE SYMORB  *DECK QMTSYM
      SUBROUTINE QMTSYM(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
C
      DIMENSION S(L2),WRK(L3),Q(L1,L1),E(L1),SCR(L1,8),IWRK(L1)
C
      PARAMETER (MXATM=2000, MXAO=8192)
C
      COMMON /BASSPH/ QMTTOL,ISPHER
      COMMON /FMOINF/ NFG,NLAYER,NATFMO,NBDFG,NAOTYP,NBODY
      COMMON /FMOOPT/ ESPSCA(9),RESPAP(2),RESPPC(2),RESDIM,RESTRI(4),
     *                RCORSD,RESPCT,CONVFG,CNVDMP,COROFF,IXESP,MXITFG,
     *                NGUESS,NBSSE,MODORB,MODPAR,IRSTSTP,IRSTLAY,NPRFMO,
     *                NFMOPAL,MODPRP,MAXL1C,IPIEDA,MODGRD,MODESP,IVMUL
      COMMON /FMORUN/ ESPSCF,E0SCF(2),IDAFMO,ICURLAY,ICURFG,JCURFG,
     *                KCURFG,NCURSH,NGAU,ICURPOP,IFMOSTP,MONCOR,NAT1E,
     *                NEEDR,MODRST,NORBPROJ,NUNESP,ISKIPESP,ICURUNT
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      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 /SYMQMT/ IRPLAB(14),IRPNUM(14),IRPDIM(14),IRPDEG(14)
      COMMON /SYMREP/ IRPNAM(14),IPA(14),LAMBDA(14),LAMBD0(14),
     *                IADDR1(14),IADDR2(14),IADDR3(14)
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TENM5=1.0D-05,
     *           TEN9=1.0D+09)
C
      DATA CMPLX /8HCOMPLEX /
      TOL = QMTTOL
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
C     FMO (WITH MBSD) PRODUCES THE Q MATRIX ELSEWHERE AND STORES
C     IT IN THE SALC RECORD (SINCE Q AND SALC ARE THE SAME IN THIS
C     CASE), EXCEPT WHEN THE Q MATRIX IS GENERATED FOR THE ORIGINAL
C     BASIS SET, WHICH HAPPENS IN
C         A) HUCKEL GUESS, B) WHEN FMO Q MATRIX IS CONSTRUCTED.
C
      IF(NFG.NE.0.AND.IAND(IXESP,256).NE.0.AND.IFMOSTP.GT.1) THEN
         L0=NQMT
C        WRITE(6,*) 'WWWSA',L0,NQMT
         CALL DAREAD(IDAF,IODA,Q,L3,45,0)
         RETURN
      ENDIF
C
      IF(NOSO.NE.0) THEN
         CALL QMATRX(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,44,0)
      CALL TFTRI(WRK,S,Q,SCR,NSALC,L1,L1)
C
C     ----- DIAGONALIZE -S- IN THE -SALC- SPACE -----
C
      CALL VCLR(Q,1,L3)
      CALL VCLR(E,1,L1)
C
      DO 20 IRP=1,NIRRED
         IRPLAB(IRP)=IRPNAM(IRP)
         IRPNUM(IRP)=IPA(IRP)
         IRPDIM(IRP)=LAMBDA(IRP)
         IRPDEG(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=IRPDIM(IRP)
         INUM=IRPNUM(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(IA(I)+J)=WRK(IA(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=IRPDIM(IRP)
            INUM=IRPNUM(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=IRPDIM(IRP)
            IDEG=IRPDEG(IRP)
            INUM=IRPNUM(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=IRPDIM(IRP)
         INUM=IRPNUM(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=IRPDIM(IRP)
         INUM=IRPNUM(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
               IF(DBG) THEN
                  WRITE(IW,9900) ISALC,IRP,IRPLAB(IRP),E(ISALC+IADD)
                  WRITE(IW,9910) (I,Q(I,ISALC+IADD),I=1,NSALC)
               END IF
            END IF
  410    CONTINUE
         IRPNUM(IRP)=IRPNUM(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,NSALC
         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,NSALC
               Q(I,JSALC)=Q(I,ISALC)
  510       CONTINUE
         ELSE
            NSMALL=NSMALL+1
         END IF
  520 CONTINUE
C
      L0=NSALC-NSMALL
      NQMT=L0
      NWARN=NWARN-NSMALL
C
      IF(MASWRK  .AND.  NPRINT.NE.-5) THEN
         IF(L0.LT.L1)    THEN
           NSPHER=L1-NSALC
           IF(NFG.NE.0) NSPHER=L1-NSAFMO
           WRITE(IW,9000) L1,NSPHER,NSMALL
           IF(NFG.NE.0.AND.NSALC.NE.NSAFMO) WRITE(IW,9003) NSAFMO-NSALC
           WRITE(IW,9005) L0
         ENDIF
         IF(NSMALL.GT.0) WRITE(IW,9010) ESMALL,NSMALL,TOL
         IF(NSMALL.GT.0) WRITE(IW,9020)
         IF(NWARN .GT.0) WRITE(IW,9030) TOL,NWARN,EWARN
      ELSE
         IF(MASWRK.AND.NFG.NE.0.AND.NSALC.NE.NSAFMO)
     *     WRITE(IW,9003) NSAFMO-NSALC
         IF(MASWRK.AND.NSMALL.GT.0) WRITE(IW,9010) ESMALL,NSMALL,TOL
      END IF
C
C     ----- FORM CANONICAL ORTHONORMAL ORBITALS -----
C
      DO 530 J=1,NSALC
      DO 530 I=1,NSALC
        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,44,0)
      CALL TFSQB(Q,WRK,SCR,NSALC,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)
 9003 FORMAT(1X,'NUMBER OF FMO REDUNDANT MOS DROPPED=     ',I6)
 9005 FORMAT(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.0E-07 PROBABLY WON''T'/
     *       1X,'CONVERGE.  EIGENVALUES BETWEEN 1.0E-07 AND 1.0E-06',
     *          ' MAY REQUIRE LOOSENING OF'/
     *       1X,'THE DENSITY CRITERION (CONV IN $SCF), MORE ACCURATE',
     *          ' INTEGRAL EVALUATION'/
     *       1X,'(ICUT=11 IN $CONTRL), MORE ACCURATE DIRECT SCF FOCK',
     *          ' MATRIX'/
     *       1X,'CONSTRUCTION (FDIFF=.FALSE. IN $SCF), OR CHANGING THE',
     *          ' SCF CONVERGER'/
     *       1X,'(DIIS=.TRUE. IN $SCF).')
 9030 FORMAT(/20X,'* * * * * WARNING * * * * *'/
     *     1X,'POSSIBLE LINEAR DEPENDENCE PROBLEMS DETECTED,',
     *     1X,'INPUT QMTTOL=',1P,E8.1,','/1X,'WITH',I6,' OVERLAP',
     *        ' EIGENVALUES LYING BETWEEN',1P,E8.1,' AND QMTTOL.'/
     *     1X,'IF YOU EXPERIENCE SCF CONVERGENCE DIFFICULTIES WITH THE',
     *        ' DENSITY ALMOST BUT'/1X,'NOT QUITE CONVERGED, YOU',
     *        ' MAY NEED TO LOOSEN -QMTTOL- BY A FACTOR 5 TO 10.')
 9900 FORMAT(' -- IN -QMTSYM- ELIMINATED VECTOR = ',I3,
     1       ' IN -IRREP- = ',I2,' WITH LABEL = ',A4,
     2       ' AND E = ',E15.8)
 9910 FORMAT(8(I5,1X,F9.4))
      END
C*MODULE SYMORB  *DECK SLCSPH
      SUBROUTINE SLCSPH(IPA,IRPNM,MAPC,NP,LL,KT,CA,NATM)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXATM=2000)
C
      DIMENSION MAPC(NATM),CA(NATM,45)
      DIMENSION MF(5),NAM(35)
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)
C
      DATA MF  /0,1,4,10,20/
      DATA NAM /4H  S ,4H  P1,4H  P2,4H  P3,4H  D1,4H  D2,4H  D3,
     1          4H  D4,4H  D5,4H D S,4H  F1,4H  F2,4H  F3,4H  F4,
     2          4H  F5,4H  F6,4H  F7,4HF P1,4HF P2,4HF P3,4H  G1,
     3          4H  G2,4H  G3,4H  G4,4H  G5,4H  G6,4H  G7,4H  G8,
     4          4H  G9,4H G S,4HG D1,4HG D2,4HG D3,4HG D4,4HG D5/
C
C     ----- ROUTINE PRINTS -SALC- EXPRESSED -----
C     ----- IN SPHERICAL HARMONICS BASIS.   -----
C
      K=0
      DO 30 L=1,LL
      WRITE(IW,9998) IPA,IRPNM,L
      DO 20 N=1,NAT
      IF(MAPC(N).EQ.0) GO TO 20
      ID=MF(KT)
      MAXNP=0
   10 MINNP=MAXNP+1
      MAXNP=MAXNP+6
      IF(MAXNP.GT.NP) MAXNP=NP
      WRITE(IW,9997) (CA(N,K+I),NAM(ID+I),N,I=MINNP,MAXNP)
      IF(MAXNP.LT.NP) GO TO 10
   20 CONTINUE
   30 K=K+NP
      RETURN
C
 9998 FORMAT(5H PSI(,I4,A4,1H,,I1,2H)=)
 9997 FORMAT(12X,6(F8.4,1X,A4,I3))
      END
C*MODULE SYMORB  *DECK SLCXYZ
      SUBROUTINE SLCXYZ(IPA,IRPNM,MAPC,NP,LL,KT,CA,NATM)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXATM=2000)
C
      DIMENSION MAPC(NATM),CA(NATM,45)
      DIMENSION MF(5),NAM(35)
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)
C
      DATA MF  /0,1,4,10,20/
      DATA NAM /4H  S ,4H  X ,4H  Y ,4H  Z ,4H  XX,4H  YY,4H  ZZ,
     1          4H  XY,4H  XZ,4H  YZ,4H XXX,4H YYY,4H ZZZ,4H XXY,
     2          4H XXZ,4H YYX,4H YYZ,4H ZZX,4H ZZY,4H XYZ,4HXXXX,
     3          4HYYYY,4HZZZZ,4HXXXY,4HXXXZ,4HYYYX,4HYYYZ,4HZZZX,
     4          4HZZZY,4HXXYY,4HXXZZ,4HYYZZ,4HXXYZ,4HYYXZ,4HZZXY/
C
C     ----- ROUTINE PRINTS -SALC- EXPRESSED -----
C     ----- IN SPHERICAL HARMONICS BASIS.   -----
C
      K=0
      DO 30 L=1,LL
      WRITE(IW,9998) IPA,IRPNM,L
      DO 20 N=1,NAT
      IF(MAPC(N).EQ.0) GO TO 20
      ID=MF(KT)
      MAXNP=0
   10 MINNP=MAXNP+1
      MAXNP=MAXNP+6
      IF(MAXNP.GT.NP) MAXNP=NP
      WRITE(IW,9997) (CA(N,K+I),NAM(ID+I),N,I=MINNP,MAXNP)
      IF(MAXNP.LT.NP) GO TO 10
   20 CONTINUE
   30 K=K+NP
      RETURN
C
 9998 FORMAT(5H PSI(,I4,A4,1H,,I1,2H)=)
 9997 FORMAT(12X,6(F8.4,1X,A4,I3))
      END
C*MODULE SYMORB  *DECK SPHXYZ
      SUBROUTINE SPHXYZ(IPA,IRPNM,MAPC,NP,LL,KT,CA,NATM)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXATM=2000)
C
      DIMENSION MAPC(NATM),CA(NATM,45)
      DIMENSION MF(5),NAM(35),CX(45)
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 /SPHERI/ PSHELL(3,3),DSHELL(6,6),
     *                FSHELL(10,10),GSHELL(15,15),
     *                PIHELL(3,3),DIHELL(6,6),
     *                FIHELL(10,10),GIHELL(15,15)
C
      DATA MF  /0,1,4,10,20/
      DATA NAM /4H  S ,4H  X ,4H  Y ,4H  Z ,4H  XX,4H  YY,4H  ZZ,
     1          4H  XY,4H  XZ,4H  YZ,4H XXX,4H YYY,4H ZZZ,4H XXY,
     2          4H XXZ,4H YYX,4H YYZ,4H ZZX,4H ZZY,4H XYZ,4HXXXX,
     3          4HYYYY,4HZZZZ,4HXXXY,4HXXXZ,4HYYYX,4HYYYZ,4HZZZX,
     4          4HZZZY,4HXXYY,4HXXZZ,4HYYZZ,4HXXYZ,4HYYXZ,4HZZXY/
      DATA ZERO /0.0D+00/
C
C     ----- NOW PRINT -SALC- COMBINATION AFTER -----
C           BACK-TRANSFORMATION FROM SPHERICAL
C           HARMONICS BASIS TO CARTESIAN BASIS
C
      K=0
      DO 900 L=1,LL
      WRITE(IW,9998) IPA,IRPNM,L
      DO 800 N=1,NAT
      IF(MAPC(N).EQ.0) GO TO 800
      ID=MF(KT)
C
C     ----- BACK TRANSFORMATION -----
C
      GO TO (100,200,300,400,500),KT
C
C     ---- S,P FUNCTIONS ----
C
  100 DO 110  KX=1,3
      CX(KX) = CA(N,K+KX)
  110 CONTINUE
      GO TO 600
C
C     ---- P FUNCTIONS ----
C
  200 DO 210 KX=1,3
      CX(KX)=ZERO
      DO 210 JX=1,3
      CX(KX) = CX(KX) + CA(N,K+JX) * PSHELL(KX,JX)
  210 CONTINUE
      GO TO 600
C
C     ---- D FUNCTIONS ----
C
  300 DO 310 KX=1,6
      CX(KX)=ZERO
      DO 310 JX=1,6
      CX(KX) = CX(KX) + CA(N,K+JX) * DSHELL(KX,JX)
  310 CONTINUE
      GO TO 600
C
C     ---- F FUNCTIONS ----
C
  400 DO 410 KX=1,10
      CX(KX)=ZERO
      DO 410 JX=1,10
      CX(KX) = CX(KX) + CA(N,K+JX) * FSHELL(KX,JX)
  410 CONTINUE
      GO TO 600
C
C     ---- G FUNCTIONS ----
C
  500 DO 510 KX=1,15
      CX(KX)=ZERO
      DO 510 JX=1,15
      CX(KX) = CX(KX) + CA(N,K+JX) * GSHELL(KX,JX)
  510 CONTINUE
C
  600 CONTINUE
C
C     ----  PRINTING  ----
C
      MAXNP=0
  700 MINNP=MAXNP+1
      MAXNP=MAXNP+6
      IF(MAXNP.GT.NP) MAXNP=NP
       WRITE(IW,9997) (CX(I),NAM(ID+I),N,I=MINNP,MAXNP)
      IF(MAXNP.LT.NP) GO TO 700
C
  800 CONTINUE
  900 K=K+NP
      RETURN
C
 9998 FORMAT(5H PSI(,I4,A4,1H,,I1,2H)=)
 9997 FORMAT(12X,6(F8.4,1X,A4,I3))
      END
C*MODULE SYMORB  *DECK STFASE
      SUBROUTINE STFASE(A,LDA,N,M)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (ZERO=0.0D+00)
      DIMENSION A(LDA,M)
C
C        SET THE PHASE OF EACH COLUMN OF A MATRIX SO THE LARGEST
C        ELEMENT IS POSITIVE
C
      DO 140 I = 1,M
         LARGE = IDAMAX(N,A(1,I),1)
         IF(LARGE.LE.0) LARGE=1
         IF(LARGE.GT.N) LARGE=1
         IF (A(LARGE,I) .LT. ZERO) THEN
            DO 120 J = 1,N
               A(J,I) = -A(J,I)
  120       CONTINUE
         END IF
  140 CONTINUE
      RETURN
      END
C*MODULE SYMORB  *DECK SYMBOL
      SUBROUTINE SYMBOL(IRPNAM,SOME)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL SOME,ABEL,GOPARR,DSKWRK,MASWRK
C
      DIMENSION IRPNAM(14)
C
      INTEGER A,AP,APP,A1,A2,AG,AU
      INTEGER A1P,A2P,A1PP,A2PP,A1G,A2G,A1U,A2U
      INTEGER B,BG,BU,B1,B2,B3,B1G,B2G,B3G,B1U,B2U,B3U
      INTEGER E,E1,E2,E3,E4,E5,E6,E7,EG,EU
      INTEGER EP,EPP,E1P,E2P,E1PP,E2PP,E3P,E3PP
      INTEGER E1G,E2G,E1U,E2U,E3G,E3U
      INTEGER F,FG,FU,F1,F2,F1G,F1U,F2G,F2U,G,H,GG,GU,HG,HU
C
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /SYMMOL/ GROUP,COMPLX,IGROUP,NAXIS,ILABMO,ABEL
C
      DATA A,AP,APP,A1,A2,AG,AU,A1P,A2P,A1PP,A2PP,A1G,A2G,A1U,A2U
     1 /4HA   ,4HA'  ,4HA'' ,4HA1  ,
     2  4HA2  ,4HAG  ,4HAU  ,4HA1' ,
     3  4HA2' ,4HA1" ,4HA2" ,4HA1G ,
     4  4HA2G ,4HA1U ,4HA2U /
C
      DATA B,BG,BU,B1,B2,B3,B1G,B2G,B3G,B1U,B2U,B3U
     1 /4HB   ,4HBG  ,4HBU  ,4HB1  ,
     2  4HB2  ,4HB3  ,4HB1G ,4HB2G ,
     3  4HB3G ,4HB1U ,4HB2U ,4HB3U /
C
      DATA E,E1,E2,E3,EG,EU,EP,EPP,
     1 E1P,E2P,E3P,E1PP,E2PP,E3PP,
     2 E1G,E2G,E1U,E2U,E4,E5,E6,E7,E3G,E3U
     3 /4HE   ,4HE1  ,4HE2  ,4HE3  ,
     4  4HEG  ,4HEU  ,4HE'  ,4HE'' ,
     5  4HE1' ,4HE2' ,4HE3' ,4HE1" ,4HE2" ,
     6  4HE3" ,4HE1G ,4HE2G ,4HE1U ,4HE2U ,
     7  4HE4  ,4HE5  ,4HE6  ,4HE7  ,4HE3G ,4HE3U /
C
      DATA F,FG,FU,F1,F2,F1G,F1U,F2G,F2U,G,H,GG,GU,HG,HU
     1 /4HF   ,4HFG  ,4HFU  ,4HF1  ,
     2  4HF2  ,4HF1G ,4HF1U ,4HF2G ,
     3  4HF2U ,4HG   ,4HH   ,4HGG  ,
     4  4HGU  ,4HHG  ,4HHU  /
C
C     ----- DEFINE THE NAMES OF IRREDUCIBLE REPRESENTATIONS -----
C     IF THIS IS NOT POSSIBLE, SET -ILABMO- TO 0
C
      ILABMO=1
C
      IF(IGROUP.GE.13) GO TO 2000
C
C     -IGROUP- IS A POINTER INTO THE FOLLOWING TABLE,
C     C1,CS,CI,CN,S2N,CNH,CNV,DN,DNH,DND,CINFV,DINFH,T,TH,TD,O,OH,I,IH
C     GROUPS 11,12 ARE THUS CINFV,DINFH AND NEVER GET HERE.
C
      GO TO (100,200,300,400,500,600,700,800,900,1000),IGROUP
C
C     -- C1 -
C
  100 IRPNAM(1)=A
      RETURN
C
C     -- CS -
C
  200 IRPNAM(1)=AP
      IRPNAM(2)=APP
      RETURN
C
C     -- CI -
C
  300 IRPNAM(1)=AG
      IRPNAM(2)=AU
      RETURN
C
C     -- CN -
C
  400 CONTINUE
      IF(NAXIS.GT.13) THEN
         IF(MASWRK) WRITE(IW,*) 'ROTATION AXIS TOO HIGH FOR -CN-'
         CALL ABRT
      END IF
      GO TO (410,420,430,440,450,460,470,480,490,495,495,495,495),NAXIS
  410 IRPNAM(1)=A
      RETURN
  420 IRPNAM(1)=A
      IRPNAM(2)=B
      RETURN
  430 IRPNAM(1)=A
      IRPNAM(2)=E
      RETURN
  440 IRPNAM(1)=A
      IRPNAM(2)=B
      IRPNAM(3)=E
      RETURN
  450 IRPNAM(1)=A
      IRPNAM(2)=E1
      IRPNAM(3)=E2
      RETURN
  460 IRPNAM(1)=A
      IRPNAM(2)=B
      IRPNAM(3)=E1
      IRPNAM(4)=E2
      RETURN
  470 IRPNAM(1)=A
      IRPNAM(2)=E1
      IRPNAM(3)=E2
      IRPNAM(4)=E3
      RETURN
  480 IRPNAM(1)=A
      IRPNAM(2)=B
      IRPNAM(3)=E1
      IRPNAM(4)=E2
      IRPNAM(5)=E3
      RETURN
  490 IRPNAM(1)=A
      IRPNAM(2)=E1
      IRPNAM(3)=E2
      IRPNAM(4)=E3
      IRPNAM(5)=E4
      RETURN
  495 IF(SOME) WRITE(IW,9495) 'CN',10
      CALL DSYMBL(IRPNAM,'K')
      RETURN
C
C     -- S2N -
C
  500 CONTINUE
      IF(NAXIS.GT.12) THEN
         IF(MASWRK) WRITE(IW,*) 'ROTATION AXIS TOO HIGH FOR -S2N-'
         CALL ABRT
      END IF
      GO TO (510,520,530,540,550,550,550,550,550,550,550,550),NAXIS
  510 IRPNAM(1)=AG
      IRPNAM(2)=AU
      RETURN
  520 IRPNAM(1)=A
      IRPNAM(2)=B
      IRPNAM(3)=E
      RETURN
  530 IRPNAM(1)=AG
      IRPNAM(2)=AU
      IRPNAM(3)=EU
      IRPNAM(4)=EG
      RETURN
  540 IRPNAM(1)=A
      IRPNAM(2)=B
      IRPNAM(3)=E1
      IRPNAM(4)=E2
      IRPNAM(5)=E3
      RETURN
  550 IF(SOME) WRITE(IW,9495) 'S2N',5
      CALL DSYMBL(IRPNAM,'K')
      RETURN
C
C     -- CNH -
C
  600 CONTINUE
      IF(NAXIS.GT.12) THEN
         IF(MASWRK) WRITE(IW,*) 'ROTATION AXIS TOO HIGH FOR -CNH-'
         CALL ABRT
      END IF
      GO TO (610,620,630,640,650,660,670,680,690,690,690,690),NAXIS
  610 IRPNAM(1)=AP
      IRPNAM(2)=APP
      RETURN
  620 IRPNAM(1)=AG
      IRPNAM(2)=AU
      IRPNAM(3)=BU
      IRPNAM(4)=BG
      RETURN
  630 IRPNAM(1)=AP
      IRPNAM(2)=APP
      IRPNAM(3)=EPP
      IRPNAM(4)=EP
      RETURN
  640 IRPNAM(1)=AG
      IRPNAM(2)=AU
      IRPNAM(3)=BG
      IRPNAM(4)=BU
      IRPNAM(5)=EG
      IRPNAM(6)=EU
      RETURN
  650 IRPNAM(1)=AP
      IRPNAM(2)=APP
      IRPNAM(3)=E1PP
      IRPNAM(4)=E1P
      IRPNAM(5)=E2PP
      IRPNAM(6)=E2P
      RETURN
  660 IRPNAM(1)=AG
      IRPNAM(2)=AU
      IRPNAM(3)=BU
      IRPNAM(4)=BG
      IRPNAM(5)=E1G
      IRPNAM(6)=E1U
      IRPNAM(7)=E2U
      IRPNAM(8)=E2G
      RETURN
  670 IRPNAM(1)=AP
      IRPNAM(2)=APP
      IRPNAM(3)=E1PP
      IRPNAM(4)=E1P
      IRPNAM(5)=E2PP
      IRPNAM(6)=E2P
      IRPNAM(7)=E3PP
      IRPNAM(8)=E3P
      RETURN
  680 IRPNAM( 1)=AG
      IRPNAM( 2)=AU
      IRPNAM( 3)=BG
      IRPNAM( 4)=BU
      IRPNAM( 5)=E1G
      IRPNAM( 6)=E1U
      IRPNAM( 7)=E2U
      IRPNAM( 8)=E2G
      IRPNAM( 9)=E3G
      IRPNAM(10)=E3U
      RETURN
  690 IF(SOME) WRITE(IW,9495) 'CNH',8
      CALL DSYMBL(IRPNAM,'K')
      RETURN
C
C     -- CNV -
C
  700 CONTINUE
      IF(NAXIS.GT.13) THEN
         IF(MASWRK) WRITE(IW,*) 'ROTATION AXIS TOO HIGH FOR -CNV-'
         CALL ABRT
      END IF
      GO TO (710,720,730,740,750,760,770,780,790,790,790,790,790),NAXIS
  710 IRPNAM(1)=AP
      IRPNAM(2)=APP
      RETURN
  720 IRPNAM(1)=A1
      IRPNAM(2)=A2
      IRPNAM(3)=B1
      IRPNAM(4)=B2
      RETURN
  730 IRPNAM(1)=A1
      IRPNAM(2)=A2
      IRPNAM(3)=E
      RETURN
  740 IRPNAM(1)=A1
      IRPNAM(2)=A2
      IRPNAM(3)=B1
      IRPNAM(4)=B2
      IRPNAM(5)=E
      RETURN
  750 IRPNAM(1)=A1
      IRPNAM(2)=A2
      IRPNAM(3)=E1
      IRPNAM(4)=E2
      RETURN
  760 IRPNAM(1)=A1
      IRPNAM(2)=A2
      IRPNAM(3)=B1
      IRPNAM(4)=B2
      IRPNAM(5)=E1
      IRPNAM(6)=E2
      RETURN
  770 IRPNAM(1)=A1
      IRPNAM(2)=A2
      IRPNAM(3)=E1
      IRPNAM(4)=E2
      IRPNAM(5)=E3
      RETURN
  780 IRPNAM(1)=A1
      IRPNAM(2)=A2
      IRPNAM(3)=B1
      IRPNAM(4)=B2
      IRPNAM(5)=E1
      IRPNAM(6)=E2
      IRPNAM(7)=E3
      RETURN
  790 IF(SOME) WRITE(IW,9495) 'CNV',8
      CALL DSYMBL(IRPNAM,'K')
      RETURN
C
C     -- DN -
C
  800 CONTINUE
      IF(NAXIS.GT.12) THEN
         IF(MASWRK) WRITE(IW,*) 'ROTATION AXIS TOO HIGH FOR -DN-'
         CALL ABRT
      END IF
      GO TO (810,820,830,840,850,860,870,880,890,890,890,890),NAXIS
  810 IRPNAM(1)=A
      IRPNAM(2)=B
      RETURN
  820 IRPNAM(1)=A
      IRPNAM(2)=B1
      IRPNAM(3)=B3
      IRPNAM(4)=B2
      RETURN
  830 IRPNAM(1)=A1
      IRPNAM(2)=A2
      IRPNAM(3)=E
      RETURN
  840 IRPNAM(1)=A1
      IRPNAM(2)=A2
      IRPNAM(3)=B1
      IRPNAM(4)=B2
      IRPNAM(5)=E
      RETURN
  850 IRPNAM(1)=A1
      IRPNAM(2)=A2
      IRPNAM(3)=E1
      IRPNAM(4)=E2
      RETURN
  860 IRPNAM(1)=A1
      IRPNAM(2)=A2
      IRPNAM(3)=B1
      IRPNAM(4)=B2
      IRPNAM(5)=E1
      IRPNAM(6)=E2
      RETURN
  870 IRPNAM(1)=A1
      IRPNAM(2)=A2
      IRPNAM(3)=E1
      IRPNAM(4)=E2
      IRPNAM(5)=E3
      RETURN
  880 IRPNAM(1)=A1
      IRPNAM(2)=A2
      IRPNAM(3)=B1
      IRPNAM(4)=B2
      IRPNAM(5)=E1
      IRPNAM(6)=E2
      IRPNAM(7)=E3
      RETURN
  890 IF(SOME) WRITE(IW,9495) 'DN',8
      CALL DSYMBL(IRPNAM,'K')
      RETURN
C
C     -- DNH -
C
  900 CONTINUE
      IF(NAXIS.GT.8) THEN
         IF(MASWRK) WRITE(IW,*) 'ROTATION AXIS TOO HIGH FOR -DNH-'
         CALL ABRT
      END IF
      GO TO (910,920,930,940,950,960,970,980),NAXIS
  910 IRPNAM(1)=A1
      IRPNAM(2)=A2
      IRPNAM(3)=B1
      IRPNAM(4)=B2
      RETURN
  920 IRPNAM(1)=AG
      IRPNAM(2)=AU
      IRPNAM(3)=B3U
      IRPNAM(4)=B3G
      IRPNAM(5)=B1G
      IRPNAM(6)=B1U
      IRPNAM(7)=B2U
      IRPNAM(8)=B2G
      RETURN
  930 IRPNAM(1)=A1P
      IRPNAM(2)=A1PP
      IRPNAM(3)=A2P
      IRPNAM(4)=A2PP
      IRPNAM(5)=EPP
      IRPNAM(6)=EP
      RETURN
  940 IRPNAM( 1)=A1G
      IRPNAM( 2)=A1U
      IRPNAM( 3)=B1G
      IRPNAM( 4)=B1U
      IRPNAM( 5)=A2G
      IRPNAM( 6)=A2U
      IRPNAM( 7)=B2G
      IRPNAM( 8)=B2U
      IRPNAM( 9)=EG
      IRPNAM(10)=EU
      RETURN
  950 IRPNAM(1)=A1P
      IRPNAM(2)=A1PP
      IRPNAM(3)=A2P
      IRPNAM(4)=A2PP
      IRPNAM(5)=E1PP
      IRPNAM(6)=E1P
      IRPNAM(7)=E2PP
      IRPNAM(8)=E2P
      RETURN
  960 IRPNAM( 1)=A1G
      IRPNAM( 2)=A1U
      IRPNAM( 3)=B1U
      IRPNAM( 4)=B1G
      IRPNAM( 5)=A2G
      IRPNAM( 6)=A2U
      IRPNAM( 7)=B2U
      IRPNAM( 8)=B2G
      IRPNAM( 9)=E1G
      IRPNAM(10)=E1U
      IRPNAM(11)=E2U
      IRPNAM(12)=E2G
      RETURN
  970 IRPNAM( 1)=A1P
      IRPNAM( 2)=A1PP
      IRPNAM( 3)=A2P
      IRPNAM( 4)=A2PP
      IRPNAM( 5)=E1PP
      IRPNAM( 6)=E1P
      IRPNAM( 7)=E2PP
      IRPNAM( 8)=E2P
      IRPNAM( 9)=E3PP
      IRPNAM(10)=E3P
      RETURN
C        MICHEL'S NAMES WERE A1G,A1U,A2G,A2U,B1G,B1U,B2G,B2U
C        WITH E'S IN THE ORDER YOU SEE BELOW
  980 IRPNAM( 1)=A1G
      IRPNAM( 2)=A1U
      IRPNAM( 3)=B1G
      IRPNAM( 4)=B1U
      IRPNAM( 5)=A2G
      IRPNAM( 6)=A2U
      IRPNAM( 7)=B2G
      IRPNAM( 8)=B2U
      IRPNAM( 9)=E1G
      IRPNAM(10)=E1U
      IRPNAM(11)=E2U
      IRPNAM(12)=E2G
      IRPNAM(13)=E3G
      IRPNAM(14)=E3U
      RETURN
C
C     -- DND -
C
 1000 CONTINUE
      IF(NAXIS.GT.10) THEN
         IF(MASWRK) WRITE(IW,*) 'ROTATION AXIS TOO HIGH FOR -DND-'
         CALL ABRT
      END IF
      GO TO (1010,1020,1030,1040,1050,1060,1070,1080,1090,1090),NAXIS
 1010 IRPNAM(1)=AG
      IRPNAM(2)=AU
      IRPNAM(3)=BU
      IRPNAM(4)=BG
      RETURN
 1020 IRPNAM(1)=A1
      IRPNAM(2)=B2
      IRPNAM(3)=B1
      IRPNAM(4)=A2
      IRPNAM(5)=E
      RETURN
 1030 IRPNAM(1)=A1G
      IRPNAM(2)=A2U
      IRPNAM(3)=A1U
      IRPNAM(4)=A2G
      IRPNAM(5)=EU
      IRPNAM(6)=EG
      RETURN
C        MICHEL'S NAMES WERE A1,A2,B1,B2,E1,E2,E3
 1040 IRPNAM(1)=A1
      IRPNAM(2)=B2
      IRPNAM(3)=B1
      IRPNAM(4)=A2
      IRPNAM(5)=E1
      IRPNAM(6)=E2
      IRPNAM(7)=E3
      RETURN
C        MICHEL'S NAMES WERE A1G,A1U,A2U,A2G,E2U,E1G,E1U,E2G
 1050 IRPNAM(1)=A1G
      IRPNAM(2)=A2U
      IRPNAM(3)=A1U
      IRPNAM(4)=A2G
      IRPNAM(5)=E1U
      IRPNAM(6)=E2G
      IRPNAM(7)=E2U
      IRPNAM(8)=E1G
      RETURN
 1060 IRPNAM(1)=A1
      IRPNAM(2)=B2
      IRPNAM(3)=B1
      IRPNAM(4)=A2
      IRPNAM(5)=E1
      IRPNAM(6)=E2
      IRPNAM(7)=E3
      IRPNAM(8)=E4
      IRPNAM(9)=E5
      RETURN
 1070 IRPNAM( 1)=A1G
      IRPNAM( 2)=A2U
      IRPNAM( 3)=A1U
      IRPNAM( 4)=A2G
      IRPNAM( 5)=E1U
      IRPNAM( 6)=E2G
      IRPNAM( 7)=E3U
      IRPNAM( 8)=E3G
      IRPNAM( 9)=E2U
      IRPNAM(10)=E1G
      RETURN
 1080 IRPNAM( 1)=A1
      IRPNAM( 2)=B2
      IRPNAM( 3)=B1
      IRPNAM( 4)=A2
      IRPNAM( 5)=E1
      IRPNAM( 6)=E2
      IRPNAM( 7)=E3
      IRPNAM( 8)=E4
      IRPNAM( 9)=E5
      IRPNAM(10)=E6
      IRPNAM(11)=E7
      RETURN
 1090 IF(SOME) WRITE(IW,9495) 'DND',8
      CALL DSYMBL(IRPNAM,'K')
      RETURN
C
 2000 CONTINUE
      NDEX=IGROUP-12
      GO TO (2100,2200,2300,2400,2500,2600,2700),NDEX
C
C   ---  TETRAHEDRAL GROUPS  ---
C
C        --- T ---
C
 2100 IRPNAM(1)=A
      IRPNAM(2)=E
      IRPNAM(3)=F
      RETURN
C
C        --- TH ---
C
 2200 IRPNAM(1)=AG
      IRPNAM(2)=EG
      IRPNAM(3)=FG
      IRPNAM(4)=AU
      IRPNAM(5)=EU
      IRPNAM(6)=FU
      RETURN
C
C        --- TD ---
C
 2300 IRPNAM(1)=A1
      IRPNAM(2)=A2
      IRPNAM(3)=E
      IRPNAM(4)=F1
      IRPNAM(5)=F2
      RETURN
C
C
C   ---  OCTAHEDRAL GROUPS  ---
C
C        --- O ---
C
 2400 IRPNAM(1)=A1
      IRPNAM(2)=A2
      IRPNAM(3)=E
      IRPNAM(4)=F1
      IRPNAM(5)=F2
      RETURN
C
C        --- OH ---
C
 2500 IRPNAM(1)=A1G
      IRPNAM(2)=A2G
      IRPNAM(3)=EG
      IRPNAM(4)=F1G
      IRPNAM(5)=F2G
      IRPNAM(6)=A1U
      IRPNAM(7)=A2U
      IRPNAM(8)=EU
      IRPNAM(9)=F1U
      IRPNAM(10)=F2U
      RETURN
C
C
C   ---  ICOSAHEDRAL GROUPS  ---
C
C        --- I ---
C
 2600 IRPNAM(1)=A
      IRPNAM(2)=F1
      IRPNAM(3)=F2
      IRPNAM(4)=G
      IRPNAM(5)=H
      RETURN
C
C        --- IH ---
C
 2700 IRPNAM(1)=AG
      IRPNAM(2)=F1G
      IRPNAM(3)=F2G
      IRPNAM(4)=GG
      IRPNAM(5)=HG
      IRPNAM(6)=AU
      IRPNAM(7)=F1U
      IRPNAM(8)=F2U
      IRPNAM(9)=GU
      IRPNAM(10)=HU
      RETURN
C
 9495 FORMAT(' WARNING : ',/,
     1 ' GROUPS -',A3,'- WITH N .GT. ',I2,' ARE NOT NAMED WELL.',
     2 ' ARBITRARY IRREP NAMES WILL BE GENERATED')
      END
C*MODULE SYMORB  *DECK DSYMBL
      SUBROUTINE DSYMBL(IRPNAM,CHAR)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION IRPNAM(14)
      CHARACTER*4 IRPNAMC
      CHARACTER*1 CHAR
C
      EQUIVALENCE (IRPNAMI,IRPNAMC)
C
      DO 100 I=1,14
         IF(I.LE.9) THEN
            WRITE(UNIT=IRPNAMC(1:4),FMT='(A1,I1)') CHAR,I
         ELSE
            WRITE(UNIT=IRPNAMC(1:4),FMT='(A1,I2)') CHAR,I
         ENDIF
         IRPNAM(I)=IRPNAMI
  100 CONTINUE
      RETURN
      END
C*MODULE SYMORB  *DECK SYMCUP
      SUBROUTINE SYMCUP(PR,PNORM,REPC,GAMI,GAMJ,GAMK,PI,CLBSCH,GAM,
     *                  CHARR,CHARIJ,DBG,SOME)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL DBG,SOME,ABEL
C
      PARAMETER (MXATM=2000, MXSH=5000)
C
      DIMENSION PR(45,45),PNORM(45),REPC(48,3,3,3,3,2),
     *          GAMI(48,3,3,2),GAMJ(48,3,3,2),GAMK(48,3,3,2),
     *          PI(45,45),CLBSCH(2,9,9,14,14),GAM(48,48),CHARR(48,14),
     *          CHARIJ(48)
      DIMENSION TXYC(2,2,2),P12C(3,3,3,2)
C
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      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 /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(432),INVT(48),NT
C
      DATA CMPLX  /8HCOMPLEX /
      DATA ZERO   /0.0D+00/
      DATA ONE    /1.0D+00/
      DATA TWO    /2.0D+00/
      DATA TOL    /1.0D-05/
      DATA MAXP   /45/
C
C     ----- THIS IMPLEMENTATION IS LIMITED TO 3-FOLD IRREPS -----
C              IT HANDLES 2-FOLD COMPLEX REPRESENTATIONS
C
      SQRT2= SQRT(TWO)
      FAC=ONE/SQRT2
      TXYC(1,1,1)= FAC
      TXYC(2,1,1)= FAC
      TXYC(1,2,1)=ZERO
      TXYC(2,2,1)=ZERO
      TXYC(1,1,2)=ZERO
      TXYC(2,1,2)=ZERO
      TXYC(1,2,2)=-FAC
      TXYC(2,2,2)= FAC
C
      DO 5 IJ=1,9
      DO 5 K =1,9
      DO 5 IRP=1,NIRRED
      DO 5 JRP=1,NIRRED
         CLBSCH(1,IJ,K,IRP,JRP)=ZERO
    5    CLBSCH(2,IJ,K,IRP,JRP)=ZERO
C
C     ----- LOOP OVER PAIRS OF -IRREPS- -----
C
      IB=0
      DO 9000 IRP=1,NIRRED
      ILAM=LAMBDA(IRP)
      IF(COMPLX.EQ.CMPLX.AND.ILAM.EQ.2) THEN
      DO 10 IT=1,NT
      GAMI(IT,1,1,1)=GAM(IT,1+IB)
      GAMI(IT,1,1,2)=GAM(IT,2+IB)
      GAMI(IT,2,1,1)=ZERO
      GAMI(IT,2,1,2)=ZERO
      GAMI(IT,1,2,1)=ZERO
      GAMI(IT,1,2,2)=ZERO
      GAMI(IT,2,2,1)=GAM(IT,4+IB)
      GAMI(IT,2,2,2)=GAM(IT,3+IB)
   10 CONTINUE
      ELSE
      DO 20 N=1,ILAM
      DO 20 M=1,ILAM
      DO 20 IT=1,NT
      GAMI(IT,M,N,1)=GAM(IT,M+ILAM*(N-1)+IB)
   20 GAMI(IT,M,N,2)=ZERO
      END IF
C
      JB=0
      DO 8000 JRP=1,IRP
      JLAM=LAMBDA(JRP)
      IF(COMPLX.EQ.CMPLX.AND.JLAM.EQ.2) THEN
      DO 110 IT=1,NT
      GAMJ(IT,1,1,1)=GAM(IT,1+JB)
      GAMJ(IT,1,1,2)=GAM(IT,2+JB)
      GAMJ(IT,2,1,1)=ZERO
      GAMJ(IT,2,1,2)=ZERO
      GAMJ(IT,1,2,1)=ZERO
      GAMJ(IT,1,2,2)=ZERO
      GAMJ(IT,2,2,1)=GAM(IT,4+JB)
      GAMJ(IT,2,2,2)=GAM(IT,3+JB)
  110 CONTINUE
      ELSE
      DO 120 N=1,JLAM
      DO 120 M=1,JLAM
      DO 120 IT=1,NT
      GAMJ(IT,M,N,1)=GAM(IT,M+JLAM*(N-1)+JB)
  120 GAMJ(IT,M,N,2)=ZERO
      END IF
C
      DO 210 NJ=1,JLAM
      DO 210 MJ=1,JLAM
      DO 210 NI=1,ILAM
      DO 210 MI=1,ILAM
      DO 210 IT=1,NT
      REPC(IT,MI,NI,MJ,NJ,1)= GAMI(IT,MI,NI,1)*GAMJ(IT,MJ,NJ,1)
     1                       -GAMI(IT,MI,NI,2)*GAMJ(IT,MJ,NJ,2)
      REPC(IT,MI,NI,MJ,NJ,2)= GAMI(IT,MI,NI,1)*GAMJ(IT,MJ,NJ,2)
     1                       +GAMI(IT,MI,NI,2)*GAMJ(IT,MJ,NJ,1)
  210 CONTINUE
      DO 220 IT=1,NT
  220 CHARIJ(IT)=CHARR(IT,IRP)*CHARR(IT,JRP)
C
C     ----- DECOMPOSE PRODUCT OVER -IRREPS- -----
C
      MK0=0
      KB=0
      DO 7000 KRP=1,NIRRED
      KLAM=LAMBDA(KRP)
      IF(COMPLX.EQ.CMPLX.AND.KLAM.EQ.2) THEN
      DO 310 IT=1,NT
      GAMK(IT,1,1,1)=GAM(IT,1+KB)
      GAMK(IT,1,1,2)=GAM(IT,2+KB)
      GAMK(IT,2,1,1)=ZERO
      GAMK(IT,2,1,2)=ZERO
      GAMK(IT,1,2,1)=ZERO
      GAMK(IT,1,2,2)=ZERO
      GAMK(IT,2,2,1)=GAM(IT,4+KB)
      GAMK(IT,2,2,2)=GAM(IT,3+KB)
  310 CONTINUE
      ELSE
      DO 320 N=1,KLAM
      DO 320 M=1,KLAM
      DO 320 IT=1,NT
      GAMK(IT,M,N,1)=GAM(IT,M+KLAM*(N-1)+KB)
  320 GAMK(IT,M,N,2)=ZERO
      END IF
C
      DUM=ZERO
      DO 410 IT=1,NT
  410 DUM=DUM+CHARIJ(IT)*CHARR(IT,KRP)
      DUM=DUM/NT
      NKRP=NINT(DUM)
      IF(NKRP.EQ.0) GO TO 7000
      IF(COMPLX.EQ.CMPLX.AND.KLAM.EQ.2) NKRP=NKRP/2
C
C     ----- SET UP PROJECTOR MATRIX -----
C
      IF(ILAM*JLAM*KLAM.GT.MAXP) GO TO 9900
C
      DO 520 NK=1,KLAM
      DO 520 MK=1,KLAM
      DO 520 NJ=1,JLAM
      DO 520 MJ=1,JLAM
      DO 520 NI=1,ILAM
      DO 520 MI=1,ILAM
      DUMR=ZERO
      DUMI=ZERO
      DO 510 IT=1,NT
      DUMR=DUMR+REPC(IT,MI,NI,MJ,NJ,1)*  GAMK(IT,MK,NK,1)
     1         -REPC(IT,MI,NI,MJ,NJ,2)*(-GAMK(IT,MK,NK,2))
      DUMI=DUMI+REPC(IT,MI,NI,MJ,NJ,1)*(-GAMK(IT,MK,NK,2))
     1         +REPC(IT,MI,NI,MJ,NJ,2)*  GAMK(IT,MK,NK,1)
  510 CONTINUE
      DUMR=(DUMR*KLAM)/NT
      DUMI=(DUMI*KLAM)/NT
      MP=MI+ILAM*(MJ-1)+ILAM*JLAM*(MK-1)
      NP=NI+ILAM*(NJ-1)+ILAM*JLAM*(NK-1)
      PR(MP,NP)=DUMR
  520 PI(MP,NP)=DUMI
C
C     ----- PRINT PROJECTOR MATRIX -----
C
      IF(DBG) THEN
         WRITE(IW,9989)
         WRITE(IW,9999) IRPNAM(IRP),IRPNAM(JRP),NKRP,IRPNAM(KRP)
         WRITE(IW,9988)
         CALL SYMPRP(PR,ILAM*JLAM*KLAM,ILAM*JLAM*KLAM,MAXP)
         WRITE(IW,9987)
         CALL SYMPRP(PI,ILAM*JLAM*KLAM,ILAM*JLAM*KLAM,MAXP)
      END IF
C
C     -----    GET CLEBSCH-GORDAN COEFFICIENTS    -----
C           FIRST ORTHONORMALIZE PROJECTOR MATRIX
C
      CALL SYMSMC(PR,PI,PNORM,ILAM*JLAM*KLAM,MAXP)
C
C     ----- THEN COMPRESS COEFFICIENT MATRIX -----
C
      MODKRP=NKRP
      IF(COMPLX.EQ.CMPLX.AND.KLAM.EQ.2) MODKRP=2*NKRP
C
      N=0
      DO 540 NP=1,ILAM*JLAM*KLAM
      IF(PNORM(NP).LT.TOL.OR.N.GE.MODKRP) GO TO 540
      N=N+1
      DO 530 MP=1,ILAM*JLAM*KLAM
      PR(MP, N)=PR(MP,NP)
      PI(MP, N)=PI(MP,NP)
      IF(NP.NE.N) THEN
      PR(MP,NP)=ZERO
      PI(MP,NP)=ZERO
      END IF
  530 CONTINUE
      PNORM( N)=PNORM(NP)
      IF(NP.NE.N) THEN
      PNORM(NP)=ZERO
      END IF
  540 CONTINUE
      IF(N.LT.MODKRP) GO TO 9910
C
C     ----- FINALLY RENORMALIZE -----
C
      IF(COMPLX.EQ.CMPLX.AND.KLAM.EQ.2) THEN
         DUM=ZERO
         DO 550 MP=1,ILAM*JLAM
            DUM=DUM+(PR(MP,NKRP)**2 +
     1                  PI(MP,NKRP)**2 )
  550       CONTINUE
         DUM=ONE/ SQRT(DUM)
         DO 560 MP=1,ILAM*JLAM
            PR(MP,NKRP)=
     1         PR(MP,NKRP)*DUM
            PI(MP,NKRP)=
     1         PI(MP,NKRP)*DUM
  560       CONTINUE
         DUM=ZERO
         DO 570 MP=1,ILAM*JLAM
            DUM=DUM+(PR(MP+ILAM*JLAM*(KLAM-1),MODKRP)**2 +
     1                  PI(MP+ILAM*JLAM*(KLAM-1),MODKRP)**2 )
  570       CONTINUE
         DUM=ONE/ SQRT(DUM)
         DO 580 MP=1,ILAM*JLAM
            PR(MP+ILAM*JLAM*(KLAM-1),NKRP)=
     1         PR(MP+ILAM*JLAM*(KLAM-1),MODKRP)*DUM
            PI(MP+ILAM*JLAM*(KLAM-1),NKRP)=
     1         PI(MP+ILAM*JLAM*(KLAM-1),MODKRP)*DUM
  580       CONTINUE
C
      ELSE
      DO 620 NP=1,NKRP
         DO 610 MK=1,KLAM
            DUM=ZERO
            DO 590 MP=1,ILAM*JLAM
               DUM=DUM+(PR(MP+ILAM*JLAM*(MK-1),NP)**2 +
     1                  PI(MP+ILAM*JLAM*(MK-1),NP)**2 )
  590       CONTINUE
            DUM=ONE/ SQRT(DUM)
            DO 600 MP=1,ILAM*JLAM
              PR(MP+ILAM*JLAM*(MK-1),NP)=PR(MP+ILAM*JLAM*(MK-1),NP)*DUM
  600         PI(MP+ILAM*JLAM*(MK-1),NP)=PI(MP+ILAM*JLAM*(MK-1),NP)*DUM
  610    CONTINUE
  620 CONTINUE
      END IF
C
C     ----- PRINT CLEBSCH-GORDAN COEFFICIENTS -----
C
      IF(DBG) THEN
         DO 650 NP=1,NKRP
         WRITE(IW,9986)
         WRITE(IW,9999) IRPNAM(IRP),IRPNAM(JRP),NKRP,IRPNAM(KRP)
         WRITE(IW,9991) NP
         WRITE(IW,9995) (MK,MK=1,KLAM)
         WRITE(IW,9994)
         DO 630 MP=1,ILAM*JLAM
            WRITE(IW,9996) MP,(PR(MP+ILAM*JLAM*(MK-1),NP),MK=1,KLAM)
  630    CONTINUE
         WRITE(IW,9994)
         DO 640 MP=1,ILAM*JLAM
            WRITE(IW,9996) MP,(PI(MP+ILAM*JLAM*(MK-1),NP),MK=1,KLAM)
  640    CONTINUE
  650    CONTINUE
      END IF
C
      IF(COMPLX.NE.CMPLX) GO TO 800
C
C     ----- TRANSFORM FROM COMPLEX TO REAL BASIS SET -----
C
      DO 780 NP=1,NKRP
C
      DO 740 MK=1,KLAM
C
      DO 710 MJ=1,JLAM
      DO 710 MI=1,ILAM
      P12C(MI,MJ,MK,1)=PR(MI+ILAM*(MJ-1)+ILAM*JLAM*(MK-1),NP)
  710 P12C(MI,MJ,MK,2)=PI(MI+ILAM*(MJ-1)+ILAM*JLAM*(MK-1),NP)
C
C     -----        -IRP- IS AN -E- REPRESENTATION         -----
C       TRANSFORM TO REAL PARTNERS VIA -TXYC(DAGGER)- ON LEFT
C
      IF(ILAM.EQ.2) THEN
      DO 720 MJ=1,JLAM
      DUM1JR= TXYC(1,1,1)*P12C(1,MJ,MK,1)+TXYC(2,1,1)*P12C(2,MJ,MK,1)
     1       +TXYC(1,1,2)*P12C(1,MJ,MK,2)+TXYC(2,1,2)*P12C(2,MJ,MK,2)
      DUM1JI= TXYC(1,1,1)*P12C(1,MJ,MK,2)+TXYC(2,1,1)*P12C(2,MJ,MK,2)
     1       -TXYC(1,1,2)*P12C(1,MJ,MK,1)-TXYC(2,1,2)*P12C(2,MJ,MK,1)
      DUM2JR= TXYC(1,2,1)*P12C(1,MJ,MK,1)+TXYC(2,2,1)*P12C(2,MJ,MK,1)
     1       +TXYC(1,2,2)*P12C(1,MJ,MK,2)+TXYC(2,2,2)*P12C(2,MJ,MK,2)
      DUM2JI= TXYC(1,2,1)*P12C(1,MJ,MK,2)+TXYC(2,2,1)*P12C(2,MJ,MK,2)
     1       -TXYC(1,2,2)*P12C(1,MJ,MK,1)-TXYC(2,2,2)*P12C(2,MJ,MK,1)
      P12C(1,MJ,MK,1)=DUM1JR
      P12C(1,MJ,MK,2)=DUM1JI
      P12C(2,MJ,MK,1)=DUM2JR
      P12C(2,MJ,MK,2)=DUM2JI
  720 CONTINUE
      END IF
C
C     -----           -JRP- IS AN -E- REPRESENTATION            -----
C        TRANSFORM TO REAL PARTNERS VIA -TXYC(CONJUGATE)- ON RIGHT
C
      IF(JLAM.EQ.2) THEN
      DO 730 MI=1,ILAM
      DUMI1R= P12C(MI,1,MK,1)*TXYC(1,1,1)+P12C(MI,2,MK,1)*TXYC(2,1,1)
     1       +P12C(MI,1,MK,2)*TXYC(1,1,2)+P12C(MI,2,MK,2)*TXYC(2,1,2)
      DUMI1I= P12C(MI,1,MK,1)*TXYC(1,1,2)+P12C(MI,2,MK,1)*TXYC(2,1,2)
     1       -P12C(MI,1,MK,2)*TXYC(1,1,1)-P12C(MI,2,MK,2)*TXYC(2,1,1)
      DUMI2R= P12C(MI,1,MK,1)*TXYC(1,2,1)+P12C(MI,2,MK,1)*TXYC(2,2,1)
     1       +P12C(MI,1,MK,2)*TXYC(1,2,2)+P12C(MI,2,MK,2)*TXYC(2,2,2)
      DUMI2I= P12C(MI,1,MK,1)*TXYC(1,2,2)+P12C(MI,2,MK,1)*TXYC(2,2,2)
     1       -P12C(MI,1,MK,2)*TXYC(1,2,1)-P12C(MI,2,MK,2)*TXYC(2,2,1)
      P12C(MI,1,MK,1)=DUMI1R
      P12C(MI,1,MK,2)=DUMI1I
      P12C(MI,2,MK,1)=DUMI2R
      P12C(MI,2,MK,2)=DUMI2I
  730 CONTINUE
      END IF
C
  740 CONTINUE
C
C     -----          -KRP- IS AN   -E- REPRESENTATION          -----
C           BACK TRANSFORM TO REAL PARTNERS VIA -TXYC- ON RIGHT
C
      IF(KLAM.EQ.2) THEN
      DO 750 MI=1,ILAM
      DO 750 MJ=1,JLAM
      DUMK1R= P12C(MI,MJ,1,1)*TXYC(1,1,1)+P12C(MI,MJ,2,1)*TXYC(2,1,1)
     1       -P12C(MI,MJ,1,2)*TXYC(1,1,2)-P12C(MI,MJ,2,2)*TXYC(2,1,2)
      DUMK1I= P12C(MI,MJ,1,1)*TXYC(1,1,2)+P12C(MI,MJ,2,1)*TXYC(2,1,2)
     1       +P12C(MI,MJ,1,2)*TXYC(1,1,1)+P12C(MI,MJ,2,2)*TXYC(2,1,1)
      DUMK2R= P12C(MI,MJ,1,1)*TXYC(1,2,1)+P12C(MI,MJ,2,1)*TXYC(2,2,1)
     1       -P12C(MI,MJ,1,2)*TXYC(1,2,2)-P12C(MI,MJ,2,2)*TXYC(2,2,2)
      DUMK2I= P12C(MI,MJ,1,1)*TXYC(1,2,2)+P12C(MI,MJ,2,1)*TXYC(2,2,2)
     1       +P12C(MI,MJ,1,2)*TXYC(1,2,1)+P12C(MI,MJ,2,2)*TXYC(2,2,1)
      P12C(MI,MJ,1,1)=DUMK1R
      P12C(MI,MJ,1,2)=DUMK1I
      P12C(MI,MJ,2,1)=DUMK2R
      P12C(MI,MJ,2,2)=DUMK2I
  750 CONTINUE
      END IF
C
      DO 760 MK=1,KLAM
      DO 760 MJ=1,JLAM
      DO 760 MI=1,ILAM
      PR(MI+ILAM*(MJ-1)+ILAM*JLAM*(MK-1),NP)=P12C(MI,MJ,MK,1)
      PI(MI+ILAM*(MJ-1)+ILAM*JLAM*(MK-1),NP)=P12C(MI,MJ,MK,2)
  760 CONTINUE
C
      IF(DBG) THEN
         WRITE(IW,9993)
         WRITE(IW,9995) (MK,MK=1,KLAM)
         WRITE(IW,9994)
         DO 770 MP=1,ILAM*JLAM
            WRITE(IW,9996) MP,(PR(MP+ILAM*JLAM*(MK-1),NP),MK=1,KLAM)
  770    CONTINUE
         WRITE(IW,9994)
         DO 775 MP=1,ILAM*JLAM
            WRITE(IW,9996) MP,(PI(MP+ILAM*JLAM*(MK-1),NP),MK=1,KLAM)
  775    CONTINUE
      END IF
C
  780 CONTINUE
C
  800 CONTINUE
C
C     -----     STORE CLEBSCH-GORDAN COEFFICIENTS     -----
C           NOTE = INDICES -NI- AND -MJ- GET PERMUTED
C
      DO 830 NP=1,NKRP
         DO 820 MK=1,KLAM
            DO 810 MJ=1,JLAM
            DO 810 MI=1,ILAM
               CLBSCH(1,MJ+JLAM*(MI-1),MK0+MK+KLAM*(NP-1),IRP,JRP)=
     1             PR(  MI+ILAM*(MJ-1)+ILAM*JLAM*(MK-1),NP)
               CLBSCH(2,MJ+JLAM*(MI-1),MK0+MK+KLAM*(NP-1),IRP,JRP)=
     1             PI(  MI+ILAM*(MJ-1)+ILAM*JLAM*(MK-1),NP)
C
               IF(IRP.EQ.JRP) GO TO 810
C
               CLBSCH(1,MI+ILAM*(MJ-1),MK0+MK+KLAM*(NP-1),JRP,IRP)=
     1         CLBSCH(1,MJ+JLAM*(MI-1),MK0+MK+KLAM*(NP-1),IRP,JRP)
               CLBSCH(2,MI+ILAM*(MJ-1),MK0+MK+KLAM*(NP-1),JRP,IRP)=
     1         CLBSCH(2,MJ+JLAM*(MI-1),MK0+MK+KLAM*(NP-1),IRP,JRP)
  810       CONTINUE
  820    CONTINUE
  830 CONTINUE
C
C     ----- PRINT CLEBSCH-GORDAN COEFFICIENTS -----
C
      IF(DBG) THEN
      WRITE(IW,9992)
      WRITE(IW,9999) IRPNAM(IRP),IRPNAM(JRP),NKRP,IRPNAM(KRP)
      DO 860 NP=1,NKRP
         WRITE(IW,9991) NP
         WRITE(IW,9995) (MK,MK=1,KLAM)
         WRITE(IW,9994)
         MP=0
         DO 840 MI=1,ILAM
         DO 840 MJ=1,JLAM
            MP=MP+1
            WRITE(IW,9990)
     1      MI,MJ,(CLBSCH(1,MJ+JLAM*(MI-1),MK0+MK+KLAM*(NP-1),IRP,JRP),
     2                                                       MK=1,KLAM)
  840    CONTINUE
         WRITE(IW,9994)
         MP=0
         DO 850 MI=1,ILAM
         DO 850 MJ=1,JLAM
            MP=MP+1
            WRITE(IW,9990)
     1      MI,MJ,(CLBSCH(2,MJ+JLAM*(MI-1),MK0+MK+KLAM*(NP-1),IRP,JRP),
     2                                                       MK=1,KLAM)
  850    CONTINUE
  860 CONTINUE
      END IF
C
      MK0=MK0+KLAM*NKRP
 7000 KB=KB+KLAM*KLAM
C
 8000 JB=JB+JLAM*JLAM
 9000 IB=IB+ILAM*ILAM
      RETURN
C
C     ----- ERROR EXIT -----
C
 9900 CONTINUE
      IF(SOME) WRITE(IW,9998)
      CALL ABRT
      RETURN
C
 9910 CONTINUE
      IF(SOME) WRITE(IW,9997)
      CALL ABRT
      RETURN
C
 9999 FORMAT(/,' IRREP. COUPLING - ',A4,' * ',A4,' = ',I2,1X,A4,/,
     1         ' ---------------------------------------')
 9998 FORMAT(' ERROR IN -SYMCUP- IRREPS. DIMENSIONS ARE TOO BIG.')
 9997 FORMAT(' ERROR IN -SYMCUP- NOT ENOUGH COUPLING VECTORS FOUND.')
 9996 FORMAT(I5,5F10.4)
 9995 FORMAT(5X,5(5X,I1,4X))
 9994 FORMAT(/)
 9993 FORMAT(/,' AFTER TRANSFORMATION TO REAL BASIS ')
 9992 FORMAT(/,' CLEBSCH-GORDAN COEFFICIENTS (IN -REAL- BASIS) ',/,
     1         ' --------------------------------------------- ')
 9991 FORMAT(/,' TERM NO. = ',I3,/,' --------------')
 9990 FORMAT(I3,I2,5F10.4)
 9989 FORMAT(/,' PROJECTOR MATRIX',/,' ----------------')
 9988 FORMAT(/,' REAL PART')
 9987 FORMAT(/,' IMAGINARY PART')
 9986 FORMAT(/,' CLEBSCH-GORDAN COEFFICIENTS',/,
     1         ' ---------------------------')
      END
C*MODULE SYMORB  *DECK SYMDIA
      SUBROUTINE SYMDIA(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 /SYMQMT/ IRPLAB(14),IRPNUM(14),IRPDIM(14),IRPDEG(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=IRPDIM(IRP)
         INUM=IRPNUM(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=IRPDIM(IRP)
               INUM=IRPNUM(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=IRPDIM(IRP)
               IDEG=IRPDEG(IRP)
               INUM=IRPNUM(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=IRPDIM(IRP)
            INUM=IRPNUM(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 SYMORB  *DECK SYMMOS
      SUBROUTINE SYMMOS(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(NAO),LABMO(NMO)
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 /SOSYM/  EULANG(4,48),GAM(48,48),IRMON(MXAO)
      COMMON /SYMBLK/ NIRRED,NSALC,NSALC2,NSALC3,NSAFMO
      COMMON /SYMMOL/ GROUP,COMPLX,IGROUP,NAXIS,ILABMO,ABEL
      COMMON /SYMQMT/ IRPLAB(14),IRPNUM(14),IRPDIM(14),IRPDEG(14)
      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
      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
            IRMON(I) = 1
  40     CONTINUE
         RETURN
      END IF
C
      IF(NOSO.NE.0  .OR.  ILABMO.EQ.0) THEN
         NSTAT=-1
         DO 50 I=1,NMO
            LABMO(I) = IQMARK
            IRMON(I) = 1
  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,IRPDIM(IRP)
               IF(IRPNUM(IRP).EQ.0) GO TO 330
               DO 320 IN=1,IRPNUM(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)=IRPLAB(IRP)
                        IRMON(I)=IRP
                     ELSE
                        IF(LABMO(I).NE.IRPLAB(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
            NSTAT=-1
            IRMON(I)=IRPMX
            WRITE(UNIT=STRING,FMT='(''?'',A3)') IRPLAB(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 SYMORB  *DECK SYMOFF
      SUBROUTINE SYMOFF
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXSH=5000, MXATM=2000)
C
      COMMON /SYMQMT/ IRPLAB(14),IRPNUM(14),IRPDIM(14),IRPDEG(14)
      COMMON /SYMREP/ IRPNAM(14),IPA(14),LAMBDA(14),LAMBD0(14),
     *                IADDR1(14),IADDR2(14),IADDR3(14)
      COMMON /SYMBLK/ NIRRED,NSALC,NSALC2,NSALC3,NSAFMO
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(432),INVT(48),NT
      COMMON /SYMSAV/ NIRP1,IRPN1,NSALC1,NDIM1,NDEG1,NTSA,
     *                IRLAB1,IRNUM1,IRDIM1,IRDEG1
C
      DATA IRPA /4HA   /
C
C         IF THE MOLECULE HAS NO SYMMETRY, SYMOFF AND SYMON SHOULD
C         NOT DO ANYTHING AT ALL.  -NIRP1- TELLS THIS TO SYMON.
C
      IF(NIRRED.EQ.1) THEN
         NIRP1 = 1
         RETURN
      END IF
C
C        SAVE CURRENT SYMMETRY INFORMATION, THEN SWITCH SYMMETRY OFF.
C        SEE THE ROUTINE NAMES SYMON FOR RESTORING SYMMETRY USAGE.
C
      NTSA   = NT
      NIRP1  = NIRRED
      IRPN1  = IRPNAM(1)
      NSALC1 = IPA(1)
      NDIM1  = LAMBDA(1)
      NDEG1  = LAMBD0(1)
C          NEXT GET DESTROYED IF A NEW Q-MATRIX IS CONSTRUCTED
C          BEFORE SYMON IS CALLED AGAIN (E.G. NUMERICAL HESSIANS)
      IRLAB1 = IRPLAB(1)
      IRNUM1 = IRPNUM(1)
      IRDIM1 = IRPDIM(1)
      IRDEG1 = IRPDEG(1)
C
      NT       = 1
      NIRRED   = 1
      IRPNAM(1)= IRPA
      IPA(1)   = NSALC
      LAMBDA(1)= 1
      LAMBD0(1)= 1
      IRPLAB(1)= IRPA
      IRPNUM(1)= NSALC
      IRPDIM(1)= 1
      IRPDEG(1)= 1
      RETURN
      END
C*MODULE SYMORB  *DECK SYMON
      SUBROUTINE SYMON
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXSH=5000, MXATM=2000)
C
      COMMON /SYMQMT/ IRPLAB(14),IRPNUM(14),IRPDIM(14),IRPDEG(14)
      COMMON /SYMREP/ IRPNAM(14),IPA(14),LAMBDA(14),LAMBD0(14),
     *                IADDR1(14),IADDR2(14),IADDR3(14)
      COMMON /SYMBLK/ NIRRED,NSALC,NSALC2,NSALC3,NSAFMO
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(432),INVT(48),NT
      COMMON /SYMSAV/ NIRP1,IRPN1,NSALC1,NDIM1,NDEG1,NTSA,
     *                IRLAB1,IRNUM1,IRDIM1,IRDEG1
C
      IF(NIRP1.EQ.1) RETURN
C
C        RESTORE USE OF POINT GROUP AND ORBITAL SYMMETRY
C
      NT        = NTSA
      NIRRED    = NIRP1
      IRPNAM(1) = IRPN1
      IPA(1)    = NSALC1
      LAMBDA(1) = NDIM1
      LAMBD0(1) = NDEG1
      IRPLAB(1) = IRLAB1
      IRPNUM(1) = IRNUM1
      IRPDIM(1) = IRDIM1
      IRPDEG(1) = IRDEG1
      RETURN
      END
C*MODULE SYMORB  *DECK SYMORB
      SUBROUTINE SYMORB
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      COMMON /FMCOM / X(1)
C
      CALL VALFM(LOADFM)
      LGEN1  = LOADFM + 1
      LGEN2  = LGEN1  + 14*3*3
      LGEN3  = LGEN2  + 14*3*3
      LCHARR = LGEN3  + 14*3*3
      LTP    = LCHARR + 48*14
      LTD    = LTP    + 48
      LTF    = LTD    + 48
      LTG    = LTF    + 48
      LCIJ   = LTG    + 48
      LAST   = LCIJ   + 48
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
      CALL SYMOR2(X(LGEN1),X(LGEN2),X(LGEN3),X(LCHARR),
     *            X(LTP),X(LTD),X(LTF),X(LTG),X(LCIJ))
      CALL RETFM(NEED)
      RETURN
      END
C*MODULE SYMORB  *DECK SYMOR2
      SUBROUTINE SYMOR2(GEN1,GEN2,GEN3,CHARR,TRACEP,TRACED,
     *                  TRACEF,TRACEG,CHARIJ)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL NODD,SOME,DBG,GOPARR,DSKWRK,MASWRK,ABEL
C
      DIMENSION GEN1(14,3,3),GEN2(14,3,3),GEN3(14,3,3),
     *          CHARR(48,14),TRACEP(48),TRACED(48),TRACEF(48),
     *          TRACEG(48),CHARIJ(48)
      DIMENSION IDEG(5),MUD(5),NUD(5),FF(4),JUD(5),NIR(5),NKL(10,5),
     *          NGNRTR(19)
C
      PARAMETER (MXATM=2000, MXSH=5000, MXGTOT=20000, MXAO=8192)
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,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /NEOJOB/ NEORUN,NELERM
      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),KMMIN(MXSH),KMMAX(MXSH),NSHELL
      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
      COMMON /SOSYM/  EULANG(4,48),GAM(48,48),IRMON(MXAO)
      COMMON /SYMBLK/ NIRRED,NSALC,NSALC2,NSALC3,NSAFMO
      COMMON /SYMMOL/ GROUP,COMPLX,IGROUP,NAXIS,ILABMO,ABEL
      COMMON /SYMMUL/ NIJREP(14,14),IJREP(2,14,14,14)
      COMMON /SYMREP/ IRPNAM(14),IPA(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 IDEG/1,3,6,10,15/
      DATA MUD /5,19,15,6,30/
      DATA NUD /1,1,2,2,2/
      DATA FF  /1.0D+00,1.0D+00,-1.0D+00,-1.0D+00/
      DATA JUD /1,5,6,15,39/
      DATA NIR /3,6,5,5,10/
      DATA NKL /1,2,3,7*0,1,2,3,1,2,3,4*0,
     1          1,1,2,3,3,5*0,1,1,2,3,3,
     1          5*0,1,1,2,3,3,1,1,2,3,3/
      DATA ZERO   /0.0D+00/
      DATA ONE    /1.0D+00/
      DATA TWO    /2.0D+00/
      DATA THREE  /3.0D+00/
      DATA PIX2   /6.2831853071796D+00/
      DATA NGNRTR /4*1,4*2,2*3,9*0/
      DATA BLANK  /8H        /
      DATA CMPLX  /8HCOMPLEX /
      DATA SALC   /8HSALC    /
C
      DBG  = MASWRK  .AND.  (NPRINT.EQ.1  .OR.  EXETYP.EQ.SALC)
      SOME = MASWRK
C
      N=0
      NGEN=0
      NODD=.TRUE.
      THETA=ZERO
C
C     ----- GET GENERATORS OF GROUP -----
C
      COMPLX=BLANK
      IF(IGROUP.GT.10) GO TO 5
      N=NAXIS
      IF(N.NE.0) THETA=PIX2/N
      NODD=.TRUE.
      IF(N.EQ.2*(N/2)) NODD=.FALSE.
      GEN1(1,1,1)=ONE
      LAMBDA(1)=1
      NGEN=NGNRTR(IGROUP)
      GEN2(1,1,1)=ONE
      GEN1(2,1,1)=ONE
      GEN2(2,1,1)=-ONE
      LAMBDA(2)=1
    5 CONTINUE
C
      CALL SYMBOL(IRPNAM,SOME)
C
      GO TO (10,20,20,40,50,60,70,70,80,90,
     *       600,600,600,600,600,600,600,900,900),IGROUP
C
C     -- C1 --
C
   10 IADDR1(1)=0
      IPA(1)=NUM
      NIRRED=1
      LAMBDA(1)=1
      KB=1
      GO TO 200
C
C     -- CS,CI --
C
   20 NIRRED=2
      GEN1(2,1,1)=-ONE
      KB=2
      GO TO 200
C
C     -- CN --     ..... CYCLIC GROUP .....
C
   40 IF(N.EQ.1) GO TO 10
      IF(N.GT.2) COMPLX=CMPLX
      IF(NODD) GO TO 45
      GEN1(2,1,1)=-ONE
      NIRRED=N/2+1
      KB=2
      IF(N-2) 10,200,170
   45 KB=1
      NIRRED=(N+1)/2
      GO TO 170
C
C     -- S2N --    ..... CYCLIC GROUP .....
C
   50 IF(N.EQ.1) GO TO 20
      IF(N.GE.2) COMPLX=CMPLX
      NIRRED=N+1
      KB=2
      MMAXK=NIRRED-KB
      DO 55 KK=1,MMAXK
      K=KK+KB
      ARG= (KK*THETA)/TWO
      GEN2(K,1,1)= COS(ARG)
      GEN2(K,2,2)= COS(ARG)
      DUM= SIN(ARG)
      GEN2(K,1,2)=-DUM
      GEN2(K,2,1)=DUM
   55 CONTINUE
      GO TO 170
C
C     -- CNH --    ..... CYCLIC GROUP .....
C
   60 IF(N.EQ.1) GO TO 20
      IF(N.GT.2) COMPLX=CMPLX
      IF(NODD) GO TO 65
      GEN2(4,1,1)=-ONE
      GEN1(3,1,1)=-ONE
      GEN1(4,1,1)=-ONE
      GEN2(3,1,1)=ONE
      LAMBDA(3)=1
      LAMBDA(4)=1
      NIRRED=N+2
      KB=4
      IF(N-2) 150,200,150
   65 KB=2
      NIRRED=N+1
      GO TO 150
C
C     -- CNV,DN --
C
   70 IF(NODD) GO TO 75
      GEN1(3,1,1)=-ONE
      GEN1(4,1,1)=-ONE
      GEN2(4,1,1)=-ONE
      GEN2(3,1,1)=ONE
      LAMBDA(3)=1
      LAMBDA(4)=1
      NIRRED=N/2+3
      KB=4
      IF(N-2) 160,200,160
   75 KB=2
      NIRRED=(N+3)/2
      GO TO 160
C
C     -- DNH --
C
   80 GEN3(1,1,1)=ONE
      GEN3(2,1,1)=ONE
      LAMBDA(3)=1
      LAMBDA(4)=1
      GEN2(3,1,1)=ONE
      GEN2(4,1,1)=-ONE
      IF(NODD) GO TO 81
      GEN3(3,1,1)=ONE
      GEN3(4,1,1)=ONE
      GEN3(5,1,1)=-ONE
      GEN3(6,1,1)=-ONE
      GEN3(7,1,1)=-ONE
      GEN3(8,1,1)=-ONE
      LAMBDA(5)=1
      LAMBDA(6)=1
      LAMBDA(7)=1
      LAMBDA(8)=1
      GEN2(5,1,1)=ONE
      GEN2(7,1,1)=ONE
      GEN2(6,1,1)=-ONE
      GEN2(8,1,1)=-ONE
      GEN1(3,1,1)=-ONE
      GEN1(4,1,1)=-ONE
      GEN1(7,1,1)=-ONE
      GEN1(8,1,1)=-ONE
      GEN1(5,1,1)=ONE
      GEN1(6,1,1)=ONE
      NIRRED=N+6
      KB=8
      IF(N-2) 82,200,82
   81 GEN3(3,1,1)=-ONE
      GEN3(4,1,1)=-ONE
      GEN1(3,1,1)=ONE
      GEN1(4,1,1)=ONE
      NIRRED=N+3
      KB=4
   82 MMAXK=NIRRED-KB
      DO 83 KK=1,MMAXK
      K=KK+KB
      GEN3(K,1,1)=ONE
      GEN3(K,2,2)=-ONE
      GEN3(K,1,2)=ZERO
      GEN3(K,2,1)=ZERO
   83 CONTINUE
      GO TO 150
C
C     -- DND --
C
   90 NIRRED=N+3
      KB=4
      GEN3(1,1,1)=ONE
      GEN3(2,1,1)=ONE
      GEN3(3,1,1)=-ONE
      GEN3(4,1,1)=-ONE
      LAMBDA(3)=1
      LAMBDA(4)=1
      GEN1(3,1,1)=ONE
      GEN1(4,1,1)=ONE
      GEN2(3,1,1)=ONE
      GEN2(4,1,1)=-ONE
      MMAXK=NIRRED-KB
      DO 91 KK=1,MMAXK
      K=KK+KB
      ARG= (KK*THETA)/TWO
      DUM= COS(ARG)
      GEN3(K,1,1)=DUM
      GEN3(K,2,2)=-DUM
      GEN3(K,1,2)= SIN(ARG)
      GEN3(K,2,1)= SIN(ARG)
   91 CONTINUE
      GO TO 160
C
C     ----- COMPLETE GENERATORS -----
C
  150 MMAXK=NIRRED-KB
      DO 151 KK=1,MMAXK
      K=KK+KB
      LAMBDA(K)=2
      M=(KK+1)/2
      ARG= M*THETA
      GEN1(K,1,1)= COS(ARG)
      GEN1(K,2,2)= COS(ARG)
      DUM= SIN(ARG)
      GEN1(K,1,2)=-DUM
      GEN1(K,2,1)=DUM
  151 CONTINUE
      S=ONE
      DO 152 KK=1,MMAXK
      S=-S
      K=KK+KB
      GEN2(K,1,1)=S
      GEN2(K,2,2)=S
      GEN2(K,1,2)=ZERO
      GEN2(K,2,1)=ZERO
  152 CONTINUE
      GO TO 200
  160 MMAXK=NIRRED-KB
      DO 161 KK=1,MMAXK
      K=KK+KB
      GEN2(K,1,1)=ONE
      GEN2(K,2,2)=-ONE
      GEN2(K,1,2)=ZERO
      GEN2(K,2,1)=ZERO
  161 CONTINUE
      IF(IGROUP.EQ.9) GO TO 200
  170 MMAXK=NIRRED-KB
      DO 171 KK=1,MMAXK
      K=KK+KB
      LAMBDA(K)=2
      ARG= KK*THETA
      GEN1(K,1,1)= COS(ARG)
      GEN1(K,2,2)= COS(ARG)
      DUM= SIN(ARG)
      GEN1(K,1,2)=-DUM
      GEN1(K,2,1)=DUM
  171 CONTINUE
C
C     ----- GENERATE IRREDUCIBLE REPRESENTATION MATRICES -----
C
  200 CONTINUE
      IB = 0
      DO 250 IRP=1,NIRRED
      LL=LAMBDA(IRP)
      DO 210 I=1,LL
      K1=IB+LL*(I-1)
      DO 205 J=1,LL
  205 GAM(1,K1+J)=ZERO
  210 GAM(1,K1+I)=ONE
      NMMAX=NAXIS
      IF(IGROUP.EQ.1) GO TO 250
      IF(IGROUP.EQ.2) NMMAX=2
      IF(IGROUP.EQ.3) NMMAX=2
      DO 220 N=2,NMMAX
      DO 220 I=1,LL
      K1=IB+LL*(I-1)
      DO 220 J=1,LL
      DUM=ZERO
      DO 215 K=1,LL
  215 DUM=DUM+GAM(N-1,K1+K)*GEN1(IRP,K,J)
      GAM(N,K1+J)=DUM
  220 CONTINUE
      IF(NGEN.EQ.1) GO TO 250
      DO 230 N=1,NMMAX
      DO 230 I=1,LL
      K1=IB+LL*(I-1)
      DO 230 J=1,LL
      DUM=ZERO
      DO 225 K=1,LL
  225 DUM=DUM+GAM(N,K1+K)*GEN2(IRP,K,J)
      GAM(NMMAX+N,K1+J)=DUM
  230 CONTINUE
      IF(NGEN.EQ.2) GO TO 250
      NMMAX=NMMAX+NMMAX
      DO 240 N=1,NMMAX
      DO 240 I=1,LL
      K1=IB+LL*(I-1)
      DO 240 J=1,LL
      DUM=ZERO
      DO 235 K=1,LL
  235 DUM=DUM+GAM(N,K1+K)*GEN3(IRP,K,J)
      GAM(NMMAX+N,K1+J)=DUM
  240 CONTINUE
  250 IB=IB+LL*LL
C
C     ----- PRINT GENERATORS -----
C
      IF(SOME) THEN
         WRITE(IW,9000) GROUP,NAXIS,NT
         IF(COMPLX.EQ.CMPLX) WRITE(IW,9989)
      END IF
C
      IF(DBG) THEN
         WRITE(IW,9990) (BLANK,I,I=1,NGEN)
         DO 340 IRP=1,KB
            GO TO (310,320,330),NGEN
  310       WRITE(IW,9998) IRP,IRPNAM(IRP),GEN1(IRP,1,1)
            GO TO 340
  320       WRITE(IW,9998) IRP,IRPNAM(IRP),GEN1(IRP,1,1),GEN2(IRP,1,1)
            GO TO 340
  330       WRITE(IW,9998) IRP,IRPNAM(IRP),GEN1(IRP,1,1),GEN2(IRP,1,1)
     1                     ,GEN3(IRP,1,1)
  340    CONTINUE
C
         IF(KB.EQ.NIRRED) GO TO 410
         MMIN=KB+1
         DO 400 IRP=MMIN,NIRRED
            GO TO (350,360,370),NGEN
  350       WRITE(IW,9997) IRP,IRPNAM(IRP),((GEN1(IRP,I,J),J=1,2),I=1,2)
            GO TO 400
  360       WRITE(IW,9996) IRP,IRPNAM(IRP),((GEN1(IRP,I,J),J=1,2),
     1                                     (GEN2(IRP,I,J),J=1,2),I=1,2)
            GO TO 400
  370       WRITE(IW,9995) IRP,IRPNAM(IRP),((GEN1(IRP,I,J),J=1,2),
     1                                     (GEN2(IRP,I,J),J=1,2),
     2                                     (GEN3(IRP,I,J),J=1,2),I=1,2)
  400    CONTINUE
C
C     ----- PRINT IRREDUCIBLE REPRESENTATION MATRICES -----
C
  410    MMAX=0
  420    MMIN=MMAX+1
         MMAX=MMAX+5
         IF(MMAX.GT.NT) MMAX=NT
         WRITE(IW,9994) (BLANK,M,M=MMIN,MMAX)
         IB=0
         DO 460 IRP=1,NIRRED
            LL=LAMBDA(IRP)
            GO TO (430,440),LL
  430       WRITE(IW,9993) IRPNAM(IRP),(GAM(M,IB+1),M=MMIN,MMAX)
            GO TO 460
  440       WRITE(IW,9992) IRPNAM(IRP),
     *             (GAM(M,IB+1),GAM(M,IB+2),M=MMIN,MMAX)
            WRITE(IW,9991)
     *             (GAM(M,IB+3),GAM(M,IB+4),M=MMIN,MMAX)
  460       IB=IB+LL*LL
         IF(MMAX.LT.NT) GO TO 420
      END IF
      GO TO 1000
C
C     ----- CINFV,DINFH,T,TH,TD,O,OH -----
C
  600 CONTINUE
      IF(IGROUP.EQ.13.OR.IGROUP.EQ.14) COMPLX=CMPLX
      INDEXG=IGROUP-12
      DO 605 I=1,NT
  605 GAM(I,1)=ONE
      MX=0
      NXX=MUD(INDEXG)
      DO 615 I=1,NT
      DO 610 J=1,9
      GAM(I,NXX+J)=T(MX+J)
  610 CONTINUE
  615 MX=MX+9
      CEE=-ONE/TWO
      ESS= SQRT(THREE)/TWO
      MX=0
      NXX=NUD(INDEXG)
      DO 620 I=1,4
      GAM(I,NXX+1)=ONE
      GAM(I,NXX+2)=ZERO
      GAM(I,NXX+3)=ZERO
  620 GAM(I,NXX+4)=ONE
      DO 625 I=5,8,1
      GAM(I,NXX+1)=CEE
      GAM(I,NXX+2)=-ESS
      GAM(I,NXX+3)=ESS
  625 GAM(I,NXX+4)=CEE
      DO 630 I=9,12
      GAM(I,NXX+1)=CEE
      GAM(I,NXX+2)=ESS
      GAM(I,NXX+3)=-ESS
  630 GAM(I,NXX+4)=CEE
      GO TO (750,660,650,650,650),INDEXG
  650 DO 655 I=13,24
      DO 655 J=1,4
  655 GAM(I,NXX+J)=GAM(I-12,NXX+J)*FF(J)
      IF(INDEXG.LT.5) GO TO 680
  660 CONTINUE
      IB=NT/2+1
      IE=NT/2
      MX=15
      IF(INDEXG.EQ.5) MX=26
      DO 665 I=IB,NT
      DO 665 J=1,4
  665 GAM(I,NXX+J)=GAM(I-IE,NXX+J)
      DO 670 I=1,IE
      DO 670 J=1,4
  670 GAM(I,MX+J)=GAM(I,NXX+J)
      DO 675 I=IB,NT
      DO 675 J=1,4
  675 GAM(I,MX+J)=-GAM(I,NXX+J)
  680 LX=2
      IF(INDEXG.EQ.2) LX=15
      DO 690 I=1,12
      GAM(I,LX)=ONE
  690 GAM(I+12,LX)=-ONE
      IF(INDEXG.LT.5) GO TO 700
      DO 695 I=1,24
      GAM(I+24,2)=GAM(I,2)
      GAM(I,25)=ONE
      GAM(I+24,25)=-ONE
      GAM(I,26)=GAM(I,2)
  695 GAM(I+24,26)=-GAM(I,2)
  700 IF(INDEXG.EQ.2) GO TO 730
      IX=JUD(INDEXG)
      JX=MUD(INDEXG)
      DO 705 I=1,12
      DO 705 J=1,9
      GAM(I,IX+J)=GAM(I,JX+J)
  705 GAM(I+12,IX+J)=-GAM(I+12,JX+J)
      IF(INDEXG.LT.5) GO TO 750
      DO 710 I=1,24
      DO 710 J=1,9
      GAM(I+24,39+J)=-GAM(I,39+J)
      GAM(I,6+J)=GAM(I,30+J)
      GAM(I,15+J)=GAM(I,39+J)
      GAM(I+24,6+J)=GAM(I,30+J)
  710 GAM(I+24,15+J)=GAM(I,39+J)
      GO TO 750
  730 DO 735 I=1,12
      DO 735 J=1,9
      GAM(I,5+J)=GAM(I,19+J)
  735 GAM(I+12,5+J)=GAM(I,19+J)
  750 CONTINUE
      NIRRED=NIR(INDEXG)
      DO 760 I=1,NIRRED
  760 LAMBDA(I)=NKL(I,INDEXG)
      GO TO 910
  900 CONTINUE
C
C     ----- GET IRREPS. OF -I- AND -IH- GROUPS -----
C
      CALL ICOSYM(SOME)
C
C     ----- PRINT IRREDUCIBLE REPRESENTATION MATRICES -----
C
  910 CONTINUE
      IF(SOME) THEN
         WRITE(IW,9100) GROUP,NT
         IF(COMPLX.EQ.CMPLX) WRITE(IW,9989)
      END IF
C
      IF(DBG) THEN
      WRITE(IW,8887)
      MMAX=0
  920 MMIN=MMAX+1
      MMAX=MMAX+2
      IF(MMAX.GT.NT) MMAX=NT
      WRITE(IW,8884) (M,M=MMIN,MMAX)
      IB=0
      DO 960 IRP=1,NIRRED
      LL=LAMBDA(IRP)
      GO TO (930,935,940,945,950),LL
  930 WRITE(IW,8883) IRPNAM(IRP),(GAM(M,IB+1),M=MMIN,MMAX)
      GO TO 960
  935 WRITE(IW,8882) IRPNAM(IRP),((GAM(M,IB+LP),LP=1,2),M=MMIN,MMAX)
      WRITE(IW,8881)             ((GAM(M,IB+LP),LP=3,4),M=MMIN,MMAX)
      GO TO 960
  940 WRITE(IW,8880) IRPNAM(IRP),((GAM(M,IB+    LP),LP=1,3),M=MMIN,MMAX)
      DO 942 IXX=3,6,3
  942 WRITE(IW,8879)             ((GAM(M,IB+IXX+LP),LP=1,3),M=MMIN,MMAX)
      GO TO 960
  945 WRITE(IW,8878) IRPNAM(IRP),((GAM(M,IB+    LP),LP=1,4),M=MMIN,MMAX)
      DO 947 IXX=4,12,4
  947 WRITE(IW,8877)             ((GAM(M,IB+IXX+LP),LP=1,4),M=MMIN,MMAX)
      GO TO 960
  950 WRITE(IW,8876) IRPNAM(IRP),((GAM(M,IB+    LP),LP=1,5),M=MMIN,MMAX)
      DO 952 IXX=5,20,5
  952 WRITE(IW,8875)             ((GAM(M,IB+IXX+LP),LP=1,5),M=MMIN,MMAX)
  960 IB=IB+LL*LL
      IF(MMAX.LT.NT) GO TO 920
      END IF
C
C     ----- GET CHARACTERS OF IRREDUCIBLE REPRESENTATIONS -----
C
 1000 CONTINUE
      DO 1030 IT=1,NT
      IB=0
      DO 1020 IRP=1,NIRRED
      LL=LAMBDA(IRP)
      DUM=ZERO
      DO 1010 L=1,LL
 1010 DUM=DUM+GAM(IT,IB+LL*(L-1)+L)
      CHARR(IT,IRP)=DUM
 1020 IB=IB+LL*LL
 1030 CONTINUE
C
      IF(DBG) THEN
         WRITE(IW,7778)
         WRITE(IW,7777) (IRPNAM(IRP),IRP=1,NIRRED)
         DO 1040 IT=1,NT
            WRITE(IW,7776) IT,(CHARR(IT,IRP),IRP=1,NIRRED)
 1040    CONTINUE
C
         LOC = 0
         DO 1060 I=1,NT
            WRITE(IW,7760) I,INVT(I)
            DO 1050 J=1,3
               WRITE(IW,7761) (T(LOC+III),III=1,3)
               LOC = LOC+3
 1050       CONTINUE
 1060    CONTINUE
      END IF
C
C     ----- GET MULTIPLICATION TABLE FOR -IRREPS- -----
C
      IF(DBG) WRITE(IW,7775)
      DO 1130 IRP=1,NIRRED
      DO 1130 JRP=1,IRP
      DO 1100 IT=1,NT
 1100 CHARIJ(IT)=CHARR(IT,IRP)*CHARR(IT,JRP)
      MRP=0
      DO 1120 KRP=1,NIRRED
      DUM=ZERO
      DO 1110 IT=1,NT
 1110 DUM=DUM+CHARIJ(IT)*CHARR(IT,KRP)
      DUM= DUM/NT
      NKRP=NINT(DUM)
      IF(NKRP.EQ.0) GO TO 1120
      KLAM=LAMBDA(KRP)
      IF(COMPLX.EQ.CMPLX.AND.KLAM.EQ.2) NKRP=NKRP/2
      MRP=MRP+1
      IJREP(1,MRP,IRP,JRP)=NKRP
      IJREP(2,MRP,IRP,JRP)= KRP
      IJREP(1,MRP,JRP,IRP)=NKRP
      IJREP(2,MRP,JRP,IRP)= KRP
 1120 CONTINUE
      NIJREP(IRP,JRP)=MRP
      NIJREP(JRP,IRP)=MRP
C
      IF(DBG) THEN
         IF(MRP.EQ.1) WRITE(IW,7774) IRPNAM(IRP),IRPNAM(JRP),
     1    (       IJREP(1,IRPDUM,IRP,JRP) ,
     2     IRPNAM(IJREP(2,IRPDUM,IRP,JRP)),IRPDUM=1,MRP)
         IF(MRP.EQ.2) WRITE(IW,7773) IRPNAM(IRP),IRPNAM(JRP),
     1    (       IJREP(1,IRPDUM,IRP,JRP) ,
     2     IRPNAM(IJREP(2,IRPDUM,IRP,JRP)),IRPDUM=1,MRP)
         IF(MRP.EQ.3) WRITE(IW,7772) IRPNAM(IRP),IRPNAM(JRP),
     1    (       IJREP(1,IRPDUM,IRP,JRP) ,
     2     IRPNAM(IJREP(2,IRPDUM,IRP,JRP)),IRPDUM=1,MRP)
         IF(MRP.EQ.4) WRITE(IW,7771) IRPNAM(IRP),IRPNAM(JRP),
     1    (       IJREP(1,IRPDUM,IRP,JRP) ,
     2     IRPNAM(IJREP(2,IRPDUM,IRP,JRP)),IRPDUM=1,MRP)
         IF(MRP.EQ.5) WRITE(IW,7770) IRPNAM(IRP),IRPNAM(JRP),
     1    (       IJREP(1,IRPDUM,IRP,JRP) ,
     2     IRPNAM(IJREP(2,IRPDUM,IRP,JRP)),IRPDUM=1,MRP)
         IF(MRP.EQ.6) WRITE(IW,7769) IRPNAM(IRP),IRPNAM(JRP),
     1    (       IJREP(1,IRPDUM,IRP,JRP) ,
     2     IRPNAM(IJREP(2,IRPDUM,IRP,JRP)),IRPDUM=1,MRP)
         IF(MRP.GT.6) WRITE(IW,7768) IRPNAM(IRP),IRPNAM(JRP),
     1    (       IJREP(1,IRPDUM,IRP,JRP) ,
     2     IRPNAM(IJREP(2,IRPDUM,IRP,JRP)),IRPDUM=1,MRP)
      END IF
 1130 CONTINUE
C
C        MEMORY ALLOCATIONS, A BIT AT THE FRONT IS OVERLAPPED
C        THIS FORMULA FOR -MXCIPA- IS HOPEFULLY A OVERESTIMATE
C
      CALL BASCHK(LMAX)
      MXCIPA = MAX(2*NUM*NT*IDEG(LMAX+1),2000)
      NSH = NSHELL
      L1 = NUM
      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  + 48*3*3*3*3*2
C
      LPR    = LAST
      LISGRP = LPR    + 45*45
      LCA    = LISGRP + NAT*6
      LSAO   = LCA    + NAT*45
      LTWRK  = LSAO   + L3
      LUWRK  = LTWRK  + L3
      LISB   = LUWRK  + L1
      LIPB   = LISB   + NSH*14
      LCCHAR = LIPB   + NSH*14
      LCC    = LCCHAR + 5*48
      LLAB   = LCC    + MXCIPA
      LSHELL = LLAB   + MXCIPA*4
      LLOC1  = LSHELL + NAT*6
      LLOC2  = LLOC1  + NAT*5
      LIWRK1 = LLOC2  + NAT*5
      LIWRK2 = LIWRK1 + NAT
      LKLASS = LIWRK2 + NAT
      LIRPBS = LKLASS + NAT
      LDLAB  = LIRPBS + L1*3
      LDIJPQ = LDLAB  + 1800
      LLDIJ  = LDIJPQ + 1000
      LDD    = LLDIJ  + 1000
      LROT   = LDD    + 35
      LBUFF  = LROT   + 15*15
      LSS    = LBUFF  + 15*15
      LVV    = LSS    + 35*35
      LTT    = LVV    + 35*35
      LPP    = LTT    + 35*35
      LPSPH  = LPP    + 35*35
      LDSPH  = LPSPH  + 3*3
      LFSPH  = LDSPH  + 6*6
      LGSPH  = LFSPH  + 10*10
      LAST2  = LGSPH  + 15*15
C
      LAST = MAX(LAST1,LAST2)
      NEED   = LAST - LOADFM -1
      CALL GETFM(NEED)
C
C     ----- GET COUPLING COEFFICIENTS BETWEEN IRREPS. -----
C
      CALL SYMCUP(X(LP),X(LPNORM),X(LREPC),X(LGAMI),
     *            X(LGAMJ),X(LGAMK),X(LPI),X(LCLB),GAM,CHARR,
     *            CHARIJ,DBG,SOME)
C
C     ----- GET -SALC- COEFFICIENTS -----
C
      CALL CIPA(X(LP),X(LPR),X(LPI),X(LPNORM),X(LISGRP),X(LCA),
     *          X(LSAO),X(LTWRK),X(LUWRK),
     *          X(LISB),X(LIPB),X(LCCHAR),X(LCC),X(LLAB),X(LSHELL),
     *          X(LLOC1),X(LLOC2),X(LIWRK1),X(LIWRK2),X(LKLASS),
     *          X(LIRPBS),X(LDLAB),X(LDIJPQ),X(LLDIJ),GAM,CHARR,TRACEP,
     *          TRACED,TRACEF,TRACEG,X(LDD),X(LSS),X(LVV),X(LTT),X(LPP),
     *          X(LROT),X(LBUFF),X(LPSPH),X(LDSPH),X(LFSPH),X(LGSPH),
     *          NAT,L1,L3,NSH,MXCIPA,DBG,SOME)
      CALL RETFM(NEED)
C
C     --- POSSIBLE NUCLEAR -SALC- COEFFICIENTS FOR NEO RUN ---
C
      IF(NEORUN.EQ.1) THEN
         CALL NEOSYM(GAM,CHARR,TRACEP,TRACED,TRACEF,TRACEG)
      END IF
C
      RETURN
C
 9000 FORMAT(/5X,42(1H-)/
     *        5X,'THE POINT GROUP IS ',A3,', NAXIS=',I2,', ORDER=',I2/
     *        5X,42(1H-))
 9100 FORMAT(/5X,32(1H-)/
     *        5X,'THE POINT GROUP IS ',A3,', ORDER=',I2/
     *        5X,32(1H-))
 9998 FORMAT(I5,1X,A4,3(15X,F10.6))
 9997 FORMAT(/I5,1X,A4,10X,2F10.6,/,20X,2F10.6)
 9996 FORMAT(/I5,1X,A4,10X,2F10.6,5X,2F10.6,/,20X,2F10.6,5X,2F10.6)
 9995 FORMAT(/I5,1X,A4,5X,3(5X,2F10.6),/,15X,3(5X,2F10.6))
 9994 FORMAT(4(/),5X,5(A8,2X,1HR,I2,12X))
 9993 FORMAT(1X,A4,5(F15.6,10X))
 9992 FORMAT(/,1X,A4,5(2F10.6,5X))
 9991 FORMAT(5X,5(2F10.6,5X))
 9990 FORMAT(/,
     1       ' -- GENERATORS OF THE GROUP AND IRREDUCIBLE',
     2       ' REPRESENTATIONS --',/,
     3       ' REPRESENTATION',3(A8,2X,'GENERATOR',I2,4X))
 9989 FORMAT(' .. THE CHARACTERS OF THE -E- REPRESENTATIONS',
     1       ' ARE COMPLEX NUMBERS ..')
 8887 FORMAT(44X,43H--- IRREDUCIBLE REPRESENTATION MATRICES ---)
 8884 FORMAT(//,34X,1HR,I3,60X,1HR,I3)
 8883 FORMAT(/,1X,A4,25X,F13.10,51X,F13.10)
 8882 FORMAT(/,1X,A4,17X,2F14.10,36X,2F14.10)
 8881 FORMAT(22X,2F14.10,36X,2F14.10)
 8880 FORMAT(/,1X,A4,14X,3F12.8,28X,3F12.8)
 8879 FORMAT(19X,3F12.8,28X,3F12.8)
 8878 FORMAT(/,1X,A4,8X,4F12.8,16X,4F12.8)
 8877 FORMAT(13X,4F12.8,16X,4F12.8)
 8876 FORMAT(/,1X,A4,2X,5F12.8,4X,5F12.8)
 8875 FORMAT(7X,5F12.8,4X,5F12.8)
 7778 FORMAT(/5X,'--- CHARACTER TABLE (TRANSPOSED) --- ')
 7777 FORMAT(3X,'OPS',1X,14(2X,A4,2X))
 7776 FORMAT(I5,14F8.3)
 7775 FORMAT(/,' --- -IRREPS- MULTIPLICATION TABLE --- ',/)
 7774 FORMAT(1X,A4,1X,'*',1X,A4,' = ',I3,1X,A4                     )
 7773 FORMAT(1X,A4,1X,'*',1X,A4,' = ',I3,1X,A4, 1(' ','+',I3,1X,A4))
 7772 FORMAT(1X,A4,1X,'*',1X,A4,' = ',I3,1X,A4, 2(' ','+',I3,1X,A4))
 7771 FORMAT(1X,A4,1X,'*',1X,A4,' = ',I3,1X,A4, 3(' ','+',I3,1X,A4))
 7770 FORMAT(1X,A4,1X,'*',1X,A4,' = ',I3,1X,A4, 4(' ','+',I3,1X,A4))
 7769 FORMAT(1X,A4,1X,'*',1X,A4,' = ',I3,1X,A4, 5(' ','+',I3,1X,A4))
 7768 FORMAT(1X,A4,1X,'*',1X,A4,' = ',I3,1X,A4,13(' ','+',I3,1X,A4))
 7760 FORMAT(1X,'SYMMETRY OPERATION',I4,' WHOSE INVERSE IS OP',I4)
 7761 FORMAT(5X,3F12.6)
      END
C*MODULE SYMORB  *DECK SYMPRP
      SUBROUTINE SYMPRP(V,M,N,NDIM)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION V(NDIM,M)
      DIMENSION IC(5),C(5)
C
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
C
      DATA VTOL  /1.5D-01/
      DATA ICMAX /5/
C
C     ----- PRINT OUT A SQUARE MATRIX -----
C
      LIST = 0
      MAX = 10
      IF(LIST.EQ.0) MAX=10
      IF(LIST.EQ.1) MAX=7
      IF(LIST.EQ.2) MAX=7
C
      IF(LIST.EQ.0.AND.N.LT.0) GO TO 200
C
      IMAX = 0
  100 IMIN = IMAX+1
      IMAX = IMAX+MAX
      IF (IMAX .GT. M) IMAX = M
      WRITE (IW,9008)
      IF(LIST.EQ.0) WRITE (IW,9028) (I,I = IMIN,IMAX)
      IF(LIST.EQ.1) WRITE (IW,9128) (I,I = IMIN,IMAX)
      IF(LIST.EQ.2) WRITE (IW,9228) (I,I = IMIN,IMAX)
      WRITE (IW,9008)
      DO 120 J = 1,N
      IF(LIST.EQ.0) WRITE (IW,9048) J,(V(J,I),I = IMIN,IMAX)
      IF(LIST.EQ.1) WRITE (IW,9148) J,(V(J,I),I = IMIN,IMAX)
      IF(LIST.EQ.2) WRITE (IW,9248) J,(V(J,I),I = IMIN,IMAX)
  120 CONTINUE
      IF (IMAX .LT. M) GO TO 100
      RETURN
C
  200 CONTINUE
C
      DO 240 J=1,M
      WRITE(IW,9328) J
C
      II=0
      DO 220 I=1,N
      IF( ABS(V(I,J)).LT.VTOL) GO TO 220
      II=II+1
      IC (II)=I
      C  (II)=V(I,J)
      IF(II.LT.ICMAX) GO TO 220
      WRITE(IW,9348) (IC(IDUM),C(IDUM),IDUM=1,II)
      II=0
  220 CONTINUE
      IF(II.EQ.0) GO TO 240
      WRITE(IW,9348) (IC(IDUM),C(IDUM),IDUM=1,II)
  240 CONTINUE
C
      RETURN
 9008 FORMAT(/)
 9028 FORMAT(6X,10(4X,I3,4X))
 9048 FORMAT(I5,1X,10F11.5)
 9128 FORMAT(6X,7(6X,I3,6X))
 9148 FORMAT(I5,1X,7F15.10)
 9228 FORMAT(6X,7(6X,I3,6X))
 9248 FORMAT(I5,1X,7E15.8)
 9328 FORMAT(/,' VEC =',I5,/,1X,10(1H-))
 9348 FORMAT(5(I5,F11.5))
      END
C*MODULE SYMORB  *DECK SYMPRV
      SUBROUTINE SYMPRV(V,E,M,N,NDIM)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION V(NDIM,M),E(M)
      DIMENSION IC(5),C(5)
C
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
C
      DATA VTOL  /1.5D-01/
      DATA ICMAX /5/
C
C     ----- PRINT OUT E AND V-MATRICES
C
      LIST = 0
      MAX = 10
      IF(LIST.EQ.0) MAX=10
      IF(LIST.EQ.1) MAX=7
      IF(LIST.EQ.2) MAX=7
C
      IF(LIST.EQ.0.AND.N.LT.0) GO TO 200
C
      IMAX = 0
  100 IMIN = IMAX+1
      IMAX = IMAX+MAX
      IF (IMAX .GT. M) IMAX = M
      WRITE (IW,9008)
      IF(LIST.EQ.0) WRITE (IW,9028) (I,I = IMIN,IMAX)
      IF(LIST.EQ.1) WRITE (IW,9128) (I,I = IMIN,IMAX)
      IF(LIST.EQ.2) WRITE (IW,9228) (I,I = IMIN,IMAX)
      WRITE (IW,9008)
      IF(LIST.EQ.0) WRITE (IW,9068) (E(I),I = IMIN,IMAX)
      IF(LIST.EQ.1) WRITE (IW,9168) (E(I),I = IMIN,IMAX)
      IF(LIST.EQ.2) WRITE (IW,9268) (E(I),I = IMIN,IMAX)
      WRITE (IW,9008)
      DO 120 J = 1,N
      IF(LIST.EQ.0) WRITE (IW,9048) J,(V(J,I),I = IMIN,IMAX)
      IF(LIST.EQ.1) WRITE (IW,9148) J,(V(J,I),I = IMIN,IMAX)
      IF(LIST.EQ.2) WRITE (IW,9248) J,(V(J,I),I = IMIN,IMAX)
  120 CONTINUE
      IF (IMAX .LT. M) GO TO 100
      RETURN
C
  200 CONTINUE
C
      DO 240 J=1,M
      WRITE(IW,9328) J,E(J)
C
      II=0
      DO 220 I=1,N
      IF( ABS(V(I,J)).LT.VTOL) GO TO 220
      II=II+1
      IC (II)=I
      C  (II)=V(I,J)
      IF(II.LT.ICMAX) GO TO 220
      WRITE(IW,9348) (IC(IDUM),C(IDUM),IDUM=1,II)
      II=0
  220 CONTINUE
      IF(II.EQ.0) GO TO 240
      WRITE(IW,9348) (IC(IDUM),C(IDUM),IDUM=1,II)
  240 CONTINUE
C
      RETURN
 9008 FORMAT(/)
 9028 FORMAT(6X,10(4X,I3,4X))
 9048 FORMAT(I5,1X,10F11.5)
 9068 FORMAT(6X,10F11.5)
 9128 FORMAT(15X,7(6X,I3,6X))
 9148 FORMAT(10X,I5,7F15.10)
 9168 FORMAT(6X,7F15.10)
 9228 FORMAT(6X,7(6X,I3,6X))
 9248 FORMAT(I5,1X,7E15.8)
 9268 FORMAT(6X,7E15.8)
 9328 FORMAT(/,' VEC =',I5,' EIG/OCC =',F11.5,/,1X,31(1H-))
 9348 FORMAT(5(I5,F11.5))
      END
C*MODULE SYMORB  *DECK SYMSMC
      SUBROUTINE SYMSMC(AR,AI,D,N,M)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION AR(M,*),AI(M,*),D(*)
C
      DATA ZERO,ONE,TOL /0.0D+00,1.0D+00,1.0D-10/
C
      IF(N.GT.1) GO TO 10
C
      D(1)=ONE
      DD= SQRT(AR(1,1)**2+AI(1,1)**2)
      IF(DD.LT.TOL) RETURN
      AR(1,1)=AR(1,1)/DD
      AI(1,1)=AI(1,1)/DD
      D(1)=DD
      RETURN
C
   10 CONTINUE
      DD=ZERO
      DO 20 I=1,N
   20 DD=DD+(AR(I,1)**2+AI(I,1)**2)
      DD= SQRT(DD)
      IF(DD.LT.TOL) GO TO 40
      DO 30 I=1,N
      AR(I,1)=AR(I,1)/DD
   30 AI(I,1)=AI(I,1)/DD
   40 D(1)=DD
C
      DO 110 J=2,N
      KMAX=J-1
      DO 70 K=1,KMAX
      DUMR=ZERO
      DUMI=ZERO
      DO 50 I=1,N
      DUMR=DUMR+(AR(I,K)*AR(I,J)+AI(I,K)*AI(I,J))
   50 DUMI=DUMI+(AR(I,K)*AI(I,J)-AI(I,K)*AR(I,J))
      DO 60 I=1,N
      AR(I,J)=AR(I,J)-(DUMR*AR(I,K)-DUMI*AI(I,K))
   60 AI(I,J)=AI(I,J)-(DUMR*AI(I,K)+DUMI*AR(I,K))
   70 CONTINUE
      DD=ZERO
      DO 80 I=1,N
   80 DD=DD+(AR(I,J)**2+AI(I,J)**2)
      DD= SQRT(DD)
      IF(DD.LT.TOL) GO TO 100
      DO 90 I=1,N
      AR(I,J)=AR(I,J)/DD
   90 AI(I,J)=AI(I,J)/DD
  100 D(J)=DD
C
  110 CONTINUE
      RETURN
      END
C*MODULE SYMORB  *DECK SYMSMD
      SUBROUTINE SYMSMD(A,D,N,M)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION A(M,*),D(*)
C
      DATA ZERO,ONE,TOL /0.0D+00,1.0D+00,1.0D-10/
C
      IF(N.GT.1) GO TO 10
C
      D(1)=ONE
      DD= SQRT(A(1,1)**2)
      IF(DD.LT.TOL) RETURN
      A(1,1)=A(1,1)/DD
      D(1)=DD
      RETURN
C
   10 CONTINUE
      DD=ZERO
      DO 20 I=1,N
   20 DD=DD+A(I,1)**2
      DD= SQRT(DD)
      IF(DD.LT.TOL) GO TO 40
      DO 30 I=1,N
   30 A(I,1)=A(I,1)/DD
   40 D(1)=DD
C
      DO 110 J=2,N
      KMAX=J-1
      DO 70 K=1,KMAX
      DUM=ZERO
      DO 50 L=1,N
   50 DUM=DUM+A(L,J)*A(L,K)
      DO 60 I=1,N
   60 A(I,J)=A(I,J)-DUM*A(I,K)
   70 CONTINUE
      DD=ZERO
      DO 80 I=1,N
   80 DD=DD+A(I,J)**2
      DD= SQRT(DD)
      IF(DD.LT.TOL) GO TO 100
      DO 90 I=1,N
   90 A(I,J)=A(I,J)/DD
  100 D(J)=DD
C
  110 CONTINUE
      RETURN
      END
C*MODULE GRD1    *DECK SYMEG
      SUBROUTINE SYMEG(EG)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXSH=5000, MXATM=2000)
C
      DIMENSION EG(3,*)
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 /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(432),INVT(48),NT
      COMMON /SYMSPD/ PTR(3,144),DTR(6,288),FTR(10,480),GTR(15,720)
C
      DATA ZERO,ONE /0.0D+00,1.0D+00/
C
C     ----- SYMMETRIZE GRADIENT VECTOR -----
C
      IF(NT.EQ.1) RETURN
C
C     ----- READ IN TRANFORMATION MATRICES OF COORDINATES. -----
C
      CALL DAREAD(IDAF,IODA,PTR,432,7,0)
C
C     ----- LOOP OVER UNIQUE ATOMS -----
C
      DO 200 IC=1,NAT
      DO 110 IT=1,NT
      IF(MAPCTR(IC,IT).GT.IC) GO TO 200
  110 CONTINUE
C
C     ----- APPLY PROJECTION OPERATOR -----
C
      DEDX=ZERO
      DEDY=ZERO
      DEDZ=ZERO
      DO 120 IT=1,NT
         JC   =MAPCTR(IC,IT)
         DEDXP=EG(1,JC)
         DEDYP=EG(2,JC)
         DEDZP=EG(3,JC)
         N=3*(IT-1)
         DEDX=DEDX+DEDXP*PTR(1,N+1)+DEDYP*PTR(2,N+1)+DEDZP*PTR(3,N+1)
         DEDY=DEDY+DEDXP*PTR(1,N+2)+DEDYP*PTR(2,N+2)+DEDZP*PTR(3,N+2)
         DEDZ=DEDZ+DEDXP*PTR(1,N+3)+DEDYP*PTR(2,N+3)+DEDZP*PTR(3,N+3)
  120 CONTINUE
      DUM=ONE/NT
      DEDX=DEDX*DUM
      DEDY=DEDY*DUM
      DEDZ=DEDZ*DUM
C
C     ----- REMAP PROJECTED BLOCK ONTO EQUIVALENT ATOMS -----
C
      DO 130 IT=1,NT
         JC=MAPCTR(IC,IT)
         N =3*(INVT(IT)-1)
         EG(1,JC)=DEDX*PTR(1,N+1)+DEDY*PTR(2,N+1)+DEDZ*PTR(3,N+1)
         EG(2,JC)=DEDX*PTR(1,N+2)+DEDY*PTR(2,N+2)+DEDZ*PTR(3,N+2)
         EG(3,JC)=DEDX*PTR(1,N+3)+DEDY*PTR(2,N+3)+DEDZ*PTR(3,N+3)
  130 CONTINUE
C
  200 CONTINUE
      RETURN
      END
