FTN4,L
C 
C    VERSION   4 / 24 / 76   JRT
C    VERSION   6 / 08 / 77   MCC
C    VERSION   8 / 24 / 78   TEF
C    VERSION   1 / 18 / 79   LW/TEF SESSION MONITOR 
C    VERSION   9 / 24 / 79   DHP
C 
      PROGRAM JRSTR (3,60),24999-16049 REV.2024 800611  
C 
      DIMENSION LU(5),IREG(2),MBUF(52),IPBUF(33),IMBUF(33)
      DIMENSION IBUF(8321),JBUF(20000B),IANS(2),IHEAD(25) 
      DIMENSION KFILE(5)
      INTEGER FILE,SFLAG  
C 
      DIMENSION MESS1(8),MESS2(6),MESS3(9),MESS4(11),MESS5(9),MESS6(10) 
      DIMENSION MESS7(3),MESS9(4),MES10(22),MES11(19),MES12(6)
      DIMENSION MES20(19),MES21(14),MES22(17),MES23(14),MES24(15) 
      DIMENSION MES25(14),MES26(23),MES27(14),MES28(20),MES29(6)
      DIMENSION IVMESS(9),MES30(51),MES14(15) 
C 
      EQUIVALENCE (IA,IREG),(IB,IREG(2)),(X,IREG) 
      EQUIVALENCE (IBUF,ITRAK),(JBUF,IBUF(2)),(LU(2),LIST)
C 
      EQUIVALENCE (MBUF,IMBUF(2)),(MBUF(2),MBUF2),(IPBUF(2),IPBUF2),
     +            (JBUF(2),JBUF2),(JBUF(3),JBUF3),(JBUF(7),JBUF7),
     +            (JBUF(8),JBUF8),(JBUF(9),JBUF9),(JBUF(10),JBUF10),
     +            (IPBUF(5),IPBUF5),(IPBUF(6),IPBUF6) 
C 
      DATA KFILE/6412B,2H F,2HIL,2HE ,2H  / 
      DATA IVMESS/2H/J,2HRS,2HTR,2H: ,2HVE,2HRI,2HFY,2H ?,2H _/ 
      DATA JLNTH/20000B/,FILE/1/,SFLAG/0/ 
      DATA IMBUF/6412B/,IMBUF(32)/2H ?/,IMBUF(33)/2H _/ 
      DATA IHEAD/2H24,2H99,2H9-,2H16,2H04,2H9 ,2H20,2H24,2H S,2HOF,2HTW,
     &           2HAR,2HE ,2HSE,2HRV,2HIC,2HE ,2HKI,2HT ,2HSY,2HST,2HEM,
     &           2H 1,2H00,2H0 /
      DATA MESS1/6412B,2HMA,2HG ,2HTA,2HPE,2H L,2HU:,2H _/
      DATA MESS2/6412B,2HDI,2HSC,2H L,2HU:,2H _/
      DATA MESS3/2HTH,2HAT,2H'S,2H N,2HOT,2H A,2H D,2HIS,2HC!/
      DATA MESS4/2HTH,2HAT,2H'S,2H N,2HOT,2H A,2H M,2HAG,2H T,2HAP,2HE!/
      DATA MESS5/2HCA,2HN',2HT ,2HDO,2H T,2HHA,2HT ,2HLU,2H! /
      DATA MESS6/2HMA,2HX ,2H= ,2H50,2H, ,2HMI,2HN ,2H =,2H 1,2H! / 
      DATA MESS7/2HEN,2HD?,2H _/
      DATA MESS9/6412B,2HDO,2HNE,2H! /
      DATA MES10/6412B,2HMA,2HG ,2HTA,2HPE,2H F,2HIL,2HE:,2H (,2H-1,
     &           2H =,2H D,2HIR,2HEC,2HTO,2HRY,2H, ,2H0 ,2H= ,
     &           2HEN,2HD),2H _/
      DATA MES11/6412B,2H /,2HJR,2HST,2HR:,2H F,2HIL,2HE ,2H  ,2H U,
     &           2HNK,2HNO,2HWN,2H T,2HAP,2HE ,2HFO,2HRM,2HAT/
      DATA MES12/6412B,2HEO,2HF ,2HFO,2HUN,2HD!/
      DATA MES14/2H/J,2HSA,2HVE,2H: ,2HWA,2HIT,2HIN,2HG ,2HFO,
     &           2HR ,2HLU,2H# ,3*2H  / 
      DATA MES20/6412B,2HDI,2HRE,2HCT,2HOR,2HY ,2HIN,2HCO,2HNS,2HIS,
     &           2HTE,2HNC,2HY!,2H #,2H T,2HRA,2HCK,2H =,2H? /
      DATA MES21/2HLO,2HAD,2HIN,2HG ,2HCA,2HRT,2HRI,2HDG,2HE ,2H' ,2H  ,
     &           2H  ,2H  ,2H' /
      DATA MES22/2HPR,2HEV,2HIO,2HUS,2H D,2HIR,2HCT,2HOR,2HY ,2HAT,2H T,
     &           2HRA,2HCK,2H: ,2H  ,2H  ,2H  / 
      DATA MES23/2HDI,2HSC,2H (,2H L,2HU ,2H) ,2HMA,2HX ,2HTR,2HAC,2HK ,
     &           2H  ,2H  ,2H  /
      DATA MES24/2HLO,2HWE,2HST,2H T,2HRA,2HCK,2H O,2HN ,2HTH,
     &          2HIS,2H C,2HR:,2H  ,2H  ,2H  /
      DATA MES25/2HMO,2HVE,2H D,2HIR,2HCT,2HOR,2HY ,2HTO,2H N,2HEW, 
     &           2H T,2HRA,2HCK,2H ?/ 
      DATA MES26/6412B,2H(Y,2HES,2H,N,2HO,,2H O,2HR ,2HNE,2HW ,2HTR,
     &           2HAC,2HK ,2HNU,2HMB, 
     &           2HER,2H [,2H<=,2H0 ,2H= ,2HAB,2HOR,2HT],2H _/
      DATA MES27/2HDI,2HRE,2HCT,2HOT,2HY ,2HNO,2HW ,2HON,2H T,2HRA,2HCK,
     &           2H  ,2H  ,2H  /
      DATA MES28/6412B,2HCR,2H ',2H  ,2H  ,2H  ,2H' ,2HDI,2HRE,2HCT,
     &           2HOR,2HY ,2HON,2H T,2HRA,2HCK,2H  ,2H  ,2H  ,2H  / 
      DATA MES29/2HIN,2HPU,2HT ,2HER,2HRO,2HR! /
C 
      DATA MES30/6412B,2H /,2HJR,2HST,2HR:,2H W,2HAR,2HNI,2HNG,2H! ,
     + 2HDA,2HTA,2H E,2HXC,2HEE,2HDS,2H D,2HIS,2HC ,2HSP,2HAC,2HE , 
     +           2HFO,2HR ,2HLU,6412B,2H /,2HJR,2HST,2HR:,2H D,2HAT,
     +           2HA ,2HFR,2HOM,2H T,2HRA,2HCK,3*2H  ,2H O,2HN ,2HNO, 
     +           2HT ,2HRE,2HST,2HOR,2HED,2H! ,6412B/ 
C 
C 
      CALL RMPAR(LU)
      IF(LU.EQ.0)LU=1 
      IF(LIST .EQ. 0)LIST = LU
      ILU=LU+400B 
      CALL EXEC(2,ILU,IHEAD,25) 
      ASSIGN 30 TO IRTN 
C 
C 
C   GET MAG TAPE LU 
C 
10    CALL EXEC(2,ILU,MESS1,8)
      X=REIO(1,ILU,MBUF,10) 
      CALL PARSE(MBUF,IB*2,IPBUF) 
      MTLU=IPBUF2 
C 
      CALL EXEC(13,MTLU,ISTAT)
      LU2LK = MTLU
C 
C     ONLY DVR 23 OR 24 DEVICES ALLOWED.
C 
      IF(IAND(ISTAT,37400B)*2.EQ.23000B)GO TO 20
      IF(IAND(ISTAT,37400B)*2.EQ.24000B)GO TO 20
      CALL EXEC(2,ILU,MESS4,11) 
      GO TO 10
C 
20    IREG=LURQ(100001B,LU2LK,1)  
      IF(IREG.EQ.0)GO TO IRTN 
C 
C LOCK UNSUCCESSFUL, SO REPORT
C 
      CALL CNUMD(MTLU,MES14(13))
      IF (IMESS .EQ. 0)CALL EXEC(2,LU,MES14,15) 
C 
      IMESS = 1 
      CALL EXEC(12,0,2,0,-3)
      IF(IFBRK(IDMMY))410,20
30    REWIND MTLU 
      FILE=1
      IBROKE = 0
C 
C 
C  GET MAG TAPE FILE NUMBER  0 = END    <0 = PRINT DIRECTORY
C 
40    CONTINUE
C 
C     ASK FOR FILE #. 
C 
50    CALL EXEC(2,ILU,MES10,22) 
      SFLAG=1 
      LASTTR = 0
      IBUF = 2H   
      X=REIO(1,ILU,MBUF,10) 
      CALL PARSE(MBUF,IB*2,IPBUF) 
      NFILE=IPBUF2
      IF(NFILE .EQ. 0)GO TO 400 
C 
C     IF < 0 GO DO A DIRECTORY LIST 
C 
      IF(IBROKE .GE. 0)GO TO 60 
      CALL EXEC(3,MTLU+1400B) 
      X = EXEC(3,MTLU+600B) 
      IA = IAND(IA,100B)
      IF(IA .EQ. 0)CALL EXEC(3,MTLU+1300B)
60    IF(NFILE.LT.0)GO TO 310 
C 
C     IF = 0 QUIT.
C 
      IF(NFILE.LE.50)GO TO 65 
      CALL EXEC(2,ILU,MESS6,10) 
      GO TO 40
C 
C  DEOF FOUND RESTART 
C 
63    CALL EXEC(2,ILU,MES12,6)
      GO TO 40
C 
C   POSITION THE TAPE 
C 
C********************************** 
65    IF(NFILE .GT. 1)GO TO 67
      REWIND MTLU 
      FILE = 1
      GO TO 120 
67    IF(FILE.EQ.NFILE)GO TO 110
      CALL EXEC(3,MTLU+1400B) 
      IF(FILE.EQ.1)GO TO 70 
      CALL EXEC(3,MTLU+1300B) 
70    CALL EXEC(1,MTLU,MBUF,50) 
      CALL HEADL(MBUF,LEN,50) 
      KFILE(5)=KCVT(FILE) 
      CALL EXEC(2,ILU,KFILE,5)
      CALL EXEC(2,ILU,MBUF,LEN) 
C 
C                   FORWORD-BACK WORD  UP PROCESSOR 
C 
C 
      IF(NFILE.GT.FILE)GO TO 80 
      GO TO 90
C 
C 
C                   FORWORD 
C 
C 
80    CALL EXEC(3,MTLU+1300B) 
      FILE=FILE+1 
      IF(FILE.EQ.NFILE)GO TO 120
      KFILE(5)=KCVT(FILE) 
      CALL EXEC(2,ILU,KFILE,5)
      CALL EXEC(1,MTLU,MBUF,50) 
      CALL HEADL(MBUF,LEN,50) 
      CALL EXEC(2,ILU,MBUF,LEN) 
      GO TO 80
C 
C 
C                   BACK WORD 
C 
C 
90    FILE=FILE-1 
      CALL EXEC(3,MTLU+1400B) 
      CALL EXEC(3,MTLU+1400B) 
      IF(FILE.EQ.1)GO TO 120
      CALL EXEC(3,MTLU+1300B) 
      IF(FILE .EQ. NFILE)GO TO 120
      CALL EXEC(1,MTLU,MBUF,50) 
      KFILE(5)=KCVT(FILE) 
      CALL EXEC(2,ILU,KFILE,5)
      CALL HEADL(MBUF,LEN,50) 
      CALL EXEC(2,ILU,MBUF,LEN) 
      GO TO 90
C 
C 
C   GET HEADER AND CHECK IF THAT'S WHAT HE WANTS
C 
110   CALL EXEC(3,MTLU+1400B) 
      IF(FILE.EQ.1)GOTO 120 
      CALL EXEC(3,MTLU+1300B) 
120   X =  EXEC(1,MTLU,IBUF,JLNTH+1)
      HEDLNT = IB 
      IF(HEDLNT .EQ. 0)GO TO 63 
C 
C  IF DSAVE TAPE, SKIP HEADR STUFF
C 
      IF(HEDLNT .GT. 300)GO TO 180
C 
C  IF SAVE OR LSAVE FORMAT TELL HIM BUT STILL DISPLAY THE HEADR 
C 
      KFILE(5)=KCVT(FILE) 
      CALL EXEC(2,ILU,KFILE,5)
C       
C  CHECK FOR SAVE FORMAT
C 
      IF(HEDLNT .NE. 140)GO TO 122
      CALL HEADL(IBUF,LEN,36) 
      CALL EXEC(2,ILU,38H /JRSTR: SAVE FORMAT CAN NOT RESTOR !!,-38)  
      CALL EXEC(2,ILU,IBUF,LEN) 
      GO TO 50  
C 
C  CHECK FOR LSAVE FORMAT 
C 
122   IF(HEDLNT .NE. 247)GO TO 124
      CALL HEADL(IBUF,LEN,75) 
      CALL EXEC(2,ILU,39H /JRSTR: LSAVE FORMAT CAN NOT RESTOR !!,-39) 
      CALL EXEC(2,ILU,IBUF,LEN) 
      GO TO 50  
C 
C     SET UP A ' ? _' IN THE BUFFER.
C 
124   CALL HEADL(IBUF,LEN,50) 
      LEN=LEN+1 
      IBUF(LEN)=20077B
      LEN = LEN + 1 
      IBUF(LEN)=20137B
C***********************************************
      CALL EXEC(2,ILU,IBUF,LEN) 
      CALL REIO(1,ILU,IANS,2) 
      IF(IANS.EQ.2HYE)GO TO 180 
      IF(IANS.EQ.2HNO)GO TO 50
C**************************** 
      CALL EXEC(3,MTLU+1400B) 
      IF(FILE.EQ.1)GO TO 140
      CALL EXEC(3,MTLU+1300B) 
140   GO TO 120 
C 
C 
C     ASK FOR DISK LU #.
C 
180   CALL EXEC(2,ILU,MESS2,6)
      X=REIO(1,ILU,MBUF,10) 
      MES23(12)=MBUF
      MES23(13)=MBUF2 
      CALL PARSE(MBUF,IB*2,IPBUF) 
      IDISC=IABS(IPBUF2)
      IF(IPBUF5 .EQ. 1)LASTTR = IPBUF6
C 
C     DISK LU OK IF > 6 
C 
      IF(IDISC.GT.6.AND.IDISC.LT.63)GO TO 190 
      IF(IDISC.EQ.0)GO TO 40  
      CALL EXEC(2,ILU,MESS5,9)
      GO TO 180 
C 
190   CALL EXEC(13,IDISC,ISTAT) 
      ITYPE=IAND(ISTAT,37400B)/256
C 
C     THIS LU OK IF DVR IS 30 OR 32 
C 
      IF((ITYPE.EQ.31B).OR.(ITYPE.EQ.32B))GO TO 200 
      CALL EXEC(2,ILU,MESS3,9)
      GO TO 180 
C 
C   GET DIRECTORY TRACKS - PERHAPS MODIFY DIRECTORY TO PUT IT IN
C   A DIFFERENT TRACK THAN WHAT IT CAME FROM, AS FROM 7905 TO 7905
C   WITH DIFFERENT # TRACKS PER CARTRIDGE.
C 
C    MAG TAPE RECORD GIVES TRACK NUMBER THAT THE DIRECTORY CAME FROM... 
C    EXEC CALL GIVES LAST TRACK OF THE DISC WE'RE WRITING TO
C     IF THEY'RE THE SAME, JUST PROCEED.... 
C     IF DIFFERENT PRINT OUT CURRENT VALUES AND REQUEST OPERATOR
C       FOR DESIRED LOCATION OF DIRECTORY.
C 
C    NOW...  READ THE TAPE TO FIND SPECIFIED TRACK
C            GET MAX TRACK ON THIS DISC 
C            REQUEST CHANGE (IF ANY)
C            MODIFY DIRECTORY 
C            COPY ALL DIRECTORY TRACKS
C            GO TO COPY DOWN REMAINING TRACKS 
C 
C 
C     READ THE NEXT RECORD IF THE LAST WAS A HEADER (LENGTH <= 100).
C 
200   IF(HEDLNT.LE.100)CALL EXEC(1,MTLU,IBUF,JLNTH+1) 
      JLNTH = JBUF7 * 64
      LODIR=JBUF8 
      NDIR=ITRAK-LODIR+1
      LOWEST=JBUF10 
      MES21(11)=JBUF
      MES21(12)=JBUF2 
      MES21(13)=JBUF3 
      MES28(4) =JBUF
      MES28(5) =JBUF2 
      MES28(6) =JBUF3 
C 
C     #TRACKS SPECIFIED & FOUND ON TAPE DONT' MATCH.
C 
      IF(NDIR.EQ.-JBUF9)GO TO 210 
      CALL EXEC(2,ILU,MES20,19) 
      GO TO 40
C 
C     FORCE A SEEK BEYOND THE END OF THIS LU TO GET # TRKS. 
C 
210   X=EXEC(1,IDISC,IDMMY,1,32766,0) 
      MAXTRK=IB-1 
      IDELT=0 
      IMES = 0
      IF(LASTTR .EQ. 0)GO TO 220
      IPBUF2 = LASTTR 
      GO TO 230 
220   IF(ITRAK.EQ.MAXTRK)GO TO 250
C 
230   CALL CNUMD(ITRAK,MES22(15)) 
      CALL CNUMD(MAXTRK,MES23(12))
      CALL CNUMD(LOWEST,MES24(13))
      CALL EXEC(2,ILU,MES21,14) 
      CALL EXEC(2,ILU,MES22,17) 
      CALL EXEC(2,ILU,MES24,15) 
      CALL EXEC(2,ILU,MES23,14) 
      IF(LASTTR .NE. 0)GO TO 240
      CALL EXEC(2,ILU,MES25,14) 
      CALL EXEC(2,ILU,MES26,23) 
      X=REIO(1,ILU,MBUF,10) 
      CALL PARSE(MBUF,IB*2,IPBUF) 
C 
      IF(IPBUF2.LE.0)GO TO 40 
      IF(IPBUF.EQ.1)GO TO 240 
      IF(IPBUF2.NE.2HYE)GO TO 250 
      IPBUF2 = MAXTRK 
C 
240   IF(IPBUF2.GT.MAXTRK)GO TO 300 
      IDELT=IPBUF2-ITRAK
      IF(LOWEST .GT. (LODIR+IDELT))JBUF10 = LODIR + IDELT 
C 
C    HAVE ALL LU'S, NOW GO COPY THE DISC... 
C 
250   LASTTR = ITRAK + IDELT
      CALL CNUMD(LASTTR,MES28(18))
      CALL EXEC(2,ILU,MES28,20) 
      JBUF8=JBUF8+IDELT 
      GO TO 280 
C 
260   IF(IFBRK(0).GE.0)GO TO 270
      IBROKE = -1 
      GO TO 40
270   X=EXEC(1,MTLU,IBUF,JLNTH+1) 
      CALL EXEC(13,MTLU,ISTAT)
C 
C     END IF EOF ENCOUNTERED. 
C 
      IF(IAND(ISTAT,200B).NE.0)GO TO 360
280   KTRAK=ITRAK 
      IF(ITRAK .LT. LODIR .AND. ITRAK .GE. (LODIR+IDELT))GO TO 290
      IF(ITRAK.GE.LODIR)KTRAK=ITRAK+IDELT 
      CALL EXEC(2,IDISC,JBUF,JLNTH,KTRAK,0) 
      GO TO 260 
290   IF(IMES .EQ. 1)GO TO 260
      IMES = 1
C 
C " /JRSTR: WARNING! DATA EXCEEDS DISC SPACE FOR LU"
C " /JRSTR: DATA FROM TRACK XXXXXX ON NOT RESTORED!"
C 
      CALL CNUMD(ITRAK,MES30(39)) 
      CALL EXEC(2,ILU,MES30,51) 
      GO TO 260 
C 
C  ERROR
C 
300   CALL EXEC(2,ILU,MES29,6)
      GO TO 40
C 
C  DIRECTORY OF MAG TAPE
C 
C 
C     READ ONE RECORD FROM TAPE - LOOK FOR DEOF TO SIGNIFY
C     THE END OF TAPE.
C 
310   REWIND MTLU 
      FILE = 1
      IF (LIST .EQ. ILU)GO TO 315 
C 
C  GO LOCK LIST DEVICE
C 
      ASSIGN 315 TO IRTN
      LU2LK = LIST
      GO TO 20
315   X=EXEC(1,MTLU,JBUF,JLNTH) 
      IF(IB.NE.0)GO TO 320
C 
C  IF DEOF BACK UP TO BETWEEN DEOF
C 
      CALL EXEC(3,MTLU+1400B) 
      CALL EXEC(3,LIST+1100B,-1)
      GO TO 40
C 
320   IF(IFBRK(0).GE.0)GO TO 330
      CALL EXEC(3,MTLU+0200B) 
      CALL EXEC(3,LIST+1100B,-1)
      GO TO 40
C 
C     IF TRANSMISSION LOG TELLS US WHAT KIND OF FILE WE HAVE
C     BASED ON THE FOLLOWING LENGTHS: 
C 
C     JSAVE,WRITT  = <= 50 WORDS
C     DSAVE        = JLNTH WORDS
C     SAVE         = 140 WORDS
C     LSAVE,USAVE  = 247 WORDS
C 
330   KFILE(5) = KCVT(FILE) 
      CALL EXEC(2,LIST,KFILE,5) 
      IF(IB.LE.50)GO TO 334 
C 
C  CHECK FOR SAVE FORMAT
C 
      IF(IB.NE.140)GO TO 331
      CALL HEADL(IBUF,LEN,36) 
      CALL EXEC(2,LIST,39H  /JRSTR: SAVE FORMAT CAN NOT RESTOR !!,-39)    
      CALL EXEC(2,LIST,IBUF,LEN)  
      GO TO 340 
331   IF(IB.NE.247)GO TO 332
C 
C  CHECK FOR LSAVE FORMAT 
C 
      CALL HEADL(IBUF,LEN,75) 
      CALL EXEC(2,LIST,40H  /JRSTR: LSAVE FORMAT CAN NOT RESTOR !!,-40)   
      CALL EXEC(2,LIST,IBUF,LEN)  
      GO TO 340 
332   IF(IB.NE.JLNTH)GO TO 350
      CALL EXEC(2,LIST,22H, /JRSTR: DSAVE FORMAT ,11) 
      GO TO 340 
C 
C     ELSE - DISPLAY THE HEADER 
C 
334   CALL HEADL(IBUF,LEN,50) 
      LINE1 = LEN 
      DO 335 J=1,LEN
      IF (IBUF(J) .NE. 6412B)GO TO 335
      LINE1 = J 
      IBUF(J) = 2H
335   CONTINUE
      CALL EXEC(2,LIST,IBUF,LINE1)
      IF(LINE1.LT.LEN)CALL EXEC(2,LIST,IBUF(LINE1),LEN-LINE1) 
C 
C     AND FF TO THE NEXT FILE.
C 
340   CALL EXEC(3,MTLU+1300B) 
      FILE=FILE+1 
      GO TO 315 
C 
C  UNRECOGNIZED TAPE FORMAT 
C 
350   MES11(9) = KCVT(FILE) 
      CALL EXEC(2,LIST,MES11,19)  
      GO TO 340 
C 
C     SET UP A TEST FOR VERIFICATION
C 
360   FILE = FILE + 1 
C 
      CALL EXEC(2,ILU,IVMESS,9) 
      CALL REIO(1,ILU,IANS,1) 
      IF(IANS .NE. 2HYE) GO TO 390
C 
C     2-BF & 1-FF REQUIRED IF NOT FILE #2 
C 
      IF(FILE .EQ. 2) GO TO 380 
      CALL EXEC(3,MTLU+1400B) 
      CALL EXEC(3,MTLU+1400B) 
380   IF(FILE .EQ. 2)REWIND MTLU
      IF(FILE .NE. 2)CALL EXEC(3,MTLU+300B) 
C 
C     READ THE HEADER AGAIN 
C 
      X =  EXEC(1,MTLU,IBUF,100)
      CALL EXEC(2,ILU,IBUF,IB)
      CALL JVRFY(IBUF,LU,IDISC,MTLU,IDELT)
C 
C     UPDATE CRN ON DIRECTORY OF LU 2 
C 
390   CONTINUE
      CALL JDCMC(LU,IDISC,LASTTR) 
      GO TO 40
C 
C 
C  END:   REWIND TAPE AND TERMINATE 
C 
400   REWIND MTLU 
      CALL EXEC(2,ILU,MESS9,4)
C 
410   END 
      SUBROUTINE HEADL(IBUF,LEN,MAX)
     +,            REV.2024 800611  
      DIMENSION IBUF(MAX) 
C 
C     DO BACK SCAN ON IBUF TO FIND TRUE LENGTH OF RECORD
C 
10    DO 20  I=MAX,1,-1 
      IF(IBUF(I) .EQ. 2H  )GO TO 20 
      IF(IBUF(I) .NE.6412B)GO TO 30 
      I = I - 2 
      GO TO 30
20    CONTINUE
      LEN = 1 
30    LEN = I + 1 
C 
      RETURN
      END 
      SUBROUTINE JVRFY(IBUFF,LUCRT,LUDISK,LUMT,IDELT) 
     +,24999-16163 REV.1932  790810 
C 
C     THIS SUBROUTINE IS DESIGNED TO COMPARE THE CONTENTS OF
C     A MAG TAPE FILE AGAINST THE CONTENTS OF A DISK TRACK. 
C     THE MAG TAPE FORMAT SHOULD BE:
C                   6145 OR 8193 WORDS LONG 
C                   WHERE WORD #1 IS THE TRACK #. 
C                   TERMINATION WILL OCCUR UPON READING EOF.
C     THE MAG TAPE MUST BE POSITIONED TO THE FIRST DISC IMAGE RECORD
C     BEFORE SCHEDULING THIS SUBROUTINE.
C 
C     FORM OF CALL: 
C                   CALL JVRFY(IBUFF,LUCRT,LUDISK,LUMT,IDELT) 
C 
C     WHERE:
C                   LUCRT - LU WHERE MESSAGES WILL BE SENT
C 
C                   LUDISK - LU # OF THE DISK SUBCHANNEL
C                   TO BE VERIFIED. 
C 
C                   LUMT - LU # OF THE MAG TAPE.
C 
C                   IDELT = OFFSET BETWEEN THE OLD DIRECTORY AND A
C                           THE NEW DIRECTORY IF IT HAS BEEN MOVED
C 
C     IPBUF(1) = 0 - COMPARE GOOD.
C     IPBUF(2) = # OF MAG TAPE RECORDS TESTED.
C 
C     IPBUF(1) = -1 MAG TAPE COMPARE ERROR
C     IPBUF(2) = MAG TAPE RECORD NUMBER 
C     IPBUF(3) = TRACK #
C     IPBUF(4) = SECTR #
C     IPBUF(5) = WORD OFFSET
C 
C     IPBUF(1) = -2 - MAG TAPE STATUS ERROR 
C     IPBUF(2) = MAG TAPE RECORD NUMBER 
C     IPBUF(3) = EQT #5 STATUS INFO 
C 
C     IPBUF(1) = -3 - MAG TAPE RECORD LENGTH ERROR
C     IPBUF(2) = MAG TAPE RECORD NUMBER 
C     IPBUF(3) = LENGTH OF MAG TAPE RECORD. 
C 
C     IPBUF(1) = -4 - DISK READ ERROR.
C     IPBUF(2) = MAG TAPE RECORD NUMBER 
C     IPBUF(3) = EQT #5 STATUS INFO.
C 
      DIMENSION IBUFF(1),IPBUF(5),LENB(7),ISCTRS(7),IREG(2) 
      DIMENSION LENC(7) 
C 
      DIMENSION JVM10(28),JVM20(31),JVM30(28),JVM40(46),JVM50(18) 
C 
      EQUIVALENCE (REG,IREG),(IREG(2),IBREG)
C 
      EQUIVALENCE (IPBUF(1),IPBUF1),(IPBUF(2),IPBUF2),(IPBUF(3),IPBUF3),
     +            (IPBUF(4),IPBUF4),(IPBUF(5),IPBUF5) 
C 
      EQUIVALENCE (JVM10(18),JVM118),(JVM10(26),JVM126) 
      EQUIVALENCE (JVM20(21),JVM221),(JVM20(29),JVM229) 
      EQUIVALENCE (JVM30(18),JVM318),(JVM30(26),JVM326) 
      EQUIVALENCE (JVM40(17),JVM417),(JVM40(29),JVM429),
     +            (JVM40(37),JVM437),(JVM40(44),JVM444) 
      EQUIVALENCE (JVM50(12),JVM512)
C 
      DATA JVM10/2H /,2HJS,2HAV,2HE:,2H D,2HIS,2HK ,2HRE,2HAD,2H E,2HRR,
     &           2HOR,2H -,2H S,2HTA,2HTU,2HS ,3*2H  ,2H R,2HEC,2HOR, 
     &           2HD ,2H# ,3*2H  /
C 
      DATA JVM20/2H /,2HJS,2HAV,2HE:,2H M,2HT ,2HRE,2HCO,2HRD,2H L,2HEN,
     &           2HGT,2HH ,2HER,2HRO,2HR ,2H- ,2HLE,2HNG,2HTH,3*2H  , 
     &           2H R,2HEC,2HOR,2HD ,2H# ,3*2H  / 
C 
      DATA JVM30/2H /,2HJS,2HAV,2HE:,2H M,2HT ,2HST,2HAT,2HUS,2H E,2HRR,
     &           2HOR,2H -,2H S,2HTA,2HTU,2HS ,3*2H  ,2H R,2HEC,2HOR, 
     &           2HD ,2H# ,3*2H  /
C 
      DATA JVM40/2H /,2HJS,2HAV,2HE:,2H C,2HOM,2HPA,2HRE,2H E,2HRR,2HOR,
     &           2H R,2HEC,2HOR,2HD ,2H# ,3*2H  ,6412B, 
     &           2H /,2HJS,2HAV,2HE:,2H T,2HRA,2HCK,2H #,3*2H  ,2H S, 
     &           2HEC,2HTO,2HR ,2H# ,3*2H  ,2H O,2HFF,2HSE,2HT ,3*2H  / 
C 
      DATA JVM50/2H /,2HJS,2HAV,2HE:,2H C,2HOM,2HPA,2HRE,2H G,2HOO,2HD.,
     &           3*2H  ,2H R,2HEC,2HOR,2HDS/
C 
      DATA LENB/128,256,512,1024,2048,2176,2048/
      DATA LENC/129,257,513,1025,2049,4097,6273/
      DATA ISCTRS/0,2,6,14,30,62,96/
C 
C 
      ICOUNT = 0
C 
C     GET A MAG TAPE RECORD AND TEST FOR EOF
C 
10    IF(IFBRK(IDMY) .LT. 0) GO TO 100
      REG=EXEC(1,LUMT,IBUFF(128),8193)
C 
C  IF FIRST TIME THROGH SET VALUES
C     (IBUFF(136) == WORD 7 OF DIRECTORY [LOWEST DIRECTORY TRACK])
C     (IBUFF(138) == WORD 9 OF DIRECTORY [NEXT AVAILABLE TRACK])
C 
      IF(ICOUNT .GT. 0)GO TO 15 
      LODIR = IBUFF(136)
      IBUFF(136) = IBUFF(136) + IDELT 
      IF(IBUFF(138) .GT. IBUFF(136))IBUFF(138) = IBUFF(136) 
C 
C     FINISHED IF EOF FOUND 
C 
15    IF(IAND(IREG,200B) .NE. 0) GO TO 100
C 
C     ANY OTHER STATUS EXCEPT NO WRITE RING IS AN ABORT CONDITION.
C 
      IF(IAND(IREG,373B) .NE. 0) GO TO 200
C 
C     RECORD LENGTH MUST BE 6145 OR 8193
C 
      IF(IBREG .NE. 6145) GO TO 20
      ITMS = 6
      GO TO 40
20    IF(IBREG .NE. 8193) GO TO 300 
      ITMS = 7
C 
C     TRACK # IS IN FIRST WORD. 
C 
40    ITRK = IBUFF(128) 
      IF(ITRK .GE. LODIR)ITRK = ITRK + IDELT
       ICOUNT = ICOUNT + 1
      IF(ITRK .LT. LODIR .AND. ITRAK .GE. (LODIR+IDELT))GO TO 10
C 
C     NOW GET AND TEST THE CONTENTS OF ONE TRACK (6 READS)
C 
      DO 50 I=1,ITMS
      LENGTH = LENB(I)
      INDEX = LENC(I) 
C 
      REG = EXEC(1,LUDISK,IBUFF,LENGTH,ITRK,ISCTRS(I))
C 
      IF(IAND(IREG,1) .NE. 0) GO TO 400 
C 
      CALL CMPWD(IBUFF,IBUFF(INDEX),LENGTH,IERR)
      IF(IERR .NE. 0) GO TO 500 
C 
50    CONTINUE
      GO TO 10
C 
C     GOOD COMPLETION 
C 
100   IPBUF1 = 0
      GO TO 1000
C 
C     MAG TAPE STATUS ERROR.
C 
200   IPBUF1 = -2 
      IPBUF3 = IREG 
      GO TO 1000
C 
C     MAG TAPE RECORD LENGTH ERROR. 
C 
300   IPBUF1 = -3 
      IPBUF3 = IBREG
      GO TO 1000
C 
C     DISK READ ERROR.
C 
400   IPBUF1 = -4 
      IPBUF3 = IREG 
      GO TO 1000
C 
C     COMPARE ERROR.
C 
500   IPBUF1 = -1 
      IPBUF3 = ITRK 
      IPBUF4 = ISCTRS(I) + IERR/64
      IPBUF5 = MOD(IERR,64) 
C 
C     FINISHED. 
C 
C     WRITE A MESG IF LUCRT IS GIVEN
C 
1000  IPBUF2 = ICOUNT 
C 
      IGO = IPBUF1 + 5
      GO TO (1010,1020,1030,1040,1050),IGO
C 
1010  CALL CNUMO(IPBUF3,JVM118) 
      CALL CNUMD(IPBUF2,JVM126) 
      CALL EXEC(2,LUCRT,JVM10,28) 
C011  FORMAT(" /JVRFY: DISK READ ERROR - STATUS ",K6," RECORD #",I4)
      GO TO 2000
C 
1020  CALL CNUMD(IPBUF3,JVM221) 
      CALL CNUMD(IPBUF2,JVM229) 
      CALL EXEC(2,LUCRT,JVM20,31) 
C021  FORMAT(" /JVRFY: MT RECORD LENGTH ERROR - LENGTH ", 
C    +       I5," RECORD #",I4) 
      GO TO 2000
C 
1030  CALL CNUMO(IPBUF3,JVM318) 
      CALL CNUMD(IPBUF2,JVM326) 
      CALL EXEC(2,LUCRT,JVM30,28) 
C031  FORMAT(" /JVRFY: MT STATUS ERROR - STATUS ",K6," RECORD #",I4)
      GO TO 2000
C 
C 
1040  CALL CNUMD(IPBUF2,JVM417) 
      CALL CNUMD(IPBUF3,JVM429) 
      CALL CNUMD(IPBUF4,JVM437) 
      CALL CNUMD(IPBUF5,JVM444) 
      CALL EXEC(2,LUCRT,JVM40,46) 
C041  FORMAT(" /JVRFY: COMPARE ERROR RECORD #",I4/, 
C    +       " /JVRFY: TRACK #",I4," SECTOR #",I4," OFFSET",I4) 
      GO TO 2000
C 
1050  CALL CNUMD(IPBUF2,JVM512) 
      CALL EXEC(2,LUCRT,JVM50,18) 
C051  FORMAT(" /JVRFY: COMPARE GOOD. ",I4," RECORDS") 
C 
2000  IBUFF = IPBUF1
      RETURN
      END 
      END$
ASMB,R,L,C,Z
      IFN 
      HED WORD COMPARE FOR 2100 & EARLIER CPU 
      NAM CMPWD,7 WORD COMPARE FOR 2100 & EARLIER CPU 6/10/77 
      XIF 
      IFZ 
      HED WORD COMPARE FOR 21MX & LATER CPU 
      NAM CMPWD,7 WORD COMPARE FOR 21MX & LATER CPU 6/10/77 
      XIF 
      ENT CMPWD 
      EXT .ENTR 
      SKP 
*     THIS PROGRAM WILL COMPARE THE CONTENTS OF TWO BUFFERS 
*      AND RETURN:
*                   IERR = 0  -  GOOD COMPARE 
*                   IERR = +N -  ERROR DETECTED.
*     WHERE N = BUFFER INDEX OF FAILED COMPARISON.
* 
*     THIS PROGRAM WILL RETURN AFTER ENCOUNTERING THE FIRST 
*     COMPARE FAILURE.
* 
*     THIS PROGRAM IS FORTRAN CALLABLE AS FOLLOWS:
*     CALL CMPWD(BUF1,BUF2,LENGTH,IERR) 
*            - OR - 
*     REG = CMPWD(BUF1,BUF2,LENGTH,IERR)
*     WHERE IERR IS RETURNED IN THE 'A' REGISTER. 
* 
*     CONDITIONAL ASSEMBLY REQUIRED FOR COMPUTER TYPE:
*                   N FOR 2100 OR EARLIER MODELS
*                   Z FOR 21MX OR LATER MODELS
* 
*     MCC 6/10/77 
* 
      SKP 
BUFF1 NOP 
BUFF2 NOP 
LENTH NOP 
IERR  NOP 
CMPWD NOP 
      SPC 1 
      JSB .ENTR 
      DEF BUFF1 
      SPC 1 
      IFN 
      LDA LENTH,I    GET THE BUFFER LENGTH
      CMA,INA       COMPLEMENT AND SAVE IT
      STA COUNT 
      SPC 1 
LOOP  LDA BUFF1,I   GET FIRST WORD
      XOR BUFF2,I   XOR WITH SECOND 
      SZA           OK IF ZERO RESULTS. 
      JMP ERROR     NO - ERROR. 
      SPC 1 
      ISZ COUNT     YES - FINISHED IF COUNT = 0 
      JMP INCR
      SPC 1 
      JMP OUT         FINISHED
      SPC 1 
INCR  ISZ BUFF1     INCREMENT BOTH BUFFER ADDRESSES 
      ISZ BUFF2 
      JMP LOOP      GO TEST THE NEXT TWO. 
      SPC 1 
ERROR ISZ COUNT     SET UP THE
      LDA LENTH,I   ERROR COUNT 
      ADA COUNT     FOR RETURN
      JMP BAD       THEN RETURN 
      SKP 
      XIF 
      IFZ 
      LDA BUFF1     GET THE TWO ADDRESSES IN 'A' & 'B'
      LDB BUFF2 
      CMW LENTH,I   GO TEST THESE ARRAYS
      JMP OUT       GOOD RETURN HERE. 
      SPC 1 
      NOP           ERROR RETURN HERE 
      LDB BUFF1     GET THE START ADDRESS 
      CMB,INB       AND SUBTRACT FROM 
      ADA B         PRESENT ADDRESS FOUND IN 'B'
      INA 
      JMP BAD       RETURN THE ERROR INDEX
      XIF 
      SKP 
OUT   CLA           GOOD RETURN HERE. 
      SPC 1 
BAD   STA IERR,I
      JMP CMPWD,I 
      SKP 
COUNT NOP 
A     EQU 0 
B     EQU 1 
      END 
ASMB,R,L
* 
************************************************************* 
*                                                           * 
*      UTILITY TO PERFORM A                                 * 
*           :DC,-LU                                         * 
*           :MC,LU                                          * 
*      WITHOUT CHANGING THE ORDER OF THE CARTRIDGES         * 
*      IN THE DIRECTORY.                                    * 
*                                                           * 
*      THIS UTILITY PATCHES THE CARTRIDGE DIRECTORY         * 
*      ON LU 2.                                             * 
*                                                           * 
*      WRITTEN BY:   TEF 8/24/78                            * 
*     MODIFIED BY:   DHP 8/10/79 FOR SESION MONITOR         * 
*                                                           * 
************************************************************* 
* 
      NAM  JDCMC,7   UTILITY TO DO A DCMC 790919
* 
      EXT  .ENTR,EXEC,$LIBR,$LIBX,REIO,PARSE,CNUMD
      EXT  $BMON,KCVT 
* 
      ENT  JDCMC
* 
      SUP PRESS EXTRANIOUS LISTINGS 
* 
*     CARTRIDGE DIRECTORY 
* 
STRCK BSS  1
SICNW OCT  000102 
SBUF  BSS  128
SBAD  DEF  SBUF 
SBADR DEF  SBUF 
SOVFL DEF  SBUF+124 
POINT BSS  1
* 
*     FILE DIRECTORY
* 
FTRCK BSS  1
FICNW OCT  074100 
FBUF  BSS  128
* 
*     TRACK ASSIGNMENT TABLE SAVE VALUES
* 
LTAT  BSS  1
DRTR  BSS  1
* 
*     INPUT/OUTPUT
* 
OUTMS ASC  2,LU # 
OUTLU BSS  3
      ASC 9, ALREADY OWNS ID #
OUTID BSS  3
      ASC  8, ENTER NEW ID? _ 
INCTL OCT  000400 
INID  BSS  33 
INLN  DEC  33 
PBUF  BSS  33 
* 
*     CONSTANTS 
* 
DISID NOP           -LU OF DISC 
SIZE  NOP           NUMBER OF TRACKS
SCBCD NOP           SST LENGTH WORD 
D0    DEC  0
D1    DEC  1
D2    DEC  2
D3    DEC  3
D4    DEC  4
D6    DEC  6
D25   DEC  25 
D128  DEC  128
DN1   DEC  -1 
* 
*     ERROR OUTPUT
* 
EMES  ASC  5,DCMC ERR 
ENUM  BSS  1
E1    ASC  1,L2 
E2    ASC  1,L3 
E3    ASC  1,NF 
E4    ASC  1,L0 
E5    ASC  1, 5 
E6    ASC  1,OV 
E7    ASC  1,NN 
E8    ASC  1,NG 
E9    ASC  1,ZE 
* 
      SKP 
************************************************************* 
*                                                           * 
*      START JDCMC                                           *
*                                                           * 
************************************************************* 
* 
LU    NOP           CRT 
IDISC NOP           DISC LU 
LASTR NOP           LAST TRACK OF CART. JUST RESTORED 
* 
JDCMC NOP 
      JSB  .ENTR    GET LU FROM INPUT PARAMETER 
      DEF LU
      LDA LU,I      GET CRT 
      STA LU         SAVE AS LOCAL VALUE
      LDA IDISC,I   SAME FOR DISC 
      STA IDISC      SAVE IT LOCAL TOO
      CMA,INA       SAVE AS -LU ALSO
      STA DISID 
      LDA LASTR,I     AND FINALLY 
      STA LASTR 
      ADA D1        ADD 1 FOR SIZE
      STA SIZE
* 
      LDA $BMON     CHECK WHAT OP. SYS. WHERE IN
      SZA,RSS 
      JMP DC.1      RTE -IV A 
* 
      JSB KCVT      CONVERT LU TO ASCII 
      DEF *+2 
      DEF IDISC 
      STA MES1+21   SAVE IN MESSAGE 
      STA MES1+27 
* 
      JSB EXEC      PRINT MESSAGE TO DO 
      DEF RTN         A :DC :MC ON LU XX. 
      DEF D2
      DEF LU
      DEF MES1
      DEF LEN1      LENGTH
RTN   JSB JDCMC,I   RETURN TO CALLER
* 
LEN1  DEC 29
MES1  OCT 6412
      ASC 13, TO UPDATE YOUR CART. LIST 
      OCT 6412
      ASC 14, DO A ':DC,-00,RR & :MC,00'. 
* 
*  THE FOLLOWING CODE CAN BE USED FOR AUTOMATIC MOUNTING OF THE DISC
*  LU.  IT HAS A NUMBER OF LIMITATIONS HOWEVER AND WAS NOT ADDED
*  IN THE INTEREST OF VERSATILITY AND PROGRAM SIZE.  FUTURE REVISIONS 
*  MAY INCLUDE THESE ENHANCEMENTS DEPENDING ON THE NEED.
* 
*     JSB $ESTB     GET THE SST LENGTH WORD 
*     STB SCBCD 
* 
*     JSB DCMC      CALL SESSION TO DO A DCMC 
*     DEF RTN 
*     DEF ENUM
*     DEF D3        CODE = 3 MOUNT LU AND CHANGE CRN IN CL
*     DEF DISID     -LU OF DISC 
*     DEF D0        P/G = 0 = PRIVATE 
*     DEF SIZE      SIZE OF THE DISC
*     DEF D0        IDENT (NOT USED)
*     DEF D0        DIRTK (NOT USED)
*     DEF D0        LABEL (NOT USED)
*     DEF SCBCD     SSB LENGTH WORD 
*     DEF D0        SECT (NOT USED) 
*RTN  JMP JDCMC,I   RETURN TO CALLER
* 
*     READ CARTRIDGE DIRECTORY
DC.1  LDA  1756B    A=#TRACKS ON LU2
      ADA  DN1      A=LAST FMP TRACK ON LU2 
      STA  STRCK
      JSB  EXEC     READ
      DEF  *+7
      DEF  D1 
      DEF  SICNW         CARTRIDGE
      DEF  SBUF 
      DEF  D128 
      DEF  STRCK
      DEF  D0                 DIRECTORY 
*     FIND CARTRIDGE POINTED TO BY LU 
D.1   LDB  SBADR    B=START OF SBUF 
      LDA  1,I      A=LU OF 1ST CARTRIDGE 
      SZA,RSS 
      JMP  ER3      CARTRIDGE NOT FOUND 
      CPA  LU+1 
      JMP  D.2      CARTRIDGE FOUND 
      ADB  D4       B=ADDRESS OF NEXT LU
      STB  SBADR    SBADR= "  "   "    "
      CMB,INB       CHECK 
      ADB  SOVFL         FOR
      SSB,RSS                 OVERFLOW
      JMP  D.1      CHECK NEXT LU 
      JMP  ER6      OVERFLOW ERROR
*     LU FOUND IN CARTRIDGE TABLE 
*     FIND CARTRIDGE SPEC ENTRY 
D.2   LDA LASTR     A=LAST FMP TRACK ON LU
      STA  FTRCK
      LDA  IDISC     PREPARE
      IOR  FICNW
      STA  FICNW         ICNWD
      JSB  EXEC     READ
      DEF  *+7
      DEF  D1 
      DEF  FICNW
      DEF  FBUF          FILE 
      DEF  D128 
      DEF  FTRCK
      DEF  D0                 DIRECTORY 
* 
*     CHECK FOR DUPLICATE ID'S
* 
      LDB  SBAD               B=START OF BUFFER 
      RSS 
D.3   LDB  POINT              POINT POINTS TO CURRENT LU
      CPB  SBADR              IS THIS THE LU TO BE CHANGED? 
      RSS                     YES 
      JMP  *+4                NO
      ADB  D4                 B POINTS TO NEXT LU 
      STB  POINT              POINT " " " 
      JMP  D.3                DO IT AGAIN 
      LDA  1,I                A " " " 
      SZA,RSS                 END OF LIST ? 
      JMP  D.5                YES 
      ADB  D2                 B POINTS TO CARTRIDGE/
      LDA  1,I                A=CURRENT ID
      CPA  FBUF+3             CHECK ID
      JMP  D.4                DUPLICATE ID FOUND
      ADB  D2                 B=ADDRESS OF NEXT LU
      STB  POINT              SAVE THIS 
      CMB,INB                 CHECK 
      ADB  SOVFL                 FOR
      SSB,RSS                       OVERFLOW
      JMP  D.3                CHECK NEXT LU 
      JMP  ER6                OVERFLOW
*     DUPLICATE ID - GET NEW ID FROM LOGLU
D.4   LDA  POINT              GET DUP LU ADDRESS
      STA  *+3                SAVE FOR OUTPUT 
      JSB  CNUMD              CONVERT 
      DEF  *+3                   LU 
      BSS  1                        TO
      DEF  OUTLU                       ASCII
      JSB  CNUMD              CONVERT 
      DEF  *+3                   ID 
      DEF  FBUF+3                   TO
      DEF  OUTID                       ASCII
      JSB  EXEC               OUTPUT
      DEF  *+5
      DEF  D2                    WARNING
      DEF  LU 
      DEF  OUTMS                    MESSAGE 
      DEF  D25
      LDA  INCTL
      IOR  LU 
      STA  INCTL
      JSB  REIO               INPUT 
      DEF  *+5
      DEF  D1 
      DEF  INCTL
      DEF  INID                  NEW
      DEF  INLN                      ID 
      RBL 
      STB  INLN 
      JSB  PARSE              PARSE 
      DEF  *+4
      DEF  INID                  ID 
      DEF  INLN 
      DEF  PBUF 
      LDA  PBUF+1             A=NEW ID
      SSA                     IS INPUT NEGATIVE 
      JMP  ER8                YES 
      SZA,RSS                 IS INPUT ZERO 
      JMP  ER9                YES 
      STA  FBUF+3             SAVE NEW ID 
      JSB  EXEC               KEEP
      DEF  *+7
      DEF  D2                    NEW
      DEF  FICNW
      DEF  FBUF                     FILE
      DEF  D128 
      DEF  FTRCK
      DEF  D0                          DIRECTORY
      JMP  D.3-2              DO IT AGAIN 
* 
*     MOVE LABEL WORD TO SBUF 
* 
D.5   LDA  FBUF+3   GET LABEL WORD
      LDB  SBADR
      ADB  D2       B POINTS TO LABEL WORD IN CART TABLE
      STA  1,I      LABEL STORED IN CARTRIDGE TABLE 
*     PATCH TRACK ASSIGNMENT TABLE
      JSB  PATCH
*     PATCH CARTRIDGE TABLE 
      JSB  EXEC     KEEP
      DEF  *+7
      DEF  D2            NEW
      DEF  SICNW
      DEF  SBUF               CARTRIDGE 
      DEF  D128 
      DEF  STRCK
      DEF  D0                      TABLE
*     UNPATCH TRACK ASSIGNMENT TABLE
      JSB UPTCH 
*     RETURN TO CALLING PROGRAM 
      JMP JDCMC,I 
* 
*     SUBROUTINES TO PATCH AND UNPATCH TAT
* 
*     PATCH TRACK ASSIGNMENT TABLE
PATCH NOP 
      JSB  $LIBR    TURN OFF MEMORY PROTECT 
      NOP 
      LDA  1656B    1656=FIRST WORD OF TRACK ASSIGNMENT TABLE 
      ADA  STRCK    A=LOCATION OF CARTRIDGE DIRECTORY ENTRY 
      STA  LTAT     LTAT= " " " " 
      LDB  0,I      GET D.RTR'S ID SEGMENT FROM TAT 
      STB  DRTR     SAVE THIS!!!!!!!!!!!!!!!
      LDB  1717B    GET THIS PROGRAM'S ID SEGMENT 
      STB  0,I      PATCH TAT 
      JSB  $LIBX    TURN ON MEMORY PROTECT
      DEF  PATCH
*     UNPATCH TRACK ASSIGNMENT TABLE
UPTCH NOP 
      JSB  $LIBR    TURN OFF MEMORY PROTECT 
      NOP 
      LDA  LTAT     LOCATION IN TRACK ASSIGNMENT TABLE
      LDB  DRTR     B=D.RTR'S ID SEGMENT FROM TAT 
      STB  0,I      PUT IT BACK!
      JSB  $LIBX    TURN ON MEMORY PROTECT
      DEF  UPTCH
* 
*     ERROR ROUTINE 
* 
ER1   LDA  E1 
      JMP  ESTP 
ER2   LDA  E2 
      JMP  ESTP 
ER3   LDA  E3 
      JMP  ESTP 
ER4   LDA  E4 
      JMP  ESTP 
ER5   LDA  E5 
      JMP  ESTP 
ER6   LDA  E6 
      JMP  ESTP 
ER7   LDA  E7 
      JMP  ESTP 
ER8   LDA  E8 
      JMP  ESTP 
ER9   LDA  E9 
ESTP  STA  ENUM 
      JSB  EXEC 
      DEF  *+5
      DEF  D2 
      DEF  LU 
      DEF  EMES 
      DEF  D6 
*     RETURN TO CALLING PROGRAM 
      JMP JDCMC,I 
      END