Retro1.org codex

PRGM SSLABEL;
# TITLE SSLABEL - INITIALIZES *SSLABEL*.                              #
 
      BEGIN  # SSLABEL #
 
#
***   SSLABEL -  INITIALIZES *SSLABEL*.
*
*     THIS PROCEDURE INITIALIZES *SSLABEL* BY
*     CRACKING THE CONTROL CARD AND SETTING
*     UP POINTERS AND DEFAULT VALUES.
*
*     SSLABEL,I,L.
*
*     PRGM SSLABEL.
*
*     ENTRY.     INPUTS TO SSLABEL ARE-
*                I           SOURCE OF DIRECTIVES IS ON FILE
*                            *INPUT*.
*                I = LFN     SOURCE OF DIRECTIVES IS ON FILE
*                            *LFN*.
*                I OMITTED   SAME AS *I*.
*                            *INPUT*.
*                L           LISTABLE OUTPUT ON FILE *OUTPUT*.
*                L = LFN     LISTABLE OUTPUT ON FILE *LFN*.
*                L = 0       NO OUTPUT FILE GENERATED.
*                L OMITTED   SAME AS *L*.
*
*                Z           SOURCE OF DIRECTIVES IS ON THE
*                            CONTROL CARD.
*
*                *SSLABEL* DIRECTIVE OPTIONS ARE-
*                OP          NOT PERMITTED.
*                OP = XX     WHERE XX IS THE DIRECTIVE TO BE PROCESSED.
*                            XX MAY BE ANY ONE OF THE FOLLOWING.
*                            *AM*--ADD A CARTRIDGE (*ADDMSC*).
*                            *RM*--REMOVE A CARTRIDGE (*RMVMSC*).
*                            *RS*--RESTORE A CARTRIDGE (*RSTRMSC*).
*                            *FX*--REPAIR A LABEL (*FIXVSN*).
*                            *IB*--SET OR CLEAR *FCT INHIBIT FLAG*
*                                  (*FLAGMSC*).
*                            *FC*--SET OR CLEAR *FREE CARTRIDGE FLAG*
*                                  (*FLAGFC*) IN FCT.
*                            *AS*--ADD A *SM* TO A SUBFAMILY
*                                  (*ADDCSU*).
*                            *RS*--REMOVE A SM FROM A SUBFAMILY
*                                  (*RMVCSU*).
*                            *AB*--ADD A CUBE TO A SUBFAMILY
*                                  (*ADDCUBE*).
*                            *RB*--REMOVE AN EMPTY CUBE FROM A SUBFAMILY
*                                  (*RMVCUBE*).
*                OP OMITTED  NOT PERMITTED.
*
*                N           NUMBER OF CARTRIDGES OR CUBES = 1.
*                N = X       NUMBER OF CARTRIDGES OR CUBES = X.
*                            X MAY RANGE FROM 1 TO 100.
*                N OMITTED   SAME AS *N*.
*                            *NOTE* - *N* MUST BE 1 IF THE *CSN*
*                            OPTION IS SPECIFIED.
*
*               B            SAME AS *B* = 600.
*               B = N        NUMBER OF AU'S (N) USED FOR SMALL FILES.
*                            1931 - N AU'S REMAIN FOR LARGE FILES.
*               B OMITTED    SAME AS *B*.
*
*                CM          CARTRIDGE MANUFACTURER CODE IS *A* INDICATI
*                            *IBM*.
*                CM = A      CARTRIDGE MANUFACTURER CODE IS *A* INDICATI
*                            *IBM*.
*                CM =        ANYTHING ELSE IS CURRENTLY ILLEGAL.
*                CM OMMITTED CARTRIDGE MANUFACTURER CODE IS *A*.
*
*                CN          CARTRIDGE SERIAL NUMBER OF CARTRIDGE IS
*                            NOT SPECIFIED.
*                CN = CSN   SERIAL NUMBER OF CARTRIDGE IS
*                            *CSN*.
*                C OMITTED  SAME AS *C*.
*                            *NOTE* - *CSN* MUST BE SPECIFIED WITH
*                            *RMVMSC LOST(LS)* OPTION.
*                            *CSN* MAY NOT BE SPECIFIED WHEN ANY *PK*
*                            OPTION IS USED.
*                            *NOTE* - PK IS SET TO 0
*                            WHENEVER CSN IS SPECIFIED.
*                            *N* MUST BE 1 IF THE *C* = CSN
*                            OPTION IS SPECIFIED.
*                            *CSN* MAY NOT BE SPECIFIED WITH
*                            *OP* = *ADDCSU* (AC)
*                            *OP* = *RMVCSU* (RC)
*                            *OP* = *ADDCUBE* (AB)
*                            *OP* = *RMVCUBE* (RB)
*
*
*                GR          CHOOSE DEFAULT GROUP.
*                GR = N      GROUP TO WHICH CARTRIDGE IS ADDED/REMOVED.
*                            INVALID IF *PT* = P IS SPECIFIED WITH
*                            *OP* = *AM*.  N MUST BE O TO 127.
*                GR OMITTED  SAME AS *GR*.
*
*                PK          SAME AS *PK* = P.
*                PK = D      CARTRIDGE IS TO BE PICKED FROM INPUT
*                            DRAWER SLOT.
*                PK = P      CARTRIDGE OR CUBE IS PICKED FROM POOL.
*                PK = F      CARTRIDGE OR CUBE IS PICKED FROM THE
*                            SPECIFIED FAMILY (SEE *FM* OPTION) AND
*                            SUBFAMILY (SEE *SB* OPTION) AND GROUP
*                            (SEE *GR* OPTION).
*                PK OMITTED  SAME AS *PK*.
*                            *NOTE* - VALID USES OF *PK*
*                                     OP=AM - PK=D OR PK=P
*                                     OP=RM - PK=P OR PK=F
*                                     OP=RB - PK=P OR PK=F OR PK=R
*                                     NONE OF THE *PK* OPTION MAY BE
*                                     USED IF *C* = CSN OPTION IS
*                                     SPECIFIED.
*                                     PK=D OR F IF PT=P.
*
*                PT          SAME AS *PT* = P.
*                PT = D      CARTRIDGE IS TO BE PLACED IN THE
*                            DRAWER.
*                PT = P      CARTRIDGE OR CUBE IS PUT IN THE POOL.
*                PT = F      CARTRIDGE OR CUBE IS PUT IN THE SPECIFIED
*                            FAMILY (SEE *FM* OPTION) AND SUBFAMILY
*                            (SEE *SB* OPTION).
*                PT = R      CUBE IS PUT INTO THE *RESERVED FOR
*                            ALTERNATE SMMAP* AREA OF THE SMMAP.
*                PT OMITTED  SAME AS *PT*.
*                            *NOTE* - VALID USES OF *PT*
*                                     OP=AM - PT=P OR PT=F
*                                     HOWEVER, WITH OP=AM AND THE CSN
*                                     SPECIFIED, *PT* CANNOT BE EQUAL
*                                     TO *P*.
*                                     OP=RM - PT=D OR PT=P
*                                     OP=AB - PT=P OR PT=F OR PT=R
*
*                LT          CARTRIDGE IS LOST AND EXISTS ONLY IN THE
*                            CATALOG.  ITS CATALOG ENTRY IS TO BE
*                            REMOVED.
*                LT OMITTED  NO ACTION.
*                            *NOTE* - *LT* IS VALID ONLY WITH OP=RM
*                            (*RMVMSC*).
*
*                SM          USE *SM* *A*.
*                SM = N      USE *SM* N WHERE N IS ONE OF THE
*                            FOLLOWING
*                            A - SM A
*                            B - SM B
*                            C - SM C
*                            D - SM D
*                            E - SM E
*                            F - SM F
*                            G - SM G
*                            H - SM H
*                SM OMITTED  SAME AS *SM*.
*
*                ON          TURN ON A FLAG.
*
*                OF          TURN OFF A FLAG.
*
*                YI          INVALID.
*                YF          INVALID.
*                ZI          INVALID.
*                ZF          INVALID.
*                YI = I      ROW I IS SELECTED FOR THE *ADDCUBE*
*                            OR *RMVCUBE* DIRECTIVE. I IS FROM 0 TO 21.
*                ZI = J      COLUMNN J IS SELECTED FOR THE *ADDCUBE* OR
*                            *RMVCUBE* DIRECTIVE. J IS FROM 0 TO 15.
*                YI=I,ZI=J   LOCATION (I,J) IS SELECTED FOR THE
*                            *ADDCUBE* OR *RMVCUBE* DIRECTIVE.
*                YI=I,ZI=J,  A RECTANGLE OF CELLS BOUNDED BY (I,J),
*                YF=K,ZF=L   (I,L), (K,J) AND (K,L) ARE SELECTED FOR
*                            THE *ADDCUBE* OR *RMVCUBE* DIRECTIVE.
*                            *NOTE* - YF=K AND ZF=L MUST BOTH BE
*                            SPECIFIED IF EITHER IS SPECIFIED.
*                            YF=K AND ZF=L CANNOT BE SPECIFIED UNLESS
*                            BOTH YI=I AND ZI=J ARE SPECIFIED.
*                            K MUST BE GREATER THAN I AND L MUST BE
*                            GREATER THAN J.
*                            YI=I AND YF=K MUST BE LESS THAN OR EQUAL
*                            TO 21.
*                            ZI=J AND ZF=L MUST BE LESS THAN OR EQUAL
*                            TO 15.
*                            THE FOLLOWING LOCATIONS ARE RESERVED:
*                            (0,0),((Y,6),Y=0,21),(0,15),(11,15),
*                            (21,15),((Y,Z),Y=11,15,Z=0,1),(0,1),
*                            (0,14),(21,0),AND (21,14).
*                YI AND ZI   *ADDCUBE* WILL SELECT THE NEXT AVAILABLE
*                OMITTED     CUBE CLOSEST TO THE TOP OF THE *SM* FOR
*                            ASSIGNMENTS TO A FAMILY OR THE FARTHEST
*                            CUBE FOR ASSIGNMENT TO THE POOL.
*                            *RMVCUBE* WILL SELECT THE FIRST UNASSIG-
*                            NED CUBE FROM THE *AST* FOR A FAMILY.
*
*                FM          USE DEFAULT FAMILY.
*                FM = FAMILY SELECT SPECIFIED FAMILY.
*                FM OMITTED  SAME AS *FM*.
*
*                SB          SELECT SUB-FAMILY 0.
*                SB = SUB    SELECT SUB-FAMILY SUB.
*                SB OMITTED  SAME AS *SB*.
*                            *NOTE* - SUB MUST BE BETWEEN 0 AND 7.
*
*     EXIT.      *SSLABEL* DIRECTIVES PROCESSED OR
*                AN ERROR CONDITION ENCOUNTERED.
*
*     MESSAGES.  1.  SSLABEL COMPLETE.
*                2.  UNABLE TO CONNECT WITH EXEC.
*                3.  SSLABEL - MUST BE SYSTEM ORIGIN.
*
*     NOTES.     PROC *SSLABEL* INITIALIZES *SSLABEL*.
*                *SSLABEL* PROCESSING IS CONTROLLED BY
*                THE USE OF DIRECTIVES.  THE DIRECTIVES CAN
*                BE SPECIFIED ON THE CONTROL CARD, ON
*                *INPUT* FILE OR ON
*                AN ALTERNATE FILE.  PROC *SSLABEL*
*                CRACKS THE CONTROL CARD AND READS
*                IN THE DIRECTIVES FROM THE FILE
*                SPECIFIED INTO THE CIO BUFFER.  PROC
*                *LBLOOP* IS CALLED TO CRACK THE DIREC-
*                TIVES AND TO WRITE THEM ON A TEMPORARY
*                FILE.  THE CRACKED PARAMETERS ARE RETUR-
*                NED IN COMMON AREA *ULBPCOM*.  ANY ERROR
*                IN THE DIRECTIVE CAUSES *SSLABEL* TO
*                ABORT.  PROC *LBERR* DOES ERROR PROCESSING
*                FOR *SSLABEL*.  AFTER THE DIRECTIVES ARE
*                CRACKED AND SYNTAX CHECKED A *CONNECT* IS
*                SET WITH EXEC.  PROC *LBMAIN* IS CALLED
*                TO PROCESS ALL THE DIRECTIVES.  A
*                *DISCONNECT* IS DONE WITH EXEC AFTER ALL
*                THE DIRECTIVES ARE PROCESSED.
#
 
#
****  PROC SSLABEL - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC ABORT;                  # ABORT PROCESSING #
        PROC BZFILL;                 # BLANK OR ZERO-FILLS A BUFFER #
        PROC CALL1;                  # SENDS TYPE 1 CALLSS TO EXEC #
        PROC GETFAM;                 # GETS DEFAULT FAMILY #
        PROC GETPFP;                 # GET USER INDEX AND FAMILY #
        PROC GETSPS;                 # GET PRIVILIDGES #
        PROC LBERR;                  # ERROR PROCESSOR #
        PROC LBHEAD;                 # WRITES HEADER ON OUTPUT FILE #
        PROC LBLOOP;                 # CRACK AND SYNTAX CHECK
                                       DIRECTIVES #
        PROC LBMAIN;                 # PROCESSES SSLABEL DIRECTIVES #
        PROC LBTAB;                  # SETS UP THE ARGUMENT LIST #
        PROC MESSAGE;                # DISPLAYS MESSAGE IN DAYFILE #
        PROC PDATE;                  # GETS PACKED DATE AND TIME #
        PROC READ;                   # READS A FILE #
        PROC RESTPFP;                # RESTORE USER-S *PFP* AND ABORT
                                       OR RETURN #
        PROC RPCLOSE;                # CLOSES OUTPUT FILE #
        PROC RPLINE;                 # WRITES A LINE ON OUTPUT FILE #
        PROC RPOPEN;                 # OPENS OUTPUT FILE #
        PROC RPSPACE;                # WRITES A BLANK LINE #
        PROC VERSION;                # GETS OS LEVEL #
        PROC XARG;                   # CRACK PARAMETER LIST #
        PROC XZAP;                   # *Z* ARGUMENT PROCESSOR #
        PROC ZSETFET;                # SETS UP A FET #
        END
 
#
****  PROC SSLABEL - XREF LIST END.
#
 
      DEF LISTCON    #0#;            # DO NOT LIST COMDECKS #
 
                                               CONTROL PRESET;
*CALL COMBFAS
*CALL COMBBZF
*CALL COMBCMD
*CALL COMBCPR
*CALL COMBLBL
*CALL COMBPFP
*CALL COMBUCR
*CALL COMSPFM
*CALL COMTERR
*CALL COMTFMT
*CALL COMTLAB
*CALL COMTLBP
*CALL COMTOUT
 
      ITEM ARGLIST    U;             # ADDRESS OF ARGUMENT TABLE #
      ITEM BUFP       U;             # FWA OF CIO BUFFER #
      ITEM DEFAULT    I;             # DEFAULT FAMILY ORDINAL #
      ITEM ERRFLAG    B;             # ERROR FLAG #
      ITEM FAM$NUM    I;             # NUMBER OF FAMILIES #
      ITEM FETP       U;             # FWA OF FET #
      ITEM FLAG       I;             # ERROR FLAG #
      ITEM LFN        C(7);          # TEMP LOC FOR FILE NAME #
      ITEM LINK       I;             # LINK FAMILY ORDINAL #
      ITEM OPTION     I;             # OPTION OF SKIPPING OVER PROGRAM
                                       NAME IN CONTROL CARD #
      ITEM REQCODE    U;             # REQUEST CODE #
      ITEM RESP$CODE  U;             # RESPONSE CODE FROM EXEC #
 
      ARRAY CALL$SS [0:0] P(CPRLEN);;  # CALLSS REQUEST BLOCK #
      ARRAY OUT$FET [0:0] S(SFETL);;  # FET FOR OUTPUT FILE #
      BASED
      ARRAY RA [0:0] P(1);;          # ACCESS CONTROL CARD AREA #
      ARRAY SPSSTAT [0:0] S(1);
        BEGIN
        ITEM SPS$STATUS U(00,48,12);  # RETURN STATUS #
        END
 
 
                                               CONTROL EJECT;
 
#
*     USER MUST HAVE SYSTEM ORIGIN PRIVILIDGES.
#
 
      GETSPS(SPSSTAT);
      IF SPS$STATUS NQ OK
      THEN
        BEGIN
        LBMSG$LINE[0] = " SSLABEL - MUST BE SYSTEM ORIGIN.";
        MESSAGE(LBMSG$BUF[0],SYSUDF1);
        ABORT;
        END
 
 
      REQID$LB = REQNAME"RQILABL";   # SET REQUESTOR ID FOR SSLABEL #
 
#
*     SAVE THE USER-S CURRENT FAMILY AND USER INDEX IN COMMON.
#
 
      GETPFP(PFP[0]);
      USER$FAM[0] = PFP$FAM[0];
      USER$UI[0] = PFP$UI[0];
 
#
*     CRACK THE PARAMETERS ON SSLABEL CALL.
#
 
      LBTAB(ARGLIST);                # SET UP THE ARGUMENT LIST #
      OPTION = 0;                    # SKIP OVER PROGRAM NAME #
      XARG(ARGLIST,OPTION,FLAG);     # CRACK THE CONTROL STATEMENT #
      IF FLAG NQ 0
      THEN                           # SYNTAX ERROR #
        BEGIN
        ERRCODE = S"SYNTX$ABRT";     # ABORT WITH *SYNTAX ERROR* #
        OUT$FETP = 0;
        LBERR(ERRCODE);
        END
 
#
*     SET UP FET FOR READING THE DIRECTIVE FILE.
#
 
      FETP = LOC(LBIN$FET[0]);
      LB$BUFP = LOC(LBIN$BUF[0]);
      LFN = LBARG$I[0];
      ZSETFET(FETP,LFN,LB$BUFP,BUFL,SFETL);
 
#
*     DO *Z* ARGUMENT PROCESSING.
#
 
      IF LBARG$Z[0] NQ 0
      THEN                           # *Z* OPTION SPECIFIED #
        BEGIN
        XZAP(LBIN$FET[0]);           # PROCESS *Z* ARGUMENTS #
        END
 
      ELSE
        BEGIN
        READ(LBIN$FET[0],NRCL);      # READ INPUT FILE #
        END
 
#
*     SET UP FET POINTER FOR OUTPUT FILE.
#
 
      IF LBARG$L[0] EQ 0
      THEN                           # NO OUTPUT FILE #
        BEGIN
        OUT$FETP = 0;
        END
 
      ELSE                           # SET UP THE FWA OF THE FET #
        BEGIN
        OUT$FETP = LOC(OUT$FET[0]);
        END
 
#
*     OPEN OUTPUT FILE AND WRITE THE CONTROL CARD
*     IMAGE TO IT.
#
 
      RPOPEN(LBARG$L[0],OUT$FETP,LBHEAD);
      P<RA> = 0;                     # SET TO RA+0 #
      BZFILL(RA[O"70"],TYPFILL"BFILL",80);
      RPLINE(OUT$FETP,RA[O"70"],2,80,0);
      RPSPACE(OUT$FETP,SP"SPACE",1);
 
#
*     READ EACH DIRECTIVE AND CRACK AND SYNTAX CHECK IT.
#
 
      ERRFLAG = FALSE;               # INITIALIZE ERROR STATUS #
      LBLOOP(ARGLIST,ERRFLAG);
      IF ERRFLAG
      THEN                           # ERROR IN ANY DIRECTIVE #
        BEGIN
        ERRCODE = S"SYNTX$ABRT";     # ABORT WITH DAYFILE MESSAGE #
        LBERR(ERRCODE);
        END
 
      PDATE(PD$T);                   # GET PACKED DATE/TIME #
      VERSION(OSVERSION[0]);         # GET *OS* LEVEL #
 
#
*     GET DEFAULT FAMILY AND SUBSYSTEM ID.
#
 
      SSID$LB = ATAS;
      GETFAM(FAMT,FAM$NUM,LINK,DEFAULT,SSID$LB);
      DEF$FAM = FAM$NAME[DEFAULT];
 
#
*     INITIALIZE THE POINTER OF THE BASED ARRAY
*     DESCRIBING THE FORMAT OF THE CALLSS REQUEST
*     BLOCK.
#
 
      P<CPR> = LOC(CALL$SS[0]);
 
#
*     SET UP CONNECT WITH EXEC.
#
 
      REQCODE = REQTYP1"CONNECT";
      CALL1(REQCODE,RESP$CODE);
      IF RESP$CODE NQ OK
      THEN
        BEGIN
        LBMSG$LINE[0] = " UNABLE TO CONNECT WITH EXEC.";
        MESSAGE(LBMSG$BUF[0],SYSUDF1);
        RPCLOSE(OUT$FETP);           # CLOSE OUTPUT FILE #
        RESTPFP(PFP$ABORT);          # RESTORE USER-S *PFP* AND ABORT #
        END
 
#
*     PROCESS EACH DIRECTIVE.
#
 
      LBMAIN;
 
#
*     DISCONNECT WITH EXEC.
#
 
      REQCODE = REQTYP1"DISCONNECT";
      CALL1(REQCODE,RESP$CODE);
      RPCLOSE(OUT$FETP);             # CLOSE OUTPUT FILE #
 
#
*     DISPLAY *SSLABEL COMPLETE* IN THE DAYFILE.
#
 
      LBMSG$LINE[0] = " SSLABEL COMPLETE.";
      MESSAGE(LBMSG$BUF[0],SYSUDF1);
      RESTPFP(PFP$END);              # RESTORE USER-S *PFP* #
 
      END  # SSLABEL #
 
    TERM
PROC CALL1((REQ$CODE),RESP$CODE);
# TITLE CALL1 - SETS UP AND ISSUES A CALLSS TYPE 1 REQUEST.           #
 
      BEGIN  # CALL1 #
 
#
**    CALL1 - SETS UP AND ISSUES A CALLSS TYPE 1 REQUEST.
*
*     THIS PROC SETS UP THE CALLSS REQUEST BLOCK FOR A
*     UCP REQUEST TYPE 1 AND CALLS *CALLSS* TO ISSUE IT
*     TO EXEC.
*
*     PROC CALL1((REQ$CODE),RESP$CODE)
*
*     ENTRY     (REQCODE)    = REQUEST CODE.
*               (REQID$LB)   = REQUESTOR ID.
*               (SSID$LB)    = SUBSYSTEM ID.
*               P<CPR>       = FWA OF PARAMETER BLOCK.
*
*     EXIT      (RESP$CODE)  = RESPONSE FROM EXEC.
*
*     NOTES     PROC *CALL1* SETS UP THE CALLSS PARAMETER
*               BLOCK FOR A UCP TYPE 1 REQUEST.  TYPE 1
*               REQUESTS ARE THE UCP LINKAGE REQUESTS I.E
*               CONNECT AND DISCONNECT.  THE REQUEST CODE
*               IS SET UP IN THE CALLSS PARAMETER BLOCK
*               TO IDENTIFY THE TYPE OF REQUEST BEING SENT
*               TO EXEC.  THE RESPONSE CODE IS RETURNED
*               TO THE CALLING PROCEDURE.
#
 
      ITEM REQ$CODE   U;             # REQUEST CODE #
      ITEM RESP$CODE  U;             # RESPONSE CODE FROM EXEC #
 
#
****  PROC CALL1 - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC CALLSS;                 # ISSUES A CALLSS TO EXEC #
        END
 
#
****  PROC CALL1 - XREF LIST END.
#
 
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS #
*CALL COMBFAS
*CALL COMBCPR
*CALL COMTLAB
 
      ITEM I          I;             # LOOP VARIABLE #
 
                                               CONTROL EJECT;
 
#
*     ZERO FILL THE CALLSS PARAMETER REQUEST BLOCK.
#
 
      SLOWFOR I = 0 STEP 1 UNTIL CPRLEN-1
      DO
        BEGIN
        CPR1[I] = 0;
        END
 
      CPR$WC[0] = TYP1$WC;           # SET UP WORD COUNT #
      CPR$RQT[0] = TYP"TYP1";        # TYPE 1 REQUEST #
      CPR$RQC[0] = REQ$CODE;         # SET UP REQUEST CODE #
      CPR$RQI[0] = REQID$LB;         # SET UP REQUESTOR ID #
      CPR$SSPFLG[0] = TRUE;
      CALLSS(SSID$LB,CPR[0],RCL);    # ISSUE CALLSS #
      RESP$CODE = CPR$ES[0];         # RETURN THE RESPONSE CODE #
      RETURN;
 
      END  # CALL1 #
 
    TERM
PROC CALL3((REQ$CODE),PT$CSU$ENT,(CATFLD),(CATVALUE),RESP$CODE);
# TITLE CALL3 - SETS UP AND ISSUES A TYPE 3 CALLSS TO EXEC.           #
 
      BEGIN  # CALL3 #
 
#
**    CALL3 - SETS UP AND ISSUES A TYPE 3 CALLSS TO EXEC.
*
*     PROC CALL3((REQ$CODE),PT$CSU$ENT,(CATFLD),(CATVALUE),RESP$CODE)
*
*     ENTRY   (REQ$CODE)   = REQUEST CODE.
*             (PT$CSU$ENT) = 3 WORD SMMAP ENTRY WITH THE THIRD
*                            WORD CONTAINING THE Y,Z COORDINATES.
*             (CATFLD)     = CATALOG FIELD TO BE UPDATED.
*             (CATVALUE)   = NEW VALUE FOR THE CATALOG FIELD TO
*                            BE UPDATED.
*             (REQID$LB)   = REQUESTOR ID.
*             (NEWLABP)    = FWA OF BUFFER CONTAINING NEW CARTRIDGE
*                            LABEL.
*             (OLDLABP)    = FWA OF BUFFER CONTAINING OLD CARTRIDGE
*                            LABEL.
*             (SSID$LB)    = SUBSYSTEM ID.
*             (LBARG$B)    = LARGE FILE ALLOCATION SPACE.
*             (LBARG$SMID) = *SM*-ID.
*             (LBARG$FM)   = FAMILY NAME.
*             (LBARG$SB)   = SUBFAMILY ID.
*             P<CPR>       = FWA OF PARAMETER BLOCK.
*
*     EXIT    (RESP$CODE)  = RESPONSE FROM EXEC.
*
*     NOTES   PROC *CALL3* SETS UP THE CALLSS PARAMETER BLOCK
*             FOR A TYPE 3 REQUEST TO EXEC.  TYPE 3 REQUESTS
*             ARE THE REQUESTS TO MODIFY MSF CATALOGS AND MAPS.
*             THE SPECIFIC REQUEST ISSUED IS DEPENDENT ON THE
*             VALUE OF *REQCODE*.  PARAMETERS NOT NEEDED FOR
*             THE REQUEST ARE IGNORED.  IF THE RESPONSE CODE
*             RETURNED BY EXEC IS *RESUBMIT THE REQUEST*, THE
*             CALLSS IS REISSUED.  OTHERWISE THE RESPONSE CODE
*             IS RETURNED TO THE CALLING PROC.
#
 
      ITEM REQ$CODE   U;             # REQUEST CODE #
 
      ARRAY PT$CSU$ENT [0:0] P(5);   # *PUT* SMMAP ENTRY #
        BEGIN
        ITEM PT$MAPENT  C(00,00,30);  # THREE WORD MAP ENTRY #
        ITEM PT$Y       U(03,00,30);  # Y COORDINATE #
        ITEM PT$Z       U(03,30,30);  # Z COORDINATE #
        ITEM PT$GR      U(04,00,07);  # GROUP #
        ITEM PT$GRT     U(04,07,05);  # GROUP ORDINAL #
        END
 
 
      ITEM CATFLD     U;             # CATALOG FIELD #
      ITEM CATVALUE   U;             # NEW VALUE FOR CATALOG FIELD #
      ITEM RESP$CODE  U;             # RESPONSE CODE FROM EXEC #
 
#
****  PROC CALL3 - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC CALLSS;                 # ISSUES A CALLSS TO EXEC #
        END
 
#
****  PROC CALL3 - XREF LIST END.
#
 
      DEF LISTCON #0#;               # CONTROLS LISTING OF COMDECKS #
*CALL COMBFAS
*CALL COMBCPR
*CALL COMBLBL
*CALL COMBMAP
*CALL COMTLAB
*CALL COMTLBP
 
      ITEM COMPLETE   B;             # CALLSS COMPLETION STATUS #
      ITEM I          I;             # LOOP VARIABLE #
 
      SWITCH CALL3ACT: REQTYP3       # TYPE OF CALLSS ISSUED #
              ADDCBFM: ADD$CUBE,     # ADD CUBE TO FAMILY #
              ADDCRFM: ADD$CART,     # ADD CARTRIDGE TO FAMILY #
              ADDCSFM: ADD$CSU,      # ADD *SM* TO FAMILY #
              RMVCBFM: RMV$CUBE,     # REMOVE CUBE FROM FAMILY #
              RMVCRFM: RMV$CART,     # REMOVE CARTRIDGE FROM FAMILY #
              RMVCSFM: RMV$CSU,      # REMOVE *SM* FROM FAMILY #
               UPDCAT: UPD$CAT,      # UPDATE CATALOG FIELD #
               UPDMAP: UPD$MAP;      # UPDATE SMMAP FIELD #
 
                                               CONTROL EJECT;
 
#
*     ZERO FILL CALLSS REQUEST BLOCK AND SET UP FIELDS COMMON
*     TO MOST REQUESTS.
#
 
      COMPLETE = FALSE;
 
      SLOWFOR I = 0 STEP 1 UNTIL CPRLEN-1
      DO
        BEGIN
        CPR1[I] = 0;
        END
 
#
*     SET UP PARAMETER BLOCK.
#
 
      CPR$RQT[0] = TYP"TYP3";
      CPR$RQC[0] = REQ$CODE;
      CPR$RQI[0] = REQID$LB;
      CPR$FAM[0] = LBARG$FM[0];
      CPR$SUB[0] = LBARG$SB[0];
      CPR$CSU[0] = LBARG$SMID[0];
      CPR$WC[0] = TYP3$WC;
      P<SMUMAP> = LOC(PT$CSU$ENT[0]);
 
#
*     SET UP ADDITIONAL REQUEST BLOCK FIELDS FOR SPECIFIC
*     REQUEST CODES.
#
 
      GOTO CALL3ACT[REQ$CODE];
 
ADDCBFM:                             # ADD CUBE TO FAMILY #
      CPR$Y[0] = PT$Y[0];            # SET Y AND Z COORDINATES #
      CPR$Z[0] = PT$Z[0];
      GOTO ISSUECALL;
 
ADDCRFM:                             # ADD CARTRIDGE TO FAMILY #
      P<LABEL$CART> = NEWLABP;
      CPR$FCT[0] = (PT$GR[0]) * 16 + PT$GRT[0];
      CPR$Y[0] = LAB$Y[0];           # SET Y AND Z COORDINATES #
      CPR$Z[0] = LAB$Z[0];
      CPR$CSND[0] = LAB$CSND[0];     # SET VSN FIELD #
      CPR$CCOD[0] = LAB$CCOD[0];
      CPR$GR[0] = LBARG$GR[0];       # SET GROUP PARAMETERS #
      CPR$GRT[0] = PT$GRT;
                                     # CALCULATE GRTO #
      CPR$B[0] = LBARG$B[0];
      CPR$STRD[0] = LAB$STRD[0];
      CPR$STWR[0] = LAB$STWR[0];
      CPR$SRDE[0] = LAB$SRDE[0];
      CPR$SWRE[0] = LAB$SWRE1[0];
      B<28,4>CPR$SWRE = LAB$SWRE[0];
      CPR$HRDE[0] = LAB$HRDE[0];
      CPR$STDM[0] = LAB$STDM[0];
      CPR$CRLD[0] = LAB$CRLD[0];
      CPR$LDER[0] = LAB$LDER[0];
      GOTO ISSUECALL;
 
ADDCSFM:                             # ADD *SM* TO FAMILY #
      GOTO ISSUECALL;
 
RMVCBFM:                             # REMOVE CUBE FROM FAMILY #
      CPR$FCT[0] = CM$FCTORD[0];     # SET FCT ORDINAL #
      CPR$Y[0] = PT$Y[0];            # SET Y AND Z COORDINATES #
      CPR$Z[0] = PT$Z[0];
      GOTO ISSUECALL;
 
RMVCRFM:                             # REMOVE CARTRIDGE FROM FAMILY #
      CPR$FAM[0] = CM$FMLYNM[0];     # USE *FM* AND *SB* FROM SMMAP #
      CPR$SUB[0] = CM$SUB[0];
      CPR$FCT[0] = CM$FCTORD[0];     # SET FCT ORDINAL #
      CPR$GR[0] = LBARG$GR[0];       # SET GROUP #
      CPR$Y[0] = PT$Y[0];            # SET Y AND Z COORDINATES #
      CPR$Z[0] = PT$Z[0];
      GOTO ISSUECALL;
 
RMVCSFM:                             # REMOVE *SM* FROM FAMILY #
      GOTO ISSUECALL;
 
UPDCAT:                              # UPDATE CATALOG FIELD #
      CPR$FAM[0] = CM$FMLYNM[0];     # USE *FM* AND *SB* FROM SMMAP #
      CPR$SUB[0] = CM$SUB[0];
      CPR$FCT[0] = CM$FCTORD[0];     # SET FCT ORDINAL #
      CPR$FLD[0] = CATFLD;           # SET FIELD NAME #
      CPR$VAL[0] = CATVALUE;         # SET CATALOG FIELD VALUE #
      GOTO ISSUECALL;
 
UPDMAP:                              # UPDATE SMMAP ENTRY #
      CPR$Y[0] = PT$Y[0];            # SET Y AND Z COORDINATES #
      CPR$Z[0] = PT$Z[0];
      CPR$MAPENT[0] = PT$MAPENT[0];  # SET UP NEW SMMAP ENTRY #
      GOTO ISSUECALL;
 
ISSUECALL:                           # ISSUE REQUEST TO EXEC #
      REPEAT WHILE NOT COMPLETE
      DO
        BEGIN
        CALLSS(SSID$LB,CPR[0],RCL);
        IF CPR$RQR[0] NQ RESPTYP3"RESUB$REQ"
        THEN                         # REQUEST COMPLETE #
          BEGIN
          COMPLETE = TRUE;
          TEST DUMMY;
          END
 
#
*     RESUBMIT THE REQUEST.
#
 
        CPR$RQR[0] = 0;
        CPR$C[0] = FALSE;
        END
 
      RESP$CODE = CPR$RQR[0];
      RETURN;
 
      END  # CALL3 #
 
    TERM
PROC CALL4((REQ$CODE),(DRD),(CART$CSN),(OLD$Y),(OLD$Z),RESP$CODE);
# TITLE CALL4 - SETS UP AND ISSUES A TYPE 4 CALLSS TO EXEC.           #
 
      BEGIN  # CALL4 #
 
#
**    CALL4 - SETS UP AND ISSUES A TYPE4 CALLSS TO EXEC.
*
*     PROC CALL4((REQ$CODE),(OLD$Y),(OLD$Z),(NEW$Y),(NEW$Z),RESP$CODE)
*
*     ENTRY   (REQ$CODE)   = REQUEST CODE.
*             (OLD$Y)      = PRIMARY Y COORDINATE.
*             (OLD$Z)      = PRIMARY Z COORDINATE.
*             (NEW$Y)      = SECONDARY Y COORDINATE.
*             (NEW$Z)      = SECONDARY Z COORDINATE.
*             (REQID$LB)   = REQUESTOR ID.
*             (SSID$LB)    = SUBSYSTEM ID.
*             (NEWLABP)    = FWA OF BUFFER CONTAINING NEW
*                            CARTRIDGE LABEL.
*             (OLDLABP)    = FWA OF BUFFER CONTAINING OLD
*                            CARTRIDGE LABEL.
*             (ADDRSNS)    = FWA OF BUFFER TO HOLD DRAWER
*                            STATUS TABLE.
*             (DRD$NUM)   = TRANSPORT ID.
*             (LBARG$SMID) = *SM*-ID.
*             P<CPR>       = FWA OF PARAMETER BLOCK.
*
*     EXIT    (RESP$CODE)  = RESPONSE FROM EXEC.
*
*     NOTES   PROC *CALL4* SETS UP THE CALLSS PARAMETER BLOCK
*             FOR A TYPE 4 REQUEST TO EXEC.  TYPE 4 ARE THE
*             REQUESTS THAT REQUIRE SM OR M860 ACTIONS PERFOR-
*             -MED.  THE SPECIFIC REQUEST ISSUED IS DEPENDENT
*             ON THE VALUE OF *REQCODE*.  PARAMETERS NOT NEEDED
*             FOR THE REQUEST ARE IGNORED.  IF THE RESPONSE
*             RETURNED BY EXEC IS *RESUBMIT* THE REQUEST*, THE
*             CALLSS IS REISSUED.  OTHERWISE THE RESPONSE CODE
*             IS RETURNED TO THE CALLING PROC.
#
 
      ITEM CART$CSN   U;             # CARTRIDGE SERIAL NUMBER #
      ITEM DRD        U;             # DRIVE NUMBER #
 
      ITEM REQ$CODE   U;             # REQUEST CODE #
      ITEM OLD$Y      I;             # OLD Y COORDINATE #
      ITEM OLD$Z      I;             # OLD Z COORDINATE #
      ITEM NEW$Y      I;             # NEW Y COORDINATE #
      ITEM NEW$Z      I;             # NEW Z COORDINATE #
      ITEM RESP$CODE  U;             # RESPONSE CODE FROM EXEC #
 
#
****  PROC CALL4 - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC CALLSS;                 # ISSUES A CALLSS TO EXEC #
        END
 
#
****  PROC CALL4 - XREF LIST END.
#
 
      DEF LISTCON #0#;               # CONTROLS LISTING OF COMDECKS #
*CALL COMBFAS
*CALL COMBCPR
*CALL COMTLAB
*CALL COMTLBP
 
      SWITCH CALL4ACT: REQTYP4       # TYPE OF CALLSS TO BE ISSUED #
              GETCART: LOAD$CART,    # GET CARTRIDGE #
              PUTCART: UNLD$CART,    # PUT CARTRIDGE #
              WRITLAB: WRT$LAB;      # WRITE LABEL #
 
      ITEM I          I;             # LOOP VARIABLE #
 
                                               CONTROL EJECT;
 
#
*     ZERO-FILL CALLSS REQUEST BLOCK AND SET UP FIELDS USED BY
*     MOST REQUESTS.
#
 
      SLOWFOR I = 0 STEP 1 UNTIL CPRLEN-1
      DO
        BEGIN
        CPR1[I] = 0;
        END
 
      CPR$RQT[0] = TYP"TYP4";
      CPR$RQC[0] = REQ$CODE;
      CPR$RQI[0] = REQID$LB;
      CPR$CSU[0] = LBARG$SMID[0];
      CPR$WC[0] = TYP4$WC;
      CPR$Y[0] = OLD$Y;
      CPR$Z[0] = OLD$Z;
 
#
*     SET UP ADDITIONAL REQUEST BLOCK FIELDS FOR SPECIFIC REQUEST.
#
 
      GOTO CALL4ACT[REQ$CODE];
 
GETCART:                             # GET CARTRIDGE REQUEST #
      CPR$ADDR2[0] = OLDLABP;
      GOTO ISSUECALL;
 
 
PUTCART:                             # PUT CARTRIDGE REQUEST #
      GOTO ISSUECALL;
 
WRITLAB:                             # WRITE LABEL REQUEST #
      CPR$ADDR2[0] = NEWLABP;
      GOTO ISSUECALL;
 
 
 
ISSUECALL:                           # ISSUE REQUEST TO EXEC #
      CALLSS(SSID$LB,CPR[0],RCL);
      RESP$CODE = CPR$RQR[0];
      RETURN;
 
      END  # CALL4 #
 
    TERM
PROC CKLAB(LAB$TYPE);
# TITLE CKLAB - CHECKS CARTRIDGE LABEL.                               #
 
      BEGIN  # CKLAB #
 
#
**    CKLAB - CHECKS CARTRIDGE LABEL.
*
*     THIS PROCEDURE CHECKS CARTRIDGE LABEL
*     TO SEE IF IT IS A RECOGNIZABLE LABEL.
*
*     PROC CKLAB(LAB$TYPE)
*
*     ENTRY     OLDLABP, AN ITEM CONTAINING FWA OF BUFFER
*                        CONTAINING OLD CARTRIDGE LABEL.
*
*     EXIT      CARTRIDGE LABEL CHECKED.
*               LAB$TYPE, AN ITEM CONTAINING
*                         LABEL TYPE.
*
*     NOTES     PROC *CKLAB* CHECKS THE LABEL
*               TO SEE IF IT IS A MANUFACTURERS
*               LABEL, SCRATCH LABEL, FAMILY
*               LABEL OR AN UNRECOGNIZABLE LABEL.
#
 
      ITEM LAB$TYPE   U;             # CARTRIDGE LABEL TYPE #
 
#
****  PROC CKLAB - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC CONVSN;                 # CONVERTS VSN FROM EBCDIC TO CDC
                                       DISPLAY CODE #
        END
 
#
****  PROC CKLAB - XREF LIST END.
#
 
      DEF PROCNAME #"CKLAB."#;       # PROC NAME #
 
      DEF LISTCON    #0#;            # DO NOT LIST COMDECKS #
*CALL COMBFAS
*CALL COMBLBL
*CALL COMTLAB
 
      ITEM CONTYPE    I;             # TYPE OF CONVERSION #
      ITEM FLAG       I;             # CHECK FOR LEGAL CHARACTER #
      ITEM TEMP$VSN   C(8);          # CSN IN CDC DISPLAY CODE #
 
                                               CONTROL EJECT;
 
#
*     CONVERT THE TWELVE BYTES IN THE CSN IN EBCDIC TO
*     DISPLAY CODE AND ALSO CHECK TO SEE IF THEY ARE
*     LEGAL CDC CHARACTERS (A - Z EXCEPT I AND O AND
*     0 - 9).
#
 
      CONTYPE = 1;
      CONVSN(TEMP$VSN,CONTYPE,FLAG);
      IF FLAG NQ 0
      THEN                           # NOT LEGAL CDC CHARACTER #
        BEGIN
        GOTO UNREC$LAB;              # PROCESS THE ERROR #
        END
 
      P<LABEL$CART> = OLDLABP;
 
 
 
#
*     CHECK FOR A FAMILY LABEL.
#
 
      IF (LAB$FMLY[0] NQ " ") AND (LAB$CARTTP[0] EQ 1)
      THEN
        BEGIN
        LAB$TYPE = LABTYPE"FAM$LAB";
        RETURN;
        END
 
#
*     CHECK FOR A SCRATCH LABEL.
#
 
      IF (LAB$FMLY[0] EQ " ") AND (LAB$CARTTP[0] EQ LABTYPE"SCR$LAB")
        THEN
        BEGIN
        LAB$TYPE = LABTYPE"SCR$LAB";
        RETURN;
        END
 
      LAB$TYPE = LABTYPE"MAN$LAB";
      RETURN;
 
 
UNREC$LAB:                           # UNRECOGNIZABLE LABEL #
      LAB$TYPE = LABTYPE"UNR$LAB";
      RETURN;
 
      END  # CKLAB #
 
    TERM
PROC CONVSN(DC$VSN,(CONTYPE),CONFLAG);
# TITLE CONVSN - CONVERTS CSN BETWEEN EBCDIC AND DISPLAY CODE.        #
 
      BEGIN  # CONVSN #
 
#
**    CONVSN - CONVERTS CSN BETWEEN EBCDIC AND DISPLAY CODE.
*
*     THIS PROCEDURE CONVERTS THE CSN FROM EBCDIC TO DISPLAY CODE,
*     OR FROM DISPLAY CODE TO EBCDIC.
*
*     PROC CONVSN(DC$VSN,(CONTYPE),CONFLAG)
*
*     ENTRY     CONTYPE   TYPE OF CONVERSION REQUESTED.
*                         0,  DISPLAY CODE TO EBCDIC.
*                         1,  EBCDIC TO DISPLAY CODE.
*               DC$VSN    AN ITEM CONTAINING CSN IN CDC
*                         DISPLAY CODE.
*               OLDLABP   AN ITEM CONTAINING FWA OF BUFFER
*                         CONTAINING OLD CARTRIDGE LABEL.
*
*     EXIT      CONFLAG   BOOLEAN ITEM CONTAINING ERROR STATUS.
*                         FALSE, NO ERROR.
*                         TRUE,  NOT A LEGAL CDC CHARACTER.
*
*     NOTES     PROC *CONVSN* CONVERTS THE EBCDIC CSN FROM
*               *OLDLABEL* AND RETURNS A DISPLAY CODE CSN IN ITEM
*               *DC$VSN*, OR IT CONVERTS THE DISPLAY CODE CSN FROM
*               ITEM *DC$VSN* TO EBCDIC AND STORES THE RESULT IN
*               ARRAY *OLDLABEL*.  IF ANY CHARACTERS ARE NOT LEGAL
*               CDC CHARACTERS (ALPHANUMERIC, EXCLUDING *O* AND *I*)
*               ERROR FLAG *CONFLAG* IS SET.
#
 
      ITEM DC$VSN     C(8);          # CSN IN CDC DISPLAY CODE #
      ITEM CONTYPE    U;             # TYPE OF CONVERSION #
      ITEM CONFLAG    B;             # ERROR FLAG FOR ILLEGAL CSN #
 
#
****  PROC CONVSN - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC DCEBC;                  # CONVERTS BETWEEN EBCDIC AND
                                       DISPLAY CODE #
        END
 
#
****  PROC CONVSN - XREF LIST END.
#
 
      DEF LISTCON #0#;               # DO NOT LIST THE COMDECKS #
*CALL COMBFAS
*CALL COMBLBL
*CALL COMTLAB
 
      ITEM DCTEMP     C(1);          # TEMPORARY DISPLAY CODE ITEM #
      ITEM EBCTEMP    U;             # TEMPORARY EBCDIC ITEM #
      ITEM I          I;             # LOOP VARIABLE #
      ITEM LEGCHAR    B;             # LEGAL CHARACTER FLAG #
 
      ARRAY EBC$VSN [1:12] P(1);     # CONTAINS EBCDIC CHARACTERS #
        BEGIN
        ITEM EBC$CHAR   U(00,00,60);  # EBCDIC CHARACTER #
        END
 
                                               CONTROL EJECT;
 
      P<LABEL$CART> = OLDLABP;       # LABEL FORMAT DESCRIPTION #
      CONFLAG = FALSE;
 
#
*     CONVERSION FROM DISPLAY CODE TO EBCDIC.
#
 
      IF CONTYPE EQ 0
      THEN
        BEGIN  # DISPLAY TO EBCDIC CONVERSION #
        SLOWFOR I = 0 STEP 1 UNTIL 7
        DO
          BEGIN
          DCTEMP = C<I,1>DC$VSN;
          IF DCTEMP EQ "I"           ##
            OR DCTEMP EQ "O"         ##
            OR DCTEMP LS "A"         ##
            OR DCTEMP GR "9"
          THEN                       # ILLEGAL CDC CHARACTER #
            BEGIN
            CONFLAG = TRUE;
            RETURN;
            END
 
          DCEBC(DCTEMP,EBCTEMP,0);   # CONVERT TO EBCDIC #
          EBC$CHAR[I+1] = EBCTEMP;
          END
 
        B<32,8>LAB$CSN[0] = B<52,8>EBC$CHAR[1];
        B<40,8>LAB$CSN[0] = B<52,8>EBC$CHAR[2];
        B<48,8>LAB$CSN[0] = B<52,8>EBC$CHAR[3];
        B<56,4>LAB$CSN[0] = B<52,4>EBC$CHAR[4];
        B<0,4>LAB$CSN[1]  = B<56,4>EBC$CHAR[4];
        B<4,8>LAB$CSN[1]  = B<52,8>EBC$CHAR[5];
        B<12,8>LAB$CSN[1] = B<52,8>EBC$CHAR[6];
        B<20,8>LAB$CSN[1] = B<52,8>EBC$CHAR[7];
        B<28,8>LAB$CSN[1] = B<52,8>EBC$CHAR[8];
        RETURN;
        END  # DISPLAY TO EBCDIC CONVERSION #
 
#
*     CONVERSION FROM EBCDIC TO DISPLAY CODE.
#
 
      IF CONTYPE EQ 1
      THEN
        BEGIN  # EBCDIC TO DISPLAY CONVERSION #
        EBC$CHAR[1] = B<32,8>LAB$CSN[0];  # SAVE EBCDIC BYTES #
        EBC$CHAR[2] = B<40,8>LAB$CSN[0];
        EBC$CHAR[3] = B<48,8>LAB$CSN[0];
        B<52,4>EBC$CHAR[4] = B<56,4>LAB$CSN[0];
        B<56,4>EBC$CHAR[4] = B<0,4>LAB$CSN[1];
        EBC$CHAR[5] = B<4,8>LAB$CSN[1];
        EBC$CHAR[6] = B<12,8>LAB$CSN[1];
        EBC$CHAR[7] = B<20,8>LAB$CSN[1];
        EBC$CHAR[8] = B<28,8>LAB$CSN[1];
        LEGCHAR = TRUE;
 
        SLOWFOR I = 0 STEP 1 WHILE LEGCHAR AND I LQ 7
        DO
          BEGIN
          DCEBC(DCTEMP,EBC$CHAR[I+1],1);  # CONVERT TO DISPLAY CODE #
          IF DCTEMP EQ "I"           ##
            OR DCTEMP EQ "O"         ##
            OR DCTEMP LS "A"         ##
            OR DCTEMP GR "9"
          THEN                       # ILLEGAL CDC CHARACTER #
            BEGIN
            LEGCHAR = FALSE;
            TEST I;
            END
 
          C<I,1>DC$VSN = DCTEMP;
          END
 
        IF NOT LEGCHAR
        THEN                         # RETURN ERROR FLAG #
          BEGIN
          CONFLAG = TRUE;
          END
 
        RETURN;
        END  # EBCDIC TO DISPLAY CONVERSION #
 
      END  # CONVSN #
 
    TERM
PROC DCEBC(DC$ITEM,EBC$ITEM,FLAG);
# TITLE DCEBC - CONVERTS TO/FROM EBCDIC VALUES.                       #
 
      BEGIN  # DCEBC #
 
#
**    DCEBC   CONVERTS TO/FROM EBCDIC VALUES.
*
*     THIS PROCEDURE CONVERTS AN ITEM FROM DISPLAY
*     CODE TO EBCDIC (FLAG = 0), OR FROM EBCDIC TO
*     DISPLAY CODE (FLAG = 1).
*
*     PROC DCEBC(DC$ITEM,EBC$ITEM,FLAG)
*
*     ENTRY   FLAG,     AN ITEM CONTAINING CODE FOR THE
*                       THE TYPE OF CONVERSION.
*                0,     DISPLAY CODE TO EBCDIC.
*                1,     EBCDIC TO DISPLAY CODE.
*             DC$ITEM,  DISPLAY CODE VALUE (IF FLAG=0).
*             EBC$ITEM, EBCDIC VALUE (IF FLAG=1).
*
*     EXIT    CONVERSION DONE AND THE CONVERTED VALUE SET
*             UP IN DC$ITEM (FLAG=1) OR EBC$ITEM(FLAG=0).
*             (DC$ITEM) = 0, IF AN ILLEGAL CHARACTER.
*
*     NOTES   PROC *DCEBC* CONVERTS AN ITEM FROM DISPLAY
*             CODE TO EBCDIC OR EBCDIC TO DISPLAY CODE
*             VALUE DEPENDING ON THE VALUE OF FLAG.  A
*             TABLE HAS BEEN PRESET WITH THE EBCDIC VALUES.
*             THE ORDINAL OF THE MATCHING EBCDIC VALUE GIVES
*             THE DISPLAY CODE VALUE.
#
 
      ITEM DC$ITEM    U;             # DISPLAY CODE VALUE #
      ITEM EBC$ITEM   U;             # EBCDIC VALUE #
      ITEM FLAG       I;             # DIRECTION OF CONVERSION #
 
      DEF CTLEN #36#;                # CONVERSION TABLE LENGTH #
 
      DEF LISTCON    #0#;            # DO NOT LIST COMDECKS #
*CALL COMBFAS
 
      ITEM I          I;             # LOOP VARIABLE #
 
#
*     DISPLAY CODE / EBCDIC CONVERSION TABLE.
#
 
      ARRAY CONVTBL [1:CTLEN] P(1);  # EBCDIC VALUE #
        BEGIN
        ITEM CONV$VAL   U(00,00,08) = [X"C1",  # A #
        X"C2",                       # B #
        X"C3",                       # C #
        X"C4",                       # D #
        X"C5",                       # E #
        X"C6",                       # F #
        X"C7",                       # G #
        X"C8",                       # H #
        X"C9",                       # I #
        X"D1",                       # J #
        X"D2",                       # K #
        X"D3",                       # L #
        X"D4",                       # M #
        X"D5",                       # N #
        X"D6",                       # O #
        X"D7",                       # P #
        X"D8",                       # Q #
        X"D9",                       # R #
        X"E2",                       # S #
        X"E3",                       # T #
        X"E4",                       # U #
        X"E5",                       # V #
        X"E6",                       # W #
        X"E7",                       # X #
        X"E8",                       # Y #
        X"E9",                       # Z #
        X"F0",                       # 0 #
        X"F1",                       # 1 #
        X"F2",                       # 2 #
        X"F3",                       # 3 #
        X"F4",                       # 4 #
        X"F5",                       # 5 #
        X"F6",                       # 6 #
        X"F7",                       # 7 #
        X"F8",                       # 8 #
        X"F9"];                      # 9 #
        END
 
                                               CONTROL EJECT;
 
      IF FLAG EQ 1
      THEN
        BEGIN  # CONVERT FROM EBCDIC TO DISPLAY CODE #
 
        SLOWFOR I = 1 STEP 1 UNTIL CTLEN
        DO
          BEGIN
          IF CONV$VAL[I] EQ EBC$ITEM
          THEN
            BEGIN
            B<0,6>DC$ITEM = I;
            RETURN;
            END
 
          END
 
        DC$ITEM = 0;                 # ILLEGAL CHARACTER #
        RETURN;
        END  # CONVERT FROM EBCDIC TO DISPLAY CODE #
 
      ELSE
        BEGIN  # CONVERT FROM DISPLAY CODE TO EBCDIC #
        I = B<0,6>DC$ITEM;
        EBC$ITEM = CONV$VAL[I];
        RETURN;
        END  # CONVERT FROM DISPLAY CODE TO EBCDIC #
 
      END  # DCEBC #
 
    TERM
PROC DLABFLD;
# TITLE DLABFLD - DISPLAYS FIELDS IN THE CARTRIDGE LABEL.             #
 
      BEGIN  # DLABFLD #
 
#
**    DLABFLD - DISPLAYS FIELDS IN THE CARTRIDGE LABEL.
*
*     PROC DLABFLD.
*
*     ENTRY     (OLDLABP) = FWA OF BUFFER CONTAINING
*                           CARTRIDGE LABEL.
*
*     EXIT      ALL APPROPRIATE FIELDS ARE DISPLAYED IN THE
*               DAYFILE AND IN THE REPORT FILE.
*
*     MESSAGES  1)  CSN = XXXXXXXX.
*               2)  FAMILY = XXXXXXX.
*               3)  SUBFAMILY = X.
                4)  SM = X.
*               5)  X = X.
*               6)  Y = X.
*
*     NOTES     PROC *DLABFLD* CALLS *CONVSN* AND *XCDD* TO
*               CONVERT ALL FIELDS TO DISPLAY CODE.  THE APPROPRIATE
*               FIELDS FROM THE OLD CARTRIDGE LABEL ARE THEN DISPLAYED
*               IN THE DAYFILE AND IN THE REPORT FILE.
#
 
#
****  PROC DLABFLD - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC BZFILL;                 # BLANK/ZERO FILLS A BUFFER #
        PROC CONVSN;                 # CONVERTS VSN FROM EBCDIC TO
                                       DISPLAY CODE #
        PROC LBERR;                  # ERROR PROCESSOR #
        PROC MESSAGE;                # DISPLAYS DAYFILE MESSAGES #
        PROC RPLINE;                 # WRITES A LINE ON OUTPUT FILE #
        FUNC XCDD C(10);             # CONVERTS ITEMS FROM INTEGERS TO
                                       DISPLAY CODE #
        END
 
#
****  PROC DLABFLD - XREF LIST END.
#
 
      DEF PROCNAME #"DLABFLD."#;     # PROC NAME #
 
      DEF LISTCON    #0#;            # DO NOT LIST COMDECKS #
*CALL COMBFAS
*CALL COMBBZF
*CALL COMBLBL
*CALL COMTERR
*CALL COMTLAB
*CALL COMTOUT
 
      ITEM CONFLAG    B;             # CONVERSION FLAG #
      ITEM CONTYPE    I;             # TYPE OF CONVERSION #
      ITEM DIS$SUB    C(10);         # SUBFAMILY IN DISPLAY CODE #
      ITEM DIS$VSN    C(8);          # *CSN* IN DISPLAY CODE #
      ITEM DIS$Y      C(10);         # Y COORDINATE IN DISPLAY CODE #
      ITEM DIS$Z      C(10);         # Z COORDINATE IN DISPLAY CODE #
      ITEM TEMP       C(7);          # TEMPORARY ITEM #
 
      ARRAY LABFLD [0:0] P(4);       # DISPLAY FIELDS ARRAY #
        BEGIN
        ITEM LABMSG     C(00,00,38);  # MESSAGE DISPLAY FIELD #
        ITEM LABY       C(00,30,02);  # Y COORDINATE IN DISPLAY #
        ITEM LABZ       C(00,30,02);  # Z COORDINATE IN DISPLAY #
        ITEM LABCSU     C(00,42,01);  # *SM* IN DISPLAY CODE #
        ITEM LABCM      C(00,42,02);  # CARTRIDGE MANUFACTURER #
        ITEM LABVSN     C(00,42,08);  # *CSN* IN DISPLAY CODE #
        ITEM LABFAM     C(01,00,07);  # FAMILY IN DISPLAY CODE #
        ITEM LABSUB     C(01,18,01);  # SUBFAMILY IN DISPLAY CODE #
        ITEM LABTERM    U(03,48,12) = [0];  # TERMINATOR #
        END
 
                                               CONTROL EJECT;
 
#
*     CONVERT EACH BYTE IN *CSN* TO DISPLAY CODE.
#
 
      CONTYPE = 1;
      CONVSN(DIS$VSN,CONTYPE,CONFLAG);
      IF CONFLAG
      THEN                           # ILLEGAL *CSN* #
        BEGIN
        ERRCODE = S"ILLEG$C";
        LBERR(ERRCODE);
        END
 
#
*     DISPLAY CARTRIDGE MANUFACTURER.
#
 
      P<LABEL$CART> = OLDLABP;
      LABMSG[0] = " CM = ";
      LABCM[0] = LAB$CCOD[0];
      MESSAGE(LABFLD[0],UDFL1);
      RPLINE(OUT$FETP,"CM = ",8,8,1);
      RPLINE(OUT$FETP,LABCM[0],14,2,0);
 
 
#
*     DISPLAY *CSN* IN DAYFILE AND IN REPORT FILE.
#
 
      LABMSG[0] = " CSN = ";
      LABVSN[0] = DIS$VSN;
      MESSAGE(LABFLD[0],UDFL1);
      RPLINE(OUT$FETP,"CSN = ",8,8,1);
      RPLINE(OUT$FETP,DIS$VSN,14,8,0);
 
 
 
#
*     DISPLAY FAMILY AND SUBFAMILY FOR A FAMILY LABEL.
#
 
      IF LAB$FMLY[0] NQ " "
      THEN
        BEGIN  # DISPLAY FAMILY/SUBFAMILY #
        TEMP = LAB$FMLY[0];          # BLANK FILL FAMILY NAME #
        BZFILL(TEMP,TYPFILL"BFILL",7);
        LABMSG[0] = " FAMILY = ";
        LABFAM[0] = TEMP;
        MESSAGE(LABFLD[0],UDFL1);
        RPLINE(OUT$FETP,"FAMILY = ",8,9,1);
        RPLINE(OUT$FETP,TEMP,17,7,0);
 
        DIS$SUB = XCDD(LAB$SF[0]);
        LABMSG[0] = " SUBFAMILY";
        LABFAM[0] = " = ";
        LABSUB[0] = C<9,1>DIS$SUB;
        MESSAGE(LABFLD[0],UDFL1);
        RPLINE(OUT$FETP,"SUBFAMILY = ",8,12,1);
        RPLINE(OUT$FETP,LABSUB[0],20,1,0);
        END  # DISPLAY FAMILY/SUBFAMILY #
 
#
*     DISPLAY *SM* IDENTIFIER.
#
 
      LABMSG[0] = " SM = ";
      LABCSU[0] = LAB$SMID[0];
      MESSAGE(LABFLD[0],UDFL1);
      RPLINE(OUT$FETP,"SM = ",8,6,1);
      RPLINE(OUT$FETP,LABCSU[0],14,1,0);
 
#
*     DISPLAY Y,Z COORDINATES.
#
 
      DIS$Y = XCDD(LAB$Y[0]);
      LABMSG[0] = " Y = ";
      LABY[0] = C<8,2>DIS$Y;
      MESSAGE(LABFLD[0],UDFL1);
      RPLINE(OUT$FETP,"Y = ",8,4,1);
      RPLINE(OUT$FETP,LABY[0],12,2,0);
 
      DIS$Z = XCDD(LAB$Z[0]);
      LABMSG[0] = " Z = ";
      LABZ[0] = C<8,2>DIS$Z;
      MESSAGE(LABFLD[0],UDFL1);
      RPLINE(OUT$FETP,"Z = ",8,4,1);
      RPLINE(OUT$FETP,LABZ[0],12,2,0);
 
      RETURN;
 
      END  # DLABFLD #
 
    TERM
PROC GENLAB((LAB$TYPE),PT$CSU$ENT,(LD$CNT),(LD$ERR),(SR$ERR), (
      STR$RD),(STR$WR),(STR$DM));
# TITLE GENLAB - SETS UP A FAMILY OR SCRATCH LABEL.                   #
 
      BEGIN  # GENLAB #
 
#
**    GENLAB - SETS UP A FAMILY OR SCRATCH LABEL.
*
*     THIS PROCEDURE SETS UP A FAMILY OR SCRATCH
*     LABEL DEPENDING UPON THE *LABTYPE* SPECIFIED.
*
*     PROC GENLAB((LAB$TYPE),PT$CSU$ENT,(LD$CNT),(LD$ERR),
*                (SR$ERR),(SW$ERR),(HR$ERR))
*
*     ENTRY     PT$CSU$ENT  AN ARRAY CONTAINING THE
*                           SMMAP ENTRY.
*               LD$CNT      AN ITEM CONTAINING THE
*                           CARTRIDGE LOAD COUNT.
*               LD$ERR      AN ITEM CONTAINING A COUNT OF
*                           LOAD ERRORS.
*               SR$ERR      AN ITEM CONTAINING A COUNT OF
*                           SOFT READ ERRORS.
*               SW$ERR      AN ITEM CONTAINING A COUNT OF
*                           SOFT WRITE ERRORS.
*               HR$ERR      AN ITEM CONTAINING A COUNT OF
*                           HARD READ ERRORS.
*               STR$RD      AN ITEM CONTAINING A COUNT OF
*                           STRIPES WRITTEN.
*               STR$WR      AN ITEM CONTAINING A COUNT OF
*                           STRIPES READ.
*               STR$DM      AN ITEM CONTAINING A COUNT OF
*                           STRIPES DEMARKED.
*               NEWLABP     AN ITEM CONTAINING FWA OF BUFFER
*                           CONTAINING NEW CARTRIDGE LABEL.
*               DRD$NUM    AN ITEM CONTAINING TRANSPORT ID.
*
*     EXIT      LABEL SET UP IN *NEWLABEL*.
*
*     NOTES    PROC *GENLAB* SETS UP THE FIELDS FOR
*              A FAMILY OR SCRATCH LABEL FOR A CARTRIDGE.
#
 
      ITEM LAB$TYPE   U;             # TYPE OF CARTRIDGE LABEL #
 
      ARRAY PT$CSU$ENT [0:0] P(5);   # *PUT* SMMAP ENTRY #
        BEGIN
        ITEM PT$MAPENT  C(00,00,30);  # THREE WORD MAP ENTRY #
        ITEM PT$Y       U(03,00,30);  # Y COORDINATE #
        ITEM PT$Z       U(03,30,30);  # Z COORDINATE #
        ITEM PT$GR      U(04,00,07);  # GROUP #
        ITEM PT$GRT     U(04,07,04);  # GROUP ORDINAL #
        END
 
 
      ITEM LD$CNT     I;             # CARTRIDGE LOAD COUNT #
      ITEM PS$CNT     I;             # CARTRIDGE PASS COUNT #
      ITEM ERR$CNT    I;             # CARTRIDGE ERROR COUNT #
 
#
****  PROC GENLAB - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC CONVSN;                 # CONVERTS VSN FROM EBCDIC TO
                                       DISPLAY CODE #
        PROC LBERR;                  # ERROR PROCESSOR #
        END
 
#
****  PROC GENLAB - XREF LIST END.
#
 
      DEF PROCNAME #"GENLAB."#;      # PROC NAME #
 
      DEF LISTCON    #0#;            # DO NOT LIST COMDECKS #
*CALL COMBFAS
*CALL COMBLBL
*CALL COMBMAP
*CALL COMTERR
*CALL COMTLAB
*CALL COMTLBP
 
      ITEM CONTYPE    I;             # TYPE OF CONVERSION #
      ITEM FLAG       I;             # ERROR FLAG #
      ITEM HR$ERR     I;             # HARD READ ERRORS #
      ITEM I          I;             # LOOP VARIABLE #
      ITEM LD$ERR     I;             # LOAD ERRORS #
      ITEM TEMP$VSN   C(8);          # CSN IN CDC DISPLAY CODE #
      ITEM SR$ERR     I;             # SOFT READ ERRORS #
      ITEM STR$RD     I;             # STRIPES READ #
      ITEM STR$WR     I;             # STRIPES WRITTEN #
      ITEM STR$DM     I;             # STRIPES DEMARKED #
      ITEM SW$ERR     I;             # SOFT WRITE ERRORS #
 
#
*     BASED ARRAY TO ACCESS FIRST FOUR WORDS OF CARTRIDGE LABEL.
#
 
      BASED
      ARRAY TEMP$LAB [0:0] P(1);
        BEGIN
        ITEM TEMP$LABW  U(00,00,60);  # FIRST WORD OF LABEL #
        END
 
                                               CONTROL EJECT;
 
#
*     ZERO FILL THE *NEWLABEL* ARRAY.
#
 
      P<LABEL$CART> = NEWLABP;
      SLOWFOR I = 0 STEP 1 UNTIL LABLEN-1
      DO
        BEGIN
        LAB$W1[I] = 0;
        END
 
#
*     SET THE FIRST 4 WORDS WORDS OF *NEWLABEL*
*     EQUAL TO THE FIRST 4 WORDS OF *OLDLABEL*.
#
 
      P<LABEL$CART> = OLDLABP;
      P<TEMP$LAB> = NEWLABP;
      SLOWFOR I = 0 STEP 1 UNTIL 3
      DO
        BEGIN
        TEMP$LABW[I] = LAB$W1[I];
        END
 
#
*     CONVERT EACH OF THE SIX EBCDIC BYTES IN *OLDLABEL*
*     TO DISPLAY CODE.
#
 
      CONTYPE = 1;
      CONVSN(TEMP$VSN,CONTYPE,FLAG);
      IF FLAG NQ 0
      THEN                           # ILLEGAL VSN #
        BEGIN
        ERRCODE = S"ILLEG$C";
        LBERR(ERRCODE);
        END
 
      P<LABEL$CART> = NEWLABP;
      P<SMUMAP> = LOC(PT$CSU$ENT[0]);
 
#
*     SET UP VARIOUS FIELDS IN *NEWLABEL*.
#
 
      LAB$CSND[0] = TEMP$VSN;
      LAB$Y[0] = PT$Y[0];
      LAB$Z[0] = PT$Z[0];
      LAB$FMLY[0] = CM$FMLYNM[0];
      LAB$SF[0] = CM$SUB[0];
      LAB$SMID[0] = LBARG$SM[0];
      LAB$CLF[0] = 1;
 
#
*     SET UP *P* FLAG.
#
 
      IF LAB$TYPE EQ LABTYPE"SCR$LAB"
      THEN                           # A SCRATCH LABEL #
        BEGIN
        LAB$CARTTP[0] = 2;
        END
 
      ELSE                           # A FAMILY LABEL #
        BEGIN
        LAB$CARTTP[0] = 1;
        END
 
 
#
*     SET UP THE LOAD COUNT, LOAD ERRORS, SOFT READ/WRITE
*     AND HARD READ ERRORS.
*     FOR THE CARTRIDGE.
#
 
      LAB$CRLD[0] = LD$CNT;
      LAB$LDER = LD$ERR;
      LAB$SWRE = B<28,4>SW$ERR;
      LAB$SWRE1 = B<32,28>SW$ERR;
      LAB$SRDE = SR$ERR;
      LAB$HRDE = HR$ERR;
      LAB$STRD[0] = B<28,8>STR$RD;
      LAB$STWR1[0] = B<36,24>STR$WR;
      LAB$STWR[0] = STR$WR;
      LAB$STDM[0] = STR$DM;
 
#
*     SET UP NUMBER OF THE TRANSPORT ON WHICH
*     LABEL WAS WRITTEN.  ALSO SET UP THE DATE
*     AND TIME WHEN LABEL WAS WRITTEN.
#
 
      LAB$DTTM[0] = PD$T;
 
      RETURN;
 
      END  # GENLAB #
 
    TERM
PROC LBADCSU;
# TITLE LBADCSU - ADDS A *SM* TO A SUBFAMILY.                          #
 
      BEGIN  # LBADCSU #
 
#
**    LBADCSU - ADDS A *SM* TO A SUBFAMILY.
*
*     THIS PROCEDURE ADDS A *SM* TO A FAMILY
*     IN THE CATALOG.  THIS DIRECTIVE DOES NOT
*     MANIPULATE CUBES OR CARTRIDGES.
*
*     PROC LBADCSU.
*
*     ENTRY   CRACKED AND SYNTAX CHECKED DIRECTIVE PARAMETERS
*             SET UP IN COMMON AREA DEFINED IN *COMTLBP*.
*
*     EXIT    *SM* ADDED TO THE SPECIFIED FAMILY.
*
*     NOTES   PROC *LBADCSU* SENDS A REQUEST TO EXEC TO ADD
*             THE *SM* TO THE FAMILY CATALOG.  IF THE *SM* IS
*             ALREADY DEFINED, IT CALLS THE ERROR PROCESSOR
*             WITH THE CORRESPONDING ERROR CODE.  SEE *LBERR*
*             FOR FURTHER INFORMATION.
#
 
#
****  PROC LBADCSU - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC CALL3;                  # SENDS TYPE 3 CALLSS TO EXEC #
        PROC LBRESP;                 # RESPONSE CODE PROCESSOR #
        END
 
#
****  PROC LBADCSU - XREF LIST END.
#
 
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS #
*CALL COMBFAS
*CALL COMBCPR
 
      ITEM RESP$CODE  U;             # RESPONSE CODE FROM EXEC #
 
                                               CONTROL EJECT;
 
#
*     ADD *SM* TO FAMILY CATALOG.
#
 
      CALL3(REQTYP3"ADD$CSU",0,0,0,RESP$CODE);
 
#
*     PROCESS THE RESPONSE CODE RETURNED BY EXEC.
#
 
      IF RESP$CODE NQ RESPTYP3"OK3"
      THEN
        BEGIN
        LBRESP(RESP$CODE,TYP"TYP3");
        END
 
      RETURN;
 
      END  # LBADCSU #
 
    TERM
PROC LBADCUB;
# TITLE LBADCUB - ADDS CUBES TO A FAMILY OR POOL.                     #
 
      BEGIN  # LBADCUB #
 
#
**    LBADCUB - ADDS CUBES TO A FAMILY OR POOL.
*
*     THIS PROC ADDS NON-ASSIGNED CUBES TO A FAMILY OR
*     THE POOL.
*
*     PROC LBADCUB.
*
*     ENTRY     CRACKED AND SYNTAX CHECKED DIRECTIVE PARAMETERS
*               SET UP IN COMMON AREA DEFINED IN *COMTLBP*.
*
*     EXIT      A SPECIFIED NUMBER OR LOCATIONS OF CUBES
*               ADDED TO A FAMILY OR POOL.
*
*     NOTES     PROC *LBADCUB* ADDS UNASSIGNED CUBES TO
*               A FAMILY OR POOL.  IT ADDS A SPECIFIED
*               NUMBER OF CUBES IF *N* IS SPECIFIED OR
*               ADDS THE CUBES AT THE LOCATIONS SPECIFIED
*               BZ *YI*, *YF*, *ZI*, *ZF*.  IT SEARCHES
*               THE SMMAP FOR AN UNASSIGNED CUBE AND
*               SENDS A REQUEST TO EXEC TO ADD IT TO THE
*               FAMILY CATALOG OR TO THE POOL.  IF AN
*               ERROR CONDITION IS ENCOUNTERED, *LBERR* IS
*               CALLED TO DO THE ERROR PROCESSING.
#
 
#
****  PROC LBADCUB - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC CALL3;                  # SENDS TYPE 3 CALLSS TO EXEC #
        PROC LBERR;                  # *SSLABEL* ERROR PROCESSOR #
        PROC LBRESP;                 # RESPONSE CODE PROCESSOR #
        PROC MFLUSH;                 # FLUSH MAP BUFFER #
        PROC MCLOSE;                 # CLOSE SMMAP #
        PROC MOPEN;                  # OPEN SMMAP #
        PROC SERCSU;                 # SEARCHES SMMAP #
        PROC SETCORD;                # SETS UP Y Z COORDINATE TABLE #
        END
 
#
****  PROC LBADCUB - XREF LIST END.
#
 
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS #
*CALL COMBFAS
*CALL COMBCPR
*CALL COMBMAP
*CALL COMTERR
*CALL COMTLAB
*CALL COMTLBP
 
      ITEM FLAG       I;             # ERROR FLAG #
      ITEM I          I;             # LOOP VARIABLE #
      ITEM LOC$OPTION B ;            # TRUE, IF *LOC* OPTION SELECTED
                                       FALSE, IF *N* OPTION SELECTED #
      ITEM RESP$CODE  U;             # RESPONSE CODE FROM EXEC #
      ITEM SERTYPE    S:SERCH$TYPE;  # SMMAP SEARCH TYPE #
      ITEM SP$CODE    U;             # CODE FOR CUBE/CARTRIDGE
                                       ASSIGNMENT #
      ITEM SP$FAM     C(7);          # SPECIFIED FAMILY #
      ITEM SP$SUB     U;             # SPECIFIED SUB FAMILY #
      ITEM SP$VSN     C(8);          # SPECIFIED *CSN* #
      ITEM SP$Y       U;             # Y COORDINATE #
      ITEM SP$Z       U;             # Z COORDINATE #
 
 
      ARRAY PK$CSU$ENT [0:0] P(4);   # *PICK* SMMAP ENTRY #
        BEGIN
        ITEM PK$MAPENT  C(00,00,30);  # THREE WORD MAP ENTRY #
        ITEM PK$Y       U(03,00,30);  # Y COORDINATE #
        ITEM PK$Z       U(03,30,30);  # Z COORDINATE #
        END
 
 
      ARRAY CMAP$NM [0:0] P(1);      # BUILD SMMAP FILE NAME #
        BEGIN
        ITEM CMAP$NAME  C(00,00,07);  # SMMAP FILE NAME #
        ITEM CMAP$IN    C(00,00,05);  # FIRST FIVE CHARACTERS #
        ITEM CMAP$ID    C(00,30,01);  # SM-ID #
        ITEM CMAP$Z     U(00,36,24) = [0];  # ZERO FILL #
        END
 
                                               CONTROL EJECT;
 
#
*     CHECK TO SEE IF THE *N* OPTION OR THE *LOC* OPTION
*     IS SPECIFIED.
#
 
      LOC$OPTION = FALSE;            # INITIALIZE #
      IF (LBARG$YI[0] NQ -1) OR (LBARG$ZI[0] NQ -1)
      THEN                           # *LOC* OPTION SPECIFIED #
        BEGIN
        SETCORD;                     # SET UP THE Y/Z COORDINATES #
        LOC$OPTION = TRUE;
        END
 
#
*     INITIALIZE ITEMS TO SEARCH SMMAP FOR UNASSIGNED
*     CUBES.
#
 
      SP$VSN = " ";
      SP$CODE = CUBSTAT"UNASGN";
      SP$FAM = " ";
      SP$SUB = 0;
      IF NOT LOC$OPTION
      THEN
        BEGIN  # *N* OPTION #
        IF LBARG$PT[0] EQ "F"
        THEN                         # SEARCH SMMAP FOR FIRST
                                       UNASSIGNED CUBE #
          BEGIN
          SERTYPE = S"ASSIGN";
          END
 
        IF LBARG$PT[0] EQ "P"
        THEN                         # SEARCH SMMAP FOR LAST
                                       UNASSIGNED CUBE #
          BEGIN
          SERTYPE = S"LST$UNAS";
          END
 
        END  # *N* OPTION #
 
      ELSE                           # *LOC* OPTION #
        BEGIN
        SERTYPE = S"LOC";            # SEARCH FOR LOCATION #
        END
 
#
*     PROCESS EACH OF THE *NOPT* CUBES.
#
 
      SLOWFOR I = 1 STEP 1 UNTIL LBARG$N[0]
      DO
        BEGIN  # ADD CUBES #
        IF SERTYPE EQ S"LOC"
        THEN
          BEGIN
          SP$Y = Y$COORD[I];         # SET UP Y AND Z COORDINATES #
          SP$Z = Z$COORD[I];
          END
 
#
*     SEARCH SMMAP FOR THE SPECIFIC ENTRY.
#
 
        SERCSU(SERTYPE,SP$Y,SP$Z,SP$CODE,SP$VSN,SP$FAM,SP$SUB,
          PK$CSU$ENT[0],FLAG);
        IF FLAG NQ 0
        THEN                         # ENTRY NOT FOUND #
          BEGIN
          NUMDONE = I - 1;           # NUMBER OF CUBES PROCESSED #
          ERRCODE = S"INSUF$CB";
          LBERR(ERRCODE);
          RETURN;
          END
 
        CMAP$ID[0] = LBARG$SM[0];
        CMAP$IN[0] = SMMAP;
 
#
*     CHECK THE *CODE* IN SMMAP ENTRY TO SEE IF
*     THE CUBE IS UNASSIGNED.
#
 
        P<SMUMAP> = LOC(PK$CSU$ENT[0]);
        IF CM$CODE[0] NQ CUBSTAT"UNASGN"
        THEN
          BEGIN
          NUMDONE = I - 1;           # NUMBER OF CUBES PROCESSED #
          ERRCODE = S"CB$ASGN";
          LBERR(ERRCODE);
          RETURN;
          END
 
#
*     CHECK *PT* TO SEE IF THE CUBE IS TO BE ADDED TO
*     FAMILY, POOL OR THE RESERVED AREA AND SEND A
*     CORRESPONDING REQUEST TO EXEC.
#
 
        IF LBARG$PT[0] EQ "F"
        THEN                         # ADD CUBE TO FAMILY #
          BEGIN
          CALL3(REQTYP3"ADD$CUBE",PK$CSU$ENT[0],0,0,RESP$CODE);
          IF RESP$CODE NQ RESPTYP3"OK3"
          THEN
            BEGIN
            LBRESP(RESP$CODE,TYP"TYP3");
            RETURN;
            END
 
          END
 
        ELSE
          BEGIN  # ADD CUBE TO POOL/RESERVED AREA #
          IF LBARG$PT[0] EQ "P"
          THEN
            BEGIN
            CM$CODE[0] = CUBSTAT"SCRPOOL";
            END
 
          IF LBARG$PT[0] EQ "R"
          THEN
            BEGIN
            CM$CODE[0] = CUBSTAT"ALTCSU";
            END
 
          CALL3(REQTYP3"UPD$MAP",PK$CSU$ENT[0],0,0,RESP$CODE);
          END  # ADD CUBE TO POOL/RESERVED AREA #
 
#
*     CHECK THE RESPONSE CODE RETURNED BY EXEC.
#
 
        IF RESP$CODE NQ RESPTYP3"OK3"
        THEN
          BEGIN
          LBRESP(RESP$CODE,TYP"TYP3");
          RETURN;
          END
 
        MFLUSH;                      # FLUSH MAP BUFFER #
        END  # ADD CUBES #
 
#
*     ALL THE CUBES ADDED.
#
 
      RETURN;
 
      END  # LBADCUB #
 
    TERM
PROC LBADMSC;
# TITLE LBADMSC - PROCESS THE *ADDMSC* DIRECTIVE.                     #
 
      BEGIN  # LBADMSC #
 
#
**    LBADMSC - PROCESS THE *ADDMSC* DIRECTIVE.
*
*     PROC LBADMSC.
*
*     ENTRY   CRACKED AND SYNTAX CHECKED DIRECTIVE PARAMETERS
*             SET UP IN COMMON AREA DEFINED IN *COMTLBP*.
*
*     EXIT    ALL CARTRIDGES PROCESSED.
*
*     NOTES   THE SMMAP IS SEARCHED FOR THE APPROPRIATE
*             *PICK* AND *PUT* LOCATIONS.  IF SUCCESSFUL, THE
*             CARTRIDGE IS BROUGHT TO A TRANSPORT AND GIVEN A NEW
*             LABEL.  THE SMMAP (AND FCT AND AST IF ADDED TO A
*             FAMILY) IS UPDATED TO REFLECT THE NEW CARTRIDGE
*             ASSIGNMENT, AND THE CARTRIDGE IS UNLOADED TO THE
*             NEW LOCATION.  ANY ERROR CONDITIONS ARE PROCESSED
*             BY PROC *LBERR*.
#
 
#
****  PROC LBADMSC - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC CALL3;                  # SENDS TYPE 3 CALLSS TO EXEC #
        PROC CALL4;                  # SENDS TYPE 4 CALLSS TO EXEC #
        PROC CKLAB;                  # CHECKS CARTRIDGE LABEL TYPE #
        PROC GENLAB;                 # GENERATES NEW LABEL #
        PROC LBERR;                  # *SSLABEL* ERROR PROCESSOR #
        PROC LBRESP;                 # RESPONSE CODE PROCESSOR #
        PROC LBSTCLR;                # STORE A *CE* CARTRIDGE #
        PROC MFLUSH;                 # FLUSH MAP BUFFER #
        PROC SERASTG;                # DETERMINE GROUP AND ORDINAL #
        PROC SERCSU;                 # SEARCHES SMMAP #
        END
 
#
****  PROC LBADMSC - XREF LIST END.
#
 
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS #
*CALL COMBFAS
*CALL COMBCPR
*CALL COMBLBL
*CALL COMBMAP
*CALL COMTERR
*CALL COMTLAB
*CALL COMTLBP
 
      ITEM CART$CSN   C(20);         # CARTRIDGE SERIAL NUMBER #
      ITEM CATFLD     U;             # CATALOG FIELD #
      ITEM CATVALUE   U;             # NEW VALUE FOR CATALOG FIELD #
      ITEM ERR$CNT    I;             # CARTRIDGE ERROR COUNT #
      ITEM FLAG       I;             # ERROR FLAG #
      ITEM GROUP      I;             # GROUP NUMBER #
      ITEM GRT        I;             # ORDINAL WITHIN GROUP #
      ITEM HR$ERR     I;             # HARD READ ERRORS #
      ITEM I          I;             # LOOP VARIABLE #
      ITEM LD$CNT     I;             # CARTRIDGE LOAD COUNT #
      ITEM LD$ERR     I;             # LOAD ERRORS #
      ITEM PS$CNT     U;             # CARTRIDGE PASS COUNT #
      ITEM REQCODE    U;             # REQUEST CODE #
      ITEM RESP$CODE  U;             # RESPONSE CODE #
      ITEM SGROUP     I;             # SAVE GROUP PARAMETER #
      ITEM SERFLAG    B;             # SMMAP SEARCH FLAG #
      ITEM SERTYPE    S:SERCH$TYPE;  # SMMAP SEARCH TYPE #
      ITEM SP$CODE    U;             # CUBE/CARTRIDGE ASSIGNMENT #
      ITEM SP$FAM     C(7);          # SPECIFIED FAMILY NAME #
      ITEM SP$SUB     U;             # SPECIFIED SUB FAMILY ID #
      ITEM SP$VSN     C(8);          # SPECIFIED CARTRIDGE *CSND* #
      ITEM SP$Y       I;             # Y COORDINATE #
      ITEM SP$Z       I;             # Z COORDINATE #
      ITEM SR$ERR     I;             # SOFT READ ERRORS #
      ITEM STR$RD     I;             # STRIPES READ #
      ITEM STR$WR     I;             # STRIPES WRITTEN #
      ITEM STR$DM     I;             # STRIPES DEMARKED #
      ITEM SW$ERR     I;             # SOFT WRITE ERRORS #
 
 
      ARRAY PK$CSU$ENT [0:0] P(4);   # *PICK* SMMAP ENTRY #
        BEGIN
        ITEM PK$MAPENT  C(00,00,30);  # THREE WORD MAP ENTRY #
        ITEM PK$Y       U(03,00,30);  # Y COORDINATE #
        ITEM PK$Z       U(03,30,30);  # Z COORDINATE #
        END
 
 
 
      ARRAY PT$CSU$ENT [0:0] P(5);   # *PUT* SMMAP ENTRY #
        BEGIN
        ITEM PT$MAPENT  C(00,00,30);  # THREE WORD MAP ENTRY #
        ITEM PT$Y       U(03,00,30);  # Y COORDINATE #
        ITEM PT$Z       U(03,30,30);  # Z COORDINATE #
        ITEM PT$GR      U(04,00,07);  # GROUP #
        ITEM PT$GRT     U(04,07,05);  # GROUP ORDINAL #
        END
 
 
                                               CONTROL EJECT;
 
      IF LBARG$CC[0] NQ -1
      THEN                           # STORE CLEAR CARTRIDGE #
        BEGIN
        LBSTCLR;
        RETURN;
        END
 
      SGROUP = LBARG$GR[0];
      SLOWFOR I = 1 STEP 1 UNTIL LBARG$N[0]
      DO
        BEGIN  # LBADMSC PROCESSING #
 
#
*     SEARCH FOR DEFAULT GROUP AND GROUP ORDINAL.
#
 
        IF LBARG$PT[0] NQ "P"
        THEN
          BEGIN
          LBARG$GR[0] = SGROUP;
          GROUP = LBARG$GR[0];
          SERASTG(GROUP,GRT,FLAG);
          IF FLAG NQ 0
          THEN                       # GROUP OR ORDINAL NOT AVAILABLE #
            BEGIN
            ERRCODE = S"GR$FULL";
            LBERR(ERRCODE);
            RETURN;
            END
 
          ELSE                       # SEARCH SUCCESSFUL #
            BEGIN
            LBARG$GR[0] = GROUP;
            PT$GR[0] = GROUP;
            PT$GRT[0] = GRT;
            END
 
          END
 
 
#
*     SEARCH FOR EMPTY CUBE TO WHICH CARTRIDGE IS TO BE ADDED.
#
 
        IF LBARG$PT[0] EQ "F"
        THEN                         # ADD CARTRIDGE TO FAMILY #
          BEGIN  # FAMILY SEARCH #
          SERTYPE = S"ASSIGN";
          SP$CODE = CUBSTAT"SUBFAM";
          SP$VSN = " ";              # SEARCH FOR AN EMPTY CUBE #
          SERCSU(SERTYPE,0,0,SP$CODE,SP$VSN,LBARG$FM[0],LBARG$SB[0],
            PT$CSU$ENT[0],SERFLAG);
          IF SERFLAG
          THEN                       # NO EMPTY CUBE IN FAMILY #
            BEGIN
            NUMDONE = I - 1;
            ERRCODE = S"NO$EMPCBFP";
            LBERR(ERRCODE);          # DO ERROR PROCESSING #
            RETURN;
            END
 
          END  # FAMILY SEARCH #
 
        IF LBARG$PT[0] EQ "P"
        THEN                         # ADD CARTRIDGE TO POOL #
          BEGIN  # POOL SEARCH #
          SERTYPE = S"ASSIGN";
          SP$FAM = " ";              # SEARCH FOR AN EMPTY CUBE #
          SP$SUB = 0;
          SP$VSN = " ";
          SP$CODE = CUBSTAT"SCRPOOL";
          SERCSU(SERTYPE,0,0,SP$CODE,SP$VSN,SP$FAM,SP$SUB,  ##
            PT$CSU$ENT[0],SERFLAG);
          IF SERFLAG
          THEN                       # NO EMPTY CUBE IN POOL #
            BEGIN
            NUMDONE = I - 1;
            ERRCODE = S"NO$EMPCBFP";
            LBERR(ERRCODE);          # DO ERROR PROCESSING #
            RETURN;
            END
 
          END  # POOL SEARCH #
 
#
*     SEARCH FOR CARTRIDGE TO BE ADDED.
#
 
 
        IF LBARG$PK[0] EQ "P" AND LBARG$C[0] EQ 0
        THEN
          BEGIN  # SEARCH POOL FOR ANY CARTRIDGE #
          SERTYPE = S"CART$POOL";
          SERCSU(SERTYPE,0,0,0,0,0,0,PK$CSU$ENT[0],SERFLAG);
          IF SERFLAG
          THEN                       # POOL EMPTY #
            BEGIN
            NUMDONE = I - 1;
            ERRCODE = S"NO$CR$PL";
            LBERR(ERRCODE);          # DO ERROR PROCESSING #
            RETURN;
            END
 
          END  # SEARCH POOL FOR ANY CARTRIDGE #
 
        IF LBARG$C[0] NQ 0
        THEN
          BEGIN  # SEARCH POOL FOR VSN #
          SERTYPE = S"CSN$MATCH";
          SERCSU(SERTYPE,0,0,0,LBARG$C[0],0,0,PK$CSU$ENT[0],SERFLAG);
          IF SERFLAG
          THEN                       # VSN NOT FOUND #
            BEGIN
            ERRCODE = S"CSN$NOTFND";
            LBERR(ERRCODE);          # DO ERROR PROCESSING #
            RETURN;
            END
 
          ELSE                       # VSN FOUND #
            BEGIN
            P<SMUMAP> = LOC(PK$CSU$ENT[0]);
            IF CM$CODE[0] NQ CUBSTAT"SCRPOOL"
            THEN                     # CARTRIDGE NOT ASSIGNED TO POOL #
              BEGIN
              ERRCODE = S"UNX$CR$ASN";
              LBERR(ERRCODE);        # DO ERROR PROCESSING #
              RETURN;
              END
 
            END
 
          END  # SEARCH POOL FOR VSN #
 
        IF LBARG$PK[0] EQ "D"
        THEN                         # SET COORDINATES TO CAS ENTRY #
          BEGIN
          PK$Y[0] = SM$ENT$TY;
          PK$Z[0] = 0;
          END
 
 
#
*     LOAD CARTRIDGE AND READ THE LABEL.
#
 
        CALL4(REQTYP4"LOAD$CART",DRD$NUM,CART$CSN,PK$Y[0], PK$Z[0],
          FLAG);
      IF FLAG NQ RESPTYP4"OK4"  ##
          AND FLAG NQ RESPTYP4"UNK$CART"
        THEN
          BEGIN  # LOAD FAILS #
          P<SMUMAP> = LOC(PK$CSU$ENT[0]);
          IF FLAG EQ RESPTYP4"CELL$EMP"  ##
            AND CM$CODE[0] EQ CUBSTAT"SCRPOOL"
          THEN
            BEGIN  # SET ERROR FLAG IN SMMAP ENTRY #
            CM$FLAG1[0] = TRUE;
            CALL3(REQTYP3"UPD$MAP",PK$CSU$ENT[0],0,0,FLAG);
            NUMDONE = I - 1;
            ERRCODE = S"CR$NOTFND";  # CARTRIDGE NOT FOUND #
            LBERR(ERRCODE);
            IF FLAG NQ RESPTYP3"OK3"
            THEN
              BEGIN
              LBRESP(FLAG,TYP"TYP3");
              END
 
            RETURN;
            END  # SET ERROR FLAG IN SMMAP ENTRY #
 
            P<LABEL$CART> = OLDLABP;
            IF FLAG EQ RESPTYP4"UNK$CART"
              AND LAB$CARTTP[0] NQ 0
            THEN                     # *CSN* MISMATCH #
              BEGIN
              LBRESP(FLAG,TYP"TYP4");
              RETURN;
              END
 
          ELSE                       # PROCESS THE RESPONSE CODE #
            BEGIN
            LBRESP(FLAG,TYP"TYP4");
            RETURN;
            END
 
          END  # LOAD FAILS #
 
 
        CKLAB(FLAG);                 # CHECK LABEL TYPE #
        P<LABEL$CART> = OLDLABP;
        IF (FLAG NQ LABTYPE"MAN$LAB"  ##
          AND FLAG NQ LABTYPE"SCR$LAB")  ##
        THEN                         # UNKNOWN LABEL TYPE #
          BEGIN
          CALL4(REQTYP4"UNLD$CART",0,0,SM$EXIT$TY,SM$TY$Z,RESP$CODE);
          IF RESP$CODE NQ 0
          THEN
            BEGIN
            LBRESP(RESP$CODE,TYP"TYP4");
            RETURN;
            END
 
          ERRCODE = S"UNKNWN$LAB";
          LBERR(ERRCODE);
          TEST I;
          END
 
        LD$CNT = LAB$CRLD[0];        # USE OLD COUNTS #
        LD$ERR = LAB$LDER[0];
        SR$ERR = LAB$SRDE[0];
        SW$ERR = LAB$SWRE1[0];
        B<28,4>SW$ERR = LAB$SWRE;
        HR$ERR = LAB$HRDE[0];
        STR$RD = LAB$STRD[0];
        STR$WR = LAB$STWR1[0];
        B<36,24>STR$WR = LAB$STWR[0];
        STR$DM = LAB$STDM[0];
 
        IF LBARG$PK[0] NQ "D"
        THEN
          BEGIN  # VERIFY VSN, Y, Z IN THE LABEL #
          P<LABEL$CART> = OLDLABP;
          P<SMUMAP> = LOC(PK$CSU$ENT[0]);
          IF LAB$CSND[0] NQ CM$CSND[0]  ##
            AND (LAB$Y[0] NQ PK$Y[0] OR LAB$Z[0] NQ PK$Z[0])
          THEN
            BEGIN  # TEST Y,Z #
            REQCODE = REQTYP4"UNLD$CART";
            CALL4(REQCODE,0,0,SM$EXIT$TY,SM$TY$Z,RESP$CODE);
            IF RESP$CODE NQ RESPTYP4"OK4"
            THEN
              BEGIN
              LBRESP(RESP$CODE,TYP"TYP4");
              RETURN;
              END
 
            ERRCODE = S"M86$HARDWR";  # MSF HARDWARE PROBLEM #
            LBERR(ERRCODE);
            RETURN;
            END  # TEST Y,Z #
 
          END  # VERIFY VSN, Y, Z IN THE LABEL #
 
#
*     GENERATE NEW CARTRIDGE LABEL
#
 
        IF LBARG$PT[0] EQ "P"
        THEN                         # SET UP SCRATCH LABEL #
          BEGIN
          GENLAB(LABTYPE"SCR$LAB",PT$CSU$ENT[0],LD$CNT,LD$ERR, SR$ERR,
            SW$ERR,HR$ERR,STR$RD,STR$WR,STR$DM);
          END
 
        ELSE                         # SET UP FAMILY LABEL #
          BEGIN
          GENLAB(LABTYPE"FAM$LAB",PT$CSU$ENT[0],LD$CNT,LD$ERR, SR$ERR,
            SW$ERR,HR$ERR,STR$RD,STR$WR,STR$DM);
          END
 
#
*     UPDATE THE CARTRIDGE LOAD AND PASS COUNTS IN THE
*     NEW LABEL.
#
 
        P<LABEL$CART> = NEWLABP;
        LAB$CRLD[0] = LAB$CRLD[0] + 1;
        IF B<0,8>LAB$CSN[0] NQ X"C9"  ##
          OR B<8,8>LAB$CSN[0] NQ X"C2" OR B<16,8>LAB$CSN[0] NQ X"D4"
          THEN                       # CARTRIDGE NOT IBM #
          BEGIN
          LAB$CCOD[0] = OTHCART;
          END
 
        ELSE
          BEGIN
          LAB$CCOD[0] = IBMCART;
          END
 
 
#
*     IF THE CARTRIDGE IS FROM THE INPUT DRAWER, ENSURE THAT
*     THE VSN IS NOT ALREADY IN THE SMUMAP.
#
 
        IF LBARG$PK[0] EQ "D"
        THEN
          BEGIN  # CHECK FOR DUPLICATE VSN #
          SERTYPE = S"CSN$MATCH";
          SERCSU(SERTYPE,0,0,0,LAB$CSND[0],0,0, PK$CSU$ENT[0],SERFLAG)
            ;
          IF NOT SERFLAG
          THEN                       # VSN ALREADY IN SMMAP #
            BEGIN
            REQCODE = REQTYP4"UNLD$CART";
            CALL4(REQCODE,0,0,SM$EXIT$TY,SM$TY$Z,RESP$CODE);
            IF RESP$CODE NQ RESPTYP4"OK4"
            THEN
              BEGIN
              LBRESP(RESP$CODE,TYP"TYP4");
              RETURN;
              END
 
            ERRCODE = S"DUPL$CSN";
            LBERR(ERRCODE);
            RETURN;
            END
 
          END  # CHECK FOR DUPLICATE VSN #
 
 
#
*     IF CARTRIDGE PICKED FROM POOL, UPDATE SMMAP ENTRY AND AST FOR
*     NOW EMPTY CUBE IN POOL.
#
 
        IF LBARG$PK[0] NQ "D"
        THEN                         # PICKED FROM POOL #
          BEGIN
          P<SMUMAP> = LOC(PK$CSU$ENT[0]);
        CM$CCOD[0] = " ";
          CM$CSND[0] = " ";          # CLEAR VSN FIELD #
          CALL3(REQTYP3"UPD$MAP",PK$CSU$ENT[0],0,0,FLAG);
          IF FLAG NQ RESPTYP3"OK3"
          THEN                       # MAP UPDATE FAILS #
            BEGIN
            REQCODE = REQTYP4"UNLD$CART";
            CALL4(REQCODE,0,0,PK$Y[0],PK$Z[0],RESP$CODE);
            IF RESP$CODE NQ RESPTYP4"OK4"
            THEN
              BEGIN
              LBRESP(RESP$CODE,TYP"TYP4");
              RETURN;
              END
 
            LBRESP(FLAG,TYP"TYP3");  # PROCESS ERROR CODE #
            RETURN;
            END
 
          END
 
#
*     WRITE NEW LABEL.
#
 
        CALL4(REQTYP4"WRT$LAB",DRD$NUM,CART$CSN,PT$Y[0],PT$Z[0], FLAG)
          ;
        IF FLAG NQ RESPTYP4"OK4"
        THEN                         # WRITE FAILS #
          BEGIN
          LBRESP(FLAG,TYP"TYP4");    # PROCESS THE RESPONSE CODE #
          RETURN;
          END
 
#
*     UPDATE SMMAP ENTRY FOR NEW LOCATION OF CARTRIDGE.
#
 
        P<SMUMAP> = LOC(PT$CSU$ENT[0]);
        IF LBARG$PT[0] EQ "P"
        THEN                         # ADD CARTRIDGE TO POOL #
          BEGIN
          P<LABEL$CART> = NEWLABP;
          CM$CCOD[0] = LAB$CCOD[0];
          CM$CSND[0] = LAB$CSND[0];  # UPDATE VSN IN MAP ENTRY #
          CALL3(REQTYP3"UPD$MAP",PT$CSU$ENT[0],0,0,FLAG);
          END
 
        IF LBARG$PT[0] EQ "F"
        THEN                         # ADD CARTRIDGE TO FAMILY #
          BEGIN
          CALL3(REQTYP3"ADD$CART",PT$CSU$ENT[0],0,0,FLAG);
          END
 
        IF FLAG NQ RESPTYP3"OK3"
        THEN                         # ADD TO FAMILY FAILS #
          BEGIN
          LBRESP(FLAG,TYP"TYP3");    # PROCESS THE RESPONSE CODE #
          RETURN;
          END
 
 
 
        MFLUSH;                      # FLUSH MAP BUFFER #
        END  # LBADMSC PROCESSING #
 
      RETURN;
 
      END  # LBADMSC #
 
    TERM
PROC LBCONV(FLAG);
# TITLE LBCONV - CONVERT CRACKED PARAMETERS TO INTEGERS.              #
 
      BEGIN  # LBCONV #
 
#
**    LBCONV - CONVERT CRACKED PARAMETERS TO INTEGERS.
*
*     THIS PROCEDURE CALLS *XDXB* TO CONVERT THE PARAMETERS
*     IN DISPLAY CODE TO INTEGER VALUES.
*
*     PROC LBCONV(FLAG)
*
*     ENTRY  DIRECTIVE PARAMETERS CRACKED AND
*            PLACED IN COMMON AREA *ULBPCOM*.
*
*     EXIT   ALL THE PARAMETERS CONVERTED AND PLACED
*            BACK IN *ULBPCOM*.
*            FLAG, AN ITEM CONTAINING THE ERROR STATUS.
*               0, NO ERROR
*               1, CONVERSION ERROR
*
*     NOTES  PROC *LBCONV* CONVERTS EACH CRACKED
*            PARAMETER FROM DISPLAY CODE TO INTEGER
*            VALUE AND REPLACES IT BACK IN ITS
*            ORIGINAL LOCATION.  ANY PARAMETER NOT
*            SPECIFIED IS SUBSTITUTED WITH ITS
*            DEFAULT VALUE.
#
 
      ITEM FLAG       I;             # ERROR STATUS #
 
#
****  PROC LBCONV - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        FUNC XDXB   I;               # CONVERT DISPLAY TO INTEGER #
        END
 
#
****  PROC LBCONV - XREF LIST END.
#
 
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS #
*CALL COMBFAS
*CALL COMTLAB
*CALL COMTLBP
 
      ITEM TEMPR      I;             # TEMP ITEM #
      ITEM TYPE       I;             # TYPE OF CONVERSION #
 
                                               CONTROL EJECT;
 
      TYPE = 1;                      # CONVERT FROM DISPLAY CODE TO
                                       INTEGER VALUE #
 
#
*     CHECK THE VALUE OF *N*.
#
 
      IF LBARG$N[0] EQ 0
      THEN                           # N OMITTED #
        BEGIN
        LBARG$N[0] = 1;              # SET DEFAULT VALUE #
        END
 
      IF LBARG$N[0] NQ 1
      THEN                           # N SPECIFIED #
        BEGIN
        FLAG = XDXB(LBARG$N[0],TYPE,TEMPR);
        IF FLAG NQ 0
        THEN                         # CONVERSION ERROR #
          BEGIN
          RETURN;
          END
 
        LBARG$N[0] = TEMPR;          # RESET N #
        END
 
#
*     CHECK THE VALUE OF *B*.
#
 
      IF LBARG$B[0] EQ 0
      THEN                           # SET DEFAULT #
        BEGIN
        LBARG$B[0] = 600;
        END
 
      IF LBARG$B[0] NQ 600
      THEN                           # *B* IS SPECIFIED #
        BEGIN
        FLAG = XDXB(LBARG$B[0],TYPE,TEMPR);
        IF FLAG NQ 0
        THEN                         # CONVERSION ERROR #
          BEGIN
          RETURN;
          END
 
        LBARG$B[0] = TEMPR;          # RESET *B* #
        END
 
#
*     SET THE VALUE OF *CC*.
#
 
      IF LBARG$CC[0] NQ 0
      THEN
        BEGIN
        IF C<0,1>LBARG$CC[0] EQ "A"
        THEN
          BEGIN
          LBARG$CC[0] = 0;
          END
 
        IF C<0,1>LBARG$CC[0] EQ "B"
        THEN
          BEGIN
          LBARG$CC[0] = 15;
          END
 
 
        END
 
      ELSE
        BEGIN
        LBARG$CC[0] = -1;
        END
 
 
 
#
*     CHECK THE VALUE OF *CC*.
#
 
      IF LBARG$CM[0] EQ 0
      THEN
        BEGIN
        LBARG$CM[0] = IBMCART;
        END
 
      ELSE
        BEGIN
        B<6,6>LBARG$CM[0] = "-";
        END
 
 
 
#
*     CHECK THE VALUE OF *GR*.
#
 
      IF LBARG$GR[0] NQ 7777
      THEN                           # VALUE IS SPECIFIED #
        BEGIN
        FLAG = XDXB(LBARG$GR[0],TYPE,TEMPR);
        IF FLAG NQ 0
        THEN                         # CONVERSION ERROR #
          BEGIN
          RETURN;
          END
 
        LBARG$GR[0] = TEMPR;         # RESET *GR* #
        END
 
      ELSE                           # *GR* NOT SPECIFIED #
        BEGIN
        LBARG$GR[0] = -1;
        END
 
 
#
*      CHECK THE VALUE OF *YI*.
#
 
      IF LBARG$YI[0] NQ 0 AND LBARG$YI[0] NQ O"7777"
      THEN
        BEGIN
        FLAG = XDXB(LBARG$YI[0],TYPE,TEMPR);
        IF FLAG NQ 0
        THEN                         # CONVERSION ERROR #
          BEGIN
          RETURN;
          END
 
        LBARG$YI[0] = TEMPR;         # RESET *YI* #
        END
 
      ELSE
        BEGIN
        IF LBARG$YI[0] EQ 0
        THEN                         # *YI* OMITTED #
          BEGIN
          LBARG$YI[0] = -1;          # SET DEFAULT VALUE #
          END
 
        END
 
#
*     CHECK THE VALUE OF *YF*.
#
 
      IF LBARG$YF[0] NQ 0            ##
        AND LBARG$YF[0] NQ O"7777"
      THEN
        BEGIN
        FLAG = XDXB(LBARG$YF[0],TYPE,TEMPR);
        IF FLAG NQ 0
        THEN                         # CONVERSION ERROR #
          BEGIN
          RETURN;
          END
 
        LBARG$YF[0] = TEMPR;         # RESET *YF* #
        END
 
      ELSE
        BEGIN
        IF LBARG$YF[0] EQ 0
        THEN                         # *YF* OMITTED #
          BEGIN
          LBARG$YF[0] = -1;          # SET DEFAULT VALUE #
          END
 
        END
 
#
*     CHECK THE VALUE OF *ZI*.
#
 
      IF LBARG$ZI[0] NQ 0 AND LBARG$ZI[0] NQ O"7777"
      THEN
        BEGIN
        FLAG = XDXB(LBARG$ZI[0],TYPE,TEMPR);
        IF FLAG NQ 0
        THEN                         # CONVERSION ERROR #
          BEGIN
          RETURN;
          END
 
        LBARG$ZI[0] = TEMPR;         # RESET *ZI* #
        END
 
      ELSE
        BEGIN
        IF LBARG$ZI[0] EQ 0
        THEN                         # *ZI* OMITTED #
          BEGIN
          LBARG$ZI[0] = -1;          # SET DEFAULT VALUE #
          END
 
        END
 
#
*     CHECK THE VALUE OF *ZF*.
#
 
      IF LBARG$ZF[0] NQ 0 AND LBARG$ZF[0] NQ O"7777"
      THEN
        BEGIN
        FLAG = XDXB(LBARG$ZF[0],TYPE,TEMPR);
        IF FLAG NQ 0
        THEN                         # CONVERSION ERROR #
          BEGIN
          RETURN;
          END
 
        LBARG$ZF[0] = TEMPR;         # RESET *ZF* #
        END
 
      ELSE
        BEGIN
        IF LBARG$ZF[0] EQ 0
        THEN                         # *ZF* OMITTED #
          BEGIN
          LBARG$ZF[0] = -1;          # SET DEFAULT VALUE #
          END
 
        END
 
#
*     CHECK THE VALUE OF *SB*.
#
 
      IF LBARG$SB[0] NQ 0
      THEN
        BEGIN
        FLAG = XDXB(LBARG$SB[0],TYPE,TEMPR);
        IF FLAG NQ 0
        THEN                         # CONVERSION ERROR #
          BEGIN
          RETURN;
          END
 
        LBARG$SB[0] = TEMPR;         # RESET *SB* #
        END
 
#
*     CHECK *CN* AND *PK*.
#
 
      IF LBARG$C[0] EQ 0 AND LBARG$PK[0] EQ 0
      THEN
        BEGIN
        LBARG$PK[0] = "P";
        END
 
#
*     CHECK *PT*.
#
 
      IF LBARG$PT[0] EQ 0
      THEN
        BEGIN
        LBARG$PT[0] = "P";
        END
 
#
*     CHECK *SM*.
#
 
      IF LBARG$SM[0] EQ 0
      THEN
        BEGIN
        LBARG$SM[0] = "A";
        END
 
      RETURN;
 
      END  # LBCONV #
 
    TERM
PROC LBERR((ERR$CODE));
# TITLE LBERR - *SSLABEL* ERROR PROCESSOR.                            #
 
      BEGIN  # LBERR #
 
#
**    LBERR - *SSLABEL* ERROR PROCESSOR.
*
*     THIS PROCEDURE DOES ERROR PROCESSING FOR *SSLABEL* IN
*     ACCORDANCE WITH THE VALUE OF THE ERROR CODE.
*
*     PROC LBERR((ERR$CODE))
*
*     ENTRY   ERR$CODE = STATUS ITEM INDICATING THE ERROR CODE.
*
*     EXIT    ERROR PROCESSING IS COMPLETED.  DEPENDING ON ERROR
*             TYPE, EITHER A RETURN OR AN ABORT OCCURS.
*
*     MESSAGES  SEE ARRAY *ERRMSG* FOR THE
*               DAYFILE MESSAGES.
*
*     NOTES   PROC *LBERR* IS A TABLE DRIVEN
*             ERROR PROCESSOR.  A TABLE HAS BEEN
*             PRESET WITH THE ERROR MESSAGES FOR THE
*             DIFFERENT ERROR CODES.  THE ERROR CODE
*             CORRESPONDS TO THE ORDINAL OF THE CORRE-
*             SPONDING ENTRY IN THE TABLE.  THE ACTION
*             TO BE TAKEN ON EACH ERROR CONDITION IS
*             PRESET AS STATUS VALUES INTO EACH ENTRY.
*             USING THE ERROR CODE THE CORRESPONDING
*             ENTRY IN THE TABLE IS FOUND AND THE ERROR
*             CONDITION IS PROCESSED BY USING A STATUS
*             SWITCH THAT CORRESPONDS TO THE STATUS
*             VALUES PRESET IN THE ENTRY.  THE MESSAGES
*             ARE PRINTED OUT IN THE DAYFILE AND ALSO
*             ON THE REPORT FILE IF ONE IS SPECIFIED.
#
 
      ITEM ERR$CODE   U;             # ERROR CODE #
 
#
****  PROC LBERR - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC MESSAGE;                # WRITES USER DAYFILE MESSAGE #
        PROC RESTPFP;                # RESTORE USER-S *PFP* AND ABORT
                                       OR RETURN #
        PROC RPCLOSE;                # CLOSES OUTPUT PRINT FILE #
        PROC RPLINE;                 # WRITES PRINT LINE FOR REPORT #
        PROC RPSPACE;                # WRITES BLANK LINE ON REPORT #
        FUNC XCDD  C(10);            # CONVERT ITEMS TO DISPLAY CODE #
        END
 
#
****  PROC LBERR - XREF LIST END.
#
 
      DEF PROCNAME #"LBERR."#;       # PROC NAME #
 
      STATUS ACTION                  # ERROR PROCESSING TO BE DONE #
        MSG,                         # DISPLAY ERROR MESSAGE #
        MSGDETL,                     # DISPLAY DETAIL ERROR MESSAGE #
        RETRN,                       # RETURN TO MAIN LOOP #
        ABRT,                        # ABORT SSLABEL #
        LSTACT;                      # END OF STATUS LIST #
 
      DEF LISTCON    #0#;            # DO NOT LIST THE COMDECKS #
*CALL COMBFAS
*CALL COMTERR
*CALL COMTLAB
*CALL COMTLBP
*CALL COMTOUT
 
      ITEM DIS$ASN    C(20);         # CUBES ASSIGNED (DISPLAY CODE) #
      ITEM DIS$ERR    C(20);         # ERROR CODE (DISPLAY CODE) #
      ITEM I          I;             # LOOP VARIABLE #
      ITEM STAT       U;             # ERROR TABLE ENTRY STATUS #
 
#
*     THIS ARRAY IS FOR DISPLAYING DETAILED MESSAGES.
#
 
      ARRAY DETAIL [0:0] P(5);       # FOR MESSAGES WITH DETAIL NO. #
        BEGIN
        ITEM DET$MSG1   C(00,00,40);  # ERROR MESSAGE #
        ITEM DET$NO     C(02,00,05);  # DETAIL NUMBER #
        ITEM DET$PRD    C(02,30,01);  # PERIOD AT END OF MESSAGE #
        ITEM DET$BLNK   C(02,36,14);  # BLANK FILL #
        ITEM DET$ZRO    U(04,00,60) = [0];  # ZERO BYTE TERMINATOR #
        END
 
#
*     THIS ARRAY IS FOR DISPLAYING DIRECTIVE NUMBERS.
#
 
      ARRAY DIRECTV [0:0] P(2);
        BEGIN
        ITEM DIR$MSG    C(00,00,11) = [" DIRECTIVE "];
        ITEM DIR$NO     C(01,06,03);  # DIRECTIVE NUMBER #
        ITEM DIR$PRD    C(01,24,01);  # ENDING PERIOD #
        ITEM DIRZRO     U(01,30,30) = [0];  # ZERO BYTE #
        END
 
#
*     ARRAY ERRMSG IS AN ERROR TABLE IN WHICH THE ORDINAL OF EACH
*     ENTRY IS EQUAL TO THE ERROR CODE IT REPRESENTS.  EACH ENTRY
*     CONTAINS THE APPROPRIATE ERROR MESSAGE AND THE STATUS VALUES
*     WHICH CONTROL ERROR PROCESSING.
#
 
      ARRAY ERRMSG [0:CODEMAX] S(6);
        BEGIN
        ITEM ERRMSSG    C(00,00,40) = [  # MESSAGE ENTRY TO BE
                                           DISPLAYED #
        " CATALOG/MAP ATTACH PROBLEM.",
        " SYNTAX ERROR IN DIRECTIVE.",
        " SYNTAX ERROR - SSLABEL ABORT.",
        " CSN NOT FOUND IN SMMAP.",
        " NO EMPTY CUBE IN FAMILY/POOL.",
        " NO CARTRIDGE AVAILABLE IN POOL.",
        " NO EMPTY CARTRIDGES AVAILABLE IN FAMILY.",
        " NO MANUFACTURER OR SCRATCH LABEL.",
        " UNEXPECTED SM, Y, Z, FAMILY OR SUBFAM.",
        " CANNOT FIX CSN FOR GOOD LABEL.",
        " UNRECOVERABLE READ ERROR.",
        " UNRECOVERABLE WRITE ERROR.",
        " EXCESSIVE PARITY ERRORS.",
        " CSN ALREADY IN SMMAP.",
        " CARTRIDGE ALREADY IN CUBE.",
        " CARTRIDGE LABEL ERROR.",
        " CARTRIDGE ALREADY IN USE.",
        " STORAGE MODULE IS TURNED OFF.",
        " CARTRIDGE NOT FOUND.",
        " CARTRIDGE NOT EMPTY.",
        " M860 HARDWARE PROBLEM.",
        " CATALOG/MAP FILE INTERLOCKED.",
        " NO SUCH SMMAP OR SUBCATALOG.",
        " CATALOG/MAP NOT OPEN.",
        " CATALOG LOST BIT MUST BE SET.",
        " CARTRIDGE PRESENT--LOST BIT SET.",
        " SUB ALREADY DEFINED.",
        " CUBES ASSIGNED TO SUB-FAMILY.",
        " INSUFFICIENT CUBES.",
        " SELECTED CUBE NOT UNASSIGNED.",
        " NO EMPTY CUBES.",
        " SELECTED CUBE NOT EMPTY.",
        " SELECTED CUBE NOT ASSIGNED AS EXPECTED.",
        " CARTRIDGE NOT ASSIGNED AS EXPECTED.",
        " UNRECOGNIZABLE LABEL.",
        " NO MATCH ON FAMILY/SUBFAMILY.",
        " INCORRECT CSN.",
        " ADDCUBE - ONLY 100 LOCATIONS PROCESSED.",
        " INCORRECT N.",
        " CSN OPTION VIOLATED.",
        " PK,PT OPTION VIOLATED.",
        " LT OPTION NOT SPECIFIED CORRECTLY.",
        " INCORRECT SM NUMBER.",
        " Y,Z OPTION VIOLATED.",
        " INCORRECT SUBFAMILY.",
        " ON,OF NOT SPECIFIED CORRECTLY.",
        " INCORRECT DIRECTIVE.",
        " GR PARAMETER USED INCORRECTLY.",
        " GR PARAMETER OUT OF RANGE.",
        " B PARAMETER USED INCORRECTLY.",
        " B PARAMETER OUT OF RANGE.",
        " NO EMPTY CARTRIDGES IN GROUP." ];
        ITEM ERRZERO    U(04,00,60) = [0,
        CODEMAX(0)];
        ITEM ERRSTATW   U(05,00,60);  # PROCESSING TO BE DONE #
 
#
*     TYPE OF MESSAGE TO BE PRINTED.
#
 
        ITEM ERRSTAT1   S:ACTION (05,00,06) = [  4(S"MSG"),
        3(S"MSGDETL"),
        11(S"MSG"),
        1(S"MSGDETL"),
        9(S"MSG"),
        5(S"MSGDETL"),
        15(S"MSG"),
        5(S"MSGDETL") ];
 
#
*     ACTION TO BE TAKEN AFTER PRINTING MESSAGE.
#
 
        ITEM ERRSTAT2   S:ACTION (05,06,06) = [   S"ABRT",
        S"RETRN",
        35(S"ABRT"),
        15(S"RETRN"),
        1(S"ABRT") ];
        END
 
#
*     ARRAY TO PRINT DAYFILE MESSAGE.
#
 
      ARRAY MSGBUF [0:0] P(3);
        BEGIN
        ITEM MSG$ID     C(00,00,15) = [" SSLABEL ERROR "];
        ITEM MSG$NO     C(01,30,03);  # ERROR NUMBER DISPLAYED #
        ITEM MSGPRD     C(01,48,01) = ["."];
        ITEM MSGZERO    U(02,48,12) = [0];  # ZERO BYTE TERMINATOR #
        END
 
      SWITCH ACT: ACTION             # TYPE OF ERROR PROCESSING #
          REPORT: MSG,               # DISPLAY ERROR MESSAGE #
        DETL$RPT: MSGDETL,           # DISPLAY DETAIL ERROR MESSAGE #
           RTURN: RETRN,             # RETURN TO MAIN LOOP #
             ABT: ABRT;              # ABORT *SSLABEL* #
 
                                               CONTROL EJECT;
 
#
*     CHECK FOR LEGAL ERROR CODE.
#
 
      IF ERR$CODE LS 0 OR ERR$CODE GR CODEMAX
      THEN                           # ERROR CODE OUT OF RANGE #
        BEGIN
        LBMSG$PROC[0] = PROCNAME;
        MESSAGE(LBMSG[0],SYSUDF1);
        RESTPFP(PFP$ABORT);          # RESTORE USER-S *PFP* AND ABORT #
        END
 
      DIR$NO[0] = LBARG$DIRN[0];
      DIR$PRD = ".";
      DIS$ERR = XCDD(ERR$CODE);
      MSG$NO[0] = C<7,3>DIS$ERR;
 
#
*     BEAD OUT STATUS VALUES FROM ERROR CODE ENTRY, AND DO
*     CORRESPONDING PROCESSING.
#
 
      SLOWFOR I = 0 STEP 6 UNTIL 12
      DO
        BEGIN
        STAT = B<I,6>ERRSTATW[ERR$CODE];
        GOTO ACT[STAT];
 
REPORT:                              # REPORT THE ERROR #
        MESSAGE(ERRMSG[ERR$CODE],SYSUDF1);
        IF ERR$CODE NQ ERRLIST"SYNTX$ABRT"
        THEN
          BEGIN
          MESSAGE(MSGBUF[0],UDFL1);
          MESSAGE(DIRECTV[0],UDFL1);
          RPLINE(OUT$FETP,"*** ERROR",2,9,1);
          RPLINE(OUT$FETP,MSG$NO[0],12,3,1);
          RPLINE(OUT$FETP,"DIRECTIVE",19,9,1);
          RPLINE(OUT$FETP,DIR$NO[0],29,3,0);
          RPLINE(OUT$FETP,ERRMSSG[ERR$CODE],18,40,1);
          RPLINE(OUT$FETP,"***",58,3,0);
          RPSPACE(OUT$FETP,SP"SPACE",1);
          END
 
        TEST I;
 
DETL$RPT:                            # REPORT THE ERROR IN DETAIL #
        DIS$ASN = XCDD(NUMDONE);
        DET$MSG1[0] = ERRMSSG[ERR$CODE];
        MESSAGE(MSGBUF[0],UDFL1);
        MESSAGE(DIRECTV[0],UDFL1);
        MESSAGE(DETAIL[0],SYSUDF1);
        DET$MSG1[0] = " NUMBER PROCESSED = ";
        DET$BLNK[0] = " ";
        DET$NO[0] = C<5,5>DIS$ASN;
        DET$PRD[0] = ".";            # ADD PERIOD TO END OF MESSAGE #
        MESSAGE(DETAIL,SYSUDF1);
        RPLINE(OUT$FETP,"*** ERROR",2,9,1);
        RPLINE(OUT$FETP,MSG$NO[0],12,3,1);
        RPLINE(OUT$FETP,"DIRECTIVE",19,9,1);
        RPLINE(OUT$FETP,DIR$NO[0],29,3,0);
        RPLINE(OUT$FETP,ERRMSSG[ERR$CODE],18,40,0);
        RPLINE(OUT$FETP,"NUMBER PROCESSED = ",19,19,1);
        RPLINE(OUT$FETP,DET$NO[0],38,5,1);
        RPLINE(OUT$FETP,"***",45,3,0);
        RPSPACE(OUT$FETP,SP"SPACE",1);
        TEST I;
 
RTURN:                               # RETURN TO CALLING PROC #
        RETURN;
 
ABT:                                 # ABORT PROCESSING #
        RPCLOSE(OUT$FETP);
        RESTPFP(PFP$ABORT);          # RESTORE USER-S *PFP* AND ABORT #
        END
 
      END  # LBERR #
 
    TERM
PROC LBFLMSC;
# TITLE LBFLMSC - MODIFIES THE *INHIBIT* FLAG IN THE FCT.             #
 
      BEGIN  # LBFLMSC #
 
#
**    LBFLMSC - MODIFIES THE *INHIBIT* FLAG IN THE FCT.
*
*     THIS PROC UPDATES THE *INHIBIT* FLAG IN THE FCT ENTRY
*     CORRESPONDING TO THE CSN SPECIFIED.
*
*     PROC LBFLMSC.
*
*     ENTRY      CRACKED AND SYNTAX CHECKED DIRECTIVE
*                PARAMETERS SET UP IN COMMON AREA DEFINED
*                IN *COMTLBP*.
*
*     EXIT       *INHIBIT* FLAG UPDATED OR ERROR CONDITION.
*
*     NOTES      PROC *LBFLMSC* SEARCHES THE SMMAP FOR AN ENTRY
*                WITH A CSN MATCHING THAT SPECIFIED.  IF THIS IS
*                FOUND AND IT IS ASSIGNED TO A FAMILY, THEN THE
*                *INHIBIT* FLAG IN THE CORRESPONDING *FCT* ENTRY
*                OR THE FREE CARTRIDGE FLAG IN THE *FCT* IS
*                MODIFIED.  IF *ON* IS SPECIFIED THE FLAG IS SET,
*                AND IF *OFF* IS SPECIFIED THE FLAG IS CLEARED.
#
 
#
****  PROC LBFLMSC - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC CALL3;                  # ISSUES TYPE 3 CALLSS TO EXEC #
        PROC LBERR;                  # *SSLABEL* ERROR PROCESSOR #
        PROC LBRESP;                 # RESPONSE CODE PROCESSOR #
        PROC SERCSU;                 # SEARCHES THE SMMAP #
        END
 
#
****  PROC LBFLMSC - XREF LIST END.
#
 
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS #
*CALL COMBFAS
*CALL COMBCPR
*CALL COMBMAP
*CALL COMTERR
*CALL COMTLAB
*CALL COMTLBP
 
      ITEM CATFLD     U;             # CATALOG FIELD #
      ITEM CATVALUE   I;             # CATALOG VALUE #
      ITEM FLAG       I;             # ERROR FLAG #
      ITEM REQCODE    U;             # REQUEST CODE #
      ITEM RESP$CODE  U;             # RESPONSE CODE FROM EXEC #
      ITEM SERTYPE    S:SERCH$TYPE;  # SEARCH TYPE #
      ITEM SP$VSN     C(12);         # SPECIFIED CSN #
 
 
      ARRAY PT$CSU$ENT [0:0] P(5);   # *PUT* SMMAP ENTRY #
        BEGIN
        ITEM PT$MAPENT  C(00,00,30);  # THREE WORD MAP ENTRY #
        ITEM PT$Y       U(03,00,30);  # Y COORDINATE #
        ITEM PT$Z       U(03,30,30);  # Z COORDINATE #
        ITEM PT$GR      U(04,00,07);  # GROUP #
        ITEM PT$GRT     U(04,07,04);  # GROUP ORDINAL #
        END
 
 
                                               CONTROL EJECT;
 
      SERTYPE = S"CSN$MATCH";
      SP$VSN = LBARG$C[0];
 
#
*     SEARCH FOR MATCHING VSN.
#
 
      SERCSU(SERTYPE,0,0,0,SP$VSN,0,0,PT$CSU$ENT[0],FLAG);
      IF FLAG NQ 0
      THEN                           # VSN NOT FOUND #
        BEGIN
        ERRCODE = S"CSN$NOTFND";
        LBERR(ERRCODE);              # DO ERROR PROCESSING #
        RETURN;
        END
 
#
*     CHECK CARTRIDGE ASSIGNMENT.
#
 
      P<SMUMAP> = LOC(PT$CSU$ENT[0]);
      IF CM$CODE NQ CUBSTAT"SUBFAM"
      THEN                           # NOT ASSIGNED TO FAMILY #
        BEGIN
        ERRCODE = S"UNX$CR$ASN";
        LBERR(ERRCODE);              # DO ERROR PROCESSING #
        RETURN;
        END
 
#
*     ISSUE A REQUEST TO EXEC TO UPDATE THE CATALOG *INHIBIT* FLAG.
#
 
      IF LBARG$ON[0] NQ 0
      THEN                           # *ON* SPECIFIED #
        BEGIN
        CATVALUE = 1;
        END
 
      ELSE
        BEGIN
        IF LBARG$OF[0] NQ 0
        THEN                         # *OFF* SPECIFIED #
          BEGIN
          CATVALUE = 0;
          END
 
        END
 
      REQCODE = REQTYP3"UPD$CAT";
      IF LBARG$OP[0] EQ "FC"
      THEN                           # FREE CARTRIDGE #
        BEGIN
        CATFLD = UCF"FREEFL";
        END
 
      ELSE                           # INHIBIT ALLOCATION #
        BEGIN
        CATFLD = UCF"INHIB";
        END
 
 
#
*     UPDATE CATALOG.
#
 
      CALL3(REQCODE,PT$CSU$ENT[0],CATFLD,CATVALUE,RESP$CODE);
      IF RESP$CODE NQ RESPTYP3"OK3"
      THEN                           # UPDATE UNSUCCESSFUL #
        BEGIN
        LBRESP(RESP$CODE,TYP"TYP3");
        END
 
      RETURN;
 
      END  # LBFLMSC #
 
    TERM
PROC LBFXVSN;
# TITLE LBFXVSN - REPLACES LABEL WITH SCRATCH LABEL.                  #
 
      BEGIN  # LBFXVSN #
 
#
**    LBFXVSN - REPLACES LABEL WITH A SCRATCH LABEL.
*
*     THIS PROC GETS A CARTRIDGE FROM THE INPUT DRAWER, WRITES A
*     SCRATCH LABEL ON IT, AND ADDS IT TO THE POOL.
*
*     PROC LBFXVSN.
*
*     ENTRY     CRACKED AND SYNTAX CHECKED DIRECTIVE
*               PARAMETERS SET UP IN COMMON AREA DEFINED
*               IN *COMTLBP*.
*
*     EXIT      CARTRIDGE IN SCRATCH POOL OR ERROR CONDITION.
*
*     NOTES     PROC *LBFXVSN* VERIFIES THE PRESENCE OF A CARTRIDGE
*               IN THE INPUT DRAWER, AND SEARCHES FOR AN
*               EMPTY CUBE IN THE POOL.  EXEC IS CALLED TO BRING
*               THE CARTRIDGE TO A DRIVE AND READ ITS LABEL.  IF
*               THE LABEL TYPE AGREES WITH THAT SPECIFIED, A NEW
*               SCRATCH LABEL IS WRITTEN AND THE CARTRIDGE IS ADDED
*               TO THE POOL.
#
 
#
****  PROC LBFXVSN - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC CALL3;                  # ISSUES TYPE 3 CALLSS TO EXEC #
        PROC CALL4;                  # ISSUES TYPE 4 CALLSS TO EXEC #
        PROC CKLAB;                  # CHECKS CARTRIDGE LABEL TYPE #
        PROC CONVSN;                 # CONVERTS VSN FROM EBCDIC TO
                                       DISPLAY CODE #
        PROC DCEBC;                  # CONVERTS DISPLAY TO EBCDIC #
        PROC DLABFLD;                # DISPLAY LABEL FIELDS #
        PROC GENLAB;                 # GENERATES A NEW LABEL #
        PROC LBERR;                  # *SSLABEL* ERROR PROCESSOR #
        PROC LBRESP;                 # RESPONSE CODE PROCESSOR #
        PROC SERCSU;                 # SEARCHES THE SMMAP #
        END
 
#
****  PROC LBFXVSN - XREF LIST END.
#
 
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS #
*CALL COMBFAS
*CALL COMBCPR
*CALL COMBLBL
*CALL COMBMAP
*CALL COMTERR
*CALL COMTLAB
*CALL COMTLBP
 
      ITEM CART$CSN   C(20);         # CARTRIDGE SERIAL NUMBER #
      ITEM CONFLAG    B;             # CONVERSION FLAG #
      ITEM DC$VSN     C(8);          # *CSN* IN DISPLAY CODE #
      ITEM ERR$CNT    I;             # ERROR COUNT #
      ITEM FLAG       I;             # ERROR FLAG #
      ITEM HR$ERR     I;             # HARD READ ERRORS #
      ITEM I          I;             # LOOP VARIABLE #
      ITEM LAB$TYPE   S:LABTYPE;     # LABEL TYPE #
      ITEM LD$CNT     I;             # LOAD COUNT #
      ITEM LD$ERR     I;             # LOAD ERRORS #
      ITEM PS$CNT     I;             # PASS COUNT #
      ITEM REQCODE    I;             # REQUEST CODE #
      ITEM RESP$CODE  I;             # RESPONSE CODE #
      ITEM SERTYPE    S:SERCH$TYPE;  # SEARCH TYPE #
      ITEM SP$CODE    I;             # SPECIFIED CODE #
      ITEM SP$FAM     C(7);          # SPECIFIED FAMILY #
      ITEM SP$SUB     I;             # SUBFAMILY #
      ITEM SP$VSN     C(8);          # SPECIFIED CARTRIDGE *CSND* #
      ITEM SP$Y       I;             # SPECIFIED Y COORDINATE #
      ITEM SP$Z       I;             # SPECIFIED Z COORDINATE #
      ITEM SR$ERR     I;             # SOFT READ ERRORS #
      ITEM STR$RD     I;             # STRIPES READ #
      ITEM STR$WR     I;             # STRIPES WRITTEN #
      ITEM STR$DM     I;             # STRIPES DEMARKED #
      ITEM SW$ERR     I;             # SOFT WRITE ERRORS #
      ITEM TEMP$VSN C(8);               # TEMPORARY *CSN* #
 
 
      ARRAY PT$CSU$ENT [0:0] P(5);   # *PUT* SMMAP ENTRY #
        BEGIN
        ITEM PT$MAPENT  C(00,00,30);  # THREE WORD MAP ENTRY #
        ITEM PT$Y       U(03,00,30);  # Y COORDINATE #
        ITEM PT$Z       U(03,30,30);  # Z COORDINATE #
        ITEM PT$GR      U(04,00,07);  # GROUP #
        ITEM PT$GRT     U(04,07,04);  # GROUP ORDINAL #
        END
 
 
                                               CONTROL EJECT;
 
#
*     CHECK IF SPECIFIED *CSN* IS ALREADY IN MAP.
#
 
      SERTYPE = S"CSN$MATCH";        # SEARCH FOR *CSN* #
      SERCSU(SERTYPE,0,0,0,LBARG$C[0],0,0,PT$CSU$ENT[0],FLAG);
      IF FLAG EQ 0                   # *CSN* ALREADY IN MAP #
      THEN
        BEGIN
        ERRCODE = S"DUPL$CSN";
        LBERR(ERRCODE);
        RETURN;
        END
 
 
#
*     CHECK THAT CARTRIDGE IS PRESENT IN INPUT DRAWER AND SEARCH
*     SMMAP FOR EMPTY CUBE IN THE POOL.
#
 
      SERTYPE = S"ASSIGN";
      SP$CODE = CUBSTAT"SCRPOOL";
      SP$FAM = " ";
      SP$SUB = 0;
      SP$VSN = " ";
      SERCSU(SERTYPE,0,0,SP$CODE,SP$VSN,SP$FAM,SP$SUB,PT$CSU$ENT[0],
        FLAG);
      IF FLAG NQ 0
      THEN                           # NO EMPTY CUBE IN POOL #
        BEGIN
        ERRCODE = S"NO$EMPCBFP";
        LBERR(ERRCODE);              # DO ERROR PROCESSING #
        RETURN;
        END
 
#
*     LOAD CARTRIDGE FROM INPUT DRAWER.
#
 
      SP$Y = 14;
      SP$Z = 0;
      REQCODE = REQTYP4"LOAD$CART";
      CALL4(REQCODE,DRD$NUM,0,SP$Y,SP$Z,RESP$CODE);
      IF RESP$CODE NQ 0
      THEN                           # *LOAD* FAILS #
        BEGIN
        LBRESP(RESP$CODE,TYP"TYP4");
        RETURN;
        END
 
      DRD$NUM = CPR$DRD[0];          # TRANSPORT ID #
 
 
      P<LABEL$CART> = OLDLABP;
      CKLAB(LAB$TYPE);               # CHECK LABEL TYPE #
      IF LAB$TYPE EQ S"UNR$LAB"
      THEN
        BEGIN  # UNRECOGNIZABLE LABEL #
        IF LBARG$ZFM[0] EQ 0
        THEN                         # FAMILY NOT SPECIFIED #
          BEGIN
          LD$CNT = 0;
          SW$ERR = 0;
          SR$ERR = 0;
          HR$ERR = 0;
          STR$RD = 0;
          STR$WR = 0;
          STR$DM = 0;
          END
 
        ELSE                         # FAMILY SPECIFIED #
          BEGIN
          REQCODE = REQTYP4"UNLD$CART";
          CALL4(REQCODE,0,0,SM$EXIT$TY,SM$TY$Z,RESP$CODE);
          IF RESP$CODE NQ RESPTYP4"OK4"
          THEN
            BEGIN
            LBRESP(RESP$CODE,TYP"TYP4");
            RETURN;
            END
 
          ERRCODE = S"UNREC$LAB";
          LBERR(ERRCODE);
          RETURN;
          END
 
        END  # UNRECOGNIZABLE LABEL #
 
      ELSE
        BEGIN  # RECOGNIZABLE LABEL #
        IF LBARG$ZFM[0] NQ 0
        THEN
          BEGIN  # FAMILY SPECIFIED #
          IF LAB$TYPE EQ S"FAM$LAB" AND LAB$FMLY[0] EQ LBARG$FM[0] AND
            LAB$SF[0] EQ LBARG$SB[0]
          THEN                       # MATCHING FAMILY LABEL #
            BEGIN
            LD$CNT = LAB$CRLD[0];
            LD$ERR = LAB$LDER[0];
            SR$ERR = LAB$SRDE[0];
            SW$ERR = LAB$SWRE1[0];
            B<28,4>SW$ERR = LAB$SWRE[0];
            HR$ERR = LAB$HRDE[0];
            STR$RD = LAB$STRD[0];
            STR$WR = LAB$STWR1[0];
            B<36,24>STR$WR = LAB$STWR[0];
            STR$DM = LAB$STDM[0];
            END
 
          ELSE                       # NO MATCHING FAMILY LABEL #
            BEGIN
            DLABFLD;                 # DISPLAY LABEL FIELDS #
            REQCODE = REQTYP4"UNLD$CART";
            CALL4(REQCODE,0,0,SM$EXIT$TY,SM$TY$Z,RESP$CODE);
            IF RESP$CODE NQ RESPTYP4"OK4"
            THEN
              BEGIN
              LBRESP(RESP$CODE,TYP"TYP4");
              RETURN;
              END
 
            ERRCODE = S"NO$FAMLAB";
            LBERR(ERRCODE);
            RETURN;
            END
 
          END  # FAMILY SPECIFIED #
 
        ELSE
          BEGIN  # FAMILY NOT SPECIFIED #
          IF LAB$TYPE EQ S"SCR$LAB"
          THEN                       # SCRATCH LABEL #
            BEGIN
            LD$CNT = LAB$CRLD[0];
            LD$ERR = LAB$LDER[0];
            SR$ERR = LAB$SRDE[0];
            SW$ERR = LAB$SWRE1[0];
            B<28,4>SW$ERR = LAB$SWRE[0];
            HR$ERR = LAB$HRDE[0];
            STR$RD = LAB$STRD[0];
            STR$WR = LAB$STWR1[0];
            B<36,24>STR$WR = LAB$STWR[0];
            STR$DM = LAB$STDM[0];
            END
 
          ELSE                       # FAMILY LABEL #
            BEGIN
            REQCODE = REQTYP4"UNLD$CART";
            CALL4(REQCODE,0,0,SM$EXIT$TY,SM$TY$Z,RESP$CODE);
            IF RESP$CODE NQ RESPTYP4"OK4"
            THEN
              BEGIN
              LBRESP(RESP$CODE,TYP"TYP4");
              RETURN;
              END
 
            DLABFLD;
            ERRCODE = S"GOOD$LAB";
            LBERR(ERRCODE);
            RETURN;
            END
 
          END  # FAMILY NOT SPECIFIED #
 
        END  # RECOGNIZABLE LABEL #
 
      LAB$TYPE = S"FAM$LAB";
 
 
#
*     CHECK *CSN* PARAMETER FOR MATCH.
#
 
      CONVSN(TEMP$VSN,1,CONFLAG);
      IF LBARG$C[0] NQ TEMP$VSN
      THEN                  # NO MATCH OF *CSN* #
        BEGIN
        ERRCODE = S"ILLEG$C";
        LBERR(ERRCODE);
        RETURN;
        END
 
#
*     CONVERT VSN FROM DISPLAY CODE TO EBCDIC.
#
 
      DC$VSN = LBARG$C[0];
      CONVSN(DC$VSN,0,CONFLAG);
      IF CONFLAG
      THEN                           # ILLEGAL CDC CHARACTER #
        BEGIN
        ERRCODE = S"ILLEG$C";
        LBERR(ERRCODE);
        RETURN;
        END
 
#
*     GENERATE NEW LABEL.
#
 
      LAB$TYPE = S"SCR$LAB";
      GENLAB(LAB$TYPE,PT$CSU$ENT[0],LD$CNT,LD$ERR, SR$ERR,SW$ERR,
        HR$ERR);
      IF LBARG$CM[0] NQ IBMCART
      THEN                           # CARTRIDGE NOT IBM #
        BEGIN
        LAB$CCOD[0] = OTHCART;
        END
 
      ELSE
        BEGIN
        LAB$CCOD[0] = IBMCART;
        END
 
      IF LBARG$CM[0] EQ IBMCART
      THEN                           # WRITE IBM ON CARTRIDGE #
        BEGIN
        B<0,32>LAB$CSN[0] = O"31160552100";
        END
 
                                     # NOTE: IF CM EQ B- THEN DO
                                       CONVERSION #
      REQCODE = REQTYP4"WRT$LAB";
      CALL4(REQCODE,DRD$NUM,CART$CSN,PT$Y[0],PT$Z[0],RESP$CODE);
      IF RESP$CODE NQ RESPTYP4"OK4"
      THEN                           # WRITE FAILS #
        BEGIN
        LBRESP(RESP$CODE,TYP"TYP4");
        RETURN;
        END
 
#
*     UPDATE SMMAP TO ADD CARTRIDGE TO POOL.
#
 
      REQCODE = REQTYP3"UPD$MAP";
      P<SMUMAP> = LOC(PT$CSU$ENT[0]);
      CM$CSND[0] = LBARG$C[0];
      CM$CCOD[0] = LAB$CCOD;
      CALL3(REQCODE,PT$CSU$ENT[0],0,0,RESP$CODE);
      IF RESP$CODE NQ RESPTYP3"OK3"
      THEN                           # UPDATE FAILS #
        BEGIN
        LBRESP(RESP$CODE,TYP"TYP3");
        RETURN;
        END
 
                                     # WHICH ERROR CODE #
      IF RESP$CODE NQ RESPTYP4"OK4"
      THEN                           # PUT FAILS #
        BEGIN
        LBRESP(RESP$CODE,TYP"TYP4");
        END
 
      RETURN;
 
      END  # LBFXVSN #
 
    TERM
PROC LBHEAD((FETP));
# TITLE LBHEAD - WRITES HEADER LINE ON OUTPUT FILE.                   #
 
      BEGIN  # LBHEAD #
 
#
**    LBHEAD - WRITES HEADER LINE ON OUTPUT FILE.
*
*     PROC LBHEAD((FETP))
*
*     ENTRY    FETP, AN ITEM CONTAINING THE FWA OF THE FET.
*
*     EXIT     HEADER WRITTEN ON OUTPUT FILE.
*
*     NOTES    THE REPORT FORMATTER IS USED TO
*              PRINT THE HEADER LINES.
#
 
      ITEM FETP       I;             # FWA OF THE FET #
 
#
****  PROC LBHEAD - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC RPLINEX;                # PRINTS A REPORT LINE #
        END
 
#
****  PROC LBHEAD - XREF LIST END.
#
 
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS #
*CALL COMBFAS
*CALL COMTOUT
 
                                               CONTROL EJECT;
 
#
*     PRINT HEADER LINE.
#
 
      RPLINEX(FETP,"SSLABEL REPORT FILE",2,19,0);
      RPLINEX(FETP," ",1,1,0);       # WRITE A BLANK LINE #
      RETURN;
 
      END  # LBHEAD #
 
    TERM
PROC LBLOOP((ARGLIST),ERRFLAG);
# TITLE LBLOOP - CRACK AND SYNTAX CHECK *SSLABEL* DIRECTIVES.         #
 
      BEGIN  # LBLOOP #
 
#
**    LBLOOP - CRACK AND SYNTAX CHECK *SSLABEL* DIRECTIVES.
*
*     THIS PROCEDURE CRACKS AND SYNTAX CHECKS THE
*     PARAMETERS SPECIFIED ON *SSLABEL* DIRECTIVE
*     CALL.
*
*     PROC LBLOOP((ARGLIST),ERRFLAG)
*
*     ENTRY     ARGLIST, AN ITEM CONTAINING THE ADDRESS
*                        OF THE ARGUMENT LIST FOR *SSLABEL*.
*
*     EXIT      ALL THE DIRECTIVES CRACKED, SYNTAX CHECKED
*               AND WRITTEN ON A TEMPORARY FILE.
*               ERRFLAG, AN ITEM CONTAINING THE ERROR STATUS.
*                        FALSE, NO ERROR.
*                        TRUE, SYNTAX ERROR IN ONE OR MORE DIRECTIVES.
*
*     MESSAGES  SSLABEL - NO DIRECTIVES.
*
*     NOTES     PROC *LBLOOP* SETS UP A LOOP TO READ IN EACH
*               DIRECTIVE, CRACK THE DIRECTIVE, CONVERT THE CRACKED
*               PARAMETERS FROM DISPLAY CODE TO INTEGER VALUE
*               AND TO CHECK FOR THE VALID OPTIONS ON THE
*               DIRECTIVE CALL.  THE CRACKED PARAMETERS ARE
*               RETURNED IN THE COMMON AREA *ULBPCOM* AND
*               AFTER CONVERSION ARE PLACED BACK IN THE
*               SAME LOCATIONS.  IF AN ERROR IS ENCOUNTERED
*               WITH THE DIRECTIVE, A DIRECTIVE ERROR FLAG
*               IS SET UP.  THE DIRECTIVE ALONG WITH THE
*               CRACKED AND CONVERTED PARAMETERS, DIRECTIVE
*               NUMBER AND THE DIRECTIVE ERROR STATUS FLAG
*               IS WRITTEN TO A TEMPORARY FILE.  THE TEMPORARY
*               FILE HAS THE FOLLOWING FORMAT.
*               EACH DIRECTIVE HAS ITS IMAGE, NUMBER AND
*               ERROR STATUS AND THE CRACKED PARAMETERS
*               WRITTEN ON TO IT.  IT CONSISTS OF
*               ONE LOGICAL RECORD FOLLOWED BY AN EOR.
*               A SYNTAX ERROR IS RETURNED TO THE CALLING
*               PROCEDURE IF AN ERROR IS ENCOUNTERED WITH
*               ANY DIRECTIVE.
#
 
      ITEM ARGLIST    I;             # ADDRESS OF ARGUMENT LIST #
      ITEM ERRFLAG    B;             # ERROR FLAG #
 
#
****  PROC LBLOOP - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC BZFILL;                 # BLANK OR ZERO FILLS A BUFFER #
        PROC LBCONV;                 # CONVERT PARAMETERS TO INTEGERS #
        PROC LBERR;                  # *SSLABEL* ERROR PROCESSOR #
        PROC LBOPT;                  # CHECKS FOR VALID OPTIONS #
        PROC LOFPROC;                # LIST OF FILES PROCESSOR #
        PROC MESSAGE;                # DISPLAYS MESSAGES #
        PROC READC;                  # READS IN A CODED LINE #
        PROC RESTPFP;                # RESTORE USER-S *PFP* AND ABORT
                                       OR RETURN #
        PROC RETERN;                 # RETURNS A FILE #
        PROC REWIND;                 # REWINDS A FILE #
        PROC RPLINE;                 # PRINTS A REPORT LINE #
        PROC RPSPACE;                # PRINTS A BLANK LINE #
        PROC WRITER;                 # WRITES EOR ON A FILE #
        PROC WRITEW;                 # DATA TRANSFER ROUTINE #
        PROC XARG;                   # CRACK PARAMETER LIST #
        FUNC XCDD C(10);             # CONVERT INTEGERS TO DISPLAY #
        PROC ZFILL;                  # ZERO FILLS A BUFFER #
        PROC ZSETFET;                # SETS UP A CIO FET #
        END
 
#
****  PROC LBLOOP - XREF LIST END.
#
 
      DEF WBUFL #8#;                 # LENGTH OF WORKING BUFFER #
 
      DEF LISTCON    #0#;            # DO NOT LIST THE COMDECKS #
*CALL COMBFAS
*CALL COMBBZF
*CALL COMTERR
*CALL COMTLAB
*CALL COMTLBP
*CALL COMTOUT
 
      ITEM BUFP       I;             # FIRST WORD ADDRESS OF BUFFER #
      ITEM COMMENT    B = FALSE;     # INDICATES A COMMENT #
      ITEM DIRNUM     I;             # DIRECTIVE NUMBER #
      ITEM EOR        B = FALSE;     # EOR STATUS ON A FILE #
      ITEM FETP       I;             # FIRST WORD ADDRESS OF FET #
      ITEM FLAG       I;             # ERROR FLAG #
      ITEM TEMP       C(10);         # TEMPORARY ITEM #
 
      ARRAY LBIN$WBUF [0:0] S(WBUFL);  # WORKING BUFFER #
        BEGIN
        ITEM LBINW$DIR  C(00,00,80);  # *SSLABEL* DIRECTIVE IMAGE #
        END
 
                                               CONTROL EJECT;
 
      DIRNUM = 0;                    # INITIALIZE DIRECTIVE NUMBER #
 
#
*     SET UP FET FOR TEMPORARY FILE.
#
 
      FETP = LOC(SCR$FET[0]);
      BUFP = LOC(SCR$BUF[0]);
      ZSETFET(FETP,SCR,BUFP,BUFL,SFETL);
      LOFPROC(SCR);                  # ADD LFN TO LIST OF FILES #
 
#
*     SET UP A LOOP TO
*     1. READ A DIRECTIVE.
*     2. CRACK THE DIRECTIVE.
*     3. CONVERT PARAMETERS.
*     4. CHECK FOR VALID OPTIONS.
*     5. WRITE THE DIRECTIVE TO A TEMPORARY FILE.
#
 
      RETERN(SCR$FET[0],RCL);        # RETURN THE TEMPORARY FILE #
 
      FASTFOR DUMMY = 0 STEP 1 WHILE NOT EOR
      DO
        BEGIN  # CRACK AND SYNTAX CHECK DIRECTIVES #
        ZFILL(LBIN$WBUF[0],WBUFL);   # ZERO FILL WORKING BUFFER #
        READC(LBIN$FET[0],LBIN$WBUF[0],WBUFL,FLAG);
        IF FLAG NQ 0
        THEN                         # NO MORE DIRECTIVES #
          BEGIN
          EOR = TRUE;
          TEST DUMMY;
          END
 
#
*     CHECK FOR A COMMENT.
#
 
        IF C<0,1>LBINW$DIR[0] EQ "*"
        THEN                         # A COMMENT #
          BEGIN
          COMMENT = TRUE;
          TEMP = " ";
          END
 
        ELSE                         # A DIRECTIVE #
          BEGIN
          COMMENT = FALSE;
          DIRNUM = DIRNUM + 1;
          TEMP = XCDD(DIRNUM);       # WRITE DIRECTIVE NUMBER #
          TEMP = C<7,3>TEMP;
          END
 
#
*     WRITE THE DIRECTIVE NUMBER AND THE DIRECTIVE
*     IMAGE TO THE OUTPUT FILE.
#
 
        BZFILL(LBIN$WBUF[0],TYPFILL"BFILL",80);
        RPLINE(OUT$FETP,TEMP,2,5,1);
        RPLINE(OUT$FETP,LBINW$DIR[0],8,80,0);
        RPSPACE(OUT$FETP,SP"SPACE",1);
 
        IF COMMENT
        THEN
          BEGIN
          TEST DUMMY;                # READ THE NEXT DIRECTIVE #
          END
 
#
*     ZERO FILL THE AREA TO HOLD THE DIRECTIVE
*     IMAGE AND THE CRACKED PARAMETERS.
#
 
        ZFILL(LBARG[0],DIRPRML);
 
#
*     SET UP THE DIRECTIVE IMAGE AND THE DIRECTIVE
*     NUMBER IN THE AREA TO BE WRITTEN TO THE
*     TEMPORARY FILE.
#
 
        LBARG$DIRN[0] = TEMP;
        LBARG$DIRI[0] = LBINW$DIR[0];  # DIRECTIVE IMAGE #
 
#
*     CRACK THE DIRECTIVE.
#
 
      LBARG$GR[0] = 7777;
        XARG(ARGLIST,LBIN$WBUF[0],FLAG);  # OPTION IS *DO NOT SKIP OVER
                                            PROGRAM NAME* #
        IF FLAG NQ 0
        THEN                         # SYNTAX ERROR #
          BEGIN
          LBARG$DIRF[0] = TRUE;      # SET UP ERROR FLAGS #
          ERRFLAG = TRUE;
          END
 
#
*     IF NO SYNTAX ERROR IN THE DIRECTIVE THEN CONVERT
*     THE PARAMETERS FROM DISPLAY CODE TO INTEGER VALUE.
#
 
        IF NOT LBARG$DIRF[0]
        THEN                         # NO ERROR IN DIRECTIVE #
          BEGIN
          LBCONV(FLAG);              # CONVERT PARAMETERS #
          IF FLAG NQ 0
          THEN                       # CONVERSION ERROR #
            BEGIN
            LBARG$DIRF[0] = TRUE;    # SET UP ERROR FLAGS #
            ERRFLAG = TRUE;
            END
 
          END
 
#
*     IF AN ERROR IS FOUND IN THE DIRECTIVE, REPORT
*     IT ON THE OUTPUT FILE.
#
 
        IF LBARG$DIRF[0]
        THEN                         # ERROR IN THE DIRECTIVE #
          BEGIN
          ERRCODE = S"SYNTX$DIR";
          LBERR(ERRCODE);            # PROCESS THE ERROR #
          END
 
#
*     IF THERE IS NO ERROR IN THE DIRECTIVE, CHECK
*     FOR ALL THE VALID OPTIONS ON THE DIRECTIVE
*     CALL.
#
 
        IF NOT LBARG$DIRF[0]
        THEN                         # CHECK FOR VALID OPTIONS #
          BEGIN
          LBOPT(FLAG);
          IF FLAG NQ 0
          THEN                       # VALID OPTIONS VIOLATED #
            BEGIN
            LBARG$DIRF[0] = TRUE;    # SET UP ERROR FLAGS #
            ERRFLAG = TRUE;
            END
 
          END
 
#
*     WRITE THE DIRECTIVE IMAGE ALONG WITH THE DIRECTIVE
*     NUMBER, DIRECTIVE FLAG AND THE CRACKED PARAMETERS
*     ON THE TEMPORARY FILE.
#
 
        WRITEW(SCR$FET[0],LBARG[0],DIRPRML,FLAG);
        END  # CRACK AND SYNTAX CHECK DIRECTIVES #
 
      IF DIRNUM EQ 0
      THEN                           # NO DIRECTIVES #
        BEGIN
        LBMSG$LINE[0] = " SSLABEL - NO DIRECTIVES.";
        MESSAGE(LBMSG$BUF[0],SYSUDF1);
        RESTPFP(PFP$ABORT);          # RESTORE USER-S *PFP* AND ABORT #
        END
 
      WRITER(SCR$FET[0],NRCL);
      REWIND(SCR$FET[0],NRCL);
      RETURN;                        # ALL DIRECTIVES CRACKED #
 
      END  # LBLOOP #
 
    TERM
PROC LBMAIN;
# TITLE LBMAIN - PROCESSES *SSLABEL* DIRECTIVES.                      #
 
      BEGIN  # LBMAIN #
 
#
**    LBMAIN - PROCESSES *SSLABEL* DIRECTIVES.
*
*     THIS PROCEDURE PROCESSES DIRECTIVES BY CALLING
*     THE APPROPRIATE DIRECTIVE ROUTINES.
*
*     PROC LBMAIN.
*
*     ENTRY     THE TEMPORARY FILE SET UP WITH
*               THE DIRECTIVE IMAGES ALONG WITH THE
*               CRACKED PARAMETERS.
*
*     EXIT      ALL DIRECTIVES HAVE BEEN PROCESSED.
*
*     MESSAGES  FAMILY NOT FOUND.
*
*     NOTES     THE CRACKED PARAMETER FILE IS READ (UNTIL EOI)
*               INTO WORKING STORAGE.  FOR EACH DIRECTIVE, THE
*               DIRECTIVE IMAGE IS WRITTEN ON THE OUTPUT FILE
*               AND THE SMMAP IS OPENED.  IF THIS OPEN FAILS,
*               OR IF THE SYNTAX ERROR FLAG IS SET FOR THIS
*               DIRECTIVE, THEN THE ERROR PROCESSOR IS CALLED.
*               OTHERWISE THE CORRESPONDING DIRECTIVE ROUTINE
*               IS CALLED.
#
 
#
****  PROC LBMAIN - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC SSINIT;                # SET UP TABLES AND POINTERS #
        PROC LBADCSU;                # ADD *SM* DIRECTIVE (AC) #
        PROC LBADCUB;                # ADD CUBE (AB) #
        PROC LBADMSC;                # ADD CARTRIDGE (AM) #
        PROC LBERR;                  # *SSLABEL* ERROR PROCESSOR #
        PROC LBFLMSC;                # SET/CLEAR FCT INHIB FLAG (IB) #
        PROC LBFXVSN;                # REPAIR LABEL (FX) #
        PROC LBRESP;                 # RESPONSE CODE PROCESSOR #
        PROC LBRMCSU;                # REMOVE *SM* DIRECTIVE (RC) #
        PROC LBRMCUB;                # REMOVE CUBE DIRECTIVE (RB) #
        PROC LBRMMSC;                # REMOVE CARTRIDGE (RM) #
        PROC LBRSMSC;                # RESTORE A CARTRIDGE (RS) #
        PROC LOFPROC;                # LIST OF FILES PROCESSOR #
        PROC MESSAGE;                # DISPLAYS MESSAGES #
        PROC MOPEN;                  # OPEN SMMAP #
        PROC READ;                   # CIO READ MACRO #
        PROC READW;                  # CIO READW MACRO #
        PROC RESTPFP;                # RESTORE USER-S *PFP* AND ABORT
                                       OR RETURN #
        PROC RETERN;                 # RETURN MACRO #
        PROC RPLINE;                 # PRINT FORMATTER ROUTINE #
        PROC RPSPACE;                # PRINTS BLANK LINES #
        PROC SETPFP;                 # SET FAMILY AND USER INDEX #
        END
 
#
****  PROC LBMAIN - XREF LIST END.
#
 
      DEF MSG1 #" FAMILY NOT FOUND."#;
 
      DEF LISTCON    #0#;            # DO NOT LIST COMDECKS #
*CALL COMBFAS
*CALL COMBCMD
*CALL COMBCMS
*CALL COMBCPR
*CALL COMBLBL
*CALL COMBPFP
*CALL COMBSNS
*CALL COMSPFM
*CALL COMTERR
*CALL COMTLAB
*CALL COMTLBP
*CALL COMTOUT
 
      ITEM J          I;             # LOOP VARIABLE #
      ITEM MSTAT      S:CMASTAT;     # ERROR STATUS #
      ITEM RDWSTAT    I = 0;         # ERROR STATUS #
 
      ARRAY CMAP$NM [0:0] P(1);      # BUILD SMMAP FILE NAME #
        BEGIN
        ITEM CMAP$NAME  C(00,00,07);  # SMMAP FILE NAME #
        ITEM CMAP$IN    C(00,00,05);  # FIRST 5 CHARACTERS #
        ITEM CMAP$ID    C(00,30,01);  # CSU-ID #
        ITEM CMAP$Z     U(00,36,24) = [0];  # ZERO FILL FILE NAME #
        END
 
      ARRAY DRW$STAT [0:0] S(SNSLEN);;  # DRAWER STATUS TABLE #
 
#
*     BUFFERS TO HOLD THE OLD CARTRIDGE LABEL
*     AND THE NEW CARTRIDGE LABEL.
#
 
      ARRAY OLDLABEL [0:0] S(LABLEN);;
      ARRAY NEWLABEL [0:0] S(LABLEN);;
 
#
*     SWITCH TO PROCESS ALL THE *SSLABEL*
*     DIRECTIVES.  THE ORDER OF THE SWITCH
*     LABELS IS THE SAME AS THE DIRECTIVE
*     NAMES SET UP IN ARRAY *DIR$NAME*
*     DEFINED IN *COMTLAB*.
#
 
      SWITCH DIR$ACT                 # SWITCH TO PROCESS DIRECTIVES #
        ADDCUBE,                     # ADD CUBES TO A FAMILY OR POOL #
      ADDCSU,                        # ADD A *SM* TO FAMILY CATALOG #
      ADDMSC,                        # ADD CARTRIDGES TO FAMILY OR POOL
                                     #
      FIXVSN,                        # FIX A CARTRIDGE VSN #
      FLAGFRE,                       # TURN FREE FLAG ON OR OFF #
      FLAGMSC,                       # TURN A FLAG ON OR OFF #
      RMVCSU,                        # REMOVE A *SM* FROM FAMILY CATALOG
                                     #
      RMVCUBE,                       # REMOVE A CUBE FROM A FAMILY OR
                                       POOL #
      RMVMSC,                        # REMOVE CARTRIDGES FROM FAMILY OR
                                       POOL #
      RSTRMSC;                       # RESTORE A LOST CARTRIDGE #
 
                                               CONTROL EJECT;
 
#
*     SET UP THE POINTERS OF THE BASED ARRAYS AND
*     THE ADDRESSES OF THE BUFFERS.
#
 
                                     # DRAWER RELATED #
      OLDLABP = LOC(OLDLABEL[0]);
      NEWLABP = LOC(NEWLABEL[0]);
      CMAP$IN[0] = SMMAP;
 
#
*     INITIALIZE THE FETS, BUFFERS ,TABLES AND
*     THE POINTERS FOR THE CATALOG AND THE MAP
*     ACCESS ROUTINES.
#
 
      SSINIT;
      READ(SCR$FET[0],NRCL);
 
#
*     READ EACH DIRECTIVE AREA FROM THE SCRATCH FILE.
#
 
      REPEAT WHILE RDWSTAT EQ 0
      DO
        BEGIN  # PROCESS DIRECTIVES #
        READW(SCR$FET[0],LBARG[0],DIRPRML,RDWSTAT);
        IF RDWSTAT NQ 0
        THEN                         # EOI REACHED #
          BEGIN
          TEST DUMMY;
          END
 
#
*     WRITE DIRECTIVE NUMBER AND IMAGE TO OUTPUT FILE.
#
 
        RPLINE(OUT$FETP,LBARG$DIRN[0],2,5,1);
        RPLINE(OUT$FETP,LBARG$DIRI[0],8,80,0);
        RPSPACE(OUT$FETP,SP"SPACE",1);
        IF LBARG$DIRF[0]
        THEN                         # CHECK SYNTAX ERROR FLAG #
          BEGIN
          RPLINE(OUT$FETP,"*** SYNTAX ERROR",2,16,0);
          TEST DUMMY;
          END
 
#
*     IF *FM* IS NOT SPECIFIED, USE THE DEFAULT FAMILY.
#
 
        IF (LBARG$ZFM[0] EQ 0 AND LBARG$OP[0] NQ "FX")  ##
          OR LBARG$ZFM[0] EQ -1
        THEN
          BEGIN
          LBARG$FM[0] = DEF$FAM;
          END
 
        PFP$WRD0[0] = 0;             # SET FAMILY AND USER INDEX #
        PFP$FAM[0] = DEF$FAM;
        PFP$UI[0] = DEF$UI;
        PFP$FG1[0] = TRUE;
        PFP$FG4[0] = TRUE;
        SETPFP(PFP);
        IF PFP$STAT[0] NQ 0
        THEN                         # FAMILY NOT FOUND #
          BEGIN
          LBMSG$LN[0] = MSG1;
          MESSAGE(LBMSG[0],SYSUDF1);
          RESTPFP(PFP$ABORT);        # RESTORE USER-S *PFP* AND ABORT #
          END
 
#
*     OPEN SMUMAP.
#
 
        CMAP$ID[0] = LBARG$SM[0];    # SET UP THE *SM* ID #
        MOPEN(LBARG$SMID[0],CMAP$NAME[0],"RM",MSTAT);
        IF MSTAT EQ S"NOERR"
        THEN
          BEGIN
          LOFPROC(CMAP$NAME[0]);     # ADD LFN TO LIST OF FILES #
          END
 
        PFP$UI[0] = DEF$UI + LBARG$SB[0];
        PFP$FAM[0] = LBARG$FM[0];
        SETPFP(PFP);
        IF PFP$STAT[0] NQ 0
          AND LBARG$OP[0] NQ "FX"
        THEN                         # FAMILY NOT FOUND #
          BEGIN
          LBMSG$LN[0] = MSG1;
          MESSAGE(LBMSG[0],SYSUDF1);
          RESTPFP(PFP$ABORT);        # RESTORE PFP #
          END
 
#
*     IF THERE IS ANY ERROR OTHER THAN
*     *FILE ALREADY OPEN*, PROCESS THE
*     ERROR STATUS.
#
 
        IF MSTAT NQ S"NOERR" AND MSTAT NQ S"FOPEN"
        THEN
          BEGIN
          LBRESP(MSTAT,0);
          TEST DUMMY;
          END
 
#
*     PROCESS THE DIRECTIVE.
#
 
        SLOWFOR J = 0 STEP 1 UNTIL 9
        DO
          BEGIN
          IF DIR$NM[J] EQ LBARG$OP[0]
          THEN                       # FIND MATCHING DIRECTIVE #
            BEGIN
            GOTO DIR$ACT[J];
            END
 
          END
 
ADDCUBE:
        LBADCUB;
        TEST DUMMY;
 
ADDCSU:                              # ADD *SM* TO FAMILY CATALOG #
        LBADCSU;
        TEST DUMMY;
 
ADDMSC:                              # ADD CARTRIDGES TO FAMILY/POOL #
        LBADMSC;
        TEST DUMMY;
 
FIXVSN:                              # FIX CARTRIDGE VSN #
        LBFXVSN;
        TEST DUMMY;
 
FLAGFRE:                             # TURN FREE FLAG ON OR OFF #
 
FLAGMSC:                             # TURN A FLAG ON OR OFF #
        LBFLMSC;
        TEST DUMMY;
 
RMVCSU:                              # REMOVE *SM* FROM FAMILY CATALOG #
        LBRMCSU;
        TEST DUMMY;
 
RMVCUBE:                             # REMOVE CUBE FROM FAMILY/POOL #
        LBRMCUB;
        TEST DUMMY;
 
RMVMSC:                              # REMOVE FAMILY/POOL CARTRIDGES #
        LBRMMSC;
        TEST DUMMY;
 
RSTRMSC:                             # RESTORE A LOST CARTRIDGE #
        LBRSMSC;
        TEST DUMMY;
 
        END  # PROCESS DIRECTIVES #
 
      RETURN;
 
      END  # LBMAIN #
 
    TERM
PROC LBOPT(ERRFLAG);
# TITLE LBOPT - TESTS FOR VALID *SSLABEL* DIRECTIVES.                 #
 
      BEGIN  # LBOPT #
 
#
**    LBOPT - TESTS FOR VALID *SSLABEL* DIRECTIVE OPTIONS.
*
*     THIS PROCEDURE CHECKS THE *SSLABEL* DIRECTIVE OPTIONS
*     SPECIFIED, AND IF AN INVALID OPTION IS FOUND THE
*     ERROR PROCESSOR IS CALLED WITH THE APPROPRIATE
*     ERROR CODE.
*
*     PROC LBOPT(ERRFLAG)
*
*     EXIT     ALL THE VALID OPTIONS CHECKED OR A VALID
*              OPTION VIOLATED.
*              ERRFLAG, AN ITEM CONTAINING THE ERROR STATUS.
*                  0, NO ERROR.
*                  1, VALID OPTION VIOLATED.
*
*     NOTES    ALL DIRECTIVE OPTIONS ARE TESTED FOR INVALID VALUES.
*              THE VALID OPTIONS ON *SSLABEL* DIRECTIVE CALLS ARE
*                  1.  *OP* MUST BE A LEGAL DIRECTIVE NAME.
*                  2.  *N* MUST BE 1 IF *CN* IS SPECIFIED.
*                  3.  *CN* MUST BE SPECIFIED WITH *RMVMSC* LOST
*                      OPTION.
*                  4.  *CN* MAY NOT BE SPECIFIED WHEN ANY *PK*
*                      OPTION IS USED.
*                  5.  *CN* MAY NOT BE SPECIFIED WITH *ADDCSU*,
*                      *RMVCSU*, *ADDCUBE* AND *RMVCUBE* DIRECTIVES.
*                  6.  VALID USES OF *PK* ARE
*                         OP=AM - PK=D OR PK=P
*                         OP=RM - PK=P OR PK=F
*                         OP=RB - PK=P OR PK=F OR PK=R
*                         PK=P MAY NOT BE SPECIFIED IF PT=P.
*                  7.  PT=P CANNOT BE SPECIFIED WHEN OP=AM AND
*                      *V* IS SPECIFIED.
*                  8.  VALID USES OF *PT* ARE
*                         OP=AM - PT=P OR PT=F
*                         OP=RM - PT=D OR PT=P
*                         OP=AB - PT=P OR PT=F OR PT=R
*                  9.  VALID USES OF *D* ARE FOR PK=D, OP=RS OR
*                      OP=FX.
*                  10. *GR* MUST BE BETWEEN 1 AND 20 AND IS
*                      VALID ONLY WITH OP=AM AND OP=RM.
*                 11.  *LS* IS VALID ONLY WITH OP=RM.
*                 12.  *SM* MUST BE IN A TO M RANGE.
*                 13.  *ON* OR *OF* CAN BE SPECIFIED ONLY FOR OP=IB.
*                 14.  *YF* AND *ZF* MUST BOTH BE SPECIFIED IF
*                      EITHER IS SPECIFIED.
*                 15.  *YF* AND *ZF* CAN BE SPECIFIED ONLY IF BOTH
*                      *YI* AND *ZI* ARE SPECIFIED.
*                 16.  *YI* AND *YF* MUST BE BETWEEN 0 TO 21.
*                 17.  *ZI* AND *ZF* MUST BE BETWEEN 0 TO 15.
*                 18.  *YF* MUST BE GREATER THAN OR EQUAL TO
*                      *YI* IF BOTH ARE SPECIFIED.
*                 19.  *ZF* MUST BE GREATER THAN OR EQUAL TO
*                      *ZI* IF BOTH ARE SPECIFIED.
*                 20.  *SB* MUST BE FROM 0 TO 7.
*                 21.  *B* IS VALID ONLY WITH OP=AB. IT MUST
*                  22.  *CC* PARAMETER IS VALID ONLY WITH *AM*, MAY
*                       NOT BE USED WITH ANY OTHER OPTIONS, AND CAN
*                       ONLY BE EQUAL TO 0 OR 15.
*                      BE BETWEEN 0 AND 1931.
*               ANY VIOLATION OF THE VALID OPTIONS CAUSES A
*               MESSAGE TO BE PRINTED ON THE REPORT FILE AND
*               IN THE DAYFILE AND AN ERROR STATUS IS RETURNED
*               TO THE CALLING PROCEDURE.  PROC *LBERR* DOES
*               ALL THE ERROR PROCESSING.
#
 
      ITEM ERRFLAG    I;             # ERROR STATUS #
 
#
****  PROC LBOPT - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC LBERR;                  # SSLABEL ERROR PROCESSOR #
        END
 
#
****  PROC LBOPT - XREF LIST END.
#
 
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS #
*CALL COMBFAS
*CALL COMTERR
*CALL COMTLAB
*CALL COMTLBP
 
      ITEM FOUND      B;             # SEARCH FLAG #
      ITEM I          I;             # LOOP VARIABLE #
 
                                               CONTROL EJECT;
 
      ERRFLAG = 0;
 
#
*     TEST SSLABEL DIRECTIVE OPTIONS AND CALL LBERR WITH APPROPRIATE
*     ERROR CODE IF ERRORS ARE FOUND.
*     CHECK FOR A LEGAL DIRECTIVE NAME.
#
 
      FOUND = FALSE;
      SLOWFOR I = 0 STEP 1 UNTIL 9
      DO
        BEGIN
        IF LBARG$OP[0] EQ DIR$NM[I]
        THEN
          BEGIN
          FOUND = TRUE;              # LEGAL DIRECTIVE NAME #
          END
 
        END
 
      IF NOT FOUND
      THEN
        BEGIN
        ERRCODE = S"ILL$DIRCTV";     # "ILLEGAL DIRECTIVE" #
        LBERR(ERRCODE);
        ERRFLAG = 1;
        RETURN;
        END
 
#
*     CHECK IF *N* HAS A LEGAL VALUE.
#
 
      IF LBARG$N[0] LS 1 OR LBARG$N[0] GR 100
      THEN
        BEGIN
        ERRCODE = S"ILL$N";          # "ILLEGAL N" #
        LBERR(ERRCODE);
        ERRFLAG = 1;
        RETURN;
        END
 
#
*     CHECK FOR A LEGAL VALUE OF *PK*.
#
 
      IF LBARG$PK[0] NQ "P"          ##
        AND LBARG$PK[0] NQ "D"       ##
        AND LBARG$PK[0] NQ "F"       ##
        AND LBARG$PK[0] NQ "R"       ##
        AND LBARG$PK[0] NQ 0
      THEN
        BEGIN
        ERRCODE = S"PK$PT$VIOL";     # "PK,PT OPTION VIOLATED" #
        LBERR(ERRCODE);
        ERRFLAG = 1;
        RETURN;
        END
 
#
*     CHECK FOR A LEGAL VALUE FOR *PT*.
#
 
      IF LBARG$PT[0] NQ "P"          ##
        AND LBARG$PT[0] NQ "D"       ##
        AND LBARG$PT[0] NQ "F"       ##
        AND LBARG$PT[0] NQ "R"
      THEN
        BEGIN
        ERRCODE = S"PK$PT$VIOL";     # "PK,PT OPTION VIOLATED" #
        LBERR(ERRCODE);
        ERRFLAG = 1;
        RETURN;
        END
 
#
*     CHECK IF *CN* IS SPECIFIED CORRECTLY.
#
 
      IF LBARG$C[0] NQ 0             ##
        AND (LBARG$OP[0] EQ "AS" OR LBARG$OP[0] EQ "RS" OR LBARG$OP[0]
        EQ "AB"                      ##
        OR LBARG$OP[0] EQ "RB")
      THEN
        BEGIN
        ERRCODE = S"CSN$VIOL";       # "VSN OPTION VIOLATED" #
        LBERR(ERRCODE);
        ERRFLAG = 1;
        RETURN;
        END
 
#
*     CHECK IF *CM* PARAMETER IS SPECIFIED CORRECTLY.
#
 
      IF (LBARG$CM[0] NQ IBMCART     ##
        AND LBARG$C[0] NQ 0)         ##
        OR LBARG$CM[0] NQ IBMCART
      THEN
        BEGIN
        ERRCODE = S"CSN$VIOL";       # *CSN* OPTION VIOLATED #
        LBERR(ERRCODE);
        ERRFLAG = 1;
        RETURN;
        END
 
#
*     CHECK *N* OR *PK* IS SPECIFIED WHEN
*     *V* IS SPECIFIED.
#
 
      IF LBARG$C[0] NQ 0             ##
        AND (LBARG$N[0] NQ 1         ##
        OR LBARG$PK[0] NQ 0)
      THEN
        BEGIN
        ERRCODE = S"CSN$VIOL";       # "VSN OPTION VIOLATED" #
        LBERR(ERRCODE);
        ERRFLAG = 1;
        RETURN;
        END
 
#
*     CHECK IF *PT* IS SPECIFIED TO BE *P*
*     WHEN *V* IS SPECIFIED FOR *AM*.
#
 
      IF LBARG$C[0] NQ 0             ##
        AND LBARG$OP[0] EQ "AM"      ##
        AND LBARG$PT[0] EQ "P"
      THEN
        BEGIN
        ERRCODE = S"PK$PT$VIOL";     # "PK,PT OPTION VIOLATED" #
        LBERR(ERRCODE);
        ERRFLAG = 1;
        RETURN;
        END
 
#
*     CHECK IF *PK* AND *PT* ARE SPECIFIED
*     CORRECTLY FOR *AM*.
#
 
      IF LBARG$OP[0] EQ "AM"         ##
        AND LBARG$CC[0] EQ -1 AND ((LBARG$PK[0] NQ 0  ##
        AND LBARG$PK[0] NQ "D"       ##
        AND LBARG$PK[0] NQ "P")      ##
        OR (LBARG$PT[0] NQ "P"       ##
        AND LBARG$PT[0] NQ "F"))
      THEN
        BEGIN
        ERRCODE = S"PK$PT$VIOL";     # "PK,PT OPTION VIOLATED" #
        LBERR(ERRCODE);
        ERRFLAG = 1;
        RETURN;
        END
 
#
*     CHECK IF *PK* AND *PT* ARE SPECIFIED
*     CORRECTLY FOR *RM*.
#
 
      IF LBARG$OP[0] EQ "RM"         ##
        AND ((LBARG$PK[0] NQ 0       ##
        AND LBARG$PK[0] NQ "P"       ##
        AND LBARG$PK[0] NQ "F")      ##
        OR (LBARG$PT[0] NQ "D"       ##
        AND LBARG$PT[0] NQ "P"))
      THEN
        BEGIN
        ERRCODE = S"PK$PT$VIOL";     # "PK,PT OPTION VIOLATED" #
        LBERR(ERRCODE);
        ERRFLAG = 1;
        RETURN;
        END
 
#
*     CHECK IF *PK* IS SPECIFIED CORRECTLY
*     FOR *RB*.
#
 
      IF LBARG$OP[0] EQ "RB"         ##
        AND (LBARG$PK[0] NQ "P"      ##
        AND LBARG$PK[0] NQ "F"       ##
        AND LBARG$PK[0] NQ "R")
      THEN
        BEGIN
        ERRCODE = S"PK$PT$VIOL";     # "PK,PT OPTION VIOLATED" #
        LBERR(ERRCODE);
        ERRFLAG = 1;
        RETURN;
        END
 
#
*     CHECK IF *PK* AND *PT* ARE BOTH SPECIFIED
*     TO BE *P* FOR *AM* OR *RM*.
#
 
      IF (LBARG$PK[0] EQ "P"         ##
        AND LBARG$PT[0] EQ "P")      ##
        AND LBARG$CC[0] EQ -1        ##
        AND (LBARG$OP[0] EQ "AM"     ##
        OR LBARG$OP[0] EQ "RM")
      THEN
        BEGIN
        ERRCODE = S"PK$PT$VIOL";     # "PK,PT OPTION VIOLATED" #
        LBERR(ERRCODE);
        ERRFLAG = 1;
        RETURN;
        END
 
#
*     CHECK IF *PT* IS SPECIFIED CORRECTLY FOR *AB*.
#
 
      IF LBARG$OP[0] EQ "AB"         ##
        AND ((LBARG$PT[0] EQ "D")    ##
        OR (LBARG$N[0] NQ 1          ##
        AND LBARG$PT[0] EQ "R"))
      THEN
        BEGIN
        ERRCODE = S"PK$PT$VIOL";     # "PK,PT OPTION VIOLATED" #
        LBERR(ERRCODE);
        ERRFLAG = 1;
        RETURN;
        END
 
#
*     CHECK IF *YI*, *ZI* OPTION IS SELECTED FOR *AB*.
#
 
      IF LBARG$OP[0] EQ "AB"         ##
        AND LBARG$PT[0] EQ "R"       ##
        AND LBARG$YI[0] EQ -1        ##
        AND LBARG$ZI[0] EQ -1
      THEN
        BEGIN
        ERRCODE = S"YZ$VIOL";        # "Y,Z OPTION VIOLATED" #
        LBERR(ERRCODE);
        ERRFLAG = 1;
        RETURN;
        END
 
#
*     CHECK IF *YI*, *ZI* OPTION IS IMPROPERLY USED FOR *AM*.
#
 
      IF LBARG$OP[0] EQ "AM"         ##
        AND (LBARG$YI[0] NQ -1       ##
        OR LBARG$ZI[0] NQ -1)        ##
        AND LBARG$CC[0] EQ -1
      THEN
        BEGIN
        ERRCODE = S"YZ$VIOL";        # "Y,Z OPTION VIOLATED" #
        LBERR(ERRCODE);
        ERRFLAG = 1;
        RETURN;
        END
 
 
#
*     CHECK IF *LOST OPTION* IS SPECIFIED CORRECTLY.
#
 
      IF LBARG$LT[0] NQ 0            ##
        AND (LBARG$OP[0] NQ "RM"     ##
        OR LBARG$C[0] EQ 0)          ##
      THEN
        BEGIN
        ERRCODE = S"LT$VIOL";        # "LT OPTION VIOLATED" #
        LBERR(ERRCODE);
        ERRFLAG = 1;
        RETURN;
        END
 
#
*     CHECK IF GROUP NUMBER IS LEGAL.
#
 
      IF ((LBARG$GR[0] GQ 0)         ##
        AND ((LBARG$OP[0] EQ "AS")   ##
        OR (LBARG$OP[0] EQ "AB")     ##
        OR (LBARG$OP[0] EQ "RS")     ##
        OR (LBARG$OP[0] EQ "RB")     ##
        OR (LBARG$OP[0] EQ "FX")     ##
        OR (LBARG$OP[0] EQ "RC")     ##
        OR (LBARG$OP[0] EQ "IB")))
      THEN                           # INCORRECT USE OF GROUP #
        BEGIN
        ERRCODE = S"GR$INCORR";
        LBERR(ERRCODE);
        ERRFLAG = 1;
        RETURN;
        END
 
      IF LBARG$GR[0] GR 20
        OR LBARG$GR[0] EQ 0
      THEN                           # GROUP OUT OF RANGE #
        BEGIN
        ERRCODE = S"GR$RANGE";
        LBERR(ERRCODE);
        ERRFLAG = 1;
        RETURN;
        END
 
 
#
*     CHECK IF *PT* IS *P* AND *OP* IS *AM* WITH *GR* SPECIFIED.
#
 
      IF LBARG$GR[0] GQ 0 AND LBARG$OP[0] EQ "AM" AND LBARG$PT[0] EQ "P
 "
      THEN
        BEGIN
        ERRCODE = S"GR$INCORR";
        LBERR(ERRCODE);
        ERRFLAG = 1;
        RETURN;
        END
 
 
#
*     CHECK IF *CN* IS SPECIFIED FOR *IB* AND *FX*.
#
 
      IF (LBARG$OP[0] EQ "IB"        ##
        OR LBARG$OP[0] EQ "FX")      ##
        AND LBARG$C[0] EQ 0
      THEN
        BEGIN
        ERRCODE = S"CSN$VIOL";       # VSN OPTION VIOLATED #
        LBERR(ERRCODE);
        ERRFLAG = 1;
        RETURN;
        END
 
#
*     CHECK IF *ON* OR *OF* IS SPECIFIED
*     FOR ANY DIRECTIVE OTHER THAN *IB* OR *FC*.
#
 
      IF (LBARG$OP[0] NQ "IB" AND LBARG$OP[0] NQ "FC")  ##
        AND(LBARG$ON[0] NQ 0 OR LBARG$OF[0] NQ 0)
      THEN
        BEGIN
        ERRCODE = S"ON$OF$VIOL";     # "ON,OFF NOT SPECIFIED CORRECTLY"
                                     #
        LBERR(ERRCODE);
        ERRFLAG = 1;
        RETURN;
        END
 
#
*     CHECK IF *ON* OR *OF* ARE SPECIFIED
*     CORRECTLY FOR *IB* OR *FC*:
#
 
      IF (LBARG$OP[0] EQ "IB" OR LBARG$OP[0] EQ "FC")  ##
        AND ((LBARG$ON[0] EQ 0       ##
        AND LBARG$OF[0] EQ 0)        ##
        OR (LBARG$ON[0] NQ 0         ##
        AND LBARG$OF[0] NQ 0))
      THEN
        BEGIN
        ERRCODE = S"ON$OF$VIOL";     # "ON,OFF NOT SPECIFIED CORRECTLY"
                                     #
        LBERR(ERRCODE);
        ERRFLAG = 1;
        RETURN;
        END
 
#
*     CHECK FOR A LEGAL VALUE FOR *CS*.
#
 
      IF LBARG$SM[0] GR "H"          ##
        OR LBARG$SM[0] LS "A"        ##
        OR LBARG$ZSM[0] NQ 0
      THEN
        BEGIN
        ERRCODE = S"ILL$SM";         # "ILLEGAL *SM* NUMBER" #
        LBERR(ERRCODE);
        ERRFLAG = 1;
        RETURN;
        END
 
#
*     CHECK THE VALUE OF YS AND ZS.
#
 
      IF LBARG$YI[0] GR MAX$Y        ##
        OR LBARG$YF[0] GR MAX$Y      ##
        OR LBARG$ZI[0] GR MAX$Z      ##
        OR LBARG$ZI[0] EQ Z$NO$CUBE  ##
        OR LBARG$ZF[0] GR MAX$Z      ##
        OR LBARG$ZF[0] EQ Z$NO$CUBE
      THEN
        BEGIN
        ERRCODE = S"YZ$VIOL";        # "Y,Z OPTION VIOLATED" #
        LBERR(ERRCODE);
        ERRFLAG = 1;
        RETURN;
        END
 
#
*     CHECK IF *YI*, *ZI*, *YF* AND *ZF* ARE SPECIFIED
*     CORRECTLY.
#
 
      IF (LBARG$YI[0] EQ -1          ##
        AND LBARG$YF[0] GR 0)        ##
        OR (LBARG$ZI[0] EQ -1        ##
        AND LBARG$ZF[0] GR 0)
      THEN
        BEGIN
        ERRCODE = S"YZ$VIOL";        # "Y,Z OPTION VIOLATED" #
        LBERR(ERRCODE);
        ERRFLAG = 1;
        RETURN;
        END
 
#
*     CHECK IF *N* IS SPECIFIED ALONG WITH
*     *YI* OR *ZI*.
#
 
      IF (LBARG$YI[0] GQ 0 OR LBARG$ZI[0] GQ 0) AND LBARG$N[0] GR 1
        THEN
        BEGIN
        ERRCODE = S"YZ$VIOL";        # "Y,Z OPTION VIOLATED" #
        LBERR(ERRCODE);
        ERRFLAG = 1;
        RETURN;
        END
 
#
*     CHECK IF *YF* AND *ZF* ARE NOT
*     SPECIFIED TOGETHER.
#
 
      IF (LBARG$YF[0] GQ 0           ##
        AND LBARG$ZF[0] EQ -1)       ##
        OR (LBARG$YF[0] EQ -1 AND LBARG$ZF[0] GQ 0)
      THEN
        BEGIN
        ERRCODE = S"YZ$VIOL";        # "Y,Z OPTION VIOLATED" #
        LBERR(ERRCODE);
        ERRFLAG = 1;
        RETURN;
        END
 
#
*     CHECK IF *YF* IS GREATER THAN OR EQUAL
*     TO *YI* WHEN BOTH ARE SPECIFIED.
#
 
      IF ((LBARG$YI[0] NQ -1)        ##
        AND (LBARG$YF[0] NQ -1))     ##
        AND (LBARG$YF[0] LS LBARG$YI[0])
      THEN
        BEGIN
        ERRCODE = S"YZ$VIOL";        # "Y,Z OPTION VIOLATED" #
        LBERR(ERRCODE);
        ERRFLAG = 1;
        RETURN;
        END
 
#
*     CHECK IF *ZF* IS GREATER THAN OR EQUAL
*     TO *ZI* WHEN BOTH ARE SPECIFIED.
#
 
      IF ((LBARG$ZI[0] NQ -1)        ##
        AND (LBARG$ZF[0] NQ -1) )    ##
        AND (LBARG$ZF[0] LS LBARG$ZI[0])
      THEN
        BEGIN
        ERRCODE = S"YZ$VIOL";        # "Y,Z OPTION VIOLATED" #
        LBERR(ERRCODE);
        ERRFLAG = 1;
        RETURN;
        END
 
 
#
*     CHECK IF *YI* AND *ZI* SPECIFY NON-EXISTANT CUBES WHILE
*     *YF* AND *ZF* ARE NOT SPECIFIED.
#
 
      IF (LBARG$YF[0] EQ -1 AND LBARG$ZF[0] EQ -1)
        AND LBARG$CC[0] EQ -1
      THEN                           # SINGLE CUBE SPECIFIED #
        BEGIN
        IF (LBARG$ZI[0] EQ Z$NO$CUBE)  ##
          OR ((LBARG$ZI[0] EQ 0)     ##
          AND ((LBARG$YI[0] EQ 0)    ##
          OR (LBARG$YI[0] EQ 11)     ##
          OR (LBARG$YI[0] EQ 12)     ##
          OR (LBARG$YI[0] EQ 13)     ##
          OR (LBARG$YI[0] EQ 14)     ##
          OR (LBARG$YI[0] EQ 15)))     ##
          OR ((LBARG$ZI[0] EQ 1)     ##
          AND ((LBARG$YI[0] EQ 11)   ##
          OR (LBARG$YI[0] EQ 12)     ##
          OR (LBARG$YI[0] EQ 13)     ##
          OR (LBARG$YI[0] EQ 14)     ##
          OR (LBARG$YI[0] EQ 15)))     ##
          OR ((LBARG$ZI[0] EQ 15)    ##
          AND ((LBARG$YI[0] EQ 0)    ##
          OR (LBARG$YI[0] EQ 11)     ##
          OR (LBARG$YI[0] EQ 21)))   ##
        THEN                         # IGNORE NON-EXISTANT CUBE #
          BEGIN
          ERRCODE = S"YZ$VIOL";      # "Y,Z OPTION VIOLATED" #
          LBERR(ERRCODE);
          ERRFLAG =1;
          RETURN;
          END
 
        END
 
 
#
*     CHECK FOR A LEGAL VALUE FOR *SB*.
#
 
      IF LBARG$SB[0] LS 0 OR LBARG$SB[0] GR 7
      THEN
        BEGIN
        ERRCODE = S"ILL$SB";         # "ILLEGAL SUBFAMILY" #
        LBERR(ERRCODE);
        ERRFLAG = 1;
        END
 
#
*     CHECK FOR LEGAL VALUE  OF *CC*.
#
 
      IF (LBARG$CC[0] NQ -1 AND LBARG$OP NQ "AM") OR (LBARG$CC[0] NQ 0
        AND LBARG$CC[0] NQ 15 AND LBARG$CC[0] NQ -1)
      THEN
        BEGIN
        ERRCODE = S"ILL$DIRCTV";
        LBERR(ERRCODE);
        ERRFLAG = 1;
        RETURN;
        END
 
#
*     CHECK FOR LEGAL *B* VALUE.
#
 
      IF (LBARG$B[0] LS 0) OR (LBARG$B[0] GR 1931)  ##
        OR ((LBARG$B[0] NQ 600)      ##
        AND (LBARG$OP[0] NQ "AM"))
      THEN                           # *B* INCORRECT #
        BEGIN
        ERRCODE = S"B$INCORR";
        LBERR(ERRCODE);
        ERRFLAG = 1;
        RETURN;
        END
 
 
      RETURN;                        # RETURN ERRFLAG = NO ERROR #
 
      END  # LBOPT #
 
    TERM
PROC LBRESP((RESP$CODE),(CALLTYP));
# TITLE LBRESP - ACTS UPON RESPONSE CODES FROM EXEC.                  #
 
      BEGIN  # LBRESP #
 
#
**    LBRESP - ACTS UPON RESPONSE CODES FROM EXEC.
*
*     THIS PROC CHECKS THE RESPONSE CODE RETURNED BY EXEC
*     AND CALLS *LBERR* WITH THE APPROPRIATE ERROR CODE IF
*     ANY ERROR OCCURRED.
*
*     PROC LBRESP((RESP$CODE),(CALLTYP))
*
*     ENTRY    RESP$CODE,  CODE RETURNED BY EXEC IN RESPONSE
*                          TO A UCP REQUEST, OR BY A CATALOG/MAP
*                          ACCESS ROUTINE.
*              CALLTYP,    TYPE OF CALL.
*                            0 - CATALOG/MAP ACCESS.
*                            3 - TYPE 3 UCP REQUEST.
*                            4 - TYPE 4 UCP REQUEST.
*
*     EXIT     PROC *LBERR* CALLED OR RETURN DIRECTLY TO CALLING PROC.
*
*     MESSAGES SSLABEL ABNORMAL, LBRESP.
*
*     NOTES    PROC *LBRESP* CHECKS THE VALUE OF *RESP$CODE* AND CALLS
*              *LBERR* WITH THE APPROPRIATE ERROR CODE IF ANY ERRORS
*              ARE INDICATED.
#
 
      ITEM RESP$CODE  U;             # RESPONSE CODE FROM EXEC #
      ITEM CALLTYP    U;             # TYPE OF CALL MADE #
 
#
****  PROC LBRESP - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC LBERR;                  # *SSLABEL* ERROR PROCESSOR #
        PROC MESSAGE;                # DISPLAYS MESSAGES #
        PROC RESTPFP;                # RESTORE USER-S *PFP* AND ABORT
                                       OR RETURN #
        END
 
#
****  PROC LBRESP - XREF LIST END.
#
 
      DEF PROCNAME #"LBRESP."#;      # PROC NAME #
 
      DEF LISTCON    #0#;            # DO NOT LIST COMDECKS #
*CALL COMBFAS
*CALL COMBCMS
*CALL COMBCPR
*CALL COMTERR
*CALL COMTLAB
 
#
*     STATUS SWITCH FOR THE RESPONSE CODES
*     RETURNED BY EXEC IN RESPONSE TO TYPE 3
*     CALLSS REQUEST.
#
 
      SWITCH RESP$ACT3:RESPTYP3      # ACTION ON RESPONSE TO TYPE 3
                                       REQUEST #
               OK3$ACT:OK3,          # REQUEST PROCESSED #
            INTLCK$ACT:C$M$INTLCK,   # CATALOG/MAP INTERLOCKED #
             NOPEN$ACT:C$M$NOPEN,    # CATALOG/MAP NOT OPEN #
             SUBEX$ACT:SUB$CAT$EX,   # SUB CATALOG ALREADY EXISTS #
             NOSUB$ACT:NO$SUB$CAT,   # NO SUCH SUBCATALOG #
            PFPROB$ACT: PF$PROB;     # PERMANENT FILE PROBLEM #
 
#
*     STATUS SWITCH FOR THE RESPONSE RETURNED BY
*     EXEC TO A TYPE 4 CALLSS REQUEST.  ONLY THE
*     APPLICABLE RESPONSE CODES ARE LISTED HERE.
#
 
      SWITCH RESP$ACT4:RESPTYP4      # ACTION ON RESPONSE TO TYPE 4
                                       REQUEST #
               OK4$ACT:OK4,          # REQUEST PROCESSED #
            CLBERR$ACT:CART$LB$ERR,  # CARTRIDGE LABEL ERROR #
            CUSERR$ACT:CSN$IN$USE,      # CARTRIDGE IN USE #
            SMOFF$ACT:SMA$OFF,          # STORAGE MODULE OFF #
            CEMERR$ACT:CELL$EMP,
            CFLERR$ACT:CELL$FULL,
            UNKERR$ACT:UNK$CART,     # UNKNOWN LABEL ERROR #
            URDERR$ACT:UN$RD$ERR,    # UNRECOVERABLE READ ERROR #
            UWTERR$ACT:UN$WRT$ERR,   # UNRECOVERABLE WRITE ERROR #
            MHDERR$ACT:M86$HDW$PR;   # M86 HARDWARE PROBLEM #
 
                                               CONTROL EJECT;
 
#
*     DO PROCESSING APPROPRIATE TO TYPE OF RESPONSE CODE.
#
 
      IF CALLTYP EQ TYP"TYP3"
      THEN                           # TYPE 3 UCP REQUEST #
        BEGIN
        GOTO RESP$ACT3[RESP$CODE];
        END
 
      IF CALLTYP EQ TYP"TYP4"
      THEN                           # TYPE 4 UCP REQUEST #
        BEGIN
        GOTO RESP$ACT4[RESP$CODE];
        END
 
      IF CALLTYP NQ 0
      THEN                           # ILLEGAL CALL TYPE #
        BEGIN
        LBMSG$PROC[0] = PROCNAME;
        MESSAGE(LBMSG[0],SYSUDF1);
        RESTPFP(PFP$ABORT);          # RESTORE USER-S *PFP* AND ABORT #
        END
 
#
*     ERROR PROCESSING FOR CATALOG/MAP ACCESS.
#
 
      IF RESP$CODE EQ CMASTAT"INTLK"
      THEN                           # CATALOG/MAP INTERLOCKED #
        BEGIN
        ERRCODE = S"CAT$MAP$LK";
        LBERR(ERRCODE);
        RETURN;
        END
 
      IF RESP$CODE EQ CMASTAT"ATTERR"
      THEN                           # PROCESS ATTACH ERROR #
        BEGIN
        ERRCODE = S"PF$PROB";
        LBERR(ERRCODE);
        RETURN;
        END
 
      IF RESP$CODE EQ CMASTAT"NOSUBCAT"
      THEN                           # NO SUCH SUBCATALOG #
        BEGIN
        ERRCODE = S"NO$CAT$MAP";
        LBERR(ERRCODE);
        RETURN;
        END
 
      IF RESP$CODE NQ CMASTAT"NOERR" AND RESP$CODE NQ CMASTAT"FOPEN"
        THEN                         # ERROR OTHER THAN *CATALOG
                                       ALREADY OPEN* #
        BEGIN
        LBMSG$PROC[0] = PROCNAME;
        MESSAGE(LBMSG[0],SYSUDF1);
        RESTPFP(PFP$ABORT);          # RESTORE USER-S *PFP* AND ABORT #
        END
 
#
*     ERROR PROCESSING FOR TYPE 3 REQUESTS TO EXEC.
#
 
OK3$ACT:                             # NO ERROR #
      RETURN;
 
INTLCK$ACT:                          # CATALOG/MAP INTERLOCKED #
      ERRCODE = S"CAT$MAP$LK";
      LBERR(ERRCODE);
      RETURN;
 
NOPEN$ACT:                           # CATALOG/MAP NOT OPEN #
      ERRCODE = S"NOT$OPEN";
      LBERR(ERRCODE);
      RETURN;
 
SUBEX$ACT:                           # SUB CATALOG ALREADY EXISTS #
      ERRCODE = S"SM$DEFND";
      LBERR(ERRCODE);
      RETURN;
 
NOSUB$ACT:                           # NO SUCH SUBCATALOG #
      ERRCODE = S"NO$CAT$MAP";
      LBERR(ERRCODE);
      RETURN;
 
PFPROB$ACT:                          # PERMANENT FILE PROBLEM #
      ERRCODE = S"PF$PROB";
      LBERR(ERRCODE);
      RETURN;
 
#
*     ERROR PROCESSING FOR TYPE 4 REQUESTS TO EXEC.
#
 
OK4$ACT:                             # NO ERRORS #
      RETURN;
 
CLBERR$ACT:                          # CARTRIDGE LABEL ERROR #
 
      ERRCODE = S"LAB$ERR";
      LBERR(ERRCODE);
      RETURN;
 
 
CUSERR$ACT:
 
      ERRCODE = S"CAR$IN$USE";
      LBERR(ERRCODE);
      RETURN;
 
 
CEMERR$ACT:                          # CARTRIDGE NOT FOUND #
 
      ERRCODE = S"CR$NOTFND";
      LBERR(ERRCODE);
      RETURN;
 
CFLERR$ACT:                          # CELL IS FULL #
 
      ERRCODE = S"CELL$FULL";
      LBERR(ERRCODE);
      RETURN;
 
 
UNKERR$ACT:                          # UNKNOWN LABEL ERROR #
 
      ERRCODE = S"LAB$ERR";
      LBERR(ERRCODE);
      RETURN;
 
 
URDERR$ACT:                          # UNRECOVERABLE READ ERROR #
      ERRCODE = S"UNRECV$RD";
      LBERR(ERRCODE);
      RETURN;
 
UWTERR$ACT:                          # UNRECOVERABLE WRITE ERROR #
      ERRCODE = S"UNRECV$WRT";
      LBERR(ERRCODE);
      RETURN;
 
MHDERR$ACT:                          # MSF HARDWARE PROBLEM #
      ERRCODE = S"M86$HARDWR";
      LBERR(ERRCODE);
      RETURN;
SMOFF$ACT:
 
      ERRCODE = S"SM$OFF";
      LBERR(ERRCODE);
      RETURN;
 
 
      END  # LBRESP #
 
    TERM
PROC LBRMCSU;
# TITLE LBRMCSU - REMOVE A *SM* FROM A FAMILY CATALOG.                 #
 
      BEGIN  # LBRMCSU #
 
#
**    LBRMCSU - REMOVE A *SM* FROM A FAMILY CATALOG.
*
*     THIS PROC UPDATES THE CATALOG FOR A FAMILY TO REMOVE
*     ASSIGNMENT OF A PARTICULAR CSU.
*
*     PROC LBRMCSU.
*
*     ENTRY     CRACKED AND SYNTAX CHECKED DIRECTIVE
*               PARAMETERS SET UP IN COMMON AREA DEFINED
*               IN *COMTLBP*.
*
*     EXIT      *SM* REMOVED FROM FAMILY OR ERROR CONDITION.
*
*     NOTES     PROC *LBRMCSU* SEARCHES THE SMMAP FOR THE *SM*
*               SPECIFIED TO VERIFY THAT NO CUBES ARE ASSIGNED
*               TO THE FAMILY.  A REQUEST IS THEN SENT TO EXEC
*               TO UPDATE THE CATALOG TO REFLECT THE REMOVAL OF
*               THE *SM*.
#
 
#
****  PROC LBRMCSU - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC CALL3;                  # ISSUES TYPE 3 CALLSS TO EXEC #
        PROC LBERR;                  # *SSLABEL* ERROR PROCESSOR #
        PROC LBRESP;                 # PROCESSES RESPONSE FROM EXEC #
        PROC SERCSU;                 # SEARCHES THE SMMAP #
        END
 
#
****  PROC LBRMCSU - XREF LIST END.
#
 
      DEF LISTCON    #0#;            # DO NOT LIST COMDECKS #
*CALL COMBFAS
*CALL COMBCPR
*CALL COMTERR
*CALL COMTLAB
*CALL COMTLBP
 
      ITEM FLAG       I;             # ERROR FLAG #
      ITEM REQCODE    U;             # REQUEST CODE #
      ITEM RESP$CODE  U;             # RESPONSE CODE FROM EXEC #
      ITEM SERTYPE    S:SERCH$TYPE;  # SMMAP SEARCH TYPE #
 
 
      ARRAY PK$CSU$ENT [0:0] P(4);   # *PICK* SMMAP ENTRY #
        BEGIN
        ITEM PK$MAPENT  C(00,00,30);  # THREE WORD MAP ENTRY #
        ITEM PK$Y       U(03,00,30);  # Y COORDINATE #
        ITEM PK$Z       U(03,30,30);  # Z COORDINATE #
        END
 
 
                                               CONTROL EJECT;
 
#
*     SEARCH SMMAP FOR CUBES ASSIGNED TO FAMILY AND UPDATE CATALOG.
#
 
      SERTYPE = S"ASGN$FAM";
      SERCSU(SERTYPE,0,0,0,0,LBARG$FM[0],LBARG$SB[0], PK$CSU$ENT[0],
        FLAG);
 
      IF FLAG EQ OK
      THEN                           # ENTRY FOUND #
        BEGIN
        ERRCODE = S"CB$ASGN$SB";
        LBERR(ERRCODE);              # DO ERROR PROCESSING #
        RETURN;
        END
 
      REQCODE = REQTYP3"RMV$CSU";
      CALL3(REQCODE,0,0,0,RESP$CODE);  # REMOVE *SM* FROM FAMILY #
      IF RESP$CODE NQ RESPTYP3"OK3"
      THEN                           # PROCESS THE RESPONSE #
        BEGIN
        LBRESP(RESP$CODE,TYP"TYP3");
        END
 
      RETURN;
 
      END  # LBRMCSU #
 
    TERM
PROC LBRMCUB;
# TITLE LBRMCUB - REMOVES CUBES FROM FAMILY/POOL/RESERVED AREA.       #
 
      BEGIN  # LBRMCUB #
 
#
**    LBRMCUB - REMOVES CUBES FROM FAMILY/POOL/RESERVED AREA.
*
*     THIS PROC REMOVES ASSIGNED CUBES FROM A FAMILY, POOL,
*     OR RESERVED AREA OF THE CSU.
*
*     PROC LBRMCUB.
*
*     ENTRY     CRACKED AND SYNTAX CHECKED DIRECTIVE
*               PARAMETERS SET UP IN COMMON AREA DEFINED
*               IN *COMTLBP*.
*
*     EXIT      SPECIFIED NUMBER OR LOCATIONS OF CUBES HAVE
*               BEEN REMOVED, OR ERROR CONDITION.
*
*     NOTES     PROC *LBRMCUB* REMOVES CUBES FROM A FAMILY,
*               POOL, OR RESERVED AREA BY CHANGING THEIR STATUS
*               FROM *ASSIGNED* TO *UNASSIGNED*.  IF THE *N*
*               OPTION IS USED THE SMMAP IS SEARCHED FOR EMPTY
*               CUBES WITH THE APPROPRIATE ASSIGNMENT.  IF THE
*               LOCATION OPTION IS USED, THE SMMAP IS CHECKED
*               TO ENSURE THAT THE SPECIFIC CUBES ARE EMPTY AND
*               ASSIGNED AS EXPECTED.  A REQUEST IS THEN SENT
*               TO EXEC TO REMOVE THE CUBES FROM ASSIGNMENT.
#
 
#
****  PROC LBRMCUB - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC CALL3;                  # ISSUES TYPE 3 CALLSS TO EXEC #
        PROC LBERR;                  # *SSLABEL* ERROR PROCESSOR #
        PROC LBRESP;                 # RESPONSE CODE PROCESSOR #
        PROC MFLUSH;                 # FLUSHES MAP BUFFER #
        PROC SERCSU;                 # SEARCHES THE SMMAP #
        PROC SETCORD;                # SETS UP Y AND Z COORDINATES #
        END
 
#
****  PROC LBRMCUB - XREF LIST END.
#
 
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS #
*CALL COMBFAS
*CALL COMBCPR
*CALL COMBMAP
*CALL COMTERR
*CALL COMTLAB
*CALL COMTLBP
 
      ITEM FLAG       I;             # ERROR FLAG #
      ITEM I          I;             # LOOP VARIABLE #
      ITEM LOC$OPTION B;             # TRUE IF *LOC* OPTION FALSE IF
                                       *N* OPTION #
      ITEM REQCODE    U;             # RESPONSE CODE FROM EXEC #
      ITEM RESP$CODE  U;             # RESPONSE CODE FROM EXEC #
      ITEM SERTYPE    S:SERCH$TYPE;  # TYPE OF SEARCH THROUGH SMMAP #
      ITEM SP$CODE    U;             # CODE FOR CUBE/CARTRIDGE
                                       ASSIGNMENT #
      ITEM SP$FAM     C(7);          # SPECIFIED FAMILY NAME #
      ITEM SP$SUB     U;             # SPECIFIED SUB FAMILY #
      ITEM SP$VSN     C(8);          # SPECIFIED CARTRIDGE *CSND* #
      ITEM SP$Y       U;             # Y COORDINATE #
      ITEM SP$Z       U;             # Z COORDINATE #
 
 
      ARRAY PK$CSU$ENT [0:0] P(4);   # *PICK* SMMAP ENTRY #
        BEGIN
        ITEM PK$MAPENT  C(00,00,30);  # THREE WORD MAP ENTRY #
        ITEM PK$Y       U(03,00,30);  # Y COORDINATE #
        ITEM PK$Z       U(03,30,30);  # Z COORDINATE #
        END
 
 
                                               CONTROL EJECT;
 
#
*     CHECK FOR *N* OPTION OR *LOC* OPTION.
#
 
      LOC$OPTION = FALSE;
      IF LBARG$YI[0] NQ -1 OR LBARG$ZI[0] NQ -1
      THEN                           # *LOC* OPTION SPECIFIED #
        BEGIN
        SETCORD;                     # BUILD Y,Z MATRIX #
        LOC$OPTION = TRUE;
        END
 
#
*     PROCESS EACH OF THE *N* CUBES SPECIFIED.
#
 
      SP$VSN = " ";
      SP$FAM = " ";
      SP$SUB = 0;
      FASTFOR I = 1 STEP 1 UNTIL LBARG$N[0]
      DO
        BEGIN  # PROCESS *N* CUBES #
        IF NOT LOC$OPTION
        THEN
          BEGIN  # *N* OPTION #
          SERTYPE = S"ASSIGN";       # SEARCH FOR ASSIGNED CUBE #
          IF LBARG$PK[0] EQ "F"
          THEN                       # REMOVE CUBE FROM FAMILY #
            BEGIN
            SP$CODE = CUBSTAT"SUBFAM";
            SP$FAM = LBARG$FM[0];
            SP$SUB = LBARG$SB[0];
            END
 
          IF LBARG$PK[0] EQ "P"
          THEN                       # REMOVE CUBE FROM POOL #
            BEGIN
            SP$CODE = CUBSTAT"SCRPOOL";
            END
 
          IF LBARG$PK[0] EQ "R"
          THEN                       # REMOVE FROM RESERVED AREA #
            BEGIN
            SP$CODE = CUBSTAT"ALTCSU";
            END
 
          END  # *N* OPTION #
 
        ELSE
          BEGIN  # *LOC* OPTION #
          SERTYPE = S"LOC";          # LOOK FOR SPECIFIC LOCATION #
          SP$Y = Y$COORD[I];
          SP$Z = Z$COORD[I];
          END  # *LOC* OPTION #
 
#
*     SEARCH THE SMMAP FOR THE SPECIFIED ENTRY.
#
 
        SERCSU(SERTYPE,SP$Y,SP$Z,SP$CODE,SP$VSN,SP$FAM,SP$SUB,
          PK$CSU$ENT[0],FLAG);
        IF FLAG NQ OK
        THEN                         # NO EMPTY CUBES #
          BEGIN
          NUMDONE = I - 1;
          ERRCODE = S"NO$EMPCB";
          LBERR(ERRCODE);
          RETURN;
          END
 
#
*     CHECK CUBE ASSIGNMENT.
#
 
        P<SMUMAP> = LOC(PK$CSU$ENT[0]);
        IF CM$CSND[0] NQ " "
        THEN                         # CUBE NOT EMPTY #
          BEGIN
          NUMDONE = I - 1;
          ERRCODE = S"CB$NOT$EMP";
          LBERR(ERRCODE);            # DO ERROR PROCESSING #
          RETURN;
          END
 
        IF LBARG$PK[0] EQ "F"        ##
          AND CM$CODE[0] EQ CUBSTAT"SUBFAM"  ##
          AND CM$FMLYNM[0] EQ LBARG$FM[0]  ##
          AND CM$SUB[0] EQ LBARG$SB[0]
        THEN                         # REMOVE CUBE FROM FAMILY #
          BEGIN
          REQCODE = REQTYP3"RMV$CUBE";
          END
 
        ELSE
          BEGIN  # REMOVE FROM POOL/RESERVED AREA #
          IF (LBARG$PK[0] EQ "P" AND CM$CODE[0] EQ CUBSTAT"SCRPOOL")
            OR (LBARG$PK[0] EQ "R" AND CM$CODE[0] EQ CUBSTAT"ALTCSU")
            OR (LBARG$PK[0] EQ "R" AND CM$CODE[0] EQ CUBSTAT"SYSUSE")
            THEN
            BEGIN
            REQCODE = REQTYP3"UPD$MAP";  # UPDATE SMMAP ENTRY #
            CM$CODE[0] = CUBSTAT"UNASGN";
            CM$FLAG1[0] = FALSE;     # CLEAR ERROR FLAG IN MAP ENTRY #
            END
 
          ELSE                       # PROCESS ERROR CONDITION #
            BEGIN
            NUMDONE = I - 1;
            ERRCODE = S"UNX$CB$ASN";
            LBERR(ERRCODE);          # DO ERROR PROCESSING #
            RETURN;
            END
 
          END  # REMOVE FROM POOL/RESERVED AREA #
 
#
*     ISSUE TYPE 3 CALLSS REQUEST AND DO ERROR PROCESSING IF AN
*     ERROR STATUS IS RETURNED BY EXEC.
#
 
        CALL3(REQCODE,PK$CSU$ENT[0],0,0,RESP$CODE);
        IF RESP$CODE NQ RESPTYP3"OK3"
        THEN                         # PROCESS THE RESPONSE #
          BEGIN
          LBRESP(RESP$CODE,TYP"TYP3");
          RETURN;
          END
 
        MFLUSH;
        END  # PROCESS *N* CUBES #
 
      RETURN;
 
      END  # LBRMCUB #
 
    TERM
PROC LBRMMSC;
# TITLE LBRMMSC - REMOVES CARTRIDGES FROM A FAMILY OR POOL.           #
 
      BEGIN  # LBRMMSC #
 
#
**    LBRMMSC - REMOVES CARTRIDGES FROM A FAMILY OR POOL.
*
*     THIS PROC LOCATES AND REMOVES EMPTY CARTRIDGES.
*
*     PROC LBRMMSC.
*
*     ENTRY     CRACKED AND SYNTAX CHECKED DIRECTIVE
*               PARAMETERS SET UP IN COMMON AREA DEFINED
*               IN *COMTLBP*.
*               (LB$BUFP) = FWA OF A BUFFER 1101B WORDS LONG.
*
*     EXIT      CARTRIDGES REMOVED OR ERROR CONDITION.
*
*     MESSAGES  FAMILY NOT FOUND.
*               CARTRIDGE NOT EMPTY, VSN.
*
*     NOTES     PROC *LBRMMSC* OPENS THE CATALOG AND SEARCHES IT
*               FOR CARTRIDGES FREE IF NO CSN
*               IS SPECIFIED.  IF CSN IS SPECIFIED THE SMMAP IS
*               SEARCHED FOR A MATCHING CSN.  IF THE *LOST* OPTION
*               IS SPECIFIED, THE CARTRIDGE IS REMOVED FROM THE
*               FAMILY AFTER VERIFYING THAT IT IS MISSING AND
*               ASSIGNED TO THE FAMILY.  THE CARTRIDGE IS LOADED
*               AND ITS LABEL IS CHECKED.  A NEW SCRATCH LABEL IS
*               WRITTEN AND THE CARTRIDGE IS UNLOADED TO THE POOL
*               OR OUTPUT DRAWER, AS SPECIFIED BY *PT*.
#
 
#
****  PROC LBRMMSC - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC CALL3;                  # ISSUES TYPE 3 EXEC CALLSS #
        PROC CALL4;                  # ISSUES TYPE 4 EXEC CALLSS #
        PROC CCLOSE;                 # CLOSE SFMCAT #
        PROC CGETFCT;                # GETS AN FCT ENTRY #
        PROC COPEN;                  # OPENS THE CATALOG #
        PROC DLABFLD;                # DISPLAY CARTRIDGE LABEL FIELDS #
        PROC GENLAB;                 # GENERATES A NEW LABEL #
        PROC LBERR;                  # *SSLABEL* ERROR PROCESSOR #
        PROC LBRESP;                 # RESPONSE CODE PROCESSOR #
        PROC LOFPROC;                # LIST OF FILES PROCESSOR #
        PROC MCLOSE;                 # CLOSE SMMAP #
        PROC MESSAGE;                # DISPLAYS MESSAGE #
        PROC MFLUSH;                 # FLUSH MAP BUFFER #
        PROC MOPEN;                  # OPEN SMMAP #
        PROC RESTPFP;                # RESTORE USER-S *PFP* AND ABORT
                                       OR RETURN #
        PROC SERAST;                 # SEARCH FOR EMPTY CARTRIDGES #
        PROC SERCSU;                 # SEARCHES THE SMMAP #
        PROC SETPFP;                 # SET FAMILY AND USER INDEX #
        FUNC XCOD;                   # INTEGER TO DISPLAY CONVERSION #
        END
 
#
****  PROC LBRMMSC - XREF LIST END.
#
 
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS #
*CALL COMBFAS
*CALL COMBCMS
*CALL,COMBCMD
*CALL COMBCPR
*CALL COMBLBL
*CALL COMBMAP
*CALL COMBMCT
*CALL COMBPFP
*CALL COMSPFM
*CALL COMTERR
*CALL COMTLAB
*CALL COMTLBP
 
      ITEM CART$CSN   C(20);         # CARTRIDGE SERIAL NUMBER #
      ITEM ERR$CNT    I;             # ERROR COUNT #
      ITEM FCTORD     U;             # EMPTY CARTRIDGE FCT ORDINAL #
      ITEM FLAG       I;             # ERROR FLAG #
      ITEM HR$ERR     I;             # HARD READ ERRORS #
      ITEM I          I;             # LOOP VARIABLE #
      ITEM LD$CNT     I;             # LOAD COUNT #
      ITEM LD$ERR     I;             # LOAD ERRORS #
      ITEM PS$CNT     I;             # PASS COUNT #
      ITEM REQCODE    I;             # REQUEST CODE #
      ITEM RESP$CODE  I;             # RESPONSE CODE #
      ITEM SERTYPE    S:SERCH$TYPE;  # SEARCH TYPE #
      ITEM SGROUP     I;             # SAVE GROUP PARAMETER #
      ITEM SLOT       I;             # DRAWER NUMBER #
      ITEM SP$CODE    I;             # SPECIFIED CODE #
      ITEM SP$Y       I;             # SPECIFIED Y #
      ITEM SP$Z       I;             # SPECIFIED Z #
      ITEM SR$ERR     I;             # SOFT READ ERRORS #
      ITEM STR$RD     I;             # STRIPES READ #
      ITEM STR$WR     I;             # STRIPES WRITTEN #
      ITEM STR$DM     I;             # STRIPES DEMARKED #
      ITEM SW$ERR     I;             # SOFT WRITE ERRORS #
 
      ARRAY CMAP$NM [0:0] P(1);      # BUILD SMMAP NAME #
        BEGIN
        ITEM CMAP$NAME  C(00,00,07);  # SMMAP FILE NAME #
        ITEM CMAP$IN    C(00,00,05);  # FIRST 5 CHARACTERS #
        ITEM CMAP$ID    C(00,30,01);  # SM-ID #
        ITEM CMAP$Z     C(00,36,24) = [0];  # ZERO FILL #
        END
 
      ARRAY MSFCATNM [0:0] P(1);     # CATALOG NAME #
        BEGIN
        ITEM MSFCAT$NM  C(00,00,06);  # FIRST 6 CHARACTERS #
        ITEM MSFCAT$LST C(00,36,01);  # LAST CHARACTER #
        END
 
      ARRAY PK$CSU$ENT [0:0] P(4);   # *PICK* SMMAP ENTRY #
        BEGIN
        ITEM PK$MAPENT  C(00,00,30);  # THREE WORD SMMAP ENTRY #
        ITEM PK$Y       U(03,00,30);  # Y COORDINATE #
        ITEM PK$Z       U(03,30,30);  # Z COORDINATE #
        END
 
 
      ARRAY PT$CSU$ENT [0:0] P(5);   # *PUT* SMMAP ENTRY #
        BEGIN
        ITEM PT$MAPENT  C(00,00,30);  # THREE WORD MAP ENTRY #
        ITEM PT$Y       U(03,00,30);  # Y COORDINATE #
        ITEM PT$Z       U(03,30,30);  # Z COORDINATE #
        ITEM PT$GR      U(04,00,07);  # GROUP #
        ITEM PT$GRT     U(04,07,04);  # GROUP ORDINAL #
        END
 
 
                                               CONTROL EJECT;
 
#
*     INITIALIZE POINTERS AND MISCELLANEOUS ITEMS.
#
 
      PFP$WRD0[0] = 0;
      PFP$FG1[0] = TRUE;
      PFP$FG4[0] = TRUE;
      P<FCT> = LB$BUFP;
      P<SMUMAP> = LOC(PK$CSU$ENT[0]);
      SGROUP = LBARG$GR[0];
 
#
*     REMOVE EACH OF *N* CARTRIDGES FROM THE FAMILY OR POOL.
#
 
      SLOWFOR I = 1 STEP 1 UNTIL LBARG$N[0]
      DO
        BEGIN  # REMOVE CARTRIDGE #
        LBARG$GR[0] = SGROUP;
 
#
*     PROCESSING FOR *CSN NOT SPECIFIED*.
#
 
        P<SMUMAP> = LOC(PT$CSU$ENT[0]);
        IF LBARG$C[0] EQ 0
        THEN
          BEGIN  # CSN NOT SPECIFIED #
 
          IF LBARG$PK[0] EQ "F"
          THEN
            BEGIN  # SELECT CARTRIDGE FROM FAMILY #
 
#
*     OPEN CATALOG AND CHECK ERROR STATUS.
#
 
            PFP$FAM[0] = LBARG$FM[0];
            PFP$UI[0] = DEF$UI + LBARG$SB[0];
            SETPFP(PFP);
            IF PFP$STAT[0] NQ 0
            THEN                     # FAMILY NOT FOUND #
              BEGIN
              LBMSG$LN[0] = " FAMILY NOT FOUND.";
              MESSAGE(LBMSG[0],SYSUDF1);
              RESTPFP(PFP$ABORT);    # RESTORE USER-S *PFP* AND ABORT #
              END
 
            MSFCAT$NM[0] = SFMCAT;   # SET UP CATALOG NAME #
            MSFCAT$LST[0] = XCOD(LBARG$SB[0]);
            COPEN(LBARG$FM[0],LBARG$SB[0],MSFCATNM[0],"RM",TRUE,FLAG);
            IF FLAG EQ CMASTAT"NOERR"
            THEN
              BEGIN
              LOFPROC(OCT$LFN[1]);   # ADD LFN TO LIST OF FILES #
              END
 
            IF FLAG NQ CMASTAT"NOERR" AND FLAG NQ CMASTAT"FOPEN"
            THEN                     # ERROR CONDITION OTHER THAN
                                       *CATALOG ALREADY OPEN* #
              BEGIN
              LBRESP(FLAG,0);
              RETURN;
              END
 
 
#
*     SEARCH *AST* FOR EMPTY CARTRIDGE.
#
 
            SERAST(FCTORD,FLAG);
            IF FLAG NQ OK
            THEN                     # NO EMPTY CARTRIDGE FOUND #
              BEGIN
              NUMDONE = I - 1;
              ERRCODE = S"NO$EMP$CR";
              LBERR(ERRCODE);        # DO ERROR PROCESSING #
              RETURN;
              END
 
#
*     GET FCT ENTRY OF EMPTY CARTRIDGE AND SET LOAD, PASS,
*     AND ERROR COUNTS FOR NEW LABEL.
#
 
            CGETFCT(LBARG$FM[0],LBARG$SB[0],LBARG$SMID[0],FCTORD,
              LB$BUFP,0,FLAG);
            IF FLAG NQ OK
            THEN                     # PROCESS ERROR STATUS #
              BEGIN
              LBRESP(FLAG,0);
              RETURN;
              END
 
            LD$CNT = FCT$CRLD[0];
            HR$ERR = FCT$HRDE[0];
            SW$ERR = FCT$SWRE[0];
            SR$ERR = FCT$SRDE[0];
            STR$RD = FCT$STRD[0];
            STR$WR = FCT$STWR[0];
            STR$DM = FCT$STDM[0];
 
#
*     GET SMMAP ENTRY.
#
 
            SERTYPE = S"LOC";
            SERCSU(SERTYPE,FCT$Y[0],FCT$Z[0],0,0,0,0, PK$CSU$ENT[0],
              FLAG);
            CCLOSE(LBARG$FM[0],LBARG$SB[0],0,FLAG);
            END  # SELECT CARTRIDGE FROM FAMILY #
 
          IF LBARG$PK[0] EQ "P"
          THEN
            BEGIN  # SELECT CARTRIDGE FROM POOL #
            SERTYPE = S"CART$POOL";
            SERCSU(SERTYPE,0,0,0,0,0,0,PK$CSU$ENT[0],FLAG);
            IF FLAG NQ OK
            THEN                     # POOL EMPTY #
              BEGIN
              NUMDONE = I - 1;
              ERRCODE = S"NO$CR$PL";
              LBERR(ERRCODE);        # DO ERROR PROCESSING #
              RETURN;
              END
 
            CMAP$ID[0] = LBARG$SM[0];
            CMAP$IN[0] = SMMAP;
            END  # SELECT CARTRIDGE FROM POOL #
 
          END  # VSN NOT SPECIFIED #
 
#
*     PROCESSING FOR *VSN SPECIFIED*.
#
 
        IF LBARG$C[0] NQ 0
        THEN
          BEGIN  # VSN SPECIFIED #
          SERTYPE = S"CSN$MATCH";    # SEARCH FOR VSN #
          SERCSU(SERTYPE,0,0,0,LBARG$C[0],0,0,PK$CSU$ENT[0],FLAG);
          IF FLAG NQ 0
          THEN                       # VSN NOT FOUND #
            BEGIN
            ERRCODE = S"CSN$NOTFND";
            LBERR(ERRCODE);          # DO ERROR PROCESSING #
            RETURN;
            END
 
#
*     OPEN CATALOG AND CHECK ERROR STATUS.
#
 
          IF CM$CODE[0] EQ CUBSTAT"SUBFAM"
          THEN
            BEGIN  # OPEN CATALOG #
            PFP$FAM[0] = CM$FMLYNM[0];
            PFP$UI[0] = DEF$UI + CM$SUB[0];
            SETPFP(PFP);
            IF PFP$STAT[0] NQ 0
            THEN                     # FAMILY NOT FOUND #
              BEGIN
              LBMSG$LN[0] = " FAMILY NOT FOUND.";
              MESSAGE(LBMSG[0],SYSUDF1);
              RESTPFP(PFP$ABORT);    # RESTORE USER-S *PFP* AND ABORT #
              END
 
            MSFCAT$NM[0] = SFMCAT;   # SET UP CATALOG NAME #
            MSFCAT$LST[0] = XCOD(CM$SUB[0]);
            COPEN(CM$FMLYNM[0],CM$SUB[0],MSFCATNM[0],"RM",TRUE,FLAG);
            IF FLAG EQ CMASTAT"NOERR"
            THEN
              BEGIN
              LOFPROC(OCT$LFN[1]);   # ADD LFN TO LIST OF FILES #
              END
 
            IF FLAG NQ CMASTAT"NOERR" AND FLAG NQ CMASTAT"FOPEN"
            THEN                     # ERROR CONDITION OTHER THAN
                                       *CATALOG ALREADY OPEN* #
              BEGIN
              LBRESP(FLAG,0);
              RETURN;
              END
 
            END  # OPEN CATALOG #
 
          END  # VSN SPECIFIED #
 
#
*     *LOST* OPTION PROCESSING.
#
 
        IF LBARG$LT[0] NQ 0
        THEN
          BEGIN  # *LOST* OPTION SPECIFIED #
          IF CM$CODE[0] NQ CUBSTAT"SUBFAM"
          THEN                       # NOT A FAMILY CARTRIDGE #
            BEGIN
            ERRCODE = S"UNX$CR$ASN";
            LBERR(ERRCODE);
            RETURN;
            END
 
#
*     GET FCT ENTRY FOR SPECIFIED CARTRIDGE.
#
 
          CGETFCT(CM$FMLYNM[0],CM$SUB[0],LBARG$SMID[0],CM$FCTORD[0],
            LB$BUFP,0,FLAG);
          IF FLAG NQ OK
          THEN                       # PROCESS ERROR STATUS #
            BEGIN
            LBRESP(FLAG,0);
            RETURN;
            END
 
          IF NOT FCT$LCF[0]
          THEN                       # FCT *LOST* FLAG NOT SET #
            BEGIN
            ERRCODE = S"LOST$NSET";
            LBERR(ERRCODE);          # DO ERROR PROCESSING #
            RETURN;
            END
 
          REQCODE = REQTYP4"LOAD$CART";
          CALL4(REQCODE,DRD$NUM,CART$CSN,PK$Y[0],PK$Z[0],RESP$CODE);
          IF RESP$CODE EQ RESPTYP4"CELL$EMP"
          THEN
            BEGIN  # REMOVE LOST CARTRIDGE FROM FAMILY #
            REQCODE = REQTYP3"RMV$CART";
            CALL3(REQCODE,PK$CSU$ENT,0,0,RESP$CODE);
            IF RESP$CODE EQ RESPTYP3"MSC$NEMPTY"
            THEN
              BEGIN
              LBMSG$LINE[0] = " CARTRIDGE NOT EMPTY,         .";
              LBMSG$CSN[0] = CM$CSND[0];
              MESSAGE(LBMSG$BUF[0],SYSUDF1);
              TEST I;
              END
 
            IF RESP$CODE NQ RESPTYP3"OK3"
            THEN
              BEGIN
              LBRESP(RESP$CODE,TYP"TYP3");
              END
 
            RETURN;
            END  # REMOVE LOST CARTRIDGE FROM FAMILY #
 
          ELSE
            BEGIN  # PROCESS ERROR STATUS #
            IF RESP$CODE EQ RESPTYP4"OK4"
            THEN
              BEGIN
              REQCODE = REQTYP4"UNLD$CART";
              CALL4(REQCODE,0,0,PK$Y[0],PK$Z[0],RESP$CODE);
              IF RESP$CODE NQ RESPTYP4"OK4"
              THEN
                BEGIN
                LBRESP(RESP$CODE,TYP"TYP4");
                RETURN;
                END
 
              ERRCODE = S"LOST$SET";
              LBERR(ERRCODE);
              RETURN;
              END
 
            ELSE                     # PROCESS DETAIL STATUS #
              BEGIN
              LBRESP(RESP$CODE,TYP"TYP4");
              RETURN;
              END
 
            END  # PROCESS ERROR STATUS #
 
          END  # *LOST* OPTION SPECIFIED #
 
#
*     CHECK CARTRIDGE ASSIGNMENT AND *PT* OPTION.
#
 
        IF CM$CODE[0] EQ CUBSTAT"SCRPOOL" AND LBARG$PT[0] EQ "P"
        THEN                         # IGNORE THE CARTRIDGE #
          BEGIN
          TEST I;
          END
 
#
*     FIND EMPTY OUTPUT DRAWER OR CUBE IN POOL.
#
 
        IF LBARG$PT[0] EQ "D"
        THEN
          BEGIN  # FIND EMPTY OUTPUT DRAWER #
          P<SMUMAP> = LOC(PT$CSU$ENT[0]);
          PT$Y[0] = 12;
          PT$Z[0] = 0;
          CM$FCTORD[0] = 0;
          CM$FMLYNM[0] = "";
          END  # FIND EMPTY OUTPUT DRAWER #
 
        ELSE
          BEGIN  # FIND EMPTY CUBE IN POOL #
          SERTYPE = S"ASSIGN";
          SP$CODE = CUBSTAT"SCRPOOL";
          SERCSU(SERTYPE,0,0,SP$CODE,"","",0,PT$CSU$ENT[0],FLAG);
          IF FLAG NQ 0
          THEN                       # NO EMPTY CUBES IN FAMILY/POOL #
            BEGIN
            NUMDONE = I - 1;
            ERRCODE = S"NO$EMPCBFP";
            LBERR(ERRCODE);          # DO ERROR PROCESSING #
            RETURN;
            END
 
          END  # FIND EMPTY CUBE IN POOL #
 
#
*     GET CARTRIDGE AND CHECK ITS LABEL.
#
 
        REQCODE = REQTYP4"LOAD$CART";
        CALL4(REQCODE,DRD$NUM,CART$CSN,PK$Y[0],PK$Z[0],RESP$CODE);
        IF RESP$CODE NQ RESPTYP4"OK4"  ##
        THEN
          BEGIN  # LOAD FAILS #
          IF RESP$CODE EQ RESPTYP4"CELL$EMP"
          THEN
            BEGIN  # SET UP ERROR FLAGS #
            P<SMUMAP> = LOC(PK$CSU$ENT[0]);
            IF CM$CODE[0] EQ CUBSTAT"SCRPOOL"
            THEN                     # SET ERROR FLAG IN SMMAP ENTRY #
              BEGIN
              CM$FLAG1[0] = TRUE;
              CALL3(REQTYP3"UPD$MAP",PK$CSU$ENT[0],0,0,FLAG);
              END
 
            ELSE                     # SET LOST FLAG IN CATALOG ENTRY #
              BEGIN
              CALL3(REQTYP3"UPD$CAT",PK$CSU$ENT[0],UCF"LOST",1,FLAG);
              END
 
            NUMDONE = I - 1;
            ERRCODE = S"CR$NOTFND";  # CARTRIDGE NOT FOUND #
            LBERR(ERRCODE);
            IF FLAG NQ RESPTYP3"OK3"
            THEN
              BEGIN
              LBRESP(FLAG,TYP"TYP3");
              RETURN;
              END
 
            RETURN;
            END  # SET UP ERROR FLAGS #
 
          ELSE                       # PROCESS RESPONSE CODE #
            BEGIN
            LBRESP(RESP$CODE,TYP"TYP4");
            IF RESP$CODE EQ RESPTYP4"CART$LB$ERR"  ##
              OR RESP$CODE EQ RESPTYP4"UNK$CART"
            THEN            # UNLOAD CARTRIDGE TO EXIT TRAY #
              BEGIN
              CALL4(REQTYP4"UNLD$CART",0,0,SM$EXIT$TY,SM$TY$Z,  ##
                RESP$CODE);
              END
 
            RETURN;
            END
 
          END  # LOAD FAILS #
 
 
        P<SMUMAP> = LOC(PK$CSU$ENT[0]);
        P<LABEL$CART> = OLDLABP;
 
#
*     VERIFY VSN, Y, Z IN THE LABEL.
#
 
        IF LAB$CSND[0] NQ CM$CSND[0]  ##
          AND(LAB$Y[0] NQ PK$Y[0] OR LAB$Z[0] NQ PK$Z[0])
        THEN
          BEGIN  # TEST Y,Z #
          REQCODE = REQTYP4"UNLD$CART";
          CALL4(REQCODE,0,0,SM$EXIT$TY,SM$TY$Z,RESP$CODE);
          IF RESP$CODE NQ RESPTYP4"OK4"
          THEN
            BEGIN
            LBRESP(RESP$CODE,TYP"TYP4");
            RETURN;
            END
 
          ERRCODE = S"M86$HARDWR";   # MSF HARDWARE PROBLEM #
          LBERR(ERRCODE);
          RETURN;
          END  # TEST Y,Z #
 
        IF CM$CODE[0] EQ CUBSTAT"SCRPOOL"
        THEN                         # CARTRIDGE FROM POOL #
          BEGIN
          LD$CNT = LAB$CRLD[0];      # USE OLD LOAD/PASS/ERROR COUNTS #
          LD$ERR = LAB$LDER[0];
          SR$ERR = LAB$SRDE[0];
          SW$ERR = LAB$SWRE1[0];
          B<28,4>SW$ERR = LAB$SWRE[0];
          HR$ERR = LAB$HRDE[0];
          STR$RD = LAB$STRD[0];
          STR$WR = LAB$STWR1[0];
          B<36,24>STR$WR = LAB$STWR[0];
          STR$DM = LAB$STDM[0];
          END
 
#
*     CHECK IF CSU, Y, Z, FAMILY, AND SUBFAMILY DO NOT
*     AGREE IN OLDLABEL AND SMMAP ENTRY.
#
 
        IF LAB$SMID[0] NQ LBARG$SMID[0]
          OR LAB$Y[0] NQ PK$Y[0]
          OR LAB$Z[0] NQ PK$Z[0]
          OR LAB$FMLY[0] NQ CM$FMLYNM[0]
          OR LAB$SF[0] NQ CM$SUB[0]
        THEN
          BEGIN  # SET UP ERROR FLAGS #
          IF CM$CODE[0] EQ CUBSTAT"SCRPOOL"
          THEN                       # SET ERROR FLAG IN SMMAP ENTRY #
            BEGIN
            CM$FLAG1[0] = TRUE;
            CALL3(REQTYP3"UPD$MAP",PK$CSU$ENT[0],0,0,FLAG);
            END
 
          ELSE                       # SET LOST FLAG IN CATALOG ENTRY #
            BEGIN
            CALL3(REQTYP3"UPD$CAT",PK$CSU$ENT[0],UCF"LOST",1,FLAG);
            END
 
          IF FLAG NQ RESPTYP3"OK3"
          THEN
            BEGIN
            LBRESP(FLAG,TYP"TYP3");
            REQCODE = REQTYP4"UNLD$CART";
            CALL4(REQCODE,0,0,SM$EXIT$TY,SM$TY$Z,RESP$CODE);
            IF RESP$CODE NQ RESPTYP4"OK4"
            THEN
              BEGIN
              LBRESP(RESP$CODE,TYP"TYP4");
              RETURN;
              END
 
            RETURN;
            END
 
          DLABFLD;
          REQCODE = REQTYP4"UNLD$CART";
          CALL4(REQCODE,0,0,SM$EXIT$TY,SM$TY$Z,RESP$CODE);
          IF RESP$CODE NQ RESPTYP4"OK4"
          THEN
            BEGIN
            LBRESP(RESP$CODE,TYP"TYP4");
            RETURN;
            END
 
          ERRCODE = S"UNXP$CYZFS";
          LBERR(ERRCODE);            # DO ERROR PROCESSING #
          RETURN;
          END  # SET UP ERROR FLAGS #
 
#
*     GENERATE LABEL AND UPDATE SMUMAP.
#
 
        GENLAB(LABTYPE"SCR$LAB",PT$CSU$ENT[0],LD$CNT,LD$ERR,  ##
          SR$ERR,SW$ERR,HR$ERR,STR$RD,STR$WR,STR$DM);
        P<LABEL$CART> = NEWLABP;
        IF B<0,8>LAB$CSN[0] NQ X"C9"      ##
          OR B<8,8>LAB$CSN[0] NQ X"C2" OR B<16,8>LAB$CSN[0] NQ X"D4"
        THEN             # CARTRIDGE IS NOT IBM #
          BEGIN
          LAB$CCOD[0] = OTHCART;
          END
 
        ELSE
          BEGIN
          LAB$CCOD[0] = IBMCART;
          END
 
        LAB$CRLD[0] = LAB$CRLD[0] + 1;  # UPDATE LOAD/PASS COUNTS #
        IF LBARG$PT[0] EQ "D"
        THEN                         # CLEAR CSU, Y, Z FIELDS #
          BEGIN
          LAB$SMID[0] = 0;
          LAB$Y[0] = 12;             # SET TO CAS EXIT #
          LAB$Z[0] = 0;
          END
 
        P<SMUMAP>= LOC(PK$CSU$ENT[0]);
        IF CM$CODE[0] EQ CUBSTAT"SUBFAM"
        THEN                         # ASSIGNED TO FAMILY #
          BEGIN
          REQCODE = REQTYP3"RMV$CART";
          END
 
        ELSE                         # ASSIGNED TO POOL #
          BEGIN
          REQCODE = REQTYP3"UPD$MAP";
          CM$CSND[0] = " ";          # REMOVE VSN FROM SMMAP ENTRY #
          CM$CCOD[0] = " ";
          CM$FLAG1[0] = FALSE;       # CLEAR ERROR FLAG IN MAP ENTRY #
          END
 
        CALL3(REQCODE,PK$CSU$ENT[0],0,0,RESP$CODE);
        IF RESP$CODE NQ RESPTYP3"OK3"
        THEN                         # FAMILY/POOL REMOVAL FAILS #
          BEGIN  # PROCESS ERROR RESPONSE #
          IF RESP$CODE NQ RESPTYP3"MSC$NEMPTY"
          THEN
            BEGIN
            LBRESP(RESP$CODE,TYP"TYP3");
            REQCODE = REQTYP4"UNLD$CART";
            CALL4(REQCODE,0,0,SM$EXIT$TY,SM$TY$Z,RESP$CODE);
            IF RESP$CODE NQ RESPTYP4"OK4"
            THEN
              BEGIN
              LBRESP(RESP$CODE,TYP"TYP4");
              RETURN;
              END
 
            RETURN;
            END
 
          ELSE
            BEGIN  # PROCESS CARTRIDGE NOT EMPTY #
 
 
#
*     UNLOAD CARTRIDGE BACK AT ORIGINAL LOCATION.
#
 
            CALL4(REQTYP4"UNLD$CART",DRD$NUM,CART$CSN,PK$Y[0], ##
              PK$Z[0],RESP$CODE);
            IF RESP$CODE NQ RESPTYP4"OK4"
            THEN
              BEGIN
              LBRESP(RESP$CODE,TYP"TYP4");
              RETURN;
              END
 
            ERRCODE = S"CR$NTEMPT";
            LBERR(ERRCODE);
            END  # PROCESS CARTRIDGE NOT EMPTY #
 
          END  # PROCESS ERROR RESPONSE #
 
#
*     WRITE NEW LABEL AND PUT CARTRIDGE IN NEW LOCATION.
#
 
        REQCODE = REQTYP4"WRT$LAB";
        CALL4(REQCODE,DRD$NUM,CART$CSN,PT$Y,PT$Z,RESP$CODE);
        IF RESP$CODE NQ RESPTYP4"OK4"
        THEN                         # *WRITE* FAILS #
          BEGIN
          LBRESP(RESP$CODE,TYP"TYP4");
          RETURN;
          END
 
        IF LBARG$PT[0] EQ "P"
        THEN
          BEGIN  # ADD CARTRIDGE TO POOL #
          REQCODE = REQTYP3"UPD$MAP";
          P<SMUMAP> = LOC(PT$CSU$ENT[0]);
          CM$CSND[0] = LAB$CSND[0];
        CM$CCOD[0] = LAB$CCOD[0];
 
#
*     ADD CARTRIDGE TO POOL.
#
 
          CALL3(REQCODE,PT$CSU$ENT[0],0,0,RESP$CODE);
          IF RESP$CODE NQ RESPTYP3"OK3"
          THEN                       # MAP UPDATE FAILS #
            BEGIN
            LBRESP(RESP$CODE,TYP"TYP3");
            RETURN;
            END
 
          END  # ADD CARTRIDGE TO POOL #
 
        MFLUSH;                    # FLUSH MAP BUFFER #
        END
 
 
      RETURN;
 
      END  # LBRMMSC #
 
    TERM
PROC LBRSMSC;
# TITLE LBRSMSC - RESTORES A CARTRIDGE TO THE CSU.                    #
 
      BEGIN  # LBRSMSC #
 
#
**    LBRSMSC - RESTORES A CARTRIDGE TO THE CSU.
*
*     THIS PROC GETS A CARTRIDGE FROM THE INPUT DRAWER AND RETURNS
*     IT TO ITS ASSIGNED LOCATION.
*
*     PROC LBRSMSC.
*
*     ENTRY     CRACKED AND SYNTAX CHECKED DIRECTIVE
*               PARAMETERS SET UP IN COMMON AREA DEFINED
*               IN *COMTLBP*.
*
*     EXIT      CARTRIDGE RESTORED OR ERROR CONDITION.
*
*     NOTES     PROC *LBRSMSC* CHECKS THAT THERE IS A CARTRIDGE IN
*               AN INPUT DRAWER AS SPECIFIED, AND CALLS EXEC TO
*               BRING THE CARTRIDGE TO A DRIVE AND READ ITS LABEL.
*               IF THE LABEL HAS THE CORRECT *SM* NUMBER, AND IF
*               A SMMAP ENTRY IS FOUND WITH MATCHING VSN, FAMILY,
*               SUBFAMILY, AND COORDINATES, THEN EXEC IS CALLED TO
*               REPLACE THE CARTRIDGE AND UPDATE THE CATALOG.
#
 
#
****  PROC LBRSMSC - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC CALL3;                  # ISSUES TYPE 3 CALLSS TO EXEC #
        PROC CALL4;                  # ISSUES TYPE 4 CALLSS TO EXEC #
        PROC DLABFLD;                # DISPLAY CARTRIDGE LABEL FIELDS #
        PROC LBERR;                  # *SSLABEL* ERROR PROCESSOR #
        PROC LBRESP;                 # RESPONSE CODE PROCESSOR #
        PROC SERCSU;                 # SEARCHES SMMAP #
        END
 
#
****  PROC LBRSMSC - XREF LIST END.
#
 
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS #
*CALL COMBFAS
*CALL COMBCPR
*CALL COMBLBL
*CALL COMBMAP
*CALL COMTERR
*CALL COMTLAB
*CALL COMTLBP
      ITEM CART$CSN   C(20);         # CARTRIDGE SERIAL NUMBER #
      ITEM CATFLD     U;             # CATALOG FIELD #
      ITEM CATVALUE   I;             # CATALOG VALUE #
      ITEM FLAG       I;             # ERROR FLAG #
      ITEM I          I;             # INDUCTION VARIABLE #
      ITEM REQCODE    I;             # REQUEST CODE #
      ITEM RESP$CODE  I;             # RESPONSE CODE #
      ITEM SERTYPE    S:SERCH$TYPE;  # SEARCH TYPE #
      ITEM SLOT       I;             # DRAWER NUMBER #
      ITEM SP$VSN     C(8);          # SPECIFIED *CSN* #
      ITEM SP$Y       I;             # SPECIFIED Y #
      ITEM SP$Z       I;             # SPECIFIED Z #
 
 
      ARRAY PT$CSU$ENT [0:0] P(5);   # *PUT* SMMAP ENTRY #
        BEGIN
        ITEM PT$MAPENT  C(00,00,30);  # THREE WORD MAP ENTRY #
        ITEM PT$Y       U(03,00,30);  # Y COORDINATE #
        ITEM PT$Z       U(03,30,30);  # Z COORDINATE #
        ITEM PT$GR      U(04,00,07);  # GROUP #
        ITEM PT$GRT     U(04,07,04);  # GROUP ORDINAL #
        END
 
      BASED
      ARRAY TEMP$LAB [0:0] P(1);
        BEGIN
        ITEM TEMP$LABW  U(00,00,60);
        END
 
 
                                               CONTROL EJECT;
 
#
*     FIND CARTRIDGE IN SPECIFIED INPUT DRAWER AND LOAD IT.
#
 
      REQCODE = REQTYP4"LOAD$CART";
      PT$Y[0] = 14;
      PT$Z[0] = 0;
      CALL4(REQCODE,DRD$NUM,CART$CSN,PT$Y[0],PT$Z[0],RESP$CODE);
      IF RESP$CODE NQ RESPTYP4"OK4"   ##
      THEN                           # LOAD FAILS #
        BEGIN
        LBRESP(RESP$CODE,TYP"TYP4");
        RETURN;
        END
 
      DRD$NUM = CPR$DRD[0];          # SET UP TRANSPORT ID #
 
      P<LABEL$CART>  = OLDLABP;
 
#
*     COMPARE THE CSU-ID, FAMILY AND THE SUBFAMILY IN THE LABEL
*     AGAINST THE USER SPECIFIED VALUES.
#
 
      IF LAB$SMID[0] NQ LBARG$SM[0]
      THEN
        BEGIN
        DLABFLD;                     # DISPLAY LABEL FIELDS #
        REQCODE = REQTYP4"UNLD$CART";
        CALL4(REQCODE,0,0,SM$EXIT$TY,SM$TY$Z,RESP$CODE);
        IF RESP$CODE NQ RESPTYP4"OK4"
        THEN
          BEGIN
          LBRESP(RESP$CODE,TYP"TYP4");
          RETURN;
          END
 
        ERRCODE = S"UNXP$CYZFS";
        LBERR(ERRCODE);              # DO ERROR PROCESSING #
        RETURN;
        END
 
      SERTYPE = S"CSN$MATCH";
      SP$VSN = LAB$CSND[0];          # SEARCH SMMAP FOR VSN MATCH #
      SERCSU(SERTYPE,0,0,0,SP$VSN,0,0,PT$CSU$ENT[0],FLAG);
      IF FLAG NQ OK
      THEN                           # VSN NOT FOUND #
        BEGIN
        DLABFLD;                     # DISPLAY LABEL FIELDS #
        REQCODE = REQTYP4"UNLD$CART";
        CALL4(REQCODE,0,0,SM$EXIT$TY,SM$TY$Z,RESP$CODE);
        IF RESP$CODE NQ RESPTYP4"OK4"
        THEN
          BEGIN
          LBRESP(RESP$CODE,TYP"TYP4");
          RETURN;
          END
 
        ERRCODE = S"CSN$NOTFND";
        LBERR(ERRCODE);              # DO ERROR PROCESSING #
        RETURN;
        END
 
      P<SMUMAP> = LOC(PT$CSU$ENT[0]);
 
#
*     CHECK TO SEE IF LABEL AND MAP ENTRY DIFFER ON
*     Y, Z, FAMILY, OR SUBFAMILY.
#
 
      IF LAB$Y[0] NQ PT$Y[0]         ##
        OR LAB$Z[0] NQ PT$Z[0]       ##
        OR LAB$FMLY[0] NQ CM$FMLYNM[0]  ##
        OR LAB$SF[0] NQ CM$SUB[0]
      THEN
        BEGIN
        REQCODE = REQTYP4"UNLD$CART";
        CALL4(REQCODE,0,0,SM$EXIT$TY,SM$TY$Z,RESP$CODE);
        IF RESP$CODE NQ RESPTYP4"OK4"
        THEN
          BEGIN
          LBRESP(RESP$CODE,TYP"TYP4");
          RETURN;
          END
 
        DLABFLD;                     # DISPLAY LABEL FIELDS #
        ERRCODE = S"UNXP$CYZFS";
        LBERR(ERRCODE);              # DO ERROR PROCESSING #
        RETURN;
        END
 
#
*     CLEAR *LOST* FLAG IN THE CATALOG IF THE CARTRIDGE IS TO BE
*     RESTORED TO THE FAMILY OR CLEAR SMMAP ERROR FLAG IF THE
*     CARTRIDGE IS TO BE RESTORED TO THE POOL AND RETURN THE
*     CARTRIDGE TO ITS ASSIGNED LOCATION.
#
 
 
      IF CM$CODE[0] EQ CUBSTAT"SUBFAM"
      THEN
        BEGIN  # CLEAR *LOST* FLAG #
        REQCODE = REQTYP3"UPD$CAT";
        CATFLD = UCF"LOST";
        CATVALUE = 0;                # CLEAR *LOST* FLAG IN CATALOG #
        CALL3(REQCODE,PT$CSU$ENT[0],CATFLD,CATVALUE,RESP$CODE);
        END  # CLEAR *LOST* FLAG #
 
      ELSE
        BEGIN  # CLEAR SMMAP ERROR FLAG #
        P<SMUMAP> = LOC(PT$CSU$ENT[0]);
        CM$FLAG1[0] = FALSE;
        REQCODE = REQTYP3"UPD$MAP";
        CALL3(REQCODE,PT$CSU$ENT[0],0,0,FLAG);
        END  # CLEAR SMMAP ERROR FLAG #
 
      IF RESP$CODE NQ RESPTYP3"OK3"
      THEN                           # UPDATE CATALOG/MAP FAILED #
        BEGIN
        REQCODE = REQTYP4"UNLD$CART";
        CALL4(REQCODE,0,0,SM$EXIT$TY,SM$TY$Z,RESP$CODE);
        IF RESP$CODE NQ RESPTYP4"OK4"
        THEN
          BEGIN
          LBRESP(RESP$CODE,TYP"TYP4");
          RETURN;
          END
 
        DLABFLD;                     # DISPLAY LABEL FIELDS #
        LBRESP(RESP$CODE,TYP"TYP3");
        RETURN;
        END
 
#
*     PUT CARTRIDGE IN ASSIGNED LOCATION.
#
 
      P<LABEL$CART> = OLDLABP;
      P<TEMP$LAB> = NEWLABP;
      SLOWFOR I = 0 STEP 1 UNTIL LABLEN-1
      DO                             # MOVE LABEL TO NEW BUFFER #
        BEGIN
        TEMP$LABW[I] = LAB$W1[I];
        END
 
      REQCODE = REQTYP4"UNLD$CART";
      CALL4(REQCODE,DRD$NUM,CART$CSN,PT$Y[0],PT$Z[0],RESP$CODE);
      IF RESP$CODE NQ RESPTYP4"OK4"
      THEN                           # PUT FAILS #
        BEGIN
        DLABFLD;                     # DISPLAY LABEL FIELDS #
        LBRESP(RESP$CODE,TYP"TYP4");
        END
 
      RETURN;
 
      END  # LBRSMSC #
 
    TERM
PROC LBSTCLR;
# TITLE LBSTCLR - STORES A *CE* CARTRIDGE IN 0,0 OR 0,15.             #
 
      BEGIN  # LBSTCLR #
 
#
**    LBSTCLR - STORES A *CE* CARTRIDGE IN 0,0 OR 0,15.
*
*     THIS PROC STORES A SPECIAL CARTRIDGE IN ONE OF TWO SPECIFIC
*     LOCATIONS.
*
*     PROC LBSTCLR.
*
*     ENTRY       (LBARG$CC) = IF EQUAL TO 0, STORE CARTRIDGE FROM
*                              DRAWER TO LOCATION 0,0.
*                              IF EQUAL TO 15, STORE INTO 0,15.
*
*     EXIT        CARTRIDGE IN LOCATION SPECIFIED.
*
#
 
      DEF LISTCON #0#;               # DO NOT DEF LIST COMDECKS #
 
#
****  PROC LBSTCLR - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC CALL4;                  # MAKE TYPE 4 REQUESTS #
        PROC CKLAB;                  # CHECK LABEL #
        PROC GENLAB;      # GENERATE CARTRIDGE LABEL #
        PROC LBERR;                  # PROCESS ERROR RESPONSE #
        PROC LBRESP;                 # PROCESS ERROR FROM EXEC #
        PROC SERCSU;      # SEARCH SMMAP #
        END
 
#
****  PROC LBSTCLR - XREF LIST END.
#
 
*CALL COMBFAS
*CALL COMBCMD
*CALL COMBCPR
*CALL COMBLBL
*CALL COMBMAP
*CALL COMTERR
*CALL COMTLAB
*CALL COMTLBP
 
      ITEM FLAG       U;             # RESPONSE FLAG #
      ITEM Y          U;             # Y COORDINATE #
      ITEM Z          U;             # Z COORDINATE #
      ITEM SERTYPE S:SERCH$TYPE;   # TYPE OF SERACH #
 
      ARRAY PT$CSU$ENT [0:0] P(4); # *PUT* SMMAP ENTRY #
        BEGIN
        ITEM PT$MAPENT  C(00,00,30); # THREE WORD MAP ENTRY #
        ITEM PT$Y       U(03,00,30); # Y COORDINATE #
        ITEM PT$Z       U(03,30,30); # Z COORDINATE #
        END
 
                                               CONTROL EJECT;
 
#
*     LOAD CARTRIDGE FROM INPUT DRAWER AND READ LABEL.
#
 
      Y = SM$ENT$TY;
      Z = SM$TY$Z;
      CALL4(REQTYP4"LOAD$CART",0,0,Y,Z,FLAG);
      IF FLAG NQ RESPTYP4"OK4"   ##
        AND FLAG NQ RESPTYP4"UNK$CART"  ##
        AND FLAG NQ RESPTYP4"CART$LB$ERR"
      THEN
        BEGIN
        CALL4(REQTYP4"UNLD$CART",0,0,SM$EXIT$TY,Z,FLAG);
        IF FLAG NQ RESPTYP4"OK4"
        THEN
          BEGIN
          LBRESP(FLAG,TYP"TYP4");
          END
 
        ERRCODE = S"M86$HARDWR";
        LBERR(ERRCODE);
        RETURN;
        END
 
#
*     SERACH SMMAP FOR DUPLICATE *CSN*.
#
 
      SERTYPE = S"CSN$MATCH";
      SERCSU(SERTYPE,0,0,0,LAB$CSND[0],0,0,PT$CSU$ENT[0],FLAG);
      IF FLAG EQ 0
      THEN              # *CSN* IN MAP #
        BEGIN
        CALL4(REQTYP4"UNLD$CART",0,0,SM$EXIT$TY,SM$TY$Z,FLAG);
        IF FLAG NQ RESPTYP4"OK4"
        THEN
          BEGIN
          LBRESP(FLAG,TYP"TYP4");
          RETURN;
          END
 
        ERRCODE = S"DUPL$CSN";
        LBERR(ERRCODE);
        RETURN;
        END
 
 
#
*     PUT CARTRIDGE BACK TO DRAWER IF LABEL IS FROM FAMILY OR POOL.
#
 
      P<LABEL$CART> = OLDLABP;
      CKLAB(FLAG);
      IF FLAG EQ LABTYPE"FAM$LAB"    ##
      THEN
        BEGIN
        ERRCODE = S"GOOD$LAB";
        LBERR(ERRCODE);
        RETURN;
        END
 
 
#
*     GENERATE NEW LABEL.
#
 
      P<SMUMAP> = LOC(PT$CSU$ENT[0]);
      PT$Y[0] = 0;
      PT$Z[0] = LBARG$CC[0];
      CM$SUB[0] = 0;
      CM$FMLYNM[0] = " ";
      GENLAB(LABTYPE"SCR$LAB",PT$CSU$ENT[0],0,0,0,0,0,0);
      LAB$CLF[0] = 2;
      LAB$RCORD[0] = 6652;
 
#
*     STORE CARTRIDGE.
#
 
      CALL4(REQTYP4"WRT$LAB",0,0,PT$Y[0],PT$Z[0],FLAG);
      IF FLAG NQ RESPTYP4"OK4"
      THEN
        BEGIN
        LBRESP(FLAG,TYP"TYP4");
        RETURN;
        END
 
 
      END
 
    TERM
PROC SERAST(FCTORD,FLAG);
# TITLE SERAST - SEARCHES THE AST FOR AN EMPTY CARTRIDGE.             #
 
      BEGIN  # SERAST #
 
#
**    SERAST - SEARCHES THE AST FOR AN EMPTY CARTRIDGE.
*
*     THIS PROC READS THE *AST* AND IFNDS THE FIRST EMPTY
*     CARTRIDGE IN A SPECIFIED GROUP.
*
*     PROC SERAST(FCTORD,FLAG)
*
*     ENTRY     (LB$BUFP) = FWA OF A BUFFER 1101B WORDS LONG.
*              (GROUP)  = IF GROUP = 0 THEN THE GROUP PARAMETER
*                         IS IGNORED. OTHERWISE, SELECT FROM THE
*                         SPECIFIED GROUP.
*
*      EXIT     (FCTORD) = FCT ORDINAL OF EMPTY CARTRIDGE, IF ANY.
*                          FREE, IF ANY.
*               (FLAG)   = ITEM INDICATING RESULT OF SEARCH.
*                          0,  EMPTY CARTRIDGE FOUND.
*                          1,  NO EMPTY CARTRIDGES.
*
*      NOTES    PROC *SERAST* READS THE *AST* FOR THE SPECIFIED
*               SUBFAMILY AND GROUP. THE *AST* IS SEARCHED
*               THE SPECIFIED SUBFAMILY. THE AST IS SEARCHED
*               SEQUENTIALLY FOR AN EMPTY CARTRIDGE. IF NO EMPTY
*               CARTRIDGES EXIST, THEN * FLAG*  IS SET TO 1.
#
 
 
#
****  PROC SERAST - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC CRDAST;                 # READS AVAILABLE STREAM TABLE #
        PROC LBERR;                  # *SSLABEL* ERROR PROCESSOR #
        PROC LBRESP;                 # RESPONSE CODE PROCESSOR #
        END
 
#
****  PROC SERAST - XREF LIST END.
#
 
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS #
*CALL COMBFAS
*CALL COMBCMD
*CALL COMBMCT
*CALL COMTLAB
*CALL COMTLBP
 
*CALL COMTERR
 
      ITEM FCTORD     U;             # EMPTY CARTRIDGE FCT ORDINAL #
      ITEM FLAG       I;             # ERROR FLAG #
      ITEM GROUP      I;             # SPECIFIED GROUP #
      ITEM I          I;             # INDUCTION VARIABLE #
      ITEM START      U;             # BEGINNING OF SEARCH #
      ITEM TERMX      U;             # END OF SEARCH #
                                               CONTROL EJECT;
 
#
*     READ AST.
#
 
      CRDAST(LBARG$FM[0],LBARG$SB[0],LBARG$SMID[0],ASTBADR,0,FLAG);
      IF FLAG NQ OK
      THEN
        BEGIN
        LBRESP(FLAG,0);
        RETURN;
        END
 
#
*      SET AST BASED ARRAY POINTER.
#
 
      P<AST> = ASTBADR;
 
#
*     SEARCH FOR FIRST EMPTY CARTIDGE IN SPECIFIED GROUP.
#
 
      FLAG = 1;
      FCTORD = -1;
      IF LBARG$GR[0] LS 0
      THEN                           # GROUP IS NOT SPECIFIED #
        BEGIN
      START = 16;
        TERMX = MAXORD;
        END
 
      ELSE
        BEGIN
      START = LBARG$GR[0] * 16;
        TERMX = START + 15;
        END
 
      SLOWFOR I = START STEP 1 WHILE (I LQ TERMX) AND (FCTORD EQ -1)
        DO                           # SEARCH FOR EMPTY CARTRIDGE #
        BEGIN
        IF AST$STAT[I] EQ ASTENSTAT"ASS$CART"  ##
          AND AST$GR[I] NQ 0         ##
          AND (AST$AULF[I] + AST$AUSF[I] + AST$FLAWS[I] EQ INAVOT)
          THEN                       # CARTRIDGE IS FOUND #
          BEGIN
          FCTORD = I;
          FLAG = 0;
          TEST I;
          END
 
        END
 
 
 
 
      RETURN;
 
      END  # SERAST #
 
    TERM
PROC SERASTG(GROUP,GRT,FLAG);
# TITLE SERASTG - SEARCHES THE AST FOR AN AVAILABLE GROUP ORDINAL.    #
 
      BEGIN  # SERASTG #
 
#
**    SERASTG - SEARCHES THE AST FOR AN AVAILABEL GROUP ORDINAL.
*
*     THIS PROC READS THE AST AND FINDS
*
*     PROC SERASTG(GROUP,GRT,FLAG)
*
*               (GROUP)   = IF NEGATIVE FIND DEFAULT GROUP AND
*                           ORDINAL, OTHERWISE FIND GROUP ORDINAL
*                           FOR THE SPECIFIED GROUP.
*     ENTRY     (LB$BUFP) = FWA OF A BUFFER 1101B WORDS LONG.
*
*     EXIT
*               (FLAG)   = ITEM INDICATING RESULT OF SEARCH.
*               (GROUP)   = DEFAULT OR SPECIFIED GROUP.
*               (GRT)     = GROUP ORDINAL IF AVAILABLE.
*
*     NOTES     PROC *SERAST* READS THE AVAILABLE STREAM TABLE FOR
#
 
      ITEM FCTORD     U;             # EMPTY CARTRIDGE FCT ORDINAL #
      ITEM FLAG       I;             # ERROR FLAG #
      ITEM GROUP      I;             # GROUP #
      ITEM GRT        I;             # GROUP ORDINAL #
      ITEM I          I;             # INDUCTION VARIABLE #
      ITEM START      U;             # BEGINNING OF SEARCH #
      ITEM TERMX      U;             # END OF SEARCH #
 
#
****  PROC SERAST - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC COPEN;                  # OPEN CATALOGS #
        PROC CCLOSE;                 # CLOSE SFMCAT #
        PROC CRDAST;                 # READS AVAILABLE STREAM TABLE #
        PROC LBERR;                  # *SSLABEL* ERROR PROCESSOR #
        PROC LBRESP;                 # RESPONSE CODE PROCESSOR #
        FUNC XCOD;                   # CONVERT TO DISPLAY CODE #
        PROC LOFPROC;                # LIST OF FILES #
        END
 
#
****  PROC SERAST - XREF LIST END.
#
 
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS #
*CALL COMBFAS
*CALL COMBCMD
*CALL COMBCMS
*CALL COMBMCT
*CALL COMTLAB
*CALL COMTLBP
 
 
*CALL COMTERR
 
      ARRAY MSFCATNM [0:0] P(1);     # CATALOG NAME #
        BEGIN
        ITEM MSFCAT$NM  C(00,00,06);  # FIRST SIX CHARACTERS #
        ITEM MSFCAT$LST  C(00,36,01);  # LAST CHARACTER #
        END
 
                                               CONTROL EJECT;
 
 
#
*     OPEN CATALOG.
#
 
      MSFCAT$NM[0] = SFMCAT;
      MSFCAT$LST[0] = XCOD(LBARG$SB[0]);
      COPEN(LBARG$FM[0],LBARG$SB[0],MSFCATNM[0],"RM",TRUE,FLAG);
      IF FLAG EQ CMASTAT"NOERR"
      THEN
        BEGIN
        LOFPROC(OCT$LFN[1]);         # ADD LFN TO LIST OF FILES #
        END
 
      IF FLAG NQ CMASTAT"NOERR" AND FLAG NQ CMASTAT"FOPEN"
      THEN                           # ERROR CONDITION OTHER THAN
                                       CATALOG ALREADY OPEN #
        BEGIN
        LBRESP(FLAG,0);
        RETURN;
        END
 
#
*     READ AST.
#
 
      CRDAST(LBARG$FM[0],LBARG$SB[0],LBARG$SMID[0],ASTBADR,0,FLAG);
      IF FLAG NQ OK
      THEN
        BEGIN
        LBRESP(FLAG,0);
        RETURN;
        END
 
 
#
*     SET AST BASED ARRAY POINTER.
#
 
      P<AST> = ASTBADR;
      CCLOSE(LBARG$FM[0],LBARG$SB[0],0,FLAG);
 
#
*     FIND DEFAULT GROUP IF GROUP IS NEGATIVE, OR GROUP
*     ORDINAL IF GROUP IS SPECIFIED.
#
 
      FLAG = 1;
      IF GROUP LS 0
      THEN
        BEGIN
      SLOWFOR I = 16 STEP 1  ##
        WHILE GROUP LS 0  ##
        AND I LQ (MAXORD + 15)
        DO                           # FIND DEFAULT GROUP #
          BEGIN
          IF (AST$STAT[I] NQ ASTENSTAT"ASS$CART") AND (AST$GR[I] EQ 0)
            THEN                     # AVAILABLE ENTRY FOUND #
            BEGIN
      GROUP = I/16;
            FLAG = 0;
            TEST I;
            END
 
          END
 
        IF FLAG NQ 0
        THEN
          BEGIN
          RETURN;
          END
 
        END
 
#
*     FIND ORDINAL WITHIN GROUP.
#
 
      GRT = -1;
      START = GROUP * 16;
      TERMX = START + 15;
      SLOWFOR I = START STEP 1 WHILE I LQ TERMX AND (GRT EQ -1)
      DO                             # SEARCH GROUP FOR AVAILABLE ORD #
        BEGIN
        IF AST$GRT[I] EQ 0 AND AST$STAT[I] NQ ASTENSTAT"ASS$CART"
        THEN
          BEGIN
      GRT = I - (I/16 * 16);
          FLAG = 0;
          TEST I;
          END
 
        END
 
 
      RETURN;
 
      END  # SERAST #
 
    TERM
PROC SERCSU((SERTYPE),(SP$Y),(SP$Z),(SP$CODE),(SP$VSN),(SP$FAM),##
      (SP$SUB),PK$CSU$ENT,SERFLAG);
# TITLE SERCSU - SEARCHES SMMAP FOR A CUBE OR A CARTRIDGE.           #
 
      BEGIN  # SERCSU #
 
#
**    SERCSU - SEARCHES SMMAP FOR A CUBE OR A CARTRIDGE.
*
*     THIS PROC SEARCHES SMMAP FOR A SPECIFIC ENTRY.
*
*     PROC SERCSU((SERTYPE),(SP$Y),(SP$Z),(SP$CODE),(SP$VSN),
*                 (SP$FAM),(SP$SUB),PK$CSU$ENT,SERFLAG)
*
*     ENTRY     SERTYPE, A STATUS ITEM SPECIFYING TYPE OF
*                        SEARCH TO BE CONDUCTED.
*                        S"LST$UNAS"   SEARCH FOR LAST
*                                      UNASSIGNED CUBE.
*                        S"LOC"        SEARCH FOR A SPECIFIC
*                                      LOCATION (SP$Y,SP$Z).
*                        S"ASSIGN"     SEARCH FOR A SPECIFIC
*                                      CARTRIDGE OR ANY CUBE
*                                      ASSIGNED TO FAMILY OR
*                                      POOL.
*                        S"CSN$MATCH"  SEARCH FOR A MATCHING
*                                      VSN.
*                        S"CART$POOL"  SEARCH FOR ANY CARTRIDGE
*                                      ASSIGNED TO A POOL.
*                        S"ASGN$FAM"   SEARCH FOR ANY ENTRY
*                                      ASSIGNED TO A GIVEN
*                                      FAMILY.
*               SP$Y, AN ITEM CONTAINING THE Y COORDINATE.
*               SP$Z, AN ITEM CONTAINING THE Z COORDINATE.
*               SP$CODE, A STATUS ITEM CONTAINING THE TYPE
*                        OF ASSIGNMENT OF CUBE OR CARTRIDGE.
*               SP$VSN, AN ITEM CONTAINING THE VSN.
*               SP$FAM, AN ITEM CONTAINING THE FAMILY.
*               SP$SUB, AN ITEM CONTAINING THE SUB FAMILY.
*
*     EXIT      SEARCH COMPLETE.
*               PK$CSU$ENT, AN ARRAY CONTAINING THE SMMAP
*                           ENTRY.
*               SERFLAG, AN ITEM CONTAINING THE ERROR STATUS.
*                     0 - ENTRY FOUND.
*                     1 - ENTRY NOT FOUND.
*
*     MESSAGES  SSLABEL ABNORMAL, SERCSU.
*
*     NOTES     PROC *SERCSU* SEARCHES THE SMMAP FOR A
*               SPECIFIC CUBE OR CARTRIDGE DEPENDING ON
*               *SERTYPE*.  THE ORDINAL OF THE SMMAP ENTRY
*               IS MAPPED BACK INTO THE Y AND Z COORDINATES
*               WHICH ARE PUT IN THE THIRD WORD ADDED TO THE
*               TWO WORD SMMAP ENTRY IN *PK$CSU$ENT*.  IF
*               THE SPECIFIC ENTRY IS NOT FOUND, AN ERROR
*               STATUS IS RETURNED BACK TO THE CALLING PROC.
#
 
      ITEM SERTYPE    U;             # SMMAP SEARCH TYPE #
      ITEM SP$Y       I;             # SPECIFIED Y COORDINATE OF
                                       CUBE/CARTRIDGE #
      ITEM SP$Z       I;             # SPECIFIED Z COORDINATE OF
                                       CUBE/CARTRIDGE #
      ITEM SP$CODE    U;             # CODE FOR CUBE/CARTRIDGE
                                       ASSIGNMENT #
      ITEM SP$VSN     C(8);          # SPECIFIED *CSN* #
      ITEM SP$FAM     C(7);          # SPECIFIED FAMILY TO PROCESS #
      ITEM SP$SUB     U;             # SPECIFIED SUBFAMILY #
 
      ARRAY PK$CSU$ENT  [0:0]  P(4);  # *PICK* SMMAP ENTRY #
        BEGIN
        ITEM PK$MAPENT  C(00,00,30);  # THREE WORD SMMAP ENTRY #
        ITEM PK$Y       U(03,00,30);  # Y COORDINATE #
        ITEM PK$Z       U(03,30,30);  # Z COORDINATE #
        END
 
 
      ITEM SERFLAG    I;             # ERROR FLAG #
 
#
****  PROC SERCSU - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC MESSAGE;                # DISPLAYS MESSAGES #
        PROC MGETENT;                # GETS SMMAP ENTRY #
        PROC RESTPFP;                # RESTORE USER-S *PFP* AND ABORT
                                       OR RETURN #
        END
 
#
****  PROC SERCSU - XREF LIST END.
#
 
      DEF PROCNAME #"SERCSU."#;      # PROC NAME #
 
      DEF LISTCON    #0#;            # DO NOT LIST COMDECKS #
*CALL COMBFAS
*CALL COMBCMS
*CALL COMBMAP
*CALL COMTLAB
*CALL COMTLBP
 
      ITEM FLAG       I;             # ERROR FLAG #
      ITEM I          I;             # LOOP VARIABLE #
      ITEM PK$CSU$ADR I;             # ADDRESS OF THE SMMAP ENTRY #
 
      SWITCH SEARCH : SERCH$TYPE
           SER$LSTUN: LST$UNAS,      # SEARCH FOR LAST UNASSIGNED CUBE
                                     #
             SER$LOC: LOC,           # SEARCH FOR A LOCATION #
             SER$ASG: ASSIGN,        # SEARCH FOR A SPECIFIC CUBE OR
                                       CARTRIDGE ASSIGNED TO FAMILY OR
                                       POOL #
             SER$VSN: CSN$MATCH,     # SEARCH FOR A VSN #
           SER$CARPL: CART$POOL,     # SEARCH FOR CARTRIDGE IN POOL #
           SER$ASNFM: ASGN$FAM;      # SEARCH FOR AN ENTRY ASSIGNED TO
                                       A GIVEN FAMILY #
 
                                               CONTROL EJECT;
 
      SERFLAG = 1;                   # INITIALIZE ERROR FLAG TO AN
                                       ERROR CONDITION #
 
#
*     CHECK *SERTYPE* FOR THE TYPE OF SEARCH TO BE
*     CONDUCTED AND GO TO THE CORRESPONDING STATUS
*     SWITCH TO PROCESS IT.
#
 
      PK$CSU$ADR = LOC(PK$CSU$ENT[0]);
      P<SMUMAP> = PK$CSU$ADR;        # SMMAP ENTRY FORMAT #
      GOTO SEARCH[SERTYPE];
 
#
*     SEARCH FOR LAST UNASSIGNED CUBE.
#
 
SER$LSTUN:
      SLOWFOR I = MAXORD STEP -1 UNTIL 1
      DO
        BEGIN  # SEARCH SMMAP BACKWARDS #
        MGETENT(LBARG$SMID[0],I,PK$CSU$ADR,FLAG);
        IF FLAG NQ CMASTAT"NOERR"
        THEN                         # ERROR CONDITION #
          BEGIN
          GOTO ERROR;                # PROCESS THE ERROR #
          END
 
        IF CM$CODE[0] EQ CUBSTAT"UNASGN"
        THEN                         # ENTRY IS FOUND #
          BEGIN
          GOTO SER$END;
          END
 
        END  # SEARCH SMMAP BACKWARDS #
 
      RETURN;                        # ENTRY NOT FOUND #
 
#
*     SEARCH FOR A LOCATION IN CSU.
#
 
SER$LOC:
      I = MAXORD - SP$Z - (SP$Y * (MAX$Z + 1));  # CALCULATE ORDINAL #
      MGETENT(LBARG$SMID[0],I,PK$CSU$ADR,FLAG);
      IF FLAG NQ CMASTAT"NOERR"
      THEN                           # ERROR CONDITION #
        BEGIN
        GOTO ERROR;                  # PROCESS THE ERROR #
        END
 
      PK$Y[0] = SP$Y;
      PK$Z[0] = SP$Z;
      SERFLAG = 0;                   # CLEAR ERROR STATUS #
      RETURN;
 
#
*     SEARCH FOR A SPECIFIC CARTRIDGE.
#
 
SER$ASG:
      SLOWFOR I = 1 STEP 1 UNTIL MAXORD
      DO
        BEGIN  # SEARCH SMMAP #
        MGETENT(LBARG$SMID[0],I,PK$CSU$ADR,FLAG);
        IF FLAG NQ CMASTAT"NOERR"
        THEN                         # ERROR CONDITION #
          BEGIN
          GOTO ERROR;                # PROCESS THE ERROR #
          END
 
#
*     CHECK FAMILY, SUBFAMILY,
*     ASSIGNMENT, AND VSN.
#
 
        IF (CM$FMLYNM[0] EQ SP$FAM)  ##
          AND (CM$SUB[0] EQ SP$SUB)  ##
          AND (CM$CODE[0] EQ SP$CODE)  ##
          AND (CM$CSND[0] EQ SP$VSN)
        THEN
          BEGIN
          GOTO SER$END;              # ENTRY FOUND #
          END
 
        END  # SEARCH SMMAP #
 
      RETURN;                        # ENTRY NOT FOUND #
 
#
*     SEARCH FOR A MATCHING VSN.
#
 
SER$VSN:
      SLOWFOR I = 1 STEP 1 UNTIL MAXORD
      DO
        BEGIN  # SEARCH SMMAP #
        MGETENT(LBARG$SMID[0],I,PK$CSU$ADR,FLAG);
        IF FLAG NQ CMASTAT"NOERR"
        THEN                         # ABNORMAL ERROR CONDITION #
          BEGIN
          GOTO ERROR;                # PROCESS THE ERROR #
          END
 
        IF CM$CSND[0] EQ SP$VSN
        THEN                         # VSN MATCH FOUND #
          BEGIN
          GOTO SER$END;
          END
 
        END  # SEARCH SMMAP #
 
      RETURN;                        # ENTRY NOT FOUND #
 
#
*     SEARCH FOR A CARTRIDGE IN POOL.
#
 
SER$CARPL:
      SLOWFOR I = 1 STEP 1 UNTIL MAXORD
      DO
        BEGIN  # SEARCH SMMAP #
        MGETENT(LBARG$SMID[0],I,PK$CSU$ADR,FLAG);
        IF FLAG NQ CMASTAT"NOERR"
        THEN                         # ERROR CONDITION #
          BEGIN
          GOTO ERROR;                # PROCESS THE ERROR #
          END
 
        IF CM$CODE[0] EQ CUBSTAT"SCRPOOL"  ##
          AND CM$CSND[0] NQ " "      ##
          AND NOT CM$FLAG1[0]
        THEN                         # POOL CARTRIDGE FOUND #
          BEGIN
          GOTO SER$END;
          END
 
        END  # SEARCH SMMAP #
 
      RETURN;                        # ENTRY NOT FOUND #
 
#
*     SEARCH FOR AN ENTRY ASSIGNED TO A GIVEN FAMILY.
#
 
SER$ASNFM:
      SLOWFOR I = 1 STEP 1 UNTIL MAXORD
      DO
        BEGIN  # SEARCH SMMAP #
        MGETENT(LBARG$SMID[0],I,PK$CSU$ADR,FLAG);
        IF FLAG NQ CMASTAT"NOERR"
        THEN                         # ERROR CONDITION #
          BEGIN
          GOTO ERROR;                # PROCESS THE ERROR #
          END
 
        IF CM$FMLYNM[0] EQ SP$FAM    ##
          AND CM$SUB[0] EQ SP$SUB
        THEN                         # ENTRY FOUND #
          BEGIN
          SERFLAG = 0;               # CLEAR ERROR STATUS #
          RETURN;
          END
 
        END  # SEARCH SMMAP #
 
      RETURN;                        # ENTRY NOT FOUND #
 
#
*     SET UP Y AND Z COORDINATES.
#
 
SER$END:
      PK$Y[0] = (MAXORD - I)/(MAX$Z + 1);
      PK$Z[0] = MAXORD - I - (MAX$Z + 1) * PK$Y[0];
      SERFLAG = 0;
      RETURN;
 
#
*     PROCESS THE ERROR ENCOUNTERED WHILE
*     SEARCHING THE SMUMAP.
#
 
ERROR:
      LBMSG$PROC[0] = PROCNAME;
      MESSAGE(LBMSG[0],SYSUDF1);
      RESTPFP(PFP$ABORT);            # RESTORE USER-S *PFP* AND ABORT #
 
      END  # SERCSU #
 
    TERM
PROC SETCORD;
# TITLE SETCORD - SETS Y,Z COORDINATES OF CUBES.                      #
 
      BEGIN  # SETCORD #
 
#
**    SETCORD - SETS Y,Z COORDINATES OF CUBES.
*
*     THIS PROC SETS UP THE Y AND Z COORDINATE POSITIONS OF THE
*     CUBES SPECIFIED, IN A TABLE *YZCOORD*.  IT ALSO RETURNS THE
*     NUMBER OF CUBES SITUATED WITHIN A SPECFIED AREA IN THE CSU.
*
*     PROC SETCORD.
*
*     ENTRY       LBARG$YI, AN ITEM CONTAINING FIRST Y COORDINATE
*                           OR -1.
*                 LBARG$ZI, AN ITEM CONTAINING FIRST Z COORDINATE
*                           OR -1.
*                 LBARG$YF, AN ITEM CONTAINING SECOND Y COORDINATE
*                           OR -1.
*                 LBARG$ZF, AN ITEM CONTAINING SECOND Z COORDINATE
*                           OR -1.
*
*     EXIT        YZCOORD, AN ARRAY IN COMMON CONTAINING THE Y, Z
*                          COORDINATES OF ALL THE CUBES.
*                 LBARG$N, AN ITEM IN COMMON CONTAINING
*                          NUMBER OF CUBES.
*
*     NOTES       PROC *SETCORD* SETS UP THE Y AND Z COORDINATES OF
*                 ALL THE CUBES SITUATED IN THE AREA OF THE *SM*
*                 SPECIFIED BZ *YI*, *YF*, *ZI* AND *ZF*, IN THE
*                 ARRAY *YZCOORD*. IT ALSO CALCULATES THE NUMBER OF
*                 CUBES INVOLVED.  IF MORE THAN *MAXNUM CUBE
*                 LOCATIONS ARE SPECIFIED, AN INFORMATIVE MESSAGE
*                 IS PLACED IN THE DAYFILE AND THE REPORT FILE
*                 AND ONLY *MAXNUM* CUBES ARE PROCESSED.
#
 
#
****  PROC SETCORD - XREF LIST BEGIN.
#
 
      XREF
        BEGIN
        PROC LBERR;                  # *SSLABEL* ERROR PROCESSOR #
        END
 
#
****  PROC SETCORD - XREF LIST END.
#
 
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS #
*CALL COMBFAS
*CALL COMTERR
*CALL COMTLAB
*CALL COMTLBP
 
      ITEM I          I;             # LOOP VARIABLE #
      ITEM J          I;             # LOOP VARIABLE #
      ITEM K          I;             # COUNTER FOR NUMBER OF CUBES #
 
                                               CONTROL EJECT;
 
#
*     CHECK TO SEE IF A COLUMN OF CUBES, A ROW OF CUBES,
*     A RECTANGLE OF CUBES OR A SINGLE CUBE LOCATION IS
*     SPECIFIED.
*     IF *YI* ALONE IS SPECIFIED, SELECT A COLUMN
*     OF CUBES AT *YI*.
#
 
      IF (LBARG$YI[0] NQ -1) AND (LBARG$ZI[0] EQ -1)
      THEN
        BEGIN
        LBARG$YF[0] = LBARG$YI[0];
        LBARG$ZI[0] = 0;
        LBARG$ZF[0] = MAX$Z;         # SET LIMIT ON Z COORDINATE #
        END
 
#
*     IF *ZI* ALONE IS SPECIFIED, SELECT A ROW
*     OF CUBES AT *ZI*.
#
 
      IF (LBARG$YI[0] EQ -1) AND (LBARG$ZI[0] NQ -1)
      THEN
        BEGIN
        LBARG$YI[0] = 0;
        LBARG$YF[0] = MAX$Y;         # SET LIMIT ON Y COORDINATE #
        LBARG$ZF[0] = LBARG$ZI[0];
        END
 
#
*     IF *YI* AND *ZI* ALONE ARE SPECIFIED, SELECT
*     THE CUBE AT LOCATION (YI,ZI).
#
 
      IF (LBARG$YI[0] NQ -1)         ##
        AND (LBARG$ZI[0] NQ -1)      ##
        AND (LBARG$YF[0] EQ -1)
      THEN
        BEGIN
        LBARG$YF[0] = LBARG$YI[0];
        LBARG$ZF[0] = LBARG$ZI[0];
        END
 
#
*     SET UP THE COORDINATE POSITIONS IN ARRAY *YZCOORD*.
#
 
      K = 1;
      SLOWFOR I = LBARG$YI[0] STEP 1 UNTIL LBARG$YF[0]
      DO
        BEGIN
        SLOWFOR J = LBARG$ZI[0] STEP 1 UNTIL LBARG$ZF[0]
        DO
          BEGIN
 
#
*     SKIP OVER THE COORDINATE POSITIONS WHERE
*     NO CUBES EXIST.  NO CUBES AT:
*     (0,0), ((Y=6),Y=0,21), (0,15), (11,15), (21,15),
*     ((Y,Z), Y= 11,15, Z= 0,1).
#
 
 
          IF J EQ Z$NO$CUBE
          THEN                       # NO CUBES AT THIS LOCATION #
            BEGIN
            TEST J;
            END
 
          IF ((J EQ 0)               ##
            AND((I EQ 0)             ##
            OR (I EQ 11)             ##
            OR (I EQ 12)             ##
            OR (I EQ 13)             ##
            OR (I EQ 14)             ##
            OR (I EQ 15)))           ##
            OR ((J EQ 1)             ##
            AND ((I EQ 11)           ##
            OR (I EQ 12)             ##
            OR (I EQ 13)             ##
            OR (I EQ 14)             ##
            OR (I EQ 15)))           ##
            OR ((J EQ 15)            ##
            AND ((I EQ 0)            ##
            OR (I EQ 11)             ##
            OR (I EQ 21)))           ##
          THEN                       # IGNORE NON-EXISTANT CUBES #
            BEGIN
            TEST J;
            END
 
 
#
*     CHECK IF MORE THAN *MAXNUM* CUBE LOCATIONS
*     ARE SPECIFIED.
#
 
          IF K GR MAXNUM
          THEN
            BEGIN
            ERRCODE = S"NUM$CUBE";
            LBERR(ERRCODE);
            LBARG$N[0] = K - 1;
            RETURN;
            END
 
          Y$COORD[K] = I;            # SET UP Y AND Z COORDINATES #
          Z$COORD[K] = J;
          K = K + 1;
          END
 
        END
 
      LBARG$N[0] = K - 1;            # SET NUMBER OF CUBES #
      RETURN;
 
      END  # SETCORD #
 
    TERM