home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS - Coast to Coast / simteldosarchivecoasttocoast2.iso / fortran / tidy64.zip / TIDY.FOR < prev    next >
Text File  |  1994-02-05  |  167KB  |  5,433 lines
  1.       PROGRAM TIDY
  2. C
  3. C     ==================================================================
  4. C     *                                                                *
  5. C     *                    * * *   T I D Y   * * *                     *
  6. C     *                                                                *
  7. C     *      A FORTRAN PROGRAM TO RENUMBER AND OTHERWISE CLEAN UP      *
  8. C     *             OLD AND TIRED FORTRAN SOURCE PROGRAMS.             *
  9. C     *                                                                *
  10. C     *                   IN ADDITION TO RENUMBERING,                  *
  11. C     *             TIDY PROVIDES A LIMITED SET OF FORTRAN             *
  12. C     *                          DIAGNOSTICS.                          *
  13. C     *                                                                *
  14. C     *                 ANSI FORTRAN  (ANSI X3.9-1978)                 *
  15. C     *                                                                *
  16. C     *                                                                *
  17. C     *       CONVERTED TO IBM (RYAN-McFARLAND) PROFESSIONAL FORTRAN   *
  18. C     *       BY AL STANGENBERGER, DEPT. OF FORESTRY, U.C. BERKELEY    *
  19. C     *                                                                *
  20. C     ==================================================================
  21. C
  22. C      Copyright (C) 1989, The Regents of the University of California
  23. C                          All Rights Reserved
  24. C
  25. C      THE REGENTS OF THE UNIVERSITY OF CALIFORNIA MAKE NO REPRESENTA-
  26. C      TION OR WARRANTIES WITH RESPECT TO THE CONTENTS HEREOF AND
  27. C      SPECIFICALLY DISCLAIM ANY IMPLIED WARRANTIES OF MERCHANTABILITY
  28. C      OR FITNESS FOR ANY PARTICULAR PURPOSE.
  29. C
  30. C      Further, the Regents of the University of California reserve the
  31. C      right to revise this software and/or documentation and to make
  32. C      changes from time to time in the content hereof without obliga-
  33. C      tion of the Regents of the University of California to notify
  34. C      any person of such revision or change.
  35. C
  36. C      PERMISSION TO COPY AND DISTRIBUTE THIS PROGRAM, AND TO MAKE
  37. C      DERIVATIVE WORKS HEREFROM, IS GRANTED PROVIDED THAT THIS COPY-
  38. C      RIGHT NOTICE IS RETAINED IN ALL SOURCE CODE AND USER MANUALS.
  39. C
  40. C     ==================================================================
  41. C     *                                                                *
  42. C     *                   **************************                   *
  43. C     *                  *         PROGRAM          *                  *
  44. C     *                 *     AND SUBROUTINES BY     *                 *
  45. C     *                *        HARRY M MURPHY        *                *
  46. C     *               *  AIR FORCE WEAPONS LABORATORY  *               *
  47. C     *                *   KIRTLAND AIR FORCE BASE    *                *
  48. C     *                 *         NEW MEXICO         *                 *
  49. C     *                  *         1 9 6 6          *                  *
  50. C     *                   **************************                   *
  51. C     *                                                                *
  52. C     *       TIDY ACCEPTS ASA FORTRAN WITH 19 CONTINUATION CARDS      *
  53. C     *     AS WELL AS SOME IBM AND CDC DIALECT FORTRAN STATEMENTS     *
  54. C     *                                                                *
  55. C     *       THIS VERSION MODIFIED FOR USE AT LRL BERKELEY BY         *
  56. C     *       GERRY TOOL (1967). (STILL CDC/6600)                      *
  57. C     *                                                                *
  58. C     *      THIS PROGRAM HAS BEEN REVISED FOR IBM 360/67 BY ALICE     *
  59. C     *      V BARLOW, NASA AMES, SUMMER 1972                          *
  60. C     *                                                                *
  61. C     *       ADDITIONS AND REWORKING BY ROGER CHAFFEE, LRL BERKELEY   *
  62. C     *       AND SLAC COMPUTATIONS RESEARCH GROUP, 1968-1982          *
  63. C     ==================================================================
  64. C
  65. C
  66. C  INPUT/OUTPUT
  67. C     FUNCTION          FORTRAN UNIT   CURRENT VALUE
  68. C      CONSOLE OUTPUT     STDERR            0
  69. C      CONSOLE INPUT      STDIN             0  (5 for UNIX systems)
  70. C      CONTROL CARD       USRFIL            3
  71. C      INPUT              INFILE            4
  72. C      LIST OUTPUT        OUTFIL            6
  73. C      CARD OUTPUT        PUNFIL            8
  74. C      SCRATCH(NORMAL)    SCFIL1            1
  75. C      SCRATCH(FORMATS)   SCFIL2            2
  76. C      SCRATCH(COMMENTS)  SCFIL3            9
  77. C
  78. C     *****************************************************************
  79. C     I N S T A L L A T I O N   N O T E S
  80. C
  81. C     1.  INCLUDE statements are used to incorporate common block
  82. C         definitions into most subroutines.  Check syntax as these
  83. C         statements are system-dependent.
  84. C
  85. C     2.  CHARACTER SET SPECIFICITY -
  86. C         The code for horizontal tab differs in EBCDIC and ASCII.
  87. C         This value is set (KTAB) in this routine. Fix as needed.
  88. C
  89. C     3.  Interactive file opening:  Subroutine PCTIDY interactively
  90. C         opens all data and scratch files by calling subroutine OPFIL.
  91. C         This routine was written for the IBM (Ryan-McFarland)
  92. C         Professional Fortran compiler, and may not work with other
  93. C         compilers (it does work with f77 on 4.3 BSD UNIX).
  94. C
  95. C         Subroutine OPFIL uses function DOSDEV to determine if a file
  96. C         name is that of a MS-DOS reserved device.  Non MS-DOS systems
  97. C         should delete the call to DOSDEV in subroutine OPFIL.
  98. C
  99. C         The entire interactive part of the program can be deleted
  100. C         if not appropriate for your operating system.
  101. C         Delete the call to PCTIDY below, and also delete subroutines
  102. C         PCTIDY, OPFIL, and DOSDEV.
  103. C
  104. C         Aside from these factors, the rest of the program is
  105. C         fairly standard Fortran-77.
  106. C
  107. C
  108. C     NOTES:
  109. C
  110. C     IN SUBROUTINE HOLSCN, HOLLERITH CHARACTERS ARE CHANGED
  111. C     SO THEY WON-T BE RECOGNIZED BY ANY OTHER TEST BY
  112. C     CHANGING SECOND CHARACTER TO '@'
  113. C
  114. C     SUBROUTINES HOLSCN AND CONTRL INVOKE FUNCTION KUPPER TO CONVERT
  115. C     LOWER-CASE ALPHABETIC CHARACTERS TO UPPER CASE (EXCEPT FOR
  116. C     HOLLERITH STRINGS).
  117. C
  118. C     THE CHARACTER $ IS TREATED AS AN ALPHA IN IBM FORTRAN.
  119. C     THE DATA STATEMENT FOR THE SPECIAL CHARACTERS, KSPK, HAS
  120. C     BEEN CHANGED SO THAT $ IS NOT RECOGNIZED AS A SPECIAL
  121. C     CHARACTER.  THIS DATA STATEMENT SHOULD BE CHANGED BACK
  122. C     ON NON-IBM SYSTEMS.
  123. C
  124. C     SUBROUTINE REDSTR IS SET UP TO ACCOMMODATE AN APPARENT BUG
  125. C     IN THE RYAN-MCFARLAND PROFESSIONAL FORTRAN COMPILER, THAT
  126. C     UNFORMATTED SEQUENTIAL RECORDS SEEM TO BE LIMITED TO 1024 BYTES.
  127. C     SINCE EACH RECORD HAS A 4-BYTE HEADER AND TRAILER, WRITES 508
  128. C     CHARACTER*2 ELEMENTS, OR 254 INTEGER*4 PER RECORD.  THIS MAY
  129. C     VARY FOR OTHER COMPILERS.
  130. C
  131. C
  132. C  INTERNAL FLAGS (JUST A LIST.  WHERE ELSE TO PUT IT...)
  133. C     MANSI =  0 FLAG ALL NON-ANSI (FORTRAN-77) STATEMENTS
  134. C           =  1 DO NOT FLAG NON-ANSI STATEMENTS
  135. C     MP2   =  1 DO PASS2
  136. C           =  0 NO PASS 2
  137. C     MCOL  = -1 COLLECT FORMAT STATEMENTS AT END
  138. C           =  0 LEAVE THEM IN PLACE
  139. C     MILDO = -1 IF DO-TERMINATOR ALLOWED BUT NON-STANDARD
  140. C           =  0 IF DO-TERMINATOR ALLOWED
  141. C           = +1 IF DO-TERMINATOR FORBIDDEN
  142. C     MCONT =  0 REMOVE CONTINUE CARDS AND DOUBLE BRANCHES
  143. C           =  1 LEAVE THEM
  144. C     MTRAN = -1 CURRENT CARD IS AN UNCONDITIONAL BRANCH
  145. C           =  0 CURRENT CARD NOT NECESSARILY A BRANCH
  146. C     NTRAN =    SAME AS MTRAN, BUT REFERS TO PREVIOUS CARD
  147. C     MLGC  = -1 NORMAL STATEMENT
  148. C           =  0 STATEMENT IS CONTROLLED BY A LOGICAL IF
  149. C     MRIT  =  N LEFT ADJUST TO COLUMN N
  150. C           = -N RIGHT ADJUST TO COLUMN N
  151. C     MDEB  =  0 *NODEBUG
  152. C           =  1 *DEBUG
  153. C     KD15  =    STATEMENT INCREMENT (*STAT=...)
  154. C     KB15  =    STATEMENT BASE (*BASE=...)
  155. C     MPUN  =  0 NO PUNCH OUTPUT
  156. C           =  1 MAKE PUNCH OUTPUT
  157. C     KPUN       SAVES *CARD/*NOCARD (1/0) FOR MPUN VALUE
  158. C     MLIST = -1 (*LIST) LIST PASS 1
  159. C           =  0 (*NOLIST) DONT
  160. C     KPRIN =  1 (*LIST=2) LIST PASS 2
  161. C           =  0 (*NOLIST=2) DONT
  162. C     MPRIN =    KPRIN AT START OF ROUTINE. MAY CHANGE IF ERROR
  163. C                  AT START OF PASS1.
  164. C     KOUNT      COUNTS CARDS IN FOR CURRENT ROUTINE.
  165. C     IQUIT =  0 UNTIL INPUT ENDFILE IS FOUND IN READER.
  166. C           =  1 THEREAFTER
  167. C     MSTOP =  0 NORMALLY
  168. C           = -1 FOR *STOP CARD FOUND--TIME TO FINISH UP
  169. C           =  1 FOR STOP NOW.
  170. C
  171. C
  172. C     ******************************************************************
  173. C
  174.       INCLUDE 'TIDY.INC'
  175.       INCLUDE 'UNITS.INC'
  176.       LOGICAL DOUSER,SCDISK
  177.       COMMON/TDYVER/VERNUM
  178.       CHARACTER*30 VERNUM
  179. C
  180.       DOUSER=.TRUE.
  181. C
  182. C     SCDISK .TRUE. ALLOWS USER TO SPECIFY DISK TO HOLD SCRATCH FILES.
  183. C          FOR UNIX SYSTEMS, SHOULD SET TO .FALSE.
  184.       SCDISK=.TRUE.
  185. C
  186. C     VALUE FOR TAB AS ASCII
  187.       KTAB = KBL
  188.       KTAB(1:1)=CHAR(9)
  189. C     VALUE FOR TAB AS EBCDIC
  190. C     KTAB(1:1)=CHAR(5)
  191. C
  192. C     FOR NON-INTERACTIVE USE, DELETE CALL TO PCTIDY
  193.       CALL PCTIDY (DOUSER,SCDISK)
  194. C
  195. C     INITIALIZE PROGRAM
  196.       CALL INITDY
  197. C     ADJUST ROUTINE NUMBER - PASS1 WILL INCREMENT IT.
  198.       NROUT = NROUT-1
  199. C
  200. C     PROCESS USER CONTROL CARD FILE.
  201.       IF (DOUSER) CALL USRCON
  202. C
  203.       CALL READER
  204.  10   CALL PASS1
  205.       IF (MSTOP.NE.0) THEN
  206.          IF (MSTOP.GT.0) GO TO 20
  207.          IF (KOUNT.LE.0) GO TO 20
  208.       ENDIF
  209.       CALL EDIT
  210.       IF (MP2.EQ.0) GO TO 10
  211.       IF (MREF.NE.0) CALL RDIR
  212.       CALL PASS2
  213.       IF (IQUIT.NE.0) GO TO 20
  214.       IF (MSTOP.EQ.0) GO TO 10
  215. C                            ALL DONE
  216.  20   CALL IOSY11
  217.       CALL IOSY21
  218.       IF (NMSG.GT.0) THEN
  219.             WRITE (OUTFIL,60) NMSG
  220.       ELSE
  221.             WRITE (OUTFIL,70)
  222.       ENDIF
  223.       WRITE (OUTFIL,80) NPUN, VERNUM
  224.       LEVEL = LERR
  225.       IF (LEVEL.GE.2) STOP 8
  226.       IF (LEVEL.EQ.1) STOP 4
  227.       IF (MDEB.EQ.0) THEN
  228.            CLOSE (SCFIL1,STATUS='DELETE')
  229.            CLOSE (SCFIL2,STATUS='DELETE')
  230.       END IF
  231.       STOP
  232. C
  233.  60   FORMAT ( '0W A R N I N G .',I5,  ' DIAGNOSTIC MESSAGES HAVE BEEN G
  234.      1ENERATED IN THIS TIDY RUN.')
  235.  70   FORMAT (  '0NO DIAGNOSTIC MESSAGES WERE GENERATED DURING THIS TIDY
  236.      1 RUN.')
  237.  80   FORMAT ('0',I5, ' CARDS WERE PUNCHED.'/  '0',A/'1')
  238.       END
  239.       BLOCK DATA MISDAT
  240. C
  241. C     THIS BLOCK DATA CONTAINS MISCELLANEOUS DATA STATEMENTS FOR TIDY.
  242. C
  243. C     VERSION 6.2 MODIFICATION -----------------------------------------
  244. C     VARIABLES WHICH ARE CONTROLLED BY SUBROUTINE CONTRL ARE SET IN
  245. C     SUBROUTINE INITDY.
  246. C
  247.       INCLUDE 'TIDY.INC'
  248.       INCLUDE 'UNITS.INC'
  249.       COMMON/TDYVER/VERNUM
  250.       CHARACTER*30 VERNUM
  251. C
  252. C     /ALPHA/
  253.       DATA KBL,KDIG/' ','0','1','2','3','4','5','6','7','8','9'/
  254.       DATA KABC/'A','B','C','D','E','F','G','H','I','J','K','L','M','N',
  255.      1'O','P','Q','R','S','T','U','V','W','X','Y','Z'/
  256.       DATA KSPK/'=', ',', '(', '/', ')', '+', '-', '*', '.', 'X$', '-',
  257.      1'''', '&', '$'/
  258. C  $ IN ABOVE STATEMENT REPLACED BY X$, SINCE $ IS NOT SPECIAL
  259. C  CHARACTER IN IBM 360/370 FORTRAN.
  260.       DATA KBL2, KLR2, KLP2, KRP2, KERM/' *', '$$', '((', '))', ' $'/
  261.       DATA KAMPR /'& '/, KAT /' @'/, KAPSTR/'''@'/
  262. C
  263. C     /MISCAL/
  264.       DATA KEND /'D' ,'N' ,'E'/
  265. C
  266. C
  267. C     /MISC/
  268. C     LOGICAL UNIT ASSIGNMENTS
  269.       DATA INFILE /4/
  270.       DATA OUTFIL /6/
  271.       DATA PUNFIL /8/
  272.       DATA STDERR /0/
  273.       DATA STDIN  /5/
  274.       DATA SCFIL1 /1/
  275.       DATA SCFIL2 /2/
  276.       DATA SCFIL3 /9/
  277.       DATA USRFIL /3/
  278. C
  279.       DATA IQUIT /0/
  280.       DATA KOUNT /0/
  281.       DATA LERR /0/
  282.       DATA LINE /1/
  283.       DATA MDEB /0/
  284.       DATA MSTOP /0/
  285.       DATA MXREF /256/
  286.       DATA MXRGHT /65/
  287.       DATA NMSG /0/
  288.       DATA NPAGE /0/
  289.       DATA NPUN /0/
  290. C
  291. C     VERSION STRING
  292.       DATA VERNUM/'TIDY VER.  6.4  -  FEB 94 ' /
  293.       END
  294.       SUBROUTINE PCTIDY (DOUSER,SCDISK)
  295. C
  296. C     INTERACTIVE FILE DEFINITION ROUTINE FOR TIDY
  297. C
  298.       INCLUDE 'TIDY.INC'
  299.       INCLUDE 'UNITS.INC'
  300.       COMMON/TDYVER/VERNUM
  301.       CHARACTER*30 VERNUM
  302.       CHARACTER DRIVE
  303.       CHARACTER RESP(80)
  304.       CHARACTER*64 FILNM1, FILNM2, FILNM3
  305.       INTEGER DOSDEV, OPFIL
  306.       LOGICAL DOUSER, SCDISK
  307. C
  308.       WRITE (STDERR,25) VERNUM
  309. C
  310.  10   WRITE (STDERR,30)
  311.       READ (STDIN,40) RESP
  312.       I=0
  313.  20   I=I+1
  314.       IF (I.GT.80) GO TO 10
  315.       IF (RESP(I).EQ.' ') GO TO 20
  316.       IF (RESP(I).EQ.'Y'.OR.RESP(I).EQ.'y') THEN
  317.            DOUSER=.TRUE.
  318.       ELSE IF (RESP(I).EQ.'N'.OR.RESP(I).EQ.'n') THEN
  319.            DOUSER=.FALSE.
  320.       ELSE
  321.            GO TO 10
  322.       ENDIF
  323. C
  324. C     OPEN CONTROL FILE
  325.       IF (DOUSER) THEN
  326.            FILNM1=' '
  327.            IOPFL =  OPFIL (USRFIL,FILNM1,0,-1,'control card',LNG)
  328.            ISCONS=DOSDEV(FILNM1)
  329.       END IF
  330. C
  331. C     DEFINE SOURCE, LISTING, AND OUTPUT FILES.
  332.       FILNM1=' '
  333.       IOPFL =  OPFIL (INFILE,FILNM1,0,-1,'source',LNG)
  334.       FILNM1=' '
  335.       IOPFL =  OPFIL (OUTFIL,FILNM1,0,1,'listing',LNG)
  336.       FILNM1=' '
  337.       IOPFL =  OPFIL (PUNFIL,FILNM1,0,1,'punched output',LNG)
  338.       FILNM1=' '
  339. C
  340. C     FOR PC'S, ALLOW USER TO SPECIFY DISK FOR SCRATCH FILES.
  341.       IF (SCDISK) THEN
  342.            WRITE (STDERR,50)
  343.            READ (STDIN,40) DRIVE
  344.            FILNM1=DRIVE//':SCFIL1.TDY'
  345.            FILNM2=DRIVE//':SCFIL2.TDY'
  346.            FILNM3=DRIVE//':SCFIL3.TDY'
  347.       ELSE
  348.            FILNM1='SCFIL1.TDY'
  349.            FILNM2='SCFIL2.TDY'
  350.            FILNM3='SCFIL3.TDY'
  351.       END IF
  352. C
  353. C     OPEN SCRATCH FILES
  354.       IOPFL =  OPFIL (SCFIL1,FILNM1,-1,2,'SCRATCH',LNG)
  355.       IOPFL =  OPFIL (SCFIL2,FILNM2,-1,2,'SCRATCH',LNG)
  356. C     future addition for handling comments in continued statements.
  357. C     IOPFL =  OPFIL (SCFIL3,FILNM3,-1,2,'SCRATCH',LNG)
  358. C
  359. C     PROMPT USER FOR CONTROL CARDS IF CONSOLE INPUT.
  360.       IF (ISCONS.EQ.2) WRITE (STDERR,60)
  361. C
  362.       RETURN
  363. C
  364.  25   FORMAT (1X,A)
  365.  30   FORMAT (' Do you have a CONTROL CARD file? (y-n) ')
  366.  40   FORMAT (80A1)
  367.  50   FORMAT (' ENTER DISK TO USE FOR TEMPORARY FILES: ')
  368.  60   FORMAT (' Enter TIDY control cards.  Type CTRL-Z to stop.')
  369.       END
  370.       SUBROUTINE CONTRL
  371.       PARAMETER (NKTRL=40)
  372. C
  373. C     THIS SUBROUTINE EXECUTES THE TIDY CONTROL STATEMENTS.
  374. C     ALL TIDY CONTROL STATEMENTS MUST HAVE AN * PUNCHED IN COLUMN 1.
  375. C
  376. C     1   BASE   NOBASE   KB15
  377. C     2   IDIN   ======   KD79
  378. C     3   IDST   ======   KD79
  379. C     4   ROUT   ======   NROUT
  380. C     5   STAT   ======   KD15
  381. C     6   CARD   NOCARD   MPUN
  382. C     7   COLL   NOCOLL   MCOL
  383. C     8   COMM   NOCOMM   MCOM
  384. C     9   EXEM   NOEXEM   MEX
  385. C     10  LABE   NOLABE   MLBL
  386. C     11  LAST   ======   MSTOP
  387. C     12  LIST   NOLIST   MLIST
  388. C     13  NEWR   ======   NROUT
  389. C     14  REFE   NOREFE   MREF
  390. C     15  SKIP   ======   MSKP
  391. C     16  STOP   ======   MSTOP
  392. C     17  SERI   NOSERI   MSER  <0 USE KOL73...=0 USE BLANKS >0 SERIAL
  393. C     18  RIGH   ======   MRIT
  394. C     19  LEFT   ======   MRIT
  395. C     20  COLU   NOCOLU   JUST
  396. C     21  INDE   NOINDE   INDENT
  397. C     22  DEBU   NODEBU   MDEB
  398. C     23  CONT   NOCONT   MCONT
  399. C     24  END    ======   SAME AS STOP
  400. C     25  ANSI   NOANSI   MANSI
  401. C     26  FEND   NOFEND   NFEND
  402. C     27  CCHR   ======   KCTCTL
  403. C     28  HTRA   ======   KHTRAN
  404. C     29  DTRA   NODTRA   KDTRAN
  405. C     30  DEL1   ======   KDEL1
  406. C     31  DEL2   ======   KDEL2
  407. C     32  ARET   ======   KALMRK
  408. C     33  ARTR   NOARTR   KALTRN
  409. C     34  BLAN   NOBLAN   KBKCOK (INCLUDE BLANK LINES IN DECK)
  410. C     35  FSPL   NOFSPL   KFSPL  (SPLIT STRINGS IN INDENTED FMTS)
  411. C     36  HLOG   NOHLOG   KHLOG  (LOG TRANSLATED H-FIELDS TO LISTING)
  412. C     37  CASE   NOCASE   MCASE  (TRANSLATE NON-STRINGS TO UPPER CASE)
  413. C     38  UCAS   ======   MCASE  (TRANSLATE NON-STRINGS TO UPPER CASE)
  414. C     39  LCAS   ======   MCASE  (TRANSLATE NON-STRINGS TO LOWER CASE)
  415. C     40  ENDO   NOENDO   MNDOO  (RETAIN END-DO STATEMENTS)
  416. C
  417.       INCLUDE 'TIDY.INC'
  418. C
  419.       COMMON /CONTDY/ KTRL(4,NKTRL)
  420.       CHARACTER*2 KTRL
  421.       CHARACTER*2 KUPPER,IT
  422. C
  423.       I=14
  424.       ISTAR=-1
  425.       JSW=0
  426.       JL=JMAX-1
  427. C
  428. C     SCAN FOR 'NO' AT START
  429.       DO 10 JB=2,JL
  430.            IT=JINT(JB)
  431.            IF (IT.NE.KBL) THEN
  432.                 IT=KUPPER(IT)
  433.                 IF (IT.NE.KABC(I)) THEN
  434.                      JC=2
  435.                      GO TO 30
  436.                 END IF
  437.                 I=I+1
  438.                 IF (I.GT.15) GO TO 20
  439.            END IF
  440. 10    CONTINUE
  441.       ISTAR=1
  442.       RETURN
  443. C
  444. 20    JSW=1
  445.       JC=JB+1
  446. 30    DO 50 J=1,NKTRL
  447.            I=1
  448.            DO 40 JCOL=JC,JMAX
  449.                 IT=KUPPER(JINT(JCOL))
  450.                 IF (IT.EQ.KTRL(I,J)) THEN
  451.                      IF (I.GE.4) GO TO 70
  452.                      I=I+1
  453.                 ELSE
  454.                      IF (IT.NE.KBL) GO TO 50
  455.                 END IF
  456. 40         CONTINUE
  457. 50    CONTINUE
  458. 60    ISTAR=1
  459.       RETURN
  460. C
  461. C     EXECUTE CONTROL STATEMENT
  462. C
  463. 70    NREC=NREC-1
  464. C                  JSW=1 IF CARD STARTS WITH NO
  465.       IF (JSW.EQ.1) THEN
  466.            GO TO (490,60,60,60,60,120,140,210,320,410,60,520,60,450,60,
  467.      1      60,480,60,60,500,510,250,230,60,100,340,60,390,280,60,270,
  468.      2      60,80,160,360,380,190,180,170,300),J
  469.       ELSE
  470.            GO TO (520,520,520,520,520,110,130,200,310,400,420,520,430,
  471.      1      440,460,420,470,520,520,520,520,240,220,420,90,330,520,520,
  472.      2      260,520,520,520,520,150,350,370,170,170,180,290),J
  473.       END IF
  474. C
  475. C                  NOARTRAN
  476. 80    KALTRN=KBL
  477.       RETURN
  478. C                  ANSI
  479. 90    MANSI=0
  480.       RETURN
  481. C                  NOANSI
  482. 100   MANSI=1
  483.       RETURN
  484. C                  CARD
  485. 110   MPUN=-1
  486.       KPUN=-1
  487.       RETURN
  488. C                  NOCARD
  489. 120   MPUN=0
  490.       KPUN=0
  491.       RETURN
  492. C                  COLL
  493. 130   MCOL=-1
  494.       RETURN
  495. C                  NOCOLL
  496. 140   MCOL=0
  497.       RETURN
  498. C                  BLAN
  499. 150   KBKCOK=1
  500.       RETURN
  501. C                  NOBLAN
  502. 160   KBKCOK=0
  503.       RETURN
  504. C                  CASE, UCAS
  505. 170   MCASE=0
  506.       CALL KCTSET (0)
  507.       RETURN
  508. C                  LCASE
  509. 180   MCASE=0
  510.       CALL KCTSET (1)
  511.       RETURN
  512. C                  NOCASE
  513. 190   MCASE=-1
  514.       RETURN
  515. C                  COMM
  516. 200   MCOM=-1
  517.       RETURN
  518. C                  NOCOMM
  519. 210   MCOM=0
  520.       RETURN
  521. C                  CONT
  522. 220   MCONT=1
  523.       RETURN
  524. C                  NOCONT
  525. 230   MCONT=0
  526.       RETURN
  527. C                  DEBUG
  528. 240   MDEB=1
  529.       RETURN
  530. C                  NODEBUG
  531. 250   MDEB=0
  532.       RETURN
  533. C                  DTRAN
  534. 260   KDTRAN=1
  535.       RETURN
  536. C                  NODEL2 -- IMPLIES *NODTRAN
  537. 270   KDEL2='""'
  538. C                  NODTRAN
  539. 280   KDTRAN=0
  540.       RETURN
  541. C                  ENDO
  542. 290   MNDOO=1
  543.       RETURN
  544. C                  NOENDO
  545. 300   MNDOO=0
  546.       RETURN
  547. C                  EXEM
  548. 310   MEX=-1
  549.       RETURN
  550. C                  NOEXEM
  551. 320   MEX=0
  552.       RETURN
  553. C                  FEND
  554. 330   NFEND=0
  555.       RETURN
  556. C                  NOFEND
  557. 340   NFEND=1
  558.       RETURN
  559. C                  FSPL
  560. 350   KFSPL=0
  561.       RETURN
  562. C                  NOFSPL
  563. 360   KFSPL=1
  564.       RETURN
  565. C                  HLOG
  566. 370   KHLOG=0
  567.       RETURN
  568. C                  NOHLOG
  569. 380   KHLOG=1
  570.       RETURN
  571. C                  NOHTRAN
  572. 390   KHTRAN=0
  573.       RETURN
  574. C                  LABE
  575. 400   MLBL=-1
  576.       RETURN
  577. C                  NOLABE
  578. 410   MLBL=0
  579.       RETURN
  580. C                  LAST/STOP
  581. 420   MSTOP=-1
  582.       RETURN
  583. C                  NEWR
  584. 430   CALL INITDY
  585.       RETURN
  586. C                  REFE
  587. 440   MREF=-1
  588.       RETURN
  589. C                  NOREFE
  590. 450   MREF=0
  591.       RETURN
  592. C                  SKIP
  593. 460   MSKP=-1
  594.       RETURN
  595. C                  SERI
  596. 470   MSER=-1
  597.       RETURN
  598. C                  NOSERI
  599. 480   MSER=0
  600.       RETURN
  601. C                  NOBASE
  602. 490   KB15=0
  603.       RETURN
  604. C
  605. C                  NOCOLU
  606. 500   JUST=0
  607.       RETURN
  608. C
  609. C                  NOINDENT
  610. 510   INDENT=0
  611.       RETURN
  612. C
  613. C     GET NUMBER FOLLOWING (=) SIGN.
  614. C
  615. 520   JAVB=JCOL
  616.       DO 530 JCOL=JAVB,JMAX
  617.            IF (JINT(JCOL).EQ.KSPK(1)) GO TO 540
  618. 530   CONTINUE
  619.       L772=1D0
  620.       GO TO 550
  621. 540   JCOL=JCOL+1
  622.       JAVB=JCOL
  623.       CALL RSTAT
  624. 550   GO TO (560,570,570,580,630,60,60,60,60,60,60,690,60,60,60,60,60,
  625.      1670,680,640,660,60,60,60,60,60,730,650,60,730,730,730,730,60),J
  626. C                  BASE
  627. 560   KB15=IDINT(L772)
  628.       RETURN
  629. C                  IDIN/IDST
  630. 570   KD79=MAX0(IDINT(L772),1)
  631.       RETURN
  632. C                  ROUT
  633. C     USE TWO LETTERS FOR ROUTINE CODE, CONSTRUCT VALUE OF NROUT.
  634. 580   JCOL=JAVB-1
  635.       NROUT=0
  636.       DO 610 I=1,2
  637. 590        JCOL=JCOL+1
  638.            IT=KUPPER(JINT(JCOL))
  639.            IF (IT.EQ.KBL) GO TO 590
  640.            IF (IT.EQ.KERM) GO TO 620
  641.            DO 600 J=1,26
  642.                 IF (IT.NE.KABC(J)) GO TO 600
  643.                 NROUT=NROUT*26+J
  644.                 GO TO 610
  645. 600        CONTINUE
  646. 610   CONTINUE
  647. C
  648. 620   NROUT=MAX0(NROUT-1,1)
  649.       RETURN
  650. C                  STAT
  651. 630   KD15=MAX0(IDINT(L772),1)
  652.       RETURN
  653. C                  COLU
  654. 640   JUST=MAX0(IDINT(L772),7)
  655.       RETURN
  656. C                  HTRAN
  657. 650   KHTRAN=MIN0(IDINT(L772),3)
  658.       IF (KHTRAN.LT.0) KHTRAN=0
  659.       RETURN
  660. C                            INDENT
  661. 660   INDENT=MIN0(10,IDINT(L772))
  662.       RETURN
  663. C                            RIGHT
  664. 670   MRIT=MIN0(IDINT(L772),5)
  665.       IF (MRIT.EQ.1) MRIT=5
  666.       RETURN
  667. C                            LEFT
  668. 680   MRIT=MAX0(IDINT(L772),1)
  669.       IF (MRIT.GT.5) MRIT=1
  670.       mrit = -mrit
  671.       RETURN
  672. C                            LIST/NOLIST
  673. 690   IF (IDINT(L772).EQ.2) GO TO 710
  674.       IF (JSW.NE.0) GO TO 700
  675. C                            LIST
  676.       MLIST=-1
  677.       RETURN
  678. C                            NOLIST
  679. 700   MLIST=0
  680.       RETURN
  681. 710   IF (JSW.NE.0) GO TO 720
  682. C                            LIST=2.
  683.       KPRIN=1
  684.       MPRIN=1
  685.       RETURN
  686. C                            NOLIST=2.
  687. 720   MPRIN=0
  688.       KPRIN=0
  689.       RETURN
  690. C
  691. C                  CARDS USING CHARACTER ARGUMENT
  692. 730   JCOL=JAVB-1
  693. 740   JCOL=JCOL+1
  694.       IT=KUPPER(JINT(JCOL))
  695.       IF (IT.EQ.KBL) GO TO 740
  696.       IF (J.EQ.27) THEN
  697. C                            CCHR (CONTINUATION CHAR)
  698.            IF (IT.NE.KERM.AND.IT.NE.KDIG(1)) THEN
  699.                 KCTCTL=1
  700.                 KCTCHR=JINT(JCOL)
  701.                 RETURN
  702.            END IF
  703. C     NO CHARACTER SPECIFIED OR ZERO.
  704.            KCTCTL=0
  705.            KCTCHR=KSPK(10)
  706.            IF (IT.EQ.KDIG(1)) CALL DIAGNO (38)
  707.       ELSE IF (J.EQ.30) THEN
  708. C                            DEL1 (PRIMARY STRING DELIMITER)
  709.            KDEL1=KBL
  710.            KDEL1(1:1)=IT(1:1)
  711.            KAPSTR=KDEL1(1:1)//KAT(2:2)
  712.       ELSE IF (J.EQ.31) THEN
  713. C                            DEL2 (SECONDARY STRING DELIMITER)
  714.            KDEL2=KBL
  715.            KDEL2(1:1)=IT(1:1)
  716.       ELSE IF (J.EQ.32) THEN
  717. C                            ARET (ALT. RETURNS IN CALLS)
  718.            KALMRK=IT
  719.       ELSE IF (J.EQ.33) THEN
  720. C                            ARTR (TRANSLATE KALMRK TO THIS)
  721.            KALTRN=IT
  722.       END IF
  723.       RETURN
  724.       END
  725.       BLOCK DATA CTLDAT
  726. C
  727.       COMMON /CONTDY/ KTRL1,KTRL2,KTRL3,KTRL4,KTRL5,KTRL6,KTRL7,KTRL8,
  728.      1KTRL9,KTRL10,KTRL11,KTRL12,KTRL13,KTRL14,KTRL15,KTRL16,KTRL17,
  729.      2KTRL18,KTRL19,KTRL20,KTRL21,KTRL22,KTRL23,KTRL24,KTRL25,KTRL26,
  730.      3KTRL27,KTRL28,KTRL29,KTRL30,KTRL31,KTRL32,KTRL33,KTRL34,KTRL35,
  731.      4KTRL36,KTRL37,KTRL38,KTRL39,KTRL40
  732.       CHARACTER*2 KTRL1(4),KTRL2(4),KTRL3(4),KTRL4(4),KTRL5(4),KTRL6(4),
  733.      1KTRL7(4),KTRL8(4),KTRL9(4),KTRL10(4),KTRL11(4),KTRL12(4),KTRL13(4)
  734.      2,KTRL14(4),KTRL15(4),KTRL16(4),KTRL17(4),KTRL18(4),KTRL19(4),
  735.      3KTRL20(4),KTRL21(4),KTRL22(4),KTRL23(4),KTRL24(4),KTRL25(4),
  736.      4KTRL26(4),KTRL27(4),KTRL28(4),KTRL29(4),KTRL30(4),KTRL31(4),
  737.      5KTRL32(4),KTRL33(4),KTRL34(4),KTRL35(4),KTRL36(4),KTRL37(4),
  738.      6KTRL38(4),KTRL39(4),KTRL40(4)
  739. C
  740. C     /CONTDY/
  741.       DATA KTRL1/'B','A','S','E'/
  742.       DATA KTRL2/'I','D','I','N'/
  743.       DATA KTRL3/'I','D','S','T'/
  744.       DATA KTRL4/'R','O','U','T'/
  745.       DATA KTRL5/'S','T','A','T'/
  746.       DATA KTRL6/'C','A','R','D'/
  747.       DATA KTRL7/'C','O','L','L'/
  748.       DATA KTRL8/'C','O','M','M'/
  749.       DATA KTRL9/'E','X','E','M'/
  750.       DATA KTRL10/'L','A','B','E'/
  751.       DATA KTRL11/'L','A','S','T'/
  752.       DATA KTRL12/'L','I','S','T'/
  753.       DATA KTRL13/'N','E','W','R'/
  754.       DATA KTRL14/'R','E','F','E'/
  755.       DATA KTRL15/'S','K','I','P'/
  756.       DATA KTRL16/'S','T','O','P'/
  757.       DATA KTRL17/'S','E','R','I'/
  758.       DATA KTRL18/'R','I','G','H'/
  759.       DATA KTRL19/'L','E','F','T'/
  760.       DATA KTRL20/'C','O','L','U'/
  761.       DATA KTRL21/'I','N','D','E'/
  762.       DATA KTRL22/'D','E','B','U'/
  763.       DATA KTRL23/'C','O','N','T'/
  764.       DATA KTRL24/'E','N','D',' '/
  765.       DATA KTRL25/'A','N','S','I'/
  766.       DATA KTRL26/'F','E','N','D'/
  767.       DATA KTRL27/'C','C','H','R'/
  768.       DATA KTRL28/'H','T','R','A'/
  769.       DATA KTRL29/'D','T','R','A'/
  770.       DATA KTRL30/'D','E','L','1'/
  771.       DATA KTRL31/'D','E','L','2'/
  772.       DATA KTRL32/'A','R','E','T'/
  773.       DATA KTRL33/'A','R','T','R'/
  774.       DATA KTRL34/'B','L','A','N'/
  775.       DATA KTRL35/'F','S','P','L'/
  776.       DATA KTRL36/'H','L','O','G'/
  777.       DATA KTRL37/'C','A','S','E'/
  778.       DATA KTRL38/'U','C','A','S'/
  779.       DATA KTRL39/'L','C','A','S'/
  780.       DATA KTRL40/'E','N','D','O'/
  781.       END
  782.       SUBROUTINE INITDY
  783. C
  784. C     INITIALIZE TIDY -- USED AT START AND WHEN *NEWR EXECUTED.
  785. C
  786.       INCLUDE 'TIDY.INC'
  787. C
  788.       INDENT=0
  789.       JUST=7
  790.       KALMRK = '* '
  791.       KALTRN= '  '
  792.       KBKCOK=1
  793.       KBLCMT=' @'
  794.       KB15=0
  795.       KCTCHR=KSPK(10)
  796.       KCTCTL=0
  797.       KD15=10
  798.       KD79=1
  799.       KDEL1 = ''' '
  800.       KDEL2 = '""'
  801.       KDTRAN=0
  802.       KHTRAN=1
  803.       KHLOG=1
  804.       KPRIN=1
  805.       KPUN=-1
  806.       KFSPL=1
  807.       MANSI=0
  808.       MCASE=0
  809.       MCOL=0
  810.       MCOM=-1
  811.       MCONT=0
  812.       MEX=0
  813.       MLBL=0
  814.       MLIST=-1
  815.       MNDOO=0
  816.       MPRIN=1
  817.       MPUN=-1
  818.       MREF=0
  819.       MRIT=2
  820.       MSER=0
  821.       NFEND=0
  822.       NLHTRN=0
  823.       NROUT=1
  824. C     DEFAULT CASE TRANSLATION = UPPER
  825. C       CHANGE TO (1) FOR DEFAULT TRANSLATION TO LOWER-CASE
  826.       CALL KCTSET (0)
  827. C
  828.       RETURN
  829.       END
  830.       SUBROUTINE KWSCAN (JT,KSTCR)
  831.       PARAMETER (NKST=83)
  832. C
  833. C     THIS ROUTINE SCANS FOR FORTRAN KEYWORDS, SETS JT TO CORRECT
  834. C     TYPE IF FOUND, ELSE ZERO.
  835. C
  836. C     INPUT: IF JT = 0, SCANS WHOLE LIST
  837. C               JT > 0, ONLY SCANS THAT WORD.
  838. C
  839.       INCLUDE 'TIDY.INC'
  840.       INCLUDE 'UNITS.INC'
  841. C
  842.       DIMENSION KSTCR(5)
  843.       COMMON /KSTCOM/ KST(10,NKST)
  844.       CHARACTER*2 KST,WKSTR(10),KUPPER
  845.       COMMON /KSTNUM/ KSTC(6,NKST)
  846. C
  847.       IF (JT.EQ.0) THEN
  848.            NL=1
  849.            NU=NKST
  850. C     ZERO OUT KSTCR FOR NEW SCANS ONLY
  851.            DO 10 I=1,5
  852.                 KSTCR(I)=0
  853. 10         CONTINUE
  854.       ELSE
  855.            NL=JT
  856.            NU=JT
  857.       END IF
  858. C
  859. C     MAKE UPPER-CASE COPY OF 10 CHARS (MAX STRING LENGTH)
  860.       LAST=JCOL-1
  861.       DO 30 I=1,10
  862. 20         LAST=LAST+1
  863.            IF (LAST.GT.JMAX) THEN
  864.                 WKSTR(I)=KBL
  865.            ELSE
  866.                 IF (JINT(LAST).EQ.KBL) GO TO 20
  867.                 WKSTR(I)=KUPPER(JINT(LAST))
  868.            END IF
  869. 30    CONTINUE
  870.       IF (MDEB.GT.0) WRITE (OUTFIL,70) WKSTR,JT
  871. C
  872.       DO 60 IT=NL,NU
  873.            NINS=KSTC(1,IT)
  874. C
  875.            DO 40 I=1,NINS
  876.                 IF (WKSTR(I).NE.KST(I,IT)) GO TO 60
  877. 40         CONTINUE
  878.            JT=KSTC(6,IT)
  879.            DO 50 I=1,5
  880.                 KSTCR(I)=KSTC(I,IT)
  881. 50         CONTINUE
  882.            IF (MDEB.GT.0) WRITE (OUTFIL,80) KSTCR,JT
  883.            RETURN
  884. C                  LOOP FOR NEXT STATEMENT.
  885. 60    CONTINUE
  886. C
  887. C     NO MATCH.
  888.       IF (MDEB.GT.0) WRITE (OUTFIL,90)
  889.       JT=0
  890. C
  891.       RETURN
  892. C
  893. C
  894. 70    FORMAT (' KWSCAN checking ',10A1,' mode = ',I2)
  895. 80    FORMAT ('   NINS  =',I3,' KLASS  =',I3,' JTYPE =',I3/'   NANSI =',
  896.      1I3,' KSTROK =',I3,' KPOS  =',I3)
  897. 90    FORMAT ('  --- no match')
  898.       END
  899.       BLOCK DATA KSTDAT
  900. C
  901.       COMMON /KSTCOM/
  902.      1      KST1  ,KST2  ,KST3  ,KST4  ,KST5
  903.      2     ,KST6  ,KST7  ,KST8  ,KST9 ,KST10
  904.      3    ,KST11 ,KST12 ,KST13 ,KST14 ,KST15
  905.      4    ,KST16 ,KST17 ,KST18 ,KST19 ,KST20
  906.      5    ,KST21 ,KST22 ,KST23 ,KST24 ,KST25
  907.      6    ,KST26 ,KST27 ,KST28 ,KST29 ,KST30
  908.      7    ,KST31 ,KST32 ,KST33 ,KST34 ,KST35
  909.      8    ,KST36 ,KST37 ,KST38 ,KST39 ,KST40
  910.      9    ,KST41 ,KST42 ,KST43 ,KST44 ,KST45
  911.      X    ,KST46 ,KST47 ,KST48 ,KST49 ,KST50
  912.      X    ,KST51 ,KST52 ,KST53 ,KST54 ,KST55
  913.      X    ,KST56 ,KST57 ,KST58 ,KST59 ,KST60
  914.      X    ,KST61 ,KST62 ,KST63 ,KST64 ,KST65
  915.      X    ,KST66 ,KST67 ,KST68 ,KST69 ,KST70
  916.      X    ,KST71 ,KST72 ,KST73 ,KST74 ,KST75
  917.      X    ,KST76 ,KST77 ,KST78 ,KST79 ,KST80
  918.      X    ,KST81 ,KST82 ,KST83
  919. C
  920. C
  921.       CHARACTER*2 KST1 (10),KST2 (10),KST3 (10),KST4 (10),KST5 (10)
  922.       CHARACTER*2 KST6 (10),KST7 (10),KST8 (10),KST9 (10),KST10(10)
  923.       CHARACTER*2 KST11(10),KST12(10),KST13(10),KST14(10),KST15(10)
  924.       CHARACTER*2 KST16(10),KST17(10),KST18(10),KST19(10),KST20(10)
  925.       CHARACTER*2 KST21(10),KST22(10),KST23(10),KST24(10),KST25(10)
  926.       CHARACTER*2 KST26(10),KST27(10),KST28(10),KST29(10),KST30(10)
  927.       CHARACTER*2 KST31(10),KST32(10),KST33(10),KST34(10),KST35(10)
  928.       CHARACTER*2 KST36(10),KST37(10),KST38(10),KST39(10),KST40(10)
  929.       CHARACTER*2 KST41(10),KST42(10),KST43(10),KST44(10),KST45(10)
  930.       CHARACTER*2 KST46(10),KST47(10),KST48(10),KST49(10),KST50(10)
  931.       CHARACTER*2 KST51(10),KST52(10),KST53(10),KST54(10),KST55(10)
  932.       CHARACTER*2 KST56(10),KST57(10),KST58(10),KST59(10),KST60(10)
  933.       CHARACTER*2 KST61(10),KST62(10),KST63(10),KST64(10),KST65(10)
  934.       CHARACTER*2 KST66(10),KST67(10),KST68(10),KST69(10),KST70(10)
  935.       CHARACTER*2 KST71(10),KST72(10),KST73(10),KST74(10),KST75(10)
  936.       CHARACTER*2 KST76(10),KST77(10),KST78(10),KST79(10),KST80(10)
  937.       CHARACTER*2 KST81(10),KST82(10),KST83(10)
  938. C
  939.       COMMON /KSTNUM/
  940.      1     KSTC1  ,KSTC2  ,KSTC3  ,KSTC4  ,KSTC5
  941.      2    ,KSTC6  ,KSTC7  ,KSTC8  ,KSTC9  ,KSTC10
  942.      3    ,KSTC11 ,KSTC12 ,KSTC13 ,KSTC14 ,KSTC15
  943.      4    ,KSTC16 ,KSTC17 ,KSTC18 ,KSTC19 ,KSTC20
  944.      5    ,KSTC21 ,KSTC22 ,KSTC23 ,KSTC24 ,KSTC25
  945.      6    ,KSTC26 ,KSTC27 ,KSTC28 ,KSTC29 ,KSTC30
  946.      7    ,KSTC31 ,KSTC32 ,KSTC33 ,KSTC34 ,KSTC35
  947.      8    ,KSTC36 ,KSTC37 ,KSTC38 ,KSTC39 ,KSTC40
  948.      9    ,KSTC41 ,KSTC42 ,KSTC43 ,KSTC44 ,KSTC45
  949.      X    ,KSTC46 ,KSTC47 ,KSTC48 ,KSTC49 ,KSTC50
  950.      X    ,KSTC51 ,KSTC52 ,KSTC53 ,KSTC54 ,KSTC55
  951.      X    ,KSTC56 ,KSTC57 ,KSTC58 ,KSTC59 ,KSTC60
  952.      X    ,KSTC61 ,KSTC62 ,KSTC63 ,KSTC64 ,KSTC65
  953.      X    ,KSTC66 ,KSTC67 ,KSTC68 ,KSTC69 ,KSTC70
  954.      X    ,KSTC71 ,KSTC72 ,KSTC73 ,KSTC74 ,KSTC75
  955.      X    ,KSTC76 ,KSTC77 ,KSTC78 ,KSTC79 ,KSTC80
  956.      X    ,KSTC81 ,KSTC82 ,KSTC83
  957.       DIMENSION KSTC1 (6),KSTC2 (6),KSTC3 (6),KSTC4 (6),KSTC5 (6)
  958.       DIMENSION KSTC6 (6),KSTC7 (6),KSTC8 (6),KSTC9 (6),KSTC10(6)
  959.       DIMENSION KSTC11(6),KSTC12(6),KSTC13(6),KSTC14(6),KSTC15(6)
  960.       DIMENSION KSTC16(6),KSTC17(6),KSTC18(6),KSTC19(6),KSTC20(6)
  961.       DIMENSION KSTC21(6),KSTC22(6),KSTC23(6),KSTC24(6),KSTC25(6)
  962.       DIMENSION KSTC26(6),KSTC27(6),KSTC28(6),KSTC29(6),KSTC30(6)
  963.       DIMENSION KSTC31(6),KSTC32(6),KSTC33(6),KSTC34(6),KSTC35(6)
  964.       DIMENSION KSTC36(6),KSTC37(6),KSTC38(6),KSTC39(6),KSTC40(6)
  965.       DIMENSION KSTC41(6),KSTC42(6),KSTC43(6),KSTC44(6),KSTC45(6)
  966.       DIMENSION KSTC46(6),KSTC47(6),KSTC48(6),KSTC49(6),KSTC50(6)
  967.       DIMENSION KSTC51(6),KSTC52(6),KSTC53(6),KSTC54(6),KSTC55(6)
  968.       DIMENSION KSTC56(6),KSTC57(6),KSTC58(6),KSTC59(6),KSTC60(6)
  969.       DIMENSION KSTC61(6),KSTC62(6),KSTC63(6),KSTC64(6),KSTC65(6)
  970.       DIMENSION KSTC66(6),KSTC67(6),KSTC68(6),KSTC69(6),KSTC70(6)
  971.       DIMENSION KSTC71(6),KSTC72(6),KSTC73(6),KSTC74(6),KSTC75(6)
  972.       DIMENSION KSTC76(6),KSTC77(6),KSTC78(6),KSTC79(6),KSTC80(6)
  973.       DIMENSION KSTC81(6),KSTC82(6),KSTC83(6)
  974. C
  975. C     /KST/
  976.       DATA KST 1/'A','C','C','E','P','T',' ',' ',' ',' '/
  977.       DATA KST 2/'A','S','C','E','N','T',' ',' ',' ',' '/
  978.       DATA KST 3/'A','S','S','I','G','N',' ',' ',' ',' '/
  979.       DATA KST 4/'B','A','C','K','S','P','A','C','E','('/
  980.       DATA KST 5/'B','L','O','C','K','D','A','T','A',' '/
  981.       DATA KST 6/'B','U','F','F','E','R','I','N','(',' '/
  982.       DATA KST 7/'B','U','F','F','E','R','O','U','T','('/
  983.       DATA KST 8/'C','A','L','L',' ',' ',' ',' ',' ',' '/
  984.       DATA KST 9/'C','H','A','R','A','C','T','E','R',' '/
  985.       DATA KST10/'C','O','M','M','O','N',' ',' ',' ',' '/
  986.       DATA KST11/'C','O','M','P','L','E','X',' ',' ',' '/
  987.       DATA KST12/'C','O','N','T','I','N','U','E',' ',' '/
  988.       DATA KST13/'D','A','T','A',' ',' ',' ',' ',' ',' '/
  989.       DATA KST14/'D','E','C','O','D','E','(',' ',' ',' '/
  990.       DATA KST15/'D','I','M','E','N','S','I','O','N',' '/
  991.       DATA KST16/'D','O','U','B','L','E','P','R','E','C'/
  992.       DATA KST17/'D','O','U','B','L','E',' ',' ',' ',' '/
  993.       DATA KST18/'E','N','C','O','D','E','(',' ',' ',' '/
  994.       DATA KST19/'E','N','D','F','I','L','E','(',' ',' '/
  995.       DATA KST20/'E','N','D','I','F',' ',' ',' ',' ',' '/
  996.       DATA KST21/'E','N','D','F','I','L','E',' ',' ',' '/
  997.       DATA KST22/'E','N','T','R','Y',' ',' ',' ',' ',' '/
  998.       DATA KST23/'E','Q','U','I','V','A','L','E','N','C'/
  999.       DATA KST24/'E','X','T','E','R','N','A','L',' ',' '/
  1000.       DATA KST25/'F','I','N','I','S',' ',' ',' ',' ',' '/
  1001.       DATA KST26/'F','O','R','M','A','T','(',' ',' ',' '/
  1002.       DATA KST27/'F','O','R','T','R','A','N',' ',' ',' '/
  1003.       DATA KST28/'I','F','(','U','N','I','T',',',' ',' '/
  1004.       DATA KST29/'F','U','N','C','T','I','O','N',' ',' '/
  1005.       DATA KST30/'G','O','T','O','(',' ',' ',' ',' ',' '/
  1006.       DATA KST31/'G','O','T','O',' ',' ',' ',' ',' ',' '/
  1007.       DATA KST32/'I','F','A','C','C','U','M','U','L','A'/
  1008.       DATA KST33/'I','F','Q','U','O','T','I','E','N','T'/
  1009.       DATA KST34/'I','F','(','D','I','V','I','D','E','C'/
  1010.       DATA KST35/'I','F','(','E','N','D','F','I','L','E'/
  1011.       DATA KST36/'I','F','(','S','E','N','S','E','L','I'/
  1012.       DATA KST37/'I','F','(','S','E','N','S','E','S','W'/
  1013.       DATA KST38/'I','F','(',' ',' ',' ',' ',' ',' ',' '/
  1014.       DATA KST39/'I','N','T','E','G','E','R',' ',' ',' '/
  1015.       DATA KST40/'L','O','G','I','C','A','L',' ',' ',' '/
  1016.       DATA KST41/'M','A','C','H','I','N','E',' ',' ',' '/
  1017.       DATA KST42/'N','A','M','E','L','I','S','T',' ',' '/
  1018.       DATA KST43/'P','A','U','S','E',' ',' ',' ',' ',' '/
  1019.       DATA KST44/'P','R','I','N','T',' ',' ',' ',' ',' '/
  1020.       DATA KST45/'P','R','O','G','R','A','M',' ',' ',' '/
  1021.       DATA KST46/'P','U','N','C','H',' ',' ',' ',' ',' '/
  1022.       DATA KST47/'R','E','A','D','I','N','P','U','T','T'/
  1023.       DATA KST48/'R','E','A','D','T','A','P','E',' ',' '/
  1024.       DATA KST49/'R','E','A','D','(',' ',' ',' ',' ',' '/
  1025.       DATA KST50/'R','E','A','D',' ',' ',' ',' ',' ',' '/
  1026.       DATA KST51/'R','E','A','L',' ',' ',' ',' ',' ',' '/
  1027.       DATA KST52/'R','E','T','U','R','N',' ',' ',' ',' '/
  1028.       DATA KST53/'R','E','W','I','N','D','(',' ',' ',' '/
  1029.       DATA KST54/'S','E','G','M','E','N','T',' ',' ',' '/
  1030.       DATA KST55/'S','E','N','S','E','L','I','G','H','T'/
  1031.       DATA KST56/'S','T','O','P',' ',' ',' ',' ',' ',' '/
  1032.       DATA KST57/'S','U','B','R','O','U','T','I','N','E'/
  1033.       DATA KST58/'T','Y','P','E',' ',' ',' ',' ',' ',' '/
  1034.       DATA KST59/'W','R','I','T','E','O','U','T','P','U'/
  1035.       DATA KST60/'W','R','I','T','E','T','A','P','E',' '/
  1036.       DATA KST61/'W','R','I','T','E','(',' ',' ',' ',' '/
  1037.       DATA KST62/'O','V','E','R','L','A','Y',' ',' ',' '/
  1038.       DATA KST63/'I','D','E','N','T',' ',' ',' ',' ',' '/
  1039.       DATA KST64/'F','R','E','Q','U','E','N','C','Y',' '/
  1040.       DATA KST65/'I','M','P','L','I','C','I','T',' ',' '/
  1041.       DATA KST66/'L','E','V','E','L',' ',' ',' ',' ',' '/
  1042.       DATA KST67/'E','L','S','E','I','F',' ',' ',' ',' '/
  1043.       DATA KST68/'E','L','S','E',' ',' ',' ',' ',' ',' '/
  1044.       DATA KST69/'T','H','E','N',' ',' ',' ',' ',' ',' '/
  1045.       DATA KST70/'C','L','O','S','E','(',' ',' ',' ',' '/
  1046.       DATA KST71/'I','N','C','L','U','D','E',' ',' ',' '/
  1047.       DATA KST72/'I','N','Q','U','I','R','E','(',' ',' '/
  1048.       DATA KST73/'I','N','T','R','I','N','S','I','C',' '/
  1049.       DATA KST74/'O','P','E','N','(',' ',' ',' ',' ',' '/
  1050.       DATA KST75/'P','A','R','A','M','E','T','E','R',' '/
  1051.       DATA KST76/'S','A','V','E',' ',' ',' ',' ',' ',' '/
  1052.       DATA KST77/'B','A','C','K','S','P','A','C','E',' '/
  1053.       DATA KST78/'E','N','D','D','O',' ',' ',' ',' ',' '/
  1054.       DATA KST79/'R','E','W','I','N','D',' ',' ',' ',' '/
  1055.       DATA KST80/'C','L','O','S','E',' ',' ',' ',' ',' '/
  1056.       DATA KST81/'E','N','D',' ',' ',' ',' ',' ',' ',' '/
  1057.       DATA KST82/'D','O','W','H','I','L','E','(',' ',' '/
  1058.       DATA KST83/'R','E','P','E','A','T',' ',' ',' ',' '/
  1059. C
  1060. C     /KSTNUM/
  1061. C     ********* NOTE - KPOS IS ADDED TO INSULATE PASS1 FROM ADDITIONS
  1062. C     TO ABOVE TABLE.  WHEN ADDING NEW STATEMENTS, SET KPOS TO THE
  1063. C     NEW VALUE OF NKST RATHER THAN THE ORDINAL POSITION OF THE NEW
  1064. C     ADDITION TO THE TABLE.
  1065. C      (NOTE WHEN ADDING - SIMILAR STRINGS MUST BE IN DESCENDING ORDER
  1066. C       BY LENGTH, I.E. END MUST FOLLOW ENDIF)
  1067. C     WARNING - DO NOT MOVE LINES 69 OR 82 WITHOUT ALTERING PASS1 -
  1068. C               THERE ARE EXPLICIT REFERENCES TO THESE LINES.
  1069. C
  1070. C                KLASS  DESCRIPTION
  1071. C                  0.   CONTROL CARD
  1072. C                  1.   COMMENT
  1073. C                  2.   HEADER
  1074. C                  3.   NO STATEMENT NO ALLOWED (NON-EXECTUABLE)
  1075. C                  4.   CONTINUE
  1076. C                  5.   FORMAT STATEMENT.
  1077. C                  6.   STATEMENT NO. ALLOWED, NO REFERENCES
  1078. C                  7.   REFERENCES PRESENT, STATEMENT NO. ALLOWED.
  1079. C                  8.   END
  1080. C                  9.   INTRODUCTORY
  1081. C                  10.  DO
  1082. C                  11.  ELSE,ENDIF,ELSEIF, UNRECOGNIZED
  1083. C                       (TRANSFER CAN GET HERE REGARDLESS OF LABEL)
  1084. C
  1085. C     KLASS 0.   CONTROL CARD
  1086. C             RESERVED FOR FUTURE DEVELOPMENT.
  1087. C
  1088. C
  1089. C                   NINS  KLASS  JTYPE NANSI   KSTROK     KPOS
  1090.       DATA KSTC 1 /    6,     7,    33,    1,       0,        1/
  1091.       DATA KSTC 2 /    6,     2,    1 ,    1,       0,        2/
  1092.       DATA KSTC 3 /    6,     7,    2 ,    0,       0,        3/
  1093.       DATA KSTC 4 /   10,     7,    47,    0,       0,        4/
  1094.       DATA KSTC 5 /    9,     2,    4 ,    0,       0,        5/
  1095.       DATA KSTC 6 /    9,     6,    5 ,    1,       0,        6/
  1096.       DATA KSTC 7 /   10,     6,    5 ,    1,       0,        7/
  1097.       DATA KSTC 8 /    4,     7,    6 ,    0,       1,        8/
  1098.       DATA KSTC 9 /    9,     3,    46,    0,       0,        9/
  1099.       DATA KSTC10 /    6,     3,    7 ,    0,       0,       10/
  1100.       DATA KSTC11 /    7,     3,    46,    0,       0,       11/
  1101.       DATA KSTC12 /    8,     4,    8 ,    0,       0,       12/
  1102.       DATA KSTC13 /    4,     3,    9 ,    0,       1,       13/
  1103.       DATA KSTC14 /    7,     7,    10,    1,       0,       14/
  1104.       DATA KSTC15 /    9,     3,    11,    0,       0,       15/
  1105.       DATA KSTC16 /   10,     3,    12,    0,       0,       16/
  1106.       DATA KSTC17 /    6,     3,    13,    0,       0,       17/
  1107.       DATA KSTC18 /    7,     7,    10,    1,       0,       18/
  1108.       DATA KSTC19 /    8,     7,    47,    0,       0,       19/
  1109.       DATA KSTC20 /    5,    11,    48,    0,       0,       20/
  1110.       DATA KSTC21 /    7,     6,    15,    0,       0,       21/
  1111.       DATA KSTC22 /    5,    11,    3 ,    0,       0,       22/
  1112.       DATA KSTC23 /   10,     3,    17,    0,       0,       23/
  1113.       DATA KSTC24 /    8,     3,    3 ,    0,       0,       24/
  1114.       DATA KSTC25 /    5,     3,    18,    1,       0,       25/
  1115.       DATA KSTC26 /    7,     5,    19,    0,       1,       26/
  1116.       DATA KSTC27 /    7,     2,    20,    1,       0,       27/
  1117.       DATA KSTC28 /    8,     7,    42,    1,       1,       28/
  1118.       DATA KSTC29 /    8,     2,    35,    0,       0,       29/
  1119.       DATA KSTC30 /    5,     7,    23,    0,       0,       30/
  1120.       DATA KSTC31 /    4,     7,    24,    0,       0,       31/
  1121.       DATA KSTC32 /   10,     7,    25,    1,       1,       32/
  1122.       DATA KSTC33 /   10,     7,    26,    1,       1,       33/
  1123.       DATA KSTC34 /   10,     7,    27,    1,       1,       34/
  1124.       DATA KSTC35 /   10,     7,    28,    1,       1,       35/
  1125.       DATA KSTC36 /   10,     7,    29,    1,       1,       36/
  1126.       DATA KSTC37 /   10,     7,    30,    1,       1,       37/
  1127.       DATA KSTC38 /    3,     7,    31,    0,       1,       38/
  1128.       DATA KSTC39 /    7,     3,    46,    0,       0,       39/
  1129.       DATA KSTC40 /    7,     3,    46,    0,       0,       40/
  1130.       DATA KSTC41 /    7,     2,    1 ,    1,       0,       41/
  1131.       DATA KSTC42 /    8,     3,    32,    1,       0,       42/
  1132.       DATA KSTC43 /    5,     6,    3 ,    0,       1,       43/
  1133.       DATA KSTC44 /    5,     7,    33,    0,       1,       44/
  1134.       DATA KSTC45 /    7,     2,    35,    0,       0,       45/
  1135.       DATA KSTC46 /    5,     7,    33,    1,       1,       46/
  1136.       DATA KSTC47 /   10,     7,    36,    0,       0,       47/
  1137.       DATA KSTC48 /    8,     6,    37,    0,       0,       48/
  1138.       DATA KSTC49 /    5,     7,    38,    0,       1,       49/
  1139.       DATA KSTC50 /    4,     7,    33,    0,       1,       50/
  1140.       DATA KSTC51 /    4,     3,    46,    0,       0,       51/
  1141.       DATA KSTC52 /    6,     6,    39,    0,       0,       52/
  1142.       DATA KSTC53 /    7,     7,    47,    0,       0,       53/
  1143.       DATA KSTC54 /    7,     9,    34,    1,       0,       54/
  1144.       DATA KSTC55 /   10,     6,    40,    1,       0,       55/
  1145.       DATA KSTC56 /    4,     6,    41,    0,       1,       56/
  1146.       DATA KSTC57 /   10,     2,    35,    0,       0,       57/
  1147.       DATA KSTC58 /    4,     7,    33,    1,       0,       58/
  1148.       DATA KSTC59 /   10,     7,    44,    0,       1,       59/
  1149.       DATA KSTC60 /    9,     6,    45,    0,       1,       60/
  1150.       DATA KSTC61 /    6,     7,    38,    0,       1,       61/
  1151.       DATA KSTC62 /    7,     9,    34,    1,       0,       62/
  1152.       DATA KSTC63 /    5,     9,    22,    1,       0,       63/
  1153.       DATA KSTC64 /    9,     3,    21,    1,       0,       64/
  1154.       DATA KSTC65 /    8,     3,    3 ,    0,       0,       65/
  1155.       DATA KSTC66 /    5,     3,    3 ,    1,       0,       66/
  1156.       DATA KSTC67 /    6,    11,    43,    0,       1,       67/
  1157.       DATA KSTC68 /    4,    11,    49,    0,       0,       68/
  1158.       DATA KSTC69 /    4,    11,     3,    0,       0,       69/
  1159.       DATA KSTC70 /    6,     7,    47,    0,       0,       70/
  1160.       DATA KSTC71 /    7,     3,    3 ,    1,       1,       71/
  1161.       DATA KSTC72 /    8,     7,    47,    0,       1,       72/
  1162.       DATA KSTC73 /    9,     3,    3 ,    0,       0,       73/
  1163.       DATA KSTC74 /    5,     7,    47,    0,       1,       74/
  1164.       DATA KSTC75 /    9,     3,    3 ,    0,       1,       75/
  1165.       DATA KSTC76 /    4,     3,    3 ,    0,       0,       76/
  1166.       DATA KSTC77 /    9,     6,    3 ,    0,       0,       77/
  1167.       DATA KSTC78 /    5,     7,    50,    1,       1,       81/
  1168.       DATA KSTC79 /    6,     6,    3 ,    0,       0,       79/
  1169.       DATA KSTC80 /    5,     6,    3 ,    0,       0,       80/
  1170.       DATA KSTC81 /    3,     8,    16,    0,       0,       78/
  1171.       DATA KSTC82 /    8,    11,    51,    1,       0,       82/
  1172.       DATA KSTC83 /    6,     7,    50,    1,       1,       83/
  1173. C                   NINS  KLASS  JTYPE NANSI   KSTROK     KPOS
  1174.       END
  1175.       LOGICAL FUNCTION BAKSCN (C1,C2)
  1176. C
  1177. C     SCANS A STRING BACKWARD FROM CURRENT POSITION FOR C1 AND C2
  1178.       CHARACTER*2 C1, C2, JT, KUPPER, JNT
  1179.       INCLUDE 'TIDY.INC'
  1180.       IP = JCOL
  1181. C     FIRST BACK TO LCPY
  1182.     5 IF (JINT(IP).NE.LCPY) THEN
  1183.            IP = IP-1
  1184.            GO TO 5
  1185.       END IF
  1186. C
  1187. C     NOW SCAN FOR C1, C2
  1188.       JT = C1
  1189.       I = 1
  1190.    15 IP = IP-1
  1191.       JNT=KUPPER(JINT(IP))
  1192.       IF (JNT.EQ.KBL) GO TO 15
  1193.       IF (JNT.NE.JT) THEN
  1194.            BAKSCN = .FALSE.
  1195.            RETURN
  1196.       ENDIF
  1197.       IF (I.EQ.1) THEN
  1198.            JT = C2
  1199.            I = 2
  1200.            GO TO 15
  1201.       ENDIF
  1202.       BAKSCN = .TRUE.
  1203.       RETURN
  1204.       END
  1205.       SUBROUTINE COPY (N)
  1206. C
  1207. C     COPY NON-BLANK CHARACTERS FROM JINT TO IOUT.
  1208. C
  1209. C                        ===   ON ENTRY   ===
  1210. C     N .LT. 0 COPIES UNTIL PARENTHESIS COUNT IS ZERO.
  1211. C     N .EQ. 0 COPIES ALL REMAINING NON-BLANK DATA FROM JINT TO IOUT.
  1212. C     N .GT. 0 COPIES N NON-BLANK DATA FROM JINT TO IOUT.
  1213. C     THE FIRST ITEM INSPECTED IS JINT(JCOL).
  1214. C     THE FIRST ITEM STORED GOES TO IOUT(ICOL+1).
  1215. C
  1216. C                        ===   ON EXIT   ===
  1217. C     THE LAST ITEM INSPECTED WAS JINT(JCOL-1).
  1218. C     THE LAST ITEM STORED WENT TO IOUT(ICOL) AND IS IN LCPY.
  1219. C
  1220. C     MEOF .LT. 0  FOR NORMAL EXIT.
  1221. C     MEOF .EQ. 0  FOR KERM FOUND WHILE COPYING  ALL REMAINING DATA,
  1222. C                  OR FOR KERM FOUND BEFORE LEFT PARENTHESIS.
  1223. C     MEOF .GT. 0  FOR MISSING RIGHT PARENTHESIS, OR FOR MEOF =0 ON
  1224. C                  ENTRY TO COPY.
  1225. C
  1226.       INCLUDE 'TIDY.INC'
  1227.       CHARACTER*2 JT
  1228.       NT=N
  1229.       IF (MEOF.LT.0) GO TO 20
  1230.  10   MEOF=1
  1231.       LCPY=KERM
  1232.       RETURN
  1233. C
  1234.  20   IF (JCOL.GT.JMAX) GO TO 10
  1235. C
  1236.       IF (NT) 100,40,70
  1237. C
  1238. C     COPY ALL REMAINING NON-BLANK CHARACTERS.
  1239. C
  1240.  30   JCOL=JCOL+1
  1241.  40   JT=JINT(JCOL)
  1242.       IF (JT.NE.KBL) THEN
  1243.            ICOL=ICOL+1
  1244.            IOUT(ICOL)=JT
  1245.       END IF
  1246.       IF (JT.NE.KERM) GO TO 30
  1247.  50   LCPY=KERM
  1248.       ICOL=ICOL-1
  1249.       MEOF=0
  1250.       RETURN
  1251. C
  1252. C     COPY --N-- NON-BLANK CHARACTERS.
  1253. C
  1254.  60   JCOL=JCOL+1
  1255.  70   JT=JINT(JCOL)
  1256.       IF (JT.NE.KBL) THEN
  1257.            ICOL=ICOL+1
  1258.            IOUT(ICOL)=JT
  1259.            NT=NT-1
  1260.            IF (NT.EQ.0) GO TO 80
  1261.            IF (JT.EQ.KERM) GO TO 50
  1262.       END IF
  1263.       GO TO 60
  1264.  80   JCOL=JCOL+1
  1265.       LCPY=JT
  1266.       RETURN
  1267. C
  1268. C     COPY TO PARENTHESIS COUNT OF ZERO.
  1269. C     LOOK FOR LEFT PARENTHESIS.
  1270. C
  1271.  90   JCOL=JCOL+1
  1272.  100  JT=JINT(JCOL)
  1273.       IF (JT.NE.KBL) THEN
  1274.            ICOL=ICOL+1
  1275.            IOUT(ICOL)=JT
  1276.            LCPY=JT
  1277.            IF (JT.EQ.KSPK(3)) GO TO 110
  1278.            IF (JT.EQ.KSPK(5)) GO TO 140
  1279.            IF (JT.EQ.KERM) GO TO 50
  1280.       END IF
  1281.       GO TO 90
  1282. C
  1283. C     HAVE LEFT PARENTHESIS, LOOK FOR PARENTHESIS COUNT OF ZERO.
  1284. C
  1285.  110  NPAR=1
  1286.  120  JCOL=JCOL+1
  1287.       JT=JINT(JCOL)
  1288.       IF (JT.NE.KBL) THEN
  1289.            ICOL=ICOL+1
  1290.            IOUT(ICOL)=JT
  1291.            LCPY=JT
  1292.            IF (JT.NE.KSPK(3)) THEN
  1293.                 IF (JT.NE.KSPK(5)) THEN
  1294.                       IF (JT.NE.KERM) GO TO 120
  1295.                       CALL DIAGNO (2)
  1296.                       LCPY=KERM
  1297.                       GO TO 150
  1298.                 ENDIF
  1299.                 NPAR=NPAR-1
  1300.                 IF (NPAR) 140,80,120
  1301.            END IF
  1302.            NPAR=NPAR+1
  1303.       END IF
  1304.       GO TO 120
  1305.  140  CALL DIAGNO (3)
  1306.  150  MEOF=1
  1307.       JCOL=JCOL+1
  1308.       RETURN
  1309.       END
  1310.       SUBROUTINE CPYSTR (IPT,STR)
  1311.       INCLUDE 'TIDY.INC'
  1312.       CHARACTER*2 KCTRAN
  1313.       CHARACTER*(*) STR
  1314.       IP=IPT
  1315.       DO 10 I=1,LEN(STR)
  1316.            IOUT(IP)=STR(I:I)
  1317.            IF (MCASE.EQ.0) IOUT(IP)=KCTRAN(IOUT(IP))
  1318.            IP=IP+1
  1319.  10   CONTINUE
  1320.       RETURN
  1321.       END
  1322.       SUBROUTINE DIAGNO (N)
  1323.       PARAMETER (MXMSG=43)
  1324. C
  1325. C     THIS ROUTINE WRITES THE GENERAL DIAGNOSTICS FOR TIDY.
  1326. C
  1327.       DIMENSION LV(MXMSG)
  1328.       INCLUDE 'TIDY.INC'
  1329.       INCLUDE 'UNITS.INC'
  1330. C     ***                                                            ***
  1331. C      1 THE ABOVE STATEMENT IS ILLEGAL AND HAS BEEN DELETED.
  1332. C      2 THE ABOVE STATEMENT HAS A MISSING RIGHT PARENTHESIS.
  1333. C      3 THE ABOVE STATEMENT HAS AN EXCESS RIGHT PARENTHESIS.
  1334. C      4 THE ABOVE STATEMENT INCORRECTLY TERMINATES A DO LOOP.
  1335. C      5 THE ABOVE STATEMENT CANNOT BE REACHED BY THE PROGRAM.
  1336. C      6 STATEMENT NUMBER TABLE FULL.  RENUMBER PASS DELETED.
  1337. C      7 REFERENCE NUMBER TABLE FULL.  RENUMBER PASS DELETED.
  1338. C      8 THE ABOVE STATEMENT IS OBSOLETE AND IS DELETED.
  1339. C      9 ABOVE STATEMENT HAS AN ILLEGAL FIRST SPECIAL CHARACTER.
  1340. C     10 ILLEGAL DATA, FUNCTION, OR SUBROUTINE STATEMENT.
  1341. C     11 THE ABOVE COMMON OR DATA STATEMENT IS MISSING A (/).
  1342. C     12 THE ABOVE CONTINUE STATEMENT IS REDUNDANT AND IS DELETED.
  1343. C     13 THE ABOVE DIMENSION STATEMENT IS NOT COMPLETE.
  1344. C     14 W A R N I N G .  STATEMENT SHOULD BE FIRST IN ROUTINE.
  1345. C     15 THE ABOVE DO STATEMENT HAS AN INVALID TERMINAL STATEMENT.
  1346. C     16 W A R N I N G .  UNSATISFIED DO LOOPS.
  1347. C     17 UNNUMBERED OR INVALID FORMAT STATEMENT DELETED.
  1348. C     18 WARNING.  ABOVE STATEMENT IS POOR PROGRAMMING PRACTICE.
  1349. C     19 ABOVE GO TO STATEMENT IS ILLEGAL.
  1350. C     20 ILLEGAL ARITHMETIC IF STATEMENT.   IF (ARITH) 1,2,3
  1351. C     21 ABOVE NAMELIST STATEMENT MISSING (/).
  1352. C     22 ILLEGAL READ, WRITE , OR PUNCH STATEMENT.
  1353. C     23 ILLEGAL READ (12) LIST, OR WRITE (12) LIST, STATEMENT.
  1354. C     24 DO LOOP TABLE FULL.  RENUMBER PASS DELETED.
  1355. C     25 W A R N I N G .   COMMA FOLLOWING X INSERTED IN ABOVE FORMAT.
  1356. C     26 TIDY CANNOT PROCESS THIS CLASS OF PROGRAM.  (COPY EXECUTED.)
  1357. C     27 WARNING.  ABOVE DO-LOOP TERMINUS PREVIOUSLY REFERENCED.
  1358. C     28 WARNING.  TIDY MAY HAVE CHANGED CARD 2 OF THIS ROUTINE
  1359. C     29 W A R N I N G .   END CARD INSERTED.
  1360. C     30 THE ABOVE STATEMENT IS TRANSMITTED WITHOUT PROCESSING
  1361. C     31 ILLEGAL CLOSE, INQUIRE, OR OPEN STATEMENT
  1362. C     32 W A R N I N G .   UNBALANCED ELSE/ELSEIF/ENDIF STATEENT
  1363. C     33 W A R N I N G .   UNSATISFIED IF BLOCKS.
  1364. C     34 W A R N I N G .   ABOVE STATEMENT NOT ANSI FORTRAN 77
  1365. C     35 TOO MANY REFERENCES IN ABOVE. RENUMBER PASS DELETED.
  1366. C     36 W A R N I N G .   NON-ANSI (L OR R) HOLLERITH SPEC.
  1367. C     37 ABOVE STATEMENT HAS MORE THAN 19 CONTINUATION LINES.
  1368. C     38 CCHR CARD IGNORED:   CANNOT USE ZERO.
  1369. C     39 >>> HOLLERITH CONSTANT CONVERTED <<<
  1370. C     40 W A R N I N G.   *PRECISION ON NUMERIC/LOGICAL VARS NOT ANSI
  1371. C     41 W A R N I N G.    VARIABLE NAME LONGER THAN 6 CHARACTERS
  1372. C     42 W A R N I N G.    INITIALIZED TYPE DECLARATIONS NOT ANSI
  1373. C     43 MORE <END DO> THAN <DO> STATEMENTS
  1374. C
  1375.       CHARACTER*60 ERMSG (MXMSG)
  1376.       DATA (ERMSG(I),I=1,15)/
  1377.      1'THE ABOVE STATEMENT IS ILLEGAL AND HAS BEEN DELETED.',
  1378.      1'THE ABOVE STATEMENT HAS A MISSING RIGHT PARENTHESIS.',
  1379.      1'THE ABOVE STATEMENT HAS AN EXCESS RIGHT PARENTHESIS.',
  1380.      1'THE ABOVE STATEMENT INCORRECTLY TERMINATES A DO LOOP.',
  1381.      1'THE ABOVE STATEMENT CANNOT BE REACHED BY THE PROGRAM.',
  1382.      1'STATEMENT NUMBER TABLE FULL.  RENUMBER PASS DELETED.',
  1383.      1'REFERENCE NUMBER TABLE FULL.  RENUMBER PASS DELETED.',
  1384.      1'THE ABOVE STATEMENT IS OBSOLETE AND IS DELETED.',
  1385.      1'ABOVE STATEMENT HAS AN ILLEGAL FIRST SPECIAL CHARACTER.',
  1386.      1'ILLEGAL DATA, FUNCTION, OR SUBROUTINE STATEMENT.',
  1387.      1'THE ABOVE COMMON OR DATA STATEMENT IS MISSING A (/).',
  1388.      1'THE ABOVE CONTINUE STATEMENT IS REDUNDANT AND IS DELETED.',
  1389.      1'THE ABOVE DIMENSION STATEMENT IS NOT COMPLETE.',
  1390.      1'W A R N I N G .  STATEMENT SHOULD BE FIRST IN ROUTINE.',
  1391.      1'THE ABOVE DO STATEMENT HAS AN INVALID TERMINAL STATEMENT.'/
  1392.       DATA (ERMSG(I),I=16,30)/
  1393.      1'W A R N I N G .  UNSATISFIED DO LOOPS.',
  1394.      1'UNNUMBERED OR INVALID FORMAT STATEMENT DELETED.',
  1395.      1'WARNING.  ABOVE STATEMENT IS POOR PROGRAMMING PRACTICE.',
  1396.      1'ABOVE GO TO STATEMENT IS ILLEGAL.',
  1397.      1'ILLEGAL ARITHMETIC IF STATEMENT.   IF (ARITH) 1,2,3',
  1398.      1'ABOVE NAMELIST STATEMENT MISSING (/).',
  1399.      1'ILLEGAL READ, WRITE , OR PUNCH STATEMENT.',
  1400.      1'ILLEGAL READ (12) LIST, OR WRITE (12) LIST, STATEMENT.',
  1401.      1'DO LOOP TABLE FULL.  RENUMBER PASS DELETED.',
  1402.      1'W A R N I N G .  COMMA INSERTED FOLLOWING X IN ABOVE FORMAT.',
  1403.      1'TIDY CANNOT PROCESS THIS CLASS OF PROGRAM.  (COPY EXECUTED.)',
  1404.      1'WARNING.  ABOVE DO-LOOP TERMINUS PREVIOUSLY REFERENCED.',
  1405.      1'WARNING.  TIDY MAY HAVE CHANGED CARD 2 OF THIS ROUTINE',
  1406.      1'W A R N I N G .  END CARD INSERTED.',
  1407.      1'THE ABOVE STATEMENT IS TRANSMITTED WITHOUT PROCESSING.'/
  1408.       DATA (ERMSG(I),I=31,MXMSG)/
  1409.      1'ILLEGAL CLOSE, INQUIRE, OR OPEN STATEMENT',
  1410.      1'W A R N I N G .   UNBALANCED ELSE/ELSEIF/ENDIF STATEMENT',
  1411.      1'W A R N I N G .   UNSATISFIED IF BLOCKS.',
  1412.      1'W A R N I N G .   ABOVE STATEMENT NOT ANSI FORTRAN 77.',
  1413.      1'TOO MANY REFERENCES IN ABOVE. RENUMBER PASS DELETED.',
  1414.      1'W A R N I N G .   NON-ANSI (L OR R) HOLLERITH SPEC.',
  1415.      1'ABOVE STATEMENT HAS MORE THAN 19 CONTINUATION LINES.',
  1416.      1'CCHR CARD IGNORED:   CANNOT USE ZERO.',
  1417.      1'>>> HOLLERITH CONSTANT CONVERTED <<<',
  1418.      1'W A R N I N G. *n PRECISION ON NUMERIC/LOGICAL VARS NOT ANSI',
  1419.      1'W A R N I N G.    VARIABLE NAME LONGER THAN 6 CHARACTERS',
  1420.      1'W A R N I N G.    INITIALIZED TYPE DECLARATIONS NOT ANSI',
  1421.      1'MORE <END DO> THAN <DO> STATEMENTS'/
  1422.  
  1423. C
  1424. C     LV=0 - TIDY USER WARNING - CAUSES NORMAL TERMINATION
  1425. C        1 - MINOR FORTRAN ERROR - STOP 4
  1426. C        2 - MAJOR FORTRAN ERROR - STOP 8
  1427.       DATA LV /2,2,2,2,1 ,2,2,2,2,2 ,2,1,2,1,2 ,2,1,1,2,2
  1428.      1        ,2,2,2,2,0 ,0,0,1,1,1 ,2,1,2,0,2 ,0,2,0,0,0
  1429.      2        ,0,0,2/
  1430. C
  1431.       J=N
  1432.       IF (J.LE.0.OR.J.GT.MXMSG) J=1
  1433.       NMSG=NMSG+1
  1434.       IF (LERR.LT.LV(J)) LERR=LV(J)
  1435.       IF (MLIST.EQ.-1) GO TO 10
  1436.          CALL PAGE ((JMAX-7)/66+4)
  1437.          WRITE (OUTFIL,320) (JINT(I),I=1,JMAX)
  1438.          GO TO 20
  1439.  10   CALL PAGE (1)
  1440.  20   WRITE (OUTFIL,340) NMSG, ERMSG(J)
  1441. C
  1442.       IF (MLIST.NE.-1) WRITE (OUTFIL,330) NREC,KBUFF
  1443.       RETURN
  1444. C
  1445. C
  1446.  320  FORMAT (7X,72A1,19(/12X,'X',66A1))
  1447.  330  FORMAT (1X,I4,2X,80A1,/'0')
  1448.  340  FORMAT (' ******(',I3,') ***',A60,'******',20X,'**********')
  1449.       END
  1450.       SUBROUTINE DLIST (MERR)
  1451. C
  1452. C     THIS SUBROUTINE UPDATES THE DEFINED STATEMENT NUMBER LIST, LDEF,
  1453. C     BY ADDING THE STATEMENT NUMBER IN L15, IF IT IS UNIQUE.
  1454. C              RETURNS MERR = 0 IF LABEL IS OK.
  1455. C                            -1 IF ERROR
  1456. C                       POSSIBLE ERRORS--
  1457. C                            ILLEGAL DO-LOOP NEST
  1458. C                            DUPLICATE STATEMENT NUMBER
  1459. C                            STATEMENT NUMBER TABLE FULL
  1460. C
  1461.       INCLUDE 'TIDY.INC'
  1462.       INCLUDE 'UNITS.INC'
  1463.       MERR=0
  1464.       DATA JTYPP/0/
  1465.       IF (KLASS.LT.4) THEN
  1466.            JTYPP=JTYPE
  1467.            RETURN
  1468.       END IF
  1469. C
  1470. C     CHECK FOR FORMAT STATEMENT, WHICH IS LABELED BUT CAN'T HAVE
  1471. C      FALL-THRU
  1472.       IF (KLASS.EQ.5) THEN
  1473. C          PROCESS FORMAT STATEMENT
  1474. C           SCAN FOR DUPLICATE STATEMENT NUMBER
  1475.            IF (NDEF.GT.0) THEN
  1476.                 DO 10 I=1,NDEF
  1477.                      IF (IABS(LDEF(I)).EQ.L15) GO TO 60
  1478. 10              CONTINUE
  1479.            END IF
  1480. C
  1481. C          PUT L15 INTO LDEF LIST AFTER LAST NON-NEGATIVE ENTRY
  1482.            IF (NDEF.GE.1500) GO TO 70
  1483.            I=NDEF
  1484.            NDEF=NDEF+1
  1485. 20         IF (I.EQ.0.OR.LDEF(I).GE.0) THEN
  1486.                 LDEF(I+1)=L15
  1487.                 LOCDEF(I+1)=NREC
  1488.                 GO TO 90
  1489.            END IF
  1490.            LDEF(I+1)=LDEF(I)
  1491.            LOCDEF(I+1)=LOCDEF(I)
  1492.            I=I-1
  1493.            GO TO 20
  1494.       END IF
  1495. C
  1496. C     EXECUTABLE STATEMENT (OR END)
  1497.       IF (L15.EQ.0) THEN
  1498. C          UNLABELLED. IS THERE A FALL-THRU...
  1499.            IF (L25.EQ.0) THEN
  1500. C
  1501. C               UNLABELLED STATEMENT. ERROR IF IT FOLLOWS TRANSFER
  1502. C                (EXCEPT COMPUTED GO TO)
  1503.                 IF (NTRAN.NE.0.AND.JTYPP.NE.23) CALL DIAGNO (5)
  1504.            ELSE
  1505. C               THERE IS A FALL-THRU LABEL. USE IT.
  1506.                 L15=L25
  1507.                 L25=0
  1508.                 LDEF(NDEF)=IABS(LDEF(NDEF))
  1509.            END IF
  1510.            GO TO 90
  1511.       END IF
  1512. C               LABELLED. SCRATCH FALL-THRU LABEL
  1513.       L25=0
  1514. C
  1515. C     SCAN FOR DUPLICATE STATEMENT NUMBERS.
  1516. C
  1517.       IF (NDEF.GT.0) THEN
  1518.            DO 30 I=1,NDEF
  1519.                 IF (IABS(LDEF(I)).EQ.L15) GO TO 60
  1520. 30         CONTINUE
  1521.       END IF
  1522. C
  1523.       IF (NDEF.GE.1500) GO TO 70
  1524.       NDEF=NDEF+1
  1525.       LDEF(NDEF)=L15
  1526.       LOCDEF(NDEF)=NREC
  1527. C
  1528. C     SCAN FOR POSSIBLE DO-LOOP TERMINATIONS.
  1529. C
  1530.       IF (NDOS.LE.0) GO TO 90
  1531.       DO 50 I=1,NDOS
  1532.            IF (LDOS(I).EQ.L15) THEN
  1533. C                            ITS IN THE LIST
  1534.                 IF (I.NE.NDOS) THEN
  1535. C                            ILLEGAL DO-LOOP NEST
  1536.                      NMSG=NMSG+1
  1537.                      CALL PAGE (1)
  1538.                      WRITE (OUTFIL,100) NMSG,I,NDOS
  1539. C
  1540. C     COMPRESS DO-LOOP TERMINAL LIST AFTER DELETIONS.
  1541. C
  1542.                      NDOS=NDOS-1
  1543.                      DO 40 J=I,NDOS
  1544.                           LDOS(J)=LDOS(J+1)
  1545. 40                   CONTINUE
  1546.                      GO TO 80
  1547.                 END IF
  1548. C                            LAST ONE IN LIST. REMOVE IT
  1549.                 NDOS=NDOS-1
  1550.                 IF (MILDO.NE.0) CALL DIAGNO (4)
  1551.                 GO TO 90
  1552.            END IF
  1553. 50    CONTINUE
  1554.       GO TO 90
  1555. C
  1556. C     ERROR DIAGNOSTICS.
  1557. C
  1558. C                            DUPLICATE STATEMENT NUMBER
  1559. 60    NMSG=NMSG+1
  1560.       CALL PAGE (1)
  1561.       WRITE (OUTFIL,110) NMSG,L15,LOCDEF(I)
  1562.       GO TO 80
  1563. C                            NUMBER TABLE FULL
  1564. 70    CALL DIAGNO (6)
  1565.       NDEF=-1
  1566.       MP2=0
  1567. C                            ERROR EXIT
  1568. 80    MPUN=0
  1569.       MERR=-1
  1570. C                            EXIT
  1571. 90    MILDO=0
  1572.       NXEQ=NXEQ+1
  1573.       JTYPP=JTYPE
  1574.       RETURN
  1575. C
  1576. C
  1577. 100   FORMAT (' ****  (',I3,') *** DO LOOP LEVEL',I2,' TERMINATES WHILE
  1578.      1LEVEL',I2,' IS IN EFFECT.     ***')
  1579. 110   FORMAT (' ****  (',I3,') *** STATEMENT NUMBER',I6,' DUPLICATES THE
  1580.      1 NUMBER AT',I4,'.',8X,'***')
  1581.       END
  1582.       INTEGER FUNCTION DOSDEV(FILEID)
  1583.       CHARACTER FILEID*(*)
  1584. C
  1585. C     RETURNS .TRUE. IF ARGUMENT IS A DOS-RESERVED NAME.
  1586. C     (SO OPFIL WON'T COMPLAIN ABOUT IT EXISTING)
  1587. C
  1588.       CHARACTER*2 KUPPER, IT
  1589.       CHARACTER*4 DEVID(9)
  1590.       DATA DEVID/'PRN','CON','NUL','AUX','LPT1','LPT2','LPT3','COM1','CO
  1591.      1M2'/, IT/'  '/
  1592. C
  1593. C     CONVERT FILEID TO UPPER CASE, FIND END OF STRING.
  1594.       LENPAT=LEN(FILEID)
  1595.       DO 10 I=1,LENPAT
  1596.            IF (FILEID(I:I).EQ.' ') THEN
  1597.                 LENPAT=I-1
  1598.                 GO TO 20
  1599.            END IF
  1600.            IT(1:1)=FILEID(I:I)
  1601.            IT=KUPPER(IT)
  1602.            FILEID(I:I)=IT(1:1)
  1603.  10   CONTINUE
  1604. C
  1605. C     BE SURE NO LEADING BLANKS.
  1606.  20   ISTRT=1
  1607.       DO 30 I=1,LENPAT
  1608.            IF (FILEID(I:I).NE.' ') GO TO 40
  1609.            ISTRT=ISTRT+1
  1610.            LENPAT=LENPAT-1
  1611.  30   CONTINUE
  1612. C
  1613. C     COMPARE ARG TO LIST OF RESERVED DEVICES.
  1614.  40   LENRES=3
  1615.       KEND=ISTRT+LENRES-1
  1616.       DO 50 I=1,9
  1617.            IF (FILEID(ISTRT:KEND).EQ.DEVID(I)(1:LENRES).AND.LENPAT.EQ.LE
  1618.      1NRES) THEN
  1619.                 DOSDEV=I
  1620.                 RETURN
  1621.            END IF
  1622.            IF (I.EQ.4) THEN
  1623.                 KEND=KEND+1
  1624.                 LENRES=4
  1625.            END IF
  1626.  50   CONTINUE
  1627.       DOSDEV=0
  1628.       RETURN
  1629.       END
  1630.       SUBROUTINE EDIT
  1631. C
  1632. C     THIS SUBROUTINE EDITS THE DEFINED AND THE REFERENCED STATEMENT
  1633. C     NUMBER LIST.
  1634. C
  1635. C     ON ENTRY, LDEF(I) CONTAINS THE STATEMENT LABELS, IN THE
  1636. C     ORDER IN WHICH THEY WERE USED.  THE LABELS OF CONTINUE
  1637. C     STATEMENTS WHICH WERE NOT PASSED ON ARE NEGATIVE.
  1638. C     LOCDEF(I) CONTAINS THE CARD NUMBER (NREC) OF THE LINE
  1639. C     IDENTIFIED BY THAT LABEL.  EXCEPTION FOR DOUBLE BRANCHES--
  1640. C     IF LDEF(I)=0, THEN THE STATEMENT WITH THE LABEL LDEF(I-1)
  1641. C     WAS A GOTO.  THE TARGET LABEL IS IN LOCDEF(I).
  1642. C
  1643. C     (1)     DEFINED STATEMENTS THAT ARE NOT REFERENCED ARE DELETED.
  1644. C     (2)     THE NEW STATEMENT NUMBERS ARE GENERATED
  1645. C     (3)     A STATEMENT NUMBER WHICH IS NEGATIVE IN THE LDEF
  1646. C             LIST IS ASSIGNED A NEW STATEMENT NUMBER THE SAME
  1647. C             AS THE NEXT POSITIVE LABEL IN THE LDEF LIST
  1648. C     (4)     A LABEL FOLLOWED BY A ZERO IN THE LDEF LIST IS
  1649. C             ASSIGNED A NEW STATEMENT NUMBER THE SAME AS THE
  1650. C             STATEMENT NUMBER ASSIGNED TO THE LABEL GIVEN IN
  1651. C             THE LOCREF ARRAY.  (FOR DOUBLE BRANCHES)
  1652. C     (5)     PSEUDO-STATEMENT NUMBERS OUTSIDE THE RANGE OF RENUMBERED
  1653. C             DEFINED STATEMENT NUMBERS ARE GENERATED FOR EACH
  1654. C             REFERENCED STATEMENT WHICH IS NOT DEFINED.
  1655. C
  1656.       INCLUDE 'TIDY.INC'
  1657.       INCLUDE 'UNITS.INC'
  1658.       IF (NREF.LE.0) NDEF=0
  1659.       IF (NDEF.LE.0) RETURN
  1660. C
  1661.       IF (MDEB.NE.0) THEN
  1662.            WRITE (OUTFIL,140) NDEF,NREF
  1663.            WRITE (OUTFIL,150) (LDEF(I),I=1,NDEF)
  1664.            WRITE (OUTFIL,160) (NEWNUM(I),I=1,NDEF)
  1665.            WRITE (OUTFIL,170) (LOCDEF(I),I=1,NDEF)
  1666.            WRITE (OUTFIL,180) (LREF(I),I=1,NREF)
  1667.       END IF
  1668. C
  1669. C     SET UP NEWNUM SO THAT IF LDEF(I) NEEDS A NEW NUMBER,
  1670. C     NEWNUM(I)=0. IF LDEF(I) WILL REFERENCE LDEF(J), THEN
  1671. C     NEWNUM(I)=-LDEF(J).  REMOVE ENTRIES WITH LDEF(I)=0
  1672. C
  1673.       IT=0
  1674.       DO 20 I=1,NDEF
  1675.            IF (LDEF(I).GT.0) THEN
  1676. C                            POSITIVE IS NORMAL
  1677.                 IT=IT+1
  1678.                 NEWNUM(IT)=0
  1679.                 LDEF(IT)=LDEF(I)
  1680.            ELSE IF (LDEF(I).EQ.0) THEN
  1681. C                            ZERO MEANS LAST WAS A BRANCH
  1682.                 NEWNUM(IT)=-LOCDEF(I)
  1683.                 GO TO 20
  1684.            ELSE
  1685. C                            NEGATIVE MEANS CONTINUE. LOOK AHEAD
  1686.                 J=I
  1687.  10             J=J+1
  1688.                 IF (LDEF(J).LT.0.OR.LOCDEF(J).LT.0) GO TO 10
  1689. C                            CHECK FOR A FORMAT STATEMENT
  1690.                 IT=IT+1
  1691.                 NEWNUM(IT)=-LDEF(J)
  1692.                 IF (LDEF(J).EQ.0) NEWNUM(IT)=-IABS(LDEF(J-1))
  1693.                 LDEF(IT)=IABS(LDEF(I))
  1694.            END IF
  1695.            LOCDEF(IT)=IABS(LOCDEF(I))
  1696.  20   CONTINUE
  1697.       NDEF=IT
  1698. C
  1699.       IF (MDEB.NE.0) THEN
  1700.            WRITE (OUTFIL,150) (LDEF(I),I=1,NDEF)
  1701.            WRITE (OUTFIL,160) (NEWNUM(I),I=1,NDEF)
  1702.            WRITE (OUTFIL,170) (LOCDEF(I),I=1,NDEF)
  1703.            WRITE (OUTFIL,180) (LREF(I),I=1,NREF)
  1704.       END IF
  1705. C
  1706. C     LDEF NOW CONTAINS DEFINED STATEMENT NUMBERS. LOCDEF(I)
  1707. C     HAS LINE NUMBER OF LDEF(I).  NEWNUM(I) HAS ZERO IF LDEF(I)
  1708. C     WILL NEED A NEW NUMBER, AND -NNN IF REFERENCES TO LDEF(I)
  1709. C     SHOULD BE CHANGED TO REFERENCES TO NNN.
  1710. C
  1711. C     FOR EACH LREF, SCAN LDEF FOR CHAINS.  BE SURE
  1712. C     TARGETS OF GOTOS ARE REFERENCED ALSO.
  1713. C
  1714.       IT=NREF
  1715.       DO 50 I=1,IT
  1716.            I1=LREF(I)
  1717. C                            GET REFERENCE IN LDEF
  1718.            DO 40 IC=1,50
  1719.                 DO 30 J=1,NDEF
  1720.                      IF (I1.EQ.LDEF(J)) THEN
  1721. C                               NEXT LINK IN CHAIN
  1722.                           I1=IABS(NEWNUM(J))
  1723.                           IF (I1.EQ.0) GO TO 50
  1724.                           L772=I1
  1725. C                            ADD TARGET TO REF LIST
  1726.                           CALL RLIST
  1727.                           GO TO 50
  1728.                      END IF
  1729.  30             CONTINUE
  1730. C                               NOT DEFINED
  1731.                 GO TO 50
  1732.  40        CONTINUE
  1733.  50   CONTINUE
  1734. C
  1735.       IF (MDEB.NE.0) THEN
  1736.            WRITE (OUTFIL,150) (LDEF(I),I=1,NDEF)
  1737.            WRITE (OUTFIL,160) (NEWNUM(I),I=1,NDEF)
  1738.            WRITE (OUTFIL,170) (LOCDEF(I),I=1,NDEF)
  1739.            WRITE (OUTFIL,180) (LREF(I),I=1,NREF)
  1740.       END IF
  1741. C
  1742. C     SCAN DEFINED LIST FOR REFERENCES.  DELETE NON-REFERENCED
  1743. C     DEFINED STATEMENT NUMBERS.
  1744. C
  1745.       IT=0
  1746.       NNUM=0
  1747.       DO 70 I=1,NDEF
  1748.            DO 60 J=1,NREF
  1749.                 IF (LDEF(I).EQ.LREF(J)) THEN
  1750.                      IF (NEWNUM(I).EQ.0) THEN
  1751. C                            MAKE NEW NUMBER
  1752.                           NNUM=NNUM+1
  1753.                           NEWNUM(I)=KD15*NNUM+KB15
  1754.                      END IF
  1755.                      IT=IT+1
  1756.                      LDEF(IT)=LDEF(I)
  1757.                      NEWNUM(IT)=NEWNUM(I)
  1758.                      LOCDEF(IT)=LOCDEF(I)
  1759.                      GO TO 70
  1760.                 END IF
  1761.  60        CONTINUE
  1762. C                            NOT REFERENCED
  1763.  70   CONTINUE
  1764.       NDEF=IT
  1765. C
  1766.       IF (MDEB.NE.0) THEN
  1767.            WRITE (OUTFIL,150) (LDEF(I),I=1,NDEF)
  1768.            WRITE (OUTFIL,160) (NEWNUM(I),I=1,NDEF)
  1769.            WRITE (OUTFIL,170) (LOCDEF(I),I=1,NDEF)
  1770.            WRITE (OUTFIL,180) (LREF(I),I=1,NREF)
  1771.       END IF
  1772. C
  1773. C     SCAN LDEF FOR INDIRECT REFERENCES AND REPLACE THEM
  1774. C
  1775.       IT=0
  1776.       DO 110 I=1,NDEF
  1777.            DO 90 IC=1,10
  1778.                 IF (NEWNUM(I).GT.0) GO TO 110
  1779.                 I1=IABS(NEWNUM(I))
  1780.                 DO 80 J=1,NDEF
  1781.                      IF (LDEF(J).EQ.I1) THEN
  1782.                           NEWNUM(I)=NEWNUM(J)
  1783.                           GO TO 90
  1784.                      END IF
  1785.  80             CONTINUE
  1786.                 STOP 45
  1787.  90        CONTINUE
  1788. C                            LOOP OF GOTO-S. BREAK IT
  1789.            IF (IT.NE.0) GO TO 100
  1790.            IT=1
  1791.            CALL PAGE (-20)
  1792.            CALL PAGE (1)
  1793.            WRITE (OUTFIL,220)
  1794.            WRITE (OUTFIL,210)
  1795.  100       NNUM=NNUM+1
  1796.            NEWNUM(I)=KD15*NNUM+KB15
  1797.            NMSG=NMSG+1
  1798.            CALL PAGE (1)
  1799.            WRITE (OUTFIL,190) NMSG,I1,NEWNUM(I)
  1800.  110  CONTINUE
  1801. C
  1802. C     SCAN REFERENCED STATEMENT LIST FOR MISSING DEFINITIONS.
  1803. C
  1804.       IT=0
  1805.       DO 130 I=1,NREF
  1806.            DO 120 J=1,NDEF
  1807.                 IF (LREF(I).EQ.LDEF(J)) GO TO 130
  1808.  120       CONTINUE
  1809. C
  1810. C     ADD PSEUDO-STATEMENT NUMBER.
  1811. C
  1812.            LERR=2
  1813.            IF (IT.LE.0) THEN
  1814.                 IT=1
  1815.                 CALL PAGE (-20)
  1816.                 CALL PAGE (4)
  1817.                 WRITE (OUTFIL,200)
  1818.                 WRITE (OUTFIL,210)
  1819.            END IF
  1820.            NDEF=NDEF+1
  1821.            IF (NDEF.GT.1500) THEN
  1822.                 CALL DIAGNO (6)
  1823.                 NDEF=-1
  1824.                 MP2=0
  1825.                 RETURN
  1826.            END IF
  1827.            LDEF(NDEF)=LREF(I)
  1828.            LOCDEF(NDEF)=0
  1829.            NEWNUM(NDEF)=NDEF*KD15+KB15
  1830.            NMSG=NMSG+1
  1831.            CALL PAGE (1)
  1832.            WRITE (OUTFIL,190) NMSG,LREF(I),NEWNUM(NDEF)
  1833.  130  CONTINUE
  1834.       RETURN
  1835. C
  1836. C
  1837.  140  FORMAT ('0FOLLOWING *DEBUG OUTPUT FROM SUBR EDIT'/' NDEF = ',I7,'
  1838.      1 NREF = ',I7)
  1839.  150  FORMAT (' LDEF  ',9I7)
  1840.  160  FORMAT (' NEWNUM',9I7)
  1841.  170  FORMAT (' LOCDEF',9I7)
  1842.  180  FORMAT (' LREF  ',9I7)
  1843.  190  FORMAT (7X,'(',I3,') *** STATEMENT NUMBER',I7,' IS ASSIGNED NUMBER
  1844.      1',I7,'.',13X,'***')
  1845.  200  FORMAT ('0',12X,'*** THE FOLLOWING REFERENCED STATEMENTS ARE NOT D
  1846.      1EFINED')
  1847.  210  FORMAT (13X,'*** PSEUDO-STATEMENT NUMBERS HAVE BEEN ASSIGNED.'/' '
  1848.      1)
  1849.  220  FORMAT ('0',12X,'*** THE FOLLOWING STATEMENTS ARE IN ENDLESS CHAIN
  1850.      1S OF GOTO''S.')
  1851.       END
  1852.       SUBROUTINE HEADER
  1853. C
  1854. C                  THIS ROUTINE CENTERS JOB HEADINGS
  1855. C
  1856.       INCLUDE 'TIDY.INC'
  1857.       CHARACTER*2 KUPPER
  1858.       IF (IPASS.EQ.1) THEN
  1859.            DO 10 I=1,72
  1860.                 JOB(I)=JINT(I)
  1861.  10        CONTINUE
  1862.       else
  1863. C
  1864.       DO 20 I=1,80
  1865.            JOB(I)=IOUT(I)
  1866.  20   CONTINUE
  1867. C
  1868.       IF (MSER.LT.0) THEN
  1869. C
  1870. C     SET UP COLUMNS 73-75 BASED ON *LABE OPTION
  1871.            IF (MLBL.EQ.0) THEN
  1872. C     USE *ROUT VALUE
  1873.                 I=(NROUT-1)/26
  1874.                 J=NROUT-I*26
  1875.                 IF (I.EQ.0) THEN
  1876.                      KOL73(3)=KBL
  1877.                      KOL73(2)=KABC(J)
  1878.                 ELSE
  1879.                      KOL73(2)=KABC(I)
  1880.                      KOL73(3)=KABC(J)
  1881.                 END IF
  1882. C
  1883.                 KOL73(1)=KBL
  1884.            ELSE
  1885. C
  1886. C     COPY PROGRAM/SUBROUTINE/FUNCTION CARD SERIAL INFORMATION
  1887.                 DO 30 I=1,3
  1888.                      KOL73(I)=KUPPER(SERIAL(I))
  1889.  30             CONTINUE
  1890.            END IF
  1891.       END IF
  1892.       END IF
  1893. C
  1894.  40   DO 50 I=73,80
  1895.            JOB(I)=KBL
  1896.  50   CONTINUE
  1897. C
  1898. C          COMPRESS STATEMENT BY ELIMINATING MULTIPLE BLANKS
  1899. C
  1900.       J=1
  1901.       K=0
  1902.       DO 80 I=1,80
  1903.            IF (JOB(I).EQ.KBL) THEN
  1904.                 IF (K.EQ.1) GO TO 80
  1905.                 K=1
  1906.            ELSE
  1907.                 K=0
  1908.            END IF
  1909.            JOB(J)=JOB(I)
  1910.            J=J+1
  1911.  80   CONTINUE
  1912.       DO 90 I=J,80
  1913.            JOB(I)=KBL
  1914.  90   CONTINUE
  1915. C
  1916. C                           CENTER HEADING
  1917. C
  1918.       IB=(80-J)/2
  1919.  100  I=J+IB
  1920.       JOB(I)=JOB(J)
  1921.       J=J-1
  1922.       IF (J.GT.0) GO TO 100
  1923. C
  1924. C                   ELIMINATE REMAINING NON-BLANKS
  1925. C
  1926.       IB=I-1
  1927.       DO 110 I=1,IB
  1928.            JOB(I)=KBL
  1929.  110  CONTINUE
  1930.       RETURN
  1931.       END
  1932.       SUBROUTINE HOLSCN (LTYPE,LSSCN,LNSTR)
  1933. C     THIS SUBROUTINE SCANS ALL FORTRAN CARDS FOR FIELDS OF HOLLERITH-
  1934. C     TYPE CONSTANTS.  IN THESE FIELDS,
  1935. C     CHARACTERS ARE REPLACED WITH EQUIVALENT CHARACTERS WHICH WILL NOT
  1936. C     BE TREATED BY ANALYSIS ROUTINES.
  1937. C     THE SEARCH IS MADE BY CHECKING FOR PATTERNS -SNNNL-, WHERE S IS A
  1938. C     SPECIAL CHARACTER, NNN IS A DECIMAL NUMBER, AND L IS THE LETTER H,
  1939. C     L, OR R.  IN ADDITION, FOR FORMAT STATEMENTS ONLY, IT ACCEPTS THE
  1940. C     PATTERN SNNNXNNNL, THE RESULT OF A MISSING -,- AFTER X.
  1941. C
  1942.       INCLUDE 'TIDY.INC'
  1943.       INCLUDE 'UNITS.INC'
  1944.       CHARACTER*2 IT,KPARAM,KUPPER,KCTRAN
  1945.       LOGICAL LHTRN,ISDEL
  1946. C
  1947.       JCOL=6
  1948.       LNSTR=0
  1949.       LNTMP=0
  1950.       NLHTRN=0
  1951. C     IF FORMAT STATEMENT, SKIP FIRST 7 NON-BLANK CHARACTERS
  1952.       IF (LTYPE.EQ.26) THEN
  1953.            DO 20 N=1,7
  1954. 10              JCOL=JCOL+1
  1955.                 IF (JINT(JCOL).EQ.KBL) GO TO 10
  1956.                 IF (MCASE.EQ.0) JINT(JCOL)=KCTRAN(JINT(JCOL))
  1957. 20         CONTINUE
  1958.            GO TO 130
  1959.       END IF
  1960. C
  1961. C                  *****************************************
  1962. C                  *                                       *
  1963. C                  *    PROCESS NON-FORMAT STATEMENTS.     *
  1964. C                  *                                       *
  1965. C                  *****************************************
  1966. C
  1967.       LFIR=6
  1968.       IFIR=14
  1969. C                            SET FLAG FOR NON-FORMAT
  1970.       IGOOF=-1
  1971. C                   LOOK FOR SPECIAL CHARACTERS.
  1972. 30    I=JCOL
  1973.       DO 60 JCOL=I,JMAX
  1974.            IT=JINT(JCOL)
  1975.            ISDEL=.FALSE.
  1976. C          (CHECK FOR SPL CHAR BEFORE DELIMS SINCE NEED J TO SET IFIR.)
  1977. C
  1978. C     =    ,    (    /    )    +    -    *    .    $    -    '    & NONE
  1979. C     1    2    3    4    5    6    7    8    9    10   11   12   13  14
  1980. C
  1981.            DO 50 J=1,13
  1982.                 IF (IT.EQ.KSPK(J)) THEN
  1983. C                   FOUND ONE.  IS IT THE FIRST...
  1984.                      IF (IFIR.EQ.14) THEN
  1985. C                   YES
  1986.                           IFIR=J
  1987.                           LFIR=JCOL
  1988. C     QUIT IF THIS STATEMENT TYPE DOESN'T ALLOW STRINGS.  JUST NEEDED
  1989. C     IFIR AND LFIR POINTERS.
  1990.                           IF (LSSCN.EQ.0.AND.LTYPE.NE.0)
  1991.      1                     THEN
  1992.                                if (mcase.eq.0) then
  1993.                                     DO 40 I=JCOL,JMAX
  1994.                                          JINT(I)=KCTRAN(JINT(I))
  1995. 40                                  CONTINUE
  1996.                                 endif
  1997.                                IF (MDEB.GT.0) WRITE (OUTFIL,320) IFIR,
  1998.      1                          LFIR
  1999.                                RETURN
  2000.                           END IF
  2001.                      END IF
  2002.                      ISDEL=IT.EQ.KDEL1.OR.IT.EQ.KDEL2
  2003.                      IF (ISDEL) GO TO 180
  2004.                      GO TO 70
  2005.                 END IF
  2006. 50         CONTINUE
  2007. C     (DELIMS MAY NOT BE SPECIAL CHARACTER, CHECK TO BE SURE)
  2008.            ISDEL=IT.EQ.KDEL1.OR.IT.EQ.KDEL2
  2009.            IF (ISDEL) GO TO 180
  2010.            IF (MCASE.EQ.0) JINT(JCOL)=KCTRAN(IT)
  2011. 60    CONTINUE
  2012.       GO TO 310
  2013. C                   LOOK FOR FOLLOWING NUMBER.
  2014. 70    IF (JCOL.EQ.JMAX) GO TO 310
  2015.       JCOL=JCOL+1
  2016.       CALL RSTAT
  2017. C                   REPEAT IF NO NUMBER.
  2018.       IF (L772.EQ.0) GO TO 30
  2019. C     MAKE IT UPPER CASE
  2020.       IF (MCASE.EQ.0) JINT(JCOL)=KCTRAN(JINT(JCOL))
  2021.       IT=KUPPER(JINT(JCOL))
  2022. C                  IS IT -H-,-L-, OR -R-
  2023.       IF (IT.EQ.KABC(8)) THEN
  2024.            LHTRN=MOD(KHTRAN,2).EQ.0
  2025.       ELSE IF (IT.EQ.KABC(12).OR.IT.EQ.KABC(18)) THEN
  2026.            LHTRN=KHTRAN.LT.2
  2027. C     COMPLAIN ABOUT L OR R IF ANSI FLAG SET.
  2028.            IF (MANSI.EQ.0) CALL DIAGNO (36)
  2029.       ELSE
  2030.            GO TO 30
  2031.       END IF
  2032. C                  MARK AS PART OF STRING (FOR INDENTING)
  2033.       IF (LHTRN) JINT(JCOL)(2:2)=KAT(2:2)
  2034. C
  2035. C     ALSO MARK THE NUMBERS.
  2036.       KTMP=L772
  2037.       I=JCOL
  2038. 80    I=I-1
  2039.       IF (JINT(I).EQ.KBL) GO TO 80
  2040.       IF (LHTRN) JINT(I)(2:2)=KAT(2:2)
  2041.       KTMP=KTMP/10
  2042.       IF (KTMP.GT.0) GO TO 80
  2043.       IP=I
  2044. C                  FIND LIMITS OF HOLLERITH FIELD.
  2045.       I=JCOL+1
  2046.       JCOL=JCOL+L772
  2047. C                   L772 IS THE LENGTH OF THE FIELD, AS FOUND BY RSTAT
  2048. C                  CHECK FOR CASE OF HOLLERITH BLANKS SPILLING OFF
  2049. C                  END OF CARD. E.G. I=6HXXXXX
  2050.       IF (JCOL.LE.JMAX) GO TO 90
  2051. C                  REPLACE CURRENT END CARD MARK.
  2052.       JINT(JMAX+1)=KBL
  2053. C                   AND SET NEW ONE
  2054.       JMAX=JCOL
  2055.       JINT(JMAX+1)=KERM
  2056. C                  CHANGE ALL CHARACTERS IN HOLLERITH FIELD.
  2057. 90    DO 100 J=I,JCOL
  2058.            JINT(J)(2:2)=KAT(2:2)
  2059. 100   CONTINUE
  2060.       IF (.NOT.LHTRN) THEN
  2061. C
  2062. C     TURN THIS ON IF WANT LOGGING OF H TRANSLATIONS IN FORMATS
  2063.            IF (KHLOG.EQ.0) NLHTRN=NLHTRN+1
  2064. C
  2065. C     IF TRANSLATING H-FIELDS, COPY STRING AND DUPLICATE APOSTROPHES.
  2066.            LNTMP=MAX0(IDINT(L772),LNTMP)
  2067.            JINT(IP)=KAPSTR
  2068.            IP=IP+1
  2069.            J=I
  2070. 110        JINT(IP)=JINT(J)
  2071.            IF (JINT(J).EQ.KAPSTR) THEN
  2072.                 IP=IP+1
  2073.                 IF (IP.GE.J) CALL MOVSTR (J)
  2074.                 JINT(IP)=KAPSTR
  2075.            END IF
  2076.            J=J+1
  2077.            IP=IP+1
  2078.            IF (J.LE.JCOL) GO TO 110
  2079.            JINT(IP)=KAPSTR
  2080. 120        IP=IP+1
  2081.            IF (IP.LE.JCOL) THEN
  2082.                 JINT(IP)=KBL
  2083.                 GO TO 120
  2084.            END IF
  2085.       END IF
  2086.       GO TO 30
  2087. C
  2088. C                  **********************************
  2089. C                  *                                *
  2090. C                  *   PROCESS FORMAT STATEMENTS.   *
  2091. C                  *                                *
  2092. C                  **********************************
  2093. C
  2094. 130   IGOOF=0
  2095.       IFIR=3
  2096.       LFIR=JCOL
  2097.       GO TO 170
  2098. C
  2099. C                  LOOK FOR SPECIAL CHARACTER
  2100. 140   IF (JCOL.GT.JMAX) GO TO 310
  2101.       I=JCOL
  2102.       DO 160 JCOL=I,JMAX
  2103.            IT=JINT(JCOL)
  2104.            ISDEL=IT.EQ.KDEL1.OR.IT.EQ.KDEL2
  2105.            IF (ISDEL) GO TO 180
  2106.            DO 150 J=1,12
  2107.                 IF (IT.EQ.KSPK(J)) GO TO 220
  2108. 150        CONTINUE
  2109.            IF (MCASE.EQ.0) JINT(JCOL)=KCTRAN(IT)
  2110. 160   CONTINUE
  2111.       GO TO 310
  2112. C
  2113. C                  SKIP IF NOT * OR '
  2114. 170   IF (JINT(JCOL).NE.KDEL1.AND.JINT(JCOL).NE.KDEL2) GO TO 220
  2115. C                  CHANGE ALL CHARACTERS BETWEEN *S OR 'S
  2116. 180   KPARAM=JINT(JCOL)
  2117. C                  MARK AS PART OF STRING (FOR INDENTING)
  2118.       JINT(JCOL)(2:2)=KAT(2:2)
  2119.       IP=JCOL
  2120. C
  2121. 190   IF (JCOL.EQ.JMAX) GO TO 310
  2122.       JCOL=JCOL+1
  2123.       IT=JINT(JCOL)
  2124.       JINT(JCOL)(2:2)=KAT(2:2)
  2125.       IF (IT.EQ.KPARAM) THEN
  2126.            IF (JINT(JCOL+1).NE.KPARAM) GO TO 200
  2127. C     THIS IS A LITERAL -- NOT TERMINAL DELIMITER
  2128.            JCOL=JCOL+1
  2129.            JINT(JCOL)(2:2)=KAT(2:2)
  2130.       END IF
  2131.       GO TO 190
  2132. C                            ALL CHANGED, CHANGE DELIMS IF DESIRED.
  2133. 200   IF (KDTRAN.EQ.1.AND.KPARAM.NE.KDEL1) THEN
  2134.            JINT(IP)=KAPSTR
  2135.            JINT(JCOL)=KAPSTR
  2136.            J=IP
  2137. 210        J=J+1
  2138.            IF (J.LT.JCOL) THEN
  2139.                 IF (JINT(J).EQ.KAPSTR) THEN
  2140. C     DUPLICATE LITERAL VERSION OF DELIMITER
  2141.                      CALL MOVSTR (J)
  2142.                      JINT(J)=KAPSTR
  2143.                 END IF
  2144.                 GO TO 210
  2145.            END IF
  2146.       END IF
  2147.       IF (IGOOF.EQ.-1) GO TO 70
  2148. C                  LOOK FOR FOLLOWING NUMBER
  2149. 220   IF (JCOL.EQ.JMAX) GO TO 310
  2150.       JCOL=JCOL+1
  2151.       CALL RSTAT
  2152. C                  IF NOT A NUMBER, START AGAIN
  2153.       IF (L772.EQ.0) GO TO 140
  2154. C                  NUMBER FOUND. LOOK AT NEXT CHARACTER.
  2155.       IF (MCASE.EQ.0) JINT(JCOL)=KCTRAN(JINT(JCOL))
  2156.       IT=KUPPER(JINT(JCOL))
  2157. C                  IS IT -H-
  2158.       IF (IT.EQ.KABC(8)) THEN
  2159.            LHTRN=MOD(KHTRAN,2).EQ.0
  2160.            GO TO 250
  2161. C                  MAYBE L OR R
  2162.       ELSE IF (IT.EQ.KABC(12).OR.IT.EQ.KABC(18)) THEN
  2163.            LHTRN=KHTRAN.LT.2
  2164.            IF (MANSI.EQ.0) CALL DIAGNO (36)
  2165.            GO TO 250
  2166.       END IF
  2167. C                  IF NOT -X-, START AGAIN.
  2168.       IF (IT.NE.KABC(24)) GO TO 140
  2169. C                  X FOUND.  LOOK AT NEXT.
  2170. 230   IF (JCOL.EQ.JMAX) GO TO 310
  2171.       JCOL=JCOL+1
  2172.       IF (JINT(JCOL).EQ.KBL) GO TO 230
  2173.       IF (MCASE.EQ.0) JINT(JCOL)=KCTRAN(JINT(JCOL))
  2174.       IT=KUPPER(JINT(JCOL))
  2175. C                  IS IT -*-
  2176.       IF (IT.EQ.KDEL1.OR.IT.EQ.KDEL2) GO TO 170
  2177. C                  IS IT -)- OR -,-
  2178.       IF (IT.EQ.KSPK(2)) GO TO 220
  2179.       IF (IT.EQ.KSPK(5)) GO TO 220
  2180. C
  2181. C     INSERT A COMMA
  2182.       DO 240 J=JMAX,JCOL,-1
  2183.            JINT(J+1)=JINT(J)
  2184. 240   CONTINUE
  2185.       JINT(JCOL)=KSPK(2)
  2186.       JMAX=JMAX+1
  2187.       JINT(JMAX+1)=KERM
  2188.       CALL DIAGNO (25)
  2189.       IGOOF=1
  2190.       GO TO 220
  2191. C
  2192. C                  HOLLERITH FOUND.   FIND LIMITS OF FIELD.
  2193. 250   IF (LHTRN) JINT(JCOL)(2:2)=KAT(2:2)
  2194. C
  2195. C     ALSO MARK THE NUMBERS.
  2196.       J=L772
  2197.       I=JCOL
  2198. 260   I=I-1
  2199.       IF (JINT(I).EQ.KBL) GO TO 260
  2200.       IF (LHTRN) JINT(I)(2:2)=KAT(2:2)
  2201.       J=J/10
  2202.       IF (J.GT.0) GO TO 260
  2203. C
  2204.       IP=I
  2205.       I=JCOL+1
  2206.       JCOL=JCOL+L772
  2207.       IF (JCOL.LE.JMAX) GO TO 270
  2208.       JINT(JMAX+1)=KBL
  2209.       JMAX=JCOL
  2210.       JINT(JMAX+1)=KERM
  2211. 270   DO 280 J=I,JCOL
  2212.            JINT(J)(2:2)=KAT(2:2)
  2213. 280   CONTINUE
  2214.       IF (.NOT.LHTRN) THEN
  2215. C
  2216. C     IF TRANSLATING H-FIELDS, COPY STRING AND DUPLICATE APOSTROPHES.
  2217.            IF (KHLOG.EQ.0) NLHTRN=NLHTRN+1
  2218.            JINT(IP)=KAPSTR
  2219.            IP=IP+1
  2220.            J=I
  2221. 290        JINT(IP)=JINT(J)
  2222.            IF (JINT(J).EQ.KAPSTR) THEN
  2223.                 IP=IP+1
  2224.                 IF (IP.GE.J) CALL MOVSTR (J)
  2225.                 JINT(IP)=KAPSTR
  2226.            END IF
  2227.            J=J+1
  2228.            IP=IP+1
  2229.            IF (J.LE.JCOL) GO TO 290
  2230.            JINT(IP)=KAPSTR
  2231. 300        IP=IP+1
  2232.            IF (IP.LE.JCOL) THEN
  2233.                 JINT(IP)=KBL
  2234.                 GO TO 300
  2235.            END IF
  2236.       END IF
  2237.       GO TO 220
  2238. C
  2239. 310   IF (LNTMP.GT.0) LNSTR=LNTMP
  2240.       IF (NLHTRN.GT.0) THEN
  2241.            IF (LTYPE.NE.26) CALL DIAGNO (39)
  2242.            NLHTRN=0
  2243.       END IF
  2244.       IF (MDEB.GT.0) WRITE (OUTFIL,320) IFIR,LFIR
  2245.       RETURN
  2246.  320  FORMAT (' HOLSCN: IFIR = ',I2,' AT COL ',I4)
  2247.       END
  2248.       SUBROUTINE IOSYS1 (OP,KV,SER,LIST)
  2249. C
  2250. C     OP CODES PERMITTED.
  2251. C     1         2         3         4
  2252. C     ERASE     REWIND    WRITE     READ
  2253. C
  2254.       INCLUDE 'TIDY.INC'
  2255.       INCLUDE 'UNITS.INC'
  2256.       INTEGER OP,KV(8)
  2257.       CHARACTER*2 SER(8),LIST(1)
  2258. C
  2259.       GO TO (10,20,30,40),OP
  2260. C
  2261. C     ERASE
  2262. C
  2263.       ENTRY IOSY11
  2264. 10    IF (MDEB.NE.0) WRITE (0,60)
  2265.       REWIND SCFIL1
  2266.       RETURN
  2267. C
  2268. C     REWIND
  2269. C
  2270.       ENTRY IOSY12
  2271. 20    IF (MDEB.NE.0) WRITE (0,70)
  2272.       REWIND SCFIL1
  2273.       RETURN
  2274. C
  2275. C     WRITE
  2276. C
  2277. 30    WRITE (SCFIL1) KV,SER
  2278.       IF (MDEB.NE.0) WRITE (0,80) KV
  2279.       CALL REDSTR (SCFIL1,LIST,KV(4),IOUTN,KV(6),1)
  2280.       GO TO 50
  2281. C
  2282. C     READ
  2283. C
  2284. 40    READ (SCFIL1) KV,SER
  2285.       IF (MDEB.NE.0) WRITE (0,90) KV
  2286.       CALL REDSTR (SCFIL1,LIST,KV(4),IOUTN,KV(6),2)
  2287. C                            NORMAL EXIT
  2288. 50    RETURN
  2289. C
  2290. 60    FORMAT (' rewinding 1 - IOSY11')
  2291. 70    FORMAT (' rewinding 1 - IOSY12')
  2292. 80    FORMAT (' write: ',8I9)
  2293. 90    FORMAT (' read: ',8I9)
  2294.       END
  2295.       SUBROUTINE IOSYS2 (OP,KV,SER,LIST)
  2296. C
  2297. C     OP CODES PERMITTED.
  2298. C     1         2         3         4
  2299. C     ERASE     REWIND    WRITE     READ
  2300. C
  2301.       INCLUDE 'TIDY.INC'
  2302.       INCLUDE 'UNITS.INC'
  2303.       INTEGER OP, KV(8)
  2304.       CHARACTER*2 SER(8), LIST(1)
  2305. C
  2306.       GO TO (10,20,50,80),OP
  2307. C
  2308. C     ERASE
  2309. C
  2310.       ENTRY IOSY21
  2311.  10   REWIND SCFIL2
  2312.       RETURN
  2313. C
  2314. C     REWIND
  2315. C
  2316.       ENTRY IOSY22
  2317.  20   REWIND SCFIL2
  2318.       RETURN
  2319. C
  2320. C     WRITE
  2321. C
  2322.  50   WRITE (SCFIL2) KV, SER
  2323.       CALL REDSTR (SCFIL2, LIST, KV(4),IOUTN,KV(6),1)
  2324.       GO TO 120
  2325. C
  2326. C     READ
  2327. C
  2328.  80   READ (SCFIL2) KV, SER
  2329.       CALL REDSTR (SCFIL2, LIST, KV(4),IOUTN,KV(6),2)
  2330. C                            NORMAL EXIT
  2331.  120  RETURN
  2332.       END
  2333.       SUBROUTINE JTYP19 (JRTCOD)
  2334. C 
  2335. C                  ***** JTYPE = 19
  2336. C     FORMAT (
  2337. C 
  2338.       INCLUDE 'TIDY.INC'
  2339. C 
  2340. C     ERROR IF NO STATEMENT NUMBER OR FIRST SPECIAL CHAR NOT (
  2341.       IF (L15.EQ.0.OR.JINT(JMAX).NE.KSPK(5)) THEN
  2342.            JRTCOD=1
  2343.            RETURN
  2344.       END IF
  2345. C 
  2346.       IF (MEX.EQ.0) THEN
  2347.            IF (MCOL.EQ.-1) THEN
  2348. C 
  2349. C          IF COLLECTING FORMATS, START THEM IN COLUMN 7 (OR JUST).
  2350.                 ICOL=6
  2351.                 IF (JUST.GT.0) ICOL=JUST-1
  2352.            END IF
  2353. C 
  2354.            CALL COPY (6)
  2355. C                            COPY REST OF CARD
  2356.            IF (MCOL.EQ.0) THEN
  2357.                 JRTCOD=3
  2358.                 RETURN
  2359.            END IF
  2360. C                            ONTO UNIT 2
  2361.            ICOL=ICOL+1
  2362.            CALL COPY (0)
  2363.            IMAX=ICOL
  2364.            JTYPE=NREC
  2365.            CALL IOSYS2 (3,KILI,SERIAL,IOUT)
  2366.            NRT2=NRT2+1
  2367.            NBLC=NBCOLD
  2368.       ELSE
  2369. C 
  2370. C     EXEMPT FLAG IS ON - TRANSFER TO TAPE1 OR TAPE2 WITHOUT REMOVING
  2371. C     ANY BLANKS.
  2372. C 
  2373.            IF (MCOL.NE.0) THEN
  2374.                 ITYPE=NREC
  2375.                 CALL IOSYS2 (3,KILI,SERIAL,JINT)
  2376.                 NRT2=NRT2+1
  2377.                 NBLC=NBCOLD
  2378.            ELSE
  2379.                 CALL DLIST (MERR)
  2380.                 IF (MERR.EQ.0) THEN
  2381.                      CALL IOSYS1 (3,KILI,SERIAL,JINT)
  2382.                      NRT1=NRT1+1
  2383.                 END IF
  2384.            END IF
  2385.       END IF
  2386. C 
  2387.       JRTCOD=2
  2388.       RETURN
  2389.       END
  2390.       SUBROUTINE JTYP31(JRTCOD)
  2391. C
  2392. C                  ***** JTYPE = 31
  2393. C     IF (ARITHMETIC) 1,2,3   OR   IF (LOGICAL) STATEMENT.
  2394. C
  2395.       INCLUDE 'TIDY.INC'
  2396.       CHARACTER*2 JT
  2397.       COMMON /PS1SUB/ KSTC(5), NIFBLK
  2398. C
  2399.       CALL COPY (2)
  2400.       ICOL=ICOL+1
  2401. C                  COPY UNTIL CLOSED PARENTHESES
  2402.       CALL COPY (-1)
  2403.       IF (MEOF.GE.0) GO TO 80
  2404.       ICOL=ICOL+1
  2405.       CALL RSTAT
  2406.       IF (L772.NE.0) THEN
  2407. C
  2408. C     STATEMENT IS    IF (ARITHMETIC) 1,2,3
  2409. C
  2410.            NCOM=0
  2411.            MILDO=-1
  2412.            CALL DLIST (MERR)
  2413.            IF (MERR.NE.0) GO TO 80
  2414. 10         IOUT(ICOL+1)=KLR2
  2415.            ICOL=ICOL+1
  2416.            IF (NXRF.GT.MXREF) THEN
  2417.                 CALL DIAGNO (35)
  2418.                 MP2=0
  2419.                 JRTCOD=2
  2420.                 RETURN
  2421.            END IF
  2422.            IOUTN(NXRF)=L772
  2423.            NXRF=NXRF+1
  2424.            CALL RLIST
  2425.            CALL COPY (1)
  2426.            IF (LCPY.EQ.KSPK(2)) THEN
  2427.                 NCOM=NCOM+1
  2428.                 IF (NCOM.GT.3) GO TO 80
  2429.                 IF (NCOM.EQ.3) CALL DIAGNO (18)
  2430.                 CALL RSTAT
  2431.                 IF (L772.EQ.0) GO TO 80
  2432.                 GO TO 10
  2433.            END IF
  2434.            IF (LCPY.NE.KERM) GO TO 80
  2435.            IF (NCOM.LE.0) GO TO 80
  2436.            IF (NCOM.EQ.1) CALL DIAGNO (18)
  2437.            MTRAN=MLGC
  2438.            JRTCOD=3
  2439.            RETURN
  2440.       END IF
  2441. C
  2442. C     STATEMENT IS   IF (LOGICAL) STATEMENT
  2443. C
  2444.       MLGC=0
  2445. C
  2446. C        CHECK FOR 'IF () THEN' UNLESS IT IS  ELSEIF () THEN
  2447.       IF (JTYPE.EQ.43) GO TO 40
  2448.       I=69
  2449.       CALL KWSCAN (I,KSTC)
  2450.       IF (I.NE.69) GO TO 40
  2451.       CALL COPY (4)
  2452. C        LOOP TO CHECK REST FOR BLANKS.
  2453.       DO 20 I=JCOL,JMAX
  2454.            IF (JINT(I).EQ.KERM) GO TO 30
  2455.            IF (JINT(I).NE.KBL) GO TO 40
  2456. 20    CONTINUE
  2457. 30    NIFBLK=NIFBLK+1
  2458.       JRTCOD=4
  2459.       RETURN
  2460. C
  2461. C                   LOOK FOR FIRST SPECIAL CHARACTER.
  2462. 40    DO 60 LFIR=JCOL,JMAX
  2463.            JT=JINT(LFIR)
  2464.            DO 50 IFIR=1,11
  2465.                 IF (JT.EQ.KSPK(IFIR)) GO TO 70
  2466. 50         CONTINUE
  2467. 60    CONTINUE
  2468.       LFIR=6
  2469.       IFIR=14
  2470. 70    JRTCOD=5
  2471.       RETURN
  2472. C
  2473. 80    JRTCOD=1
  2474.       RETURN
  2475. C
  2476.       END
  2477.       SUBROUTINE JTYP33 (JRTCOD)
  2478. C
  2479. C     PROCESS TYPE 33 CARDS - AGS 23 DEC 1993
  2480. C
  2481. C     JRTCOD IS RETURN CODE - USE COMPUTED GOTO TO BRANCH TO PROPER
  2482. C      PLACE IN PASS1.
  2483. C
  2484.       INCLUDE 'TIDY.INC'
  2485. C
  2486. C                  ***** JTYPE = 33
  2487. C     PRINT, TYPE, WRITE, PUNCH, READ, ACCEPT.
  2488. C
  2489.       CALL COPY (NINS)
  2490.       ICOL=ICOL+1
  2491.       CALL RSTAT
  2492.       IF (L772.NE.0) GO TO 20
  2493. C
  2494. C     HAVE WRITE  FMT,LIST
  2495. C
  2496. C            , AS IN PRINT IFT,XXX
  2497.       IF (IFIR.NE.2) THEN
  2498. C            *, AS IN PRINT *,XXX
  2499.            IF (IFIR.EQ.8.OR.IFIR.EQ.12.OR.IFIR.EQ.14) THEN
  2500.                 JRTCOD=1
  2501.            ELSE
  2502.                 JRTCOD=2
  2503.            END IF
  2504.            RETURN
  2505.       END IF
  2506. C
  2507.    10 CALL COPY (1)
  2508.       IF (LCPY.EQ.KSPK(2)) THEN
  2509.            JRTCOD=3
  2510.            RETURN
  2511.       END IF
  2512.       IF (MEOF.LT.0) GO TO 10
  2513.       JRTCOD=2
  2514.       RETURN
  2515. C
  2516. C     HAVE WRITE  12345 LIST
  2517. C
  2518.    20 CALL RLIST
  2519.       IOUT(ICOL+1)=KLR2
  2520.       ICOL=ICOL+1
  2521.       IF (NXRF.GT.MXREF) THEN
  2522.            JRTCOD=4
  2523.            RETURN
  2524.       END IF
  2525.       IOUTN(NXRF)=L772
  2526.       NXRF=NXRF+1
  2527.       IF (IFIR.EQ.2) GO TO 10
  2528.       IF (JMAX.GT.JCOL) THEN
  2529.            JRTCOD=2
  2530.       ELSE
  2531.            IMAX=ICOL
  2532.            JRTCOD=5
  2533.       END IF
  2534.       RETURN
  2535.       END
  2536.       CHARACTER*2 FUNCTION KCTRAN(C)
  2537. C
  2538. C     CONVERTS ALL LETTERS TO A SINGLE CASE, SELECTED BY USER'S CALL TO
  2539. C      SUBROUTINE KCTSET.
  2540. C     PORTABLE VERSION - NOT ASCII/EBCDIC DEPENDENT.
  2541. C     AGS 12 OCT 93
  2542. C
  2543. C
  2544.       CHARACTER CT
  2545.       CHARACTER*2 C
  2546. C     COMMON BLOCK FOR CHARACTER TRANSLATION TABLES
  2547.       COMMON /CTRAN/ LININ,LINOUT
  2548.       CHARACTER*26 LININ,LINOUT
  2549.       SAVE
  2550. C
  2551. C     FIND POSITION OF CHARACTER IN INPUT-CASE ALPHABET
  2552.       CT=C(1:1)
  2553.       J=INDEX(LININ,CT)
  2554. C
  2555. C     IF FOUND, RETURN OUTPUT-CASE EQUIVALENT, OTHERWISE ORIGINAL CHAR.
  2556.       IF (J.GT.0) THEN
  2557.            KCTRAN=LINOUT(J:J)
  2558.       ELSE
  2559.            KCTRAN=C
  2560.       END IF
  2561. C
  2562.       RETURN
  2563.       END
  2564.       SUBROUTINE KCTSET (IP)
  2565. C
  2566. C     SET CHARACTER TRANSLATION TABLE FOR KCTRAN:
  2567. C     IP = 0 - LOWER TO UPPER
  2568. C     IP = 1 - UPPER TO LOWER
  2569. C
  2570. C     COMMON BLOCK FOR CHARACTER TRANSLATION TABLES
  2571.       COMMON /CTRAN/ LININ,LINOUT
  2572.       CHARACTER*26 LININ,LINOUT
  2573.       CHARACTER*26 CTBL(0:1)
  2574.       SAVE
  2575.       DATA CTBL/'abcdefghijklmnopqrstuvwxyz',
  2576.      1          'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
  2577. C
  2578. C     ASSIGN INPUT AND OUTPUT ALPHABETS BASED ON VALUE OF IP.
  2579.       LININ=CTBL(IP)
  2580.       LINOUT=CTBL(1-IP)
  2581. C
  2582.       RETURN
  2583.       END
  2584.       CHARACTER*2 FUNCTION KHIDE (C)
  2585.       CHARACTER*2 C
  2586.       CHARACTER*2 KBL
  2587.       DATA KBL/' @'/
  2588. C
  2589. C     CONVERT CHARACTERS IN HOLSCN STRINGS TO SPECIAL FORM
  2590. C      (UNLESS ALREADY SET TO INDICATE EMBEDDED COMMENT STATEMENT)
  2591. C      SO THAT BLANKS WILL NOT BE REMOVED FROM STRINGS.
  2592. C
  2593.       IF (C(2:2).EQ.' ') THEN
  2594.            KHIDE=KBL
  2595.            KHIDE(1:1)=C(1:1)
  2596.       ELSE
  2597.            KHIDE=C
  2598.       END IF
  2599.       RETURN
  2600.       END
  2601.       SUBROUTINE KIMPAK
  2602. C
  2603. C     THIS ROUTINE PACKS SUPER-CARD IMAGES FROM IOUT(I) INTO KIM(I,J).
  2604. C
  2605.       INCLUDE 'TIDY.INC'
  2606.       LOGICAL CONIND,SPLSTR
  2607. C
  2608.       CONIND=.TRUE.
  2609.       SPLSTR=.FALSE.
  2610. C
  2611.  10   J=0
  2612. C
  2613.  20   J=J+1
  2614.       IF (KLASS.LT.2) THEN
  2615.            K7=0
  2616.            JL=1
  2617.            JR=72
  2618.            GO TO 90
  2619.       END IF
  2620. C
  2621. C     INDENTING COULD MAKE CARD OVERFLOW CONTINUATIONS, IF SO, REPACK.
  2622.       IF (J.GT.20) THEN
  2623.            IF (.NOT.CONIND) THEN
  2624.                 CALL DIAGNO (37)
  2625.                 J=20
  2626.                 GO TO 120
  2627.            END IF
  2628.            CONIND=.FALSE.
  2629.            JL=7
  2630.            JR=72
  2631.            GO TO 10
  2632.       END IF
  2633. C
  2634. C     PREPARE COLUMNS 1-6 OF FIRST CARD.
  2635.       IF (CONIND) THEN
  2636.            IF (J.EQ.1) THEN
  2637.                 K7=ICOLSV
  2638.                 DO 30 I=1,6
  2639.                      KIM(I,1)=IOUT(I)
  2640.  30             CONTINUE
  2641.            ELSE
  2642. C     BLANK COLUMN 1-5
  2643.                 DO 40 I=1,5
  2644.                      KIM(I,J)=KBL
  2645.  40             CONTINUE
  2646. C     COLUMN 6 - NUMBER SERIALLY UNLESS CCHR SET OTHERWISE.
  2647.                 IF (KCTCTL.EQ.0) THEN
  2648.                      IF (J.LT.11) THEN
  2649.                           KIM(6,J)=KDIG(J)
  2650.                      ELSE
  2651.                           KIM(6,J)=KSPK(10)
  2652.                      END IF
  2653.                 ELSE
  2654.                      KIM(6,J)=KCTCHR
  2655.                 END IF
  2656.            END IF
  2657. C
  2658. C     SET LEFT EDGE OF TEXT
  2659. C      (USE COL 7 IF EXEMPT, NON-INDENTED, OR IF PART OF STRING
  2660.            IF (MEX.LT.0.OR.ICOLSV.EQ.6.OR.(IOUT(K7)(2:2).EQ.KAT(2:2).
  2661.      1      AND.IOUT(K7+1)(2:2).EQ.KAT(2:2))) THEN
  2662.                 JL=7
  2663.            ELSE
  2664.                 JL=ICOLSV
  2665.                 IF (J.GT.1) JL=JL+1
  2666.                 DO 50 I=7,JL
  2667.                      KIM(I,J)=KBL
  2668.  50             CONTINUE
  2669.                 JL=JL+1
  2670.            END IF
  2671. C
  2672. C     SET RIGHT EDGE OF TEXT
  2673. C     FIRST GET RIGHT-MOST POTENTIAL CHAR IN STRING (KRR)
  2674.            JR=72
  2675.            KRR=K7+JR-JL+1
  2676.            IF (KRR.GT.IMAX) THEN
  2677. C     IF PAST END OF STATEMENT, STOP AT END.
  2678.                 JR=JL+IMAX-K7-1
  2679.                 GO TO 90
  2680.            END IF
  2681. C
  2682. C     NOW CHECK IF WE CAN BREAK IT HERE.
  2683. C     BREAK IF PART OF A STRING. KIMPAK PROTECTS DELIMETERS ALSO.
  2684.  60        IF (IOUT(KRR)(2:2).EQ.KAT(2:2)) THEN
  2685. C
  2686. C     FORMAT STATEMENTS - MAY HAVE PROBLEMS WITH QUOTES AT END.
  2687.                 IF (KLASS.EQ.5) THEN
  2688. C          DON'T SPLIT IF TURNED OFF OR AT TOP INDENT LEVEL.
  2689.                      IF (KFSPL.EQ.1.OR.ICOLSV.EQ.6) GO TO 90
  2690. C          IF NEXT CHAR NOT IN STRING, BREAK IS FINE.
  2691.                      IF (IOUT(KRR+1)(2:2).NE.KAT(2:2)) GO TO 90
  2692. C
  2693. C          COLUMN 72 NOT A QUOTE, CAN SPLIT ON COL 71
  2694.                      IF (IOUT(KRR).NE.KAPSTR) THEN
  2695. C          INSERT ',' IN STRING
  2696.                           JR=JR-1
  2697.                           SPLSTR=.TRUE.
  2698.                      ELSE
  2699. C          COLUMN 72 QUOTE WITHIN A STRING, BACKTRACK.
  2700.                           KRR=KRR-1
  2701.                           JR=JR-1
  2702.                           IF (JR.GT.JL) GO TO 60
  2703.                      END IF
  2704. C     END FORMAT STRING BREAKER
  2705.                 END IF
  2706.                 GO TO 90
  2707.            END IF
  2708. C
  2709. C     BREAK IF IT IS A BLANK (NOT IN STRING)
  2710.            IF (IOUT(KRR).EQ.KBL) GO TO 90
  2711. C
  2712. C     GO BACK IF LEFT PARENTHESIS
  2713.  70        IF (IOUT(KRR).EQ.KSPK(3)) THEN
  2714.                 KRR=KRR-1
  2715.                 JR=JR-1
  2716.                 GO TO 70
  2717.            END IF
  2718. C
  2719. C     BREAK FOR SPECIAL CHARACTERS (EXCEPT DECIMAL POINTS)
  2720.            DO 80 I=1,14
  2721.                 IF (IOUT(KRR).EQ.KSPK(I).AND.I.NE.9) GO TO 90
  2722.  80        CONTINUE
  2723. C
  2724. C     OTHERWISE BACK UP ONE, TRY AGAIN.
  2725.            KRR=KRR-1
  2726.            JR=JR-1
  2727.            IF (JR.GT.JL) GO TO 60
  2728. C
  2729. C     IF GO ALL THE WAY BACK, FORCE IT TO 72
  2730.            JR=72
  2731.       END IF
  2732. C
  2733. C     COPY THE TEXT
  2734.  90   DO 100 I=JL,JR
  2735.            K7=K7+1
  2736.            IF (K7.LE.IMAX) THEN
  2737.                 KIM(I,J)=IOUT(K7)
  2738.            ELSE
  2739.                 KIM(I,J)=KBL
  2740.            END IF
  2741.  100  CONTINUE
  2742. C
  2743. C     STRING SPLITTER
  2744.       IF (SPLSTR) THEN
  2745.            KIM(JR+1,J)=KAPSTR
  2746.            IOUT(K7-1)=KSPK(2)
  2747.            IOUT(K7)=KAPSTR
  2748.            K7=K7-2
  2749.            JR=JR+1
  2750.            SPLSTR=.FALSE.
  2751.       END IF
  2752. C
  2753. C     SCRUB GARBAGE OFF END IF SHORTER THAN 72
  2754.       IF (JR.LT.72) THEN
  2755.            DO 110 I=JR+1,72
  2756.                 KIM(I,J)=KBL
  2757.  110       CONTINUE
  2758.       END IF
  2759. C
  2760. C     DO ANOTHER CONTINUATION IF NECESSARY.
  2761.       IF (K7.LT.IMAX) GO TO 20
  2762. C
  2763.  120  NCD=J
  2764.       RETURN
  2765.       END
  2766.       CHARACTER*2 FUNCTION KUPPER(C)
  2767. C
  2768. C     CONVERTS LOWER-CASE LETTERS TO UPPER-CASE. PORTABLE VERSION.
  2769. C     AGS 23 APR 93
  2770. C
  2771.       CHARACTER CT
  2772.       CHARACTER*2 C
  2773.       CHARACTER*26 LC,UC
  2774.       SAVE
  2775.       DATA LC/'abcdefghijklmnopqrstuvwxyz'/
  2776.       DATA UC/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
  2777. C
  2778. C     FIND POSITION OF CHARACTER IN LOWER-CASE ALPHABET
  2779.       CT=C(1:1)
  2780.       J=INDEX(LC,CT)
  2781. C
  2782. C     IF FOUND, RETURN UPPER-CASE EQUIVALENT, OTHERWISE ORIGINAL CHAR.
  2783.       IF (J.GT.0) THEN
  2784.            KUPPER=UC(J:J)
  2785.       ELSE
  2786.            KUPPER=C
  2787.       END IF
  2788. C
  2789.       RETURN
  2790.       END
  2791.       SUBROUTINE MOVSTR (J)
  2792.       INCLUDE 'TIDY.INC'
  2793. C
  2794. C     ADDS 1 BYTE TO STRING BY SHIFTING UNPROCESSED CHARS RIGHT.
  2795. C     USED BY HOLSCN WHEN REPLICATING APOSTROPHES
  2796. C
  2797.       DO 10 I=JMAX,J,-1
  2798.            JINT(I+1)=JINT(I)
  2799.  10   CONTINUE
  2800.       JMAX=JMAX+1
  2801.       JINT(JMAX+1)=KERM
  2802.       J=J+1
  2803.       JCOL = JCOL+1
  2804.       RETURN
  2805.       END
  2806.       SUBROUTINE NOPRO
  2807. C
  2808. C     THIS SUBROUTINE EXECUTES A HIGH-SPEED SEARCH FOR AN END STATEMENT.
  2809. C     IF MP2 IS ON, CARD IMAGES ARE WRITTEN ON TAPE 1 FOR USE BY PASS2.
  2810. C     NO INTERNAL PROCESSING IS DONE ON THE STATEMENTS.
  2811. C
  2812.       INCLUDE 'TIDY.INC'
  2813. C     SET INITIAL VALUES.
  2814. C
  2815.       CALL IOSY11
  2816.       CALL IOSY21
  2817.       NRT2=0
  2818.       NDEF=0
  2819.       KLASS=1
  2820.       ITYPE=0
  2821.       L15=0
  2822.       IF (MP2.NE.0) THEN
  2823. C
  2824. C     WRITE OUT STATEMENT CURRENTLY IN JINT.
  2825. C
  2826.            IMAX=JMAX
  2827.            KLASS=2
  2828.            CALL IOSYS1 (3,KILI,SERIAL,JINT)
  2829.            NRT1=1
  2830.            KLASS=3
  2831.            IF (JMAX.GT.72) CALL DIAGNO (28)
  2832.       END IF
  2833.       GO TO 20
  2834. C
  2835. C     READ AND COPY CARD IMAGES BY WAY OF KBUFF.
  2836. C
  2837.  10   CALL READER
  2838.  20   NREC=NREC+1
  2839. C
  2840. C     LOOK FOR LAST NON-BLANK CHARACTER ON CARD.
  2841. C
  2842.       I=72
  2843.  30   IF (KBUFF(I).EQ.KBL) THEN
  2844.            I=I-1
  2845.            IF (I.GT.7) GO TO 30
  2846.       END IF
  2847.       IMAX=I
  2848. C
  2849. C     LOOK FOR END STATEMENT IN INPUT BUFFER KBUFF
  2850. C
  2851.       J=3
  2852.       DO 40 I=7,IMAX
  2853.            K=I
  2854.            IF (KBUFF(I).NE.KBL) THEN
  2855.                 IF (KBUFF(I).NE.KEND(J)) GO TO 50
  2856.                 J=J-1
  2857.                 IF (J.EQ.0) THEN
  2858. C     FOUND AN END CARD IF NEXT CHAR IS BLANK.
  2859.                      IF (KBUFF(K+1).EQ.KBL) KLASS=8
  2860.                      GO TO 50
  2861.                 END IF
  2862.            END IF
  2863.  40   CONTINUE
  2864. C
  2865. C
  2866. C     WRITE OUT CARD IMAGE FOR PASS2.
  2867. C
  2868.  50   IF (MP2.NE.0) THEN
  2869.            CALL IOSYS1 (3,KILI,SERIAL,KBUFF)
  2870.            NRT1=NRT1+1
  2871.       END IF
  2872. C
  2873. C     GET NEXT RECORD UNLESS END CARD OR EOF
  2874.       IF (IQUIT.NE.1.AND.KLASS.NE.8) GO TO 10
  2875. C
  2876. C     CLOSE FILE
  2877.       IF (MP2.NE.0) CALL IOSY12
  2878. C
  2879. C     LOAD BUFFER, KBUFF, BEFORE EXITING.
  2880. C
  2881.       IF (IQUIT.EQ.0) CALL READER
  2882.       RETURN
  2883.       END
  2884.       INTEGER FUNCTION OPFIL(KUNIT,FNAME,KTYPE,KNOUT,EXPRES,LENGTH)
  2885. C-------------------------------------------------------------------------
  2886. C---- THIS IS THE OPEN FILE FUNCTION BY W.J. MEERSCHAERT & P.J. DAUGHERTY
  2887. C---- JULY 25, 1986
  2888. C---- DUMMY PARAMETERS ARE AS FOLLOWS:
  2889. C
  2890. C    IUNIT....UNIT NUMBER OF THE FILE TO BE OPENED, PREFERRABLY > 20
  2891. C    FNAME....NAME OF FILE TO BE OPENED, IF SCRATCH, IT IS IGNORED,
  2892. C                IF MISSING, IT IS PROMPTED FOR
  2893. C    ITYPE....TYPE OF FILE TO BE OPENED, AS FOLLOWS:
  2894. C            >0   RECL FOR A DIRECT ACCESS UNFORMATTED FILE
  2895. C            >100000 DIRECT ACCESS FORMATTED FILE RECL=MOD(ITYPE,100000)
  2896. C             0   FORMATTED SEQUENTIAL FILE
  2897. C            <0   UNFORMATTED SEQUENTIAL FILE
  2898. C    INOUT....SPECIFIES WHAT THE FILE IS FOR:
  2899. C            -2   INPUT FILE, IF NOT EXIST, EXIT WITH ERROR CODE
  2900. C            -1   INPUT FILE, IF NOT EXIST, PROMPT USER FOR NEW NAME
  2901. C             0   SCRATCH FILE
  2902. C             1   OUTPUT FILE, IF EXIST, PROMPT USER FOR ACTION
  2903. C             2   OUTPUT FILE, IF EXIST, OVERWRITE AUTOMATICALLY
  2904. C             3   OUTPUT FILE, IF EXIST, APPEND AUTOMATICALLY
  2905. C             4   OUTPUT FILE, IF EXIST, EXIT WITH ERROR CODE
  2906. C    EXPRES...EXPRESSION FOR PROMPTING USER FOR FILENAME
  2907. C    LENGTH...NUMBER OF LINES IN OLD PART OF APPENDED FILE
  2908. C
  2909. C OPFIL RETURNS THE FOLLOWING:
  2910. C    0......ALL IS WELL
  2911. C    >0.....COMPILER OR SYSTEM ERROR MESSAGE ON OPEN STATEMENT
  2912. C    1......USER EOF ON A READ PROMPT (I.E., ABORT OPEN)
  2913. C    2......ERROR CODE BASED ON INOUT, FILE M=NOT OPENED
  2914. C
  2915. C-------------------------------------------------------------------------
  2916.       CHARACTER FNAME*(*),EXPRES*(*),ANS
  2917.       INTEGER DOSDEV
  2918.       LOGICAL EXST,FILOPN
  2919.       INCLUDE 'UNITS.INC'
  2920. C
  2921. C---- REASSIGN INTEGER DUMMY VARIABLES
  2922. C
  2923.       IUNIT=KUNIT
  2924.       ITYPE=KTYPE
  2925.       INOUT=KNOUT
  2926.       LENGTH=0
  2927. C
  2928. C---- OPEN SCRATCH FILE
  2929. C
  2930.       IF (INOUT.EQ.0) THEN
  2931.            IF (ITYPE) 10,20,30
  2932.  10        OPEN (IUNIT,STATUS='SCRATCH',FORM='UNFORMATTED',ACCESS='SEQUE
  2933.      1NTIAL',IOSTAT=OPFIL)
  2934.            RETURN
  2935.  20        OPEN (IUNIT,STATUS='SCRATCH',FORM='FORMATTED',ACCESS='SEQUENT
  2936.      1IAL',IOSTAT=OPFIL)
  2937.            RETURN
  2938.  30        IF (ITYPE.GT.100000) THEN
  2939.                 ITYPE=MOD(ITYPE,100000)
  2940.                 OPEN (IUNIT,ACCESS='DIRECT',STATUS='SCRATCH',RECL=ITYPE,
  2941.      1FORM='FORMATTED',IOSTAT=OPFIL)
  2942.            ELSE
  2943.                 OPEN (IUNIT,ACCESS='DIRECT',STATUS='SCRATCH',RECL=ITYPE,
  2944.      1FORM='UNFORMATTED',IOSTAT=OPFIL)
  2945.            END IF
  2946.            RETURN
  2947.       END IF
  2948. C
  2949. C---- CHECK FOR LOGIC OF ARGUMENTS AND FILE PROPERTIES
  2950. C
  2951.  40   IF (FNAME.EQ.' '.AND.INOUT.NE.2) THEN
  2952.            WRITE (STDERR,190) EXPRES
  2953.            READ (STDIN,200,END=170) FNAME
  2954.            IF (FNAME(1:1).EQ.'?') THEN
  2955.                 PAUSE 'Type DIR to see a list of files'
  2956.                 FNAME=' '
  2957.                 GO TO 40
  2958.            ELSE IF (FNAME(1:1).EQ.'>'.AND.FNAME(2:2).NE.'>') THEN
  2959.                 IF (INOUT.GT.0) INOUT=2
  2960.                 FNAME=FNAME(2:)
  2961.            ELSE IF (FNAME(1:2).EQ.'>>') THEN
  2962.                 IF (INOUT.GT.0) INOUT=3
  2963.                 FNAME=FNAME(3:)
  2964.            ELSE
  2965.                 IF (INOUT.GT.0) INOUT=1
  2966.            END IF
  2967.       END IF
  2968. C
  2969. C---- GET EXST AND FILOPN
  2970. C
  2971.       INQUIRE (FILE=FNAME,EXIST=EXST,OPENED=FILOPN)
  2972. C
  2973. C     DON'T OPEN SAME FILE TWICE.
  2974.       IF (FILOPN) THEN
  2975.            WRITE (STDERR,210) FNAME
  2976.            FNAME=' '
  2977.            GO TO 40
  2978.       END IF
  2979. C
  2980. C---- INPUT FILE
  2981. C
  2982.       IF (.NOT.EXST.AND.INOUT.LT.0) THEN
  2983.            IF (INOUT.EQ.-1) THEN
  2984.                 WRITE (STDERR,220) FNAME
  2985.                 FNAME=' '
  2986.                 GO TO 40
  2987.            ELSE IF (INOUT.EQ.-2) THEN
  2988.                 GO TO 180
  2989.            END IF
  2990. C
  2991. C---- OUTPUT FILE
  2992. C
  2993.       ELSE IF (EXST.AND.INOUT.EQ.1) THEN
  2994. C
  2995.            ISDEV = 0
  2996. C
  2997. C     DOS DEVICES ARE OK IF THEY EXIST
  2998.            ISDEV =  DOSDEV(FNAME)
  2999.            IF (ISDEV.GT.0) THEN
  3000.                 INOUT=2
  3001.                 GO TO 60
  3002.            END IF
  3003. C
  3004. C     OTHERWISE ASK USER WHAT TO DO.
  3005.  50        WRITE (STDERR,230) EXPRES,FNAME
  3006.            READ (STDIN,240,END=170) ANS
  3007.            IF (ANS.EQ.'o'.OR.ANS.EQ.'O') THEN
  3008.                 INOUT=2
  3009.            ELSE IF (ANS.EQ.'a'.OR.ANS.EQ.'A') THEN
  3010.                 INOUT=3
  3011.            ELSE IF (ANS.EQ.'n'.OR.ANS.EQ.'N') THEN
  3012.                 FNAME=' '
  3013.                 GO TO 40
  3014.            ELSE
  3015.                 GO TO 50
  3016.            END IF
  3017.       ELSE IF (EXST.AND.INOUT.EQ.4) THEN
  3018.            OPFIL=2
  3019.            RETURN
  3020.       END IF
  3021. C
  3022. C---- OPEN FILE
  3023. C
  3024.  60   IF (ITYPE) 70,80,90
  3025.  70   OPEN (IUNIT,FILE=FNAME,STATUS='UNKNOWN',FORM='UNFORMATTED',ACCESS=
  3026.      1'SEQUENTIAL',IOSTAT=OPFIL)
  3027.       GO TO 100
  3028.  80   OPEN (IUNIT,FILE=FNAME,STATUS='UNKNOWN',FORM='FORMATTED',ACCESS='S
  3029.      1EQUENTIAL',IOSTAT=OPFIL)
  3030.       GO TO 100
  3031.  90   IF (ITYPE.GT.100000) THEN
  3032.            ITYPE=MOD(ITYPE,100000)
  3033.            OPEN (IUNIT,FILE=FNAME,STATUS='UNKNOWN',FORM='FORMATTED',ACCE
  3034.      1SS='DIRECT',RECL=ITYPE,IOSTAT=OPFIL)
  3035.       ELSE
  3036.            OPEN (IUNIT,FILE=FNAME,STATUS='UNKNOWN',FORM='UNFORMATTED',AC
  3037.      1CESS='DIRECT',RECL=ITYPE,IOSTAT=OPFIL)
  3038.       END IF
  3039.       RETURN
  3040.  100  REWIND IUNIT
  3041. C
  3042. C---- APPEND IF REQUESTED
  3043. C
  3044.       IF (INOUT.EQ.3) THEN
  3045.            IF (ITYPE) 110,120,120
  3046.  110       READ (IUNIT,END=130)
  3047.            LENGTH=LENGTH+1
  3048.            GO TO 110
  3049.  120       READ (IUNIT,240,END=130) ANS
  3050.            LENGTH=LENGTH+1
  3051.            GO TO 120
  3052.  130       REWIND IUNIT
  3053.            DO 160 N=1,LENGTH
  3054.                 IF (ITYPE) 140,150,150
  3055.  140            READ (IUNIT)
  3056.                 GO TO 160
  3057.  150            READ (IUNIT,240) ANS
  3058.  160       CONTINUE
  3059.            END FILE IUNIT
  3060.            BACKSPACE (IUNIT)
  3061.       END IF
  3062. C
  3063. C---- ALL DONE
  3064. C
  3065.       RETURN
  3066.  170  OPFIL=1
  3067.       RETURN
  3068.  180  OPFIL=2
  3069.       RETURN
  3070. C
  3071. C
  3072.  190  FORMAT (/T3,'Open the ',A,' file'/T3,'Enter a file name here: ')
  3073.  200  FORMAT (A)
  3074.  210  FORMAT (/T3,'File already open: ',A)
  3075.  220  FORMAT (/T3,'File not found: ',A)
  3076.  230  FORMAT (/T3,A,' file exists: ',A/T5,'[O]verwrite'/T5,'[A]ppend'
  3077.      1/T5,'[N]ew file spec'/T3,'Enter here: ')
  3078.  240  FORMAT (A1)
  3079.       END
  3080.       SUBROUTINE PAGE (N)
  3081. C 
  3082. C     THIS SUBROUTINE DOES THE GENERAL PAGE COUNTING FOR TIDY WHILE
  3083. C     LIMITING THE OUTPUT TO MAXLIN LINES PER PAGE.
  3084. C 
  3085. C          N>0 -- I WILL WRITE N LINES.  START A NEW PAGE IF NECESSARY.
  3086. C          N=0 -- START A NEW PAGE.
  3087. C          N<0 -- START A NEW PAGE IF .LT. -N LINES ARE LEFT.
  3088. C 
  3089.       INCLUDE 'TIDY.INC'
  3090.       INCLUDE 'UNITS.INC'
  3091.       DATA MAXLIN/56/
  3092. C 
  3093.       IF (N.LT.0) THEN
  3094. C                            CONDITIONAL EJECT (NO LINES WRITTEN)
  3095.            IF ((LINE-N).LE.MAXLIN) RETURN
  3096.       ELSE IF (N.GT.0) THEN
  3097.            LINE=LINE+N
  3098.            IF (LINE.LE.MAXLIN) RETURN
  3099.       END IF
  3100. C                            MAKE NEW PAGE
  3101.       IF (LINE.NE.0) THEN
  3102.            LINE=0
  3103.            IF (N.GT.0) LINE=N
  3104.            NPAGE=NPAGE+1
  3105.            MPAGE=MPAGE+1
  3106.            WRITE (OUTFIL,10) NROUT,IPASS,MPAGE,NPAGE,JOB
  3107.       END IF
  3108.       RETURN
  3109. C 
  3110. C 
  3111.  10   FORMAT (/'1',6X,'* T I D Y *          ROUTINE',I4,4X,'PASS',I2,2X,
  3112.      1'PAGE',I3,21X,'PAGE',I4/7X,80A1/1X)
  3113.       END
  3114.       SUBROUTINE PASS1
  3115. C 
  3116. C     THIS ROUTINE COLLECTS STATEMENT NUMBERS, MAKES DIAGNOSTIC COMMENTS
  3117. C     AND SETS UP THE FORTRAN STATEMENTS IN A FORM SUITABLE FOR PASS2.
  3118. C 
  3119.       INTEGER JTMP(8)
  3120.       INCLUDE 'TIDY.INC'
  3121.       INCLUDE 'UNITS.INC'
  3122.       CHARACTER*2 JNT,JT,ICH,KUPPER,PRVCPY
  3123.       COMMON /PS1SUB/ KSTC(5),NIFBLK
  3124.       DIMENSION KCNDO(1500)
  3125.       LOGICAL BAKSCN
  3126. C 
  3127. C     A    B    C    D    E    F    G    H    I    J    K    L    M
  3128. C     1    2    3    4    5    6    7    8    9    10   11   12   13
  3129. C 
  3130. C     N    O    P    Q    R    S    T    U    V    W    X    Y    Z
  3131. C     14   15   16   17   18   19   20   21   22   23   24   25   26
  3132. C 
  3133. C     =    ,    (    /    )    +    -    *    .    $    -    '    & NONE
  3134. C     1    2    3    4    5    6    7    8    9    10   11   12   13  14
  3135. C 
  3136. C 
  3137. C     SET UP INITIAL CONDITIONS.
  3138. C     REWIND TAPE FILES 1 AND 2.
  3139. C 
  3140.    10 CALL IOSY11
  3141.       CALL IOSY21
  3142.       DO 20 I=1,10
  3143.            LDOS(I)=0
  3144.    20 CONTINUE
  3145.       IMAX=1326
  3146.       IPASS=1
  3147.       ICOL=0
  3148.       KOUNT=0
  3149.       MP2=1
  3150.       NBLC=2
  3151.       MPUN=KPUN
  3152.       MPRIN=KPRIN
  3153.       NROUT=NROUT+1
  3154.       NRT1=0
  3155.       NRT2=0
  3156.       MILDO=0
  3157.       MLGC=-1
  3158.       MSKP=0
  3159.       MPAGE=0
  3160.       MTRAN=0
  3161.       NDEF=0
  3162.       NDOS=0
  3163.       NFORT=0
  3164.       NREC=0
  3165.       NREF=0
  3166.       L25=0
  3167.       NTRAN=0
  3168.       NXEQ=0
  3169.       NIFBLK=0
  3170.       KENDDO=100000
  3171.       KCNDP=0
  3172.       GO TO 50
  3173. C 
  3174. C                  ILLEGAL FIRST CHARACTER.
  3175.    30 JGOOF=9
  3176. C                  WRITE DIAGNOSTIC
  3177.    40 CALL DIAGNO (JGOOF)
  3178. C                  GET NEW CARD.
  3179. C     (UNLESS EOF ALREADY)
  3180.    50 IF (IQUIT.NE.0) GO TO 890
  3181.       CALL SKARD
  3182.       NXRF=1
  3183.       IF (IMAX.LT.ICOL) IMAX=ICOL
  3184.       DO 60 I=1,IMAX
  3185.            IOUT(I)=KBL
  3186.    60 CONTINUE
  3187.       IMAX=0
  3188. C 
  3189. C     LOOK FOR * IN COLUMN 1
  3190. C 
  3191.       IF (JINT(1).EQ.KSPK(8)) THEN
  3192.            CALL CONTRL
  3193.            IF (ISTAR.LT.0) THEN
  3194. C                  CONTROL CARD FOUND AND EXECUTED.
  3195.                 IF (MSTOP.NE.0) THEN
  3196. C                            *STOP CARD FOUND. QUIT IF FIRST OF ROUTINE
  3197.                      IF (NFORT.LE.0) THEN
  3198.                           MP2=0
  3199.                           RETURN
  3200.                      ELSE
  3201. C                            OTHERWISE BUILD AN END CARD
  3202.                           GO TO 850
  3203.                      END IF
  3204.                 END IF
  3205.                 IF (MSKP.EQ.0) GO TO 50
  3206.                 MP2=0
  3207.                 CALL NOPRO
  3208.                 GO TO 10
  3209. C                  CONTROL CARD FOR DELAYED EXECUTION. SAVE FOR PASS 2.
  3210.            ELSE IF (ISTAR.EQ.0) THEN
  3211.                 KLASS=0
  3212.                 GO TO 120
  3213.            ELSE
  3214. C                  * IN COL 1. NOT A CONTROL CARD.  PUT OUT LITERALLY
  3215. C                  UNLESS * IN COL 2. ALSO.
  3216.                 IF (JINT(2).EQ.KSPK(8)) GO TO 50
  3217.                 GO TO 110
  3218.            END IF
  3219.       END IF
  3220. C 
  3221. C     *STOP COMMAND EXIT.
  3222. C 
  3223. C     NO * IN COLUMN 1, LOOK FOR C, D, I, F, ., OR $. (UPPER CASE)
  3224. C 
  3225. C 
  3226.       IF (JINT(1).EQ.KBL) GO TO 150
  3227.       JNT=KUPPER(JINT(1))
  3228. C 
  3229. C     COMMENT CARD
  3230.       IF (JNT.EQ.KABC(3)) THEN
  3231.            IF (MCOM.EQ.0) GO TO 50
  3232.            IF (MCOM.GT.0) THEN
  3233. C                  CHECK COL 2-6. DELETE *, SKIP ON ANYTHING ELSE.
  3234.                 DO 80 JCOL=2,6
  3235.                      IF (JINT(JCOL).NE.KBL) THEN
  3236.                           IF (JINT(JCOL).EQ.KSPK(8)) THEN
  3237. C 
  3238. C     NON-BLANK IN STATEMENT FIELD.
  3239. C 
  3240.                                ICOL=6
  3241.                                DO 70 I=JCOL,JMAX
  3242.                                     ICOL=ICOL+1
  3243.                                     IOUT(ICOL)=JINT(I)
  3244.    70                          CONTINUE
  3245.                                IOUT(1)=KABC(3)
  3246.                                IF (ICOL.GT.72) ICOL=72
  3247.                                IMAX=ICOL
  3248.                                KLASS=1
  3249.                                JTYPE=0
  3250.                                L15=0
  3251.                                CALL IOSYS1 (3,KILI,SERIAL,IOUT)
  3252.                                NRT1=NRT1+1
  3253.                                GO TO 50
  3254.                           END IF
  3255.                           JINT(JCOL)=KBL
  3256.                      END IF
  3257.    80           CONTINUE
  3258.            END IF
  3259. C 
  3260. C     LOOK FOR BLANK COMMENT
  3261. C 
  3262.            DO 90 JCOL=2,JMAX
  3263.                 IF (JINT(JCOL).NE.KBL) GO TO 140
  3264.    90      CONTINUE
  3265. C 
  3266. C     BLANK COMMENT. TEST IF TWO PREVIOUS CARDS WERE BLANK
  3267. C 
  3268.            NBLC=NBLC+1
  3269.            IF (NBLC.GT.2) GO TO 50
  3270.            JINT(1)=KABC(3)
  3271.            JMAX=7
  3272.            GO TO 110
  3273.       END IF
  3274. C 
  3275. C     A BLANK LINE PRESERVED AS A COMMENT WITH NON-PRINTING FIRST CHAR
  3276. C      (SET IN SUBROUTINE READER IF *NOSTRIP OPTION TURNED ON)
  3277.       IF (JINT(1).EQ.KBLCMT) GO TO 140
  3278. C 
  3279.       IF (JNT.EQ.KABC(4).OR.JNT.EQ.KABC(9).OR.JNT.EQ.KABC(6)) THEN
  3280.            CALL DIAGNO (8)
  3281.            GO TO 50
  3282.       END IF
  3283. C 
  3284. C     LOOK FOR ANY SPECIAL CHARACTER IN COLUMN 1
  3285.       DO 100 I=1,14
  3286.            IF (JNT.EQ.KSPK(I)) THEN
  3287. C 
  3288. C     SPECIAL CHAR IN COL 1.  GIVE MSG AND TREAT AS COMMENT
  3289. C 
  3290.                 CALL DIAGNO (30)
  3291.                 GO TO 110
  3292.            END IF
  3293.   100 CONTINUE
  3294.       GO TO 150
  3295. C 
  3296. C     COMMENT CARD.  DO WE SAVE THEM...
  3297.   110 KLASS=1
  3298.   120 JTYPE=0
  3299. C 
  3300. C     WRITE STATEMENT IMAGE ON TAPE 1 FOR PASS 2.
  3301. C 
  3302.   130 L15=0
  3303.       IMAX=JMAX
  3304.       CALL IOSYS1 (3,KILI,SERIAL,JINT)
  3305.       NRT1=NRT1+1
  3306.       GO TO 50
  3307. C 
  3308. C     NON-BLANK COMMENT.
  3309. C 
  3310.   140 NBLC=0
  3311.       IF (JMAX.GT.72) JMAX=72
  3312.       GO TO 110
  3313. C 
  3314. C               ===============================================
  3315. C               *                                             *
  3316. C               *      START PROCESSING OF FORTRAN CARDS      *
  3317. C               *                                             *
  3318. C               ===============================================
  3319. C 
  3320.   150 IF (JMAX.LT.8) GO TO 40
  3321.       NFORT=NFORT+1
  3322. C     CLASSIFY STATEMENT, THEN CHECK AND CHANGE HOLLERITH FIELDS
  3323. C       (DO UNCLASSIFIED (REPLACEMENT, ETC) STATEMENTS, AND ALSO
  3324. C       THOSE IN WHICH STRINGS ARE LEGAL PARTS.
  3325.       ITYPE=0
  3326.       JCOL=6
  3327.       CALL KWSCAN (ITYPE,KSTC)
  3328.       MPASS1=1
  3329.       I=KSTC(5)
  3330.       KLASS=KSTC(2)
  3331.       NINS=KSTC(1)
  3332.       CALL HOLSCN (ITYPE,I,LNGST)
  3333. C                  CLEAR FLAGS
  3334.       MLGC=-1
  3335.       NTRAN=MTRAN
  3336.       MTRAN=0
  3337.       MEOF=-1
  3338.       JGOOF=1
  3339. C                  CLEAR STATEMENT AND REFERENCE NUMBERS
  3340.       L15=0
  3341.       L772=0
  3342. C                  CLEAR BLANK COMMENT COUNTER
  3343.       NBCOLD=NBLC
  3344.       NBLC=0
  3345. C                  SET POSITION COUNTERS.
  3346.       JCOL=7
  3347.       IF (JUST.EQ.0) THEN
  3348. C                            NO COLUMN SHIFT
  3349.            ICOL=6
  3350.   160      IF (JINT(JCOL).NE.KBL) GO TO 170
  3351.            JCOL=JCOL+1
  3352.            ICOL=ICOL+1
  3353.            GO TO 160
  3354.       END IF
  3355. C                            COLUMN=SOMETHING
  3356.       ICOL=JUST-1
  3357. C                            ADD INDENT
  3358.   170 ICOL=ICOL+INDENT*(NDOS+NIFBLK)
  3359.       ICOL=MIN0(ICOL,MXRGHT)
  3360. C                            REMEMBER THE STARTING COLUMN
  3361.       ICOLSV=ICOL
  3362. C                  ANALYSIS OF LOGICAL IF RE-ENTERS HERE.
  3363. C 
  3364. C                  SELECT NEXT COURSE ON BASIS OF FIRST SPECIAL CH.
  3365. C             =   ,   (   /  )  +  -  *   .  $  -  '  &  NONE
  3366.   180 GO TO (230,340,190,390,30,30,30,390,30,30,30,390,30,390),IFIR
  3367. C 
  3368. C                  FIRST IS (.  LOOK FOR )
  3369.   190 NPAR=0
  3370.       DO 200 NF=LFIR,JMAX
  3371.            IF (JINT(NF).EQ.KSPK(5)) NPAR=NPAR-1
  3372.            IF (JINT(NF).EQ.KSPK(3)) NPAR=NPAR+1
  3373.            IF (NPAR.EQ.0) GO TO 210
  3374.   200 CONTINUE
  3375. C                            MISSING )
  3376.       JGOOF=2
  3377.       GO TO 40
  3378. C                  THIS IS THE END OF THE FIRST STACK OF PARENS.
  3379. C                  SKIP BLANKS.
  3380. C                  FIRST LOOK FOR DO WHILE STATEMENT
  3381.   210 IF (KLASS.EQ.3) GO TO 390
  3382.       KJ=82
  3383.       CALL KWSCAN (KJ,KSTC)
  3384.       IF (KJ.EQ.82) GO TO 1580
  3385. C 
  3386.   220 NF=NF+1
  3387.       IF (NF.GE.JMAX) GO TO 390
  3388.       IF (JINT(NF).EQ.KBL) GO TO 220
  3389. C 
  3390. C                  CHARACTER REPLACEMENT STATEMENTS CAN HAVE 2 SETS OF
  3391. C                  PARENS BEFORE =.
  3392.       IF (JINT(NF).EQ.KSPK(3)) THEN
  3393.            LFIR=NF
  3394.            GO TO 190
  3395.       END IF
  3396. C 
  3397.       IF (JINT(NF).EQ.KSPK(1)) THEN
  3398. C           IF NEXT CHARACTER IS = PROCESS AS ARITHMETIC REPLACEMENT.
  3399.            LQUAL=NF
  3400.            GO TO 310
  3401.       ELSE
  3402. C           OTHERWISE, PROCESS AS FORTRAN STATEMENT
  3403.            GO TO 390
  3404.       END IF
  3405. C 
  3406. C                  FIRST SPECIAL CH. IS =.
  3407.   230 LQUAL=LFIR
  3408. C                  IS IT A DO STATEMENT.  IF NOT, GO TO ARITHMETIC PROC.
  3409. C                  LOOK FOR -D- -O-
  3410.       ICH=KABC(4)
  3411.       DO 240 J=7,JMAX
  3412.            JNT=KUPPER(JINT(J))
  3413.            IF (JNT.EQ.KBL) GO TO 240
  3414.            IF (JNT.NE.ICH) GO TO 310
  3415.            IF (ICH.EQ.KABC(15)) GO TO 250
  3416.            ICH=KABC(15)
  3417.   240 CONTINUE
  3418.       GO TO 310
  3419. C                  FOUND -D- -O- NOW LOOK FOR COMMAS.  ALLOW EXACTLY 1
  3420. C                  OR 2 COMMAS OUTSIDE OF PARENTHESES, 1 EQUALS.
  3421. C                  CERTAIN SPECIAL CHARACTERS NOT ALLOWED.
  3422.   250 NCOMA=0
  3423.       NLPS=0
  3424.       JJ=LQUAL+1
  3425.       DO 300 J=JJ,JMAX
  3426.            JNT=JINT(J)
  3427.            DO 260 I=1,14
  3428.                 IF (JNT.EQ.KSPK(I)) GO TO (310,290,270,300,280,300,300,
  3429.      1           300,300,310,300,310,310,310),I
  3430.   260      CONTINUE
  3431.            GO TO 300
  3432. C 
  3433. C     COUNT LEFT PARENTHESES
  3434.   270      NLPS=NLPS+1
  3435.            GO TO 300
  3436. C 
  3437. C     COUNT RIGHT PARENTHESES
  3438.   280      NLPS=NLPS-1
  3439.            GO TO 300
  3440. C 
  3441. C     A COMMA. DISREGARD IF INSIDE PARENTHESES, ABORT SCAN IF UNBALANCED
  3442.   290      IF (NLPS.LT.0) THEN
  3443.                 GO TO 310
  3444.            ELSE IF (NLPS.EQ.0) THEN
  3445.                 IF (NCOMA.GT.1) GO TO 310
  3446.                 NCOMA=NCOMA+1
  3447.            END IF
  3448.   300 CONTINUE
  3449. C 
  3450.       IF (NCOMA.EQ.0) GO TO 310
  3451. C                  O.K.  THIS IS A DO STATEMENT.
  3452.       KLASS=10
  3453.       JTYPE=14
  3454.       GO TO 420
  3455. C 
  3456. C              =================================================
  3457. C              *                                               *
  3458. C              *   START PROCESSING OF ARITHMETIC STATEMENT.   *
  3459. C              *                                               *
  3460. C              =================================================
  3461.   310 KLASS=6
  3462.       JTYPE=0
  3463. C 
  3464. C     IF IN ANSI MODE, CHECK LENGTH OF VARIABLE ON LEFT
  3465.       IF (MANSI.EQ.0) THEN
  3466.            IF (IFIR.EQ.1.OR.IFIR.EQ.3) THEN
  3467.                 LNGVR=0
  3468.                 DO 320 J=JCOL,LFIR-1
  3469.                      IF (JINT(J).NE.KBL) LNGVR=LNGVR+1
  3470.   320           CONTINUE
  3471.                 IF (LNGVR.GT.6) CALL DIAGNO (41)
  3472.            END IF
  3473.       END IF
  3474. C 
  3475.   330 CALL COPY (-1)
  3476.       IF (MEOF.LT.0) THEN
  3477.            GO TO 330
  3478.       ELSE IF (MEOF.GT.0.OR.LCPY.EQ.KERM) THEN
  3479.            IF (MLGC.NE.0) THEN
  3480.                 JCOL=1
  3481.                 CALL RSTAT
  3482.                 L15=L772
  3483.            END IF
  3484.            GO TO 490
  3485.       ELSE
  3486.            ICOL=ICOL+1
  3487.            MEOF=-1
  3488.            GO TO 330
  3489.       END IF
  3490. C 
  3491. C 
  3492. C     DO STATEMENTS WITH COMMA BEFORE INDEX VARIABLE
  3493.   
  3494. C                  IS IT A DO STATEMENT.  IF NOT, GO TO ARITHMETIC PROC.
  3495. C                  LOOK FOR -D- -O-
  3496. C                  (UNLESS STATEMENT IS CLASSIFIED)
  3497.   340 IF (KLASS.EQ.0) THEN
  3498.            ICH=KABC(4)
  3499.            DO 350 J=JCOL,JMAX
  3500.                 JNT=KUPPER(JINT(J))
  3501.                 IF (JNT.EQ.KBL) GO TO 350
  3502.                 IF (JNT.NE.ICH) GO TO 390
  3503.                 IF (ICH.EQ.KABC(15)) THEN
  3504.                      JCOLD=JCOL
  3505.                      JCOL=J+1
  3506.                      GO TO 360
  3507.                 END IF
  3508.                 ICH=KABC(15)
  3509.   350      CONTINUE
  3510.            GO TO 390
  3511. C 
  3512. C          CHECK FOR STATEMENT NUMBER, NEXT NON-BLANK SHOULD BE THE COMM
  3513.   360      CALL RSTAT
  3514.            IF (L772.NE.0.AND.LFIR.EQ.JCOL) THEN
  3515. C          NOW CHECK FOR VARIABLE FOLLOWED BY EQUAL SIGN.  IF FOUND, CHA
  3516. C           COMMA TO BLANK AND USE POSITION OF = AS LQUAL, PROCESS AS DO
  3517.                 JCOL=JCOL+1
  3518.                 DO 380 J=JCOL,JMAX
  3519.                      JNT=JINT(J)
  3520.                      DO 370 I=1,13
  3521.                           IF (JNT.EQ.KSPK(I)) THEN
  3522.                                JCOL=JCOLD
  3523.                                IF (I.EQ.1) THEN
  3524.                                     IFIR=I
  3525.                                     JINT(LFIR)=KBL
  3526.                                     LFIR=J
  3527.                                     LQUAL=LFIR
  3528.                                     GO TO 250
  3529.                                END IF
  3530.                                GO TO 390
  3531.                           END IF
  3532.   370                CONTINUE
  3533.   380           CONTINUE
  3534.            END IF
  3535.       END IF
  3536. C 
  3537. C              ========================================
  3538. C              *                                      *
  3539. C              *     END OF ARITHMETIC PROCESSING     *
  3540. C              *  START FORTRAN STATEMENT PROCESSING  *
  3541. C              *                                      *
  3542. C              ========================================
  3543. C 
  3544. C                  CHECK EVERY LISTED STATEMENT TYPE.
  3545.   390 IF (MPASS1.GT.1) THEN
  3546. C     MUST RE-CHECK REST OF IF-STATEMENTS
  3547.            ITYPE=0
  3548.            CALL KWSCAN (ITYPE,KSTC)
  3549.            IF (ITYPE.EQ.0) GO TO 480
  3550.       END IF
  3551.       NINS=KSTC(1)
  3552.       MPASS1=MPASS1+1
  3553. C 
  3554. C                  FOUND IT.
  3555.       IF (ITYPE.NE.0) THEN
  3556.            KLASS=KSTC(2)
  3557.            JTYPE=KSTC(3)
  3558.            IF (IFIR.NE.12) THEN
  3559. C     COMPLAIN IF NON-ANSI STATEMENT.
  3560.                 IF (MANSI.EQ.0.AND.KSTC(4).EQ.1) CALL DIAGNO (34)
  3561.                 IF (MLGC.NE.0) GO TO 400
  3562. C                            FOLLOWS LOGICAL IF OR IS FUNCTION DECL.
  3563.                 IF (KLASS.EQ.3.OR.KLASS.EQ.4.OR.KLASS.EQ.6.OR.KLASS.EQ.7
  3564.      1           .OR.KLASS.EQ.11) GO TO 450
  3565.                 GO TO 40
  3566.            ELSE
  3567. C        COMPLAIN IF FIRST SPECIAL CHAR ' AND NOT INCLUDE OR PRINT
  3568.                 IF (ITYPE.NE.71.AND.ITYPE.NE.43.AND.ITYPE.NE.44) GO TO
  3569.      1           30
  3570.            END IF
  3571.       ELSE
  3572. C 
  3573. C                  NOT IN TABLE.  PASS IT WITHOUT PROCESSING.
  3574.            CALL DIAGNO (30)
  3575.            KLASS=11
  3576.            JTYPE=0
  3577.       END IF
  3578. C 
  3579. C                  THIS IS A FORTRAN STATEMENT.
  3580. C                  SET IMAX IN CASE THIS STATEMENT IS PUT OUT DIRECTLY.
  3581.   400 IMAX=JMAX
  3582. C                  CHECK FOR EXEMPT STATEMENT.
  3583.       IF (KLASS.EQ.3) THEN
  3584.            DO 410 J=1,6
  3585.                 JINT(J)=KBL
  3586.   410      CONTINUE
  3587.            IF (MEX.EQ.0) GO TO 450
  3588. C                  THIS IS A NON-EXECUTABLE (KLASS 3.) FORTRAN STATEMENT
  3589. C                  AND THE EXEMPT FLAG IS SET.  SO PUT IT OUT DIRECTLY.
  3590.            GO TO 130
  3591.       END IF
  3592. C 
  3593. C                  GET STATEMENT NUMBER UNLESS FOLLOWING LOGICAL IF.
  3594.       IF (MLGC.EQ.0) GO TO 450
  3595.   420 DO 440 I=1,5
  3596.            IF (JINT(I).NE.KBL) THEN
  3597.                 DO 430 J=1,10
  3598.                      IF (JINT(I).EQ.KDIG(J)) THEN
  3599.                           L15=L15*10+J-1
  3600.                           GO TO 440
  3601.                      END IF
  3602.   430           CONTINUE
  3603.                 GO TO 450
  3604.            END IF
  3605.   440 CONTINUE
  3606. C 
  3607. C        IF THIS IS A WEIRD CARD, ALLOW A TRANSFER TO IT
  3608.   450 IF (KLASS.EQ.11) NTRAN=0
  3609. C 
  3610. C     GO TO INDIVIDUAL STATEMENT PROCESSING BY JTYPE.
  3611. C 
  3612.       I=JTYPE+1
  3613.       GO TO (520,550,580,590,600,610,620,650,680,720,730,750,770,780,
  3614.      1790,840,850,930,950,960,970,990,560,1000,1020,1070,1090,1100,1110,
  3615.      21140,1150,1170,1180,1190,1200,1210,1230,1320,1360,1410,1420,1430,
  3616.      31440,1160,1220,1310,1460,1540,1550,1560,1570,1580,460),I
  3617. C 
  3618. C     ==================================================================
  3619. C     *                                                                *
  3620. C     *  AT THIS POINT, COMMENTS AND ARITHMETIC STATEMENTS HAVE BEEN   *
  3621. C     *  PROCESSED.  THE STATEMENTS HAVE BEEN CLASSIFIED AS ITYPE AND  *
  3622. C     *  KLASS.  THE LAST SYMBOL USED IN SCANNING THE FORTRAN STATE-   *
  3623. C     *  MENT IS KST(NINS,ITYPE), AND WAS FOUND AT JINT(LAST).  THE    *
  3624. C     *  FIRST SPECIAL CHARACTER, IF ANY, IS KSPK(IFIR), LOCATED AT    *
  3625. C     *  JINT(LFIR).  IF A STATEMENT                                   *
  3626. C     *  NUMBER IS PERMITTED, IT IS IN L15.  IF NOT, L15=0.            *
  3627. C     *  JCOL IS ON THE CURRENT CHARACTER IN THE INPUT STRING (THE     *
  3628. C     *  FIRST, UNLESS FOLLOWING A LOGICAL IF).  ICOL IS ON THE MOST   *
  3629. C     *  RECENT CHARACTER TO BE PUT INTO THE OUTPUT STRING (E.G. 6.)   *
  3630. C     *                                                                *
  3631. C     ==================================================================
  3632. C 
  3633. C                  ILLEGAL JTYPE
  3634.   460 WRITE (OUTFIL,1620) JTYPE
  3635.       STOP 126
  3636. C 
  3637. C                  COPY REST OF CARD.
  3638.   470 ICOL=ICOL+1
  3639.   480 CALL COPY (0)
  3640.       IF (KLASS.LT.4) GO TO 500
  3641. C                  DLIST HANDLES THE STATEMENT NUMBER.
  3642.   490 CALL DLIST (MERR)
  3643.       IF (MERR.NE.0) GO TO 50
  3644.   500 IMAX=ICOL
  3645. C                  WRITE STATEMENT IMAGE ON TAPE1 FOR PASS 2.
  3646.   510 CALL IOSYS1 (3,KILI,SERIAL,IOUT)
  3647.       NRT1=NRT1+1
  3648.       GO TO 50
  3649. C 
  3650. C                  ***** JTYPE = 0
  3651. C     UNRECOGNIZED FORTRAN CARD
  3652. C                  COPY IT, INCLUDING BLANKS
  3653.   520 DO 530 I=JCOL,1600
  3654.            ICOL=ICOL+1
  3655.            IOUT(ICOL)=JINT(I)
  3656.            IF (IOUT(ICOL).EQ.KERM) GO TO 540
  3657.   530 CONTINUE
  3658.       I=1600
  3659.   540 JCOL=I
  3660.       LCPY=KERM
  3661.       ICOL=ICOL-1
  3662.       MEOF=0
  3663.       GO TO 490
  3664. C 
  3665. C                  ***** JTYPE = 1
  3666. C     ASCENT,MACHINE.
  3667.   550 I=0
  3668.       GO TO 570
  3669. C 
  3670. C                  ***** JTYPE = 22
  3671. C     IDENT
  3672. C 
  3673.   560 MP2=1
  3674. C            (MUST BE THE FIRST CARD OF THIS PASS.)
  3675.   570 IF (NFORT.NE.1) CALL DIAGNO (14)
  3676.       CALL DIAGNO (26)
  3677.       CALL NOPRO
  3678.       CALL HEADER
  3679.       RETURN
  3680. C 
  3681. C                  ***** JTYPE = 2
  3682. C     ASSIGN
  3683. C 
  3684.   580 CALL COPY (6)
  3685.       CALL RSTAT
  3686.       CALL RLIST
  3687.       IOUT(ICOL+2)=KLR2
  3688.       IF (NXRF.GT.MXREF) GO TO 1600
  3689.       IOUTN(NXRF)=L772
  3690.       NXRF=NXRF+1
  3691.       ICOL=ICOL+3
  3692.       CALL COPY (2)
  3693.       IF (MEOF.LT.0) GO TO 470
  3694.       GO TO 40
  3695. C 
  3696. C                  ***** JTYPE = 3
  3697. C     BACKSPACE, EXTERNAL, IMPLICIT, PAUSE.
  3698. C 
  3699.   590 CALL COPY (NINS)
  3700. C     FINISH AN IMPLICIT STATEMENT
  3701.       IF (ITYPE.EQ.65) THEN
  3702.            ICOL=ICOL+1
  3703.            GO TO 390
  3704.       END IF
  3705.       GO TO 470
  3706. C 
  3707. C                  ***** JTYPE = 4
  3708. C      BLOCK DATA
  3709. C 
  3710.   600 IF (NFORT.NE.1) GO TO 40
  3711.       CALL COPY (5)
  3712.       ICOL=ICOL+1
  3713.       CALL COPY (4)
  3714.       GO TO 470
  3715. C 
  3716. C                  ***** JTYPE = 5
  3717. C     BUFFER IN (I,P) (A,B) /// BUFFER OUT (I,P) (A,B)
  3718. C 
  3719.   610 CALL COPY (6)
  3720.       ICOL=ICOL+1
  3721. C                  NINS IS 9 FOR BUFFERIN, 10 FOR BUFFEROUT
  3722.       CALL COPY (NINS-7)
  3723.       ICOL=ICOL+1
  3724.       CALL COPY (-1)
  3725.       ICOL=ICOL+1
  3726.       CALL COPY (-1)
  3727.       IF (MEOF.LT.0.AND.JCOL.GT.JMAX) GO TO 490
  3728.       GO TO 40
  3729. C 
  3730. C                  ***** JTYPE = 6
  3731. C     CALL   (FUNCTION,SUBROUTINE)
  3732. C 
  3733.   620 JGOOF=10
  3734.       CALL COPY (4)
  3735.       ICOL=ICOL+1
  3736.       IF (IFIR.NE.3) GO TO 480
  3737.   630 CALL COPY (1)
  3738.       IF (LCPY.NE.KSPK(3)) THEN
  3739.            IF (MEOF.LT.0) GO TO 630
  3740.            GO TO 40
  3741.       END IF
  3742.       IOUT(ICOL)=KBL2
  3743.       JCOL=JCOL-1
  3744.   640 PRVCPY=LCPY
  3745.       CALL COPY (1)
  3746.       IF (MEOF.LT.0) THEN
  3747.            IF (LCPY.EQ.KALMRK) THEN
  3748. C     ALTERNATE RETURNS MUST BE PRECEDED BY , OR (
  3749.                 IF (PRVCPY.NE.KSPK(2).AND.PRVCPY.NE.KSPK(3)) GO TO 640
  3750. C                            ARGUMENT IS *STATEMENT NUMBER
  3751. C     TRANSLATE ALTERNATE RETURN CODE IF DESIRED.
  3752.                 IF (KALTRN.NE.KBL) IOUT(ICOL)=KALTRN
  3753.                 CALL RSTAT
  3754. C 
  3755. C     NO NUMBER LEGAL ONLY FOR FUNCTIONS AND SUBROUTINES.
  3756.                 IF (L772.EQ.0) THEN
  3757.                      IF (ITYPE.EQ.29.OR.ITYPE.EQ.57) GO TO 640
  3758.                      GO TO 40
  3759.                 END IF
  3760.                 ICOL=ICOL+1
  3761.                 IOUT(ICOL)=KLR2
  3762.                 IF (NXRF.GT.MXREF) GO TO 1600
  3763.                 IOUTN(NXRF)=L772
  3764.                 NXRF=NXRF+1
  3765.                 CALL RLIST
  3766.            END IF
  3767.            GO TO 640
  3768.       END IF
  3769. C 
  3770.       IMAX=ICOL
  3771.       IF (NPAR.EQ.0) GO TO 490
  3772.       GO TO 40
  3773. C 
  3774. C                  ***** JTYPE = 7
  3775. C      COMMON
  3776. C 
  3777.   650 CALL COPY (6)
  3778.       ICOL=ICOL+1
  3779. C          J COUNTS SLASHES
  3780.       J=-2
  3781.       IF (IFIR.NE.4) GO TO 480
  3782.   660 IF (J.EQ.0) GO TO 470
  3783.       J=J+1
  3784.   670 CALL COPY (1)
  3785.       IF (LCPY.EQ.KSPK(4)) GO TO 660
  3786.       IF (MEOF.LT.0) GO TO 670
  3787.       CALL DIAGNO (11)
  3788.       GO TO 510
  3789. C 
  3790. C                  ***** JTYPE = 8
  3791. C     CONTINUE
  3792. C 
  3793.   680 JGOOF=12
  3794.       IF (L15.EQ.0) GO TO 40
  3795.       IF (MLGC.EQ.0) THEN
  3796.            DO 690 I=7,ICOL
  3797.                 IOUT(I)=KBL
  3798.   690      CONTINUE
  3799.            ICOL=ICOLSV
  3800.            MLGC=-1
  3801.       END IF
  3802.       IF (MCONT.EQ.0) THEN
  3803. C                            IS THIS A DO-LOOP TERMINATOR...
  3804.            IF (NDOS.GT.0) THEN
  3805.                 DO 700 I=1,NDOS
  3806.                      IF (L15.EQ.LDOS(I)) GO TO 710
  3807.   700           CONTINUE
  3808.            END IF
  3809. C                            COPY THE CARD
  3810.            CALL COPY (8)
  3811. C                            PROCESS STATEMENT NUMBER
  3812.            CALL DLIST (MERR)
  3813. C                            SET A FLAG
  3814.            LDEF(NDEF)=-LDEF(NDEF)
  3815.            L25=L15
  3816. C                            TAKE TRANSFER STATUS OF LAST CARD
  3817.            MTRAN=NTRAN
  3818. C                            DONT SAVE STATEMENT FOR PASS2
  3819.            GO TO 50
  3820.       END IF
  3821. C                            THIS CONTINUE STATEMENT IS TO BE RETAINED
  3822.   710 IF (NDOS.NE.0) THEN
  3823. C                            IT TERMINATES THIS DO-LOOP. INDENT
  3824. C                            ONE LESS LEVEL
  3825.            IF (L15.EQ.LDOS(NDOS).AND.MLGC.NE.0) THEN
  3826.                 ICOL=ICOL-INDENT
  3827.                 ICOLSV=ICOL
  3828.            END IF
  3829.       END IF
  3830.       CALL COPY (8)
  3831.       GO TO 490
  3832. C 
  3833. C                  ***** JTYPE = 9
  3834. C     DATA
  3835. C 
  3836.   720 CALL COPY (4)
  3837.       ICOL=ICOL+1
  3838.       IF (IFIR.NE.4) GO TO 480
  3839.       IF (JINT(JMAX).NE.KSPK(4).OR.LFIR.GE.JMAX) CALL DIAGNO (11)
  3840.       GO TO 480
  3841. C 
  3842. C                  ***** JTYPE = 10
  3843. C     DECODE (C,N,V) LIST  ///  ENCODE (C,N,V) LIST
  3844. C 
  3845.   730 JGOOF=23
  3846.       CALL COPY (6)
  3847.       ICOL=ICOL+1
  3848.       CALL COPY (1)
  3849.   740 CALL COPY (1)
  3850.       IF (LCPY.NE.KSPK(2)) THEN
  3851.            IF (MEOF.LT.0) GO TO 740
  3852.            GO TO 40
  3853.       END IF
  3854.       CALL RSTAT
  3855.       IF (L772.EQ.0) GO TO 1380
  3856.       ICOL=ICOL+1
  3857.       IOUT(ICOL)=KLR2
  3858.       IF (NXRF.GT.MXREF) GO TO 1600
  3859.       IOUTN(NXRF)=L772
  3860.       NXRF=NXRF+1
  3861.       CALL RLIST
  3862.       GO TO 1380
  3863. C 
  3864. C                  ***** JTYPE = 11
  3865. C     DIMENSION
  3866. C 
  3867.   750 JGOOF=13
  3868.       CALL COPY (9)
  3869.       ICOL=ICOL+1
  3870.       NPAR=-1
  3871.       DO 760 I=JCOL,JMAX
  3872.            CALL COPY (1)
  3873.            IF (NPAR.LT.0) THEN
  3874.                 IF (LCPY.EQ.KSPK(3)) NPAR=NPAR+1
  3875.            ELSE IF (NPAR.EQ.0) THEN
  3876.                 IF (LCPY.EQ.KSPK(5)) NPAR=NPAR+1
  3877.            ELSE
  3878.                 IF (LCPY.NE.KSPK(2)) GO TO 760
  3879.                 ICOL=ICOL+1
  3880.                 NPAR=-1
  3881.            END IF
  3882.   760 CONTINUE
  3883.       IF (NPAR.GT.0) GO TO 500
  3884.       GO TO 40
  3885. C 
  3886. C                  ***** JTYPE = 12
  3887. C     DOUBLE PRECISION
  3888. C 
  3889.   770 CALL COPY (6)
  3890.       ICOL=ICOL+1
  3891.       CALL COPY (9)
  3892.       ICOL=ICOL+1
  3893.       GO TO 390
  3894. C 
  3895. C                  ***** JTYPE = 13
  3896. C     DOUBLE, (CONVERT TO DOUBLE PRECISION).
  3897. C 
  3898.   780 CALL COPY (6)
  3899.       ICOL=ICOL+2
  3900.       CALL CPYSTR (ICOL,'PRECISION')
  3901.       ICOL=ICOL+9
  3902.       GO TO 480
  3903. C 
  3904. C                  ***** JTYPE = 14
  3905. C     DO STATEMENT
  3906. C 
  3907.   790 MILDO=1
  3908.       CALL COPY (2)
  3909.       CALL RSTAT
  3910. C 
  3911. C     IF NO STATEMENT, GIVE IT IMPOSSIBLE (FROM CARDS) NUMBER
  3912. C     KCNDO IS STACK OF CURRENTLY-OPEN ENDDO LOOPS
  3913.       IF (L772.EQ.0) THEN
  3914. C          JUMP IF CONVERSION TO F-77 LOOP NOT DESIRED.
  3915.            IF (MNDOO.NE.0) GO TO 1590
  3916.            L772=KENDDO
  3917.            KCNDP=KCNDP+1
  3918.            KCNDO(KCNDP)=KENDDO
  3919.            KENDDO=KENDDO+1
  3920.       END IF
  3921. C 
  3922. C     BE SURE IT DOESN'T REFERENCE BACKWARD IN PROGRAM.
  3923.       IF (NDEF.GT.0) THEN
  3924.            DO 800 I=1,NDEF
  3925.                 IF (IABS(LDEF(I)).EQ.L772) THEN
  3926.                      JGOOF=15
  3927.                      GO TO 40
  3928.                 END IF
  3929.   800      CONTINUE
  3930.       END IF
  3931. C 
  3932. C     ADD STATEMENT NUMBER TO DO-LIST.
  3933. C 
  3934.       IF (NDOS.LT.0) STOP 30
  3935.       IF (NDOS.GT.0) THEN
  3936.            IF (LDOS(NDOS).EQ.L772) GO TO 830
  3937.            IF (NDOS.GT.1) THEN
  3938.                 DO 810 I=2,NDOS
  3939.                      IF (LDOS(I-1).EQ.L772) THEN
  3940.                           JGOOF=15
  3941.                           GO TO 40
  3942.                      END IF
  3943.   810           CONTINUE
  3944.                 IF (NDOS.GE.10) THEN
  3945.                      JGOOF=24
  3946.                      MPUN=0
  3947.                      MP2=0
  3948.                      GO TO 40
  3949.                 END IF
  3950.            END IF
  3951.       END IF
  3952. C 
  3953.       NDOS=NDOS+1
  3954.       LDOS(NDOS)=L772
  3955.       IF (NREF.GT.0) THEN
  3956.            DO 820 I=1,NREF
  3957.                 IF (LREF(I).EQ.L772) THEN
  3958.                      CALL DIAGNO (27)
  3959.                      GO TO 830
  3960.                 END IF
  3961.   820      CONTINUE
  3962.       END IF
  3963. C 
  3964.   830 CALL RLIST
  3965.       IOUT(ICOL+2)=KLR2
  3966.       IF (NXRF.GT.MXREF) GO TO 1600
  3967.       IOUTN(NXRF)=L772
  3968.       NXRF=NXRF+1
  3969.       ICOL=ICOL+3
  3970.       GO TO 480
  3971. C 
  3972. C     END DO-LOOP STATEMENT PROCESSING.
  3973. C 
  3974. C 
  3975. C                  ***** JTYPE = 15
  3976. C     END FILE
  3977. C 
  3978.   840 IF (IFIR.NE.14) GO TO 30
  3979.       CALL COPY (3)
  3980.       ICOL=ICOL+1
  3981.       CALL COPY (4)
  3982.       GO TO 470
  3983. C 
  3984. C                  ***** JTYPE = 16
  3985. C     END STATEMENT.
  3986. C 
  3987. C                   IS THERE A STATEMENT NUMBER TO USE?
  3988.   850 IF (L15.EQ.0.AND.L25.EQ.0) GO TO 870
  3989. C                   YES. MAKE A CONTINUE CARD FOR IT TO FALL TO.
  3990.       ICOL=7
  3991.       CALL CPYSTR (ICOL,'CONTINUE')
  3992.       MILDO=0
  3993.       CALL DLIST (MERR)
  3994.       IF (MERR.NE.0) GO TO 860
  3995.       JTMP(1)=4
  3996.       JTMP(2)=8
  3997.       JTMP(3)=L15
  3998.       JTMP(4)=14
  3999.       JTMP(5)=MTRAN
  4000.       JTMP(6)=NXRF
  4001.       JTMP(7)=MEX
  4002.       JTMP(8)=ICOLSV
  4003.       CALL IOSYS1 (3,JTMP,JINT(6),IOUT)
  4004.       NRT1=NRT1+1
  4005.   860 L15=0
  4006.   870 IF (NIFBLK.GT.0) CALL DIAGNO (33)
  4007.       IF (NDOS.NE.0) THEN
  4008.            CALL DIAGNO (16)
  4009.            CALL PAGE (1)
  4010.            WRITE (OUTFIL,1610) (LDOS(I),I=1,NDOS)
  4011. C                   DOES THIS STATEMENT HAVE A NUMBER....
  4012.       END IF
  4013.       IF (L15.EQ.0) GO TO 890
  4014. C                   YES.  IS IT REFERENCED....
  4015. C                   NO.  IGNORE THE NUMBER.
  4016.       IF (NREF.LE.0) GO TO 890
  4017. C                   YES.
  4018.       DO 880 I=1,NREF
  4019.            IF (LREF(I).EQ.L15) THEN
  4020.                 CALL DIAGNO (18)
  4021. C                           GENERATE NEW STOP COMMAND.
  4022.                 CALL CPYSTR (7,'STOP')
  4023.                 MILDO=-1
  4024.                 CALL DLIST (MERR)
  4025.                 IF (MERR.NE.0) GO TO 890
  4026.                 JTMP(1)=6
  4027.                 JTMP(2)=55
  4028.                 JTMP(3)=L15
  4029.                 JTMP(4)=10
  4030.                 JTMP(5)=MTRAN
  4031.                 JTMP(6)=NXRF
  4032.                 JTMP(7)=MEX
  4033.                 JTMP(8)=ICOLSV
  4034.                 CALL IOSYS1 (3,JTMP,JINT(6),IOUT)
  4035.                 NRT1=NRT1+1
  4036.                 GO TO 890
  4037.            END IF
  4038.   880 CONTINUE
  4039. C 
  4040. C                       PROCESS FORMATS ON TAPE 2
  4041.   890 IF (NRT2.GT.0) THEN
  4042.            CALL IOSY22
  4043. C                                  INSERT BLANK COMMENT CARD.
  4044.            IF (NBLC.EQ.0) THEN
  4045.                 IOUT(1)=KABC(3)
  4046.                 DO 900 I=2,7
  4047.                      IOUT(I)=KBL
  4048.   900           CONTINUE
  4049.                 KLASS=1
  4050.                 ITYPE=0
  4051.                 L15=0
  4052.                 IMAX=7
  4053.                 CALL IOSYS1 (3,KILI,SERIAL,IOUT)
  4054.                 NRT1=NRT1+1
  4055.            END IF
  4056. C                                TRANSFER FORMAT STATEMENTS
  4057.   910      CALL IOSYS2 (4,KILI,SERIAL,IOUT)
  4058.            NRT2=NRT2-1
  4059.            ICOLSV=6
  4060.            NREC=JTYPE
  4061.            MILDO=1
  4062.            CALL DLIST (MERR)
  4063.            IF (MERR.EQ.0) THEN
  4064.                 CALL IOSYS1 (3,KILI,SERIAL,IOUT)
  4065.                 NRT1=NRT1+1
  4066.            END IF
  4067.            IF (NRT2.GT.0) GO TO 910
  4068.            CALL IOSY21
  4069.       END IF
  4070. C                                      MAKE END STATEMENT
  4071.       IF (NFEND.EQ.0.AND.NFORT.GT.0) THEN
  4072.            DO 920 I=1,6
  4073.                 IOUT(I)=KBL
  4074.   920      CONTINUE
  4075.            CALL CPYSTR (7,'END')
  4076.            KLASS=8
  4077.            ITYPE=20
  4078.            L15=0
  4079.            IMAX=9
  4080.            CALL IOSYS1 (3,KILI,SERIAL,IOUT)
  4081.            NRT1=NRT1+1
  4082.       END IF
  4083.       CALL IOSY12
  4084.       RETURN
  4085. C 
  4086. C                 ==================================
  4087. C                 *   PASS1 NORMALLY EXITS HERE.   *
  4088. C                 ==================================
  4089. C 
  4090. C 
  4091. C                  ***** JTYPE = 17
  4092. C     EQUIVALENCE
  4093. C 
  4094.   930 CALL COPY (10)
  4095.   940 CALL COPY (1)
  4096.       ICOL=ICOL+1
  4097.       CALL COPY (-1)
  4098.       IF (MEOF.LT.0) GO TO 940
  4099.       GO TO 500
  4100. C 
  4101. C                  ***** JTYPE = 18
  4102. C     FINIS.
  4103. C 
  4104.   950 MSTOP=-1
  4105.       RETURN
  4106. C 
  4107. C                  ***** JTYPE = 19
  4108. C     FORMAT (
  4109. C 
  4110.   960 JGOOF=17
  4111.       CALL JTYP19 (JRTCOD)
  4112.       GO TO (40,50,470),JRTCOD
  4113. C 
  4114. C                  ***** JTYPE = 20
  4115. C     FORTRAN,ETC
  4116. C 
  4117.   970 DO 980 I=7,JMAX
  4118.            IOUT(I)=JINT(I)
  4119.   980 CONTINUE
  4120.       IMAX=JMAX
  4121.       GO TO 510
  4122. C 
  4123. C                  ***** JTYPE = 21
  4124. C     FREQUENCY
  4125. C 
  4126.   990 JGOOF=8
  4127.       GO TO 40
  4128. C 
  4129. C                  ***** JTYPE = 23
  4130. C     GO TO (***,***),N
  4131. C 
  4132.  1000 JGOOF=19
  4133.       CALL COPY (2)
  4134.       ICOL=ICOL+1
  4135.       CALL COPY (2)
  4136.       ICOL=ICOL+1
  4137.       CALL COPY (1)
  4138.       MILDO=1
  4139.       MTRAN=MLGC
  4140. C 
  4141. C     PROCESS --GO TO LIST--.
  4142. C 
  4143.  1010 ICOL=ICOL+1
  4144.       IOUT(ICOL)=KLR2
  4145.       CALL RSTAT
  4146.       IF (L772.EQ.0) GO TO 40
  4147.       IF (NXRF.GT.MXREF) GO TO 1600
  4148.       IOUTN(NXRF)=L772
  4149.       NXRF=NXRF+1
  4150.       CALL RLIST
  4151.       CALL COPY (1)
  4152.       IF (LCPY.EQ.KSPK(2)) GO TO 1010
  4153.       IF (LCPY.NE.KSPK(5)) GO TO 40
  4154.       CALL COPY (1)
  4155.       IF (LCPY.NE.KSPK(2)) THEN
  4156.            IOUT(ICOL+2)=IOUT(ICOL)
  4157.            IOUT(ICOL)=KSPK(2)
  4158.            ICOL=ICOL+2
  4159.       END IF
  4160.       GO TO 480
  4161. C 
  4162. C                  ***** JTYPE = 24
  4163. C     GO TO ****
  4164. C 
  4165.  1020 JGOOF=19
  4166.       MILDO=-1
  4167.       CALL COPY (2)
  4168.       ICOL=ICOL+1
  4169.       CALL COPY (2)
  4170.       ICOL=ICOL+1
  4171.       CALL RSTAT
  4172. C 
  4173. C     TEST REF STATEMENT FOR GO TO N OR GO TO N, (LIST)
  4174. C 
  4175.       IF (L772.EQ.0) GO TO 1040
  4176. C 
  4177. C     STATEMENT IS --GO TO 12345--.
  4178. C 
  4179.       IF (L15.EQ.0.AND.L25.EQ.0) GO TO 1030
  4180.       IF (MLGC.EQ.0) GO TO 1030
  4181. C     LABELLED GOTO STATEMENT.
  4182.       IF (MCONT.EQ.0) THEN
  4183.            CALL DLIST (MERR)
  4184.            IF (MERR.NE.0) GO TO 40
  4185. C          SET UP REFERENCE TRANSLATION
  4186.            IF (NDEF.LT.1500) THEN
  4187.                 NDEF=NDEF+1
  4188.                 LDEF(NDEF)=0
  4189.                 LOCDEF(NDEF)=L772
  4190.                 L15=0
  4191. C               IF NO WAY TO GET HERE, DELETE IT
  4192.                 IF (NTRAN.NE.0) GO TO 50
  4193.            END IF
  4194.       ELSE
  4195.            CALL DIAGNO (18)
  4196.       END IF
  4197.  1030 MTRAN=MLGC
  4198.       IOUT(ICOL+1)=KLR2
  4199.       ICOL=ICOL+1
  4200.       IF (NXRF.GT.MXREF) GO TO 1600
  4201.       IOUTN(NXRF)=L772
  4202.       NXRF=NXRF+1
  4203.       CALL RLIST
  4204.       GO TO 490
  4205. C 
  4206. C     GO TO N OR GO TO N,LIST
  4207. C 
  4208.  1040 MTRAN=MLGC
  4209.       IF (IFIR.NE.2) THEN
  4210. C 
  4211. C          STATEMENT IS --GO TO N--.
  4212. C 
  4213.            IF (IFIR.EQ.14) GO TO 480
  4214.            GO TO 40
  4215.       END IF
  4216. C 
  4217. C     GO TO N,(LIST)
  4218. C 
  4219.  1050 CALL COPY (1)
  4220.       IF (LCPY.NE.KSPK(2)) GO TO 1050
  4221.       ICOL=ICOL+1
  4222.       CALL COPY (1)
  4223.       IF (LCPY.NE.KSPK(3)) GO TO 40
  4224.  1060 CALL RSTAT
  4225.       IF (L772.EQ.0) GO TO 40
  4226.       IOUT(ICOL+1)=KLR2
  4227.       ICOL=ICOL+1
  4228.       IF (NXRF.GT.MXREF) GO TO 1600
  4229.       IOUTN(NXRF)=L772
  4230.       NXRF=NXRF+1
  4231.       CALL RLIST
  4232.       CALL COPY (1)
  4233.       IF (LCPY.EQ.KSPK(2)) GO TO 1060
  4234.       IF (LCPY.EQ.KSPK(5)) GO TO 490
  4235.       GO TO 40
  4236. C 
  4237. C                  ***** JTYPE = 25
  4238. C     IF ACCUMULATOR OVERFLOW (QUOTIENT, DIVIDE CHECK, END FILE, SENSE)
  4239. C 
  4240.  1070 CALL COPY (2)
  4241.       ICOL=ICOL+1
  4242.       CALL COPY (11)
  4243.       ICOL=ICOL+1
  4244.       CALL COPY (8)
  4245. C 
  4246. C     PROCESS TWO-WAY TRANSFER.
  4247. C 
  4248.  1080 ICOL=ICOL+1
  4249.       JGOOF=20
  4250.       MILDO=-1
  4251.       IOUT(ICOL)=KLR2
  4252.       CALL RSTAT
  4253.       IF (L772.EQ.0) GO TO 40
  4254.       IF (NXRF.GT.MXREF) GO TO 1600
  4255.       IOUTN(NXRF)=L772
  4256.       NXRF=NXRF+1
  4257.       CALL RLIST
  4258.       CALL COPY (1)
  4259.       IF (LCPY.NE.KSPK(2)) GO TO 40
  4260.       CALL RSTAT
  4261.       IF (L772.EQ.0) GO TO 40
  4262.       GO TO 1030
  4263. C 
  4264. C                  ***** JTYPE = 26
  4265. C     IF QUOTIENT OVERFLOW
  4266. C 
  4267.  1090 CALL COPY (2)
  4268.       ICOL=ICOL+1
  4269.       CALL COPY (8)
  4270.       ICOL=ICOL+1
  4271.       CALL COPY (8)
  4272.       GO TO 1080
  4273. C 
  4274. C                  ***** JTYPE = 27
  4275. C     IF(DIVIDE CHECK)
  4276. C 
  4277.  1100 CALL COPY (2)
  4278.       ICOL=ICOL+1
  4279.       CALL COPY (7)
  4280.       ICOL=ICOL+1
  4281.       CALL COPY (6)
  4282.       GO TO 1080
  4283. C 
  4284. C                  ***** JTYPE = 28
  4285. C     IF(END FILE  I)
  4286. C 
  4287.  1110 CALL COPY (2)
  4288.       ICOL=ICOL+1
  4289.       CALL COPY (8)
  4290.       ICOL=ICOL+1
  4291.       DO 1120 I=JCOL,JMAX
  4292.            IF (JINT(I).EQ.KSPK(5)) GO TO 1130
  4293.  1120 CONTINUE
  4294.       JGOOF=20
  4295.       GO TO 40
  4296.  1130 CALL COPY (1)
  4297.       IF (LCPY.EQ.KSPK(5)) GO TO 1080
  4298.       GO TO 1130
  4299. C 
  4300. C                  ***** JTYPE = 29
  4301. C     IF(SENSE LIGHT 5) 1,2
  4302. C 
  4303.  1140 JGOOF=20
  4304.       CALL COPY (2)
  4305.       ICOL=ICOL+1
  4306.       CALL COPY (6)
  4307.       ICOL=ICOL+1
  4308.       CALL COPY (5)
  4309.       ICOL=ICOL+1
  4310.       CALL COPY (2)
  4311.       IF (LCPY.EQ.KSPK(5)) GO TO 1080
  4312.       GO TO 40
  4313. C 
  4314. C                  ***** JTYPE = 30
  4315. C     IF(SENSE SWITCH 5) 1,2
  4316. C 
  4317.  1150 CALL COPY (2)
  4318.       ICOL=ICOL+1
  4319.       CALL COPY (6)
  4320.       ICOL=ICOL+1
  4321.       CALL COPY (6)
  4322.       ICOL=ICOL+1
  4323.       CALL COPY (2)
  4324.       JGOOF=20
  4325.       IF (LCPY.EQ.KSPK(5)) GO TO 1080
  4326.       GO TO 40
  4327. C 
  4328. C                  ***** JTYPE = 43
  4329. C     ELSEIF
  4330. C 
  4331.  1160 IF (NIFBLK.LE.0) THEN
  4332.            IOUT(1)=KABC(3)
  4333.            CALL DIAGNO (32)
  4334.       ELSE
  4335.            ICOL=ICOL-INDENT
  4336.            ICOLSV=ICOL
  4337.       END IF
  4338.       CALL COPY (4)
  4339.       ICOL=ICOL+1
  4340. C          FALL THRU TO IF
  4341. C 
  4342. C                  ***** JTYPE = 31
  4343. C     IF (ARITHMETIC) 1,2,3   OR   IF (LOGICAL) STATEMENT.
  4344. C 
  4345.  1170 JGOOF=20
  4346.       CALL JTYP31 (JRTCOD)
  4347.       GO TO (40,50,500,490,180),JRTCOD
  4348. C 
  4349. C                  ***** JTYPE = 32
  4350. C     NAMELIST
  4351. C 
  4352.  1180 JGOOF=21
  4353.       CALL COPY (8)
  4354.       ICOL=ICOL+1
  4355.       J=-1
  4356.       IF (IFIR.EQ.4) GO TO 660
  4357.       GO TO 40
  4358. C 
  4359. C                  ***** JTYPE = 33
  4360. C     PRINT, TYPE, WRITE, PUNCH, READ, ACCEPT.
  4361. C 
  4362.  1190 JGOOF=22
  4363.       CALL JTYP33 (JRTCOD)
  4364.       GO TO (480,40,470,1600,490),JRTCOD
  4365. C 
  4366. C                  ***** JTYPE = 34
  4367. C     SEGMENT,OVERLAY
  4368. C 
  4369.  1200 NFORT=NFORT-1
  4370.       IF (NFORT.NE.0) CALL DIAGNO (14)
  4371.       CALL COPY (NINS)
  4372.       CALL HEADER
  4373.       IF (IFIR.EQ.3) GO TO 630
  4374.       GO TO 40
  4375. C                  ***** JTYPE = 35
  4376. C     PROGRAM, SUBROUTINE, FUNCTION.
  4377. C 
  4378.  1210 IF (NFORT.NE.1) CALL DIAGNO (14)
  4379.       CALL COPY (NINS)
  4380.       CALL HEADER
  4381.       ICOL=ICOL+1
  4382.       IF (IFIR.EQ.3) GO TO 630
  4383.       GO TO 480
  4384. C 
  4385. C 
  4386. C                  ***** JTYPE = 44
  4387. C     WRITE OUTPUT TAPE
  4388. C 
  4389.  1220 CALL COPY (1)
  4390. C                  ***** JTYPE = 36
  4391. C     READ INPUT TAPE
  4392. C 
  4393.  1230 CALL COPY (4)
  4394. C                  CONVERT TO CORRESPONDING READ/WRITE(I,N)LIST
  4395.       JGOOF=22
  4396.       ICOL=ICOL+2
  4397.       IOUT(ICOL)=KSPK(3)
  4398.       JCOL=JCOL+1
  4399. C                  SKIP TO CHARACTER E
  4400.       DO 1240 JAVB=JCOL,JMAX
  4401.            JNT=KUPPER(JINT(JAVB-1))
  4402.            IF (JNT.EQ.KABC(5)) GO TO 1250
  4403.  1240 CONTINUE
  4404. C                  COPY UNTIL COMMA
  4405.  1250 JCOL=JAVB
  4406.  1260 CALL COPY (1)
  4407.       IF (MEOF.GE.0) GO TO 40
  4408.       IF (LCPY.NE.KSPK(2)) GO TO 1260
  4409. C                  PROCESS STATEMENT NUMBER
  4410.       CALL RSTAT
  4411.       IF (L772.NE.0) GO TO 1300
  4412. C                  VARIABLE FORMAT--NO REFERENCE
  4413.       KLASS=6
  4414.  1270 CALL COPY (1)
  4415. C                  LOOK FOR COMMA
  4416.       IF (LCPY.EQ.KSPK(2)) GO TO 1290
  4417.       IF (MEOF.LT.0) GO TO 1270
  4418. C                  NO COMMA. END WITH )
  4419.  1280 ICOL=ICOL+1
  4420.       IOUT(ICOL)=KSPK(5)
  4421.       IMAX=ICOL
  4422.       GO TO 490
  4423. C                  REPLACE , BY ) AND GO PROCESS LIST
  4424.  1290 IOUT(ICOL)=KSPK(5)
  4425.       ICOL=ICOL+1
  4426.       GO TO 480
  4427.  1300 IOUT(ICOL+1)=KLR2
  4428.       ICOL=ICOL+1
  4429.       IF (NXRF.GT.MXREF) GO TO 1600
  4430.       IOUTN(NXRF)=L772
  4431.       NXRF=NXRF+1
  4432.       CALL RLIST
  4433.       CALL COPY (1)
  4434.       IF (LCPY.EQ.KSPK(2)) GO TO 1290
  4435.       IF (LCPY.EQ.KERM) GO TO 1280
  4436.       GO TO 40
  4437. C 
  4438. C 
  4439. C                  ***** JTYPE = 45
  4440. C     WRITE TAPE
  4441.  1310 CALL COPY (1)
  4442. C                  ***** JTYPE = 37
  4443. C     READ TAPE
  4444. C 
  4445.  1320 CALL COPY (4)
  4446.       JCOL=LAST+1
  4447.       ICOL=ICOL+2
  4448.       IOUT(ICOL)=KSPK(3)
  4449. C                  SKIP TO CHARACTER E
  4450.       DO 1330 JAVB=JCOL,JMAX
  4451.            IF (KUPPER(JINT(JAVB-1)).EQ.KABC(5)) GO TO 1340
  4452.  1330 CONTINUE
  4453. C                  COPY UNTIL COMMA
  4454.  1340 JCOL=JAVB
  4455.  1350 CALL COPY (1)
  4456.       IF (LCPY.NE.KSPK(2)) GO TO 1350
  4457.       IOUT(ICOL)=KSPK(5)
  4458.       GO TO 470
  4459. C 
  4460. C                  ***** JTYPE = 38
  4461. C     READ ( AND WRITE (
  4462. C 
  4463.  1360 JGOOF=23
  4464.  1370 CALL COPY (NINS-1)
  4465.       ICOL=ICOL+1
  4466.       NLPS=-1
  4467.  1380 CALL COPY (1)
  4468.       IF (MEOF.GE.0) GO TO 40
  4469. C     LEFT PAREN MEANS START OF AN INTERNAL READ/WRITE SUBSCRIPT
  4470.       IF (LCPY.EQ.KSPK(3)) THEN
  4471.            NLPS=NLPS+1
  4472.            GO TO 1380
  4473.       END IF
  4474. C     RIGHT PAREN - COPY REST OF CARD UNLESS CLOSING SUBSCRIPT
  4475.       IF (LCPY.EQ.KSPK(5)) THEN
  4476.            IF (NLPS.LE.0) GO TO 470
  4477.            NLPS=NLPS-1
  4478.            GO TO 1380
  4479.       END IF
  4480. C     COMMA - NUMBER WILL FOLLOW UNLESS INTERNAL WRITE SUBSCRIPT
  4481.       IF (LCPY.EQ.KSPK(2)) THEN
  4482.            IF (NLPS.EQ.0) GO TO 1400
  4483.            GO TO 1380
  4484.       END IF
  4485. C     ACCEPT ANYTHING BUT = SIGN.
  4486.       IF (LCPY.NE.KSPK(1)) GO TO 1380
  4487. C 
  4488. C     LAST CHARACTER WAS =.  CHECK KEYWORD FOR NUMBER FOLLOWING.
  4489. C      (SKIP FMT AND END FOR TYPE 47)
  4490.       IF (JTYPE.EQ.47) GO TO 1390
  4491. C     FMT
  4492.       IF (BAKSCN(KABC(20),KABC(13))) GO TO 1400
  4493. C     END
  4494.       IF (BAKSCN(KABC(4),KABC(14))) GO TO 1400
  4495. C     ERR
  4496.  1390 IF (.NOT.BAKSCN(KABC(18),KABC(18))) GO TO 1380
  4497. C 
  4498. C     GET STATEMENT NUMBER
  4499. C 
  4500.  1400 CALL RSTAT
  4501.       IF (L772.EQ.0) GO TO 1380
  4502.       IOUT(ICOL+1)=KLR2
  4503.       ICOL=ICOL+1
  4504.       IF (NXRF.GT.MXREF) GO TO 1600
  4505.       IOUTN(NXRF)=L772
  4506.       NXRF=NXRF+1
  4507.       CALL RLIST
  4508.       GO TO 1380
  4509. C 
  4510. C                  ***** JTYPE = 39
  4511. C     RETURN
  4512. C 
  4513.  1410 CALL COPY (6)
  4514.       MTRAN=MLGC
  4515.       GO TO 470
  4516. C 
  4517. C                  ***** JTYPE = 40
  4518. C     SENSE LIGHT
  4519. C 
  4520.  1420 CALL COPY (5)
  4521.       ICOL=ICOL+1
  4522.       CALL COPY (5)
  4523.       GO TO 470
  4524. C 
  4525. C                  ***** JTYPE = 41
  4526. C     STOP
  4527. C 
  4528.  1430 CALL COPY (4)
  4529.       MILDO=-1
  4530.       MTRAN=MLGC
  4531.       GO TO 470
  4532. C 
  4533. C                  ***** JTYPE = 42
  4534. C     IF (UNIT,N) L1,L2,L3,L4
  4535. C 
  4536.  1440 CALL COPY (2)
  4537.       ICOL=ICOL+1
  4538.       CALL COPY (-1)
  4539.       IF (MEOF.GE.0) GO TO 40
  4540.       ICOL=ICOL+1
  4541.       MILDO=1
  4542.       CALL DLIST (MERR)
  4543.       IF (MERR.EQ.0) THEN
  4544.            DO 1450 I=1,4
  4545.                 CALL RSTAT
  4546.                 IF (L772.EQ.0) GO TO 40
  4547.                 ICOL=ICOL+1
  4548.                 IOUT(ICOL)=KLR2
  4549.                 IF (NXRF.GT.MXREF) GO TO 1600
  4550.                 IOUTN(NXRF)=L772
  4551.                 NXRF=NXRF+1
  4552.                 CALL RLIST
  4553.                 CALL COPY (1)
  4554.                 IF (LCPY.NE.KSPK(2)) THEN
  4555.                      IF (I.EQ.4.AND.LCPY.EQ.KERM) GO TO 500
  4556.                      GO TO 40
  4557.                 END IF
  4558.  1450      CONTINUE
  4559.       END IF
  4560.       GO TO 40
  4561. C 
  4562. C                        ***** JTYPE = 46
  4563. C     COMPLEX,  INTEGER,  REAL,  LOGICAL,  CHARACTER
  4564. C 
  4565.  1460 CALL COPY (NINS)
  4566.       KTDCL=0
  4567. C 
  4568. C     CHECK IF HAS PRECISION
  4569.       IF (IFIR.EQ.8) THEN
  4570. C          STATEMENT IS E.G. REAL*8, I.E. WITH BYTE NUMBER
  4571. C          FIRST SWALLOW ANY BLANKS BEFORE IT.
  4572.  1470      IF (JCOL.EQ.LFIR) GO TO 1480
  4573.            IF (JINT(JCOL).NE.KBL) GO TO 470
  4574.            JCOL=JCOL+1
  4575.            GO TO 1470
  4576. C 
  4577. C     * WAS NEXT CHARACTER. COPY IT.
  4578.  1480      CALL COPY (1)
  4579. C 
  4580.  1490      IF (JINT(JCOL).NE.KBL) THEN
  4581. C 
  4582. C     PROCESS  *(*)
  4583.                 IF (JINT(JCOL).EQ.KSPK(3)) THEN
  4584.                      CALL COPY (3)
  4585.                      ICOL=ICOL+1
  4586.                      GO TO 480
  4587.                 END IF
  4588.                 GO TO 1510
  4589.            END IF
  4590.            JCOL=JCOL+1
  4591.            GO TO 1490
  4592. C 
  4593. C     GO PAST BYTE COUNT
  4594.  1500      CALL COPY (1)
  4595.  1510      DO 1520 I=1,10
  4596.                 IF (JINT(JCOL).EQ.KDIG(I)) GO TO 1500
  4597.  1520      CONTINUE
  4598. C 
  4599. C     POSSIBLE VIOLATION OF ANSI STANDARD (REAL*8, ETC)
  4600. C      (ONLY LEGAL SIZE DECLARATION IS CHARACTER)
  4601.            IF (MANSI.EQ.0.AND.ITYPE.NE.9) KTDCL=1
  4602.       END IF
  4603. C 
  4604. C     SEE IF IT IS A FUNCTION, IF SO ADD A SPACE AFTER
  4605.       I=29
  4606.       CALL KWSCAN (I,KSTC)
  4607.       IF (I.EQ.29) THEN
  4608.            ICOL=ICOL+1
  4609.            NINS=KSTC(1)
  4610.            CALL COPY (NINS)
  4611.            GO TO 470
  4612.       END IF
  4613. C 
  4614.       IF (KTDCL.EQ.1) CALL DIAGNO (40)
  4615. C 
  4616. C     LOOK FOR NON-ANSI INITIALIZED DECLARATIONS.
  4617.       IF (MANSI.EQ.0) THEN
  4618.            DO 1530 NF=LFIR,JMAX
  4619.                 IF (JINT(NF).EQ.KSPK(4)) THEN
  4620.                      CALL DIAGNO (42)
  4621.                      GO TO 470
  4622.                 END IF
  4623.  1530      CONTINUE
  4624.       END IF
  4625. C 
  4626.       GO TO 470
  4627. C 
  4628. C                        ***** JTYPE = 47
  4629. C     OPEN, CLOSE, INQUIRE
  4630.  1540 JGOOF=31
  4631.       GO TO 1370
  4632. C 
  4633. C                        ***** JTYPE = 48
  4634. C     ENDIF
  4635.  1550 NIFBLK=NIFBLK-1
  4636.       IF (NIFBLK.LT.0) THEN
  4637.            NIFBLK=0
  4638.            IOUT(1)=KABC(3)
  4639.            CALL DIAGNO (32)
  4640.       ELSE
  4641.            ICOL=ICOL-INDENT
  4642.            ICOLSV=ICOL
  4643.       END IF
  4644.       CALL COPY (3)
  4645.       ICOL=ICOL+1
  4646.       CALL COPY (2)
  4647.       GO TO 500
  4648. C 
  4649. C                        ***** JTYPE = 49
  4650. C     ELSE
  4651.  1560 IF (NIFBLK.LE.0) THEN
  4652.            IOUT(1)=KABC(3)
  4653.            CALL DIAGNO (32)
  4654.       ELSE
  4655.            ICOL=ICOL-INDENT
  4656.            ICOLSV=ICOL
  4657.       END IF
  4658.       CALL COPY (NINS)
  4659.       GO TO 500
  4660. C 
  4661. C                        ***** JTYPE = 50
  4662. C     ENDDO, REPEAT
  4663. C       GET CURRENT END-DO NUMBER
  4664.  1570 L15=KCNDO(KCNDP)
  4665.       KCNDP=KCNDP-1
  4666.       IF (KCNDP.LT.0) CALL DIAGNO (43)
  4667.       IF (L15.GT.0) THEN
  4668. C     CONVERT TO A CONTINUE STATEMENT
  4669. C                            PROCESS STATEMENT NUMBER
  4670.            IF (NDOS.NE.0) THEN
  4671. C                            IT TERMINATES THIS DO-LOOP. INDENT
  4672. C                            ONE LESS LEVEL
  4673.                 IF (L15.EQ.LDOS(NDOS).AND.MLGC.NE.0) THEN
  4674.                      ICOL=ICOL-INDENT
  4675.                      ICOLSV=ICOL
  4676.                 END IF
  4677.            END IF
  4678.            ICOL=ICOL+1
  4679. C     CONVERT TO A CONTINUE CARD.
  4680.            CALL CPYSTR (ICOL,'CONTINUE')
  4681.            ICOL=ICOL+8
  4682.            IOUT(ICOL)=KERM
  4683.            GO TO 490
  4684.       ELSE
  4685. C     PASS A DO WHILE LOOP TERMINATOR UNALTERED (BUT PROPERLY INDENTED)
  4686.            IF (MLGC.NE.0) THEN
  4687.                 ICOL=ICOL-INDENT
  4688.                 ICOLSV=ICOL
  4689.            END IF
  4690.            NIFBLK=NIFBLK-1
  4691.            IF (ITYPE.EQ.81) THEN
  4692. C     END DO
  4693.                 CALL COPY (3)
  4694.                 ICOL=ICOL+1
  4695.                 CALL COPY (2)
  4696.            ELSE
  4697. C     REPEAT (MICROSOFT F77)
  4698.                 CALL COPY (6)
  4699.            END IF
  4700.            GO TO 500
  4701.       END IF
  4702. C 
  4703. C                        ***** JTYPE = 51
  4704. C     DO WHILE
  4705.  1580 CALL COPY (2)
  4706.       ICOL=ICOL+1
  4707.       CALL COPY (5)
  4708. C     TREAT UNNUMBERED DO-LOOP THIS WAY IF DESIRED
  4709.  1590 ICOL=ICOL+1
  4710.       CALL COPY (0)
  4711. C     GIVE IT A NEGATIVE PSEUDO-STATEMENT NUMBER IN STACK TO PREVENT
  4712. C      CONVERSION TO CONTINUE
  4713.       KCNDP=KCNDP+1
  4714.       KCNDO(KCNDP)=-KENDDO
  4715.       KENDDO=KENDDO+1
  4716.       NIFBLK=NIFBLK+1
  4717.       GO TO 500
  4718. C 
  4719. C     TOO MANY CROSS-REFERENCES
  4720.  1600 CALL DIAGNO (35)
  4721.       MP2=0
  4722.       GO TO 50
  4723. C 
  4724. C 
  4725.  1610 FORMAT (13X,'***',10I6,'***')
  4726.  1620 FORMAT ('0JTYPE =',I3,' IS ILLEGAL.  I AM CONFUSED AND CANNOT GO O
  4727.      1N.')
  4728.       END
  4729.       SUBROUTINE PASS2
  4730. C
  4731. C     THIS ROUTINE READS THE DATA GENERATED BY PASS1 AND WRITES AND
  4732. C     PUNCHES THE RENUMBERED DECK.
  4733. C     UNNUMBERED CONTINUE AND FORMAT STATEMENTS ARE DELETED WITHOUT
  4734. C     A DIAGNOSTIC.
  4735. C     UNREACHABLE STATEMENTS ARE DELETED IF *NO CONTINUES
  4736. C     IS IN EFFECT (MCONT=0)
  4737. C
  4738.       INCLUDE 'TIDY.INC'
  4739.       INCLUDE 'UNITS.INC'
  4740. C     SET UP DIMENSIONED ARRAY FOR EFFICIENT PRINTING
  4741.       CHARACTER*2 IOUT72(72),MINUS
  4742.       EQUIVALENCE (IOUT72(1),IOUT(1)), (MINUS,KSPK(7))
  4743. C        TABLE OF EXECUTABLE(1) OR NON-EXECUTABLE(0) BY KLASS
  4744.       INTEGER IEXFLG(12)
  4745. C         KLASS    0 1 2 3 4 5 6 7 8 9 1011
  4746.       DATA IEXFLG/0,0,0,0,1,0,1,1,0,1,1,1/
  4747. C
  4748.       IF (MP2.EQ.0.OR.NRT1.LE.0) RETURN
  4749. C
  4750. C     MOVE LIST OF NEW STATEMENT NUMBERS FROM TEMP STORAGE
  4751. C
  4752.       DO 10 I=1,NDEF
  4753.            LOCDEF(I)=NEWNUM(I)
  4754.  10   CONTINUE
  4755. C
  4756. C     SET INITIAL CONSTANTS.
  4757. C
  4758.       IPASS=2
  4759.       MPAGE=0
  4760.       NREC=0
  4761.       NTRAN=0
  4762.       IMAX=1326
  4763.       JTYPE=0
  4764. C
  4765.  20   IF (NRT1.EQ.0) GO TO 200
  4766.       JTYPP=JTYPE
  4767.       IOLD=IMAX
  4768.       CALL IOSYS1 (4,KILI,SERIAL,IOUT)
  4769. C                  BLANK OUT REMAINDER OF PREVIOUS CARD, IF NECESSARY.
  4770.       IF (IMAX.LT.IOLD) THEN
  4771.            INEW=IMAX+1
  4772.            DO 30 I=INEW,IOLD
  4773.                 IOUT(I)=KBL
  4774.  30        CONTINUE
  4775.       END IF
  4776. C                  LOOK FOR $  (FOR WARNING FLAG)
  4777.       IF (KLASS.GT.1) THEN
  4778.            DO 40 I=7,IMAX
  4779.                 IF (IOUT(I).EQ.KSPK(10)) THEN
  4780.                      IF (MPRIN.EQ.0) WRITE (OUTFIL,240) IOUT72
  4781.                      WRITE (OUTFIL,230)
  4782.                      GO TO 50
  4783.                 END IF
  4784.  40        CONTINUE
  4785.       END IF
  4786. C
  4787.  50   NRT1=NRT1-1
  4788.       IF (NREC.EQ.0) THEN
  4789.            CALL HEADER
  4790.            IF (MPRIN.NE.0) CALL PAGE (0)
  4791.       END IF
  4792. C
  4793.       IF (MDEB.NE.0) WRITE (OUTFIL,210) KILI,SERIAL
  4794.       I=KLASS+1
  4795. C            0   1   2   3   4   5   6   7   8   9   10  11
  4796.       GO TO (20,130,60,130,100,100,100,70,170,130,70,100),I
  4797. C                KLASS  DESCRIPTION
  4798. C                  0.   CONTROL CARD
  4799. C                  1.   COMMENT
  4800. C                  2.   HEADER
  4801. C                  3.   NO STATEMENT NO ALLOWED (NON-EXECTUABLE)
  4802. C                  4.   CONTINUE
  4803. C                  5.   FORMAT STATEMENT.
  4804. C                  6.   STATEMENT NO. ALLOWED, NO REFERENCES
  4805. C                  7.   REFERENCES PRESENT, STATEMENT NO. ALLOWED.
  4806. C                  8.   END
  4807. C                  9.   INTRODUCTORY
  4808. C                  10.  DO
  4809. C                  11.  ELSE,ENDIF,ELSEIF, UNRECOGNIZED
  4810. C                       (TRANSFER CAN GET HERE REGARDLESS OF LABEL)
  4811. C
  4812. C     KLASS 0.   CONTROL CARD
  4813. C             RESERVED FOR FUTURE DEVELOPMENT.
  4814. C
  4815.  60   IF (MPRIN.EQ.0) THEN
  4816.            CALL PAGE (2)
  4817.            IF (MPUN.NE.0) THEN
  4818.                 WRITE (OUTFIL,280) (KIM(I,1),I=1,72)
  4819.            ELSE
  4820.                 WRITE (OUTFIL,290) (KIM(I,1),I=1,72)
  4821.            END IF
  4822.       END IF
  4823.       GO TO 130
  4824. C
  4825. C     DO REFERENCES.
  4826. C
  4827.  70   DO 80 I=7,IMAX
  4828.            JINT(I)=IOUT(I)
  4829.            IOUT(I)=KBL
  4830.  80   CONTINUE
  4831.       ICOL=6
  4832.       JCOL=7
  4833.       JMAX=IMAX
  4834.       I=1
  4835. C
  4836.  90   IF (JINT(JCOL).EQ.KLR2) THEN
  4837. C     RENUMBER A REFERENCE
  4838.            L772=IOUTN(I)
  4839.            JCOL=JCOL+1
  4840.            I=I+1
  4841.            CALL RENUM
  4842.       ELSE
  4843. C     COPY A CHARACTER
  4844.            ICOL=ICOL+1
  4845.            IOUT(ICOL)=JINT(JCOL)
  4846.            JCOL=JCOL+1
  4847.       END IF
  4848.       IF (JCOL.LE.JMAX) GO TO 90
  4849.       IMAX=ICOL
  4850. C
  4851. C          DO STATEMENT NUMBER
  4852. C
  4853.  100  L772=L15
  4854.       ICOL=0
  4855.       CALL RENUM
  4856. C        PRINT ALL LABELLED STATEMENTS, ELSE, ELSEIF, ENDIF
  4857.       IF (L772.NE.0.OR.KLASS.EQ.11) GO TO 120
  4858. C                 DELETE ALL UNLABELLED CONTINUES AND FORMATS
  4859.       IF (KLASS.EQ.4.OR.KLASS.EQ.5) GO TO 110
  4860. C           PUNCH IF THERE IS A PATH TO THIS STATEMENT
  4861.       IF (NTRAN.NE.-1) GO TO 130
  4862. C                 *CONTINUE MEANS ALL OTHER KLASSES ARE OK
  4863.       IF (MCONT.NE.0) GO TO 130
  4864. C                 PUNCH NON-EXECUTABLE STATEMENTS
  4865.       IF (IEXFLG(KLASS+1).EQ.0) GO TO 130
  4866. C     ACCEPT GOTO FOLLOWING A COMPUTED GOTO
  4867.       IF (JTYPE.EQ.24 .AND. JTYPP.EQ.23) GO TO 130
  4868.  110  IF (MDEB.NE.0) WRITE (OUTFIL,220) KLASS
  4869.       GO TO 20
  4870. C
  4871. C     REMEMBER THAT THIS STATEMENT HAS A PATH TO IT
  4872. C
  4873.  120  NTRAN=0
  4874. C
  4875. C     WRITE  (PUNCH) NEW STATEMENT.
  4876. C
  4877.  130  CALL KIMPAK
  4878.       DO 160 J=1,NCD
  4879.            NREC=NREC+KD79
  4880. C
  4881. C     IF NO SERIAL, DO NOT PRINT TRAILING BLANKS.
  4882.            IF (MSER.EQ.0) THEN
  4883.                 N72=72
  4884.                 DO 140 I=72,1,-1
  4885.                      IF (KIM(I,J).NE.KBL) THEN
  4886.                           N72=I
  4887.                           GO TO 150
  4888.                      END IF
  4889.  140            CONTINUE
  4890.            END IF
  4891.  150       IF (MPRIN.NE.0) THEN
  4892.                 CALL PAGE (1)
  4893.                 IF (MSER.LT.0) THEN
  4894.                      WRITE (OUTFIL,240) (KIM(I,J),I=1,72),KOL73,NREC
  4895.                 ELSE IF (MSER.EQ.0) THEN
  4896.                      WRITE (OUTFIL,240) (KIM(I,J),I=1,N72)
  4897.                 ELSE
  4898.                      WRITE (OUTFIL,250) (KIM(I,J),I=1,72),SERIAL
  4899.                 END IF
  4900.            END IF
  4901.            IF (MPUN.NE.0) THEN
  4902.                 NPUN=NPUN+1
  4903.                 IF (MSER.LT.0) THEN
  4904.                      WRITE (PUNFIL,260) (KIM(I,J),I=1,72),KOL73,NREC
  4905.                 ELSE IF (MSER.EQ.0) THEN
  4906.                      WRITE (PUNFIL,260) (KIM(I,J),I=1,N72)
  4907.                 ELSE
  4908.                      WRITE (PUNFIL,270) (KIM(I,J),I=1,72),SERIAL
  4909.                 END IF
  4910.            END IF
  4911. C
  4912.  160  CONTINUE
  4913. C           REMENBER IF THIS IS AN UNCONDITIONAL TRANSFER
  4914.       IF (MTRAN.EQ.-1) NTRAN=-1
  4915.       GO TO 20
  4916. C
  4917. C     END STATEMENT.
  4918. C
  4919.  170  NREC=NREC+KD79
  4920. C
  4921. C     IF NO SERIAL, DO NOT PRINT TRAILING BLANKS.
  4922.       IF (MSER.EQ.0) THEN
  4923.            DO 180 I=72,1,-1
  4924.                 IF (IOUT72(I).NE.KBL) THEN
  4925.                      N72=I
  4926.                      GO TO 190
  4927.                 END IF
  4928.  180       CONTINUE
  4929.       END IF
  4930.  190  IF (MPRIN.NE.0) THEN
  4931.            CALL PAGE (1)
  4932.            IF (MSER.LT.0) THEN
  4933.                 WRITE (OUTFIL,240) IOUT72,KOL73,NREC,MINUS
  4934.            ELSE IF (MSER.EQ.0) THEN
  4935.                 WRITE (OUTFIL,240) (IOUT72(I),I=1,N72)
  4936.            ELSE
  4937.                 WRITE (OUTFIL,250) IOUT72,SERIAL
  4938.            END IF
  4939.       END IF
  4940.       IF (MPUN.NE.0) THEN
  4941.            NPUN=NPUN+1
  4942.            IF (MSER.LT.0) THEN
  4943.                 WRITE (PUNFIL,260) IOUT72,KOL73,NREC,MINUS
  4944.            ELSE IF (MSER.EQ.0) THEN
  4945.                 WRITE (PUNFIL,260) (IOUT72(I),I=1,N72)
  4946.            ELSE
  4947.                 WRITE (PUNFIL,270) IOUT72,SERIAL
  4948.            END IF
  4949.       END IF
  4950.  200  RETURN
  4951. C
  4952. C
  4953.  210  FORMAT (' KLASS',I3,' JTYPE',I3,' L15',I7,' IMAX',I4,' TRAN',I2,'
  4954.      1NXRF: ',I4/'  MEX=',I4,' ICOLSV = ',I3,' SERIAL:',8A2)
  4955.  220  FORMAT (' DELETING A KLASS=',I3,' STATEMENT')
  4956.  230  FORMAT ('+',110X,'$ $ $ $ $')
  4957.  240  FORMAT (7X,75A1,I4,A1)
  4958.  250  FORMAT (7X,80A1)
  4959.  260  FORMAT (75A1,I4,A1)
  4960.  270  FORMAT (80A1)
  4961.  280  FORMAT ('0',15X,72A1,5X,'--PUNCHED')
  4962.  290  FORMAT ('0',15X,72A1,5X,'--NOT PUNCHED')
  4963.       END
  4964.       SUBROUTINE RDIR
  4965. C
  4966. C     THIS SUBROUTINE GENERATES A REFERENCE DIRECTORY OF STATEMENT
  4967. C     NUMBERS SHOWING THE OLD STATEMENT NUMBER, ITS LOCATION IN THE
  4968. C     ROUTINE, AND THE NEW STATEMENT NUMBER GENERATED BY TIDY.
  4969. C
  4970.       INCLUDE 'TIDY.INC'
  4971.       INCLUDE 'UNITS.INC'
  4972.       DIMENSION INDEX(1000)
  4973.       IF (NDEF.LE.0) RETURN
  4974.       CALL PAGE (-(8+NDEF))
  4975.       CALL PAGE (4)
  4976.       WRITE (OUTFIL,60)
  4977.       DO 10 I=1,NDEF
  4978.            INDEX(I)=I
  4979.  10   CONTINUE
  4980. C
  4981. C     ADDRESS-SORT STATEMENT NUMBERS
  4982. C
  4983.       IF (NDEF.EQ.1) GO TO 40
  4984.       M=NDEF+1
  4985.  20   NR=0
  4986.       M=M-1
  4987.       DO 30 I=2,M
  4988.            J=INDEX(I-1)
  4989.            K=INDEX(I)
  4990.            IF (LDEF(J).EQ.LDEF(K)) THEN
  4991.                 INDEX(I-1)=K
  4992.                 INDEX(I)=J
  4993.                 NR=1
  4994.            END IF
  4995.  30   CONTINUE
  4996.       IF (NR.NE.0) GO TO 20
  4997. C
  4998. C     WRITE  DIRECTORY
  4999. C
  5000.  40   DO 50 I=1,NDEF
  5001.            NW1=NEWNUM(I)
  5002.            NO1=LDEF(I)
  5003.            LO1=LOCDEF(I)
  5004.            J=INDEX(I)
  5005.            NW2=NEWNUM(J)
  5006.            NO2=LDEF(J)
  5007.            LO2=LOCDEF(J)
  5008.            CALL PAGE (1)
  5009.            WRITE (OUTFIL,70) NW1,NO1,LO1,NO2,LO2,NW2
  5010.  50   CONTINUE
  5011.       CALL PAGE (3)
  5012.       WRITE (OUTFIL,80)
  5013.       RETURN
  5014. C
  5015.  60   FORMAT ('0',32X,'STATEMENT NUMBER DIRECTORY'/'0',22X,'NEW    OLD
  5016.      1 LOC',13X,'OLD   LOC      NEW'/1X)
  5017.  70   FORMAT (21X,I5,' = ',I6,',(',I4,').',8X,I6,',(',I4,') = ',I5,'.')
  5018.  80   FORMAT ('0',20X,'OLD STATEMENT NUMBERS NOT APPEARING IN THIS DIREC
  5019.      1TORY'/21X,'WERE NOT REFERENCED AND HENCE ARE DELETED.')
  5020.       END
  5021.       SUBROUTINE READER
  5022. C     THIS ROUTINE READS CARDS ONE BY ONE, UNTIL IT FINDS A
  5023. C     NON-BLANK ONE, THEN RETURNS.   IF IT FINDS AN END-OF-FILE, OR IF
  5024. C     IQUIT IS NON-ZERO, IT GENERATES A *STOP CARD.
  5025.       INCLUDE 'TIDY.INC'
  5026.       INCLUDE 'UNITS.INC'
  5027.       IF (IQUIT.NE.0) GO TO 30
  5028. 10    READ (INFILE,60,END=30) KBUFF
  5029. C
  5030. C     QUICK CHECK IF THERE IS SOMETHING THERE...
  5031.       IF (KBUFF(7).NE.KBL) RETURN
  5032. C
  5033. C     LOOK FOR A TOTALLY BLANK CARD.
  5034.       DO 20 I=1,72
  5035.            IF (KBUFF(I).NE.KBL) RETURN
  5036. 20    CONTINUE
  5037. C
  5038. C     BLANK CARD. IF INCLUDE FLAG IS SET, MAKE FIRST CHARACTER SPECIAL
  5039. C      CODE SO CAN BE RECOGNIZED AS A BLANK COMMENT.
  5040. C      OTHERWISE ISSUE MESSAGE AND GET NEXT CARD.
  5041.       IF (KBKCOK.EQ.1) THEN
  5042.            KBUFF(1)=KBLCMT
  5043.            KBUFF(2)=KERM
  5044.            RETURN
  5045.       ELSE
  5046.            CALL PAGE (1)
  5047.            WRITE (OUTFIL,70)
  5048.            GO TO 10
  5049.       END IF
  5050. C                            NO MORE INPUT
  5051. 30    IQUIT=1
  5052.       KBUFF(1)=KSPK(8)
  5053.       KBUFF(2)=KABC(19)
  5054.       KBUFF(3)=KABC(20)
  5055.       KBUFF(4)=KABC(15)
  5056.       KBUFF(5)=KABC(16)
  5057.       DO 40 I=6,72
  5058.            KBUFF(I)=KBL
  5059. 40    CONTINUE
  5060.       L15=0
  5061.       L25=0
  5062.       RETURN
  5063. C
  5064. C
  5065. C
  5066. 60    FORMAT (80A1)
  5067. 70    FORMAT (35X,'( B L A N K   C A R D )')
  5068.       END
  5069.       SUBROUTINE REDSTR (LU,LIST,NCHR,IRF,NR,IOP)
  5070.       CHARACTER*2 LIST(NCHR)
  5071.       DIMENSION IRF(NR)
  5072. C 
  5073. C     WRITE OUT STRING AS SERIES OF 508-(CHAR*2) RECS
  5074. C      (APPARENTLY 1024 BYTES IS MAGIC NUMBER FOR PROFORT, AND EACH REC
  5075. C       HAS 4-BYTE HEADER AND TRAILER)
  5076. C 
  5077.       DATA MXCHR/508/,MXINT/254/
  5078.       NL=1
  5079.       MU=MXCHR
  5080.  10   NU=MIN0(NCHR,MU)
  5081.       NB=NU-NL+1
  5082.       CALL IOSTR (LU,LIST(NL),NB,IOP)
  5083.       IF (NCHR.GT.NU) THEN
  5084.            MU=MU+MXCHR
  5085.            NL=NU+1
  5086.            GO TO 10
  5087.       END IF
  5088. C 
  5089. C     NOW DO THE CROSS-REFERENCE TABLE (253 REFS?!)
  5090.       NL=1
  5091.       MU=MXINT
  5092.  20   NU=MIN0(NR,MU)
  5093.       NB=NU-NL+1
  5094.       CALL IONUM (LU,IRF(NL),NB,IOP)
  5095.       IF (NR.GT.NU) THEN
  5096.            MU=MU+MXINT
  5097.            NL=NU+1
  5098.            GO TO 20
  5099.       END IF
  5100. C 
  5101.       RETURN
  5102.       END
  5103.       SUBROUTINE IOSTR (LU,LIST,NB,IOP)
  5104. C 
  5105. C     READ OR WRITE A STRING
  5106. C 
  5107.       CHARACTER*2 LIST(NB)
  5108.       IF (IOP.EQ.1) THEN
  5109.            WRITE (LU) LIST
  5110.       ELSE
  5111.            READ (LU) LIST
  5112.       END IF
  5113.       RETURN
  5114.       END
  5115.       SUBROUTINE IONUM (LU,IRF,NR,IOP)
  5116. C 
  5117. C     READ OR WRITE AN INTEGER ARRAY.
  5118. C 
  5119.       DIMENSION IRF(NR)
  5120.       IF (IOP.EQ.1) THEN
  5121.            WRITE (LU) IRF
  5122.       ELSE
  5123.            READ (LU) IRF
  5124.       END IF
  5125.       RETURN
  5126.       END
  5127.       SUBROUTINE RENUM
  5128. C
  5129. C     THIS SUBROUTINE INSPECTS THE OLD STATEMENT NUMBER IN L772 AND
  5130. C     INSERTS THE NEW NUMBER CORRESPONDING TO L772 IN IOUT STARTING AT
  5131. C     ICOL+1.  ON EXIT, L772 CONTAINS THE NEW STATEMENT NUMBER.
  5132. C
  5133.       INCLUDE 'TIDY.INC'
  5134. C
  5135. C     SEARCH DEFINED STATEMENT TABLE FOR L772.
  5136. C
  5137.       IF (NDEF.NE.0) THEN
  5138.            DO 50 II=1,NDEF
  5139.                 IF (LDEF(II).EQ.L772) THEN
  5140. C
  5141. C     ASSEMBLE NEW STATEMENT NUMBER.
  5142. C
  5143.                      I=NEWNUM(II)
  5144.                      L772=I
  5145.                      DO 10 L=1,5
  5146.                           IT=I/10
  5147.                           K=I-IT*10
  5148.                           J=L
  5149.                           NTEMP(J)=KDIG(K+1)
  5150.                           I=IT
  5151.                           IF (I.EQ.0) GO TO 20
  5152. 10                   CONTINUE
  5153.                      J=5
  5154. C
  5155. C     INSERT STATEMENT NUMBER DIGITS.
  5156. C
  5157. 20                   IF (ICOL.EQ.0) THEN
  5158. C                            COLUMNS 1-5
  5159.                           DO 30 IK=1,5
  5160.                                IOUT(IK)=KBL
  5161. 30                        CONTINUE
  5162.                           IF (MRIT.GE.0) THEN
  5163. C                            RIGHT ADJUST TO COLUMN -MRIT
  5164.                                ICOL=IDIM(MRIT,J)
  5165.                           ELSE
  5166. C                            LEFT ADJUST TO COLUMN MRIT
  5167.                                ICOL=MIN0(-MRIT,6-J)
  5168.                                ICOL=IDIM(ICOL,1)
  5169.                           END IF
  5170.                      END IF
  5171. 40                   ICOL=ICOL+1
  5172.                      IOUT(ICOL)=NTEMP(J)
  5173.                      J=J-1
  5174.                      IF (J.NE.0) GO TO 40
  5175.                      RETURN
  5176.                 END IF
  5177. 50         CONTINUE
  5178.       END IF
  5179. C
  5180. C     NOT IN STATEMENT NUMBER LIST. DELETE NUMBER.
  5181. C
  5182.       L772=0
  5183.       RETURN
  5184.       END
  5185.       SUBROUTINE RLIST
  5186. C 
  5187. C     THIS SUBROUTINE UPDATES THE REFERENCED STATEMENT NUMBER LIST.
  5188. C     L772 CONTAINS THE REFERENCED STATEMENT NUMBER.
  5189. C 
  5190.       INCLUDE 'TIDY.INC'
  5191.       IF (L772.EQ.0) RETURN
  5192. C                  POOR PROGRAMMING PRACTICE.
  5193.       IF (L772.EQ.L15) CALL DIAGNO (18)
  5194.       IF (NREF.LT.0) RETURN
  5195.       IF (NREF.GT.0) THEN
  5196.            DO 10 I=1,NREF
  5197.                 IF (LREF(I).EQ.L772) RETURN
  5198.  10        CONTINUE
  5199.       END IF
  5200. C 
  5201. C     ADD REFERENCED STATEMENT TO TABLE.
  5202. C 
  5203.       NREF=NREF+1
  5204.       IF (NREF.LE.1000) THEN
  5205.            LREF(NREF)=L772
  5206.       ELSE
  5207. C                  TABLE FULL
  5208.            CALL DIAGNO (7)
  5209.            NREF=-1
  5210.            MP2=0
  5211.       END IF
  5212.       RETURN
  5213.       END
  5214.       SUBROUTINE RSTAT
  5215. C 
  5216. C     THIS SUBROUTINE GETS THE STATEMENT NUMBER REFERENCED AT LOCATION
  5217. C     JCOL AND PUTS IT IN L772.  JCOL IS LEFT SET AT THE LOCATION OF THE
  5218. C     NEXT SYMBOL ON JINT.
  5219. C 
  5220.       INCLUDE 'TIDY.INC'
  5221.       L772=0
  5222.       IF (JCOL.GT.JMAX) THEN
  5223.            JCOL=JMAX
  5224.       ELSE
  5225. C 
  5226.            I=JCOL
  5227.            DO 20 JCOL=I,JMAX
  5228. C     SKIP BLANKS
  5229.                 IF (JINT(JCOL).NE.KBL) THEN
  5230.                      DO 10 J=1,10
  5231.                           IF (JINT(JCOL).EQ.KDIG(J)) THEN
  5232. C     ADD DIGIT TO NUMBER
  5233.                                L772=L772*10+J-1
  5234.                                GO TO 20
  5235.                           END IF
  5236.  10                  CONTINUE
  5237. C     ANY OTHER NON-BLANK CHAR MEANS END OF NUMBER.
  5238.                      RETURN
  5239. C 
  5240.                 END IF
  5241.  20        CONTINUE
  5242.            JCOL=JMAX
  5243.            LCPY=KERM
  5244.            MEOF=0
  5245.       END IF
  5246.       RETURN
  5247.       END
  5248.       SUBROUTINE SKARD
  5249. C 
  5250. C     super-card input routine.
  5251. C     this routine reads fortran statements with up to 19 continuation
  5252. C     cards and packs the statement into the super-card --JINT--.
  5253. C 
  5254.       INCLUDE 'TIDY.INC'
  5255.       INCLUDE 'UNITS.INC'
  5256.       LOGICAL RSHFT
  5257.       CHARACTER*2 KB1,KB6,KZERO,KC,KSTAR,KDOL,KPER,KUPPER,KB1CR1
  5258.       EQUIVALENCE (KB1,KBUFF(1)), (KB6,KBUFF(6))
  5259.       EQUIVALENCE (KZERO,KDIG(1)), (KC,KABC(3)), (KSTAR,KSPK(8)) 
  5260.       EQUIVALENCE (KDOL,KSPK(14)), (KPER,KSPK(9))
  5261. C 
  5262.       RSHFT=.TRUE.
  5263.       K72=72
  5264. C 
  5265. C     TEST FOR A CONTINUATION CARD - SHOULD NOT BE HERE
  5266. C      (ANSI F77 ALLOWS EMBEDDED COMMENTS IN CONTINUED STATEMENTS, SO
  5267. C       THIS PATCH SHOULD BE REMOVED IF A WAY TO DO THEM IS FOUND)
  5268.       IF (KBUFF(1).EQ.KAMPR.OR.(KBUFF(1).EQ.KBL.AND.(KBUFF(6)
  5269.      1.NE.KBL.AND.KBUFF(6).NE.KZERO))) THEN
  5270.            WRITE (OUTFIL,120)
  5271.            STOP 33
  5272.       END IF
  5273. C 
  5274. C     SAVE FIRST CHARACTER OF CARD
  5275.       KB1CR1=KUPPER(KBUFF(1))
  5276. C 
  5277.       JMAX=1
  5278.       DO 30 I=1,K72
  5279.            IF (KBUFF(I).EQ.KTAB) THEN
  5280.                 IF (I.LT.7.AND.RSHFT) THEN
  5281. C                  BLANK REST OF NUMBER FIELD
  5282.                      DO 10 L=JMAX,6
  5283.                           JINT(L)=KBL
  5284. 10                   CONTINUE
  5285.                      JMAX=7
  5286.                      RSHFT=.FALSE.
  5287. C     blank the serial field
  5288.                      DO 20 L=1,8
  5289.                           SERIAL(L)=KBL
  5290. 20                   CONTINUE
  5291. C     SET LINE LENGTH TO 80
  5292.                      K72=80
  5293.                      GO TO 30
  5294.                 ELSE
  5295. C     tabs past column 6 translate to spaces with f77
  5296.                      KBUFF(I)=KBL
  5297.                 END IF
  5298.            END IF
  5299.            JINT(JMAX)=KBUFF(I)
  5300.            JMAX=JMAX+1
  5301. 30    CONTINUE
  5302. C 
  5303. C     grab existing serial number if needed.
  5304.       IF (MSER.NE.0.AND.RSHFT) THEN
  5305.            DO 40 I=1,8
  5306.                 SERIAL(I)=KBUFF(I+72)
  5307. 40         CONTINUE
  5308.       END IF
  5309. C 
  5310. C     skip page header if not beginning.
  5311.       IF (KOUNT.LE.0) THEN
  5312.            CALL HEADER
  5313.            IF (MLIST.NE.0) CALL PAGE (0)
  5314.       END IF
  5315. C 
  5316.       MEOF=-1
  5317.       KOUNT=KOUNT+1
  5318.       NREC=NREC+1
  5319.       IF (MLIST.NE.0) THEN
  5320.            CALL PAGE (1)
  5321.            WRITE (OUTFIL,130) NREC,KBUFF
  5322.       END IF
  5323. C 
  5324.       NXRF=2
  5325.       J=1
  5326. C 
  5327. C     look for continuation cards and transfer them to iout via kbuff.
  5328. C 
  5329.       IF (IQUIT.NE.1) THEN
  5330. C     if first card was a comment, do not try to continue it...
  5331.            IF (KB1CR1.EQ.KC.OR.KB1CR1.EQ.KBLCMT.OR.KB1CR1.EQ.KSTAR.OR.KB
  5332.      1      1CR1.EQ.KDOL.OR.KB1CR1.EQ.KPER) THEN
  5333.                 CALL READER
  5334.                 GO TO 90
  5335.            END IF
  5336. C 
  5337. C     not comment, continuations are legal.
  5338.            DO 80 J=2,20
  5339.                 CALL READER
  5340.                 IF (IQUIT.EQ.1) GO TO 90
  5341. C     ampersand means continuation.
  5342.                 IF (KB1.EQ.KAMPR) THEN
  5343.                      K7=2
  5344.                      K72=80
  5345.                      GO TO 60
  5346.                 ELSE
  5347.                      K7=7
  5348.                      K72=72
  5349.                 END IF
  5350. C     check for a tab in number field. If so, not a continuation
  5351.                 DO 50 I=1,6
  5352.                      IF (KBUFF(I).EQ.KTAB) GO TO 90
  5353. 50              CONTINUE
  5354. C     check for continuation or comments
  5355.                 KB1=KUPPER(KB1)
  5356.                 IF (KB1.EQ.KC) GO TO 90
  5357.                 IF (KB1.EQ.KBLCMT) GO TO 90
  5358.                 IF (KB1.EQ.KSTAR) GO TO 90
  5359.                 IF (KB1.EQ.KDOL) GO TO 90
  5360.                 IF (KB1.EQ.KPER) GO TO 90
  5361.                 IF (KB6.EQ.KBL) GO TO 90
  5362.                 IF (KB6.EQ.KZERO) GO TO 90
  5363. C 
  5364. 60              DO 70 I=K7,K72
  5365.                      IF (KBUFF(I).NE.KTAB) THEN
  5366.                           JINT(JMAX)=KBUFF(I)
  5367.                      ELSE
  5368.                           JINT(JMAX)=KBL
  5369.                      END IF
  5370.                      JMAX=JMAX+1
  5371. 70              CONTINUE
  5372.                 IF (MLIST.EQ.0) GO TO 80
  5373.                 CALL PAGE (1)
  5374.                 WRITE (OUTFIL,140) KBUFF
  5375. 80         CONTINUE
  5376. C 
  5377. C     nineteen continuation cards.  load empty buffer before exiting.
  5378. C 
  5379.            J=21
  5380.            CALL READER
  5381.       END IF
  5382. C 
  5383. C     locate last non-blank column in card and exit.
  5384. C 
  5385. 90    NCD=J-1
  5386.       JMAX=JMAX-1
  5387.       DO 100 I=JMAX,1,-1
  5388.            IF (JINT(I).NE.KBL) THEN
  5389.                 JMAX=I
  5390.                 GO TO 110
  5391.            END IF
  5392. 100   CONTINUE
  5393.       JMAX=1
  5394. 110   JINT(JMAX+1)=KERM
  5395.       RETURN
  5396. C 
  5397. C 
  5398. 120   FORMAT (' FATAL ERROR - STATEMENT BEGINS WITH CONTINUATION LINE.'/
  5399.      1'  POSSIBLY COMMENT WITHIN CONTINUED STATEMENT.'/'  TIDY CANNOT PR
  5400.      2OCESS THESE ALTHOUGH THEY ARE LEGAL IN FORTRAN-77.')
  5401. 130   FORMAT (1X,I4,2X,80A1)
  5402. 140   FORMAT (7X,80A1)
  5403.       END
  5404.       SUBROUTINE USRCON
  5405. C
  5406. C     READS A SEPARATE FILE OF TIDY CONTROL CARDS SO USER DOES NOT
  5407. C     HAVE TO EDIT THEM INTO SOURCE FILE.
  5408. C
  5409.       INCLUDE 'TIDY.INC'
  5410.       INCLUDE 'UNITS.INC'
  5411. C
  5412.       WRITE (OUTFIL,30)
  5413. C
  5414.  10   READ (USRFIL,40,END=20) (JINT(I),I=1,75)
  5415.       WRITE (OUTFIL,50) (JINT(I),I=1,75)
  5416.       IF (JINT(1).NE.KSPK(8)) THEN
  5417.            WRITE (OUTFIL,60)
  5418.       ELSE
  5419.            JMAX=75
  5420.            CALL CONTRL
  5421.       END IF
  5422.       GO TO 10
  5423. C
  5424.  20   CLOSE (USRFIL,STATUS='KEEP')
  5425.       RETURN
  5426. C
  5427. C
  5428.  30   FORMAT ('1      ** T I D Y **  SPECIAL CONTROL CARD FILE')
  5429.  40   FORMAT (75A1)
  5430.  50   FORMAT ('0',75A1)
  5431.  60   FORMAT (' CONTROL CARDS MUST HAVE * IN COLUMN 1.')
  5432.       END
  5433.