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