SUBROUTINE MAIN COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER I, N INTEGER GETARG, OPEN LOGICAL*1 ARG (40) CALL QUERY (35Husage: ratfor [file] ... >outfile.) CALL INITKW CALL LODSYM(ARG) N = 1 I = 1 23000 IF (.NOT.(GETARG (I, ARG, 40) .NE. -1))GOTO 23002 N = N + 1 IF (.NOT.(ARG (1) .EQ. 45 .AND. ARG (2) .EQ. 0))GOTO 23003 INFILE (1) = 1 GOTO 23004 23003 CONTINUE INFILE (1) = OPEN (ARG, 1) IF (.NOT.(INFILE (1) .EQ. -3))GOTO 23005 CALL CANT (ARG) 23005 CONTINUE 23004 CONTINUE CALL PARSE IF (.NOT.(INFILE (1) .NE. 1))GOTO 23007 CALL CLOSE (INFILE (1)) 23007 CONTINUE 23001 I = I + 1 GOTO 23000 23002 CONTINUE IF (.NOT.(N .EQ. 1))GOTO 23009 INFILE (1) = 1 CALL PARSE 23009 CONTINUE RETURN END SUBROUTINE ADDCHR(C, BUF, BP, MAXSIZ) INTEGER BP, MAXSIZ LOGICAL*1 C, BUF(100) IF (.NOT.(BP .GT. MAXSIZ))GOTO 23011 CALL BADERR(16Hbuffer overflow.) 23011 CONTINUE BUF(BP) = C BP = BP + 1 RETURN END SUBROUTINE ADDSTR(S, BUF, BP, MAXSIZ) LOGICAL*1 S(100), BUF(100) INTEGER BP, MAXSIZ INTEGER I I = 1 23013 IF (.NOT.(S(I) .NE. 0))GOTO 23015 CALL ADDCHR(S(I), BUF, BP, MAXSIZ) 23014 I=I+1 GOTO 23013 23015 CONTINUE RETURN END INTEGER FUNCTION ALLDIG (STR) LOGICAL*1 STR (100) LOGICAL*1 TYPE INTEGER I ALLDIG = 0 IF (.NOT.(STR (1) .EQ. 0))GOTO 23016 RETURN 23016 CONTINUE I = 1 23018 IF (.NOT.(STR (I) .NE. 0))GOTO 23020 IF (.NOT.(.NOT.(48.LE.STR (I).AND.STR (I).LE.57)))GOTO 23021 RETURN 23021 CONTINUE 23019 I = I + 1 GOTO 23018 23020 CONTINUE ALLDIG = 1 RETURN END SUBROUTINE BADERR (MSG) LOGICAL*1 MSG (100) CALL SYNERR (MSG) CALL ENDST(-3) END SUBROUTINE BALPAR LOGICAL*1 T, TOKEN (120) LOGICAL*1 GETTOK, GNBTOK INTEGER NLPAR IF (.NOT.(GNBTOK (TOKEN, 120) .NE. 40))GOTO 23023 CALL SYNERR (19Hmissing left paren.) RETURN 23023 CONTINUE CALL OUTSTR (TOKEN) NLPAR = 1 23025 CONTINUE T = GETTOK (TOKEN, 120) IF (.NOT.(T .EQ. 59 .OR. T .EQ. 123 .OR. T .EQ. 125 .OR. T .EQ. -1 *))GOTO 23028 CALL PBSTR (TOKEN) GOTO 23027 23028 CONTINUE IF (.NOT.(T .EQ. 10))GOTO 23030 TOKEN (1) = 0 GOTO 23031 23030 CONTINUE IF (.NOT.(T .EQ. 40))GOTO 23032 NLPAR = NLPAR + 1 GOTO 23033 23032 CONTINUE IF (.NOT.(T .EQ. 41))GOTO 23034 NLPAR = NLPAR - 1 23034 CONTINUE 23033 CONTINUE 23031 CONTINUE CALL OUTSTR (TOKEN) 23026 IF (.NOT.(NLPAR .LE. 0))GOTO 23025 23027 CONTINUE IF (.NOT.(NLPAR .NE. 0))GOTO 23036 CALL SYNERR (33Hmissing parenthesis in condition.) 23036 CONTINUE RETURN END SUBROUTINE BRKNXT (SP, LEXTYP, LABVAL, TOKEN) INTEGER LABVAL (100), LEXTYP (100), SP, TOKEN INTEGER I, N LOGICAL*1 T INTEGER ALLDIG, CTOI LOGICAL*1 GNBTOK COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM N = 0 T = GNBTOK (SCRTOK, 120) IF (.NOT.(ALLDIG (SCRTOK) .EQ. 1))GOTO 23038 I = 1 N = CTOI (SCRTOK, I) - 1 GOTO 23039 23038 CONTINUE IF (.NOT.(T .NE. 59))GOTO 23040 CALL PBSTR (SCRTOK) 23040 CONTINUE 23039 CONTINUE I = SP 23042 IF (.NOT.(I .GT. 0))GOTO 23044 IF (.NOT.(LEXTYP (I) .EQ. -15 .OR. LEXTYP (I) .EQ. -10 .OR. LEXTYP * (I) .EQ. -16 .OR. LEXTYP (I) .EQ. -17))GOTO 23045 IF (.NOT.(N .GT. 0))GOTO 23047 N = N - 1 GOTO 23043 23047 CONTINUE IF (.NOT.(TOKEN .EQ. -8))GOTO 23049 CALL OUTGO (LABVAL (I) + 1) GOTO 23050 23049 CONTINUE CALL OUTGO (LABVAL (I)) 23050 CONTINUE 23048 CONTINUE XFER = 1 RETURN 23045 CONTINUE 23043 I = I - 1 GOTO 23042 23044 CONTINUE IF (.NOT.(TOKEN .EQ. -8))GOTO 23051 CALL SYNERR (14Hillegal break.) GOTO 23052 23051 CONTINUE CALL SYNERR (13Hillegal next.) 23052 CONTINUE RETURN END SUBROUTINE CASCOD (LAB, TOKEN) INTEGER LAB, TOKEN COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER T, L, LB, UB, I, J, JUNK INTEGER CASLAB, LABGEN LOGICAL*1 GNBTOK IF (.NOT.(SETOP .LE. 0))GOTO 23053 CALL SYNERR (24Hillegal case or default.) RETURN 23053 CONTINUE CALL OUTGO (LAB + 1) XFER = 1 L = LABGEN (1) IF (.NOT.(TOKEN .EQ. -25))GOTO 23055 23057 IF (.NOT.(CASLAB (LB, T) .NE. -1))GOTO 23058 UB = LB IF (.NOT.(T .EQ. 45))GOTO 23059 JUNK = CASLAB (UB, T) 23059 CONTINUE IF (.NOT.(LB .GT. UB))GOTO 23061 CALL SYNERR (28Hillegal range in case label.) UB = LB 23061 CONTINUE IF (.NOT.(SELAST + 3 .GT. 300))GOTO 23063 CALL BADERR (22Hselect table overflow.) 23063 CONTINUE I = SETOP + 3 23065 IF (.NOT.(I .LT. SELAST))GOTO 23067 IF (.NOT.(LB .LE. SESTAK (I)))GOTO 23068 GOTO 23067 23068 CONTINUE IF (.NOT.(LB .LE. SESTAK (I+1)))GOTO 23070 CALL SYNERR (21Hduplicate case label.) 23070 CONTINUE 23069 CONTINUE 23066 I = I + 3 GOTO 23065 23067 CONTINUE IF (.NOT.(I .LT. SELAST .AND. UB .GE. SESTAK (I)))GOTO 23072 CALL SYNERR (21Hduplicate case label.) 23072 CONTINUE J = SELAST 23074 IF (.NOT.(J .GT. I))GOTO 23076 SESTAK (J+2) = SESTAK (J-1) 23075 J = J - 1 GOTO 23074 23076 CONTINUE SESTAK (I) = LB SESTAK (I + 1) = UB SESTAK (I + 2) = L SESTAK (SETOP + 1) = SESTAK (SETOP + 1) + 1 SELAST = SELAST + 3 IF (.NOT.(T .EQ. 58))GOTO 23077 GOTO 23058 23077 CONTINUE IF (.NOT.(T .NE. 44))GOTO 23079 CALL SYNERR (20Hillegal case syntax.) 23079 CONTINUE 23078 CONTINUE GOTO 23057 23058 CONTINUE GOTO 23056 23055 CONTINUE T = GNBTOK (SCRTOK, 120) IF (.NOT.(SESTAK (SETOP + 2) .NE. 0))GOTO 23081 CALL BADERR (38Hmultiple defaults in select statement.) GOTO 23082 23081 CONTINUE SESTAK (SETOP + 2) = L 23082 CONTINUE 23056 CONTINUE IF (.NOT.(T .EQ. -1))GOTO 23083 CALL SYNERR (15Hunexpected EOF.) GOTO 23084 23083 CONTINUE IF (.NOT.(T .NE. 58))GOTO 23085 CALL BADERR (39Hmissing colon in case or default label.) 23085 CONTINUE 23084 CONTINUE XFER = 0 CALL OUTCON (L) RETURN END INTEGER FUNCTION CASLAB (N, T) INTEGER N, T LOGICAL*1 TOK (120) INTEGER I, S LOGICAL*1 GNBTOK INTEGER CTOI T = GNBTOK (TOK, 120) 23087 IF (.NOT.(T .EQ. 10))GOTO 23088 T = GNBTOK (TOK, 120) GOTO 23087 23088 CONTINUE IF (.NOT.(T .EQ. -1))GOTO 23089 CASLAB=(T) RETURN 23089 CONTINUE IF (.NOT.(T .EQ. 45))GOTO 23091 S = -1 GOTO 23092 23091 CONTINUE S = +1 23092 CONTINUE IF (.NOT.(T .EQ. 45 .OR. T .EQ. 43))GOTO 23093 T = GNBTOK (TOK, 120) 23093 CONTINUE IF (.NOT.(T .NE. 2))GOTO 23095 CALL SYNERR (19Hinvalid case label.) N = 0 GOTO 23096 23095 CONTINUE I = 1 N = S * CTOI (TOK, I) 23096 CONTINUE T = GNBTOK (TOK, 120) 23097 IF (.NOT.(T .EQ. 10))GOTO 23098 T = GNBTOK (TOK, 120) GOTO 23097 23098 CONTINUE RETURN END INTEGER FUNCTION CNDGET(TOKEN, TOKSIZ) LOGICAL*1 TOKEN(120) INTEGER TOKSIZ COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER VALUE LOGICAL*1 PTOK(3) INTEGER LOOKUP LOGICAL*1 GTOK IF (.NOT.(CSP .GE. 10))GOTO 23099 CALL BADERR(31HConditionals nested too deeply.) 23099 CONTINUE CSP = CSP + 1 CNDSTK (CSP) = CURCND CALL SKPBLK IF (.NOT.(GTOK(TOKEN, TOKSIZ) .NE. 40))GOTO 23101 CALL BADERR(27Hmissing `(' in conditional.) 23101 CONTINUE CALL SKPBLK IF (.NOT.(GTOK(TOKEN, TOKSIZ) .NE. -9))GOTO 23103 CALL BADERR(26Hinvalid conditional token.) 23103 CONTINUE CALL SKPBLK IF (.NOT.(GTOK(PTOK, 3) .NE. 41))GOTO 23105 CALL BADERR(27Hmissing `)' in conditional.) 23105 CONTINUE IF (.NOT.(LOOKUP(TOKEN, VALUE, DEFTBL) .EQ. 1))GOTO 23107 CNDGET = 1 GOTO 23108 23107 CONTINUE CNDGET = -1 23108 CONTINUE RETURN END LOGICAL*1 FUNCTION CNDLU (TOKEN) LOGICAL*1 TOKEN(120) INTEGER I, J LOGICAL*1 TEMP (9) INTEGER INDEXC, EQUAL LOGICAL*1 LETTS(5) LOGICAL*1 CNDTBL(35) DATA LETTS(1)/101/,LETTS(2)/69/,LETTS(3)/105/,LETTS(4)/73/,LETTS(5 *)/0/ DATA CNDTBL(1)/105/,CNDTBL(2)/102/,CNDTBL(3)/100/,CNDTBL(4)/101/,C *NDTBL(5)/102/,CNDTBL(6)/47/,CNDTBL(7)/32/,CNDTBL(8)/105/,CNDTBL(9) */102/,CNDTBL(10)/110/,CNDTBL(11)/111/,CNDTBL(12)/116/,CNDTBL(13)/1 *00/,CNDTBL(14)/101/,CNDTBL(15)/102/,CNDTBL(16)/47/,CNDTBL(17)/32/, *CNDTBL(18)/101/,CNDTBL(19)/108/,CNDTBL(20)/115/,CNDTBL(21)/101/,CN *DTBL(22)/100/,CNDTBL(23)/101/,CNDTBL(24)/102/,CNDTBL(25)/47/,CNDTB *L(26)/32/,CNDTBL(27)/101/,CNDTBL(28)/110/,CNDTBL(29)/100/,CNDTBL(3 *0)/100/,CNDTBL(31)/101/,CNDTBL(32)/102/,CNDTBL(33)/47/,CNDTBL(34)/ *32/,CNDTBL(35)/0/ DATA CNDTBL(7)/-15/,CNDTBL(17)/-16/,CNDTBL(26)/-17/, CNDTBL(34)/-1 *8/ CNDLU = -19 IF (.NOT.(INDEXC (LETTS, TOKEN (1)) .GT. 0))GOTO 23109 I=1 23111 IF (.NOT.(CNDTBL(I) .NE. 0))GOTO 23113 J=1 23114 IF (.NOT.(CNDTBL(I) .NE. 47))GOTO 23116 TEMP(J) = CNDTBL(I) 23115 I=I+1 J=J+1 GOTO 23114 23116 CONTINUE TEMP(J) = 0 I = I + 1 J = EQUAL(TOKEN, TEMP) IF (.NOT.(J .EQ. 0))GOTO 23117 CALL UPPER(TEMP) J = EQUAL(TOKEN, TEMP) 23117 CONTINUE IF (.NOT.(J .EQ. 1))GOTO 23119 CNDLU = CNDTBL(I) GOTO 23113 23119 CONTINUE 23112 I=I+1 GOTO 23111 23113 CONTINUE 23109 CONTINUE RETURN END LOGICAL*1 FUNCTION DEFTOK (TOKEN, TOKSIZ) LOGICAL*1 TOKEN (120) INTEGER TOKSIZ COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 T, C, DEFN (250) INTEGER AP, ARGSTK (100), CALLST (50), NLB, PLEV (50), IFL INTEGER LUDEF, PUSH, IFPARM LOGICAL*1 GCTOK LOGICAL*1 BALP(3) DATA BALP(1)/40/,BALP(2)/41/,BALP(3)/0/ CP = 0 AP = 1 EP = 1 T = GCTOK (TOKEN, TOKSIZ) 23121 IF (.NOT.(T .NE. -1))GOTO 23123 IF (.NOT.(T .EQ. -9))GOTO 23124 IF (.NOT.(LUDEF (TOKEN, DEFN, DEFTBL) .EQ. 0))GOTO 23126 IF (.NOT.(CP .EQ. 0))GOTO 23128 GOTO 23123 23128 CONTINUE CALL PUTTOK (TOKEN) 23129 CONTINUE GOTO 23127 23126 CONTINUE IF (.NOT.(DEFN (1) .EQ. -4))GOTO 23130 CALL GETDEF (TOKEN, TOKSIZ, DEFN, 250) CALL ENTDEF (TOKEN, DEFN, DEFTBL) GOTO 23131 23130 CONTINUE CP = CP + 1 IF (.NOT.(CP .GT. 50))GOTO 23132 CALL BADERR (20Hcall stack overflow.) 23132 CONTINUE CALLST (CP) = AP AP = PUSH (EP, ARGSTK, AP) CALL PUTTOK (DEFN) CALL PUTCHR (0) AP = PUSH (EP, ARGSTK, AP) CALL PUTTOK (TOKEN) CALL PUTCHR (0) AP = PUSH (EP, ARGSTK, AP) T = GCTOK (TOKEN, TOKSIZ) IF (.NOT.(T .EQ. 32))GOTO 23134 T = GCTOK (TOKEN, TOKSIZ) CALL PBSTR (TOKEN) IF (.NOT.(T .NE. 40))GOTO 23136 CALL PUTBAK (32) 23136 CONTINUE GOTO 23135 23134 CONTINUE CALL PBSTR (TOKEN) 23135 CONTINUE IF (.NOT.(T .NE. 40))GOTO 23138 CALL PBSTR (BALP) GOTO 23139 23138 CONTINUE IF (.NOT.(IFPARM (DEFN) .EQ. 0))GOTO 23140 CALL PBSTR (BALP) 23140 CONTINUE 23139 CONTINUE PLEV (CP) = 0 23131 CONTINUE 23127 CONTINUE GOTO 23125 23124 CONTINUE IF (.NOT.(T .EQ. -10))GOTO 23142 NLB = 1 23144 CONTINUE T = GCTOK (TOKEN, TOKSIZ) IF (.NOT.(T .EQ. -10))GOTO 23147 NLB = NLB + 1 GOTO 23148 23147 CONTINUE IF (.NOT.(T .EQ. -11))GOTO 23149 NLB = NLB - 1 IF (.NOT.(NLB .EQ. 0))GOTO 23151 GOTO 23146 23151 CONTINUE GOTO 23150 23149 CONTINUE IF (.NOT.(T .EQ. -1))GOTO 23153 CALL BADERR (14HEOF in string.) 23153 CONTINUE 23150 CONTINUE 23148 CONTINUE CALL PUTTOK (TOKEN) 23145 GOTO 23144 23146 CONTINUE GOTO 23143 23142 CONTINUE IF (.NOT.(CP .EQ. 0))GOTO 23155 GOTO 23123 23155 CONTINUE IF (.NOT.(T .EQ. 40))GOTO 23157 IF (.NOT.(PLEV (CP) .GT. 0))GOTO 23159 CALL PUTTOK (TOKEN) 23159 CONTINUE PLEV (CP) = PLEV (CP) + 1 GOTO 23158 23157 CONTINUE IF (.NOT.(T .EQ. 41))GOTO 23161 PLEV (CP) = PLEV (CP) - 1 IF (.NOT.(PLEV (CP) .GT. 0))GOTO 23163 CALL PUTTOK (TOKEN) GOTO 23164 23163 CONTINUE CALL PUTCHR (0) CALL EVALR (ARGSTK, CALLST (CP), AP - 1) AP = CALLST (CP) EP = ARGSTK (AP) CP = CP - 1 23164 CONTINUE GOTO 23162 23161 CONTINUE IF (.NOT.(T .EQ. 44 .AND. PLEV (CP) .EQ. 1))GOTO 23165 CALL PUTCHR (0) AP = PUSH (EP, ARGSTK, AP) GOTO 23166 23165 CONTINUE CALL PUTTOK (TOKEN) 23166 CONTINUE 23162 CONTINUE 23158 CONTINUE 23156 CONTINUE 23143 CONTINUE 23125 CONTINUE 23122 T = GCTOK (TOKEN, TOKSIZ) GOTO 23121 23123 CONTINUE DEFTOK = T IF (.NOT.(T .EQ. -9))GOTO 23167 CALL FOLD (TOKEN) 23167 CONTINUE RETURN END SUBROUTINE DOARTH (ARGSTK, I, J) INTEGER ARGSTK (100), I, J COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER K, L, ANS, FIRST, SECOND LOGICAL*1 OP INTEGER CTOI K = ARGSTK (I + 2) FIRST = CTOI(EVALST, K) L = ARGSTK (I + 4) SECOND = CTOI(EVALST, L) OP = EVALST (ARGSTK (I + 3)) IF (.NOT.(OP .EQ. 43))GOTO 23169 CALL PBNUM (FIRST + SECOND) GOTO 23170 23169 CONTINUE IF (.NOT.(OP .EQ. 45))GOTO 23171 CALL PBNUM (FIRST - SECOND) GOTO 23172 23171 CONTINUE IF (.NOT.(OP .EQ. 42 ))GOTO 23173 IF (.NOT.(EVALST(ARGSTK(I+3) + 1) .EQ. 42))GOTO 23175 ANS = 1 23177 IF (.NOT.(SECOND .GT. 0))GOTO 23179 ANS = ANS * FIRST 23178 SECOND = SECOND - 1 GOTO 23177 23179 CONTINUE CALL PBNUM(ANS) GOTO 23176 23175 CONTINUE CALL PBNUM (FIRST * SECOND) 23176 CONTINUE GOTO 23174 23173 CONTINUE IF (.NOT.(OP .EQ. 47 ))GOTO 23180 CALL PBNUM (FIRST / SECOND) GOTO 23181 23180 CONTINUE CALL SYNERR (12Harith error.) 23181 CONTINUE 23174 CONTINUE 23172 CONTINUE 23170 CONTINUE RETURN END SUBROUTINE DOCODE (LAB) INTEGER LAB INTEGER LABGEN COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 GNBTOK LOGICAL*1 SDO(3) DATA SDO(1)/100/,SDO(2)/111/,SDO(3)/0/ XFER = 0 CALL OUTTAB CALL OUTSTR (SDO) CALL OUTCH (32) LAB = LABGEN (2) IF (.NOT.(GNBTOK (SCRTOK, 120) .EQ. 2))GOTO 23182 CALL OUTSTR (SCRTOK) GOTO 23183 23182 CONTINUE CALL PBSTR (SCRTOK) CALL OUTNUM (LAB) 23183 CONTINUE CALL OUTCH (32) CALL EATUP CALL OUTDON RETURN END SUBROUTINE DOIF (ARGSTK, I, J) INTEGER ARGSTK (100), I, J COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER A2, A3, A4, A5 INTEGER EQUAL IF (.NOT.(J - I .LT. 5))GOTO 23184 RETURN 23184 CONTINUE A2 = ARGSTK (I + 2) A3 = ARGSTK (I + 3) A4 = ARGSTK (I + 4) A5 = ARGSTK (I + 5) IF (.NOT.(EQUAL (EVALST (A2), EVALST (A3)) .EQ. 1))GOTO 23186 CALL PBSTR (EVALST (A4)) GOTO 23187 23186 CONTINUE CALL PBSTR (EVALST (A5)) 23187 CONTINUE RETURN END SUBROUTINE DOINCR (ARGSTK, I, J) INTEGER ARGSTK (100), I, J COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER K INTEGER CTOI K = ARGSTK (I + 2) CALL PBNUM (CTOI (EVALST, K) + 1) RETURN END SUBROUTINE DOMAC (ARGSTK, I, J) INTEGER ARGSTK (100), I, J COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER A2, A3 IF (.NOT.(J - I .GT. 2))GOTO 23188 A2 = ARGSTK (I + 2) A3 = ARGSTK (I + 3) CALL ENTDEF (EVALST (A2), EVALST (A3), DEFTBL) 23188 CONTINUE RETURN END SUBROUTINE DOSTAT (LAB) INTEGER LAB CALL OUTCON (LAB) CALL OUTCON (LAB + 1) RETURN END SUBROUTINE DOSUB (ARGSTK, I, J) INTEGER ARGSTK (100), I, J COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER AP, FC, K, NC INTEGER CTOI, LENGTH IF (.NOT.(J - I .LT. 3))GOTO 23190 RETURN 23190 CONTINUE IF (.NOT.(J - I .LT. 4))GOTO 23192 NC = 120 GOTO 23193 23192 CONTINUE K = ARGSTK (I + 4) NC = CTOI (EVALST, K) 23193 CONTINUE K = ARGSTK (I + 3) AP = ARGSTK (I + 2) FC = AP + CTOI (EVALST, K) - 1 IF (.NOT.(FC .GE. AP .AND. FC .LT. AP + LENGTH (EVALST (AP))))GOTO * 23194 K = FC + MIN0(NC, LENGTH (EVALST (FC))) - 1 23196 IF (.NOT.(K .GE. FC))GOTO 23198 CALL PUTBAK (EVALST (K)) 23197 K = K - 1 GOTO 23196 23198 CONTINUE 23194 CONTINUE RETURN END LOGICAL*1 FUNCTION DOTHER(TOKEN) LOGICAL*1 TOKEN(120), T LOGICAL*1 GETTOK CALL OUTTAB 23199 CONTINUE T = GETTOK(TOKEN, 120) IF (.NOT.(T .EQ. 59 .OR. T .EQ. 125))GOTO 23202 GOTO 23201 23202 CONTINUE IF (.NOT.(T .EQ. -1))GOTO 23204 CALL SYNERR(15Hunexpected EOF.) CALL PBSTR(TOKEN) GOTO 23201 23204 CONTINUE IF (.NOT.(T .NE. 10))GOTO 23206 CALL OUTSTR(TOKEN) 23206 CONTINUE 23200 GOTO 23199 23201 CONTINUE CALL OUTDON DOTHER=(T) RETURN END SUBROUTINE EATUP LOGICAL*1 PTOKEN (120), T, TOKEN (120) INTEGER NLPAR LOGICAL*1 GETTOK NLPAR = 0 23208 CONTINUE T = GETTOK (TOKEN, 120) IF (.NOT.(T .EQ. 59 .OR. T .EQ. 10))GOTO 23211 GOTO 23210 23211 CONTINUE IF (.NOT.(T .EQ. 125 .OR. T .EQ. 123))GOTO 23213 CALL PBSTR (TOKEN) GOTO 23210 23213 CONTINUE IF (.NOT.(T .EQ. -1))GOTO 23215 CALL SYNERR (15Hunexpected EOF.) CALL PBSTR (TOKEN) GOTO 23210 23215 CONTINUE IF (.NOT.(T .EQ. 44 .OR. T .EQ. 43 .OR. T .EQ. 45 .OR. T .EQ. 42 . *OR. T .EQ. 40 .OR. T .EQ. 38 .OR. T .EQ. 124 .OR. T .EQ. 33 .OR. T * .EQ. 33 .OR. T .EQ. 126 .OR. T .EQ. 94 .OR. T .EQ. 61))GOTO 23217 23219 IF (.NOT.(GETTOK (PTOKEN, 120) .EQ. 10))GOTO 23220 GOTO 23219 23220 CONTINUE CALL PBSTR (PTOKEN) 23217 CONTINUE IF (.NOT.(T .EQ. 40))GOTO 23221 NLPAR = NLPAR + 1 GOTO 23222 23221 CONTINUE IF (.NOT.(T .EQ. 41))GOTO 23223 NLPAR = NLPAR - 1 23223 CONTINUE 23222 CONTINUE CALL OUTSTR (TOKEN) 23209 IF (.NOT.(NLPAR .LT. 0))GOTO 23208 23210 CONTINUE IF (.NOT.(NLPAR .NE. 0))GOTO 23225 CALL SYNERR (23Hunbalanced parentheses.) 23225 CONTINUE RETURN END INTEGER FUNCTION ELENTH(BUF) LOGICAL*1 BUF(100), C INTEGER I, N LOGICAL*1 ESC N = 0 I=1 23227 IF (.NOT.(BUF(I) .NE. 0))GOTO 23229 C = ESC(BUF, I) N = N + 1 23228 I=I+1 GOTO 23227 23229 CONTINUE ELENTH = N RETURN END SUBROUTINE ELSEIF (LAB) INTEGER LAB CALL OUTGO (LAB+1) CALL OUTCON (LAB) RETURN END SUBROUTINE ENTDKW LOGICAL*1 DEFT (2), INCT (2), SUBT (2), IFT (2), ART (2), MACT (2) LOGICAL*1 DEFNAM(7) LOGICAL*1 MACNAM(8) LOGICAL*1 INCNAM(5) LOGICAL*1 SUBNAM(7) LOGICAL*1 IFNAM(7) LOGICAL*1 ARNAM(6) DATA DEFNAM(1)/100/,DEFNAM(2)/101/,DEFNAM(3)/102/,DEFNAM(4)/105/,D *EFNAM(5)/110/,DEFNAM(6)/101/,DEFNAM(7)/0/ DATA MACNAM(1)/109/,MACNAM(2)/100/,MACNAM(3)/101/,MACNAM(4)/102/,M *ACNAM(5)/105/,MACNAM(6)/110/,MACNAM(7)/101/,MACNAM(8)/0/ DATA INCNAM(1)/105/,INCNAM(2)/110/,INCNAM(3)/99/,INCNAM(4)/114/,IN *CNAM(5)/0/ DATA SUBNAM(1)/115/,SUBNAM(2)/117/,SUBNAM(3)/98/,SUBNAM(4)/115/,SU *BNAM(5)/116/,SUBNAM(6)/114/,SUBNAM(7)/0/ DATA IFNAM(1)/105/,IFNAM(2)/102/,IFNAM(3)/101/,IFNAM(4)/108/,IFNAM *(5)/115/,IFNAM(6)/101/,IFNAM(7)/0/ DATA ARNAM(1)/97/,ARNAM(2)/114/,ARNAM(3)/105/,ARNAM(4)/116/,ARNAM( *5)/104/,ARNAM(6)/0/ DATA DEFT (1), DEFT (2) /-4, 0/ DATA MACT (1), MACT (2) /-10, 0/ DATA INCT (1), INCT (2) /-12, 0/ DATA SUBT (1), SUBT (2) /-13, 0/ DATA IFT (1), IFT (2) /-11, 0/ DATA ART (1), ART (2) /-14, 0/ CALL ULSTAL (DEFNAM, DEFT) CALL ULSTAL (MACNAM, MACT) CALL ULSTAL (INCNAM, INCT) CALL ULSTAL (SUBNAM, SUBT) CALL ULSTAL (IFNAM, IFT) CALL ULSTAL (ARNAM, ART) RETURN END SUBROUTINE ENTRKW COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER JUNK INTEGER ENTER LOGICAL*1 SIF(3) LOGICAL*1 SELSE(5) LOGICAL*1 SWHILE(6) LOGICAL*1 SDO(3) LOGICAL*1 SBREAK(6) LOGICAL*1 SNEXT(5) LOGICAL*1 SFOR(4) LOGICAL*1 SREPT(7) LOGICAL*1 SUNTIL(6) LOGICAL*1 SRET(7) LOGICAL*1 SSTR(7) LOGICAL*1 SSELCT(7) LOGICAL*1 SCASE(5) LOGICAL*1 SDEFLT(8) DATA SIF(1)/105/,SIF(2)/102/,SIF(3)/0/ DATA SELSE(1)/101/,SELSE(2)/108/,SELSE(3)/115/,SELSE(4)/101/,SELSE *(5)/0/ DATA SWHILE(1)/119/,SWHILE(2)/104/,SWHILE(3)/105/,SWHILE(4)/108/,S *WHILE(5)/101/,SWHILE(6)/0/ DATA SDO(1)/100/,SDO(2)/111/,SDO(3)/0/ DATA SBREAK(1)/98/,SBREAK(2)/114/,SBREAK(3)/101/,SBREAK(4)/97/,SBR *EAK(5)/107/,SBREAK(6)/0/ DATA SNEXT(1)/110/,SNEXT(2)/101/,SNEXT(3)/120/,SNEXT(4)/116/,SNEXT *(5)/0/ DATA SFOR(1)/102/,SFOR(2)/111/,SFOR(3)/114/,SFOR(4)/0/ DATA SREPT(1)/114/,SREPT(2)/101/,SREPT(3)/112/,SREPT(4)/101/,SREPT *(5)/97/,SREPT(6)/116/,SREPT(7)/0/ DATA SUNTIL(1)/117/,SUNTIL(2)/110/,SUNTIL(3)/116/,SUNTIL(4)/105/,S *UNTIL(5)/108/,SUNTIL(6)/0/ DATA SRET(1)/114/,SRET(2)/101/,SRET(3)/116/,SRET(4)/117/,SRET(5)/1 *14/,SRET(6)/110/,SRET(7)/0/ DATA SSTR(1)/115/,SSTR(2)/116/,SSTR(3)/114/,SSTR(4)/105/,SSTR(5)/1 *10/,SSTR(6)/103/,SSTR(7)/0/ DATA SSELCT(1)/115/,SSELCT(2)/101/,SSELCT(3)/108/,SSELCT(4)/101/,S *SELCT(5)/99/,SSELCT(6)/116/,SSELCT(7)/0/ DATA SCASE(1)/99/,SCASE(2)/97/,SCASE(3)/115/,SCASE(4)/101/,SCASE(5 *)/0/ DATA SDEFLT(1)/100/,SDEFLT(2)/101/,SDEFLT(3)/102/,SDEFLT(4)/97/,SD *EFLT(5)/117/,SDEFLT(6)/108/,SDEFLT(7)/116/,SDEFLT(8)/0/ JUNK = ENTER (SIF, -19, RKWTBL) JUNK = ENTER (SELSE, -11, RKWTBL) JUNK = ENTER (SWHILE, -15, RKWTBL) JUNK = ENTER (SDO, -10, RKWTBL) JUNK = ENTER (SBREAK, -8, RKWTBL) JUNK = ENTER (SNEXT, -13, RKWTBL) JUNK = ENTER (SFOR, -16, RKWTBL) JUNK = ENTER (SREPT, -17, RKWTBL) JUNK = ENTER (SUNTIL, -18, RKWTBL) JUNK = ENTER (SRET, -20, RKWTBL) JUNK = ENTER (SSTR, -23, RKWTBL) JUNK = ENTER (SSELCT, -24, RKWTBL) JUNK = ENTER (SCASE, -25, RKWTBL) JUNK = ENTER (SDEFLT, -26, RKWTBL) RETURN END SUBROUTINE EVALR (ARGSTK, I, J) INTEGER ARGSTK (100), I, J COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER ARGNO, K, M, N, T, TD INTEGER INDEXC, LENGTH LOGICAL*1 DIGITS(11) DATA DIGITS(1)/48/,DIGITS(2)/49/,DIGITS(3)/50/,DIGITS(4)/51/,DIGIT *S(5)/52/,DIGITS(6)/53/,DIGITS(7)/54/,DIGITS(8)/55/,DIGITS(9)/56/,D *IGITS(10)/57/,DIGITS(11)/0/ T = ARGSTK (I) TD = EVALST (T) IF (.NOT.(TD .EQ. -10))GOTO 23230 CALL DOMAC (ARGSTK, I, J) GOTO 23231 23230 CONTINUE IF (.NOT.(TD .EQ. -12))GOTO 23232 CALL DOINCR (ARGSTK, I, J) GOTO 23233 23232 CONTINUE IF (.NOT.(TD .EQ. -13))GOTO 23234 CALL DOSUB (ARGSTK, I, J) GOTO 23235 23234 CONTINUE IF (.NOT.(TD .EQ. -11))GOTO 23236 CALL DOIF (ARGSTK, I, J) GOTO 23237 23236 CONTINUE IF (.NOT.(TD .EQ. -14))GOTO 23238 CALL DOARTH (ARGSTK, I, J) GOTO 23239 23238 CONTINUE K = T + LENGTH (EVALST (T)) - 1 23240 IF (.NOT.(K .GT. T))GOTO 23242 IF (.NOT.(EVALST (K - 1) .NE. 36))GOTO 23243 CALL PUTBAK (EVALST (K)) GOTO 23244 23243 CONTINUE ARGNO = INDEXC (DIGITS, EVALST (K)) - 1 IF (.NOT.(ARGNO .GE. 0))GOTO 23245 IF (.NOT.(ARGNO .LT. J - I))GOTO 23247 N = I + ARGNO + 1 M = ARGSTK (N) CALL PBSTR (EVALST (M)) 23247 CONTINUE K = K - 1 GOTO 23246 23245 CONTINUE CALL PUTBAK (EVALST (K)) 23246 CONTINUE 23244 CONTINUE 23241 K = K - 1 GOTO 23240 23242 CONTINUE IF (.NOT.(K .EQ. T))GOTO 23249 CALL PUTBAK (EVALST (K)) 23249 CONTINUE 23239 CONTINUE 23237 CONTINUE 23235 CONTINUE 23233 CONTINUE 23231 CONTINUE RETURN END SUBROUTINE FCLAUS LOGICAL*1 TOKEN(120), T INTEGER BRACE LOGICAL*1 GNBTOK, DOTHER IF (.NOT.(GNBTOK(TOKEN, 120) .EQ. 123))GOTO 23251 BRACE = 1 GOTO 23252 23251 CONTINUE CALL PBSTR(TOKEN) BRACE = 0 23252 CONTINUE T = DOTHER(TOKEN) IF (.NOT.(BRACE .EQ. 1))GOTO 23253 23255 IF (.NOT.(T .NE. 125 .AND. T .NE. -1))GOTO 23256 T = GNBTOK(TOKEN, 120) CALL PBSTR(TOKEN) T = DOTHER(TOKEN) GOTO 23255 23256 CONTINUE IF (.NOT.(GNBTOK(TOKEN, 120) .NE. 59))GOTO 23257 CALL SYNERR(19Hinvalid for clause.) 23257 CONTINUE 23253 CONTINUE RETURN END SUBROUTINE FINIT COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM OUTP = 0 LEVEL = 1 LINECT (1) = 1 SBP = 1 FNAMP = 2 FNAMES (1) = 0 BP = 0 FORDEP = 0 FCNAME (1) = 0 SETOP = 0 SELAST = 1 CSP = 0 CURCND = 1 RETURN END SUBROUTINE FORCOD (LAB) INTEGER LAB COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 T INTEGER I, J, NLPAR, LEN LOGICAL*1 GETTOK, GNBTOK INTEGER LENGTH, LABGEN LOGICAL*1 IFNOT(10) LOGICAL*1 SEMI(2) DATA IFNOT(1)/105/,IFNOT(2)/102/,IFNOT(3)/32/,IFNOT(4)/40/,IFNOT(5 *)/46/,IFNOT(6)/110/,IFNOT(7)/111/,IFNOT(8)/116/,IFNOT(9)/46/,IFNOT *(10)/0/ DATA SEMI(1)/59/,SEMI(2)/0/ LAB = LABGEN (3) CALL OUTCON (0) IF (.NOT.(GNBTOK (SCRTOK, 120) .NE. 40))GOTO 23259 CALL SYNERR (19Hmissing left paren.) RETURN 23259 CONTINUE IF (.NOT.(GNBTOK (SCRTOK, 120) .NE. 59))GOTO 23261 CALL PBSTR (SCRTOK) CALL FCLAUS 23261 CONTINUE IF (.NOT.(GNBTOK (SCRTOK, 120) .EQ. 59))GOTO 23263 CALL OUTCON (LAB) GOTO 23264 23263 CONTINUE CALL PBSTR (SCRTOK) CALL OUTNUM (LAB) CALL OUTTAB CALL OUTSTR (IFNOT) CALL OUTCH (40) NLPAR = 0 23265 IF (.NOT.(NLPAR .GE. 0))GOTO 23266 T = GETTOK (SCRTOK, 120) IF (.NOT.(T .EQ. 59))GOTO 23267 GOTO 23266 23267 CONTINUE IF (.NOT.(T .EQ. 40))GOTO 23269 NLPAR = NLPAR + 1 GOTO 23270 23269 CONTINUE IF (.NOT.(T .EQ. 41))GOTO 23271 NLPAR = NLPAR - 1 23271 CONTINUE 23270 CONTINUE IF (.NOT.(T .EQ. -1))GOTO 23273 CALL PBSTR (SCRTOK) RETURN 23273 CONTINUE IF (.NOT.(T .NE. 10))GOTO 23275 CALL OUTSTR (SCRTOK) 23275 CONTINUE GOTO 23265 23266 CONTINUE CALL OUTCH (41) CALL OUTCH (41) CALL OUTGO (LAB+2) IF (.NOT.(NLPAR .LT. 0))GOTO 23277 CALL SYNERR (19Hinvalid for clause.) 23277 CONTINUE 23264 CONTINUE FORDEP = FORDEP + 1 LEN = 0 J = 1 I = 1 23279 IF (.NOT.(I .LT. FORDEP))GOTO 23281 J = J + LENGTH (FORSTK (J)) + 1 23280 I = I + 1 GOTO 23279 23281 CONTINUE FORSTK (J) = 0 NLPAR = 0 T = GNBTOK (SCRTOK, 120) CALL PBSTR (SCRTOK) 23282 IF (.NOT.(NLPAR .GE. 0))GOTO 23283 T = GETTOK (SCRTOK, 120) IF (.NOT.(T .EQ. 40))GOTO 23284 NLPAR = NLPAR + 1 GOTO 23285 23284 CONTINUE IF (.NOT.(T .EQ. 41))GOTO 23286 NLPAR = NLPAR - 1 23286 CONTINUE 23285 CONTINUE IF (.NOT.(T .EQ. -1))GOTO 23288 CALL PBSTR (SCRTOK) GOTO 23283 23288 CONTINUE IF (.NOT.(NLPAR .GE. 0 .AND. T .NE. 10))GOTO 23290 IF (.NOT.(J + LENGTH (SCRTOK) .GE. 300))GOTO 23292 CALL BADERR (20Hfor clause too long.) 23292 CONTINUE CALL SCOPY (SCRTOK, 1, FORSTK, J) J = J + LENGTH (SCRTOK) LEN = LEN + LENGTH (SCRTOK) GOTO 23291 23290 CONTINUE IF (.NOT.(NLPAR .EQ. -1 .AND. LEN .GT. 0))GOTO 23294 IF (.NOT.(J .LT. 300))GOTO 23296 CALL SCOPY(SEMI, 1, FORSTK, J) GOTO 23297 23296 CONTINUE CALL BADERR(20Hfor clause too long.) 23297 CONTINUE 23294 CONTINUE 23291 CONTINUE GOTO 23282 23283 CONTINUE LAB = LAB + 1 RETURN END SUBROUTINE FORS (LAB) INTEGER LAB COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER I, J INTEGER LENGTH XFER = 0 CALL OUTNUM (LAB) J = 1 I = 1 23298 IF (.NOT.(I .LT. FORDEP))GOTO 23300 J = J + LENGTH (FORSTK (J)) + 1 23299 I = I + 1 GOTO 23298 23300 CONTINUE IF (.NOT.(LENGTH (FORSTK (J)) .GT. 0))GOTO 23301 CALL PBSTR (FORSTK (J)) CALL FCLAUS 23301 CONTINUE CALL OUTGO (LAB - 1) CALL OUTCON (LAB + 1) FORDEP = FORDEP - 1 RETURN END LOGICAL*1 FUNCTION GCTOK(TOKEN, TOKSIZ) LOGICAL*1 TOKEN(120) INTEGER TOKSIZ COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 C INTEGER NEWCND LOGICAL*1 GTOK, CNDLU INTEGER CNDGET GCTOK=GTOK(TOKEN,TOKSIZ) 23303 IF (.NOT.(GCTOK .NE. -1))GOTO 23305 C = CNDLU (TOKEN) IF (.NOT.(C .EQ. -19))GOTO 23306 IF (.NOT.(CURCND .EQ. 1))GOTO 23308 GOTO 23305 23308 CONTINUE GOTO 23307 23306 CONTINUE IF (.NOT.(C .EQ. -18))GOTO 23310 IF (.NOT.(CSP .LE. 0))GOTO 23312 CALL BADERR(27HIllegal enddef encountered.) 23312 CONTINUE CURCND = CNDSTK(CSP) CSP = CSP - 1 GOTO 23311 23310 CONTINUE IF (.NOT.(C .EQ. -15))GOTO 23314 NEWCND = CNDGET (TOKEN, TOKSIZ) GOTO 23315 23314 CONTINUE IF (.NOT.(C .EQ. -16))GOTO 23316 NEWCND = - CNDGET (TOKEN, TOKSIZ) GOTO 23317 23316 CONTINUE NEWCND = - CURCND 23317 CONTINUE 23315 CONTINUE CURCND = MIN0(NEWCND, CNDSTK (CSP) ) 23311 CONTINUE 23307 CONTINUE 23304 GCTOK=GTOK(TOKEN,TOKSIZ) GOTO 23303 23305 CONTINUE RETURN END SUBROUTINE GETDEF (TOKEN, TOKSIZ, DEFN, DEFSIZ) LOGICAL*1 TOKEN (120), DEFN (250) INTEGER TOKSIZ, DEFSIZ COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 C, T, PTOKEN (120) INTEGER I, NLPAR LOGICAL*1 GCTOK, NGETCH CALL SKPBLK C = GCTOK (PTOKEN, 120) IF (.NOT.(C .EQ. 40))GOTO 23318 T = 40 GOTO 23319 23318 CONTINUE T = 32 CALL PBSTR (PTOKEN) 23319 CONTINUE CALL SKPBLK IF (.NOT.(GCTOK (TOKEN, TOKSIZ) .NE. -9))GOTO 23320 CALL BADERR (22Hnon-alphanumeric name.) 23320 CONTINUE CALL SKPBLK C = GCTOK (PTOKEN, 120) IF (.NOT.(T .EQ. 32))GOTO 23322 CALL PBSTR (PTOKEN) I = 1 23324 CONTINUE C = NGETCH (C) IF (.NOT.(I .GT. DEFSIZ))GOTO 23327 CALL BADERR (20Hdefinition too long.) 23327 CONTINUE DEFN (I) = C I = I + 1 23325 IF (.NOT.(C .EQ. 35 .OR. C .EQ. 10 .OR. C .EQ. -1))GOTO 23324 23326 CONTINUE IF (.NOT.(C .EQ. 35))GOTO 23329 CALL PUTBAK (C) 23329 CONTINUE GOTO 23323 23322 CONTINUE IF (.NOT.(T .EQ. 40))GOTO 23331 IF (.NOT.(C .NE. 44))GOTO 23333 CALL BADERR (24Hmissing comma in define.) 23333 CONTINUE NLPAR = 0 I = 1 23335 IF (.NOT.(NLPAR .GE. 0))GOTO 23337 IF (.NOT.(I .GT. DEFSIZ))GOTO 23338 CALL BADERR (20Hdefinition too long.) GOTO 23339 23338 CONTINUE IF (.NOT.(NGETCH (DEFN (I)) .EQ. -1))GOTO 23340 CALL BADERR (20Hmissing right paren.) GOTO 23341 23340 CONTINUE IF (.NOT.(DEFN (I) .EQ. 40))GOTO 23342 NLPAR = NLPAR + 1 GOTO 23343 23342 CONTINUE IF (.NOT.(DEFN (I) .EQ. 41))GOTO 23344 NLPAR = NLPAR - 1 23344 CONTINUE 23343 CONTINUE 23341 CONTINUE 23339 CONTINUE 23336 I = I + 1 GOTO 23335 23337 CONTINUE GOTO 23332 23331 CONTINUE CALL BADERR (19Hgetdef is confused.) 23332 CONTINUE 23323 CONTINUE DEFN (I - 1) = 0 RETURN END LOGICAL*1 FUNCTION GETTOK (TOKEN, TOKSIZ) LOGICAL*1 TOKEN (120) INTEGER TOKSIZ COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER I, LEN LOGICAL*1 NAME (40), T INTEGER EQUAL, OPEN, LENGTH LOGICAL*1 DEFTOK LOGICAL*1 FNCN(9) LOGICAL*1 INCL(8) DATA FNCN(1)/102/,FNCN(2)/117/,FNCN(3)/110/,FNCN(4)/99/,FNCN(5)/11 *6/,FNCN(6)/105/,FNCN(7)/111/,FNCN(8)/110/,FNCN(9)/0/ DATA INCL(1)/105/,INCL(2)/110/,INCL(3)/99/,INCL(4)/108/,INCL(5)/11 *7/,INCL(6)/100/,INCL(7)/101/,INCL(8)/0/ 23346 IF (.NOT.(LEVEL .GT. 0))GOTO 23348 GETTOK = DEFTOK (TOKEN, TOKSIZ) 23349 IF (.NOT.(GETTOK .NE. -1))GOTO 23351 IF (.NOT.(EQUAL (TOKEN, FNCN) .EQ. 1))GOTO 23352 CALL SKPBLK T = DEFTOK (FCNAME, 40) CALL PBSTR (FCNAME) IF (.NOT.(T .NE. -9))GOTO 23354 CALL SYNERR (22Hmissing function name.) 23354 CONTINUE CALL PUTBAK (32) RETURN 23352 CONTINUE IF (.NOT.(EQUAL (TOKEN, INCL) .EQ. 0))GOTO 23356 RETURN 23356 CONTINUE 23353 CONTINUE CALL SKPBLK T = DEFTOK (NAME, 40) IF (.NOT.(T .EQ. 39 .OR. T .EQ. 34))GOTO 23358 LEN = LENGTH (NAME) - 1 I = 1 23360 IF (.NOT.(I .LT. LEN))GOTO 23362 NAME (I) = NAME (I + 1) 23361 I = I + 1 GOTO 23360 23362 CONTINUE NAME (I) = 0 23358 CONTINUE I = LENGTH (NAME) + 1 IF (.NOT.(LEVEL .GE. 4))GOTO 23363 CALL SYNERR (27Hincludes nested too deeply.) GOTO 23364 23363 CONTINUE INFILE (LEVEL + 1) = OPEN (NAME, 1) LINECT (LEVEL + 1) = 1 IF (.NOT.(INFILE (LEVEL + 1) .EQ. -3))GOTO 23365 CALL SYNERR (19Hcan't open include.) GOTO 23366 23365 CONTINUE LEVEL = LEVEL + 1 IF (.NOT.(FNAMP + I .LE. 160))GOTO 23367 CALL SCOPY (NAME, 1, FNAMES, FNAMP) FNAMP = FNAMP + I 23367 CONTINUE 23366 CONTINUE 23364 CONTINUE 23350 GETTOK = DEFTOK (TOKEN, TOKSIZ) GOTO 23349 23351 CONTINUE IF (.NOT.(LEVEL .GT. 1))GOTO 23369 CALL CLOSE (INFILE (LEVEL)) FNAMP = FNAMP - 1 23371 IF (.NOT.(FNAMP .GT. 1))GOTO 23373 IF (.NOT.(FNAMES (FNAMP - 1) .EQ. 0))GOTO 23374 GOTO 23373 23374 CONTINUE 23372 FNAMP = FNAMP - 1 GOTO 23371 23373 CONTINUE 23369 CONTINUE 23347 LEVEL = LEVEL - 1 GOTO 23346 23348 CONTINUE TOKEN (1) = -1 TOKEN (2) = 0 GETTOK = -1 RETURN END LOGICAL*1 FUNCTION GNBTOK (TOKEN, TOKSIZ) LOGICAL*1 TOKEN (120) INTEGER TOKSIZ COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 GETTOK 23376 CONTINUE CALL SKPBLK GNBTOK = GETTOK (TOKEN, TOKSIZ) 23377 IF (.NOT.(GNBTOK .NE. 32))GOTO 23376 23378 CONTINUE RETURN END LOGICAL*1 FUNCTION GTOK (LEXSTR, TOKSIZ) LOGICAL*1 LEXSTR (120) INTEGER TOKSIZ COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 C INTEGER I, B, N, D LOGICAL*1 NGETCH, TYPE, CLOWER, ESC INTEGER ITOC, INDEXC LOGICAL*1 DIGITS(37) DATA DIGITS(1)/48/,DIGITS(2)/49/,DIGITS(3)/50/,DIGITS(4)/51/,DIGIT *S(5)/52/,DIGITS(6)/53/,DIGITS(7)/54/,DIGITS(8)/55/,DIGITS(9)/56/,D *IGITS(10)/57/,DIGITS(11)/97/,DIGITS(12)/98/,DIGITS(13)/99/,DIGITS( *14)/100/,DIGITS(15)/101/,DIGITS(16)/102/,DIGITS(17)/103/,DIGITS(18 *)/104/,DIGITS(19)/105/,DIGITS(20)/106/,DIGITS(21)/107/,DIGITS(22)/ *108/,DIGITS(23)/109/,DIGITS(24)/110/,DIGITS(25)/111/,DIGITS(26)/11 *2/,DIGITS(27)/113/,DIGITS(28)/114/,DIGITS(29)/115/,DIGITS(30)/116/ *,DIGITS(31)/117/,DIGITS(32)/118/,DIGITS(33)/119/,DIGITS(34)/120/,D *IGITS(35)/121/,DIGITS(36)/122/,DIGITS(37)/0/ 23379 CONTINUE C = NGETCH (LEXSTR (1)) IF (.NOT.(C .EQ. 95))GOTO 23382 IF (.NOT.(NGETCH(C) .NE. 10))GOTO 23384 CALL PUTBAK(C) C = 95 GOTO 23381 23384 CONTINUE 23382 CONTINUE 23380 IF (.NOT.(LEXSTR(1) .NE. 95))GOTO 23379 23381 CONTINUE IF (.NOT.(C .EQ. 32 .OR. C .EQ. 9))GOTO 23386 LEXSTR (1) = 32 23388 IF (.NOT.(C .EQ. 32 .OR. C .EQ. 9))GOTO 23389 C = NGETCH (C) GOTO 23388 23389 CONTINUE IF (.NOT.(C .EQ. 35))GOTO 23390 23392 IF (.NOT.(NGETCH (C) .NE. 10))GOTO 23393 GOTO 23392 23393 CONTINUE 23390 CONTINUE IF (.NOT.(C .NE. 10))GOTO 23394 CALL PUTBAK (C) GOTO 23395 23394 CONTINUE LEXSTR (1) = 10 23395 CONTINUE LEXSTR (2) = 0 GTOK = LEXSTR (1) RETURN 23386 CONTINUE I = 1 IF (.NOT.(((65.LE.C.AND.C.LE.90).OR.(97.LE.C.AND.C.LE.122))))GOTO *23396 I = 1 23398 IF (.NOT.(I .LT. TOKSIZ - 2))GOTO 23400 C = NGETCH (LEXSTR (I + 1)) IF (.NOT.(.NOT.((65.LE.C.AND.C.LE.90).OR.(97.LE.C.AND.C.LE.122)) . *AND. .NOT.(48.LE.C.AND.C.LE.57) .AND. C .NE. 95))GOTO 23401 GOTO 23400 23401 CONTINUE 23399 I = I + 1 GOTO 23398 23400 CONTINUE CALL PUTBAK (C) GTOK = -9 GOTO 23397 23396 CONTINUE IF (.NOT.((48.LE.C.AND.C.LE.57)))GOTO 23403 B = C - 48 I = 1 23405 IF (.NOT.(I .LT. TOKSIZ - 2))GOTO 23407 C = NGETCH (LEXSTR (I + 1)) IF (.NOT.(.NOT.(48.LE.C.AND.C.LE.57)))GOTO 23408 GOTO 23407 23408 CONTINUE B = 10 * B + C - 48 23406 I = I + 1 GOTO 23405 23407 CONTINUE IF (.NOT.(C .EQ. 37 .AND. B .GE. 2 .AND. B .LE. 36))GOTO 23410 N = 0 23412 CONTINUE D = INDEXC (DIGITS, CLOWER (NGETCH (C))) - 1 IF (.NOT.(D .LT. 0))GOTO 23415 GOTO 23414 23415 CONTINUE N = B * N + D 23413 GOTO 23412 23414 CONTINUE CALL PUTBAK (C) I = ITOC (N, LEXSTR, TOKSIZ) GOTO 23411 23410 CONTINUE CALL PUTBAK (C) 23411 CONTINUE GTOK = 2 GOTO 23404 23403 CONTINUE IF (.NOT.(C .EQ. 91))GOTO 23417 LEXSTR (1) = 123 GTOK = 123 GOTO 23418 23417 CONTINUE IF (.NOT.(C .EQ. 93))GOTO 23419 LEXSTR (1) = 125 GTOK = 125 GOTO 23420 23419 CONTINUE IF (.NOT.(C .EQ. 36))GOTO 23421 IF (.NOT.(NGETCH (LEXSTR (2)) .EQ. 40))GOTO 23423 I = 2 GTOK = -10 GOTO 23424 23423 CONTINUE IF (.NOT.(LEXSTR (2) .EQ. 41))GOTO 23425 I = 2 GTOK = -11 GOTO 23426 23425 CONTINUE CALL PUTBAK (LEXSTR (2)) GTOK = 36 23426 CONTINUE 23424 CONTINUE GOTO 23422 23421 CONTINUE IF (.NOT.(C .EQ. 39))GOTO 23427 I = 2 IF (.NOT.(NGETCH(LEXSTR(1)) .EQ. 64))GOTO 23429 C = NGETCH(LEXSTR(2)) I = 3 23429 CONTINUE LEXSTR(I) = 0 I = 1 C = ESC(LEXSTR, I) N = C I = ITOC(N, LEXSTR, TOKSIZ) GTOK = 2 IF (.NOT.(NGETCH(C) .NE. 39))GOTO 23431 CALL SYNERR(41Hmissing apostrophe in character constant.) 23433 IF (.NOT.(C .NE. -1))GOTO 23435 IF (.NOT.(C .EQ. 39 .OR. C .EQ. 10))GOTO 23436 GOTO 23435 23436 CONTINUE 23434 C = NGETCH(C) GOTO 23433 23435 CONTINUE IF (.NOT.(C .EQ. 10))GOTO 23438 CALL PUTBAK(10) 23438 CONTINUE 23431 CONTINUE GOTO 23428 23427 CONTINUE IF (.NOT.(C .EQ. 34))GOTO 23440 GTOK = C I = 2 23442 IF (.NOT.(NGETCH(C) .NE. -1))GOTO 23444 LEXSTR(I) = C IF (.NOT.(C .EQ. 64))GOTO 23445 IF (.NOT.(NGETCH(C) .EQ. -1))GOTO 23447 CALL PUTBAK(C) GOTO 23448 23447 CONTINUE I = I + 1 IF (.NOT.(I .GE. TOKSIZ -1))GOTO 23449 I = TOKSIZ - 1 23449 CONTINUE LEXSTR(I) = C C = 64 23448 CONTINUE 23445 CONTINUE IF (.NOT.(C .EQ. 34))GOTO 23451 GOTO 23444 23451 CONTINUE IF (.NOT.(LEXSTR (I) .EQ. 95))GOTO 23453 IF (.NOT.(NGETCH (C) .EQ. 10))GOTO 23455 23457 IF (.NOT.(C .EQ. 10 .OR. C .EQ. 32 .OR. C .EQ. 9))GOTO 23458 C = NGETCH (C) GOTO 23457 23458 CONTINUE LEXSTR (I) = C GOTO 23456 23455 CONTINUE CALL PUTBAK (C) 23456 CONTINUE 23453 CONTINUE IF (.NOT.(LEXSTR (I) .EQ. 10 .OR. I .GE. TOKSIZ - 1))GOTO 23459 CALL SYNERR (14Hmissing quote.) LEXSTR (I) = LEXSTR (1) CALL PUTBAK (10) GOTO 23444 23459 CONTINUE 23443 I = I + 1 GOTO 23442 23444 CONTINUE GOTO 23441 23440 CONTINUE IF (.NOT.(C .EQ. 35))GOTO 23461 23463 IF (.NOT.(NGETCH (LEXSTR (1)) .NE. 10))GOTO 23464 GOTO 23463 23464 CONTINUE GTOK = 10 GOTO 23462 23461 CONTINUE IF (.NOT.(C .EQ. 62 .OR. C .EQ. 60 .OR. C .EQ. 33 .OR. C .EQ. 38 . *OR. C .EQ. 124 .OR. C .EQ. 61 .OR. C .EQ. 33 .OR. C .EQ. 126 .OR. *C .EQ. 94))GOTO 23465 CALL RELATE (LEXSTR, I) GTOK = C GOTO 23466 23465 CONTINUE GTOK = C 23466 CONTINUE 23462 CONTINUE 23441 CONTINUE 23428 CONTINUE 23422 CONTINUE 23420 CONTINUE 23418 CONTINUE 23404 CONTINUE 23397 CONTINUE IF (.NOT.(I .GE. TOKSIZ - 1))GOTO 23467 CALL SYNERR (15Htoken too long.) 23467 CONTINUE LEXSTR (I + 1) = 0 RETURN END SUBROUTINE IFCODE (LAB) INTEGER LAB COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER LABGEN XFER = 0 LAB = LABGEN (2) CALL IFGO (LAB) RETURN END SUBROUTINE IFGO (LAB) INTEGER LAB LOGICAL*1 IFNOT(10) DATA IFNOT(1)/105/,IFNOT(2)/102/,IFNOT(3)/32/,IFNOT(4)/40/,IFNOT(5 *)/46/,IFNOT(6)/110/,IFNOT(7)/111/,IFNOT(8)/116/,IFNOT(9)/46/,IFNOT *(10)/0/ CALL OUTTAB CALL OUTSTR (IFNOT) CALL BALPAR CALL OUTCH (41) CALL OUTGO (LAB) RETURN END INTEGER FUNCTION IFPARM (STRNG) LOGICAL*1 STRNG (100) LOGICAL*1 C INTEGER I INTEGER INDEXC LOGICAL*1 TYPE C = STRNG (1) IF (.NOT.(C .EQ. -12 .OR. C .EQ. -13 .OR. C .EQ. -11 .OR. C .EQ. - *14 .OR. C .EQ. -10))GOTO 23469 IFPARM = 1 GOTO 23470 23469 CONTINUE IFPARM = 0 I = 1 23471 IF (.NOT.(INDEXC (STRNG (I), 36) .GT. 0))GOTO 23473 I = I + INDEXC (STRNG (I), 36) IF (.NOT.(TYPE (STRNG (I)) .EQ. 2))GOTO 23474 IF (.NOT.(TYPE (STRNG (I + 1)) .NE. 2))GOTO 23476 IFPARM = 1 GOTO 23473 23476 CONTINUE 23474 CONTINUE 23472 GOTO 23471 23473 CONTINUE 23470 CONTINUE RETURN END SUBROUTINE INITKW COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER MKTABL CALL DSINIT (4250) DEFTBL = MKTABL (1) CALL ENTDKW RKWTBL = MKTABL (1) CALL ENTRKW LABEL = 23000 RETURN END SUBROUTINE LABELC (LEXSTR) LOGICAL*1 LEXSTR (100) COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER LENGTH XFER = 0 IF (.NOT.(LENGTH (LEXSTR) .EQ. 5))GOTO 23478 IF (.NOT.(LEXSTR (1) .EQ. 50 .AND. LEXSTR (2) .EQ. 51))GOTO 23480 CALL SYNERR (33Hwarning: possible label conflict.) 23480 CONTINUE 23478 CONTINUE CALL OUTSTR (LEXSTR) CALL OUTTAB RETURN END INTEGER FUNCTION LABGEN (N) INTEGER N COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LABGEN = LABEL LABEL = LABEL + N RETURN END INTEGER FUNCTION LEX (LEXSTR) LOGICAL*1 LEXSTR (120) COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 GNBTOK INTEGER LOOKUP LEX = GNBTOK (LEXSTR, 120) 23482 IF (.NOT.(LEX .EQ. 10))GOTO 23484 23483 LEX = GNBTOK (LEXSTR, 120) GOTO 23482 23484 CONTINUE IF (.NOT.(LEX .EQ. -1 .OR. LEX .EQ. 59 .OR. LEX .EQ. 123 .OR. LEX *.EQ. 125))GOTO 23485 RETURN 23485 CONTINUE IF (.NOT.(LEX .EQ. 2))GOTO 23487 LEX = -9 GOTO 23488 23487 CONTINUE IF (.NOT.(LEX .EQ. 37))GOTO 23489 LEX = -27 GOTO 23490 23489 CONTINUE IF (.NOT.(LOOKUP (LEXSTR, LEX, RKWTBL) .EQ. 1))GOTO 23491 GOTO 23492 23491 CONTINUE LEX = -14 23492 CONTINUE 23490 CONTINUE 23488 CONTINUE RETURN END SUBROUTINE LITRAL COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 NGETCH IF (.NOT.(OUTP .GT. 0))GOTO 23493 CALL OUTDON 23493 CONTINUE OUTP = 1 23495 IF (.NOT.(NGETCH (OUTBUF (OUTP)) .NE. 10))GOTO 23497 23496 OUTP = OUTP + 1 GOTO 23495 23497 CONTINUE OUTP = OUTP - 1 CALL OUTDON RETURN END SUBROUTINE LODSYM(FBUF) COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 FBUF(40) INTEGER OPEN, LOCCOM LOGICAL*1 DEFNS(8) LOGICAL*1 SUFFIX(3) DATA DEFNS(1)/115/,DEFNS(2)/121/,DEFNS(3)/109/,DEFNS(4)/98/,DEFNS( *5)/111/,DEFNS(6)/108/,DEFNS(7)/115/,DEFNS(8)/0/ DATA SUFFIX(1)/0/,SUFFIX(2)/10/,SUFFIX(3)/0/ IF (.NOT.(DEFNS(1) .NE. 0))GOTO 23498 CALL IMPATH(FNAMES) IF (.NOT.(LOCCOM(DEFNS, FNAMES, SUFFIX, FBUF) .EQ. 12))GOTO 23500 INFILE(1) = OPEN(FBUF, 1) IF (.NOT.(INFILE(1) .EQ. -3))GOTO 23502 CALL REMARK(38Hcannot open standard definitions file.) GOTO 23503 23502 CONTINUE CALL PARSE CALL CLOSE(INFILE(1)) 23503 CONTINUE GOTO 23501 23500 CONTINUE CALL REMARK(40Hcannot locate standard definitions file.) 23501 CONTINUE 23498 CONTINUE RETURN END LOGICAL*1 FUNCTION NGETCH (C) LOGICAL*1 C COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 GETCH IF (.NOT.(BP .GT. 0))GOTO 23504 C = BUF(BP) BP = BP - 1 GOTO 23505 23504 CONTINUE C = GETCH(C, INFILE (LEVEL) ) IF (.NOT.(C .EQ. 10))GOTO 23506 LINECT (LEVEL) = LINECT (LEVEL) + 1 23506 CONTINUE 23505 CONTINUE NGETCH=(C) RETURN END SUBROUTINE OTHERC (LEXSTR) LOGICAL*1 LEXSTR (100) COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM XFER = 0 CALL OUTTAB CALL OUTSTR (LEXSTR) CALL EATUP CALL OUTDON RETURN END SUBROUTINE OUTCH (C) LOGICAL*1 C COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER I IF (.NOT.(OUTP .GE. 72))GOTO 23508 CALL OUTDON I = 1 23510 IF (.NOT.(I .LT. 6))GOTO 23512 OUTBUF (I) = 32 23511 I = I + 1 GOTO 23510 23512 CONTINUE OUTBUF (6) = 42 OUTP = 6 23508 CONTINUE OUTP = OUTP + 1 OUTBUF (OUTP) = C RETURN END SUBROUTINE OUTCON (N) INTEGER N COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 CONTIN(9) DATA CONTIN(1)/99/,CONTIN(2)/111/,CONTIN(3)/110/,CONTIN(4)/116/,CO *NTIN(5)/105/,CONTIN(6)/110/,CONTIN(7)/117/,CONTIN(8)/101/,CONTIN(9 *)/0/ XFER = 0 IF (.NOT.(N .LE. 0 .AND. OUTP .EQ. 0))GOTO 23513 RETURN 23513 CONTINUE IF (.NOT.(N .GT. 0))GOTO 23515 CALL OUTNUM (N) 23515 CONTINUE CALL OUTTAB CALL OUTSTR (CONTIN) CALL OUTDON RETURN END SUBROUTINE OUTDON COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM OUTBUF (OUTP + 1) = 10 OUTBUF (OUTP + 2) = 0 CALL PUTLIN (OUTBUF, 2) OUTP = 0 RETURN END SUBROUTINE OUTGO (N) INTEGER N COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 SGOTO(6) DATA SGOTO(1)/103/,SGOTO(2)/111/,SGOTO(3)/116/,SGOTO(4)/111/,SGOTO *(5)/32/,SGOTO(6)/0/ IF (.NOT.(XFER .EQ. 1))GOTO 23517 RETURN 23517 CONTINUE CALL OUTTAB CALL OUTSTR (SGOTO) CALL OUTNUM (N) CALL OUTDON RETURN END SUBROUTINE OUTNUM (N) INTEGER N LOGICAL*1 CHARS (20) INTEGER I, M M = IABS (N) I = 0 23519 CONTINUE I = I + 1 CHARS (I) = MOD (M, 10) + 48 M = M / 10 23520 IF (.NOT.(M .EQ. 0 .OR. I .GE. 20))GOTO 23519 23521 CONTINUE IF (.NOT.(N .LT. 0))GOTO 23522 CALL OUTCH (45) 23522 CONTINUE 23524 IF (.NOT.(I .GT. 0))GOTO 23526 CALL OUTCH (CHARS (I)) 23525 I = I - 1 GOTO 23524 23526 CONTINUE RETURN END SUBROUTINE OUTSTR (STR) LOGICAL*1 STR (100) LOGICAL*1 C INTEGER I, J, N LOGICAL*1 CUPPER INTEGER LENGTH IF (.NOT.(STR(1) .NE. 34))GOTO 23527 I=1 23529 IF (.NOT.(STR(I) .NE. 0))GOTO 23531 C = STR(I) CALL OUTCH (CUPPER(C)) 23530 I=I+1 GOTO 23529 23531 CONTINUE GOTO 23528 23527 CONTINUE J = LENGTH(STR) I=2 N=0 23532 IF (.NOT.(I .LT. J))GOTO 23534 IF (.NOT.(STR(I) .EQ. 34))GOTO 23535 GOTO 23534 23535 CONTINUE IF (.NOT.(STR(I) .EQ. 64))GOTO 23537 IF (.NOT.(STR(I+1) .EQ. 34))GOTO 23539 I = I + 1 23539 CONTINUE N = N + 1 GOTO 23538 23537 CONTINUE N = N + 1 23538 CONTINUE 23536 CONTINUE 23533 I=I+1 GOTO 23532 23534 CONTINUE CALL OUTNUM (N) CALL OUTCH(72) I=2 23541 IF (.NOT.(I .LT. J))GOTO 23543 IF (.NOT.(STR(I) .EQ. 64 .AND. STR(I+1) .EQ. 34))GOTO 23544 I = I + 1 23544 CONTINUE CALL OUTCH(STR(I)) 23542 I = I + 1 GOTO 23541 23543 CONTINUE 23528 CONTINUE RETURN END SUBROUTINE OUTTAB COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM 23546 IF (.NOT.(OUTP .LT. 6))GOTO 23547 CALL OUTCH (32) GOTO 23546 23547 CONTINUE RETURN END SUBROUTINE PARSE COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 LEXSTR (120) INTEGER LAB, LABVAL (100), LEXTYP (100), SP, TOKEN, I INTEGER LEX CALL FINIT SP = 1 LEXTYP (1) = -1 TOKEN = LEX (LEXSTR) 23548 IF (.NOT.(TOKEN .NE. -1))GOTO 23550 IF (.NOT.(TOKEN .EQ. -19))GOTO 23551 CALL IFCODE (LAB) GOTO 23552 23551 CONTINUE IF (.NOT.(TOKEN .EQ. -10))GOTO 23553 CALL DOCODE (LAB) GOTO 23554 23553 CONTINUE IF (.NOT.(TOKEN .EQ. -15))GOTO 23555 CALL WHILEC (LAB) GOTO 23556 23555 CONTINUE IF (.NOT.(TOKEN .EQ. -16))GOTO 23557 CALL FORCOD (LAB) GOTO 23558 23557 CONTINUE IF (.NOT.(TOKEN .EQ. -17))GOTO 23559 CALL REPCOD (LAB) GOTO 23560 23559 CONTINUE IF (.NOT.(TOKEN .EQ. -24))GOTO 23561 CALL SELCOD (LAB) GOTO 23562 23561 CONTINUE IF (.NOT.(TOKEN .EQ. -25 .OR. TOKEN .EQ. -26))GOTO 23563 I = SP 23565 IF (.NOT.(I .GT. 0))GOTO 23567 IF (.NOT.(LEXTYP (I) .EQ. -24))GOTO 23568 GOTO 23567 23568 CONTINUE 23566 I = I - 1 GOTO 23565 23567 CONTINUE IF (.NOT.(I .EQ. 0))GOTO 23570 CALL SYNERR (24Hillegal case or default.) GOTO 23571 23570 CONTINUE CALL CASCOD (LABVAL (I), TOKEN) 23571 CONTINUE GOTO 23564 23563 CONTINUE IF (.NOT.(TOKEN .EQ. -9))GOTO 23572 CALL LABELC (LEXSTR) GOTO 23573 23572 CONTINUE IF (.NOT.(TOKEN .EQ. -11))GOTO 23574 IF (.NOT.(LEXTYP (SP) .EQ. -19))GOTO 23576 CALL ELSEIF (LABVAL (SP)) GOTO 23577 23576 CONTINUE CALL SYNERR (13Hillegal else.) 23577 CONTINUE GOTO 23575 23574 CONTINUE IF (.NOT.(TOKEN .EQ. -27))GOTO 23578 CALL LITRAL 23578 CONTINUE 23575 CONTINUE 23573 CONTINUE 23564 CONTINUE 23562 CONTINUE 23560 CONTINUE 23558 CONTINUE 23556 CONTINUE 23554 CONTINUE 23552 CONTINUE IF (.NOT.(TOKEN .EQ. -19 .OR. TOKEN .EQ. -11 .OR. TOKEN .EQ. -15 . *OR. TOKEN .EQ. -16 .OR. TOKEN .EQ. -17 .OR. TOKEN .EQ. -24 .OR. *TOKEN .EQ. -10 .OR. TOKEN .EQ. -9 .OR. TOKEN .EQ. 123))GOTO 23580 SP = SP + 1 IF (.NOT.(SP .GT. 100))GOTO 23582 CALL BADERR (25Hstack overflow in parser.) 23582 CONTINUE LEXTYP (SP) = TOKEN LABVAL (SP) = LAB GOTO 23581 23580 CONTINUE IF (.NOT.(TOKEN .NE. -25 .AND. TOKEN .NE. -26))GOTO 23584 IF (.NOT.(TOKEN .EQ. 125))GOTO 23586 IF (.NOT.(LEXTYP (SP) .EQ. 123))GOTO 23588 SP = SP - 1 GOTO 23589 23588 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -24))GOTO 23590 CALL SELEND (LABVAL (SP)) SP = SP - 1 GOTO 23591 23590 CONTINUE CALL SYNERR (20Hillegal right brace.) 23591 CONTINUE 23589 CONTINUE GOTO 23587 23586 CONTINUE IF (.NOT.(TOKEN .EQ. -14))GOTO 23592 CALL OTHERC (LEXSTR) GOTO 23593 23592 CONTINUE IF (.NOT.(TOKEN .EQ. -8 .OR. TOKEN .EQ. -13))GOTO 23594 CALL BRKNXT (SP, LEXTYP, LABVAL, TOKEN) GOTO 23595 23594 CONTINUE IF (.NOT.(TOKEN .EQ. -20))GOTO 23596 CALL RETCOD GOTO 23597 23596 CONTINUE IF (.NOT.(TOKEN .EQ. -23))GOTO 23598 CALL STRDCL 23598 CONTINUE 23597 CONTINUE 23595 CONTINUE 23593 CONTINUE 23587 CONTINUE TOKEN = LEX (LEXSTR) CALL PBSTR (LEXSTR) CALL UNSTAK (SP, LEXTYP, LABVAL, TOKEN) 23584 CONTINUE 23581 CONTINUE 23549 TOKEN = LEX (LEXSTR) GOTO 23548 23550 CONTINUE IF (.NOT.(SP .NE. 1))GOTO 23600 CALL SYNERR (15Hunexpected EOF.) 23600 CONTINUE IF (.NOT.(CSP .GT. 0))GOTO 23602 CALL SYNERR(43Hconditional processing still active at EOF.) 23602 CONTINUE RETURN END SUBROUTINE PBNUM (N) INTEGER N INTEGER M, NUM LOGICAL*1 DIGITS(11) DATA DIGITS(1)/48/,DIGITS(2)/49/,DIGITS(3)/50/,DIGITS(4)/51/,DIGIT *S(5)/52/,DIGITS(6)/53/,DIGITS(7)/54/,DIGITS(8)/55/,DIGITS(9)/56/,D *IGITS(10)/57/,DIGITS(11)/0/ NUM = IABS(N) 23604 CONTINUE M = MOD (NUM, 10) CALL PUTBAK (DIGITS (M + 1)) NUM = NUM / 10 23605 IF (.NOT.(NUM .EQ. 0))GOTO 23604 23606 CONTINUE IF (.NOT.(N .LT. 0))GOTO 23607 CALL PUTBAK(45) 23607 CONTINUE RETURN END SUBROUTINE PBSTR (IN) LOGICAL*1 IN (100) INTEGER I INTEGER LENGTH I = LENGTH (IN) 23609 IF (.NOT.(I .GT. 0))GOTO 23611 CALL PUTBAK (IN (I)) 23610 I = I - 1 GOTO 23609 23611 CONTINUE RETURN END INTEGER FUNCTION PUSH (EP, ARGSTK, AP) INTEGER AP, ARGSTK (100), EP IF (.NOT.(AP .GT. 100))GOTO 23612 CALL BADERR (19Harg stack overflow.) 23612 CONTINUE ARGSTK (AP) = EP PUSH = AP + 1 RETURN END SUBROUTINE PUTBAK (C) LOGICAL*1 C COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM IF (.NOT.(BP .GE. 500))GOTO 23614 CALL BADERR (32Htoo many characters pushed back.) GOTO 23615 23614 CONTINUE BP = BP + 1 BUF (BP) = C 23615 CONTINUE RETURN END SUBROUTINE PUTCHR (C) LOGICAL*1 C COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM IF (.NOT.(EP .GT. 500))GOTO 23616 CALL BADERR (26Hevaluation stack overflow.) 23616 CONTINUE EVALST (EP) = C EP = EP + 1 RETURN END SUBROUTINE PUTTOK (STR) LOGICAL*1 STR (120) INTEGER I I = 1 23618 IF (.NOT.(STR (I) .NE. 0))GOTO 23620 CALL PUTCHR (STR (I)) 23619 I = I + 1 GOTO 23618 23620 CONTINUE RETURN END SUBROUTINE RELATE (TOKEN, LAST) LOGICAL*1 TOKEN (100) INTEGER LAST LOGICAL*1 NGETCH INTEGER LENGTH IF (.NOT.(NGETCH (TOKEN (2)) .NE. 61))GOTO 23621 CALL PUTBAK (TOKEN (2)) TOKEN (3) = 116 GOTO 23622 23621 CONTINUE TOKEN (3) = 101 23622 CONTINUE TOKEN (4) = 46 TOKEN (5) = 0 TOKEN (6) = 0 IF (.NOT.(TOKEN (1) .EQ. 62))GOTO 23623 TOKEN (2) = 103 GOTO 23624 23623 CONTINUE IF (.NOT.(TOKEN (1) .EQ. 60))GOTO 23625 TOKEN (2) = 108 GOTO 23626 23625 CONTINUE IF (.NOT.(TOKEN (1) .EQ. 33 .OR. TOKEN(1) .EQ. 33 .OR. TOKEN(1) .E *Q. 126 .OR. TOKEN(1) .EQ. 94))GOTO 23627 IF (.NOT.(TOKEN (2) .NE. 61))GOTO 23629 TOKEN (3) = 111 TOKEN (4) = 116 TOKEN (5) = 46 23629 CONTINUE TOKEN (2) = 110 GOTO 23628 23627 CONTINUE IF (.NOT.(TOKEN (1) .EQ. 61))GOTO 23631 IF (.NOT.(TOKEN (2) .NE. 61))GOTO 23633 TOKEN (2) = 0 LAST = 1 RETURN 23633 CONTINUE TOKEN (2) = 101 TOKEN (3) = 113 GOTO 23632 23631 CONTINUE IF (.NOT.(TOKEN (1) .EQ. 38))GOTO 23635 TOKEN (2) = 97 TOKEN (3) = 110 TOKEN (4) = 100 TOKEN (5) = 46 GOTO 23636 23635 CONTINUE IF (.NOT.(TOKEN (1) .EQ. 124))GOTO 23637 TOKEN (2) = 111 TOKEN (3) = 114 GOTO 23638 23637 CONTINUE TOKEN (2) = 0 23638 CONTINUE 23636 CONTINUE 23632 CONTINUE 23628 CONTINUE 23626 CONTINUE 23624 CONTINUE TOKEN (1) = 46 LAST = LENGTH (TOKEN) RETURN END SUBROUTINE REPCOD (LAB) INTEGER LAB INTEGER LABGEN CALL OUTCON (0) LAB = LABGEN (3) CALL OUTCON (LAB) LAB = LAB + 1 RETURN END SUBROUTINE RETCOD COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 T LOGICAL*1 GNBTOK LOGICAL*1 SRET(7) DATA SRET(1)/114/,SRET(2)/101/,SRET(3)/116/,SRET(4)/117/,SRET(5)/1 *14/,SRET(6)/110/,SRET(7)/0/ T = GNBTOK (SCRTOK, 120) IF (.NOT.(T .NE. 10 .AND. T .NE. 59 .AND. T .NE. 125))GOTO 23639 CALL PBSTR (SCRTOK) CALL OUTTAB CALL SCOPY (FCNAME, 1, SCRTOK, 1) CALL OUTSTR (SCRTOK) CALL OUTCH (61) CALL EATUP CALL OUTDON GOTO 23640 23639 CONTINUE IF (.NOT.(T .EQ. 125))GOTO 23641 CALL PBSTR (SCRTOK) 23641 CONTINUE 23640 CONTINUE CALL OUTTAB CALL OUTSTR (SRET) CALL OUTDON XFER = 1 RETURN END SUBROUTINE SELCOD (LAB) INTEGER LAB COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER LABGEN, GNBTOK LAB = LABGEN (2) IF (.NOT.(SELAST + 3 .GT. 300))GOTO 23643 CALL BADERR (22Hselect table overflow.) 23643 CONTINUE SESTAK (SELAST) = SETOP SESTAK (SELAST + 1) = 0 SESTAK (SELAST + 2) = 0 SETOP = SELAST SELAST = SELAST + 3 XFER = 0 CALL OUTTAB CALL SELVAR (LAB) CALL OUTCH (61) CALL BALPAR CALL OUTDON CALL OUTGO (LAB) XFER = 1 23645 IF (.NOT.(GNBTOK (SCRTOK, 120) .EQ. 10))GOTO 23646 GOTO 23645 23646 CONTINUE IF (.NOT.(SCRTOK (1) .NE. 123))GOTO 23647 CALL SYNERR (39Hmissing left brace in select statement.) CALL PBSTR (SCRTOK) 23647 CONTINUE RETURN END SUBROUTINE SELEND (LAB) INTEGER LAB COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER LB, UB, N, I, J LOGICAL*1 SIF(5) LOGICAL*1 SLT(10) LOGICAL*1 SGT(5) LOGICAL*1 SGOTO(7) LOGICAL*1 SEQ(5) LOGICAL*1 SGE(5) LOGICAL*1 SLE(5) LOGICAL*1 SAND(6) DATA SIF(1)/105/,SIF(2)/102/,SIF(3)/32/,SIF(4)/40/,SIF(5)/0/ DATA SLT(1)/46/,SLT(2)/108/,SLT(3)/116/,SLT(4)/46/,SLT(5)/49/,SLT( *6)/46/,SLT(7)/111/,SLT(8)/114/,SLT(9)/46/,SLT(10)/0/ DATA SGT(1)/46/,SGT(2)/103/,SGT(3)/116/,SGT(4)/46/,SGT(5)/0/ DATA SGOTO(1)/103/,SGOTO(2)/111/,SGOTO(3)/116/,SGOTO(4)/111/,SGOTO *(5)/32/,SGOTO(6)/40/,SGOTO(7)/0/ DATA SEQ(1)/46/,SEQ(2)/101/,SEQ(3)/113/,SEQ(4)/46/,SEQ(5)/0/ DATA SGE(1)/46/,SGE(2)/103/,SGE(3)/101/,SGE(4)/46/,SGE(5)/0/ DATA SLE(1)/46/,SLE(2)/108/,SLE(3)/101/,SLE(4)/46/,SLE(5)/0/ DATA SAND(1)/46/,SAND(2)/97/,SAND(3)/110/,SAND(4)/100/,SAND(5)/46/ *,SAND(6)/0/ LB = SESTAK (SETOP + 3) UB = SESTAK (SELAST - 2) N = SESTAK (SETOP + 1) CALL OUTGO (LAB + 1) IF (.NOT.(SESTAK (SETOP + 2) .EQ. 0))GOTO 23649 SESTAK (SETOP + 2) = LAB + 1 23649 CONTINUE XFER = 0 CALL OUTCON (LAB) IF (.NOT.(N .GE. 3 .AND. UB - LB + 1 .LT. 2 * N))GOTO 23651 IF (.NOT.(LB .NE. 1))GOTO 23653 CALL OUTTAB CALL SELVAR (LAB) CALL OUTCH (61) CALL SELVAR (LAB) IF (.NOT.(LB .LT. 1))GOTO 23655 CALL OUTCH (43) 23655 CONTINUE CALL OUTNUM (-LB + 1) CALL OUTDON 23653 CONTINUE CALL OUTTAB CALL OUTSTR (SIF) CALL SELVAR (LAB) CALL OUTSTR (SLT) CALL SELVAR (LAB) CALL OUTSTR (SGT) CALL OUTNUM (UB - LB + 1) CALL OUTCH (41) CALL OUTGO (SESTAK (SETOP + 2)) CALL OUTTAB CALL OUTSTR (SGOTO) J = LB I = SETOP + 3 23657 IF (.NOT.(I .LT. SELAST))GOTO 23659 23660 IF (.NOT.(J .LT. SESTAK (I)))GOTO 23662 CALL OUTNUM (SESTAK (SETOP + 2)) CALL OUTCH (44) 23661 J = J + 1 GOTO 23660 23662 CONTINUE J = SESTAK (I + 1) - SESTAK (I) 23663 IF (.NOT.(J .GE. 0))GOTO 23665 CALL OUTNUM (SESTAK (I + 2)) 23664 J = J - 1 GOTO 23663 23665 CONTINUE J = SESTAK (I + 1) + 1 IF (.NOT.(I .LT. SELAST - 3))GOTO 23666 CALL OUTCH (44) 23666 CONTINUE 23658 I = I + 3 GOTO 23657 23659 CONTINUE CALL OUTCH (41) CALL OUTCH (44) CALL SELVAR (LAB) CALL OUTDON GOTO 23652 23651 CONTINUE IF (.NOT.(N .GT. 0))GOTO 23668 I = SETOP + 3 23670 IF (.NOT.(I .LT. SELAST))GOTO 23672 CALL OUTTAB CALL OUTSTR (SIF) CALL SELVAR (LAB) IF (.NOT.(SESTAK (I) .EQ. SESTAK (I+1)))GOTO 23673 CALL OUTSTR (SEQ) CALL OUTNUM (SESTAK (I)) GOTO 23674 23673 CONTINUE CALL OUTSTR (SGE) CALL OUTNUM (SESTAK (I)) CALL OUTSTR (SAND) CALL SELVAR (LAB) CALL OUTSTR (SLE) CALL OUTNUM (SESTAK (I + 1)) 23674 CONTINUE CALL OUTCH (41) CALL OUTGO (SESTAK (I + 2)) 23671 I = I + 3 GOTO 23670 23672 CONTINUE IF (.NOT.(LAB + 1 .NE. SESTAK (SETOP + 2)))GOTO 23675 CALL OUTGO (SESTAK (SETOP + 2)) 23675 CONTINUE 23668 CONTINUE 23652 CONTINUE CALL OUTCON (LAB + 1) SELAST = SETOP SETOP = SESTAK (SETOP) RETURN END SUBROUTINE SELVAR (LAB) INTEGER LAB CALL OUTCH (73) CALL OUTNUM (LAB) RETURN END SUBROUTINE SKPBLK COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 C LOGICAL*1 NGETCH C = NGETCH (C) 23677 IF (.NOT.(C .EQ. 32 .OR. C .EQ. 9))GOTO 23679 23678 C = NGETCH (C) GOTO 23677 23679 CONTINUE CALL PUTBAK (C) RETURN END SUBROUTINE STRDCL COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 T, DCHAR (120) INTEGER I, J, K, N, LEN LOGICAL*1 GNBTOK, ESC INTEGER LENGTH, CTOI, LEX, ELENTH LOGICAL*1 CHAR(11) LOGICAL*1 DAT(6) LOGICAL*1 EOSS(5) DATA CHAR(1)/99/,CHAR(2)/104/,CHAR(3)/97/,CHAR(4)/114/,CHAR(5)/97/ *,CHAR(6)/99/,CHAR(7)/116/,CHAR(8)/101/,CHAR(9)/114/,CHAR(10)/47/,C *HAR(11)/0/ DATA DAT(1)/100/,DAT(2)/97/,DAT(3)/116/,DAT(4)/97/,DAT(5)/32/,DAT( *6)/0/ DATA EOSS(1)/69/,EOSS(2)/79/,EOSS(3)/83/,EOSS(4)/47/,EOSS(5)/0/ T = GNBTOK (SCRTOK, 120) IF (.NOT.(T .NE. -9))GOTO 23680 CALL SYNERR (22Hmissing string scrtok.) 23680 CONTINUE CALL OUTTAB CALL PBSTR (CHAR) 23682 CONTINUE T = GNBTOK (DCHAR, 120) IF (.NOT.(T .EQ. 47))GOTO 23685 GOTO 23684 23685 CONTINUE CALL OUTSTR (DCHAR) 23683 GOTO 23682 23684 CONTINUE CALL OUTCH (32) CALL OUTSTR (SCRTOK) CALL ADDSTR (SCRTOK, SBUF, SBP, 600) CALL ADDCHR (0, SBUF, SBP, 600) IF (.NOT.(GNBTOK (SCRTOK, 120) .NE. 40))GOTO 23687 LEN = ELENTH (SCRTOK) + 1 IF (.NOT.(SCRTOK (1) .EQ. 39 .OR. SCRTOK (1) .EQ. 34))GOTO 23689 LEN = LEN - 2 23689 CONTINUE GOTO 23688 23687 CONTINUE T = GNBTOK (SCRTOK, 120) I = 1 LEN = CTOI (SCRTOK, I) IF (.NOT.(SCRTOK (I) .NE. 0))GOTO 23691 CALL SYNERR (20Hinvalid string size.) 23691 CONTINUE IF (.NOT.(GNBTOK (SCRTOK, 120) .NE. 41))GOTO 23693 CALL SYNERR (20Hmissing right paren.) GOTO 23694 23693 CONTINUE T = GNBTOK (SCRTOK, 120) 23694 CONTINUE 23688 CONTINUE CALL OUTCH (40) CALL OUTNUM (LEN) CALL OUTCH (41) CALL OUTDON IF (.NOT.(SCRTOK (1) .EQ. 39 .OR. SCRTOK (1) .EQ. 34))GOTO 23695 LEN = LENGTH (SCRTOK) SCRTOK (LEN) = 0 CALL ADDSTR (SCRTOK (2), SBUF, SBP, 600) GOTO 23696 23695 CONTINUE CALL ADDSTR (SCRTOK, SBUF, SBP, 600) 23696 CONTINUE CALL ADDCHR (0, SBUF, SBP, 600) T = LEX (SCRTOK) CALL PBSTR (SCRTOK) IF (.NOT.(T .NE. -23))GOTO 23697 I = 1 23699 IF (.NOT.(I .LT. SBP))GOTO 23701 CALL OUTTAB CALL OUTSTR (DAT) K = 1 J = I + LENGTH (SBUF (I)) + 1 23702 CONTINUE IF (.NOT.(K .GT. 1))GOTO 23705 CALL OUTCH (44) 23705 CONTINUE CALL OUTSTR (SBUF (I)) CALL OUTCH (40) CALL OUTNUM (K) CALL OUTCH (41) CALL OUTCH (47) IF (.NOT.(SBUF (J) .EQ. 0))GOTO 23707 GOTO 23704 23707 CONTINUE N = ESC (SBUF, J) CALL OUTNUM (N) CALL OUTCH (47) K = K + 1 23703 J = J + 1 GOTO 23702 23704 CONTINUE CALL PBSTR (EOSS) 23709 CONTINUE T = GNBTOK (SCRTOK, 120) CALL OUTSTR (SCRTOK) 23710 IF (.NOT.(T .EQ. 47))GOTO 23709 23711 CONTINUE CALL OUTDON 23700 I = J + 1 GOTO 23699 23701 CONTINUE SBP = 1 23697 CONTINUE RETURN END SUBROUTINE SYNERR (MSG) LOGICAL*1 MSG (100) COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 LC (20) INTEGER I, JUNK INTEGER ITOC LOGICAL*1 IN(5) LOGICAL*1 ERRMSG(15) DATA IN(1)/32/,IN(2)/105/,IN(3)/110/,IN(4)/32/,IN(5)/0/ DATA ERRMSG(1)/101/,ERRMSG(2)/114/,ERRMSG(3)/114/,ERRMSG(4)/111/,E *RRMSG(5)/114/,ERRMSG(6)/32/,ERRMSG(7)/97/,ERRMSG(8)/116/,ERRMSG(9) */32/,ERRMSG(10)/108/,ERRMSG(11)/105/,ERRMSG(12)/110/,ERRMSG(13)/10 *1/,ERRMSG(14)/32/,ERRMSG(15)/0/ CALL PUTLIN (ERRMSG, 3) IF (.NOT.(LEVEL .GE. 1))GOTO 23712 I = LEVEL GOTO 23713 23712 CONTINUE I = 1 23713 CONTINUE JUNK = ITOC (LINECT (I), LC, 20) CALL PUTLIN (LC, 3) I = FNAMP - 1 23714 IF (.NOT.(I .GT. 1))GOTO 23716 IF (.NOT.(FNAMES (I - 1) .EQ. 0))GOTO 23717 CALL PUTLIN (IN, 3) CALL PUTLIN (FNAMES (I), 3) GOTO 23716 23717 CONTINUE 23715 I = I - 1 GOTO 23714 23716 CONTINUE CALL PUTCH (58, 3) CALL PUTCH (32, 3) CALL REMARK (MSG) RETURN END SUBROUTINE ULSTAL (NAME, DEFN) LOGICAL*1 NAME (100), DEFN (100) COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM CALL ENTDEF (NAME, DEFN, DEFTBL) CALL UPPER (NAME) CALL ENTDEF (NAME, DEFN, DEFTBL) RETURN END SUBROUTINE UNSTAK (SP, LEXTYP, LABVAL, TOKEN) INTEGER LABVAL (100), LEXTYP (100), SP, TOKEN 23719 IF (.NOT.(SP .GT. 1))GOTO 23721 IF (.NOT.(LEXTYP (SP) .EQ. 123))GOTO 23722 GOTO 23721 23722 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -24))GOTO 23724 GOTO 23721 23724 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -19 .AND. TOKEN .EQ. -11))GOTO 23726 GOTO 23721 23726 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -19))GOTO 23728 CALL OUTCON (LABVAL (SP)) GOTO 23729 23728 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -11))GOTO 23730 IF (.NOT.(SP .GT. 2))GOTO 23732 SP = SP - 1 23732 CONTINUE CALL OUTCON (LABVAL (SP) + 1) GOTO 23731 23730 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -10))GOTO 23734 CALL DOSTAT (LABVAL (SP)) GOTO 23735 23734 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -15))GOTO 23736 CALL WHILES (LABVAL (SP)) GOTO 23737 23736 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -16))GOTO 23738 CALL FORS (LABVAL (SP)) GOTO 23739 23738 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -17))GOTO 23740 CALL UNTILS (LABVAL (SP), TOKEN) 23740 CONTINUE 23739 CONTINUE 23737 CONTINUE 23735 CONTINUE 23731 CONTINUE 23729 CONTINUE 23720 SP = SP - 1 GOTO 23719 23721 CONTINUE RETURN END SUBROUTINE UNTILS (LAB, TOKEN) INTEGER LAB, TOKEN COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CSELCT/ SETOP, SELAST, SESTAK (300) INTEGER SETOP INTEGER SELAST INTEGER SESTAK COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK COMMON / CSCTOK / SCRTOK(120) LOGICAL*1 SCRTOK INTEGER MEM( 4250) LOGICAL*1 CMEM(8500) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 PTOKEN (120) INTEGER JUNK INTEGER LEX XFER = 0 CALL OUTNUM (LAB) IF (.NOT.(TOKEN .EQ. -18))GOTO 23742 JUNK = LEX (PTOKEN) CALL IFGO (LAB - 1) GOTO 23743 23742 CONTINUE CALL OUTGO (LAB - 1) 23743 CONTINUE CALL OUTCON (LAB + 1) RETURN END SUBROUTINE WHILEC (LAB) INTEGER LAB INTEGER LABGEN CALL OUTCON (0) LAB = LABGEN (2) CALL OUTNUM (LAB) CALL IFGO (LAB + 1) RETURN END SUBROUTINE WHILES (LAB) INTEGER LAB CALL OUTGO (LAB) CALL OUTCON (LAB + 1) RETURN END