FTN4,Q,C
      PROGRAM USAVE(4,60),92067-16345 REV.2026 800501 
C 
C NAME:  USAVE
C 
C PART NO.: SOURCE- 92067-18345 
C PART NO.: RELOC.  92067-16345 
C 
C 
C   PROGRAMMER: J.S.W.,JRS
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 
C 
C  THIS PROGRAM IS USED TO SAVE A DISC UNIT ACCORDING TO THE TRACK
C  MAP TABLE DEFINITION.  THE RUN FORMAT IS:
C 
C  RU,USAVE[,<LOGLU>,<DISK LU>,<MT LU>,VE,<TITLE-LABEL> 
C     WHERE 
C       <LOGLU>- LOGGING DEVICE LU
C       <DISK-LU>- ANY DISC LU POINTING TO THE DISC UNIT
C       <MT LU> -  MAG TAPE LU
C       VE-  VERIFY 
C       <TITLE>-  40 CHARACTER LABEL INFO.
C 
C  THE PROGRAM FIRST GETS ALL THE RUN STRING PARAMETERS (XGTPM) AND 
C  THE TIME DATE AND DAY. IT THEN FINDS THE TRACK MAP TABLE FOR THE 
C  ENTIRE DISC AND ALSO THE TMT ENTRY FOR <DISC LU>. IT FINDS ALL 
C  THE SUBCHHANELS WITH IDENTICAL ADDRESS/UNIT # AND GO THRU EACH 
C  ONE. FOR EACH SUBCHHANNEL, USAVE COMPUTES LAST TRACK, TRACK SIZE 
C  AND CHECK IF THE SUBCHANNEL IS LU 2 OR 3 AND MARKS THE HEADER. 
C  USAVE THEN READS THE TRACK, WRITES IT ON TAPE AND CHECKS EOT FOR 
C  ALL TRACKS FORM 0 TO LAST TRACK
C 
C 
C 
C 
      DIMENSION IREG(2),IBUF(1),IXBUF(8208), IVBUF(128),VBUF(134),
     X ISTR(80),IHDR(247),ITME(15),ITX32(161),ISUBC(5),ITEMP(5),
     X IPBUF(10),MSG1(12),MSG2(11),IPARM(5) 
C 
      INTEGER SUBNO,VBUF
C 
C 
C 
      EQUIVALENCE (REG,IA,IREG),(IB,IREG(2)), 
     X            (ITME,IHDR(1)), 
     X            (ITX32,IHDR(77)), 
     X            (ISUBC(1),IHDR(239)), 
     X            (LU2,IHDR(244)),
     X            (ISTR(1),IHDR(16)), 
     X            (LSAVEN,IHDR(245)), 
     X            (IBUF(1),IXBUF(16)),
     X            (IVBUF(1),VBUF(17)),
     X            (LUSUB,IHDR(246)),
     X            (ITAPE,IHDR(247)) 
C 
      DATA MSG1/2HSA,2HVI,2HNG,2H S,2HUB,2HCH,2HNN,2HL  / 
      DATA MSG2/2H  ,2H  ,2H  ,2H  ,2HSU,2HBC,2HHN,2HLS,
     X  2H S,2HAV,2HED/ 
C 
C 
C GET PARAMETER 
C 
      CALL XGTPM(ISTR,1,LOG,IDLU,MTLU,IVRFY)
      CALL FTIME(ITME)
C 
C SET TAPE NO. EQUAL TO 1 
C AND SET UP INTERACTIVE DEVICE LU
C 
C CLEAR END-OF-TAPE FLAG
C CLEAR 10G RETURN
C INIT TAPE # TO 1
C INIT INTERACTIVE LU TO LOGLU
C 
C 
      IEOT=0
      IPARM(1)=2H 
      ITAPE=1 
      ITTY=LOGLU(ISES)
C 
C 
C     UNBUFFER THE MAGTAPE, PUT IT BACK WHEN DONE 
C 
      IFLAG = 0 
      CALL XMTBU(MTLU,IFLAG)
C 
C     CHECK FOR UNSUPPORTED DISCS 
C 
      CALL EXEC(13,IDLU,IEQT5)
      IF (IAND(IEQT5,37400B)-15000B) 985,1010,985 
1010   CONTINUE 
C 
C GO GET TRACK MAP TABLE
C 
      REG=EXEC(1,IDLU+2200B,ITX32, 161,0,5) 
      REG=EXEC(1,IDLU+2200B,ISUBC, 5,0,5) 
C 
C 
      IF(ITX32(1).GT.0) STOP 7
      LSUBCH=-ITX32(1)-1
      IF(IDLU.EQ.2.OR.IDLU.EQ.3) LU2=1
C 
C     LOCK THE PROGRAM IN MEMORY TO PREVENT DEADLOCKS 
C 
      CALL EXEC(22+100000B,1) 
      GO TO 30
   29 GO TO 40
   30 CALL EXEC(2,LOG,33H UNABLE TO LOCK PROGRAM IN MEMORY,-33) 
      CALL EXEC(2,LOG,32H   WARNING: DEADLOCKS MAY OCCUR!,-32)
   40 CONTINUE
C 
C 
C REQUEST MT LOCK 
C 
10    CALL LURQ(140001B,MTLU,1) 
       GO TO 15 
11    CONTINUE
15    CALL ABREG(IA,IB) 
      IF(IA.EQ.0) GO TO 25
      CALL EXEC(2,ITTY,22HMAG TAPE BUSY (LOCKED),-22) 
C 
C 
C 
C REQ. MT LOCK WITH WAIT
C 
      CALL LURQ(1,MTLU,1) 
C 
C CHECK WRITE RING
C 
25    REG=EXEC(3,600B+MTLU) 
      IF(IAND(IA,4B).EQ.4) GO TO 920
C 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C 
C COUNT NO. OF SUBCHANNELS TO BE SAVED
C GO THRU EACH SUBCHANNEL, IF DEVICE ADDRESS DOES NOT MATCH 
C    SKIP THE SUBCHANNEL, ELSE
C      WRITE MT HEADER, COMPUTE LAST TRACK,SECTOR PER TRACK 
C      TRACK SIZE AND SAVE ALL TRACKS FOR THIS SUBCH
C 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
C 
C 
      LSAVEN=0
      IUNIT=IAND(ISUBC(3),17B)
C 
      DO 5 I=0,LSUBCH 
      CALL EXEC(1,IDLU+2200B,ISUBC,5,0,5) 
      IF(IUNIT.EQ.IAND(ITX32(I*5+4),17B)) 
     X                      LSAVEN=LSAVEN+1 
5     CONTINUE
C 
      NLSAVE=LSAVEN 
C 
      DO 5000 SUBNO=0,LSUBCH
      CALL EXEC(1,IDLU+2200B,ISUBC,5,0,5) 
      IF(IUNIT.NEQ.IAND(ITX32(SUBNO*5+4),17B))
     X                          GO TO 5000
C 
C MOVE THE 5 WORD ENTRY TO ISUBC FOR READ TRACK 
C 
      DO 44 I=1,5 
      ISUBC(I)=ITX32(SUBNO*5+I+1) 
44    CONTINUE
C CHECK IF  LU 2 OR 3 INCLUDED IN THIS UNIT 
C BY MATCHING SUBCHANNEL ENTRY WITH CURRENT SYSTEM
C 
C 
      CALL EXEC(13,2,IEQT5) 
      IDTYP=IAND(IEQT5,37000B)/256
      IF(IDTYP.LT.32B.OR.IDTYP.GE.34B) GO TO 50 
      CALL EXEC(1,2202B,ITEMP,5,0,5)
      CALL COMPR(ISUBC,ITEMP,5,IER) 
      IF(IER.NEQ.0) LU2=1 
C 
50    CALL EXEC(13+100000B,3,IEQT5) 
      GO TO 55
52    IDTYP=IAND(IEQT5,37000B)/256
      IF (IDTYP.LT.32B.OR.IDTYP.GE.34B) GO TO 55
      CALL EXEC(1,2203B,ITEMP,5,0,5)
      CALL COMPR(ISUBC,ITEMP,5,IER) 
      IF(IER.NEQ.0) LU2=1 
C 
C SET SUBCHNNAL # AND WRITE MT HEADER 
C 
C 
55    LUSUB=SUBNO 
      CALL EXEC(2,MTLU,IHDR,247)
C 
C SET UP # OF SECTORS PER TRACK, NO. OF TRACKS AND TRACK SIZE 
      MXSEC=ISUBC(1)
      MXTRK=ISUBC(4)
      ISIZE=MXSEC*64+1
C 
C 
      CALL XDCAS(MSG1( 9),2,SUBNO)
      CALL EXEC(2,LOG+200B,MSG1,-20)
C 
C 
      DO 100 LTRK=0,MXTRK-1 
      IBUF(1)=LTRK
      CALL RDATK(IDLU,LTRK,0,ISIZE-1,ISUBC,IXBUF,IBT,LOG) 
      IF(IBT.EQ.1) IPARM=2H-1 
      REG=EXEC(2,MTLU,IBUF,ISIZE) 
      CALL ABREG(IS1,IB)
      IF(IB.EQ.0) GO TO 970 
      IF(IAND(IA,2).EQ.2) GO TO 980 
      IF(IAND(IS1,40B).EQ.40B) IEOT=1 
      IF(IAND(IS1,40B).EQ.40B) CALL WREOT(ITTY,MTLU,IHDR,IBUF,ISIZE)
100   CONTINUE
C 
      LSAVEN=LSAVEN-1 
5000  CONTINUE
      ENDFILE MTLU
C 
C 
      CALL CNUMD(NLSAVE,MSG2) 
      CALL EXEC(2,LOG+200B,MSG2,-22)
C 
C 
C 
C 
C 
      IF(IVRFY.EQ.0)     GO TO 777
C 
C 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C 
C VERIFY
C 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
C 
C 
C 
C CHECK EOF FLAG, IF SET ,ASK TO RE-MOUNT 
C TAPE #1 AND FILE #
C THE CHECK TAPE ON-LINE AND FORWARD SPACE TO FILE# 
C 
C 
      IF(IEOT.EQ.0) GO TO 199 
C 
177   CALL EXEC(2,ITTY,26HRE-MOUNT TAPE #1 FOR VERFY,-26) 
      CALL EXEC(2,ITTY,26HTHEN TYPE "GO" TO CONTINUE,-26) 
      CALL EXEC(1,ITTY+400B,I,-2) 
      IF(I.NEQ.2HGO) GO TO 177
C 
C CHECK MT ON-LINE
C 
      CALL EXEC(3,600B+MTLU)
      CALL ABREG(IA,IB) 
      IF(IAND(IA,1).EQ.0) GO TO 188 
      CALL EXEC(2,ITTY,17HMAG TAPE OFF-LINE,-17)
      GO TO 177 
C 
C 
C ASK FOR FILE#, PARSE IPUT AND CONVERT INTO BINARY 
C THEN FORWARD SPACE IF NEEDED
C 
188   CALL EXEC(2,ITTY,7HFILE #?,-7)
      CALL EXEC(1,ITTY+400B,ITEMP,-6) 
      CALL ABREG(IA,IB) 
      LEN=IB
      IPTR=1
      IF(NAMR(IPBUF,ITEMP,LEN,IPTR)) 188,190
190   IF(IAND(IPBUF(4),3).NEQ.1) GO TO 188
      NFILE=IPBUF(1)-1
      IF(NFILE.EQ.0) GO TO 250
C 
C NOW FORWARD SPACE TO THE DESIRED FILE 
C 
      DO 220 I=1,NFILE
      CALL EXEC(3,MTLU+1300B) 
220   CONTINUE
C 
C SKIP THE BACKSPACE FILE 
C 
      GO TO 250 
C 
C BACKSPACE 1 FILE
C 
C 
199   DO 200 I=1,247
200   IHDR(I)=2H
C  BACKSPACE 1 RECORD 
      CALL EXEC(3,MTLU+0200B) 
      CALL EXEC(3,MTLU+1400B) 
201   CALL EXEC(13,MTLU,IST)
      IF(IAND(IST,100000B).NEQ.0) GO TO 201 
      IF(IAND(IST,200B).NEQ.0)CALL EXEC(3,MTLU+300B)
C 
C 
C VERIFYING 
C 
250   CALL EXEC(2,ITTY,9HVERIFYING,-9)
C 
      IERROR=0
      DO 6000 SUBNO=1,NLSAVE
      CALL EXEC(1,MTLU,IHDR,247)
C PRINT HEADER
      IF(SUBNO.EQ.1)CALL EXEC(2,LOG+200B,IHDR,-75)  
      MXSEC=ISUBC(1)
      ISIZE=MXSEC*64+1
      MXSEC=MXSEC-1 
      MXTRK=ISUBC(4)
C 
C 
C NOW VERIFY ALL TRACKS 
C 
      DO 300 LTRK=0,MXTRK-1 
C READ 1 BLOCK,INIT ERROR FLAG
      IERFG=0 
      K=2 
      CALL EXEC(1,MTLU,IBUF,ISIZE)
      CALL ABREG(IA,IB) 
      IF(IAND(IA,40B).EQ.40B) CALL EOTAP(ITTY,MTLU,IHDR,IBUF,ISIZE) 
C 
C VERIFY 2 SECTRS 
C 
      DO 350 ISEC=0,MXSEC,4 
      CALL RDATK (IDLU,LTRK,ISEC,256,ISUBC,VBUF,IER,LOG)
      CALL COMPR(IBUF(K),IVBUF,256,IER) 
      IF(IER.NEQ.0) IERFG=1 
      K=K+256 
350   CONTINUE
C 
      IF(IERFLG.EQ.1) IERROR=1
      IF(IERFG.EQ.0) GO TO 300
      CALL CNUMD(LTRK,ITEMP)
      CALL EXEC(2,LOG,21HVERIFY DATA ERROR-TRK,-21) 
      CALL EXEC(2,LOG,ITEMP,-6) 
300   CONTINUE
C 
6000  CONTINUE
C 
      IF(IERROR.EQ.0) CALL EXEC(2,LOG,9HVERIFY OK,-9) 
      IF(IERROR.EQ.1) CALL EXEC(2,LOG,12HVERIFY ERROR,-12)
C FORWARD SPACE 1 RECORD
      CALL EXEC(3,MTLU+300B)
C 
777   CALL LURQ(0,MTLU,1) 
      CALL PRTN(IPARM)
C 
C     RETURN MAGTAPE TO ITS PREVIOUS STATE
C 
      CALL XMTBU(MTLU,IFLAG)
C 
C     UNLOCK PROGRAM
C 
      CALL EXEC(22+100000B,0) 
      GO TO 779 
  778 STOP 77 
  779 STOP 77 
920   CALL EXEC(2,LOG,18HWRITE RING MISSING,-18)
      GO TO 990 
970   CALL EXEC(2,LOG,14H MT XMIT ERROR,-14)
      GO TO 990 
980   CALL EXEC(2,LOG,16H MT PARITY ERROR,-16)
      GO TO 990 
985   CALL EXEC(2,LOG,17H UNSUPPORTED DISC,-17) 
990   CALL XMTBU(MTLU,IFLAG)
      STOP 66 
      END 
                                                                                                                      