ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/PROG/MISC/TIDY621.ZIP/TIDY.FOR

Text File | 1990-09-26 | 148.2 KB | 4,781 lines

      PROGRAM TIDY
C
C     ==================================================================
C     *                                                                *
C     *                    * * *   T I D Y   * * *                     *
C     *                                                                *
C     *      A FORTRAN PROGRAM TO RENUMBER AND OTHERWISE CLEAN UP      *
C     *             OLD AND TIRED FORTRAN SOURCE PROGRAMS.             *
C     *                                                                *
C     *                   IN ADDITION TO RENUMBERING,                  *
C     *             TIDY PROVIDES A LIMITED SET OF FORTRAN             *
C     *                          DIAGNOSTICS.                          *
C     *                                                                *
C     *                 ANSI FORTRAN  (ANSI X3.9-1978)                 *
C     *                                                                *
C     *                                                                *
C     *       CONVERTED TO IBM (RYAN-McFARLAND) PROFESSIONAL FORTRAN   *
C     *       BY AL STANGENBERGER, DEPT. OF FORESTRY, U.C. BERKELEY    *
C     *       THIS VERSION IS DATED SEPTEMBER 1990                     *
C     *                                                                *
C     ==================================================================
C
C      Copyright (C) 1989, The Regents of the University of California
C                          All Rights Reserved
C
C      THE REGENTS OF THE UNIVERSITY OF CALIFORNIA MAKE NO REPRESENTA-
C      TION OR WARRANTIES WITH RESPECT TO THE CONTENTS HEREOF AND
C      SPECIFICALLY DISCLAIM ANY IMPLIED WARRANTIES OF MERCHANTABILITY
C      OR FITNESS FOR ANY PARTICULAR PURPOSE.
C
C      Further, the Regents of the University of California reserve the
C      right to revise this software and/or documentation and to make
C      changes from time to time in the content hereof without obliga-
C      tion of the Regents of the University of California to notify
C      any person of such revision or change.
C
C      PERMISSION TO COPY AND DISTRIBUTE THIS PROGRAM, AND TO MAKE
C      DERIVATIVE WORKS HEREFROM, IS GRANTED PROVIDED THAT THIS COPY-
C      RIGHT NOTICE IS RETAINED IN ALL SOURCE CODE AND USER MANUALS.
C
C     ==================================================================
C     *                                                                *
C     *                   **************************                   *
C     *                  *         PROGRAM          *                  *
C     *                 *     AND SUBROUTINES BY     *                 *
C     *                *        HARRY M MURPHY        *                *
C     *               *  AIR FORCE WEAPONS LABORATORY  *               *
C     *                *   KIRTLAND AIR FORCE BASE    *                *
C     *                 *         NEW MEXICO         *                 *
C     *                  *         1 9 6 6          *                  *
C     *                   **************************                   *
C     *                                                                *
C     *       TIDY ACCEPTS ASA FORTRAN WITH 19 CONTINUATION CARDS      *
C     *     AS WELL AS SOME IBM AND CDC DIALECT FORTRAN STATEMENTS     *
C     *                                                                *
C     *       THIS VERSION MODIFIED FOR USE AT LRL BERKELEY BY         *
C     *       GERRY TOOL (1967). (STILL CDC/6600)                      *
C     *                                                                *
C     *      THIS PROGRAM HAS BEEN REVISED FOR IBM 360/67 BY ALICE     *
C     *      V BARLOW, NASA AMES, SUMMER 1972                          *
C     *                                                                *
C     *       ADDITIONS AND REWORKING BY ROGER CHAFFEE, LRL BERKELEY   *
C     *       AND SLAC COMPUTATIONS RESEARCH GROUP, 1968-1982          *
C     ==================================================================
C
C
C  INPUT/OUTPUT
C     FUNCTION          FORTRAN UNIT   CURRENT VALUE
C      CONSOLE OUTPUT     STDERR            0
C      CONSOLE INPUT      STDIN             0  (5 for UNIX systems)
C      CONTROL CARD       USRFIL            3
C      INPUT              INFILE            4
C      LIST OUTPUT        OUTFIL            6
C      CARD OUTPUT        PUNFIL            8
C      SCRATCH(NORMAL)    SCFIL1            1
C      SCRATCH(FORMATS)   SCFIL2            2
C
C     *****************************************************************
C     I N S T A L L A T I O N   N O T E S
C
C     1.  INCLUDE statements are used to incorporate common block
C         definitions into most subroutines.  Check syntax as these
C         statements are system-dependent.
C
C
C     2.  CHARACTER SET SPECIFICITY - function KUPPER must be modified
C         (by changing a PARAMETER statement) if the system is using
C         a character set other than ASCII.  The proper EBCDIC values
C         are included as a comment statement.
C
C         ALSO, the code for horizontal tab differs in EBCDIC and ASCII.
C         This value is set (KTAB) in this routine. Fix as needed.
C
C     3.  Interactive file opening:  Subroutine PCTIDY interactively
C         opens all data and scratch files by calling subroutine OPFIL.
C         This routine was written for the IBM (Ryan-McFarland)
C         Professional Fortran compiler, and may not work with other
C         compilers (it does work with f77 on 4.3 BSD UNIX).
C
C         Subroutine OPFIL uses function DOSDEV to determine if a file
C         name is that of a MS-DOS reserved device.  Non MS-DOS systems
C         should delete the call to DOSDEV in subroutine OPFIL.
C
C         The entire interactive part of the program can be deleted
C         if not appropriate for your operating system.
C         Delete the call to PCTIDY below, and also delete subroutines
C         PCTIDY, OPFIL, and DOSDEV.
C
C         Aside from these factors, the rest of the program is
C         fairly standard Fortran-77.
C
C
C     NOTES:
C
C     IN SUBROUTINE HOLSCN, HOLLERITH CHARACTERS ARE CHANGED
C     SO THEY WON-T BE RECOGNIZED BY ANY OTHER TEST BY
C     CHANGING SECOND CHARACTER TO '@'
C
C     SUBROUTINES HOLSCN AND CONTRL INVOKE FUNCTION KUPPER TO CONVERT
C     LOWER-CASE ALPHABETIC CHARACTERS TO UPPER CASE (EXCEPT FOR
C     HOLLERITH STRINGS).  *** KUPPER IS CHARACTER-SET DEPENDENT ***
C
C     THE CHARACTER $ IS TREATED AS AN ALPHA IN IBM FORTRAN.
C     THE DATA STATEMENT FOR THE SPECIAL CHARACTERS, KSPK, HAS
C     BEEN CHANGED SO THAT $ IS NOT RECOGNIZED AS A SPECIAL
C     CHARACTER.  THIS DATA STATEMENT SHOULD BE CHANGED BACK
C     ON NON-IBM SYSTEMS.
C
C     SUBROUTINE REDSTR IS SET UP TO ACCOMMODATE AN APPARENT BUG
C     IN THE RYAN-MCFARLAND PROFESSIONAL FORTRAN COMPILER, THAT
C     UNFORMATTED SEQUENTIAL RECORDS SEEM TO BE LIMITED TO 1024 BYTES.
C     SINCE EACH RECORD HAS A 4-BYTE HEADER AND TRAILER, WRITES 508
C     CHARACTER*2 ELEMENTS, OR 254 INTEGER*4 PER RECORD.  THIS MAY
C     VARY FOR OTHER COMPILERS.
C
C
C  INTERNAL FLAGS (JUST A LIST.  WHERE ELSE TO PUT IT...)
C     MANSI =  0 FLAG ALL NON-ANSI (FORTRAN-77) STATEMENTS
C           =  1 DO NOT FLAG NON-ANSI STATEMENTS
C     MP2   =  1 DO PASS2
C           =  0 NO PASS 2
C     MCOL  = -1 COLLECT FORMAT STATEMENTS AT END
C           =  0 LEAVE THEM IN PLACE
C     MILDO = -1 IF DO-TERMINATOR ALLOWED BUT NON-STANDARD
C           =  0 IF DO-TERMINATOR ALLOWED
C           = +1 IF DO-TERMINATOR FORBIDDEN
C     MCONT =  0 REMOVE CONTINUE CARDS AND DOUBLE BRANCHES
C           =  1 LEAVE THEM
C     MTRAN = -1 CURRENT CARD IS AN UNCONDITIONAL BRANCH
C           =  0 CURRENT CARD NOT NECESSARILY A BRANCH
C     NTRAN =    SAME AS MTRAN, BUT REFERS TO PREVIOUS CARD
C     MLGC  = -1 NORMAL STATEMENT
C           =  0 STATEMENT IS CONTROLLED BY A LOGICAL IF
C     MRIT  =  N LEFT ADJUST TO COLUMN N
C           = -N RIGHT ADJUST TO COLUMN N
C     MDEB  =  0 *NODEBUG
C           =  1 *DEBUG
C     KD15  =    STATEMENT INCREMENT (*STAT=...)
C     KB15  =    STATEMENT BASE (*BASE=...)
C     MPUN  =  0 NO PUNCH OUTPUT
C           =  1 MAKE PUNCH OUTPUT
C     KPUN       SAVES *CARD/*NOCARD (1/0) FOR MPUN VALUE
C     MLIST = -1 (*LIST) LIST PASS 1
C           =  0 (*NOLIST) DONT
C     KPRIN =  1 (*LIST=2) LIST PASS 2
C           =  0 (*NOLIST=2) DONT
C     MPRIN =    KPRIN AT START OF ROUTINE. MAY CHANGE IF ERROR
C                  AT START OF PASS1.
C     KOUNT      COUNTS CARDS IN FOR CURRENT ROUTINE.
C     IQUIT =  0 UNTIL INPUT ENDFILE IS FOUND IN READER.
C           =  1 THEREAFTER
C     MSTOP =  0 NORMALLY
C           = -1 FOR *STOP CARD FOUND--TIME TO FINISH UP
C           =  1 FOR STOP NOW.
C
C
C     ******************************************************************
C
      INCLUDE 'TIDY.INC'
      INCLUDE 'UNITS.INC'
      LOGICAL DOUSER,SCDISK
      COMMON/TDYVER/VERNUM
      CHARACTER*25 VERNUM
C
      DOUSER=.TRUE.
C
C     SCDISK .TRUE. ALLOWS USER TO SPECIFY DISK TO HOLD SCRATCH FILES.
C          FOR UNIX SYSTEMS, SHOULD SET TO .FALSE.
      SCDISK=.TRUE.
C
C     VALUE FOR TAB AS ASCII
      KTAB = KBL
      KTAB(1:1)=CHAR(9)
C     VALUE FOR TAB AS EBCDIC
C     KTAB(1:1)=CHAR(5)
C
C     FOR NON-INTERACTIVE USE, DELETE CALL TO PCTIDY
      CALL PCTIDY (DOUSER,SCDISK)
C
C     INITIALIZE PROGRAM
      CALL INITDY
C     ADJUST ROUTINE NUMBER - PASS1 WILL INCREMENT IT.
      NROUT = NROUT-1
C
C     PROCESS USER CONTROL CARD FILE.
      IF (DOUSER) CALL USRCON
C
      CALL READER
 10   CALL PASS1
      IF (MSTOP.NE.0) THEN
         IF (MSTOP.GT.0) GO TO 20
         IF (KOUNT.LE.0) GO TO 20
      ENDIF
      CALL EDIT
      IF (MP2.EQ.0) GO TO 10
      IF (MREF.NE.0) CALL RDIR
      CALL PASS2
      IF (MSTOP.EQ.0) GO TO 10
C                            ALL DONE
 20   CALL IOSY11
      CALL IOSY21
      IF (NMSG.GT.0) THEN
            WRITE (OUTFIL,60) NMSG
      ELSE
            WRITE (OUTFIL,70)
      ENDIF
      WRITE (OUTFIL,80) NPUN, VERNUM
      LEVEL = LERR
      IF (LEVEL.GE.2) STOP 8
      IF (LEVEL.EQ.1) STOP 4
      IF (MDEB.EQ.0) THEN
           CLOSE (SCFIL1,STATUS='DELETE')
           CLOSE (SCFIL2,STATUS='DELETE')
      END IF
      STOP
C
 60   FORMAT ( '0W A R N I N G .',I5,  ' DIAGNOSTIC MESSAGES HAVE BEEN G
     1ENERATED IN THIS TIDY RUN.')
 70   FORMAT (  '0NO DIAGNOSTIC MESSAGES WERE GENERATED DURING THIS TIDY
     1 RUN.')
 80   FORMAT ('0',I5, ' CARDS WERE PUNCHED.'/  '0',A/'1')
      END
      BLOCK DATA MISDAT
C
C     THIS BLOCK DATA CONTAINS MISCELLANEOUS DATA STATEMENTS FOR TIDY.
C
C     VERSION 6.2 MODIFICATION -----------------------------------------
C     VARIABLES WHICH ARE CONTROLLED BY SUBROUTINE CONTRL ARE SET IN
C     SUBROUTINE INITDY.
C
      INCLUDE 'TIDY.INC'
      INCLUDE 'UNITS.INC'
      COMMON/TDYVER/VERNUM
      CHARACTER*25 VERNUM
C
C     /ALPHA/
      DATA KBL,KDIG/' ','0','1','2','3','4','5','6','7','8','9'/
      DATA KABC/'A','B','C','D','E','F','G','H','I','J','K','L','M','N',
     1'O','P','Q','R','S','T','U','V','W','X','Y','Z'/
      DATA KSPK/'=', ',', '(', '/', ')', '+', '-', '*', '.', 'X$', '-',
     1'''', '&', '$'/
C  $ IN ABOVE STATEMENT REPLACED BY X$, SINCE $ IS NOT SPECIAL
C  CHARACTER IN IBM 360/370 FORTRAN.
      DATA KBL2, KLR2, KLP2, KRP2, KERM/' *', '$$', '((', '))', ' $'/
      DATA KAMPR /'& '/, KAT /' @'/, KAPSTR/'''@'/
C
C     /MISCAL/
      DATA KEND /'D' ,'N' ,'E'/
C
C
C     /MISC/
C     LOGICAL UNIT ASSIGNMENTS
      DATA INFILE /4/
      DATA OUTFIL /6/
      DATA PUNFIL /8/
      DATA STDERR /0/
      DATA STDIN  /5/
      DATA SCFIL1 /1/
      DATA SCFIL2 /2/
      DATA USRFIL /3/
C
      DATA IQUIT /0/
      DATA KOUNT /0/
      DATA LERR /0/
      DATA LINE /1/
      DATA MDEB /0/
      DATA MSTOP /0/
      DATA MXREF /256/
      DATA MXRGHT /65/
      DATA NMSG /0/
      DATA NPAGE /0/
      DATA NPUN /0/
C
C     VERSION STRING
      DATA VERNUM/'TIDY VER.  6.21- 09/21/90' /
      END
      SUBROUTINE PCTIDY (DOUSER,SCDISK)
C
C     INTERACTIVE FILE DEFINITION ROUTINE FOR TIDY
C
      INCLUDE 'TIDY.INC'
      INCLUDE 'UNITS.INC'
      COMMON/TDYVER/VERNUM
      CHARACTER*25 VERNUM
      CHARACTER DRIVE
      CHARACTER RESP(80)
      CHARACTER*64 FILNAM, FILNAM2
      INTEGER DOSDEV, OPFIL
      LOGICAL DOUSER, SCDISK
C
      WRITE (STDERR,25) VERNUM
C
 10   WRITE (STDERR,30)
      READ (STDIN,40) RESP
      I=0
 20   I=I+1
      IF (I.GT.80) GO TO 10
      IF (RESP(I).EQ.' ') GO TO 20
      IF (RESP(I).EQ.'Y'.OR.RESP(I).EQ.'y') THEN
           DOUSER=.TRUE.
      ELSE IF (RESP(I).EQ.'N'.OR.RESP(I).EQ.'n') THEN
           DOUSER=.FALSE.
      ELSE
           GO TO 10
      ENDIF
C
C     OPEN CONTROL FILE
      IF (DOUSER) THEN
           FILNAM=' '
           IOPFL =  OPFIL (USRFIL,FILNAM,0,-1,'control card',LNG)
           ISCONS=DOSDEV(FILNAM)
      END IF
C
C     DEFINE SOURCE, LISTING, AND OUTPUT FILES.
      FILNAM=' '
      IOPFL =  OPFIL (INFILE,FILNAM,0,-1,'source',LNG)
      FILNAM=' '
      IOPFL =  OPFIL (OUTFIL,FILNAM,0,1,'listing',LNG)
      FILNAM=' '
      IOPFL =  OPFIL (PUNFIL,FILNAM,0,1,'punched output',LNG)
      FILNAM=' '
C
C     FOR PC'S, ALLOW USER TO SPECIFY DISK FOR SCRATCH FILES.
      IF (SCDISK) THEN
           WRITE (STDERR,50)
           READ (STDIN,40) DRIVE
           FILNAM=DRIVE//':SCFIL1.TDY'
           FILNAM2=DRIVE//':SCFIL2.TDY'
      ELSE
           FILNAM='SCFIL1.TDY'
           FILNAM2='SCFIL2.TDY'
      END IF
C
C     OPEN SCRATCH FILES
      IOPFL =  OPFIL (SCFIL1,FILNAM,-1,2,'SCRATCH',LNG)
      IOPFL =  OPFIL (SCFIL2,FILNAM2,-1,2,'SCRATCH',LNG)
C
C     PROMPT USER FOR CONTROL CARDS IF CONSOLE INPUT.
      IF (ISCONS.EQ.2) WRITE (STDERR,60)
C
      RETURN
C
 25   FORMAT (1X,A)
 30   FORMAT (' Do you have a CONTROL CARD file? (y-n) ')
 40   FORMAT (80A1)
 50   FORMAT (' ENTER DISK TO USE FOR TEMPORARY FILES: ')
 60   FORMAT (' Enter TIDY control cards.  Type CTRL-Z to stop.')
      END
      CHARACTER*2 FUNCTION KUPPER (C)
C
C     CONVERTS LOWER-CASE LETTERS TO UPPER-CASE. SEMI-PORTABLE VERSION.
C     ALGORITHM ALLOWS FOR NON-ALPHABETIC CHARACTERS WITHIN THE (a-z)
C     INTERVAL (AS WITH EBCDIC)
C
C     AL STANGENBERGER, FORESTRY, U.C. BERKELEY  AUGUST 1988
C
C     PARAMETERS:
C       ICA  = DECIMAL CODE FOR UPPER-CASE A
C       ICZ  = DECIMAL CODE FOR UPPER-CASE Z
C       ICLA = DECIMAL CODE FOR LOWER-CASE a
C       ICLZ = DECIMAL CODE FOR UPPER-CASE z
C
C     ASCII PARAMETERS
      PARAMETER (ICA=65,ICLA=97,ICZ=90,ICLZ=122)
C
C     EBCDIC PARAMETERS
C     PARAMETER (ICA=193,ICLA=129,ICZ=233,ICLZ=169)
C
      CHARACTER  C2
      CHARACTER*2 TBL(ICLA:ICLZ),C,KBL
      CHARACTER*26 LC,UC
      LOGICAL SETUP
      DATA LC/'abcdefghijklmnopqrstuvwxyz'/
      DATA UC/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
      DATA SETUP /.TRUE./
      DATA KBL /' @'/

C
C     BUILD TRANSLATION TABLE FIRST PASS.
C     (NOTE - EBCDIC HAS SOME NON-ALPHABETIC CHARS IN THE INTERVAL, SO
C      BUILD A TABLE WHICH WON'T TRANSLATE THEM.)
      IF (SETUP) THEN
       J=1
       DO 10 I=ICLA,ICLZ
       TBL(I)='  '
       C2 = CHAR(I)
       IF (C2.EQ.LC(J:J))THEN
        TBL(I)(1:1) = UC(J:J)
        J=J+1
       ELSE
        TBL(I)(1:1)=C2(1:1)
       ENDIF
   10  CONTINUE
C
      SETUP = .FALSE.
      ENDIF
      IF (C(2:2).EQ.KBL(2:2)) THEN
       KUPPER = C
       RETURN
      ENDIF
C
C     IF C OUTSIDE OF LOWER-CASE RANGE, RETURN
      I = ICHAR(C(1:1))
      IF (I.GE.ICLA .AND. I.LE.ICLZ) THEN
       KUPPER = TBL(I)
      ELSE
       KUPPER = C
      ENDIF
      RETURN
      END
      LOGICAL FUNCTION BAKSCN (C1,C2)
C
C     SCANS A STRING BACKWARD FROM CURRENT POSITION FOR C1 AND C2
      CHARACTER*2 C1, C2, JT
      INCLUDE 'TIDY.INC'
      IP = JCOL
C     FIRST BACK TO LCPY
    5 IF (JINT(IP).EQ.LCPY) GO TO 10
      IP = IP-1
      GO TO 5
C
C     NOW SCAN FOR C1, C2
   10 JT = C1
      I = 1
   15 IP = IP-1
      IF (JINT(IP).EQ.KBL) GO TO 15
      IF (JINT(IP).NE.JT) THEN
           BAKSCN = .FALSE.
           RETURN
      ENDIF
      IF (I.EQ.1) THEN
           JT = C2
           I = 2
           GO TO 15
      ENDIF
      BAKSCN = .TRUE.
      RETURN
      END
      SUBROUTINE CONTRL
      PARAMETER (NKTRL=33)
C
C     THIS SUBROUTINE EXECUTES THE TIDY CONTROL STATEMENTS.
C     ALL TIDY CONTROL STATEMENTS MUST HAVE AN * PUNCHED IN COLUMN 1.
C
C     1   BASE   NOBASE   KB15
C     2   IDIN   ======   KD79
C     3   IDST   ======   KD79
C     4   ROUT   ======   NROUT
C     5   STAT   ======   KD15
C     6   CARD   NOCARD   MPUN
C     7   COLL   NOCOLL   MCOL
C     8   COMM   NOCOMM   MCOM
C     9   EXEM   NOEXEM   MEX
C     10  LABE   NOLABE   MLBL
C     11  LAST   ======   MSTOP
C     12  LIST   NOLIST   MLIST
C     13  NEWR   ======   NROUT
C     14  REFE   NOREFE   MREF
C     15  SKIP   ======   MSKP
C     16  STOP   ======   MSTOP
C     17  SERI   NOSERI   MSER  <0 USE KOL73...=0 USE BLANKS >0 SERIAL
C     18  RIGH   ======   MRIT
C     19  LEFT   ======   MRIT
C     20  COLU   NOCOLU   JUST
C     21  INDE   NOINDE   INDENT
C     22  DEBU   NODEBU   MDEB
C     23  CONT   NOCONT   MCONT
C     24  END    ======   SAME AS STOP
C     25  ANSI   NOANSI   MANSI
C     26  FEND   NOFEND   NFEND
C     27  CCHR   ======   KCTCTL
C     28  HTRA   ======   KHTRAN
C     29  DTRA   NODTRA   KDTRAN
C     30  DEL1   ======   KDEL1
C     31  DEL2   ======   KDEL2
C     32  ARET   ======   KALMRK
C     33  ARTR   NOARTR   KALTRN
C
      INCLUDE 'TIDY.INC'
C
      COMMON /CONTDY/ KTRL(4,NKTRL)
      CHARACTER*2 KTRL
      CHARACTER*2 KUPPER,IT
C
      I=14
      ISTAR=-1
      JSW=0
      JL=JMAX-1
C
C     SCAN FOR 'NO' AT START
      DO 10 JB=2,JL
           IT=JINT(JB)
           IF (IT.EQ.KBL) GO TO 10
           IT=KUPPER(IT)
           IF (IT.NE.KABC(I)) THEN
               JC=2
               GO TO 30
           ENDIF
           I=I+1
           IF (I.GT.15) GO TO 20
 10   CONTINUE
      ISTAR=1
      RETURN
C
 20   JSW=1
      JC=JB+1
 30   DO 50 J=1,NKTRL
           I=1
           DO 40 JCOL=JC,JMAX
                IT=KUPPER(JINT(JCOL))
                IF (IT.EQ.KTRL(I,J)) THEN
                     IF (I.GE.4) GO TO 70
                     I=I+1
                ELSE
                     IF (IT.NE.KBL) GO TO 50
                END IF
 40        CONTINUE
 50   CONTINUE
 60   ISTAR=1
      RETURN
C
C     EXECUTE CONTROL STATEMENT
C
 70   NREC=NREC-1
C                  JSW=1 IF CARD STARTS WITH NO
      IF (JSW.EQ.1) THEN
           GO TO (360,60,60,60,60,110,130,150,230,280,60,390,60,320,60,
     1      60,350,60,60,370,380,190,170,60,90,250,60,260,210,60,205,
     2      60,75),J
      ELSE
           GO TO (390,390,390,390,390,100,120,140,220,270,290,390,300,
     1      310,330,290,340,390,390,390,390,180,160,290,80,240,390,390,
     2      200,390,390,390,390),J
      END IF
C
C                  NOARTRAN
 75   KALTRN = KBL
      RETURN
C                  ANSI
 80   MANSI=0
      RETURN
C                  NOANSI
 90   MANSI=1
      RETURN
C                  CARD
 100  MPUN=-1
      KPUN=-1
      RETURN
C                  NOCARD
 110  MPUN=0
      KPUN=0
      RETURN
C                  COLL
 120  MCOL=-1
      RETURN
C                  NOCOLL
 130  MCOL=0
      RETURN
C                  COMM
 140  MCOM=-1
      RETURN
C                  NOCOMM
 150  MCOM=0
      RETURN
C                  CONT
 160  MCONT=1
      RETURN
C                  NOCONT
 170  MCONT=0
      RETURN
C                  DEBUG
 180  MDEB=1
      RETURN
C                  NODEBUG
 190  MDEB=0
      RETURN
C                  DTRAN
 200  KDTRAN=1
      RETURN
C                  NODEL2 -- IMPLIES *NODTRAN
 205  KDEL2 = '""'
C                  NODTRAN
 210  KDTRAN=0
      RETURN
C                  EXEM
 220  MEX=-1
      RETURN
C                  NOEXEM
 230  MEX=0
      RETURN
C                  FEND
 240  NFEND=0
      RETURN
C                  NOFEND
 250  NFEND=1
      RETURN
C                  NOHTRAN
 260  KHTRAN=0
      RETURN
C                  LABE
 270  MLBL=-1
      RETURN
C                  NOLABE
 280  MLBL=0
      RETURN
C                  LAST/STOP
 290  MSTOP=-1
      RETURN
C                  NEWR
 300  CALL INITDY
      RETURN
C                  REFE
 310  MREF=-1
      RETURN
C                  NOREFE
 320  MREF=0
      RETURN
C                  SKIP
 330  MSKP=-1
      RETURN
C                  SERI
 340  MSER=-1
      RETURN
C                  NOSERI
 350  MSER=0
      RETURN
C                  NOBASE
 360  KB15=0
      RETURN
C
C                  NOCOLU
 370  JUST=0
      RETURN
C
C                  NOINDENT
 380  INDENT=0
      RETURN
C
C     GET NUMBER FOLLOWING (=) SIGN.
C
 390  JAVB=JCOL
      DO 400 JCOL=JAVB,JMAX
           IF (JINT(JCOL).EQ.KSPK(1)) GO TO 410
 400  CONTINUE
      L772=1D0
      GO TO 420
 410  JCOL=JCOL+1
      JAVB=JCOL
      CALL RSTAT
 420  GO TO (430,440,440,450,500,60,60,60,60,60,60,560,60,60,60,60,60,
     1540,550,510,530,60,60,60,60,60,600,520,60,600,600,600,600),J
C                  BASE
 430  KB15=IDINT(L772)
      RETURN
C                  IDIN/IDST
 440  KD79=MAX0(IDINT(L772),1)
      RETURN
C                  ROUT
C     USE TWO LETTERS FOR ROUTINE CODE, CONSTRUCT VALUE OF NROUT.
 450  JCOL=JAVB-1
      NROUT=0
      DO 480 I=1,2
 460       JCOL=JCOL+1
           IT=KUPPER(JINT(JCOL))
           IF (IT.EQ.KBL) GO TO 460
           IF (IT.EQ.KERM) GO TO 490
           DO 470 J=1,26
                IF (IT.NE.KABC(J)) GO TO 470
                NROUT=NROUT*26+J
                GO TO 480
 470       CONTINUE
 480  CONTINUE
C
 490  NROUT=MAX0(NROUT-1,1)
      RETURN
C                  STAT
 500  KD15=MAX0(IDINT(L772),1)
      RETURN
C                  COLU
 510  JUST=MAX0(IDINT(L772),7)
      RETURN
C                  HTRAN
 520  KHTRAN=MIN0(IDINT(L772),3)
      IF (KHTRAN.LT.0) KHTRAN=0
      RETURN
C                            INDENT
 530  INDENT=MIN0(10,IDINT(L772))
      RETURN
C                            RIGHT
 540  MRIT=MIN0(IDINT(L772),5)
      IF (MRIT.EQ.0) MRIT=5
      RETURN
C                            LEFT
 550  MRIT=MAX0(IDINT(L772),1)
      IF (MRIT.GT.5) MRIT=1
      RETURN
C                            LIST/NOLIST
 560  IF (IDINT(L772).EQ.2) GO TO 580
      IF (JSW.NE.0) GO TO 570
C                            LIST
      MLIST=-1
      RETURN
C                            NOLIST
 570  MLIST=0
      RETURN
 580  IF (JSW.NE.0) GO TO 590
C                            LIST=2.
      KPRIN=1
      MPRIN=1
      RETURN
C                            NOLIST=2.
 590  MPRIN=0
      KPRIN=0
      RETURN
C
C                  CARDS USING CHARACTER ARGUMENT
 600  JCOL=JAVB-1
 610  JCOL=JCOL+1
      IT=KUPPER(JINT(JCOL))
      IF (IT.EQ.KBL) GO TO 610
      IF (J.EQ.27) THEN
C                            CCHR (CONTINUATION CHAR)
           IF (IT.NE.KERM.AND.IT.NE.KDIG(1)) THEN
                KCTCTL=1
                KCTCHR=JINT(JCOL)
                RETURN
           END IF
C     NO CHARACTER SPECIFIED OR ZERO.
           KCTCTL=0
           KCTCHR=KSPK(10)
           IF (IT.EQ.KDIG(1)) CALL DIAGNO (38)
      ELSE IF (J.EQ.30) THEN
C                            DEL1 (PRIMARY STRING DELIMITER)
           KDEL1 = KBL
           KDEL1(1:1)=IT(1:1)
           KAPSTR=KDEL1(1:1)//KAT(2:2)
      ELSE IF (J.EQ.31) THEN
C                            DEL2 (SECONDARY STRING DELIMITER)
           KDEL2 = KBL
           KDEL2(1:1)=IT(1:1)
      ELSE IF (J.EQ.32) THEN
C                            ARET (ALT. RETURNS IN CALLS)
           KALMRK = IT
      ELSE IF (J.EQ.33) THEN
C                            ARTR (TRANSLATE KALMRK TO THIS)
           KALTRN = IT
      END IF
      RETURN
      END
      BLOCK DATA CTLDAT
C
      COMMON /CONTDY/ KTRL1,KTRL2,KTRL3,KTRL4,KTRL5,KTRL6,KTRL7,KTRL8,
     1KTRL9,KTRL10,KTRL11,KTRL12,KTRL13,KTRL14,KTRL15,KTRL16,KTRL17,
     2KTRL18,KTRL19,KTRL20,KTRL21,KTRL22,KTRL23,KTRL24,KTRL25,KTRL26,
     3KTRL27,KTRL28,KTRL29,KTRL30,KTRL31,KTRL32,KTRL33
      CHARACTER*2 KTRL1(4),KTRL2(4),KTRL3(4),KTRL4(4),KTRL5(4),KTRL6(4),
     1KTRL7(4),KTRL8(4),KTRL9(4),KTRL10(4),KTRL11(4),KTRL12(4),KTRL13(4)
     2,KTRL14(4),KTRL15(4),KTRL16(4),KTRL17(4),KTRL18(4),KTRL19(4),
     3KTRL20(4),KTRL21(4),KTRL22(4),KTRL23(4),KTRL24(4),KTRL25(4),
     4KTRL26(4),KTRL27(4),KTRL28(4),KTRL29(4),KTRL30(4),KTRL31(4),
     5KTRL32(4),KTRL33(4)
C
C     /CONTDY/
      DATA KTRL1/'B','A','S','E'/
      DATA KTRL2/'I','D','I','N'/
      DATA KTRL3/'I','D','S','T'/
      DATA KTRL4/'R','O','U','T'/
      DATA KTRL5/'S','T','A','T'/
      DATA KTRL6/'C','A','R','D'/
      DATA KTRL7/'C','O','L','L'/
      DATA KTRL8/'C','O','M','M'/
      DATA KTRL9/'E','X','E','M'/
      DATA KTRL10/'L','A','B','E'/
      DATA KTRL11/'L','A','S','T'/
      DATA KTRL12/'L','I','S','T'/
      DATA KTRL13/'N','E','W','R'/
      DATA KTRL14/'R','E','F','E'/
      DATA KTRL15/'S','K','I','P'/
      DATA KTRL16/'S','T','O','P'/
      DATA KTRL17/'S','E','R','I'/
      DATA KTRL18/'R','I','G','H'/
      DATA KTRL19/'L','E','F','T'/
      DATA KTRL20/'C','O','L','U'/
      DATA KTRL21/'I','N','D','E'/
      DATA KTRL22/'D','E','B','U'/
      DATA KTRL23/'C','O','N','T'/
      DATA KTRL24/'E','N','D',' '/
      DATA KTRL25/'A','N','S','I'/
      DATA KTRL26/'F','E','N','D'/
      DATA KTRL27/'C','C','H','R'/
      DATA KTRL28/'H','T','R','A'/
      DATA KTRL29/'D','T','R','A'/
      DATA KTRL30/'D','E','L','1'/
      DATA KTRL31/'D','E','L','2'/
      DATA KTRL32/'A','R','E','T'/
      DATA KTRL33/'A','R','T','R'/
      END
      SUBROUTINE COPY (N)
C
C     THIS SUBROUTINE COPYS NON-BLANK CHARACTERS FROM JINT TO IOUT.
C
C                        ===   ON ENTRY   ===
C     N .LT. 0 COPYS UNTIL PARENTHESIS COUNT IS ZERO.
C     N .EQ. 0 COPYS ALL REMAINING NON-BLANK DATA FROM JINT TO IOUT.
C     N .GT. 0 COPYS N NON-BLANK DATA FROM JINT TO IOUT.
C     THE FIRST ITEM INSPECTED IS JINT(JCOL).
C     THE FIRST ITEM STORED GOES TO IOUT(ICOL+1).
C
C                        ===   ON EXIT   ===
C     THE LAST ITEM INSPECTED WAS JINT(JCOL-1).
C     THE LAST ITEM STORED WENT TO IOUT(ICOL) AND IS IN LCPY.
C
C     MEOF .LT. 0  FOR NORMAL EXIT.
C     MEOF .EQ. 0  FOR KERM FOUND WHILE COPYING  ALL REMAINING DATA,
C                  OR FOR KERM FOUND BEFORE LEFT PARENTHESIS.
C     MEOF .GT. 0  FOR MISSING RIGHT PARENTHESIS, OR FOR MEOF =0 ON
C                  ENTRY TO COPY.
C
      INCLUDE 'TIDY.INC'
      CHARACTER*2 JT
      NT=N
      IF (MEOF.LT.0) GO TO 20
 10   MEOF=1
      LCPY=KERM
      RETURN
C
 20   IF (JCOL.GT.JMAX) GO TO 10
C
      IF (NT) 100,40,70
C
C     COPY ALL REMAINING NON-BLANK CHARACTERS.
C
 30   JCOL=JCOL+1
 40   JT=JINT(JCOL)
      IF (JT.EQ.KBL) GO TO 30
      ICOL=ICOL+1
      IOUT(ICOL)=JT
      IF (JT.NE.KERM) GO TO 30
 50   LCPY=KERM
      ICOL=ICOL-1
      MEOF=0
      RETURN
C
C     COPY --N-- NON-BLANK CHARACTERS.
C
 60   JCOL=JCOL+1
 70   JT=JINT(JCOL)
      IF (JT.EQ.KBL) GO TO 60
      ICOL=ICOL+1
      IOUT(ICOL)=JT
      NT=NT-1
      IF (NT.EQ.0) GO TO 80
      IF (JT.EQ.KERM) GO TO 50
      GO TO 60
 80   JCOL=JCOL+1
      LCPY=JT
      RETURN
C
C     COPY TO PARENTHESIS COUNT OF ZERO.
C     LOOK FOR LEFT PARENTHESIS.
C
 90   JCOL=JCOL+1
 100  JT=JINT(JCOL)
      IF (JT.EQ.KBL) GO TO 90
      ICOL=ICOL+1
      IOUT(ICOL)=JT
      LCPY=JT
      IF (JT.EQ.KSPK(3)) GO TO 110
      IF (JT.EQ.KSPK(5)) GO TO 150
      IF (JT.EQ.KERM) GO TO 50
      GO TO 90
C
C     HAVE LEFT PARENTHESIS, LOOK FOR PARENTHESIS COUNT OF ZERO.
C
 110  NPAR=1
 120  JCOL=JCOL+1
      JT=JINT(JCOL)
      IF (JT.EQ.KBL) GO TO 120
      ICOL=ICOL+1
      IOUT(ICOL)=JT
      LCPY=JT
      IF (JT.NE.KSPK(3)) GO TO 130
      NPAR=NPAR+1
      GO TO 120
 130  IF (JT.NE.KSPK(5)) GO TO 140
      NPAR=NPAR-1
      IF (NPAR) 150,80,120
 140  IF (JT.NE.KERM) GO TO 120
      CALL DIAGNO (2)
      LCPY=KERM
      GO TO 160
 150  CALL DIAGNO (3)
 160  MEOF=1
      JCOL=JCOL+1
      RETURN
      END
      SUBROUTINE DIAGNO (N)
      PARAMETER (MXMSG=38)
C
C     THIS ROUTINE WRITES THE GENERAL DIAGNOSTICS FOR TIDY.
C
      DIMENSION LV(MXMSG)
      INCLUDE 'TIDY.INC'
      INCLUDE 'UNITS.INC'
C     ***                                                            ***
C      1 THE ABOVE STATEMENT IS ILLEGAL AND HAS BEEN DELETED.
C      2 THE ABOVE STATEMENT HAS A MISSING RIGHT PARENTHESIS.
C      3 THE ABOVE STATEMENT HAS AN EXCESS RIGHT PARENTHESIS.
C      4 THE ABOVE STATEMENT INCORRECTLY TERMINATES A DO LOOP.
C      5 THE ABOVE STATEMENT CANNOT BE REACHED BY THE PROGRAM.
C      6 STATEMENT NUMBER TABLE FULL.  RENUMBER PASS DELETED.
C      7 REFERENCE NUMBER TABLE FULL.  RENUMBER PASS DELETED.
C      8 THE ABOVE STATEMENT IS OBSOLETE AND IS DELETED.
C      9 ABOVE STATEMENT HAS AN ILLEGAL FIRST SPECIAL CHARACTER.
C     10 ILLEGAL DATA, FUNCTION, OR SUBROUTINE STATEMENT.
C     11 THE ABOVE COMMON OR DATA STATEMENT IS MISSING A (/).
C     12 THE ABOVE CONTINUE STATEMENT IS REDUNDANT AND IS DELETED.
C     13 THE ABOVE DIMENSION STATEMENT IS NOT COMPLETE.
C     14 W A R N I N G .  STATEMENT SHOULD BE FIRST IN ROUTINE.
C     15 THE ABOVE DO STATEMENT HAS AN INVALID TERMINAL STATEMENT.
C     16 W A R N I N G .  UNSATISFIED DO LOOPS.
C     17 UNNUMBERED OR INVALID FORMAT STATEMENT DELETED.
C     18 WARNING.  ABOVE STATEMENT IS POOR PROGRAMMING PRACTICE.
C     19 ABOVE GO TO STATEMENT IS ILLEGAL.
C     20 ILLEGAL ARITHMETIC IF STATEMENT.   IF (ARITH) 1,2,3
C     21 ABOVE NAMELIST STATEMENT MISSING (/).
C     22 ILLEGAL READ, WRITE , OR PUNCH STATEMENT.
C     23 ILLEGAL READ (12) LIST, OR WRITE (12) LIST, STATEMENT.
C     24 DO LOOP TABLE FULL.  RENUMBER PASS DELETED.
C     25 W A R N I N G .   COMMA FOLLOWING X INSERTED IN ABOVE FORMAT.
C     26 TIDY CANNOT PROCESS THIS CLASS OF PROGRAM.  (COPY EXECUTED.)
C     27 WARNING.  ABOVE DO-LOOP TERMINUS PREVIOUSLY REFERENCED.
C     28 WARNING.  TIDY MAY HAVE CHANGED CARD 2 OF THIS ROUTINE
C     29 W A R N I N G .   END CARD INSERTED.
C     30 THE ABOVE STATEMENT IS TRANSMITTED WITHOUT PROCESSING
C     31 ILLEGAL CLOSE, INQUIRE, OR OPEN STATEMENT
C     32 W A R N I N G .   UNBALANCED ELSE/ELSEIF/ENDIF STATEENT
C     33 W A R N I N G .   UNSATISFIED IF BLOCKS.
C     34 W A R N I N G .   ABOVE STATEMENT NOT ANSI FORTRAN 77
C     35 TOO MANY REFERENCES IN ABOVE. RENUMBER PASS DELETED.
C     36 W A R N I N G .   NON-ANSI (L OR R) HOLLERITH SPEC.
C     37 ABOVE STATEMENT HAS MORE THAN 19 CONTINUATION LINES.
C     38 CCHR CARD IGNORED:   CANNOT USE ZERO.
C
      CHARACTER*60 ERMSG (MXMSG)
      DATA (ERMSG(I),I=1,15)/
     1'THE ABOVE STATEMENT IS ILLEGAL AND HAS BEEN DELETED.',
     1'THE ABOVE STATEMENT HAS A MISSING RIGHT PARENTHESIS.',
     1'THE ABOVE STATEMENT HAS AN EXCESS RIGHT PARENTHESIS.',
     1'THE ABOVE STATEMENT INCORRECTLY TERMINATES A DO LOOP.',
     1'THE ABOVE STATEMENT CANNOT BE REACHED BY THE PROGRAM.',
     1'STATEMENT NUMBER TABLE FULL.  RENUMBER PASS DELETED.',
     1'REFERENCE NUMBER TABLE FULL.  RENUMBER PASS DELETED.',
     1'THE ABOVE STATEMENT IS OBSOLETE AND IS DELETED.',
     1'ABOVE STATEMENT HAS AN ILLEGAL FIRST SPECIAL CHARACTER.',
     1'ILLEGAL DATA, FUNCTION, OR SUBROUTINE STATEMENT.',
     1'THE ABOVE COMMON OR DATA STATEMENT IS MISSING A (/).',
     1'THE ABOVE CONTINUE STATEMENT IS REDUNDANT AND IS DELETED.',
     1'THE ABOVE DIMENSION STATEMENT IS NOT COMPLETE.',
     1'W A R N I N G .  STATEMENT SHOULD BE FIRST IN ROUTINE.',
     1'THE ABOVE DO STATEMENT HAS AN INVALID TERMINAL STATEMENT.'/
      DATA (ERMSG(I),I=16,30)/
     1'W A R N I N G .  UNSATISFIED DO LOOPS.',
     1'UNNUMBERED OR INVALID FORMAT STATEMENT DELETED.',
     1'WARNING.  ABOVE STATEMENT IS POOR PROGRAMMING PRACTICE.',
     1'ABOVE GO TO STATEMENT IS ILLEGAL.',
     1'ILLEGAL ARITHMETIC IF STATEMENT.   IF (ARITH) 1,2,3',
     1'ABOVE NAMELIST STATEMENT MISSING (/).',
     1'ILLEGAL READ, WRITE , OR PUNCH STATEMENT.',
     1'ILLEGAL READ (12) LIST, OR WRITE (12) LIST, STATEMENT.',
     1'DO LOOP TABLE FULL.  RENUMBER PASS DELETED.',
     1'W A R N I N G .  COMMA INSERTED FOLLOWING X IN ABOVE FORMAT.',
     1'TIDY CANNOT PROCESS THIS CLASS OF PROGRAM.  (COPY EXECUTED.)',
     1'WARNING.  ABOVE DO-LOOP TERMINUS PREVIOUSLY REFERENCED.',
     1'WARNING.  TIDY MAY HAVE CHANGED CARD 2 OF THIS ROUTINE',
     1'W A R N I N G .  END CARD INSERTED.',
     1'THE ABOVE STATEMENT IS TRANSMITTED WITHOUT PROCESSING.'/
      DATA (ERMSG(I),I=31,MXMSG)/
     1'ILLEGAL CLOSE, INQUIRE, OR OPEN STATEMENT',
     1'W A R N I N G .   UNBALANCED ELSE/ELSEIF/ENDIF STATEMENT',
     1'W A R N I N G .   UNSATISFIED IF BLOCKS.',
     1'W A R N I N G .   ABOVE STATEMENT NOT ANSI FORTRAN 77.',
     1'TOO MANY REFERENCES IN ABOVE. RENUMBER PASS DELETED.',
     1'W A R N I N G .   NON-ANSI (L OR R) HOLLERITH SPEC.',
     1'ABOVE STATEMENT HAS MORE THAN 19 CONTINUATION LINES.',
     1'CCHR CARD IGNORED:   CANNOT USE ZERO.'/
C
C     LV=0 - TIDY USER WARNING - CAUSES NORMAL TERMINATION
C        1 - MINOR FORTRAN ERROR - STOP 4
C        2 - MAJOR FORTRAN ERROR - STOP 8
      DATA LV /2,2,2,2,1 ,2,2,2,2,2 ,2,1,2,1,2 ,2,1,1,2,2
     X        ,2,2,2,2,0 ,0,0,1,1,1 ,2,1,2,0,2 ,0,2,0/
C
      J=N
      IF (J.LE.0.OR.J.GT.MXMSG) J=1
      NMSG=NMSG+1
      IF (LERR.LT.LV(J)) LERR=LV(J)
      IF (MLIST.EQ.-1) GO TO 10
         CALL PAGE ((JMAX-7)/66+4)
         WRITE (OUTFIL,320) (JINT(I),I=1,JMAX)
         GO TO 20
 10   CALL PAGE (1)
 20   WRITE (OUTFIL,340) NMSG, ERMSG(J)
C
      IF (MLIST.NE.-1) WRITE (OUTFIL,330) NREC,KBUFF
      RETURN
C
C
 320  FORMAT (7X,72A1,19(/12X,1HX,66A1))
 330  FORMAT (1X,I4,2X,80A1,/1H0)
 340  FORMAT (8H ******(,I3,5H) ***,A60,6H******,20X,10H**********)
      END
      SUBROUTINE DLIST (MERR)
C
C     THIS SUBROUTINE UPDATES THE DEFINED STATEMENT NUMBER LIST, LDEF,
C     BY ADDING THE STATEMENT NUMBER IN L15, IF IT IS UNIQUE.
C              RETURNS MERR = 0 IF LABEL IS OK.
C                            -1 IF ERROR
C                       POSSIBLE ERRORS--
C                            ILLEGAL DO-LOOP NEST
C                            DUPLICATE STATEMENT NUMBER
C                            STATEMENT NUMBER TABLE FULL
C
      INCLUDE 'TIDY.INC'
      INCLUDE 'UNITS.INC'
      MERR=0
      IF (KLASS.LT.4) RETURN
C                            CHECK FOR FORMAT STATEMENT, WHICH
C                            IS LABELED BUT CANT HAVE FALL-THRU
      IF (KLASS.NE.5) GO TO 50
C                            PROCESS FORMAT STATEMENT
C                               SCAN FOR DUPLICATE STATEMENT NUMBER
      IF (NDEF.EQ.0) GO TO 20
      DO 10 I=1,NDEF
           IF (IABS(LDEF(I)).EQ.L15) GO TO 140
 10   CONTINUE
C                            PUT L15 INTO LDEF LIST AFTER
C                            LAST NON-NEGATIVE ENTRY
 20   IF (NDEF.GE.1500) GO TO 150
      I=NDEF
      NDEF=NDEF+1
 30   IF (I.EQ.0) GO TO 40
      IF (LDEF(I).GE.0) GO TO 40
      LDEF(I+1)=LDEF(I)
      LOCDEF(I+1)=LOCDEF(I)
      I=I-1
      GO TO 30
 40   LDEF(I+1)=L15
      LOCDEF(I+1)=NREC
      GO TO 170
C                            EXECUTABLE STATEMENT (OR END)
 50   IF (L15.NE.0) GO TO 70
C                            UNLABELLED. IS THERE A FALL-THRU...
      IF (L25.EQ.0) GO TO 60
C                            THERE IS A FALL-THRU LABEL. USE IT.
      L15=L25
      L25=0
      LDEF(NDEF)=IABS(LDEF(NDEF))
      GO TO 170
C
C           UNLABELLED STATEMENT. ERROR IF IT FOLLOWS TRANSFER
 60   IF (NTRAN.NE.0) CALL DIAGNO (5)
      GO TO 170
C                            LABELLED. SCRATCH FALL-THRU LABEL
 70   L25=0
C
C     SCAN FOR DUPLICATE STATEMENT NUMBERS.
C
      IF (NDEF.EQ.0) GO TO 90
      DO 80 I=1,NDEF
           IF (IABS(LDEF(I)).EQ.L15) GO TO 140
 80   CONTINUE
 90   IF (NDEF.GE.1500) GO TO 150
      NDEF=NDEF+1
      LDEF(NDEF)=L15
      LOCDEF(NDEF)=NREC
C
C     SCAN FOR POSSIBLE DO-LOOP TERMINATIONS.
C
      IF (NDOS.LE.0) GO TO 170
      DO 100 I=1,NDOS
           IF (LDOS(I).EQ.L15) GO TO 110
 100  CONTINUE
      GO TO 170
C                            ITS IN THE LIST
 110  IF (I.NE.NDOS) GO TO 120
C                            LAST ONE IN LIST. REMOVE IT
      NDOS=NDOS-1
      IF (MILDO.NE.0) CALL DIAGNO (4)
      GO TO 170
C                            ILLEGAL DO-LOOP NEST
 120  NMSG=NMSG+1
      CALL PAGE (1)
      WRITE (OUTFIL,180) NMSG,I,NDOS
C
C     COMPRESS DO-LOOP TERMINAL LIST AFTER DELETIONS.
C
      NDOS=NDOS-1
      DO 130 J=I,NDOS
 130       LDOS(J)=LDOS(J+1)
      GO TO 160
C
C     ERROR DIAGNOSTICS.
C
C                            DUPLICATE STATEMENT NUMBER
 140  NMSG=NMSG+1
      CALL PAGE (1)
      WRITE (OUTFIL,190) NMSG,L15,LOCDEF(I)
      GO TO 160
C                            NUMBER TABLE FULL
 150  CALL DIAGNO (6)
      NDEF=-1
      MP2=0
C                            ERROR EXIT
 160  MPUN=0
      MERR=-1
C                            EXIT
 170  MILDO=0
      NXEQ=NXEQ+1
      RETURN
C
C
 180  FORMAT (8H ****  (,I3,19H) *** DO LOOP LEVEL,I2,23H TERMINATES WHI
     1LE LEVEL,I2,22H IS IN EFFECT.     ***)
 190  FORMAT (8H ****  (,I3,22H) *** STATEMENT NUMBER,I5,25H DUPLICATES
     1THE NUMBER AT,I4,1H.,8X,3H***)
      END
      INTEGER FUNCTION DOSDEV(FILEID)
      CHARACTER FILEID*(*)
C
C     RETURNS .TRUE. IF ARGUMENT IS A DOS-RESERVED NAME.
C     (SO OPFIL WON'T COMPLAIN ABOUT IT EXISTING)
C
      CHARACTER*2 KUPPER, IT
      CHARACTER*4 DEVID(9)
      DATA DEVID/'PRN','CON','NUL','AUX','LPT1','LPT2','LPT3','COM1','CO
     1M2'/, IT/'  '/
C
C     CONVERT FILEID TO UPPER CASE, FIND END OF STRING.
      LENPAT=LEN(FILEID)
      DO 10 I=1,LENPAT
           IF (FILEID(I:I).EQ.' ') THEN
                LENPAT=I-1
                GO TO 20
           END IF
           IT(1:1)=FILEID(I:I)
           IT=KUPPER(IT)
           FILEID(I:I)=IT(1:1)
 10   CONTINUE
C
C     BE SURE NO LEADING BLANKS.
 20   ISTRT=1
      DO 30 I=1,LENPAT
           IF (FILEID(I:I).NE.' ') GO TO 40
           ISTRT=ISTRT+1
           LENPAT=LENPAT-1
 30   CONTINUE
C
C     COMPARE ARG TO LIST OF RESERVED DEVICES.
 40   LENRES=3
      KEND=ISTRT+LENRES-1
      DO 50 I=1,9
           IF (FILEID(ISTRT:KEND).EQ.DEVID(I)(1:LENRES).AND.LENPAT.EQ.LE
     1NRES) THEN
                DOSDEV=I
                RETURN
           END IF
           IF (I.EQ.4) THEN
                KEND=KEND+1
                LENRES=4
           END IF
 50   CONTINUE
      DOSDEV=0
      RETURN
      END
      SUBROUTINE EDIT
C
C     THIS SUBROUTINE EDITS THE DEFINED AND THE REFERENCED STATEMENT
C     NUMBER LIST.
C
C     ON ENTRY, LDEF(I) CONTAINS THE STATEMENT LABELS, IN THE
C     ORDER IN WHICH THEY WERE USED.  THE LABELS OF CONTINUE
C     STATEMENTS WHICH WERE NOT PASSED ON ARE NEGATIVE.
C     LOCDEF(I) CONTAINS THE CARD NUMBER (NREC) OF THE LINE
C     IDENTIFIED BY THAT LABEL.  EXCEPTION FOR DOUBLE BRANCHES--
C     IF LDEF(I)=0, THEN THE STATEMENT WITH THE LABEL LDEF(I-1)
C     WAS A GOTO.  THE TARGET LABEL IS IN LOCDEF(I).
C
C     (1)     DEFINED STATEMENTS THAT ARE NOT REFERENCED ARE DELETED.
C     (2)     THE NEW STATEMENT NUMBERS ARE GENERATED
C     (3)     A STATEMENT NUMBER WHICH IS NEGATIVE IN THE LDEF
C             LIST IS ASSIGNED A NEW STATEMENT NUMBER THE SAME
C             AS THE NEXT POSITIVE LABEL IN THE LDEF LIST
C     (4)     A LABEL FOLLOWED BY A ZERO IN THE LDEF LIST IS
C             ASSIGNED A NEW STATEMENT NUMBER THE SAME AS THE
C             STATEMENT NUMBER ASSIGNED TO THE LABEL GIVEN IN
C             THE LOCREF ARRAY.  (FOR DOUBLE BRANCHES)
C     (5)     PSEUDO-STATEMENT NUMBERS OUTSIDE THE RANGE OF RENUMBERED
C             DEFINED STATEMENT NUMBERS ARE GENERATED FOR EACH
C             REFERENCED STATEMENT WHICH IS NOT DEFINED.
C
      INCLUDE 'TIDY.INC'
      INCLUDE 'UNITS.INC'
      IF (NREF.LE.0) NDEF=0
      IF (NDEF.LE.0) RETURN
      IF (MDEB.EQ.0) GO TO 10
      WRITE (OUTFIL,260) NDEF,NREF
      WRITE (OUTFIL,270) (LDEF(I),I=1,NDEF)
      WRITE (OUTFIL,300) (NEWNUM(I),I=1,NDEF)
      WRITE (OUTFIL,280) (LOCDEF(I),I=1,NDEF)
      WRITE (OUTFIL,290) (LREF(I),I=1,NREF)
C     SET UP NEWNUM SO THAT IF LDEF(I) NEEDS A NEW NUMBER,
C     NEWNUM(I)=0. IF LDEF(I) WILL REFERENCE LDEF(J), THEN
C     NEWNUM(I)=-LDEF(J).  REMOVE ENTRIES WITH LDEF(I)=0
C
 10   IT=0
      DO 60 I=1,NDEF
           IF (LDEF(I).GT.0) GO TO 40
           IF (LDEF(I).NE.0) GO TO 20
C                            ZERO MEANS LAST WAS A BRANCH
           NEWNUM(IT)=-LOCDEF(I)
           GO TO 60
C                            NEGATIVE MEANS CONTINUE. LOOK AHEAD
 20        J=I
 30        J=J+1
           IF (LDEF(J).LT.0) GO TO 30
C                            CHECK FOR A FORMAT STATEMENT
           IF (LOCDEF(J).LT.0) GO TO 30
           IT=IT+1
           NEWNUM(IT)=-LDEF(J)
           IF (LDEF(J).EQ.0) NEWNUM(IT)=-IABS(LDEF(J-1))
           LDEF(IT)=IABS(LDEF(I))
           GO TO 50
C                            POSITIVE IS NORMAL
 40        IT=IT+1
           NEWNUM(IT)=0
           LDEF(IT)=LDEF(I)
 50        LOCDEF(IT)=IABS(LOCDEF(I))
 60   CONTINUE
      NDEF=IT
      IF (MDEB.EQ.0) GO TO 70
      WRITE (OUTFIL,270) (LDEF(I),I=1,NDEF)
      WRITE (OUTFIL,300) (NEWNUM(I),I=1,NDEF)
      WRITE (OUTFIL,280) (LOCDEF(I),I=1,NDEF)
      WRITE (OUTFIL,290) (LREF(I),I=1,NREF)
C
C     LDEF NOW CONTAINS DEFINED STATEMENT NUMBERS. LOCDEF(I)
C     HAS LINE NUMBER OF LDEF(I).  NEWNUM(I) HAS ZERO IF LDEF(I)
C     WILL NEED A NEW NUMBER, AND -NNN IF REFERENCES TO LDEF(I)
C     SHOULD BE CHANGED TO REFERENCES TO NNN.
C
C     FOR EACH LREF, SCAN LDEF FOR CHAINS.  BE SURE
C     TARGETS OF GOTOS ARE REFERENCED ALSO.
C
 70   IT=NREF
      DO 110 I=1,IT
           I1=LREF(I)
C                            GET REFERENCE IN LDEF
           DO 100 IC=1,50
                DO 80 J=1,NDEF
                     IF (I1.EQ.LDEF(J)) GO TO 90
 80             CONTINUE
C                               NOT DEFINED
                GO TO 110
C                               NEXT LINK IN CHAIN
 90             I1=IABS(NEWNUM(J))
                IF (I1.EQ.0) GO TO 110
                L772=I1
C                            ADD TARGET TO REF LIST
                CALL RLIST
 100       CONTINUE
 110  CONTINUE
      IF (MDEB.EQ.0) GO TO 120
      WRITE (OUTFIL,270) (LDEF(I),I=1,NDEF)
      WRITE (OUTFIL,300) (NEWNUM(I),I=1,NDEF)
      WRITE (OUTFIL,280) (LOCDEF(I),I=1,NDEF)
      WRITE (OUTFIL,290) (LREF(I),I=1,NREF)
C
C     SCAN DEFINED LIST FOR REFERENCES.  DELETE NON-REFERENCED
C     DEFINED STATEMENT NUMBERS.
C
 120  IT=0
      NNUM=0
      DO 160 I=1,NDEF
           DO 130 J=1,NREF
                IF (LDEF(I).EQ.LREF(J)) GO TO 140
 130       CONTINUE
C                            NOT REFERENCED
           GO TO 160
 140       IF (NEWNUM(I).NE.0) GO TO 150
C                            MAKE NEW NUMBER
           NNUM=NNUM+1
           NEWNUM(I)=KD15*NNUM+KB15
 150       IT=IT+1
           LDEF(IT)=LDEF(I)
           NEWNUM(IT)=NEWNUM(I)
           LOCDEF(IT)=LOCDEF(I)
 160  CONTINUE
      NDEF=IT
      IF (MDEB.EQ.0) GO TO 170
      WRITE (OUTFIL,270) (LDEF(I),I=1,NDEF)
      WRITE (OUTFIL,300) (NEWNUM(I),I=1,NDEF)
      WRITE (OUTFIL,280) (LOCDEF(I),I=1,NDEF)
      WRITE (OUTFIL,290) (LREF(I),I=1,NREF)
C
C     SCAN LDEF FOR INDIRECT REFERENCES AND REPLACE THEM
C
 170  IT=0
      DO 220 I=1,NDEF
           DO 200 IC=1,10
                IF (NEWNUM(I).GT.0) GO TO 220
                I1=IABS(NEWNUM(I))
                DO 180 J=1,NDEF
                     IF (LDEF(J).EQ.I1) GO TO 190
 180            CONTINUE
                STOP 45
 190            NEWNUM(I)=NEWNUM(J)
 200       CONTINUE
C                            LOOP OF GOTO-S. BREAK IT
           IF (IT.NE.0) GO TO 210
           IT=1
           CALL PAGE (-20)
           CALL PAGE (1)
           WRITE (OUTFIL,340)
           WRITE (OUTFIL,330)
 210       NNUM=NNUM+1
           NEWNUM(I)=KD15*NNUM+KB15
           NMSG=NMSG+1
           CALL PAGE (1)
           WRITE (OUTFIL,310) NMSG,I1,NEWNUM(I)
 220  CONTINUE
C
C     SCAN REFERENCED STATEMENT LIST FOR MISSING DEFINITIONS.
C
      IT=0
      DO 240 I=1,NREF
           DO 230 J=1,NDEF
                IF (LREF(I).EQ.LDEF(J)) GO TO 240
 230       CONTINUE
C
C     ADD PSEUDO-STATEMENT NUMBER.
C
           LERR=2
           IF (IT.LE.0) THEN
                IT=1
                CALL PAGE (-20)
                CALL PAGE (4)
                WRITE (OUTFIL,320)
                WRITE (OUTFIL,330)
           END IF
           NDEF=NDEF+1
           IF (NDEF.GT.1500) GO TO 250
           LDEF(NDEF)=LREF(I)
           LOCDEF(NDEF)=0
           NEWNUM(NDEF)=NDEF*KD15+KB15
           NMSG=NMSG+1
           CALL PAGE (1)
           WRITE (OUTFIL,310) NMSG,LREF(I),NEWNUM(NDEF)
 240  CONTINUE
      RETURN
C
 250  CALL DIAGNO (6)
      NDEF=-1
      MP2=0
      RETURN
C
C
C
 260  FORMAT ('0FOLLOWING *DEBUG OUTPUT FROM SUBR EDIT'/' NDEF = ',I6,'
     1 NREF = ',I6)
 270  FORMAT (' LDEF  ',9I6)
 280  FORMAT (' LOCDEF',9I6)
 290  FORMAT (' LREF  ',9I6)
 300  FORMAT (' NEWNUM',9I6)
 310  FORMAT (7X,'(',I3,') *** STATEMENT NUMBER',I5,' IS ASSIGNED NUMBER
     1',I5,'.',13X,'***')
 320  FORMAT ('0',12X,'*** THE FOLLOWING REFERENCED STATEMENTS ARE NOT D
     1EFINED')
 330  FORMAT (13X,'*** PSEUDO-STATEMENT NUMBERS HAVE BEEN ASSIGNED.'/' '
     1)
 340  FORMAT ('0',12X,'*** THE FOLLOWING STATEMENTS ARE IN ENDLESS CHAIN
     1S OF GOTO''S.')
      END
      SUBROUTINE HEADER
C
C                  THIS ROUTINE CENTERS JOB HEADINGS
C
      INCLUDE 'TIDY.INC'
      CHARACTER*2 KUPPER
      IF (IPASS.NE.1) GO TO 20
      DO 10 I=1,72
 10   JOB(I)=JINT(I)
      GO TO 60
C
 20   DO 30 I=1,80
 30   JOB(I)=IOUT(I)
C
      IF (MSER.GE.0) GO TO 60
C
C     SET UP COLUMNS 73-75 BASED ON *LABE OPTION
      IF (MLBL.EQ.0) THEN
C     USE *ROUT VALUE
      I=(NROUT-1)/26
      J=NROUT-I*26
      IF (I.EQ.0) GO TO 40
      KOL73(2)=KABC(I)
      KOL73(3)=KABC(J)
      GO TO 50
C
 40   KOL73(3)=KBL
      KOL73(2)=KABC(J)
 50   KOL73(1)=KBL
      ELSE
C
C     COPY PROGRAM/SUBROUTINE/FUNCTION CARD SERIAL INFORMATION
      DO 55 I=1,3
         KOL73(I)=KUPPER(SERIAL(I))
   55 CONTINUE
      ENDIF
C
 60   DO 70 I=73,80
 70   JOB(I)=KBL
C
C          COMPRESS STATEMENT BY ELIMINATING MULTIPLE BLANKS
C
      J = 1
      K = 0
      DO 110 I=1,80
         IF (JOB(I).NE.KBL) GO TO 100
            IF (K.EQ.0) GO TO 110
               K = 0
               GO TO 105
 100     K = 1
 105     JOB(J) = JOB(I)
         J = J+1
 110  CONTINUE
      DO 120 I=J,80
 120  JOB(I)=KBL
C
C                           CENTER HEADING
C
      IB=(80-J)/2
 130  I=J+IB
      JOB(I)=JOB(J)
      J=J-1
      IF (J.GT.0) GO TO 130
C
C                   ELIMINATE REMAINING NON-BLANKS
C
      IB=I-1
      DO 150 I=1,IB
 150  JOB(I)=KBL
      RETURN
      END
      SUBROUTINE HOLSCN (LTYPE,LSSCN)
C     THIS SUBROUTINE SCANS ALL FORTRAN CARDS FOR FIELDS OF HOLLERITH-
C     TYPE CONSTANTS.  IN THESE FIELDS,
C     CHARACTERS ARE REPLACED WITH EQUIVALENT CHARACTERS WHICH WILL NOT
C     BE TREATED BY ANALYSIS ROUTINES.
C     THE SEARCH IS MADE BY CHECKING FOR PATTERNS -SNNNL-, WHERE S IS A
C     SPECIAL CHARACTER, NNN IS A DECIMAL NUMBER, AND L IS THE LETTER H,
C     L, OR R.  IN ADDITION, FOR FORMAT STATEMENTS ONLY, IT ACCEPTS THE
C     PATTERN SNNNXNNNL, THE RESULT OF A MISSING -,- AFTER X.
C
      INCLUDE 'TIDY.INC'
      CHARACTER*2 IT,KPARAM,KUPPER
      LOGICAL LHTRN,ISDEL
C
      JCOL=6
C     IF FORMAT STATEMENT, SKIP FIRST 7 NON-BLANK CHARACTERS
      IF (LTYPE.EQ.26) THEN
           DO 20 N=1,7
 10             JCOL=JCOL+1
                IF (JINT(JCOL).EQ.KBL) GO TO 10
                JINT(JCOL)=KUPPER(JINT(JCOL))
 20        CONTINUE
           GO TO 130
      END IF
C
C                  *****************************************
C                  *                                       *
C                  *    PROCESS NON-FORMAT STATEMENTS.     *
C                  *                                       *
C                  *****************************************
C
      LFIR=6
      IFIR=14
C                            SET FLAG FOR NON-FORMAT
      IGOOF=-1
C                   LOOK FOR SPECIAL CHARACTERS.
 30   I=JCOL
      DO 60 JCOL=I,JMAX
           IT=JINT(JCOL)
           ISDEL=.FALSE.
C          (CHECK FOR SPL CHAR BEFORE DELIMS SINCE NEED J TO SET IFIR.)
           DO 50 J=1,13
                IF (IT.EQ.KSPK(J)) THEN
C                   FOUND ONE.  IS IT THE FIRST...
                     IF (IFIR.EQ.14) THEN
C                   YES
                          IFIR=J
                          LFIR=JCOL
C     QUIT IF THIS STATEMENT TYPE DOESN'T ALLOW STRINGS.  JUST NEEDED
C     IFIR AND LFIR POINTERS.
                          IF (LSSCN.EQ.0.AND.LTYPE.NE.0) THEN
                               DO 40 I=JCOL,JMAX
                                    JINT(I)=KUPPER(JINT(I))
 40                            CONTINUE
                               RETURN
                          END IF
                     END IF
                     ISDEL=IT.EQ.KDEL1.OR.IT.EQ.KDEL2
                     IF (ISDEL) GO TO 180
                     GO TO 70
                END IF
 50        CONTINUE
C     (DELIMS MAY NOT BE SPECIAL CHARACTER, CHECK TO BE SURE)
           ISDEL=IT.EQ.KDEL1.OR.IT.EQ.KDEL2
           IF (ISDEL) GO TO 180
           JINT(JCOL)=KUPPER(IT)
 60   CONTINUE
      GO TO 310
C                   LOOK FOR FOLLOWING NUMBER.
 70   IF (JCOL.EQ.JMAX) GO TO 310
      JCOL=JCOL+1
      CALL RSTAT
C                   REPEAT IF NO NUMBER.
      IF (L772.EQ.0) GO TO 30
C     MAKE IT UPPER CASE
      JINT(JCOL)=KUPPER(JINT(JCOL))
      IT=JINT(JCOL)
C                  IS IT -H-,-L-, OR -R-
      IF (IT.EQ.KABC(8)) THEN
           LHTRN=MOD(KHTRAN,2).EQ.0
      ELSE IF (IT.EQ.KABC(12).OR.IT.EQ.KABC(18)) THEN
           LHTRN=KHTRAN.LT.2
C     COMPLAIN ABOUT L OR R IF ANSI FLAG SET.
           IF (MANSI.EQ.0.AND.IGOOF.EQ.0) CALL DIAGNO (36)
      ELSE
           GO TO 30
      END IF
C                  MARK AS PART OF STRING (FOR INDENTING)
      IF (LHTRN) JINT(JCOL)(2:2)=KAT(2:2)
C
C     ALSO MARK THE NUMBERS.
      KTMP=L772
      I=JCOL
 80   I=I-1
      IF (JINT(I).EQ.KBL) GO TO 80
      IF (LHTRN) JINT(I)(2:2)=KAT(2:2)
      KTMP=KTMP/10
      IF (KTMP.GT.0) GO TO 80
      IP=I
C                  FIND LIMITS OF HOLLERITH FIELD.
      I=JCOL+1
      JCOL=JCOL+L772
C                   L772 IS THE LENGTH OF THE FIELD, AS FOUND BY RSTAT
C                  CHECK FOR CASE OF HOLLERITH BLANKS SPILLING OFF
C                  END OF CARD. E.G. I=6HXXXXX
      IF (JCOL.LE.JMAX) GO TO 90
C                  REPLACE CURRENT END CARD MARK.
      JINT(JMAX+1)=KBL
C                   AND SET NEW ONE
      JMAX=JCOL
      JINT(JMAX+1)=KERM
C                  CHANGE ALL CHARACTERS IN HOLLERITH FIELD.
 90   DO 100 J=I,JCOL
           JINT(J)(2:2)=KAT(2:2)
 100  CONTINUE
      IF (.NOT.LHTRN) THEN
C
C     IF TRANSLATING H-FIELDS, COPY STRING AND DUPLICATE APOSTROPHES.
           JINT(IP)=KAPSTR
           IP=IP+1
           J=I
 110       JINT(IP)=JINT(J)
           IF (JINT(J).EQ.KAPSTR) THEN
                IP=IP+1
                IF (IP.GE.J) CALL MOVSTR (J)
                JINT(IP)=KAPSTR
           END IF
           J=J+1
           IP=IP+1
           IF (J.LE.JCOL) GO TO 110
           JINT(IP)=KAPSTR
 120       IP=IP+1
           IF (IP.LE.JCOL) THEN
                JINT(IP)=KBL
                GO TO 120
           END IF
      END IF
      GO TO 30
C
C                  **********************************
C                  *                                *
C                  *   PROCESS FORMAT STATEMENTS.   *
C                  *                                *
C                  **********************************
C
 130  IGOOF=0
      IFIR=3
      LFIR=JCOL
      GO TO 170
C
C                  LOOK FOR SPECIAL CHARACTER
 140  IF (JCOL.GT.JMAX) GO TO 310
      I=JCOL
      DO 160 JCOL=I,JMAX
           IT=JINT(JCOL)
           ISDEL=IT.EQ.KDEL1.OR.IT.EQ.KDEL2
           IF (ISDEL) GO TO 180
           DO 150 J=1,12
                IF (IT.EQ.KSPK(J)) GO TO 220
 150       CONTINUE
           JINT(JCOL)=KUPPER(IT)
 160  CONTINUE
      GO TO 310
C
C                  SKIP IF NOT * OR '
 170  IF (JINT(JCOL).NE.KDEL1.AND.JINT(JCOL).NE.KDEL2) GO TO 220
C                  CHANGE ALL CHARACTERS BETWEEN *S OR 'S
 180  KPARAM=JINT(JCOL)
C                  MARK AS PART OF STRING (FOR INDENTING)
      JINT(JCOL)(2:2)=KAT(2:2)
      IP=JCOL
C
 190  IF (JCOL.EQ.JMAX) GO TO 310
      JCOL=JCOL+1
      IT=JINT(JCOL)
      JINT(JCOL)(2:2)=KAT(2:2)
      IF (IT.EQ.KPARAM) THEN
           IF (JINT(JCOL+1).NE.KPARAM) GO TO 200
C     THIS IS A LITERAL -- NOT TERMINAL DELIMITER
           JCOL=JCOL+1
           JINT(JCOL)(2:2)=KAT(2:2)
      END IF
      GO TO 190
C                            ALL CHANGED, CHANGE DELIMS IF DESIRED.
 200  IF (KDTRAN.EQ.1.AND.KPARAM.NE.KDEL1) THEN
           JINT(IP)=KAPSTR
           JINT(JCOL)=KAPSTR
           J=IP
 210       J=J+1
           IF (J.LT.JCOL) THEN
                IF (JINT(J).EQ.KAPSTR) THEN
C     DUPLICATE LITERAL VERSION OF DELIMITER
                     CALL MOVSTR (J)
                     JINT(J)=KAPSTR
                END IF
                GO TO 210
           END IF
      END IF
      IF (IGOOF.EQ.-1) GO TO 70
C                  LOOK FOR FOLLOWING NUMBER
 220  IF (JCOL.EQ.JMAX) GO TO 310
      JCOL=JCOL+1
      CALL RSTAT
C                  IF NOT A NUMBER, START AGAIN
      IF (L772.EQ.0) GO TO 140
C                  NUMBER FOUND. LOOK AT NEXT CHARACTER.
      JINT(JCOL)=KUPPER(JINT(JCOL))
      IT=JINT(JCOL)
C                  IS IT -H-
      IF (IT.EQ.KABC(8)) THEN
           LHTRN=MOD(KHTRAN,2).EQ.0
           GO TO 250
C                  MAYBE L OR R
      ELSE IF (IT.EQ.KABC(12).OR.IT.EQ.KABC(18)) THEN
           LHTRN=KHTRAN.LT.2
           IF (MANSI.EQ.0) CALL DIAGNO (36)
           GO TO 250
      END IF
C                  IF NOT -X-, START AGAIN.
      IF (IT.NE.KABC(24)) GO TO 140
C                  X FOUND.  LOOK AT NEXT.
 230  IF (JCOL.EQ.JMAX) GO TO 310
      JCOL=JCOL+1
      IF (JINT(JCOL).EQ.KBL) GO TO 230
      JINT(JCOL)=KUPPER(JINT(JCOL))
      IT=JINT(JCOL)
C                  IS IT -*-
      IF (IT.EQ.KDEL1.OR.IT.EQ.KDEL2) GO TO 170
C                  IS IT -)- OR -,-
      IF (IT.EQ.KSPK(2)) GO TO 220
      IF (IT.EQ.KSPK(5)) GO TO 220
C
C     INSERT A COMMA
      DO 240 J=JMAX,JCOL,-1
           JINT(J+1)=JINT(J)
 240  CONTINUE
      JINT(JCOL)=KSPK(2)
      JMAX=JMAX+1
      JINT(JMAX+1)=KERM
      CALL DIAGNO (25)
      IGOOF=1
      GO TO 220
C
C                  HOLLERITH FOUND.   FIND LIMITS OF FIELD.
 250  IF (LHTRN) JINT(JCOL)(2:2)=KAT(2:2)
C
C     ALSO MARK THE NUMBERS.
      J=L772
      I=JCOL
 260  I=I-1
      IF (JINT(I).EQ.KBL) GO TO 260
      IF (LHTRN) JINT(I)(2:2)=KAT(2:2)
      J=J/10
      IF (J.GT.0) GO TO 260
C
      IP=I
      I=JCOL+1
      JCOL=JCOL+L772
      IF (JCOL.LE.JMAX) GO TO 270
      JINT(JMAX+1)=KBL
      JMAX=JCOL
      JINT(JMAX+1)=KERM
 270  DO 280 J=I,JCOL
           JINT(J)(2:2)=KAT(2:2)
 280  CONTINUE
      IF (.NOT.LHTRN) THEN
C
C     IF TRANSLATING H-FIELDS, COPY STRING AND DUPLICATE APOSTROPHES.
           JINT(IP)=KAPSTR
           IP=IP+1
           J=I
 290       JINT(IP)=JINT(J)
           IF (JINT(J).EQ.KAPSTR) THEN
                IP=IP+1
                IF (IP.GE.J) CALL MOVSTR (J)
                JINT(IP)=KAPSTR
           END IF
           J=J+1
           IP=IP+1
           IF (J.LE.JCOL) GO TO 290
           JINT(IP)=KAPSTR
 300       IP=IP+1
           IF (IP.LE.JCOL) THEN
                JINT(IP)=KBL
                GO TO 300
           END IF
      END IF
      GO TO 220
C
 310  RETURN
      END
      SUBROUTINE INITDY
C
C     INITIALIZE TIDY -- USED AT START AND WHEN *NEWR EXECUTED.
C
      INCLUDE 'TIDY.INC'
C
      INDENT=0
      JUST=7
      KALMRK = '* '
      KALTRN= '  '
      KB15=0
      KCTCHR=KSPK(10)
      KCTCTL=0
      KD15=10
      KD79=1
      KDEL1 = ''' '
      KDEL2 = '""'
      KDTRAN=0
      KHTRAN=1
      KPRIN=1
      KPUN=-1
      MANSI=0
      MCOL=0
      MCOM=-1
      MCONT=0
      MEX=0
      MLBL=0
      MLIST=-1
      MPRIN=1
      MPUN=-1
      MREF=0
      MRIT=2
      MSER=0
      NFEND=0
      NROUT=1
C
      RETURN
      END
      SUBROUTINE IOSYS1 (OP,KV,SER,LIST)
C
C     OP CODES PERMITTED.
C     1         2         3         4
C     ERASE     REWIND    WRITE     READ
C
      INCLUDE 'TIDY.INC'
      INCLUDE 'UNITS.INC'
      INTEGER OP, KV(8)
      CHARACTER*2 SER(8), LIST(1)
C
      GO TO (10,20,50,80),OP
C
C     ERASE
C
      ENTRY IOSY11
 10   REWIND SCFIL1
      RETURN
C
C     REWIND
C
      ENTRY IOSY12
 20   REWIND SCFIL1
      RETURN
C
C     WRITE
C
 50   WRITE (SCFIL1) KV, SER
      CALL REDSTR (SCFIL1, LIST, KV(4),IOUTN,KV(6),1)
      GO TO 120
C
C     READ
C
 80   READ (SCFIL1) KV, SER
      CALL REDSTR (SCFIL1, LIST, KV(4),IOUTN,KV(6),2)
C                            NORMAL EXIT
 120  RETURN
      END
      SUBROUTINE IOSYS2 (OP,KV,SER,LIST)
C
C     OP CODES PERMITTED.
C     1         2         3         4
C     ERASE     REWIND    WRITE     READ
C
      INCLUDE 'TIDY.INC'
      INCLUDE 'UNITS.INC'
      INTEGER OP, KV(8)
      CHARACTER*2 SER(8), LIST(1)
C
      GO TO (10,20,50,80),OP
C
C     ERASE
C
      ENTRY IOSY21
 10   REWIND SCFIL2
      RETURN
C
C     REWIND
C
      ENTRY IOSY22
 20   REWIND SCFIL2
      RETURN
C
C     WRITE
C
 50   WRITE (SCFIL2) KV, SER
      CALL REDSTR (SCFIL2, LIST, KV(4),IOUTN,KV(6),1)
      GO TO 120
C
C     READ
C
 80   READ (SCFIL2) KV, SER
      CALL REDSTR (SCFIL2, LIST, KV(4),IOUTN,KV(6),2)
C                            NORMAL EXIT
 120  RETURN
      END
      CHARACTER*2 FUNCTION KHIDE (C)
      CHARACTER*2 C
      CHARACTER*2 KBL
      DATA KBL/' @'/
C
C     CONVERT CHARACTERS IN HOLSCN STRINGS TO SPECIAL FORM
C
      KHIDE=KBL
      KHIDE(1:1)=C(1:1)
      RETURN
      END
      SUBROUTINE KIMPAK
C
C     THIS ROUTINE PACKS SUPER-CARD IMAGES FROM IOUT(I) INTO KIM(I,J).
C
      INCLUDE 'TIDY.INC'
      LOGICAL CONIND
C
      CONIND=.TRUE.
C
 10   J=0
C
 20   J=J+1
      IF (KLASS.LT.2) THEN
           K7=0
           JL=1
           JR=72
           GO TO 90
      END IF
C
C     INDENTING COULD MAKE CARD OVERFLOW CONTINUATIONS, IF SO, REPACK.
      IF (J.GT.20) THEN
           IF (.NOT.CONIND) THEN
                CALL DIAGNO (37)
                J=20
                GO TO 120
           END IF
           CONIND=.FALSE.
           JL=7
           JR=72
           GO TO 10
      END IF
C
C     PREPARE COLUMNS 1-6 OF FIRST CARD.
      IF (CONIND) THEN
           IF (J.EQ.1) THEN
                K7=ICOLSV
                DO 30 I=1,6
                     KIM(I,1)=IOUT(I)
 30             CONTINUE
           ELSE
C     BLANK COLUMN 1-5
                DO 40 I=1,5
                     KIM(I,J)=KBL
 40             CONTINUE
C     COLUMN 6 - NUMBER SERIALLY UNLESS CCHR SET OTHERWISE.
                IF (KCTCTL.EQ.0) THEN
                     IF (J.LT.11) THEN
                          KIM(6,J)=KDIG(J)
                     ELSE
                          KIM(6,J)=KSPK(10)
                     END IF
                ELSE
                     KIM(6,J)=KCTCHR
                END IF
           END IF
C
C     SET LEFT EDGE OF TEXT
C      (USE COL 7 IF EXEMPT, NON-INDENTED, OR IF PART OF STRING
           IF (MEX.LT.0.OR.ICOLSV.EQ.6.OR.(IOUT(K7)(2:2).EQ.KAT(2:2)
     1     .AND. IOUT(K7+1)(2:2).EQ.KAT(2:2))) THEN
                JL=7
           ELSE
                JL=ICOLSV
                IF (J.GT.1) JL=JL+1
                DO 50 I=7,JL
                     KIM(I,J)=KBL
 50             CONTINUE
                JL=JL+1
           END IF
C
C     SET RIGHT EDGE OF TEXT
C     FIRST GET RIGHT-MOST POTENTIAL CHAR IN STRING (KRR)
           JR=72
           KRR=K7+JR-JL+1
           IF (KRR.GT.IMAX) THEN
C     IF PAST END OF STATEMENT, STOP AT END.
                JR=JL+IMAX-K7-1
                GO TO 90
           END IF
C
C     NOW CHECK IF WE CAN BREAK IT HERE.
C     BREAK IF PART OF A STRING. KIMPAK PROTECTS DELIMETERS ALSO.
 60        IF (IOUT(KRR)(2:2).EQ.KAT(2:2)) GO TO 90
C
C     BREAK IF IT IS A BLANK (NOT IN STRING)
           IF (IOUT(KRR).EQ.KBL) GO TO 90
C
C     GO BACK IF LEFT PARENTHESIS
 70        IF (IOUT(KRR).EQ.KSPK(3)) THEN
                KRR=KRR-1
                JR=JR-1
                GO TO 70
           END IF
C
C     BREAK FOR SPECIAL CHARACTERS.
           DO 80 I=1,14
                IF (IOUT(KRR).EQ.KSPK(I)) GO TO 90
 80        CONTINUE
C
C     OTHERWISE BACK UP ONE, TRY AGAIN.
           KRR=KRR-1
           JR=JR-1
           IF (JR.GT.JL) GO TO 60
C
C     IF GO ALL THE WAY BACK, FORCE IT TO 72
           JR=72
      END IF
C
C     COPY THE TEXT
 90   DO 100 I=JL,JR
           K7=K7+1
           IF (K7.LE.IMAX) THEN
                KIM(I,J)=IOUT(K7)
           ELSE
                KIM(I,J)=KBL
           END IF
 100  CONTINUE
C
C     SCRUB GARBAGE OFF END IF SHORTER THAN 72
      IF (JR.LT.72) THEN
           DO 110 I=JR+1,72
                KIM(I,J)=KBL
 110       CONTINUE
      END IF
C
C     DO ANOTHER CONTINUATION IF NECESSARY.
      IF (K7.LT.IMAX) GO TO 20
C
 120  NCD=J
      RETURN
      END
      SUBROUTINE KWSCAN (JT,KSTCR)
      PARAMETER (NKST=80)
C
C     THIS ROUTINE SCANS FOR FORTRAN KEYWORDS, SETS JT TO CORRECT
C     TYPE IF FOUND, ELSE ZERO.
C
C     INPUT: IF JT = 0, SCANS WHOLE LIST
C               JT > 0, ONLY SCANS THAT WORD.
C
      INCLUDE 'TIDY.INC'
      INCLUDE 'UNITS.INC'
C
      DIMENSION KSTCR(5)
      COMMON /KSTCOM/ KST(10,NKST)
      CHARACTER*2 KST,WKSTR(10),KUPPER
      COMMON /KSTNUM/ KSTC(6,NKST)
C
      IF (JT.EQ.0) THEN
           NL=1
           NU=NKST
      ELSE
           NL=JT
           NU=JT
      END IF
C
C     MAKE UPPER-CASE COPY OF 10 CHARS (MAX STRING LENGTH)
      LAST=JCOL-1
      DO 20 I=1,10
 10        LAST=LAST+1
           IF (LAST.GT.JMAX) THEN
                WKSTR(I)=KBL
           ELSE
                IF (JINT(LAST).EQ.KBL) GO TO 10
                WKSTR(I)=KUPPER(JINT(LAST))
           END IF
 20   CONTINUE
C
      DO 50 IT=NL,NU
           NINS=KSTC(1,IT)
C
           DO 30 I=1,NINS
                IF (WKSTR(I).NE.KST(I,IT)) GO TO 50
 30        CONTINUE
           JT=KSTC(6,IT)
           DO 40 I=1,5
                KSTCR(I)=KSTC(I,IT)
 40        CONTINUE
           IF (MDEB.GT.0) WRITE (OUTFIL,60) KSTCR,WKSTR
           RETURN
C                  LOOP FOR NEXT STATEMENT.
 50   CONTINUE
      JT=0
      RETURN
C
 60   FORMAT (' KWSCAN: ',5I3,1X,10A1)
      END
      BLOCK DATA KSTDAT
C
      COMMON /KSTCOM/
     1      KST1  ,KST2  ,KST3  ,KST4  ,KST5
     2     ,KST6  ,KST7  ,KST8  ,KST9 ,KST10
     3    ,KST11 ,KST12 ,KST13 ,KST14 ,KST15
     4    ,KST16 ,KST17 ,KST18 ,KST19 ,KST20
     5    ,KST21 ,KST22 ,KST23 ,KST24 ,KST25
     6    ,KST26 ,KST27 ,KST28 ,KST29 ,KST30
     7    ,KST31 ,KST32 ,KST33 ,KST34 ,KST35
     8    ,KST36 ,KST37 ,KST38 ,KST39 ,KST40
     9    ,KST41 ,KST42 ,KST43 ,KST44 ,KST45
     X    ,KST46 ,KST47 ,KST48 ,KST49 ,KST50
     X    ,KST51 ,KST52 ,KST53 ,KST54 ,KST55
     X    ,KST56 ,KST57 ,KST58 ,KST59 ,KST60
     X    ,KST61 ,KST62 ,KST63 ,KST64 ,KST65
     X    ,KST66 ,KST67 ,KST68 ,KST69 ,KST70
     X    ,KST71 ,KST72 ,KST73 ,KST74 ,KST75
     X    ,KST76 ,KST77 ,KST78 ,KST79 ,KST80
C
C
      CHARACTER*2 KST1 (10),KST2 (10),KST3 (10),KST4 (10),KST5 (10)
      CHARACTER*2 KST6 (10),KST7 (10),KST8 (10),KST9 (10),KST10(10)
      CHARACTER*2 KST11(10),KST12(10),KST13(10),KST14(10),KST15(10)
      CHARACTER*2 KST16(10),KST17(10),KST18(10),KST19(10),KST20(10)
      CHARACTER*2 KST21(10),KST22(10),KST23(10),KST24(10),KST25(10)
      CHARACTER*2 KST26(10),KST27(10),KST28(10),KST29(10),KST30(10)
      CHARACTER*2 KST31(10),KST32(10),KST33(10),KST34(10),KST35(10)
      CHARACTER*2 KST36(10),KST37(10),KST38(10),KST39(10),KST40(10)
      CHARACTER*2 KST41(10),KST42(10),KST43(10),KST44(10),KST45(10)
      CHARACTER*2 KST46(10),KST47(10),KST48(10),KST49(10),KST50(10)
      CHARACTER*2 KST51(10),KST52(10),KST53(10),KST54(10),KST55(10)
      CHARACTER*2 KST56(10),KST57(10),KST58(10),KST59(10),KST60(10)
      CHARACTER*2 KST61(10),KST62(10),KST63(10),KST64(10),KST65(10)
      CHARACTER*2 KST66(10),KST67(10),KST68(10),KST69(10),KST70(10)
      CHARACTER*2 KST71(10),KST72(10),KST73(10),KST74(10),KST75(10)
      CHARACTER*2 KST76(10),KST77(10),KST78(10),KST79(10),KST80(10)
C
      COMMON /KSTNUM/
     1     KSTC1  ,KSTC2  ,KSTC3  ,KSTC4  ,KSTC5
     2    ,KSTC6  ,KSTC7  ,KSTC8  ,KSTC9  ,KSTC10
     3    ,KSTC11 ,KSTC12 ,KSTC13 ,KSTC14 ,KSTC15
     4    ,KSTC16 ,KSTC17 ,KSTC18 ,KSTC19 ,KSTC20
     5    ,KSTC21 ,KSTC22 ,KSTC23 ,KSTC24 ,KSTC25
     6    ,KSTC26 ,KSTC27 ,KSTC28 ,KSTC29 ,KSTC30
     7    ,KSTC31 ,KSTC32 ,KSTC33 ,KSTC34 ,KSTC35
     8    ,KSTC36 ,KSTC37 ,KSTC38 ,KSTC39 ,KSTC40
     9    ,KSTC41 ,KSTC42 ,KSTC43 ,KSTC44 ,KSTC45
     X    ,KSTC46 ,KSTC47 ,KSTC48 ,KSTC49 ,KSTC50
     X    ,KSTC51 ,KSTC52 ,KSTC53 ,KSTC54 ,KSTC55
     X    ,KSTC56 ,KSTC57 ,KSTC58 ,KSTC59 ,KSTC60
     X    ,KSTC61 ,KSTC62 ,KSTC63 ,KSTC64 ,KSTC65
     X    ,KSTC66 ,KSTC67 ,KSTC68 ,KSTC69 ,KSTC70
     X    ,KSTC71 ,KSTC72 ,KSTC73 ,KSTC74 ,KSTC75
     X    ,KSTC76 ,KSTC77 ,KSTC78 ,KSTC79 ,KSTC80
      DIMENSION KSTC1 (6),KSTC2 (6),KSTC3 (6),KSTC4 (6),KSTC5 (6)
      DIMENSION KSTC6 (6),KSTC7 (6),KSTC8 (6),KSTC9 (6),KSTC10(6)
      DIMENSION KSTC11(6),KSTC12(6),KSTC13(6),KSTC14(6),KSTC15(6)
      DIMENSION KSTC16(6),KSTC17(6),KSTC18(6),KSTC19(6),KSTC20(6)
      DIMENSION KSTC21(6),KSTC22(6),KSTC23(6),KSTC24(6),KSTC25(6)
      DIMENSION KSTC26(6),KSTC27(6),KSTC28(6),KSTC29(6),KSTC30(6)
      DIMENSION KSTC31(6),KSTC32(6),KSTC33(6),KSTC34(6),KSTC35(6)
      DIMENSION KSTC36(6),KSTC37(6),KSTC38(6),KSTC39(6),KSTC40(6)
      DIMENSION KSTC41(6),KSTC42(6),KSTC43(6),KSTC44(6),KSTC45(6)
      DIMENSION KSTC46(6),KSTC47(6),KSTC48(6),KSTC49(6),KSTC50(6)
      DIMENSION KSTC51(6),KSTC52(6),KSTC53(6),KSTC54(6),KSTC55(6)
      DIMENSION KSTC56(6),KSTC57(6),KSTC58(6),KSTC59(6),KSTC60(6)
      DIMENSION KSTC61(6),KSTC62(6),KSTC63(6),KSTC64(6),KSTC65(6)
      DIMENSION KSTC66(6),KSTC67(6),KSTC68(6),KSTC69(6),KSTC70(6)
      DIMENSION KSTC71(6),KSTC72(6),KSTC73(6),KSTC74(6),KSTC75(6)
      DIMENSION KSTC76(6),KSTC77(6),KSTC78(6),KSTC79(6),KSTC80(6)
C
C     /KST/
      DATA KST 1/'A','C','C','E','P','T',' ',' ',' ',' '/
      DATA KST 2/'A','S','C','E','N','T',' ',' ',' ',' '/
      DATA KST 3/'A','S','S','I','G','N',' ',' ',' ',' '/
      DATA KST 4/'B','A','C','K','S','P','A','C','E','('/
      DATA KST 5/'B','L','O','C','K','D','A','T','A',' '/
      DATA KST 6/'B','U','F','F','E','R','I','N','(',' '/
      DATA KST 7/'B','U','F','F','E','R','O','U','T','('/
      DATA KST 8/'C','A','L','L',' ',' ',' ',' ',' ',' '/
      DATA KST 9/'C','H','A','R','A','C','T','E','R',' '/
      DATA KST10/'C','O','M','M','O','N',' ',' ',' ',' '/
      DATA KST11/'C','O','M','P','L','E','X',' ',' ',' '/
      DATA KST12/'C','O','N','T','I','N','U','E',' ',' '/
      DATA KST13/'D','A','T','A',' ',' ',' ',' ',' ',' '/
      DATA KST14/'D','E','C','O','D','E','(',' ',' ',' '/
      DATA KST15/'D','I','M','E','N','S','I','O','N',' '/
      DATA KST16/'D','O','U','B','L','E','P','R','E','C'/
      DATA KST17/'D','O','U','B','L','E',' ',' ',' ',' '/
      DATA KST18/'E','N','C','O','D','E','(',' ',' ',' '/
      DATA KST19/'E','N','D','F','I','L','E','(',' ',' '/
      DATA KST20/'E','N','D','I','F',' ',' ',' ',' ',' '/
      DATA KST21/'E','N','D','F','I','L','E',' ',' ',' '/
      DATA KST22/'E','N','T','R','Y',' ',' ',' ',' ',' '/
      DATA KST23/'E','Q','U','I','V','A','L','E','N','C'/
      DATA KST24/'E','X','T','E','R','N','A','L',' ',' '/
      DATA KST25/'F','I','N','I','S',' ',' ',' ',' ',' '/
      DATA KST26/'F','O','R','M','A','T','(',' ',' ',' '/
      DATA KST27/'F','O','R','T','R','A','N',' ',' ',' '/
      DATA KST28/'I','F','(','U','N','I','T',',',' ',' '/
      DATA KST29/'F','U','N','C','T','I','O','N',' ',' '/
      DATA KST30/'G','O','T','O','(',' ',' ',' ',' ',' '/
      DATA KST31/'G','O','T','O',' ',' ',' ',' ',' ',' '/
      DATA KST32/'I','F','A','C','C','U','M','U','L','A'/
      DATA KST33/'I','F','Q','U','O','T','I','E','N','T'/
      DATA KST34/'I','F','(','D','I','V','I','D','E','C'/
      DATA KST35/'I','F','(','E','N','D','F','I','L','E'/
      DATA KST36/'I','F','(','S','E','N','S','E','L','I'/
      DATA KST37/'I','F','(','S','E','N','S','E','S','W'/
      DATA KST38/'I','F','(',' ',' ',' ',' ',' ',' ',' '/
      DATA KST39/'I','N','T','E','G','E','R',' ',' ',' '/
      DATA KST40/'L','O','G','I','C','A','L',' ',' ',' '/
      DATA KST41/'M','A','C','H','I','N','E',' ',' ',' '/
      DATA KST42/'N','A','M','E','L','I','S','T',' ',' '/
      DATA KST43/'P','A','U','S','E',' ',' ',' ',' ',' '/
      DATA KST44/'P','R','I','N','T',' ',' ',' ',' ',' '/
      DATA KST45/'P','R','O','G','R','A','M',' ',' ',' '/
      DATA KST46/'P','U','N','C','H',' ',' ',' ',' ',' '/
      DATA KST47/'R','E','A','D','I','N','P','U','T','T'/
      DATA KST48/'R','E','A','D','T','A','P','E',' ',' '/
      DATA KST49/'R','E','A','D','(',' ',' ',' ',' ',' '/
      DATA KST50/'R','E','A','D',' ',' ',' ',' ',' ',' '/
      DATA KST51/'R','E','A','L',' ',' ',' ',' ',' ',' '/
      DATA KST52/'R','E','T','U','R','N',' ',' ',' ',' '/
      DATA KST53/'R','E','W','I','N','D','(',' ',' ',' '/
      DATA KST54/'S','E','G','M','E','N','T',' ',' ',' '/
      DATA KST55/'S','E','N','S','E','L','I','G','H','T'/
      DATA KST56/'S','T','O','P',' ',' ',' ',' ',' ',' '/
      DATA KST57/'S','U','B','R','O','U','T','I','N','E'/
      DATA KST58/'T','Y','P','E',' ',' ',' ',' ',' ',' '/
      DATA KST59/'W','R','I','T','E','O','U','T','P','U'/
      DATA KST60/'W','R','I','T','E','T','A','P','E',' '/
      DATA KST61/'W','R','I','T','E','(',' ',' ',' ',' '/
      DATA KST62/'O','V','E','R','L','A','Y',' ',' ',' '/
      DATA KST63/'I','D','E','N','T',' ',' ',' ',' ',' '/
      DATA KST64/'F','R','E','Q','U','E','N','C','Y',' '/
      DATA KST65/'I','M','P','L','I','C','I','T',' ',' '/
      DATA KST66/'L','E','V','E','L',' ',' ',' ',' ',' '/
      DATA KST67/'E','L','S','E','I','F',' ',' ',' ',' '/
      DATA KST68/'E','L','S','E',' ',' ',' ',' ',' ',' '/
      DATA KST69/'T','H','E','N',' ',' ',' ',' ',' ',' '/
      DATA KST70/'C','L','O','S','E','(',' ',' ',' ',' '/
      DATA KST71/'I','N','C','L','U','D','E',' ',' ',' '/
      DATA KST72/'I','N','Q','U','I','R','E','(',' ',' '/
      DATA KST73/'I','N','T','R','I','N','S','I','C',' '/
      DATA KST74/'O','P','E','N','(',' ',' ',' ',' ',' '/
      DATA KST75/'P','A','R','A','M','E','T','E','R',' '/
      DATA KST76/'S','A','V','E',' ',' ',' ',' ',' ',' '/
      DATA KST77/'B','A','C','K','S','P','A','C','E',' '/
      DATA KST78/'E','N','D',' ',' ',' ',' ',' ',' ',' '/
      DATA KST79/'R','E','W','I','N','D',' ',' ',' ',' '/
      DATA KST80/'C','L','O','S','E',' ',' ',' ',' ',' '/
C
C     /KSTNUM/
C     ********* NOTE - KPOS IS ADDED TO INSULATE PASS1 FROM ADDITIONS
C     TO ABOVE TABLE.  WHEN ADDING NEW STATEMENTS, SET KPOS TO THE
C     NEW VALUE OF NKST RATHER THAN THE ORDINAL POSITION OF THE NEW
C     ADDITION TO THE TABLE.
C                   NINS  KLASS  JTYPE NANSI   KSTROK     KPOS
      DATA KSTC 1 /    6,     7,    33,    1,       0,        1/
      DATA KSTC 2 /    6,     2,    1 ,    1,       0,        2/
      DATA KSTC 3 /    6,     7,    2 ,    0,       0,        3/
      DATA KSTC 4 /   10,     7,    47,    0,       0,        4/
      DATA KSTC 5 /    9,     2,    4 ,    0,       0,        5/
      DATA KSTC 6 /    9,     6,    5 ,    1,       0,        6/
      DATA KSTC 7 /   10,     6,    5 ,    1,       0,        7/
      DATA KSTC 8 /    4,     7,    6 ,    0,       1,        8/
      DATA KSTC 9 /    9,     3,    46,    0,       0,        9/
      DATA KSTC10 /    6,     3,    7 ,    0,       0,       10/
      DATA KSTC11 /    7,     3,    46,    0,       0,       11/
      DATA KSTC12 /    8,     4,    8 ,    0,       0,       12/
      DATA KSTC13 /    4,     3,    9 ,    0,       1,       13/
      DATA KSTC14 /    7,     7,    10,    1,       0,       14/
      DATA KSTC15 /    9,     3,    11,    0,       0,       15/
      DATA KSTC16 /   10,     3,    12,    0,       0,       16/
      DATA KSTC17 /    6,     3,    13,    0,       0,       17/
      DATA KSTC18 /    7,     7,    10,    1,       0,       18/
      DATA KSTC19 /    8,     7,    47,    0,       0,       19/
      DATA KSTC20 /    5,    11,    48,    0,       0,       20/
      DATA KSTC21 /    7,     6,    15,    0,       0,       21/
      DATA KSTC22 /    5,    11,    3 ,    0,       0,       22/
      DATA KSTC23 /   10,     3,    17,    0,       0,       23/
      DATA KSTC24 /    8,     3,    3 ,    0,       0,       24/
      DATA KSTC25 /    5,     3,    18,    1,       0,       25/
      DATA KSTC26 /    7,     5,    19,    0,       1,       26/
      DATA KSTC27 /    7,     2,    20,    1,       0,       27/
      DATA KSTC28 /    8,     7,    42,    1,       1,       28/
      DATA KSTC29 /    8,     2,    35,    0,       0,       29/
      DATA KSTC30 /    5,     7,    23,    0,       0,       30/
      DATA KSTC31 /    4,     7,    24,    0,       0,       31/
      DATA KSTC32 /   10,     7,    25,    1,       1,       32/
      DATA KSTC33 /   10,     7,    26,    1,       1,       33/
      DATA KSTC34 /   10,     7,    27,    1,       1,       34/
      DATA KSTC35 /   10,     7,    28,    1,       1,       35/
      DATA KSTC36 /   10,     7,    29,    1,       1,       36/
      DATA KSTC37 /   10,     7,    30,    1,       1,       37/
      DATA KSTC38 /    3,     7,    31,    0,       1,       38/
      DATA KSTC39 /    7,     3,    46,    0,       0,       39/
      DATA KSTC40 /    7,     3,    46,    0,       0,       40/
      DATA KSTC41 /    7,     2,    1 ,    1,       0,       41/
      DATA KSTC42 /    8,     3,    32,    1,       0,       42/
      DATA KSTC43 /    5,     6,    3 ,    0,       1,       43/
      DATA KSTC44 /    5,     7,    33,    0,       1,       44/
      DATA KSTC45 /    7,     2,    35,    0,       0,       45/
      DATA KSTC46 /    5,     7,    33,    1,       1,       46/
      DATA KSTC47 /   10,     7,    36,    0,       0,       47/
      DATA KSTC48 /    8,     6,    37,    0,       0,       48/
      DATA KSTC49 /    5,     7,    38,    0,       1,       49/
      DATA KSTC50 /    4,     7,    33,    0,       1,       50/
      DATA KSTC51 /    4,     3,    46,    0,       0,       51/
      DATA KSTC52 /    6,     6,    39,    0,       0,       52/
      DATA KSTC53 /    7,     7,    47,    0,       0,       53/
      DATA KSTC54 /    7,     9,    34,    1,       0,       54/
      DATA KSTC55 /   10,     6,    40,    1,       0,       55/
      DATA KSTC56 /    4,     6,    41,    0,       1,       56/
      DATA KSTC57 /   10,     2,    35,    0,       0,       57/
      DATA KSTC58 /    4,     7,    33,    1,       0,       58/
      DATA KSTC59 /   10,     7,    44,    0,       1,       59/
      DATA KSTC60 /    9,     6,    45,    0,       1,       60/
      DATA KSTC61 /    6,     7,    38,    0,       1,       61/
      DATA KSTC62 /    7,     9,    34,    1,       0,       62/
      DATA KSTC63 /    5,     9,    22,    1,       0,       63/
      DATA KSTC64 /    9,     3,    21,    1,       0,       64/
      DATA KSTC65 /    8,     3,    3 ,    0,       0,       65/
      DATA KSTC66 /    5,     3,    3 ,    1,       0,       66/
      DATA KSTC67 /    6,    11,    43,    0,       1,       67/
      DATA KSTC68 /    4,    11,    49,    0,       0,       68/
      DATA KSTC69 /    4,    11,     3,    0,       0,       69/
      DATA KSTC70 /    6,     7,    47,    0,       0,       70/
      DATA KSTC71 /    7,    11,    3 ,    1,       0,       71/
      DATA KSTC72 /    8,     7,    47,    0,       1,       72/
      DATA KSTC73 /    9,     3,    3 ,    0,       0,       73/
      DATA KSTC74 /    5,     7,    47,    0,       1,       74/
      DATA KSTC75 /    9,     3,    3 ,    0,       1,       75/
      DATA KSTC76 /    4,     3,    3 ,    0,       0,       76/
      DATA KSTC77 /    9,     6,    3 ,    0,       0,       77/
      DATA KSTC78 /    3,     8,    16,    0,       0,       78/
      DATA KSTC79 /    6,     6,    3 ,    0,       0,       79/
      DATA KSTC80 /    5,     6,    3 ,    0,       0,       80/
      END
      SUBROUTINE MOVSTR (J)
      INCLUDE 'TIDY.INC'
C
C     ADDS 1 BYTE TO STRING BY SHIFTING UNPROCESSED CHARS RIGHT.
C     USED BY HOLSCN WHEN REPLICATING APOSTROPHES
C
      DO 10 I=JMAX,J,-1
           JINT(I+1)=JINT(I)
 10   CONTINUE
      JMAX=JMAX+1
      JINT(JMAX+1)=KERM
      J=J+1
      JCOL = JCOL+1
      RETURN
      END
      SUBROUTINE NOPRO (IFLAG)
C
C     THIS SUBROUTINE EXECUTES A HIGH-SPEED SEARCH FOR AN END STATEMENT.
C     IF MP2 IS ON, CARD IMAGES ARE WRITTEN ON TAPE 1 FOR USE BY PASS2.
C     NO INTERNAL PROCESSING IS DONE ON THE STATEMENTS.
C
      INCLUDE 'TIDY.INC'
C     SET INITIAL VALUES.
C
      CALL IOSY11
      CALL IOSY21
      NRT2=0
      NDEF=0
      KLASS=1
      ITYPE=0
      L15=0
      IF (MP2.EQ.0) GO TO 20
C
C     WRITE OUT STATEMENT CURRENTLY IN JINT.
C
      IMAX=JMAX
      KLASS=2
      CALL IOSYS1 (3,KILI,SERIAL,JINT)
      NRT1=1
      KLASS=3
      IF (JMAX.GT.72) CALL DIAGNO (28)
      GO TO 20
C
C     READ AND COPY CARD IMAGES BY WAY OF KBUFF.
C
 10   CALL READER
 20   NREC=NREC+1
C
C     LOOK FOR LAST NON-BLANK CHARACTER ON CARD.
C
      I=72
 30   IF (KBUFF(I).NE.KBL) GO TO 40
      I=I-1
      IF (I.GT.7) GO TO 30
 40   IMAX=I
C
C     LOOK FOR END STATEMENT IN INPUT BUFFER KBUFF
C
      J=3
      DO 50 I=7,IMAX
      K=I
      IF (KBUFF(I).EQ.KBL) GO TO 50
      IF (KBUFF(I).NE.KEND(J)) GO TO 60
      J=J-1
      IF (J.EQ.0) GO TO 70
 50   CONTINUE
      GO TO 60
C
C     FOUND AN END CARD IF NEXT CHAR IS BLANK.
 70   IF (KBUFF(K+1).EQ.KBL) KLASS=8
C
C     WRITE OUT CARD IMAGE FOR PASS2.
C
 60   IF (MP2.NE.0) THEN
      CALL IOSYS1 (3,KILI,SERIAL,KBUFF)
      NRT1=NRT1+1
      ENDIF
C
C     GET NEXT RECORD UNLESS END CARD OR EOF
      IF (IQUIT.NE.1.AND.KLASS.NE.8) GO TO 10
C
C     CLOSE FILE
      IF (MP2.NE.0) CALL IOSY12
C
C     LOAD BUFFER, KBUFF, BEFORE EXITING.
C
 90   IF (IQUIT.EQ.0) CALL READER
      RETURN
      END
      INTEGER FUNCTION OPFIL(KUNIT,FNAME,KTYPE,KNOUT,EXPRES,LENGTH)
C-------------------------------------------------------------------------
C---- THIS IS THE OPEN FILE FUNCTION BY W.J. MEERSCHAERT & P.J. DAUGHERTY
C---- JULY 25, 1986
C---- DUMMY PARAMETERS ARE AS FOLLOWS:
C
C    IUNIT....UNIT NUMBER OF THE FILE TO BE OPENED, PREFERRABLY > 20
C    FNAME....NAME OF FILE TO BE OPENED, IF SCRATCH, IT IS IGNORED,
C                IF MISSING, IT IS PROMPTED FOR
C    ITYPE....TYPE OF FILE TO BE OPENED, AS FOLLOWS:
C            >0   RECL FOR A DIRECT ACCESS UNFORMATTED FILE
C            >100000 DIRECT ACCESS FORMATTED FILE RECL=MOD(ITYPE,100000)
C             0   FORMATTED SEQUENTIAL FILE
C            <0   UNFORMATTED SEQUENTIAL FILE
C    INOUT....SPECIFIES WHAT THE FILE IS FOR:
C            -2   INPUT FILE, IF NOT EXIST, EXIT WITH ERROR CODE
C            -1   INPUT FILE, IF NOT EXIST, PROMPT USER FOR NEW NAME
C             0   SCRATCH FILE
C             1   OUTPUT FILE, IF EXIST, PROMPT USER FOR ACTION
C             2   OUTPUT FILE, IF EXIST, OVERWRITE AUTOMATICALLY
C             3   OUTPUT FILE, IF EXIST, APPEND AUTOMATICALLY
C             4   OUTPUT FILE, IF EXIST, EXIT WITH ERROR CODE
C    EXPRES...EXPRESSION FOR PROMPTING USER FOR FILENAME
C    LENGTH...NUMBER OF LINES IN OLD PART OF APPENDED FILE
C
C OPFIL RETURNS THE FOLLOWING:
C    0......ALL IS WELL
C    >0.....COMPILER OR SYSTEM ERROR MESSAGE ON OPEN STATEMENT
C    1......USER EOF ON A READ PROMPT (I.E., ABORT OPEN)
C    2......ERROR CODE BASED ON INOUT, FILE M=NOT OPENED
C
C-------------------------------------------------------------------------
      CHARACTER FNAME*(*),EXPRES*(*),ANS
      INTEGER DOSDEV
      LOGICAL EXST,FILOPN
      INCLUDE 'UNITS.INC'
C
C---- REASSIGN INTEGER DUMMY VARIABLES
C
      IUNIT=KUNIT
      ITYPE=KTYPE
      INOUT=KNOUT
      LENGTH=0
C
C---- OPEN SCRATCH FILE
C
      IF (INOUT.EQ.0) THEN
           IF (ITYPE) 10,20,30
 10        OPEN (IUNIT,STATUS='SCRATCH',FORM='UNFORMATTED',ACCESS='SEQUE
     1NTIAL',IOSTAT=OPFIL)
           RETURN
 20        OPEN (IUNIT,STATUS='SCRATCH',FORM='FORMATTED',ACCESS='SEQUENT
     1IAL',IOSTAT=OPFIL)
           RETURN
 30        IF (ITYPE.GT.100000) THEN
                ITYPE=MOD(ITYPE,100000)
                OPEN (IUNIT,ACCESS='DIRECT',STATUS='SCRATCH',RECL=ITYPE,
     1FORM='FORMATTED',IOSTAT=OPFIL)
           ELSE
                OPEN (IUNIT,ACCESS='DIRECT',STATUS='SCRATCH',RECL=ITYPE,
     1FORM='UNFORMATTED',IOSTAT=OPFIL)
           END IF
           RETURN
      END IF
C
C---- CHECK FOR LOGIC OF ARGUMENTS AND FILE PROPERTIES
C
 40   IF (FNAME.EQ.' '.AND.INOUT.NE.2) THEN
           WRITE (STDERR,190) EXPRES
           READ (STDIN,200,END=170) FNAME
           IF (FNAME(1:1).EQ.'?') THEN
                PAUSE 'Type DIR to see a list of files'
                FNAME=' '
                GO TO 40
           ELSE IF (FNAME(1:1).EQ.'>'.AND.FNAME(2:2).NE.'>') THEN
                IF (INOUT.GT.0) INOUT=2
                FNAME=FNAME(2:)
           ELSE IF (FNAME(1:2).EQ.'>>') THEN
                IF (INOUT.GT.0) INOUT=3
                FNAME=FNAME(3:)
           ELSE
                IF (INOUT.GT.0) INOUT=1
           END IF
      END IF
C
C---- GET EXST AND FILOPN
C
      INQUIRE (FILE=FNAME,EXIST=EXST,OPENED=FILOPN)
C
C     DON'T OPEN SAME FILE TWICE.
      IF (FILOPN) THEN
           WRITE (STDERR,210) FNAME
           FNAME=' '
           GO TO 40
      END IF
C
C---- INPUT FILE
C
      IF (.NOT.EXST.AND.INOUT.LT.0) THEN
           IF (INOUT.EQ.-1) THEN
                WRITE (STDERR,220) FNAME
                FNAME=' '
                GO TO 40
           ELSE IF (INOUT.EQ.-2) THEN
                GO TO 180
           END IF
C
C---- OUTPUT FILE
C
      ELSE IF (EXST.AND.INOUT.EQ.1) THEN
C
           ISDEV = 0
C
C     DOS DEVICES ARE OK IF THEY EXIST
           ISDEV =  DOSDEV(FNAME)
           IF (ISDEV.GT.0) THEN
                INOUT=2
                GO TO 60
           END IF
C
C     OTHERWISE ASK USER WHAT TO DO.
 50        WRITE (STDERR,230) EXPRES,FNAME
           READ (STDIN,240,END=170) ANS
           IF (ANS.EQ.'o'.OR.ANS.EQ.'O') THEN
                INOUT=2
           ELSE IF (ANS.EQ.'a'.OR.ANS.EQ.'A') THEN
                INOUT=3
           ELSE IF (ANS.EQ.'n'.OR.ANS.EQ.'N') THEN
                FNAME=' '
                GO TO 40
           ELSE
                GO TO 50
           END IF
      ELSE IF (EXST.AND.INOUT.EQ.4) THEN
           OPFIL=2
           RETURN
      END IF
C
C---- OPEN FILE
C
 60   IF (ITYPE) 70,80,90
 70   OPEN (IUNIT,FILE=FNAME,STATUS='UNKNOWN',FORM='UNFORMATTED',ACCESS=
     1'SEQUENTIAL',IOSTAT=OPFIL)
      GO TO 100
 80   OPEN (IUNIT,FILE=FNAME,STATUS='UNKNOWN',FORM='FORMATTED',ACCESS='S
     1EQUENTIAL',IOSTAT=OPFIL)
      GO TO 100
 90   IF (ITYPE.GT.100000) THEN
           ITYPE=MOD(ITYPE,100000)
           OPEN (IUNIT,FILE=FNAME,STATUS='UNKNOWN',FORM='FORMATTED',ACCE
     1SS='DIRECT',RECL=ITYPE,IOSTAT=OPFIL)
      ELSE
           OPEN (IUNIT,FILE=FNAME,STATUS='UNKNOWN',FORM='UNFORMATTED',AC
     1CESS='DIRECT',RECL=ITYPE,IOSTAT=OPFIL)
      END IF
      RETURN
 100  REWIND IUNIT
C
C---- APPEND IF REQUESTED
C
      IF (INOUT.EQ.3) THEN
           IF (ITYPE) 110,120,120
 110       READ (IUNIT,END=130)
           LENGTH=LENGTH+1
           GO TO 110
 120       READ (IUNIT,240,END=130) ANS
           LENGTH=LENGTH+1
           GO TO 120
 130       REWIND IUNIT
           DO 160 N=1,LENGTH
                IF (ITYPE) 140,150,150
 140            READ (IUNIT)
                GO TO 160
 150            READ (IUNIT,240) ANS
 160       CONTINUE
           END FILE IUNIT
           BACKSPACE (IUNIT)
      END IF
C
C---- ALL DONE
C
      RETURN
 170  OPFIL=1
      RETURN
 180  OPFIL=2
      RETURN
C
C
 190  FORMAT (/T3,'Open the ',A,' file'/T3,'Enter a file name here: ')
 200  FORMAT (A)
 210  FORMAT (/T3,'File already open: ',A)
 220  FORMAT (/T3,'File not found: ',A)
 230  FORMAT (/T10,A/T3,'File exists: ',A/T5,'[O]verwrite'/T5,'[A]ppend'
     1/T5,'[N]ew file spec'/T3,'Enter here: ')
 240  FORMAT (A1)
      END
      SUBROUTINE PAGE (N)
C
C     THIS SUBROUTINE DOES THE GENERAL PAGE COUNTING FOR TIDY WHILE
C     LIMITING THE OUTPUT TO MAXLIN LINES PER PAGE.
C
C          N>0 -- I WILL WRITE N LINES.  START A NEW PAGE IF NECESSARY.
C          N=0 -- START A NEW PAGE.
C          N<0 -- START A NEW PAGE IF .LT. -N LINES ARE LEFT.
C
      INCLUDE 'TIDY.INC'
      INCLUDE 'UNITS.INC'
      DATA MAXLIN /56/
C
      IF (N) 10,30,20
C                            CONDITIONAL EJECT (NO LINES WRITTEN)
 10   IF ((LINE-N).LE.MAXLIN) RETURN
      GO TO 30
 20   LINE=LINE+N
      IF (LINE.LE.MAXLIN) RETURN
C                            MAKE NEW PAGE
 30   IF (LINE.EQ.0) RETURN
         LINE=0
         IF (N.GT.0) LINE=N
         NPAGE=NPAGE+1
         MPAGE=MPAGE+1
         WRITE (OUTFIL,40) NROUT,IPASS,MPAGE,NPAGE,JOB
      RETURN
C
C
 40   FORMAT (/1H1,6X,'* T I D Y *          ROUTINE',I4,4X,4HPASS,I2,2X,
     14HPAGE,I3,21X,4HPAGE,I4/7X,80A1/1X)
      END
      SUBROUTINE PASS1
C
C     THIS ROUTINE COLLECTS STATEMENT NUMBERS, MAKES DIAGNOSTIC COMMENTS
C     AND SETS UP THE FORTRAN STATEMENTS IN A FORM SUITABLE FOR PASS2.
C
      INTEGER JTMP(8)
      INCLUDE 'TIDY.INC'
      INCLUDE 'UNITS.INC'
      CHARACTER*2 JNT,JT,ICH,KUPPER,PRVCPY
      DIMENSION KSTC(5)
      LOGICAL BAKSCN
C
C     A    B    C    D    E    F    G    H    I    J    K    L    M
C     1    2    3    4    5    6    7    8    9    10   11   12   13
C
C     N    O    P    Q    R    S    T    U    V    W    X    Y    Z
C     14   15   16   17   18   19   20   21   22   23   24   25   26
C
C     =    ,    (    /    )    +    -    *    .    $    -    '    & NONE
C     1    2    3    4    5    6    7    8    9    10   11   12   13  14
C
C
C     SET UP INITIAL CONDITIONS.
C     REWIND TAPE FILES 1 AND 2.
C
 10   CALL IOSY11
      CALL IOSY21
      DO 20 I=1,10
           LDOS(I)=0
 20   CONTINUE
      IMAX=1326
      IPASS=1
      ICOL=0
      KOUNT=0
      MP2=1
      NBLC=2
      MPUN=KPUN
      MPRIN=KPRIN
      NROUT=NROUT+1
      NRT1=0
      NRT2=0
      MILDO=0
      MLGC=-1
      MSKP=0
      MPAGE=0
      MTRAN=0
      NDEF=0
      NDOS=0
      NFORT=0
      NREC=0
      NREF=0
      L25=0
      NTRAN=0
      NXEQ=0
      NIFBLK=0
      GO TO 50
C
C                  ILLEGAL FIRST CHARACTER.
 30   JGOOF=9
C                  WRITE DIAGNOSTIC
 40   CALL DIAGNO (JGOOF)
C                  GET NEW CARD.
C     (UNLESS EOF ALREADY)
      IF (IQUIT.NE.0) RETURN
 50   CALL SKARD
      NXRF=1
      IF (IMAX.LT.ICOL) IMAX=ICOL
      DO 60 I=1,IMAX
           IOUT(I)=KBL
 60   CONTINUE
      IMAX=0
C
C     LOOK FOR * IN COLUMN 1
C
      IF (JINT(1).NE.KSPK(8)) GO TO 110
      CALL CONTRL
      IF (ISTAR) 70,90,100
C                  CONTROL CARD FOUND AND EXECUTED.
 70   IF (MSTOP.EQ.0) GO TO 80
C                            *STOP CARD FOUND. QUIT IF FIRST OF ROUTINE
      IF (NFORT.LE.0) RETURN
C                            OTHERWISE BUILD AN END CARD
      GO TO 1100
 80   IF (MSKP.EQ.0) GO TO 50
      MP2=0
      CALL NOPRO (0)
      GO TO 10
C                  CONTROL CARD FOR DELAYED EXECUTION. SAVE FOR PASS 2.
 90   KLASS=0
      GO TO 210
C                  * IN COL 1. NOT A CONTROL CARD.  PUT OUT LITERALLY
C                  UNLESS * IN COL 2. ALSO.
 100  IF (JINT(2).EQ.KSPK(8)) GO TO 50
      GO TO 200
C
C     *STOP COMMAND EXIT.
C
C     NO * IN COLUMN 1, LOOK FOR C, D, I, F, ., OR $. (UPPER CASE)
C
 110  IF (JINT(1).EQ.KBL) GO TO 260
      JINT(1)=KUPPER(JINT(1))
      IF (JINT(1).EQ.KABC(3)) GO TO 150
      IF (JINT(1).EQ.KABC(4)) GO TO 130
      IF (JINT(1).EQ.KABC(9)) GO TO 130
      IF (JINT(1).EQ.KABC(6)) GO TO 130
C     LOOK FOR ANY SPECIAL CHARACTER IN COLUMN 1
      DO 120 I=1,14
           IF (JINT(1).EQ.KSPK(I)) GO TO 140
 120  CONTINUE
      GO TO 260
 130  CALL DIAGNO (8)
      GO TO 50
C
C     SPECIAL CHAR IN COL 1.  GIVE MSG AND TREAT AS COMMENT
C
 140  CALL DIAGNO (30)
      GO TO 200
C
C     COMMENT CARD.  DO WE SAVE THEM...
 150  IF (MCOM) 180,50,160
C                  CHECK COL 2-6. DELETE *, SKIP ON ANYTHING ELSE.
 160  DO 170 JCOL=2,6
           IF (JINT(JCOL).EQ.KBL) GO TO 170
           IF (JINT(JCOL).NE.KSPK(8)) GO TO 240
           JINT(JCOL)=KBL
 170  CONTINUE
C
C     LOOK FOR BLANK COMMENT
C
 180  DO 190 JCOL=2,JMAX
           IF (JINT(JCOL).NE.KBL) GO TO 230
 190  CONTINUE
C
C     BLANK COMMENT. TEST IF TWO PREVIOUS CARDS WERE BLANK
C
      NBLC=NBLC+1
      IF (NBLC.GT.2) GO TO 50
      JINT(1)=KABC(3)
      JMAX=7
 200  KLASS=1
 210  JTYPE=0
C
C     WRITE STATEMENT IMAGE ON TAPE 1 FOR PASS 2.
C
 220  L15=0
      IMAX=JMAX
      CALL IOSYS1 (3,KILI,SERIAL,JINT)
      NRT1=NRT1+1
      GO TO 50
C
C     NON-BLANK COMMENT.
C
 230  NBLC=0
      IF (JMAX.GT.72) JMAX=72
      GO TO 200
C
C     NON-BLANK IN STATEMENT FIELD.
C
 240  ICOL=6
      DO 250 I=JCOL,JMAX
           ICOL=ICOL+1
           IOUT(ICOL)=JINT(I)
 250  CONTINUE
      IOUT(1)=KABC(3)
      IF (ICOL.GT.72) ICOL=72
      IMAX=ICOL
      KLASS=1
      JTYPE=0
      L15=0
      CALL IOSYS1 (3,KILI,SERIAL,IOUT)
      NRT1=NRT1+1
      GO TO 50
C
C               ===============================================
C               *                                             *
C               *      START PROCESSING OF FORTRAN CARDS      *
C               *                                             *
C               ===============================================
C
 260  IF (JMAX.LT.8) GO TO 40
      NFORT=NFORT+1
C     CLASSIFY STATEMENT, THEN CHECK AND CHANGE HOLLERITH FIELDS
C       (DO UNCLASSIFIED (REPLACEMENT, ETC) STATEMENTS, AND ALSO
C       THOSE IN WHICH STRINGS ARE LEGAL PARTS.
      ITYPE=0
      JCOL=6
      CALL KWSCAN (ITYPE,KSTC)
      MPASS1=1
      I=KSTC(5)
      CALL HOLSCN (ITYPE,I)
C                  CLEAR FLAGS
      MLGC=-1
      NTRAN=MTRAN
      MTRAN=0
      MEOF=-1
      JGOOF=1
C                  CLEAR STATEMENT AND REFERENCE NUMBERS
      L15=0
      L772=0
C                  CLEAR BLANK COMMENT COUNTER
      NBCOLD=NBLC
      NBLC=0
C                  SET POSITION COUNTERS.
      JCOL=7
      IF (JUST.NE.0) GO TO 280
C                            NO COLUMN SHIFT
      ICOL=6
 270  IF (JINT(JCOL).NE.KBL) GO TO 290
      JCOL=JCOL+1
      ICOL=ICOL+1
      GO TO 270
C                            COLUMN=SOMETHING
 280  ICOL=JUST-1
C                            ADD INDENT
 290  ICOL=ICOL+INDENT*(NDOS+NIFBLK)
      ICOL=MIN0(ICOL,MXRGHT)
C                            REMEMBER THE STARTING COLUMN
      ICOLSV=ICOL
C                  ANALYSIS OF LOGICAL IF RE-ENTERS HERE.
C
C                  SELECT NEXT COURSE ON BASIS OF FIRST SPECIAL CH.
C             =   ,   (   /  )  +  -  *   .  $  -  '  &  NONE
 300  GO TO (340,480,310,480,30,30,30,480,30,30,30,480,30,480),IFIR
C
C                  FIRST IS (.  LOOK FOR )
 310  NPAR=0
      DO 320 NF=LFIR,JMAX
           IF (JINT(NF).EQ.KSPK(5)) NPAR=NPAR-1
           IF (JINT(NF).EQ.KSPK(3)) NPAR=NPAR+1
           IF (NPAR.EQ.0) GO TO 330
 320  CONTINUE
C                            MISSING )
      JGOOF=2
      GO TO 40
C                  THIS IS THE END OF THE FIRST STACK OF PARENS.
C                  SKIP BLANKS.
 330  NF=NF+1
      IF (NF.EQ.JMAX) GO TO 480
      IF (JINT(NF).EQ.KBL) GO TO 330
C
C                  CHARACTER REPLACEMENT STATEMENTS CAN HAVE 2 SETS OF
C                  PARENS BEFORE =.
      IF (JINT(NF).EQ.KSPK(3)) THEN
           LFIR=NF
           GO TO 310
      END IF
C                  IF NEXT CHARACTER IS NOT = PROCESS AS FORTRAN STATEME
      IF (JINT(NF).NE.KSPK(1)) GO TO 480
C                  OTHERWISE, PROCESS AS ARITHMETIC REPLACEMENT.
      LQUAL=NF
      GO TO 440
C
C                  FIRST SPECIAL CH. IS =.
 340  LQUAL=LFIR
C                  IS IT A DO STATEMENT.  IF NOT, GO TO ARITHMETIC PROC.
C                  LOOK FOR -D- -O-
      ICH=KABC(4)
      DO 350 J=7,JMAX
           IF (JINT(J).EQ.KBL) GO TO 350
           IF (JINT(J).NE.ICH) GO TO 440
           IF (ICH.EQ.KABC(15)) GO TO 360
           ICH=KABC(15)
 350  CONTINUE
      GO TO 440
C                  FOUND -D- -O- NOW LOOK FOR COMMAS.  ALLOW EXACTLY 1
C                  OR 2 COMMAS OUTSIDE OF PARENTHESES, 1 EQUALS.
C                  CERTAIN SPECIAL CHARACTERS NOT ALLOWED.
 360  NCOMA=0
      NLPS=0
      JJ=LQUAL+1
      DO 430 J=JJ,JMAX
           JNT=JINT(J)
           DO 370 I=1,14
                IF (JNT.EQ.KSPK(I)) GO TO 380
 370       CONTINUE
           GO TO 430
C
 380       GO TO (440,410,390,430,400,430,430,430,430,440,430,440,440,
     1      440),I
C
C     COUNT LEFT PARENTHESES
 390       NLPS=NLPS+1
           GO TO 430
C
C     COUNT RIGHT PARENTHESES
 400       NLPS=NLPS-1
           GO TO 430
C
C     A COMMA. DISREGARD IF INSIDE PARENTHESES, ABORT SCAN IF UNBALANCED
 410       IF (NLPS) 440,420,430
C---
 420       IF (NCOMA.GT.1) GO TO 440
           NCOMA=NCOMA+1
 430  CONTINUE
      IF (NCOMA.EQ.0) GO TO 440
C                  O.K.  THIS IS A DO STATEMENT.
      KLASS=10
      JTYPE=14
      GO TO 530
C              =================================================
C              *                                               *
C              *   START PROCESSING OF ARITHMETIC STATEMENT.   *
C              *                                               *
C              =================================================
 440  KLASS=6
      JTYPE=0
 450  CALL COPY (-1)
      IF (MEOF) 450,470,460
 460  IF (LCPY.EQ.KERM) GO TO 470
      ICOL=ICOL+1
      MEOF=-1
      GO TO 450
 470  IF (MLGC.EQ.0) GO TO 610
C
C     GET STATEMENT NUMBER.
C
      JCOL=1
      CALL RSTAT
      L15=L772
      GO TO 610
C
C              ========================================
C              *                                      *
C              *     END OF ARITHMETIC PROCESSING     *
C              *  START FORTRAN STATEMENT PROCESSING  *
C              *                                      *
C              ========================================
C
C                  CHECK EVERY LISTED STATEMENT TYPE.
 480  IF (MPASS1.GT.1) THEN
C     MUST RE-CHECK REST OF IF-STATEMENTS
           ITYPE=0
           CALL KWSCAN (ITYPE,KSTC)
           IF (ITYPE.EQ.0) GO TO 600
      END IF
      MPASS1=MPASS1+1
      IF (ITYPE.EQ.0) GO TO 490
C                  FOUND IT.
C        COMPLAIN IF FIRST SPECIAL CHAR ' AND NOT INCLUDE STATEMENT.
      IF (IFIR.EQ.12.AND.ITYPE.NE.71.AND.ITYPE.NE.43) GO TO 30
      KLASS=KSTC(2)
      JTYPE=KSTC(3)
C     COMPLAIN IF NON-ANSI STATEMENT.
      IF (MANSI.EQ.0.AND.KSTC(4).EQ.1) CALL DIAGNO (34)
      IF (MLGC.NE.0) GO TO 500
C                            FOLLOWS LOGICAL IF
      IF (KLASS.EQ.4.OR.KLASS.EQ.6.OR.KLASS.EQ.7.OR.KLASS.EQ.11) GO TO
     1570
      GO TO 40
C                  NOT IN TABLE.  PASS IT WITHOUT PROCESSING.
 490  CALL DIAGNO (30)
      KLASS=11
      JTYPE=0
C
C                  THIS IS A FORTRAN STATEMENT.
C                  SET IMAX IN CASE THIS STATEMENT IS PUT OUT DIRECTLY.
 500  IMAX=JMAX
C                  CHECK FOR EXEMPT STATEMENT.
      IF (KLASS.NE.3) GO TO 520
      DO 510 J=1,6
           JINT(J)=KBL
 510  CONTINUE
      IF (MEX.EQ.0) GO TO 570
C                  THIS IS A NON-EXECUTABLE (KLASS 3.) FORTRAN STATEMENT
C                  AND THE EXEMPT FLAG IS SET.  SO PUT IT OUT DIRECTLY.
      GO TO 220
C
C                  GET STATEMENT NUMBER UNLESS FOLLOWING LOGICAL IF.
 520  IF (MLGC.EQ.0) GO TO 570
 530  DO 560 I=1,5
           IF (JINT(I).EQ.KBL) GO TO 560
           DO 540 J=1,10
                IF (JINT(I).EQ.KDIG(J)) GO TO 550
 540       CONTINUE
           GO TO 570
 550       L15=L15*10+J-1
 560  CONTINUE
C
C        IF THIS IS A WEIRD CARD, ALLOW A TRANSFER TO IT
 570  IF (KLASS.EQ.11) NTRAN=0
C
C     GO TO INDIVIDUAL STATEMENT PROCESSING BY JTYPE.
C
      I=JTYPE+1
      GO TO (640,670,700,710,720,730,740,780,810,880,890,920,980,990,
     11000,1090,1100,1220,1240,1250,1290,1310,680,1320,1340,1400,1420,
     21430,1440,1470,1480,1500,1590,1600,1630,1640,1660,1750,1790,1840,
     31850,1860,1870,1490,1650,1740,1900,1980,1990,2000,580),I
C
C     ==================================================================
C     *                                                                *
C     *  AT THIS POINT, COMMENTS AND ARITHMETIC STATEMENTS HAVE BEEN   *
C     *  PROCESSED.  THE STATEMENTS HAVE BEEN CLASSIFIED AS ITYPE AND  *
C     *  KLASS.  THE LAST SYMBOL USED IN SCANNING THE FORTRAN STATE-   *
C     *  MENT IS KST(NINS,ITYPE), AND WAS FOUND AT JINT(LAST).  THE    *
C     *  FIRST SPECIAL CHARACTER, IF ANY, IS KSPK(IFIR), LOCATED AT    *
C     *  JINT(LFIR).  IF A STATEMENT                                   *
C     *  NUMBER IS PERMITTED, IT IS IN L15.  IF NOT, L15=0.            *
C     *  JCOL IS ON THE CURRENT CHARACTER IN THE INPUT STRING (THE     *
C     *  FIRST, UNLESS FOLLOWING A LOGICAL IF).  ICOL IS ON THE MOST   *
C     *  RECENT CHARACTER TO BE PUT INTO THE OUTPUT STRING (E.G. 6.)   *
C     *                                                                *
C     ==================================================================
C
C                  ILLEGAL JTYPE
 580  WRITE (OUTFIL,2030) JTYPE
      STOP 126
C
C                  COPY REST OF CARD.
 590  ICOL=ICOL+1
 600  CALL COPY (0)
      IF (KLASS.LT.4) GO TO 620
C                  DLIST HANDLES THE STATEMENT NUMBER.
 610  CALL DLIST (MERR)
      IF (MERR.NE.0) GO TO 50
 620  IMAX=ICOL
C                  WRITE STATEMENT IMAGE ON TAPE1 FOR PASS 2.
 630  CALL IOSYS1 (3,KILI,SERIAL,IOUT)
      NRT1=NRT1+1
      GO TO 50
C
C                  ***** JTYPE = 0
C     UNRECOGNIZED FORTRAN CARD
C                  COPY IT, INCLUDING BLANKS
 640  DO 650 I=JCOL,1600
           ICOL=ICOL+1
           IOUT(ICOL)=JINT(I)
           IF (IOUT(ICOL).EQ.KERM) GO TO 660
 650  CONTINUE
      I=1600
 660  JCOL=I
      LCPY=KERM
      ICOL=ICOL-1
      MEOF=0
      GO TO 610
C
C                  ***** JTYPE = 1
C     ASCENT,MACHINE.
 670  I=0
      GO TO 690
C
C                  ***** JTYPE = 22
C     IDENT
C
 680  I=1
C            (MUST BE THE FIRST CARD OF THIS PASS.)
 690  IF (NFORT.NE.1) CALL DIAGNO (14)
      CALL DIAGNO (26)
      CALL NOPRO (I)
      CALL HEADER
      RETURN
C
C                  ***** JTYPE = 2
C     ASSIGN
C
 700  CALL COPY (6)
      CALL RSTAT
      CALL RLIST
      IOUT(ICOL+2)=KLR2
      IF (NXRF.GT.MXREF) GO TO 2010
      IOUTN(NXRF)=L772
      NXRF=NXRF+1
      ICOL=ICOL+3
      CALL COPY (2)
      IF (MEOF.LT.0) GO TO 590
      GO TO 40
C
C                  ***** JTYPE = 3
C     BACKSPACE, EXTERNAL, IMPLICIT, PAUSE.
C
 710  CALL COPY (NINS)
C     FINISH AN IMPLICIT STATEMENT
      IF (ITYPE.EQ.65) THEN
           ICOL=ICOL+1
           GO TO 480
      END IF
      GO TO 590
C
C                  ***** JTYPE = 4
C      BLOCK DATA
C
 720  IF (NFORT.NE.1) GO TO 40
      CALL COPY (5)
      ICOL=ICOL+1
      CALL COPY (4)
      GO TO 590
C
C                  ***** JTYPE = 5
C     BUFFER IN (I,P) (A,B) /// BUFFER OUT (I,P) (A,B)
C
 730  CALL COPY (6)
      ICOL=ICOL+1
C                  NINS IS 9 FOR BUFFERIN, 10 FOR BUFFEROUT
      CALL COPY (NINS-7)
      ICOL=ICOL+1
      CALL COPY (-1)
      ICOL=ICOL+1
      CALL COPY (-1)
      IF (MEOF.LT.0.AND.JCOL.GT.JMAX) GO TO 610
      GO TO 40
C
C                  ***** JTYPE = 6
C     CALL   (FUNCTION,SUBROUTINE)
C
 740  JGOOF=10
      CALL COPY (4)
      ICOL=ICOL+1
      IF (IFIR.NE.3) GO TO 600
 750  CALL COPY (1)
      IF (LCPY.EQ.KSPK(3)) GO TO 760
      IF (MEOF.LT.0) GO TO 750
      GO TO 40
 760  IOUT(ICOL)=KBL2
      JCOL=JCOL-1
 770  PRVCPY = LCPY
      CALL COPY (1)
      IF (MEOF.LT.0) THEN
           IF (LCPY.EQ.KALMRK) THEN
C     ALTERNATE RETURNS MUST BE PRECEDED BY , OR (
                IF (PRVCPY.NE.KSPK(2).AND.PRVCPY.NE.KSPK(3)) GO TO 770
C                            ARGUMENT IS *STATEMENT NUMBER
C     TRANSLATE ALTERNATE RETURN CODE IF DESIRED.
                IF (KALTRN.NE.KBL) IOUT(ICOL)=KALTRN
                CALL RSTAT
C
C     NO NUMBER LEGAL ONLY FOR FUNCTIONS AND SUBROUTINES.
                IF (L772.EQ.0) THEN
                     IF (ITYPE.EQ.29 .OR. ITYPE.EQ.57) GO TO 770
                     GO TO 40
                ENDIF
                ICOL=ICOL+1
                IOUT(ICOL)=KLR2
                IF (NXRF.GT.MXREF) GO TO 2010
                IOUTN(NXRF)=L772
                NXRF=NXRF+1
                CALL RLIST
           END IF
           GO TO 770
      END IF
C
      IMAX=ICOL
      IF (NPAR.EQ.0) GO TO 610
      GO TO 40
C
C                  ***** JTYPE = 7
C      COMMON
C
 780  CALL COPY (6)
      ICOL=ICOL+1
C          J COUNTS SLASHES
      J=-2
      IF (IFIR.NE.4) GO TO 600
 790  IF (J.EQ.0) GO TO 590
      J=J+1
 800  CALL COPY (1)
      IF (LCPY.EQ.KSPK(4)) GO TO 790
      IF (MEOF.LT.0) GO TO 800
      CALL DIAGNO (11)
      GO TO 630
C
C                  ***** JTYPE = 8
C     CONTINUE
C
 810  JGOOF=12
      IF (L15.EQ.0) GO TO 40
      IF (MLGC.NE.0) GO TO 830
      DO 820 I=7,ICOL
           IOUT(I)=KBL
 820  CONTINUE
      ICOL=ICOLSV
      MLGC=-1
 830  IF (MCONT.NE.0) GO TO 860
C                            IS THIS A DO-LOOP TERMINATOR...
      IF (NDOS.EQ.0) GO TO 850
      DO 840 I=1,NDOS
           IF (L15.EQ.LDOS(I)) GO TO 860
 840  CONTINUE
C                            COPY THE CARD
 850  CALL COPY (8)
C                            PROCESS STATEMENT NUMBER
      CALL DLIST (MERR)
C                            SET A FLAG
      LDEF(NDEF)=-LDEF(NDEF)
      L25=L15
C                            TAKE TRANSFER STATUS OF LAST CARD
      MTRAN=NTRAN
C                            DONT SAVE STATEMENT FOR PASS2
      GO TO 50
C                            THIS CONTINUE STATEMENT IS TO BE RETAINED
 860  IF (NDOS.EQ.0) GO TO 870
C                            IT TERMINATES THIS DO-LOOP. INDENT
C                            ONE LESS LEVEL
      IF (L15.EQ.LDOS(NDOS).AND.MLGC.NE.0) THEN
           ICOL=ICOL-INDENT
           ICOLSV=ICOL
      END IF
 870  CALL COPY (8)
      GO TO 610
C
C                  ***** JTYPE = 9
C     DATA
C
 880  CALL COPY (4)
      ICOL=ICOL+1
      IF (IFIR.NE.4) GO TO 600
      IF (JINT(JMAX).NE.KSPK(4).OR.LFIR.GE.JMAX) CALL DIAGNO (11)
      GO TO 600
C
C                  ***** JTYPE = 10
C     DECODE (C,N,V) LIST  ///  ENCODE (C,N,V) LIST
C
 890  JGOOF=23
      CALL COPY (6)
      ICOL=ICOL+1
      CALL COPY (1)
 900  CALL COPY (1)
      IF (LCPY.EQ.KSPK(2)) GO TO 910
      IF (MEOF.LT.0) GO TO 900
      GO TO 40
 910  CALL RSTAT
      IF (L772.EQ.0) GO TO 1810
      ICOL=ICOL+1
      IOUT(ICOL)=KLR2
      IF (NXRF.GT.MXREF) GO TO 2010
      IOUTN(NXRF)=L772
      NXRF=NXRF+1
      CALL RLIST
      GO TO 1810
C
C                  ***** JTYPE = 11
C     DIMENSION
C
 920  JGOOF=13
      CALL COPY (9)
      ICOL=ICOL+1
      NPAR=-1
      DO 970 I=JCOL,JMAX
           CALL COPY (1)
           IF (NPAR) 930,940,950
 930       IF (LCPY.EQ.KSPK(3)) GO TO 960
           GO TO 970
 940       IF (LCPY.EQ.KSPK(5)) GO TO 960
           GO TO 970
 950       IF (LCPY.NE.KSPK(2)) GO TO 970
           ICOL=ICOL+1
           NPAR=-1
           GO TO 970
 960       NPAR=NPAR+1
 970  CONTINUE
      IF (NPAR.GT.0) GO TO 620
      GO TO 40
C
C                  ***** JTYPE = 12
C     DOUBLE PRECISION
C
 980  CALL COPY (6)
      ICOL=ICOL+1
      CALL COPY (9)
      ICOL=ICOL+1
      GO TO 480
C
C                  ***** JTYPE = 13
C     DOUBLE, (CONVERT TO DOUBLE PRECISION).
C
 990  CALL COPY (6)
      IOUT(ICOL+2)=KABC(16)
      IOUT(ICOL+3)=KABC(18)
      IOUT(ICOL+4)=KABC(5)
      IOUT(ICOL+5)=KABC(3)
      IOUT(ICOL+6)=KABC(9)
      IOUT(ICOL+7)=KABC(19)
      IOUT(ICOL+8)=KABC(9)
      IOUT(ICOL+9)=KABC(15)
      IOUT(ICOL+10)=KABC(14)
      ICOL=ICOL+11
      GO TO 600
C
C                  ***** JTYPE = 14
C     DO STATEMENT
C
 1000 MILDO=1
      CALL COPY (2)
      CALL RSTAT
      IF (L772.EQ.0) GO TO 40
      JGOOF=15
      IF (NDEF.LE.0) GO TO 1020
      DO 1010 I=1,NDEF
           IF (IABS(LDEF(I)).EQ.L772) GO TO 40
 1010 CONTINUE
C
C     ADD STATEMENT NUMBER TO DO-LIST.
C
 1020 IF (NDOS.EQ.0) GO TO 1040
      IF (NDOS.LT.0) STOP 30
      IF (LDOS(NDOS).EQ.L772) GO TO 1060
      IF (NDOS.EQ.1) GO TO 1040
      DO 1030 I=2,NDOS
           IF (LDOS(I-1).EQ.L772) GO TO 40
 1030 CONTINUE
      IF (NDOS.GE.10) GO TO 1080
 1040 NDOS=NDOS+1
      LDOS(NDOS)=L772
      IF (NREF.LE.0) GO TO 1060
      DO 1050 I=1,NREF
           IF (LREF(I).EQ.L772) GO TO 1070
 1050 CONTINUE
 1060 CALL RLIST
      IOUT(ICOL+2)=KLR2
      IF (NXRF.GT.MXREF) GO TO 2010
      IOUTN(NXRF)=L772
      NXRF=NXRF+1
      ICOL=ICOL+3
      GO TO 600
C
 1070 CALL DIAGNO (27)
      GO TO 1060
C
 1080 JGOOF=24
      MPUN=0
      MP2=0
      GO TO 40
C
C     END DO-LOOP STATEMENT PROCESSING.
C
C
C                  ***** JTYPE = 15
C     END FILE
C
 1090 IF (IFIR.NE.14) GO TO 30
      CALL COPY (3)
      ICOL=ICOL+1
      CALL COPY (4)
      GO TO 590
C
C                  ***** JTYPE = 16
C     END STATEMENT.
C
C                   IS THERE A STATEMENT NUMBER TO USE?
 1100 IF (L15.EQ.0.AND.L25.EQ.0) GO TO 1120
C                   YES. MAKE A CONTINUE CARD FOR IT TO FALL TO.
      IOUT(7)=KABC(3)
      IOUT(8)=KABC(15)
      IOUT(9)=KABC(14)
      IOUT(10)=KABC(20)
      IOUT(11)=KABC(9)
      IOUT(12)=KABC(14)
      IOUT(13)=KABC(21)
      IOUT(14)=KABC(5)
      MILDO=0
      CALL DLIST (MERR)
      IF (MERR.NE.0) GO TO 1110
      JTMP(1)=4
      JTMP(2)=8
      JTMP(3)=L15
      JTMP(4)=14
      JTMP(5)=MTRAN
      JTMP(6)=NXRF
      JTMP(7)=MEX
      JTMP(8)=ICOLSV
      CALL IOSYS1 (3,JTMP,JINT(6),IOUT)
      NRT1=NRT1+1
 1110 L15=0
 1120 IF (NIFBLK.GT.0) CALL DIAGNO (33)
      IF (NDOS.EQ.0) GO TO 1130
      CALL DIAGNO (16)
      CALL PAGE (1)
      WRITE (OUTFIL,2020) (LDOS(I),I=1,NDOS)
C                   DOES THIS STATEMENT HAVE A NUMBER....
 1130 IF (L15.EQ.0) GO TO 1160
C                   YES.  IS IT REFERENCED....
      IF (NREF.LE.0) GO TO 1160
      DO 1140 I=1,NREF
           IF (LREF(I).EQ.L15) GO TO 1150
 1140 CONTINUE
C                   NO.  IGNORE THE NUMBER.
      GO TO 1160
C                   YES.
 1150 CALL DIAGNO (18)
C                           GENERATE NEW STOP COMMAND.
      IOUT(7)=KABC(19)
      IOUT(8)=KABC(20)
      IOUT(9)=KABC(15)
      IOUT(10)=KABC(16)
      MILDO=-1
      CALL DLIST (MERR)
      IF (MERR.NE.0) GO TO 1160
      JTMP(1)=6
      JTMP(2)=55
      JTMP(3)=L15
      JTMP(4)=10
      JTMP(5)=MTRAN
      JTMP(6)=NXRF
      JTMP(7)=MEX
      JTMP(8)=ICOLSV
      CALL IOSYS1 (3,JTMP,JINT(6),IOUT)
      NRT1=NRT1+1
C                       PROCESS FORMATS ON TAPE 2
 1160 IF (NRT2.LE.0) GO TO 1200
      CALL IOSY22
C                                  INSERT BLANK COMMENT CARD.
      IF (NBLC.NE.0) GO TO 1180
      IOUT(1)=KABC(3)
      DO 1170 I=2,7
           IOUT(I)=KBL
 1170 CONTINUE
      KLASS=1
      ITYPE=0
      L15=0
      IMAX=7
      CALL IOSYS1 (3,KILI,SERIAL,IOUT)
      NRT1=NRT1+1
C                                TRANSFER FORMAT STATEMENTS
 1180 CALL IOSYS2 (4,KILI,SERIAL,IOUT)
      NRT2=NRT2-1
      ICOLSV=6
      NREC=JTYPE
      MILDO=1
      CALL DLIST (MERR)
      IF (MERR.NE.0) GO TO 1190
      CALL IOSYS1 (3,KILI,SERIAL,IOUT)
      NRT1=NRT1+1
 1190 IF (NRT2.GT.0) GO TO 1180
      CALL IOSY21
C                                      MAKE END STATEMENT
 1200 IF (NFEND.EQ.0) THEN
           DO 1210 I=1,6
                IOUT(I)=KBL
 1210      CONTINUE
           IOUT(7)=KABC(5)
           IOUT(8)=KABC(14)
           IOUT(9)=KABC(4)
           KLASS=8
           ITYPE=20
           L15=0
           IMAX=9
           CALL IOSYS1 (3,KILI,SERIAL,IOUT)
           NRT1=NRT1+1
      END IF
      CALL IOSY12
      RETURN
C
C                 ==================================
C                 *   PASS1 NORMALLY EXITS HERE.   *
C                 ==================================
C
C
C                  ***** JTYPE = 17
C     EQUIVALENCE
C
 1220 CALL COPY (10)
 1230 CALL COPY (1)
      ICOL=ICOL+1
      CALL COPY (-1)
      IF (MEOF.LT.0) GO TO 1230
      GO TO 620
C
C                  ***** JTYPE = 18
C     FINIS.
C
 1240 MSTOP=-1
      RETURN
C
C                  ***** JTYPE = 19
C     FORMAT (
C
 1250 JGOOF=17
      IF (L15.EQ.0) GO TO 40
      IF (JINT(JMAX).NE.KSPK(5)) GO TO 40
      IF (MEX.NE.0) GO TO 1270
      IF (MCOL.NE.-1) GO TO 1260
C
C     IF COLLECTING FORMATS, START THEM IN COLUMN 7 (OR JUST).
      ICOL=6
      IF (JUST.GT.0) ICOL=JUST-1
C
 1260 CALL COPY (6)
C                            COPY REST OF CARD
      IF (MCOL.EQ.0) GO TO 590
C                            ONTO UNIT 2
      ICOL=ICOL+1
      CALL COPY (0)
      IMAX=ICOL
      JTYPE=NREC
      CALL IOSYS2 (3,KILI,SERIAL,IOUT)
      NRT2=NRT2+1
      NBLC=NBCOLD
      GO TO 50
C
C     EXEMPT FLAG IS ON - TRANSFER TO TAPE1 OR TAPE2 WITHOUT REMOVING
C     ANY BLANKS.
C
 1270 IF (MCOL.EQ.0) GO TO 1280
      ITYPE=NREC
      CALL IOSYS2 (3,KILI,SERIAL,JINT)
      NRT2=NRT2+1
      NBLC=NBCOLD
      GO TO 50
 1280 CALL DLIST (MERR)
      IF (MERR.NE.0) GO TO 50
      CALL IOSYS1 (3,KILI,SERIAL,JINT)
      NRT1=NRT1+1
      GO TO 50
C
C                  ***** JTYPE = 20
C     FORTRAN,ETC
C
 1290 DO 1300 I=7,JMAX
           IOUT(I)=JINT(I)
 1300 CONTINUE
      IMAX=JMAX
      GO TO 630
C
C                  ***** JTYPE = 21
C     FREQUENCY
C
 1310 JGOOF=8
      GO TO 40
C
C                  ***** JTYPE = 23
C     GO TO (***,***),N
C
 1320 JGOOF=19
      CALL COPY (2)
      ICOL=ICOL+1
      CALL COPY (2)
      ICOL=ICOL+1
      CALL COPY (1)
      MILDO=1
      MTRAN=MLGC
C
C     PROCESS --GO TO LIST--.
C
 1330 ICOL=ICOL+1
      IOUT(ICOL)=KLR2
      CALL RSTAT
      IF (L772.EQ.0) GO TO 40
      IF (NXRF.GT.MXREF) GO TO 2010
      IOUTN(NXRF)=L772
      NXRF=NXRF+1
      CALL RLIST
      CALL COPY (1)
      IF (LCPY.EQ.KSPK(2)) GO TO 1330
      IF (LCPY.NE.KSPK(5)) GO TO 40
      CALL COPY (1)
      IF (LCPY.EQ.KSPK(2)) GO TO 600
      IOUT(ICOL+2)=IOUT(ICOL)
      IOUT(ICOL)=KSPK(2)
      ICOL=ICOL+2
      GO TO 600
C
C                  ***** JTYPE = 24
C     GO TO ****
C
 1340 JGOOF=19
      MILDO=-1
      CALL COPY (2)
      ICOL=ICOL+1
      CALL COPY (2)
      ICOL=ICOL+1
      CALL RSTAT
C
C     TEST REF STATEMENT FOR GO TO N OR GO TO N, (LIST)
C
      IF (L772.EQ.0) GO TO 1370
C
C     STATEMENT IS --GO TO 12345--.
C
      IF (L15.EQ.0.AND.L25.EQ.0) GO TO 1360
      IF (MLGC.EQ.0) GO TO 1360
C     LABELLED GOTO STATEMENT.
      IF (MCONT.NE.0) GO TO 1350
      CALL DLIST (MERR)
      IF (MERR.NE.0) GO TO 40
C     SET UP REFERENCE TRANSLATION
      IF (NDEF.GE.1500) GO TO 1360
      NDEF=NDEF+1
      LDEF(NDEF)=0
      LOCDEF(NDEF)=L772
      L15=0
C     IF NO WAY TO GET HERE, DELETE IT
      IF (NTRAN.NE.0) GO TO 50
      GO TO 1360
 1350 CALL DIAGNO (18)
 1360 MTRAN=MLGC
      IOUT(ICOL+1)=KLR2
      ICOL=ICOL+1
      IF (NXRF.GT.MXREF) GO TO 2010
      IOUTN(NXRF)=L772
      NXRF=NXRF+1
      CALL RLIST
      GO TO 610
C
C     GO TO N OR GO TO N,LIST
C
 1370 MTRAN=MLGC
      IF (IFIR.EQ.2) GO TO 1380
C
C     STATEMENT IS --GO TO N--.
C
      IF (IFIR.EQ.14) GO TO 600
      GO TO 40
C
C     GO TO N,(LIST)
C
 1380 CALL COPY (1)
      IF (LCPY.NE.KSPK(2)) GO TO 1380
      ICOL=ICOL+1
      CALL COPY (1)
      IF (LCPY.NE.KSPK(3)) GO TO 40
 1390 CALL RSTAT
      IF (L772.EQ.0) GO TO 40
      IOUT(ICOL+1)=KLR2
      ICOL=ICOL+1
      IF (NXRF.GT.MXREF) GO TO 2010
      IOUTN(NXRF)=L772
      NXRF=NXRF+1
      CALL RLIST
      CALL COPY (1)
      IF (LCPY.EQ.KSPK(2)) GO TO 1390
      IF (LCPY.EQ.KSPK(5)) GO TO 610
      GO TO 40
C
C                  ***** JTYPE = 25
C     IF ACCUMULATOR OVERFLOW (QUOTIENT, DIVIDE CHECK, END FILE, SENSE)
C
 1400 CALL COPY (2)
      ICOL=ICOL+1
      CALL COPY (11)
      ICOL=ICOL+1
      CALL COPY (8)
C
C     PROCESS TWO-WAY TRANSFER.
C
 1410 ICOL=ICOL+1
      JGOOF=20
      MILDO=-1
      IOUT(ICOL)=KLR2
      CALL RSTAT
      IF (L772.EQ.0) GO TO 40
      IF (NXRF.GT.MXREF) GO TO 2010
      IOUTN(NXRF)=L772
      NXRF=NXRF+1
      CALL RLIST
      CALL COPY (1)
      IF (LCPY.NE.KSPK(2)) GO TO 40
      CALL RSTAT
      IF (L772.EQ.0) GO TO 40
      GO TO 1360
C
C                  ***** JTYPE = 26
C     IF QUOTIENT OVERFLOW
C
 1420 CALL COPY (2)
      ICOL=ICOL+1
      CALL COPY (8)
      ICOL=ICOL+1
      CALL COPY (8)
      GO TO 1410
C
C                  ***** JTYPE = 27
C     IF(DIVIDE CHECK)
C
 1430 CALL COPY (2)
      ICOL=ICOL+1
      CALL COPY (7)
      ICOL=ICOL+1
      CALL COPY (6)
      GO TO 1410
C
C                  ***** JTYPE = 28
C     IF(END FILE  I)
C
 1440 CALL COPY (2)
      ICOL=ICOL+1
      CALL COPY (8)
      ICOL=ICOL+1
      DO 1450 I=JCOL,JMAX
           IF (JINT(I).EQ.KSPK(5)) GO TO 1460
 1450 CONTINUE
      JGOOF=20
      GO TO 40
 1460 CALL COPY (1)
      IF (LCPY.EQ.KSPK(5)) GO TO 1410
      GO TO 1460
C
C                  ***** JTYPE = 29
C     IF(SENSE LIGHT 5) 1,2
C
 1470 JGOOF=20
      CALL COPY (2)
      ICOL=ICOL+1
      CALL COPY (6)
      ICOL=ICOL+1
      CALL COPY (5)
      ICOL=ICOL+1
      CALL COPY (2)
      IF (LCPY.EQ.KSPK(5)) GO TO 1410
      GO TO 40
C
C                  ***** JTYPE = 30
C     IF(SENSE SWITCH 5) 1,2
C
 1480 CALL COPY (2)
      ICOL=ICOL+1
      CALL COPY (6)
      ICOL=ICOL+1
      CALL COPY (6)
      ICOL=ICOL+1
      CALL COPY (2)
      JGOOF=20
      IF (LCPY.EQ.KSPK(5)) GO TO 1410
      GO TO 40
C
C                  ***** JTYPE = 43
C     ELSEIF
C
 1490 IF (NIFBLK.LE.0) THEN
           IOUT(1)=KABC(3)
           CALL DIAGNO (32)
      ELSE
           ICOL=ICOL-INDENT
           ICOLSV=ICOL
      END IF
      CALL COPY (4)
      ICOL=ICOL+1
C          FALL THRU TO IF
C
C                  ***** JTYPE = 31
C     IF (ARITHMETIC) 1,2,3   OR   IF (LOGICAL) STATEMENT.
C
 1500 JGOOF=20
      CALL COPY (2)
      ICOL=ICOL+1
C                  COPY UNTIL CLOSED PARENTHESES
      CALL COPY (-1)
      IF (MEOF.GE.0) GO TO 40
      ICOL=ICOL+1
      CALL RSTAT
      IF (L772.EQ.0) GO TO 1530
C
C     STATEMENT IS    IF (ARITHMETIC) 1,2,3
C
      NCOM=0
      MILDO=-1
      CALL DLIST (MERR)
      IF (MERR.NE.0) GO TO 40
 1510 IOUT(ICOL+1)=KLR2
      ICOL=ICOL+1
      IF (NXRF.GT.MXREF) GO TO 2010
      IOUTN(NXRF)=L772
      NXRF=NXRF+1
      CALL RLIST
      CALL COPY (1)
      IF (LCPY.EQ.KSPK(2)) GO TO 1520
      IF (LCPY.NE.KERM) GO TO 40
      IF (NCOM.LE.0) GO TO 40
      IF (NCOM.EQ.1) CALL DIAGNO (18)
      MTRAN=MLGC
      GO TO 620
 1520 NCOM=NCOM+1
      IF (NCOM.GT.3) GO TO 40
      IF (NCOM.EQ.3) CALL DIAGNO (18)
      CALL RSTAT
      IF (L772.EQ.0) GO TO 40
      GO TO 1510
C
C     STATEMENT IS   IF (LOGICAL) STATEMENT
C
 1530 MLGC=0
C
C        CHECK FOR 'IF () THEN' UNLESS IT IS  ELSEIF () THEN
      IF (JTYPE.EQ.43) GO TO 1560
      I=69
      CALL KWSCAN (I,KSTC)
      IF (I.NE.69) GO TO 1560
      CALL COPY (4)
C        LOOP TO CHECK REST FOR BLANKS.
      DO 1540 I=JCOL,JMAX
           IF (JINT(I).EQ.KERM) GO TO 1550
           IF (JINT(I).NE.KBL) GO TO 1560
 1540 CONTINUE
 1550 NIFBLK=NIFBLK+1
      GO TO 610
C                   LOOK FOR FIRST SPECIAL CHARACTER.
 1560 DO 1580 LFIR=JCOL,JMAX
           JT=JINT(LFIR)
           DO 1570 IFIR=1,11
                IF (JT.EQ.KSPK(IFIR)) GO TO 300
 1570      CONTINUE
 1580 CONTINUE
      LFIR=6
      IFIR=14
      GO TO 300
C
C                  ***** JTYPE = 32
C     NAMELIST
C
 1590 JGOOF=21
      CALL COPY (8)
      ICOL=ICOL+1
      J=-1
      IF (IFIR.EQ.4) GO TO 790
      GO TO 40
C
C                  ***** JTYPE = 33
C     TYPE, WRITE, PUNCH, READ, ACCEPT.
C
 1600 JGOOF=22
      CALL COPY (NINS)
      ICOL=ICOL+1
      CALL RSTAT
      IF (L772.NE.0) GO TO 1620
C
C     HAVE WRITE  FMT,LIST
C
C            , AS IN PRINT IFT,XXX
      IF (IFIR.EQ.2) GO TO 1610
C            *, AS IN PRINT *,XXX
      IF (IFIR.EQ.8) GO TO 600
      IF (IFIR.EQ.14) GO TO 600
      GO TO 40
 1610 CALL COPY (1)
      IF (LCPY.EQ.KSPK(2)) GO TO 590
      IF (MEOF.LT.0) GO TO 1610
      GO TO 40
C
C     HAVE WRITE  12345 LIST
C
 1620 CALL RLIST
      IOUT(ICOL+1)=KLR2
      ICOL=ICOL+1
      IF (NXRF.GT.MXREF) GO TO 2010
      IOUTN(NXRF)=L772
      NXRF=NXRF+1
      IF (IFIR.EQ.2) GO TO 1610
      IF (JMAX.GT.JCOL) GO TO 40
      IMAX=ICOL
      GO TO 610
C
C                  ***** JTYPE = 34
C     SEGMENT,OVERLAY
C
 1630 NFORT=NFORT-1
      IF (NFORT.NE.0) CALL DIAGNO (14)
      CALL COPY (NINS)
      CALL HEADER
      IF (IFIR.EQ.3) GO TO 750
      GO TO 40
C                  ***** JTYPE = 35
C     PROGRAM, SUBROUTINE, FUNCTION.
C
 1640 IF (NFORT.NE.1) CALL DIAGNO (14)
      CALL COPY (NINS)
      CALL HEADER
      ICOL=ICOL+1
      IF (IFIR.EQ.3) GO TO 750
      GO TO 600
C
C
C                  ***** JTYPE = 44
C     WRITE OUTPUT TAPE
C
 1650 CALL COPY (1)
C                  ***** JTYPE = 36
C     READ INPUT TAPE
C
 1660 CALL COPY (4)
C                  CONVERT TO CORRESPONDING READ/WRITE(I,N)LIST
      JGOOF=22
      ICOL=ICOL+2
      IOUT(ICOL)=KSPK(3)
      JCOL=JCOL+1
C                  SKIP TO CHARACTER E
      DO 1670 JAVB=JCOL,JMAX
           IF (JINT(JAVB-1).EQ.KABC(5)) GO TO 1680
 1670 CONTINUE
C                  COPY UNTIL COMMA
 1680 JCOL=JAVB
 1690 CALL COPY (1)
      IF (MEOF.GE.0) GO TO 40
      IF (LCPY.NE.KSPK(2)) GO TO 1690
C                  PROCESS STATEMENT NUMBER
      CALL RSTAT
      IF (L772.NE.0) GO TO 1730
C                  VARIABLE FORMAT--NO REFERENCE
      KLASS=6
 1700 CALL COPY (1)
C                  LOOK FOR COMMA
      IF (LCPY.EQ.KSPK(2)) GO TO 1720
      IF (MEOF.LT.0) GO TO 1700
C                  NO COMMA. END WITH )
 1710 ICOL=ICOL+1
      IOUT(ICOL)=KSPK(5)
      IMAX=ICOL
      GO TO 610
C                  REPLACE , BY ) AND GO PROCESS LIST
 1720 IOUT(ICOL)=KSPK(5)
      ICOL=ICOL+1
      GO TO 600
 1730 IOUT(ICOL+1)=KLR2
      ICOL=ICOL+1
      IF (NXRF.GT.MXREF) GO TO 2010
      IOUTN(NXRF)=L772
      NXRF=NXRF+1
      CALL RLIST
      CALL COPY (1)
      IF (LCPY.EQ.KSPK(2)) GO TO 1720
      IF (LCPY.EQ.KERM) GO TO 1710
      GO TO 40
C
C
C                  ***** JTYPE = 45
C     WRITE TAPE
 1740 CALL COPY (1)
C                  ***** JTYPE = 37
C     READ TAPE
C
 1750 CALL COPY (4)
      JCOL=LAST+1
      ICOL=ICOL+2
      IOUT(ICOL)=KSPK(3)
C                  SKIP TO CHARACTER E
      DO 1760 JAVB=JCOL,JMAX
           IF (JINT(JAVB-1).EQ.KABC(5)) GO TO 1770
 1760 CONTINUE
C                  COPY UNTIL COMMA
 1770 JCOL=JAVB
 1780 CALL COPY (1)
      IF (LCPY.NE.KSPK(2)) GO TO 1780
      IOUT(ICOL)=KSPK(5)
      GO TO 590
C
C                  ***** JTYPE = 38
C     READ ( AND WRITE (
C
 1790 JGOOF=23
 1800 CALL COPY (NINS-1)
      ICOL=ICOL+1
      NLPS=-1
 1810 CALL COPY (1)
      IF (MEOF.GE.0) GO TO 40
C     LEFT PAREN MEANS START OF AN INTERNAL READ/WRITE SUBSCRIPT
      IF (LCPY.EQ.KSPK(3)) THEN
           NLPS=NLPS+1
           GO TO 1810
      END IF
C     RIGHT PAREN - COPY REST OF CARD UNLESS CLOSING SUBSCRIPT
      IF (LCPY.EQ.KSPK(5)) THEN
           IF (NLPS.LE.0) GO TO 590
           NLPS=NLPS-1
           GO TO 1810
      END IF
C     COMMA - NUMBER WILL FOLLOW UNLESS INTERNAL WRITE SUBSCRIPT
      IF (LCPY.EQ.KSPK(2)) THEN
           IF (NLPS.EQ.0) GO TO 1830
           GO TO 1810
      END IF
C     ACCEPT ANYTHING BUT = SIGN.
      IF (LCPY.NE.KSPK(1)) GO TO 1810
C
C     LAST CHARACTER WAS =.  CHECK KEYWORD FOR NUMBER FOLLOWING.
C      (SKIP FMT AND END FOR TYPE 47)
      IF (JTYPE.EQ.47) GO TO 1820
C     FMT
      IF (BAKSCN(KABC(20),KABC(13))) GO TO 1830
C     END
      IF (BAKSCN(KABC(4),KABC(14))) GO TO 1830
C     ERR
 1820 IF (.NOT.BAKSCN(KABC(18),KABC(18))) GO TO 1810
C
C     GET STATEMENT NUMBER
C
 1830 CALL RSTAT
      IF (L772.EQ.0) GO TO 1810
      IOUT(ICOL+1)=KLR2
      ICOL=ICOL+1
      IF (NXRF.GT.MXREF) GO TO 2010
      IOUTN(NXRF)=L772
      NXRF=NXRF+1
      CALL RLIST
      GO TO 1810
C
C                  ***** JTYPE = 39
C     RETURN
C
 1840 CALL COPY (6)
      MTRAN=MLGC
      GO TO 590
C
C                  ***** JTYPE = 40
C     SENSE LIGHT
C
 1850 CALL COPY (5)
      ICOL=ICOL+1
      CALL COPY (5)
      GO TO 590
C
C                  ***** JTYPE = 41
C     STOP
C
 1860 CALL COPY (4)
      MILDO=-1
      MTRAN=MLGC
      GO TO 590
C
C                  ***** JTYPE = 42
C     IF (UNIT,N) L1,L2,L3,L4
C
 1870 CALL COPY (2)
      ICOL=ICOL+1
      CALL COPY (-1)
      IF (MEOF.GE.0) GO TO 40
      ICOL=ICOL+1
      MILDO=1
      CALL DLIST (MERR)
      IF (MERR.NE.0) GO TO 40
      DO 1880 I=1,4
           CALL RSTAT
           IF (L772.EQ.0) GO TO 40
           ICOL=ICOL+1
           IOUT(ICOL)=KLR2
           IF (NXRF.GT.MXREF) GO TO 2010
           IOUTN(NXRF)=L772
           NXRF=NXRF+1
           CALL RLIST
           CALL COPY (1)
           IF (LCPY.NE.KSPK(2)) GO TO 1890
 1880 CONTINUE
      GO TO 40
 1890 IF (I.EQ.4.AND.LCPY.EQ.KERM) GO TO 620
      GO TO 40
C
C                        ***** JTYPE = 46
C     COMPLEX,  INTEGER,  REAL,  LOGICAL,  CHARACTER
C
 1900 CALL COPY (NINS)
C
C     SEE IF IT IS A FUNCTION, IF SO ADD A SPACE AFTER
      I=29
      CALL KWSCAN (I,KSTC)
      IF (I.EQ.29) THEN
           ICOL=ICOL+1
           NINS=KSTC(1)
           CALL COPY (NINS)
           GO TO 590
      END IF
C
      IF (IFIR.NE.8) GO TO 590
C          STATEMENT IS E.G. REAL*8, I.E. WITH BYTE NUMBER
C          FIRST SWALLOW ANY BLANKS BEFORE IT.
 1910 IF (JCOL.EQ.LFIR) GO TO 1920
      IF (JINT(JCOL).NE.KBL) GO TO 590
      JCOL=JCOL+1
      GO TO 1910
C
C     * WAS NEXT CHARACTER. COPY IT.
 1920 CALL COPY (1)
 1930 IF (JINT(JCOL).NE.KBL) GO TO 1940
      JCOL=JCOL+1
      GO TO 1930
C
C     PROCESS  *(*)
 1940 IF (JINT(JCOL).EQ.KSPK(3)) THEN
           CALL COPY (3)
           ICOL=ICOL+1
           GO TO 600
      END IF
      GO TO 1960
C
C     GO PAST BYTE COUNT
 1950 CALL COPY (1)
 1960 DO 1970 I=1,10
           IF (JINT(JCOL).EQ.KDIG(I)) GO TO 1950
 1970 CONTINUE
C
C     CHECK FOR INTEGER*2 FUNCTION, ETC.
      IFIR=14
      ICOL=ICOL+1
      GO TO 480
C
C                        ***** JTYPE = 47
C     OPEN, CLOSE, INQUIRE
 1980 JGOOF=31
      GO TO 1800
C
C                        ***** JTYPE = 48
C     ENDIF
 1990 NIFBLK=NIFBLK-1
      IF (NIFBLK.LT.0) THEN
           NIFBLK=0
           IOUT(1)=KABC(3)
           CALL DIAGNO (32)
      ELSE
           ICOL=ICOL-INDENT
           ICOLSV=ICOL
      END IF
      CALL COPY (3)
      ICOL=ICOL+1
      CALL COPY (2)
      GO TO 620
C
C                        ***** JTYPE = 49
C     ELSE
 2000 IF (NIFBLK.LE.0) THEN
           IOUT(1)=KABC(3)
           CALL DIAGNO (32)
      ELSE
           ICOL=ICOL-INDENT
           ICOLSV=ICOL
      END IF
      CALL COPY (NINS)
      GO TO 620
C
C     TOO MANY CROSS-REFERENCES
 2010 CALL DIAGNO (35)
      MP2=0
      GO TO 50
C
C
C
 2020 FORMAT (13X,'***',10I6,'***')
 2030 FORMAT ('0JTYPE =',I3,' IS ILLEGAL.  I AM CONFUSED AND CANNOT GO O
     1N.')
      END
      SUBROUTINE PASS2
C
C     THIS ROUTINE READS THE DATA GENERATED BY PASS1 AND WRITES AND
C     PUNCHES THE RENUMBERED DECK.
C     UNNUMBERED CONTINUE AND FORMAT STATEMENTS ARE DELETED WITHOUT
C     A DIAGNOSTIC.
C     UNREACHABLE STATEMENTS ARE DELETED IF *NO CONTINUES
C     IS IN EFFECT (MCONT=0)
C
      INCLUDE 'TIDY.INC'
      INCLUDE 'UNITS.INC'
C     SET UP DIMENSIONED ARRAY FOR EFFICIENT PRINTING
      CHARACTER*2 IOUT72(72),MINUS
      EQUIVALENCE (IOUT72(1),IOUT(1)), (MINUS,KSPK(7))
C        TABLE OF EXECUTABLE(1) OR NON-EXECUTABLE(0) BY KLASS
      INTEGER IEXFLG(12)
C         KLASS    0 1 2 3 4 5 6 7 8 9 1011
      DATA IEXFLG/0,0,0,0,1,0,1,1,0,1,1,1/
C
      IF (MP2.EQ.0.OR.NRT1.LE.0) RETURN
C
C     MOVE LIST OF NEW STATEMENT NUMBERS FROM TEMP STORAGE
C
      DO 10 I=1,NDEF
           LOCDEF(I)=NEWNUM(I)
 10   CONTINUE
C
C     SET INITIAL CONSTANTS.
C
      IPASS=2
      MPAGE=0
      NREC=0
      NTRAN=0
      IMAX=1326
C
 20   IF (NRT1.EQ.0) GO TO 230
      IOLD=IMAX
      CALL IOSYS1 (4,KILI,SERIAL,IOUT)
C                  BLANK OUT REMAINDER OF PREVIOUS CARD, IF NECESSARY.
      IF (IMAX.GE.IOLD) GO TO 40
      INEW=IMAX+1
      DO 30 I=INEW,IOLD
           IOUT(I)=KBL
 30   CONTINUE
C                  LOOK FOR $  (FOR WARNING FLAG)
 40   IF (KLASS.LE.1) GO TO 70
      DO 50 I=7,IMAX
           IF (IOUT(I).EQ.KSPK(10)) GO TO 60
 50   CONTINUE
      GO TO 70
 60   IF (MPRIN.EQ.0) WRITE (OUTFIL,270) IOUT72
      WRITE (OUTFIL,260)
 70   NRT1=NRT1-1
      IF (NREC.NE.0) GO TO 80
      CALL HEADER
      IF (MPRIN.NE.0) CALL PAGE (0)
C
 80   IF (MDEB.NE.0) WRITE (OUTFIL,240) KILI,SERIAL
      I=KLASS+1
C            0   1   2   3   4   5   6   7   8   9   10  11
      GO TO (20,160,90,160,130,130,130,100,200,160,100,130),I
C                KLASS  DESCRIPTION
C                  0.   CONTROL CARD
C                  1.   COMMENT
C                  2.   HEADER
C                  3.   NO STATEMENT NO ALLOWED (NON-EXECTUABLE)
C                  4.   CONTINUE
C                  5.   FORMAT STATEMENT.
C                  6.   STATEMENT NO. ALLOWED, NO REFERENCES
C                  7.   REFERENCES PRESENT, STATEMENT NO. ALLOWED.
C                  8.   END
C                  9.   INTRODUCTORY
C                  10.  DO
C                  11.  ELSE,ENDIF,ELSEIF, UNRECOGNIZED
C                       (TRANSFER CAN GET HERE REGARDLESS OF LABEL)
C
C     KLASS 0.   CONTROL CARD
C             RESERVED FOR FUTURE DEVELOPMENT.
C
 90   IF (MPRIN.NE.0) GO TO 160
      CALL PAGE (2)
      IF (MPUN.NE.0) WRITE (OUTFIL,310) (KIM(I,1),I=1,72)
      IF (MPUN.EQ.0) WRITE (OUTFIL,320) (KIM(I,1),I=1,72)
      GO TO 160
C
C     DO REFERENCES.
C
 100  DO 110 I=7,IMAX
           JINT(I)=IOUT(I)
           IOUT(I)=KBL
 110  CONTINUE
      ICOL=6
      JCOL=7
      JMAX=IMAX
      I=1
 120  IF (JINT(JCOL).EQ.KLR2) THEN
C     RENUMBER A REFERENCE
           L772=IOUTN(I)
           JCOL=JCOL+1
           I=I+1
           CALL RENUM
      ELSE
C     COPY A CHARACTER
           ICOL=ICOL+1
           IOUT(ICOL)=JINT(JCOL)
           JCOL=JCOL+1
      END IF
      IF (JCOL.LE.JMAX) GO TO 120
      IMAX=ICOL
C
C          DO STATEMENT NUMBER
C
 130  L772=L15
      ICOL=0
      CALL RENUM
C        PRINT ALL LABELLED STATEMENTS, ELSE, ELSEIF, ENDIF
      IF (L772.NE.0.OR.KLASS.EQ.11) GO TO 150
C                 DELETE ALL UNLABELLED CONTINUES AND FORMATS
      IF (KLASS.EQ.4.OR.KLASS.EQ.5) GO TO 140
C           PUNCH IF THERE IS A PATH TO THIS STATEMENT
      IF (NTRAN.NE.-1) GO TO 160
C                 *CONTINUE MEANS ALL OTHER KLASSES ARE OK
      IF (MCONT.NE.0) GO TO 160
C                 PUNCH NON-EXECUTABLE STATEMENTS
      IF (IEXFLG(KLASS+1).EQ.0) GO TO 160
 140  IF (MDEB.EQ.0) GO TO 20
      WRITE (OUTFIL,250) KLASS
      GO TO 20
C
C     REMEMBER THAT THIS STATEMENT HAS A PATH TO IT
C
 150  NTRAN=0
C
C     WRITE  (PUNCH) NEW STATEMENT.
C
 160  CALL KIMPAK
      DO 190 J=1,NCD
           NREC=NREC+KD79
C
C     IF NO SERIAL, DO NOT PRINT TRAILING BLANKS.
           IF (MSER.EQ.0) THEN
                N72=72
                DO 170 I=72,1,-1
                     IF (KIM(I,J).NE.KBL) THEN
                          N72=I
                          GO TO 180
                     END IF
 170            CONTINUE
           END IF
 180       IF (MPRIN.NE.0) THEN
                CALL PAGE (1)
                IF (MSER.LT.0) WRITE (OUTFIL,270) (KIM(I,J),I=1,72),
     1           KOL73,NREC
                IF (MSER.EQ.0) WRITE (OUTFIL,270) (KIM(I,J),I=1,N72)
                IF (MSER.GT.0) WRITE (OUTFIL,280) (KIM(I,J),I=1,72),
     1           SERIAL
           END IF
           IF (MPUN.NE.0) THEN
                NPUN=NPUN+1
                IF (MSER.LT.0) WRITE (PUNFIL,290) (KIM(I,J),I=1,72),
     1           KOL73,NREC
                IF (MSER.EQ.0) WRITE (PUNFIL,290) (KIM(I,J),I=1,N72)
                IF (MSER.GT.0) WRITE (PUNFIL,300) (KIM(I,J),I=1,72),
     1           SERIAL
           END IF
C
 190  CONTINUE
C           REMENBER IF THS IS AN UNCONDITIONAL TRANSFER
      IF (MTRAN.EQ.-1) NTRAN=-1
      GO TO 20
C
C     END STATEMENT.
C
 200  NREC=NREC+KD79
C
C     IF NO SERIAL, DO NOT PRINT TRAILING BLANKS.
      IF (MSER.EQ.0) THEN
           DO 210 I=72,1,-1
                IF (IOUT72(I).NE.KBL) THEN
                     N72=I
                     GO TO 220
                END IF
 210       CONTINUE
      END IF
 220  IF (MPRIN.NE.0) THEN
           CALL PAGE (1)
           IF (MSER.LT.0) WRITE (OUTFIL,270) IOUT72,KOL73,NREC,MINUS
           IF (MSER.EQ.0) WRITE (OUTFIL,270) (IOUT72(I),I=1,N72)
           IF (MSER.GT.0) WRITE (OUTFIL,280) IOUT72,SERIAL
      END IF
      IF (MPUN.NE.0) THEN
           NPUN=NPUN+1
           IF (MSER.LT.0) WRITE (PUNFIL,290) IOUT72,KOL73,NREC,MINUS
           IF (MSER.EQ.0) WRITE (PUNFIL,290) (IOUT72(I),I=1,N72)
           IF (MSER.GT.0) WRITE (PUNFIL,300) IOUT72,SERIAL
      END IF
 230  RETURN
C
C
C
 240  FORMAT (' KLASS',I2,' JTYPE',I3,' L15',I5,' IMAX',I4,' TRAN',I2,'
     1NXRF: ',I4/'  MEX=',I4,' ICOLSV = ',I3,' SERIAL:',8A2)
 250  FORMAT (' DELETING A KLASS=',I1,' STATEMENT')
 260  FORMAT ('+',110X,'$ $ $ $ $')
 270  FORMAT (7X,75A1,I4,A1)
 280  FORMAT (7X,80A1)
 290  FORMAT (75A1,I4,A1)
 300  FORMAT (80A1)
 310  FORMAT ('0',15X,72A1,5X,'--PUNCHED')
 320  FORMAT ('0',15X,72A1,5X,'--NOT PUNCHED')
      END
      SUBROUTINE RDIR
C
C     THIS SUBROUTINE GENERATES A REFERENCE DIRECTORY OF STATEMENT
C     NUMBERS SHOWING THE OLD STATEMENT NUMBER, ITS LOCATION IN THE
C     ROUTINE, AND THE NEW STATEMENT NUMBER GENERATED BY TIDY.
C
      INCLUDE 'TIDY.INC'
      INCLUDE 'UNITS.INC'
      DIMENSION INDEX(1000)
      IF (NDEF.LE.0) RETURN
      CALL PAGE (-(8+NDEF))
      CALL PAGE (4)
      WRITE (OUTFIL,50)
      DO 10 I=1,NDEF
 10   INDEX(I)=I
C
C     ADDRESS-SORT STATEMENT NUMBERS
C
      IF (NDEF.EQ.1) GO TO 35
         M=NDEF+1
 20      NR=0
         M=M-1
         DO 30 I=2,M
            J=INDEX(I-1)
            K=INDEX(I)
            IF (LDEF(J).LE.LDEF(K)) GO TO 30
               INDEX(I-1)=K
               INDEX(I)=J
               NR=1
 30      CONTINUE
         IF (NR.NE.0) GO TO 20
C
C     WRITE  DIRECTORY
C
 35   DO 40 I=1,NDEF
         NW1=NEWNUM(I)
         NO1=LDEF(I)
         LO1=LOCDEF(I)
         J=INDEX(I)
         NW2=NEWNUM(J)
         NO2=LDEF(J)
         LO2=LOCDEF(J)
         CALL PAGE (1)
         WRITE (OUTFIL,60) NW1,NO1,LO1,NO2,LO2,NW2
 40   CONTINUE
      CALL PAGE (3)
      WRITE (OUTFIL,70)
      RETURN
C
C
 50   FORMAT (1H0,32X,26HSTATEMENT NUMBER DIRECTORY/
     1 1H0,22X,15HNEW   OLD   LOC,12X,18HOLD   LOC      NEW/1X)
 60   FORMAT (21X,I5,3H = ,I5,2H,(,I4,2H).,8X,I5,2H,(,I4,4H) = ,I5,1H.)
 70   FORMAT (1H0,20X,53HOLD STATEMENT NUMBERS NOT APPEARING IN THIS DIR
     1ECTORY/21X,42HWERE NOT REFERENCED AND HENCE ARE DELETED.)
      END
      SUBROUTINE READER
C     THIS ROUTINE READS CARDS ONE BY ONE, UNTIL IT FINDS A
C     NON-BLANK ONE, THEN RETURNS.   IF IT FINDS AN END-OF-FILE, OR IF
C     IQUIT IS NON-ZERO, IT GENERATES A *STOP CARD.
      INCLUDE 'TIDY.INC'
      INCLUDE 'UNITS.INC'
      IF (IQUIT.NE.0) GO TO 30
 10   READ (INFILE,50,END=30) KBUFF
      IF (KBUFF(7).NE.KBL) GO TO 40
      DO 20 I=1,72
      IF (KBUFF(I).NE.KBL) GO TO 40
 20   CONTINUE
C                            BLANK CARD. PRINT AND GET ANOTHER.
      CALL PAGE (1)
      WRITE (OUTFIL,60)
      GO TO 10
C                            NO MORE INPUT
 30   IQUIT = 1
      KBUFF(1)=KSPK(8)
      KBUFF(2)=KABC(19)
      KBUFF(3)=KABC(20)
      KBUFF(4)=KABC(15)
      KBUFF(5)=KABC(16)
      DO 35 I=6,72
        KBUFF(I)=KBL
 35   CONTINUE
      L15=0
      L25=0
 40   RETURN
C
 50   FORMAT (80A1)
 60   FORMAT (35X,23H( B L A N K   C A R D ))
      END
      SUBROUTINE REDSTR (LU, LIST, NCHR, IRF, NR, IOP)
      CHARACTER*2 LIST (NCHR)
      DIMENSION IRF(NR)
C
C     WRITE OUT STRING AS SERIES OF 508-(CHAR*2) RECS
C      (APPARENTLY 1024 BYTES IS MAGIC NUMBER FOR PROFORT, AND EACH REC
C       HAS 4-BYTE HEADER AND TRAILER)
C
      DATA MXCHR/508/, MXINT/254/
      NL = 1
      MU = MXCHR
   10 NU = MIN0(NCHR,MU)
      NB = NU-NL+1
      CALL IOSTR (LU, LIST(NL), NB, IOP)
      IF (NCHR.GT.NU) THEN
        MU=MU+MXCHR
        NL=NU+1
        GO TO 10
      ENDIF
C
C     NOW DO THE CROSS-REFERENCE TABLE (253 REFS?!)
      NL = 1
      MU = MXINT
   20 NU = MIN0(NR,MU)
      NB = NU-NL+1
      CALL IONUM (LU, IRF(NL), NB, IOP)
      IF (NR.GT.NU) THEN
        MU=MU+MXINT
        NL=NU+1
        GO TO 20
      ENDIF
C
      RETURN
      END
      SUBROUTINE IOSTR (LU, LIST, NB, IOP)
C
C     READ OR WRITE A STRING
C
      CHARACTER*2 LIST (NB)
      IF (IOP.EQ.1) THEN
      WRITE (LU) LIST
      ELSE
      READ (LU) LIST
      ENDIF
      RETURN
      END
      SUBROUTINE IONUM (LU, IRF, NR, IOP)
C
C     READ OR WRITE AN INTEGER ARRAY.
C
      DIMENSION IRF(NR)
      IF (IOP.EQ.1) THEN
      WRITE (LU) IRF
      ELSE
      READ (LU) IRF
      ENDIF
      RETURN
      END
      SUBROUTINE RENUM
C
C     THIS SUBROUTINE INSPECTS THE OLD STATEMENT NUMBER IN L772 AND
C     INSERTS THE NEW NUMBER CORRESPONDING TO L772 IN IOUT STARTING AT
C     ICOL+1.  ON EXIT, L772 CONTAINS THE NEW STATEMENT NUMBER.
C
      INCLUDE 'TIDY.INC'
C
C     SEARCH DEFINED STATEMENT TABLE FOR L772.
C
      IF (NDEF.EQ.0) GO TO 15
         DO 10 I=1,NDEF
         IF (LDEF(I).EQ.L772) GO TO 20
 10      CONTINUE
C
C     NOT IN STATEMENT NUMBER LIST. DELETE NUMBER.
C
 15   L772=0
      RETURN
C
C     ASSEMBLE NEW STATEMENT NUMBER.
C
 20   I=NEWNUM(I)
      L772=I
      DO 30 J=1,5
      IT=I/10
      K=I-IT*10
      NTEMP(J)=KDIG(K+1)
      I=IT
      IF (I.EQ.0) GO TO 40
 30   CONTINUE
      J=5
C
C     INSERT STATEMENT NUMBER DIGITS.
C
 40   IF (ICOL.NE.0) GO TO 70
C                            COLUMNS 1-5
         DO 50 I=1,5
 50      IOUT(I)=KBL
         IF (MRIT.LT.0) GO TO 60
C                            LEFT ADJUST TO COLUMN MRIT
         ICOL=MIN0(MRIT,6-J)
         ICOL=IDIM(ICOL,1)
         GO TO 70
C                            RIGHT ADJUST TO COLUMN -MRIT
 60      ICOL=IDIM(-MRIT,J)
 70   ICOL=ICOL+1
      IOUT(ICOL)=NTEMP(J)
      J=J-1
      IF (J.NE.0) GO TO 70
      RETURN
      END
      SUBROUTINE RLIST
C
C     THIS SUBROUTINE UPDATES THE REFERENCED STATEMENT NUMBER LIST.
C     L772 CONTAINS THE REFERENCED STATEMENT NUMBER.
C
      INCLUDE 'TIDY.INC'
      IF (L772.EQ.0) RETURN
C                  POOR PROGRAMMING PRACTICE.
      IF (L772.EQ.L15) CALL DIAGNO (18)
      IF (NREF.EQ.0) GO TO 20
      IF (NREF.LT.0) RETURN
      DO 10 I=1,NREF
      IF (LREF(I).EQ.L772) RETURN
 10   CONTINUE
C
C     ADD REFERENCED STATEMENT TO TABLE.
C
 20   NREF=NREF+1
      IF (NREF.GT.1000) GO TO 30
      LREF(NREF)=L772
      RETURN
C
C                  TABLE FULL
 30   CALL DIAGNO (7)
      NREF=-1
      MP2=0
      RETURN
      END
      SUBROUTINE RSTAT
C
C     THIS SUBROUTINE GETS THE STATEMENT NUMBER REFERENCED AT LOCATION
C     JCOL AND PUTS IT IN L772.  JCOL IS LEFT SET AT THE LOCATION OF THE
C     NEXT SYMBOL ON JINT.
C
      INCLUDE 'TIDY.INC'
      L772=0
      IF (JCOL-JMAX) 20,20,10
 10   JCOL=JMAX
      RETURN
C
 20   I=JCOL
      DO 50 JCOL=I,JMAX
      IF (JINT(JCOL).EQ.KBL) GO TO 50
      DO 30 J=1,10
      IF (JINT(JCOL).EQ.KDIG(J)) GO TO 40
 30   CONTINUE
      RETURN
C
 40   L772=L772*10+J-1
 50   CONTINUE
      JCOL=JMAX
      LCPY=KERM
      MEOF=0
      RETURN
      END
      SUBROUTINE SKARD
C
C     super-card input routine.
C     this routine reads fortran statements with up to 19 continuation
C     cards and packs the statement into the super-card --JINT--.
C
      INCLUDE 'tidy.inc'
      INCLUDE 'units.inc'
      LOGICAL RSHFT
      CHARACTER*2 KB1,KB6,KZERO,KC,KSTAR,KDOL,KPER,KUPPER
      EQUIVALENCE (KB1,KBUFF(1)), (KB6,KBUFF(6))
      EQUIVALENCE (KZERO,KDIG(1)), (KC,KABC(3)), (KSTAR,KSPK(8))
      EQUIVALENCE (KDOL,KSPK(14)), (KPER,KSPK(9))
C
      RSHFT=.TRUE.
      K72=72
C
      JMAX=1
      DO 30 I=1,K72
           IF (KBUFF(I).EQ.KTAB) THEN
                IF (I.LT.7.AND.RSHFT) THEN
C     blank rest of number field
                     DO 10 L=JMAX,6
                          JINT(L)=KBL
 10                  CONTINUE
                     JMAX=7
                     RSHFT=.FALSE.
C     blank the serial field
                     DO 20 L=1,8
                          SERIAL(L)=KBL
 20                  CONTINUE
C     SET LINE LENGTH TO 80
                     K72=80
                     GO TO 30
                ELSE
C     tabs past column 6 translate to spaces with f77
                     KBUFF(I)=KBL
                END IF
           END IF
           JINT(JMAX)=KBUFF(I)
           JMAX=JMAX+1
 30   CONTINUE
C
C     grab existing serial number if needed.
      IF (MSER.NE.0.AND.RSHFT) THEN
           DO 40 I=1,8
                SERIAL(I)=KBUFF(I+72)
 40        CONTINUE
      END IF
C
C     skip page header if not beginning.
      IF (KOUNT.LE.0) THEN
           CALL HEADER
           IF (MLIST.NE.0) CALL PAGE (0)
      END IF
C
      MEOF=-1
      KOUNT=KOUNT+1
      NREC=NREC+1
      IF (MLIST.NE.0) THEN
           CALL PAGE (1)
           WRITE (OUTFIL,120) NREC,KBUFF
      END IF
C
      NXRF=2
C
C     look for continuation cards and transfer them to iout via kbuff.
C
      DO 80 J=2,20
           CALL READER
C     ampersand means continuation.
           IF (KB1.EQ.KAMPR) THEN
                K7=2
                K72=80
                GO TO 60
           ELSE
                K7=7
                K72=72
           END IF
C     check for a tab in number field. If so, not a continuation
           DO 50 I=1,6
                IF (KBUFF(I).EQ.KTAB) GO TO 90
 50        CONTINUE
C     check for continuation or comments
           KB1=KUPPER(KB1)
           IF (KB1.EQ.KC) GO TO 90
           IF (KB1.EQ.KSTAR) GO TO 90
           IF (KB1.EQ.KDOL) GO TO 90
           IF (KB1.EQ.KPER) GO TO 90
           IF (KB6.EQ.KBL) GO TO 90
           IF (KB6.EQ.KZERO) GO TO 90
C
 60        DO 70 I=K7,K72
                IF (KBUFF(I).NE.KTAB) THEN
                     JINT(JMAX)=KBUFF(I)
                ELSE
                     JINT(JMAX)=KBL
                END IF
                JMAX=JMAX+1
 70        CONTINUE
           IF (MLIST.EQ.0) GO TO 80
           CALL PAGE (1)
           WRITE (OUTFIL,130) KBUFF
 80   CONTINUE
C
C     nineteen continuation cards.  load empty buffer before exiting.
C
      J=21
      CALL READER
C
C     locate last non-blank column in card and exit.
C
 90   NCD=J-1
      JMAX=JMAX-1
      DO 100 I=JMAX,1,-1
           IF (JINT(I).NE.KBL) THEN
                JMAX=I
                GO TO 110
           END IF
 100  CONTINUE
 110  JINT(JMAX+1)=KERM
      RETURN
C
C
 120  FORMAT (1X,I4,2X,80A1)
 130  FORMAT (7X,80A1)
      END
      SUBROUTINE USRCON
C
C     READS A SEPARATE FILE OF TIDY CONTROL CARDS SO USER DOES NOT
C     HAVE TO EDIT THEM INTO SOURCE FILE.
C
      INCLUDE 'TIDY.INC'
      INCLUDE 'UNITS.INC'
C
      WRITE (OUTFIL,30)
C
 10   READ (USRFIL,40,END=20) (JINT(I),I=1,75)
      WRITE (OUTFIL,50) (JINT(I),I=1,75)
      IF (JINT(1).NE.KSPK(8)) THEN
           WRITE (OUTFIL,60)
      ELSE
           JMAX=75
           CALL CONTRL
      END IF
      GO TO 10
C
 20   CLOSE (USRFIL,STATUS='KEEP')
      RETURN
C
C
 30   FORMAT ('1      ** T I D Y **  SPECIAL CONTROL CARD FILE')
 40   FORMAT (75A1)
 50   FORMAT (1H0,75A1)
 60   FORMAT (' CONTROL CARDS MUST HAVE * IN COLUMN 1.')
      END