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
      IERC=0
      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
      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)                                                     942
      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
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������