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