IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     PROGRAM TO COMPUTE X-SECTIONS FOR ITYPE= 3, 23  IDENTICAL MOLECS.
C       FROM S-MATRICES SAVED ON TAPE(S) BY SCATTERING PROG.
C     VERSION 5 (14 OCT 94, SG): ADDS ITYPE=3 CAPABILITIES
C                                VERSION 14 NEGATIVE SIG INDX ITYPE=23
C
C     CALCULATES PLUS/MINUS EXCHANGE CROSS SECTIONS AND 'CROSS TERM'
C       ALSO GENERATES 'NO SYMMETRY' (DISTINGUISHALBE) CROSS SECTIONS
C       REQUIRES TWO TAPES EACH WITH ONE EXCHANGE SYM
C       DEFAULT TAPE UNITS ITAPEU(I),I=1,2 ARE 10 AND 11
C       TAPES *MUST* HAVE CORRESPONDING SETS OF S-MATRICES (JTOT,INRG)
C     INDEXING IS SIG(INITIAL,FINAL), INITIAL,FINAL=1,NSIG
C
C     FOR ITYPE=23, &SIGID (NAMELIST INPUT) JZCSMX **MUST** BE SPECIFIED
C       (FOR IPROGM .GE. 14 THIS IS NOT NECESSARY)
C
C     MXCH IS MAXIMUM NO. OF CHANNELS IN ANY S-MATRIX
      PARAMETER (MXCH=400, MXS=MXCH*MXCH)
      DIMENSION J1(MXCH),L1(MXCH),WV1(MXCH),J2(MXCH),L2(MXCH),WV2(MXCH)
      DIMENSION MAP(MXCH)
      DIMENSION SR1(MXS),SR2(MXS),SI1(MXS),SI2(MXS)
C
C     BELOW ARE LIMITS TO INPUT NNRG, NLEV*NQN AND TO OUTPUT NO. SIGMA
      PARAMETER (MXNRG=100,MXJLV=2000,MAXSIG=75000)
C     MXNOSM IS MAX NO. OF 'NO SYMMETRY' LEVELS GENERATED FROM JLEV.
      PARAMETER(MXNOSM=100)
      DIMENSION SIGP(MAXSIG),SIGM(MAXSIG),SIGX(MAXSIG)
      DIMENSION INDX(MXNOSM),Q(MXNOSM),JLEVEL(2,MXNOSM)
      DIMENSION JLEV(MXJLV),JLEV2(MXJLV)
      DIMENSION MINJT(MXNRG),MAXJT(MXNRG),ISTSIG(MXNRG)
      DIMENSION ENERGY(MXNRG),ELEVEL(1000),ENERG2(MXNRG),ELEVE2(1000)
C     NB. DIMENSION OF ELEVEL FIXED BY /CMBASE/ LIMITS
C
C     INPUT TAPE UNITS: ITAPEU(1) IS ODD EXCH, ITAPEU(2) IS EVEN
C       DEFAULTS ARE 10 AND 11, CAN BE RESET BY READ(5,SIGID)
      DIMENSION ITAPEU(2)
C
      CHARACTER*4 LABEL(20),LABEL2(20),EO(2)
      LOGICAL MATCH,EQUAL,LEOF,LEOF2
C
      DATA LEOF/.FALSE./,LEOF2/.FALSE./
      DATA EO/' ODD','EVEN'/
C
      NAMELIST /SIGID/ JZCSMX,MXSIG,JTOUT,JTOTU,ITAPEU,IPRFG
C       JZCSMX: *MUST* BE INPUT AND EQUAL TO VALUE USED TO MAKE TAPE
C       MXSIG - IF .GT. 0 MAY REDUCE NUMBER OF LEVELS IN SIGMA
C       JTOUT - CAN LIMIT ECHO OF INPUT DATA
C       JTOTU - CAN LIMIT PROCESSING OF INPUT (NOT USED IN THIS VERSION)
C       ITAPEU(2) - INPUT TAPE UNITS (DEFAULT = 10, 11)
C       IPRFG = 0, DO NOT PRINT SIG(-), SIG(+), SIG(X)
C             = 1, PRINT SIG(-), SIG(+), SIG(X)
C
C     LOGICAL STATEMENT FUNCTION
      EQUAL(A,B)=ABS(A-B).LE.1.D-6
C
C     SUPPRESS UNDERFLOWS ...
C     CALL CLEARFI (Cray)
C     CALL XUFLOW(0) (IBM)
C
      WRITE(6,604)
  604 FORMAT(' *** PROGRAM TO CONVERT IDENTICAL MOLECULE S-MATRICES'/
     2 '     TO DISTINGUISHABLE MOLECULE S-MATRICES'/
     3 '     VERSION 5 (19 OCT 94) -- ')
C
C     INITIALIZE AND GET NAMELIST INPUT ...
      DO 10  I=1,MXNRG
      MINJT(I)=-1
   10 MAXJT(I)=-1
      MXVIN=0
      JSTEP=-1
      IPRFG=0
      ITAPEU(1)=10
      ITAPEU(2)=11
      MXSIG=0
      JTOUT=999
      JTOTU=999
      JZCSMX=-1
C
      READ(5,SIGID)
C
      WRITE(6,605) ITAPEU
  605 FORMAT(' *** INPUT WILL BE TAKEN FROM TAPE UNITS',2I4)
      IF (ITAPEU(1).EQ.ITAPEU(2)) THEN
        WRITE(6,*) ' *** CANNOT USE SAME UNIT FOR BOTH FILES'
        STOP
      ENDIF
C
C     ----------------------------------------------------------------
C     BEGIN READING TAPE ...
C
      IT=ITAPEU(1)
      READ(IT) LABEL,ITYPE,NLEV,NQN,URED,IP
      WRITE(6,600) IT,LABEL,ITYPE,NLEV,NQN,URED,IP
  600 FORMAT('  SAVE TAPE ON UNIT',I4/
     2       '  LABEL =',20A4/
     3       '  ITYPE =',I3,5X,'NLEV, NQN =',2I4,5X,'URED =',F8.4,
     4       5X,'IPROGM =',I3)
C
      IF (IP.LT.11) THEN
        WRITE(6,*) ' *** THIS VERSION READS ONLY UNFORMATTED TAPES   '
        WRITE(6,*) ' *** IT DOES NOT WORK FOR MOLSCAT VERSION',IP
        STOP
      ENDIF
C     ----- IMPLEMENTATION LIMITED TO ITYPE = 3, 23 ONLY  -----
      IF (.NOT.(ITYPE.EQ.3.OR.ITYPE.EQ.23)) THEN
        WRITE(6,*) ' *** THIS PROGRAM ONLY FOR ITYPE= 3, 23'
        STOP
      ENDIF
C
      IF (IP.LE.12 .AND. ITYPE.EQ.23) THEN
        IF (JZCSMX.LT.0) THEN
          WRITE(6,*) ' *** &SIGID INPUT ERROR.  JZCSMX =',JZCSMX
          WRITE(6,*) ' ***        SPECIFY CORRECT VALUE AND RESUBMIT'
          STOP
        ENDIF
C       CALCULATE MXPAR FROM JZCSMX  (FOR ITYPE=23 UP TO VERSION 12)
        MXPAR=2*(JZCSMX+1)
        WRITE(6,671) MXPAR,JZCSMX
  671   FORMAT(' *** MXPAR CALCULATED TO BE',I4,
     1       ' FROM INPUT &SIGID JZCSMX =',I3)
      ENDIF
C
C     JLEV CONTAINS THE QUANTUM NUMBERS FOR EACH 'LEVEL'
C       ((JLEV(I,NQ),NQ=1,NQN),I=1,NLEV)
      NSQ=NLEV*NQN
      IF (NSQ.GT.MXJLV) THEN
        WRITE(6,*) ' *** JLEV DIMENSION (MXJLV) EXCEEDED',NSQ,MXJLV
        STOP
      ENDIF
      READ(IT) (JLEV(I),I=1,NSQ)
C
      READ(IT) NLEVEL,(ELEVEL(I),I=1,NLEVEL)
      WRITE(6,603) NLEVEL,(ELEVEL(I),I=1,NLEVEL)
  603 FORMAT(' ',I4,'   ROTATIONAL LEVELS'/(' ',1P,8E16.8))
C
C *** CHECK JLEV(I,NQN) AND DECIDE IF IDENT=1
      IDENT=0
      CALL IDCHK(IDENT,NLEV,JLEV)
      IF (IDENT.NE.1) THEN
        WRITE(6,*) ' *** NON-IDENTICAL MOLECULES DETERMINED BY IDCHK'
        WRITE(6,*) ' *** PROGRAM LIMITATION - TERMINATING.'
        STOP
      ENDIF
C
C     OUTPUT BASIS INFORMATION; CHECK AGAINST NLEVEL LIMIT
      NSIG=0
      NERR=0
      DO 1002 I=1,NLEV
      ILEV=ABS(JLEV(NLEV*(NQN-1)+I))
      NSIG=MAX(NSIG,ILEV)
      IF (ILEV.GT.NLEVEL) THEN
        WRITE(6,*) ' *** INCONSISTENT JLEV/JLEVEL. ILEV,NLEVEL =',
     1              ILEV,NLEVEL
        NERR=NERR+1
      ENDIF
 1002 WRITE(6,601) I,ILEV,ELEVEL(ILEV),(JLEV(NLEV*(K-1)+I),K=1,NQN)
  601 FORMAT('  BASIS FN',I3,', LEVEL',I3,',  E =',
     1        F11.3,'  QUANT. NOS.',5I3)
      IF (NERR.GT.0) STOP
C
C     NNRG IS NUMBER OF ENERGIES FOR WHICH SCATTERING CALC WAS DONE.
C     ENERGY(I),I=1,NNRG ARE THE ENERGIES (IN (1/CM))
      READ(IT) NNRG,(ENERGY(I),I=1,NNRG)
      WRITE(6,602) NNRG,(ENERGY(I),I=1,NNRG)
  602 FORMAT(/' ',I4,'  COLLISION (TOTAL) ENERGIES ARE'/(' ',1P,8E16.8))
      IF (NNRG.GT.MXNRG) THEN
        WRITE(6,*) ' *** NNRG.GT.MXNRG',NNRG,MXNRG
        STOP
      ENDIF
C     THIS ENDS HEADER PROCESSING FOR FIRST TAPE
C
      IT=ITAPEU(2)
      WRITE(6,*) ' ***  INPUT FROM 2ND TAPE ON UNIT',IT
      READ(IT,END=1009,ERR=1009) LABEL2,ITYPE2,NLEV2,NQN2,URED2,IP2
      GO TO 1008
 1009 WRITE(6,*) ' *** EOF OR ERROR ON UNIT',IT
      WRITE(6,*) ' *** CANNOT CONTINUE'
      STOP
 1008 WRITE(6,600) IT,LABEL2,ITYPE2,NLEV2,NQN2,URED2,IP2
      MATCH=ITYPE2.EQ.ITYPE.AND.NLEV2.EQ.NLEV.AND.
     1      NQN2.EQ.NQN.AND.EQUAL(URED2,URED)
      IF (.NOT.MATCH) THEN
        WRITE(6,*) '  *** ERROR.  2ND TAPE DOES NOT MATCH 1ST.'
        STOP
      ENDIF
      IF (IP2.LT.3) THEN
        WRITE(6,*) ' *** THIS VERSION OF IDENTICAL-TO-DISTINGUISHABLE'
        WRITE(6,*) ' ***   DOES NOT WORK FOR MOLSCAT VERSION',IP2
        STOP
      ENDIF
C     CHECK FOR CONSISTENCY OF IPROGM ON TWO TAPES -----
C     ----- SAVE RECORD FORMAT CHANGED IN VERSION 14 -----
      IF (IP.LT.14.AND.IP2.GE.14.OR.IP.GE.14.AND.IP2.LT.14) THEN
        WRITE(6,*) ' *** CANNOT PROCESS INCOMPATIBLE SAVE TAPE',
     1     ' FORMATS FOR VERSIONS',
     2               IP,IP2
        STOP
      ENDIF
C     ----- ITYPE=23 'M':MVALUE CHANGED IN VERSION 13  -----
      IF (ITYPE.EQ.23.AND.
     1     (IP.LE.12.AND.IP2.GT.12.OR.IP.GT.12.AND.IP2.LE.12)) THEN
        WRITE(6,*) ' *** ITYPE=23, INCOMPATIBLE PROGRAM VERSIONS',
     1    IP,IP2
        STOP
      ENDIF
C     ----- CONTINUE WITH INPUT FROM TAPE 2 HEADER -----
      NSQ=NLEV*NQN
      READ(IT) (JLEV2(I),I=1,NSQ)
      DO 1003 I=1,NSQ
 1003 MATCH=MATCH.AND.JLEV2(I).EQ.JLEV(I)
      IF (.NOT.MATCH) THEN
        WRITE(6,*) ' *** ERROR.  JLEV ON 2ND TAPE DOES NOT MATCH 1ST.'
        STOP
      ENDIF
      NLEVE2=0
      READ(IT) NLEVE2,(ELEVE2(I),I=1,NLEVE2)
      MATCH=NLEVEL.EQ.NLEVE2
      IF (MATCH) THEN
        DO 1004 I=1,NLEVEL
 1004   MATCH=MATCH.AND.EQUAL(ELEVEL(I),ELEVE2(I))
      ENDIF
      IF (.NOT.MATCH) THEN
        WRITE(6,*) ' *** ERROR.  NLEVEL/ELEVEL ON TAPES DO NOT MATCH.'
        STOP
      ENDIF
      READ(IT) NNRG2,(ENERG2(I),I=1,NNRG2)
      MATCH=NNRG.EQ.NNRG2
      IF (MATCH) THEN
        DO 1005 I=1,NNRG
 1005   MATCH=MATCH.AND.EQUAL(ENERGY(I),ENERG2(I))
      ENDIF
      IF (.NOT.MATCH) THEN
        WRITE(6,*) ' *** ERROR.  NNRG/ENERGY ON TAPES DO NOT MATCH.'
        STOP
      ENDIF
C     WE HAVE COMPLETED HEADER FOR 2ND TAPE AND IT MATCHES 1ST
      WRITE(6,*) '  HEADER INFO FROM 2ND TAPE MATCHES 1ST.'
      WRITE(6,*) '  JSTEP WILL BE DETERMINED FROM INPUT TAPES.'
      WRITE(6,*) ' '
C
C     ------------------------------------------------------
C     SET-UP TO ACCUMULATE SIGMA FOR NLEVEL LEVELS
 1000 IF (NSIG.NE.NLEVEL) THEN
        WRITE(6,*) ' *** INCONSISTENT NSIG,NLEVEL',NSIG,NLEVEL
        STOP
      ENDIF
      IF (MXSIG.GT.0) THEN
        WRITE(6,643) MXSIG
  643   FORMAT(/' ***  NOTE POSSIBLE LIMIT BY MXSIG =',I6)
        NSIG=MIN(MXSIG,NSIG)
      ENDIF
      NSIGMA=NSIG*NSIG
      IF (NSIGMA*(NNRG+1).GT.MAXSIG)  THEN
        WRITE(6,*) ' *** NSIGMA*(NNRG+1).GT.MAXSIG',NSIG,NNRG,MAXSIG
        STOP
      ENDIF
C
C     USE FIRST NSIG*NSIG IN SIGM FOR DEGENERACY DENOMINATOR.
C       AND IN SIGP FOR TEMPORARY STORAGE IN SIGADD
      CALL DEGENI(SIGM,NSIG,JLEV,NLEV,NQN)
      ISTSIG(1)=NSIGMA
      DO 1001 I=2,NNRG
 1001 ISTSIG(I)=ISTSIG(I-1)+NSIGMA
C     CLEAR SIG()
      ISTART=NSIGMA+1
      ISTOP=NSIGMA*(NNRG+1)
      DO 1100 I=ISTART,ISTOP
      SIGM(I)=0.D0
      SIGP(I)=0.D0
 1100 SIGX(I)=0.
C
C     -----------------------------------------------------------------
C     START LOOP OVER JTOT / PARITY/ ENERGY VALUES . . .
C     JTOT,INRG,ENERGY(INRG) HEAD EACH BLOCK OF S-MATRICES
C
      IOK=0
      JSTEPX=-1
      JTOLD=-1
      IF (JTOUT.LT.999) WRITE(6,688) JTOUT
  688 FORMAT(/'  ***  NOTE: INPUT ECHO SUPPRESSED for JTOT.LE.',I4)
C
C     FIRST, GET JTOT, INRG HEADER FROM TAPE 1
 2000 IT=ITAPEU(1)
      IF (IP.LT.14) THEN
        READ(IT,END=9999) JTOT,INRG,ECHK,IEXCH,WT,M
      ELSE
        READ(IT,END=9999) JTOT,INRG,ECHK,IEXCH,WT,M,NOPEN
      ENDIF
C     N.B. JTOT.LT.0 INDICATES (OBSOLETE) ROLLOUT RECORD. NO S-MATRIX
      IF (JTOT.LT.0)  THEN
        WRITE(6,698)  IT,JTOT
  698   FORMAT('0 * * * NOTE. ROLLOUT MARKER.  UNIT, NROLL =',I3,I6)
        GO TO 2000
      ENDIF
      MXVIN=MAX(MXVIN,M)
C     CHECK THAT ENERGY(INRG) CORRESPONDS WITH HEADER RECORD. . .
      IF (.NOT.EQUAL(ECHK,ENERGY(INRG)))
     1  WRITE(6,697)  INRG,ECHK
  697 FORMAT('0 * * * WARNING.  FOR ',I4,'-TH ENERGY, ECHECK =',E16.8)
      IF (IP.LE.12.AND.ITYPE.EQ.23.AND.M.GT.MXPAR) THEN
        WRITE(6,672) M,MXPAR
  672   FORMAT('  *** M-BLOCK  =',I4,'  IS GREATER THAN MXPAR =',I3)
        STOP
      ENDIF
C     ECHO, DEPENDING ON JTOTU
      IF (JTOUT.GE.999.OR.(JTOUT.LT.999.AND.JTOT.GT.JTOUT)) THEN
        IF (IP.LT.14) THEN
          WRITE(6,662) IT,JTOT,M,INRG,ECHK,IEXCH,WT
  662     FORMAT('  READ UNIT(',I2,'), JTOT ',I4,'.',I3,'  E(',I3,')=',
     1         F10.3,' IEX,WT=',I2,F6.2)
        ELSE
          WRITE(6,663) IT,JTOT,M,INRG,ECHK,IEXCH,WT,NOPEN
  663     FORMAT('  READ UNIT(',I2,'), JTOT ',I4,'.',I3,'  E(',I3,')=',
     1         F10.3,' IEX,WT,NOP=',I2,F7.2,I5)
        ENDIF
      ENDIF
      IF (LEOF2) THEN
        WRITE(6,*) ' *** DATA FOUND ON TAPE',IT
        WRITE(6,*) ' *** AFTER EOF ON OTHER TAPE -- NOT PROCESSED'
        GO TO 7000
      ENDIF
C
C     DETERMINE JSTEP ...
      IF (JTOT.NE.JTOLD) THEN
        IF (JTOLD.EQ.-1) THEN
          JTOLD=JTOT
        ELSE
          JSTEP=JTOT-JTOLD
          IF (JSTEP.EQ.JSTEPX) THEN
            JTOLD=JTOT
          ELSE
            IF (JSTEPX.EQ.-1) THEN
              JSTEPX=JSTEP
            ELSE
              WRITE(6,649) JSTEP,JSTEPX
  649         FORMAT('  *** JSTEP ERROR CURRENT, OLD =',2I6)
              STOP
            ENDIF
          ENDIF
        ENDIF
      ENDIF
      GO TO 2200
C
C     END OF FILE ON TAPE 1
 9999 LEOF=.TRUE.
      WRITE(6,*) ' *** NORMAL EOF ENCOUNTERED ON TAPE',IT
      IF (LEOF2) GO TO 7000
C
C     NOW GET JTOT,INRG HEADER FROM TAPE 2, UNLESS IOK.EQ.1 INDICATING 
C       THAT WE HAVE SAVED A HEADER FROM TAPE 2
 2200 IF (IOK.EQ.1) GO TO 2700
      IT=ITAPEU(2)
 2201 IF (IP.LT.14) THEN
        READ(IT,END=9998) JTOT2,INRG2,ECHK2,IEXCH2,WT2,M2
      ELSE
        READ(IT,END=9998) JTOT2,INRG2,ECHK2,IEXCH2,WT2,M2,NOPEN2
      ENDIF
C     N.B. JTOT.LT.0 INDICATES (OBSOLETE) ROLLOUT RECORD. NO S-MATRIX
      IF (JTOT2.LT.0)  THEN
        WRITE(6,698)  IT,JTOT2
        GO TO 2201
      ENDIF
C     CHECK THAT ENERGY(INRG) CORRESPONDS WITH HEADER RECORD. . .
      IF (.NOT.EQUAL(ECHK2,ENERGY(INRG2)))
     1  WRITE(6,697)  INRG2,ECHK2
      IF (IP.LE.12.AND.ITYPE.EQ.23.AND.M2.GT.MXPAR) THEN
        WRITE(6,672) M2,MXPAR
        STOP
      ENDIF
      MXVIN=MAX(MXVIN,M2)
C     ECHO, DEPENDING ON JTOTU
      IF (JTOUT.GE.999.OR.(JTOUT.LT.999.AND.JTOT2.GT.JTOUT)) THEN
        IF (IP.LT.14) THEN
          WRITE(6,662) IT,JTOT2,M2,INRG2,ECHK2,IEXCH2,WT2
        ELSE
          WRITE(6,663) IT,JTOT2,M2,INRG2,ECHK2,IEXCH2,WT2,NOPEN2
        ENDIF
      ENDIF
      IF (LEOF) THEN
        WRITE(6,*) ' *** DATA FOUND ON TAPE',IT
        WRITE(6,*) ' *** AFTER EOF ON OTHER TAPE -- NOT PROCESSED'
        GO TO 7000
      ENDIF
      GO TO 2700
C
C     END OF FILE ON 2ND TAPE
 9998 LEOF2=.TRUE.
      WRITE(6,*) ' *** NORMAL EOF ENCOUNTERED ON TAPE',IT
      IF (LEOF) GO TO 7000
C
C     SEE WHETHER FILES ON THE TWO TAPES CORRESPOND; IF NOT, SET IOK
C       TO 1 'SMALLER' AND PROCESS IT ALONE
 2700 IF (JTOT.EQ.JTOT2) THEN
        IF (INRG.EQ.INRG2) THEN
          IOK=0
          GO TO 1900
        ELSE
          IF (INRG.GT.INRG2) THEN
            GO TO 1901
          ELSE
            GO TO 1902
          ENDIF
        ENDIF
      ELSE
        IF (JTOT.GT.JTOT2) THEN
          GO TO 1902
        ELSE
          GO TO 1901
        ENDIF
      ENDIF
      WRITE(6,*) ' *** ILLEGAL IOK LOGICAL PATH'
      STOP
 1902 IOK=2
      WRITE(6,642) ITAPEU(3-IOK)
 642  FORMAT('  ==> MISSING SET ON UNIT(',I3,
     1       '). WILL PROCESS SINGLE S-MATRIX')
      JTSV=JTOT
      INSV=INRG
      MSV=M
      IEXSV=IEXCH
      WTSV=WT
      IF (IP.GE.14) NOPSV=NOPEN
      JTOT=JTOT2
      INRG=INRG2
      NOPEN=0
      GO TO 1900
 1901 IOK=1
      WRITE(6,642) ITAPEU(3-IOK),JTOT,INRG
      JTSV=JTOT2
      INSV=INRG2
      MSV=M2
      IEXSV=IEXCH
      WTSV=WT2
      IF (IP.GE.14) NOPSV=NOPEN2
      JTOT2=JTOT
      INRG2=INRG
      NOPEN2=0
      GO TO 1900
C
C     BOOKEEPING FOR MINJT, MAXJT . . .
 1900 IF (MINJT(INRG).LT.0)  MINJT(INRG)=JTOT
      MAXJT(INRG)=MAX0(MAXJT(INRG),JTOT)
C
C     ------------------------------------------------------------------
C     GET MVALUE, IEXCH // CODE DEPENDS ON ITYPE AND PROGRAM VERSION
C     ------------------------------------------------------------------
C
      WT=1.D0
      IF (ITYPE.EQ.23) THEN
        IF (IP.LE.12) THEN
C         GET EXCHANGE SYMMETRY/ MVALUE FROM M, M2
C         N.B. IEXCH IN JTOT,INRG RECORD IS NOT MEANINGFUL
C         -- CURRENT CODE IS BASED ON THE FACT THAT EVEN/ODD ARE ON
C            DIFFERENT INPUT UNITS.  WE DO NOT CHECK THAT VALUES ON
C            A GIVEN UNIT ARE *ALWAYS* SAME EXCHANGE SYMMETRY
          IF (M.LE.MXPAR/2) THEN
            IEXCH=1
            MVALUE=M-1
          ELSE
            IEXCH=2
            MVALUE=M-(MXPAR/2)-1
          ENDIF
          IF (M2.LE.MXPAR/2) THEN
            IEXCH2=1
            MVALU2=M2-1
          ELSE
            IEXCH2=2
            MVALU2=M2-(MXPAR/2)-1
          ENDIF
        ELSE
C         ALGORITHM RELATING ICODE W/ MVALUE,IEXCH STARTING VERSION 13
          IEX=2-MOD(M,2)
          MVALUE=(M+1)/2-1
          IEX2=2-MOD(M2,2)
          MVALU2=(M2+1)/2-1
          IF (IP.GE.14.AND.(IEX.NE.IEXCH.OR.IEX2.NE.IEXCH2)) THEN
            WRITE(6,*) ' *** VERSION 14: IEX.NE.IEXCH .OR.',
     1        ' IEX2.NE.IEXCH2'
            WRITE(6,*) IEX,IEXCH,IEX2,IEXCH2
            STOP
          ENDIF
          IEXCH=IEX
          IEXCH2=IEX2
        ENDIF
        IF (IOK.EQ.1) THEN
          MVALUE2=MVALUE
          IEXCH2=3-IEXCH
        ELSEIF (IOK.EQ.2) THEN
          MVALUE=MVALU2
          IEXCH=3-IEXCH2
        ENDIF
        IF (MVALUE.NE.MVALU2) THEN
          WRITE(6,*) ' *** MVALUES ARE NOT EQUAL',MVALUE,MVALU2
          WRITE(6,*) '     CURRENT PROGRAM CANNOT HANDLE THIS MISMATCH'
          STOP
        ENDIF
        IF (MVALUE.GT.0) WT=2.D0
      ELSEIF (ITYPE.EQ.3) THEN
        IEXCH=(M+1)/2
        IEXCH2=(M2+1)/2
C       MAY WANT TO HAVE "PARITY" FOR TWO TAPES
        IPTY=MOD(M,2)
        IPTY2=MOD(M2,2)
        IF (IOK.EQ.1) THEN
          IPTY2=IPTY
          IEXCH2=3-IEXCH
        ELSEIF (IOK.EQ.2) THEN
          IPTY=IPTY2
          IEXCH=3-IEXCH2
        ENDIF
        IF (IPTY.NE.IPTY2) THEN
          WRITE(6,*) ' *** BAD VALUES FOR ITYPE=3 PARITIES',IPTY,IPTY2
          STOP
        ENDIF
      ELSE
        WRITE(6,*) ' *** ILLEGAL LOGICAL PATH / INVALID ITYPE'
        STOP
      ENDIF
C     FOR BOTH ITYPE SHOULD HAVE DIFFERENT EXCHANGE ON EACH TAPE --
      IF (IEXCH+IEXCH2.NE.3) THEN
        WRITE(6,*) ' *** INCORRECT IEXCH VALUES',IEXCH,IEXCH2
        WRITE(6,*) '     CURRENT PROGRAM CANNOT HANDLE THIS MISMATCH'
        STOP
      ENDIF
C
C     ------------------------------------------------------------------
C     CHOOSE IT ACCORDING TO IEXCH TO PUT ODD EXCH INTO SR1,SI1 AND
C       EVEN EXCH INTO SR2,SI2
C     BELOW IS INPUT OF ODD EXCHANGE SYMMETRY
      IT=ITAPEU(IEXCH)
C     ------------------------------------------------------------------
C     IF WE READ 2ND TAPE 1ST, WE MUST SWITCH NOPEN, NOPEN2
      IF (IT.EQ.ITAPEU(2)) THEN
        NXX=NOPEN2
        NOPEN2=NOPEN
        NOPEN=NXX
      ENDIF
      IF (IOK.NE.0.AND.IT.NE.ITAPEU(IOK)) GO TO 3001
      IF (IP.LT.14) THEN
        READ(IT,END=9090) NOPEN,(J1(IX),L1(IX),WV1(IX),IX=1,NOPEN)
        IF (NOPEN.GT.MXCH) THEN
          WRITE(6,675) NOPEN,MXCH,IT
  675     FORMAT('  *** ERROR NOPEN EXCEEDS MXCH',2I5,'  ON UNIT',I3)
          STOP
        ENDIF
      ELSE
        IF (NOPEN.GT.MXCH) THEN
          WRITE(6,675) NOPEN,MXCH,IT
          STOP
        ENDIF
        READ(IT,END=9090) (J1(IX),L1(IX),WV1(IX),IX=1,NOPEN)
      ENDIF
      CALL SREAD(IT,NOPEN,SR1,IEND)
      IF (IEND.GT.0) GO TO 9090
      CALL SREAD(IT,NOPEN,SI1,IEND)
      IF (IEND.GT.0) GO TO 9090
C
C     THEN INPUT EVEN EXCHANGE INTO J2,L2,WV2,SR2,SI2
 3001 IT=ITAPEU(IEXCH2)
      IF (IOK.NE.0.AND.IT.NE.ITAPEU(IOK)) GO TO 3002
      IF (IP.LT.14) THEN
        READ(IT,END=9090) NOPEN2,(J2(IX),L2(IX),WV2(IX),IX=1,NOPEN2)
        IF (NOPEN2.GT.MXCH) THEN
          WRITE(6,675) NOPEN2,MXCH,IT
          STOP
        ENDIF
      ELSE
        IF (NOPEN2.GT.MXCH) THEN
          WRITE(6,675) NOPEN2,MXCH,IT
          STOP
        ENDIF
        READ(IT,END=9090) (J2(IX),L2(IX),WV2(IX),IX=1,NOPEN2)
      ENDIF
      CALL SREAD(IT,NOPEN2,SR2,IEND)
      IF (IEND.GT.0) GO TO 9090
      CALL SREAD(IT,NOPEN2,SI2,IEND)
      IF (IEND.GT.0) GO TO 9090
C
C     ------------------------------------------------------------------
C     WE NOW HAVE A SET OF ODD/EVEN VALUES FOR GIVEN JTOT,INRG,MVALUE
C     PROCESS TO SIGM/SIGP.  INDEX OF SIGM/SIGP IS IXSG
C     ------------------------------------------------------------------
 3002 IXSG=ISTSIG(INRG)+1
      CALL SIGADD(JTOT,SR1,SI1,J1,WV1,NOPEN,JLEV,NLEV,NQN,
     2            SIGM(IXSG),SIGM(1),SIGP(1),NSIG,DMAX,OMAX,WT)
      CALL SIGADD(JTOT,SR2,SI2,J2,WV2,NOPEN2,JLEV,NLEV,NQN,
     2            SIGP(IXSG),SIGM(1),SIGP(1),NSIG,DMAX,OMAX,WT)
C     THEN CALL XADD TO CALCULATE 'EXCHANGE' CROSS TERMS
      CALL XADD(JTOT,SR1,SI1,J1,L1,WV1,NOPEN,
     1          SR2,SI2,J2,L2,WV2,NOPEN2, JLEV,NLEV,NQN,
     2          SIGX(IXSG),SIGM(1),SIGP(1),NSIG,DMAX,OMAX,WT,MAP)
      IF (ITYPE.EQ.23) THEN
        WRITE(6,676) EO(IEXCH),EO(IEXCH2),JTOT,INRG,MVALUE,NOPEN,NOPEN2
  676   FORMAT(2X,A4,'/',A4,' S-MATRICES DONE FOR JTOT,INRG,MVALUE',I5,
     1         I3,I3,'  NOP=',2I4)
      ELSEIF (ITYPE.EQ.3) THEN
        WRITE(6,677) EO(IEXCH),EO(IEXCH2),JTOT,INRG,IPTY,NOPEN,NOPEN2
  677   FORMAT(2X,A4,'/',A4,' S-MATRICES DONE FOR JTOT,INRG,PARITY',
     1         I5,I3,I2,'  NOP=',2I4)
      ENDIF
      IF (IOK.EQ.0) THEN
C       GO BACK FOR MORE NEW CYCLE OF JTOT,INRG,MVALUE SETS
        GO TO 2000
      ELSEIF (IOK.EQ.2) THEN
C       WE HAVE PROCESSED VALUES FROM TAPE 2; 
C       RESTORE TAPE 1 HEADER AND GO BACK FOR NEW TAPE 2 RECORD
        JTOT=JTSV
        INRG=INSV
        M=MSV
        IEXCH=IEXSV
        WT=WTSV
        IF (IP.GE.14) NOPEN=NOPSV
        IOK=0
        GO TO 2200
      ELSEIF (IOK.EQ.1) THEN
C       GO BACK FOR A NEW TAPE 1 RECORD, BUT *NOT* NEW TAPE 2 RECORD
        JTOT2=JTSV
        INRG2=INSV
        M2=MSV
        IEXCH2=IEXSV
        WT2=WTSV
        IF (IP.GE.14) NOPEN2=NOPSV
        GO TO 2000
      ENDIF
C
 9090 WRITE(6,690) IT
  690 FORMAT('  ***** ***** PREMATURE EOF REACHED ON UNIT',I3/
     1       '  ***** ***** PARTIAL INPUT WILL BE IGNORED.')
C
C
C     EOF ENCOUNTERED AND S-MATRICES PROCESSED. OUTPUT SIG()
 7000 IF (JSTEPX.EQ.-1) THEN
        WRITE(6,*) ' *** JSTEP NOT DETERMINED (ONLY ONE JTOT ?)'
        WRITE(6,*) ' *** JSTEP SET TO 1'
        JSTEP=1
      ENDIF
      WRITE(6,611) JSTEP
  611 FORMAT(/'  *** PROCESSING OF TAPE FINISHED.'
     1       /'  *** ALL CROSS SECTIONS MULTIPLIED BY JSTEP =',I3)
      IF (ITYPE.EQ.23.AND.IP.LE.12) THEN
        IF (MXVIN.EQ.MXPAR) THEN
          WRITE(6,647)
  647     FORMAT(' *** MAXIMUM M-VALUE FOUND ON TAPES AGREED WITH'
     1        ,' &SIGID JZCSMX VALUE')
        ELSE
          WRITE(6,*) ' *** POSSIBLE ERROR IN JZCSMX'
          WRITE(6,*) '     MAX M-VALUE ON TAPE DID NOT AGREE WITH'
          WRITE(6,*) '     VALUE CALCUALTED FROM &SIDID JZCSMX VALUE'
          WRITE(6,*) ' ***'
        ENDIF
      ENDIF
      IF(IPRFG.EQ.0) GO TO 4100
      DO 4000 I=1,NNRG
      IX=ISTSIG(I)+1
 4000 CALL OUTSIG(ENERGY(I),MINJT(I),JSTEP,MAXJT(I),
     1            SIGM(IX),SIGP(IX),SIGX(IX),NSIG)
C
C     SET-UP TO GET 'NO-SYMMETRY' CROSS SECTIONS
 4100 NNO=0
      DO 5000 I=1,NSIG
      DO 5100 II=1,NLEV
      IF (ABS(JLEV(NLEV*(NQN-1)+II)).NE.I) GO TO 5100
      IX=II
      GO TO 5200
 5100 CONTINUE
      WRITE(6,*) ' *** SIG INDEX NOT IN JLEV(,NQN) FOR INDEX',I
      STOP
 5200 NNO=NNO+1
      IF (NNO.GT.MXNOSM) THEN
        WRITE(6,*) ' *** MXNOSM EXCEEDED',MXNOSM
        STOP
      ENDIF
      INDX(NNO)=I
      JLEVEL(1,NNO)=JLEV(IX)
      JLEVEL(2,NNO)=JLEV(IX+NLEV)
      IF (JLEVEL(1,NNO).GE.JLEVEL(2,NNO)) THEN
        Q(NNO)=1.D0
      ELSE
        Q(NNO)=-1.D0
      ENDIF
      IF (JLEVEL(1,NNO).EQ.JLEVEL(2,NNO)) GO TO 5000
C     J1.NE.J2 ==> ADD J2,J1 TO SET
      NNO=NNO+1
      IF (NNO.GT.MXNOSM) THEN
        WRITE(6,*) ' *** MXNOSM EXCEEDED IN REVERSING',MXNOSM
        STOP
      ENDIF
      INDX(NNO)=I
      JLEVEL(1,NNO)=JLEV(IX+NLEV)
      JLEVEL(2,NNO)=JLEV(IX)
      IF (JLEVEL(1,NNO).GE.JLEVEL(2,NNO)) THEN
        Q(NNO)=1.D0
      ELSE
        Q(NNO)=-1.D0
      ENDIF
 5000 CONTINUE
      WRITE(6,650) (I,JLEVEL(1,I),JLEVEL(2,I),INDX(I),Q(I),I=1,NNO)
  650 FORMAT(/' UNSYMMETRIZED CROSS SECTIONS FOR'/
     1       ' LEVEL    J1 J2 INDX      Q'/
     2       (I6,3X,2I3,I5,F7.1) )
      WRITE(6,655) LABEL
655   FORMAT(//20A4)
      WRITE(6,660)
660   FORMAT(/12X,'ENERGY  JTOTL  JSTEP  JTOTU',7X,
     1       'F    I',12X,'SIG(F,I)'/)
      DO 5300 I=1,NNRG
      IX=ISTSIG(I)+1
 5300 CALL NOSYM(ENERGY(I),MINJT(I),JSTEP,MAXJT(I),JLEVEL,INDX,Q,NNO,
     1            SIGM(IX),SIGP(IX),SIGX(IX),NSIG)
      STOP
      END
      SUBROUTINE OUTSIG(ENERGY,JTL,JST,JTU,SIGM,SIGP,SIGX,N)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION SIGM(N,N),SIGP(N,N),SIGX(N,N)
C
C     THIS VERSION PRINTS SIG-, SIG+, SIG(X)
C
      WRITE(6,600)
  600 FORMAT(/'    ENERGY  JTL JST  JTU       F    I    SIG(-)',
     1       '      SIG(+)      SIG(X)')
      XJS=JST
      DO 1000 II=1,N
      DO 1000 IF=1,N
 1000 WRITE(6,601) ENERGY,JTL,JST,JTU,IF,II,XJS*SIGM(II,IF),
     1             XJS*SIGP(II,IF),XJS*SIGX(II,IF)
  601 FORMAT(1X,F9.2,I5,'(',I2,')',I5,3X,2I5,1P,3D12.4)
      RETURN
      END
      SUBROUTINE NOSYM(ENERGY,MINJT,JSTEP,MAXJT,
     1                  JLEVEL,INDX,Q,NNO,SIGM,SIGP,SIGX,NS)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION INDX(NNO),Q(NNO),JLEVEL(2,NNO)
      DIMENSION SIGM(NS,NS),SIGP(NS,NS),SIGX(NS,NS)
      CHARACTER*1 BLANK
      DATA BLANK/' '/
C     ROUTINE TO GENERATE 'NO SYMMETRY' CROSS SECTIONS FROM
C       SIG(+), SIG(-), SIG(X)
C
      XJS=JSTEP
      DO 2000 II=1,NNO
      IXI=INDX(II)
      DO 2000 IF=1,NNO
      IXF=INDX(IF)
      SIGMA=SIGM(IXI,IXF)+SIGP(IXI,IXF)+2.D0*Q(II)*Q(IF)*SIGX(IXI,IXF)
      SIGMA=0.25D0*SIGMA * XJS
      IF(SIGMA.LE.1.0E-10) GO TO 2000
      WRITE(6,650) BLANK,ENERGY,MINJT,JSTEP,MAXJT,IF,II,SIGMA
650   FORMAT(A1,F19.6,I5,2I7, 5X,2I5,1P,E20.6)
2000  CONTINUE
      RETURN
      END
      SUBROUTINE SIGADD(JT,SREAL,SIMAG,LEV,WV,N,JLEV,NLEV,NQN,
     1                  SIG,DEGEN,STEMP,NSIG,DMX,OMX,WT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C     INPUT IS S-MATRIX (SREAL,SIMAG( W/DESCRIPTORS IN LEV,WV (AND JLEV)
C       AND 'DEGENERACY FACTORS'
C     OUTPUT IS UPDATED CROSS SECTION MATRIX (SIG) DMAX,OMAX (MAX CHNGS)
C
      DIMENSION SREAL(N,N),SIMAG(N,N),WV(N),LEV(N),JLEV(NLEV,NQN)
      DIMENSION SIG(NSIG,NSIG),DEGEN(NSIG,NSIG),STEMP(NSIG,NSIG)
      LOGICAL BAD
      DATA PI/3.14159 26535 89793 D0/
      BAD(I)=I.LE.0.OR.I.GT.NSIG
C
      IF (N.LE.0) RETURN
C     CLEAR TEMPORARY STORAGE
      DO 1000 II=1,NSIG
      DO 1000 IF=1,NSIG
 1000 STEMP(IF,II)=0.D0
      XJT=(2*JT+1)*PI
      DO 3000 II=1,N
C     LEVI/LEVF ARE 'LEVEL NO.' IN JLEV()
C      IXI,IXF ARE INDICES IN SIGMA FROM JLEV(LEVX,NQN)
      LEVI=LEV(II)
      IXI=ABS(JLEV(LEVI,NQN))
      IF (BAD(IXI)) WRITE(6,*) ' *** BAD LEVEL',II,IXI
C     FACTOR OF PI*(2*JTOT+1)/(WAVEVECTOR OF INITIAL CHANNEL**2)
      FACT=XJT/(WV(II)*WV(II))
      DO 3000 IF=1,N
      LEVF=LEV(IF)
      IXF=ABS(JLEV(LEVF,NQN))
C     GET T = DELTA(II,IF) - S-MATRIX
      TR=-SREAL(II,IF)
      IF (II.EQ.IF)  TR=1.D0+TR
      TI=-SIMAG(II,IF)
      ADD = (TR*TR+TI*TI)*FACT/DEGEN(IXI,IXF)
      IF (WT.GT.0.D0) ADD=ADD*WT
      STEMP(IXI,IXF)=STEMP(IXI,IXF)+ADD
 3000 CONTINUE
C
C     TRANSFER FROM TEMPORARY STORAGE TO SIG()
      DMX=0.D0
      OMX=0.D0
      DO 4000 IF=1,NSIG
      DO 4000 II=1,NSIG
      IF (II.EQ.IF) THEN
        DMX=MAX(DMX,STEMP(II,IF))
      ELSE
        OMX=MAX(OMX,STEMP(II,IF))
      ENDIF
 4000 SIG(II,IF)=SIG(II,IF)+STEMP(II,IF)
      RETURN
      END
      SUBROUTINE XADD(JT,SR1,SI1,LV1,L1,WV1,N1,SR2,SI2,LV2,L2,WV2,N2,
     1                JLEV,NLEV,NQN,SIG,DEGEN,TEMP,NSIG,DMX,OMX,WT,MAP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION SR1(N1,N1),SI1(N1,N1),LV1(N1),L1(N1),WV1(N1),
     1          SR2(N2,N2),SI2(N2,N2),LV2(N2),L2(N2),WV2(N2),
     2          JLEV(NLEV,NQN),SIG(NSIG,NSIG),DEGEN(NSIG,NSIG),
     3          TEMP(NSIG,NSIG),MAP(N1)
      DATA PI/3.14159 26535 89793 D0/
C
      IF (N1.LE.0.OR.N2.LE.0) RETURN
C     CLEAR TEMP
      DO 1000 II=1,NSIG
      DO 1000 IF=1,NSIG
 1000 TEMP(II,IF)=0.D0
      OMX=0.D0
      DMX=0.D0
      XJT=(2*JT+1)*PI
      IF (WT.LE.0.D0) WT=1.D0
C
      DO 8000 I1=1,N1
      NMATCH=0
      MAP(I1)=0
      DO 8001 I2=1,N2
      IF (LV1(I1).NE.LV2(I2).OR.L1(I1).NE.L2(I2)) GO TO 8001
      IF (WV2(I2).NE.WV1(I1))
     1   WRITE(6,*) ' *** ERROR IN WVEC,I1,I2',I1,I2
      MAP(I1)=I2
      NMATCH=NMATCH+1
 8001 CONTINUE
      IF (NMATCH.GT.1) THEN
        WRITE(6,*) ' *** MORE THAN ONE MATCH ',NMATCH
        WRITE(6,*) '     I1 =',I1
      ENDIF
 8000 CONTINUE
C
C     SUBTRACT 1. FROM DIAGONAL S-MATRIX.  N.B. THESE WILL NOT BE USED
C       AGAIN; IF THEY WERE, ONE COULD ADD THE 1. BACK ON BEFORE EXITING.
C     T-MATRIX = NEGATIVE OF S-MATRIX IGNORED AS ONLY PRODUCT IS USED.
      DO 8100 I1=1,N1
 8100 SR1(I1,I1)=SR1(I1,I1)-1.D0
      DO 8200 I2=1,N2
 8200 SR2(I2,I2)=SR2(I2,I2)-1.D0
C
      DO 2000 II1=1,N1
      II2=MAP(II1)
      IF (II2.EQ.0) GO TO 2000
      LEVI=LV1(II1)
      IXI=ABS(JLEV(LEVI,NQN))
      WVEC=WV1(II1)
      FACT=XJT*WT/(WVEC*WVEC)
      DO 2100 IF1=1,N1
      IF2=MAP(IF1)
      IF (IF2.EQ.0) GO TO 2100
      LEVF=LV1(IF1)
      IXF=ABS(JLEV(LEVF,NQN))
      ADD=(SR1(II1,IF1)*SR2(II2,IF2)+SI1(II1,IF1)*SI2(II2,IF2))
     1       *FACT/DEGEN(IXI,IXF)
      TEMP(IXI,IXF)=TEMP(IXI,IXF)+ADD
 2100 CONTINUE
 2000 CONTINUE
C
      DO 4000 II=1,NSIG
      DO 4000 IF=1,NSIG
      IF (II.EQ.IF) THEN
        DMX=MAX(DMX,TEMP(II,IF))
      ELSE
        OMX=MAX(OMX,TEMP(II,IF))
      ENDIF
 4000 SIG(II,IF)=SIG(II,IF)+TEMP(II,IF)
      RETURN
      END
      SUBROUTINE DEGENI(SIG,NTOP,JLEV,NLEV,NQN)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C     THIS CODE IS SPECIFIC TO ITYPE=3,23 AND IDENTICAL PARTICLES
C     ***NOTE*** THIS USES TAKAYANAGI'S COUNTING FOR IDENTICAL MOLS
      DIMENSION SIG(NTOP,NTOP),JLEV(NLEV,NQN)
      F(J)=2*J+1
C     FILL INITIALLY WITH SIGNAL TO CHECK DUPLICATES/MISSING
      DO 1000 LF=1,NTOP
      DO 1000 LI=1,NTOP
 1000 SIG(LI,LF)=-9.9
C
      DO 2000 II=1,NLEV
      LI=ABS(JLEV(II,NQN))
      IF (LI.GT.NTOP) GO TO 2000
      J1I=JLEV(II,1)
      J2I=JLEV(II,2)
      DGI=F(J1I)*F(J2I)
      IF (J1I.EQ.J2I) DGI=DGI*0.5D0
      DO 2100 IF=1,NLEV
      LF=ABS(JLEV(IF,NQN))
      IF (LF.GT.NTOP) GO TO 2100
      DGF=1.D0
      IF (JLEV(IF,1).EQ.JLEV(IF,2)) DGF=0.5D0
      DG=DGI*DGF
      IF (SIG(LI,LF).LT.0.0) GO TO 2200
      IF (ABS(SIG(LI,LF)-DG).LE.1.D-6) GO TO 2100
      WRITE(6,600) II,IF,LI,LF,SIG(LI,LF),DG
  600 FORMAT(' *** ERROR IN DEGENI. INITIAL/FINAL JLEV/JLEVEL',2I4,2X,
     1        2I4,2F10.2)
      GO TO 2100
 2200 SIG(LI,LF)=DG
 2100 CONTINUE
 2000 CONTINUE
      RETURN
      END
      SUBROUTINE IDCHK(IDENT,NLEV,JLEV)
      DIMENSION JLEV(NLEV)
      LOGICAL J1GEJ2,J1LEJ2,J1AND2
      WRITE(6,600)
  600 FORMAT('  ***'/'  *** FOR MOD(ITYPE,10)=3 ATTEMP TO DETERMINE'
     1      ,' IDENT FROM JLEV'/'  ***')
      J1GEJ2=.TRUE.
      J1LEJ2=.TRUE.
      DO 1000 I=1,NLEV
      J1=JLEV(I)
      J2=JLEV(NLEV+I)
      J1GEJ2=J1GEJ2.AND.J1.GE.J2
 1000 J1LEJ2=J1LEJ2.AND.J1.LE.J2
      IF (J1LEJ2.AND.J1GEJ2) THEN
        WRITE(6,601)
  601   FORMAT('  *** J1=J2 FOR ALL BASIS FUNCTIONS ',
     1         ' -- ASSUME NON-IDENTICAL')
        IDENT=0
        GO TO 9000
      ENDIF
      IF ((.NOT.J1LEJ2).AND.(.NOT.J1GEJ2)) THEN
        WRITE(6,602)
  602   FORMAT('  *** BASIS NOT ORDERED J1.GT.J2 OR J1.LE.J2',
     1       ' -- ASSUME NON-IDENTICAL')
        IDENT=0
        GO TO 9000
      ENDIF
C     IF WE REACH BELOW, EITHER J1.GE.J2 **OR** J1.LE.J2 FOR ALL BASIS
      WRITE(6,603)
  603 FORMAT('  *** BASIS IS ORDERED EITHER J1.GE.J2 OR J1.LE.J2'/
     1       '      ASSUME IDENTICAL PARTICLES')
      IDENT=1
 9000 WRITE(6,604) IDENT
  604 FORMAT('  *** IDENT HAS BEEN SET TO',I3)
      RETURN
      END
      SUBROUTINE SWRITE(IU,N,S)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION S(N,N)
C
      WRITE(IU) ((S(I,J),J=1,I),I=1,N)
      RETURN
C
      ENTRY SREAD(IU,N,S,IEND)
      IEND=0
      READ(IU,END=9999) ((S(I,J),J=1,I),I=1,N)
      DO 1000 I=1,N
      DO 1000 J=1,I-1
 1000 S(J,I)=S(I,J)
      RETURN
 9999 IEND=1
      RETURN
      END