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