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