FTN4,Q,T
C 
      PROGRAM READT (3,50),92067-16332 REV.2026 800522
C 
C 
C     NAME:   READT 
C     SOURCE: 92067-18332 
C     RELOC:  92067-16332 
C     PGMR:   R.D.
C 
C  ***************************************************************
C  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979.  ALL RIGHTS     *
C  * RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED,      *
C  * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT*
C  * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.       *
C  ***************************************************************
C 
C 
C   CALLING SEQUENCE IS:
C 
C                  -LU    MAG   P 
C         RU,READT, OR , TAPE , OR , SIZE (# TRACKS),IH (INHIBIT REWIND)
C                  +CRN   LU    G 
C 
C  READT WILL MOUNT A CARTRIDGE FROM THE DISC POOL IF A CRN OR DISC 
C  LU ISN'T SPECIFIED. CARTRIDGE TYPE (PRIVATE OR GROUP) WILL DEFAULT 
C  TO WHAT'S FOUND IN THE HEADER. SIZE IS THE NUMBER OF DESIRED TRACKS, 
C  DEFAULT IS THE SIZE RETURNED FROM THE MOUNT ROUTINE. IH WILL INHIBIT 
C  THE REWIND OF THE MAG TAPE BEFORE AND AFTER THE RESTORE. 
C 
C 
C 
C 
C                        **** NOTE **** 
C 
C  IN CASES WHERE THE RATIO OF INTEGER VARIABLES ARE COMPUTED, EACH 
C  IS FLOATED BEFORE THE OPERATION. THIS IS DONE TO AVOID THE TRUNCATION
C  AFTER EACH INTEGER OPERATION WHICH NORMALLY OCCURS.
C 
C 
      IMPLICIT INTEGER(A-Z) 
      DOUBLE PRECISION TSEC(2)
      REAL T
      LOGICAL NAMR,IN 
      EXTERNAL MT1OK,FESSN,DCMC,NMCHK,VVALD,REDIR,REFMT,IDSGM 
      DIMENSION MBUFR(9),DLNTH(2),JBUF(8192)
      DIMENSION ILBUF(80),INAM1(10),INAM2(10),INAM3(10),INAM4(10) 
      DIMENSION INAM5(10) 
      DIMENSION MSCRN(21),MSDRT(23),MSBUF(3),IDENT(2),KBUFR(4)
      DIMENSION MS10(10),MS11(16),MS12(14)
      DIMENSION MDR1(24),MDR2(17),MDR3(26),MDR4(24),MR13(32)
      DIMENSION LUARY(2),MRR11(11),MRR12(16),MRR17(19)
      DIMENSION MRR1(13),MRR2(14),MRR3(11),MRR4(16),MRR5(12)
      DIMENSION MR15(17),MR14(24),ISTAT(256),MR16(22),MR17(26),MR18(20) 
      DIMENSION MRR6(13),MRR7(12),MRR8(12),MRR9(27),MRR10(22) 
      DIMENSION LU(5),IREG(2),DTYPE(3)
      DIMENSION IDISK(2),MESS8(7),MESLU(10),MSFMT(30) 
C 
C  COMMON BLOCK FOR SUBROUTINES VVALD, RESET, AND REFMT.
C 
      COMMON/COMRD/ ILU,ITAPE,NDIR,IDISC,MTLU,SIZE,IBUF(8193) 
C 
C 
      EQUIVALENCE (IBUF(1),ITRAK),(JBUF,IBUF(2))
      EQUIVALENCE (LUARY(1),MTLU),(MRR12(16),FLAG)
      EQUIVALENCE (IBUF(30),DTYPE)
      EQUIVALENCE (LU(3),INAM3(1))
C 
C 
      DATA ILNTH/8192/
      DATA JLNTH/8192/
      DATA MSBUF/2H  ,2H  ,2H  /
      DATA INSES/0/ 
      DATA MRR1/6412B,2HRE,2HAD,2H 0,2H01,2H  ,2HMA,2HG ,2HTA,2HPE, 
     &                2H D,2HOW,2HN / 
      DATA MRR2/6412B,2HRE,2HAD,2H 0,2H02,2H  ,2HBA,2HD ,2HTA,2HPE, 
     &                2H F,2HOR,2HMA,2HT /
      DATA MRR3/6412B,2HRE,2HAD,2H 0,2H03,2H  ,2HLU,2H L,2HOC,2HKE,2HD /
      DATA MRR4/6412B,2HRE,2HAD,2H 0,2H04,2H  ,2HIL,2HLE,2HGA,2HL , 
     &                2HMA,2HG ,2HTA,2HPE,2H L,2HU /
      DATA MRR5/6412B,2HRE,2HAD,2H 0,2H05,2H  ,2HMT,2H O,2HFF,2H L,2HIN,
     &                2HE / 
      DATA MRR6/6412B,2HRE,2HAD,2H 0,2H06,2H I,2HLL,2HEG,2HAL,
     &                2H D,2HIS,2HC ,2HLU/
      DATA MRR7/6412B,2HRE,2HAD,2H 0,2H07,2H  ,2HPA,2HRI,2HTY,2H E,2HRR,
     &                2HOR/ 
      DATA MRR8/6412B,2HRE,2HAD,2H 0,2H08,2H  ,2HEN,2HD ,2HOF,2H T,2HAP,
     &                2HE / 
      DATA MRR9/6412B,2HRE,2HAD,2H 0,2H09,2H F,2HIL,2HE ,2HOP,2HEN, 
     &               2H O,2HR ,2HRE,2HAD,2HT',2HS ,2HDI,2HSC,2H L,2HU , 
     &                2HLO,2HCK,2H R,2HEJ,2HEC,2HTE,2HD / 
      DATA MRR10/6412B,2HRE,2HAD,2H 0,2H10,2H  ,2HNO,2HN ,2HSE,2HSS,
     &                 2HIO,2HN:,2H L,2HU ,2HMU,2HST,2H B,2HE ,2HNE,
     &                 2HGA,2HTI,2HVE/
      DATA MRR11/6412B,2HRE,2HAD,2H 0,2H11,2H  ,2HSI,2HZE,2H E,2HRR,
     &                 2HOR/
      DATA MRR12/6412B,2HRE,2HAD,2H 0,2H12,2H  ,2HMO,2HUN,2HT ,2HER,
     &                 2HRO,2HR ,2HFM,2HGR,2H 0,2HXX/ 
C 
      DATA MESS8/2H/R,2HEA,2HDT,2H: ,2H S,2HTO,2HP /
      DATA MESLU/2HRE,2HST,2HOR,2HED,2H T,2HO , 
     &                 2HLU,2H  ,2H  ,2H  / 
      DATA MDR1/2HCR,2HN ,2H  ,2H  ,2H  ,2H W,2HAS,2H S,2HAV, 
     &               2HED,2H F,2HRO,2HM ,2HA ,2H  ,2H  ,2H  ,2H  ,
     &               2H T,2HRA,2HCK,2H D,2HIS,2HC / 
      DATA MDR2/2HLA,2HST,2H T,2HRA,2HCK,2H U,2HSE,2HD ,2HIS, 
     &               2H  ,2H  ,2H  ,2H  ,2H  ,2H  ,2H  ,2H  / 
      DATA MDR3/2HRE,2HAD,2HT ,2HWO,2HUL,2HD ,2HLI,2HKE,2H T, 
     &               2HO ,2HRE,2HST,2HOR,2HE ,2H T,2HO ,2HA , 
     &               2H  ,2H  ,2H  ,2H T,2HRA,2HCK,2H D,2HIS,2HC /
      DATA MDR4/2HIS,2H I,2HT ,2HOK,2HAY,2H T,2HO ,2HMO,2HVE, 
     &               2H D,2HIR,2HEC,2HTO,2HRY,2H T,2HRA,2HCK, 
     &               2HS ,2H(Y,2HES,2H O,2HR ,2HNO,2H)?/
      DATA MR13/6412B,2HRE,2HAD,2H 0,2H13,2H  ,2HSP,2HEC,2HIF,2HIE, 
     &               2HD ,2HLU,2H O,2HR ,2HFR,2HEE,2H L,2HU ,2HNO,
     &               2HT ,2HBI,2HG ,2HEN,2HOU,2HGH,2H T,2HO ,2HMO,
     &               2HUN,2HT ,2HCR,2HN / 
      DATA MSCRN/2HCR,2HN ,2H  ,2H  ,2H  ,2H H,2HAS,2H B,2HEE,
     &               2HN ,2HCH,2HAN,2HGE,2HD ,2HTO,2H C,2HRN, 
     &               2H  ,2H  ,2H  ,2H  / 
      DATA MSDRT/6412B,2HDI,2HRE,2HCT,2HOR,2HY ,2HTR,2HAC,2HKS,2H M,
     &               2HOV,2HED,2H F,2HRO,2HM ,2H  ,2H  ,2H  , 
     &               2H T,2HO ,2H  ,2H  ,2H  /
      DATA MSFMT/6412B,2HTR,2HAC,2HKS,2H R,2HEF,2HOR,2HMA,2HTT,2HED,
     &          2H F,2HRO,2HM ,2H  ,2H  ,2H  ,2H S,2HEC,2H/T,2HRK,2H T, 
     &               2HO ,2H  ,2H  ,2H  ,2H S,2HEC,2H/T,2HRK,6412B/ 
      DATA MR14/6412B,2HDO,2H Y,2HOU,2H W,2HAN,2HT ,2HTO,2H O,
     &                2HVE,2HRL,2HAY,2H C,2HRN,2H  ,2H  ,2H  ,
     &                2H  ,2HON,2H L,2HU ,2H  ,2H  ,2H  / 
      DATA MR15/6412B,2HWI,2HTH,2H C,2HRN,2H  ,2H  ,2H  ,2H  ,2H  , 
     &               2H(Y,2HES,2H O,2HR ,2HNO,2H) ,20137B/
      DATA MR16/6412B,2HDU,2HPL,2HIC,2HAT,2HE ,2HCR,2HN ,2HLA,2HBE, 
     &                2HL ,2HOR,2H L,2HU ,2HAL,2HRE,2HAD,2HY ,2HMO, 
     &                2HUN,2HTE,2HD / 
      DATA MR17/6412B,2HRE,2HAD,2H 0,2H14,2H O,2HNL,2HY ,2HTH,2HE , 
     &                2HSY,2HS ,2HMN,2HGR,2H M,2HAY,2H R,2HES,2HTO, 
     &                2HRE,2H S,2HYS,2HTE,2HM ,2HDI,2HCS/ 
      DATA MR18/6412B,2HRE,2HAD,2H 0,2H17,2H I,2HLL,2HEG,2HAL,2H R, 
     &                2HES,2HTO,2HRE,2H T,2HO ,2HLU,2H 2,2H O,2HR ,2H3 /
      DATA MRR17/6412B,2H E,2HOF,2H E,2HNC,2HOU,
     &           2HNT,2HER,2HED,2H B,2HEF,2HOR,2HE ,2HDA,2HTA,2H T, 
     &           2HRA,2HCK,2HS /
      DATA MS10/2HDI,2HSC,2H A,2HLR,2HEA,2HDY,2H M,2HOU,2HNT,2HED/
      DATA MS11/2HDO,2H Y,2HOU,2H W,2HAN,2HT ,2HTO,2H O,2HVE,2HRL,
     &          2HAY,2H L,2HU ,2H  ,2H  ,2H  /
      DATA MS12/2HWI,2HTH,2H C,2HRN,2H  ,2H  ,2H  ,2H (,2HYE,2HS ,
     &          2HOR,2H N,2HO),2H  /
C 
C  INITIALIZE TAPE COUNT - THE NUMBER OF REELS
C 
      ITAPE=1 
C 
C  SET UP "ILU" AS TERMINAL LU
C 
      CALL EXEC(14,1,ILBUF,-80) 
      CALL ABREG(IA,IB) 
      IS=1
      ILU=LOGLU(ISES)+400B
C 
C  PARSE FIRST 2 PARTS OF COMMAND STRING (I.E. "RU,READT")
C 
      IF(NAMR(INAM1,ILBUF,IB,IS))1,1
1     IF(NAMR(INAM1,ILBUF,IB,IS))2,2
C 
C  NOW PARSE COMMAND STRING TO GET CRN,MTLU,....  ETC.
C 
2     IF(NAMR(INAM1,ILBUF,IB,IS))3,3
3     IF(NAMR(INAM2,ILBUF,IB,IS))4,4
4     IF(NAMR(INAM3,ILBUF,IB,IS))5,5
5     IF(NAMR(INAM4,ILBUF,IB,IS))6,6
6     IF(NAMR(INAM5,ILBUF,IB,IS))7,7
C 
7     ILU=LOGLU(ISES)+400B
C 
      IDISC=INAM1(1)
      MTLU=INAM2(1) 
      SIZE=INAM4(1) 
C 
C     CHECK WHETHER TO INHIBIT REWIND,  IF SO INHBT=-1,OTHERWISE INHBT>=0 
C 
      IF(INAM5.EQ.2HIH)INHBT=-1 
C 
C      PICK UP MAG TAPE LU, DEFAULT IS 8
C 
      IF (MTLU.EQ.0)MTLU=8
      MTLU=IABS(MTLU) 
C 
C       SIZE PARAMETER MUST BE POSITIVE 
C 
      IF(INAM4.LT.0)GO TO 885 
C 
C     SET ISYSV=-1 IF RESTORING LU 2
C 
      IF(IABS(IDISC).EQ.2)ISYSV=-1
C 
C     IF RESTORING AUX DISC THEN SET ISYSV=-2 
C 
C  PICK UP CONTENTS OF BASE PAGE WORD 1760B - # SEC/TRK ON LU 3.
C 
      IAUX=IXGET(1760B) 
C 
      IF((IAUX.NE.0).AND.(IABS(IDISC).EQ.3))ISYSV=-2
C 
C 
C  USE IGET TO GET CURRENT EXECUTING PROGRAM ADDRESS
C 
      IXEQT=IXGET(1717B)
C 
C  DETERMINE WHETHER OR NOT IN SESSION
C  OUT OF SESSION, -LU MUST BE SPECIFED 
C     ADSCB - ADDRESS OF SCB
C     INSES - =0 IF IN SESSION  =1 IF NOT 
C     SMID  - OFFSET TO USER ID WORD OF SCB 
C 
      CALL FESSN(ADSCB,INSES,SMID,SMDL) 
C 
C  GET USER AND GROUP ID'S FROM SCB 
C     USER ID IN FIRST WORD, GROUP ID IN SECOND WORD OF IDENT 
C 
      CALL ISMVE(ADSCB,SMID,IDENT,2)
C 
C 
C     CAN'T RESTORE SYS OR AUX DISC IF NOT SYS. MNGR. (ID=7777B)
C 
      IF((IABS(IDISC).EQ.2).AND.(IDENT.NE.7777B))GO TO 208
      IF(IAUX.EQ.0)GO TO 8
      IF((IABS(IDISC).EQ.3).AND.(IDENT.NE.7777B))GO TO 208
C 
C 
8     IF (INSES.EQ.0)GO TO 10 
      IF (IDISC.GE.0)GO TO 80 
C 
C  CHECK VALDITY OF LU - ISTAT IS EQT STATUS WORD 5.
C                        ISTA1 IS EQT STATUS WORD 4 (NOT USED)
C                        ISTA2 - SPECIFIES WHETHER DEVICE UP OR DOWN
C 
10    IF(LUARY.GT.64)GO TO 106
      CALL EXEC(13+100000B,MTLU,ISTAT,ISTA1,ISTA2)
      GO TO 106 
C 
C  MUST BE DRIVERS 23 OR 24 
C 
2666  IF(IAND(ISTAT,37400B)*2.EQ.23000B)GO TO 14
      IF(IAND(ISTAT,37400B)*2.EQ.24000B)GO TO 14
      GO TO 106 
C 
C  CHECK TO SEE IF LU AND EQT ARE UP
C 
14    IF(IAND(ISTAT,040000B).EQ.040000B)GO TO 100 
      IF(IAND(ISTA2,100000B).EQ.100000B)GO TO 100 
C 
C  LOCK MAG TAPE LU 
C 
      CALL LURQ(140001B,MTLU,1) 
      GO TO 106 
C 
C  IF A-REGISTER = 1, THEN ALREADY LOCKED.
C 
2333  CALL ABREG(IA,IB) 
      IF(IA.EQ.1)GO TO 104
C 
C  CHECK STATUS OF MAG TAPE UNIT
C   FLAG=1 IF OFLINE/BUSY; =4 IF EOT
C 
      CALL MT1OK(LUARY,FLAG)
      IF(FLAG.EQ.1)GO TO 200
      IF(FLAG.EQ.4)GO TO 206
C 
C  IF IDISC > 0, THEN CRN ## WAS SPECIFIED
C 
      IF(IDISC.GE.0)GO TO 28
C 
C  IF IDISC < -63, THEN ILLEGAL DISC LU 
C 
      IF(IDISC.LT.-63)GO TO 82
C 
C 
28    IF(INHBT)30,295,295 
C 
295   REWIND MTLU 
C 
C 
C 
C  GET HEADER FROM MAG TAPE 
C 
30    CALL EXEC(1+100000B,MTLU,IBUF,ILNTH+1)
      GO TO 81
3001  CALL ABREG(IA,IB) 
      IF(IAND(IA,2).EQ.2)GO TO 204
      HEDLNT=IB 
      IRMBR=0 
C 
C IF HEADER LENGTH NOT WHAT WAS EXPECTED - ERROR (BAD TAPE FORMAT)
C 
      IF((HEDLNT.LT.2).OR.(HEDLNT.GT.50))GO TO 81 
C 
C  CHECK FOR TYPE OF CARTRIDGE, I.E. PRIVATE OR GROUP 
C 
      IF(LU(3).EQ.0)GO TO 37
      TYPE=0
      IF((LU(3).EQ.2HG ).OR.(LU(3).EQ.2HGR))TYPE=1
      GO TO 39
37    TYPE=0
      IF(IBUF(29).EQ.2HGR)TYPE=1
C 
C  WRITE OUT HEADER 
C 
39    CALL EXEC(2,ILU,IBUF,31)
      IF(IDISC.GE.0)GO TO 44
C 
C  SET UP DISC LU FOR EXTENDED EXEC CALL
C 
      IDISK=-IDISC
C 
C  CHECK I/O STATUS OF DISC - ISTAT EQT STATUS WORD 5 
C 
      CALL EXEC(13+100000B,IDISK,ISTAT) 
      GO TO 82
2555  ITYPE=IAND(ISTAT,37400B)/256
C 
C  THIS LU OK IF DVR IS 30,31,32, OR 33 
C 
      IF((ITYPE.LE.27B).OR.(ITYPE.GE.34B))GO TO 82
C 
C  READ THE NEXT RECORD IF THE LAST WAS A HEADER (LENGTH <= 100). 
C 
44    CALL EXEC(1,MTLU,IBUF,ILNTH+1)
C 
C  THIS SHOULD BE THE FIRST DIRECTORY TRACK 
C  CHECK FOR END OF TAPE
C  A-REGISTER HAS EQT STATUS WORD FIVE
C 
      CALL ABREG(IA,IB) 
  
      IF((IAND(IA,00040B).NE.40B))GO TO 141 
      CALL EXEC(3,MTLU+500B)
      CALL EXEC(2,ILU,MRR8,12)
      CALL PTERR(MRR8(2),FLAG)
182   CALL EXEC(2,ILU,28HPLEASE MOUNT SUBSEQUENT TAPE,-28)
183   CALL EXEC(2,ILU,25HAFTER MOUNTING ENTER "GO",-25) 
      CALL REIO(1,ILU,INBF,1) 
      IF(INBF.EQ.2HAB)GO TO 91
      IF(INBF.NE.2HGO)GO TO 183 
C 
C  FIRST RECORD (ONE WORD) CONTAINS TAPE COUNT. MAKE SURE TAPE COUNT
C  IS WHAT'S EXPECTED.
C 
      ITAPE=ITAPE+1 
      CALL EXEC(1,MTLU,INBUF,1) 
      CALL ABREG(IA,IB) 
      IF(INBUF.NE.ITAPE)GO TO 190 
      GO TO 141 
C 
C  WRONG TAPE COUNT 
C  HE PROBABLY MOUNTED THE WRONG REEL, TELL HIM SO. 
C 
C 
190   CALL EXEC(2,ILU,MRR2,14)
      CALL PTERR(MRR2(2),FLAG)
      ITAPE=ITAPE-1 
      GO TO 182 
  
141   ISIZE=INAM4 
  
C 
C  JBUF(4) IS CRN FROM FILE DIRECTORY OF MAG TAPE.
C 
      IF(IDISC.EQ.JBUF(4).OR.IDISC.LE.0)GO TO 443 
C 
C  REPORT CHANGE OF CRN NUMBER
C  ALSO CHECK TO SEE IF NEW NUMBER IS REALLY ASCII
C  IF CRN IS LEGAL FILENAME THEN DON'T CONVERT
C 
      MSBUF=IDISC 
      MSCRN(19)=IDISC 
      CALL NMCHK(MSBUF) 
      CALL ABREG(IA,IB) 
      IF(IA.EQ.0)GO TO 440
      CALL CNUMD(IDISC,MSCRN(18)) 
  
440   MSBUF=JBUF(4) 
      MSCRN(3)=JBUF(4)
      CALL NMCHK(MSBUF) 
      CALL ABREG(IA,IB) 
      IF(IA.EQ.0)GO TO 449
      CALL CNUMD(JBUF(4),MSCRN(3))
C 
C  "CRN XXX HAS BEEN CHANGED TO CRN YYY". 
C 
449   CALL EXEC(2,ILU,MSCRN,21) 
443   IBTRK=0 
C 
C  GET CURRENT CARTRIDGE NUMBER 
C 
      IF(IDISC.GT.0)JBUF(4)=IDISC 
      IF(IDISC.NE.0)GO TO 447 
      IDISC=JBUF(4) 
      ICRN=JBUF(4)
      GO TO 650 
447   ICRN=0
      IF(IDISC.GT.0)GO TO 650 
      ICRN=JBUF(4)
C 
C  DISC LU SPECIFIED, MAKE SURE CRN OF MAG TAPE DOESN'T DUPLICATE A 
C  CRN NAME CURRENTLY MOUNTED ON ANOTHER CARTRIDGE. THAT IS SEARCH
C  CARTRIDGE LIST.
C 
C 
      CALL FSTAT(ISTAT,256,1,0) 
      I=3 
C 
C  SET IRMBR TO INDICATE DISC ALREADY MOUNTED 
C 
      IRMBR=-1
624   IF(ICRN.NE.ISTAT(I))GO TO 625 
      IF((-IDISC).NE.IAND(ISTAT(I-2),377B))GO TO 633
625   IF(ISTAT(I+2).EQ.0)GO TO 650
      I=I+4 
      GO TO 624 
C 
C  DISC LU IS CURRENTLY MOUNTED TO SOMEONE ELSE RETURN ERROR
C 
633   FLAG=12 
      GO TO 83
C 
C 
650   FLAG=0
      ITDSC=IDISC 
C 
C  MUST BE SYS MNGR TO RESTORE CRN 2
C 
C 
      IF((ICRN.EQ.2).AND.(IDENT.NE.7777B))GO TO 208 
C 
C     CHECK TO SEE IF AUX DISC EXISTS, IF IT DOES THEN CAN'T RESTORE IT.
C 
      IF(IAUX.EQ.0)GO TO 655
      IF((ICRN.EQ.3).AND.(IDENT.NE.7777B))GO TO 208 
C 
C 
C 
C 
C  REMEMBER SECTOR/TRK VALUE AND WORD/TRK VALUE OF MAG TAPE 
C  JBUF(7)=SECTOR/TRACK VALUE ON MAG TAPE 
C 
C 
655   ISCTR=JBUF(7) 
      ILNTH=JBUF(7)*64
C 
C  CALL MOUNT ROUTINE TO GET CARTRIDGE OR DISC LU 
C  (LAST PARAMETER IN CALL TO "DCMC" SPECIFIES SEC/TRK VALUE. BY NOT
C  REQUESTING A SPECIFIC SEC/TRK VALUE IT WILL DEFAULT TO THE FIRST 
C  AVAILABLE CARTRIDGE FROM THE DISC POOL). 
C 
C 
      CALL DCMC(FLAG,3,IDISC,TYPE,SIZE,0,0,ICRN,0,0)
C 
C  B-REGISTER CONTAINS DISC LU MOUNT OBTAINED 
C 
      CALL ABREG(IA,IDISC)
C 
C 
C 
      IF(ISYSV)660,670,670
C 
660   IF(ISYSV.EQ.-1)IDUM=IXGET(1757B)
      IF(ISYSV.EQ.-2)IDUM=IXGET(1760B)
C 
C     CHECK CONDITIONS FOR A LEGAL RESTORE
C     GET STARTING TRACK LOC OF FMP TRACKS
C     NOW COMPARE AGAINST NEW LOCATION
C     ALSO, NEW SEC/TRK MUST BE THE SAME
C 
C     CALL EXEC(1,-ITDSC,MBUFR,9) 
C     IF((MBUFR(5).LT.JBUF(5)).OR.(ISCTR.NE.IDUM))CALL EXEC(2,ILU,
C    & 16HILLEGAL RESTORE ,-8)
C 
C 
C 
C  IF FLAG(ERROR WORD) IS ZERO THEN PROCEED WITH RESTORATION
C  TO THE DESCRIBED DISC LU.
C  IF FLAG IS 12 THEN CARTRIDGE IS ALREADY MOUNTED, FIND
C  CRN NUMBER AND DISC LU FROM FSTAT AND PROMPT USER ON WHETHER 
C  TO PROCEED WITH RESTORING THE CARTRIDGE. 
C  REPORT ALL OTHER ERRORS AND RETURN 
C 
670   IF (FLAG.EQ.0)GO TO 434 
      IF(FLAG.NE.12)GO TO 83
      IF(ITDSC.LT.0)GO TO 500 
C 
C  A CARTRIDGE WAS SPECIFIED, SEARCH FSTAT FOR A MATCH
C  SET IRMBR TO INDICATE DISC WAS ALREADY MOUNTED 
C 
      J=1 
      IRMBR=-1
      CALL FSTAT(ISTAT,256,1,0) 
337   IF(JBUF(4).EQ.ISTAT(J+2))GO TO 338
      IF(ISTAT(J+4).EQ.0)GO TO 83 
      J=J+4 
      GO TO 337 
C 
C  FOUND IT 
C 
338   IF((ISTAT(J+3).EQ.7777B).AND.(IDENT.NE.7777B))GO TO 83
      IDISC=IAND(ISTAT(J),00377B) 
C 
C  DO IMPOSSIBLE READ OF DISC AND MAKE SURE IT HAS ENOUGH ROOM. 
C  JBUF(7) - SEC/TRK VALUE FROM MAG TAPE
C  IDUM - SEC/TRK VALUE OF DISC 
C     IBTRK = LAST TRACK OF DISC LU 
C     IDENT = TYPE (PRIVATE OR GROUP) 
C 
C 
      IBTRK=ISTAT(J+1)
      IDENT=ISTAT(J+3)
C 
C     IF RESOTRING LU 2 OR 3 GET LAST TRACK FROM CL.
C        DO NOT ALLOW MOVING THE FIRST FMP TRACK BACK.
C        E.G. FROM TRACK 100 TO TRACK 90. 
C        NOR ALLOW RESTORING TO A DIFFERENT SEC/TRK CARTRIDGE.
C 
C 
      IF(ISYSV.GE.0)GO TO 342 
      IBSZE=ISTAT(J+1)+1
      CALL EXEC(1,IDISC,MBUFR,9,ISTAT(J+1),0) 
      IF(JBUF(5).LT.MBUFR(5))GO TO 210
      IF(MBUFR(7).NE.IDUM)GO TO 210 
      GO TO 340 
C 
342   CALL EXEC(1,IDISC,IDUM,1,-1,0)
C 
C  ROOM ENOUGH? COMPARE # SECTORS NECESSARY (FROM MT) WITH
C  # SECTORS AVAILABLE (FROM DISC). 
C  JBUF(6) - NEXT AVAILABLE SECTOR (FROM MT)
C  JBUF(10) - NEXT AVAILABLE TRACK  " 
C  JBUF(9) - # DIRECTORY TRACKS (NEGATIVE)
C 
340   IF((FLOAT(JBUF(10)-JBUF(9))*ISCTR+JBUF(6)).GT.
     & FLOAT(IBTRK+1)*IDUM) GO TO 84
      ITDSC=IDISC 
C 
C 
C  DON'T CONVERT IF ASCII 
C 
      MSBUF=IDISC 
      MR14(25)=IDISC
      CALL NMCHK(MSBUF) 
      CALL ABREG(IA,IB) 
      IF(IA.EQ.0)GO TO 350
      MR14(24)=KCVT(IDISC)
  
350   MSBUF=(JBUF(4)) 
      MR14(16)=(JBUF(4))
      MR15(8)=(JBUF(4)) 
      CALL NMCHK(MSBUF) 
      CALL ABREG(IA,IB) 
      IF(IA.EQ.0)GO TO 355
      CALL CNUMD(JBUF(4),MR14(15))
      CALL CNUMD(JBUF(4),MR15(6)) 
C 
C     DO YOU WANT TO OVERLAY......? 
C 
355   CALL EXEC(2,ILU,MR16,22)
      CALL EXEC(2,ILU,MR14,24)
      CALL EXEC(2,ILU,MR15,17)
      CALL REIO(1,ILU,INBF,1) 
      IF(INBF.EQ.2HYE)GO TO 357 
      CALL EXEC(2,ILU,16HCRN NOT RESTORED,8)
      GO TO 91
357   IDISC=-IDISC
      I=J 
      GO TO 560 
C 
C  A DISC LU WAS SPECIFIED, SEARCH FSTAT FOR A MATCH
C 
500   CALL FSTAT(ISTAT,256,1,0) 
      I=1 
C 
C  SET IRMBR=-1 TO INDICATE DISC WAS MOUNTED ALREADY. 
C 
      IRMBR=-1
532   IF((-ITDSC).EQ.IAND(ISTAT(I),00377B))GO TO 538
      IF(ISTAT(I+4).EQ.0)GO TO 83 
      I=I+4 
      GO TO 532 
C 
C     ICRN = CARTRIDGE REFERENCE NUMBER 
C     IBTRK= LAST TRACK 
C     IDENT= TYPE CARTRIDGE (PRIVATE OR GROUP)
C 
538   IF((ISTAT(I+3).EQ.7777B).AND.(IDENT.NE.7777B))GO TO 83
      ICRN=ISTAT(I+2) 
      IBTRK=ISTAT(I+1)
      ITDSC=-ITDSC
      IDISC=-ITDSC
C 
C     IF RESTORING LU 2 OR 3 THEN GET LAST TRACK FROM CL
C     CAN'T MOVE STARTING FMP TRACKS BACK 
C       NOR CAN YOU RESTORE TO A CARTRDIGE WITH A DIFFERENT SEC/TRK VALUE.
C 
C 
C 
      IF(ISYSV.GE.0)GO TO 542 
      IBSZE=ISTAT(I+1)+1
      CALL EXEC(1,ITDSC,MBUFR,9,ISTAT(I+1),0) 
      IF(JBUF(5).LT.MBUFR(5))GO TO 210
      IF(MBUFR(7).NE.IDUM)GO TO 210 
      GO TO 539 
C 
C 
C 
542   CALL EXEC(1,ITDSC,IDUM,1,-1,0)
      CALL ABREG(IA,IBSZE)
C 
C  ROOM ENOUGH? CHECK # SECTORS NEEDED VS. # SECTORS AVAILABLE. 
C 
539   IF((FLOAT(JBUF(10)-JBUF(9))*ISCTR+JBUF(6)).GT.
     & FLOAT(IBTRK+1)*IDUM) GO TO 84
      IDENT=ISTAT(I+3)
      MS11(16)=KCVT(ITDSC)
      MSBUF=JBUF(4) 
      MS12(7)=JBUF(4) 
      CALL NMCHK(MSBUF) 
      CALL ABREG(IA,IB) 
      IF(IA.EQ.0)GO TO 540
      CALL CNUMD(JBUF(4),MS12(5)) 
C 
C  DISC CARTRIDGE ALREADY MOUNTED, ASK USER IF O.K. TO OVERLAY WITH 
C  WHAT'S ON TAPE.
C 
540   CALL EXEC(2,ILU,MS10,10)
      CALL EXEC(2,ILU,MS11,16)
      CALL EXEC(2,ILU,MS12,14)
      CALL REIO(1,ILU,INBF,1) 
      IF(INBF.EQ.2HYE)GO TO 560 
C 
      CALL EXEC(2,ILU,16HCRN NOT RESTORED,8)
      GO TO 91
C 
C  UPDATE SYSTEM CARTRIDGE LIST I.E. CALL D.RTR TO DO THE UPDATE
C  KBUFR CONTAINS 1. DISC LU 2.LAST FMP TRACK 3.CRN 4.ID
C 
560   CALL EXEC(2,ILU,18H/READT:  CONTINUE ,9)
      KBUFR(1)=ITDSC
      KBUFR(2)=IBTRK
      KBUFR(3)=JBUF(4)
      KBUFR(4)=IDENT
C 
C  CALL D.RTR 
C 
      CALL EXEC(23,6HD.RTR ,IXEQT,15,-ITDSC,0,0,KBUFR,4)
C 
C  CALL D.RTR TO LOCK DISC
C 
      CALL EXEC(23,6HD.RTR ,IXEQT,3,-ITDSC,0,0,0,0) 
C 
C  CHECK TO SEE IF LOCK WAS REJECTED
C 
      CALL RMPAR(LU)
C 
C     IF THE FIRST WORD IS NEGATIVE THEN LOCK WAS REJECTED. 
C 
      IF(LU.LT.0)GO TO 102
C 
C     IF NOT RESTORING SYS OR AUX DISCS THEN SKIP THIS. 
C 
      IF(ISYSV)788,434,434
C 
C     FIND OUT IF THERE ARE ANY ID SEG. POINTING TO FMP TRACKS
C     ON THE CARTRIDGE BEING RESTORED.
C 
C 
C     JBUF(5) IS THE FIRST AVAILABLE TRACK FOR FMP FILES
C 
C 
788   DISCL=IABS(ITDSC) 
C 
      IDISC=-ITDSC
C 
C 
      CALL IDSGM(DISCL,JBUF(5),ILU,IERR)
      IF(IERR)91,434,434
C 
C 
C  A CARTRIDGE OR DISC HAS BEEN FOUND RE-ADJUST TRACK SIZE
C  IF NECESSARY 
C 
434   IDISC=-IDISC
      IF(IBTRK.EQ.0)GO TO 437 
C 
C  DO AN IMPOSSIBLE READ TO GET SEC/TRACK VALUE OF DISC 
C  AND THEN DETERMINE IF THERE'S ENOUGH ROOM ON THE DISC. 
C  (OTHERWISE CAN'T RESTORE TO THAT LU) 
C 
C 
      IF(ISYSV)1110,430,430 
C 
430   CALL EXEC(1,IDISC,IDUM,1,-1,0)
      CALL ABREG(IA,IBSZE)
C 
C  ROOM ENOUGH? 
C  COMPARE # TRACKS USED ON MAG TAPE WITH # TRACKS AVAILABLE ON DISC. 
C  (SINCE THEY MAY HAVE DIFFERENT SEC/TRK VALUES, MUST USE RATIO).
C 
1110  IF((JBUF(10)*FLOAT(ISCTR)/FLOAT(IDUM)).GT.
     & ((IBTRK+(JBUF(9)+1))*FLOAT(ISCTR)/FLOAT(IDUM))) GOTO 84
      SIZE=IBTRK+1
C 
C  DO AN IMPOSSIBLE READ TO GET TRACK AND SECTOR
C  SIZE OF DISC LU
C 
C 
C 
C 
437   IF(ISYSV)4350,438,438 
C 
438   CALL EXEC(1,IDISC,IDUM,1,-1,0)
      CALL ABREG(IA,IBSZE)
4350  IF((IDUM.NE.ISCTR).OR.(IBSZE.GE.SIZE)) GOTO 445 
C 
C  IF CARTRIDGE CAN BE MOUNTED TO DIFFERENT SIZE
C  DISC ASK USER IF IT'S OKAY TO PROCEED
C 
      IF((FLOAT(JBUF(10)-JBUF(9))*ISCTR+JBUF(6)).GT.
     & FLOAT(IBSZE)*IDUM)GO TO 84 
      MSBUF=(JBUF(4)) 
      MDR1(3)=(JBUF(4)) 
      CALL NMCHK(MSBUF) 
      CALL ABREG(IA,IB) 
      IF(IA.EQ.0)GO TO 423
      CALL CNUMD(JBUF(4),MDR1(3)) 
  
423   ISIZE=JBUF(8)+1 
      CALL CNUMD(ISIZE,MDR1(15))
      CALL CNUMD(JBUF(10),MDR2(15)) 
      CALL CNUMD(IBSZE,MDR3(18))
      CALL REIO(2,ILU,MDR1,24)
      CALL REIO(2,ILU,MDR2,17)
      CALL REIO(2,ILU,MDR3,26)
      CALL REIO(2,ILU,MDR4,24)
      CALL REIO(1,ILU,MBUF,1) 
      IF(MBUF.NE.2HYE)GO TO 90
      SIZE=IBSZE
C 
C  IF SIZE OF CARTRIDGE IS NOT EQ TO SIZE SPECIFIED 
C  THEN TELL USER THE DIRECTORY TRACKS HAVE BEEN MOVED
C 
445   IF(SIZE.EQ.0)SIZE=IBSZE 
C 
C     MAKE SURE THERE'S ENOUGH ROOM 
C 
      IF((FLOAT(JBUF(10)-JBUF(9))*ISCTR+JBUF(6)).GT.
     & FLOAT(IBSZE)*IDUM) GO TO 84
      IF(JBUF(8)-JBUF(9).EQ.SIZE)GO TO 446
      CALL CNUMD((JBUF(8)-JBUF(9)-1),MSDRT(16)) 
      CALL CNUMD(SIZE-1,MSDRT(21))
      CALL EXEC(2,ILU,MSDRT,23) 
446   JBUF(8)=SIZE+JBUF(9)
C 
C  COMPUTE WORD/TRK VALUE OF DISC.
C 
      JLNTH=IDUM*64 
C 
C  SAVE LOWEST DIRECTORY TRACK AND TOTAL NUMBER OF DIRECTORY TRACKS.
C 
      LODIR=JBUF(8) 
      NDIR=-(JBUF(9)) 
C 
C  SEC/TRK SAME? IF NOT, GO RE-FORMAT BEFORE RESTORE. 
C 
      IF(ISCTR.NE.IDUM) GOTO 600
C 
C  NOW COPY DIRECTORY TRACKS. 
C 
C     INITIALIZE RELATIVE DIRECTORY SECTOR  (USED ONLY FOR  LU 2 OR 3)
C 
      JJ=0
C 
      DO 47 II=1,NDIR 
       N=9
C 
C  GET READY TO CLEAR OPEN FLAGS (4 ENTRIES/SECTOR).
C 
       DO 46 I=1,ISCTR*4
C 
C  IF THIS IS THE FIRST TIME THROUGH, SKIP. 
C 
        IF((II.EQ.1).AND.(N.EQ.9)) GOTO 455 
C 
C  NOW CLEAR 'EM OUT (OPEN FLAGS, THAT IS). 
C 
         DO 45 J=1,7
          JBUF(N+J)=0 
45       CONTINUE 
C 
C INCREMENT TO NEXT ENTRY (EACH ENTRY 16 WORDS).
C 
455      N=N+16 
46      CONTINUE
C 
C  WRITE DIRECTORY TRACK TO DISC
C 
C     IF RESTORING SYS OR AUXILARY DISC HAVE D.RTR RESTORE
C     DIRECTORY TRACKS. 
C 
C 
      IF(ISYSV)460,465,465
C 
C 
C     THIS CODE IS USED ONLY WHEN RESTORING LU 2 OR 3.
C     **********************************************
C     BB IS POINTER INTO JBUF ONLY 128 WORDS ARE WRITTEN AT A TIME
C     JJ IS THE RELATIVE DIRECTORY SECTOR E.G. 98 IS
C     SECTOR 2 OF THE SECOND DIR. TRACK ON A 96 SECTOR/TRK CRN. 
C     THIS IS USED ONLY WHEN RESTORING LU 2 OR LU 3.
C 
C 
460   BB=1
462   CALL EXEC(23,6HD.RTR ,IXEQT,9,IDISC,JJ,0,JBUF(BB),128)
      BB=(JJ+1)*14
      BB=BB-((BB/ISCTR)*ISCTR)
      BB=(BB*64)+1
      JJ=JJ+1 
      IF(JJ.EQ.((ISCTR*II)/2))GO TO 470 
      GO TO 462 
C 
C 
464   GO TO 470 
C 
C 
465    CALL EXEC(2+100000B,IDISC+74000B,JBUF,JLNTH,SIZE-II,0) 
C 
C     DO ANYTHING EXCEPT ABORT
C 
4666  GO TO 4655
4777  GO TO 4666
C 
C  MAKE SURE WRITE WAS O.K. 
C 
4655   CALL ABREG(IA,IB)
       CALL VVALD(IA,IB,-1,JLNTH,SIZE-II,0,0,FLAG,0)
C 
C  GET NEXT TRACK FROM MAG TAPE 
C 
470    IF(II.EQ.NDIR) GOTO 47 
       CALL EXEC(1,MTLU,IBUF,ILNTH+1) 
       CALL ABREG(IA,IB)
C 
C  MAKE SURE READ WAS O.K.
C      IERR - = 1 EOF - TROUBLE, WHERE ARE DATA TRACKS? 
C             =-1 ABORT 
C             =-2 PARITY ERROR
C 
       IERR=0 
       CALL VVALD(IA,IB,1,JLNTH,ITRAK,0,ILNTH,FLAG,IERR)
       IF(IERR.EQ.1) GOTO 201 
       IF(IERR.EQ.-1) GOTO 91 
       IF(IERR.EQ.-2) GOTO 204
47    CONTINUE
C 
C  NOW DO DATA TRACKS.
C 
48    CALL EXEC(1,MTLU,IBUF,ILNTH+1)
      CALL ABREG(IA,IB) 
C 
C  MAKE SURE READ WAS O.K.
C      IERR -  = 1  EOF (NORMAL TERMINATION)
C              =-1  ABORT 
C              =-2  PARITY ERROR
C 
      IERR=0
      CALL VVALD(IA,IB,1,JLNTH,ITRAK,0,ILNTH,FLAG,IERR) 
      IF(IERR.EQ.1) GOTO 203
      IF(IERR.EQ.-1) GOTO 91
      IF(IERR.EQ.-2) GOTO 204 
C 
C  READ WAS O.K. NOW WRITE TRACK TO DISC. 
C 
       CALL EXEC(2+100000B,IDISC+74000B,JBUF,JLNTH,ITRAK,0) 
C 
4790  GO TO 4800
4888  GO TO 4790
C  MAKE SURE WRITE WAS O.K. 
C 
4800  CALL ABREG(IA,IB) 
      CALL VVALD(IA,IB,-1,JLNTH,ITRAK,0,0,FLAG,0) 
      GOTO 48 
  
C 
C  MUST CHANGE THE FOLLOWING SO THAT FMGR WILL HAVE CORRECT INFO
C  AFTER THE REFORMATTING OCCURS: 
C     1) NEXT AVAILABLE TRACK AND SECTOR.   JBUF(10),JBUF(6)
C     2) SEC/TRK                            JBUF(7) 
C     3) FIRST AVIALABLE FMP TRACK          JBUF(5) 
C 
600   TSEC=FLOAT(JBUF(10))*FLOAT(ISCTR)+JBUF(6) 
      JBUF(10)=TSEC/IDUM
      JBUF(6)=TSEC-FLOAT(JBUF(10))*FLOAT(IDUM)
      JBUF(7)=IDUM
C 
C     PICK UP STARTING TRACK LOCATION 
C 
      TEMP2=JBUF(5) 
C 
C  TELL USER THAT THE SEC/TRK VALUE OF THE NEW CARTRIDGE IS 
C  DIFFERENT AND THAT MT TRACKS MUST BE RE-FORMATTED BEFORE 
C  RESTORING. 
C 
      CALL CNUMD(ISCTR,MSFMT(14)) 
      CALL CNUMD(IDUM,MSFMT(23))
      CALL EXEC(2,ILU,MSFMT,30) 
C 
C  CALL SUBROUTINE TO REFORMAT AND RESTORE DIRECTORY TRACKS TO DISC.
C      IERR -  = 1  EOF - TROUBLE, WHERE ARE DATA TRACKS? 
C              =-1  ABORT 
C              =-2  PARITY ERROR
C 
      IERR=0
      CALL REDIR(ISCTR,IDUM,FLAG,IERR)
      IF(IERR.EQ.1) GOTO 201
      IF(IERR.EQ.-1) GOTO 91
      IF(IERR.EQ.-2) GOTO 204 
C 
C  EVERYTHING WENT O.K. NOW DO SAME FOR THE DATA TRACKS.
C     IERR -  = 1  EOF (NORMAL TERMINATION) 
C             =-1  ABORT
C             =-2  PARITY ERROR 
C 
      IERR=0
      CALL REFMT(ISCTR,IDUM,FLAG,IERR,TEMP2)
      IF(IERR.EQ.1) GOTO 203
      IF(IERR.EQ.-1) GOTO 91
      IF(IERR.EQ.-2) GOTO 204 
C 
C  ERRORS 
C 
C  NON-SESSION: LU MUST BE NEGATIVE 
C 
80    CALL EXEC(2,ILU,MRR10,22) 
      CALL PTERR(MRR10(2),FLAG) 
      GO TO 91
C 
C  BAD TAPE FORMAT
C 
81    CALL EXEC(2,ILU,MRR2,14)
      CALL PTERR(MRR2(2),FLAG)
      GO TO 91
C 
C  ILLEGAL DISC LU
C 
82    CALL EXEC(2,ILU,MRR6,13)
      CALL PTERR(MRR6(2),FLAG)
      GO TO 91
C 
C  SPECIFIED DISC LU MOUNTED TO SOMEONE ELSE OR CRN ALREADY EXISTS. 
C 
83    IF(FLAG.GE.0)GO TO 835
      FLAG=-FLAG
      MRR12(15)=2H-0
835   MRR12(16)=KCVT(FLAG)
      CALL EXEC(2,ILU,MRR12,16) 
      CALL PTERR(MRR12(2),FLAG) 
      IF(IRMBR) 91,90,90
C 
C  SPECIFIED LU OR FREE LU IS NOT BIG ENOUGH TO RESTORE CRN 
C 
84    CALL EXEC(2,ILU,MR13,32)
      CALL PTERR(MR13(2),FLAG)
      IF(IRMBR)91,90,90 
C 
C  MAG TAPE DOWN
C 
100   CALL EXEC(2,ILU,MRR1,13)
      CALL PTERR(MRR1(2),FLAG)
      GO TO 92
C 
C  DISC LU LOCKED 
C 
102   CALL EXEC(2,ILU,MRR9,27)
      CALL PTERR(MRR9(2),FLAG)
      GO TO 91
C 
C  LU LOCKED
C 
104   CALL EXEC(2,ILU,MRR3,11)
      CALL PTERR(MRR3(2),FLAG)
      GO TO 95
C 
C  ILLEGAL MAG TAPE LU
C 
106   CALL EXEC(2,ILU,MRR4,16)
      CALL PTERR(MRR4(2),FLAG)
      GO TO 94
C 
C  MAG TAPE OFFLINE 
C 
200   CALL EXEC(2,ILU,MRR5,12)
      CALL PTERR(MRR5(2),FLAG)
      GO TO 92
C 
C  EOF FOUND BEFORE DATA TRACKS 
C 
201   CALL EXEC(2,ILU,MRR17,19) 
C 
C  NORMAL TERMINATION - EVERYTHING HAS BEEN RESTORED. 
C 
203   CALL CNUMD(IDISC,MESLU(8))
      CALL EXEC(2,ILU,MESLU,10) 
      GOTO 91 
C 
C  PARITY ERROR 
C 
204   CALL EXEC(2,ILU,MRR7,12)
      CALL PTERR(MRR7(2),FLAG)
      GO TO 91
C 
C  END OF TAPE
C 
206   CALL EXEC(2,ILU,MRR8,12)
      CALL PTERR(MRR8(2),FLAG)
      GO TO 92
C 
C  CAN'T RESTORE LU 2 
C 
208   CALL EXEC(2,ILU,MR17,26)
      CALL PTERR(MR17(2),FLAG)
      GO TO 91
C 
C     ILLEGAL RESTORE TO LU 2 OR 3. 
C 
210   CALL EXEC(2,ILU,MR18,20)
      CALL PTERR(MR18(2),FLAG)
      GO TO 91
C 
C  SIZE ERROR (# OF TRACKS REQUESTED IS TO SMALL TO RESTORE TO )
C 
885   CALL EXEC(2,ILU,MRR11,11) 
      CALL PTERR(MRR11(2),FLAG) 
      GO TO 91
C 
C  UNLOCK AND DISMOUNT DISC LU. 
C 
90    CALL DCMC(FLAG,2,-IDISC,2HRR) 
C 
C  INHIBIT REWIND? IF (INHBT)YES,NO,NO
C 
91    IF(INHBT)92,911,911 
911   CALL EXEC(3,MTLU+500B)
C 
C  UNLOCK DISC
C 
92    CALL EXEC(23,6HD.RTR ,IXEQT,5,-ITDSC,0,0,0,0) 
C 
C  UNLOCK MAG TAPE UNIT 
C 
94    CALL LURQ(40000B,MTLU,1)
      GO TO 93
95    CONTINUE
C 
C  REPORT /READT: STOP
C 
93    CALL EXEC(2,ILU,MESS8,7)
  
      END 
      END$