SXSERV
PROC ACQ$FCT((FAMNAME),(SUBFAM),(SMID),(FCTORD),FCTQADDR,(REQADDR)
      ,   RSTATUS); 
  
# TITLE ACQ$FCT - ACQUIRE AN *FCTQ* ENTRY.                            # 
  
      BEGIN  # ACQ$FCT #
  
# 
**    ACQ$FCT - ACQUIRE AN *FCTQ* ENTRY.
* 
*     *ACQ$FCT* READS AN *FCT* ENTRY INTO THE *FCTQ* (IF NOT ALREADY
*     THERE) AND RETURNS ITS ADDRESS TO THE CALLER. 
* 
*     PROC ACQ$FCT((FAMNAME),(SUBFAM),(SMID),(FCTORD),FCTQADDR, 
*       (REQADDR),RSTATUS)
* 
*     ENTRY      (FAMNAME) - FAMILY NAME. 
*                (SUBFAM)  - SUBFAMILY ID.
*                (SMID)   - *SM* NUMBER.
*                (FCTORD)  - *FCT* ORDINAL. 
*                (REQADDR) - ADDRESS OF *HLRQ* ENTRY, ELSE ZERO.
* 
*     EXIT       (FCTQADDR) - ADDRESS OF *FCTQ* ENTRY.
*                (RSTATUS)  - *CGETFCT* ERROR STATUS (DEFINED IN
*                             PROC *CGETFCT* IN DECK *CATACC*). 
* 
*     NOTES      IF THE CATALOG IS INTERLOCKED AND IF *REQADDR* IS
*                NONZERO, *CGETFCT* WILL PUT THE *HLRQ* ENTRY ON THE
*                "WAITING-FOR-CATALOG-INTERLOCK" CHAIN. 
# 
  
      ITEM FAMNAME    C(7);          # FAMILY NAME #
      ITEM SUBFAM     U;             # SUBFAMILY ID # 
      ITEM SMID       U;             # *SM* NUMBER #
      ITEM FCTORD     U;             # *FCT* ORDINAL #
      ITEM FCTQADDR   U;             # *FCTQ* ADDRESS # 
      ITEM REQADDR    U;             # *HLRQ* REQUEST ADDRESS # 
      ITEM RSTATUS    U;             # *CGETFCT* ERROR STATUS # 
  
# 
****  PROC ACQ$FCT - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC ABORT;                  # ABORT #
        PROC ADD$LNK;                # ADD ENTRY TO CHAIN # 
        PROC CGETFCT;                # GET AN *FCT* ENTRY # 
        PROC DEL$LNK;                # DELETE ENTRY FROM CHAIN #
        PROC MESSAGE;                # INTERFACE TO *MESSAGE* MACRO # 
        END 
  
# 
****  PROC ACQ$FCT - XREF LIST END. 
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMMON DECKS # 
*CALL,COMBFAS 
*CALL,COMBCHN 
*CALL,COMBCMD 
*CALL,COMBMCT 
*CALL,COMXFCQ 
*CALL,COMXMSC 
  
      ITEM I          U;             # COUNTER #
  
                                               CONTROL EJECT; 
  
# 
*     SEARCH THE *FCTQ* TO SEE IF AN ENTRY EXISTS WHICH WILL SATISFY
*     THE REQUEST.  IF FOUND, PASS ITS ADDRESS TO THE CALLER AND
*     INCREASE THE ACTIVE USER COUNT BY 1.
# 
  
      RSTATUS = 0;
      FCTQADDR = 0; 
      P<FCTQ> = CHN$BOC[LCHN"FCT$ACT"]; 
      SLOWFOR I = 0 WHILE P<FCTQ> NQ 0
      DO
        BEGIN  # SEARCH THE *FCTQ* #
        IF FAMNAME EQ FCTQFAMILY[0] AND SUBFAM EQ FCTQSUBF[0]  ## 
          AND SMID EQ FCTQSMID[0] AND FCTORD EQ FCTQFCTORD[0] 
        THEN
          BEGIN 
          FCTQACTCNT[0] = FCTQACTCNT[0] + 1;
          FCTQADDR = P<FCTQ>; 
          RETURN; 
          END 
  
        P<FCTQ> = FCTQLINK1[0]; 
        END  # SEARCH THE *FCTQ* #
  
# 
*     REQUIRED ENTRY IS NOT CURRENTLY IN THE *FCTQ*.
# 
  
      FCTQADDR = CHN$BOC[LCHN"FCT$FRSPC"];
  
# 
*     ABORT IF THERE IS NO SPACE FOR NEW *FCTQ* ENTRIES.
# 
  
      IF FCTQADDR EQ 0
      THEN
        BEGIN 
        FE$RTN[0] = "ACQ$FCT."; 
        MESSAGE(FEMSG,UDFL1); 
        ABORT;
        END 
  
# 
*     GET THE *FCT* ENTRY FROM THE FILE.
# 
  
      P<FCT> = FCTQADDR + FCTQHL; 
      CGETFCT(FAMNAME,SUBFAM,SMID,FCTORD,P<FCT>,REQADDR,RSTATUS); 
      IF RSTATUS NQ 0 
      THEN
        BEGIN 
        FCTQADDR = 0; 
        RETURN; 
        END 
  
# 
*     BUILD A *FCTQ* ENTRY AND SET THE ACTIVE USER COUNT TO 1.
# 
  
      DEL$LNK(FCTQADDR,LCHN"FCT$FRSPC",0);
      ADD$LNK(FCTQADDR,LCHN"FCT$ACT",0);
      P<FCTQ> = FCTQADDR; 
      FCTQFAMILY[0] = FAMNAME;
      FCTQSUBF[0] = SUBFAM; 
      FCTQSMID[0] = SMID; 
      FCTQFCTORD[0] = FCTORD; 
      FCTQACTCNT[0] = 1;
  
  
      RETURN; 
      END  # ACQ$FCT #
  
    TERM
PROC ADD$LNK((ADDR),(CHNTYP),(WRD));
  
# TITLE ADD$LNK - ADD ENTRY TO END OF CHAIN.                          # 
  
      BEGIN  # ADD$LNK #
  
# 
**    ADD$LNK - ADD ENTRY TO END OF CHAIN.
* 
*     *ADD$LNK* LINKS AN ENTRY INTO A CHAIN BY ADDING IT TO THE END 
*     OF THE CHAIN. 
* 
*     PROC ADD$LNK((ADDR),(CHNTYP),(WRD)) 
* 
*     ENTRY      (ADDR)   - ADDRESS OF THE ENTRY. 
*                (CHNTYP) - CHAIN TYPE INDICATOR. 
*                           (VALUES DEFINED IN *COMBCHN*).
*                (WRD)    - WORD NUMBER WITHIN ENTRY WHICH CONTAINS 
*                           THE LINKAGE FIELD.
* 
*     EXIT       THE LINKAGE FIELD HAS BEEN CLEARED IN THE ENTRY ADDED
*                TO THE END OF THE CHAIN. 
* 
*     NOTES      THE LINKAGE FIELD IS ASSUMED TO BE IN THE LOWER
*                18 BITS OF WORD *WRD* OF THE ENTRY.
# 
  
      ITEM ADDR       U;             # ADDRESS OF ENTRY # 
      ITEM CHNTYP     I;             # CHAIN TYPE INDICATOR # 
      ITEM WRD        I;             # LINKAGE WORD # 
  
      DEF LISTCON #0#;               # DO NOT LIST COMMON DECKS # 
*CALL,COMBFAS 
*CALL,COMBCHN 
                                               CONTROL EJECT; 
  
      P<LINKWRD> = ADDR;             # CLEAR LINK FIELD IN ENTRY #
      LINK$ADR[WRD] = 0;
      IF CHN$BOC[CHNTYP] EQ 0 
      THEN                           # IF EMPTY CHAIN # 
        BEGIN 
        CHN$BOC[CHNTYP] = ADDR; 
        END 
  
      ELSE
        BEGIN 
        P<LINKWRD> = CHN$EOC[CHNTYP];  # ADD ENTRY TO END OF CHAIN #
        LINK$ADR[WRD] = ADDR; 
        END 
  
      CHN$EOC[CHNTYP] = ADDR;        # RESET END OF CHAIN POINTER # 
      RETURN; 
  
      END  # ADD$LNK #
  
    TERM
PROC ANLZAST((SM),(NEED$S),(NEED$L),FCTX$S,FCTX$L,GPX,GPS); 
  
# TITLE ANLZAST - SCAN *AST* TO DETERMINE BEST CARTRIDGES AND GROUP.  # 
  
      BEGIN  # ANLZAST #
  
# 
**    ANLZAST - SCAN *AST* TO DETERMINE BEST CARTRIDGES AND GROUP.
* 
*     THE BEST CARTRIDGE FOR SHORT FILES IS THE ONE WITH THE
*     MOST FREE AU FOR LONG FILES AMONG THOSE CARTRIDGES WHICH
*     HAVE AT LEAST THE NUMBER OF FREE AU SPECIFIED BY *NEED$S*.
*     IF NO CARTRIDGE HAS AT LEAST *NEED$S* FREE AU, THEN THE BEST
*     CARTRIDGE IS THE ONE WITH THE MOST FREE AU. 
* 
*     THE BEST CARTRIDGE FOR LONG FILES IS SIMPLY THE ONE WITH THE
*     MOST NUMBER OF FREE AU. 
* 
*     THE BEST GROUP FOR LONG FILES IS THE ONE WITH THE CARTRIDGE 
*     HAVING THE MOST FREE AU AND AN OFF-CARTRIDGE LINK (OCL) 
*     AMONG THE CARTRIDGES IN GROUPS WHICH HAVE AT LEAST *NEED$L* 
*     FREE AU AVAILABLE FOR LONG FILES.  IF NO GROUP HAS THIS 
*     MUCH FREE SPACE, THEN THE GROUP WITH THE MOST USABLE SPACE
*     FOR A LARGE FILE IS SELECTED.  NOTE THAT THE USABLE SPACE 
*     FOR A LARGE FILE IS THE SUM OF THE FREE AU ON CARTRIDGES
*     WITH AN *OCL* PLUS THE SPACE ON THE ONE CARTRIDGE IN THE
*     GROUP HAVING THE MOST FREE SPACE, BUT NO *OCL*. 
* 
*     PROC ANLZAST(NEED$S,NEED$L,FCTX$S,FCTX$L,GPX,GPS) 
* 
*     ENTRY          (SM)        - INDEX OF DESIRED STORAGE MODULE. 
*                    (NEED$S)    - =N, AU NEEDED FOR SHORT FILES. 
*                                  =0, *FCTX$S* IS NOT TO BE RETURNED.
*                    (NEED$L)    - =N, AU NEEDED FOR LONG FILES.
*                                  =0, *FCTX$L*, *GPX* AND *GPS*
*                                      ARE NOT TO BE RETURNED.
* 
*                    (P<PREAMBLE>)- POINTS TO THE PREAMBLE. 
* 
*     EXIT           (FCTX$S)    - *FCT* INDEX OF THE BEST CARTRIDGE
*                                  FOR SHORT FILES. 
*                    (FCTX$L)    - *FCT* INDEX OF THE BEST CARTRIDGE
*                                  FOR LONG FILES.
*                    (GPX)       - INDEX OF THE BEST GROUP. 
*                    (GPS)       - AVAILABLE SPACE IN THE BEST GROUP. 
# 
  
      ITEM SM         U;             # STORAGE MODULE INDEX # 
      ITEM NEED$S     U;             # AU FOR SHORT FILES # 
      ITEM NEED$L     U;             # AU FOR LONG FILES #
      ITEM FCTX$S     U;             # BEST CARTRIDGE FOR SHORT FILES # 
      ITEM FCTX$L     U;             # BEST CARTRIDGE FOR LONG FILES #
      ITEM GPX        U;             # BEST GROUP # 
      ITEM GPS        U;             # AU AVAILABLE ON BEST GROUP # 
  
# 
****  PROC ALLOCAT - XREF LIST BEGIN. 
# 
  
# 
****  PROC ANLZAST - XREF LIST END. 
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMMON DECKS # 
*CALL,COMBFAS 
*CALL,COMBCMD 
*CALL,COMBMCT 
  
  
      ITEM BESTGR     I;             # BEST GROUP # 
      ITEM BESTL      I;             # BEST CARTRIDGE FOR LONG FILES #
      ITEM BESTSH     I;             # BEST CARTRIDGE FOR SHORT FILES # 
      ITEM CURRGR     I;             # GROUP FOR LAST USABLE CARTRIDGE
                                     #
      ITEM GRSIZE     I;             # FREE AU IN A GROUP # 
      ITEM GRSUMOCL   I;             # FREE AU IN GROUP ON CARTRIDGES 
                                       WITH AN OFF CARTRIDGE LINK # 
      ITEM I          I;             # LOOP INDEX # 
      ITEM LAST       I;             # LAST *FCT* INDEX + 1 # 
      ITEM MAXAUGR    I;             # AU IN BEST GROUP # 
      ITEM MAXAUL     I;             # AU ON BEST CARTRIDGE FOR LONG
                                       FILES #
      ITEM MAXAUNOCL  I;             # AU ON BEST CARTRIDGE W/O OCL # 
      ITEM MAXAUOCL   I;             # AU ON BEST CARTRIDGE WITH OCL #
      ITEM MAXAUS     I;             # AU ON BEST CARTRIDGE FOR SHORT 
                                       FILES #
      ITEM SZBSTGR    I;             # SIZE OF THE BEST GROUP # 
      ITEM USABLE     B;             # TRUE IF CARTRIDGE CAN BE USED #
      ITEM USE        I;             # TEMPORARY #
                                               CONTROL EJECT; 
  
# 
*     INITIALIZE VARIABLES. 
# 
  
      P<AST> = ASTBADR; 
  
      BESTGR = 0; 
      BESTL = 0;
      BESTSH = 0; 
      CURRGR = 1; 
      GRSUMOCL = 0; 
  
      MAXAUGR = 0;
      MAXAUL = 0; 
      MAXAUNOCL = 0;
      MAXAUOCL = 0; 
      MAXAUS = 0; 
      SZBSTGR = 0;
  
      LAST = MAXGRT + PRM$ENTRC[SM];
  
      FOR I = MAXGRT STEP 1 UNTIL LAST+1
      DO
        BEGIN  # MAIN LOOP #
  
        USABLE = AST$AAF[I] AND (I LQ LAST) AND  ## 
          (AST$STAT[I] EQ ASTENSTAT"ASS$CART"); 
  
        IF USABLE AND (NEED$S NQ 0) 
        THEN                         # SELECT BEST CARTRIDGE FOR SHORT
                                       FILES #
          BEGIN 
  
          IF AST$AUSF[I] GQ NEED$S
          THEN
            BEGIN 
            USE = AST$AULF[I] + NEED$S; 
            END 
  
          ELSE
  
            BEGIN 
            USE = AST$AUSF[I];
            END 
  
          IF USE GR MAXAUS
          THEN                       # PICK THIS CARTRIDGE #
            BEGIN 
            BESTSH = I; 
            MAXAUS = USE; 
            END 
  
          END 
  
        IF NEED$L NQ 0
        THEN                         # CALCULATE LARGE FILE DATA #
          BEGIN  # LARGE FILE ANALYSIS #
  
# 
*     PICK CARTRIDGE WITH THE MAXIMUM AU FOR LONG FILES.
# 
  
          IF USABLE AND (AST$AULF[I] GR MAXAUL)       ##
            AND ((NEED$L LQ AST$AULF[I])              ##
              OR (NEED$L GR AST$AULF[I] AND NOT AST$NOCLF[I]))
          THEN                       # SELECT THIS CARTRIDGE #
            BEGIN 
            BESTL = I;
            MAXAUL = AST$AULF[I]; 
            END 
  
# 
*     PICK BEST GROUP WHEN NEW GROUP MET OR AFTER LAST CARTRIDGE. 
# 
  
          IF (I GR LAST) OR          ## 
            ((AST$GR[I] NQ CURRGR)   ## 
            AND AST$AAF[I]           ## 
            AND (AST$STAT[I] EQ ASTENSTAT"ASS$CART")) 
          THEN                       # COMPARE THIS GROUP WITH PREVIOUS 
                                       BEST # 
            BEGIN  # SELECT BEST GROUP #
            GRSIZE = GRSUMOCL + MAXAUNOCL;
  
            IF GRSIZE GR NEED$L 
            THEN
              BEGIN 
              USE = MAXAUOCL + NEED$L;
              END 
  
            ELSE
              BEGIN 
              USE = GRSIZE; 
              END 
  
            IF USE GR MAXAUGR 
            THEN
              BEGIN 
              BESTGR = CURRGR;
              MAXAUGR = USE;
              SZBSTGR = GRSIZE; 
              END 
  
            GRSUMOCL = 0; 
            MAXAUNOCL = 0;
            MAXAUOCL = 0; 
  
            END  # SELECT BEST GROUP #
  
# 
*     UPDATE GROUP STATISTICS TO REFLECT THIS CARTRIDGE 
*       - SUM OF AU AVAILABLE IF OCL EXISTS.
*       - CARTRIDGE WITH MOST AU WITH AN OCL. 
*       - CARTRIDGE WITH MOST AU WITHOUT AN OCL.
# 
  
          IF USABLE 
          THEN                       # INCLUDE THIS CARTRIDGE # 
            BEGIN  # DO GROUP STATISTICS #
  
            CURRGR = AST$GR[I]; 
  
            IF AST$NOCLF[I] 
            THEN                     # NO OVERFLOW #
              BEGIN 
              IF AST$AULF[I] GR MAXAUNOCL 
              THEN
                BEGIN 
                MAXAUNOCL = AST$AULF[I];
                END 
  
              END 
  
            ELSE                     # OVERFLOW LINK AVAILABLE #
              BEGIN 
              GRSUMOCL = GRSUMOCL + AST$AULF[I];
              IF AST$AULF[I] GR MAXAUOCL
              THEN
                BEGIN 
                MAXAUOCL = AST$AULF[I]; 
                END 
  
              END 
  
            END  # DO GROUP STATISTICS #
  
          END  # LARGE FILE ANALYSIS #
  
        END  # MAIN LOOP #
  
# 
*     RETURN OUTPUT PARAMETERS. 
# 
  
      IF NEED$S NQ 0
      THEN
        BEGIN 
        FCTX$S = BESTSH;
        END 
  
      IF NEED$L NQ 0
      THEN
        BEGIN 
        FCTX$L = BESTL; 
        GPX = BESTGR; 
        GPS = SZBSTGR;
        END 
  
      RETURN; 
      END  # ANLZAST #
  
    TERM
PROC DELAY((DTIME),(ADDR),(TYP)); 
  
# TITLE DELAY - TIMED DELAY.                                          # 
  
      BEGIN  # DELAY #
  
# 
**    DELAY - TIMED DELAY.
* 
*     *DELAY* CALCULATES A WAKE-UP TIME AND PUTS AN *HLRQ* OR *LLRQ*
*     ENTRY ON THE APPROPRIATE DELAY CHAIN. 
* 
*     PROC DELAY((DTIME),(ADDR),(TYP))
* 
*     ENTRY      (DTIME) - DELAY TIME IN SECONDS. 
*                (ADDR)  - ADDRESS OF ENTRY.
*                (TYP)   - *HLRQ* OR *LLRQ* INDICATOR.
*                          = FALSE, *LLRQ* ENTRY. 
*                          = TRUE,  *HLRQ* ENTRY. 
* 
*     EXIT       A WAKE-UP TIME IS IN THE *HLRQ* OR *LLRQ* ENTRY. 
# 
  
      ITEM DTIME      U;             # DELAY TIME # 
      ITEM ADDR       U;             # ADDRESS OF ENTRY # 
      ITEM TYP        B;             # ENTRY TYPE INDICATOR # 
  
# 
****  PROC DELAY - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC ADD$LNK;                # ADD ENTRY TO END OF CHAIN #
        PROC RTIME;                  # OBTAIN REAL TIME CLOCK READING # 
        END 
  
# 
****  PROC DELAY - XREF LIST END. 
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMMON DECKS # 
*CALL,COMBFAS 
*CALL,COMBCHN 
*CALL,COMBLRQ 
*CALL,COMXHLR 
  
      ITEM WAKEUP     U;             # WAKEUP TIME #
  
  
  
  
      RTIME(RTIMESTAT[0]);           # CALCULATE WAKE-UP TIME # 
      WAKEUP = RTIMSECS[0] + DTIME; 
      IF TYP
      THEN                           # IF ENTRY IS FROM *HLRQ* #
        BEGIN 
        P<HLRQ> = ADDR;              # PUT ENTRY ON *HLRQ* DELAY CHAIN
                                     #
        HLR$RTIME[0] = WAKEUP;
        ADD$LNK(ADDR,LCHN"HL$DELAY",0); 
        END 
  
      ELSE                           # IF ENTRY IS FROM *LLRQ* #
        BEGIN 
        P<LLRQ> = ADDR;              # PUT ENTRY ON *LLRQ* DELAY CHAIN
                                     #
        LLR$RTIME[0] = WAKEUP;
        ADD$LNK(ADDR,LCHN"LL$DELAY",0); 
        END 
  
      RETURN; 
      END  # DELAY #
  
    TERM
PROC DEL$LNK((ADDR),(CHNTYP),(WRD));
  
# TITLE DEL$LNK - DELETE ENTRY FROM CHAIN.                            # 
  
      BEGIN  # DEL$LNK #
  
# 
**    DEL$LNK - DELETE ENTRY FROM CHAIN.
* 
*     *DEL$LNK* DELINKS AN ENTRY FROM A CHAIN AND RESETS THE BEGINNING
*     AND END OF CHAIN POINTERS IF NECESSARY. 
* 
*     PROC DEL$LNK((ADDR),(CHNTYP),(WRD)) 
* 
*     ENTRY      (ADDR)   - ADDRESS OF THE ENTRY. 
*                (CHNTYP) - CHAIN TYPE INDICATOR. 
*                           (VALUES DEFINED IN *COMBCHN*).
*                (WRD)    - WORD NUMBER WITHIN ENTRY WHICH CONTAINS 
*                           THE LINKAGE FIELD.
* 
*     EXIT       IF THE CHAIN LINKAGE IS BAD, AN ERROR MESSAGE IS 
*                ISSUED AND THE PROGRAM IS ABORTED, OTHERWISE THE ENTRY 
*                IS DELETED FROM THE CHAIN. 
* 
*     MESSAGES   * EXEC ABNORMAL, DEL$LNK.*.
* 
*     NOTES      THE LINKAGE FIELD IS ASSUMED TO BE IN THE LOWER 18 
*                BITS IN WORD *WRD* OF THE ENTRY. 
# 
  
      ITEM ADDR       U;             # ADDRESS OF ENTRY # 
      ITEM CHNTYP     I;             # CHAIN TYPE INDICATOR # 
      ITEM WRD        I;             # LINKAGE WORD # 
  
# 
****  PROC DEL$LNK - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC ABORT;                  # ABORT #
        PROC MESSAGE;                # ISSUE A MESSAGE #
        END 
  
# 
****  PROC DEL$LNK - XREF LIST END. 
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMMON DECKS # 
*CALL,COMBFAS 
*CALL,COMBCHN 
*CALL,COMXMSC 
  
      ITEM CADDR      U;             # ADDRESS OF CURRENT ENTRY # 
      ITEM NEXT       U;             # NEXT ENTRY ON CHAIN #
  
                                               CONTROL EJECT; 
  
      P<LINKWRD> = ADDR;             # FIND NEXT ENTRY ON CHAIN # 
      NEXT = LINK$ADR[WRD]; 
      IF CHN$BOC[CHNTYP] EQ 0        ## 
        OR (NEXT EQ 0 AND ADDR NQ CHN$EOC[CHNTYP])
      THEN                           # IF CHAIN IS BAD #
        BEGIN 
        GOTO BAD$CHN; 
        END 
  
      LINK$ADR[WRD] = 0;             # CLEAR LINKAGE IN ENTRY # 
      IF ADDR EQ CHN$BOC[CHNTYP]
      THEN                           # IF ENTRY IS AT *BOC* # 
        BEGIN 
        CHN$BOC[CHNTYP] = NEXT; 
        IF ADDR EQ CHN$EOC[CHNTYP]
        THEN                         # IF ENTRY IS AT *EOC* # 
          BEGIN 
          CHN$EOC[CHNTYP] = 0;       # CLEAR END OF CHAIN POINTER # 
          END 
  
        RETURN; 
        END 
  
      CADDR = CHN$BOC[CHNTYP];
      P<LINKWRD> = CADDR; 
      REPEAT WHILE LINK$ADR[WRD] NQ ADDR AND LINK$ADR[WRD] NQ 0 
      DO                             # SEARCH FOR ENTRY ON CHAIN #
        BEGIN 
        CADDR = LINK$ADR[WRD];
        P<LINKWRD> = CADDR; 
        END 
  
      IF LINK$ADR[WRD] EQ 0 
      THEN                           # IF ENTRY NOT FOUND # 
        BEGIN 
        GOTO BAD$CHN; 
        END 
  
      LINK$ADR[WRD] = NEXT; 
      IF NEXT EQ 0
      THEN                           # IF DELINKED ENTRY IS AT *EOC* #
        BEGIN 
        CHN$EOC[CHNTYP] = CADDR;     # RESET *EOC* POINTER #
        END 
  
      RETURN; 
  
BAD$CHN:                             # BAD CHAIN ENCOUNTERED #
      FE$RTN[0] = "DEL$LNK."; 
      MESSAGE(FEMSG,UDFL1); 
      ABORT;
      END  # DEL$LNK #
  
    TERM
PROC GETBUF((REQADR),(REQIND),FLAG);
  
# TITLE GETBUF - GET LARGE BUFFER.                                    # 
  
      BEGIN  # GETBUF # 
  
# 
**    GETBUF - GET LARGE BUFFER.
* 
*     *GETBUF* ASSIGNS THE BUFFERS AND FET-S TO BE USED FOR A FILE
*     TRANSFER.  IF NO ACQUIRED BUFFERS ARE AVAILABLE AND THERE ARE ANY 
*     AUTHORIZED ENTRIES IN THE *BST*, AN ATTEMPT IS MADE TO ACQUIRE
*     ANOTHER BUFFER. 
* 
*     PROC GETBUF((REQADR),(REQIND),FLAG) 
* 
*     ENTRY      (REQADR) - ADDRESS OF THE HIGH LEVEL/LOW LEVEL REQUEST 
*                           QUEUE ENTRY.
*                (REQIND) - HIGH LEVEL/LOW LEVEL REQUEST INDICATOR. 
*                           = TRUE, A HIGH LEVEL REQUEST. 
*                           = FALSE, A LOW LEVEL REQUEST. 
* 
*     EXIT       (FLAG)   - BUFFER AVAILABLE FLAG.
*                           = TRUE, BUFFER ASSIGNED.
*                           = FALSE, NO BUFFER AVAILABLE. 
*                THE LOCATION OF THE LARGE BUFFER SPACE IS RETURNED IN
*                THE REQUEST QUEUE ENTRY, IF A BUFFER IS ASSIGNED.
* 
*     NOTES      IF NO BUFFER IS AVAILABLE, THE CALLER SHOULD ADD THE 
*                ENTRY TO THE *HLRQ*/*LLRQ* WAITING FOR LARGE BUFFER
*                CHAIN AND THEN DROP OUT UNTIL ONE BECOMES AVAILABLE. 
*                WHEN A BUFFER BECOMES AVAILABLE, *GOBUF* WILL PUT THE
*                *HLRQ*/*LLRQ* ENTRY ON THE APPROPRIATE READY CHAIN.
# 
  
      ITEM REQADR     U;             # REQUEST ADDRESS #
      ITEM REQIND     B;             # REQUEST TYPE INDICATOR # 
      ITEM FLAG       B;             # BUFFER AVAILABLE FLAG #
  
# 
****  PROC GETBUF - XREF LIST BEGIN.
# 
  
      XREF
        BEGIN 
        PROC REQBS;                  # REQUEST BUFFER SPACE # 
        PROC SETBSTE;                # SET *BST* ENTRY #
        END 
  
# 
****  PROC GETBUF - XREF LIST END.
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMMON DECKS # 
*CALL,COMBFAS 
*CALL,COMXBST 
  
      ITEM I          I;             # LOOP COUNTER # 
      ITEM ORD        I;             # *BST* ENTRY ORDINAL #
                                               CONTROL EJECT; 
  
      ORD = 0;
  
      SLOWFOR I = 1 STEP 1 WHILE I LQ BSTL AND ORD EQ 0 
      DO                             # SEARCH BST FOR AVAILABLE ENTRY # 
        BEGIN 
        IF BST$ACQD[I] AND NOT BST$BUSY[I]
        THEN
          BEGIN 
          ORD = I;
          END 
  
        END 
  
      IF ORD EQ 0 
      THEN
        BEGIN  # NO AVAILABLE ENTRY # 
        SLOWFOR I = 1 STEP 1 WHILE I LQ BSTL AND ORD EQ 0 
        DO
          BEGIN  # SEARCH FOR AUTHORIZED ENTRY #
          IF BST$AUTH[I] AND NOT BST$ACQD[I]
          THEN
            BEGIN  # ENTRY FOUND #
            REQBS(I,FLAG);
            IF NOT FLAG 
            THEN
              BEGIN 
              RETURN;                # NO BUFFER AVAILABLE #
              END 
  
            ORD = I;
            END  # ENTRY FOUND #
  
          END  # SEARCH FOR AUTHORIZED ENTRY #
  
        END  # NO AVAILABLE ENTRY # 
  
      IF ORD NQ 0 
      THEN                           # IF AVAILABLE ENTRY FOUND # 
        BEGIN 
        SETBSTE(REQADR,REQIND,ORD);  # RETURN ADDRESSES TO CALLER # 
        FLAG = TRUE;                 # BUFFER ASSIGNED #
        END 
  
      ELSE
        BEGIN 
        FLAG = FALSE;                # NO BUFFER AVAILABLE #
        END 
  
      RETURN; 
      END  # GETBUF # 
  
    TERM
  
PROC GOBUF; 
  
# TITLE GOBUF - ASSIGN AVAILABLE BUFFERS.                             # 
  
      BEGIN  # GOBUF #
  
# 
**    GOBUF - ASSIGN AVAILABLE BUFFERS. 
* 
*     *GOBUF* PROCESSES THE *BST* TO SEE IF ANY ENTRIES ON THE WAITING
*     FOR LARGE BUFFER CHAINS CAN BE ASSIGNED A BUFFER. 
* 
*     PROC GOBUF. 
* 
*     EXIT       ALL ENTRIES WHICH HAVE BEEN ASSIGNED A BUFFER ARE ON 
*                THE *HLRQ*/*LLRQ* READY CHAIN.  THE LOCATION OF THE
*                LARGE BUFFER SPACE IS RETURNED IN THE REQUEST QUEUE
*                ENTRY. 
# 
  
# 
****  PROC GOBUF - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC ADD$LNK;                # ADD ENTRY TO CHAIN # 
        PROC DEL$LNK;                # DELETE ENTRY FROM CHAIN #
        PROC REQBS;                  # REQUEST BUFFER SPACE # 
        PROC SETBSTE;                # SET *BST* ENTRY #
        END 
  
# 
****  PROC GOBUF - XREF LIST END. 
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMMON DECKS # 
*CALL,COMBFAS 
*CALL,COMBCHN 
*CALL,COMXBST 
*CALL,COMXMSC 
  
      ITEM ACQFLAG    B;             # BUFFER ACQUIRED FLAG # 
      ITEM ENTADR     U;             # ENTRY ADDRESS #
      ITEM I          I;             # LOOP COUNTER # 
                                               CONTROL EJECT; 
  
      SLOWFOR I = 1 STEP 1 WHILE I LQ BSTL AND BST$AUTH[I]  ##
        AND (CHN$BOC[LCHN"LL$LGBUF"] NQ 0)
      DO
        BEGIN  # ASSIGN AVAILABLE BUFFERS # 
        IF BST$BUSY[I]
        THEN
          BEGIN 
          TEST I; 
          END 
  
        IF NOT BST$ACQD[I]
        THEN
          BEGIN  # ACQUIRE BUFFER # 
          REQBS(I,ACQFLAG); 
          IF NOT ACQFLAG
          THEN
            BEGIN 
            RETURN;                  # NO BUFFER AVAILABLE #
            END 
  
          END  # ACQUIRE BUFFER # 
  
        IF CHN$BOC[LCHN"LL$LGBUF"] NQ 0 
        THEN                         # IF *LLRQ* ENTRY WAITING #
          BEGIN 
          ENTADR = CHN$BOC[LCHN"LL$LGBUF"]; 
          SETBSTE(ENTADR,LLRQIND,I);
          DEL$LNK(ENTADR,LCHN"LL$LGBUF",0); 
          ADD$LNK(ENTADR,LCHN"LL$READY",0); 
          END 
  
        END  # ASSIGN AVAILABLE BUFFERS # 
  
      RETURN; 
      END  # GOBUF #
  
    TERM
PROC HLCPYCD((HLRQADR));
  
# TITLE HLCPYCD - *HLRQ*/*LLRQ* ROUTINE TO COPY CARTRIDGE TO DISK.    # 
  
      BEGIN  # HLCPYCD #
  
# 
**    HLCPYCD - *HLRQ*/*LLRQ* LINK ROUTINE TO COPY CARTRIDGE TO DISK. 
* 
*     *HLCPYCD* CALLS *CPY$SD* TO COPY DATA FROM A CARTRIDGE BUFFER 
*     TO THE DISK SPECIFIED IN THE *HLRQ* ENTRY.
*     *HLCPYCD* CHECKS THE STATUS AFTER THE REQUEST IS PROCESSED
*     AND DOES THE APPROPRIATE ERROR PROCESSING IF AN ERROR 
*     IS ENCOUNTERED IN WRITING THE DATA. 
* 
*     PROC HLCPYCD((HLRQADR)) 
* 
*     ENTRY      (HLRQADR) - ADDRESS OF THE *HLRQ* ENTRY. 
* 
*     EXIT       VOLUME COPIED TO M860 CARTRIDGE. 
* 
# 
  
      ITEM HLRQADR    U;             # *HLRQ* ENTRY ADDRESS # 
  
# 
****  PROC HLCPYCD - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC ADD$LNK;                # ADD ENTRY TO END OF CHAIN #
        END 
  
# 
****  PROC HLCPYCD - XREF LIST END. 
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMMON DECKS # 
*CALL,COMBFAS 
*CALL,COMBCHN 
*CALL,COMBCPR 
*CALL,COMBLRQ 
*CALL,COMBMCT 
*CALL,COMSPFM 
*CALL,COMXEMC 
*CALL,COMXFCQ 
*CALL,COMXHLR 
*CALL,COMXMSC 
  
      ITEM FLAG       B;             # STATUS FLAG #
      ITEM STAT       U;             # DRIVER ERROR STATUS #
      ITEM TEMP       U;             # SCRATCH CELL # 
  
                                               CONTROL EJECT; 
      P<HLRQ> = HLRQADR;
      P<LLRQ> = HLR$LRQADR[0];
  
      STAT = HLR$RESP[0]; 
      IF STAT EQ RESPTYP4"OK4"
      THEN
        BEGIN  # INDICATE NO ERROR #
        HLR$RESP[0] = ERRST"NOERR"; 
        END  # INDICATE NO ERROR #
  
      ELSE
        BEGIN  # PROCESS ERROR #
        HLR$RESP[0] = ERRST"TEMP";   # RESPONSE, UNLESS MODIFIED #
        HLR$ERRC[0] = STGERRC"HWPROB";
  
        IF STAT EQ RESPTYP4"DISK$FULL"
        THEN
          BEGIN 
          HLR$RESP[0] = ERRST"ABANDON"; 
          HLR$ERRC[0] = STGERRC"DSKFULL"; 
          END 
  
        IF STAT EQ RESPTYP4"RMS$FL$ERR" 
        THEN
          BEGIN 
          HLR$RESP[0] = ERRST"ABANDON"; 
          HLR$ERRC[0] = STGERRC"DSKERR";
          END 
  
        IF STAT EQ RESPTYP4"UN$RD$ERR"
        THEN
          BEGIN 
          IF HLR$RETRY[0] 
          THEN                       # FATAL ERROR #
            BEGIN 
            HLR$RESP[0] = ERRST"PERM";
            HLR$PEF[0] = AFPDE; 
            HLR$ERRC[0] = STGERRC"DATAERR"; 
            END 
  
          ELSE                       # RETRY ONE TIME # 
            BEGIN 
            HLR$RESP[0] = ERRST"RETRY"; 
            HLR$RETRY[0] = TRUE;
            END 
  
          END 
  
        IF STAT EQ RESPTYP4"PPU$D$PROB" 
        THEN
          BEGIN 
          IF HLR$RETRY[0] 
          THEN
            BEGIN       # FATAL PASS #
            HLR$RESP[0] = ERRST"PERM";
            HLR$PEF[0] = AFTMP;    # TEMPORARY PFM ERROR #
            HLR$ERRC[0] = STGERRC"PPUDPRB"; 
            END 
  
          ELSE
            BEGIN       # RETRY ONE TIME #
            HLR$RESP[0] = ERRST"RETRY"; 
            HLR$RETRY[0] = TRUE;
            END 
  
          END 
  
        IF STAT EQ RESPTYP4"VOL$HD$ERR" 
        THEN
          BEGIN 
          P<FCT> = HLR$FCTQ[0] + FCTQHL;
          SETFCTX(HLR$VOLAU[0]);
          FCT$AUCF(FWD,FPS) = 1;     # SET CONFLICT FLAG #
          HLR$RESP[0] = ERRST"PERM";
          HLR$PEF[0] = AFPSE; 
          HLR$ERRC[0] = STGERRC"CHKERR";
          END 
  
        IF STAT EQ RESPTYP4"M86$HDW$PR" 
        THEN
          BEGIN 
          HLR$RESP[0] = ERRST"RETRY"; 
          HLR$RETRY[0] = FALSE; 
          END 
  
        END  # PROCESS ERROR #
  
# 
*     RETURN TO CALLING PROGRAM.
# 
  
      RETURN; 
  
      END  # HLCPYCD #
  
    TERM
PROC HLCPYDC((HLRQADR));
  
# TITLE HLCPYDC - CONTROL ROUTINE FOR COPYING DISK TO CARTRIDGE.      # 
  
      BEGIN  # HLCPYDC #
  
# 
**    HLCPYDC - *HLRQ*/*LLRQ* LINK ROUTINE TO COPY DISK TO CARTRIDGE. 
* 
*     *HLCPYDC* CALLS *CPY$DS* TO COPY DATA FROM A DISK BUFFER
*     TO THE CARTRIDGE SPECIFIED IN THE *HLRQ* ENTRY. 
*     *HLCPYDC* CHECKS THE STATUS AFTER THE REQUEST IS PROCESSED
*     AND DOES THE APPROPRIATE ERROR PROCESSING IF AN ERROR 
*     IS ENCOUNTERED IN WRITING THE DATA. 
* 
*     PROC HLCPYDC((HLRQADR)) 
* 
*     ENTRY      (HLRQADR) - ADDRESS OF THE *HLRQ* ENTRY. 
* 
*     EXIT       VOLUME COPIED TO M860 CARTRIDGE. 
* 
# 
  
      ITEM HLRQADR    U;             # *HLRQ* ENTRY ADDRESS # 
  
# 
****  PROC HLCPYDC - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC ADD$LNK;                # ADD ENTRY TO END OF CHAIN #
        PROC RLSVOL;                 # RELEASE UNUSED AU #
        END 
  
# 
****  PROC HLCPYDC - XREF LIST END. 
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMMON DECKS # 
*CALL,COMBFAS 
*CALL,COMBCHN 
*CALL,COMBCPR 
*CALL,COMBLRQ 
*CALL,COMBMCT 
*CALL,COMBTDM 
*CALL,COMXFCQ 
*CALL,COMXHLR 
*CALL,COMXMSC 
  
  
      ITEM FLAG       B;             # STATUS FLAG #
      ITEM RELFIRST   U;             # FIRST AU TO RELEASE #
      ITEM RELNUM     U;             # NUMBER OF AU TO RELEASE #
      ITEM STAT       U;             # STATUS FROM *HLR$RESP* # 
      ITEM TEMP       U;             # SCRATCH CELL # 
  
                                               CONTROL EJECT; 
      P<HLRQ> = HLRQADR;
      P<LLRQ> = HLR$LRQADR[0];
  
# 
*     SET DEFAULT *HLR$RESP* VALUE AND RELEASE PARAMETERS 
*     IN CASE THEY ARE NOT SPECIFICALLY MODIFIED. 
# 
  
      STAT = HLR$RESP[0]; 
  
      IF STAT EQ RESPTYP4"OK4"
      THEN
        BEGIN  # INDICATE NO ERROR #
        HLR$RESP[0] = ERRST"NOERR"; 
        END  # INDICATE NO ERROR #
  
      ELSE
        BEGIN  # PROCESS ERROR #
  
        RELFIRST = HLR$VOLAU[0];
        RELNUM = HLR$VOLLN[0];
        HLR$RESP[0] = ERRST"RETRY"; 
  
        IF STAT EQ RESPTYP4"RMS$FL$ERR" 
        THEN
          BEGIN 
          HLR$RESP[0] = ERRST"ABANDON"; 
          HLR$ERRC[0] = ABANDON"DSKRDERR";
          END 
  
        P<FCT> = HLR$FCTQ[0] + FCTQHL;
  
        IF STAT EQ RESPTYP4"UN$WRT$ERR" 
        THEN
          BEGIN  # UNRECOVERED WRITE ERROR PROCESSING # 
  
          RELNUM = HLR$AUUD[0] - HLR$VOLAU[0];
          RLSVOL(HLRQADR,HLR$FCTQ[0],HLR$AUUD[0]+1,  ## 
            HLR$VOLLN[0] - RELNUM - 1);  # RELEASE AU AFTER FLAW #
  
          SETFCTX(HLR$AUUD[0]); 
          FCT$FAUF(FWD,FPS) = 1;
          FCT$FLAWS[0] = FCT$FLAWS[0] + 1;
          END  # UNRECOVERED WRITE ERROR PROCESSING # 
  
        IF STAT EQ RESPTYP4"EX$DMARK" 
        THEN
          BEGIN  # EXCESSIVE DEMARKS #
          SLOWFOR TEMP = HLR$VOLAU[0] STEP 1 UNTIL HLR$AUUD[0]
          DO
            BEGIN  # FLAW ALL AU THAT WERE USED # 
  
            SETFCTX(TEMP);
            FCT$FAUF(FWD,FPS) = 1;
            FCT$FLAWS[0] = FCT$FLAWS[0] + 1;
            END  # FLAW ALL AU THAT WERE USED # 
  
          RELNUM = HLR$VOLLN[0] - ( HLR$AUUD[0] - HLR$VOLAU[0]) - 1;
          RELFIRST = HLR$AUUD[0]+1;  # RELEASE REST OF AU # 
          END  # EXCESSIVE DEMARKS #
  
        IF STAT EQ RESPTYP4"M86$HDW$PR" 
        THEN                         # FORCE CARTRIDGE UNLOAD # 
          BEGIN 
          HLR$ERRC[0] = ERRST"SPECIAL"; 
          END 
  
# 
*     IF ERRORS, RELEASE ANY REMAINING UNFLAWED AU.  THEN RETURN
*     TO CALLING PROGRAM. 
# 
  
        HLR$VOLLN[0] = 0; 
        RLSVOL(HLRQADR,HLR$FCTQ[0], RELFIRST, RELNUM);  # RELEASE AU #
  
        END  # PROCESS ERROR #
  
      RETURN; 
      END  # HLCPYDC #
  
    TERM
PROC HLLDSET((HLRQADR));
  
# TITLE HLLDSET - TRANSFER *HLRQ* DATA TO *LLRQ*.                     # 
  
      BEGIN  # HLLDSET #
  
# 
**    HLLDSET - TRANSFER *HLRQ* DATA TO *LLRQ*. 
* 
*     *HLLDSET* MOVES RELEVANT *HLRQ* INFORMATION TO THE *LLRQ* ENTRY 
*     SO THE DRIVER HAS SUFFICIENT INFORMATION TO PROCESS THE 
*     FORTHCOMING LOAD CARTRIDGE REQUEST. 
* 
*     PROC HLLDSET((HLRQADR)) 
* 
*     ENTRY      (HLRQADR) - ADDRESS OF THE *HLRQ* ENTRY. 
* 
*     EXIT       NONE 
# 
  
      ITEM HLRQADR    U;             # *HLRQ* ENTRY ADDRESS # 
  
# 
****  PROC HLLDSET - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC LLRQENQ;                # *LLRQ* ENQUEUER #
        END 
  
# 
****  HLLDSET - XREF LIST END.
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMMON DECKS # 
*CALL,COMBFAS 
*CALL,COMBCPR 
*CALL,COMBLRQ 
*CALL,COMBMCT 
*CALL,COMBUCR 
*CALL,COMXEMC 
*CALL,COMXFCQ 
*CALL,COMXHLR 
*CALL,COMXMSC 
  
  
      ITEM LLRQADR    U;             # *LLRQ* ENTRY ADDRESS # 
  
  
  
  
  
      P<HLRQ> = HLRQADR;
      LLRQENQ(LLRQADR);              # GET *LLRQ* ENTRY # 
      P<LLRQ> = LLRQADR;
      HLR$LRQADR[0] = LLRQADR;
      LLR$UCPRA[0] = HLRQADR; 
      LLR$CSNT[0] = HLR$CSNTCU[0];
      LLR$Y[0] = HLR$Y[0];
      LLR$Z[0] = HLR$Z[0];
      LLR$SMA[0] = HLR$SM[0]; 
      LLR$RQI[0] = REQNAME"RQIINT"; 
      LLR$PRCNME[0] = REQTYP4"LOAD$CART"; 
      LLR$PRCST[0] = PROCST"INITIAL"; 
      P<FCT> = HLR$FCTQ[0] + FCTQHL;
  
      END  # HLLDSET #
  
    TERM
PROC HLLOAD((HLRQADR)); 
  
# TITLE HLLOAD - *HLRQ*/*LLRQ* INTERFACE ROUTINE TO LOAD CARTRIDGE.   # 
  
      BEGIN  # HLLOAD # 
  
# 
**    HLLOAD - *HLRQ*/*LLRQ* LINKING ROUTINE FOR LOADING CARTRIDGES.
* 
*     *HLLOAD* CALLS *HLLDSET* TO TRANSFER RELEVANT INFORMATION 
*     FROM THE *HLRQ* ENTRY TO THE *LLRQ* ENTRY FOR LOADING FILES.
*     *HLLOAD* CHECKS THE STATUS AFTER THE LOAD REQUEST IS PROCESSED
*     AND DOES THE APPROPRIATE ERROR PROCESSING IF AN ERROR 
*     IS ENCOUNTERED IN LOADING A CARTRIDGE.
* 
*     PROC HLLOAD((HLRQADR))
* 
*     ENTRY      (HLRQADR) - ADDRESS OF THE *HLRQ* ENTRY. 
* 
*     EXIT       *HLRQ* ENTRY ESTABLISHED.
* 
# 
  
      ITEM FLAG       B;             # STATUS FLAG #
      ITEM HLRQADR    U;             # *HLRQ* ENTRY ADDRESS # 
  
# 
****  PROC HLLOAD - XREF LIST BEGIN.
# 
  
      XREF
        BEGIN 
        PROC ADD$LNK;                # ADD ENTRY TO END OF CHAIN #
        PROC MSGAFDF;                # ISSUE ACCOUNT-DAYFILE MESSAGE #
        PROC HLLDSET;                # TRANSFER DATA TO *LLRQ* #
        END 
  
# 
****  PROC HLLOAD - XREF LIST END.
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMMON DECKS # 
*CALL,COMBFAS 
*CALL,COMBCHN 
*CALL,COMBCPR 
*CALL,COMBLRQ 
*CALL,COMBMCT 
*CALL,COMBTDM 
*CALL,COMSPFM 
*CALL,COMXEMC 
*CALL,COMXFCQ 
*CALL,COMXHLR 
*CALL,COMXMSC 
  
      ITEM STAGE      B;             # TRUE IF CALLED FROM *STAGER* # 
      ITEM STAT       U;             # STATUS (FROM *HLR$RESP*) # 
  
  
                                               CONTROL EJECT; 
      P<HLRQ> = HLRQADR;
      P<LLRQ> = HLR$LRQADR[0];
      P<FCT> = HLR$FCTQ[0] + FCTQHL;
      STAGE = HLR$HPN[0] EQ HLRPN"STAGE"; 
      IF HLR$RESP[0] EQ RESPTYP4"OK4" 
      THEN
        BEGIN  # NO ERROR # 
        HLR$RESP[0] = ERRST"NOERR"; 
        FCT$LCF[0] = FALSE;           # CLEAR LOST CARTRIDGEFLAG #
        END  # NO ERROR # 
  
      ELSE
        BEGIN  # PROCESS ERROR #
  
        STAT = HLR$RESP[0]; 
  
        IF STAGE
        THEN
          BEGIN 
          HLR$RESP[0] = ERRST"TEMP";  # DEFAULT FOR STAGE # 
          HLR$ERRC[0] = STGERRC"HWPROB";
          END 
  
        ELSE
          BEGIN 
          HLR$RESP[0] = ERRST"RETRY";  # DEFAULT FOR DESTAGER # 
          END 
  
        IF STAT EQ RESPTYP4"CELL$EMP" 
        THEN
          BEGIN  # SET LOST FLAG IN *FCT* # 
          FCT$LCF[0] = TRUE;
  
          IF STAGE
          THEN
            BEGIN 
            HLR$ERRC[0] = STGERRC"LOSTCART";
            END 
  
          END  # SET LOST FLAG IN *FCT* # 
  
        IF STAT EQ RESPTYP4"CART$LB$ERR"
        THEN
          BEGIN  # PROCESS CARTRIDGE LABEL ERROR #
          FCT$IAF[0] = TRUE;
  
          IF STAGE
          THEN
            BEGIN 
            HLR$RESP[0] = ERRST"PERM";
            HLR$PEF[0] = AFPSE; 
            HLR$ERRC[0] = STGERRC"CARTLBL"; 
            END 
  
          END  # PROCESS CARTRIDGE LABEL ERROR #
  
        IF STAGE
        THEN                         # DIAGNOSE OTHER PROBLEMS #
          BEGIN 
          IF STAT EQ RESPTYP4"UNK$CART" 
          THEN
            BEGIN 
            HLR$RESP[0] = ERRST"RETRY"; 
            END 
  
          IF STAT EQ RESPTYP4"SMA$OFF"
          THEN
            BEGIN 
            HLR$ERRC[0] = STGERRC"SMOFF"; 
            END 
  
          END 
  
          IF STAT EQ RESPTYP4"CSN$IN$USE" 
          THEN
            BEGIN 
            HLR$RESP[0] = ERRST"RSFULL";
            IF STAGE
            THEN
              BEGIN 
              HLR$ERRC[0] = STGERRC"CARTINUSE"; 
              END 
  
            END 
  
  
        END  # PROCESS ERROR #
  
      RETURN; 
      END  # HLLOAD # 
  
    TERM
PROC MSG((DFMSG),(OP)); 
  
# TITLE MSG - DISPLAY DAYFILE MESSAGE.                                # 
  
      BEGIN  # MSG #
  
# 
**    MSG - DISPLAY DAYFILE MESSAGE.
* 
*     *MSG* SEARCHES A MESSAGE FOR A TERMINATING CHARACTER AND
*     ZERO FILLS THE MESSAGE FROM THE TERMINATOR TO THE END 
*     OF THE MESSAGE. 
* 
*     PROC MSG((DFMSG),(OP))
* 
*     ENTRY      (DFMSG) - MESSAGE TO BE DISPLAYED, 40 CHARACTER
*                          MAXIMUM. 
*                (OP)    - MESSAGE ROUTING OPTION.
*                          (VALUES DEFINED IN *COMBFAS*)
* 
*     EXIT       THE MESSAGE HAS BEEN DISPLAYED AT THE LOCATION 
*                SPECIFIED BY (OP). 
# 
  
      ITEM DFMSG      C(40);         # MESSAGE TEXT # 
      ITEM OP         I;             # MESSAGE ROUTING OPTION # 
  
# 
*     PROC MSG - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC MESSAGE;                # ISSUE MESSAGE #
        END 
  
# 
*     PROC MSG - XREF LIST END. 
# 
  
      DEF BLANK #" "#;               # BLANK CHARACTER #
      DEF TERMCHAR   #";"#;          # TERMINATOR CHARACTER # 
  
      DEF LISTCON    #0#;            # DO NOT LIST COMMON DECKS # 
*CALL,COMBFAS 
  
      ITEM I          I;             # LOOP COUNTER # 
      ITEM CP         I;             # CHARACTER POSITION # 
  
                                               CONTROL EJECT; 
  
      CP = 0; 
      FASTFOR I = 0 STEP 1 WHILE I LS 40 AND CP EQ 0
      DO                             # FIND TERMINATOR #
        BEGIN 
        IF C<I,1>DFMSG EQ TERMCHAR
        THEN
          BEGIN 
          CP = I; 
          END 
  
        END 
  
      IF CP NQ 0
      THEN                           # ZERO FILL END OF MESSAGE # 
        BEGIN 
        B<CP*6,(40-CP)*6>DFMSG = 0; 
        END 
  
      MESSAGE(DFMSG,OP);             # ISSUE MESSAGE #
      RETURN; 
      END  # MSG #
  
    TERM
PROC REQBS((ORD),ACQFLAG);
  
# TITLE REQBS - REQUEST LARGE BUFFER SPACE.                           # 
  
      BEGIN  # REQBS #
  
# 
**    REQBS - REQUEST LARGE BUFFER SPACE. 
* 
*     *REQBS* REQUESTS ADDITIONAL MEMORY FOR A LARGE BUFFER.
* 
*     PROC REQBS((ORD),ACQFLAG) 
* 
*     ENTRY      (ORD) - ORDINAL OF *BST* ENTRY.
* 
*     EXIT       (ACQFLAG) - BUFFER ACQUIRED FLAG.
*                            = TRUE, BUFFER SPACE ACQUIRED. 
*                            = FALSE, MEMORY NOT AVAILABLE. 
*                IF THE BUFFER SPACE IS ACQUIRED, THE ADDRESSES OF THE
*                COPY CONTROL BLOCK, MSF FET, DISK FET, LABEL BUFFER
*                AND DATA BUFFER (WHICH MAKE UP THE LARGE BUFFER SPACE) 
*                ARE STORED IN THE *BST* ENTRY. 
* 
*     MESSAGES   *STF1, NNNNNN.*. 
# 
  
      ITEM ORD        I;             # ORDINAL OF *BST* ENTRY # 
      ITEM ACQFLAG    B;             # BUFFER ACQUIRED FLAG # 
  
# 
****  PROC REQBS - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC MNGMEM;                 # MANAGE MEMORY #
        PROC MSG;                    # ISSUE MESSAGE #
        FUNC XCDD C(10);             # CONVERT TO DISPLAY CODE #
        END 
  
# 
****  PROC REQBS - XREF LIST END. 
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMMON DECKS # 
*CALL,COMBFAS 
*CALL,COMBLBL 
*CALL,COMXACM 
*CALL,COMXBST 
*CALL,COMXCCB 
*CALL,COMXCTF 
*CALL,COMXJCA 
*CALL,COMXMSC 
  
      ITEM BUFADR     U;             # BUFFER ADDRESS # 
      ITEM DC$FL      C(10);         # DISPLAY CODED FIELD LENGTH # 
      ITEM LBUFLEN    I;             # LARGE BUFFER SPACE LENGTH #
                                               CONTROL EJECT; 
  
      LBUFLEN = CCBLEN + RFETL + RFHBL + DATABL;
      MNGMEM(LBUFLEN,BUFADR);        # GET ADDITIONAL FIELD LENGTH #
      IF BUFADR EQ 0
      THEN                           # IF REQUEST DENIED #
        BEGIN 
        ACQFLAG = FALSE;             # NO BUFFER SPACE AVAILABLE #
        RETURN; 
        END 
  
      BST$CCB[ORD] = BUFADR;         # STORE LOCATIONS IN ENTRY # 
      BST$DISKF[ORD] = BUFADR + CCBLEN; 
      BST$M86F[ORD] = BST$DISKF[ORD] + RFETL; 
      BST$DATA[ORD] = BST$M86F[ORD] + RFHBL;
      BST$ACQD[ORD] = TRUE; 
      ACQFLAG = TRUE;                # BUFFER SPACE ACQUIRED #
      RETURN; 
      END  # REQBS #
  
    TERM
PROC RLSBUF((REQADR));
  
# TITLE RLSBUF - RELEASE LARGE BUFFER.                                # 
  
      BEGIN  # RLSBUF # 
  
# 
**    RLSBUF - RELEASE LARGE BUFFER.
* 
*     *RLSBUF* ALLOWS THE CALLER TO RELINQUISH CONTROL OF A LARGE 
*     BUFFER AND CALLS *GOBUF* TO ASSIGN ANY AVAILABLE BUFFERS TO 
*     WAITING *HLRQ*/*LLRQ* PROCESSES.
* 
*     PROC RLSBUF((REQADR)) 
* 
*     ENTRY      (REQADR) - ADDRESS OF REQUEST QUEUE ENTRY. 
* 
*     EXIT       IF A *BST* ENTRY CONTROLLED BY *REQADR* IS FOUND, THE
*                ENTRY IS MARKED AVAILABLE AND THE *GLBRTRNB* FLAG IS 
*                SET. 
# 
  
      ITEM REQADR     U;             # REQUEST QUEUE ENTRY ADDRESS #
  
# 
****  PROC RLSBUF - XREF LIST BEGIN.
# 
  
      XREF
        BEGIN 
        PROC GOBUF;                  # ASSIGN AVAILABLE BUFFERS # 
        END 
  
# 
****  PROC RLSBUF - XREF LIST END.
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMMON DECKS # 
*CALL,COMBFAS 
*CALL,COMXBST 
*CALL,COMXCTF 
  
      ITEM I          I;             # LOOP VARIABLE #
                                               CONTROL EJECT; 
  
      SLOWFOR I = 1 STEP 1 WHILE I LQ BSTL
      DO
        BEGIN  # FIND ENTRY TO BE RELEASED #
        IF BST$REQA[I] EQ REQADR
        THEN
          BEGIN 
          BST$REQA[I] = 0;           # SET BUFFER AVAILABLE # 
          BST$BUSY[I] = FALSE;
          GOBUF;
          GLBRTRNB = TRUE;
          RETURN; 
          END 
  
        END  # FIND ENTRY TO BE RELEASED #
  
      RETURN; 
      END  # RLSBUF # 
  
    TERM
PROC RLSVOL(HLRQADR,FCTADR,VOLAU,VOLLN);
  
# TITLE RLSVOL - RELEASE UNUSED AU.                                   # 
  
      BEGIN  # RLSVOL # 
  
# 
**    RLSVOL - RELEASE UNUSED AU. 
* 
*     THIS PROCEDURE UPDATES AN *FCT* ENTRY TO MAKE THE 
*     INDICATED AU AVAILABLE FOR RE-ALLOCATION.  *RLSVOL* 
*     WILL CREATE THESE AU INTO ONE VOLUME AND LINK THIS
*     VOLUME INTO THE CORRECT CHAIN OF FREE AU. 
* 
*     RLSVOL(HLRQADR,FCTADR,VOLAU,VOLLN)
* 
*     ENTRY      (HLRQADR) - ADDRESS OF *HLRQ* ENTRY. 
*                (FCTADR) - ADDRESS OF *FCT* ENTRY. 
*                (VOLAU)   - FIRST AU OF THE VOLUME TO BE 
*                            MADE AVAILABLE FOR REUSE.
*                (VOLLN)  - LENGTH OF THE VOLUME TO BE RELEASED.
*                            (ZERO OR NEGATIVE IS LEGAL)
* 
*     EXIT                - THE CORRECT (LONG OR SHORT FILE) CHAIN
*                           OF VOLUMES AVAILABLE FOR ALLOCATION 
*                           IS UPDATED TO INCLUDE THIS VOLUME.
# 
  
      ITEM HLRQADR    U;             # *HLRQ* ENTRY ADDRESS # 
      ITEM FCTADR     U;             # ADDRESS OF *FCT* ENTRY # 
      ITEM VOLAU      U;             # INDEX OF FIRST AU OF THE VOLUME
                                     #
      ITEM VOLLN      I;             # LENGTH OF THE VOLUME # 
  
      DEF LISTCON #0#;               # DO NOT LIST COMMON DECKS # 
*CALL,COMBFAS 
*CALL,COMBMCT 
*CALL,COMXFCQ 
*CALL,COMXHLR 
  
      ITEM CAUF       U;             # CONTINUATION AU FIELD VALUE #
      ITEM I          I;             # LOOP INDEX # 
      ITEM LINK       U;             # VALUE OF LINK FIELD #
      ITEM NOTYET     B;             # LOOP TERMINATOR #
      ITEM PREV       U;             # LINK FIELD OF PREVIOUS CHAIN 
                                       ELEMENT #
      ITEM PREVLN     U;             # LENGTH OF PREVIOUS VOLUME #
                                               CONTROL EJECT; 
      P<FCT> = FCTADR + FCTQHL; 
      P<HLRQ> = HLRQADR;
  
      IF VOLLN LQ 0 
      THEN                           # NO-OP CALL # 
        BEGIN 
        RETURN; 
        END 
  
# 
*     INITIALIZE FOR SEARCH OF FREE VOLUME CHAIN. 
# 
  
      IF VOLAU LS FCT$CDP[0]
      THEN                           # USE SHORT FILE CHAIN # 
        BEGIN 
        LINK = FCT$FAUSF[0];
        END 
  
      ELSE                           # USE LONG FILE CHAIN #
        BEGIN 
        LINK = FCT$FAULF[0];
        END 
  
      PREV = 0; 
  
# 
*     SEARCH FREE VOLUME CHAIN TO DETERMINE WHERE TO ADD THIS VOLUME. 
# 
  
      NOTYET = TRUE;
      FOR I = 0 STEP 1 WHILE NOTYET 
      DO
        BEGIN 
        IF (LINK NQ 0)               # NOT END OF CHAIN # 
          AND (LINK LS VOLAU)        # NOT BEFORE THIS VOLUME # 
        THEN                         # TRY THE NEXT FREE VOLUME # 
          BEGIN 
          PREV = LINK;
          SETFCTX(LINK);
          PREVLN = FCT$LEN(FWD,FPS);
          LINK = FCT$LINK(FWD,FPS); 
          TEST I; 
          END 
  
        NOTYET = FALSE;              # TERMINATE SEARCH LOOP #
        END 
  
# 
*     VERIFY THAT THE NEW VOLUME DOES NOT INCLUDE ANY AU BELONGING
*     TO EITHER OF THE VOLUMES BETWEEN WHICH IT IS TO BE LINKED.
# 
  
      IF                             # NEW VOLUME OVERLAPS NEXT ONE # 
        (( LINK NQ 0)                ## 
        AND (VOLAU+VOLLN GR LINK))   ## 
        OR                           # PREVIOUS VOLUME OVERLAPS NEW ONE 
                                     #
        ((PREV NQ 0)                 ## 
        AND (PREV+PREVLN GR VOLAU)) 
      THEN                           # DO NOT ADD IN THE NEW VOLUME # 
        BEGIN 
        RETURN; 
        END 
  
# 
*     INITIALIZE NEW VOLUME ELEMENTS AND
*     INSERT NEW VOLUME INTO CHAIN AT THIS SPOT.
# 
  
      CAUF = 0;                      # FIRST CAUF FIELD = 0 # 
  
      FOR I = 0 STEP 1 UNTIL VOLLN-1
      DO
        BEGIN 
        SETFCTX(VOLAU+I);            # DEFINE *FWD* AND *FPS* # 
  
        FCT$CLFG(FWD,FPS) = 0;
        FCT$CAUF(FWD,FPS) = CAUF; 
        FCT$LEN(FWD,FPS) = VOLLN-I-1; 
        FCT$LINK(FWD,FPS) = LINK; 
  
        LINK = VOLAU; 
        CAUF = 1;                    # REMAINING CAUF FIELDS = 1 #
        END 
  
      IF PREV NQ 0
      THEN                           # LINK PREVIOUS VOLUME TO NEW
                                       VOLUME # 
        BEGIN 
        SETFCTX(PREV);
        FCT$LINK(FWD,FPS) = VOLAU;
        END 
  
      ELSE                           # UPDATE HEAD OF CORRECT CHAIN TO
                                       POINT TO NEW VOLUME #
        BEGIN 
        IF VOLAU LS FCT$CDP[0]
        THEN                         # UPDATE SHORT FILE POINTER #
          BEGIN 
          FCT$FAUSF[0] = VOLAU; 
          END 
  
        ELSE                         # UPDATE LONG FILE POINTER # 
          BEGIN 
          FCT$FAULF[0] = VOLAU; 
          END 
  
        END 
  
      IF HLRQADR NQ 0 
      THEN                           # UPDATE AVAILABLE AU LEFT ON
                                       CARTRIDGE #
        BEGIN 
        IF HLR$SH[0]
        THEN
          BEGIN 
          HLR$AUSF[0] = HLR$AUSF[0] + VOLLN;
          END 
  
        ELSE
          BEGIN 
          HLR$AULF[0] = HLR$AULF[0] + VOLLN;
          END 
  
        END 
  
      RETURN; 
      END  # RLSVOL # 
  
    TERM
PROC RLS$FCT(FCTQADDR,(REQADDR),RSTATUS); 
  
# TITLE RLS$FCT - RELEASE AN *FCTQ* ENTRY.                            # 
  
      BEGIN  # RLS$FCT #
  
# 
**    RLS$FCT - RELEASE AN *FCTQ* ENTRY.
* 
*     *RLS$FCT* RELEASES AN *FCT* ENTRY WHEN IT IS NO LONGER
*     NEEDED BY A PROCESS.
* 
*     PROC RLS$FCT(FCTQADDR,(REQADDR),RSTATUS)
* 
*     ENTRY      (FCTQADDR) - ADDRESS OF *FCTQ* ENTRY TO BE RELEASED. 
*                (REQADDR)  - ADDRESS OF *HLRQ* ENTRY, ELSE ZERO. 
* 
*     EXIT       (RSTATUS) - *CPUTFCT* ERROR STATUS (DEFINED IN 
*                            PROC *CPUTFCT* IN DECK *CATACC*).
* 
*     NOTES      *FCTQADDR* WILL BE ZERO UPON RETURN FROM THIS
*                PROCEDURE PROVIDING THE *FCTQ* ENTRY WAS FOUND AND 
*                THE USER COUNT DECREMENTED.
* 
*                IF THE CATALOG IS INTERLOCKED AND IF *REQADDR* IS
*                NONZERO, *CGETFCT* WILL PUT THE *HLRQ* ENTRY ON THE
*                "WAITING-FOR-CATALOG-INTERLOCK" CHAIN. 
# 
  
      ITEM FCTQADDR   U;             # *FCTQ* ADDRESS TO BE RELEASED #
      ITEM REQADDR    U;             # *HLRQ* REQUEST ADDRESS # 
      ITEM RSTATUS    U;             # *CPUTFCT* ERROR STATUS # 
  
# 
****  PROC RLS$FCT - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC ABORT;                  # ABORT #
        PROC ADD$LNK;                # ADD ENTRY TO CHAIN # 
        PROC CPUTFCT;                # PUT AN *FCT* ENTRY # 
        PROC DEL$LNK;                # DELETE ENTRY FROM CHAIN #
        PROC MESSAGE;                # INTERFACE TO *MESSAGE* MACRO # 
        PROC ZFILL;                  # ZERO FILL BUFFER # 
        END 
  
# 
****  PROC RLS$FCT - XREF LIST END. 
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMMON DECKS # 
*CALL,COMBFAS 
*CALL,COMBCHN 
*CALL,COMBMCT 
*CALL,COMXFCQ 
*CALL,COMXMSC 
                                               CONTROL EJECT; 
  
      RSTATUS = 0;
  
# 
*     IF THERE IS NO *FCTQ* ENTRY TO RELEASE, RETURN TO CALLER. 
# 
  
      IF FCTQADDR EQ 0
      THEN
        BEGIN 
        RETURN; 
        END 
  
      IF CHN$BOC[LCHN"FCT$ACT"] EQ 0
      THEN                           # NO *FCTQ* ENTRIES #
        BEGIN 
        FE$RTN[0] = "RLS$FCT."; 
        MESSAGE(FEMSG[0],UDFL1);
        ABORT;
        END 
  
# 
*     UPDATE *FCT* WITH THE CONTENT OF THE *FCTQ* ENTRY.
# 
  
      P<FCTQ> = FCTQADDR; 
      P<FCT> = FCTQADDR + FCTQHL; 
      CPUTFCT(FCTQFAMILY[0],FCTQSUBF[0],FCTQSMID[0],FCTQFCTORD[0],  ##
        P<FCT>,REQADDR,RSTATUS);
      IF RSTATUS NQ 0 
      THEN
        BEGIN 
        RETURN; 
        END 
  
# 
*     DO NOT DELETE THE *FCTQ* ENTRY IF THERE ARE STILL ACTIVE USERS. 
# 
  
      FCTQACTCNT[0] = FCTQACTCNT[0] - 1;
      IF FCTQACTCNT[0] NQ 0 
      THEN
        BEGIN 
        FCTQADDR = 0; 
        RETURN; 
        END 
  
# 
*     DELETE THE ENTRY FROM THE ACTIVE CHAIN. 
# 
  
      DEL$LNK(FCTQADDR,LCHN"FCT$ACT",0);
      ZFILL(FCTQ[0],FCTQHL+FCTENTL);
  
# 
*     MOVE THE DELETED ENTRY TO THE FREE SPACE CHAIN. 
# 
  
      ADD$LNK(FCTQADDR,LCHN"FCT$FRSPC",0);
      P<FCTQ> = FCTQADDR; 
      FCTQADDR = 0; 
      RETURN; 
      END  # RLS$FCT #
  
    TERM
PROC RMVBLNK(CHARBUF,(COUNT));
  
# TITLE RMVBLNK - REMOVE MULTIPLE BLANKS.                             # 
  
      BEGIN  # RMVBLNK #
  
# 
**    RMVBLNK - REMOVE MULTIPLE BLANKS. 
* 
*     *RMVBLNK* REPLACES STRINGS OF MULTIPLE BLANKS WITH A SINGLE 
*     BLANK AND REMOVES ALL BLANKS IMMEDIATELY PRECEEDING A COMMA 
*     OR A PERIOD.
* 
*     PROC RMVBLNK(CHARBUF,(COUNT)) 
* 
*     ENTRY      (CHARBUF) - CHARACTER STRING, LEFT JUSTIFIED, MAXIMUM
*                            OF 80 CHARACTERS.
*                (COUNT)   - NUMBER OF CHARACTERS.
* 
*     EXIT       (CHARBUF) - CHARACTER STRING PASSED IN WITH EXCESS 
*                            BLANKS REMOVED.
# 
  
      ITEM CHARBUF    C(80);         # CHARACTER BUFFER # 
      ITEM COUNT      I;             # CHARACTER COUNT #
  
      DEF BLANK   #" "#;             # DISPLAY CODE BLANK # 
      DEF COMMA      #","#;          # DISPLAY CODE COMMA # 
      DEF PERIOD     #"."#;          # DISPLAY CODE PERIOD #
  
      DEF LISTCON    #0#;            # DO NOT LIST COMMON DECKS # 
*CALL,COMBFAS 
  
      ITEM CHARPOS    I;             # CHARACTER POSITION # 
      ITEM I          I;             # LOOP COUNTER # 
      ITEM NEXTCHAR   C(1);          # NEXT CHARACTER # 
      ITEM TEMPBUF    C(80);         # TEMPORARY BUFFER # 
                                               CONTROL EJECT; 
  
      TEMPBUF = CHARBUF;
      C<0,COUNT>CHARBUF = BLANK;
      CHARPOS = 0;
  
# 
*     TRANSFER CHARACTERS, REMOVING MULTIPLE BLANKS.
# 
  
      SLOWFOR I = 0 STEP 1 WHILE I LS COUNT 
      DO
        BEGIN  # TRANSFER # 
        NEXTCHAR = C<I+1,1>TEMPBUF; 
        IF C<I,1> TEMPBUF EQ BLANK   ## 
          AND (NEXTCHAR EQ BLANK OR NEXTCHAR EQ COMMA  ## 
          OR NEXTCHAR EQ PERIOD) AND I NQ COUNT-1 
        THEN
          BEGIN 
          TEST I;                    # IGNORE MULTIPLE BLANKS # 
          END 
  
        C<CHARPOS,1>CHARBUF = C<I,1>TEMPBUF;
        CHARPOS = CHARPOS + 1;
        END  # TRANSFER # 
  
      RETURN; 
      END  # RMVBLNK #
  
    TERM
PROC RTRNBUF; 
  
# TITLE RTRNBUF - RETURN LARGE BUFFER SPACE.                          # 
  
      BEGIN  # RTRNBUF #
  
# 
**    RTRNBUF - RETURN LARGE BUFFER SPACE.
* 
*     *RTRNBUF* RETURNS MEMORY OCCUPIED BY UNUSED BUFFERS TO REDUCE 
*     EXEC-S FIELD LENGTH.
* 
*     PROC RTRNBUF. 
* 
*     EXIT       (GLBRTRNB) - FALSE.
*                THE ACQUIRED FLAG IS CLEARED IN *BST* ENTRIES WHOSE
*                BUFFER SPACE IS RELEASED.
* 
*     MESSAGES   *STF2, NNNNNN.*. 
# 
  
# 
****  PROC RTRNBUF - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC MNGMEM;                 # MANAGE MEMORY #
        PROC MSG;                    # ISSUE MESSAGE #
        FUNC XCDD C(10);             # CONVERT TO DISPLAY CODE #
        END 
  
# 
****  PROC RTRNBUF - XREF LIST END. 
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMMON DECKS # 
*CALL,COMBFAS 
*CALL,COMBLBL 
*CALL,COMXACM 
*CALL,COMXBST 
*CALL,COMXCCB 
*CALL,COMXCTF 
*CALL,COMXJCA 
*CALL,COMXMSC 
  
      ITEM COUNT      I;             # UNUSED BUFFER COUNT #
      ITEM DC$FL      C(10);         # DISPLAY CODED FIELD LENGTH # 
      ITEM I          I;             # LOOP COUNTER # 
      ITEM REDUCEFL   I;             # FIELD LENGTH REDUCTION VALUE # 
      ITEM STAT       I;             # STATUS # 
                                               CONTROL EJECT; 
  
      GLBRTRNB = FALSE; 
      COUNT = 0;
      SLOWFOR I = BSTL STEP -1 WHILE I GR 0 AND NOT BST$BUSY[I] 
      DO                             # SEARCH *BST* FOR FREE ENTRIES #
        BEGIN 
        IF BST$ACQD[I]
        THEN
          BEGIN 
          COUNT = COUNT + 1;         # COUNT ACQUIRED, FREE ENTRIES # 
          END 
  
        END 
  
      IF COUNT EQ 0 
      THEN                           # NO BUFFER SPACE TO BE RELEASED # 
        BEGIN 
        RETURN; 
        END 
  
      REDUCEFL = -(COUNT * (CCBLEN + (2 * RFETL) + DATABL + LABLEN)); 
      MNGMEM(REDUCEFL,STAT);
      IF STAT NQ 0
      THEN
        BEGIN  # MEMORY REDUCTION HONORED # 
        FASTFOR I = BSTL STEP -1 WHILE COUNT NQ 0 
        DO
          BEGIN 
          IF BST$ACQD[I]
          THEN
            BEGIN 
            COUNT = COUNT - 1;
            BST$ACQD[I] = FALSE;     # CLEAR ACQUIRED FLAG #
            END 
  
          END 
  
        END  # MEMORY REDUCTION HONORED # 
  
      RETURN; 
      END  # RTRNBUF #
  
    TERM
PROC SETBSTE((REQADR),(REQIND),(ORD));
  
# TITLE SETBSTE - SET *BST* ENTRY BUSY.                               # 
  
      BEGIN  # SETBSTE #
  
# 
**    SETBSTE - SET *BST* ENTRY BUSY. 
* 
*     *SETBSTE* ASSIGNS THE SPECIFIED *BST* ENTRY TO A HIGH LEVEL/LOW 
*     LEVEL PROCESS AND RETURNS THE LOCATION OF THE LARGE BUFFER SPACE
*     IN THE REQUEST QUEUE ENTRY. 
* 
*     PROC SETBSTE((REQADR),(REQIND),(ORD)) 
* 
*     ENTRY      (REQADR) - ADDRESS OF HIGH LEVEL/LOW LEVEL REQUEST 
*                           QUEUE ENTRY.
*                (REQIND) - HIGH LEVEL/LOW LEVEL REQUEST INDICATOR. 
*                           = TRUE, HIGH LEVEL REQUEST. 
*                           = FALSE, LOW LEVEL REQUEST. 
*                (ORD)    - *BST* ENTRY ORDINAL.
* 
*     EXIT       (BST$REQA[ORD]) = (REQADR).
*                (BST$BUSY[ORD]) = TRUE.
*                IF THE REQUEST IS A HIGH LEVEL REQUEST, THE ADDRESSES
*                OF THE COPY CONTROL BLOCK, MSF FET, DISK FET, LABEL
*                BUFFER AND DATA BUFFER (WHICH MAKE UP THE LARGE
*                BUFFER) ARE RETURNED IN THE *HLRQ* ENTRY.  IF THE
*                REQUEST IS A LOW LEVEL REQUEST, THE ADDRESSES OF THE 
*                MSF AND DISK FET-S ARE RETURNED IN THE *LLRQ* ENTRY
*                AND THE FET-S ARE INITIALIZED (BUFFER POINTERS SET). 
# 
  
      ITEM REQADR     U;             # REQUEST ADDRESS #
      ITEM REQIND     B;             # REQUEST TYPE INDICATOR # 
      ITEM ORD        I;             # *BST* ENTRY ORDINAL #
  
# 
****  PROC SETBSTE - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC ZFILL;                  # ZERO FILL BUFFER # 
        PROC ZSETFET;                # INITIALIZE A FET # 
        END 
  
# 
****  PROC SETBSTE - XREF LIST END. 
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMMON DECKS # 
*CALL,COMBFAS 
*CALL,COMBFET 
*CALL,COMBLBL 
*CALL,COMBLRQ 
*CALL,COMXBST 
*CALL,COMXCCB 
*CALL,COMXHLR 
  
      ITEM LENGTH     I;             # BUFFER SPACE LENGTH #
  
      BASED 
      ARRAY LBUF [0:0] P(1); ;       # LARGE BUFFER SPACE # 
                                               CONTROL EJECT; 
  
      BST$REQA[ORD] = REQADR;        # SET *BST* ENTRY BUSY # 
      BST$BUSY[ORD] = TRUE; 
      P<LBUF> = BST$CCB[ORD];        # ZERO FILL BUFFER SPACE # 
      LENGTH = CCBLEN + RFETL + RFHBL + DATABL; 
      ZFILL(LBUF[0],LENGTH);
      P<LLRQ> = REQADR; 
  
      LLR$CCB[0] = BST$CCB[ORD];
      LLR$DSKFET[0] = BST$DISKF[ORD]; 
      LLR$MSFET[0] = BST$M86F[ORD]; 
      LLR$DA[0] = BST$DATA[ORD];
  
      RETURN; 
      END  # SETBSTE #
  
    TERM
PROC UASTPRM((FAM),(SFX),(SMX),(FCTADR),STAT);
  
# TITLE UASTPRM - UPDATE *AST* AND PREAMBLE.                          # 
  
      BEGIN  # UASTPRM #
  
# 
**    UASTPRM((FAM),(SFX),(SMX),(FCTADR),STAT). 
* 
*     WHEN AN *FCT* ENTRY HAS BEEN UPDATED SUCH THAT ITS
*     ALLOCATION STATUS HAS CHANGED (MORE OR FEWER AU AVAILABLE,
*     CHANGE IN *OCL* OR USABILITY, ETE.), THIS ROUTINE IS
*     CALLED TO UPDATE THE CORRESPONDING *AST* ENTRY AND THEN 
*     UPDATE THE PREAMBLE FOR THE ASSOCIATED STORAGE MODULE.
* 
*     ENTRY     (FAM)    - FAMILY NAME. 
*               (SFX)    - SUBFAMILY INDEX. 
*               (SMX)    - STORAGE MODULE INDEX.
*               (FCTADR) - ADDRESS OF *FCT* ENTRY.
*                          =0 *AST* IS IN CORE ALREADY. 
* 
*     EXIT       (STAT)     - STATUS.  =0, IF NO ERRORS.
*                AST        - UPDATED ON DISK.
*                PREAMBLE   - UPDATED ON DISK AND IN MEMORY.
# 
  
      ITEM FAM        C(7);          # FAMILY # 
      ITEM SFX        U;             # SUBFAMILY INDEX #
      ITEM SMX        U;             # STORAGE MODULE INDEX # 
      ITEM FCTADR     U;             # ADDRESS OF *FCT* ENTRY # 
      ITEM STAT       U;             # REPLAY STATUS #
  
# 
****  PROC UASTPRM - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC ANLZAST;                # ANALYZE *AST* #
        PROC CRDAST;                 # READ *AST* TO MEMORY # 
        PROC CWTAST;                 # WRITE *AST* BACK TO DISK # 
        PROC OCTSRCH;                # OPEN CATALOG SEARCH #
        END 
  
# 
****  PROC UASTPRM - XREF LIST END. 
# 
  
  
      DEF LISTCON #0#;               # DO NOT LIST COMMON DECKS # 
*CALL,COMBFAS 
*CALL,COMBCMD 
*CALL,COMBCMS 
*CALL,COMBMCT 
*CALL,COMXFCQ 
*CALL,COMXMSC 
  
  
      ITEM FCTLX      U;             # INDEX TO BEST CARTRIDGE FOR LONG 
                                       FILES #
      ITEM FCTSX      U;             # INDEX TO BEST CARTRIDGE FOR
                                       SHORT FILES #
      ITEM GPLN       U;             # AU ON BEST GROUP # 
      ITEM I          U;             # LOOP INDEX # 
      ITEM J          U;             # LOOP INDEX # 
      ITEM LINK       U;             # INDEX OF NEXT VOLUME IN CHAIN #
      ITEM PREV       U;             # PREVIOUS LINK VALUE #
      ITEM TMP1       U;             # TEMPORARY #
      ITEM TOTAL      U;             # TOTAL AU AVAILABLE FOR 
                                       ALLOCATION # 
  
                                               CONTROL EJECT; 
  
# 
*     LOCATE PREAMBLE AND READ IN *AST* (IF *FCTADR* NQ 0). 
# 
  
      OCTSRCH(FAM,SFX,TMP1,0,STAT); 
      IF STAT EQ CMASTAT"NOERR" AND FCTADR NQ 0 
      THEN
        BEGIN 
        CRDAST(FAM,SFX,SMX,ASTBADR,0,STAT); 
        END 
  
      IF STAT NQ CMASTAT"NOERR" 
      THEN
        BEGIN 
        RETURN; 
        END 
  
      P<AST> = ASTBADR; 
      P<PREAMBLE> = OCT$PRMA[TMP1]; 
  
# 
*     UPDATE *AST INFORMATION FOR CARTRIDGE.
# 
  
      IF FCTADR NQ 0
      THEN
        BEGIN  # *AST* UPDATE # 
        P<FCT> = FCTADR + FCTQHL; 
        TMP1 = FCT$ORD[0];
        FOR I = 1 STEP 1 UNTIL 2
        DO
          BEGIN  # FREE SPACE CALCULATIONS #
          IF I EQ 1 
          THEN
            BEGIN 
            LINK = FCT$FAUSF[0];
            END 
  
          ELSE
            BEGIN 
            LINK = FCT$FAULF[0];
            AST$AUSF[TMP1] = TOTAL; 
            END 
  
          TOTAL = 0;
          PREV = 0; 
          SLOWFOR J = 0 WHILE LINK GR PREV
          DO
            BEGIN 
            SETFCTX(LINK);
            TOTAL = TOTAL + FCT$LEN(FWD,FPS) + 1; 
            PREV = LINK;
            LINK = FCT$LINK(FWD,FPS); 
            END 
  
          END  # FREE SPACE CALCULATIONS #
  
        AST$FLAWS[TMP1] = FCT$FLAWS[0]; 
        AST$AULF[TMP1] = TOTAL; 
        AST$NOCLF[TMP1] = FCT$OCLF[0] EQ 7; 
        AST$AAF[TMP1] = NOT ( FCT$IAF[0]  ##
          OR FCT$LCF[0] OR FCT$FCF[0] OR FCT$EEF[0]); 
  
        END  # *AST* UPDATE # 
  
# 
*     DETERMINE THE BEST CARTRIDGES AND GROUP FOR SHORT AND 
*     LONG FILES.  ENTER AVAILABLE AU FOR EACH INTO *AST*.
# 
  
      ANLZAST(SMX,999999,999999,FCTSX,FCTLX,TMP1,GPLN); 
      IF FCTSX EQ 0 
      THEN
        BEGIN 
        PRM$MXAUS[SMX] = 0; 
        END 
      ELSE
        BEGIN 
        PRM$MXAUS[SMX] = AST$AUSF[FCTSX]; 
        END 
  
      IF FCTLX EQ 0 
      THEN
        BEGIN 
        PRM$MXAUL[SMX] = 0; 
        END 
      ELSE
        BEGIN 
        PRM$MXAUL[SMX] = AST$AULF[FCTLX]; 
        END 
  
      PRM$MXAUGR[SMX] = GPLN; 
  
# 
*     CALL *CWTAST* TO WRITE THE *AST* AND PREAMBLE TO DISK.
# 
  
      CWTAST(FAM,SFX,SMX,ASTBADR,0,STAT); 
  
      RETURN; 
      END  # UASTPRM #
  
    TERM
PROC UPUSAGE((HLRQADR),(FCTADR)); 
  
# TITLE UPUSAGE - UPDATE CARTRIDGE USAGE STATISTICS.                  # 
  
      BEGIN  # UPUSAGE #
  
# 
**    UPUSAGE - UPDATE CARTRIDGE USAGE STATISTICS.
* 
*     *UPUSAGE* ADDS CARTRIDGE USAGE INFORMATION FROM FIELDS
*     IN THE *HLRQ* ENTRY TO THE CORRESPONDING FIELDS IN THE
*     *FCT* ENTRY.
* 
*     PROC ((HLRQADR),(FCTADR)).
* 
*     ENTRY     (HLRQADR)  - ADDRESS OF *HLRQ* ENTRY. 
*               (FCTADR)   - ADDRESS OF *FCT* ENTRY.
*               (HLR$UUU)  - USAGE FIELDS IN *HLRQ* ENTRY.
* 
*     EXIT      FCT        - USAGE FIELDS IN THE *FCT* ENTRY
*                            ARE INCREMENTED.  THE *FCT* ENTRY IS 
*                            LEFT IN MEMORY.
# 
  
  
      ITEM HLRQADR    U;             # *HLRQ* ADDRESS # 
      ITEM FCTADR     U;             # *FCT* ADDRESS #
  
      DEF LISTCON #0#;               # DO NOT LIST COMMON DECKS # 
*CALL,COMBFAS 
*CALL,COMBCMD 
*CALL,COMBMCT 
*CALL,COMXFCQ 
*CALL,COMXHLR 
                                               CONTROL EJECT; 
      P<HLRQ> = HLRQADR;
      P<FCT> = FCTADR + FCTQHL; 
  
      FCT$STRD[0] = FCT$STRD[0] + HLR$STRD[0];
      FCT$STWR[0] = FCT$STWR[0] + HLR$STWR[0];
  
      FCT$SRDE[0] = FCT$SRDE[0] + HLR$SRDE[0];
      FCT$SWRE[0] = FCT$SWRE[0] + HLR$SWRE[0];
  
      FCT$HRDE[0] = FCT$HRDE[0] + HLR$HRDE[0];
      FCT$STDM[0] = FCT$STDM[0] + HLR$STDM[0];
      FCT$CRLD[0] = FCT$CRLD[0] + HLR$CRLD[0];
      FCT$LDER[0] = FCT$LDER[0] + HLR$LDER[0];
  
  
      HLR$USE1[0] = 0;
      HLR$USE2[0] = 0;
      HLR$USE3[0] = 0;
  
      RETURN; 
  
      END  # UPUSAGE #
  
    TERM
