SSLABEL 
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
