FTN4,L,C
      PROGRAM CMM3 (3,90) 
C 
C 
C                  MIKE MANLEY          REVISION 2
C 
C 
      DIMENSION IPBUF(33),LU(5),IBUF(25),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(6),IVALU2(13)
      DIMENSION IARRAY(64),IDISC(26),MDISK(10),IVALUE(9),ITEL33(28) 
      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),IG(11),IH(11),IJ(11),IK(9),IOUT(7) 
      DIMENSION IL(12),IO(15),IP(16),IQ(17),IR(21),IDI(28),MEMR(7)
      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),ITEL15(11),ITEL16(16) 
      DIMENSION ITEL17(13),ITEL18(17),ITEL19(6),ITEL20(6),ITEL21(6) 
      DIMENSION IGTOUT(27),ITAT(12),ISYS(5),IAUX(5),LDISC(5),IABS(7)
      DIMENSION IT(17),ITEL26(2),ITEL27(5),ITEL28(13),ITEL34(13)
      DIMENSION IPR(14),ILE(17),ITEL35(2),IGO(27),IRP(6)
      DIMENSION IPG(19),ITEL36(13)
      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 MEMR/2H  ,2HME,2HM ,2HRE,2HS ,2HPR,2HOG/ 
      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 MDISK/2H  ,2HMO,2HDI,2HFY,2H O,2HP ,2HSY,2HST,2HEM,2H ?/ 
      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 IBUF/2H24,2H99,2H9-,2H16,2H05,2H2 ,2H17,2H52,2H S,2HOF,
     &          2HTW,2HAR,2HE ,2HSE,2HRV,2HIC,2HE ,2HKI,2HT ,2HSY,
     &          2HST,2HEM,2H 1,2H00,2H0 / 
      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 ITEL15/2H  ,2HLI,2H,E,2HNT,2HRY,2H P,2HOI,2HNT,2H N, 
     &            2HAM,2HE /
      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 ITEL26/2H  ,2HTA/
      DATA ITEL27/2H  ,2HTA,2H,L,2HU ,2H# / 
      DATA ITEL28/2H  ,2HTA,2H,L,2HU ,2H#,,2HTR,2HK ,2H#,,
     &            2H #,2H O,2HF ,2HTR,2HKS/ 
      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 ITEL33/2H  ,2HDI,2H,E,2HNT,2HRY,2H P,2HOI,2HNT,2H N,2HAM,
     &2HE / 
      DATA ITEL34/2H  ,2HLP,2H,P,2HRO,2HG ,2HNA,2HME,2H,R,2HEL, 
     &2H A,2HDD,2HRE,2HSS/
      DATA ITEL35/2H  ,2HLE/
      DATA ITEL36/2H  ,2HPG,2H, ,2HPG,2H#,,2H# ,2HOF,2H W,2HOR,2HDS,
     &2H,O,2HFS,2HET/ 
      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 IG/2H  ,2HLI,2H  ,2HLI,2HST,2H E,2HNT,2HRY,2H P,2HOI,2HNT/ 
      DATA IDI/2H  ,2HDI,2H  ,2HRE,2HPO,2HRT,2H D,2HIS,2HC ,2HDI,2HCT,
     &2HIO,2HNA,2HRY,2H A,2HDD,2HRE,2HSS,2H O,2HF ,2H A,2HN ,2HEN,2HTR, 
     &2HY ,2HPO,2HIN,2HT /
      DATA ILE/2H  ,2HLE,2H  ,2HLI,2HST,2H A,2HLL,2H E,2HNT,2HRY, 
     &2H P,2HOI,2HNT,2HS ,2HIN,2H S,2HYS/ 
      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 IPG/2H  ,2HPG,2H  ,2HLI,2HST,2H A,2HNY,2H L,2HOC,2HAT,2HIO,
     &2HN ,2HIN,2H P,2HHY,2HS ,2HME,2HMO,2HRY/
      DATA IM/2H  ,2HXT,2H  ,2HTR,2HAC,2HE ,2HLI,2HST,2H (,2HSY,
     &2HST,2HEM,2H M,2HAP,2H) / 
      DATA IPR/2H  ,2HLP,2H  ,2HLI,2HST,2H D,2HIS,2HC ,2HRE,2HS , 
     &2HPR, 2HOG,2HRA,2HM / 
      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 IT/2H  ,2HTA,2H  ,2HLI,2HST,2H T,2HRA,2HCK,2H A,2HSS,
     &2HIG,2HNM,2HEN,2HT ,2HTA,2HBL,2HE / 
      DATA IO/2H  ,2HFO,2HR ,2HMO,2HRE,2H I,2HNF,2HO ,2HDO,2H A,
     &        2H ?,2H?,,2HIN,2HPU,2HT / 
      DATA ITAT/2H  ,2HTR,2HAC,2HK ,2HAS,2HSI,2HGN,2HME,2HNT, 
     &2H T,2HAB,2HLE/ 
      DATA ISYS/2H  ,2HSY,2HS ,2HDI,2HSC/ 
      DATA IAUX/2H  ,2HAU,2HX ,2HDI,2HSC/ 
      DATA IRP/2H  ,2HRP,2H  /
      DATA LDISC/2H  ,2HDI,2HSC,2H R,2HES/
      DATA IABS/2H  ,2HAB,2HS ,2H  /
      DATA IGO/2HID,2HEQ,2HDR,2HXL,2HLM,2HIN,2HLL,2HPM,2HXP,2HF/, 
     &         2HXF,2HLI,2HDI,2HLE,2HDL,2HDM,2HDS,2HTA,2HTR,2HXT, 
     &         2HDP,2HLP,2H??,2H/E,2HEX,2HEN,2HPG/
C 
      CALL RMPAR(LU)
      LU1=LU
      IF(LU1.EQ.0) LU1=1
      LU2 = LU1+200B
C 
      CALL EXEC(2,LU1,IBUF,25)
C 
      IPRMPT = 2H=
C 
C     SET UP THE IPRAM BUFFER.  THIS BUFFER IS USED BY THE I/O
C     SUBROUTINES (DOIO & DISC3) TO DETERMINE HOW THE I/O IS
C     TO BE DONE. 
C 
1     IPRAM = 1 
      IPRAM(2) = 0
      IPRAM(3) = 0
      IPRAM(4) = 0
      IPRAM(5) = 0
      IPRAM(6) = -1 
      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     FIND OUT WHICH COMMAND IT WAS 
C 
C 
      DO 20 I = 1,27
      IF(IPRS1.EQ.IGO(I)) GO TO(100,200,300,400,410,500,600,710,700,
     &810,800,900,900,900,1000,1100,1400,1500,1610,1600,1700,100,9000,
     &50,50,50,1900) I
20    CONTINUE
C 
C 
C      ILLEGAL COMMAND
C 
C 
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 
C 
150   DO 170 I = 1,257
      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 176 
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) = IGET(IGET(KYWORD)+14) 
C 
180   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) ISTOP = ISTART + 21
C 
C     SEE IF THIS IS 'ID' OR 'PL' COMMAND 
C 
      IF(IPRS1 .EQ.2HLP) GO TO 1800 
C 
C     'ID' COMMAND, SO GIVE HIM THE ID SEGMENT !! 
      CALL EXEC(3,LU2+1100B,1)
      CALL EXEC(2,LU2,IMESS1,-17) 
      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 = (IAND(IGET(ISTART+4),37400B)/256)
      IBUF = IBUF + 2*(IBUF/8)
      CALL CNUMD(IBUF,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 
C     GET THE DISC ADDRESS OF THE EQT 
      CALL DTRK(ISTART+11,ITRK,ISECTR,IWORD,ISTOP,IARRAY) 
C     GET THE SECTOR
      CALL EXEC(1,102B,IARRAY,64,ITRK,ISECTR) 
C     IF IT IS DVR00 THERE ARE NO EXTENTS 
C     IF # OF EXTENT WORDS IS NEG THERE ARE NO EXTENTS
      IF((IARRAY(IWORD).LT.1).OR.(IBUF(4).EQ.30060B)) GO TO 210 
      IDRT = IARRAY(IWORD)
C     NOW GET THE ADDRESS OF THE EXTENT 
      CALL DTRK(ISTART+12,ITRK,ISECTR,IWORD,ISTOP,IARRAY) 
      CALL EXEC(1,102B,IARRAY,64,ITRK,ISECTR) 
C     IF ADDRESS OF EXTENT IS NEG THERE ARE NO EXTENTS
      IF(IARRAY(IWORD).LT.1) GO TO 210
C 
C 
      CALL EXEC(3,LU2+1100B,1)
      CALL EXEC(2,LU2,IEXT,4) 
      CALL DOIO(IARRAY(IWORD),IARRAY(IWORD)+IDRT-1,LU2,IPRAM) 
210   CONTINUE
      GO TO 1 
C 
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 = 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 + 200B
      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).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 = IPRAM + 1 
850   CONTINUE
      IF(IPRAM(3).EQ.0) GO TO 190 
      GO TO 1 
C 
C 
C*******FIND ADDRESS OF SELECTED SYSTEM ENTRY POINTS********
C 
C 
C 
C 
C 
C 
900   ITRK = IGET(1761B)/128
      ISECTR = IAND(IGET(1761B),177B)-1 
      DO 993 I = 1,IGET(1762B)/16 + 1 
      ISECTR = ISECTR + 1 
      IF(ISECTR.NE.96) GO TO 910
      ISECTR = 0
      ITRK = ITRK + 1 
910   CALL EXEC(1,102B,IARRAY,64,ITRK,ISECTR) 
      DO 992 J = 1,64,4 
      IF(IFBRK(IDUMY))1,911 
911   IF(IPRS1.EQ.2HLE) GO TO 965 
      IF(((IARRAY(J).EQ.IPBUF(6)).AND.(IARRAY(J+1).EQ.IPBUF(7))).AND. 
     &(IOR(IAND(IARRAY(J+2),177400B),40B).EQ.IPBUF(8))) GO TO 970 
      GO TO 992 
C 
965   CALL EXEC(2,LU2,IARRAY(J),-5) 
C 
C 
C 
970   IF(IPRS1.EQ.2HDI) GO TO 995 
      MYTYPE = IAND(IARRAY(J+2),177B) + 1 
      GO TO (975,980,190,985,990) MYTYPE
C 
C 
975   CALL DOIO(IARRAY(J+3),IARRAY(J+3),LU2,IPRAM)
      IF(IPRAM(3).EQ.9999) GO TO 1
      IPRAM(3) = 1
      IPRAM = IPRAM + 1 
      GO TO 991 
C 
C 
980   CALL EXEC(2,LU2,LDISC,5)
      IDISC(6) = 2H 
      CALL CNUMD((IARRAY(J+3)/128),IDISC(9))
      CALL CNUMD(IAND(IARRAY(J+3),177B),IDISC(17))
      CALL EXEC(2,LU2,IDISC(6),14)
      GO TO 991 
C 
C 
C 
985   CALL CNUMO(IARRAY(J+3),IABS(5)) 
      CALL EXEC(2,LU2,IABS,7) 
      GO TO 991 
C 
C 
990   CALL CNUMO(IARRAY(J+3),IRP(4))
      CALL EXEC(2,LU2,IRP,6)
C 
991   IF(IPRS1.EQ.2HLI) GO TO 1 
992   CONTINUE
993   CONTINUE
      IF(IPRS1.EQ.2HLE) GO TO 1 
      GO TO 190 
C 
995   IPRAM = 0 
      CALL DISC3(2,ITRK,ISECTR,J,IARRAY,IPRAM,LU2,IDISC)
      GO TO 1 
C 
C 
C********LOOK AT ANY DISC LOCATION************
1000  DO 1050 J = 1,IPRS5 
      CALL EXEC(1,IPRS2 + 100B,IARRAY,64,IPRS3,IPRS4) 
      CALL DISC3(IPRS2,IPRS3,IPRS4,IPRAM,IARRAY,IPRAM,LU2,IDISC)
      IF(IPRAM(3).EQ.9999) GO TO 1
      IPRS4 = IPRS4 + 1 
      IF(IPRS4.LT.96) 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)
      CALL EXEC(2,LU1,MDISK,10) 
      CALL EXEC(2,LU1+2000B,IMESS7,7) 
      REG = REIO(1,LU1+400B,IBUF,1) 
      IF(IBUF.EQ.2H/D) GO TO 1
      IF(IBUF.NE.2HYE) GO TO 1150 
C 
C 
C 
C  ASK FOR THE LOCATION AND REPLACEMENT VALUE 
C 
1125  CALL EXEC(2,LU1+2000B,IVALUE,9) 
      REG = REIO(1,LU1 +400B,IBUF,10) 
      CALL PARSE(IBUF,IB*2,IPBUF) 
      IF(IPBUF.EQ.2) GO TO 1
      IFIX = IPRS2
      ILU = 2 
      INULL = IPBUF(5)
C 
      CALL DTRK(IPRS1,ITRK,ISECTR,IWORD,ISTOP,IARRAY) 
C SEE IF WORD IS BEYOND ACTUAL OP SYSTEM SIZE 
C 
      IF(IPRS1.GT.ISTOP) GO TO 30 
C 
      ASSIGN 1125 TO ILABEL 
C 
      GO TO 1210
C 
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(IPBUF.EQ.2) 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,64,ITRK,ISECTR) 
      IPRAM = 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  LUTYP = 0 
      IF(ILU.EQ.3) LUTYP = IGET(1756B)
      ITAT = IGET(1656B) + ITRK +LUTYP
      IARRAY(IWORD) = IFIX
      ISTART = IGET(ITAT) 
      IF(ILU.LT.4)CALL IPUT(ITAT,IGET(1717B)) 
C     !!!!!PATCH DISC!!!!!! 
      CALL EXEC(100002B,ILU+100B,IARRAY,64,ITRK,ISECTR) 
      GO TO 1310
C 
C     FIX TRACK ASSIGNMENT TABLE
1310  IF(ILU.LT.4)CALL IPUT(ITAT,ISTART)
C 
C 
C 
C 
      INULL = 0 
      GO TO 1210
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  DO 1450 I =0,95 
      CALL EXEC(1,IPRS2 + 100B,IARRAY,64,IPRS3,I) 
      DO 1425 J = 1,64
      IF(IARRAY(J).NE.IPRS4) GO TO 1425 
      CALL CNUMD(I,IDISC(17)) 
      CALL CNUMD(J,IDISC(24)) 
      CALL EXEC(2,LU2,IDISC(12),15) 
1425  CONTINUE
1450  CONTINUE
      GO TO 1 
C 
C*********** PRINT OUT THE TRACK ASSIGNMENT TABLE ******************
C 
1500  CALL EXEC(2,LU2,ITAT,12)
      IPRAM = 0 
      IF((IPRS2.GT.3).OR.(IPRS2.LT.0)) GO TO 25 
C     GET # OF TRACKS ON AUX DISC 
      INEED =-( IGET(1755B))- IGET(1756B) 
C     GET STOP ADDRESS OF TAT FOR SYS DISC
      ISTOP = IGET(1656B) + IGET(1756B) - 1 
      IF (IPRS2 .EQ. 3) GO TO 1510
C     PRINT OUT SYS DISC TRACK ASSIGNMENTS
      CALL EXEC(2,LU2,ISYS,5) 
C 
      IF(IPRS3.EQ.0) GO TO 1505 
      IPRAM = IPRS3 
C 
      ISTART = IGET(1656B) + IPRS3
      IF(ISTART .GT. ISTOP ) GO TO 25 
      IF(ISTART+IPRS4-1.LT.ISTOP)ISTOP=ISTART+IPRS4-1 
1505  CALL DOIO(IGET(1656B)+IPRS3,ISTOP,LU2,IPRAM)
C 
C 
      IF(IPRAM(3).EQ.9999) GO TO 1
1510  IF(IPRS2.EQ.2) GO TO 1
      IF (INEED .EQ.0 ) GO TO 1 
C 
      CALL EXEC(3,LU2+1100B,1)
      CALL EXEC(2,LU2,IAUX,5) 
      ISTART = ISTOP + 1 + IPRS3
      ISTOP = ISTOP + INEED 
      IF(ISTART .GT.ISTOP) GO TO 25 
      IF(IPRS3 .EQ. 0 ) GO TO 1520
      IPRAM = IPRS3 
      IF(ISTART+IPRS4-1 .LT. ISTOP)ISTOP = ISTART+IPRS4-1 
1520  CALL DOIO(ISTART,ISTOP,LU2,IPRAM) 
      IF(IPRAM(3) .EQ. 9999) GO TO 1
      GO TO 1 
C 
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*********DISPLAY WHATEVER THE USER HAS INPUT ************
C 
C 
1700  IARRAY = IPRS2
      IPRAM = 0 
      IPRAM(3) = 1
      CALL DISC3(1,1,1,1,IARRAY,IPRAM,LU2,IDISC)
      GO TO 1 
C 
C 
C*********DISPLAY ABSOLUTE PROGRAM ON THE DISC*********** 
C 
C 
1800  IF(ISTOP - ISTART .EQ. 21) GO TO 1880 
      IF(ISTOP - ISTART .EQ. 8) ISTOP = ISTOP +1
      ISTART = IGET(ISTOP-1)
      IPRS2 = 2 
      IF(ISTART.LT.0) IPRS2 = 3 
      ISECTR = IAND(ISTART,177B)
      ITRK = (IAND(ISTART,77777B)/128)
C     SET A FLAG FOR THE DTRK SUBROUTINE
      IARRAY = -1 
      CALL DTRK(IPRS3+2,IARRAY,IARRAY(2),IPRAM,ISTOP,IARRAY)
C     ON RETURN IARRAY(1) =TRK#,IARRAY(2) = SECTR#
C     IWORD = WORD #
C 
      IPRS3 = ITRK+IARRAY 
      IPRS4 = ISECTR + IARRAY(2)
      IPRS5 = 1 
      IPRAM(4) = 1
      IF((IPRS4 -95).LE.0) GO TO 1850 
C     OPPS TOO MANY SECTORS 
C 
      IPRS3 = IPRS3 + 1 
      IPRS4 = IPRS4 - 96
C 
1850  GO TO 1000
1880  CALL EXEC(2,LU1,MEMR,7) 
      GO TO 1 
C 
C 
C************ LIST ANY LOCATION IN PHYSICAL MEMORY *********
C 
C 
1900  IF(((IPRS2.GT.1023).OR.(IPRS2.LT.0)).OR.(IPRS3.LT.1)) GO TO 25
      CALL DUMMY(IARRAY,ISTART) 
      IF(IPRS4.LT.1024) GO TO 1910
      ISTOP = IPRS4/1024
      IPRS2 = IPRS2 + ISTOP 
      IPRS4 = IPRS4 -(ISTOP * 1024) 
C 
1910  ISTOP = 63
      J = IPRS3 
      IPRAM(2) = 1
C 
      DO 1950 I = 1,IPRS3,64
      IPRAM = IPRS4 
      IPRAM(6) = IPRS2
      CALL MAPXX(IPRS2,IPRS4,IARRAY)
      IF(J .LT. 64) ISTOP = J - 1 
      CALL DOIO(ISTART,ISTART + ISTOP,LU2,IPRAM)
C 
      IF(IPRAM(3).EQ.9999) GO TO 1
      IPRAM(3) = 1
      J = J - 64
1950  CONTINUE
      GO TO 1 
C 
C 
C********  MAKE THE PROGRAM FRIENDLY FOR THE PEOPLE  ************ 
C 
9000  DO 9025 I = 1,27
      IF(IPRS2.EQ.IGO(I)) GO TO(9100,9200,9300,9960,9400,9500,9600, 
     &9700,9970,9800,9980,9900,9988,9992,9905,9910,9920,9930,9984,
     &9984,9982,9990,25,9940,9940,9940,9994) I
9025  CONTINUE
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,IT,17)
      CALL EXEC(2,LU2,IN,8) 
      CALL EXEC(2,LU2,IM,15)
      CALL EXEC(2,LU2,IPR,14) 
      CALL EXEC(2,LU2,IDP,22) 
      CALL EXEC(2,LU2,IPG,19) 
      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,IG,11)
      CALL EXEC(2,LU2,IDI,28) 
      CALL EXEC(2,LU2,ILE,17) 
      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 
9900  CALL EXEC(2,LU2,ITEL15,11)
      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 
9930  CALL EXEC(2,LU2,ITEL26,2) 
      CALL EXEC(2,LU2,ITEL27,5) 
      CALL EXEC(2,LU2,ITEL28,13)
      GO TO 9999
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 
9988  CALL EXEC(2,LU2,ITEL33,11)
      GO TO 1 
9990  CALL EXEC(2,LU2,ITEL34,13)
      GO TO 9999
9994  CALL EXEC(2,LU2,ITEL36,13)
C 
9999  MORUSE(6) = IPRS2 
      CALL EXEC(2,LU2,MORUSE,8) 
      GO TO 1 
9992  CALL EXEC(2,LU2,ITEL35,2) 
      GO TO 1 
      END 
      SUBROUTINE DOIO(ISTART,ISTOP,LU,IPRAM)
      DIMENSION IBUF(25),IMESS(27),IPRAM(6),LMESS(17) 
      DIMENSION IPAGE(11) 
      INTEGER OBUF(37)
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 IPAGE/2H  ,2HPH,2HYS,2HIC,2HAL,2H P,2HAG,2HE / 
      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     IPRAM(6) =+N MEANS A MAPPED IN LISTING OF PHYS MEMORY 
C                  WHERE N = PHYSICAL PAGE NUMBER 
C     IPRAM(6) =-1 MEANS WE ARE DOING NORMAL I/O
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 
C 
      IF(IPRAM(5).EQ.1) GO TO 500 
C 
      IF(IPRAM(6).LT.0) GO TO 1 
      CALL CNUMD(IPRAM(6),IPAGE(9)) 
      CALL EXEC(2,LU,IPAGE,11)
1     IF(IPRAM(3).EQ. 0) CALL EXEC(2,LU,IMESS,-54)
C 
C 
      DO 100 I = ISTART,ISTOP 
      K = K + 1 
      IF((IPRAM(6).LT.0).OR.(K.NE.1024)) GO TO 2
      K = 0 
      IPRAM(6) = IPRAM(6) + 1 
2     CALL CNUMD(K,IBUF(3)) 
      IF(IPRAM(2) .EQ.1) CALL CNUMO(K,IBUF(3))
      CALL CNUMO(I,IBUF(8)) 
      IF(IPRAM(6).LT.0) GO TO 5 
      CALL CNUMD(IPRAM(6),IBUF(8))
      IBUF(8) = 2HPG
5     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 
      IF(IPRAM(6).LT.0) GO TO 551 
      CALL CNUMO(IPRAM,LMESS(7))
      CALL CNUMO(IPRAM+ISTOP - ISTART,LMESS(15))
      CALL CNUMD(IPRAM(6),IPAGE(9)) 
C 
551   CALL EXEC(3,LU + 1100B,1) 
      IF(IPRAM(6).GE.0) CALL EXEC(2,LU,IPAGE,11)
      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(64),IPRAM(6),IBUF(17)
      INTEGER 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 64 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 64 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(4) = 1 THEN 64 WORDS ARE OUTPUT PLUS THE WORD # 
C    IF IPRAM(5) = 0 THEN A PACKED LISTING IS DESIRED 
C 
      CALL CNUMD(INDEX,IDISC(24)) 
      IF(IPRAM .EQ.0) GO TO 55
      NUMBR = 64
      INDEX = 1 
      ID = 19 
      IF(IPRAM(4).EQ.1) ID = 26 
      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))
      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,8 
      CALL PACK(8,1,IPOINT,OBUF)
      CALL EXEC(2,LU2,OBUF,37)
      IPOINT = IPOINT + 8 
      IF(IFBRK(IDUMY)) 999,3000 
3000  CONTINUE
      END 
      SUBROUTINE DTRK(IPRS1,ITRK,ISECTR,IWORD,ISTOP,IARRAY) 
      DIMENSION IARRAY(64)
C 
C     SEE WHETHER WE ARE LOOKING AT A PROGRAM OR OP SYS.
C 
      IF(ITRK.GE.0) GO TO 1200
C 
C     A PROGRAM ! 
C 
      IPAST = IPRS1 
      ISTART = 0
      GO TO 1240
C 
1200  CALL EXEC(1,102B,IARRAY,64,0,1) 
      DO 1207 I = 1,64
      IF(((IARRAY(I).EQ.2).AND.(IARRAY(I+1).EQ.2000B)).AND. 
     &(IARRAY(I+3).EQ.2000B))GO TO 1208 
1207  CONTINUE
C 
C 
C     GRANDFATHER DISC
C 
C 
C     BASE PAGE STARTS HERE 
      IBASE = 2 
C     ASSUME OP SYSTEM ENDS HERE
      ISTOP = 77770B
C     OP SYSTEM STARTS HERE 
      ISTART = 18 
C 
      GO TO 1233
C 
C 
C     STARTING SECTOR OF OP SYSTEM ON DISC
1208  ISTART = IARRAY(I+5)
C     LAST WORD OF OP SYSTEM
      ISTOP = IARRAY(I+4) 
C     STARTING SECTOR OF BASE PAGE VALUES ON THE DISC 
      IBASE = IARRAY(I+2) 
C 
C 
C SEE IF WORD IS ON BASE PAGE 
C 
1233  IPAST = IPRS1 - 1024
      IF(IPAST.GE. 0) GO TO 1240
C 
C     WORD ON BASE PAGE 
C 
      ITRK = 0
      ISTART = IBASE
      ITEMP = IPRS1 - 2 
      GO TO 1250
C 
C 
1240  ITRK = IPAST/6144 
      ITEMP = IPAST - (ITRK * 6144) 
1250  ISECTR = ITEMP/64 
      IWORD = ITEMP - (ISECTR * 64) 
      ISECTR = ISECTR +ISTART 
      IF((ISECTR - 95).LE.0) GO TO 1210 
C 
C OOPS TOO MANY SECTORS 
C 
      ITRK = ITRK + 1 
      ISECTR = ISECTR - 96
C 
C 
C 
C     CHANGE RANGE OF WORD FROM 0-63 TO 1-64 SO FORTRAN CAN HANDLE IT.
1210  IWORD = IWORD + 1 
      END 
ASMB,L
      NAM IXGET,7 
      ENT IXGET,XPUT,PACK,IASCI,DUMMY,MAPXX 
*     ENT IGET,IPUT 
      EXT $LIBR,$LIBX,.ENTR,.ENTP 
* 
* 
* 
*GET  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 
* 
* 
* 
*PUT  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 
D64   DEC 64
D1024 DEC 1024
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 
DM64  DEC -64 
SIGN  OCT 100000
* 
* 
*            ************************************** 
*            * MAP IN ANY PAGE OF PHYSICAL MEMORY * 
*            ************************************** 
* 
* 
* THE PURPOSE OF THIS SUBROUTINE IS TO MAP IN THE PAGE REQUESTED
* AND READ 64 WORDS OF THAT MAPPED PAGE.  THE ROUTINE IS FORTRAN
* CALLABLE.  TO BE USED ONE OF TWO CONDITIONS MUST BE MET.
* THE PROGRAM USING THE ROUTINE MUST NOT BE GREATER THAN 30K
* IN LENGTH (IE IF PROGRAM IS 10K AND LARGEST ADDRESSABLE 
* PARTITION IS 12K YOUR OK. IF LARGEST ADDRESSABLE PARTITION IS 
* 11K YOU HAVE PROBLEMS).  ALTERNATELY IF THE PROGRAM EXTENDS 
* INTO THE LAST TWO PAGES OF MEMORY MAKE SURE THIS ROUTINE
* AND THE INPUT PARAMETERS TO THIS ROUTINE DO NOT RESIDE THERE
* AND YOU WILL BE ALLRIGHT. 
* 
* THE PROGRAM MODIFIES THE USER MAP REGISTERS BUT ALSO RESTORES THEM. 
* 
* 
*      CALLING SEQUENCE  JSB MAPXX
*                        DEF RETURN 
*                        DEF PAGE#
*                        DEF OFFSET     (NOT GREATER THAN 1023 DECIMAL) 
*                        DEF ARRAY      (ARRAY OF 64 WORDS) 
* 
* 
* 
PAGE# NOP 
OFSET NOP 
ARRAY NOP 
* 
MAPXX NOP 
      JSB $LIBR 
      NOP 
      JSB .ENTP 
      DEF PAGE# 
* 
      LDA MPBUF     GET THE ADDRESS OF THE MAP BUFFER 
      ADA SIGN      SET THE SIGN BIT SO IT IS A READ
      USA           GET THE USER MAP
* 
      LDA MAP31     GET THE OLD VALUE 
      STA OLD31     AND SAVE IT 
      LDA MAP32     OLD VALUE.
      STA OLD32     SAVE THIS TOO 
      LDB PAGE#,I   GET THE DESIRED PAGE
      STB MAP31     PUT IT INTO THE OLD PAGE
      INB           BUMP PAGE # TO ACCOUNT FOR OVERFLOW 
      STB MAP32     SET NEXT PAGE INTO THE LAST LOCATION
* 
      LDA MPBUF     GET THE USER MAP BUFFER ADDRESS 
      USA           !!!!!! LOAD THE USER MAP !!!!!! 
* 
* 
* 
      LDA DM64      GET LOOP INDEX
      STA XTEMP 
      LDA START     GET THE START ADDRESS 
      ADA OFSET,I   ADD IN THE OFFSET 
      STA YTEMP     SAVE POINTER
      LDA ARRAY     GET ARRAY ADDRESS 
MLOOP LDB YTEMP,I   GET THE WORD
      STB A,I       AND PUT INTO BUFFER 
      ISZ YTEMP     BUMP OUR
      INA           POINTERS
      ISZ XTEMP     DONE ?
      JMP MLOOP     NO
* 
* 
      LDA OLD31     YES RESTORE THE USER MAP
      STA MAP31 
      LDA OLD32 
      STA MAP32 
* 
      LDA OFSET,I   GET THE OFFSET
      ADA D64       ADD 64 WORDS FOR WHAT WE JUST DID 
      CLB 
      DIV D1024     DIVIDE NEW OFFSET BY # OF WORDS IN PAGE 
      ADA PAGE#,I   ADD OLD PAGE # TO GIVE NEW PAGE # 
      STA PAGE#,I   AND SEND THE RESULT BACK
      STB OFSET,I   SEND THE NEW OFFSET BACK TOO
* 
      LDA MPBUF 
      USA           !!!!!!  RESTORE THE USER MAP  !!!!!!! 
* 
      JSB $LIBX     RESTORE INTERUPT SYSTEM 
      DEF MAPXX     AND RETURN TO CALLER
* 
* 
* 
START OCT 74000     START ADDRESS OF NEWLY MAPPED AREA
MPBUF DEF MAPIT 
MAPIT BSS 30         BUFFER FOR 1ST 30 WORDS OF USER MAP
MAP31 NOP            THIS LOCATION IS USED TO CHANGE MAP
MAP32 NOP            THIS LOCATION IS FOR I/O OVERFLOW
OLD31 NOP 
OLD32 NOP 
* 
* 
      END 
FTN4,L
      END$