ASMB,R,L,C
*     NAME:   SAVE
*     SOURCE: 92067-18335 
*     RELOC:  92067-16335 
*     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.       *
*  ***************************************************************
* 
      NAM SAVE,3,99 92067-16335 REV.2013 790620 
* DISC TO MAG TAPE DATA TRANSFER
      EXT DMT,RMPAR,COR.A,EXEC,BUFER,ITASK
SAVE  JSB RMPAR     GET PARAMETERS
      DEF *+2 
      DEF IP
      CLA 
      STA ITASK     TASK=0 FOR SAVE 
      JSB BUFER     ROUTINE TO FIND FWA IN FREE MEM OF PARTITION
      DEF FWA       AND TO DETERMINE # OF WORDS IN AVMEM
      DEF PLEN
      DEF BFLEN     # OF WORDS IN AVMEM 
* 
      LDA FWA 
      INA 
      STA ITR       SET UP VERIABLE FOR TRACK # 
      INA 
      STA JB        ADDRESS FOR READ BUFFER 
      JSB DMT       GO TO MAIN DISC TO MAG TAPE ROUTINE 
      DEF *+8 
      DEF FWA,I     ADDR OF WRITE BUFFER - KB 
      DEF JB,I      ADDR OF READ BUFFER - JB
      DEF PLEN      LENGTH OF PPARTITION
      DEF BFLEN     # OF WORDS IN AVMEM 
      DEF IP        BUFFER WITH PARAMETERS
      DEF ITR,I     ADDR OF TRACK # - ITR 
      DEF FWA,I     ADDR OF SUBCHNL # - ISUB
      JSB EXEC      END OF SAVE PROGRAM 
      DEF *+2 
      DEF D6
* 
A     EQU 0 
B     EQU 1 
IP    BSS 5 
ITR   BSS 1 
JB    BSS 1 
FWA   BSS 1 
PLEN  BSS 1 
BFLEN BSS 1 
D6    DEC 6 
      END SAVE
FTN4,L,C
C     NAME:   DMT 
C     SOURCE: 92067-18335 
C     RELOC:  92067-16335 
C     PGMR:   S.P.K.,J.S.W. 
C 
C  ***************************************************************
C  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980.  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 
      SUBROUTINE DMT (KB,JB,IPLEN,IBLEN,IP,ITR,ISUB 
     X ),92067-16335 REV.2013 800103
      DIMENSION IP(5),KB(1),JB(1),ILUTR(64),MSG(3), 
     C          IHDR(140),INAME(3),IREG(2),ICHAR2(2),ITITL(4) 
      EXTERNAL MESG,MPFND,ASCDC,DCASC,SUB,CHDLU,TPPOS,
     C         CHUTP,LUTRK,PRNTH,MEMGT,READU
      EQUIVALENCE (REG,IA,IREG),(IREG(2),IB),(INAME,NAME1), 
     C            (INAME(2),NAME2),(INAME(3),NAME3),(IHDR(37),ITAPE), 
     C            (IHDR(39),ITPSV),(IHDR(40),LU2),(IHDR(42),IREC),
     C            (IHDR(43),ITB30)
      DATA ITITL/2HFI,2HLE,2H I,2HD?/,IHDR(41)/0/,
     C     ISIGN/100000B/,IVERFY/0/,IQUES/2H??/ 
      CALL EXEC (22,3)
      ITLU=IP 
      CALL MEMGT (1653B,LUMAX)
      IF(ITLU.GT.64) GO TO 920
      IF ((ITLU.LE.0).OR.(ITLU.GT.LUMAX)) GO TO 920 
      INT=IFTTY(ITLU) 
      IF(INT.EQ.0) GO TO 920
      LP=IP(2)
      IMLU=IP(4)
      IF(IMLU.GE.64) GO TO 580
      IDTYP=IP(5) 
C 
      IDISK=IDTYP 
C 
C 
      IF (IBLEN.LT.2050) GO TO 770
      IF (IPLEN.EQ.-1) CALL MESG (ITLU,27)
      IF (IBLEN.LT.6146) GO TO 5
C 
C 
C 
      IF(LP.NEQ.0) GO TO 2
      LU=IP(3)
      IDISK=7905
      IF(LU.NEQ.2.AND.LU.NEQ.3) REG=EXEC(1,LU,MXSEC,1,-1,0) 
      IF(LU.EQ.2) CALL MEMGT(1757B,MXSEC) 
      IF(LU.EQ.3) CALL MEMGT(1760B,MXSEC) 
      IF(MXSEC.EQ.128)IDISK=7925
C 
2     IF(IBLEN.LT.8194.AND.IDISK.EQ.7925) GO TO 5 
C 
C 
      IF (IPLEN.EQ.0) CALL MESG (ITLU,3)
      CALL MESG (ITLU,2)
      CALL READU (ITLU,IYES,1)
      IF (IYES.NEQ.2HYE) GO TO 5
      ISIZE=6144
      INCR=96 
      IF(IDISK.EQ.7925) ISIZE=8192
      IF(IDISK.EQ.7925) INCR=128
C 
C 
      IREC=1
      IF (IPLEN.EQ.1) GO TO 8 
      GO TO 9 
    5 ISIZE=2048
      INCR=32 
      IREC=0
      IF (IPLEN.EQ.-1) GO TO 9
    8 CALL MESG (ITLU,0)
      CALL READU (ITLU,IVERFY,1)
C     CHECK IF LOGICAL OR PHYSICAL COPY 
    9 IF (LP) 10,100,10 
C     CHECK IF PROPER UNIT # SPECIFIED FOR PHYSICAL COPY
   10 IUNIT=IP(3) 
      ITPSV=2 
      CALL CHUTP(ITLU,IUNIT,IDTYP)
      IDISK=IDTYP 
      IF(IDTYP.EQ.7925) IDTYP=7905
      IF(IDISK.EQ.7925.AND.ISIZE.EQ.6144) ISIZE=8192
      IF(IDISK.EQ.7925.AND.INCR.EQ.96) INCR=128 
      GO TO 110 
C     LOGICAL COPY TO BE DONE 
C     CHECK IF IDLU IS FOR DISC UNITS ONLY
  100 IDLU=IP(3)
      ITPSV=1 
      CALL CHDLU(ITLU,IDLU,ISUB,IDTYP)
      IF(IDLU.NEQ.2.AND.IDLU.NEQ.3) REG=EXEC(1,IDLU,MXSEC,1,-1,0) 
      IF(IDLU.EQ.2) CALL MEMGT(1757B,MXSEC) 
      IF(IDLU.EQ.3) CALL MEMGT(1760B,MXSEC) 
      IF(MXSEC.EQ.128.AND.ISIZE.EQ.6144) ISIZE=8192 
      IF(MXSEC.EQ.128.AND.INCR.EQ.96)    INCR=128 
      IF(MXSEC.EQ.128) IDISK=7925 
  110 NAME3=2H1 
      IF (IDTYP.EQ.7905) NAME3=2H2
      IF (IDTYP.EQ.7900) IDISK=7900 
D     WRITE(1,3333) IDTYP,IDISK 
D3333 FORMAT("TYP ",2I8)
      CALL MPFND(INAME,ITLU,IDTYP,ITB30,JB) 
      IHDR(38)=IDISK
      IF (IDTYP.EQ.7905) GO TO 140
      MPST=43 
      IF (ITB30.LT.0) MPST=44 
      GO TO 150 
  140 MPST=44 
      IF (IHDR(44).LT.0) MPST=45
C     CHECK IF IMLU IS FOR MAG TAPE UNIT ONLY 
  150 IF ((IMLU.LT.0).OR.(IMLU.GT.LUMAX)) GO TO 580 
      IF (IMLU.EQ.0) IMLU=8 
      IF (IMLU.GT.64) GO TO 580 
      CALL EXEC (13+100000B,IMLU,IEQT5) 
      GO TO 580 
151   IF (IAND(IEQT5,37000B)-11000B) 580,155,580
C     REQUEST A MAG TAPE LU LOCK W/OUT WAIT & NO-ABORT
  155 CALL LURQ (140001B,IMLU,1)
      GO TO 158 
 156  CONTINUE
 158  CALL ABREG(IA,IB) 
C 
C 
      IF (IA.EQ.0) GO TO 160
C     MT LU LOCK WAS NOT SUCCESSFUL, TELL USER
      CALL MESG (ITLU,25) 
C     REQUEST MT LU LOCK WITH WAIT
      CALL LURQ (1,IMLU,1)
C     WRITE RING IN THE MAG TAPE? 
  160 REG=EXEC(3,600B+IMLU) 
      IF (IAND(IA,4B).EQ.4B) GO TO 750
      CALL EXEC (2,ITLU,ITITL,4)
  165 DO 170 ITRY = 1,36
      IHDR(ITRY)=2H 
  170 CONTINUE
      REG = EXEC (1,ITLU+400B,IHDR,36)
      IF (IB.NEQ.0) GO TO 180 
      CALL EXEC (2,ITLU,IQUES,1)
      GO TO 165 
  180 IF (LP.EQ.0) GO TO 250
C 
C     BUILD LU-# OF TRACKS TABLE FOR SOURCE DISC USING TRACK MAP INFO 
C 
      LUFLG=1 
      CALL LUTRK(ITLU,LIMIT,IUNIT,IDTYP,IHDR,MPST,ILUTR,LUFLG,IEQT) 
      LU2=LUFLG 
      GO TO 300 
C     BUILD ILUTR TABLE FOR LP=0
  250 ILUTR=IDLU
      ILUTR(2)=IHDR(MPST+ISUB+8)
      IF (IDTYP.EQ.7905) ILUTR(2)=IHDR(MPST+ISUB*3+2) 
      LIMIT=1 
      LU2=0 
      IF (IDLU.EQ.2) LU2=1
C     POSITION TAPE TO DESIRED FILE # AND WRITE HEADER RECORD ON TAPE 
  300 IFILE=0 
      ITAPE=1 
      CALL TPPOS(ITLU,IMLU,IFILE,ITAPE) 
      CALL EXEC(2,IMLU,IHDR,140)
C 
      LFLAG=0 
      DO 320 ILU=1,LIMIT,2
      IDLU=ILUTR(ILU) 
      CALL EXEC(13+100000B,IDLU,IEQT5)
      GO TO 319 
317   GO TO 320 
319   IF(LFLAG.EQ.0) CALL EXEC(2,ITLU,
     X 45HPLEASE DEFINE FOLLOWING LU(S) IN THIS SESSION,-45)
C 
      LFLAG=1 
      CALL CNUMD(IDLU,MSG)
      CALL EXEC(2,ITLU,MSG,-6)
320   CONTINUE
      IF(LFLAG.EQ.1) STOP 66
C 
C     START DATA TRANSFER FROM DISC TO MAG TAPE USING ILUTR TABLE 
C 
      DO 410 ILU=1,LIMIT,2
      IDLU=ILUTR(ILU) 
      ILT=ILUTR(ILU+1)-1
C 
C 
      IF(IDLU.NEQ.2.AND.IDLU.NEQ.3) REG=EXEC(1,LU,MXSEC,1,-1,0) 
      IF(IDLU.EQ.2) CALL MEMGT(1757B,MXSEC) 
      IF(IDLU.EQ.3) CALL MEMGT(1760B,MXSEC) 
      MXSEC=MXSEC-1 
C 
      DO 400 ITR=0,ILT
      DO 390 ISEC=0,MXSEC,INCR
      CALL SUB (IDLU,ISUB)
         ITRY=1 
  335    CALL EXEC (1+100000B,IDLU,JB,ISIZE,ITR,ISEC) 
         GO TO 3339 
3336     CONTINUE 
         CALL ABREG(IA,IB)
  337 IF (IDTYP.EQ.7905) GO TO 340
      IF (IAND(IA,10B)-10B) 350,345,350 
  340 IF (IAND(IA,20B).NEQ.20B) GO TO 350 
  345 ISUB=ISUB+ISIGN 
  350 REG=EXEC(3,600B+IMLU) 
  353     IF (IAND(IA,40B).EQ.40B) GO TO 650
  354 ITRY=1
  355    REG= EXEC (2,IMLU,KB,ISIZE+2)
  390 CONTINUE
  400 CONTINUE
  410 CONTINUE
  450 ENDFILE IMLU
C 
C     VERIFY WANTED?
C 
      IF (IVERFY.NEQ.2HYE) GO TO 500
C     YES, PASS ILUTR TABLE TO SAM USING CLASS I/O CALL 
      CALL EXEC(20,0,ILUTR,64,IDUMY,JDUMY,ICLAS)
      NAME1=2HVE
      NAME2=2HRF
      NAME3=2HY 
C     POSITION MAG TAPE TO BEGINING OF FILE ON TAPE 1 
      IF (ITAPE.EQ.1) GO TO 470 
      JTAPE=ITAPE 
  460 CALL MESG (ITLU,24) 
      CALL MESG (ITLU,11) 
      REWIND IMLU 
      PAUSE 
      CALL TPPOS(ITLU,IMLU,IFILE,JTAPE) 
      CALL PRNTH(ITLU,IMLU,KB)
      IF (KB.EQ.-1) GO TO 460 
      GO TO 480 
  470 CALL TPPOS(ITLU,IMLU,IFILE,ITAPE) 
      CALL EXEC (1,IMLU,KB,140) 
C     UNLOCK MAG TAPE LU
  480 CALL LURQ (0,IMLU,1)
C     SCHEDULE VERFY PROGRAM WITH WAIT
C 
      IF(ISIZE.EQ.8192) IREC=2
      IF(MXSEC.EQ.127.AND.ISIZE.NEQ.8192) IREC=-1 
      CALL EXEC (23,INAME,ITLU,ICLAS,LIMIT,IMLU,IREC) 
  500 REWIND IMLU 
      STOP
  580 CALL MESG (ITLU,8)
      CALL READU (ITLU,ICHAR,1) 
      CALL ASCDC (ICHAR,1,IMLU) 
      GO TO 150 
  650 CALL MESG (ITLU,12) 
      CALL MESG (ITLU,11) 
      REWIND IMLU 
      CALL EXEC (7) 
      ITAPE=ITAPE+1 
677   CALL EXEC(3,600B+IMLU)
      CALL ABREG(IA,IB) 
D     WRITE(1,9999) IA
D9999 FORMAT("IA=",@8)
      IF(IAND(IA,4B).EQ.4B) GO TO 711 
      CALL EXEC (2,IMLU,IHDR,140) 
      GO TO 354 
C 
C 
711   CALL MESG(ITLU,10)
      CALL MESG(ITLU,11)
      CALL EXEC(7)
      GO TO 677 
  680 CALL MESG (ITLU,13) 
      CALL DCASC (ICHAR2,2,ITR) 
      CALL EXEC (2,ITLU,ICHAR2,2) 
      CALL DCASC(ICHAR,1,IDLU)
      CALL EXEC (2,ITLU,ICHAR,1)
  695 CALL MESG (ITLU,14) 
      STOP
  750 CALL MESG(ITLU,10)
      CALL MESG (ITLU,11) 
      CALL EXEC (7) 
      GO TO 160 
  770 CALL MESG (ITLU,1)
      GO TO 695 
920   CALL EXEC(2,1,18HILLEGAL CONSOLE LU,-18)
      STOP
3339  GO TO 3336
      END 
      END$
                                                                                                                                                                                                                                            