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   
