ACCCAT
PROC BFLUSH((QRADR),ERSTAT);
# TITLE BFLUSH - FLUSHES THE I/O BUFFER.                              # 
      BEGIN  # BFLUSH # 
  
# 
**    BFLUSH - FLUSHES THE I/O BUFFER.
* 
*     *BFLUSH* FLUSHES THE *FCT* I/O BUFFER AND CLEARS THE BUFFER 
*     MODIFIED FLAG IF THE DATA IN THE BUFFER HAS BEEN MODIFIED.
* 
*     BFLUSH - IS CALLED BY CBUFMAN,CEXTSC,CFLUSH,CRELSLK,CRMUSC. 
* 
*     BFLUSH - IS CALLED BY CBUFMAN,CEXTSC,CFLUSH,CRELSLK,
*              CRMVSC,ASVAL,VLAMSF,VLAPFC,VLBICT,VLBLDVT, 
*              VLCFS,VLFIX,VLNCS,VLSCH,VLSUBFM,VLWFIX.
* 
*     PROC BFLUSH((QRADR),ERSTAT) 
* 
*     ENTRY      (QRADR) - *HLRQ* ENTRY ADDRESS, ELSE ZERO. 
* 
*     EXIT       (ERSTAT) - ERROR STATUS. 
*                           (VALUES DEFINED IN *COMACMS*) 
*                           =  NO ERRORS. 
*                           =  *CIO* ERROR. 
*                THE I/O BUFFER HAS BEEN FLUSHED IF NECESSARY AND THE 
*                BUFFER MODIFIED FLAG CLEARED.
# 
  
      ITEM QRADR      U;             # *HLRQ* ENTRY ADDRESS # 
      ITEM ERSTAT     I;             # ERROR STATUS # 
  
# 
****  PROC BFLUSH - XREF LIST BEGIN.
# 
  
      XREF
        BEGIN 
        PROC CPIOERR;                # PROCESS MSF CATALOG I/O ERROR #
        PROC REWRITE;              # REWRITE DATA FROM IO BUFFER #
        PROC ZSETFET;                # INITIALIZES A FET #
        END 
  
# 
****  PROC BFLUSH - XREF LIST END.
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBCMD 
*CALL COMBCMS 
*CALL COMBFET 
*CALL COMBMCT 
*CALL COMSPFM 
  
      ITEM ORD        I;             # ORDINAL OF *OCT* ENTRY # 
CONTROL EJECT;
  
      ORD = FB$ORD[0];
  
      IF FB$BMF[0]
      THEN
        BEGIN  # BUFFER MODIFIED #
  
# 
*     WRITE OUT BUFFER. 
# 
  
        FB$BMF[0] = FALSE;           # CLEAR BUFFER MODIFIED FLAG # 
        ZSETFET(FCTFADR,OCT$LFN[ORD],FCTBADR,OCT$BUFL[ORD],RFETL);
        FET$EP[0] = TRUE; 
        FET$IN[0] = FET$FRST[0] + OCT$BUFL[ORD] - 1;
        FET$R[0] = TRUE;
        FET$RR[0] = FB$PRUNUM[0]; 
        REWRITE(FETSET[0],RCL); 
        IF FET$AT[0] NQ 0 
        THEN
          BEGIN 
          CPIOERR(OCT$FAM[ORD],OCT$SUBF[ORD],QRADR,ERSTAT,FETSET[0]); 
          RETURN; 
          END 
  
        END  # BUFFER MODIFIED #
  
      IF OCT$ATTM[ORD] NQ "M" 
      THEN                           # IF NOT OPEN IN MODIFY MODE # 
        BEGIN 
        FB$CWRD[ORD] = 0;            # CLEAR BUFFER CONTROL WORD #
        END 
  
      RETURN; 
      END  # BFLUSH # 
  
    TERM
PROC CADDSC((FAMNM),(SUBF),(SMID ),(NUM),(QRADDR),ERRSTAT); 
# TITLE CADDSC - ADD SUBCATALOG.                                      # 
      BEGIN  # CADDSC # 
  
# 
**    CADDSC - ADD SUBCATALOG.
* 
*     *CADDSC* EXPANDS THE CATALOG FILE WITH SPACE FOR AN ADDITIONAL
*     SUBCATALOG WITH THE SPECIFIED NUMBER OF *FCT* AND *AST* ENTRIES.
*     THE CATALOG MUST BE OPEN IN MODIFY MODE.
* 
*     CADDSC - IS CALLED  BY ADDCSU.
* 
*     CADDSC - IS CALLED BY ADDCSU. 
* 
*     PROC CADDSC((FAMNM),(SUBF),(SMID ),(NUM),(QRADDR),ERRSTAT)
* 
*     ENTRY      (FAMNM)  - FAMILY NAME, LEFT JUSTIFIED, ZERO FILLED, 
*                           7 CHARACTER MAXIMUM.
*                (SUBF)   - SUBFAMILY DESIGNATOR. 
*                (SMID )  - NUMERIC SM  IDENTIFIER. 
*                (NUM)    - NUMBER OF *FCT* (AND *AST*) ENTRIES TO ADD. 
*                (QRADDR) - *HLRQ* ENTRY ADDRESS, ELSE ZERO.
* 
*     EXIT       THE SUBCATALOG HAS BEEN ADDED AND THE CATALOG PREAMBLE 
*                HAS BEEN UPDATED TO REFLECT THE CHANGE.
*                (ERRSTAT) - ERROR STATUS.
*                            (VALUES DEFINED IN *COMBCMS*)
*                            =  NO ERRORS.
*                            =  CATALOG FILE INTERLOCKED. 
*                            =  CATALOG NOT OPEN. 
*                            =  CATALOG NOT OPEN IN MODIFY MODE.
*                            =  SUBCATALOG ALREADY EXISTS.
*                            =  *CIO* ERROR.
*                IF THE DESIRED FAMILY IS NOT FOUND ON A *SETPFP*, AN 
*                ERROR MESSAGE IS ISSUED AND THE PROGRAM IS ABORTED.
* 
*     NOTES      THE CATALOG IS RE-ATTACHED IN WRITE MODE BEFORE ADDING 
*                THE SUBCATALOG, (IN ORDER TO EXTEND THE CATALOG), AND
*                WHEN FINISHED, THE FILE IS ATTACHED IN MODIFY MODE 
*                AGAIN.  SPACE FOR A SUBCATALOG IS ALWAYS ADDED IN FULL 
*                PRU-S, SO THAT EACH *FCT* AND *AST* BEGINS AT A PRU
*                BOUNDARY.  HOWEVER, THE LENGTH OF THE *FCT* AND *AST*
*                MAINTAINED IN THE CATALOG PREAMBLE REFLECTS THE
*                NUMBER OF ENTRIES SPECIFIED BY (NUM).
* 
*     MESSAGES   * PROGRAM ABNORMAL, CADDSC.*.
# 
  
      ITEM FAMNM      C(7);          # FAMILY NAME #
      ITEM SUBF       U;             # SUBFAMILY DESIGNATOR # 
      ITEM SMID       U;             # SM  IDENTIFIER # 
      ITEM NUM        I;             # NUMBER OF ENTRIES TO ADD # 
      ITEM QRADDR     U;             # *HLRQ* ENTRY ADDRESS # 
      ITEM ERRSTAT    I;             # ERROR STATUS # 
  
# 
**** PROC CADDSC - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC ABORT;                  # ABORT #
        PROC BKSPRU;                 # BACKSPACE PHYSICAL RECORDS # 
        PROC CDEFTF;                 # DEFINE TEMPORARY CATALOG # 
        PROC CPIOERR;                # PROCESS MSF CATALOG I/O ERROR #
        PROC MESSAGE;                # ISSUE MESSAGE #
        PROC OCTSRCH;                # SEARCH OPEN CATALOG TABLE #
        PROC READ;                   # READ FILE TO *CIO* BUFFER #
        PROC REPLCAT;                # REPLACE MSF CATALOG #
        PROC REWIND;                 # REWIND A FILE #
        PROC RPHR;                   # READ PRU TO *CIO* BUFFER # 
        PROC SETPFP;                 # SET PERMANENT FILE PARAMETERS #
        PROC WPHR;                   # WRITE PRU FROM *CIO* BUFFER #
        PROC WRITE;                  # WRITE DATA FROM *CIO* BUFFER # 
        PROC WRITEF;                 # WRITE END OF FILE #
        PROC WRITEW;                 # WRITE DATA FROM WORKING BUFFER # 
        PROC ZSETFET;                # INITIALIZES A FET #
        END 
  
# 
****  PROC CADDSC - XREF LIST END.
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBCMD 
*CALL COMBCMS 
*CALL COMBFET 
*CALL COMXMSC 
*CALL COMBMCT 
*CALL COMBPFP 
  
      ITEM I          I;             # LOOP COUNTER # 
      ITEM LOCAT      I;             # LOCATION OF NEW SUBCATALOG # 
      ITEM NAST       I;             # NUMBER OF PRU-S IN *AST* # 
      ITEM NFCT       I;             # NUMBER OF PRU-S IN *FCT* # 
      ITEM ORD        I;             # ORDINAL OF *OCT* ENTRY # 
      ITEM STAT       I;             # ATTACH STATUS #
      ITEM TEMP       I;             # TEMPORARY STORAGE #
CONTROL EJECT;
  
      OCTSRCH(FAMNM,SUBF,ORD,QRADDR,ERRSTAT);  # GET *OCT* ORDINAL #
      IF ERRSTAT NQ CMASTAT"NOERR"
      THEN
        BEGIN 
        RETURN;                      # RETURN ERROR STATUS #
        END 
  
      P<PREAMBLE> = OCT$PRMA[ORD];
      IF PRM$SCW1[SMID ] NQ 0 
      THEN                           # SUBCATALOG ALREADY EXISTS #
        BEGIN 
        ERRSTAT = CMASTAT"SCEXISTS";
        RETURN;                      # RETURN ERROR STATUS #
        END 
  
      IF OCT$ATTM[ORD] NQ "M" 
      THEN                           # NOT OPEN IN MODIFY MODE #
        BEGIN 
        ERRSTAT = CMASTAT"MODERR";
        RETURN;                      # RETURN ERROR STATUS #
        END 
  
# 
*     DEFINE TEMPORARY FILE AND COPY CATALOG TO IT. 
# 
  
      PFP$WRD0[0] = 0;               # SET FAMILY AND USER INDEX #
      PFP$FAM[0] = OCT$FAM[ORD];
      PFP$UI[0] = DEF$UI + OCT$SUBF[ORD]; 
      PFP$FG1[0] = TRUE;
      PFP$FG4[0] = TRUE;
      SETPFP(PFP);
      IF PFP$STAT[0] NQ 0 
      THEN                           # FAMILY NOT FOUND # 
        BEGIN 
        CMA$RTN[0] = "CADDSC."; 
        MESSAGE(CMAMSG,UDFL1);       # ISSUE ERROR MESSAGE #
        ABORT;
        END 
  
  
      ZSETFET(TFETADR,OCT$LFN[ORD],TBUFADR,TBUFL,RFETL);
      ZSETFET(TFETADR+RFETL,TSFMCAT,TBUFADR,TBUFL,RFETL); 
      P<FETSET> = TFETADR;
      FET$EP[0] = TRUE; 
      FET$EP[1] = TRUE; 
      REWIND(FETSET[0],NRCL); 
      CDEFTF(FETSET[1],ERRSTAT);     # DEFINE TEMPORARY CATALOG FILE #
      IF ERRSTAT NQ CMASTAT"NOERR"
      THEN
        BEGIN 
        RETURN;                      # RETURN ERROR STATUS #
        END 
  
  
      REPEAT WHILE NOT FET$EOI[0] 
      DO                             # COPY CATALOG FILE #
        BEGIN 
        READ(FETSET[0],RCL);
        FET$IN[1] = FET$IN[0];
        WRITE(FETSET[1],RCL); 
        FET$OUT[0] = FET$OUT[1];
        END 
  
      WRITEF(FETSET[1],RCL);
  
# 
*     CALCULATE NUMBER OF PRU-S TO ADD. 
# 
  
      NAST =(MAXORD/PRULEN)* 2 + 1; 
  
# 
*     ALLOCATE SPACE AT END OF FILE.
# 
  
      FET$R[1] = TRUE;
      BKSPRU(FETSET[1],2,RCL);
      IF FET$AT[1] NQ 0 
      THEN
        BEGIN 
        GOTO ERR; 
        END 
  
      LOCAT = FET$CRI[1];            # LOCATION OF NEW SUBCATALOG # 
      SLOWFOR I = 1 STEP 1 UNTIL WBUFL
      DO
        BEGIN 
        WBUF$W[I] = 0;               # ZERO FILL WORKING BUFFER # 
        END 
  
      SLOWFOR I = NAST STEP -1 UNTIL 1
      DO
        BEGIN 
        WRITEW(FETSET[1],WBUF,WBUFL,STAT);
        IF STAT NQ 0
        THEN                         # *CIO* ERROR #
          BEGIN 
          GOTO ERR; 
          END 
  
        END 
  
      WRITEF(FETSET[1],RCL);
      IF FET$AT[1] NQ 0 
      THEN
        BEGIN 
        GOTO ERR; 
        END 
  
# 
*     UPDATE CATALOG PREAMBLE.
# 
  
      PRM$SMID[SMID ] = SMID ;
      PRM$ENTRC[SMID] = 0;
      PRM$ASTLOC[SMID] = LOCAT ;
      PRM$FCTLOC[SMID] = LOCAT + NAST;
      PRM$MXAUS[SMID] = 0;
      PRM$MXAUL[SMID] = 0;
      PRM$PDATE[SMID] = 0;
      FET$RR[1] = 1;                 # WRITE UPDATED PREAMBLE # 
      FET$IN[1] = FET$FRST[1];
      FET$OUT[1] = FET$FRST[1]; 
      RPHR(FETSET[1],RCL);
      IF FET$AT[1] NQ 0 
      THEN
        BEGIN 
        GOTO ERR; 
        END 
  
      TBUF$W[SMID +1] = PRM$SCW1[SMID]; 
      TBUF$W1[SMID+1] = PRM$SCW2[SMID]; 
      TBUF$W2[SMID+1] = PRM$SCW2[SMID]; 
      FET$RR[1] = 1;
      FET$W[1] = TRUE;
      WPHR(FETSET[1],RCL);
      IF FET$AT[1] NQ 0 
      THEN
        BEGIN 
        GOTO ERR; 
        END 
  
# 
*     REPLACE MSF CATALOG WITH NEW CATALOG (*TSFMCAT*). 
# 
  
      REPLCAT(ORD,ERRSTAT); 
      RETURN; 
  
ERR:                                 # PROCESS *CIO* ERROR #
      CPIOERR(FAMNM,SUBF,QRADDR,ERRSTAT,FETSET[1]); 
      END  # CADDSC # 
  
    TERM
PROC CBUFMAN((FAMNM),(SUBF),(SMID),(FCTORD),(MODF), 
      (QRADDR),ERRSTAT);
# TITLE CBUFMAN - MANAGE CATALOG *FCT* BUFFER.                        # 
      BEGIN  # CBUFMAN #
  
# 
**    CBUFMAN - MANAGE CATALOG *FCT* BUFFER.
* 
*     *CBUFMAN* ENSURES THAT THE REQUESTED FILE AND CARTRIDGE TABLE 
*     ENTRY IS IN THE CATALOG *FCT* I/O BUFFER.  THE WORD OFFSET OF THE 
*     ENTRY WITHIN THE BUFFER IS RETURNED TO THE CALLER.
* 
*     CBUFMAN - IS CALLED BY CGETFCT,CPUTFCT. 
* 
*     PROC CBUFMAN((FAMNM),(SUBF),(SMID ),(FCTORD),OFFSET,(MODF), 
*       (QRADDR),ERRSTAT) 
* 
*     ENTRY      (FAMNM)  - FAMILY NAME, LEFT JUSTIFIED, ZERO FILLED, 
*                           7 CHARACTER MAXIMUM.
*                (SUBF)   - SUBFAMILY DESIGNATOR. 
*                (SMID )  - NUMERIC SM  IDENTIFIER. 
*                (FCTORD) - ORDINAL OF ENTRY IN *FCT*.
*                (MODF)   - CATALOG ATTACH MODE FLAG. 
*                           = FALSE, MODIFY MODE NOT REQUIRED.
*                           = TRUE, MODIFY MODE IS REQUIRED.
*                (QRADDR) - ADDRESS OF *HLRQ* ENTRY, ELSE ZERO. 
* 
*     EXIT       THE REQUESTED *FCT* ENTRY IS IN THE *FCT* I/O BUFFER.
*                (OFFSET)  - WORD OFFSET OF ENTRY WITHIN BUFFER.
*                (ERRSTAT) - ERROR STATUS.
*                            (VALUES DEFINED IN *COMBCMS*)
*                          =  NO ERROR. 
*                          =  CATALOG FILE INTERLOCKED. 
*                          =  CATALOG NOT OPEN. 
*                          =  CATALOG NOT OPEN IN MODIFY MODE.
*                          =  NO SUCH SUBCATALOG. 
*                          =  *CIO* ERROR.
*                          =  *FCT* ORDINAL OUT OF RANGE. 
# 
  
      ITEM FAMNM      C(7);          # FAMILY NAME #
      ITEM SUBF       U;             # SUBFAMILY DESIGNATOR # 
      ITEM SMID       U;             # SM  IDENTIFIER # 
      ITEM FCTORD     I;             # *FCT* ORDINAL #
      ITEM OFFSET     I;             # WORD OFFSET WITHIN BUFFER #
      ITEM MODF       B;             # MODIFY MODE FLAG # 
      ITEM QRADDR     U;             # *HLRQ* ENTRY ADDRESS # 
      ITEM ERRSTAT    I;             # ERROR STATUS # 
  
# 
****  PROC CBUFMAN - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC BFLUSH;                 # BUFFER FLUSH # 
        PROC CCLOSE;                 # CLOSE CATALOG #
        PROC OCTSRCH;                # SEARCH OPEN CATALOG TABLE #
        PROC READ;                   # READ FILE TO *CIO* BUFFER #
        PROC ZSETFET;                # INITIALIZES A FET #
        END 
  
# 
****  PROC CBUFMAN - XREF LIST END. 
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBCMD 
*CALL COMBCMS 
*CALL COMBFET 
*CALL COMBMCT 
*CALL COMXMSC 
*CALL COMSPFM 
  
      ITEM ORD        I;             # ORDINAL OF *OCT* ENTRY # 
      ITEM PRUNUM     I;             # PRU NUMBER # 
      ITEM TEMP       I;             # TEMPORARY STORAGE ITEM # 
  
CONTROL EJECT;
  
      OCTSRCH(FAMNM,SUBF,ORD,QRADDR,ERRSTAT);  # GET *OCT* ORDINAL #
      IF ERRSTAT NQ CMASTAT"NOERR"
      THEN
        BEGIN 
        RETURN;                      # RETURN ERROR STATUS #
        END 
  
      P<PREAMBLE> = OCT$PRMA[ORD];
      IF PRM$SCW1[SMID ] EQ 0 
      THEN                           # IF NO SUCH SUBCATALOG EXISTS # 
        BEGIN 
        ERRSTAT = CMASTAT"NOSUBCAT";
        RETURN;                      # RETURN ERROR STATUS #
        END 
  
      IF FCTORD GR (PRM$ENTRC[SMID] + 15) OR FCTORD LQ 15 
      THEN                           # IF *FCT* ORDINAL BAD # 
        BEGIN 
        ERRSTAT = CMASTAT"ORDERR";
        RETURN;                      # RETURN ERROR STATUS #
        END 
  
      IF MODF AND OCT$ATTM[ORD] NQ "M"
      THEN                           # IF NOT OPEN IN MODIFY MODE # 
        BEGIN 
        ERRSTAT = CMASTAT"MODERR";
        RETURN;                      # RETURN ERROR STATUS #
        END 
  
# 
*     CALCULATE POSITION OF REQUESTED *FCT* ENTRY.
*     (PRUNUM) = PRU OFFSET WITHIN CATALOG. 
# 
  
      TEMP = 16 * (FCTORD - 16);
      PRUNUM = PRM$FCTLOC[SMID ] + TEMP;
  
# 
*     ENSURE THAT REQUESTED *FCT* ENTRY IS IN I/O BUFFER. 
# 
  
      IF PRUNUM NQ FB$PRUNUM[0] 
        OR ORD NQ FB$ORD[0] 
        OR PRM$SUBF[0] NQ SUBF
        OR PRM$FAM[0] NQ FAMNM
      THEN                           # IF ENTRY NOT IN BUFFER # 
        BEGIN  # READ ENTRY INTO BUFFER # 
        IF PRM$SUBF[0] EQ SUBF
          AND PRM$FAM[0] EQ FAMNM 
        THEN
          BEGIN 
        BFLUSH(QRADDR,ERRSTAT);      # FLUSH CATALOG *FCT* I/O BUFFER # 
        IF ERRSTAT NQ CMASTAT"NOERR"
        THEN
          BEGIN 
          RETURN; 
          END 
          END 
  
  
        ZSETFET(FCTFADR,OCT$LFN[ORD],FCTBADR,OCT$BUFL[ORD],RFETL);
        P<FETSET> = FCTFADR;
        FET$EP[0] = TRUE; 
        FET$R[0] = TRUE;
        FET$RR[0] = PRUNUM; 
        READ(FETSET[0],RCL);
        IF FET$AT[0] NQ 0 
        THEN
          BEGIN 
          CCLOSE(FAMNM,SUBF,QRADDR,ERRSTAT);  # CLOSE CATALOG # 
          ERRSTAT = CMASTAT"CIOERR";  # RETURN ERROR STATUS # 
          RETURN; 
          END 
  
        FB$ORD[0] = ORD;             # SET BUFFER CONTROL WORD #
        FB$PRUCNT[0] = OCT$BUFL[ORD]/PRULEN;
        FB$PRUNUM[0] = PRUNUM;
        END  # READ ENTRY INTO BUFFER # 
  
  
      RETURN; 
      END  # CBUFMAN #
  
    TERM
PROC CCLOSE((FAMNM),(SUBF),(QRADDR),ERRSTAT); 
# TITLE CCLOSE - CLOSE CATALOG.                                       # 
      BEGIN  # CCLOSE # 
  
# 
**    CCLOSE - CLOSE CATALOG. 
* 
*     *CCLOSE* TERMINATES CATALOG USAGE.  IF THE CATALOG WAS
*     OPEN IN MODIFY MODE, THE UPDATED PREAMBLE IS WRITTEN
*     BACK TO THE CATALOG AND THE *FCT* I/O BUFFER IS FLUSHED 
*     (IF THE DATA IN THE BUFFER WAS MODIFIED). 
*     THE CATALOG FILE IS RETURNED AND THE *OCT* ENTRY IS CLEARED.
* 
*     CCLOSE - IS CALLED BY CBUFMAN,CPIOERR,CRDPRM,DBFLAG,DBFMAP, 
*             DBRDFIL,DBREL,TERMCAT,USRPBAS,USRPDE,VLSUBFM. 
* 
*     PROC CCLOSE((FAMNM),(SUBF),(QRADDR),ERRSTAT)
* 
*     ENTRY      (FAMNM)  - FAMILY NAME, LEFT JUSTIFIED, ZERO FILLED, 
*                           7 CHARACTER MAXIMUM.
*                (SUBF)   - SUBFAMILY DESIGNATOR. 
*                (QRADDR) - *HLRQ* ENTRY ADDRESS, ELSE ZERO.
* 
*     EXIT       (ERRSTAT) - ERROR STATUS.
*                            (VALUES DEFINED IN *COMBCMS*)
*                            =  NO ERRORS.
*                            =  CATALOG FILE INTERLOCKED. 
*                            =  CATALOG NOT OPEN. 
*                            =  *CIO* ERROR.
* 
# 
  
      ITEM FAMNM      C(7);          # FAMILY NAME #
      ITEM SUBF       U;             # SUBFAMILY DESIGNATOR # 
      ITEM QRADDR     U;             # *HLRQ* ENTRY ADDRESS # 
      ITEM ERRSTAT    I;             # ERROR STATUS # 
  
# 
****  PROC CCLOSE - XREF LIST BEGIN.
# 
  
      XREF
        BEGIN 
        PROC OCTSRCH;                # SEARCH OPEN CATALOG TABLE #
        PROC RETERN;                 # RETURN FILE TO SYSTEM #
        PROC REWRITE;              # REWRITE DATA FROM I/O BUFFER # 
        PROC RPHR;                   # READ PRU TO *CIO* BUFFER # 
        PROC WPHR;                   # WRITE PRU FROM *CIO* BUFFER #
        PROC ZFILL;                  # ZERO FILLS A BUFFER #
        PROC ZSETFET;                # INITIALIZES A FET #
        END 
  
# 
****  PROC CCLOSE - XREF LIST END.
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBCMD 
*CALL COMBCMS 
*CALL COMBFET 
*CALL COMBMCT 
*CALL COMSPFM 
  
      ITEM I          I;             # LOOP COUNTER # 
      ITEM ORD        I;             # ORDINAL OF *OCT* ENTRY # 
CONTROL EJECT;
  
      OCTSRCH(FAMNM,SUBF,ORD,QRADDR,ERRSTAT);  # GET *OCT* ORDINAL #
      IF ERRSTAT NQ CMASTAT"NOERR"
      THEN
        BEGIN 
        RETURN;                      # RETURN ERROR STATUS #
        END 
  
      IF FB$BMF[0] AND ORD EQ FB$ORD[0] 
      THEN
        BEGIN  # FLUSH BUFFER # 
        ZSETFET(FCTFADR,OCT$LFN[ORD],FCTBADR,OCT$BUFL[ORD],RFETL);
        FET$EP[0] = TRUE; 
        FET$R[0] = TRUE;
        FET$IN[0] = FET$FRST[0] + OCT$BUFL[ORD] - 1;
        FET$RR[0] = FB$PRUNUM[0]; 
        REWRITE(FETSET[0],RCL); 
        IF FET$AT[0] NQ 0 
        THEN
          BEGIN 
          ERRSTAT = CMASTAT"CIOERR";
          FET$AT[0] = 0;
          END 
  
        FB$CWRD[0] = 0; 
        END  # FLUSH BUFFER # 
  
      ZSETFET(TFETADR,OCT$LFN[ORD],TBUFADR,2*PRULEN,RFETL); 
  
# 
*     WRITE UPDATED PREAMBLE BACK TO THE CATALOG FILE.
# 
  
      IF OCT$ATTM[ORD] EQ "M" 
      THEN                           # IF CATALOG OPEN IN MODIFY MODE # 
        BEGIN  # UPDATE CATALOG PREAMBLE #
        FET$EP[0] = TRUE; 
        FET$R[0] = TRUE;
        FET$RR[0] = 1;
        RPHR(FETSET[0],RCL);
        IF FET$AT[0] NQ 0 
        THEN
          BEGIN 
          ERRSTAT = CMASTAT"CIOERR";
          FET$AT[0] = 0;
          END 
  
        P<PREAMBLE> = OCT$PRMA[ORD];
        FASTFOR I = 0 STEP 1 UNTIL MAXSM
        DO
          BEGIN 
          TBUF$W[I+1] = PRM$SCW1[I];
          TBUF$W1[I+1] = PRM$SCW2[I]; 
          TBUF$W2[I+1] = PRM$SCW3[I]; 
          END 
  
        FET$RR[0] = 1;
        FET$W[0] = TRUE;
        WPHR(FETSET[0],RCL);
        IF FET$AT[0] NQ 0 
        THEN
          BEGIN 
          ERRSTAT = CMASTAT"CIOERR";
          FET$AT[0] = 0;
          END 
  
        END  # UPDATE CATALOG PREAMBLE #
  
# 
*     RETURN CATALOG FILE.
# 
  
      RETERN(FETSET[0],RCL);
  
# 
*     CLEAR ENTRY IN OPEN CATALOG TABLE.
# 
  
      ZFILL(OCT[ORD],OCTENTL);
      RETURN; 
      END  # CCLOSE # 
  
    TERM
PROC CDEFTF(FET,ERSTAT);
# TITLE CDEFTF - DEFINE TEMPORARY CATALOG.                            # 
      BEGIN  # CDEFTF # 
  
# 
**    CDEFTF - DEFINE TEMPORARY CATALOG.
* 
*     *CDEFTF* DEFINES A FILE TO BE USED FOR CHANGING THE 
*     SIZE OF THE MSS CATALOG.
* 
*     CDEFTF - IS CALLED BY CADDSC, CEXTSC,CRMVSC.
* 
* 
*     PROC CDEFTF(FET,ERSTAT) 
* 
*     ENTRY      FET - AN ARRAY CONTAINING THE FET FOR *TSFMCAT*. 
* 
*     EXIT       A FILE NAMED *TSFMCAT* HAS BEEN DEFINED. 
*                (ERSTAT) - ERROR STATUS. 
*                           (VALUES DEFINED IN *COMBCMS*) 
*                            =  NO ERRORS.
*                            =  *CIO* ERROR.
*                            =  FILE DEFINE ERROR.
*                            =  FILE PURGE ERROR. 
* 
* 
*     NOTES      IF THE FILE ALREADY EXISTS, IT IS PURGED AND 
*                REDEFINED. 
# 
  
      ARRAY FET [0:0] P(1); ;        # FET FOR FILE *TSFMCAT* # 
      ITEM ERSTAT     I;             # ERROR STATUS # 
  
# 
**** PROC CDEFTF - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC PFD;                    # PERMANENT FILE REQUEST DELAYS #
        PROC RETERN;                 # RETURN FILE TO SYSTEM #
        END 
  
# 
****  PROC CDEFTF - XREF LIST END.
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBCMS 
*CALL COMBPFS 
*CALL COMXMSC 
*CALL COMSPFM 
CONTROL EJECT;
  
      PFD("DEFINE",TSFMCAT,0,"BR","Y","SR","MR","RC",PFSTAT,"UP",0,0);
      IF PFSTAT NQ 0
      THEN
        BEGIN  # DEFINE ERROR # 
        IF PFSTAT EQ FAP
        THEN
          BEGIN  # FILE ALREADY EXISTS #
          PFD("PURGE",TSFMCAT,"RC",PFSTAT,"UP",0,0);
          IF PFSTAT NQ 0
          THEN                       # IF PURGE ERROR # 
            BEGIN 
            ERSTAT = CMASTAT"TPRGERR";
            RETURN; 
            END 
  
          RETERN(FET[0],RCL); 
          PFD("DEFINE",TSFMCAT,0,"BR","Y","SR","MR",
            "RC",PFSTAT,"UP",0,0);
          IF PFSTAT NQ 0
          THEN                       # IF DEFINE ERROR #
            BEGIN 
            ERSTAT = CMASTAT"TDEFERR";
            RETURN; 
            END 
  
          END  # FILE ALREADY EXISTS #
  
        ELSE
          BEGIN 
          ERSTAT = CMASTAT"TDEFERR";
          RETURN; 
          END 
  
        END  # DEFINE ERROR # 
  
      END  # CDEFTF # 
  
    TERM
PROC CEXTSC((FAMNM),(SUBF),(SMID ),(NUM),(QRADDR),ERRSTAT); 
# TITLE CEXTSC - EXTEND SUBCATALOG.                                   # 
      BEGIN  # CEXTSC # 
  
# 
**    CEXTSC - EXTEND SUBCATALOG. 
* 
*     *CEXTSC* EXPANDS AND REORGANIZES THE CATALOG FILE TO ACCOMODATE 
*     AN INCREASE IN THE SIZE OF THE SUBCATALOG.  THE CATALOG MUST BE 
*     OPEN IN MODIFY MODE.
* 
*     CEXTSC - IS CALLED BY ADDCUBE.
* 
*     PROC CEXTSC((FAMNM),(SUBF),(SMID ),(NUM),(QRADDR),ERRSTAT)
* 
*     ENTRY      (FAMNM)  - FAMILY NAME, LEFT JUSTIFIED, ZERO FILLED, 
*                           7 CHARACTER MAXIMUM.
*                (SUBF)   - SUBFAMILY DESIGNATOR. 
*                (SMID )  - NUMERIC SM  IDENTIFIER. 
*                (NUM)    - NUMBER OF *FCT* (AND *AST*) ENTRIES TO ADD. 
*                (QRADDR) - *HLRQ* ENTRY ADDRESS, ELSE ZERO.
* 
*     EXIT       THE SIZE OF THE SPECIFIED SUBCATALOG HAS BEEN
*                INCREASED AND THE PREAMBLE HAS BEEN UPDATED TO 
*                REFLECT THE CHANGE.
*                (ERRSTAT) - ERROR STATUS.
*                            (VALUES DEFINED IN *COMBCMS*)
*                            =  NO ERRORS.
*                            =  CATALOG FILE INTERLOCKED. 
*                            =  CATALOG NOT OPEN. 
*                            =  CATALOG NOT OPEN IN MODIFY MODE.
*                            =  NO SUCH SUBCATALOG. 
*                            =  *CIO* ERROR.
*                            =  FILE DEFINE ERROR.
*                            =  FILE ATTACH ERROR.
*                            =  FILE PURGE ERROR. 
*                            =  FILE RENAME ERROR.
*                IF THE DESIRED FAMILY IS NOT FOUND ON A *SETPFP*, AN 
*                ERROR MESSAGE IS ISSUED AND THE PROGRAM IS ABORTED.
* 
*     NOTES      THE CATALOG IS RE-ATTACHED IN WRITE MODE IN ORDER TO 
*                EXTEND THE SUBCATALOG, AND WHEN FINISHED, THE FILE IS
*                ATTACHED IN MODIFY MODE AGAIN. 
* 
*     MESSAGES   * PROGRAM ABNORMAL, CEXTSC.*.
# 
  
      ITEM FAMNM      C(7);          # FAMILY NAME #
      ITEM SUBF       U;             # SUBFAMILY DESIGNATOR # 
      ITEM SMID       U;             # SM  IDENTIFIER # 
      ITEM NUM        I;             # NUMBER OF ENTRIES TO ADD # 
      ITEM QRADDR     U;             # *HLRQ* ENTRY ADDRESS # 
      ITEM ERRSTAT    I;             # ERROR STATUS # 
  
# 
**** PROC CEXTSC - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC ABORT;                  # ABORT #
        PROC BFLUSH;                 # FLUSH *FCT* I/O BUFFER # 
        PROC CDEFTF;                 # DEFINE TEMPORARY CATALOG # 
        PROC CPIOERR;                # PROCESS MSF CATALOG I/O ERROR #
        PROC MESSAGE;                # ISSUE MESSAGE #
        PROC OCTSRCH;                # SEARCH OPEN CATALOG TABLE #
        PROC READ;                   # READ FILE TO *CIO* BUFFER #
        PROC READW;                  # READ DATA TO WORKING BUFFER #
        PROC REPLCAT;                # REPLACE MSF CATALOG #
        PROC REWIND;                 # REWIND A FILE #
        PROC SETPFP;                 # SET PERMANENT FILE PARAMETERS #
        PROC WRITEF;                 # WRITE END OF FILE #
        PROC WRITEW;                 # WRITE DATA FROM WORKING BUFFER # 
        PROC ZFILL;                  # ZERO FILL BUFFER # 
        PROC ZSETFET;                # INITIALIZES A FET #
        END 
  
# 
****  PROC CEXTSC - XREF LIST END.
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBBZF 
*CALL COMBCMD 
*CALL COMBCMS 
*CALL COMBFET 
*CALL COMBMCT 
*CALL COMBPFP 
*CALL COMXMSC 
  
      ITEM EXT1       I;             # EXTEND VALUE 1 # 
      ITEM EXT2       I;             # EXTEND VALUE 2 # 
      ITEM I          I;             # LOOP COUNTER # 
      ITEM J          I;             # LOOP COUNTER # 
      ITEM N          I;             # COUNTER #
      ITEM NAST       I;             # NUMBER OF PRU-S IN *AST* # 
      ITEM NFCT       I;             # NUMBER OF PRU-S IN *FCT* # 
      ITEM ORD        I;             # ORDINAL OF *OCT* ENTRY # 
      ITEM STAT       I;             # STATUS # 
      ITEM TEMP       I;             # TEMPORARY STORAGE #
      ITEM WRD$AV     I;             # NUMBER OF WORDS AVAILABLE #
      ITEM WRD$ND     I;             # NUMBER OF WORDS NEEDED # 
CONTROL EJECT;
  
      OCTSRCH(FAMNM,SUBF,ORD,QRADDR,ERRSTAT);  # GET *OCT* ORDINAL #
      IF ERRSTAT NQ CMASTAT"NOERR"
      THEN
        BEGIN 
        RETURN;                      # RETURN ERROR STATUS #
        END 
  
      IF OCT$ATTM[ORD] NQ "M" 
      THEN                           # IF NOT OPEN IN MODIFY MODE # 
        BEGIN 
        ERRSTAT = CMASTAT"MODERR";
        RETURN;                      # RETURN ERROR STATUS #
        END 
  
      P<PREAMBLE> = OCT$PRMA[ORD];
      IF PRM$SCW1[SMID ] EQ 0 
      THEN                           # IF NO SUCH SUBCATALOG #
        BEGIN 
        ERRSTAT = CMASTAT"NOSUBCAT";
        RETURN;                      # RETURN ERROR STATUS #
        END 
  
      BFLUSH(QRADDR,ERRSTAT);        # FLUSH CATALOG *FCT* I/O BUFFER # 
      FB$CWRD[0] = 0; 
      IF ERRSTAT NQ CMASTAT"NOERR"
      THEN
        BEGIN 
        RETURN; 
        END 
  
# 
*     SET FAMILY AND USER INDEX.
# 
  
      PFP$WRD0[0] = 0;
      PFP$FAM[0] = OCT$FAM[ORD];
      PFP$UI[0] = DEF$UI + OCT$SUBF[ORD]; 
      PFP$FG1[0] = TRUE;
      PFP$FG4[0] = TRUE;
      SETPFP(PFP);
      IF PFP$STAT[0] NQ 0 
      THEN                           # IF FAMILY NOT FOUND #
        BEGIN 
        CMA$RTN[0] = "CEXTSC."; 
        MESSAGE(CMAMSG,UDFL1);       # ISSUE ERROR MESSAGE #
        ABORT;
        END 
  
      ZSETFET(TFETADR,OCT$LFN[ORD],FCTBADR,SEQBL,RFETL);
      FET$EP[0] = TRUE; 
      ZSETFET(TFETADR+RFETL,TSFMCAT,TBUFADR,TBUFL,RFETL); 
      FET$EP[0] = TRUE; 
      REWIND(TFET[0],NRCL); 
      CDEFTF(TFET[1],ERRSTAT);       # DEFINE TEMPORARY CATALOG FILE #
      IF ERRSTAT NQ CMASTAT"NOERR"
      THEN
        BEGIN 
        RETURN;                      # RETURN ERROR STATUS #
        END 
  
# 
*     DETERMINE CATALOG EXTENSION VALUES. 
*     (EXT1) = RELATIVE SECTOR ADDRESS TO BEGIN *FCT* EXTENSION AT. 
*     (NFCT) = NUMBER OF PRU-S NEEDED FOR THE *FCT* EXTENSION.
# 
  
      EXT1 = PRM$FCTLOC[SMID] + PRM$ENTRC[SMID] * 16; 
      NFCT = 16 * NUM;
  
  
# 
*     UPDATE CATALOG PREAMBLE.
# 
  
      PRM$ENTRC[SMID ] = PRM$ENTRC[SMID ] + NUM;
      FASTFOR I = 1 STEP 1 UNTIL MAXSM
      DO
        BEGIN 
        IF PRM$ASTLOC[I] GR PRM$ASTLOC[SMID]
        THEN                         # IF SUBCATALOG LOCATION CHANGED # 
          BEGIN 
          PRM$FCTLOC[I] = PRM$FCTLOC[I] + NFCT; 
          PRM$ASTLOC[I] = PRM$ASTLOC[I] + NFCT; 
          END 
  
        END 
  
# 
*     TRANSFER CATALOG FILE TO TEMPORARY FILE, EXTENDING SUBCATALOG.
# 
  
      READ(TFET[0],RCL);
      READW(TFET[0],WBUF,WBUFL,STAT); 
      IF STAT EQ CIOERR 
      THEN                           # IF *CIO* ERROR # 
        BEGIN 
        CPIOERR(FAMNM,SUBF,QRADDR,ERRSTAT,TFET[0]); 
        RETURN; 
        END 
  
      IF STAT NQ 0
      THEN                           # IF TRANSFER NOT COMPLETE # 
        BEGIN 
        CMA$RTN[0] = "CEXTSC."; 
        MESSAGE(CMAMSG,UDFL1);
        ABORT;
        END 
  
      P<TBUF> = WBUFADR;
      FASTFOR I = 0 STEP 1 UNTIL MAXSM
      DO
        BEGIN 
        TBUF$W[I+1] = PRM$SCW1[I];
        TBUF$W1[I+1] = PRM$SCW2[I]; 
        TBUF$W2[I+1] = PRM$SCW3[I]; 
        END 
      P<TBUF> = TBUFADR;
  
      WRITEW(TFET[1],WBUF,WBUFL,STAT);
      SLOWFOR I = 2 STEP 1 WHILE STAT EQ 0
      DO
        BEGIN  # TRANSFER CATALOG # 
        IF I EQ EXT1
        THEN
          BEGIN  # FILE TO BE EXTENDED #
  
          ZFILL(WBUF,WBUFL);
  
          SLOWFOR J = 1 STEP 1 UNTIL NFCT 
          DO
            BEGIN 
            WRITEW(TFET[1],WBUF,WBUFL,STAT);
            IF STAT NQ 0
            THEN                     # IF *CIO* ERROR # 
              BEGIN 
              CPIOERR(FAMNM,SUBF,QRADDR,ERRSTAT,TFET[1]); 
              RETURN; 
              END 
  
            END 
  
          END  # FILE TO BE EXTENDED #
  
        READW(TFET[0],WBUF,WBUFL,STAT); 
        IF STAT EQ CIOERR 
        THEN                         # IF *CIO* ERROR # 
          BEGIN 
          CPIOERR(FAMNM,SUBF,QRADDR,ERRSTAT,TFET[0]); 
          RETURN; 
          END 
  
      IF STAT NQ 0 AND (I + 1) EQ EXT1
        THEN                         # ADD SPACE AT END OF FILE # 
          BEGIN 
          SLOWFOR J = 1 STEP 1 UNTIL NFCT 
          DO
            BEGIN 
            WRITEW(TFET[1],WBUF,WBUFL,STAT);
            IF STAT NQ 0
            THEN
              BEGIN 
              CPIOERR(FAMNM,SUBF,QRADDR,ERRSTAT,TFET[1]); 
              RETURN; 
              END 
  
            END 
  
          STAT = -1;
          TEST I; 
          END 
  
  
        IF STAT NQ 0
        THEN                         # IF *EOR*, *EOF* OR *EOI* # 
          BEGIN 
          TEST I;                    # EXIT LOOP #
          END 
  
        WRITEW(TFET[1],WBUF,WBUFL,STAT);
        IF STAT NQ 0
        THEN                      # *CIO* ERROR # 
          BEGIN 
          CPIOERR(FAMNM,SUBF,QRADDR,ERRSTAT,TFET[1]); 
          RETURN; 
          END 
  
  
        END  # TRANSFER CATALOG # 
  
      WRITEF(TFET[1],RCL);
      IF FET$AT[0] NQ 0 
      THEN
        BEGIN 
        CPIOERR(FAMNM,SUBF,QRADDR,ERRSTAT,TFET[1]); 
        RETURN; 
        END 
  
# 
*     REPLACE MSF CATALOG WITH NEW CATALOG (*TSFMCAT*). 
# 
  
      REPLCAT(ORD,ERRSTAT); 
      RETURN; 
      END  # CEXTSC # 
  
    TERM
PROC CFLUSH((FAMNM),(SUBF),(QRADDR),ERRSTAT); 
# TITLE CFLUSH - FLUSHES THE CATALOG I/O BUFFER.                      # 
      BEGIN  # CFLUSH # 
  
# 
**    CFLUSH - FLUSHES THE CATALOG I/O BUFFER.
* 
*     *CFLUSH* CHECKS FOR ERRORS AND CALLS *BFLUSH* TO FLUSH THE
*     CATALOG I/O BUFFER, WHICH IS USED FOR READING AND WRITING 
*     *FCT* ENTRIES.  THE CATALOG MUST BE OPEN IN MODIFY MODE.
* 
*     CFLUSH - IS CALLED BY ADDCAR,ADDCSU,ADDCUBE,DESTAGR,PURGCHN,
*              PURGFCT,RMVCAR,RMVCUBE,STAGER. 
* 
* 
*     PROC CFLUSH((FAMNM),(SUBF),(QRADDR),ERRSTAT)
* 
*     ENTRY      (FAMNM)  - FAMILY NAME, LEFT JUSTIFIED, ZERO FILLED, 
*                           7 CHARACTER MAXIMUM.
*                (SUBF)   - SUBFAMILY DESIGNATOR. 
*                (QRADDR) - *HLRQ* ENTRY ADDRESS, ELSE ZERO.
* 
*     EXIT       (ERRSTAT) - ERROR STATUS.
*                            (VALUES DEFINED IN *COMBCMS*)
*                            =  NO ERRORS.
*                            =  CATALOG FILE INTERLOCKED. 
*                            =  CATALOG NOT OPEN. 
*                            =  CATALOG NOT OPEN IN MODIFY MODE.
*                            =  *CIO* ERROR.
# 
  
      ITEM FAMNM      C(7);          # FAMILY NAME #
      ITEM SUBF       U;             # SUBFAMILY DESIGNATOR # 
      ITEM QRADDR     U;             # *HLRQ* ENTRY ADDRESS # 
      ITEM ERRSTAT    I;             # ERROR STATUS # 
  
# 
****  PROC CFLUSH - XREF LIST BEGIN.
# 
  
      XREF
        BEGIN 
        PROC BFLUSH;                 # BUFFER FLUSH # 
        PROC OCTSRCH;                # SEARCH OPEN CATALOG TABLE #
        END 
  
# 
****  PROC CFLUSH - XREF LIST END.
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBCMD 
*CALL COMBCMS 
*CALL COMSPFM 
  
      ITEM ORD        I;             # ORDINAL OF *OCT* ENTRY # 
CONTROL EJECT;
  
# 
*     FIND ENTRY IN THE OPEN CATALOG TABLE. 
# 
  
      OCTSRCH(FAMNM,SUBF,ORD,QRADDR,ERRSTAT); 
      IF ERRSTAT NQ CMASTAT"NOERR"
      THEN
        BEGIN 
        RETURN;                      # RETURN ERROR STATUS #
        END 
  
      IF OCT$ATTM[ORD] NQ "M" 
      THEN                           # IF NOT OPEN IN MODIFY MODE # 
        BEGIN 
        ERRSTAT = CMASTAT"MODERR";   # RETURN ERROR STATUS #
        RETURN; 
        END 
  
      BFLUSH(QRADDR,ERRSTAT);        # FLUSH CATALOG *FCT* I/O BUFFER # 
      RETURN; 
      END  # CFLUSH # 
  
    TERM
PROC CGETFCT((FAMNM),(SUBF),(SMID ),(FCTORD),(BADDR),(QRADDR),
      ERRSTAT); 
# TITLE CGETFCT - GET AN *FCT* ENTRY.                                 # 
      BEGIN  # CGETFCT #
  
# 
**    CGETFCT - GET AN *FCT* ENTRY. 
* 
* 
*     *CGETFCT* RETURNS THE REQUESTED FILE AND CARTRIDGE TABLE ENTRY
*     TO THE CALLER.
* 
*     CGETFCT - IS CALLED BY ACQ$FCT,DBFLAG,DBFMAP,DBRDFIL,DBREL, 
*               LBRMMSC,OPENCAT,USANALF,USRPDE,VLBLDVT. 
* 
*     PROC CGETFCT((FAMNM),(SUBF),(SMID ),(FCTORD),(BADDR), 
*       (QRADDR),ERRSTAT) 
* 
*     ENTRY      (FAMNM)  - FAMILY NAME, LEFT JUSTIFIED, ZERO FILLED, 
*                           7 CHARACTER MAXIMUM.
*                (SUBF)   - SUBFAMILY DESIGNATOR. 
*                (SMID )  - NUMERIC SM  IDENTIFIER. 
*                (FCTORD) - ORDINAL OF ENTRY IN *FCT*.
*                (BADDR)  - ADDRESS OF BUFFER TO RECEIVE *FCT* ENTRY. 
*                (QRADDR) - ADDRESS OF *HLRQ* ENTRY, ELSE ZERO. 
* 
*     EXIT       THE REQUESTED *FCT* ENTRY IS RETURNED TO THE CALLER AT 
*                THE ADDRESS SPECIFIED BY (BADDR).
*                (ERRSTAT) - ERROR STATUS.
*                            (VALUES DEFINED IN *COMBCMS*)
*                          =  NO ERROR. 
*                          =  CATALOG FILE INTERLOCKED. 
*                          =  CATALOG NOT OPEN. 
*                          =  NO SUCH SUBCATALOG. 
*                          =  *CIO* ERROR.
*                          =  *FCT* ORDINAL OUT OF RANGE. 
# 
  
      ITEM FAMNM      C(7);          # FAMILY NAME #
      ITEM SUBF       U;             # SUBFAMILY DESIGNATOR # 
      ITEM SMID       U;             # SM  IDENTIFIER # 
      ITEM FCTORD     I;             # *FCT* ORDINAL #
      ITEM BADDR      U;             # ADDRESS OF *FCT* ENTRY BUFFER #
      ITEM QRADDR     U;             # *HLRQ* ENTRY ADDRESS # 
      ITEM ERRSTAT    I;             # ERROR STATUS # 
  
# 
****  PROC CGETFCT - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC CBUFMAN;                # MANAGE CATALOG *FCT* BUFFER #
        END 
  
# 
****  PROC CGETFCT - XREF LIST END. 
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBCMD 
*CALL COMBCMS 
*CALL COMBMCT 
  
      ITEM I          I;             # LOOP COUNTER # 
      ITEM MODF       B = FALSE;     # MODIFY MODE FLAG # 
      ITEM OFFSET     I;             # WORD OFFSET WITHIN BUFFER #
  
      BASED 
      ARRAY ENTBUF [1:FCTENTL] P(1);  # *FCT* ENTRY BUFFER #
        BEGIN 
        ITEM ENT$WRD    I(00,00,60);  # ENTRY WORD #
        END 
  
CONTROL EJECT;
  
# 
*     ENSURE THAT REQUESTED *FCT* ENTRY IS WITHIN I/O BUFFER. 
# 
  
      CBUFMAN(FAMNM,SUBF,SMID,FCTORD,MODF,QRADDR,ERRSTAT);
      IF ERRSTAT NQ CMASTAT"NOERR"
      THEN
        BEGIN 
        RETURN;                      # RETURN ERROR STATUS #
        END 
  
# 
*     TRANSFER ENTRY TO CALLERS BUFFER. 
# 
  
      P<ENTBUF> = BADDR;
      SLOWFOR I = 1 STEP 1 UNTIL FCTENTL
      DO
        BEGIN 
        ENT$WRD[I] = FCTB$WRD[I]; 
        END 
  
      RETURN; 
      END  # CGETFCT #
  
    TERM
PROC CGETPD((FAMNM),(SUBF),(SMID ),LASTPRG,(QRADDR),ERRSTAT); 
# TITLE CGETPD - GET PURGE DATE.                                      # 
      BEGIN  # CGETPD # 
  
# 
**    CGETPD - GET PURGE DATE.
* 
* 
*     *CGETPD* GETS THE DATE AND TIME OF THE LAST PURGE OF ORPHAN 
*     FILES (AN MSF FILE WITH NO REFERENCE TO IT IN THE *PFC*) FROM THE 
*     APPROPRIATE CATALOG PREAMBLE ENTRY. 
* 
*     CGETPD - IS CALLED BY GETPD AND VLSUBTD.
* 
*     PROC CGETPD((FAMNM),(SUBF),(SMID ),LASTPRG,(QRADDR),ERRSTAT)
* 
*     ENTRY      (FAMNM)  - FAMILY NAME, LEFT JUSTIFIED, ZERO FILLED
*                           7 CHARACTER MAXIMUM.
*                (SUBF)   - SUBFAMILY DESIGNATOR. 
*                (SMID )  - NUMERIC SM  IDENTIFIER. 
*                (QRADDR) - *HLRQ* ENTRY ADDRESS, ELSE ZERO.
* 
*     EXIT       (LASTPRG) - LAST PURGE DATE AND TIME IN PACKED FORMAT, 
*                            AS RETURNED BY THE *PDATE* MACRO.
*                (ERRSTAT) - ERROR STATUS.
*                            (VALUES DEFINED IN *COMBCMS*)
*                            =  NO ERROR. 
*                            =  CATALOG FILE INTERLOCKED. 
*                            =  CATALOG NOT OPEN. 
*                            =  NO SUCH SUBCATALOG EXISTS.
*                            =  *CIO* ERROR.
* 
*     NOTES      THE PREAMBLE TABLE DOES NOT CONTAIN THE LAST PURGE 
*                DATE AND TIME (ONLY THE FIRST WORD OF EACH SUBCATALOG
*                ENTRY IS IN THE TABLE), SO THE PREAMBLE MUST BE READ 
*                FROM THE CATALOG.
# 
  
      ITEM FAMNM      C(7);          # FAMILY NAME #
      ITEM SUBF       U;             # SUBFAMILY DESIGNATOR # 
      ITEM SMID       U;             # SM  IDENTIFIER # 
      ITEM LASTPRG    U;             # LAST PURGE DATE #
      ITEM QRADDR     U;             # *HLRQ* ENTRY ADDRESS # 
      ITEM ERRSTAT    I;             # ERROR STATUS # 
  
# 
****  PROC CGETPD - XREF LIST BEGIN.
# 
  
      XREF
        BEGIN 
        PROC CPIOERR;                # PROCESS MSF CATALOG I/O ERROR #
        PROC OCTSRCH;                # SEARCH OPEN CATALOG TABLE #
        PROC REWIND;                 # REWIND FILE #
        PROC RPHR;                   # READ PRU TO *CIO* BUFFER # 
        PROC ZSETFET;                # INITIALIZES A FET #
        END 
  
# 
****  PROC CGETPD - XREF LIST END.
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBCMD 
*CALL COMBCMS 
*CALL COMBFET 
*CALL COMBMCT 
*CALL COMXMSC 
  
      ITEM ORD        I;             # ORDINAL OF *OCT* ENTRY # 
CONTROL EJECT;
  
      OCTSRCH(FAMNM,SUBF,ORD,QRADDR,ERRSTAT);  # GET *OCT* ORDINAL #
      IF ERRSTAT NQ CMASTAT"NOERR"
      THEN
        BEGIN 
        RETURN;                      # RETURN ERROR STATUS #
        END 
  
      P<PREAMBLE> = OCT$PRMA[ORD];
      IF PRM$SCW1[SMID ] EQ 0 
      THEN                           # IF NO SUCH SUBCATALOG #
        BEGIN 
        ERRSTAT = CMASTAT"NOSUBCAT";
        RETURN; 
        END 
  
  
# 
*     GET DATE AND TIME OF LAST PURGE OF ORPHAN FILES.
# 
  
      ZSETFET(TFETADR,OCT$LFN[ORD],TBUFADR,TBUFL,RFETL);
      FET$EP[0] = TRUE; 
      REWIND(FETSET[0],RCL);
      RPHR(FETSET[0],RCL);
      IF FET$AT[0] NQ 0 
      THEN
        BEGIN 
        CPIOERR(FAMNM,SUBF,QRADDR,ERRSTAT,FETSET[0]); 
        RETURN; 
        END 
  
      P<PREAMBLE> = TBUFADR;
      LASTPRG = PRM$PDATE[SMID ]; 
      RETURN; 
      END  # CGETPD # 
  
    TERM
PROC CINIT((FAMNM),(SUBF),(FLNM),ERRSTAT);
# TITLE CINIT - MSS CATALOG INITIALIZATION.                           # 
      BEGIN  # CINIT #
  
# 
**    CINIT - MSS CATALOG INITIALIZATION. 
* 
*     CINIT - IS CALLED BY DFCAT OF THE SSDEF DECK. 
* 
*     *CINIT* CREATES A FILE AND INITIALIZES IT AS A SKELETON CATALOG 
*     CONTAINING A PREAMBLE BUT NO SUBCATALOGS.  THE PREAMBLE CONTAINS
*     THE FAMILY NAME AND SUBFAMILY DESIGNATOR IN THE HEADER. 
* 
*     PROC CINIT((FAMNM),(SUBF),(FLNM),ERRSTAT) 
* 
*     ENTRY      (FAMNM) - FAMILY NAME, LEFT JUSTIFIED, ZERO FILLED,
*                          7 CHARACTER MAXIMUM. 
*                (SUBF)  - SUBFAMILY DESIGNATOR.
*                (FLNM)  - CATALOG FILE NAME, LEFT JUSTIFIED, ZERO
*                          FILLED, 7 CHARACTER MAXIMUM. 
* 
*     EXIT       (ERRSTAT) - ERROR STATUS.
*                            (VALUES DEFINED IN *COMBCMS*)
*                          =  NO ERROR. 
*                          =  CATALOG FILE ALREADY EXISTS.
*                          =  *CIO* ERROR.
*                          =  CATALOG DEFINE ERROR. 
# 
  
      ITEM FAMNM      C(7);          # FAMILY NAME #
      ITEM SUBF       U;             # SUBFAMILY DESIGNATOR # 
      ITEM FLNM       C(7);          # CATALOG FILE NAME #
      ITEM ERRSTAT    I;             # ERROR STATUS # 
  
# 
****  PROC CINIT - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC PFD;                    # PERMANENT FILE REQUEST DELAYS #
        PROC RETERN;                 # RETURN FILE TO SYSTEM #
        PROC WRITEF;                 # WRITE END OF FILE #
        PROC WRITEW;                 # WRITE DATA FROM WORKING BUFFER # 
        PROC ZSETFET;                # INITIALIZES A FET #
        END 
  
# 
****  PROC CINIT - XREF LIST END. 
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBCMD 
*CALL COMBCMS 
*CALL COMBFET 
*CALL COMBMCT 
*CALL COMBPFS 
*CALL COMXMSC 
*CALL COMSPFM 
  
      ITEM I          I;             # LOOP COUNTER # 
      ITEM STAT       I;             # DEFINE STATUS #
CONTROL EJECT;
  
# 
*     DEFINE CATALOG FILE.
# 
  
      ERRSTAT = CMASTAT"NOERR"; 
      PFD("DEFINE",FLNM,0,"BR","Y","SR","MR","RC",PFSTAT,"UP",0,0); 
      IF PFSTAT NQ 0
      THEN
        BEGIN  # DEFINE ERROR # 
        IF PFSTAT EQ FAP
        THEN                         # IF FILE ALREADY EXISTS # 
          BEGIN 
          ERRSTAT = CMASTAT"INTLZD";
          END 
  
        ELSE
          BEGIN 
          ERRSTAT = CMASTAT"DEFERR";
          END 
  
        RETURN;                      # RETURN ERROR STATUS #
        END  # DEFINE ERROR # 
  
# 
*     CREATE SKELETON CATALOG.
# 
  
      FASTFOR I = 1 STEP 1 UNTIL WBUFL
      DO                             # ZERO FILL WORKING BUFFER # 
        BEGIN 
        WBUF$W[I] = 0;
        END 
  
      P<PREAMBLE> = WBUFADR;
      PRM$FAM[0] = FAMNM; 
      PRM$SUBF[0] = SUBF; 
# 
*     THE PRM$ID IS SET TO 1 FOR THE M860 SFMCAT SO THAT IF 
*     MSS AMD M860 ARE EVER RUN IN PARALLEL PFDUMP CAN DISTINGUISH
*     BETWEEN THE TWO.
# 
      PRM$ID[0] = 1;
      ZSETFET(TFETADR,FLNM,TBUFADR,TBUFL,RFETL);  # SET UP FET #
      FET$EP[0] = TRUE; 
      WRITEW(FETSET[0],PREAMBLE,WBUFL,STAT);
      WRITEF(FETSET[0],RCL);
      IF FET$AT[0] NQ 0 
      THEN
        BEGIN 
        ERRSTAT = CMASTAT"CIOERR";
        END 
  
      RETERN(FETSET[0],RCL);
      RETURN; 
      END  # CINIT #
  
    TERM
PROC CNAME(FLNM); 
# TITLE CNAME - GET LFN FOR CATALOG.                                  # 
      BEGIN  # CNAME #
  
# 
**    CNAME - GET LFN FOR CATALOG.
* 
*     *CNAME* SUPPLIES A 7 CHARACTER NAME TO BE USED AS THE LFN ON AN 
*     ATTACH OF A CATALOG FILE. 
* 
*     CNAME - IS CALLED BY COPEN. 
*     PROC CNAME(FLNM)
* 
*     EXIT       (FLNM) - A SEVEN CHARACTER FILE NAME.
* 
*     NOTES      *INT$NUM* IS INITIALIZED TO 1000000D SO THAT 
*                WHEN IT IS CONVERTED TO DISPLAY CODE, THE RESULT 
*                WILL CONTAIN DISPLAY CODED NUMBERS IN THE BOTTOM 
*                6 CHARACTERS RATHER THAN BLANKS. 
# 
  
      ITEM FLNM       C(7);          # FILE NAME #
  
# 
****  PROC CNAME - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        FUNC XCDD C(10);             # INTEGER TO DISPLAY CODE
                                       CONVERSION # 
        END 
  
# 
****  PROC CNAME - XREF LIST END. 
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBCMD 
  
      ITEM DC$NUM     C(10);         # DISPLAY CODE NUMBER #
      ITEM INT$NUM    I = 1000000;   # INTEGER NUMBER # 
      ITEM NEXTNM     C(7) = "C000000";  # NEXT FILE NAME # 
CONTROL EJECT;
  
      FLNM = NEXTNM;                 # SET FILE NAME #
  
# 
*     INCREMENT FILE NAME.
# 
  
      INT$NUM = INT$NUM + 1;
      DC$NUM = XCDD(INT$NUM); 
      C<1,6>NEXTNM = C<4,6>DC$NUM;
      B<0,60>DC$NUM = 0;             # CLEAR DISPLAY CODE VALUE # 
      RETURN; 
      END  # CNAME #
  
    TERM
PROC COPEN((FAMNM),(SUBF),(FLNM),(ATTM),(ACCM),ERRSTAT);
# TITLE COPEN - OPEN CATALOG.                                         # 
      BEGIN  # COPEN #
  
# 
**    COPEN - OPEN CATALOG. 
* 
*     *COPEN* PREPARES THE GIVEN CATALOG FOR SUBSEQUENT REFERENCE 
*     BY THE CALLER.
* 
*     COPEN - IS CALLED BY DBMAIN,LBRMMSC,OPENCAT,USRPDE,USRPBAS, 
*             VLSUBFM.
* 
*     PROC COPEN((FAMNM),(SUBF),(FLNM),(ATTM),(ACCM),ERRSTAT) 
* 
*     ENTRY      (FAMNM)   - FAMILY NAME, LEFT JUSTIFIED, ZERO FILLED,
*                            7 CHARACTER MAXIMUM. 
*                (SUBF)    - SUBFAMILY DESIGNATOR.
*                (FLNM)    - CATALOG FILE NAME, LEFT JUSTIFIED, ZERO
*                            FILLED, 7 CHARACTER MAXIMUM. 
*                (ATTM)    - FILE ATTACH MODE IN DISPLAY CODE.
*                            = *M*, MODIFY MODE.
*                            = *RM*, READ/ALLOW MODIFY MODE.
*                (ACCM)    - FILE ACCESS MODE.
*                            = FALSE, RANDOM ACCESS.
*                            = TRUE, SEQUENTIAL ACCESS. 
* 
*                CALLER MUST ISSUE *SETPFP* TO APPROPRIATE FAMILY AND 
*                USER INDEX, IF THE CATALOG FILE IS NOT LOCAL.
* 
*     EXIT       (ERRSTAT) - ERROR STATUS.
*                            (VALUES DEFINED IN *COMBCMS*)
*                            =  NO ERRORS.
*                            =  CATALOG FILE INTERLOCKED. 
*                            =  CATALOG ALREADY OPEN. 
*                            =  *CIO* ERROR.
*                            =  CATALOG ATTACH ERROR. 
*                            =  OPEN CATALOG TABLE FULL.
* 
*     NOTES      THE PFN OF AN MSF CATALOG IS *SFMCATX*, WHERE *X* IS 
*                THE SUBFAMILY DESIGNATOR.
*                *COPEN* ATTACHES THE CATALOG FILE *SFMCATX*, CREATES 
*                AN ENTRY IN THE *OCT* AND IF THE CATALOG IS NOT
*                INTERLOCKED, THE FIRST WORD OF THE HEADER AND OF EACH
*                SUBCATALOG ENTRY IN THE PREAMBLE IS READ INTO A
*                TABLE.  IF THE CALLER HAS ALREADY ATTACHED THE 
*                CATALOG FILE, (FLNM) MUST BE THE LFN OF THE FILE 
*                INSTEAD OF THE PFN, SO THAT THE ATTACH WILL BE 
*                BYPASSED.
# 
  
      ITEM FAMNM      C(7);          # FAMILY NAME #
      ITEM SUBF       U;             # SUBFAMILY DESIGNATOR # 
      ITEM FLNM       C(7);          # CATALOG FILE NAME #
      ITEM ATTM       C(2);          # FILE ATTACH MODE # 
      ITEM ACCM       B;             # FILE ACCESS MODE # 
      ITEM ERRSTAT    I;             # ERROR STATUS # 
  
# 
****  PROC COPEN - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC CNAME;                  # GET CATALOG LFN #
        PROC CRDPRM;                 # READ CATALOG PREAMBLE #
        PROC PFD;                    # PERMANENT FILE REQUEST DELAYS #
        END 
  
# 
****  PROC COPEN - XREF LIST END. 
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBCMD 
*CALL COMBCMS 
*CALL COMBMCT 
*CALL COMBPFS 
*CALL COMXCTF 
*CALL COMXMSC 
*CALL COMSPFM 
  
      ITEM I          I;             # LOOP COUNTER # 
      ITEM LFN        C(7);          # LOCAL FILE NAME #
      ITEM ORD        I;             # ORDINAL OF *OCT* ENTRY # 
CONTROL EJECT;
  
      ERRSTAT = CMASTAT"NOERR"; 
      IF C<0,6>FLNM EQ SFMCAT 
      THEN                           # IF FILE NOT ALREADY ATTACHED # 
        BEGIN 
  
# 
*     ATTACH CATALOG FILE.
# 
  
        CNAME(LFN); 
        PFD("ATTACH",LFN,FLNM,"M",ATTM,"RC",PFSTAT,"NA",0,"UP",0,0);
        IF PFSTAT NQ 0 AND PFSTAT NQ FBS
        THEN                         # IF ATTACH ERROR #
          BEGIN 
          ERRSTAT = CMASTAT"ATTERR";
          RETURN;                    # RETURN ERROR STATUS #
          END 
  
        END 
  
      ELSE
        BEGIN 
        LFN = FLNM; 
        END 
  
# 
*     CREATE AN OPEN CATALOG TABLE ENTRY. 
# 
  
      ORD = 0;
      FASTFOR I = 1 STEP 1 WHILE I LQ OCTLEN AND ORD EQ 0 
      DO
        BEGIN  # SEARCH *OCT* # 
        IF OCT$SUBF[I] EQ SUBF       ## 
          AND OCT$FAM[I] EQ FAMNM 
        THEN                         # IF CATALOG ALREADY OPEN #
          BEGIN 
          ERRSTAT = CMASTAT"FOPEN"; 
          RETURN;                    # RETURN ERROR STATUS #
          END 
  
        IF OCT$W1[I] EQ 0 
        THEN                         # IF EMPTY ENTRY # 
          BEGIN 
          ORD = I;
          END 
  
        END  # SEARCH *OCT* # 
  
      IF ORD EQ 0 
      THEN                           # IF NO EMPTY ENTRIES #
        BEGIN 
        ERRSTAT = CMASTAT"OCTFULL"; 
        RETURN;                      # RETURN ERROR STATUS #
        END 
  
      OCT$FAM[ORD] = FAMNM; 
      OCT$SUBF[ORD] = SUBF; 
      OCT$LFN[ORD] = LFN; 
      OCT$ATTM[ORD] = ATTM; 
      OCT$BUFL[ORD] = SEQBL;
  
# 
*     CHECK FOR CATALOG INTERLOCK.
# 
  
      IF PFSTAT EQ FBS
      THEN                           # IF CATALOG INTERLOCKED # 
        BEGIN 
        OCT$INTLK[ORD] = TRUE;       # SET INTERLOCK FLAGS #
        GLBINTLK = TRUE;
        ERRSTAT = CMASTAT"INTLK"; 
        RETURN;                      # RETURN WITH INTERLOCK STATUS # 
        END 
  
      CRDPRM(ORD,ERRSTAT);           # READ AND UPDATE PREAMBLE # 
      RETURN; 
      END  # COPEN #
  
    TERM
PROC CPIOERR((FAMNM),(SUBF),(QRADDR),ERRSTAT,FET);
# TITLE CPIOERR - PROCESS I/O ERROR ON MSF CATALOG.                   # 
  
      BEGIN  # CPIOERR #
  
# 
**    CPIOERR - PROCESS I/O ERROR ON MSF CATALOG. 
* 
*     *CPIOERR* CLOSES THE MSF CATALOG WITH THE I/O ERROR AND SETS
*     AN I/O ERROR STATUS.  IF CALLED BY THE MSS EXECUTIVE IT ALSO
*     DUMPS THE FET FOR THE CATALOG TO *LOGFILE* AND ISSUES 
*     AN ERROR MESSAGE TO THE K-DISPLAY AND TO EXEC-S DAYFILE.
* 
*     CPIOERR - IS CALLED BY BFLUSH,CADDSC,CEXTSC,CGETPD,CPUTPD,
*              CRDAST,CWTAST. 
* 
*     PROC CPIOERR((FAMNM),(SUBF),(QRADDR),ERRSTAT,FET) 
* 
*     ENTRY      (FAMNM) - FAMILY NAME. 
*                (SUBF) - SUBFAMILY DESIGNATOR. 
*                (QRADDR) - *HLRQ* ENTRY ADDRESS, ELSE ZERO.
*                FET - AN ARRAY CONTAINING THE FET FOR THE MSF CATALOG. 
* 
*     EXIT       (ERRSTAT) - ERROR STATUS (VALUES DEFINED IN
*                            *COMBCMS*).
*                            = *CIO* ERROR. 
* 
*     MESSAGES   * I/O ERROR ON SFMCATN, CATALOG CLOSED.
*                  RESPOND GO TO ACKNOWLEDGE.*
# 
  
      ITEM FAMNM      C(7);          # FAMILY NAME #
      ITEM SUBF       U;             # SUBFAMILY DESIGNATOR # 
      ITEM QRADDR     U;             # *HLRQ* ENTRY ADDRESS # 
      ITEM ERRSTAT    I;             # ERROR STATUS # 
  
# 
****  PROC CPIOERR - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC CCLOSE;                 # CLOSE MSF CATALOG #
        PROC KREQ;                   # K-DISPLAY REQUEST #
        PROC RECALL;                 # RECALL # 
        END 
  
# 
****  PROC CPIOERR - XREF LIST END. 
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBCMD 
*CALL COMBCMS 
*CALL COMBKDD 
  
      ARRAY FET [0:0] P(RFETL); ;    # MSF CATALOG FET #
                                               CONTROL EJECT; 
  
      IF EXEC 
      THEN
        BEGIN  # MSS EXECUTIVE PROCESSING # 
  
# 
*     ISSUE ERROR MESSAGE TO EXEC-S DAYFILE AND TO THE K-DISPLAY. 
# 
  
        P<KWORD> = LOC(KDISBLK[0]); 
        IF KW$WORD[0] NQ 0 AND NOT KW$COMP[0] 
        THEN                         # PREVIOUS MESSAGE NOT ISSUED #
          BEGIN  # K-DISPLAY WORD BUSY #
          REPEAT WHILE NOT KW$COMP[0] 
          DO                         # WAIT FOR MESSAGE TO BE ISSUED #
            BEGIN 
            RECALL(0);
            END 
  
          END  # K-DISPLAY WORD BUSY #
  
        KW$WORD[0] = 0; 
        KW$IC[0] = TRUE;
        KW$RPGO[0] = TRUE;
        KW$DF[0] = TRUE;
        KW$LINE1[0] = KM"KM13"; 
        KW$LINE2[0] = KM"KM21"; 
        KP$SF = SUBF; 
        KREQ(P<KWORD>,KLINK); 
        END  # MSS EXECUTIVE PROCESSING # 
  
      CCLOSE(FAMNM,SUBF,QRADDR,ERRSTAT);  # CLOSE MSF CATALOG # 
      ERRSTAT = CMASTAT"CIOERR";
      RETURN; 
      END  # CPIOERR #
  
    TERM
PROC CPUTFCT((FAMNM),(SUBF),(SMID ),(FCTORD),(BADDR),(QRADDR),
      ERRSTAT); 
# TITLE CPUTFCT - PUT AN *FCT* ENTRY.                                 # 
      BEGIN  # CPUTFCT #
  
# 
**    CPUTFCT - PUT AN *FCT* ENTRY. 
* 
*     *CPUTFCT* TRANSFERS THE SPECIFIED FILE AND CARTRIDGE TABLE ENTRY
*     FROM THE CALLERS BUFFER TO THE I/O BUFFER.  THE CATALOG MUST
*     BE OPEN IN MODIFY MODE. 
* 
*     CPUTFCT - IS CALLED BY RLS$FCT. 
*     PROC CPUTFCT((FAMNM),(SUBF),(SMID ),(FCTORD),(BADDR), 
*       (QRADDR),ERRSTAT) 
* 
*     ENTRY      (FAMNM)  - FAMILY NAME, LEFT JUSTIFIED, ZERO FILLED, 
*                           7 CHARACTER MAXIMUM.
*                (SUBF)   - SUBFAMILY DESIGNATOR. 
*                (SMID )  - NUMERIC SM  IDENTIFIER. 
*                (FCTORD) - ORDINAL OF ENTRY IN *FCT*.
*                (BADDR)  - ADDRESS OF BUFFER TO RECEIVE *FCT* ENTRY. 
*                (QRADDR) - ADDRESS OF *HLRQ* ENTRY, ELSE ZERO. 
* 
*     EXIT       THE REQUESTED *FCT* ENTRY IS TRANSFERRED TO THE *FCT*
*                I/O BUFFER FROM THE ADDRESS SPECIFIED BY (BADDR).
*                (ERRSTAT) - ERROR STATUS.
*                            (VALUES DEFINED IN *COMBCMS*)
*                          =  NO ERROR. 
*                          =  CATALOG FILE INTERLOCKED. 
*                          =  CATALOG NOT OPEN. 
*                          =  CATALOG NOT OPEN IN MODIFY MODE.
*                          =  NO SUCH SUBCATALOG. 
*                          =  *CIO* ERROR.
*                          =  *FCT* ORDINAL OUT OF RANGE. 
* 
*     NOTES      THE *FCT* ENTRY IS TRANSFERRED FROM THE CALLERS BUFFER 
*                BACK TO THE I/O BUFFER, BUT IS NOT WRITTEN TO THE
*                CATALOG FILE UNTIL SOME SUBSEQUENT REQUEST CAUSES
*                THE I/O BUFFER TO BE FLUSHED.
# 
  
      ITEM FAMNM      C(7);          # FAMILY NAME #
      ITEM SUBF       U;             # SUBFAMILY DESIGNATOR # 
      ITEM SMID       U;             # SM  IDENTIFIER # 
      ITEM FCTORD     I;             # *FCT* ORDINAL #
      ITEM BADDR      U;             # ADDRESS OF *FCT* ENTRY BUFFER #
      ITEM QRADDR     U;             # *HLRQ* ENTRY ADDRESS # 
      ITEM ERRSTAT    I;             # ERROR STATUS # 
  
# 
****  PROC CPUTFCT - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC CBUFMAN;                # MANAGE CATALOG *FCT* BUFFER #
        END 
  
# 
****  PROC CPUTFCT - XREF LIST END. 
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBCMD 
*CALL COMBCMS 
*CALL COMBMCT 
  
      ITEM I          I;             # LOOP COUNTER # 
      ITEM MODF       B = TRUE;      # MODIFY MODE FLAG # 
      ITEM OFFSET     I;             # WORD OFFSET WITHIN BUFFER #
  
      BASED 
      ARRAY ENTBUF [1:FCTENTL] P(1);  # *FCT* ENTRY BUFFER #
        BEGIN 
        ITEM ENT$WRD    I(00,00,60);  # ENTRY WORD #
        END 
  
CONTROL EJECT;
  
# 
*     ENSURE THAT REQUESTED *FCT* ENTRY IS WITHIN I/O BUFFER. 
# 
  
      CBUFMAN(FAMNM,SUBF,SMID,FCTORD,MODF,QRADDR,ERRSTAT);
      IF ERRSTAT NQ CMASTAT"NOERR"
      THEN
        BEGIN 
        RETURN;                      # RETURN ERROR STATUS #
        END 
  
# 
*     TRANSFER ENTRY TO *FCT* I/O BUFFER. 
# 
  
      P<FCTBUF> = FCTBADR;
      P<ENTBUF> = BADDR;
      SLOWFOR I = 1 STEP 1 UNTIL FCTENTL
      DO
        BEGIN 
        FCTB$WRD[I] = ENT$WRD[I]; 
        END 
  
      FB$BMF[0] = TRUE;              # SET BUFFER MODIFIED FLAG # 
      RETURN; 
      END  # CPUTFCT #
  
    TERM
PROC CPUTPD((FAMNM),(SUBF),(SMID ),(QRADDR),ERRSTAT); 
# TITLE CPUTPD - PUT PURGE DATE.                                      # 
      BEGIN  # CPUTPD # 
  
# 
**    CPUTPD - PUT PURGE DATE.
* 
*     *CPUTPD* PUTS THE DATE AND TIME OF THE LAST PURGE OF ORPHAN 
*     FILES (AN MSF FILE WITH NO REFERENCE TO IT IN THE PFC) INTO THE 
*     APPROPRIATE CATALOG PREAMBLE ENTRY.  THE CURRENT PACKED DATE AND
*     TIME IS USED.  THE CATALOG MUST BE OPEN IN MODIFY MODE. 
* 
*     CPUTPD - IS CALLED BY PURGCHN,UPDCAT. 
* 
*     PROC CPUTPD((FAMNM),(SUBF),(SMID ),(QRADDR),ERRSTAT)
* 
*     ENTRY      (FAMNM)  - FAMILY NAME, LEFT JUSTIFIED, ZERO FILLED, 
*                           7 CHARACTER MAXIMUM.
*                (SUBF)   - SUBFAMILY DESIGNATOR. 
*                (SMID )  - NUMERIC SM  IDENTIFIER. 
*                (QRADDR) - *HLRQ* ENTRY ADDRESS, ELSE ZERO.
* 
*     EXIT       THE CURRENT PACKED DATE AND TIME IS WRITTEN IN THE 
*                SPECIFIED SUBCATALOG ENTRY IN THE PREAMBLE.
*                (ERRSTAT) - ERROR STATUS.
*                            (VALUES DEFINED IN *COMBCMS*)
*                            =  NO ERRORS.
*                            =  CATALOG FILE INTERLOCKED. 
*                            =  CATALOG NOT OPEN. 
*                            =  CATALOG NOT OPEN IN MODIFY MODE.
*                            =  NO SUCH SUBCATALOG EXISTS.
*                            =  *CIO* ERROR.
* 
*     NOTE       THE PREAMBLE TABLE DOES NOT CONTAIN THE LAST PURGE 
*                DATE AND TIME (ONLY THE FIRST WORD OF EACH SUBCATALOG
*                ENTRY IS IN THE TABLE), SO THE PREAMBLE MUST BE READ 
*                FROM AND WRITTEN TO THE CATALOG. 
# 
  
      ITEM FAMNM      C(7);          # FAMILY NAME #
      ITEM SUBF       U;             # SUBFAMILY DESIGNATOR # 
      ITEM SMID       U;             # SM  IDENTIFIER # 
      ITEM QRADDR     U;             # *HLRQ* ENTRY ADDRESS # 
      ITEM ERRSTAT    I;             # ERROR STATUS # 
  
# 
****  PROC CPUTPD - XREF LIST BEGIN.
# 
  
      XREF
        BEGIN 
        PROC CPIOERR;                # PROCESS MSF CATALOG I/O ERROR #
        PROC OCTSRCH;                # SEARCH OPEN CATALOG TABLE #
        PROC PDATE;                  # OBTAIN PACKED DATE AND TIME #
        PROC RPHR;                   # READ PRU TO *CIO* BUFFER # 
        PROC WPHR;                   # WRITE PRU FROM *CIO* BUFFER #
        PROC ZSETFET;                # INITIALIZES A FET #
        END 
  
# 
****  PROC CPUTPD - XREF LIST END.
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBCMD 
*CALL COMBCMS 
*CALL COMBFET 
*CALL COMBMCT 
*CALL COMXMSC 
*CALL COMSPFM 
  
      ITEM LASTPRG    U;             # LAST PURGE DATE #
      ITEM ORD        I;             # ORDINAL OF *OCT* ENTRY # 
CONTROL EJECT;
  
      OCTSRCH(FAMNM,SUBF,ORD,QRADDR,ERRSTAT);  # GET *OCT* ORDINAL #
      IF ERRSTAT NQ CMASTAT"NOERR"
      THEN
        BEGIN 
        RETURN;                      # RETURN ERROR STATUS #
        END 
  
      IF OCT$ATTM[ORD] NQ "M" 
      THEN                           # IF NOT OPEN IN MODIFY MODE # 
        BEGIN 
        ERRSTAT = CMASTAT"MODERR";
        RETURN;                      # RETURN ERROR STATUS #
        END 
  
      P<PREAMBLE> = OCT$PRMA[ORD];
      IF PRM$SCW1[SMID ] EQ 0 
      THEN                           # IF NO SUCH SUBCATALOG #
        BEGIN 
        ERRSTAT = CMASTAT"NOSUBCAT";
        RETURN; 
        END 
  
# 
*     PUT DATE AND TIME OF LAST PURGE OF ORPHAN FILES INTO PREAMBLE.
# 
  
      PDATE(LASTPRG);                # GET PACKED DATE AND TIME # 
      PRM$PDATE[SMID] = LASTPRG;
      ZSETFET(TFETADR,OCT$LFN[ORD],TBUFADR,TBUFL,RFETL);
      FET$EP[0] = TRUE; 
      FET$R[0] = TRUE;
      FET$RR[0] = 1;
      RPHR(FETSET[0],RCL);
      IF FET$AT[0] NQ 0 
      THEN
        BEGIN 
        GOTO ERR; 
        END 
  
      P<PREAMBLE> = TBUFADR;
      PRM$PDATE[SMID ] = LASTPRG; 
      FET$RR[0] = 1;
      FET$W[0] = TRUE;
      WPHR(FETSET[0],RCL);
      IF FET$AT[0] NQ 0 
      THEN
        BEGIN 
        GOTO ERR; 
        END 
  
      RETURN; 
  
ERR:                                 # PROCESS *CIO* ERROR #
      CPIOERR(FAMNM,SUBF,QRADDR,ERRSTAT,FETSET[0]); 
      RETURN; 
      END  # CPUTPD # 
  
    TERM
PROC CRCLMLK(ERRSTAT);
# TITLE CRCLMLK - RECLAIM CATALOG INTERLOCKS.                         # 
      BEGIN  # CRCLMLK #
  
# 
**    CRCLMLK - RECLAIM CATALOG INTERLOCKS. 
* 
*     *CRCLMLK* TRIES TO RECLAIM ALL MSF CATALOG INTERLOCKS.  IF THE
*     INTERLOCK IS RECLAIMED, (THE CATALOG IS SUCCESSFULLY ATTACHED)
*     THE STATUS OF ALL WAITING-FOR-INTERLOCK REQUESTS ARE SET
*     TO READY. 
* 
*     CRCLMLK - IS CALLED BY RCLMLK.
* 
*     PROC CRCLMLK(ERRSTAT) 
* 
*     EXIT       THE CATALOG INTERLOCK IS RECLAIMED IF THE CATALOG
*                WAS SUCCESSFULLY ATTACHED. 
*                (ERRSTAT) - ERROR STATUS.
*                            (VALUES DEFINED IN *COMBCMS*)
*                            =  NO ERRORS.
*                            =  *CIO* ERROR.
*                            =  CATALOG ATTACH ERROR. 
*                IF THE DESIRED FAMILY IS NOT FOUND ON A *SETPFP*, AN 
*                ERROR MESSAGE IS ISSUED AND THE PROGRAM IS ABORTED.
* 
*     NOTES      IF A CATALOG OPEN REQUEST WAS PREVIOUSLY ISSUED BUT
*                THE CATALOG WAS INTERLOCKED AT THAT TIME, THE
*                REMAINDER OF THE OPEN PROCESSING WILL BE DONE IF THE 
*                CATALOG INTERLOCK IS RECLAIMED.  FOR ALL OTHER 
*                REQUESTS, THE INTERLOCK BIT IN THE *OCT* IS MERELY 
*                CLEARED. 
* 
*     MESSAGES   * PROGRAM ABNORMAL, CRCLMLK.*. 
*                * UNABLE TO REATTACH MSF CATALOG.
*                  SFMCATN FOR FAMILY FFFFFFF CLOSED.*
# 
  
      ITEM ERRSTAT    I;             # ERROR STATUS # 
  
# 
**** PROC CRCLMLK - XREF LIST BEGIN.
# 
  
      XREF
        BEGIN 
        PROC ABORT;                  # ABORT #
        PROC ADD$LNK;                # ADD ENTRY TO END OF CHAIN #
        PROC BZFILL;                 # BLANK OR ZERO FILL WORD #
        PROC CRDPRM;                 # READ CATALOG PREAMBLE #
        PROC MESSAGE;                # ISSUE MESSAGE #
        PROC PF;                     # *PFM* REQUEST INTERFACE #
        PROC RMVBLNK;                # REMOVE MULTIPLE BLANKS # 
        PROC RTIME;                  # GET REAL TIME CLOCK READING #
        PROC SETPFP;                 # SET PERMANENT FILE PARAMETERS #
        FUNC XCDD C(10);             # INTEGER TO DISPLAY CODE
                                       CONVERSION # 
        PROC ZFILL;                  # ZERO FILL A BUFFER # 
        END 
  
# 
****  PROC CRCLMLK - XREF LIST END. 
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBBZF 
*CALL COMBCHN 
*CALL COMBCMD 
*CALL COMBCMS 
*CALL COMBMCT 
*CALL COMBPFP 
*CALL COMXCTF 
*CALL COMXHLR 
*CALL COMXIPR 
*CALL COMXMSC 
*CALL COMSPFM 
  
      ITEM CATPFN     C(7);          # MSS CATALOG PFN #
      ITEM DIS$SUBF   C(10);         # SUBFAMILY (DISPLAY CODE) # 
      ITEM FAMILY     C(7);          # FAMILY NAME #
      ITEM I          I;             # LOOP COUNTER # 
      ITEM INTLK      B;             # INTERLOCK STATUS # 
      ITEM STAT       I;             # ATTACH STATUS #
      ITEM TEMP       U;             # TEMPORARY STORAGE #
CONTROL EJECT;
  
      ERRSTAT = CMASTAT"NOERR";      # INITIALIZE VALUES #
      INTLK = FALSE;
      PFP$WRD0[0] = 0;
      PFP$FG1[0] = TRUE;
      PFP$FG4[0] = TRUE;
  
# 
*     SEARCH OPEN CATALOG TABLE FOR INTERLOCKED CATALOGS. 
# 
  
      FASTFOR I = 1 STEP 1 UNTIL OCTLEN 
      DO
        BEGIN  # SEARCH *OCT* # 
        IF NOT OCT$INTLK[I] 
        THEN                         # IF CATALOG NOT INTERLOCKED # 
          BEGIN 
          TEST I;                    # CHECK NEXT ENTRY # 
          END 
  
        PFP$FAM[0] = OCT$FAM[I];     # SET FAMILY AND USER INDEX #
        PFP$UI[0] = DEF$UI + OCT$SUBF[I]; 
        SETPFP(PFP);
        IF PFP$STAT[0] NQ 0 
        THEN                         # IF FAMILY NOT FOUND #
          BEGIN 
          CMA$RTN[0] = "CRCLMLK.";
          MESSAGE(CMAMSG,UDFL1);     # ISSUE ERROR MESSAGE #
          ABORT;
          END 
  
# 
*     ATTEMPT CATALOG FILE ATTACH.
# 
  
        CATPFN = SFMCAT;             # BUILD CATALOG PFN #
        DIS$SUBF = XCDD(OCT$SUBF[I]); 
        C<6,1>CATPFN = C<9,1>DIS$SUBF;
        PF("ATTACH",OCT$LFN[I],CATPFN,"M",OCT$ATTM[I],
          "RC",STAT,"NA",0,"UP",0,"SR","IE",0); 
        IF STAT EQ FBS OR STAT EQ PFA OR STAT EQ INA  ##
          OR STAT EQ FTF OR STAT EQ PEA 
        THEN                         # FILE BUSY OR TEMPORARY ERROR # 
          BEGIN 
          INTLK = TRUE; 
          END 
  
        ELSE
          BEGIN  # FILE NOT INTERLOCKED # 
          OCT$INTLK[I] = FALSE; 
          TEMP = OCT$LINK[I]; 
          OCT$LINK[I] = 0;
          REPEAT WHILE TEMP NQ 0
          DO
            BEGIN  # ADD WAITING REQUESTS TO READY CHAIN #
            P<HLRQ> = TEMP; 
            TEMP = HLR$LNK1[0]; 
            ADD$LNK(P<HLRQ>,LCHN"HL$READY",0);
            END  # ADD WAITING REQUESTS TO READY CHAIN #
  
          IF STAT NQ 0
          THEN                       # IF ATTACH ERROR #
            BEGIN 
            CMSGLINE[0] = CMSG3;
            MESSAGE(CMSGAREA,UDFL1);
            CMSGLINE[0] = CMSGCLOSE;
            CMSGCSUBF[0] = C<9,1>DIS$SUBF;
            FAMILY = OCT$FAM[I];
            BZFILL(FAMILY,TYPFILL"BFILL",7);
            CMSGCFAM[0] = FAMILY; 
            RMVBLNK(CMSGAREA,48); 
            MESSAGE(CMSGAREA,UDFL1);
            ZFILL(OCT[I],OCTENTL);   # CLEAR *OCT* ENTRY #
            TEST I; 
            END 
  
# 
*     CHECK FOR CATALOG OPENED. 
# 
  
          IF OCT$PRMA[I] EQ 0 
          THEN                       # IF CATALOG OPEN NOT COMPLETE # 
            BEGIN 
            CRDPRM(I,ERRSTAT);       # FINISH CATALOG OPEN #
            IF ERRSTAT NQ CMASTAT"NOERR"
            THEN
              BEGIN 
              RETURN;                # RETURN ERROR STATUS #
              END 
  
            END 
  
          END  # FILE NOT INTERLOCKED # 
  
        END  # SEARCH *OCT* # 
  
      IF NOT INTLK
      THEN                           # IF NO CATALOGS INTERLOCKED # 
        BEGIN 
        GLBINTLK = FALSE;            # CLEAR GLOBAL INTERLOCK FLAG #
        ITLK$EXPIR = 0; 
        END 
  
      ELSE
        BEGIN 
        RTIME(RTIMESTAT[0]);
        ITLK$EXPIR = RTIMSECS[0] + INLK$INTV; 
        END 
  
      RETURN; 
      END  # CRCLMLK #
  
    TERM
PROC CRDAST((FAMNM),(SUBF),(SMID ),(BADDR),(QRADDR),ERRSTAT); 
# TITLE CRDAST - READ AVAILABLE STREAM TABLE.                         # 
      BEGIN  # CRDAST # 
  
# 
**    CRDAST - READ AVAILABLE STREAM TABLE. 
* 
*     *CRDAST* READS THE ENTIRE AVAILABLE STREAM TABLE DIRECTLY INTO
*     THE CALLERS BUFFER. 
* 
*     CRDAST - IS CALLED BY ADDCAR,ADDCUBE,ADDCSU,ALLOCAT,DESTAGR,
*              OPENCAT,PURGCHN,PURGFCT,RLSUNS,RMVCAR,RMVCUBE,SERAST,
*              STAGER,UPDCAT. 
* 
*     PROC CRDAST((FAMNM),(SUBF),(SMID ),(BADDR),(QRADDR),ERRSTAT)
* 
*     ENTRY      (FAMNM)  - FAMILY NAME, LEFT JUSTIFIED, ZERO FILLED, 
*                           7 CHARACTER MAXIMUM.
*                (SUBF)   - SUBFAMILY DESIGNATOR. 
*                (SMID )  - NUMERIC SM  IDENTIFIER. 
*                (BADDR)  - ADDRESS OF BUFFER TO CONTAIN *AST*. 
*                (QRADDR) - *HLRQ* ENTRY ADDRESS, ELSE ZERO.
* 
*     EXIT       THE *AST* HAS BEEN READ INTO THE BUFFER AT THE ADDRESS 
*                SPECIFIED BY (BADDR).
*                (ERRSTAT) - ERROR STATUS.
*                            (VALUES DEFINED IN *COMBCMS*)
*                            =  NO ERRORS.
*                            =  CATALOG FILE INTERLOCKED. 
*                            =  CATALOG NOT OPEN. 
*                            =  NO SUCH SUBCATALOG. 
*                            =  *CIO* ERROR.
* 
*     NOTES      THE *AST* IS READ DIRECTLY INTO THE CALLERS BUFFER.
*                IT IS THE CALLERS RESPONSIBILITY TO ENSURE THAT THE
*                BUFFER IS LARGE ENOUGH TO CONTAIN THE ENTIRE *AST*.
*                THE BUFFER SIZE SHOULD BE THE LENGTH OF THE *AST*
*                ROUNDED UP TO A PRU SIZE MULTIPLE OR LARGER. 
# 
  
      ITEM FAMNM      C(7);          # FAMILY NAME #
      ITEM SUBF       U;             # SUBFAMILY DESIGNATOR # 
      ITEM SMID       U;             # SM  IDENTIFIER # 
      ITEM BADDR      U;             # *AST* BUFFER ADDRESS # 
      ITEM QRADDR     U;             # *HLRQ* ENTRY ADDRESS # 
      ITEM ERRSTAT    I;             # ERROR STATUS # 
  
# 
****  PROC CRDAST - XREF LIST BEGIN.
# 
  
      XREF
        BEGIN 
        PROC CPIOERR;                # PROCESS MSF CATALOG I/O ERROR #
        PROC CRDPRM;
        PROC OCTSRCH;                # SEARCH OPEN CATALOG TABLE #
        PROC READ;                   # READ FILE TO *CIO* BUFFER #
        PROC ZSETFET;                # INITIALIZES A FET #
        END 
  
# 
****  PROC CRDAST - XREF LIST END.
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBCMD 
*CALL COMBCMS 
*CALL COMBFET 
*CALL COMBMCT 
*CALL COMXMSC 
  
      ITEM LENGTH     I;             # *AST* LENGTH # 
      ITEM ORD        I;             # ORDINAL OF *OCT* ENTRY # 
CONTROL EJECT;
  
      OCTSRCH(FAMNM,SUBF,ORD,QRADDR,ERRSTAT);  # GET *OCT* ORDINAL #
      IF ERRSTAT NQ CMASTAT"NOERR"
      THEN
        BEGIN 
        RETURN;                      # RETURN ERROR STATUS #
        END 
  
      P<PREAMBLE> = OCT$PRMA[ORD];
      IF PRM$SCW1[SMID ] EQ 0 
      THEN                           # IF NO SUCH SUBCATALOG #
        BEGIN 
        ERRSTAT = CMASTAT"NOSUBCAT";
        RETURN; 
        END 
  
     LENGTH = ABUFLEN;
  
# 
*     READ ENTIRE *AST* INTO CALLERS BUFFER.
# 
  
      ZSETFET(TFETADR,OCT$LFN[ORD],BADDR,LENGTH,RFETL); 
      FET$EP[0] = TRUE; 
      FET$R[0] = TRUE;
      FET$RR[0] = PRM$ASTLOC[SMID ];
      READ(FETSET[0],RCL);
      IF FET$AT[0] NQ 0 
      THEN
        BEGIN 
        CPIOERR(FAMNM,SUBF,QRADDR,ERRSTAT,FETSET[0]); 
        RETURN; 
        END 
  
      CRDPRM(ORD,ERRSTAT);
      RETURN; 
      END  # CRDAST # 
  
    TERM
PROC CRDPRM((TORD),ERRSTAT);
# TITLE CRDPRM - READ CATALOG PREAMBLE.                               # 
      BEGIN  # CRDPRM # 
  
# 
**    CRDPRM - READ CATALOG PREAMBLE. 
* 
*     *CRDPRM* READS THE  HEADER  OF EACH 
*     SUBCATALOG ENTRY IN THE PREAMBLE INTO A BUFFER (THE 
*     PREAMBLE TABLE).
* 
*     CRDPRM - IS CALLED BY COPEN.
* 
*     PROC CRDPRM((TORD),ERRSTAT) 
* 
*     ENTRY      (TORD) - ORDINAL OF CATALOGS ENTRY IN THE OPEN CATALOG 
*                         TABLE.
* 
*     EXIT       A  CATALOG PREAMBLE IS READ INTO A BUFFER AND
*                UPDATED. 
*                (ERRSTAT) - ERROR STATUS.
*                            (VALUES DEFINED IN *COMBCMS*)
*                            =  NO ERRORS.
*                            =  *CIO* ERROR.
*                            =  CATALOG ATTACH ERROR. 
* 
*     NOTES      WHEN A CATALOG IS OPENED, A  PREAMBLE IS READ
*                INTO THE PREAMBLE TABLE, TO BE USED TO REFERENCE 
*                DATA IN THE PREAMBLE, THUS REDUCING DISK REFERENCES. 
# 
  
      ITEM TORD       I;             # OPEN CATALOG TABLE ORDINAL # 
      ITEM ERRSTAT    I;             # ERROR STATUS # 
  
# 
****  PROC CRDPRM - XREF LIST BEGIN.
# 
  
      XREF
        BEGIN 
        PROC CCLOSE;                 # CLOSE CATALOGS # 
        PROC CPIOERR;                # PROCESS MSF CATALOG I/O ERROR #
        PROC REWIND;                 # REWIND FILE #
        PROC RPHR;                   # READ PRU TO *CIO* BUFFER # 
        PROC ZSETFET;                # INITIALIZES A FET #
        END 
  
# 
****  PROC CRDPRM - XREF LIST END.
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBCMD 
*CALL COMBCMS 
*CALL COMBFET 
*CALL COMBMCT 
*CALL COMXMSC 
  
      ITEM I          I;             # LOOP COUNTER # 
      ITEM J          I;             # LOOP COUNTER # 
CONTROL EJECT;
  
# 
*     READ  CATALOG PREAMBLE INTO BUFFER. 
# 
  
      OCT$PRMA[TORD] = (PRMBADR+((TORD-1)*PRMTLEN*3));
      ZSETFET(TFETADR,OCT$LFN[TORD],TBUFADR,2*PRULEN,RFETL);
      FET$EP[0] = TRUE; 
      REWIND(FETSET[0],RCL);
      RPHR(FETSET[0],RCL);
      IF FET$AT[0] NQ 0 
      THEN
        BEGIN 
        GOTO ERR; 
        END 
  
      P<PREAMBLE> = OCT$PRMA[TORD]; 
  
# 
*     TRANSFER HEADER OF EACH ENTRY TO THE TABLE. 
# 
  
      FASTFOR I = 0 STEP 1 UNTIL MAXSM
      DO
        BEGIN 
        PRM$SCW1[I] = TBUF$W[I + 1];
        PRM$SCW2[I] = TBUF$W1[I + 1]; 
        PRM$SCW3[I] = TBUF$W2[I + 1]; 
        END 
  
      IF OCT$FAM[TORD] NQ PRM$FAM[0]  ##
        OR OCT$SUBF[TORD] NQ PRM$SUBF[0]
      THEN                           # IF WRONG CATALOG ATTACHED #
        BEGIN 
        CCLOSE(OCT$FAM[TORD],OCT$SUBF[TORD],0,ERRSTAT); 
        ERRSTAT = CMASTAT"ATTERR";
        RETURN;                      # RETURN ERROR STATUS #
        END 
  
  
# CHANGE DELETED 36 LINES THAT UPDATED STREAM COUNTS #
      RETURN; 
ERR:                                 # PROCESS *CIO* ERROR #
      CPIOERR(OCT$FAM[TORD],OCT$SUBF[TORD],0,ERRSTAT,FETSET[0]);
      RETURN; 
      END  # CRDPRM # 
  
    TERM
PROC CRELSLK((FAMNM),(MASK),(QRADDR),ERRSTAT);
# TITLE CRELSLK - RELEASE CATALOG INTERLOCKS.                         # 
      BEGIN  # CRELSLK #
  
# 
**    CRELSLK - RELEASE CATALOG INTERLOCKS. 
* 
*     *CRELSLK* RETURNS THE SPECIFIED CATALOGS IF THEY ARE INTERLOCKED
*     AND SETS THE INTERLOCK BIT IN THE OPEN CATALOG TABLE TO INDICATE
*     THAT THE INTERLOCK HAS BEEN GIVEN UP BY *MSSEXEC*.
* 
*     CRELSLK - IS CALLED BY HLRQMTR,TDAM$RP. 
* 
*     PROC CRELSLK((FAMNM),(MASK),(QRADDR),ERRSTAT) 
* 
*     ENTRY      (FAMNM)  - FAMILY NAME, LEFT JUSTIFIED, ZERO FILLED, 
*                           7 CHARACTER MAXIMUM.
*                (MASK)   - THE 8-BIT DEVICE MASK FOR A DEVICE. 
* 
*     EXIT       (ERRSTAT) - ERROR STATUS.
*                            (VALUES DEFINED IN *COMBCMS*)
*                            =  *CIO* ERROR.
*                THE SPECIFIED CATALOGS ARE RETURNED.  THE INTERLOCK
*                BIT IS SET IN THE CORRESPONDING *OCT* ENTRIES, AND THE 
*                GLOBAL INTERLOCK FLAG IS SET.
# 
  
      ITEM FAMNM      C(7);          # FAMILY NAME #
      ITEM MASK       U;             # DEVICE MASK #
      ITEM QRADDR     U;             # *HLRQ* ENTRY ADDRESS # 
      ITEM ERRSTAT    I;             # ERROR STATUS # 
  
# 
****  PROC CRELSLK - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC BFLUSH;                 # BUFFER FLUSH # 
        PROC RETERN;                 # RETURN FILE TO SYSTEM #
        PROC RTIME;                  # GET REAL TIME CLOCK READING #
        PROC ZSETFET;                # INITIALIZES A FET #
        END 
  
# 
****  PROC CRELSLK - XREF LIST END. 
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBCMD 
*CALL COMBCMS 
*CALL COMXCTF 
*CALL COMXIPR 
  
      ITEM I          I;             # LOOP COUNTER # 
CONTROL EJECT;
  
      ERRSTAT = CMASTAT"NOERR"; 
      BFLUSH(QRADDR,ERRSTAT);        # FLUSH CATALOG *FCT* I/O BUFFER # 
      IF ERRSTAT NQ CMASTAT"NOERR"
      THEN
        BEGIN 
        RETURN; 
        END 
  
      FASTFOR I = 1 STEP 1 UNTIL OCTLEN 
      DO
        BEGIN 
        IF OCT$FAM[I] EQ FAMNM AND NOT OCT$INTLK[I]  ## 
          AND B<(59-OCT$SUBF[I]),1>MASK EQ 1
        THEN                         # IF INTERLOCK TO BE GIVEN UP #
          BEGIN 
          GLBINTLK = TRUE;           # SET GLOBAL INTERLOCK FLAG #
          OCT$INTLK[I] = TRUE;
          RTIME(RTIMESTAT[0]);
          ITLK$EXPIR = RTIMSECS[0] + INLK$INTV; 
          ZSETFET(TFETADR,OCT$LFN[I],TBUFADR,TBUFL,RFETL);
          RETERN(TFET[0],RCL);
          END 
  
        END 
  
      RETURN; 
      END  # CRELSLK #
  
    TERM
PROC CRELSMM((FAMNM),(MASK),(QRADDR),ERRSTAT);
# TITLE CRELSMM - RELEASE CATALOG IN MODIFY MODE.                     # 
      BEGIN  # CRELSMM #
  
# 
**    CRELSMM - RELEASE CATALOG IN MODIFY MODE. 
* 
*     *CRELSMM* ATTACHES THE SPECIFIED CATALOGS IN UPDATE MODE
*     (RELINQUISHING MODIFY MODE) IF THEY ARE INTERLOCKED BY
*     *SSEXEC* AND SETS THE UPDATE MODE INTERLOCK FLAG IN THE 
*     OPEN CATALOG TABLE.  *PFDUMP* WILL ATTACH THE CATALOGS IN 
*     READ/ALLOW UPDATE MODE, PREVENTING *SSEXEC* FROM
*     RECLAIMING THE CATALOGS IN MODIFY MODE UNTIL IT RETURNS 
*     THEM.  DESTAGING FILES AND ADDING, EXTENDING OR REMOVING
*     SUBCATALOGS ARE NOT ALLOWED WHILE THIS INTERLOCK IS SET.
* 
*     PROC CRELSMM((FAMNM),(MASK),(QRADDR),ERRSTAT) 
* 
*     ENTRY      (FAMNM)  - FAMILY NAME, LEFT JUSTIFIED, ZERO FILLED, 
*                           7 CHARACTER MAXIMUM.
*                (MASK)   - THE 8-BIT DEVICE MASK FOR A DEVICE. 
*                (QRADDR) - *HLRQ* ENTRY ADDRESS, ELSE ZERO.
* 
*     EXIT       (ERRSTAT) - ERROR STATUS.
*                            (VALUES DEFINED IN *COMACMS*)
*                            =  NO ERRORS.
*                            =  I/O ERROR.
*                            =  CATALOG ATTACH ERROR. 
*                IF THE DESIRED FAMILY IS NOT FOUND ON A *SETPFP*, AN 
*                ERROR MESSAGE IS ISSUED AND THE PROGRAM IS ABORTED.
* 
*                THE SPECIFIED CATALOGS ARE ATTACHED IN UPDATE MODE.
*                THE INTERLOCK FLAG IS SET IN THE CORRESPONDING *OCT* 
*                ENTRIES AND THE GLOBAL INTERLOCK FLAG IS SET, IF THE 
*                INTERLOCK WAS RELEASED.
* 
*     MESSAGES   * PROGRAM ABNORMAL, CRELSMM.*
*                * UNABLE TO REATTACH SMF CATALOG.
*                  SMFCATN FOR FAMILY FFFFFFF CLOSED.*
# 
  
      ITEM FAMNM      C(7);          # FAMILY NAME #
      ITEM MASK       U;             # DEVICE MASK #
      ITEM QRADDR     U;             # *HLRQ* ENTRY ADDRESS # 
      ITEM ERRSTAT    I;             # ERROR STATUS # 
  
# 
****  PROC CRELSMM - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC ABORT;                  # ABORT #
        PROC BFLUSH;                 # BUFFER FLUSH # 
        PROC BZFILL;                 # BLANK OR ZERO FILL WORD #
        PROC MESSAGE;                # ISSUE MESSAGE #
        PROC PFD;                    # PERMANENT FILE REQUEST DELAYS #
        PROC RMVBLNK;                # REMOVE MULTIPLE BLANKS # 
        PROC RTIME;                  # GET REAL TIME CLOCK READING #
        PROC SETPFP;                 # SET PERMANENT FILE PARAMETERS #
        FUNC XCDD C(10);             # INTEGER TO DISPLAY CODE
                                       CONVERSION # 
        PROC ZFILL;                  # ZERO FILL A BUFFER # 
        END 
  
# 
****  PROC CRELSMM - XREF LIST END. 
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBBZF 
*CALL COMBCMD 
*CALL COMBCMS 
*CALL COMBPFP 
*CALL COMBPFS 
*CALL COMXCTF 
*CALL COMXIPR 
  
      ITEM CATPFN     C(7);          # MSF CATALOG PFN #
      ITEM DIS$SUBF   C(10);         # SUBFAMILY (DISPLAY CODE) # 
      ITEM FAMILY     C(7);          # FAMILY NAME #
      ITEM I          I;             # LOOP COUNTER # 
                                               CONTROL EJECT; 
  
      ERRSTAT = CMASTAT"NOERR"; 
      BFLUSH(QRADDR,ERRSTAT);        # FLUSH CATALOG *FCT* I/O BUFFER # 
      IF ERRSTAT NQ CMASTAT"NOERR"
      THEN
        BEGIN 
        RETURN; 
        END 
  
      FASTFOR I = 1 STEP 1 UNTIL OCTLEN 
      DO
        BEGIN  # SEARCH *OCT* # 
        IF OCT$FAM[I] EQ FAMNM       ## 
          AND NOT OCT$INTLK[I]       ## 
          # AND NOT OCT$UMI[I] #
          AND B<(59-OCT$SUBF[I]),1>MASK EQ 1
        THEN
          BEGIN  # INTERLOCK TO BE GIVEN UP # 
          PFP$FAM[0] = OCT$FAM[I];   # SET FAMILY AND USER INDEX #
          PFP$UI[0] = DEF$UI + OCT$SUBF[I]; 
          PFP$FG1[0] = TRUE;
          PFP$FG4[0] = TRUE;
          SETPFP(PFP);
          IF PFP$STAT NQ 0
          THEN                       # IF FAMILY NOT FOUND #
            BEGIN 
            CMA$RTN[0] = "CRELSMM.";
            MESSAGE(CMAMSG,UDFL1);   # ISSUE ERROR MESSAGE #
            ABORT;
            END 
  
          CATPFN = SFMCAT;           # REATTACH IN UPDATE MODE #
          DIS$SUBF = XCDD(OCT$SUBF[I]); 
          C<6,1>CATPFN = C<9,1>DIS$SUBF;
          PFD("ATTACH",OCT$LFN[I],CATPFN,"M","U", 
            "RC",PFSTAT,"NA",0,"UP",0,0); 
          IF PFSTAT NQ 0
          THEN                       # ATTACH ERROR # 
            BEGIN 
            CMSGLINE[0] = CMSG3;
            MESSAGE(CMSGAREA,UDFL1);
            CMSGLINE[0] = CMSGCLOSE;
            CMSGCSUBF[0] = C<9,1>DIS$SUBF;
            FAMILY = OCT$FAM[I];
            BZFILL(FAMILY,TYPFILL"BFILL",7);
            CMSGCFAM[0] = FAMILY; 
            RMVBLNK(CMSGAREA,48); 
            MESSAGE(CMSGAREA,UDFL1);
            ZFILL(OCT[I],OCTENTL);   # CLEAR *OCT* ENTRY #
            TEST I; 
            END 
  
          GLBINTLK = TRUE;           # SET GLOBAL INTERLOCK FLAG #
          # OCT$UMI[I] = TRUE # 
          RTIME(RTIMESTAT[0]);
          ITLK$EXPIR = RTIMSECS[0] + INLK$INTV; 
          END  # INTERLOCK TO BE GIVEN UP # 
  
        END  # SEARCH *OCT* # 
  
      RETURN; 
      END  # CRELSMM #
  
    TERM
PROC CRMVSC((FAMNM),(SUBF),(SMID ),(QRADDR),ERRSTAT); 
# TITLE CRMVSC - REMOVE SUBCATALOG.                                   # 
      BEGIN  # CRMVSC # 
  
# 
**    CRMVSC - REMOVE SUBCATALOG. 
* 
*     *CRMVSC* REMOVES THE SPECIFIED SUBCATALOG FROM THE CATALOG FILE.
*     THE CATALOG MUST BE OPEN IN MODIFY MODE.
* 
*     CRMVSC - IS CALLED BY RMVCSU. 
* 
*     PROC CRMVSC((FAMNM),(SUBF),(SMID ),(QRADDR),ERRSTAT)
* 
*     ENTRY      (FAMNM)  - FAMILY NAME, LEFT JUSTIFIED, ZERO FILLED, 
*                           7 CHARACTER MAXIMUM.
*                (SUBF)   - SUBFAMILY DESIGNATOR. 
*                (SMID )  - NUMERIC SM  IDENTIFIER. 
*                (QRADDR) - *HLRQ* ENTRY ADDRESS, ELSE ZERO.
* 
*     EXIT       THE SUBCATALOG HAS BEEN REMOVED AND THE CATALOG
*                PREAMBLE HAS BEEN UPDATED TO REFLECT THE CHANGE. 
*                (ERRSTAT) - ERROR STATUS.
*                            (VALUES DEFINED IN *COMBCMS*)
*                            =  NO ERRORS.
*                            =  CATALOG FILE INTERLOCKED. 
*                            =  CATALOG NOT OPEN. 
*                            =  CATALOG NOT OPEN IN MODIFY MODE.
*                            =  NO SUCH SUBCATALOG. 
*                            =  *CIO* ERROR.
*                            =  FILE DEFINE ERROR.
*                            =  FILE ATTACH ERROR.
*                            =  FILE PURGE ERROR. 
*                            =  FILE RENAME ERROR.
*                IF THE DESIRED FAMILY IS NOT FOUND ON A *SETPFP*, AN 
*                ERROR MESSAGE IS ISSUED AND THE PROGRAM IS ABORTED.
* 
*     NOTES      THE CATALOG IS RE-ATTACHED IN WRITE MODE BEFORE
*                REMOVING THE SUBCATALOG IN ORDER TO ALTER THE FILE 
*                LENGTH, AND WHEN FINISHED, THE FILE IS ATTACHED IN 
*                MODIFY MODE AGAIN. 
* 
*     MESSAGES   * PROGRAM ABNORMAL, CRMVSC.*.
# 
  
      ITEM FAMNM      C(7);          # FAMILY NAME #
      ITEM SUBF       U;             # SUBFAMILY DESIGNATOR # 
      ITEM SMID       U;             # SM  IDENTIFIER # 
      ITEM QRADDR     U;             # *HLRQ* ENTRY ADDRESS # 
      ITEM ERRSTAT    I;             # ERROR STATUS # 
  
# 
**** PROC CRMVSC - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC ABORT;                  # ABORT #
        PROC BFLUSH;                 # FLUSH *FCT* I/O BUFFER # 
        PROC CDEFTF;                 # DEFINE TEMPORARY CATALOG # 
        PROC CPIOERR;                # PROCESS MSF CATALOG I/O ERROR #
        PROC MESSAGE;                # ISSUE MESSAGE #
        PROC OCTSRCH;                # SEARCH OPEN CATALOG TABLE #
        PROC READ;                   # READ FILE TO *CIO* BUFFER #
        PROC READW;                  # READ DATA TO WORKING BUFFER #
        PROC REPLCAT;                # REPLACE MSF CATALOG #
        PROC REWIND;                 # REWIND A FILE #
        PROC SETPFP;                 # SET PERMANENT FILE PARAMETERS #
        PROC WRITEF;                 # WRITE END OF FILE #
        PROC WRITEW;                 # WRITE DATA FROM WORKING BUFFER # 
        PROC ZSETFET;                # INITIALIZES A FET #
        END 
  
# 
****  PROC CRMVSC - XREF LIST END.
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBCMD 
*CALL COMBCMS 
*CALL COMBFET 
*CALL COMBMCT 
*CALL COMBPFP 
*CALL COMXMSC 
  
      ITEM I          I;             # LOOP COUNTER # 
      ITEM J          I;             # LOOP COUNTER # 
      ITEM NAST       I;             # NUMBER OF PRU-S IN *AST* # 
      ITEM NFCT       I;             # NUMBER OF PRU-S IN *FCT* # 
      ITEM NPRU       I;             # NUMBER OF PRU-S TO REMOVE #
      ITEM ORD        I;             # ORDINAL OF *OCT* ENTRY # 
      ITEM RMV        I;             # SUBCATALOG LOCATION #
      ITEM STAT       I;             # STATUS # 
CONTROL EJECT;
  
      OCTSRCH(FAMNM,SUBF,ORD,QRADDR,ERRSTAT);  # GET *OCT* ORDINAL #
      IF ERRSTAT NQ CMASTAT"NOERR"
      THEN
        BEGIN 
        RETURN;                      # RETURN ERROR STATUS #
        END 
  
      IF OCT$ATTM[ORD] NQ "M" 
      THEN                           # IF NOT OPEN IN MODIFY MODE # 
        BEGIN 
        ERRSTAT = CMASTAT"MODERR";
        RETURN;                      # RETURN ERROR STATUS #
        END 
  
      P<PREAMBLE> = OCT$PRMA[ORD];
      IF PRM$SCW1[SMID ] EQ 0 
      THEN                           # IF NO SUCH SUBCATALOG #
        BEGIN 
        ERRSTAT = CMASTAT"NOSUBCAT";
        RETURN;                      # RETURN ERROR STATUS #
        END 
  
      BFLUSH(QRADDR,ERRSTAT);        # FLUSH CATALOG *FCT* I/O BUFFER # 
      FB$CWRD[0] = 0; 
      IF ERRSTAT NQ CMASTAT"NOERR"
      THEN
        BEGIN 
        RETURN; 
        END 
  
# 
*     SET FAMILY AND USER INDEX.
# 
  
      PFP$WRD0[0] = 0;
      PFP$FAM[0] = OCT$FAM[ORD];
      PFP$UI[0] = DEF$UI + OCT$SUBF[ORD]; 
      PFP$FG1[0] = TRUE;
      PFP$FG4[0] = TRUE;
      SETPFP(PFP);
      IF PFP$STAT[0] NQ 0 
      THEN                           # IF FAMILY NOT FOUND #
        BEGIN 
        CMA$RTN[0] = "CRMVSC."; 
        MESSAGE(CMAMSG,UDFL1);       # ISSUE ERROR MESSAGE #
        ABORT;
        END 
  
      ZSETFET(TFETADR,OCT$LFN[ORD],FCTBADR,SEQBL,RFETL);
      FET$EP[0] = TRUE; 
      ZSETFET(TFETADR+RFETL,TSFMCAT,TBUFADR,TBUFL,RFETL); 
      FET$EP[0] = TRUE; 
      REWIND(TFET[0],NRCL); 
      CDEFTF(TFET[1],ERRSTAT);       # DEFINE TEMPORARY CATALOG FILE #
      IF ERRSTAT NQ CMASTAT"NOERR"
      THEN
        BEGIN 
        RETURN;                      # RETURN ERROR STATUS #
        END 
  
# 
*     DETERMINE SUBCATALOG LENGTH.
# 
  
      NFCT = PRM$ENTRC[SMID] * 16;
      NAST = (MAXORD/PRULEN) * 2 + 1; 
      NPRU = NFCT + NAST;            # SUBCATALOG LENGTH IN PRU-S # 
  
# 
*     UPDATE CATALOG PREAMBLE.
# 
  
      RMV = PRM$ASTLOC[SMID];        # SAVE SUBCATALOG LOCATION # 
      PRM$SCW1[SMID ] = 0;           # CLEAR ENTRY IN PREAMBLE #
      FASTFOR I = 1 STEP 1 UNTIL MAXSM
      DO
        BEGIN 
        IF PRM$FCTLOC[I] GR RMV 
        THEN                         # IF SUBCATALOG LOCATION CHANGED # 
          BEGIN 
          PRM$FCTLOC[I] = PRM$FCTLOC[I] - NPRU; 
          PRM$ASTLOC[I] = PRM$ASTLOC[I] - NPRU; 
          END 
  
        END 
  
# 
*     TRANSFER CATALOG FILE TO TEMPORARY FILE, REMOVING SUBCATALOG. 
# 
  
      READ(TFET[0],RCL);
      READW(TFET[0],WBUF,WBUFL,STAT); 
      IF STAT EQ CIOERR 
      THEN                           # IF *CIO* ERROR # 
        BEGIN 
        CPIOERR(FAMNM,SUBF,QRADDR,ERRSTAT,TFET[0]); 
        RETURN; 
        END 
  
      IF STAT NQ 0
      THEN                           # IF TRANSFER NOT COMPLETE # 
        BEGIN 
        CMA$RTN[0] = "CRMVSC."; 
        MESSAGE(CMAMSG,UDFL1);
        ABORT;
        END 
  
      FASTFOR I = 0 STEP 1 UNTIL MAXSM
      DO                             # UPDATE CATALOG PREAMBLE #
        BEGIN 
        WBUF$W[I*3+1] = PRM$SCW1[I];
        WBUF$W[I*3+2] = PRM$SCW2[I];
        WBUF$W[I*3+3] = PRM$SCW3[I];
        END 
  
      P<PREAMBLE> = LOC(WBUF[0]);    # CLEAR SECOND WORD OF ENTRY # 
      PRM$SCW1[SMID] = 0; 
      PRM$SCW2[SMID ] = 0;
      PRM$SCW3[SMID] = 0; 
      WRITEW(TFET[1],WBUF,WBUFL,STAT);
      FASTFOR I = 2 STEP 1 WHILE STAT EQ 0
      DO
        BEGIN  # TRANSFER CATALOG # 
        IF I EQ RMV                  # IF AT SUBCATALOG TO BE REMOVED # 
        THEN
          BEGIN  # SUBCATALOG TO BE REMOVED # 
          FASTFOR J = 1 STEP 1 UNTIL NPRU 
          DO
            BEGIN  # SKIP SUBCATALOG #
            READW(TFET[0],WBUF,WBUFL,STAT); 
            IF STAT EQ CIOERR 
            THEN                     # IF *CIO* ERROR # 
              BEGIN 
              CPIOERR(FAMNM,SUBF,QRADDR,ERRSTAT,TFET[0]); 
              RETURN; 
              END 
  
            IF STAT NQ 0
            THEN                     # IF *EOR*, *EOF* OR *EOI* # 
              BEGIN 
              TEST I;                # EXIT TRANSFER CATALOG LOOP # 
              END 
  
            END  # SKIP SUBCATALOG #
  
          END  # SUBCATALOG TO BE REMOVED # 
  
        READW(TFET[0],WBUF,WBUFL,STAT); 
        IF STAT EQ CIOERR 
        THEN                         # IF *CIO* ERROR # 
          BEGIN 
          CPIOERR(FAMNM,SUBF,QRADDR,ERRSTAT,TFET[0]); 
          RETURN; 
          END 
  
        IF STAT NQ 0                 # IF *EOR*, *EOF*, OR *EOI* #
        THEN
          BEGIN 
          TEST I;                    # EXIT LOOP #
          END 
  
        WRITEW(TFET[1],WBUF,WBUFL,STAT);
        IF STAT NQ 0
        THEN                         # IF *CIO* ERROR # 
          BEGIN 
          CPIOERR(FAMNM,SUBF,QRADDR,ERRSTAT,TFET[1]); 
          RETURN; 
          END 
  
        END  # TRANSFER CATALOG # 
  
      WRITEF(TFET[1],RCL);
      IF FET$AT[0] NQ 0 
      THEN
        BEGIN 
        CPIOERR(FAMNM,SUBF,QRADDR,ERRSTAT,TFET[1]); 
        RETURN; 
        END 
  
# 
*     REPLACE MSF CATALOG WITH NEW CATALOG (*TSFMCAT*). 
# 
  
      REPLCAT(ORD,ERRSTAT); 
      RETURN; 
      END  # CRMVSC # 
  
    TERM
PROC CWTAST((FAMNM),(SUBF),(SMID ),(BADDR),(QRADDR),ERRSTAT); 
# TITLE CWTAST - WRITE AVAILABLE STREAM TABLE.                        # 
      BEGIN  # CWTAST # 
  
# 
**    CWTAST - WRITE AVAILABLE STREAM TABLE.
* 
*     *CWTAST* WRITES THE ENTIRE ALLOCATION SUMMARY TABLE FROM THE
*     CALLERS BUFFER TO THE CATALOG FILE. THE FREE AU COUNT 
*     IN THE CATALOG PREAMBLE IS UPDATED.  THE CATALOG MUST BE
*     OPEN IN MODIFY MODE.
* 
*     CWTAST - IS CALLED BY ADDCAR,ADDCUBE,ADDCSU,ALLOCAT,
*             DESTAGR,OPENCAT,PURGCHN,PURGFCT,RLSUNS,RMVCAR,
*             RMVCUBE,STAGER,UPDCAT.
* 
*     PROC CWTAST((FAMNM),(SUBF),(SMID ),(BADDR),(QRADDR),ERRSTAT)
* 
*     ENTRY      (FAMNM)  - FAMILY NAME, LEFT JUSTIFIED, ZERO FILLED, 
*                           7 CHARACTER MAXIMUM.
*                (SUBF)   - SUBFAMILY DESIGNATOR. 
*                (SMID )  - NUMERIC SM  IDENTIFIER. 
*                (BADDR)  - ADDRESS OF BUFFER CONTAINING *AST*. 
*                (QRADDR) - *HLRQ* ENTRY ADDRESS, ELSE ZERO.
* 
*     EXIT       THE *AST* HAS BEEN WRITTEN FROM THE BUFFER AT THE
*                ADDRESS SPECIFIED BY (BADDR) TO THE CATALOG. 
*                (ERRSTAT) - ERROR STATUS.
*                            (VALUES DEFINED IN *COMBCMS*)
*                            =  NO ERRORS.
*                            =  CATALOG FILE INTERLOCKED. 
*                            =  CATALOG NOT OPEN. 
*                            =  CATALOG NOT OPEN IN MODIFY MODE.
*                            =  NO SUCH SUBCATALOG. 
*                            =  *CIO* ERROR.
* 
*     NOTES      THE LENGTH OF THE *AST* MUST NOT BE CHANGED
*                BY THE CALLER.  THE CALLERS BUFFER SIZE SHOULD 
*                BE THE LENGTH OF THE *AST* ROUNDED UP TO A PRU 
*                MULTIPLE OR LARGER.
# 
  
      ITEM FAMNM      C(7);          # FAMILY NAME #
      ITEM SUBF       U;             # SUBFAMILY DESIGNATOR # 
      ITEM SMID       U;             # SM  IDENTIFIER # 
      ITEM BADDR      U;             # *AST* BUFFER ADDRESS # 
      ITEM QRADDR     U;             # *HLRQ* ENTRY ADDRESS # 
      ITEM ERRSTAT    I;             # ERROR STATUS # 
  
# 
****  PROC CWTAST - XREF LIST BEGIN.
# 
  
      XREF
        BEGIN 
        PROC CPIOERR;                # PROCESS MSF CATALOG I/O ERROR #
        PROC OCTSRCH;                # SEARCH OPEN CATALOG TABLE #
        PROC REWRITE;             # REWRITE DATA FROM I/O BUFFER #
        PROC ZSETFET;                # INITIALIZES A FET #
        PROC RPHR;               # RANDOM READ #
        PROC WPHR;               # RANDOM WRITE # 
        END 
  
# 
****  PROC CWTAST - XREF LIST END.
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBCMD 
*CALL COMBCMS 
*CALL COMBFET 
*CALL COMBMCT 
*CALL COMXMSC 
*CALL COMSPFM 
  
      ITEM COUNT      I;             # FREE STREAM COUNT #
      ITEM I          I;             # LOOP COUNTER # 
      ITEM LENGTH     I;             # *AST* LENGTH # 
      ITEM ORD        I;             # ORDINAL OF *OCT* ENTRY # 
CONTROL EJECT;
  
      OCTSRCH(FAMNM,SUBF,ORD,QRADDR,ERRSTAT);  # GET *OCT* ORDINAL #
      IF ERRSTAT NQ CMASTAT"NOERR"
      THEN
        BEGIN 
        RETURN;                      # RETURN ERROR STATUS #
        END 
  
      IF OCT$ATTM[ORD] NQ "M" 
      THEN                           # IF NOT OPEN IN MODIFY MODE # 
        BEGIN 
        ERRSTAT = CMASTAT"MODERR";
        RETURN;                      # RETURN ERROR STATUS #
        END 
  
      P<PREAMBLE> = OCT$PRMA[ORD];
      IF PRM$SCW1[SMID ] EQ 0 
      THEN                           # IF NO SUCH SUBCATALOG #
        BEGIN 
        ERRSTAT = CMASTAT"NOSUBCAT";
        RETURN; 
        END 
  
  
      COUNT = 0;
      P<AST> = BADDR; 
  
  
# 
*     WRITE ENTIRE *AST* FROM CALLERS BUFFER TO CATALOG FILE. 
# 
  
      LENGTH = ABUFLEN; 
      ZSETFET(TFETADR,OCT$LFN[ORD],BADDR,LENGTH,RFETL); 
      FET$EP[0] = TRUE; 
      FET$IN[0] = FET$FRST[0] + LENGTH - 1; 
      FET$R[0] = TRUE;
      FET$RR[0] = PRM$ASTLOC[SMID ];
      REWRITE(FETSET[0],RCL); 
      IF FET$AT[0] NQ 0 
      THEN
        BEGIN 
        CPIOERR(FAMNM,SUBF,QRADDR,ERRSTAT,FETSET[0]); 
        RETURN; 
        END 
  
  
# 
*     WRITE UPDATED PREAMBLE TO CATALOG FILE. 
# 
  
      ZSETFET(TFETADR,OCT$LFN[ORD],TBUFADR,2*PRULEN,RFETL); 
      FET$EP[0] = TRUE; 
      FET$R[0] = TRUE;
      FET$RR[0] = 1;
      RPHR(FETSET[0],RCL);
      IF FET$AT[0] NQ 0 
      THEN                         # READ ERROR # 
        BEGIN 
        ERRSTAT = CMASTAT"CIOERR";
        FET$AT[0] = 0;
        END 
  
      P<PREAMBLE> = OCT$PRMA[ORD];
      FASTFOR I = 0 STEP 1 UNTIL MAXSM
      DO                           # TRANSFER PREAMBLE TO TBUF #
        BEGIN 
        TBUF$W[I + 1] = PRM$SCW1[I];
        TBUF$W1[I + 1] = PRM$SCW2[I]; 
        TBUF$W2[I + 1] = PRM$SCW3[I]; 
        END 
  
      FET$RR[0] = 1;
      FET$W[0] = TRUE;
      WPHR(FETSET[0],RCL);
      IF FET$AT[0] NQ 0 
      THEN
        BEGIN 
        ERRSTAT = CMASTAT"CIOERR";
        FET$AT[0] = 0;
        END 
  
      RETURN; 
      END  # CWTAST # 
  
    TERM
PROC OCTSRCH((FAM),(SUB),ORD,(QRADR),ERRSTAT);
# TITLE OCTSRCH - OPEN CATALOG TABLE SEARCH.                          # 
      BEGIN  # OCTSRCH #
  
# 
**    OCTSRCH - OPEN CATALOG TABLE SEARCH.
* 
*     *OCTSRCH* SEARCHES THE OPEN CATALOG TABLE TO GET THE ORDINAL
*     OF THE ENTRY WITH THE SPECIFIED FAMILY NAME AND SUBFAMILY 
*     DESIGNATOR. 
* 
*     OCTSRCH - IS CALLED BY CADDSC,CBUFMAN,CCLOSE,CEXTSC,CFLUSH, 
*              CGETPD,CPUTPD,CRDAST,CRMVSC,CSELSC,CWTAST,PURGCHN.*
* 
*     PROC OCTSRCH((FAM),(SUB),ORD,(QRADR),ERRSTAT) 
* 
*     ENTRY      (FAM)   - FAMILY NAME. 
*                (SUB)   - SUBFAMILY DESIGNATOR.
*                (QRADR) - ADDRESS OF *HLRQ* ENTRY, ELSE ZERO.
* 
*     EXIT       (ORD)    - THE ORDINAL OF THE DESIRED ENTRY, IF NO 
*                           ERRORS. 
*                (ERRSTAT) - ERROR STATUS.
*                            (VALUES DEFINED IN *COMBCMS*)
*                          =  NO ERRORS.
*                          =  CATALOG FILE INTERLOCKED. 
*                          =  CATALOG NOT OPEN. 
*                IF THE CATALOG IS INTERLOCKED AND (QRADR) IS NON-ZERO, 
*                THE CATALOG ACCESS REQUEST IS ADDED TO THE END OF A
*                WAITING-FOR-INTERLOCK CHAIN. 
* 
*     NOTES      CATALOG ACCESS REQUESTS FROM *MSSEXEC* PASS THE
*                ADDRESS OF THE *HLRQ* ENTRY ASSOCIATED WITH THE
*                REQUEST, SO THAT THE REQUEST CAN BE QUEUED IF THE
*                CATALOG IS INTERLOCKED.  REQUESTS FROM MSS UTILITIES 
*                SET (QRADR) EQUAL TO ZERO AND MUST BE RETRIED IF THE 
*                CATALOG IS INTERLOCKED.
# 
  
      ITEM FAM        C(7);          # FAMILY NAME #
      ITEM SUB        U;             # SUBFAMILY DESIGNATOR # 
      ITEM ORD        I;             # ORDINAL OF *OCT* ENTRY # 
      ITEM QRADR      U;             # *HLRQ* ENTRY ADDRESS # 
      ITEM ERRSTAT    I;             # ERROR STATUS # 
  
# 
****  PROC OCTSRCH - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC ADD$LNK;                # ADD ENTRY TO END OF CHAIN #
        END 
  
# 
****  PROC OCTSRCH - XREF LIST END. 
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBCMD 
*CALL COMBCMS 
*CALL COMXHLR 
  
      ITEM I          I;             # LOOP COUNTER # 
CONTROL EJECT;
  
# 
*     SEARCH THE *OCT* FOR THE REQUESTED ENTRY. 
# 
  
      ERRSTAT = CMASTAT"NOERR"; 
      ORD = 0;
      FASTFOR I = 1 STEP 1 WHILE ORD EQ 0 AND I LQ OCTLEN 
      DO
        BEGIN  # SEARCH FOR ENTRY # 
        IF OCT$SUBF[I] EQ SUB        ## 
          AND OCT$FAM[I] EQ FAM 
        THEN
          BEGIN  # REQUESTED ENTRY FOUND #
          ORD = I;
          IF OCT$INTLK[I] 
          THEN                       # IF CATALOG INTERLOCKED # 
            BEGIN 
            ERRSTAT = CMASTAT"INTLK"; 
            IF QRADR NQ 0 
            THEN
              BEGIN  # ADD REQUEST TO WAITING-FOR-INTERLOCK CHAIN # 
              IF OCT$LINK[I] EQ 0 
              THEN                   # IF EMPTY CHAIN # 
                BEGIN 
                OCT$LINK[I] = QRADR;
                END 
  
              ELSE
                BEGIN 
                P<HLRQ> = OCT$LINK[I];
                REPEAT WHILE HLR$LNK1[0] NQ 0 
                DO                   # SEARCH FOR END OF CHAIN #
                  BEGIN 
                  P<HLRQ> = HLR$LNK1[0];
                  END 
  
                HLR$LNK1[0] = QRADR;
                END 
  
              END  # ADD REQUEST TO WAITING-FOR-INTERLOCK CHAIN # 
  
            END 
  
          END  # REQUESTED ENTRY FOUND #
  
        END  # SEARCH FOR ENTRY # 
  
      IF ORD EQ 0 
      THEN                           # IF CATALOG NOT OPEN #
        BEGIN 
        ERRSTAT = CMASTAT"NOTOPEN"; 
        END 
  
      RETURN; 
      END  # OCTSRCH #
  
    TERM
PROC REPLCAT((ORD),ERRSTAT);
# TITLE REPLCAT - REPLACES THE MSF CATALOG.                           # 
  
      BEGIN  # REPLCAT #
  
# 
**    REPLCAT - REPLACES THE MSF CATALOG. 
* 
*     *REPLCAT* REPLACES THE MSF CATALOG WITH THE TEMPORARY CATALOG 
*     (*TSFMCAT*) CREATED BY *CADDSC*, *CEXTSC* OR *CRMVSC*.  THE 
*     OLD CATALOG IS PURGED.  THE TEMPORARY CATALOG IS REATTACHED 
*     IN MODIFY MODE AND THE TEMPORARY CATALOG FILE NAME IS CHANGED 
*     TO THE ACTUAL CATALOG FILE NAME.
* 
*     REPLCAT - IS CALLED BY CADDSC,CEXTSC,CRMVSC.
* 
* 
*     PROC REPLCAT((ORD),ERRSTAT) 
* 
*     ENTRY      (ORD) = ORDINAL OF *OCT* ENTRY FOR CATALOG.
*                TFETADR = ADDRESS OF FET FOR MSF CATALOG.
*                TFETADR+RFETL = ADDRESS OF FET FOR TEMPORARY CATALOG.
* 
*                THE MSF CATALOG IS ATTACHED IN MODIFY MODE AND 
*                THE NEWLY CREATED CATALOG, *TSFMCAT*, IS ATTACHED
*                IN WRITE MODE. 
* 
*     EXIT       (ERRSTAT) - ERROR STATUS.
*                            (VALUES DEFINED IN *COMBCMS*)
*                            = NO ERRORS. 
*                            = TEMPORARY FILE ATTACH ERROR. 
*                            = TEMPORARY FILE PURGE ERROR.
*                            = TEMPORARY FILE RENAME ERROR. 
*                THE MSF CATALOG IS REPLACED WITH *TSFMCAT*.
* 
*     MESSAGES   * MSF CATALOG REPLACE ERROR. 
*                  SFMCATN FOR FAMILY FFFFFFF CLOSED.*
* 
*                * DEVICE UNAVAILABLE ON MSF CATALOG ACCESS.
*                  SFMCATN FOR FAMILY FFFFFFF CLOSED.*
* 
*     NOTES      IF AN ERROR IDLE STATUS IS RETURNED ON A *PFM* 
*                REQUEST, *REPLCAT* WILL RESTORE THE MSF CATALOG
*                TO ITS PRIOR STATE (BEFORE CURRENT UPDATE).  IF
*                SOME OTHER ERROR IS RETURNED, ANALYST INTERVENTION 
*                MAY BE REQUIRED TO RESTORE THE CATALOG.  IN EITHER 
*                CASE THE CATALOG WILL BE CLOSED. 
# 
  
      ITEM ORD        I;             # ORDINAL OF *OCT* ENTRY # 
      ITEM ERRSTAT    I;             # ERROR STATUS # 
  
# 
****  PROC REPLCAT - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC BZFILL;                 # BLANK OR ZERO FILL WORD #
        PROC MESSAGE;                # ISSUE MESSAGE #
        PROC PFD;                    # PERMANENT FILE REQUEST DELAYS #
        PROC READ;                   # READ FILE TO *CIO* BUFFER #
        PROC RENAME;                 # RENAME LOCAL FILE #
        PROC RETERN;                 # RETURN A FILE #
        PROC REWIND;                 # REWIND A FILE #
        PROC RMVBLNK;                # REMOVE MULTIPLE BLANKS # 
        PROC WRITE;                  # WRITE DATA FROM *CIO* BUFFER # 
        PROC WRITEF;                 # WRITE END OF FILE #
        FUNC XCDD C(10);             # CONVERT DECIMAL TO DISPLAY # 
        PROC ZFILL;                  # ZERO FILL BUFFER # 
        END 
  
# 
****  PROC REPLCAT - XREF LIST END. 
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBBZF 
*CALL COMBCMD 
*CALL COMBCMS 
*CALL COMBFET 
*CALL COMBPFS 
*CALL COMXMSC 
*CALL COMSPFM 
  
      ITEM CATPFN     C(7);          # MSF CATALOG PFN #
      ITEM DEV$NA     B;             # DEVICE NOT AVAILABLE FLAG #
      ITEM DIS$SUBF   C(10);         # SUBFAMILY (DISPLAY CODE) # 
      ITEM FAMILY     C(7);          # FAMILY NAME #
                                               CONTROL EJECT; 
  
      P<FETSET> = TFETADR;
      DEV$NA = FALSE; 
  
# 
*     PURGE OLD CATALOG FILE. 
# 
  
      CATPFN = SFMCAT;               # BUILD CATALOG PFN #
      DIS$SUBF = XCDD(OCT$SUBF[ORD]); 
      C<6,1>CATPFN = C<9,1>DIS$SUBF;
      PFD("PURGE",CATPFN,"RC",PFSTAT,"UP",0,0); 
      IF PFSTAT NQ 0
      THEN
        BEGIN 
        DEV$NA = PFSTAT EQ PFN; 
        ERRSTAT = CMASTAT"TPRGERR"; 
        PFD("PURGE",TSFMCAT,"RC",PFSTAT,"UP",0,"SR","IE",0);
        GOTO RETNCAT; 
        END 
  
# 
*     REATTACH CATALOG IN MODIFY MODE.
# 
  
      PFD("ATTACH",TSFMCAT,0,"M","M","RC",PFSTAT,"NA",0,"UP",0,0);
      IF PFSTAT NQ 0
      THEN
        BEGIN  # ATTACH ERROR # 
        ERRSTAT = CMASTAT"TATTERR"; 
        IF PFSTAT EQ PFN
        THEN
          BEGIN 
          GOTO RESTCAT; 
          END 
  
        ELSE
          BEGIN 
          GOTO RETNCAT; 
          END 
  
        END  # ATTACH ERROR # 
  
# 
*     CHANGE TEMPORARY FILE NAME TO ACTUAL CATALOG NAME.
# 
  
      PFD("CHANGE",CATPFN,TSFMCAT,"RC",PFSTAT,"UP",0,0);
      IF PFSTAT NQ 0
      THEN
        BEGIN  # CHANGE ERROR # 
        ERRSTAT = CMASTAT"TRNMERR"; 
        IF PFSTAT EQ PFN
        THEN
          BEGIN 
          GOTO RESTCAT; 
          END 
  
        ELSE
          BEGIN 
          GOTO RETNCAT; 
          END 
  
        END  # CHANGE ERROR # 
  
      RETERN(FETSET[0],RCL);
      RENAME(FETSET[1],OCT$LFN[ORD]); 
      RETURN; 
  
RESTCAT:                             # RESTORE ORIGINAL CATALOG # 
      PFD("ATTACH",TSFMCAT,0,"M","W","RC",PFSTAT,"NA",0,  ##
        "UP",0,"SR","IE",0);
      FET$IN[0] = FET$FRST[0];       # RESET FET POINTERS # 
      FET$OUT[0] = FET$FRST[0]; 
      FET$IN[1] = FET$FRST[1];
      FET$OUT[1] = FET$FRST[1]; 
      REWIND(FETSET[0],NRCL); 
      REPEAT WHILE NOT FET$EOI[0] 
      DO
        BEGIN 
        READ(FETSET[0],RCL);
        FET$IN[1] = FET$IN[0];
        WRITE(FETSET[1],RCL); 
        FET$OUT[0] = FET$OUT[1];
        END 
  
      WRITEF(FETSET[1],RCL);
      PFD("CHANGE",CATPFN,TSFMCAT,"RC",PFSTAT,"UP",0,"SR","IE",0);
      DEV$NA = TRUE;
  
RETNCAT:                             # RETURN LOCAL CATALOGS #
      RETERN(FETSET[0],RCL);
      RETERN(FETSET[1],RCL);
  
      IF DEV$NA                      # ISSUE ERROR MESSAGE #
      THEN
        BEGIN 
        CMSGLINE[0] = CMSG1;
        END 
  
      ELSE
        BEGIN 
        CMSGLINE[0] = CMSG2;
        END 
  
      MESSAGE(CMSGAREA,UDFL1);       # ISSUE ERROR MESSAGE #
      CMSGLINE[0] = CMSGCLOSE;
      FAMILY = OCT$FAM[ORD];
      BZFILL(FAMILY,TYPFILL"BFILL",7);
      CMSGCFAM[0] = FAMILY; 
      CMSGCSUBF[0] = C<9,1>DIS$SUBF;
      RMVBLNK(CMSGAREA,48); 
      MESSAGE(CMSGAREA,UDFL1);
  
      ZFILL(OCT[ORD],OCTENTL);
      RETURN; 
  
      END  # REPLCAT #
  
    TERM
