*DECK USECDCS 
USETEXT TAREATB 
USETEXT TCLFN 
USETEXT TCRMDEF 
USETEXT TCYBDEF 
USETEXT TENVIRN 
USETEXT TFIT
USETEXT TOPTION 
USETEXT TRELTBL 
USETEXT TREPORT 
USETEXT TXSTD 
      PROC USECDCS; 
      BEGIN 
  
#----------------------------------------------------------------------#
#                                                                      #
#     U S E C D C S                                                    #
#                                                                      #
#     THIS ROUTINE PROCESSES THE FOLLOWING DIRECTIVES IF A             #
#     CDCS SUBSCHEMA HAS BEEN SPECIFIED:                               #
#                                                                      #
#       CREATE, INVOKE, USE, VERSION                                   #
#                                                                      #
#----------------------------------------------------------------------#
  
  
  
#----------------------------------------------------------------------#
#   S T A R T   O F   X R E F S                                        #
  
      XREF ITEM  ABORTED B;        # TRUE IF REPRIEVED                 #
      XREF ITEM  AREATBLPTR I;     # POINTER TO 1ST AREA TABLE IN CHAIN#
      XREF ITEM  ASCII64 I;        # DEFAULT ASCII COLL SEQ LOCATION   #
      XREF ITEM  ATPTR I;          # POINTER TO AREA TABLE IF *CREATE* #
      XREF ITEM  CATBLPTR I;       # POINTER TO CATALOG FILE           #
      XREF ITEM  CATGORD I;        # IF CDCS CATALOG MODE, AREA        #
                                   # ORDINAL OF CATALOG FILE           #
      XREF ITEM  CATRORD I;        # IF CDCS CATALOG MODE, RECORD      #
                                   # ORDINAL OF CATALOG FILE           #
      XREF ITEM  CDCSCAT B;        # TRUE IF CDCS VERSION              #
      XREF ITEM  CDCSDBM B;        # TRUE IF CDCS USE/CREATE           #
      XREF ITEM  CDCSUP B;         # TRUE IF TO ACTUALLY CALL CDCS     #
      XREF ITEM  COBCOL I;         # DEFAULT COBOL COLL SEQ LOCATION   #
      XREF ITEM  COBOL64 I;        # DEFAULT COBOL COLL SEQ LOCATION   #
      XREF ITEM  DBVNAME C(7);     # DATABASE VERSION NAME             #
      XREF ITEM  DUMMY I;          # SCRATCH                           #
      XREF ITEM  FORTCOL I;        # DEFAULT FORTRAN COLL SEQ LOCATION #
      XREF ITEM  INDEX I;          # JUMP INDEX                        #
      XREF ITEM  INVOKED B;        # TRUE IF AN -INVOKE- IN EFFECT     #
      XREF ITEM  IOFLAG I;         # 0 - SUBSCHEMA BEGIN READ BY CRM   #
                                   # 1 - SUBSCHEMA BEING READ BY       #
                                   #     DIRECTORY ACCESS ROUTINES     #
      XREF ITEM  MODCAT B;         # TRUE IF CATALOG MODIFIED          #
      XREF ITEM  MODIFYFLAG B;     # TRUE IF CHANGING PARAMS IN FDB    #
      XREF ITEM  MXTRNLG I;        # MAXIMUM TRANSMISSION LENGTH       #
      XREF ITEM  NEWATBL I;        # AREA TBL PTR FOR SUBSCHEMA DURING #
                                   # USE INITIALIZATION BY (5,1)       #
      XREF ITEM  PREDBVN C(7);     # PREVIOUS DATABASE VERSION NAME    #
      XREF ITEM  RA0 I;            # VALUE OF ZERO FOR CALLING PARAMS  #
      XREF ITEM  RELATBLPTR I;     # POINTER TO 1ST RELATION TBL ENTRY #
      XREF ITEM  SAMELFN B;        # TRUE IF LFN OF NEW SUBSCHEMA FILE #
                                   # SAME AS PREVIOUS (NOS ONLY) - IF  #
                                   # SO, PREVIOUS WAS RETURNED WHEN    #
                                   # NEW WAS ATTACHED                  #
      XREF ITEM  SBSCADD I;        # WA OF SUBSCHEMA WITHIN SBSCH LIB  #
      XREF ITEM  SBSCHG B;         # TRUE IF DIFFERENT SUBSCHEMA FILE  #
                                   # THAN THAT OF PREVIOUS C/U/V       #
      XREF ITEM  SBSCKSM I;        # CHECKSUM OF SUBSCHEMA IN USE      #
      XREF ITEM  SCTLPTR I;        # POINTER TO SUBSCHEMA CONTROL INFO #
      XREF ITEM  TAREA1 I;         # POINTER TO AREA FDB               #
      XREF ITEM  TAREA2 I;         # POINTER TO INDEX FDB              #
      XREF ITEM  TAREA4 I;         # POINTER TO RELATION STRING        #
      XREF ITEM  TAREA4X I;        # POINTER TO CURRENT AREA IN        #
                                   # RELATION STRING                   #
      XREF ITEM  TARGETAREA I;     # P<AREA$TABLE> OF AREA TO BE       #
                                   # UPDATED IF UPDATE AREA IN EFFECT  #
      XREF ITEM  UPDATEAREA B;     # TRUE IF UPDATE AREA IN EFFECT     #
      XREF ITEM  USEDIR B;         # TRUE IF USE / FALSE IF CREATE     #
      XREF ITEM  VERAREATBL I;     # ADDRESS OF AREA TABLE WITH ACTIVE #
                                   # VERIFY LIST                       #
      XREF ITEM  VERDIR B;         # TRUE IF -VERSION- DIRECTIVE       #
      XREF ITEM  VERSBSCHPTR I;    # POINTER TO 1ST AREA TABLE (SUBSC) #
                                   # IF IN CDCS CATALOG MODE           #
      XREF ITEM  VIAPOINT I;       # PTR TO RELATION TABLE ENTRY       #
                                   # WITH VIA SPECIFIED NAME           #
  
      XREF FUNC  CMM$AGR;          # ACTIVATE BLOCK GROUP              #
      XREF FUNC  CMM$ALF;          # ALLOCATE FIXED BLOCK              #
  
      XREF PROC  BGTABLE;          # BUILD BACKGROUND TABLE            #
      XREF PROC  CLOSEM;           # CLOSE FILE                        #
      XREF PROC  CMM$FGR;          # FREE BLOCK GROUP                  #
      XREF PROC  CMM$FRF;          # FREE FIXED BLOCK                  #
      XREF PROC  CMM$SLF;          # SHRINK FIXED BLOCK                #
      XREF PROC  DB$CLS;           # CDCS CLOSE FILE                   #
      XREF PROC  DB$DBST;          # CDCS STATUS BLOCK SETUP           #
      XREF PROC  DB$END;           # CDCS TERMINATE                    #
      XREF PROC  DB$INQV;          # CDCS INVOKE FOR INTERACTIVE USER  #
      XREF PROC  DB$INVV;          # CDCS INVOKE FOR BATCH USER        #
      XREF PROC  DE$CLSB;          # CLOSE SUBSCHEMA LIBRARY           #
      XREF PROC  DE$GTSB;          # READ WORDS FROM SUBSCHEMA         #
      XREF PROC  DE$OPSB;          # FIND SUBSCHEMA IN SUBSCH LIBRARY  #
      XREF PROC  DIAG;             # ISSUE DIAGNOSTIC                  #
      XREF PROC  GET;              # READ FILE                         #
      XREF PROC  LOADOVL;          # LOAD QU OVERLAY                   #
      XREF PROC  OPENM;            # OPEN FILE                         #
      XREF PROC  READ;             # READ KEYBOARD INPUT               #
      XREF PROC  REQPF;            # REQUEST PERMANENT FILE DEVICE     #
      XREF PROC  RETURNM;          # RETURN FILE                       #
      XREF PROC  WRITEBL;          # WRITE LINE TO OUTPUT              #
  
      XREF ARRAY  CPAKORD;         # IF CDCS CATALOG MODE,             #
        BEGIN 
        ITEM  CPAKITEM      I(00,36,12);    # ITEM ORD OF CATALOG FILE #
        ITEM  CPAKREC       I(00,48,12);    # RECORD ORD OF CAT. FILE  #
        END 
  
      XREF BASED ARRAY  DBSTAT;    # CDCS STATUS BLOCK                 #
        BEGIN 
        ITEM  DBSERRCODE    I(00,00,60);    # CRM OR CDCS ERROR CODE   #
        ITEM  DBSFATALFLG   B(11,05,01);    # TRUE IF FATAL ERROR      #
        ITEM  DBSFUNCTION   C(04,00,10);    # FUNCTION IN DISPLAY CODE #
        ITEM  DBSMSGADDR    I(11,42,18);    # CDCS ERROR MSG BUF ADR   #
        ITEM  DBSNAME       C(08,00,30);    # REALM OR AREA NAME ON    #
                                            # WHICH ERROR OCCURRED     #
        END 
  
      XREF
*CALL SCHEMAFIT 
  
  
  
#----------------------------------------------------------------------#
#   S T A R T   O F   D E F S                                          #
  
      DEF ALPHANUMERIC #0#;        # CODE FOR -AN- CLASS IN SUBSCHEMA  #
      DEF DBUFSZ       #O"101"#;   # SIZE OF BUFFER FOR USE BY         #
                                   # DIRECTORY ACCESS ROUTINES         #
      DEF STATBLKSZ    #12#;       # SIZE OF CDCS STATUS BLOCK         #
  
      DEF ERRFOUNDCODE #2#;        # CDCS ERROR HAS OCCURRED           #
      DEF INVOKEOKCODE #0#;        # INVOKE COMPLETED NORMALLY         #
      DEF RETRYCODE    #-2#;       # CDCS REQUEST NOT YET COMPLETED    #
  
      DEF $BLANKS$     #O"55555 55555 55555 55555"#;
  
      DEF $DDLUN$      #O"14"#;    # DDL PF ID FOR NOS UN              #
      DEF $DDLPWL$     #O"20"#;    # DDL PF ID FOR NOS PW (LOW VALUE)  #
      DEF $DDLPWH$     #O"24"#;    # DDL PF ID FOR NOS PW (HIGH VALUE) #
      DEF $DDLM$       #O"30"#;    # DDL PF ID FOR NOS M               #
      DEF $DDLPN$      #O"40"#;    # DDL PF ID FOR NOS PN              #
      DEF $DDLR$       #O"41"#;    # DDL PF ID FOR NOS R               #
  
      DEF $FDBUN$      #5#;        # FDB WORD FOR NOS UN PARAM         #
      DEF $FDBPW$      #6#;        # FDB WORD FOR NOS PW PARAM         #
      DEF $FDBM$       #7#;        # FDB WORD FOR NOS M  PARAM         #
      DEF $FDBPN$      #8#;        # FDB WORD FOR NOS PN PARAM         #
      DEF $FDBR$       #9#;        # FDB WORD FOR NOS R PARAMETER      #
  
      DEF NOSPFM$W     #0#;        # NOS PF CODE FOR MODE (M=W)        #
      DEF NOSPFM$R     #1#;        # NOS PF CODE FOR MODE (M=R)        #
      DEF NOSPFM$M     #5#;        # NOS PF CODE FOR MODE (M=M)        #
      DEF NOSPFM$RM    #6#;        # NOS PF CODE FOR MODE (M=RM)       #
      DEF NOSPFM$RA    #7#;        # NOS PF CODE FOR MODE (M=RA)       #
  
*CALL COMHDRLEN 
  
  
  
#----------------------------------------------------------------------#
#   S T A R T   O F   L O C A L   I T E M S                            #
  
                                   # KEY FOR CONVERTING DBMS CLASS     #
                                   # FIELD IN SUBSCHEMA TO DATA TYPE   #
                                   # FIELD IN RESTRICT DATA NAME TABLE #
      ITEM  CLASSCVT I = O"0001 1000 0020 3456 7770"; 
      ITEM  COUNTER;               # COUNT OF NUMBER OF REALMS         #
      ITEM  CURPATHCNT I;          # PATH COUNTER                      #
      ITEM  CURPATHFLG I;          # CURRENT PATH BIT FLAG             #
      ITEM  DUMMY1 I;              # LOOP COUNTER                      #
      ITEM  DUMMY2 I;              # LOOP COUNTER                      #
      ITEM  FINISHED B;            # FOR LOOP COMPLETION FLAG          #
      ITEM  HASHSIZE I;            # LENGTH OF HASH TABLE              #
      ITEM  LASTENTRY I;           # LAST AREA TBL ADR DURING SCAN     #
      ITEM  MUSTXEX B;             # TRUE IF TO GO TO EXECUTION OVLY   #
      ITEM  NBRAREAS I;            # NO. AREAS IN USE AT ONE TIME      #
      ITEM  NBRRELS I;             # NO. RELATIONS IN USE AT ONE TIME  #
      ITEM  PREVCATMD B;           # PREVIOUS CATALOG MODE FLAG        #
      ITEM  PREVCKSM I;            # CHECKSUM OF PREVIOUS SUBSCH FILE  #
      ITEM  RC I;                  # RETURN CODE                       #
      ITEM  RETRYANS C(1);         # Y OR N RESPONSE TO RETRY MESSAGE  #
      ITEM  RGROUPID I;            # RELATION GROUP-ID                 #
      ITEM  SAMESBS B;             # TRUE IF SAME SUBSCH AS ON LAST USE#
      ITEM  SAVEPOS I;             # SAVE POSITION OF ARRAY            #
      ITEM  SIZE I;                # TEMP STORAGE ITEM                 #
      ITEM  TEMPBUFPTR I;          # POINTER TO A TEMP INPUT BUFFER    #
      ITEM  TGROUPID I;            # TEMP CMM GROUP-ID                 #
      ITEM  THISENTRY I;           # ADR OF CURRENT TBL DURING SCANS   #
      ITEM  TOTALWDS I;            # TOTAL WORDS READ FOR SEARCH       #
      ITEM  WAKEY I;               # WORD ADDRESS FOR GETS             #
      ITEM  WAKEY2 I;              # WORD ADDRESS FOR GETS             #
      ITEM  WORD I;                # WORD INDEX VALUE                  #
  
  
  
#----------------------------------------------------------------------#
#   S T A R T   O F   L O C A L   A R R A Y S                          #
  
      ARRAY  AAAHOLD [0:2] S(1);   # HOLDS MISC SMALL ITEMS            #
        BEGIN 
        ITEM  AAAWORD       I(00,00,60);
        END 
  
                                   # HOLDS AREA ENTRY HEADER           #
      ARRAY  AREAHEAD [0:0] S(DFSBARLG);
        BEGIN 
*CALL SBAHDDCLS 
        END 
  
      ARRAY  AREANAME [0:2] S(1);  # HOLDS AREA (AND OTHER) NAMES      #
        BEGIN 
        ITEM  NAMEC         C(0,0,30);
        ITEM  NAMEI         I(0,0,60);
        END 
  
                                   # HOLDS DATA CONTROL ENTRY HEADER   #
      ARRAY  DATACTLHEAD [0:0] S(DFSBDCHLG);
        BEGIN 
*CALL SBDCHDDCL 
        END 
  
                                   # HOLDS ITEM ENTRY HEADER           #
      ARRAY  ITEMHEAD [0:0] S(DFSBITMLG); 
        BEGIN 
*CALL SBIHDDCLS 
        END 
  
  
                                   # HOLDS RECORD ENTRY HEADER         #
      ARRAY  RECHEAD [0:0] S(DFSBRCLG); 
        BEGIN 
*CALL SBRHDDCLS 
        END 
  
  
                                   # HOLDS RECORD LIST ENTRY POINTED   #
                                   # TO BY REALM/RELATION LIST         #
      ARRAY  RECLISTHEAD [0:0] S(DFSBRECLST); 
        BEGIN 
*CALL SBRECLST
        END 
  
  
                                   # HOLDS RELATION SEARCH TABLE       #
                                   # FIXED PART                        #
      ARRAY  RELHEAD [0:0] S(DFSBRLHLG);
        BEGIN 
*CALL SBRLHDDCL 
        END 
  
                                   # HOLDS REALM LIST ENTRY            #
      ARRAY  RLMLIST [0:0] S(DFSBRLMLST); 
        BEGIN 
*CALL SBRLMLST
        END 
  
      BASED ARRAY RNAME;           # POINT TO 3 WORDS OF REALM NAME    #
        BEGIN 
        ITEM REALMNAME U(0,0,60); 
        END 
      ARRAY  RQTATTRIB [0:0] S(4);  # USED FOR SCANNING RELATION       #
                                   # QUAL. TABLE ATTRIBUTE ENTRIES     #
        BEGIN 
*CALL SBRQATDCL 
        END 
  
      ARRAY  RQTHEAD [0:0] S(1);   # HOLDS RELATION QUALIFICATION      #
                                   # TABLE HEADER                      #
        BEGIN 
*CALL SBRQHDDCL 
        END 
  
  
  
  
#----------------------------------------------------------------------#
#   S T A R T   O F   L O C A L   B A S E D   A R R A Y S              #
  
  
      BASED ARRAY  GETA;             # USED FOR MOVING AND COMPARING   #
        BEGIN 
        ITEM  GETITEM       U(00,00,60);
        ITEM  GETITEMN      C(00,00,07);    # FIRST 7 CHARACTERS       #
        ITEM  GETITEMX      U(00,42,18);    # LOW 18 BITS FOR ADDRESS  #
        END 
  
      BASED ARRAY  GIVEA;            # USED FOR MOVING AND COMPARING   #
        BEGIN 
        ITEM  GIVECHAR      C(00,00,64);
        ITEM  GIVECHAR30    C(00,00,30);    # 30 CHARACTERS            #
        ITEM  GIVEITEM      U(00,00,60);
        ITEM  GIVEITEMN     C(00,00,07);    # FIRST 7 CHARACTERS       #
        END 
  
                                   # USED FOR SCANNING THE DBI ENTRIES #
                                   # OF THE SUBSCHEMA RELATION ENTRIES #
      BASED ARRAY  RELDBIENTRY [0:0] S(2);
        BEGIN 
*CALL SBRLDBDCL 
        END 
  
      BASED ARRAY  RQTSTACK;       # USED FOR SCANNING RELATION        #
                                   # QUALIFICATION TABLE STACK ENTRIES #
        BEGIN 
*CALL SBRQSTDCL 
        END 
  
      BASED ARRAY  SBSBUF ;;       # BUFFER USED BY DIR. ACC. ROUTINES #
  
      BASED ARRAY  SBSFDB;         # CONTAINS VARIOUS FDBS             #
        BEGIN 
        ITEM  SBSFDBITEM    U(00,00,60);    # FDB WORD ITEM            #
        ITEM  SBSLFN        C(04,00,07);    # LFN FIELD                #
        END 
  
      BASED ARRAY  SCONTROL;       # CONTAINS SUBSCHEMA CONTROL INFO   #
        BEGIN 
*CALL SBCWDECLS 
*CALL DITDECLS
        END 
CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     A B O R T U S E                                                  #
#                                                                      #
#     THIS CALLED WHENEVER *USECDCS* ABORTS THE CURRENT                #
#     DIRECTIVE.  IT DOES THE FOLLOWING:                               #
#                                                                      #
#   --- ISSUES FATAL DIAG 869.                                         #
#   --- FREES ANY DYNAMIC MEMORY, INCLUDING THE *TAREA* TABLES,        #
#       THE NEW AREA TABLE, ALL AREA TABLES,INCLUDING THAT OF          #
#       THE SUBSCHEMA.  EXCEPTION - THE SUBSCHEMA TABLE IS NOT         #
#       FREED IF IN CDCS CATALOG MODE.                                 #
#   --- CLOSES THE SUBSCHEMA FILE, IF OPEN.  RETURN IT UNLESS          #
#       IN CDCS CATALOG MODE.                                          #
#   --- ISSUES A -TERMINATE- TO CDCS IF INVOKED AND IF NOT             #
#       IN CDCS CATALOG MODE.                                          #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC  ABORTUSE; 
        BEGIN 
        CDCSCAT = PREVCATMD;       # RESTORE PREV CATALOG MODE SETTING #
                                   # RESTORE CHECKSUM OF PREVIOUS      #
        SBSCKSM = PREVCKSM;        # SUBSCHEMA FOR COMPARISON PURPOSES #
        DIAG (869);                # ISSUE FATAL DIAGNOSTIC            #
                                   # FREE ALL *TAREA* TABLES USED      #
                                   # BY *USECDCS*                      #
        IF TAREA1 NQ 0
        THEN
          BEGIN 
          CMM$FRF (TAREA1); 
          TAREA1 = 0; 
          END 
  
        IF SCTLPTR NQ 0 
        THEN                       # FREE TABLE WITH SUBSCHEMA CTL INFO#
          BEGIN 
          CMM$FRF (SCTLPTR);
          SCTLPTR = 0;
          END 
  
        IF P<SBSBUF> NQ 0 
        THEN                       # FREE CRM BUFFER                   #
          BEGIN 
          CMM$FRF (P<SBSBUF>);
          P<SBSBUF> = 0;
          END 
  
                                   #-----------------------------------#
                                   # RETURN NEW SUBSCHEMA AND FREE     #
                                   # ITS NEW AREA TABLE                #
  
        IF NEWATBL NQ 0 
        THEN                       # IF IN PROCESS OF SWITCHING SUBSCHS#
          BEGIN 
          P<AREA$TABLE> = NEWATBL;  # POSITION TO FIT OF NEW SUBSCHEMA #
          P<FIT> = LOC (AT$AFITPOS);
          DE$CLSB;                 # CLOSE NEW SUBSCHEMA LIBRARY       #
          IF (NOT CDCSCAT)
            OR SBSCHG 
          THEN                     # NOT SAME AS CDCS CATALOG FILE     #
            BEGIN 
            RETURNM (FIT, RA0);    # RETURN NEW SUBSCHEMA LIB FILE     #
            END 
  
          CMM$FGR (AT$GROUPID[0]); # FREE NEW AREA TABLE               #
          NEWATBL = 0;             # INDICATE NEW SUBSCHEMA NOT PRESENT#
          END 
  
        IF AREATBLPTR LOR VERSBSCHPTR NQ 0
        THEN                       # IF AREA TABLES PRESENT            #
          BEGIN 
  
                                   #-----------------------------------#
                                   # FREE VERIFY TABLE, IF PRESENT     #
  
          IF VERAREATBL NQ 0
          THEN                     # IF ACTIVE VERIFY LIST             #
            BEGIN 
            P<AREA$TABLE> = VERAREATBL; 
            CMM$FGR (AT$VERGRPID[0]);  # RELEASE VERIFY CM             #
            VERAREATBL = 0;        # INDICATE NO ACTIVE VERIFY LIST    #
            END 
  
          P<AREA$TABLE> = AREATBLPTR LOR VERSBSCHPTR; 
  
                                   #-----------------------------------#
                                   # CLOSE AND RETURN SUBSCHEMA FILE   #
  
          P<FIT> = LOC (AT$AFITPOS[0]); 
          IF IOFLAG EQ 1
          THEN                     # USING DIRECTORY ACCESS ROUTINES   #
            BEGIN 
            DE$CLSB;               # CLOSE SUBSCHEMA                   #
            END 
  
          ELSE                     # WAS READING IT WITH CRM           #
            BEGIN 
            IF FITOC[0] EQ OC$OPEN
            THEN                   # ISSUE CRM -CLOSE-                 #
              BEGIN 
              CLOSEM (FIT, $DET$, RA0); 
              END 
            END 
  
          IF NOT CDCSCAT
          THEN                     # RETURN IT IF NOT CDCS CAT FILE    #
            BEGIN 
            RETURNM (FIT, RA0); 
            END 
  
                                   #-----------------------------------#
                                   # FREE AREA TABLES                  #
  
          IF CDCSCAT
          THEN                     # PREVIOUSLY IN CDCS CATALOG MODE   #
            BEGIN 
            THISENTRY = AT$FORWARD[0];  # SET TO KEEP ONLY THE 1ST     #
            AT$FORWARD[0] = 0;     # AREA TBL (I.E., THE SUBSCHEMA)    #
            FRARTBL (THISENTRY);   # FREE AREA AND RELATION TABLES     #
            AREATBLPTR = 0;        # -VERSBSCHPTR- STILL POINTS TO IT  #
            END 
  
          ELSE                     # NOT IN CDCS CATALOG MODE          #
            BEGIN 
            FRSUBTBL;              # FREE SUBSCHEMA TABLE              #
            FRARTBL (THISENTRY);   # FREE AREA AND RELATION TABLES     #
            VERSBSCHPTR = 0;       # NO VERSION SUBSCH POINTER         #
            END 
          END 
  
        IF INVOKED
          AND (NOT CDCSCAT) 
        THEN                       # INVOKE IN EFFECT FOR CDCS DATA    #
                                   # BASE, BUT NOT CDCS CATALOG MODE   #
          BEGIN 
IF CDCSUP THEN
          DB$END;                  # ISSUE THE -TERMINATE-             #
          INVOKED = FALSE;         # INDICATE -INVOKE- NOT IN EFFECT   #
          IF P<DBSTAT> NQ 0 
          THEN                     # FREE CDCS STATUS BLOCK            #
            BEGIN 
            CMM$FRF (P<DBSTAT>);
            P<DBSTAT> = 0;
            END 
          END 
  
        CDCSDBM = FALSE;           # TURN OFF CDCS DATABASE MODE       #
        RETURN; 
        END                        # --- ABORTUSE ---                  #
*CALL ATTACHF 
CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     A U T O P S Y                                                    #
#                                                                      #
#     THIS PROC IS CALLED WHENEVER A JOB ABORT OCCURS FROM WITHIN THE  #
#     (5,3) OVERLAY.  *ABORTUSE* IS CALLED TO CLEAN UP.                #
#                                                                      #
#----------------------------------------------------------------------#
  
      XDEF PROC  AUTOPSY; 
      PROC       AUTOPSY; 
      BEGIN 
      ABORTUSE;                    # CLOSE AND RETURN FILES, FREE CORE #
      RETURN; 
      END                          # --- AUTOPSY ---                   #
CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     B U I L D A R E A T B L                                          #
#                                                                      #
#     *BUILDAREATBL* IS CALLED FROM THE MAIN ROUTINE AND FROM          #
#     *PROCRELENTRY* TO BUILD ONE AREA TABLE.  IF A TABLE ALREADY      #
#     EXISTS FOR THIS AREA, THE ROUTINE EXITS IMMEDIATELY.             #
#                                                                      #
#     INPUT: AREAHEAD - AREA ENTRY HEADER FROM SUBSCHEMA.              #
#            WAKEY2 - RELATIVE WORD ADDRESS OF AREA ENTRY.             #
#                                                                      #
#     OUTPUT: RC - NZ IF AN ERROR OCCURRED.                            #
#             THISENTRY - POINTER TO AREA TABLE.                       #
#                         ZERO IF *CREATE* AND IF AREA TABLE NOT TO    #
#                         BE BUILT FOR THIS AREA.                      #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC BUILDAREATBL;
      BEGIN 
      RC = 0;                      # SET RETURN CODE FOR NORMAL RETURN #
      P<AREA$TABLE> = AREATBLPTR;  # CHECK IF THIS AREA ALREADY HAS AN #
                                   # AREA TABLE BUILT FOR IT           #
      FOR DUMMY = 0 
        WHILE P<AREA$TABLE> NQ 0
      DO
        BEGIN 
        IF AT$AREAWA EQ WAKEY2
        THEN                       # THIS AREA ALREADY PRESENT         #
          BEGIN 
                                   # SET THIS PATH BIT IN ITS ENTRY    #
          AT$PATHFLAGS = AT$PATHFLAGS LOR CURPATHFLG; 
                                   # SET POINTER TO ENTRY              #
          THISENTRY = P<AREA$TABLE>;
          RETURN;                  # LEAVE AS IS                       #
          END 
  
        P<AREA$TABLE> = AT$FORWARD;  # SET FOR NEXT ENTRY              #
        END 
                                   # READ AREA NAME                    #
      NAMEI[1] = 0;                # TO INSURE ZERO FILL FOR NAME      #
      NAMEI[2] = 0; 
      DE$GTSB (AREANAME, SBARLENGWRDS[0], WAKEY2 + SBARNAMEPTR[0]); 
  
                                   #-----------------------------------#
                                   # IF *CREATE*, CHECK IF THIS AREA   #
                                   # IS THE ONE SPECIFIED IN THE       #
                                   # *CREATE* DIRECTIVE, AS THAT WILL  #
                                   # BE THE ONLY AREA TABLE SET UP     #
      IF NOT USEDIR 
        AND NOT VERDIR                                                  000110
      THEN                         # IF *CREATE*                       #
        BEGIN 
        P<GIVEA> = TAREA1;
        IF NAMEI[0] NQ GIVEITEM[0]
          OR NAMEI[1] NQ GIVEITEM[1]
          OR NAMEI[2] NQ GIVEITEM[2]
        THEN                       # THIS IS NOT THE DESIRED AREA ENTRY#
          BEGIN 
          THISENTRY = 0;           # TO BE CONSISTENT                  #
          RETURN;                  # NOTHING HAS BEEN DONE YET - RETURN#
          END 
  
        MUSTXEX = TRUE;            # MUST GO TO EXECUTION OVERLAY      #
        CMM$FRF (TAREA1);          # *TAREA1* NO LONGER NEEDED         #
        TAREA1 = 0; 
        END 
  
                                   #-----------------------------------#
                                   # SET UP NEW AREA TABLE             #
  
      NBRAREAS = NBRAREAS + 1;     # ONE MORE AREA IN USE              #
      IF NBRAREAS GR NBRAREASALLD 
      THEN                         # IF TOO MANY AREAS                 #
        BEGIN 
        DIAG (372);                # TOO MANY AREAS IN USE             #
        RC = 1; 
        RETURN; 
        END 
  
                                   # SET UP BLOCK FOR NEW AREA TABLE   #
      TGROUPID = CMM$AGR (0);      # GET NEW GROUP-ID                  #
                                   # ALLOCATE NEW BLOCK                #
      THISENTRY = CMM$ALF (MAXATBLSIZE, 2, TGROUPID); 
                                   # FIND LAST AREA TABLE              #
      P<AREA$TABLE> = AREATBLPTR; 
      FOR DUMMY = 0 
        WHILE AT$FORWARD NQ 0 
      DO
        BEGIN 
        P<AREA$TABLE> = AT$FORWARD; 
        END 
  
      AT$FORWARD = THISENTRY;      # SET FWD PTR TO THE NEW ONE        #
      LASTENTRY = P<AREA$TABLE>;   # SAVE POSITION FOR BACK POINTER    #
      P<AREA$TABLE> = THISENTRY;   # POSITION TO NEW ENTRY             #
      AT$BACKWARD = LASTENTRY;     # SET BACK POINTER                  #
      AT$GROUPID = TGROUPID;       # SAVE GROUP-ID                     #
      AT$NEXTFREE = MINATBLSIZE;   # POINT TO END OF MIN AREA TABLE    #
      AT$PATHFLAGS = CURPATHFLG;   # SET INITIAL PATH BIT IF RELATION  #
      AT$AREAORD = SBARORDINAL[0];  # SET ORDINAL OF AREA ENTRY        #
      AT$AREAWA = WAKEY2;          # SET WORD ADDRESS OF AREA ENTRY    #
                                   # SET AREA NAME LENGTH IN CHARS     #
      AT$AFDBLENG[0] = SBARLENGCHAR[0]; 
      ATPTR = P<AREA$TABLE>;       # SET PTR TO *CREATE* AREA          #
  
                                   # MOVE AREA NAME INTO FDB           #
                                   # NOTE THAT THIS IS THE ONLY PART OF#
                                   # THE AREA FDB WHICH IS SET UP BY   #
                                   # USE FOR CDCS                      #
      P<GETA> = LOC (AT$AFDBPOS[0]);
      GETITEM[0] = NAMEI[0];
      GETITEM[1] = NAMEI[1];
      GETITEM[2] = NAMEI[2];
  
                                   #-----------------------------------#
                                   # PROCESS REALM LIST FIELDS         #
  
                                   # SET WA OF REALM/RELATION LIST     #
      AT$RLMLSTADR[0] = SBCWRLMLSTAD[0];
      AT$RLMLSTENT[0] = 0;         # INITIALIZE REALM LIST ENTRY PTR   #
                                   # SET INITIAL READ ADDRESS          #
      WAKEY = SBCWRLMLSTAD[0];
                                   # FIND THE ENTRY FOR THIS REALM     #
      FINISHED = FALSE;            # SET LOOP CONTROL                  #
      COUNTER = 1;                 # SET TO FIRST REALM NAME           #
      P<RNAME> = LOC(REALMLISTNME[0]);
      FOR DUMMY1 = 0
        WHILE NOT FINISHED
      DO
        BEGIN 
                                   # READ NEXT REALM LIST ENTRY        #
        DE$GTSB (RLMLIST, DFSBRLMLST, WAKEY); 
        FINISHED = TRUE;           # SET FOR DONE                      #
        FOR DUMMY2 = 0 STEP 1 
          UNTIL 2 
        DO
          BEGIN 
          IF GETITEM[DUMMY2] NQ REALMNAME[DUMMY2] 
          THEN                     # IF NOT THE DESIRED REALM NAME     #
            BEGIN 
            FINISHED = FALSE;      # SET FOR NOT DONE                  #
            END 
          END 
  
        COUNTER = COUNTER + 1;
        IF NOT FINISHED 
          AND COUNTER GR SBCWNUMAREAS[0]
        THEN
          BEGIN 
          FINISHED = TRUE;
          DIAG(803,GETITEM[0]); 
          END 
        IF NOT FINISHED 
        THEN
          BEGIN 
          WAKEY = WAKEY + DFSBRLMLST;  # ADVANCE TO NEXT REALM ENTRY   #
                                   # ADVANCE REALM ENTRY POINTER       #
                                   # IN AREA TABLE                     #
          AT$RLMLSTENT[0] = AT$RLMLSTENT[0] + DFSBRLMLST; 
          END 
        END 
  
                                   #-----------------------------------#
                                   # PROCESS FIT                       #
  
                                   # READ HEADER OF DATA CONTROL ENTRY #
      DE$GTSB (DATACTLHEAD, 
               DFSBDCHLG, 
               SBARDCONTRLA[0]);
      IF SBDCFITLENG[0] LQ LFIT    # SET PROPER LENGTH FOR FIT         #
      THEN
        BEGIN 
        SIZE = SBDCFITLENG[0];
        END 
  
      ELSE
        BEGIN 
        SIZE = LFIT;
        END 
  
      P<FIT> = LOC (AT$AFITPOS[0]);  # READ FIT INTO AREA TABLE        #
      DE$GTSB (FIT, 
               SIZE,
               SBARDCONTRLA[0] + SBDCFITPTR[0]);
  
                                   #-----------------------------------#
                                   # SET UP COLLATING SEQUENCE         #
  
      AT$COLSEQ[0] = AT$NEXTFREE[0];  # SET SPACE IN TABLE FOR COL SEQ #
      AT$NEXTFREE[0] = AT$NEXTFREE[0] + 8;
      P<GETA> = LOC (AREA$TABLE) + AT$COLSEQ[0];
      IF SBDCSEQOPT[0] EQ 0 
      THEN
        BEGIN 
        P<GIVEA> = LOC (FORTCOL);  # USE DEFAULT FORTRAN               #
        END 
      IF SBDCSEQOPT[0] EQ 1 
      THEN
        BEGIN 
        P<GIVEA> = LOC (ASCII64);  # USE DEFAULT ASCII 64              #
        END 
      IF SBDCSEQOPT[0] EQ 2 
      THEN
        BEGIN 
        P<GIVEA> = LOC (COBOL64);  # USE DEFAULT COBOL 64              #
        END 
  
      FOR DUMMY1 = 0 STEP 1        # MOVE IN THE COLLATING SEQ TABLE   #
        UNTIL 7 
      DO
        BEGIN 
        GETITEM[DUMMY1] = GIVEITEM[DUMMY1]; 
        END 
  
                                   #-----------------------------------#
                                   # PROCESS HASH TABLE                #
  
                                   # SET WA OF HASH TABLE START        #
      WAKEY = SBARHASHWA[0];
      DE$GTSB (AAAHOLD, 1, WAKEY);  # READ 1ST WORD TO GET LENGTH      #
      HASHSIZE = AAAWORD[0] + 10;  # HASH TABLE HAS 10 EXTRA WORDS     #
                                   # GET BLOCK FOR HASH TABLE          #
      AT$HASHLOC = CMM$ALF (HASHSIZE, 0, AT$GROUPID); 
      P<GETA> = AT$HASHLOC;        # INITIALIZE READ FWA               #
      TOTALWDS = 51;               # MAX. RECORD SIZE = 51 WORDS       #
                                   # READ HASH TABLE IN CHUNKS THIS SZ #
      FOR HASHSIZE = HASHSIZE STEP - 51 
        WHILE HASHSIZE GR 0 
      DO
        BEGIN 
        IF HASHSIZE LS TOTALWDS 
        THEN                       # SET SIZE OF LAST READ             #
          BEGIN 
          TOTALWDS = HASHSIZE;
          END 
  
                                   # READ IN NEXT BLOCK                #
        DE$GTSB (GETA, TOTALWDS, WAKEY);
        WAKEY = WAKEY + TOTALWDS;  # ADVANCE WA OF READ                #
        P<GETA> = P<GETA> + TOTALWDS;  # ADVANCE READ FWA              #
        END 
  
      RETURN; 
      END                          # --- BUILDAREATBL ---              #
*CALL CLCAT 
CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     D I A G 9 0 4                                                    #
#                                                                      #
#     THIS PROC ISSUES DIAG 904, GETTING THE PARAMETERS FOR THE        #
#     MESSAGE FROM THE CDCS STATUS BLOCK:                              #
#                                                                      #
#           CRM/CDCS ERROR -X- FILE/RELATION -Y- FUNCTION -Z-          #
#                                                                      #
#     IF -X- IS A CDCS ERROR, THE CDCS MESSAGE TEXT IS ALSO            #
#     WRITTEN OUT.                                                     #
#                                                                      #
#     INPUT:  -GIVEA- POINTS TO THE SUBSCHEMA NAME.                    #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC  DIAG904;
      BEGIN 
      ITEM  CHAR I;                # CHARACTER POSITION                #
      ITEM  LOOPCON B;             # LOOP CONTROL                      #
      ITEM  RC I;                  # RETURN CODE                       #
      ITEM  WD I;                  # WORD POSITION                     #
  
      BASED ARRAY  ERRMSG;         # ARRAY TO HOLD ERROR MESSAGE       #
        BEGIN 
        ITEM  MSGW          U(00,00,60);
        END 
  
                                   # ISSUE THE DIAG 904                #
      DIAG (904, DBSERRCODE[0], GIVECHAR[0], "INVOKE"); 
      IF DBSERRCODE[0] GQ CDCSERRCODE 
      THEN                         # CDCS ERROR, PRINT ERROR TEXT      #
        BEGIN 
        P<ERRMSG> = DBSMSGADDR[0]; # POSITION TO ERROR TEXT            #
        C<0,2>MSGW[0] = " ";       # CARRIAGE CONTROL                  #
        LOOPCON = TRUE; 
        FOR WD = 0 STEP 1          # SCAN ERROR TEXT FOR TRAILING ZERO #
          WHILE LOOPCON 
        DO
          BEGIN 
          FOR CHAR = 0 STEP 1      # SCAN 1 WORD                       #
            UNTIL 9 
          DO
            BEGIN 
            IF B<CHAR*6,6>MSGW[WD] EQ 0 
            THEN                   # IF TRAILING ZERO                  #
              BEGIN 
              LOOPCON = FALSE;     # ZERO FOUND, TERMINATE LOOP        #
              TEST WD;
              END 
            END 
          END 
  
                                   # PRINT ERROR TEXT                  #
        WRITEBL (ERRMSG, ((WD - 1) * 10) + CHAR, RC); 
        END 
  
      RETURN;                      # ALL DONE                          #
      END                          # --- DIAG904 ---                   #
CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     F R A R T B L                                                    #
#                                                                      #
#     THIS FREES ALL AREA TABLES EXCEPT THE FIRST AND THEN FREES       #
#     ALL RELATION TABLES.                                             #
#                                                                      #
#     INPUT:  FWDPTR POINTS TO THE FIRST AREA TABLE TO BE FREED.       #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC FRARTBL (FWDPTR);
        BEGIN 
        ITEM  FWDPTR U; 
  
        FOR DUMMY = 0 
          WHILE FWDPTR NQ 0 
        DO                         # STEP THRU AREA TABLES             #
          BEGIN 
          P<AREA$TABLE> = FWDPTR;  # POSITION TO TABLE                 #
          FWDPTR = AT$FORWARD;     # SAVE POINTER TO NEXT TABLE        #
          P<FIT> = LOC (AT$AFITPOS);
          IF CDCSDBM
            AND FITOC EQ OC$OPEN
            AND NOT ABORTED 
          THEN                     # IF AREA WAS LEFT OPEN (BY CDCS)   #
            BEGIN 
IF CDCSUP THEN
                                   # CDCS CLOSE FILE                   #
            DB$CLS (FIT, AT$AREAORD[0]);
            END 
  
          IF AT$MIPID NQ 0
          THEN                     # IF A MIP ALTERNATE KEY INFO       #
                                   # STRING WAS ALLOCATED              #
            BEGIN 
            CMM$FGR (AT$MIPID);    # FREE IT                           #
            END 
  
          CMM$FGR (AT$GROUPID);    # FREE AREA TABLE                   #
          END 
  
        FWDPTR = RELATBLPTR;       # FREE ALL RELATION TABLES          #
        RELATBLPTR = 0; 
        VIAPOINT = 0;              # RESET LAST -VIA-                  #
        FOR DUMMY = 0 
          WHILE FWDPTR NQ 0 
        DO                         # STEP THRU RELATION TABLES         #
          BEGIN 
          P<REL$TABLE> = FWDPTR;   # POSITION TO TABLE                 #
          FWDPTR = RT$FORWARD;     # SAVE POINTER TO NEXT TABLE        #
          LASTENTRY = P<REL$TABLE>;  # SAVE ADR OF LAST REL TABLE      #
          CMM$FGR (RT$GROUPID);    # FREE RELATION TABLE               #
          END 
  
        RETURN; 
        END                        # --- FRARTBL ---                   #
CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     F R S U B T B L                                                  #
#                                                                      #
#     THIS FREES THE FIRST AREA TABLE IN THE CHAIN, WHICH IS THE       #
#     TABLE FOR THE SUBSCHEMA LIBRARY FILE.                            #
#                                                                      #
#     INPUT:  P<AREA$TABLE> SET TO SUBSCHEMA AREA TABLE.               #
#                                                                      #
#     OUTPUT:  *THISENTRY* POINTS TO NEXT AREA TABLE AFTER             #
#              SUBSCHEMA (MAY = 0).                                    #
#              *AREATBLPTR* = 0.                                       #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC FRSUBTBL;
        BEGIN 
        THISENTRY = AT$FORWARD;    # SAVE FORWARD POINTER              #
        CMM$FGR (AT$GROUPID);      # FREE SUBSCHEMA ENTRY              #
        AREATBLPTR = 0;            # DO THIS ONLY TO KEEP IT CLEAN     #
        UPDATEAREA = FALSE;        # DISCARD LAST UPDATE AREA          #
        TARGETAREA = 0; 
        VIAPOINT = 0;              # DISCARD LAST VIA                  #
        RETURN; 
        END                        # --- FRSUBTBL ---                  #
*CALL PFDIAG
CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     P R O C R E L E N T R Y                                          #
#                                                                      #
#     THIS PROC IS CALLED FROM THE MAIN ROUTINE TO SET UP ONE RELATION #
#     TABLE AND ANY OTHER ASSOCIATED TABLES.                           #
#                                                                      #
#     INPUT: RELHEAD - RELATION SEARCH TABLE HEADER FROM SUBSCHEMA.    #
#            WAKEY2 - RELATIVE WORD ADDRESS OF RELATION SEARCH TABLE.  #
#            CURPATHCNT - CURRENT PATH BIT NUMBER.                     #
#            CURPATHFLG - CURRENT FLAG BIT.                            #
#            ALL AREA TABLES FOR THIS SUBSCHEMA HAVE BEEN BUILT.       #
#                                                                      #
#     OUTPUT: RC - NZ IF AN ERROR OCCURRED.                            #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC PROCRELENTRY;
      BEGIN 
  
      ITEM  T1 I;                  # TEMP STORAGE                      #
      ITEM  T2 I;                  # TEMP STORAGE                      #
      ITEM  T3 I;                  # TEMP STORAGE                      #
  
      RC = 0;                      # SET NORMAL RETURN                 #
  
  
                                   #-----------------------------------#
                                   # SET UP NEW RELATION TABLE         #
  
      NBRRELS = NBRRELS + 1;       # ADVANCE RELATION COUNT            #
      IF NBRRELS GR NBRRELSALLD 
      THEN                         # IF TOO MANY RELATIONS             #
        BEGIN 
        DIAG (373);                # TOO MANY RELATIONS IN USE         #
        RC = 1; 
        RETURN; 
        END 
  
      RGROUPID = CMM$AGR (0);      # GET GROUP-ID FOR RELATION         #
                                   # GET SPACE FOR RELATION TABLE      #
      SIZE = RT$TBLSIZE + (RSTHIGHRANK[0] - 1) * 2 * RANKSIZE;
      THISENTRY = CMM$ALF (SIZE, 0, RGROUPID);
      IF RELATBLPTR EQ 0
      THEN                         # IF 1ST RELATION TABLE             #
        BEGIN 
        RELATBLPTR = THISENTRY;    # SET POINTER TO THIS, THE 1ST ONE  #
        P<REL$TABLE> = THISENTRY; 
        END 
  
      ELSE                         # ADD NEW TABLE TO CHAIN            #
        BEGIN 
        P<REL$TABLE> = RELATBLPTR;
        FOR DUMMY1 = 0             # FIND LAST TABLE IN CHAIN          #
          WHILE RT$FORWARD[0] NQ 0
        DO
          BEGIN 
          P<REL$TABLE> = RT$FORWARD[0]; 
          END 
  
        RT$FORWARD[0] = THISENTRY;  # POINT TO NEW RELATION TABLE      #
        LASTENTRY = P<REL$TABLE>;  # SAVE FOR BKD POINTER IN NEW ONE   #
        P<REL$TABLE> = THISENTRY;  # POSITION TO NEW RELATION TABLE    #
        RT$BACKWARD[0] = LASTENTRY;  # SET BACKWARD POINTER            #
        END 
  
      RT$GROUPID[0] = RGROUPID;    # SET CMM GROUP-ID IN REL TABLE     #
      RT$PATHBIT[0] = CURPATHCNT;  # SET PATH BIT NUMBER               #
      RT$ORDINAL[0] = RSTRELORD[0];  # SET RELATION ORDINAL            #
                                   # SET NUMBER OF JOIN TERMS          #
      RT$NORANKS[0] = RSTHIGHRANK[0] - 1; 
  
  
                                   #-----------------------------------#
                                   # READ IN REMAINDER OF RELATION ENT #
  
                                   # COMPUTE SIZE OF SPACE TO HOLD     #
                                   # RELATION NAME AND DBI ENTRIES     #
      SIZE = RSTRELNMELW[0] + (RSTHIGHRANK[0] - 1) * 4; 
                                   # GET THE SPACE                     #
      TEMPBUFPTR = CMM$ALF (SIZE, 0, 0);
      WAKEY = WAKEY2 + 2;          # STARTS AT WORD 2 IN HEADER INFO   #
      P<GIVEA> = TEMPBUFPTR;       # SET READ ADDRESS                  #
      DE$GTSB (GIVEA, SIZE, WAKEY);  # READ IT IN                      #
      RT$RELNAME[0] = $BLANKS$;    # PRESET NAME TO BLANK FILL         #
                                   # MOVE RELATION NAME INTO TABLE     #
      C<0,RSTRELNMELC[0]>RT$RELNAME[0] = C<0,RSTRELNMELC[0]>GIVECHAR[0];
  
  
                                   #-----------------------------------#
                                   # FORM LIST OF FIT ADDRESSES        #
                                   # AND SET UP RANK ENTRIES           #
  
      P<RELDBIENTRY> = TEMPBUFPTR + RSTRELNMELW[0]; 
                                   # GET SPACE FOR LIST OF FIT ADDRS   #
                                   # IT ENDS WITH A ZERO WORD          #
      P<FITADDRTBL> = CMM$ALF (RT$NORANKS[0] + 1 + 1, 0, RGROUPID); 
      RT$FITADDR[0] = P<FITADDRTBL>;  # SET POINTER TO IT              #
      T1 = 0;                      # INITIALIZE MOST RECENT AREA ORD   #
      T2 = 0;                      # INITIALIZE COUNT OF AREAS FOUND   #
                                   # POSITION TO 1ST RANK ENTRY        #
      P<REL$RANKINFO> = LOC (RT$RANKPOS); 
  
      FOR T3 = 0 STEP 1            # STEP THRU ALL DBI ENTRIES         #
        WHILE T2 LS RT$NORANKS[0] + 1 
      DO
        BEGIN 
        IF RSTAREAORD[T3] NQ T1 
        THEN                       # IF DIFFERENT (OR 1ST) AREA THAN   #
                                   # THE ONE IN THE PREVIOUS ENTRY     #
          BEGIN 
          T1 = RSTAREAORD[T3];     # SET CURRENT AREA ORDINAL          #
          P<AREA$TABLE> = AREATBLPTR;  # FIND AREA TABLE FOR THIS AREA #
          FINISHED = FALSE;        # SET LOOP CONTROL                  #
          FOR DUMMY1 = 0           # LOOP THRU AREA TABLES             #
            WHILE NOT FINISHED
          DO
            BEGIN 
            IF AT$AREAORD[0] EQ T1
            THEN                   # IF THIS IS THE CORRECT AREA       #
              BEGIN 
              FINISHED = TRUE;     # SET LOOP CONTROL TO DONE          #
                                   # SET FIT ADDRESS                   #
              FITADDR[T2] = LOC (AT$AFITPOS[0]);
                                   # SET PATH BIT FOR THIS RELATION    #
              AT$PATHFLAGS = AT$PATHFLAGS LOR CURPATHFLG; 
              T2 = T2 + 1;         # ADVANCE COUNT OF AREAS            #
              END 
  
            ELSE
              BEGIN 
              IF AT$FORWARD[0] EQ 0  # SHOULD NOT HAPPEN               #
              THEN                 # PROTECT AGAINST SYSTEM FAILURE    #
                BEGIN 
                T2 = T2 + 1;
                FINISHED = TRUE;
                END 
  
              P<AREA$TABLE> = AT$FORWARD[0];  # GO TO NEXT AREA TABLE  #
              END 
            END 
          END 
  
                                   # SET AREA TABLE POINTER IN RANK ENT#
        RR$AREAPTR[0] = P<AREA$TABLE>;
                                   # ADVANCE TO NEXT RANK ENTRY        #
        P<REL$RANKINFO> = P<REL$RANKINFO> + RANKSIZE; 
        END 
  
      CMM$FRF (TEMPBUFPTR);        # FREE DBI WORK SPACE               #
  
  
                                   #-----------------------------------#
                                   # FORM RESTRICT DATA NAME TABLE     #
  
      IF RSTRQTPTR[0] NQ 0
      THEN                         # IF ANY RESTRICTS PRESENT          #
        BEGIN 
                                   # SET WA OF RELATION QUAL. TABLE    #
        WAKEY = WAKEY2 + RSTRQTPTR[0];
        DE$GTSB (RQTHEAD, 1, WAKEY);  # READ RELATION QUAL. TABLE HDR  #
        SIZE = RQTATTRIBPTR[0] - 1;  # NO. OF STACK ENTRIES IN RQT     #
                                   # GET SPACE TO READ STACK ENTRIES   #
        TEMPBUFPTR = CMM$ALF (SIZE, 0, 0);
        P<RQTSTACK> = TEMPBUFPTR; 
                                   # READ IN STACK ENTRIES             #
        DE$GTSB (RQTSTACK, SIZE, WAKEY + 1);
        T2 = 0;                    # INIT. COUNT OF DATA NAME ENTRIES  #
        FOR T1 = 0 STEP 1          # COUNT DATA NAME ENTRIES TO        #
          UNTIL SIZE               # DETERMINE NECESSARY SIZE OF       #
        DO                         # RESTRICT DATA NAME TABLE          #
          BEGIN 
          IF RQTSTACKTYPE[T1] EQ 3
          THEN                     # IF THE DESIRED TYPE               #
            BEGIN 
            T2 = T2 + 1;
            END 
          END 
  
        RT$NORESTDBI[0] = T2;      # SET NO. OF DATA BASE ITEMS        #
        IF T2 NQ 0                 # IF NO ENTRIES, DO NOT BUILD TABLE #
        THEN
          BEGIN 
                                   # ALLOCATE RESTRICT DATA NAME TABLE #
          P<RESDNAMETBL> = CMM$ALF (T2 * 4, 0, RGROUPID); 
          RT$RESDNADDR[0] = P<RESDNAMETBL>; 
          FOR T1 = 0 STEP 1 
            UNTIL SIZE - 1
          DO
            BEGIN 
            IF RQTSTACKTYPE[T1] EQ 3
            THEN                   # IF THE DESIRED TYPE               #
              BEGIN 
                                   # READ ATTRIB. ENTRY FOR DATA NAME  #
              DE$GTSB (RQTATTRIB, 4, WAKEY + RQTATRIBTEWA[T1]); 
                                   # MOVE IN NAME LENGTH, BOTH IN      #
                                   # CHARS AND IN WORDS                #
              RD$NAMELGC[0] = RQTDATALENC[0]; 
              RD$NAMELGW[0] = (RQTDATALENC[0] - 1) / 10 + 1;
                                   # MOVE DEFINED NAME INTO R-D-N-TABLE#
                                   # WITH BLANK FILL                   #
              RD$NAME[0] = $BLANKS$;
              C<0,RQTDATALENC[0]>RD$NAME[0] 
                = C<0,RQTDATALENC[0]>RQTDATANM30[0];
                                   # READ IN ITEM ENTRY                #
              DE$GTSB (ITEMHEAD, DFSBITMLG, WAKEY - RQTITEMPTR[T1]);
                                   # STORE SIGN INDICATOR              #
              RD$SIGN[0] = SBITMSIGNF[0]; 
              T2 = SBITMPTLOC[0];  # STORE POINT LOCATION              #
              IF SBITMLFTPT[0] EQ 0  # IF POINT TO RIGHT, COMPLEMENT   #
                AND T2 NQ 0        # VALUE FROM SUBSCHEMA              #
              THEN
                BEGIN 
                T2 = - T2;
                END 
  
              RD$DPTLOC[0] = T2;
                                   # STORE DATA TYPE                   #
              RD$DATATYPE[0] = B<SBITMDBCLASS[0] * 3, 3>CLASSCVT; 
                                   # STORE ITEM SIZE                   #
              RD$USESIZE[0] = SBITMUSESIZE[0];
              P<RESDNAMETBL> = P<RESDNAMETBL> + 4;
              END 
            END 
          END 
  
        CMM$FRF (TEMPBUFPTR);      # FREE SPACE USED FOR STACK ENTRIES #
        END 
  
      RETURN; 
      END                          # --- PROCRELENTRY ---              #
CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     R E P S U B T B L                                                #
#                                                                      #
#     *REPSUBTBL* REPLACES THE AREA$TABLE ENTRY FOR THE SUBSCHEMA,     #
#     LEAVING THE AREA ENTRIES INTACT.                                 #
#                                                                      #
#     INPUT -                                                          #
#       AREATBLPTR AND/OR VERSBSCHPTR - ADDRESS OF THE PREVIOUS        #
#                                       SUBSCHEMA ENTRY                #
#       NEWATBL - ADDRESS OF THE NEW SUBSCHEMA ENTRY                   #
#                                                                      #
#     OUTPUT -                                                         #
#       AREATBLPTR AND/OR VERSBSCHPTR - ADDRESS OF THE NEW SUBSCHEMA   #
#                                       ENTRY                          #
#       P<AREA$TABLE> - ADDRESS OF THE NEW SUBSCHEMA ENTRY             #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC REPSUBTBL; 
      BEGIN 
                                   # POSITION TO OLD SUBSCHEMA ENTRY   #
      P<AREA$TABLE> = AREATBLPTR LOR VERSBSCHPTR; 
      THISENTRY = AT$FORWARD[0];   # SAVE POINTER TO FIRST AREA ENTRY  #
      CMM$FGR (AT$GROUPID[0]);     # FREE MEMORY OF OLD ENTRY          #
  
      IF THISENTRY NQ 0            # IF AREA ENTRY EXISTS              #
      THEN
        BEGIN 
                                   # LINK FIRST AREA ENTRY BACK TO NEW #
        P<AREA$TABLE> = THISENTRY; # SUBSCHEMA ENTRY                   #
        AT$BACKWARD[0] = NEWATBL; 
        END 
                                   # LINK NEW SUBSCHEMA ENTRY FORWARD  #
      P<AREA$TABLE> = NEWATBL;     # TO FIRST AREA ENTRY               #
      AT$FORWARD[0] = THISENTRY;
  
      IF AREATBLPTR NQ 0           # CHANGE USE POINTER IF NECESSARY   #
      THEN
        BEGIN 
        AREATBLPTR = NEWATBL; 
        END 
  
      IF VERSBSCHPTR NQ 0          # CHANGE VERSION POINTER IF NEEDED  #
      THEN
        BEGIN 
        VERSBSCHPTR = NEWATBL;
        END 
  
      RETURN; 
      END                          # END PROC *REPSUBTBL*              #
CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     U N C U V                                                        #
#                                                                      #
#     THIS PROC CLEANS THINGS UP FROM THE PREVIOUS                     #
#     CREATE/INVOKE/USE/VERSION BY DOING A COMBINATION OF              #
#     THE ACTIONS LISTED BELOW.  WHAT GETS DONE DEPENDS UPON THE       #
#     EXISTING CONDITIONS AS INDICATED BY THE INPUT CONDITIONS         #
#     LISTED WITH THE MAIN ROUTINE.                                    #
#                                                                      #
#     -- FREES AREA AND RELATION TABLES.                               #
#     -- FREES ACTIVE VERIFY LIST.                                     #
#     -- FREES AREA TABLE FOR SUBSCHEMA FILE.                          #
#     -- CLOSES AND RETURNS SUBSCHEMA FILE.                            #
#     -- ISSUES CDCS -TERMINATE-.                                      #
#     -- FREES CDCS STATUS BLOCK.                                      #
#     -- CLOSES AND RETURNS PREVIOUS CATALOG FILE.                     #
#     -- DELINKS, FROM THE CURRENT AREA TABLE CHAIN, THE AREA          #
#        TABLE FOR THE FILE WHICH IS TO BE THE NEW CATALOG FILE.       #
#                                                                      #
#     INPUT:  ALL INPUT CONDITIONS LISTED UNDER MAIN ROUTINE.          #
#             SAMESBS = TRUE IF CURRENT DIRECTIVE SPECIFIES THE SAME   #
#             SUBSCHEMA AS THE PREVIOUS DIRECTIVE.                     #
#                                                                      #
#     OUTPUT: RC = 0 IF NO ERRORS WERE DETECTED.                       #
#             FLAGS DESCRIBING THE NEW CONDITIONS HAVE NOT BEEN SET    #
#             YET.  THIS IS DONE BY THE MAIN ROUTINE.                  #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC UNCUV; 
      BEGIN 
      ITEM  AREATMP I;             # PREVIOUS VALUE OF *AREATBLPTR*    #
      ITEM  BTEMP1 B;              # BOOLEAN TEMP                      #
  
      RC = 0;                      # INDICATE NO ERROR                 #
      AREATMP = AREATBLPTR;        # KEEP PREV. *AREATBLPTR* AVAILABLE #
      IF NOT VERDIR 
      THEN                         # -CREATE-, -INVOKE-, OR -USE-      #
        BEGIN 
        IF CDCSCAT
        THEN                       # IF IN CDCS CATALOG MODE           #
          BEGIN 
          IF NOT SAMESBS
          THEN                     # DIFFERENT SUBSCHEMA THAN THE LAST #
            BEGIN 
            P<AREA$TABLE> = NEWATBL;      # GET SUBSCHEMA NAME         #
            P<GIVEA> = P<AREA$TABLE> + AT$SBSCNAME[0];
            DIAG (406, GIVEITEM[0]);
            RC = 1;                # INDICATE ERROR RETURN             #
            END 
  
          ELSE                     # SAME SUBSCHEMA                    #
            BEGIN 
            IF AREATMP NQ 0 
            THEN                   # A PREVIOUS USE IS IN EFFECT       #
              BEGIN 
              P<AREA$TABLE> = AREATMP;    # FREE ALL AREA TABLES       #
              THISENTRY = AT$FORWARD[0];  # AND RELATION TABLES        #
              AT$FORWARD[0] = 0;
              FRARTBL (THISENTRY);
              AREATBLPTR = 0; 
              END 
            END 
  
          RETURN; 
          END 
  
        IF AREATMP NQ 0 
        THEN                       # A PREVIOUS USE IS IN EFFECT       #
          BEGIN 
          P<AREA$TABLE> = AREATMP;  # POSITION TO SUBSCHEMA FIT        #
          P<FIT> = LOC(AT$AFITPOS); 
          IF CDCSDBM
          THEN                     # PREVIOUSLY IN CDCS DATABASE MODE  #
            BEGIN 
            IF SBSCHG              # IF DIFFERENT SUBSCHEMA FILE       #
              AND NOT SAMELFN      # AND OLD FILE NOT ALREADY RETURNED #
            THEN
              BEGIN 
              IF FITOC EQ OC$OPEN 
              THEN                 # SUBSCHEMA IS OPEN                 #
                BEGIN 
                CLOSEM (FIT, $DET$, RA0);  # CLOSE, RELEASE BUFFERS    #
                END 
  
              RETURNM (FIT, RA0);  # RETURN SUBSCHEMA FILE             #
              END 
  
            IF NOT SAMESBS
            THEN                   # DIFFERENT SUBSCHEMA THAN LAST     #
              BEGIN 
              FRSUBTBL;            # FREE AREA TBL FOR THE SUBSCHEMA   #
              FRARTBL (THISENTRY);  # FREE AREA AND RELATION TABLES    #
              IF INVOKED
              THEN                 # -INVOKE- IS IN EFFECT             #
                BEGIN 
IF CDCSUP THEN
                DB$END;            # CDCS -TERMINATE-                  #
                INVOKED = FALSE;   # INDICATE NO -INVOKE- IN EFFECT    #
                IF P<DBSTAT> NQ 0 
                THEN               # FREE CDCS STATUS BLOCK            #
                  BEGIN 
                  CMM$FRF (P<DBSTAT>);
                  P<DBSTAT> = 0;
                  END 
                END 
              END 
  
            ELSE                   # SAME SUBSCHEMA AS LAST            #
              BEGIN 
              THISENTRY = AT$FORWARD;  # SET TO KEEP ONLY THE 1ST      #
              AT$FORWARD = 0;      #  (SUBSCHEMA) TABLE                #
              FRARTBL (THISENTRY);  # FREE AREA AND RELATION TABLES    #
              END 
            END 
  
          ELSE                     # PREVIOUSLY IN CRM DATABASE MODE   #
            BEGIN 
            IF NOT SAMELFN         # IF OLD FILE NOT ALREADY RETURNED  #
            THEN
            BEGIN 
            IF FITOC EQ OC$OPEN 
            THEN                   # SUBSCHEMA OPEN                    #
              BEGIN 
              CLOSEM (FIT, $DET$, RA0);  # CLOSE, RELEASE BUFFERS      #
              END 
  
            RETURNM (FIT, RA0);    # RETURN SUBSCHEMA FILE             #
            END 
  
            FRSUBTBL;              # FREE AREA TBL FOR THE SUBSCHEMA   #
            FRARTBL (THISENTRY);   # FREE AREA AND RELATION TABLES     #
            END 
  
          IF VERAREATBL NQ 0
          THEN                     # IF ACTIVE VERIFY LIST             #
            BEGIN 
            P<AREA$TABLE> = VERAREATBL;  # POSITION AREATABLE          #
            CMM$FGR (AT$VERGRPID);  # RELEASE VERIFY CM                #
            VERAREATBL = 0;        # INDICATE NO ACTIVE VERIFY LIST    #
            END 
          END 
  
        RETURN; 
        END 
  
      ELSE                         # -VERSION- DIRECTIVE               #
        BEGIN 
  
#     IN THE FOLLOWING PROCESSING FOR A CDCS -VERSION- DIRECTIVE,      #
#     THE STEPS TO BE TAKEN VARY DEPENDING ON MANY COMBINATIONS        #
#     OF CURRENT CONDITIONS.  THE CASES BELOW ARE INDICATED IN LATER   #
#     COMMENTS TO HELP CLARIFY THINGS:                                 #
#                                                                      #
#       1 -  NO VERSION,     NO USE                                    #
#       2 -  NO VERSION,     CRM USE                                   #
#       3A   NO VERSION,     CDCS USE, SAME SUBSCHEMA                  #
#       3B - NO VERSION,     CDCS USE, DIFFERENT SUBSCHEMA             #
#       4 -  CRM VERSION,    NO USE                                    #
#       5 -  CRM VERSION,    CRM USE                                   #
#       6A - CRM VERSION,    CDCS USE, SAME SUBSCHEMA                  #
#       6B - CRM VERSION,    CDCS USE, DIFFERENT SUBSCHEMA             #
#       7A - CDCS VERSION,   NO USE,   SAME SUBSCHEMA                  #
#       7B - CDCS VERSION,   NO USE,   DIFFERENT SUBSCHEMA             #
#       8A - CDCS VERSION,   CDCS USE, SAME SUBSCHEMA                  #
#       8B - CDCS VERSION,   CDCS USE, DIFFERENT SUBSCHEMA             #
  
        P<AREA$TABLE> = AREATMP;
        IF AREATMP EQ 0 
        THEN                       # IF ONLY CDCS VERSION (NO USE)     #
          BEGIN 
          P<AREA$TABLE> = VERSBSCHPTR;
          END 
  
        P<FIT> = LOC (AT$AFITPOS[0]); 
  
#     CASES TO RETURN THE PREVIOUS CATALOG FILE:                       #
#                                                                      #
#     4, 5, 6A, 6B     (I.E., ALL CASES WITH CRM VERSION)              #
  
        IF (PFCATAL AND NOT CDCSCAT)
        THEN
          BEGIN 
          CLCAT;                   # CLOSE OLD CATALOG FILE            #
          MODCAT = FALSE;          # CATALOG NOT MODIFIED SINCE CLOSE  #
          RETURNM (CATAFIT, RA0);  # RETURN OLD CATALOG FILE           #
          P<FIT> = LOC (CATAFIT);  # POINT TO CATALOG FIT              #
          FITES = 0;               # CLEAR ERROR STATUS                #
          FITFNF = FALSE;          # CLEAR FATAL ERROR FLAG            #
          FITOC = 0;               # NEVER OPENED                      #
          FITPD = 0;               # PROCESSING DIRECTION              #
          FITBN = 0;               # BLOCK NUMBER                      #
          FITFP = 0;               # FILE POSITION                     #
          FITLOP = 0;              # LAST OPERATION                    #
          FITCDT = 0;              # COLLATING TO DISPLAY TABLE        #
          FITDCT = 0;              # DISPLAY TO COLLATING TABLE        #
          FITHRL = 0;              # HASHING ROUTINE ADDRESS           #
          END 
  
#     CASES TO CLOSE AND RETURN OLD SUBSCHEMA:                         #
#                                                                      #
#     2, 3B, 5, 6B, 7B, 8B                                             #
  
        BTEMP1 =                   # SAME CONDITIONS ARE USED AGAIN    #
          (NOT PFCATAL
            AND (AREATMP NQ 0 AND NOT CDCSDBM)) 
          OR (NOT PFCATAL 
            AND (AREATMP NQ 0 AND CDCSDBM)
              AND NOT SAMESBS)
          OR ((PFCATAL AND NOT CDCSCAT) 
            AND (AREATMP NQ 0 AND NOT CDCSDBM)) 
          OR ((PFCATAL AND NOT CDCSCAT) 
            AND (AREATMP NQ 0 AND CDCSDBM)
              AND NOT SAMESBS)
          OR (CDCSCAT 
            AND NOT SAMESBS); 
        IF BTEMP1 
          AND SBSCHG               # IF DIFFERENT SUBSCHEMA FILE       #
          AND NOT SAMELFN          # AND OLD FILE NOT ALREADY RETURNED #
        THEN
          BEGIN 
          IF FITOC EQ OC$OPEN 
          THEN                     # CLOSE SUBSCHEMA                   #
            BEGIN 
            CLOSEM (FIT, $DET$, RA0); 
            END 
  
          RETURNM (FIT, RA0);      # RETURN SUBSCHEMA                  #
          END 
  
#     CASES WHERE SUBSCHEMA TABLE AND ALL AREA AND RELATION            #
#     TABLES ARE RELEASED:                                             #
#                                                                      #
#     2, 3B, 5, 6B, 7B, 8B                                             #
  
        IF BTEMP1 
        THEN
          BEGIN 
          FRSUBTBL;                # FREE SUBSCHEMA TABLE              #
          FRARTBL (THISENTRY);     # FREE AREA AND RELATION TABLES     #
          END 
  
#     CASES IN WHICH THE AREA SPECIFIED AS THE NEW CATALOG FILE        #
#     MUST BE DELINKED FROM THE CURRENT CHAIN OF AREA TABLES:          #
#                                                                      #
#     3A, 6A, 8A                                                       #
  
        IF (NOT PFCATAL 
          AND ((AREATMP NQ 0) AND CDCSDBM)
            AND SAMESBS)
          OR ((PFCATAL AND NOT CDCSCAT) 
            AND ((AREATMP NQ 0) AND CDCSDBM)
              AND SAMESBS)
            OR (CDCSCAT 
              AND ((AREATMP NQ 0) AND CDCSDBM)
                AND SAMESBS)
        THEN
          BEGIN 
          P<GIVEA> = TAREA1;       # NAME OF CATALOG FILE              #
          LASTENTRY = P<AREA$TABLE>;  # ADR OF PREVIOUS AREA TABLE     #
                                   # SEARCH AREA TABLES FOR THE AREA   #
                                   # SPECIFIED ON THE CATALOG FILE     #
          THISENTRY = AT$FORWARD[0];
          FOR DUMMY1 = 0
            WHILE THISENTRY NQ 0
          DO
            BEGIN 
                                   # POSITION TO NEXT AREA TABLE       #
            P<AREA$TABLE> = THISENTRY;
                                   # POSITION TO AREA NAME             #
            P<GETA> = LOC (AT$AFDBPOS[0]);
            IF GIVEITEM[0] NQ GETITEM[0]
              OR GIVEITEM[1] NQ GETITEM[1]
              OR GIVEITEM[2] NQ GETITEM[2]
            THEN                   # DIFFERENT AREA - REPEAT LOOP      #
              BEGIN 
              LASTENTRY = THISENTRY;  #ADVANCE POINTERS                #
              THISENTRY = AT$FORWARD[0];
              TEST DUMMY1;         # REPEAT LOOP                       #
              END 
  
            IF AT$PATHFLAGS[0] NQ 0 
            THEN                   # AREA IS PART OF A RELATION        #
              BEGIN 
              DIAG (407, GIVEITEM[0]);
              RC = 1;              # ERROR RETURN                      #
              RETURN; 
              END 
  
                                   # RESET FWD PTR OF PREV. AREA TBL   #
            DUMMY2 = AT$FORWARD[0]; 
            P<AREA$TABLE> = LASTENTRY;
            AT$FORWARD[0] = DUMMY2; 
                                   # RESET BKD OF NEXT AREA TABLE,     #
                                   # IF THERE IS ONE                   #
            IF DUMMY2 NQ 0
            THEN
              BEGIN 
              P<AREA$TABLE> = DUMMY2; 
              AT$BACKWARD[0] = LASTENTRY; 
              END 
  
                                   # POSITION TO AREA TBL TO BE FREED  #
            P<AREA$TABLE> = THISENTRY;
            P<FIT> = LOC (AT$AFITPOS[0]); 
            IF FITOC EQ OC$OPEN 
            THEN                   # IF AREA LEFT OPEN BY CDCS         #
              BEGIN 
IF CDCSUP THEN
                                   # CDCS CLOSE                        #
              DB$CLS (FIT, AT$AREAORD[0]);
              END 
  
            IF AT$MIPID[0] NQ 0 
            THEN                   # IF A MIP ALTERNATE KEY INFO       #
                                   # STRING WAS ALLOCATED              #
              BEGIN 
              CMM$FGR (AT$MIPID[0]);  # FREE IT                        #
              END 
  
            CMM$FGR (AT$GROUPID[0]);  # FREE AREA TABLE                #
            THISENTRY = 0;         # GET OUT OF LOOP                   #
            END 
          END 
  
#     CASES WHERE A -TERMINATE- IS ISSUED:                             #
#                                                                      #
#     3B, 6B, 7B, 8B                                                   #
  
        IF NOT SAMESBS
          AND (((AREATMP NQ 0) AND CDCSDBM) 
            OR ((AREATMP EQ 0) AND CDCSCAT))
        THEN
          BEGIN 
          IF INVOKED
          THEN                     # -INVOKE- IS IN EFFECT             #
            BEGIN 
IF CDCSUP THEN
            DB$END;                # CDCS -TERMINATE-                  #
            INVOKED = FALSE;       # INDICATE NO -INVOKE- IN EFFECT    #
            IF P<DBSTAT> NQ 0 
            THEN                   # FREE CDCS STATUS BLOCK            #
              BEGIN 
              CMM$FRF (P<DBSTAT>);
              P<DBSTAT> = 0;
              END 
            END 
  
          CDCSDBM = FALSE;         # TURN OFF CDCS DATABASE MODE       #
          END 
  
        RETURN; 
        END 
      END                          # --- UNCUV ---                     #
CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     U S E C D C S   -   MAIN ROUTINE.                                #
#                                                                      #
#     INPUT:                                                           #
#                                                                      #
#     --- IF PRESENTLY IN CDCS CATALOG MODE:                           #
#         -- *CDCSCAT* = TRUE.                                         #
#         -- *PFCATAL* = TRUE.                                         #
#         -- *VERSBSCHPTR* POINTS TO THE AREATABLE FOR THE             #
#            SUBSCHEMA FILE.                                           #
#     --- IF PRESENTLY IN CDCS DATABASE MODE:                          #
#         -- *CDCSDBM* = TRUE.                                         #
#         -- *AREATBLPTR* POINTS TO THE AREA TABLE FOR THE             #
#            SUBSCHEMA FILE.                                           #
#     --- IF PRESENTLY IN CRM CATALOG MODE:                            #
#         -- *CDCSCAT* = FALSE.                                        #
#         -- *PFCATAL* = TRUE.                                         #
#         -- THE CATALOG FILE IS ATTACHED AS LFN *ZZZZZQ3*.            #
#     --- IF PRESENTLY IN CRM DATABASE MODE:                           #
#         -- *CDCSDBM* = FALSE.                                        #
#         -- *AREATBLPTR* POINTS TO THE AREA TABLE FOR THE             #
#         -- SUBSCHEMA FILE.                                           #
#                                                                      #
#     --- IF THE NEW DIRECTIVE IS -VERSION-:                           #
#         -- *VERDIR* = TRUE.                                          #
#         -- *USEDIR* = FALSE.                                         #
#         -- *TAREA1* POINTS TO THE FDB FOR THE CATALOG FILE.          #
#     --- IF THE NEW DIRECTIVE IS -CREATE-:                            #
#         -- *VERDIR* = FALSE.                                         #
#         -- *USEDIR* = FALSE.                                         #
#         -- *TAREA1* POINTS TO THE FDB FOR THE AREA FILE.             #
#     --- IF THE NEW DIRECTIVE IS -INVOKE- OR -USE-:                   #
#         -- *VERDIR* = FALSE.                                         #
#         -- *USEDIR* = TRUE.                                          #
#         -- *TAREA1*, IF SET, IS DISREGARDED.                         #
#                                                                      #
#     --- THE PREVIOUS SUBSCHEMA LIBRARY, IF ANY, IS ATTACHED,         #
#         BUT CLOSED.                                                  #
#     --- THE NEW SUBSCHEMA LIBRARY, WHICH MIGHT BE THE SAME FILE      #
#         AS THE PREVIOUS ONE, IS ATTACHED AND OPEN.  ITS AREA TABLE   #
#         IS POINTED TO BY *NEWATBL*.                                  #
#         IT PRESENTLY CONTAINS:                                       #
#         -- THE GROUP-ID.                                             #
#         -- THE SUBSCHEMA NAME.                                       #
#         -- THE FDB CONTENTS.                                         #
#         -- THE FIT CONTENTS.                                         #
#     --- SUBSCHEMA CONTROL INFO (FOR THE 1ST SUBSCHEMA OF THE LIBRARY)#
#         IS IN BASED ARRAY *SCONTROL*.                                #
#     --- *SCHEMAFIT* IS SET TO THE FIT FOR THE PREVIOUS               #
#         SUBSCHEMA FILE.                                              #
#                                                                      #
#     THIS ROUTINE DOES THE FOLLOWING:                                 #
#                                                                      #
#     --- FREES UNNEEDED *TAREA* TABLES.                               #
#     --- ALLOCATES WORK BUFFER FOR *DE$OPSB*.                         #
#     --- CALLS *DE$OPSB* TO FIND THE DESIRED SUBSCHEMA WITHIN THE     #
#         SUBSCHEMA LIBRARY.  IT READS THE CONTROL INFORMATION         #
#         INTO *SCONTROL*.                                             #
#     --- SAVES THE WA OF THE SUBSCHEMA IN THE LOW-CORE                #
#         LOCATION *SBSCADD*.                                          #
#     --- SETS THE FLAG *SAMESBS* FOR *UNCUV*.                         #
#     --- CALLS *UNCUV* TO CLEAN UP THE PREVIOUS DIRECTIVE.            #
#     --- IF THE SAME SUBSCHEMA AS BEFORE, FREES THE NEW AREA TABLE    #
#         AND SETS UP TO USE THE PREVIOUS SUBSCHEMA AREA TABLE.        #
#     --- SETS *SCHEMAFIT* TO THE NEW SUBSCHEMA FOR THE USE BY OTHER   #
#         ROUTINES.                                                    #
#     --- IF THE SUBSCHEMA IS DIFFERENT THAN BEFORE, ISSUES AN         #
#         -INVOKE- TO CDCS.  IF RUNNING IN INTERACTIVE MODE, THE       #
#         INTERACTIVE -INVOKE- FUNCTION IS USED, AND THE CONTENTS OF   #
#         STATUS BLOCK ARE EXAMINED AND APPROPRIATE ACTION TAKEN.      #
#                                                                      #
#         FOR VERSION:                                                 #
#                                                                      #
#     --- THE SUBSCHEMA IS READ TO MAKE SURE THE AREA SPECIFIED        #
#         FOR THE CATALOG FILE IS OF THE PROPER FORMAT.                #
#         CHECKS MADE:                                                 #
#         - MUST BE SEQUENCE DISPLAY.                                  #
#         - FO MUST BE INDEXED.                                        #
#         - RT MUST BE CONTROL WORD.                                   #
#         - MUST BE EXACTLY TWO (2) ITEMS.                             #
#           - FIRST MUST BE PRIMARY KEY OF LENGTH 10 AN CHARS.         #
#           - SECOND MUST BE OF LENGTH (XMISSION LENGTH).              #
#     --- POINTERS FOR CATALOG FILE ARE SET UP (CATGORD, CATRORD,      #
#         CPAKREC, CPAKITEM).                                          #
#     --- *CATABLE* IS ALLOCATED AND SET UP.                           #
#     --- *CATAFIT* IS RE-INITIALIZED.                                 #
#                                                                      #
#         FOR CREATE/INVOKE/USE:                                       #
#                                                                      #
#     --- READS EACH AREA ENTRY HEADER FROM THE SUBSCHEMA AND          #
#         CALLS *BUILDAREATBL* TO BUILD THE RESPECTIVE AREA TABLE.     #
#     --- READS EACH RELATION SEARCH TABLE HEADER AND CALLS            #
#         *PROCRELENTRY* TO BUILD THE RESPECTIVE RELATION TABLE.       #
#     --- CLOSES THE SUBSCHEMA LIBRARY FILE VIA *DE$CLSB*.             #
#     --- OPENS THE SUBSCHEMA LIBRARY FILE CALLING *OPENM* DIRECTLY    #
#         AND POINTING TO *SCHEMAFIT*, SO *BGTABLE* CAN ACCESS THE     #
#         SUBSCHEMA LIB FILE WITH DIRECT CALLS TO *GET*.               #
#         *BGTABLE* IS CALLED FOR EACH AREA TABLE (EXCEPT THAT OF THE  #
#         SUBSCHEMA).                                                  #
#     --- FREES UNNEEDED BLOCKS AND CLOSES THE SUBSCHEMA LIBRARY FILE. #
#                                                                      #
#----------------------------------------------------------------------#
  
  
      P<AREA$TABLE> = NEWATBL;
      PREVCATMD = CDCSCAT;         # SAVE PRESENT CATALOG MODE SETTING #
      PREVCKSM = SBSCKSM;          # SAVE CURRENT SUBSCH CHECKSUM      #
      RC = 0; 
      IF USEDIR 
        AND NOT VERDIR                                                  000130
      THEN                         # IF -USE- OR -INVOKE-              #
        BEGIN 
        IF TAREA1 NQ 0
        THEN                       # IF FORMAT 3 OF -USE-              #
          BEGIN 
          RC = 1;                  # SET FLAG TO ISSUE DIAG            #
          CMM$FRF (TAREA1); 
          TAREA1 = 0; 
          END 
  
        IF TAREA4 NQ 0
        THEN                       # IF FORMAT 2 OF -USE-              #
          BEGIN 
          RC = 1;                  # SET FLAG TO ISSUE DIAG            #
          CMM$FRF (TAREA4); 
          TAREA4 = 0; 
          END 
  
        IF RC NQ 0
        THEN                       # IF FORMAT 2 OR 3 OF -USE-, ISSUE  #
                                   # INFORMATIVE DIAG AND THEN GO      #
                                   # ON AS IF FORMAT 1                 #
          BEGIN 
          DIAG (400); 
          END 
        END 
  
      IF TAREA2 NQ 0
      THEN                         # FREE TAREA2 IN ANY CASE           #
        BEGIN 
        CMM$FRF (TAREA2); 
        TAREA2 = 0; 
        END 
  
      P<FIT> = LOC(AT$AFITPOS);    # POSITION TO FIT FOR NEW SBSCH FILE#
      CLOSEM (FIT, $DET$, RA0);    # CLOSE FILE (DE$OPSB OPENS IT)     #
      P<SBSBUF> = CMM$ALF (DBUFSZ, 0, 0);  # GET BUFFER USED BY DE$OPSB#
      P<SBSFDB> = LOC(AT$AFDBPOS);  # POINT TO SUBSCH LIB FDB          #
                                   # POINT TO SUBSCHEMA NAME           #
      P<GIVEA> = P<AREA$TABLE> + AT$SBSCNAME[0];
      P<SCONTROL> = SCTLPTR;       # AREA FOR SUBSCH CONTROL INFO      #
                                   # FIND THE DESIRED SUBSCHEMA        #
      DE$OPSB (SBSLFN[0], GIVECHAR[0], SCONTROL, SBSBUF, DBUFSZ) ;
      IF DASTATE[0] NQ 0
      THEN                         # DIAGNOSE ERROR FROM DE$OPSB       #
        BEGIN 
        IF DASTATE[0] EQ 1
        THEN                       # SUBSCHEMA NOT FOUND               #
          BEGIN 
          DIAG (803, GIVEITEM[0], SBSFDBITEM[4]); 
          END 
  
        ELSE                       # SOME OTHER ERROR                  #
          BEGIN 
          DIAG (804, DASTATE[0], GIVEITEM[0]);
          END 
  
        ABORTUSE;                  # RELEASE EVERYTHING FROM THE USE   #
        RETURN; 
        END 
  
      AT$SCNAME = AT$NEXTFREE;     # SET POINTER TO SCHEMA NAME        #
      P<GIVEA> = P<AREA$TABLE> + AT$SCNAME;  # MOVE SCHEMA NAME        #
      GIVECHAR30 = SBCWSCHNAM30[0]; 
      AT$NEXTFREE = AT$NEXTFREE + 3;  # RESERVE 3 WORDS                #
      SBSCADD = SBCWSBADDR[0];     # SAVE SUBSCHEMA WORD ADDRESS       #
      IF (CDCSCAT OR CDCSDBM) 
        AND SBSCKSM EQ SBCWCHECKSUM[0]
        AND PREDBVN EQ DBVNAME     # SAME DATABASE VERSION NAME        #
      THEN                         # SAME SUBSCHEMA AS LAST USE        #
        BEGIN 
        SAMESBS = TRUE; 
        END 
  
      ELSE                         # DIFFERENT SUBSCHEMA               #
        BEGIN 
        SAMESBS = FALSE;
        END 
  
      UNCUV;                       # CLEAN UP PREVIOUS USE, IF ANY     #
      IF RC NQ 0
      THEN                         # ERROR IN *UNCUV*                  #
        BEGIN 
        ABORTUSE; 
        RETURN; 
        END 
  
                                   # IF THE NEW AND OLD SUBSCHEMAS     #
                                   # ARE THE SAME, THE NEW SUBSCHEMA   #
                                   # TABLE BUILT BY *USE* IS FREED, AND#
                                   # THE POINTER SET BACK TO THE       #
                                   # PREVIOUS ONE.  IF DIFFERENT, THE  #
                                   # OLD TABLES HAVE ALREADY BEEN      #
                                   # FREED BY *UNCUV*.                 #
      P<AREA$TABLE> = NEWATBL;     # SET POINTERS TO NEW AREA TABLE    #
      IF SAMESBS                   # IF SAME SUBSCHEMA                 #
        AND NOT SBSCHG             # AND SAME SUBSCHEMA FILE           #
      THEN
        BEGIN 
        CMM$FGR (AT$GROUPID);      # FREE NEW SUBSCHEMA TABLE          #
        P<AREA$TABLE> = AREATBLPTR LOR VERSBSCHPTR; 
        END 
  
      ELSE                         # DIFFERENT SUBSCHEMA               #
                                   # AND/OR DIFFERENT SUBSCHEMA FILE   #
        BEGIN 
        IF SBSCHG                  # IF DIFFERENT FILE,                #
          AND SAMESBS              # BUT NOT DIFFERENT SUBSCHEMA       #
        THEN
          BEGIN 
          REPSUBTBL;               # REPLACE AREA$TABLE ENTRY FOR      #
                                   # SUBSCHEMA                         #
          END 
  
                                   # SHRINK SUBSCHEMA TABLE TO THE     #
                                   # MINIMUM SIZE NEEDED               #
        CMM$SLF (P<AREA$TABLE>, MAXATBLSIZE - AT$NEXTFREE[0]);
        END 
  
      NEWATBL = 0;                 # INDICATE THAT THE SWITCH OF       #
                                   # SUBSCHEMAS IS COMPLETE            #
      IF VERDIR 
      THEN
        BEGIN 
        VERSBSCHPTR = P<AREA$TABLE>;  # SET VERSION POINTER            #
        CDCSCAT = TRUE;            # SET CDCS CATALOG MODE             #
        END 
  
      ELSE
        BEGIN 
        AREATBLPTR = P<AREA$TABLE>;  # SET CREATE/INV/USE PTR          #
        CDCSDBM = TRUE;            # SET CDCS DATABASE MODE            #
        MUSTXEX = FALSE;           # REMAINS FALSE UNTIL CORRECT AREA  #
                                   # FOUND IF THIS IS A -CREATE-       #
        END 
  
      P<SCHEMAFIT> = LOC (AT$AFITPOS);   # PTR TO SUBSCHEMA FIT        #
      SBSCKSM = SBCWCHECKSUM[0];   # SET CHECKSUM OF CURRENT SUBSCHEMA #
      IF NOT SAMESBS               # CHECK IF TO ISSUE *INVOKE*        #
      THEN                         # DIFFERENT SUBSCHEMA - DO IT       #
        BEGIN 
                                   # POINT TO SUBSCHEMA NAME           #
        P<GIVEA> = P<AREA$TABLE> + AT$SBSCNAME[0];
  
        IF P<DBSTAT> EQ 0 
        THEN                       # ALLOCATE CDCS STATUS BLOCK        #
          BEGIN 
          P<DBSTAT> = CMM$ALF (STATBLKSZ, 0, 0);
          END 
  
        IF (NOT BATCHMD)
          AND TERMINAL NQ 0 
        THEN                       # INTERACTIVE USER AT TERMINAL      #
          BEGIN 
          RC = RETRYCODE;          # SET LOOP CONTROL                  #
          FOR DUMMY1 = DUMMY1 
            WHILE RC EQ RETRYCODE 
          DO
            BEGIN 
                                   # ISSUE CDCS INTERACTIVE INVOKE     #
IF CDCSUP THEN
            DB$INQV ( GIVECHAR[0], SBCWSCHNAM30[0], USERID, 
                      SBSCKSM, DBSTAT, DBVNAME, 0 );
            IF DBSERRCODE[0] EQ PFWAITAREA
              OR DBSERRCODE[0] EQ PFWAITPRLIB 
              OR DBSERRCODE[0] EQ WAITMEMORY
            THEN                   # CDCS PASSED BACK A RETURN         #
                                   # CODE TO INDICATE THAT IT COULD NOT#
                                   # COMPLETE THE REQUEST BECAUSE THERE#
                                   # IS SOMETHING IT HAS TO WAIT FOR.  #
                                   # QU NOW ASKS THE INTERACTIVE USER  #
                                   # IF HE/SHE WANTS QU TO TRY THE     #
                                   # REQUEST AGAIN OR TO ABORT         #
              BEGIN 
              DIAG904;             # ISSUE DIAG 904                    #
              DIAG (1018);         # REQUEST -Y- OR -N-                #
              READ (RETRYANS, WORD, 1, RC); 
              IF RETRYANS EQ "Y"
              THEN                 # USER INDICATED YES                #
                BEGIN 
                RC = RETRYCODE;    # INDICATE ANOTHER TRY IN ORDER     #
                TEST DUMMY1;       # START LOOP AGAIN                  #
                END 
  
              ELSE                 # USER INDICATED NO                 #
                BEGIN 
                RC = ERRFOUNDCODE; # INDICATE ERROR OCCURRED           #
                DBSERRCODE[0] = 0; # CLEAR ERROR FIELD                 #
                TEST DUMMY1;       # GO ON TO ABORT                    #
                END 
              END 
  
            IF DBSERRCODE[0] NQ 0 
            THEN                   # FATAL CDCS ERROR                  #
              BEGIN 
              IF DBSERRCODE[0] EQ CDCSUNAVAIL 
              THEN                 # CDCS NOT AVAILABLE                #
                BEGIN 
                                   # ISSUE DIAG WITH SUBSCHEMA NAME    #
                DIAG (904, DBSERRCODE[0], GIVECHAR[0], "INVOKE"); 
                                   # PUT OUT OUR OWN MESSAGE           #
                WRITEBL (" CDCS NOT AVAILABLE", 19);
                END 
  
              ELSE                 # ANY OTHER CDCS ERROR              #
                BEGIN 
                DIAG904;           # ISSUE DIAG 904                    #
                END 
  
              RC = ERRFOUNDCODE;   # INDICATE ERROR OCCURRED           #
              DBSERRCODE[0] = 0;   # CLEAR ERROR FIELD                 #
              TEST DUMMY1;         # GO ON TO ABORT                    #
              END 
  
            INVOKED = TRUE;        # INDICATE -INVOKE- IS IN EFFECT    #
            RC = INVOKEOKCODE;     # INDICATE ERROR-FREE               #
            END 
  
          IF RC NQ INVOKEOKCODE 
          THEN                     # IF ERROR ON -INVOKE-              #
            BEGIN 
            ABORTUSE; 
            RETURN; 
            END 
          END 
  
        ELSE                       # NON-INTERACTIVE QU SESSION        #
          BEGIN 
                                   # ISSUE NORMAL -INVOKE-             #
IF CDCSUP THEN
          DB$INVV ( GIVECHAR[0], SBCWSCHNAM30[0], USERID, 
                    SBSCKSM, DBVNAME, 0 );
          IF DBSERRCODE EQ CDCSUNAVAIL   # IF CDCS NOT LOADED          #
          THEN
            BEGIN                  # WRITE DIAGNOSTIC                  #
            DIAG (904, DBSERRCODE[0], GIVECHAR[0], "INVOKE"); 
            WRITEBL (" CDCS NOT AVAILABLE", 19);
            ABORTUSE;              # FREE MEM, CLOSE FILES, AND ABORT  #
            RETURN; 
            END 
          INVOKED = TRUE;          # INDICATE -INVOKE- IS IN EFFECT    #
          END 
  
                                   # SET CDCS UP WITH STATUS BLOCK     #
IF CDCSUP THEN
        DB$DBST (DBSTAT, STATBLKSZ);
        END 
  
      IF VERDIR 
      THEN
  
#     --- VERSION PROCESSING ---                                       #
#                                                                      #
#     THE SUBSCHEMA IS READ IN ORDER TO MAKE SURE THE AREA SPECIFIED   #
#     FOR THE CATALOG FILE IS OF THE PROPER FORMAT.  THEN THE ARRAY    #
#     *CATABLE* IS SET UP.                                             #
  
        BEGIN 
        WAKEY = SBCWRLMLSTAD[0];   # SEARCH REALM LIST FOR THE AREA    #
        SIZE = SBCWNUMAREAS[0];    # NUMBER OF AREAS IN SUBSCHEMA      #
        FINISHED = FALSE;          # LOOP CONTROL                      #
        FOR DUMMY1 = 0
          WHILE NOT FINISHED
        DO
          BEGIN 
                                   # READ A REALM LIST ENTRY           #
          DE$GTSB (RLMLIST, DFSBRLMLST, WAKEY); 
          P<GIVEA> = TAREA1;       # COMPARE AREA NAMES                #
          IF   REALMLISTNME[0] NQ GIVEITEM[0] 
            OR REALMLISTNME[1] NQ GIVEITEM[1] 
            OR REALMLISTNME[2] NQ GIVEITEM[2] 
          THEN                     # NOT THE DESIRED AREA              #
            BEGIN 
            SIZE = SIZE - 1;       # UPDATE AREAS REMAINING            #
            IF SIZE EQ 0
            THEN                   # AREA NOT FOUND IN SUBSCHEMA       #
              BEGIN 
              P<GETA> = P<AREA$TABLE> + AT$SBSCNAME[0]; 
              DIAG (409, GIVEITEM[0], GETITEM[0]);
              ABORTUSE; 
              RETURN; 
              END 
  
                                   # ADVANCE READ ADDRESS              #
            WAKEY = WAKEY + DFSBRLMLST; 
            TEST DUMMY1;           # REPEAT LOOP                       #
            END 
  
          FINISHED = TRUE;         # DESIRED AREA FOUND                #
          END 
  
                                   # READ AREA ENTRY HEADER            #
        DE$GTSB (AREAHEAD, DFSBARLG, REALMADR[0]);
                                   # READ DATA CONTROL ENTRY HEADER    #
        DE$GTSB (DATACTLHEAD, DFSBDCHLG, SBARDCONTRLA[0]);
        IF SBDCSEQOPT[0] NQ 0 
        THEN                       # AREA IS NOT SEQUENCE DISPLAY      #
          BEGIN 
          DIAG (410, GIVEITEM[0]);
          ABORTUSE; 
          RETURN; 
          END 
  
                                   # ALLOCATE SPACE TO READ FIT        #
        P<FIT> = CMM$ALF (SBDCFITLENG[0], 0, 0);
        RC = 0;                    # SET NO ERROR                      #
                                   # READ FIT FROM DATA CONTROL ENTRY  #
        DE$GTSB (FIT, SBDCFITLENG[0], SBARDCONTRLA[0] + SBDCFITPTR[0]); 
        IF FITFO[0] NQ FOIS        # FILE ORGANIZATION NOT INDEXED     #
          OR FITRT[0] NQ RTW       # RECORD TYPE NOT CONTROL WORD      #
        THEN
          BEGIN 
          RC = 1;                  # SET ERROR                         #
          END 
  
        SIZE = FITMRL[0];          # EXTRACT MAXIMUM RECORD LENGTH     #
        CMM$FRF (P<FIT>);          # FREE FIT SPACE                    #
        IF RC NQ 0
        THEN                       # ERROR DETECTED ABOVE              #
          BEGIN 
          DIAG (411, GIVEITEM[0]);
          ABORTUSE; 
          RETURN; 
          END 
  
                                   # READ RECORD LIST ENTRY            #
        DE$GTSB (RECLISTHEAD, 
                 DFSBRECLST,
                 SBCWRLMLSTAD[0] + REALMRECLIST[0]);
                                   # READ RECORD ENTRY HEADER          #
        DE$GTSB (RECHEAD, DFSBRCLG, RECLISTLADR[0]);
        IF REALMRECLEN[0] NQ 1     # MORE THAN ONE RECORD              #
          OR SBRECNBRITMS[0] NQ 2  # NOT EXACTLY TWO ITEMS             #
        THEN
          BEGIN 
          DIAG (412, GIVEITEM[0]);
          ABORTUSE; 
          RETURN; 
          END 
  
                                   # SAVE WA OF FIRST ITEM ENTRY       #
        WAKEY2 = RECLISTLADR[0] + SBRECNXITEMP[0];
                                   # READ FIRST ITEM ENTRY HEADER      #
        DE$GTSB (ITEMHEAD, DFSBITMLG, WAKEY2);
        IF NOT SBITMKEYFLG[0]      # NOT PRIMARY KEY                   #
          OR SBITMDBCLASS[0] NQ ALPHANUMERIC
          OR SBITMUSESIZE[0] NQ 10 # SIZE NOT = 10 AN CHARS            #
        THEN
          BEGIN 
          DIAG (412, GIVEITEM[0]);
          ABORTUSE; 
          RETURN; 
          END 
  
                                   # READ SECOND ITEM ENTRY HEADER     #
        DE$GTSB (ITEMHEAD, DFSBITMLG, WAKEY2 + SBITMNEXTP[0]);
        IF SBITMDBCLASS[0] NQ ALPHANUMERIC
          OR SBITMUSESIZE[0] NQ MXTRNLG 
        THEN                       # SIZE NOT = (MAX TRANSMISSION LTH) #
                                   # ALPHANUMERIC CHARACTERS           #
          BEGIN 
          DIAG (412, GIVEITEM[0]);
          ABORTUSE; 
          RETURN; 
          END 
  
        CATGORD = SBARORDINAL[0];  # SET AREA ORDINAL                  #
        CATRORD = SBRECORDINAL[0]; # SET RECORD ORDINAL                #
                                   # SET ITEM AND RECORD ORDINAL       #
        CPAKREC[0] = SBRECORDINAL[0]; 
        CPAKITEM[0] = 1;
                                   # ALLOCATE CATALOG TABLE            #
        P<CATABLE> = CMM$ALF (10, 0, 0);
        CATBLPTR = P<CATABLE>;     # SET POINTER TO CATALOG TABLE      #
                                   # SET AREA NAME LENGTH              #
        CAT$LENG[0] = SBARLENGCHAR[0];
                                   # STORE AREA (CATALOG) NAME         #
        C<0,SBARLENGCHAR[0]>CAT$NAM[0]
          = C<0,SBARLENGCHAR[0]>GIVECHAR[0];
        P<FIT> = LOC (CATAFIT);    # SET UP CATALOG FIT                #
        C<0,7>FITLFN = "ZZZZZQ3";  # SET CATALOG LFN                   #
        FITMRL[0] = SIZE;          # SET MAXIMUM RECORD LENGTH         #
        FITOC[0] = 0;              # INDICATE NEVER OPENED             #
        FITPD[0] = 0;              # PROCESSING DIRECTION              #
        FITORG = TRUE;             # FORCE ORG = NEW                   #
        PFCATAL = TRUE;            # CATALOG FILE IS A PERMANENT FILE  #
        CMM$FRF (TAREA1);          # FREE *TAREA1*                     #
        TAREA1 = 0; 
        RETURN;                    # ALL DONE FOR -VERSION-            #
        END 
  
  
#     --- CREATE/INVOKE/USE PROCESSING ---                             #
#                                                                      #
#     ALL AREAS AND THEN ALL RELATIONS SPECIFIED IN THE SUBSCHEMA      #
#     ARE PICKED UP AND TABLES BUILT.  IF THIS IS A *USE* DIRECTIVE,   #
#     ALL AREAS AND RELATIONS ARE PROCESSED.  IF *CREATE*,             #
#     *BUILDAREATBL* COMPARES THE SUBSCHEMA AREA ENTRIES WITH THE      #
#     *TAREA1* CONTENTS, IN ORDER TO PROCESS ONLY THE AREA SPECIFIED   #
#     ON THE *CREATE*.                                                 #
  
                                   # SET RELATIVE WA OF 1ST AREA ENTRY #
      WAKEY2 = SBCWFRSTAREA[0];    # SET REL WA OF 1ST AREA ENTRY      #
      FOR DUMMY = 0 
        WHILE WAKEY2 NQ 0 
      DO
        BEGIN 
                                   # READ NEXT AREA ENTRY FROM SUBSCH  #
        DE$GTSB (AREAHEAD, DFSBARLG, WAKEY2); 
        BUILDAREATBL;              # BUILD AREA TABLE                  #
        IF RC NQ 0
        THEN                       # IF ERROR RETURNED                 #
          BEGIN 
          ABORTUSE; 
          RETURN; 
          END 
  
        WAKEY2 = SBARNEXT[0];      # RELATIVE WA OF NEXT AREA ENTRY    #
        END 
  
      IF NOT USEDIR                # IF *CREATE* DIRECTIVE             #
        AND NOT VERDIR                                                  000150
        AND NOT MUSTXEX            # AND IF NO AREA WAS PROCESSED      #
      THEN
        BEGIN 
        P<GETA> = TAREA1; 
        DIAG (862, GETA);          # AREA NOT FOUND ON *CREATE*        #
        ABORTUSE; 
        RETURN; 
        END 
  
  
#     --- START OF RELATION LOOP ---                                   #
  
      CURPATHCNT = 1;              # INITIALIZE PATH COUNTER           #
      B<1,1>CURPATHFLG = 1;        # INITIALIZE PATH BIT FLAG          #
      WAKEY2 = SBCWFRSTRELA[0];    # SET REL WA OF 1ST RELATION ENTRY  #
      FOR DUMMY = 0 
        WHILE WAKEY2 NQ 0 
      DO
        BEGIN 
                             # READ NEXT RELATION SEARCH TABLE ENTRY   #
        DE$GTSB (RELHEAD, DFSBRLHLG, WAKEY2); 
        PROCRELENTRY;              # BUILD RELATION TABLE              #
        IF RC NQ 0
        THEN                       # IF ERROR RETURNED                 #
          BEGIN 
          ABORTUSE; 
          RETURN; 
          END 
  
        CURPATHCNT = CURPATHCNT + 1;  # UPDATE BIT NO. FOR PATH FLAG   #
        CURPATHFLG = 0; 
        B<CURPATHCNT,1>CURPATHFLG = 1;  # SET NEXT FLAG BIT            #
        IF RSTNXTRSTPTR[0] NQ 0 
        THEN                       # POINT TO NEXT RELATION ENTRY      #
          BEGIN 
          WAKEY2 = WAKEY2 + RSTNXTRSTPTR[0];
          END 
  
        ELSE                       # SET TO EXIT LOOP                  #
          BEGIN 
          WAKEY2 = 0; 
          END 
  
        END 
  
  
  
#     --- BUILD BACKGROUND TABLE FOR EACH AREA ---                     #
  
      DE$CLSB;                     # CLOSE SUBSCHEMA LIB VIA DIRECTORY #
                                   # ACCESS ROUTINES                   #
      P<AREA$TABLE> = AREATBLPTR;  # POSITION TO SUBSCHEMA AREA TABLE  #
      OPENM (SCHEMAFIT, $INPUT$, RA0);  # OPEN SUBSCH FILE WITH OUR FIT#
      RC = SCHFITES[0];            # ERROR STATUS                      #
      IF RC NQ 0
      THEN                         # IF ERROR ON OPEN                  #
        BEGIN 
        DIAG (903, RC, SCHEMAFIT);
        ABORTUSE; 
        RETURN; 
        END 
  
      FOR DUMMY1 = 0               # LOOP THRU ALL AREAS               #
        WHILE AT$FORWARD[0] NQ 0
      DO
        BEGIN 
        P<AREA$TABLE> = AT$FORWARD[0];
        TAREA4X = P<AREA$TABLE>;   # SET POINTER FOR *BGTABLE*         #
        BGTABLE;                   # GO BUILD BACKGROUND TABLE         #
                                   # SHRINK AREA TABLE TO SIZE NEEDED  #
        CMM$SLF (P<AREA$TABLE>, MAXATBLSIZE - AT$NEXTFREE); 
        END 
  
      CLOSEM (SCHEMAFIT, $DET$, RA0);  # CLOSE SUBSCHEMA LIBRARY FILE  #
      CMM$FRF (SCTLPTR);           # FREE ARRAY WITH SUBSCH CTL INFO   #
      SCTLPTR = 0;
      CMM$FRF (P<SBSBUF>);         # FREE CRM BUFFER                   #
      P<SBSBUF> = 0;               # INDICATE THAT BUFFER IS FREED     #
      IF MUSTXEX
      THEN                         # IT WAS A *CREATE* - GO TO (50,0)  #
        BEGIN 
        INDEX = 1;
        CROPEN = TRUE;             # SIGNAL 1ST OPEN MUST BE FOR OUTPUT#
        END 
  
      RETURN; 
      END                          # --- USECDCS ---                   #
      TERM
