Trailing-Edge
-
PDP-10 Archives
-
decuslib10-01
-
43,50046/chartr.f4
There are no other files named chartr.f4 in the archive.
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