C MOSTEK F8 CROSS ASSEMBLER (LAST SEQUENCE NUMBER = 1120) 0001 C WRITTEN BY J.S.GOINGS 0002 C V04 8 APRIL 1976 0003 C MAIN ROUTINE 0004 COMMON/ERCT/IERC,ERF 0005 LOGICAL ERF 0006 LOGICAL LAB,PRNTF,PNCHF,ER,OF,PASS2,FLAG 0007 COMMON /DEV/ IC,OC,PR,PU 0008 COMMON /LETTRS/LETAB(64) 0009 EQUIVALENCE (LBK,LETAB(1)),(LAP,LETAB(47)) 0010 DIMENSION IMAGE(80) 0011 INTEGER HDR,PAGE 0012 COMMON /HDG/ HDR(80),PAGE,LINE 0013 INTEGER FIELD(6),EXPR(32),OP12,OP34,OP56,OVAL,OTYP,CH12,CH34,CH56, 0014 XSVALL,SVALH,SFLG,OC,PR,PU,FLG 0015 COMMON /OPTAB/OP12(63),OP34(63),OP56(63),OVAL(63),OTYP(63) 0016 COMMON /SYMTAB/CH12(500),CH34(500),CH56(500),SVALL(500),SVALH(500) 0017 X,SFLG(500) 0018 COMMON /LOC/LOCL,LOCH 0019 COMMON /DELIMS/KBK,KPL,KMI,KAP,KKO 0020 DATA KS/20/,KI/10/,KD/5/ 0021 DATA KF/7/,KO/16/ 0022 DO 100 I=1,500 0023 CH12(I)=0 0024 CH34(I)=0 0025 CH56(I)=0 0026 SVALL(I)=0 0027 SVALH(I)=0 0028 SFLG(I)=0 0029 100 CONTINUE 0030 IC=8 0031 OC=2 0032 PR=5 0033 PU=7 0034 OF=.TRUE. 0035 PRNTF=.TRUE. 0036 PNCHF=.FALSE. 0037 PASS2=.FALSE. 0038 1000 LOCH=0 0039 LOCL=0 0040 IF (PASS2.AND.PNCHF) CALL PHDR 0041 IF (PASS2.AND.PRNTF) CALL TOFM 0042 C CLEAR LABEL FLAG 0043 1010 LAB=.FALSE. 0044 C READ A LINE OF SOURCE 0045 READ (IC,1,END=1470 ) IMAGE 0046 1 FORMAT (80A1) 0047 C WRITE TO SECONDARY STORAGE IF NOT PASS2 AND DISK AVAILABLE 0048 IF (.NOT.PASS2.AND.OF) WRITE (OC,1) IMAGE 0049 C IGNORE COMMENT CARDS 0050 IBCT=0 0051 IF (IMAGE(1).EQ.LAP) GO TO 1510 0052 I=1 0053 C CHECK FOR PRESENCE OF LABEL 0054 IF (IMAGE(1).EQ.LBK) GO TO 1050 0055 CALL GETFLD(IMAGE,I,FIELD,6,ER) 0056 IF (FIELD(1).GT.27) GO TO 1015 0057 IF (.NOT.ER) GO TO 1020 0058 1015 IF (PASS2) CALL SCERR(1) 0059 GO TO 1050 0060 1020 CALL HASH (FIELD,INS) 0061 IF (INS.GT.0) GO TO 1030 0062 IF (PASS2) CALL LABERR 0063 1030 IF (SFLG(INS).NE.4) GO TO 1040 0064 IF (PASS2) CALL PHERR 0065 GO TO 1050 0066 1040 LAB=.TRUE. 0067 LABL=LOCL 0068 LABH=LOCH 0069 C SCAN FOR OPERATOR 0070 1050 CALL GETFLD (IMAGE,I,FIELD,6,ER) 0071 IF (.NOT.ER) GO TO 1060 0072 IF (PASS2) CALL SCERR(2) 0073 GO TO 1510 0074 1060 CALL OPSRCH (FIELD,INO) 0075 IF (INO.GT.0) GO TO 1070 0076 IF (PASS2) CALL OPERR 0077 IBCT=1 0078 I1=43 0079 GO TO 1510 0080 C BRANCH ON OP CODE TYPE 0081 1070 ITYP=OTYP(INO) 0082 GO TO(1080,1080,1080,1080,1160,1200,1200,1200,1200,1320,1340,1360 0083 X,1380,1470,1080,1080),ITYP 0084 C TYPES 1,2,3,4,15,16 - ONE BYTE 0085 1080 IBCT=1 0086 IF (.NOT.PASS2) GO TO 1490 0087 IF (ITYP.NE.2) GO TO 1090 0088 I1=OVAL(INO) 0089 GO TO 1490 0090 1090 IF (ITYP.NE.1) GO TO 1100 0091 CALL LR (IMAGE,I,I1) 0092 GO TO 1490 0093 1100 CALL GETFLD (IMAGE,I,EXPR,32,ER) 0094 IF (.NOT.ER) GO TO 1105 0095 IF (.NOT.PASS2) GO TO 1490 0096 CALL SCERR(3) 0097 IVL=0 0098 IVH=0 0099 GO TO 1120 0100 1105 IF (ITYP.NE.3.OR.EXPR(2).NE.KBK) GO TO 1110 0101 IVH=0 102 IVL=0 103 IF (EXPR(1).EQ.KS) IVL=12 104 IF (EXPR(1).EQ.KI) IVL=13 105 IF (EXPR(1).EQ.KD) IVL=14 106 IF (IVL.NE.0) GO TO 1120 107 1110 CALL EXPRES (EXPR,IVL,IVH,ER,FLG) 108 CALL FLGCK (ER,FLG) 109 1120 IF (IVH.EQ.0) GO TO 1130 110 IVH=0 111 CALL OVFERR 112 1130 IF (ITYP.EQ.3) IMAX=14 113 IF (ITYP.EQ.4) IMAX=15 114 IF (ITYP.EQ.15) IMAX=7 115 IF (ITYP.EQ.16) GO TO 1150 116 IF(IVL.LE.IMAX) GO TO 1140 117 1135 IVL=0 118 CALL OVFERR 119 1140 I1=OVAL(INO)+IVL 120 GO TO 1490 121 1150 IF ((IVL.NE.1).AND.(IVL.NE.4)) GO TO 1135 122 IF (IVL.EQ.1) IVL=2 123 GO TO 1140 124 C TYPE 5 -DC 125 1160 CALL GETFLD (IMAGE,I,EXPR,32,ER) 126 IF (.NOT.ER) GO TO 1180 127 IF (PASS2) CALL SCERR(3) 128 I1=0 129 I2=0 130 1170 IBCT=2 131 GO TO 1490 132 1180 DO 2000 J=2,31 133 IF (EXPR(J).EQ.KKO) GO TO 2010 134 2000 CONTINUE 135 J=1 136 ICNT=1 137 GO TO 1185 138 2010 EXPR(J)=KBK 139 J=J+1 140 CALL EXPRES (EXPR,IVL,IVH,ER,FLG) 141 IF (PASS2) GO TO 2020 142 IBCT=IVL 143 GO TO 1490 144 2020 CALL FLGCK (ER,FLG) 145 ICNT=IVL 146 IF (IVH.NE.0) CALL OVFERR 147 IF (ICNT.EQ.2) GO TO 1185 148 IF (ICNT.EQ.1) GO TO 1195 149 IF (EXPR(J).EQ.4.AND.EXPR(J+1).EQ.KAP) GO TO 2050 150 CALL EXPRES(EXPR(J),IVL,IVH,ER,FLG) 151 CALL FLGCK (ER,FLG) 152 IF (IVH.NE.0.AND.IVH.NE.255) CALL OVFERR 153 IBCT=3 154 I1=IVL 155 I2=I1 156 I3=I1 157 IFN=80 158 2030 IF (PNCHF) CALL OUTP(IBCT,I1,I2,I3) 159 IF (PRNTF.OR.ERF) CALL LIST (IBCT,I1,I2,I3,IMAGE) 160 DO 2040 I=1,IFN 161 2040 IMAGE (I)=LBK 162 IFN=1 163 LOCL=LOCL+IBCT 164 CALL M256(LOCL,LOCH) 165 ICNT=ICNT-IBCT 166 I2=I3 167 I1=I3 168 IF (ICNT.GT.3) GO TO 2030 169 2045 IBCT=ICNT 170 GO TO 1490 171 2050 IFN=80 172 J=J+2 173 IBCT=3 174 2070 IF (ICNT.LT.3) IBCT=ICNT 175 I1=I3 176 I2=I3 177 IF (EXPR(J).EQ.KAP) GO TO 2030 178 I1=IASCI(EXPR(J)) 179 I2=I1 180 I3=I2 181 IF (EXPR(J+1).EQ.KAP) GO TO 2030 182 I2=IASCI (EXPR(J+1)) 183 I3=I2 184 IF (EXPR(J+2).EQ.KAP) GO TO 2030 185 I3=IASCI(EXPR(J+2)) 186 J=J+3 187 IF (ICNT.LE.3) GO TO 1490 188 IF (J.GT.30) GO TO 2030 189 ICNT=ICNT-IBCT 190 IF (PRNTF.OR.ERF) CALL LIST(IBCT,I1,I2,I3,IMAGE) 191 IF (PNCHF) CALL OUTP(IBCT,I1,I2,I3) 192 DO 2060 I=1,IFN 193 2060 IMAGE(I)=LBK 194 IFN=1 195 LOCL=LOCL+IBCT 196 CALL M256(LOCL,LOCH) 197 GO TO 2070 198 1185 CALL EXPRES(EXPR(J),IVL,IVH,ER,FLG) 199 IF (PASS2) CALL FLGCK (ER,FLG) 200 IF (IVH.NE.0.AND.IVH.NE.255.OR.ICNT.EQ.2) GO TO 1190 201 1187 I1=IVL 202 IBCT=1 203 GO TO 1490 204 1190 I1=IVH 205 I2=IVL 206 GO TO 1170 207 1195 CALL EXPRES (EXPR(J),IVL,IVH,ER,FLG) 208 CALL FLGCK(ER,FLG) 209 IF (IVH.NE.0.AND.IVH.NE.255) CALL OVFERR 210 GO TO 1187 211 C TYPE 6,7,8,9 TWO BYTE 212 1200 IBCT=2 213 IF (.NOT.PASS2) GO TO 1490 214 I1=OVAL(INO) 215 CALL GETFLD (IMAGE,I,EXPR,32,ER) 216 IF (.NOT.ER) GO TO 1220 217 CALL SCERR (3) 218 1210 I2=0 219 GO TO 1490 220 1220 IF ((ITYP.NE.6).AND.(ITYP.NE.7)) GO TO 1270 221 J=1 222 1230 CALL EXPRES (EXPR(J),IVL,IVH,ER,FLG) 223 CALL FLGCK (ER,FLG) 224 IF (ITYP.NE.6) GO TO 1260 225 1240 IF ((IVH.EQ.0).OR.(IVH.EQ.255)) GO TO 1250 226 CALL OVFERR 227 IVH=0 228 1250 I2=IVL 229 GO TO 1490 230 1260 IVL=IVL-LOCL-1 231 IVH=IVH-LOCH 232 CALL M256(IVL,IVH) 233 IF (IVL.GT.127.AND.IVH.NE.255) CALL OVFERR 234 IF (IVL.LT.128.AND.IVH.NE.0) CALL OVFERR 235 GO TO 1250 236 C BF OR BT -FIND THE COMMA 237 1270 DO 1280 J=2,31 2371 IF (EXPR(J).EQ.KKO) GO TO 1290 238 1280 CONTINUE 239 CALL SCERR(3) 240 GO TO 1210 241 1290 EXPR(J)=KBK 242 J=J+1 243 CALL EXPRES(EXPR,IVL,IVH,ER,FLG) 244 CALL FLGCK (ER,FLG) 245 IF ((IVH.EQ.0).OR.(IVH.EQ.255)) GO TO 1300 246 CALL OVFERR 247 IVH=0 248 1300 IMAX=15 249 IF (ITYP.EQ.8) IMAX=7 250 IF (IVL.LE.IMAX) GO TO 1310 251 CALL OVFERR 252 IVL=0 253 1310 I1=I1+IVL 254 GO TO 1230 255 C TYPE 10 -3BYTE 256 1320 IBCT=3 257 IF (.NOT.PASS2) GO TO 1490 258 I1=OVAL(INO) 259 CALL GETFLD (IMAGE,I,EXPR,32,ER) 260 IF (.NOT.ER) GO TO 1330 261 CALL SCERR(3) 262 I2=0 263 I3=0 264 GO TO 1490 265 1330 CALL EXPRES(EXPR,IVL,IVH,ER,FLG) 266 CALL FLGCK (ER,FLG) 267 I2=IVH 268 I3=IVL 269 GO TO 1490 270 C TYPE 11 -ORG 271 1340 IBCT=0 272 CALL GETFLD (IMAGE,I,EXPR,32,ER) 273 IF (.NOT.ER) GO TO 1350 274 CALL SCERR(3) 275 GO TO 1490 276 1350 CALL EXPRES (EXPR,IVL,IVH,ER,FLG) 277 IF (PASS2) CALL FLGCK(ER,FLG) 278 LOCH=IVH 279 LOCL=IVL 280 IF (PASS2.AND.PNCHF) CALL PHDR 281 GO TO 1490 282 C TYPE 12 -EQU 283 1360 IBCT=0 284 CALL GETFLD(IMAGE,I,EXPR,32,ER) 285 IF (.NOT.ER.AND.LAB) GO TO 1370 286 CALL SCERR(3) 287 LAB=.FALSE. 288 GO TO 1510 289 1370 CALL EXPRES (EXPR,IVL,IVH,ER,FLG) 290 IF (PASS2) CALL FLGCK(ER,FLG) 291 IF (SFLG(INS).EQ.2) GO TO 1375 292 SVALL(INS)=IVL 293 SVALH(INS)=IVH 294 SFLG(INS)=1 295 GO TO 1510 296 1375 IF (PASS2) CALL PHERR 297 GO TO 1510 298 C TYPE 13 -MISC PSUEDO-OPS 299 1380 CONTINUE 300 C EJECT 301 IF (INO.NE.27) GO TO 1390 302 IF (PRNTF.AND.PASS2) CALL TOFM 303 GO TO 1010 304 C TITLE 305 1390 IF (INO.NE.58) GO TO 1420 306 J=1 307 DO 1400 K=I,80 308 HDR(J)=IMAGE(K) 309 1400 J=J+1 310 DO 1410 K=J,80 311 1410 HDR(K)=LBK 312 GO TO 1510 313 C PRINT AND PUNCH 314 1420 CALL GETFLD(IMAGE,I,FIELD,6,ER) 315 IF (.NOT.ER) GO TO 1430 316 1425 IF (PASS2) CALL SCERR(3) 317 GO TO 1510 318 1430 IF (FIELD(1).NE.KO) GO TO 1425 319 IF (FIELD(2).EQ.KF) GO TO 1440 320 FLAG=.TRUE. 321 GO TO 1450 322 1440 FLAG=.FALSE. 323 1450 IF (INO.NE.54) GO TO 1460 324 PNCHF=FLAG 325 GO TO 1510 326 1460 PRNTF=FLAG 327 GO TO 1510 328 C TYPE 14 -END 329 1470 IF (PASS2) GO TO 1480 330 PASS2=.TRUE. 331 IF (.NOT.OF) GO TO 1000 332 ENDFILE OC 333 REWIND OC 334 IC=OC 335 GO TO 1000 336 1480 IF (PRNTF) WRITE (PR,3) 337 3 FORMAT (14X,3HEND) 338 WRITE (PR,4) IERC 339 4 FORMAT (18H NUMBER OF ERRORS=,I3) 340 IF (PNCHF) CALL OFINIS 341 IF (PRNTF) CALL SYMLST 342 CALL EXIT 343 C FIX LABEL VALUE IF NECESSARY 344 1490 IF (.NOT.LAB) GO TO 1510 345 IF (SFLG(INS).NE.0) GO TO 1500 346 SVALL(INS)=LABL 347 SVALH(INS)=LABH 348 SFLG(INS)=2 349 1500 IF (SVALL(INS).EQ.LABL.AND.SVALH(INS).EQ.LABH) GO TO 1510 350 SFLG(INS)=4 351 CALL PHERR 352 C LINE ASSEMBLED,DO LISTING AND OUTPUT AS NEEDED 353 1510 IF (.NOT.PASS2) GO TO 1520 354 IF (PRNTF.OR.ERF) CALL LIST(IBCT,I1,I2,I3,IMAGE) 355 IF (PNCHF) CALL OUTP(IBCT,I1,I2,I3) 356 1520 LOCL=LOCL+IBCT 357 CALL M256 (LOCL,LOCH) 358 GO TO 1010 359 END 360 BLOCK DATA 361 COMMON /HDG/HDR(80),PAGE,LINE 362 INTEGER HDR,PAGE 363 COMMON /LETTRS/LETAB(64) 364 COMMON/DELIMS/KBK,KPL,KMI,KAP,KKO 365 INTEGER OP12,OP34,OP56,OVAL,OTYP 366 COMMON /OPTAB/OP12(63),OP34(63),OP56(63),OVAL(63),OTYP(63) 367 DATA HDR/80*1H /,PAGE/0/ 368 DATA LETAB/2H ,2HA ,2HB ,2HC ,2HD ,2HE ,2HF ,2HG ,2HH ,2HI ,2HJ , 369 X2HK ,2HL ,2HM ,2HN ,2HO ,2HP ,2HQ ,2HR ,2HS ,2HT ,2HU ,2HV ,2HW , 370 X2HX ,2HY ,2HZ ,2H0 ,2H1 ,2H2 ,2H3 ,2H4 ,2H5 ,2H6 ,2H7 ,2H8 ,2H9 , 371 X2H! ,2H" ,2H# ,2H$ ,2H% ,2H& ,2H' ,2H( ,2H) ,2H* ,2H+ ,2H, ,2H- , 372 X2H. ,2H/ ,2H: ,2H; ,2H< ,2H= ,2H> ,2H? ,2H@ ,2H[ ,2H] ,2H^ ,2H_ , 373 X2H\ / 374 DATA KBK/1/,KAP/44/,KPL/48/,KMI/50/,KKO/49/ 375 DATA OP12(63)/32767/ 376 C ADC 377 DATA OP12( 1)/ 261/,OP34( 1)/ 513/,OP56( 1)/ 129/, 378 X OVAL( 1)/ 142/,OTYP( 1)/ 2/ 379 C AI 380 DATA OP12( 2)/ 266/,OP34( 2)/ 129/,OP56( 2)/ 129/, 381 X OVAL( 2)/ 36/,OTYP( 2)/ 6/ 382 C AM 383 DATA OP12( 3)/ 270/,OP34( 3)/ 129/,OP56( 3)/ 129/, 384 X OVAL( 3)/ 136/,OTYP( 3)/ 2/ 385 C AMD 386 DATA OP12( 4)/ 270/,OP34( 4)/ 641/,OP56( 4)/ 129/, 387 X OVAL( 4)/ 137/,OTYP( 4)/ 2/ 388 C AS 389 DATA OP12( 5)/ 276/,OP34( 5)/ 129/,OP56( 5)/ 129/, 390 X OVAL( 5)/ 192/,OTYP( 5)/ 3/ 391 C ASD 392 DATA OP12( 6)/ 276/,OP34( 6)/ 641/,OP56( 6)/ 129/, 393 X OVAL( 6)/ 208/,OTYP( 6)/ 3/ 394 C BC 395 DATA OP12( 7)/ 388/,OP34( 7)/ 129/,OP56( 7)/ 129/, 396 X OVAL( 7)/ 130/,OTYP( 7)/ 7/ 397 C BF 398 DATA OP12( 8)/ 391/,OP34( 8)/ 129/,OP56( 8)/ 129/, 399 X OVAL( 8)/ 144/,OTYP( 8)/ 9/ 400 C BM 401 DATA OP12( 9)/ 398/,OP34( 9)/ 129/,OP56( 9)/ 129/, 402 X OVAL( 9)/ 145/,OTYP( 9)/ 7/ 403 C BNC 404 DATA OP12(10)/ 399/,OP34(10)/ 513/,OP56(10)/ 129/, 405 X OVAL(10)/ 146/,OTYP(10)/ 7/ 406 C BNO 407 DATA OP12(11)/ 399/,OP34(11)/2049/,OP56(11)/ 129/, 408 X OVAL(11)/ 152/,OTYP(11)/ 7/ 409 C BNZ 410 DATA OP12(12)/ 399/,OP34(12)/3457/,OP56(12)/ 129/, 411 X OVAL(12)/ 148/,OTYP(12)/ 7/ 412 C BP 413 DATA OP12(13)/ 401/,OP34(13)/ 129/,OP56(13)/ 129/, 414 X OVAL(13)/ 129/,OTYP(13)/ 7/ 415 C BR 416 DATA OP12(14)/ 403/,OP34(14)/ 129/,OP56(14)/ 129/, 417 X OVAL(14)/ 144/,OTYP(14)/ 7/ 418 C BR7 419 DATA OP12(15)/ 403/,OP34(15)/4481/,OP56(15)/ 129/, 420 X OVAL(15)/ 143/,OTYP(15)/ 7/ 421 C BT 422 DATA OP12(16)/ 405/,OP34(16)/ 129/,OP56(16)/ 129/, 423 X OVAL(16)/ 128/,OTYP(16)/ 8/ 424 C BZ 425 DATA OP12(17)/ 411/,OP34(17)/ 129/,OP56(17)/ 129/, 426 X OVAL(17)/ 132/,OTYP(17)/ 7/ 427 C CI 428 DATA OP12(18)/ 522/,OP34(18)/ 129/,OP56(18)/ 129/, 429 X OVAL(18)/ 37/,OTYP(18)/ 6/ 430 C CLR 431 DATA OP12(19)/ 525/,OP34(19)/2433/,OP56(19)/ 129/, 432 X OVAL(19)/ 112/,OTYP(19)/ 2/ 433 C CM 434 DATA OP12(20)/ 526/,OP34(20)/ 129/,OP56(20)/ 129/, 435 X OVAL(20)/ 141/,OTYP(20)/ 2/ 436 C COM 437 DATA OP12(21)/ 528/,OP34(21)/1793/,OP56(21)/ 129/, 438 X OVAL(21)/ 24/,OTYP(21)/ 2/ 439 C DC 440 DATA OP12(22)/ 644/,OP34(22)/ 129/,OP56(22)/ 129/, 441 X OVAL(22)/ 0/,OTYP(22)/ 5/ 442 C DCI 443 DATA OP12(23)/ 644/,OP34(23)/1281/,OP56(23)/ 129/, 444 X OVAL(23)/ 42/,OTYP(23)/ 10/ 445 C DI 446 DATA OP12(24)/ 650/,OP34(24)/ 129/,OP56(24)/ 129/, 447 X OVAL(24)/ 26/,OTYP(24)/ 2/ 448 C DS 449 DATA OP12(25)/ 660/,OP34(25)/ 129/,OP56(25)/ 129/, 450 X OVAL(25)/ 48/,OTYP(25)/ 3/ 451 C EI 452 DATA OP12(26)/ 778/,OP34(26)/ 129/,OP56(26)/ 129/, 453 X OVAL(26)/ 27/,OTYP(26)/ 2/ 454 C EJECT 455 DATA OP12(27)/ 779/,OP34(27)/ 772/,OP56(27)/2689/, 456 X OVAL(27)/ 0/,OTYP(27)/ 13/ 457 C END 458 DATA OP12(28)/ 783/,OP34(28)/ 641/,OP56(28)/ 129/, 459 X OVAL(28)/ 0/,OTYP(28)/ 14/ 460 C EQU 461 DATA OP12(29)/ 786/,OP34(29)/2817/,OP56(29)/ 129/, 462 X OVAL(29)/ 0/,OTYP(29)/ 12/ 463 C IN 464 DATA OP12(30)/1295/,OP34(30)/ 129/,OP56(30)/ 129/, 465 X OVAL(30)/ 38/,OTYP(30)/ 6/ 466 C INC 467 DATA OP12(31)/1295/,OP34(31)/ 513/,OP56(31)/ 129/, 468 X OVAL(31)/ 31/,OTYP(31)/ 2/ 469 C INS 470 DATA OP12(32)/1295/,OP34(32)/2561/,OP56(32)/ 129/, 471 X OVAL(32)/ 160/,OTYP(32)/ 4/ 472 C JMP 473 DATA OP12(33)/1422/,OP34(33)/2177/,OP56(33)/ 129/, 474 X OVAL(33)/ 41/,OTYP(33)/ 10/ 475 C LI 476 DATA OP12(34)/1674/,OP34(34)/ 129/,OP56(34)/ 129/, 477 X OVAL(34)/ 32/,OTYP(34)/ 6/ 478 C LIS 479 DATA OP12(35)/1674/,OP34(35)/2561/,OP56(35)/ 129/, 480 X OVAL(35)/ 112/,OTYP(35)/ 4/ 481 C LISL 482 DATA OP12(36)/1674/,OP34(36)/2573/,OP56(36)/ 129/, 483 X OVAL(36)/ 104/,OTYP(36)/ 15/ 484 C LISU 485 DATA OP12(37)/1674/,OP34(37)/2582/,OP56(37)/ 129/, 486 X OVAL(37)/ 96/,OTYP(37)/ 15/ 487 C LM 488 DATA OP12(38)/1678/,OP34(38)/ 129/,OP56(38)/ 129/, 489 X OVAL(38)/ 22/,OTYP(38)/ 2/ 490 C LNK 491 DATA OP12(39)/1679/,OP34(39)/1537/,OP56(39)/ 129/, 492 X OVAL(39)/ 25/,OTYP(39)/ 2/ 493 C LR 494 DATA OP12(40)/1683/,OP34(40)/ 129/,OP56(40)/ 129/, 495 X OVAL(40)/ 0/,OTYP(40)/ 1/ 496 C NI 497 DATA OP12(41)/1930/,OP34(41)/ 129/,OP56(41)/ 129/, 498 X OVAL(41)/ 33/,OTYP(41)/ 6/ 499 C NM 500 DATA OP12(42)/1934/,OP34(42)/ 129/,OP56(42)/ 129/, 501 X OVAL(42)/ 138/,OTYP(42)/ 2/ 502 C NOP 503 DATA OP12(43)/1936/,OP34(43)/2177/,OP56(43)/ 129/, 504 X OVAL(43)/ 43/,OTYP(43)/ 2/ 505 C NS 506 DATA OP12(44)/1940/,OP34(44)/ 129/,OP56(44)/ 129/, 507 X OVAL(44)/ 240/,OTYP(44)/ 3/ 508 C OI 509 DATA OP12(45)/2058/,OP34(45)/ 129/,OP56(45)/ 129/, 510 X OVAL(45)/ 34/,OTYP(45)/ 6/ 511 C OM 512 DATA OP12(46)/2062/,OP34(46)/ 129/,OP56(46)/ 129/, 513 X OVAL(46)/ 139/,OTYP(46)/ 2/ 514 C ORG 515 DATA OP12(47)/2067/,OP34(47)/1025/,OP56(47)/ 129/, 516 X OVAL(47)/ 0/,OTYP(47)/ 11/ 517 C OUT 518 DATA OP12(48)/2070/,OP34(48)/2689/,OP56(48)/ 129/, 519 X OVAL(48)/ 39/,OTYP(48)/ 6/ 520 C OUTS 521 DATA OP12(49)/2070/,OP34(49)/2708/,OP56(49)/ 129/, 522 X OVAL(49)/ 176/,OTYP(49)/ 4/ 523 C PI 524 DATA OP12(50)/2186/,OP34(50)/ 129/,OP56(50)/ 129/, 525 X OVAL(50)/ 40/,OTYP(50)/ 10/ 526 C PK 527 DATA OP12(51)/2188/,OP34(51)/ 129/,OP56(51)/ 129/, 528 X OVAL(51)/ 12/,OTYP(51)/ 2/ 529 C POP 530 DATA OP12(52)/2192/,OP34(52)/2177/,OP56(52)/ 129/, 531 X OVAL(52)/ 28/,OTYP(52)/ 2/ 532 C PRINT 533 DATA OP12(53)/2195/,OP34(53)/1295/,OP56(53)/2689/, 534 X OVAL(53)/ 0/,OTYP(53)/ 13/ 535 C PUNCH 536 DATA OP12(54)/2198/,OP34(54)/1924/,OP56(54)/1153/, 537 X OVAL(54)/ 0/,OTYP(54)/ 13/ 538 C SL 539 DATA OP12(55)/2573/,OP34(55)/ 129/,OP56(55)/ 129/, 540 X OVAL(55)/ 17/,OTYP(55)/ 16/ 541 DATA OP12(56)/2579/,OP34(56)/ 129/,OP56(56)/ 129/, 542 X OVAL(56)/ 16/,OTYP(56)/ 16/ 543 C ST 544 DATA OP12(57)/2581/,OP34(57)/ 129/,OP56(57)/ 129/, 545 X OVAL(57)/ 23/,OTYP(57)/ 2/ 546 C TITLE 547 DATA OP12(58)/2698/,OP34(58)/2701/,OP56(58)/ 769/, 548 X OVAL(58)/ 0/,OTYP(58)/ 13/ 549 C XDC 550 DATA OP12(59)/3205/,OP34(59)/ 513/,OP56(59)/ 129/, 551 X OVAL(59)/ 44/,OTYP(59)/ 2/ 552 C XI 553 DATA OP12(60)/3210/,OP34(60)/ 129/,OP56(60)/ 129/, 554 X OVAL(60)/ 35/,OTYP(60)/ 6/ 555 C XM 556 DATA OP12(61)/3214/,OP34(61)/ 129/,OP56(61)/ 129/, 557 X OVAL(61)/ 140/,OTYP(61)/ 2/ 558 C XS 559 DATA OP12(62)/3220/,OP34(62)/ 129/,OP56(62)/ 129/, 560 X OVAL(62)/ 224/,OTYP(62)/ 3/ 561 END 562 INTEGER FUNCTION IASCI(K) 563 IF (K.EQ.1) IASCI=32 564 IF (K.GT.1.AND.K.LT.28) IASCI=K+63 565 IF (K.GT.27.AND.K.LT.38) IASCI=K+20 566 IF (K.GT.37.AND.K.LT.53) IASCI=K-5 567 IF (K.GT.52.AND.K.LT.60) IASCI=K+5 568 IF (K.GT.59) IASCI=K+31 569 RETURN 570 END 571 SUBROUTINE EVAL (S,VL,VH,ERC,FLG) 572 INTEGER S,VL,VH,FLG,BA,R1,R3,VT 573 INTEGER CH12,CH34,CH56,SVALL,SVALH,SFLG 574 COMMON /SYMTAB/CH12(500),CH34(500),CH56(500),SVALL(500),SVALH(500) 575 X,SFLG(500) 576 COMMON /LETTRS/LETAB(64) 577 COMMON/LOC/LOCL,LOCH 578 LOGICAL ERC,TFLG 579 LOGICAL BFLG 580 DIMENSION S(18) 581 DATA KST/47/,KAP/44/,KBK/1/,KD/5/,KH/9/,KO/16/,KB/3/,KC/4/,KT/21/, 582 XKA/2/,KE/6/,KF/7/,K0/28/,K1/29/,K2/30/,K3/31/,K4/32/,K5/33/,K6/34/ 583 X,K7/35/,K8/36/,K9/37/ 584 DATA KLN/53/ 585 DATA KPD/51/ 586 BFLG=.FALSE. 587 TFLG=.FALSE. 588 DO 100 I=1,18 589 IF (S(I).EQ.KLN) GO TO 110 590 IF (S(I).EQ.KBK) GO TO 120 591 IF (S(I).EQ.KPD) GO TO 105 592 100 CONTINUE 593 GO TO 120 594 105 BFLG=.TRUE. 595 110 TFLG=.TRUE. 596 IF (S(1).NE.KC.OR.S(2).NE.KAP) S(I)=KBK 597 120 ERC=.FALSE. 598 FLG=1 599 I=1 600 VL=0 601 VH=0 602 IF (S(1).EQ.KBK) RETURN 603 IF (S(1).EQ.KST) GO TO 500 604 IF (S(1).GE.K0) GO TO 300 605 IF (S(2).NE.KAP) GO TO 400 606 I=3 607 IF (S(1).NE.KD) GO TO 10 608 300 BA=10 609 GO TO 310 610 10 IF (S(1).NE.KH) GO TO 20 611 BA=16 612 GO TO 310 613 20 IF (S(1).NE.KO) GO TO 30 614 BA=8 615 GO TO 310 616 30 IF (S(1).NE.KB) GO TO 40 617 BA=2 618 GO TO 310 619 40 IF (S(1).NE.KC) GO TO 50 620 VH=0 621 45 VL=IASCI(S(I)) 622 I=I+1 623 IF (S(I).EQ.KAP) RETURN 624 IF (I.GT.4) GO TO 50 625 VH=VL 626 GO TO 45 627 50 CONTINUE 628 60 ERC=.TRUE. 629 RETURN 630 310 R1=BA-9 631 IF (R1.LT.0) R1=0 632 R3=BA+27 633 IF (R3.GT.37)R3=37 634 ERC=.FALSE. 635 VL=0 636 VH=0 637 320 IF ((S(I).EQ.KAP).OR.(S(I).EQ.KBK)) GO TO 350 638 IF (S(I).GT.R1) GO TO 330 639 IC=S(I)+8 640 GO TO 340 641 330 IF ((S(I).LT.K0).OR.(S(I).GT.R3)) GO TO 60 642 IC=S(I)-K0 643 340 VL=VL*BA+IC 644 VH=VH*BA 645 CALL M256(VL,VH) 646 I=I+1 647 GO TO 320 648 350 IF (.NOT.TFLG) RETURN 649 IF (.NOT.BFLG) VL=VH 650 VH=0 651 RETURN 652 400 CALL HASH (S,VT) 653 IF (VT.EQ.0) GO TO 60 654 VL=SVALL(VT) 655 VH=SVALH(VT) 656 FLG=SFLG(VT) 657 GO TO 350 658 500 VL=LOCL 659 VH=LOCH 660 GO TO 350 661 END 662 SUBROUTINE M256(IL,IH) 663 C MAINTAINS 2 8-BIT VALUES IN 16 BIT 2'S COMPLEMENT FORM 664 IM=MOD(IL,256) 665 IC=IL/256 666 IL=MOD((IM+256),256) 667 IF (IM.LT.0) IC=IC+255 668 IH=MOD((IH+IC+256),256) 669 RETURN 670 END 671 SUBROUTINE LIST (IBCT,I1,I2,I3,IMAGE) 672 DIMENSION IMAGE(80) 673 COMMON /HDG/HDR(80),PAGE,LINE /DEV/IC,OC,PR,PU /ERCT/IERC,ERF 674 INTEGER HDR,PAGE,OC,PR,PU,IOL(10) 675 LOGICAL ERF 676 COMMON /LOC/LOCL,LOCH /LETTRS/LETAB(64) 677 EQUIVALENCE(LETAB(1),LBK) 678 IF (ERF) LINE=LINE+1 679 ERF=.FALSE. 680 LINE=LINE+1 681 IF (LINE.GT.54) CALL TOFM 682 DO 10 I=1,10 683 10 IOL(I)=LBK 684 IK=IBCT+1 685 GO TO (100,200,300,400),IK 686 400 CALL HXOUT (I3,IOL(9),IOL(10),IDUM) 687 300 CALL HXOUT (I2,IOL(7),IOL(8),IDUM) 688 200 CALL HXOUT (I1,IOL(5),IOL(6),IDUM) 689 CALL HXOUT (LOCL,IOL(3),IOL(4),IDUM) 690 CALL HXOUT (LOCH,IOL(1),IOL(2),IDUM) 691 100 WRITE (PR,1) IOL,IMAGE 692 1 FORMAT (1H ,4A1,3(1X,2A1),1X,80A1) 693 RETURN 694 END 695 SUBROUTINE LABERR 696 COMMON /DEV/IC,OC,PR,PU /ERCT/IERC,ERF 697 INTEGER OC,PR,PU 698 LOGICAL ERF 699 IERC=IERC+1 700 ERF=.TRUE. 701 WRITE (PR,1) 702 1 FORMAT (19H **SYMBOL AREA FULL) 703 RETURN 704 END 705 SUBROUTINE EXPRES (F,VL,VH,ERC,FLG) 706 LOGICAL KFG 707 LOGICAL ERC 708 INTEGER F(32),S(18),PROP,OPS,CVL,CVH,VL,VH,FLG,VT 709 COMMON /DELIMS/OPS(3),IG(2) 710 KFG=.TRUE. 711 VL=0 712 VH=0 713 PROP=2 714 I=1 715 5 DO 10 J=1,18 716 10 S(J)=OPS(1) 717 J=1 718 15 DO 20 K=1,3 719 IF (F(I).EQ.IG(1)) KFG=.NOT.KFG 720 IF (.NOT.KFG) GO TO 20 721 IF (F(I).EQ.OPS(K)) GO TO 100 722 20 CONTINUE 723 S(J)=F(I) 724 J=J+1 725 IF (J.GT.18) GO TO 150 726 I=I+1 727 IF (I.GT.32) GO TO 150 728 GO TO 15 729 100 CALL EVAL (S,CVL,CVH,ERC,FLG) 730 IF ((FLG.EQ.0).OR.(FLG.EQ.4).OR.ERC) GO TO 145 731 GO TO (145,110,120),PROP 732 120 CVL=-CVL 733 CVH=-CVH 734 CALL M256 (CVL,CVH) 735 110 VL=VL+CVL 736 VH=VH+CVH 737 CALL M256(VL,VH) 738 PROP=K 739 I=I+1 740 IF (K.GT.1) GO TO 5 741 145 RETURN 742 150 ERC=.TRUE. 743 RETURN 744 END 745 SUBROUTINE PHDR 746 COMMON /BUFFER/IOPB(16),KB,ICK /DEV/IC,OC,PR,PU 747 X/LOC/LOCL,LOCH 748 INTEGER OC,PR,PU,SBLK(4) 749 IF (KB.EQ.0) KB=1 750 IF (KB.GT.1) CALL OUTPP 751 CALL HXOUT (LOCH,SBLK(1),SBLK(2),IDUM) 752 CALL HXOUT (LOCL,SBLK(3),SBLK(4),IDUM) 753 WRITE (PU,1) SBLK 754 1 FORMAT (1HS,4A1) 755 RETURN 756 END 757 SUBROUTINE OUTPP 758 INTEGER HEX 759 C OUTPUTS A LINE OF PUNCH DATA 760 COMMON /BUFFER/IOPB(16),KB,ICK /DEV/IC,OC,PR,PU /LETTRS/LETAB(64) 761 EQUIVALENCE (L0,LETAB(28)) 762 INTEGER OC,PR,PU 763 ICK=HEX(ICK) 764 WRITE (PU,1) IOPB,ICK 765 1 FORMAT (1HX,16A1,A1) 766 DO 100 I=1,16 767 100 IOPB(I)=L0 768 ICK=0 769 KB=1 770 RETURN 771 END 772 SUBROUTINE OFINIS 773 COMMON /BUFFER/IOPB(16),KB,ICK /DEV/IC,OC,PR,PU 774 INTEGER OC,PR,PU 775 IF (KB.GT.1) CALL OUTPP 776 WRITE (PU,1) 777 1 FORMAT (1H*) 778 RETURN 779 END 780 SUBROUTINE SYMLST 781 C PRINTS SYMBOL TABLE 782 INTEGER CH12,CH34,CH56,SVALL,SVALH,OC,PR,PU,SFLG,KO(72) 783 COMMON /SYMTAB/CH12(500),CH34(500),CH56(500),SVALL(500),SVALH(500) 784 X,SFLG(500) 785 COMMON /LETTRS/LETAB(64) 786 COMMON /DEV/IC,OC,PR,PU 787 WRITE (PR,1) 788 1 FORMAT (1H1) 789 40 DO 50 I=1,72 790 50 KO(I)=LETAB(1) 791 K=1 792 75 DO 100 J=1,500 793 IF (CH12(J).NE.0) GO TO 110 794 100 CONTINUE 795 GO TO 170 796 110 DO 120 I=1,500 797 IF (CH12(I).EQ.0) GO TO 120 798 116 IF (CH12(I)-CH12(J)) 119,117,120 799 117 IF (CH34(I)-CH34(J)) 119,118,120 800 118 IF (CH56(I)-CH56(J)) 119,119,120 801 119 J=I 802 120 CONTINUE 803 GO TO 150 804 150 CALL UNPAK(CH12(J),KO(K)) 805 CALL UNPAK(CH34(J),KO(K+2)) 806 CALL UNPAK(CH56(J),KO(K+4)) 807 IF (SFLG(J).EQ.1) KO(K+6)=LETAB(56) 808 CALL HXOUT(SVALH(J),KO(K+7),KO(K+8),IDUM) 809 CALL HXOUT(SVALL(J),KO(K+9),KO(K+10),IDUM) 810 N=K+5 811 CH12(J)=0 812 DO 160 M=K,N 813 IK=KO(M) 814 160 KO(M)=LETAB(IK) 815 K=K+12 816 IF (K.LT.73) GO TO 75 817 WRITE (PR,2) KO 818 2 FORMAT (1H ,72A1) 819 GO TO 40 820 170 WRITE (PR,2) KO 823 RETURN 824 END 825 SUBROUTINE OPSRCH(S,I) 826 C RETURNS INDEX TO OP TABLE 827 INTEGER S(6),OP12,OP34,OP56,OTYP,OVAL 828 COMMON /OPTAB/OP12(63),OP34(63),OP56(63),OVAL(63),OTYP(63) 829 DIMENSION IC(6) 830 DATA IC/16,8,4,2,1,0/ 831 I12=IPAK(S) 832 I34=IPAK(S(3)) 833 I56=IPAK(S(5)) 834 I=32 835 DO 200 K=1,6 836 IF (I12-OP12(I)) 100,50,110 837 50 IF (I34-OP34(I)) 100,60,110 838 60 IF (I56-OP56(I)) 100,400,110 839 100 I=I-IC(K) 840 GO TO 200 841 110 I=I+IC(K) 842 200 CONTINUE 843 I=0 844 400 RETURN 845 END 846 SUBROUTINE LR(IN,I,IV) 847 C PROCESSES LR OPCODE 848 INTEGER FLG 849 LOGICAL ER 850 INTEGER LR12(25),LR34(25),LRVL(25),EXPR(32),IN(80) 851 COMMON/DELIMS/KBK,KPL,KMI,KAP,KKO 852 DATA KA/2/ 853 C A,D 854 DATA LR12( 1)/ 305/,LR34( 1)/ 641/,LRVL( 1)/ 78/ 855 C A,I 856 DATA LR12( 2)/ 305/,LR34( 2)/1281/,LRVL( 2)/ 77/ 857 C A,IS 858 DATA LR12( 3)/ 305/,LR34( 3)/1300/,LRVL( 3)/ 10/ 859 C A,KL 860 DATA LR12( 4)/ 305/,LR34( 4)/1549/,LRVL( 4)/ 1/ 861 C A,KU 862 DATA LR12( 5)/ 305/,LR34( 5)/1558/,LRVL( 5)/ 0/ 863 C A,QL 864 DATA LR12( 6)/ 305/,LR34( 6)/2317/,LRVL( 6)/ 3/ 865 C A,QU 866 DATA LR12( 7)/ 305/,LR34( 7)/2326/,LRVL( 7)/ 2/ 867 C A,S 868 DATA LR12( 8)/ 305/,LR34( 8)/2561/,LRVL( 8)/ 76/ 869 C DC,H 870 DATA LR12( 9)/ 644/,LR34( 9)/6281/,LRVL( 9)/ 16/ 871 C DC,Q 872 DATA LR12(10)/ 644/,LR34(10)/6290/,LRVL(10)/ 15/ 873 C D,A 874 DATA LR12(11)/ 689/,LR34(11)/ 257/,LRVL(11)/ 94/ 875 C H,DC 876 DATA LR12(12)/1201/,LR34(12)/ 644/,LRVL(12)/ 17/ 877 C IS,A 878 DATA LR12(13)/1300/,LR34(13)/6274/,LRVL(13)/ 11/ 879 C I,A 880 DATA LR12(14)/1329/,LR34(14)/ 257/,LRVL(14)/ 93/ 881 C J,W 882 DATA LR12(15)/1457/,LR34(15)/3073/,LRVL(15)/ 30/ 883 C KL,A 884 DATA LR12(16)/1549/,LR34(16)/6274/,LRVL(16)/ 5/ 885 C KU,A 886 DATA LR12(17)/1558/,LR34(17)/6274/,LRVL(17)/ 4/ 887 C K,P 888 DATA LR12(18)/1585/,LR34(18)/2177/,LRVL(18)/ 8/ 889 C P0,Q 890 DATA LR12(19)/2204/,LR34(19)/6290/,LRVL(19)/ 13/ 891 C P,K 892 DATA LR12(20)/2225/,LR34(20)/1537/,LRVL(20)/ 9/ 893 C QL,A 894 DATA LR12(21)/2317/,LR34(21)/6274/,LRVL(21)/ 7/ 895 C QU,A 896 DATA LR12(22)/2326/,LR34(22)/6274/,LRVL(22)/ 6/ 897 C Q,DC 898 DATA LR12(23)/2353/,LR34(23)/ 644/,LRVL(23)/ 14/ 899 C S,A 900 DATA LR12(24)/2609/,LR34(24)/ 257/,LRVL(24)/ 92/ 901 C W,J 902 DATA LR12(25)/3121/,LR34(25)/1409/,LRVL(25)/ 29/ 903 IV=43 904 CALL GETFLD (IN,I,EXPR,32,ER) 905 IF (.NOT.ER) GO TO 100 906 50 CALL SCERR(3) 907 RETURN 908 100 IF (EXPR(5).NE.KBK) GO TO 200 909 IC12=IPAK(EXPR) 910 IC34=IPAK(EXPR(3)) 911 DO 110 J=1,25 912 IF (IC12.NE.LR12(J)) GO TO 110 913 IF (IC34.EQ.LR34(J)) GO TO 300 914 110 CONTINUE 915 200 IF ((EXPR(1).EQ.KA).AND.(EXPR(2).EQ.KKO)) GO TO 250 916 IV=80 917 DO 210 J=1,32 918 IF (EXPR(J).EQ.KKO) GO TO 220 919 210 CONTINUE 920 GO TO 50 921 220 EXPR(J)=KBK 922 IF (EXPR(J+1).NE.KA) GO TO 50 923 L=1 924 GO TO 260 925 250 IV=64 926 L=3 927 260 CALL EXPRES (EXPR(L),IL,IH,ER,FLG) 928 CALL FLGCK (ER,FLG) 929 IF((IH.NE.0).OR.(IL.GT.14)) GO TO 50 930 IV=IV+IL 931 RETURN 932 300 IV=LRVL(J) 933 RETURN 934 END 935 SUBROUTINE HASH(SY,IN) 936 INTEGER CH12,CH34,CH56,SFLG,SY(6),SVALL,SVALH 937 COMMON /SYMTAB/CH12(500),CH34(500),CH56(500),SVALL(500),SVALH(500) 938 X,SFLG(500) 939 I12=IPAK(SY) 940 I34=IPAK(SY(3)) 941 I56=IPAK(SY(5)) 942 IN=MOD(I12,500) 943 IN=IN+1 944 IST=IN 945 50 IF (CH12(IN).EQ.0) GO TO 200 946 IF((I12.EQ.CH12(IN)).AND.(I34.EQ.CH34(IN)).AND.(I56.EQ.CH56(IN))) 947 XRETURN 948 IN=IN+1 949 IF (IN.GT.500)IN=1 950 IF (IN.NE.IST)GO TO 50 951 IN=0 952 RETURN 953 200 CH12(IN)=I12 954 CH34(IN)=I34 955 CH56(IN)=I56 956 SVALH(IN)=0 957 SVALL(IN)=0 958 SFLG(IN)=0 959 RETURN 960 END 961 SUBROUTINE GETFLD(IN,I,OU,SZ,ER) 962 INTEGER OU,SZ,CC 963 LOGICAL LFG,ER 964 DIMENSION IN(80),OU(SZ) 965 COMMON /LETTRS/LETAB(64) 966 EQUIVALENCE (LBK,LETAB(1)),(LAP,LETAB(44)) 967 LFG=.TRUE. 968 ER=.FALSE. 969 DO 10 J=1,SZ 970 10 OU(J)=1 971 100 IF (IN(I).NE.LBK) GO TO 200 972 I=I+1 973 IF (I.LE.80) GO TO 100 974 110 ER=.TRUE. 975 RETURN 976 200 DO 300 J=1,SZ 977 OU(J)=LETTER(IN(I)) 978 IF (IN(I).EQ.LAP) LFG=.NOT.LFG 979 I=I+1 980 IF (I.GT.80) GO TO 110 981 IF (LFG.AND.(IN(I).EQ.LBK)) GO TO 310 982 300 CONTINUE 983 310 IF (IN(I).EQ.LBK) RETURN 984 I=I+1 985 IF (I.LE.80) GO TO 310 986 GO TO 110 987 END 988 SUBROUTINE OUTP(IBCT,I1,I2,I3) 989 C FILLS BUFFER WITH PUNCH OUTPUT DATA 990 COMMON /BUFFER/IOPB(16),KB,ICK 991 DIMENSION IB(3) 992 IF (IBCT.EQ.0) RETURN 993 IB(1)=I1 994 IB(2)=I2 995 IB(3)=I3 996 DO 100 I=1,IBCT 997 IF (KB.GT.16) CALL OUTPP 998 CALL HXOUT(IB(I),IOPB(KB),IOPB(KB+1),IC) 999 ICK=MOD((IC+ICK),16) 1000 100 KB=KB+2 1001 RETURN 1002 END 1003 SUBROUTINE HXOUT (I,I1,I2,ICK) 1004 INTEGER HEX 1005 C RETURNS THE 2CHARACTER REPRESENTATION OF THE 8-BIT VALUE IN I 1006 I1=I/16 1007 I2=MOD(I,16) 1008 ICK=MOD((I1+I2),16) 1009 I1=HEX(I1) 1010 I2=HEX(I2) 1011 RETURN 1012 END 1013 INTEGER FUNCTION HEX(I) 1014 INTEGER HEXTAB(16) 1015 DATA HEXTAB /1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HA,1HB,1HC, 1016 X1HD,1HE,1HF/ 1017 HEX=HEXTAB(I+1) 1018 RETURN 1019 END 1020 SUBROUTINE TOFM 1021 C EJECTS A PAGE 1022 INTEGER HDR,PAGE,OC,PR,PU 1023 COMMON /HDG/HDR(80),PAGE,LINE /DEV/IC,OC,PR,PU 1024 PAGE=PAGE+1 1025 LINE=1 1026 WRITE (PR,1) PAGE 1027 1 FORMAT ( 8H1F8X V04,30X,5HPAGE ,I3) 1028 WRITE (PR,2) HDR 1029 2 FORMAT (1H0,80A1) 1030 RETURN 1031 END 1032 SUBROUTINE FLGCK (ER,FLG) 1033 C CHECKS RESULTS OF EXPRESSION EVALUATION FOR VALIDITY 1034 COMMON /DEV/IC,OC,PR,PU /ERCT/IERC,ERF 1035 LOGICAL ER,ERF 1036 INTEGER FLG,OC,PR,PU 1037 IF (.NOT.ER) GO TO 100 1038 WRITE (PR,1) 1039 1 FORMAT (26H **BAD CONSTANT IN OPERAND) 1040 50 ERF=.TRUE. 1041 IERC=IERC+1 1042 RETURN 1043 100 IF (FLG.NE.0) GO TO 200 1044 WRITE (PR,2) 1045 2 FORMAT (30H **UNDEFINED SYMBOL IN OPERAND) 1046 GO TO 50 1047 200 IF (FLG.NE.4) RETURN 1048 WRITE (PR,3) 1049 3 FORMAT (37H **MULTIPLY DEFINED SYMBOL IN OPERAND) 1050 GO TO 50 1051 END 1052 SUBROUTINE OVFERR 1053 COMMON /DEV/IC,OC,PR,PU /ERCT/IERC,ERF 1054 INTEGER OC,PR,PU 1055 LOGICAL ERF 1056 ERF=.TRUE. 1057 IERC=IERC+1 1058 WRITE (PR,1) 1059 1 FORMAT (24H **OPERAND EXCEEDS RANGE) 1060 RETURN 1061 END 1062 SUBROUTINE OPERR 1063 COMMON /DEV/IC,OC,PR,PU /ERCT/IERC,ERF 1064 INTEGER OC,PR,PU 1065 LOGICAL ERF 1066 ERF=.TRUE. 1067 IERC=IERC+1 1068 WRITE (PR,1) 1069 1 FORMAT (19H **UNKNOWN OPERATOR) 1070 RETURN 1071 END 1072 SUBROUTINE PHERR 1073 COMMON /DEV/IC,OC,PR,PU /ERCT/IERC,ERF 1074 INTEGER OC,PR,PU 1075 LOGICAL ERF 1076 ERF=.TRUE. 1077 IERC=IERC+1 1078 WRITE (PR,1) 1079 1 FORMAT (25H **MULTIPLY DEFINED LABEL) 1080 RETURN 1081 END 1082 SUBROUTINE SCERR(J) 1083 C OUTPUTS SCAN ERROR FOR FIELD J 1084 INTEGER OC,PR,PU 1085 COMMON /DEV/IC,OC,PR,PU /ERCT/IERC,ERF 1086 LOGICAL ERF 1087 GO TO (100,200,300),J 1088 100 WRITE (PR,1) 1089 1 FORMAT (15H **LABEL SYNTAX) 1090 110 ERF=.TRUE. 1091 IERC=IERC+1 1092 RETURN 1093 200 WRITE (PR,2) 1094 2 FORMAT (18H **OPERATOR SYNTAX) 1095 GO TO 110 1096 300 WRITE (PR,3) 1097 3 FORMAT (17H **OPERAND SYNTAX) 1098 GO TO 110 1099 END 1100 INTEGER FUNCTION IPAK(K) 1101 DIMENSION K(2) 1102 IPAK=K(1)*128+K(2) 1103 RETURN 1104 END 1105 SUBROUTINE UNPAK(J,K) 1106 DIMENSION K(2) 1107 K(1)=J/128 1108 K(2)=J-K(1)*128 1109 RETURN 1110 END 1111 INTEGER FUNCTION LETTER(K) 1112 COMMON /LETTRS/LETAB(64) 1113 DO 10 I=1,64 1114 IF (K.EQ.LETAB(I)) GO TO 20 1115 10 CONTINUE 1116 I=0 1117 20 LETTER=I 1118 RETURN 1119 END 1120