FTN4
      PROGRAM CMM4 (3,90),24999-16202 REV.1938 790911 
C 
C 
C                  MIKE MANLEY          RTE IV VERSION
C                                       9/11/79  EFH
C 
C 
      DIMENSION IPBUF(33),LU(5),IBUF(30),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(14)
      DIMENSION IARRAY(64),IDISC(36),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(9),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(17),ITEL16(16) 
      DIMENSION ITEL17(21),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(32),IRP(6),INBS(10) 
      DIMENSION IPG(19),ITEL36(14),IPP(22),ITEL37(14),IFUN(4) 
      DIMENSION INS(16),ITEL38(27),IMS(23),ITEL39(23),ISOR(19)
C ^ 
      DIMENSION IFPHD(29),IFPMS(17),IKIL(18),IFP(14),IFPAR(6),ILSEC(8)
      DIMENSION IBDSK(10),IEP(16),INOT4(16),INMOD(21) 
      DIMENSION ISKP(10),IWLU(8),IWRN(8)
      EQUIVALENCE(IREG,REG,IA),(IREG(2),IB) 
      EQUIVALENCE(IPBUF(2),IPRS1),(IPBUF(6),IPRS2),(IPBUF(10),IPRS3)
      EQUIVALENCE(IPBUF(14),IPRS4),(IPBUF(18),IPRS5)
      EQUIVALENCE(IPBUF(22),IPRS6),(IPBUF(26),IPRS7)
      EQUIVALENCE(IPBUF(30),IPRS8)
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:,2H _/ 
      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,2HM4,2H D,2HON,2HE ,2H! /
      DATA IBUF/2H  ,2HCM,2HM4,2H !,2H T,2HHE,2H R,2HTE,
     &            2H I,2HV ,2H S,2HYS,2HTE,2HM ,2H M,2HOD,
     &            2H/A,2HNA,2HLI,2HZE,2H P,2HRO,2HGR,2HAM,2H !, 
     &            2H  ,2H09,2H/1,2H1/,2H79/ 
      DATA IMESS7/2H  ,2HYE,2HS ,2HOR,2H N,2HO ,2H?_/ 
      DATA IMESS8/2HIN,2HT ,2HTA,2HBL ,2HE ,2HST,2HAR,2HTS, 
     &            2H A,2HT ,2H6./ 
C ^ 
      DATA IDISC/2H  ,2HLU,2H =,2H  ,2H  ,2H  ,2H  ,2HTR,2HK ,2H= , 
     &      2H  ,2H  ,2H  ,2H  ,2HSE,2HCT,2HR ,2H= ,2H  ,2H  ,2H  , 
     &      2H  ,2HWO,2HRD,2H =,2H  ,2H  ,2H  ,2H  ,2HOL,2HD(,2H8), 
     &      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 ,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,,2H W,2HOR,2HD , 
     &            2HTO,2H F,2HIN,2HD ,2H, ,2H(5,2H W,2HOR,2HDS, 
     &            2H M,2HAX,2H) / 
      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,2H,*,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#,,2HOF,2HFS,2HET,2H,#,2H O,
     &2HF ,2HWO,2HRD,2HS /
      DATA ITEL37/2H  ,2HPP,2H, ,2HPG,2H#,,2H O,2HFF,2HSE,2HT,, 
     &2H N,2HEW,2H V,2HAL,2HUE/ 
      DATA ITEL38/2H  ,2HNS,2H, ,2H# ,2HOF,2H S,2HEC,2HTS,2H/T,2HRK,
     &                      2H, ,2H# ,2HOF,2H S,2HEC,2HTS,2H/T,2HRK,
     &2H  ,2H(F,2HOR,2H M,2HS ,2HCO,2HMM,2HAN,2HD)/ 
      DATA ITEL39/2H  ,2HMS,2H, , 
     &            2HLU,2H,T,2HRK,2H,S,2HEC,2HTR,2H, , 
     &            2HLU,2H,T,2HRK,2H,S,2HEC,2HTR,2H, , 
     &            2H# ,2HOF,2H S,2HEC,2HTR,2HS /
      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 IPP/2H  ,2HPP,2H  ,2HMO,2HDI,2HFY,2H A,2HNY,2H L,2HOC, 
     &2HAT,2HIO,2HN ,2HIN,2H P,2HHY,2HSI,2HCA,2HL ,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 INBS/2H# ,2HOF,2H S,2HEC,2HTO,2HRS,2H =/ 
      DATA ISOR/2H  ,2H  ,2H  ,2H  ,
     &          2HSO,2HUR,2HCE,2H I,2HS:,2H  ,2H  , 
     &          2HDE,2HST,2HIN,2HAT,2HIO,2HN ,2HIS,2H: /
      DATA INS/2H  ,2HNS,2H  ,2HSE,2HT ,2H# ,2H O,2HF ,2HSE,2HCT,2HRS,
     &2H P,2HER,2H T,2HRA,2HCK/ 
      DATA IMS/2H  ,2HMS,2H  ,2HMO,2HVE,2HS ,2HDI,2HSC,2H S,2HEC,2HTO,
     &2HRS,2H T,2HO ,2HAN,2HOT,2HHE,2HR ,2HDI,2HSC,2H A,2HRE,2HA /
      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,2HEP,2HDL,2HDM,2HDS,2HTA,2HTR,2HXT,
     &         2HDP,2HLP,2H??,2H/E,2HEX,2HEN,2HPG,2HPP,2HMS,2HNS,2HFP/
C 
      DATA NSECTS/96/ 
      DATA NSECT2/96/ 
      DATA IFUN/2H,*,2H,/,2H,+,2H,-/
C ^ 
      DATA IFPHD/2H  ,2HFO,2HOT,2HPR,2HIN,2HT ,2HAR,2HEA,2H :,2H #, 
     &          2H O,2HF ,2HCH,2HAN,2HGE,2HS ,2H= ,2H  ,2H  , 
     &          2H  ,2H  ,2HLA,2HTE,2HST,2H 1,2H90,2H S,2HAV,2HED/
      DATA IFPMS/2H  ,2HNU,2HMB,2HER,2H O,2HF ,2HSE,2HCT,2HOR,2HS ,2HMO,
     &           2HVE,2HD ,2H= ,2H  ,2H  ,2H  / 
      DATA IKIL/2H  ,2HTU,2HRN,2H O,2HFF,2H D,2HIS,2HK ,2HWR,2HIT,2HE , 
     &           2HPR,2HOT,2HEC,2HT ,2HON,2H L,2HU2/
      DATA IFP/2H  ,2HFP,2H  ,2HDI,2HSP,2HLA,2HY ,2HPA,2HST,2H D,2HIS,
     &           2HK ,2HMO,2HDS/
      DATA ILSEC/2H  ,2HIL,2HLE,2HGA,2HL ,2HSE,2HCT,2HOR/ 
      DATA IBDSK/2H  ,2HBA,2HD ,2HDI,2HSK,2H R,2HEF,2HER,2HEN,2HCE/ 
      DATA IEP/2H  ,2HEP,2H  ,2HEJ,2HEC,2HT ,2HPA,2HGE,2H I,2HF , 
     &         2HLI,2HNE,2H P,2HRI,2HNT,2HER/ 
      DATA INOT4/2H  ,2HNO,2HT ,2HRU,2HNN,2HIN,2HG ,2HON,2H A,
     &           2H R,2HTE,2H-I,2HV ,2HSY,2HST,2HEM/
      DATA INMOD/2H  ,2HNO,2HT ,2HAL,2HLO,2HWE,2HD-,2H-R,2HUN,
     &           2HNI,2HNG,2H N,2HO ,2HDI,2HSC,2H M,2HOD,2H V,
     &           2HER,2HSI,2HON/
      DATA ISKP/2HPP,2HLL,2HPM,2HXP,2HDM,2HMS,2HNS,2H/E,
     &           2HEX,2HEN/ 
      DATA IWLU/2H  ,2HWA,2HIT,2HIN,2HG ,2HFO,2HR ,2HLU/
      DATA IWRN/2H  ,2HWA,2HIT,2HIN,2HG ,2HFO,2HR ,2HRN/
      CALL RMPAR(LU)
      LU1=LU
      IF(LU1.EQ.0) LU1=1
      LU2 = LU1+200B
C 
C NO FOOTPRINT CHECK DONE IF : RU,CMM4,,,,,NF 
C 
      INFP = LU(5)
      IF (INFP.EQ.2HNF) GO TO 15
C ^ 
C NO GO IF WE CANNOT INITIALIZE ON LU 2 
C 
      CALL CINIT (IARRAY) 
      IF (IARRAY(1).NE.1) GO TO 5 
      CALL EXEC (2,LU1,IKIL,-36)
      GO TO 50
5     DO 10 I = 2,7 
      IFPAR(I-1) = IARRAY(I)
10    CONTINUE
C 
15    CALL EXEC(2,LU1,IBUF,30)
      IF (IRTE4(I).NE.-9) GO TO 45
C 
      IPRMPT = 2H=_                                                     * 
      INTER = IFTTY(LU1)
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 
C     UNLOCK LIST DEVICE
1     CALL LURQ (100000B,LU2-200B,1)
      IPRAM = 1 
      IPRAM(2) = 0
      IPRAM(3) = 0
      IPRAM(4) = 0
      IPRAM(5) = 0
      IPRAM(6) = -1 
      CALL EXEC(2,LU1,IPRMPT,-2)
      REG = REIO(1,LU1 + 400B,IBUF,30)
      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     LOCK LIST DEVICE EXCEPT IF INTERACTIVE DEVICE 
C     OR INTERACTIVE OR NONLISTING COMMAND
C 
      IF (INTER.EQ.-1) GO TO 19 
      DO 16 I = 1,10
      IF (IPRS1.EQ.ISKP(I)) GO TO 19
16    CONTINUE
      IRQFG = -1
17    CALL LURQ(100001B,LU2-200B,1) 
      CALL ABREG(IA,IB) 
      IF (IA.EQ.0) GO TO 19 
      IF (IA.EQ.-1) GO TO 18
      IF (IRQFG.EQ.-1) CALL EXEC (2,LU1,IWLU,8) 
      IRQFG = 0 
      GO TO 21
18    IF (IRQFG.EQ.-1) CALL EXEC (2,LU1,IWRN,8) 
      IRQFG = 0 
21    CALL EXEC  (12,0,2,0,-5)
      IF (IFBRK(IDMY)) 1,17 
C 
C 
C     FIND OUT WHICH COMMAND IT WAS 
C 
C 
19    DO 20 I = 1,32
      IF(IPRS1.EQ.IGO(I)) GO TO(100,200,300,400,410,500,600,710,700,
     &810,800,900,900,900,2400,1000,1100,1400,1500,1610,1600,1700,
     &100,9000,50,50,50,1900,1900,2100,2200,2300) 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 
35    CALL EXEC(2,LU1,INMOD,21) 
      GO TO 1 
40    CALL EXEC (2,LU1,IBDSK,10)
      GO TO 1 
45    CALL EXEC(2,LU1,INOT4,16) 
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 +32
C ITEMP IS THE PROGRAM TYPE 
      ITEMP = IAND(IGET(IGET(KYWORD) +14),17B)
C ITEMP1 IS THE ID SEGMENT TYPE 
      ITEMP1= IAND(IGET(IGET(KYWORD) +14),20B)
      IF(ITEMP1.EQ.20B) ISTART= IGET(KYWORD) +11
      IF(ITEMP1.EQ.20B) ISTOP = ISTART + 8
C 
C     SEE IF THIS IS 'ID' OR 'LP' COMMAND 
C 
      IF(IPRS1 .EQ.2HLP) GO TO 1800 
C 
C     'ID' COMMAND, SO GIVE HIM THE ID SEGMENT !! 
      CALL EXEC(3,LU2+700B,1) 
      CALL EXEC(2,LU2,IMESS1,-17) 
      CALL DOIO(ISTART,ISTOP,LU2,IPRAM) 
C 
C     IF NOT EMA OR IF IT'S A SEGMENT OR MEM RES
C     THEN DON'T PRINT THE ID EXTENSION 
C 
      IF((ITEMP1 .EQ. 20B).OR. (ITEMP .EQ. 1)) GO TO 185
      IF(IGET(IGET(KYWORD)+28).EQ.0) GO TO 185
C     GET THE ID EXTENSION
      ISTART = IDEX(IGET(KYWORD)) 
      CALL EXEC(2,LU2,IEXT,4) 
      CALL DOIO(ISTART,ISTART+2,LU2,IPRAM)
185   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+700B,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+700B,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) = 20061B
C 
C 
      CALL EXEC(2,LU2,IMESS3,6) 
      IF(IPRS3.GT.LUMAX) IPRS3 = LUMAX
      IF(IPRS2.LE.0) IPRS2 = 1
      IF (IPBUF(9).EQ.0) IPRS3 = IPRS2
      CALL DOIO(IDRT + IPRS2-1,IDRT + IPRS3-1,LU2,IPRAM)
      IMESS3(6) = 20062B
      CALL EXEC(3,LU2+700B,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 
410   IF (IPRS3.LE.0) IPRS3 = 1 
      IF (IPRS2.LT.0) GO TO 30
      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 (IPBUF(9).EQ.0) IPRS3 = IPRS2
      ISTART = INTBA + IPRS2 -6 
      ISTOP = INTBA +IPRS3 -6 
      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
      INTER = IFTTY(IPRS2)
C     CHECK IF LEGAL LU 
      CALL EXEC(100015B,IPRS2,ISTA1)
      GO TO 25
610   GO TO 1 
C 
C 
C 
C     ***********PATCH MEMORY ANY MEMORY LOCATION**************** 
C 
700   IPRAM(4) = -1 
710   CALL DOIO(IPRS2,IPRS2,LU2,IPRAM)
      IF (LU1.NE.LU2-200B) CALL DOIO(IPRS2,IPRS2,LU1,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 IXPUT(IPRS2,IPRS3) 
      CALL DOIO(IPRS2,IPRS2,LU2,IPRAM)
      IF (LU1.NE.LU2-200B) CALL DOIO(IPRS2,IPRS2,LU1,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) GO TO 30
      DO 850 I = IPRS3,IPRS3+IPRS4-1
      IF(IPRAM(4).EQ.-1) GO TO 815
      IF(IGET(I).EQ.IPRS2) GO TO 820
      GO TO 850 
815   IF(IXGET(I).EQ.IPRS2) 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 
      IPRAM(4) = -1 
      ICT = 1 
C ^ 
      DO 993 I = 1,(IGET(1762B)+IGET(1764B)+15)/16
      ISECTR = ISECTR + 1 
      IF(ISECTR.NE.IGET(1757B)) 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   IF (IPRS3.EQ.0) IPRS3 = 1 
      CALL DOIO(IARRAY(J+3),IARRAY(J+3)+IPRS3-1,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(7) = 2H 
      CALL CNUMD((IARRAY(J+3)/128),IDISC(11)) 
      CALL CNUMD(IAND(IARRAY(J+3),177B),IDISC(19))
      CALL EXEC(2,LU2,IDISC(7),15)
      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 
C ^ 
      IF (ICT.EQ.(IGET(1762B)+IGET(1764B))) GO TO 1 
      ICT = ICT + 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  INSEC = NSECTS
      IF(IPRS2 .LE. 3) INSEC = IGET(1755B + IPRS2)
      DO 1050 J = 1,IPRS5 
      CALL EXEC(100001B,IPRS2 + 100B,IARRAY,64,IPRS3,IPRS4) 
      GO TO 40
1010  CALL DISC3(IPRS2,IPRS3,IPRS4,IPRAM,IARRAY,IPRAM,LU2,IDISC)
      IF(IPRAM(3).EQ.9999) GO TO 1
      IPRS4 = IPRS4 + 1 
      IF(IPRS4.LT.INSEC) 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  IF (INFP.EQ.2HNF) GO TO 35
      CALL EXEC(2,LU1,IGTOUT,27)
      CALL EXEC(2,LU1,MDISK,10) 
      CALL EXEC(2,LU1,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(3,LU2+700B,1) 
      CALL EXEC(2,LU1,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 1205
C 
C 
C** THIS SECTION ALLOWS MODIFICATION OF ANY DISC**
C 
C 
1150  CALL EXEC(2,LU2,IMESS1,1) 
      CALL EXEC(2,LU1,IVALU2,14)
      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 
1205  IPRAM(6) = 0
1210  CALL EXEC(100001B,ILU+100B,IARRAY,64,ITRK,ISECTR) 
      GO TO 40
1220  IPRAM = 0 
      CALL DISC3(ILU,ITRK,ISECTR,IWORD,IARRAY,IPRAM,LU2,IDISC)
      IF (LU1.NE.LU2-200B)
     &CALL DISC3(ILU,ITRK,ISECTR,IWORD,IARRAY,IPRAM,LU1,IDISC)
C 
      IF (INULL.EQ.0) GO TO ILABEL
      CALL EXEC(2,LU1,IMESS7,-14) 
      CALL REIO(1,LU1+400B,IPBUF(7),1)
      IF(IPBUF(7).NE. 2HYE) GO TO ILABEL
C ^ 
C CHECK THAT IS NOT FP AREA 1ST TRK AND SECTR 
      IF ((ILU.EQ.2).AND.(ITRK.EQ.IFPAR(5)).AND.(ISECTR.EQ.IFPAR(6))) 
     &     GO TO 1320 
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
C ^ 
      ITEMP = IARRAY(IWORD) 
      IARRAY(IWORD) = IFIX
      ISTART = IGET(ITAT) 
      IF(ILU.LT.4)CALL IPUT(ITAT,IGET(1717B)) 
C     !!!!!PATCH DISC!!!!!! 
      CALL EXEC(100002B,ILU+74100B,IARRAY,64,ITRK,ISECTR) 
      GO TO 1310
C ^ 
1305  IF(ILU.LT.4) CALL IPUT(ITAT,ISTART) 
      CALL EXEC (1,ILU+100B,IARRAY,64,ITRK,ISECTR)
      IF (IARRAY(IWORD).NE.IFIX) GO TO 1315 
      CALL IMFP(IFPAR,ILU,ITRK,ISECTR,IWORD-1,ITEMP,IARRAY) 
      GO TO 1315
C 
C     FIX TRACK ASSIGNMENT TABLE
1310  IF(ILU.LT.4)CALL IPUT(ITAT,ISTART)
C 
C 
C 
C 
1315  IPRAM(6) = 1
      INULL = 0 
      GO TO 1210
1320  CALL EXEC(2,LU1,ILSEC,8)
      GO TO 1 
C 
C 
C 
C 
C**********************DISC SEARCH ROUTINE************************
C 
C 
C 
C***          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 
1400  ISTOP = 0 
      JK = 1
      KK = 5
      I = 0 
      IF(IPBUF(33).LT.4) GO TO 25 
      CALL EXEC(100001B,IPRS2,IARRAY,64,IPRS3,I)
      GO TO 40
C 
C 
1405  DO 1410 K = 1,5 
      LU(K) = IARRAY(K) 
1410  CONTINUE
C 
C 
1415  DO 1420 K = 1,IPBUF(33)-3 
      IF(LU(K).NE.IPBUF(10 + K*4)) GO TO 1430 
1420  CONTINUE
C 
C 
      ISTART = I
      ISTOP = 1 
      IF(JK + 4 .GT. 64) ISTART = I - 1 
      CALL CNUMD(ISTART,IDISC(19))
      CALL CNUMD(JK,IDISC(26))
      CALL EXEC(2,LU2,IDISC(14),15) 
C 
C 
1430  DO 1440 K = 1,4 
      LU(K) = LU(K + 1) 
1440  CONTINUE
C 
C 
      JK = JK + 1 
      IF(JK .EQ. 65) JK = 1 
      KK = KK + 1 
      IF(KK.EQ.65) GO TO 1475 
1450  LU(5) = IARRAY(KK)
      GO TO 1415
C 
C 
1475  I = I + 1 
      KK = 1
      IF(I .EQ. NSECTS) GO TO 1495
      CALL EXEC(1,IPRS2,IARRAY,64,IPRS3,I)
      GO TO 1450
C 
C 
1495  IF(ISTOP .EQ. 0) GO TO 190
      GO TO 1 
C 
C 
C 
C*********** PRINT OUT THE TRACK ASSIGNMENT TABLE ******************
C 
1500  CALL EXEC(2,LU2,ITAT,12)
      IPRAM = 0 
      IF (IPRS4.LE.0) IPRS4 =1
      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+700B,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  IF(IPRS3.EQ.0) GO TO 1750 
      IF(IPRS3.EQ.2H* )IPRS2 = IPRS2*IPRS4
      IF(IPRS3.EQ.2H+ )IPRS2 = IPRS2+IPRS4
      IF(IPRS3.EQ.2H/ )IPRS2 = IPRS2/IPRS4
      IF(IPRS3.EQ.2H- )IPRS2 = IPRS2-IPRS4
1750  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(ITEMP.EQ.1) GO TO 1880 
      IF(ISTOP - ISTART .EQ. 8) ISTOP = ISTOP +6
      ISTART = IGET(ISTOP - 6)
      IPRS2 = 2 
      IF(ISTART.LT.0) IPRS2 = 3 
      INSEC = IGET(IPRS2 + 1755B) 
      ISECTR = IAND(ISTART,177B)
      ITRK = (IAND(ISTART,77777B)/128)
C     DO NOT OFFSET A SEGMENT 
      IF (ITEMP.NE.5) IPRS3 = IPRS3 + 34
C     SET A FLAG FOR THE DTRK SUBROUTINE
      IARRAY = -IPRS2 
      CALL DTRK(IPRS3,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 -INSEC - 1).LE.0) GO TO 1850
C     OPPS TOO MANY SECTORS 
C 
      IPRS3 = IPRS3 + 1 
      IPRS4 = IPRS4 - INSEC 
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))GO TO 25 
      IF((IPRS1.EQ.2HPG).AND.(IPRS4.LT.1)) GO TO 25 
      CALL DUMMY(IARRAY,ISTART) 
      IF(IPRS3.LT.1024) GO TO 1910
      ISTOP = IPRS3/1024
      IPRS2 = IPRS2 + ISTOP 
      IPRS3 = IPRS3 -(ISTOP * 1024) 
C 
1910  ISTOP = 63
      J = IPRS4 
      IPRAM(2) = 1
C 
      DO 1950 I = 1,IPRS4,64
      IPRAM = IPRS3 
      IPRAM(6) = IPRS2
      IF(IPRS1 .EQ. 2HPP) GO TO 2000
      CALL MAPXX(IPRS2,IPRS3,IARRAY,1,0)
      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************MODIFY ANY LOCATION IN PHYSICAL MEMORY*********************
C 
C 
2000  CALL MAPXX(IPRS2,IPRS3,IARRAY,3,0)
      CALL DOIO(ISTART,ISTART,LU2,IPRAM)
      IF (LU1.NE.LU2-200B) CALL DOIO(ISTART,ISTART,LU1,IPRAM) 
      CALL EXEC(2,LU1,IMESS7,-14) 
      CALL REIO(1,LU1+400B,IPBUF(7),1)
      IF(IPBUF(7).NE.2HYE) GO TO 1
      CALL MAPXX(IPRS2,IPRS3,IARRAY,2,IPRS4)
      CALL MAPXX(IPRS2,IPRS3,IARRAY,3,0)
      CALL DOIO(ISTART,ISTART,LU2,IPRAM)
      IF (LU1.NE.LU2-200B) CALL DOIO(ISTART,ISTART,LU1,IPRAM) 
      GO TO 1 
C 
C 
C********************* MOVE DATA ON THE DISC ***************************
C 
C 
C  THIS SECTION OF CMM4 CAN DESTROY A SYSTEM FASTER AND BETTER
C  THAN ANYTHING I KNOW.
C  YOU ARE LITERALLY TAKING YOUR LIFE IN YOUR HANDS !!!!!!
C 
2100  IF (INFP.EQ.2HNF) GO TO 35
      INSECS = NSECTS 
      INSEC2 = NSECT2 
      IF(IPRS2 .LT. 4) INSECS = IGET(1755B + IPRS2) 
      IF(IPRS5 .LT. 4) INSEC2 = IGET(1755B + IPRS5) 
      IPRAM(5) = 1
      IPRAM(2) = 1
C ^ 
      ITEMP = IOR(IPRS7,100000B)
      CALL EXEC(2,LU1,ISOR(5),5)
      CALL DISC3(IPRS2,IPRS3,IPRS4,ISTART,IARRAY,IPRAM,LU2,IDISC) 
      IF (LU1.NE.LU2-200B)
     &CALL DISC3(IPRS2,IPRS3,IPRS4,ISTART,IARRAY,IPRAM,LU1,IDISC) 
      CALL EXEC(2,LU1,ISOR(12),8) 
      CALL DISC3(IPRS5,IPRS6,IPRS7,ISTART,IARRAY,IPRAM,LU2,IDISC) 
      IF (LU1.NE.LU2-200B)
     &CALL DISC3(IPRS5,IPRS6,IPRS7,ISTART,IARRAY,IPRAM,LU1,IDISC) 
      CALL CNUMD(IPRS8,INBS(8)) 
      CALL EXEC(2,LU1,INBS,10)
      CALL EXEC(2,LU1,IMESS7,-14) 
      CALL REIO(1,LU1+400B,IPBUF(7),1)
      IF(IPBUF(7).NE.2HYE) GO TO 1
      IF (IPRS8 .EQ. 0) GO TO 1 
      DO 2150 I = 1,IPRS8 
C ^ 
      IF ((IPRS5.EQ.2).AND.(IPRS6.EQ.IFPAR(5)).AND.(IPRS7.EQ.IFPAR(6))) 
     &     GO TO 2107 
      CALL EXEC(100001B,IPRS2,IARRAY,64,IPRS3,IPRS4)
      GO TO 40
2101  LUTYP = 0 
      IF(IPRS5.EQ.3) LUTYP = IGET(1756B)
      ITAT = IGET(1656B) + IPRS6 + LUTYP
      ISTART = IGET(ITAT) 
      IF(IPRS5 .LT. 4) CALL IPUT(ITAT,IGET(1717B))
C ^ 
      CALL EXEC(100002B,IPRS5+74000B,IARRAY,64,IPRS6,IPRS7) 
      GO TO 2105
2103  CALL ABREG(IA,IB) 
      IF (IPRS5.LT.4) CALL IPUT (ITAT,ISTART) 
      IF(IB.NE.64) GO TO 2107 
      IF (I.EQ.1) CALL IMFP(IFPAR,IPRS5,IPRS6,ITEMP,0,IPRS8,IARRAY) 
  
      GO TO 2107
2105  IF(IPRS5 .LT. 4) CALL IPUT(ITAT,ISTART) 
2107  IPRS4 = IPRS4 + 1 
      IF (IPRS4.LT.INSECS) GO TO 2110 
      IPRS4 = 0 
      IPRS3 = IPRS3 + 1 
2110  IPRS7 = IPRS7 + 1 
      IF(IPRS7.LT.INSEC2) GO TO 2150
      IPRS7 = 0 
      IPRS6 = IPRS6 + 1 
2150  CONTINUE
      GO TO 1 
C 
C **************SET UP THE # OF 64 WORD SECTORS/TRACK *********** 
C 
2200  IF(IPRS3.NE.0) NSECT2 = IPRS3 
      NSECTS = IPRS2
      GO TO 1 
C ^ 
C 
C **********DISPLAY PAST DISK MODS********************
C 
C 
C 
2300  IF (INFP.EQ.2HNF) GO TO 35
      ITEMP = IFPAR(4)
C *** HEADER ***
      CALL CNUMD(ITEMP,IFPHD(18)) 
      CALL EXEC(2,LU2,IFPHD,29) 
      IF (ITEMP.EQ.0) GO TO 1 
C PRINT 190 MAX 
      IF (ITEMP.GT.190) ITEMP = 190 
      ITRK = IFPAR(5) 
      ISECTR = IFPAR(6) 
      IWORD = 9 
      CALL EXEC (1,2,IARRAY,64,ITRK,ISECTR) 
C 
C     LOOP TO SET UP AND PRINT EACH ENTRY 
C 
      DO 2320 I = 1,ITEMP 
      CALL CNUMD(IARRAY(IWORD)/64,IDISC(4)) 
      CALL CNUMD(IARRAY(IWORD+1),IDISC(11)) 
      IF (IARRAY(IWORD+2).LT.0) GO TO 2305
C 
C     DISK MOD
C 
      CALL CNUMD(IARRAY(IWORD+2),IDISC(19)) 
      IFIX = IAND(IARRAY(IWORD),77B) + 1
      CALL CNUMD(IFIX,IDISC(26))
      CALL CNUMO(IARRAY(IWORD+3),IDISC(34)) 
      CALL EXEC(3,LU2+700B,1) 
      CALL EXEC(2,LU2,IDISC,36) 
      GO TO 2380
C 
C     MOVE SECTORS
C 
2305  CALL CNUMD(IAND(IARRAY(IWORD+2),77777B),IDISC(19))
      CALL EXEC(3,LU2+700B,1) 
      CALL EXEC(2,LU2,IDISC,21) 
      CALL CNUMD(IARRAY(IWORD+3),IFPMS(14)) 
      CALL EXEC(2,LU2,IFPMS,17) 
C *******  UPDATE POINTERS  ******* 
2380  IWORD = IWORD + 4 
      IF (IFBRK(IDMY).EQ.-1) GO TO 1
      IF (IWORD.LE.64) GO TO 2320 
      IWORD = IWORD -64 
      ISECTR = ISECTR + 1 
      IF (ISECTR.LT.IGET(1757B)) GO TO 2310 
      ISECTR = 0
      ITRK = ITRK + 1 
C READ ANOTHER SECTOR WHEN NECESSARY
2310  CALL EXEC(1,2,IARRAY,64,ITRK,ISECTR)
2320  CONTINUE
      GO TO 1 
C 
C **********EJECT PAGE (TOP OF FORM FOR LINE PRINTER) **********
C 
2400  CALL EXEC(3,LU2+700B,-1)
      GO TO 1 
C 
C********  MAKE THE PROGRAM FRIENDLY FOR THE PEOPLE  ************ 
C 
9000  DO 9025 I = 1,32
      IF(IPRS2.EQ.IGO(I)) GO TO(9100,9200,9300,9960,9400,9500,9600, 
     &9700,9970,9800,9980,9900,9988,9992,9925,9905,9910,9920, 
     &9930,9984,9984,9982,9990,25,9940,9940,9940,9994,9996, 
     &9997,9998,9950) 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,IPP,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,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,IMS,23) 
      CALL EXEC(2,LU2,INS,16) 
C ^ 
      CALL EXEC (2,LU2,IEP,16)
      CALL EXEC(2,LU2,IFP,14) 
      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)
      CALL EXEC(2,LU2,ITEL15,17)
      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,21)
      GO TO 1 
9925  CALL EXEC(2,LU2,IEP,2)
      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) 
      DO 9983 I = 1,4 
      ITEL30(6) = IFUN(I) 
      CALL EXEC(2,LU2,ITEL30,9) 
9983  CONTINUE
      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,14)
      GO TO 9999
9996  CALL EXEC(2,LU2,ITEL37,14)
C 
9999  MORUSE(6) = IPRS2 
      CALL EXEC(2,LU2,MORUSE,8) 
      GO TO 1 
9992  CALL EXEC(2,LU2,ITEL35,2) 
      GO TO 1 
C ^ 
9950  CALL EXEC(2,LU2,IFP,2)
      GO TO 1 
C     ??,MS 
9997  CALL EXEC(2,LU2,ISOR(2),19) 
      CALL EXEC(2,LU2,ITEL39,23)
C     ??,NS  (AND ??,MS)
9998  CALL EXEC(2,LU2,ITEL38,10)
      CALL EXEC(2,LU2,ITEL38,27)
      GO TO 1 
      END 
      END$
ASMB,Q
* 
* 
*  CINIT
* FIND THE END OF THE ENTRY POINTS.  IF MARKED, 
* WE'VE INITIALIZED ALREADY, OTHERWISE WE'D BETTER
* DO IT.  WE TAKE 12 SECTORS FOR THE FOOTPRINT AREA 
* 
* 1ST 5 WORDS OF FP AREA      IARRAY
*   1 = FLAG (-1 DONE)        1 = INIT FLAG (1 BAD) 
*   2 = NEXT TRACK                (IFPAR(1))
*   3 = NEXT SECTOR               (IFPAR(2))
*   4 = NEXT WORD                 (IFPAR(3))
*   5 = COUNT                     (IFPAR(4))
*                             6 = START TRACK FP AREA 
*                                 (IFPAR(5))
*                             7 = START SECTOR FP AREA
*                                 (IFPAR(6))
* 
* 
      NAM CINIT,7 
      ENT CINIT,DSKOT 
      EXT EXEC, $LIBR, $LIBX, .ENTR 
* 
RRAY  NOP 
CINIT NOP 
      JSB .ENTR 
      DEF RRAY
* 
      LDA RRAY
      CAX 
      STA ELOC
      STA DLOC
      STA FLOC
* 
      LDA DSCLB          DISC ADDR OF RES LIB ENTRY PTS 
      CLB 
      DIV D128           QUOTIENT = TRACK REM = SECT
      STA STRAK          TRACK
      STB SSECT          SECTOR 
* 
      LDA DSCLN          # RES LIB ENTRY PTS
      ADA DSCUN          # RTE LIB ROUTINES 
      CLB 
      DIV D16            DIV BY # ENTS/SECT = # SECTS NEEDED
      SZB                NEED PARTIAL SECTOR? 
      INA                ADD 1 TO # SECTS NEEDED
      ADA SSECT          ADD IN START SECT
      ADA D6             OP SYS TAKES 384 MORE FOR GOOD MEASURE 
      CLB 
      DIV SECT2          DIV BY # SECT/TRACK = # TRACKS NEEDED
      ADA STRAK          ADD IN START TRACK 
      STA STRAK          START TRACK OF FP AREA 
      STB SSECT          START SECTOR OF FP AREA
* 
      JSB EXEC            GO READ THE SECTOR
      DEF *+7 
      DEF D1              READ
      DEF ICNWD           LU2 BINARY
ELOC  NOP                 REALLY RRAY 
      DEF IBUFL           64 WORDS
      DEF STRAK          FP AREA 1ST TRACK
      DEF SSECT           FP AREA 1ST SECTOR
* 
      LDA RRAY,I        GET 1ST WORD
      SZA               ZERO? 
      JMP NEXT          NO. HAVE INITIALIZED ALREADY
* 
      CCA               YES. MUST INITIALIZE
      STA EFLAG 
      STA RRAY,I        SET FLAG
      LDA STRAK 
      SAX D1,I           SET TRACK
      LDA SSECT 
      SAX D2,I           SET SECT 
      LDA D8
      SAX D3,I           SET OFFSET 
* 
      JSB DSKOT          WRITE TO DISK
      DEF *+5 
      DEF STRAK          THIS TRACK 
      DEF SSECT          THIS SECTOR
DLOC  NOP                BUFFER TO WRITE
      DEF IBUFL          # OF WORDS 
* 
* 
      JSB EXEC      READ BACK 
      DEF *+7       TO CHECK THE WRITE
      DEF D1
      DEF ICNWD 
FLOC  NOP 
      DEF IBUFL 
      DEF STRAK 
      DEF SSECT 
* 
      LDA RRAY,I    GET THE FIRST WORD
      CPA M1        IS IT -1
      JMP NEXT
      CLB,INB 
      STB RRAY,I    FLAG IF NO WRITE DONE 
* 
NEXT  LDA STRAK          RETURN START TRACK 
      SAX D5,I
      LDA SSECT          RETURN START SECTOR
      SAX D6,I
      JMP CINIT,I 
* 
A     EQU 0 
B     EQU 1 
TAT   EQU  01656B          FWA OF TRACK ASSIGN TABLE
XEQT  EQU  01717B          ID SEG ADDR OF CURRENT PROG
SECT2 EQU  01757B          # SECT/TRACK ON LU2
DSCLB EQU  01761B          DISC ADDR IF RES LIB ENTRY PTS 
DSCLN EQU  01762B          # RES LIB ENTRY PTS
DSCUN EQU  01764B          # RTE LIB ROUTINES 
* 
M1    OCT 177777          -1 FLAG 
D1    DEC      1
D2    DEC      2
D3    DEC      3
D5    DEC      5
D6    DEC      6
D8    DEC      8
D16   DEC     16
D128  DEC    128
* 
STRAK NOP 
SSECT NOP 
EFLAG NOP 
* 
ICNWD OCT    102           LU2, BINARY
IBUFL DEC     64           BUFFER LENGTH
* 
* 
* 
* DSKOT 
*       SUBROUTINE TO WRITE TO DISK 
*       MUST FUDGE TAT SO CAN WRITE ON
*       SYSTEM TRACKS 
* 
* 
TRK   NOP 
SCT   NOP 
BUF   NOP 
BUFL  NOP 
DSKOT NOP 
      JSB .ENTR 
      DEF TRK 
* 
      LDA TAT            TAT
      ADA TRK,I          OFFSET FOR TRACK 
      STA TTAT           SAVE POINTER 
      LDB A,I 
      STB SAVE           SAVE VALUE 
      LDB XEQT           GET OWN ID SEG ADDR
* 
      JSB $LIBR          TURN OFF INTERRUPT SYS 
      NOP 
      STB A,I            PUT OWN SELF IN AS OWNER OF TRK
      JSB $LIBX          TURN ON INTERRUPT SYS
      DEF *+1 
      DEF *+1 
* 
      JSB EXEC            WATCH OUT! WRITING ON DISK
      DEF *+7 
      DEF CODE            WRITE,ERR RETURN SET
      DEF ICNWD 
      DEF BUF,I 
      DEF BUFL,I
      DEF TRK,I 
      DEF SCT,I 
      JSB SERR             ERROR RETURN 
* 
SERR  LDA TTAT             GET POINTER
      LDB SAVE             GET SAVED VALUE
      JSB $LIBR          TURN OFF INTERRUPT SYS 
      NOP 
      STB A,I              PUT TAT BACK HOW WE FOUND IT 
      JSB $LIBX            TURN INTERRUPT SYS BACK ON 
      DEF *+1 
      DEF *+1 
      JMP DSKOT,I          BYE BYE
* 
* 
TTAT  NOP                    TEMP POINTER 
SAVE  NOP                    TEMP VALUE 
CODE  OCT  100002 
      END 
FTN4
      SUBROUTINE IMFP (INFO,IL,IT,IS,IW,IV,IB)
      DIMENSION INFO(6),IB(64)
C 
C 
C  IMFP 
C         I MAKE FOOTPRINTS 
C 
C  FOUR WORDS/ENTRY 
C     1. LU (15-6)  WORD (5-0)
C     2. TRACK
C     3. FLAG (15)  SECTOR
C     4. OLD VALUE (FLAG = 0) 
C        # SECTORS MOVED (FLAG = 1) 
C 
C  INFO = FOOTPRINT AREA INFORMATION
C  IL,IT,IS,IW = LU,TRACK,SECTOR,WORD MODIFIED
C  IV = OLD VALUE (DM)  # SECTRS MOVED (MS) 
C 
C 
      CALL EXEC (1,102B,IB,64,INFO(5),INFO(6))
C 
C  MAKE SURE THEY DIDN'T CHANGE DISKS ON US 
C 
      IF (IB(1).NE.-1) GO TO 200
      DO 100 I = 2,5
      IF (IB(I).NE.INFO(I-1)) GO TO 200 
100   CONTINUE
C 
C  SET UP NEW ENTRY 
C 
      CALL EXEC (1,102B,IB,64,INFO(1),INFO(2))
      ITMP = INFO(3)
      IB(ITMP+1) = IOR((IL*64),IW)
      IB(ITMP+2) = IT 
      IB(ITMP+3) = IS 
      IB(ITMP+4) = IV 
C 
C  MAKE A FOOTPRINT, MAKE SURE WE MADE IT,
C  IF EVERYTHING IS PEACHY, UPDATE THE POINTERS 
C  FOR THE NEXT FOOTPRINT 
C 
      IFLAG = -1
      CALL DSKOT(INFO(1),INFO(2),IB,64) 
C 
      CALL EXEC(1,102B,IB,64,INFO(1),INFO(2)) 
      IF (IB(ITMP+1).EQ.IOR((IL*64),IW).AND.(IB(ITMP+2).EQ.IT)
     &.AND.(IB(ITMP+3).EQ.IS).AND.(IB(ITMP+4).EQ.IV)) 
     &CALL UPTRS(INFO(1),INFO(2),INFO(3),INFO(4),INFO(5),INFO(6),IB)
C 
200   CONTINUE
      END 
C 
C 
C 
C 
C 
      SUBROUTINE UPTRS (INT,INS,INW,ICT,IST,ISS,IDSK) 
      DIMENSION IDSK(64)
C 
C 
C  UPDATE POINTERS
C 
C  INCREMENT COUNT, IF WE'VE FILLED THE FOOTPRINT 
C  AREA, FILL IT UP ALL OVER AGAIN. 
C  FIX THINGS IN CASE WE CROSS SECTOR OR TRACK
C  BOUNDARY SO WE KNOW WHERE TO STEP NEXT.
C  UPDATE ON DISK, TOO. 
C 
C 
      ICT = ICT +1
      IF (ICT-((ICT/190)*190).EQ.0) GO TO 101 
      INW = INW +4
      IF (INW.LT.64) GO TO 201
      INW = INW - 64
      INS = INS + 1 
      ISECN = IGET(1757B) 
      IF (INS.LT.ISECN) GO TO 201 
      INS = INS - ISECN 
      INT = INT + 1 
      GO TO 201 
101   INW = 8 
      INS = ISS 
      INT = IST 
201   CALL EXEC (1,102B,IDSK,64,IST,ISS)
      IDSK(2) = INT 
      IDSK(3) = INS 
      IDSK(4) = INW 
      IDSK(5) = ICT 
      CALL DSKOT(IST,ISS,IDSK,64) 
      END 
      END$
FTN4
      SUBROUTINE DOIO(ISTART,ISTOP,LU,IPRAM)
      DIMENSION IBUF(40),IMESS(29),IPRAM(6),LMESS(17) 
      DIMENSION IPAGE(11) 
      INTEGER OBUF(37)
C 
      DATA IMESS/2H  ,2HWO,2HRD,
     &2H  ,2HLO,2HCA,2HTI,2HON,2H  ,
     &2HVA,2HLU,2HE(,2H8),2H  ,2HVA,2HLU,2HE(,2H10,2H) ,
     &2HVA,2HLU,2HE(,2HAS,2H) ,2HVA,2HLU,2HE(,2HSY,2HM)/
      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/40*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,-58)
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(1)) 
      IF(IPRAM(2) .EQ.1) CALL CNUMO(K,IBUF(1))
      CALL CNUMO(I,IBUF(5)) 
      IF(IPRAM(6).LT.0) GO TO 5 
      CALL CNUMD(IPRAM(6),IBUF(5))
      IBUF(5) = 2HPG
5     IF(IPRAM(4) .NE.-1) GO TO 50
      CALL CNUMO(IXGET(I),IBUF(10)) 
      CALL CNUMD(IABS(IXGET(I)),IBUF(15)) 
      IF(IXGET(I).LT.0)IBUF(15) = IBUF(15) + 6400B
C 
      CALL IASCI(IXGET(I),IBUF(22)) 
      CALL INVRS(I,IXGET(I),IBUF(25),16,IWRD) 
C 
      GO TO 75
50    CALL CNUMO(IGET(I),IBUF(10))
      CALL CNUMD(IABS(IGET(I)),IBUF(15))
      IF (IGET(I).LT.0) IBUF(15) = IBUF(15) + 6400B 
C 
      CALL IASCI(IGET(I),IBUF(22))
      CALL INVRS(I,IGET(I),IBUF(25),16,IWRD)
C 
75    CALL EXEC(2,LU,IBUF,24+IWRD)
      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 + 700B,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(36)
      INTEGER OBUF(37)
      DIMENSION IDISK(25),IDISC(28) 
      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) ,2HVA,2HLU,2HE(,2HSY,2HM)/
      DATA IBUF/36*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    IF IPRAM(6) = 1 THEN DONT PRINT ANY HEADER INFOD 
C 
      CALL CNUMD(INDEX,IDISC(26)) 
      IF(IPRAM .EQ.0) GO TO 55
      NUMBR = 64
      INDEX = 1 
      ID = 21 
      IF(IPRAM(4).EQ.1) ID = 28 
      GO TO 100 
C 
55    NUMBR = 1 
      ID = 28 
C 
100   IF(IPRAM(6) .EQ. 1) GO TO 150 
      CALL CNUMD(LU,IDISC(4)) 
      CALL CNUMD(ITRK,IDISC(11))
      CALL CNUMD(ISECTR,IDISC(19))
      IF(IPRAM(3).NE.1) CALL EXEC(2,LU2,IDISC,ID) 
      IF(IPRAM(5).NE.1) CALL EXEC(2,LU2,IDISK,25) 
C     SEE IF JUST LIST OF DISC LOCATION DESIRED 
      IF(IPRAM(2).EQ.1) RETURN
C 
      IF(IPRAM(5).EQ.1) GO TO 2000
C 
C 
150   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 INVRS (0,IARRAY(I),IBUF(21),16,IWRD) 
      CALL EXEC(2,LU2,IBUF,20+IWRD) 
      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 
      END$
FTN4,L
      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 
      NSECTS = IGET(1757B)
      IF(ITRK.GE.0) GO TO 1200
C 
C     A PROGRAM ! 
C 
C     GET THE # OF SECTORS PER TRACK
      NSECTS = IGET(1755B - ITRK) 
      IPAST = IPRS1 
      ISTART = 0
      GO TO 1240
C 
C 
C 
C     GRANDFATHER DISC
C 
C 
C     BASE PAGE STARTS HERE 
1200  IBASE = ISSCT(II) 
C     ASSUME OP SYSTEM ENDS HERE
      ISTOP = 77770B
C     OP SYSTEM STARTS HERE 
      ISTART = IBASE + 16 
C 
C 
C SEE IF WORD IS ON BASE PAGE 
C 
      IPAST = IPRS1 - 1024
      IF(IPAST.GE. 0) GO TO 1240
C 
C     WORD ON BASE PAGE 
C 
      ITRK = 0
      ISTART = IBASE
      ITEMP = IPRS1 
      GO TO 1250
C 
C 
1240  ITRK = IPAST/(64*NSECTS)
      ITEMP = IPAST - (ITRK * 64 * NSECTS)
1250  ISECTR = ITEMP/64 
      IWORD = ITEMP - (ISECTR * 64) 
      ISECTR = ISECTR +ISTART 
      IF(ISECTR.LT.NSECTS) GO TO 1210 
C 
C OOPS TOO MANY SECTORS 
C 
      ITRK = ITRK + 1 
      ISECTR = ISECTR - NSECTS
C 
C 
C 
C     CHANGE RANGE OF WORD FROM 0-63 TO 1-64 SO FORTRAN CAN HANDLE IT.
1210  IWORD = IWORD + 1 
      END 
      END$
ASMB,L
      NAM PIDMI,7 
      ENT PACK,IASCI,DUMMY,MAPXX,IDEX,IRTE4 
*     ENT IGET,IPUT 
      EXT $LIBR,$LIBX,.ENTR,.ENTP,$IDEX,$OPSY 
* 
* 
* 
*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
* 
* 
* 
*IXPUT  NOP 
*     JSB $LIBR 
*     NOP 
*     LDA IXPUT,I 
*     STA IXGET 
*     ISZ IXPUT 
*     DLD IXPUT,I 
*     LDA A,I 
*     LDB B,I 
*     XSB A,I 
*     JSB $LIBX 
*     DEF IXGET 
* 
IDEXX NOP 
IDEX  NOP           ROUTINE TO GET ADDRESS OF ID EXT
      JSB .ENTR     GET THE PARAMETER 
      DEF IDEXX 
      LDB IDEXX,I   GET THE ID ADDRESS
      ADB D28       INDEX TO ID EXT WORD
      LDA B,I       PULL IT IN
      ALF           ROTATE ARROUND
      RAL,RAL 
      AND M77       KEEP ONLY ID EXT #
      ADA $IDEX     ADD ADDRESS OF ID EXT TABLE 
      LDA A,I       PULL IN ADDRESS 
      STA IDEXX,I   AND GIVE TO CALLER
      JMP IDEX,I
* 
D28   DEC 28
M77   OCT 77
* 
* 
* 
* 
* 
* 
*  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 B176
      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
B176  OCT 176 
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#      PHYSICAL PG # (0-1023)
*                        DEF OFFSET     (NOT GREATER THAN 1023 DECIMAL) 
*                        DEF ARRAY      (ARRAY OF 64 WORDS) 
*                        DEF FLAG       1/2/3  READ/WRITE/READ BUT DON'T
*                                       UPDATE PAGE# OR OFFSET
*                        DEF NVAL       NEW VALUE (FLAG = 2)
* 
* 
* 
PAGE# NOP 
OFSET NOP 
ARRAY NOP 
FLAG  NOP 
NVAL  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 FLAG,I    GET THE READ WRITE FLAG 
      CPA D2        ARE WE READING OR WRITING ? 
      JMP WRTPG     WRITING ! 
* 
* 
* 
* 
      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
* 
* 
RTMAP LDA OLD31     YES RESTORE THE USER MAP
      STA MAP31 
      LDA OLD32 
      STA MAP32 
* 
      LDA MPBUF     GET THE ADDRESS 
      USA           !!!!!!!!!!RESTORE THE USER MAP!!!!!!!!!!!!!!!!
      JSB $LIBX     RESTORE INTERUPTS 
      DEF *+1 
      DEF *+1 
* 
      LDA FLAG,I    GET THE FLAG
      CPA D1        DO WE UPDATE THE PAGE # & OFFSET
      RSS           YES 
      JMP MAPXX,I   NO, SO RETURN TO THE CALLER 
* 
      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
* 
      JMP MAPXX,I   RETURN TO CALLER
* 
* 
WRTPG LDA START     GET THE START ADDRESS 
      ADA OFSET,I   ADD THE OFFSET INTO THE PAGE
      LDB NVAL,I    GET THE NEW VALUE 
      STB A,I       AND SET IT UP.
      JMP RTMAP     RESET THE MAP & RETURN
* 
* 
* 
D1    DEC 1 
D2    DEC 2 
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 
* 
* 
*  THIS ROUTINE RETURNS THE VALUE OF $OPSY
*  IF $OPSY = -9, THEN WE HAVE AN RTE-IV SYSTEM 
* 
* 
IRTE4 NOP 
      LDB IRTE4,I   GET RETURN ADDRESS
      LDA $OPSY     GET VALUE OF $OPSY
      JMP B,I       THAT'S ALL
* 
* 
      END 
ASMB,Q,C
      NAM INVRS,7 
* 
*     THIS ROUTINE INVERSE ASSEMBLES HP 21MX
*     INSTRUCTIONS
* 
*     THE CALLING SEQUENCE IS AS FOLLOWS
* 
*        JSB INVRS
*        DEF RTRN 
*        DEF ADDRSS    LOGICAL ADDRESS OF INSTRUCTION 
*        DEF VALUE     INSTRUCTION AT ADDRSS
*        DEF IBUF      OUTPUT BUFFER
*        DEF ISIZE     SIZE OF OUTPUT BUFFER
*        DEF IWRDS     RETURNED NO OF WORDS FILLED
*  RTRN  ...
* 
*     FORTRAN CALL: 
* 
*       CALL INVRS(IADRS,VALUE,IBUF,ISIZE,IWRDS)
* 
* 
      ENT INVRS 
      EXT .ENTR 
* 
* 
A     EQU 0 
B     EQU 1 
* 
* 
ADDRS BSS 1 
VALUE BSS 1 
BUFAD BSS 1 
BSIZE BSS 1 
WCNT  BSS 1 
INVRS NOP 
      JSB .ENTR 
      DEF ADDRS 
      LDA BUFAD 
      RAL           MAKE BYTE ADDRESS 
      STA BUFAD 
      STA BPNTR 
      LDB BSIZE,I   GET BUFFER SIZE 
      RBL           MAKE INTO BYTES 
      ADA B         COMPUTE END OF BUFFER 
      STA BFEND 
      LDA ADDRS,I 
      STA IADR      SAVE ADDRESS OF INSTRUCTION 
      LDA B2        SET NO OF WORDS/ENTRY 
      STA  INCR     IN INCREMENT
      JSB LOAD      FETCH INSTRUCTION 
      STA INSTR 
      STA TEMP
      AND B70K      IS IT A MEMORY REFERENCE
      SZA 
      JMP MRGI      YES GO GET IT 
      LDA INSTR     NO
      ELA,ALF       PUT SIGN  IN E REG
      RAL           AND BITS 10&11 IN BITS 0&1
      SEZ           IF E SET(I.E. SIGN) MUST BE I/O OR EIG
      JMP IOGI
* 
      AND B3        SET UP OP CODE TABLE COUNTER
      LDB M18       SHIFT ROTATE
      SLA 
      LDB M12       ALTER SKIP
      STB CNTR
      ADA GRTBL     GET ADDRESS OF GROUP TABLE
      LDB A,I 
* 
LOOP1 LDA TEMP      FETCH REMAINING BITS OF INSTRUCTION 
      AND B,I       ARE ALL REQUIRED BITS SET 
      XOR B,I 
      SZA,RSS 
      JMP FOND1     YES GO GET MNEMONIC 
LOP1A ADB INCR      BUMP ADDRESS
      ISZ CNTR
      JMP LOOP1 
* 
NFND  LDA BUFAD     IF WE FALL THROUGH NOT COMPLETELY 
      STA BPNTR     DEFINED SO JUST PRINT OCTAL 
      LDA INSTR 
      JSB PN
      JMP EXIT
* 
IADR  BSS 1 
INCR  BSS 1 
INSTR BSS 1 
TEMP  BSS 1 
CNTR  BSS 1 
BPNTR BSS 1 
* 
B2    OCT 2 
B3    OCT 3 
B70K  OCT 70000 
M12   DEC -12 
M18   DEC -18 
BFEND BSS 1 
* 
GRTBL DEF *+1 
      DEF SRGA
      DEF ASGA
      DEF SRGB
      DEF ASGB
* 
MRGA1 DEF MRG-4 
* 
FOND1 JSB POPCD     PRINT MNEMONIC
      LDA B,I       REMOVE OPCODE FROM
      AND B1777     INSTRUCTION 
      XOR TEMP
      STA TEMP
      AND B1777     ARE ANY BITS LEFT 
      SZA,RSS 
      JMP EXIT   NO,THEN RETURN 
      LDA COMMA 
      JSB TYO       PRINT COMMA 
      JMP LOP1A     GO LOOK FOR REST
* 
B1777 OCT 001777
COMMA OCT 54
* 
MRGI  LDA INSTR 
      ALF,RAL 
      AND B17 
      RAL           TIMES 2 
      ADA MRGA1     COMPUTE TABLE POSITION
      LDB A 
      JSB POPCD     PRINT MNEMONIC
      LDA INSTR     COMPUTE ADDRESS 
      AND B2000     MERGE WITH PROPER PAGE
      SZA 
      LDA IADR
      XOR INSTR 
      AND B76K
      XOR INSTR 
      JSB PADR      PRINT ADDRESS 
      JMP EXIT
* 
B17   OCT 17
B2000 OCT 2000
B76K  OCT 76000 
* 
IOGI  LDB IOGTB     FETCH TABLE OF LOOP FOR I/O 
      SLA,RSS       IF EIG INSTEAD
      LDB DSGTB     THEN GET TABLE FOR EIG'S
      STB PNTR      PARMETERS 
      LDB PNTR,I    SET B TO START
      ISZ PNTR
LOOP2 LDA PNTR,I    GET COUNT FOR THIS TYPE 
      SSA 
      JMP LOP2A     IF NEGATIVE CONTINUE
* 
      SZA,RSS       IF ZERO THEN DONE 
      JMP NFND
      LDA B3
      STA INCR      ELSE SET INCREMENT TO 3 
      LDA PNTR,I    AND MAKE COUNT NEGATIVE 
      CMA,INA 
* 
LOP2A STA CNTR
      ISZ PNTR
LOOP3 LDA INSTR     FETCH INSTRUCTION 
      XOR B,I       SEARCH FOR MATCH
      AND PNTR,I    MASK UNWANTED BITS
      SZA,RSS 
      JMP FOND2 
      ADB INCR      BUMP ADDRESS IN OPCTBL
      ISZ CNTR      DONE WITH THIS TYPE
      JMP LOOP3     NO CONTINUE 
      ISZ PNTR
      JMP LOOP2     YES GO TO NEXT TYPE 
* 
* 
PNTR  BSS 1 
* 
FOND2 JSB POPCD     GO PRINT MNEMONIC 
      LDA PNTR,I    FETCH MASK
      CMA           IF EXACT NO OPERAND IN SAME WORD
      AND B77 
      SZA,RSS 
      JMP OPRND 
* 
      AND INSTR     STRIP OFF OPERAND 
      STA TEMP      SAVE FOR COMMA C TEST 
      LDB PNTR,I    IS MASK FOR 
      CPB DSMSK     A DOUBLE SHIFT GROUP
      SZA           AND OPERAND EQUAL 0 
      RSS 
      LDA B20       YES MAKE OPERAND IT 16
      AND B77       AND MASK C BIT
      JSB PNUMB     GO PRINT NUMBER 
      LDA TEMP
      AND B1000     IS A COMMA C REQUIRED 
      SZA,RSS       NO RETURN 
      JMP EXIT
      LDA COMMA 
      JSB TYO       PRINT COMMA 
      LDA "C
      JSB TYO       PRINT "C" 
      JMP EXIT
* 
* 
*     PRINTS MULTI WORD OPERANDS
* 
OPRND LDA TFLAG     TRACING 
      SZA,RSS 
      JMP EXIT   NO THEN RETURN 
* 
*     MUTIWORD PRINT HERE 
* 
      JMP EXIT
* 
* 
TFLAG OCT 0 
* 
B20   OCT 20
B77   OCT 77
B1000 OCT 1000
"C    OCT 103 
* 
* 
*     PRINT ONE CHARACTER 
* 
TYO   NOP 
      STB TEMP2     SAVE B REG
      LDB BPNTR 
      CPB BFEND 
      JMP EXIT   IF FULL THEN COMPLETE
      SBT           ELSE STORE BYTE 
      STB BPNTR     UPDATE POINTER
      LDB TEMP2     RESTORE B REG 
      JMP TYO,I 
* 
IOGTB DEF *+1 
      DEF OVFG
      DEC -4        OVERFLOW GROUP
      OCT 177777
      DEC -1        CLF 
      OCT 177700
      DEC -12       I/O GROUP 
      OCT 176700
      OCT 0         INDICATES END OF IO TABLE 
DSGTB DEF *+1 
      DEF DSG 
      DEC -6        DOUBLE SHIFT GROUP
DSMSK OCT 5760
      DEC -90       REST OF BASE SET
      OCT 5777
*                   MICROCODED INSTRUCTIONS 
      DEC 27        POSITIVE COUNT MEANS CHANGE INCREMENT 
      OCT 5777
      OCT 0         THIS INDICATES END
* 
LOAD  NOP 
      LDA VALUE,I 
      JMP LOAD,I
* 
TEMP2 BSS 1 
* 
*     PRINT MNEMONIC
POPCD NOP 
      STB TEMP3 
      INB 
      LDA B,I       FETCH FIRST 3 CHARS 
      JSB DSQZ      GO PRINT THEM 
      LDA INCR
      CPA B2        DOES MNEMONIC HAVE MORE THAN 3 CHARS
      JMP POP1      NO,GO TO RETURN 
      LDB TEMP3 
      ADB B2        YES FETCH NEXT 3 CHARS
      LDA B,I 
      JSB DSQZ      GO TO PRINT THEM
POP1  LDB TEMP3     RESTORE B REG 
      JMP POPCD,I   RETURN
* 
* 
DSQZ  NOP 
      CLB           A=SQOZE CODE
      DIV D1600 
      JSB CONV      A=FIRST CHAR,B=2ND,3RD
      LDA B 
      CLB 
      DIV D40       SPLIT SECOND 2 CHARS
      JSB CONV
      LDA B 
      JSB CONV
      JMP DSQZ,I
* 
*     A REG = ONE SQOZE CHARACTER 
* 
CONV  NOP 
      SZA,RSS       IF ZERO THEN TERMINATE DSQZ 
      JMP DSQZ,I
* 
      CPA B45       IS IT A "." 
      CCA           YES SET TO CONVERT TO 56B 
      ADA M13B       IS IT A LETTER 
      SSA,RSS 
      ADA B7        YES ADD 101B
      ADA B72       NO ADD 57B
      JSB TYO       GO PRINT IT 
      JMP CONV,I    RETURN
* 
B7    OCT 7 
B45   OCT 45
B72   OCT 72
M13B  OCT -13 
D40   DEC 40
D1600 DEC 1600
* 
TEMP3 BSS 1 
* 
* 
*     A =ADDRESS TO BE PRINTED
* 
* 
PADR  NOP           PRINT ADDRESS 
      STA SIGN      SAVE INDIRECT BIT 
      ELA,CLE,ERA   REMOVE SIGN BIT 
* 
************INSERT SYMBOL SEARCH HERE 
* 
      JSB PNUMB     GO PRINT  NUMBER
      LDA SIGN
      SSA,RSS       IS ",I" REQUIRED
      JMP PADR,I    NO THEN RETURN
* 
      LDA COMMA     YES THEN PRINT ",I" 
      JSB TYO 
      LDA "I
      JSB TYO 
      JMP PADR,I    AND RETURN
* 
"I    OCT 111 
RADIX DEC 8 
* 
SIGN BSS 1
* 
*     A =NUMBER TO BE PRINTED 
* 
PNUMB NOP 
      STA TEMP3 
      LDA BLANK 
      JSB TYO       PRINT BLANK 
      LDA TEMP3 
      JSB PN        PRINT NUMBER
      JMP PNUMB,I 
* 
PN    NOP 
      LDB TBADD     SET TEMP BUFFER 
      STB TBPTR 
PN1   CLB           CLEAR B FOR DIV 
      DIV RADIX 
      ADB M12B      CONVERT TO ASCII
      SSB,RSS 
      ADB B7
      ADB B72 
      JSB SRBT      PUT IN TEMP BUFFER
      SZA           IF QUOTIENT NON ZERO CONTINUE 
      JMP PN1 
* 
      LDB TBADD     ELSE MOVE TO OUTPUT BUFFER
      CMB,INB       SET UP CHAR COUNT 
      ADB TBPTR 
      STB TEMP3 
* 
PN2 ISZ TBPTR       BUMP POINTER
      LDA TBPTR,I   FETCH CHARACTER 
      JSB TYO       PRINT CHARACTER 
      ISZ TEMP3 
      JMP PN2       CONTINUE UNTIL ALL ARE MOVED
      JMP PN,I      AND THEN RETURN 
* 
* 
SRBT  NOP           SAVE CHARACTERS IN REVERSE ORDER
      STB TBPTR,I 
      CCB 
      ADB TBPTR     DECREMENT POINTER 
      STB TBPTR 
      JMP SRBT,I    AND RETURN
* 
BLANK OCT 40
M12B  OCT -12 
* 
TBPTR BSS 1 
      BSS 16
TBADD DEF *-1 
* 
EXIT  LDA BLANK     FILL WITH BLANK CHAR
      JSB TYO 
      LDA BUFAD     COMPUTE WORD COUNT
      CMA,INA 
      ADA BPNTR 
      ARS 
      STA WCNT,I
      JMP INVRS,I   AND RETURN
* 
* 
MRG   EQU *         MEMORY REFERENCE GROUP
      AND 0 
      OCT 044216
      JSB 0 
      OCT 100624
      XOR 0 
      OCT 154204
      JMP 0 
      OCT 100262
      IOR 0 
      OCT 075304
      ISZ 0 
      OCT 075554
      ADA 0 
      OCT 043373
      ADB 0 
      OCT 043374
      CPA 0 
      OCT 052533
      CPB 0 
      OCT 052534
      LDA 0 
      OCT 105673
      LDB 0 
      OCT 105674
      STA 0 
      OCT 134773
      STB 0 
      OCT 134774
SRGA  EQU *         SHIFT ROTATE GROUP
      ALF 
      OCT 044100
      ELA 
      OCT 060473
      ERA 
      OCT 061053
      ALR 
      OCT 044114
      RAR 
      OCT 130324
      RAL 
      OCT 130316
      ARS 
      OCT 044475
      ALS 
      OCT 044115
      OCT 40        CLE 
      OCT 052277
      SLA 
      OCT 134273
      OCT 27        ALF 
      OCT 044100
      OCT 26        ELA 
      OCT 060473
      OCT 25        ERA 
      OCT 061053
      OCT 24        ALR 
      OCT 044114
      OCT 23        RAR 
      OCT 130324
      OCT 22        RAL 
      OCT 130316
      OCT 21        ARS 
      OCT 044475
      OCT 20        ALS 
      OCT 044115
SRGB  EQU * 
      BLF 
      OCT 047200
      ELB 
      OCT 060474
      RBR 
      OCT 130374
      RBL 
      OCT 130366
      BRS 
      OCT 047575
      BLS 
      OCT 047215
      OCT 4040      CLE 
      OCT 052277
      SLB 
      OCT 134274
      OCT 4027      BLF 
      OCT 047200
      OCT 4026      ELB 
      OCT 060474
      OCT 4025      ERB 
      OCT 061054
      OCT 4024      BLR 
      OCT 047214
      OCT 4023      RBR 
      OCT 130374
      OCT 4022      RBL 
      OCT 130366
      OCT 4021      BRS 
      OCT 047575
      OCT 4020      BLS 
      OCT 047215
ASGA  EQU *         ALTER SKIP GROUP
      CCA 
      OCT 051523
      CLA 
      OCT 052273
      CMA 
      OCT 052343
      SEZ 
      OCT 133674
      CCE 
      OCT 051527
      OCT 2100      CLE 
      OCT 052277
      CME 
      OCT 052347
      SSA 
      OCT 134723
      SLA 
      OCT 134273
      INA 
      OCT 075213
      SZA 
      OCT 135353
      RSS 
      OCT 131645
ASGB  EQU * 
      CCB 
      OCT 051524
      CLB 
      OCT 052274
      CMB 
      OCT 052344
      OCT 6040      SEZ 
      OCT 133674
      OCT 6300      CCE 
      OCT 051527
      OCT 6100      CLE 
      OCT 052277
      OCT 6200      CME 
      OCT 052347
      SSB 
      OCT 134724
      SLB 
      OCT 134274
      INB 
      OCT 075214
      SZB 
      OCT 135354
      OCT 6001      RSS 
      OCT 131645
OVFG  EQU *         OVERFLOW GROUP
      CLO 
      OCT 052311
      STO 
      OCT 135011
      SOS 
      OCT 134505
      SOC 
      OCT 134465
CLF   EQU *         CLEAR FLAG
      CLF 0 
      OCT 052300
IOG   EQU *         I/O GROUP 
      CLC 0 
      OCT 052275
      STC 0 
      OCT 134775
      OTB 0 
      OCT 120374
      OTA 0 
      OCT 120373
      LIB 0 
      OCT 106204
      LIA 0 
      OCT 106203
      MIB 0 
      OCT 111304
      MIA 0 
      OCT 111303
      SFS 0 
      OCT 133735
      SFC 0 
      OCT 133715
      STF 0 
      OCT 135000
      HLT 0 
      OCT 072016
DSG   EQU *         DOUBLE SHIFT GROUP
      OCT 003100    RRR    1 WORD 
      OCT 131574
      OCT 003040    LSR    1 WORD 
      OCT 107044
      OCT 003020    ASR    1 WORD 
      OCT 044544
      OCT 002100    RRL    1 WORD 
      OCT 131566
      OCT 002040    LSL    1 WORD 
      OCT 107036
      OCT 002020    ASL    1 WORD 
      OCT 044536
EIG1  EQU *         1 WORD EXTENDED AND DMS GROUP 
      OCT 003741    CAX    1 WORD 
      OCT 051432
      OCT 003751    CAY    1 WORD 
      OCT 051433
      OCT 007741    CBX    1 WORD 
      OCT 051502
      OCT 007751    CBY    1 WORD 
      OCT 051503
      OCT 003744    CXA    1 WORD 
      OCT 053233
      OCT 007744    CXB    1 WORD 
      OCT 053234
      OCT 003754    CYA    1 WORD 
      OCT 053303
      OCT 007754    CYB    1 WORD 
      OCT 053304
      OCT 007761    DSX    1 WORD 
      OCT 056052
      OCT 007771    DSY    1 WORD 
      OCT 056053
      OCT 007760    ISX    1 WORD 
      OCT 075552
      OCT 007770    ISY    1 WORD 
      OCT 075553
      OCT 003747    XAX    1 WORD 
      OCT 153132
      OCT 003757    XAY    1 WORD 
      OCT 153133
      OCT 007747    XBX    1 WORD 
      OCT 153202
      OCT 007757    XBY    1 WORD 
      OCT 153203
      OCT 007763    LBT    1 WORD 
      OCT 105576
      OCT 007764    SBT    1 WORD 
      OCT 133476
      OCT 007767    SFB    1 WORD 
      OCT 133714
      OCT 007100    FIX    1 WORD 
      OCT 063432
      OCT 007120    FLT    1 WORD 
      OCT 063616
      OCT 003727    LFA    1 WORD 
      OCT 106013
      OCT 007727    LFB    1 WORD 
      OCT 106014
      OCT 007703    MBF    1 WORD 
      OCT 110660
      OCT 007702    MBI    1 WORD 
      OCT 110663
      OCT 007704    MBW    1 WORD 
      OCT 110701
      OCT 007706    MWF    1 WORD 
      OCT 112370
      OCT 007705    MWI    1 WORD 
      OCT 112373
      OCT 007707    MWW    1 WORD 
      OCT 112411
      OCT 003712    PAA    1 WORD 
      OCT 122103
      OCT 007712    PAB    1 WORD 
      OCT 122104
      OCT 003713    PBA    1 WORD 
      OCT 122153
      OCT 007713    PBB    1 WORD 
      OCT 122154
      OCT 003730    RSA    1 WORD 
      OCT 131623
      OCT 007730    RSB    1 WORD 
      OCT 131624
      OCT 003731    RVA    1 WORD 
      OCT 132013
      OCT 007731    RVB    1 WORD 
      OCT 132014
      OCT 003710    SYA    1 WORD 
      OCT 135303
      OCT 007710    SYB    1 WORD 
      OCT 135304
      OCT 003711    USA    1 WORD 
      OCT 143123
      OCT 007711    USB    1 WORD 
      OCT 143124
      OCT 003722    XMA    1 WORD 
      OCT 154043
      OCT 007722    XMB    1 WORD 
      OCT 154044
      OCT 007720    XMM    1 WORD 
      OCT 154057
      OCT 007721    XMS    1 WORD 
      OCT 154065
EIG2  EQU *         2 WORD EXTENDED AND DMS GROUP 
      OCT 010400    DIV    2 WORDS
      OCT 055230
      OCT 014200    DLD    2 WORDS
      OCT 055376
      OCT 014400    DST    2 WORDS
      OCT 056046
      OCT 010200    MPY    2 WORDS
      OCT 111763
      OCT 015000    FAD    2 WORDS
      OCT 062706
      OCT 015060    FDV    2 WORDS
      OCT 063120
      OCT 015040    FMP    2 WORDS
      OCT 063662
      OCT 015020    FSB    2 WORDS
      OCT 064224
      OCT 015746    ADX    2 WORDS
      OCT 043422
      OCT 015756    ADY    2 WORDS
      OCT 043423
      OCT 011742    LAX    2 WORDS
      OCT 105532
      OCT 011752    LAY    2 WORDS
      OCT 105533
      OCT 015742    LBX    2 WORDS
      OCT 105602
      OCT 015752    LBY    2 WORDS
      OCT 105603
      OCT 015745    LDX    2 WORDS
      OCT 105722
      OCT 015755    LDY    2 WORDS
      OCT 105723
      OCT 011740    SAX    2 WORDS
      OCT 133432
      OCT 011750    SAY    2 WORDS
      OCT 133433
      OCT 015740    SBX    2 WORDS
      OCT 133502
      OCT 015750    SBY    2 WORDS
      OCT 133503
      OCT 015743    STX    2 WORDS
      OCT 135022
      OCT 015753    STY    2 WORDS
      OCT 135023
      OCT 015714    SSM    2 WORDS
      OCT 134737
      OCT 011726    XCA    2 WORDS
      OCT 153223
      OCT 015726    XCB    2 WORDS
      OCT 153224
      OCT 011724    XLA    2 WORDS
      OCT 153773
      OCT 015724    XLB    2 WORDS
      OCT 153774
      OCT 011725    XSA    2 WORDS
      OCT 154423
      OCT 015725    XSB    2 WORDS
      OCT 154424
EIG2J EQU *         2 WORD JUMPS
      OCT 015762    JLY    2 WORDS
      OCT 100223
      OCT 015772    JPY    2 WORDS
      OCT 100463
      OCT 015732    DJP    2 WORDS
      OCT 055272
      OCT 015733    DJS    2 WORDS
      OCT 055275
      OCT 015734    SJP    2 WORDS
      OCT 134172
      OCT 015735    SJS    2 WORDS
      OCT 134175
      OCT 015736    UJP    2 WORDS
      OCT 142372
      OCT 015737    UJS    2 WORDS
      OCT 142375
EIG3  EQU *         3 WORD
JRS   OCT 017715    JRS    3 WORDS
      OCT 100575
      OCT 017766    CBT    3 WORDS
      OCT 051476
      OCT 017765    MBT    3 WORDS
      OCT 110676
      OCT 017776    CMW    3 WORDS
      OCT 052371
      OCT 017777    MVW    3 WORDS
      OCT 112341
      OCT 017774    CBS    3 WORDS
      OCT 051475
      OCT 017773    SBS    3 WORDS
      OCT 133475
      OCT 017775    TBS    3 WORDS
      OCT 136575
MIC   EQU *         MICRO CODED MACROS
      OCT 005201    DBLE   0 FORTRAN CALLABLE 
      OCT 054566
      OCT 056700
      OCT 005202    SNGL   0 FORTRAN CALLABLE 
      OCT 134421
      OCT 104600
      OCT 025203    .XMPY  4 WORD(S)
      OCT 166247
      OCT 123770
      OCT 025204    .XDIV  4 WORD(S)
      OCT 166236
      OCT 075700
      OCT 017205    .DFER  3 WORD(S)
      OCT 164600
      OCT 061040
      OCT 025213    .XADD  4 WORD(S)
      OCT 166233
      OCT 054660
      OCT 025214    .XSUB  4 WORD(S)
      OCT 166255
      OCT 141640
      OCT 177221    .GOTO 31 SPECIAL PROCESSING 
      OCT 165001
      OCT 137550
      OCT 175222    ..MAP 30 SPECIAL PROCESSING 
      OCT 166437
      OCT 044320
      OCT 167223    .ENTR 29 SPECIAL PROCESSING 
      OCT 164660
      OCT 137740
      OCT 167224    .ENTP 29 SPECIAL PROCESSING 
      OCT 164660
      OCT 137620
      OCT 015225    .PWR2  2 WORD(S)
      OCT 165561
      OCT 127570
      OCT 007226    .FLUN  1 WORD(S)
      OCT 164726
      OCT 142600
      OCT 015227    .SETP  2 WORD(S)
      OCT 165727
      OCT 137620
      OCT 015230    .PACK  2 WORD(S)
      OCT 165533
      OCT 052210
      OCT 007220    .XFER  1 WORD(S)
      OCT 166240
      OCT 061040
      OCT 015206    .XPAK  2 WORD(S)
      OCT 166252
      OCT 044010
      OCT 005207    XADD   0 FORTRAN CALLABLE 
      OCT 153106
      OCT 053600
      OCT 005210    XSUB   0 FORTRAN CALLABLE 
      OCT 154447
      OCT 045400
      OCT 005211    XMPY   0 FORTRAN CALLABLE 
      OCT 154062
      OCT 155300
      OCT 005212    XDIV   0 FORTRAN CALLABLE 
      OCT 153303
      OCT 144000
      OCT 015215    .XCOM  2 WORD(S)
      OCT 166235
      OCT 117730
      OCT 015216    ..DCM  2 WORD(S)
      OCT 166426
      OCT 052330
      OCT 005217    DDINT  0 FORTRAN CALLABLE 
      OCT 054703
      OCT 115260
      OCT 005257    .EMAP  0 FORTRAN CALLABLE 
      OCT 164657
      OCT 044320
      OCT 005240    .EMIO  0 FORTRAN CALLABLE 
      OCT 164657
      OCT 075250
      OCT 005241    MMAP   0 FORTRAN CALLABLE 
      OCT 111543
      OCT 121200
      END 
      END 
MCEND EQU * 
      END 
      END 
ASMB,R,L
      NAM ISSCT,7 
      ENT ISSCT 
      EXT $SSCT 
* 
* 
*     THIS ROUTINE IS SO THAT THE FORTRAN SUBROUTINE
*     DTRK CAN ACCESS THE SYSTEM ENTRY POINT $SSCT
* 
* 
ISSCT NOP 
      LDB ISSCT,I 
      LDA $SSCT     FUNCTION CALL RETURNS VALUE IN A REG
      JMP B,I 
A     EQU 0 
B     EQU 1 
      END 
              