ASMB,R,Q,C
      HED "IDRP" FTN/SPL SUBR TO DO A FMGR ":RP,PROG" FROM ANY CART.
*     SOURCE: 92067-18561 
*     RELOC:  92067-16185 
*     PGMR:   D.L.B., D.C.L.
* 
*  ***************************************************************
*  * (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 IDRP,7 92067-16185 REV.2026 800305
* 
*  MODIFICATION RECORD: 
*       DATE      REASON       BY WHOM
* 1)    2-2-76    TO ADD PRIVILEDGE READ CODE TO EXEC CALL TO 
*                 THE DISC CALL TO THE FILE. (DLB)
* 2)   8-16-77    TO ZERO THE 5 TEMP WORDS IN THE RESTORED
*                 ID SEGMENT
* 3)  10-14-77    TO SUPPORT EXTENDED ID SEGMENT
* 4)    1-6-78    TO NOT USE DYNAMIC BASE PAGE WORDS IN CALCULATION 
*                 OF SYSTEM CHECKSUM (RTE-IV ONLY). (GLM) 
* 5)    4-3-78    CROSS-MAP ACCESS TO ID SEGMENTS FOR RTE-IV
*                 TYPE 4 PROGRAMS USING THIS ROUTINE
* 6)   5-31-78    TO PRESERVE WORD 32 OF NEW ID SEGMENT (BL)
* 7)   9-20-78    TO SET "I'M A COPY" FLAG (GLM)
* 8)   1-22-79    TO RETURN NEW IDSEG ADDR., TO PRESERVE DON'T COPY 
*                 FLAG, AND TO SKIP ERR 23 IF DISC ADDRESSES MATCH
* 9)   2-22-79    TO REMOVE ID SEGMENT IF EMA PGM AND NO ID EXTENSIONS
*                 ARE AVAILABLE 
* 10)  7-26-79    TO RESTORE TIME LIST WORD (WD 18)  SST #4429
* 11) 10-16-79    TO TEST IF PROTECTED TYPE 6 PGM BEFORE RESTORING
* 12) 12-19-79    TO :RP FROM ANY CARTRIDGE.  IF TYPE 6 NOT ON LU 
*                 2 OR 3 THEN COPY INTO POOL TRACKS (FAKE A TEMPORARY 
*                 PROGRAM LOAD).  THIS SUBROUTINE WAS MADE BY 
*                 MODIFYING THE 2001 REV. OF <IDRPL>.  (DCL)
* 13) 12-27-79    FIXED ORIGINAL BUG IN <IDRPL>.  DIDN'T SETUP
*                 "DON'T COPY" BIT IN IDSEG CORRECTLY.  (DCL) 
* 14)   3-5-80    CLEANED UP FOR RELEASE (DCL)
* 
* 
      SUP PRESS EXTRANEOUS LISTINGS 
* 
      ENT IDRP                                             791219 
      EXT EXEC,.ENTR,$LIBR,$LIBX,IDSGA,NAM..,$OPSY,$IDEX
      EXT .OWNR,$SMCA,$SMGP,$SMID,ISMVE,SESSN 
A     EQU 0 
B     EQU 1 
KEYWD EQU 1657B 
RTDRA EQU 1750B                                   780106 GLM
BGDRA EQU 1754B                                   780106 GLM
TATLG EQU 1755B                                   780106 GLM
TAT   EQU 1656B     TAT BASE ADDR                          791219 
TATSD EQU 1756B     # TRACKS ON LU2                        791219 
SECT2 EQU 1757B     # SECTORS/TRACK ON LU2                 791219 
SECT3 EQU 1760B     # SECTORS/TRACK ON LU3                 791219 
BPA1  EQU 1742B 
XEQT  EQU 1717B 
EQTA  EQU 1650B 
      SKP 
* 
*  PURPOSE: 
* 
*    TO ACCOMPLISH THE EQUIVALENT OF A FMGR ":RP,PROG" IN A SUBROUTINE. 
*    AND TO ALLOW THE TYPE 6 FILE TO RESIDE ON ANY CARTRIDGE. 
*    IF THE TYPE 6 FILE IS ON LU2 OR LU3 THEN AN ID SEGMENT IS
*    CONSTRUCTED WHICH POINTS DIRECTLY TO THE TYPE 6 FILE.
*    IF THE TYPE 6 FILE IS NOT ON LU2 OR LU3, THE PROGRAM IMAGE PART
*    OF THE FILE IS COPIED INTO SYSTEM POOL TRACKS AND AN ID SEGMENT
*    IS CONSTRUCTED WHICH POINTS TO THESE TRACKS.  (THIS SIMULATES
*    A TEMPORARY PROGRAM LOAD.) 
* 
*  CALLED:
* 
*     CALL IDRP (IDCB,IERR,NAME,IBUF,IBUFL,NID) 
*           -OR-
*     IF (IDRP (IDCB,IERR,NAME,IBUF,IBUFL,NID).NE.0) GO TO IERROR 
* 
*  WHERE: 
* 
*     IERR = RETURN ERROR CODE (SAME AS ERROR CODES IN FMGR)
*     IDCB = AN OPEN DCB OF THE TYPE 6 FILE 
*     NAME = 5 CHARACTER BUFFER OF THE PROGRAM NAME PUT IN ID SEGMENT 
*     IBUF = BUFFER FOR DISK TRANSFER IF FILE IS NOT ON LU2 OR LU3
*     IBUFL= LENGTH OF "IBUF" (MUST BE AT LEAST 64 WORDS, 
*            BUT SHOULD BE LARGE FOR EFFICIENT TRANSFERS) 
*     NID  = (OPTIONAL) RETURN ADDRESS OF NEW ID SEGMENT
* 
*  SKELETON ID:   (1ST 37 WORDS IN FILE)
* 
*  ID(1) = NOT USED, NOR CHANGED IN SYSTEM
*  ID(2) - ID(6) = XTEMP(1) - XTEMP(5) IN DEFAULT CASE. (I.E. '*RU,PROG') 
*  ID(7) = PRIORITY OF PROGRAM IF PROGRAM TYPE IS 2 OR 3, ELSE NOT USED 
*  ID(8) = ENTRY ADDRESS OF PROGRAM 
*  ID(9) - ID(12) = NOT USED (ID(11) 'XB' IS SET TO XTEMP(1)) 
*  ID(13) - ID(14) = NOT USED 
*  ID(15) = PROG TYPE BITS 0-3, BITS 4-15 NOT USED
*  ID(16) - ID(21) = NOT USED (ID(19),ID(20) = 25000B,177574B)
*  ID(18) = TIME PARAMETERS 
*  ID(22) = 0 IF RTE-II, ??? IF RTE-III. (SEE RTE-III MANUAL) 
*  ID(23) = LOW MAIN MEMORY LOAD ADDRESS
*  ID(24) = HI MAIN MEMORY LOAD ADDRESS + 1 
*  ID(25) = LOW BASE PAGE LOAD ADDRESS
*  ID(26) = HI BASE PAGE LOAD ADDRESS + 1 
*  ID(27) = DISC ADDR - LU(15),TRK(14-7),SECTOR(6-0)
*  ID(28) = NOT USED
*  ID(29) = EMA SIZE (BITS 0-9), ID EXT# (BITS 10-15) 
*  ID(30) = HI-ADDR + 1 OF LARGEST SEGMENT
*  ID(31) = 
*  ID(32) = 
*  ID(33) = 
*  ID(34) = ARITHMETIC SUM OF ID(1) THRU ID(33) 
*  ID(35) = SYSTEM SET UP CODE (SUM 1650-1657 + 1742-1764)
*  ID(36) = ID EXTENSION WORD 0 
*  ID(37) = ID EXTENSION WORD 1 
*  ID(39) = USER ID REQUIRED TO RUN OR RP IF SIGN BIT SET 
*  ID(40) = GROUP ID REQUIRED TO RUN OR RP IF SIGN BIT SET
*  ID(41) = CAPABILITY LEVEL REQUIRED TO RUN OR RP
* 
*  RETURN:
* 
*     IERR =   0 > SUCCESSFUL INSTALLATION OF ID SEGMENT INTO SYSTEM
*     E-REG =  1 IF ERROR, ELSE E-REG =  0 (FOR SPL FRETURN)
*     IERR =  -1 > DISC ERROR 
*     IERR = -11 > IDCB NOT OPEN
*     IERR =  14 > NO BLANK ID SEGMENTS OR EXTENSIONS AVAILABLE 
*     IERR = -15 > ILLEGAL NAME 
*     IERR =  16 > FILE NOT ON DISC LU =  2 OR LU =  3
*                   AND INSUFFICIENT SYSTEM POOL TRACKS 
*                   AVAILABLE FOR COPY
*     IERR =  19 > ID(34),ID(35) WORDS DID NOT CHECKSUM CORRECTLY.
*     IERR =  23 > DUPLICATE PROGRAM NAME.
*     IERR =  75 > TYPE 6 PGM IS PROTECTED ON USER ID 
*     IERR =  76 > TYPE 6 PGM IS PROTECTED ON GROUP ID
*     IERR =  77 > TYPE 6 PGM IS PROTECTED ON CAPABILITY LEVEL
*     IERR =  78 > IBUFL < 64 WORDS OR INTERNAL CONSISTENCY 
*                  CHECKS HAVE FAILED.  CAN'T RP PROGRAM. 
* 
*  NOTES: 
* 
*    (1)  A-REG = IERR ON RETURN, THEREFORE MAY BE USED AS FUNCTION 
*    (2)  IDRP  DOES NOT CLOSE THE FILE.
*    (3)  RECOMMEND FILE BE NON-EXCLUSIVELY OPENED
*    (4)  E-REG = 1, IF ERROR, E=0, IF NO ERROR(FOR SPL)
*    (5)  ONLY THE 1ST 10 WORDS OF THE DCB ARE USED BY THIS SUBROUTINE. 
* 
*  TEST PROGRAM:
*FTN,L
*      PROGRAM TYRP(2,99) 
*      DIMENSION NAME(3),LU(5),NUNAM(3),IDCB(144),IBUF(6144)
*      DATA IBUFL/6144/ 
*      CALL RMPAR(LU) 
*      IF (LU.EQ.0) LU = 1
*    1 WRITE (LU,11)
*   11 FORMAT ("INPUT PROGRAM FILE NAME? _")
*      READ (LU,12) NAME
*      IF (NAME.EQ.2H/E) GO TO 9999 
*      WRITE (LU,13)
*   13 FORMAT ("INPUT NEW NAME FOR PROG? _")
*      READ (LU,12) NUNAM 
*      IF (NUNAM.EQ.2H/E) GO TO 9999
*   12 FORMAT (3A2) 
*      IF(OPEN(IDCB,IERR,NAME,1).LT.0) GO TO 33 
*      IF(IDRP(IDCB,IERR,NUNAM,IBUF,IBUFL).EQ.0) GO TO 9999 
*   33 WRITE (LU,46) IERR 
*   46 FORMAT ("FMGR ERROR "I3) 
*      GO TO 1
* 9999 END
*      END$ 
      SKP 
IDCB  NOP           OPEN DCB ADDRESS
IERR  NOP           RETURNED ERROR CODE 
NAME  NOP           FIVE CHAR ASCII NAME TO GIVE PROGRAM
IBUF  NOP           DISK TRANSFER BUFFER                   791219 
IBUFL NOP           DISK TRANSFER BUFFER LENGTH            791219 
NID   NOP           ADDRESS OF NEW ID SEGMENT 
* 
IDRP  NOP           ENTRY 
      JSB .ENTR 
      DEF IDCB
* 
      CCA           SET FLAG TO INDICATE                   791219 
      STA ITRAK       NO POOL TRACKS ALLOCATED YET         791219 
* 
      LDA IDCB,I    GET TRACK-LU WORD FROM DCB
      LDB IDCB      CALCULATE FILE TRACK/SECTOR WORD
      ADB O3        ADDRESSES 
      STB DCB3
      INB 
      STB DCB4      AND SET INTO EXEC CALL
      ADB O4        BUMP TO SECT/TRACK WORD 
      STB DCB8      AND SAVE IDCB(9) ADDRESS               791219 
      CCE,INB       PREPARE E-REG IN CASE OF ERROR
      LDB B,I       GET OPEN FLAG 
      CPB XEQT      DCB OPEN? 
      RSS           YES, CHECK DISC LU
      JMP ERR11     NO, ERROR -11 
      AND O77       MASK TO JUST LU OF DISC 
      STA DLU       SAVE DISK LU #                         791219 
      IOR PRC       MERGE IN PRIVILEDGED CODE 
      STA FDLU      SAVE FOR EXEC CALL                     791219 
      AND O77       TAKE IT OUT 
      CLE,ERA       SAVE LU=2 OR LU=3 FLAG IN E-REG 
      CPA O1        CHECK IF EQUAL TO 2 OR 3? 
      ERA,SLA       YES, PUT FLAG IN BIT 15 & SKIP
      CLA           NO, FILE NOT ON LU 2 OR 3 <IGNORE>     791219 
      STA TEMP1     SAVE DISC LU FOR LATER USE
      JSB EXEC      READ 1ST 41 WORDS OF FILE 
      DEF *+7 
      DEF O1        READ
      DEF FDLU      DISC LU                                791219 
DEFID DEF IDBUF     DESTINATION BUFFER ADDRESS
      DEF D41       BUFFER LENGTH 
DCB3  DEF *         DISC TRACK
DCB4  DEF *         DISK SECTOR 
      CLA,CCE 
      JSB SUM       CALCULATE CHECKSUM
      DEF IDBUF     OF THE 1ST 33 WORDS OF FILE 
      DEC -33 
      CPA ID+34     EQUAL TO WORD 34? 
      CLA,RSS       YES 
      JMP ERR19     NO
      JSB SUM       1650B TO 1657B
      DEF EQTA
      DEC -8
      JSB SUM       1742B TO 1747B                780106 GLM
      DEF BPA1                                    780106 GLM
      OCT -6                                      780106 GLM
      JSB SUM       1755B TO 1764B                780106 GLM
      DEF TATLG                                   780106 GLM
      DEC -8                                      780106 GLM
* 
* IF NOT RTE-IV, WE MUST INCLUDE LOCATIONS 1750B TO 1754B.  780106 GLM
* 
      LDB $OPSY     FETCH SYSTEM                  780106 GLM
      CPB M9        IF RTE-IV                     780106 GLM
      JMP IDOK?              THEN JUST CHECK IT.  780106 GLM
* 
      JSB SUM                                     780106 GLM
      DEF RTDRA     INCLUDE 1750B TO 1754B (RTE-II&III ONLY)780106 GLM
      OCT -5                                      780106 GLM
* 
IDOK? CPA ID+35     COMPARE?
      JMP DORP      YES, CONTINUE 
ERR19 LDA D19       NO, FMGR ERROR 19 
      JMP EREXT 
ERR01 CCA           DISK ERROR                             800305 
      JMP EREXT                                            800305 
ERR75 LDA D75       TYPE 6 PGM IS PROTECTED ON USER ID
      JMP EREXT 
ERR76 LDA D76       TYPE 6 PGM IS PROTECTED ON GROUP ID 
      JMP EREXT 
ERR77 LDA D77       TYPE 6 PGM IS PROTECTED ON CAPABILITY LEVEL 
      JMP EREXT 
ERR78 LDA D78       INTERNAL CONSISTENCY CHECK FAILED      800305 
      JMP EREXT                                            800305 
ERR11 LDA D11 
      CMA,INA,RSS   MAKE NEGATIVE 
ERR16 LDA O20       GET DEC 16
EREXT CCE           ERROR EXIT E-REG = 1
EXIT  STA IERR,I    TELL CALLER RETURN CODE 
* 
      STA TEMP1     SAVE A-REG                             791219 
      ELA                                                  791219 
      STA TEMP2     SAVE E-REG                             791219 
* 
*  RELEASE ANY TRACKS THIS SUBROUTINE HAS ALLOCATED 
*  WHICH IS STILL OWNS. 
* 
      LDA ITRAK     LOAD TRACK ALLOCATE FLAG               791219 
      SSA           TRACKS ALLOCATED?                      791219 
      JMP .L2       -NO                                    791219 
* 
      JSB EXEC      RELEASE TRACKS                         791219 
       DEF *+1+4                                           791219 
       DEF O5                                              791219 
       DEF NTRAK                                           791219 
       DEF ITRAK                                           791219 
       DEF IDISC                                           791219 
* 
.L2   LDA TEMP2                                            791219 
      ERA           RESTORE E-REG                          791219 
      LDA TEMP1     RESTORE A-REG                          791219 
* 
      CLB 
      STB NID       CLEAR OPTIONAL PARAMETER
      JMP IDRP,I    RETURN IERR = A-REG 
      SPC 1 
DORP  LDA $OPSY     OP SYSTEM IDENTIFIER           *780403* 
      ERA           MOVE MAPPED BIT FOR SLA        *780403* 
      STA STYPE     SAVE FOR LOADA,STORA ROUTINES  *780403* 
      LDA DCB3,I    GET START TRACK NUMBER         *780403* 
      LSL 7         PUT IN BITS 7-14 OF A-REG 
      LDB DCB4,I    GET STARTING SECTOR NUMBER
      ADB O2        BUMP TO SECOND BLOCK OF FILE
      CPB DCB8,I    CHECK IF TRACK CROSSING?(IDCB(9))      791219 
      LDB O200      YES, BUMP TRACK>SET SECTOR=0
      ADA B         MERGE SECTOR OR BUMP TRACK
      IOR TEMP1     MERGE IN DISC LU
      STA ID+27     PUT IN THE SKELETON IDSEG 
      SPC 1 
      LDA ID+18     GET TIME LIST WORD
      STA DEFTM+3   SAVE IT 
      LDA ID+15     GET PROGRAM TYPE
      AND O7        MASK DOWN TO 2,3 OR 5 
      STA ID+1
      SPC 1 
      LDB D99       SET PRIORITY TO 99 IF 
      CPA O5        PROGRAM IS TYPE 5 
      STB ID+7
      SPC 1 
*  CHECK THAT NAME IS AS LEGAL AS A FILE NAME 
      SPC 1 
      JSB NAM..     USE FMP NAME CHECKING ROUTINE 
      DEF *+2 
      DEF NAME,I
      SZA           NAME OK?
      JMP EREXT     NO, FMGR ERROR -15
      SPC 1 
*  THE FOLLOWING CODE TESTS WHETHER THE TYPE 6 PROGRAM IS PROTECTED 
*  BY A USER ID, A GROUP ID, OR BY A MINIMUM CAPABILITY LEVEL 
      SPC 1 
      JSB SESSN     CHECK IF IN SESSION 
      DEF *+2 
      DEF XEQT      ID SEGMENT ADDRESS
      SEZ           IN SESSION (E=0)? 
      JMP PRIV      NO, SO SKIP TESTS 
      SPC 1 
      STB SESWD     SAVE ID SEGMENT SESSION WORD
      JSB ISMVE     GET USER ID FROM SESSION CONTROL BLOCK
      DEF *+5 
      DEF SESWD     ID SEGMENT SESSION WORD 
      DEF $SMID     SCB OFFSET TO USER ID 
      DEF TEMP      RETURN CALLER'S USER ID 
      DEF O1        ONE WORD
      LDA TEMP      CHECK CALLER'S USER ID
      CPA O7777     SYSTEM MANAGER? 
      JMP PRIV      YES, SO ALLOW RP
      SPC 1 
      LDA ID+39     GET USER ID FROM TYPE 6 FILE, WORD 39 
      ELA           ISOLATE SIGN BIT (SET MEANS USER ID MUST MATCH) 
      SEZ,RSS       SIGN BIT SET? 
      JMP GTGID     NO, NOT PROTECTED ON USER ID
      SPC 1 
      CLE,ERA       CLEAR SIGN BIT FROM USER ID WORD
      CPA TEMP      DOES USER ID REQUIRED MATCH CALLER'S USER ID? 
      JMP GTCAP     YES, NOW CHECK IF MINIMUM CAPABILITY REQUIRED 
      JMP ERR75     NO, ERROR - TYPE 6 PGM PROTECTED BY USER ID 
      SPC 1 
GTGID LDA ID+40     GET GROUP ID FROM TYPE 6 FILE, WORD 40
      ELA           ISOLATE SIGN BIT (SET MEANS GROUP ID MUST MATCH)
      SEZ,RSS       SIGN BIT SET? 
      JMP GTCAP     NO, NOT PROTECTED ON GROUP ID 
      SPC 1 
      JSB ISMVE     GET GROUP ID FROM SESSION CONTROL BLOCK 
      DEF *+5 
      DEF SESWD     ID SEGMENT SESSION WORD 
      DEF $SMGP     SCB OFFSET TO GROUP ID
      DEF TEMP      RETURN CALLER'S GROUP ID
      DEF O1        ONE WORD
      LDA ID+40     GET GROUP ID FROM TYPE 6 FILE 
      ELA,CLE,ERA   CLEAR SIGN BIT
      CPA TEMP      DOES GROUP ID REQUIRED MATCH CALLER'S GROUP ID? 
      RSS           YES, NOW CHECK IF MINIMUM CAPABILITY REQUIRED 
      JMP ERR76     NO, ERROR - TYPE 6 PGM PROTECTED BY GROUP ID
      SPC 1 
GTCAP JSB ISMVE     GET CAPABILITY FROM SESSION CONTROL BLOCK 
      DEF *+5 
      DEF SESWD     ID SEGMENT SESSION WORD 
      DEF $SMCA     SCB OFFSET TO CAPABILITY
      DEF TEMP      RETURN CALLER'S CAPABILITY
      DEF O1        ONE WORD
      LDA TEMP      USER'S CAPABILITY LEVEL 
      CMA 
      ADA ID+41 
      SSA,RSS       CALLER'S CAPABILITY GREATER OR EQUAL? 
      JMP ERR77     NO, ERROR - INSUFFICIENT CAPABILITY 
      SPC 1 
*  GO PRIVILEDGED TO PREVENT CONFLICTS WITH OTHER PROGRAMS OF DIFFERENT 
*  PRIORITY USING THIS SUBROUTINE.
      SPC 1 
* IF TYPE 6 FILE IS ON LU2 OR LU3 THEN SKIP SPECIAL PROCESSING
* 
PRIV  LDA DLU       A = DISK LU OF TYPE 6 FILE             791219 
      CPA O2        IF DISK LU = 2                         791219 
      RSS             OR                                   791219 
      CPA O3        IF DISK LU = 3                         791219 
      JMP PRIV2       THEN SKIP SPECIAL PROCESSING         791219 
* 
      JSB $LIBR     GO PRIVILEDGED TO PREVENT 
      NOP           CONFLICTS WITH OTHER ROUTINE USING SAME SUB 
      SPC 1 
      JSB FIDSG     CHECK ID SEG AVAILABILITY              791219 
      RSS           -MAYBE ALREADY RP'D                    791219 
      JMP COPYF     -ID SEG IS AVAILABLE                   791219 
* 
* AT THIS POINT EITHER: 
* 
* 1) (A=23, E=1)  THERE EXISTS AN ID SEGMENT WITH THE SAME
*    NAME, BUT WHOSE DISK ADDRESS WORD DOES NOT POINT TO OUR
*    TYPE 6 FILE. 
*       => RETURN FMGR ERROR 23:  DUPLICATE PROGRAM NAME
* 
* 2) (A=E=0)  THERE EXISTS AN ID SEGMENT WITH THE SAME NAME 
*    AND WHOSE DISK ADDRESS WORD SEEMS TO POINT TO OUR TYPE 6 
*    FILE.
*       IF TYPE 6 FILE IS ON LU2 OR LU3 THEN THIS FILE IS 
*          ALREADY RP'D.
*          =>  RETURN SUCCESS 
*       ELSE DISK ADDRESS WORD CAN'T POINT TO OUR TYPE 6 FILE.
*          =>  RETURN FMGR ERROR 23:  DUPLICATE PROGRAM NAME
* 
      LDB DLU       B = DISK LU OF FILE                    791219 
      SZA,RSS       IF A = NON-ZERO ERROR THEN DO ERROR RETURN  791219
      CPB O2        FILE ON LU2 ?                          791219 
      RSS             OR                                   791219 
      CPB O3        IS FILE ON LU3 ?                       791219 
      JMP PEXIT     -YES, RETURN A & E = STATUS            791219 
* 
* TYPE 6 FILE NOT ON LU2 OR LU3, => DUPLICATE PROGRAM NAME
* 
      LDA D23       A = ERROR = 23                         791219 
      CCE           E = ERROR = 1                          791219 
      JMP PEXIT     RETURN                                 791219 
* 
* 
* WE'RE GOING TO COPY THE PROGRAM IMAGE PART OF THE TYPE 6 FILE 
* INTO SYSTEM POOL TRACKS TO MAKE IT LOOK LIKE A TEMPORARY LOAD.
* 
* 
* COMPUTE MINIMUM NUMBER OF SECTORS PER TRACK ON TRACK POOL DISKS 
* BECAUSE WE DON'T KNOW WHICH DISK OUR POOL TRACKS WILL COME FROM.
* 
COPYF JSB $LIBX     GO UNPRIVILEDGED                       791219 
       DEF *+1                                             791219 
       DEF *+1                                             791219 
* 
      LDA SECT2     A = # SECTORS/TRACK ON LU2             791219 
      STA SECTR     SAVE AS DEFAULT MINIMUM                791219 
* 
      CMA,INA       CALCULATE DIFFERENCE BETWEEN           791219 
      ADA SECT3       LU2 & LU3 SECTORS/TRACK              791219 
      LDB SECT3                                            791219 
      SZB,RSS       IS THERE AN LU3?                       791219 
      JMP .L1       -NO                                    791219 
      SSA           FEWER SECTORS/TRACK ON LU3 ?           791219 
      STB SECTR     -YES, SET NEW MINIMUM                  791219 
* 
.L1   EQU *                                                791219 
* 
* USE MINIMUM NUMBER OF SECTORS/TRACK TO CALCULATE HOW MANY 
* TRACKS TO ASK FOR, = (FILE SIZE) - (2 SECTORS OF DCB INFO)
* 
*   ***** ASSUME FILE IS NOT AN "EXTENDED FILE" ***** 
*   ***** WHOSE FILE SIZE IS IN "CHUNKS".       ***** 
* 
      LDA IDCB                                             791219 
      ADA O5        CALCULATE ADDR OF IDCB(6)              791219 
* 
      LDA A,I       A = FILE SIZE (SECTORS)                791219 
      ADA M2        IGNORE DCB INFO SECTORS                791219 
      STA PSIZE     SAVE PROGRAM SIZE (SECTORS)            791219 
* 
      CLB           (B = 0 FOR DIVISION)                   791219 
      DIV SECTR     CALCULATE MAX # TRACKS REQUIRED        791219 
      SZB           PARTIAL TRACK?                         791219 
      INA           -YES, ROUND UP                         791219 
      IOR O1S       SET NO WAIT BIT                        791219 
      STA NTRAK     SAVE FOR ALLOCATION CALL               791219 
* 
* ALLOCATE POOL TRACKS
*   (ALLOCATE LOCALLY FOR NOW IN CASE WE'RE ABORTED)
* 
      JSB EXEC      REQUEST TRACKS                         791219 
       DEF *+1+5                                           791219 
       DEF O4                                              791219 
       DEF NTRAK     (# TRACKS REQUESTED)                  791219 
       DEF ITRAK     (RETURNED STARTING TRACK ADDR)        791219 
       DEF IDISC     (RETURNED DISK LU #)                  791219 
       DEF ISETR     (RETURNED # SECTORS/TRACK)            791219 
* 
      LDA ITRAK                                            791219 
      SSA           DID I GET TRACKS?                      791219 
      JMP ERR16     -NO, ERROR RETURN                      791219 
* 
      LDA NTRAK     LOAD # TRACKS REQUESTED                791219 
      AND MASK      CLEAR SIGN (NO ABORT) BIT              791219 
      STA NTRAK     SAVE # TRACKS RECEIVED                 791219 
* 
* RETURN ANY UNNEEDED DISK SPACE
* 
      LDA PSIZE     A = PROGRAM SIZE (SECTORS)             791219 
      CLB           (B = 0 FOR DIVISION)                   791219 
      DIV ISETR     CALCULATE # TRACKS ACTUALLY REQUIRED   791219 
      SZB           PARTIAL TRACK?                         791219 
      INA           -YES, ROUND UP                         791219 
      STA TEMP1     SAVE FOR LATER                         791219 
* 
      CMA,INA       NEGATE                                 791219 
      ADA NTRAK     A = # EXTRA TRACKS RECEIVED            791219 
      SZA,RSS       EXTRA TRACKS?                          791219 
      JMP NRLSE     -NO, SO DON'T RETURN ANY               791219 
* 
      SSA           IF # EXTRA TRACKS < 0                  800305 
      JMP ERR78       THEN NOT ENOUGH TRACKS ?!?!          800305 
* 
      STA NTRAK     SAVE # EXTRA TRACKS                    791219 
* 
      LDA TEMP1     A = # TRACKS ACTUALLY NEEDED           791219 
      ADA ITRAK     CALCULATE STARTING TRACK TO RETURN     791219 
      STA TEMP2     SAVE FOR SYSTEM CALL                   791219 
* 
      JSB EXEC      RETURN THE EXTRA TRACKS                791219 
       DEF *+1+4                                           791219 
       DEF O5                                              791219 
       DEF NTRAK                                           791219 
       DEF TEMP2                                           791219 
       DEF IDISC                                           791219 
* 
      LDA TEMP1     LOAD ACTUAL # OF TRACKS TO USE         791219 
      STA NTRAK     SAVE                                   791219 
* 
NRLSE EQU * 
* 
* 
* 
* UPDATE SKELETON ID SEGMENT DISK ADDRESS WORD
* TO POINT TO POOL TRACKS.
* 
* 
* CONSTRUCT DISK LU PART OF ADDRESS WORD (SIGN BIT) 
* 
      CCA           A = -1 (FOR PARANOID CHECK)            791219 
      LDB IDISC     B = POOL TRACK DISK LU                 791219 
* 
      CPB O2        LU2 ?                                  791219 
      CLA           -YES, CLEAR SIGN BIT                   791219 
* 
      CPB O3        LU3 ?                                  791219 
      LDA O1S       -YES, SET SIGN BIT                     791219 
* 
      SLA           PARANOID CHECK: LU2 OR LU3 ?           791219 
      JMP ERR78     -NO, BARF                              800305 
* 
* INCLUDE TRACK ADDR IN BITS 14-7 
* (SECTOR ADDR = 0 IN BITS 6-0) 
* 
      LSR 7         POSITION                               791219 
      IOR ITRAK     INCLUDE TRACK ADDR                     791219 
      LSL 7         POSITION BACK                          791219 
      STA ID+27     SET INTO SKELETON ID SEGMENT           791219 
* 
* 
* 
* COPY THE PROGRAM IMAGE FROM THE TYPE 6 FILE INTO
* THE SYSTEM POOL TRACKS. 
* 
* (IGNORE THE FIRST TWO SECTORS OF THE FILE WHICH 
*  CONTAIN ID SEGMENT INFORMATION.) 
* 
* 
* 
* SETUP SOURCE PARAMETER ARRAY FOR SUBROUTINE <ZXFER> 
* 
      LDB DCB3,I    LOAD FILE TRACK ADDR                   791219 
      STB .TRKI     SAVE                                   800305 
* 
      LDA DCB4,I    LOAD FILE SECTOR ADDR                  791219 
      ADA O2        SKIP ID SEG INFO                       791219 
      STA .SECI     SAVE                                   800305 
* 
      CPA DCB8,I    TRACK CROSSING?                        791219 
      RSS           -YES                                   791219 
      JMP NOCRS     -NO                                    791219 
* 
      ISZ .TRKI     INCREMENT TRACK ADDRESS                800305 
      CLA           ZERO THE                               791219 
      STA .SECI       SECTOR ADDRESS                       800305 
* 
NOCRS EQU *                                                800305 
* 
* SETUP DESTINATION PARAMETER ARRAY FOR SUBROUTINE <ZXFER>
* 
      LDA ITRAK                                            791219 
      STA .TRKO     TRACK ADDRESS                          800305 
* 
      CLA                                                  791219 
      STA .SECO     SECTOR ADDRESS                         800305 
* 
* SET UP OTHER INFO FOR SUBROUTINE <ZXFER>
* 
      LDA PSIZE     GET PROGRAM SIZE (SECTORS)             791219 
      STA .NSCI     SAVE AS COPY SIZES                     800305 
      STA .NSCO                                            800305 
* 
* CALL SUBROUTINE <ZXFER> TO DO THE TRANSFER
* 
FILOP JSB ZXFER     READ FROM FILE                         800305 
       DEF *+1+8                                           800305 
       DEF O1       (1:READ  2:WRITE)                      800305 
       DEF FDLU     (DISK LU)                              791219 
       DEF IBUF,I   (BUFFER)                               791219 
       DEF IBUFL,I  (BUFFER LENGTH)                        791219 
       DEF .TRKI    (TRACK ADDRESS)                        800305 
       DEF .SECI    (SECTOR ADDRESS)                       800305 
       DEF .NSCI    (# SECTORS TO COPY)                    800305 
       DEF DCB8,I   (# SECTORS PER TRACK)                  791219 
* 
      JSB ZXFER     WRITE TO POOL TRACKS                   800305 
       DEF *+1+8                                           800305 
       DEF O2                                              800305 
       DEF IDISC                                           791219 
       DEF IBUF,I                                          791219 
       DEF IBUFL,I                                         791219 
       DEF .TRKO                                           800305 
       DEF .SECO                                           800305 
       DEF .NSCO                                           800305 
       DEF ISETR                                           791219 
* 
*  IF NOT DONE WITH COPY THEN LOOP
* 
      LDA .NSCO     LOAD # SECTORS LEFT TO COPY            800305 
      SZA           DONE ?                                 800305 
      JMP FILOP     -NO, LOOP                              800305 
* 
* 
* 
* GET ID SEGMENT AND SETUP TO POINT TO FILE OR POOL TRACKS
* 
PRIV2 JSB $LIBR     GO PRIVILEDGED TO PREVENT              791219 
      NOP             CONFLICTS WITH OTHER ROUTINES        791219 
* 
      JSB FIDSG     CHECK ID SEG AVAILABILITY:             791219 
      JMP PEXIT     -ALREADY RP'D                          791219 
* 
      LDB ID+29     GET ID SEG EMA WORD                    800305 
      LDA $OPSY     GET OP SYSTEM IDENTIFIER               800305 
* 
      CPA M9        IF RTE-IV                              800305 
      SZB,RSS         AND PROGRAM USES EMA                 800305 
      RSS               THEN                               800305 
      JSB FIDEX           GET AN ID SEG EXTENSION          800305 
* 
* WE GOT AN ID SEGMENT, LET'S GO... 
* 
* FIRST, IF WE COPIED THE FILE INTO SYSTEM POOL TRACKS, 
* WE MUST ASSIGN OWNERSHIP OF THE TRACKS TO THE SYSTEM
* SO THAT THIS WHOLE THING LOOKS JUST LIKE A TEMPORARY
* PROGRAM LOAD.  TO DO THIS WE MODIFY THE TAT (TRACK
* ASSIGNMENT TABLE) WHILE IN PRIVILEDGED MODE.
* 
      LDA B1000     INITIALIZE THE                         791219 
      STA CPY         "I'M A COPY" BIT FLAG                791219 
* 
      LDA ITRAK     LOAD POOL TRACK ADDRESS                791219 
      SSA           WERE POOL TRACKS ALLOCATED?            791219 
      JMP TRDON     -NO, SKIP SPECIAL PROCESSING           791219 
* 
* CALCULATE INDEX INTO TAT
* 
      CLB           OFFSET = 0                             791219 
      LDA IDISC     A = POOL TRACK DISK LU                 791219 
      CPA O3        LU3 ?                                  791219 
      LDB TATSD     -YES, OFFSET = # TRACKS ON LU2         791219 
      ADB TAT       ADD TAT BASE ADDR                      791219 
      ADB ITRAK     ADD STARTING TRACK NUMBER              791219 
* 
*  CHANGE OWNERSHIP OF TRACKS IN TAT
* 
      LDA NTRAK     LOAD # TRACKS                          791219 
      CMA,INA       NEGATE                                 791219 
      STA TEMP2     SAVE FOR LOOP COUNTER                  791219 
* 
      LDA O1S       A = SYSTEM OWNERSHIP FLAG              791219 
* 
TROWN JSB STORA     CHANGE TAT OWNERSHIP FOR A TRACK       791219 
      INB           INCREMENT TAT ADDR                     791219 
      ISZ TEMP2     DONE WITH TRACKS?                      791219 
      JMP TROWN     -NO, LOOP                              791219 
* 
      CCA           SET FLAG TO INDICATE WE NO             791219 
      STA ITRAK       LONGER HAVE TRACKS ALLOCATED         791219 
* 
      CLA           CLEAR THE "I'M A COPY" FLAG SO THAT    791219 
      STA CPY         TRACKS WILL BE RELEASED ON PROG :OF  791219 
* 
TRDON EQU * 
* 
* 
      SPC 1 
*  FOUND BLANK IDSEG, SET IT UP 
      SPC 1 
      LDA DID32,I   GET IDSEG WORD32                      *791227 
      AND B2000     EXTRACT DON'T COPY BIT                *791227 
      STA NOCPY     SAVE IT                               *791227 
* 
      JSB .OWNR     FETCH THE OWNER ID             *780920* 
      IOR CPY       AND SET "I'M A COPY" FLAG      *780920*791219 
      STA OWID      SAVE FOR ID BUILD              *780920* 
      LDB ID+17     GET IDSEG(1) ADDRESS           *780403* 
      JSB LOADA                                    *780403* 
      STA B                                        *780403* 
      STA NID,I     SAVE ADDRESS OF NEW ID SEGMENT
      LDA TEMP      RESTORE TRACK INDICATOR        *780403* 
      CLE,SZA       NOW MOVE INTO SYSTEM
      JMP SHOR1     SHORT ID, SKIP SOME OF MOVE 
      CCE,INB       BUMP TO XTEMP 
      STB ID+11     SET UP XB WORD
      LDA DEFZ      ZERO THE 5 XTEMP WORDS
      JSB MOVE      MOVE TO THE BLANK ID SEG. 
      OCT 5 
      LDA DEFID     GET BUFFER
      ADA D6        OFFSET TO 7TH WORD
      LDA A,I       GET CONTENTS AND
      JSB STORA     RESTORE TO BLANK ID SEG.       *780403* 
      INB           BUMP DESTINATION ADDRESS
      ISZ ID+18 
      SPC 1 
*  E-REG = 0 FOR LONG ID, E-REG=1 FOR SHORT ID
      SPC 1 
      RSS 
SHOR1 ADB D11       CORRECT FOR SHORT ID
      LDA ID+8      GET PROGRAM ENTRY POINT ADDRESS 
      JSB STORA     AND PUT                        *780403* 
      SEZ,INB,RSS   BUMP TO ID(9) IF LONG 
      JMP SHOR2     YES, SHORT ID 
      LDA DID9      GET DEF TO ID(9)
      JSB MOVE      MOVE ID(9) TO ID(12)
O4    OCT 4 
SHOR2 STB ADNAM     SAVE ADDRESS OF IDSEG WORD 13 (NAME)
      LDA NAME      GET NAME(1) 
      JSB MOVE      MOVE NAME(1),NAME(2)
O2    OCT 2 
      LDA ID+18,I   GET NAME(3) 
      AND OM400     MASK OFF 6TH CHAR 
      XOR ID+15     MERGE IN PROGRAM TYPE 
      AND OM20      MASK OFF BITS 4-15
      XOR ID+15 
      IOR O200      PUT IN TEMP BIT 
      SEZ,RSS       CHECK IF SHORT ID BIT 
      IOR O20       PUT IN SHORT ID IF SHORT
      JSB STORA     STORE ID(15)                   *780403* 
      SEZ,INB,RSS   ZERO OUT ID(16),ID(17)
      JMP SHOR3     SKIP IF SHORT ID
      LDA DEFTM     MOVE SIX WORDS
      JSB MOVE      INTO IDSEG(16) - IDSEG(21)
D6    DEC 6 
      LDA ID+22     GET THE RTE-III THING 
      JSB STORA     IDSG(22)! CALLER BETTER KNOW P'S,Q'S *"*
      INB           POINT ID(23)
SHOR3 LDA DID23     GET ADDRESS OF LOW MAIN ADDRESS 
      JSB MOVE      A-REG = SOURCE ADDRESS, B-REG=DEST
O5    OCT 5         NUMBER OF WORDS TO MOVE 
      CLA,SEZ,CCE,RSS  IF SHORT ID (E=0), 
      JMP ERR14          THEN DONE
      JSB STORA     ZERO ID(28) FOR LONG ID        *780403* 
* 
*  CHECK PROGRAM TYPE (SAVED IN ID+1). IF PROGRAM SEGMENT 
*  (TYPE = 5), SKIP THE ID EXTENSION WORK.         *780407* 
* 
      LDA ID+1      FETCH PROG TYPE                *780407* 
      CPA O5        IF SEGMENT,                    *780407* 
      JMP CNT.5       SKIP ID EXT WORK             *780407* 
* 
      SPC 1 
      LDA $OPSY     OP SYSTEM IDENTIFIER
      CPA M9        RTE-IV? 
      JMP CONT1     YES, SAVE RTE-IV WORDS
CNT.5 CLA           RESET A  (E=1 !!!)
      JMP ERR14     EXIT
CONT1 INB           POINT TO ID(29) 
      STB NEWID     SAVE DESTINATION ADDRESS
* 
      LDA ID+29     GET ID SEG EMA WORD                    800305 
      SZA,RSS       PROGRAM USES EMA ?                     800305 
      JMP NOEMA     -NO, EMA WORD IS ZERO 
* 
*  PROGRAM USES EMA.  SETUP THE ID SEG EXTENSION
* 
      LDA INDX      GET FOUND ID SEG EXT #                 800305 
      CLB                                          *780403* 
      RRR 6         RESTORE ID EXT# TO HIGH 6 BITS *780403* 
*                                                  *780403* 
      LDA DID29,I   GET ID SEGMENT EMA WORD 
      AND O1777     MASK OFF HIGH 6 BITS
      IOR B         MERGE TO CREATE NEW EMA WORD
      LDB NEWID                                    *780403* 
      JSB STORA     RESTORE TO NEW ID SEGMENT (29) *780403* 
      ISZ NEWID     BUMP DESTINATION ADDRESS
      LDA DID36     RESTORE ID EXTENSION WORDS
      LDA A,I       GET SAVED ID EXT WORD 0        *780403* 
      LDB IDEXT                                    *780403* 
      JSB STORA     SAVE IN NEW ID EXT WORD 0      *780403* 
      INB           BUMP TO NEXT WORD OF NEW ID EXT *780403*
      LDA DID36                                    *780403* 
      INA           POINT TO ID(37) 
      LDA A,I       GET SAVED ID EXT WORD 1        *780403* 
      JSB STORA     SAVE IN NEW ID EXT WORD 1      *780403* 
      INB           BUMP TO WORD 2 OF NEW ID EXT   *780403* 
      CLA                                          *780403* 
      JSB STORA     ZERO NEW ID EXT WORD 2         *780403* 
      LDB NEWID     SET UP ID30 ADDRESS            *780508* 
      JMP SETUP     CONTINUE
      SPC 1 
NOEMA LDB NEWID                                    *780403* 
      JSB STORA     ZERO EMA WORD IN NEW ID SEG    *780403* 
      INB           BUMP POINTER TO NEW ID SEGMENT *780403* 
SETUP LDA DID29     POINTER TO ID(29) 
      INA           BUMP TO ID(30)
      LDA A,I       GET SAVED HI-ADDR+1 OF SEGMENT *780403* 
      JSB STORA     RESTORE TO NEW ID SEGMENT      *780403* 
      INB           BUMP POINTER TO NEW ID SEG     *780403* 
      CLA 
      JSB STORA     ZERO ID(31)                    *780403* 
      INB                                          *780403* 
      JSB LOADA     FETCH ID 32                    *780920* 
      AND B170K     SAVE SEQUENCE COUNTER          *780920* 
      IOR OWID      MERGE IN COPY FLAG             *780920* 
      IOR NOCPY     MERGE IN DONT' COPY BIT 
      JSB STORA     RESTORE ID 32                  *780920* 
      INB                                          *780403* 
      CLA 
      JSB STORA     ZERO ID(33)                    *780403* 
ERR14 SEZ,CME,RSS   CHANGE SO E=1, IF ERROR, ELSE = 0 
      LDA D14       RETURN IDSEGMENT NOT FOUND
PEXIT JSB $LIBX     DONE A=0,E=0 FOR GOOD EXIT
      DEF *+1 
      DEF EXIT
      SKP 
* 
* 
*  SUBROUTINE TO FIND AN AVAILABLE, SUITABLE ID SEGMENT 
* 
* 
*  CALLING ROUTINE MUST BE PRIVILEDGED: 
* 
*     JSB $LIBR 
*      NOP
*     JSB FIDSG 
*     <RETURN:  DUPLICATE PROGRAM NAME> 
*     <RETURN:  SUCCESS>
* 
*  OTHER POSSIBLE SUBROUTINE EXITS: 
* 
*     JMP ERR14     (IF NO BLANK ID SEGMENTS) 
* 
* 
*  RETURNED PARAMETERS: 
* 
*  <SUCCESS RETURN>:
*     ADDRESS OF KEYWD BLOCK ENTRY FOR FOUND ID SEGMENT 
*       RETURNED IN ID+17 
*     TEMP CONTAINS THE TRACKS & LONG/SHORT ID SEG INDICATOR
* 
*  <DUPLICATE PROGRAM NAME RETURN>:  EITHER 
*     (A=23,E=1)  THERE EXISTS AN ID SEGMENT WITH THE SAME NAME,
*                   BUT WHOSE DISK ADDRESS WORD DOES NOT MATCH ID+27. 
*                   (A DIFFERENT PROGRAM WITH THE SAME NAME.) 
*     (A=E=0)     THERE EXISTS AN ID SEGMENT WITH THE SAME NAME,
*                   AND WHOSE DISK ADDRESS WORD MATCHES ID+27.
*                   (THIS PROGRAM IS ALREADY RP'D.) 
* 
* 
FIDSG NOP 
      JSB IDSGA     SEARCH FOR NAME ALREADY EXISTS
      DEF *+2 
      DEF NAME,I
      SEZ,CME       IF NOT FOUND, CLEAR E-REG & A-REG 
      JMP SERCH     AND GO FIND A BLANK IDSEGMENT 
      STA NID,I     RETURN ADDR OF NEW ID SEGMENT 
      ADA D26       OFFSET TO DISC ADDRESS WORD (ID27)
      STA B         SAVE IN B 
      JSB LOADA     GET DISC ADDRESS TO A 
      CPA ID+27     COMPARE WITH ADDRESS OF TYPE 6 FILE 
      JMP LABL1     MATCH, SO RETURN AS IF WE DID IT
      LDA D23       NO MATCH, ERROR 23
      CCE,RSS       RETURN WITH E=1 
LABL1 CLA,CLE       GOOD RETURN, A=E=0
      JMP FIDSG,I 
      SPC 1 
*            BLANK ID'S ARE SEARCHED IN FOLLOWING PRECEDENCE
* 
*      TYPE 2 OR 3 PROG              TYPE 5 PROG (SEGMENT)
*    1)LONG BLANK WITHOUT TRACKS   1)SHORT BLANK WITHOUT TRACKS 
*    2)LONG BLANK & DON'T CARE     2)LONG BLANK WITHOUT TRACKS
*      <RETURN FMGR ERROR 14>      3)SHORT BLANK & DON'T CARE IF HAS TRACKS 
*                                  4)LONG BLANK & DON'T CARE IF HAS TRACKS
*                                      <RETURN FMGR ERROR 14> 
      SPC 1 
LOOP1 LDA ID+16     GET LONG/SHORT ID FLAG (0/20B)
      SEZ,SZA,RSS   IF DOWN TO LONG BLANK & DONT CARE 
      JMP ERR14     THEN GET OUT FMGR ERROR 14
      SPC 1 
SERCH SZA,RSS       TOGGLE E-REG WHEN A= 0
      CME 
      LDB ID+1      GET PROGRAM TYPE
      CPB O5        CAN IT HAVE A SHORT ID? 
      XOR O20       YES, THEN CHANGE SEARCH TO OTHER KIND 
      STA ID+16     AND PUT BACK IN TEMP
      LDA KEYWD     RESET FOR KEYWORD SEARCH
      STA ID+17 
      RSS           SKIP 1ST ISZ
      SPC 1 
*  ID+16=0 > SEARCH LONG ID              ID+16=20B > SEARCH SHORT ID
*  E-REG=1 > SEARCH ID WITHOUT TRACKS    E-REG=0 > DON'T CARE ABOUT TRACKS
      SPC 1 
LOOP2 ISZ ID+17     BUMP AND CHECK IF DONE WITH 
      LDB ID+17     KEYWORD SEARCH                 *780403* 
      JSB LOADA                                    *780403* 
      SZA,RSS       DONE?                          *780403* 
      JMP LOOP1     YES, TRY NEXT TYPE OF BLANK ID
      STA B                                        *780403* 
      ADB D14       BUMP TO WORD 15 IN IDSEG (NAME/TYPE)
      JSB LOADA     GET VALUE                      *780403* 
      AND OM360     MASK TO CHAR 5 & SHORT/LONG BIT(177420B)
      CPA ID+16     NULL AND SHORT/LONG?
      RSS           FOUND ONE BLANK, CHECK
      JMP LOOP2     NO, TRY NEXT IDSEG
      ADB O5        IF HAS TRACKS 
      SZA,RSS       CHECK IF SHORT OR LONG? 
      ADB O7        LONG, BUMP TO WORD 27 
      STA TEMP      SAVE TRACKS INDICATOR          *780403* 
      JSB LOADA     EQUAL TO 0 IF NO TRACKS        *780403* 
      SEZ,SZA       CHECK IF HAS TRACKS & CARE FLAG *780403*
      JMP LOOP2     WELL THIS DUDE HAS TRACKS, SKIP 
* 
      ISZ FIDSG     POINT TO NORMAL RETURN                 791219 
      JMP FIDSG,I   EXIT SUBROUTINE                        791219 
      SKP 
* 
* 
*  SUBROUTINE TO FIND AN AVAILABLE ID SEGMENT EXTENSION 
* 
* 
*  CALLING ROUTINE MUST BE PRIVILEDGED: 
* 
*     JSB $LIBR 
*      NOP
*     JSB FIDEX 
*     <RETURN:  SUCCESS>
* 
*  OTHER POSSIBLE SUBROUTINE EXITS: 
* 
*     JMP ERR14     (IF NO FREE ID SEGMENT EXTENSIONS)
* 
* 
*  RETURNED PARAMETERS: 
* 
*     IDEXT         CONTAINS THE ADDRESS OF THE FOUND ID
*                   SEGMENT EXTENSION 
* 
*     INDX          CONTAINS THE INDEX INTO THE ID EXTENSION
*                   LIST OF THE FOUND ID SEGMENT EXTENSION
* 
* 
FIDEX NOP 
      CLA           INITIALIZE INDEX INTO 
      STA INDX        THE ID EXTENSION LIST 
* 
      XLB $IDEX     LOAD ID EXTENSION LIST HEAD 
      STB IDEXT     SAVE
* 
GTEX1 LDB IDEXT 
      XLA B,I       GET NEXT ENTRY IN ID EXT LIST 
* 
      SZA,RSS       END OF ID EXTENSION BLOCK ? 
      JMP GTEX2     -YES, NO AVAILABLE ID EXTENSIONS
* 
      STA B 
      XLA B,I       GET WORD ZERO OF ID EXTENSION 
* 
      SZA,RSS       AVAILABLE ? 
      JMP GTEX3     -YES, FOUND ONE 
* 
      ISZ INDX      BUMP INDEX INTO ID EXT LIST 
      ISZ IDEXT     BUMP ID EXTENSION ADDRESS 
* 
      JMP GTEX1     TRY THE NEXT ID EXTENSION 
* 
*  CAN'T FIND AN ID SEGMENT EXTENSION 
* 
GTEX2 CLE           SET FOR ERROR EXIT
      JMP ERR14     TAKE ERROR EXIT 
* 
*  FOUND AN ID SEGMENT EXTENSION
* 
GTEX3 STB IDEXT     SAVE RESULT 
      JMP FIDEX,I   EXIT
* 
* 
IDEXT BSS 1         ID EXTENSION ADDRESS
INDX  BSS 1         ID EXTENSION LIST INDEX 
      SKP 
* 
*  TRANSFER DATA BETWEEN DISK AND A BUFFER
* 
*  CALLING SEQUENCE:
* 
*  CALL ZXFER (ZDIR,ZLU,ZBUF,ZBUFL,ZTRK,ZSEC,ZNSEC,ZNSPT) 
* 
*  ZDIR  = 1 (READ FROM DISK) OR 2 (WRITE TO DISK)
*  ZLU   = DISK LU
*  ZBUF  = BUFFER 
*  ZBUFL = BUFFER LENGTH (WORDS).  MUST BE AT LEAST 64 WORDS LONG.
*  ZTRK  = STARTING TRACK ADDRESS 
*  ZSEC  = STARTING SECTOR ADDRESS
*  ZNSEC = TOTAL NUMBER OF SECTORS ON DISK TO TRANSFER
*  ZNSPT = NUMBER OF SECTORS PER TRACK ON DISK
* 
*  ERROR EXITS:  IF ZBUFL < 64 WORDS:    JMP ERR78
*                IF DISK I/O ERROR:      JMP ERR01
* 
*  NOTE:  ZTRK AND ZSEC ARE MODIFIED BY THIS ROUTINE TO ALWAYS POINT
*         TO THE NEXT POSITION ON DISK TO TRANSFER TO/FROM. 
*         ZNSEC IS MODIFIED BY THIS ROUTINE TO ALWAYS INDICATE THE
*         NUMBER OF SECTORS REMAINING TO BE TRANSFERED. 
* 
*         ZXFER SHOULD BE CALLED ITERATIVELY UNTIL ZNSEC DROPS TO ZERO. 
* 
* 
ZDIR  NOP           TRANSFER DIRECTION
ZLU   NOP           DISK LU 
ZBUF  NOP           BUFFER ADDRESS
ZBUFL NOP           BUFFER LENGTH 
ZTRK  NOP           TRACK ADDRESS 
ZSEC  NOP           SECTOR ADDRESS
ZNSEC NOP           NUMBER OF SECTORS ON DISK TO COPY 
ZNSPT NOP           NUMBER OF SECTORS PER TRACK 
* 
ZXFER NOP 
      JSB .ENTR     PICKUP PARAMETERS 
       DEF ZDIR 
* 
*  PICKUP PARAMETERS
* 
      LDA ZDIR,I    A = READ (1) OR WRITE (2) 
      AND O3        CLEAR UNUSED BITS 
      IOR O1S       SET "NO ABORT" BIT
      STA ZDIR      SAVE FOR EXEC CALL
* 
      LDA ZBUFL,I   LOAD BUFFER LENGTH
      AND FLOOR     FORCE TO BE A MULTIPLE OF SECTOR SIZE 
      STA ZBUFL     SAVE AS "REMAINING BUFFER LENGTH" 
* 
      SZA           IF BUFFER LENGTH IS ZERO
      SSA             OR NEGATIVE 
      JMP ERR78         THEN TAKE ERROR EXIT
*  (NOTE:  LEAVE A-REG UNALTERED FOR USAGE BELOW.)
* 
*  REMAINING BUFFER LENGTH =
*    MINIMUM (SUPPLIED BUFFER LENGTH, REMAINING FILE LENGTH)
* 
      LDB ZNSEC,I   B=REMAINING FILE LENGTH (SECTORS) 
      BLF           MULTIPLY BY 64 WORDS/SECTOR 
      BLS,BLS       B=REMAINING FILE LENGTH (WORDS) 
* 
      CMA,INA       A=NEGATIVE REMAINING BUF LENGTH (WORDS) 
      ADA B         A=(FILE LENGTH) - (BUFFER LENGTH) 
* 
      SSA           FILE LENGTH < BUFFER LENGTH ? 
      STB ZBUFL     -YES, RESET REMAINING BUFFER LENGTH 
* 
*  TRANSFER LENGTH =
*    MINIMUM (REMAINING BUFFER LENGTH, REMAINING TRACK LENGTH)
* 
ZLOOP LDA ZSEC,I    A=CURRENT SECTOR ADDR 
      CMA,INA       NEGATE
      ADA ZNSPT,I   A=REMAINING TRACK LENGTH (SECTORS)
* 
      ALF           MULTIPLY BY 64 WORDS/SECTOR 
      ALS,ALS       A=REMAINING TRACK LENGTH (WORDS)
* 
      LDB ZBUFL     B=REMAINING BUFFER LENGTH (WORDS) 
      STB ZXLEN     SAVE AS DEFAULT TRANSFER LENGTH 
      CMB,INB       NEGATE
      ADB A         B=(TRACK LENGTH) - (BUFFER LENGTH)
* 
      SSB           TRACK LENGTH < BUFFER LENGTH ?
      STA ZXLEN     -YES, RESET TRANSFER LENGTH 
* 
*  DO THE DISK TRANSFER 
* 
      JSB EXEC
       DEF *+1+6
       DEF ZDIR     (TRANSFER DIRECTION)
       DEF ZLU,I    (DISK LU) 
       DEF ZBUF,I   (BUFFER)
       DEF ZXLEN    (TRANSFER LENGTH) 
       DEF ZTRK,I   (TRACK ADDRESS) 
       DEF ZSEC,I   (SECTOR ADDRESS)
      JMP ERR01     (NO-ABORT ERROR RETURN) 
* 
*  UPDATE SECTOR AND TRACK ADDRESSES
* 
      LDA ZXLEN     A=TRANSFER LENGTH (WORDS) 
      ARS,ARS       DIVIDE BY 64 WORDS/SECTOR 
      ARS,ARS 
      ARS,ARS       A=TRANSFER LENGTH (SECTORS) 
      LDB A         (SAVE IN B-REG) 
* 
      ADA ZSEC,I    CALCULATE NEW SECTOR ADDRESS
      STA ZSEC,I    UPDATE CURRENT SECTOR ADDRESS 
* 
      CPA ZNSPT,I   END OF TRACK ?
      RSS           -YES
      JMP ZSKIP     -NO 
* 
      ISZ ZTRK,I    INCREMENT TRACK ADDRESS 
      CLA 
      STA ZSEC,I    RESET SECTOR ADDRESS
* 
ZSKIP EQU * 
* 
*  UPDATE REMAINING FILE LENGTH 
* 
      CMB,INB       B=NEGATIVE TRANSFER LENGTH (SECTORS)
      ADB ZNSEC,I   CALCULATE NEW REMAINING FILE LENGTH 
      STB ZNSEC,I   SAVE
* 
*  UPDATE BUFFER ADDRESS
* 
      LDA ZBUF      A = OLD BUFFER ADDRESS
      ADA ZXLEN     ADD TRANSFER LENGTH 
      STA ZBUF      UPDATE CURRENT BUFFER ADDRESS 
* 
*  UPDATE REMAINING BUFFER LENGTH 
* 
      LDA ZXLEN     A=TRANSFER LENGTH (WORDS) 
      CMA,INA       NEGATE
      ADA ZBUFL     CALCULATE NEW BUFFER LENGTH 
      STA ZBUFL     SAVE
* 
*  LOOP UNTIL BUFFER IS EMPTY 
* 
      SZA           BUFFER EMPTY ?
      JMP ZLOOP     -NO, LOOP 
      JMP ZXFER,I   -YES, EXIT
* 
* 
ZXLEN BSS 1         STORAGE FOR TRANSFER LENGTH (WORDS) 
FLOOR OCT 177700    MASK TO INSURE MULTIPLE OF 64 
      SKP 
* 
*  MISC. UTILITY SUBROUTINES
* 
* 
* 
MOVE  NOP           ENTRY A=SOURCE,B=DEST ADDRESS 
      STA ID+18     SAVE SOURCE ADDRESS 
      LDA MOVE,I    GET COUNTER 
      CMA,INA 
      STA ID+19 
      ISZ MOVE      SET RETURN TO P+2 
MORE  LDA ID+18,I   GET NEXT WORD 
      JSB STORA     PUT                            *780403* 
      INB 
      ISZ ID+18 
      ISZ ID+19 
      JMP MORE      E-REG UNMODIFIED!!!!!!!!!!!!
      JMP MOVE,I    RETURN DONE B=NEXT ADDRESS
      SPC 1 
SUM   NOP           P+1=ADDRESS,P+2=# OF WORDS
      LDB SUM,I 
      ISZ SUM 
      STB MOVE     SAVE START SUMMING ADDRESS 
      LDB SUM,I     GET NUMBER OF WORDS 
      ISZ SUM       BUMP TO P+3 
      ADA MOVE,I   ACCUMULATE THE SUM 
      ISZ MOVE     BUMP TO NEXT WORD
      INB,SZB       DONE? 
      JMP *-3 
      JMP SUM,I     RETURN P+3, E-REG = 1!!!!!! 
      SPC 1 
STYPE NOP                                           *780403*
LOADA NOP           DOES XLA B,I IF MAPPED SYS      *780403*
      LDA STYPE     OP SYS IDENTIFIER (AFTER ERA)   *780403*
      SLA           MAPPED SYSTEM?                  *780403*
      JMP MAPSY     YES                             *780403*
      LDA B,I       NO, DO DIRECT LOAD              *780403*
      JMP LOADA,I   RETURN                          *780403*
MAPSY XLA B,I       DO CROSS-LOAD (2-WD INSTRUCT.)  *780403*
      JMP LOADA,I   RETURN                          *780403*
      SPC 1 
STORA NOP           DOES XSA B,I IF MAPPED SYS      *780403*
      STA STSAV     SAVE TEMPORARILY                *780403*791219
      LDA STYPE     OP SYS IDENTIFIER (AFTER ERA)   *780403*
      SLA           MAPPED SYSTEM?                  *780403*
      JMP MAP       YES                             *780403*
      LDA STSAV     RESTORE TEMP WORD               *780403*791219
      STA B,I       NON-MAPPED, DO DIRECT LOAD      *780403*
      JMP STORA,I   RETURN                          *780403*
MAP   LDA STSAV     RESTORE TEMP WORD               *780403*791219
      XSA B,I       DO CROSS-STORE(2-WD INSTRUCT.)  *780403*
      JMP STORA,I   RETURN                          *780403*
* 
STSAV BSS 1         <STORA> TEMPORARY STORAGE              791219 
* 
      SPC 1 
DEFZ  DEF *+1 
      DEC 0 
      DEC 0 
      DEC 0 
      DEC 0 
      DEC 0 
DEFTM DEF *+1 
      DEC 0 
      DEC 0 
      DEC 0 
      OCT 25000     TIME = ONE DAY
      OCT 177574
      DEC 0 
      SPC 1 
* 
PRC   OCT 74000     FMP PRIV CODE FOR WRITE ON FMP TRACKS 
* 
O1S   OCT 100000                                           791219 
O1    OCT 1 
O3    OCT 3 
O7    OCT 7 
M2    DEC -2                                               791219 
M9    DEC -9
D11   DEC 11
D14   DEC 14
D19   DEC 19
D23   DEC 23
D26   DEC 26
D41   DEC 41
D75   DEC 75
D76   DEC 76
D77   DEC 77
D78   DEC 78
D99   DEC 99
O20   OCT 20
O77   OCT 77
O200  OCT 200 
O1777 OCT 1777
MASK  OCT 77777 
B170K OCT 170000
B1000 OCT 1000
B2000 OCT 2000
O7777 OCT 7777
OM20  OCT -20 
OM360 OCT -360
OM400 OCT -400
DID9  DEF ID+9
DID23 DEF ID+23 
DID29 DEF ID+29 
DID32 DEF ID+32 
DID36 DEF ID+36 
* 
IDBUF BSS 41
ID    EQU IDBUF-1 
TEMP  NOP                                          *780403* 
TEMP1 NOP 
OWID  NOP 
ADNAM NOP 
NEWID NOP 
NOCPY NOP 
CPY   BSS 1         "I'M A COPY" FLAG                      791219 
SESWD NOP 
* 
TEMP2 BSS 1                                                791219 
IDISC BSS 1         POOL DISK LU #                         791219 
ITRAK BSS 1         STARTING POOL TRACK #                  791219 
ISETR BSS 1         # SECTORS/TRACK ON "IDISC"             791219 
NTRAK BSS 1         NUMBER OF POOL TRACKS DESIRED/RECEIVED 791219 
* 
DCB8  DEF *-*       ADDR OF IDCB(9)                        791219 
DLU   BSS 1         FILE DISK LU #                         791219 
FDLU  BSS 1         FILE DISK LU # WITH FMP PRIV. CODE     791219 
SECTR BSS 1         MIN # SECTORS/TRACK ON POOL DISKS      791219 
PSIZE BSS 1         PROGRAM SIZE (IN SECTORS)              791219 
* 
*  PARAMETER STORAGE FOR CALLS TO SUBROUTINE <ZXFER>
* 
.TRKI BSS 1         INPUT TRACK ADDR                       800305 
.SECI BSS 1         INPUT SECTOR ADDR                      800305 
.NSCI BSS 1         INPUT # SECTORS TO READ                800305 
.TRKO BSS 1         OUTPUT TRACK ADDR                      800305 
.SECO BSS 1         OUTPUT SECTOR ADDR                     800305 
.NSCO BSS 1         OUTPUT # SECTORS TO WRITE              800305 
* 
* 
      END 
                                              