FTN4
      PROGRAM CMMM (3,90), 24999-16101 REV 1839  RTE M SYS MGR PROG.
C 
C 
C                  MIKE MANLEY          REVISION 2
C                                       RTE M VERSION 
C 
C 
      DIMENSION IPBUF(33),LU(5),IBUF(17),IREG(2),IMESS5(6),IDP(22)
      DIMENSION IMESS0(8),IMESS1(9),IMES11(6),IMESS3(6),IMESS7(7) 
      DIMENSION IMESS2(11),IWHAT(6),IMESS8(11),IPRAM(5),IVALU2(13)
      DIMENSION IARRAY(128),IDISC(26),IVALUE(9) 
      DIMENSION IEXT(4),ITEL22(14),ITEL23(20),ITEL24(17),ITEL25(22) 
      DIMENSION IX(8),I1(11),I2(13),I3(12),I4(9),I5(13),I6(12)
      DIMENSION I7(9),I9(14),IH(11),IJ(11),IK(9),IOUT(7)
      DIMENSION IL(12),IO(15),IP(16),IQ(17),IR(21)
      DIMENSION IN(8),IM(22),IPACK(23),MORUSE(8),ITEL30(5),ITEL31(17) 
      DIMENSION ITEL1(9),ITEL2(9),ITEL3(16),ITEL4(5),ITEL5(19),ITEL6(12)
      DIMENSION ITEL7(6),ITEL8(5),ITEL9(23),ITEL10(5),ITEL11(26)
      DIMENSION ITEL12(7),ITEL13(11),ITEL14(22),ITEL16(16)
      DIMENSION ITEL17(13),ITEL18(17),ITEL19(6),ITEL20(6),ITEL21(6) 
      DIMENSION IBEGIN(22),IGTOUT(27) 
      EQUIVALENCE(IREG,REG,IA),(IREG(2),IB) 
      EQUIVALENCE(IPBUF(2),IPRS1),(IPBUF(6),IPRS2),(IPBUF(10),IPRS3)
      EQUIVALENCE(IPBUF(14),IPRS4),(IPBUF(18),IPRS5)
C 
      DATA IMESS1/2H  ,2HID,2H S,2HEG,2H O,2HF /
      DATA IEXT/2H  ,2HEX,2HTE,2HNT/
      DATA IVALUE/2H  ,2HWO,2HRD,2H ,,2H V,2HAL,2HUE,2H  ,2H  / 
      DATA IVALU2/2H  ,2HLU,2H,T,2HRK,2H,S,2HEC,2HTR,2H,W,2HOR, 
     &            2HD,,2HVA,2HLU,2HE /
      DATA IGTOUT/2H  ,2HDI,2HSC,2H M,2HOD,2H !,2H  ,2HEN,2HTE,2HR ,
     &            2HA ,2H/D,2H A,2HT ,2HAN,2HY ,2HTI,2HME,2H T,2HO ,
     &            2HEX,2HIT,2H T,2HHI,2HS ,2HMO,2HDE/ 
      DATA IWHAT/2H  ,2HSA,2HY ,2HWH,2HAT,2H ?/ 
      DATA IMESS2/2H  ,2HEQ,2HT ,2H# ,2H  ,2H  ,2H  ,2H  ,2HDV,2HR /
      DATA IMES11/2H  ,2HNO,2HT ,2HFO,2HUN,2HD /
      DATA IMESS3/2H  ,2HDR,2HT ,2HPA,2HRT,2H  /
      DATA IMESS5/2H  ,2HIN,2HT ,2HTA,2HBL,2HE /
      DATA IMESS0/2H  ,2H =,2HCM,2HM3,2H D,2HON,2HE ,2H! /
      DATA IBEGIN/2H  ,2HCM,2HMM,2H !,2H  ,2H  ,2HRT,2HE ,
     &            2HM2,2H &,2H M,2H3 ,2H  ,2HVE,2HRS,2HIO,
     &            2HN ,2H  ,2H03,2H/0,2H1/,2H77/
      DATA IMESS7/2H  ,2HYE,2HS ,2HOR,2H N,2HO ,2H? / 
      DATA IMESS8/2HIN,2HT ,2HTA,2HBL ,2HE ,2HST,2HAR,2HTS, 
     &            2H A,2HT ,2H6./ 
      DATA IDISC/2H  ,2HLU,2H =,2H  ,2H  ,2H  ,2HTR,2HK ,2H= ,
     &           2H  ,2H  ,2H  ,2HSE,2HCT,2HR ,2H= ,2H  ,2H  ,2H  , 
     &           2H  ,2HWO,2HRD,2H =,2H  ,2H  ,2H  /
      DATA IOUT/2H  ,2HOU,2HT ,2HOF,2H R,2HAN,2HGE/ 
      DATA ITEL1/2H  ,2HID,2H,P,2HRO,2HGR,2HAM,2H N,2HAM,2HE /
      DATA ITEL2/2H  ,2HID,2H,S,2HEG,2HME,2HNT,2H N,2HAM,2HE /
      DATA ITEL3/2H  ,2HID,2H,N,2HUM,2HBR,2H =,2H A,2HLL,2H I,
     &           2HD',2HS ,2HIN,2H S,2HYS,2HTE,2HM /
      DATA ITEL4/2H  ,2HEQ,2H,N,2HUM,2HBR/
      DATA ITEL5/2H  ,2HEQ,2H,N,2HUM,2HBR,2H,N,2HUM,2HBR,2H  ,
     &           2HGI,2HVE,2HS ,2HEQ,2HTS,2H I,2HNC,2HLU,2HSI,
     &           2HVE/
      DATA ITEL6/2H  ,2HLM,2H,A,2HDD,2HRE,2HSS,2H,#,2H O,2HF ,
     &           2HWO,2HRD,2HS /
      DATA ITEL7/2H  ,2HLM,2H,A,2HDD,2HRE,2HSS/ 
      DATA ITEL8/2H  ,2HDR,2H,N,2HUM,2HBR/
      DATA ITEL9/2H  ,2HDR,2H,N,2HUM,2HBR,2H,N,2HUM,2HBR,2H  ,
     &           2HGI,2HVE,2HS ,2HDR,2HT ,2HEN,2HTR,2HIE,2HS ,
     &           2HIN,2HCL,2HUS,2HIV,2HE /
      DATA ITEL10/2H  ,2HIN,2H,N,2HUM,2HBR/ 
      DATA ITEL11/2H  ,2HIN,2H,N,2HUM,2HBR,2H,N,2HUM,2HBR,2H  , 
     &            2HGI,2HVE,2HS ,2HIN,2HT ,2HTA,2HBL,2HE ,2HEN, 
     &            2HTR,2HIE,2HS ,2HIN,2HCL,2HUS,2HIV,2HE /
      DATA ITEL12/2H  ,2HLL,2H,L,2HIS,2HT ,2HLU,2H# / 
      DATA ITEL13/2H  ,2HPM,2H,A,2HDD,2HRE,2HSS,2H,N,2HEW,
     &            2H V,2HAL,2HUE/ 
      DATA ITEL14/2H  ,2HF/,2H,V,2HAL,2HUE,2H T,2HO ,2HFI,2HND, 
     &            2H,S,2HTA,2HRT,2H A,
     &            2HDD,2HRE,2HSS,2H,#,2H O,2HF ,2HWO,2HRD,2HS / 
      DATA ITEL16/2H  ,2HDL,2H,L,2HU,,2HTR,2HK,,2HSE,2HCT,2HR,, 
     &            2H #,2H O,2HF ,2HSE,2HCT,2HOR,2HS / 
      DATA ITEL17/2H  ,2HDS,2H,L,2HU,,2HTR,2HK,,2HVA,2HLU,2HE , 
     &            2HTO,2H F,2HIN,2HD /
      DATA ITEL18/2H  ,2HDM,2H  ,2H  ,2HDI,2HSC,2H M,2HOD,2H  , 
     &            2H  ,2H<I,2HNT,2HER,2HAC,2HTI,2HVE,2H> /
      DATA ITEL19/2H  ,2HEX,2H  ,2H  ,2HEX,2HIT/
      DATA ITEL20/2H  ,2HEN,2H  ,2H  ,2HEX,2HIT/
      DATA ITEL21/2H  ,2H/E,2H  ,2H  ,2HEX,2HIT/
      DATA ITEL22/2H  ,2HXL,2H,A,2HDD,2HRE,2HSS,2H  ,2H  ,2H(S, 
     &            2HYS,2HTE,2HM ,2HMA,2HP)/ 
      DATA ITEL23/2H  ,2HXL,2H,A,2HDD,2HRE,2HSS,2H,#,2H O,2HF , 
     &            2HWO,2HRD,2HS ,2H  ,2H(S,2HYS,2HTE,2HM ,2HMA, 
     &            2HP)/ 
      DATA ITEL24/2H  ,2HXP,2H,A,2HDD,2HRE,2HSS,2H,V,2HAL,2HUE, 
     &            2H  ,2H  ,2H(S,2HYS,2HTE,2HM ,2HMA,2HP)/
      DATA ITEL25/2H  ,2HXF,2H,V,2HAL,2HUE,2H T,2HO ,2HFI,2HND, 
     &            2H,S,2HTA,2HRT,2H A,2HDD,2HRE,2HSS,2H,#,2H O, 
     &            2HF ,2HWO,2HRD,2HS /
      DATA ITEL30/2H  ,2HDP,2H,V,2HAL,2HUE/ 
      DATA ITEL31/2H  ,2HTR,2H,S,2HTA,2HRT,2H L,2HOC,2HAT,2HIO,2HN,,
     &2HLI,2HST,2H D,2HEL,2HIM,2HIT,2HER/ 
      DATA IX/2H I,2HNP,2HUT,2H  ,2HFU,2HNC,2HTI,2HON/
      DATA I1/2H  ,2HID,2H  ,2HLI,2HST,2H I,2HD ,2HSE,2HGM,2HEN,2HT / 
      DATA I2/2H  ,2HEQ,2H  ,2HLI,2HST,2H E,2HQT,2H A,2HND,2H E,2HXT, 
     &        2HEN,2HTS/
      DATA I3/2H  ,2HDR,2H  ,2HLI,2HST,2H D,2HEV,2H R,2HEF,2H T,2HAB, 
     &        2HLE/ 
      DATA I4/2H  ,2HLM,2H  ,2HLI,2HST,2H M,2HEM,2HOR,2HY / 
      DATA IP/2H  ,2HXL,2H  ,2HLI,2HST,2H M,2HEM,2HOR,2HY ,2H  ,
     &        2H(S,2HYS,2HTE,2HM ,2HMA,2HP)/
      DATA I5/2H  ,2HIN,2H  ,2HLI,2HST,2H I,2HNT,2HER,2HUP,2HT ,2HTA, 
     &        2HBL,2HE /
      DATA I6/2H  ,2HLL,2H  ,2HCH,2HAN,2HGE,2H L,2HIS,2HT ,2HDE,2HVI, 
     &        2HCE/ 
      DATA I7/2H  ,2HPM,2H  ,2HPA,2HTC,2HH ,2HME,2HMO,2HRY/ 
      DATA IQ/2H  ,2HXP,2H  ,2HPA,2HTC,2HH ,2HME,2HMO,2HRY,2H  ,2H  , 
     &        2H(S,2HYS,2HTE,2HM ,2HMA,2HP)/
      DATA I9/2H  ,2HF/,2H  ,2HFI,2HND,2H A,2H V,2HAL,2HUE,2H I,2HN , 
     &        2HME,2HMO,2HRY/ 
      DATA IR/2H  ,2HXF,2H  ,2HFI,2HND,2H A,2H V,2HAL,2HUE,2H I,2HN , 
     &        2HME,2HMO,2HRY,2H  ,2H(S,2HYS,2HTE,2HM ,2HMA,2HP)/
      DATA IH/2H  ,2HDL,2H  ,2HLI,2HST,2H D,2HIS,2HC ,2HSE,2HCT,2HOR/ 
      DATA IJ/2H  ,2HDM,2H  ,2HDI,2HSC,2H M,2HOD,2H  ,2HAN,2HY ,2HLU/ 
      DATA IK/2H  ,2HDS,2H  ,2HDI,2HSC,2H S,2HEA,2HRC,2HH / 
      DATA IL/2H  ,2H/E,2H O,2HR ,2HEN,2H O,2HR ,2HEX,2H T,2HO ,
     &2HEX,2HIT/
      DATA IDP/2H  ,2HDP,2H  ,2HDI,2HSP,2HLA,2HY ,2HIN,2HPU,2HT , 
     &2HIN,2H O,2HCT,2HAL,2H D,2HEC,2HIM,2HAL,2H &,2H A,2HSC,2HII/
      DATA IN/2H  ,2HTR,2H  ,2HTR,2HAC,2HE ,2HLI,2HST/
      DATA IM/2H  ,2HXT,2H  ,2HTR,2HAC,2HE ,2HLI,2HST,2H (,2HSY,
     &2HST,2HEM,2H M,2HAP,2H) / 
      DATA IPACK/2H  ,2HA ,2HPK,2H A,2HFT,2HER,2H T,2HHE,2H I,2HNP, 
     &2HUT,2H G,2HIV,2HES,2H A,2H P,2HAC,2HKE,2HD ,2HLI,2HST,2HIN,
     &2HG / 
      DATA MORUSE/2H  ,2HOR,2H U,2HSE,2H  ,2H  ,2HPK,2H, /
      DATA IO/2H  ,2HFO,2HR ,2HMO,2HRE,2H I,2HNF,2HO ,2HDO,2H A,
     &        2H ?,2H?,,2HIN,2HPU,2HT / 
C 
      CALL RMPAR(LU)
      LU1=LU(1) 
      IF(LU1.EQ.0) LU1=1
      LU2 = LU1 
C 
      CALL EXEC(2,LU1,IBEGIN,22)
C 
      IPRMPT = 2H=
1     IPRAM(1) = 1
      IPRAM(2) = 0
      IPRAM(3) = 0
      IPRAM(4) = 0
      IPRAM(5) = 0
      CALL EXEC(2,LU1+ 2000B,IPRMPT,-2) 
      REG = REIO(1,LU1 + 400B,IBUF,17)
      CALL PARSE(IBUF,IB*2,IPBUF) 
C     SEE IF THE PACKED FORM OF THE OUTPUT IS DESIRED 
      IF(IPBUF(3).EQ.2HPK) IPRAM(5) = 1 
C 
C 
C 
C 
C 
C 
      IF(IPRS1.EQ.2HID) GO TO 100 
      IF(IPRS1.EQ.2HEQ) GO TO 200 
      IF(IPRS1.EQ.2HDR) GO TO 300 
      IF(IPRS1.EQ.2HXL) GO TO 400 
      IF(IPRS1.EQ.2HLM) GO TO 410 
      IF(IPRS1.EQ.2HIN) GO TO 500 
      IF(IPRS1.EQ.2HLL) GO TO 600 
      IF(IPRS1.EQ.2HPM) GO TO 710 
      IF(IPRS1.EQ.2HXP) GO TO 700 
      IF(IPRS1.EQ.2HF/) GO TO 810 
      IF(IPRS1.EQ.2HXF) GO TO 800 
      IF(IPRS1.EQ.2HDL) GO TO 1000
      IF(IPRS1.EQ.2HDM) GO TO 1100
      IF(IPRS1.EQ.2HDS) GO TO 1400
      IF(IPRS1.EQ.2HTR) GO TO 1610
      IF(IPRS1.EQ.2HXT) GO TO 1600
      IF(IPRS1.EQ.2HDP) GO TO 1700
      IF(IPRS1.EQ.2H??) GO TO 9000
      IF(IPRS1.EQ.2H/E) GO TO 50
      IF(IPRS1.EQ.2HEX) GO TO 50
      IF(IPRS1.EQ.2HEN) GO TO 50
25    CALL EXEC(2,LU1,IWHAT,-12)
      GO TO 1 
30    CALL EXEC(2,LU1,IOUT,7) 
      GO TO 1 
50    CALL EXEC(2,LU1,IMESS0,-16) 
      CALL EXEC(6,0)
C 
C 
C     **********GET ID SEGMENT INFO************** 
100   KYWORD = IGET(1657B) -1 
      IF(IPBUF(5).EQ.1) GO TO 175 
C 
      IMESS1(7) = IPRS2 
      IMESS1(8) = IPBUF(7)
      IMESS1(9) = IPBUF(8)
C 
150   DO 170 I = 1,156
      KYWORD = KYWORD +1
      IF(IGET(KYWORD).EQ.0) GO TO 190 
      IF(((IPRS2.EQ.IGET(IGET(KYWORD)+12)).AND. 
     &  (IPBUF(7).EQ.IGET(IGET(KYWORD)+13))).AND. 
     &  (IPBUF(8).EQ.IOR(IAND(IGET(IGET(KYWORD)+14),177400B),40B))) 
     &  GO TO 180 
170   CONTINUE
175   KYWORD = KYWORD +1
      IF(IPRAM(3).EQ.9999) GO TO 1
      IF(IGET(KYWORD).EQ.0) GO TO 1 
      IF(IGET(IGET(KYWORD)+12).NE.0) GO TO 176
      IMESS1(7) = 2H<F
      IMESS1(8) = 2HRE
      IMESS1(9) = 2HE>
      GO TO 180 
176   IMESS1(7) = IGET(IGET(KYWORD)+12) 
      IMESS1(8) = IGET(IGET(KYWORD)+13) 
      IMESS1(9) = IOR(IAND(IGET(IGET(KYWORD)+14),177400B),40B)
C 
180   CALL EXEC(3,LU2+1100B,1)
      CALL EXEC(2,LU2,IMESS1,-18) 
      ISTART = IGET(KYWORD) 
      ISTOP = ISTART +27
      ITEMP = IAND(IGET(IGET(KYWORD) +14),17B)
      ITEMP1= IAND(IGET(IGET(KYWORD) +14),20B)
      IF(ITEMP1.EQ.20B) ISTART= IGET(KYWORD) +11
      IF(ITEMP1.EQ.20B) ISTOP = ISTART + 8
      IF((((ITEMP.EQ.1).OR.(ITEMP.EQ.9)).OR.(ITEMP.EQ.17)).OR.
     &(ITEMP.EQ.25)) ISTOP = ISTART + 21
      CALL DOIO(ISTART,ISTOP,LU2,IPRAM) 
      IF(IPBUF(5).EQ.1) GO TO 175 
      GO TO 1 
190   CALL EXEC(2,LU1,IMES11,-12) 
      GO TO 1 
C 
C 
C     **********GET EQT INFO************* 
C 
C 
200   IEQTA = IGET(1650B) 
      IEQTNO = IGET(1651B)
      IF(IPRS3 .GT. IEQTNO) IPRS3 = IEQTNO
      IF(IPRS2.GT.IEQTNO) GO TO 25
      IF(IPRS2.LT. 1) IPRS2 = 1 
C 
C 
      DO 210 I = IPRS2,IPRS3
      IF(IPRAM(3) .EQ. 9999) GO TO 1
      ISTART = IEQTA + (I - 1)*15 
      CALL CNUMD(I,IBUF(2)) 
      IMESS2(4) = IBUF(4) 
      IBUF(1) = (IAND(IGET(ISTART+4),37400B)/256) 
      IBUF(1) = IBUF(1) + 2*(IBUF(1)/8) 
      CALL CNUMD(IBUF(1),IBUF(2)) 
C     INSERT A 0 SO DVR00 DOESNT LOOK LIKE DVR 0
      IF (IAND(IBUF(4),177400B).EQ.20000B) IBUF(4) = IBUF(4) + 10000B 
      IMESS2(11) = IBUF(4)
C 
      CALL EXEC(3,LU2+1100B,1)
      CALL EXEC(2,LU2,IMESS2,11)
      CALL DOIO(ISTART,ISTART +14,LU2,IPRAM)
C 
C 
210   CONTINUE
C 
      GO TO 1 
C 
C 
C     **********GET DEVICE REF TABLE**************
C 
300   IDRT = IGET(1652B)
      LUMAX = IGET(1653B) 
      IMESS3(6) = 61B 
C 
C 
      CALL EXEC(2,LU2,IMESS3,6) 
      IF(IPRS3.GT.LUMAX) IPRS3 = LUMAX
      IF(IPRS2.LE.0) IPRS2 = 1
      CALL DOIO(IDRT + IPRS2-1,IDRT + IPRS3-1,LU2,IPRAM)
      IMESS3(6) = 62B 
      CALL EXEC(3,LU2+1100B,1)
      CALL EXEC(2,LU2,IMESS3,6) 
      CALL DOIO(IDRT+IPRS2-1+LUMAX,IDRT+IPRS3-1+LUMAX,LU2,IPRAM)
      GO TO 1 
C 
C 
C 
C     ***********LIST ANY MEMORY LOCATION REQUESTED**************** 
C 
C 
400   IPRAM(4) = -1 
      IF((IPRS2.LT.0).OR.(IPRS3+IPRS2-1.LT.0)) GO TO 30 
410   CALL DOIO(IPRS2,IPRS2+IPRS3-1,LU2,IPRAM)
      GO TO 1 
C 
C 
C     *************GET THE INTERUPT TABLE*****************
C 
C 
500   INTBA = IGET(1654B) 
      INTLG = IGET(1655B) 
C 
C 
      IF(IPRS2.LT.6) GO TO 550
      CALL EXEC(2,LU2,IMESS5,-12) 
      IF(IPRS3.GT.INTLG) IPRS3 = INTLG
      IF(IPRS2.LE.0) IPRS2 = 1
      ISTART = INTBA + IPRS2 -6 
      ISTOP = INTBA +IPRS3 -1 
      IPRAM(1) = IPRS2
      IPRAM(2) = 1
      CALL DOIO(ISTART,ISTOP,LU2,IPRAM) 
      GO TO 1 
550   CALL EXEC(2,LU1,IMESS8,-22) 
      GO TO 1 
C 
C 
C 
C     ***********CHANGE OUTPUT LU***************
C 
C 
600   LU2 = IPRS2 
      GO TO 1 
C 
C 
C 
C     ***********PATCH MEMORY ANY MEMORY LOCATION**************** 
C 
700   IPRAM(4) = -1 
710   CALL DOIO(IPRS2,IPRS2,LU2,IPRAM)
      CALL EXEC(2,LU1,IMESS7,-14) 
      CALL REIO(1,LU1+400B,IPBUF(7),1)
C     IF YOU CHANGE YOUR MIND THIS IS THE ESCAPE ROUTE
      IF(IPBUF(7).NE.2HYE) GO TO 1
      IF(IPRAM(4).EQ.0)CALL IPUT(IPRS2,IPRS3) 
      IF(IPRAM(4).EQ.-1)CALL XPUT(IPRS2,IPRS3)
      CALL DOIO(IPRS2,IPRS2,LU2,IPRAM)
      GO TO 1 
C 
C 
C*******FIND A WORD BETWEEN GIVEN LIMITS IN MEMORY********
C 
800   IPRAM(4) = -1 
810   IF (IPRS3.LT.0) IPRS3 = 1 
      IF((IPRS3.LT.0).OR.(IPRS3+IPRS4-1.LT.0)) GO TO 30 
      DO 850 I = IPRS3,IPRS3+IPRS4-1
      IF((IGET(I).EQ.IPRS2).AND.(IPRAM(4).EQ.0)) GO TO 820
      IF((IXGET(I).EQ.IPRS2).AND.(IPRAM(4).EQ.-1)) GO TO 820
      GO TO 850 
820   CALL DOIO(I,I,LU2,IPRAM)
      IF(IPRAM(3).EQ.9999) GO TO 1
      IPRAM(3) = 1
      IPRAM(1) = IPRAM(1) + 1 
850   CONTINUE
      IF(IPRAM(3).EQ.0) GO TO 190 
      GO TO 1 
C 
C 
C********LOOK AT ANY DISC LOCATION************
1000  DO 1050 J = 1,IPRS5 
      CALL EXEC(1,IPRS2 + 100B,IARRAY,128,IPRS3,IPRS4)
      CALL DISC3(IPRS2,IPRS3,IPRS4,IPRAM(1),IARRAY,IPRAM,LU2,IDISC) 
      IF(IPRAM(3).EQ.9999) GO TO 1
      IPRS4 = IPRS4 + 2 
      IF(IPRS4.LT.60) GO TO 1050
      IPRS4 = 0 
      IPRS3 = IPRS3 + 1 
1050  CONTINUE
      GO TO 1 
C 
C 
C 
C*************MODIFY OP SYSTEM ON THE DISC****************
C 
C 
C 
1100  CALL EXEC(2,LU1,IGTOUT,27)
C 
C** THIS SECTION ALLOWS MODIFICATION OF ANY DISC**
C 
C 
1150  CALL EXEC(2,LU1+2000B,IVALU2,13)
      REG=REIO(1,LU1+400B,IBUF,10)
      CALL PARSE(IBUF,IB*2,IPBUF) 
      IF(IPRS1.EQ.2H/D) GO TO 1 
      ILU= IPRS1
      ITRK= IPRS2 
      ISECTR = IPRS3
      IWORD = IPRS4 
      IF(IWORD .LE. 0 ) GO TO 25
      IFIX = IPBUF(18)
      INULL = IPBUF(17) 
C 
      ASSIGN 1150 TO ILABEL 
C 
C 
1210  CALL EXEC(1,ILU+100B,IARRAY,128,ITRK,ISECTR)
      IPRAM(1) = 0
      CALL DISC3(ILU,ITRK,ISECTR,IWORD,IARRAY,IPRAM,LU2,IDISC)
C 
      IF (INULL.EQ.0) GO TO ILABEL
      CALL EXEC(2,LU1+2000B,IMESS7,-14) 
      CALL REIO(1,LU1+400B,IPBUF(7),1)
      IF(IPBUF(7).EQ. 2H/D) GO TO 1 
      IF(IPBUF(7).NE. 2HYE) GO TO ILABEL
C 
C 
C 
C     LETS GO MODIFY THE TRACK ASSIGNMENT TABLE SO WE CAN WRITE 
C     ON SYSTEM TRACKS. 
C 
1300  IARRAY(IWORD) = IFIX
C     !!!!!PATCH DISC!!!!!! 
      CALL EXEC(100002B,ILU+100B,IARRAY,128,ITRK,ISECTR)
      GO TO 1310
C 
C     FIX TRACK ASSIGNMENT TABLE
C 
1333  INULL = 0 
1310  INULL = 0 
      GO TO 1210
C 
C 
C 
C 
C 
C***THIS SECTION WILL SEARCH A TRACK FOR ALL OCCURRENCES OF A *** 
C***    GIVEN VALUE.  USE THIS SECTION TO UNPURGE A FILE.     *** 
C*** HINT ! IF YOU UNPURGE DON'T FORGET THE EXTENTS OR YOU WILL *** 
C***  DEVELOP A FMGR -005 ERROR . 
C 
C 
C 
1400  ISTART = 0
      DO 1450 I =0,58,2 
      CALL EXEC(1,IPRS2 + 100B,IARRAY,128,IPRS3,I)
      DO 1425 J = 1,128 
      IF(IARRAY(J).NE.IPRS4) GO TO 1425 
      ISTART = 1
      CALL CNUMD(I,IDISC(17)) 
      CALL CNUMD(J,IDISC(24)) 
      CALL EXEC(2,LU2,IDISC(12),15) 
      IF(IFBRK(IDUMY)) 1,1425 
1425  CONTINUE
1450  CONTINUE
      IF (ISTART .EQ. 0) GO TO 190
      GO TO 1 
C 
C******************* TRACE A LIST IN ANY MAP ************************** 
C 
1600  IPRAM(4) = -1 
1610  IF((IPRS2 .LT.1).OR. (IPRS2 .EQ.IPRS3))  GO TO 1
      CALL DOIO(IPRS2,IPRS2,LU2,IPRAM)
      IPRAM(3) = 1
      IF(IPRAM(4).EQ.0) IPRS2 = IGET(IPRS2) 
      IF(IPRAM(4).EQ.-1) IPRS2 = IXGET(IPRS2) 
      GO TO 1610
C 
C 
1700  IARRAY(1) = IPRS2 
      IPRAM(1) = 0
      IPRAM(3) = 1
      CALL DISC3(1,1,1,1,IARRAY,IPRAM,LU2,IDISC)
      GO TO 1 
9000  IF(IPRS2.EQ.2HID) GO TO 9100
      IF(IPRS2.EQ.2HEQ) GO TO 9200
      IF(IPRS2.EQ.2HDR) GO TO 9300
      IF(IPRS2.EQ.2HLM) GO TO 9400
      IF(IPRS2.EQ.2HIN) GO TO 9500
      IF(IPRS2.EQ.2HLL) GO TO 9600
      IF(IPRS2.EQ.2HPM) GO TO 9700
      IF(IPRS2.EQ.2HF/) GO TO 9800
      IF(IPRS2.EQ.2HDL) GO TO 9905
      IF(IPRS2.EQ.2HDM) GO TO 9910
      IF(IPRS2.EQ.2HDS) GO TO 9920
      IF(IPRS2.EQ.2H/E) GO TO 9940
      IF(IPRS2.EQ.2HEX) GO TO 9940
      IF(IPRS2.EQ.2HEN) GO TO 9940
      IF(IPRS2.EQ.2HXL) GO TO 9960
      IF(IPRS2.EQ.2HXP) GO TO 9970
      IF(IPRS2.EQ.2HXF) GO TO 9980
      IF(IPRS2.EQ.2HDP) GO TO 9982
      IF(IPRS2.EQ.2HTR) GO TO 9984
      IF(IPRS2.EQ.2HXT) GO TO 9984
C 
C 
C 
      CALL EXEC(2,LU2,IX,8) 
      CALL EXEC(2,LU2,I1,11)
      CALL EXEC(2,LU2,I2,13)
      CALL EXEC(2,LU2,I3,12)
      CALL EXEC(2,LU2,I4,9) 
      CALL EXEC(2,LU2,IP,16)
      CALL EXEC(2,LU2,I5,13)
      CALL EXEC(2,LU2,IN,8) 
      CALL EXEC(2,LU2,IM,15)
      CALL EXEC(2,LU2,IDP,22) 
      CALL EXEC(2,LU2,I6,12)
      CALL EXEC(2,LU2,I7,9) 
      CALL EXEC(2,LU2,IQ,17)
      CALL EXEC(2,LU2,I9,14)
      CALL EXEC(2,LU2,IR,21)
      CALL EXEC(2,LU2,IH,11)
      CALL EXEC(2,LU2,IJ,11)
      CALL EXEC(2,LU2,IK,9) 
      CALL EXEC(2,LU2,IL,12)
      CALL EXEC(2,LU2,IO,15)
      CALL EXEC(2,LU2,IPACK,23) 
      GO TO 1 
C 
C 
C 
C 
9100  CALL EXEC(2,LU2,ITEL1,9)
      CALL EXEC(2,LU2,ITEL2,9)
      CALL EXEC(2,LU2,ITEL3,16) 
      GO TO 9999
9200  CALL EXEC(2,LU2,ITEL4,5)
      CALL EXEC(2,LU2,ITEL5,19) 
      GO TO 9999
9300  CALL EXEC(2,LU2,ITEL8,5)
      CALL EXEC(2,LU2,ITEL9,23) 
      GO TO 9999
9400  CALL EXEC(2,LU2,ITEL7,6)
      CALL EXEC(2,LU2,ITEL6,12) 
      GO TO 9999
9500  CALL EXEC(2,LU2,ITEL10,5) 
      CALL EXEC(2,LU2,ITEL11,26)
      GO TO 9999
9600  CALL EXEC(2,LU2,ITEL12,7) 
      GO TO 1 
9700  CALL EXEC(2,LU2,ITEL13,11)
      GO TO 1 
9800  CALL EXEC(2,LU2,ITEL14,22)
      GO TO 1 
9905  CALL EXEC(2,LU2,ITEL16,16)
      GO TO 9999
9910  CALL EXEC(2,LU2,ITEL18,17)
      GO TO 1 
9920  CALL EXEC(2,LU2,ITEL17,13)
      GO TO 1 
9940  CALL EXEC(2,LU2,ITEL21,6) 
      CALL EXEC(2,LU2,ITEL20,6) 
      CALL EXEC(2,LU2,ITEL19,6) 
      GO TO 1 
9960  CALL EXEC(2,LU2,ITEL22,14)
      CALL EXEC(2,LU2,ITEL23,19)
      GO TO 9999
9970  CALL EXEC(2,LU2,ITEL24,17)
      GO TO 1 
9980  CALL EXEC(2,LU2,ITEL25,22)
      GO TO 1 
9982  CALL EXEC(2,LU2,ITEL30,5) 
      GO TO 1 
9984  ITEL31(2) = IPRS2 
      CALL EXEC(2,LU2,ITEL31,17)
      GO TO 1 
C 
9999  MORUSE(6) = IPRS2 
      CALL EXEC(2,LU2,MORUSE,8) 
      GO TO 1 
      END 
      END$
FTN4,L
      SUBROUTINE DOIO(ISTART,ISTOP,LU,IPRAM)
      DIMENSION IBUF(25),IMESS(27),IPRAM(5),OBUF(37),LMESS(17)
C 
      DATA IMESS/2H  ,2H  ,2H  ,2HWO,2HRD,
     &2H  ,2H  ,2HLO,2HCA,2HTI,2HON,2H  , 
     &2HVA,2HLU,2HE(,2H8),2H  ,2HVA,2HLU,2HE(,2H10,2H) ,
     &2HVA,2HLU,2HE(,2HAS,2H) / 
      DATA LMESS/2H  ,2HLO,2HCA,2HTI,2HON,2HS ,2H  ,2H  ,2H  ,
     &2H T,2HHR,2HOU,2HGH,2H  / 
      DATA IBUF/25*2H  /
C 
C 
C     THE IPRAM ARRAY TELLS HOW TO DO THE I/O 
C     IPRAM(1) = WORD # TO START COUNTING AT, 
C     IPRAM(2) = 0 MEANS WORD COUNT TO BE IN DECIMAL
C     IPRAM(2) = 1 MEANS WORD COUNT TO BE IN OCTAL
C     IPRAM(3) = 0 MEANS PRINT HEADER.  = 1 MEANS NO HEADER.
C     IPRAM(4) =-1 MEANS WE ARE DOING A CROSS MAP LOAD
C     IPRAM(5) = 1 MEANS A PACKED LISTING IS DESIRED
C 
C     ISTART IS LOCATION TO START COUNTING AT 
C     ISTOP IS LOCATION TO STOP COUNTING AT.
C     LU IS THE OUTPUT LU.
C 
C 
      K = IPRAM(1)-1
C 
      IF(IPRAM(5).EQ.1) GO TO 500 
C 
1     IF(IPRAM(3).EQ. 0) CALL EXEC(2,LU,IMESS,-54)
C 
C 
      DO 100 I = ISTART,ISTOP 
      K = K + 1 
      CALL CNUMD(K,IBUF(3)) 
      IF(IPRAM(2) .EQ.1) CALL CNUMO(K,IBUF(3))
      CALL CNUMO(I,IBUF(8)) 
      IF(IPRAM(4) .NE.-1) GO TO 50
      CALL CNUMO(IXGET(I),IBUF(13)) 
      CALL CNUMD(IABS(IXGET(I)),IBUF(18)) 
      IF(IXGET(I).LT.0)IBUF(18) = IBUF(18) + 6400B
C 
      CALL IASCI(IXGET(I),IBUF(25)) 
C 
      GO TO 75
50    CALL CNUMO(IGET(I),IBUF(13))
      CALL CNUMD(IABS(IGET(I)),IBUF(18))
      IF (IGET(I).LT.0) IBUF(18) = IBUF(18) + 6400B 
C 
      CALL IASCI(IGET(I),IBUF(25))
C 
75    CALL EXEC(2,LU,IBUF,-50)
      IF(IFBRK(IDMY))200,100
100   CONTINUE
      GO TO 300 
200   IPRAM(3) = 9999 
300   RETURN
C 
C 
500   K = ISTART
550   IF((ISTOP-K).LT.0) RETURN 
      CALL CNUMO(K,LMESS(7))
      CALL CNUMO(ISTOP,LMESS(15)) 
      IF(((ISTOP-K)/64).GT.0) CALL CNUMO(K + 63,LMESS(15))
C 
      CALL EXEC(3,LU + 1100B,1) 
      CALL EXEC(2,LU,LMESS,17)
      CALL EXEC(3,LU + 1100B,1) 
C 
      DO 800 I = 1,8
C 
      CALL PACK (ISTOP - K + 1,IPRAM(4)+1,K,OBUF) 
      CALL EXEC(2,LU,OBUF,37) 
C 
      K = K + 8 
      IF((ISTOP-K).LT.0) RETURN 
      IF(IFBRK(IDMY)) 200,800 
800   CONTINUE
C 
      GO TO 550 
      END 
      SUBROUTINE DISC3(LU,ITRK,ISECTR,INDEX,IARRAY,IPRAM,LU2,IDISC) 
      DIMENSION IARRAY(128),IPRAM(4),IBUF(17),OBUF(37)
      DIMENSION IDISK(20),IDISC(20) 
      DATA IDISK/2H  ,2HWO,2HRD,2H  ,2H V,2HAL,2HUE,2H(8,2H) ,
     &           2H V,2HAL,2HUE,2H(1,2H0),2H  ,2HVA,2HLU,2HE(,
     &           2HAS,2H) / 
      DATA IBUF/17*2H  /
C 
C 
C    THIS SUBROUTINE DOES THE I/O FOR ALL DISC READS.  THE MAIN 
C    PROGRAM DOES THE READ PASSING THE 128 WORDS READ IN IARRAY.
C    THIS ROUTINE FORMATS THE OUTPUT. 
C 
C    IN ADDITION IT DOES THE OUTPUT FOR THE ' DP ' INSTRUCTION
C    THIS IS A SLIGHT PERTERBATION FROM THE SUBROUTINES REAL
C    PURPOSE. 
C 
C 
C    IF IPRAM(1) #0  THEN 128 WORDS ARE OUTPUT
C    IF IPRAM(1) =0  THEN ONLY ONE WORD IS OUTPUT 
C    IF IPRAM(3) # 0 THEN NO DISC TRK & SECTOR INFO IS PRINTED
C    IF IPRAM(5) = 0 THEN A PACKED LISTING IS DESIRED 
C 
      IF(IPRAM(1).EQ.0) GO TO 55
      NUMBR = 128 
      INDEX = 1 
      ID = 19 
      GO TO 100 
C 
55    NUMBR = 1 
      ID = 26 
C 
100   CALL CNUMD(LU,IDISC(3)) 
      CALL CNUMD(ITRK,IDISC(9)) 
      CALL CNUMD(ISECTR,IDISC(17))
      CALL CNUMD(INDEX,IDISC(24)) 
      IF(IPRAM(3).NE.1) CALL EXEC(2,LU2,IDISC,ID) 
      IF(IPRAM(5).NE.1) CALL EXEC(2,LU2,IDISK,20) 
C 
      IF(IPRAM(5).EQ.1) GO TO 2000
C 
C 
      DO 1020 I = INDEX,NUMBR 
C 
      CALL IASCI(IARRAY(I),IBUF(17))
C 
C 
C 
C 
      CALL CNUMD(I,IBUF)
      CALL CNUMO(IARRAY(I),IBUF(5)) 
      CALL CNUMD(IABS(IARRAY(I)),IBUF(10))
      IF (IARRAY(I).LT.0) IBUF(10) = IBUF(10) + 6400B 
      CALL EXEC(2,LU2,IBUF,17)
      IF(IFBRK(IDUMY)) 999,1020 
1020  CONTINUE
      RETURN
 999  IPRAM(3) = 9999 
      RETURN
C 
C 
C     FIX UP A POINTER TO THE ARRAY IARRAY SO THAT THE
C     PACK ROUTINE WILL WORK. 
C 
2000  CALL DUMMY(IARRAY,IPOINT) 
C 
      DO 3000 I = 1,16
      CALL PACK(8,1,IPOINT,OBUF)
      CALL EXEC(2,LU2,OBUF,37)
      IPOINT = IPOINT + 8 
      IF(IFBRK(IDUMY)) 999,3000 
3000  CONTINUE
      END 
      END$
ASMB,L
      NAM IXGET,7 
      ENT IXGET,XPUT,PACK,IASCI,DUMMY 
      ENT IGET
      ENT IPUT
      EXT $LIBR,$LIBX,.ENTR 
* 
* 
* 
IGET  NOP 
      DLD IGET,I
      SWP 
      LDA A,I 
      LDA A,I 
      JMP B,I 
* 
* 
* 
IXGET NOP 
      DLD IXGET,I 
      SWP 
      LDA A,I 
      XLA A,I 
      JMP B,I 
* 
* 
* 
IPUT  NOP 
      JSB $LIBR 
      NOP 
      LDA IPUT,I
      STA IGET
      ISZ IPUT
      DLD IPUT,I
      LDA A,I 
      LDB B,I 
      STB A,I 
      JSB $LIBX 
      DEF IGET
* 
* 
* 
XPUT  NOP 
      JSB $LIBR 
      NOP 
      LDA XPUT,I
      STA IXGET 
      ISZ XPUT
      DLD XPUT,I
      LDA A,I 
      LDB B,I 
      XSB A,I 
      JSB $LIBX 
      DEF IXGET 
* 
* 
* 
* 
* 
* 
* 
* 
*  THIS ROUTINE ACCEPTS UP TO 8 WORDS OF INPUT AND CONVERTS THOSE 
*  WORDS TO OCTAL ASCII IN A PACKED FORMAT .  EIGHT WORDS OF OCTAL
*  DELIMITED BY A * AND THEN THEIR ASIII REPRESENTATION.
*  THE WORDS MAY EITHOR BE IN THE SYSTEM MAP OR THE USER MAP
*  THE ROUTINE IS FORTRAN CALLABLE AS:
* 
*        CALL PACK(#WORDS,MAP,INPUT BUFFER,OUTPUT BUFFER) 
* 
*        MAP =  0    SYSTEM MAP 
*        MAP >= 1    USER MAP 
* 
*     THE OUTPUT BUFFER MUST BE 36 WORDS LONG 
* 
* 
* 
KOUNT NOP 
MAP   NOP 
INBUF NOP 
ASSLC NOP 
PACK  NOP 
      JSB .ENTR     GET THE PARAMETER ADDRESSES 
      DEF KOUNT 
* 
      LDA KOUNT,I    GET THE # OF WORDS TO CONVERT
BACK  CMA,INA       MAKE NEG AND
      SSA,RSS       IF 0 OR NEG WORDS INPUT THEN FORGET IT
      JMP PACK,I
      STA KOUNT     NOW SAVE FOR LOOP 
* 
      ADA D8        ADD 8 TO SEE IF INPUT # 
      SSA,RSS       GREATER THAN 8
      JMP CONTU     ALL IS WELL ! 
      LDA D8
      JMP BACK
* 
* 
CONTU LDA MAP,I     GET THE MAP AND SAVE
      STA MAP       FOR LATER 
* 
      LDA INBUF,I 
      STA INBUF 
* 
      LDA ASSLC     GET THE ADDRESS 
      LDB ASSLC     TWICE 
      STB TEMP      SAVE TEMPORARIALLY
      INA           BUMP IT 
      CLE,ELA       CONVERT TO A BYTE ADDRESS 
      STA ASSLC     AND SAVE FOR LATER
      ADB D29       NOW DEFINE THE ASCII ADDRESS
      STB OABUF     AND SAVE FOR THE IASCI SUBROUTINE 
      STB YTEMP 
* 
      LDA DM37      NOW CLEAR OUT THE OLD BUFFER
      STA XTEMP 
      LDB BLANK     GET A BLANK READY 
* 
LOOPX STB TEMP,I    SET A BLANK INTO THE OUTPUT BUFFER
      ISZ TEMP      STEP BUFFER POINTER 
      ISZ XTEMP     DONE YET ?
      JMP LOOPX     NO
* 
* 
* 
LOOP  LDB INBUF      GET THE 1ST WORD 
      LDA MAP        GET THE MAP TO USE 
      SZA,RSS        SYS MAP ?
      JMP SYSTM     YES 
      LDB B,I        NO 
      JMP OUT 
SYSTM XLB B,I        GET THE INFO FROM THE SYSTEM MAP 
OUT   STB XTEMP     SAVE FOR THE IASCI SUBROUTINE 
      JSB ASCI       AND CONVERT TO OCTAL ASCII 
* 
      JSB IASCI      AND PLACE THROUGH THE ASCII FILTER 
      DEF *+3 
      DEF XTEMP 
      DEF TEMP
* 
      STB OABUF,I    PUT RESULT INTO THE OUTPUT BUFFER
* 
      ISZ INBUF       BUMP OUR
      ISZ OABUF       POINTERS
      ISZ ASSLC       AND THE CHAR ADDRESS
* 
      ISZ KOUNT       ARE WE DONE ? 
      JMP LOOP        NOT YET 
* 
      CCB              YES,GET THE END OF THE OCTAL #'S 
      ADB YTEMP 
      LDA B,I       NOW GET THE LAST WORD 
      IOR ASTRK     PUT IN AN ASTRISK 
      STA B,I       NOW PUT IT BACK 
* 
      JMP PACK,I      RETURN TO THE CALLER
* 
* 
* 
*      ** DATA TO OCTAL ASCII CONVERSION ** 
      SPC 1 
*     CALLING SEQUENCE:  LDB (DATA WORD)
*                        LDA (ADDRESS AT START OF STORAGE)
*                        JSB ASCI 
      SPC 1 
ASCI  NOP           OUTPUT 6 DIGITS 
*     STA ASSLC     SET THE ADDRESS (NOT USED AT THE MOMENT ) 
      LDA KM6       GET NO. OF DIGITS TO CONVERT
      RBL           MOVE FIRST DIGIT TO LOW B 
      JSB NUM.F     CONVERT THE NUMBER
      JMP ASCI,I    RETURN
      SPC 2 
*SCI2 NOP           5 DIGITS & BLANK
*     LDA KM5       GET NO OF DIGITS TO CONVERT 
*     BLF           POSITION FIRST DIGIT
*     JSB NUM.F     CONVERT THE NUMBER
*     JMP ASCI2,I   RETURN
* 
*                   *********************************** 
*                   * CONVERT DIGITS TO ASCII  BASE 8 * 
*                   *********************************** 
* 
* 
NUM.F NOP 
      STA T1NUM     SAVE THE DIGIT COUNT
      CPA KM6       IF 6 THEN 
      CLA,INA,RSS   USE 1 AS A MASK FOR FIRST DIGIT 
NUM00 LDA K7        ELSE USE 7
      AND B         ISOLATE THE DIGIT 
      ADA "0"       ADD 60 TO MAKE ASCII
      JSB PUT.F     PUT IN THE BUFFER 
      BLF,RBR       POSITION THE NEXT DIGIT 
      ISZ T1NUM     DONE? 
      JMP NUM00     NO  DO NEXT DIGIT 
* 
      JMP NUM.F,I   YES RETURN
* 
T1NUM NOP 
KM6   DEC -6
* 
      SPC 2 
* 
*                   ********************************
*                   * PUT CHARACTER IN LIST BUFFER *
*                   ********************************
* 
PUT.F NOP 
      STB T1PUT     SAVE B
      LDB ASSLC     GET CURRENT BUFFER ADDRESS
      AND B177      ISOLATE THE CHARACTER 
      CLE,ERB       WORD ADDRESS TO B E=UPPER,LOWER FLAG
      SEZ,RSS       IF UPPER CHAR 
      ALF,SLA,ALF   POSITION AND SKIP 
      XOR B,I       INCLUSION OF HIGHER CHAR. 
      XOR B40       ADD,TAKE AWAY LOWER BLANK 
      STA B,I       SET THE WORD DOWN 
      ISZ ASSLC     STEP THE CHAR ADDRESS 
      LDB T1PUT     RESTORE B 
      JMP PUT.F,I   RETURN
* 
T1PUT NOP 
OABUF NOP 
B40   OCT 40
K7    DEC 7 
D8    DEC 8 
"0"   OCT 60
D29   DEC 29
DM37  DEC -37 
BLANK ASC 1,
ASTRK OCT 52        LOWER BYTE = *
B177  OCT 177 
TEMP  NOP 
XTEMP NOP 
YTEMP NOP 
ADDRS NOP 
PONTR NOP 
DUMMY NOP           THIS IS A DUMMY SUBROUTINE TO FIX UP A POINTER
      JSB .ENTR     SO THAT THE PACK ROUTINE CAN WORK WITH ARRAYS 
      DEF ADDRS     IN A PROGRAM AS WELL AS MEMORY ADDRESSES. 
* 
      LDA ADDRS 
      STA PONTR,I 
      JMP DUMMY,I 
      SPC 1 
* 
* 
* 
* 
* 
* 
*  THE IASCI SUBROUTINE TAKES ONE WORD OF INPUT AND CONVERTS THAT 
*  WORD TO ASCII.  IF ANY BYTE CAN NOT BE CONVERTED TO ASCII THEN 
*  AN ASCII BLANK IS RETURNED FOR THAT BYTE.
* 
* 
*    CALLING SEQUENCE :    JSB IASCI
*                          DEF RETURN 
*                          DEF VALUE    VALUE TO BE CONVERTED 
*                          DEF ASCII    RETURNED ASCII VALUE
*                       ----
* 
*   ON RETURN, THE B REGISTER HAS THE ASCII VALUE 
* 
VALUE NOP 
LOCTN NOP 
IASCI NOP 
      JSB .ENTR 
      DEF VALUE 
* 
      LDA VALUE,I   GET THE VALUE TO CONVERT
      STA TEMP1     SAVE IT 
      AND M377      KEEP ONLY LOWER BYTE
      JSB CNVRT     AND CONVERT 
      STB VALUE     SAVE THE RETURNED VALUE 
* 
      LDA TEMP1     GET THE WORD BACK AGAIN 
      AND M1774     KEEP ONLY THE UPPER BYTE
      ALF,ALF       SHIFT TO LOW ORDER
      JSB CNVRT     AND GO CONVERT
      BLF,BLF       PUT INTO UPPER BYTE 
      ADB VALUE     NOW MERGE ADD IN LOWER BYTE 
      STB LOCTN,I   AND RETURN IT TO THE USER 
      JMP IASCI,I 
* 
* 
*   THIS SUBROUTINE CONVERTS LOWER BYTE OF A TO ASCII AND PLACES
*   THE RETURNED ASCII INTO B 
* 
CNVRT NOP 
      STA B      AND SAVE 
      CMA,INA 
      ADA B135
      SSA           IS IT OK
      JMP BLNK2     NO
      LDA B40 
      CMA,INA 
      ADA B 
      SSA           OK ?
BLNK2 LDB B40       NO
      JMP CNVRT,I 
* 
* 
* 
* 
A     EQU 0 
B     EQU 1 
M1774 OCT 177400
B135  OCT 137 
M377  OCT 377 
TEMP1 NOP 
      END 
                        