SSDEBUG 
PRGM SSDEBUG; 
# TITLE SSDEBUG - INITIALIZES *SSDEBUG* UTILITY.                      # 
  
      BEGIN  # SSDEBUG #
  
# 
***   SSDEBUG - INITIALIZES *SSDEBUG* UTILITY.
* 
*     THIS PRGM INITIALIZES *SSDEBUG* UTILITY BY
*     CRACKING THE CONTROL CARD AND CHECKING THE
*     SYNTAX OF THE PARAMETERS. 
* 
*     SSDEBUG,I,L=REPORT. 
* 
*     PRGM SSDEBUG. 
* 
*     ENTRY.     INPUTS TO SSDEBUG ARE -
* 
*               CM         CARTRIDGE MANUFACTURER CODE IS *A *, 
*                          INDICATING *IBM *. 
* 
*               CM = A     CARTRIDGE MANUFACTURE CODE IS *A *,
*                          INDICATING *IBM *. 
* 
*               CM OMITTED CARTRIDGE MANUFACTURER CODE IS *A *, 
*                          INDICATING *IBM *. 
* 
*               CM = ANYTHING ELSE IS CURRENTLY ILLEGAL.
* 
*               CN         NOT PERMITTED. 
* 
*               CN = CSN   DIGIT PORTION OF CARTRIDGE SERIAL NUMBER 
*                          IS *CSN*.
* 
*               CN OMITTED FOR OP=RS, ONE AND ONE OF THE FOLLOWING
*                          MUST BE SPECIFIED: *YI* OR *CN*. 
*                          FOR OP=CF, ONE AND ONLY ONE OF THE FOLLOWING 
*                          MUST BE SPECIFIED: *FO*, *YI*, OR *CN*.
* 
*               I          SOURCE OF DIRECTIVES IS ON FILE
*                          *INPUT*. 
*               I = LFN    SOURCE OF DIRECTIVES IS ON FILE
*                          *LFN*. 
*               I OMITTED  SOURCE OF DIRECTIVES IS ON FILE
*                          *INPUT*. 
* 
*               Z          SOURCE OF DIRECTIVES IS ON THE 
*                          CONTROL CARD.
* 
*               L          LISTABLE OUTPUT ON FILE *OUTPUT*.
*               L = LFN    LISTABLE OUTPUT ON FILE *LFN*. 
*               L = 0      NO OUTPUT FILE GENERATED.
*               L OMITTED  SAME AS *L*. 
* 
*               *SSDEBUG* DIRECTIVE OPTIONS ARE-
*               OP         NOT PERMITTED. 
*               OP = XX    WHERE *XX* IS THE DIRECTIVE TO BE PROCESSED. 
*                          *XX* MAY BE ONE OF THE FOLLOWING.
*                          *RS*--READ SELECTED RAW AU.
*                          *RF*--READ SELECTED RAW FILES. 
*                          *RP*--RELEASE SPACE FOR PROBLEM CHAINS.
*                          *RL*--REMOVE FCT ENTRY NOT LINKED PROPERLY 
*                                TO THE SMMAP.
*                          *RC*--REMOVE SMMAP ENTRY WHERE THERE IS NO 
*                                CORRESPONDING FCT ENTRY. 
*                          *CF*--CHANGE FLAG IN SFMCAT OR SMMAP.
*               OP OMITTED NOT PERMITTED. 
* 
*               PF         USE PERMANENT FILE NAME *MMMMBUG* FOR
*                          RAW MSF IMAGE. 
*               PF = PFN   USE PERMANENT FILE NAME *PFN* FOR RAW
*                          MSF IMAGE. 
*               PF OMITTED SAME AS *PF*.
*                          *NOTE* - *PF* IS ONLY USED WITH OP=RS
*                          OR OP=RF.  THE PERMANENT FILE-S FAMILY 
*                          AND USER INDEX WILL BE TAKEN FROM THE
*                          USER-S CURRENT PERMANENT FILE PARAMETERS.
* 
*               FO         NOT PERMITTED. 
*               FO = N     *FCT* ORDINAL. 
*               FO OMITTED MUST BE SPECIFIED FOR OP=RF, OP=RP, AND
*                          OP=RL. 
*                          FOR OP=CF, ONE AND ONLY ONE OF THE FOLLOWING 
*                          MUST BE SPECIFIED: *FO* , *YI* , OR *CN*.
* 
*               ST         NOT PERMITTED. 
*               ST = N     AU NUMBER.  FOR OP=RF AND OP=RP, *N* IS
*                          THE STARTING AU OF A FILE OR FRAGMENT. 
*                          FOR OP=CF, *N* IS THE AU NUMBER OF AN
*                          *FCT* FLAG TO BE CHANGED, AND TAKES PRIORITY 
*                          OVER THE RANGE OF AU INDICATED BY THE
*                          *SL* AND *SU* PARAMETERS.  AU NUMBERS
*                          ARE MEANINGFUL WITH OP=CF ONLY FOR AU
*                          DETAIL FLAGS (FL=SF, FL=FC, OR FL=SC). 
*               ST OMITTED MUST BE SPECIFIED FOR OP=RF AND OP=RP. 
*                          FOR OP=CF, VALUES OF *SL* AND *SU* ARE USED. 
* 
*               FM         USE DEFAULT FAMILY.
*               FM = FAM   PROCESS THE FAMILY *FAM*.
*               FM OMITTED SAME AS *FM*.
* 
*               SB         NOT PERMITTED. 
*               SB = SUB   SELECT A SUBFAMILY *SUB*.
*               SB OMITTED NOT PERMITTED. 
* 
*               SM         USE  A 
*               SM = N     USE SM *N* WHERE *N* IS A LETTER FROM
*                          A TO H.
*               SM OMITTED SAME AS *SM*.
* 
*               SL         COPY, OR CHANGE FLAGS FOR, AU 1
*                          THROUGH *SU* (FROM THE *SU* PARAMETER).
*               SL = Z     COPY, OR CHANGE FLAGS FOR, AU *Z*
*                          THROUGH *SU* (FROM THE *SU* PARAMETER).
*               SL OMITTED SAME AS *SL*.
* 
*               SU         COPY, OR CHANGE FLAGS FOR, AU *SL* 
*                          (FROM THE *SL* PARAMETER) THROUGH 1. 
*               SU = J     COPY, OR CHANGE FLAGS FOR, AU *SL* 
*                          (FROM THE *SL* PARAMETER) THROUGH *J*. 
*               SU OMITTED SAME AS *SU*.
*                          *NOTE* - *SL* AND *SU* MUST BE IN
*                          THE RANGE 1 THROUGH 1931.  *SL* MUST BE
*                          LESS THAN OR EQUAL TO *SU*.
*                          FOR OP=CF, IF *ST* IS SPECIFIED, THEN
*                          *SL* AND *SU* ARE NOT USED.
* 
*               FL         NOT PERMITTED. 
*               FL = XX    SET OR CLEAR FLAG *XX* IN SMMAP OR MSF 
*                          CATALOG (VALID ONLY FOR OP=CF).  *XX* MUST 
*                          BE ONE OF THE FOLLOWING -
*                          *ME* - LINKAGE ERROR FLAG (IN SMMAP).
*                          *FE* - LINKAGE ERROR FLAG (IN MSF CATALOG
*                                 *FCT*). 
*                          *IB* - INHIBIT ALLOCATION FLAG.
*                          *LC* - LOST CARTRIDGE FLAG.
*                          *EW* - EXCESSIVE WRITE PARITY ERROR FLAG.
*                          *SF* - START OF FRAGMENT FLAG. 
*                          *FC* - FROZEN CHAIN FLAG.
*                          *AC* - AU CONFLICT FLAG. 
*               FL OMITTED *FL* MUST BE SPECIFIED FOR OP=CF.
* 
*               ON         FLAG SPECIFIED BY *FL* IS TO BE SET
*                          (VALID ONLY FOR OP=CF).
*               OF         FLAG SPECIFIED BY *FL* IS TO BE CLEARED
*                          (VALID ONLY FOR OP=CF).
* 
*               YI         NOT PERMITTED. 
*               YI = N     USE *N* AS THE Y COORDINATE WHERE
*                          *N* IS FROM 0 TO 21. 
*                          *NOTE* - THERE ARE NO CUBES ON THE 
*                          COLUMN Z=6.
*                          *ZI* MUST BE SPECIFIED WHEN *YI*=N 
*                          IS USED. 
*               YI OMITTED FOR OP=RS, ONE AND ONLY ONE OF THE FOLLOWING 
*                          MUST BE SPECIFIED: *YI* OR *CN*. 
*                          FOR OP=CF, ONE AND ONLY ONE OF THE FOLLOWING 
*                          MUST BE SPECIFIED: *FO*, *YI*, OR *CN*.
*                          *YI* AND *ZI* ARE REQUIRED FOR OP=RC.
* 
*               ZI         NOT PERMITTED. 
*               ZI = N     USE *N* AS THE ZI COORDINATE WHERE 
*                          *N* IS FROM 0 TO 15. 
*                          *YI* MUST BE SPECIFIED WHEN *ZI*=N 
*                          IS USED. 
*               ZI OMITTED *ZI* MUST BE SPECIFIED IF *YI* IS USED.
*                          *YI* AND *ZI* ARE REQUIRED FOR OP=RC.
* 
*     EXIT.     *SSDEBUG* DIRECTIVES WERE PROCESSED OR AN 
*               ERROR CONDITION WAS ENCOUNTERED.
* 
*     MESSAGES. SSDEBUG COMPLETE. 
*               SSDEBUG - MUST BE SYSTEM ORIGIN.
*               UNABLE TO CONNECT WITH EXEC.
* 
*     NOTES.    PRGM *SSDEBUG* INITIALIZES THE *SSDEBUG*
*               UTILITY.  *SSDEBUG* IS A DIRECTIVE
*               ORIENTED UTILITY.  THE DIRECTIVES CAN 
*               BE SPECIFIED ON THE CONTROL CARD OR VIA 
*               A FILE.  THE CONTROL CARD IS CRACKED AND
*               THE DIRECTIVES ARE READ INTO A BUFFER.
*               PROC *DBLOOP* IS CALLED TO CRACK AND
*               SYNTAX CHECK EACH DIRECTIVE.  THE CRACKED 
*               DIRECTIVES ARE WRITTEN TO A SCRATCH FILE. 
*               ANY ERROR IN THE DIRECTIVES CAUSES *SSDEBUG*
*               TO ABORT.  IF THERE ARE NO ERRORS IN THE
*               DIRECTIVES, A CONNECT IS SET UP WITH EXEC.
*               PROC *DBMAIN* IS CALLED TO PROCESS EACH 
*               DIRECTIVE.  A DISCONNECT IS DONE WITH EXEC
*               AFTER ALL THE DIRECTIVES HAVE BEEN PROCESSED
*               SUCCESSFULLY. 
# 
  
# 
****  PRGM SSDEBUG - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC ABORT;                  # CALLS *ABORT* MACRO #
        PROC BZFILL;                 # BLANK/ZERO FILLS A BUFFER #
        PROC DBCALL1;                # ISSUES TYPE 1 REQUESTS TO EXEC # 
        PROC DBERR;                  # ERROR PROCESSOR #
        PROC DBHEAD;                 # WRITES HEADER LINE # 
        PROC DBLOOP;                 # CRACKS AND SYNTAX CHECKS 
                                       DIRECTIVES # 
        PROC DBMAIN;                 # PROCESSES EACH DIRECTIVE # 
        PROC DBTAB;                  # SETS UP ARGUMENT LIST #
        PROC GETFAM;                 # GETS DEFAULT FAMILY AND SUB
                                       SYSTEM ID #
        PROC GETPFP;                 # GET USER-S FAMILY AND UI # 
        PROC GETSPS;                 # GET SYSTEM ORIGIN STATUS # 
        PROC MESSAGE;                # DISPLAYS MESSAGES #
        PROC READ;                   # READS A FILE # 
        PROC RESTPFP;                # RESTORE USER-S *PFP* AND ABORT 
                                       OR RETURN #
        PROC RPCLOSE;                # CLOSES REPORT FILE # 
        PROC RPLINE;                 # WRITES A REPORT LINE # 
        PROC RPOPEN;                 # OPENS REPORT FILE #
        PROC RPSPACE;                # WRITES A BLANK LINE #
        PROC XARG;                   # CRACK PARAMETER LIST # 
        PROC XZAP;                   # *Z* ARGUMENT PROCESSOR # 
        PROC ZSETFET;                # INITIALIZES A FET #
        END 
  
# 
****  PRGM SSDEBUG - XREF LIST END. 
# 
  
      DEF RSLEN     #1#;             # RETURN STATUS WORD LENGTH #
      DEF LISTCON   #0#;             # DO NOT LIST COMDECKS # 
  
                                               CONTROL PRESET;
*CALL COMBFAS 
*CALL COMBBZF 
*CALL COMBCMD 
*CALL COMBCPR 
*CALL COMBPFP 
*CALL COMBUCR 
*CALL COMSPFM 
*CALL COMTDBG 
*CALL COMTDBP 
*CALL COMTDER 
*CALL COMTFMT 
*CALL COMTOUT 
  
      ITEM ARGLIST    U;             # FWA OF ARGUMENT TABLE #
      ITEM BUFP       U;             # FWA OF *CIO* BUFFER #
      ITEM DEFORD     I;             # DEFAULT FAMILY ORDINAL # 
      ITEM ERRFLAG    B;             # ERROR FLAG # 
      ITEM FETP       U;             # FWA OF FET # 
      ITEM FLAG       I;             # ERROR FLAG # 
      ITEM LFN        C(7);          # FILE NAME #
      ITEM LNKORD     I;             # LINKED FAMILY ORDINAL #
      ITEM NUM        I;             # NUMBER OF FAMILIES # 
      ITEM RESPCODE   U;             # RESPONSE CODE FROM EXEC #
  
      ARRAY CALL$SS [0:0] P(CPRLEN);;  # CALLSS REQUEST BLOCK # 
      ARRAY OUTFET [0:0] S(SFETL);;  # FET FOR OUTPUT FILE #
      BASED 
      ARRAY RA [0:0];;               # TO ACCESS CONTROL CARD AREA #
      ARRAY SPSSTAT [0:0] S(RSLEN); 
        BEGIN 
        ITEM SPS$STATUS U(00,48,12);  # RETURN STATUS # 
        END 
  
CONTROL EJECT;
  
      GETSPS(SPSSTAT);               # GET SYSTEM ORIGIN STATUS # 
      IF SPS$STATUS NQ 0
      THEN
        BEGIN 
        DBMSG$LN[0] = " SSDEBUG - MUST BE SYSTEM ORIGIN.";
        MESSAGE(DBMSG[0],SYSUDF1);
        ABORT;
        END 
  
      DBREQID = REQNAME"RQIDBUG";    # SET REQUESTOR ID # 
  
# 
*     SAVE THE USER-S PERMANENT FILE PARAMETERS.
# 
  
      GETPFP(PFP[0]); 
      USER$FAM[0] = PFP$FAM[0]; 
      USER$UI[0] = PFP$UI[0]; 
      USER$PACK[0] = PFP$PACK[0]; 
  
# 
*     CRACK THE CONTROL CARD. 
# 
  
      DBTAB(ARGLIST);                # SET UP ARGUMENT TABLE #
      XARG(ARGLIST,0,FLAG); 
      IF FLAG NQ OK 
      THEN                           # PROCESS SYNTAX ERROR # 
        BEGIN 
        DBERRCODE = S"DSYNT$CRD"; 
        OUT$FETP = 0; 
        DBERR(DBERRCODE); 
        END 
  
# 
*     READ THE DIRECTIVES.
# 
  
      FETP = LOC(DB$FET[0]);
      BUFP = LOC(DB$CBUF[0]); 
      LFN = DBARG$I[0]; 
      ZSETFET(FETP,LFN,BUFP,DBUFL,SFETL); 
  
      IF DBARG$Z[0] NQ 0
      THEN                           # *Z* OPTION SPECIFIED # 
        BEGIN 
        XZAP(DB$FET[0]);
        END 
  
      ELSE
        BEGIN 
        READ(DB$FET[0],RCL);         # READ DIRECTIVE FILE #
        END 
  
# 
*     SET UP THE OUTPUT FILE. 
# 
  
      IF DBARG$WL[0] EQ 0 
      THEN                           # NO OUTPUT FILE SPECIFIED # 
        BEGIN 
        OUT$FETP = 0; 
        END 
  
      ELSE                           # OUTPUT FILE IS SPECIFIED # 
        BEGIN 
        OUT$FETP = LOC(OUTFET[0]);
        END 
  
      RPOPEN(DBARG$L[0],OUT$FETP,DBHEAD);  # OPEN OUTPUT FILE # 
  
# 
*     WRITE THE CONTROL CARD IMAGE TO THE OUTPUT FILE.
# 
  
      P<RA>= 0; 
      BZFILL(RA[O"70"],TYPFILL"BFILL",80);
      RPLINE(OUT$FETP,RA[O"70"],2,80,0);
      RPSPACE(OUT$FETP,SP"SPACE",1);
  
# 
*     CRACK AND SYNTAX CHECK THE DIRECTIVES.
# 
  
      DBLOOP(ARGLIST,ERRFLAG);
      IF ERRFLAG
      THEN                           # SYNTAX ERROR IN DIRECTIVES # 
        BEGIN 
        DBERRCODE = S"DSYNT$CRD"; 
        DBERR(DBERRCODE); 
        END 
  
# 
*     GET THE DEFAULT FAMILY AND SUBSYSTEM ID.
# 
  
      DBSSID = ATAS;
      GETFAM(FAMT,NUM,LNKORD,DEFORD,DBSSID);
      DEF$FAM = FAM$NAME[DEFORD]; 
  
# 
*     CONNECT TO EXEC.
# 
  
      P<CPR> = LOC(CALL$SS[0]); 
      DBCALL1(REQTYP1"CONNECT",RESPCODE); 
      IF RESPCODE NQ OK 
      THEN
        BEGIN 
        DBMSG$LN[0] = " UNABLE TO CONNECT WITH EXEC.";
        MESSAGE(DBMSG[0],SYSUDF1);
        RPCLOSE(OUT$FETP);           # CLOSE OUTPUT FILE #
        RESTPFP(PFP$ABORT);          # RESTORE USER-S *PFP* AND ABORT # 
        END 
  
# 
*     PROCESS EACH DIRECTIVE. 
# 
  
      DBMAIN; 
  
# 
*     DISCONNECT FROM EXEC. 
# 
  
      DBCALL1(REQTYP1"DISCONNECT",RESPCODE);
  
      RPCLOSE(OUT$FETP);
      DBMSG$LN[0] = " SSDEBUG COMPLETE.";  # END WITH DAYFILE MESSAGE # 
      MESSAGE(DBMSG[0],UDFL1);
      RESTPFP(PFP$END);              # RESTORE USER-S *PFP* # 
  
      END  # SSDEBUG #
  
    TERM
PROC DBCALL1((REQCODE),RESPCODE); 
# TITLE DBCALL1 - ISSUES A TYPE 1 UCP CALL TO EXEC.                   # 
  
      BEGIN  # DBCALL1 #
  
# 
**    DBCALL1 - ISSUES A TYPE 1 UCP CALL TO EXEC. 
* 
*     PROC DBCALL1((REQCODE),RESPCODE)
* 
*     ENTRY     (REQCODE) = REQUEST CODE. 
*               (DBREQID) = REQUESTOR ID. 
*               (DBSSID)  = SUBSYSTEM ID. 
*               P<CPR>    = FWA OF CALLSS PARAMETER BLOCK.
* 
*     EXIT      (RESPCODE) = RESPONSE FROM EXEC.
* 
*     NOTES     THE CALLSS PARAMETER BLOCK IS SET UP FOR
*               A TYPE 1 REQUEST AND THE REQUEST IS ISSUED
*               TO EXEC.  TYPE 1 REQUESTS ARE THE UCP 
*               LINKAGE REQUESTS, CONNECT AND DISCONNECT. 
# 
  
      ITEM REQCODE    I;             # REQUEST CODE # 
      ITEM RESPCODE   I;             # RESPONSE FROM EXEC # 
  
# 
****  PROC DBCALL1 - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC CALLSS;                 # ISSUES A UCP/SCP REQUEST # 
        END 
  
# 
****  PRDC DBCALL1 - XREF LIST END. 
# 
  
      DEF LISTCON   #0#;             # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBCPR 
*CALL COMTDBG 
  
      ITEM I          I;             # LOOP INDUCTION VARIABLE #
  
CONTROL EJECT;
  
# 
*     SET UP THE PARAMETER BLOCK. 
# 
  
      FASTFOR I = 0 STEP 1 UNTIL CPRLEN-1 
      DO
        BEGIN 
        CPR1[I] = 0;                 # ZERO FILL PARAMETER BLOCK #
        END 
  
      CPR$RQT[0] = TYP"TYP1"; 
      CPR$RQC[0] = REQCODE; 
      CPR$RQI[0] = DBREQID; 
      CPR$SSPFLG[0] = TRUE; 
      CPR$WC[0] = TYP1$WC;
  
# 
*     ISSUE THE CALL. 
# 
  
      CALLSS(DBSSID,CPR[0],RCL);
      RESPCODE = CPR$ES[0]; 
  
      RETURN; 
  
      END  # DBCALL1 #
  
    TERM
PROC DBCALL3((REQCODE),MAPENT,(FCTORD),(CATFLD),(CATVALUE),RESPCODE); 
# TITLE DBCALL3 - ISSUES TYPE 3 UCP CALL TO EXEC.                     # 
  
      BEGIN  # DBCALL3 #
  
# 
**    DBCALL3 - ISSUES TYPE 3 UCP CALL TO EXEC. 
* 
*     PROC DBCALL3((REQCODE),MAPENT,(FCTORD),(CATFLD),(CATVALUE), 
*       RESPCODE) 
* 
*     ENTRY     (REQCODE)    = REQUEST CODE.
*               (MAPENT)     = UPDATED SMMAP ENTRY. 
*               (FCTORD)     = *FCT* ORDINAL. 
*               (CATFLD)     = CATALOG FIELD TO BE UPDATED. 
*               (CATVALUE)   = NEW VALUE FOR UPDATED CATALOG FIELD. 
*               (DBREQID)    = REQUESTOR ID.
*               (DBSSID)     = SUBSYSTEM ID.
*               (DBARG$FM)   = FAMILY NAME. 
*               (DBARG$SB)   = SUBFAMILY IDENTIFIER.
*               (DBARG$SMID) = SM IDENTIFIER. 
*               (DBARG$Y)    = Y COORDINATE.
*               (DBARG$Z)    = Z COORDINATE.
*               (DBARG$ST)   = STARTING AU NUMBER.
*               P<CPR>       = FWA OF CALLSS PARAMETER BLOCK. 
* 
*     EXIT      (RESPCODE)  = RESPONSE FROM EXEC. 
* 
*     MESSAGES  SSDEBUG ABNORMAL, DBCALL3.
  
*     NOTES     THE PARAMETER BLOCK IS SET UP FOR A TYPE 3
*               REQUEST AND THE REQUEST IS ISSUED TO EXEC.
*               TYPE 3 REQUESTS ARE THE REQUESTS TO MODIFY
*               MSF CATALOGS AND MAPS.  THE SPECIFIC REQUEST
*               ISSUED DEPENDS ON THE REQUEST CODE.  PARAMETERS 
*               NOT NEEDED FOR THE REQUEST ARE IGNORED.  THE
*               RESPONSE CODE FROM EXEC IS RETURNED TO THE
*               CALLING PROC. 
# 
  
      ITEM REQCODE    I;             # REQUEST CODE # 
      ARRAY MAPENT [0:0] P(3);        # SMMAP ENTRY # 
        BEGIN 
        ITEM MAPENTRY  C(00,00,30);  # 3 WORD SMMAP ENTRY # 
        END 
  
      ITEM FCTORD     I;             # *FCT* ORDINAL #
      ITEM CATFLD     I;             # CATALOG FIELD TO BE UPDATED #
      ITEM CATVALUE   I;             # CATALOG VALUE FOR UPDATE # 
      ITEM RESPCODE   I;             # RESPONSE FROM EXEC # 
  
# 
****  PROC DBCALL3 - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC CALLSS;                 # ISSUES A UCP/SCP REQUEST # 
        PROC MESSAGE;                # DISPLAYS MESSAGES #
        PROC RESTPFP;                # RESTORE USER-S *PFP* AND ABORT 
                                       OR RETURN #
        END 
  
# 
****  PROC DBCALL3 - XREF LIST END. 
# 
  
      DEF PROCNAME   #"DBCALL3."#;   # PROC NAME #
  
      DEF LISTCON   #0#;             # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBCPR 
*CALL COMTDBG 
*CALL COMTDBP 
  
      ITEM COMPLETE   B;             # COMPLETION STATUS #
      ITEM I          I;             # LOOP INDUCTION VARIABLE #
  
      SWITCH CALL3ACT: REQTYP3       # TYPE 3 REQUESTS #
               UPDCAT: UPD$CAT,      # UPDATE CATALOG FIELD # 
               UPDMAP: UPD$MAP,      # UPDATE SMMAP ENTRY # 
             PURGFRAG: PURG$FRAG,    # PURGE FRAGMENT # 
              PURGFCT: PURG$FCT;     # PURGE *FCT* ENTRY #
  
CONTROL EJECT;
  
# 
*     CHECK FOR A VALID REQUEST CODE. 
# 
  
      IF REQCODE LS REQTYP3"UPD$CAT"
        OR REQCODE GR REQTYP3"PURG$FCT"  ## 
        OR REQCODE EQ REQTYP3"REL$SETUP"
      THEN                           # ILLEGAL REQUEST CODE # 
        BEGIN 
        DBMSG$PROC[0] = PROCNAME; 
        MESSAGE(DBMSG[0],SYSUDF1);
        RESTPFP(PFP$ABORT);          # RESTORE USER-S *PFP* AND ABORT # 
        END 
  
# 
*     SET UP THE FIELDS COMMON TO ALL THE REQUESTS. 
# 
  
      FASTFOR I  = 0 STEP 1 UNTIL CPRLEN-1
      DO
        BEGIN 
        CPR1[I]  = 0;                # ZERO FILL PARAMETER BLOCK #
        END 
  
      CPR$RQT[0]  = TYP"TYP3";
      CPR$RQC[0]  = REQCODE;
      CPR$RQI[0] = DBREQID; 
      CPR$FAM[0] = DBARG$FM[0]; 
      CPR$SUB[0] = DBARG$SB[0]; 
      CPR$CSU[0] = DBARG$SMID[0]; 
      CPR$WC[0] = TYP3$WC;
  
# 
*     SET UP THE FIELDS NEEDED FOR SPECIFIC REQUESTS. 
# 
  
      GOTO CALL3ACT[REQCODE]; 
  
UPDCAT:                              # UPDATE CATALOG ENTRY # 
      CPR$FCT[0] = FCTORD;
      CPR$AU[0] = DBARG$ST[0];
      CPR$FLD[0] = CATFLD;
      CPR$VAL[0] = CATVALUE;
      GOTO ISSUECALL; 
  
UPDMAP:                              # UPDATE SMMAP ENTRY # 
      CPR$Y[0] = DBARG$YI[0]; 
      CPR$Z[0] = DBARG$ZI[0]; 
      CPR$MAPENT[0] = MAPENTRY[0];
      GOTO ISSUECALL; 
  
PURGFRAG:                            # PURGE FRAGMENT # 
      CPR$FCT[0] = FCTORD;
      CPR$AU[0] = DBARG$ST[0];
      GOTO ISSUECALL; 
  
PURGFCT:                             # PURGE *FCT* ENTRY #
      CPR$FCT[0] = FCTORD;
      GOTO ISSUECALL; 
  
ISSUECALL:                           # ISSUE REQUEST TO EXEC #
      COMPLETE = FALSE; 
      REPEAT WHILE NOT COMPLETE 
      DO
        BEGIN 
        CALLSS(DBSSID,CPR[0],RCL);
        IF CPR$RQR[0] NQ RESPTYP3"RESUB$REQ"
        THEN                         # REQUEST COMPLETE # 
          BEGIN 
          COMPLETE = TRUE;
          TEST DUMMY; 
          END 
  
        CPR$RQR[0] = 0;              # RESUBMIT THE REQUEST # 
        CPR$C[0] = FALSE; 
        END 
  
      RESPCODE = CPR$RQR[0];
      RETURN; 
  
      END  # DBCALL3 #
  
    TERM
PROC DBCALL4((REQCODE),(Y),(Z),(SL),(SH),(FAMLY),(UI),RESPCODE);
# TITLE DBCALL4 - ISSUES A TYPE 4 UCP REQUEST TO EXEC.                # 
  
      BEGIN  # DBCALL4 #
  
# 
**    DBCALL4 - ISSUES A TYPE 4 UCP REQUEST TO EXEC.
* 
*     PROC DBCALL4((REQCODE),(Y),(Z),(STRM),(FAMLY),(UI),RESPCODE)
* 
*     ENTRY     (REQCODE)    = REQUEST CODE.
*               (Y)          = Y COORDINATE.
*               (Z)          = Z COORDINATE.
*               (SL)         = STRIPE LOW.
*               (SH)         = STRIPE HIGH. 
*               (FAMLY)      = USER-S FAMILY NAME.
*               (UI)         = USER INDEX.
*               (DBREQID)    = REQUESTOR ID.
*               (TRNSPORT)   = TRANSPORT ID.
*               (ADDRSENSE)  = FWA OF BUFFER TO HOLD SENSE BYTES. 
*               (DBARG$SMID) = SM ID. 
*               (DBARG$PF)   = FILE NAME TO WHICH DATA IS WRITTEN.
*               P<CPR>       = FWA OF PARAMETER BLOCK.
* 
*     EXIT      (RESPCODE)  = RESPONSE FROM EXEC. 
*               (CPR$DRD)   = TRANSPORT ID (ONLY FOR LOAD CARTRIDGE 
*                             REQUEST). 
*               (ADDRSENSE) = FWA OF BUFFER CONTAINING SENSE BYTES
*                             (ONLY FOR GET DRAWER STATUS REQUEST). 
* 
*     MESSAGES  SSDEBUG ABNORMAL, DBCALL4.
* 
*     NOTES     THE PARAMETER BLOCK IS SET UP FOR A TYPE 4
*               UCP REQUEST AND THE REQUEST IS ISSUED TO EXEC.
*               TYPE 4 REQUESTS ARE THE REQUESTS THAT REQUIRE 
*               SM OR MST ACTIONS PERFORMED.  PARAMETERS NOT
*               NEEDED FOR THE REQUEST ARE IGNORED.  THE RESPONSE 
*               CODE FROM EXEC IS RETURNED TO THE CALLING PROC. 
# 
  
      ITEM REQCODE    I;             # REQUEST CODE # 
      ITEM Y          I;             # Y COORDINATE # 
      ITEM Z          I;             # Z COORDINATE # 
      ITEM SL         I;             # STRIPE LOW # 
      ITEM SH         I;             # STRIPE HIGH #
      ITEM FAMLY      C(7);          # USER-S FAMILY NAME # 
      ITEM UI         U;             # USER INDEX # 
      ITEM RESPCODE   I;             # RESPONSE CODE FROM EXEC #
  
# 
****  PROC DBCALL4 - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC CALLSS;                 # ISSUES A UCP/SCP REQUEST # 
        PROC MESSAGE;                # DISPLAYS MESSAGES #
        PROC RESTPFP;                # RESTORE USER-S *PFP* AND ABORT 
                                       OR RETURN #
        END 
  
# 
****  PROC DBCALL4 - XREF LIST END. 
# 
  
      DEF PROCNAME   #"DBCALL4."#;   # PROC NAME #
  
      DEF LISTCON   #0#;             # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBCPR 
*CALL,COMBLBL 
*CALL COMTDBG 
*CALL COMTDBP 
*CALL,COMTLAB 
  
      ITEM I          I;             # LOOP INDUCTION VARIABLE #
  
# 
*     ARRAY TO HOLD CARTRIDGE LABEL.
# 
  
      ARRAY CARTLABEL[0:0]S(LABLEN);; 
  
      SWITCH CALL4ACT: REQTYP4       # TYPE 4 REQUESTS #
             LOADCART: LOAD$CART,    # LOAD CARTRIDGE # 
             UNLDCART: UNLD$CART,    # UNLOAD CARTRIDGE # 
             WRITELAB: WRT$LAB,      # WRITE CARTRIDGE LABEL #
             CPRAWSTR: CP$RAW$AU;    # COPY RAW AU #
  
CONTROL EJECT;
  
# 
*     CHECK FOR A VALID REQUEST CODE. 
# 
  
      IF REQCODE NQ REQTYP4"LOAD$CART"  ##
        AND REQCODE NQ REQTYP4"UNLD$CART"  ## 
        AND REQCODE NQ REQTYP4"CP$RAW$AU"  ## 
        AND REQCODE NQ REQTYP4"WRT$LAB" 
      THEN                           # ILLEGAL REQUEST CODE # 
        BEGIN 
        DBMSG$PROC[0] = PROCNAME; 
        MESSAGE(DBMSG[0],SYSUDF1);
        RESTPFP(PFP$ABORT);          # RESTORE USER-S *PFP* AND ABORT # 
        END 
  
# 
*     SET UP THE FIELDS COMMON TO ALL REQUESTS. 
# 
  
      FASTFOR I = 0 STEP 1 UNTIL CPRLEN-1 
      DO
        BEGIN 
        CPR1[I] = 0;                 # ZERO FILL PARAMETER BLOCK #
        END 
  
      CPR$RQT[0] = TYP"TYP4"; 
      CPR$RQC[0] = REQCODE; 
      CPR$RQI[0] = DBREQID; 
      CPR$CSU[0] = DBARG$SMID[0]; 
      CPR$WC[0] = TYP4$WC;
  
# 
*     SET UP THE FIELDS FOR SPECIFIC REQUESTS.
# 
  
      GOTO CALL4ACT[REQCODE]; 
  
LOADCART:                            # LOAD CARTRIDGE FROM Y,Z #
      CPR$Y[0] = Y; 
      CPR$Z[0] = Z; 
      CPR$ADDR2[0] = LOC(CARTLABEL[0]); 
      GOTO ISSUECALL; 
  
UNLDCART:                            # UNLOAD CARTRIDGE TO Y,Z #
      CPR$Y[0] = Y; 
      CPR$Z[0] = Z; 
      CPR$DRD[0] = TRNSPORT;
      GOTO ISSUECALL; 
  
CPRAWSTR:                            # COPY RAW AU #
      CPR$Y[0] = Y; 
      CPR$Z[0] = Z; 
      CPR$DRD[0] = TRNSPORT;
      CPR$ST$LW = SL; 
      CPR$ST$HI = SH; 
      CPR$FAM[0] = FAMLY; 
      CPR$PFN[0] = DBARG$PF[0]; 
      CPR$UI[0] = UI; 
      GOTO ISSUECALL; 
  
WRITELAB: 
      CPR$Y[0] = Y; 
      CPR$Z[0] = Z; 
      CPR$ADDR2[0] = LOC(CARTLABEL[0]); 
      P<LABEL$CART> = LOC(CARTLABEL[0]);
      LAB$CARTTP[0] = LABTYPE"SCR$LAB"; 
      LAB$SMID[0] = " ";
      LAB$FMLY[0] = " ";
      GOTO ISSUECALL; 
ISSUECALL:                           # ISSUE REQUEST TO EXEC #
      CALLSS(DBSSID,CPR[0],RCL);
      RESPCODE = CPR$RQR[0];
      RETURN; 
  
      END  # DBCALL4 #
  
    TERM
PROC DBCMAP;
# TITLE DBCMAP - REMOVE SMMAP ENTRY.                                 #
  
      BEGIN  # DBCMAP # 
  
# 
**    DBCMAP - REMOVE SMMAP ENTRY.
* 
*     PROC DBCMAP.
* 
*     ENTRY    THE CRACKED AND SYNTAX CHECKED DIRECTIVE PARAMETERS
*              ARE SET UP IN THE COMMON AREA DEFINED IN *COMTDBP*.
*              THE SMMAP IS OPEN FOR THE SPECIFIED SM.
*              P<CPR> = FWA OF CALLSS PARAMETER BLOCK.
* 
*     EXIT     THE DIRECTIVE WAS PROCESSED AND MAP WAS
*              CLOSED OR AN ERROR CONDITION WAS DETECTED. 
* 
*     MESSAGES SSDEBUG ABNORMAL, DBCMAP.
* 
*     NOTES    THE SELECTED SMMAP ENTRY IS CHECKED FOR THE
*              ERROR FLAG.  IF SET, THE CARTRIDGE FROM THAT 
*              LOCATION IS MOVED TO THE OUTPUT DRAWER AND THE 
*              SMMAP ENTRY IS UPDATED TO BE EMPTY AND UNASSIGNED. 
# 
  
# 
****  PROC DBCMAP - XREF LIST BEGIN.
# 
  
      XREF
        BEGIN 
        PROC DBCALL3;                # ISSUES A TYPE 3 UCP REQUEST #
        PROC DBCALL4;                # ISSUES A TYPE 4 UCP REQUEST #
        PROC DBERR;                  # ERROR PROCESSOR #
        PROC DBRESP;                 # PROCESS RESPONSE FROM EXEC # 
        PROC MCLOSE;                 # CLOSES SMMAP # 
        PROC MESSAGE;                # DISPLAYS MESSAGES #
        PROC MGETENT;                # GET SMMAP ENTRY #
        PROC RESTPFP;                # RESTORE USER-S *PFP* AND ABORT 
                                       OR RETURN #
        END 
  
# 
****  PROC DBCMAP - XREF LIST END.
# 
  
      DEF PROCNAME  #"DBCMAP."#;     # PROC NAME #
  
      DEF LISTCON   #0#;             # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBCPR 
*CALL COMBCMS 
*CALL COMBMAP 
*CALL COMTDBG 
*CALL COMTDBP 
*CALL COMTDER 
*CALL COMTLAB 
  
      ITEM CMAPADR    I;             # FWA OF MAP ENTRY # 
      ITEM FLAG       I;             # ERROR STATUS # 
      ITEM ORD        I;             # SMMAP ENTRY ORDINAL #
      ITEM RESPCODE   I;             # RESPONSE FROM EXEC # 
      ITEM UNLOAD     B;             # UNLOAD REQUIRED FLAG # 
      ITEM Y          I;             # Y COORDINATE # 
      ITEM Z          I;             # Z COORDINATE # 
  
      ARRAY CMAPENT [0:0] P(MAPENTL);;  # SMMAP ENTRY # 
  
CONTROL EJECT;
  
# 
*     CHECK THE SMMAP ENTRY FOR THE ERROR FLAG. 
# 
  
      CMAPADR = LOC(CMAPENT[0]);
      ORD = MAXORD - DBARG$ZI[0] - ( DBARG$YI[0]*16 );
      MGETENT(DBARG$SMID[0],ORD,CMAPADR,FLAG);
      IF FLAG NQ CMASTAT"NOERR" 
      THEN                           # ABNORMAL TERMINATION # 
        BEGIN 
        DBMSG$PROC[0] = PROCNAME; 
        MESSAGE(DBMSG[0],SYSUDF1);
        RESTPFP(PFP$ABORT);          # RESTORE USER-S *PFP* AND ABORT # 
        END 
  
      P<SMUMAP> = CMAPADR;
      IF NOT CM$FLAG1[0]
      THEN                           # SMMAP ERROR FLAG NOT SET # 
        BEGIN 
        DBERRCODE = S"DMAP$NSET"; 
        DBERR(DBERRCODE); 
        RETURN; 
        END 
  
# 
*     UPDATE THE SMMAP ENTRY TO BE EMPTY AND UNASSIGNED.
# 
  
      UNLOAD = CM$CSND[0] NQ "";      # SET FLAG IF UNLOAD REQUIRED # 
      CM$CODE[0] = CUBSTAT"UNASGN"; 
      CM$TCSN[0] = "          ";
      CM$FMLYNM[0] = "       "; 
      CM$SUB[0] = 0;
      CM$FCTORD[0] = 0; 
      CM$FLAG1[0] = FALSE;
      DBCALL3(REQTYP3"UPD$MAP",CMAPENT[0],0,0,0,RESPCODE);
      IF RESPCODE NQ RESPTYP3"OK3"
      THEN                           # UNABLE TO UPDATE ENTRY # 
        BEGIN 
        DBRESP(RESPCODE,TYP"TYP3"); 
        RETURN; 
        END 
  
      MCLOSE(DBARG$SMID[0],FLAG); 
      IF FLAG NQ CMASTAT"NOERR" 
      THEN                           # UNABLE TO CLOSE MAP #
        BEGIN 
        DBRESP(FLAG,0); 
        END 
  
# 
*     MOVE THE CARTRIDGE TO THE OUTPUT DRAWER.
# 
  
      IF UNLOAD 
      THEN
        BEGIN  # MOVE CARTRIDGE TO OUTPUT DRAWER #
        DBCALL4(REQTYP4"LOAD$CART",DBARG$YI[0],DBARG$ZI[0],0,0,0,0, 
          RESPCODE);
        IF RESPCODE EQ RESPTYP4"CELL$EMP" 
        THEN                         # EMPTY CUBE # 
          BEGIN 
          DBERRCODE = S"DEMPTYCUBE";
          DBERR(DBERRCODE);          # ISSUE INFORMATIVE MESSAGE #
          RETURN; 
          END 
  
        IF RESPCODE NQ RESPTYP4"OK4"
        THEN                         # OTHER ERROR ON LOAD #
          BEGIN 
          DBRESP(RESPCODE,TYP"TYP4"); 
          RETURN; 
          END 
  
        TRNSPORT = CPR$DRD[0];       # SET UP TRANSPORT ID #
        Z = 0;
        Y = SM$EXIT$TY;              # SET EXIT TRAY #
        DBCALL4(REQTYP4"WRT$LAB",Y,Z,0,0,0,0,RESPCODE); 
        IF RESPCODE NQ RESPTYP4"OK4"
        THEN                         # *CHANGE* FAILS # 
          BEGIN 
          DBRESP(RESPCODE,TYP"TYP4"); 
          RETURN; 
          END 
  
        END  # MOVE CARTRIDGE TO OUTPUT DRAWER #
  
      RETURN; 
  
      END  # DBCMAP # 
  
    TERM
PROC DBCONV(FLAG);
# TITLE DBCONV - CONVERTS CRACKED PARAMETERS TO INTEGERS.             # 
  
      BEGIN  # DBCONV # 
  
# 
**    DBCONV - CONVERTS CRACKED PARAMETERS TO INTEGERS. 
* 
*     PROC DBCONV(FLAG) 
* 
*     ENTRY    THE CRACKED PARAMETERS ARE SET UP IN THE COMMON AREA 
*              DEFINED IN *COMTDBP*.
* 
*     EXIT     THE CRACKED PARAMETERS ARE CONVERTED OR REPLACED 
*              BY DEFAULT VALUES AND PLACED BACK IN THE SAME
*              COMMON AREA. 
*              (FLAG) = 0, NO ERROR.
*                       1, CONVERSION ERROR.
* 
*     NOTES    THE PARAMETERS ARE CONVERTED FROM DISPLAY
*              CODE TO INTEGER VALUES OR ARE REPLACED BY
*              DEFAULT VALUES.  THE CONVERTED PARAMETERS
*              ARE PLACED BACK IN THEIR ORIGINAL LOCATIONS. 
# 
  
      ITEM FLAG       I;             # ERROR FLAG # 
  
# 
****  PROC DBCONV - XREF LIST BEGIN.
# 
  
      XREF
        BEGIN 
        FUNC XDXB   I;               # DISPLAY TO INTEGER CONVERSION #
        END 
  
# 
****  PROC DBCONV - XREF LIST END.
# 
  
      DEF LISTCON   #0#;             # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBCPR 
*CALL COMTDBG 
*CALL COMTDBP 
  
      ITEM TEMP       I;             # TEMPORARY ITEM # 
  
CONTROL EJECT;
  
      FLAG = 0;                      # INITIALIZE # 
  
# 
*     CHECK THE VALUE OF *SB*.
# 
  
      IF DBARG$SB[0] EQ 0 
      THEN                           # *SB* OMITTED # 
        BEGIN 
        DBARG$SB[0] = -2; 
        END 
  
      ELSE
        BEGIN 
        IF DBARG$SB[0] NQ -1
        THEN
          BEGIN  # CONVERT *SB* # 
          FLAG = XDXB(DBARG$SB[0],1,TEMP);
          IF FLAG NQ OK 
          THEN                       # CONVERSION ERROR # 
            BEGIN 
            RETURN; 
            END 
  
          DBARG$SB[0] = TEMP; 
          END  # CONVERT *SB* # 
  
        END 
  
# 
*     CHECK THE VALUE OF *SM*.
# 
  
      IF DBARG$SM[0] EQ 0 
      THEN
        BEGIN 
        DBARG$SM[0] = "A";           # USE DEFAULT VALUE #
        END 
  
# 
*     CHECK THE VALUE OF *SL*.
# 
  
      IF DBARG$SL[0] NQ 0 
      THEN
        BEGIN  # CONVERT *SL* # 
        FLAG = XDXB(DBARG$SL[0],1,TEMP);
        IF FLAG NQ OK 
        THEN                         # CONVERSION ERROR # 
          BEGIN 
          RETURN; 
          END 
  
        DBARG$SL[0] = TEMP; 
        END  # CONVERT *SL* # 
  
      ELSE                           # USE DEFAULT VALUE #
        BEGIN 
        DBARG$SL[0] = 1;
        END 
  
# 
*     CHECK THE VALUE OF *SU*.
# 
  
      IF DBARG$SU[0] NQ 0 
      THEN
        BEGIN  # CONVERT *SU* # 
        FLAG = XDXB(DBARG$SU[0],1,TEMP);
        IF FLAG NQ OK 
        THEN                         # CONVERSION ERROR # 
          BEGIN 
          RETURN; 
          END 
  
        DBARG$SU[0] = TEMP; 
        END  # CONVERT *SU* # 
  
      ELSE                           # USE DEFAULT VALUE #
        BEGIN 
        DBARG$SU[0] = 1;
        END 
  
# 
*     CHECK THE VALUE OF *D*. 
# 
  
      IF DBARG$D[0] EQ 0
      THEN                           # *D* OMITTED #
        BEGIN 
        DBARG$D[0] = -2;
        END 
  
      ELSE
        BEGIN 
        IF DBARG$D[0] NQ -1 
        THEN
          BEGIN  # CONVERT *D* #
          FLAG = XDXB(DBARG$D[0],1,TEMP); 
          IF FLAG NQ OK 
          THEN                       # CONVERSION ERROR # 
            BEGIN 
            RETURN; 
            END 
  
          DBARG$D[0] = TEMP;
          END  # CONVERT *D* #
  
        END 
  
# 
*     CHECK THE VALUE OF *YI*.
# 
  
      IF DBARG$YI[0] EQ 0 
      THEN                           # *YI* OMITTED # 
        BEGIN 
        DBARG$YI[0] = -1; 
        END 
  
      ELSE                           # *YI* SPECIFIED # 
        BEGIN 
        IF DBARG$YI[0] NQ O"7777" 
        THEN
          BEGIN  # CONVERT *YI* # 
          FLAG = XDXB(DBARG$YI[0],1,TEMP);
          IF FLAG NQ OK 
          THEN                       # CONVERSION ERROR # 
            BEGIN 
            RETURN; 
            END 
  
          DBARG$YI[0] = TEMP; 
          END  # CONVERT *YI* # 
  
        END 
  
# 
*     CHECK THE VALUE OF *ZI*.
# 
  
      IF DBARG$ZI[0] EQ 0 
      THEN                           # *ZI* OMITTED # 
        BEGIN 
        DBARG$ZI[0] = -1; 
        END 
  
      ELSE                           # *ZI* SPECIFIED # 
        BEGIN 
        IF DBARG$ZI[0] NQ O"7777" 
        THEN
          BEGIN  # CONVERT *ZI* # 
          FLAG = XDXB(DBARG$ZI[0],1,TEMP);
          IF FLAG NQ OK 
          THEN
            BEGIN 
            RETURN; 
            END 
  
          DBARG$ZI[0] = TEMP; 
          END  # CONVERT *ZI* # 
  
        END 
  
# 
*     CHECK THE VALUE OF *PF*.
# 
  
      IF DBARG$WPF[0] EQ 0
      THEN
        BEGIN 
        DBARG$PF[0] = "MMMMBUG";     # USE DEFAULT VALUE #
        END 
  
# 
*     CHECK THE VALUE OF *FO*.
# 
  
      IF DBARG$FO[0] EQ 0 
      THEN                           # *FO* OMITTED # 
        BEGIN 
        DBARG$FO[0] = -2; 
        END 
  
      ELSE                           # *FO* SPECIFIED # 
        BEGIN 
        IF DBARG$FO[0] NQ -1
        THEN
          BEGIN  # CONVERT *FO* # 
          FLAG = XDXB(DBARG$FO[0],1,TEMP);
          IF FLAG NQ OK 
          THEN                       # CONVERSION ERROR # 
            BEGIN 
            RETURN; 
            END 
  
          DBARG$FO[0] = TEMP; 
          END  # CONVERT *FO* # 
  
        END 
  
# 
*     CHECK THE VALUE OF *ST*.
# 
  
      IF DBARG$ST[0] EQ 0 
      THEN                           # *ST* OMITTED # 
        BEGIN 
        DBARG$ST[0] = -2; 
        END 
  
      ELSE                           # *ST* SPECIFIED # 
        BEGIN 
        IF DBARG$ST[0] NQ -1
        THEN
          BEGIN  # CONVERT *ST* # 
          FLAG = XDXB(DBARG$ST[0],1,TEMP);
          IF FLAG NQ OK 
          THEN                       # CONVERSION ERROR # 
            BEGIN 
            RETURN; 
            END 
  
          DBARG$ST[0] = TEMP; 
          END  # CONVERT *ST* # 
  
        END 
  
      RETURN; 
  
      END  # DBCONV # 
  
    TERM
  
PROC DBERR(ERRCODE);
# TITLE DBERR - ERROR PROCESSOR.                                      # 
  
      BEGIN  # DBERR #
  
# 
**    DBERR - ERROR PROCESSOR.
* 
*     PROC DBERR(ERRCODE) 
* 
*     ENTRY   (ERRCODE)    = ERROR CODE.
*             (OUT$FETP)   = FWA OF FET FOR OUTPUT FILE.
*             (DBARG$PF)   = PERMANENT FILE NAME. 
*             (DBARG$DIRN) = DIRECTIVE NUMBER IN DISPLAY CODE.
* 
*     EXIT    ERROR PROCESSING DONE.  DEPENDING ON THE
*             ERROR CODE EITHER *SSDEBUG* IS TERMINATED 
*             OR CONTROL IS RETURNED BACK TO THE CALLING
*             PROC. 
* 
*     MESSAGES SSDEBUG ABNORMAL, DBERR. 
*              SEE ARRAY *ERRMSG* FOR THE DAYFILE MESSAGES
*              PRINTED OUT. 
* 
*     NOTES   *DBERR* IS A TABLE DRIVEN ERROR PROCESSOR.  A 
*             TABLE HAS BEEN PRESET WITH THE ERROR MESSAGES 
*             WHICH CORRESPOND TO THE ERROR STATUS LIST SET 
*             UP IN *COMTDER*.  THE ERROR CODE CORRESPONDS
*             TO THE ORDINAL OF THE CORRESPONDING ENTRY IN
*             THE TABLE.  THE ACTION TO BE TAKEN FOR THE
*             ERROR CODE HAS BEEN PRESET AS STATUS VALUES 
*             IN THE CORRESPONDING ENTRY IN THE TABLE.  THE 
*             ERROR MESSAGE IS PRINTED OUT IN THE DAYFILE 
*             AND THE REPORT FILE.
# 
  
      ITEM ERRCODE    I;             # ERROR CODE # 
  
# 
****  PROC DBERR - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC BZFILL;                 # BLANK/ZERO FILL A BUFFER # 
        PROC MESSAGE;                # DISPLAYS MESSAGE # 
        PROC RESTPFP;                # RESTORE USER-S *PFP* AND ABORT 
                                       OR RETURN #
        PROC RPCLOSE;                # CLOSE OUTPUT FILE #
        PROC RPLINE;                 # PRINTS A REPORT LINE # 
        PROC RPSPACE;                # PRINTS A BLANK LINE #
        FUNC XCDD C(10);             # CONVERTS TO DISPLAY CODE # 
        END 
  
# 
****  PROC DBERR - XREF LIST END. 
# 
  
      DEF PROCNAME  #"DBERR."#;      # PROC NAME #
  
      STATUS ACTION                  # ACTION TO BE TAKEN # 
        MSG,                         # DISPLAY DAYFILE/REPORT MESSAGE # 
        MSGDTL,                      # DISPLAY DETAILED MESSAGE # 
        RETRN,                       # RETURN TO CALLING PROC # 
        ABRT,                        # ABORT PROCESSING # 
        LSTACT;                      # END OF STATUS LIST # 
  
      DEF LISTCON   #0#;             # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBBZF 
*CALL COMBCPR 
*CALL COMTDBG 
*CALL COMTDBP 
*CALL COMTDER 
*CALL COMTOUT 
  
      ITEM DIS$ERR    C(20);         # ERROR CODE IN DISPLAY #
      ITEM FNAME      C(7);          # FILE NAME #
      ITEM I          I;             # LOOP INDUCTION VARIABLE #
      ITEM STAT       I;             # STATUS VALUE # 
  
# 
*     ARRAYS FOR DISPLAZING DAYFILE MESSAGES. 
# 
  
      ARRAY DAYMSG [0:0] P(5);       # ERROR MESSAGE #
        BEGIN 
        ITEM DAY$MSGTXT C(00,00,40);  # MESSAGE TEXT #
        ITEM DAY$MSGFIL C(01,48,07);  # FILE NAME # 
        ITEM DAY$MSGTRM U(04,00,60) = [0];  # ZERO BYTE TERMINATOR #
        END 
  
      ARRAY DIRNUM [0:0] P(2);       # DIRECTIVE NUMBER # 
        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 DIR$TRM    U(01,30,30) = [0];  # ZERO BYTE TERMINATOR #
        END 
  
      ARRAY ERRNUM [0:0] P(3);       # ERROR NUMBER # 
        BEGIN 
        ITEM ERR$TXT    C(00,00,15) = [" SSDEBUG ERROR "];
        ITEM ERR$NUM    C(01,30,03);  # ERROR NUMBER #
        ITEM ERR$PRD    C(01,48,02) = [". "];  # ENDING PERIOD #
        ITEM ERR$TRM    U(02,00,60) = [0];  # ZERO BYTE TERMINATOR #
        END 
  
# 
*     ARRAY PRESET WITH THE ERROR MESSAGES AND THE STATUS 
*     VALUES REPRESENTING THE ACTION TO BE TAKEN ON AN ERROR
*     CODE. 
# 
  
      ARRAY ERRMSG [0:DBCODEMAX] S(5);
        BEGIN 
        ITEM ERR$MSG    C(00,00,38) = [ 
        " SYNTAX ERROR, SSDEBUG ABORT.",
        " SYNTAX ERROR IN DIRECTIVE.",
        " ILLEGAL DIRECTIVE.",
        " FO NOT SPECIFIED CORRECTLY.", 
        " ST NOT SPECIFIED CORRECTLY.", 
        " ILLEGAL SUBFAMILY.",
        " ILLEGAL SM.", 
        " ILLEGAL SL.", 
        " ILLEGAL SU.", 
        # CSN OPTION VIOLATED.#,
        # CN OR YI OPTION VIOLATED.#, 
        # CN, FO, OR YI OPTION VIOLATED.#,
        " FL OPTION VIOLATED.", 
        " ON,OF OPTION VIOLATED.",
        " ILLEGAL D.",
        " YI,ZI OPTION VIOLATED.",
        " CUBE EMPTY - SMMAP ENTRY REMOVED.", 
        " UNABLE TO DEFINE        .", 
        " ATTACH ERROR ON         .", 
        # CSN NOT FOUND.#,
        # CSN OR Y-Z NOT IN SUBFAMILY.#,
        " NON FROZEN FRAGMENT.",
        " FROZEN CHAIN.", 
        " SMMAP ERROR FLAG NOT SET IN FCT.",
        " ERROR FLAG NOT SET IN SMMAP.",
        " CATALOG/MAP INTERLOCKED.",
        " PERMANENT FILE PROBLEM.", 
        " NO SUCH SUBCATALOG.", 
        " FCT ORDINAL OUT OF RANGE.", 
        " CATALOG/MAP NOT OPEN.", 
        " CARTRIDGE NOT FOUND.",
        " MSF SYSTEM ERROR.", 
        " MSF HARDWARE PROBLEM.", 
        " DISK FILE ERROR.",
        " ONLY PART OF CARTRIDGE LABEL MATCHED.", 
        " CARTRIDGE IN USE.", 
        " SPECIFIED CELL EMPTY.", 
        " NO CARTRIDGE LABEL MATCH.", 
        " UNRECOVERABLE READ ERROR.", 
        " VOLUME HEADER ERROR.",
        " DISK FULL.",
        " STORAGE MODULE OFF."] ; 
        ITEM ERR$MTRM   U(03,48,12) = [0,DBCODEMAX(0)]; 
                                     # ZERO BYTE TERMINATOR # 
        ITEM ERR$STATW  U(04,00,60);  # ACTION TO BE TAKEN #
  
# 
*     STATUS VALUES REPRESENTING TYPE OF MESSAGE TO 
*     BE PRINTED. 
# 
  
        ITEM ERR$STAT1  S: ACTION (04,00,06) = [ 17(S"MSG"),
                                                  2(S"MSGDTL"), 
                                                23(S"MSG")];
  
# 
*     STATUS VALUES REPRESENTING TYPE OF ACTION TO BE 
*     TAKEN AFTER PRINTING THE MESSAGE. 
# 
  
        ITEM ERR$STAT2  S: ACTION (04,06,06) =  [    S"ABRT", 
                                                 16(S"RETRN"),
                                                 25(S"ABRT")];
        END 
  
CONTROL EJECT;
  
# 
*     CHECK FOR A LEGAL ERRCODE.
# 
  
      IF ERRCODE LS 0 OR ERRCODE GR DBCODEMAX 
      THEN                           # ILLEGAL ERROR CODE # 
        BEGIN 
        DBMSG$PROC[0] = PROCNAME; 
        MESSAGE(DBMSG[0],SYSUDF1);
        RESTPFP(PFP$ABORT);          # RESTORE USER-S *PFP* AND ABORT # 
        END 
  
# 
*     SET UP THE DIRECTIVE NUMBER AND ERROR CODE
*     FOR DISPLAY.
# 
  
      DIR$NO[0] = DBARG$DIRN[0];
      DIS$ERR = XCDD(ERRCODE);
      ERR$NUM = C<7,3>DIS$ERR;
  
# 
*     DO THE CORRESPONDING PROCESSING FOR THE 
*     ERROR CODE. 
# 
  
      IF ERRCODE NQ DERRLIST"DSYNT$CRD" 
      THEN
        BEGIN  # DISPLAY MESSAGE HEADER # 
        IF ERR$STAT2[ERRCODE] EQ S"ABRT"
        THEN                         # SEND MESSAGE TO SYSTEM DAYFILE # 
          BEGIN 
          MESSAGE(ERRNUM[0],SYSUDF1); 
          MESSAGE(DIRNUM[0],SYSUDF1); 
          END 
  
        ELSE                         # SEND MESSAGE TO USER DAYFILE # 
          BEGIN 
          MESSAGE(ERRNUM[0],UDFL1); 
          MESSAGE(DIRNUM[0],UDFL1); 
          END 
  
        RPLINE(OUT$FETP,"*** ERROR",4,9,1); 
        RPLINE(OUT$FETP,ERR$NUM[0],14,3,0); 
        RPLINE(OUT$FETP,"DIRECTIVE",8,9,1); 
        RPLINE(OUT$FETP,DIR$NO[0],18,3,0);
        END  # DISPLAY MESSAGE HEADER # 
  
# 
*     DISPLAY ERROR MESSAGE.
# 
  
      IF ERR$STAT1[ERRCODE] EQ S"MSG" 
      THEN
        BEGIN  # DISPLAY ERROR MESSAGE #
        IF ERR$STAT2[ERRCODE] EQ S"ABRT"
        THEN                         # SEND MESSAGE TO SYSTEM DAYFILE # 
          BEGIN 
          MESSAGE(ERRMSG[ERRCODE],SYSUDF1); 
          END 
  
        ELSE                         # SEND MESSAGE TO USER DAYFILE # 
          BEGIN 
          MESSAGE(ERRMSG[ERRCODE],UDFL1); 
          END 
  
        RPLINE(OUT$FETP,ERR$MSG[ERRCODE],7,38,0); 
        END 
  
      ELSE
        BEGIN  # DISPLAY DETAILED MESSAGE # 
        DAY$MSGTXT[0] = ERR$MSG[ERRCODE]; 
        FNAME = DBARG$PF[0];
        BZFILL(FNAME,TYPFILL"BFILL",7); 
        DAY$MSGFIL[0] = FNAME;
        IF ERR$STAT2[ERRCODE] EQ S"ABRT"
        THEN                         # SEND MESSAGE TO SYSTEM DAYFILE # 
          BEGIN 
          MESSAGE(DAYMSG[0],SYSUDF1); 
          END 
  
        ELSE                         # SEND MESSAGE TO USER DAYFILE # 
          BEGIN 
          MESSAGE(DAYMSG[0],UDFL1); 
          END 
  
        RPLINE(OUT$FETP,DAY$MSGTXT[0],7,40,0);
        END  # DISPLAY DETAILED MESSAGE # 
  
      RPSPACE(OUT$FETP,SP"SPACE",1);
  
# 
*     ABORT OR RETURN.
# 
  
      IF ERR$STAT2[ERRCODE] EQ S"ABRT"
      THEN
        BEGIN 
        RPCLOSE(OUT$FETP);
        RESTPFP(PFP$ABORT);          # RESTORE USER-S *PFP* AND ABORT # 
        END 
  
      RETURN; 
  
      END  # DBERR #
  
    TERM
PROC DBFLAG;
# TITLE DBFLAG - SET OR CLEAR SPECIFIED FLAGS.                        # 
  
      BEGIN  # DBFLAG # 
  
# 
**    DBFLAG - SET OR CLEAR SPECIFIED FLAGS.
* 
*     *DBFLAG* CHANGES SPECIFIED FLAGS IN SMMAPS OR CATALOGS. 
* 
*     PROC DBFLAG 
* 
*     ENTRY    THE CRACKED AND SYNTAX CHECKED DIRECTIVE PARAMETERS
*              ARE SET UP IN THE COMMON AREA DEFINED IN *COMTDBP*.
*              THE APPROPRIATE SMMAP AND CATALOG, IF ANY, HAVE
*              BEEN OPENED. 
*              P<CPR> = FWA OF *CALLSS* PARAMETER BLOCK.
* 
*     EXIT     THE DIRECTIVE WAS PROCESSED AND THE MAP AND
*              CATALOG WERE CLOSED, OR AN ERROR CONDITION 
*              WAS DETECTED.
* 
*     MESSAGES * SSDEBUG ABNORMAL, DBFLAG.* 
# 
  
# 
****  PROC DBFLAG - XREF LIST BEGIN.
# 
  
      XREF
        BEGIN 
        PROC CCLOSE;                 # CLOSE MSF CATALOG #
        PROC CGETFCT;                # GET *FCT* ENTRY #
        PROC DBCALL3;                # ISSUE TYPE 3 *CALLSS* #
        PROC DBERR;                  # *SSDEBUG* ERROR PROCESSOR #
        PROC DBRESP;                 # RESPOND TO ERROR CONDITION # 
        PROC DBVSN;                  # SEARCH SMMAP FOR A VSN # 
        PROC MCLOSE;                 # CLOSE SMMAP #
        PROC MGETENT;                # GET A SMMAP ENTRY #
        PROC MESSAGE;                # ISSUE MESSAGE #
        PROC RESTPFP;                # RESTORE USER-S *PFP* AND ABORT 
                                       OR RETURN #
        END 
  
# 
****  PROC DBFLAG - XREF LIST END.
# 
  
  
      DEF PROCNAME   #"DBFLAG"#;     # PROCEDURE NAME # 
  
      DEF LISTCON    #0#;            # DO NOT LIST COMMON DECKS # 
*CALL COMBFAS 
*CALL COMBCMS 
*CALL COMBCPR 
*CALL COMBMAP 
*CALL COMBMCT 
*CALL COMTDBG 
*CALL COMTDBP 
*CALL COMTDER 
  
      ITEM CONTINUE   B;             # LOOP CONTROL FLAG #
      ITEM I          I;             # INDUCTION VARIABLE # 
      ITEM ORD        I;             # SMMAP ORDINAL #
      ITEM RESPCODE   I;             # RESPONSE CODE #
      ITEM Y          I;             # SM *Y* COORDINATE #
      ITEM Z          I;             # SM *Z* COORDINATE #
  
      ARRAY FCTENT [0:0] P(FCTENTL); ;  # *FCT* ENTRY # 
      ARRAY MAPENT [0:0] P(MAPENTL); ;  # SMMAP ENTRY # 
  
                                               CONTROL EJECT; 
  
# 
*     IF THE *ST* PARAMETER WAS SPECIFIED, USE THIS VALUE IN PLACE
*     OF THE *SL* AND *SU* AU NUMBERS.
# 
  
      IF DBARG$ST[0] NQ -2
      THEN                           # *ST* SPECIFIED # 
        BEGIN 
        DBARG$SL[0] = DBARG$ST[0];
        DBARG$SU[0] = DBARG$ST[0];
        END 
  
# 
*     GET THE APPROPRIATE SMMAP OR CATALOG ENTRY. 
# 
  
      IF DBARG$FL[0] EQ "ME" AND DBARG$FO[0] GR 0 
      THEN                           # *FCT* ENTRY REQUIRED # 
        BEGIN  # GET *FCT* #
        CGETFCT(DBARG$FM[0],DBARG$SB[0],DBARG$SMID[0],DBARG$FO[0],
          LOC(FCTENT[0]),0,RESPCODE); 
        IF RESPCODE NQ CMASTAT"NOERR" 
        THEN                         # UNABLE TO GET *FCT* #
          BEGIN 
          DBRESP(RESPCODE,0); 
          END 
  
        P<FCT> = LOC(FCTENT[0]);
        IF FCT$Y[0] EQ 0 AND FCT$Z[0] EQ 0
        THEN                        # NO CARTRIDGE FOR THIS *FO* #
          BEGIN 
          RESPCODE = CMASTAT"ORDERR"; 
          DBRESP(RESPCODE,0); 
          END 
  
        DBARG$YI[0] = FCT$Y[0]; 
        DBARG$ZI[0] = FCT$Z[0]; 
        CCLOSE(DBARG$FM[0],DBARG$SB[0],0,RESPCODE); 
        IF RESPCODE NQ CMASTAT"NOERR" 
        THEN                         # UNABLE TO CLOSE CATALOG #
          BEGIN 
          DBRESP(RESPCODE,0); 
          END 
  
        END  # GET *FCT* #
  
      IF DBARG$WCN[0] NQ 0
      THEN                           # CSN SPECIFIED #
        BEGIN  # *CN* SPECIFIED # 
        DBVSN(Y,Z,MAPENT[0],RESPCODE);
        IF RESPCODE NQ OK 
        THEN                         # CSN NOT FOUND #
          BEGIN 
          DBERRCODE = S"DVSN$NFND"; 
          DBERR(DBERRCODE); 
          RETURN; 
          END 
  
        DBARG$YI[0] = Y;
        DBARG$ZI[0] = Z;
        END  # *CN* SPECIFIED # 
  
      IF DBARG$YI[0] GQ 0 
        AND DBARG$WCN[0] EQ 0 
      THEN
        BEGIN  # *YI* SPECIFIED # 
        ORD = MAXORD -DBARG$ZI[0] - ( DBARG$YI[0]*16 ); 
        MGETENT(DBARG$SMID[0],ORD,LOC(MAPENT[0]),RESPCODE); 
        IF RESPCODE NQ CMASTAT"NOERR" 
        THEN                         # UNABLE TO GET MAP ENTRY #
          BEGIN 
          DBMSG$PROC[0] = PROCNAME; 
          MESSAGE(DBMSG[0],SYSUDF1);
          RESTPFP(PFP$ABORT); 
          END 
  
        END  # *YI* SPECIFIED # 
  
# 
*     UPDATE THE CATALOG OR SMMAP AS REQUESTED. 
# 
  
      P<SMUMAP> = LOC(MAPENT[0]); 
      IF DBARG$FL[0] EQ "ME"
      THEN                           # UPDATE SMMAP # 
        BEGIN  # *FL* .EQ. *ME* # 
        CM$FLAG1[0] = DBARG$ON[0] NQ 0; 
        DBCALL3(REQTYP3"UPD$MAP",MAPENT[0],0,0,0,RESPCODE); 
        IF RESPCODE NQ RESPTYP3"OK3"
        THEN                         # UNABLE TO UPDATE MAP # 
          BEGIN 
          DBRESP(RESPCODE,TYP"TYP3"); 
          RETURN; 
          END 
  
        END  # *FL* .EQ. *ME* # 
  
      ELSE                           # UPDATE CATALOG # 
        BEGIN  # *FL* .NE. *ME* # 
        IF DBARG$FO[0] EQ 0 OR DBARG$FO[0] EQ -2
        THEN
          BEGIN  # *FO* NOT SPECIFIED # 
          IF CM$CODE[0] NQ CUBSTAT"SUBFAM"
          THEN                       # VSN OR Y-Z NOT IN SUBFAMILY #
            BEGIN 
            DBERRCODE = S"DNOTIN$SB"; 
            DBERR(DBERRCODE); 
            RETURN; 
            END 
  
          DBARG$FO[0] = CM$FCTORD[0]; 
          DBARG$FM[0] = CM$FMLYNM[0]; 
          DBARG$SB[0] = CM$SUB[0];
          END  # *FO* NOT SPECIFIED # 
  
        CONTINUE = TRUE;
        SLOWFOR I = DBARG$SL[0] STEP 1
          WHILE CONTINUE
          AND I LQ DBARG$SU[0]
        DO
          BEGIN 
          CONTINUE = DBARG$FLSD[0];  # TRUE FOR AU DETAIL FLAGS # 
          DBARG$ST[0] = I;
          DBCALL3(REQTYP3"UPD$CAT",0,DBARG$FO[0],DBARG$FLCD[0], 
            DBARG$ON[0],RESPCODE);
          IF RESPCODE NQ RESPTYP3"OK3"
          THEN                       # UNABLE TO UPDATE CATALOG # 
            BEGIN 
            DBRESP(RESPCODE,TYP"TYP3"); 
            RETURN; 
            END 
  
          END 
  
        END  # *FL* .NE. *ME* # 
  
      IF DBARG$FL[0] EQ "ME" OR DBARG$FO[0] EQ 0
      THEN                           # MAP OPENED # 
        BEGIN 
        MCLOSE(DBARG$SMID[0],RESPCODE); 
        IF RESPCODE NQ CMASTAT"NOERR" 
        THEN                         # UNABLE TO CLOSE MAP #
          BEGIN 
          DBRESP(RESPCODE,0); 
          END 
  
        END 
  
      END  # DBFLAG # 
  
    TERM
PROC DBFMAP;
# TITLE DBFMAP - REMOVE *FCT* ENTRY.                                  # 
  
      BEGIN  # DBFMAP # 
  
# 
**    DBFMAP - REMOVE *FCT* ENTRY.
* 
*     PROC DBFMAP.
* 
*     ENTRY    THE CRACKED AND SYNTAX CHECKED DIRECTIVE PARAMETERS
*              ARE SET UP IN THE COMMON AREA DEFINED IN *COMTDBP*.
*              THE CATALOG IS OPEN FOR THE SPECIFIED FAMILY AND 
*              SUBFAMILY. 
*              P<CPR> = FWA OF CALLSS PARAMETER BLOCK.
* 
*     EXIT     THE DIRECTIVE HAS BEEN PROCESSED AND CATALOG 
*              HAS BEEN CLOSED OR AN ERROR CONDITION HAS
*              BEEN DETECTED. 
* 
*     NOTES    THE SELECTED *FCT* ENTRY IS CHECKED FOR THE
*              SMMAP ERROR FLAG AND IF SET, A REQUEST IS
*              SENT TO EXEC TO PURGE THE *FCT* ENTRY. 
# 
  
# 
****  PROC DBFMAP - XREF LIST BEGIN.
# 
  
      XREF
        BEGIN 
        PROC CCLOSE;                 # CLOSES THE CATALOG # 
        PROC CGETFCT;                # GET *FCT* ENTRY #
        PROC DBCALL3;                # ISSUES A TYPE 3 UCP REQUEST #
        PROC DBERR;                  # ERROR PROCESSOR #
        PROC DBRESP;                 # PROCESS RESPONSE FROM EXEC # 
        END 
  
# 
****  PROC DBFMAP - XREF LIST END.
# 
  
      DEF LISTCON   #0#;             # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBCMS 
*CALL COMBCPR 
*CALL COMBMCT 
*CALL COMTDBG 
*CALL COMTDBP 
*CALL COMTDER 
  
      ITEM FCTBADR    I;             # FWA OF BUFFER FOR *FCT* #
      ITEM FLAG       I;             # ERROR STATUS # 
      ITEM RESPCODE   I;             # RESPONSE FROM EXEC # 
  
      ARRAY FCTENT [0:0] P(FCTENTL);;  # *FCT* ENTRY #
  
CONTROL EJECT;
  
# 
*     CHECK THE SMMAP ERROR FLAG IN THE *FCT* ENTRY.
# 
  
      FCTBADR = LOC(FCTENT[0]); 
      CGETFCT(DBARG$FM[0],DBARG$SB[0],DBARG$SMID[0],DBARG$FO[0],
        FCTBADR,0,FLAG);
      IF FLAG NQ CMASTAT"NOERR" 
      THEN                           # UNABLE TO GET *FCT* ENTRY #
        BEGIN 
        DBRESP(FLAG,0); 
        RETURN; 
        END 
  
      P<FCT> = FCTBADR; 
      IF NOT FCT$SEF[0] 
      THEN                           # SMMAP ERROR FLAG NOT SET # 
        BEGIN 
        DBERRCODE = S"DCME$NSET"; 
        DBERR(DBERRCODE); 
        RETURN; 
        END 
  
# 
*     PURGE THE *FCT* ENTRY.
# 
  
      DBCALL3(REQTYP3"PURG$FCT",0,DBARG$FO[0],0,0,RESPCODE);
      IF RESPCODE NQ RESPTYP3"OK3"
      THEN                           # UNABLE TO PURGE *FCT* ENTRY #
        BEGIN 
        DBRESP(RESPCODE,TYP"TYP3"); 
        RETURN; 
        END 
  
      CCLOSE(DBARG$FM[0],DBARG$SB[0],0,FLAG); 
      IF FLAG NQ CMASTAT"NOERR" 
      THEN                           # UNABLE TO CLOSE CATALOG #
        BEGIN 
        DBRESP(FLAG,0); 
        END 
  
      RETURN; 
  
      END  # DBFMAP # 
  
    TERM
PROC DBHEAD((FETP));
# TITLE DBHEAD - PRINT HEADER LINE ON THE REPORT.  #
  
      BEGIN  # DBHEAD # 
  
# 
**    DBHEAD - PRINT HEADER LINE ON THE REPORT. 
* 
*     PROC DBHEAD((FETP)) 
* 
*     ENTRY    (FETP) = FWA OF FET FOR REPORT FILE. 
* 
*     EXIT     HEADER LINE HAS BEEN WRITTEN.
* 
*     NOTES    THE REPORT FORMATTER IS USED TO PRINT
*              THE HEADER LINE. 
# 
  
      ITEM FETP       I;             # FWA OF FET # 
  
# 
****  PROC DBHEAD - XREF LIST BEGIN.
# 
  
      XREF
        BEGIN 
        PROC RPLINEX;                # PRINT A REPORT LINE #
        END 
  
# 
****  PROC DBHEAD - XREF LIST END.
# 
  
      DEF LISTCON #0#;               # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
  
CONTROL EJECT;
  
# 
*     PRINT HEADER LINE.
# 
  
      RPLINEX(FETP,"SSDEBUG REPORT FILE",2,19,0); 
      RPLINEX(FETP," ",2,1,0);
      RPLINEX(FETP," ",2,1,0);
      RETURN; 
  
      END  # DBHEAD # 
  
    TERM
PROC DBLOOP((ARGLIST),ERRFLAG); 
# TITLE DBLOOP - CRACK AND SYNTAX CHECK *SSDEBUG* DIRECTIVES.         # 
  
      BEGIN  # DBLOOP # 
  
# 
**    DBLOOP - CRACK AND SYNTAX CHECK *SSDEBUG* DIRECTIVES. 
* 
*     PROC DBLOOP((ARGLIST),ERRFLAG)
* 
*     ENTRY    (ARGLIST) = FWA OF ARGUMENT LIST.
*              (DB$CBUF) = *SSDEBUG* DIRECTIVES.
*              (DB$FET)  = FET FOR READING DIRECTIVES.
* 
*     EXIT     ALL THE DIRECTIVES HAVE BEEN CRACKED, SYNTAX CHECKED 
*              AND WRITTEN TO A SCRATCH FILE. 
*              (DSCR$FET) = FET FOR READING THE SCRATCH FILE. 
*              (ERRFLAG)  = FALSE, NO ERROR.
*                           TRUE, ERROR IN ONE OR MORE DIRECTIVES.
* 
*     MESSAGES SSDEBUG, NO DIRECTIVES.
* 
*     NOTES    A LOOP IS SET UP TO READ EACH DIRECTIVE. 
*              THE DIRECTIVE IS CRACKED AND THE CRACKED 
*              PARAMETERS ARE CONVERTED FROM DISPLAY
*              CODE TO INTEGER VALUES.  THE CONVERTED PARAMETERS
*              ARE PLACED BACK INTO THE SAME LOCATIONS (DEFINED 
*              IN *COMTDBP*).  THE DIRECTIVE IS THEN CHECKED FOR
*              ALL THE VALID OPTIONS.  ANY ERROR IN THE DIRECTIVE 
*              CAUSES A DIRECTIVE ERROR FLAG TO BE SET UP.  THE 
*              CRACKED DIRECTIVE ALONG WITH THE DIRECTIVE 
*              FLAG, NUMBER AND IMAGE IS WRITTEN TO A SCRATCH 
*              FILE.  THE SCRATCH FILE HAS ONE RECORD WITH
*              AN EOR.  AN ERROR IN ANY DIRECTIVE CAUSES AN 
*              ERROR FLAG TO BE RETURNED TO THE CALLING PROC. 
# 
  
      ITEM ARGLIST    I;             # FWA OF ARGUMENT LIST # 
      ITEM ERRFLAG    B;             # ERROR FLAG # 
  
# 
****  PROC DBLOOP - XREF LIST BEGIN.
# 
  
      XREF
        BEGIN 
        PROC BZFILL;                 # BLANK/ZERO FILLS A BUFFER #
        PROC DBCONV;                 # CONVERT PARAMETERS TO INTEGERS # 
        PROC DBERR;                  # ERROR PROCESSOR #
        PROC DBOPT;                  # CHECKS FOR VALID OPTIONS # 
        PROC LOFPROC;                # LIST OF FILES PROCESSOR #
        PROC MESSAGE;                # DISPLAYS MESSAGES #
        PROC READC;                  # READS 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;                 # WRITES A REPORT LINE # 
        PROC RPSPACE;                # WRITES A BLANK LINE #
        PROC WRITER;                 # WRITES EOR ON A FILE # 
        PROC WRITEW;                 # DATA TRANSFER ROUTINE #
        PROC XARG;                   # CRACK PARAMETER LIST # 
        FUNC XCDD C(10);             # CONVERTS TO DISPLAY CODE # 
        PROC ZFILL;                  # ZERO FILLS A BUFFER #
        PROC ZSETFET;                # INITIALIZES A FET #
        END 
  
# 
****  PROC DBLOOP - XREF LIST END.
# 
  
      DEF WBUFL     #8#;             # LENGTH OF WORKING BUFFER # 
  
      DEF LISTCON   #0#;             # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBBZF 
*CALL COMBCPR 
*CALL COMTDBG 
*CALL COMTDBP 
*CALL COMTDER 
*CALL COMTOUT 
  
      ITEM BUFP       I;             # FWA OF *CIO* BUFFER #
      ITEM COMMENT    B;             # COMMENT INDICATOR #
      ITEM DIRNUM     I;             # DIRECTIVE NUMBER # 
      ITEM EOR        B;             # EOR STATUS ON A FILE # 
      ITEM FETP       I;             # FWA OF FET # 
      ITEM I          I;             # LOOP INDUCTION VARIABLE #
      ITEM FLAG       I;             # ERROR STATUS # 
      ITEM TEMP       C(10);         # TEMPORARY ITEM # 
  
      ARRAY DB$WBUF [0:0] S(WBUFL);  # WORKING BUFFER # 
        BEGIN 
        ITEM DB$DIRIMG  C(00,00,80);  # DIRECTIVE IMAGE # 
        END 
  
CONTROL EJECT;
  
      COMMENT = FALSE;               # INITIALIZE # 
      EOR = FALSE;
      DIRNUM = 0; 
      ERRFLAG = FALSE;
  
# 
*     SET UP FET FOR SCRATCH FILE.
# 
  
      FETP = LOC(DSCR$FET[0]);
      BUFP = LOC(DSCR$BUF[0]);
      ZSETFET(FETP,DBSCR,BUFP,DBUFL,SFETL); 
      RETERN(DSCR$FET[0],RCL);       # RETURN THE SCRATCH FILE #
      LOFPROC(DBSCR);                # ADD LFN TO LIST OF FILES # 
  
# 
*     SET UP A LOOP TO
*     1. READ A DIRECTIVE.
*     2. CRACK THE DIRECTIVE. 
*     3. CONVERT THE PARAMETERS.
*     4. CHECK FOR VALID OPTIONS. 
*     5. WRITE THE DIRECTIVE TO THE SCRATCH FILE. 
# 
  
      FASTFOR I = 0 STEP 1 WHILE NOT EOR
      DO
        BEGIN  # CRACK AND SYNTAX CHECK DIRECTIVES #
  
# 
*     READ THE DIRECTIVE. 
# 
  
        ZFILL(DB$WBUF[0],WBUFL);
        READC(DB$FET[0],DB$WBUF[0],WBUFL,FLAG); 
        IF FLAG NQ OK 
        THEN                         # NO MORE DIRECTIVES # 
          BEGIN 
          EOR = TRUE; 
          TEST I; 
          END 
  
# 
*     CHECK FOR A COMMENT.
# 
  
        IF C<0,1>DB$DIRIMG[0] EQ "*"
        THEN                         # A COMMENT #
          BEGIN 
          COMMENT = TRUE; 
          TEMP = " "; 
          END 
  
        ELSE                         # A DIRECTIVE #
          BEGIN 
          COMMENT = FALSE;
          DIRNUM = DIRNUM + 1;
          TEMP = XCDD(DIRNUM);       # SET UP DIRECTIVE NUMBER #
          TEMP = C<7,3>TEMP;
          END 
  
# 
*     WRITE THE DIRECTIVE IMAGE ALONG WITH THE DIRECTIVE
*     NUMBER TO THE OUTPUT FILE.
# 
  
        BZFILL(DB$WBUF[0],TYPFILL"BFILL",80); 
        RPLINE(OUT$FETP,TEMP,2,5,1);
        RPLINE(OUT$FETP,DB$DIRIMG[0],8,80,0); 
        RPSPACE(OUT$FETP,SP"SPACE",1);
  
        IF COMMENT
        THEN
          BEGIN 
          TEST I;                    # READ NEXT DIRECTIVE #
          END 
  
# 
*     SET UP THE AREA TO BE WRITTEN TO THE
*     SCRATCH FILE. 
# 
  
        ZFILL(DBARG[0],DBDIRPRML);
        DBARG$DIRN[0] = TEMP; 
        DBARG$DIRI[0] = DB$DIRIMG[0]; 
  
# 
*     CRACK THE DIRECTIVE.
# 
  
        XARG(ARGLIST,DB$WBUF[0],FLAG);
        IF FLAG NQ OK 
        THEN                         # SYNTAX ERROR IN DIRECTIVE #
          BEGIN 
          DBARG$DIRF[0] = TRUE; 
          ERRFLAG = TRUE; 
          END 
  
  
# 
*     ADJUST FOR MANUFACTURERS CODE.
# 
  
        IF C<1,1>DBARG$CM[0] NQ "-" 
        THEN                         # INSERT HYPHEN #
          BEGIN 
          C<1,1>DBARG$CM[0] = "-";
          END 
  
# 
*     CONVERT THE PARAMETERS FROM DISPLAY CODE TO 
*     INTEGER VALUES. 
# 
  
        IF NOT DBARG$DIRF[0]
        THEN
          BEGIN  # CONVERT PARAMETERS # 
          DBCONV(FLAG); 
          IF FLAG NQ OK 
          THEN                       # CONVERSION ERROR # 
            BEGIN 
            DBARG$DIRF[0] = TRUE; 
            ERRFLAG = TRUE; 
            END 
  
  
          END  # CONVERT PARAMETERS # 
  
        IF DBARG$DIRF[0]
        THEN
          BEGIN 
          DBERRCODE = S"DSYNT$DIR"; 
          DBERR(DBERRCODE); 
          END 
  
# 
*     CHECK THE DIRECTIVE FOR VALID OPTIONS.
# 
  
        IF NOT DBARG$DIRF[0]
        THEN
          BEGIN  # CHECK VALID OPTIONS #
          DBOPT(FLAG);
          IF FLAG NQ OK 
          THEN                       # VALID OPTIONS VIOLATED # 
            BEGIN 
            DBARG$DIRF[0] = TRUE; 
            ERRFLAG = TRUE; 
            END 
  
          END  # CHECK VALID OPTIONS #
  
# 
*     WRITE THE DIRECTIVE NUMBER, ERROR FLAG, 
*     IMAGE AND THE CRACKED PARAMETERS TO THE 
*     SCRATCH FILE. 
# 
  
        WRITEW(DSCR$FET[0],DBARG[0],DBDIRPRML,FLAG);
        END  # CRACK AND SYNTAX CHECK DIRECTIVES #
  
      IF DIRNUM EQ 0
      THEN                           # NO DIRECTIVES #
        BEGIN 
        DBMSG$LN[0] = " SSDEBUG, NO DIRECTIVES."; 
        MESSAGE(DBMSG[0],SYSUDF1);
        RESTPFP(PFP$ABORT);          # RESTORE USER-S *PFP* AND ABORT # 
        END 
  
      WRITER(DSCR$FET[0],RCL);
      REWIND(DSCR$FET[0],RCL);
      RETURN; 
  
      END  # DBLOOP # 
  
    TERM
PROC DBMAIN;
# TITLE DBMAIN - PROCESS *SSDEBUG* DIRECTIVES.                        # 
  
      BEGIN  # SSDEBUG #
  
# 
**    DBMAIN - PROCESS *SSDEBUG* DIRECTIVES.
* 
*     PROC DBMAIN.
* 
*     ENTRY    THE CRACKED AND SYNTAX CHECKED DIRECTIVES
*              HAVE BEEN WRITTEN TO A SCRATCH FILE WHICH HAS
*              BEEN REWOUND.
*              (DSCR$FET) = FET FOR READING THE SCRATCH FILE. 
* 
*     EXIT     ALL DIRECTIVES HAVE BEEN PROCESSED OR AN ERROR FLAG
*              HAS BEEN SET UP. 
* 
*     MESSAGES FAMILY NOT FOUND.
* 
*     NOTES    A LOOP IS SET UP TO READ EACH DIRECTIVE
*              FROM THE SCRATCH FILE INTO THE COMMON AREA 
*              DEFINED IN *COMTDBP*.  THE CATALOG OR MAP IS 
*              OPENED AND THE CORRESPONDING ROUTINE IS
*              CALLED TO PROCESS THE DIRECTIVE.  ANY ERROR
*              IN DIRECTIVE PROCESSING CAUSES *SSDEBUG* 
*              TO ABORT.
# 
  
# 
****  PROC DBMAIN - XREF LIST BEGIN.
# 
  
      XREF
        BEGIN 
        PROC COPEN;                  # OPEN CATALOG # 
        PROC DBCMAP;                 # PROCESS REMOVE SMMAP ENTRY 
                                       DIRECTIVE #
        PROC DBFLAG;                 # PROCESS CHANGE FLAG DIRECTIVE #
        PROC DBFMAP;                 # PROCESS REMOVE FCT ENTRY 
                                       DIRECTIVE #
        PROC DBRDFIL;                # PROCESS READ FILE DIRECTIVE #
        PROC DBRDSTM;                # PROCESS READ AU DIRECTIVE #
        PROC DBREL;                  # PROCESS RELEASE MSF PROBLEM
                                       CHAIN DIRECTIVE #
        PROC DBRESP;                 # PROCESSES RESPONSE FROM EXEC # 
        PROC LOFPROC;                # LIST OF FILES PROCESSOR #
        PROC MESSAGE;                # DISPLAY MESSAGES # 
        PROC MOPEN;                  # OPEN SMMAP # 
        PROC READ;                   # READS A FILE # 
        PROC READW;                  # DATA TRANSFER ROUTINE #
        PROC RESTPFP;                # RESTORE USER-S *PFP* AND ABORT 
                                       OR RETURN #
        PROC RETERN;                 # RETURNS A FILE # 
        PROC RPLINE;                 # WRITES A REPORT LINE # 
        PROC RPSPACE;                # WRITES A BLANK LINE #
        PROC SETPFP;                 # SET FAMILY AND USER INDEX #
        PROC SSINIT;                  # SETS UP TABLES AND POINETRS # 
        FUNC XCOD C(10);             # INTEGER TO DISPLAY CONVERSION #
        END 
  
# 
****  PROC DBMAIN - XREF LIST END.
# 
  
      DEF LISTCON   #0#;             # DO NOT LIST COMDECKS # 
  
*CALL COMBFAS 
*CALL COMBCMD 
*CALL COMBCMS 
*CALL COMBCPR 
*CALL COMBPFP 
*CALL COMBSNS 
*CALL COMSPFM 
*CALL COMTDBG 
*CALL COMTDBP 
*CALL COMTOUT 
  
      ITEM DIS$SB     C(10);         # SUBFAMILY IN DISPLAY CODE #
      ITEM EOR        B;             # INDICATES END OF RECORD #
      ITEM I          I;             # LOOP INDUCTION VARIABLE #
      ITEM J          I;             # LOOP INDUCTION VARIABLE #
      ITEM RESPCODE   I;             # RESPONSE CODE #
  
      ARRAY CATNAME [0:0] P(1);      # CATALOG FILE NAME #
        BEGIN 
        ITEM CAT$NAM    C(00,00,06);  # FIRST 6 CHARACTERS #
        ITEM CAT$SB     C(00,36,01);  # SUBFAMILY IDENTIFIER #
        END 
  
      ARRAY DRWSTAT [0:0] S(SNSLEN);;  # DRAWER STATUS TABLE #
  
      ARRAY MAPNAME [0:0] P(1);      # MAP FILE NAME #
        BEGIN 
        ITEM MAP$NAM    C(00,00,07) = ["SMMAP  "];
        ITEM MAP$SM     C(00,30,01);  # SM IDENTIFIER # 
        ITEM MAP$ZFILL  U(00,36,06) = [0];
        END 
  
# 
*     SWITCH TO PROCESS *SSDEBUG* DIRECTIVES.  THE
*     ORDER OF THE SWITCH LABELS IS THE SAME AS THE 
*     DIRECTIVE NAMES SET UP IN ARRAY *DB$DIR*
*     DEFINED IN *COMTDBG*. 
# 
  
      SWITCH DIR$ACT                 # SWITCH TO PROCESS DIRECTIVES # 
        CMAP,                        # REMOVE SMMAP ENTRY # 
        FMAP,                        # REMOVE *FCT* ENTRY # 
        REL,                         # RELEASE PROBLEM CHAIN #
        RDFIL,                       # READ FILE #
        RDSTM,                       # READ AU #
        FLAG;                        # CHANGE FLAG #
  
CONTROL EJECT;
  
      ADDRSENSE = LOC(DRWSTAT[0]);   # FWA OF DRAWER STATUS TABLE # 
      P<SNS> = ADDRSENSE; 
  
# 
*     INITIALIZE THE FETS, BUFFERS, TABLES AND
*     POINTERS NEEDED TO ACCESS CATALOGS AND MAPS.
# 
  
      SSINIT; 
  
# 
*     READ THE DIRECTIVES.
# 
  
      READ(DSCR$FET[0],RCL);
  
      EOR = FALSE;
      FASTFOR I = 0 STEP 1 WHILE NOT EOR
      DO
        BEGIN  # PROCESS EACH DIRECTIVE # 
        READW(DSCR$FET[0],DBARG[0],DBDIRPRML,RESPCODE); 
        IF RESPCODE NQ OK 
        THEN                         # NO MORE DIRECTIVES # 
          BEGIN 
          EOR = TRUE; 
          TEST I; 
          END 
  
# 
*     WRITE THE DIRECTIVE TO THE OUTPUT FILE. 
# 
  
        RPLINE(OUT$FETP,DBARG$DIRN[0],2,5,1); 
        RPLINE(OUT$FETP,DBARG$DIRI[0],8,80,0);
        RPSPACE(OUT$FETP,SP"SPACE",1);
  
        IF DBARG$DIRF[0]
        THEN                         # SYNTAX ERROR IN DIRECTIVE #
          BEGIN 
          RPLINE(OUT$FETP,"*** SYNTAX ERROR",2,16,0); 
          TEST I;                    # GET NEXT DIRECTIVE # 
          END 
  
        IF DBARG$FM[0] EQ 0 
        THEN                         # FAMILY NOT SPECIFIED # 
          BEGIN 
          DBARG$FM[0] = DEF$FAM;     # USE DEFAULT FAMILY # 
          END 
  
        PFP$WRD0[0] = 0;             # SET FLAGS #
        PFP$WRD1[0] = 0;             # CLEAR PACK NAME #
        PFP$FG1[0] = TRUE;
        PFP$FG2[0] = TRUE;
        PFP$FG4[0] = TRUE;
  
# 
*     OPEN THE SMMAP FOR *RS*, *RC* AND *CF* DIRECTIVES.
# 
  
        IF DBARG$OP[0] EQ "RC"
          OR ( DBARG$OP[0] EQ "RS" AND DBARG$WCN[0] NQ 0 )
          OR (DBARG$OP[0] EQ "CF" 
          AND (DBARG$FL[0] EQ "ME" OR DBARG$FO[0] LS 0))
        THEN
          BEGIN  # OPEN SMMAP # 
          PFP$FAM[0] = DEF$FAM;      # SET FAMILY AND USER INDEX #
          PFP$UI[0] = DEF$UI; 
          SETPFP(PFP);
          IF PFP$STAT[0] NQ 0 
          THEN                       # DEFAULT FAMILY NOT FOUND # 
            BEGIN 
            DBMSG$LN[0] = " FAMILY NOT FOUND."; 
            MESSAGE(DBMSG[0],SYSUDF1);
            RESTPFP(PFP$ABORT);      # RESTORE USER-S *PFP* AND ABORT # 
            END 
  
          MAP$SM[0] = DBARG$SM[0];
          MOPEN(DBARG$SMID[0],MAP$NAM[0],"RM",RESPCODE);
          IF RESPCODE NQ CMASTAT"NOERR" 
          THEN                       # UNABLE TO OPEN MAP # 
            BEGIN 
            DBRESP(RESPCODE,0); 
            TEST I; 
            END 
  
          ELSE                       # MAP OPENED # 
            BEGIN 
            LOFPROC(MAP$NAM[0]);     # ADD LFN TO LIST OF FILES # 
            END 
  
          END  # OPEN SMMAP # 
  
# 
*     OPEN THE CATALOG FOR *RF*, *RP*, *RL*, AND *CF* DIRECTIVES. 
# 
  
        IF DBARG$OP[0] EQ "RF"
          OR DBARG$OP[0] EQ "RP"
          OR DBARG$OP[0] EQ "RL"
          OR (DBARG$OP[0] EQ "CF" AND DBARG$FL[0] EQ "ME" 
          AND DBARG$FO[0] GR 0) 
        THEN
          BEGIN  # OPEN CATALOG # 
          PFP$FAM[0] = DBARG$FM[0];  # SET FAMILY AND USER INDEX #
          PFP$UI[0] = DEF$UI + DBARG$SB[0]; 
          SETPFP(PFP);
          IF PFP$STAT[0] NQ 0 
          THEN                       # FAMILY NOT FOUND # 
            BEGIN 
            DBMSG$LN[0] = " FAMILY NOT FOUND."; 
            MESSAGE(DBMSG[0],SYSUDF1);
            RESTPFP(PFP$ABORT);      # RESTORE USER-S *PFP* AND ABORT # 
            END 
  
          CAT$NAM[0] = SFMCAT;
          DIS$SB = XCOD(DBARG$SB[0]); 
          CAT$SB[0] = C<9,1>DIS$SB; 
          COPEN(DBARG$FM[0],DBARG$SB[0],CATNAME[0],"RM",TRUE,RESPCODE); 
          IF RESPCODE NQ CMASTAT"NOERR" 
          THEN                       # UNABLE TO OPEN CATALOG # 
            BEGIN 
            DBRESP(RESPCODE,0); 
            TEST I; 
            END 
  
          ELSE                       # CATALOG OPENED # 
            BEGIN 
            LOFPROC(OCT$LFN[1]);     # ADD LFN TO LIST OF FILES # 
            END 
  
          END  # OPEN CATALOG # 
  
# 
*     PROCESS THE DIRECTIVE.
# 
  
        SLOWFOR J = 0 STEP 1 UNTIL DBDIRNM
        DO
          BEGIN  # FIND MATCHING DIRECTIVE #
          IF DB$DIRNM[J] EQ DBARG$OP[0] 
          THEN
            BEGIN 
            GOTO DIR$ACT[J];
CMAP:                                # REMOVE SMMAP ENTRY # 
            DBCMAP; 
            TEST I; 
  
FMAP:                                # REMOVE *FCT* ENTRY # 
            DBFMAP; 
            TEST I; 
  
REL:                                 # RELEASE PROBLEM CHAINS # 
            DBREL;
            TEST I; 
  
RDFIL:                               # READ FILE #
            DBRDFIL;
            TEST I; 
  
RDSTM:  
            DBRDSTM;                 # READ AU #
            TEST I; 
  
FLAG: 
            DBFLAG;                  # CHANGE FLAG #
            TEST I; 
  
            END 
  
          END  # FIND MATCHING DIRECTIVE #
  
        END  # PROCESS EACH DIRECTIVE # 
  
      RETURN; 
  
      END  # DBMAIN # 
  
    TERM
PROC DBOPT(FLAG); 
# TITLE DBOPT - CHECKS CRACKED PARAMETERS FOR VALID OPTIONS.          # 
  
      BEGIN  # DBOPT #
  
# 
**    DBOPT - CHECKS CRACKED PARAMETERS FOR VALID OPTIONS.
* 
*     PROC DBOPT(FLAG)
* 
*     ENTRY   THE CRACKED AND CONVERTED PARAMETERS ARE SET UP 
*             IN THE COMMON AREA DEFINED IN *COMTDBP*.
* 
*     EXIT    ALL OPTIONS HAVE BEEN CHECKED FOR VALIDITY. 
*             (FLAG) = 0, NO ERROR. 
*                      1, VALID OPTION VIOLATED.
* 
*     NOTES   ALL THE DIRECTIVES ARE CHECKED FOR VALID
*             OPTIONS.  THE VALID OPTIONS ARE 
*               1.  *OP* MUST BE A VALID DIRECTIVE NAME.
*               2.  *FO* MUST BE SPECIFIED FOR OP=RF, RP AND RL,
*                   AND *ST* MUST BE SPECIFIED FOR OP=RF AND RP.
*               3.  *SB* MUST BE FROM 0 TO 7. 
*               4.  *CS* MUST BE FROM A THROUGH H.
*               5.  *SL* AND *SU* MUST BE FROM 1 TO 1931. 
*               5.  *SL* AND *SU* MUST BE FROM 1 TO 1931. 
*               6.  *SL* MUST BE LESS THAN OR EQUAL TO *SU*.
*               7.  FOR OP=RS, ONE AND ONLY ONE OF THE FOLLOWING
*                   PARAMETERS MUST BE SPECIFIED:  *V*, *YI*, OR *D*. 
*               8.  FOR OP=CF, ONE AND ONLY ONE OF THE FOLLOWING
*                   PARAMETERS MUST BE SPECIFIED:  *V*, *YI*, OR *FO*.
*               9.  *FL*, *ON*, AND *OF* ARE VALID ONLY FOR OP=CF.
*               10. FOR OP=CF, *FL* MUST BE A VALID FLAG NAME AND 
*                   EITHER *ON* OR *OF* MUST BE SPECIFIED.
*               11. *YI* AND *ZI* MUST BE SPECIFIED TOGETHER. 
*               12. *YI* MUST BE FROM 0 TO 21.
*               13. *ZI* MUST BE FROM 0 TO 15.
*               14. *YI*, *ZI* MUST BE SPECIFIED FOR OP=RC. 
* 
*              ANY VIOLATION OF THE VALID OPTIONS CAUSES A
*              MESSAGE TO BE PRINTED IN THE DAYFILE AND THE 
*              REPORT FILE, AND AN ERROR FLAG TO BE RETURNED
*              TO THE CALLING ROUTINE.
# 
  
      ITEM FLAG       I;             # ERROR STATUS # 
  
# 
****  PROC DBOPT - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC DBERR;                  # ERROR PROCESSOR #
        END 
  
# 
****  PROC DBOPT - XREF LIST END. 
# 
  
      DEF LISTCON   #0#;             # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBCPR 
*CALL COMTDBP 
*CALL COMTDBG 
*CALL COMTDER 
*CALL COMTLAB 
  
      ITEM FOUND      B;             # SEARCH FLAG #
      ITEM I          I;             # LOOP INDUCTION VARIABLE #
      ITEM OPTCOUNT   I;             # OPTION COUNT # 
  
CONTROL EJECT;
  
      FLAG = 1;                      # INITIALIZE # 
  
# 
*     CHECK FOR A LEGAL DIRECTIVE NAME. 
# 
  
      FOUND = FALSE;
      FASTFOR I = 0 STEP 1 UNTIL DBDIRNM
      DO
        BEGIN  # SEARCH FOR MATCHING DIRECTIVE NAME # 
        IF DBARG$OP[0] EQ DB$DIRNM[I] 
        THEN
          BEGIN 
          FOUND = TRUE; 
          END 
  
        END  # SEARCH FOR MATCHING DIRECTIVE NAME # 
  
      IF NOT FOUND
      THEN                           # ILLEGAL DIRECTIVE #
        BEGIN 
        DBERRCODE = S"DILLEG$DIR";
        DBERR(DBERRCODE); 
        RETURN; 
        END 
  
# 
*     CHECK IF *FO* SPECIFIED CORRECTLY.
# 
  
      IF DBARG$FO[0] EQ -1           ## 
        OR (DBARG$FO[0] EQ -2        ## 
        AND (DBARG$OP[0] EQ "RF"     ## 
        OR DBARG$OP[0] EQ "RP"       ## 
        OR DBARG$OP[0] EQ "RL"))
        OR ( DBARG$FO[0] GQ 0 AND DBARG$FO[0] LS MINFO )
        OR ( DBARG$FO[0] GR MAXFO ) 
      THEN                           # *FO* OPTION VIOLATED # 
        BEGIN 
        DBERRCODE = S"DVIOL$FO";
        DBERR(DBERRCODE); 
        RETURN; 
        END 
  
# 
*     CHECK IF *ST* IS SPECIFIED CORRECTLY. 
# 
  
      IF DBARG$ST[0] EQ -1           ## 
        OR ( ( DBARG$ST[0] EQ -2       ## 
        OR DBARG$ST[0] EQ 0 )          ## 
        AND (DBARG$OP[0] EQ "RF"     ## 
        OR DBARG$OP[0] EQ "RP"))
      THEN                           # *ST* OPTION VIOLATED # 
        BEGIN 
        DBERRCODE = S"DVIOL$ST";
        DBERR(DBERRCODE); 
        RETURN; 
        END 
  
# 
*     CHECK THE VALUE OF *SB*.
# 
  
      IF DBARG$SB[0] LS 0            ## 
        OR DBARG$SB[0] GR 7 
      THEN                           # *SB* OPTION VIOLATED # 
        BEGIN 
        DBERRCODE = S"DVIOL$SB";
        DBERR(DBERRCODE); 
        RETURN; 
        END 
  
# 
*     CHECK THE VALUE OF *SM*.
# 
  
      IF DBARG$SM[0] LS "A"          ## 
        OR DBARG$SM[0] GR "H"        ## 
        OR DBARG$WSM[0] NQ 0         ## 
      THEN                           # *SM* OPTION VIOLATED # 
        BEGIN 
        DBERRCODE = S"DVIOL$SM";
        DBERR(DBERRCODE); 
        RETURN; 
        END 
  
# 
*     CHECK THE VALUE OF *SL*.
# 
  
      IF ( DBARG$SL[0] LS 0          ## 
        OR DBARG$SL[0] GR INAVOT )  # MAXIMUM AU PER CARTRIDGE #
        OR ( DBARG$OP[0] EQ "RS"     ## 
        AND DBARG$SL[0] EQ 0 )       ## 
      THEN                           # *SL* OPTION VIOLATED # 
        BEGIN 
        DBERRCODE = S"DVIOL$SL";
        DBERR(DBERRCODE); 
        RETURN; 
        END 
  
# 
*     CHECK THE VALUE OF *SU*.
# 
  
      IF ( DBARG$SU[0] LS 0          ## 
        OR DBARG$SU[0] GR INAVOT )  # MAXIMUM AU PER CARTRIDGE #
        OR ( DBARG$OP[0] EQ "RS"     ## 
        AND DBARG$SU[0] EQ 0 )       ## 
        OR DBARG$SU[0] LS DBARG$SL[0] 
      THEN                           # *SU* OPTION VIOLATED # 
        BEGIN 
        DBERRCODE = S"DVIOL$SU";
        DBERR(DBERRCODE); 
        RETURN; 
        END 
  
# 
*     CHECK THE VALUE OF *CN* 
# 
  
      IF DBARG$WCN[0] EQ -1 
      THEN                           # *CN* OPTION VIOLATED # 
        BEGIN 
        DBERRCODE = S"DVIOL$V"; 
        DBERR(DBERRCODE); 
        RETURN; 
        END 
  
  
# 
*     CHECK THE VALUE OF *YI* AND *ZI*. 
# 
  
      IF DBARG$YI[0] LS -1           ## 
        OR DBARG$ZI[0] LS -1         ## 
        OR DBARG$YI[0] GR MAX$Y      ## 
        OR DBARG$ZI[0] GR MAX$Z      ## 
        OR DBARG$ZI[0] EQ Z$NO$CUBE 
      THEN                           # *YI*, *ZI* OPTION VIOLATED # 
        BEGIN 
        DBERRCODE = S"DVIOL$YZ";
        DBERR(DBERRCODE); 
        RETURN; 
        END 
  
# 
*     CHECK IF *YI* AND *ZI* ARE SPECIFIED TOGETHER.
# 
  
      IF (DBARG$YI[0] EQ -1          ## 
        AND DBARG$ZI[0] GQ 0)        ## 
        OR (DBARG$YI[0] GQ 0         ## 
        AND DBARG$ZI[0] EQ -1)
      THEN                           # *YI*, *ZI* OPTION VIOLATED # 
        BEGIN 
        DBERRCODE = S"DVIOL$YZ";
        DBERR(DBERRCODE); 
        RETURN; 
        END 
  
# 
*     *YI*, *ZI* MUST BE SPECIFIED FOR OP=RC. 
# 
  
      IF DBARG$OP[0] EQ "RC"         ## 
        AND DBARG$YI[0] EQ -1 
      THEN                           # *YI*, *ZI* OPTION VIOLATED # 
        BEGIN 
        DBERRCODE = S"DVIOL$YZ";
        DBERR(DBERRCODE); 
        RETURN; 
        END 
  
# 
*     FOR OP=RS, ONE AND ONLY ONE OF THE FOLLOWING MUST BE
*     SPECIFIED:  *CN*, OR *YI*.  FOR OP=CF, ONE AND ONLY 
*     ONE OF THE FOLLOWING MUST BE SPECIFIED: *CN*, *YI*, OR *FO*.
# 
  
      IF DBARG$OP[0] EQ "RS" OR DBARG$OP[0] EQ "CF" 
      THEN
        BEGIN  # CHECK *CN*, *YI*, AND *FO* # 
        OPTCOUNT = 0; 
        IF DBARG$WCN[0] NQ 0
        THEN                          # *CN* SPECIFIED #
          BEGIN 
          OPTCOUNT = OPTCOUNT + 1;
          END 
  
        IF DBARG$YI[0] GQ 0 
        THEN                         # *YI* SPECIFIED # 
          BEGIN 
          OPTCOUNT = OPTCOUNT + 1;
          END 
  
        IF DBARG$OP[0] EQ "CF" ## 
          AND DBARG$FO[0] GR 0
        THEN                         # *FO* SPECIFIED AND OP=CF # 
          BEGIN 
          OPTCOUNT = OPTCOUNT + 1;
          DBERRCODE = S"DVIOL$VFOX";
          END 
  
        IF OPTCOUNT NQ 1
        THEN                         # OPTION VIOLATED #
          BEGIN 
          DBERR(DBERRCODE); 
          RETURN; 
          END 
  
        END  # CHECK *CN*, *YI*, AND *FO* # 
  
  
# 
*     *FL* IS REQUIRED FOR OP=CF, AND NOT ALLOWED FOR ANY 
*     OTHER DIRECTIVES. 
# 
  
      IF (DBARG$OP[0] EQ "CF" AND DBARG$FL[0] LQ 0) 
        OR (DBARG$OP[0] NQ "CF" AND DBARG$FL[0] GR 0) 
      THEN                           # *FL* OPTION VIOLATED # 
        BEGIN 
        DBERRCODE = S"DVIOL$FL";
        DBERR(DBERRCODE); 
        RETURN; 
        END 
  
# 
*     EITHER *ON* OR *OF* (BUT NOT BOTH) MUST BE SPECIFIED FOR
*     OP=CF, BUT NEITHER MAY BE USED WITH OTHER DIRECTIVES. 
# 
  
      IF (DBARG$OP[0] EQ "CF" AND DBARG$ON[0] EQ DBARG$OF[0]) 
        OR (DBARG$OP[0] NQ "CF" 
        AND ((DBARG$ON[0] NQ 0) OR (DBARG$OF[0] NQ 0))) 
      THEN                           # *ON*, *OF* OPTION VIOLATED # 
        BEGIN 
        DBERRCODE = S"DVIOL$ONOF";
        DBERR(DBERRCODE); 
        RETURN; 
        END 
  
# 
*     CHECK FOR A VALID VALUE OF *FL*.
# 
  
      IF DBARG$OP[0] EQ "CF"
      THEN                           # CHANGE FLAG DIRECTIVE #
        BEGIN  # CHECK *FL* # 
        FOUND = FALSE;
        FASTFOR I = 0 STEP 1 WHILE NOT FOUND AND I LQ DBFLAGNM
        DO
          BEGIN 
          IF DBARG$FL[0] EQ DB$FLAG[I]
          THEN
            BEGIN 
            FOUND = TRUE; 
            DBARG$FLCD[0] = DB$FLCODE[I];  # SAVE STATUS VALUE #
            DBARG$FLSD[0] = DB$FLSTR[I];   # AU DETAIL FLAG # 
            END 
  
          END 
  
        IF NOT FOUND
        THEN
          BEGIN 
          DBERRCODE = S"DVIOL$FL";
          DBERR(DBERRCODE); 
          RETURN; 
          END 
  
        END  # CHECK *FL* # 
  
      FLAG = 0;                      # NO ERRORS DETECTED # 
      RETURN; 
  
      END  # DBOPT #
  
    TERM
PROC DBRDFIL; 
# TITLE DBRDFIL - PROCESS READ FILE DIRECTIVE.                        # 
  
      BEGIN  # DBRDFIL #
  
# 
**    DBRDFIL - PROCESS READ FILE DIRECTIVE.
* 
*     PROC DBRDFIL. 
* 
*     ENTRY     THE CRACKED AND SYNTAX CHECKED DIRECTIVE IS 
*               IN THE COMMON AREA DEFINED IN *COMTDBP*.
*               THE CATALOG IS OPEN FOR THE SPECIFIED FAMILY
*               AND SUBFAMILY.
*               P<CPR>     = FWA OF CALLSS PARAMETER BLOCK. 
*               (USER$FAM) = USER-S FAMILY NAME.
*               (USER$UI)  = USER-S USER INDEX. 
* 
*     EXIT      THE DIRECTIVE HAS BEEN PROCESSED AND
*               THE CATALOG HAS BEEN CLOSED OR AN ERROR 
*               CONDITION HAS BEEN DETECTED.
* 
*     MESSAGES  SSDEBUG ABNORMAL, DBRDFIL.
* 
*     NOTES     THE CARTRIDGE IS LOADED AND A REQUEST IS SENT 
*               TO EXEC TO COPY EACH RAW AU IN THE CHAIN
*               TO THE SPECIFIED FILE.  IF AN OFF CARTRIDGE 
*               LINK EXISTS THE NEXT CARTRIDGE IS LOADED.  THIS 
*               SEQUENCE IS REPEATED UNTIL THE ENTIRE FILE IS 
*               COPIED.  IF FROZEN CHAIN FLAG IS SET
*               *SSDEBUG* ABORTS WITH A DAYFILE MESSAGE.
# 
  
# 
****  PROC DBRDFIL - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC CCLOSE;                 # CLOSES THE CATALOG # 
        PROC CGETFCT;                # GET *FCT* ENTRY #
        PROC DBCALL4;                # ISSUES A TYPE 4 UCP REQUEST #
        PROC DBERR;                  # ERROR PROCESSOR #
        PROC DBRESP;                 # PROCESSES RESPONSE FROM EXEC # 
        PROC MESSAGE;                # DISPLAYS MESSAGES #
        PROC PFD;                    # *PFM* REQUEST INTERFACE #
        PROC RESTPFP;                # RESTORE USER-S *PFP* AND ABORT 
                                       OR RETURN #
        PROC RETERN;                 # RETURNS A FILE # 
        PROC SETPFP;                 # SET FAMILY AND USER INDEX #
        PROC ZSETFET;                # INITIALIZES A FET #
        END 
  
# 
****  PROC DBRDFIL - XREF LIST END. 
# 
  
      DEF PROCNAME  #"DBRDFIL."#;    # PROC NAME #
  
      DEF LISTCON   #0#;             # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBCMS 
*CALL COMBCPR 
*CALL COMBMCT 
*CALL COMBPFP 
*CALL COMSPFM 
*CALL COMTDBG 
*CALL COMTDBP 
*CALL COMTDER 
  
      ITEM ANOTHERVOL B;             # MORE VOLUMES ON CARTRIDGE #
      ITEM CHNCNTRL   I;             # CHAIN CONTROL FIELD #
      ITEM FCTBADR    I;             # FWA OF BUFFER FOR *FCT* #
      ITEM FLAG       I;             # ERROR STATUS # 
      ITEM GTNXTCART  B;             # GET NEXT CARTRIDGE FLAG #
      ITEM LAST       B;             # END OF CHAIN INDICATOR # 
      ITEM LINK       I;             # OFF CARTRIDGE LINK # 
      ITEM NXTFCT     I;             # NEXT *FCT* ENTRY ORDINAL # 
      ITEM NXTSTRM    I;             # NEXT AU IN THE CHAIN # 
      ITEM RESPCODE   I;             # RESPONSE FROM EXEC # 
      ITEM SH         I;             # STRIPE HIGH #
      ITEM SL         I;             # STRIPE LOW # 
      ITEM TEMP       I;             # INTEGER SCRATCH #
      ARRAY FCTENT [0:0] P(FCTENTL);;  # *FCT* ENTRY #
      ARRAY SCRFET [0:0] S(SFETL);;  # SCRATCH FET #
  
  
CONTROL EJECT;
  
# 
*     DEFINE THE USER-S FILE TO RECEIVE THE RAW AU DATA.
# 
  
      RESTPFP(PFP$RESUME);           # RESTORE USER-S *PFP* # 
  
      FLAG = 0; 
      PFD("DEFINE",DBARG$PF[0],0,"RC",FLAG,0);
      IF FLAG NQ OK 
      THEN                           # UNABLE TO DEFINE USER-S FILE # 
        BEGIN 
        DBERRCODE = S"DDEF$PF"; 
        DBERR(DBERRCODE); 
        RETURN; 
        END 
  
      ZSETFET(LOC(SCRFET[0]),DBARG$PF[0],0,0,SFETL);
      RETERN(SCRFET[0],RCL);
  
      GTNXTCART = TRUE;              # INITIALIZE THE FLAGS # 
      LINK = 0; 
      ANOTHERVOL = FALSE; 
      NXTFCT = DBARG$FO[0]; 
      SL = INSPAU*DBARG$ST[0] + (INFTST - INSPAU);
      NXTSTRM = DBARG$ST[0];
      LAST = FALSE; 
      FCTBADR = LOC(FCTENT[0]); 
  
# 
*     COPY EACH AU OF THE FILE. 
# 
  
      REPEAT WHILE NOT LAST 
      DO
        BEGIN  # COPY RAW AU #
        IF GTNXTCART  ##
          AND NOT ANOTHERVOL
        THEN
          BEGIN  # GET NEXT CARTRIDGE # 
          CGETFCT(DBARG$FM[0],DBARG$SB[0],DBARG$SMID[0],NXTFCT, 
            FCTBADR,0,FLAG);
          IF FLAG NQ CMASTAT"NOERR" 
          THEN                       # UNABLE TO GET *FCT* ENTRY #
            BEGIN 
            DBRESP(FLAG,0); 
            RETURN; 
            END 
  
# 
*     CHECK FOR FROZEN CHAIN. 
# 
  
          P<FCT> = FCTBADR; 
          IF FCT$Y[0] EQ 0 AND FCT$Z[0] EQ 0
          THEN                    # NO CARTRIDGE FOR *FO* # 
            BEGIN 
            FLAG = CMASTAT"ORDERR"; 
            DBRESP(FLAG,0); 
            END 
  
          FLAG = FCT$FRCF(FCT$WD(NXTSTRM),FCT$WP(NXTSTRM)); 
          IF FLAG EQ 1
          THEN                       # FROZEN CHAIN # 
            BEGIN 
            DBERRCODE = S"DFROZ$CHN"; 
            DBERR(DBERRCODE); 
            RETURN; 
            END 
  
          SETFCTX(NXTSTRM); 
          TEMP = FCT$LEN(FWD,FPS);
          SH = SL + INSPAU*TEMP + INSPAU - 1; 
  
# 
*     CHECK FOR BEGINNING OF VOLUME.
# 
  
          FLAG = FCT$CC(FCT$WD(NXTSTRM),FCT$WP(NXTSTRM)); 
          IF FLAG NQ CHAINCON"FIRST"  ##
            AND FLAG NQ CHAINCON"ONLY"  ##
            AND LINK EQ 0            # NOT CONTINUATION CARTRIDGE # 
          THEN                           # INVALID STARTING AU #
            BEGIN 
            DBERRCODE = S"DVIOL$ST";
            DBERR(DBERRCODE); 
            RETURN; 
            END 
  
# 
*     CHECK FOR ALLOCATED AU. 
# 
  
          FLAG = FCT$FBF(FCT$WD(NXTSTRM),FCT$WP(NXTSTRM));
          IF FLAG EQ 0
          THEN                           # AU NOT ALLOCATED # 
            BEGIN 
            DBERRCODE = S"DVIOL$ST";
            DBERR(DBERRCODE); 
            RETURN; 
            END 
  
# 
*     CHECK FOR AU CONFLICT.
# 
  
          FLAG = FCT$AUCF(FCT$WD(NXTSTRM),FCT$WP(NXTSTRM)); 
          IF FLAG NQ 0
          THEN                           # INTERSECTING CHAIN # 
            BEGIN 
            DBERRCODE = S"DVIOL$ST";
            DBERR(DBERRCODE); 
            RETURN; 
            END 
  
# 
*     CHECK FOR START OF FRAGMENT.
# 
  
          FLAG = FCT$SFF(FCT$WD(NXTSTRM),FCT$WP(NXTSTRM));
          IF FLAG NQ 0
          THEN                           # START OF FRAGMENT #
            BEGIN 
            DBERRCODE = S"DVIOL$ST";
            DBERR(DBERRCODE); 
            RETURN; 
            END 
  
# 
*     LOAD THE CARTRIDGE. 
# 
  
          P<FCT> = FCTBADR; 
          DBCALL4(REQTYP4"LOAD$CART",FCT$Y[0],FCT$Z[0],0,0,0,0, 
            RESPCODE);
          IF RESPCODE NQ RESPTYP4"OK4"
          THEN                       # UNABLE TO LOAD CARTRIDGE # 
            BEGIN 
            DBRESP(RESPCODE,TYP"TYP4"); 
            RETURN; 
            END 
  
          TRNSPORT = CPR$DRD[0];     # SET UP TRANSPORT ID #
          GTNXTCART = FALSE;
          END  # GET NEXT CARTRIDGE # 
  
# 
*     COPY THE RAW AU.
# 
  
        ANOTHERVOL = FALSE; 
        DBCALL4(REQTYP4"CP$RAW$AU",FCT$Y[0],FCT$Z[0],SL,SH, 
          USER$FAM[0],USER$UI[0],RESPCODE); 
        IF RESPCODE NQ RESPTYP4"OK4"
        THEN                         # UNABLE TO COPY RAW AU #
          BEGIN 
          DBRESP(RESPCODE,TYP"TYP4"); 
          RETURN; 
          END 
  
# 
*     GET THE NEXT AU IN THE CHAIN. 
# 
  
        LINK = FCT$CLKOCL(FCT$WD(NXTSTRM),FCT$WP(NXTSTRM)); 
        IF LINK NQ 0
        THEN                         # OFF CARTRIDGE LINK TEST #
          BEGIN  # OFF CARTRIDGE LINK EXISTS #
          GTNXTCART = TRUE; 
          IF LINK EQ 1
          THEN                       # USE FIRST OFF CARTRIDGE LINK # 
            BEGIN 
            NXTFCT = FCT$OCL[0] + MINFO;
            END 
  
          IF LINK EQ 2
          THEN                       # USE SECOND OFF CARTRIDGE LINK #
            BEGIN 
            NXTFCT = FCT$OCL1[0] + MINFO; 
            END 
  
          IF LINK EQ 3
          THEN                       # USE THIRD OFF CARTRIDGE LINK # 
            BEGIN 
            NXTFCT = FCT$OCL2[0] + MINFO; 
            END 
  
          DBCALL4(REQTYP4"UNLD$CART",FCT$Y[0],FCT$Z[0],0,0,0,0, 
            RESPCODE);
          IF RESPCODE NQ RESPTYP4"OK4"
          THEN                       # UNABLE TO UNLOAD CARTRIDGE # 
            BEGIN 
            DBRESP(RESPCODE,TYP"TYP4"); 
            RETURN; 
            END 
  
          NXTSTRM = FCT$LINK(FCT$WD(NXTSTRM),FCT$WP(NXTSTRM));
          SL = INSPAU*NXTSTRM + (INFTST - INSPAU);
          END  # OFF CARTRIDGE LINK EXISTS #
  
        IF LINK EQ 0
        THEN                         # NO OFF CARTRIGE LINK # 
          BEGIN  # NO OFF CARTRIDGE LINK #
          CHNCNTRL = FCT$CC(FCT$WD(NXTSTRM),FCT$WP(NXTSTRM)); 
          IF CHNCNTRL EQ CHAINCON"LAST"  ## 
            OR CHNCNTRL EQ CHAINCON"ONLY" 
          THEN                      # END OF CHAIN #
            BEGIN 
            LAST = TRUE;
            TEST DUMMY; 
            END 
  
          NXTSTRM = FCT$LINK(FCT$WD(NXTSTRM),FCT$WP(NXTSTRM));
          SL = INSPAU*NXTSTRM + (INFTST - INSPAU);
          SETFCTX(NXTSTRM); 
          TEMP = FCT$LEN(FWD,FPS);
          SH = SL + INSPAU*TEMP + INSPAU - 1; 
          ANOTHERVOL = TRUE;
          END  # NO OFF CARTRIDGE LINK #
  
        END  # COPY RAW AU #
  
# 
*     UNLOAD THE CARTRIDGE. 
# 
  
      DBCALL4(REQTYP4"UNLD$CART",FCT$Y[0],FCT$Z[0],0,0,0,0, 
        RESPCODE);
      IF RESPCODE NQ RESPTYP4"OK4"
      THEN                           # PROCESS ERROR RESPONSE # 
        BEGIN 
        DBRESP(RESPCODE,TYP"TYP4"); 
        RETURN; 
        END 
  
      CCLOSE(DBARG$FM[0],DBARG$SB[0],0,FLAG); 
      IF FLAG NQ CMASTAT"NOERR" 
      THEN                           # UNABLE TO CLOSE CATALOG #
        BEGIN 
        DBRESP(FLAG,0); 
        END 
  
      RETURN; 
  
      END  # DBRDFILE # 
  
    TERM
PROC DBRDSTM; 
# TITLE DBRDSTM - PROCESS READ AU DIRECTIVE.                      # 
  
      BEGIN  # DBRDSTM #
  
# 
**    DBRDSTM - PROCESS READ AU DIRECTIVE.
* 
*     PROC DBRDSTM. 
* 
*     ENTRY     THE CRACKED AND SYNTAX CHECKED DIRECTIVE IS 
*               IN THE COMMON AREA DEFINED IN *COMTDBG*.
*               THE MAP FOR THE SPECIFIED SM IS OPEN. 
*               P<CPR>     = FWA OF CALLSS PARAMETER BLOCK. 
*               (USER$FAM) = USER-S FAMILY NAME.
*               (USER$UI)  = USER-S USER INDEX. 
* 
*     EXIT      THE DIRECTIVE HAS BEEN PROCESSED AND
*               THE MAP HAS BEEN CLOSED OR AN ERROR 
*               CONDITION HAS BEEN DETECTED.
* 
*     MESSAGES  SSDEBUG ABNORMAL, DBRDSTM.
* 
*     NOTES     THE SPECIFIED CARTRIDGE IS LOADED AND A REQUEST 
*               IS SENT TO EXEC TO COPY EACH SELECTED AU TO 
*               THE SPECIFIED FILE. 
# 
  
# 
****  PROC DBRDSTM - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC DBCALL4;                # ISSUES TYPE 4 UCP REQUEST #
        PROC DBERR;                  # ERROR PROCESSOR #
        PROC DBRESP;                 # PROCESSES RESPONSE FROM EXEC # 
        PROC DBVSN;                  # SEARCH SM MAP FOR A VSN #
        PROC MCLOSE;                 # CLOSES SMMAP # 
        PROC MESSAGE;                # DISPLAYS MESSAGES #
        PROC PFD;                    # *PFM* REQUEST INTERFACE #
        PROC RESTPFP;                # RESTORE USER-S *PFP* AND ABORT 
                                       OR RETURN #
        PROC RETERN;                 # RETURNS A FILE # 
        PROC SETPFP;                 # SET FAMILY AND USER INDEX #
        PROC ZSETFET;                # INITIALIZES A FET #
        END 
  
# 
****  PROC DBRDSTM - XREF LIST END. 
# 
  
      DEF PROCNAME  #"DBRDSTM."#;    # PROC NAME #
  
      DEF LISTCON   #0#;             # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBCMS 
*CALL COMBCPR 
*CALL COMBMAP 
*CALL COMBPFP 
*CALL COMSPFM 
*CALL COMTDBG 
*CALL COMTDBP 
*CALL COMTDER 
  
      ITEM FLAG       I;             # ERROR STATUS # 
      ITEM I          I;             # LOOP INDUCTION VARIABLE #
      ITEM RESPCODE   I;             # RESPONSE CODE #
      ITEM STRIPELO   I;             # INITIAL STRIPE # 
      ITEM STRIPEHI   I;             # LAST STRIPE #
      ITEM Y          I;             # Y COORDINATE # 
      ITEM Z          I;             # Z COORDINATE # 
  
      ARRAY CMAPENT [0:0] P(MAPENTL);;  # SMMAP ENTRY # 
      ARRAY SCRFET [0:0] S(SFETL);;  # SCRATCH FET #
  
CONTROL EJECT;
  
# 
*     DEFINE THE USER-S FILE TO RECEIVE THE RAW AU DATA.
# 
  
      RESTPFP(PFP$RESUME);           # RESTORE USER-S *PFP* # 
  
      FLAG = 0; 
      PFD("DEFINE",DBARG$PF[0],0,"RC",FLAG,0);
      IF FLAG NQ OK 
      THEN                           # UNABLE TO DEFINE USER-S FILE # 
        BEGIN 
        DBERRCODE = S"DDEF$PF"; 
        DBERR(DBERRCODE); 
        RETURN; 
        END 
  
      ZSETFET(LOC(SCRFET[0]),DBARG$PF[0],0,0,SFETL);
      RETERN(SCRFET[0],RCL);
  
# 
*     LOCATE THE CARTRIDGE. 
# 
  
      Y = DBARG$YI[0];               # COORDINATES SPECIFIED, IF ANY #
      Z = DBARG$ZI[0];
  
      IF DBARG$D[0] GQ -1 
      THEN                           # CARTRIDGE IN INPUT DRAWER #
        BEGIN 
        Z = SM$ENT$TY;                # SET ENTRY TRAY #
        Y = 0;
        END 
  
      IF DBARG$WCN[0] NQ 0
      THEN
        BEGIN  # SEARCH SMMAP FOR THE VSN # 
        DBVSN(Y,Z,CMAPENT[0],FLAG); 
        IF FLAG NQ OK 
        THEN                         # VSN NOT FOUND #
          BEGIN 
          DBERRCODE = S"DVSN$NFND"; 
          DBERR(DBERRCODE); 
          RETURN; 
          END 
  
        END  # SEARCH SMMAP FOR THE VSN # 
  
# 
*     LOAD THE CARTRIDGE. 
# 
  
      DBCALL4(REQTYP4"LOAD$CART",Y,Z,0,0,0,0,RESPCODE); 
      IF RESPCODE NQ RESPTYP4"OK4"
      THEN                           # UNABLE TO LOAD CARTRIDGE # 
        BEGIN 
        DBRESP(RESPCODE,TYP"TYP4"); 
        RETURN; 
        END 
  
      TRNSPORT = CPR$DRD[0];         # SET UP TRANSPORT ID #
  
# 
*     COPY EACH OF THE SELECTED RAW AU. 
# 
  
      STRIPELO = INSPAU*DBARG$SL[0] + ( INFTST - INSPAU );
      STRIPEHI = INSPAU*(DBARG$SU[0] - DBARG$SL[0] + 1) + STRIPELO - 1; 
      DBCALL4(REQTYP4"CP$RAW$AU",Y,Z,STRIPELO,STRIPEHI,USER$FAM[0], 
        USER$UI[0],RESPCODE); 
  
# 
*     UNLOAD THE CARTRIDGE. 
# 
  
      DBCALL4(REQTYP4"UNLD$CART",Y,Z,0,0,0,0,RESPCODE); 
      IF RESPCODE NQ RESPTYP4"OK4"
      THEN                           # UNABLE TO UNLOAD CARTRIDGE # 
        BEGIN 
        DBRESP(RESPCODE,TYP"TYP4"); 
        RETURN; 
        END 
  
      IF DBARG$WCN[0] NQ 0
      THEN                           # MAP OPENED # 
        BEGIN 
        MCLOSE(DBARG$SMID[0],FLAG); 
        IF FLAG NQ CMASTAT"NOERR" 
        THEN                         # UNABLE TO CLOSE SMMAP #
          BEGIN 
          DBRESP(FLAG,0); 
          END 
  
        END 
  
      RETURN; 
  
      END  # DBRDSTM #
  
    TERM
PROC DBREL; 
# TITLE DBREL - RELEASE PROBLEM CHAIN AND CLEAR FLAGS.                # 
  
      BEGIN  # DBREL #
  
# 
**    DBREL - RELEASE PROBLEM CHAIN AND CLEAR FLAGS.
* 
*     PROC DBREL. 
* 
*     ENTRY   THE CRACKED AND SYNTAX CHECKED DIRECTIVE PARAMETERS 
*             ARE IN THE COMMON AREA DEFINED IN *COMTDBP*.
*             THE CATALOG IS OPEN FOR THE SPECIFIED FAMILY AND
*             SUBFAMILY.
*             P<CPR> = FWA OF CALLSS PARAMETER BLOCK. 
* 
*     EXIT    THE DIRECTIVE HAS BEEN PROCESSED AND THE
*             CATALOG HAS BEEN CLOSED OR AN ERROR CONDI-
*             TION HAS BEEN DETECTED. 
* 
*     NOTES   THE SELECTED *FCT* ENTRY IS CHECKED FOR THE 
*             FROZEN CHAIN FLAG AND IF SET, A REQUEST IS
*             SENT TO EXEC TO RELEASE THE PROBLEM CHAIN.
# 
  
# 
****  PROC DBREL - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC CCLOSE;                 # CLOSES THE CATALOG # 
        PROC CGETFCT;                # GET *FCT* ENTRY #
        PROC DBCALL3;                # ISSUES A TYPE 3 UCP REQUEST #
        PROC DBERR;                  # ERROR PROCESSOR #
        PROC DBRESP;                 # PROCESS RESPONSE FROM EXEC # 
        END 
  
# 
****  PROC DBREL - XREF LIST END. 
# 
  
      DEF LISTCON   #0#;             # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBCMS 
*CALL COMBCPR 
*CALL COMBMCT 
*CALL COMTDBG 
*CALL COMTDBP 
*CALL COMTDER 
  
      ITEM FCTBADR    I;             # FWA OF BUFFER FOR *FCT* #
      ITEM FLAG       I;             # ERROR STATUS # 
      ITEM RESPCODE   I;             # RESPONSE FROM EXEC # 
  
      ARRAY FCTENT [0:0] P(FCTENTL);;  # *FCT* ENTRY #
  
CONTROL EJECT;
  
# 
*     CHECK THE FROZEN CHAIN FLAG IN THE *FCT* ENTRY. 
# 
  
      FCTBADR = LOC(FCTENT[0]); 
      CGETFCT(DBARG$FM[0],DBARG$SB[0],DBARG$SMID[0],DBARG$FO[0],
        FCTBADR,0,FLAG);
      IF FLAG NQ CMASTAT"NOERR" 
      THEN                           # UNABLE TO GET *FCT* ENTRY #
        BEGIN 
        DBRESP(FLAG,0); 
        RETURN; 
        END 
  
      P<FCT> = FCTBADR; 
      FLAG = FCT$FRCF(FCT$WD(DBARG$ST[0]),FCT$WP(DBARG$ST[0])); 
      IF FLAG EQ 0
      THEN                           # FROZEN CHAIN FLAG NOT SET #
        BEGIN 
        DBERRCODE = S"DFROZ$NSET";
        DBERR(DBERRCODE); 
        RETURN; 
        END 
  
# 
*     RELEASE FROZEN CHAIN. 
# 
  
      DBCALL3(REQTYP3"PURG$FRAG",0,DBARG$FO[0],0,0,RESPCODE); 
      IF RESPCODE NQ RESPTYP3"OK3"
      THEN                           # UNABLE TO RELEASE FROZEN CHAIN # 
        BEGIN 
        DBRESP(RESPCODE,TYP"TYP3"); 
        RETURN; 
        END 
  
      CCLOSE(DBARG$FM[0],DBARG$SB[0],0,FLAG); 
      IF FLAG NQ CMASTAT"NOERR" 
      THEN                           # UNABLE TO CLOSE CATALOG #
        BEGIN 
        DBRESP(FLAG,0); 
        END 
  
      RETURN; 
  
      END  # DBREL #
  
    TERM
PROC DBRESP((RESPCODE),(REQTYPE));
# TITLE DBRESP - PROCESS RESPONSE FROM EXEC.                          # 
  
      BEGIN  # DBRESP # 
  
# 
**    DBRESP - PROCESS RESPONSE FROM EXEC.
* 
*     PROC DBRESP((RESPCODE),(REQTYPE)) 
* 
*     ENTRY    (RESPCODE) = RESPONSE CODE FROM EXEC.
*              (REQTYPE)  = TYPE OF REQUEST SENT TO EXEC. 
*                           0, FOR MAP/CATALOG ACCESS ROUTINES. 
* 
*     EXIT     THE ERROR RESPONSE HAS BEEN PROCESSED. 
* 
*     MESSAGES SSDEBUG ABNORMAL, DBRESP.
* 
*     NOTES    *SSDEBUG* ERROR PROCESSOR IS CALLED WITH THE 
*              CORRESPONDING ERROR CODE.
# 
  
      ITEM RESPCODE   I;             # RESPONSE CODE FROM EXEC #
      ITEM REQTYPE    I;             # TYPE OF REQUEST SENT TO EXEC # 
  
# 
****  PROC DBRESP - XREF LIST BEGIN.
# 
  
      XREF
        BEGIN 
        PROC DBERR;                  # ERROR PROCESSOR #
        PROC MESSAGE;                # DISPLAYS MESSAGE # 
        PROC RESTPFP;                # RESTORE USER-S *PFP* AND ABORT 
                                       OR RETURN #
        END 
  
# 
****  PROC DBRESP - XREF LIST END.
# 
  
      DEF PROCNAME  #"DBRESP."#;     # PROC NAME #
  
      DEF LISTCON   #0#;             # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBCMS 
*CALL COMBCPR 
*CALL COMTDBG 
*CALL COMTDER 
  
# 
*     STATUS SWITCH TO PROCESS THE RESPONSE CODES RETURNED
*     IN RESPONSE TO A TYPE 3 UCP REQUEST.
# 
  
      SWITCH RESPACT3: RESPTYP3      # TYPE 3 RESPONSE CODES #
              OK3$ACT: OK3,          # NO ERROR # 
           INTLCK$ACT: C$M$INTLCK,   # CATALOG/MAP INTERLOCKED #
            NOPEN$ACT: C$M$NOPEN,    # CATALOG/MAP NOT OPEN # 
            RESUB$ACT: RESUB$REQ,    # RESUBMIT REQUEST # 
           SCATEX$ACT: SUB$CAT$EX,   # SUBCATALOG ALREADY EYISTS #
            NOSUB$ACT: NO$SUB$CAT,   # NO SUCH SUBCATALOG # 
           PFPROB$ACT: PF$PROB,      # PF PROBLEM # 
           NEMPTY$ACT: MSC$NEMPTY,   # MSC NOT EMPTY #
           ILLORD$ACT:ILLEG$ORD,     # ORDINAL OUT OF RANGE # 
            NFROZ$ACT: NFROZ$FRAG,   # NON FROZEN FRAGMENT #
            GR$FL$ACT: GROUP$FUL;    # GROUP FULL STATUS #
  
# 
*     STATUS SWITCH TO PROCESS THE RESPONSE CODES 
*     RETURNED IN RESPONSE TO A TYPE 4 UCP REQUEST. 
# 
  
      SWITCH RESPACT4: RESPTYP4      # TYPE 4 RESPONSE CODES #
              OK4$ACT: OK4,          # NO ERROR # 
          CSN$MIS$ACT: CART$LB$ERR,  # PART OF LABEL MATCHED #
          CSN$USE$ACT: CSN$IN$USE,   # CSN IN USE # 
         CELL$EMP$ACT: CELL$EMP,     # SPECIFIED CELL EMPTY # 
         CELL$FLL$ACT: CELL$FULL,    # SPECIFIED CELL FULL #
         EX$DMARK$ACT: EX$DMARK,     # EXCESSIVE DMARKS # 
         UNK$CART$ACT: UNK$CART,     # NO CARTRIDGE LABEL MATCH # 
           URDERR$ACT: UN$RD$ERR,    # UNRECOVERABLE READ ERROR # 
           UWTERR$ACT: UN$WRT$ERR,   # UNRECOVERABLE WRITE ERROR #
          VOL$ERR$ACT: VOL$HD$ERR,   # VOLUME HEADER ERROR #
         M86HW$PR$ACT: M86$HDW$PR,   # M860 HARDWARE PROBLEM #
            RMSER$ACT: RMS$FL$ERR,   # DISK FILE ERROR #
           DSKFUL$ACT: DISK$FULL,    # DISK FULL #
            ATTER$ACT: ATTACH$ERR,   # ATTACH ERROR # 
          SMA$OFF$ACT: SMA$OFF,      # SM IS OFF #
              EOI$ACT: EOI;          # END OF INFORMATION ON FILE # 
  
CONTROL EJECT;
  
# 
*     CHECK THE RESPONSE TYPE.
# 
  
      IF REQTYPE EQ TYP"TYP3" 
      THEN                           # TYPE 3 UCP REQUEST # 
        BEGIN 
        GOTO RESPACT3[RESPCODE];
        END 
  
      IF REQTYPE EQ TYP"TYP4" 
      THEN                           # TYPE 4 UCP REQUEST # 
        BEGIN 
        GOTO RESPACT4[RESPCODE];
        END 
  
      IF REQTYPE NQ 0 
      THEN                           # ILLEGAL ERROR TYPE # 
        BEGIN 
        GOTO ERR; 
        END 
  
# 
*     PROCESS RESPONSE FROM CATALOG/MAP ACCESS ROUTINES.
# 
  
      IF RESPCODE EQ CMASTAT"INTLK" 
      THEN                           # CATALOG/MAP INTERLOCKED #
        BEGIN 
        DBERRCODE = S"DC$M$INTLK";
        DBERR(DBERRCODE); 
        RETURN; 
        END 
  
      IF RESPCODE EQ CMASTAT"ATTERR"
      THEN                           # ATTACH ERROR # 
        BEGIN 
        DBERRCODE = S"DPF$PROB";
        DBERR(DBERRCODE); 
        RETURN; 
        END 
  
      IF RESPCODE EQ CMASTAT"NOSUBCAT"
      THEN                           # NO SUCH SUBCATALOG # 
        BEGIN 
        DBERRCODE = S"DNO$SUBCAT";
        DBERR(DBERRCODE); 
        RETURN; 
        END 
  
      IF RESPCODE EQ CMASTAT"ORDERR"
      THEN                           # *FCT* ORDINAL OUT OF RANGE # 
        BEGIN 
        DBERRCODE = S"DORD$ERR";
        DBERR(DBERRCODE); 
        RETURN; 
        END 
  
      GOTO ERR;                      # ILLEGAL RESPONSE CODE #
  
# 
*     PROCESS RESPONSE CODES FOR TYPE 3 UCP REQUESTS. 
# 
  
OK3$ACT:                             # NO ERROR # 
      RETURN; 
  
INTLCK$ACT:                          # CATALOG/MAP FILE INTERLOCKED # 
      DBERRCODE = S"DC$M$INTLK";
      DBERR(DBERRCODE); 
      RETURN; 
  
NOPEN$ACT:                           # CATALOG/MAP NOT OPEN # 
      DBERRCODE = S"DC$M$NOPEN";
      DBERR(DBERRCODE); 
      RETURN; 
  
RESUB$ACT:                           # RESUBMIT REQUEST # 
      GOTO ERR; 
  
SCATEX$ACT:                          # SUBCATALOG ALREADY EYISTS #
      GOTO ERR; 
  
NOSUB$ACT:                           # NO SUCH SUBCATALOG # 
      DBERRCODE = S"DNO$SUBCAT";
      DBERR(DBERRCODE); 
      RETURN; 
  
PFPROB$ACT:                          # PF PROBLEM # 
      DBERRCODE = S"DPF$PROB";
      DBERR(DBERRCODE); 
      RETURN; 
  
NEMPTY$ACT:                          # MSC NOT EMPTY #
      GOTO ERR; 
  
ILLORD$ACT:                          # *FCT* ORDINAL OUT OF RANGE # 
      DBERRCODE = S"DORD$ERR";
      DBERR(DBERRCODE); 
      RETURN; 
  
NFROZ$ACT:                           # NON FROZEN FRAGMENT #
      DBERRCODE = S"DFROZ$NSET";
      DBERR(DBERRCODE); 
      RETURN; 
  
GR$FL$ACT:                           # GROUP FULL # 
      GOTO ERR; 
  
# 
*     PROCESS RESPONSE CODES FOR TYPE 4 UCP REQUESTS. 
# 
  
OK4$ACT:                             # NO ERROR # 
      RETURN; 
  
CSN$MIS$ACT:                         # CSN CARTRIDGE MISMATCH # 
      DBERRCODE = S"DCART$LB$ERR";
      DBERR(DBERRCODE); 
      RETURN; 
  
CSN$USE$ACT:                         # CSN IN USE # 
      DBERRCODE = S"DCSN$IN$USE"; 
      DBERR(DBERRCODE); 
      RETURN; 
  
CELL$EMP$ACT:                        # CELL EMPTY # 
      DBERRCODE = S"DCELL$EMP"; 
      DBERR(DBERRCODE); 
      RETURN; 
  
CELL$FLL$ACT:                        # CELL FULL #
      GOTO ERR; 
  
EX$DMARK$ACT:                        # EXCESSIVE DEMARKS #
      GOTO ERR; 
  
UNK$CART$ACT:                        # NO CARTRIDGE LABEL MATCH # 
      DBERRCODE = S"DUNK$CART"; 
      DBERR(DBERRCODE); 
      RETURN; 
  
URDERR$ACT:                          # UNRECOVERABLE READ ERROR # 
      DBERRCODE = S"DUN$RD$ERR";
      DBERR(DBERRCODE); 
      RETURN; 
  
UWTERR$ACT:                          # UNRECOVERABLE WRITE ERROR #
      GOTO ERR; 
  
VOL$ERR$ACT:                         # VOLUME HEADER ERROR #
      DBERRCODE = S"DVOL$HD$ERR"; 
      DBERR(DBERRCODE); 
      RETURN; 
  
M86HW$PR$ACT:                        # M860 HARDWARE ERROR #
      DBERRCODE = S"DSYS$ERR";
      DBERR(DBERRCODE); 
      RETURN; 
  
RMSER$ACT:                           # DISK FILE ERROR #
      DBERRCODE = S"DDSKFL$ERR";
      DBERR(DBERRCODE); 
      RETURN; 
  
DSKFUL$ACT:                          # DISK FULL #
      DBERRCODE = S"DDISK$FULL";
      DBERR(DBERRCODE); 
      RETURN; 
  
ATTER$ACT:                           # ATTACH ERROR # 
      DBERRCODE = S"DATT$ERR";
      DBERR(DBERRCODE); 
      RETURN; 
  
SMA$OFF$ACT:                          # SMA OFF # 
      DBERRCODE = S"DSMA$OFF";
      DBERR(DBERRCODE); 
      RETURN; 
  
EOI$ACT:                            # EOI ON FILE # 
      GOTO ERR; 
  
ERR:  
      DBMSG$PROC[0] = PROCNAME;      # ABNORMAL TERMINATION # 
      MESSAGE(DBMSG[0],SYSUDF1);
      RESTPFP(PFP$ABORT);            # RESTORE USER-S *PFP* AND ABORT # 
  
  
      END  # DBRESP # 
  
    TERM
PROC DBVSN(Y,Z,MAPENT,FLAG);
# TITLE - DBVSN - SEARCH SMMAP FOR THE CSN.                         # 
  
      BEGIN  # DBVSN #
  
# 
**    DBVSN - SEARCH SMMAP FOR CSN. 
* 
*     PROC DBVSN(Y,Z,MAPENT,FLAG) 
* 
*     ENTRY    (DBARG$SMID) = SM-ID.
*              (DBARG$CN)    = DIGIT PORTION OF CSN.
*              (DBARG$CM)    = CARTRIDGE MANUFACTURER CODE. 
* 
*     EXIT     (Y)    = Y COORDINATE OF MATCHING CSN. 
*              (Z)    = Z COORDINATE OF MATCHING CSN. 
*              (MAPENT) = SMMAP ENTRY.
*              (FLAG)   = ERROR STATUS. 
*                         0, NO ERROR 
*                       1, CSN NOT FOUND. 
* 
*     MESSAGES SSDEBUG ABNORMAL, DBVSN. 
* 
*     NOTES    THE SMMAP IS SEARCHED SEQUENTIALLY FOR 
*              MATCHING CSN.
# 
  
      ITEM Y           I;           # Y COORDINATE OF MATCHING CSN #
      ITEM Z           I;           # Z COORDINATE OF MATCHING CSN #
      ARRAY MAPENT [0:0] S(3);;      # SMMAP ENTRY #
      ITEM FLAG       I;             # ERROR STATUS # 
  
# 
****  PROC DBVSN - XREF LIST BEGIN. 
# 
  
      XREF
        BEGIN 
        PROC MESSAGE;                # DISPLAYS MESSAGE # 
        PROC MGETENT;                # GET SMMAP ENTRY #
        PROC RESTPFP;                # RESTORE USER-S *PFP* AND ABORT 
                                       OR RETURN #
        END 
  
# 
****  PROC DBVSN - XREF LIST END. 
# 
  
      DEF PROCNAME  #"DBVSN."#;      # PROC NAME #
  
      DEF LISTCON   #0#;             # DO NOT LIST COMDECKS # 
*CALL COMBFAS 
*CALL COMBCMS 
*CALL COMBCPR 
*CALL COMBMAP 
*CALL COMTDBP 
*CALL COMTDBG 
  
      ITEM I          I;             # LOOP INDUCTION VARIABLE #
      ITEM MAPADDR    I;             # FWA OF BUFFER TO HOLD ENTRY #
  
CONTROL EJECT;
  
      FLAG = 0;                      # INITIALIZE # 
      MAPADDR = LOC(MAPENT[0]); 
      P<SMUMAP> = MAPADDR;
  
# 
*     SEARCH SMMAP FOR MATCHING VSN.
# 
  
      FASTFOR I = 1 STEP 1 UNTIL MAXORD 
      DO
        BEGIN  # SEARCH SMMAP # 
        MGETENT(DBARG$SMID[0],I,MAPADDR,FLAG);
        IF FLAG NQ CMASTAT"NOERR" 
        THEN                         # ABNORMAL TERMINATION # 
          BEGIN 
          DBMSG$PROC[0] = PROCNAME; 
          MESSAGE(DBMSG[0],SYSUDF1);
          RESTPFP(PFP$ABORT);        # RESTORE USER-S *PFP* AND ABORT # 
          END 
  
        IF CM$CCOD[0] EQ DBARG$CM[0] AND CM$CSND[0] EQ DBARG$CN[0]
        THEN                         # VSN MATCH FOUND #
          BEGIN 
          Y = ( MAXORD - I )/( MAX$Z + 1 ); 
          Z = MAXORD - I - ( MAX$Z + 1 )* Y;
          RETURN; 
          END 
  
        END  # SEARCH SMMAP # 
  
      FLAG = 1;                      # MATCHING VSN NOT FOUND # 
      RETURN; 
  
      END 
  
    TERM
