ASMB,R,L,C
*     NAME:   DBKLB 
*     SOURCE: 92067-18339 
*     RELOC:  92067-16339
*     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 DBKLB,7 92067-16339 REV.2013 790309 
      ENT DBKLB 
DBKLB EQU * 
      END DBKLB 
ASMB,R,L,C
*     NAME:   BUFER 
*     SOURCE: 92067-18339 
*     RELOC:  92067-16339
*     PGMR:   S.P.K. J.S.W
* 
*  ***************************************************************
*  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979.  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 BUFER,7 92067-16339 REV.1903 790309 
      ENT BUFER     ROUTINE TO FIND HIGH ADDR OF MAIN AND DETERMINE 
      EXT COR.A     # OF WORDS IN PROGRAM'S PARTITION AND 
BUFER NOP           IN FREE AVAILABLE MEM IN PARTITION
      LDA 1717B     ADDRESS OF ID SEG OF MAIN PROG
      JSB COR.A     SYS ROUTINE TO GET FWA OF FREE MEM IN PARTITION 
      LDB BUFER,I 
      STA B,I       ADDRESS OF FWA RETURNED IN A REG
      STA FWAVM 
      LDA 1717B     ADDR OF IDSEG OF CURRENT MAIN PROG
      ADA D14       ADDR OF 15TH WORD OF ID SEG 
      LDA A,I       VALUE OF 15 TH WORD OF ID SEG 
      AND .17       FIND TYPE OF PROG IE.FG OR BG 
      CPA D3        BG DISC RESIDENT? 
      RSS 
      JMP FG        NO FOREGROUND DISC RESIDENT 
      LDA 1777B     YES, LWA MEM IN BG PARTITION
      STA LWA 
      LDB 1754B     FWA OF BG PARTITION 
      STB FWA 
      JMP BLEN      FIND LENGTH OF AVMEM
* 
FG    LDA 1751B     LWA+1 MEM IN FG PARTITION 
      ADA N1        LWA IN FG PARTITION 
      STA LWA 
      LDB 1750B     FWA OF FG PARTITION 
      STB FWA 
* 
BLEN  LDA NAME3     ADDRESS OF FIRST 2 CHARS OF NAME
      AND MASKU     MASK OFF LOWER CHAR 
      STA NAME3 
      LDA KEYWD     TOP OF KEYWORD LIST 
      STA KEY 
TN005 LDA KEY,I     CHECK IF END OF LIST
      CCE,SZA,RSS 
      JMP NOID      END OF INSTR LIST, NO ID SEGMENT
      ADA D12 
      LDB A,I       ID SEG ASCII NAME CHARS 1 & 2 
      CPB NAME1     COMPARE WITH CHAR 1 & 2 
      INA,RSS       COMPARES
      JMP TN030     DOES NOT COMPARE, GO TO NEXT ID SEG 
      LDB A,I       ID SEG ASCII NAME 3,4 
      CPB NAME2     COMPARE WITH REQUESTED CHARS 3,4
      INA,RSS       COMPARES
      JMP TN030     DOES NOT COMPARE-GO TO NEXT ID SEG
      LDA A,I       ID SEG ASCII NAME CHAR 5
      STA B 
      AND MASKU 
      CPA NAME3     COMPARE CHAR 5
      JMP TN040     COMPARES - SO ID SEG FOUND
* 
TN030 ISZ KEY       INCREMENT KEYWORD ADDRESS 
      JMP TN005     GO TO COMPARE CHARACTERS
TN040 LDB KEY,I     ADDRESS OF ID SEGMENT 
      LDA BPA1      RTE II OR III ? 
      CPA D2
      RSS           RTE III 
      JMP BLEN2     RTE II FIND BUFFER LENGTH 
      ADB D21       POINT TO WORD 22 OF ID SEGMENT
      LDA B,I       LOAD CONTENTS OF WORD 22
      AND .76K
      CLE 
      ELA,ALF       ROTATE # OF PAGES TO
      RAL           LOWER 6 BITS
     STA NAME1      SAVE IT 
      ADA N19       IS IT LESS THAN 15 PAGES? 
      SSA 
      JMP BFLN2     YES, THEN CANNOT DO VERIFY WITH 6K BUFFER 
      CLB,INB       NO, B REG = 1 - CAN VERIFY WITH 6K BUFFER 
      JMP BUFLN     SEND VALUE OF B REG BACK TO MAIN PROG 
BFLN2 LDA NAME1 
      ADA N6        IS IT LESS THAN 7 PAGES?
      SSA 
      CCB,RSS       YES, THEN CANNOT VERIFY AT ALL
      CLB           NO THEN CAN VERIFY WITH 2048 WORD BUF 
      JMP BUFLN 
NOID  CCB           B REG = -1 - ID SEG NOT FOUND 
      JMP BUFLN 
BLEN2 LDB FWA 
      CMB,INB       FIND PARTITION SIZE 
      ADB LWA 
      INB           LWA-FWA+1 
      ADB N1350     ADD -13500 - -VE OF PARTITION SIZE REQD.
      SSB           FOR VERIFY WITH 6144 WORD BUFFER
      CLB,RSS       CANNOT VERIFY WITH 6144 WORD BUFFER 
      CLB,INB       VERIFY WITH 6K BUFFER POSSIBLE
BUFLN ISZ BUFER 
      LDA BUFER,I   PASS BACK LENGTH OF PARTITION 
      STB A,I 
      LDA LWA       FIND LENGTH OF AVMEM IN PARTITION 
      LDB FWAVM 
      CMB,INB       B REG HAS FWA OF AVMEM
      ADB A 
      INB           LWA-FWAVM+1 
      ISZ BUFER 
      LDA BUFER,I 
      STB A,I       # OF WORDS IN FREE AVMEM IN PARTITION 
      ISZ BUFER 
      JMP BUFER,I   RETURN
* 
A     EQU 0 
B     EQU 1 
FWAVM BSS 1 
LWA   BSS 1 
FWA   BSS 1 
KEY   BSS 1 
MASKU OCT 177400
.76K  OCT 76000 
N1350 DEC -13500
N19   DEC -19 
D21   DEC 21
BPA1  EQU 1742B 
KEYWD EQU 1657B 
VERFY ASC 6,VERFY 
NAME1 EQU VERFY 
NAME2 EQU VERFY+1 
NAME3 EQU VERFY+2 
D2    DEC 2 
D3    DEC 3 
N6    DEC -6
D12   DEC 12
D14   DEC 14
N1    DEC -1
.17   OCT 17
      END 
FTN4,L
C     NAME:   CHDLU 
C     SOURCE: 92067-18339 
C     RELOC:  92067-16339 
C     PGMR:   S.P.K. J.S.W
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 
      SUBROUTINE CHDLU(ITLU,IDLU,ISUB,IDTYP 
     X ),92067-16339 REV.1903 790512
      DIMENSION ICHAR(2)
      EXTERNAL SUB,READU,MESG,ASCDC,DCASC,MEMGT 
      CALL MEMGT(1653B,LUMAX) 
   10 IF ((IDLU.LT.1).OR.(IDLU.GT.64)) GO TO 530
      CALL EXEC (13+100000B,IDLU,IEQT5) 
      GO TO 530 
C     EQUIPMENT TYPE 32?
55    IF (IAND(IEQT5,37400B)-15000B) 115,130,530
C     EQUIPMENT TYPE 31?
  115 IF (IAND(IEQT5,37400B)-14400B) 530,140,530
  130 IDTYP=7905
      GO TO 150 
  140 IDTYP=7900
  150 CALL SUB(IDLU,ISUB) 
      RETURN
  530 CALL MESG(ITLU,7) 
      CALL DCASC (ICHAR,1,IDLU) 
      CALL EXEC (2,ITLU,ICHAR,1)
540   ICHAR=2H
      CALL READU(ITLU,ICHAR,2)
      CALL ASCDC(ICHAR,1,IDLU)
      GO TO 10
      END 
      END$
FTN 
C     NAME:   CHUTP 
C     SOURCE: 92067-18339 
C     RELOC:  92067-16339 
C     PGMR:   S.P.K. J.S.W
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 
      SUBROUTINE CHUTP(ITLU,IUNIT,IDTYP),92067-16339 REV.1903 790309
      EXTERNAL MESG,ASCDC,READU,DCASC 
      DIMENSION ICHAR2(2) 
   10 IF ((IDTYP.EQ.7900).OR.(IDTYP.EQ.7901)) GO TO 50
      IF ((IDTYP.EQ.7905).OR.(IDTYP.EQ.7920).OR.(IDTYP.EQ.7906) 
     X .OR.(IDTYP.EQ.7925)) GO TO 60
11    CALL MESG(ITLU,15)
      CALL DCASC (ICHAR2,2,IDTYP) 
      CALL EXEC (2,ITLU,ICHAR2,2) 
      CALL READU(ITLU,ICHAR2,2) 
      CALL ASCDC (ICHAR2,2,IDTYP) 
      GO TO 10
   50 IDTYP=7900
      IF ((IUNIT.LT.0).OR.(IUNIT.GT.3)) GO TO 505 
      RETURN
60    IF(IDTYP.EQ.7925) GO TO 66
      IDTYP=7905
66    IF ((IUNIT.LT.0).OR.(IUNIT.GT.7)) GO TO 505 
      RETURN
  505 CALL MESG(ITLU,6) 
      CALL DCASC (ICHAR,1,IUNIT)
      CALL EXEC (2,ITLU,ICHAR,1)
      ICHAR=2H
      CALL READU(ITLU,ICHAR,1)
      CALL ASCDC(ICHAR,1,IUNIT) 
      GO TO 10
      END 
      END$
FTN4,L,C
C     NAME:   LUTRK 
C     SOURCE: 92067-18339 
C     RELOC:  92067-16339 
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 LUTRK(ITLU,LIMIT,IUNIT,IDTYP,ITB30,MPST,ILUTR,LUFLG, 
     C                 IEQT1),92067-16339 REV.2013 800103 
C     ROUTINE TO DECODE TRACK MAP TABLE AND BUILD TABLE FOR LU# AND 
C     # OF TRACKS FOR THE DISC UNIT SPECIFIED BY IUNIT
C 
C     FORMAT OF TABLE IS: WORD 1 - LU# OF SUBCHANNEL 1 ON DISC 1
C     WORD 2- # OF TRACKS FOR SUBCHANNEL 1 ON DISC 1, 
C     WORD 3- LU# OF SUBCHANNEL 2 ON DISC 1 ..............
C 
      EXTERNAL MESG 
      DIMENSION ITB30(1),ILUTR(1) 
      LUFLG=0 
      IF (IDTYP.EQ.7900) GO TO 20 
C     FIND FIRST SUBCHANNEL # ON 7905 DISC UNIT 
C 
      NSUB=-ITB30(MPST-1) 
      ISUB=-1 
   10 IF (ISUB.EQ.NSUB) GO TO 150 
      ISUB=ISUB+1 
C     ISOLATE UNIT NUMBER FOR EVERY SUBCHANNEL ON TRACK MAP TABLE 
C     UNTIL IT MATCHES IUNIT
C 
      IF (IAND(ITB30(MPST+ISUB*3+1),17B).NEQ.IUNIT) GO TO 10
      GO TO 30
C 
C     FIRST SUBCHANNEL # ON 7900 DISC UNIT
   20 ISUB=IUNIT*2
   30 IDLU=1
   40 IEQT=0
      IFLAG=0 
C     CALL ROUTINE TO GO THRU DEVICE REFERENCE TABLE AND FIND LU FOR
C     SUBCHANNEL
D     WRITE(1,5555) IUNIT,ISUB
D5555 FORMAT("UNIT,SUB",2I5)
      CALL DRT (ISUB,IDLU,IEQT) 
C     DRT RETURNS WITH LU=-1 IF SUBCHANNEL IS NOT ASSIGNED AN LU# 
      IF (IDLU.EQ.-1) GO TO 200 
C 
C     CHECK EQUIPMENT# IN STATUS WORD TO MAKE SURE LU RETURNED IS FOR 
C     THE RIGHT DISC UNIT TYPE
C 
      IAEQT5=(IAND(77B,IXGET(IXGET(1652B)+IDLU-1))-1)*15
     X      +IXGET(1650B)+4 
C 
      IEQT5=IXGET(IAEQT5) 
C 
      IF ((IAND(IEQT5,37400B).EQ.15000B).AND.(IDTYP.EQ.7905).AND. 
     C   (IFDVR(IDLU).EQ.0)) GO TO 50 
      IF ((IAND(IEQT5,37400B).EQ.14400B).AND.(IDTYP.EQ.7900)) 
     C      GO TO 50
C     THE EQUIPMENT TYPE IS NOT 31 OR 32, LU # NOT RIGHT, TRY AGAIN 
C 
      IDLU=IDLU+1 
      GO TO 40
C     FILL THE ILUTR TABLE WITH LU# AND # OF TRACKS 
   50 DO 90 ILU = 1,63,2
      ILUTR(ILU)=IDLU 
      IF (IDLU.EQ.2) LUFLG=1
C     GET # OF TRACKS 
      IF (IDTYP.EQ.7905) GO TO 60 
      ILUTR(ILU+1)=ITB30(MPST+ISUB+8) 
C     ALL SUBCHANNELS FOR 7900 DISC UNIT DONE?
      IF (ISUB.EQ.IUNIT*2+1) GO TO 100
      ISUB=ISUB+1 
      GO TO 80
   60 ILUTR(ILU+1)=ITB30(MPST+ISUB*3+2) 
   70 IF (ISUB.EQ.NSUB-1) GO TO 100 
      ISUB=ISUB+1 
      IF (IAND(ITB30(MPST+ISUB*3+1),17B).NEQ.IUNIT) GO TO 70
   80 IDLU=1
      IFLAG=-1
C     FIND LU# FOR GIVEN SUBCHANNEL AND EQT#
      CALL DRT(ISUB,IDLU,IEQT)
      IF (IDLU.EQ.-1) GO TO 200 
   90 CONTINUE
C 
C     END OF LIST OF LU #'S TO BE MARKED WITH -1
  100 LIMIT=ILU 
      IEQT1=IEQT
      RETURN
C     "IMPROPER TRACK MAP INFO. " 
  150 CALL MESG (ITLU,28) 
      CALL MESG (ITLU,14) 
      STOP
C     ERROR MESSAGE PRINTED - LU # NOT ASSIGNED TO FOLL. SUBCHNL
  200 CALL MESG(ITLU,9) 
      ICHAR=2H
      CALL DCASC(ICHAR,1,ISUB)
      CALL EXEC (2,ITLU,ICHAR,1)
C     ASSIGN LU# TO SUBCHANNEL AND RSTART UTILITY USIG RTE GO CMND
      CALL MESG (ITLU,11) 
      PAUSE 
      IF (IFLAG) 80,40
      END 
      END$
ASMB,R      
*     NAME:   MATCH 
*     SOURCE: 92067-18339 
*     RELOC:  92067-16339
*     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 MATCH,7 92067-16339 REV.1903 790309 
      ENT MATCH     ROUTINE TO MATCH TRACK MAP INFO FOR 2 DISC UNITS
      EXT MESG,EXEC,RMOVI,DRT,DCASC,EXEC
MATCH NOP 
      LDA MATCH,I 
      STA RETRN     SAVE RETURN ADDRESS 
      CLA 
      STA IWORD     FETCH VALUES OF FIRST 8 ARGUMENTS 
      LDB N7
      STB ITEMP     ITEMP IS COUNTER
LOOP  ISZ MATCH     LOAD THEM IN BUF
      LDA MATCH,I   ADDRESS OF ARGUMENT IN A REG
      LDA A,I       VALUE IN A REG
      LDB ABUF      LOAD ADDRESS OF BUFFER
      ADB IWORD     DISPLACEMENT
      STA B,I 
      ISZ IWORD 
      ISZ ITEMP 
      JMP LOOP
      LDB N3
      STB ITEMP     ITEMP IS COUNTER
LOOP0 ISZ MATCH     FETCH THE ADDRESSES OF 2 TRACK MAP TABLES 
      LDA MATCH,I 
      JSB RMOVI 
      LDB ABUF      ADDRESS OF BUFFER FOR PARAMETERS
      ADB IWORD     INDEX INTO IT 
      STA B,I       STORE TABLE ADDRESS IN BUFFER 
      ISZ IWORD 
      ISZ ITEMP 
      JMP LOOP0 
      LDA MPST1     ADJUST MAP START ADDRESS FOR ASSEMBLY 
      ADA N1
      STA MPST1 
      LDA MPST2 
      ADA N1
      STA MPST2 
      LDA IDTYP     CHECK DISC TYPE - 7900,7905 
      CPA D7905     7905 DISC?
      JMP M7905     YES,JUMP
      JSB M7900     NO,MATCH INFO, FOR 7900 DISC UNITS
      DEF D0        MATCH FIRST SUBCHNL STARTING TRACK #
      JSB M7900 
      DEF D1        MATCH SECOND SUBCHNL(REMOVABLE) STARTING TRACK #
      JSB M7900 
      DEF D8        MATCH FIRST SUBCHNL # OF TRACKS 
      JSB M7900 
      DEF D9        MATCH SECOND SUBCHNL # OF TRACKS
      JMP RETRN,I   TM INFO FOR BOTH 7900 UNITS MATCHES, RETURN 
M7905 LDA MPST1     DETERMINE NUMBER OF SUBCHNLS IN TRACK MAP TABLE 
      ADA N1
      ADA MAP1
      LDA A,I 
      CMA,INA       NUMBER IS -VE SO MAKE IT +VE
      STA NSUB1 
      LDA MPST2     FIND # OF SUBCHANNELS IN MAP2 
      ADA N1
      ADA MAP2
      LDA A,I 
      CMA,INA       MAKE IT +VE 
      STA NSUB2     # OF SUBCHANNELS IN MAP2
      CLA 
      STA ISUB1     SUBCHNL #'S FOR SOURCE DISC 
LOOP1 LDB MAP1      MAP ADDRESS OF SOUCE UNIT 
      JSB CMPR      IS ISUB1 ON IUNIT1? 
      DEF MPST1     MAP START ADDR OF MAP1
      DEF IUNT1     UNIT# OF SOURCE UNIT
      SZA           A REG = 0 IF ISUB1 ON UNIT1 
      JMP ENDL3     NO,TRY NEXT SUBCHNL 
      STB ITMP1     ADDR OF TRACK MAP INFO FOR ISUB1
      STA ISUB2     YES, ISUB2 IS SUBCHNL FOR DEST DISC IUNIT2
LOOP2 LDB MAP2      MAP ADDRESS OF DEST DISC UNIT 
      JSB CMPR      ISUB2 ON IUNIT2?
      DEF MPST2     MAP START ADDR OF MAP2
      DEF IUNT2     UNIT# OF SOURCE UNIT
      SZA           A REG =0 SAYS ISUB2 IS ON IUNIT2
      JMP ENDL2     NO, TRY NEXT SUBCHNL
* TRACK MAP INFO FOR BOTH SUBCHANNELS MATCHES?
      STB ITMP2     ADDR OF TRACK MAP INFO FOR ISUB2
      LDA ITMP1     BOTH SBCHNLS ARE ON DESIRED UNIT#'S 
      LDA A,I       START COMPARING - AREG HAS FIRST WORD 
      LDB ITMP2     FIRST WORD FOR SUBCHNL ON 2ND DISC UNIT 
      LDB B,I 
      CPA B         COMPARE 
      RSS 
      JMP ENDL2     DOES NOT MATCH - TRY WITH NEXT SUBCHNL
      LDA ITMP1     MATCH SECOND WORD FOR BOTH SUBCHANNELS
      INA 
      LDA A,I       BRING CONTENTS OF 2ND WORD
      AND .7776     MASK OUT THE UNIT# FROM WORD 2 OF SBCHNL ON UNIT1 
      STA ITEMP 
      LDA ITMP2     POINTER TO BEG OF SUBCHNL INFO ON MAP 2 
      INA 
      LDA A,I       CONTENS OF WORD 2 
      AND .7776     MASK OUT UNIT# FROM WORD 2 OF SBCHNL ON UNIT2 
      CPA ITEMP     COMPARE WORD INFO 
      RSS 
      JMP ENDL2     DO NOT MATCH - TRY WITH NEXT SUBCHNL
      LDA ITMP1     YES,COMPARE WORD 3
      ADA D2
      LDA A,I 
      LDB ITMP2     FETCH CONTENTS OF WORD3 OF SUBCHNL ON UNIT2 
      ADB D2
      LDB B,I 
      CPA B 
      JMP ENDL1 
ENDL2 ISZ ISUB2     NO MATCH - TRY WITH NEXT SUBCHNL
      LDA ISUB2     INCREMENT AND TRY AGAIN 
      CPA NSUB2     ALL SUBCHANNELS LOOKED AT?
      JMP ERROR     YES - NO MATCH IN ENTIRE TMT - ERROR
      JMP LOOP2     NO - TRY AGAIN
ENDL1 LDA ILUTR     LU#-#TRACKS TABLE ADDR
      ADA ILU       POINT TO NEXT ENTRY POINT IN IT 
      INA           # OF TRACKS ENTRY FOR ISUB2 
      STB A,I 
MTCH2 CLA 
      STA ITEMP 
      JSB DRT       FIND LU# OF ISUB2 
      DEF *+4 
      DEF ISUB2 
      DEF ITEMP     LU# 
      DEF IEQT      EQT # 
      LDB ITEMP     WAS SUBCHNL ENTRY MADE IN DRT?
      SSB,RSS 
      JMP MTCH1     YES 
      JSB MESG      NO, LU# NOT ASSIGNED TO SUBCHNL 
      DEF *+3 
      DEF ITLU
      DEF D9        ASSIGN LU# TO FOLL SUBCHNL
      JSB DCASC     CONVERT SUBCHNL# TO ASCII 
      DEF *+4 
      DEF ITEMP 
      DEF D1
      DEF ISUB
      JSB EXEC      DISPLAY SUBCHANNEL #
      DEF *+5 
      DEF D2
      DEF ITLU
      DEF ITEMP 
      DEF D1
      JSB MESG
      DEF *+3 
      DEF ITLU
      DEF D11       RESTART MESSAGE 
      JSB EXEC
      DEF *+2 
      DEF D7        PAUSE 
      JMP MTCH2     CONTINUE
* 
MTCH1 LDA ILUTR     ADDRESS OF LU-#TRACKS TABLE 
      ADA ILU       INDEX INTO TABLE
      STB A,I       LU# ENTRY MADE IN TABLE 
      LDA ILU       INCREMENT ILU INDEX BY 2
      ADA D2
      STA ILU 
ENDL3 ISZ ISUB1     MATCH FOUND - NOW TRY WITH NEXT SUBCHNL 
      LDA ISUB1     ON IUNIT1 
      CPA NSUB1     ALL SUBCHANNELS HAVE BEEN MATCHED?
      JMP RETRN,I   YES-RETURN
      JMP LOOP1     NO - FIND NEXT ONE
* 
*ERROR - SYSTEM LU TO BE RESTORED,SOURCE AND DEST TRCK MAP INFO 
*        DOES NOT MATCH 
* 
ERROR JSB MESG
      DEF *+3 
      DEF ITLU
      DEF D16 
      JSB MESG
      DEF *+3 
      DEF ITLU
      DEF D14 
      JSB EXEC
      DEF *+2 
      DEF D6
* 
*SUBROUTINE TO COMPARE 1 WORD OF TRACK MAP INFO. FOR 7900 DISC UNITS
* 
*CALLING SEQUENCE:
*JSB M7900
*DEF DN     DN IS THE DISPLACEMENT WITHIN TMT 
* 
M7900 NOP 
      LDB M7900,I GET PARAMETER ADDRESS 
      LDB B,I       VALUE OF ARGUMENT 
      STB ITEMP 
      LDA IUNT1 
      ADA A 
      ADA MPST1     POINTER TO BEG. OF INFO. FOR UNIT1 IN MAP 1 
      ADA MAP1
      ADA ITEMP     POINTER TO REQUIRED WORD IN MAP 1 
      LDA A,I       FETCH CONTENTS OF WORD
* 
      LDB IUNT2     REPEAT PROCEDURE FOR WORD IN MAP 2
      ADB B 
      ADB MPST2 
      ADB MAP2
      ADB ITEMP 
      LDB B,I 
      CPA B         COMPARE INFO
      RSS 
      JMP ERROR     NO MATCH - ERROR
      ISZ M7900     MATCH, GET RETURN ADDRESS 
      JMP M7900,I   RETURN
* 
*SUBROUTINE TO COMPARE UNIT# FOR GIVEN SBCHNL AND GIVEN DISC UNIT#
* 
*CALLING SEQUENCE:
*JSB CMPR 
*DEF MPST           MAP START ADDR
*DEF UNIT#
* A REG=ISUB    SUBCHNL # WHOSE UNIT # HAS TO BE COMPARED 
* B REG = MAP ADDRESS 
* RETURNS: A REG = 0 IF SUBCHNL IS ON UNIT
*                  1 OTHERWISE
*          B REG = IF A REG = 0 THEN ADDR OF TRACK MAP INFO FOR SUB 
* 
CMPR  NOP 
      STA ISUB
      ALS           INDEX TO THE BEG OF SUBCHANNEL ENTRY
      ADA ISUB      ISUB*3
      ADA B         ADDRESS OF MAP
      LDB CMPR,I    GET MAP START ADDR
      LDB B,I 
      ADA B 
      STA ITEMP 
      INA 
      LDA A,I       BRING CONTENTS OF 2ND WORD FOR SBCHNL 
      AND .17       ISOLATE UNIT #
      ISZ CMPR
      LDB CMPR,I
      LDB B,I       BRING UNIT #
      CPA B         COMPARE UNIT #'S
      JMP EQUAL     MATCH,JUMP
      LDA D1        DO NOT MATCH RETURN WITH 1 IN A REG 
      JMP RCMPR 
EQUAL CLA           RETURN WITH 0 IN A REG
      LDB ITEMP     ADDR OF TRACK MAP INFO FOR SUB
RCMPR ISZ CMPR      RETURN ADDRESS
      JMP CMPR,I    RETURN
* 
* 
A     EQU 0 
B     EQU 1 
ABUF  DEF BUF 
BUF   BSS 10
ITLU  EQU BUF 
IDTYP EQU BUF+1     DISC TYPE 
IEQT  EQU BUF+2     EQT # OF DISC 
IUNT1 EQU BUF+3     UNIT # 1
IUNT2 EQU BUF+4     UNIT # 2
MPST1 EQU BUF+5     STARTING WORD # ON MAP 1
MPST2 EQU BUF+6     STARTING WORD # ON MAP 2
MAP1  EQU BUF+7     ADDR OF TRACK MAP TABLE OF SOURCE DISC
MAP2  EQU BUF+8     ADDR OF TRACK MAP TABLE OF DEST DISC
ILUTR EQU BUF+9     ADDR OF LU#-# OF TRACKS TABLE 
IWORD BSS 1 
ILU   DEC 0 
RETRN BSS 1 
ITEMP BSS 1 
ITMP1 BSS 1 
ITMP2 BSS 1 
ISUB1 BSS 1 
ISUB2 BSS 1 
ISUB  BSS 1 
NSUB1 BSS 1 
NSUB2 BSS 1 
D0    DEC 0 
D1    DEC 1 
D2    DEC 2 
D6    DEC 6 
D7    DEC 7 
D8    DEC 8 
D9    DEC 9 
D11   DEC 11
D14   DEC 14
D16   DEC 16
D96   DEC 96
D7905 DEC 7905
N1    DEC -1
N3    DEC -3
N7    DEC -7
.17   OCT 17
.7776 OCT 77760 
      END 
FTN4
C     NAME:   MPFND 
C     SOURCE: 92067-18339 
C     RELOC:  92067-16339 
C     PGMR:   S.P.K. J.S.W. 
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 
      SUBROUTINE MPFND(MPNAM,ITLU,IDTYP,ITMT,JB 
     X ),92067-16339 REV.1903 790512
C     FIND TRACK MAP TABLE BY LOOKING AT LIST OF ENTRY POINTS 
      EXTERNAL DSCAD,MESG,MEMGT 
      DIMENSION MPNAM(3),JB(1),ITMT(1)
      DATA ISIZE/2048/
      MPNAM=2H$T
      MPNAM(2)=2HB3 
C     LOC 1762B HAS THE NO. OF ENTRY POINTS IN LIST 
C     EACH ENTRY POINT IS FOUR WORDS LONG 
C     IDSCLN IS NO. OF WORDS TAKEN UP BY THE ENTRY POINT LIST 
  140 CALL MEMGT(1762B,IDSCLN)
      IDSCLN=IDSCLN*4 
C     1761B IS THE DISC ADRESS OF FW OF ENTRY POINT LIST
      CALL MEMGT(1761B,IPARM) 
C     CONVERT DISC ADDRESS TO TRACK #, SECTOR # AND LU #
      CALL DSCAD (IPARM,ILU,ITRCK,ISECTR) 
C 
C 
      MXSEC=96
      IF(ILU.EQ.2) CALL MEMGT(1757B,MXSEC)
      IF(ILU.EQ.3) CALL MEMGT(1760B,MXSEC)
C 
C 
      ITEMP=MXSEC-ISECTR
      IF (ITEMP.GE.32) GO TO 145
      JBUFL=ITEMP*64
      GO TO 150 
C     MAX BUFFER LENGTH 
  145 JBUFL=ISIZE 
  150 IF (IDSCLN.LT.JBUFL) JBUFL=IDSCLN 
C     READ JBUFL WORDS FROM ENTRY POINT LIST
      CALL EXEC (1,ILU,JB,JBUFL,ITRCK,ISECTR) 
C     EACH ENTRY POINT HAS 4 WORDS - FIRST 5 CHARACTERS ASSIGNED TO 
C     ENTRY POINT NAME, IF LOWER BYTE OF WORD 3 IS 1 THEN ROUTINE IS
C     ON DISC AND WORD 4 CONTAINS THE DISC ADDRESS OF ROUTINE - IF
C     LOWER BYTE OF WORD 3 IS NOT 1 THEN ROUTINE IS IN MEMORY AND 
C     WORD 4 IS MEMORY ADDRESS OF ROUTINE 
C 
C     GO THROUGH LIST TO FIND MATCHING ENTRY POINT NAME 
      DO 147 IWORD=1,JBUFL,4
         IF (JB(IWORD).NEQ.MPNAM) GO TO 147 
      IF (JB(IWORD+1).NEQ.MPNAM(2)) GO TO 147 
      IF ((IAND(JB(IWORD+2),177400B)+40B).EQ.MPNAM(3)) GO TO 230
  147 CONTINUE
      IDSCLN=IDSCLN-JBUFL 
C     IF NO MORE WORDS LEFT IN LIST THEN ERROR, ELSE TRY WITH NEXT BUF
      IF (IDSCLN) 700,700,200 
  200 ISECTR=ISECTR+32
C     SET UP SECTOR & TRACK ADDRESS TO READ NEXT SET OF DATA FROM DISC
      ITEMP=MXSEC-ISECTR
      IF (ITEMP.GE.32) GO TO 145
      IF (ITEMP.LE.0) GO TO 210 
      JBUFL=ITEMP*64
      GO TO 150 
  210 ISECTR=0
      ITRCK=ITRCK+1 
      GO TO 145 
C     IF LOWER BYTE OF WORD 3 IS 1 THEN DISC ADDRESS
  230 IF (IAND(JB(IWORD+2),377B).EQ.1) GO TO 250
C     GET MEMORY ADDRESS OF ROUTINE 
      MPADR=JB(IWORD+3) 
      IF (IDTYP.EQ.7905) GO TO 232
C 
C 
C 
      M=17
C     MOVE M WORDS OF TRACK MAP INTO BUFFER 
  237 DO 240 IWORD=1,M
         CALL MEMGT(MPADR+IWORD-1,ITMT(IWORD))
  240 CONTINUE
      RETURN
C     CONVERT DISC ADRESS INTO TRACK#,SECTOR# AND LU# 
  250 CALL DSCAD(JB(IWORD+3),ILU,ITRCK,ISECTR)
      M=17
      IF (IDTYP.EQ.7905) GO TO 400
C     READ M WORDS OF TRACK MAP FROM DISC 
      CALL EXEC (1,ILU,ITMT,M,ITRCK,ISECTR) 
      RETURN
C     ERROR - ROUTINE NAME CANNOT BE FOUND IN ENTRY POINT LIST
  700 CALL MESG (ITLU,4)
      CALL EXEC (2,ITLU,MPNAM,3)
      CALL MESG (ITLU,14) 
      STOP
C 
C 
C 
C 
C 
C 
400   CALL EXEC(1,ILU,JB,161,ITRCK,ISECTR)
      GO TO 310 
C 
C 
232   DO 255 IWORD=1,161
      CALL MEMGT(MPADR+IWORD-1,JB(IWORD)) 
255   CONTINUE
C 
C 
310   INDEX=1 
      IWORD=1 
      IF(JB(1).GE.0.AND.JB(2).LT.0) STOP 66 
C 
C 
      ITMT(1)=JB(1) 
      DO 350 IS=1,32
      DO 350 IW=1,5 
      IWORD=IWORD+1 
      IF(IW.EQ.1.OR.IW.EQ.5) GO TO 350
      INDEX=INDEX+1 
      IF(IW.EQ.3) GO TO 330 
      ITMT(INDEX)=JB(IWORD) 
      GO TO 350 
330   ITEMP=IAND(JB(IWORD),176000B)*4 
      ITEMP=ITEMP+(IAND(JB(IWORD),1760B)*16)
      ITMT(INDEX)=ITEMP+IAND(JB(IWORD),17B) 
350   CONTINUE
C 
      RETURN
C 
C 
      END 
      END$
FTN4,L
C     NAME:   PRNTH 
C     SOURCE: 92067-18339 
C     RELOC:  92067-16339 
C     PGMR:   S.P.K. J.S.W
C 
C  ***************************************************************
C  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1976.  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 PRNTH (ITLU,IMLU,IBUF),92067-16339 REV.1903 790309 
C     SUBROUTINE TO READ HEADER RECORD AND PRINT TITLE AND TAPE # 
C 
      DIMENSION IBUF(1),ITITL(4),ITAPE(5),IOK(7)
      EXTERNAL MESG,DCASC,READU 
      DATA ITITL/2HFI,2HLE,2H I,2HD:/,
     C     ITAPE,ITAPE(2),ITAPE(3),ITAPE(4)/2HTA,2HPE,2H#:,2H  /, 
     C     IOK/2HOK,2H? ,2H (,2HYE,2HS/,2HNO,2H) /
   10 CALL EXEC (1,IMLU,IBUF,140) 
      CALL EXEC (2,ITLU,ITITL,4)
      CALL EXEC (2,ITLU,IBUF,36)
      CALL DCASC (ITAPE(5),1,IBUF(37))
      CALL EXEC (2,ITLU,ITAPE,5)
      CALL EXEC (2,ITLU,IOK,7)
      CALL READU(ITLU,IYES,1) 
      IF (IYES.EQ.2HYE) RETURN
      CALL MESG (ITLU,11) 
      PAUSE 
      IBUF=-1 
      RETURN
      END 
      END$
FTN4
C     NAME:   TPPOS 
C     SOURCE: 92067-18339 
C     RELOC:  92067-16339 
C     PGMR:   S.P.K.
C 
C  ***************************************************************
C  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1976.  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 TPPOS(ITLU,IMLU,IFILE,ITAPE),92067-16339 REV.1903 790309 
     X9 
C     ROUTINE TO POSITION MAG TAPE TO A DESIRED FILE #
      EXTERNAL ASCDC,READU,MESG 
      EQUIVALENCE (REG,IA)
      IF (IFILE.GT.0) GO TO 25
   10 CALL MESG (ITLU,5)
      CALL READU(ITLU,NFILE,1)
      CALL ASCDC (NFILE,1,IFILE)
C     CHECK IF FILE # > 0 AND <= 8
      IF (IFILE.EQ.0) IFILE=1 
      IF ((IFILE.LT.1).OR.(IFILE.GT.8)) GO TO 100 
   15 REWIND IMLU 
C     POSITION BY MOVING TAPE IFILE-1 FILES FORWARD 
      IF (IFILE.EQ.1) RETURN
      DO 20 NFILE=1,IFILE-1 
C     FORWARD SPACE MAG TAPE BY 1 FILE
      CALL EXEC (3+100000B,1300B+IMLU)
      GO TO 120 
C     EOT MARK SEEN? IF YES, ERROR - FILE NOT FOUND 
   17 REG=EXEC(3,600B+IMLU) 
      IF (IAND(IA,40B).EQ.40B) GO TO 120
   20 CONTINUE
      RETURN
C 
   25 IF (ITAPE.NEQ.1) GO TO 15 
      IF (IFILE.EQ.1) GO TO 15
      CALL EXEC (3,200B+IMLU) 
      CALL EXEC (3,1400B+IMLU)
      CALL EXEC (3,300B+IMLU) 
      RETURN
C 
C     ERROR MESSAGES
  100 CALL MESG(ITLU,18)
      GO TO 10
  120 CALL MESG (ITLU,19) 
      CALL MESG(ITLU,11)
      REWIND IMLU 
      PAUSE 
      GO TO 10
      END 
      END$
ASMB,R          
*     NAME:   ASCDC 
*     SOURCE: 92067-18339 
*     RELOC:  92067-16339
*     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 ASCDC,7 92067-16339 REV.1903 790309 
      ENT ASCDC     ROUTINE TO CONVERT ASCII TO DEC OR OCTAL
      ENT ASCOC 
ASCDC NOP           ASCII TO DECIMAL
      LDA D9
      STA RADIX     SET UP RADIX
      JMP START 
ASCOC NOP           ASCII TO OCTAL
      LDA ASCOC 
      STA ASCDC 
      LDA D7
      STA RADIX     SET UP RADIX TO 7 
START CLA 
      STA VAL       VAL IS GOING TO ACCUMULATE INTEGER VALUE
      STA IWORD     IWORD IS COUNTER FOR WORD IN BUF BEING CONVERTED
      LDA ASCDC,I 
      STA RETRN     SAVE RETURN ADDRESS 
      ISZ ASCDC 
      LDA ASCDC,I 
      STA INAM      SAVE ADDRESS OF CHARACTER STRING
      ISZ ASCDC 
      LDA ASCDC,I 
      LDA A,I 
      ADA N1
      STA NWORD     SAVE # OF WORDS TO BE CONVERTED-1 
      LDA IWORD 
LOOP  ADA INAM      INDEX INTO CHARACTER STRING BUFFER
      LDA A,I       FETCH CURRENT WORD IN STRING TO BE CONVERTED
      STA CWORD 
      AND .1774     SEPERATE UPPER BYTE 
      ALF,ALF 
      CPA SPACE     IF SPACE ENCOUNTERED IN FIRST BYTE IGNORE IT
      JMP IGNOR 
      CLB           CLEAR FLAG TO INDICATE UPPER BYTE OF CURRENT WORD 
      STB IFLAG     IS BEING CONVERTED
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 
      LDA IFLAG     JUST CONVERTED UPPER BYTE?
      SZA 
      JMP NEXT      YES, GET NEXT BYTE
IGNOR LDA CWORD     NO, FETCH CURRENT WORD THAT IS BEING CONVERTED
      AND .377      EXTRACT LOWER BYTE
      CPA SPACE     SPACE?
      JMP DONE      YES, DONE 
      ISZ IFLAG     SET FLAG TO INDICATE CONVERTING LOWER BYTE
      JMP CNVRT 
NEXT  LDA IWORD     GET ASCII STRING COUNTER
      CPA NWORD     ALL WORDS IN STRING CONVERTED?
      JMP DONE      YES, DONE 
      INA           NO, SET POINTER TO CONVERT THE NEXT WORD
      STA IWORD 
      JMP LOOP
DONE  ISZ ASCDC 
      LDA ASCDC,I 
      LDB VAL 
      STB A,I 
      JMP RETRN,I   RETURN WITH CONVERTED VALUE 
ERR   ISZ ASCDC     RETURN WITH VALUE = -1
      LDA ASCDC,I 
      LDB N1
      STB A,I 
      JMP RETRN,I 
* 
A     EQU 0 
B     EQU 1 
N1    DEC -1
.N60  OCT -60 
.1774 OCT 177400
.377  OCT 377 
D9    DEC 9 
D7    DEC 7 
VAL   BSS 1 
RADIX BSS 1 
RETRN BSS 1 
IFLAG BSS 1 
CWORD BSS 1 
NWORD BSS 1 
IWORD BSS 1 
INAM  BSS 1 
SPACE OCT 00040 
      END 
ASMB,R      
*     NAME:   DCASC 
*     SOURCE: 92067-18339 
*     RELOC:  92067-16339
*     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 DCASC,7 92067-16339 REV.1903 790309 
      ENT DCASC     ROUTINE TO CONVERT DECIMAL INTEGERS TO ASCII
DCASC NOP 
      CLA 
      STA IFLAG 
      STA CWORD 
      LDA DCASC,I 
      STA RETRN 
      ISZ DCASC 
      LDA DCASC,I 
      STA INAM      BUFFER ADDRESS
      ISZ DCASC 
      LDA DCASC,I 
      LDA A,I 
      ADA N1
      STA NWORD     LENGTH OF BUFFER-1
      LDA INAM      BUFFER TO BE BLANKED
LOOP0 LDB SPACE 
      STB A,I       BLANK OUT A WORD IN BUFFER
      LDB CWORD     USE CWORD AS COUNTER TO POINT IN TO BUFFER
      CPB NWORD     ALL WORDS IN BUFFER DONE? 
      JMP DCAS1     YES, GO ON
      INA 
      ISZ CWORD     INCREMENT COUNTER 
      JMP LOOP0 
DCAS1 ISZ DCASC 
      LDA DCASC,I 
      LDA A,I       LOAD INTEGER TO BE CONVERTED
LOOP  CLB 
      DIV D10       DIVIDE INTEGER BY BASE 10 
      STA QOTNT     QOTNT IS USED TO EXTRACT REMAINING DIGITS 
      ADB .60       B REG CONTAINS REMAINDER WHICH IS THE LATEST DIGIT
*                                   TO BE CONVERTED BY ADDING OCTAL 60
      STB BYTE      ASCII INTEGER SAVED 
      LDA IFLAG     CHECK TO SEE IF THIS IS A LOW ORDER BYTE
      SZA           LOW ORDER BYTE IF IFLAG=0, ELSE HIGH ORDER BYTE 
      JMP HIGH
      LDA BYTE
      STA CWORD     STORE BYTE IN LOWER HALF OF CWORD 
      LDA QOTNT     GET READY TO EXTRACT AND CONVERT NEXT DIGIT 
      ISZ IFLAG      SET FLAG TO INDICATE WORKING ON HIGH ORDER BYTE
      JMP LOOP      START CONVERSION AGAIN
HIGH  LDA BYTE      BIT 0 NOT SET IF HIGH ORDER BYTE
      ALF,ALF       STORE BYTE IN UPPER HALF OF CWORD 
      ADA CWORD 
      STA CWORD 
      LDA NWORD 
      ADA INAM      REG A POINTS TO BUFFER WHERE CWORD IS PLACED
      LDB CWORD 
      STB A,I 
      LDA NWORD 
      SZA,RSS       HAS THE BUFFER BEEN FILLED? 
      JMP RETRN,I   YES,RETURN TO CALLING ROUTINE 
      ADA N1        NO,DECREASE NWORD TO POINT TO NEXT WORD IN BUFFER 
      STA NWORD 
      CLA 
      STA IFLAG     CLEAR FLAG TO INDICATE WORKING ON LOW ORDER BYTE
      LDA QOTNT     GET READY TO EXTRACT NEXT DIGIT 
      SZA           IF QOTNT=0 THEN NO MORE DIGITS LEFT TO CONVERT
      JMP LOOP
      JMP RETRN,I 
* 
A     EQU 0 
B     EQU 1 
RETRN BSS 1 
NWORD BSS 1 
CWORD BSS 1 
IFLAG BSS 1 
QOTNT BSS 1 
BYTE  BSS 1 
N1    DEC -1
D10   DEC 10
.60   OCT 60
INAM  BSS 1 
SPACE ASC 1,
      END 
ASMB,R      
*     NAME:   DRT 
*     SOURCE: 92067-18339 
*     RELOC:  92067-16339
*     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 DRT,7 92067-16339 REV.1903 790309 
      ENT DRT     DEVICE REFERENCE TABLE IS SCANNED THROUGH TO FIND 
      EXT RMOVI 
DRT   NOP           LU# FOR GIVEN SUBCHANNEL AND EQT# 
      LDA DRT,I   SAVE RETURN POINTER 
      STA RETRN 
      ISZ DRT 
      LDA DRT,I   PICK UP SUBCHANNEL # TO BE FOUND IN DRT 
      LDA A,I 
      STA ISUB
      ISZ DRT 
      LDA DRT,I   PICK UP LAST PLACE (LU) LOOKED AT IN DRT
      LDA A,I     NON-ZERO IF EQT DID NOT SHOW RIGHT DEVICE TYPE
      STA ILU 
      LDA DRT 
      INA 
      LDA A,I     PICK UP EQT# PARAMETER. IF FIRST SUBCHNL EQT# PARM. 
      JSB RMOVI 
      STA IEQT    WILL BE 0, ELSE >0 FOR NEXT SUBCHNLS
LOOP  LDB IDRT
      ADB ILU       INDEX INTO DRT
      ADB N1
      LDA B,I 
      AND .174    FIND SUBCHNL # OF PARTICULAR DRT ENTRY
      ALF,RAL 
      CPA ISUB
      JMP EQT     JUMP IF MATCHING SUBCHNL # FOUND
CHLU  LDA ILU     HAVE ALL THE ENTRIES IN DRT BEEN CHECKED? 
      CPA LUMAX 
      JMP ERR     YES, THEREFORE ERROR
      ISZ ILU     NO, THEREFORE INCREAMENT LU# AND TRY AGAIN
      JMP LOOP
EQT   LDB IDRT FIND EQT # FOR GIVEN SUBCHNL 
      ADB ILU 
      ADB N1
      LDA B,I 
      AND .77 
      LDB IEQT,I
      SZB         IF LOOKING FOR SUBCHNL FIRST TIME,
*                 RETURN EQT # TO CHECK FOR DEVICE
      JMP CHEQT   IF LOOKING FOR NEXT SUBCHNL, CHECK IF EQT # MATCHES 
      STA IEQT,I
LU    LDA DRT,I 
      LDB ILU     RETURN LU # FOR GIVEN SUBCHNL 
      STB A,I 
      JMP RETRN,I 
ERR   LDA DRT,I   NO LU # ASSIGNED TO GIVEN SUBCHNL 
      LDB N1
      STB A,I 
      JMP RETRN,I 
CHEQT CPA B       CHECK IF EQT #'S MATCH
      JMP LU      YES. RETURN WITH LU # 
      JMP CHLU    NO. TRY WITH NEXT LU #
RETRN BSS 1 
ISUB  BSS 1 
IEQT  BSS 1 
ILU   BSS 1 
IDRT  EQU 1652B   FWA OF DRT
LUMAX EQU 1653B   # OF ENTRIES IN DRT 
A     EQU 0 
B     EQU 1 
.77   OCT 77
.174  OCT 174000
N1    DEC -1
      END 
ASMB,R,L,C
*     NAME:   DSCAD 
*     SOURCE: 92067-18339 
*     RELOC:  92067-16339
*     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 DSCAD,7 92067-16339 REV.1903 790309 
      EXT EXEC      ROUTINE TO FIND LU#, TRACK#, SECTOR # FROM
      ENT DSCAD     DISC ADDRESS WORD.  WHERE IF BIT 15=0  LU = 2,
DSCAD NOP           IF BIT 15=1, LU=3; BITS 7-14 IS TRACK NUMBER; 
      LDA DSCAD,I                    BITS 0-6 IS SECTOR NUMBER
      STA RETRN   SAVE RETURN POINTER 
      ISZ DSCAD 
      LDA DSCAD,I 
      LDA A,I 
      STA IDADR 
      ISZ DSCAD 
      LDB DSCAD,I 
      STB T1
      SSA 
      JMP LU3 
      LDB D2
      STB T1,I    LU=2
      JMP TRCK
LU3   LDB D3      LU=3
      STB T1,I
TRCK  AND .776    FIND TRACK #
      ISZ DSCAD 
      LDB DSCAD,I 
      ALF,ALF 
      RAL 
      STA B,I 
      STA ITRCK 
      LDA IDADR 
      AND .177    FIND SECTOR # 
      ISZ DSCAD 
      LDB DSCAD,I 
      STA B,I 
      JMP RETRN,I RETURN TO CALLING ROUTINE 
IDADR BSS 1 
T1    BSS 1 
ITRCK BSS 1 
RETRN BSS 1 
MSG   ASC 2,HERE
D3    DEC 3 
D2    DEC 2 
D1    DEC 1 
.776  OCT 77600 
.177  OCT 177 
A     EQU 0 
B     EQU 1 
      END 
ASMB,R      
*     NAME:   MEMGT 
*     SOURCE: 92067-18339 
*     RELOC:  92067-16339
*     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 MEMGT,7 92067-16339 REV.1903 790309 
      ENT MEMGT     ROUTINE TO RETURN CONTENTS OF GIVEN LOC IN MEMORY 
MEMGT NOP           ROUTINE TO GET CONTENTS OF GIVEN MEMORY LOCATION
      LDA MEMGT,I 
      STA RETRN     SAVE RETURN ADDRESS 
      ISZ MEMGT 
      LDA MEMGT,I 
      LDA A,I       A REG HAS CONTENTS ADDRESS OF LOCATION
      LDA A,I       A REG HAS CONTENTS OF LOCATION
      ISZ MEMGT 
      LDB MEMGT,I   B REG HAS ADDRESS OF VARIABLE 
      STA B,I 
      JMP RETRN,I   RETURN
A     EQU 0 
B     EQU 1 
RETRN BSS 1 
      END 
ASMB,R      
*     NAME:   SUB 
*     SOURCE: 92067-18339 
*     RELOC:  92067-16339
*     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 SUB,7 92067-16339 REV.1903 790309 
      ENT SUB       ROUTINE TO DETERMINE SUBCHNL# OF GIVEN LU#
SUB   NOP           LU# ENTRY IN DRT (BITS 11-15) IS USED 
      LDA SUB,I 
      STA RETRN     SAVE RETURN ADDRESS 
      ISZ SUB 
      LDB SUB,I     B HAS ADDRESS OF SUBCHANNEL LU
      LDB B,I       LU # IN B REG 
      ADB N1
      ADB DRT       ADDRESS OF FIRST WORD IN DRT
      LDA B,I       DRT ENTRY IN A REG
      AND .1740     MASK OFF BITS 0-10
      ALF,RAL       ROTATE BITS 11-15 TO 0-4 POSITION 
      ISZ SUB 
      LDB SUB,I     ADDRESS OF ISUB 
      STA B,I       PASS BACK SUBCHANNEL #
      JMP RETRN,I   RETURN TO CALLING ROUTINE 
RETRN BSS 1 
A     EQU 0 
B     EQU 1 
.1740 OCT 174000
N1    DEC -1
DRT   EQU 1652B     FWA OF DRT
      END 
FTN4
C     NAME:   READU 
C     SOURCE: 92067-18339 
C     RELOC:  92067-16339 
C     PGMR:   S.P.K.
C 
C  ***************************************************************
C  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1976.  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 READU(ITLU,IBUF,ILEN),92067-16339 REV.1903 790309
      DIMENSION IBUF(1),IREG(2) 
      EQUIVALENCE (IREG(1),IA,REG),(IREG(2),IB) 
      DATA IABRT/2HAB/,IQUES/2H??/
    5 DO 10 I=1,ILEN
      IBUF(I)=2H
   10 CONTINUE
      REG = EXEC (1,ITLU+400B,IBUF,ILEN)
      LEN=IB
      IF (LEN.NEQ.0)  GO TO 20
      CALL EXEC (2,ITLU,IQUES,1)
      GO TO 5 
   20 IF (IBUF(1).NEQ.IABRT) RETURN 
      CALL MESG (ITLU,14) 
      STOP
      END 
      END$
ASMB,R      
*     NAME:   RMOVI 
*     SOURCE: 92067-18339 
*     RELOC:  92067-16339
*     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 RMOVI,7 92067-16339 REV.1903 790309 
      ENT RMOVI     ROUTINE TO REMOVE INDIRECTS FROM GIVEN ADDRESS
RMOVI NOP           ROUTINE TO REMOVE INDIRECTS FROM DEF ADDRESSES
      RSS 
MOREI LDA A,I       REG A HAS INDIRECT ADDRESS
      RAL,CLE,SLA,ERA 
      JMP MOREI     STILL AN INDIRECT ADDRESS 
      JMP RMOVI,I 
* 
A     EQU 0 
      END 
ASMB,Q,C
*     NAME:   MESG
*     SOURCE: 92067-18339 
*     RELOC:  92067-16339
*     PGMR:   S.P.K. J.S.W
* 
*  ***************************************************************
*  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980.  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 MESG,7 92067-16339 REV.2013 800104
      ENT MESG,ITASK      ROUTINE TO PRINT MESSAGES FOR 
      EXT EXEC      SAVE, RSTOR AND COPY
      EXT PNAME     GET PROGRAM NAME ROUTINE
MESG  NOP 
      SUP 
      LDA MESG,I
      STA RETRN     SAVE RETURN ADDRESS 
      ISZ MESG
      LDA MESG,I
      LDB A,I 
      STB ITLU
      ISZ MESG
      LDA MESG,I
      LDB A,I 
      STB TEMP      MESSAGE # 
      CPB D50       IF MSG# IS 28 CONVERT IT TO 17
      LDB D17 
      LDA MSG 
      ADA B 
      LDB A,I 
      LDA B,I 
      STA IBUFL 
      INB 
      STB MADDR 
      JSB PNAME     FIND THIS PROGRAM'S NAME
      DEF *+2 
ADDR  DEF NAME  
      LDB MADDR     GET THE ADDRESS OF MESSAGE
      LDA TEMP      MESSAGE #?
      CPA D11       IS IT RESTART ------ BY ENTERING........? 
      JMP MESG1     YES 
      CPA D14       IS IT ----- ABORTED?
      JMP MESG2 
      CPA D25       IS IT MESG # 25?
      JMP MESG2     YES 
      CPA D17       IS IT MESG # 17?
      JMP MESG3     YES 
      CPA D50       USE DIFFERENT NAME ADDR FOR MESG 28 
      RSS 
      JMP MESG5 
      LDA ADDR2 
      RSS 
MESG3 LDA ADDR1 
      ADB D7
      JSB MOVE
      JMP MESG5 
MESG2 LDA ADDR      YES, THEN A REG HAS ADDR OF NAME
      JSB MOVE      MOVE NAME MESSAGE INTO MESSAGE 14 
      JMP MESG5     SEND MESSAGE OUT TO TTY 
MESG1 LDA ADDR      MESSAGE OF NAME 
      ADB D4        INDEX INTO IT 
      JSB MOVE      MOVE APPROPRIATE NAME IN IT 
      LDA ADDR      MESSAGE OF NAME 
      LDB MADDR 
      ADB D15       INDEX FURTHER INTO MSG11
      JSB MOVE      MOVE WORDS
MESG5 JSB EXEC
      DEF *+5 
      DEF ICODE 
      DEF ITLU
      DEF MADDR,I 
      DEF IBUFL 
      JMP RETRN,I 
* 
MOVE  NOP           ROUTINE TO MOVE THREE WORDS FROM
      STA TEMP      SAVE CONTENTS OF A REG
      LDA N3
      STA COUNT     COUNTER 
LOOP  LDA TEMP
      LDA A,I 
      STA B,I 
      INB 
      ISZ TEMP
      ISZ COUNT 
      JMP LOOP
      JMP MOVE,I    RETURN
* 
MSG   DEF MESGX 
MESGX DEF MSG0
      DEF MSG1
      DEF MSG2
      DEF MSG3
      DEF MSG4
      DEF MSG5
      DEF MSG6
      DEF MSG7
      DEF MSG8
      DEF MSG9
      DEF MSG10 
      DEF MSG11 
      DEF MSG12 
      DEF MSG13 
      DEF MSG14 
      DEF MSG15 
      DEF MSG16 
      DEF MSG17 
      DEF MSG18 
      DEF MSG19 
      DEF MSG20 
      DEF MSG21 
      DEF MSG22 
      DEF MSG23 
      DEF MSG24 
      DEF MSG25 
      DEF MSG26 
      DEF MSG27 
      DEF MSG28 
* 
A     EQU 0 
B     EQU 1 
RETRN BSS 1 
ITLU  BSS 1 
IBUFL BSS 1 
ICODE DEC 2 
MSG0  DEC 8 
      ASC 8,VERIFY? (YES/NO)
MSG1  DEC 12
      ASC 12,PARTITION SIZE TOO SMALL 
MSG2  DEC 17
      ASC 21,TRACK SIZE BUFFER DESIRED?(YES/NO) 
MSG3  DEC 30
      ASC 4,WARNING-
      ASC 26,PARTITION SIZE TOO SMALL FOR VERIFY W/ TRCK SIZE BUF 
MSG4  DEC 16
      ASC 16,FOLLOWING TRCK MAP TBL NOT FOUND 
MSG5  DEC 3 
      ASC 3,FILE#?
MSG6  DEC 21
      ASC 21,FOLLOWING DISC DRIVE# IMPROPER,ENTER AGAIN 
MSG7  DEC 20
      ASC 20,FOLLOWING DISC LU# IMPROPER, ENTER AGAIN 
MSG8  DEC 11
      ASC 11,IMPROPER MT LU#, LU#=? 
MSG9  DEC 16
      ASC 16,ASSIGN LU# TO FOLLOWING SUBCHNL
MSG10 DEC 15
      ASC 15,NO WRITE RING, WRITE ENABLE MT 
MSG11 DEC 19
      ASC 19,RESTART       BY ENTERING 'GO,      '
MSG12 DEC 13
      ASC 13,EOT REACHED,MOUNT NEW TAPE 
MSG13 DEC 17
      ASC 17,DISC ERROR AT FOLLOWING TRCK & LU# 
MSG14 DEC 7 
      ASC 7,      ABORTED 
MSG15 DEC 20
      ASC 20,FOLLOWING DISC TYPE IMPROPER,ENTER AGAIN 
MSG16 DEC 22
      ASC 22,SOURCE & DEST TRACK MAP INFO. NOT COMPATIBLE 
MSG17 DEC 16
      ASC 16,DISC TYPE FOR        DISC UNIT?
MSG18 DEC 7 
      ASC 7,IMPROPER FILE#
MSG19 DEC 7 
      ASC 7,FILE NOT FOUND
MSG20 DEC 17
      ASC 17,SAVE TYPE NOT SAME AS RESTORE TYPE 
MSG21 DEC 17
      ASC 17,WARNING-WRITING ON PROTECTED TRCKS 
MSG22 DEC 13
      ASC 13,DEST SUBCHNL IS LU2 OR LU3 
MSG23 DEC 20
      ASC 20,OFF-LINE SAVE,CANNOT BE RESTORED ON-LINE 
MSG24 DEC 7 
      ASC 7,MOUNT TAPE# 1 
MSG25 DEC 14
      ASC 14,      WAITING FOR MT LU LOCK 
MSG26 DEC 18
      ASC 18,MISSING REC FOR FOLLOWING TRCK & LU# 
MSG27 DEC 27
      ASC 27,WARNING-VERFY NOT DEFINED OR PARTITION SIZE TOO SMALL
MSG28 DEC 11
      ASC 11,IMPROPER TRCK MAP INFO 
ADDR1 DEF *+1 
      ASC 3,SOURCE
ADDR2 DEF *+1 
      ASC 3,DEST
ITASK BSS 1 
MADDR BSS 1 
NAME  BSS 3 
D4    DEC 4 
D7    EQU MSG14 
D11   EQU MSG8
D14   EQU MSG25 
D15   EQU MSG10 
D17   EQU MSG2
D25   DEC 25
D50   DEC 50
N3    DEC -3
TEMP  BSS 1 
COUNT BSS 1 
      END