ASMB,R,L,C,Z
      HED (FMP) IDRPL: SUBROUTINE TO DO A FMGR ":RP,PROG" 
*     NAME:   IDRPL 
*     SOURCE: 92071-18062 
*     RELOC:  92071-16062 
*     PGMR:   M.L.K.
*     MOD:    E.D.B.
* 
*  ***************************************************************
*  * (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 IDRPL,7 92071-1X062 REV.2041 800421 
* 
      ENT IDRPL 
* 
      EXT GTOPN, NAM..
      EXT IDSGA, LOGLU, .MWI, .XLA, .CAX
      EXT EXEC,  .ENTR, $LIBR, $LIBX, $SETP, $IDSZ
      IFZ           *** L/20 CODE *** 
      EXT $CKSM, $SCCK
      XIF 
      IFN           *** L/10 CODE *** 
      EXT $FWBG, $BGBP, $CKSM 
      XIF 
* 
      EXT F.DCB, F.LU, F.TR2, F.SC2, F.S/T, F.FLG 
      SUP 
      SKP 
* 
*     DESCRIPTION 
* 
*     IDRPL CREATES AN ID SEGMENT FOR A PROGRAM 
* 
*     CALLING SEQUENCE: 
* 
*     CALL IDRPL (IDCB,IERR,NAME,IPERM) 
*     IERR = IDRPL (IDCB,IERR,NAME,IPERM) 
* 
*     WHERE:
* 
*     IERR   WILL BE ERROR RETURN CODE (SAME AS ERROR CODES IN FMGR)
* 
*     IDCB   IS AN OPEN DATA CONTROL BLOCK (144-WORD ARRAY) 
*            FOR THE TYPE 6 FILE TO BE RESTORED.
* 
*     NAME   IS 5 CHARACTER PROGRA NAME (3-WORD ARRAY) TO PUT INTO
*            ID SEGMENT.
* 
*     IPERM  IS 0 IF PROGRAM TO BE TEMPORARY, #0 IF TO BE PERMANENT 
* 
*     WORDS SET BY IDRPL: 
* 
*     LONG ID SEGMENT 
*     13-15  PROGRAM NAME FROM THIRD INPUT PARAMETER
*     16     ID BIT SET ACCORDING TO IPERM PARAMETER
*     25     BASE PAGE TRACK NUMBER (L/10 ONLY) 
*     26 LO  BASE PAGE BLOCK NUMBER (L/10 ONLY) 
*        HI  MAIN BLOCK NUMBER
*     27     MAIN TRACK NUMBER
*     28 LO  MAIN DISC LU 
*     29 LO  CONSOLE LU (FROM LOGLU)
*        HI  SEQUENCE NUMBER (FROM OLD ID SEGMENT)
* 
*     SHORT ID SEGMENT
*     3      MAIN TRACK OFFSET (L/10 ONLY)
*     6      BASE PAGE TRACK OFFSET (L/10 ONLY) 
*     7      BASE PAGE BLOCK NUMBER (L/10 ONLY) 
*     8      SYSTEM CHECKSUM (L/10 ONLY)
* 
*     POSSIBLE ERRORS:
* 
*       0    SUCCESSFUL INSTALLATION OF ID SEGMENT INTO SYSTEM
*     -11    IDCB NOT OPEN
*      14    NO BLANK ID SEGMENTS OR EXTENSIONS AVAILABLE 
*     -15    ILLEGAL NAME 
*      19    A CHECKSUM (ID(34), ID(35), ID(36)) DID NOT MATCH. 
*      23    DUPLICATE PROGRAM NAME 
*      39    DISC ADDRESS OUT OF RANGE
*      40    MEMORY BOUNDS CONFLICT 
*      ??    PROGRAM ALREADY RP'ED
* 
*     NOTES:
*     (1)    IDRPL DOES NOT CLOSE THE FILE. 
*     (2)    RECOMMEND FILE BE NON-EXCLUSIVELY OPENED.
*     (3)    E-REG = 1 IF ERROR; E=0 IF NO ERROR (FOR SPL). 
*     (4)    ONLY THE DCB HEADER IS USED BY THIS SUBROUTINE.
* 
*     SPECIAL ASSEMBLY INSTRUCTIONS:
*     THIS FILE CONTAINS SOURCE CODE FOR BOTH THE RTE-L AND RTE-L/20
*     IDRPL SUBROUTINE.  ASSEMBLY THE CODE WITH THE N OPTION FOR
*     THE RTE-L VERSION, AND WITH THE Z OPTION FOR THE RTE-L/20 
*     VERSION 
      SKP 
* 
*     ENTRY 
* 
IDRPL NOP           DUMMY ENTRY POINT 
      LDA DZERO 
      STA PERM
      LDA IDRPL 
      STA DRPL
      JMP DRPL+1
* 
IDCB  NOP           OPEN DCB ADDRESS
IERR  NOP           RETURNED ERROR CODE 
NAME  NOP           FIVE CHAR ASCII NAME TO GIVE PROGRAM
PERM  NOP           PERMANENT OR TEMPORARY INDICATOR
* 
DRPL  NOP           ENTRY 
      JSB .ENTR 
      DEF IDCB
* 
      LDA IDCB      MAKE LOCAL COPY OF DCB POINTERS 
      LDB F.DCB 
      JSB $SETP 
      DEF .16 
      NOP 
* 
      JSB GTOPN     GET PROGRAM'S OPEN FLAG 
      DEF *+1 
      CPA F.FLG,I   IS IT THE SAME AS IN DCB? 
      RSS 
      JMP ER11       NO, TAKE ERROR EXIT
* 
      JSB NAM..     CHECK FOR LEGAL NAME
      DEF *+2 
      DEF NAME,I
* 
      SZA           NAME OK?
      JMP EREX      NO, FMGR ERROR -15
      SKP 
* 
*     PROCESS REQUEST 
* 
      LDA F.LU,I    GET WORD CONTAINING LU
      AND B77        ISOLATE LU 
      IOR B7700       ADD PROTECT BITS
      STA PDSLU        SAVE FOR EXEC
* 
      IFN           *** L/10 CODE *** 
      LDA F.S/T,I   GET SECTORS / TRACK 
      ARS            CONVERT TO BLOCKS
      STA BK/TR 
      XIF 
* 
      JSB EXEC      READ SKELETON ID SEGMENT FROM FILE
      DEF *+7 
      DEF .1
      DEF PDSLU     PROTECTED DISC LU 
DEFID DEF IDBUF     DESTINATION BUFFER ADDRESS
      DEF IDSIZ     BUFFER LENGTH 
      DEF F.TR2,I   DISC TRACK
      DEF F.SC2,I   DISK SECTOR 
* 
      JSB .XLA      GET SYSTEM CHECKSUM 
      DEF $CKSM+0 
      CPA CKSM      IF SAME AS ID SEGMENT,
      RSS            THEN CONTINUE
      JMP ER19
* 
      IFZ           *** L/20 CODE *** 
      LDA ID+16     GET ID SEGMENT STATUS WORD
      AND B4K        ISOLATE SYSTEM-COMMON FLAG 
      SZA,RSS       IF PROGRAM DOESN'T USE SYSTEM COMMON
      JMP NOCHK      THEN DON'T TEST CHECKSUM 
* 
      JSB .XLA      GET SYSTEM COMMON CHECKSUM
      DEF $SCCK+0 
      CPA SCCK      IF SAME AS ID SEGMENT,
      RSS            THEN CONTINUE
      JMP ER19
      XIF 
* 
NOCHK LDA DEFID     GET THE LONG ID SEGMENT'S ADDRESS 
      STA #MOVE      SAVE CHECKSUM START ADDRESS
      LDB NCKSM     GET NUMBER OF WORDS (NEGATIVE)
      CLA           CLEAR CHECKSUM FOR TOTALING 
* 
SUM1  ADA #MOVE,I   ACCUMULATE THE SUM
      ISZ #MOVE     BUMP TO NEXT WORD 
      INB,SZB       IF NOT DONE,
      JMP SUM1       THEN ADD THE NEXT
* 
      CPA CKSM1     IF EQUAL TO INTERNAL CHECKSUM,
      RSS            THEN CONTINUE
      JMP ER19       ELSE TAKE ERROR EXIT 
      SKP 
* 
*     SET UP LONG ID SEGMENT
* 
      LDA F.SC2,I   GET STARTING SECTOR NUMBER
      ADA .2         BUMP TO BEGINNING OF MAIN (RECORD 2) 
      CLB           CLEAR B FOR DIVIDE
      DIV F.S/T,I   DIVIDE BY SECTORS / TRACK 
      ADA F.TR2,I    ADD STARTING TRACK NUMBER
      BRS             CONVERT SECTORS TO BLOCKS 
* 
      IFN           *** L/10 CODE *** 
      DST ID+26     SAVE MAIN TRACK AND BLOCK ADDRESS 
      DST TRACK     SAVE TRACK AND BLOCK FOR BUMP 
      LDA ID+22     FETCH MAIN HIGH ADDRESS 
      LDB ID+21     FETCH MAIN LOW ADDRESS
      JSB BUMP       CALCULATE DISC ADDRESS 
      ALF,ALF       ALIGN BASE PAGE BLOCK ADDRESS 
      IOR ID+26      MERGE WITH MAIN BLOCK ADDRESS
      STA ID+26       AND SAVE AGAIN
* 
      LDA ID+27     GET MAIN TRACK ADDRESS
      CMA,INA        NEGATE 
      STA NEGMN       AND SAVE FOR LATER
      ADB A         ADD BASE PAGE TRACK ADDRESS 
      LDA N64        TEST IF OFFSET NEEDS MORE THAN 6 BITS
      ADA B 
      SSA,RSS       IF OUT OF RANGE,
      JMP ER39       THEN TAKE ERROR EXIT 
* 
      CLA           CLEAR FOR SHIFT 
      ASR 6          MOVE OFFSET (B-REG) TO HI BITS OF A-REG
      IOR ID+25       MERGE WITH OLD WORD 25
      STA ID+25        AND SAVE AGAIN 
      XIF 
      IFZ           *** L/20 CODE *** 
      SWP 
      ALF,ALF       SHIFT MAIN BLOCK ADDRESS TO HIGH BYTE 
      AND NB400      ISOLATE IT 
      IOR ID+26       MERGE WITH CURRENT WORD 26
      DST ID+26     SAVE MAIN TRACK AND BLOCK ADDRESS 
      XIF 
* 
      LDA F.LU,I    GET DISC LU 
      AND B77        ISOLATE LU 
      IOR ID+28       MERGE WITH CURRENT WORD 28
      STA ID+28     SAVE IN WORD 28 
* 
      JSB LOGLU     GET CONSOLE LU
      DEF *+2 
      DEF PDSLU     DUMMY PARAMETER 
      STA ID+29     SAVE IN WORD 29 
* 
      LDA NAME,I    GET FIRST TWO CHARACTERS
      STA ID+13     SAVE IN WORD 13 
      LDA NAME      GET THE ADDRESS OF THE NAME 
      INA           POINT TO THE SECOND WORD
      DLD A,I       AND GET THE REST
      STA ID+14     SAVE THE SECOND WORD
      LDA B         MOVE LAST CHARACTER TO A
      AND NB400     CLEAR LOWER BYTE
      STA ID+15     AND SAVE IN ID WORD 15
* 
*  SET ID BIT IF NECESSARY
* 
      LDA IDBIT     PRESET THE ID BIT 
      LDB PERM,I    NOW GET THE PERMANENT PARAMETER 
      SZB           PREMANENT OR TEMPORARY? 
      CLA           PERMANENT, DON'T SET ID BIT 
      IOR ID+16     TEMPORARY, SET ID BIT 
      STA ID+16     SAVE BACK IN WORD 16
* 
*  CHECK PRIORITY, SET TO 99 IF 0 
* 
      LDA ID+7      GET PRIORITY
      SZA,RSS       IF IT IS ZERO 
      LDA .99       THEN SET IT TO 99 
      STA ID+7      AND SET IN WORD 7 
      SKP 
* 
*     SET UP SHORT ID SEGMENTS
* 
      IFN           *** L/10 CODE *** 
      DLD F.TR2,I   GET DISC ADDRESS
      DST TRAK       AND SAVE FOR SETPT 
* 
      LDA ID+24     GET ID WORD 24
      ALF,ALF       SWAP BYTES
      RAR,RAR       POSITION # OF SEGMENTS INTO LOWER BITS
      AND B77       AND ISOLATE 
      SZA,RSS       ANY SEGMENTS? 
      JMP WRTID     NO, GO WRITE ID SEG INTO MEMORY 
      CMA,INA       SET # SEG NEGATIVE
      STA LPCNT     SAVE AS LOOP COUNTER
      CCA           SET INIT TO -1 TO CAUSE 
      STA INIT      SETPT TO INITIALIZE THE SECTOR BUFFER 
* 
      JSB .XLA      GET BG BOUNDRY IN CASE REAL TIME
      DEF $FWBG+0 
      STA HISEG     SAVE IN PLACE OF HI SEGMENT 
      JSB .XLA      GET BG BP BOUNDRY IN CASE REAL TIME 
      DEF $BGBP+0 
      STA HIBP      SAVE IN PLACE OF HI SEGMENT BP
* 
      LDA ID+24     GET BASE PAGE LOW ADDRESS 
      AND B1777      ISOLATE, 
      STA B           AND PUT INTO B
      LDA ID+25     GET BASE PAGE HIGH ADDRESS + 1
      AND B1777      ISOLATE, 
      STA HMNBP       AND SAVE FOR LOOP 
      JSB BUMP      POSITION TRACK AND SECTOR TO SEGMENT 0
* 
LOOP  JSB SETPT     SET UP POINTERS TO SHORT ID SEGMENT 
      DLD TRACK     GET CURRENT TRACK AND BLOCK OF SEGMENT MAIN 
      STA TR         SAVE TRACK FOR LATER 
      STB SID7,I     SAVE BLOCK IN THE SHORT ID WORD 7
      ADA NEGMN     SUBTRACT THE MAIN TRACK TO GET OFFSET 
      LDB N256      TEST WHETHER OFFSET IS GREATER THAN 255 
      ADB A           AND WON'T FIT IN A BYTE 
      SSB,RSS       IF OUT OF RANGE 
      JMP ER39       THEN TAKE ERROR EXIT 
* 
      STA B         MOVE OFFSET INTO B-REG
      LDA SID3,I    GET LAST LETTER OF NAME AND 
      AND NB400      ISOLATE IT 
      IOR B           MERGE WITH OFFSET 
      STA SID3,I       AND SAVE AGAIN 
      SKP 
* 
*  SET UP FOR SEGMENT'S BASE PAGE 
* 
      LDA SID5,I    GET THE SEGMENT'S MAIN HIGH ADDRESS + 1 
      LDB ID+22     USE THE MAIN HIGH ADDRESS AS LOW
      JSB BUMP      UPDATE THE DISC POINTERS
      ALF,ALF       POSITION THE BP SECTOR IN THE UPPER BYTE
      IOR SID7,I    PUT IN THE SEGMENT'S MAIN SECTOR
      STA SID7,I    AND SAVE BACK IN WORD 7 
      LDB TR        GET SEGMENT'S MAIN TRACK
      CMB,INB       AND SET IT NEGATIVE 
      ADB TRACK     ADD THE SEGMENT'S BP TRACK
      LDA N64       TEST IF GREATER THAN 64 
      ADA B 
      SSA,RSS       IF OUT OF RANGE,
      JMP ER39       THEN TAKE ERROR EXIT 
* 
      BLF,BLF       POSITION TRACK OFFSET TO UPPER
      RBL,RBL         SIX BITS
      LDA SID6,I    GET BASE PAGE HIGH ADDRESS + 1 IN A 
      AND B1777      ISOLATE BASE PAGE HIGH ADDRESS + 1 
      ADB A           MERGE WITH BASE PAGE TRACK OFFSET 
      STB SID6,I       AND SAVE AGAIN 
      LDB HMNBP     LOAD MAIN BASE PAGE HIGH ADDRESS
      JSB BUMP      NOW UPDATE DISC ADDRESSES 
* 
*  CALCULATE THE SHORT ID SEGMENT CHECKSUM
* 
      LDA SID1      GET THE SHORT ID SEGMENT'S ADDRESS
      STA #MOVE      SAVE CHECKSUM START ADDRESS
      LDB N7        GET NUMBER OF WORDS (NEGATIVE)
      CLA           CLEAR CHECKSUM FOR TOTALING 
* 
SUM2  ADA #MOVE,I   ACCUMULATE THE SUM
      ISZ #MOVE     BUMP TO NEXT WORD 
      INB,SZB       IF NOT DONE,
      JMP SUM2       THEN ADD THE NEXT
* 
      STA SID8,I    SAVE CHECKSUM IN WORD 8 
* 
*  CHECK COUNT
* 
      ISZ LPCNT     DONE YET? 
      JMP LOOP      NO, DO NEXT SEGMENT 
* 
*  WRITE OUT LAST SECTOR
* 
      LDA ENDSB     GET ADDRESS OF THE END OF THE SECTOR BUFFER 
      ADA N8        AND SUBTRACT 8 AND SAVE IN SID1.  THIS WILL 
      STA SID1      FORCE A WRITE OF THE CURRENT SECTOR.
      JSB SETPT     NOW CALL TO DO WRITE
      XIF 
      SKP 
* 
*     WRITE THE ID SEGMENT INTO SYSTEM MEMORY 
* 
WRTID JSB $LIBR     GO PRIVILEGED TO PREVENT
      NOP            CONFLICTS WITH OTHER ROUTINES
* 
      JSB IDSGA     SEARCH FOR DUPLICATE PROGRAM NAME 
      DEF *+2 
      DEF NAME,I
* 
      SEZ           IF NOT FOUND, 
      JMP FREID 
* 
*     WAS IT ALREADY RP'ED
* 
*     JMP PER??     INDICATE ALREADY RP'ED
      JMP PER23     INDICATE DUPLICATE PROGRAM NAME 
* 
*  SEARCH FOR FREE ID SEGMENT 
* 
FREID JSB IDSGA     LOOK FOR BLANK NAME (EMPTY ID SEGMENT)
      DEF *+2 
      DEF ZERO      ARRAY OF THREE ZEROS
* 
      SEZ           IF NOT FOUND
      JMP PER14      THEN INDICATE NO ID SEGMENTS AVAILABLE 
* 
*  MOVE ID SEGMENT INTO SYSTEM
* 
      STA B         SAVE COPY OF ID ADDRESS FOR MOVE
      ADA .28       BUMP TO WORD 29 
      JSB .XLA      GET WORD WITH SEQUENCE NUMBER 
      DEF A,I 
      AND B170K      ISOLATE SEQUENCE NUMBER
      IOR ID+29       MERGE WITH USER'S CONSOLE LU
      STA ID+29        AND SAVE IN WORD 29
* 
      JSB .XLA      SET TO MOVE ID SEGMENT
      DEF $IDSZ+0 
      JSB .CAX       (MOVE TO X-REG FOR .MWI) 
      LDA DEFID     SET A TO SOURCE (B TO DESTINATION)
* 
      JSB .MWI      MOVE THE ID SEGMENT 
* 
      CLA,CLE       NO ERROR INTENDED 
      JMP PEREX 
* 
PER?? LDA .??       PROGRAM ALREADY RP'ED 
      JMP PEREX 
* 
PER23 LDA .23       DUPLICATE PROGRAM NAME
      JMP PEREX 
* 
PER14 LDA .14       REQUIRED ID-SEGMENT NOT FOUND 
* 
PEREX JSB $LIBX     DONE! 
      DEF *+1 
      DEF EXIT1 
      SKP 
* 
*     EXIT
* 
ER19  LDA .19       CHECKSUM ERROR
      JMP EREX
* 
ER39  LDA .39       CANNOT RP PROGRAM 
      JMP EREX
* 
ER01  CCA           DISC ERROR
      JMP EREX
* 
ER11  LDA N11       FILE NOT OPEN TO PROGRAM
* 
EREX  CCE           ERROR EXIT E-REG = 1
* 
EXIT1 STA IERR,I    SAVE ERROR RETURN CODE
      JMP DRPL,I     AND RETURN 
      SKP 
* 
*  SETPT (SET UP POINTERS TO SHORT ID SEGMENT) - SETS UP POINTERS 
*  SID1,SID3,SID5,SID6,SID7,SID8 TO THE CORRESPONDING WORDS IN THE
*  CURRENT ID SEGMENT.  WILL WRITE OUT AND READ NEXT SECTOR IF
*  NECESSARY. 
* 
*  ON ENTRY IF INIT = -1, INITIALIZES SUBROUTINE AND CLEARS INIT. 
*  USES VARIBLES SECBF(128)   SECTOR BUFFER 
*                SEKTR        DISC ADDRESS TO READ
*                TRAK           WRITE TO
*                BK/TR        NUMBER OF BLOCKS/TRACK
* 
      IFN           *** L/10 CODE *** 
SETPT NOP 
* 
      ISZ INIT      IS THIS THE INITIALIZE CALL?
      RSS           NO, GO SET UP ID POINTERS 
      JMP REED      YES, GO READ SECTOR WITH SHORT ID SEGMENTS
* 
      LDA SID1      GET CURRENT SHORT ID POINTER
      ADA .8          AND POINT TO THE NEXT ID
      CPA ENDSB     AT THE END OF THE SECTOR? 
      JMP RITE        THEN WRITE IT OUT AND READ THE NEXT BLOCK 
* 
SET   STA SID1        ELSE, SAVE FOR WORD 1 
      ADA .2        ADD 2 FOR 
      STA SID3        WORD 3
      ADA .2        ADD 2 FOR 
      STA SID5        WORD 5
      INA           INCREMENT 
      STA SID6      FOR WORD 6
      INA           INCREMENT 
      STA SID7      FOR WORD 7
      INA           INCREMENT 
      STA SID8      FOR WORD 8
      JMP SETPT,I   EXIT
* 
RITE  JSB EXEC      WRITE OUT SECTOR CONTAINING UPDATED 
      DEF *+7         SHORT ID SEGMENTS 
      DEF .2        WRITE 
      DEF PDSLU     PROTECTED DISC LU 
      DEF SECBF     SECTOR BUFFER 
      DEF .128      WHOLE SECTOR
      DEF TRAK      DISC TRACK
      DEF SEKTR     DISC SECTOR 
* 
      CPB .128      CHECK FOR COMPLETE TRANSMISSION 
      RSS           OK, GO READ 
      JMP ER01      DISC ERROR, EXIT
* 
REED  LDA SEKTR     GET CURRENT SECTOR ADDRESS
      ADA .2        INCREMENT TO THE NEXT SECTOR (64 WORD)
      CPA F.S/T,I   OVERFLOW THIS TRACK?
      CLA,RSS       YES, SET SECTOR TO 0
      RSS           NO, SKIP TRACK INCREMENT
      ISZ TRAK      INCREMENT TRACK ADDRESS 
      STA SEKTR     SAVE SECTOR ADDRESS 
* 
      JSB EXEC      READ NEXT SECTOR FROM THE DISC
      DEF *+7         WHICH CONTAINS THE SHORT ID SEGMENTS
      DEF .1        READ
      DEF PDSLU     PROTECTED DISC LU 
DSCBF DEF SECBF     SECTOR BUFFER 
      DEF .128      WHOLE SECTOR
      DEF TRAK      DISC TRACK
      DEF SEKTR     DISC SECTOR 
* 
      CPB .128      CHECK FOR COMPLETE TRANSMISSION 
      RSS           OK
      JMP ER01      DISC ERROR, EXIT
* 
      LDA DSCBF     GET ADDRESS OF SECTOR BUFFER
      JMP SET         AND SET UP NEW POINTERS 
      XIF 
      SKP 
* 
*     BUMP - BUMP DISC POINTERS TO POINT AT THE VARIOUS MAINS, BASE PAGES,
*     AND SEGMENTS CONTAINED WITHIN A TYPE 6 FILE.
* 
*     CALLING SEQUENCE: 
* 
*     A = HIGH ADDRESS + 1
*     B = LOW ADDRESS 
*     JSB BUMP
*     A = BLOCK AND BLOCK = CURRENT BLOCK 
*     B = TRACK AND TRACK = CURRENT TRACK 
*                   BK/TR = BLOCKS/TRACK
* 
      IFN           *** L/10 CODE *** 
BUMP  NOP 
* 
      CMB,INB       SET THE LOW ADDRESS NEGATIVE
      ADA B         AND ADD TO HIGH ADDRESS.  A = PROGRAM SIZE
      CLB           CLEAR B FOR DIVIDE
      DIV .128      DIVIDE BY 128 GIVING NUMBER OF BLOCKS 
      SZB           IF REMAINDER IS NOT ZERO
      INA            THEN ADD ONE TO BLOCK COUNT FOR A PARTIAL BLOCK
      ADA BLOCK     ADD IN CURRENT BLOCK
      CLB           CLEAR B FOR DIVIDE
      DIV BK/TR     DIVIDE BY BLOCKS/TRACK
      STB BLOCK      SAVE REMAINDER AS CURRENT BLOCK
      ADA TRACK     ADD QUOTIENT TO TRACK ADDRESS 
      STA TRACK      SAVE AS CURRENT TRACK ADDRESS
      SWP           PUT BLOCK IN A, TRACK IN B
      JMP BUMP,I    RETURN
      XIF 
      SKP 
* 
*     STORAGE AREA
* 
ZERO  NOP           THIS ARRAY IS USED TO FIND
      NOP             A BLANK 
      NOP             ID SEGMENT
* 
N7    DEC -7
N8    DEC -8
N11   DEC -11 
N64   DEC -64 
N256  DEC -256
* 
.1    DEC 1 
.2    DEC 2 
.8    DEC 8 
.14   DEC 14
.16   DEC 16
.19   DEC 19
.23   DEC 23
.28   DEC 28
.39   DEC 39
.99   DEC 99
.128  DEC 128 
.??   DEC 23
* 
B77   OCT 77
B1777 OCT 1777
B4K   OCT 4000
B7700 OCT 7700
B170K OCT 170000
* 
NB400 OCT -400
* 
IDBIT OCT 2000
* 
* 
DZERO DEF ZERO
* 
      IFN           *** L/10 CODE *** 
TRACK NOP           (BUMP) TRACK ADDRESS
BLOCK NOP           (BUMP) BLOCK ADDRESS
* 
TRAK  NOP           (SETPT) TRACK ADDRESS 
SEKTR NOP           (SETPT) SECTOR ADDRESS
* 
BK/TR NOP           (BUMP) BLOCKS/TRACK FOR DISC 'LU' 
NEGMN NOP           NEGATIVE VALUE OF MAIN TRACK
HMNBP NOP           BASE PAGE HIGH ADDRESS
* 
SECBF BSS 128       SECTOR BUFFER 
ENDSB DEF *         END OF SECTOR BUFFER ADDRESS
* 
LPCNT NOP           LOOP COUNTER
TR    NOP           TEMPORARY TRACK WORD
* 
SID1  NOP           SHORT ID POINTER TO WORD 1
SID3  NOP           SHORT ID POINTER TO WORD 3
SID5  NOP           SHORT ID POINTER TO WORD 5
SID6  NOP           SHORT ID POINTER TO WORD 6
SID7  NOP           SHORT ID POINTER TO WORD 7
SID8  NOP           SHORT ID POINTER TO WORD 8
* 
INIT  NOP           (SETPT) INITIALIZATION FLAG 
      XIF 
* 
#MOVE NOP           USED BY SUM 
* 
IDSIZ ABS IDEND-IDBUF SKELETON IDBUFSEGMENT SIZE
NCKSM ABS IDBUF-CKSM1 NEGATIVE WORDS TO CHECKSUM
* 
PDSLU NOP           PROTECTED DISC LU 
* 
      IFN           *** L/10 CODE *** 
IDBUF BSS 30        - ID SEGMENT BUFFER 
CKSM  NOP           ! 
CKSM1 NOP           ! 
HISEG NOP           ! 
HIBP  NOP           - 
      XIF 
      IFZ           *** L/20 CODE *** 
IDBUF BSS 30        - 
HISEG NOP           ! 
HIBP  NOP           ! 
      NOP           ! 
CKSM  NOP           ! 
SCCK  NOP           ! 
CKSM1 NOP           - 
      XIF 
* 
ID    EQU IDBUF-1 
IDEND EQU * 
* 
A     EQU 0 
B     EQU 1 
* 
END   EQU * 
* 
      END 
                                                                                                                                                                                                                        