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 / 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 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