FTN4,Q,C
      PROGRAM DISK(3,90),92067-16348 REV.2026 800502
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 PROGRAMMING LANGUAGE     *
C*  WITHOUT THE PRIOR WRITTEN CONSENT OF THE HEWLETT-PACKARD     *
C*  COMPANY.                                                     *
C*                                                               *
C*****************************************************************
C 
C     NAME:  DISK 
C   SOURCE:  92067-18348
C    RELOC:  PART OF 92067-12003
C     PGMR:  J.S.W
C 
C 
      DIMENSION IXBUF(8209),IHDR(247),IREG(2),
     X          IBUF(8192),ITX32(161),ISUBC(5), 
     X          ICMD(10),IPBUF(10),ITASK(3) 
C 
C 
      EQUIVALENCE (IBUF(1),IXBUF(17)),
     X            (REG,IA,IREG),(IB,IREG(2)), 
     X            (ITX32,IHDR(77)), 
     X            (ISUBC(1),IHDR(239)), 
     X            (LU2,IHDR(244)),
     X            (LSAVEN,IHDR(245))
C 
C 
      COMMON IXBUF,IHDR,ICMD
      DATA ITASK/2HTA,2HSK,2H? /
C 
C  GET S REGISTER, FIND OUT IF DVR05 OR DVR00 AND FIX EQT1
C 
      ISR=0 
      CALL BOOTC(ISR) 
      IF(ISR.EQ.-1) GO TO 40
      MTSC=IAND(ISR,7700B)/100B 
      IF(MTSC.NEQ.0) CALL FXTBL(8,MTSC) 
C 
      ITSC=IAND(ISR,77B)
      IF(ITSC.NEQ.0) CALL FXTBL(1,ITSC) 
C 
       CALL EXEC(2,1,36HDISK BACK UP UTILITY REV.2026 800502,-36) 
C 
C 
      CALL LISIO
      ITBG=IXGET(1674B) 
      CALL CNUMO(ITBG,IBUF) 
      CALL EXEC(2,1,18HSEL. CODE OF TBG=_,-18)
      CALL EXEC(2,1,IBUF,-6)
C 
C 
C GET S.C. FOR DVR32,DVA32
C 
20    CALL EXEC(2,1,34HENTER SELECT CODE FOR DVR32,DVA32:,-34)
C 
      CALL EXEC(1,401B,ICMD,-20)
      CALL ABREG(IA,IB) 
      IF(ICMD(1).EQ.2H/E.OR.ICMD.EQ.2HEN.OR.ICMD.EQ.2HEX) GO TO 40
      LEN=IB
      IPTR=1
      CALL ASCOC(ICMD,IPTR,LEN,ISC1)
      CALL ASCOC(ICMD,IPTR,LEN,ISC2)
      IF(ISC1.LT.77B.AND.ISC2.LT.77B) GO TO 30
C 
      CALL EXEC(2,1,17HERROR- S.C. GT 77,-17) 
      GO TO 20
C 
30    IF(ISC1.LE.-1.OR.ISC2.LE.-1) GO TO 999
C 
C LU 5 FOR 13037 DISCS
C LU 4 FOR HPIB  DISCS
C 
      IF(ISC1.NEQ.0) CALL FXTBL(5,ISC1) 
      IF(ISC2.NEQ.0) CALL FXTBL(4,ISC2) 
C 
C 
C 
40    MTLU=8
      ITTY=1
      ICMD(1)=2H
      ICMD(2)=2H
      ICMD(3)=2H
      CALL EXEC(2,ITTY,ITASK,-5)
      REG=EXEC(1,ITTY+400B,ICMD,-10)
      LEN=IB
      IF(ICMD(1).EQ.2HIO) CALL IOCON
      IF(ICMD(1).EQ.2HCO) CALL COPY 
      IF(ICMD(1).EQ.2HRE) GO TO 70
      IF(ICMD(1).EQ.2HRW) GO TO 100 
      IF(ICMD(1).EQ.2HAB) STOP
      IF(ICMD(1).EQ.2HFF.OR.ICMD(1).EQ.2HBF) GO TO 200
      IF(ICMD(1).NEQ.2HIO.AND.ICMD(1).NEQ.2HCO.AND.ICMD(1).NEQ.2HRE)
     X                                GO TO 50
      GO TO 40
50    CALL EXEC(2,ITTY,19HVALID COMMANDS ARE:,-19)
      CALL EXEC(2,ITTY,20HIO,CO,RE,RW,FF,BF,EN,-20) 
      GO TO 40
C 
70    CONTINUE
      CALL RESTR(IPBUF,LEN) 
      GO TO 40
C 
C 
C CHECK MT STATUS 
C 
100   CALL MTOK(MTLU,IER) 
      IF(IER.NEQ.0) GO TO 40
C 
C REWIND MT 
C 
105   CALL EXEC( 3,MTLU+400B) 
      GO TO 40
C 
C 
C FORWARD SPACE 
C 
200   CALL MTOK(MTLU,IER) 
      IF(IER.EQ.0) GO TO 250
      GO TO 40
C 
C 
250   IPTR=1
      IF(NAMR(IPBUF,ICMD,LEN,IPTR))40,252 
252   NFILE=1 
      IF(NAMR(IPBUF,ICMD,LEN,IPTR)) 255,251 
251   IF(IAND(IPBUF(4),3).EQ.1) NFILE=IPBUF 
255   CALL EXEC(2,ITTY,31HFORWARD/BACKWARD N FILE(S): N=_,-31)
      CALL CNUMD(NFILE,IHDR)
      CALL EXEC(2,ITTY,IHDR,-6) 
      DO 260 I=1,NFILE
      IF(ICMD(1).EQ.2HFF) CALL EXEC(3,MTLU+1300B) 
      IF(ICMD(1).EQ.2HBF) CALL EXEC(3,MTLU+1400B) 
C 
C GET STATUS
C 
      CALL ABREG(ISTAT1,IB) 
260   CONTINUE
C 
C 
D     WRITE(1,9999) ISTAT1
D9999 FORMAT("STAT=",@8)
C 
C IF COMMAND IS BF, CHECK IF BOT IS DETECTED
C IF NOT DO A BF AND FR TO PUT THE TAPE IN FRONT OF EOF 
C 
      IF(IAND(ISTAT1,100B).EQ.100B) GO TO 40
      IF(ICMD(1).EQ.2HFF) GO TO 40
C 
C BACKSPACE FILE, THEN FORWORD SPACE RECORD 
C 
      CALL EXEC(3,MTLU+1400B) 
C 
C IF BOT NO FR
C 
      CALL ABREG(ISTAT1,IB) 
D     WRITE(1,9999)ISTAT1 
      IF(IAND(ISTAT1,100B).EQ.100B) GO TO 40
      CALL EXEC(3,MTLU+300B)
      GO TO 40
C 
C 
999   CALL EXEC(2,1,17HINVALID SEL. CODE,-17) 
      GO TO 20
      END 
      END$
ASMB,R,L
      NAM DISKB,7 92067-18348 REV.2001 791018 
      EXT .ENTR,$LIBR,$LIBX 
      ENT BOOTC 
* 
* 
A     EQU 0 
B     EQU 1 
DRT   EQU 1652B 
* 
SREG  NOP 
BOOTC NOP 
      JSB .ENTR 
      DEF SREG
* 
      CCA           INIT SREG TO -1 
      STA SREG,I
      ISZ FLAG      IF FLAG IS NOT -1 
      JMP BOOTC,I   NOT FIRST TIME, RETURN
      JSB $LIBR 
      NOP 
      CLF 0         TURN INTERRUPT OFF
* 
      LDA DRT,I 
      CLB,INB       SET LU 1 TO EQT 1 
      IOR B 
      STA DRT,I 
* 
      LIA 1         GET S REGISTER
      SZA,RSS       IF ZERO 
      JMP OUT       GET OUT 
      AND .7777     MASK OUT TBG S.C. 
      STA SREG,I
      AND B77       MASK OUT CONSOLE S.C. 
      STA CONSO 
      LDA CN1 
      ADA CONSO 
      STA CN1 
      LDA CN2 
      ADA CONSO 
      STA CN2 
      LDA CN3 
      ADA CONSO 
      STA CN3 
      LDA CN4 
      ADA CONSO 
      STA CN4 
      LDA CN5 
      ADA CONSO 
      STA CN5 
      LDA MRSET 
CN1   CLF 0 
CN2   OTA 0 
CN3   SFS 0 
      JMP OUT 
DVR05 LDA DRT,I     GET DRT 
      AND .3700     MASK OUT EQT# OF LU 1 
      ADA D3        SET LU 1 TO EQT 3 
      STA DRT,I     RESET LU 1
      LDA 1650B     GET EQT ADDRESS 
      ADA D30       MAKE EQT3 ADDRESS 
      STA 1675B 
OUT   CLA 
      OTA 1 
      LDA C120K 
CN4   OTA 0,C 
CN5   STC 0,C 
      JSB $LIBX 
      DEF BOOTC 
* 
* 
D30   DEC 30
.7777 OCT 7777
FLAG  DEC -1
CONSO NOP 
B77   OCT 77
MRSET OCT 150077
.3700 OCT 3700
C120K OCT 120001
D3    OCT 3 
.1777 OCT 177700
LU    DEC 1 
*     NAME:   ASCOC 
*     SOURCE: 92060-18348 
*     RELOC:  92060-16348
*     PGMR:   S.P.K.
* 
*  ***************************************************************
*  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1976.  ALL RIGHTS     *
*  * RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED,      *
*  * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT*
*  * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.       *
*  ***************************************************************
* 
      ENT ASCOC     ROUTINE TO CONVERT ASCII TO DEC OR OCTAL
      EXT .ENTR 
* 
ICHAR NOP 
IPTR  NOP 
LEN   NOP 
NUMB  NOP 
* 
* 
ASCOC NOP 
      JSB .ENTR 
      DEF ICHAR 
* 
      LDA D7        GET RADIX 
      STA RADIX 
START CLA 
      STA VAL 
      LDA ICHAR 
      STA INAM
      CCA 
      STA NUMB,I    SET NUMB TO -1 FOR ERROR
LOOP  LDA IPTR,I    GET POINTER 
      CMA,INA       LEN > IPTR? 
      ADA LEN,I 
      SSA 
      JMP ASCOC,I   YES ERROR RETURN
      LDA IPTR,I
      CLB 
      CLE,ERA 
      SEZ 
      INB 
      SZB,RSS 
      ADA N1
      ADA INAM
      LDA A,I 
      STA CWORD 
      SZB 
      ALF,ALF 
      AND .377
      CPA SPACE 
      JMP IGNOR 
      CPA COMMA 
      JMP FINI
CNVRT ADA .N60      CONVERT 
      CMA,SSA,INA,RSS  NEGATIVE NUMBER? 
      JMP ERR       YES,ERROR 
      ADA RADIX 
      CMA,SSA,INA,RSS   INTEGER?
      JMP ERR       NO,ERROR
      ADA RADIX     BACK TO ORIGINAL NUMBER 
      LDB RADIX 
      CMB 
      CLO 
      ADA VAL       ADD EXISTING VALUE TO THE NEW INTEGER 10 TIMES
      ISZ B 
      JMP *-2 
      SOC           IF OVERFLOW, ERROR
      JMP ERR 
      STA VAL 
IGNOR ISZ IPTR,I
      LDA IPTR,I
      CMA,INA       LEN-IPTR
      ADA LEN,I     <0 ?
      SSA,RSS 
      JMP LOOP
      JMP DONE      LEN<IPTR
* 
* 
FINI  ISZ IPTR,I
DONE  LDB VAL 
      STB NUMB,I
      JMP ASCOC,I 
COMMA OCT 54
ERR   LDB N1
      STB NUMB,I
      JMP ASCOC,I 
* 
N1    DEC -1
.N60  OCT -60 
.1774 OCT 177400
.377  OCT 377 
D9    DEC 9 
D7    DEC 7 
VAL   BSS 1 
RADIX BSS 1 
IFLAG BSS 1 
CWORD BSS 1 
NWORD BSS 1 
IWORD BSS 1 
INAM  BSS 1 
SPACE OCT 00040 
      ENT IGET,IXGET
* 
* 
IXGET EQU * 
IGET  NOP 
      DLD IGET,I
      SWP 
      LDA 0,I 
      LDA 0,I 
      JMP 1,I 
      EXT .ENTR 
      ENT IPUT
* 
* 
ADDR  NOP 
DATA  NOP 
* 
* 
IPUT  NOP 
      JSB .ENTR 
      DEF ADDR
* 
      LDB ADDR,I    GET ADDRESS 
      LDA DATA,I    GET DATA
      STA 1,I       PUT DATA INTO ADDRESS 
      JMP IPUT,I
      END 
FTN4
       SUBROUTINE IOCON,92067-16348 REV.1940 790727 
      DIMENSION IREG(2),IBUF(10),IPBUF(10),LUTBL(4) 
C 
      EQUIVALENCE (REG,IA,IREG),(IB,IREG(2))
C 
      DATA LUTBL/1,4,5,8/ 
C 
C ASK FOR NEW CONFIGURATION 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C 
      CALL LISIO
C 
10    CALL EXEC(2,1,17HTO EXIT TYPE "/E",-17) 
      CALL EXEC(2,1,18HENTER LU,NEW S.C.?,-18)
      REG= EXEC(1,1+400B,IBUF,-20)
      LEN=IB
      IF(IBUF(1).EQ.2HEX.OR.IBUF(1).EQ.2H/E.OR.IBUF(1).EQ.2HEN) RETURN
      IPTR=1
      IF(NAMR(IPBUF,IBUF,LEN,IPTR)) 10,20 
20    IF(IAND(IPBUF(4),3).NEQ.1) GO TO 10 
      LU=IPBUF(1) 
C 
      CALL ASCOC(IBUF,IPTR,LEN,NEWSC) 
C 
      IF(NEWSC.LT.10B.OR.NEWSC.GE.77B) GO TO 88 
C 
C 
C 
40    IF(LU.GT.0.OR.LU.LE.77B) GO TO 50 
      CALL EXEC(2,1,12HINVALID LU  ,-12)
      GO TO 10
C 
C 
C 
50    IF(LU.EQ.1) GO TO 99
      DO 60 I=1,4 
      IF(LU.EQ.LUTBL(I)) GO TO 80 
60    CONTINUE
      CALL EXEC(2,1,14HLU NOT DEFINED,-14)
      RETURN
80    CALL FXTBL(LU,NEWSC)
      RETURN
C 
C 
88    CALL EXEC(2,1,12HINVALID S.C.,-12)
      GO TO 10
99    CALL EXEC(2,1,39HRECONFIGURE CONSOLE DURING BOOT UP ONLY,-39) 
      RETURN
      END 
      END$
FTN4
       SUBROUTINE LISIO,92067-16348 REV.1940 790706 
      DIMENSION LINE(70),ITEM1(1),ITEM2(1),ITEM3(1),ITEM4(1),ITEM5(1) 
     X         ,ITEM6(1),IDVTB(28)
C 
      EQUIVALENCE (ITEM1(1),LINE(1)), 
     X            (ITEM2(1),LINE(4)), 
     X            (ITEM3(1),LINE( 7)),
     X            (ITEM4(1),LINE(10)),
     X             (ITEM5(1),LINE(16)), 
     X             (ITEM6(1),LINE(22)), 
     X             (IDB,ITEM5(1)),
     X             (IPS,ITEM5(2)),
     X             (IT,ITEM5(3))
C 
C 
      DATA IDVTB/2HCO,2HNS,2HOL,2HE ,2H  ,2H  ,2H  ,
     X           2H13,2H03,2H7 ,2HDI,2HSC,2HS ,2H  ,
     X           2HI.,2HC.,2H D,2HIS,2HCS,2H  ,2H  ,
     X           2HMA,2HG ,2HTA,2HPE,2H  ,2H  ,2H  /
C 
C NOW DISPLAY CURRENT IO CONFIGURATION
C 
C 
      ITTY=1
C 
C 
      CALL EXEC(2,ITTY,55H     LU    EQT   S.C. S.CHNL
     X   DRIVER,-55)
      LUMAX=IXGET(1653B)
      IDRT=IXGET(1652B) 
      IEQTB=IXGET(1650B)
C 
      DO 505 I=1,LUMAX
C 
C 
      DO 444 K=1,70 
444   LINE(K)=2H
C 
C 
      IVAL=IXGET(IDRT)
      IF(IVAL.NE.0) GO TO 501 
      GO TO 505 
501   ISCC=IAND(IVAL,174000B) 
      ISC=IAND(ISCC,74000B)/4000B 
      IF(ISCC.LT.0) ISC=ISC+20B 
      IEQT=IAND(IVAL,77B) 
      IEQTA=(IEQT-1)*15+IEQTB 
C 
C 
      ISTAT=IXGET(IEQTA+3)
C 
C 
      ISCDE=IAND(IXGET(IEQTA+3),77B)
      IDVR=IAND(IXGET(IEQTA+4),37400B)/256
C 
      CALL CNUMO(IDVR,ITEM6)
      IF(IDVR.EQ.5) ITEM6(3)=2H05 
      ITEM6(1)=2H D 
      ITEM6(2)=2HVR 
      IF(IEQT.EQ.4) ITEM6(2)=2HVA 
      IF(IEQT.EQ.1.OR.IEQT.EQ.3) INDEX=1
      IF(IEQT.EQ.2) INDEX=8 
      IF(IEQT.EQ.4) INDEX=15
      IF(IEQT.EQ.5) INDEX=22
C 
C 
      J=26
      DO 550 K=1,14 
      LINE(J)=IDVTB(INDEX)
      INDEX=INDEX+1 
550   J=J+1 
C WRITE INFO
C 
      CALL CNUMD(I,ITEM1) 
      CALL CNUMD(IEQT,ITEM2)
      CALL CNUMO(ISCDE,ITEM3) 
      CALL CNUMD(ISC,ITEM4) 
      CALL EXEC(2,ITTY,LINE,-63)
C 
505    IDRT=IDRT+1
C 
      RETURN
      END 
      END$
FTN4
      SUBROUTINE FXTBL(LU,NEWSC)
C 
C 
C 
50    IEQT2=(IAND(77B,IGET(IGET(1652B)+LU-1))-1)*15 
     X       +IGET(1650B)+1 
C 
C SAVE OLD S.C. AND GET EQT4 VALUE
C 
      IOLDSC=IAND(IGET(IEQT2+2),77B)
C 
C 
C NOW SEARCH ALL EQTS FOR MATCHING NEWSC AND SET EQT4 S.C.
C    TO ZERO TO AVOID DUPLICATE EQT POINTING TO SAME S.C. 
C 
      MXEQT=IGET(1651B) 
      IEQT4=IGET(1650B)+3 
      DO 10 I=1,MXEQT 
      IF(IAND(IGET(IEQT4),77B).NEQ.NEWSC) GO TO 15
      IVEQ4=IAND(IGET(IEQT4),177700B) 
      CALL IPUT(IEQT4,IVEQ4)
15    IEQT4=IEQT4+15
10    CONTINUE
C 
C 
C 
      IVEQ4=IOR (NEWSC,IAND(IGET(IEQT2+2),177700B)) 
      CALL IPUT(IEQT2+2,IVEQ4)
C 
C GET DVR TYPE
C 
      IDVRTP=IAND(IGET(IEQT2+3),37400B)/256 
C 
C NOW FIX OLD SELECT IN INT TABLE 
C 
      CALL IPUT(IGET(1654B)+IOLDSC-6,0) 
C 
C IF DRIVER TYPE IS 23 FIX OLD S.C. 
C 
      IF(IDVRTP.EQ.23B) CALL IPUT(IGET(1654B)+IOLDSC-5,0) 
C 
C FIX NEW SEL CODE IN INT TABLE 
C 
      CALL IPUT(IGET(1654B)+NEWSC-6,IEQT2-1)
C 
C IF DRIVER TYPE IS 23 FIX NEW SELECT CODE
C 
       IF (IDVRTP.EQ.23B) CALL IPUT(IGET(1654B)+NEWSC-5,IEQT2-1)
       RETURN 
       END
       END$ 
FTN4
       SUBROUTINE RESTR(IPBUF,LEN),92067-16348 REV.2001 790802
C 
C NAME: RESTR- OFF LINE RESTR 
C PART #: 92067-18348 (SOURCE)
C PART# RELC: 92067-16348 
C CREATED BY: J.S.W.
C 
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: 
C     RE,[TM],[A/H] 
C 
C       WHERE:
C         TM- CHANGE TRACK MAP ENTRY DEFINITION FOR LSAVE TAPE
C             (NOT ALLOWED FOR USAVE TAPE 
C         A/H- A FOR RESTORING TO 13037 
C              H FOR RESTORING TO HPIB DISC USING SAME TMT IN TAPE
C 
C 
      DIMENSION IREG(2),IBUF(8193),ISTR(80), IPBUF(1),
     X          IHDR(247),ITME(15),ITX32(161),ITMT(5),ITEMP(5)
     X         ,IXBUF(8209),ISUBC(5),ICMD(1)
C 
C 
      EQUIVALENCE (REG,IA,IREG),(IB,IREG(2)), 
     X            (IBUF(1),IXBUF(16)),
     X            (ITME,IHDR(1)), 
     X            (ITMT(1),IHDR(239)),
     X            (LU2,IHDR(244)),
     X            (ISTR(1),IHDR(16)), 
     X            (ITX32,IHDR(77)), 
     X            (LSAVEN,IHDR(245)), 
     X            (LUSUB,IHDR(246)),
     X            (ITAPE,IHDR(247)) 
C 
      COMMON IXBUF,IHDR,ICMD
C 
C 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
C 
C  OFF-LINE RESTOR SUBROUTINE 
C 
C THIS SUBROUTINE IS CALLED BY THE MAIN PROGRAM DISK TO RESTORE 
C A TAPE SAVE ON-LINE.
C 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
C 
C 
      IUSAVE=0
      ISUBC(1)=-1 
      ITTY=1
      MTLU=8
C 
C 
C CHECK IF MT IS ON-LINE AND UP 
C 
      CALL MTOK(MTLU,IER) 
      IF(IER.NEQ.0)RETURN 
C 
C 
C  CHECK PARAMETERS, COMMAND FORMAT:
C 
C  RE,[OPTION[,MODEL]]
C 
C    WHERE OPTION=DE  FOR DEFAULT RESTORE 
C                =TM  CHANGE TMT
C          MODEL = A  RESTORE TO 13037
C                = H  RESTORE TO HPIB 
C 
C ISUBC CONTAINS INPUT SUBCHNNL DEFINITION (NEW)
C 
C READ MT HEADER WITH NO ABORT BIT SET
C IF ABORT THEN PARITY ERROR, RETURN
C THEN CHECK IF MT LU IS DOWN, IF YES ASK TO UP IT AND RESTART
C 
C 
10    CALL EXEC(1+100000B,MTLU,IHDR,247)
      GO TO 950 
11    CALL ABREG(IA,IB) 
      IF(IB.EQ.0) GO TO 900 
      CALL MTOK(MTLU,IER) 
      IF(IER.NEQ.0)RETURN 
C 
C PRINT HEADRAND TAPE # ON CONSOLE
C 
      CALL EXEC(2,ITTY,IHDR,-76)
      WRITE(1,13) ITAPE 
13    FORMAT("TAPE #",I3) 
C 
C FIND OUT IF USAVE OR NOT AND INIT POINTERS
C 
      IF(LSAVEN.GT.1) IUSAVE=1
      IPTR=1
      MODEL=2H
      IOPT=2H 
C 
C PARSE THE COMMAND BUFFER (ICMD) TO SEE IF [TM] OR 
C [A/H] OPTION EXISTS 
C 
C 
      IF(NAMR(IPBUF,ICMD,LEN,IPTR))15,15
15    IF(NAMR(IPBUF,ICMD,LEN,IPTR))50,16
16    IOPT=IPBUF(1) 
      IF(NAMR(IPBUF,ICMD,LEN,IPTR))25,20
20    MODEL=IPBUF(1)
25    IF(IOPT.NEQ.2HTM)  GO TO 50 
C 
C IF USAVE TAPE, NOT ALLOWED TO CHANGE TMT
C 
      IF(IOPT.EQ.2HTM.AND.IUSAVE.EQ.1) GO TO 28 
      GO TO 30
28    CALL EXEC(2,ITTY, 
     X 47HNOT ALLOWED TO CHANGE TRACK MAP TABLE FOR USAVE,-47)
      GO TO 50
C 
C [TM] OPTION IS ENTERED, ASK FOR SUBCHHANNEL DEFINITION
C AND CHECK IF SAME TRACK SIZE, THEN MOVE THE 5 WORD TO ITMT
C IF EXIT FROM PROMTS, IGNORE RESTORE AND RETURN
C IF [A/H] OPTION COEXIST WITH [TM], IGNORE [A/H] 
C 
30    CALL GTSUB(32HFOR DEST. SUBCHNNL (LSAVE TAPE):,-32,ISUBC) 
      IF(ISUBC(1).EQ.-1) RETURN 
      MODEL=2H
C 
C CHECK TRACK SIZES EQUAL 
C 
      IF(ISUBC(1).NEQ.ITMT(1)) GO TO 920
      DO 40 I=1,5 
40    ITMT(I)=ISUBC(I)
C 
C IF OPTION NOT = DE ,ASK IF HEADER IS OK 
C 
50    IF(IOPT .EQ.2HDE) GO TO 80
60    CALL EXEC(2,ITTY,3HOK?,-3)
      CALL  EXEC(1,ITTY+400B,ITEMP,-2)
      IF(ITEMP.EQ.2HYE) GO TO 80
      IF(ITEMP.EQ.2H/E.OR.ITEMP.EQ.2HEN.OR.ITEMP.EQ.2HEX) RETURN
      IF(ITEMP.NEQ.2HNO) GO TO 60 
C 
C IF THE ANSWER IS NO, CHECK MT OK AND FORWORD ON FILE
C THEN TRY AGAIN
C 
      CALL MTOK(MTLU,IER) 
      IF(IER.NEQ.0) RETURN
      CALL EXEC(3,MTLU+1300B) 
      GO TO 10
C 
C 
C  # OF LSAVES
C 
C 
80    LSUBN=LSAVEN
C 
C 
C 
C LU 5= 13037 DISCS 
C LU 4 =HPIB
C IF UPPER OF WORD 5 OF TMT NOT 0, IT IS AN HPIB DISC 
C 
C IF MODEL =A OVERRIDE TMT INFO AND RESTORE TO 13037
C          =H                       RESTORE TO HPIB 
C 
C 
      IDLU=4
      IF(IAND(ITMT(5),177400B).EQ.0) IDLU=5 
      IF(MODEL.EQ.2HA ) IDLU=5
      IF(MODEL.EQ.2HH ) IDLU=4
C 
      IUNIT=IAND(ITMT(3),7) 
      IF(IDLU.EQ.4) WRITE(ITTY,67) IUNIT
67    FORMAT("RESTORE TO I.C. DISC ADDR ",I1) 
      IF(IDLU.EQ.5) WRITE(ITTY,68) IUNIT
68    FORMAT("RESTORE TO 13037 DISC UNIT ",I1)
C 
C 
C NOW GO THRU ALL THE SUBCHANNELS (LSUBN) AND RESTORE THEM
C 
      DO 500 ISUB=1,LSUBN 
      IF(IUSAVE.EQ.1)WRITE(1,70) LUSUB
70    FORMAT(" RESTORING SUBCHNL #",I3) 
C 
90    ISIZE=ITMT(1)*64+1
      MXTRK=ITMT(4) 
C 
C DO A DUMMY WRITE TO TEST FORMAT SWITCH ETC AND THEN 
C CALL CLRSP TO CLEAR ALL SPARE TRACKS IN  POOL 
C 
      ISTRK=-1
      CALL MWRTK(IDLU,0,ITMT,IBUF,ISTRK)
      CALL CLRSP(IDLU,ITMT) 
C 
C INIT SPARE TRACK #
      ISTRK=MXTRK 
C 
C 
C READ TAPE, CHECK TO SEE IF MT IS DOWN (DUE TO PARITY ERROR ETC) 
C GET STATUS AND SEE IF EOT OR PARITY ERROR 
C IF EVERTHING OK, DISPLAY TRACK# TO SW. REG. 
C AND WRITE THE TRACK WITH SPARING
C 
C 
      DO 100 LTRK=0,MXTRK-1 
      CALL MTOK(MTLU,IER) 
      IF(IER.NEQ.0) RETURN
      CALL EXEC(1+100000B,MTLU,IBUF,ISIZE)
      GO TO 950 
111   CALL ABREG(IS1,IB)
      CALL MTOK(MTLU,IER) 
      IF(IER.NEQ.0) RETURN
C 
      IF(IAND(IS1, 40B).EQ.40B) CALL EOTAP(ITTY,MTLU,IHDR,IBUF,ISIZE) 
      IF(IAND(IS1,200B).EQ.200B) GO TO 850
      IF(IAND(IBUF(1),3777B).NEQ.LTRK) GO TO 800
      CALL ISSR(LTRK) 
      CALL MWRTK(IDLU,LTRK,ITMT,IBUF,ISTRK) 
100   CONTINUE
C 
C 
      CALL EXEC(1,MTLU,IHDR,247)
500   CONTINUE
C 
      CALL EXEC(2,ITTY,4HDONE,-4) 
      RETURN
C 
C 
C IF /E IS THE REPLY FOR "OK?", DO A BF AND FR TO GET 
C TO BEGINNING OF THIS FILE 
C IF START-OF-TAPE MARK IS DETECTED, RETURN 
C 
C 
700   CALL EXEC(3,MTLU+600B)
      CALL ABREG(IA,IB) 
      IF(IAND(IA,100B).EQ.100B) RETURN
      CALL EXEC(3,MTLU+1400B) 
      CALL EXEC(3,MTLU+300B)
      RETURN
800   CALL EXEC(2,ITTY,19HTAPE FORMAT ERROR  ,-19)
      RETURN
C 
C 
850   CALL EXEC(2,ITTY,16HTAPE EOF ILLEGAL,-16) 
      RETURN
900   CALL EXEC(2,ITTY,11HMT TIME OUT,-11)
      RETURN
920   CALL EXEC(2,ITTY,21HTRACK SIZES NOT EQUAL,-21)
      RETURN
950   CALL EXEC(2,ITTY,28HMT PARITY ERROR             ,-28) 
      RETURN
      END 
      END$
FTN4
      SUBROUTINE MWRTK(LU,LTRK,ISUBC,IBUF,STRAK),REV.2026 800502
      IMPLICIT INTEGER(A-Z) 
      DIMENSION ISUBC(1),IBUF(1),ITEMP(6),SBUF(144),IHDR(1),IXBUF(1)
      COMMON IXBUF,IHDR 
C 
C 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C 
C  OFF LINE WRITE TRACK SUBROUTINE
C      WITH SPARING IF NEEDED 
C 
C  CALLING PARAMETERS:
C    LU - DISC LU POINTER TO DVR32 OR DVA32 
C    LTRK - LOGICAL TRACK # FOR THIS SUBCHANNEL 
C    ISUBC - 5 WORD ARRAY CONTAIN TRACK MAP TABLE ENTRY FOR THIS SUBCHHAL 
C    IBUF  - TRACK BUFFER FOR WRITING ON DISC (8192 WORDS MAX)
C    STRAK - CURRRENT SPARE TRACK # (LOGICAL) FOR THIS SUBCHANNEL 
C 
C  COMMON PARATERS: 
C    IXBUF - IBUF PLUS 16 WORDS HEADER FOR DISC LIBRARY 
C    IHDR  - MAG TAPE HEADER RECORD: 237 WORDS
C 
C  THIS PROGRAM WRITES ONE TRACK ONTO THE DISC SETTING P BIT
C  ACCORDING TO THE SOURCE. SPARING IS DONE IF THE DESTINATION TRACK
C  IS MARKED DEFECTIVE OR DATA ERROR REPORTED AFTER VERIFY COMMAND
C  THE SUBROUTINE MAKES USE OF DISC LIBRARY SUBROUTINES EXCLUSIVELY.
C  (SEE ERS #2256-1138  FOR DISC LIBRARY) 
C 
C 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
      LOG=1 
      RETRY=0 
C 
C  CONVERT LOGICAL TO PHYSICAL TRK ADDRESS
C    CHECK STATUS AND LOOK AT STATUS 2, 
C    IF STATUS 2 < 0 (BIT 15 SET) DISC IS NOT READY 
C    IF NOT EQUAL TO 40 OCTAL FORMAT SWITCH OFF, TELL USER
C    IF  EQUAL TO 100 OCTAL PROCTECT SWITCH ON, TELL USER 
C    IF IER= 4 TIMED OUT BY DVA32 
C 
C 
       LSEC=0 
      CALL MXGTA(LU,IDVID,LTRK,LSEC,ICYL,IHD,ISEC,ISUBC)
      IUNIT=IAND(IDVID,77B) 
      MSK = 4 
100   CALL XFMSK(LU,IDVID,MSK,IER)
      CALL XSEEK(LU,IDVID,ICYL,IHD,ISEC,ISTAT1,ISTAT2,IER)
      IF(IER.EQ.4) GO TO 950
      IF(IER.EQ.2) GO TO 100
      IF((ISTAT2.LT.0).AND.(IAND(ISTAT2,4B).EQ.4)) GO TO 900
      IF(ISTAT2.LT.0) GO TO 950 
      IF(IAND(ISTAT2,40B).EQ.0) GO TO 910 
      IF(IAND(ISTAT2,100B).EQ.100B) GO TO 920 
C 
C SEE IF SPARE TRACK# IS -1 , IF YES NO ACTION YET
C 
      IF(STRAK.EQ.-1) RETURN
C 
C FILE MASK, SEEK, WRITE
C AFTER SEEK, LOOK AT STATUS 2. 
C IF < 0 NOT READY. IF D BIT SET DO SPARING (7910 ONLY) 
C THEN DO VERIFY TO SEE IF D BIT SET
C 
C 
      ISIZE=ISUBC(1)*64 
      NSECTS=ISUBC(1)/2 
C 
C IF BIT 14 IBUF(1) IS SET THE TRACK IS PROTECTED, SET PBIT TO 2
C 
      PBIT=0
      IF(IXBUF(16).LT.0) PBIT=2 
C 
D     WRITE(1,9999) IXBUF(16) 
D9999 FORMAT("IXBUF(16)=",@8) 
C 
C 
C FOR 7910 LOOK AT P BIT AFTER SEEK 
C 
      IF (IAND(ISTAT1,20000B).NEQ.0) GO TO 850
C 
C DO A READ FULL SECTOR TO SEE IF D BIT IS SET
C BY LOOKING AT THE 3RD WORD OF THE PREAMBLE (SBUF(19)) 
C IF YES, RE-SPARE THE TRACK
C IF NO IGNORE ALL OTHER BITS (S AND P) AND INITIALIZE THE TRACK
C 
      CALL XRDFS(LU,IDVID,SBUF,128,ISTAT1,ISTAT2,IER) 
      IF(IER.EQ.2) GO TO 100
      IF(IER.EQ.4) GO TO 950
C 
C 
      IF (IAND(SBUF(19),20000B).NEQ.0) GO TO 850
C 
C SEEK BACK TO TARGET TRACK (XRDFS  WILL MOVE THE HEAD) 
C AND INIT THE TRACK WITH P BIT SET APPROPRIATELY 
C 
C 
      CALL XSEEK(LU,IDVID,ICYL,IHD,ISEC,ISTAT1,ISTAT2,IER)
      IF (ISTAT2.LT.0) GO TO 900
      CALL XINIT(LU,IDVID,IXBUF,ISIZE,PBIT,ISTAT1,ISTAT2,IER) 
500   CALL XEND(LU,IDVID) 
      RETURN
C 
C************************************************************************ 
C 
C    ERROR HANDLING 
C 
C*************************************************************************
C 
C SEE IF ERROR IS CORRECTALBLE BY RETRY 
C 
800   IF(IS1.GT.16B.AND.IS1.LT.20B) GO TO 850 
      RETRY=RETRY+1 
      IF(RETRY.GE.10) GO TO 850 
      GO TO 100 
C 
C SEEK CHECK, DO RECALIBRATE AND RETRY UP TO 10 TIMES 
C 
900   CALL EXEC(2,1,10HSEEK CHECK,-10)
      RETRY=RETRY+1 
      IF(RETRY.GT.10) GO TO 950 
      CALL XRCAL(LU,IDVID,IER)
      GO TO 100 
C 
910   WRITE(1,911) IUNIT
911   FORMAT(" TURN FORMAT SWITCH ON FOR UNIT/ADDRESS:",I2, 
     X   /," TYPE 'GO' TO CONTINUE")
      CALL EXEC(1,401B,IXX,-2)
      IF(IXX.EQ.2HGO) GO TO 100 
      IF(IXX.EQ.2H/E.OR.IXX.EQ.2HEN.OR.IXX.EQ.2HEX) GO TO 8800
      GO TO 910 
C 
C 
920   WRITE(1,922) IUNIT
922   FORMAT(" TURN DISC PROTECT SWITCH OFF FOR UNIT/ADDRESS:"
     X  ,I2/," TYPE 'GO' TO CONTINUE")
      CALL EXEC(1,401B,IXX,-2)
      IF(IXX.EQ.2HGO) GO TO 100 
      IF(IXX.EQ.2H/E.OR.IXX.EQ.2HEN.OR.IXX.EQ.2HEX) GO TO 8800
      GO TO 920 
C 
950   WRITE(1,951) IUNIT
951   FORMAT("DISC UNIT/ADDRESS",I2," NOT READY") 
      CALL EXEC(2,1,37HREADY DISC AND ENTER "GO" TO CONTINUE,-37) 
      CALL EXEC(1,401B,IXX,-2)
      IF(IXX.EQ.2HGO) GO TO 100 
      IF(IXX.EQ.2H/E.OR.IXX.EQ.2HEN.OR.IXX.EQ.2HEX) GO TO 8800
      GO TO 950 
C 
C 
850   WRITE(1,880) LTRK,ICYL,IHD,IUNIT
880   FORMAT("DEST. SUBCHANNEL"/
     X  "BAD TRACK AT: TRACK #",I5," CYL ",I3," HEAD",I3, 
     X  " UNIT/ADDRESS ",I2)
C 
C 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C 
C 
C   SPARING 
C 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
C 
C 
C COMPUTE LAST AVAILABLE  SPARE TRACK # 
C                       = # OF TRACKS + # OF SPARES 
C 
C CHAECK IF CURRENT SPARE TRACK # = LAST SPARE TRACK #
C 
300   LSPARE=ISUBC(4)+IAND(ISUBC(5),377B) 
      IF(STRAK.GE.LSPARE) GO TO 7000
C 
C 1. SET FILE MASK TO 0 => AUTO SEEK TO SPARE 
C 2. SEEK TO SPARE TRACK
C 3. ADDRESS RECORD WITH SPARE TRACK ADDRESS
C 4. INIT SPARE WITH DATA BUFFER FROM  TAPE AND SETTING S, P BITS 
C      ACCORDINGLY
C 
      MSK=0 
      SECTR=0 
      CALL XFMSK(LU,IDVID,MSK,IER)
C 
      CALL MXGTA (LU,IDVID,STRAK,SECTR,SCYL,SHED,SECT2,ISUBC) 
      CALL XSEEK (LU,IDVID,SCYL,SHED,SECTR,S1,S2,IER) 
C