FTN4,L,C
C 
      PROGRAM WRITT (3,50),92067-16333 REV.2026 800416
C 
C     NAME: WRITT 
C     SOURCE: 92067-18333 
C     RELOC:  92067-16333 
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              -LU   MAG
C     RU,WRITT, OR ,TAPE, IH (INHIBIT REWIND), DC (DON'T PERFORM THE
C              +CRN   LU                             OVERLAY CHECK) 
C 
C     RU,WRITT       WILL DEFAULT TO THE FIRST PRIVATE OR GROUP 
C                    CARTRIDGE THAT'S MOUNTED TO THE SESSION
C                    EXECUTING THE PROGRAM. 
C 
C 
      IMPLICIT INTEGER (A-Z)
      LOGICAL NAMR,IN 
      EXTERNAL MT1OK,FESSN,NMCHK
      DIMENSION ILBUF(80),INAM1(10),INAM2(10),INAM3(10),INAM4(10) 
      DIMENSION MESSD(7),JTM(27),MSAVE(12),IDENT(2) 
      DIMENSION LUARY(2),ISTAT(256) 
      DIMENSION MRR1(13),MRR2(25),MRR3(11),MRR4(16),MRR5(12)
      DIMENSION MRR6(13),MRR7(12),MRR8(12),MRR9(27),MRR10(13) 
      DIMENSION MRR14(27),MRR15(29),LU(5),IREG(2) 
      DIMENSION IBUF(8193),JBUF(8192) 
      DIMENSION MES10(12),MES11(20),MES16(30) 
      DIMENSION MES12(26),MES14(9)
      INTEGER FIRST,LAST,FLAG,LASTTR
C 
      DIMENSION MSBUF(3)
      DIMENSION MESS9(8),MRR11(14),MRR12(25)
      DIMENSION ITM(30) 
      DIMENSION NAMBF(4),NAMDR(4) 
      COMPLEX ITMI(3) 
C 
      EQUIVALENCE (MESSD(5),MLU)
      EQUIVALENCE (IBUF,ITRAK),(JBUF,IBUF(2)) 
      EQUIVALENCE (ITME,ITM(13)),(NAMBF,ITM(6)) 
      EQUIVALENCE (NAMDR,JBUF(1)),(ITMI,ITM)
      EQUIVALENCE (LUARY,MTLU),(MTYPE,ITM(29))
      EQUIVALENCE (IDISC,INAM1) 
C 
      DATA MSBUF/2H  ,2H  ,2H  /
      DATA ITAPE/1/ 
      DATA MBLNK/2H  /
      DATA LASTTR/0/
      DATA MID1/2HPR/ 
      DATA MID2/2HGR/ 
      DATA LUARY(2)/2HWR/ 
      DATA JYES/2HYE/ 
      DATA MRR1/6412B,2HWR,2HIT,2H 0,2H01,2H  ,2HMA,2HG ,2HTA,2HPE, 
     &                2H D,2HOW,2HN / 
      DATA MRR2/6412B,2HWR,2HIT,2H 0,2H02,2H O,2HNL,2HY ,2HTH,2HE , 
     &                2HSY,2HS ,2HMN,2HGR,2H M,2HAY,2H S,2HAV,2HE , 
     &                2HSY,2HST,2HEM,2H D,2HIS,2HCS/
      DATA MRR3/6412B,2HWR,2HIT,2H 0,2H03,2H  ,2HLU,2H L,2HOC,2HKE, 
     &                2HD / 
      DATA MRR4/6412B,2HWR,2HIT,2H 0,2H04,2H  ,2HIL,2HLE,2HGA,2HL , 
     &                2HMA,2HG ,2HTA,2HPE,2H L,2HU /
      DATA MRR5/6412B,2HWR,2HIT,2H 0,2H05,2H  ,2HMT,2H O,2HFF,2H L, 
     &                2HIN,2HE /
      DATA MRR6/6412B,2HWR,2HIT,2H 0,2H06,2H  ,2HNO,2H W,2HRI,2HTE, 
     &                2H R,2HIN,2HG / 
      DATA MRR7/6412B,2HWR,2HIT,2H 0,2H07,2H P,2HAR,2HIT,2HY ,2HER, 
     &                2HRO,2HR /
      DATA MRR8/6412B,2HWR,2HIT,2H 0,2H08,2H  ,2HEN,2HD ,2HOF,2H T, 
     &                2HAP,2HE /
      DATA MRR9/6412B,2HWR,2HIT,2H 0,2H09,2H F,2HIL,2HE ,2HOP,2HEN, 
     &                2H O,2HR ,2HWR,2HIT,2HT',2HS ,2HDI,2HSC,2H L,2HU ,
     &                2HLO,2HCK,2H R,2HEJ,2HEC,2HTE,2HD / 
      DATA MRR10/6412B,2HWR,2HIT,2H 0,2H10,2H  ,2HDI,2HSC,2H N,2HOT,
     &                 2H F,2HOU,2HND/
      DATA MRR11/6412B,2HWR,2HIT,2H 0,2H11,2H  ,2HIL,2HLE,2HGA,2HL ,
     &                2HDI,2HSC,2H L,2HU /
      DATA MRR12/6412B,2HWR,2HIT,2H 0,2H12,2H O,2HNL,2HY ,2HTH, 
     &                 2HE ,2HSY,2HS ,2HMN,2HGR,2H M,2HAY,
     &                 2H S,2HAV,2HE ,2HLU,2H 2,2H O,2HR ,
     &                 2HLU,2H 3/ 
      DATA MRR14/6412B,2HWR,2HIT,2H 0,2H13,2H B,2HAD,2H T,2HRA,2HNS,
     &          2HMI,2HSS,2HIO,2HN-,2H-D,2HIS,2HC ,2HTO,2H M,2HEM,2HOR, 
     &         2HY ,2HTR,2HK ,2H  ,2H  ,2H  / 
      DATA MRR15/6412B,2HWR,2HIT,2H 0,2H14,2H B,2HAD,2H T,2HRA,2HNS,
     &          2HMI,2HSS,2HIO,2HN-,2H-M,2HEM,2HOR,2HY ,2HTO,2H M,2HAG, 
     &          2H T,2HAP,2HE ,2HRE,2HC ,2H  ,2H  ,2H  /
  
      DATA JLNTH/8192/
C 
      DATA MESS9/6412B,2H/W,2HRI,2HTT,2H: ,2H S,2HTO,2HP /
      DATA ITMI/8HCR      ,8H  CRNAME,8H SAVED  / 
      DATA MESSD/2HFR,2HOM,2H L,2HU ,2HXX,2HXX,2HXX/
C 
C 
      DATA MES10/6412B,2H  ,2H  ,2H  ,2H  ,2H  ,2H  ,2H  ,2HWA, 
     &           2HRN,2HIN,2HG /
      DATA MES11/2HWR,2HIT,2HT',2HS ,2HDI,2HSC,2H L,2HU ,2HLO,2HCK, 
     &           2H W,2HAS,2H N,2HOT,2H S,2HUC,2HCE,2HSS,2HFU,2HL,/ 
      DATA MES16/2HHO,2HWE,2HVE,2HR,,2H W,2HRI,2HTT,2H W,2HIL,2HL , 
     &           2HPE,2HRF,2HOR,2HM ,2HTH,2HE ,2HSA,2HVE,2H. ,2HIT, 
     &           2H'S,2H S,2HUG,2HGE,2HST,2HTE,2HD ,2HTH,2HAT,2H  / 
      DATA MES12/2HMO,2HDI,2HFI,2HCA,2HTI,2HON,2HS ,2HTO,2H D,2HIS, 
     &           2HC ,2HLU,2H  ,2H  ,2H  ,2HBE,2H P,2HOS,2HTP,2HON, 
     &           2HED,2H U,2HNT,2HIL,2H T,2HHE/ 
      DATA MES14/2HSA,2HVE,2H I,2HS ,2HCO,2HMP,2HLE,2HTE,2HD./
C 
C     PICK UP PARAMETERS +CRN OR -LU (DISC) AND + OR - MAG TAPE LU
C 
      CALL EXEC(14,1,ILBUF,-80) 
      CALL ABREG(IA,IB) 
      IS=1
      ILU=LOGLU(ISES)+400B
C 
C     PARSE "RU,WRITT"
C 
      IF(NAMR(INAM1,ILBUF,IB,IS))1,1
1     IF(NAMR(INAM1,ILBUF,IB,IS))2,2
C 
C     PARSE LU OR CRN, MTLU, IH (INHIBIT REWIND), DC (DON'T CHECK)
C 
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     MTLU=IABS(INAM2)
      IF(MTLU.EQ.0)MTLU=8 
C     MAG TAPE LU 
C     SET FLAG TO KNOW WHETHER TO INHIBIT REWIND  INHBT<0 DO NOT REWIND 
C                                                 INHBT>= REWIND
C 
      IF(INAM3.EQ.2HIH)INHBT=-1 
C 
C     SET FLAG TO NOT PERFORM THE OVERLAY FEATURE.
C 
      IF(INAM4.EQ.2HDC)IDONC=-1 
      IAUX=IXGET(1760B) 
C 
C     SET ISYSV=-1 IF SAVING LU 2 OR 3. 
C 
      IF(IABS(IDISC).EQ.2)ISYSV=-1
      IF((IAUX.NE.0).AND.(IABS(IDISC).EQ.3))ISYSV=-1
C 
C 
C     USE IGET TO GET CURRENT EXECUTING PROGRAM 
C 
      IXEQT=IXGET(1717B)
C 
C     CHECK VALIDITY OF MAG TAPE LU 
C 
      IF(LUARY.GT.64)GO TO 106
C 
      CALL EXEC(13+100000B,MTLU,ISTAT,ISTA1,ISTA2)
      GO TO 106 
C 
C     MUST BE DRIVERS 23 0R 24
C 
C 
C     CHECK TO SEE IF DEVICE IS BUFFERED. 
C     IF IT IS THEN A AND B REGS. ARE MEANINGLESS AFTER EXEC CALLS. 
C 
2555  BUFRD=0 
      IF(IAND(ISTA1,040000B).EQ.040000B) BUFRD=-1 
      IF(IAND(ISTAT,37400B)*2.EQ.23000B)GO TO 113 
      IF(IAND(ISTAT,37400B)*2.EQ.24000B)GO TO 113 
      GO TO 106 
C 
C     CHECK TO SEE IF MAG TAPE AND EQT ARE UP 
C 
113   IF(IAND(ISTAT,040000B).EQ.040000B)GO TO 100 
      IF(IAND(ISTA2,100000B).EQ.100000B)GO TO 100 
C 
C     LOCK MAG TAPE UNIT
C 
      CALL LURQ(140001B,MTLU,1) 
      GO TO 106 
2333  CALL ABREG(IA,IB) 
      IF(IA.EQ.1)GO TO 104
C 
C     PERFORM STATUS CHECK ON MAG TAPE UNIT 
C 
      CALL EXEC(13+100000B,MTLU,ISTAT)
      GO TO 106 
2666  ITYPE=IAND(ISTAT,37400B)/256
C 
C     CHECK FOR CORRECT DRIVER TYPE 
C 
      IF((ITYPE.EQ.23B).OR.(ITYPE.EQ.24B))GO TO 18
      GO TO 106 
C 
C     CHECK STATUS OF MAG TAPE
C 
18    CALL MT1OK(LUARY,FLAG)
      IF(FLAG.EQ.0)GO TO 15 
      IF(FLAG.EQ.1)GO TO 200
      IF(FLAG.EQ.2)GO TO 202
      IF(FLAG.EQ.4)GO TO 206
C 
C     CHECK TO SEE IF CRN (POSITIVE) OR LU (NEGATIVE) 
C     WAS SPECIFIED.
C 
C 
15    IF(IDISC.GE.0)GO TO 20
      IDISC=-IDISC
C 
C     MUST BE A LEGAL LU
C 
      IF(IDISC.LE.1)GO TO 115 
      IF(IDISC.GT.63)GO TO 115
C 
C     CHECK DRIVER TYPE OF SPECIFIED LU 
C 
      CALL EXEC(13+100000B,IDISC,ISTAT) 
      GO TO 115 
2444  ITYPE=IAND(ISTAT,37400B)/256
C 
C     NOT A DISK IF DVR NOT 30,31,32, OR 33 
C 
      IF((ITYPE.GT.27B).AND.(ITYPE.LT.34B))GO TO 117
C 
C     ILLEGAL DISC LU 
C 
115   CALL REIO(2,ILU,MRR11,14) 
      CALL PTERR(MRR11(2),FLAG) 
      GO TO 90
C 
117   IDISC=-IDISC
C 
C 
C     CHECK WHETHER IN SESSION OR NOT 
C     RETURN ADSCB =ADDRESS OF SCB
C       SMID=$SMID, OFFSET TO USER ID WORD IN SCB 
C       INSES=DESCRIBES WHETHER OR NOT IN SESSION 
C 
C 
20    IF(INHBT)2442,2440,2440 
C 
2440  REWIND MTLU 
C 
C 
2442  CALL FESSN(ADSCB,INSES,SMID)
C 
C     MOVE USER AND GROUP ID'S INTO IDENT 
C 
      CALL ISMVE(ADSCB,SMID,IDENT,2)
      IOP=0 
C 
C     IF SYSTEM MANAGER (7777B) HE HAS ACCESS TO ALL DISCS
C 
      IF(IDENT.EQ.7777B)IOP=1 
C 
C     CALL FSTAT TO GET ALL CARTRIDGES CURRENTLY MOUNTED
C 
      CALL FSTAT(ISTAT,256,1,IOP) 
C 
C     ONLY SYSTEM MANAGER CAN SAVE LU 2 AND LU 3
C     CHECK FOR NONQUALIFIED REQUESTS 
C 
      IF((IABS(IDISC).EQ.2).AND.(IDENT.NE.7777B))GO TO 212
      IF(IAUX.EQ.0)GO TO 2280 
      IF((IABS(IDISC).EQ.3).AND.(IDENT.NE.7777B))GO TO 212
C 
C     IS CRN OR LU SPECIFED 
C 
2280  IF(IDISC.GT.0)GO TO 23
      IF(IDISC.LT.0)GO TO 36
C 
C     NEITHER WAS SPECIFIED DEFAULT TO FIRST PRIVATE OR 
C     GROUP CATRIDGE MOUNTED TO HIS SESSION 
C 
      K=3 
C 
C     HE CAN'T DEFAULT TO SYS DISCS THOUGH
C 
228   IF(IDENT.EQ.7777B)GO TO 2283
      IF(ISTAT(K-2).EQ.2)GO TO 212
      IF((IAUX.NE.0).AND.(ISTAT(K-2).EQ.3))GO TO 212
2282  IF((ISTAT(K+1).EQ.7777B).AND.(IDENT.NE.7777B))GO TO 205 
C 
C     OTHERWISE GET DISC LU 
C 
2283  IDISC=IAND(ISTAT(K-2),00377B) 
      IF(IDENT.EQ.ISTAT(K+1).OR.IDENT(2).EQ.ISTAT(K+1))GO TO 230
C 
C     IF NO MORE CARTRIDGES THEN "DISC NOT FOUND" 
C 
      IF(ISTAT(K+1).EQ.0)GO TO 210
      K=K+4 
      GO TO 228 
C 
C     A CARTRIDGE HAS BEEN FOUND
C     CHECK FOR PRIVATE OR GROUP TYPE 
C 
230   TYPE=0
      IF(ISTAT(K+1).EQ.IDENT(2))TYPE=1
C 
C     SAVE LAST FMP TRACK (IT'S THE FIRST DIRECTORY TRACK)
C 
      ITRAK=ISTAT(K-1)
      GO TO 30
  
C 
C     CHECK TO SEE IF THE DISC IS REALLY THERE
C 
23    I=3 
24    IF(IDISC.EQ.ISTAT(I))GO TO 33 
      IF(ISTAT(I+2).EQ.0)GO TO 210
25    I=I+4 
      GO TO 24
  
C 
C     GET THE LU OF THE DISC AND MAKE SURE IT WASN'T THE SYSTEM DISC
C 
33    IDISC=IAND(ISTAT(I-2),00377B) 
      CALL ISMVE(ADSCB,SMID,IDENT,2)
      IF((ISTAT(I+1).EQ.7777B).AND.(IDENT.NE.7777B))GO TO 205 
C 
C     IS IT PRIVATE OF GROUP? 
C 
      TYPE=0
      IF(ISTAT(I+1).EQ.IDENT(2))TYPE=1
C 
C     SAVE THE LAST FMP TRACK (IT'S THE FIRST DIRECTORY TRACK)
C 
      ITRAK=ISTAT(I-1)
      GO TO 30
  
36    J=1 
      IDISC=-IDISC
C 
C     GET THE DISC LU AND MAKE SURE IT'S REALLY THERE 
C 
37    IF(IDISC.EQ.IAND(ISTAT(J),00377B))GO TO 38
      IF(ISTAT(J+4).EQ.0)GO TO 210
39    J=J+4 
      GO TO 37
  
C 
C     MAKE SURE IT'S NOT THE SYSTEM DISC
C 
38    CALL ISMVE(ADSCB,SMID,IDENT,2)
      IF((ISTAT(J+3).EQ.7777B).AND.(IDENT.NE.7777B))GO TO 205 
C 
C     PRIVATE OR GROUP DISC?
C 
      TYPE=0
      IF(ISTAT(J+3).EQ.IDENT(2))TYPE=1
C 
C     SAVE THAT LAST FMP TRACK (IT'S THE FIRST DIRECTORY TRACK) 
C 
      ITRAK=ISTAT(J+1)
C 
C     LOCK DISC LU THROUGH D.RTR
C 
30    CALL EXEC(23,6HD.RTR ,IXEQT,3,-IDISC,0,0,0,0) 
C 
C     IF THE FIRST WORD IS NEGATIVE THEN LOCK REQUEST IS REJECTED 
C 
      CALL RMPAR(LU)
C 
      IF(LU.LT.0)GO TO 208
C 
C 
      IF(LASTTR.NE.0)ITRAK=LASTTR 
C 
C     GET SEC/TRK OF DISC BY DOING AN IMPOSSIBLE READ.
C     DON'T DO IT IF IDISC EQUALS LU 2 OR LU 3
C 
      IF(ISYSV)2774,2775,2775 
C 
2774  IF(IABS(IDISC).EQ.2)IDUM=IXGET(1757B) 
      IF(IABS(IDISC).EQ.3)IDUM=IXGET(1760B) 
      GO TO 2777
C 
2775  CALL EXEC(1+100000B,IDISC,IDUM,1,-1,0)
      GO TO 115 
2777  CALL ABREG(IA,IB) 
C 
C     CALCULATE THE WORD/TRK VALUE OF THE DISC
C 
      JLNTH=IDUM*64 
C 
C     READ FIRST DIRECTORY TRACK FROM THE DISC
C 
      CALL EXEC(1,IDISC,JBUF,JLNTH,ITRAK,0) 
C 
C     MAKE SURE THE READ WAS O.K. 
C 
      CALL ABREG(IA,IB) 
      IF((IB.EQ.JLNTH).AND.(IAND(IA,1).NE.1)) GO TO 299 
C 
C     BAD LENGTH OR BIT ZERO OF EQT STATUS WORD 5 WAS SET 
C 
      CALL CNUMD(ITRAK,MRR14(25)) 
      CALL EXEC(2,ILU,MRR14,27) 
      CALL PTERR(MRR14(2),FLAG) 
  
299   CALL FTIME(ITME)
      MSBUF=JBUF(4) 
      ITM(4)=JBUF(4)
C 
C     CHECK FOR ILLEGAL FILENAME
C 
      CALL NMCHK(MSBUF) 
      CALL ABREG(IA,IB) 
      IF(IA.EQ.0)GO TO 300
      CALL CNUMD(MSBUF,ITM(2))
300   NAMBF=NAMDR 
      NAMBF(2)=NAMDR(2) 
      NAMBF(3)=NAMDR(3) 
      ITM(28)=MBLNK 
      MTYPE=MID1
      IF(TYPE.EQ.1)MTYPE=MID2 
C 
C     REMEMBER IF TAPE IS AT LOAD POINT 
C 
      CALL EXEC(13,MTLU,ISTA1)
C 
C     CHECK FOR POSSIBLE HEADER CONFLICT
C 
C     IF IDONC < 0 THEN DON'T CHECK TAPE HEADER.
C 
      IF(IDONC)190,170,170
C 
170   CALL EXEC(1+100000B,MTLU,JTM,27)
      GO TO 214 
1701  CALL ABREG(IA,IB) 
C 
C     IF BLANK TAPE I.E. TRANSMISSION LOG =0 THEN SKIP CHECK
C 
      IF(IB.EQ.0)GO TO 19 
  
C 
C     CHECK TO SEE IF THIS CARTRIDGE PREVIOUSLY RESIDES ON THE MAG TAPE 
C 
      DO 17 JJ=1,12 
        IF(ITM(JJ).NE.JTM(JJ))GO TO 21
17    CONTINUE
      GO TO 19
  
C 
C     SAVING A DIFFERENT CARTRIDGE TO THIS TAPE. BETTER MAKE SURE USER
C     IS AWARE OF THIS. 
C 
21    CALL EXEC(2,ILU,2H  ,1) 
      CALL EXEC(2,ILU,24H****** CAUTION *********,12) 
      CALL EXEC(2,ILU,14HDO YOU WANT TO,7)
      CALL EXEC(2,ILU,10H OVERLAY  ,5)
      IF(JTM(1).NE.2HCR) CALL EXEC(2,ILU,16H A NONWRITT TAPE ,8)
      CALL EXEC(2,ILU,JTM,27) 
      CALL EXEC(2,ILU,10H   WITH   ,5)
      CALL EXEC(2,ILU,ITM,30) 
      CALL EXEC(2,ILU,14H(YES OR NO)?  ,7)
      CALL EXEC(1,ILU,JTM,27) 
      CALL EXEC(2,ILU,2H  ,1) 
      IF(JTM.EQ.JYES)GO TO 19 
      CALL EXEC(2,ILU,22H*** DISC NOT SAVED ***,11) 
      CALL EXEC(2,ILU,2H  ,1) 
C 
C     IF INHIBIT REWIND WAS SPECIFIED ONLY BACKUP ONE RECORD. 
C 
      IF(INHBT.NE.-1)GO TO 90 
C 
      CALL EXEC(3,MTLU+200B)
      GO TO 92
C 
C     REWIND MAG TAPE AND WRITE NEW HEADER TO IT AND TO USER
C 
19    IF(IAND(ISTA1,100B).EQ.1)GO TO 185
C 
C     IF TAPE WASN'T AT LOAD POINT THEN BACKUP ONE RECORD 
C 
      CALL EXEC(3,MTLU+200B)
      GO TO 190 
185   REWIND MTLU 
190   CALL EXEC(2,MTLU,ITM,30)
      CALL EXEC(2,ILU,ITM,30) 
C 
C     SAVE FIRST FMP TRACK (FIRST DATA TRACK) AND LAST FMP TRACK (LAST
C     DATA TRACK). ALSO SAVE THE LOWEST DIRECTORY TRACK.
C 
      FIRST=JBUF(5) 
      LAST=JBUF(10) 
      IF(LAST.EQ.LASTTR)LAST=LAST-1 
      IF((IAND(JBUF(6),7777B)).EQ.0)LAST=LAST-1 
      LOWDIR=JBUF(8)
C 
C     CHECK THE SEC/TRK VALUE FOUND IN THE CARTRIDGE SPECIFICATION ENTRY. 
C     (FIRST 16 WORDS OF THE FIRST DIRECTORY FILE). IF IT'S DIFFERENT 
C     THAN WHAT'S BEEN FOUND BEFORE, RESET IT AND RECALCULATE THE 
C     WORD/TRK VALUE OF THE DISC. 
C 
      IF(JBUF(7).EQ.IDUM) GO TO 42
      IDUM=JBUF(7)
      JLNTH=IDUM*64 
C 
C     TELL USER WHICH LU IS BEING SAVED 
C 
42    CALL CNUMD(IDISC,MLU) 
      CALL EXEC(2,ILU,MESSD,7)
      GO TO 411 
  
C 
C     COPY TRACKS, DIRECTORY TRACK(S) FIRST, FOLLOWED BY DATA TRACK(S)
C     UNUSED TRACKS WILL NOT BE COPIED. 
C 
40    CALL EXEC(1,IDISC,JBUF,JLNTH,ITRAK,0) 
C 
C     MAKE SURE READ WAS O.K. 
C 
      CALL ABREG(IA,IB) 
      IF((IB.EQ.JLNTH).AND.(IAND(IA,1).NE.1)) GO TO 411 
C 
C 
C     BAD LENGTH OR ERROR EXISTS BIT OF EQT STATUS WORD 5 WAS SET.
C 
      CALL CNUMD(ITRAK,MRR14(25)) 
      CALL EXEC(2,ILU,MRR14,27) 
      CALL PTERR(MRR14(2),FLAG) 
C 
C     CHECK FOR END OF TAPE 
C 
411   CALL EXEC(3,MTLU+600B)
      CALL ABREG(IA,IB) 
      IF((IAND(IA,00040B).NE.40B))GO TO 403 
      CALL EXEC(3,MTLU+500B)
      CALL EXEC(2,ILU,MRR8,12)
      CALL PTERR(MRR8(2),FLAG)
      CALL EXEC(2,ILU,28HPLEASE MOUNT ANOTHER TAPE   ,-28)
405   CALL EXEC(2,ILU,25HAFTER MOUNTING ENTER "GO",-25) 
      CALL REIO(1,ILU,INBF,1) 
      IF(INBF.NE.2HGO)GO TO 407 
      ITAPE=ITAPE+1 
      CALL EXEC(2,MTLU,ITAPE,1) 
      GO TO 41
  
407   IF(INBF.EQ.2HAB)GO TO 90
      GO TO 405 
  
403   IF(IFBRK(IDMY))90,41
C 
C     NOW WRITE THAT TRACK TO MAG TAPE
C 
41    CALL EXEC(2,MTLU,IBUF,JLNTH+1)
C 
C     MAKE SURE WRITE WAS O.K.
C 
      IF(BUFRD.NE.0)GO TO 406 
      CALL ABREG(IA,IB) 
C 
C     PARITY ERROR? 
C 
      IF(IAND(IA,2).EQ.2) GO TO 204 
C 
C     TRANSMISSION LENGTH O.K.? 
C 
      IF(IB.EQ.JLNTH+1) GO TO 406 
      CALL CNUMD(ITRAK,MRR15(27)) 
      CALL EXEC(2,ILU,MRR15,29) 
      CALL PTERR(MRR15(2),FLAG) 
C 
C     GO COPY DATA TRKS IF DONE WITH DIRECTORY TRACKS.
C 
406   IF(ITRAK.EQ.LOWDIR) GO TO 45
C 
C     ELSE - DECREMENT TRK # TO NEXT DIRECTORY TRK. 
C 
      ITRAK=ITRAK-1 
      GO TO 40
C 
C     MAG TAPE DOWN 
C 
100   CALL EXEC(2,ILU,MRR1,13)
      CALL PTERR(MRR1(2),FLAG)
      GO TO 92
C 
C     LU LOCKED 
C 
104   CALL EXEC(2,ILU,MRR3,11)
      CALL PTERR(MRR3(2),FLAG)
      GO TO 92
C 
C     ILLEGAL LU
C 
106   CALL EXEC(2,ILU,MRR4,16)
      CALL PTERR(MRR4(2),FLAG)
      GO TO 92
C 
C     MAG TAPE OFF LINE 
C 
200   CALL EXEC(2,ILU,MRR5,12)
      CALL PTERR(MRR5(2),FLAG)
      GO TO 92
C 
C     NO WRITE RING 
C 
202   CALL EXEC(2,ILU,MRR6,13)
      CALL PTERR(MRR6(2),FLAG)
      GO TO 92
C 
C     PARITY ERROR
C 
204   CALL EXEC(2,ILU,MRR7,12)
      CALL PTERR(MRR7(2),FLAG)
      GO TO 92
C 
C     END OF TAPE 
C 
206   CALL EXEC(2,ILU,MRR8,13)
      CALL EXEC(2,ILU,28HMOUNT ANOTHER TAPE, AFTER   ,-28)
      CALL EXEC(2,ILU,28HMOUNTING "RU,WRITT,... AGAIN,-28)
      CALL PTERR(MRR8(2),FLAG)
      GO TO 92
C 
C     DISC LU LOCKED
C 
208   CALL EXEC(2,ILU,MRR9,27)
      CALL PTERR(MRR9(2),FLAG)
      GO TO 90
C 
C 
C     DISC NOT FOUND
C 
210   CALL EXEC(2,ILU,MRR10,13) 
      CALL PTERR(MRR10(2),FLAG) 
      GO TO 90
C 
C     CAN`T SAVE SYSTEM DISCS 
C 
205   CALL EXEC(2,ILU,MRR2,25)
      CALL PTERR(MRR2(2),FLAG)
      GO TO 90
C 
C     CAN'T SAVE LU 2 0R 3
C 
212   CALL EXEC(2,ILU,MRR12,25) 
      CALL PTERR(MRR12(2),FLAG) 
      GO TO 90
C 
C     BAD TRANSMISSION OF DATA
C 
214   CALL EXEC(2,ILU,MRR14,14) 
      CALL PTERR(MRR14(2),FLAG) 
      GO TO 1701
C 
C     NOW SAVE DATA TRACKS
C 
45    DO 49 ITRAK=FIRST,LAST
C 
C     READ DATA TRACK FROM DISC 
C 
46    CALL EXEC(1,IDISC,JBUF,JLNTH,ITRAK,0) 
C 
C     MAKE SURE READ WAS O.K. 
C 
      CALL ABREG(IA,IB) 
      IF((IB.EQ.JLNTH).AND.(IAND(IA,1).NE.1)) GO TO 474 
C 
C     BAD LENGTH OR ERROR EXISTS BIT IN EQT STATUS WORD 5 WAS SET.
C 
      CALL CNUMD(ITRAK,MRR14(25)) 
      CALL EXEC(2,ILU,MRR14,27) 
      CALL PTERR(MRR14(2),ITRAK)
C 
C     CHECK FOR END OF TAPE 
C 
474   CALL EXEC(3,MTLU+600B)
      CALL ABREG(IA,IB) 
      IF((IAND(IA,00040B).NE.40B))GO TO 443 
      CALL EXEC(3,MTLU+500B)
      CALL EXEC(2,ILU,MRR8,12)
      CALL PTERR(MRR8(2),FLAG)
475   CALL EXEC(2,ILU,28HPLEASE MOUNT ANOTHER TAPE   ,-28)
      CALL EXEC(2,ILU,25HAFTER MOUNTING ENTER "GO",-25) 
      CALL REIO(1,ILU,INBF,1) 
      IF(INBF.NE.2HGO)GO TO 477 
      ITAPE=ITAPE+1 
      CALL EXEC(2,MTLU,ITAPE,1) 
      GO TO 47
  
477   IF(INBF.EQ.2HAB)GO TO 90
      GO TO 475 
  
443   IF(IFBRK(IDMY))90,47
47    CALL EXEC(2,MTLU,IBUF,JLNTH+1)
C 
C     MAKE SURE WRITE WAS O.K.
      IF(BUFRD.NE.0)GO TO 49
      CALL ABREG(IA,IB) 
C 
C     PARITY ERROR? 
C 
      IF(IAND(IA,2).EQ.2) GO TO 204 
C 
C     TRANSMISSION LENGTH O.K.? 
C 
      IF(IB.EQ.JLNTH+1) GO TO 49
      CALL CNUMD(ITRAK,MRR15(27)) 
      CALL EXEC(2,ILU,MRR15,29) 
      CALL PTERR(MRR15(2),FLAG) 
49    CONTINUE
C 
C     PUT 2 EOF AT THE END. 
C     BACK OVER ONE END OF FILE 
C 
C 
      ENDFILE MTLU
      ENDFILE MTLU
C 
C 
      CALL EXEC(3,MTLU+1400B) 
C 
C  END:   REWIND TAPE 
C 
C     CHECK WHETHER TO REWIND OR NOT INHBT< 0 DON'T REWIND
C 
      IF(INHBT)92,90,90 
C 
90    CALL EXEC(3,MTLU+500B)
92    CALL EXEC(23,6HD.RTR ,IXEQT,5,-IDISC,0,0,0,0) 
      CALL LURQ(40000B,MTLU,1)
      GO TO 94
93    CONTINUE
C 
C     REPORT:  /WRITT:  STOP
C 
94    CALL REIO(2,ILU,MESS9,8)
C 
      END 
      END$