C     PROGRAM TITLE     FLOW-CHARTER
C
C     DECUS PROGRAM NUMBER 38A, VERSION 3
C
C     PROGRAMMER        UNKNOWN
C     MODIFIED BY J.C. WYMAN/ M. JACOBSON (G.E.)
C     MODIFIED BY T.E. OSTEN (D.E.C.)
C     MODIFIED BY D.C. MILLER (BBN)
C	MODIFIED BY J. SIGONA (DOT/TSC/PDC)
C	MODIFIED BY S.R. SHAPIRO (BBN) - 30OCT72
C
C
C	EXTENSIVELY MODIFIED AND DEBUGGED FOR VERSION 3 
C	BY DAVID DYER 10/73 (INFORMATION INTERNATIONAL,L.A.)
C
C
C
C
C     FROM:
C               GENERAL ELECTRIC COMPANY
C               SPECIAL INFORMATION PRODUCTS DEPARTMENT
C               ENGINEERING PROGRAMMING AND APPLICATIONS UNIT
C               SYRACUSE, N.Y.
C
C
C
C     THIS PROGRAM WILL PRODUCE FLOW CHARTS OF FORTRAN PROGRAMS
C       DIRECTLY FROM THE SOURCE CODE. ALL FORTRAN IV STATEMENTS WILL
C       BE PROPERLY HANDLED, AS WILL ALL FORTRAN II STATEMENTS EXCEPT
C       IF ACCUMULATOR OVERFLOW, IF QUOTIENT OVERFLOW, AND IF DIVIDE
C       CHECK. THE LATTER THREE STATEMENTS WILL BE PRINTED OUT, BUT
C       NO FLOW LINES WILL BE DRAWN.
C
C     INPUT FROM DEVICE DSK (DEVICE # 1) CONSISTS OF A SEQUENCE OF
C	FORTRAN SOURCE IN CARD IMAGE EACH TERMINATED BY AN END CARD.
C
C     OUTPUT ON DEVICE DSK1 (DEVICE # 21) CONSISTS OF A LISTING OF
C	EACH SOURCE DECK FROM BEGINNING TO END STATEMENT AND EACH
C	ASSOCIATED FLOWCHART FOLLOWED BY A LIST OF ALL STATEMENT
C	NUMBERS USED BY THE PROGRAM.
C
C     OUTPUT ON DEVICE DSK0 (DEVICE # 20) CONSISTS OF A SCRATCH
C	FILE FOR EACH SOURCE DECK WHICH IS DELETED AT END OF JOB.

C
C
C     ARRAY FOR LISTING OF STATEMENT NUMBERS.
	INTEGER DSK1,DSK,DSK0
      COMMON NMBRS(1000)
C
      DIMENSION HDIG(11)
      COMMON /GOOD/ IOP,NEXITS,IESN,LOC,IRTL,JCHR,JCDS,IPL,
     1ISW,IST,IPDN,IPC,LNCT,INBX,BXCN,PASS,HMAIN,HDAT,ENDFLG
      COMMON /BAD/ BUF(72),STMNT(72,20),CNDST(1220),IEX(16),IPDL(10),
     1ALFBT(52),IRT(3,1000),LINE(130),NCOL(15),WS(10),LCHR(15)
	COMMON /DEVICE/ DSK1,DSK,DSK0
      EQUIVALENCE (ALFBT(1),HA,IA),(ALFBT(2),HB,IB),(ALFBT(3),HC,IC),
     1(ALFBT(4),HD,ID),(ALFBT(5),HE,IE),(ALFBT(6),HF,JF),
     2(ALFBT(7),HG,IG),(ALFBT(8),HH,IH),(ALFBT(9),HI,II),
     3(ALFBT(10),HJ,IJ),(ALFBT(11),HK,IK),(ALFBT(12),HL,IL),
     4(ALFBT(13),HM,IM),(ALFBT(14),HN,IN),(ALFBT(15),HO,IO),
     5(ALFBT(16),HP,IP),(ALFBT(17),HQ,IQ),(ALFBT(18),HR,IR),
     6(ALFBT(19),HS,IS),(ALFBT(20),HT,IT),(ALFBT(21),HU,IU),
     7(ALFBT(22),HV,IV),(ALFBT(23),HW,IW),(ALFBT(24),HX,IX),
     8(ALFBT(25),HY,IY),(ALFBT(26),HZ,IZ)
      EQUIVALENCE (ALFBT(27),H1,I1,HDIG(1)),(ALFBT(28),H2,I2),
     1(ALFBT(29),H3,I3),(ALFBT(30),H4,I4 ),(ALFBT(31),H5,I5),
     2(ALFBT(32),H6,I6),(ALFBT(33),H7,I7),(ALFBT(34),H8,I8),
     3(ALFBT(35),H9,I9),(ALFBT(36),H0,I0,ZERO)
      EQUIVALENCE (ALFBT(37),HBLNK,IBLNK,BLNK),
     1(ALFBT(38),HMIN,IMIN),(ALFBT(39),HPLUS,IPLUS),
     2(ALFBT(40),HSLSH,ISLSH),(ALFBT(41),HEQ,IEQ),
     3(ALFBT(42),HCOM,ICOM),(ALFBT(43),HDOL,IDOL),
     4(ALFBT(44),HPER,IPER),(ALFBT(45),HAPOS,IAPOS),
     5(ALFBT(46),HLP,ILP),(ALFBT(47),HAST,IAST),
     6(ALFBT(48),HRP,IRP),(ALFBT(49),HUA,IUA),
     7(ALFBT(50),HLT,ILT),(ALFBT(51),HGT,IGT),
     8(ALFBT(52),EOS,SENT)
      EQUIVALENCE (IIRN,IEX(1))
      LOGICAL INBX,BXCN,STMNT1
      DOUBLE PRECISION HMAIN,NAME,HDAT,XTRACT


C	INITIALIZATION FOR PASS 1
C
	TYPE 910
	TYPE 10000
10000	FORMAT(2X,'INPUT FILE MUST HAVE A .DAT EXTENSION'/'
	1 INPUT FILE NAME (5 CHARS)='$)
	ACCEPT 10001,INFIL
10001	FORMAT (A5)
	CALL IFILE (DSK,INFIL)
	TYPE 10002
10002	FORMAT(' OUTPUT FILE NAME (5 CHARS)='$)
	ACCEPT 10001,OUTFIL
	CALL OFILE (DSK1,OUTFIL)
	IEND=0
1	CALL GETREC(IEND)
	IF (IEND.EQ.-1) STOP
2	REWIND DSK0
	WRITE(DSK0)IOP
	REWIND(DSK0)
      NST8S=0
      IPDN=0
      LOC=1
      STMNT1=.TRUE.
	FIRST=.TRUE.
      PASS=1.
      IRTL=0
      DO 3 I=1,15
    3 NCOL(I)=0
    4 NEXITS=1
	IF(FIRST)WRITE (DSK1,1009)
	FIRST=.FALSE.
      IIRN=0
      IESN=0

C
C     TEST FOR COMMENT CARD
C
    5 IF(BUF(1).EQ.HC) GO TO 8
C
C     TEST FOR STATEMENT NUMBER
C
      DO 6 I=1,5
      J=6-I
      IF (BUF(J).NE.HBLNK) GO TO 7
    6 CONTINUE
      GO TO 8
C
C     STORE STATEMENT NUMBER IN INTERNAL REFERENCE NUMBER TABLE
C
    7 IESN=NUMAL(BUF,J)
      NST8S=NST8S + 1
      NMBRS(NST8S)=IESN
      IIRN=IREFIN(IESN,LOC)
C
C     MOVE CONTENTS OF CARD TO ASSEMBLY AREA
C
    8 JCHR=1
      DO 11 JCDS=1,20
      CALL MOVE (72,BUF(1),STMNT(1,JCDS))
      DO 9 I=7,72
      IF (BUF(I).EQ.HBLNK) GO TO 9
      CNDST(JCHR)=BUF(I)
      JCHR=JCHR+1
    9 CONTINUE

C
C     TEST FOR CONTINUATION CARDS
C
10	CALL GETREC(IEND)
	IF (IEND.EQ.-1) STOP
      IF(BUF(6).EQ.HBLNK.OR.BUF(6).EQ.H0.OR.BUF(1).EQ.HC) GO TO 17
   11 CONTINUE
	WRITE (DSK1,903)
	WRITE (DSK1,904)
12	CALL GETREC(IEND)
	IF (IEND.EQ.-1) STOP
C     TROUBLE -- SEARCH FOR END CARD AND PROCESS NEXT DECK
C
      J=1
      DO 16 I=7,72
      IF (BUF(I).EQ.HBLNK) GO TO 16
      GO TO (13,14,15,12),J
   13 IF (BUF(I).NE.HE) GO TO 12
      J=2
      GO TO 16
   14 IF (BUF(I).NE.HN) GO TO 12
      J=3
      GO TO 16
   15 IF (BUF(I).NE.HD) GO TO 12
      J=4
   16 CONTINUE
      GO TO 1
C
C     TEST FOR COMMENT AND WRITE INTERMEDIATE RECORD
C
   17 CNDST(JCHR)=EOS
      IF (STMNT(1,1).NE.HC) GO TO 200
   18 IOP=1
19    WRITE (DSK0,20000) LOC,IOP,JCDS,NEXITS,((STMNT(I,J),I=1,72),J
	1=1,JCDS)
	 WRITE(DSK0,20001)(IEX(I),I=1,NEXITS)
      IF (STMNT(1,1).NE.HC) LOC=LOC+1

C
C     TEST FOR END OF FIRST PASS
C
      IF (IOP.NE.6) GO TO 4
      TYPE 911,NAME
      GO TO 51
C
C     EXTRACT PROGRAM NAME IF SUBPROGRAM
C
  200 IF(.NOT.STMNT1) GO TO 20
      NAME=HMAIN
      STMNT1=.FALSE.
      IF(JCHR.LT.12) GO TO 201
      IF(CNDST(1).NE.HS)GO TO 202
C
C     TEST FOR SUBROUTINE AND EXTRACT ITS' NAME
C
      IF(CNDST(2).EQ.HU.AND.CNDST(3).EQ.HB.AND.CNDST(4).EQ.HR.AND.
     1CNDST(10).EQ.HE) NAME=XTRACT(CNDST(11))
      GO TO 20

C
C     TEST FOR BLOCK DATA
C
  201 IF(JCHR.EQ.10.AND.CNDST(1).EQ.HB.AND.CNDST(2).EQ.HL.AND.CNDST(3)
     1.EQ.HO.AND.CNDST(4).EQ.HC.AND.CNDST(5).EQ.HK) NAME=HDAT
      GO TO 20
C
C     TEST FOR FUNCTION AND EXTRACT ITS' NAME
C
  202 J=1
      DO 208 I=1,JCHR
      GO TO (203,204,205,206,207),J
  203 IF(CNDST(I).NE.HF) GO TO 208
      J=2
      GO TO 208
  204 IF(CNDST(I).NE.HU)GO TO 20
      J=3
      GO TO 208
  205 IF(CNDST(I).NE.HN) GO TO 20
      J=4
      GO TO 208
  206 IF(CNDST(I).NE.HC) GO TO 20
      J=5
      GO TO 208
  207 IF(CNDST(I).NE.HT) GO TO 20
      IF(CNDST(I+3).EQ.HN) NAME=XTRACT(CNDST(I+4))
      GO TO 20
  208 CONTINUE
C
C     TEST FOR RETURN, STOP, AND END STATEMENTS
C
   20 IF (JCHR.NE.7.OR.CNDST(1).NE.HR.OR.CNDST(2).NE.HE.OR.CNDST(3).
     1NE.HT.OR.CNDST(4).NE.HU.OR.CNDST(5).NE.HR.OR.CNDST(6).NE.HN)
     2GO TO 22
   21 IOP=5
      GO TO 19
   22 IF (JCHR.EQ.5.AND.CNDST(1).EQ.HS.AND.CNDST(2).EQ.HT.AND.CNDST(3).
     1EQ.HO.AND.CNDST(4).EQ.HP) GO TO 21
      IF (JCHR.NE.4.OR.CNDST(1).NE.HE.OR.CNDST(2).NE.HN.OR.CNDST(3).
     1NE.HD) GO TO 23
      IOP=6
      GO TO 19

C
C     TEST FOR DO STATEMENT
C
   23 IF (CNDST(1).NE.HD.OR.CNDST(2).NE.HO.OR.NUM(CNDST(3)).LE.0)
     1GO TO 29
      NEQ=0
      NCM=0
      NLP=0
      NRP=0
      DO 26 I=5,JCHR
      IF (CNDST(I-1).NE.HEQ) GO TO 24
      IF (NEQ.NE.0) GO TO 29
      NEQ=1
      GO TO 26
   24 IF (CNDST(I-1).NE.HCOM) GO TO 25
      IF (NCM.GE.2) GO TO 29
      NCM=NCM+1
      GO TO 26
   25 IF (CNDST(I-1).EQ.HLP.OR.CNDST(I-1).EQ.HRP) GO TO 29
   26 CONTINUE
      IOP=4
      IST=0
      DO 27 I=3,8
      J=NUM(CNDST(I))
      IF (J.LT.0) GO TO 28
   27 IST=10*IST+J
      GO TO 29
   28 NEXITS=2
      IEX(2)=IREFIN(IST,-1)
      GO TO 19
C
C     TEST FOR A GO TO STATEMENT
C
   29 IF (CNDST(1).NE.HG.OR.CNDST(2).NE.HO.OR.CNDST(3).NE.HT.OR.
     1CNDST(4).NE.HO) GO TO 33
      DO 30 I=5,JCHR
      IF (CNDST(I).EQ.HLP) GO TO 32
   30 CONTINUE
      IF (NUM(CNDST(5)).LT.0) GO TO 33
      IST=0
      IOP=3
      DO 31 I=5,10
      J=NUM(CNDST(I))
      IF (J.GE.0) GO TO 31
      IF (CNDST(I).EQ.EOS) GO TO 28
      GO TO 33
   31 IST=10*IST+J
      GO TO 33

C
C     GO TO SUBROUTINE FOR COMPUTED OR ASSIGNED GO TO STATEMENTS
C
   32 CALL GORT (I)
      IOP=3
      GO TO 19
C
C     TEST FOR IF STATEMENT
C
   33 IF (CNDST(1).NE.HI.OR.CNDST(2).NE.HF.OR.CNDST(3).NE.HLP) GO TO 18
      IPL=1
      DO 34 I=4,JCHR
      IF (CNDST(I).EQ.HLP) IPL=IPL+1
      IF (CNDST(I).EQ.HRP) IPL=IPL-1
      IF (IPL.EQ.0) GO TO 36
   34 CONTINUE
	WRITE (DSK1,905)
	WRITE (DSK1,904)
      GO TO 12
C
C     TEST FOR A GO TO CLAUSE IN LOGICAL IF STATEMENT
C
   36 IF (CNDST(I+1).NE.HG.OR.CNDST(I+2).NE.HO.OR.CNDST(I+3).NE.HT.OR.
     1CNDST(I+4).NE.HO) GO TO 39
      J=I+4
      DO 37 I=J,JCHR
      IF (CNDST(I).EQ.HLP) GO TO 38
   37 CONTINUE
      IF (NUM(CNDST(J+1)).LT.0) GO TO 18
   38 IOP=2
      CALL GORT (J)
      GO TO 19
C
C     TEST FOR AN ARITHMETIC IF STATEMENT
C
   39 IF (NUM(CNDST(I+1)).LT.0) GO TO 18
      GO TO 32

C
C     INITIALIZATION FOR PASS 2
C
   51 REWIND DSK0
	DO 9000 I=1,72
	DO 9000 J=1,JCDS
9000	STMNT(I,J)=' '
      PASS=2.
      LNCT=0
      INBX=.FALSE.
      BXCN=.TRUE.
      CALL REPT (IBLNK,1,130)
      LINE(58)=II
	WRITE (DSK1,906)
C
C     READ NEXT STATEMENT
C
   52 READ (DSK0,20000) LOC,IOP,JCDS,NEXITS,((STMNT(
	1I,J),I=1,72),J=1,JCDS)
	READ(DSK0,20001)(IEX(I),I=1,NEXITS)
C
C     PROCESS THIS STATEMENT FOR BOX CHARACTERISTICS
C
      IF (INBX) GO TO 53
      IF (IIRN.NE.0.AND.IRT(2,IIRN).NE.0) GO TO 55
      GO TO 56
   53 IF (IOP.NE.1) GO TO 54
      IF (IIRN.EQ.0.OR.IRT(2,IIRN).EQ.0) GO TO 57
C
C     PRINT BOTTOM OF CURRENT BOX AND START CONNECTION TO NEXT BOX
C
   54 INBX=.FALSE.
      BXCN=.TRUE.
      CALL PRNT
      CALL PRNT

C
C     CONSTRUCT LINE TO TOP OF THIS BOX IF THERE ARE ANY REFERENCES
C       TO THIS STATEMENT
C
   55 IF (IIRN.EQ.0) GO TO 56
      CALL ASSIGN (IIRN)
      IF (LINE(96).EQ.IBLNK) GO TO 56
      LINE(58)=IO
      LINE(59)=ILT
      CALL REPT (LINE(96),60,95)
      BXCN=.TRUE.
C
C     PRINT TOP OF NEW BOX
C
   56 CALL PRNT
      INBX=.TRUE.
      CALL PRNT
      CALL PRNT
C
C     TEST FOR DO LOOP TERMINATION
C
   57 IF (IPDN.EQ.0.OR.IIRN.NE.IPDL(IPDN)) GO TO 58
      CALL REPT (IPER,2*IPDN,21)
      IOP=8
      IPDN=IPDN-1
      GO TO 57
C
C     TEST FOR DO LOOP ORIGIN
C
   58 IF (IOP.NE.4) GO TO 59
      IPDN=IPDN+1
      IPDL(IPDN)=IEX(2)
      CALL REPT (IPER,2*IPDN,21)
      LINE(2*IPDN)=II
C
C     TEST FOR EXITS
C
   59 J=1
      JJ=1
   60 JJJ=J+JJ
      IF ((IOP.NE.2.AND.IOP.NE.3).OR.JJJ.GT.NEXITS) GO TO 61
      JK=IEX(JJJ)
      IF (IRT(3,JK).NE.LOC+1) GO TO 62
      JJ=JJ+1
      GO TO 60
   61 IF (J.LE.JCDS) GO TO 63
      GO TO 65
   62 CALL ASSIGN (JK)
      IF (J.LE.JCDS) GO TO 63
      CALL REPT (IBLNK,23,94)
      GO TO 64

C
C     PRINT A STATEMENT
C
   63 CALL MOVE (72,STMNT(1,J),LINE(23))
   64 CALL PRNT
      J=J+1
      IF (J.LE.MAX0(JCDS,NEXITS-JJ)) GO TO 60
   65 IF (IOP.EQ.1) GO TO 52
C
C     TEST FOR BOX BOTTOM
C
      INBX=.FALSE.
      BXCN=.FALSE.
	IF (IOP.EQ.2.OR.IOP.EQ.4.OR.IOP.EQ.8.OR.JJ.GT.1)BXCN=.TRUE.

      CALL PRNT
      CALL PRNT
      IF (IOP.NE.6) GO TO 52
C
C     PRINTING OF STATEMENT NUMBERS IN NUMERICAL SEQUENCE.
C     SORT ORDERS ARRAY OF STATEMENT NUMBERS
      CALL SORT(NST8S)
	WRITE(DSK1,907),NAME
C     TEST ON SIZE OF STATEMENT-NUMBER ARRAY.
C
	IF (NST8S.EQ.0) GO TO 209
      IF(NST8S .GT. 500)       GO TO 66
C     SIZE LESS THAN 501.  DOUBLE SPACE PRINT-OUT.
      WRITE(DSK1,908) (NMBRS(I), I = 1, NST8S)
      GO TO 2
C     SIZE GREATER THAN 500.  SINGLE SPACE PRINT-OUT.
   66 WRITE(DSK1,909) (NMBRS(I), I = 1, NST8S)
      GO TO 2
209	WRITE (DSK1,298)
	GO TO 2

C
C     FORMAT STATEMENTS
C
20000	FORMAT(I7,I2,I3,I3,/(72A1))
20001	FORMAT(I7)
298	FORMAT (/' NO STATEMENT NUMBERS USED')
  901 FORMAT (72A1,8X)
  902 FORMAT (1H-,5X,10HEND OF JOB)
  903 FORMAT (45H1MORE THAN 19 CONTINUATION CARDS IN STATEMENT)
  904 FORMAT (27H PROGRAM SKIPS TO NEXT DECK)
  905 FORMAT (40H1PARENTHESES DO NOT MATE IN IF STATEMENT)
  906 FORMAT (1H1,52X,10H(ENTRANCE))
  907 FORMAT(1H1//40X,43H LIST OF STATEMENT NUMBERS USED IN PROGRAM 
     1,A10//)
  908 FORMAT(/6X, 20I6)
  909 FORMAT( 6X, 20I6)
  910 FORMAT(' OUTPUT SCRATCH FILE ON DSK:FOR20.DAT' /
     1 16H BEGIN EXECUTION /// )
  911 FORMAT( 23H FLOW-CHARTING PROGRAM ,A10/)
1007	FORMAT (1X,72A1)
1009	FORMAT (1H1,45X,'PROGRAM LISTING'//)
      END
      SUBROUTINE PRNT
C
C     PRNT - SUBROUTINE TO EXECUTE FLOW CHART PRINTING
C
	INTEGER DSK1,DSK,DSK0
      COMMON /GOOD/ IOP,NEXITS,IESN,LOC,IRTL,JCHR,JCDS,IPL,
     1ISW,IST,IPDN,IPC,LNCT,INBX,BXCN,PASS,HMAIN,HDAT
      COMMON /BAD/ BUF(72),STMNT(72,20),CNDST(1220),IEX(16),IPDL(10),
     1ALFBT(52),IRT(3,1000),LINE(130),NCOL(15),WS(10),LCHR(15)
	COMMON /DEVICE/ DSK1, DSK, DSK0
      EQUIVALENCE (ALFBT(9),HI,II)
	EQUIVALENCE(ALFBT(22),IV)
	EQUIVALENCE(ALFBT(49),IUA)
      EQUIVALENCE (ALFBT(37),HBLNK,IBLNK)
      EQUIVALENCE (ALFBT(47),HAST,IAST)
      LOGICAL INBX,BXCN
	PNTFLG=1
C	PNTFLG=1 MAKES CLOSE SPACED LISTINGS,ANY OTHER MAKES 
C	LISTINGS WITH SPACES BETWEEN PAGES
	CALL OUT(LINE,130)
      CALL REPT (IBLNK,2*IPDN+1,130)
      IF (.NOT.INBX) GO TO 1
      CALL REPT (IAST,22,95)
      GO TO 2
   1  IF (BXCN) LINE(58)=II
   2  DO 3 I=1,15
	J=NCOL(I)
	IF (J.EQ.0)GOTO 300
	IF (IRT(3,J).GT.LOC)LCHR(I)=IV
	IF (IRT(3,J).LT.LOC.OR.LCHR(I).EQ.0)LCHR(I)=IUA
	LINE(2*I+100)=LCHR(I)
	GOTO 3
300	LCHR(I)=0
   3  CONTINUE
	IF (PNTFLG.EQ.1)GOTO 910
C
C	FOR SINGLE PAGE OUTPUT CHANGE NEXT 2 CONSTANTS TO 60,53 RESP
C	ELSE 120,110 FOR DOUBLE PAGE
C
      LNCT=MOD(LNCT+1,60)
      IF (LNCT.LT.53) RETURN
      IF (INBX) RETURN
	CALL OUT(LINE,130)
      WRITE (DSK1,902)
	CALL OUT(LINE,130)
      LNCT=1
910      RETURN
  902 FORMAT (1H1)
      END
	SUBROUTINE OUT(LARK,LEN)
	DIMENSION LARK(LEN)
	DIMENSION JET(130)
	COMMON /DEVICE/ DSK1, DSK, DSK0
	INTEGER ENDFL,TABFL,DSK1
	J=130
	ENDFL=0
	I=MOD(LEN,8)
	IF(I.EQ.0)GOTO 100
	DO 10 IA=130,130-I,-1
	IT=LARK(IA)
	IF(ENDFL.NE.0)GOTO 9
	IF(IT.EQ.' '.OR.IT.EQ.'	')GOTO 10
	ENDFL=-1
9	IF(IT.EQ.'	')IT=' '
	JET(J)=IT
	J=J-1
10	CONTINUE
100	DO 200 IA=LEN-I,8,-8
	TABFL=0
	IF (ENDFL.EQ.0)TABFL=1
	DO 150 IB=0,7
	IT=LARK(IA-IB)
	IF(TABFL.EQ.-1)GOTO 148
	IF (IT.NE.' '.AND.IT.NE.'	')GOTO 149
	IF (ENDFL.EQ.0.OR.TABFL.EQ.1)GOTO 150
	TABFL=1
	IT='	'
	GOTO 147
149	TABFL=-1
	ENDFL=-1
148	IF (IT.EQ.'	')IT=' '
147	JET(J)=IT
	J=J-1
150	CONTINUE
200	CONTINUE
	IF(J.NE.130)WRITE(DSK1,1010)(JET(I),I=J+1,130)
1010	FORMAT(1H*,130A1)
	END
      SUBROUTINE GORT (K)
C
C     GORT - SUBROUTINE TO TRACE THE FLOW OF GO TO STATEMENTS
C
      COMMON /GOOD/ IOP,NEXITS,IESN,LOC,IRTL,JCHR,JCDS,IPL,
     1ISW,IST,IPDN,IPC,LNCT,INBX,BXCN,PASS,HMAIN,HDAT
      COMMON /BAD/ BUF(72),STMNT(72,20),CNDST(1220),IEX(16),IPDL(10),
     1ALFBT(52),IRT(3,1000),LINE(130),NCOL(15),WS(10)
      EQUIVALENCE (ALFBT(42),HCOM,ICOM),(ALFBT(48),HRP,IRP),
     1(ALFBT(52),EOS,SENT)
      LOGICAL INBX,BXCN
      KK=K
      NEXITS=1
   1  DO 2 J=1,6
      L=KK+J
      IF (CNDST(L).EQ.HCOM.OR.CNDST(L).EQ.HRP.OR.CNDST(L).EQ.EOS)
     1GO TO 3
   2  WS(J)=CNDST(L)
      CALL ERROR (1)
   3  ITMP=IREFIN(NUMAL(WS,J-1),-1)
      I=2
   4  IF (I.GT.NEXITS) GO TO 5
      IF (IEX(I).EQ.ITMP) GO TO 6
      I=I+1
      GO TO 4
   5  NEXITS=NEXITS+1
      IF (NEXITS.GT.16) CALL ERROR (2)
      IEX(NEXITS)=ITMP
   6  KK=L
      IF (CNDST(L).NE.HCOM) RETURN
      GO TO 1
      END

      SUBROUTINE ASSIGN (ISN)
C
C     ASSIGN - SUBROUTINE TO CONTROL THE PRINTING OF FLOW LINES
C
      COMMON /GOOD/ IOP,NEXITS,IESN,LOC,IRTL,JCHR,JCDS,IPL,
     1ISW,IST,IPDN,IPC,LNCT,INBX,BXCN,PASS,HMAIN,HDAT
      COMMON /BAD/ BUF(72),STMNT(72,20),CNDST(1220),IEX(16),IPDL(10),
     1ALFBT(52),IRT(3,1000),LINE(130),NCOL(15),WS(10),LCHR(15)
      EQUIVALENCE (ALFBT(1),HA,IA),(ALFBT(15),HO,IO),(ALFBT(22),HV,IV),
     1(ALFBT(37),HBLNK,IBLNK),(ALFBT(44),HPER,IPER),(ALFBT(49),IUA)
	1,(ALFBT(51),HGT,IGT)
           LOGICAL INBX,BXCN
      DIMENSION JORD(15)
      DATA JORD/1,5,9,13,3,7,11,15,2,6,10,14,4,8,12/
      IF (IRT(2,ISN).EQ.0) RETURN
      DO 1 I=1,15
      IF (NCOL(I).EQ.ISN) GO TO 3
   1  CONTINUE
      IF (IRT(2,ISN).EQ.LOC) RETURN
      DO 2 J=1,15
      I=JORD(J)
      IF (NCOL(I).EQ.0) GO TO 4
   2  CONTINUE
      CALL ERROR (2)
   3  IF (IRT(2,ISN).NE.LOC) GO TO 5
      NCOL(I)=0
      GO TO 6
   4  NCOL(I)=ISN
      GO TO 6
   5  IF (IRT(3,ISN).NE.LOC) GO TO 7
6	IF (INBX)GOTO 60
	IT="575004020100
C	THE ABOVE IS A BACK ARROW

	GOTO 61
60	IT=IPER
61	LINE(2*I+99)=IT
	LCHR(I)=IUA
      LINE(2*I+100)=IO
      GO TO 8
   7  IF (IRT(3,ISN).GT.LOC) LINE(2*I+100)=IV
      IF (IRT(3,ISN).LT.LOC) LINE(2*I+100)=IA
      LINE(2*I+99)=IGT
	IT=IPER
   8  CONTINUE
      K=2*I+98
      DO 9 J=96,K
      IF (LINE(J).EQ.IBLNK) LINE(J)=IT
   9  CONTINUE
      RETURN
      END

      SUBROUTINE MOVE (N,F,T)
C
C     MOVE - SUBROUTINE TO MOVE N SUCCESSIVE WORDS FROM FIELD F TO
C     FIELD T
C
      DIMENSION F(2),T(2)
      DO 1 I=1,N
   1  T(I)=F(I)
      RETURN
      END

      SUBROUTINE REPT (K,I,J)
C
C     REPT - SUBROUTINE TO FILL ALL SUCCESSIVE PRINT LINE POSITIONS
C     BETWEEN POSITION I AND POSITION J WITH CHARACTER K
C
      COMMON /GOOD/ IOP,NEXITS,IESN,LOC,IRTL,JCHR,JCDS,IPL,
     1ISW,IST,IPDN,IPC,LNCT,INBX,BXCN,PASS,HMAIN,HDAT
      COMMON /BAD/ BUF(72),STMNT(72,20),CNDST(1220),IEX(16),IPDL(10),
     1ALFBT(52),IRT(3,1000),LINE(130),NCOL(15),WS(10)
      LOGICAL INBX,BXCN
      LINE(I)=K
      CALL MOVE (J-I,LINE(I),LINE(I+1))
      RETURN
      END

      FUNCTION NUM(X)
C
C     NUM - FUNCTION TO PROVIDE THE BINARY EQUIVALENT OF BCD DIGIT
C
      COMMON /GOOD/ IOP,NEXITS,IESN,LOC,IRTL,JCHR,JCDS,IPL,
     1  ISW,IST,IPDN,IPC,LNCT,INBX,BXCN,PASS,HMAIN,HDAT
      COMMON /BAD/ BUF(72),STMNT(72,20),CNDST(1220),IEX(16),IPDL(10),
     1  ALFBT(52),IRT(3,1000),LINE(130),NCOL(15),WS(10)
      LOGICAL INBX,BXCN
      DIMENSION HDIG(11)
      EQUIVALENCE (ALFBT(27),HDIG(1))
      DO 1 N=1,9
      NUM=N
      IF (X.EQ.HDIG(NUM)) RETURN
   1  CONTINUE
      NUM=-1
      IF (X.EQ.HDIG(10).OR.X.EQ.HDIG(11)) NUM=0
      RETURN
      END

      FUNCTION NUMAL(X,N)
C     NUMAL - FUNCTION TO PROVIDE THE NUMERIC (BINARY) EQUIVALENT
C     OF A STATEMENT NUMBER
C
      COMMON /GOOD/ IOP,NEXITS,IESN,LOC,IRTL,JCHR,JCDS,IPL,
     1  ISW,IST,IPDN,IPC,LNCT,INBX,BXCN,PASS,HMAIN,HDAT
      COMMON /BAD/ BUF(72),STMNT(72,20),CNDST(1220),IEX(16),IPDL(10),
     1  ALFBT(52),IRT(3,1000),LINE(130),NCOL(15),WS(10)
      LOGICAL INBX,BXCN
      DIMENSION HDIG(11),X(10)
      EQUIVALENCE (ALFBT(27),HDIG(1))
      NUMAL=0
      DO 1 I=1,N
      M=N+1-I
      IF (X(M).NE.HDIG(11)) GO TO 2
   1  CONTINUE
      RETURN
   2  DO 3 I=1,M
   3  NUMAL=10*NUMAL+NUM(X(I))
      RETURN
      END

      BLOCK DATA
C
C     MISC - BLOCK DATA SUBPROGRAM TO ENTER CONSTANTS INTO NAMED COMMON
C       STORAGE
C
      COMMON /GOOD/ IOP,NEXITS,IESN,LOC,IRTL,JCHR,JCDS,IPL,
     1  ISW,IST,IPDN,IPC,LNCT,INBX,BXCN,PASS,HMAIN,HDAT,ENDFLG
      COMMON /BAD/ BUF(72),STMNT(72,20),CNDST(1220),IEX(16),IPDL(10),
     1  ALFBT(52),IRT(3,1000),LINE(130),NCOL(15),WS(10)
	INTEGER DSK1,DSK,DSK0
	DATA ENDFLG/0/
      DATA             ALFBT/1HA,1HB,1HC,1HD,1HE,1HF,1HG,1HH,1HI,1HJ,
     1  1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,1HS,1HT,1HU,1HV,1HW,1HX,1HY,1HZ,
     2  1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1H0,1H ,1H-,1H+,1H/,1H=,1H,,
     3  1H$,1H.,1H',1H(,1H*,1H),1H^,1H<,1H>,5HZZZZZ /
      COMMON /DEVICE/ DSK1, DSK, DSK0
      DATA DSK1/21/, DSK/1/, DSK0/20/
      DOUBLE PRECISION HMAIN,HDAT
      DATA HMAIN/6HMAIN  /,HDAT/10HBLOCK DATA/
      END

      SUBROUTINE ERROR (I)
C
C     ERROR - SUBROUTINE TO PRINT OUT SUBROUTINE ERROR MESSAGES
C
	COMMON /DEVICE/ DSK1, DSK, DSK0
	INTEGER DSK1,DSK,DSK0
      GO TO (1,2),I
   1  WRITE (DSK1,901)
      RETURN
   2  WRITE (DSK1,902)
      RETURN
  901 FORMAT (46H1STATEMENT NUMBER TOO LARGE IN GO TO STATEMENT)
  902 FORMAT (34H1T00 MANY EXITS IN GO TO STATEMENT)
      END

      FUNCTION IREFIN(ISN,K)
C
C     IREFIN - FUNCTION TO PROVIDE INTERNAL EQUIVALENTS OF STATEMENT
C       NUMBERS
C
      COMMON /GOOD/ IOP,NEXITS,IESN,LOC,IRTL,JCHR,JCDS,IPL,
     1  ISW,IST,IPDN,IPC,LNCT,INBX,BXCN,PASS,HMAIN,HDAT
      COMMON /BAD/ BUF(72),STMNT(72,20),CNDST(1220),IEX(16),IPDL(10),
     1  ALFBT(52),IRT(3,1000),LINE(130),NCOL(15),WS(10)
      LOGICAL INBX,BXCN
      IF (IRTL.EQ.0) GO TO 2
      DO 1 I=1,IRTL
      IF (ISN.EQ.IRT(1,I)) GO TO 4
   1  CONTINUE
   2  IRTL=IRTL+1
      IRT(1,IRTL)=ISN
      IRT(2,IRTL)=0
      IREFIN=IRTL
   3  IF (K.GT.0) IRT(3,IREFIN)=LOC
      RETURN
   4  IRT(2,I)=LOC
      IREFIN=I
      GO TO 3
   5  RETURN
      END

      SUBROUTINE SORT(NST8S)
C
C     THIS ROUTINE ORDERS AN INTEGER ARRAY IN INCREASING SIZE.
C
      COMMON NMBRS(1000)
C
	IF ((NST8S.EQ.0).OR.(NST8S.EQ.1)) RETURN
      DO 10 I = 1,NST8S
      KLEMNT = NST8S-I
      DO 10 J = 1, KLEMNT
C            PUT LARGEST ELEMENT LAST OF EACH SUB-ARRAY.
      IF(NMBRS(J) - NMBRS(J+1)) 10, 10, 5
C
   5  LARGER = NMBRS(J)
      NMBRS(J)=NMBRS(J + 1)
      NMBRS(J+1) = LARGER
C
  10  CONTINUE
C
      RETURN
      END

      DOUBLE PRECISION FUNCTION XTRACT(CHAR)
C
C     XTRACT - SUBROUTINE TO EXTRACT THE INDIVIDUAL CHARACTERS FROM
C     A NAME OF UP TO SIX CHARACTERS IN LENGTH AND PACK THEM INTO
C     A CHARACTER STRING
C
      LOGICAL CHAR(6),NAME(2)
      EQUIVALENCE (XTRACT,NAME(1))
      COMMON /GOOD/ IOP,NEXITS,IESN,LOC,IRTL,JCHR,JCDS,IPL,ISW,IST
     1,IPDN,IPC,LNCT,INBX,BXCN,PASS,HMAIN,HDAT
      COMMON /BAD/ BUF(72),STMNT(72,20),CNDST(1220),IEX(16),IPDL(10)
     1,ALFBT(52),IRT(3,1000),LINE(130),NCOL(15),WS(10)
      EQUIVALENCE (ALFBT(35),N9),(ALFBT(36),N0),(ALFBT(52),EOS)
      DOUBLE PRECISION HMAIN
C
      XTRACT=HMAIN
      DO 7 I=1,6
C
C     FORTRAN NAMES MAY CONSIST OF ALPHABETIC CHARACTERS OR DIGITS
C     ONLY.
C
      IF(CHAR(I).EQ.EOS.OR.CHAR(I).GT.0.AND.(CHAR(I).LT.N0.OR.CHAR(I)
     1.GT.N9))RETURN
      GO TO (1,2,3,4,5,6),I
C
C     THE FIRST CHARACTER OF A FORTRAN NAME MUST NOT BE A DIGIT
C
    1 IF(CHAR(1).GT.0) RETURN
      NAME(1)=CHAR(1)
      GO TO 7
C
C     LEFT JUSTIFIED SEVEN BIT ASCII CHARACTERS ARE EXTRACTED BY
C     MASKING AND SHIFTING
C
    2 NAME(1)=(NAME(1).AND."774000000000).OR.((CHAR(2)/128)
     1.AND."003777777776)
      GO TO 7
    3 NAME(1)=(NAME(1).AND."777760000000).OR.((CHAR(3)/16384)
     1.AND."000017777776)
      GO TO 7
    4 NAME(1)=(NAME(1).AND."777777700000).OR.((CHAR(4)/2097152)
     1.AND."000000077776)
      GO TO 7
    5 NAME(1)=(NAME(1).AND."777777777400).OR.((CHAR(5)/268435456)
     1.AND."000000000376)
      GO TO 7
    6 NAME(2)=CHAR(6)
    7 CONTINUE
      RETURN
      END
C
	SUBROUTINE GETREC(IEND)
C
C	GETREC-GETS A RECORD FROM INPUT FILE
C
	COMMON/GOOD/IOP,NEXITS,IESN,LOC,IRTL,JCHR,JCDS,ENDFLG
	COMMON/DEVICE/DSK1,DSK,DSK0
	COMMON/BAD/BUF(72),STMNT(72,20)
	LOGICAL BUF,IBUF,ITAB,ICR,ILF,IFF
	INTEGER DSK1,DSK,DSK0
	DIMENSION IBUF(80)
	IFF="061004020100
	ICR="065004020100
	ILF="051004020100
	ITAB="045004020100
C
C BLANK OUT INPUT AREA -- BUF
C
172	DO 173 I=1,72
173	BUF(I)=' '
C
C READ A RECORD
C
13	READ (DSK,901,END=1000,ERR=1001) BUF
C
C TEST TO SEE IF RECORD IS BLANK - IF SO, GET NEXT RECORD
C
	DO 171 I=1,72
	IF ((BUF(I).NE.ITAB).AND.(BUF(I).NE.' ')) GO TO 695
171	CONTINUE
	GO TO 172
79	CONTINUE

C
C GET RID OF TABS IN COLS 6-72
C
695	CALL OUT(STMNT(1,JCDS),72)
	DO 20 I=6,72
	IF(BUF(I).EQ.ITAB) BUF(I)='     '
20	CONTINUE

	IF(BUF(1).NE.'C') GO TO 9876
	DO 9678 II=1,72
	IF(BUF(II).EQ.ITAB) BUF(II)=' '
9678	CONTINUE
C
C SEARCH FOR TAB IN COLS 1-5
C
9876	DO 15 I=1,5
	IF(BUF(I).EQ.ITAB) GO TO 28
15	CONTINUE
	RETURN
C
C INPUT READ ERROR
C
1001	TYPE 1002
1002	FORMAT(1X,'INPUT READ ERROR - JOB ABORTED')
	STOP

C
C CLEAR COLS 1-6 OF IBUF
C
28	DO 33 M=1,6
33	IBUF(M)='     '
C
C IF TAB IS FOLLOWED BY A DIGIT THEN RECORD = A CONTINUED CARD
C
	IF((BUF(I+1).GE.'1').AND.(BUF(I+1).LE.'9')) GO TO 96
	II=7
	IF(I.NE.1) GO TO 52

43	DO 16 M=2,72
	IBUF(II)=BUF(M)
16	II=II+1

37	DO 17 M=1,72
17	BUF(M)=IBUF(M)
	RETURN

52	DO 72 K=1,I-1
72	IBUF(K)=BUF(K)
	DO 73 K=I+1,72
	IBUF(II)=BUF(K)
73	II=II+1
	GOTO 37
96	II=6
	IF(I.NE.1) GO TO 52
	GO TO 43

901	FORMAT(72A1,8X)
902	FORMAT(1H1,5X,'END OF JOB')
905	FORMAT(//5X,'END OF JOB')

1000	IF(IOP.EQ.6) GO TO 69
	IF (ENDFLG.NE.0)GOTO 1077
	ENDFLG=1
	RETURN
1077	WRITE(DSK1,1078)
	WRITE(5,1078)
	GOTO 69
1078	FORMAT(1X,'NO END STATEMENT IN FILE,FLOW CHARTING TERMINATED')
	RETURN

69	WRITE(DSK1,902)
	TYPE 905
	END FILE DSK1
	END FILE DSK
	END FILE DSK0
	WRITE(DSK0)IOP
	REWIND(DSK0)
	IEND=-1
	RETURN

	END